summaryrefslogtreecommitdiff
path: root/contrib/interface
diff options
context:
space:
mode:
authorGravatar Samuel Mimram <samuel.mimram@ens-lyon.org>2004-07-28 21:54:47 +0000
committerGravatar Samuel Mimram <samuel.mimram@ens-lyon.org>2004-07-28 21:54:47 +0000
commit6b649aba925b6f7462da07599fe67ebb12a3460e (patch)
tree43656bcaa51164548f3fa14e5b10de5ef1088574 /contrib/interface
Imported Upstream version 8.0pl1upstream/8.0pl1
Diffstat (limited to 'contrib/interface')
-rw-r--r--contrib/interface/COPYRIGHT19
-rw-r--r--contrib/interface/ascent.mli784
-rwxr-xr-xcontrib/interface/blast.ml628
-rw-r--r--contrib/interface/blast.mli5
-rw-r--r--contrib/interface/centaur.ml4700
-rw-r--r--contrib/interface/ctast.ml76
-rw-r--r--contrib/interface/dad.ml382
-rw-r--r--contrib/interface/dad.mli10
-rw-r--r--contrib/interface/debug_tac.ml4570
-rw-r--r--contrib/interface/debug_tac.mli6
-rw-r--r--contrib/interface/history.ml373
-rw-r--r--contrib/interface/history.mli12
-rwxr-xr-xcontrib/interface/line_parser.ml4241
-rw-r--r--contrib/interface/line_parser.mli5
-rw-r--r--contrib/interface/name_to_ast.ml252
-rw-r--r--contrib/interface/name_to_ast.mli2
-rw-r--r--contrib/interface/parse.ml488
-rw-r--r--contrib/interface/paths.ml26
-rw-r--r--contrib/interface/paths.mli4
-rw-r--r--contrib/interface/pbp.ml758
-rw-r--r--contrib/interface/pbp.mli4
-rw-r--r--contrib/interface/showproof.ml1899
-rwxr-xr-xcontrib/interface/showproof.mli23
-rw-r--r--contrib/interface/showproof_ct.ml185
-rw-r--r--contrib/interface/translate.ml165
-rw-r--r--contrib/interface/translate.mli11
-rw-r--r--contrib/interface/vernacrc12
-rw-r--r--contrib/interface/vtp.ml1915
-rw-r--r--contrib/interface/vtp.mli15
-rw-r--r--contrib/interface/xlate.ml2118
-rw-r--r--contrib/interface/xlate.mli9
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);;