diff --git a/candle/prover/Holmakefile b/candle/prover/Holmakefile index 60715a5750..8e9dbd24c4 100644 --- a/candle/prover/Holmakefile +++ b/candle/prover/Holmakefile @@ -9,7 +9,8 @@ INCLUDES = ../../developers \ ../standard/ml_kernel \ ../standard/monadic \ ../standard/semantics \ - ../standard/syntax + ../standard/syntax \ + compute all: $(DEFAULT_TARGETS) README.md .PHONY: all diff --git a/candle/prover/README.md b/candle/prover/README.md index 59c8274b56..0e4bc3332b 100644 --- a/candle/prover/README.md +++ b/candle/prover/README.md @@ -6,6 +6,9 @@ Useful predicates on the CakeML ast. [candle_basis_evaluateScript.sml](candle_basis_evaluateScript.sml): Proving that the basis program only produces v_ok values. +[candle_kernelProgScript.sml](candle_kernelProgScript.sml): +Adds Candle specific functions to the kernel module from ml_hol_kernel_funsProg + [candle_kernel_funsScript.sml](candle_kernel_funsScript.sml): Prove that kernel functions maintain Candle prover's invariants @@ -25,5 +28,8 @@ evaluate of Candle prover [candle_prover_semanticsScript.sml](candle_prover_semanticsScript.sml): Top-level soundness theorem for the Candle theorem prover. +[compute](compute): +A verified Candle compute primitive. + [permsScript.sml](permsScript.sml): Permissions for CakeML values. diff --git a/candle/prover/candle_basis_evaluateScript.sml b/candle/prover/candle_basis_evaluateScript.sml index c40499d7f5..1c9675e5ad 100644 --- a/candle/prover/candle_basis_evaluateScript.sml +++ b/candle/prover/candle_basis_evaluateScript.sml @@ -15,6 +15,15 @@ val _ = set_grammar_ancestry [ "candle_prover_inv", "ast_extras", "evaluate", "namespaceProps", "perms", "semanticPrimitivesProps", "misc"]; +val _ = temp_send_to_back_overload "If" {Name="If", Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "App" {Name="App",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "Var" {Name="Var",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "Let" {Name="Let",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "If" {Name="If", Thy="compute_exec"}; +val _ = temp_send_to_back_overload "App" {Name="App",Thy="compute_exec"}; +val _ = temp_send_to_back_overload "Var" {Name="Var",Thy="compute_exec"}; +val _ = temp_send_to_back_overload "Let" {Name="Let",Thy="compute_exec"}; + Definition simple_exp_def: simple_exp = every_exp $ λx. case x of diff --git a/candle/standard/ml_kernel/candle_kernelProgScript.sml b/candle/prover/candle_kernelProgScript.sml similarity index 54% rename from candle/standard/ml_kernel/candle_kernelProgScript.sml rename to candle/prover/candle_kernelProgScript.sml index 0bc8836eaf..7f5a99ac31 100644 --- a/candle/standard/ml_kernel/candle_kernelProgScript.sml +++ b/candle/prover/candle_kernelProgScript.sml @@ -5,10 +5,14 @@ open preamble; open ml_translatorLib ml_monad_translatorLib ml_progLib ml_hol_kernel_funsProgTheory; open basisFunctionsLib print_thmTheory; open (* lisp: *) lisp_parsingTheory lisp_valuesTheory lisp_printingTheory; +open (* compute: *) compute_syntaxTheory compute_evalTheory computeTheory + compute_pmatchTheory; +open runtime_checkTheory runtime_checkLib; val _ = new_theory "candle_kernelProg"; -val _ = set_grammar_ancestry ["ml_hol_kernel_funsProg"]; +val _ = set_grammar_ancestry [ "ml_hol_kernel_funsProg", "compute" + ]; val _ = m_translation_extends "ml_hol_kernel_funsProg" @@ -71,6 +75,89 @@ val _ = (append_prog o process_topdecs) ` #(kernel_ffi) str arr end; ` +(* compute primitive *) + +val _ = ml_prog_update open_local_block; + +val r = translate dest_num_PMATCH; +val r = m_translate dest_numeral_PMATCH; +val r = translate dest_numeral_opt_PMATCH; +val r = translate list_dest_comb_def; +val r = translate mapOption_def; +val r = translate app_type_def; +val r = translate dest_cexp_def; + +Theorem dest_cexp_side[local]: + ∀x. dest_cexp_side x +Proof + ho_match_mp_tac dest_cexp_ind \\ rw [] + \\ once_rewrite_tac [fetch "-" "dest_cexp_side_def"] \\ rw [] +QED + +val _ = update_precondition dest_cexp_side; + +val r = m_translate option_def; +val r = m_translate check_def; +val r = translate SAFEMOD_def; +val r = translate SAFEDIV_def; +val r = translate num2bit_def; +val r = translate compute_execTheory.cv2term_def + +val r = compute_thms_def |> EVAL_RULE |> translate; + +val r = m_translate dest_binary_PMATCH; + +val r = check [‘ths’] compute_init_def |> translate; + +val r = m_translate check_var_def; + +val _ = use_mem_intro := true; +val res = translate_no_ind check_cexp_closed_def; + +val ind_lemma = Q.prove( + `^(first is_forall (hyp res))`, + rpt gen_tac + \\ rpt (disch_then strip_assume_tac) + \\ match_mp_tac (latest_ind ()) + \\ rpt strip_tac + \\ last_x_assum match_mp_tac + \\ rpt strip_tac + \\ fs [FORALL_PROD, GSYM ml_translatorTheory.MEMBER_INTRO]) + |> update_precondition; +val _ = use_mem_intro := false; + +val r = translate var_list_def; + +val r = translate const_list_def; +val r = m_translate map_def; + +val _ = use_mem_intro := true; +val r = m_translate check_consts_def; +val r = m_translate check_eqn_def; +val _ = use_mem_intro := false; + +val r = translate compute_default_clock; (* TODO _def *) +val r = translate indexedListsTheory.findi_def +val r = translate compute_execTheory.monop_def +val r = translate compute_execTheory.to_num_def +val r = translate compute_execTheory.cv_T_def +val r = translate compute_execTheory.cv_F_def +val r = translate compute_execTheory.binop_def +val r = translate compute_execTheory.to_ce_def +val r = translate compute_execTheory.compile_to_ce_def +val r = translate compute_execTheory.build_funs_def +val r = translate compute_execTheory.env_lookup_def + +val r = m_translate compute_execTheory.get_code_def +val r = m_translate compute_execTheory.exec_def + +val _ = ml_prog_update open_local_in_block; + +val r = check [‘ths’,‘tm’] compute_add_def |> m_translate; +val r = compute_def + |> SIMP_RULE(srw_ss()) [combinTheory.C_DEF] + |> check [‘ths’,‘ceqs’,‘tm’] + |> m_translate; val _ = ml_prog_update close_local_blocks; val _ = ml_prog_update (close_module NONE); diff --git a/candle/prover/candle_kernel_funsScript.sml b/candle/prover/candle_kernel_funsScript.sml index 5ee369e3f9..b0b58a7edf 100644 --- a/candle/prover/candle_kernel_funsScript.sml +++ b/candle/prover/candle_kernel_funsScript.sml @@ -6,7 +6,7 @@ open preamble helperLib; open semanticPrimitivesTheory semanticPrimitivesPropsTheory evaluateTheory namespacePropsTheory evaluatePropsTheory sptreeTheory holKernelProofTheory ml_hol_kernel_funsProgTheory - candle_kernel_permsTheory candle_kernelProgTheory; + candle_kernel_permsTheory candle_kernelProgTheory computeProofTheory; open permsTheory candle_kernel_valsTheory candle_prover_invTheory ast_extrasTheory; local open ml_progLib in end @@ -469,7 +469,6 @@ Theorem inferred_ok: (∀vs. res = Rval vs ⇒ EVERY (v_ok ctxt') vs) ∧ (∀v. res = Rerr (Rraise v) ⇒ v_ok ctxt' v) Proof - rw [Once inferred_cases] >~ [‘TYPE ctxt ty’] >- ( Cases_on ‘ty’ \\ gs [TYPE_TYPE_def, do_opapp_cases]) @@ -480,7 +479,8 @@ Proof \\ rename [‘f ∈ kernel_funs’] \\ Cases_on ‘f ∈ { call_type_subst_v; call_freesin_v; call_vfree_in_v; call_variant_v; vsubst_v; inst_v; trans_v; abs_v; eq_mp_v; - deduct_antisym_rule_v; inst_type_v; inst_1_v; trans_v }’ THEN1 + deduct_antisym_rule_v; inst_type_v; inst_1_v; trans_v; + compute_add_v; compute_v }’ THEN1 (gvs [] \\ qpat_x_assum ‘do_opapp _ = _’ mp_tac \\ last_x_assum mp_tac @@ -1508,11 +1508,7 @@ Proof \\ gvs[SF SFY_ss, THM_IMP_v_ok] \\ reverse conj_tac >- metis_tac[v_ok_APPEND, CONS_APPEND] \\ metis_tac[ref_ok_APPEND, CONS_APPEND]) - >~ [‘do_opapp [Kernel_print_thm_v; v]’] >- ( - - - drule_all Kernel_print_thm_v_head \\ strip_tac \\ gvs[] >- (first_assum $ irule_at Any \\ simp[]) @@ -1766,6 +1762,7 @@ Theorem kernel_vals_ok: (∀vs. res = Rval vs ⇒ EVERY (v_ok ctxt') vs) ∧ (∀v. res = Rerr (Rraise v) ⇒ v_ok ctxt' v) Proof + rw [Once v_ok_cases] >~ [‘inferred ctxt f’] >- ( irule_at Any inferred_ok @@ -2148,6 +2145,56 @@ Proof \\ imp_res_tac THM_IMP_v_ok \\ gvs [] \\ rename [‘M_failure ff’] \\ Cases_on ‘ff’ \\ fs [] \\ fs [HOL_EXN_TYPE_Fail_v_ok, SF SFY_ss]) + \\ Cases_on ‘f = compute_add_v’ \\ gvs [] >- ( + drule_all compute_add_v_head \\ strip_tac \\ gvs[] + >- (qexists_tac`ctxt` \\ fs[]) + \\ rename1 ‘do_opapp [g; w]’ + \\ assume_tac compute_add_v_thm + \\ fs[state_ok_def] + \\ drule_all_then strip_assume_tac v_ok_LIST_THM_TYPE_HEAD + \\ drule_all_then strip_assume_tac v_ok_TERM_TYPE_HEAD + \\ drule ArrowM2 + \\ rpt(disch_then drule) + \\ simp[SF SFY_ss, TERM_TYPE_perms_ok, LIST_TYPE_THM_perms_ok] + \\ strip_tac \\ gvs[] + \\ qexists_tac ‘ctxt’ \\ simp[] + \\ drule_all_then assume_tac v_ok_TERM + \\ drule_all_then assume_tac v_ok_LIST_THM + \\ strip_tac + \\ drule_all_then strip_assume_tac compute_add_thm \\ rveq + >- ( first_assum $ irule_at $ Any \\ simp[SF SFY_ss] ) + \\ Cases_on ‘r’ \\ gvs [THM_IMP_v_ok, SF SFY_ss] + \\ rename [‘M_failure ff’] \\ Cases_on ‘ff’ \\ fs [] + \\ fs [HOL_EXN_TYPE_Fail_v_ok, SF SFY_ss]) + \\ Cases_on ‘f = compute_v’ \\ gvs [] >- ( + + drule_all compute_v_head \\ strip_tac \\ gvs[] + >- (qexists_tac`ctxt` \\ fs[]) + \\ rename1 ‘do_opapp [g; w]’ + \\ assume_tac compute_v_thm + \\ fs[state_ok_def] + \\ ‘∃pq. PAIR_TYPE (LIST_TYPE THM_TYPE) (LIST_TYPE THM_TYPE) pq v’ + by (irule_at Any v_ok_PAIR_TYPE_HEAD + \\ first_x_assum (irule_at Any) + \\ first_x_assum (irule_at Any) + \\ simp [v_ok_LIST_THM_TYPE_HEAD, SF SFY_ss]) + \\ drule_all_then strip_assume_tac v_ok_TERM_TYPE_HEAD + \\ drule ArrowM2 + \\ rpt(disch_then drule) \\ simp [] + \\ Cases_on ‘pq’ \\ gs [ml_translatorTheory.PAIR_TYPE_def] + \\ simp [Once perms_ok_def, TERM_TYPE_perms_ok, LIST_TYPE_THM_perms_ok, + SF SFY_ss] + \\ strip_tac \\ gvs[] + \\ qexists_tac ‘ctxt’ \\ gs [v_ok_def] + \\ drule_all_then assume_tac v_ok_TERM + \\ imp_res_tac v_ok_LIST_THM \\ gs [SF SFY_ss] + \\ drule_all_then strip_assume_tac compute_thm \\ gvs [] + \\ strip_tac + >- ( first_assum $ irule_at $ Any \\ simp[SF SFY_ss] ) + \\ rename [‘compute _ _ _ = (res1,_)’] + \\ Cases_on ‘res1’ \\ gvs [THM_IMP_v_ok, SF SFY_ss] + \\ rename [‘M_failure ff’] \\ Cases_on ‘ff’ \\ fs [] + \\ fs [HOL_EXN_TYPE_Fail_v_ok, SF SFY_ss]) \\ qsuff_tac ‘∃v1 v2 x. f = Closure v1 v2 x ∧ ∀n w. x ≠ Fun n w’ THEN1 (strip_tac \\ fs [do_partial_app_def,AllCaseEqs()]) \\ fs [kernel_funs_def] diff --git a/candle/prover/candle_kernel_permsScript.sml b/candle/prover/candle_kernel_permsScript.sml index 3ec66c6dac..ab42a1e9a6 100644 --- a/candle/prover/candle_kernel_permsScript.sml +++ b/candle/prover/candle_kernel_permsScript.sml @@ -6,6 +6,7 @@ open preamble helperLib; open semanticPrimitivesTheory semanticPrimitivesPropsTheory sptreeTheory evaluateTheory namespacePropsTheory evaluatePropsTheory candle_kernel_valsTheory candle_kernelProgTheory; +open candle_prover_invTheory; open permsTheory ml_hol_kernel_funsProgTheory ml_progLib ast_extrasTheory; val _ = new_theory "candle_kernel_perms"; @@ -137,6 +138,12 @@ Proof rw[perms_ok_def, check_tm_v_def, astTheory.pat_bindings_def, perms_ok_env_def] QED +Theorem perms_ok_check_thm_v[simp]: + perms_ok ps check_thm_v +Proof + rw[perms_ok_def, check_thm_v_def, astTheory.pat_bindings_def, perms_ok_env_def] +QED + Theorem perms_ok_check_tm_tm_v[simp]: perms_ok ps check_tm_tm_v Proof @@ -810,6 +817,350 @@ Proof \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw [] \\ fs [] QED +Theorem perms_ok_funpow_v[simp]: + perms_ok ps funpow_v +Proof + rw[perms_ok_def, std_preludeTheory.funpow_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_app_type_v[simp]: + perms_ok ps app_type_v +Proof + rw[perms_ok_def, app_type_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_num2bit_v[simp]: + perms_ok ps num2bit_v +Proof + rw[perms_ok_def, num2bit_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_cv2term_v[simp]: + perms_ok ps cv2term_v +Proof + rw[perms_ok_def, cv2term_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_safemod_v[simp]: + perms_ok ps safemod_v +Proof + rw[perms_ok_def, safemod_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_safediv_v[simp]: + perms_ok ps safediv_v +Proof + rw[perms_ok_def, safediv_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED +Theorem perms_ok_alookup_v[simp]: + perms_ok ps ListProg$alookup_v +Proof + rw[perms_ok_def, ListProgTheory.alookup_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_zip_v[simp]: + perms_ok ps ListProg$zip_v +Proof + rw[perms_ok_def, ListProgTheory.zip_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_option_v[simp]: + perms_ok ps option_v +Proof + rw[perms_ok_def, option_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_check_v[simp]: + perms_ok ps check_v +Proof + rw[perms_ok_def, check_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_get_code_v[simp]: + perms_ok ps get_code_v +Proof + rw[perms_ok_def, get_code_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_env_lookup_v[simp]: + perms_ok ps env_lookup_v +Proof + rw[perms_ok_def, env_lookup_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_exec_v[simp]: + perms_ok ps exec_v +Proof + rw[perms_ok_def, exec_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_cv_t_v[simp]: + perms_ok ps cv_t_v +Proof + mp_tac candle_kernelProgTheory.cv_t_v_thm + \\ qabbrev_tac ‘a = cv_t_v’ \\ EVAL_TAC + \\ rw[perms_ok_def, astTheory.pat_bindings_def, perms_ok_env_def] +QED + +Theorem perms_ok_cv_f_v[simp]: + perms_ok ps cv_f_v +Proof + mp_tac candle_kernelProgTheory.cv_f_v_thm + \\ qabbrev_tac ‘a = cv_f_v’ \\ EVAL_TAC + \\ rw[perms_ok_def, astTheory.pat_bindings_def, perms_ok_env_def] +QED + +Theorem perms_ok_to_num_v[simp]: + perms_ok ps to_num_v +Proof + rw[perms_ok_def, to_num_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_monop_v[simp]: + perms_ok ps monop_v +Proof + rw[perms_ok_def, monop_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_binop_v[simp]: + perms_ok ps binop_v +Proof + rw[perms_ok_def, binop_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_findi_1_v[simp]: + perms_ok ps findi_1_v +Proof + rw[perms_ok_def, findi_1_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_to_ce_v[simp]: + perms_ok ps to_ce_v +Proof + rw[perms_ok_def, to_ce_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_rev_v[simp]: + perms_ok ps ListProg$rev_v +Proof + rw[perms_ok_def, ListProgTheory.rev_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_reverse_v[simp]: + perms_ok ps ListProg$reverse_v +Proof + rw[perms_ok_def, ListProgTheory.reverse_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_compile_to_ce_v[simp]: + perms_ok ps compile_to_ce_v +Proof + rw[perms_ok_def, compile_to_ce_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_build_funs_v[simp]: + perms_ok ps build_funs_v +Proof + rw[perms_ok_def, build_funs_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ gs [] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_compute_thms_v[simp]: + perms_ok ps compute_thms_v +Proof + irule LIST_TYPE_THM_perms_ok + \\ irule_at Any compute_thms_v_thm +QED + +Theorem perms_ok_compute_init_v[simp]: + perms_ok ps compute_init_v +Proof + rw[perms_ok_def, compute_init_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_list_dest_comb_v[simp]: + perms_ok ps list_dest_comb_v +Proof + once_rewrite_tac [list_dest_comb_v_def] + \\ rw[perms_ok_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_mapoption_v[simp]: + perms_ok ps mapoption_v +Proof + rw[perms_ok_def, mapoption_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_i_v[simp]: + perms_ok ps i_v +Proof + rw[perms_ok_def, std_preludeTheory.i_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_dest_num_v[simp]: + perms_ok ps dest_num_v +Proof + rw[perms_ok_def, dest_num_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_dest_numeral_v[simp]: + perms_ok ps dest_numeral_v +Proof + rw[perms_ok_def, dest_numeral_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_dest_binary_v[simp]: + perms_ok ps dest_binary_v +Proof + rw[perms_ok_def, dest_binary_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_dest_numeral_opt_v[simp]: + perms_ok ps dest_numeral_opt_v +Proof + rw[perms_ok_def, dest_numeral_opt_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_hd_v[simp]: + perms_ok ps ListProg$hd_v +Proof + rw[perms_ok_def, ListProgTheory.hd_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_dest_cexp_v[simp]: + perms_ok ps dest_cexp_v +Proof + once_rewrite_tac [dest_cexp_v_def] + \\ rw[perms_ok_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] +QED + +Theorem perms_ok_check_cexp_closed_v[simp]: + perms_ok ps check_cexp_closed_v +Proof + rw[perms_ok_def, check_cexp_closed_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_map_2_v[simp]: + perms_ok ps map_2_v +Proof + rw[perms_ok_def, map_2_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_all_distinct_v[simp]: + perms_ok ps ListProg$all_distinct_v +Proof + rw[perms_ok_def, ListProgTheory.all_distinct_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_flat_v[simp]: + perms_ok ps ListProg$flat_v +Proof + rw[perms_ok_def, ListProgTheory.flat_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_check_var_v[simp]: + perms_ok ps check_var_v +Proof + rw[perms_ok_def, check_var_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_var_list_v[simp]: + perms_ok ps var_list_v +Proof + rw[perms_ok_def, var_list_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_check_eqn_v[simp]: + perms_ok ps check_eqn_v +Proof + rw[perms_ok_def, check_eqn_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_const_list_v[simp]: + perms_ok ps const_list_v +Proof + rw[perms_ok_def, const_list_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_check_consts_v[simp]: + perms_ok ps check_consts_v +Proof + rw[perms_ok_def, check_consts_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_compute_default_clock_v[simp]: + perms_ok ps compute_default_clock_v +Proof + assume_tac compute_default_clock_v_thm + \\ gs [computeTheory.compute_default_clock, ml_translatorTheory.NUM_def, + ml_translatorTheory.INT_def, perms_ok_def] +QED + (* Functions translated with 'm_translate' should be proved for kernel_perms *) Theorem perms_ok_the_type_constants[simp]: @@ -1097,6 +1448,22 @@ Proof \\ rw[] QED +Theorem perms_ok_compute_add_v[simp]: + perms_ok kernel_perms compute_add_v +Proof + rw[perms_ok_def, compute_add_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + +Theorem perms_ok_compute_v[simp]: + perms_ok kernel_perms compute_v +Proof + rw[perms_ok_def, compute_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + \\ pop_assum mp_tac \\ eval_nsLookup_tac + \\ rw[] +QED + (* Theorem perms_ok_member_v: perms_ok ps member_v diff --git a/candle/prover/candle_kernel_valsScript.sml b/candle/prover/candle_kernel_valsScript.sml index 83bdb4e600..bbe39e05f6 100644 --- a/candle/prover/candle_kernel_valsScript.sml +++ b/candle/prover/candle_kernel_valsScript.sml @@ -83,14 +83,20 @@ Definition kernel_funs_def: Kernel_print_thm_v; + (* Compute additions *) + compute_add_v; + compute_v; } End Theorem kernel_funs_v_def = kernel_funs_def |> concl |> rand |> find_terms is_const |> filter (fn tm => not (mem (fst (dest_const tm)) ["INSERT","EMPTY"])) - |> map (fn c => DB.find (fst (dest_const c) ^ "_def")) - |> map (fn t => hd t |> snd |> fst) + |> map (fn c => fst (dest_const c) ^ "_def") + |> map (fn defn => + DB.find defn + |> Lib.pluck (fn ((_,nm),_) => nm = defn) + |> fst |> snd |> fst) |> curry (op @) [constants_v_def,abs_v_def] |> LIST_CONJ; @@ -118,7 +124,7 @@ val context_refs_defs = the_context_def |> concl |> find_terms (listSyntax.is_le |> map (dest_thy_const o listSyntax.dest_length) |> map (fn cn => fetch (#Thy cn) (#Name cn ^ "_def")) -Theorem refs_defs = LIST_CONJ context_refs_defs +Theorem refs_defs = LIST_CONJ (cv_t_refs_def :: cv_f_refs_def :: context_refs_defs) Theorem kernel_locs = IN_kernel_locs |> SIMP_RULE (srw_ss()) [the_type_constants_def, @@ -315,7 +321,8 @@ val safe_error_goal = (res = Rerr (Rabort Rtype_error) ∨ res = Rerr (Rraise bind_exn_v) ∨ res = Rerr (Rabort Rtimeout_error) - :(semanticPrimitives$v list, semanticPrimitives$v) semanticPrimitives$result)” + :(semanticPrimitives$v list, semanticPrimitives$v) + semanticPrimitives$result)” Theorem do_opapp_clos: do_opapp [Closure env v e; argv] = SOME (env1,e1) ⇔ @@ -417,6 +424,30 @@ Proof \\ fs [namespaceTheory.nsOptBind_def] QED +Theorem evaluate_thm_check: + evaluate ^s env + [Let NONE + (Mat (Var (Short v)) + [(Pcon (SOME (Short "Sequent")) [Pvar a1; Pvar a2], Con NONE [])]) ee] = + (s',res) ∧ + nsLookup env.c (Short "Sequent") = SOME (2,TypeStamp "Sequent" thm_stamp_n) ∧ + nsLookup env.v (Short v) = SOME w ⇒ + ^safe_error_goal ∨ THM_TYPE_HEAD w ∧ evaluate ^s env [ee] = (s',res) +Proof + fs [evaluate_def,same_ctor_def,pmatch_def,do_con_check_def] \\ csimp [] + \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ rpt strip_tac + \\ gvs [AllCaseEqs(),LENGTH_EQ_NUM_compute,same_clock_exists] + \\ Cases_on ‘w’ \\ gvs [pmatch_def] + \\ rename [‘Conv oo ll’] \\ Cases_on ‘oo’ \\ gvs [pmatch_def,AllCaseEqs()] + \\ gvs [AllCaseEqs(),LENGTH_EQ_NUM_compute] + \\ rpt strip_tac \\ gvs [same_ctor_def,pmatch_def] + \\ fs [THM_TYPE_HEAD_def] + \\ rpt (pop_assum mp_tac) + \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ fs [namespaceTheory.nsOptBind_def] +QED + Theorem evaluate_mat_pair: evaluate ^s env [Mat (Var (Short v)) [(Pcon NONE [Pvar a1; Pvar a2], ee)]] = (s',res) ∧ @@ -608,6 +639,79 @@ Proof \\ fs [] \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] QED +Theorem check_thm_head: + ∀v s. + ∃env e s' res. + do_opapp [check_thm_v; v] = SOME (env,e) ∧ + evaluate (dec_clock ^s) env [e] = (s',res) ∧ + (^safe_error_goal ∨ + ∃k z. s' = s with clock := k ∧ res = Rval [z] ∧ + LIST_TYPE_HEAD THM_TYPE_HEAD v) +Proof + strip_tac \\ completeInduct_on ‘v_size v’ + \\ rpt strip_tac \\ gvs [PULL_FORALL,AND_IMP_INTRO] + \\ rename [‘do_opapp [_; v]’] + \\ simp [check_thm_v_def] + \\ simp [do_opapp_def] + \\ once_rewrite_tac [find_recfun_def] \\ fs [] + \\ simp_tac (srw_ss()) [Once evaluate_def] + \\ simp_tac (srw_ss()) [Once evaluate_def] + \\ reverse IF_CASES_TAC \\ fs [] + THEN1 fs [dec_clock_def,same_clock_exists] + \\ simp_tac (srw_ss()) [Once evaluate_def,ALL_DISTINCT,astTheory.pat_bindings_def] + \\ simp_tac (srw_ss()) [pmatch_def] + \\ reverse CASE_TAC \\ fs [] + \\ TRY (fs [dec_clock_def,same_clock_exists] \\ NO_TAC) + \\ pop_assum mp_tac + \\ Cases_on ‘v’ \\ simp_tac (srw_ss()) [pmatch_def] + \\ Cases_on ‘o'’ \\ simp_tac (srw_ss()) [pmatch_def,AllCaseEqs(),same_ctor_def] + \\ strip_tac \\ fs [] + THEN1 + (rpt var_eq_tac + \\ simp_tac (srw_ss()) [evaluate_def] + \\ rpt (CASE_TAC \\ gvs [dec_clock_def,same_clock_exists,GSYM PULL_EXISTS]) + \\ rpt (pop_assum mp_tac) + \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ rpt strip_tac \\ gvs [] + \\ fs [LIST_TYPE_HEAD_def] + \\ qexists_tac ‘[]’ + \\ fs [LIST_TYPE_def]) + \\ simp_tac (srw_ss()) [Once evaluate_def,ALL_DISTINCT,astTheory.pat_bindings_def] + \\ CASE_TAC \\ fs [] + \\ TRY (fs [dec_clock_def,same_clock_exists] \\ NO_TAC) + THEN1 + (simp_tac (srw_ss()) [Once evaluate_def,ALL_DISTINCT,astTheory.pat_bindings_def] + \\ simp_tac (srw_ss()) [pmatch_def,dec_clock_def,same_clock_exists]) + \\ pop_assum mp_tac \\ simp_tac (srw_ss()) [pmatch_def,AllCaseEqs(),same_ctor_def] + \\ strip_tac \\ fs [] + \\ gvs [LENGTH_EQ_NUM_compute,pmatch_def] + \\ qmatch_goalsub_abbrev_tac ‘xx = (_,_)’ + \\ ‘∃res s. xx = (s,res)’ by metis_tac [PAIR] + \\ fs [Abbr ‘xx’] + \\ drule evaluate_thm_check + \\ fs [] \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ strip_tac \\ gvs [same_clock_exists] + \\ pop_assum mp_tac + \\ simp [Once evaluate_def] + \\ simp [Once evaluate_def] + \\ simp [Once evaluate_def] + \\ simp [Once evaluate_def] + \\ fs [] \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ fs [build_rec_env_def] + \\ fs [] \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] + \\ fs [GSYM check_thm_v_def] + \\ rename [‘do_opapp [_; h_tail]’] + \\ last_x_assum (qspecl_then [‘h_tail’,‘dec_clock s’] mp_tac) + \\ impl_tac THEN1 fs [v_size_def] + \\ strip_tac \\ fs [] + \\ rw [] \\ fs [dec_clock_def,same_clock_exists,GSYM PULL_EXISTS] + \\ fs [LIST_TYPE_HEAD_def] + \\ qexists_tac ‘()::l’ + \\ fs [LIST_TYPE_def,PAIR_TYPE_HEAD_def,PAIR_TYPE_def] + \\ rpt (pop_assum mp_tac) + \\ fs [] \\ CONV_TAC (DEPTH_CONV ml_progLib.nsLookup_conv) \\ simp [] +QED + Theorem check_tm_tm_head: ∀v s. ∃env e s' res. @@ -810,6 +914,22 @@ Proof \\ fs [] \\ strip_tac \\ gvs [] \\ metis_tac [] QED +Theorem evaluate_thm_list_check: + evaluate ^s env + [Let NONE (App Opapp [Var (Short "check_thm"); Var (Short v)]) ee] = (s',res) ∧ + nsLookup env.v (Short "check_thm") = SOME check_thm_v ∧ + nsLookup env.v (Short v) = SOME w ⇒ + ^safe_error_goal ∨ + LIST_TYPE_HEAD THM_TYPE_HEAD w ∧ + ∃k. evaluate (^s with clock := k) env [ee] = (s',res) +Proof + fs [evaluate_def,same_ctor_def,pmatch_def,do_con_check_def] \\ csimp [] + \\ fs [do_app_def,AllCaseEqs()] \\ strip_tac \\ gvs [same_clock_exists] + \\ fs [STRING_TYPE_HEAD_def,STRING_TYPE_def,namespaceTheory.nsOptBind_def] + \\ qspecl_then [‘w’,‘s’] mp_tac check_thm_head + \\ fs [] \\ strip_tac \\ gvs [] \\ metis_tac [] +QED + Theorem evaluate_ty_ty_list_check: evaluate ^s env [Let NONE (App Opapp [Var (Short "check_ty_ty"); Var (Short v)]) ee] = (s',res) ∧ @@ -946,6 +1066,8 @@ val prove_head_tac = dxrule evaluate_tm_check ORELSE dxrule evaluate_tm_list_check ORELSE dxrule evaluate_tm_tm_list_check ORELSE + dxrule evaluate_thm_check ORELSE + dxrule evaluate_thm_list_check ORELSE dxrule evaluate_str_check ORELSE dxrule evaluate_mat_thm ORELSE dxrule evaluate_mat_pair) @@ -1497,6 +1619,28 @@ Proof prove_head_tac QED +Theorem compute_add_v_head: + do_partial_app compute_add_v v = SOME g ∧ + do_opapp [g; w] = SOME (env,exp) ∧ + evaluate ^s env [exp] = (s',res) ⇒ + ^safe_error_goal ∨ + LIST_TYPE_HEAD THM_TYPE_HEAD v ∧ + TERM_TYPE_HEAD w +Proof + prove_head_tac +QED + +Theorem compute_v_head: + do_partial_app compute_v v = SOME g ∧ + do_opapp [g; w] = SOME (env,exp) ∧ + evaluate ^s env [exp] = (s',res) ⇒ + ^safe_error_goal ∨ + PAIR_TYPE_HEAD (LIST_TYPE_HEAD THM_TYPE_HEAD) + (LIST_TYPE_HEAD THM_TYPE_HEAD) v ∧ + TERM_TYPE_HEAD w +Proof + prove_head_tac +QED (* ------------------------------------------------------------------------- * Misc. simps diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml index 2b0e688af8..b92b47cf54 100644 --- a/candle/prover/candle_prover_evaluateScript.sml +++ b/candle/prover/candle_prover_evaluateScript.sml @@ -16,6 +16,11 @@ val _ = set_grammar_ancestry [ "candle_kernel_funs", "ast_extras", "evaluate", "namespaceProps", "perms", "semanticPrimitivesProps", "misc"]; +val _ = temp_send_to_back_overload "If" {Name="If",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "App" {Name="App",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "Var" {Name="Var",Thy="compute_syntax"}; +val _ = temp_send_to_back_overload "Let" {Name="Let",Thy="compute_syntax"}; + Theorem pmatch_v_ok: (∀envC s p v ws env. pmatch envC s p v ws = Match env ∧ @@ -216,7 +221,7 @@ Proof QED Theorem evaluate_v_ok_Eval: - op = Eval ⇒ ^(get_goal "App") + op = Eval ⇒ ^(get_goal "ast$App") Proof rw [evaluate_def] \\ gvs [AllCaseEqs(), evaluateTheory.do_eval_res_def] @@ -652,7 +657,7 @@ Proof QED Theorem evaluate_v_ok_Op: - op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") + op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "ast$App") Proof rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gs[] >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[]) @@ -694,7 +699,7 @@ Proof QED Theorem evaluate_v_ok_Opapp: - op = Opapp ⇒ ^(get_goal "App") + op = Opapp ⇒ ^(get_goal "ast$App") Proof rw [evaluate_def] \\ gvs [AllCaseEqs()] @@ -760,7 +765,7 @@ Proof QED Theorem evaluate_v_ok_App: - ^(get_goal "App") + ^(get_goal "ast$App") Proof Cases_on ‘op = Opapp’ >- (match_mp_tac evaluate_v_ok_Opapp \\ gs []) \\ Cases_on ‘op = Eval’ >- (match_mp_tac evaluate_v_ok_Eval \\ gs []) @@ -788,7 +793,7 @@ Proof QED Theorem evaluate_v_ok_If: - ^(get_goal "If") + ^(get_goal "ast$If") Proof rw [evaluate_def] \\ gvs [AllCaseEqs(), do_if_def] @@ -827,7 +832,7 @@ Proof QED Theorem evaluate_v_ok_Let: - ^(get_goal "Let") + ^(get_goal "ast$Let") Proof rw [evaluate_def] \\ gvs [AllCaseEqs()] diff --git a/candle/prover/candle_prover_invScript.sml b/candle/prover/candle_prover_invScript.sml index cb53d7e1b9..a60f01f61c 100644 --- a/candle/prover/candle_prover_invScript.sml +++ b/candle/prover/candle_prover_invScript.sml @@ -14,7 +14,7 @@ val _ = new_theory "candle_prover_inv"; val _ = set_grammar_ancestry [ "candle_kernel_vals", "ast_extras", "evaluate", "namespaceProps", "perms", - "semanticPrimitivesProps", "misc"]; + "holKernelProof", "semanticPrimitivesProps", "misc"]; (* ------------------------------------------------------------------------- * Expressions are safe if they do not construct anything with a name from the @@ -565,6 +565,18 @@ Proof \\ metis_tac[v_ok_TERM_TYPE_HEAD] QED +Theorem v_ok_LIST_THM_TYPE_HEAD: + v_ok ctxt v ∧ + LIST_TYPE_HEAD THM_TYPE_HEAD v ⇒ + ∃ths. LIST_TYPE THM_TYPE ths v +Proof + strip_tac + \\ irule v_ok_LIST_TYPE_HEAD + \\ first_assum (irule_at Any) + \\ first_assum (irule_at Any) + \\ rw [v_ok_THM_TYPE_HEAD, SF SFY_ss] +QED + Theorem v_ok_PAIR_TYPE_HEAD: v_ok ctxt v ∧ (!v. v_ok ctxt v ∧ A_HEAD v ==> ?a. A a v) ∧ @@ -661,6 +673,16 @@ Proof \\ metis_tac[v_ok_TERM] QED +Theorem v_ok_LIST_THM: + ∀ths v ctxt. LIST_TYPE THM_TYPE ths v ∧ v_ok ctxt v ⇒ EVERY (THM ctxt) ths +Proof + rpt strip_tac + \\ irule v_ok_LIST + \\ first_assum (irule_at Any) + \\ first_assum (irule_at Any) + \\ rw [v_ok_THM, SF SFY_ss] +QED + Theorem v_ok_LIST_TYPE: ∀tms v ctxt. LIST_TYPE TYPE_TYPE tms v ∧ v_ok ctxt v ⇒ EVERY (TYPE ctxt) tms Proof @@ -772,6 +794,14 @@ Proof \\ fs [TYPE_TYPE_perms_ok, SF SFY_ss] QED +Theorem LIST_TYPE_THM_perms_ok: + ∀tm v. LIST_TYPE THM_TYPE th v ⇒ perms_ok ps v +Proof + rw [] + \\ drule_at Any LIST_TYPE_perms_ok + \\ fs [THM_TYPE_perms_ok, SF SFY_ss] +QED + Theorem UPDATE_TYPE_perms_ok: ∀u v. UPDATE_TYPE u v ⇒ perms_ok ps v Proof diff --git a/candle/prover/candle_prover_semanticsScript.sml b/candle/prover/candle_prover_semanticsScript.sml index dab15e5a6d..179e82f138 100644 --- a/candle/prover/candle_prover_semanticsScript.sml +++ b/candle/prover/candle_prover_semanticsScript.sml @@ -187,7 +187,8 @@ Proof \\ simp [state_ok_def, candle_init_state_stamp] \\ irule_at Any STATE_init_refs \\ simp [candle_init_state_refs,kernel_locs] - \\ rw [LLOOKUP_EQ_EL, EL_APPEND_EQN, candle_init_state_def, refs_defs] + \\ rw [LLOOKUP_EQ_EL, EL_APPEND_EQN, candle_init_state_def, refs_defs, + compute_thms_refs_def, compute_default_clock_refs_def] \\ ‘loc = 0’ by fs [] \\ fs [ref_ok_def] QED diff --git a/candle/prover/compute/Holmakefile b/candle/prover/compute/Holmakefile new file mode 100644 index 0000000000..9651b7b6e3 --- /dev/null +++ b/candle/prover/compute/Holmakefile @@ -0,0 +1,20 @@ +INCLUDES = ../../../developers \ + ../../../misc \ + ../../../semantics \ + ../../../semantics/proofs \ + ../../../translator \ + ../../../translator/monadic \ + ../../../characteristic \ + ../../../basis \ + ../../standard/ml_kernel \ + ../../standard/monadic \ + ../../standard/semantics \ + ../../standard/syntax + +all: $(DEFAULT_TARGETS) README.md +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) + $(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES) diff --git a/candle/prover/compute/README.md b/candle/prover/compute/README.md new file mode 100644 index 0000000000..19538d91b8 --- /dev/null +++ b/candle/prover/compute/README.md @@ -0,0 +1,28 @@ +A verified Candle compute primitive. + +[computeProofScript.sml](computeProofScript.sml): +Proof of correctness for the compute primitive. + +[computeScript.sml](computeScript.sml): +Implementation of the compute primitive. + +[compute_evalProofScript.sml](compute_evalProofScript.sml): +Proofs about the interpreter function for the Candle compute primitive. + +[compute_evalScript.sml](compute_evalScript.sml): +Interpreter function for the Candle compute primitive. + +[compute_execProofScript.sml](compute_execProofScript.sml): +Verification of fast interpreter for the Candle compute primitive. + +[compute_execScript.sml](compute_execScript.sml): +Fast interpreter function for the Candle compute primitive. + +[compute_pmatchScript.sml](compute_pmatchScript.sml): +Pmatch definitions for functions in computeScript.sml. + +[compute_syntaxProofScript.sml](compute_syntaxProofScript.sml): +Proofs related to term embeddings for the Candle compute primitive. + +[compute_syntaxScript.sml](compute_syntaxScript.sml): +Definitions of 'compute expressions' for the Candle compute primitive. diff --git a/candle/prover/compute/computeProofScript.sml b/candle/prover/compute/computeProofScript.sml new file mode 100644 index 0000000000..c0ee47dc27 --- /dev/null +++ b/candle/prover/compute/computeProofScript.sml @@ -0,0 +1,476 @@ +(* + Proof of correctness for the compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holKernelTheory + holKernelProofTheory ml_monadBaseTheory; +open compute_syntaxTheory compute_syntaxProofTheory; +open compute_evalTheory compute_evalProofTheory; +open computeTheory; + +val _ = new_theory "computeProof"; + +val _ = numLib.prefer_num (); + +Theorem compute_init_thy_ok: + compute_init ths ∧ + STATE ctxt s ∧ + EVERY (THM ctxt) ths ⇒ + compute_thy_ok (thyof ctxt) +Proof + strip_tac + \\ gvs [compute_init_def] + \\ gs [compute_thms_def, compute_thy_ok_def, numeral_thy_ok_def, + bool_thy_ok_def, STATE_def, CONTEXT_def, THM_def, extends_theory_ok, + init_theory_ok, SF SFY_ss] +QED + +(* ------------------------------------------------------------------------- + * compute_add + * ------------------------------------------------------------------------- *) + +Theorem compute_add_thm: + STATE ctxt s ∧ + EVERY (THM ctxt) ths ∧ + TERM ctxt tm ⇒ + compute_add ths tm s = (res, s') ⇒ + s' = s ∧ + (∀th. res = M_success th ⇒ THM ctxt th) ∧ + (∀tm. res ≠ M_failure (Clash tm)) +Proof + simp [compute_add_def, raise_Failure_def] + \\ IF_CASES_TAC \\ gs [] \\ strip_tac + \\ drule_all_then strip_assume_tac compute_init_thy_ok + \\ drule_then strip_assume_tac compute_thy_ok_terms_ok + \\ ‘theory_ok (thyof ctxt) ∧ numeral_thy_ok (thyof ctxt)’ by fs [] + \\ simp [Once st_ex_bind_def, otherwise_def] + \\ CASE_TAC \\ gs [] + \\ ‘TERM ctxt _ADD_TM’ + by gs [TERM_def] + \\ drule_all_then strip_assume_tac dest_binary_thm \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ pairarg_tac \\ gvs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac dest_numeral_thm \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac dest_numeral_thm \\ gvs [] + \\ CASE_TAC \\ gvs [] + \\ simp [Once st_ex_bind_def, st_ex_return_def] \\ CASE_TAC \\ gs [] + \\ rename [‘num2bit (x + y)’, + ‘dest_binary _ (_ADD (_NUMERAL l) (_NUMERAL r)) s’] + \\ ‘TERM ctxt (_NUMERAL (num2bit (x + y)))’ + by (‘TERM ctxt (num2bit (x + y))’ + suffices_by rw [TERM_def, term_ok_def] + \\ simp [num2bit_thm]) + \\ drule_then (qspec_then ‘ctxt’ mp_tac) mk_eq_thm + \\ impl_tac >- fs [] + \\ strip_tac \\ rveq + \\ CASE_TAC \\ fs [] + \\ rw [] \\ rw [THM_def] + \\ ‘term_type (_ADD (_NUMERAL l) (_NUMERAL r)) = Num’ + by (fs [STATE_def] + \\ qpat_x_assum ‘TERM _ (_ADD _ _)’ assume_tac + \\ drule_all term_type \\ gs []) + \\ gvs [] + \\ fs [STATE_def] + \\ dxrule num2bit_dest_numeral \\ fs [] \\ strip_tac + \\ dxrule num2bit_dest_numeral \\ fs [] \\ strip_tac + \\ gvs [] + \\ qmatch_asmsub_abbrev_tac ‘TERM ctxt _’ + \\ ‘TERM ctxt l ∧ TERM ctxt r’ + by gs [TERM_def, term_ok_def] + \\ ‘l has_type Num ∧ r has_type Num’ + by gs [TERM_def, term_ok_def, WELLTYPED] + \\ ‘(thyof ctxt,[]) |- _NUMERAL l === l’ + by gs [NUMERAL_eqn, TERM_def] + \\ ‘(thyof ctxt,[]) |- _NUMERAL r === r’ + by gs [NUMERAL_eqn, TERM_def] + \\ ‘(thyof ctxt,[]) |- _ADD (_NUMERAL l) (_NUMERAL r) === + _NUMERAL (num2bit (x + y))’ + suffices_by rw [equation_def] + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ irule replaceL1 \\ first_x_assum (irule_at Any) + \\ irule replaceL2 \\ first_x_assum (irule_at Any) + \\ ‘numeral_thy_ok (thyof ctxt)’ by fs [] + \\ dxrule_then assume_tac num2bit_term_ok \\ fs [] + \\ resolve_then Any irule trans_equation_simple sym_equation + \\ irule_at Any NUMERAL_eqn \\ rw [num2bit_ADD] +QED + +(* ------------------------------------------------------------------------- + * compute + * ------------------------------------------------------------------------- *) + +Theorem const_list_ok[local]: + ∀vs. set (const_list vs) = cexp_consts vs +Proof + ho_match_mp_tac const_list_ind + \\ rw [const_list_def, cexp_consts_def] + \\ simp [Once EXTENSION] + \\ rw [MEM_FLAT, MEM_MAP, PULL_EXISTS] + \\ eq_tac \\ rw [DISJ_EQ_IMP] \\ gs [] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (irule_at Any) \\ gs [] +QED + +Theorem var_list_ok[local]: + ∀vs. set (var_list vs) = cexp_vars vs +Proof + ho_match_mp_tac var_list_ind + \\ rw [var_list_def, cexp_vars_def, LIST_TO_SET_FILTER, INTER_DEF, DIFF_DEF] + \\ simp [Once EXTENSION] + \\ rw [MEM_FLAT, MEM_MAP, PULL_EXISTS] + \\ eq_tac \\ rw [DISJ_EQ_IMP] \\ gs [] + \\ first_x_assum (drule_then assume_tac) + \\ first_x_assum (irule_at Any) \\ gs [] +QED + +Theorem check_cexp_closed_correct: + ∀bvs v. check_cexp_closed bvs v ⇒ cexp_vars v DIFF set bvs = {} +Proof + ho_match_mp_tac check_cexp_closed_ind + \\ rw [check_cexp_closed_def, cexp_vars_def] + \\ gs [SUBSET_DIFF_EMPTY, DIFF_DEF, SUBSET_DEF, PULL_EXISTS, DISJ_EQ_IMP, + SF DNF_ss] + \\ rw [DISJ_EQ_IMP] \\ gs [EVERY_MEM] + \\ simp [Once EXTENSION, EQ_IMP_THM, MEM_MAP, PULL_EXISTS] + \\ gvs [MEM_MAP, EXISTS_PROD, SF SFY_ss] +QED + +Theorem map_check_var_thm: + ∀tms s res s'. + STATE ctxt s ∧ + EVERY (TERM ctxt) tms ∧ + map check_var tms s = (res, s') ⇒ + s = s' ∧ + (∀tm. res ≠ M_failure (Clash tm)) ∧ + ∀ns. + res = M_success ns ⇒ + LIST_REL (λtm n. tm = Var n Cexp) tms ns +Proof + Induct \\ simp [map_def, st_ex_return_def] + \\ rpt gen_tac + \\ strip_tac + \\ qpat_x_assum ‘_ = (res,_)’ mp_tac + \\ simp [Once st_ex_bind_def] + \\ CASE_TAC \\ gs [] + \\ reverse CASE_TAC \\ gs [] + >- ( + strip_tac \\ gvs [] + \\ Cases_on ‘h’ \\ gs [check_var_def, raise_Failure_def, st_ex_return_def] + \\ gvs [COND_RATOR, CaseEq "bool"]) + \\ Cases_on ‘h’ \\ gs [check_var_def, raise_Failure_def, st_ex_return_def] + \\ gvs [COND_RATOR, CaseEq "bool"] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum drule_all \\ rw [] + \\ gvs [CaseEq "exc"] +QED + +Theorem check_eqn_thm: + compute_thy_ok (thyof ctxt) ∧ + STATE ctxt s ∧ + THM ctxt th ∧ + check_eqn th s = (res, s') ⇒ + s = s' ∧ + (∀tm. res ≠ M_failure (Clash tm)) ∧ + ∀f vs r. + res = M_success (f,vs,cv) ⇒ + ∃l r. ALL_DISTINCT vs ∧ + th = Sequent [] (l === r) ∧ + list_dest_comb [] l = Const f (app_type (LENGTH vs)):: + (MAP (λs. Var s Cexp) vs) ∧ + dest_cexp r = SOME cv ∧ + ∀v. v ∈ cexp_vars cv ⇒ MEM v vs +Proof + strip_tac + \\ qpat_x_assum ‘check_eqn _ _ = _’ mp_tac + \\ Cases_on ‘th’ \\ gvs [check_eqn_def] + \\ simp [st_ex_return_def, raise_Failure_def, st_ex_ignore_bind_def] + \\ IF_CASES_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ ‘TERM ctxt t’ + by (fs [THM_def, TERM_def] + \\ drule proves_term_ok \\ rw []) + \\ drule_all_then strip_assume_tac dest_eq_thm \\ gvs [] + \\ reverse CASE_TAC \\ gs [] >- (rw [] \\ strip_tac \\ gs []) + \\ pairarg_tac \\ gvs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ IF_CASES_TAC \\ gs [] + \\ simp [otherwise_def, Once st_ex_bind_def] + \\ CASE_TAC \\ gs [] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ ‘TERM ctxt h ∧ EVERY (TERM ctxt) t’ + by (fs [TERM_def] + \\ drule_then strip_assume_tac term_ok_FOLDL_Comb + \\ fs [EVERY_MEM, TERM_def]) + \\ drule_all_then strip_assume_tac dest_const_thm \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ pairarg_tac \\ gvs [] + \\ simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC + \\ drule_all_then strip_assume_tac map_check_var_thm \\ gvs [] + \\ reverse TOP_CASE_TAC \\ gs [] >- (rpt strip_tac \\ gs []) + \\ rename [‘LIST_REL _ xs ys’] + \\ ‘ALL_DISTINCT ys’ + by (qpat_x_assum ‘ALL_DISTINCT xs’ mp_tac + \\ qpat_x_assum ‘LIST_REL _ _ _’ mp_tac + \\ qid_spec_tac ‘ys’ + \\ qid_spec_tac ‘xs’ + \\ Induct \\ rw [] + \\ gvs [LIST_REL_EL_EQN, MEM_EL, PULL_EXISTS] + \\ gs [DECIDE “A ⇒ ¬(B < C) ⇔ B < C ⇒ ¬A”]) + \\ gvs [LIST_REL_EL_EQN] + \\ TOP_CASE_TAC \\ gs [] + \\ drule_then drule dest_cexp_thm + \\ impl_tac >- fs [TERM_def] + \\ strip_tac + \\ IF_CASES_TAC \\ gs [GSYM equation_def] \\ rw [] + \\ simp [equation_def] + \\ irule_at Any LIST_EQ \\ gvs [LIST_REL_EL_EQN, EL_MAP] + \\ gvs [EVERY_MEM, var_list_ok] + \\ rename [‘tm = Const f (app_type (LENGTH tms))’] + \\ qpat_x_assum ‘dest_const tm _ = _’ mp_tac + \\ simp [dest_const_def, raise_Failure_def, st_ex_return_def] + \\ CASE_TAC \\ gs [] \\ rw [] + \\ rename [‘FOLDL _ (Const f ty) xs’] + \\ ‘LENGTH tms = LENGTH xs’ + by fs [map_LENGTH, SF SFY_ss] + \\ gs [TERM_def] + \\ ‘typeof (FOLDL Comb (Const f ty) xs) = Cexp’ + by fs [term_ok_def, equation_def] + \\ ‘∀tm. + term_ok (sigof ctxt) tm ∧ + (∀x. MEM x xs ⇒ term_ok (sigof ctxt) x ∧ typeof x = Cexp) ∧ + term_ok (sigof ctxt) (FOLDL Comb tm xs) ∧ + typeof (FOLDL Comb tm xs) = Cexp ⇒ + typeof tm = app_type (LENGTH xs)’ + suffices_by ( + rw [] + \\ first_x_assum (qspec_then ‘Const f ty’ assume_tac) + \\ gs [MEM_EL, PULL_EXISTS, SF SFY_ss]) + \\ rpt (pop_assum kall_tac) + \\ Induct_on ‘xs’ \\ simp [app_type] + \\ rw [] \\ gs [SF DNF_ss] + \\ drule_then strip_assume_tac term_ok_FOLDL_Comb + \\ first_x_assum drule \\ gs [term_ok_def] +QED + +Theorem map_check_eqn_thm: + compute_thy_ok (thyof ctxt) ⇒ + ∀ceqs s res s'. + STATE ctxt s ∧ + EVERY (THM ctxt) ceqs ∧ + map check_eqn ceqs s = (res, s') ⇒ + s = s' ∧ + (∀tm. res ≠ M_failure (Clash tm)) ∧ + ∀eqs. res = M_success eqs ⇒ + ∀n. n < LENGTH eqs ⇒ + ∃f vs cv l r. + ALL_DISTINCT vs ∧ + EL n eqs = (f,vs,cv) ∧ + EL n ceqs = Sequent [] (l === r) ∧ + list_dest_comb [] l = Const f (app_type (LENGTH vs)):: + (MAP (λs. Var s Cexp) vs) ∧ + dest_cexp r = SOME cv ∧ + ∀v. v ∈ cexp_vars cv ⇒ MEM v vs +Proof + strip_tac + \\ Induct \\ simp [map_def, st_ex_return_def, raise_Failure_def] + \\ qx_gen_tac ‘th’ + \\ rpt gen_tac \\ strip_tac + \\ qpat_x_assum ‘_ = (res,s')’ mp_tac + \\ simp [Once st_ex_bind_def] + \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac check_eqn_thm \\ gvs [] + \\ reverse CASE_TAC \\ gs [] >- (strip_tac \\ gvs []) + \\ rename [‘check_eqn _ _ = (M_success p, _)’] + \\ PairCases_on ‘p’ \\ fs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] \\ strip_tac \\ gvs [] + \\ Cases \\ gs [] +QED + +Theorem check_consts_thm: + STATE ctxt s ∧ + check_consts ars f r s = (res, s') ⇒ + s = s' ∧ + (∀tm. res ≠ M_failure (Clash tm)) ∧ + ∀u. res = M_success u ⇒ EVERY (λ(c,n). MEM (c,n) ars) (const_list r) +Proof + rw [check_consts_def, st_ex_return_def, raise_Failure_def] +QED + +Theorem map_check_consts_thm: + ∀ceqs s res s'. + STATE ctxt s ∧ + map (λ(f,(n,r)). check_consts ars f r) ceqs s = (res, s') ⇒ + s = s' ∧ + (∀tm. res ≠ M_failure (Clash tm)) ∧ + ∀u. res = M_success u ⇒ + ∀f vs cv. + MEM (f,vs,cv) ceqs ⇒ + EVERY (λ(c,n). MEM (c,n) ars) (const_list cv) +Proof + Induct \\ fs [map_def, check_consts_def, st_ex_return_def, raise_Failure_def] + \\ qx_gen_tac ‘h’ \\ PairCases_on ‘h’ + \\ rpt gen_tac \\ strip_tac + \\ qpat_x_assum ‘_ = (res,s')’ mp_tac + \\ simp [Once st_ex_bind_def] + \\ reverse IF_CASES_TAC \\ gs [] >- rw [] + \\ simp [Once st_ex_bind_def] + \\ CASE_TAC \\ gs [] + \\ first_x_assum drule_all + \\ strip_tac \\ gvs [] + \\ reverse CASE_TAC \\ gs [] \\ rw [] \\ gs [SF SFY_ss] +QED + +Theorem check_consts_ok: + ∀eqs cexp s u s'. + check_consts (MAP (λ(f,vs,x) . (f,LENGTH vs)) eqs) fn cexp s = + (M_success u, s') ⇒ + cexp_consts_ok eqs cexp +Proof + rw [check_consts_def, st_ex_return_def, raise_Failure_def] + \\ pop_assum mp_tac + \\ qid_spec_tac ‘eqs’ + \\ qid_spec_tac ‘cexp’ + \\ ho_match_mp_tac const_list_ind \\ rw [] + \\ gs [const_list_def, cexp_consts_ok_def] + \\ gs [EVERY_MEM, MEM_MAP, MEM_FLAT, EXISTS_PROD, PULL_EXISTS, FORALL_PROD, + SF SFY_ss] +QED + +Theorem cexp2term_from_cv: + ∀v. cexp2term (from_cv v) = cv2term v +Proof + Induct \\ fs [cexp2term_def,compute_execTheory.cv2term_def] +QED + +Theorem const_list_imp_cexp_consts_ok: + ∀eqs cv. + EVERY (λ(p1,p2). MEM (p1,p2) (MAP (λ(f,n,r). (f,LENGTH n)) eqs)) (const_list cv) ⇒ + cexp_consts_ok eqs cv +Proof + ho_match_mp_tac cexp_consts_ok_ind + \\ fs [const_list_def,cexp_consts_ok_def] + \\ rw [] + \\ simp [EVERY_MEM] + \\ rw [] \\ last_x_assum drule + \\ disch_then irule + \\ fs [EVERY_MEM,MEM_FLAT,PULL_EXISTS,FORALL_PROD,MEM_MAP,EXISTS_PROD] + \\ rw [] \\ res_tac \\ fs [] + \\ metis_tac [] +QED + +(* The type check can cause all sorts of failures, but the 'compute_eval' + * (and its implementation called exec) function always succeeds or raises + * a «timeout» exception. (Unfortunately, this is shadowed by the failures + * raised by the 'compute' function.) + *) + +Theorem compute_thm: + STATE ctxt s ∧ + EVERY (THM ctxt) ths ∧ + EVERY (THM ctxt) ceqs ∧ + TERM ctxt tm ⇒ + compute (ths,ceqs) tm s = (res, s') ⇒ + s' = s ∧ + (∀th. res = M_success th ⇒ THM ctxt th) ∧ + (∀tm. res ≠ M_failure (Clash tm)) +Proof + strip_tac + \\ simp [compute_def, handle_Clash_def, raise_Failure_def, st_ex_return_def] + \\ IF_CASES_TAC \\ gs [] + \\ gs [] + \\ drule_all_then strip_assume_tac compute_init_thy_ok + \\ drule_then assume_tac compute_thy_ok_is_std_sig + \\ ‘theory_ok (thyof ctxt) ∧ numeral_thy_ok (thyof ctxt)’ + by fs [] + \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_ignore_bind_def] + \\ IF_CASES_TAC \\ gs [] + \\ drule_then assume_tac check_cexp_closed_correct + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac map_check_eqn_thm \\ gvs [] + \\ reverse CASE_TAC \\ gs [] >- (CASE_TAC \\ gs [] \\ rw []) + \\ simp [st_ex_ignore_bind_def] + \\ IF_CASES_TAC \\ gs [] + \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac check_consts_thm + \\ rename [‘check_consts _ _ _ _ = (res,_)’] + \\ reverse (Cases_on ‘res’) \\ gs [] >- (CASE_TAC \\ gs [] \\ rw []) + \\ qmatch_goalsub_abbrev_tac ‘map g a s’ + \\ Cases_on ‘map g a s’ \\ gs [] + \\ unabbrev_all_tac \\ gs [] + \\ drule_all_then strip_assume_tac map_check_consts_thm \\ gvs [] + \\ rename [‘map _ _ s = (res,s)’] + \\ reverse (Cases_on ‘res’) \\ gs [] >- (CASE_TAC \\ gs [] \\ rw []) + \\ rename [‘to_ce eqs _ cv’] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC + \\ ‘term_ok (sigof ctxt) tm’ by fs [TERM_def] + \\ drule dest_cexp_thm \\ simp [] + \\ disch_then (drule_all_then strip_assume_tac) + \\ ‘term_ok (sigof ctxt) (cexp2term cv)’ + by (drule_then assume_tac proves_term_ok + \\ gvs [term_ok_clauses]) + \\ drule (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL compute_eval_thm))) + \\ ‘∃res1 s1. compute_eval compute_default_clock eqs cv s = (res1,s1)’ by metis_tac [PAIR] + \\ disch_then drule \\ gs [] + \\ impl_tac + >- ( + irule_at Any check_consts_ok + \\ first_assum (irule_at Any) + \\ gvs [EVERY_MEM, FORALL_PROD, MEM_EL, PULL_EXISTS] \\ rw [] + \\ first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ simp [cexp2term_def, MAP_MAP_o, o_DEF] + \\ first_x_assum (irule_at Any) + \\ imp_res_tac map_LENGTH \\ gs [] + \\ qpat_x_assum ‘∀n. _ ⇒ THM _ _’ drule + \\ rw [THM_def] \\ gs [SUBSET_DEF, MEM_EL, SF SFY_ss] + \\ irule check_consts_ok + \\ drule_then strip_assume_tac map_thm + \\ gs [PULL_FORALL] + \\ first_x_assum drule \\ rw [] + \\ first_assum (irule_at Any)) + \\ strip_tac \\ gvs [] + \\ qpat_x_assum ‘_ = _’ mp_tac + \\ DEP_REWRITE_TAC [compute_execProofTheory.compute_eval_eq_exec] + \\ conj_tac >- + (drule check_consts_ok \\ fs [] \\ rw [] + \\ fs [EVERY_EL] \\ rw [] + \\ ‘∃x. EL n eqs = x’ by fs [] \\ PairCases_on ‘x’ \\ fs [] + \\ res_tac \\ gvs [] \\ gvs [SUBSET_DEF] + \\ qpat_x_assum ‘∀x1 x2 x3. _’ mp_tac + \\ simp [Once MEM_EL,PULL_EXISTS] + \\ disch_then drule \\ fs [] + \\ simp [GSYM EVERY_EL] \\ fs [LAMBDA_PROD] + \\ simp [const_list_imp_cexp_consts_ok]) + \\ gvs [] + \\ strip_tac \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ rename [‘exec _ _ _ _ _ = (M_success tm', _)’] + \\ fs [cexp2term_from_cv] + \\ ‘TERM ctxt (cv2term tm')’ + by (drule_then strip_assume_tac proves_term_ok + \\ gvs [term_ok_clauses, TERM_def]) + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ drule_all_then strip_assume_tac mk_eq_thm \\ gvs [] + \\ reverse CASE_TAC >- (CASE_TAC \\ gs [] \\ rw []) + \\ rw [] + \\ ‘term_type tm = Cexp’ + by (fs [STATE_def] + \\ qpat_x_assum ‘TERM ctxt tm’ assume_tac + \\ drule_all term_type \\ gs []) + \\ ‘(thyof ctxt,[]) |- tm === cv2term tm'’ + suffices_by rw [equation_def, THM_def] + \\ resolve_then Any irule trans_equation_simple sym_equation + \\ first_x_assum (irule_at Any) \\ gs [sym_equation] +QED + +val _ = export_theory (); diff --git a/candle/prover/compute/computeScript.sml b/candle/prover/compute/computeScript.sml new file mode 100644 index 0000000000..044ddadd5a --- /dev/null +++ b/candle/prover/compute/computeScript.sml @@ -0,0 +1,286 @@ +(* + Implementation of the compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holKernelTheory + holKernelProofTheory ml_monadBaseTheory; +open compute_syntaxTheory compute_evalTheory compute_execTheory; + +val _ = new_theory "compute"; + +val _ = numLib.prefer_num (); + +val st_ex_monadinfo : monadinfo = { + bind = “st_ex_bind”, + ignorebind = SOME “st_ex_ignore_bind”, + unit = “st_ex_return”, + fail = SOME “raise_Failure”, + choice = SOME “$otherwise”, + guard = NONE + }; + +val _ = declare_monad ("st_ex", st_ex_monadinfo); +val _ = enable_monadsyntax (); +val _ = enable_monad "st_ex"; + +Overload return[local] = “st_ex_return”; +Overload failwith[local] = “raise_Failure”; +Overload handle[local] = “handle_Failure”; + +(* ------------------------------------------------------------------------- + * Theory initialization + * ------------------------------------------------------------------------- *) + +Definition compute_thms_def: + compute_thms = MAP (Sequent []) [ + (* COND_TRUE *) _COND _TRUE _M _N === _M; + (* COND_FALSE *) _COND _FALSE _M _N === _N; + (* IF_TRUE *) _IF _TRUE _X _Y === _X; + (* IF_FALSE *) _IF _FALSE _X _Y === _Y; + (* NUMERAL *) _NUMERAL _N === _N; + (* BIT0 *) _BIT0 _N === _ADD _N _N; + (* BIT1 *) _BIT1 _N === _SUC (_ADD _N _N); + (* ADD *) _ADD (_NUMERAL _0) _N === _N; + (* ADD *) _ADD (_SUC _M) _N === _SUC (_ADD _M _N); + (* SUB *) _SUB (_NUMERAL _0) _N === _NUMERAL _0; + (* SUB *) _SUB _M (_NUMERAL _0) === _M; + (* SUB *) _SUB (_SUC _M) (_SUC _N) === _SUB _M _N; + (* MUL *) _MUL (_NUMERAL _0) _N === _NUMERAL _0; + (* MUL *) _MUL (_SUC _M) _N === _ADD _N (_MUL _M _N); + (* DIV *) _DIV _M _N === + _COND (_N === _NUMERAL _0) (_NUMERAL _0) + (_COND (_LESS _M _N) (_NUMERAL _0) + (_SUC (_DIV (_SUB _M _N) _N))); + (* MOD *) _MOD _M _N === + _COND (_N === _NUMERAL _0) _M + (_COND (_LESS _M _N) _M + (_MOD (_SUB _M _N) _N)); + (* LESS *) _LESS _M (_NUMERAL _0) === _FALSE; + (* LESS *) _LESS (_NUMERAL _0) (_SUC _N) === _TRUE; + (* LESS *) _LESS (_SUC _M) (_SUC _N) === _LESS _M _N; + (* EQ *) (_NUMERAL _0 === _NUMERAL _0) === _TRUE; + (* EQ *) (_NUMERAL _0 === _SUC _N) === _FALSE; + (* EQ *) (_SUC _M === _NUMERAL _0) === _FALSE; + (* EQ *) (_SUC _M === _SUC _N) === (_M === _N); + (* CEXP_ADD *) _CEXP_ADD (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_ADD _M _N); + (* CEXP_ADD *) _CEXP_ADD (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M; + (* CEXP_ADD *) _CEXP_ADD (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM _N; + (* CEXP_ADD *) _CEXP_ADD (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_SUB *) _CEXP_SUB (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_SUB _M _N); + (* CEXP_SUB *) _CEXP_SUB (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M; + (* CEXP_SUB *) _CEXP_SUB (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_SUB *) _CEXP_SUB (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_MUL *) _CEXP_MUL (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_MUL _M _N); + (* CEXP_MUL *) _CEXP_MUL (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_MUL *) _CEXP_MUL (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_MUL *) _CEXP_MUL (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_DIV *) _CEXP_DIV (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_DIV _M _N); + (* CEXP_DIV *) _CEXP_DIV (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_DIV *) _CEXP_DIV (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_DIV *) _CEXP_DIV (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_MOD *) _CEXP_MOD (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_MOD _M _N); + (* CEXP_MOD *) _CEXP_MOD (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M; + (* CEXP_MOD *) _CEXP_MOD (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_MOD *) _CEXP_MOD (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_LESS *) _CEXP_LESS (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_COND (_LESS _M _N) (_SUC (_NUMERAL _0)) + (_NUMERAL _0)); + (* CEXP_LESS *) _CEXP_LESS (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_LESS *) _CEXP_LESS (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_LESS *) _CEXP_LESS (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_IF *) _CEXP_IF (_CEXP_NUM (_SUC _M)) _P1 _Q1 === _P1; + (* CEXP_IF *) _CEXP_IF (_CEXP_PAIR _P2 _Q2) _P1 _Q1 === _P1; + (* CEXP_IF *) _CEXP_IF (_CEXP_NUM (_NUMERAL _0)) _P1 _Q1 === _Q1; + (* CEXP_FST *) _CEXP_FST (_CEXP_PAIR _P1 _Q1) === _P1; + (* CEXP_FST *) _CEXP_FST (_CEXP_NUM _M) === _CEXP_NUM (_NUMERAL _0); + (* CEXP_SND *) _CEXP_SND (_CEXP_PAIR _P1 _Q1) === _Q1; + (* CEXP_SND *) _CEXP_SND (_CEXP_NUM _M) === _CEXP_NUM (_NUMERAL _0); + (* CEXP_ISPAIR*) _CEXP_ISPAIR (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_SUC (_NUMERAL _0)); + (* CEXP_ISPAIR*) _CEXP_ISPAIR (_CEXP_NUM _M) === + _CEXP_NUM (_NUMERAL _0); + (* CEXP_EQ *) _CEXP_EQ _P1 _Q1 === + _CEXP_NUM (_COND (_P1 === _Q1) + (_SUC (_NUMERAL _0)) + (_NUMERAL _0)); + (* PAIR_EQ1 *) (_CEXP_PAIR _P1 _Q1 === _CEXP_PAIR _P2 _Q2) === + (_IF (_P1 === _P2) (_Q1 === _Q2) _FALSE); + (* PAIR_EQ2 *) (_CEXP_NUM _M === _CEXP_NUM _N) === (_M === _N); + (* PAIR_EQ3 *) (_CEXP_NUM _M === _CEXP_PAIR _P1 _Q1) === _FALSE; + (* PAIR_EQ4 *) (_CEXP_PAIR _P1 _Q1 === _CEXP_NUM _N) === _FALSE; + (* LET *) (_LET _F _P1 === Comb _F _P1) + ] +End + +Theorem compute_thms_def = SIMP_RULE list_ss [] compute_thms_def; + +Definition compute_init_def: + compute_init ths ⇔ ths = compute_thms +End + +(* ------------------------------------------------------------------------- + * compute_add + * ------------------------------------------------------------------------- *) + +Definition compute_add_def: + compute_add ths tm = + if ¬ (compute_init ths) then + failwith «compute_add: wrong theorems provided for initialization» + else + do (l,r) <- dest_binary _ADD_TM tm; + x <- dest_numeral l; + y <- dest_numeral r; + res <<- num2bit (x + y); + c <- mk_eq (tm,_NUMERAL res); + return (Sequent [] c) + od ++ failwith «compute_add» +End + +(* ------------------------------------------------------------------------- + * compute + * ------------------------------------------------------------------------- *) + +Definition const_list_def: + const_list (Var n) = [] ∧ + const_list (Num n) = [] ∧ + const_list (Pair x y) = const_list x ++ const_list y ∧ + const_list (Uop uop x) = const_list x ∧ + const_list (Binop bop x y) = const_list x ++ const_list y ∧ + const_list (If x y z) = const_list x ++ const_list y ++ const_list z ∧ + const_list (Let s x y) = const_list x ++ const_list y ∧ + const_list (App s xs) = (s,LENGTH xs)::FLAT (MAP const_list xs) +Termination + wf_rel_tac ‘measure compute_exp_size’ +End + +Definition var_list_def: + var_list (Var n) = [n] ∧ + var_list (Num n) = [] ∧ + var_list (Pair x y) = var_list x ++ var_list y ∧ + var_list (Uop uop x) = var_list x ∧ + var_list (Binop bop x y) = var_list x ++ var_list y ∧ + var_list (If x y z) = var_list x ++ var_list y ++ var_list z ∧ + var_list (Let s x y) = var_list x ++ FILTER (λn. n ≠ s) (var_list y) ∧ + var_list (App s xs) = FLAT (MAP var_list xs) +Termination + wf_rel_tac ‘measure compute_exp_size’ +End + +(* A valid equation is: + * [] |- const var1 ... varN = expr + * where: + * - var1 ... varN all have type Cexp + * - expr contains only the variables var1 ... varN, and has type Cexp + *) + +Definition check_var_def: + check_var (Var s ty) = + (if ty = Cexp then return s else + failwith («Kernel.compute: ill-typed variable: » ^ s)) ∧ + check_var _ = + failwith «Kernel.compute: non-variable argument on lhs of equation» +End + +Definition check_eqn_def: + check_eqn (Sequent h c) = + do + if h = [] then return () else + failwith «Kernel.compute: non-empty hypotheses in equation»; + (ls,r) <- dest_eq c; + (f,vs) <- case list_dest_comb [] ls of + | f::vs => + if ALL_DISTINCT vs then return (f,vs) + else failwith «Kernel.compute: variables not distinct» + | _ => failwith «»; + (nm,ty) <- dest_const f ++ + failwith «Kernel.compute: not a constant being applied on lhs»; + args <- map check_var vs; + case dest_cexp r of + | NONE => failwith «Kernel.compute: rhs is not a cexp» + | SOME cv => + do + if EVERY (λv. MEM v args) (var_list cv) then return () else + failwith «Kernel.compute: rhs contains free variable»; + return (nm,args,cv) + od + od +End + +Definition compute_default_clock: + compute_default_clock = 1000000000 +End + +Definition check_consts_def: + check_consts ars fn rhs = + if EVERY (λ(c,n). MEM (c,n) ars) (const_list rhs) then return () else + failwith («Kernel.compute: rhs of » ^ fn ^ « has a constant » ^ + «with no equation associated to it.») +End + +Definition check_cexp_closed_def: + check_cexp_closed bvs (Var n) = MEM n bvs ∧ + check_cexp_closed bvs (Num n) = T ∧ + check_cexp_closed bvs (Pair p q) = + EVERY (check_cexp_closed bvs) [p;q] ∧ + check_cexp_closed bvs (Uop uop p) = + check_cexp_closed bvs p ∧ + check_cexp_closed bvs (Binop bop p q) = + EVERY (check_cexp_closed bvs) [p;q] ∧ + check_cexp_closed bvs (If p q r) = + EVERY (check_cexp_closed bvs) [p;q;r] ∧ + check_cexp_closed bvs (Let s p q) = + (check_cexp_closed bvs p ∧ check_cexp_closed (s::bvs) q) ∧ + check_cexp_closed bvs (App f cs) = + EVERY (check_cexp_closed bvs) cs +Termination + wf_rel_tac ‘measure (compute_exp_size o SND)’ \\ rw [] \\ gs [] +End + +Definition compute_def: + compute (ths,ceqs) tm = + flip handle_Clash (λe. failwith «impossible» ) $ + if ¬compute_init ths then + failwith «Kernel.compute: wrong theorems provided for initialization» + else + case dest_cexp tm of + | NONE => failwith «Kernel.compute: term is not a compute_exp» + | SOME cexp => + do + if check_cexp_closed [] cexp then return () else + failwith «Kernel.compute: free variables in starting expression»; + ceqs <- map check_eqn ceqs; + if ALL_DISTINCT (MAP FST ceqs) then return () else + failwith «Kernel.compute: non-distinct function names in equations»; + ars <<- MAP (λ(f,(n,r)). (f,LENGTH n)) ceqs; + check_consts ars «starting cexpr» cexp; + map (λ(f,(n,r)). check_consts ars f r) ceqs; + res <- exec (build_funs ceqs) [] compute_default_clock (to_ce ceqs [] cexp); + c <- mk_eq (tm, cv2term res); + return (Sequent [] c) + od +End + +val _ = export_theory (); diff --git a/candle/prover/compute/compute_evalProofScript.sml b/candle/prover/compute/compute_evalProofScript.sml new file mode 100644 index 0000000000..570633b14a --- /dev/null +++ b/candle/prover/compute/compute_evalProofScript.sml @@ -0,0 +1,1777 @@ +(* + Proofs about the interpreter function for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory; +open compute_evalTheory compute_syntaxTheory compute_syntaxProofTheory; +open ml_monadBaseTheory ml_monadBaseLib; + +val _ = new_theory "compute_evalProof"; + +val _ = numLib.prefer_num (); + +fun SIMPR ths = SIMP_RULE (srw_ss()) ths; +fun SIMPC ths = SIMP_CONV (srw_ss()) ths; + +Theorem do_fst_thm: + do_fst p s = (res, s') ⇒ + s = s' ∧ + ∃q. res = M_success q ∧ cexp_consts q ⊆ cexp_consts p +Proof + Cases_on ‘p’ \\ rw [do_fst_def, cexp_consts_def, st_ex_return_def] +QED + +Theorem do_snd_thm: + do_snd p s = (res, s') ⇒ + s = s' ∧ + ∃q. res = M_success q ∧ cexp_consts q ⊆ cexp_consts p +Proof + Cases_on ‘p’ \\ rw [do_snd_def, cexp_consts_def, st_ex_return_def] +QED + +Theorem do_ispair_thm: + do_ispair p s = (res, s') ⇒ + s = s' ∧ + ∃q. res = M_success q ∧ cexp_consts q ⊆ cexp_consts p +Proof + Cases_on ‘p’ \\ rw [do_ispair_def, cexp_consts_def, st_ex_return_def] +QED + +Theorem term_ok_FOLDL_Comb: + ∀tms tm. + term_ok sig (FOLDL Comb tm tms) ⇒ + term_ok sig tm ∧ + EVERY (term_ok sig) tms +Proof + Induct \\ rw [term_ok_def] + \\ first_x_assum drule \\ rw [term_ok_def] +QED + +Theorem subst_term_ok: + ∀env cv. + term_ok ctxt (cexp2term cv) ∧ + EVERY (term_ok ctxt o cexp2term) (MAP SND env) ⇒ + term_ok ctxt (cexp2term (subst env cv)) +Proof + ho_match_mp_tac subst_ind \\ rw [] + >~ [‘Var _’] >- ( + gs [subst_def, cexp2term_def] + \\ CASE_TAC \\ imp_res_tac ALOOKUP_MEM + \\ gvs [cexp2term_def, EVERY_MEM, MEM_MAP, PULL_EXISTS, EXISTS_PROD, + term_ok_def, SF SFY_ss]) + \\ gs [subst_def, cexp2term_def, EVERY_MEM, MEM_MAP, EXISTS_PROD, PULL_EXISTS, + term_ok_def, SF SFY_ss] + >~ [‘uop2term uop _’] >- ( + Cases_on ‘uop’ + \\ gs [subst_def, cexp2term_def, EVERY_MEM, MEM_MAP, EXISTS_PROD, + uop2term_def, PULL_EXISTS, term_ok_def, SF SFY_ss]) + >~ [‘bop2term bop _ _’] >- ( + Cases_on ‘bop’ + \\ gs [subst_def, cexp2term_def, EVERY_MEM, MEM_MAP, EXISTS_PROD, + bop2term_def, PULL_EXISTS, term_ok_def, SF SFY_ss]) + >~ [‘FILTER _ _’] >- ( + last_x_assum irule + \\ rw [MEM_FILTER] + \\ gs [SF SFY_ss]) + \\ ‘∀tm tms. + term_ok ctxt tm ∧ + tm has_type (app_type (LENGTH tms)) ∧ + EVERY (term_ok ctxt) tms ∧ + EVERY (λtm. tm has_type Cexp) tms ⇒ + term_ok ctxt (FOLDL Comb tm tms)’ + suffices_by ( + disch_then irule + \\ drule_then strip_assume_tac term_ok_FOLDL_Comb + \\ gs [EVERY_MAP, EVERY_MEM, has_type_rules, SF SFY_ss]) + \\ Induct_on ‘tms’ \\ rw [] \\ gs [] + \\ first_x_assum irule + \\ gs [term_ok_def, term_ok_welltyped, SF SFY_ss] + \\ imp_res_tac WELLTYPED_LEMMA + \\ gs [has_type_rules, app_type, SF SFY_ss] +QED + +Theorem do_arith_value: + ∀opn x y s z s'. + do_arith opn x y s = (M_success z, s') ⇒ cexp_value z +Proof + ho_match_mp_tac do_arith_ind \\ rw [do_arith_def, st_ex_return_def] \\ fs [] +QED + +Theorem do_reln_value: + ∀opn x y s z s'. + do_reln opn x y s = (M_success z, s') ⇒ cexp_value z +Proof + ho_match_mp_tac do_reln_ind \\ rw [do_reln_def, st_ex_return_def] \\ fs [] +QED + +Theorem do_eq_value: + do_eq (x:compute_exp) y (s:'a) = (M_success z, s') ⇒ cexp_value z +Proof + rw [do_eq_def, st_ex_return_def] \\ fs [] +QED + +Theorem do_binop_value: + ∀bop x y z s s'. + do_binop bop x y s = (M_success z, s') ⇒ cexp_value z +Proof + Cases \\ rw [do_binop_def] + \\ gs [do_arith_value, do_reln_value, do_eq_value, SF SFY_ss] +QED + +Theorem compute_eval_value: + (∀ck ceqs cv s x s'. + compute_eval ck ceqs cv s = (M_success x, s') ⇒ cexp_value x) ∧ + (∀ck ceqs cvs s xs s'. + compute_eval_list ck ceqs cvs s = (M_success xs, s') ⇒ EVERY cexp_value xs) +Proof + ho_match_mp_tac compute_eval_ind \\ rw [] + \\ gvs [compute_eval_def, raise_Failure_def, st_ex_return_def] + \\ qpat_x_assum ‘_ = (M_success _, _)’ mp_tac + >- ((* Pair *) + simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs [st_ex_return_def] + \\ rw [] \\ fs [SF SFY_ss]) + >- ((* Uop *) + simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC \\ gs [] \\ TOP_CASE_TAC \\ gs [] \\ rw [] + \\ first_x_assum (drule_then assume_tac) \\ gs [] + \\ rename [‘do_uop p’] + \\ Cases_on ‘p’ \\ gvs [do_uop_def] + \\ rename [‘_ a r = (M_success x,_)’] + \\ Cases_on ‘a’ \\ gs [do_fst_def, do_snd_def, do_ispair_def, + st_ex_return_def]) + >- ((* Binop *) + simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ rw [] \\ drule do_binop_value \\ rw []) + >- ((* App *) + IF_CASES_TAC \\ gs [] + \\ simp [option_def, Once st_ex_bind_def, st_ex_return_def, + raise_Failure_def] + \\ CASE_TAC \\ gs [] \\ pairarg_tac \\ gvs [] + \\ simp [check_def, raise_Failure_def, st_ex_return_def, + st_ex_ignore_bind_def] + \\ IF_CASES_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs [] \\ rw [] + \\ last_x_assum irule + \\ first_x_assum (irule_at Any)) + >- ((* If *) + simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC \\ gs [] \\ TOP_CASE_TAC \\ gs [] + \\ TOP_CASE_TAC \\ gs [SF SFY_ss] + \\ TOP_CASE_TAC \\ gs [SF SFY_ss]) + >- ((* Let *) + IF_CASES_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC \\ gs [] \\ TOP_CASE_TAC \\ gs [] + \\ rw [] \\ gs [SF SFY_ss]) + >- ((* List *) + simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC \\ gs [] \\ TOP_CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] + \\ TOP_CASE_TAC \\ TOP_CASE_TAC \\ rw [] \\ gs [SF SFY_ss]) +QED + +Theorem dest_binary_thm: + STATE ctxt s ∧ + TERM ctxt tm ∧ + TERM ctxt tm' ⇒ + dest_binary tm' tm s = (res,s') ⇒ + s' = s ∧ + ∀l r. res = M_success (l,r) ⇒ + TERM ctxt l ∧ TERM ctxt r ∧ + tm = Comb (Comb tm' l) r +Proof + simp [dest_binary_def, raise_Failure_def, st_ex_return_def] + \\ strip_tac + \\ rpt CASE_TAC \\ gs [] + \\ rw [] \\ gs [TERM_def, term_ok_def] +QED + +Theorem dest_numeral_thm: + STATE ctxt s ∧ + TERM ctxt tm ⇒ + dest_numeral tm s = (res,s') ⇒ + s' = s ∧ + ∀n. res = M_success n ⇒ + (numeral_thy_ok (thyof ctxt) ⇒ typeof tm = Num) ∧ + ∃tm'. tm = _NUMERAL tm' ∧ dest_num tm' = SOME n +Proof + simp [dest_numeral_def, raise_Failure_def, st_ex_return_def] + \\ strip_tac + \\ rpt CASE_TAC \\ gs [] + \\ rw [SF SFY_ss] +QED + +Theorem num2bit_thm: + numeral_thy_ok (thyof ctxt) ⇒ + TERM ctxt (num2bit x) +Proof + strip_tac \\ qid_spec_tac ‘x’ + \\ drule_then strip_assume_tac numeral_thy_ok_terms_ok + \\ ho_match_mp_tac num2bit_ind \\ rw [] + \\ gs [numeral_thy_ok_def] + \\ rw [Once num2bit_def] \\ gs [] + \\ fs [TERM_def] \\ simp [Once term_ok_def] +QED + +Theorem dest_num_num2bit: + numeral_thy_ok thy ⇒ + ∀x y. + dest_num x = SOME y ⇒ + (thy,[]) |- num2bit y === x +Proof + strip_tac + \\ drule_then strip_assume_tac numeral_thy_ok_terms_ok + \\ ‘theory_ok thy’ + by fs [numeral_thy_ok_def] + \\ ho_match_mp_tac dest_num_ind \\ rw [] + \\ qpat_x_assum ‘dest_num _ = _’ mp_tac + \\ simp [Once dest_num_def] + \\ rw [CaseEqs ["term", "option", "bool"]] + \\ simp [Once num2bit_def, proves_REFL] \\ gs [] + \\ rw [] \\ simp [MK_COMB_simple, proves_REFL] + \\ gs [Once num2bit_def] + \\ irule trans_equation_simple + \\ qexists_tac ‘_BIT0 _0’ + \\ simp [sym_equation, BIT0_0, numeral_thy_ok_def] + \\ irule MK_COMB_simple \\ simp [proves_REFL] +QED + +Theorem num2bit_dest_numeral: + dest_numeral (_NUMERAL x) s = (M_success y, s') ∧ + numeral_thy_ok (thyof s.the_context) ⇒ + s = s' ∧ (thyof s.the_context,[]) |- num2bit y === x +Proof + simp [dest_numeral_def, st_ex_return_def, raise_Failure_def] + \\ CASE_TAC \\ gs [] \\ rw [] + \\ drule_all dest_num_num2bit \\ rw [] +QED + +Theorem cexp2term_dest_numeral_opt: + dest_numeral_opt x = SOME y ∧ + compute_thy_ok thy ⇒ + (thy,[]) |- cexp2term (Num y) === _CEXP_NUM x +Proof + simp [dest_numeral_opt_def] + \\ CASE_TAC \\ gs [] + \\ TOP_CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs [] \\ rw [] + \\ ‘numeral_thy_ok thy’ + by gs [compute_thy_ok_def] + \\ drule_all dest_num_num2bit \\ rw [cexp2term_def] + \\ drule_then assume_tac num2bit_term_ok + \\ irule replaceR2 \\ fs [] + \\ irule_at Any sym_equation + \\ irule_at Any NUMERAL_eqn + \\ simp [compute_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) t0 ∧ t0 has_type Num’ + by (drule proves_term_ok + \\ fs [equation_def, term_ok_def, numeral_thy_ok_terms_ok] + \\ rw [] \\ fs [WELLTYPED]) + \\ simp [term_ok_welltyped, WELLTYPED_LEMMA, Once term_ok_def, + welltyped_def, numeral_thy_ok_terms_ok, SF SFY_ss] + \\ irule MK_COMB_simple + \\ simp [proves_REFL, term_ok_welltyped, WELLTYPED_LEMMA, Once term_ok_def, + welltyped_def, compute_thy_ok_terms_ok, SF SFY_ss] + \\ irule trans_equation_simple + \\ irule_at Any sym_equation + \\ first_x_assum (irule_at Any) + \\ rw [NUMERAL_eqn, sym_equation] +QED + +Theorem dest_cexp_thm: + compute_thy_ok thy ⇒ + ∀tm cv. + dest_cexp tm = SOME cv ⇒ + term_ok (sigof thy) tm ⇒ + (thy,[]) |- cexp2term cv === tm ∧ + typeof tm = Cexp +Proof + strip_tac + \\ ho_match_mp_tac dest_cexp_ind + \\ ntac 3 strip_tac \\ simp [Once dest_cexp_def] + \\ TOP_CASE_TAC + \\ TOP_CASE_TAC + >- ((* variable *) + fs [CaseEqs ["list", "option"]] \\ rw [] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ fs [cexp2term_def, proves_REFL, term_ok_def, SF SFY_ss]) + \\ TOP_CASE_TAC + >- ((* LET *) + fs [CaseEqs ["term", "list", "option"], PULL_EXISTS] + \\ rpt gen_tac \\ ntac 2 strip_tac \\ gvs [] + \\ simp [cexp2term_def] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ ‘is_std_sig (sigof thy)’ + by (irule theory_ok_sig \\ gs []) + \\ gs [term_ok_clauses] + \\ irule MK_COMB_simple \\ simp [] + \\ irule MK_COMB_simple \\ simp [proves_REFL] + \\ irule proves_ABS \\ simp []) + \\ TOP_CASE_TAC + >- ((* 0-ary *) + rw [mapOption_def, app_type] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ gvs [cexp2term_def, cexp_consts_def, app_type, proves_REFL]) + \\ TOP_CASE_TAC + >- ((* unary: num, uop or app *) + fs [CaseEqs ["list", "option", "bool"]] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ rw [] \\ fs [] + \\ gvs [cexp2term_dest_numeral_opt] \\ gvs [cexp2term_def, uop2term_def] + \\ rename [‘term_ok (sigof thy) tm ⇒ _’] + \\ ‘term_ok (sigof thy) tm’ + by fs [term_ok_def] + \\ gvs [app_type_def] + \\ irule MK_COMB_simple \\ simp [] + \\ irule proves_REFL \\ fs [term_ok_def, SF SFY_ss]) + \\ TOP_CASE_TAC + >- ( + simp [mapOption_def, CaseEq "option"]) + \\ TOP_CASE_TAC + >- ((* binary: binop, pair, app *) + simp [mapOption_def, CaseEq "option", PULL_EXISTS] + \\ rename [‘MAP _ xs = [x1; SOME x]’] \\ Cases_on ‘x1’ \\ gs [] + \\ fs [CaseEqs ["list", "option", "bool"]] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ Cases_on ‘xs’ \\ gvs [] + \\ rw [] \\ fs [] + \\ rename [‘term_ok _ (Comb (Comb _ x) y)’] + \\ ‘term_ok (sigof thy) x ∧ term_ok (sigof thy) y’ + by fs [term_ok_def] + \\ gvs [cexp2term_def, bop2term_def, MK_COMB_simple, proves_REFL, + compute_thy_ok_terms_ok] + \\ simp [app_type_def, numeralTheory.numeral_funpow] + \\ irule MK_COMB_simple \\ simp [] + \\ irule MK_COMB_simple \\ simp [] + \\ irule proves_REFL + \\ fs [term_ok_def, SF SFY_ss]) + \\ TOP_CASE_TAC + >- ( + simp [mapOption_def, CaseEq "option"]) + \\ TOP_CASE_TAC + >- ((* ternary: if *) + simp [mapOption_def, CaseEq "option", PULL_EXISTS] + \\ rename [‘MAP _ xs = [x1; SOME x; SOME y]’] \\ Cases_on ‘x1’ \\ gs [] + \\ fs [CaseEqs ["list", "option", "bool"]] + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ Cases_on ‘xs’ \\ gvs [] + \\ rename [‘MAP _ xs = _’] \\ Cases_on ‘xs’ \\ gvs [] + \\ rw [] \\ fs [] + \\ rename [‘term_ok _ (Comb (Comb (Comb _ x) y) z)’] + \\ ‘term_ok (sigof thy) x ∧ term_ok (sigof thy) y ∧ term_ok (sigof thy) z’ + by fs [term_ok_def] + \\ gvs [cexp2term_def, app_type_def, numeralTheory.numeral_funpow] + \\ irule MK_COMB_simple \\ simp [] + \\ irule MK_COMB_simple \\ simp [] + \\ irule MK_COMB_simple + \\ fs [compute_thy_ok_terms_ok, term_ok_def, proves_REFL, SF SFY_ss]) + (* n-ary: app *) + \\ fs [CaseEqs ["list", "option", "bool"], SF ETA_ss] + \\ strip_tac \\ gvs [] + \\ qpat_x_assum ‘∀x y z w. _ ∧ (_ = «LET» ∧ _) ∧ _ ⇒ _’ kall_tac + \\ qpat_x_assum ‘_ = «LET» ⇒ _’ kall_tac + \\ qmatch_asmsub_abbrev_tac ‘mapOption _ tms’ + \\ rename [‘tms = a::b::c::d::e’] + \\ ‘∀tm. tm = a ∨ tm = b ∨ tm = c ∨ tm = d ∨ MEM tm e ⇔ MEM tm tms’ + by gs [Abbr ‘tms’] + \\ fs [] + \\ ntac 2 (pop_assum kall_tac) + \\ strip_tac + \\ drule_then strip_assume_tac list_dest_comb_folds_back \\ gvs [] + \\ simp [cexp2term_def, FOLDL_MAP] + \\ rename [‘mapOption I (MAP dest_cexp tms)’] + \\ ‘∀tm tm'. + typeof tm = app_type (LENGTH tms) ∧ + term_ok (sigof thy) tm ∧ + (thy,[]) |- tm === tm' ⇒ + (thy,[]) |- FOLDL (λx y. Comb x (cexp2term y)) tm' cvs === + FOLDL Comb tm tms ∧ + typeof (FOLDL Comb tm tms) = Cexp’ + suffices_by ( + disch_then irule + \\ drule_then assume_tac mapOption_LENGTH \\ gs [] + \\ irule_at Any proves_REFL \\ fs [] + \\ drule term_ok_FOLDL_Comb \\ rw []) + \\ qpat_x_assum ‘list_dest_comb _ _ = _’ kall_tac + \\ dxrule_then strip_assume_tac term_ok_FOLDL_Comb + \\ qpat_x_assum ‘term_ok _ (Const _ _)’ kall_tac + \\ ntac 3 (pop_assum mp_tac) + \\ qid_spec_tac ‘tms’ + \\ qid_spec_tac ‘cvs’ + \\ Induct \\ Cases_on ‘tms’ \\ simp [mapOption_def, app_type, proves_REFL, + CaseEq "option", Once sym_equation] + \\ ntac 7 strip_tac + \\ rename [‘mapOption I (MAP dest_cexp tms)’] + \\ first_x_assum (qspec_then ‘tms’ assume_tac) + \\ gs [SF SFY_ss] \\ first_x_assum irule \\ gs [SF DNF_ss] + \\ conj_asm1_tac + >- ( + qpat_x_assum ‘_ |- cexp2term _ === _’ assume_tac + \\ drule proves_term_ok + \\ simp [term_ok_def, term_ok_welltyped, equation_def, SF SFY_ss]) + \\ irule MK_COMB_simple + \\ pop_assum mp_tac + \\ simp [proves_term_ok, term_ok_welltyped, term_ok_def, sym_equation] +QED + +Theorem ALOOKUP_MAP_3[local]: + ∀xs n. + (∀x y. f x = f y ⇒ x = y) ⇒ + ALOOKUP (MAP (λ(k,v). (f k, g v)) xs) (f n) = + ALOOKUP (MAP (λ(k,v). (k, g v)) xs) n +Proof + Induct \\ simp [] + \\ Cases \\ rw [] \\ gs [] +QED + +Theorem cexp_value_closed: + ∀v. cexp_value v ⇒ cexp_vars v = {} +Proof + ho_match_mp_tac cexp_value_ind + \\ rw [cexp_value_def, cexp_vars_def] +QED + +Theorem closed_subst: + ∀env v. + EVERY cexp_value (MAP SND env) ⇒ + cexp_vars (subst env v) = cexp_vars v DIFF set (MAP FST env) +Proof + ho_match_mp_tac subst_ind \\ simp [] + \\ rpt conj_tac \\ simp [subst_def, cexp_vars_def] + >- ( + rw [] \\ CASE_TAC \\ gs [ALOOKUP_NONE, cexp_vars_def] + \\ drule_then assume_tac ALOOKUP_MEM + \\ gs [MEM_MAP, EXISTS_PROD, PULL_EXISTS, EVERY_MEM, SF SFY_ss] + \\ irule cexp_value_closed \\ gs [SF SFY_ss]) + >- ( + gs [DIFF_DEF, UNION_DEF, EXTENSION] + \\ rw [EQ_IMP_THM] \\ gs []) + >~ [‘FILTER _ _’] >- ( + rw [] \\ gs [EVERY_MAP, EVERY_FILTER, LAMBDA_PROD] + \\ qpat_x_assum ‘_ ⇒ _’ mp_tac + \\ impl_tac >- gs [EVERY_MEM, FORALL_PROD, SF DNF_ss, SF SFY_ss] + \\ rw [] + \\ gs [EXTENSION, MEM_MAP, EXISTS_PROD, FORALL_PROD, PULL_EXISTS, + MEM_FILTER] + \\ metis_tac []) + \\ gs [BIGUNION, EXTENSION, PULL_EXISTS, SF ETA_ss, MEM_MAP, EXISTS_PROD, + PULL_EXISTS, EVERY_MEM, FORALL_PROD] + \\ rw [EQ_IMP_THM] \\ gs [] \\ metis_tac [] +QED + +Theorem closed_subst': + EVERY cexp_value (MAP SND env) ∧ + cexp_vars v ⊆ set (MAP FST env) ⇒ + cexp_vars (subst env v) = {} +Proof + rw [] + \\ drule_all_then (qspec_then ‘v’ SUBST1_TAC) closed_subst + \\ gs [DIFF_DEF, SUBSET_DEF, EXTENSION, DISJ_EQ_IMP] +QED + +Theorem VSUBST_FOLDL_Comb_push: + ∀tms t. + FOLDL Comb (VSUBST is t) (MAP (VSUBST is) tms) = + VSUBST is (FOLDL Comb t tms) +Proof + Induct \\ rw [] \\ gs [] + \\ simp [GSYM VSUBST_thm] +QED + +Theorem VSUBST_bop2term[simp]: + VSUBST is (bop2term bop x y) = bop2term bop (VSUBST is x) (VSUBST is y) +Proof + Cases_on ‘bop’ \\ gs [bop2term_def, VSUBST_thm] +QED + +Theorem VSUBST_uop2term[simp]: + VSUBST is (uop2term uop x) = uop2term uop (VSUBST is x) +Proof + Cases_on ‘uop’ \\ gs [uop2term_def, VSUBST_thm] +QED + + +Theorem VFREE_IN_FOLDL: + ∀ts v t. + VFREE_IN v (FOLDL Comb t ts) ⇔ EXISTS (VFREE_IN v) ts ∨ VFREE_IN v t +Proof + Induct \\ simp [] \\ rw [] + \\ eq_tac \\ rw [] \\ gs [] +QED + +Theorem VFREE_IN_cexp_vars: + ∀v. cexp_vars v = {n | VFREE_IN (Var n Cexp) (cexp2term v) } +Proof + ho_match_mp_tac cexp2term_ind + \\ rw [cexp2term_def, cexp_vars_def] + >- ( + rw [EXTENSION] + \\ qid_spec_tac ‘n’ + \\ ho_match_mp_tac num2bit_ind \\ rw [] + \\ simp [Once num2bit_def] \\ rw [] \\ gs []) + >- ( + gs [EXTENSION, PULL_EXISTS, EQ_IMP_THM, SF DNF_ss, SF SFY_ss]) + >- ( + Cases_on ‘uop’ \\ gs [uop2term_def]) + >- ( + Cases_on ‘bop’ \\ gs [bop2term_def] + \\ gs [EXTENSION, PULL_EXISTS, EQ_IMP_THM, SF DNF_ss, SF SFY_ss]) + >- ( + gs [EXTENSION, PULL_EXISTS, EQ_IMP_THM, SF DNF_ss, SF SFY_ss]) + >- ( + gs [EXTENSION, DIFF_DEF, PULL_EXISTS, EQ_IMP_THM, SF DNF_ss, SF SFY_ss]) + >- ( + gs [VFREE_IN_FOLDL, EXISTS_MAP, BIGUNION, EXISTS_MEM, MEM_MAP, + PULL_EXISTS, EXTENSION] + \\ rw [EQ_IMP_THM] \\ gs [SF SFY_ss, SF DNF_ss] + \\ first_assum (irule_at Any) \\ gs [] + \\ qexists_tac ‘cexp_vars a’ \\ gs []) +QED + +Theorem subst_VSUBST: + ∀env x. + EVERY (λv. cexp_vars v = {}) (MAP SND env) ⇒ + cexp2term (subst env x) = + VSUBST (MAP (λ(s,v). (cexp2term v, Var s Cexp)) env) (cexp2term x) +Proof + ho_match_mp_tac subst_ind \\ rw [] + >~ [‘Var n’] >- ( + simp [subst_def, cexp2term_def, VSUBST_def, REV_ASSOCD_ALOOKUP, + MAP_MAP_o, combinTheory.o_DEF, LAMBDA_PROD] + \\ gvs [EVERY_MEM, cexp_vars_def] + \\ CASE_TAC \\ CASE_TAC + \\ imp_res_tac ALOOKUP_MEM + \\ gvs [ALOOKUP_NONE, cexp2term_def, MEM_MAP, EXISTS_PROD, PULL_EXISTS] + \\ Q.ISPECL_THEN [‘cexp2term’, ‘λs. Var s Cexp’] assume_tac + (GEN_ALL ALOOKUP_MAP_3) + \\ gs [ALOOKUP_MAP, SF SFY_ss]) + >~ [‘Let s x y’] >- ( + gs [cexp_vars_def, cexp2term_def, subst_def, VSUBST_thm] + \\ IF_CASES_TAC \\ gs [] + >- ( + ‘F’ suffices_by rw [] + \\ pop_assum mp_tac + \\ gs [o_DEF, LAMBDA_PROD, EVERY_FILTER, EVERY_MAP, EVERY_MEM, + FORALL_PROD] + \\ rw [] \\ first_x_assum (drule_then assume_tac) + \\ gs [VFREE_IN_cexp_vars, EXTENSION]) + \\ gs [FILTER_MAP, combinTheory.o_DEF, LAMBDA_PROD, EVERY_MAP, EVERY_FILTER, + EVERY_MEM, FORALL_PROD, SF SFY_ss]) + \\ gs [subst_def, cexp2term_def, VSUBST_def, cexp_vars_def, SF ETA_ss] + \\ gs [BIGUNION_SUBSET, MEM_MAP, PULL_EXISTS] + \\ simp [GSYM VSUBST_FOLDL_Comb_push] + \\ simp [VSUBST_thm] + \\ AP_TERM_TAC + \\ simp [MAP_MAP_o, o_DEF, LAMBDA_PROD, MAP_EQ_f] +QED + +Theorem MAP_subst_MAP_Var[local]: + ∀xs ys. + ALL_DISTINCT xs ∧ + LENGTH xs = LENGTH ys ⇒ + MAP (subst (ZIP(xs,ys))) (MAP Var xs) = ys +Proof + Induct \\ simp [] \\ Cases_on ‘ys’ \\ rw [subst_def] + \\ first_x_assum (drule_all_then assume_tac) + \\ gs [MAP_MAP_o, combinTheory.o_DEF, LIST_EQ_REWRITE, EL_MAP, + subst_def] + \\ rw [] \\ gs [MEM_EL] +QED + +(* TODO Move *) +Theorem SAFEDIV_0[simp]: + 0 SAFEDIV n = 0 +Proof + rw [SAFEDIV_def, ZERO_DIV] +QED + +Theorem NUMERAL_ONE[local]: + numeral_thy_ok thy ⇒ + (thy,[]) |- _NUMERAL (_SUC _0) === _SUC (_NUMERAL _0) +Proof + rw [] + \\ irule trans_equation_simple \\ irule_at Any NUMERAL_eqn + \\ irule_at Any MK_COMB_simple + \\ gs [numeral_thy_ok_terms_ok, proves_REFL, NUMERAL_eqn, sym_equation] +QED + +Theorem do_binop_thm: + compute_thy_ok thy ⇒ + term_ok (sigof thy) (cexp2term p) ∧ + term_ok (sigof thy) (cexp2term q) ∧ + (thy,[]) |- cexp2term p === cexp2term x ∧ cexp_value x ∧ + (thy,[]) |- cexp2term q === cexp2term y ∧ cexp_value y ∧ + do_binop bop x y s = (res, s') ⇒ + s' = s ∧ + ∃cv. res = M_success cv ∧ + (thy,[]) |- bop2term bop (cexp2term p) (cexp2term q) === cexp2term cv +Proof + ntac 2 strip_tac + \\ Cases_on ‘bop’ \\ gs [bop2term_def, do_binop_def, do_reln_def] + >~ [‘_CEXP_ADD _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_arith_def, st_ex_return_def, cexp2term_def] + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any NUMERAL_eqn \\ simp [num2bit_term_ok] + \\ irule replaceL2 \\ irule_at Any ADD_num2bit + \\ rw [CEXP_ADD_eqn1, sym_equation, num2bit_term_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_ADD_eqn2, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_ADD_eqn3, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [] \\ rw [CEXP_ADD_eqn4, compute_thy_ok_terms_ok]) + >~ [‘_CEXP_SUB _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_arith_def, st_ex_return_def, cexp2term_def] + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any NUMERAL_eqn \\ simp [num2bit_term_ok] + \\ irule replaceL2 \\ irule_at Any SUB_num2bit + \\ rw [CEXP_SUB_eqn1, sym_equation, num2bit_term_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_SUB_eqn2, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + num2bit_term_ok, NUMERAL_eqn]) + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_SUB_eqn3, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [] \\ rw [CEXP_SUB_eqn4, compute_thy_ok_terms_ok]) + >~ [‘_CEXP_MUL _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_arith_def, st_ex_return_def, cexp2term_def] + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any NUMERAL_eqn \\ simp [num2bit_term_ok] + \\ irule replaceL2 \\ irule_at Any MUL_num2bit + \\ rw [CEXP_MUL_eqn1, sym_equation, num2bit_term_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ simp [Once num2bit_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_MUL_eqn2, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ simp [Once num2bit_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_MUL_eqn3, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [] \\ rw [CEXP_MUL_eqn4, compute_thy_ok_terms_ok]) + >~ [‘_CEXP_DIV _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_arith_def, st_ex_return_def, cexp2term_def] + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any NUMERAL_eqn \\ simp [num2bit_term_ok] + \\ irule replaceL2 \\ irule_at Any DIV_num2bit + \\ rw [CEXP_DIV_eqn1, sym_equation, num2bit_term_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ simp [SAFEDIV_def, Once num2bit_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_DIV_eqn2, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ simp [Once num2bit_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_DIV_eqn3, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [] \\ rw [CEXP_DIV_eqn4, compute_thy_ok_terms_ok]) + >~ [‘_CEXP_MOD _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_arith_def, st_ex_return_def, cexp2term_def] + \\ ‘(thy,[]) |- cexp2term p === _CEXP_NUM (num2bit m)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ ‘(thy,[]) |- cexp2term q === _CEXP_NUM (num2bit n)’ + by (irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, proves_REFL, compute_thy_ok_terms_ok, + NUMERAL_eqn, num2bit_term_ok]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any NUMERAL_eqn \\ simp [num2bit_term_ok] + \\ irule replaceL2 \\ irule_at Any MOD_num2bit + \\ rw [CEXP_MOD_eqn1, sym_equation, num2bit_term_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ simp [SAFEMOD_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_MOD_eqn2, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ simp [SAFEMOD_def, Once num2bit_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ rw [CEXP_MOD_eqn3, num2bit_term_ok, compute_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_arith_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [] \\ rw [CEXP_MOD_eqn4, compute_thy_ok_terms_ok]) + >~ [‘_CEXP_LESS _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_reln_def, st_ex_return_def, cexp2term_def] + \\ qmatch_asmsub_abbrev_tac ‘_ |- cexp2term p === A’ + \\ qmatch_asmsub_abbrev_tac ‘_ |- cexp2term q === B’ + \\ ‘(thy,[]) |- _CEXP_NUM (_NUMERAL (num2bit (if m < n then 1 else 0))) + === _CEXP_LESS A B’ + suffices_by ( + rw [Abbr ‘A’, Abbr ‘B’] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [cexp2term_def, sym_equation]) + \\ unabbrev_all_tac + \\ irule replaceR2 \\ irule_at Any MK_COMB_simple + \\ resolve_then Any (irule_at Any) NUMERAL_eqn sym_equation + \\ irule_at Any proves_REFL + \\ simp [compute_thy_ok_terms_ok, num2bit_term_ok] + \\ irule replaceL1 \\ irule_at Any MK_COMB_simple + \\ resolve_then Any (irule_at Any) NUMERAL_eqn sym_equation + \\ irule_at Any proves_REFL + \\ simp [compute_thy_ok_terms_ok, num2bit_term_ok] + \\ irule trans_equation_simple \\ irule_at Any CEXP_LESS_eqn1 + \\ simp [num2bit_term_ok] + \\ irule MK_COMB_simple \\ simp [proves_REFL, compute_thy_ok_terms_ok] + \\ irule replaceL3 \\ irule_at Any bool2term_LESS_num2bit \\ simp [] + \\ irule replaceL1 \\ irule_at Any NUMERAL_ONE \\ gs [] + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any num2bit_num2term \\ simp [] + \\ once_rewrite_tac [ONE] + \\ IF_CASES_TAC \\ simp [bool2term_def, num2term_def] + \\ gs [sym_equation, COND_eqn, compute_thy_ok_terms_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_reln_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ rw [CEXP_LESS_eqn2, num2bit_term_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_reln_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ rw [CEXP_LESS_eqn3, num2bit_term_ok]) + \\ gvs [cexp2term_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_reln_def, st_ex_return_def] + \\ simp [Once num2bit_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ gs [CEXP_LESS_eqn4]) + >~ [‘_CEXP_EQ _ _’] >- ( + Cases_on ‘∃m. x = Num m’ \\ fs [] + >- ( + Cases_on ‘∃n. y = Num n’ \\ fs [] + >- ( + gvs [do_eq_def, st_ex_return_def, cexp2term_def] + \\ qmatch_asmsub_abbrev_tac ‘_ |- cexp2term p === A’ + \\ qmatch_asmsub_abbrev_tac ‘_ |- cexp2term q === B’ + \\ ‘(thy,[]) |- _CEXP_NUM (_NUMERAL (num2bit (if m = n then 1 else 0))) + === _CEXP_EQ A B’ + suffices_by ( + rw [Abbr ‘A’, Abbr ‘B’] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ fs [cexp2term_def, sym_equation]) + \\ unabbrev_all_tac + \\ irule replaceR2 \\ irule_at Any MK_COMB_simple + \\ resolve_then Any (irule_at Any) NUMERAL_eqn sym_equation + \\ irule_at Any proves_REFL + \\ simp [compute_thy_ok_terms_ok, num2bit_term_ok] + \\ irule replaceL1 \\ irule_at Any MK_COMB_simple + \\ resolve_then Any (irule_at Any) NUMERAL_eqn sym_equation + \\ irule_at Any proves_REFL + \\ simp [compute_thy_ok_terms_ok, num2bit_term_ok] + \\ irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn1 + \\ ‘theory_ok thy’ by fs [] + \\ ‘is_std_sig (sigof thy)’ + by gs [theory_ok_def] + \\ simp [num2bit_term_ok, compute_thy_ok_terms_ok, term_ok_clauses] + \\ simp [Ntimes has_type_cases 3] + \\ simp [Ntimes has_type_cases 3] + \\ irule MK_COMB_simple + \\ gs [compute_thy_ok_terms_ok, proves_REFL, welltyped_equation, + EQUATION_HAS_TYPE_BOOL, term_ok_welltyped, SF SFY_ss] + \\ simp [Once equation_def] + \\ resolve_then Any irule sym_equation replaceL3 + \\ irule_at Any CEXP_EQ_eqn3 \\ gs [num2bit_term_ok] + \\ irule replaceL3 + \\ irule_at Any bool2term_EQ_num2bit \\ simp [] + \\ irule replaceL1 \\ irule_at Any NUMERAL_ONE \\ gs [] + \\ resolve_then Any irule sym_equation replaceR2 + \\ irule_at Any num2bit_num2term \\ simp [] + \\ once_rewrite_tac [ONE] + \\ IF_CASES_TAC \\ simp [bool2term_def, num2term_def] + \\ gs [sym_equation, COND_eqn, compute_thy_ok_terms_ok]) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. y = Pair p1 q1’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_eq_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn1 + \\ ‘theory_ok thy’ by fs [] + \\ ‘is_std_sig (sigof thy)’ + by gs [theory_ok_def] + \\ gs [num2bit_term_ok, compute_thy_ok_terms_ok, term_ok_clauses] + \\ simp [Ntimes has_type_cases 3] + \\ simp [Ntimes has_type_cases 3] + \\ irule MK_COMB_simple + \\ gs [compute_thy_ok_terms_ok, proves_REFL, welltyped_equation, + EQUATION_HAS_TYPE_BOOL, term_ok_welltyped, SF SFY_ss] + \\ simp [Once equation_def] + \\ resolve_then Any irule sym_equation replaceL3 + \\ irule_at Any CEXP_EQ_eqn4 \\ gs [num2bit_term_ok] + \\ irule (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok]) + \\ Cases_on ‘∃n. y = Num n’ \\ gs [] + >- ( + gvs [cexp2term_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ gvs [cexp2term_def, do_eq_def, st_ex_return_def] + \\ ‘term_ok (sigof thy) (cexp2term p1) ∧ + term_ok (sigof thy) (cexp2term q1)’ + by (qpat_x_assum ‘_ |- _ === _CEXP_PAIR _ _’ assume_tac + \\ drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn1 + \\ ‘theory_ok thy’ by fs [] + \\ ‘is_std_sig (sigof thy)’ + by gs [theory_ok_def] + \\ gs [num2bit_term_ok, compute_thy_ok_terms_ok, term_ok_clauses] + \\ simp [Ntimes has_type_cases 3] + \\ simp [Ntimes has_type_cases 3] + \\ irule MK_COMB_simple + \\ gs [compute_thy_ok_terms_ok, proves_REFL, welltyped_equation, + EQUATION_HAS_TYPE_BOOL, term_ok_welltyped, SF SFY_ss] + \\ simp [Once equation_def] + \\ resolve_then Any irule sym_equation replaceL3 + \\ irule_at Any CEXP_EQ_eqn5 \\ gs [num2bit_term_ok] + \\ irule (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok]) + \\ gvs [cexp2term_def, st_ex_return_def] + \\ ‘cexp_value x’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p1 q1. x = Pair p1 q1’ + by (Cases_on ‘x’ \\ fs []) + \\ ‘cexp_value y’ + by rw [compute_eval_value, SF SFY_ss] + \\ ‘∃p2 q2. y = Pair p2 q2’ + by (Cases_on ‘y’ \\ fs []) + \\ gvs [cexp2term_def, do_eq_def, st_ex_return_def] + \\ ‘EVERY (term_ok (sigof thy) o cexp2term) [p1;q1;p2;q2]’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ resolve_then Any (irule_at Any) sym_equation replaceR2 + \\ irule_at Any MK_COMB_simple \\ irule_at Any num2bit_num2term + \\ irule_at Any proves_REFL \\ gs [numeral_thy_ok_terms_ok] + \\ irule sym_equation + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) + \\ irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn1 + \\ ‘theory_ok thy’ by fs [] + \\ ‘is_std_sig (sigof thy)’ + by gs [theory_ok_def] + \\ gs [num2bit_term_ok, compute_thy_ok_terms_ok, term_ok_clauses] + \\ simp [Ntimes has_type_cases 3] + \\ simp [Ntimes has_type_cases 3] + \\ irule MK_COMB_simple + \\ gs [compute_thy_ok_terms_ok, proves_REFL, welltyped_equation, + EQUATION_HAS_TYPE_BOOL, term_ok_welltyped, SF SFY_ss] + \\ simp [Once equation_def] + \\ resolve_then Any irule sym_equation replaceL3 + \\ irule_at Any CEXP_EQ_eqn2 \\ gs [num2bit_term_ok] + \\ irule replaceL3 + \\ qexists_tac ‘_IF (bool2term (p1 = p2)) (bool2term (q1 = q2)) _FALSE’ + \\ irule_at Any MK_COMB_simple \\ gs [] + \\ irule_at Any MK_COMB_simple \\ gs [] + \\ irule_at Any MK_COMB_simple \\ gs [] + \\ simp [proves_REFL, bool_thy_ok_terms_ok, bool2term_EQ_cexpterm] + \\ Cases_on ‘p1 = p2’ \\ Cases_on ‘q1 = q2’ \\ gs [bool2term_def] + \\ once_rewrite_tac [ONE] \\ simp [num2term_def] + \\ resolve_then Any irule sym_equation replaceL3 + \\ (irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL IF_eqn))) ORELSE + irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL IF_eqn)))) + \\ gs [bool_thy_ok_terms_ok, term_ok_clauses, has_type_rules] + \\ irule replaceL1 \\ irule_at Any NUMERAL_ONE \\ gs [] + \\ (irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) ORELSE + irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn)))) + \\ gs [numeral_thy_ok_terms_ok]) +QED + +Theorem do_uop_thm: + compute_thy_ok thy ⇒ + term_ok (sigof thy) (cexp2term p) ∧ + (thy,[]) |- cexp2term p === cexp2term x ∧ cexp_value x ∧ + do_uop uop x s = (res, s') ⇒ + s' = s ∧ + ∃cv. res = M_success cv ∧ + (thy,[]) |- uop2term uop (cexp2term p)=== cexp2term cv +Proof + ntac 2 strip_tac + \\ Cases_on ‘uop’ \\ gs [uop2term_def, do_uop_def] + >~ [‘_CEXP_FST p’] >- ( + drule_then strip_assume_tac do_fst_thm \\ gvs [] + \\ rename [‘do_fst p r = (M_success cv,_)’] + \\ drule_then assume_tac cexp_value_no_consts + \\ Cases_on ‘∃p1 q1. p = Pair p1 q1’ \\ gvs [] + >- ( + gvs [do_fst_def, st_ex_return_def, cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ gs [CEXP_FST_eqn1, cexp2term_term_ok, cexp_consts_def]) + \\ ‘cv = Num 0’ + by (Cases_on ‘p’ \\ gs [do_fst_def, st_ex_return_def]) + \\ ‘∃m. p = Num m’ + by (Cases_on ‘p’ \\ gs []) + \\ gvs [cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ irule CEXP_FST_eqn2 + \\ simp [Ntimes has_type_cases 3] + \\ gs [term_ok_def, compute_thy_ok_terms_ok, num2bit_term_ok]) + >~ [‘_CEXP_SND p’] >- ( + drule_then strip_assume_tac do_snd_thm \\ gvs [] + \\ rename [‘do_snd p r = (M_success cv,_)’] + \\ drule_then assume_tac cexp_value_no_consts + \\ Cases_on ‘∃p1 q1. p = Pair p1 q1’ \\ gvs [] + >- ( + gvs [do_snd_def, st_ex_return_def, cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ gs [CEXP_SND_eqn1, cexp2term_term_ok, cexp_consts_def]) + \\ ‘cv = Num 0’ + by (Cases_on ‘p’ \\ gs [do_snd_def, st_ex_return_def]) + \\ ‘∃m. p = Num m’ + by (Cases_on ‘p’ \\ gs []) + \\ gvs [cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ irule CEXP_SND_eqn2 + \\ simp [Ntimes has_type_cases 3] + \\ gs [term_ok_def, compute_thy_ok_terms_ok, num2bit_term_ok]) + >~ [‘_CEXP_ISPAIR p’] >- ( + drule_then strip_assume_tac do_ispair_thm \\ gvs [] + \\ rename [‘do_ispair p r = (M_success cv,_)’] + \\ drule_then assume_tac cexp_value_no_consts + \\ Cases_on ‘∃p1 q1. p = Pair p1 q1’ \\ gvs [] + >- ( + gvs [do_ispair_def, st_ex_return_def, cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ irule replaceR2 \\ qexists_tac ‘_NUMERAL (num2term 1)’ + \\ simp [MK_COMB_simple, proves_REFL, numeral_thy_ok_terms_ok, + num2bit_num2term, Once sym_equation] + \\ once_rewrite_tac [ONE] \\ simp [num2term_def] + \\ irule replaceL2 \\ qexists_tac ‘_SUC (_NUMERAL _0)’ + \\ resolve_then Any (irule_at Any) sym_equation replaceL2 + \\ irule_at Any NUMERAL_eqn \\ gs [numeral_thy_ok_terms_ok] + \\ irule_at Any sym_equation \\ irule_at Any NUMERAL_eqn + \\ gs [numeral_thy_ok_terms_ok, Once sym_equation, CEXP_ISPAIR_eqn1, + cexp2term_term_ok, cexp_consts_def]) + \\ ‘cv = Num 0’ + by (Cases_on ‘p’ \\ gs [do_ispair_def, st_ex_return_def]) + \\ ‘∃m. p = Num m’ + by (Cases_on ‘p’ \\ gs []) + \\ gvs [cexp2term_def] + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ simp [Once num2bit_def, SimpR “(===)”] + \\ irule CEXP_ISPAIR_eqn2 \\ gs [] + \\ gs [term_ok_def, compute_thy_ok_terms_ok, num2bit_term_ok]) +QED + +Theorem term_ok_bop2term: + term_ok sig (bop2term bop tm1 tm2) ⇒ + term_ok sig tm1 ∧ term_ok sig tm2 +Proof + Cases_on ‘bop’ \\ rw [term_ok_def, bop2term_def] +QED + +Theorem term_ok_uop2term: + term_ok sig (uop2term uop tm) ⇒ + term_ok sig tm +Proof + Cases_on ‘uop’ \\ rw [term_ok_def, uop2term_def] +QED + +Theorem compute_eval_list_map: + ∀cvs s. compute_eval_list ck eqs cvs s = map (compute_eval ck eqs) cvs s +Proof + Induct \\ rw [map_def, compute_eval_def, st_ex_return_def, st_ex_bind_def] +QED + +Theorem compute_thy_ok_is_std_sig: + compute_thy_ok thy ⇒ is_std_sig (sigof thy) +Proof + rw [] + \\ ‘theory_ok thy’ by gs [] + \\ gs [theory_ok_def] +QED + +Definition cexp_consts_ok_def: + cexp_consts_ok eqs (Var s) = T ∧ + cexp_consts_ok eqs (Num n) = T ∧ + cexp_consts_ok eqs (Pair p q) = + (cexp_consts_ok eqs p ∧ cexp_consts_ok eqs q) ∧ + cexp_consts_ok eqs (If p q r) = + (cexp_consts_ok eqs p ∧ cexp_consts_ok eqs q ∧ cexp_consts_ok eqs r) ∧ + cexp_consts_ok eqs (Uop uop p) = cexp_consts_ok eqs p ∧ + cexp_consts_ok eqs (Binop bop p q) = + (cexp_consts_ok eqs p ∧ cexp_consts_ok eqs q) ∧ + cexp_consts_ok eqs (Let s p q) = + (cexp_consts_ok eqs p ∧ cexp_consts_ok eqs q) ∧ + cexp_consts_ok eqs (App f cs) = + (MEM (f,LENGTH cs) (MAP (λ(f,n,x). (f,LENGTH n)) eqs) ∧ + EVERY (cexp_consts_ok eqs) cs) +Termination + wf_rel_tac ‘measure (compute_exp_size o SND)’ +End + +Theorem cexp_consts_ok_value: + ∀eqs cv. + cexp_value cv ⇒ + cexp_consts_ok eqs cv +Proof + ho_match_mp_tac cexp_consts_ok_ind \\ rw [] + \\ gs [cexp_consts_ok_def, cexp_consts_def] +QED + +Theorem cexp_consts_ok_subst: + ∀xs x. + cexp_consts_ok eqs x ∧ + EVERY (cexp_consts_ok eqs) (MAP SND xs) ⇒ + cexp_consts_ok eqs (subst xs x) +Proof + ho_match_mp_tac subst_ind \\ rw [] \\ gs [cexp_consts_ok_def, subst_def] + >- ( + gs [EVERY_MEM, MEM_MAP, EXISTS_PROD, PULL_EXISTS] + \\ CASE_TAC \\ gs [cexp_consts_ok_def] + \\ drule_then assume_tac ALOOKUP_MEM \\ gs [SF SFY_ss]) + \\ gs [EVERY_MAP, EVERY_MEM, EXISTS_PROD, PULL_EXISTS, MEM_FILTER] +QED + +(* N.B. This can be cleaned up a bit. There's a derivation of general beta + * conversion hidden in here that could be pulled out into a lemma if its + * ever needed. + *) + +Theorem LET_VSUBST: + compute_thy_ok thy ∧ + term_ok (sigof thy) q ∧ term_ok (sigof thy) p ∧ term_ok (sigof thy) r ∧ + (thy,[]) |- p === r ∧ p has_type Cexp ∧ q has_type Cexp ⇒ + (thy,[]) |- _LET (Abs (Var s Cexp) q) p === VSUBST [(r,Var s Cexp)] q +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any LET_eqn \\ gs [] + \\ ‘is_std_sig (sigof thy)’ + by (irule theory_ok_sig \\ gs []) + \\ gs [term_ok_clauses] + \\ simp [Ntimes has_type_cases 3] + \\ ‘r has_type Cexp ∧ welltyped q ∧ welltyped r ∧ welltyped p’ + by (drule_then strip_assume_tac proves_term_ok + \\ gs [term_ok_clauses, EQUATION_HAS_TYPE_BOOL] \\ rgs [WELLTYPED] + \\ imp_res_tac WELLTYPED_LEMMA \\ gs []) + \\ conj_asm1_tac + >- ( + drule_then strip_assume_tac compute_thy_ok_terms_ok + \\ rfs []) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_x_assum (irule_at Any) + \\ qabbrev_tac ‘_S = Var s Cexp’ + \\ irule trans_equation_simple + \\ qexists_tac ‘VSUBST [r,_S] (Comb (Abs _S q) _S)’ + \\ conj_tac + >- ( + simp [VSUBST_thm, Abbr ‘_S’, REV_ASSOCD_def] + \\ irule proves_REFL + \\ fs [term_ok_clauses] + \\ irule WELLTYPED_LEMMA \\ fs []) + \\ qspecl_then [‘(Comb (Abs _S q) _S) === q’,‘[]’,‘[r,_S]’,‘thy’] + mp_tac proves_INST + \\ simp [] + \\ impl_tac + >- ( + simp [Abbr ‘_S’, proves_BETA]) + \\ simp [equation_def, VSUBST_thm] +QED + +Theorem compute_eval_thm: + compute_thy_ok thy ⇒ + ((∀ck eqs cv s res s' tm. + compute_eval ck eqs cv s = (res, s') ∧ + term_ok (sigof thy) (cexp2term cv) ∧ + cexp_vars cv = {} ∧ + cexp_consts_ok eqs cv ∧ + ALL_DISTINCT (MAP FST eqs) ∧ + EVERY (λ(f,vs,cv). + ALL_DISTINCT vs ∧ + cexp_consts_ok eqs cv ∧ + ∃r. (thy,[]) |- cexp2term (App f (MAP Var vs)) === r ∧ + dest_cexp r = SOME cv ∧ + cexp_vars cv ⊆ set vs) eqs ⇒ + s' = s ∧ + (∀err. res = M_failure err ⇒ err = Failure «timeout») ∧ + ∀cv'. res = M_success cv' ⇒ + (thy,[]) |- cexp2term cv === cexp2term cv') ∧ + (∀ck eqs cvs s res s' tm. + compute_eval_list ck eqs cvs s = (res, s') ∧ + EVERY (term_ok (sigof thy)) (MAP cexp2term cvs) ∧ + EVERY (λcv. cexp_vars cv = {}) cvs ∧ + EVERY (cexp_consts_ok eqs) cvs ∧ + ALL_DISTINCT (MAP FST eqs) ∧ + EVERY (λ(f,vs,cv). + ALL_DISTINCT vs ∧ + cexp_consts_ok eqs cv ∧ + ∃r. (thy,[]) |- cexp2term (App f (MAP Var vs)) === r ∧ + dest_cexp r = SOME cv ∧ + cexp_vars cv ⊆ set vs) eqs ⇒ + s' = s ∧ + (∀err. res = M_failure err ⇒ err = Failure «timeout») ∧ + ∀cvs'. res = M_success cvs' ⇒ + LIST_REL (λcv cv'. (thy,[]) |- cexp2term cv === cexp2term cv') + cvs cvs')) +Proof + strip_tac \\ fs [] + \\ drule_then assume_tac compute_thy_ok_is_std_sig + \\ ho_match_mp_tac compute_eval_ind \\ rpt conj_tac + \\ rpt (gen_tac ORELSE disch_then strip_assume_tac) + \\ qpat_x_assum ‘_ = (res, _)’ mp_tac + \\ simp [compute_eval_def, st_ex_return_def, raise_Failure_def] + >~ [‘Var s’] >- ( + gs [cexp_vars_def]) + >~ [‘Num n’] >- ( + strip_tac + \\ gvs [cexp2term_term_ok, proves_REFL]) + >~ [‘Pair p q’] >- ( + simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ gs [cexp2term_def, term_ok_clauses, cexp_vars_def, cexp_consts_ok_def] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ reverse CASE_TAC \\ gs [] + \\ strip_tac \\ gvs [] + \\ fs [cexp2term_def, term_ok_def, MK_COMB_simple, proves_REFL, SF SFY_ss]) + >~ [‘Uop uop p’] >- ( + gvs [cexp2term_def, cexp_vars_def, cexp_consts_ok_def] + \\ drule_then strip_assume_tac term_ok_uop2term + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ rename [‘do_uop uop x s’] \\ strip_tac + \\ imp_res_tac (CONJUNCT1 compute_eval_value) + \\ drule_all_then strip_assume_tac do_uop_thm \\ gs []) + >~ [‘If p q r’] >- ( + gvs [cexp2term_def, term_ok_clauses, cexp_vars_def, cexp_consts_ok_def] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ rename [‘compute_eval _ _ _ _ = (M_success cv', _)’] + \\ Cases_on ‘cv' = Num 0’ + >- ( + gvs [] \\ rw [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_x_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL2 + \\ first_assum (irule_at Any) + \\ simp [cexp2term_def, Once num2bit_def] + \\ irule_at Any CEXP_IF_eqn3 \\ gs [] + \\ drule_then assume_tac proves_term_ok + \\ fs [equation_def, term_ok_def]) + \\ Cases_on ‘∃x y. cv' = Pair x y’ + >- ( + gvs [] \\ rw [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_assum (irule_at Any) + \\ fs [cexp2term_def, cexp_vars_def] + \\ irule_at Any CEXP_IF_eqn2 \\ gs [] + \\ imp_res_tac proves_term_ok + \\ fs [equation_def, term_ok_def]) + \\ Cases_on ‘∃n. cv' = Num (SUC n)’ + >- ( + gvs [] \\ rw [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_assum (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_assum (irule_at Any) + \\ fs [cexp2term_def] + \\ irule replaceL3 \\ Q.REFINE_EXISTS_TAC ‘_CEXP_NUM x’ + \\ irule_at Any MK_COMB_simple + \\ simp [proves_REFL, compute_thy_ok_terms_ok] + \\ resolve_then Any (irule_at Any) NUMERAL_eqn sym_equation + \\ simp [num2bit_term_ok, compute_thy_ok_def, compute_thy_ok_terms_ok, + proves_REFL] + \\ irule replaceL3 \\ Q.REFINE_EXISTS_TAC ‘_CEXP_NUM x’ + \\ irule_at Any MK_COMB_simple + \\ resolve_then Any (irule_at Any) num2bit_num2term sym_equation + \\ simp [num2bit_term_ok, compute_thy_ok_def, compute_thy_ok_terms_ok, + proves_REFL] + \\ simp [num2term_def] + \\ irule CEXP_IF_eqn1 \\ fs [num2term_term_ok] + \\ imp_res_tac proves_term_ok + \\ fs [equation_def, term_ok_def]) + \\ ‘cexp_value cv'’ + by (irule (CONJUNCT1 compute_eval_value) + \\ first_x_assum (irule_at Any)) + \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs []) + >~ [‘Binop bop p q’] >- ( + gvs [cexp2term_def, cexp_vars_def, cexp_consts_ok_def] + \\ drule_then strip_assume_tac term_ok_bop2term + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ rename [‘do_binop bop x y s’] \\ strip_tac + \\ drule_then strip_assume_tac term_ok_bop2term \\ gvs [] + \\ imp_res_tac (CONJUNCT1 compute_eval_value) + \\ drule_all_then strip_assume_tac do_binop_thm \\ gs []) + >~ [‘Let s p q’] >- ( + IF_CASES_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] + \\ gs [cexp_consts_ok_def, cexp_vars_def, cexp2term_def] + \\ ‘is_std_sig (sigof thy)’ + by (irule theory_ok_sig \\ gs []) + \\ gs [term_ok_clauses] + \\ CASE_TAC + \\ first_x_assum (drule_then strip_assume_tac) \\ gvs [] + \\ CASE_TAC \\ gs [] + \\ strip_tac + \\ first_x_assum drule + \\ ‘term_ok (sigof thy) (cexp2term a)’ + by (drule proves_term_ok \\ gs [term_ok_clauses]) + \\ ‘cexp_value a’ + by (irule_at Any (CONJUNCT1 compute_eval_value) + \\ first_assum (irule_at Any)) + \\ impl_keep_tac + >- ( + irule_at Any closed_subst' \\ gs [SUBSET_DIFF_EMPTY] + \\ irule_at Any cexp_consts_ok_subst \\ gs [] + \\ irule_at Any cexp_consts_ok_value + \\ irule_at Any subst_term_ok \\ gs []) + \\ rw [] \\ gs [] + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) \\ gvs [SF ETA_ss] + \\ DEP_REWRITE_TAC [subst_VSUBST] \\ simp [] + \\ gs [SUBSET_DIFF_EMPTY] + \\ irule_at Any cexp_value_closed \\ gs [] + \\ irule LET_VSUBST \\ fs []) + >~ [‘App f cs’] >- ( + IF_CASES_TAC \\ gs [] + \\ simp [option_def, Once st_ex_bind_def, st_ex_return_def, + raise_Failure_def] + \\ gs [cexp_consts_ok_def] + \\ CASE_TAC + >- ( + strip_tac \\ gvs [] + \\ gs [ALOOKUP_NONE, MEM_MAP, EXISTS_PROD]) + \\ pairarg_tac \\ gvs [] + \\ simp [check_def, st_ex_return_def, Once st_ex_ignore_bind_def, + raise_Failure_def] + \\ reverse IF_CASES_TAC \\ simp [] \\ simp [Once st_ex_bind_def] + >- ( + strip_tac + \\ gs [MEM_ALOOKUP, MEM_MAP, EXISTS_PROD]) + \\ CASE_TAC + \\ first_x_assum drule + \\ impl_keep_tac + >- ( + gs [term_ok_def, cexp_vars_def, cexp2term_def] + \\ drule_then strip_assume_tac term_ok_FOLDL_Comb \\ gs [SF ETA_ss] + \\ qpat_x_assum ‘_ = {{}}’ mp_tac + \\ rw [Once EXTENSION] + \\ gs [EVERY_MEM, MEM_MAP, PULL_EXISTS, EQ_IMP_THM]) + \\ strip_tac \\ gvs [] + \\ qpat_x_assum ‘term_ok _ (cexp2term _)’ + (strip_assume_tac o SIMPR [cexp2term_def]) + \\ drule_then strip_assume_tac term_ok_FOLDL_Comb \\ gvs [EVERY_MAP] + \\ drule_then ASSUME_TAC ALOOKUP_MEM + \\ reverse CASE_TAC >- (strip_tac \\ gvs []) + \\ strip_tac + \\ rename [‘ZIP(as,bs)’] + \\ gvs [EVERY_MEM, FORALL_PROD] + \\ first_x_assum (drule_then strip_assume_tac) + \\ rename [‘dest_cexp rhs = SOME exp’] + \\ qmatch_asmsub_abbrev_tac ‘_ |- lhs === rhs’ + \\ ‘term_ok (sigof thy) lhs ∧ term_ok (sigof thy) rhs’ + by (imp_res_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ unabbrev_all_tac + \\ drule_then drule dest_cexp_thm \\ gs [] \\ strip_tac + \\ ‘∀n. n < LENGTH bs ⇒ + cexp_value (EL n bs) ∧ term_ok (sigof thy) (cexp2term (EL n bs))’ + by (gen_tac + \\ strip_tac + \\ drule (CONJUNCT2 compute_eval_value) \\ rw [EVERY_EL] + \\ gvs [LIST_REL_EL_EQN] + \\ first_x_assum (drule_then strip_assume_tac) + \\ first_x_assum (drule_then strip_assume_tac) + \\ drule_then assume_tac proves_term_ok + \\ gvs [equation_def, term_ok_def]) + \\ first_x_assum drule + \\ gs [compute_eval_list_map] + \\ drule_then strip_assume_tac map_thm + \\ impl_keep_tac + >- ( + irule_at Any closed_subst' + \\ irule_at Any subst_term_ok + \\ irule_at Any cexp_consts_ok_subst + \\ gvs [GSYM MEM_ALOOKUP] + \\ gvs [MAP_ZIP, EVERY_EL, PULL_EXISTS, MEM_MAP, EXISTS_PROD, MEM_EL, + PULL_EXISTS, SF SFY_ss] + \\ drule proves_term_ok \\ simp [term_ok_clauses] \\ rw [] + \\ irule cexp_consts_ok_value + \\ irule (CONJUNCT1 compute_eval_value) + \\ first_x_assum (drule_then strip_assume_tac) + \\ first_x_assum (irule_at Any)) + \\ rw [] + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) \\ gvs [SF ETA_ss] + \\ ‘(thy,[]) |- VSUBST (MAP (λ(s,v). (cexp2term v, Var s Cexp)) + (ZIP (as,bs))) + (cexp2term exp === cexp2term (App f (MAP Var as)))’ + by (qspecl_then [‘c’,‘[]’] (irule o SIMPR []) proves_INST + \\ simp [MEM_MAP, EXISTS_PROD, PULL_EXISTS] + \\ rw [MEM_ZIP] \\ gs [SF SFY_ss] + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ rw [sym_equation]) + \\ ‘(thy,[]) |- VSUBST (MAP (λ(s,v). (cexp2term v, Var s Cexp)) + (ZIP (as,bs))) (cexp2term exp) === + VSUBST (MAP (λ(s,v). (cexp2term v, Var s Cexp)) + (ZIP (as,bs))) (cexp2term (App f (MAP Var as)))’ + by (qmatch_goalsub_abbrev_tac ‘VSUBST env’ + \\ qpat_x_assum ‘_ |- VSUBST _ _’ mp_tac + \\ simp [Once equation_def] + \\ simp [VSUBST_thm] + \\ ‘typeof (VSUBST env (cexp2term exp)) = Cexp’ + by (irule WELLTYPED_LEMMA + \\ irule VSUBST_HAS_TYPE + \\ gs [Abbr ‘env’, MEM_MAP, EXISTS_PROD, PULL_EXISTS]) + \\ pop_assum (SUBST1_TAC o SYM) + \\ simp [GSYM equation_def]) + \\ ‘(thy,[]) |- cexp2term (subst (ZIP(as,bs)) exp) === + cexp2term (subst (ZIP(as,bs)) (App f (MAP Var as)))’ + by (DEP_REWRITE_TAC [subst_VSUBST] + \\ simp [MAP_ZIP, cexp_vars_def, MAP_MAP_o, combinTheory.o_DEF, + BIGUNION_SUBSET, MEM_MAP, PULL_EXISTS] + \\ rw [EVERY_EL] + \\ first_x_assum (drule_then strip_assume_tac) + \\ first_x_assum (drule_then strip_assume_tac) + \\ drule_then assume_tac cexp_value_closed \\ gs []) + \\ resolve_then Any irule trans_equation_simple sym_equation + \\ first_x_assum (irule_at Any) + \\ simp [subst_def, SF ETA_ss] + \\ simp [MAP_subst_MAP_Var, cexp2term_def] + \\ ‘∀xs ys tm tm1. + LENGTH xs = LENGTH ys ∧ + tm has_type app_type (LENGTH xs) ∧ + (thy,[]) |- tm === tm1 ∧ + (∀n. + n < LENGTH xs ⇒ + (thy,[]) |- cexp2term (EL n xs) === cexp2term (EL n ys)) ⇒ + (thy,[]) |- FOLDL Comb tm (MAP cexp2term xs) === + FOLDL Comb tm1 (MAP cexp2term ys)’ + suffices_by ( + simp [SF ETA_ss] + \\ disch_then irule + \\ simp [proves_REFL] + \\ gs [has_type_rules] \\ rw [] + \\ first_x_assum (drule_then strip_assume_tac) + \\ first_x_assum (drule_then strip_assume_tac) + \\ gs [MEM_EL, PULL_EXISTS] + \\ gvs [LIST_REL_EL_EQN] + \\ irule sym_equation + \\ first_x_assum irule \\ gs []) + \\ Induct \\ simp [app_type, proves_REFL] + \\ qx_gen_tac ‘x’ \\ Cases_on ‘ys’ \\ simp [] + \\ rw [] \\ first_x_assum irule \\ gs [] + \\ irule_at Any MK_COMB_simple + \\ ‘term_ok (sigof thy) tm1 ∧ term_ok (sigof thy) tm’ + by (drule_then assume_tac proves_term_ok + \\ gs [term_ok_def, equation_def]) + \\ gs [term_ok_welltyped, SF SFY_ss] + \\ irule_at Any WELLTYPED_LEMMA + \\ qexists_tac ‘app_type (LENGTH t)’ \\ simp [] + \\ simp [Once has_type_cases] + \\ first_x_assum (irule_at Any) \\ gs [] + \\ conj_tac >- (first_x_assum (qspec_then ‘0’ mp_tac) \\ gs []) + \\ rw [] \\ first_x_assum (qspec_then ‘SUC n’ assume_tac) \\ gs []) + \\ simp [Once st_ex_bind_def] \\ CASE_TAC + \\ first_x_assum drule \\ gs [] \\ strip_tac \\ gvs [] + \\ reverse CASE_TAC >- (strip_tac \\ gvs []) + \\ simp [Once st_ex_bind_def] \\ CASE_TAC + \\ first_x_assum drule \\ gs [] \\ strip_tac \\ gvs [] + \\ reverse CASE_TAC >- (strip_tac \\ gvs []) + \\ rw [] \\ gs [SF SFY_ss] +QED + +val _ = export_theory (); + diff --git a/candle/prover/compute/compute_evalScript.sml b/candle/prover/compute/compute_evalScript.sml new file mode 100644 index 0000000000..c97267a519 --- /dev/null +++ b/candle/prover/compute/compute_evalScript.sml @@ -0,0 +1,500 @@ +(* + Interpreter function for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory compute_syntaxTheory; +open ml_monadBaseTheory ml_monadBaseLib; + +val _ = new_theory "compute_eval"; + +val _ = numLib.prefer_num (); + +(* ------------------------------------------------------------------------- + * st_ex_monad setup + * ------------------------------------------------------------------------- *) + +val st_ex_monadinfo : monadinfo = { + bind = “st_ex_bind”, + ignorebind = SOME “st_ex_ignore_bind”, + unit = “st_ex_return”, + fail = SOME “raise_Failure”, + choice = SOME “$otherwise”, + guard = NONE + }; + +val _ = declare_monad ("st_ex", st_ex_monadinfo); +val _ = enable_monadsyntax (); +val _ = enable_monad "st_ex"; + +Overload return[local] = “st_ex_return”; +Overload failwith[local] = “raise_Failure”; +Overload handle[local] = “handle_Failure”; +Overload error[local] = “raise_Failure «error»”; +Overload timeout[local] = “raise_Failure «timeout»”; + +(* ------------------------------------------------------------------------- + * Destructuring + * ------------------------------------------------------------------------- *) + +Definition dest_num_def: + dest_num tm = + case tm of + Const n t => if tm = _0 then SOME 0 else NONE + | Comb (Const nm t) r => + (case dest_num r of + | NONE => NONE + | SOME n => if Const nm t = _BIT0_TM then SOME (2 * n) + else if Const nm t = _BIT1_TM then SOME (2 * n + 1) + else NONE) + | _ => NONE +End + +Definition dest_numeral_def: + dest_numeral tm = + case tm of + Comb (Const n t) r => + if Const n t = _NUMERAL_TM then + case dest_num r of + | NONE => failwith «dest_numeral» + | SOME n => return n + else + failwith «dest_numeral» + | _ => failwith «dest_numeral» +End + +Definition dest_numeral_opt_def: + dest_numeral_opt tm = + case tm of + Comb (Const n t) r => + if Const n t = _NUMERAL_TM then + case dest_num r of + | NONE => NONE + | SOME n => SOME n + else + NONE + | _ => NONE +End + +Definition dest_binary_def: + dest_binary tm' tm = + case tm of + Comb (Comb (Const n t) l) r => + if tm' = Const n t then return (l, r) + else failwith «dest_binary» + | _ => failwith «dest_binary» +End + +Definition list_dest_comb_def: + list_dest_comb sofar (Comb f x) = list_dest_comb (x::sofar) f ∧ + list_dest_comb sofar tm = tm::sofar +End + +Theorem list_dest_comb_not_nil[simp]: + ∀sofar tm. list_dest_comb sofar tm ≠ [] +Proof + ho_match_mp_tac list_dest_comb_ind + \\ rw [list_dest_comb_def] +QED + +Theorem list_dest_comb_folds_back: + ∀sofar tm h t. + list_dest_comb sofar tm = h::t ⇒ + ∃xs. t = xs ++ sofar ∧ + FOLDL Comb h xs = tm +Proof + ho_match_mp_tac list_dest_comb_ind + \\ rw [list_dest_comb_def] \\ gvs [FOLDL_APPEND] +QED + +Definition term_size_alt_def: + term_size_alt (Comb s t) = term_size_alt s + term_size_alt t ∧ + term_size_alt (Abs s t) = term_size_alt s + term_size_alt t ∧ + term_size_alt _ = 1 +End + +Definition list_term_size_alt_def: + list_term_size_alt [] = 0 ∧ + list_term_size_alt (x::xs) = term_size_alt x + list_term_size_alt xs +End + +Theorem list_dest_comb_term_size[local]: + ∀sofar tm res. + list_dest_comb sofar tm = res ⇒ + list_term_size_alt res = list_term_size_alt sofar + term_size_alt tm +Proof + ho_match_mp_tac list_dest_comb_ind + \\ rw [list_dest_comb_def] \\ gs [list_term_size_alt_def, term_size_alt_def] +QED + +Theorem list_term_size_MEM[local]: + MEM x xs ⇒ term_size_alt x ≤ list_term_size_alt xs +Proof + Induct_on ‘xs’ + \\ rw [list_term_size_alt_def] \\ fs [] +QED + +Definition mapOption_def: + mapOption f [] = SOME [] ∧ + mapOption f (x::xs) = + case f x of + | NONE => NONE + | SOME y => + case mapOption f xs of + | NONE => NONE + | SOME ys => SOME (y::ys) +End + +Theorem mapOption_CONG[defncong]: + ∀xs ys f g. + xs = ys ∧ + (∀x. MEM x xs ⇒ f x = g x) ⇒ + mapOption f xs = mapOption g ys +Proof + Induct \\ rw [] \\ rw [mapOption_def] + \\ TOP_CASE_TAC \\ gs [SF DNF_ss] + \\ first_x_assum drule_all \\ rw [] +QED + +Theorem mapOption_LENGTH: + ∀xs ys. mapOption f xs = SOME ys ⇒ LENGTH xs = LENGTH ys +Proof + Induct \\ rw [mapOption_def] + \\ gvs [CaseEq "option"] +QED + +Definition dest_cexp_def: + dest_cexp tm = + case list_dest_comb [] tm of + | [Var n ty] => if ty = Cexp then SOME (Var n) else NONE + | Const n ty :: args => + (if Const n ty = _LET_TM then + (case args of + | [Abs (Var s ty) y; x] => + if ty = Cexp then + case dest_cexp x of + | NONE => NONE + | SOME p => + case dest_cexp y of + | NONE => NONE + | SOME q => SOME (Let s p q) + else NONE + | _ => NONE) + else let vs = MAP dest_cexp args in + case vs of + | [arg] => + if Const n ty = _CEXP_NUM_TM then + case dest_numeral_opt (HD args) of + | NONE => NONE + | SOME n => SOME (Num n) + else if ty = Fun Cexp Cexp then + case arg of + | NONE => NONE + | SOME cv => + if Const n ty = _CEXP_FST_TM then + SOME (Uop Fst cv) + else if Const n ty = _CEXP_SND_TM then + SOME (Uop Snd cv) + else if Const n ty = _CEXP_ISPAIR_TM then + SOME (Uop Ispair cv) + else + SOME (App n [cv]) + else + NONE + | [SOME p; SOME q] => + if Const n ty = _CEXP_PAIR_TM then + SOME (Pair p q) + else if Const n ty = _CEXP_ADD_TM then + SOME (Binop Add p q) + else if Const n ty = _CEXP_SUB_TM then + SOME (Binop Sub p q) + else if Const n ty = _CEXP_MUL_TM then + SOME (Binop Mul p q) + else if Const n ty = _CEXP_DIV_TM then + SOME (Binop Div p q) + else if Const n ty = _CEXP_MOD_TM then + SOME (Binop Mod p q) + else if Const n ty = _CEXP_LESS_TM then + SOME (Binop Less p q) + else if Const n ty = _CEXP_EQ_TM then + SOME (Binop Eq p q) + else if ty = Fun Cexp (Fun Cexp Cexp) then + SOME (App n [p; q]) + else + NONE + | [SOME p; SOME q; SOME r] => + if Const n ty = _CEXP_IF_TM then + SOME (If p q r) + else if ty = Fun Cexp (Fun Cexp (Fun Cexp Cexp)) then + SOME (App n [p; q; r]) + else + NONE + | args => + (case mapOption I args of + | NONE => NONE + | SOME cvs => + if ty = app_type (LENGTH cvs) then + SOME (App n cvs) + else NONE)) + | _ => NONE +Termination + wf_rel_tac ‘measure term_size_alt’ \\ rw [] + \\ drule_then assume_tac list_dest_comb_term_size + \\ gs [list_term_size_alt_def, term_size_alt_def] + \\ drule_then assume_tac list_term_size_MEM \\ gs [] +End + +(* TODO use term_size and list_size as measure instead *) + +Definition do_arith_def: + do_arith opn (Num m) (Num n) = return (Num (opn m n)) ∧ + do_arith opn (Num m) _ = return (Num (opn m 0)) ∧ + do_arith opn _ (Num n) = return (Num (opn 0 n)) ∧ + do_arith opn _ _ = return (Num 0) +End + +Definition do_reln_def: + do_reln opn (Num m) (Num n) = return (Num (if opn m n then SUC 0 else 0)) ∧ + do_reln opn _ _ = return (Num 0) +End + +Definition do_eq_def: + do_eq p q = return (Num (if p = q then SUC 0 else 0)) +End + +Definition do_binop_def: + do_binop Add p q = do_arith $+ p q ∧ + do_binop Sub p q = do_arith $- p q ∧ + do_binop Mul p q = do_arith $* p q ∧ + do_binop Div p q = do_arith $SAFEDIV p q ∧ + do_binop Mod p q = do_arith $SAFEMOD p q ∧ + do_binop Less p q = do_reln $< p q ∧ + do_binop Eq p q = do_eq p q +End + +Definition do_fst_def: + do_fst (Pair p q) = return p ∧ + do_fst _ = return (Num 0) +End + +Definition do_snd_def: + do_snd (Pair p q) = return q ∧ + do_snd _ = return (Num 0) +End + +Definition do_ispair_def: + do_ispair (Pair p q) = return (Num 1) ∧ + do_ispair _ = return (Num 0) +End + +Definition do_uop_def: + do_uop Fst p = do_fst p ∧ + do_uop Snd p = do_snd p ∧ + do_uop Ispair p = do_ispair p +End + +Definition map_def: + map f [] = return [] ∧ + map f (x::xs) = + do y <- f x; + ys <- map f xs; + return (y::ys) + od +End + +Theorem map_CONG[defncong]: + ∀xs ys f g. + xs = ys ∧ + (∀x. MEM x xs ⇒ f x = g x) ⇒ + map f xs = map g ys +Proof + simp [FUN_EQ_THM] \\ Induct \\ rw [map_def] + \\ once_rewrite_tac [st_ex_bind_def] \\ gs [] + \\ CASE_TAC \\ gs [] + \\ CASE_TAC \\ gs [] + \\ ‘map f ys = map g ys’ + suffices_by rw [] + \\ rw [FUN_EQ_THM] +QED + +Theorem map_LENGTH: + ∀xs f ys s s'. + map f xs s = (M_success ys, s') ⇒ + LENGTH xs = LENGTH ys +Proof + Induct \\ simp [map_def, st_ex_return_def] + \\ rpt gen_tac + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ rw [] \\ fs [SF SFY_ss] +QED + +Theorem map_thm: + ∀xs f ys s s'. + map f xs s = (M_success ys, s') ⇒ + LENGTH xs = LENGTH ys ∧ + ∀n. n < LENGTH xs ⇒ ∃r r'. f (EL n xs) r = (M_success (EL n ys), r') +Proof + Induct \\ simp [map_def, st_ex_return_def] + \\ qx_gen_tac ‘x’ \\ rpt gen_tac + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ simp [Once st_ex_bind_def] \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [] + \\ strip_tac \\ gvs [SF SFY_ss, SF DNF_ss] + \\ rename [‘M_success (EL _ (y::ys))’] + \\ Cases \\ simp [SF SFY_ss] +QED + +(* ------------------------------------------------------------------------- + * Interpreter for compute values + * ------------------------------------------------------------------------- *) + +Definition check_def: + check P = if P then return () else error +End + +Definition option_def: + option f x = case f x of SOME r => return r | _ => error +End + +Definition subst_def: + subst env (Var n) = + (case ALOOKUP env n of + | NONE => Var n + | SOME cv => cv) ∧ + subst env (Num n) = Num n ∧ + subst env (Pair p q) = Pair (subst env p) (subst env q) ∧ + subst env (Uop uop p) = Uop uop (subst env p) ∧ + subst env (Binop bop p q) = Binop bop (subst env p) (subst env q) ∧ + subst env (App f cs) = App f (MAP (subst env) cs) ∧ + subst env (If p q r) = If (subst env p) (subst env q) (subst env r) ∧ + subst env (Let s x y) = Let s (subst env x) + (subst (FILTER (λ(n,x). n ≠ s) env) y) +Termination + wf_rel_tac ‘measure (compute_exp_size o SND)’ +End + +Theorem subst_empty[simp]: + subst [] x = x +Proof + ‘∀xs x. xs = [] ⇒ subst xs x = x’ + suffices_by rw [] + \\ ho_match_mp_tac subst_ind + \\ rw [subst_def] + \\ irule LIST_EQ + \\ gs [MEM_EL, PULL_EXISTS, EL_MAP] +QED + +Definition compute_eval_def: + compute_eval ck ceqs (Var s) = error ∧ + compute_eval ck ceqs (Num n) = return (Num n) ∧ + compute_eval ck ceqs (Pair p q) = + do + x <- compute_eval ck ceqs p; + y <- compute_eval ck ceqs q; + return (Pair x y) + od ∧ + compute_eval ck ceqs (Uop uop p) = + do x <- compute_eval ck ceqs p; + do_uop uop x + od ∧ + compute_eval ck ceqs (Binop bop p q) = + do + x <- compute_eval ck ceqs p; + y <- compute_eval ck ceqs q; + do_binop bop x y + od ∧ + compute_eval ck ceqs (App f cs) = + (if ck = 0 then timeout else + do + (args,exp) <- option (ALOOKUP ceqs) f; + check (LENGTH args = LENGTH cs); + cs <- compute_eval_list ck ceqs cs; + compute_eval (ck - 1) ceqs (subst (ZIP (args,cs)) exp) + od) ∧ + compute_eval ck ceqs (If p q r) = + do + x <- compute_eval ck ceqs p; + case x of + | Num 0 => compute_eval ck ceqs r + | Num _ => compute_eval ck ceqs q + | Pair _ _ => compute_eval ck ceqs q + | _ => error + od ∧ + compute_eval ck ceqs (Let s p q) = + (if ck = 0 then timeout else + do + x <- compute_eval ck ceqs p; + compute_eval (ck - 1) ceqs (subst [s,x] q) + od) ∧ + compute_eval_list ck ceqs [] = return [] ∧ + compute_eval_list ck ceqs (c::cs) = + do + x <- compute_eval ck ceqs c; + xs <- compute_eval_list ck ceqs cs; + return (x::xs) + od +Termination + wf_rel_tac ‘inv_image ($< LEX $<) + (λx. case x of INL (ck,_,cv) => (ck, compute_exp_size cv) + | INR (ck,_,cv) => (ck, compute_exp1_size cv))’ +End + +(* Let and App cases are modified below to get a more useful ind theorem *) +Definition compute_eval_ind_def: + compute_eval_ind ck ceqs (Var s) = error ∧ + compute_eval_ind ck ceqs (Num n) = return (Num n) ∧ + compute_eval_ind ck ceqs (Pair p q) = + do + x <- compute_eval_ind ck ceqs p; + y <- compute_eval_ind ck ceqs q; + return (Pair x y) + od ∧ + compute_eval_ind ck ceqs (Uop uop p) = + do x <- compute_eval_ind ck ceqs p; + do_uop uop x + od ∧ + compute_eval_ind ck ceqs (Binop bop p q) = + do + x <- compute_eval_ind ck ceqs p; + y <- compute_eval_ind ck ceqs q; + do_binop bop x y + od ∧ + compute_eval_ind ck ceqs (App f cs) = + (if ck = 0 then timeout else + do + (args,exp) <- option (ALOOKUP ceqs) f; + check (LENGTH args = LENGTH cs); + cs <- compute_eval_ind_list ck ceqs cs; + compute_eval_ind (ck - 1) ceqs exp + od) ∧ + compute_eval_ind ck ceqs (If p q r) = + do + x <- compute_eval_ind ck ceqs p; + case x of + | Num 0 => compute_eval_ind ck ceqs r + | Num _ => compute_eval_ind ck ceqs q + | Pair _ _ => compute_eval_ind ck ceqs q + | _ => error + od ∧ + compute_eval_ind ck ceqs (Let s p q) = + (if ck = 0 then timeout else + do + x <- compute_eval_ind ck ceqs p; + compute_eval_ind (ck - 1) ceqs q + od) ∧ + compute_eval_ind_list ck ceqs [] = return [] ∧ + compute_eval_ind_list ck ceqs (c::cs) = + do + x <- compute_eval_ind ck ceqs c; + xs <- compute_eval_ind_list ck ceqs cs; + return (x::xs) + od +Termination + wf_rel_tac ‘inv_image ($< LEX $<) + (λx. case x of INL (ck,_,cv) => (ck, compute_exp_size cv) + | INR (ck,_,cv) => (ck, compute_exp1_size cv))’ +End + +val _ = Theory.delete_binding "compute_eval_ind_def" + +val _ = export_theory (); diff --git a/candle/prover/compute/compute_execProofScript.sml b/candle/prover/compute/compute_execProofScript.sml new file mode 100644 index 0000000000..4d556a860e --- /dev/null +++ b/candle/prover/compute/compute_execProofScript.sml @@ -0,0 +1,447 @@ +(* + Verification of fast interpreter for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory compute_syntaxTheory + compute_evalTheory compute_execTheory compute_evalProofTheory; +open ml_monadBaseTheory ml_monadBaseLib; +open mlvectorTheory + +val _ = new_theory "compute_execProof"; + +(* verification *) + +Definition from_cv_def[simp]: + from_cv ((Num n):cv) = (Num n : compute_exp) ∧ + from_cv (Pair x y) = Pair (from_cv x) (from_cv y) +End + +Definition from_res_def[simp]: + from_res f (M_success v) = M_success (f v) ∧ + from_res f (M_failure e) = M_failure e +End + +Inductive code_rel: + (∀eqs v1 n v2. + ~MEM n v1 ⇒ + code_rel eqs (v1 ++ [n] ++ v2) ((Var n):compute_exp) ((Var (LENGTH v1)):ce)) ∧ + (∀eqs vars n. + code_rel eqs vars (Num n) (Const n)) ∧ + (∀eqs vars x y x1 y1. + code_rel eqs vars x x1 ∧ + code_rel eqs vars y y1 ⇒ + code_rel eqs vars (Pair x y) (Binop Pair x1 y1)) ∧ + (∀eqs vars x y z x1 y1 z1. + code_rel eqs vars x x1 ∧ + code_rel eqs vars y y1 ∧ + code_rel eqs vars z z1 ⇒ + code_rel eqs vars (If x y z) (If x1 y1 z1)) ∧ + (∀eqs vars s x y x1 y1. + code_rel eqs vars x x1 ∧ + code_rel eqs (s::vars) y y1 ⇒ + code_rel eqs vars (Let s x y) (Let x1 y1)) ∧ + (∀eqs vars xs xs1 f l body n. + LIST_REL (code_rel eqs vars) xs xs1 ∧ + n < LENGTH eqs ∧ EL n eqs = (f,l,body) ∧ + LENGTH l = LENGTH xs ∧ + (∀k. k < n ⇒ FST (EL k eqs) ≠ f) ⇒ + code_rel eqs vars (App f xs) (App n xs1)) ∧ + (∀eqs vars x x1 m. + code_rel eqs vars x x1 ⇒ + code_rel eqs vars (Uop m x) (Monop (monop m) x1)) ∧ + (∀eqs vars x y x1 y1 b. + code_rel eqs vars x x1 ∧ + code_rel eqs vars y y1 ⇒ + code_rel eqs vars (Binop b x y) (Binop (binop b) x1 y1)) +End + +Theorem option_ALOOKUP: + ∀eqs n f l body s. + n < LENGTH eqs ∧ + EL n eqs = (f,l,body) ∧ + (∀k. k < n ⇒ FST (EL k eqs) ≠ f) ⇒ + option (ALOOKUP eqs) f s = (M_success (l,body),s) +Proof + Induct \\ fs [] + \\ Cases_on ‘n’ \\ fs [] + \\ gvs [option_def,st_ex_return_def,ALOOKUP_def,FORALL_PROD] + \\ rpt strip_tac + \\ first_assum $ qspec_then ‘0’ mp_tac + \\ strip_tac \\ fs [] + \\ first_x_assum irule + \\ first_x_assum $ irule_at Any + \\ rw [] + \\ ‘SUC k < SUC n'’ by fs [] + \\ res_tac \\ fs [] +QED + +Theorem LESS_LENGTH_env_lookup: + ∀xs n. n < LENGTH xs ⇒ env_lookup n xs = EL n xs +Proof + Induct \\ fs [] + \\ Cases_on ‘n’ \\ fs [env_lookup_def] +QED + +Theorem compute_eval_from_cv: + ∀x s ck eqs. compute_eval ck eqs (from_cv x) s = (M_success (from_cv x),s) +Proof + Induct + \\ fs [compute_eval_def,st_ex_return_def,st_ex_bind_def] +QED + +Theorem compile_eval_list_length: + ∀cvs xs ck ceqs s s'. + compute_eval_list ck ceqs cvs s = (M_success xs,s') ⇒ LENGTH xs = LENGTH cvs +Proof + Induct \\ fs [compute_eval_def,st_ex_return_def,st_ex_bind_def] + \\ rw [] \\ gvs [AllCaseEqs()] + \\ res_tac \\ fs [] +QED + +Theorem cexp_value_from_cv: + ∀y. cexp_value (from_cv y) +Proof + Induct \\ fs [cexp_value_def] +QED + +Triviality cexp_vars_def[simp] = compute_syntaxProofTheory.cexp_vars_def; + +Definition eqs_ok_def: + eqs_ok eqs ⇔ + EVERY (λ(n,args,body). + cexp_vars body ⊆ set args ∧ ALL_DISTINCT args ∧ + code_rel eqs (REVERSE args) body (compile_to_ce eqs (n,args,body))) eqs +End + +Theorem do_uop_from_cv: + do_uop uop (from_cv a) s = (M_success (from_cv (monop uop a)),s) +Proof + Cases_on ‘uop’ \\ Cases_on ‘a’ + \\ fs [do_uop_def,monop_def,do_fst_def,do_snd_def,do_ispair_def,st_ex_return_def] +QED + +Theorem from_cv_11: + ∀x y. from_cv x = from_cv y ⇔ x = y +Proof + Induct \\ Cases_on ‘y’ \\ fs [] +QED + +Theorem do_binop_from_cv: + do_binop bop (from_cv a) (from_cv b) s = (M_success (from_cv (binop bop a b)),s) +Proof + Cases_on ‘bop’ \\ Cases_on ‘a’ \\ Cases_on ‘b’ \\ fs [] + \\ fs [binop_def,do_binop_def,do_arith_def,st_ex_return_def, + SAFEDIV_def,SAFEMOD_def,do_reln_def,cv_T_def,cv_F_def] + \\ rw [] \\ fs [DIV_EQ_X,do_eq_def,st_ex_return_def,from_cv_11] + \\ rw [] +QED + +Theorem env_lookup_lemma: + ∀v1 env s v2. + MAP FST env = v1 ++ [s] ++ v2 ∧ ¬MEM s v1 ⇒ + ∃z. + ALOOKUP (MAP (λ(x,y). (x,from_cv y)) env) s = SOME (from_cv z) ∧ + env_lookup (LENGTH v1) (MAP SND env) = z +Proof + Induct \\ fs [] + \\ Cases_on ‘env’ \\ fs [] \\ PairCases_on ‘h’ \\ fs [env_lookup_def] +QED + +Theorem subst_from_cv: + ∀v xs. subst xs (from_cv v) = from_cv v +Proof + Induct \\ fs [subst_def] +QED + +Theorem subst_subst: + ∀e xs ys. + EVERY (λx. ∃v. SND x = from_cv v) ys ⇒ + subst xs (subst ys e) = subst (ys ++ xs) e +Proof + ho_match_mp_tac compute_syntaxProofTheory.cexp_vars_ind \\ rw [] + \\ gvs [subst_def,FILTER_APPEND,MAP_MAP_o,combinTheory.o_DEF,MAP_EQ_f] + \\ gvs [ALOOKUP_APPEND] + \\ every_case_tac \\ fs [subst_def] + \\ fs [EVERY_FILTER_IMP] + \\ imp_res_tac ALOOKUP_MEM + \\ fs [EVERY_MEM] \\ res_tac + \\ fs [subst_from_cv] +QED + +Theorem alookup_subst: + ∀e xs ys. + ALOOKUP xs = ALOOKUP ys ⇒ + subst xs e = subst ys e +Proof + ho_match_mp_tac compute_syntaxProofTheory.cexp_vars_ind \\ rw [] + \\ gvs [subst_def,MAP_EQ_f] + \\ first_x_assum irule + \\ fs [ALOOKUP_FILTER,FUN_EQ_THM] +QED + +Theorem subst_cons_lemma: + subst [(s,from_cv a)] + (subst + (FILTER (λ(n,x). n ≠ s) (MAP (λ(x,y). (x,from_cv y)) env)) e2) = + subst (MAP (λ(x,y). (x,from_cv y)) ((s,a)::env)) e2 +Proof + DEP_REWRITE_TAC [subst_subst] \\ fs [] + \\ conj_tac + >- + (fs [EVERY_FILTER,EVERY_MAP,LAMBDA_PROD,EXISTS_PROD] + \\ fs [EVERY_MEM,FORALL_PROD] \\ metis_tac []) + \\ irule alookup_subst + \\ fs [FUN_EQ_THM] + \\ rw [] + >- + (fs [ALOOKUP_APPEND,AllCaseEqs(),ALOOKUP_NONE] + \\ fs [MEM_MAP,EXISTS_PROD,MEM_FILTER]) + \\ Induct_on ‘env’ \\ fs [] + \\ PairCases \\ fs [] \\ rw [] +QED + +Theorem subst_eq_subst_lemma: + ∀s xs ys. + ALL_DISTINCT (MAP FST xs) ∧ xs = REVERSE ys ⇒ + subst xs s = subst ys s +Proof + ho_match_mp_tac compute_syntaxProofTheory.cexp_vars_ind + \\ rw [] \\ gvs [subst_def] + \\ fs [MAP_EQ_f] + \\ imp_res_tac alistTheory.alookup_distinct_reverse + \\ fs [FILTER_REVERSE] + \\ first_x_assum irule + \\ fs [MAP_REVERSE] + \\ qsuff_tac ‘MAP FST (FILTER (λ(n,x). n ≠ s) ys) = FILTER (λn. n ≠ s) (MAP FST ys)’ + \\ fs [FILTER_ALL_DISTINCT] + \\ qid_spec_tac ‘ys’ \\ Induct \\ fs [FORALL_PROD] + \\ rw [] +QED + +Theorem exec_thm: + (∀ck eqs e res env e1 s s1. + compute_eval ck eqs (subst (MAP (λ(x,y). (x, from_cv y)) env) e) s = (res,s1) ∧ + cexp_vars e SUBSET set (MAP FST env) ∧ eqs_ok eqs ∧ + code_rel eqs (MAP FST env) e e1 ⇒ + ∃res1. + exec (build_funs eqs) (MAP SND env) ck e1 s = (res1,s1) ∧ + res = from_res from_cv res1) ∧ + (∀ck eqs e res env e1 s s1 acc. + compute_eval_list ck eqs (MAP (subst (MAP (λ(x,y). (x, from_cv y)) env)) e) s = (res,s1) ∧ + EVERY (λe. cexp_vars e SUBSET set (MAP FST env)) e ∧ eqs_ok eqs ∧ + LIST_REL (code_rel eqs (MAP FST env)) e e1 ⇒ + ∃res1. + exec_list (build_funs eqs) (MAP SND env) ck e1 acc s = (res1,s1) ∧ + from_res (λxs. REVERSE xs ++ MAP from_cv acc) res = from_res (MAP from_cv) res1) +Proof + ho_match_mp_tac compute_eval_ind_ind \\ rpt strip_tac + >~ [‘Var’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac + \\ gvs [subst_def,exec_def,st_ex_return_def] + \\ drule_all env_lookup_lemma \\ strip_tac \\ fs [] + \\ gvs [compute_eval_from_cv]) + >~ [‘Num’] >- + (gvs [Once code_rel_cases] + \\ gvs [compute_eval_def,st_ex_return_def,exec_def,from_cv_def, + LESS_LENGTH_env_lookup,subst_def]) + >~ [‘Pair x y’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac \\ gvs [] + \\ gvs [compute_eval_def,st_ex_return_def,exec_def,from_cv_def,subst_def, + LESS_LENGTH_env_lookup,compute_eval_from_cv,st_ex_bind_def] + \\ gvs [cexp_consts_ok_def] + \\ gvs [AllCaseEqs()] + \\ rpt $ first_x_assum drule_all + \\ rw [] \\ gvs [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ Cases_on ‘res1'’ \\ gvs []) + >~ [‘If x y z’] >- + (gvs [cexp_consts_ok_def] + \\ gvs [compute_eval_def,st_ex_return_def,exec_def,from_cv_def,subst_def, + LESS_LENGTH_env_lookup,compute_eval_from_cv,st_ex_bind_def] + \\ gvs [AllCaseEqs()] + \\ pop_assum mp_tac \\ simp [Once code_rel_cases] \\ rw [] + \\ first_x_assum drule_all \\ strip_tac \\ fs [exec_def,st_ex_bind_def] + \\ Cases_on ‘res1’ \\ gvs [] + \\ Cases_on ‘a’ \\ gvs [] + \\ TRY (first_x_assum drule_all \\ strip_tac \\ fs [exec_def,st_ex_bind_def]) + \\ Cases_on ‘n’ \\ gvs [] + \\ first_x_assum drule_all \\ strip_tac \\ fs [exec_def,st_ex_bind_def]) + >~ [‘Let s e1 e2’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac + \\ Cases_on ‘ck = 0’ \\ gvs [compute_eval_def,exec_def,subst_def] + \\ gvs [raise_Failure_def,exec_def,st_ex_bind_def] + \\ gvs [AllCaseEqs(),PULL_EXISTS] + \\ first_x_assum drule_all \\ gvs [] \\ strip_tac \\ gvs [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘a::MAP SND env = MAP SND ((s,a)::env)’ by fs [] + \\ pop_assum $ once_rewrite_tac o single + \\ first_x_assum irule + \\ fs [subst_cons_lemma] + \\ fs [SUBSET_DEF] \\ metis_tac []) + >~ [‘App f xs’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac + \\ qpat_x_assum ‘cexp_vars (App f xs) ⊆ set (MAP FST env)’ mp_tac + \\ gvs [subst_def] + \\ Cases_on ‘ck = 0’ \\ gvs [compute_eval_def] + \\ gvs [raise_Failure_def,exec_def] + \\ drule_all option_ALOOKUP + \\ strip_tac \\ fs [st_ex_bind_def,check_def,st_ex_return_def,st_ex_ignore_bind_def] + \\ ‘n < length (build_funs eqs)’ by fs [build_funs_def,length_def] + \\ fs [get_code_def,st_ex_return_def] + \\ disch_then assume_tac + \\ ‘EVERY (λe. cexp_vars e ⊆ set (MAP FST env)) xs’ by + (fs [EVERY_MEM,EXTENSION,MEM_MAP,PULL_EXISTS,SUBSET_DEF] + \\ metis_tac []) + \\ reverse $ gvs [AllCaseEqs(),SF ETA_ss] + \\ first_x_assum drule_all + \\ disch_then $ qspec_then ‘[]’ mp_tac \\ strip_tac \\ gvs [] + >- (Cases_on ‘res1’ \\ fs []) + \\ Cases_on ‘res1’ \\ fs [] + \\ rename [‘REVERSE vs = _’] + \\ gvs [SWAP_REVERSE_SYM,sub_def,build_funs_def,EL_MAP] + \\ gvs [eqs_ok_def,EVERY_EL] + \\ imp_res_tac compile_eval_list_length \\ fs [MAP_ZIP,MEM_ZIP,PULL_EXISTS] + \\ qpat_x_assum ‘∀x. _ ⇒ _’ drule + \\ fs [] \\ strip_tac + \\ ‘a = MAP SND (ZIP (REVERSE l,a))’ by fs [MAP_ZIP] + \\ pop_assum $ once_rewrite_tac o single + \\ first_x_assum irule + \\ fs [MAP_ZIP] + \\ first_x_assum $ irule_at $ Pos last + \\ first_x_assum $ irule_at $ Pos last + \\ qpat_x_assum ‘_ = (res,s1)’ $ rewrite_tac o single o GSYM + \\ AP_THM_TAC \\ AP_TERM_TAC + \\ ‘MAP (λ(x,y). (x,from_cv y)) (ZIP (REVERSE l,a)) = + ZIP (REVERSE l,MAP from_cv a)’ by + (‘LENGTH a = LENGTH l’ by fs [] + \\ pop_assum mp_tac + \\ qid_spec_tac ‘a’ + \\ qid_spec_tac ‘l’ + \\ Induct using SNOC_INDUCT + \\ fs [] \\ strip_tac \\ Cases \\ fs []) + \\ fs [] + \\ irule subst_eq_subst_lemma + \\ fs [MAP_ZIP,REVERSE_ZIP]) + >~ [‘Uop’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac \\ gvs [] + \\ gvs [compute_eval_def,st_ex_return_def,exec_def,from_cv_def,subst_def, + LESS_LENGTH_env_lookup,compute_eval_from_cv,st_ex_bind_def] + \\ gvs [cexp_consts_ok_def] + \\ gvs [AllCaseEqs()] + \\ rpt $ first_x_assum drule_all + \\ rw [] \\ gvs [] + \\ Cases_on ‘res1’ \\ gvs [do_uop_from_cv]) + >~ [‘Binop’] >- + (pop_assum mp_tac + \\ simp [Once code_rel_cases] \\ strip_tac \\ gvs [] + \\ gvs [compute_eval_def,st_ex_return_def,exec_def,from_cv_def,subst_def, + LESS_LENGTH_env_lookup,compute_eval_from_cv,st_ex_bind_def] + \\ gvs [cexp_consts_ok_def] + \\ gvs [AllCaseEqs()] + \\ rpt $ first_x_assum drule_all + \\ rw [] \\ gvs [] + \\ Cases_on ‘res1’ \\ gvs [do_binop_from_cv] + \\ Cases_on ‘res1'’ \\ gvs [do_binop_from_cv]) + >- (gvs [exec_def,st_ex_return_def,compute_eval_def]) + \\ gvs [compute_eval_def,exec_def] + \\ fs [Once st_ex_bind_def] + \\ reverse (gvs [AllCaseEqs()]) + \\ last_x_assum drule_all \\ fs [] \\ strip_tac \\ fs [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ gvs [compute_eval_def,exec_def] + \\ fs [st_ex_bind_def,st_ex_return_def] + \\ reverse (gvs [AllCaseEqs()]) + \\ last_x_assum drule_all \\ fs [] \\ strip_tac \\ fs [] + \\ first_x_assum $ qspec_then ‘a::acc’ strip_assume_tac + \\ gvs [] \\ Cases_on ‘res1’ \\ gvs [] +QED + +Theorem exec_lemma = + exec_thm + |> CONJUNCT1 + |> Q.SPECL [‘ck’,‘eqs’,‘e’,‘res’,‘[]’,‘to_ce eqs [] e’,‘s’,‘s1’] + |> SIMP_RULE std_ss [MAP,subst_empty,listTheory.LIST_TO_SET]; + +Triviality LIST_REL_MAP_lemma: + ∀xs. LIST_REL R xs (MAP f xs) = EVERY (λx. R x (f x)) xs +Proof + Induct \\ fs [] +QED + +Theorem code_rel_to_ce: + ∀e vars eqs. + cexp_vars e ⊆ set vars ∧ cexp_consts_ok eqs e ∧ + EVERY (λ(n,args,body). cexp_vars body ⊆ set args ∧ cexp_consts_ok eqs body) eqs ∧ + ALL_DISTINCT (MAP FST eqs) ⇒ + code_rel eqs vars e (to_ce eqs vars e) +Proof + ho_match_mp_tac compute_syntaxProofTheory.cexp_vars_ind + \\ rw [to_ce_def,cexp_consts_ok_def] + \\ simp [Once code_rel_cases] + >- + (Induct_on ‘vars’ \\ fs [] \\ rw [] \\ fs [indexedListsTheory.findi_def] + \\ rw [] \\ fs [] + \\ qexists_tac ‘h::v1’ \\ qexists_tac ‘v2’ \\ fs []) + >- + (first_x_assum irule + \\ fs [SUBSET_DEF] \\ metis_tac []) + \\ gvs [MEM_MAP,EXISTS_PROD,LIST_REL_MAP_lemma] + \\ fs [EVERY_MEM,FORALL_PROD] + \\ rename [‘MEM (n,args,body) _’] + \\ qexists_tac ‘args’ + \\ qexists_tac ‘body’ + \\ fs [] + \\ conj_tac + >- + (rw [] \\ first_x_assum irule \\ fs [] + \\ res_tac \\ fs [] + \\ rw [] \\ res_tac \\ fs [] + \\ fs [SUBSET_DEF,PULL_EXISTS,MEM_MAP] + \\ res_tac \\ fs []) + \\ qpat_x_assum ‘MEM _ _’ mp_tac + \\ pop_assum mp_tac + \\ qid_spec_tac ‘eqs’ + \\ Induct \\ fs [FORALL_PROD] + \\ rw [] \\ gvs [indexedListsTheory.findi_def] + \\ rw [] \\ fs [] + \\ gvs [GSYM ADD1,EL] + \\ gvs [MEM_MAP,FORALL_PROD] + \\ every_case_tac \\ gvs [] + \\ Cases_on ‘k’ \\ gvs [] +QED + +Theorem compute_eval_eq_exec: + cexp_vars e = ∅ ∧ + cexp_consts_ok eqs e ∧ + ALL_DISTINCT (MAP FST eqs) ∧ + EVERY (λ(n,args,body). + ALL_DISTINCT args ∧ + cexp_vars body ⊆ set args ∧ + cexp_consts_ok eqs body) eqs + ⇒ + compute_eval ck eqs e s = + let (r,s1) = exec (build_funs eqs) [] ck (to_ce eqs [] e) s in + (from_res from_cv r, s1) +Proof + Cases_on ‘compute_eval ck eqs e s’ \\ fs [] + \\ pairarg_tac \\ gvs [] \\ strip_tac + \\ ‘eqs_ok eqs’ by + (fs [eqs_ok_def,EVERY_MEM,FORALL_PROD] + \\ rw [] \\ res_tac \\ fs [compile_to_ce_def] + \\ irule code_rel_to_ce \\ fs [] + \\ fs [eqs_ok_def,EVERY_MEM,FORALL_PROD] + \\ rw [] \\ res_tac) + \\ drule exec_lemma + \\ impl_tac \\ rpt strip_tac \\ fs [] + \\ irule code_rel_to_ce \\ fs [] + \\ gvs [EVERY_MEM,FORALL_PROD] + \\ rw [] \\ res_tac \\ fs [] +QED + +val _ = export_theory (); diff --git a/candle/prover/compute/compute_execScript.sml b/candle/prover/compute/compute_execScript.sml new file mode 100644 index 0000000000..1bb4a07db0 --- /dev/null +++ b/candle/prover/compute/compute_execScript.sml @@ -0,0 +1,184 @@ +(* + Fast interpreter function for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory compute_syntaxTheory + compute_evalTheory; +open ml_monadBaseTheory ml_monadBaseLib; +open mlvectorTheory + +val _ = new_theory "compute_exec"; + +(* ------------------------------------------------------------------------- + * st_ex_monad setup + * ------------------------------------------------------------------------- *) + +val st_ex_monadinfo : monadinfo = { + bind = “st_ex_bind”, + ignorebind = SOME “st_ex_ignore_bind”, + unit = “st_ex_return”, + fail = SOME “raise_Failure”, + choice = SOME “$otherwise”, + guard = NONE + }; + +val _ = declare_monad ("st_ex", st_ex_monadinfo); +val _ = enable_monadsyntax (); +val _ = enable_monad "st_ex"; + +Overload return[local] = “st_ex_return”; +Overload failwith[local] = “raise_Failure”; +Overload handle[local] = “handle_Failure”; +Overload error[local] = “raise_Failure «error»”; +Overload timeout[local] = “raise_Failure «timeout»”; + +(* ------------------------------------------------------------------------- + * execute engine + * ------------------------------------------------------------------------- *) + +Datatype: + cv = Num num | Pair cv cv +End + +Datatype: + ce = Const num + | Var num + | Monop (cv -> cv) ce + | Binop (cv -> cv -> cv) ce ce + | App num (ce list) + | If ce ce ce + | Let ce ce +End + +Definition env_lookup_def: + env_lookup n [] = Num 0 /\ + env_lookup n (x::xs) = + if n = 0n then x else env_lookup (n-1) xs +End + +Definition get_code_def: + get_code f funs = + if f < length funs then + return (sub funs f) + else + timeout +End + +Definition exec_def: + exec funs env ck (Const n) = + return (Num n) ∧ + exec funs env ck (Var n) = + return (env_lookup n env) ∧ + exec funs env ck (Monop m x) = + do + v <- exec funs env ck x; + return (m v) + od ∧ + exec funs env ck (Binop b x y) = + do + v <- exec funs env ck x; + w <- exec funs env ck y; + return (b v w) + od ∧ + exec funs env ck (App f xs) = + (if ck = 0 then timeout else + do + vs <- exec_list funs env ck xs []; + c <- get_code f funs; + exec funs vs (ck-1n) c + od) ∧ + exec funs env ck (Let x y) = + (if ck = 0 then timeout else + do + v <- exec funs env ck x; + exec funs (v::env) (ck-1) y + od) ∧ + exec funs env ck (If x y z) = + do + v <- exec funs env ck x; + exec funs env ck (if v = Num 0 then z else y) + od ∧ + exec_list funs env ck [] acc = + return acc ∧ + exec_list funs env ck (x::xs) acc = + do + v <- exec funs env ck x; + exec_list funs env ck xs (v::acc) + od +Termination + WF_REL_TAC ‘inv_image ($< LEX $<) $ + λx. case x of INL (_,_,ck,cv) => (ck, ce_size cv) + | INR (_,_,ck,cv,_) => (ck, ce1_size cv)’ + \\ rw [] \\ fs [] +End + +Definition monop_def: + (monop Fst = λx. case x of Pair y z => y | _ => Num 0) ∧ + (monop Snd = λx. case x of Pair y z => z | _ => Num 0) ∧ + (monop IsPair = λx. case x of Pair y z => Num 1 | _ => Num 0) +End + +Definition to_num_def[simp]: + to_num (Pair _ _) = 0 ∧ + to_num ((Num n):cv) = n +End + +Definition cv_T_def: + cv_T = Num 1 : cv +End + +Definition cv_F_def: + cv_F = Num 0 : cv +End + +Definition binop_def: + binop op = + case op of + | Add => (λx y. Num (to_num x + to_num y)) + | Sub => (λx y. Num (to_num x - to_num y)) + | Mul => (λx y. Num (to_num x * to_num y)) + | Div => (λx y. Num (let k = to_num y in if k = 0 then 0 else to_num x DIV k)) + | Mod => (λx y. Num (let k = to_num y in if k = 0 then to_num x else to_num x MOD k)) + | Eq => (λx y. if x = y then cv_T else cv_F) + | Less => (λx y. case x of + | Pair _ _ => cv_F + | Num n => case y of + | Pair _ _ => cv_F + | Num m => if n < m then cv_T else cv_F) +End + +Definition to_ce_def: + to_ce (eqs:(mlstring # mlstring list # compute_exp) list) + args ((Var v):compute_exp) = Var (findi v args) ∧ + to_ce eqs args (Num n) = Const n ∧ + to_ce eqs args (Pair x y) = + Binop Pair (to_ce eqs args x) (to_ce eqs args y) ∧ + to_ce eqs args (If x y z) = + If (to_ce eqs args x) (to_ce eqs args y) (to_ce eqs args z) ∧ + to_ce eqs args (Let s x y) = + Let (to_ce eqs args x) (to_ce eqs (s::args) y) ∧ + to_ce eqs args (Uop m x) = + Monop (monop m) (to_ce eqs args x) ∧ + to_ce eqs args (Binop b x y) = + Binop (binop b) (to_ce eqs args x) (to_ce eqs args y) ∧ + to_ce eqs args (App f xs) = + App (findi f (MAP FST eqs)) (MAP (to_ce eqs args) xs) +Termination + WF_REL_TAC ‘measure $ λ(eqs,args,e). compute_exp_size e’ +End + +Definition compile_to_ce_def: + compile_to_ce eqs (n,args,body) = to_ce eqs (REVERSE args) body +End + +Definition build_funs_def: + build_funs eqs = Vector ((MAP (compile_to_ce eqs) eqs) : ce list) +End + +Definition cv2term_def: + cv2term ((Num n):cv) = _CEXP_NUM (_NUMERAL (num2bit n)) ∧ + cv2term (Pair p q) = _CEXP_PAIR (cv2term p) (cv2term q) +End + +val _ = export_theory (); diff --git a/candle/prover/compute/compute_pmatchScript.sml b/candle/prover/compute/compute_pmatchScript.sml new file mode 100644 index 0000000000..b05aacb023 --- /dev/null +++ b/candle/prover/compute/compute_pmatchScript.sml @@ -0,0 +1,114 @@ +(* + Pmatch definitions for functions in computeScript.sml. + *) + +open preamble compute_syntaxTheory compute_evalTheory computeTheory; +local open patternMatchesLib in end; + +val _ = new_theory "compute_pmatch"; + +val _ = numLib.prefer_num (); + +val _ = patternMatchesLib.ENABLE_PMATCH_CASES (); + +Theorem dest_num_PMATCH: + ∀tm. + dest_num tm = + case tm of + Const n t => if tm = _0 then SOME 0 else NONE + | Comb (Const nm t) r => + (dtcase dest_num r of + | NONE => NONE + | SOME n => if Const nm t = _BIT0_TM then SOME (2 * n) + else if Const nm t = _BIT1_TM then SOME (2 * n + 1) + else NONE) + | _ => NONE +Proof + CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) + \\ rw [Once dest_num_def] +QED + +Theorem dest_numeral_PMATCH: + ∀tm. + dest_numeral tm = + case tm of + Comb (Const n t) r => + if Const n t = _NUMERAL_TM then + dtcase dest_num r of + | NONE => raise_Failure «dest_numeral» + | SOME n => st_ex_return n + else + raise_Failure «dest_numeral» + | _ => raise_Failure «dest_numeral» +Proof + rw [Once dest_numeral_def] + \\ CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ rw [] +QED + +Theorem dest_binary_PMATCH: + ∀tm' tm. + dest_binary tm' tm = + case tm of + Comb (Comb (Const n t) l) r => + if tm' = Const n t then st_ex_return (l, r) + else raise_Failure «dest_binary» + | _ => raise_Failure «dest_binary» +Proof + CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) + \\ rw [Once dest_binary_def] +QED + +Theorem dest_numeral_opt_PMATCH: + ∀tm. + dest_numeral_opt tm = + case tm of + Comb (Const n t) r => + if Const n t = _NUMERAL_TM then + dtcase dest_num r of + | NONE => NONE + | SOME n => SOME n + else + NONE + | _ => NONE +Proof + rw [Once dest_numeral_opt_def] + \\ CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) \\ rw [] +QED + +Theorem do_arith_PMATCH: + ∀t1 t2. + do_arith op t1 t2 = + case t1 of + | Num n => + (case t2 of + | Num m => return (Num (op n m)) + | _ => return (Num (op n 0))) + | _ => + (case t2 of + | Num m => return (Num (op 0 m)) + | _ => return (Num 0)) +Proof + rpt gen_tac + \\ CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) + \\ Cases_on ‘t1’ \\ Cases_on ‘t2’ + \\ rw [do_arith_def] +QED + +Theorem do_reln_PMATCH: + ∀t1 t2. + do_reln op t1 t2 = + case t1 of + | Num n => + (case t2 of + | Num m => return (Num (if op n m then SUC 0 else 0)) + | _ => return (Num 0)) + | _ => return (Num 0) +Proof + rpt gen_tac + \\ CONV_TAC (DEPTH_CONV patternMatchesLib.PMATCH_ELIM_CONV) + \\ Cases_on ‘t1’ \\ Cases_on ‘t2’ + \\ rw [do_reln_def] +QED + +val _ = export_theory (); + diff --git a/candle/prover/compute/compute_syntaxProofScript.sml b/candle/prover/compute/compute_syntaxProofScript.sml new file mode 100644 index 0000000000..7910e3953f --- /dev/null +++ b/candle/prover/compute/compute_syntaxProofScript.sml @@ -0,0 +1,2237 @@ +(* + Proofs related to term embeddings for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory compute_syntaxTheory; + +val _ = new_theory "compute_syntaxProof"; + +val _ = numLib.prefer_num (); + +fun SIMPR ths = SIMP_RULE (srw_ss()) ths; +fun SIMPC ths = SIMP_CONV (srw_ss()) ths; + +(* ------------------------------------------------------------------------- + * Support + * ------------------------------------------------------------------------- *) + +Theorem trans_equation_simple: + (thy,[]) |- a === b ∧ + (thy,[]) |- b === c ⇒ + (thy,[]) |- a === c +Proof + rw [] + \\ qspecl_then [‘t’,‘[]’,‘[]’] (irule o SIMPR []) trans_equation + \\ simp [ACONV_REFL, SF SFY_ss] +QED + +Theorem MK_COMB_simple = + Q.SPECL [‘[]’,‘[]’] proves_MK_COMB |> SIMPR [PULL_EXISTS]; + +Theorem replaceL1: + (thy,[]) |- x === y ∧ + (thy,[]) |- Comb (Comb f x) r === z ⇒ + (thy,[]) |- Comb (Comb f y) r === z +Proof + rw [] + \\ ‘theory_ok thy ∧ + EVERY (term_ok (sigof thy)) [f;x;y;r;z] ∧ + typeof x = typeof y ∧ + (∃ty. typeof f = Fun (typeof y) (Fun (typeof r) ty))’ + by (imp_res_tac proves_term_ok + \\ imp_res_tac proves_theory_ok + \\ gs [term_ok_def, equation_def]) + \\ irule trans_equation_simple \\ fs [] + \\ first_x_assum (irule_at Any) + \\ simp [MK_COMB_simple, Once sym_equation, term_ok_welltyped, proves_REFL, + SF SFY_ss] +QED + +Theorem replaceL2: + (thy,[]) |- x === y ∧ + (thy,[]) |- Comb f x === z ⇒ + (thy,[]) |- Comb f y === z +Proof + rw [] + \\ ‘theory_ok thy ∧ + EVERY (term_ok (sigof thy)) [f;x;y;z] ∧ + typeof x = typeof y ∧ + (∃ty. typeof f = Fun (typeof y) ty)’ + by (imp_res_tac proves_term_ok + \\ imp_res_tac proves_theory_ok + \\ gs [term_ok_def, equation_def]) + \\ irule trans_equation_simple + \\ first_assum (irule_at Any) \\ fs [] + \\ simp [MK_COMB_simple, term_ok_welltyped, proves_REFL, sym_equation, + SF SFY_ss] +QED + +Theorem replaceL3: + (thy,[]) |- x === y ∧ + (thy,[]) |- Comb (Comb (Comb f x) s) t === z ⇒ + (thy,[]) |- Comb (Comb (Comb f y) s) t === z +Proof + rw [] + \\ ‘theory_ok thy ∧ + EVERY (term_ok (sigof thy)) [f;x;y;z;s;t] ∧ + typeof x = typeof y ∧ + (∃ty. typeof f = Fun (typeof y) (Fun (typeof s) (Fun (typeof t) ty)))’ + by (imp_res_tac proves_term_ok + \\ imp_res_tac proves_theory_ok + \\ gs [term_ok_def, equation_def]) + \\ irule trans_equation_simple + \\ first_assum (irule_at Any) \\ fs [] + \\ simp [MK_COMB_simple, term_ok_welltyped, proves_REFL, sym_equation, + SF SFY_ss] +QED + +Theorem replaceL_eq1: + (thy,[]) |- (x === x') ∧ + (thy,[]) |- (x === y) === r ⇒ + (thy,[]) |- (x' === y) === r +Proof + rw [] + \\ ‘theory_ok thy ∧ + EVERY (term_ok (sigof thy)) [x;x';y;r] ∧ + typeof x = typeof y ∧ + typeof x' = typeof x ∧ + typeof r = Bool ∧ + type_ok (tysof thy) (typeof y)’ + by (imp_res_tac proves_term_ok + \\ imp_res_tac proves_theory_ok + \\ gs [term_ok_def, equation_def, type_ok_def]) + \\ irule trans_equation_simple + \\ first_assum (irule_at Any) \\ fs [] + \\ CONV_TAC (PATH_CONV "rl" (SIMPC [equation_def])) + \\ CONV_TAC (PATH_CONV "rr" (SIMPC [equation_def])) + \\ irule MK_COMB_simple \\ gs [proves_REFL, term_ok_welltyped, SF SFY_ss] + \\ irule MK_COMB_simple \\ gs [proves_REFL, term_ok_welltyped, SF SFY_ss] + \\ rw [sym_equation] \\ irule proves_REFL \\ gs [] + \\ gs [theory_ok_def, term_ok_clauses] +QED + +Theorem replaceL_eq2: + (thy,[]) |- (x === x') ∧ + (thy,[]) |- (y === x) === r ⇒ + (thy,[]) |- (y === x') === r +Proof + rw [] + \\ ‘theory_ok thy ∧ + EVERY (term_ok (sigof thy)) [x;x';y;r] ∧ + typeof x = typeof y ∧ + typeof x' = typeof x ∧ + typeof r = Bool ∧ + type_ok (tysof thy) (typeof y)’ + by (imp_res_tac proves_term_ok + \\ imp_res_tac proves_theory_ok + \\ gs [term_ok_def, equation_def, type_ok_def]) + \\ irule trans_equation_simple + \\ first_assum (irule_at Any) \\ fs [] + \\ CONV_TAC (PATH_CONV "rl" (SIMPC [equation_def])) + \\ CONV_TAC (PATH_CONV "rr" (SIMPC [equation_def])) + \\ irule MK_COMB_simple \\ gs [proves_REFL, term_ok_welltyped, SF SFY_ss] + \\ rw [sym_equation] + \\ irule proves_REFL \\ gs [] + \\ gs [theory_ok_def, term_ok_clauses, term_ok_welltyped, SF SFY_ss] +QED + +Theorem replaceR1 = + UNDISCH_ALL replaceL1 |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem replaceR2 = + UNDISCH_ALL replaceL2 |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem replaceR3 = + UNDISCH_ALL replaceL3 |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem replaceR_eq1 = + UNDISCH_ALL replaceL_eq1 |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem replaceR_eq2 = + UNDISCH_ALL replaceL_eq2 |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem DEDUCT_ANTISYM_simple: + (thy,[]) |- a ∧ (thy,[]) |- b ⇒ (thy,[]) |- a === b +Proof + qspecl_then [‘a’,‘b’,‘[]’,‘[]’] (assume_tac o SIMPR [ACONV_REFL]) + proves_DEDUCT_ANTISYM + \\ gs [] +QED + +(* ------------------------------------------------------------------------- + * Booleans + * ------------------------------------------------------------------------- *) + +Definition bool_thy_ok_def: + bool_thy_ok thy ⇔ + theory_ok thy ∧ + (* COND *) + (thy,[]) |- _COND _TRUE _M _N === _M ∧ + (thy,[]) |- _COND _FALSE _M _N === _N ∧ + (thy,[]) |- _IF _TRUE _X _Y === _X ∧ + (thy,[]) |- _IF _FALSE _X _Y === _Y +End + +Theorem bool_thy_ok_terms_ok: + bool_thy_ok thy ⇒ + term_ok (sigof thy) _TRUE ∧ + term_ok (sigof thy) _FALSE ∧ + term_ok (sigof thy) _COND_TM ∧ + term_ok (sigof thy) _IF_TM +Proof + simp [bool_thy_ok_def] \\ strip_tac + \\ rpt (dxrule_then assume_tac proves_term_ok) \\ rfs [] + \\ gs [theory_ok_def, term_ok_clauses] +QED + +Theorem bool_thy_ok_theory_ok[simp]: + bool_thy_ok thy ⇒ theory_ok thy +Proof + rw [bool_thy_ok_def] +QED + +(* ------------------------------------------------------------------------- + * Natural numbers + * ------------------------------------------------------------------------- *) + +(* All the necessary constants defined with the right types and + * with the right defining equations (and some lemmas). + *) + +Definition numeral_thy_ok_def: + numeral_thy_ok thy ⇔ + bool_thy_ok thy ∧ + (* NUMERAL *) + (thy,[]) |- _NUMERAL _N === _N ∧ + (* BIT0, BIT1 *) + (thy,[]) |- _BIT0 _N === _ADD _N _N ∧ + (thy,[]) |- _BIT1 _N === _SUC (_ADD _N _N) ∧ + (* ADD *) + (thy,[]) |- _ADD (_NUMERAL _0) _N === _N ∧ + (thy,[]) |- _ADD (_SUC _M) _N === _SUC (_ADD _M _N) ∧ + (* SUB *) + (thy,[]) |- _SUB (_NUMERAL _0) _N === _NUMERAL _0 ∧ + (thy,[]) |- _SUB _M (_NUMERAL _0) === _M ∧ + (thy,[]) |- _SUB (_SUC _M) (_SUC _N) === _SUB _M _N ∧ + (* MUL *) + (thy,[]) |- _MUL (_NUMERAL _0) _N === _NUMERAL _0 ∧ + (thy,[]) |- _MUL (_SUC _M) _N === _ADD _N (_MUL _M _N) ∧ + (* DIV, MOD *) + (thy,[]) |- _DIV _M _N === + _COND (_N === _NUMERAL _0) (_NUMERAL _0) + (_COND (_LESS _M _N) (_NUMERAL _0) + (_SUC (_DIV (_SUB _M _N) _N))) ∧ + (thy,[]) |- _MOD _M _N === + _COND (_N === _NUMERAL _0) _M + (_COND (_LESS _M _N) _M + (_MOD (_SUB _M _N) _N)) ∧ + (* LESS *) + (thy,[]) |- _LESS _M (_NUMERAL _0) === _FALSE ∧ + (thy,[]) |- _LESS (_NUMERAL _0) (_SUC _N) === _TRUE ∧ + (thy,[]) |- _LESS (_SUC _M) (_SUC _N) === _LESS _M _N ∧ + (* EQ *) + (thy,[]) |- (_NUMERAL _0 === _NUMERAL _0) === _TRUE ∧ + (thy,[]) |- (_NUMERAL _0 === _SUC _N) === _FALSE ∧ + (thy,[]) |- (_SUC _M === _NUMERAL _0) === _FALSE ∧ + (thy,[]) |- (_SUC _M === _SUC _N) === (_M === _N) +End + +Theorem numeral_thy_ok_theory_ok[simp]: + numeral_thy_ok thy ⇒ theory_ok thy +Proof + rw [numeral_thy_ok_def] + \\ drule proves_theory_ok \\ simp [] +QED + +Theorem numeral_thy_ok_bool_thy_ok[simp]: + numeral_thy_ok thy ⇒ bool_thy_ok thy +Proof + rw [numeral_thy_ok_def] +QED + +Theorem numeral_thy_ok_terms_ok: + numeral_thy_ok thy ⇒ + term_ok (sigof thy) _TRUE ∧ + term_ok (sigof thy) _FALSE ∧ + term_ok (sigof thy) _COND_TM ∧ + term_ok (sigof thy) _IF_TM ∧ + term_ok (sigof thy) _ADD_TM ∧ + term_ok (sigof thy) _SUB_TM ∧ + term_ok (sigof thy) _MUL_TM ∧ + term_ok (sigof thy) _DIV_TM ∧ + term_ok (sigof thy) _MOD_TM ∧ + term_ok (sigof thy) _LESS_TM ∧ + term_ok (sigof thy) _0 ∧ + term_ok (sigof thy) _SUC_TM ∧ + term_ok (sigof thy) _BIT0_TM ∧ + term_ok (sigof thy) _BIT1_TM ∧ + term_ok (sigof thy) _NUMERAL_TM +Proof + simp [numeral_thy_ok_def] \\ strip_tac + \\ dxrule_then assume_tac bool_thy_ok_terms_ok \\ gs [] + \\ rpt (dxrule_then assume_tac proves_term_ok) \\ rfs [] + \\ fs [equation_def, term_ok_def, SF SFY_ss] +QED + +Theorem term_ok_NUMERAL[simp]: + numeral_thy_ok thy ⇒ + term_ok (sigof thy) (_NUMERAL N) = (term_ok (sigof thy) N ∧ + N has_type Num) +Proof + rw [EQ_IMP_THM] + \\ gs [numeral_thy_ok_terms_ok, term_ok_def, term_ok_welltyped, + WELLTYPED_LEMMA, SF SFY_ss] + \\ drule_then (Lib.C (resolve_then Any mp_tac) (iffLR WELLTYPED)) + term_ok_welltyped + \\ gs [] +QED + +Theorem NUMERAL_has_type[simp]: + _NUMERAL N has_type Num ⇔ N has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +Theorem has_type_0[simp]: + _0 has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +Theorem term_ok_SUC[simp]: + numeral_thy_ok thy ⇒ + term_ok (sigof thy) (_SUC N) = (term_ok (sigof thy) N ∧ N has_type Num) +Proof + rw [EQ_IMP_THM] + \\ gs [numeral_thy_ok_terms_ok, term_ok_def, term_ok_welltyped, + WELLTYPED_LEMMA, SF SFY_ss] + \\ drule_then (Lib.C (resolve_then Any mp_tac) (iffLR WELLTYPED)) + term_ok_welltyped + \\ gs [] +QED + +Theorem SUC_has_type[simp]: + _SUC N has_type Num ⇔ N has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +(* The numeral_thy_ok theorems with object variables replaced with meta + variables. + *) + +Theorem NUMERAL_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ⇒ + (thy,[]) |- _NUMERAL n === n +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- _NUMERAL x === x’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem BIT0_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ⇒ + (thy,[]) |- _BIT0 n === _ADD n n +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- _BIT0 x === _ADD x x’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem BIT1_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ⇒ + (thy,[]) |- _BIT1 n === _SUC (_ADD n n) +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- _BIT1 _ === _SUC _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem ADD_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _ADD (_NUMERAL _0) n === n ∧ + (thy,[]) |- _ADD (_SUC m) n === _SUC (_ADD m n) +Proof + rw [numeral_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _ADD (_NUMERAL _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _ADD (_SUC _) _ === _SUC _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem SUB_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _SUB (_NUMERAL _0) n === _NUMERAL _0 ∧ + (thy,[]) |- _SUB m (_NUMERAL _0) === m ∧ + (thy,[]) |- _SUB (_SUC m) (_SUC n) === _SUB m n +Proof + rw [numeral_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _SUB (_NUMERAL _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + >- ( + qpat_x_assum ‘_ |- _SUB _ (_NUMERAL _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _SUB (_SUC _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem MUL_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _MUL (_NUMERAL _0) n === _NUMERAL _0 ∧ + (thy,[]) |- _MUL (_SUC m) n === _ADD n (_MUL m n) +Proof + rw [numeral_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _MUL (_NUMERAL _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _MUL (_SUC _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem LESS_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _LESS m (_NUMERAL _0) === _FALSE ∧ + (thy,[]) |- _LESS (_NUMERAL _0) (_SUC n) === _TRUE ∧ + (thy,[]) |- _LESS (_SUC m) (_SUC n) === _LESS m n +Proof + rw [numeral_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _LESS _ (_NUMERAL _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + >- ( + qpat_x_assum ‘_ |- _LESS (_NUMERAL _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _LESS (_SUC _) _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem EQ_eqn1: + numeral_thy_ok thy ⇒ + (thy,[]) |- (_NUMERAL _0 === _NUMERAL _0) === _TRUE +Proof + rw [numeral_thy_ok_def] +QED + +Theorem EQ_eqn2: + numeral_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ⇒ + (thy,[]) |- (_NUMERAL _0 === _SUC n) === _FALSE +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_NUMERAL _ === _SUC _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem EQ_eqn3: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- (_SUC m === _NUMERAL _0) === _FALSE +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_SUC _ === _NUMERAL _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) proves_INST + \\ simp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem EQ_eqn4: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- (_SUC m === _SUC n) === (m === n) +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_SUC _ === _SUC _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M;n,_N]’ mp_tac) proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] + \\ ‘Equal (typeof (_SUC m)) = Equal Num’ by gs [] + \\ pop_assum (SUBST1_TAC o SYM) \\ simp [GSYM equation_def] + \\ ‘Equal (typeof m) = Equal Num’ by gs [WELLTYPED_LEMMA] + \\ pop_assum (SUBST1_TAC o SYM) \\ simp [GSYM equation_def] +QED + +Theorem COND_eqn: + bool_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _COND _TRUE m n === m ∧ + (thy,[]) |- _COND _FALSE m n === n +Proof + rw [bool_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _COND _TRUE _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _COND _FALSE _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem IF_eqn: + bool_thy_ok thy ∧ + term_ok (sigof thy) x ∧ term_ok (sigof thy) y ∧ + x has_type Bool ∧ y has_type Bool ⇒ + (thy,[]) |- _IF _TRUE x y === x ∧ + (thy,[]) |- _IF _FALSE x y === y +Proof + rw [bool_thy_ok_def] + >- ( + qpat_x_assum ‘_ |- _IF _TRUE _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[x,_X; y,_Y]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def]) + \\ qpat_x_assum ‘_ |- _IF _FALSE _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[x,_X; y,_Y]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem DIV_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _DIV m n === + _COND (n === _NUMERAL _0) (_NUMERAL _0) + (_COND (_LESS m n) (_NUMERAL _0) + (_SUC (_DIV (_SUB m n) n))) +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- _DIV _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N;m,_M]’ mp_tac) proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def, SF DNF_ss] + \\ drule_then assume_tac WELLTYPED_LEMMA \\ gs [] +QED + +Theorem MOD_eqn: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _MOD m n === + _COND (n === _NUMERAL _0) m + (_COND (_LESS m n) m + (_MOD (_SUB m n) n)) +Proof + rw [numeral_thy_ok_def] + \\ qpat_x_assum ‘_ |- _MOD _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N;m,_M]’ mp_tac) proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def, SF DNF_ss] + \\ drule_then assume_tac WELLTYPED_LEMMA \\ gs [] +QED + +(* TODO Move *) +Theorem COND_has_type[simp]: + _COND p m n has_type Num ⇔ + p has_type Bool ∧ m has_type Num ∧ n has_type Num +Proof + rw [Ntimes has_type_cases 3] + \\ rw [Ntimes has_type_cases 3] +QED + +(* TODO Move *) +Theorem LESS_has_type[simp]: + _LESS m n has_type Bool ⇔ m has_type Num ∧ n has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +(* TODO Move *) +Theorem SUB_has_type[simp]: + _SUB m n has_type Num ⇔ m has_type Num ∧ n has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +(* TODO Move *) +Theorem MOD_has_type[simp]: + _MOD m n has_type Num ⇔ m has_type Num ∧ n has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +(* TODO Move *) +Theorem DIV_has_type[simp]: + _DIV m n has_type Num ⇔ m has_type Num ∧ n has_type Num +Proof + rw [Ntimes has_type_cases 3] +QED + +Theorem MOD_eqn1: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- _MOD m (_NUMERAL _0) === m +Proof + rw [] + \\ irule trans_equation_simple + \\ drule_then (qspecl_then [‘_NUMERAL _0’,‘m’] mp_tac) MOD_eqn + \\ simp [numeral_thy_ok_terms_ok] + \\ disch_then (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL3 + \\ qexists_tac ‘_TRUE’ + \\ conj_tac >- fs [numeral_thy_ok_def] + \\ irule (COND_eqn |> UNDISCH_ALL |> CONJUNCT1 |> DISCH_ALL) \\ gs [] + \\ simp [term_ok_def, numeral_thy_ok_terms_ok, term_ok_welltyped, + WELLTYPED_LEMMA, SF SFY_ss] +QED + +Theorem DIV_eqn1: + numeral_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- _DIV m (_NUMERAL _0) === _NUMERAL _0 +Proof + rw [] + \\ irule trans_equation_simple + \\ drule_then (qspecl_then [‘_NUMERAL _0’,‘m’] mp_tac) DIV_eqn + \\ simp [numeral_thy_ok_terms_ok] + \\ disch_then (irule_at Any) + \\ resolve_then Any irule sym_equation replaceL3 + \\ qexists_tac ‘_TRUE’ + \\ conj_tac >- fs [numeral_thy_ok_def] + \\ irule (COND_eqn |> UNDISCH_ALL |> CONJUNCT1 |> DISCH_ALL) \\ gs [] + \\ simp [term_ok_def, numeral_thy_ok_terms_ok, term_ok_welltyped, + WELLTYPED_LEMMA, SF SFY_ss] +QED + +Theorem BIT0_0: + numeral_thy_ok thy ⇒ + (thy,[]) |- _BIT0 _0 === _0 +Proof + strip_tac + \\ ‘term_ok (sigof thy) _0 ∧ _0 has_type Num’ + by gs [numeral_thy_ok_terms_ok, term_ok_def, has_type_rules] + \\ drule_all_then assume_tac BIT0_eqn + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ drule_all_then assume_tac (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL ADD_eqn))) + \\ irule replaceL1 + \\ irule_at Any NUMERAL_eqn \\ simp [] +QED + +(* ------------------------------------------------------------------------- + * num2term, num2bit + * ------------------------------------------------------------------------- *) + +Theorem num2term_typeof[simp]: + typeof (num2term n) = Num +Proof + Induct_on ‘n’ \\ simp [num2term_def] +QED + +Theorem num2term_has_type[simp]: + num2term n has_type Num +Proof + Induct_on ‘n’ \\ rw [num2term_def] + \\ rw [Once has_type_cases] + \\ rw [Once has_type_cases] +QED + +Theorem num2term_welltyped[simp]: + welltyped (num2term n) +Proof + rw [welltyped_def, num2term_has_type, SF SFY_ss] +QED + +Theorem num2term_term_ok: + numeral_thy_ok thy ⇒ term_ok (sigof thy) (num2term n) +Proof + strip_tac + \\ drule_then strip_assume_tac numeral_thy_ok_terms_ok + \\ Induct_on ‘n’ \\ rw [numeral_thy_ok_def, term_ok_def, num2term_def] +QED + +Theorem num2term_VSUBST[simp]: + ∀n. VSUBST is (num2term n) = num2term n +Proof + Induct \\ rw [num2term_def, VSUBST_def] +QED + +Theorem num2bit_typeof[simp]: + ∀n. typeof (num2bit n) = Num +Proof + ho_match_mp_tac num2bit_ind \\ rw [] + \\ rw [Once num2bit_def] +QED + +Theorem num2bit_has_type[simp]: + ∀n. num2bit n has_type Num +Proof + ho_match_mp_tac num2bit_ind \\ rw [] + \\ rw [Once num2bit_def] + \\ rw [Ntimes has_type_cases 3] +QED + +Theorem num2bit_welltyped[simp]: + ∀n. welltyped (num2bit n) +Proof + rw [welltyped_def, num2bit_has_type, SF SFY_ss] +QED + +Theorem num2bit_term_ok: + numeral_thy_ok thy ⇒ term_ok (sigof thy) (num2bit n) +Proof + strip_tac + \\ drule_then strip_assume_tac numeral_thy_ok_terms_ok + \\ qid_spec_tac ‘n’ + \\ ho_match_mp_tac num2bit_ind \\ rw [] + \\ rw [Once num2bit_def, term_ok_def] +QED + +Theorem num2bit_VSUBST[simp]: + ∀n. VSUBST is (num2bit n) = num2bit n +Proof + ho_match_mp_tac num2bit_ind \\ rw [] + \\ once_rewrite_tac [num2bit_def] + \\ rw [VSUBST_def] +QED + +Theorem num2term_ADD: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2term (m + n) === _ADD (num2term m) (num2term n) +Proof + strip_tac \\ irule sym_equation \\ qid_spec_tac ‘m’ + \\ Induct \\ simp [] + >- ( + rw [num2term_def] + \\ qabbrev_tac ‘M = num2term n’ + \\ irule replaceL1 + \\ irule_at Any NUMERAL_eqn + \\ simp [numeral_thy_ok_terms_ok, has_type_rules] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok] + \\ rw [ADD_eqn, SF SFY_ss]) + \\ rw [ADD_CLAUSES, num2term_def] \\ fs [] + \\ qmatch_goalsub_abbrev_tac ‘_ADD (_SUC N) M’ + \\ ‘term_ok (sigof thy) M ∧ M has_type Num ∧ + term_ok (sigof thy) N ∧ N has_type Num’ + by fs [Abbr ‘M’, Abbr ‘N’, num2term_term_ok] + \\ irule replaceR2 + \\ first_x_assum (irule_at Any) + \\ csimp [numeral_thy_ok_terms_ok, term_ok_def, term_ok_welltyped, + num2term_term_ok, WELLTYPED_LEMMA, SF SFY_ss] + \\ rw [ADD_eqn, sym_equation, SF SFY_ss] +QED + +Theorem ADD_num2term = + UNDISCH_ALL num2term_ADD |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2term_SUB: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2term (m - n) === _SUB (num2term m) (num2term n) +Proof + strip_tac + \\ ‘∀m n. (thy,[]) |- _SUB (num2term m) (num2term n) === num2term (m - n)’ + suffices_by rw [sym_equation] + \\ Induct \\ simp [] + >- ( + rw [num2term_def] + \\ qabbrev_tac ‘M = num2term n’ + \\ irule replaceL1 + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ irule trans_equation_simple + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok, numeral_thy_ok_terms_ok] + \\ rw [SUB_eqn, SF SFY_ss]) + \\ Cases \\ gs [num2term_def] + >- ( + qabbrev_tac ‘M = _SUC (num2term m)’ + \\ irule replaceL2 + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok, numeral_thy_ok_terms_ok] + \\ rw [SUB_eqn, SF SFY_ss]) + \\ rename [‘m - n’] + \\ first_x_assum (qspec_then ‘n’ assume_tac) \\ gs [] + \\ resolve_then Any irule sym_equation trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ simp [SUB_eqn, sym_equation, num2term_term_ok] +QED + +Theorem SUB_num2term = + UNDISCH_ALL num2term_SUB |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2term_MUL: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2term (m * n) === _MUL (num2term m) (num2term n) +Proof + strip_tac + \\ ‘∀m. (thy,[]) |- _MUL (num2term m) (num2term n) === num2term (m * n)’ + suffices_by rw [sym_equation] + \\ Induct \\ simp [] + >- ( + rw [num2term_def] + \\ qabbrev_tac ‘M = num2term n’ + \\ irule replaceL1 + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ irule trans_equation_simple + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok, numeral_thy_ok_terms_ok] + \\ rw [MUL_eqn, SF SFY_ss]) + \\ rw [MULT_SUC, num2term_def] + \\ irule trans_equation_simple \\ irule_at Any ADD_num2term \\ gs [] + \\ irule replaceR2 \\ first_x_assum (irule_at Any) + \\ rw [MUL_eqn, sym_equation, num2term_term_ok] +QED + +Theorem MUL_num2term = + UNDISCH_ALL num2term_MUL |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem bool2term_LESS_num2term: + numeral_thy_ok thy ⇒ + (thy,[]) |- bool2term (m < n) === _LESS (num2term m) (num2term n) +Proof + strip_tac + \\ ‘∀m n. (thy,[]) |- _LESS (num2term m) (num2term n) === bool2term (m < n)’ + suffices_by rw [sym_equation] + \\ Induct \\ simp [] + >- ( + Cases \\ rw [num2term_def, bool2term_def] + >- ( + irule replaceL2 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any (CONJUNCT1 (SIMPR [IMP_CONJ_THM, SF DNF_ss] LESS_eqn)) + \\ qexists_tac ‘_0’ \\ gs [numeral_thy_ok_terms_ok]) + \\ qmatch_goalsub_abbrev_tac ‘_SUC M’ + \\ irule replaceL1 + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok, numeral_thy_ok_terms_ok] + \\ rw [LESS_eqn, SF SFY_ss]) + \\ Cases \\ gs [num2term_def, bool2term_def] + >- ( + qmatch_goalsub_abbrev_tac ‘_LESS M _’ + \\ irule replaceL2 + \\ irule_at Any NUMERAL_eqn \\ simp [numeral_thy_ok_terms_ok] + \\ ‘term_ok (sigof thy) M ∧ M has_type Num’ + by fs [Abbr ‘M’, num2term_term_ok, numeral_thy_ok_terms_ok] + \\ rw [LESS_eqn, SF SFY_ss]) + \\ rename [‘m < n’] + \\ first_x_assum (qspec_then ‘n’ assume_tac) \\ gs [] + \\ resolve_then Any irule sym_equation trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ simp [LESS_eqn, sym_equation, num2term_term_ok] +QED + +Theorem LESS_bool2term_num2term = + UNDISCH_ALL bool2term_LESS_num2term |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem bool2term_EQ_num2term: + numeral_thy_ok thy ⇒ + (thy,[]) |- bool2term (m = n) === (num2term m === num2term n) +Proof + strip_tac + \\ ‘∀m n. (thy,[]) |- (num2term m === num2term n) === bool2term (m = n)’ + suffices_by rw [sym_equation] + \\ Induct \\ simp [] + >- ( + Cases \\ rw [num2term_def, bool2term_def] + >- ( + irule replaceL_eq1 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any replaceL_eq2 \\ irule_at Any NUMERAL_eqn + \\ gs [numeral_thy_ok_terms_ok, EQ_eqn1]) + \\ irule replaceL_eq1 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any EQ_eqn2 \\ gs [num2term_term_ok, numeral_thy_ok_terms_ok]) + \\ Cases \\ gs [num2term_def, bool2term_def] + >- ( + irule replaceL_eq2 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any EQ_eqn3 \\ gs [num2term_term_ok, numeral_thy_ok_terms_ok]) + \\ rename [‘m = n’] + \\ first_x_assum (qspec_then ‘n’ assume_tac) \\ gs [] + \\ irule trans_equation_simple \\ first_x_assum (irule_at Any) + \\ irule EQ_eqn4 \\ gs [num2term_term_ok] +QED + +Theorem EQ_bool2term_num2term = + UNDISCH_ALL bool2term_EQ_num2term |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem SUB_DIV: + ∀m n. 0 < n ∧ n ≤ m ⇒ SUC ((m - n) DIV n) = m DIV n +Proof + rw [LESS_OR_EQ] \\ gs [DIVMOD_ID, ZERO_DIV] + \\ qspecl_then [‘1’,‘n’,‘m’] assume_tac (GEN_ALL DIV_SUB) \\ gs [] + \\ ‘SUC (PRE (m DIV n)) = m DIV n’ + suffices_by rw [prim_recTheory.PRE, ADD1] + \\ irule (iffLR SUC_PRE) + \\ gs [X_LT_DIV] +QED + +Theorem DIV_num2term: + numeral_thy_ok thy ⇒ + (thy,[]) |-_DIV (num2term m) (num2term n) === num2term (m SAFEDIV n) +Proof + strip_tac + \\ qid_spec_tac ‘n’ \\ qid_spec_tac ‘m’ + \\ completeInduct_on ‘m’ \\ gen_tac + \\ Cases_on ‘m’ + >- ((* m = 0 *) + gs [num2term_def, SAFEDIV_def] + \\ irule replaceL1 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple \\ irule_at Any DIV_eqn + \\ simp [term_ok_def, numeral_thy_ok_terms_ok, num2term_term_ok] + \\ Cases_on ‘n’ \\ gs [num2term_def] + >- ( + ‘(thy,[]) |- (_0 === _NUMERAL _0) === (_NUMERAL _0 === _NUMERAL _0)’ + by simp [DEDUCT_ANTISYM_simple, proves_REFL, NUMERAL_eqn, sym_equation, + numeral_thy_ok_terms_ok] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_x_assum (irule_at Any) + \\ irule replaceL3 + \\ irule_at Any sym_equation + \\ qexists_tac ‘_TRUE’ + \\ conj_tac >- fs [numeral_thy_ok_def] + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, term_ok_def, proves_REFL]) + \\ irule replaceL3 + \\ qexists_tac ‘_FALSE’ + \\ conj_tac + >- ( + irule sym_equation + \\ irule EQ_eqn3 \\ gs [num2term_term_ok]) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL] + \\ resolve_then Any irule sym_equation replaceL3 + \\ qexists_tac ‘_TRUE’ + \\ irule_at Any (DISCH_ALL (cj 2 (UNDISCH_ALL LESS_eqn))) + \\ qexists_tac ‘_0’ \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok] + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL, + num2term_def, ZERO_DIV]) + \\ rename [‘SUC m’] + \\ gs [SAFEDIV_def] + \\ IF_CASES_TAC \\ gs [num2term_def] + >- ((* n = 0 *) + irule replaceL2 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple \\ irule_at Any NUMERAL_eqn + \\ gs [numeral_thy_ok_terms_ok, DIV_eqn1, num2term_term_ok]) + \\ irule trans_equation_simple \\ irule_at Any DIV_eqn + \\ gs [num2term_term_ok] + \\ Cases_on ‘n’ \\ gs [num2term_def] \\ rename [‘_SUC (num2term n)’] + \\ irule replaceL3 + \\ qexists_tac ‘_FALSE’ + \\ conj_tac + >- ( + irule sym_equation + \\ irule EQ_eqn3 \\ gs [num2term_term_ok]) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL] + \\ drule_then (qspecl_then [‘SUC n’,‘SUC m’] assume_tac) + bool2term_LESS_num2term + \\ Cases_on ‘m < n’ \\ gs [bool2term_def, num2term_def] + >- ( + irule replaceL3 \\ first_x_assum (irule_at Any) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL, + LESS_DIV_EQ_ZERO, num2term_def, NUMERAL_eqn]) + \\ irule replaceL3 \\ first_x_assum (irule_at Any) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL, + num2term_def] + \\ simp [Q.SPECL [‘SUC m’,‘SUC n’] SUB_DIV |> SIMPR [SUB] |> GSYM, + proves_REFL, num2term_term_ok, num2term_def] + \\ irule MK_COMB_simple \\ gs [proves_REFL, numeral_thy_ok_terms_ok] + \\ resolve_then Any irule sym_equation replaceL1 + \\ irule_at Any (DISCH_ALL (cj 3 (UNDISCH_ALL SUB_eqn))) + \\ gs [num2term_term_ok] + \\ resolve_then Any irule sym_equation replaceL1 + \\ irule_at Any SUB_num2term \\ gs [PULL_FORALL] + \\ first_x_assum (qspecl_then [‘SUC m - SUC n’,‘SUC n’] assume_tac) + \\ gs [num2term_def] +QED + +Theorem num2term_DIV = + UNDISCH_ALL DIV_num2term |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem MOD_num2term: + numeral_thy_ok thy ⇒ + (thy,[]) |-_MOD (num2term m) (num2term n) === num2term (m SAFEMOD n) +Proof + strip_tac + \\ qid_spec_tac ‘n’ \\ qid_spec_tac ‘m’ + \\ completeInduct_on ‘m’ \\ gen_tac + \\ Cases_on ‘m’ + >- ((* m = 0 *) + simp [num2term_def, SAFEMOD_def] + \\ irule replaceL1 \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple \\ irule_at Any MOD_eqn + \\ simp [term_ok_def, numeral_thy_ok_terms_ok, num2term_term_ok] + \\ Cases_on ‘n’ \\ gs [num2term_def] + >- ( + ‘(thy,[]) |- (_0 === _NUMERAL _0) === (_NUMERAL _0 === _NUMERAL _0)’ + by simp [DEDUCT_ANTISYM_simple, proves_REFL, NUMERAL_eqn, sym_equation, + numeral_thy_ok_terms_ok] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_x_assum (irule_at Any) + \\ irule replaceL3 + \\ irule_at Any sym_equation + \\ qexists_tac ‘_TRUE’ + \\ conj_tac >- fs [numeral_thy_ok_def] + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, term_ok_def, proves_REFL]) + \\ irule replaceL3 + \\ qexists_tac ‘_FALSE’ + \\ conj_tac + >- ( + irule sym_equation + \\ irule EQ_eqn3 \\ gs [num2term_term_ok]) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL] + \\ resolve_then Any irule sym_equation replaceL3 + \\ qexists_tac ‘_TRUE’ + \\ irule_at Any (DISCH_ALL (cj 2 (UNDISCH_ALL LESS_eqn))) + \\ qexists_tac ‘_0’ \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok] + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL]) + \\ rename [‘SUC m’] + \\ gs [SAFEMOD_def] + \\ IF_CASES_TAC \\ gs [num2term_def] + >- ((* n = 0 *) + irule replaceL2 \\ irule_at Any NUMERAL_eqn + \\ gs [numeral_thy_ok_terms_ok, MOD_eqn1, num2term_term_ok]) + \\ irule trans_equation_simple \\ irule_at Any MOD_eqn + \\ gs [num2term_term_ok] + \\ Cases_on ‘n’ \\ gs [num2term_def] \\ rename [‘_SUC (num2term n)’] + \\ irule replaceL3 + \\ qexists_tac ‘_FALSE’ + \\ conj_tac + >- ( + irule sym_equation + \\ irule EQ_eqn3 \\ gs [num2term_term_ok]) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL] + \\ drule_then (qspecl_then [‘SUC n’,‘SUC m’] assume_tac) + bool2term_LESS_num2term + \\ Cases_on ‘m < n’ \\ gs [bool2term_def, num2term_def] + >- ( + irule replaceL3 \\ first_x_assum (irule_at Any) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT1 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL, + num2term_def]) + \\ irule replaceL3 \\ first_x_assum (irule_at Any) + \\ irule trans_equation_simple + \\ irule_at Any (DISCH_ALL (CONJUNCT2 (UNDISCH_ALL COND_eqn))) + \\ gs [numeral_thy_ok_terms_ok, num2term_term_ok, term_ok_def, proves_REFL, + num2term_def] + \\ simp [Q.SPECL [‘SUC m’,‘SUC n’] SUB_MOD |> SIMPR [SUB] |> GSYM, + proves_REFL, num2term_term_ok] + \\ resolve_then Any irule sym_equation replaceL1 + \\ irule_at Any (DISCH_ALL (cj 3 (UNDISCH_ALL SUB_eqn))) + \\ gs [num2term_term_ok] + \\ resolve_then Any irule sym_equation replaceL1 + \\ irule_at Any SUB_num2term \\ gs [PULL_FORALL] + \\ first_x_assum (qspecl_then [‘SUC m - SUC n’,‘SUC n’] assume_tac) + \\ gs [num2term_def] +QED + +Theorem num2term_MOD = + UNDISCH_ALL MOD_num2term |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2bit_num2term: + numeral_thy_ok thy ⇒ + ∀n. (thy,[]) |- num2bit n === num2term n +Proof + strip_tac \\ ho_match_mp_tac num2bit_ind \\ rw [] + \\ ‘term_ok (sigof thy) _0 ∧ _0 has_type Num’ + by fs [numeral_thy_ok_terms_ok, has_type_rules] + \\ rw [num2term_def, Once num2bit_def, proves_REFL] + >- ( + qabbrev_tac ‘N = num2term (n DIV 2)’ + \\ ‘term_ok (sigof thy) N ∧ N has_type Num’ + by fs [Abbr ‘N’, num2term_term_ok] + \\ ‘(thy,[]) |- _BIT0 (num2bit (n DIV 2)) === _BIT0 N’ + by rw [MK_COMB_simple, proves_REFL, numeral_thy_ok_terms_ok] + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ ‘(thy,[]) |- _ADD N N === num2term n’ + suffices_by ( + strip_tac + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ simp [BIT0_eqn]) + \\ fs [Abbr ‘N’] + \\ ‘num2term n = num2term (n DIV 2 + n DIV 2)’ + by (AP_TERM_TAC \\ intLib.ARITH_TAC) + \\ pop_assum SUBST1_TAC + \\ irule_at Any ADD_num2term \\ fs []) + >- ( + qabbrev_tac ‘N = num2term (n DIV 2)’ + \\ ‘term_ok (sigof thy) N ∧ N has_type Num’ + by fs [Abbr ‘N’, num2term_term_ok] + \\ ‘(thy,[]) |- _BIT1 (num2bit (n DIV 2)) === _BIT1 N’ + by rw [MK_COMB_simple, proves_REFL, numeral_thy_ok_terms_ok] + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ ‘(thy,[]) |- _SUC (_ADD N N) === num2term n’ + suffices_by ( + strip_tac + \\ irule trans_equation_simple + \\ first_x_assum (irule_at Any) + \\ simp [BIT1_eqn]) + \\ ‘num2term n = _SUC (num2term (2 * (n DIV 2)))’ + by (‘n = SUC (n DIV 2 + n DIV 2)’ by intLib.ARITH_TAC + \\ pop_assum (fn th => simp [SimpLHS, Once th]) + \\ simp [num2term_def]) + \\ pop_assum SUBST1_TAC + \\ irule MK_COMB_simple + \\ simp [term_ok_welltyped, WELLTYPED_LEMMA, proves_REFL, + numeral_thy_ok_terms_ok, SF SFY_ss] + \\ qunabbrev_tac ‘N’ + \\ ‘2 * (n DIV 2) = n DIV 2 + n DIV 2’ + by rw [] + \\ pop_assum SUBST1_TAC + \\ rw [ADD_num2term]) +QED + +Theorem num2bit_ADD: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2bit (m + n) === _ADD (num2bit m) (num2bit n) +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceR1 \\ irule_at Any sym_equation + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceL2 + \\ irule_at Any sym_equation \\ irule_at Any num2bit_num2term + \\ fs [ADD_num2term] +QED + +Theorem ADD_num2bit = + UNDISCH_ALL num2bit_ADD |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2bit_SUB: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2bit (m - n) === _SUB (num2bit m) (num2bit n) +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceR1 \\ irule_at Any sym_equation + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceL2 + \\ irule_at Any sym_equation \\ irule_at Any num2bit_num2term + \\ fs [SUB_num2term] +QED + +Theorem SUB_num2bit = + UNDISCH_ALL num2bit_SUB |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2bit_MUL: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2bit (m * n) === _MUL (num2bit m) (num2bit n) +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceR1 \\ irule_at Any sym_equation + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceL2 + \\ irule_at Any sym_equation \\ irule_at Any num2bit_num2term + \\ fs [MUL_num2term] +QED + +Theorem MUL_num2bit = + UNDISCH_ALL num2bit_MUL |> MATCH_MP sym_equation |> DISCH_ALL; + + +Theorem num2bit_DIV: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2bit (m SAFEDIV n) === _DIV (num2bit m) (num2bit n) +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceR1 \\ irule_at Any sym_equation + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceL2 + \\ irule_at Any sym_equation \\ irule_at Any num2bit_num2term + \\ fs [DIV_num2term] +QED + +Theorem DIV_num2bit = + UNDISCH_ALL num2bit_DIV |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem num2bit_MOD: + numeral_thy_ok thy ⇒ + (thy,[]) |- num2bit (m SAFEMOD n) === _MOD (num2bit m) (num2bit n) +Proof + strip_tac + \\ irule trans_equation_simple + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceR1 \\ irule_at Any sym_equation + \\ irule_at Any num2bit_num2term + \\ irule_at Any replaceL2 + \\ irule_at Any sym_equation \\ irule_at Any num2bit_num2term + \\ fs [MOD_num2term] +QED + +Theorem MOD_num2bit = + UNDISCH_ALL num2bit_MOD |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem bool2term_LESS_num2bit: + numeral_thy_ok thy ⇒ + (thy,[]) |- bool2term (m < n) === _LESS (num2bit m) (num2bit n) +Proof + strip_tac + \\ resolve_then Any irule sym_equation replaceR1 + \\ irule_at Any num2bit_num2term \\ gs [] + \\ resolve_then Any irule sym_equation replaceL2 + \\ irule_at Any num2bit_num2term \\ gs [] + \\ fs [LESS_bool2term_num2term] +QED + +Theorem LESS_bool2term_num2bit = + UNDISCH_ALL bool2term_LESS_num2bit |> MATCH_MP sym_equation |> DISCH_ALL; + +Theorem bool2term_EQ_num2bit: + numeral_thy_ok thy ⇒ + (thy,[]) |- bool2term (m = n) === (num2bit m === num2bit n) +Proof + strip_tac + \\ resolve_then Any irule sym_equation replaceR_eq1 + \\ irule_at Any num2bit_num2term \\ gs [] + \\ resolve_then Any irule sym_equation replaceL_eq2 + \\ irule_at Any num2bit_num2term \\ gs [] + \\ fs [EQ_bool2term_num2term] +QED + +Theorem EQ_bool2term_num2bit = + UNDISCH_ALL bool2term_EQ_num2bit |> MATCH_MP sym_equation |> DISCH_ALL; + +(* ------------------------------------------------------------------------- + * Compute values + * ------------------------------------------------------------------------- *) + +Definition cexp_consts_def: + cexp_consts (Num n) = {} ∧ + cexp_consts (Var s) = {} ∧ + cexp_consts (Pair p q) = cexp_consts p ∪ cexp_consts q ∧ + cexp_consts (Uop uop p) = cexp_consts p ∧ + cexp_consts (Binop bop p q) = cexp_consts p ∪ cexp_consts q ∧ + cexp_consts (If p q r) = cexp_consts p ∪ cexp_consts q ∪ cexp_consts r ∧ + cexp_consts (Let s p q) = cexp_consts p ∪ cexp_consts q ∧ + cexp_consts (App s cs) = {s, LENGTH cs} ∪ BIGUNION (set (MAP cexp_consts cs)) +Termination + wf_rel_tac ‘measure compute_exp_size’ +End + +Definition cexp_vars_def: + cexp_vars (Num n) = {} ∧ + cexp_vars (Var s) = {s} ∧ + cexp_vars (Pair p q) = cexp_vars p ∪ cexp_vars q ∧ + cexp_vars (Uop uop p) = cexp_vars p ∧ + cexp_vars (Binop bop p q) = cexp_vars p ∪ cexp_vars q ∧ + cexp_vars (If p q r) = cexp_vars p ∪ cexp_vars q ∪ cexp_vars r ∧ + cexp_vars (Let s p q) = cexp_vars p ∪ (cexp_vars q DIFF {s}) ∧ + cexp_vars (App s cs) = BIGUNION (set (MAP cexp_vars cs)) +Termination + wf_rel_tac ‘measure compute_exp_size’ +End + +(* The semantics of 'ill-typed' operations on the compute_exp type is to + * return the number 0 (i.e. Num 0n). + *) + +Definition compute_thy_ok_def: + compute_thy_ok thy ⇔ + numeral_thy_ok thy ∧ + (* Cexp_add *) + (thy,[]) |- _CEXP_ADD (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_ADD _M _N) ∧ + (thy,[]) |- _CEXP_ADD (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M ∧ + (thy,[]) |- _CEXP_ADD (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM _N ∧ + (thy,[]) |- _CEXP_ADD (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_sub *) + (thy,[]) |- _CEXP_SUB (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_SUB _M _N) ∧ + (thy,[]) |- _CEXP_SUB (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M ∧ + (thy,[]) |- _CEXP_SUB (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_SUB (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_mul *) + (thy,[]) |- _CEXP_MUL (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_MUL _M _N) ∧ + (thy,[]) |- _CEXP_MUL (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_MUL (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_MUL (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_div *) + (thy,[]) |- _CEXP_DIV (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_DIV _M _N) ∧ + (thy,[]) |- _CEXP_DIV (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_DIV (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_DIV (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_mod *) + (thy,[]) |- _CEXP_MOD (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_MOD _M _N) ∧ + (thy,[]) |- _CEXP_MOD (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM _M ∧ + (thy,[]) |- _CEXP_MOD (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_MOD (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_less *) + (thy,[]) |- _CEXP_LESS (_CEXP_NUM _M) (_CEXP_NUM _N) === + _CEXP_NUM (_COND (_LESS _M _N) (_SUC (_NUMERAL _0)) + (_NUMERAL _0)) ∧ + (thy,[]) |- _CEXP_LESS (_CEXP_NUM _M) (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_LESS (_CEXP_PAIR _P1 _Q1) (_CEXP_NUM _N) === + _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_LESS (_CEXP_PAIR _P1 _Q1) (_CEXP_PAIR _P2 _Q2) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_if *) + (thy,[]) |- _CEXP_IF (_CEXP_NUM (_SUC _M)) _P1 _Q1 === _P1 ∧ + (thy,[]) |- _CEXP_IF (_CEXP_PAIR _P2 _Q2) _P1 _Q1 === _P1 ∧ + (thy,[]) |- _CEXP_IF (_CEXP_NUM (_NUMERAL _0)) _P1 _Q1 === _Q1 ∧ + (* Cexp_fst, Cexp_snd *) + (thy,[]) |- _CEXP_FST (_CEXP_PAIR _P1 _Q1) === _P1 ∧ + (thy,[]) |- _CEXP_FST (_CEXP_NUM _M) === _CEXP_NUM (_NUMERAL _0) ∧ + (thy,[]) |- _CEXP_SND (_CEXP_PAIR _P1 _Q1) === _Q1 ∧ + (thy,[]) |- _CEXP_SND (_CEXP_NUM _M) === _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_ispair *) + (thy,[]) |- _CEXP_ISPAIR (_CEXP_PAIR _P1 _Q1) === + _CEXP_NUM (_SUC (_NUMERAL _0)) ∧ + (thy,[]) |- _CEXP_ISPAIR (_CEXP_NUM _M) === + _CEXP_NUM (_NUMERAL _0) ∧ + (* Cexp_eq *) + (thy,[]) |- _CEXP_EQ _P1 _Q1 === + _CEXP_NUM (_COND (_P1 === _Q1)(_SUC (_NUMERAL _0)) + (_NUMERAL _0)) ∧ + (thy,[]) |- (_CEXP_PAIR _P1 _Q1 === _CEXP_PAIR _P2 _Q2) === + (_IF (_P1 === _P2) (_Q1 === _Q2) _FALSE) ∧ + (thy,[]) |- (_CEXP_NUM _M === _CEXP_NUM _N) === (_M === _N) ∧ + (thy,[]) |- (_CEXP_NUM _M === _CEXP_PAIR _P1 _Q1) === _FALSE ∧ + (thy,[]) |- (_CEXP_PAIR _P1 _Q1 === _CEXP_NUM _N) === _FALSE ∧ + (* Let *) + (thy,[]) |- _LET _F _P1 === Comb _F _P1 +End + +Theorem LET_eqn: + compute_thy_ok thy ∧ + term_ok (sigof thy) f ∧ term_ok (sigof thy) p1 ∧ + f has_type (Fun Cexp Cexp) ∧ p1 has_type Cexp ⇒ + (thy,[]) |- _LET f p1 === Comb f p1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _LET _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; f,_F]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_IF_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_IF (_CEXP_NUM (_SUC m)) p1 q1 === p1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_IF (_CEXP_NUM (_SUC _)) _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_IF_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_IF (_CEXP_PAIR p2 q2) p1 q1 === p1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_IF (_CEXP_PAIR _ _ ) _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_IF_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_IF (_CEXP_NUM (_NUMERAL _0)) p1 q1 === q1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_IF (_CEXP_NUM (_NUMERAL _)) _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ADD_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_ADD (_CEXP_NUM m) (_CEXP_NUM n) === _CEXP_NUM (_ADD m n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ADD _ _ === _CEXP_NUM (_ADD _ _)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ADD_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_ADD (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === _CEXP_NUM m +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ADD x _ === x’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ADD_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_ADD (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === _CEXP_NUM n +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ADD _ x === x’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ADD_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_ADD (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ADD _ _ === _CEXP_NUM (_NUMERAL _0)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SUB_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_SUB (_CEXP_NUM m) (_CEXP_NUM n) === _CEXP_NUM (_SUB m n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SUB _ _ === _CEXP_NUM (_SUB _ _)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SUB_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_SUB (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === _CEXP_NUM m +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SUB x _ === x’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SUB_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_SUB (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SUB (_CEXP_PAIR _ _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SUB_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_SUB (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SUB (_CEXP_PAIR _ _) (_CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MUL_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_MUL (_CEXP_NUM m) (_CEXP_NUM n) === _CEXP_NUM (_MUL m n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MUL (_CEXP_NUM _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MUL_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MUL (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MUL (_CEXP_NUM _) (_CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MUL_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MUL (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MUL (_CEXP_PAIR _ _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MUL_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MUL (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MUL (_CEXP_PAIR _ _) (_CEXP_PAIR _ _) === + _CEXP_NUM (_NUMERAL _0)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_DIV_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_DIV (_CEXP_NUM m) (_CEXP_NUM n) === _CEXP_NUM (_DIV m n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_DIV (_CEXP_NUM _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_DIV_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_DIV (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_DIV (_CEXP_NUM _) (_CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_DIV_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_DIV (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_DIV (_CEXP_PAIR _ _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_DIV_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_DIV (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_DIV (_CEXP_PAIR _ _) (_CEXP_PAIR _ _) === + _CEXP_NUM (_NUMERAL _0)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MOD_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_MOD (_CEXP_NUM m) (_CEXP_NUM n) === _CEXP_NUM (_MOD m n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MOD (_CEXP_NUM _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MOD_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MOD (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === + _CEXP_NUM m +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MOD (_CEXP_NUM _) (_CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MOD_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MOD (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MOD (_CEXP_PAIR _ _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_MOD_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_MOD (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_MOD (_CEXP_PAIR _ _) (_CEXP_PAIR _ _) === + _CEXP_NUM (_NUMERAL _0)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_LESS_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) n ∧ + m has_type Num ∧ n has_type Num ⇒ + (thy,[]) |- _CEXP_LESS (_CEXP_NUM m) (_CEXP_NUM n) === + _CEXP_NUM (_COND (_LESS m n) (_SUC (_NUMERAL _0)) + (_NUMERAL _0)) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_LESS _ _ === _CEXP_NUM (_COND _ _ _)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_LESS_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + m has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_LESS (_CEXP_NUM m) (_CEXP_PAIR p1 q1) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_LESS (_CEXP_NUM _) (_CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_LESS_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + n has_type Num ∧ p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_LESS (_CEXP_PAIR p1 q1) (_CEXP_NUM n) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_LESS (_CEXP_PAIR _ _) (_CEXP_NUM _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1; n,_N]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_LESS_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + term_ok (sigof thy) p2 ∧ term_ok (sigof thy) q2 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ∧ + p2 has_type Cexp ∧ q2 has_type Cexp ⇒ + (thy,[]) |- _CEXP_LESS (_CEXP_PAIR p1 q1) (_CEXP_PAIR p2 q2) === + _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_LESS (_CEXP_PAIR _ _) (_CEXP_PAIR _ _) === + _CEXP_NUM (_NUMERAL _0)’ assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1; q1,_Q1; p2,_P2; q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_FST_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_FST (_CEXP_PAIR p1 q1) === p1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_FST (_CEXP_PAIR _ _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_FST_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- _CEXP_FST (_CEXP_NUM m) === _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_FST (_CEXP_NUM _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SND_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_SND (_CEXP_PAIR p1 q1) === q1 +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SND (_CEXP_PAIR _ _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_SND_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- _CEXP_SND (_CEXP_NUM m) === _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_SND (_CEXP_NUM _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ISPAIR_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ term_ok (sigof thy) q1 ∧ + p1 has_type Cexp ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_ISPAIR (_CEXP_PAIR p1 q1) === + _CEXP_NUM (_SUC (_NUMERAL _0)) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ISPAIR (_CEXP_PAIR _ _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1; q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_ISPAIR_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- _CEXP_ISPAIR (_CEXP_NUM m) === _CEXP_NUM (_NUMERAL _0) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_ISPAIR (_CEXP_NUM _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_def, equation_def, REV_ASSOCD_def] +QED + +Theorem CEXP_EQ_eqn1: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ p1 has_type Cexp ∧ + term_ok (sigof thy) q1 ∧ q1 has_type Cexp ⇒ + (thy,[]) |- _CEXP_EQ p1 q1 === + _CEXP_NUM (_COND (p1 === q1)(_SUC (_NUMERAL _0)) + (_NUMERAL _0)) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- _CEXP_EQ _ _ === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[p1,_P1;q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def] + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ simp [] +QED + +Theorem CEXP_EQ_eqn2: + compute_thy_ok thy ∧ + term_ok (sigof thy) p1 ∧ p1 has_type Cexp ∧ + term_ok (sigof thy) q1 ∧ q1 has_type Cexp ∧ + term_ok (sigof thy) p2 ∧ p2 has_type Cexp ∧ + term_ok (sigof thy) q2 ∧ q2 has_type Cexp ⇒ + (thy,[]) |- (_CEXP_PAIR p1 q1 === _CEXP_PAIR p2 q2) === + (_IF (p1 === p2) (q1 === q2) _FALSE) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_CEXP_PAIR _ _ === _CEXP_PAIR _ _) === _’ + assume_tac + \\ dxrule_at_then (Pos (el 2)) + (qspec_then ‘[p1,_P1;q1,_Q1;p2,_P2;q2,_Q2]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def] + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ simp [] +QED + +Theorem CEXP_EQ_eqn3: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ∧ + term_ok (sigof thy) m ∧ m has_type Num ⇒ + (thy,[]) |- (_CEXP_NUM m === _CEXP_NUM n) === (m === n) +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_CEXP_NUM _ === _CEXP_NUM _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N;m,_M]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def] + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ simp [] +QED + +Theorem CEXP_EQ_eqn4: + compute_thy_ok thy ∧ + term_ok (sigof thy) m ∧ m has_type Num ∧ + term_ok (sigof thy) p1 ∧ p1 has_type Cexp ∧ + term_ok (sigof thy) q1 ∧ q1 has_type Cexp ⇒ + (thy,[]) |- (_CEXP_NUM m === _CEXP_PAIR p1 q1) === _FALSE +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_CEXP_NUM _ === _CEXP_PAIR _ _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[m,_M;p1,_P1;q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def] + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ simp [] +QED + +Theorem CEXP_EQ_eqn5: + compute_thy_ok thy ∧ + term_ok (sigof thy) n ∧ n has_type Num ∧ + term_ok (sigof thy) p1 ∧ p1 has_type Cexp ∧ + term_ok (sigof thy) q1 ∧ q1 has_type Cexp ⇒ + (thy,[]) |- (_CEXP_PAIR p1 q1 === _CEXP_NUM n) === _FALSE +Proof + rw [compute_thy_ok_def] + \\ qpat_x_assum ‘_ |- (_CEXP_PAIR _ _ === _CEXP_NUM _) === _’ assume_tac + \\ dxrule_at_then (Pos (el 2)) (qspec_then ‘[n,_N;p1,_P1;q1,_Q1]’ mp_tac) + proves_INST + \\ dsimp [VSUBST_thm, equation_def, REV_ASSOCD_def] + \\ dxrule WELLTYPED_LEMMA + \\ dxrule WELLTYPED_LEMMA + \\ simp [] +QED + +Theorem compute_thy_ok_terms_ok: + compute_thy_ok thy ⇒ + (* bools *) + term_ok (sigof thy) _TRUE ∧ + term_ok (sigof thy) _FALSE ∧ + term_ok (sigof thy) _COND_TM ∧ + term_ok (sigof thy) _IF_TM ∧ + (* nums *) + term_ok (sigof thy) _ADD_TM ∧ + term_ok (sigof thy) _SUB_TM ∧ + term_ok (sigof thy) _MUL_TM ∧ + term_ok (sigof thy) _DIV_TM ∧ + term_ok (sigof thy) _MOD_TM ∧ + term_ok (sigof thy) _LESS_TM ∧ + term_ok (sigof thy) _0 ∧ + term_ok (sigof thy) _SUC_TM ∧ + term_ok (sigof thy) _BIT0_TM ∧ + term_ok (sigof thy) _BIT1_TM ∧ + term_ok (sigof thy) _NUMERAL_TM ∧ + (* cexps *) + term_ok (sigof thy) _CEXP_ADD_TM ∧ + term_ok (sigof thy) _CEXP_SUB_TM ∧ + term_ok (sigof thy) _CEXP_MUL_TM ∧ + term_ok (sigof thy) _CEXP_DIV_TM ∧ + term_ok (sigof thy) _CEXP_MOD_TM ∧ + term_ok (sigof thy) _CEXP_LESS_TM ∧ + term_ok (sigof thy) _CEXP_NUM_TM ∧ + term_ok (sigof thy) _CEXP_IF_TM ∧ + term_ok (sigof thy) _CEXP_PAIR_TM ∧ + term_ok (sigof thy) _CEXP_FST_TM ∧ + term_ok (sigof thy) _CEXP_SND_TM ∧ + term_ok (sigof thy) _CEXP_ISPAIR_TM ∧ + term_ok (sigof thy) _CEXP_EQ_TM ∧ + (* let *) + term_ok (sigof thy) _LET_TM ∧ + (* types *) + type_ok (tysof thy) Cexp +Proof + simp [compute_thy_ok_def] \\ strip_tac + \\ dxrule_then strip_assume_tac numeral_thy_ok_terms_ok + \\ rpt (first_x_assum (irule_at Any)) + \\ rpt (dxrule_then strip_assume_tac proves_term_ok) \\ rfs [] + \\ fs [equation_def, term_ok_def, SF SFY_ss] +QED + +Theorem compute_thy_ok_theory_ok[simp]: + compute_thy_ok thy ⇒ theory_ok thy +Proof + rw [compute_thy_ok_def] +QED + +Theorem compute_thy_ok_numeral_thy_ok[simp]: + compute_thy_ok thy ⇒ numeral_thy_ok thy +Proof + rw [compute_thy_ok_def] +QED + +Theorem compute_thy_ok_bool_thy_ok[simp]: + compute_thy_ok thy ⇒ bool_thy_ok thy +Proof + rw [compute_thy_ok_def] +QED + +Theorem cexp2term_typeof[simp]: + ∀cv. typeof (cexp2term cv) = Cexp +Proof + ho_match_mp_tac cexp2term_ind \\ rw [] + \\ simp [cexp2term_def, FOLDL_MAP] + >~ [‘bop2term _’] >- ( + Cases_on ‘bop’ \\ gs [bop2term_def]) + >~ [‘uop2term _’] >- ( + Cases_on ‘uop’ \\ gs [uop2term_def]) + \\ pop_assum mp_tac + \\ ‘∀tm. + typeof tm = app_type (LENGTH cs) ⇒ + typeof (FOLDL (λx y. Comb x (cexp2term y)) tm cs) = Cexp ’ + suffices_by rw [SF SFY_ss] + \\ Induct_on ‘cs’ + \\ simp [app_type] +QED + +Theorem cexp2term_has_type[simp]: + ∀cv. cexp2term cv has_type Cexp +Proof + ho_match_mp_tac cexp2term_ind \\ rw [] \\ simp [cexp2term_def] + >~ [‘_CEXP_NUM _’] >- ( + rw [Ntimes has_type_cases 3] + \\ rw [Ntimes has_type_cases 3]) + >~ [‘uop2term _’] >- ( + Cases_on ‘uop’ \\ simp [uop2term_def] + \\ rw [Ntimes has_type_cases 3]) + >~ [‘_CEXP_PAIR _ _’] >- ( + rw [Ntimes has_type_cases 3]) + >~ [‘_CEXP_IF _ _ _’] >- ( + rw [Ntimes has_type_cases 3] + \\ rw [Ntimes has_type_cases 3]) + >~ [‘bop2term _ _ _’] >- ( + Cases_on ‘bop’ \\ simp [bop2term_def] + \\ rw [Ntimes has_type_cases 3]) + >~ [‘_LET _ _’] >- ( + rw [Ntimes has_type_cases 3] + \\ rw [Ntimes has_type_cases 3]) + >~ [‘Var _’] >- ( + rw [has_type_rules]) + \\ simp [FOLDL_MAP] + \\ ‘∀tm. + tm has_type app_type (LENGTH cs) ⇒ + FOLDL (λx y. Comb x (cexp2term y)) tm cs has_type Cexp ’ + suffices_by rw [has_type_rules, SF SFY_ss] + \\ Induct_on ‘cs’ \\ rw [app_type] + \\ gs [has_type_rules, SF SFY_ss, SF DNF_ss] +QED + +Theorem cexp2term_welltyped[simp]: + ∀cv. welltyped (cexp2term cv) +Proof + rw [welltyped_def, cexp2term_has_type, SF SFY_ss] +QED + +Theorem bop2term_term_ok: + compute_thy_ok thy ⇒ + typeof tm1 = Cexp ∧ typeof tm2 = Cexp ∧ + term_ok (sigof thy) tm1 ∧ term_ok (sigof thy) tm2 ⇒ + term_ok (sigof thy) (bop2term bop tm1 tm2) +Proof + rw [] + \\ drule_then strip_assume_tac compute_thy_ok_terms_ok + \\ Cases_on ‘bop’ \\ gs [bop2term_def] + \\ simp [term_ok_def, term_ok_welltyped, SF SFY_ss] +QED + +Theorem uop2term_term_ok: + compute_thy_ok thy ⇒ + typeof tm = Cexp ∧ + term_ok (sigof thy) tm ⇒ + term_ok (sigof thy) (uop2term uop tm) +Proof + rw [] + \\ drule_then strip_assume_tac compute_thy_ok_terms_ok + \\ Cases_on ‘uop’ \\ gs [uop2term_def] + \\ simp [term_ok_def, term_ok_welltyped, SF SFY_ss] +QED + +Theorem cexp2term_term_ok: + compute_thy_ok thy ⇒ + ∀cv. + (∀c n. + (c,n) ∈ cexp_consts cv ⇒ + term_ok (sigof thy) (Const c (app_type n))) ⇒ + term_ok (sigof thy) (cexp2term cv) +Proof + strip_tac + \\ drule_then strip_assume_tac compute_thy_ok_terms_ok + \\ ho_match_mp_tac cexp2term_ind \\ rw [] + \\ gs [cexp2term_def, cexp_consts_def] + >~ [‘_CEXP_NUM _’] >- ( + simp [term_ok_def, compute_thy_ok_def, num2bit_term_ok, SF SFY_ss]) + >~ [‘uop2term _’] >- ( + irule uop2term_term_ok \\ gs []) + >~ [‘_CEXP_PAIR _ _ ’] >- ( + simp [term_ok_def, compute_thy_ok_def, num2bit_term_ok, SF SFY_ss]) + >~ [‘bop2term _ _ _ ’] >- ( + irule bop2term_term_ok \\ gs []) + >~ [‘_CEXP_IF _ _ _ ’] >- ( + simp [term_ok_def, compute_thy_ok_def, num2bit_term_ok, SF SFY_ss]) + >~ [‘_LET _ _’] >- ( + simp [term_ok_def]) + >~ [‘Var s _’] >- ( + simp [term_ok_def]) + \\ gvs [FOLDL_MAP, MEM_MAP, SF SFY_ss, SF DNF_ss] + \\ ‘∀tm. + term_ok (sigof thy) tm ∧ + tm has_type (app_type (LENGTH cs)) ⇒ + term_ok (sigof thy) (FOLDL (λx y. Comb x (cexp2term y)) tm cs)’ + suffices_by rw [term_ok_def, has_type_rules] + \\ rpt (qpat_x_assum ‘term_ok _ _’ kall_tac) + \\ Induct_on ‘cs’ + \\ rw [app_type, SF SFY_ss, SF DNF_ss] + \\ first_x_assum irule \\ fs [SF SFY_ss] + \\ simp [has_type_rules, cexp2term_has_type, SF SFY_ss] + \\ simp [term_ok_def, term_ok_welltyped, SF SFY_ss] + \\ irule_at Any WELLTYPED_LEMMA \\ fs [SF SFY_ss] +QED + +(* TODO move *) +Theorem bool2term_term_ok[simp]: + bool_thy_ok thy ⇒ + term_ok (sigof thy) (bool2term b) +Proof + Cases_on ‘b’ \\ rw [bool2term_def] + \\ gs [bool_thy_ok_terms_ok] +QED + +Theorem cexp_value_no_consts: + ∀v. cexp_value v ⇒ cexp_consts v = {} +Proof + ho_match_mp_tac cexp_value_ind + \\ rw [cexp_value_def, cexp_consts_def] +QED + +Theorem bool2term_EQ_cexpterm: + compute_thy_ok thy ⇒ + cexp_value p ∧ cexp_value q ⇒ + (thy,[]) |- bool2term (p = q) === (cexp2term p === cexp2term q) +Proof + strip_tac + \\ ‘∀p q. cexp_value p ∧ cexp_value q ⇒ + (thy,[]) |- (cexp2term p === cexp2term q) === bool2term (p = q)’ + suffices_by rw [sym_equation] + \\ ho_match_mp_tac cexp2term_ind \\ rw [] + >~ [‘Num n’] >- ( + rw [cexp2term_def] + \\ Cases_on ‘q = Num n’ \\ gvs [bool2term_def, cexp2term_def] + >- ( + irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn3 + \\ gs [num2bit_term_ok] + \\ resolve_then Any irule sym_equation replaceL_eq1 + \\ irule_at Any NUMERAL_eqn + \\ resolve_then Any (irule_at Any) sym_equation replaceL_eq2 + \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple + \\ irule_at Any EQ_bool2term_num2bit + \\ simp [bool2term_def, proves_REFL, num2bit_term_ok, + bool_thy_ok_terms_ok]) + \\ Cases_on ‘∃m. q = Num m’ \\ gvs [cexp2term_def] + >- ( + irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn3 + \\ gs [num2bit_term_ok] + \\ resolve_then Any irule sym_equation replaceL_eq1 + \\ irule_at Any NUMERAL_eqn + \\ resolve_then Any (irule_at Any) sym_equation replaceL_eq2 + \\ irule_at Any NUMERAL_eqn + \\ irule_at Any trans_equation_simple + \\ irule_at Any EQ_bool2term_num2bit + \\ simp [bool2term_def, proves_REFL, num2bit_term_ok, + bool_thy_ok_terms_ok]) + \\ ‘∃p1 q1. q = Pair p1 q1’ + by (Cases_on ‘q’ \\ gs []) + \\ gvs [cexp2term_def] + \\ irule CEXP_EQ_eqn4 + \\ gs [num2bit_term_ok, cexp_value_no_consts, cexp2term_term_ok]) + >~ [‘Pair p1 q1’] >- ( + gs [cexp2term_def] + \\ Cases_on ‘q = Pair p1 q1’ \\ gvs [bool2term_def, cexp2term_def] + >- ( + irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn2 + \\ gs [cexp2term_term_ok, cexp_value_no_consts] + \\ qpat_x_assum ‘cexp_value q1’ assume_tac + \\ first_x_assum (drule_then assume_tac) + \\ qpat_x_assum ‘cexp_value p1’ assume_tac + \\ first_x_assum (drule_then assume_tac) + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_x_assum (irule_at Any) \\ simp [bool2term_def] + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) \\ simp [bool2term_def] + \\ gs [numeral_thy_ok_terms_ok, has_type_rules, IF_eqn]) + \\ Cases_on ‘∃p2 q2. q = Pair p2 q2’ \\ gvs [cexp2term_def] + >- ( + first_x_assum (qspec_then ‘q2’ assume_tac) + \\ first_x_assum (qspec_then ‘p2’ assume_tac) \\ gs [] + \\ irule trans_equation_simple \\ irule_at Any CEXP_EQ_eqn2 + \\ gs [cexp2term_term_ok, cexp_value_no_consts] + \\ resolve_then Any irule sym_equation replaceL3 + \\ first_x_assum (irule_at Any) \\ simp [] + \\ resolve_then Any irule sym_equation replaceL1 + \\ first_x_assum (irule_at Any) \\ simp [] + \\ Cases_on ‘p2 = p1’ \\ Cases_on ‘q2 = q1’ + \\ gs [numeral_thy_ok_terms_ok, bool2term_term_ok, has_type_rules, + IF_eqn, bool2term_def]) + \\ ‘∃n. q = Num n’ + by (Cases_on ‘q’ \\ gs []) + \\ gvs [cexp2term_def] + \\ irule CEXP_EQ_eqn5 + \\ gs [num2bit_term_ok, cexp_value_no_consts, cexp2term_term_ok]) +QED + +Theorem EQ_bool2term_cexpterm: + compute_thy_ok thy ⇒ + cexp_value p ∧ cexp_value q ⇒ + (thy,[]) |- (cexp2term p === cexp2term q) === bool2term (p = q) +Proof + rw [] \\ irule sym_equation + \\ rw [bool2term_EQ_cexpterm] +QED + +val _ = export_theory (); + diff --git a/candle/prover/compute/compute_syntaxScript.sml b/candle/prover/compute/compute_syntaxScript.sml new file mode 100644 index 0000000000..261e689308 --- /dev/null +++ b/candle/prover/compute/compute_syntaxScript.sml @@ -0,0 +1,225 @@ +(* + Definitions of 'compute expressions' for the Candle compute primitive. + *) + +open preamble holSyntaxTheory holSyntaxExtraTheory holSyntaxLibTheory + holKernelTheory holKernelProofTheory; + +val _ = new_theory "compute_syntax"; + +val _ = numLib.prefer_num (); + +(* Numbers, bools *) + +Overload Num = “Tyapp «num» []”; + +Overload "_X" = “Var «x» Bool”; +Overload "_Y" = “Var «y» Bool”; +Overload "_TRUE" = “Const «T» Bool”; +Overload "_FALSE" = “Const «F» Bool”; +(* COND on numbers: *) +Overload "_COND_TM" = + “Const «COND» (Fun Bool (Fun Num (Fun Num Num)))”; +Overload "_COND" = “λt t1 t2. Comb (Comb (Comb _COND_TM t) t1) t2”; +(* COND on booleans: *) +Overload "_IF_TM" = + “Const «COND» (Fun Bool (Fun Bool (Fun Bool Bool)))”; +Overload "_IF" = “λt t1 t2. Comb (Comb (Comb _IF_TM t) t1) t2”; + +Overload "_0" = “Const «_0» Num”; +Overload "_SUC_TM" = “Const «SUC» (Fun Num Num)”; +Overload "_SUC" = “λtm. Comb _SUC_TM tm”; +Overload "_BIT0_TM" = “Const «BIT0» (Fun Num Num)”; +Overload "_BIT0" = “λtm. Comb _BIT0_TM tm”; +Overload "_BIT1_TM" = “Const «BIT1» (Fun Num Num)”; +Overload "_BIT1" = “λtm. Comb _BIT1_TM tm”; +Overload "_N" = “Var «n» Num”; +Overload "_M" = “Var «m» Num”; +Overload "_ADD_TM" = “Const «+» (Fun Num (Fun Num Num))”; +Overload "_ADD" = “λt1 t2. Comb (Comb _ADD_TM t1) t2”; +Overload "_SUB_TM" = “Const «-» (Fun Num (Fun Num Num))”; +Overload "_SUB" = “λt1 t2. Comb (Comb _SUB_TM t1) t2”; +Overload "_MUL_TM" = “Const «*» (Fun Num (Fun Num Num))”; +Overload "_MUL" = “λt1 t2. Comb (Comb _MUL_TM t1) t2”; +Overload "_MOD_TM" = “Const «MOD» (Fun Num (Fun Num Num))”; +Overload "_MOD" = “λt1 t2. Comb (Comb _MOD_TM t1) t2”; +Overload "_DIV_TM" = “Const «DIV» (Fun Num (Fun Num Num))”; +Overload "_DIV" = “λt1 t2. Comb (Comb _DIV_TM t1) t2”; +Overload "_LESS_TM" = “Const «<» (Fun Num (Fun Num Bool))”; +Overload "_LESS" = “λt1 t2. Comb (Comb _LESS_TM t1) t2”; +Overload "_NUMERAL_TM" = “Const «NUMERAL» (Fun Num Num)”; +Overload "_NUMERAL" = “λtm. Comb _NUMERAL_TM tm”; + +(* Compute expressions *) + +Overload Cexp = “Tyapp «cexp» []”; +Overload Cexp_list = “Tyapp «list» [Cexp]”; +Overload "_P1" = “Var «p1» Cexp”; +Overload "_P2" = “Var «p2» Cexp”; +Overload "_Q1" = “Var «q1» Cexp”; +Overload "_Q2" = “Var «q2» Cexp”; +Overload "_CS" = “Var «cs» Cexp_list”; +(* +Overload "_CEXP_NIL_TM" = “Const «[]» Cexp_list”; +Overload "_CEXP_CONS_TM" = + “Const «::» (Fun Cexp (Fun Cexp_list Cexp_list))”; +Overload "_CEXP_CONS" = “λt1 t2. Comb (Comb _CEXP_CONS_TM t1) t2”; + *) +Overload "_CEXP_NUM_TM" = “Const «Cexp_num» (Fun Num Cexp)”; +Overload "_CEXP_NUM" = “λtm. Comb _CEXP_NUM_TM tm”; +Overload "_CEXP_PAIR_TM" = “Const «Cexp_pair» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_PAIR" = “λt1 t2. Comb (Comb _CEXP_PAIR_TM t1) t2”; + +Overload "_CEXP_VAR_TM" = “Const «Cexp_var» (Fun string_ty Cexp)” +Overload "_CEXP_VAR" = “λtm. Comb _CEXP_VAR_TM tm” +Overload "_CEXP_ADD_TM" = + “Const «Cexp_add» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_ADD" = “λt1 t2. Comb (Comb _CEXP_ADD_TM t1) t2”; +Overload "_CEXP_SUB_TM" = + “Const «Cexp_sub» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_SUB" = “λt1 t2. Comb (Comb _CEXP_SUB_TM t1) t2”; +Overload "_CEXP_MUL_TM" = + “Const «Cexp_mul» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_MUL" = “λt1 t2. Comb (Comb _CEXP_MUL_TM t1) t2”; +Overload "_CEXP_MOD_TM" = + “Const «Cexp_mod» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_MOD" = “λt1 t2. Comb (Comb _CEXP_MOD_TM t1) t2”; +Overload "_CEXP_DIV_TM" = + “Const «Cexp_div» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_DIV" = “λt1 t2. Comb (Comb _CEXP_DIV_TM t1) t2”; +Overload "_CEXP_LESS_TM" = + “Const «Cexp_less» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_LESS" = “λt1 t2. Comb (Comb _CEXP_LESS_TM t1) t2”; +Overload "_CEXP_APP_TM" = + “Const «Cexp_app» (Fun string_ty (Fun Cexp_list Cexp))”; +Overload "_CEXP_APP" = “λt1 t2. Comb (Comb _CEXP_APP_TM t1) t2”; +Overload "_CEXP_IF_TM" = + “Const «Cexp_if» (Fun Cexp (Fun Cexp (Fun Cexp Cexp)))”; +Overload "_CEXP_IF" = “λt1 t2 t3. Comb (Comb (Comb _CEXP_IF_TM t1) t2) t3”; +Overload "_CEXP_FST_TM" = “Const «Cexp_fst» (Fun Cexp Cexp)”; +Overload "_CEXP_FST" = “λtm. Comb _CEXP_FST_TM tm”; +Overload "_CEXP_SND_TM" = “Const «Cexp_snd» (Fun Cexp Cexp)”; +Overload "_CEXP_SND" = “λtm. Comb _CEXP_SND_TM tm”; +Overload "_CEXP_ISPAIR_TM" = “Const «Cexp_ispair» (Fun Cexp Cexp)”; +Overload "_CEXP_ISPAIR" = “λtm. Comb _CEXP_ISPAIR_TM tm”; +Overload "_CEXP_EQ_TM" = “Const «Cexp_eq» (Fun Cexp (Fun Cexp Cexp))”; +Overload "_CEXP_EQ" = “λt1 t2. Comb (Comb _CEXP_EQ_TM t1) t2”; + +(* Lets, “let a = b in x”: *) + +Overload "_F" = “Var «f» (Fun Cexp Cexp)”; +Overload "_LET_TM" = “Const «LET» (Fun (Fun Cexp Cexp) (Fun Cexp Cexp))”; +Overload "_LET" = “λt1 t2. Comb (Comb _LET_TM t1) t2”; + +(* ------------------------------------------------------------------------- + * Bools + * ------------------------------------------------------------------------- *) + +Definition bool2term_def: + bool2term F = _FALSE ∧ + bool2term T = _TRUE +End + +(* ------------------------------------------------------------------------- + * Natural numbers + * ------------------------------------------------------------------------- *) + +Definition num2term_def: + num2term 0 = _0 ∧ + num2term (SUC n) = _SUC (num2term n) +End + +Definition num2bit_def: + num2bit n = + if n = 0 then _0 else + Comb (if n MOD 2 = 0 then _BIT0_TM else _BIT1_TM) (num2bit (n DIV 2)) +Termination + wf_rel_tac ‘$<’ \\ intLib.ARITH_TAC +End + +(* ------------------------------------------------------------------------- + * Compute expressions + * ------------------------------------------------------------------------- *) + +Datatype: + binop = Add | Sub | Mul | Div | Mod | Less | Eq +End + +Datatype: + uop = Fst | Snd | Ispair +End + +Datatype: + compute_exp = Pair compute_exp compute_exp + | Num num + | Var mlstring + | App mlstring (compute_exp list) + | If compute_exp compute_exp compute_exp + | Let mlstring compute_exp compute_exp + | Uop uop compute_exp + | Binop binop compute_exp compute_exp +End + +Definition cexp_value_def[simp]: + cexp_value (Num n) = T ∧ + cexp_value (Pair p q) = (cexp_value p ∧ cexp_value q) ∧ + cexp_value _ = F +End + +Definition app_type_def: + app_type arity = FUNPOW (Fun Cexp) arity Cexp +End + +Theorem app_type: + app_type 0 = Cexp ∧ + app_type (SUC n) = Fun Cexp (app_type n) +Proof + rw [app_type_def, FUNPOW_SUC] +QED + +Definition bop2term_def: + bop2term Add = _CEXP_ADD ∧ + bop2term Sub = _CEXP_SUB ∧ + bop2term Mul = _CEXP_MUL ∧ + bop2term Div = _CEXP_DIV ∧ + bop2term Mod = _CEXP_MOD ∧ + bop2term Less = _CEXP_LESS ∧ + bop2term Eq = _CEXP_EQ +End + +Definition uop2term_def: + uop2term Fst = _CEXP_FST ∧ + uop2term Snd = _CEXP_SND ∧ + uop2term Ispair = _CEXP_ISPAIR +End + +Definition cexp2term_def: + cexp2term (Num n) = _CEXP_NUM (_NUMERAL (num2bit n)) ∧ + cexp2term (Pair p q) = _CEXP_PAIR (cexp2term p) (cexp2term q) ∧ + cexp2term (Uop uop p) = uop2term uop (cexp2term p) ∧ + cexp2term (Binop bop p q) = bop2term bop (cexp2term p) (cexp2term q) ∧ + cexp2term (If p q r) = _CEXP_IF (cexp2term p) (cexp2term q) (cexp2term r) ∧ + cexp2term (Let s x y) = _LET (Abs (Var s Cexp) (cexp2term y)) (cexp2term x) ∧ + cexp2term (Var s) = Var s Cexp ∧ + cexp2term (App s cs) = + FOLDL Comb (Const s (app_type (LENGTH cs))) (MAP cexp2term cs) +Termination + wf_rel_tac ‘measure compute_exp_size’ +End + +(* DIV and MOD definitions that are defined for zero (and as in HOL Light). *) + +Definition SAFEDIV_def: + SAFEDIV m n = if n = 0 then 0 else m DIV n +End + +val _ = Parse.add_infix ("SAFEDIV", 500, HOLgrammars.LEFT); + +Definition SAFEMOD_def: + SAFEMOD m n = if n = 0 then m else m MOD n +End + +val _ = Parse.add_infix ("SAFEMOD", 500, HOLgrammars.LEFT); + +val _ = export_theory (); + diff --git a/candle/prover/compute/readmePrefix b/candle/prover/compute/readmePrefix new file mode 100644 index 0000000000..f355a95cbe --- /dev/null +++ b/candle/prover/compute/readmePrefix @@ -0,0 +1 @@ +A verified Candle compute primitive. diff --git a/candle/standard/ml_kernel/Holmakefile b/candle/standard/ml_kernel/Holmakefile index a72f40b9c7..6688e08d4c 100644 --- a/candle/standard/ml_kernel/Holmakefile +++ b/candle/standard/ml_kernel/Holmakefile @@ -1,7 +1,13 @@ -INCLUDES = $(CAKEMLDIR)/misc lisp $(CAKEMLDIR)/semantics\ - $(CAKEMLDIR)/translator $(CAKEMLDIR)/translator/monadic\ - $(CAKEMLDIR)/basis $(CAKEMLDIR)/basis/pure\ - $(CAKEMLDIR)/characteristic ../monadic +INCLUDES = $(CAKEMLDIR)/misc\ + lisp\ + $(CAKEMLDIR)/semantics\ + $(CAKEMLDIR)/translator\ + $(CAKEMLDIR)/translator/monadic\ + $(CAKEMLDIR)/basis\ + $(CAKEMLDIR)/basis/pure\ + $(CAKEMLDIR)/characteristic\ + ../monadic + all: $(DEFAULT_TARGETS) README.md .PHONY: all diff --git a/candle/standard/ml_kernel/README.md b/candle/standard/ml_kernel/README.md index cabeefeb8c..64b255d638 100644 --- a/candle/standard/ml_kernel/README.md +++ b/candle/standard/ml_kernel/README.md @@ -1,9 +1,6 @@ Implementation of the monadic functions in (deeply embedded) CakeML, generated by the translator (proof-producing synthesis). -[candle_kernelProgScript.sml](candle_kernelProgScript.sml): -Adds Candle specific functions to the kernel module from ml_hol_kernel_funsProg - [lisp](lisp): Parsing and pretty printing of simple s-expressions @@ -26,3 +23,10 @@ The output is produced in a file called kernel_ml.txt. [print_thmScript.sml](print_thmScript.sml): Defines functions for turning a ctxt & thm to a string and back + +[runtime_checkLib.sml](runtime_checkLib.sml): +Mechanism for adding runtime type checking annotations, used in the Candle +prover soundness proofs. + +[runtime_checkScript.sml](runtime_checkScript.sml): +Theorems and definitions to support adding runtime type checking annotations. diff --git a/candle/standard/ml_kernel/ml_hol_kernel_funsProgScript.sml b/candle/standard/ml_kernel/ml_hol_kernel_funsProgScript.sml index cbddaffd0f..ff63a4b19c 100644 --- a/candle/standard/ml_kernel/ml_hol_kernel_funsProgScript.sml +++ b/candle/standard/ml_kernel/ml_hol_kernel_funsProgScript.sml @@ -14,6 +14,7 @@ open holKernelTheory open basisProgTheory open holAxiomsSyntaxTheory (* for setting up the context *) local open holKernelPmatchTheory in end +open runtime_checkTheory runtime_checkLib; (* Adds runtime type checks *) val _ = temp_delsimps ["NORMEQ_CONV"] @@ -30,14 +31,14 @@ Type state = ``:'ffi semanticPrimitives$state`` (* construct type refinement invariants *) -val _ = register_type ``:type``; +val _ = register_type “:type”; +val _ = register_type “:term”; +val _ = register_type “:thm”; (* check ``:type`` is known to be an EqualityType *) val EqualityType_TYPE = EqualityType_rule [] ``:type``; -val _ = register_type ``:term``; val _ = register_exn_type ``:hol_exn``; -val _ = register_type ``:thm``; val _ = register_type ``:update``; val HOL_EXN_TYPE_def = theorem"HOL_EXN_TYPE_def"; @@ -110,69 +111,11 @@ val (monad_parameters, store_translation, exn_specs) = NONE NONE; -(* mechanism for adding type checking annotations *) - -val pure_seq_intro = prove(“x = y ⇒ ∀z. x = pure_seq z y”, fs [pure_seq_def]); - -fun mlstring_check s = “mlstring$strlen ^s” -fun type_check ty = “case ^ty of Tyvar _ => () | _ => abc” |> subst [“abc:unit”|->“()”] -fun term_check tm = “case ^tm of Const _ _ => () | _ => abc” |> subst [“abc:unit”|->“()”] - -val t1 = type_check “t1:type” -val t2 = type_check “t2:type” -val tm = term_check “tm:term” -val tm' = term_check “tm':term” - -Definition check_ty_def: - check_ty [] = () ∧ - check_ty (t1::l) = pure_seq ^t1 (check_ty l) -End - -Definition check_tm_def: - check_tm [] = () ∧ - check_tm (tm::l) = pure_seq ^tm (check_tm l) -End - -Definition check_ty_ty_def: - check_ty_ty [] = () ∧ - check_ty_ty ((t1,t2)::l) = pure_seq ^t1 (pure_seq ^t2 (check_ty_ty l)) -End - -Definition check_tm_tm_def: - check_tm_tm [] = () ∧ - check_tm_tm ((tm,tm')::l) = pure_seq ^tm (pure_seq ^tm' (check_tm_tm l)) -End - -fun ty_list_check ty = “check_ty ^ty”; -fun tm_list_check tm = “check_tm ^tm”; -fun ty_ty_list_check tyty = “check_ty_ty ^tyty”; -fun tm_tm_list_check tmtm = “check_tm_tm ^tmtm”; - -fun guess_check tm = - if type_of tm = “:mlstring” then mlstring_check else - if type_of tm = “:type” then type_check else - if type_of tm = “:term” then term_check else - if type_of tm = “:type list” then ty_list_check else - if type_of tm = “:term list” then tm_list_check else - if type_of tm = “:(type # type) list” then ty_ty_list_check else - if type_of tm = “:(term # term) list” then tm_tm_list_check else fail() - -fun add_type_check v f def = let - val def = SPEC_ALL def - val tm = f v - in MATCH_MP pure_seq_intro def |> ISPEC tm end - -fun check [] def = SPEC_ALL def - | check (v::vs) def = - let - val def = check vs def - val tm = Parse.parse_in_context (free_vars (concl def)) v - val f = guess_check tm - val def = add_type_check tm f def - in def end +(* Translate type-checking code from checkTheory *) val res = translate check_ty_def; val res = translate check_tm_def; +val res = translate check_thm_def; val res = translate check_ty_ty_def; val res = translate check_tm_tm_def; diff --git a/candle/standard/ml_kernel/runtime_checkLib.sig b/candle/standard/ml_kernel/runtime_checkLib.sig new file mode 100644 index 0000000000..ea2e9314e2 --- /dev/null +++ b/candle/standard/ml_kernel/runtime_checkLib.sig @@ -0,0 +1,7 @@ +signature runtime_checkLib = sig + + include Abbrev + + val check : term quotation list -> thm -> thm + +end diff --git a/candle/standard/ml_kernel/runtime_checkLib.sml b/candle/standard/ml_kernel/runtime_checkLib.sml new file mode 100644 index 0000000000..0a1cac13f4 --- /dev/null +++ b/candle/standard/ml_kernel/runtime_checkLib.sml @@ -0,0 +1,55 @@ +(* + Mechanism for adding runtime type checking annotations, used in the Candle + prover soundness proofs. + *) + +structure runtime_checkLib :> runtime_checkLib = struct + +open HolKernel boolLib bossLib BasicProvers mlstringTheory runtime_checkTheory; + +fun mlstring_check s = + “mlstring$strlen ^s”; + +fun type_check ty = + “case ^ty of Tyvar _ => () | _ => abc” |> subst [“abc:unit”|->“()”]; + +fun term_check tm = + “case ^tm of Const _ _ => () | _ => abc” |> subst [“abc:unit”|->“()”]; + +fun thm_check th = + “case ^th of Sequent _ _ => ()”; + +fun ty_list_check ty = “check_ty ^ty”; +fun tm_list_check tm = “check_tm ^tm”; +fun thm_list_check th = “check_thm ^th”; +fun ty_ty_list_check tyty = “check_ty_ty ^tyty”; +fun tm_tm_list_check tmtm = “check_tm_tm ^tmtm”; + +fun guess_check tm = + if type_of tm = “:mlstring” then mlstring_check else + if type_of tm = “:type” then type_check else + if type_of tm = “:term” then term_check else + if type_of tm = “:thm” then thm_check else + if type_of tm = “:type list” then ty_list_check else + if type_of tm = “:term list” then tm_list_check else + if type_of tm = “:thm list” then thm_list_check else + if type_of tm = “:(type # type) list” then ty_ty_list_check else + if type_of tm = “:(term # term) list” then tm_tm_list_check else fail() + +fun add_type_check v f def = let + val def = SPEC_ALL def + val tm = f v + in MATCH_MP pure_seq_intro def |> ISPEC tm end + +fun check [] def = SPEC_ALL def + | check (v::vs) def = + let + val def = check vs def + val tm = Parse.parse_in_context (free_vars (concl def)) v + val f = guess_check tm + val def = add_type_check tm f def + in def end + + +end + diff --git a/candle/standard/ml_kernel/runtime_checkScript.sml b/candle/standard/ml_kernel/runtime_checkScript.sml new file mode 100644 index 0000000000..6fde09f258 --- /dev/null +++ b/candle/standard/ml_kernel/runtime_checkScript.sml @@ -0,0 +1,59 @@ +(* + Theorems and definitions to support adding runtime type checking annotations. + *) + +open preamble ml_translatorTheory ml_translatorLib holKernelTheory + mlstringTheory; + +val _ = new_theory "runtime_check"; + +Theorem pure_seq_intro: + x = y ⇒ ∀z. x = pure_seq z y +Proof + fs [pure_seq_def] +QED + +(* It's annoying but these few functions need to appear here and in checkLib *) + +fun type_check ty = + “case ^ty of Tyvar _ => () | _ => abc” |> subst [“abc:unit”|->“()”]; + +fun term_check tm = + “case ^tm of Const _ _ => () | _ => abc” |> subst [“abc:unit”|->“()”]; + +fun thm_check th = + “case ^th of Sequent _ _ => ()”; + +val t1 = type_check “t1:type” +val t2 = type_check “t2:type” +val tm = term_check “tm:term” +val tm' = term_check “tm':term” +val th = PmatchHeuristics.with_classic_heuristic thm_check “th:thm” + +Definition check_ty_def: + check_ty [] = () ∧ + check_ty (t1::l) = pure_seq ^t1 (check_ty l) +End + +Definition check_tm_def: + check_tm [] = () ∧ + check_tm (tm::l) = pure_seq ^tm (check_tm l) +End + +Definition check_thm_def: + check_thm [] = () ∧ + check_thm (th::l) = pure_seq ^th (check_thm l) +End + +Definition check_ty_ty_def: + check_ty_ty [] = () ∧ + check_ty_ty ((t1,t2)::l) = pure_seq ^t1 (pure_seq ^t2 (check_ty_ty l)) +End + +Definition check_tm_tm_def: + check_tm_tm [] = () ∧ + check_tm_tm ((tm,tm')::l) = pure_seq ^tm (pure_seq ^tm' (check_tm_tm l)) +End + +val _ = export_theory (); + diff --git a/candle/standard/syntax/holSyntaxScript.sml b/candle/standard/syntax/holSyntaxScript.sml index b5e7afc1d3..827a0c1e1b 100644 --- a/candle/standard/syntax/holSyntaxScript.sml +++ b/candle/standard/syntax/holSyntaxScript.sml @@ -459,53 +459,53 @@ val theory_ok_def = Define` val _ = Parse.add_infix("|-",450,Parse.NONASSOC) Inductive proves: - (* ABS *) +[~ABS:] (¬(EXISTS (VFREE_IN (Var x ty)) h) ∧ type_ok (tysof thy) ty ∧ (thy, h) |- l === r ⇒ (thy, h) |- (Abs (Var x ty) l) === (Abs (Var x ty) r)) ∧ - (* ASSUME *) +[~ASSUME:] (theory_ok thy ∧ p has_type Bool ∧ term_ok (sigof thy) p ⇒ (thy, [p]) |- p) ∧ - (* BETA *) +[~BETA:] (theory_ok thy ∧ type_ok (tysof thy) ty ∧ term_ok (sigof thy) t ⇒ (thy, []) |- Comb (Abs (Var x ty) t) (Var x ty) === t) ∧ - (* DEDUCT_ANTISYM *) +[~DEDUCT_ANTISYM:] ((thy, h1) |- c1 ∧ (thy, h2) |- c2 ⇒ (thy, term_union (term_remove c2 h1) (term_remove c1 h2)) |- c1 === c2) ∧ - (* EQ_MP *) +[~EQ_MP:] ((thy, h1) |- p === q ∧ (thy, h2) |- p' ∧ ACONV p p' ⇒ (thy, term_union h1 h2) |- q) ∧ - (* INST *) +[~INST:] ((∀s s'. MEM (s',s) ilist ⇒ ∃x ty. (s = Var x ty) ∧ s' has_type ty ∧ term_ok (sigof thy) s') ∧ (thy, h) |- c ⇒ (thy, term_image (VSUBST ilist) h) |- VSUBST ilist c) ∧ - (* INST_TYPE *) +[~INST_TYPE:] ((EVERY (type_ok (tysof thy)) (MAP FST tyin)) ∧ (thy, h) |- c ⇒ (thy, term_image (INST tyin) h) |- INST tyin c) ∧ - (* MK_COMB *) +[~MK_COMB:] ((thy, h1) |- l1 === r1 ∧ (thy, h2) |- l2 === r2 ∧ welltyped(Comb l1 l2) ⇒ (thy, term_union h1 h2) |- Comb l1 l2 === Comb r1 r2) ∧ - (* REFL *) +[~REFL:] (theory_ok thy ∧ term_ok (sigof thy) t ⇒ (thy, []) |- t === t) ∧ - (* axioms *) +[~axioms:] (theory_ok thy ∧ c ∈ (axsof thy) ⇒ (thy, []) |- c) End diff --git a/compiler/bootstrap/translation/arm7ProgScript.sml b/compiler/bootstrap/translation/arm7ProgScript.sml index d0e73d4c0e..94a2c8b251 100644 --- a/compiler/bootstrap/translation/arm7ProgScript.sml +++ b/compiler/bootstrap/translation/arm7ProgScript.sml @@ -134,11 +134,11 @@ val arm7_enc1 = replace_at 1 (fn th => th |>finish|> SIMP_RULE (srw_ss()) [] ) val arm7_enc2 = replace_at 2 (fn th => th |> finish |> gconv) -val arm7_enc3 = replace_at 3 (fn th => th |> Q.GEN `bop` |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:binop``]) (LET_THM::arm7_bop_def::defaults) |> finish |> CONJUNCTS +val arm7_enc3 = replace_at 3 (fn th => th |> Q.GEN `bop` |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) (LET_THM::arm7_bop_def::defaults) |> finish |> CONJUNCTS |> reconstruct_case ``arm7_enc (Inst (Arith (Binop bop r1 r2 (Reg r3))))`` (rand o rator o rator o rator o rand o rand o rand)) (* TODO: Uses THE (EncodeARMImmediate)*) -val arm7_enc4 = replace_at 4 (fn th => th |> Q.GEN `bop` |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:binop``]) (arm7_bop_def::defaults) |> finish +val arm7_enc4 = replace_at 4 (fn th => th |> Q.GEN `bop` |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) (arm7_bop_def::defaults) |> finish |> SIMP_RULE (srw_ss())[word_2comp_def] |> CONJUNCTS |> reconstruct_case ``arm7_enc (Inst (Arith (Binop bop r1 r2 (Imm i))))`` (rand o rator o rator o rator o rand o rand o rand)) diff --git a/compiler/bootstrap/translation/arm8ProgScript.sml b/compiler/bootstrap/translation/arm8ProgScript.sml index d9c0b72dcf..9f6cca8724 100644 --- a/compiler/bootstrap/translation/arm8ProgScript.sml +++ b/compiler/bootstrap/translation/arm8ProgScript.sml @@ -134,7 +134,7 @@ val (binop::shift::rest) = el 3 arm8_enc1s |> SIMP_RULE (srw_ss() ++ val (binopreg_aux::binopimm_aux::_) = binop |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:64 reg_imm``]) [FORALL_AND_THM] |> CONJUNCTS |> map (SIMP_RULE (srw_ss() ++ LET_ss - ++ DatatypeSimps.expand_type_quants_ss [``:binop``]) []) + ++ DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) []) val binopreg = binopreg_aux |> CONJUNCTS |> map(fn th => th |> SIMP_RULE (srw_ss()++LET_ss) (defaults) |> wc_simp |> we_simp |> diff --git a/compiler/bootstrap/translation/caml_parserProgScript.sml b/compiler/bootstrap/translation/caml_parserProgScript.sml index c7b51a400a..87eb5ab335 100644 --- a/compiler/bootstrap/translation/caml_parserProgScript.sml +++ b/compiler/bootstrap/translation/caml_parserProgScript.sml @@ -72,6 +72,10 @@ fun def_of_const tm = let val _ = (find_def_for_const := def_of_const); +val _ = ml_translatorLib.use_string_type false; + +val r = translate string_lt_def; + val _ = ml_translatorLib.use_string_type true; (* ------------------------------------------------------------------------- @@ -105,6 +109,7 @@ val _ = update_precondition ptree_op_side; val r = preprocess ptree_Literal_def |> translate; + Theorem ptree_literal_side[local]: ∀x. camlptreeconversion_ptree_literal_side x Proof @@ -116,6 +121,8 @@ QED val _ = update_precondition ptree_literal_side; +val r = preprocess ptree_FieldName_def |> translate; + val r = translate (DefnBase.one_line_ify NONE precparserTheory.precparse_def) Theorem precparse_side: @@ -149,7 +156,9 @@ Theorem ptree_Expr_preconds[local]: (∀x. camlptreeconversion_ptree_patternmatches_side x) ∧ (∀x. camlptreeconversion_ptree_patternmatch_side x) ∧ (∀x. camlptreeconversion_ptree_exprlist_side x) ∧ - (∀x. camlptreeconversion_ptree_exprcommas_side x) + (∀x. camlptreeconversion_ptree_exprcommas_side x) ∧ + (∀x. camlptreeconversion_ptree_update_side x) ∧ + (∀x. camlptreeconversion_ptree_updates_side x) Proof ho_match_mp_tac ptree_Expr_ind \\ strip_tac @@ -173,16 +182,14 @@ QED val _ = List.app (ignore o update_precondition) (CONJUNCTS ptree_Expr_preconds); -val r = preprocess ptree_TypeDefinition_def |> translate; -Theorem ptree_typedefinition_side[local]: - ∀x. camlptreeconversion_ptree_typedefinition_side x +val r = translate partition_types_def; + +Theorem camlptreeconversion_partition_types_side[local]: + camlptreeconversion_partition_types_side x Proof - rw [fetch "-" "camlptreeconversion_ptree_typedefinition_side_def", - fetch "-" "sum_outr_side_def", fetch "-" "sum_outl_side_def"] - \\ gs [EVERY_MEM, FORALL_PROD, quantHeuristicsTheory.ISR_exists, - quantHeuristicsTheory.ISL_exists, SF SFY_ss] - \\ res_tac \\ gs [] + rw [fetch "-" "camlptreeconversion_partition_types_side_def", + fetch "-" "sum_outl_side_def", fetch "-" "sum_outr_side_def"] \\ qpat_x_assum ‘PARTITION _ _ = _’ (assume_tac o SYM) \\ gs [PARTITION_DEF] \\ drule_then assume_tac PARTs_HAVE_PROP @@ -194,7 +201,14 @@ Proof \\ res_tac \\ fs [] QED -val _ = update_precondition ptree_typedefinition_side; +val _ = update_precondition camlptreeconversion_partition_types_side; + +val r = translate sort_records_def; +val r = translate MAP_OUTR_def; +val r = translate extract_record_defns_def; +val r = translate strip_record_fields_def; + +val r = preprocess ptree_TypeDefinition_def |> translate; val r = preprocess ptree_ModuleType_def |> translate; val r = preprocess ptree_Definition_def |> translate; diff --git a/compiler/bootstrap/translation/mipsProgScript.sml b/compiler/bootstrap/translation/mipsProgScript.sml index af2560eb93..bbcb3fff77 100644 --- a/compiler/bootstrap/translation/mipsProgScript.sml +++ b/compiler/bootstrap/translation/mipsProgScript.sml @@ -86,7 +86,7 @@ val (binop::shift::rest) = el 3 mips_enc1s |> SIMP_RULE (srw_ss() ++ DatatypeSim val (binopreg_aux::binopimm_aux::_) = binop |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:64 reg_imm``]) [FORALL_AND_THM] |> CONJUNCTS |> map (SIMP_RULE (srw_ss() ++ LET_ss - ++ DatatypeSimps.expand_type_quants_ss [``:binop``]) []) + ++ DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) []) val binopreg = binopreg_aux |> CONJUNCTS |> map(fn th => th |> SIMP_RULE (srw_ss()++LET_ss) (defaults) |> wc_simp |> we_simp |> diff --git a/compiler/bootstrap/translation/riscvProgScript.sml b/compiler/bootstrap/translation/riscvProgScript.sml index badbedd533..d6b74b7485 100644 --- a/compiler/bootstrap/translation/riscvProgScript.sml +++ b/compiler/bootstrap/translation/riscvProgScript.sml @@ -94,7 +94,7 @@ val (binop::shift::rest) = el 3 riscv_enc1s |> SIMP_RULE (srw_ss() ++ val (binopreg_aux::binopimm_aux::_) = binop |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:64 reg_imm``]) [FORALL_AND_THM] |> CONJUNCTS |> map (SIMP_RULE (srw_ss() ++ LET_ss - ++ DatatypeSimps.expand_type_quants_ss [``:binop``]) []); + ++ DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) []); val binopreg = binopreg_aux |> CONJUNCTS |> map(fn th => th |> SIMP_RULE (srw_ss()++LET_ss) (defaults) |> wc_simp |> we_simp |> diff --git a/compiler/bootstrap/translation/x64ProgScript.sml b/compiler/bootstrap/translation/x64ProgScript.sml index 037605eb42..cd8f0a515f 100644 --- a/compiler/bootstrap/translation/x64ProgScript.sml +++ b/compiler/bootstrap/translation/x64ProgScript.sml @@ -168,7 +168,7 @@ DatatypeSimps.expand_type_quants_ss [``:64 arith``]) [] |> CONJUNCTS val (binopreg_aux::binopimm_aux::_) = binop |> SIMP_RULE (srw_ss() ++ DatatypeSimps.expand_type_quants_ss [``:64 reg_imm``]) [FORALL_AND_THM] |> CONJUNCTS |> map (SIMP_RULE (srw_ss() ++ LET_ss ++ -DatatypeSimps.expand_type_quants_ss [``:binop``]) []) +DatatypeSimps.expand_type_quants_ss [``:asm$binop``]) []) (* TODO: simplify further? *) val binopreg = binopreg_aux |> CONJUNCTS |> map(fn th => th |> SIMP_RULE (srw_ss()++LET_ss) ((Q.ISPEC diff --git a/compiler/parsing/ocaml/camlPEGScript.sml b/compiler/parsing/ocaml/camlPEGScript.sml index 7d561e5708..149ec2dd4b 100644 --- a/compiler/parsing/ocaml/camlPEGScript.sml +++ b/compiler/parsing/ocaml/camlPEGScript.sml @@ -227,22 +227,27 @@ Datatype: | nTypeConstr | nTypeConstrName | nModulePath | nModuleName | nModTypePath | nModTypeName + | nFieldName | nOperatorName (* expressions *) | nLiteral | nIdent | nEBase | nEList | nEApp | nEConstr | nEFunapp | nEAssert | nELazy | nEPrefix | nENeg | nEShift | nEMult + | nERecProj | nERecUpdate | nERecCons | nEAdd | nECons | nECat | nERel | nEAnd | nEOr | nEProd | nEAssign | nEIf | nESeq | nEMatch | nETry | nEFun | nEFunction | nELet | nELetRec | nEWhile | nEFor | nExpr | nEUnclosed (* expressions that bind everything to the right *) + (* record updates *) + | nUpdate | nUpdates | nFieldDec | nFieldDecs (* pattern matches *) | nLetBinding | nLetBindings | nLetRecBinding | nLetRecBindings | nPatternMatch | nPatternMatches (* type definitions *) | nTypeDefinition | nTypeDef | nTypeDefs | nTypeParams | nTypeInfo - | nTypeRepr | nTypeReprs | nConstrDecl | nConstrArgs | nExcDefinition + | nTypeRepr | nTypeReprs | nConstrDecl | nConstrArgs | nRecord + | nExcDefinition (* patterns *) | nPAny | nPList | nPPar | nPBase | nPCons | nPAs | nPOps | nPattern | nPatterns @@ -307,6 +312,8 @@ Definition camlPEG_def[nocompute]: pegf (tokIdP identLower) (bindNT nTypeConstrName)); (INL nModuleName, pegf (tokIdP identUpperLower) (bindNT nModuleName)); + (INL nFieldName, + pegf (tokIdP identLower) (bindNT nFieldName)); (INL nValuePath, seql [try (seql [pnt nModulePath; tokeq DotT] I); pnt nValueName] (bindNT nValuePath)); @@ -476,8 +483,18 @@ Definition camlPEG_def[nocompute]: seql [tokeq BarT; pnt nConstrDecl; try (pnt nTypeReprs)] (bindNT nTypeReprs)); (INL nConstrDecl, - seql [pnt nConstrName; try (seql [tokeq OfT; pnt nConstrArgs] I)] + seql [pnt nConstrName; + try (seql [tokeq OfT; choicel [pnt nConstrArgs; pnt nRecord]] I)] (bindNT nConstrDecl)); + (INL nRecord, + seql [tokeq LbraceT; pnt nFieldDecs; try (tokeq SemiT); tokeq RbraceT] + (bindNT nRecord)); + (INL nFieldDecs, + seql [pnt nFieldDec; try (seql [tokeq SemiT; pnt nFieldDecs] I)] + (bindNT nFieldDecs)); + (INL nFieldDec, + seql [pnt nFieldName; tokeq ColonT; pnt nType] + (bindNT nFieldDec)); (INL nConstrArgs, seql [pnt nTConstr; rpt (seql [tokeq StarT; pnt nTConstr] I) FLAT] (bindNT nConstrArgs)); @@ -529,12 +546,23 @@ Definition camlPEG_def[nocompute]: tok (λx. MEM x [TrueT; FalseT]) (bindNT nLiteral o mktokLf)]); (INL nIdent, tok isIdent (bindNT nIdent o mktokLf)); + (INL nUpdate, + seql [pnt nFieldName; tokeq EqualT; pnt nEIf] + (bindNT nUpdate)); + (INL nUpdates, + seql [pnt nUpdate; try (seql [tokeq SemiT; pnt nUpdates] I)] + (bindNT nUpdates)); + (INL nERecUpdate, + seql [tokeq LbraceT; pnt nExpr; tokeq WithT; pnt nUpdates; + try (tokeq SemiT); tokeq RbraceT] + (bindNT nERecUpdate)); (INL nEBase, choicel [ pegf (pnt nLiteral) (bindNT nEBase); pegf (pnt nValuePath) (bindNT nEBase); pegf (pnt nConstr) (bindNT nEBase); pegf (pnt nEList) (bindNT nEBase); + pegf (pnt nERecUpdate) (bindNT nEBase); seql [tokeq LparT; tokeq RparT] (bindNT nEBase); (* unit *) seql [tokeq BeginT; tokeq EndT] (bindNT nEBase); (* unit *) seql [tokeq LparT; pnt nExpr; @@ -548,21 +576,31 @@ Definition camlPEG_def[nocompute]: (bindNT nPrefixOp)); (INL nEPrefix, seql [try (pnt nPrefixOp); pnt nEBase] (bindNT nEPrefix)); + (* -- Expr14.5 ------------------------------------------------------- *) + (INL nERecProj, + seql [pnt nEPrefix; + try (seql [tokeq DotT; pnt nFieldName] I)] + (bindNT nERecProj)); (* -- Expr14 --------------------------------------------------------- *) (INL nEAssert, - seql [tokeq AssertT; pnt nEPrefix] (bindNT nEAssert)); + seql [tokeq AssertT; pnt nERecProj] (bindNT nEAssert)); (INL nELazy, - seql [tokeq LazyT; pnt nEPrefix] (bindNT nELazy)); + seql [tokeq LazyT; pnt nERecProj] (bindNT nELazy)); (INL nEConstr, - seql [pnt nConstr; pnt nEPrefix] (bindNT nEConstr)); + seql [pnt nConstr; pnt nERecProj] (bindNT nEConstr)); + (INL nERecCons, + seql [pnt nConstr; + tokeq LbraceT; pnt nUpdates; try (tokeq SemiT); tokeq RbraceT] + (bindNT nERecCons)); (INL nEFunapp, - seql [pnt nEPrefix; rpt (pnt nEPrefix) FLAT] + seql [pnt nERecProj; rpt (pnt nERecProj) FLAT] (λl. case l of [] => [] | h::t => [FOLDL (λa b. mkNd (INL nEFunapp) [a; b]) (mkNd (INL nEFunapp) [h]) t])); (INL nEApp, - pegf (choicel (MAP pnt [nELazy; nEAssert; nEConstr; nEFunapp; nEPrefix])) + pegf (choicel (MAP pnt [nELazy; nEAssert; nERecCons; nEConstr; nEFunapp; + nERecProj])) (bindNT nEApp)); (* -- Expr13 --------------------------------------------------------- *) (INL nEUnclosed, @@ -955,10 +993,11 @@ end val npeg0_rwts = List.foldl pegnt [] [ “nShiftOp”, “nMultOp”, “nAddOp”, “nRelOp”, “nAndOp”, “nOrOp”, - “nHolInfixOp”, “nCatOp”, “nPrefixOp”, “nAssignOp”, - “nValueName”, “nOperatorName”, “nConstrName”, “nTypeConstrName”, - “nModuleName”, “nValuePath”, “nConstr”, “nTypeConstr”, “nModulePath”, - “nLiteral”, “nIdent”, “nEList”, “nEConstr”, “nEBase”, “nEPrefix”, + “nHolInfixOp”, “nCatOp”, “nPrefixOp”, “nAssignOp”, “nValueName”, + “nOperatorName”, “nConstrName”, “nTypeConstrName”, “nModuleName”, + “nValuePath”, “nConstr”, “nTypeConstr”, “nModulePath”, “nFieldName”, + “nUpdate”, “nUpdates”, “nERecUpdate”, “nERecCons”, “nLiteral”, + “nIdent”, “nEList”, “nEConstr”, “nEBase”, “nEPrefix”, “nERecProj”, “nELazy”, “nEAssert”, “nEFunapp”, “nEApp”, “nLetBinding”, “nPAny”, “nPList”, “nPPar”, “nPBase”, “nPCons”, “nPAs”, “nPOps”, “nPattern”, “nPatterns”, “nLetBindings”, “nLetRecBinding”, “nLetRecBindings”, @@ -995,25 +1034,26 @@ val topo_nts = [ “nShiftOp”, “nMultOp”, “nAddOp”, “nRelOp”, “nAndOp”, “nOrOp”, “nHolInfixOp”, “nCatOp”, “nPrefixOp”, “nAssignOp”, “nValueName”, “nOperatorName”, “nConstrName”, “nTypeConstrName”, “nModuleName”, - “nModulePath”, “nValuePath”, “nConstr”, “nTypeConstr”, “nLiteral”, - “nIdent”, “nEList”, “nEConstr”, “nEBase”, “nEPrefix”, “nELazy”, - “nEAssert”, “nEFunapp”, “nEApp”, “nPAny”, “nPList”, “nPPar”, “nPBase”, - “nPCons”, “nPAs”, “nPOps”, “nPattern”, “nPatterns”, “nLetBinding”, - “nLetBindings”, “nLetRecBinding”, “nLetRecBindings”, “nPatternMatches”, - “nPatternMatch”, “nEMatch”, “nETry”, “nEFun”, “nEFunction”, “nELet”, - “nELetRec”, “nEWhile”, “nEFor”, “nEUnclosed”, “nENeg”, “nEShift”, - “nEMult”, “nEAdd”, “nECons”, “nECat”, “nERel”, “nEAnd”, “nEOr”, - “nEHolInfix”, “nEProd”, “nEAssign”, “nEIf”, “nESeq”, “nExpr”, - “nTypeDefinition”, “nTVar”, “nTBase”, “nTConstr”, “nTProd”, “nTFun”, - “nType”, “nTypeList”, “nTypeLists”, “nTypeParams”, “nTypeDef”, - “nTypeDefs”, “nConstrDecl”, “nTypeReprs”, “nTypeRepr”, “nTypeInfo”, - “nConstrArgs”, “nExcDefinition”, “nTopLet”, “nTopLetRec”, “nOpen”, - “nSemis”, “nExprItem”, “nExprItems”, “nModuleDef”, “nModTypeName”, - “nModTypePath”, “nSigSpec”, “nExcType”, “nValType”, “nOpenMod”, - “nIncludeMod”, “nModTypeAsc”, “nModTypeAssign”, “nSigItem”, “nSigItems”, - “nModuleType”, “nModAscApp”, “nModAscApps”, “nCakeMLPragma”, - “nModuleTypeDef”, “nModExpr”, “nDefinition”, “nDefItem”, “nModuleItem”, - “nModuleItems”, “nStart”]; + “nModulePath”, “nValuePath”, “nConstr”, “nTypeConstr”, “nFieldName”, + “nLiteral”, “nIdent”, “nEList”, “nEConstr”, “nERecUpdate”, + “nERecCons”, “nEBase”, “nEPrefix”, “nERecProj”, “nELazy”, “nEAssert”, + “nEFunapp”, “nEApp”, “nPAny”, “nPList”, “nPPar”, “nPBase”, “nPCons”, + “nPAs”, “nPOps”, “nPattern”, “nPatterns”, “nLetBinding”, “nLetBindings”, + “nLetRecBinding”, “nLetRecBindings”, “nPatternMatches”, “nPatternMatch”, + “nEMatch”, “nETry”, “nEFun”, “nEFunction”, “nELet”, “nELetRec”, + “nEWhile”, “nEFor”, “nEUnclosed”, “nENeg”, “nEShift”, “nEMult”, “nEAdd”, + “nECons”, “nECat”, “nERel”, “nEAnd”, “nEOr”, “nEHolInfix”, “nEProd”, + “nEAssign”, “nEIf”, “nESeq”, “nExpr”, “nTypeDefinition”, “nTVar”, + “nTBase”, “nTConstr”, “nTProd”, “nTFun”, “nType”, “nTypeList”, + “nTypeLists”, “nTypeParams”, “nTypeDef”, “nTypeDefs”, “nConstrDecl”, + “nTypeReprs”, “nTypeRepr”, “nTypeInfo”, “nUpdate”, “nUpdates”, + “nFieldDec”, “nFieldDecs”, “nRecord”, “nConstrArgs”, “nExcDefinition”, + “nTopLet”, “nTopLetRec”, “nOpen”, “nSemis”, “nExprItem”, “nExprItems”, + “nModuleDef”, “nModTypeName”, “nModTypePath”, “nSigSpec”, “nExcType”, + “nValType”, “nOpenMod”, “nIncludeMod”, “nModTypeAsc”, “nModTypeAssign”, + “nSigItem”, “nSigItems”, “nModuleType”, “nModAscApp”, “nModAscApps”, + “nCakeMLPragma”, “nModuleTypeDef”, “nModExpr”, “nDefinition”, + “nDefItem”, “nModuleItem”, “nModuleItems”, “nStart”]; val cml_wfpeg_thm = save_thm( "cml_wfpeg_thm", diff --git a/compiler/parsing/ocaml/camlPtreeConversionScript.sml b/compiler/parsing/ocaml/camlPtreeConversionScript.sml index 30963528de..0e708bbaab 100644 --- a/compiler/parsing/ocaml/camlPtreeConversionScript.sml +++ b/compiler/parsing/ocaml/camlPtreeConversionScript.sml @@ -481,6 +481,23 @@ Definition ptree_TypeConstrName_def: fail (locs, «Expected typeconstr-name non-terminal») End +Definition ptree_FieldName_def: + ptree_FieldName (Lf (_, locs)) = + fail (locs, «Expected fieldname non-terminal») ∧ + ptree_FieldName (Nd (nterm, locs) args) = + if nterm = INL nFieldName then + case args of + [arg] => + do + lf <- destLf arg; + tk <- option $ destTOK lf; + option $ destIdent tk + od + | _ => fail (locs, «Impossible: nFieldName») + else + fail (locs, «Expected fieldname non-terminal») +End + Definition ptree_ModuleName_def: ptree_ModuleName (Lf (_, locs)) = fail (locs, «Expected modulename non-terminal») ∧ @@ -987,8 +1004,7 @@ Definition ptree_PPattern_def: fail (locs, «Impossible: nPBase») od | _ => fail (locs, «Impossible: nPBase») - else if nterm = INL nPCons then - case args of + else if nterm = INL nPCons then case args of [cn] => do cns <- ptree_Constr cn; @@ -1260,6 +1276,51 @@ Definition flatten_pmatch_def: flatten_pmatch pss = FLAT (MAP (λ(ps,x,w). MAP (λp. (p,x,w)) ps) pss) End +Definition mk_record_update_name_def: + mk_record_update_name field = "{record_update(" ++ field ++ ")}" +End + +Definition build_record_upd_def: + build_record_upd b (f,x) = + App Opapp [App Opapp [Var (Short (mk_record_update_name f)); b]; x] +End + +Definition mk_record_proj_name_def: + mk_record_proj_name field = "{record_projection(" ++ field ++ ")}" +End + +Definition build_record_proj_def: + build_record_proj f x = + App Opapp [Var (Short (mk_record_proj_name f)); x] +End + +Definition mk_record_constr_name_def: + mk_record_constr_name constr fields = + FLAT $ ["{record_constructor("; constr; ")"] ++ + MAP (λfn. "(" ++ fn ++ ")") fields ++ ["}"] +End + +Definition build_record_cons_id_def: + build_record_cons_id fns [] = + fail (unknown_loc, «build_record_cons_id: empty path») ∧ + build_record_cons_id fns [cn] = + return $ Short $ mk_record_constr_name cn fns ∧ + build_record_cons_id fns (c::cs) = + do + id <- build_record_cons_id fns cs; + return $ Long c id + od +End + +Definition build_record_cons_def: + build_record_cons path upds = + let (names,exprs) = UNZIP (QSORT (λ(f,_) (g,_). string_lt f g) upds) in + do + id <- build_record_cons_id names path; + return $ build_funapp (Var id) exprs + od +End + Definition ptree_Expr_def: (ptree_Expr et (Lf (_, locs)) = fail (locs, «Expected an expression non-terminal»)) ∧ @@ -1342,7 +1403,9 @@ Definition ptree_Expr_def: | [arg] => do n <- nterm_of arg; - if n = INL nLiteral then + if n = INL nERecUpdate then + ptree_Expr nERecUpdate arg + else if n = INL nLiteral then fmap (λid. Con (SOME id) []) (ptree_Bool arg) ++ fmap Lit (ptree_Literal arg) else if n = INL nValuePath then @@ -1363,12 +1426,65 @@ Definition ptree_Expr_def: fail (locs, «Impossible: nEBase») od | _ => fail (locs, «Impossible: nEBase») + else if nterm = INL nERecUpdate then + case args of + [lb; x; witht; upds; semi; rb] => + do + expect_tok lb LbraceT; + expect_tok witht WithT; + expect_tok semi SemiT; + expect_tok rb RbraceT; + e <- ptree_Expr nExpr x; + us <- ptree_Updates upds; + return $ FOLDL build_record_upd e us + od + | [lb; x; witht; upds; rb] => + do + expect_tok lb LbraceT; + expect_tok witht WithT; + expect_tok rb RbraceT; + e <- ptree_Expr nExpr x; + us <- ptree_Updates upds; + return $ FOLDL build_record_upd e us + od + | _ => fail (locs, «Impossible: nERecUpdate») + else if nterm = INL nERecProj then + case args of + [arg] => ptree_Expr nEPrefix arg + | [arg; dot; fn] => + do + expect_tok dot DotT; + x <- ptree_Expr nEPrefix arg; + f <- ptree_FieldName fn; + return $ build_record_proj f x + od + | _ => fail (locs, «Impossible: nERecProj») + else if nterm = INL nERecCons then + case args of + [cons; lb; upds; semi; rb] => + do + expect_tok lb LbraceT; + expect_tok semi SemiT; + expect_tok rb RbraceT; + path <- ptree_Constr cons; + us <- ptree_Updates upds; + build_record_cons path us + od + | [cons; lb; upds; rb] => + do + expect_tok lb LbraceT; + expect_tok rb RbraceT; + path <- ptree_Constr cons; + us <- ptree_Updates upds; + build_record_cons path us + od + | _ => fail (locs, «Impossible: nERecCons») else if nterm = INL nEAssert then case args of [assr; expr] => do expect_tok assr AssertT; - x <- ptree_Expr nEPrefix expr; + x <- ptree_Expr nERecProj expr; return (App Opapp [Var (Short "assert"); x]) od | _ => fail (locs, «Impossible: nEAssert») @@ -1377,7 +1493,7 @@ Definition ptree_Expr_def: [lazy; expr] => do expect_tok lazy LazyT; - x <- ptree_Expr nEPrefix expr; + x <- ptree_Expr nERecProj expr; return (App Opapp [Var (Short "lazy"); x]) od | _ => fail (locs, «Impossible: nELazy») @@ -1387,17 +1503,17 @@ Definition ptree_Expr_def: do cns <- ptree_Constr consid; id <- path_to_ns locs cns; - x <- ptree_Expr nEPrefix expr; + x <- ptree_Expr nERecProj expr; return $ compatCurryE id x od | _ => fail (locs, «Impossible: nEConstr») else if nterm = INL nEFunapp then case args of - [exp] => ptree_Expr nEPrefix exp + [exp] => ptree_Expr nERecProj exp | [fexp; aexp] => do f <- ptree_Expr nEFunapp fexp; - x <- ptree_Expr nEPrefix aexp; + x <- ptree_Expr nERecProj aexp; return (build_funapp f [x]) od | _ => fail (locs, «Impossible: nEFunapp») @@ -1414,8 +1530,10 @@ Definition ptree_Expr_def: ptree_Expr nEConstr arg else if n = INL nEFunapp then ptree_Expr nEFunapp arg - else if n = INL nEPrefix then - ptree_Expr nEPrefix arg + else if n = INL nERecCons then + ptree_Expr nERecCons arg + else if n = INL nERecProj then + ptree_Expr nERecProj arg else fail (locs, «Impolssible: nEApp») od @@ -1905,7 +2023,38 @@ Definition ptree_Expr_def: y <- ptree_Expr nEHolInfix x; ys <- ptree_ExprCommas xs; return (y::ys) - od) + od) ∧ + (ptree_Update (Lf (_, locs)) = + fail (locs, «Expected an update non-terminal»)) ∧ + (ptree_Update (Nd (nterm,locs) args) = + if nterm = INL nUpdate then + case args of + [fd; eq; expr] => + do + expect_tok eq EqualT; + f <- ptree_FieldName fd; + x <- ptree_Expr nEIf expr; + return (f, x) + od + | _ => fail (locs, «Impossible: nUpdate») + else + fail (locs, «Expected an update non-terminal»)) ∧ + (ptree_Updates (Lf (_, locs)) = + fail (locs, «Expected an updates non-terminal»)) ∧ + (ptree_Updates (Nd (nterm,locs) args) = + if nterm = INL nUpdates then + case args of + [upd] => fmap (λu. [u]) $ ptree_Update upd + | [upd; semi; upds] => + do + expect_tok semi SemiT; + u <- ptree_Update upd; + us <- ptree_Updates upds; + return (u::us) + od + | _ => fail (locs, «Impossible: nUpdates») + else + fail (locs, «Expected an updates non-terminal»)) Termination WF_REL_TAC ‘measure $ sum_size (pair_size camlNT_size psize) $ sum_size psize @@ -1914,7 +2063,9 @@ Termination $ sum_size psize $ sum_size psize $ sum_size psize - $ sum_size (SUC o list_size psize) (SUC o list_size psize)’ + $ sum_size (SUC o list_size psize) + $ sum_size (SUC o list_size psize) + $ sum_size psize psize’ \\ simp [parsetree_size_lemma] End @@ -1923,6 +2074,75 @@ End Theorem ptree_Expr_ind = ptree_Expr_ind |> SIMP_RULE (srw_ss() ++ CONJ_ss) []; +Definition ptree_FieldDec_def: + ptree_FieldDec (Lf (_, locs)) = + fail (locs, «Expected a field declaration non-terminal») ∧ + ptree_FieldDec (Nd (nterm, locs) args) = + if nterm = INL nFieldDec then + case args of + [fn; colon; ty] => + do + expect_tok colon ColonT; + f <- ptree_FieldName fn; + t <- ptree_Type ty; + return (f, t) + od + | _ => fail (locs, «Impossible: nFieldDec») + else + fail (locs, «Expected a field declaration non-terminal») +End + +Definition ptree_FieldDecs_def: + ptree_FieldDecs (Lf (_, locs)) = + fail (locs, «Expected a field decls non-terminal») ∧ + ptree_FieldDecs (Nd (nterm, locs) args) = + if nterm = INL nFieldDecs then + case args of + [fdec] => fmap (λfd. [fd]) $ ptree_FieldDec fdec + | [fdec; semi; fdecs] => + do + expect_tok semi SemiT; + f <- ptree_FieldDec fdec; + fs <- ptree_FieldDecs fdecs; + return (f::fs) + od + | _ => fail (locs, «Impossible: nFieldDecs») + else + fail (locs, «Expected a field declaration non-terminal») +End + +(* + * Record definitions return a list of (field_name,type) pairs. + *) + +Definition ptree_Record_def: + ptree_Record (Lf (_, locs)) = + fail (locs, «Expected a record constructor») ∧ + ptree_Record (Nd (nterm, locs) args) = + if nterm = INL nRecord then + case args of + [lb; fds; semi; rb] => + do + expect_tok lb LbraceT; + expect_tok semi SemiT; + expect_tok rb RbraceT; + ptree_FieldDecs fds + od + | [lb; fds; rb] => + do + expect_tok lb LbraceT; + expect_tok rb RbraceT; + ptree_FieldDecs fds + od + | _ => fail (locs, «Impossible: nRecord») + else + fail (locs, «Expected a record constructor») +End + +(* + * Vanilla constructor definitions return a list of types. + *) + Definition ptree_ConstrArgs_def: ptree_ConstrArgs (Lf (_, locs)) = fail (locs, «Expected a constructor arguments non-terminal») ∧ @@ -1940,6 +2160,13 @@ Definition ptree_ConstrArgs_def: fail (locs, «Expected a constructor arguments non-terminal») End +(* + * A constructor declaration returns one of: + * - a name and a list of types (a regular constructor) + * - a name and a list of (name*type) pairs (record constructor) + * The latter causes a bunch of definitions to be generated. + *) + Definition ptree_ConstrDecl_def: ptree_ConstrDecl (Lf (_, locs)) = fail (locs, «Expected a constructor declaration non-terminal») ∧ @@ -1947,13 +2174,24 @@ Definition ptree_ConstrDecl_def: if nterm = INL nConstrDecl then case args of [name] => - fmap (λnm. (nm,[])) $ ptree_ConstrName name + fmap (λnm. INL (nm,[])) $ ptree_ConstrName name | [name; oft; args] => do expect_tok oft OfT; nm <- ptree_ConstrName name; - ts <- ptree_ConstrArgs args; - return (nm, ts) + nt <- nterm_of args; + if nt = INL nRecord then + do + ts <- ptree_Record args; + return $ INR (nm, ts) + od + else if nt = INL nConstrArgs then + do + ts <- ptree_ConstrArgs args; + return $ INL (nm, ts) + od + else + fail (locs, «Impossible: nConstrDecl») od | _ => fail (locs, «Impossible: nConstrDecl») else @@ -1969,8 +2207,10 @@ Definition ptree_ExcType_def: [exnt; cdecl] => do expect_tok exnt ExceptionT; - (nm, args) <- ptree_ConstrDecl cdecl; - return () (* No types in the CakeML ast *) + res <- ptree_ConstrDecl cdecl; + case res of + | INR _ => fail (locs, «Record type exceptions are forbidden») + | INL (nm, args) => return () (* No types in the CakeML ast *) od | _ => fail (locs, «Impossible: nExcType») @@ -1996,8 +2236,10 @@ Definition ptree_ExcDefinition_def: [exnt; cdecl] => do expect_tok exnt ExceptionT; - (nm, args) <- ptree_ConstrDecl cdecl; - return $ Dexn locs nm (ctor_tup args) + res <- ptree_ConstrDecl cdecl; + case res of + | INR _ => fail (locs, «Record type exceptions are forbidden») + | INL (nm, args) => return $ Dexn locs nm (ctor_tup args) od | [exnt; lhsid; eq; rhsid] => fail (locs, «Exception abbreviation is not supported») @@ -2006,9 +2248,10 @@ Definition ptree_ExcDefinition_def: fail (locs, «Expected an exception definition non-terminal») End -(* ptree_TypeRepr picks out constructor declarations and returns - * a list of (constructor_name # argument_types) pairs, one for - * each constructor. +(* ptree_TypeRepr takes apart the rows in a datatype declaration + * and returns a list where each element is one of: + * - a name and a list of types (a regular constructor) + * - a name and a list of (name*type) pairs (record constructor) *) Definition ptree_TypeRepr_def: @@ -2067,17 +2310,14 @@ Definition ptree_TypeInfo_def: ptree_TypeInfo (Nd (nterm, locs) args) = if nterm = INL nTypeInfo then case args of - [eq; arg] => + [eqt; arg] => do - expect_tok eq EqualT; + expect_tok eqt EqualT; n <- nterm_of arg; if n = INL nType then fmap INL (ptree_Type arg) else if n = INL nTypeRepr then - do - tr <- ptree_TypeRepr arg; - return $ INR $ MAP (λ(n,ts). (n, ctor_tup ts)) tr - od + fmap INR (ptree_TypeRepr arg) else fail (locs, «Impossible: nTypeInfo») od @@ -2196,12 +2436,97 @@ Definition ptree_TypeDefs_def: fail (locs, «Expected a typedef:s non-terminal») End -(* Ocaml datatype definitions and type abbreviations can be made mutually - * recursive with each other and this is not supported in CakeML. Example: - * type foo = A of bar | B of baz | ... - * and baz = foo list +(* Builds the constructor, projection, and update functions for a record + * datatype constructor. + *) + +Definition build_rec_funs_def: + build_rec_funs (locs, cname, fds) = + let vars = MAP (Var o Short) fds in + let rhs = Con (SOME (Short cname)) + (case vars of + | _::_::_ => [Con NONE vars] + | _ => vars) in + let constr = Dlet locs (Pvar (mk_record_constr_name cname fds)) + (FOLDR (λf x. Fun f x) rhs fds) in + let pvars = MAP Pvar fds in + let pat = Pcon (SOME (Short cname)) + (case pvars of + | _::_::_ => [Pcon NONE pvars] + | _ => pvars) in + let projs = MAP (λf. + Dlet locs (Pvar (mk_record_proj_name f)) + (Fun "" (Mat (Var (Short "")) + [(pat, Var (Short f))]))) fds in + let upds = MAP (λf. + Dlet locs (Pvar (mk_record_update_name f)) + (Fun "" (Mat (Var (Short "")) + [(pat, Fun f rhs)]))) fds in + constr :: projs ++ upds +End + +(* This function attempts to make sense of different type declarations. It has + * grown quite convoluted. ptree_TypeDefs returns a list of tuples: + * + * (locs * (tvarN list) * name * (ast_t + ast_t list + (name * ast_t) list)) + * + * The sum type chooses between the three kinds of type declarations: + * - type abbreviations: (ast_t) + * "type foo = bar" + * - datatype declarations: (ast_t list) + * "type foo = C of args | D | ..." + * - record datatype declarations: ((name # ast_t) list) + * "type foo = C { arg1 : type1; ...}" + * + * The latter two can be mixed within one declaration. Type declarations can + * also be mutually recursive, but the type abbreviation cannot be put into + * mutual recursion with the datatype declarations. + * + * A record constructor is turned into a datatype constructor and a set of + * function definitions for projection, update and construction of values of the + * record datatype. + *) + +Definition partition_types_def: + partition_types tdefs = + let (abbrevs,datas) = PARTITION (λ(_,_,_,trs). ISL trs) tdefs in + let abbrevs = MAP (λ(l,tvs,cn,trs). (l,tvs,cn,OUTL trs)) abbrevs in + let datas = MAP (λ(l,tvs,cn,trs). (l,tvs,cn,OUTR trs)) datas in + (abbrevs,datas) +End + +Definition sort_records_def: + sort_records (locs,tvs,tn,tds) = + (locs,tvs,tn, + MAP (λtdef. + case tdef of + | INL (cn,tys) => INL (cn,tys) + | INR (cn,fds) => INR (cn,QSORT (λ(l,_) (r,_). string_lt l r) fds)) tds) +End + +Definition MAP_OUTR_def: + MAP_OUTR f [] = [] ∧ + MAP_OUTR f ((INR x)::xs) = f x :: MAP_OUTR f xs ∧ + MAP_OUTR f ((INL x)::xs) = MAP_OUTR f xs +End + +Definition extract_record_defns_def: + extract_record_defns (locs,tvs,tn,tds) = + MAP_OUTR (λ(cn,fds). (locs,cn,MAP FST fds)) tds +End + +(* Flattens records into regular datatype constructors. Multi-argument + * constructors are turned into single argument constructors with tuple + * arguments. *) +Definition strip_record_fields_def: + strip_record_fields (locs,tvs,cn,trs) = + (locs,tvs,cn,MAP (λtr. case tr of + | INL (n,tys) => (n, ctor_tup tys) + | INR (n,fds) => (n, ctor_tup (MAP SND fds))) trs) +End + Definition ptree_TypeDefinition_def: ptree_TypeDefinition (Lf (_, locs)) = fail (locs, «Expected a type definition non-terminal») ∧ @@ -2212,31 +2537,35 @@ Definition ptree_TypeDefinition_def: do expect_tok typet TypeT; expect_tok nrec NonrecT; - tdefs <- fmap REVERSE $ ptree_TypeDefs tds; - if EVERY (λ(locs,tys,nm,trs). ISL trs) tdefs then - return $ MAP (λ(locs,tys,nm,trs). Dtabbrev locs tys nm (OUTL trs)) - tdefs - else if EVERY (λ(locs,tys,nm,trs). ISR trs) tdefs then - return $ [Dtype locs (MAP (λ(_,tys,nm,trs). (tys,nm,OUTR trs)) - tdefs)] - else - fail (locs, concat [ - «Type abbreviations and datatype definitions cannot be»; - « mutually recursive in CakeML»]) + fail (locs, «nonrec type definitions are not supported») od | [typet; tds] => do expect_tok typet TypeT; tdefs <- fmap REVERSE $ ptree_TypeDefs tds; - (abbrevs,datas) <<- PARTITION (λ(_,tys,nm,trs). ISL trs) tdefs; + (abbrevs,datas) <<- partition_types tdefs; + if abbrevs ≠ [] ∧ datas ≠ [] then + fail (locs, concat[ + «datatypes and type abbreviations cannot be made »; + «mutually recursive»]) else return (); abbrevs <<- - MAP (λ(locs,tys,nm,trs). Dtabbrev locs tys nm (OUTL trs)) - abbrevs; + MAP (λ(locs,tys,nm,trs). Dtabbrev locs tys nm trs) abbrevs; case datas of - [] => return abbrevs - | _ => let datas = Dtype locs - (MAP (λ(_,tys,nm,trs). (tys,nm,OUTR trs)) datas) - in return (datas::abbrevs) + | [] => return abbrevs + | _ => + do + defs <<- MAP sort_records datas; + recs <<- FLAT $ MAP extract_record_defns defs; + if ¬EVERY (ALL_DISTINCT o SND o SND) recs then + fail (locs, «record field names must be distinct») + else return (); + recfuns <<- FLAT $ MAP build_rec_funs recs; + defs <<- MAP strip_record_fields defs; + (* Datatype constructors for everything: *) + datas <<- Dtype locs (MAP SND defs); + (* Record-related function definitions: *) + return (datas::abbrevs ++ recfuns) + od od | _ => fail (locs, «Impossible: nTypeDefinition») else diff --git a/compiler/parsing/ocaml/camlTestsScript.sml b/compiler/parsing/ocaml/camlTestsScript.sml index 04df6ebe04..c0ac05650c 100644 --- a/compiler/parsing/ocaml/camlTestsScript.sml +++ b/compiler/parsing/ocaml/camlTestsScript.sml @@ -443,6 +443,80 @@ val _ = parsetest0 “nPattern” “ptree_Pattern” (SOME “[Pc "Cn" [Pcon NONE [Pv "x"; Pas (Pv "y") "z"]]]”) ; +(* ------------------------------------------------------------------------- + * Record syntax + * ------------------------------------------------------------------------- *) + +(* record projection and update *) + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "x.foo" + (SOME (rconc $ EVAL “App Opapp [V (mk_record_proj_name "foo"); V "x"]”)) + ; + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "{x with foo = bar}" + (SOME (rconc $ EVAL “App Opapp [App Opapp [ + V (mk_record_update_name "foo"); V "x"]; V "bar"]”)) + ; + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "{x with foo = bar;}" + (SOME (rconc $ EVAL “App Opapp [App Opapp [ + V (mk_record_update_name "foo"); V "x"]; V "bar"]”)) + ; + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "{x with foo = bar; baz = quux;}" + (SOME (rconc $ EVAL “App Opapp [App Opapp [V (mk_record_update_name "baz"); + App Opapp [App Opapp [V (mk_record_update_name "foo"); + V "x"]; V "bar"]]; V "quux"]”)) + ; + +(* construction *) + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "Foo { foo = 5; bar = true }" + (SOME (rconc $ EVAL + “App Opapp [App Opapp [V (mk_record_constr_name "Foo" ["bar";"foo"]); + (C "True" [])]; + Lit (IntLit 5)]”)) + ; + +val _ = parsetest0 “nExpr” “ptree_Expr nExpr” + "Foo { f2 = 2; f1 = 1; f3 = 3;}" + NONE + ; + +(* declaration *) + +val _ = parsetest0 “nStart” “ptree_Start” + "type rec1 = Foo of {f3: t3; f1: t1; f2: t2};;" + NONE + ; + +val _ = parsetest0 “nStart” “ptree_Start” + "type rec1 = Foo of {foo: int; bar: bool};;" + (SOME (rconc $ EVAL “ + [Dtype L [([],"rec1",[("Foo",[Attup [Atapp [] (Short "bool"); Atapp [] (Short "int")]])])]; + Dlet L1 (Pv (mk_record_constr_name "Foo" ["bar";"foo"])) + (Fun "bar" (Fun "foo" (C "Foo" [Con NONE [V "bar"; V "foo"]]))); + Dlet L2 (Pv (mk_record_proj_name "bar")) + (Fun "" (Mat (V "") [(Pc "Foo" [Pcon NONE [Pv "bar"; Pv "foo"]],V "bar")])); + Dlet L3 (Pv (mk_record_proj_name "foo")) + (Fun "" (Mat (V "") [(Pc "Foo" [Pcon NONE [Pv "bar"; Pv "foo"]],V "foo")])); + Dlet L4 (Pv (mk_record_update_name "bar")) + (Fun "" + (Mat (V "") + [(Pc "Foo" [Pcon NONE [Pv "bar"; Pv "foo"]], + Fun "bar" (C "Foo" [Con NONE [V "bar"; V "foo"]]))])); + Dlet L5 (Pv (mk_record_update_name "foo")) + (Fun "" + (Mat (V "") + [(Pc "Foo" [Pcon NONE [Pv "bar"; Pv "foo"]], + Fun "foo" (C "Foo" [Con NONE [V "bar"; V "foo"]]))]))]”)) + ; + (* ------------------------------------------------------------------------- * Expressions * ------------------------------------------------------------------------- *) diff --git a/compiler/parsing/ocaml/caml_parserScript.sml b/compiler/parsing/ocaml/caml_parserScript.sml index d3083767a9..964c79744f 100644 --- a/compiler/parsing/ocaml/caml_parserScript.sml +++ b/compiler/parsing/ocaml/caml_parserScript.sml @@ -53,8 +53,7 @@ Definition run_parser_def: [ptree] => (case ptree_Start ptree of INR x => INR x - | INL (loc, err) => - fail (loc, concat [«Ptree conversion: »; err])) + | INL (loc, err) => fail (loc, err)) | _ => fail (unknown_loc, «Impossible: run_parser») od End