diff options
Diffstat (limited to 'contrib/interface')
31 files changed, 11697 insertions, 0 deletions
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT new file mode 100644 index 00000000..2fb11c6b --- /dev/null +++ b/contrib/interface/COPYRIGHT @@ -0,0 +1,19 @@ +(*****************************************************************************) +(* *) +(* Coq support for the Pcoq Graphical Interface of Coq *) +(* *) +(* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *) +(* *) +(*****************************************************************************) + +The current directory contrib/interface implements Coq support for the +Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot +with contributions from Loïc Pottier and Laurence Rideau. + +The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq) +is developed by the Lemme team at INRIA Sophia-Antipolis (see +http://www-sop.inria.fr/lemme) + +The files of the current directory are distributed under the terms of +the GNU Lesser General Public License Version 2.1. + diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli new file mode 100644 index 00000000..61d0d5a3 --- /dev/null +++ b/contrib/interface/ascent.mli @@ -0,0 +1,784 @@ +type ct_AST = + CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT + | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING + | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE + | CT_astnode of ct_ID * ct_AST_LIST + | CT_astpath of ct_ID_LIST + | CT_astslam of ct_ID_OPT * ct_AST +and ct_AST_LIST = + CT_ast_list of ct_AST list +and ct_BINARY = + CT_binary of int +and ct_BINDER = + CT_coerce_DEF_to_BINDER of ct_DEF + | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA + | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA +and ct_BINDER_LIST = + CT_binder_list of ct_BINDER list +and ct_BINDER_NE_LIST = + CT_binder_ne_list of ct_BINDER * ct_BINDER list +and ct_BINDING = + CT_binding of ct_ID_OR_INT * ct_FORMULA +and ct_BINDING_LIST = + CT_binding_list of ct_BINDING list +and ct_BOOL = + CT_false + | CT_true +and ct_CASE = + CT_case of string +and ct_CLAUSE = + CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT +and ct_COERCION_OPT = + CT_coerce_NONE_to_COERCION_OPT of ct_NONE + | CT_coercion_atm +and ct_COFIXTAC = + CT_cofixtac of ct_ID * ct_FORMULA +and ct_COFIX_REC = + CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA +and ct_COFIX_REC_LIST = + CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list +and ct_COFIX_TAC_LIST = + CT_cofix_tac_list of ct_COFIXTAC list +and ct_COMMAND = + CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST + | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD + | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN + | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL + | CT_abort of ct_ID_OPT_OR_ALL + | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST + | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_LIST + | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_addpath of ct_STRING * ct_ID_OPT + | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST + | CT_bind_scope of ct_ID * ct_ID_NE_LIST + | CT_cd of ct_STRING_OPT + | CT_check of ct_FORMULA + | CT_class of ct_ID + | CT_close_scope of ct_ID + | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID + | CT_cofix_decl of ct_COFIX_REC_LIST + | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT + | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR + | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT + | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT + | CT_delim_scope of ct_ID * ct_ID + | CT_delpath of ct_STRING + | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE + | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID + | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE + | CT_explain_proof of ct_INT_LIST + | CT_explain_prooftree of ct_INT_LIST + | CT_export_id of ct_ID_NE_LIST + | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST + | CT_extraction of ct_ID_OPT + | CT_fix_decl of ct_FIX_REC_LIST + | CT_focus of ct_INT_OPT + | CT_go of ct_INT_OR_LOCN + | CT_guarded + | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM + | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST + | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_implicits of ct_ID * ct_ID_LIST_OPT + | CT_import_id of ct_ID_NE_LIST + | CT_ind_scheme of ct_SCHEME_SPEC_LIST + | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT + | CT_inline of ct_ID_NE_LIST + | CT_inspect of ct_INT + | CT_kill_node of ct_INT + | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING + | CT_local_close_scope of ct_ID + | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT + | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST + | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT + | CT_local_open_scope of ct_ID + | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST + | CT_locate of ct_ID + | CT_locate_file of ct_STRING + | CT_locate_lib of ct_ID + | CT_locate_notation of ct_STRING + | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST + | CT_ml_add_path of ct_STRING + | CT_ml_declare_modules of ct_STRING_NE_LIST + | CT_ml_print_modules + | CT_ml_print_path + | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR + | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT + | CT_no_inline of ct_ID_NE_LIST + | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE + | CT_opaque of ct_ID_NE_LIST + | CT_open_scope of ct_ID + | CT_print + | CT_print_about of ct_ID + | CT_print_all + | CT_print_classes + | CT_print_coercions + | CT_print_grammar of ct_GRAMMAR + | CT_print_graph + | CT_print_hint of ct_ID_OPT + | CT_print_hintdb of ct_ID_OR_STAR + | CT_print_id of ct_ID + | CT_print_implicit of ct_ID + | CT_print_loadpath + | CT_print_module of ct_ID + | CT_print_module_type of ct_ID + | CT_print_modules + | CT_print_natural of ct_ID + | CT_print_natural_feature of ct_NATURAL_FEATURE + | CT_print_opaqueid of ct_ID + | CT_print_path of ct_ID * ct_ID + | CT_print_proof of ct_ID + | CT_print_scope of ct_ID + | CT_print_scopes + | CT_print_section of ct_ID + | CT_print_states + | CT_print_tables + | CT_print_universes of ct_STRING_OPT + | CT_print_visibility of ct_ID_OPT + | CT_proof of ct_FORMULA + | CT_proof_no_op + | CT_proof_with of ct_TACTIC_COM + | CT_pwd + | CT_quit + | CT_read_module of ct_ID + | CT_rec_ml_add_path of ct_STRING + | CT_recaddpath of ct_STRING * ct_ID_OPT + | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST + | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING + | CT_reserve of ct_ID_NE_LIST * ct_FORMULA + | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST + | CT_reset of ct_ID + | CT_reset_section of ct_ID + | CT_restart + | CT_restore_state of ct_ID + | CT_resume of ct_ID_OPT + | CT_save of ct_THM_OPT * ct_ID_OPT + | CT_scomments of ct_SCOMMENT_CONTENT_LIST + | CT_search of ct_ID * ct_IN_OR_OUT_MODULES + | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES + | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_section_end of ct_ID + | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND + | CT_set_natural of ct_ID + | CT_set_natural_default + | CT_set_option of ct_TABLE + | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE + | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST + | CT_sethyp of ct_INT + | CT_setundo of ct_INT + | CT_show_existentials + | CT_show_goal of ct_INT_OPT + | CT_show_implicit of ct_INT + | CT_show_intro + | CT_show_intros + | CT_show_node + | CT_show_proof + | CT_show_proofs + | CT_show_script + | CT_show_tree + | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT + | CT_suspend + | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT + | CT_tactic_definition of ct_TAC_DEF_NE_LIST + | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT + | CT_time of ct_COMMAND + | CT_transparent of ct_ID_NE_LIST + | CT_undo of ct_INT_OPT + | CT_unfocus + | CT_unset_option of ct_TABLE + | CT_unsethyp + | CT_unsetundo + | CT_user_vernac of ct_ID * ct_VARG_LIST + | CT_variable of ct_VAR * ct_BINDER_NE_LIST + | CT_write_module of ct_ID * ct_STRING_OPT +and ct_COMMAND_LIST = + CT_command_list of ct_COMMAND * ct_COMMAND list +and ct_COMMENT = + CT_comment of string +and ct_COMMENT_S = + CT_comment_s of ct_COMMENT list +and ct_CONSTR = + CT_constr of ct_ID * ct_FORMULA + | CT_constr_coercion of ct_ID * ct_FORMULA +and ct_CONSTR_LIST = + CT_constr_list of ct_CONSTR list +and ct_CONTEXT_HYP_LIST = + CT_context_hyp_list of ct_PREMISE_PATTERN list +and ct_CONTEXT_PATTERN = + CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA + | CT_context of ct_ID_OPT * ct_FORMULA +and ct_CONTEXT_RULE = + CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM + | CT_def_context_rule of ct_TACTIC_COM +and ct_CONVERSION_FLAG = + CT_beta + | CT_delta + | CT_evar + | CT_iota + | CT_zeta +and ct_CONVERSION_FLAG_LIST = + CT_conversion_flag_list of ct_CONVERSION_FLAG list +and ct_CONV_SET = + CT_unf of ct_ID list + | CT_unfbut of ct_ID list +and ct_CO_IND = + CT_co_ind of string +and ct_DECL_NOTATION_OPT = + CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE + | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT +and ct_DEF = + CT_def of ct_ID_OPT * ct_FORMULA +and ct_DEFN = + CT_defn of string +and ct_DEFN_OR_THM = + CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN + | CT_coerce_THM_to_DEFN_OR_THM of ct_THM +and ct_DEF_BODY = + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN + | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD + | CT_type_of of ct_FORMULA +and ct_DEF_BODY_OPT = + CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY + | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT +and ct_DEP = + CT_dep of string +and ct_DESTRUCTING = + CT_coerce_NONE_to_DESTRUCTING of ct_NONE + | CT_destructing +and ct_DESTRUCT_LOCATION = + CT_conclusion_location + | CT_discardable_hypothesis + | CT_hypothesis_location +and ct_DOTDOT_OPT = + CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE + | CT_dotdot +and ct_EQN = + CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA +and ct_EQN_LIST = + CT_eqn_list of ct_EQN list +and ct_EVAL_CMD = + CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA +and ct_FIXTAC = + CT_fixtac of ct_ID * ct_INT * ct_FORMULA +and ct_FIX_BINDER = + CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC + | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA +and ct_FIX_BINDER_LIST = + CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list +and ct_FIX_REC = + CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT * + ct_FORMULA * ct_FORMULA +and ct_FIX_REC_LIST = + CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list +and ct_FIX_TAC_LIST = + CT_fix_tac_list of ct_FIXTAC list +and ct_FORMULA = + CT_coerce_BINARY_to_FORMULA of ct_BINARY + | CT_coerce_ID_to_FORMULA of ct_ID + | CT_coerce_NUM_to_FORMULA of ct_NUM + | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE + | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA + | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST + | CT_arrowc of ct_FORMULA * ct_FORMULA + | CT_bang of ct_FORMULA + | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST + | CT_cofixc of ct_ID * ct_COFIX_REC_LIST + | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST + | CT_existvarc + | CT_fixc of ct_ID * ct_FIX_BINDER_LIST + | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA + | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA + | CT_labelled_arg of ct_ID * ct_FORMULA + | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA + | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA + | CT_letin of ct_DEF * ct_FORMULA + | CT_notation of ct_STRING * ct_FORMULA_LIST + | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA + | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA + | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST +and ct_FORMULA_LIST = + CT_formula_list of ct_FORMULA list +and ct_FORMULA_NE_LIST = + CT_formula_ne_list of ct_FORMULA * ct_FORMULA list +and ct_FORMULA_OPT = + CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA + | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT +and ct_FORMULA_OR_INT = + CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA + | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT +and ct_GRAMMAR = + CT_grammar_none +and ct_HYP_LOCATION = + CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD + | CT_intype of ct_ID * ct_INT_LIST + | CT_invalue of ct_ID * ct_INT_LIST +and ct_HYP_LOCATION_LIST_OR_STAR = + CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR + | CT_hyp_location_list of ct_HYP_LOCATION list +and ct_ID = + CT_ident of string + | CT_metac of ct_INT + | CT_metaid of string +and ct_IDENTITY_OPT = + CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE + | CT_identity +and ct_ID_LIST = + CT_id_list of ct_ID list +and ct_ID_LIST_LIST = + CT_id_list_list of ct_ID_LIST list +and ct_ID_LIST_OPT = + CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST + | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE +and ct_ID_NE_LIST = + CT_id_ne_list of ct_ID * ct_ID list +and ct_ID_NE_LIST_OR_STAR = + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST + | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR +and ct_ID_NE_LIST_OR_STRING = + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST + | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING +and ct_ID_OPT = + CT_coerce_ID_to_ID_OPT of ct_ID + | CT_coerce_NONE_to_ID_OPT of ct_NONE +and ct_ID_OPT_LIST = + CT_id_opt_list of ct_ID_OPT list +and ct_ID_OPT_NE_LIST = + CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list +and ct_ID_OPT_OR_ALL = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT + | CT_all +and ct_ID_OR_INT = + CT_coerce_ID_to_ID_OR_INT of ct_ID + | CT_coerce_INT_to_ID_OR_INT of ct_INT +and ct_ID_OR_INT_OPT = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT + | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT + | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT +and ct_ID_OR_STAR = + CT_coerce_ID_to_ID_OR_STAR of ct_ID + | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR +and ct_ID_OR_STRING = + CT_coerce_ID_to_ID_OR_STRING of ct_ID + | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING +and ct_ID_OR_STRING_NE_LIST = + CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list +and ct_IMPEXP = + CT_coerce_NONE_to_IMPEXP of ct_NONE + | CT_export + | CT_import +and ct_IND_SPEC = + CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT +and ct_IND_SPEC_LIST = + CT_ind_spec_list of ct_IND_SPEC list +and ct_INT = + CT_int of int +and ct_INTRO_PATT = + CT_coerce_ID_to_INTRO_PATT of ct_ID + | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list +and ct_INTRO_PATT_LIST = + CT_intro_patt_list of ct_INTRO_PATT list +and ct_INTRO_PATT_OPT = + CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT + | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT +and ct_INT_LIST = + CT_int_list of ct_INT list +and ct_INT_NE_LIST = + CT_int_ne_list of ct_INT * ct_INT list +and ct_INT_OPT = + CT_coerce_INT_to_INT_OPT of ct_INT + | CT_coerce_NONE_to_INT_OPT of ct_NONE +and ct_INT_OR_LOCN = + CT_coerce_INT_to_INT_OR_LOCN of ct_INT + | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN +and ct_INT_OR_NEXT = + CT_coerce_INT_to_INT_OR_NEXT of ct_INT + | CT_next_level +and ct_INV_TYPE = + CT_inv_clear + | CT_inv_regular + | CT_inv_simple +and ct_IN_OR_OUT_MODULES = + CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE + | CT_in_modules of ct_ID_NE_LIST + | CT_out_modules of ct_ID_NE_LIST +and ct_LET_CLAUSE = + CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE +and ct_LET_CLAUSES = + CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list +and ct_LET_VALUE = + CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY + | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM +and ct_LOCAL_OPT = + CT_coerce_NONE_to_LOCAL_OPT of ct_NONE + | CT_local +and ct_LOCN = + CT_locn of string +and ct_MATCHED_FORMULA = + CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA + | CT_formula_as of ct_FORMULA * ct_ID_OPT + | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA + | CT_formula_in of ct_FORMULA * ct_FORMULA +and ct_MATCHED_FORMULA_NE_LIST = + CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list +and ct_MATCH_PATTERN = + CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT + | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM + | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST + | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT + | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN + | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST +and ct_MATCH_PATTERN_LIST = + CT_match_pattern_list of ct_MATCH_PATTERN list +and ct_MATCH_PATTERN_NE_LIST = + CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list +and ct_MATCH_TAC_RULE = + CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE +and ct_MATCH_TAC_RULES = + CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list +and ct_MODIFIER = + CT_entry_type of ct_ID * ct_ID + | CT_format of ct_STRING + | CT_lefta + | CT_nona + | CT_only_parsing + | CT_righta + | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT + | CT_set_level of ct_INT +and ct_MODIFIER_LIST = + CT_modifier_list of ct_MODIFIER list +and ct_MODULE_BINDER = + CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE +and ct_MODULE_BINDER_LIST = + CT_module_binder_list of ct_MODULE_BINDER list +and ct_MODULE_EXPR = + CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT + | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR +and ct_MODULE_TYPE = + CT_coerce_ID_to_MODULE_TYPE of ct_ID + | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID * ct_FORMULA + | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID * ct_ID +and ct_MODULE_TYPE_CHECK = + CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT + | CT_only_check of ct_MODULE_TYPE +and ct_MODULE_TYPE_OPT = + CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT + | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE +and ct_NATURAL_FEATURE = + CT_contractible + | CT_implicit + | CT_nat_transparent +and ct_NONE = + CT_none +and ct_NUM = + CT_int_encapsulator of string +and ct_NUM_TYPE = + CT_num_type of string +and ct_OMEGA_FEATURE = + CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING + | CT_flag_action + | CT_flag_system + | CT_flag_time +and ct_OMEGA_MODE = + CT_set + | CT_switch + | CT_unset +and ct_ORIENTATION = + CT_lr + | CT_rl +and ct_PATTERN = + CT_pattern_occ of ct_INT_LIST * ct_FORMULA +and ct_PATTERN_NE_LIST = + CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list +and ct_PATTERN_OPT = + CT_coerce_NONE_to_PATTERN_OPT of ct_NONE + | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN +and ct_PREMISE = + CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA + | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA + | CT_premise of ct_ID * ct_FORMULA +and ct_PREMISES_LIST = + CT_premises_list of ct_PREMISE list +and ct_PREMISE_PATTERN = + CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN +and ct_PROOF_SCRIPT = + CT_proof_script of ct_COMMAND list +and ct_RECCONSTR = + CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT + | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT + | CT_recconstr of ct_ID_OPT * ct_FORMULA + | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA +and ct_RECCONSTR_LIST = + CT_recconstr_list of ct_RECCONSTR list +and ct_REC_TACTIC_FUN = + CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM +and ct_REC_TACTIC_FUN_LIST = + CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list +and ct_RED_COM = + CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET + | CT_fold of ct_FORMULA_LIST + | CT_hnf + | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET + | CT_pattern of ct_PATTERN_NE_LIST + | CT_red + | CT_simpl of ct_PATTERN_OPT + | CT_unfold of ct_UNFOLD_NE_LIST +and ct_RETURN_INFO = + CT_coerce_NONE_to_RETURN_INFO of ct_NONE + | CT_as_and_return of ct_ID_OPT * ct_FORMULA + | CT_return of ct_FORMULA +and ct_RULE = + CT_rule of ct_PREMISES_LIST * ct_FORMULA +and ct_RULE_LIST = + CT_rule_list of ct_RULE list +and ct_SCHEME_SPEC = + CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE +and ct_SCHEME_SPEC_LIST = + CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list +and ct_SCOMMENT_CONTENT = + CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA + | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING +and ct_SCOMMENT_CONTENT_LIST = + CT_scomment_content_list of ct_SCOMMENT_CONTENT list +and ct_SECTION_BEGIN = + CT_section of ct_ID +and ct_SECTION_BODY = + CT_section_body of ct_COMMAND list +and ct_SIGNED_INT = + CT_coerce_INT_to_SIGNED_INT of ct_INT + | CT_minus of ct_INT +and ct_SIGNED_INT_LIST = + CT_signed_int_list of ct_SIGNED_INT list +and ct_SINGLE_OPTION_VALUE = + CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT + | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING +and ct_SORT_TYPE = + CT_sortc of string +and ct_SPEC_LIST = + CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST + | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST +and ct_SPEC_OPT = + CT_coerce_NONE_to_SPEC_OPT of ct_NONE + | CT_spec +and ct_STAR = + CT_star +and ct_STAR_OPT = + CT_coerce_NONE_to_STAR_OPT of ct_NONE + | CT_coerce_STAR_to_STAR_OPT of ct_STAR +and ct_STRING = + CT_string of string +and ct_STRING_NE_LIST = + CT_string_ne_list of ct_STRING * ct_STRING list +and ct_STRING_OPT = + CT_coerce_NONE_to_STRING_OPT of ct_NONE + | CT_coerce_STRING_to_STRING_OPT of ct_STRING +and ct_TABLE = + CT_coerce_ID_to_TABLE of ct_ID + | CT_table of ct_ID * ct_ID +and ct_TACTIC_ARG = + CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD + | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT + | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM + | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE + | CT_void +and ct_TACTIC_ARG_LIST = + CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list +and ct_TACTIC_COM = + CT_abstract of ct_ID_OPT * ct_TACTIC_COM + | CT_absurd of ct_FORMULA + | CT_any_constructor of ct_TACTIC_OPT + | CT_apply of ct_FORMULA * ct_SPEC_LIST + | CT_assert of ct_ID_OPT * ct_FORMULA + | CT_assumption + | CT_auto of ct_INT_OPT + | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR + | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT + | CT_autotdb of ct_INT_OPT + | CT_case_type of ct_FORMULA + | CT_casetac of ct_FORMULA * ct_SPEC_LIST + | CT_cdhyp of ct_ID + | CT_change of ct_FORMULA * ct_CLAUSE + | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE + | CT_clear of ct_ID_NE_LIST + | CT_clear_body of ct_ID_NE_LIST + | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST + | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_constructor of ct_INT * ct_SPEC_LIST + | CT_contradiction + | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST + | CT_cut of ct_FORMULA + | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT + | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT + | CT_dauto of ct_INT_OPT * ct_INT_OPT + | CT_dconcl + | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA + | CT_decompose_record of ct_FORMULA + | CT_decompose_sum of ct_FORMULA + | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT + | CT_deprewrite_lr of ct_ID + | CT_deprewrite_rl of ct_ID + | CT_destruct of ct_ID_OR_INT + | CT_dhyp of ct_ID + | CT_discriminate_eq of ct_ID_OR_INT_OPT + | CT_do of ct_ID_OR_INT * ct_TACTIC_COM + | CT_eapply of ct_FORMULA * ct_SPEC_LIST + | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT + | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR + | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING + | CT_elim_type of ct_FORMULA + | CT_exact of ct_FORMULA + | CT_exists of ct_SPEC_LIST + | CT_fail of ct_ID_OR_INT * ct_STRING_OPT + | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_firstorder of ct_TACTIC_OPT + | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST + | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST + | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST + | CT_formula_marker of ct_FORMULA + | CT_fresh of ct_STRING_OPT + | CT_generalize of ct_FORMULA_NE_LIST + | CT_generalize_dependent of ct_FORMULA + | CT_idtac of ct_STRING_OPT + | CT_induction of ct_ID_OR_INT + | CT_info of ct_TACTIC_COM + | CT_injection_eq of ct_ID_OR_INT_OPT + | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE + | CT_intro of ct_ID_OPT + | CT_intro_after of ct_ID_OPT * ct_ID + | CT_intros of ct_INTRO_PATT_LIST + | CT_intros_until of ct_ID_OR_INT + | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST + | CT_left of ct_SPEC_LIST + | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE + | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE + | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list + | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list + | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES + | CT_move_after of ct_ID * ct_ID + | CT_new_destruct of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT + | CT_new_induction of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT + | CT_omega + | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM + | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_pose of ct_ID_OPT * ct_FORMULA + | CT_progress of ct_TACTIC_COM + | CT_prolog of ct_FORMULA_LIST * ct_INT + | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM + | CT_reduce of ct_RED_COM * ct_CLAUSE + | CT_refine of ct_FORMULA + | CT_reflexivity + | CT_rename of ct_ID * ct_ID + | CT_repeat of ct_TACTIC_COM + | CT_replace_with of ct_FORMULA * ct_FORMULA + | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_right of ct_SPEC_LIST + | CT_ring of ct_FORMULA_LIST + | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST + | CT_simplify_eq of ct_ID_OR_INT_OPT + | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST + | CT_split of ct_SPEC_LIST + | CT_subst of ct_ID_LIST + | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB + | CT_symmetry of ct_CLAUSE + | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT + | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM + | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_transitivity of ct_FORMULA + | CT_trivial + | CT_trivial_with of ct_ID_NE_LIST_OR_STAR + | CT_truecut of ct_ID_OPT * ct_FORMULA + | CT_try of ct_TACTIC_COM + | CT_use of ct_FORMULA + | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST + | CT_user_tac of ct_ID * ct_TARG_LIST +and ct_TACTIC_OPT = + CT_coerce_NONE_to_TACTIC_OPT of ct_NONE + | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM +and ct_TAC_DEF = + CT_tac_def of ct_ID * ct_TACTIC_COM +and ct_TAC_DEF_NE_LIST = + CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list +and ct_TARG = + CT_coerce_BINDING_to_TARG of ct_BINDING + | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC + | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC + | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT + | CT_coerce_PATTERN_to_TARG of ct_PATTERN + | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT + | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST + | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE + | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST + | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM + | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST + | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD + | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST +and ct_TARG_LIST = + CT_targ_list of ct_TARG list +and ct_TERM_CHANGE = + CT_check_term of ct_FORMULA + | CT_inst_term of ct_ID * ct_FORMULA +and ct_TEXT = + CT_coerce_ID_to_TEXT of ct_ID + | CT_text_formula of ct_FORMULA + | CT_text_h of ct_TEXT list + | CT_text_hv of ct_TEXT list + | CT_text_op of ct_TEXT list + | CT_text_path of ct_SIGNED_INT_LIST + | CT_text_v of ct_TEXT list +and ct_THEOREM_GOAL = + CT_goal of ct_FORMULA + | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA +and ct_THM = + CT_thm of string +and ct_THM_OPT = + CT_coerce_NONE_to_THM_OPT of ct_NONE + | CT_coerce_THM_to_THM_OPT of ct_THM +and ct_TYPED_FORMULA = + CT_typed_formula of ct_FORMULA * ct_FORMULA +and ct_UNFOLD = + CT_coerce_ID_to_UNFOLD of ct_ID + | CT_unfold_occ of ct_ID * ct_INT_NE_LIST +and ct_UNFOLD_NE_LIST = + CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list +and ct_USING = + CT_coerce_NONE_to_USING of ct_NONE + | CT_using of ct_FORMULA * ct_SPEC_LIST +and ct_USINGTDB = + CT_coerce_NONE_to_USINGTDB of ct_NONE + | CT_usingtdb +and ct_VAR = + CT_var of string +and ct_VARG = + CT_coerce_AST_to_VARG of ct_AST + | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST + | CT_coerce_BINDER_to_VARG of ct_BINDER + | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST + | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST + | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST + | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT + | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT + | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL + | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT + | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST + | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT + | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT + | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT + | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST +and ct_VARG_LIST = + CT_varg_list of ct_VARG list +and ct_VERBOSE_OPT = + CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE + | CT_verbose +;; diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml new file mode 100755 index 00000000..d5236a7a --- /dev/null +++ b/contrib/interface/blast.ml @@ -0,0 +1,628 @@ +(* Une tactique qui tente de démontrer toute seule le but courant, + interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A) +*) +open Ctast;; +open Termops;; +open Nameops;; +open Auto;; +open Clenv;; +open Command;; +open Ctast;; +open Declarations;; +open Declare;; +open Eauto;; +open Environ;; +open Equality;; +open Evd;; +open Hipattern;; +open Inductive;; +open Names;; +open Pattern;; +open Pbp;; +open Pfedit;; +open Pp;; +open Printer +open Proof_trees;; +open Proof_type;; +open Rawterm;; +open Reduction;; +open Refiner;; +open Sign;; +open String;; +open Tacmach;; +open Tacred;; +open Tacticals;; +open Tactics;; +open Term;; +open Typing;; +open Util;; +open Vernacentries;; +open Vernacinterp;; +open Evar_refiner;; + + +let parse_com = Pcoq.parse_string Pcoq.Constr.constr;; +let parse_tac t = + try (Pcoq.parse_string Pcoq.Tactic.tactic t) + with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t)); + failwith "tactic") +;; + +let is_free () = + let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in + let c=input_char st in + close_in st; + c = 'A' +;; + +(* marche pas *) +(* +let is_free () = + msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]); + let s = Stream.of_channel stdin in + msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]); + try (Stream.empty s; + msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]); + true) + with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]); + false) +;; +*) +let free_try tac g = + if is_free() + then (tac g) + else (failwith "not free") +;; +let adrel (x,t) e = + match x with + Name(xid) -> Environ.push_rel (x,None,t) e + | Anonymous -> Environ.push_rel (x,None,t) e +(* les constantes ayant une définition apparaissant dans x *) +let rec def_const_in_term_rec vl x = + match (kind_of_term x) with + Prod(n,t,c)-> + let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c + | Lambda(n,t,c) -> + let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c + | App(f,args) -> def_const_in_term_rec vl f + | Sort(Prop(Null)) -> Prop(Null) + | Sort(c) -> c + | Ind(ind) -> + let (mib, mip) = Global.lookup_inductive ind in + mip.mind_sort + | Construct(c) -> + def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) + | Case(_,x,t,a) + -> def_const_in_term_rec vl x + | Cast(x,t)-> def_const_in_term_rec vl t + | Const(c) -> def_const_in_term_rec vl (lookup_constant c vl).const_type + | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x) +;; +let def_const_in_term_ x = + def_const_in_term_rec (Global.env()) (strip_outer_cast x) +;; +(************************************************************************* + recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli + modif de print_info_script avec pr_bar +*) + +let pr_bar () = str "|" + +let rec print_info_script sigma osign pf = + let {evar_hyps=sign; evar_concl=cl} = pf.goal in + match pf.ref with + | None -> (mt ()) + | Some(r,spfl) -> + pr_rule r ++ + match spfl with + | [] -> + (str " " ++ fnl()) + | [pf1] -> + if pf1.ref = None then + (str " " ++ fnl()) + else + (str";" ++ brk(1,3) ++ + print_info_script sigma sign pf1) + | _ -> ( str";[" ++ fnl() ++ + prlist_with_sep pr_bar + (print_info_script sigma sign) spfl ++ + str"]") + +let format_print_info_script sigma osign pf = + hov 0 (print_info_script sigma osign pf) + +let print_subscript sigma sign pf = + (* if is_tactic_proof pf then + format_print_info_script sigma sign (subproof_of_proof pf) + else *) + format_print_info_script sigma sign pf +(****************) + +let pp_string x = + msgnl_with Format.str_formatter x; + Format.flush_str_formatter () +;; + +(*********************************************************************** + copié de tactics/eauto.ml +*) + +(***************************************************************************) +(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) +(***************************************************************************) + +let unify_e_resolve (c,clenv) gls = + let (wc,kONT) = startWalk gls in + let clenv' = connect_clenv wc clenv in + let _ = clenv_unique_resolver false clenv' gls in + vernac_e_resolve_constr c gls + +let rec e_trivial_fail_db db_list local_db goal = + let tacl = + registered_e_assumption :: + (tclTHEN Tactics.intro + (function g'-> + let d = pf_last_hyp g' in + let hintl = make_resolve_hyp (pf_env g') (project g') d in + (e_trivial_fail_db db_list + (Hint_db.add_list hintl local_db) g'))) :: + (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) + in + tclFIRST (List.map tclCOMPLETE tacl) goal + +and e_my_find_search db_list local_db hdc concl = + let hdc = head_of_constr_reference hdc in + let hintl = + if occur_existential concl then + list_map_append (Hint_db.map_all hdc) (local_db::db_list) + else + list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list) + in + let tac_of_hint = + fun ({pri=b; pat = p; code=t} as patac) -> + (b, + let tac = + match t with + | Res_pf (term,cl) -> unify_resolve (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve (term,cl) + | Give_exact (c) -> e_give_exact_constr c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN (unify_e_resolve (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> unfold_constr c + | Extern tacast -> Auto.conclPattern concl + (out_some p) tacast + in + (free_try tac,fmt_autotactic t)) + (*i + fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + try tac gls + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); + raise e) + i*) + in + List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db gl = + try + Auto.priority + (e_my_find_search db_list local_db + (List.hd (head_constr_bound gl [])) gl) + with Bound | Not_found -> [] + +let e_possible_resolve db_list local_db gl = + try List.map snd (e_my_find_search db_list local_db + (List.hd (head_constr_bound gl [])) gl) + with Bound | Not_found -> [] + +let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +module MySearchProblem = struct + + type state = { + depth : int; (*r depth of search before failing *) + tacres : goal list sigma * validation; + last_tactic : std_ppcmds; + dblist : Auto.Hint_db.t list; + localdb : Auto.Hint_db.t list } + + let success s = (sig_it (fst s.tacres)) = [] + + let rec filter_tactics (glls,v) = function + | [] -> [] + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in + let v' p = v (ptl p) in + ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl + with e when Logic.catchable_exception e -> + filter_tactics (glls,v) tacl + + let rec list_addn n x l = + if n = 0 then l else x :: (list_addn (pred n) x l) + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let nbgoals s = List.length (sig_it (fst s.tacres)) in + if d <> 0 then d else nbgoals s - nbgoals s' + + let branching s = + if s.depth = 0 then + [] + else + let lg = fst s.tacres in + let nbgl = List.length (sig_it lg) in + assert (nbgl > 0); + let g = find_first_goal lg in + let assumption_tacs = + let l = + filter_tactics s.tacres + (List.map + (fun id -> (e_give_exact_constr (mkVar id), + (str "Exact" ++ spc()++ pr_id id))) + (pf_ids_of_hyps g)) + in + List.map (fun (res,pp) -> { depth = s.depth; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb }) l + in + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list hintl (List.hd s.localdb) in + { depth = s.depth; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb }) + (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) + in + let rec_tacs = + let l = + filter_tactics s.tacres + (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + in + List.map + (fun ((lgls,_) as res, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; tacres = res; last_tactic = pp; + dblist = s.dblist; localdb = List.tl s.localdb } + else + { depth = pred s.depth; tacres = res; + dblist = s.dblist; last_tactic = pp; + localdb = + list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = + msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ + s.last_tactic ++ str "\n")) + +end + +module MySearch = Explore.Make(MySearchProblem) + +let make_initial_state n gl dblist localdb = + { MySearchProblem.depth = n; + MySearchProblem.tacres = tclIDTAC gl; + MySearchProblem.last_tactic = (mt ()); + MySearchProblem.dblist = dblist; + MySearchProblem.localdb = [localdb] } + +let e_depth_search debug p db_list local_db gl = + try + let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in + let s = tac (make_initial_state p gl db_list local_db) in + s.MySearchProblem.tacres + with Not_found -> error "EAuto: depth first search failed" + +let e_breadth_search debug n db_list local_db gl = + try + let tac = + if debug then MySearch.debug_breadth_first else MySearch.breadth_first + in + let s = tac (make_initial_state n gl db_list local_db) in + s.MySearchProblem.tacres + with Not_found -> error "EAuto: breadth first search failed" + +let e_search_auto debug (n,p) db_list gl = + let local_db = make_local_hint_db gl in + if n = 0 then + e_depth_search debug p db_list local_db gl + else + e_breadth_search debug n db_list local_db gl + +let eauto debug np dbnames = + let db_list = + List.map + (fun x -> + try Stringmap.find x !searchtable + with Not_found -> error ("EAuto: "^x^": No such Hint database")) + ("core"::dbnames) + in + tclTRY (e_search_auto debug np db_list) + +let full_eauto debug n gl = + let dbnames = stringmap_dom !searchtable in + let dbnames = list_subtract dbnames ["v62"] in + let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in + let local_db = make_local_hint_db gl in + tclTRY (e_search_auto debug n db_list) gl + +let my_full_eauto n gl = full_eauto false (n,0) gl + +(********************************************************************** + copié de tactics/auto.ml on a juste modifié search_gen +*) +let searchtable_map name = + Stringmap.find name !searchtable + +(* local_db is a Hint database containing the hypotheses of current goal *) +(* Papageno : cette fonction a été pas mal simplifiée depuis que la base + de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) + +let rec trivial_fail_db db_list local_db gl = + let intro_tac = + tclTHEN intro + (fun g'-> + let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') + in + tclFIRST + (assumption::intro_tac:: + (List.map tclCOMPLETE + (trivial_resolve db_list local_db (pf_concl gl)))) gl + +and my_find_search db_list local_db hdc concl = + let tacl = + if occur_existential concl then + list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list) + else + list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db) + (local_db::db_list) + in + List.map + (fun ({pri=b; pat=p; code=t} as patac) -> + (b, + match t with + | Res_pf (term,cl) -> unify_resolve (term,cl) + | ERes_pf (_,c) -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve (term,cl)) + (trivial_fail_db db_list local_db) + | Unfold_nth c -> unfold_constr c + | Extern tacast -> + conclPattern concl (out_some p) tacast)) + tacl + +and trivial_resolve db_list local_db cl = + try + let hdconstr = List.hd (head_constr_bound cl []) in + priority + (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) + with Bound | Not_found -> + [] + +(**************************************************************************) +(* The classical Auto tactic *) +(**************************************************************************) + +let possible_resolve db_list local_db cl = + try + let hdconstr = List.hd (head_constr_bound cl []) in + List.map snd + (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) + with Bound | Not_found -> + [] + +let decomp_unary_term c gls = + let typc = pf_type_of gls c in + let hd = List.hd (head_constr typc) in + if Hipattern.is_conjunction hd then + simplest_case c gls + else + errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") + +let decomp_empty_term c gls = + let typc = pf_type_of gls c in + let (hd,_) = decompose_app typc in + if Hipattern.is_empty_type hd then + simplest_case c gls + else + errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") + + +(* decomp is an natural number giving an indication on decomposition + of conjunction in hypotheses, 0 corresponds to no decomposition *) +(* n is the max depth of search *) +(* local_db contains the local Hypotheses *) + +let rec search_gen decomp n db_list local_db extra_sign goal = + if n=0 then error "BOUND 2"; + let decomp_tacs = match decomp with + | 0 -> [] + | p -> + (tclTRY_sign decomp_empty_term extra_sign) + :: + (List.map + (fun id -> tclTHEN (decomp_unary_term (mkVar id)) + (tclTHEN + (clear [id]) + (free_try (search_gen decomp p db_list local_db [])))) + (pf_ids_of_hyps goal)) + in + let intro_tac = + tclTHEN intro + (fun g' -> + let (hid,_,htyp as d) = pf_last_hyp g' in + let hintl = + try + [make_apply_entry (pf_env g') (project g') + (true,false) + hid (mkVar hid,body_of_type htyp)] + with Failure _ -> [] + in + (free_try + (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d]) + g')) + in + let rec_tacs = + List.map + (fun ntac -> + tclTHEN ntac + (free_try + (search_gen decomp (n-1) db_list local_db empty_named_context))) + (possible_resolve db_list local_db (pf_concl goal)) + in + tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal + + +let search = search_gen 0 + +let default_search_depth = ref 5 + +let full_auto n gl = + let dbnames = stringmap_dom !searchtable in + let dbnames = list_subtract dbnames ["v62"] in + let db_list = List.map (fun x -> searchtable_map x) dbnames in + let hyps = pf_hyps gl in + tclTRY (search n db_list (make_local_hint_db gl) hyps) gl + +let default_full_auto gl = full_auto !default_search_depth gl +(************************************************************************) + +let blast_tactic = ref (free_try default_full_auto) +;; + +let blast_auto = (free_try default_full_auto) +(* (tclTHEN (free_try default_full_auto) + (free_try (my_full_eauto 2))) +*) +;; +let blast_simpl = (free_try (reduce (Simpl None) onConcl)) +;; +let blast_induction1 = + (free_try (tclTHEN (tclTRY intro) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; +let blast_induction2 = + (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; +let blast_induction3 = + (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; + +blast_tactic := + (tclORELSE (tclCOMPLETE blast_auto) + (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto)) + (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1 + (tclTHEN blast_simpl blast_auto))) + (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2 + (tclTHEN blast_simpl blast_auto))) + (tclCOMPLETE (tclTHEN blast_induction3 + (tclTHEN blast_simpl blast_auto))))))) +;; +(* +blast_tactic := (tclTHEN (free_try default_full_auto) + (free_try (my_full_eauto 4))) +;; +*) + +let vire_extvar s = + let interro = ref false in + let interro_pos = ref 0 in + for i=0 to (length s)-1 do + if get s i = '?' + then (interro := true; + interro_pos := i) + else if (!interro && + (List.mem (get s i) + ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) + then set s i ' ' + else interro:=false + done; + s +;; + +let blast gls = + let leaf g = { + open_subgoals = 1; + goal = g; + ref = None } in + try (let (sgl,v) as res = !blast_tactic gls in + let {it=lg} = sgl in + if lg = [] + then (let pf = v (List.map leaf (sig_it sgl)) in + let sign = (sig_it gls).evar_hyps in + let x = print_subscript + (sig_sig gls) sign pf in + msgnl (hov 0 (str"Blast ==> " ++ x)); + let x = print_subscript + (sig_sig gls) sign pf in + let tac_string = + pp_string (hov 0 x ) in + (* on remplace les ?1 ?2 ... de refine par ? *) + parse_tac ((vire_extvar tac_string) + ^ ".") + ) + else (msgnl (hov 0 (str"Blast failed to prove the goal...")); + failwith "echec de blast")) + with _ -> failwith "echec de blast" +;; + +let blast_tac display_function = function + | (n::_) as l -> + (function g -> + let exp_ast = (blast g) in + (display_function exp_ast; + tclIDTAC g)) + | _ -> failwith "expecting other arguments";; + +let blast_tac_txt = + blast_tac + (function x -> msgnl(Pptactic.pr_glob_tactic (Tacinterp.glob_tactic x)));; + +(* Obsolète ? +overwriting_add_tactic "Blast1" blast_tac_txt;; +*) + +(* +Grammar tactic ne_numarg_list : list := + ne_numarg_single [numarg($n)] ->[$n] +| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ]. +Grammar tactic simple_tactic : ast := + blast1 [ "Blast1" ne_numarg_list($ns) ] -> + [ (Blast1 ($LIST $ns)) ]. + + + +PATH=/usr/local/bin:/usr/bin:$PATH +COQTOP=d:/Tools/coq-7.0-3mai +CAMLLIB=/usr/local/lib/ocaml +CAMLP4LIB=/usr/local/lib/camlp4 +export CAMLLIB +export COQTOP +export CAMLP4LIB +d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe +Drop. +#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; +*) diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli new file mode 100644 index 00000000..21c29bc9 --- /dev/null +++ b/contrib/interface/blast.mli @@ -0,0 +1,5 @@ +val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) -> + int list -> + Proof_type.goal Tacmach.sigma -> + Proof_type.goal list Proof_type.sigma * Proof_type.validation;; + diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 new file mode 100644 index 00000000..7bf12f3b --- /dev/null +++ b/contrib/interface/centaur.ml4 @@ -0,0 +1,700 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +(*Toplevel loop for the communication between Coq and Centaur *) +open Names;; +open Nameops;; +open Util;; +open Ast;; +open Term;; +open Pp;; +open Libnames;; +open Libobject;; +open Library;; +open Vernacinterp;; +open Evd;; +open Proof_trees;; +open Termast;; +open Tacmach;; +open Pfedit;; +open Proof_type;; +open Parsing;; +open Environ;; +open Declare;; +open Declarations;; +open Rawterm;; +open Reduction;; +open Classops;; +open Vernacinterp;; +open Vernac;; +open Command;; +open Protectedtoplevel;; +open Coqast;; +open Line_oriented_parser;; +open Xlate;; +open Vtp;; +open Ascent;; +open Translate;; +open Name_to_ast;; +open Pbp;; +open Blast;; +(* open Dad;; *) +open Debug_tac;; +open Search;; +open Constrintern;; +open Nametab;; +open Showproof;; +open Showproof_ct;; +open Tacexpr;; +open Vernacexpr;; + +let pcoq_started = ref None;; + +let if_pcoq f a = + if !pcoq_started <> None then f a else error "Pcoq is not started";; + +let text_proof_flag = ref "en";; + +let current_proof_name () = + try + string_of_id (get_current_proof_name ()) + with + UserError("Pfedit.get_proof", _) -> "";; + +let current_goal_index = ref 0;; + +let guarded_force_eval_stream (s : std_ppcmds) = + let l = ref [] in + let f elt = l:= elt :: !l in + (try Stream.iter f s with + | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); + Stream.of_list (List.rev !l);; + + +let rec string_of_path p = + match p with [] -> "\n" + | i::p -> (string_of_int i)^" "^ (string_of_path p) +;; +let print_path p = + output_results_nl (str "Path:" ++ str (string_of_path p)) +;; + +let kill_proof_node index = + let paths = History.historical_undo (current_proof_name()) index in + let _ = List.iter + (fun path -> (traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + traverse_to [])) + paths in + History.border_length (current_proof_name());; + + +(*Message functions, the text of these messages is recognized by the protocols *) +(*of CtCoq *) +let ctf_header message_name request_id = + fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++ + int request_id ++ fnl();; + +let ctf_acknowledge_command request_id command_count opt_exn = + let goal_count, goal_index = + if refining() then + let g_count = + List.length + (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in + g_count, (min g_count !current_goal_index) + else + (0, 0) in + (ctf_header "acknowledge" request_id ++ + int command_count ++ fnl() ++ + int goal_count ++ fnl () ++ + int goal_index ++ fnl () ++ + str (current_proof_name()) ++ fnl() ++ + (match opt_exn with + Some e -> Cerrors.explain_exn e + | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; + +let ctf_undoResults = ctf_header "undo_results";; + +let ctf_TextMessage = ctf_header "text_proof";; + +let ctf_SearchResults = ctf_header "search_results";; + +let ctf_OtherGoal = ctf_header "other_goal";; + +let ctf_Location = ctf_header "location";; + +let ctf_StateMessage = ctf_header "state";; + +let ctf_PathGoalMessage () = + fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();; + +let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; + +let ctf_NewStateMessage = ctf_header "fresh_state";; + +let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ + str "saved" ++ fnl();; + +let ctf_KilledMessage req_id ngoals = + ctf_header "killed" req_id ++ int ngoals ++ fnl ();; + +let ctf_AbortedAllMessage () = + fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; + +let ctf_AbortedMessage request_id na = + ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; + +let ctf_UserErrorMessage request_id stream = + let stream = guarded_force_eval_stream stream in + ctf_header "user_error" request_id ++ stream ++ fnl() ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +let ctf_ResetInitialMessage () = + fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();; + +let ctf_ResetIdentMessage request_id s = + ctf_header "reset_ident" request_id ++ str s ++ fnl () ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +type vtp_tree = + | P_rl of ct_RULE_LIST + | P_r of ct_RULE + | P_s_int of ct_SIGNED_INT_LIST + | P_pl of ct_PREMISES_LIST + | P_cl of ct_COMMAND_LIST + | P_t of ct_TACTIC_COM + | P_text of ct_TEXT + | P_ids of ct_ID_LIST;; + +let print_tree t = + (match t with + | P_rl x -> fRULE_LIST x + | P_r x -> fRULE x + | P_s_int x -> fSIGNED_INT_LIST x + | P_pl x -> fPREMISES_LIST x + | P_cl x -> fCOMMAND_LIST x + | P_t x -> fTACTIC_COM x + | P_text x -> fTEXT x + | P_ids x -> fID_LIST x); + print_string "e\nblabla\n";; + + + +let break_happened = ref false;; + +let output_results stream vtp_tree = + let _ = Sys.signal Sys.sigint + (Sys.Signal_handle(fun i -> (break_happened := true;()))) in + msg stream; + match vtp_tree with + Some t -> print_tree t + | None -> ();; + +let output_results_nl stream = + let _ = Sys.signal Sys.sigint + (Sys.Signal_handle(fun i -> break_happened := true;())) + in + msgnl stream;; + + +let rearm_break () = + let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break)) + in ();; + +let check_break () = + if (!break_happened) then + begin + break_happened := false; + raise Sys.Break + end + else ();; + +let print_past_goal index = + let path = History.get_path_for_rank (current_proof_name()) index in + try traverse_to path; + let pf = proof_of_pftreestate (get_pftreestate ()) in + output_results (ctf_PathGoalMessage ()) + (Some (P_r (translate_goal pf.goal))) + with + | Invalid_argument s -> + ((try traverse_to [] with _ -> ()); + error "No focused proof (No proof-editing in progress)") + | e -> (try traverse_to [] with _ -> ()); raise e +;; + +let show_nth n = + try + let pf = proof_of_pftreestate (get_pftreestate()) in + if (!text_proof_flag<>"off") then + (if n=0 + then output_results (ctf_TextMessage !global_request_id) + (Some (P_text (show_proof !text_proof_flag []))) + else + let path = History.get_nth_open_path (current_proof_name()) n in + output_results (ctf_TextMessage !global_request_id) + (Some (P_text (show_proof !text_proof_flag path)))) + else + output_results (ctf_GoalReqIdMessage !global_request_id) + (let goal = List.nth (fst (frontier pf)) + (n - 1) in + (Some (P_r (translate_goal goal)))) + with + | Invalid_argument s -> + error "No focused proof (No proof-editing in progress)";; + +(* The rest of the file contains commands that are changed from the plain + Coq distribution *) + +let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);; + +(* +let filter_by_module_from_varg_list l = + let dir_list, b = Vernacentries.interp_search_restriction l in + Search.filter_by_module_from_list (dir_list, b);; +*) + +let add_search (global_reference:global_reference) assumptions cstr = + try + let id_string = + string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty + global_reference) in + let ast = + try + CT_premise (CT_ident id_string, translate_constr false assumptions cstr) + with Not_found -> + CT_premise (CT_ident id_string, + CT_coerce_ID_to_FORMULA( + CT_ident ("Error printing" ^ id_string))) in + ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST + with e -> msgnl (str "add_search raised an exception"); raise e;; + +(* +let make_error_stream node_string = + str "The syntax of " ++ str node_string ++ + str " is inconsistent with the vernac interpreter entry";; +*) + +let ctf_EmptyGoalMessage id = + fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; + + +let print_check judg = + let {uj_val=value; uj_type=typ} = judg in + let value_ct_ast = + (try translate_constr false (Global.env()) value + with UserError(f,str) -> + raise(UserError(f, + Ast.print_ast + (ast_of_constr true (Global.env()) value) ++ + fnl () ++ str ))) in + let type_ct_ast = + (try translate_constr false (Global.env()) typ + with UserError(f,str) -> + raise(UserError(f, Ast.print_ast (ast_of_constr true (Global.env()) + value) ++ fnl() ++ str))) in + ((ctf_SearchResults !global_request_id), + (Some (P_pl + (CT_premises_list + [CT_coerce_TYPED_FORMULA_to_PREMISE + (CT_typed_formula(value_ct_ast,type_ct_ast) + )]))));; + +let ct_print_eval ast red_fun env judg = +((if refining() then traverse_to []); +let {uj_val=value; uj_type=typ} = judg in +let nvalue = red_fun value +(* // Attention , ici il faut peut être utiliser des environnemenst locaux *) +and ntyp = nf_betaiota typ in +(ctf_SearchResults !global_request_id, + Some (P_pl + (CT_premises_list + [CT_eval_result + (xlate_formula ast, + translate_constr false env nvalue, + translate_constr false env ntyp)]))));; + + + +(* The following function is copied from globpr in env/printer.ml *) +let globcv x = + match x with + | Node(_,"MUTIND", (Path(_,sp))::(Num(_,tyi))::_) -> + convert_qualid + (Nametab.shortest_qualid_of_global Idset.empty (IndRef(sp,tyi))) + | Node(_,"MUTCONSTRUCT",(Path(_,sp))::(Num(_,tyi))::(Num(_,i))::_) -> + convert_qualid + (Nametab.shortest_qualid_of_global Idset.empty + (ConstructRef ((sp, tyi), i))) + | _ -> failwith "globcv : unexpected value";; + +let pbp_tac_pcoq = + pbp_tac (function (x:raw_tactic_expr) -> + output_results + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; + +let blast_tac_pcoq = + blast_tac (function (x:raw_tactic_expr) -> + output_results + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; + +(* <\cpa> +let dad_tac_pcoq = + dad_tac(function x -> + output_results + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; +</cpa> *) + +let search_output_results () = + output_results + (ctf_SearchResults !global_request_id) + (Some (P_pl (CT_premises_list + (List.rev !ctv_SEARCH_LIST))));; + + +let debug_tac2_pcoq tac = + (fun g -> + let the_goal = ref (None : goal sigma option) in + let the_ast = ref tac in + let the_path = ref ([] : int list) in + try + let result = report_error tac the_goal the_ast the_path [] g in + (errorlabstrm "DEBUG TACTIC" + (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++ + fnl () ++ str "the tactic is" ++ fnl () ++ + Pptactic.pr_glob_tactic tac); + result) + with + e -> + match !the_goal with + None -> raise e + | Some g -> + (output_results + (ctf_Location !global_request_id) + (Some (P_s_int + (CT_signed_int_list + (List.map + (fun n -> CT_coerce_INT_to_SIGNED_INT + (CT_int n)) + (clean_path tac + (List.rev !the_path))))))); + (output_results + (ctf_OtherGoal !global_request_id) + (Some (P_r (translate_goal (sig_it g))))); + raise e);; + +let rec selectinspect n env = + match env with + [] -> [] + | a::tl -> + if n = 0 then + [] + else + match a with + (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl) + | _ -> (selectinspect n tl);; + +open Term;; + +let inspect n = + let env = Global.env() in + let add_search2 x y = add_search x env y in + let l = selectinspect n (Lib.contents_after None) in + ctv_SEARCH_LIST := []; + List.iter + (fun a -> + try + (match a with + oname, Lib.Leaf lobj -> + (match oname, object_tag lobj with + (sp,_), "VARIABLE" -> + let (_, _, v) = get_variable (basename sp) in + add_search2 (Nametab.locate (qualid_of_sp sp)) v + | (sp,kn), "CONSTANT" -> + let {const_type=typ} = Global.lookup_constant kn in + add_search2 (Nametab.locate (qualid_of_sp sp)) typ + | (sp,kn), "MUTUALINDUCTIVE" -> + add_search2 (Nametab.locate (qualid_of_sp sp)) + (Pretyping.understand Evd.empty (Global.env()) + (RRef(dummy_loc, IndRef(kn,0)))) + | _ -> failwith ("unexpected value 1 for "^ + (string_of_id (basename (fst oname))))) + | _ -> failwith "unexpected value") + with e -> ()) + l; + output_results + (ctf_SearchResults !global_request_id) + (Some + (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; + +let ct_int_to_TARG n = + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; + +let pair_list_to_ct l = + CT_user_tac(CT_ident "pair_int_list", + CT_targ_list + (List.map (fun (a,b) -> + CT_coerce_TACTIC_COM_to_TARG + (CT_user_tac + (CT_ident "pair_int", + CT_targ_list + [ct_int_to_TARG a; ct_int_to_TARG b]))) + l));; + +(* Annule toutes les commandes qui s'appliquent sur les sous-buts du + but auquel a été appliquée la n-ième tactique *) +let logical_kill n = + let path = History.get_path_for_rank (current_proof_name()) n in + begin + traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + (let kept_cmds, undone_cmds, remaining_goals, current_goal = + History.logical_undo (current_proof_name()) n in + output_results (ctf_undoResults !global_request_id) + (Some + (P_t + (CT_user_tac + (CT_ident "log_undo_result", + CT_targ_list + [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds); + CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds); + ct_int_to_TARG remaining_goals; + ct_int_to_TARG current_goal]))))); + traverse_to [] + end;; + +let simulate_solve n tac = + let path = History.get_nth_open_path (current_proof_name()) n in + solve_nth n (Tacinterp.hide_interp tac (get_end_tac())); + traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + traverse_to [] + +let kill_node_verbose n = + let ngoals = kill_proof_node n in + output_results_nl (ctf_KilledMessage !global_request_id ngoals) + +let set_text_mode s = text_proof_flag := s + +let pcoq_reset_initial() = + output_results(ctf_AbortedAllMessage()) None; + Vernacentries.abort_refine Lib.reset_initial (); + output_results(ctf_ResetInitialMessage()) None;; + +let pcoq_reset x = + if refining() then + output_results (ctf_AbortedAllMessage ()) None; + Vernacentries.abort_refine Lib.reset_name (dummy_loc,x); + output_results + (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; + + +VERNAC ARGUMENT EXTEND text_mode +| [ "fr" ] -> [ "fr" ] +| [ "en" ] -> [ "en" ] +| [ "Off" ] -> [ "off" ] +END + +VERNAC COMMAND EXTEND TextMode +| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ] +END + +VERNAC COMMAND EXTEND OutputGoal + [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ] +END + +VERNAC COMMAND EXTEND OutputGoal + [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ] +END + +VERNAC COMMAND EXTEND KillProofAfter +| [ "Kill" "Proof" "after" natural(n) ] -> [ kill_node_verbose n ] +END + +VERNAC COMMAND EXTEND KillProofAt +| [ "Kill" "Proof" "at" natural(n) ] -> [ kill_node_verbose n ] +END + +VERNAC COMMAND EXTEND KillSubProof + [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ] +END + +VERNAC COMMAND EXTEND PcoqReset + [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ] +END + +VERNAC COMMAND EXTEND PcoqResetInitial + [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ] +END + +let start_proof_hook () = + History.start_proof (current_proof_name()); + current_goal_index := 1 + +let solve_hook n = + let name = current_proof_name () in + let old_n_count = History.border_length name in + let pf = proof_of_pftreestate (get_pftreestate ()) in + let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in + begin + current_goal_index := n; + History.push_command name n n_goals + end + +let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) + +let interp_search_about_item = function + | SearchRef qid -> GlobSearchRef (Nametab.global qid) + | SearchString s -> GlobSearchString s + +let pcoq_search s l = + ctv_SEARCH_LIST:=[]; + begin match s with + | SearchAbout sl -> + raw_search_about (filter_by_module_from_list l) add_search + (List.map interp_search_about_item sl) + | SearchPattern c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + raw_pattern_search (filter_by_module_from_list l) add_search pat + | SearchRewrite c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + raw_search_rewrite (filter_by_module_from_list l) add_search pat; + | SearchHead locqid -> + filtered_search + (filter_by_module_from_list l) add_search (Nametab.global locqid) + end; + search_output_results() + +(* Check sequentially whether the pattern is one of the premises *) +let rec hyp_pattern_filter pat name a c = + let c1 = strip_outer_cast c in + match kind_of_term c with + | Prod(_, hyp, c2) -> + (try +(* let _ = msgnl ((str "WHOLE ") ++ (Printer.prterm c)) in + let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *) + if Matching.is_matching pat hyp then + (msgnl (str "ok"); true) + else + false + with UserError _ -> false) or + hyp_pattern_filter pat name a c2 + | _ -> false;; + +let hyp_search_pattern c l = + let _, pat = interp_constrpattern Evd.empty (Global.env()) c in + ctv_SEARCH_LIST := []; + gen_filtered_search + (fun s a c -> (filter_by_module_from_list l s a c && + (if hyp_pattern_filter pat s a c then + (msgnl (str "ok2"); true) else false))) + (fun s a c -> (msgnl (str "ok3"); add_search s a c)); + output_results + (ctf_SearchResults !global_request_id) + (Some + (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; +let pcoq_print_name ref = + let results = xlate_vernac_list (name_to_ast ref) in + output_results + (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ()) + (Some (P_cl results)) + +let pcoq_print_check j = + let a,b = print_check j in output_results a b + +let pcoq_print_eval redfun env c j = + let strm, vtp = ct_print_eval c redfun env j in + output_results strm vtp;; + +open Vernacentries + +let pcoq_show_goal = function + | Some n -> show_nth n + | None -> + if !pcoq_started = Some true (* = debug *) then + msg (Pfedit.pr_open_subgoals ()) + else errorlabstrm "show_goal" + (str "Show must be followed by an integer in Centaur mode");; + +let pcoq_hook = { + start_proof = start_proof_hook; + solve = solve_hook; + abort = abort_hook; + search = pcoq_search; + print_name = pcoq_print_name; + print_check = pcoq_print_check; + print_eval = pcoq_print_eval; + show_goal = pcoq_show_goal +} + + +TACTIC EXTEND Pbp +| [ "Pbp" ident_opt(idopt) natural_list(nl) ] -> + [ if_pcoq pbp_tac_pcoq idopt nl ] +END + +TACTIC EXTEND CtDebugTac +| [ "DebugTac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] +END + +TACTIC EXTEND CtDebugTac2 +| [ "DebugTac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] +END + + +let start_pcoq_mode debug = + begin + pcoq_started := Some debug; +(* <\cpa> + start_dad(); +</cpa> *) + declare_in_coq(); +(* The following ones are added to enable rich comments in pcoq *) +(* TODO ... + add_tactic "Image" (fun _ -> tclIDTAC); +*) +(* "Comments" moved to Vernacentries, other obsolete ? + List.iter (fun (a,b) -> vinterp_add a b) command_creations; +*) +(* Now hooks in Vernacentries + List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes; + if not debug then + List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes; +*) + set_pcoq_hook pcoq_hook; + end;; + + +let start_pcoq () = + start_pcoq_mode false; + set_acknowledge_command ctf_acknowledge_command; + set_start_marker "CENTAUR_RESERVED_TOKEN_start_command"; + set_end_marker "CENTAUR_RESERVED_TOKEN_end_command"; + raise Vernacexpr.ProtectedLoop;; + +let start_pcoq_debug () = + start_pcoq_mode true; + set_acknowledge_command ctf_acknowledge_command; + set_start_marker "--->"; + set_end_marker "<---"; + raise Vernacexpr.ProtectedLoop;; + +VERNAC COMMAND EXTEND HypSearchPattern + [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ] +END + +VERNAC COMMAND EXTEND StartPcoq + [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ] +END + +VERNAC COMMAND EXTEND Pcoq_inspect + [ "Pcoq_inspect" ] -> [ inspect 15 ] +END + +VERNAC COMMAND EXTEND StartPcoqDebug +| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ] +END diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml new file mode 100644 index 00000000..67279bb8 --- /dev/null +++ b/contrib/interface/ctast.ml @@ -0,0 +1,76 @@ +(* A copy of pre V7 ast *) + +open Names +open Libnames + +type loc = Util.loc + +type t = + | Node of loc * string * t list + | Nvar of loc * string + | Slam of loc * string option * t + | Num of loc * int + | Id of loc * string + | Str of loc * string + | Path of loc * string list + | Dynamic of loc * Dyn.t + +let section_path sl = + match List.rev sl with + | s::pa -> + Libnames.encode_kn + (make_dirpath (List.map id_of_string pa)) + (id_of_string s) + | [] -> invalid_arg "section_path" + +let is_meta s = String.length s > 0 && s.[0] == '$' + +let purge_str s = + if String.length s == 0 || s.[0] <> '$' then s + else String.sub s 1 (String.length s - 1) + +let rec ct_to_ast = function + | Node (loc,a,b) -> Coqast.Node (loc,a,List.map ct_to_ast b) + | Nvar (loc,a) -> + if is_meta a then Coqast.Nmeta (loc,purge_str a) + else Coqast.Nvar (loc,id_of_string a) + | Slam (loc,Some a,b) -> + if is_meta a then Coqast.Smetalam (loc,purge_str a,ct_to_ast b) + else Coqast.Slam (loc,Some (id_of_string a),ct_to_ast b) + | Slam (loc,None,b) -> Coqast.Slam (loc,None,ct_to_ast b) + | Num (loc,a) -> Coqast.Num (loc,a) + | Id (loc,a) -> Coqast.Id (loc,a) + | Str (loc,a) -> Coqast.Str (loc,a) + | Path (loc,sl) -> Coqast.Path (loc,section_path sl) + | Dynamic (loc,a) -> Coqast.Dynamic (loc,a) + +let rec ast_to_ct = function x -> failwith "ast_to_ct: not TODO?" +(* + | Coqast.Node (loc,a,b) -> Node (loc,a,List.map ast_to_ct b) + | Coqast.Nvar (loc,a) -> Nvar (loc,string_of_id a) + | Coqast.Nmeta (loc,a) -> Nvar (loc,"$"^a) + | Coqast.Slam (loc,Some a,b) -> + Slam (loc,Some (string_of_id a),ast_to_ct b) + | Coqast.Slam (loc,None,b) -> Slam (loc,None,ast_to_ct b) + | Coqast.Smetalam (loc,a,b) -> Slam (loc,Some ("$"^a),ast_to_ct b) + | Coqast.Num (loc,a) -> Num (loc,a) + | Coqast.Id (loc,a) -> Id (loc,a) + | Coqast.Str (loc,a) -> Str (loc,a) + | Coqast.Path (loc,a) -> + let (sl,bn) = Libnames.decode_kn a in + Path(loc, (List.map string_of_id + (List.rev (repr_dirpath sl))) @ [string_of_id bn]) + | Coqast.Dynamic (loc,a) -> Dynamic (loc,a) +*) + +let loc = function + | Node (loc,_,_) -> loc + | Nvar (loc,_) -> loc + | Slam (loc,_,_) -> loc + | Num (loc,_) -> loc + | Id (loc,_) -> loc + | Str (loc,_) -> loc + | Path (loc,_) -> loc + | Dynamic (loc,_) -> loc + +let str s = Str(Util.dummy_loc,s) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml new file mode 100644 index 00000000..ec989296 --- /dev/null +++ b/contrib/interface/dad.ml @@ -0,0 +1,382 @@ +(* This file contains an ml version of drag-and-drop. *) + +(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *) + +open Names;; +open Term;; +open Rawterm;; +open Util;; +open Environ;; +open Tactics;; +open Tacticals;; +open Pattern;; +open Matching;; +open Reduction;; +open Constrextern;; +open Constrintern;; +open Vernacinterp;; +open Libnames;; +open Nametab + +open Proof_type;; +open Proof_trees;; +open Tacmach;; +open Typing;; +open Pp;; + +open Paths;; + +open Topconstr;; +open Genarg;; +open Tacexpr;; +open Rawterm;; + +(* In a first approximation, drag-and-drop rules are like in CtCoq + 1/ a pattern, + 2,3/ Two paths: start and end positions, + 4/ the degree: the number of steps the algorithm should go up from the + longest common prefix, + 5/ the tail path: the suffix of the longest common prefix of length the + degree, + 6/ the command pattern, where meta variables are represented by objects + of the form Node(_,"META"; [Num(_,i)]) +*) + + +type dad_rule = + constr_expr * int list * int list * int * int list + * raw_atomic_tactic_expr;; + +(* This value will be used systematically when constructing objects *) + +let zz = Util.dummy_loc;; + +(* This function receives a length n, a path p, and a term and returns a + couple whose first component is the subterm designated by the prefix + of p of length n, and the second component is the rest of the path *) + +let rec get_subterm (depth:int) (path: int list) (constr:constr) = + match depth, path, kind_of_term constr with + 0, l, c -> (constr,l) + | n, 2::a::tl, App(func,arr) -> + get_subterm (n - 2) tl arr.(a-1) + | _,l,_ -> failwith (int_list_to_string + "wrong path or wrong form of term" + l);; + +(* This function maps a substitution on an abstract syntax tree. The + first argument, an object of type env, is necessary to + transform constr terms into abstract syntax trees. The second argument is + the substitution, a list of pairs linking an integer and a constr term. *) + +let rec map_subst (env :env) (subst:patvar_map) = function + | CPatVar (_,(_,i)) -> + let constr = List.assoc i subst in + extern_constr false env constr + | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;; + +let map_subst_tactic env subst = function + | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> + let c,bl = out_gen rawwit_constr_with_bindings cbl in + assert (bl = NoBindings); + let c = (map_subst env subst c,NoBindings) in + TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c]) + | _ -> failwith "map_subst_tactic: unsupported tactic" + +(* This function is really the one that is important. *) +let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = + match l with + [] -> failwith "nothing happens" + | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl -> + let length = List.length p in + try + if deg > length then + failwith "internal" + else + let term_to_match, p_r = + try + get_subterm (length - deg) p constr + with + Failure s -> failwith "internal" in + let _, constr_pat = + interp_constrpattern Evd.empty (Global.env()) + ((*ct_to_ast*) pat) in + let subst = matches constr_pat term_to_match in + if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then + TacAtom (zz, map_subst_tactic env subst cmd) + else + failwith "internal" + with + Failure "internal" -> find_cmd tl env constr p p1 p2 + | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;; + + +let dad_rule_list = ref ([]: (string * dad_rule) list);; + +(* +(* \\ This function is also used in pbp. *) +let rec tactic_args_to_ints = function + [] -> [] + | (Integer n)::l -> n::(tactic_args_to_ints l) + | _ -> failwith "expecting only numbers";; + +(* We assume that the two lists of integers for the tactic are simply + given in one list, separated by a dummy tactic. *) +let rec part_tac_args l = function + [] -> l,[] + | (Tacexp a)::tl -> l, (tactic_args_to_ints tl) + | (Integer n)::tl -> part_tac_args (n::l) tl + | _ -> failwith "expecting only numbers and the word \"to\"";; + + +(* The dad_tac tactic takes a display_function as argument. This makes + it possible to use it in pcoq, but also in other contexts, just by + changing the output routine. *) +let dad_tac display_function = function + l -> let p1, p2 = part_tac_args [] l in + (function g -> + let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in + (display_function + (find_cmd (!dad_rule_list) (pf_env g) + (pf_concl g) p_a p1prime p2prime)); + tclIDTAC g);; +*) +let dad_tac display_function p1 p2 g = + let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in + (display_function + (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); + tclIDTAC g;; + +(* Now we enter dad rule list management. *) + +let add_dad_rule name patt p1 p2 depth pr command = + dad_rule_list := (name, + (patt, p1, p2, depth, pr, command))::!dad_rule_list;; + +let rec remove_if_exists name = function + [] -> false, [] + | ((a,b) as rule1)::tl -> if a = name then + let result1, l = (remove_if_exists name tl) in + true, l + else + let result1, l = remove_if_exists name tl in + result1, (rule1::l);; + +let remove_dad_rule name = + let result1, result2 = remove_if_exists name !dad_rule_list in + if result1 then + failwith("No such name among the drag and drop rules " ^ name) + else + dad_rule_list := result2;; + +let dad_rule_names () = + List.map (function (s,_) -> s) !dad_rule_list;; + +(* this function is inspired from matches_core in pattern.ml *) +let constrain ((n : patvar),(pat : constr_pattern)) sigma = + if List.mem_assoc n sigma then + if pat = (List.assoc n sigma) then sigma + else failwith "internal" + else + (n,pat)::sigma + +(* This function is inspired from matches_core in pattern.ml *) +let more_general_pat pat1 pat2 = + let rec match_rec sigma p1 p2 = + match p1, p2 with + | PMeta (Some n), m -> constrain (n,m) sigma + + | PMeta None, m -> sigma + + | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma + + | PVar v1, PVar v2 when v1 = v2 -> sigma + + | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma + + | PRel n1, PRel n2 when n1 = n2 -> sigma + + | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma + + | PSort (RType _), PSort (RType _) -> sigma + + | PApp (c1,arg1), PApp (c2,arg2) -> + (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 + with Invalid_argument _ -> failwith "internal") + | _ -> failwith "unexpected case in more_general_pat" in + try let _ = match_rec [] pat1 pat2 in true + with Failure "internal" -> false;; + +let more_general r1 r2 = + match r1,r2 with + (_,(patt1,p11,p12,_,_,_)), + (_,(patt2,p21,p22,_,_,_)) -> + (more_general_pat patt1 patt2) & + (is_prefix p11 p21) & (is_prefix p12 p22);; + +let not_less_general r1 r2 = + not (match r1,r2 with + (_,(patt1,p11,p12,_,_,_)), + (_,(patt2,p21,p22,_,_,_)) -> + (more_general_pat patt1 patt2) & + (is_prefix p21 p11) & (is_prefix p22 p12));; + +let rec add_in_list_sorting rule1 = function + [] -> [rule1] + | (b::tl) as this_list -> + if more_general rule1 b then + b::(add_in_list_sorting rule1 tl) + else if not_less_general rule1 b then + let tl2 = add_in_list_sorting_aux rule1 tl in + (match tl2 with + [] -> rule1::this_list + | _ -> b::tl2) + else + rule1::this_list +and add_in_list_sorting_aux rule1 = function + [] -> [] + | b::tl -> + if more_general rule1 b then + b::(add_in_list_sorting rule1 tl) + else + let tl2 = add_in_list_sorting_aux rule1 tl in + (match tl2 with + [] -> [] + | _ -> rule1::tl2);; + +let rec sort_list = function + [] -> [] + | a::l -> add_in_list_sorting a (sort_list l);; + +let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; +let mk_rewrite lr ast = + let b = in_gen rawwit_bool lr in + let cb = in_gen rawwit_constr_with_bindings ((*Ctast.ct_to_ast*) ast,NoBindings) in + TacExtend (zz,"Rewrite",[b;cb]) + +open Vernacexpr + +let dad_status = ref false;; + +let start_dad () = dad_status := true;; + +let add_dad_rule_fn name pat p1 p2 tac = + let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in + add_dad_rule name pat p1 p2 (List.length pr) pr tac;; + +(* To be parsed by camlp4 + +(*i camlp4deps: "parsing/grammar.cma" i*) + +VERNAC COMMAND EXTEND AddDadRule + [ "Add" "Dad" "Rule" string(name) constr(pat) + "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] -> + [ add_dad_rule_fn name pat p1 p2 tac ] +END + +*) + +let mk_id s = mkIdentC (id_of_string s);; +let mkMetaC = mk_dad_meta;; + +add_dad_rule "distributivity-inv" +(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "distributivity1-r" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) +[2; 2; 2; 2] +[] +0 +[] +(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "distributivity1-l" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) +[2; 1; 2; 2] +[] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "associativity" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) +[2; 1] +[] +0 +[] +(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "minus-identity-lr" +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) +[2; 1] +[2; 2] +1 +[2] +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); + +add_dad_rule "minus-identity-rl" +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); + +add_dad_rule "plus-sym-rl" +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "plus-sym-lr" +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) +[2; 1] +[2; 2] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "absorb-0-r-rl" +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) +[2; 2] +[1] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); + +add_dad_rule "absorb-0-r-lr" +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) +[1] +[2; 2] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); + +add_dad_rule "plus-permute-lr" +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) +[2; 1] +[2; 2; 2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "plus-permute-rl" +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) +[2; 2; 2; 1] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; + +vinterp_add "StartDad" + (function + | [] -> + (function () -> start_dad()) + | _ -> errorlabstrm "StartDad" (mt()));; diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli new file mode 100644 index 00000000..f556c192 --- /dev/null +++ b/contrib/interface/dad.mli @@ -0,0 +1,10 @@ +open Proof_type;; +open Tacmach;; +open Topconstr;; + +val dad_rule_names : unit -> string list;; +val start_dad : unit -> unit;; +val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma -> + goal list sigma * validation;; +val add_dad_rule : string -> constr_expr -> (int list) -> (int list) -> + int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;; diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 new file mode 100644 index 00000000..bf596b28 --- /dev/null +++ b/contrib/interface/debug_tac.ml4 @@ -0,0 +1,570 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Ast;; +open Coqast;; +open Tacmach;; +open Tacticals;; +open Proof_trees;; +open Pp;; +open Pptactic;; +open Util;; +open Proof_type;; +open Tacexpr;; +open Genarg;; + +(* Compacting and uncompacting proof commands *) + +type report_tree = + Report_node of bool *int * report_tree list + | Mismatch of int * int + | Tree_fail of report_tree + | Failed of int;; + +type report_card = + Ngoals of int + | Goals_mismatch of int + | Recursive_fail of report_tree + | Fail;; + +type card_holder = report_card ref;; +type report_holder = report_tree list ref;; + +(* This tactical receives an integer and a tactic and checks that the + tactic produces that number of goals. It never fails but signals failure + by updating the boolean reference given as third argument to false. + It is especially suited for use in checked_thens below. *) + +let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic = + fun card_holder count flag t g -> + try + let (gls, v) as result = t g in + let len = List.length (sig_it gls) in + card_holder := + (if len = count then + (flag := true; + Ngoals count) + else + (flag := false; + Goals_mismatch len)); + result + with + e -> card_holder := Fail; + flag := false; + tclIDTAC g;; + +let no_failure = function + [Report_node(true,_,_)] -> true + | _ -> false;; + +let check_subgoals_count2 + : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = + fun card_holder count flag t g -> + let new_report_holder = ref ([] : report_tree list) in + let (gls, v) as result = t new_report_holder g in + let succeeded = no_failure !new_report_holder in + let len = List.length (sig_it gls) in + card_holder := + (if (len = count) & succeeded then + (flag := true; + Ngoals count) + else + (flag := false; + Recursive_fail (List.hd !new_report_holder))); + result;; + +(* +let traceable = function + Node(_, "TACTICLIST", a::b::tl) -> true + | _ -> false;; +*) +let traceable = function + | TacThen _ | TacThens _ -> true + | _ -> false;; + +let rec collect_status = function + Report_node(true,_,_)::tl -> collect_status tl + | [] -> true + | _ -> false;; + +(* This tactical receives a tactic and executes it, reporting information + about success in the report holder and a boolean reference. *) + +let count_subgoals : card_holder -> bool ref -> tactic -> tactic = + fun card_holder flag t g -> + try + let (gls, _) as result = t g in + card_holder := (Ngoals(List.length (sig_it gls))); + flag := true; + result + with + e -> card_holder := Fail; + flag := false; + tclIDTAC g;; + +let count_subgoals2 + : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = + fun card_holder flag t g -> + let new_report_holder = ref([] : report_tree list) in + let (gls, v) as result = t new_report_holder g in + let succeeded = no_failure !new_report_holder in + if succeeded then + (flag := true; + card_holder := Ngoals (List.length (sig_it gls))) + else + (flag := false; + card_holder := Recursive_fail(List.hd !new_report_holder)); + result;; + +let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function +(* + Node(_, "TACTICLIST", [a;Node(_, "TACLIST", l)]) -> + (fun report_holder -> checked_thens report_holder a l) + | Node(_, "TACTICLIST", a::((Node(_, "TACLIST", l))as b)::c::tl) -> + local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl)) + | Node(_, "TACTICLIST", [a;b]) -> + (fun report_holder -> checked_then report_holder a b) + | Node(_, "TACTICLIST", a::b::c::tl) -> + local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl)) + | ast -> + (fun report_holder g -> + try + let (gls, _) as result = Tacinterp.interp ast g in + report_holder := (Report_node(true, List.length (sig_it gls), [])) + ::!report_holder; + result + with e -> (report_holder := (Failed 1)::!report_holder; + tclIDTAC g)) +*) + TacThens (a,l) -> + (fun report_holder -> checked_thens report_holder a l) + | TacThen (a,b) -> + (fun report_holder -> checked_then report_holder a b) + | t -> + (fun report_holder g -> + try + let (gls, _) as result = Tacinterp.eval_tactic t g in + report_holder := (Report_node(true, List.length (sig_it gls), [])) + ::!report_holder; + result + with e -> (report_holder := (Failed 1)::!report_holder; + tclIDTAC g)) + + +(* This tactical receives a tactic and a list of tactics as argument. + It applies the first tactic and then maps the list of tactics to + various produced sub-goals. This tactic will never fail, but reports + are added in the report_holder in the following way: + - In case of partial success, a new report_tree is added to the report_holder + - In case of failure of the first tactic, with no more indications + then Failed 0 is added to the report_holder, + - In case of partial failure of the first tactic then (Failed n) is added to + the report holder. + - In case of success of the first tactic, but count mismatch, then + Mismatch n is added to the report holder. *) + +and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = + (fun report_holder t1 l g -> + let flag = ref true in + let traceable_t1 = traceable t1 in + let card_holder = ref Fail in + let new_holder = ref ([]:report_tree list) in + let tac_t1 = + if traceable_t1 then + (check_subgoals_count2 card_holder (List.length l) + flag (local_interp t1)) + else + (check_subgoals_count card_holder (List.length l) + flag (Tacinterp.eval_tactic t1)) in + let (gls, _) as result = + tclTHEN_i tac_t1 + (fun i -> + if !flag then + (fun g -> + let tac_i = (List.nth l i) in + if traceable tac_i then + local_interp tac_i new_holder g + else + try + let (gls,_) as result = Tacinterp.eval_tactic tac_i g in + let len = List.length (sig_it gls) in + new_holder := + (Report_node(true, len, []))::!new_holder; + result + with + e -> (new_holder := (Failed 1)::!new_holder; + tclIDTAC g)) + else + tclIDTAC) g in + let new_goal_list = sig_it gls in + (if !flag then + report_holder := + (Report_node(collect_status !new_holder, + (List.length new_goal_list), + List.rev !new_holder))::!report_holder + else + report_holder := + (match !card_holder with + Goals_mismatch(n) -> Mismatch(n, List.length l) + | Recursive_fail tr -> Tree_fail tr + | Fail -> Failed 1 + | _ -> errorlabstrm "check_thens" + (str "this case should not happen in check_thens")):: + !report_holder); + result) + +(* This tactical receives two tactics as argument, it executes the + first tactic and applies the second one to all the produced goals, + reporting information about the success of all tactics in the report + holder. It never fails. *) + +and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic = + (fun report_holder t1 t2 g -> + let flag = ref true in + let card_holder = ref Fail in + let tac_t1 = + if traceable t1 then + (count_subgoals2 card_holder flag (local_interp t1)) + else + (count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in + let new_tree_holder = ref ([] : report_tree list) in + let (gls, _) as result = + tclTHEN tac_t1 + (fun (g:goal sigma) -> + if !flag then + if traceable t2 then + local_interp t2 new_tree_holder g + else + try + let (gls, _) as result = Tacinterp.eval_tactic t2 g in + new_tree_holder := + (Report_node(true, List.length (sig_it gls),[])):: + !new_tree_holder; + result + with + e -> + (new_tree_holder := ((Failed 1)::!new_tree_holder); + tclIDTAC g) + else + tclIDTAC g) g in + (if !flag then + report_holder := + (Report_node(collect_status !new_tree_holder, + List.length (sig_it gls), + List.rev !new_tree_holder))::!report_holder + else + report_holder := + (match !card_holder with + Recursive_fail tr -> Tree_fail tr + | Fail -> Failed 1 + | _ -> error "this case should not happen in check_then")::!report_holder); + result);; + +(* This tactic applies the given tactic only to those subgoals designated + by the list of integers given as extra arguments. + *) + +let on_then = function [t1;t2;l] -> + let t1 = out_gen wit_tactic t1 in + let t2 = out_gen wit_tactic t2 in + let l = out_gen (wit_list0 wit_int) l in + tclTHEN_i (Tacinterp.eval_tactic t1) + (fun i -> + if List.mem (i + 1) l then + (Tacinterp.eval_tactic t2) + else + tclIDTAC) + | _ -> anomaly "bad arguments for on_then";; + +let mkOnThen t1 t2 selected_indices = + let a = in_gen rawwit_tactic t1 in + let b = in_gen rawwit_tactic t2 in + let l = in_gen (wit_list0 rawwit_int) selected_indices in + TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));; + +(* Analyzing error reports *) + +(* +let rec select_success n = function + [] -> [] + | Report_node(true,_,_)::tl -> (Num((0,0),n))::select_success (n+1) tl + | _::tl -> select_success (n+1) tl;; +*) +let rec select_success n = function + [] -> [] + | Report_node(true,_,_)::tl -> n::select_success (n+1) tl + | _::tl -> select_success (n+1) tl;; + +(* +let rec expand_tactic = function + Node(loc1, "TACTICLIST", [a;Node(loc2,"TACLIST", l)]) -> + Node(loc1, "TACTICLIST", + [expand_tactic a; + Node(loc2, "TACLIST", List.map expand_tactic l)]) + | Node(loc1, "TACTICLIST", a::((Node(loc2, "TACLIST", l))as b)::c::tl) -> + expand_tactic (Node(loc1, "TACTICLIST", + (Node(loc1, "TACTICLIST", [a;b]))::c::tl)) + | Node(loc1, "TACTICLIST", [a;b]) -> + Node(loc1, "TACTICLIST",[expand_tactic a;expand_tactic b]) + | Node(loc1, "TACTICLIST", a::b::c::tl) -> + expand_tactic (Node(loc1, "TACTICLIST", + (Node(loc1, "TACTICLIST", [a;b]))::c::tl)) + | any -> any;; +*) +(* Useless: already in binary form... +let rec expand_tactic = function + TacThens (a,l) -> TacThens (expand_tactic a, List.map expand_tactic l) + | TacThen (a,b) -> TacThen (expand_tactic a, expand_tactic b) + | any -> any;; +*) + +(* +let rec reconstruct_success_tac ast = + match ast with + Node(_, "TACTICLIST", [a;Node(_,"TACLIST",l)]) -> + (function + Report_node(true, n, l) -> ast + | Report_node(false, n, rl) -> + ope("TACTICLIST",[a;ope("TACLIST", + List.map2 reconstruct_success_tac l rl)]) + | Failed n -> ope("Idtac",[]) + | Tree_fail r -> reconstruct_success_tac a r + | Mismatch (n,p) -> a) + | Node(_, "TACTICLIST", [a;b]) -> + (function + Report_node(true, n, l) -> ast + | Report_node(false, n, rl) -> + let selected_indices = select_success 1 rl in + ope("OnThen", a::b::selected_indices) + | Failed n -> ope("Idtac",[]) + | Tree_fail r -> reconstruct_success_tac a r + | _ -> error "this error case should not happen in a THEN tactic") + | _ -> + (function + Report_node(true, n, l) -> ast + | Failed n -> ope("Idtac",[]) + | _ -> + errorlabstrm + "this error case should not happen on an unknown tactic" + (str "error in reconstruction with " ++ fnl () ++ + (gentacpr ast)));; +*) +let rec reconstruct_success_tac (tac:glob_tactic_expr) = + match tac with + TacThens (a,l) -> + (function + Report_node(true, n, l) -> tac + | Report_node(false, n, rl) -> + TacThens (a,List.map2 reconstruct_success_tac l rl) + | Failed n -> TacId "" + | Tree_fail r -> reconstruct_success_tac a r + | Mismatch (n,p) -> a) + | TacThen (a,b) -> + (function + Report_node(true, n, l) -> tac + | Report_node(false, n, rl) -> + let selected_indices = select_success 1 rl in + TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", + [in_gen globwit_tactic a; + in_gen globwit_tactic b; + in_gen (wit_list0 globwit_int) selected_indices])) + | Failed n -> TacId "" + | Tree_fail r -> reconstruct_success_tac a r + | _ -> error "this error case should not happen in a THEN tactic") + | _ -> + (function + Report_node(true, n, l) -> tac + | Failed n -> TacId "" + | _ -> + errorlabstrm + "this error case should not happen on an unknown tactic" + (str "error in reconstruction with " ++ fnl () ++ + (pr_glob_tactic tac)));; + + +let rec path_to_first_error = function +| Report_node(true, _, l) -> + let rec find_first_error n = function + | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl + | it::tl -> n, it + | [] -> error "no error detected" in + let p, t = find_first_error 1 l in + p::(path_to_first_error t) +| _ -> [];; + +(* +let rec flatten_then_list tail = function + | Node(_, "TACTICLIST", [a;b]) -> + flatten_then_list ((flatten_then b)::tail) a + | ast -> ast::tail +and flatten_then = function + Node(_, "TACTICLIST", [a;b]) -> + ope("TACTICLIST", flatten_then_list [flatten_then b] a) + | Node(_, "TACLIST", l) -> + ope("TACLIST", List.map flatten_then l) + | Node(_, "OnThen", t1::t2::l) -> + ope("OnThen", (flatten_then t1)::(flatten_then t2)::l) + | ast -> ast;; +*) + +let debug_tac = function + [(Tacexp ast)] -> + (fun g -> + let report = ref ([] : report_tree list) in + let result = local_interp ast report g in + let clean_ast = (* expand_tactic *) ast in + let report_tree = + try List.hd !report with + Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in + let success_tac = + reconstruct_success_tac clean_ast report_tree in + let compact_success_tac = (* flatten_then *) success_tac in + msgnl (fnl () ++ + str "========= Successful tactic =============" ++ + fnl () ++ + pr_glob_tactic compact_success_tac ++ fnl () ++ + str "========= End of successful tactic ============"); + result) + | _ -> error "wrong arguments for debug_tac";; + +(* TODO ... used ? +add_tactic "DebugTac" debug_tac;; +*) + +(* +hide_tactic "OnThen" on_then;; +*) +Refiner.add_tactic "OnThen" on_then;; + +(* +let rec clean_path p ast l = + match ast, l with + Node(_, "TACTICLIST", ([_;_] as tacs)), fst::tl -> + fst::(clean_path 0 (List.nth tacs (fst - 1)) tl) + | Node(_, "TACTICLIST", tacs), 2::tl -> + let rank = (List.length tacs) - p in + rank::(clean_path 0 (List.nth tacs (rank - 1)) tl) + | Node(_, "TACTICLIST", tacs), 1::tl -> + clean_path (p+1) ast tl + | Node(_, "TACLIST", tacs), fst::tl -> + fst::(clean_path 0 (List.nth tacs (fst - 1)) tl) + | _, [] -> [] + | _, _ -> failwith "this case should not happen in clean_path";; +*) +let rec clean_path tac l = + match tac, l with + | TacThen (a,b), fst::tl -> + fst::(clean_path (if fst = 1 then a else b) tl) + | TacThens (a,l), 1::tl -> + 1::(clean_path a tl) + | TacThens (a,tacs), 2::fst::tl -> + 2::fst::(clean_path (List.nth tacs (fst - 1)) tl) + | _, [] -> [] + | _, _ -> failwith "this case should not happen in clean_path";; + +let rec report_error + : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> + int list -> tactic = + fun tac the_goal the_ast returned_path path -> + match tac with + TacThens (a,l) -> + let the_card_holder = ref Fail in + let the_flag = ref false in + let the_exn = ref (Failure "") in + tclTHENS + (fun g -> + let result = + check_subgoals_count + the_card_holder + (List.length l) + the_flag + (fun g2 -> + try + (report_error a the_goal the_ast returned_path (1::path) g2) + with + e -> (the_exn := e; raise e)) + g in + if !the_flag then + result + else + (match !the_card_holder with + Fail -> + the_ast := TacThens (!the_ast, l); + raise !the_exn + | Goals_mismatch p -> + the_ast := tac; + returned_path := path; + error ("Wrong number of tactics: expected " ^ + (string_of_int (List.length l)) ^ " received " ^ + (string_of_int p)) + | _ -> error "this should not happen")) + (let rec fold_num n = function + [] -> [] + | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path)):: + (fold_num (n + 1) tl) in + fold_num 1 l) + | TacThen (a,b) -> + let the_count = ref 1 in + tclTHEN + (fun g -> + try + report_error a the_goal the_ast returned_path (1::path) g + with + e -> + (the_ast := TacThen (!the_ast, b); + raise e)) + (fun g -> + try + let result = + report_error b the_goal the_ast returned_path (2::path) g in + the_count := !the_count + 1; + result + with + e -> + if !the_count > 1 then + msgnl + (str "in branch no " ++ int !the_count ++ + str " after tactic " ++ pr_glob_tactic a); + raise e) + | tac -> + (fun g -> + try + Tacinterp.eval_tactic tac g + with + e -> + (the_ast := tac; + the_goal := Some g; + returned_path := path; + raise e));; + +let strip_some = function + Some n -> n + | None -> failwith "No optional value";; + +let descr_first_error tac = + (fun g -> + let the_goal = ref (None : goal sigma option) in + let the_ast = ref tac in + let the_path = ref ([] : int list) in + try + let result = report_error tac the_goal the_ast the_path [] g in + msgnl (str "no Error here"); + result + with + e -> + (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ + fnl () ++ Cerrors.explain_exn e ++ fnl () ++ + fnl () ++ str "on goal" ++ fnl () ++ + pr_goal (sig_it (strip_some !the_goal)) ++ fnl () ++ + str "faulty tactic is" ++ fnl () ++ fnl () ++ + pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ()); + tclIDTAC g)) + +(* TODO ... used ?? +add_tactic "DebugTac2" descr_first_error;; +*) + +(* +TACTIC EXTEND DebugTac2 + [ ??? ] -> [ descr_first_error tac ] +END +*) diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli new file mode 100644 index 00000000..ded714b6 --- /dev/null +++ b/contrib/interface/debug_tac.mli @@ -0,0 +1,6 @@ + +val report_error : Tacexpr.glob_tactic_expr -> + Proof_type.goal Proof_type.sigma option ref -> + Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;; + +val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;; diff --git a/contrib/interface/history.ml b/contrib/interface/history.ml new file mode 100644 index 00000000..f73c2084 --- /dev/null +++ b/contrib/interface/history.ml @@ -0,0 +1,373 @@ +open Paths;; + +type tree = {mutable index : int; + parent : tree option; + path_to_root : int list; + mutable is_open : bool; + mutable sub_proofs : tree list};; + +type prf_info = { + mutable prf_length : int; + mutable ranks_and_goals : (int * int * tree) list; + mutable border : tree list; + prf_struct : tree};; + +let theorem_proofs = ((Hashtbl.create 17): + (string, prf_info) Hashtbl.t);; + + +let rec mk_trees_for_goals path tree rank k n = + if k = (n + 1) then + [] + else + { index = rank; + parent = tree; + path_to_root = k::path; + is_open = true; + sub_proofs = [] } ::(mk_trees_for_goals path tree rank (k+1) n);; + + +let push_command s rank ngoals = + let ({prf_length = this_length; + ranks_and_goals = these_ranks; + border = this_border} as proof_info) = + Hashtbl.find theorem_proofs s in + let rec push_command_aux n = function + [] -> failwith "the given rank was too large" + | a::l -> + if n = 1 then + let {path_to_root = p} = a in + let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in + new_trees,(new_trees@l),a + else + let new_trees, res, this_tree = push_command_aux (n-1) l in + new_trees,(a::res),this_tree in + let new_trees, new_border, this_tree = + push_command_aux rank this_border in + let new_length = this_length + 1 in + begin + proof_info.border <- new_border; + proof_info.prf_length <- new_length; + proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks; + this_tree.index <- new_length; + this_tree.is_open <- false; + this_tree.sub_proofs <- new_trees + end;; + +let get_tree_for_rank thm_name rank = + let {ranks_and_goals=l;prf_length=n} = + Hashtbl.find theorem_proofs thm_name in + let rec get_tree_aux = function + [] -> + failwith + "inconsistent values for thm_name and rank in get_tree_for_rank" + | (_,_,({index=i} as tree))::tl -> + if i = rank then + tree + else + get_tree_aux tl in + get_tree_aux l;; + +let get_path_for_rank thm_name rank = + let {path_to_root=l}=get_tree_for_rank thm_name rank in + l;; + +let rec list_descendants_aux l tree = + let {index = i; is_open = open_status; sub_proofs = tl} = tree in + let res = (List.fold_left list_descendants_aux l tl) in + if open_status then i::res else res;; + +let list_descendants thm_name rank = + list_descendants_aux [] (get_tree_for_rank thm_name rank);; + +let parent_from_rank thm_name rank = + let {parent=mommy} = get_tree_for_rank thm_name rank in + match mommy with + Some x -> Some x.index + | None -> None;; + +let first_child_command thm_name rank = + let {sub_proofs = l} = get_tree_for_rank thm_name rank in + let rec first_child_rec = function + [] -> None + | {index=i;is_open=b}::l -> + if b then + (first_child_rec l) + else + Some i in + first_child_rec l;; + +type index_or_rank = Is_index of int | Is_rank of int;; + +let first_child_command_or_goal thm_name rank = + let proof_info = Hashtbl.find theorem_proofs thm_name in + let {sub_proofs=l}=get_tree_for_rank thm_name rank in + match l with + [] -> None + | ({index=i;is_open=b} as t)::_ -> + if b then + let rec get_rank n = function + [] -> failwith "A goal is lost in first_child_command_or_goal" + | a::l -> + if a==t then + n + else + get_rank (n + 1) l in + Some(Is_rank(get_rank 1 proof_info.border)) + else + Some(Is_index i);; + +let next_sibling thm_name rank = + let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in + match mommy with + None -> None + | Some real_mommy -> + let {sub_proofs=l}=real_mommy in + let rec next_sibling_aux b = function + (opt_first, []) -> + if b then + opt_first + else + failwith "inconsistency detected in next_sibling" + | (opt_first, {is_open=true}::l) -> + next_sibling_aux b (opt_first, l) + | (Some(first),({index=i; is_open=false} as t')::l) -> + if b then + Some i + else + next_sibling_aux (t == t') (Some first,l) + | None,({index=i;is_open=false} as t')::l -> + next_sibling_aux (t == t') ((Some i), l) + in + Some (next_sibling_aux false (None, l));; + + +let prefix l1 l2 = + let l1rev = List.rev l1 in + let l2rev = List.rev l2 in + is_prefix l1rev l2rev;; + +let rec remove_all_prefixes p = function + [] -> [] + | a::l -> + if is_prefix p a then + (remove_all_prefixes p l) + else + a::(remove_all_prefixes p l);; + +let recompute_border tree = + let rec recompute_border_aux tree acc = + let {is_open=b;sub_proofs=l}=tree in + if b then + tree::acc + else + List.fold_right recompute_border_aux l acc in + recompute_border_aux tree [];; + + +let historical_undo thm_name rank = + let ({ranks_and_goals=l} as proof_info)= + Hashtbl.find theorem_proofs thm_name in + let rec undo_aux acc = function + [] -> failwith "bad rank provided for undoing in historical_undo" + | (r, n, ({index=i} as tree))::tl -> + let this_path_reversed = List.rev tree.path_to_root in + let res = remove_all_prefixes this_path_reversed acc in + if i = rank then + begin + proof_info.prf_length <- i-1; + proof_info.ranks_and_goals <- tl; + tree.is_open <- true; + tree.sub_proofs <- []; + proof_info.border <- recompute_border proof_info.prf_struct; + this_path_reversed::res + end + else + begin + tree.is_open <- true; + tree.sub_proofs <- []; + undo_aux (this_path_reversed::res) tl + end + in + List.map List.rev (undo_aux [] l);; + +(* The following function takes a list of trees and compute the + number of elements whose path is lexically smaller or a suffixe of + the path given as a first argument. This works under the precondition that + the list is lexicographically order. *) + +let rec logical_undo_on_border the_tree rev_path = function + [] -> (0,[the_tree]) + | ({path_to_root=p}as tree)::tl -> + let p_rev = List.rev p in + if is_prefix rev_path p_rev then + let (k,res) = (logical_undo_on_border the_tree rev_path tl) in + (k+1,res) + else if lex_smaller p_rev rev_path then + let (k,res) = (logical_undo_on_border the_tree rev_path tl) in + (k,tree::res) + else + (0, the_tree::tree::tl);; + + +let logical_undo thm_name rank = + let ({ranks_and_goals=l; border=last_border} as proof_info)= + Hashtbl.find theorem_proofs thm_name in + let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in + let rev_ref_path = List.rev ref_path in + let rec logical_aux lex_smaller_offset family_width = function + [] -> failwith "this case should never happen in logical_undo" + | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree)):: + tl -> + let this_path_rev = List.rev this_path in + let new_rank, new_offset, new_width, kept = + if is_prefix rev_ref_path this_path_rev then + (r + lex_smaller_offset), lex_smaller_offset, + (family_width + 1 - n), false + else if lex_smaller this_path_rev rev_ref_path then + r, (lex_smaller_offset - 1 + n), family_width, true + else + (r + 1 - family_width+ lex_smaller_offset), + lex_smaller_offset, family_width, true in + if i=rank then + [i,new_rank],[], tl, rank + else + let ranks_undone, ranks_kept, ranks_and_goals, current_rank = + (logical_aux new_offset new_width tl) in + begin + if kept then + begin + tree.index <- current_rank; + ranks_undone, ((i,new_rank)::ranks_kept), + ((new_rank, n, tree)::ranks_and_goals), + (current_rank + 1) + end + else + ((i,new_rank)::ranks_undone), ranks_kept, + ranks_and_goals, current_rank + end in + let number_suffix, new_border = + logical_undo_on_border ref_tree rev_ref_path last_border in + let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, + new_length_plus_one = logical_aux 0 number_suffix l in + let the_goal_index = + let rec compute_goal_index n = function + [] -> failwith "this case should never happen in logical undo (2)" + | {path_to_root=path}::tl -> + if List.rev path = (rev_ref_path) then + n + else + compute_goal_index (n+1) tl in + compute_goal_index 1 new_border in + begin + ref_tree.is_open <- true; + ref_tree.sub_proofs <- []; + proof_info.border <- new_border; + proof_info.ranks_and_goals <- new_ranks_and_goals; + proof_info.prf_length <- new_length_plus_one - 1; + changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, + the_goal_index + end;; + +let start_proof thm_name = + let the_tree = + {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in + Hashtbl.add theorem_proofs thm_name + {prf_length=0; + ranks_and_goals=[]; + border=[the_tree]; + prf_struct=the_tree};; + +let dump_sequence chan s = + match (Hashtbl.find theorem_proofs s) with + {ranks_and_goals=l}-> + let rec dump_rec = function + [] -> () + | (r,n,_)::tl -> + dump_rec tl; + output_string chan (string_of_int r); + output_string chan ","; + output_string chan (string_of_int n); + output_string chan "\n" in + begin + dump_rec l; + output_string chan "end\n" + end;; + + +let proof_info_as_string s = + let res = ref "" in + match (Hashtbl.find theorem_proofs s) with + {prf_struct=tree} -> + let open_goal_counter = ref 0 in + let rec dump_rec = function + {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> + begin + (match the_parent with + None -> + if op then + res := !res ^ "\"open goal\"\n" + | Some {index=j} -> + begin + res := !res ^ (string_of_int j); + res := !res ^ " -> "; + if op then + begin + res := !res ^ "\"open goal "; + open_goal_counter := !open_goal_counter + 1; + res := !res ^ (string_of_int !open_goal_counter); + res := !res ^ "\"\n"; + end + else + begin + res := !res ^ (string_of_int i); + res := !res ^ "\n" + end + end); + List.iter dump_rec trees + end in + dump_rec tree; + !res;; + + +let dump_proof_info chan s = + match (Hashtbl.find theorem_proofs s) with + {prf_struct=tree} -> + let open_goal_counter = ref 0 in + let rec dump_rec = function + {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> + begin + (match the_parent with + None -> + if op then + output_string chan "\"open goal\"\n" + | Some {index=j} -> + begin + output_string chan (string_of_int j); + output_string chan " -> "; + if op then + begin + output_string chan "\"open goal "; + open_goal_counter := !open_goal_counter + 1; + output_string chan (string_of_int !open_goal_counter); + output_string chan "\"\n"; + end + else + begin + output_string chan (string_of_int i); + output_string chan "\n" + end + end); + List.iter dump_rec trees + end in + dump_rec tree;; + +let get_nth_open_path s n = + match Hashtbl.find theorem_proofs s with + {border=l} -> + let {path_to_root=p}=List.nth l (n - 1) in + p;; + +let border_length s = + match Hashtbl.find theorem_proofs s with + {border=l} -> List.length l;; diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli new file mode 100644 index 00000000..053883f0 --- /dev/null +++ b/contrib/interface/history.mli @@ -0,0 +1,12 @@ +type prf_info;; + +val start_proof : string -> unit;; +val historical_undo : string -> int -> int list list +val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int +val dump_sequence : out_channel -> string -> unit +val proof_info_as_string : string -> string +val dump_proof_info : out_channel -> string -> unit +val push_command : string -> int -> int -> unit +val get_path_for_rank : string -> int -> int list +val get_nth_open_path : string -> int -> int list +val border_length : string -> int diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4 new file mode 100755 index 00000000..b5669351 --- /dev/null +++ b/contrib/interface/line_parser.ml4 @@ -0,0 +1,241 @@ +(* line-oriented Syntactic analyser for a Coq parser *) +(* This parser expects a very small number of commands, each given on a complete +line. Some of these commands are then followed by a text fragment terminated +by a precise keyword, which is also expected to appear alone on a line. *) + +(* The main parsing loop procedure is "parser_loop", given at the end of this +file. It read lines one by one and checks whether they can be parsed using +a very simple parser. This very simple parser uses a lexer, which is also given +in this file. + +The lexical analyser: + There are only 5 sorts of tokens *) +type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | + Tlbracket | Trbracket;; + +(* When recognizing identifiers or strings, the lexical analyser accumulates + the characters in a buffer, using the command add_in_buff. To recuperate + the characters, one can use get_buff (this code was inspired by the + code in src/meta/lexer.ml of Coq revision 6.1) *) +let add_in_buff,get_buff = + let buff = ref (String.create 80) in + (fun i x -> + let len = String.length !buff in + if i >= len then (buff := !buff ^ (String.create len);()); + String.set !buff i x; + succ i), + (fun len -> String.sub !buff 0 len);; + +(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*. When arriving here the first + character has already been recognized. *) +let rec ident len = parser + [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] -> + ident (add_in_buff len c) s +| [< >] -> let str = get_buff len in Tid(str);; + +(* While recognizing integers, one constructs directly the integer value. + The ascii code of '0' is important for this. *) +let code0 = Char.code '0';; + +let get_digit c = Char.code c - code0;; + +(* Integers are [0-9]* + The variable intval is the integer value of the text that has already + been recognized. As for identifiers, the first character has already been + recognized. *) + +let rec parse_int intval = parser + [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i +| [< >] -> Tint intval;; + +(* The string lexer is borrowed from the string parser of Coq V6.1 + This may be a problem if convention have changed in Coq, + However this parser is only used to recognize file names which should + not contain too many special characters *) + +let rec spec_char = parser + [< ''n' >] -> '\n' +| [< ''t' >] -> '\t' +| [< ''b' >] -> '\008' +| [< ''r' >] -> '\013' +| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> + Char.chr v +| [< 'x >] -> x + +and spec1 v = parser + [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s +| [< >] -> v +;; + +(* This is the actual string lexical analyser. Strings are + QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used + to represents double quotation characters, that cannot be used + freely, even inside comments. *) + +let rec string len = parser + [< ''"' >] -> len +| [<''\\' ; + len = (parser [< ''\n' >] -> len + | [< c=spec_char >] -> add_in_buff len c); + s >] -> string len s +| [< 'x; s >] -> string (add_in_buff len x) s;; + +(* The lexical analyser repeats the recognized given by next_token: + spaces and tabulations are ignored, identifiers, integers, + strings, opening and closing square brackets. Lexical errors are + ignored ! *) +let rec next_token = parser count + [< '' ' | '\t'; tok = next_token >] -> tok +| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i +| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i +| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len) +| [< ''[' >] -> Tlbracket +| [< '']' >] -> Trbracket +| [< '_ ; x = next_token >] -> x;; + +(* A very simple lexical analyser to recognize a integer value behind + blank characters *) + +let rec next_int = parser count + [< '' ' | '\t'; v = next_int >] -> v +| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] -> + (match i with + Tint n -> n + | _ -> failwith "unexpected branch in next_int");; + +(* This is the actual lexical analyser, implemented as a function on a stream. + It will be used with the Stream.from primitive to construct a function + of type char Stream.t -> simple_token option Stream.t *) +let token_stream cs _ = + try let tok = next_token cs in + Some tok + with Stream.Failure -> None;; + +(* Two of the actions of the parser request that one reads the rest of + the input up to a specific string stop_string. This is done + with a function that transform the input_channel into a pair of + char Stream.t, reading from the input_channel all the lines to + the stop_string first. *) + + +let rec gather_strings stop_string input_channel = + let buff = input_line input_channel in + if buff = stop_string then + [] + else + (buff::(gather_strings stop_string input_channel));; + + +(* the result of this function is supposed to be used in a Stream.from + construction. *) + +let line_list_to_stream string_list = + let count = ref 0 in + let buff = ref "" in + let reserve = ref string_list in + let current_length = ref 0 in + (fun i -> if (i - !count) >= !current_length then + begin + count := !count + !current_length + 1; + match !reserve with + | [] -> None + | s1::rest -> + begin + buff := s1; + current_length := String.length !buff; + reserve := rest; + Some '\n' + end + end + else + Some(String.get !buff (i - !count)));; + + +(* In older revisions of this file you would find a function that + does line oriented breakdown of the input channel without resorting to + a list of lines. However, the need for the list of line appeared when + we wanted to have a channel and a list of strings describing the same + data, one for regular parsing and the other for error recovery. *) + +let channel_to_stream_and_string_list stop_string input_channel = + let string_list = gather_strings stop_string input_channel in + (line_list_to_stream string_list, string_list);; + +let flush_until_end_of_stream char_stream = + Stream.iter (function _ -> ()) char_stream;; + +(* There are only 5 kinds of lines recognized by our little parser. + Unrecognized lines are ignored. *) +type parser_request = + | PRINT_VERSION + | PARSE_STRING of string + (* parse_string <int> [<ident>] then text and && END--OF--DATA *) + | QUIET_PARSE_STRING + (* quiet_parse_string then text and && END--OF--DATA *) + | PARSE_FILE of string + (* parse_file <int> <string> *) + | ADD_PATH of string + (* add_path <int> <string> *) + | ADD_REC_PATH of string * string + (* add_rec_path <int> <string> <ident> *) + | LOAD_SYNTAX of string + (* load_syntax_file <int> <ident> *) + | GARBAGE +;; + +(* The procedure parser_loop should never terminate while the input_channel is + not closed. This procedure receives the functions called for each sentence + as arguments. Thus the code is completely independent from the Coq sources. *) +let parser_loop functions input_channel = + let print_version_action, + parse_string_action, + quiet_parse_string_action, + parse_file_action, + add_path_action, + add_rec_path_action, + load_syntax_action = functions in + let rec parser_loop_rec input_channel = + (let line = input_line input_channel in + let reqid, parser_request = + try + (match Stream.from (token_stream (Stream.of_string line)) with + parser + | [< 'Tid "print_version" >] -> + 0, PRINT_VERSION + | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; + 'Tid phylum ; 'Trbracket >] + -> reqid,PARSE_STRING phylum + | [< 'Tid "quiet_parse_string" >] -> + 0,QUIET_PARSE_STRING + | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] -> + reqid, PARSE_FILE fname + | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ; 'Tid alias >] + -> reqid, ADD_REC_PATH(directory, alias) + | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >] + -> reqid, ADD_PATH directory + | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] -> + reqid, LOAD_SYNTAX module_name + | [< 'Tid "quit_parser" >] -> raise End_of_file + | [< >] -> 0, GARBAGE) + with + Stream.Failure | Stream.Error _ -> 0,GARBAGE in + match parser_request with + PRINT_VERSION -> print_version_action () + | PARSE_STRING phylum -> + let regular_stream, string_list = + channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in + parse_string_action reqid phylum (Stream.from regular_stream) + string_list;() + | QUIET_PARSE_STRING -> + let regular_stream, string_list = + channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in + quiet_parse_string_action + (Stream.from regular_stream);() + | PARSE_FILE file_name -> + parse_file_action reqid file_name + | ADD_PATH path -> add_path_action reqid path + | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias + | LOAD_SYNTAX syn -> load_syntax_action reqid syn + | GARBAGE -> ()); + parser_loop_rec input_channel in + parser_loop_rec input_channel;; diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli new file mode 100644 index 00000000..b0b043c7 --- /dev/null +++ b/contrib/interface/line_parser.mli @@ -0,0 +1,5 @@ +val parser_loop : + (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) * + (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) * + (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c +val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml new file mode 100644 index 00000000..eaff0968 --- /dev/null +++ b/contrib/interface/name_to_ast.ml @@ -0,0 +1,252 @@ +open Sign;; +open Classops;; +open Names;; +open Nameops +open Coqast;; +open Ast;; +open Termast;; +open Term;; +open Impargs;; +open Reduction;; +open Libnames;; +open Libobject;; +open Environ;; +open Declarations;; +open Prettyp;; +open Inductive;; +open Util;; +open Pp;; +open Declare;; +open Nametab +open Vernacexpr;; +open Decl_kinds;; +open Constrextern;; +open Topconstr;; + +(* This function converts the parameter binders of an inductive definition, + in particular you have to be careful to handle each element in the + context containing all previously defined variables. This squeleton + of this procedure is taken from the function print_env in pretty.ml *) +let convert_env = + let convert_binder env (na, b, c) = + match b with + | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) + | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in + let rec cvrec env = function + [] -> [] + | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in + cvrec (Global.env());; + +(* let mib string = + let sp = Nametab.sp_of_id CCI (id_of_string string) in + let lobj = Lib.map_leaf (objsp_of sp) in + let (cmap, _) = outMutualInductive lobj in + Listmap.map cmap CCI;; *) + +(* This function is directly inspired by print_impl_args in pretty.ml *) + +let impl_args_to_string_by_pos = function + [] -> None + | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.") + | l -> Some (" positions " ^ + (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s) + l + " are implicit."));; + +(* This function is directly inspired by implicit_args_id in pretty.ml *) + +let impl_args_to_string l = + impl_args_to_string_by_pos (positions_of_implicits l) + +let implicit_args_id_to_ast_list id l ast_list = + (match impl_args_to_string l with + None -> ast_list + | Some(s) -> CommentString s:: + CommentString ("For " ^ (string_of_id id)):: + ast_list);; + +(* This function construct an ast to enumerate the implicit positions for an + inductive type and its constructors. It is obtained directly from + implicit_args_msg in pretty.ml. *) + +let implicit_args_to_ast_list sp mipv = + let implicit_args_descriptions = + let ast_list = ref [] in + (Array.iteri + (fun i mip -> + let imps = implicits_of_global (IndRef (sp, i)) in + (ast_list := + implicit_args_id_to_ast_list mip.mind_typename imps !ast_list; + Array.iteri + (fun j idc -> + let impls = implicits_of_global + (ConstructRef ((sp,i),j+1)) in + ast_list := + implicit_args_id_to_ast_list idc impls !ast_list) + mip.mind_consnames)) + mipv; + !ast_list) in + match implicit_args_descriptions with + [] -> [] + | _ -> [VernacComments (List.rev implicit_args_descriptions)];; + +let convert_qualid qid = + let d, id = Libnames.repr_qualid qid in + match repr_dirpath d with + [] -> nvar id + | d -> ope("QUALID", List.fold_left (fun l s -> (nvar s)::l) + [nvar id] d);; + +(* This function converts constructors for an inductive definition to a + Coqast.t. It is obtained directly from print_constructors in pretty.ml *) + +let convert_constructors envpar names types = + let array_idC = + array_map2 + (fun n t -> + let coercion_flag = false (* arbitrary *) in + (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) + names types in + Array.to_list array_idC;; + +(* this function converts one inductive type in a possibly multiple inductive + definition *) + +let convert_one_inductive sp tyi = + let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in + let env = Global.env () in + let envpar = push_rel_context params env in + let sp = sp_of_global (IndRef (sp, tyi)) in + ((dummy_loc,basename sp), None, + convert_env(List.rev params), + (extern_constr true envpar arity), + convert_constructors envpar cstrnames cstrtypes);; + +(* This function converts a Mutual inductive definition to a Coqast.t. + It is obtained directly from print_mutual in pretty.ml. However, all + references to kinds have been removed and it treats only CCI stuff. *) + +let mutual_to_ast_list sp mib = + let mipv = (Global.lookup_mind sp).mind_packets in + let _, l = + Array.fold_right + (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in + VernacInductive (mib.mind_finite, l) + :: (implicit_args_to_ast_list sp mipv);; + +let constr_to_ast v = + extern_constr true (Global.env()) v;; + +let implicits_to_ast_list implicits = + match (impl_args_to_string implicits) with + | None -> [] + | Some s -> [VernacComments [CommentString s]];; + +(* +let make_variable_ast name typ implicits = + (ope("VARIABLE", + [string "VARIABLE"; + ope("BINDERLIST", + [ope("BINDER", + [(constr_to_ast (body_of_type typ)); + nvar name])])]))::(implicits_to_ast_list implicits) + ;; +*) +let make_variable_ast name typ implicits = + (VernacAssumption + ((Local,Definitional), + [false,([dummy_loc,name], constr_to_ast (body_of_type typ))])) + ::(implicits_to_ast_list implicits);; + + +let make_definition_ast name c typ implicits = + VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None, + (constr_to_ast c), Some (constr_to_ast (body_of_type typ))), + (fun _ _ -> ())) + ::(implicits_to_ast_list implicits);; + +(* This function is inspired by print_constant *) +let constant_to_ast_list kn = + let cb = Global.lookup_constant kn in + let c = cb.const_body in + let typ = cb.const_type in + let l = implicits_of_global (ConstRef kn) in + (match c with + None -> + make_variable_ast (id_of_label (label kn)) typ l + | Some c1 -> + make_definition_ast (id_of_label (label kn)) (Declarations.force c1) typ l) + +let variable_to_ast_list sp = + let (id, c, v) = get_variable sp in + let l = implicits_of_global (VarRef sp) in + (match c with + None -> + make_variable_ast id v l + | Some c1 -> + make_definition_ast id c1 v l);; + +(* this function is taken from print_inductive in file pretty.ml *) + +let inductive_to_ast_list sp = + let mib = Global.lookup_mind sp in + mutual_to_ast_list sp mib + +(* this function is inspired by print_leaf_entry from pretty.ml *) + +let leaf_entry_to_ast_list ((sp,kn),lobj) = + let tag = object_tag lobj in + match tag with + | "VARIABLE" -> variable_to_ast_list (basename sp) + | "CONSTANT" -> constant_to_ast_list kn + | "INDUCTIVE" -> inductive_to_ast_list kn + | s -> + errorlabstrm + "print" (str ("printing of unrecognized object " ^ + s ^ " has been required"));; + + + + +(* this function is inspired by print_name *) +let name_to_ast ref = + let (loc,qid) = qualid_of_reference ref in + let l = + try + let sp = Nametab.locate_obj qid in + let (sp,lobj) = + let (sp,entry) = + List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None) + in + match entry with + | Lib.Leaf obj -> (sp,obj) + | _ -> raise Not_found + in + leaf_entry_to_ast_list (sp,lobj) + with Not_found -> + try + match Nametab.locate qid with + | ConstRef sp -> constant_to_ast_list sp + | IndRef (sp,_) -> inductive_to_ast_list sp + | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp + | VarRef sp -> variable_to_ast_list sp + with Not_found -> + try (* Var locale de but, pas var de section... donc pas d'implicits *) + let dir,name = repr_qualid qid in + if (repr_dirpath dir) <> [] then raise Not_found; + let (_,c,typ) = Global.lookup_named name in + (match c with + None -> make_variable_ast name typ [] + | Some c1 -> make_definition_ast name c1 typ []) + with Not_found -> + try + let sp = Nametab.locate_syntactic_definition qid in + errorlabstrm "print" + (str "printing of syntax definitions not implemented") + with Not_found -> + errorlabstrm "print" + (pr_qualid qid ++ + spc () ++ str "not a defined object") + in + VernacList (List.map (fun x -> (dummy_loc,x)) l) + diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli new file mode 100644 index 00000000..0eca0a1e --- /dev/null +++ b/contrib/interface/name_to_ast.mli @@ -0,0 +1,2 @@ +val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; +val convert_qualid : Libnames.qualid -> Coqast.t;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml new file mode 100644 index 00000000..3f0b2d2e --- /dev/null +++ b/contrib/interface/parse.ml @@ -0,0 +1,488 @@ +open Util;; +open System;; +open Pp;; +open Libnames;; +open Library;; +open Ascent;; +open Vtp;; +open Xlate;; +open Line_parser;; +open Pcoq;; +open Vernacexpr;; +open Mltop;; + +type parsed_tree = + | P_cl of ct_COMMAND_LIST + | P_c of ct_COMMAND + | P_t of ct_TACTIC_COM + | P_f of ct_FORMULA + | P_id of ct_ID + | P_s of ct_STRING + | P_i of ct_INT;; + +let print_parse_results n msg = + print_string "message\nparsed\n"; + print_int n; + print_string "\n"; + (match msg with + | P_cl x -> fCOMMAND_LIST x + | P_c x -> fCOMMAND x + | P_t x -> fTACTIC_COM x + | P_f x -> fFORMULA x + | P_id x -> fID x + | P_s x -> fSTRING x + | P_i x -> fINT x); + print_string "e\nblabla\n"; + flush stdout;; + +let ctf_SyntaxErrorMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++ + int reqid ++ fnl () ++ + pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; +let ctf_SyntaxWarningMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++ + int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +let ctf_FileErrorMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++ + int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ + fnl ();; + +(* +(*In the code for CoqV6.2, the require_module call is encapsulated in + a function "without_mes_ambig". Here I have supposed that this + function has no effect on parsing *) +let try_require_module import specif names = + try Library.require_module + (if specif = "UNSPECIFIED" then None + else Some (specif = "SPECIFICATION")) + (List.map + (fun name -> + (dummy_loc,Libnames.make_short_qualid (Names.id_of_string name))) + names) + (import = "IMPORT") + with + | e -> msgnl (str "Reinterning of " ++ prlist str names ++ str " failed");; +*) +(* +let try_require_module_from_file import specif name fname = + try Library.require_module_from_file (if specif = "UNSPECIFIED" then None + else Some (specif = "SPECIFICATION")) (Some (Names.id_of_string name)) fname (import = "IMPORT") + with + | e -> msgnl (str "Reinterning of " ++ str name ++ str " failed");; +*) +(* +let execute_when_necessary ast = + (match ast with + | Node (_, "GRAMMAR", ((Nvar (_, s)) :: ((Node (_, "ASTLIST", al)) :: []))) -> + Metasyntax.add_grammar_obj s (List.map Ctast.ct_to_ast al) +(* Obsolete + | Node (_, "TOKEN", ((Str (_, s)) :: [])) -> Metasyntax.add_token_obj s +*) + | Node (_, "Require", + ((Str (_, import)) :: + ((Str (_, specif)) :: l))) -> + let mnames = List.map (function + | (Nvar (_, m)) -> m + | _ -> error "parse_string_action : bad require expression") l in + try_require_module import specif mnames + | Node (_, "RequireFrom", + ((Str (_, import)) :: + ((Str (_, specif)) :: + ((Nvar (_, mname)) :: ((Str (_, file_name)) :: []))))) -> + try_require_module_from_file import specif mname file_name + | _ -> ()); ast;; +*) + +let execute_when_necessary v = + (match v with + | VernacGrammar _ -> Vernacentries.interp v + | VernacOpenCloseScope sc -> Vernacentries.interp v + | VernacRequire (_,_,l) -> + (try + Vernacentries.interp v + with _ -> + let l=prlist_with_sep spc pr_reference l in + msgnl (str "Reinterning of " ++ l ++ str " failed")) + | VernacRequireFrom (_,_,f) -> + (try + Vernacentries.interp v + with _ -> + msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) + | _ -> ()); v;; + +let parse_to_dot = + let rec dot st = match Stream.next st with + | ("", ".") -> () + | ("EOI", "") -> raise End_of_file + | _ -> dot st in + Gram.Entry.of_parser "Coqtoplevel.dot" dot;; + +let rec discard_to_dot stream = + try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with + | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;; + +let rec decompose_string_aux s n = + try let index = String.index_from s n '\n' in + (String.sub s n (index - n)):: + (decompose_string_aux s (index + 1)) + with Not_found -> [String.sub s n ((String.length s) - n)];; + +let decompose_string s n = + match decompose_string_aux s n with + ""::tl -> tl + | a -> a;; + +let make_string_list file_chan fst_pos snd_pos = + let len = (snd_pos - fst_pos) in + let s = String.create len in + begin + seek_in file_chan fst_pos; + really_input file_chan s 0 len; + decompose_string s 0; + end;; + +let rec get_sub_aux string_list snd_pos = + match string_list with + [] -> [] + | s::l -> + let len = String.length s in + if len >= snd_pos then + if snd_pos < 0 then + [] + else + [String.sub s 0 snd_pos] + else + s::(get_sub_aux l (snd_pos - len - 1));; + +let rec get_substring_list string_list fst_pos snd_pos = + match string_list with + [] -> [] + | s::l -> + let len = String.length s in + if fst_pos > len then + get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) + else + (* take into account the fact that carriage returns are not in the *) + (* strings. *) + let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in + if snd_pos > len then + String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2):: + (get_sub_aux l (snd_pos - len - 2)) + else + let gap = (snd_pos - fst_pos2) in + if gap < 0 then + [] + else + [String.sub s (fst_pos2 - 1) gap];; + +(* When parsing a list of commands, we try to recover error messages for + each individual command. *) + +type parse_result = + | ParseOK of Vernacexpr.vernac_expr located option + | ParseError of string * string list + +let embed_string s = + CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s)) + +let make_parse_error_item s l = + CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l)) + +let parse_command_list reqid stream string_list = + let rec parse_whole_stream () = + let this_pos = Stream.count stream in + let first_ast = + try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) + with + | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> + begin + msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); + try + discard_to_dot stream; + msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ + int (Stream.count stream)); +(* + Some( Node(l, "PARSING_ERROR", + List.map Ctast.str + (get_substring_list string_list this_pos + (Stream.count stream)))) +*) + ParseError ("PARSING_ERROR", + get_substring_list string_list this_pos + (Stream.count stream)) + with End_of_file -> ParseOK None + end + | e-> + begin + discard_to_dot stream; +(* + Some(Node((0,0), "PARSING_ERROR2", + List.map Ctast.str + (get_substring_list string_list this_pos + (Stream.count stream)))) +*) + ParseError ("PARSING_ERROR2", + get_substring_list string_list this_pos (Stream.count stream)) + end in + match first_ast with + | ParseOK (Some (loc,ast)) -> + let ast0 = (execute_when_necessary ast) in + (try xlate_vernac ast + with e -> +(* + xlate_vernac + (Node((0,0), "PARSING_ERROR2", + List.map Ctast.str + (get_substring_list string_list this_pos + (Stream.count stream)))))::parse_whole_stream() +*) + make_parse_error_item "PARSING_ERROR2" + (get_substring_list string_list this_pos + (Stream.count stream)))::parse_whole_stream() + | ParseOK None -> [] + | ParseError (s,l) -> + (make_parse_error_item s l)::parse_whole_stream() + in + match parse_whole_stream () with + | first_one::tail -> (P_cl (CT_command_list(first_one, tail))) + | [] -> raise (UserError ("parse_string", (str "empty text.")));; + +(*When parsing a string using a phylum, the string is first transformed + into a Coq Ast using the regular Coq parser, then it is transformed into + the right ascent term using xlate functions, then it is transformed into + a stream, using the right vtp function. There is a special case for commands, + since some of these must be executed!*) +let parse_string_action reqid phylum char_stream string_list = + try let msg = + match phylum with + | "COMMAND_LIST" -> + parse_command_list reqid char_stream string_list + | "COMMAND" -> + P_c + (xlate_vernac + (execute_when_necessary + (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) + | "TACTIC_COM" -> + P_t + (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi + (Gram.parsable char_stream))) + | "FORMULA" -> + P_f + (xlate_formula + (Gram.Entry.parse + (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) + | "ID" -> P_id (CT_ident + (Libnames.string_of_qualid + (snd + (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) + (Gram.parsable char_stream))))) + | "STRING" -> + P_s + (CT_string (Gram.Entry.parse Pcoq.Prim.string + (Gram.parsable char_stream))) + | "INT" -> + P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural + (Gram.parsable char_stream))) + | _ -> error "parse_string_action : bad phylum" in + print_parse_results reqid msg + with + | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> + flush_until_end_of_stream char_stream; + msgnl (ctf_SyntaxErrorMessage reqid + (Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error "match failure")))) + | e -> + flush_until_end_of_stream char_stream; + msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));; + + +let quiet_parse_string_action char_stream = + try let _ = + Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in + () + with + | _ -> flush_until_end_of_stream char_stream; ();; + + +let parse_file_action reqid file_name = + try let file_chan = open_in file_name in + (* file_chan_err, stream_err are the channel and stream used to + get the text when a syntax error occurs *) + let file_chan_err = open_in file_name in + let stream = Stream.of_channel file_chan in + let stream_err = Stream.of_channel file_chan_err in + let rec discard_to_dot () = + try Gram.Entry.parse parse_to_dot (Gram.parsable stream) + with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in + match let rec parse_whole_file () = + let this_pos = Stream.count stream in + match + try + ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) + with + | Stdpp.Exc_located(l,Stream.Error txt) -> + msgnl (ctf_SyntaxWarningMessage reqid + (str "Error with file" ++ spc () ++ + str file_name ++ fnl () ++ + Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error txt)))); + (try + begin + discard_to_dot (); + ParseError ("PARSING_ERROR", + (make_string_list file_chan_err this_pos + (Stream.count stream))) + end + with End_of_file -> ParseOK None) + | e -> + begin + Gram.Entry.parse parse_to_dot (Gram.parsable stream); + ParseError ("PARSING_ERROR2", + (make_string_list file_chan this_pos + (Stream.count stream))) + end + + with + | ParseOK (Some (_,ast)) -> + let ast0=(execute_when_necessary ast) in + let term = + (try xlate_vernac ast + with e -> + print_string ("translation error between " ^ + (string_of_int this_pos) ^ + " " ^ + (string_of_int (Stream.count stream)) ^ + "\n"); + make_parse_error_item "PARSING_ERROR2" + (make_string_list file_chan_err this_pos + (Stream.count stream))) in + term::parse_whole_file () + | ParseOK None -> [] + | ParseError (s,l) -> + (make_parse_error_item s l)::parse_whole_file () in + parse_whole_file () with + | first_one :: tail -> + print_parse_results reqid + (P_cl (CT_command_list (first_one, tail))) + | [] -> raise (UserError ("parse_file_action", str "empty file.")) + with + | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> + msgnl + (ctf_SyntaxErrorMessage reqid + (str "Error with file" ++ spc () ++ str file_name ++ + fnl () ++ + Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error "match failure")))) + | e -> + msgnl + (ctf_SyntaxErrorMessage reqid + (str "Error with file" ++ spc () ++ str file_name ++ + fnl () ++ Cerrors.explain_exn e));; + +let add_rec_path_action reqid string_arg ident_arg = + let directory_name = glob string_arg in + begin + add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) + end;; + + +let add_path_action reqid string_arg = + let directory_name = glob string_arg in + begin + add_path directory_name Names.empty_dirpath + end;; + +let print_version_action () = + msgnl (mt ()); + msgnl (str "$Id: parse.ml,v 1.22 2004/04/21 08:36:58 barras Exp $");; + +let load_syntax_action reqid module_name = + msg (str "loading " ++ str module_name ++ str "... "); + try + (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in + read_library (dummy_loc,qid); + msg (str "opening... "); + Declaremods.import_module false (Nametab.locate_module qid); + msgnl (str "done" ++ fnl ()); + ()) + with + | UserError (label, pp_stream) -> + (*This one may be necessary to make sure that the message won't be indented *) + msgnl (mt ()); + msgnl + (fnl () ++ str "error while loading syntax module " ++ str module_name ++ + str ": " ++ str label ++ fnl () ++ pp_stream) + | e -> + msgnl (mt ()); + msgnl + (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++ + int reqid ++ fnl ()); + ();; + +let coqparser_loop inchan = + (parser_loop : (unit -> unit) * + (int -> string -> char Stream.t -> string list -> unit) * + (char Stream.t -> unit) * (int -> string -> unit) * + (int -> string -> unit) * (int -> string -> string -> unit) * + (int -> string -> unit) -> in_channel -> unit) + (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action, + add_path_action, add_rec_path_action, load_syntax_action) inchan;; + +if !Sys.interactive then () + else +Libobject.relax true; +(let coqdir = + try Sys.getenv "COQDIR" + with Not_found -> + let coqdir = Coq_config.coqlib in + if Sys.file_exists coqdir then + coqdir + else + (msgnl (str "could not find the value of COQDIR"); exit 1) in + begin + add_rec_path (Filename.concat coqdir "theories") + (Names.make_dirpath [Nameops.coq_root]); + add_rec_path (Filename.concat coqdir "contrib") + (Names.make_dirpath [Nameops.coq_root]) + end; +(let vernacrc = + try + Sys.getenv "VERNACRC" + with + Not_found -> + List.fold_left + (fun s1 s2 -> (Filename.concat s1 s2)) + coqdir [ "contrib"; "interface"; "vernacrc"] in + try + (Gramext.warning_verbose := false; + Esyntax.warning_verbose := false; + coqparser_loop (open_in vernacrc)) + with + | End_of_file -> () + | e -> + (msgnl (Cerrors.explain_exn e); + msgnl (str "could not load the VERNACRC file")); + try + msgnl (str vernacrc) + with + e -> ()); +(try let user_vernacrc = + try Some(Sys.getenv "USERVERNACRC") + with + | Not_found as e -> + msgnl (str "no .vernacrc file"); None in + (match user_vernacrc with + Some f -> coqparser_loop (open_in f) + | None -> ()) + with + | End_of_file -> () + | e -> + msgnl (Cerrors.explain_exn e); + msgnl (str "error in your .vernacrc file")); +msgnl (str "Starting Centaur Specialized Parser Loop"); +try + coqparser_loop stdin +with + | End_of_file -> () + | e -> msgnl(Cerrors.explain_exn e)) diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml new file mode 100644 index 00000000..b1244d15 --- /dev/null +++ b/contrib/interface/paths.ml @@ -0,0 +1,26 @@ +let int_list_to_string s l = + List.fold_left + (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) + s + l;; + +(* Given two paths, this function returns the longest common prefix and the + two suffixes. *) +let rec decompose_path + : (int list * int list) -> (int list * int list * int list) = + function + (a::l,b::m) when a = b -> + let (c,p1,p2) = decompose_path (l,m) in + (a::c,p1,p2) + | p1,p2 -> [], p1, p2;; + +let rec is_prefix p1 p2 = match p1,p2 with + [], _ -> true +| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2 +| _ -> false;; + +let rec lex_smaller p1 p2 = match p1,p2 with + [], _ -> true +| a::tl1, b::tl2 when a < b -> true +| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 +| _ -> false;;
\ No newline at end of file diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli new file mode 100644 index 00000000..26620723 --- /dev/null +++ b/contrib/interface/paths.mli @@ -0,0 +1,4 @@ +val decompose_path : (int list * int list) -> (int list * int list * int list);; +val int_list_to_string : string -> int list -> string;; +val is_prefix : int list -> int list -> bool;; +val lex_smaller : int list -> int list -> bool;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml new file mode 100644 index 00000000..e0f88ba6 --- /dev/null +++ b/contrib/interface/pbp.ml @@ -0,0 +1,758 @@ +(* A proof by pointing algorithm. *) +open Util;; +open Names;; +open Term;; +open Tactics;; +open Tacticals;; +open Hipattern;; +open Pattern;; +open Matching;; +open Reduction;; +open Rawterm;; +open Environ;; + +open Proof_trees;; +open Proof_type;; +open Tacmach;; +open Tacexpr;; +open Typing;; +open Pp;; +open Libnames;; +open Genarg;; +open Topconstr;; +open Termops;; + +let zz = Util.dummy_loc;; + +let hyp_radix = id_of_string "H";; + +let next_global_ident = next_global_ident_away true + +(* get_hyp_by_name : goal sigma -> string -> constr, + looks up for an hypothesis (or a global constant), from its name *) +let get_hyp_by_name g name = + let evd = project g in + let env = pf_env g in + try (let judgment = + Pretyping.understand_judgment + evd env (RVar(zz, name)) in + ("hyp",judgment.uj_type)) +(* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... + Loïc *) + with _ -> (let c = Nametab.global (Ident (zz,name)) in + ("cste",type_of (Global.env()) Evd.empty (constr_of_reference c))) +;; + +type pbp_atom = + | PbpTryAssumption of identifier option + | PbpTryClear of identifier list + | PbpGeneralize of identifier * identifier list + | PbpLApply of identifier (* = CutAndApply *) + | PbpIntros of intro_pattern_expr list + | PbpSplit + (* Existential *) + | PbpExists of identifier + (* Or *) + | PbpLeft + | PbpRight + (* Head *) + | PbpApply of identifier + | PbpElim of identifier * identifier list;; + +(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics + [a1]..[an-1] are atomic (or try of an atomic) tactic and produce + exactly one goal, and [an] produces exactly p subgoals + + In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and + produces exactly one subgoal, except the last one which may complete the + goal + + Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion + from atomic to composed tactic +*) + +type pbp_sequence = + | PbpThens of pbp_atom list * pbp_sequence list + | PbpThen of pbp_atom list + +(* This flattens sequences of tactics producing just one subgoal *) +let chain_tactics tl1 = function + | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3) + | PbpThen tl2 -> PbpThen (tl1@tl2) + +type pbp_rule = (identifier list * + identifier list * + bool * + identifier option * + (types, constr) kind_of_term * + int list * + (identifier list -> + identifier list -> + bool -> + identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) -> + pbp_sequence option;; + + +let make_named_intro id = PbpIntros [IntroIdentifier id];; + +let make_clears str_list = PbpThen [PbpTryClear str_list] + +let add_clear_names_if_necessary tactic clear_names = + match clear_names with + [] -> tactic + | l -> chain_tactics [PbpTryClear l] tactic;; + +let make_final_cmd f optname clear_names constr path = + add_clear_names_if_necessary (f optname constr path) clear_names;; + +let (rem_cast:pbp_rule) = function + (a,c,cf,o, Cast(f,_), p, func) -> + Some(func a c cf o (kind_of_term f) p) + | _ -> None;; + +let (forall_intro: pbp_rule) = function + (avoid, + clear_names, + clear_flag, + None, + Prod(Name x, _, body), + (2::path), + f) -> + let x' = next_global_ident x avoid in + Some(chain_tactics [make_named_intro x'] + (f (x'::avoid) + clear_names clear_flag None (kind_of_term body) path)) +| _ -> None;; + +let (imply_intro2: pbp_rule) = function + avoid, clear_names, + clear_flag, None, Prod(Anonymous, _, body), 2::path, f -> + let h' = next_global_ident hyp_radix avoid in + Some(chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) + | _ -> None;; + + +(* +let (imply_intro1: pbp_rule) = function + avoid, clear_names, + clear_flag, None, Prod(Anonymous, prem, body), 1::path, f -> + let h' = next_global_ident hyp_radix avoid in + let str_h' = h' in + Some(chain_tactics [make_named_intro str_h'] + (f (h'::avoid) clear_names clear_flag (Some str_h') + (kind_of_term prem) path)) + | _ -> None;; +*) + +let make_var id = CRef (Ident(zz, id)) + +let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l) + +let make_pbp_pattern x = + make_app (make_var (id_of_string "PBP_META")) + [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] + +let rec make_then = function + | [] -> TacId "" + | [t] -> t + | t1::t2::l -> make_then (TacThen (t1,t2)::l) + +let make_pbp_atomic_tactic = function + | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) + | PbpTryAssumption (Some a) -> + TacTry (TacAtom (zz, TacExact (make_var a))) + | PbpExists x -> + TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x])) + | PbpGeneralize (h,args) -> + let l = List.map make_pbp_pattern args in + TacAtom (zz, TacGeneralize [make_app (make_var h) l]) + | PbpLeft -> TacAtom (zz, TacLeft NoBindings) + | PbpRight -> TacAtom (zz, TacRight NoBindings) + | PbpIntros l -> TacAtom (zz, TacIntroPattern l) + | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) + | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings)) + | PbpElim (hyp_name, names) -> + let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in + TacAtom + (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None)) + | PbpTryClear l -> + TacTry (TacAtom (zz, TacClear (List.map (fun s -> AI (zz,s)) l))) + | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));; + +let rec make_pbp_tactic = function + | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl) + | PbpThens (l,tl) -> + TacThens + (make_then (List.map make_pbp_atomic_tactic l), + List.map make_pbp_tactic tl) + +let (forall_elim: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Name x, _, body), 2::path, f -> + let h' = next_global_ident hyp_radix avoid in + let clear_names' = if clear_flag then h::clear_names else clear_names in + Some + (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h'] + (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path)) + | _ -> None;; + + +let (imply_elim1: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Anonymous, prem, body), 1::path, f -> + let clear_names' = if clear_flag then h::clear_names else clear_names in + let h' = next_global_ident hyp_radix avoid in + let str_h' = (string_of_id h') in + Some(PbpThens + ([PbpLApply h], + [chain_tactics [make_named_intro h'] (make_clears (h::clear_names)); + f avoid clear_names' false None (kind_of_term prem) path])) + | _ -> None;; + + +let (imply_elim2: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Anonymous, prem, body), 2::path, f -> + let clear_names' = if clear_flag then h::clear_names else clear_names in + let h' = next_global_ident hyp_radix avoid in + Some(PbpThens + ([PbpLApply h], + [chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names' false (Some h') + (kind_of_term body) path); + make_clears clear_names])) + | _ -> None;; + +let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s + +let constant dir s = Coqlib.gen_constant "Pbp" ("Init"::dir) s + +let andconstr: unit -> constr = Coqlib.build_coq_and;; +let prodconstr () = constant ["Datatypes"] "prod";; +let exconstr = Coqlib.build_coq_ex;; +let sigconstr () = constant ["Specif"] "sig";; +let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;; +let orconstr = Coqlib.build_coq_or;; +let sumboolconstr = Coqlib.build_coq_sumbool;; +let sumconstr() = constant ["Datatypes"] "sum";; +let notconstr = Coqlib.build_coq_not;; +let notTconstr () = constant ["Logic_Type"] "notT";; + +let is_matching_local a b = is_matching (pattern_of_constr a) b;; + +let rec (or_and_tree_to_intro_pattern: identifier list -> + constr -> int list -> + intro_pattern_expr * identifier list * identifier *constr + * int list * int * int) = +fun avoid c path -> match kind_of_term c, path with + | (App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (andconstr()) oper) or + (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> + let id2 = next_global_ident hyp_radix avoid in + let cont_expr = if a = 1 then c1 else c2 in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in + let patt_list = + if a = 1 then + [cont_patt; IntroIdentifier id2] + else + [IntroIdentifier id2; cont_patt] in + (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, + total_branches) + | (App(oper, [|c1; c2|]), 2::3::path) + when ((is_matching_local (exconstr()) oper) or + (is_matching_local (sigconstr()) oper)) -> + (match (kind_of_term c2) with + Lambda (Name x, _, body) -> + let id1 = next_global_ident x avoid in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id1::avoid) body path in + (IntroOrAndPattern[[IntroIdentifier id1; cont_patt]], + avoid_names, id, c, path, rank, total_branches) + | _ -> assert false) + | (App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (orconstr ()) oper) or + (is_matching_local (sumboolconstr ()) oper) or + (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) -> + let id2 = next_global_ident hyp_radix avoid in + let cont_expr = if a = 1 then c1 else c2 in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in + let new_rank = if a = 1 then rank else rank+1 in + let patt_list = + if a = 1 then + [[cont_patt];[IntroIdentifier id2]] + else + [[IntroIdentifier id2];[cont_patt]] in + (IntroOrAndPattern patt_list, + avoid_names, id, c, path, new_rank, total_branches+1) + | (_, path) -> let id = next_global_ident hyp_radix avoid in + (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; + +let auxiliary_goals clear_names clear_flag this_name n_aux others = + let clear_cmd = + make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in + let rec clear_list = function + 0 -> others + | n -> clear_cmd::(clear_list (n - 1)) in + clear_list n_aux;; + + +let (imply_intro3: pbp_rule) = function + avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body), + 1::path, f -> + let intro_patt, avoid_names, id, c, p, rank, total_branches = + or_and_tree_to_intro_pattern avoid prem path in + if total_branches = 1 then + Some(chain_tactics [PbpIntros [intro_patt]] + (f avoid_names clear_names clear_flag (Some id) + (kind_of_term c) path)) + else + Some + (PbpThens + ([PbpIntros [intro_patt]], + auxiliary_goals clear_names clear_flag id + (rank - 1) + ((f avoid_names clear_names clear_flag (Some id) + (kind_of_term c) path):: + auxiliary_goals clear_names clear_flag id + (total_branches - rank) []))) + | _ -> None;; + + + +let (and_intro: pbp_rule) = function + avoid, clear_names, clear_flag, + None, App(and_oper, [|c1; c2|]), 2::a::path, f + -> + if ((is_matching_local (andconstr()) and_oper) or + (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then + let cont_term = if a = 1 then c1 else c2 in + let cont_cmd = f avoid clear_names false None + (kind_of_term cont_term) path in + let clear_cmd = make_clears clear_names in + let cmds = + (if a = 1 + then [cont_cmd;clear_cmd] + else [clear_cmd;cont_cmd]) in + Some (PbpThens ([PbpSplit],cmds)) + else None + | _ -> None;; + +let exists_from_lambda avoid clear_names clear_flag c2 path f = + match kind_of_term c2 with + Lambda(Name x, _, body) -> + Some (PbpThens ([PbpExists x], + [f avoid clear_names false None (kind_of_term body) path])) + | _ -> None;; + + +let (ex_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(oper, [| c1; c2|]), 2::3::path, f + when (is_matching_local (exconstr ()) oper) + or (is_matching_local (sigconstr ()) oper) -> + exists_from_lambda avoid clear_names clear_flag c2 path f + | _ -> None;; + +let (exT_intro : pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(oper, [| c1; c2|]), 2::2::2::path, f + when (is_matching_local (sigTconstr ()) oper) -> + exists_from_lambda avoid clear_names clear_flag c2 path f + | _ -> None;; + +let (or_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(or_oper, [|c1; c2 |]), 2::a::path, f -> + if ((is_matching_local (orconstr ()) or_oper) or + (is_matching_local (sumboolconstr ()) or_oper) or + (is_matching_local (sumconstr ()) or_oper)) + & (a = 1 or a = 2) then + let cont_term = if a = 1 then c1 else c2 in + let fst_cmd = if a = 1 then PbpLeft else PbpRight in + let cont_cmd = f avoid clear_names false None + (kind_of_term cont_term) path in + Some(chain_tactics [fst_cmd] cont_cmd) + else + None + | _ -> None;; + +let dummy_id = id_of_string "Dummy";; + +let (not_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(not_oper, [|c1|]), 2::1::path, f -> + if(is_matching_local (notconstr ()) not_oper) or + (is_matching_local (notTconstr ()) not_oper) then + let h' = next_global_ident hyp_radix avoid in + Some(chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names false (Some h') + (kind_of_term c1) path)) + else + None + | _ -> None;; + + + + +let elim_with_bindings hyp_name names = + PbpElim (hyp_name, names);; + +(* This function is used to follow down a path, while staying on the spine of + successive products (universal quantifications or implications). + Arguments are the current observed constr object and the path that remains + to be followed, and an integer indicating how many products have already been + crossed. + Result is: + - a list of string indicating the names of universally quantified variables. + - a list of integers indicating the positions of the successive + universally quantified variables. + - an integer indicating the number of non-dependent products. + - the last constr object encountered during the walk down, and + - the remaining path. + + For instance the following session should happen: + let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign())) + (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in + down_prods (tt, [2;2;2], 0) + ---> ["P","x"],[0;1], 1, <<(P x)>>, [] +*) + + +let rec down_prods: (types, constr) kind_of_term * (int list) * int -> + identifier list * (int list) * int * (types, constr) kind_of_term * + (int list) = + function + Prod(Name x, _, body), 2::path, k -> + let res_sl, res_il, res_i, res_cstr, res_p + = down_prods (kind_of_term body, path, k+1) in + x::res_sl, (k::res_il), res_i, res_cstr, res_p + | Prod(Anonymous, _, body), 2::path, k -> + let res_sl, res_il, res_i, res_cstr, res_p + = down_prods (kind_of_term body, path, k+1) in + res_sl, res_il, res_i+1, res_cstr, res_p + | cstr, path, _ -> [], [], 0, cstr, path;; + +exception Pbp_internal of int list;; + +(* This function should be usable to check that a type can be used by the + Apply command. Basically, c is supposed to be the head of some + type, where l gives the ranks of all universally quantified variables. + It check that these universally quantified variables occur in the head. + + The knowledge I have on constr structures is incomplete. +*) +let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = + function c -> function l -> + let rec delete n = function + | [] -> [] + | p::tl -> if n = p then tl else p::(delete n tl) in + let rec check_rec l = function + | App(f, array) -> + Array.fold_left (fun l c -> check_rec l (kind_of_term c)) + (check_rec l (kind_of_term f)) array + | Const _ -> l + | Ind _ -> l + | Construct _ -> l + | Var _ -> l + | Rel p -> + let result = delete p l in + if result = [] then + raise (Pbp_internal []) + else + result + | _ -> raise (Pbp_internal l) in + try + (check_rec l c) = [] + with Pbp_internal l -> l = [];; + +let (mk_db_indices: int list -> int -> int list) = + function int_list -> function nprems -> + let total = (List.length int_list) + nprems in + let rec mk_db_aux = function + [] -> [] + | a::l -> (total - a)::(mk_db_aux l) in + mk_db_aux int_list;; + + +(* This proof-by-pointing rule is quite complicated, as it attempts to foresee + usages of head tactics. A first operation is to follow the path as far + as possible while staying on the spine of products (function down_prods) + and then to check whether the next step will be an elim step. If the + answer is true, then the built command takes advantage of the power of + head tactics. *) + +let (head_tactic_patt: pbp_rule) = function + avoid, clear_names, clear_flag, Some h, cstr, path, f -> + (match down_prods (cstr, path, 0) with + | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path) + when (((is_matching_local (exconstr ()) oper) (* or + (is_matching_local (sigconstr ()) oper) *)) && a = 3) -> + (match (kind_of_term c2) with + Lambda(Name x, _,body) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let x' = next_global_ident x avoid in + let cont_body = + Prod(Name x', c1, + mkProd(Anonymous, body, + mkVar(dummy_id))) in + let cont_tac + = f avoid (h::clear_names) false None + cont_body (2::1::path) in + cont_tac::(auxiliary_goals + clear_names clear_flag + h nprems []))) + | _ -> None) + | (str_list, _, nprems, + App(oper,[|c1|]), 2::1::path) + when + (is_matching_local (notconstr ()) oper) or + (is_matching_local (notTconstr ()) oper) -> + Some(chain_tactics [elim_with_bindings h str_list] + (f avoid clear_names false None (kind_of_term c1) path)) + | (str_list, _, nprems, + App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (andconstr()) oper) or + (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> + let h1 = next_global_ident hyp_radix avoid in + let h2 = next_global_ident hyp_radix (h1::avoid) in + Some(PbpThens + ([elim_with_bindings h str_list], + let cont_body = + if a = 1 then c1 else c2 in + let cont_tac = + f (h2::h1::avoid) (h::clear_names) + false (Some (if 1 = a then h1 else h2)) + (kind_of_term cont_body) path in + (chain_tactics + [make_named_intro h1; make_named_intro h2] + cont_tac):: + (auxiliary_goals clear_names clear_flag h nprems []))) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) + when ((is_matching_local (sigTconstr()) oper)) & a = 2 -> + (match (kind_of_term c2),path with + Lambda(Name x, _,body), (2::path) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let x' = next_global_ident x avoid in + let cont_body = + Prod(Name x', c1, + mkProd(Anonymous, body, + mkVar(dummy_id))) in + let cont_tac + = f avoid (h::clear_names) false None + cont_body (2::1::path) in + cont_tac::(auxiliary_goals + clear_names clear_flag + h nprems []))) + | _ -> None) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) + when ((is_matching_local (orconstr ()) oper) or + (is_matching_local (sumboolconstr ()) oper) or + (is_matching_local (sumconstr ()) oper)) & + (a = 1 or a = 2) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let cont_body = + if a = 1 then c1 else c2 in + (* h' is the name for the new intro *) + let h' = next_global_ident hyp_radix avoid in + let cont_tac = + chain_tactics + [make_named_intro h'] + (f + (* h' should not be used again *) + (h'::avoid) + (* the disjunct itself can be discarded *) + (h::clear_names) false (Some h') + (kind_of_term cont_body) path) in + let snd_tac = + chain_tactics + [make_named_intro h'] + (make_clears (h::clear_names)) in + let tacs1 = + if a = 1 then + [cont_tac; snd_tac] + else + [snd_tac; cont_tac] in + tacs1@(auxiliary_goals (h::clear_names) + false dummy_id nprems []))) + | (str_list, int_list, nprems, c, []) + when (check_apply c (mk_db_indices int_list nprems)) & + (match c with Prod(_,_,_) -> false + | _ -> true) & + (List.length int_list) + nprems > 0 -> + Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) + | _ -> None) + | _ -> None;; + + +let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; + forall_elim; imply_intro3; imply_elim1; imply_elim2; + and_intro; or_intro; not_intro; ex_intro; exT_intro];; + + +let try_trace = ref true;; + +let traced_try (f1:tactic) g = + try (try_trace := true; tclPROGRESS f1 g) + with e when Logic.catchable_exception e -> + (try_trace := false; tclIDTAC g);; + +let traced_try_entry = function + [Tacexp t] -> + traced_try (Tacinterp.interp t) + | _ -> failwith "traced_try_entry received wrong arguments";; + + +(* When the recursive descent along the path is over, one includes the + command requested by the point-and-shoot strategy. Default is + Try Assumption--Try Exact. *) + + +let default_ast optname constr path = PbpThen [PbpTryAssumption optname] + +(* This is the main proof by pointing function. *) +(* avoid: les noms a ne pas utiliser *) +(* final_cmd: la fonction appelee par defaut *) +(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *) + +let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = + let rec try_all_rules rl = + match rl with + f::tl -> + (match f (avoid, clear_names, clear_flag, + opt_name, constr, path, pbpt final_cmd) with + Some(ast) -> ast + | None -> try_all_rules tl) + | [] -> make_final_cmd final_cmd opt_name clear_names constr path + in try_all_rules (!pbp_rules);; + +(* these are the optimisation functions. *) +(* This function takes care of flattening successive then commands. *) + + +(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy + that t is some [PbpAtom t] *) + +(* This optimization function takes care of compacting successive Intro commands + together. *) + +let rec group_intros names = function + [] -> (match names with + [] -> [] + | l -> [PbpIntros l]) + | (PbpIntros ids)::others -> group_intros (names@ids) others + | t1::others -> + (match names with + [] -> t1::(group_intros [] others) + | l -> (PbpIntros l)::t1::(group_intros [] others)) + +let rec optim2 = function + | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2) + | PbpThen tl -> PbpThen (group_intros [] tl) + + +let rec cleanup_clears str_list = function + [] -> [] + | x::tail -> + if List.mem x str_list then cleanup_clears str_list tail + else x::(cleanup_clears str_list tail);; + +(* This function takes care of compacting instanciations of universal + quantifications. *) + +let rec optim3_aux str_list = function + (PbpGeneralize (h,l1)):: + (PbpIntros [IntroIdentifier s])::(PbpGeneralize (h',l2))::others + when s=h' -> + optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others) + | (PbpTryClear names)::other -> + (match cleanup_clears str_list names with + [] -> other + | l -> (PbpTryClear l)::other) + | a::l -> a::(optim3_aux str_list l) + | [] -> [];; + +let rec optim3 str_list = function + PbpThens (tl1, tl2) -> + PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2) + | PbpThen tl -> PbpThen (optim3_aux str_list tl) + +let optim x = make_pbp_tactic (optim3 [] (optim2 x));; + +(* TODO +add_tactic "Traced_Try" traced_try_entry;; +*) + +let rec tactic_args_to_ints = function + [] -> [] + | (Integer n)::l -> n::(tactic_args_to_ints l) + | _ -> failwith "expecting only numbers";; + +(* +let pbp_tac display_function = function + (Identifier a)::l -> + (function g -> + let str = (string_of_id a) in + let (ou,tstr) = (get_hyp_by_name g str) in + let exp_ast = + pbpt default_ast + (match ou with + "hyp" ->(pf_ids_of_hyps g) + |_ -> (a::(pf_ids_of_hyps g))) + [] + false + (Some str) + (kind_of_term tstr) + (tactic_args_to_ints l) in + (display_function (optim exp_ast); + tclIDTAC g)) + | ((Integer n)::_) as l -> + (function g -> + let exp_ast = + (pbpt default_ast (pf_ids_of_hyps g) [] false + None (kind_of_term (pf_concl g)) + (tactic_args_to_ints l)) in + (display_function (optim exp_ast); + tclIDTAC g)) + | [] -> (function g -> + (display_function (default_ast None (pf_concl g) []); + tclIDTAC g)) + | _ -> failwith "expecting other arguments";; + + +*) +let pbp_tac display_function idopt nl = + match idopt with + | Some str -> + (function g -> + let (ou,tstr) = (get_hyp_by_name g str) in + let exp_ast = + pbpt default_ast + (match ou with + "hyp" ->(pf_ids_of_hyps g) + |_ -> (str::(pf_ids_of_hyps g))) + [] + false + (Some str) + (kind_of_term tstr) + nl in + (display_function (optim exp_ast); tclIDTAC g)) + | None -> + if nl <> [] then + (function g -> + let exp_ast = + (pbpt default_ast (pf_ids_of_hyps g) [] false + None (kind_of_term (pf_concl g)) nl) in + (display_function (optim exp_ast); tclIDTAC g)) + else + (function g -> + (display_function + (make_pbp_tactic (default_ast None (pf_concl g) [])); + tclIDTAC g));; + + diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli new file mode 100644 index 00000000..43ec1274 --- /dev/null +++ b/contrib/interface/pbp.mli @@ -0,0 +1,4 @@ +val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) -> + Names.identifier option -> int list -> + Proof_type.goal Tacmach.sigma -> + Proof_type.goal list Proof_type.sigma * Proof_type.validation;; diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml new file mode 100644 index 00000000..5b265ec8 --- /dev/null +++ b/contrib/interface/showproof.ml @@ -0,0 +1,1899 @@ +(* +#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; +open Coqast;; +*) +open Environ +open Evd +open Names +open Nameops +open Libnames +open Term +open Termops +open Util +open Proof_type +open Coqast +open Pfedit +open Translate +open Term +open Reductionops +open Clenv +open Typing +open Inductive +open Inductiveops +open Vernacinterp +open Declarations +open Showproof_ct +open Proof_trees +open Sign +open Pp +open Printer +open Rawterm +open Tacexpr +open Genarg +(*****************************************************************************) +(* + Arbre de preuve maison: + +*) + +(* hypotheses *) + +type nhyp = {hyp_name : identifier; + hyp_type : Term.constr; + hyp_full_type: Term.constr} +;; + +type ntactic = tactic_expr +;; + +type nproof = + Notproved + | Proof of ntactic * (ntree list) + +and ngoal= + {newhyp : nhyp list; + t_concl : Term.constr; + t_full_concl: Term.constr; + t_full_env: Sign.named_context} +and ntree= + {t_info:string; + t_goal:ngoal; + t_proof : nproof} +;; + + +let hyps {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = lh +;; + +let concl {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = g +;; + +let proof {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = p +;; +let g_env {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = ge +;; +let sub_ntrees t = + match (proof t) with + Notproved -> [] + | Proof (_,l) -> l +;; + +let tactic t = + match (proof t) with + Notproved -> failwith "no tactic applied" + | Proof (t,_) -> t +;; + + +(* +un arbre est clos s'il ne contient pas de sous-but non prouves, +ou bien s'il a un cousin gauche qui n'est pas clos +ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. +*) +let update_closed nt = + let found_not_closed=ref false in + let rec update {t_info=b; t_goal=g; t_proof =p} = + if !found_not_closed + then {t_info="to_prove"; t_goal=g; t_proof =p} + else + match p with + Notproved -> found_not_closed:=true; + {t_info="not_proved"; t_goal=g; t_proof =p} + | Proof(tac,lt) -> + let lt1=List.map update lt in + let b=ref "proved" in + (List.iter + (fun x -> + if x.t_info ="not_proved" then b:="not_proved") lt1; + {t_info=(!b); + t_goal=g; + t_proof=Proof(tac,lt1)}) + in update nt + ;; + + +(* + type complet avec les hypotheses. +*) + +let long_type_hyp lh t= + let t=ref t in + List.iter (fun (n,th) -> + let ni = match n with Name ni -> ni | _ -> assert false in + t:= mkProd(n,th,subst_term (mkVar ni) !t)) + (List.rev lh); + !t +;; + +(* let long_type_hyp x y = y;; *) + +(* Expansion des tactikelles *) + +let seq_to_lnhyp sign sign' cl = + let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in + let nh=List.map (fun (id,c,ty) -> + {hyp_name=id; + hyp_type=ty; + hyp_full_type= + let res= long_type_hyp !lh ty in + lh:=(!lh)@[(Name id,ty)]; + res}) + sign' + in + {newhyp=nh; + t_concl=cl; + t_full_concl=long_type_hyp !lh cl; + t_full_env = sign@sign'} +;; + + +let rule_is_complex r = + match r with + Tactic (TacArg (Tacexp t),_) -> true + | Tactic (TacAtom (_,TacAuto _), _) -> true + | Tactic (TacAtom (_,TacSymmetry _), _) -> true + |_ -> false +;; + +let ast_of_constr = Termast.ast_of_constr true (Global.env()) ;; + +(* +let rule_to_ntactic r = + let rast = + (match r with + Tactic (s,l) -> + Ast.ope (s,(List.map ast_of_cvt_arg l)) + | Prim (Refine h) -> + Ast.ope ("Exact", + [Node ((0,0), "COMMAND", [ast_of_constr h])]) + | _ -> Ast.ope ("Intros",[])) in + if rule_is_complex r + then (match rast with + Node(_,_,[Node(_,_,[Node(_,_,x)])]) ->x + | _ -> assert false) + + else [rast ] +;; +*) +let rule_to_ntactic r = + let rt = + (match r with + Tactic (t,_) -> t + | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) + | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in + if rule_is_complex r + then (match rt with + TacArg (Tacexp _) as t -> t + | _ -> assert false) + + else rt +;; + +(* +let term_of_command x = + match x with + Node(_,_,y::_) -> y + | _ -> x +;; +*) + +(* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt *) + + +let fill_unproved nt l = + let lnt = ref l in + let rec fill nt = + let {t_goal=g;t_proof=p}=nt in + match p with + Notproved -> let p=List.hd (!lnt) in + lnt:=List.tl (!lnt); + {t_info="to_prove";t_goal=g;t_proof=p} + |Proof(tac,lt) -> + {t_info="to_prove";t_goal=g; + t_proof=Proof(tac,List.map fill lt)} + in fill nt +;; +(* Differences entre signatures *) + +let new_sign osign sign = + let res=ref [] in + List.iter (fun (id,c,ty) -> + try (let (_,_,ty1)= (lookup_named id osign) in + ()) + with Not_found -> res:=(id,c,ty)::(!res)) + sign; + !res +;; + +let old_sign osign sign = + let res=ref [] in + List.iter (fun (id,c,ty) -> + try (let (_,_,ty1) = (lookup_named id osign) in + if ty1 = ty then res:=(id,c,ty)::(!res)) + with Not_found -> ()) + sign; + !res +;; + +(* convertit l'arbre de preuve courant en ntree *) +let to_nproof sigma osign pf = + let rec to_nproof_rec sigma osign pf = + let {evar_hyps=sign;evar_concl=cl} = pf.goal in + let nsign = new_sign osign sign in + let oldsign = old_sign osign sign in + match pf.ref with + + None -> {t_info="to_prove"; + t_goal=(seq_to_lnhyp oldsign nsign cl); + t_proof=Notproved} + | Some(r,spfl) -> + if rule_is_complex r + then ( + let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in + let ntree= fill_unproved p1 + (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) + spfl) in + (match r with + Tactic (TacAtom (_, TacAuto _),_) -> + if spfl=[] + then + {t_info="to_prove"; + t_goal= {newhyp=[]; + t_concl=concl ntree; + t_full_concl=ntree.t_goal.t_full_concl; + t_full_env=ntree.t_goal.t_full_env}; + t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} + else ntree + | _ -> ntree)) + else + {t_info="to_prove"; + t_goal=(seq_to_lnhyp oldsign nsign cl); + t_proof=(Proof (rule_to_ntactic r, + List.map (fun x -> to_nproof_rec sigma sign x) spfl))} + in update_closed (to_nproof_rec sigma osign pf) + ;; + +(* + recupere l'arbre de preuve courant. +*) + +let get_nproof () = + to_nproof (Global.env()) [] + (Tacmach.proof_of_pftreestate (get_pftreestate())) +;; + + +(*****************************************************************************) +(* + Pprinter +*) + +let pr_void () = sphs "";; + +let list_rem l = match l with [] -> [] |x::l1->l1;; + +(* liste de chaines *) +let prls l = + let res = ref (sps (List.hd l)) in + List.iter (fun s -> + res:= sphv [ !res; spb; sps s]) (list_rem l); + !res +;; + +let prphrases f l = + spv (List.map (fun s -> sphv [f s; sps ","]) l) +;; + +(* indentation *) +let spi = spnb 3;; + +(* en colonne *) +let prl f l = + if l=[] then spe else spv (List.map f l);; +(*en colonne, avec indentation *) +let prli f l = + if l=[] then spe else sph [spi; spv (List.map f l)];; + +(* + Langues. +*) + +let rand l = + List.nth l (Random.int (List.length l)) +;; + +type natural_languages = French | English;; +let natural_language = ref French;; + +(*****************************************************************************) +(* + Les liens html pour proof-by-pointing +*) + +(* le path du but en cours. *) + +let path=ref[1];; + +let ftag_apply =ref (fun (n:string) t -> spt t);; + +let ftag_case =ref (fun n -> sps n);; + +let ftag_elim =ref (fun n -> sps n);; + +let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);; + +let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);; + +let ftag_uselemma =ref (fun h t -> + let intro = match !natural_language with + French -> "par" + | English -> "by" + in + spuselemma intro h t);; + +let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);; + +let tag_apply = !ftag_apply;; + +let tag_case = !ftag_case;; + +let tag_elim = !ftag_elim;; + +let tag_uselemma = !ftag_uselemma;; + +let tag_hyp = !ftag_hyp;; + +let tag_hypt = !ftag_hypt;; + +let tag_toprove = !ftag_toprove;; + +(*****************************************************************************) + +(* pluriel *) +let txtn n s = + if n=1 then s + else match s with + |"un" -> "des" + |"a" -> "" + |"an" -> "" + |"une" -> "des" + |"Soit" -> "Soient" + |"Let" -> "Let" + | s -> s^"s" +;; + +let _et () = match !natural_language with + French -> sps "et" +| English -> sps "and" +;; + +let name_count = ref 0;; +let new_name () = + name_count:=(!name_count)+1; + string_of_int !name_count +;; + +let enumerate f ln = + match ln with + [] -> [] + | [x] -> [f x] + |ln -> + let rec enum_rec f ln = + (match ln with + [x;y] -> [f x; spb; sph [_et ();spb;f y]] + |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) + | _ -> assert false) + in enum_rec f ln +;; + + +let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; + +(* +let sp_tac tac = + try spt (constr_of_ast (term_of_command tac)) + with _ -> (* let Node(_,t,_) = tac in *) + spe (* sps ("error in sp_tac " ^ t) *) +;; +*) +let sp_tac tac = failwith "TODO" + +let soit_A_une_proposition nh ln t= match !natural_language with + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "une";txtn nh "proposition"]]) +| English -> + sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]]) +;; + +let on_a ()= match !natural_language with + French -> rand ["on a "] +| English ->rand ["we have "] +;; + +let bon_a ()= match !natural_language with + French -> rand ["On a "] +| English ->rand ["We have "] +;; + +let soit_X_un_element_de_T nh ln t = match !natural_language with + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "un";txtn nh "élément";"de"]] + @[spb; spt t]) +| English -> + sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]] + @[spb; spt t]) +;; + +let soit_F_une_fonction_de_type_T nh ln t = match !natural_language with + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]] + @[spb; spt t]) +| English -> + sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]] + @[spb; spt t]) +;; + + +let telle_que nh = match !natural_language with + French -> [prls [" ";txtn nh "telle";"que";" "]] +| English -> [prls [" "; "such";"that";" "]] +;; + +let tel_que nh = match !natural_language with + French -> [prls [" ";txtn nh "tel";"que";" "]] +| English -> [prls [" ";"such";"that";" "]] +;; + +let supposons () = match !natural_language with + French -> "Supposons " +| English -> "Suppose " +;; + +let cas () = match !natural_language with + French -> "Cas" +| English -> "Case" +;; + +let donnons_une_proposition () = match !natural_language with + French -> sph[ (prls ["Donnons";"une";"proposition"])] +| English -> sph[ (prls ["Let us give";"a";"proposition"])] +;; + +let montrons g = match !natural_language with + French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]); + spb; spt g; sps ". "] +| English -> sph[ sps (rand ["Let us";"Now"]);spb; + sps (rand ["prove";"show"]); + spb; spt g; sps ". "] +;; + +let calculons_un_element_de g = match !natural_language with + French -> sph[ (prls ["Calculons";"un";"élément";"de"]); + spb; spt g; sps ". "] +| English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]); + spb; spt g; sps ". "] +;; + +let calculons_une_fonction_de_type g = match !natural_language with + French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]); + spb; spt g; sps ". "] +| English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]); + spb; spt g; sps ". "];; + +let en_simplifiant_on_obtient g = match !natural_language with + French -> + sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"]; + rand ["on doit";"il reste à"]; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English -> + sphv [ (prls [rand ["After simplification,"; "Simplifying,"]; + rand ["we must";"it remains to"]; + rand ["prove";"show"]]); + spb; spt g; sps ". "] ;; + +let on_obtient g = match !natural_language with + French -> sph[ (prls [rand ["on doit";"il reste à"]; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English ->sph[ (prls [rand ["we must";"it remains to"]; + rand ["prove";"show"]]); + spb; spt g; sps ". "] +;; + +let reste_a_montrer g = match !natural_language with + French -> sph[ (prls ["Reste";"à"; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English -> sph[ (prls ["It remains";"to"; + rand ["prove";"show"]]); + spb; spt g; sps ". "] +;; + +let discutons_avec_A type_arg = match !natural_language with + French -> sphv [sps "Discutons"; spb; sps "avec"; spb; + spt type_arg; sps ":"] +| English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; + spt type_arg; sps ":"] +;; + +let utilisons_A arg1 = match !natural_language with + French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); + spb; spt arg1; sps ":"] +| English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); + spb; spt arg1; sps ":"] +;; + +let selon_les_valeurs_de_A arg1 = match !natural_language with + French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); + spb; spt arg1; sps ":"] +| English -> sphv [ (prls ["According";"values";"of"]); + spb; spt arg1; sps ":"] +;; + +let de_A_on_a arg1 = match !natural_language with + French -> sphv [ sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb; + sps (rand ["on a:";"on déduit:";"on obtient:"])] +| English -> sphv [ sps (rand ["From";"With";"Thanks to"]); spb; + spt arg1; spb; + sps (rand ["we have:";"we deduce:";"we obtain:"])] +;; + + +let procedons_par_recurrence_sur_A arg1 = match !natural_language with + French -> sphv [ (prls ["Procédons";"par";"récurrence";"sur"]); + spb; spt arg1; sps ":"] +| English -> sphv [ (prls ["By";"induction";"on"]); + spb; spt arg1; sps ":"] +;; + + +let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A + nfun tfun narg = match !natural_language with + French -> sphv [ + sphv [ prls ["Calculons";"la";"fonction"]; + spb; sps (string_of_id nfun);spb; + prls ["de";"type"]; + spb; spt tfun;spb; + prls ["par";"récurrence";"sur";"son";"argument"]; + spb; sps (string_of_int narg); sps ":"] + ] +| English -> sphv [ + sphv [ prls ["Let us compute";"the";"function"]; + spb; sps (string_of_id nfun);spb; + prls ["of";"type"]; + spb; spt tfun;spb; + prls ["by";"induction";"on";"its";"argument"]; + spb; sps (string_of_int narg); sps ":"] + ] + +;; +let pour_montrer_G_la_valeur_recherchee_est_A g arg1 = + match !natural_language with + French -> sph [sps "Pour";spb;sps "montrer"; spt g; spb; + sps ","; spb; sps "choisissons";spb; + spt arg1;sps ". " ] +| English -> sph [sps "In order to";spb;sps "show"; spt g; spb; + sps ","; spb; sps "let us choose";spb; + spt arg1;sps ". " ] +;; + +let on_se_sert_de_A arg1 = match !natural_language with + French -> sph [sps "On se sert de";spb ;spt arg1;sps ":" ] +| English -> sph [sps "We use";spb ;spt arg1;sps ":" ] +;; + + +let d_ou_A g = match !natural_language with + French -> sph [spi; sps "d'où";spb ;spt g;sps ". " ] +| English -> sph [spi; sps "then";spb ;spt g;sps ". " ] +;; + + +let coq_le_demontre_seul () = match !natural_language with + French -> rand [prls ["Coq";"le";"démontre"; "seul."]; + sps "Fastoche."; + sps "Trop cool"] +| English -> rand [prls ["Coq";"shows";"it"; "alone."]; + sps "Fingers in the nose."] +;; + +let de_A_on_deduit_donc_B arg g = match !natural_language with + French -> sph + [ sps "De"; spb; spt arg; spb; sps "on";spb; + sps "déduit";spb; sps "donc";spb; spt g ] +| English -> sph + [ sps "From"; spb; spt arg; spb; sps "we";spb; + sps "deduce";spb; sps "then";spb; spt g ] +;; + +let _A_est_immediat_par_B g arg = match !natural_language with + French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); + spb; spt arg ] +| English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); + spb; spt arg ] +;; + +let le_resultat_est arg = match !natural_language with + French -> sph [ (prls ["le";"résultat";"est"]); + spb; spt arg ] +| English -> sph [ (prls ["the";"result";"is"]); + spb; spt arg ];; + +let on_applique_la_tactique tactic tac = match !natural_language with + French -> sphv + [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] +| English -> sphv + [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] +;; + +let de_A_il_vient_B arg g = match !natural_language with + French -> sph + [ sps "De"; spb; spt arg; spb; + sps "il";spb; sps "vient";spb; spt g; sps ". " ] +| English -> sph + [ sps "From"; spb; spt arg; spb; + sps "it";spb; sps "comes";spb; spt g; sps ". " ] +;; + +let ce_qui_est_trivial () = match !natural_language with + French -> sps "Trivial." +| English -> sps "Trivial." +;; + +let en_utilisant_l_egalite_A arg = match !natural_language with + French -> sphv [ sps "En"; spb;sps "utilisant"; spb; + sps "l'egalite"; spb; spt arg; sps "," + ] +| English -> sphv [ sps "Using"; spb; + sps "the equality"; spb; spt arg; sps "," + ] +;; + +let simplifions_H_T hyp thyp = match !natural_language with + French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:"; + spb;spt thyp;sps "."] +| English -> sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:"; + spb;spt thyp;sps "."] +;; + +let grace_a_A_il_suffit_de_montrer_LA arg lg= + match !natural_language with + French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb; + spt arg;sps ",";spb; + sps "il suffit";spb; sps "de"; spb; + sps (rand["prouver";"montrer";"démontrer"]); spb] + @[spv (enumerate (fun x->x) lg)]) +| English -> sphv ([sps (rand ["Thanks to";"With"]);spb; + spt arg;sps ",";spb; + sps "it suffices";spb; sps "to"; spb; + sps (rand["prove";"show"]); spb] + @[spv (enumerate (fun x->x) lg)]) +;; +let reste_a_montrer_LA lg= + match !natural_language with + French -> sphv ([ sps "Il reste";spb; sps "à"; spb; + sps (rand["prouver";"montrer";"démontrer"]); spb] + @[spv (enumerate (fun x->x) lg)]) +| English -> sphv ([ sps "It remains";spb; sps "to"; spb; + sps (rand["prove";"show"]); spb] + @[spv (enumerate (fun x->x) lg)]) +;; +(*****************************************************************************) +(* + Traduction des hypothèses. +*) + +type n_sort= + Nprop + | Nformula + | Ntype + | Nfunction +;; + + +let sort_of_type t ts = + let t=(strip_outer_cast t) in + if is_Prop t + then Nprop + else + match ts with + Prop(Null) -> Nformula + |_ -> (match (kind_of_term t) with + Prod(_,_,_) -> Nfunction + |_ -> Ntype) +;; + +let adrel (x,t) e = + match x with + Name(xid) -> Environ.push_rel (x,None,t) e + | Anonymous -> Environ.push_rel (x,None,t) e + +let rec nsortrec vl x = + match (kind_of_term x) with + Prod(n,t,c)-> + let vl = (adrel (n,t) vl) in nsortrec vl c + | Lambda(n,t,c) -> + let vl = (adrel (n,t) vl) in nsortrec vl c + | App(f,args) -> nsortrec vl f + | Sort(Prop(Null)) -> Prop(Null) + | Sort(c) -> c + | Ind(ind) -> + let (mib,mip) = lookup_mind_specif vl ind in + mip.mind_sort + | Construct(c) -> + nsortrec vl (mkInd (inductive_of_constructor c)) + | Case(_,x,t,a) + -> nsortrec vl x + | Cast(x,t)-> nsortrec vl t + | Const c -> nsortrec vl (lookup_constant c vl).const_type + | _ -> nsortrec vl (type_of vl Evd.empty x) +;; +let nsort x = + nsortrec (Global.env()) (strip_outer_cast x) +;; + +let sort_of_hyp h = + (sort_of_type h.hyp_type (nsort h.hyp_full_type)) +;; + +(* grouper les hypotheses successives de meme type, ou logiques. + donne une liste de liste *) +let rec group_lhyp lh = + match lh with + [] -> [] + |[h] -> [[h]] + |h::lh -> + match group_lhyp lh with + (h1::lh1)::lh2 -> + if h.hyp_type=h1.hyp_type + || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) + then (h::(h1::lh1))::lh2 + else [h]::((h1::lh1)::lh2) + |_-> assert false +;; + +(* ln noms des hypotheses, lt leurs types *) +let natural_ghyp (sort,ln,lt) intro = + let t=List.hd lt in + let nh=List.length ln in + let ns=List.hd ln in + match sort with + Nprop -> soit_A_une_proposition nh ln t + | Ntype -> soit_X_un_element_de_T nh ln t + | Nfunction -> soit_F_une_fonction_de_type_T nh ln t + | Nformula -> + sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) + (List.combine ln lt))) +;; + +(* Cas d'une hypothese *) +let natural_hyp h = + let ns= string_of_id h.hyp_name in + let t=h.hyp_type in + let ts= (nsort h.hyp_full_type) in + natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ()) +;; + +let rec pr_ghyp lh intro= + match lh with + [] -> [] + | [(sort,ln,t)]-> + (match sort with + Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] + | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) + | (sort,ln,t)::lh -> + let hp= + ([natural_ghyp(sort,ln,t) intro] + @(match lh with + [] -> [sps ". "] + |(sort1,ln1,t1)::lh1 -> + match sort1 with + Nformula -> + (let nh=List.length ln in + match sort with + Nprop -> telle_que nh + |Nfunction -> telle_que nh + |Ntype -> tel_que nh + |Nformula -> [sps ". "]) + | _ -> [sps ". "])) in + (sphv hp)::(pr_ghyp lh "") +;; + +(* traduction d'une liste d'hypotheses groupees. *) +let prnatural_ghyp llh intro= + if llh=[] + then spe + else + sphv (pr_ghyp (List.map + (fun lh -> + let h=(List.hd lh) in + let sh = sort_of_hyp h in + let lhname = (List.map (fun h -> + string_of_id h.hyp_name) lh) in + let lhtype = (List.map (fun h -> h.hyp_type) lh) in + (sh,lhname,lhtype)) + llh) intro) +;; + + +(*****************************************************************************) +(* + Liste des hypotheses. +*) +type type_info_subgoals_hyp= + All_subgoals_hyp + | Reduce_hyp + | No_subgoals_hyp + | Case_subgoals_hyp of string (* word for introduction *) + * Term.constr (* variable *) + * string (* constructor *) + * int (* arity *) + * int (* number of constructors *) + | Case_prop_subgoals_hyp of string (* word for introduction *) + * Term.constr (* variable *) + * int (* index of constructor *) + * int (* arity *) + * int (* number of constructors *) + | Elim_subgoals_hyp of Term.constr (* variable *) + * string (* constructor *) + * int (* arity *) + * (string list) (* rec hyp *) + * int (* number of constructors *) + | Elim_prop_subgoals_hyp of Term.constr (* variable *) + * int (* index of constructor *) + * int (* arity *) + * (string list) (* rec hyp *) + * int (* number of constructors *) +;; +let rec nrem l n = + if n<=0 then l else nrem (list_rem l) (n-1) +;; + +let rec nhd l n = + if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1)) +;; + +let par_hypothese_de_recurrence () = match !natural_language with + French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])] +| English -> sphv [(prls ["by";"induction";"hypothesis";","])] +;; + +let natural_lhyp lh hi = + match hi with + All_subgoals_hyp -> + ( match lh with + [] -> spe + |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) + | Reduce_hyp -> + (match lh with + [h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type + | _-> spe) + | No_subgoals_hyp -> spe + |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *) + let s=ref c in + for i=1 to a do + let nh=(List.nth lh (i-1)) in + s:=(!s)^" "^(string_of_id nh.hyp_name); + done; + if a>0 then s:="("^(!s)^")"; + sphv [ (if ncase>1 + then sph[ sps ("-"^(cas ()));spb] + else spe); + (* spt var;sps "="; *) sps !s; sps ":"; + (prphrases (natural_hyp) (nrem lh a))] + |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) -> + prnatural_ghyp (group_lhyp lh) sintro + |Elim_subgoals_hyp (var,c,a,lhci,ncase) -> + let nlh = List.length lh in + let nlhci = List.length lhci in + let lh0 = ref [] in + for i=1 to (nlh-nlhci) do + lh0:=(!lh0)@[List.nth lh (i-1)]; + done; + let lh=nrem lh (nlh-nlhci) in + let s=ref c in + let lh1=ref [] in + for i=1 to nlhci do + let targ=(List.nth lhci (i-1))in + let nh=(List.nth lh (i-1)) in + if targ="arg" || targ="argrec" + then + (s:=(!s)^" "^(string_of_id nh.hyp_name); + lh0:=(!lh0)@[nh]) + else lh1:=(!lh1)@[nh]; + done; + let introhyprec= + (if (!lh1)=[] then spe + else par_hypothese_de_recurrence () ) + in + if a>0 then s:="("^(!s)^")"; + spv [sphv [(if ncase>1 + then sph[ sps ("-"^(cas ()));spb] + else spe); + sps !s; sps ":"]; + prnatural_ghyp (group_lhyp !lh0) (supposons ()); + introhyprec; + prl (natural_hyp) !lh1] + |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) -> + sphv [ (if ncase>1 + then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c); + sps ":";spb] + else spe); + (prphrases (natural_hyp) lh )] + +;; + +(*****************************************************************************) +(* + Analyse des tactiques. +*) + +(* +let name_tactic tac = + match tac with + (Node(_,"Interp", + (Node(_,_, + (Node(_,t,_))::_))::_))::_ -> t + |(Node(_,t,_))::_ -> t + | _ -> assert false +;; +*) +let name_tactic = function + | TacIntroPattern _ -> "Intro" + | TacAssumption -> "Assumption" + | _ -> failwith "TODO" +;; + +(* +let arg1_tactic tac = + match tac with + (Node(_,"Interp", + (Node(_,_, + (Node(_,_,x::_))::_))::_))::_ ->x + | (Node(_,_,x::_))::_ -> x + | x::_ -> x + | _ -> assert false +;; +*) + +let arg1_tactic tac = failwith "TODO" + +let arg2_tactic tac = + match tac with + (Node(_,"Interp", + (Node(_,_, + (Node(_,_,_::x::_))::_))::_))::_ -> x + | (Node(_,_,_::x::_))::_ -> x + | _ -> assert false +;; + +(* +type nat_tactic = + Split of (Coqast.t list) + | Generalize of (Coqast.t list) + | Reduce of string*(Coqast.t list) + | Other of string*(Coqast.t list) +;; + +let analyse_tac tac = + match tac with + [Node (_, "Split", [Node (_, "BINDINGS", [])])] + -> Split [] + | [Node (_, "Split",[Node(_, "BINDINGS",[Node(_, "BINDING", + [Node (_, "COMMAND", x)])])])] + -> Split x + | [Node (_, "Generalize", [Node (_, "COMMAND", x)])] + ->Generalize x + | [Node (_, "Reduce", [Node (_, "REDEXP", [Node (_, mode, _)]); + Node (_, "CLAUSE", lhyp)])] + -> Reduce(mode,lhyp) + | [Node (_, x,la)] -> Other (x,la) + | _ -> assert false +;; +*) + + + + + +let id_of_command x = + match x with + Node(_,_,Node(_,_,y::_)::_) -> y + |_ -> assert false +;; +type type_info_subgoals = + {ihsg: type_info_subgoals_hyp; + isgintro : string} +;; + +let rec show_goal lh ig g gs = + match ig with + "intros" -> + if lh = [] + then spe + else show_goal lh "standard" g gs + |"standard" -> + (match (sort_of_type g gs) with + Nprop -> donnons_une_proposition () + | Nformula -> montrons g + | Ntype -> calculons_un_element_de g + | Nfunction ->calculons_une_fonction_de_type g) + | "apply" -> show_goal lh "" g gs + | "simpl" ->en_simplifiant_on_obtient g + | "rewrite" -> on_obtient g + | "equality" -> reste_a_montrer g + | "trivial_equality" -> reste_a_montrer g + | "" -> spe + |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ] +;; + +let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s = + if ig="" && lh = [] + then spe + else sphv [ show_goal lh ig g gs; sps s] +;; + +let imaginez_une_preuve_de () = match !natural_language with + French -> "Imaginez une preuve de" +| English -> "Imagine a proof of" +;; + +let donnez_un_element_de () = match !natural_language with + French -> "Donnez un element de" +| English -> "Give an element of";; + +let intro_not_proved_goal gs = + match gs with + Prop(Null) -> imaginez_une_preuve_de () + |_ -> donnez_un_element_de () +;; + +let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= + match lh with + {hyp_name=n}::_ -> n + | _ -> assert false +;; + +let rec find_type x t= + match (kind_of_term (strip_outer_cast t)) with + Prod(y,ty,t) -> + (match y with + Name y -> + if x=(string_of_id y) then ty + else find_type x t + | _ -> find_type x t) + |_-> assert false +;; + +(*********************************************************************** +Traitement des égalités +*) +(* +let is_equality e = + match (kind_of_term e) with + AppL args -> + (match (kind_of_term args.(0)) with + Const (c,_) -> + (match (string_of_sp c) with + "Equal" -> true + | "eq" -> true + | "eqT" -> true + | "identityT" -> true + | _ -> false) + | _ -> false) + | _ -> false +;; +*) + +let is_equality e = + let e= (strip_outer_cast e) in + match (kind_of_term e) with + App (f,args) -> (Array.length args) >= 3 + | _ -> false +;; + +let terms_of_equality e = + let e= (strip_outer_cast e) in + match (kind_of_term e) with + App (f,args) -> (args.(1) , args.(2)) + | _ -> assert false +;; + +let eq_term = eq_constr;; + +let is_equality_tac = function + | TacAtom (_, + (TacExtend + (_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" + |"ERewriteParallel"|"ERewriteNormal" + |"RewriteLR"|"RewriteRL"|"Replace"),_) + | TacReduce _ + | TacSymmetry _ | TacReflexivity + | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true + | _ -> false + +let equalities_ntree ig ntree = + let rec equalities_ntree ig ntree = + if not (is_equality (concl ntree)) + then [] + else + match (proof ntree) with + Notproved -> [(ig,ntree)] + | Proof (tac,ltree) -> + if is_equality_tac tac + then (match ltree with + [] -> [(ig,ntree)] + | t::_ -> let res=(equalities_ntree ig t) in + if eq_term (concl ntree) (concl t) + then res + else (ig,ntree)::res) + else [(ig,ntree)] + in + equalities_ntree ig ntree +;; + +let remove_seq_of_terms l = + let rec remove_seq_of_terms l = match l with + a::b::l -> if (eq_term (fst a) (fst b)) + then remove_seq_of_terms (b::l) + else a::(remove_seq_of_terms (b::l)) + | _ -> l + in remove_seq_of_terms l +;; + +let list_to_eq l o= + let switch = fun h h' -> (if o then h else h') in + match l with + [a] -> spt (fst a) + | (a,h)::(b,h')::l -> + let rec list_to_eq h l = + match l with + [] -> [] + | (b,h')::l -> + (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) + :: (list_to_eq (switch h' h) l) + in sph [spt a; spb; + spv ((sph [sps "="; spb; spt b; spb; + tag_uselemma (switch h h') spe]) + ::(list_to_eq (switch h' h) l))] + | _ -> assert false +;; + +let stde = Global.env;; + +let dbize env = Constrintern.interp_constr Evd.empty env;; + +(**********************************************************************) +let rec natural_ntree ig ntree = + let {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = ntree in + let leq = List.rev (equalities_ntree ig ntree) in + if List.length leq > 1 + then (* Several equalities to treate ... *) + ( + print_string("Several equalities to treate ...\n"); + let l1 = ref [] in + let l2 = ref [] in + List.iter + (fun (_,ntree) -> + let lemma = match (proof ntree) with + Proof (tac,ltree) -> + (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *) + (match ltree with + [] ->spe + | [_] -> spe + | _::l -> sphv[sps ": "; + prli (natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="standard"}) + l])]) + with _ -> sps "simplification" ) + | Notproved -> spe + in + let (t1,t2)= terms_of_equality (concl ntree) in + l2:=(t2,lemma)::(!l2); + l1:=(t1,lemma)::(!l1)) + leq; + l1:=remove_seq_of_terms !l1; + l2:=remove_seq_of_terms !l2; + l2:=List.rev !l2; + let ltext=ref [] in + if List.length !l1 > 1 + then (ltext:=(!ltext)@[list_to_eq !l1 true]; + if List.length !l2 > 1 then + (ltext:=(!ltext)@[_et()]; + ltext:=(!ltext)@[list_to_eq !l2 false])) + else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false]; + if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext]; + let (ig,ntree)=(List.hd leq) in + spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g (nsort gf) ""); + sph !ltext; + + natural_ntree {ihsg=All_subgoals_hyp; + isgintro= + let (t1,t2)= terms_of_equality (concl ntree) in + if eq_term t1 t2 + then "trivial_equality" + else "equality"} + ntree] + ) + else + let ntext = + let gs=nsort gf in + match p with + Notproved -> spv [ (natural_lhyp lh ig.ihsg); + sph [spi; sps (intro_not_proved_goal gs); spb; + tag_toprove g ] + ] + + | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) + | Proof (TacAtom (_,tac),ltree) -> + (let ntext = + match tac with +(* Pas besoin de l'argument éventuel de la tactique *) + TacIntroPattern _ -> natural_intros ig lh g gs ltree + | TacIntroMove _ -> natural_intros ig lh g gs ltree + | TacFix (_,n) -> natural_fix ig lh g gs n ltree + | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree + | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree + | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree + | TacRight _ -> natural_right ig lh g gs ltree + | TacLeft _ -> natural_left ig lh g gs ltree + | (* "Simpl" *)TacReduce (r,cl) -> + natural_reduce ig lh g gs ge r cl ltree + | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree + | TacAuto _ -> natural_auto ig lh g gs ltree + | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree + | TacTrivial _ -> natural_trivial ig lh g gs ltree + | TacAssumption -> natural_trivial ig lh g gs ltree + | TacClear _ -> natural_clear ig lh g gs ltree +(* Besoin de l'argument de la tactique *) + | TacSimpleInduction (NamedHyp id,_) -> + natural_induction ig lh g gs ge id ltree false + | TacExtend (_,"InductionIntro",[a]) -> + let id=(out_gen wit_ident a) in + natural_induction ig lh g gs ge id ltree true + | TacApply (c,_) -> natural_apply ig lh g gs c ltree + | TacExact c -> natural_exact ig lh g gs c ltree + | TacCut c -> natural_cut ig lh g gs c ltree + | TacExtend (_,"CutIntro",[a]) -> + let c = out_gen wit_constr a in + natural_cutintro ig lh g gs a ltree + | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false + | TacExtend (_,"CaseIntro",[a]) -> + let c = out_gen wit_constr a in + natural_case ig lh g gs ge c ltree true + | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false + | TacExtend (_,"ElimIntro",[a]) -> + let c = out_gen wit_constr a in + natural_elim ig lh g gs ge c ltree true + | TacExtend (_,"Rewrite",[_;a]) -> + let (c,_) = out_gen wit_constr_with_bindings a in + natural_rewrite ig lh g gs c ltree + | TacExtend (_,"ERewriteRL",[a]) -> + let c = out_gen wit_constr a in (* TODO *) + natural_rewrite ig lh g gs c ltree + | TacExtend (_,"ERewriteLR",[a]) -> + let c = out_gen wit_constr a in (* TODO *) + natural_rewrite ig lh g gs c ltree + |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree + in + ntext (* spwithtac ntext tactic*) + ) + | Proof _ -> failwith "Don't know what to do with that" + in + if info<>"not_proved" + then spshrink info ntext + else ntext +and natural_generic ig lh g gs tactic tac ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + on_applique_la_tactique tactic tac ; + (prli(natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="standard"}) + ltree) + ] +and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree) +(* + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree ig) ltree) + ] +*) +and natural_intros ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="intros"}) + ltree) + ] +and natural_apply ig lh g gs arg ltree = + let lg = List.map concl ltree in + match lg with + [] -> + spv + [ (natural_lhyp lh ig.ihsg); + de_A_il_vient_B arg g + ] + | [sg]-> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh + {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" + then "standard" + else ""} + g gs ""); + grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; + sph [spi ; natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} (List.hd ltree)] + ] + | _ -> + let ln = List.map (fun _ -> new_name()) lg in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh + {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" + then "standard" + else ""} + g gs ""); + grace_a_A_il_suffit_de_montrer_LA arg + (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) + lg ln); + sph [spi; spv (List.map2 + (fun x n -> sph [sps ("("^n^"):"); spb; + natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} x]) + ltree ln)] + ] +and natural_rem_goals ltree = + let lg = List.map concl ltree in + match lg with + [] -> spe + | [sg]-> + spv + [ reste_a_montrer_LA [spt sg]; + sph [spi ; natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} (List.hd ltree)] + ] + | _ -> + let ln = List.map (fun _ -> new_name()) lg in + spv + [ reste_a_montrer_LA + (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) + lg ln); + sph [spi; spv (List.map2 + (fun x n -> sph [sps ("("^n^"):"); spb; + natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} x]) + ltree ln)] + ] +and natural_exact ig lh g gs arg ltree = +spv + [ + (natural_lhyp lh ig.ihsg); + (let {ihsg=pi;isgintro=ig}= ig in + (show_goal2 lh {ihsg=pi;isgintro=""} + g gs "")); + (match gs with + Prop(Null) -> _A_est_immediat_par_B g arg + |_ -> le_resultat_est arg) + + ] +and natural_cut ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + (List.rev ltree)); + de_A_on_deduit_donc_B arg g + ] +and natural_cutintro ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + sph [spi; + (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""} + (List.nth ltree 1))]; + sph [spi; + (natural_ntree + {ihsg=No_subgoals_hyp;isgintro=""} + (List.nth ltree 0))] + ] +and whd_betadeltaiota x = whd_betaiotaevar (Global.env()) Evd.empty x +and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) +and prod_head t = + match (kind_of_term (strip_outer_cast t)) with + Prod(_,_,c) -> prod_head c +(* |App(f,a) -> f *) + | _ -> t +and string_of_sp sp = string_of_id (basename sp) +and constr_of_mind mip i = + (string_of_id mip.mind_consnames.(i-1)) +and arity_of_constr_of_mind env indf i = + (get_constructors env indf).(i-1).cs_nargs +and gLOB ge = Global.env_of_context ge (* (Global.env()) *) + +and natural_case ig lh g gs ge arg1 ltree with_intros = + let env= (gLOB ge) in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in + if ncti<>1 +(* Zéro ou Plusieurs constructeurs *) + then ( + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (match (nsort targ1) with + Prop(Null) -> + (match ti with + "or" -> discutons_avec_A type_arg + | _ -> utilisons_A arg1) + |_ -> selon_les_valeurs_de_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=if with_intros + then (arity_of_constr_of_mind env indf !ci) + else 0 in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Case_prop_subgoals_hyp (supposons (),arg1,ici,aci, + (List.length ltree)) + |_-> Case_subgoals_hyp ("",arg1,nci,aci, + (List.length ltree))); + isgintro= if with_intros then "" else "standard"} + treearg) + ]) + (nrem ltree ((List.length ltree)- ncti)))); + (sph [spi; (natural_rem_goals + (nhd ltree ((List.length ltree)- ncti)))]) + ] ) +(* Cas d'un seul constructeur *) + else ( + + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + de_A_on_a arg1; + (let treearg=List.hd ltree in + let nci=(constr_of_mind mip 1) in + let aci= + if with_intros + then (arity_of_constr_of_mind env indf 1) + else 0 in + let ici= 1 in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Case_prop_subgoals_hyp ("",arg1,1,aci, + (List.length ltree)) + |_-> Case_subgoals_hyp ("",arg1,nci,aci, + (List.length ltree))); + isgintro=""} + treearg) + ]); + (sph [spi; (natural_rem_goals + (nhd ltree ((List.length ltree)- 1)))]) + ] + ) +(* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) + +(*****************************************************************************) +(* + Elim +*) +and prod_list_var t = + match (kind_of_term (strip_outer_cast t)) with + Prod(_,t,c) -> t::(prod_list_var c) + |_ -> [] +and hd_is_mind t ti = + try (let env = Global.env() in + let IndType (indf,targ) = find_rectype env Evd.empty t in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + (string_of_id mip.mind_typename) = ti) + with _ -> false +and mind_ind_info_hyp_constr indf c = + let env = Global.env() in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let p = mip.mind_nparams in + let a = arity_of_constr_of_mind env indf c in + let lp=ref (get_constructors env indf).(c).cs_args in + let lr=ref [] in + let ti = (string_of_id mip.mind_typename) in + for i=1 to a do + match !lp with + ((_,_,t)::lp1)-> + if hd_is_mind t ti + then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1) + else (lr:=(!lr)@["arg"];lp:=lp1) + | _ -> raise (Failure "mind_ind_info_hyp_constr") + done; + !lr +(* + mind_ind_info_hyp_constr "le" 2;; +donne ["arg"; "argrec"] +mind_ind_info_hyp_constr "le" 1;; +donne [] + mind_ind_info_hyp_constr "nat" 2;; +donne ["argrec"] +*) + +and natural_elim ig lh g gs ge arg1 ltree with_intros= + let env= (gLOB ge) in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg=targ1 (* List.nth targ (mis_index dmi) *) in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (match (nsort targ1) with + Prop(Null) -> utilisons_A arg1 + |_ ->procedons_par_recurrence_sur_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in + let hci= + if with_intros + then mind_ind_info_hyp_constr indf !ci + else [] in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Elim_prop_subgoals_hyp (arg1,ici,aci,hci, + (List.length ltree)) + |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, + (List.length ltree))); + isgintro= ""} + treearg) + ]) + (nhd ltree ncti))); + (sph [spi; (natural_rem_goals (nrem ltree ncti))]) + ] +(* ) + with _ ->natural_generic ig lh g gs (sps "Elim") (spt arg1) ltree *) + +(*****************************************************************************) +(* + InductionIntro n +*) +and natural_induction ig lh g gs ge arg2 ltree with_intros= + let env = (gLOB (g_env (List.hd ltree))) in + let arg1= mkVar arg2 in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg= targ1(*List.nth targ (mis_index dmi)*) in + + let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *) + (* on les enleve des hypotheses des sous-buts *) + let ltree = List.map + (fun {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} -> + {t_info=info; + t_goal={newhyp=(nrem lh (List.length lh1)); + t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p}) ltree in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (natural_lhyp lh1 All_subgoals_hyp); + (match (print_string "targ1------------\n";(nsort targ1)) with + Prop(Null) -> utilisons_A arg1 + |_ -> procedons_par_recurrence_sur_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in + let hci= + if with_intros + then mind_ind_info_hyp_constr indf !ci + else [] in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Elim_prop_subgoals_hyp (arg1,ici,aci,hci, + (List.length ltree)) + |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, + (List.length ltree))); + isgintro= "standard"} + treearg) + ]) + ltree)) + ] +(************************************************************************) +(* Points fixes *) + +and natural_fix ig lh g gs narg ltree = + let {t_info=info; + t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1; + t_full_env=ge1};t_proof=p1}=(List.hd ltree) in + match lh1 with + {hyp_name=nfun;hyp_type=tfun}::lh2 -> + let ltree=[{t_info=info; + t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1; + t_full_env=ge1}; + t_proof=p1}] in + spv + [ (natural_lhyp lh ig.ihsg); + calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_reduce ig lh g gs ge mode la ltree = + match la with + {onhyps=Some[];onconcl=true} -> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro="simpl"}) + ltree) + ] + | {onhyps=Some[hyp]; onconcl=false} -> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=Reduce_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_split ig lh g gs ge la ltree = + match la with + [arg] -> + let env= (gLOB ge) in + let arg1= (*dbize env*) arg in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + pour_montrer_G_la_valeur_recherchee_est_A g arg1; + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree) + ] + | [] -> + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree) + ] + | _ -> assert false +and natural_generalize ig lh g gs ge la ltree = + match la with + [arg] -> + let env= (gLOB ge) in + let arg1= (*dbize env*) arg in + let type_arg=type_of (Global.env()) Evd.empty arg in +(* let type_arg=type_of_ast ge arg in*) + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + on_se_sert_de_A arg1; + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_right ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree); + d_ou_A g + ] +and natural_left ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree); + d_ou_A g + ] +and natural_auto ig lh g gs ltree = + match ig.isgintro with + "trivial_equality" -> spe + | _ -> + if ltree=[] + then sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + coq_le_demontre_seul ()] + else spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} + ) + ltree)] +and natural_infoauto ig lh g gs ltree = + match ig.isgintro with + "trivial_equality" -> + spshrink "trivial_equality" + (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"} + (List.hd ltree)) + | _ -> sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + coq_le_demontre_seul (); + spshrink "auto" + (sph [spi; + (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""} + (List.hd ltree))])] +and natural_trivial ig lh g gs ltree = + if ltree=[] + then sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + ce_qui_est_trivial () ] + else spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ". "); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree)] +and natural_rewrite ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + en_utilisant_l_egalite_A arg; + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="rewrite"}) + ltree) + ] +;; + +let natural_ntree_path ig g = + Random.init(0); + natural_ntree ig g +;; + +let show_proof lang gpath = + (match lang with + "fr" -> natural_language:=French + |"en" -> natural_language:=English + | _ -> natural_language:=English); + path:=List.rev gpath; + name_count:=0; + let ntree=(get_nproof ()) in + let {t_info=i;t_goal=g;t_proof=p} =ntree in + root_of_text_proof + (sph [(natural_ntree_path {ihsg=All_subgoals_hyp; + isgintro="standard"} + {t_info="not_proved";t_goal=g;t_proof=p}); + spr]) + ;; + +let show_nproof path = + pp (sp_print (sph [spi; show_proof "fr" path]));; + +vinterp_add "ShowNaturalProof" + (fun _ -> + (fun () ->show_nproof[];()));; + +(*********************************************************************** +debug sous cygwin: + +PATH=/usr/local/bin:/usr/bin:$PATH +COQTOP=d:/Tools/coq-7avril +CAMLLIB=/usr/local/lib/ocaml +CAMLP4LIB=/usr/local/lib/camlp4 +export CAMLLIB +export COQTOP +export CAMLP4LIB +cd d:/Tools/pcoq/src/text +d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history + + + +Lemma l1: (A, B : Prop) A \/ B -> B -> A. +Intros. +Elim H. +Auto. +Qed. + + +Drop. + +#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; +#load "xlate.cmo";; +#load "translate.cmo";; +#load "showproof_ct.cmo";; +#load "showproof.cmo";; +#load "pbp.cmo";; +#load "debug_tac.cmo";; +#load "name_to_ast.cmo";; +#load "paths.cmo";; +#load "dad.cmo";; +#load "vtp.cmo";; +#load "history.cmo";; +#load "centaur.cmo";; +Xlate.set_xlate_mut_stuff Centaur.globcv;; +Xlate.declare_in_coq();; + +#use "showproof.ml";; + +let pproof x = pP (sp_print x);; +Pp_control.set_depth_boxes 100;; +#install_printer pproof;; + +ep();; +let bidon = ref (constr_of_string "O");; + +#trace to_nproof;; +***********************************************************************) +let ep()=show_proof "fr" [];; diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli new file mode 100755 index 00000000..ee269458 --- /dev/null +++ b/contrib/interface/showproof.mli @@ -0,0 +1,23 @@ +open Environ +open Evd +open Names +open Term +open Util +open Proof_type +open Coqast +open Pfedit +open Translate +open Term +open Reduction +open Clenv +open Typing +open Inductive +open Vernacinterp +open Declarations +open Showproof_ct +open Proof_trees +open Sign +open Pp +open Printer + +val show_proof : string -> int list -> Ascent.ct_TEXT;; diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml new file mode 100644 index 00000000..ee901c5e --- /dev/null +++ b/contrib/interface/showproof_ct.ml @@ -0,0 +1,185 @@ +(*****************************************************************************) +(* + Vers Ctcoq +*) + +open Esyntax +open Metasyntax +open Printer +open Pp +open Translate +open Ascent +open Vtp +open Xlate + +let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);; + +let sps s = + ct_text s + ;; + + +let sphs s = + ct_text s + ;; + +let spe = sphs "";; +let spb = sps " ";; +let spr = sps "Retour chariot pour Show proof";; + +let spnb n = + let s = ref "" in + for i=1 to n do s:=(!s)^" "; done; sps !s +;; + + +let rec spclean l = + match l with + [] -> [] + |x::l -> if x=spe then (spclean l) else x::(spclean l) +;; + + +let spnb n = + let s = ref "" in + for i=1 to n do s:=(!s)^" "; done; sps !s +;; + +let ct_FORMULA_constr = Hashtbl.create 50;; + +let stde() = (Global.env()) + +;; + +let spt t = + let f = (translate_constr true (stde()) t) in + Hashtbl.add ct_FORMULA_constr f t; + CT_text_formula f +;; + + + +let root_of_text_proof t= + CT_text_op [ct_text "root_of_text_proof"; + t] + ;; + +let spshrink info t = + CT_text_op [ct_text "shrink"; + CT_text_op [ct_text info; + t]] +;; + +let spuselemma intro x y = + CT_text_op [ct_text "uselemma"; + ct_text intro; + x;y] +;; + +let sptoprove p t = + CT_text_op [ct_text "to_prove"; + CT_text_path p; + ct_text "goal"; + (spt t)] +;; +let sphyp p h t = + CT_text_op [ct_text "hyp"; + CT_text_path p; + ct_text h; + (spt t)] +;; +let sphypt p h t = + CT_text_op [ct_text "hyp_with_type"; + CT_text_path p; + ct_text h; + (spt t)] +;; + +let spwithtac x t = + CT_text_op [ct_text "with_tactic"; + ct_text t; + x] +;; + + +let spv l = + let l= spclean l in + CT_text_v l +;; + +let sph l = + let l= spclean l in + CT_text_h l +;; + + +let sphv l = + let l= spclean l in + CT_text_hv l +;; + +let rec prlist_with_sep f g l = + match l with + [] -> hov 0 (mt ()) + |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) +;; + +let rec sp_print x = + match x with + | CT_coerce_ID_to_TEXT (CT_ident s) + -> (match s with + | "\n" -> fnl () + | "Retour chariot pour Show proof" -> fnl () + |_ -> str s) + | CT_text_formula f -> prterm (Hashtbl.find ct_FORMULA_constr f) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident "goal"); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (str "<b>" ++ sp_print g ++ str "</b>") + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma"); + CT_coerce_ID_to_TEXT (CT_ident intro); + l;g] -> + h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident hyp); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (str hyp) + + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident hyp); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") + + | CT_text_h l -> + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_v l -> + v 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_hv l -> + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink"); + CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]] -> + h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); + t]-> + sp_print t + | _ -> str "..." +;; + diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml new file mode 100644 index 00000000..e63baecf --- /dev/null +++ b/contrib/interface/translate.ml @@ -0,0 +1,165 @@ +open Names;; +open Sign;; +open Util;; +open Ast;; +open Term;; +open Pp;; +open Libobject;; +open Library;; +open Vernacinterp;; +open Termast;; +open Tacmach;; +open Pfedit;; +open Parsing;; +open Evd;; +open Evarutil;; + +open Xlate;; +open Ctast;; +open Vtp;; +open Ascent;; +open Environ;; +open Proof_type;; + +(* dead code: let rel_reference gt k oper = + if is_existential_oper oper then ope("XTRA", [str "ISEVAR"]) + else begin + let id = id_of_global oper in + let oper', _ = global_operator (Nametab.sp_of_id k id) id in + if oper = oper' then nvar (string_of_id id) + else failwith "xlate" +end;; +*) + +(* dead code: +let relativize relfun = + let rec relrec = + function + | Nvar (_, id) -> nvar id + | Slam (l, na, ast) -> Slam (l, na, relrec ast) + | Node (loc, nna, l) as ast -> begin + try relfun ast + with + | Failure _ -> Node (loc, nna, List.map relrec l) + end + | a -> a in + relrec;; +*) + +(* dead code: +let dbize_sp = + function + | Path (loc, sl, s) -> begin + try section_path sl s + with + | Invalid_argument _ | Failure _ -> + anomaly_loc + (loc, "Translate.dbize_sp (taken from Astterm)", + [< str "malformed section-path" >]) + end + | ast -> + anomaly_loc + (Ast.loc ast, "Translate.dbize_sp (taken from Astterm)", + [< str "not a section-path" >]);; +*) + +(* dead code: +let relativize_cci gt = relativize (function + | Node (_, "CONST", (p :: _)) as gt -> + rel_reference gt CCI (Const (dbize_sp p)) + | Node (_, "MUTIND", (p :: ((Num (_, tyi)) :: _))) as gt -> + rel_reference gt CCI (MutInd (dbize_sp p, tyi)) + | Node (_, "MUTCONSTRUCT", (p :: ((Num (_, tyi)) :: ((Num (_, i)) :: _)))) as gt -> + rel_reference gt CCI (MutConstruct ( + (dbize_sp p, tyi), i)) + | _ -> failwith "caught") gt;; +*) + +let coercion_description_holder = ref (function _ -> None : t -> int option);; + +let coercion_description t = !coercion_description_holder t;; + +let set_coercion_description f = + coercion_description_holder:=f; ();; + +let rec nth_tl l n = if n = 0 then l + else (match l with + | a :: b -> nth_tl b (n - 1) + | [] -> failwith "list too short for nth_tl");; + +let rec discard_coercions = + function + | Slam (l, na, ast) -> Slam (l, na, discard_coercions ast) + | Node (l, ("APPLIST" as nna), (f :: args as all_sons)) -> + (match coercion_description f with + | Some n -> + let new_args = + try nth_tl args n + with + | Failure "list too short for nth_tl" -> [] in + (match new_args with + | a :: (b :: c) -> Node (l, nna, List.map discard_coercions new_args) + | a :: [] -> discard_coercions a + | [] -> Node (l, nna, List.map discard_coercions all_sons)) + | None -> Node (l, nna, List.map discard_coercions all_sons)) + | Node (l, nna, all_sons) -> + Node (l, nna, List.map discard_coercions all_sons) + | it -> it;; + +(*translates a formula into a centaur-tree --> FORMULA *) +let translate_constr at_top env c = + xlate_formula (Constrextern.extern_constr at_top env c);; + +(*translates a named_context into a centaur-tree --> PREMISES_LIST *) +(* this code is inspired from printer.ml (function pr_named_context_of) *) +let translate_sign env = + let l = + Environ.fold_named_context + (fun env (id,v,c) l -> + (match v with + None -> + CT_premise(CT_ident(string_of_id id), translate_constr false env c) + | Some v1 -> + CT_eval_result + (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), + translate_constr false env v1, + translate_constr false env c))::l) + env ~init:[] + in + CT_premises_list l;; + +(* the function rev_and_compact performs two operations: + 1- it reverses the list of integers given as argument + 2- it replaces sequences of "1" by a negative number that is + the length of the sequence. *) +let rec rev_and_compact l = function + [] -> l + | 1::tl -> + (match l with + n::tl' -> + if n < 0 then + rev_and_compact ((n - 1)::tl') tl + else + rev_and_compact ((-1)::l) tl + | [] -> rev_and_compact [-1] tl) + | a::tl -> + if a < 0 then + (match l with + n::tl' -> + if n < 0 then + rev_and_compact ((n + a)::tl') tl + else + rev_and_compact (a::l) tl + | [] -> rev_and_compact (a::l) tl) + else + rev_and_compact (a::l) tl;; + +(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *) +let translate_path l = + CT_signed_int_list + (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) + (rev_and_compact [] l));; + +(*translates a path and a goal into a centaur-tree --> RULE *) +let translate_goal (g:goal) = + CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);; diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli new file mode 100644 index 00000000..65d8331b --- /dev/null +++ b/contrib/interface/translate.mli @@ -0,0 +1,11 @@ +open Ascent;; +open Evd;; +open Proof_type;; +open Environ;; +open Term;; + +val translate_goal : goal -> ct_RULE;; +(* The boolean argument indicates whether names from the environment should *) +(* be avoided (same interpretation as for prterm_env and ast_of_constr) *) +val translate_constr : bool -> env -> constr -> ct_FORMULA;; +val translate_path : int list -> ct_SIGNED_INT_LIST;; diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc new file mode 100644 index 00000000..42b5e5ab --- /dev/null +++ b/contrib/interface/vernacrc @@ -0,0 +1,12 @@ +# $Id: vernacrc,v 1.3 2004/01/14 14:52:59 bertot Exp $ + +# This file is loaded initially by ./vernacparser. + +load_syntax_file 1 Notations +load_syntax_file 2 Logic +load_syntax_file 34 Omega +load_syntax_file 27 Ring +quiet_parse_string +Goal a. +&& END--OF--DATA +print_version diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml new file mode 100644 index 00000000..ff418523 --- /dev/null +++ b/contrib/interface/vtp.ml @@ -0,0 +1,1915 @@ +open Ascent;; + +let fNODE s n = + print_string "n\n"; + print_string ("vernac$" ^ s); + print_string "\n"; + print_int n; + print_string "\n";; + +let fATOM s1 = + print_string "a\n"; + print_string ("vernac$" ^ s1); + print_string "\n";; + +let f_atom_string = print_string;; +let f_atom_int = print_int;; +let rec fAST = function +| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x +| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x +| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x +| CT_astnode(x1, x2) -> + fID x1; + fAST_LIST x2; + fNODE "astnode" 2 +| CT_astpath(x1) -> + fID_LIST x1; + fNODE "astpath" 1 +| CT_astslam(x1, x2) -> + fID_OPT x1; + fAST x2; + fNODE "astslam" 2 +and fAST_LIST = function +| CT_ast_list l -> + (List.iter fAST l); + fNODE "ast_list" (List.length l) +and fBINARY = function +| CT_binary x -> fATOM "binary"; + (f_atom_int x); + print_string "\n"and fBINDER = function +| CT_coerce_DEF_to_BINDER x -> fDEF x +| CT_binder(x1, x2) -> + fID_OPT_NE_LIST x1; + fFORMULA x2; + fNODE "binder" 2 +| CT_binder_coercion(x1, x2) -> + fID_OPT_NE_LIST x1; + fFORMULA x2; + fNODE "binder_coercion" 2 +and fBINDER_LIST = function +| CT_binder_list l -> + (List.iter fBINDER l); + fNODE "binder_list" (List.length l) +and fBINDER_NE_LIST = function +| CT_binder_ne_list(x,l) -> + fBINDER x; + (List.iter fBINDER l); + fNODE "binder_ne_list" (1 + (List.length l)) +and fBINDING = function +| CT_binding(x1, x2) -> + fID_OR_INT x1; + fFORMULA x2; + fNODE "binding" 2 +and fBINDING_LIST = function +| CT_binding_list l -> + (List.iter fBINDING l); + fNODE "binding_list" (List.length l) +and fBOOL = function +| CT_false -> fNODE "false" 0 +| CT_true -> fNODE "true" 0 +and fCASE = function +| CT_case x -> fATOM "case"; + (f_atom_string x); + print_string "\n"and fCLAUSE = function +| CT_clause(x1, x2) -> + fHYP_LOCATION_LIST_OR_STAR x1; + fSTAR_OPT x2; + fNODE "clause" 2 +and fCOERCION_OPT = function +| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x +| CT_coercion_atm -> fNODE "coercion_atm" 0 +and fCOFIXTAC = function +| CT_cofixtac(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "cofixtac" 2 +and fCOFIX_REC = function +| CT_cofix_rec(x1, x2, x3, x4) -> + fID x1; + fBINDER_LIST x2; + fFORMULA x3; + fFORMULA x4; + fNODE "cofix_rec" 4 +and fCOFIX_REC_LIST = function +| CT_cofix_rec_list(x,l) -> + fCOFIX_REC x; + (List.iter fCOFIX_REC l); + fNODE "cofix_rec_list" (1 + (List.length l)) +and fCOFIX_TAC_LIST = function +| CT_cofix_tac_list l -> + (List.iter fCOFIXTAC l); + fNODE "cofix_tac_list" (List.length l) +and fCOMMAND = function +| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x +| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x +| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x +| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x +| CT_abort(x1) -> + fID_OPT_OR_ALL x1; + fNODE "abort" 1 +| CT_abstraction(x1, x2, x3) -> + fID x1; + fFORMULA x2; + fINT_LIST x3; + fNODE "abstraction" 3 +| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) -> + fFORMULA x1; + fFORMULA x2; + fFORMULA x3; + fFORMULA x4; + fFORMULA x5; + fFORMULA x6; + fFORMULA x7; + fFORMULA x8; + fFORMULA x9; + fFORMULA x10; + fBINDING_LIST x11; + fNODE "add_field" 11 +| CT_add_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "add_natural_feature" 2 +| CT_addpath(x1, x2) -> + fSTRING x1; + fID_OPT x2; + fNODE "addpath" 2 +| CT_arguments_scope(x1, x2) -> + fID x1; + fID_OPT_LIST x2; + fNODE "arguments_scope" 2 +| CT_bind_scope(x1, x2) -> + fID x1; + fID_NE_LIST x2; + fNODE "bind_scope" 2 +| CT_cd(x1) -> + fSTRING_OPT x1; + fNODE "cd" 1 +| CT_check(x1) -> + fFORMULA x1; + fNODE "check" 1 +| CT_class(x1) -> + fID x1; + fNODE "class" 1 +| CT_close_scope(x1) -> + fID x1; + fNODE "close_scope" 1 +| CT_coercion(x1, x2, x3, x4, x5) -> + fLOCAL_OPT x1; + fIDENTITY_OPT x2; + fID x3; + fID x4; + fID x5; + fNODE "coercion" 5 +| CT_cofix_decl(x1) -> + fCOFIX_REC_LIST x1; + fNODE "cofix_decl" 1 +| CT_compile_module(x1, x2, x3) -> + fVERBOSE_OPT x1; + fID x2; + fSTRING_OPT x3; + fNODE "compile_module" 3 +| CT_declare_module(x1, x2, x3, x4) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_CHECK x3; + fMODULE_EXPR x4; + fNODE "declare_module" 4 +| CT_define_notation(x1, x2, x3, x4) -> + fSTRING x1; + fFORMULA x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "define_notation" 4 +| CT_definition(x1, x2, x3, x4, x5) -> + fDEFN x1; + fID x2; + fBINDER_LIST x3; + fDEF_BODY x4; + fFORMULA_OPT x5; + fNODE "definition" 5 +| CT_delim_scope(x1, x2) -> + fID x1; + fID x2; + fNODE "delim_scope" 2 +| CT_delpath(x1) -> + fSTRING x1; + fNODE "delpath" 1 +| CT_derive_depinversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "derive_depinversion" 4 +| CT_derive_inversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fINT_OPT x2; + fID x3; + fID x4; + fNODE "derive_inversion" 4 +| CT_derive_inversion_with(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "derive_inversion_with" 4 +| CT_explain_proof(x1) -> + fINT_LIST x1; + fNODE "explain_proof" 1 +| CT_explain_prooftree(x1) -> + fINT_LIST x1; + fNODE "explain_prooftree" 1 +| CT_export_id(x1) -> + fID_NE_LIST x1; + fNODE "export_id" 1 +| CT_extract_to_file(x1, x2) -> + fSTRING x1; + fID_NE_LIST x2; + fNODE "extract_to_file" 2 +| CT_extraction(x1) -> + fID_OPT x1; + fNODE "extraction" 1 +| CT_fix_decl(x1) -> + fFIX_REC_LIST x1; + fNODE "fix_decl" 1 +| CT_focus(x1) -> + fINT_OPT x1; + fNODE "focus" 1 +| CT_go(x1) -> + fINT_OR_LOCN x1; + fNODE "go" 1 +| CT_guarded -> fNODE "guarded" 0 +| CT_hint_destruct(x1, x2, x3, x4, x5, x6) -> + fID x1; + fINT x2; + fDESTRUCT_LOCATION x3; + fFORMULA x4; + fTACTIC_COM x5; + fID_LIST x6; + fNODE "hint_destruct" 6 +| CT_hint_extern(x1, x2, x3, x4) -> + fINT x1; + fFORMULA x2; + fTACTIC_COM x3; + fID_LIST x4; + fNODE "hint_extern" 4 +| CT_hintrewrite(x1, x2, x3, x4) -> + fORIENTATION x1; + fFORMULA_NE_LIST x2; + fID x3; + fTACTIC_COM x4; + fNODE "hintrewrite" 4 +| CT_hints(x1, x2, x3) -> + fID x1; + fID_NE_LIST x2; + fID_LIST x3; + fNODE "hints" 3 +| CT_hints_immediate(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "hints_immediate" 2 +| CT_hints_resolve(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "hints_resolve" 2 +| CT_hyp_search_pattern(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "hyp_search_pattern" 2 +| CT_implicits(x1, x2) -> + fID x1; + fID_LIST_OPT x2; + fNODE "implicits" 2 +| CT_import_id(x1) -> + fID_NE_LIST x1; + fNODE "import_id" 1 +| CT_ind_scheme(x1) -> + fSCHEME_SPEC_LIST x1; + fNODE "ind_scheme" 1 +| CT_infix(x1, x2, x3, x4) -> + fSTRING x1; + fID x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "infix" 4 +| CT_inline(x1) -> + fID_NE_LIST x1; + fNODE "inline" 1 +| CT_inspect(x1) -> + fINT x1; + fNODE "inspect" 1 +| CT_kill_node(x1) -> + fINT x1; + fNODE "kill_node" 1 +| CT_load(x1, x2) -> + fVERBOSE_OPT x1; + fID_OR_STRING x2; + fNODE "load" 2 +| CT_local_close_scope(x1) -> + fID x1; + fNODE "local_close_scope" 1 +| CT_local_define_notation(x1, x2, x3, x4) -> + fSTRING x1; + fFORMULA x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "local_define_notation" 4 +| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) -> + fID x1; + fINT x2; + fDESTRUCT_LOCATION x3; + fFORMULA x4; + fTACTIC_COM x5; + fID_LIST x6; + fNODE "local_hint_destruct" 6 +| CT_local_hint_extern(x1, x2, x3, x4) -> + fINT x1; + fFORMULA x2; + fTACTIC_COM x3; + fID_LIST x4; + fNODE "local_hint_extern" 4 +| CT_local_hints(x1, x2, x3) -> + fID x1; + fID_NE_LIST x2; + fID_LIST x3; + fNODE "local_hints" 3 +| CT_local_hints_immediate(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "local_hints_immediate" 2 +| CT_local_hints_resolve(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "local_hints_resolve" 2 +| CT_local_infix(x1, x2, x3, x4) -> + fSTRING x1; + fID x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "local_infix" 4 +| CT_local_open_scope(x1) -> + fID x1; + fNODE "local_open_scope" 1 +| CT_local_reserve_notation(x1, x2) -> + fSTRING x1; + fMODIFIER_LIST x2; + fNODE "local_reserve_notation" 2 +| CT_locate(x1) -> + fID x1; + fNODE "locate" 1 +| CT_locate_file(x1) -> + fSTRING x1; + fNODE "locate_file" 1 +| CT_locate_lib(x1) -> + fID x1; + fNODE "locate_lib" 1 +| CT_locate_notation(x1) -> + fSTRING x1; + fNODE "locate_notation" 1 +| CT_mind_decl(x1, x2) -> + fCO_IND x1; + fIND_SPEC_LIST x2; + fNODE "mind_decl" 2 +| CT_ml_add_path(x1) -> + fSTRING x1; + fNODE "ml_add_path" 1 +| CT_ml_declare_modules(x1) -> + fSTRING_NE_LIST x1; + fNODE "ml_declare_modules" 1 +| CT_ml_print_modules -> fNODE "ml_print_modules" 0 +| CT_ml_print_path -> fNODE "ml_print_path" 0 +| CT_module(x1, x2, x3, x4) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_CHECK x3; + fMODULE_EXPR x4; + fNODE "module" 4 +| CT_module_type_decl(x1, x2, x3) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_OPT x3; + fNODE "module_type_decl" 3 +| CT_no_inline(x1) -> + fID_NE_LIST x1; + fNODE "no_inline" 1 +| CT_omega_flag(x1, x2) -> + fOMEGA_MODE x1; + fOMEGA_FEATURE x2; + fNODE "omega_flag" 2 +| CT_opaque(x1) -> + fID_NE_LIST x1; + fNODE "opaque" 1 +| CT_open_scope(x1) -> + fID x1; + fNODE "open_scope" 1 +| CT_print -> fNODE "print" 0 +| CT_print_about(x1) -> + fID x1; + fNODE "print_about" 1 +| CT_print_all -> fNODE "print_all" 0 +| CT_print_classes -> fNODE "print_classes" 0 +| CT_print_coercions -> fNODE "print_coercions" 0 +| CT_print_grammar(x1) -> + fGRAMMAR x1; + fNODE "print_grammar" 1 +| CT_print_graph -> fNODE "print_graph" 0 +| CT_print_hint(x1) -> + fID_OPT x1; + fNODE "print_hint" 1 +| CT_print_hintdb(x1) -> + fID_OR_STAR x1; + fNODE "print_hintdb" 1 +| CT_print_id(x1) -> + fID x1; + fNODE "print_id" 1 +| CT_print_implicit(x1) -> + fID x1; + fNODE "print_implicit" 1 +| CT_print_loadpath -> fNODE "print_loadpath" 0 +| CT_print_module(x1) -> + fID x1; + fNODE "print_module" 1 +| CT_print_module_type(x1) -> + fID x1; + fNODE "print_module_type" 1 +| CT_print_modules -> fNODE "print_modules" 0 +| CT_print_natural(x1) -> + fID x1; + fNODE "print_natural" 1 +| CT_print_natural_feature(x1) -> + fNATURAL_FEATURE x1; + fNODE "print_natural_feature" 1 +| CT_print_opaqueid(x1) -> + fID x1; + fNODE "print_opaqueid" 1 +| CT_print_path(x1, x2) -> + fID x1; + fID x2; + fNODE "print_path" 2 +| CT_print_proof(x1) -> + fID x1; + fNODE "print_proof" 1 +| CT_print_scope(x1) -> + fID x1; + fNODE "print_scope" 1 +| CT_print_scopes -> fNODE "print_scopes" 0 +| CT_print_section(x1) -> + fID x1; + fNODE "print_section" 1 +| CT_print_states -> fNODE "print_states" 0 +| CT_print_tables -> fNODE "print_tables" 0 +| CT_print_universes(x1) -> + fSTRING_OPT x1; + fNODE "print_universes" 1 +| CT_print_visibility(x1) -> + fID_OPT x1; + fNODE "print_visibility" 1 +| CT_proof(x1) -> + fFORMULA x1; + fNODE "proof" 1 +| CT_proof_no_op -> fNODE "proof_no_op" 0 +| CT_proof_with(x1) -> + fTACTIC_COM x1; + fNODE "proof_with" 1 +| CT_pwd -> fNODE "pwd" 0 +| CT_quit -> fNODE "quit" 0 +| CT_read_module(x1) -> + fID x1; + fNODE "read_module" 1 +| CT_rec_ml_add_path(x1) -> + fSTRING x1; + fNODE "rec_ml_add_path" 1 +| CT_recaddpath(x1, x2) -> + fSTRING x1; + fID_OPT x2; + fNODE "recaddpath" 2 +| CT_record(x1, x2, x3, x4, x5, x6) -> + fCOERCION_OPT x1; + fID x2; + fBINDER_LIST x3; + fFORMULA x4; + fID_OPT x5; + fRECCONSTR_LIST x6; + fNODE "record" 6 +| CT_remove_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "remove_natural_feature" 2 +| CT_require(x1, x2, x3) -> + fIMPEXP x1; + fSPEC_OPT x2; + fID_NE_LIST_OR_STRING x3; + fNODE "require" 3 +| CT_reserve(x1, x2) -> + fID_NE_LIST x1; + fFORMULA x2; + fNODE "reserve" 2 +| CT_reserve_notation(x1, x2) -> + fSTRING x1; + fMODIFIER_LIST x2; + fNODE "reserve_notation" 2 +| CT_reset(x1) -> + fID x1; + fNODE "reset" 1 +| CT_reset_section(x1) -> + fID x1; + fNODE "reset_section" 1 +| CT_restart -> fNODE "restart" 0 +| CT_restore_state(x1) -> + fID x1; + fNODE "restore_state" 1 +| CT_resume(x1) -> + fID_OPT x1; + fNODE "resume" 1 +| CT_save(x1, x2) -> + fTHM_OPT x1; + fID_OPT x2; + fNODE "save" 2 +| CT_scomments(x1) -> + fSCOMMENT_CONTENT_LIST x1; + fNODE "scomments" 1 +| CT_search(x1, x2) -> + fID x1; + fIN_OR_OUT_MODULES x2; + fNODE "search" 2 +| CT_search_about(x1, x2) -> + fID_OR_STRING_NE_LIST x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_about" 2 +| CT_search_pattern(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_pattern" 2 +| CT_search_rewrite(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_rewrite" 2 +| CT_section_end(x1) -> + fID x1; + fNODE "section_end" 1 +| CT_section_struct(x1, x2, x3) -> + fSECTION_BEGIN x1; + fSECTION_BODY x2; + fCOMMAND x3; + fNODE "section_struct" 3 +| CT_set_natural(x1) -> + fID x1; + fNODE "set_natural" 1 +| CT_set_natural_default -> fNODE "set_natural_default" 0 +| CT_set_option(x1) -> + fTABLE x1; + fNODE "set_option" 1 +| CT_set_option_value(x1, x2) -> + fTABLE x1; + fSINGLE_OPTION_VALUE x2; + fNODE "set_option_value" 2 +| CT_set_option_value2(x1, x2) -> + fTABLE x1; + fID_OR_STRING_NE_LIST x2; + fNODE "set_option_value2" 2 +| CT_sethyp(x1) -> + fINT x1; + fNODE "sethyp" 1 +| CT_setundo(x1) -> + fINT x1; + fNODE "setundo" 1 +| CT_show_existentials -> fNODE "show_existentials" 0 +| CT_show_goal(x1) -> + fINT_OPT x1; + fNODE "show_goal" 1 +| CT_show_implicit(x1) -> + fINT x1; + fNODE "show_implicit" 1 +| CT_show_intro -> fNODE "show_intro" 0 +| CT_show_intros -> fNODE "show_intros" 0 +| CT_show_node -> fNODE "show_node" 0 +| CT_show_proof -> fNODE "show_proof" 0 +| CT_show_proofs -> fNODE "show_proofs" 0 +| CT_show_script -> fNODE "show_script" 0 +| CT_show_tree -> fNODE "show_tree" 0 +| CT_solve(x1, x2, x3) -> + fINT x1; + fTACTIC_COM x2; + fDOTDOT_OPT x3; + fNODE "solve" 3 +| CT_suspend -> fNODE "suspend" 0 +| CT_syntax_macro(x1, x2, x3) -> + fID x1; + fFORMULA x2; + fINT_OPT x3; + fNODE "syntax_macro" 3 +| CT_tactic_definition(x1) -> + fTAC_DEF_NE_LIST x1; + fNODE "tactic_definition" 1 +| CT_test_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "test_natural_feature" 2 +| CT_theorem_struct(x1, x2) -> + fTHEOREM_GOAL x1; + fPROOF_SCRIPT x2; + fNODE "theorem_struct" 2 +| CT_time(x1) -> + fCOMMAND x1; + fNODE "time" 1 +| CT_transparent(x1) -> + fID_NE_LIST x1; + fNODE "transparent" 1 +| CT_undo(x1) -> + fINT_OPT x1; + fNODE "undo" 1 +| CT_unfocus -> fNODE "unfocus" 0 +| CT_unset_option(x1) -> + fTABLE x1; + fNODE "unset_option" 1 +| CT_unsethyp -> fNODE "unsethyp" 0 +| CT_unsetundo -> fNODE "unsetundo" 0 +| CT_user_vernac(x1, x2) -> + fID x1; + fVARG_LIST x2; + fNODE "user_vernac" 2 +| CT_variable(x1, x2) -> + fVAR x1; + fBINDER_NE_LIST x2; + fNODE "variable" 2 +| CT_write_module(x1, x2) -> + fID x1; + fSTRING_OPT x2; + fNODE "write_module" 2 +and fCOMMAND_LIST = function +| CT_command_list(x,l) -> + fCOMMAND x; + (List.iter fCOMMAND l); + fNODE "command_list" (1 + (List.length l)) +and fCOMMENT = function +| CT_comment x -> fATOM "comment"; + (f_atom_string x); + print_string "\n"and fCOMMENT_S = function +| CT_comment_s l -> + (List.iter fCOMMENT l); + fNODE "comment_s" (List.length l) +and fCONSTR = function +| CT_constr(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "constr" 2 +| CT_constr_coercion(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "constr_coercion" 2 +and fCONSTR_LIST = function +| CT_constr_list l -> + (List.iter fCONSTR l); + fNODE "constr_list" (List.length l) +and fCONTEXT_HYP_LIST = function +| CT_context_hyp_list l -> + (List.iter fPREMISE_PATTERN l); + fNODE "context_hyp_list" (List.length l) +and fCONTEXT_PATTERN = function +| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x +| CT_context(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "context" 2 +and fCONTEXT_RULE = function +| CT_context_rule(x1, x2, x3) -> + fCONTEXT_HYP_LIST x1; + fCONTEXT_PATTERN x2; + fTACTIC_COM x3; + fNODE "context_rule" 3 +| CT_def_context_rule(x1) -> + fTACTIC_COM x1; + fNODE "def_context_rule" 1 +and fCONVERSION_FLAG = function +| CT_beta -> fNODE "beta" 0 +| CT_delta -> fNODE "delta" 0 +| CT_evar -> fNODE "evar" 0 +| CT_iota -> fNODE "iota" 0 +| CT_zeta -> fNODE "zeta" 0 +and fCONVERSION_FLAG_LIST = function +| CT_conversion_flag_list l -> + (List.iter fCONVERSION_FLAG l); + fNODE "conversion_flag_list" (List.length l) +and fCONV_SET = function +| CT_unf l -> + (List.iter fID l); + fNODE "unf" (List.length l) +| CT_unfbut l -> + (List.iter fID l); + fNODE "unfbut" (List.length l) +and fCO_IND = function +| CT_co_ind x -> fATOM "co_ind"; + (f_atom_string x); + print_string "\n"and fDECL_NOTATION_OPT = function +| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x +| CT_decl_notation(x1, x2, x3) -> + fSTRING x1; + fFORMULA x2; + fID_OPT x3; + fNODE "decl_notation" 3 +and fDEF = function +| CT_def(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "def" 2 +and fDEFN = function +| CT_defn x -> fATOM "defn"; + (f_atom_string x); + print_string "\n"and fDEFN_OR_THM = function +| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x +| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x +and fDEF_BODY = function +| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x +| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x +| CT_type_of(x1) -> + fFORMULA x1; + fNODE "type_of" 1 +and fDEF_BODY_OPT = function +| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x +| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x +and fDEP = function +| CT_dep x -> fATOM "dep"; + (f_atom_string x); + print_string "\n"and fDESTRUCTING = function +| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x +| CT_destructing -> fNODE "destructing" 0 +and fDESTRUCT_LOCATION = function +| CT_conclusion_location -> fNODE "conclusion_location" 0 +| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0 +| CT_hypothesis_location -> fNODE "hypothesis_location" 0 +and fDOTDOT_OPT = function +| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x +| CT_dotdot -> fNODE "dotdot" 0 +and fEQN = function +| CT_eqn(x1, x2) -> + fMATCH_PATTERN_NE_LIST x1; + fFORMULA x2; + fNODE "eqn" 2 +and fEQN_LIST = function +| CT_eqn_list l -> + (List.iter fEQN l); + fNODE "eqn_list" (List.length l) +and fEVAL_CMD = function +| CT_eval(x1, x2, x3) -> + fINT_OPT x1; + fRED_COM x2; + fFORMULA x3; + fNODE "eval" 3 +and fFIXTAC = function +| CT_fixtac(x1, x2, x3) -> + fID x1; + fINT x2; + fFORMULA x3; + fNODE "fixtac" 3 +and fFIX_BINDER = function +| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x +| CT_fix_binder(x1, x2, x3, x4) -> + fID x1; + fINT x2; + fFORMULA x3; + fFORMULA x4; + fNODE "fix_binder" 4 +and fFIX_BINDER_LIST = function +| CT_fix_binder_list(x,l) -> + fFIX_BINDER x; + (List.iter fFIX_BINDER l); + fNODE "fix_binder_list" (1 + (List.length l)) +and fFIX_REC = function +| CT_fix_rec(x1, x2, x3, x4, x5) -> + fID x1; + fBINDER_NE_LIST x2; + fID_OPT x3; + fFORMULA x4; + fFORMULA x5; + fNODE "fix_rec" 5 +and fFIX_REC_LIST = function +| CT_fix_rec_list(x,l) -> + fFIX_REC x; + (List.iter fFIX_REC l); + fNODE "fix_rec_list" (1 + (List.length l)) +and fFIX_TAC_LIST = function +| CT_fix_tac_list l -> + (List.iter fFIXTAC l); + fNODE "fix_tac_list" (List.length l) +and fFORMULA = function +| CT_coerce_BINARY_to_FORMULA x -> fBINARY x +| CT_coerce_ID_to_FORMULA x -> fID x +| CT_coerce_NUM_to_FORMULA x -> fNUM x +| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x +| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x +| CT_appc(x1, x2) -> + fFORMULA x1; + fFORMULA_NE_LIST x2; + fNODE "appc" 2 +| CT_arrowc(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "arrowc" 2 +| CT_bang(x1) -> + fFORMULA x1; + fNODE "bang" 1 +| CT_cases(x1, x2, x3) -> + fMATCHED_FORMULA_NE_LIST x1; + fFORMULA_OPT x2; + fEQN_LIST x3; + fNODE "cases" 3 +| CT_cofixc(x1, x2) -> + fID x1; + fCOFIX_REC_LIST x2; + fNODE "cofixc" 2 +| CT_elimc(x1, x2, x3, x4) -> + fCASE x1; + fFORMULA_OPT x2; + fFORMULA x3; + fFORMULA_LIST x4; + fNODE "elimc" 4 +| CT_existvarc -> fNODE "existvarc" 0 +| CT_fixc(x1, x2) -> + fID x1; + fFIX_BINDER_LIST x2; + fNODE "fixc" 2 +| CT_if(x1, x2, x3, x4) -> + fFORMULA x1; + fRETURN_INFO x2; + fFORMULA x3; + fFORMULA x4; + fNODE "if" 4 +| CT_inductive_let(x1, x2, x3, x4) -> + fFORMULA_OPT x1; + fID_OPT_NE_LIST x2; + fFORMULA x3; + fFORMULA x4; + fNODE "inductive_let" 4 +| CT_labelled_arg(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "labelled_arg" 2 +| CT_lambdac(x1, x2) -> + fBINDER_NE_LIST x1; + fFORMULA x2; + fNODE "lambdac" 2 +| CT_let_tuple(x1, x2, x3, x4) -> + fID_OPT_NE_LIST x1; + fRETURN_INFO x2; + fFORMULA x3; + fFORMULA x4; + fNODE "let_tuple" 4 +| CT_letin(x1, x2) -> + fDEF x1; + fFORMULA x2; + fNODE "letin" 2 +| CT_notation(x1, x2) -> + fSTRING x1; + fFORMULA_LIST x2; + fNODE "notation" 2 +| CT_num_encapsulator(x1, x2) -> + fNUM_TYPE x1; + fFORMULA x2; + fNODE "num_encapsulator" 2 +| CT_prodc(x1, x2) -> + fBINDER_NE_LIST x1; + fFORMULA x2; + fNODE "prodc" 2 +| CT_proj(x1, x2) -> + fFORMULA x1; + fFORMULA_NE_LIST x2; + fNODE "proj" 2 +and fFORMULA_LIST = function +| CT_formula_list l -> + (List.iter fFORMULA l); + fNODE "formula_list" (List.length l) +and fFORMULA_NE_LIST = function +| CT_formula_ne_list(x,l) -> + fFORMULA x; + (List.iter fFORMULA l); + fNODE "formula_ne_list" (1 + (List.length l)) +and fFORMULA_OPT = function +| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x +| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x +and fFORMULA_OR_INT = function +| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x +| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x +and fGRAMMAR = function +| CT_grammar_none -> fNODE "grammar_none" 0 +and fHYP_LOCATION = function +| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x +| CT_intype(x1, x2) -> + fID x1; + fINT_LIST x2; + fNODE "intype" 2 +| CT_invalue(x1, x2) -> + fID x1; + fINT_LIST x2; + fNODE "invalue" 2 +and fHYP_LOCATION_LIST_OR_STAR = function +| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x +| CT_hyp_location_list l -> + (List.iter fHYP_LOCATION l); + fNODE "hyp_location_list" (List.length l) +and fID = function +| CT_ident x -> fATOM "ident"; + (f_atom_string x); + print_string "\n"| CT_metac(x1) -> + fINT x1; + fNODE "metac" 1 +| CT_metaid x -> fATOM "metaid"; + (f_atom_string x); + print_string "\n"and fIDENTITY_OPT = function +| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x +| CT_identity -> fNODE "identity" 0 +and fID_LIST = function +| CT_id_list l -> + (List.iter fID l); + fNODE "id_list" (List.length l) +and fID_LIST_LIST = function +| CT_id_list_list l -> + (List.iter fID_LIST l); + fNODE "id_list_list" (List.length l) +and fID_LIST_OPT = function +| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x +| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x +and fID_NE_LIST = function +| CT_id_ne_list(x,l) -> + fID x; + (List.iter fID l); + fNODE "id_ne_list" (1 + (List.length l)) +and fID_NE_LIST_OR_STAR = function +| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x +| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x +and fID_NE_LIST_OR_STRING = function +| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x +| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x +and fID_OPT = function +| CT_coerce_ID_to_ID_OPT x -> fID x +| CT_coerce_NONE_to_ID_OPT x -> fNONE x +and fID_OPT_LIST = function +| CT_id_opt_list l -> + (List.iter fID_OPT l); + fNODE "id_opt_list" (List.length l) +and fID_OPT_NE_LIST = function +| CT_id_opt_ne_list(x,l) -> + fID_OPT x; + (List.iter fID_OPT l); + fNODE "id_opt_ne_list" (1 + (List.length l)) +and fID_OPT_OR_ALL = function +| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x +| CT_all -> fNODE "all" 0 +and fID_OR_INT = function +| CT_coerce_ID_to_ID_OR_INT x -> fID x +| CT_coerce_INT_to_ID_OR_INT x -> fINT x +and fID_OR_INT_OPT = function +| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x +| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x +| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x +and fID_OR_STAR = function +| CT_coerce_ID_to_ID_OR_STAR x -> fID x +| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x +and fID_OR_STRING = function +| CT_coerce_ID_to_ID_OR_STRING x -> fID x +| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x +and fID_OR_STRING_NE_LIST = function +| CT_id_or_string_ne_list(x,l) -> + fID_OR_STRING x; + (List.iter fID_OR_STRING l); + fNODE "id_or_string_ne_list" (1 + (List.length l)) +and fIMPEXP = function +| CT_coerce_NONE_to_IMPEXP x -> fNONE x +| CT_export -> fNODE "export" 0 +| CT_import -> fNODE "import" 0 +and fIND_SPEC = function +| CT_ind_spec(x1, x2, x3, x4, x5) -> + fID x1; + fBINDER_LIST x2; + fFORMULA x3; + fCONSTR_LIST x4; + fDECL_NOTATION_OPT x5; + fNODE "ind_spec" 5 +and fIND_SPEC_LIST = function +| CT_ind_spec_list l -> + (List.iter fIND_SPEC l); + fNODE "ind_spec_list" (List.length l) +and fINT = function +| CT_int x -> fATOM "int"; + (f_atom_int x); + print_string "\n"and fINTRO_PATT = function +| CT_coerce_ID_to_INTRO_PATT x -> fID x +| CT_disj_pattern(x,l) -> + fINTRO_PATT_LIST x; + (List.iter fINTRO_PATT_LIST l); + fNODE "disj_pattern" (1 + (List.length l)) +and fINTRO_PATT_LIST = function +| CT_intro_patt_list l -> + (List.iter fINTRO_PATT l); + fNODE "intro_patt_list" (List.length l) +and fINTRO_PATT_OPT = function +| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x +| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x +and fINT_LIST = function +| CT_int_list l -> + (List.iter fINT l); + fNODE "int_list" (List.length l) +and fINT_NE_LIST = function +| CT_int_ne_list(x,l) -> + fINT x; + (List.iter fINT l); + fNODE "int_ne_list" (1 + (List.length l)) +and fINT_OPT = function +| CT_coerce_INT_to_INT_OPT x -> fINT x +| CT_coerce_NONE_to_INT_OPT x -> fNONE x +and fINT_OR_LOCN = function +| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x +| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x +and fINT_OR_NEXT = function +| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x +| CT_next_level -> fNODE "next_level" 0 +and fINV_TYPE = function +| CT_inv_clear -> fNODE "inv_clear" 0 +| CT_inv_regular -> fNODE "inv_regular" 0 +| CT_inv_simple -> fNODE "inv_simple" 0 +and fIN_OR_OUT_MODULES = function +| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x +| CT_in_modules(x1) -> + fID_NE_LIST x1; + fNODE "in_modules" 1 +| CT_out_modules(x1) -> + fID_NE_LIST x1; + fNODE "out_modules" 1 +and fLET_CLAUSE = function +| CT_let_clause(x1, x2, x3) -> + fID x1; + fTACTIC_OPT x2; + fLET_VALUE x3; + fNODE "let_clause" 3 +and fLET_CLAUSES = function +| CT_let_clauses(x,l) -> + fLET_CLAUSE x; + (List.iter fLET_CLAUSE l); + fNODE "let_clauses" (1 + (List.length l)) +and fLET_VALUE = function +| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x +| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x +and fLOCAL_OPT = function +| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x +| CT_local -> fNODE "local" 0 +and fLOCN = function +| CT_locn x -> fATOM "locn"; + (f_atom_string x); + print_string "\n"and fMATCHED_FORMULA = function +| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x +| CT_formula_as(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "formula_as" 2 +| CT_formula_as_in(x1, x2, x3) -> + fFORMULA x1; + fID_OPT x2; + fFORMULA x3; + fNODE "formula_as_in" 3 +| CT_formula_in(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "formula_in" 2 +and fMATCHED_FORMULA_NE_LIST = function +| CT_matched_formula_ne_list(x,l) -> + fMATCHED_FORMULA x; + (List.iter fMATCHED_FORMULA l); + fNODE "matched_formula_ne_list" (1 + (List.length l)) +and fMATCH_PATTERN = function +| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x +| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x +| CT_pattern_app(x1, x2) -> + fMATCH_PATTERN x1; + fMATCH_PATTERN_NE_LIST x2; + fNODE "pattern_app" 2 +| CT_pattern_as(x1, x2) -> + fMATCH_PATTERN x1; + fID_OPT x2; + fNODE "pattern_as" 2 +| CT_pattern_delimitors(x1, x2) -> + fNUM_TYPE x1; + fMATCH_PATTERN x2; + fNODE "pattern_delimitors" 2 +| CT_pattern_notation(x1, x2) -> + fSTRING x1; + fMATCH_PATTERN_LIST x2; + fNODE "pattern_notation" 2 +and fMATCH_PATTERN_LIST = function +| CT_match_pattern_list l -> + (List.iter fMATCH_PATTERN l); + fNODE "match_pattern_list" (List.length l) +and fMATCH_PATTERN_NE_LIST = function +| CT_match_pattern_ne_list(x,l) -> + fMATCH_PATTERN x; + (List.iter fMATCH_PATTERN l); + fNODE "match_pattern_ne_list" (1 + (List.length l)) +and fMATCH_TAC_RULE = function +| CT_match_tac_rule(x1, x2) -> + fCONTEXT_PATTERN x1; + fLET_VALUE x2; + fNODE "match_tac_rule" 2 +and fMATCH_TAC_RULES = function +| CT_match_tac_rules(x,l) -> + fMATCH_TAC_RULE x; + (List.iter fMATCH_TAC_RULE l); + fNODE "match_tac_rules" (1 + (List.length l)) +and fMODIFIER = function +| CT_entry_type(x1, x2) -> + fID x1; + fID x2; + fNODE "entry_type" 2 +| CT_format(x1) -> + fSTRING x1; + fNODE "format" 1 +| CT_lefta -> fNODE "lefta" 0 +| CT_nona -> fNODE "nona" 0 +| CT_only_parsing -> fNODE "only_parsing" 0 +| CT_righta -> fNODE "righta" 0 +| CT_set_item_level(x1, x2) -> + fID_NE_LIST x1; + fINT_OR_NEXT x2; + fNODE "set_item_level" 2 +| CT_set_level(x1) -> + fINT x1; + fNODE "set_level" 1 +and fMODIFIER_LIST = function +| CT_modifier_list l -> + (List.iter fMODIFIER l); + fNODE "modifier_list" (List.length l) +and fMODULE_BINDER = function +| CT_module_binder(x1, x2) -> + fID_NE_LIST x1; + fMODULE_TYPE x2; + fNODE "module_binder" 2 +and fMODULE_BINDER_LIST = function +| CT_module_binder_list l -> + (List.iter fMODULE_BINDER l); + fNODE "module_binder_list" (List.length l) +and fMODULE_EXPR = function +| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x +| CT_module_app(x1, x2) -> + fMODULE_EXPR x1; + fMODULE_EXPR x2; + fNODE "module_app" 2 +and fMODULE_TYPE = function +| CT_coerce_ID_to_MODULE_TYPE x -> fID x +| CT_module_type_with_def(x1, x2, x3) -> + fMODULE_TYPE x1; + fID x2; + fFORMULA x3; + fNODE "module_type_with_def" 3 +| CT_module_type_with_mod(x1, x2, x3) -> + fMODULE_TYPE x1; + fID x2; + fID x3; + fNODE "module_type_with_mod" 3 +and fMODULE_TYPE_CHECK = function +| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x +| CT_only_check(x1) -> + fMODULE_TYPE x1; + fNODE "only_check" 1 +and fMODULE_TYPE_OPT = function +| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x +| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x +and fNATURAL_FEATURE = function +| CT_contractible -> fNODE "contractible" 0 +| CT_implicit -> fNODE "implicit" 0 +| CT_nat_transparent -> fNODE "nat_transparent" 0 +and fNONE = function +| CT_none -> fNODE "none" 0 +and fNUM = function +| CT_int_encapsulator x -> fATOM "int_encapsulator"; + (f_atom_string x); + print_string "\n"and fNUM_TYPE = function +| CT_num_type x -> fATOM "num_type"; + (f_atom_string x); + print_string "\n"and fOMEGA_FEATURE = function +| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x +| CT_flag_action -> fNODE "flag_action" 0 +| CT_flag_system -> fNODE "flag_system" 0 +| CT_flag_time -> fNODE "flag_time" 0 +and fOMEGA_MODE = function +| CT_set -> fNODE "set" 0 +| CT_switch -> fNODE "switch" 0 +| CT_unset -> fNODE "unset" 0 +and fORIENTATION = function +| CT_lr -> fNODE "lr" 0 +| CT_rl -> fNODE "rl" 0 +and fPATTERN = function +| CT_pattern_occ(x1, x2) -> + fINT_LIST x1; + fFORMULA x2; + fNODE "pattern_occ" 2 +and fPATTERN_NE_LIST = function +| CT_pattern_ne_list(x,l) -> + fPATTERN x; + (List.iter fPATTERN l); + fNODE "pattern_ne_list" (1 + (List.length l)) +and fPATTERN_OPT = function +| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x +| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x +and fPREMISE = function +| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x +| CT_eval_result(x1, x2, x3) -> + fFORMULA x1; + fFORMULA x2; + fFORMULA x3; + fNODE "eval_result" 3 +| CT_premise(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "premise" 2 +and fPREMISES_LIST = function +| CT_premises_list l -> + (List.iter fPREMISE l); + fNODE "premises_list" (List.length l) +and fPREMISE_PATTERN = function +| CT_premise_pattern(x1, x2) -> + fID_OPT x1; + fCONTEXT_PATTERN x2; + fNODE "premise_pattern" 2 +and fPROOF_SCRIPT = function +| CT_proof_script l -> + (List.iter fCOMMAND l); + fNODE "proof_script" (List.length l) +and fRECCONSTR = function +| CT_defrecconstr(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fFORMULA_OPT x3; + fNODE "defrecconstr" 3 +| CT_defrecconstr_coercion(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fFORMULA_OPT x3; + fNODE "defrecconstr_coercion" 3 +| CT_recconstr(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "recconstr" 2 +| CT_recconstr_coercion(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "recconstr_coercion" 2 +and fRECCONSTR_LIST = function +| CT_recconstr_list l -> + (List.iter fRECCONSTR l); + fNODE "recconstr_list" (List.length l) +and fREC_TACTIC_FUN = function +| CT_rec_tactic_fun(x1, x2, x3) -> + fID x1; + fID_OPT_NE_LIST x2; + fTACTIC_COM x3; + fNODE "rec_tactic_fun" 3 +and fREC_TACTIC_FUN_LIST = function +| CT_rec_tactic_fun_list(x,l) -> + fREC_TACTIC_FUN x; + (List.iter fREC_TACTIC_FUN l); + fNODE "rec_tactic_fun_list" (1 + (List.length l)) +and fRED_COM = function +| CT_cbv(x1, x2) -> + fCONVERSION_FLAG_LIST x1; + fCONV_SET x2; + fNODE "cbv" 2 +| CT_fold(x1) -> + fFORMULA_LIST x1; + fNODE "fold" 1 +| CT_hnf -> fNODE "hnf" 0 +| CT_lazy(x1, x2) -> + fCONVERSION_FLAG_LIST x1; + fCONV_SET x2; + fNODE "lazy" 2 +| CT_pattern(x1) -> + fPATTERN_NE_LIST x1; + fNODE "pattern" 1 +| CT_red -> fNODE "red" 0 +| CT_simpl(x1) -> + fPATTERN_OPT x1; + fNODE "simpl" 1 +| CT_unfold(x1) -> + fUNFOLD_NE_LIST x1; + fNODE "unfold" 1 +and fRETURN_INFO = function +| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x +| CT_as_and_return(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "as_and_return" 2 +| CT_return(x1) -> + fFORMULA x1; + fNODE "return" 1 +and fRULE = function +| CT_rule(x1, x2) -> + fPREMISES_LIST x1; + fFORMULA x2; + fNODE "rule" 2 +and fRULE_LIST = function +| CT_rule_list l -> + (List.iter fRULE l); + fNODE "rule_list" (List.length l) +and fSCHEME_SPEC = function +| CT_scheme_spec(x1, x2, x3, x4) -> + fID x1; + fDEP x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "scheme_spec" 4 +and fSCHEME_SPEC_LIST = function +| CT_scheme_spec_list(x,l) -> + fSCHEME_SPEC x; + (List.iter fSCHEME_SPEC l); + fNODE "scheme_spec_list" (1 + (List.length l)) +and fSCOMMENT_CONTENT = function +| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x +| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x +and fSCOMMENT_CONTENT_LIST = function +| CT_scomment_content_list l -> + (List.iter fSCOMMENT_CONTENT l); + fNODE "scomment_content_list" (List.length l) +and fSECTION_BEGIN = function +| CT_section(x1) -> + fID x1; + fNODE "section" 1 +and fSECTION_BODY = function +| CT_section_body l -> + (List.iter fCOMMAND l); + fNODE "section_body" (List.length l) +and fSIGNED_INT = function +| CT_coerce_INT_to_SIGNED_INT x -> fINT x +| CT_minus(x1) -> + fINT x1; + fNODE "minus" 1 +and fSIGNED_INT_LIST = function +| CT_signed_int_list l -> + (List.iter fSIGNED_INT l); + fNODE "signed_int_list" (List.length l) +and fSINGLE_OPTION_VALUE = function +| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x +| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x +and fSORT_TYPE = function +| CT_sortc x -> fATOM "sortc"; + (f_atom_string x); + print_string "\n"and fSPEC_LIST = function +| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x +| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x +and fSPEC_OPT = function +| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x +| CT_spec -> fNODE "spec" 0 +and fSTAR = function +| CT_star -> fNODE "star" 0 +and fSTAR_OPT = function +| CT_coerce_NONE_to_STAR_OPT x -> fNONE x +| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x +and fSTRING = function +| CT_string x -> fATOM "string"; + (f_atom_string x); + print_string "\n"and fSTRING_NE_LIST = function +| CT_string_ne_list(x,l) -> + fSTRING x; + (List.iter fSTRING l); + fNODE "string_ne_list" (1 + (List.length l)) +and fSTRING_OPT = function +| CT_coerce_NONE_to_STRING_OPT x -> fNONE x +| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x +and fTABLE = function +| CT_coerce_ID_to_TABLE x -> fID x +| CT_table(x1, x2) -> + fID x1; + fID x2; + fNODE "table" 2 +and fTACTIC_ARG = function +| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x +| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x +| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x +| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x +| CT_void -> fNODE "void" 0 +and fTACTIC_ARG_LIST = function +| CT_tactic_arg_list(x,l) -> + fTACTIC_ARG x; + (List.iter fTACTIC_ARG l); + fNODE "tactic_arg_list" (1 + (List.length l)) +and fTACTIC_COM = function +| CT_abstract(x1, x2) -> + fID_OPT x1; + fTACTIC_COM x2; + fNODE "abstract" 2 +| CT_absurd(x1) -> + fFORMULA x1; + fNODE "absurd" 1 +| CT_any_constructor(x1) -> + fTACTIC_OPT x1; + fNODE "any_constructor" 1 +| CT_apply(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "apply" 2 +| CT_assert(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "assert" 2 +| CT_assumption -> fNODE "assumption" 0 +| CT_auto(x1) -> + fINT_OPT x1; + fNODE "auto" 1 +| CT_auto_with(x1, x2) -> + fINT_OPT x1; + fID_NE_LIST_OR_STAR x2; + fNODE "auto_with" 2 +| CT_autorewrite(x1, x2) -> + fID_NE_LIST x1; + fTACTIC_OPT x2; + fNODE "autorewrite" 2 +| CT_autotdb(x1) -> + fINT_OPT x1; + fNODE "autotdb" 1 +| CT_case_type(x1) -> + fFORMULA x1; + fNODE "case_type" 1 +| CT_casetac(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "casetac" 2 +| CT_cdhyp(x1) -> + fID x1; + fNODE "cdhyp" 1 +| CT_change(x1, x2) -> + fFORMULA x1; + fCLAUSE x2; + fNODE "change" 2 +| CT_change_local(x1, x2, x3) -> + fPATTERN x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "change_local" 3 +| CT_clear(x1) -> + fID_NE_LIST x1; + fNODE "clear" 1 +| CT_clear_body(x1) -> + fID_NE_LIST x1; + fNODE "clear_body" 1 +| CT_cofixtactic(x1, x2) -> + fID_OPT x1; + fCOFIX_TAC_LIST x2; + fNODE "cofixtactic" 2 +| CT_condrewrite_lr(x1, x2, x3, x4) -> + fTACTIC_COM x1; + fFORMULA x2; + fSPEC_LIST x3; + fID_OPT x4; + fNODE "condrewrite_lr" 4 +| CT_condrewrite_rl(x1, x2, x3, x4) -> + fTACTIC_COM x1; + fFORMULA x2; + fSPEC_LIST x3; + fID_OPT x4; + fNODE "condrewrite_rl" 4 +| CT_constructor(x1, x2) -> + fINT x1; + fSPEC_LIST x2; + fNODE "constructor" 2 +| CT_contradiction -> fNODE "contradiction" 0 +| CT_contradiction_thm(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "contradiction_thm" 2 +| CT_cut(x1) -> + fFORMULA x1; + fNODE "cut" 1 +| CT_cutrewrite_lr(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "cutrewrite_lr" 2 +| CT_cutrewrite_rl(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "cutrewrite_rl" 2 +| CT_dauto(x1, x2) -> + fINT_OPT x1; + fINT_OPT x2; + fNODE "dauto" 2 +| CT_dconcl -> fNODE "dconcl" 0 +| CT_decompose_list(x1, x2) -> + fID_NE_LIST x1; + fFORMULA x2; + fNODE "decompose_list" 2 +| CT_decompose_record(x1) -> + fFORMULA x1; + fNODE "decompose_record" 1 +| CT_decompose_sum(x1) -> + fFORMULA x1; + fNODE "decompose_sum" 1 +| CT_depinversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID_OR_INT x2; + fINTRO_PATT_OPT x3; + fFORMULA_OPT x4; + fNODE "depinversion" 4 +| CT_deprewrite_lr(x1) -> + fID x1; + fNODE "deprewrite_lr" 1 +| CT_deprewrite_rl(x1) -> + fID x1; + fNODE "deprewrite_rl" 1 +| CT_destruct(x1) -> + fID_OR_INT x1; + fNODE "destruct" 1 +| CT_dhyp(x1) -> + fID x1; + fNODE "dhyp" 1 +| CT_discriminate_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "discriminate_eq" 1 +| CT_do(x1, x2) -> + fID_OR_INT x1; + fTACTIC_COM x2; + fNODE "do" 2 +| CT_eapply(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "eapply" 2 +| CT_eauto(x1, x2) -> + fID_OR_INT_OPT x1; + fID_OR_INT_OPT x2; + fNODE "eauto" 2 +| CT_eauto_with(x1, x2, x3) -> + fID_OR_INT_OPT x1; + fID_OR_INT_OPT x2; + fID_NE_LIST_OR_STAR x3; + fNODE "eauto_with" 3 +| CT_elim(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fUSING x3; + fNODE "elim" 3 +| CT_elim_type(x1) -> + fFORMULA x1; + fNODE "elim_type" 1 +| CT_exact(x1) -> + fFORMULA x1; + fNODE "exact" 1 +| CT_exists(x1) -> + fSPEC_LIST x1; + fNODE "exists" 1 +| CT_fail(x1, x2) -> + fID_OR_INT x1; + fSTRING_OPT x2; + fNODE "fail" 2 +| CT_first(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "first" (1 + (List.length l)) +| CT_firstorder(x1) -> + fTACTIC_OPT x1; + fNODE "firstorder" 1 +| CT_firstorder_using(x1, x2) -> + fTACTIC_OPT x1; + fID_NE_LIST x2; + fNODE "firstorder_using" 2 +| CT_firstorder_with(x1, x2) -> + fTACTIC_OPT x1; + fID_NE_LIST x2; + fNODE "firstorder_with" 2 +| CT_fixtactic(x1, x2, x3) -> + fID_OPT x1; + fINT x2; + fFIX_TAC_LIST x3; + fNODE "fixtactic" 3 +| CT_formula_marker(x1) -> + fFORMULA x1; + fNODE "formula_marker" 1 +| CT_fresh(x1) -> + fSTRING_OPT x1; + fNODE "fresh" 1 +| CT_generalize(x1) -> + fFORMULA_NE_LIST x1; + fNODE "generalize" 1 +| CT_generalize_dependent(x1) -> + fFORMULA x1; + fNODE "generalize_dependent" 1 +| CT_idtac(x1) -> + fSTRING_OPT x1; + fNODE "idtac" 1 +| CT_induction(x1) -> + fID_OR_INT x1; + fNODE "induction" 1 +| CT_info(x1) -> + fTACTIC_COM x1; + fNODE "info" 1 +| CT_injection_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "injection_eq" 1 +| CT_instantiate(x1, x2, x3) -> + fINT x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "instantiate" 3 +| CT_intro(x1) -> + fID_OPT x1; + fNODE "intro" 1 +| CT_intro_after(x1, x2) -> + fID_OPT x1; + fID x2; + fNODE "intro_after" 2 +| CT_intros(x1) -> + fINTRO_PATT_LIST x1; + fNODE "intros" 1 +| CT_intros_until(x1) -> + fID_OR_INT x1; + fNODE "intros_until" 1 +| CT_inversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID_OR_INT x2; + fINTRO_PATT_OPT x3; + fID_LIST x4; + fNODE "inversion" 4 +| CT_left(x1) -> + fSPEC_LIST x1; + fNODE "left" 1 +| CT_let_ltac(x1, x2) -> + fLET_CLAUSES x1; + fLET_VALUE x2; + fNODE "let_ltac" 2 +| CT_lettac(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "lettac" 3 +| CT_match_context(x,l) -> + fCONTEXT_RULE x; + (List.iter fCONTEXT_RULE l); + fNODE "match_context" (1 + (List.length l)) +| CT_match_context_reverse(x,l) -> + fCONTEXT_RULE x; + (List.iter fCONTEXT_RULE l); + fNODE "match_context_reverse" (1 + (List.length l)) +| CT_match_tac(x1, x2) -> + fTACTIC_COM x1; + fMATCH_TAC_RULES x2; + fNODE "match_tac" 2 +| CT_move_after(x1, x2) -> + fID x1; + fID x2; + fNODE "move_after" 2 +| CT_new_destruct(x1, x2, x3) -> + fFORMULA_OR_INT x1; + fUSING x2; + fINTRO_PATT_OPT x3; + fNODE "new_destruct" 3 +| CT_new_induction(x1, x2, x3) -> + fFORMULA_OR_INT x1; + fUSING x2; + fINTRO_PATT_OPT x3; + fNODE "new_induction" 3 +| CT_omega -> fNODE "omega" 0 +| CT_orelse(x1, x2) -> + fTACTIC_COM x1; + fTACTIC_COM x2; + fNODE "orelse" 2 +| CT_parallel(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "parallel" (1 + (List.length l)) +| CT_pose(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "pose" 2 +| CT_progress(x1) -> + fTACTIC_COM x1; + fNODE "progress" 1 +| CT_prolog(x1, x2) -> + fFORMULA_LIST x1; + fINT x2; + fNODE "prolog" 2 +| CT_rec_tactic_in(x1, x2) -> + fREC_TACTIC_FUN_LIST x1; + fTACTIC_COM x2; + fNODE "rec_tactic_in" 2 +| CT_reduce(x1, x2) -> + fRED_COM x1; + fCLAUSE x2; + fNODE "reduce" 2 +| CT_refine(x1) -> + fFORMULA x1; + fNODE "refine" 1 +| CT_reflexivity -> fNODE "reflexivity" 0 +| CT_rename(x1, x2) -> + fID x1; + fID x2; + fNODE "rename" 2 +| CT_repeat(x1) -> + fTACTIC_COM x1; + fNODE "repeat" 1 +| CT_replace_with(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "replace_with" 2 +| CT_rewrite_lr(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fID_OPT x3; + fNODE "rewrite_lr" 3 +| CT_rewrite_rl(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fID_OPT x3; + fNODE "rewrite_rl" 3 +| CT_right(x1) -> + fSPEC_LIST x1; + fNODE "right" 1 +| CT_ring(x1) -> + fFORMULA_LIST x1; + fNODE "ring" 1 +| CT_simple_user_tac(x1, x2) -> + fID x1; + fTACTIC_ARG_LIST x2; + fNODE "simple_user_tac" 2 +| CT_simplify_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "simplify_eq" 1 +| CT_specialize(x1, x2, x3) -> + fINT_OPT x1; + fFORMULA x2; + fSPEC_LIST x3; + fNODE "specialize" 3 +| CT_split(x1) -> + fSPEC_LIST x1; + fNODE "split" 1 +| CT_subst(x1) -> + fID_LIST x1; + fNODE "subst" 1 +| CT_superauto(x1, x2, x3, x4) -> + fINT_OPT x1; + fID_LIST x2; + fDESTRUCTING x3; + fUSINGTDB x4; + fNODE "superauto" 4 +| CT_symmetry(x1) -> + fCLAUSE x1; + fNODE "symmetry" 1 +| CT_tac_double(x1, x2) -> + fID_OR_INT x1; + fID_OR_INT x2; + fNODE "tac_double" 2 +| CT_tacsolve(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "tacsolve" (1 + (List.length l)) +| CT_tactic_fun(x1, x2) -> + fID_OPT_NE_LIST x1; + fTACTIC_COM x2; + fNODE "tactic_fun" 2 +| CT_then(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "then" (1 + (List.length l)) +| CT_transitivity(x1) -> + fFORMULA x1; + fNODE "transitivity" 1 +| CT_trivial -> fNODE "trivial" 0 +| CT_trivial_with(x1) -> + fID_NE_LIST_OR_STAR x1; + fNODE "trivial_with" 1 +| CT_truecut(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "truecut" 2 +| CT_try(x1) -> + fTACTIC_COM x1; + fNODE "try" 1 +| CT_use(x1) -> + fFORMULA x1; + fNODE "use" 1 +| CT_use_inversion(x1, x2, x3) -> + fID_OR_INT x1; + fFORMULA x2; + fID_LIST x3; + fNODE "use_inversion" 3 +| CT_user_tac(x1, x2) -> + fID x1; + fTARG_LIST x2; + fNODE "user_tac" 2 +and fTACTIC_OPT = function +| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x +| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x +and fTAC_DEF = function +| CT_tac_def(x1, x2) -> + fID x1; + fTACTIC_COM x2; + fNODE "tac_def" 2 +and fTAC_DEF_NE_LIST = function +| CT_tac_def_ne_list(x,l) -> + fTAC_DEF x; + (List.iter fTAC_DEF l); + fNODE "tac_def_ne_list" (1 + (List.length l)) +and fTARG = function +| CT_coerce_BINDING_to_TARG x -> fBINDING x +| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x +| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x +| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x +| CT_coerce_PATTERN_to_TARG x -> fPATTERN x +| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x +| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x +| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x +| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x +| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x +| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x +| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x +| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x +and fTARG_LIST = function +| CT_targ_list l -> + (List.iter fTARG l); + fNODE "targ_list" (List.length l) +and fTERM_CHANGE = function +| CT_check_term(x1) -> + fFORMULA x1; + fNODE "check_term" 1 +| CT_inst_term(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "inst_term" 2 +and fTEXT = function +| CT_coerce_ID_to_TEXT x -> fID x +| CT_text_formula(x1) -> + fFORMULA x1; + fNODE "text_formula" 1 +| CT_text_h l -> + (List.iter fTEXT l); + fNODE "text_h" (List.length l) +| CT_text_hv l -> + (List.iter fTEXT l); + fNODE "text_hv" (List.length l) +| CT_text_op l -> + (List.iter fTEXT l); + fNODE "text_op" (List.length l) +| CT_text_path(x1) -> + fSIGNED_INT_LIST x1; + fNODE "text_path" 1 +| CT_text_v l -> + (List.iter fTEXT l); + fNODE "text_v" (List.length l) +and fTHEOREM_GOAL = function +| CT_goal(x1) -> + fFORMULA x1; + fNODE "goal" 1 +| CT_theorem_goal(x1, x2, x3, x4) -> + fDEFN_OR_THM x1; + fID x2; + fBINDER_LIST x3; + fFORMULA x4; + fNODE "theorem_goal" 4 +and fTHM = function +| CT_thm x -> fATOM "thm"; + (f_atom_string x); + print_string "\n"and fTHM_OPT = function +| CT_coerce_NONE_to_THM_OPT x -> fNONE x +| CT_coerce_THM_to_THM_OPT x -> fTHM x +and fTYPED_FORMULA = function +| CT_typed_formula(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "typed_formula" 2 +and fUNFOLD = function +| CT_coerce_ID_to_UNFOLD x -> fID x +| CT_unfold_occ(x1, x2) -> + fID x1; + fINT_NE_LIST x2; + fNODE "unfold_occ" 2 +and fUNFOLD_NE_LIST = function +| CT_unfold_ne_list(x,l) -> + fUNFOLD x; + (List.iter fUNFOLD l); + fNODE "unfold_ne_list" (1 + (List.length l)) +and fUSING = function +| CT_coerce_NONE_to_USING x -> fNONE x +| CT_using(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "using" 2 +and fUSINGTDB = function +| CT_coerce_NONE_to_USINGTDB x -> fNONE x +| CT_usingtdb -> fNODE "usingtdb" 0 +and fVAR = function +| CT_var x -> fATOM "var"; + (f_atom_string x); + print_string "\n"and fVARG = function +| CT_coerce_AST_to_VARG x -> fAST x +| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x +| CT_coerce_BINDER_to_VARG x -> fBINDER x +| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x +| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x +| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x +| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x +| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x +| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x +| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x +| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x +| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x +| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x +| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x +| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x +and fVARG_LIST = function +| CT_varg_list l -> + (List.iter fVARG l); + fNODE "varg_list" (List.length l) +and fVERBOSE_OPT = function +| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x +| CT_verbose -> fNODE "verbose" 0 +;; diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli new file mode 100644 index 00000000..fe30b317 --- /dev/null +++ b/contrib/interface/vtp.mli @@ -0,0 +1,15 @@ +open Ascent;; + +val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;; +val fCOMMAND : ct_COMMAND -> unit;; +val fTACTIC_COM : ct_TACTIC_COM -> unit;; +val fFORMULA : ct_FORMULA -> unit;; +val fID : ct_ID -> unit;; +val fSTRING : ct_STRING -> unit;; +val fINT : ct_INT -> unit;; +val fRULE_LIST : ct_RULE_LIST -> unit;; +val fRULE : ct_RULE -> unit;; +val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;; +val fPREMISES_LIST : ct_PREMISES_LIST -> unit;; +val fID_LIST : ct_ID_LIST -> unit;; +val fTEXT : ct_TEXT -> unit;;
\ No newline at end of file diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml new file mode 100644 index 00000000..ed51b9cb --- /dev/null +++ b/contrib/interface/xlate.ml @@ -0,0 +1,2118 @@ +(** Translation from coq abstract syntax trees to centaur vernac + *) +open String;; +open Char;; +open Util;; +open Ast;; +open Names;; +open Ascent;; +open Genarg;; +open Rawterm;; +open Tacexpr;; +open Vernacexpr;; +open Decl_kinds;; +open Topconstr;; +open Libnames;; +open Goptions;; + + +let in_coq_ref = ref false;; + +let declare_in_coq () = in_coq_ref:=true;; + +let in_coq () = !in_coq_ref;; + +(* // Verify whether this is dead code, as of coq version 7 *) +(* The following three sentences have been added to cope with a change +of strategy from the Coq team in the way rules construct ast's. The +problem is that now grammar rules will refer to identifiers by giving +their absolute name, using the mutconstruct when needed. Unfortunately, +when you have a mutconstruct structure, you don't have a way to guess +the corresponding identifier without an environment, and the parser +does not have an environment. We add one, only for the constructs +that are always loaded. *) +let type_table = ((Hashtbl.create 17) : + (string, ((string array) array)) Hashtbl.t);; + +Hashtbl.add type_table "Coq.Init.Logic.and" + [|[|"dummy";"conj"|]|];; + +Hashtbl.add type_table "Coq.Init.Datatypes.prod" + [|[|"dummy";"pair"|]|];; + +Hashtbl.add type_table "Coq.Init.Datatypes.nat" + [|[|"";"O"; "S"|]|];; + +Hashtbl.add type_table "Coq.ZArith.fast_integer.Z" +[|[|"";"ZERO";"POS";"NEG"|]|];; + + +Hashtbl.add type_table "Coq.ZArith.fast_integer.positive" +[|[|"";"xI";"xO";"xH"|]|];; + +(*The following two codes are added to cope with the distinction + between ocaml and caml-light syntax while using ctcaml to + manipulate the program *) +let code_plus = code (get "+" 0);; + +let code_minus = code (get "-" 0);; + +let coercion_description_holder = ref (function _ -> None : t -> int option);; + +let coercion_description t = !coercion_description_holder t;; + +let set_coercion_description f = + coercion_description_holder:=f; ();; + +let string_of_node_loc the_node = + match Util.unloc (loc the_node) with + (a,b) -> "(" ^ (string_of_int a) ^ ", " ^ (string_of_int b) ^ ")";; + +let xlate_error s = failwith ("Translation error: " ^ s);; + +let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;; + +let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;; + +let ctf_STRING_OPT = function + | None -> ctf_STRING_OPT_NONE + | Some s -> ctf_STRING_OPT_SOME (CT_string s) + +let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;; + +let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;; + +let ctv_ID_OPT_OR_ALL_NONE = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);; + +let ctv_FORMULA_OPT_NONE = + CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);; + +let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; + +let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT + ctv_FORMULA_OPT_NONE;; + +let ctf_ID_OPT_OR_ALL_SOME s = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);; + +let ctv_ID_OPT_OR_ALL_ALL = CT_all;; + +let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;; + +let ct_coerce_FORMULA_to_DEF_BODY x = + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY + (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);; + +let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;; + +let varc x = CT_coerce_ID_to_FORMULA x;; + +let xlate_ident id = CT_ident (string_of_id id) + +let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);; + +let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);; + +let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;; + +let nums_to_int_list l = CT_int_list(nums_to_int_list_aux l);; + +let nums_to_int_ne_list n l = + CT_int_ne_list(CT_int n, nums_to_int_list_aux l);; + +type iTARG = Targ_command of ct_FORMULA + | Targ_intropatt of ct_INTRO_PATT_LIST + | Targ_id_list of ct_ID_LIST + | Targ_spec_list of ct_SPEC_LIST + | Targ_binding_com of ct_FORMULA + | Targ_ident of ct_ID + | Targ_int of ct_INT + | Targ_binding of ct_BINDING + | Targ_pattern of ct_PATTERN + | Targ_unfold of ct_UNFOLD + | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST + | Targ_string of ct_STRING + | Targ_fixtac of ct_FIXTAC + | Targ_cofixtac of ct_COFIXTAC + | Targ_tacexp of ct_TACTIC_COM + | Targ_redexp of ct_RED_COM;; + +type iVARG = Varg_binder of ct_BINDER + | Varg_binderlist of ct_BINDER_LIST + | Varg_bindernelist of ct_BINDER_NE_LIST + | Varg_call of ct_ID * iVARG list + | Varg_constr of ct_FORMULA + | Varg_sorttype of ct_SORT_TYPE + | Varg_constrlist of ct_FORMULA list + | Varg_ident of ct_ID + | Varg_int of ct_INT + | Varg_intlist of ct_INT_LIST + | Varg_none + | Varg_string of ct_STRING + | Varg_tactic of ct_TACTIC_COM + | Varg_ast of ct_AST + | Varg_astlist of ct_AST_LIST + | Varg_tactic_arg of iTARG + | Varg_varglist of iVARG list;; + + +let coerce_iVARG_to_FORMULA = + function + | Varg_constr x -> x + | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x + | Varg_ident id -> CT_coerce_ID_to_FORMULA id + | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";; + +let coerce_iVARG_to_ID = + function Varg_ident id -> id + | _ -> xlate_error "coerce_iVARG_to_ID";; + +let coerce_VARG_to_ID = + function + | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) -> + x + | _ -> xlate_error "coerce_VARG_to_ID";; + +let xlate_ident_opt = + function + | None -> ctv_ID_OPT_NONE + | Some id -> ctf_ID_OPT_SOME (xlate_ident id) + +let xlate_id_to_id_or_int_opt s = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT + (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));; + +let xlate_int_to_id_or_int_opt n = + CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_ID_OR_INT (CT_int n));; + +let none_in_id_or_int_opt = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT + (CT_coerce_NONE_to_ID_OPT(CT_none));; + +let xlate_int_opt = function + | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n) + | None -> CT_coerce_NONE_to_INT_OPT CT_none + +let tac_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) + +let loc_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) + +let int_of_meta n = int_of_string (string_of_id n) +let is_int_meta n = try let _ = int_of_meta n in true with _ -> false + +let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l) + +let reference_to_ct_ID = function + | Ident (_,id) -> CT_ident (Names.string_of_id id) + | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) + +let xlate_class = function + | FunClass -> CT_ident "FUNCLASS" + | SortClass -> CT_ident "SORTCLASS" + | RefClass qid -> loc_qualid_to_ct_ID qid + +let id_to_pattern_var ctid = + match ctid with + | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" + | CT_ident "_" -> + CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) + | CT_ident id_string -> + CT_coerce_ID_OPT_to_MATCH_PATTERN + (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) + | CT_metac _ -> assert false;; + +exception Not_natural;; + +let xlate_sort = + function + | RProp Term.Pos -> CT_sortc "Set" + | RProp Term.Null -> CT_sortc "Prop" + | RType None -> CT_sortc "Type" + | RType (Some u) -> xlate_error "xlate_sort";; + + +let xlate_qualid a = + let d,i = Libnames.repr_qualid a in + let l = Names.repr_dirpath d in + List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; + +(* // The next two functions should be modified to make direct reference + to a notation operator *) +let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; + +let xlate_reference = function + Ident(_,i) -> CT_ident (string_of_id i) + | Qualid(_, q) -> CT_ident (xlate_qualid q);; +let rec xlate_match_pattern = + function + | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference s) + | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_") + | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f) + | CPatCstr (_, f1 , (arg1 :: args)) -> + CT_pattern_app + (id_to_pattern_var (xlate_reference f1), + CT_match_pattern_ne_list + (xlate_match_pattern arg1, + List.map xlate_match_pattern args)) + | CPatAlias (_, pattern, id) -> + CT_pattern_as + (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) + | CPatDelimiters(_, key, p) -> + CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) + | CPatNumeral(_,n) -> + CT_coerce_NUM_to_MATCH_PATTERN + (CT_int_encapsulator(Bignat.bigint_to_string n)) + | CPatNotation(_, s, l) -> + CT_pattern_notation(CT_string s, + CT_match_pattern_list(List.map xlate_match_pattern l)) +;; + + +let xlate_id_opt_aux = function + Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id)) + | Anonymous -> ctv_ID_OPT_NONE;; + +let xlate_id_opt (_, v) = xlate_id_opt_aux v;; + +let xlate_id_opt_ne_list = function + [] -> assert false + | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);; + + +let rec last = function + [] -> assert false + | [a] -> a + | a::tl -> last tl;; + +let rec decompose_last = function + [] -> assert false + | [a] -> [], a + | a::tl -> let rl, b = decompose_last tl in (a::rl), b;; + +let make_fix_struct (n,bl) = + let names = names_of_local_assums bl in + let nn = List.length names in + if nn = 1 then ctv_ID_OPT_NONE + else if n < nn then xlate_id_opt(List.nth names n) + else xlate_error "unexpected result of parsing for Fixpoint";; + + +let rec xlate_binder = function + (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) +and xlate_return_info = function +| (Some Anonymous, None) | (None, None) -> + CT_coerce_NONE_to_RETURN_INFO CT_none +| (None, Some t) -> CT_return(xlate_formula t) +| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t) +| (Some _, None) -> assert false +and xlate_formula_opt = + function + | None -> ctv_FORMULA_OPT_NONE + | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e) + +and xlate_binder_l = function + LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) + | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, + xlate_formula v)) +and + xlate_match_pattern_ne_list = function + [] -> assert false + | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, + List.map xlate_match_pattern l) +and translate_one_equation = function + (_,lp, a) -> CT_eqn ( xlate_match_pattern_ne_list lp, + xlate_formula a) +and + xlate_binder_ne_list = function + [] -> assert false + | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) +and + xlate_binder_list = function + l -> CT_binder_list( List.map xlate_binder_l l) +and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function + + CRef r -> varc (xlate_reference r) + | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) + | CProdN(_,ll,b) as whole_term -> + let rec gather_binders = function + CProdN(_, ll, b) -> + ll@(gather_binders b) + | _ -> [] in + let rec fetch_ultimate_body = function + CProdN(_, _, b) -> fetch_ultimate_body b + | a -> a in + CT_prodc(xlate_binder_ne_list (gather_binders whole_term), + xlate_formula (fetch_ultimate_body b)) + | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) + | CLetIn(_, v, a, b) -> + CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) + | CAppExpl(_, (Some n, r), l) -> + let l', last = decompose_last l in + CT_proj(xlate_formula last, + CT_formula_ne_list + (CT_bang(varc (xlate_reference r)), + List.map xlate_formula l')) + | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) + | CAppExpl(_, (None, r), l) -> + CT_appc(CT_bang(varc (xlate_reference r)), + xlate_formula_ne_list l) + | CApp(_, (Some n,f), l) -> + let l', last = decompose_last l in + CT_proj(xlate_formula_expl last, + CT_formula_ne_list + (xlate_formula f, List.map xlate_formula_expl l')) + | CApp(_, (_,f), l) -> + CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) + | CCases (_, _, [], _) -> assert false + | CCases (_, (Some _, _), _, _) -> xlate_error "NOT parsed: Cases with Some" + | CCases (_,(None, ret_type), tm::tml, eqns)-> + CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, + List.map xlate_matched_formula tml), + xlate_formula_opt ret_type, + CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns)) + | COrderedCase (_,Term.IfStyle,po,c,[b1;b2]) -> + xlate_error "No more COrderedCase" + | CLetTuple (_,a::l, ret_info, c, b) -> + CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a, + List.map xlate_id_opt_aux l), + xlate_return_info ret_info, + xlate_formula c, + xlate_formula b) + | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" + | CIf (_,c, ret_info, b1, b2) -> + CT_if + (xlate_formula c, xlate_return_info ret_info, + xlate_formula b1, xlate_formula b2) + + | COrderedCase (_,Term.LetStyle, po, c, [CLambdaN(_,[l,_],b)]) -> + CT_inductive_let(xlate_formula_opt po, + xlate_id_opt_ne_list l, + xlate_formula c, xlate_formula b) + | COrderedCase (_,c,v,e,l) -> + let case_string = match c with + Term.MatchStyle -> "Match" + | _ -> "Case" in + CT_elimc(CT_case "Case", xlate_formula_opt v, xlate_formula e, + CT_formula_list(List.map xlate_formula l)) + | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) + | CNotation(_, s, l) -> notation_to_formula s (List.map xlate_formula l) + | CNumeral(_, i) -> + CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bignat.bigint_to_string i)) + | CHole _ -> CT_existvarc +(* I assume CDynamic has been inserted to make free form extension of + the language possible, but this would go agains the logic of pcoq anyway. *) + | CDynamic (_, _) -> assert false + | CDelimiters (_, key, num) -> + CT_num_encapsulator(CT_num_type key , xlate_formula num) + | CCast (_, e, t) -> + CT_coerce_TYPED_FORMULA_to_FORMULA + (CT_typed_formula(xlate_formula e, xlate_formula t)) + | CPatVar (_, (_,i)) when is_int_meta i -> + CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i))) + | CPatVar (_, (false, s)) -> + CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s)) + | CPatVar (_, (true, s)) -> + xlate_error "Second order variable not supported" + | CEvar (_, _) -> xlate_error "CEvar not supported" + | CCoFix (_, (_, id), lm::lmi) -> + let strip_mutcorec (fid, bl,arf, ardef) = + CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, + xlate_formula arf, xlate_formula ardef) in + CT_cofixc(xlate_ident id, + (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) + | CFix (_, (_, id), lm::lmi) -> + let strip_mutrec (fid, n, bl, arf, ardef) = + let (struct_arg,bl,arf,ardef) = + if bl = [] then + let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in + let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in + (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) + else (make_fix_struct (n, bl),bl,arf,ardef) in + let arf = xlate_formula arf in + let ardef = xlate_formula ardef in + match xlate_binder_list bl with + | CT_binder_list (b :: bl) -> + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + struct_arg, arf, ardef) + | _ -> xlate_error "mutual recursive" in + CT_fixc (xlate_ident id, + CT_fix_binder_list + (CT_coerce_FIX_REC_to_FIX_BINDER + (strip_mutrec lm), List.map + (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) + lmi)) + | CCoFix _ -> assert false + | CFix _ -> assert false +and xlate_matched_formula = function + (f, (Some x, Some y)) -> + CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y) + | (f, (None, Some y)) -> + CT_formula_in(xlate_formula f, xlate_formula y) + | (f, (Some x, None)) -> + CT_formula_as(xlate_formula f, xlate_id_opt_aux x) + | (f, (None, None)) -> + CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) +and xlate_formula_expl = function + (a, None) -> xlate_formula a + | (a, Some (_,ExplByPos i)) -> + xlate_error "explicitation of implicit by rank not supported" + | (a, Some (_,ExplByName i)) -> + CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) +and xlate_formula_expl_ne_list = function + [] -> assert false + | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) +and xlate_formula_ne_list = function + [] -> assert false + | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; + +let (xlate_ident_or_metaid: + Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function + AI (_, x) -> xlate_ident x + | MetaId(_, x) -> CT_metaid x;; + +let xlate_hyp = function + | AI (_,id) -> xlate_ident id + | MetaId _ -> xlate_error "MetaId should occur only in quotations" + +let xlate_hyp_location = + function + | AI (_,id), nums, (InHypTypeOnly,_) -> + CT_intype(xlate_ident id, nums_to_int_list nums) + | AI (_,id), nums, (InHypValueOnly,_) -> + CT_invalue(xlate_ident id, nums_to_int_list nums) + | AI (_,id), [], (InHyp,_) -> + CT_coerce_UNFOLD_to_HYP_LOCATION + (CT_coerce_ID_to_UNFOLD (xlate_ident id)) + | AI (_,id), a::l, (InHyp,_) -> + CT_coerce_UNFOLD_to_HYP_LOCATION + (CT_unfold_occ (xlate_ident id, + CT_int_ne_list(CT_int a, nums_to_int_list_aux l))) + | MetaId _, _,_ -> + xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" + +let xlate_clause cls = + let hyps_info = + match cls.onhyps with + None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star + | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in + CT_clause + (hyps_info, + if cls.onconcl then + CT_coerce_STAR_to_STAR_OPT CT_star + else + CT_coerce_NONE_to_STAR_OPT CT_none) + +(** Tactics + *) +let strip_targ_spec_list = + function + | Targ_spec_list x -> x + | _ -> xlate_error "strip tactic: non binding-list argument";; + +let strip_targ_binding = + function + | Targ_binding x -> x + | _ -> xlate_error "strip tactic: non-binding argument";; + +let strip_targ_command = + function + | Targ_command x -> x + | Targ_binding_com x -> x + | _ -> xlate_error "strip tactic: non-command argument";; + +let strip_targ_ident = + function + | Targ_ident x -> x + | _ -> xlate_error "strip tactic: non-ident argument";; + +let strip_targ_int = + function + | Targ_int x -> x + | _ -> xlate_error "strip tactic: non-int argument";; + +let strip_targ_pattern = + function + | Targ_pattern x -> x + | _ -> xlate_error "strip tactic: non-pattern argument";; + +let strip_targ_unfold = + function + | Targ_unfold x -> x + | _ -> xlate_error "strip tactic: non-unfold argument";; + +let strip_targ_fixtac = + function + | Targ_fixtac x -> x + | _ -> xlate_error "strip tactic: non-fixtac argument";; + +let strip_targ_cofixtac = + function + | Targ_cofixtac x -> x + | _ -> xlate_error "strip tactic: non-cofixtac argument";; + +(*Need to transform formula to id for "Prolog" tactic problem *) +let make_ID_from_FORMULA = + function + | CT_coerce_ID_to_FORMULA id -> id + | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";; + +let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);; + +let xlate_quantified_hypothesis = function + | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) + | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) + +let xlate_quantified_hypothesis_opt = function + | None -> + CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE + | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n + | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; + +let xlate_id_or_int = function + ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) + | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; + +let xlate_explicit_binding (loc,h,c) = + CT_binding (xlate_quantified_hypothesis h, xlate_formula c) + +let xlate_bindings = function + | ImplicitBindings l -> + CT_coerce_FORMULA_LIST_to_SPEC_LIST + (CT_formula_list (List.map xlate_formula l)) + | ExplicitBindings l -> + CT_coerce_BINDING_LIST_to_SPEC_LIST + (CT_binding_list (List.map xlate_explicit_binding l)) + | NoBindings -> + CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list []) + +let strip_targ_spec_list = + function + | Targ_spec_list x -> x + | _ -> xlate_error "strip_tar_spec_list";; + +let strip_targ_intropatt = + function + | Targ_intropatt x -> x + | _ -> xlate_error "strip_targ_intropatt";; + +let get_flag r = + let conv_flags, red_ids = + if r.rDelta then + [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst) + else + (if r.rConst = [] + then (* probably useless: just for compatibility *) [] + else [CT_delta]), + CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in + let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in + let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in + let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in + (* Rem: EVAR flag obsolète *) + conv_flags, red_ids + +let rec xlate_intro_pattern = + function + | IntroOrAndPattern [] -> assert false + | IntroOrAndPattern (fp::ll) -> + CT_disj_pattern + (CT_intro_patt_list(List.map xlate_intro_pattern fp), + List.map + (fun l -> + CT_intro_patt_list(List.map xlate_intro_pattern l)) + ll) + | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) + | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) + +let compute_INV_TYPE = function + FullInversionClear -> CT_inv_clear + | SimpleInversion -> CT_inv_simple + | FullInversion -> CT_inv_regular + +let is_tactic_special_case = function + "AutoRewrite" -> true + | _ -> false;; + +let xlate_context_pattern = function + | Term v -> + CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) + | Subterm (idopt, v) -> + CT_context(xlate_ident_opt idopt, xlate_formula v) + + +let xlate_match_context_hyps = function + | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b);; + +let xlate_arg_to_id_opt = function + Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) + | None -> ctv_ID_OPT_NONE;; + +let xlate_largs_to_id_opt largs = + match List.map xlate_arg_to_id_opt largs with + fst::rest -> fst, rest + | _ -> assert false;; + +let xlate_int_or_constr = function + ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) + | ElimOnIdent(_,i) -> + CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) + | ElimOnAnonHyp i -> + CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT(CT_int i));; + +let xlate_using = function + None -> CT_coerce_NONE_to_USING(CT_none) + | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; + +let xlate_one_unfold_block = function + ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid) + | (n::nums, qid) -> + CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);; + +let xlate_intro_patt_opt = function + None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE + | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) + +let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = + function + | TacVoid -> + CT_void + | Tacexp t -> + CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) + | Integer n -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n))) + | Reference r -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r))) + | TacDynamic _ -> + failwith "Dynamics not treated in xlate_ast" + | ConstrMayEval (ConstrTerm c) -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c)) + | ConstrMayEval(ConstrEval(r,c)) -> + CT_coerce_EVAL_CMD_to_TACTIC_ARG + (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, + xlate_formula c)) + | ConstrMayEval(ConstrTypeOf(c)) -> + CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) + | MetaIdArg _ -> + xlate_error "MetaIdArg should only be used in quotations" + | t -> + CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t) + +and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = + function + (* Moved from xlate_tactic *) + | TacCall (_, r, a::l) -> + CT_simple_user_tac + (reference_to_ct_ID r, + CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l)) + | Reference (Ident (_,s)) -> ident_tac s + | ConstrMayEval(ConstrTerm a) -> + CT_formula_marker(xlate_formula a) + | TacFreshId s -> CT_fresh(ctf_STRING_OPT s) + | t -> xlate_error "TODO LATER: result other than tactic or constr" + +and xlate_red_tactic = + function + | Red true -> xlate_error "" + | Red false -> CT_red + | Hnf -> CT_hnf + | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE + | Simpl (Some (l,c)) -> + CT_simpl + (CT_coerce_PATTERN_to_PATTERN_OPT + (CT_pattern_occ + (CT_int_list(List.map (fun n -> CT_int n) l), xlate_formula c))) + | Cbv flag_list -> + let conv_flags, red_ids = get_flag flag_list in + CT_cbv (CT_conversion_flag_list conv_flags, red_ids) + | Lazy flag_list -> + let conv_flags, red_ids = get_flag flag_list in + CT_lazy (CT_conversion_flag_list conv_flags, red_ids) + | Unfold unf_list -> + let ct_unf_list = List.map xlate_one_unfold_block unf_list in + (match ct_unf_list with + | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) + | [] -> error "there should be at least one thing to unfold") + | Fold formula_list -> + CT_fold(CT_formula_list(List.map xlate_formula formula_list)) + | Pattern l -> + let pat_list = List.map (fun (nums,c) -> + CT_pattern_occ + (CT_int_list (List.map (fun x -> CT_int x) nums), + xlate_formula c)) l in + (match pat_list with + | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) + | [] -> error "Expecting at least one pattern in a Pattern command") + | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" + +and xlate_local_rec_tac = function + (* TODO LATER: local recursive tactics and global ones should be handled in + the same manner *) + | ((_,x),(argl,tac)) -> + let fst, rest = xlate_largs_to_id_opt argl in + CT_rec_tactic_fun(xlate_ident x, + CT_id_opt_ne_list(fst, rest), + xlate_tactic tac) + +and xlate_tactic = + function + | TacFun (largs, t) -> + let fst, rest = xlate_largs_to_id_opt largs in + CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) + | TacThen (t1,t2) -> + (match xlate_tactic t1 with + CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) + | t -> CT_then (t,[xlate_tactic t2])) + | TacThens(t1,[]) -> assert false + | TacThens(t1,t::l) -> + let ct = xlate_tactic t in + let cl = List.map xlate_tactic l in + (match xlate_tactic t1 with + CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)]) + | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)])) + | TacFirst([]) -> assert false + | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l) + | TacSolve([]) -> assert false + | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l) + | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) + | TacTry t -> CT_try (xlate_tactic t) + | TacRepeat t -> CT_repeat(xlate_tactic t) + | TacAbstract(t,id_opt) -> + CT_abstract((match id_opt with + None -> ctv_ID_OPT_NONE + | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), + xlate_tactic t) + | TacProgress t -> CT_progress(xlate_tactic t) + | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2) + | TacMatch (exp, rules) -> + CT_match_tac(xlate_tactic exp, + match List.map + (function + | Pat ([],p,tac) -> + CT_match_tac_rule(xlate_context_pattern p, + mk_let_value tac) + | Pat (_,p,tac) -> xlate_error"No hyps in pure Match" + | All tac -> + CT_match_tac_rule + (CT_coerce_FORMULA_to_CONTEXT_PATTERN + CT_existvarc, + mk_let_value tac)) rules with + | [] -> assert false + | fst::others -> + CT_match_tac_rules(fst, others)) + | TacMatchContext (_,[]) -> failwith "" + | TacMatchContext (false,rule1::rules) -> + CT_match_context(xlate_context_rule rule1, + List.map xlate_context_rule rules) + | TacMatchContext (true,rule1::rules) -> + CT_match_context_reverse(xlate_context_rule rule1, + List.map xlate_context_rule rules) + | TacLetIn (l, t) -> + let cvt_clause = + function + ((_,s),None,ConstrMayEval v) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_DEF_BODY_to_LET_VALUE + (formula_to_def_body v)) + | ((_,s),None,Tacexp t) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_tactic t)) + | ((_,s),None,t) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_call_or_tacarg t)) + | ((_,s),Some c,t) -> + CT_let_clause(xlate_ident s, + CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c), + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_call_or_tacarg t)) in + let cl_l = List.map cvt_clause l in + (match cl_l with + | [] -> assert false + | fst::others -> + CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) + | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition" + | TacLetRecIn(f1::l, t) -> + let tl = CT_rec_tactic_fun_list + (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in + CT_rec_tactic_in(tl, xlate_tactic t) + | TacAtom (_, t) -> xlate_tac t + | TacFail (count, "") -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) + | TacFail (count, s) -> CT_fail(xlate_id_or_int count, + ctf_STRING_OPT_SOME (CT_string s)) + | TacId "" -> CT_idtac ctf_STRING_OPT_NONE + | TacId s -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s)) + | TacInfo t -> CT_info(xlate_tactic t) + | TacArg a -> xlate_call_or_tacarg a + +and xlate_tac = + function + | TacExtend (_, "firstorder", tac_opt::l) -> + let t1 = match out_gen (wit_opt rawwit_tactic) tac_opt with + | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none + | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in + (match l with + [] -> CT_firstorder t1 + | [l1] -> + (match genarg_tag l1 with + List1ArgType PreIdentArgType -> + let l2 = List.map + (fun x -> CT_ident x) + (out_gen (wit_list1 rawwit_pre_ident) l1) in + let fst,l3 = + match l2 with fst::l3 -> fst,l3 | [] -> assert false in + CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) + | List1ArgType RefArgType -> + let l2 = List.map reference_to_ct_ID + (out_gen (wit_list1 rawwit_ref) l1) in + let fst,l3 = + match l2 with fst::l3 -> fst, l3 | [] -> assert false in + CT_firstorder_with(t1, CT_id_ne_list(fst, l3)) + | _ -> assert false) + | _ -> assert false) + | TacExtend (_, "refine", [c]) -> + CT_refine (xlate_formula (out_gen rawwit_casted_open_constr c)) + | TacExtend (_,"absurd",[c]) -> + CT_absurd (xlate_formula (out_gen rawwit_constr c)) + | TacExtend (_,"contradiction",[opt_c]) -> + (match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with + None -> CT_contradiction + | Some(c, b) -> + let c1 = xlate_formula c in + let bindings = xlate_bindings b in + CT_contradiction_thm(c1, bindings)) + | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) + | TacChange (Some(l,c), f, b) -> + (* TODO LATER: combine with other constructions of pattern_occ *) + CT_change_local( + CT_pattern_occ(CT_int_list(List.map (fun n -> CT_int n) l), + xlate_formula c), + xlate_formula f, + xlate_clause b) + | TacExtend (_,"contradiction",[]) -> CT_contradiction + | TacDoubleInduction (n1, n2) -> + CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2) + | TacExtend (_,"discriminate", [idopt]) -> + CT_discriminate_eq + (xlate_quantified_hypothesis_opt + (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | TacExtend (_,"deq", [idopt]) -> + let idopt1 = out_gen (wit_opt rawwit_quant_hyp) idopt in + let idopt2 = match idopt1 with + None -> CT_coerce_ID_OPT_to_ID_OR_INT_OPT + (CT_coerce_NONE_to_ID_OPT CT_none) + | Some v -> + CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT + (xlate_quantified_hypothesis v) in + CT_simplify_eq idopt2 + | TacExtend (_,"injection", [idopt]) -> + CT_injection_eq + (xlate_quantified_hypothesis_opt + (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | TacFix (idopt, n) -> + CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) + | TacMutualFix (id, n, fixtac_list) -> + let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in + CT_fixtactic + (ctf_ID_OPT_SOME (xlate_ident id), CT_int n, + CT_fix_tac_list (List.map f fixtac_list)) + | TacCofix idopt -> + CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list []) + | TacMutualCofix (id, cofixtac_list) -> + let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in + CT_cofixtactic + (CT_coerce_ID_to_ID_OPT (xlate_ident id), + CT_cofix_tac_list (List.map f cofixtac_list)) + | TacIntrosUntil (NamedHyp id) -> + CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) + | TacIntrosUntil (AnonHyp n) -> + CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) + | TacIntroMove (Some id1, Some (_,id2)) -> + CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_ident id2) + | TacIntroMove (None, Some (_,id2)) -> + CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_ident id2) + | TacMove (true, id1, id2) -> + CT_move_after(xlate_hyp id1, xlate_hyp id2) + | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal" + | TacIntroPattern patt_list -> + CT_intros + (CT_intro_patt_list (List.map xlate_intro_pattern patt_list)) + | TacIntroMove (Some id, None) -> + CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) + | TacIntroMove (None, None) -> CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) + | TacLeft bindl -> CT_left (xlate_bindings bindl) + | TacRight bindl -> CT_right (xlate_bindings bindl) + | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl) + | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl) + | TacExtend (_,"replace", [c1; c2]) -> + let c1 = xlate_formula (out_gen rawwit_constr c1) in + let c2 = xlate_formula (out_gen rawwit_constr c2) in + CT_replace_with (c1, c2) + | TacExtend (_,"rewrite", [b; cbindl]) -> + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + if b then CT_rewrite_lr (c, bindl, ctv_ID_OPT_NONE) + else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE) + | TacExtend (_,"rewritein", [b; cbindl; id]) -> + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in + if b then CT_rewrite_lr (c, bindl, id) + else CT_rewrite_rl (c, bindl, id) + | TacExtend (_,"conditionalrewrite", [t; b; cbindl]) -> + let t = out_gen rawwit_tactic t in + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) + else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) + | TacExtend (_,"conditionalrewritein", [t; b; cbindl; id]) -> + let t = out_gen rawwit_tactic t in + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in + if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id) + else CT_condrewrite_rl (xlate_tactic t, c, bindl, id) + | TacExtend (_,"dependentrewrite", [b; id_or_constr]) -> + let b = out_gen Extraargs.rawwit_orient b in + (match genarg_tag id_or_constr with + | IdentArgType -> (*Dependent Rewrite/SubstHypInConcl*) + let id = xlate_ident (out_gen rawwit_ident id_or_constr) in + if b then CT_deprewrite_lr id else CT_deprewrite_rl id + | ConstrArgType -> (*CutRewrite/SubstConcl*) + let c = xlate_formula (out_gen rawwit_constr id_or_constr) in + if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) + else CT_cutrewrite_rl (c, ctv_ID_OPT_NONE) + | _ -> xlate_error "") + | TacExtend (_,"dependentrewrite", [b; c; id]) -> (*CutRewrite in/SubstHyp*) + let b = out_gen Extraargs.rawwit_orient b in + let c = xlate_formula (out_gen rawwit_constr c) in + let id = xlate_ident (out_gen rawwit_ident id) in + if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) + else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) + | TacExtend(_, "subst", [l]) -> + CT_subst + (CT_id_list + (List.map (fun x -> CT_ident (string_of_id x)) + (out_gen (wit_list1 rawwit_ident) l))) + | TacReflexivity -> CT_reflexivity + | TacSymmetry cls -> CT_symmetry(xlate_clause cls) + | TacTransitivity c -> CT_transitivity (xlate_formula c) + | TacAssumption -> CT_assumption + | TacExact c -> CT_exact (xlate_formula c) + | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) + | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) + | TacDestructConcl -> CT_dconcl + | TacSuperAuto (nopt,l,a3,a4) -> + CT_superauto( + xlate_int_opt nopt, + xlate_qualid_list l, + (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none), + (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none)) + | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt) + | TacAuto (nopt, Some []) -> CT_auto (xlate_int_opt nopt) + | TacAuto (nopt, None) -> + CT_auto_with (xlate_int_opt nopt, + CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | TacAuto (nopt, Some (id1::idl)) -> + CT_auto_with(xlate_int_opt nopt, + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( + CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl))) + |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) -> + let (id_list:ct_ID list) = + List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in + let fst, (id_list1: ct_ID list) = + match id_list with [] -> assert false | a::tl -> a,tl in + let t1 = + match t with + [t0] -> + CT_coerce_TACTIC_COM_to_TACTIC_OPT + (xlate_tactic(out_gen rawwit_tactic t0)) + | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none + | _ -> assert false in + CT_autorewrite (CT_id_ne_list(fst, id_list1), t1) + | TacExtend (_,"eauto", [nopt; popt; idl]) -> + let first_n = + match out_gen (wit_opt rawwit_int_or_var) nopt with + | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s + | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | None -> none_in_id_or_int_opt in + let second_n = + match out_gen (wit_opt rawwit_int_or_var) popt with + | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s + | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | None -> none_in_id_or_int_opt in + let idl = out_gen Eauto.rawwit_hintbases idl in + (match idl with + None -> CT_eauto_with(first_n, + second_n, + CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | Some [] -> CT_eauto(first_n, second_n) + | Some (a::l) -> + CT_eauto_with(first_n, second_n, + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR + (CT_id_ne_list + (CT_ident a, + List.map (fun x -> CT_ident x) l)))) + | TacExtend (_,"prolog", [cl; n]) -> + let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in + (match out_gen wit_int_or_var n with + | ArgVar _ -> xlate_error "" + | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) + | TacExtend (_,"eapply", [cbindl]) -> + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + CT_eapply (c, bindl) + | TacTrivial (Some []) -> CT_trivial + | TacTrivial None -> + CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | TacTrivial (Some (id1::idl)) -> + CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( + (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl)))) + | TacReduce (red, l) -> + CT_reduce (xlate_red_tactic red, xlate_clause l) + | TacApply (c,bindl) -> + CT_apply (xlate_formula c, xlate_bindings bindl) + | TacConstructor (n_or_meta, bindl) -> + let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" + in CT_constructor (CT_int n, xlate_bindings bindl) + | TacSpecialize (nopt, (c,sl)) -> + CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl) + | TacGeneralize [] -> xlate_error "" + | TacGeneralize (first :: cl) -> + CT_generalize + (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl)) + | TacGeneralizeDep c -> + CT_generalize_dependent (xlate_formula c) + | TacElimType c -> CT_elim_type (xlate_formula c) + | TacCaseType c -> CT_case_type (xlate_formula c) + | TacElim ((c1,sl), u) -> + CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u) + | TacCase (c1,sl) -> + CT_casetac (xlate_formula c1, xlate_bindings sl) + | TacSimpleInduction (h,_) -> CT_induction (xlate_quantified_hypothesis h) + | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h) + | TacCut c -> CT_cut (xlate_formula c) + | TacLApply c -> CT_use (xlate_formula c) + | TacDecompose ([],c) -> + xlate_error "Decompose : empty list of identifiers?" + | TacDecompose (id::l,c) -> + let id' = tac_qualid_to_ct_ID id in + let l' = List.map tac_qualid_to_ct_ID l in + CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c) + | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c) + | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c) + | TacClear [] -> + xlate_error "Clear expects a non empty list of identifiers" + | TacClear (id::idl) -> + let idl' = List.map xlate_hyp idl in + CT_clear (CT_id_ne_list (xlate_hyp id, idl')) + | (*For translating tactics/Inv.v *) + TacInversion (NonDepInversion (k,idl,l),quant_hyp) -> + CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp, + xlate_intro_patt_opt l, + CT_id_list (List.map xlate_hyp idl)) + | TacInversion (DepInversion (k,copt,l),quant_hyp) -> + let id = xlate_quantified_hypothesis quant_hyp in + CT_depinversion (compute_INV_TYPE k, id, + xlate_intro_patt_opt l, xlate_formula_opt copt) + | TacInversion (InversionUsing (c,idlist), id) -> + let id = xlate_quantified_hypothesis id in + CT_use_inversion (id, xlate_formula c, + CT_id_list (List.map xlate_hyp idlist)) + | TacExtend (_,"omega", []) -> CT_omega + | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2) + | TacClearBody([]) -> assert false + | TacClearBody(a::l) -> + CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) + | TacDAuto (a, b) -> CT_dauto(xlate_int_opt a, xlate_int_opt b) + | TacNewDestruct(a,b,(c,_)) -> + CT_new_destruct + (xlate_int_or_constr a, xlate_using b, + xlate_intro_patt_opt c) + | TacNewInduction(a,b,(c,_)) -> + CT_new_induction + (xlate_int_or_constr a, xlate_using b, + xlate_intro_patt_opt c) + | TacInstantiate (a, b, cl) -> + CT_instantiate(CT_int a, xlate_formula b, + xlate_clause cl) + | TacLetTac (na, c, cl) -> + CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, + (* TODO LATER: This should be shared with Unfold, + but the structures are different *) + xlate_clause cl) + | TacForward (true, name, c) -> + CT_pose(xlate_id_opt_aux name, xlate_formula c) + | TacForward (false, name, c) -> + CT_assert(xlate_id_opt ((0,0),name), xlate_formula c) + | TacTrueCut (na, c) -> + CT_truecut(xlate_id_opt ((0,0),na), xlate_formula c) + | TacAnyConstructor(Some tac) -> + CT_any_constructor + (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) + | TacAnyConstructor(None) -> + CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) + | TacExtend(_, "ring", [args]) -> + CT_ring + (CT_formula_list + (List.map xlate_formula + (out_gen (wit_list0 rawwit_constr) args))) + | TacExtend (_,id, l) -> + CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) + | TacAlias _ -> xlate_error "Alias not supported" + +and coerce_genarg_to_TARG x = + match Genarg.genarg_tag x with + (* Basic types *) + | BoolArgType -> xlate_error "TODO: generic boolean argument" + | IntArgType -> + let n = out_gen rawwit_int x in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n))) + | IntOrVarArgType -> + let x = match out_gen rawwit_int_or_var x with + | ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) + | ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x) + | StringArgType -> + let s = CT_string (out_gen rawwit_string x) in + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT + (CT_coerce_STRING_to_ID_OR_STRING s)) + | PreIdentArgType -> + let id = CT_ident (out_gen rawwit_pre_ident x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + | IntroPatternArgType -> + xlate_error "TODO" + | IdentArgType -> + let id = xlate_ident (out_gen rawwit_ident x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + | HypArgType -> + xlate_error "TODO (similar to IdentArgType)" + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + (* Specific types *) + | SortArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) + | ConstrArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) + | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" + | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" + | TacticArgType -> + let t = xlate_tactic (out_gen rawwit_tactic x) in + CT_coerce_TACTIC_COM_to_TARG t + | CastedOpenConstrArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula + (out_gen + rawwit_casted_open_constr x))) + | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" + | BindingsArgType -> xlate_error "TODO: generic with bindings" + | RedExprArgType -> xlate_error "TODO: generic red expr" + | List0ArgType l -> xlate_error "TODO: lists of generic arguments" + | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" + | OptArgType x -> xlate_error "TODO: optional generic arguments" + | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" + | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" +and xlate_context_rule = + function + | Pat (hyps, concl_pat, tactic) -> + CT_context_rule + (CT_context_hyp_list (List.map xlate_match_context_hyps hyps), + xlate_context_pattern concl_pat, xlate_tactic tactic) + | All tactic -> + CT_def_context_rule (xlate_tactic tactic) +and formula_to_def_body = + function + | ConstrEval (red, f) -> + CT_coerce_EVAL_CMD_to_DEF_BODY( + CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, + xlate_red_tactic red, xlate_formula f)) + | ConstrContext((_, id), f) -> + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY + (CT_context + (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)), + xlate_formula f)) + | ConstrTypeOf f -> CT_type_of (xlate_formula f) + | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) + +and mk_let_value = function + TacArg (ConstrMayEval v) -> + CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) + | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; + +let coerce_genarg_to_VARG x = + match Genarg.genarg_tag x with + (* Basic types *) + | BoolArgType -> xlate_error "TODO: generic boolean argument" + | IntArgType -> + let n = out_gen rawwit_int x in + CT_coerce_ID_OR_INT_OPT_to_VARG + (CT_coerce_INT_OPT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_INT_OPT (CT_int n))) + | IntOrVarArgType -> + (match out_gen rawwit_int_or_var x with + | ArgArg n -> + CT_coerce_ID_OR_INT_OPT_to_VARG + (CT_coerce_INT_OPT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_INT_OPT (CT_int n))) + | ArgVar (_,id) -> + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT (xlate_ident id)))) + | StringArgType -> + let s = CT_string (out_gen rawwit_string x) in + CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s) + | PreIdentArgType -> + let id = CT_ident (out_gen rawwit_pre_ident x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + | IntroPatternArgType -> + xlate_error "TODO" + | IdentArgType -> + let id = xlate_ident (out_gen rawwit_ident x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + | HypArgType -> + xlate_error "TODO (similar to IdentArgType)" + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + (* Specific types *) + | SortArgType -> + CT_coerce_FORMULA_OPT_to_VARG + (CT_coerce_FORMULA_to_FORMULA_OPT + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) + | ConstrArgType -> + CT_coerce_FORMULA_OPT_to_VARG + (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) + | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" + | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" + | TacticArgType -> + let t = xlate_tactic (out_gen rawwit_tactic x) in + CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) + | CastedOpenConstrArgType -> xlate_error "TODO: generic open constr" + | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" + | BindingsArgType -> xlate_error "TODO: generic with bindings" + | RedExprArgType -> xlate_error "TODO: red expr as generic argument" + | List0ArgType l -> xlate_error "TODO: lists of generic arguments" + | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" + | OptArgType x -> xlate_error "TODO: optional generic arguments" + | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" + | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" + + +let xlate_thm x = CT_thm (match x with + | Theorem -> "Theorem" + | Remark -> "Remark" + | Lemma -> "Lemma" + | Fact -> "Fact") + + +let xlate_defn x = CT_defn (match x with + | (Local, Definition) -> "Local" + | (Global, Definition) -> "Definition" + | (Global, SubClass) -> "SubClass" + | (Global, Coercion) -> "Coercion" + | (Local, SubClass) -> "Local SubClass" + | (Local, Coercion) -> "Local Coercion" + | (Global,CanonicalStructure) -> "Canonical Structure" + | (Local, CanonicalStructure) -> + xlate_error "Local CanonicalStructure not parsed") + +let xlate_var x = CT_var (match x with + | (Global,Definitional) -> "Parameter" + | (Global,Logical) -> "Axiom" + | (Local,Definitional) -> "Variable" + | (Local,Logical) -> "Hypothesis" + | (Global,Conjectural) -> "Conjecture" + | (Local,Conjectural) -> xlate_error "No local conjecture");; + + +let xlate_dep = + function + | true -> CT_dep "Induction for" + | false -> CT_dep "Minimality for";; + +let xlate_locn = + function + | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n) + | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top") + | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev") + | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next") + +let xlate_search_restr = + function + | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none + | SearchInside (m1::l1) -> + CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, + List.map loc_qualid_to_ct_ID l1)) + | SearchOutside (m1::l1) -> + CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, + List.map loc_qualid_to_ct_ID l1)) + | SearchInside [] -> xlate_error "bad extra argument for Search" + +let xlate_check = + function + | "CHECK" -> "Check" + | "PRINTTYPE" -> "Type" + | _ -> xlate_error "xlate_check";; + +let build_constructors l = + let f (coe,((_,id),c)) = + if coe then CT_constr_coercion (xlate_ident id, xlate_formula c) + else CT_constr (xlate_ident id, xlate_formula c) in + CT_constr_list (List.map f l) + +let build_record_field_list l = + let build_record_field (coe,d) = match d with + | AssumExpr (id,c) -> + if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) + else + CT_recconstr(xlate_id_opt id, xlate_formula c) + | DefExpr (id,c,topt) -> + if coe then + CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c, + xlate_formula_opt topt) + else + CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in + CT_recconstr_list (List.map build_record_field l);; + +let get_require_flags impexp spec = + let ct_impexp = + match impexp with + | None -> CT_coerce_NONE_to_IMPEXP CT_none + | Some false -> CT_import + | Some true -> CT_export in + let ct_spec = + match spec with + | None -> ctv_SPEC_OPT_NONE + | Some true -> CT_spec + | Some false -> ctv_SPEC_OPT_NONE in + ct_impexp, ct_spec;; + +let cvt_optional_eval_for_definition c1 optional_eval = + match optional_eval with + None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1) + | Some red -> + CT_coerce_EVAL_CMD_to_DEF_BODY( + CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, + xlate_red_tactic red, + xlate_formula c1)) + +let cvt_vernac_binder = function + | b,(id::idl,c) -> + let l,t = + CT_id_opt_ne_list + (xlate_ident_opt (Some (snd id)), + List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), + xlate_formula c in + if b then + CT_binder_coercion(l,t) + else + CT_binder(l,t) + | _, _ -> xlate_error "binder with no left part, rejected";; + +let cvt_vernac_binders = function + a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args) + | [] -> assert false;; + + +let xlate_comment = function + CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c) + | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT + (CT_coerce_STRING_to_ID_OR_STRING(CT_string s)) + | CommentInt n -> + CT_coerce_FORMULA_to_SCOMMENT_CONTENT + (CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));; + +let translate_opt_notation_decl = function + None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) + | Some(s, f, sc) -> + let tr_sc = + match sc with + None -> ctv_ID_OPT_NONE + | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in + CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; + +let xlate_level = function + Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n) + | Extend.NextLevel -> CT_next_level;; + +let xlate_syntax_modifier = function + Extend.SetItemLevel((s::sl), level) -> + CT_set_item_level + (CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl), + xlate_level level) + | Extend.SetItemLevel([], _) -> assert false + | Extend.SetLevel level -> CT_set_level (CT_int level) + | Extend.SetAssoc Gramext.LeftA -> CT_lefta + | Extend.SetAssoc Gramext.RightA -> CT_righta + | Extend.SetAssoc Gramext.NonA -> CT_nona + | Extend.SetEntryType(x,typ) -> + CT_entry_type(CT_ident x, + match typ with + Extend.ETIdent -> CT_ident "ident" + | Extend.ETReference -> CT_ident "global" + | Extend.ETBigint -> CT_ident "bigint" + | _ -> xlate_error "syntax_type not parsed") + | Extend.SetOnlyParsing -> CT_only_parsing + | Extend.SetFormat(_,s) -> CT_format(CT_string s);; + + +let rec xlate_module_type = function + | CMTEident(_, qid) -> + CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) + | CMTEwith(mty, decl) -> + let mty1 = xlate_module_type mty in + (match decl with + CWith_Definition((_, id), c) -> + CT_module_type_with_def(xlate_module_type mty, + xlate_ident id, xlate_formula c) + | CWith_Module((_, id), (_, qid)) -> + CT_module_type_with_mod(xlate_module_type mty, + xlate_ident id, + CT_ident (xlate_qualid qid)));; + +let xlate_module_binder_list (l:module_binder list) = + CT_module_binder_list + (List.map (fun (idl, mty) -> + let idl1 = + List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in + let fst,idl2 = match idl1 with + [] -> assert false + | fst::idl2 -> fst,idl2 in + CT_module_binder + (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);; + +let xlate_module_type_check_opt = function + None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK + (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) + | Some(mty, true) -> CT_only_check(xlate_module_type mty) + | Some(mty, false) -> + CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK + (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT + (xlate_module_type mty));; + +let rec xlate_module_expr = function + CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR + (CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid))) + | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1, + xlate_module_expr me2) + +let rec xlate_vernac = + function + | VernacDeclareTacticDefinition (true, tacs) -> + (match List.map + (function + ((_, id), body) -> + CT_tac_def(CT_ident (string_of_id id), xlate_tactic body)) + tacs with + [] -> assert false + | fst::tacs1 -> + CT_tactic_definition + (CT_tac_def_ne_list(fst, tacs1))) + | VernacDeclareTacticDefinition(false, _) -> + xlate_error "obsolete tactic definition not handled" + | VernacLoad (verbose,s) -> + CT_load ( + (match verbose with + | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none + | true -> CT_verbose), + CT_coerce_STRING_to_ID_OR_STRING (CT_string s)) + | VernacCheckMayEval (Some red, numopt, f) -> + let red = xlate_red_tactic red in + CT_coerce_EVAL_CMD_to_COMMAND + (CT_eval (xlate_int_opt numopt, red, xlate_formula f)) + |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s) + | VernacAddLoadPath (false,str,None) -> + CT_addpath (CT_string str, ctv_ID_OPT_NONE) + | VernacAddLoadPath (false,str,Some x) -> + CT_addpath (CT_string str, + CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) + | VernacAddLoadPath (true,str,None) -> + CT_recaddpath (CT_string str, ctv_ID_OPT_NONE) + | VernacAddLoadPath (_,str, Some x) -> + CT_recaddpath (CT_string str, + CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) + | VernacRemoveLoadPath str -> CT_delpath (CT_string str) + | VernacToplevelControl Quit -> CT_quit + | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported" + (*ML commands *) + | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str) + | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str) + | VernacDeclareMLModule [] -> failwith "" + | VernacDeclareMLModule (str :: l) -> + CT_ml_declare_modules + (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l)) + | VernacGoal c -> + CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c)) + | VernacAbort (Some (_,id)) -> + CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) + | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE + | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL + | VernacRestart -> CT_restart + | VernacSolve (n, tac, b) -> + CT_solve (CT_int n, xlate_tactic tac, + if b then CT_dotdot + else CT_coerce_NONE_to_DOTDOT_OPT CT_none) + | VernacFocus nopt -> CT_focus (xlate_int_opt nopt) + | VernacUnfocus -> CT_unfocus + |VernacExtend("Extraction", [f;l]) -> + let file = out_gen rawwit_string f in + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in + CT_extract_to_file(CT_string file, + CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("ExtractionInline", [l]) -> + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in + CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("ExtractionNoInline", [l]) -> + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in + CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("Field", + [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) -> + (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) + [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl] + with + [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] -> + let bind = + match out_gen Field.rawwit_minus_div_arg minusdiv with + None, None -> + CT_binding_list[] + | Some m, None -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)] + | None, Some d -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] + | Some m, Some d -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m); + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in + CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1, + ainv1, fth1, ainvl1, bind) + |_ -> assert false) + | VernacExtend (("HintRewriteV7"|"HintRewriteV8") as key, largs) -> + let in_v8 = (key = "HintRewriteV8") in + let orient = out_gen Extraargs.rawwit_orient (List.nth largs 0) in + let formula_list = out_gen (wit_list1 rawwit_constr) (List.nth largs 1) in + let t = + if List.length largs = 4 then + out_gen rawwit_tactic (List.nth largs (if in_v8 then 2 else 3)) + else + TacId "" in + let base = + out_gen rawwit_pre_ident + (if in_v8 then last largs else List.nth largs 2) in + let ct_orient = match orient with + | true -> CT_lr + | false -> CT_rl in + let f_ne_list = match List.map xlate_formula formula_list with + (fst::rest) -> CT_formula_ne_list(fst,rest) + | _ -> assert false in + CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) + | VernacHints (local,dbnames,h) -> + let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in + (match h with + | HintsConstructors (None, l) -> + let n1, names = match List.map tac_qualid_to_ct_ID l with + n1 :: names -> n1, names + | _ -> failwith "" in + if local then + CT_local_hints(CT_ident "Constructors", + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident "Constructors", + CT_id_ne_list(n1, names), dblist) + | HintsExtern (None, n, c, t) -> + CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist) + | HintsResolve l | HintsImmediate l -> + let l = + List.map + (function (None, f) -> xlate_formula f + | _ -> + xlate_error "obsolete Hint Resolve not supported") l in + let f1, formulas = match l with + a :: tl -> a, tl + | _ -> failwith "" in + let l' = CT_formula_ne_list(f1, formulas) in + if local then + (match h with + HintsResolve _ -> + CT_local_hints_resolve(l', dblist) + | HintsImmediate _ -> + CT_local_hints_immediate(l', dblist) + | _ -> assert false) + else + (match h with + HintsResolve _ -> CT_hints_resolve(l', dblist) + | HintsImmediate _ -> CT_hints_immediate(l', dblist) + | _ -> assert false) + | HintsUnfold l -> + let l = List.map + (function (None,ref) -> loc_qualid_to_ct_ID ref | + _ -> xlate_error "obsolete Hint Unfold not supported") l in + let n1, names = match l with + n1 :: names -> n1, names + | _ -> failwith "" in + if local then + CT_local_hints(CT_ident "Unfold", + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) + | HintsDestruct(id, n, loc, f, t) -> + let dl = match loc with + ConclLocation() -> CT_conclusion_location + | HypLocation true -> CT_discardable_hypothesis + | HypLocation false -> CT_hypothesis_location in + if local then + CT_local_hint_destruct + (xlate_ident id, CT_int n, + dl, xlate_formula f, xlate_tactic t, dblist) + else + CT_hint_destruct + (xlate_ident id, CT_int n, dl, xlate_formula f, + xlate_tactic t, dblist) + | HintsExtern(Some _, _, _, _) + | HintsConstructors(Some _, _) -> + xlate_error "obsolete Hint Constructors not supported" +) + | VernacEndProof (Proved (true,None)) -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE) + | VernacEndProof (Proved (false,None)) -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE) + | VernacEndProof (Proved (b,Some ((_,s), Some kind))) -> + CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind), + ctf_ID_OPT_SOME (xlate_ident s)) + | VernacEndProof (Proved (b,Some ((_,s),None))) -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), + ctf_ID_OPT_SOME (xlate_ident s)) + | VernacEndProof Admitted -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE) + | VernacSetOpacity (false, id :: idl) -> + CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl)) + | VernacSetOpacity (true, id :: idl) + -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl)) + | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur" + | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n)) + | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt) + | VernacShow ShowNode -> CT_show_node + | VernacShow ShowProof -> CT_show_proof + | VernacShow ShowTree -> CT_show_tree + | VernacShow ShowProofNames -> CT_show_proofs + | VernacShow (ShowIntros true) -> CT_show_intros + | VernacShow (ShowIntros false) -> CT_show_intro + | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1) + | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n) + | VernacShow ShowExistentials -> CT_show_existentials + | VernacShow ShowScript -> CT_show_script + | VernacGo arg -> CT_go (xlate_locn arg) + | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l) + | VernacShow ExplainTree l -> + CT_explain_prooftree (nums_to_int_list l) + | VernacCheckGuard -> CT_guarded + | VernacPrint p -> + (match p with + PrintFullContext -> CT_print_all + | PrintName id -> CT_print_id (loc_qualid_to_ct_ID id) + | PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id) + | PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id) + | PrintModules -> CT_print_modules + | PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none + | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) + | PrintHintDbName id -> + CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) + | PrintHint id -> + CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) + | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE + | PrintLoadPath -> CT_print_loadpath + | PrintMLLoadPath -> CT_ml_print_path + | PrintMLModules -> CT_ml_print_modules + | PrintGraph -> CT_print_graph + | PrintClasses -> CT_print_classes + | PrintCoercions -> CT_print_coercions + | PrintCoercionPaths (id1, id2) -> + CT_print_path (xlate_class id1, xlate_class id2) + | PrintInspect n -> CT_inspect (CT_int n) + | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) + | PrintLocalContext -> CT_print + | PrintTables -> CT_print_tables + | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) + | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) + | PrintScopes -> CT_print_scopes + | PrintScope id -> CT_print_scope (CT_ident id) + | PrintVisibility id_opt -> + CT_print_visibility + (match id_opt with + Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) + | None -> ctv_ID_OPT_NONE) + | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid) + | PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid)) + | VernacBeginSection (_,id) -> + CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id)) + | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id) + | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) -> + CT_coerce_THEOREM_GOAL_to_COMMAND( + CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, + xlate_binder_list bl, xlate_formula c)) + | VernacSuspend -> CT_suspend + | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt)) + | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> + CT_coerce_THEOREM_GOAL_to_COMMAND + (CT_theorem_goal + (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k), + xlate_ident s, xlate_binder_list bl, xlate_formula typ)) + | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) -> + CT_definition + (xlate_defn kind, xlate_ident s, xlate_binder_list bl, + cvt_optional_eval_for_definition c red_option, + xlate_formula_opt typ_opt) + | VernacAssumption (kind, b) -> + CT_variable (xlate_var kind, cvt_vernac_binders b) + | VernacCheckMayEval (None, numopt, c) -> + CT_check (xlate_formula c) + | VernacSearch (s,x) -> + let translated_restriction = xlate_search_restr x in + (match s with + | SearchPattern c -> + CT_search_pattern(xlate_formula c, translated_restriction) + | SearchHead id -> + CT_search(loc_qualid_to_ct_ID id, translated_restriction) + | SearchRewrite c -> + CT_search_rewrite(xlate_formula c, translated_restriction) + | SearchAbout (a::l) -> + let xlate_search_about_item it = + match it with + SearchRef x -> + CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) + | SearchString s -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string s) in + CT_search_about + (CT_id_or_string_ne_list(xlate_search_about_item a, + List.map xlate_search_about_item l), + translated_restriction) + | SearchAbout [] -> assert false) + + | (*Record from tactics/Record.v *) + VernacRecord + (_, (add_coercion, (_,s)), binders, c1, + rec_constructor_or_none, field_list) -> + let record_constructor = + xlate_ident_opt (option_app snd rec_constructor_or_none) in + CT_record + ((if add_coercion then CT_coercion_atm else + CT_coerce_NONE_to_COERCION_OPT(CT_none)), + xlate_ident s, xlate_binder_list binders, + xlate_formula c1, record_constructor, + build_record_field_list field_list) + | VernacInductive (isind, lmi) -> + let co_or_ind = if isind then "Inductive" else "CoInductive" in + let strip_mutind ((_,s), notopt, parameters, c, constructors) = + CT_ind_spec + (xlate_ident s, xlate_binder_list parameters, xlate_formula c, + build_constructors constructors, + translate_opt_notation_decl notopt) in + CT_mind_decl + (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) + | VernacFixpoint [] -> xlate_error "mutual recursive" + | VernacFixpoint (lm :: lmi) -> + let strip_mutrec ((fid, n, bl, arf, ardef), ntn) = + let (struct_arg,bl,arf,ardef) = + if bl = [] then + let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in + let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in + (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) + else (make_fix_struct (n, bl),bl,arf,ardef) in + let arf = xlate_formula arf in + let ardef = xlate_formula ardef in + match xlate_binder_list bl with + | CT_binder_list (b :: bl) -> + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + struct_arg, arf, ardef) + | _ -> xlate_error "mutual recursive" in + CT_fix_decl + (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) + | VernacCoFixpoint [] -> xlate_error "mutual corecursive" + | VernacCoFixpoint (lm :: lmi) -> + let strip_mutcorec (fid, bl, arf, ardef) = + CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, + xlate_formula arf, xlate_formula ardef) in + CT_cofix_decl + (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)) + | VernacScheme [] -> xlate_error "induction scheme" + | VernacScheme (lm :: lmi) -> + let strip_ind ((_,id), depstr, inde, sort) = + CT_scheme_spec + (xlate_ident id, xlate_dep depstr, + CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), + xlate_sort sort) in + CT_ind_scheme + (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi)) + | VernacSyntacticDefinition (id, c, false, _) -> + CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None) + | VernacSyntacticDefinition (id, c, true, _) -> + xlate_error "TODO: Local abbreviations" + (* Modules and Module Types *) + | VernacDeclareModuleType((_, id), bl, mty_o) -> + CT_module_type_decl(xlate_ident id, + xlate_module_binder_list bl, + match mty_o with + None -> + CT_coerce_ID_OPT_to_MODULE_TYPE_OPT + ctv_ID_OPT_NONE + | Some mty1 -> + CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT + (xlate_module_type mty1)) + | VernacDefineModule((_, id), bl, mty_o, mexpr_o) -> + CT_module(xlate_ident id, + xlate_module_binder_list bl, + xlate_module_type_check_opt mty_o, + match mexpr_o with + None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE + | Some m -> xlate_module_expr m) + | VernacDeclareModule((_, id), bl, mty_o, mexpr_o) -> + CT_declare_module(xlate_ident id, + xlate_module_binder_list bl, + xlate_module_type_check_opt mty_o, + match mexpr_o with + None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE + | Some m -> xlate_module_expr m) + | VernacRequire (impexp, spec, id::idl) -> + let ct_impexp, ct_spec = get_require_flags impexp spec in + CT_require (ct_impexp, ct_spec, + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( + CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl))) + | VernacRequire (_,_,[]) -> + xlate_error "Require should have at least one id argument" + | VernacRequireFrom (impexp, spec, filename) -> + let ct_impexp, ct_spec = get_require_flags impexp spec in + CT_require(ct_impexp, ct_spec, + CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) + + | VernacSyntax (phylum, l) -> xlate_error "SYNTAX not implemented" + + | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) + | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) + | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) + | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) + | VernacArgumentsScope(qid, l) -> + CT_arguments_scope(loc_qualid_to_ct_ID qid, + CT_id_opt_list + (List.map + (fun x -> + match x with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) + | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) + | VernacBindScope(id, a::l) -> + let xlate_class_rawexpr = function + FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" + | RefClass qid -> loc_qualid_to_ct_ID qid in + CT_bind_scope(CT_ident id, + CT_id_ne_list(xlate_class_rawexpr a, + List.map xlate_class_rawexpr l)) + | VernacBindScope(id, []) -> assert false + | VernacNotation(b, c, None, _, _) -> assert false + | VernacNotation(b, c, Some(s,modif_list), _, opt_scope) -> + let translated_s = CT_string s in + let formula = xlate_formula c in + let translated_modif_list = + CT_modifier_list(List.map xlate_syntax_modifier modif_list) in + let translated_scope = match opt_scope with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x) in + if b then + CT_local_define_notation + (translated_s, formula, translated_modif_list, translated_scope) + else + CT_define_notation(translated_s, formula, + translated_modif_list, translated_scope) + | VernacSyntaxExtension(b,Some(s,modif_list), None) -> + let translated_s = CT_string s in + let translated_modif_list = + CT_modifier_list(List.map xlate_syntax_modifier modif_list) in + if b then + CT_local_reserve_notation(translated_s, translated_modif_list) + else + CT_reserve_notation(translated_s, translated_modif_list) + | VernacSyntaxExtension(_, _, _) -> assert false + | VernacInfix (b,(str,modl),id,_, opt_scope) -> + let id1 = loc_qualid_to_ct_ID id in + let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in + let s = CT_string str in + let translated_scope = match opt_scope with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x) in + if b then + CT_local_infix(s, id1,modl1, translated_scope) + else + CT_infix(s, id1,modl1, translated_scope) + | VernacGrammar _ -> xlate_error "GRAMMAR not implemented" + | VernacCoercion (s, id1, id2, id3) -> + let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in + let local_opt = + match s with + (* Cannot decide whether it is a global or a Local but at toplevel *) + | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none + | Local -> CT_local in + CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1, + xlate_class id2, xlate_class id3) + + | VernacIdentityCoercion (s, (_,id1), id2, id3) -> + let id_opt = CT_identity in + let local_opt = + match s with + (* Cannot decide whether it is a global or a Local but at toplevel *) + | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none + | Local -> CT_local in + CT_coercion (local_opt, id_opt, xlate_ident id1, + xlate_class id2, xlate_class id3) + | VernacResetName id -> CT_reset (xlate_ident (snd id)) + | VernacResetInitial -> CT_restore_state (CT_ident "Initial") + | VernacExtend (s, l) -> + CT_user_vernac + (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) + | VernacDebug b -> xlate_error "Debug On/Off not supported" + | VernacList((_, a)::l) -> + CT_coerce_COMMAND_LIST_to_COMMAND + (CT_command_list(xlate_vernac a, + List.map (fun (_, x) -> xlate_vernac x) l)) + | VernacList([]) -> assert false + | (VernacV7only _ | VernacV8only _) -> + xlate_error "Not treated here" + | VernacNop -> CT_proof_no_op + | VernacComments l -> + CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) + | VernacDeclareImplicits(id, opt_positions) -> + CT_implicits + (reference_to_ct_ID id, + match opt_positions with + None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none + | Some l -> + CT_coerce_ID_LIST_to_ID_LIST_OPT + (CT_id_list + (List.map + (function ExplByPos x + -> xlate_error + "explication argument by rank is obsolete" + | ExplByName id -> CT_ident (string_of_id id)) l))) + | VernacReserve((_,a)::l, f) -> + CT_reserve(CT_id_ne_list(xlate_ident a, + List.map (fun (_,x) -> xlate_ident x) l), + xlate_formula f) + | VernacReserve([], _) -> assert false + | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id) + | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id) + | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s) + | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s) + | VernacTime(v) -> CT_time(xlate_vernac v) + | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) + |VernacExactProof f -> CT_proof(xlate_formula f) + | VernacSetOption (table, BoolValue true) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_set_option(table1) + | VernacSetOption (table, v) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + let value = + match v with + | BoolValue _ -> assert false + | StringValue s -> + CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s) + | IntValue n -> + CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in + CT_set_option_value(table1, value) + | VernacUnsetOption(table) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_unset_option(table1) + | VernacAddOption (table, l) -> + let values = + List.map + (function + | QualidRefValue x -> + CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) + | StringRefValue x -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in + let fst, values1 = + match values with [] -> assert false | a::b -> (a,b) in + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1)) + | VernacImport(true, a::l) -> + CT_export_id(CT_id_ne_list(reference_to_ct_ID a, + List.map reference_to_ct_ID l)) + | VernacImport(false, a::l) -> + CT_import_id(CT_id_ne_list(reference_to_ct_ID a, + List.map reference_to_ct_ID l)) + | VernacImport(_, []) -> assert false + | VernacProof t -> CT_proof_with(xlate_tactic t) + | VernacVar _ -> xlate_error "Grammar vernac obsolete" + | (VernacGlobalCheck _|VernacPrintOption _| + VernacMemOption (_, _)|VernacRemoveOption (_, _) + | VernacBack _|VernacRestoreState _| VernacWriteState _| + VernacSolveExistential (_, _)|VernacCanonical _ | VernacDistfix _| + VernacTacticGrammar _) + -> xlate_error "TODO: vernac";; + +let rec xlate_vernac_list = + function + | VernacList (v::l) -> + CT_command_list + (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l) + | VernacV7only v -> + if !Options.v7 then xlate_vernac_list v + else xlate_error "Unknown command" + | VernacList [] -> xlate_error "xlate_command_list" + | _ -> xlate_error "Not a list of commands";; diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli new file mode 100644 index 00000000..bedb4ac8 --- /dev/null +++ b/contrib/interface/xlate.mli @@ -0,0 +1,9 @@ +open Ascent;; + +val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;; +val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;; +val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;; +val xlate_ident : Names.identifier -> ct_ID;; +val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;; + +val declare_in_coq : (unit -> unit);; |