diff --git a/adapter/ra_sl.c b/adapter/ra_sl.c new file mode 100644 index 0000000000000000000000000000000000000000..3a2b077d479aa0a35d0d1675698dfc22b442b594 --- /dev/null +++ b/adapter/ra_sl.c @@ -0,0 +1,125 @@ +#include "proof/adapter/ra_sl.h" +#include "proof/theory/logic/resource_prop_internal.h" + +#require "proof/proof_sl.c" +#require "proof/theory/logic/resource_prop.c" + +PROOF int ra_sl_build(const term R, sl_theory *out) { + ENSURE_COND(out != NULL, "resource SL output bundle must not be null"); + bool R_is_empty = IS_NULL(R); + ENSURE_COND(!R_is_empty, "resource SL algebra must not be empty"); + term_list R_free_vars = free_vars(R); + size_t R_free_var_count = vector_size(R_free_vars); + ENSURE_COND(R_free_var_count == 0, "resource SL algebra must be closed"); + type_list R_term_tyvars = term_tyvars(R); + size_t R_term_tyvar_count = vector_size(R_term_tyvars); + ENSURE_COND(R_term_tyvar_count == 0, + "resource SL algebra term must be monomorphic"); + + type ra_type = type_of(R); + type_list ra_type_tyvars = type_tyvars(ra_type); + size_t ra_type_tyvar_count = vector_size(ra_type_tyvars); + ENSURE_COND(ra_type_tyvar_count == 0, + "resource SL algebra type must be monomorphic"); + bool ra_type_is_application = is_app_type(ra_type); + ENSURE_COND(ra_type_is_application, + "resource SL algebra must have type `(A)ra`"); + dest_app_type_results ra_shape = dest_app_type(ra_type); + int ra_name_order = strcmp(ra_shape.s, "ra"); + size_t ra_argument_count = vector_size(ra_shape.tys); + bool ra_shape_is_unary = ra_name_order == 0 && ra_argument_count == 1; + ENSURE_COND(ra_shape_is_unary, + "resource SL algebra must have unary type `(A)ra`"); + + type carrier_type = ra_shape.tys[0]; + type bool_type = mk_bool_type(); + type prop_type = mk_fun_type(carrier_type, bool_type); + type prop_to_prop_type = mk_fun_type(prop_type, prop_type); + type binary_prop_type = mk_fun_type(prop_type, prop_to_prop_type); + type prop_to_bool_type = mk_fun_type(prop_type, bool_type); + type binary_relation_type = mk_fun_type(prop_type, prop_to_bool_type); + type fact_type = mk_fun_type(bool_type, prop_type); + type witness_type = mk_var_type("B"); + type witness_family_type = mk_fun_type(witness_type, prop_type); + type exists_type = mk_fun_type(witness_family_type, prop_type); + + sl_theory theory; + theory.prop_type = prop_type; + + type emp_head_type = mk_fun_type(ra_type, prop_type); + term head = mk_const("r_emp", emp_head_type); + theory.emp = mk_comb(head, R); + + type binary_prop_head_type = mk_fun_type(ra_type, binary_prop_type); + head = mk_const("r_sep", binary_prop_head_type); + theory.sep = mk_comb(head, R); + + head = mk_const("r_wand", binary_prop_head_type); + theory.wand = mk_comb(head, R); + + head = mk_const("r_and", binary_prop_head_type); + theory.and_op = mk_comb(head, R); + + head = mk_const("r_or", binary_prop_head_type); + theory.or_op = mk_comb(head, R); + + /* Leave only the witness type polymorphic. `proof_sl` explicitly + * instantiates this variable before applying the operator to an assertion + * family; HOL's raw `mk_comb` does not perform that instantiation. */ + type exists_head_type = mk_fun_type(ra_type, exists_type); + head = mk_const("r_exists", exists_head_type); + theory.exists_op = mk_comb(head, R); + + head = mk_const("r_forall", exists_head_type); + theory.forall_op = mk_comb(head, R); + + type relation_head_type = mk_fun_type(ra_type, binary_relation_type); + head = mk_const("r_entails", relation_head_type); + theory.entails = mk_comb(head, R); + + head = mk_const("r_equiv", relation_head_type); + theory.equiv = mk_comb(head, R); + + type fact_head_type = mk_fun_type(ra_type, fact_type); + head = mk_const("r_fact", fact_head_type); + theory.fact = mk_comb(head, R); + + /* The ACU and existential-distribution laws are exact predicate equalities; + * logical antisymmetry is deliberately installed as `r_equiv` instead. */ + theory.sep_emp_left = ispec_rule(R, r_sep_emp_l_eq); + theory.sep_emp_right = ispec_rule(R, r_sep_emp_r_eq); + theory.sep_assoc = ispec_rule(R, r_sep_assoc_eq); + theory.sep_comm = ispec_rule(R, r_sep_comm_eq); + theory.sep_mono = ispec_rule(R, r_sep_mono); + theory.wand_sep_adjoint = ispec_rule(R, r_wand_adjunction); + + theory.and_intro = ispec_rule(R, r_and_intro); + theory.and_elim1 = ispec_rule(R, r_and_elim_l); + theory.and_elim2 = ispec_rule(R, r_and_elim_r); + theory.or_intro1 = ispec_rule(R, r_or_intro_l); + theory.or_intro2 = ispec_rule(R, r_or_intro_r); + theory.or_elim = ispec_rule(R, r_or_elim); + + theory.exists_intro = ispec_rule(R, r_exists_intro); + theory.exists_elim = ispec_rule(R, r_exists_elim); + theory.exists_mono = ispec_rule(R, r_exists_mono); + theory.sep_exists_left = ispec_rule(R, r_sep_exists_l_eq); + theory.sep_exists_right = ispec_rule(R, r_sep_exists_r_eq); + theory.forall_intro = ispec_rule(R, r_forall_intro); + theory.forall_elim = ispec_rule(R, r_forall_elim_cont); + + theory.ent_refl = ispec_rule(R, r_entails_refl); + theory.ent_trans = ispec_rule(R, r_entails_trans); + theory.equiv_intro = ispec_rule(R, r_equiv_intro); + + theory.fact_intro = ispec_rule(R, r_fact_intro); + theory.fact_elim = ispec_rule(R, r_fact_elim); + theory.fact_dup = ispec_rule(R, r_fact_dup); + theory.fact_true_emp = ispec_rule(R, r_fact_true_eq); + + *out = theory; + return 0; +err: + ERR_FUN_PUTS("ra_sl_build"); + return -1; +} diff --git a/adapter/ra_sl.h b/adapter/ra_sl.h new file mode 100644 index 0000000000000000000000000000000000000000..4fe20cc7f0937652ab43c4a039bcfad2f5ed333c --- /dev/null +++ b/adapter/ra_sl.h @@ -0,0 +1,47 @@ +/** + * @file ra_sl.h + * @brief Adapt generic resource propositions to the installable SL signature. + * + * For a closed monomorphic algebra `R:(A)ra`, `ra_sl_build` specializes the + * language-independent BI operators at `R`; the resulting assertion type is + * `A->bool`. Entailment and logical equivalence observe valid resources. + * + * The underlying theory intentionally has two proposition embeddings: + * + * - `r_pure R phi a <=> phi` is independent of the owned resource; + * - `r_fact R phi a <=> phi /\ a = ra_unit R` is exact-unit and spatial. + * + * `sl_theory` exposes the latter as its `fact` operator. A selected alias scope + * adds `pure` separately; see `ra_sl_scope.h`. + * + * Public resource-proposition laws state connective algebra through `r_equiv`. + * The generic proof engine additionally needs a few exact predicate equalities + * for certified SEP normalization. This adapter is the boundary that selects + * those private equalities; clients should not depend on them directly. + * + * This module constructs only the base BI signature. It does not install it, + * select parser notation, add update modalities, or provide C memory and + * symbolic-state semantics. + */ + +#pragma once + +#include "proof/proof_sl.h" +#include "proof/theory/logic/resource_prop.h" + +/** + * Build the generic resource-proposition proof bundle specialized at `R`. + * + * `R` must be a nonempty, closed, monomorphic term whose type is exactly a + * unary RA application `(A)ra`. The returned operators are the direct + * applications `r_emp R`, `r_sep R`, and so on, and every theorem in the + * bundle uses those same heads. This function does not mutate the active SL + * theory or any parser interface. + * + * `out` must be non-null and remains owned by the caller; its term and theorem + * handles refer to prover-global immutable HOL objects. + * + * @return Zero on success, or `-1` after setting proof error status if `R` or + * `out` violates the contract or specialization fails. + */ +PROOF int ra_sl_build(const term R, sl_theory* out); diff --git a/adapter/ra_sl_scope.c b/adapter/ra_sl_scope.c new file mode 100644 index 0000000000000000000000000000000000000000..7c19c112cb0ff94a257b9529637aa8f19ab8809c --- /dev/null +++ b/adapter/ra_sl_scope.c @@ -0,0 +1,245 @@ +#include "proof/adapter/ra_sl_scope_internal.h" + +#require "proof/syntax/base.c" +#require "proof/adapter/ra_sl.c" + +PROOF bool sl_scope_name_is_valid(const char *scope_name) { + if (scope_name == NULL || scope_name[0] == '\0') + return false; + for (size_t i = 0; scope_name[i] != '\0'; ++i) { + char ch = scope_name[i]; + if (!(('a' <= ch && ch <= 'z') || ('A' <= ch && ch <= 'Z') || + ('0' <= ch && ch <= '9') || ch == '_')) { + return false; + } + } + return true; +} + +PROOF static bool sl_const_name_exists(const char *name) { + hol_const_list constants = get_all_consts(); + if (constants == NULL) + return false; + for (size_t i = 0; i < vector_size(constants); ++i) { + if (strcmp(constants[i].name, name) == 0) + return true; + } + return false; +} + +PROOF int sl_define_scope_alias(const char *scope_name, const char *suffix, + const term direct, term *alias, + thm *alias_def) { + bool scope_name_is_valid = sl_scope_name_is_valid(scope_name); + ENSURE_COND(scope_name_is_valid, + "SL scope must be a nonempty ASCII identifier"); + bool suffix_is_valid = sl_scope_name_is_valid(suffix); + ENSURE_COND(suffix_is_valid, + "SL alias suffix must be a nonempty ASCII identifier"); + bool direct_is_empty = IS_NULL(direct); + ENSURE_COND(!direct_is_empty, "direct SL operator must not be empty"); + ENSURE_COND(alias != NULL && alias_def != NULL, + "SL alias outputs must not be null"); + term_list direct_free_vars = free_vars(direct); + size_t direct_free_var_count = vector_size(direct_free_vars); + ENSURE_COND(direct_free_var_count == 0, + "direct SL operator must be closed"); + + const char *alias_name = gc_sprintf("cstar_sl__%s__%s", scope_name, suffix); + bool alias_exists = sl_const_name_exists(alias_name); + type direct_type = type_of(direct); + term lhs; + if (alias_exists) { + lhs = mk_const(alias_name, direct_type); + } else { + lhs = mk_var(alias_name, direct_type); + } + term equation_term = mk_eq(lhs, direct); + *alias_def = new_const_definition(equation_term); + term equation_conclusion = concl(*alias_def); + dest_eq_results equation = dest_eq(equation_conclusion); + *alias = equation.tm1; + bool alias_is_constant = is_const(*alias); + ENSURE_COND(alias_is_constant, + "scoped SL definition did not produce a constant head"); + return 0; +err: + { + char *scope_name_text = cstr_string(scope_name); + char *suffix_text = cstr_string(suffix); + char *direct_text = cstr_term(direct); + ERR_FUN_PUTS("sl_define_scope_alias", scope_name_text, suffix_text, + direct_text); + return -1; + } +} + +PROOF thm ra_sl_scope_fold(const ra_sl_scope *scope, const thm direct_rule) { + ENSURE_COND(scope != NULL, "resource scope must not be null"); + bool direct_rule_is_empty = IS_NULL(direct_rule); + ENSURE_COND(!direct_rule_is_empty, "direct resource rule is empty"); + thm emp_fold = gsym_rule(scope->emp_def); + thm sep_fold = gsym_rule(scope->sep_def); + thm wand_fold = gsym_rule(scope->wand_def); + thm and_fold = gsym_rule(scope->and_def); + thm or_fold = gsym_rule(scope->or_def); + thm exists_fold = gsym_rule(scope->exists_def); + thm forall_fold = gsym_rule(scope->forall_def); + thm entails_fold = gsym_rule(scope->entails_def); + thm equiv_fold = gsym_rule(scope->equiv_def); + thm fact_fold = gsym_rule(scope->fact_def); + thm pure_fold = gsym_rule(scope->pure_def); + thm_list folds = + THM_LIST(emp_fold, sep_fold, wand_fold, and_fold, or_fold, exists_fold, + forall_fold, entails_fold, equiv_fold, fact_fold, pure_fold); + thm result = pure_rewrite_rule(folds, direct_rule); + return result; +err: + { + char *direct_rule_text = cstr_thm(direct_rule); + ERR_FUN_PUTS("ra_sl_scope_fold", direct_rule_text); + return empty_theorem; + } +} + +PROOF int ra_sl_scope_prepare(const char *scope_name, const term R, + ra_sl_scope *out) { + ENSURE_COND(out != NULL, "resource scope output must not be null"); + bool scope_name_is_valid = sl_scope_name_is_valid(scope_name); + ENSURE_COND(scope_name_is_valid, + "SL scope must be a nonempty ASCII identifier"); + + sl_theory direct; + ra_sl_build(R, &direct); + ra_sl_scope result; + result.theory = direct; + +#define DEFINE_RESOURCE_ALIAS(field, suffix_name, definition_field) \ + sl_define_scope_alias(scope_name, suffix_name, direct.field, \ + &result.theory.field, &result.definition_field) + + DEFINE_RESOURCE_ALIAS(emp, "emp", emp_def); + DEFINE_RESOURCE_ALIAS(sep, "sep", sep_def); + DEFINE_RESOURCE_ALIAS(wand, "wand", wand_def); + DEFINE_RESOURCE_ALIAS(and_op, "and", and_def); + DEFINE_RESOURCE_ALIAS(or_op, "or", or_def); + DEFINE_RESOURCE_ALIAS(exists_op, "exists", exists_def); + DEFINE_RESOURCE_ALIAS(forall_op, "forall", forall_def); + DEFINE_RESOURCE_ALIAS(entails, "entails", entails_def); + DEFINE_RESOURCE_ALIAS(equiv, "equiv", equiv_def); + DEFINE_RESOURCE_ALIAS(fact, "fact", fact_def); +#undef DEFINE_RESOURCE_ALIAS + + type ra_type = type_of(R); + type bool_type = mk_bool_type(); + type bool_to_prop_type = mk_fun_type(bool_type, direct.prop_type); + type pure_head_type = mk_fun_type(ra_type, bool_to_prop_type); + term pure_head = mk_const("r_pure", pure_head_type); + term direct_pure = mk_comb(pure_head, R); + sl_define_scope_alias(scope_name, "pure", direct_pure, &result.pure, + &result.pure_def); + +#define FOLD_RESOURCE_RULE(field) \ + result.theory.field = ra_sl_scope_fold(&result, direct.field) + + FOLD_RESOURCE_RULE(sep_emp_left); + FOLD_RESOURCE_RULE(sep_emp_right); + FOLD_RESOURCE_RULE(sep_assoc); + FOLD_RESOURCE_RULE(sep_comm); + FOLD_RESOURCE_RULE(sep_mono); + FOLD_RESOURCE_RULE(wand_sep_adjoint); + FOLD_RESOURCE_RULE(and_intro); + FOLD_RESOURCE_RULE(and_elim1); + FOLD_RESOURCE_RULE(and_elim2); + FOLD_RESOURCE_RULE(or_intro1); + FOLD_RESOURCE_RULE(or_intro2); + FOLD_RESOURCE_RULE(or_elim); + FOLD_RESOURCE_RULE(exists_intro); + FOLD_RESOURCE_RULE(exists_elim); + FOLD_RESOURCE_RULE(exists_mono); + FOLD_RESOURCE_RULE(sep_exists_left); + FOLD_RESOURCE_RULE(sep_exists_right); + FOLD_RESOURCE_RULE(forall_intro); + FOLD_RESOURCE_RULE(forall_elim); + FOLD_RESOURCE_RULE(ent_refl); + FOLD_RESOURCE_RULE(ent_trans); + FOLD_RESOURCE_RULE(equiv_intro); + FOLD_RESOURCE_RULE(fact_intro); + FOLD_RESOURCE_RULE(fact_elim); + FOLD_RESOURCE_RULE(fact_dup); + FOLD_RESOURCE_RULE(fact_true_emp); +#undef FOLD_RESOURCE_RULE + + *out = result; + return 0; +err: + { + char *scope_name_text = cstr_string(scope_name); + char *R_text = cstr_term(R); + ERR_FUN_PUTS("ra_sl_scope_prepare", scope_name_text, R_text); + return -1; + } +} + +PROOF int ra_sl_scope_install(const ra_sl_scope *scope) { + ENSURE_COND(scope != NULL, "resource scope must not be null"); + sl_install_theory(&scope->theory); + return 0; +err: + ERR_FUN_PUTS("ra_sl_scope_install"); + return -1; +} + +PROOF int ra_sl_scope_activate(const ra_sl_scope *scope) { + ENSURE_COND(scope != NULL, "resource scope must not be null"); + const sl_theory *active = sl_current_theory(); + bool prop_type_matches = + equals_type(active->prop_type, scope->theory.prop_type); + bool emp_matches = equals_term(active->emp, scope->theory.emp); + bool sep_matches = equals_term(active->sep, scope->theory.sep); + bool wand_matches = equals_term(active->wand, scope->theory.wand); + bool and_matches = equals_term(active->and_op, scope->theory.and_op); + bool or_matches = equals_term(active->or_op, scope->theory.or_op); + bool exists_matches = + equals_term(active->exists_op, scope->theory.exists_op); + bool forall_matches = + equals_term(active->forall_op, scope->theory.forall_op); + bool entails_matches = equals_term(active->entails, scope->theory.entails); + bool equiv_matches = equals_term(active->equiv, scope->theory.equiv); + bool fact_matches = equals_term(active->fact, scope->theory.fact); + bool theory_matches = + prop_type_matches && emp_matches && sep_matches && wand_matches && + and_matches && or_matches && exists_matches && forall_matches && + entails_matches && equiv_matches && fact_matches; + ENSURE_COND(theory_matches, + "resource notation scope is not the active SL theory"); + proof_install_base_syntax(); + + parse_as_infix("**", 8, "right"); + parse_as_infix("-*", 4, "right"); + parse_as_infix("|--", 2, "right"); + parse_as_infix("-||-", 2, "right"); + parse_as_infix("-|-", 2, "right"); + + override_interface("**", scope->theory.sep); + override_interface("-*", scope->theory.wand); + override_interface("|--", scope->theory.entails); + override_interface("-||-", scope->theory.equiv); + type bool_type = mk_bool_type(); + type prop_to_bool_type = mk_fun_type(scope->theory.prop_type, bool_type); + type equality_type = + mk_fun_type(scope->theory.prop_type, prop_to_bool_type); + term scoped_equality = mk_const("=", equality_type); + override_interface("-|-", scoped_equality); + override_interface("emp", scope->theory.emp); + override_interface("fact", scope->theory.fact); + override_interface("pure", scope->pure); + overload_interface("&&", scope->theory.and_op); + overload_interface("||", scope->theory.or_op); + overload_interface("exists", scope->theory.exists_op); + overload_interface("forall", scope->theory.forall_op); + return 0; +err: + ERR_FUN_PUTS("ra_sl_scope_activate"); + return -1; +} diff --git a/adapter/ra_sl_scope.h b/adapter/ra_sl_scope.h new file mode 100644 index 0000000000000000000000000000000000000000..a4249640cc9c7a9134aa00f266dd225be9251dd6 --- /dev/null +++ b/adapter/ra_sl_scope.h @@ -0,0 +1,49 @@ +/** + * @file ra_sl_scope.h + * @brief Closed, stable aliases for one selected resource algebra. + * + * A scope gives polymorphic resource-proposition operators fixed HOL constant + * heads suitable for a parser, theorem registry, and runtime descriptor. Scope + * construction and activation are installer internals; this header exposes + * only the immutable result shared with a concrete logic installer. + */ + +#pragma once + +#include "proof/syntax/base.h" +#include "proof/adapter/ra_sl.h" + +/** + * Conservative alias layer over one specialized resource proposition theory. + * + * Each definition has shape `alias = direct_operator`. The terms and theorem + * handles in `theory` use the alias heads already, so clients never need to + * unfold the definitions merely to use a proof rule. + * + * `theory.fact` is the exact-unit embedding: `fact(phi)` owns only the RA unit. + * `pure` is kept separate because `pure(phi)` is true at every resource when + * `phi` holds. Conflating these operators would make linear ownership + * silently discardable. + */ +PROOF typedef struct { + /** Alias-backed BI signature and its folded primitive laws. */ + sl_theory theory; + + /** Resource-independent `r_pure` alias; not part of `sl_theory`. */ + term pure; + + /* Conservative definitions for the operators in `theory`. */ + thm emp_def; + thm sep_def; + thm wand_def; + thm and_def; + thm or_def; + thm exists_def; + thm forall_def; + thm entails_def; + thm equiv_def; + thm fact_def; + + /** Conservative definition for `pure`. */ + thm pure_def; +} ra_sl_scope; diff --git a/adapter/ra_sl_scope_internal.h b/adapter/ra_sl_scope_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..cdfaea1b076a312f5825d3effffeb1dfe13df614 --- /dev/null +++ b/adapter/ra_sl_scope_internal.h @@ -0,0 +1,51 @@ +/** + * @file ra_sl_scope_internal.h + * @brief Internal construction phases for selected-resource installers. + * + * These operations let a concrete logic installer prepare and validate all + * aliases before crossing runtime or parser commit boundaries. HOL constant + * definitions and parser mutations are process-global and cannot be rolled + * back, so callers must treat a later error as initialization fail-stop. + * + * This is not a standalone public installation API. In particular, preparing + * a scope does not install its base theory, and installing the theory does not + * activate its parser notation. + */ + +#pragma once + +#include "proof/adapter/ra_sl_scope.h" + +/** Return whether `scope_name` is a nonempty ASCII `[A-Za-z0-9_]` string. */ +PROOF bool sl_scope_name_is_valid(const char* scope_name); + +/** + * Define `cstar_sl____ = direct`. + * + * `direct` must be closed and both output pointers must be non-null. On + * success, `alias` is the newly selected constant head and `alias_def` is its + * conservative definition. Defining the HOL constant is nontransactional. + */ +PROOF int sl_define_scope_alias(const char* scope_name, const char* suffix, + const term direct, term* alias, + thm* alias_def); + +/** Build all base BI aliases and folded laws without installing them. */ +PROOF int ra_sl_scope_prepare(const char* scope_name, const term R, + ra_sl_scope* out); + +/** Rewrite one direct resource-proposition theorem to `scope`'s alias heads. */ +PROOF thm ra_sl_scope_fold(const ra_sl_scope* scope, + const thm direct_rule); + +/** Install `scope->theory` as the active base SL signature. */ +PROOF int ra_sl_scope_install(const ra_sl_scope* scope); + +/** + * Activate notation for an already-installed matching scope. + * + * This verifies that `scope->theory` is active before mutating parser and + * interface state. It installs distinct source spellings for logical + * equivalence (`-||-`) and raw assertion equality (`-|-`). + */ +PROOF int ra_sl_scope_activate(const ra_sl_scope* scope); diff --git a/docs/BACKWARD_PROOF_SPEC.md b/docs/BACKWARD_PROOF_SPEC.md index 6d4d76eb27cf5f75cbce4957274a6d83c9401917..063da0a3a4ea3d2a08eaa7b4e1d9a54ed6838abb 100644 --- a/docs/BACKWARD_PROOF_SPEC.md +++ b/docs/BACKWARD_PROOF_SPEC.md @@ -40,16 +40,20 @@ For a theorem `T` and goal `G = [Γ ?⊢ p]`, define: achieves(T, G) iff concl(T) ≡α p and hyp(T) ⊆α |Γ| ``` -Here `⊆α` is set-like containment modulo alpha-equivalence. A theorem +Conclusion matching is alpha-equivalence only; it is not a host-language +quotient and performs no implicit beta conversion. Here `⊆α` is set-like containment +modulo alpha-equivalence. A theorem hypothesis may match an assumption regardless of its label, and duplicate HOL hypotheses do not consume duplicate assumptions. -An SL goal `[Γ; Δ ?⊢SL H]` is represented by `SL_GOAL` and has logical -conclusion `Sep(Δ) ⊢SL H`, where Δ is the ordered labeled spatial context. -Generic goal-tree operations use that logical conclusion. Assumption-only -transformations preserve the goal representation; conclusion transformations -create general HOL child goals unless a dedicated SL tactic specifies -otherwise. +An SL goal `[Γ; Δ ?⊢SL H]` is an extension goal whose cached logical +conclusion is `Sep(Δ) ⊢SL H`, where Δ is the ordered labeled spatial context. +Its private payload snapshots Δ and records `H` and the active SL-theory +generation. Generic goal-tree operations use only the cached conclusion; SL +accessors additionally require the recorded generation to remain active. +Assumption-only transformations preserve the extension payload; conclusion +transformations create general HOL child goals unless a dedicated SL tactic +specifies otherwise. ## 2. Goal-tree model @@ -78,8 +82,11 @@ for every T₁, …, Tₙ, ⇒ achieves(V(T₁,…,Tₙ),G) ``` -Validators receive child theorems in child order. Their conclusions need only -be alpha-equivalent to the child conclusions. Intermediate validators do not +Validators receive child theorems in child order. Their conclusions must be +alpha-equivalent to the child conclusions. A validator that deliberately +introduces a beta-redex must prove and apply that local conversion before it +returns; `gnode_accept` performs no beta transport. An alpha match may retain +its binder names until the root. Intermediate validators do not otherwise rename binders merely to reproduce the stored goal syntax. ### 2.1 Kernel operations diff --git a/docs/LITHIUM_AUTOMATION.md b/docs/LITHIUM_AUTOMATION.md new file mode 100644 index 0000000000000000000000000000000000000000..9feaede77fe76ddba2ad2b35ffa613f1ebbd22ff --- /dev/null +++ b/docs/LITHIUM_AUTOMATION.md @@ -0,0 +1,237 @@ +# Lithium-inspired entailment automation + +`proof_lithium` is a proof-producing, rule-extensible interpreter for the +currently installed C* separation-logic theory. It deliberately implements the +goal-directed and committed-choice core of +[RefinedC Lithium](https://gitlab.mpi-sws.org/iris/refinedc/-/tree/master/theories/lithium), +not a claim that C* already has all of Lithium's open judgments, persistent +contexts, modalities, or existential-evar machinery. + +The design keeps three ideas from Lithium: + +- fixed connective interpretation surrounds an extensible rule phase; +- proved rules are ordered by priority and source order; and +- after a rule head is selected, failure of its recursive entailment does not + backtrack to a different rule. + +## Soundness boundary + +The interpreter is not a primitive inference rule. Every successful step is +one of: + +- an existing validated `proof_backward_sl` tactic; +- `LITHIUM_AND_SLTAC`, whose validator calls `conj_slrule`; +- `LITHIUM_FORALL_SLTAC`, whose validator calls `forall_slrule`; or +- a custom callback that must itself expand a validated proof tree. + +A theorem entry is an already-proved SL equality or entailment. Matching only +chooses and specializes it. Consequent-rule preflight checks the complete RHS +modulo spatial ACU and verifies that every specialized HOL theorem premise is +already in the ordinary context before committing. At completion, +`gnode_prove` runs the entire validator tree bottom-up. An invalid match, +unavailable premise, duplicated linear resource, or malformed callback cannot +yield an accepted theorem. + +Custom callbacks remain part of tactic code, not the kernel. Their returned +vector must be exactly the callback subtree's complete unresolved frontier; +null, missing, or extra leaves are rejected. A callback can still explicitly +invoke an unsafe API such as `CHEAT_TAC`, so the safe extension path is a +theorem rule. + +## Rule categories + +`LITHIUM_GOAL_RULE` is the identity-modality local counterpart of Lithium's +`lemma_to_li_entails`. Given `E : P |-- Q`, a whole consequent matching `Qθ` +modulo spatial ACU becomes `Pθ`; the left spatial context is unchanged. The +interpreter does not implicitly lift `E` to `P ** F |-- Q ** F`. A proved +binary endpoint may explicitly quantify a frame parameter, for example +`forall F. P ** F |-- Q ** F`; this pattern is matched and regression-tested. + +`LITHIUM_HYP_RULE` applies `E` forward to matching linear antecedent resources +and retains their unmatched frame. It is useful, but is only a binary rewrite. +It is considered applicable only if that one rewrite immediately increases the +greedy direct-frame score or reduces the number of spatial resources. It is not +the same judgment as Lithium's continuation-aware `SimplifyHyp` or `Subsume`, +and rewrites useful only after additional intermediate steps may be skipped. + +`LITHIUM_ENTAIL_RULE` is a C* convenience enabling both interpretations of one +binary theorem. It is therefore broader than `lemma_to_li_entails`, not a +one-to-one translation of an official Lithium class. + +`LITHIUM_CUSTOM_RULE` provides a leading matcher/tactic hook. Independent +modules can publish caller-owned bundles and combine them with +`lithium_rule_set_append`. The registry intentionally has no process-global +mutable state; lookup is currently a stable linear scan rather than Lithium's +discriminated typeclass/hint indexing. + +## Selection and scheduling + +Phase precedence is stronger than numeric priority: leading custom/GOAL rules +always precede the later HYP phase. Within one registered phase, rules are +sorted by `(priority, registration order)`, with smaller numeric priorities +first. Equal-priority entries preserve registration order, including across +appended bundles. For `LITHIUM_ENTAIL_RULE`, the GOAL interpretation is thus +always considered before its HYP interpretation. Applicability is probed on a +private node. Once a rule commits, its recursive leaves are scheduled and a +later stuck leaf does not reconsider another entry. + +This is analogous to Lithium's `LiEntailsShelve`: typeclass search selects the +outer rule while the recursive entailment premise is shelved until after that +choice point is gone. “No backtracking” here means no backtracking over a +committed rule because recursive proof search failed. A matcher can still scan +several local candidates before it reports applicability, just as Lithium's +`FindInContext` may try multiple finder instances. + +For one SL leaf, the local phase order is: + +1. leading custom rules and exact consequent (`GOAL`) theorem rules; +2. expose separating paths to `fact` resources and move those facts to the + duplicable ordinary context; +3. direct linear cancellation and `emp` closure; +4. left wand, separating conjunction, disjunction, existential, unit, and + additive-conjunction interpretation; +5. relevant forward (`HYP`) theorem rules; and +6. right update, fact, pulled existential, additive conjunction/disjunction, + wand, existential, and universal interpretation. + +Delaying forward rules until after direct cancellation prevents a theorem such +as `P |-- Q` from destroying a resource that already closes `P |-- P`. +Conversely, custom and goal rules lead the phase order so they can override +ordinary connective interpretation, corresponding most closely to Lithium's +leading `liTactic` entry. C* has no separate analogue of Lithium's +continuation-judgment-to-`iProp_to_Prop` `liExtensible` bridge yet. + +Pure HOL leaves introduce quantifiers and implications, close from an +assumption, `T`, or reflexive equality, split conjunction, and make a stable +disjunction choice. Only custom rules apply to a general HOL leaf. + +The context remains linear. Without an explicit theorem, the interpreter does +not prove `P ** Q |-- P` or `P |-- P ** P`. Spatial `fact` is the sole built-in +exception: it is moved to the ordinary context using the proved fact-elimination +law, after which it may be discarded or used repeatedly. + +## API example + +```c +lithium_rule_set module_rules = lithium_rule_set_new(); +lithium_rule_set_add_theorem( + &module_rules, "my-atom-rule", 10, + LITHIUM_GOAL_RULE, MY_PROVED_RULE); + +lithium_rule_set rules = lithium_rule_set_new(); +lithium_rule_set_append(&rules, &module_rules); + +gnode root = gnode_new_with_ccl(`source |-- target`); +lithium_options options = lithium_options_default(&rules); +gnode_list unresolved = LITHIUM_SLTAC(root, options); +if (vector_size(unresolved) == 0) { + thm result = gnode_prove(root); +} +``` + +`lithium_options.trace` observes only committed steps. Both public interpreter +entry points must run outside `proof_try`, because private theorem and witness +probes use that process-global mechanism internally. `LITHIUM_SLTAC` can resume +a partially expanded proof tree from its existing leaves; one-step +`LITHIUM_STEP_SLTAC` requires an open leaf. + +## Comparison with RefinedC's default instances + +The official +[`instances.v`](https://gitlab.mpi-sws.org/iris/refinedc/-/blob/master/theories/lithium/instances.v) +contains several different extensible judgments. Their current C* status is: + +| RefinedC instance family | C* status | +| --- | --- | +| `find_in_context_direct` | Direct occurrence-sensitive cancellation is built in and regression-tested, but the finder itself is not yet an open indexed judgment. | +| `simplify_hyp_id` | Identity is represented by doing no forward rewrite; non-identity binary forward theorems are supported. The general continuation-producing judgment is missing. | +| `simplify_goal_id` | Identity falls through to ordinary structural solving; exact non-identity RHS reduction is implemented by `LITHIUM_GOAL_RULE`. | +| `subsume_id` | Direct cancellation covers the unit/no-extra-output case. Dependent result witnesses and a returned continuation are not represented by the binary rule record. | +| `subsume_simplify` | Only a restricted scheduling analogue exists. C* does not yet compare separate `SimplifyHyp`/`SimplifyGoal` `option N` costs or construct Lithium's dependent continuation. | +| `find_sep_list` and the five `subsume_sep_list_*` rules | Not copied literally. `sep_list`, its ignored-index protocol, list insertion, and `list_subequiv` are RefinedC typing infrastructure, not part of C*'s current generic SL interface. | + +Lithium's `li_vm_compute_tac` side-condition hook likewise has no generic C* +entry yet; a module can currently use a validated custom callback or a proved +HOL conversion. Thus the regression suite reproduces the locally meaningful +entailment behavior and selection discipline, not the typeclass records of all +RefinedC-specific `sep_list` instances. + +## Deliberate semantic differences and remaining work + +### Pure assertions + +Iris BI pure propositions have the laws needed to discharge a pure condition +without consuming spatial resources. C* permits arbitrary, possibly +non-monotone predicates `A -> bool`, so the pointwise definition +`r_pure R p a <=> p` does not by itself validate the corresponding separating +laws. + +The adapter therefore maps Lithium-style pure side conditions to `r_fact`, +using `r_fact_intro`, `r_fact_elim`, `r_fact_dup`, and the fact/separation laws. +Treating `r_pure` as an interchangeable zero-resource fact would be unsound. + +### Persistence and modalities + +The current resource-proposition layer has no Iris `Persistent`/`□` connective, +no split persistent/spatial environment, and no general `limodal`. Only +`r_fact` is duplicated by a proved law. Basic-update introduction and +monotonicity are supported when an update theory is installed, but this does +not reproduce Lithium's general `liModal`, `liPersistent`, or `liAccu` steps. + +### Existential variables + +C* has no analogue of Lithium's protected existential tuples, unification +evars, `SimplExist`, or `li_done_evar` sharing across branches. The interpreter +infers a witness by one-way matching a witness-dependent goal component against +a spatial assertion or ordinary fact. If no witness is determined, the goal +stays unresolved; the interpreter never invents one by recursive backtracking. + +### Continuation-aware judgments + +Lithium's `SimplifyGoal`, `SimplifyHyp`, and `Subsume` carry a modality and a +continuation; `Subsume` can additionally return dependent witnesses and extra +resources. C* theorem entries currently store only binary `P |-- Q` relations. +Those endpoints can quantify explicit assertion or frame parameters, and HYP +application preserves unmatched input resources, so several common rules are +expressible. The registry still has no first-class continuation judgment, +modality, result index, +cost arbitration, or protected dependent witness, and therefore cannot expose +the full judgment +`P1 -* M (exists x. P2 x ** T x)`. This is the largest semantic step needed for +a literal port of `subsume_simplify` and the `sep_list` rules. + +### Object-logic surface + +The generic `sl_theory` adapter does not expose `r_top`, `r_bottom`, `r_impl`, +`r_pure`, persistence, or an iterated-separation operator. A theorem about a +hidden connective can be registered atomically, but the interpreter cannot +structurally inspect it. The local structural handling of resource +disjunction is an extra C* feature; general Lithium `liStep` does not have an +equivalent BI-disjunction case. + +`ra_sl_build` also requires a closed monomorphic RA, so the solver targets an +installed concrete assertion type rather than proving generic theorems with +an open `R : (A)ra` parameter. + +## Regression coverage + +`test/proof_lithium_regression.c` checks: + +- exact direct lookup, ACU multiplicity, and negative weakening/duplication; +- `fact` discard and duplication, false elimination, and HOL-to-fact goals; +- separating/additive connectives, ambiguous branch scoring, wand, + existential opening/witness inference, and dependent universal introduction; +- basic-update introduction and monotonicity; +- quantified entailment, explicit frame-parameter, equality, and dual + `ENTAIL` theorem registrations; +- positive and unavailable theorem guards; +- custom override, custom miss, malformed-frontier rejection, and pre-step + trace snapshots; +- priority ordering independent of registration order, equal-priority source + order across bundles, phase-before-numeric precedence, HYP relevance, + bundle composition, and committed recursive failure; +- exact fuel/no-match boundary behavior; and +- explicit unresolved unknown atoms and unknown existential witnesses. + +Every successful regression is reconstructed with zero admitted axioms and +zero remaining verification conditions. diff --git a/docs/RA_SL_THEOREM_GUIDE.md b/docs/RA_SL_THEOREM_GUIDE.md new file mode 100644 index 0000000000000000000000000000000000000000..6bceb39a438b6e7799fa4f185d98a93ab92edb15 --- /dev/null +++ b/docs/RA_SL_THEOREM_GUIDE.md @@ -0,0 +1,801 @@ +# C* RA / SL theorem guide：逐文件内容与直觉 + +本文按源码文件说明 C* RA / separation logic v2 的 theorem surface：每个模块 +证明什么、这些结论表达什么资源直觉，以及通常怎样组合使用。总体设计、形式化 +定义和依赖图见 [`RA_SL_THEORY_SUMMARY.md`](RA_SL_THEORY_SUMMARY.md)；本文更偏向 +“拿到一个 theorem handle 后该如何理解它”。 + +## 1. 阅读约定 + +- `foo.h` 是稳定 public surface；同名 `foo.c` 定义 HOL constant、完成证明并审计 + “无新增 axiom”。因此下面通常把 `.h/.c` 作为一个模块说明。 +- `*_internal.h` 只服务于 theory implementation 或 adapter，不是 client API。 +- `_def` 通常是定义展开；`_iff` 是精确刻画；`intro`/`elim` 是引入/消去； + `mono`/`frame`/`trans` 分别表示单调、保 frame、传递组合。 +- theorem handles 使用 `lower_snake_case`。若 handle 嵌入本来就带大写的 + object-language constant，则保留该片段，例如 `ra_updateP_refl`、 + `pmem_c_address_ok_Tuint64`。 +- 记 `e = ra_unit R`、`a · b = ra_op R a b`、`✓a = ra_valid R a`。 +- `P ⊢ Q` 表示 validity-sensitive entailment，`P ≡ Q` 表示双向 entailment； + assertion algebra 的 public laws 使用 `r_equiv`，不把 raw predicate equality + 暴露给普通 client。 + +推荐阅读顺序是：`ra` → 一个具体 RA instance → `resource_prop` → +`basic_update`/`product_resource` → `c_resource`/`c_ghost`。只有实现新 RA +constructor 时才需要 `ra_builder` 与各 internal header。 + +## 2. RA 核心 + +### 2.1 `theory/logic/ra.h` / `ra.c` + +文件：[`ra.h`](../theory/logic/ra.h)、[`ra.c`](../theory/logic/ra.c) + +这是所有模块的语义根。`(A)ra` 是 lawful 的交换幺半群加 downward-closed +validity；`ra_updateP` 是 primitive frame-preserving update，结果可依赖未知 +frame；`ra_update` 只是 singleton result 的特化。 + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| 派生关系 | `ra_compatible_def`, `ra_included_def`, `ra_updateP_def`, `ra_update_def`, `ra_cancellative_def`, `ra_maximal_def` | compatibility 是“合起来仍 valid”；inclusion 是“补一个 frame 得到整体”；update 要对每个兼容隐藏 frame 找到仍兼容的结果；maximal 还显式要求 source valid，避免 invalid-source vacuity。 | +| RA 固有律 | `ra_laws`, `ra_assoc`, `ra_comm`, `ra_unit_l`, `ra_unit_r`, `ra_valid_unit`, `ra_valid_op` | ownership composition 可重排、unit 不携带资源；整体 valid 时每个 fragment 都 valid。 | +| compatibility / inclusion | `ra_compat_comm`, `ra_compat_unit`, `ra_included_refl`, `ra_included_unit`, `ra_included_op_l`, `ra_included_op_r`, `ra_included_trans`, `ra_included_op_mono`, `ra_included_valid` | inclusion 是以 unit 为底的 preorder；组合对 inclusion 单调；validity 可从整体向 fragment 下传。 | +| predicate update | `ra_updateP_singleton`, `ra_updateP_refl`, `ra_updateP_mono`, `ra_updateP_trans`, `ra_updateP_valid`, `ra_updateP_frame`, `ra_updateP_op` | `updateP` 可弱化 postcondition、Kleisli 式串接、显式加 frame，也可把两个独立更新逐点组合。valid source 至少给出一个 valid witness。 | +| deterministic update | `ra_update_refl`, `ra_update_trans`, `ra_update_frame`, `ra_update_op`, `ra_update_included`, `ra_update_target_included`, `ra_update_valid` | 确定更新继承 reflexive/transitive/frame 结构；丢掉当前 fragment 的一部分总是安全，target 还可继续向 included part 弱化。 | +| 可选性质 | `ra_maximal_included`, `ra_maximal_update`, `ra_cancellative_apply` | maximal source 没有非平凡 valid extension，因而可替换为任意 valid target；cancellative RA 可取消公共 fragment。 | + +`ra_maximal R a` 表达的是强 frame-maximality：`a` 本身 valid，且任何与 +`a` 组合后仍 valid 的 frame 都必须精确等于 RA unit。它不等同于 +“`a · a` invalid”这类 self-conflict exclusive 性质；后者目前尚未在核心 +RA API 中定义。`excl_ra` 仍保留 exclusive-token 构造器语义，因为两个 +owned `Excl` token 的组合确实冲突；其 owned 元素同时还满足 `ra_maximal`。 + +最常见的证明路径是：先用 instance theorem 得到 `ra_update` 或 `ra_updateP`， +再用 `ra_update_frame`/`ra_updateP_frame` 放回显式资源，最后由 ownership theorem +提升到 view shift。 + +### 2.2 `theory/logic/ra_builder.h` + +文件：[`ra_builder.h`](../theory/logic/ra_builder.h) + +这是 constructor-author API，不是普通 RA client API。 + +| handles | 内容与直觉 | +| --- | --- | +| `ra_laws_def` | 展开 raw descriptor 需要满足的 associativity、commutativity、left unit、unit validity 与 validity projection。 | +| `ra_type_bijection`, `ra_rep_laws`, `ra_abs_rep`, `ra_abs_eta` | 在 lawful raw triple 与抽象 `(A)ra` 之间安全往返；抽象类型保证 client 不必重复携带 laws premise。 | +| `ra_unit_abs`, `ra_op_abs`, `ra_valid_abs` | 新 constructor 证明 raw laws 后，用这些 computation rules 得到其 unit/op/valid 公理化接口。 | + +直观上，`ra_builder` 是“封装证明一次，之后把结构当成合法 RA 使用”的边界。 + +### 2.3 `theory/logic/ra_internal.h` + +文件：[`ra_internal.h`](../theory/logic/ra_internal.h) + +实现层便捷规则包括： + +- operation/validity normalization：`ra_op_swap_right`、`ra_valid_op_l`、 + `ra_valid_op_r`； +- 直接应用 relation：`ra_maximal_apply`、`ra_update_apply`、 + `ra_updateP_apply`； +- inclusion/cancellation：`ra_included_op_mono_l`、`ra_included_op_mono_r`、 + `ra_included_valid_frame`、`ra_included_cancel_l`、 + `ra_maximal_valid_op_iff`； +- update bridge：`ra_updateP_of_update`、`ra_update_unit`。 + +这些 theorem 主要用于 constructor proof 中消除定义展开和 frame bookkeeping。 +例如 `ra_update_unit` 解释了为何“丢掉当前 fragment”在 frame-preserving 语义下 +总是可行，但普通 client 应使用更有语义的 instance-level `drop` theorem。 + +### 2.4 `theory/logic/local_update.h` / `local_update.c` + +文件：[`local_update.h`](../theory/logic/local_update.h)、 +[`local_update.c`](../theory/logic/local_update.c) + +五参数关系 `ra_local_update R a f b g` 表示：已知 whole/local decomposition +`a = f · residual` 时，在保持同一个未知 residual 的前提下，把 `(a,f)` 同步变成 +`(b,g)`。 + +| handles | 内容与直觉 | +| --- | --- | +| `ra_local_update_def`, `ra_local_update_apply` | 展开关系并应用到一个具体 residual。与普通 update 相比，它同时记录 whole 和当前可见 fragment。 | +| `ra_local_update_refl`, `ra_local_update_trans`, `ra_local_update_frame` | local update 可组合，并允许在两侧 local fragment 上加同一个显式 extra。 | +| `ra_local_update_preserves_included` | 在外部 fragment 存在时仍保持 target validity/inclusion，是 auth 与 gmap lifting 的关键桥。 | +| `ra_local_update_alloc` | 把一个 piece 同时加入 whole 与 visible local ownership；不是凭空复制，而是更新 decomposition。 | +| `ra_local_update_maximal` | visible fragment 已是强 frame-maximal source 时，可同步替换为 valid target。 | +| `ra_local_update_cancel`, `ra_local_update_cancellative` | 前者消去 whole/local 共有前缀；后者在 cancellative RA 中同步已知 residual。 | + +## 3. 基础 RA constructors + +### 3.1 `unit_ra.h` / `unit_ra.c` + +文件：[`unit_ra.h`](../theory/logic/unit_ra.h)、 +[`unit_ra.c`](../theory/logic/unit_ra.c) + +`unit_ra` 只有 `one`，没有可区分的资源状态。 + +- `unit_ra_unit`, `unit_ra_op`, `unit_ra_valid`, `unit_ra_included` 完全刻画其 + algebra； +- `unit_ra_maximal` 说明唯一元素的唯一 compatible frame 也是 unit； +- `unit_ra_updateP_iff` 把 predicate update 化为 `P one`； +- `unit_ra_local_update` 说明任意四个 singleton carrier 值都满足 local update。 + +直觉：它是“无 ghost information”的 payload，也常作为默认 named cell payload。 + +### 3.2 `prod_ra.h` / `prod_ra.c` + +文件：[`prod_ra.h`](../theory/logic/prod_ra.h)、 +[`prod_ra.c`](../theory/logic/prod_ra.c)、 +[`prod_ra_internal.h`](../theory/logic/prod_ra_internal.h) + +产品 RA 把两个独立资源坐标并排组合。 + +| handles | 内容与直觉 | +| --- | --- | +| `prod_ra_unit`, `prod_ra_op`, `prod_ra_valid`, `prod_ra_included` | unit/op/valid/inclusion 全部逐坐标计算。 | +| `prod_ra_cancellative_iff`, `prod_ra_maximal_iff` | 产品具有 cancellativity/maximality，当且仅当两个坐标分别具有相应性质。 | +| `prod_ra_updateP`, `prod_ra_update_left`, `prod_ra_update_right`, `prod_ra_local_update` | 两边 predicate update 可配对；确定更新可只改一个坐标；local update 也逐坐标 lifting。 | +| `prod_inl_def`, `prod_inr_def`, `prod_inl_op`, `prod_inr_op` | `inl`/`inr` 用另一坐标的 unit 嵌入一个 component，并保持 composition。 | +| `prod_inl_updateP`, `prod_inr_updateP`, `prod_inl_update`, `prod_inr_update` | component update 可提升为 exact one-sided product update。 | + +`prod_ra_internal.h` 的 `prod_ra_cancellative` 是 implementation eliminator；普通 +client 使用 public 的 iff characterization。 + +### 3.3 `option_ra.h` / `option_ra.c` + +文件：[`option_ra.h`](../theory/logic/option_ra.h)、 +[`option_ra.c`](../theory/logic/option_ra.c)、 +[`option_ra_internal.h`](../theory/logic/option_ra_internal.h) + +`option_ra R` 给 base RA 增加一个真正的 empty `NONE`；`SOME a` 表示存在的 +resource。 + +- unit/op/valid：`option_ra_unit`、`option_ra_op_none_l`、 + `option_ra_op_some_some`、`option_ra_valid_none`、`option_ra_valid_some`； +- inclusion/disjointness：`option_ra_included_none`、 + `option_ra_included_some_some`、`option_ra_not_included_some_none`、 + `option_ra_some_unit_ne_none`； +- structural property：`option_ra_not_cancellative`，因为新增 empty 会让 + `NONE` 与 `SOME (ra_unit R)` 在 composition 行为上产生不可取消情形； +- update/local update：`option_ra_updateP_iff`、`option_ra_update_iff`、 + `option_ra_local_update_iff` 把 exact `SOME` image 上的结论回落到 base RA。 + +internal 的 `option_ra_op_none_r`、`option_ra_update`、`option_ra_updateP` 是 +单向 normalization/lifting helper，不扩大 public 契约。 + +### 3.4 `excl_ra.h` / `excl_ra.c` + +文件：[`excl_ra.h`](../theory/logic/excl_ra.h)、 +[`excl_ra.c`](../theory/logic/excl_ra.c)、 +[`excl_ra_internal.h`](../theory/logic/excl_ra_internal.h) + +`excl_ra`（exclusive-token RA）表示“最多一个有效 owner”。 + +- `excl_ra_unit`, `excl_ra_owned_conflict`, `excl_ra_valid_unit`、 + `excl_ra_valid_owned`, `excl_ra_invalid` 描述 constructors 与冲突； +- `excl_ra_included_owned`, `excl_ra_maximal`, `excl_ra_cancellative` + 给出 ownership 的 inclusion、强 frame-maximality 与 cancellation；owned + token 的 self-conflict 直觉则由 `excl_ra_owned_conflict` 给出； +- `excl_ra_update_owned_iff` 说明 valid owned source 可更新到任意 valid + target；`excl_ra_local_update_iff` 给出对应 local-update characterization。 + +`excl_ra_internal.h` 公开给实现的 raw datatype/computation handles 是 +`excl_owned_op_def`、`excl_op_def`、`excl_owned_ne_unit`、 +`excl_invalid_ne_unit`、`excl_ra_op_fn`、`excl_ra_update`。直觉上这些是证明 +constructor cases 的 rewrite facts，而不是协议层规则。 + +### 3.5 `agree_ra.h` / `agree_ra.c` + +文件：[`agree_ra.h`](../theory/logic/agree_ra.h)、 +[`agree_ra.c`](../theory/logic/agree_ra.c) + +agreement RA 允许多个 fragment 共享同一值，但不同值组合即 invalid。 + +| handles | 内容与直觉 | +| --- | --- | +| `agree_ra_unit`, `agree_ra_owned_op`, `agree_ra_idempotent` | 相同 payload ownership 可幂等合并；这支持只读知识的复制式共享。 | +| `agree_ra_valid_unit`, `agree_ra_valid_owned`, `agree_ra_invalid`, `agree_ra_valid_combine_iff` | 单个 owned 总 valid；组合 valid 当且仅当所有可见 payload 一致。 | +| `agree_ra_agreement`, `agree_ra_included_owned` | 从 valid composition 提取 payload equality；owned inclusion 也强制 agreement。 | +| `agree_ra_not_cancellative` | 幂等使 cancellation 失败：`x·x=x` 无法反推出被取消部分。 | +| `agree_ra_update_iff`, `agree_ra_local_update_iff` | 只允许保持已建立的 agreement；不能 frame-preservingly 改成不同 payload。 | + +### 3.6 `max_nat_ra.h` / `max_nat_ra.c` + +文件：[`max_nat_ra.h`](../theory/logic/max_nat_ra.h)、 +[`max_nat_ra.c`](../theory/logic/max_nat_ra.c) + +handles `max_nat_ra_unit`、`max_nat_ra_op`、`max_nat_ra_valid`、 +`max_nat_ra_included`、`max_nat_ra_idempotent`、`max_nat_ra_update` 说明：unit 是 +`0`，composition 是 `MAX`，所有自然数 valid，inclusion 就是 `<=`，operation +幂等，而且任意确定 target 都是 frame-preserving update。 + +直觉：未知 frame 只会把值提高；替换 source 为任意 target 后，与同一 frame 取 +`MAX` 仍 valid，所以 update 没有额外 validity 障碍。协议通常另外施加单调状态机 +约束，而不是依赖 RA update 本身限制方向。 + +### 3.7 `frac_ra.h` / `frac_ra.c` + +文件：[`frac_ra.h`](../theory/logic/frac_ra.h)、 +[`frac_ra.c`](../theory/logic/frac_ra.c) + +fraction RA 同时记录 share 与 payload RA。 + +- constructors/composition：`frac_ra_unit`、`frac_ra_full`、 + `frac_ra_own_op`；positive shares 相加，payload 以 base `ra_op` 合并； +- validity/maximality：`frac_ra_valid_own` 要求 `0 < p <= 1` 且 payload valid， + `frac_ra_maximal_full` 说明 full share 已占满容量，因而任何 compatible + frame 都只能是 unit； +- updates：`frac_ra_update_weaken`、`frac_ra_updateP_weaken` 可在 base payload + update 的同时减小 share；`frac_ra_update_full_iff` 精确说明 full-to-full update + 只需保证 valid source 蕴含 valid target。 + +直觉：fraction 控制“还能否与隐藏 share 共存”，payload RA 控制“内容能否与隐藏 +payload 共存”。full share 排除了任何 positive hidden share，因此更新最自由。 +`frac_ra_update_full_iff` 在 invalid source 上仍按 update 定义产生 vacuous implication； +这不是一个额外的 invalid-source public shortcut，也不表示该 source 可被合法拥有。 + +## 4. Finite map、naming 与 authoritative state + +### 4.1 `finmap.h` / `finmap.c` + +文件：[`finmap.h`](../theory/logic/finmap.h)、 +[`finmap.c`](../theory/logic/finmap.c) + +这不是 RA，而是 `gmap_ra` 的 finite-support map 基础。 + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| representation | `finmap_finite_def`, `finmap_type_bijection`, `finmap_rep_finite`, `finmap_eq` | 把 abstract finite map 与 finite-support function 对接；map equality 归结为逐 key lookup。 | +| constructors | `finmap_empty_def`, `finmap_lookup_def`, `finmap_singleton_def`, `finmap_insert_def`, `finmap_delete_def`, `finmap_dom_def` | 定义 empty/lookup/singleton/insert/delete/domain。 | +| representation equations | `finmap_empty_rep`, `finmap_singleton_support`, `finmap_singleton_rep`, `finmap_insert_support`, `finmap_insert_rep`, `finmap_delete_support`, `finmap_delete_rep` | 实现证明使用的 support/function computation。 | +| lookup equations | `finmap_empty_lookup`, `finmap_singleton_lookup`, `finmap_insert_lookup`, `finmap_insert_lookup_eq`, `finmap_insert_lookup_ne`, `finmap_delete_lookup`, `finmap_delete_lookup_eq`, `finmap_delete_lookup_ne`, `finmap_eq_lookup` | 读写同 key 命中，不同 key 不受影响；逐点相同即可判 map 相同。 | +| algebra of edits | `finmap_insert_empty`, `finmap_delete_empty`, `finmap_insert_overwrite`, `finmap_insert_comm`, `finmap_delete_idempotent`, `finmap_delete_comm`, `finmap_delete_insert`, `finmap_delete_insert_ne`, `finmap_insert_delete`, `finmap_insert_id`, `finmap_delete_id`, `finmap_decompose` | insert/delete 的覆盖、交换、幂等与 decomposition 规则。 | +| finite domain | `finmap_dom_finite`, `finmap_dom_empty`, `finmap_dom_singleton`, `finmap_in_dom`, `finmap_in_dom_some`, `finmap_not_in_dom`, `finmap_dom_eq_empty`, `finmap_dom_insert`, `finmap_dom_delete` | domain 精确对应 lookup 非 `NONE`，且始终 finite。 | +| freshness | `finmap_fresh_in`, `finmap_fresh_in_pair`, `finmap_fresh`, `finmap_fresh_pair` | 从 infinite candidate/key type 中避开 finite domain，必要时同时满足两个 map 的 freshness。 | +| induction | `finmap_induct` | 以 empty 与 fresh insert 为归纳结构，适合证明 pointwise map algebra。 | + +### 4.2 `gmap_ra.h` / `gmap_ra.c` + +文件：[`gmap_ra.h`](../theory/logic/gmap_ra.h)、 +[`gmap_ra.c`](../theory/logic/gmap_ra.c)、 +[`gmap_ra_internal.h`](../theory/logic/gmap_ra_internal.h) + +`gmap_ra R` 在每个 key 上做 option/base RA composition，并保持 finite support。 + +| handles | 内容与直觉 | +| --- | --- | +| `gmap_ra_unit`, `gmap_ra_op_lookup` | unit 是 empty map；composition 在每个 key 上 pointwise 计算。 | +| `gmap_ra_valid`, `gmap_ra_valid_singleton`, `gmap_ra_valid_lookup` | whole map valid 当且仅当每个 present payload valid；validity 可投影到任意 lookup。 | +| `gmap_ra_included_lookup_iff`, `gmap_ra_included_dom`, `gmap_ra_decompose` | map inclusion 等价于逐 key inclusion，并蕴含 source domain 包含于 target domain；map 可拆成 singleton 与其余部分。 | +| `gmap_ra_local_update_at`, `gmap_ra_update_at`, `gmap_ra_updateP_at` | 在一个已存在 key 上 lifting base local/deterministic/predicate update，其他 key 属于不变 frame。 | +| `gmap_ra_drop_at` | 丢掉当前 key 的 fragment；不声称 hidden frame 或全局不存在同名 key。 | +| `gmap_ra_alloc_strong_dep`, `gmap_ra_alloc`, `gmap_ra_alloc_cofinite` | 从 infinite candidates 中选 source/frame-compatible fresh key；payload 可依赖 witness，也可避开 finite forbidden set。 | + +internal handles `gmap_ra_singleton_op`、`gmap_ra_singleton_op_fresh`、 +`gmap_ra_update_singleton`、`gmap_ra_updateP_singleton`、 +`gmap_ra_alloc_strong` 是 singleton normalization 和 allocation proof bridge。 + +### 4.3 `named_ra.h` / `named_ra.c` + +文件：[`named_ra.h`](../theory/logic/named_ra.h)、 +[`named_ra.c`](../theory/logic/named_ra.c) + +`named_ra R` 只是 `num` key 的 `gmap_ra R` specialization，不是 C resource +自动插入的一层。 + +- `named_ra_def`, `named_ra_unit`, `named_ra_singleton_op`, + `named_ra_valid_singleton` 固定 map specialization 与 singleton semantics； +- `named_ra_update_singleton`, `named_ra_updateP_singleton` lifting 固定 name 的 + payload update； +- `named_ra_drop` 丢掉当前 fragment 的 singleton contribution，不证明 global + absence； +- `named_ra_alloc` 返回 existential fresh `num` name，freshness 只在 + frame-preserving update 语义下成立。 + +### 4.4 `auth_ra.h` / `auth_ra.c` + +文件：[`auth_ra.h`](../theory/logic/auth_ra.h)、 +[`auth_ra.c`](../theory/logic/auth_ra.c) + +authoritative RA 把唯一 authority 与可组合 fragments 放在同一资源中： +`auth_auth R a`、`auth_frag f`、`auth_both a f`。 + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| composition | `auth_ra_unit`, `auth_ra_auth_frag`, `auth_ra_frag_frag`, `auth_ra_both_frag` | unit 是 empty fragment；authority 与 fragment 合成 both；fragments 通过 base op 聚合。 | +| validity/conflict | `auth_ra_valid_frag`, `auth_ra_valid_both`, `auth_ra_valid_auth`, `auth_ra_valid_both_frame`, `auth_ra_auth_conflict` | `auth_both a f` valid 恰当 `✓a` 且 `f ⪯ a`；任意 compatible hidden frame 只能贡献 fragment；两个 authority 冲突。 | +| inclusion | `auth_ra_included_frag_frag`, `auth_ra_included_frag_both`, `auth_ra_included_auth_auth`, `auth_ra_included_auth_both`, `auth_ra_included_both_both` | fragment inclusion 回落到 base；包含 authority 时 authoritative value 必须相同。 | +| structure | `auth_ra_cancellative_iff` | auth construction 是否 cancellative 精确由 base RA 决定。 | +| updates | `auth_ra_update_framewise_iff`, `auth_ra_update_local`, `auth_ra_update_auth_iff`, `auth_ra_update_alloc`, `auth_ra_update_drop_local`, `auth_ra_update_drop_auth`, `auth_ra_update_weaken_frag`, `auth_ra_alloc` | framewise theorem是总判据；base local update 可同步 authority/local fragment；可分配、弱化或分别 drop authority/local 部分，但所有变化都必须继续覆盖未知 external fragments。 | + +直觉：authority 是“全局真相”，fragment 是“客户端看到的下界/片段”。任何更新都 +必须让新 authority 继续容纳旧 frame 中可能存在的 fragment，因此不能只检查当前 +可见 fragment。 + +## 5. Linear separation logic + +### 5.1 `resource_prop.h` / `resource_prop.c` + +文件：[`resource_prop.h`](../theory/logic/resource_prop.h)、 +[`resource_prop.c`](../theory/logic/resource_prop.c)、 +[`resource_prop_internal.h`](../theory/logic/resource_prop_internal.h) + +对 `R:(A)ra`，assertion 是 `A -> bool`；entailment 只观察 valid resource： + +```text +r_entails R P Q <=> forall a. ra_valid R a ==> P a ==> Q a +r_equiv R P Q <=> r_entails R P Q && r_entails R Q P +``` + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| 定义 | `r_entails_def`, `r_equiv_def`, `r_emp_def`, `r_sep_def`, `r_wand_def`, `r_own_def`, `r_top_def`, `r_bottom_def`, `r_and_def`, `r_or_def`, `r_impl_def`, `r_exists_def`, `r_forall_def`, `r_pure_def`, `r_fact_def` | `emp` 精确 unit；`sep` 把资源分成两个 RA fragments；`own a` 精确拥有 `a`；wand 对所有 compatible extension 作承诺。 | +| entailment/equivalence | `r_entails_refl`, `r_entails_trans`, `r_entails_pointwise`, `r_equiv_pointwise`, `r_equiv_intro`, `r_equiv_refl`, `r_equiv_sym`, `r_equiv_trans` | `r_equiv` 是 valid points 上的逻辑等价，不等于 arbitrary predicate 的 raw function equality。 | +| truth/false | `r_top_intro`, `r_bottom_elim` | additive truth 可由任意 assertion 推出；bottom 可推出任意 assertion。 | +| separating conjunction | `r_sep_assoc`, `r_sep_comm`, `r_sep_emp_l`, `r_sep_emp_r`, `r_sep_mono`, `r_sep_frame_l`, `r_sep_frame_r`, `r_sep_exists_l`, `r_sep_exists_r` | 公开代数律都返回 `r_equiv`；frame rules 保留未参与推理的 linear resource；exists 可与 sep 交换 witness。 | +| additive connectives/quantifiers | `r_impl_adjunction`, `r_and_intro`, `r_and_elim_l`, `r_and_elim_r`, `r_or_intro_l`, `r_or_intro_r`, `r_or_elim`, `r_exists_intro`, `r_exists_elim`, `r_exists_mono`, `r_forall_intro`, `r_forall_elim` | additive 分支观察同一整个 resource；它们不执行 spatial split。 | +| wand | `r_wand_adjunction`, `r_wand_elim`, `r_wand_mono` | `P ** Q ⊢ S` 与 `P ⊢ Q -* S` 对应；wand 对前件反变、对后件协变。 | +| pure | `r_pure_and_intro`, `r_pure_and_elim` | resource-independent HOL side condition 只通过 additive `r_and` 携带，不可当作空资源 conjunct。 | +| fact | `r_fact_as_pure_and_emp`, `r_fact_true`, `r_fact_false`, `r_fact_sep_l`, `r_fact_sep_r`, `r_fact_intro`, `r_fact_elim`, `r_fact_dup` | `fact phi ≡ pure phi && emp`，所以它精确占有 unit，可安全进入 separating context 并可 duplicate。 | +| ownership | `r_own_unit`, `r_own_op`, `r_own_valid` | unit ownership 等价 emp；composition ownership 可 split/join；validity以 `fact(✓a) ** own a` 暴露，同时保留 ownership。 | +| 单向分配 | `r_sep_and_forward_r`, `r_sep_and_forward_l` | sep 可向 additive conjunction 单向分配；反向一般错误，因为 additive 两支可能选不同 resource decomposition。 | + +这里最容易犯错的是混淆 `r_pure` 与 `r_fact`： + +```text +r_pure R phi a <=> phi +r_fact R phi a <=> phi && a == ra_unit R +``` + +`pure` 在任意资源上成立，适合 additive guard；`fact` 只在 unit 上成立，适合 +spatial side condition。validity 与 `updateP` witness 必须使用 `fact`，否则会把 +仍然存在的资源悄悄吞掉。逻辑整体仍是 linear：除 exact-unit `fact` 外，没有一般 +weakening 或 contraction。 + +`resource_prop_internal.h` 的 raw equality handles 是： + +- sep：`r_sep_comm_eq`, `r_sep_emp_l_eq`, `r_sep_emp_r_eq`, + `r_sep_assoc_eq`, `r_sep_exists_l_eq`, `r_sep_exists_r_eq`； +- adapter schema：`r_forall_elim_cont`； +- fact：`r_fact_as_pure_and_emp_eq`, `r_fact_true_eq`, `r_fact_false_eq`, + `r_fact_sep_l_eq`, `r_fact_sep_r_eq`； +- ownership：`r_own_unit_eq`, `r_own_op_eq`。 + +这些 theorem 允许 proof engine 做 certified raw rewrite；普通 client 应使用对应 +public `r_equiv` law。 + +### 5.2 `basic_update.h` / `basic_update.c` + +文件：[`basic_update.h`](../theory/logic/basic_update.h)、 +[`basic_update.c`](../theory/logic/basic_update.c) + +`r_bupd R Q a <=> ra_updateP R a Q`，而 +`r_viewshift R P Q <=> P ⊢ r_bupd R Q`。这是对完整 `R` 的 generic update；若 +`R` 同时包含 physical state，就不能拿它作为 C command 的 ghost update。 + +| handles | 内容与直觉 | +| --- | --- | +| `r_bupd_def`, `r_viewshift_def` | 从 algebraic `ra_updateP` 提升为 assertion modality 与 assertion-to-assertion view shift。 | +| `r_bupd_intro`, `r_bupd_mono`, `r_bupd_idem`, `r_bupd_frame` | 不更新、postcondition consequence、两层 update 合并、保留 spatial frame。 | +| `r_viewshift_refl`, `r_entails_to_viewshift`, `r_viewshift_trans`, `r_viewshift_mono`, `r_viewshift_frame`, `r_viewshift_sep`, `r_viewshift_exists` | 普通 entailment 可嵌入 view shift；view shift 可串接、frame、并行组合和逐 witness lifting。 | +| `r_own_update` | `ra_update R a b` 给出 `own a ⇛ own b`。 | +| `r_own_updateP` | `ra_updateP R a P` 给出 `own a ⇛ exists b. fact(P b) ** own b`；witness side condition 是 exact-unit fact。 | + +### 5.3 `big_sep.h` / `big_sep.c` + +文件：[`big_sep.h`](../theory/logic/big_sep.h)、 +[`big_sep.c`](../theory/logic/big_sep.c) + +该模块保持为一个整体，不拆 core/extras。稳定 surface 只有 list right fold。 + +- `r_big_sep_list_def` 是 raw recursive computation：空表为 `emp`，cons 为 + `Phi x ** big_sep xs`； +- `r_big_sep_list_nil`, `r_big_sep_list_cons`, + `r_big_sep_list_singleton`, `r_big_sep_list_append` 是 public `r_equiv` + normalization； +- `r_big_sep_list_mono`, `r_big_sep_list_equiv` 只要求列表实际成员上的 pointwise + entailment/equivalence； +- `r_big_sep_list_map` 是普通 list `MAP` 的 naturality，不是 finite-map binder； +- `r_big_sep_list_sep` 在“每个元素各有两份资源”与“两份完整 big-sep”之间重排。 + +典型用法：以 append 暴露 prefix/suffix，以 cons 暴露 head，以 mono/equiv 逐元素 +推理，再用 sep theorem 把两条资源列表分组。 + +### 5.4 `product_resource.h` / `product_resource.c` + +文件：[`product_resource.h`](../theory/logic/product_resource.h)、 +[`product_resource.c`](../theory/logic/product_resource.c)、 +[`product_resource_internal.h`](../theory/logic/product_resource_internal.h) + +exact lift 要求未选中的 projection 精确为 unit： + +```text +r_lift_left R S P (left,right) <=> P left && right == ra_unit S +r_lift_right R S Q (left,right) <=> left == ra_unit R && Q right +``` + +right-only update 固定复用 source left： + +```text +r_bupd_right R S Q (left,right) <=> + ra_updateP S right (\right'. Q (left,right')) +``` + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| 定义 | `r_lift_left_def`, `r_lift_right_def`, `r_bupd_right_def`, `r_viewshift_right_def` | exact projection lifts 与只更新右 RA 的 modality。 | +| lift laws | `r_lift_left_emp`, `r_lift_right_emp`, `r_lift_left_sep`, `r_lift_right_sep`, `r_lift_left_entails`, `r_lift_right_entails` | exact lift 保持 emp、sep 与 entailment；public algebra laws 用 `r_equiv`。 | +| right bupd | `r_bupd_right_intro`, `r_bupd_right_mono`, `r_bupd_right_idem`, `r_bupd_right_frame` | 虽然 frame 可同时含左右资源，更新本身只由右坐标的 `ra_updateP` 驱动。 | +| right view shift | `r_viewshift_right_refl`, `r_viewshift_right_entails`, `r_viewshift_right_trans`, `r_viewshift_right_mono`, `r_viewshift_right_frame`, `r_viewshift_right_sep`, `r_viewshift_right_fact`, `r_viewshift_right_exists` | consequence/composition/frame/并行/量词规则；fact guard 保持 exact-unit 语义。 | +| right ownership | `r_right_own_update`, `r_right_own_updateP` | 把右 RA 的 deterministic/predicate update 提升为产品 view shift；predicate 版返回 witness、`fact(P b)` 与新 right ownership。 | + +`product_resource_internal.h` 只有 `r_lift_left_emp_eq`、 +`r_lift_right_emp_eq`、`r_lift_left_sep_eq`、`r_lift_right_sep_eq` 四个 raw +equality，供 adapter normalization 使用。 + +### 5.5 `named_logic.h` / `named_logic.c` + +文件：[`named_logic.h`](../theory/logic/named_logic.h)、 +[`named_logic.c`](../theory/logic/named_logic.c) + +`named_own R name a` 是 `named_ra R` 中 singleton map 的 exact ownership。 + +- `named_own_def` 展开 singleton ownership； +- `named_own_op` 在同一 name 下 split/join payload composition； +- `named_own_valid` 暴露 `fact (ra_valid R a)` 并保留 ownership； +- `named_own_update`, `named_own_updateP` 在固定 name 上提升 payload update， + predicate 版返回 `exists b. fact(P b) ** named_own name b`； +- `named_own_drop` 丢掉当前 singleton fragment，不证明 hidden/global absence； +- `named_own_alloc` 在 ambient assertion 外 frame-preservingly 分配 fresh name，返回 + existential name 与原 frame。 + +## 6. Adapter 与安装边界 + +### 6.1 `adapter/ra_sl.h` / `ra_sl.c` + +文件：[`ra_sl.h`](../adapter/ra_sl.h)、[`ra_sl.c`](../adapter/ra_sl.c) + +public C API 只有 `ra_sl_build(const term R, sl_theory *out)`。它要求 `R` 是 closed、 +monomorphic、类型严格为 unary `(A)ra`，然后把 generic BI theorem specialize 成 +`A -> bool` 上的 `sl_theory` bundle；它不安装 parser、不选择 C memory、不创建 +update modality。 + +bundle 中 `fact` 映射到 `r_fact`，而不是 `r_pure`。SEP ACU normalization、exists +distribution 与 `fact(T)=emp` 的 proof-engine schema 需要 internal raw equality； +这是 adapter 有意承担的 certified boundary，并不把 `_eq` theorem 变成 client API。 + +### 6.2 `adapter/ra_sl_scope.h` / `ra_sl_scope.c` + +文件：[`ra_sl_scope.h`](../adapter/ra_sl_scope.h)、 +[`ra_sl_scope.c`](../adapter/ra_sl_scope.c)、 +[`ra_sl_scope_internal.h`](../adapter/ra_sl_scope_internal.h) + +`ra_sl_scope` 保存一个 immutable alias-backed `sl_theory`，以及 scoped operators 的 +conservative definition handles：`emp_def`, `sep_def`, `wand_def`, `and_def`, +`or_def`, `exists_def`, `forall_def`, `entails_def`, `equiv_def`, `fact_def`, +`pure_def`。其中 `pure` 单独保存，不进入把 `fact` 作为 spatial proposition 的 +`sl_theory`。 + +internal functions `sl_scope_name_is_valid`、`sl_define_scope_alias`、 +`ra_sl_scope_prepare`、`ra_sl_scope_fold`、`ra_sl_scope_install`、 +`ra_sl_scope_activate` 把流程拆成 prepare、fold、commit/install、syntax activation。 +HOL constant definition 与 parser mutation 是 process-global、不可回滚；越过 commit +边界后的错误必须 fail-stop。 + +syntax 中 `-||-` 是 validity-sensitive `r_equiv`，`-|-` 才是 raw HOL assertion +equality；两者不能互换。 + +## 7. C program logic + +这一层固定： + +```text +Mem = (int,(pmem_byte_state)excl)finmap +G = 完整 global ghost RA +CRes_G = c_resource_ra G = prod_ra mem_ra G +Prop_G = carrier(CRes_G) -> bool +``` + +`G` 已经是完整 ghost algebra；`c_resource_ra` 不会暗中增加 `named_ra`。 + +### 7.1 `c_types.h` / `c_types.c` + +文件：[`c_types.h`](../theory/c_program_logic/c_types.h)、 +[`c_types.c`](../theory/c_program_logic/c_types.c) + +`sizeof_def` 给出 provisional 64-bit ABI 下的 scalar/function-pointer width；struct +layout 仍由抽象事实提供。`field_addr_prop` 把 field address 联系到 base address 与 +abstract field offset。该模块是 C type/layout vocabulary，不携带 ownership。 + +### 7.2 `mem_ra.h` / `mem_ra.c` + +文件：[`mem_ra.h`](../theory/c_program_logic/mem_ra.h)、 +[`mem_ra.c`](../theory/c_program_logic/mem_ra.c) + +物理内存 RA 是 address-keyed exclusive byte-state map：地址缺失表示无 ownership， +`PMemUninit` 与 `PMemByte value` 是两种独占 byte state。 + +| handles | 内容与直觉 | +| --- | --- | +| `mem_ra_def`, `mem_ra_unit`, `mem_ra_op_lookup`, `mem_ra_valid` | 把 physical memory 实现为 `gmap_ra excl_ra`；composition 逐地址，重叠是否合法由 exclusive byte payload 决定。 | +| `pmem_singleton_def`, `pmem_uninit_def`, `pmem_byte_def` | 构造一个地址上的 canonical uninitialized/initialized fragment。 | +| `pmem_singleton_valid`, `pmem_singleton_overlap_invalid` | 单字节 ownership valid；同地址的两个 canonical singleton 冲突。 | +| `pmem_update_uninit_byte`, `pmem_update_byte_uninit`, `pmem_update_byte_byte` | 底层 byte-state frame-preserving updates，供 certified C command semantics 使用。它们不是允许 proof-level view shift 改物理内存的接口。 | + +### 7.3 `mem_own.h` / `mem_own.c` + +文件：[`mem_own.h`](../theory/c_program_logic/mem_own.h)、 +[`mem_own.c`](../theory/c_program_logic/mem_own.c) + +`pmem_own_def` 是 `r_own mem_ra`；`pmem_uninit_at_def`、`pmem_byte_at_def` 分别 +把 canonical singleton 包成 exact physical ownership assertion。这三个是具体 +predicate 的 definition equations，不是通用 BI connective law。 + +### 7.4 `mem_value.h` / `mem_value.c` + +文件：[`mem_value.h`](../theory/c_program_logic/mem_value.h)、 +[`mem_value.c`](../theory/c_program_logic/mem_value.c) + +该模块从单字节 ownership 组装连续区域与 little-endian scalar。 + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| unknown byte | `pmem_allocated_byte_at_def` | existentially 隐藏 byte state；既可能是 `PMemUninit`，也可能是 `PMemByte v`，表示“拥有且可覆盖写，当前内容未知”。 | +| initialized byte list | `pmem_bytes_at_def`, `pmem_bytes_at_nil`, `pmem_bytes_at_cons` | 按连续地址精确拥有给定 initialized bytes。 | +| allocated range | `pmem_allocated_at_def`, `pmem_allocated_at_zero`, `pmem_allocated_at_suc`, `pmem_allocated_at_append`, `pmem_allocated_at_split` | 连续 unknown-content ownership 的递归、拼接和切分。append/split 是 carving memory range 的主规则。 | +| forget byte contents | `pmem_uninit_at_allocated_byte`, `pmem_byte_at_allocated_byte`, `pmem_bytes_at_allocated` | initialized 或 strictly-uninitialized ownership 都可弱化为 allocated/unknown ownership；逆向恢复内容不成立。 | +| little endian | `pmem_le_bytes_def`, `pmem_le_bytes_zero`, `pmem_le_bytes_suc`, `pmem_le_bytes_length` | 取 value 的低 `n` 个 base-256 digits，least-significant byte first，并证明输出长度。 | +| scalar assertions | `pmem_scalar_at_def`, `pmem_undef_scalar_at_def`, `pmem_scalar_at_zero`, `pmem_scalar_at_suc`, `pmem_undef_scalar_at_zero`, `pmem_undef_scalar_at_suc` | `scalar_at` 精确 initialized bytes；`undef_scalar_at` 要求每个 byte 都严格是 `PMemUninit`。 | +| forget scalar state | `pmem_undef_scalar_at_allocated`, `pmem_scalar_at_allocated` | initialized 或严格未初始化 scalar 都可忘记为同宽 allocated range。 | + +关键区别：`pmem_allocated_at`/后续 `undef_data_at` 表示 unknown content，不表示 +strictly uninitialized。只有 `pmem_undef_scalar_at` 才对每个字节断言 +`PMemUninit`。 + +### 7.5 `c_resource.h` / `c_resource.c` + +文件：[`c_resource.h`](../theory/c_program_logic/c_resource.h)、 +[`c_resource.c`](../theory/c_program_logic/c_resource.c) + +| handles | 内容与直觉 | +| --- | --- | +| `c_resource_ra_def`, `c_resource_ra_unit`, `c_resource_ra_op`, `c_resource_ra_valid` | `CRes_G = mem_ra × G`，unit/op/valid 逐坐标。这里的 `G` 是完整 global ghost RA。 | +| `c_lift_phys_def`, `c_lift_ghost_def` | physical/ghost assertions 分别 exact lift 到 left/right；另一个 projection 必须精确为 unit。 | +| `c_ghost_own_def` | `c_lift_ghost G (r_own G a)`，即 exact ownership of arbitrary global ghost fragment。 | +| `c_pmem_uninit_at_def`, `c_pmem_byte_at_def` | 把 canonical physical byte assertions exact lift 到 complete C resource。 | + +物理与 ghost exact lift 通过 `**` 合并后，才得到同时含两种状态的资源。需要 +numeric names 时应显式取 `G = named_ra R`。 + +### 7.6 `c_basic_update.h` / `c_basic_update.c` + +文件：[`c_basic_update.h`](../theory/c_program_logic/c_basic_update.h)、 +[`c_basic_update.c`](../theory/c_program_logic/c_basic_update.c) + +`c_bupd_def`、`c_viewshift_def` 分别 specialize 为 +`r_bupd_right mem_ra G` 与 `r_viewshift_right mem_ra G`。 +`c_bupd_preserves_phys` 给出安全边界：valid source 的任何结果都形如 +`(FST source,new_ghost)`。 + +直觉：C view shift 只能更新完整 ghost projection。物理写入、清零或初始化状态 +改变必须来自 certified C command semantics，而不是 algebraic ghost view shift。 + +### 7.7 `c_ghost.h` / `c_ghost.c` + +文件：[`c_ghost.h`](../theory/c_program_logic/c_ghost.h)、 +[`c_ghost.c`](../theory/c_program_logic/c_ghost.c) + +对任意完整 `G`： + +- `c_ghost_own_op` 以 `r_equiv` split/join `a · b`； +- `c_ghost_own_valid` 保留 ownership，并暴露 exact-unit validity fact； +- `c_ghost_own_update`, `c_ghost_own_updateP` 提升 deterministic/predicate ghost + update，predicate 版返回 existential witness、`r_fact(P b)` 与新 ownership； +- `c_ghost_own_drop` 显式放弃当前 ghost fragment。 + +对 `G = named_ra R` 的 convenience specialization： + +- `c_named_own_def`, `c_named_own_op`, `c_named_own_valid`； +- `c_named_own_update`, `c_named_own_updateP`, `c_named_own_drop`； +- `c_named_own_alloc` 在任意 physical/ghost frame 下返回 existential fresh name。 + +所有 update/drop/alloc 都使用 right-only `c_viewshift`，所以不能改变 physical +projection。“drop”只表示放弃当前 fragment 的贡献，不等价于证明 global key +不存在。 + +### 7.8 `c_memory.h` / `c_memory.c` + +文件：[`c_memory.h`](../theory/c_program_logic/c_memory.h)、 +[`c_memory.c`](../theory/c_program_logic/c_memory.c) + +该模块把 byte-level ownership 加上 C scalar ABI guard，并 exact lift 到 complete +C resource。 + +| theorem 族 | handles | 内容与直觉 | +| --- | --- | --- | +| scalar ABI | `pmem_ctype_distinct`, `pmem_c_scalar_type_def`, `pmem_c_width_def`, `pmem_c_min_def`, `pmem_c_max_def`, `pmem_c_address_ok_def`, `pmem_uint64_address_ok_def`, `pmem_ptr_address_ok_def`, `pmem_c_value_ok_def`, `pmem_c_address_ok_Tuint64` | 区分 scalar constructors，定义 1/2/4/8-byte width、signed/unsigned range、64-bit address bounds 与 natural alignment。`Tstruct`/`Tfun` 没有这里的 scalar-storage semantics。 | +| physical typed atoms | `pmem_data_at_def`, `pmem_undef_data_at_def` | `data_at` 是 address/value guard 与 initialized scalar ownership 的 additive conjunction；`undef_data_at` 是 address guard 与 unknown-content allocated range。guard 使用 resource-independent `r_pure`。 | +| physical weakening | `pmem_data_at_allocated_at`, `pmem_undef_data_at_allocated_at`, `pmem_allocated_at_to_undef_data_at`, `pmem_data_at_to_undef_data_at`, `pmem_undef_scalar_at_Tuint64` | initialized/unknown/strict-uninitialized representation 之间只按丢失信息的方向转换，不凭逻辑恢复未知值。 | +| complete-C definitions | `c_allocated_at_def`, `c_data_at_def`, `c_undef_data_at_def` | physical predicates 的 exact left lifts，ghost projection 是 unit。 | +| concrete range normalization | `c_allocated_at_zero`, `c_allocated_at_append` | 具体 allocated-range predicate 的 raw computation/normalization；不是 generic BI connective equality。 | +| complete-C entailments | `c_allocated_at_to_undef_data_at`, `c_data_at_to_undef_data_at`, `c_data_at_allocated_at`, `c_undef_data_at_allocated_at` | lifted typed/allocated assertions之间的 information-forgetting rules。 | +| value range | `c_data_at_value_range` | 保留 initialized cell，并以 separating `r_fact` 暴露 `min <= value <= max`；range fact 不消耗 cell。 | + +`pmem_data_at` 是可读且值已知；`pmem_undef_data_at` 只表示可覆盖写的 unknown +cell；`pmem_undef_scalar_at` 才表示严格未初始化。不存在从 unknown-content assertion +恢复 initialized value 的 theorem。 + +### 7.9 `c_integer.h` / `c_integer.c` + +文件：[`c_integer.h`](../theory/c_program_logic/c_integer.h)、 +[`c_integer.c`](../theory/c_program_logic/c_integer.c) + +这是独立整数/bit-operation semantics，不拥有资源。 + +- width-generic definitions：`c_exp_2_def`, `c_max_unsigned_def`, + `c_max_signed_def`, `c_min_signed_def`, `cast_unsigned_def`, + `cast_signed_def`, `unsigned_last_nbits_def`, `signed_last_nbits_def`, + `unsigned_last_nbits_id`；unsigned cast 是 modulo `2^width`，signed cast 是 + two's-complement reinterpretation； +- 32-bit signed：`i32_and_def`, `i32_or_def`, `i32_xor_def`, `i32_not_def`, + `i32_shl_def`, `i32_shr_def`； +- 32-bit unsigned：`u32_and_def`, `u32_or_def`, `u32_xor_def`, `u32_not_def`, + `u32_shl_def`, `u32_shr_def`； +- 64-bit signed：`i64_and_def`, `i64_or_def`, `i64_xor_def`, `i64_not_def`, + `i64_shl_def`, `i64_shr_def`； +- 64-bit unsigned：`u64_and_def`, `u64_or_def`, `u64_xor_def`, `u64_not_def`, + `u64_shl_def`, `u64_shr_def`。 + +signed result 使用 `ival`，unsigned result 使用 `val`；right shift 分别选择 +arithmetic/logical word shift。`c_exp_2_def` 在 searchable theorem database 中以 +`int_exp_2_def` 注册。 + +### 7.10 `c_fnspec.h` / `c_fnspec.c` + +文件：[`c_fnspec.h`](../theory/c_program_logic/c_fnspec.h)、 +[`c_fnspec.c`](../theory/c_program_logic/c_fnspec.c) + +该模块没有 public theorem equation，只声明 opaque markers： + +```text +c_fnspec G : int -> ctype -> Prop_G -> Prop_G -> Prop_G +c_fnspec_w G : int -> ctype -> (B -> Prop_G) -> (B -> Prop_G) -> Prop_G +``` + +它们的 operational meaning 属于 certified QCP/C-logic boundary，不能在普通 +RA/BI proof 中展开。 + +## 8. QCP runtime surface + +文件：[`userlib/qcp/c_logic.h`](../../userlib/qcp/c_logic.h)、 +[`userlib/qcp/c_logic.c`](../../userlib/qcp/c_logic.c)、 +[`userlib/qcp/c_logic_default.h`](../../userlib/qcp/c_logic_default.h)、 +[`userlib/qcp/c_logic_default.c`](../../userlib/qcp/c_logic_default.c)、 +[`userlib/qcp/veriftime.h`](../../userlib/qcp/veriftime.h)、 +[`userlib/qcp/veriftime.c`](../../userlib/qcp/veriftime.c) + +`c_logic_install_named(R)` 接收 closed monomorphic payload RA，并显式选择： + +```text +G = named_ra R +CRes = c_resource_ra G +``` + +调用者传 `R`，不能传已经包过的 `named_ra R`。安装定义 scoped aliases、构造 +right-only update bundle、注册 theorem names，并激活 parser；这是一次性、全局、 +fail-stop transaction。默认安装取 `R = unit_ra`。 + +`c_logic_default.h/.c` 只封装这个默认选择；`veriftime.h` 在未定义 +`CSTAR_DEFER_C_LOGIC_INSTALL` 时加载默认 installer，并提供 QCP proof-time +notation。需要自定义 payload RA 的 root 应先 defer default，再定义/export +payload vocabulary 并调用 `c_logic_install_named(R)`。`veriftime.c` 是对应 runtime +support，不定义另一套 RA/SL semantics。 + +### 8.1 `c_logic_scope` 中的 theorem families + +- physical aliases：`data_at`/`data_at_def`、 + `undef_data_at`/`undef_data_at_def`； +- opaque spec aliases：`fnspec`/`fnspec_def`、`fnspec_w`/`fnspec_w_def`； +- named ownership alias：`own`/`own_def`； +- right-only update bundle：`bupd_intro`, `bupd_mono`, `bupd_idem`, `bupd_frame`, + `viewshift_refl`, `viewshift_entails`, `viewshift_trans`, `viewshift_mono`, + `viewshift_frame`, `viewshift_sep`, `viewshift_fact`, `viewshift_exists`； +- selected memory rules：`data_at_value_range`, `allocated_at_zero`, + `allocated_at_append`, `data_at_allocated_at`, `undef_data_at_allocated_at`, + `allocated_at_to_undef_data_at`, `data_at_to_undef_data_at`； +- selected named ghost rules：`ghost_own_op`, `ghost_own_split`, + `ghost_own_join`, `ghost_own_valid`, `ghost_own_update`, + `ghost_own_updateP`, `ghost_own_drop`, `ghost_own_alloc`。 + +`ghost_own_op` 是 logical equivalence；`split` 与 `join` 是两个相反方向的 +entailment，既不是 raw equality，也不是 view shift。 + +固定 searchable theorem database names 是： + +```text +c_logic_data_at_value_range +c_logic_allocated_at_zero +c_logic_allocated_at_append +c_logic_data_at_allocated_at +c_logic_undef_data_at_allocated_at +c_logic_allocated_at_to_undef_data_at +c_logic_data_at_to_undef_data_at +c_logic_ghost_own_op +c_logic_ghost_own_split +c_logic_ghost_own_join +c_logic_ghost_own_valid +c_logic_ghost_own_update +c_logic_ghost_own_updateP +c_logic_ghost_own_drop +c_logic_ghost_own_alloc +``` + +source interface 中，`fact` 与 `pure` 保持不同；`==*=>` 是 right-only view +shift；`-||-` 是 logical equivalence；`-|-` 是 raw equality；`cprop` 只是当前 +`Prop_G` 的 parser abbreviation，不是新 HOL type。 + +## 9. 常见 theorem 组合路径 + +### 9.1 分解 ownership 并取得 validity + +1. 用 `r_own_op` 或 instance-specific `*_own_op` 把 `own(a · b)` 改写成 + `own a ** own b`。 +2. 用 `r_own_valid` 得到 `fact(✓a) ** own a`。 +3. 用 `r_fact_elim` 把 validity 放入 ordinary HOL context，同时保留 `own a`。 + +这里不能把 `fact` 替换为 `pure`；否则 side condition 会在任意资源上成立，破坏 +linear resource accounting。 + +### 9.2 deterministic / predicate update + +- deterministic：`ra_update` → `r_own_update` → `r_viewshift_frame` → + `r_viewshift_trans`； +- predicate：`ra_updateP` → `r_own_updateP` → + `exists b. fact(P b) ** own b`，随后消去 existential 与 fact； +- 两个独立更新可用 `r_viewshift_sep` 合并；普通 entailment 可先以 + `r_entails_to_viewshift` 嵌入。 + +### 9.3 named lifecycle + +- allocation：`ra_valid R a` + `named_own_alloc`/`c_named_own_alloc`； +- 同 name split/join：`named_own_op`/`c_named_own_op`； +- fixed-name update：`named_own_update(P)`/`c_named_own_update(P)`； +- release current fragment：`named_own_drop`/`c_named_own_drop`。 + +allocation 的 name 是 existential witness；drop 不提供 global freshness/absence。 + +### 9.4 physical memory + +- 区间切分：`pmem_allocated_at_append`/`pmem_allocated_at_split` 或 lifted + `c_allocated_at_append`； +- initialized cell 忘记内容：`c_data_at_to_undef_data_at` 或 + `c_data_at_allocated_at`； +- strict uninitialized `Tuint64` 变为 QCP unknown cell： + `pmem_undef_scalar_at_Tuint64`； +- 暴露 value range 且保留 cell：`c_data_at_value_range`； +- 在 physical frame 下更新 ghost：`c_named_own_update(P)` 配合 + `r_viewshift_right_frame`/installed `viewshift_frame`。 + +任何 physical byte-state 改变都应来自 certified command rule；不能用 generic +`r_bupd` 或 C ghost view shift 绕过这一边界。 + +## 10. Regression files 对应的契约 + +以下测试不是额外公理，而是把 public theorem statements 与架构边界锁定： + +- [`ra_core_regression.c`](../test/ra_core_regression.c)：RA relations、 + `ra_updateP` frame-dependent witness、valid-source exclusivity 与五参数 local update； +- [`basic_ra_constructors_regression.c`](../test/basic_ra_constructors_regression.c)、 + [`value_ra_constructors_regression.c`](../test/value_ra_constructors_regression.c)： + unit/product/option/excl/agree/max-nat/fraction constructors； +- [`gmap_ra_regression.c`](../test/gmap_ra_regression.c)、 + [`named_ra_regression.c`](../test/named_ra_regression.c)：pointwise map、drop 与 fresh + allocation； +- [`auth_ra_regression.c`](../test/auth_ra_regression.c)、 + [`auth_ra_structure_regression.c`](../test/auth_ra_structure_regression.c)： + authoritative validity/inclusion/update； +- [`sl_v2_regression.c`](../test/sl_v2_regression.c)：`r_equiv` laws、 + `pure`/`fact`、big-sep 与 right-only product update； +- [`c_resource_v2_regression.c`](../test/c_resource_v2_regression.c)：complete global + `G`、physical preservation、generic/named ghost rules； +- [`dependency_v2_regression.sh`](../test/dependency_v2_regression.sh)：RA→SL/C 依赖方向、 + public/internal 边界、lowercase theorem handles 与 removed v1 API。 diff --git a/docs/RA_SL_THEORY_SUMMARY.md b/docs/RA_SL_THEORY_SUMMARY.md new file mode 100644 index 0000000000000000000000000000000000000000..b8014817582f779f3c6b961de6befdb1cdb063ea --- /dev/null +++ b/docs/RA_SL_THEORY_SUMMARY.md @@ -0,0 +1,569 @@ +# C* first-order RA / linear separation logic v2 + +> 本文描述 `cstar_examples/proof` 当前 v2 理论的稳定设计与公开接口。 +> 实现中的定理对象仍由 HOL 内核机械检查；各 public header 是精确 API 的最终 +> 来源。v2 是一次 breaking redesign，不提供历史接口的兼容别名或转接层。 + +按源码文件查阅 theorem families、直观解释和典型组合方式时，请配合 +[`RA_SL_THEOREM_GUIDE.md`](RA_SL_THEOREM_GUIDE.md) 阅读。 + +## 1. 设计边界 + +本理论面向“不含 later 的 first-order ghost state”。RA 是带 validity 的交换 +幺半群；SL 是其 carrier 上的严格 linear BI。此范围有意不引入 OFE/COFE、 +step index、camera extension、core、contractive functor、guarded fixpoint、 +later modality或 impredicative invariant ownership。 + +v2 固定以下边界： + +- predicate update `ra_updateP` 是唯一 primitive update；`ra_update` 只是它的 + singleton 特化； +- `ra_maximal` 自带 source validity，不允许无效源通过真空蕴含被称为 + maximal； +- 用户级 assertion algebra 统一以 `r_equiv` 表达；raw assertion-function + equality 只留给实现和 adapter； +- `r_pure` 与 `r_fact` 明确保留为两个不同构造：前者资源无关，后者精确占有 + unit； +- C resource 的参数 `G` 表示完整、闭合的 global ghost RA， + `c_resource_ra G = prod_ra mem_ra G`； +- generic basic update 可以更新完整 RA；C basic update 只能更新产品右分量， + 物理内存投影不变； +- numeric naming 是显式可选构造 `named_ra R = gmap_ra R`，不是 C resource + 暗中加入的一层； +- 释放当前 fragment 的操作统一称为 `drop`；它不声称隐藏 frame 中不存在同名 + 资源； +- theorem handles 统一使用 `lower_snake_case`；若名称嵌入了本理论中原本带 + 大写字母的 object-language constant，则保留该 constant 的拼写，例如 + `ra_updateP_refl` 与 `pmem_c_address_ok_Tuint64`； +- big separation 继续由同一个 `big_sep.{h,c}` 模块提供，不拆文件或子模块。 + +核心依赖关系如下： + +```text +ra + ra_builder +├── local_update +├── unit_ra / prod_ra / option_ra / excl_ra / agree_ra +├── max_nat_ra / frac_ra +├── gmap_ra ─────────────── named_ra +└── auth_ra + +ra ─────────────────────── resource_prop +resource_prop + ra ─────── basic_update +resource_prop + prod_ra ── product_resource +resource_prop ──────────── big_sep + +gmap_ra + excl_ra ──────── mem_ra +mem_ra + complete G ────── c_resource +product_resource ───────── c_basic_update +c_basic_update + named_ra c_ghost +``` + +## 2. RA 核心 + +源文件：[`ra.h`](../theory/logic/ra.h)、 +[`ra.c`](../theory/logic/ra.c)。构造者接口位于 +[`ra_builder.h`](../theory/logic/ra_builder.h)。 + +固定 `R:(A)ra`，记： + +$$ +e_R = \operatorname{ra\_unit}(R),\qquad +a\cdot_R b = \operatorname{ra\_op}(R,a,b),\qquad +\checkmark_R(a)=\operatorname{ra\_valid}(R,a). +$$ + +raw descriptor 的合法性为： + +```text +ra_laws e op valid <=> + (forall a b c. op (op a b) c == op a (op b c)) && + (forall a b. op a b == op b a) && + (forall a. op e a == a) && + valid e && + (forall a b. valid (op a b) ==> valid a) +``` + +`(A)ra` 是只收纳 lawful descriptor 的 abstract HOL type。普通 client 使用 +`ra_laws`、`ra_assoc`、`ra_comm`、`ra_unit_l`、`ra_unit_r`、 +`ra_valid_unit` 和 `ra_valid_op`，无需重复携带 laws premise。只有 constructor +author 需要 `ra_builder.h` 中的 `ra_laws_def`、`ra_type_bijection`、 +`ra_rep_laws`、`ra_abs_rep`、`ra_unit_abs`、`ra_op_abs`、`ra_valid_abs` +与 `ra_abs_eta`。 + +### 2.1 核心关系 + +兼容性、包含关系和两种 update 的定义是： + +```text +ra_compatible R a b <=> + ra_valid R (ra_op R a b) + +ra_included R a b <=> + exists frame. b == ra_op R a frame + +ra_updateP R a P <=> + forall frame. + ra_valid R (ra_op R a frame) ==> + exists b. P b && ra_valid R (ra_op R b frame) + +ra_update R a b <=> + ra_updateP R a (\x. x == b) +``` + +`ra_updateP` 中的结果 witness 可以依赖隐藏 `frame`。这正是 predicate update +的语义；确定性 update 不另设第二套 primitive 定义。 + +公开更新定理分为两组： + +- predicate update：`ra_updateP_singleton`、`ra_updateP_refl`、 + `ra_updateP_mono`、`ra_updateP_trans`、`ra_updateP_valid`、 + `ra_updateP_frame`、`ra_updateP_op`； +- deterministic update：`ra_update_refl`、`ra_update_trans`、 + `ra_update_frame`、`ra_update_op`、`ra_update_included`、 + `ra_update_target_included`、`ra_update_valid`。 + +包含关系是 extension preorder，不承诺反对称。公开规则为 +`ra_included_refl`、`ra_included_unit`、`ra_included_op_l`、 +`ra_included_op_r`、`ra_included_trans`、`ra_included_op_mono`、 +`ra_included_valid`。兼容性公开 `ra_compat_comm` 和 `ra_compat_unit`。 + +### 2.2 cancellative 与 maximal + +```text +ra_cancellative R <=> + forall frame a b. + ra_valid R (ra_op R frame a) ==> + ra_op R frame a == ra_op R frame b ==> + a == b + +ra_maximal R a <=> + ra_valid R a && + forall frame. + ra_valid R (ra_op R a frame) ==> + frame == ra_unit R +``` + +因此 `ra_maximal R a` 本身就能推出 `ra_valid R a`。它表达强 +frame-maximality：所有 compatible frame 都必须精确等于 unit。这不等同于 +`~ra_valid R (ra_op R a a)` 这类 self-conflict exclusive 性质，后者尚未在 +核心 RA API 中定义。`excl_ra` 仍作为 exclusive-token 构造器：其 owned +tokens 之间会冲突，并且这些 owned 元素同时满足 `ra_maximal`。 + +公开使用 `ra_maximal_included`、`ra_maximal_update` 与 +`ra_cancellative_apply`；invalid-source 的真空特例不属于稳定 client API。 + +### 2.3 五参数 local update + +源文件：[`local_update.h`](../theory/logic/local_update.h)、 +[`local_update.c`](../theory/logic/local_update.c)。 + +```text +ra_local_update R a f b g <=> + forall residual. + ra_valid R a ==> + a == ra_op R f residual ==> + ra_valid R b && b == ra_op R g residual +``` + +这里 `(a,f)` 是更新前的 whole/local pair，`(b,g)` 是更新后的 pair；同一个 +未知 `residual` 被保留。接口直接使用五个参数，不再把两个 pair 包在 HOL +product 中。公开规则为： + +```text +ra_local_update_apply +ra_local_update_refl +ra_local_update_trans +ra_local_update_frame +ra_local_update_preserves_included +ra_local_update_alloc +ra_local_update_maximal +ra_local_update_cancel +ra_local_update_cancellative +``` + +## 3. RA 构造子 + +| 模块 | carrier / operation | 稳定能力 | +|---|---|---| +| `unit_ra` | singleton，unit 为 `one` | 全有效、全 included、predicate update 与 local update 的退化律 | +| `prod_ra R S` | `A#B`，逐坐标合成和 validity | 逐坐标 inclusion、update、local update，以及 `prod_inl`/`prod_inr` 提升 | +| `option_ra R` | `A option`，`NONE` 为新增 unit | `SOME` 上的 inclusion、update、local update 精确回落到 base RA | +| `excl_ra` | `ExclUnit | Excl a | ExclInvalid` | owned conflict、有效 exclusive token、替换 update | +| `agree_ra` | `AgreeUnit | Agree a | AgreeInvalid` | 相同值幂等，不同值冲突，兼容性推出 payload 相等 | +| `max_nat_ra` | `num`，unit `0`，operation `MAX` | inclusion 是 `<=`；base RA 上所有 deterministic update 都成立 | +| `frac_ra R` | empty 或正 share token | share 合成、full maximality、share weakening 与 predicate update lifting | +| `gmap_ra R` | finite map，逐 key 使用 `option_ra R` | pointwise validity/inclusion、key update、drop、fresh allocation | +| `named_ra R` | `gmap_ra R`，key 固定为 `num` | numeric name 下的 singleton ownership/update/drop/allocation | +| `auth_ra R` | authoritative + fragment | authoritative validity、framewise update、local-update lifting、allocation/drop | + +### 3.1 产品嵌入 + +```text +prod_inl R S a == (a, ra_unit S) +prod_inr R S b == (ra_unit R, b) +``` + +`prod_inl_op`/`prod_inr_op` 保持 operation； +`prod_inl_updateP`/`prod_inr_updateP` 和 +`prod_inl_update`/`prod_inr_update` 把分量更新提升到完整产品。它们用于用 +普通嵌套 product 组合多个 global ghost protocol，无需异构 registry。 + +### 3.2 finite map 与 naming + +`gmap_ra R` 对每个 key 通过 `option_ra R` 逐点解释，finite-map representation +和 support 细节保持私有。client 通过 `gmap_ra_op_lookup`、`gmap_ra_valid`、 +`gmap_ra_valid_lookup`、`gmap_ra_included_lookup_iff`、 +`gmap_ra_decompose`、`gmap_ra_local_update_at`、`gmap_ra_update_at`、 +`gmap_ra_updateP_at`、`gmap_ra_drop_at` 与 allocation rules 操作它。 + +numeric naming 是一个显式薄层： + +```text +named_ra R == (gmap_ra R : ((num,A)finmap)ra) +``` + +[`named_ra.h`](../theory/logic/named_ra.h) 公开： + +```text +named_ra_def +named_ra_unit +named_ra_singleton_op +named_ra_valid_singleton +named_ra_update_singleton +named_ra_updateP_singleton +named_ra_drop +named_ra_alloc +``` + +`drop` 只表示将当前持有的 singleton fragment 更新到 unit；它不证明同名 key +未出现在未知 frame 中。fresh allocation 由 finite support 与无限 `num` key +space 保证。 + +## 4. 资源命题与严格 linear BI + +源文件：[`resource_prop.h`](../theory/logic/resource_prop.h)、 +[`resource_prop.c`](../theory/logic/resource_prop.c)。assertion 类型为 +`A->bool`。 + +### 4.1 观察关系 + +```text +r_entails R P Q <=> + forall resource. + ra_valid R resource ==> P resource ==> Q resource + +r_equiv R P Q <=> + r_entails R P Q && r_entails R Q P +``` + +`r_equiv` 只观察有效资源；两个 assertion 可以在无效资源上不同而仍逻辑等价。 +所以 public connective laws 使用 `r_equiv`，不把 raw HOL 函数等号当作用户级 +逻辑等价。实现确实需要 rewrite 时，才包含 +`resource_prop_internal.h` 或 `product_resource_internal.h` 中的 `*_EQ` +helpers。 + +### 4.2 核心 assertion + +```text +r_emp R resource <=> + resource == ra_unit R + +r_sep R P Q resource <=> + exists left right. + resource == ra_op R left right && P left && Q right + +r_own R owned resource <=> + resource == owned + +r_wand R P Q resource <=> + forall frame. + ra_valid R (ra_op R resource frame) ==> + P frame ==> + Q (ra_op R resource frame) +``` + +此外提供 `r_top`、`r_bottom`、`r_and`、`r_or`、`r_impl`、`r_exists`、 +`r_forall`。这是 linear 逻辑：没有一般的资源 weakening 或 contraction。 +`r_sep_assoc`、`r_sep_comm`、`r_sep_emp_l`、`r_sep_emp_r`、 +`r_sep_exists_l`、`r_sep_exists_r` 的结论都是 `r_equiv`。 + +### 4.3 `r_pure` 与 `r_fact` 必须区分 + +v2 有意保留以下两个不同定义： + +```text +r_pure R phi resource <=> + phi + +r_fact R phi resource <=> + phi && resource == ra_unit R +``` + +也就是说： + +- `r_pure R phi` 是资源无关的 proposition embedding；它在任意资源点的真假 + 都只由 `phi` 决定； +- `r_fact R phi` 是 exact-unit spatial fact，等价于 pure proposition 与 + `r_emp` 的 additive conjunction；它可以安全地参与分离合取的单位元规则。 + +两者不可互换。尤其是 ownership validity 和 predicate-update witness 使用 +`r_fact`，以便结论形如： + +```text +r_fact R condition ** exact ownership +``` + +而不是用一个资源无关 proposition 偷偷消费或制造空间资源。相关公开规则是： + +```text +r_pure_and_intro r_pure_and_elim +r_fact_as_pure_and_emp r_fact_true +r_fact_false r_fact_sep_l +r_fact_sep_r r_fact_intro +r_fact_elim r_fact_dup +r_own_unit r_own_op +r_own_valid +``` + +## 5. Basic update 与 view shift + +### 5.1 generic modality + +源文件：[`basic_update.h`](../theory/logic/basic_update.h)。 + +```text +r_bupd R Q owned <=> + ra_updateP R owned Q + +r_viewshift R P Q <=> + r_entails R P (r_bupd R Q) +``` + +generic modality 可以更新完整的 `R`。公开组合律包括 intro、mono、idem、frame、 +viewshift refl/trans/mono/frame/sep/exists，以及 `r_own_update` 和 +`r_own_updateP`。其中 predicate-update ownership rule 的后置条件显式给出 +witness、`r_fact R (P witness)` 与 exact ownership。 + +### 5.2 产品 assertion lift 与右分量 update + +源文件：[`product_resource.h`](../theory/logic/product_resource.h)、 +[`product_resource.c`](../theory/logic/product_resource.c)。 + +产品 lift 是 exact lift： + +```text +r_lift_left R S P (left,right) <=> + P left && right == ra_unit S + +r_lift_right R S Q (left,right) <=> + left == ra_unit R && Q right +``` + +因此 lift 保持 `emp`、`sep` 与 entailment，同时明确要求另一坐标为 unit。 + +右分量 basic update 定义为： + +```text +r_bupd_right R S Q resource <=> + ra_updateP S (SND resource) + (\right'. Q (FST resource,right')) + +r_viewshift_right R S P Q <=> + r_entails (prod_ra R S) P (r_bupd_right R S Q) +``` + +结果始终复用源的 `FST resource`，只有 `SND` 可以变化。公开 API 提供 +`r_bupd_right_*`、`r_viewshift_right_*`、`r_right_own_update` 和 +`r_right_own_updateP`，用于 C 层以及其他需要固定左投影的产品逻辑。 + +## 6. Big separation + +源文件保持为 [`big_sep.h`](../theory/logic/big_sep.h) 与 +[`big_sep.c`](../theory/logic/big_sep.c)，不拆分模块。 + +稳定 API 只公开 list right-fold： + +```text +r_big_sep_list R Phi [] = r_emp R +r_big_sep_list R Phi (x::xs) = + r_sep R (Phi x) (r_big_sep_list R Phi xs) +``` + +公开规则仍全部使用 `r_equiv`： + +```text +r_big_sep_list_def +r_big_sep_list_nil +r_big_sep_list_cons +r_big_sep_list_singleton +r_big_sep_list_append +r_big_sep_list_mono +r_big_sep_list_equiv +r_big_sep_list_map +r_big_sep_list_sep +``` + +set/map/indexed binder 不进入稳定核心 surface；这不意味着拆分现有 big-sep +文件，而是保持同一模块中的精简 list API。 + +## 7. Named ownership + +[`named_logic.h`](../theory/logic/named_logic.h) 在 `named_ra R` 上定义： + +```text +named_own R name a = + r_own (named_ra R) (finmap_singleton name a) +``` + +公开规则为 `named_own_op`、`named_own_valid`、`named_own_update`、 +`named_own_updateP`、`named_own_drop`、`named_own_alloc`。其中： + +- `named_own_op` 的结论是 `r_equiv`； +- `named_own_valid` 把 payload validity 放入 exact-unit `r_fact`； +- `named_own_updateP` 的后置条件是 witness、`r_fact` 与更新后的 exact + ownership； +- allocation 返回 fresh numeric name；drop 只丢弃当前 fragment。 + +## 8. C resource theory + +### 8.1 物理内存 RA + +[`mem_ra.h`](../theory/c_program_logic/mem_ra.h) 定义 byte state： + +```text +pmem_byte_state = PMemUninit | PMemByte int +``` + +物理内存 carrier 是： + +```text +(int,(pmem_byte_state)excl)finmap +``` + +并且： + +```text +mem_ra = gmap_ra excl_ra +``` + +缺失 key 表示不拥有该 byte；存在的 `Excl state` 表示 exact byte ownership。 +同址两个 canonical singleton 合成无效。物理 byte 状态的 RA update 是 C command +语义的实现引理，不能直接包装成程序级 ghost viewshift。 + +### 8.2 完整 global ghost RA + +[`c_resource.h`](../theory/c_program_logic/c_resource.h) 定义： + +```text +c_resource_ra G = prod_ra mem_ra G +``` + +`G` 是 complete global ghost RA，不是某个 name 下的 payload RA。若程序只需要 +一种命名协议，可显式选择 `G = named_ra R`；若需要多种协议，可令： + +```text +G = prod_ra (named_ra R1) (named_ra R2) +``` + +并用 `prod_inl` / `prod_inr` 嵌入对应分量。 + +C assertion lift 为： + +```text +c_lift_phys G = r_lift_left mem_ra G +c_lift_ghost G = r_lift_right mem_ra G +c_ghost_own G ghost = c_lift_ghost G (r_own G ghost) +``` + +因此 physical assertion 精确要求 ghost 分量为 unit，ghost assertion 精确要求 +physical 分量为 unit；分离合取负责把它们组合成完整 C resource。 + +### 8.3 C-only ghost update + +[`c_basic_update.h`](../theory/c_program_logic/c_basic_update.h) 定义： + +```text +c_bupd G = r_bupd_right mem_ra G +c_viewshift G = r_viewshift_right mem_ra G +``` + +`c_bupd_preserves_phys` 明确证明所有 observable result 的 physical projection +与 source 相同。这是 generic update 和 C program-level update 之间不可越过的 +安全边界。 + +[`c_ghost.h`](../theory/c_program_logic/c_ghost.h) 为任意 complete `G` 公开： + +```text +c_ghost_own_op +c_ghost_own_valid +c_ghost_own_update +c_ghost_own_updateP +c_ghost_own_drop +``` + +当 complete global RA 恰为 `named_ra R` 时，`c_named_own` 提供 convenience +层，并公开 `c_named_own_op`、`c_named_own_valid`、`c_named_own_update`、 +`c_named_own_updateP`、`c_named_own_drop`、`c_named_own_alloc`。这只是显式 +specialization，不改变 `c_resource_ra` 的定义。 + +## 9. Adapter 与安装边界 + +[`adapter/ra_sl.h`](../adapter/ra_sl.h) 的 `ra_sl_build R` 接收一个闭合、 +monomorphic 的 RA term，把 generic resource-proposition 定理 specialize 成 +`sl_theory`。它不定义第二套逻辑，也不包含 C memory 或 update 语义。 + +`ra_sl_scope` 负责为被选中的 RA 建立闭合 assertion aliases，并在 commit +阶段安装到 runtime/parser。C installer 应选择一个完整 global RA；需要 numeric +naming 时，它显式选择 `named_ra R`。安装过程不依赖历史接口的兼容包装。 + +adapter 为满足 runtime theorem schema 可能使用 internal raw-equality theorem； +这不会扩大 public logical API。client-facing 推理仍通过 `r_entails`、`r_equiv` +和对应的 lowercase theorem handles。 + +## 10. 稳定 API 与实现私有 API + +稳定 client surface 由 public headers 中的 `PROOF extern` 声明组成。以下内容 +刻意保持私有： + +- RA representation normalization 和 constructor discrimination； +- invalid-source 的真空 update 辅助引理； +- assertion raw equality rewrite rules； +- option/product/gmap 的单向 normalization helpers； +- finite-map representation 与 support 实现细节； +- adapter 安装事务中的中间 theorem bundles。 + +对应 internal headers 仅供实现模块使用： + +```text +ra_internal.h +resource_prop_internal.h +product_resource_internal.h +prod_ra_internal.h +option_ra_internal.h +gmap_ra_internal.h +``` + +v2 不提供兼容层。下游代码应直接迁移到 `ra_updateP`、五参数 +`ra_local_update`、显式 `named_ra`、`drop`、完整 global `G` 和 `r_equiv` +public laws。 + +## 11. 回归与可信边界 + +每个理论模块在加载前后记录 axioms 数量，并验证公开定理： + +- theorem handle 非空； +- theorem hypotheses 为空； +- 加载模块不增加 axioms。 + +回归测试覆盖 RA 核心、构造子、gmap、auth、named RA、SL、C resource 与依赖 +边界。接口审计还应保证： + +- public headers 不重新导出 implementation-only raw equality； +- update API 只有 `ra_updateP` primitive 与 singleton `ra_update`； +- maximal 始终包含 source validity，并表达“compatible frame 必为 unit”； +- ownership validity/updateP 使用 `r_fact`，不混同 `r_pure`； +- C update 不能改变 physical projection； +- C resource 不隐式增加 naming layer； +- big-sep 仍是单一 `big_sep.{h,c}` 模块； +- theorem handles 使用 `lower_snake_case`，并仅保留嵌入 constant 原名中的 + mixed-case 片段（当前包括 `updateP`、`Tuint64`、`leftP`、`rightP`）。 diff --git a/docs/SL_PROOF_SPEC.md b/docs/SL_PROOF_SPEC.md index 1291f91cb7ba5e6ae46826b708df35c5937e8412..2e77c966c41563deae0cd91062576f6abaabb0ae 100644 --- a/docs/SL_PROOF_SPEC.md +++ b/docs/SL_PROOF_SPEC.md @@ -469,13 +469,15 @@ goal_hcon(G) = K fresh_hants_label(G,s) returns a label absent from Δ ``` -These functions are defined only for `SL_GOAL`; a null fresh-label prefix uses -`"H"`. +These functions are defined only for goals created by `sl_goal_new` under the +currently active SL-theory generation; a null fresh-label prefix uses `"H"`. -`Γ` and `Δ` are mutable vector handles. Callers must treat vectors -stored in a goal as immutable. Every SL tactic that changes either context -copies it first, and no implementation may retain a vector address or element -pointer across `vector_add` or `vector_erase`. +`Γ` remains a shared vector handle that callers must not mutate through a +goal, while the goal stores a private shallow snapshot of `Δ`. Accessing `Δ` +returns another shallow vector copy. Terms and label strings remain shared. +Every SL tactic that changes either context copies it first, and no +implementation may retain a vector address or element pointer across +`vector_add` or `vector_erase`. ## 6. Entering SL mode and equality @@ -840,18 +842,17 @@ For an equality, the replacement must be its left side and the current consequent its right side; callers use `sym_rule` before the tactic when the available equality has the opposite orientation. -For example, in +For example, given a closed representation theorem of the schematic form ```text -get_data_at_to_undef_data_at : - data_at p Tptr q ⊢SL undef_data_at p Tptr +CELL_VIEW : concrete_cell p q ⊢SL abstract_cell p ``` -the consequent match automatically infers `p` and `Tptr`. The variable `q` +the consequent match automatically infers `p`. The variable `q` occurs only in the left endpoint, so it is unconstrained and remains fresh in the new obligation. A caller that wants the existing term `q` there must first -specialize the theorem at `p`, `Tptr`, and `q`. Applying the resulting theorem -changes consequent `undef_data_at p Tptr` to `data_at p Tptr q` while leaving +specialize the theorem at `p` and `q`. Applying the resulting theorem changes +consequent `abstract_cell p` to `concrete_cell p q` while leaving the antecedents untouched. ### 8.2 Separating conjunction @@ -924,7 +925,11 @@ left to right, so `w₁` instantiates the outermost existential visible at the first step. `EXISTS_PULL_SLTAC` applies the trusted `**`/existential rewrite rules to the -consequent only. It does not rewrite any labeled antecedent. +consequent only. It uses one `PURE_REWRITE_CONV` containing exactly the active +left/right distribution theorems. Because the pure conversion has no HOL basic +rewrite net, it does not beta-reduce unrelated caller syntax. The conversion is +cached only for the current installed SL-theory generation. No labeled +antecedent is rewritten. ## 9. Conversion tactics diff --git a/printers.h b/printers.h new file mode 100644 index 0000000000000000000000000000000000000000..3ef74762d45c40e785424952d6165a495906d48a --- /dev/null +++ b/printers.h @@ -0,0 +1,51 @@ +/** + * @file printers.h + * @brief IDE value printers that do not select an assertion model. + * + * Pure proof theories should include this header when they only need C* LSP + * rendering. In particular, including it neither installs an SL theory nor + * registers anything with QCP. + */ +#pragma once + +#include "proof/proof_kernel.h" + +// PROOF static inline char *cst_string_of_int(const int x) { +// return cstr_int(x); +// } + +PROOF static inline char *cst_string_of_term(const term tm) { + if (IS_NULL(tm)) return ""; + return cstr_term(tm); +} + +PROOF static inline char *cst_string_of_thm(const thm th) { + if (IS_NULL(th)) return ""; + return cstr_thm(th); +} + +PROOF static inline char *cst_string_of_type(const type ty) { + if (IS_NULL(ty)) return ""; + return cstr_type(ty); +} + +PROOF static inline char *cst_string_of_indtype(const indtype idt) { + return cstr_indtype(idt); +} + +PROOF static inline char *cst_string_of_inddef(const inddef idf) { + return cstr_inddef(idf); +} + +PROOF static inline char *cst_string_of_term_list(const term_list terms) { + return cstr_term_list(terms); +} + +PROOF static inline char *cst_string_of_thm_list(const thm_list theorems) { + return cstr_thm_list(theorems); +} + +PROOF static inline char *cst_string_of_term_pair_list( + const term_pair_list pairs) { + return cstr_term_pair_list(pairs); +} diff --git a/proof.h b/proof.h index fd31f8b2663f74f705ea9196ceae7065306c1274..15f5d609ccb78d36718af9577dc6c146e1e0d423 100644 --- a/proof.h +++ b/proof.h @@ -5,18 +5,22 @@ * * ```text * proof_kernel - * | - * proof_user user-facing HOL utilities - * | - * proof_sl forward SL theorem construction - * | - * proof_backward validated goal trees and HOL tactics - * | | - * proof_backward_sl proof_symexec SL tactics / trusted QCP bridge + * └─ proof_user user-facing HOL utilities + * ├─ proof_sl forward SL theorem construction + * └─ proof_backward generic goal trees / HOL tactics + * + * proof_sl + proof_backward + * ├─ proof_backward_sl SL backward tactics + * ├─ proof_lithium extensible committed SL search + * └─ proof_symexec trusted QCP bridge * ``` * - * Except for the explicitly unsafe `CHEAT_TAC`, `proof_backward` and - * `proof_backward_sl` reconstruct theorems bottom-up through validators. + * `proof_backward` is independent of any object logic; both SL consumers + * explicitly depend on it and `proof_sl`. Except for the explicitly unsafe + * `CHEAT_TAC`, `proof_backward` and `proof_backward_sl` reconstruct theorems + * bottom-up through validators. `proof_lithium` adds only rule selection and + * committed goal scheduling on top of those validators; registered theorem + * rules do not enlarge the trust base. * `CHEAT_TAC` calls `new_axiom` for its goal. `proof_symexec` is also a * deliberate trust boundary: its documented QCP bridge and fact-purification * equations use private axioms. These APIs must be counted in the verification @@ -27,11 +31,20 @@ * `*_SLTAC` transform validated backward goals. The latter store validators * that reconstruct a theorem when their children are proved. * - * This umbrella inherits the canonical notation of `proof_kernel.h`, - * `proof_user.h`, and `proof_sl.h`. Backward-proof headers use Γ for the - * ordered labeled ordinary-assumption context, Δ for the ordered labeled - * spatial-antecedent context, and 𝒜 for the set of hypotheses of a HOL - * theorem. They do not redefine the underlying HOL or SL judgments. + * This umbrella inherits the canonical typing notation `t:τ` and theorem + * judgment `𝒜 ⊢ φ` of `proof_kernel.h`, plus `P ⊢SL Q`, `P ⇛ Q`, raw + * `P = Q`, and `P ** Q` from `proof_sl.h`. A C `thm` value is an opaque handle + * to `𝒜 ⊢ φ`, never φ itself. Backward-proof diagrams use Γ for the ordered + * labeled ordinary context and Δ for the ordered labeled spatial context; + * `|Γ|` denotes the corresponding set of ordinary HOL assumptions when a + * theorem-side condition is stated. + * + * Including this file installs the user-side parser/printer dialect and loads + * the generic proof implementation units shown above. It deliberately selects + * no assertion model: C programs normally obtain the default unit-ghost model + * from `veriftime.h`, while proof-only tests explicitly install an RA-backed + * scope such as the default unit-ghost C logic. Header inclusion transfers no + * ownership of HOL handles or runtime vector/string storage. * * The public headers are the per-function API reference. The companion * specifications explain the proof-state and validation semantics across @@ -45,9 +58,17 @@ #include "proof/proof_kernel.h" +/* Reinstall the C* proof dialect from the user-side library so parsing and + * printing do not depend on an OCaml bootstrap module. */ +#include "proof/syntax/base.h" +#require "proof/syntax/base.c" + #include "proof/proof_user.h" #require "proof/proof_user.c" +#include "proof/theory/data/list.h" +#require "proof/theory/data/list.c" + #include "proof/proof_sl.h" #require "proof/proof_sl.c" @@ -57,5 +78,8 @@ #include "proof/proof_backward_sl.h" #require "proof/proof_backward_sl.c" +#include "proof/proof_lithium.h" +#require "proof/proof_lithium.c" + #include "proof/proof_symexec.h" #require "proof/proof_symexec.c" diff --git a/proof_backward.c b/proof_backward.c index 2a32a525b04e78605f374fd702221ce7765b1420..81dea23f0cbcc90796a3438ca5ca94d68986e39d 100644 --- a/proof_backward.c +++ b/proof_backward.c @@ -1,5 +1,18 @@ #include "proof/proof_backward.h" +PROOF static thm prove_EXCLUDED_MIDDLE(void) { + thm result = get_theorem_by_name("EXCLUDED_MIDDLE"); + term expected = `!t : bool.t || ~t`; + ENSURE_COND(equals_term(concl(result), expected), + "HOL EXCLUDED_MIDDLE theorem has an unexpected conclusion"); + return result; +err: + ERR_FUN_PUTS("prove_EXCLUDED_MIDDLE", cstr_thm(result)); + return empty_theorem; +} + +PROOF static thm EXCLUDED_MIDDLE = prove_EXCLUDED_MIDDLE(); + PROOF static bool distinct_assumption_labels(const const_cstr_list lbs) { for (size_t i = 0; i < vector_size(lbs); ++i) { if (lbs[i] == NULL) return false; @@ -22,33 +35,20 @@ PROOF gnode_list gnode_list_from_array(size_t size, gnode* nodes) { return result; } +PROOF static const goal_kind general_goal_kind = {"general", NULL}; + PROOF goal general_goal_new(const labeled_term_list lasmps, const term ccl) { - goal g; - g.type = GENERAL_GOAL; - g.lasmps = lasmps; - g.ccl = ccl; - return g; + return (goal){lasmps, ccl, &general_goal_kind, NULL}; } -PROOF goal sl_goal_new(const labeled_term_list lasmps, const labeled_term_list lhants, - const term hcon) { - goal g; - g.type = SL_GOAL; - g.lasmps = lasmps; - g.lhants = lhants; - g.hcon = hcon; - return g; +PROOF bool goal_is_general(const goal g) { + return g.kind == &general_goal_kind; } PROOF goal goal_with_lasmps(const goal g, const labeled_term_list lasmps) { - switch (g.type) { - case GENERAL_GOAL: - return general_goal_new(lasmps, g.ccl); - case SL_GOAL: - return sl_goal_new(lasmps, g.lhants, g.hcon); - default: - return empty_goal; - } + goal result = g; + result.lasmps = lasmps; + return result; } PROOF labeled_term_list goal_lasmps(const goal g) { @@ -56,18 +56,7 @@ PROOF labeled_term_list goal_lasmps(const goal g) { } PROOF term goal_ccl(const goal g) { - switch (g.type) { - case GENERAL_GOAL: - return g.ccl; - case SL_GOAL: { - term_list hants = labeled_term_list_to_term_list(g.lhants); - term hant = list_mk_sl_sep(hants); - term ccl = mk_binop(sl_ent(), hant, g.hcon); - return ccl; - } - default: - return empty_term; - } + return g.ccl; } PROOF bool var_free_in_goal(const term v, const goal g) { @@ -128,7 +117,7 @@ PROOF void gnode_accept(const gnode gn, const thm th) { term ccl = goal_ccl(gn->g); term th_ccl = concl(th); ENSURE_COND(alpha_compare(th_ccl, ccl) == 0, - "Theorem conclusion does not match the goal"); + "Theorem conclusion does not match the goal modulo alpha"); /* Every theorem hypothesis must occur among the goal assumptions, modulo * alpha-equivalence. */ term_list th_hyps = hyp(th); @@ -182,57 +171,24 @@ PROOF static char* cstr_lasmps(const labeled_term_list lasmps) { return buf; } -PROOF static char* cstr_lhants(const labeled_term_list lhants) { - char* buf = BOLD("Antecedents:"); - if (vector_size(lhants) == 0) { - buf = gc_strcat(buf, GRAY(" (none)")); - } else { - for (size_t i = 0; i < vector_size(lhants); ++i) { - buf = gc_strcat(buf, GRAY("\n")); - labeled_term ltm = lhants[i]; - char* tm_str = string_of_term(ltm.tm); - if (ltm.lb) { - buf = gc_strcat(buf, GRAY(ltm.lb)); - buf = gc_strcat(buf, GRAY(": ")); - buf = gc_strcat(buf, YELLOW(tm_str)); - } else { - buf = gc_strcat(buf, YELLOW(tm_str)); - } - } - } - return buf; -} - PROOF char* cstr_goal(const goal g) { char* buf = NORMAL("\n--------------------------------\n"); char* lasmps_cstr = cstr_lasmps(g.lasmps); buf = gc_strcat(buf, lasmps_cstr); - switch (g.type) { - case GENERAL_GOAL: { - buf = gc_strcat(buf, NORMAL("\n--------------------------------\n")); - buf = gc_strcat(buf, BOLD("Conclusion:")); - buf = gc_strcat(buf, NORMAL("\n ")); - char* ccl_str = - string_of_term(g.ccl); // TODO: use HOL Light colored printing? - buf = gc_strcat(buf, YELLOW(ccl_str)); - buf = gc_strcat(buf, NORMAL("\n")); - return buf; - } - case SL_GOAL: { - buf = gc_strcat(buf, NORMAL("\n--------------------------------\n")); - char* lhants_cstr = cstr_lhants(g.lhants); - buf = gc_strcat(buf, lhants_cstr); - buf = gc_strcat(buf, NORMAL("\n================================\n")); - buf = gc_strcat(buf, BOLD("Consequent:")); - buf = gc_strcat(buf, NORMAL("\n ")); - char* hcon_str = string_of_term(g.hcon); - buf = gc_strcat(buf, YELLOW(hcon_str)); - buf = gc_strcat(buf, NORMAL("\n")); - return buf; - } - default: - return gc_sprintf("Unknown goal type"); + buf = gc_strcat(buf, NORMAL("\n--------------------------------\n")); + if (goal_is_general(g)) { + buf = gc_strcat(buf, BOLD("Conclusion:")); + buf = gc_strcat(buf, NORMAL("\n ")); + char* ccl_str = + string_of_term(g.ccl); // TODO: use HOL Light colored printing? + buf = gc_strcat(buf, YELLOW(ccl_str)); + buf = gc_strcat(buf, NORMAL("\n")); + return buf; + } + if (g.kind == NULL || g.kind->format_payload == NULL) { + return gc_strcat(buf, gc_sprintf("Invalid goal kind")); } + return gc_strcat(buf, g.kind->format_payload(g.payload)); } PROOF char* cstr_gnode(const gnode gn) { @@ -423,9 +379,12 @@ PROOF static thm neg_disch_tac_valid(thm* ths, gnode gn) { thm imp = disch_rule(ant, ths[0]); /* NOT_DEF: |- (~) = (\p. p ==> false). Applying both sides to ant and - * beta-reducing gives |- ~ant = (ant ==> false). */ + * contracting only the generated application on the equality's right side + * gives |- ~ant = (ant ==> false). Redexes already inside ant are retained. */ thm not_def = get_theorem_by_name("NOT_DEF"); - thm not_eq_imp = beta_rule(ap_thm_rule(not_def, ant)); + thm applied = ap_thm_rule(not_def, ant); + conv beta = get_conversion_by_name("BETA_CONV"); + thm not_eq_imp = conv_rule(rand_conv(beta), applied); return eq_mp_rule(sym_rule(not_eq_imp), imp); } @@ -812,7 +771,7 @@ PROOF gnode_list DISJ_CASES_TAC(const gnode gn, const thm th, const char* lb) { } PROOF gnode_list BOOL_CASES_TAC(const gnode gn, const term tm, const char* lb) { - thm tt = ispec_rule(tm, get_EXCLUDED_MIDDLE()); + thm tt = ispec_rule(tm, EXCLUDED_MIDDLE); return DISJ_CASES_TAC(gn, tt, lb); err: ERR_FUN_PUTS("BOOL_CASES_TAC", cstr_gnode(gn), cstr_term(tm), diff --git a/proof_backward.h b/proof_backward.h index 7969b91e66a4be7987064bc99727be60cb2c9c06..874639606c1970c186b1a08af4ed8995b7714253 100644 --- a/proof_backward.h +++ b/proof_backward.h @@ -21,9 +21,9 @@ * * An open leaf contains only its goal. Expanding it installs child nodes, a * validator, and a validator environment. A proved node stores a theorem that - * achieves its goal: the theorem conclusion is alpha-equivalent to the goal - * conclusion, and every theorem hypothesis has an alpha-equivalent proposition - * in the goal's ordinary assumption context. + * achieves its goal: theorem and goal conclusions are alpha-equivalent, and + * every theorem hypothesis has an alpha-equivalent + * proposition in the goal's ordinary assumption context. * * ## Goal-oriented proof process with explicit goal trees * @@ -46,22 +46,34 @@ * [backward-proof specification](docs/BACKWARD_PROOF_SPEC.md). * * This header inherits HOL judgments and ≡α from `proof_kernel.h` and - * `proof_user.h`, and SL connectives from `proof_sl.h`. Γ is the ordered list - * of labeled ordinary assumptions, 𝒜 is the set of hypotheses of a HOL theorem, - * and Δ is reserved for the spatial context in `proof_backward_sl.h`. Write - * `|Γ|` for the propositions in Γ, ignoring labels and duplicates, and - * `𝒜 ⊆α |Γ|` when each member of 𝒜 has an ≡α match in `|Γ|`. Consequently - * `[Γ ?⊢ p]` is a goal state, whereas `𝒜 ⊢ p` is a theorem judgment; labels - * belong only to Γ. + * `proof_user.h`; it has no dependency on a particular object logic. Γ is the + * ordered list of labeled ordinary assumptions and 𝒜 is the set of + * hypotheses of a HOL theorem. Write `|Γ|` for the propositions in Γ, ignoring + * labels and duplicates, and `𝒜 ⊆α |Γ|` when each member of 𝒜 has an ≡α + * match in `|Γ|`. Consequently `[Γ ?⊢ p]` is a goal state, whereas + * `𝒜 ⊢ p` is a theorem judgment; labels belong only to Γ. Object-logic + * layers such as `proof_backward_sl.h` may attach an immutable payload and a + * formatter through `goal_kind`, while every goal still caches its complete + * HOL conclusion. Beta-equivalent but non-alpha-equivalent conclusions are not + * interchangeable at the proof-tree boundary; a tactic that introduces a + * beta-redex must discharge it explicitly in its own validator. + * + * Node pointers, returned frontier vectors, validator environments allocated by + * library tactics, and rendered strings are prover/GC managed; callers do not + * free them. A returned `gnode` is a shared pointer into the proof tree, and a + * returned `gnode_list` is a GC-managed container of such pointers. Unless a + * tactic documents partial progress, failure is reported through the prover + * error channel and returns `empty_gnode`/`NULL`; a `void` closer leaves the + * node unsolved. These C sentinels are operational results, not HOL theorems. * * Authors: Jinkai Fan, Yiyuan Cao - * Last updated: 2026-07-19 + * Last updated: 2026-07-27 */ #pragma once -#include "proof/proof_sl.h" -#require "proof/proof_sl.c" +#include "proof/proof_user.h" +#require "proof/proof_user.c" /** * Construct a goal vector from the supplied goal values. @@ -87,7 +99,9 @@ * Nodes are visited in vector order and receive the same additional arguments. * The macro ignores tactic return values; use it only when the tactic mutates * each supplied node in place or when the new frontier will be recovered from - * the common proof tree. + * the common proof tree. `__gns` is evaluated repeatedly and therefore must be + * a stable side-effect-free vector expression. If a delegated tactic propagates + * an error, mutations already made to the visited prefix are not rolled back. */ #define APPLY_ALL_TAC(tactic, __gns, ...) \ do { \ @@ -99,43 +113,68 @@ /*----------------------------- Types -----------------------------*/ /** - * Discriminate the two goal representations. + * Render the object-logic-specific portion of an extended goal. * - * A general goal stores one HOL conclusion. An SL goal stores a labeled spatial - * antecedent context and one spatial consequent. + * The payload pointer is borrowed and kind-specific. Return a valid + * GC-managed C string; the caller concatenates it without copying or freeing + * it. A formatter must report its own errors and must not retain call-local + * pointers. */ -PROOF typedef enum { - GENERAL_GOAL, // A general goal. - SL_GOAL // A separation-logic goal, i.e., the conclusion term is a separation-logic entailment. -} goal_type; +PROOF typedef char* (*goal_payload_formatter)(const void* payload); /** - * Represent a general or separation-logic goal. + * Identify one extension of the base goal representation. * - * Both forms carry Γ in `lasmps`. `GENERAL_GOAL` uses `ccl`; `SL_GOAL` uses - * `lhants` for Δ and `hcon` for its spatial consequent. + * Extension layers keep one stable `goal_kind` object and use its address as + * the kind identity. `format_payload` renders only the extension-specific + * portion shown after the ordinary assumptions; it must tolerate every + * payload created for this kind. The kind object must outlive all of its + * goals, normally by having static storage duration. A payload must not cache + * or otherwise depend on the ordinary-assumption context Γ, because + * `goal_with_lasmps` reuses it when replacing Γ. + */ +PROOF typedef struct goal_kind { + /** Borrowed, stable diagnostic name for this goal kind. */ + const char* name; + /** Non-null renderer for this kind's immutable payload. */ + goal_payload_formatter format_payload; +} goal_kind; + +/** + * Represent a backward goal with an optional object-logic extension. + * + * Every goal stores Γ and its complete HOL conclusion. `kind` identifies the + * constructor that owns `payload`; an extension payload is immutable through + * this interface and must outlive all shallow copies of the goal. The general + * goal kind uses a null payload. */ PROOF typedef struct goal { - goal_type type; // The type of the goal. - labeled_term_list lasmps; // The list of labeled assumptions. - union { - term ccl; // The conclusion term (GENERAL_GOAL). - struct { - labeled_term_list lhants; // The labeled SL entailment antecedents (SL_GOAL). - term hcon; // The SL entailment consequent (SL_GOAL). - }; - }; + /** Borrowed ordered labeled ordinary-assumption context Γ. */ + labeled_term_list lasmps; // Ordered labeled ordinary assumptions Γ. + /** Shared, prover-managed handle to the complete HOL conclusion. */ + term ccl; // Complete cached HOL conclusion. + /** Borrowed pointer whose address is the stable kind identity. */ + const goal_kind* kind; // Stable kind identity. + /** Borrowed, kind-owned immutable extension data, possibly `NULL`. */ + const void* payload; // Kind-owned immutable extension data. } goal; +/** Shared pointer to a mutable proof-tree node; never owned by the caller. */ PROOF typedef struct goal_node* gnode; +/** Vector-backed ordered sequence of shallow-copied `goal` values. */ PROOF typedef goal* goal_list; +/** Vector-backed ordered sequence of shared `gnode` pointers. */ PROOF typedef gnode* gnode_list; /** * Reconstruct a parent theorem from theorems for its children. * - * The theorem list follows child order. The validator may inspect the parent - * node and its environment, and must return a theorem that achieves that node. + * The borrowed theorem vector follows child order and is valid for the call. + * The validator may inspect the parent node and its stored environment, and + * must return a theorem `𝒜 ⊢ φ` such that `φ ≡α goal_ccl(node->g)` and + * `𝒜 ⊆α |Γ|`. It returns a prover-managed theorem handle; on failure it must + * report a prover error and return `empty_theorem`. `gnode_accept` checks the + * stated conclusion/hypothesis obligations after the callback returns. */ PROOF typedef thm (*valid_fun)(thm_list, gnode); @@ -147,17 +186,24 @@ PROOF typedef thm (*valid_fun)(thm_list, gnode); * accepted an achieving theorem. */ PROOF typedef struct goal_node { + /** Shallow goal value represented by this node. */ goal g; // The goal to be proved at this node. + /** Accepted theorem handle, or `empty_theorem` while open. */ thm solved; // The theorem achieving the goal, empty if it hasn't been proved yet. + /** Shared child-node vector in tactic order; `NULL` before expansion. */ gnode_list children; // Child nodes in tactic-specified order; NULL before expansion. + /** Bottom-up validator, or `NULL` before expansion. */ valid_fun valid; // The validator function to combine subgoal theorems, NULL when no tactic is applied. + /** Borrowed/GC-managed validator environment, or `NULL`. */ void* env; // Captured validator environment; NULL before expansion. }* gnode; /*--------------------------- Constants ---------------------------*/ +/** All-zero invalid `goal` sentinel returned after construction errors. */ #define empty_goal ((goal){0}) +/** Null `gnode` sentinel returned after node/tactic errors. */ #define empty_gnode NULL /** @@ -181,33 +227,35 @@ PROOF goal_list goal_list_from_array(size_t size, goal* goals); */ PROOF gnode_list gnode_list_from_array(size_t size, gnode* nodes); -/*---------------------------- Kernel -----------------------------*/ +/*----------------------- Construction and access -----------------------*/ /* goal */ /** * Construct a general goal from Γ and a HOL conclusion. * - * The returned `GENERAL_GOAL` stores the supplied handles unchanged. This - * constructor performs no copying, type checking, or normalization. + * The result stores the supplied handles unchanged, uses the private general + * kind, and has no extension payload. This constructor performs no copying, + * type checking, or normalization. The caller must supply valid handles, a + * Boolean `ccl`, Boolean propositions in Γ, and label strings that outlive the + * goal; after construction the shared Γ container must be treated as immutable. */ PROOF goal general_goal_new(const labeled_term_list lasmps, const term ccl); /** - * Construct an SL goal from Γ, Δ, and a spatial consequent. + * Test whether a goal was created by `general_goal_new`. * - * The returned `SL_GOAL` stores the supplied handles unchanged. This - * constructor performs no copying, type checking, or normalization. + * Kind identity is compared by address. The payload and conclusion are not + * inspected. */ -PROOF goal sl_goal_new(const labeled_term_list lasmps, const labeled_term_list lhants, - const term hcon); +PROOF bool goal_is_general(const goal g); /** - * Replace Γ while preserving the other fields of a goal. + * Replace Γ with a shallow copy of a goal. * - * The result retains `g.type` and its general conclusion or spatial fields, and - * stores `lasmps` as its exact Γ handle. An invalid discriminant returns - * `empty_goal`. + * The result retains the exact cached conclusion, kind, and immutable payload + * pointer, and stores `lasmps` as its exact Γ handle. No object-logic + * constructor or validation callback is rerun. */ PROOF goal goal_with_lasmps(const goal g, const labeled_term_list lasmps); @@ -220,11 +268,10 @@ PROOF goal goal_with_lasmps(const goal g, const labeled_term_list lasmps); PROOF labeled_term_list goal_lasmps(const goal g); /** - * Reconstruct the HOL conclusion represented by a goal. + * Return the complete cached HOL conclusion represented by a goal. * - * A general goal returns `g.ccl`. For an SL goal, right-fold Δ with `**` - * (empty Δ becomes `emp`) and return that assertion entailing `g.hcon`. - * An invalid discriminant returns `empty_term`. + * The term handle is returned unchanged. Object-logic payloads are never + * consulted or reconstructed by the base layer. */ PROOF term goal_ccl(const goal g); @@ -233,7 +280,7 @@ PROOF term goal_ccl(const goal g); * * Test `v` for free occurrence first in every ordinary assumption in Γ, then * in `goal_ccl(g)`. Return at the first match. `v` need not itself be a - * variable; an invalid goal fails as `goal_ccl` does. + * variable. The cached conclusion must be a valid term. */ PROOF bool var_free_in_goal(const term v, const goal g); @@ -242,7 +289,7 @@ PROOF bool var_free_in_goal(const term v, const goal g); * * Apply HOL `variant` to `v` against all terms in Γ followed by * `goal_ccl(g)`, preserving its type and using its name as the base. Fail when - * `v` is not a variable or the goal is invalid. + * `v` is not a variable or the cached conclusion is not a valid term. */ PROOF term fresh_var_in_goal(const term v, const goal g); @@ -255,7 +302,7 @@ PROOF term fresh_var_in_goal(const term v, const goal g); */ PROOF const char* fresh_asmps_label(const goal g, const char* prefix); -/* gnode */ +/*---------------------- Proof-tree validation ----------------------*/ /** * Create an open proof-tree leaf for a goal. @@ -277,8 +324,10 @@ PROOF gnode gnode_new(const goal g); * The child list may be empty and is not shape-checked, but an unsolved * zero-child expansion cannot be validated: `gnode_prove` rejects it as an * open leaf. The returned vector aliases `gn->children` and must not be resized - * or reordered. Re-expansion discards the stored solved theorem and replaces - * the previous expansion. + * or reordered. `env` is stored without copying or a destructor and must have + * static/GC storage or otherwise outlive later validation. Re-expansion detaches + * the stored solved theorem and previous expansion from the parent; it does not + * destroy old nodes still reachable through external shared handles. */ PROOF gnode_list gnode_expand(const gnode gn, const goal_list child_gs, const valid_fun valid, void* env); @@ -286,15 +335,16 @@ PROOF gnode_list gnode_expand(const gnode gn, const goal_list child_gs, const va /** * Close a node with a theorem that achieves its goal. * - * Accept exactly when `concl(th) ≡α goal_ccl(gn->g)` and every member of - * `𝒜 = hyp(th)` has an ≡α match among Γ's propositions. On success store `th`, - * thereby closing the whole subtree. On either mismatch preserve the node and - * set the prover error. This is the + * Accept exactly when `concl(th) ≡α goal_ccl(gn->g)`, and every member of + * `𝒜 = hyp(th)` has an ≡α match among Γ's propositions. No beta conversion is + * attempted. A caller that deliberately constructs a beta-redex must first + * prove and apply the required local conversion. On either mismatch preserve + * the node and set the prover error. This is the * unique proof-tree boundary that checks conclusion alignment and theorem * hypothesis containment; callers do not repeat either scan. * - * The theorem need only satisfy `concl(th) ≡α goal_ccl(gn->g)`; - * `gnode_prove` performs exact user-visible binder alignment at the root. + * The accepted theorem may retain alpha-renamed binders; `gnode_prove` + * performs exact user-visible binder alignment at the root. */ PROOF void gnode_accept(const gnode gn, const thm th); @@ -306,7 +356,8 @@ PROOF void gnode_accept(const gnode gn, const thm th); * left-to-right. The proof tree is unchanged. * * A solved node contributes no leaves even if it retains children from an - * earlier expansion. + * earlier expansion. The result is a fresh GC-managed vector of shared node + * pointers; callers may resize that container without changing the tree. */ PROOF gnode_list gnode_leaves(const gnode gn); @@ -316,12 +367,11 @@ PROOF gnode_list gnode_leaves(const gnode gn); * Render a goal as an ANSI-colored string. * * Render ordinary assumptions Γ under `Assumptions:`. A general goal renders - * its proposition under `Conclusion:`. An SL goal instead renders its labeled - * SL antecedents Δ under `Antecedents:` and its right-hand assertion under - * `Consequent:`. The labels are the actual tactic-visible labels stored in the - * goal; printing does not rename either context. Preserve order and return a - * GC-managed ANSI-colored string; invalid discriminants render - * `Unknown goal type`. + * its cached proposition under `Conclusion:`. Any extension kind delegates + * the remaining display to `kind->format_payload(payload)`. Labels are the + * actual tactic-visible labels stored in the goal; printing does not rename + * the ordinary context. Preserve order and return a GC-managed ANSI-colored + * string. A missing kind or formatter renders an invalid-kind diagnostic. * * This function renders only one goal and does not inspect a proof tree. */ @@ -355,7 +405,7 @@ PROOF char* cstr_gnode_list(const gnode_list gns); * * Construct `general_goal_new(NULL, ccl)` and wrap it with `gnode_new`; the * result is an open leaf. The function performs no type checking or - * normalization of `ccl`. + * normalization of `ccl`; the caller must supply a valid Boolean term handle. */ PROOF gnode gnode_new_with_ccl(const term ccl); @@ -369,8 +419,12 @@ PROOF gnode gnode_new_with_ccl(const term ccl); * * At the requested root, HOL-checked alpha conversion aligns bound-variable * names so the returned conclusion exactly matches the stored goal syntax. - * Missing validators, unacceptable validator results, unavailable hypotheses, - * and conclusion mismatches are errors. + * Missing + * validators, unacceptable validator results, unavailable hypotheses, and + * conclusion mismatches report a prover error and return `empty_theorem`. + * Successful validation caches accepted theorem handles in every traversed + * parent node. On failure, already validated descendants and any tactic prefix + * remain installed; theorem handles are prover managed. */ PROOF thm gnode_prove(const gnode gn); @@ -378,26 +432,45 @@ PROOF thm gnode_prove(const gnode gn); * Select ordinary assumptions by label. * * Extract the Γ entry for each requested label in requested order and return - * only its proposition. Request order and duplicates are preserved. + * only its proposition in a fresh GC-managed vector. Request order and + * duplicates are preserved and term handles are shared. * - * Every requested label must be non-null and present in Γ; otherwise selection - * fails as `labeled_term_list_extract` does. + * Every requested label and every stored label in Γ must be a valid non-null + * C string. Each requested label must be present; otherwise selection reports + * a prover error and returns `NULL` as `labeled_term_list_extract` does. The + * all-label precondition is required by that function's source-wide failure + * diagnostic. */ PROOF term_list gnode_get_asmps(const gnode gn, const const_cstr_list lbs); /*------------------------- Basic Tactics -------------------------*/ +/** + * Tactic-family convention for extended goals. + * + * Tactics that only replace the ordinary context Γ use `goal_with_lasmps` and + * preserve `kind`, the immutable payload, and the cached complete conclusion. + * `ASSERT_TAC` preserves the extension on its main child but creates a general + * goal for the asserted proposition. Conclusion-transforming tactics + * (`GEN_TAC`, `SPEC_TAC`, `EXISTS_TAC`, `DISCH_TAC`, `UNDISCH_TAC`, + * `UNDISCH_ALL_TAC`, `CONJ_TAC`, `DISJ1_TAC`, `DISJ2_TAC`, `MATCH_MP_TAC`, + * `EQ_TAC`, and a non-closing `CONV_TAC`) construct general children and do not + * copy an extension payload. Derived tactics inherit the behavior of the + * primitive step that creates each child. + */ + /** * Close a goal with a supplied theorem. * * ```text - * 𝒜 ⊢ t' t' ≡α t 𝒜 ⊆α Γ + * 𝒜 ⊢ t' t' ≡α t 𝒜 ⊆α |Γ| * -------------------------------- ACCEPT_TAC * [Γ ?⊢ t] → [] * ``` - * Here `𝒜 ⊆α Γ` means that every theorem hypothesis has an alpha-equivalent + * Here `𝒜 ⊆α |Γ|` means that every theorem hypothesis has an alpha-equivalent * proposition in Γ. The tactic delegates both checks to `gnode_accept`; on - * failure it leaves the node open. + * failure it reports a prover error and leaves the node open. Its `void` C + * return is not a theorem or Boolean result. */ PROOF void ACCEPT_TAC(const gnode gn, const thm th); @@ -525,6 +598,10 @@ PROOF gnode_list ASMP_DESTRUCT_TAC(const gnode gn, const char* lb, const char* s * * A delegated decomposition or fresh-name failure is propagated. Any successful * prefix already installed in the proof tree remains in place. + * Every structured assumption visited by this tactic must have a valid non-null + * label. Atomic unlabeled assumptions are skipped, but attempting to destruct a + * structured unlabeled entry reaches label lookup with `NULL`; this is currently + * a host-language precondition rather than a recoverable prover mismatch. */ PROOF gnode_list AUTO_ASMP_DESTRUCT_TAC(const gnode gn); @@ -647,7 +724,9 @@ PROOF gnode_list CASES_TAC(const gnode gn, const term tm, const char* lb); * after introducing exactly its constructor variables and induction-hypothesis * premises. Fail if `var` is not a variable, has no registered induction * theorem, is neither free in the goal nor a leading universal binder, or the - * registered theorem has an unexpected induction-rule shape. + * registered theorem has an unexpected induction-rule shape. Every reverted + * `Dᵢ` must have a valid non-null label; induction currently inherits this + * host-language precondition from `REVERT_TAC`. */ PROOF gnode_list INDUCT_TAC(const gnode gn, const term var); @@ -779,9 +858,12 @@ PROOF gnode DISJ2_TAC(const gnode gn); * ```text * [Γ ?⊢ t'] → [Γ ?⊢ ∃z₁ … zₚ. s'] * ``` - * Match `t` from `∀x₁ … xₙ. s ⇒ t` against the current conclusion; `s'` - * receives the same instantiation, and only unmatched quantified variables - * become existential subgoal binders. + * Strip `∀X. s ⇒ t` and first define + * `Y = [x ∈ X | x ∈ FV(s) ∧ x ∉ FV(t)]`, preserving quantifier order. Match + * `t` against the current conclusion, apply that instantiation to + * `∃Y. s`, and use the resulting term as the child conclusion. Thus the + * existential set is determined syntactically before matching; it is not the + * set of variables left unmatched by the matcher. * * Fail if stripping leading universal quantifiers from `th` does not expose an * implication, or if its consequent cannot match the current conclusion. The @@ -868,7 +950,9 @@ PROOF gnode AUTO_INTROS_TAC(const gnode gn); * `pₙ ⇒ … ⇒ p₁ ⇒ q`. * * `v` must be a variable. It remains free; use `SPEC_TAC` afterwards when it - * should also be generalized. + * should also be generalized. Every selected Γ entry must have a valid + * non-null label; passing an affected unlabeled assumption to the delegated + * label lookup is currently a host-language precondition, not a safe mismatch. */ PROOF gnode REVERT_TAC(const gnode gn, const term v); @@ -911,23 +995,34 @@ PROOF gnode CONV_WITH_ASMP_TAC(const gnode gn, const conv_builder builder, * Close a goal by false elimination. * * ```text - * 𝒜 ⊢ ⊥ 𝒜 ⊆α Γ + * 𝒜 ⊢ ⊥ 𝒜 ⊆α |Γ| * ------------------- CONTR_TAC * [Γ ?⊢ t] → [] * ``` * Derive the current Boolean conclusion from `fth`, then pass the result to * `gnode_accept`. Fail if `fth` does not conclude false or any hypothesis in 𝒜 - * lacks an alpha-equivalent proposition in Γ. + * lacks an alpha-equivalent proposition in `|Γ|`. On failure report a prover + * error and leave the node unsolved; the `void` return is not a theorem. */ PROOF void CONTR_TAC(const gnode gn, const thm fth); /*----------------------- Pattern Matching ------------------------*/ +/** + * Outermost constructor recognized by `parse_pattern`. + * + * `PT_NONE` is a leaf, `PT_AND`/`PT_OR` are `&`/`|`, `PT_EX` is `?`, + * `PT_SEP` is `*`, and `PT_FACT` is an SL fact selector `[label]`. + */ PROOF typedef enum { PT_NONE, PT_AND, PT_OR, PT_EX, PT_SEP, PT_FACT } parsed_type; +/** Parsed outer pattern and its GC-managed operand strings. */ PROOF typedef struct { + /** Recognized outer constructor. */ parsed_type pt; + /** Left operand, binder name, leaf text, or fact label. */ char* left; + /** Right operand for binary forms; otherwise `NULL`. */ char* right; } parsed_pattern; @@ -948,6 +1043,11 @@ PROOF typedef struct { * Return the outer operator and trimmed operands. A leaf returns `PT_NONE` with * its text in `left`; `[L]` returns `PT_FACT` with `L` in `left`. Fail on an * empty pattern, unbalanced or nested brackets, unbalanced parentheses, an - * empty fact label, or a binary operator with an empty operand. + * empty fact label, or a binary operator with an empty operand. Returned + * strings are GC-managed and remain valid beyond the call; on error the + * function reports a prover error and returns a zero-initialized record. + * `parse_pattern(NULL)` is also a successful leaf represented by that same + * zero record, so callers distinguish it from malformed non-null input through + * the prover error status rather than record fields alone. */ PROOF parsed_pattern parse_pattern(const char* str); diff --git a/proof_backward_sl.c b/proof_backward_sl.c index 8c2eeffd889270e0d5d7582ebc765d14706c123f..8ea49d661903b5d04cb6c5b4b299d1caf1f88bc8 100644 --- a/proof_backward_sl.c +++ b/proof_backward_sl.c @@ -10,6 +10,82 @@ PROOF static bool distinct_labels(const const_cstr_list lbs) { return true; } +PROOF typedef struct { + labeled_term_list lhants; + term hcon; + size_t theory_generation; +} sl_goal_payload; + +PROOF static char* cstr_lhants(const labeled_term_list lhants) { + char* buf = BOLD("Antecedents:"); + if (vector_size(lhants) == 0) { + buf = gc_strcat(buf, GRAY(" (none)")); + } else { + for (size_t i = 0; i < vector_size(lhants); ++i) { + buf = gc_strcat(buf, GRAY("\n")); + labeled_term ltm = lhants[i]; + char* tm_str = string_of_term(ltm.tm); + if (ltm.lb) { + buf = gc_strcat(buf, GRAY(ltm.lb)); + buf = gc_strcat(buf, GRAY(": ")); + buf = gc_strcat(buf, YELLOW(tm_str)); + } else { + buf = gc_strcat(buf, YELLOW(tm_str)); + } + } + } + return buf; +} + +PROOF static char* cstr_sl_goal_payload(const void* raw_payload) { + if (raw_payload == NULL) return gc_sprintf("Invalid SL goal payload"); + const sl_goal_payload* payload = (const sl_goal_payload*)raw_payload; + char* buf = cstr_lhants(payload->lhants); + buf = gc_strcat(buf, NORMAL("\n================================\n")); + buf = gc_strcat(buf, BOLD("Consequent:")); + buf = gc_strcat(buf, NORMAL("\n ")); + buf = gc_strcat(buf, YELLOW(string_of_term(payload->hcon))); + return gc_strcat(buf, NORMAL("\n")); +} + +PROOF static const goal_kind sl_goal_kind = {"sl", cstr_sl_goal_payload}; + +PROOF bool goal_is_sl(const goal g) { + return g.kind == &sl_goal_kind; +} + +PROOF goal sl_goal_new(const labeled_term_list lasmps, + const labeled_term_list lhants, const term hcon) { + bool hcon_is_prop = is_sl_prop(hcon); + ENSURE_COND(hcon_is_prop, + "SL consequent(`%s`) does not have the active assertion type", + string_of_term(hcon)); + for (size_t i = 0; i < vector_size(lhants); ++i) { + bool hant_is_prop = is_sl_prop(lhants[i].tm); + ENSURE_COND( + hant_is_prop, + "SL antecedent %d (`%s`) does not have the active assertion type", + (int)i, string_of_term(lhants[i].tm)); + } + + labeled_term_list payload_lhants = + (labeled_term_list)vector_copy(lhants); + term_list hants = labeled_term_list_to_term_list(payload_lhants); + term hant = list_mk_sl_sep(hants); + term ccl = mk_sl_ent(hant, hcon); + size_t generation = sl_theory_generation(); + + sl_goal_payload* payload = GC_MALLOC(sizeof(sl_goal_payload)); + payload->lhants = payload_lhants; + payload->hcon = hcon; + payload->theory_generation = generation; + return (goal){lasmps, ccl, &sl_goal_kind, payload}; +err: + ERR_FUN_PUTS("sl_goal_new", cstr_labeled_term_list(lasmps), + cstr_labeled_term_list(lhants), cstr_term(hcon)); + return empty_goal; +} + PROOF typedef struct { labeled_term_list lasmps; labeled_term_list lhants; @@ -17,8 +93,14 @@ PROOF typedef struct { } sl_goal_view; PROOF static sl_goal_view dest_sl_goal(const goal g) { - ENSURE_COND(g.type == SL_GOAL, "Goal is not a SL goal"); - return (sl_goal_view){g.lasmps, g.lhants, g.hcon}; + ENSURE_COND(goal_is_sl(g), "Goal is not an SL goal"); + ENSURE_COND(g.payload != NULL, "SL goal has no payload"); + const sl_goal_payload* payload = (const sl_goal_payload*)g.payload; + size_t generation = sl_theory_generation(); + ENSURE_COND(payload->theory_generation == generation, + "SL goal belongs to inactive theory generation %zu, current is %zu", + payload->theory_generation, generation); + return (sl_goal_view){g.lasmps, payload->lhants, payload->hcon}; err: ERR_FUN_PUTS("dest_sl_goal", cstr_goal(g)); return (sl_goal_view){NULL, NULL, empty_term}; @@ -26,7 +108,7 @@ err: PROOF labeled_term_list goal_lhants(const goal g) { sl_goal_view view = dest_sl_goal(g); - return view.lhants; + return (labeled_term_list)vector_copy(view.lhants); err: ERR_FUN_PUTS("goal_lhants", cstr_goal(g)); return NULL; @@ -71,18 +153,18 @@ err: return NULL; } -PROOF static thm eq_sltac_valid(thm* ths, const gnode gn) { - thm th = antisym_slrule(ths[0], ths[1]); +PROOF static thm equiv_sltac_valid(thm* ths, const gnode gn) { + thm th = equiv_slrule(ths[0], ths[1]); return th; } -PROOF gnode_list EQ_SLTAC(const gnode gn, const char* lb1, const char* lb2) { - labeled_term_list lasmps = goal_lasmps(gn->g); - term ccl = goal_ccl(gn->g); - - dest_binop_results res = dest_sl_eq(ccl); - term hp1 = res.tm1; - term hp2 = res.tm2; +PROOF static gnode_list expand_equiv_sltac(const gnode gn, + const labeled_term_list lasmps, + const term hp1, const term hp2, + const char* lb1, + const char* lb2) { + ENSURE_COND(lb1 != NULL && lb2 != NULL, + "Equivalence branch labels must be non-null"); labeled_term lhant1 = {hp1, GC_STRDUP(lb1)}; labeled_term_list lhants1 = LABELED_TERM_LIST(lhant1); @@ -91,12 +173,306 @@ PROOF gnode_list EQ_SLTAC(const gnode gn, const char* lb1, const char* lb2) { labeled_term_list lhants2 = LABELED_TERM_LIST(lhant2); goal new_g2 = sl_goal_new(lasmps, lhants2, hp1); - return gnode_expand(gn, LIST_GOAL(new_g1, new_g2), eq_sltac_valid, NULL); + return gnode_expand(gn, LIST_GOAL(new_g1, new_g2), equiv_sltac_valid, NULL); +err: + ERR_FUN_PUTS("expand_equiv_sltac", cstr_gnode(gn), cstr_term(hp1), + cstr_term(hp2), cstr_string(lb1), cstr_string(lb2)); + return NULL; +} + +PROOF gnode_list EQUIV_SLTAC(const gnode gn, const char* lb1, + const char* lb2) { + labeled_term_list lasmps = goal_lasmps(gn->g); + term ccl = goal_ccl(gn->g); + + dest_binop_results res = dest_sl_equiv(ccl); + term hp1 = res.tm1; + term hp2 = res.tm2; + + return expand_equiv_sltac(gn, lasmps, hp1, hp2, lb1, lb2); +err: + ERR_FUN_PUTS("EQUIV_SLTAC", cstr_gnode(gn), cstr_string(lb1), + cstr_string(lb2)); + return NULL; +} + +PROOF gnode_list EQ_SLTAC(const gnode gn, const char* lb1, const char* lb2) { + /* Mutual validity-aware entailment does not imply raw HOL equality. This + * compatibility tactic is available only when the explicitly installed + * logical-equivalence operator is itself assertion equality. */ + ENSURE_COND( + equals_term(sl_equiv(), sl_eq()), + "EQ_SLTAC is unavailable: the active SL theory distinguishes logical " + "equivalence from raw HOL equality; use EQUIV_SLTAC"); + + labeled_term_list lasmps = goal_lasmps(gn->g); + term ccl = goal_ccl(gn->g); + dest_binop_results res = dest_sl_eq(ccl); + + return expand_equiv_sltac(gn, lasmps, res.tm1, res.tm2, lb1, lb2); err: ERR_FUN_PUTS("EQ_SLTAC", cstr_gnode(gn), cstr_string(lb1), cstr_string(lb2)); return NULL; } +PROOF static thm bupd_intro_sltac_valid(thm* ths, const gnode gn) { + term parent_ccl = goal_ccl(gn->g); + dest_binop_results parent = dest_sl_ent(parent_ccl); + term post = dest_sl_bupd(parent.tm2); + thm introduced = bupd_intro_slrule(post); + thm result = trans_slrule(ths[0], introduced); + return result; +err: + ERR_FUN_PUTS("bupd_intro_sltac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode BUPD_INTRO_SLTAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + sl_goal_view view = dest_sl_goal(gn->g); + term post = dest_sl_bupd(view.hcon); + goal child = sl_goal_new(view.lasmps, view.lhants, post); + gnode_list expanded = + gnode_expand(gn, LIST_GOAL(child), bupd_intro_sltac_valid, NULL); + return expanded[0]; +err: + ERR_FUN_PUTS("BUPD_INTRO_SLTAC", cstr_gnode(gn)); + return empty_gnode; +} + +PROOF static thm bupd_mono_sltac_valid(thm* ths, const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + thm result = bupd_mono_slrule(ths[0]); + return result; +err: + ERR_FUN_PUTS("bupd_mono_sltac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode BUPD_MONO_SLTAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + sl_goal_view view = dest_sl_goal(gn->g); + ENSURE_COND(vector_size(view.lhants) == 1, + "Basic-update monotonicity requires one exact antecedent"); + term source = dest_sl_bupd(view.lhants[0].tm); + term target = dest_sl_bupd(view.hcon); + + labeled_term_list child_lhants = + (labeled_term_list)vector_copy(view.lhants); + child_lhants[0].tm = source; + goal child = sl_goal_new(view.lasmps, child_lhants, target); + gnode_list expanded = + gnode_expand(gn, LIST_GOAL(child), bupd_mono_sltac_valid, NULL); + return expanded[0]; +err: + ERR_FUN_PUTS("BUPD_MONO_SLTAC", cstr_gnode(gn)); + return empty_gnode; +} + +PROOF void BUPD_IDEM_SLTAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + sl_goal_view view = dest_sl_goal(gn->g); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results entailment = dest_sl_ent(goal_conclusion); + term nested = dest_sl_bupd(entailment.tm1); + term source = dest_sl_bupd(nested); + term target = dest_sl_bupd(view.hcon); + int endpoint_order = alpha_compare(source, target); + ENSURE_COND(endpoint_order == 0, + "Goal is not exact basic-update idempotence"); + thm proof = bupd_idem_slrule(source); + ACCEPT_TAC(gn, proof); + return; +err: + ERR_FUN_PUTS("BUPD_IDEM_SLTAC", cstr_gnode(gn)); + return; +} + +PROOF void BUPD_FRAME_SLTAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + sl_goal_view view = dest_sl_goal(gn->g); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results entailment = dest_sl_ent(goal_conclusion); + dest_binop_results source_sep = dest_sl_sep(entailment.tm1); + term source = dest_sl_bupd(source_sep.tm1); + term target = dest_sl_bupd(view.hcon); + dest_binop_results target_sep = dest_sl_sep(target); + int payload_order = alpha_compare(source, target_sep.tm1); + int frame_order = alpha_compare(source_sep.tm2, target_sep.tm2); + ENSURE_COND(payload_order == 0 && frame_order == 0, + "Goal is not exact framed basic update"); + thm proof = bupd_frame_slrule(source, source_sep.tm2); + ACCEPT_TAC(gn, proof); + return; +err: + ERR_FUN_PUTS("BUPD_FRAME_SLTAC", cstr_gnode(gn)); + return; +} + +PROOF void VIEWSHIFT_REFL_TAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + ENSURE_COND(goal_is_general(gn->g), + "View-shift reflexivity requires a general goal"); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results endpoints = dest_sl_viewshift(goal_conclusion); + int endpoint_order = alpha_compare(endpoints.tm1, endpoints.tm2); + ENSURE_COND(endpoint_order == 0, + "View-shift endpoints are not alpha-equivalent"); + thm proof = viewshift_refl_slrule(endpoints.tm1); + ACCEPT_TAC(gn, proof); + return; +err: + ERR_FUN_PUTS("VIEWSHIFT_REFL_TAC", cstr_gnode(gn)); + return; +} + +PROOF static thm viewshift_trans_tac_valid(thm* ths, const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + thm result = viewshift_trans_slrule(ths[0], ths[1]); + return result; +err: + ERR_FUN_PUTS("viewshift_trans_tac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode_list VIEWSHIFT_TRANS_TAC(const gnode gn, const term mid) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + ENSURE_COND(goal_is_general(gn->g), + "View-shift transitivity requires a general goal"); + bool mid_is_prop = is_sl_prop(mid); + ENSURE_COND(mid_is_prop, + "Intermediate term(`%s`) is not an active SL assertion", + string_of_term(mid)); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results endpoints = dest_sl_viewshift(goal_conclusion); + labeled_term_list lasmps = goal_lasmps(gn->g); + term first_ccl = mk_sl_viewshift(endpoints.tm1, mid); + goal first = general_goal_new(lasmps, first_ccl); + term second_ccl = mk_sl_viewshift(mid, endpoints.tm2); + goal second = general_goal_new(lasmps, second_ccl); + gnode_list expanded = gnode_expand( + gn, LIST_GOAL(first, second), viewshift_trans_tac_valid, NULL); + return expanded; +err: + ERR_FUN_PUTS("VIEWSHIFT_TRANS_TAC", cstr_gnode(gn), cstr_term(mid)); + return NULL; +} + +PROOF static thm viewshift_frame_tac_valid(thm* ths, const gnode gn) { + term parent_ccl = goal_ccl(gn->g); + dest_binop_results parent = dest_sl_viewshift(parent_ccl); + dest_binop_results source = dest_sl_sep(parent.tm1); + thm result = viewshift_frame_slrule(ths[0], source.tm2); + return result; +err: + ERR_FUN_PUTS("viewshift_frame_tac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode VIEWSHIFT_FRAME_TAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + ENSURE_COND(goal_is_general(gn->g), + "View-shift framing requires a general goal"); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results endpoints = dest_sl_viewshift(goal_conclusion); + dest_binop_results source = dest_sl_sep(endpoints.tm1); + dest_binop_results target = dest_sl_sep(endpoints.tm2); + int frame_order = alpha_compare(source.tm2, target.tm2); + ENSURE_COND(frame_order == 0, + "View-shift goal has no exact shared right frame"); + + labeled_term_list lasmps = goal_lasmps(gn->g); + term child_ccl = mk_sl_viewshift(source.tm1, target.tm1); + goal child = general_goal_new(lasmps, child_ccl); + gnode_list expanded = + gnode_expand(gn, LIST_GOAL(child), viewshift_frame_tac_valid, NULL); + return expanded[0]; +err: + ERR_FUN_PUTS("VIEWSHIFT_FRAME_TAC", cstr_gnode(gn)); + return empty_gnode; +} + +PROOF static thm viewshift_sep_tac_valid(thm* ths, const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + thm result = viewshift_sep_slrule(ths[0], ths[1]); + return result; +err: + ERR_FUN_PUTS("viewshift_sep_tac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode_list VIEWSHIFT_SEP_TAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + ENSURE_COND(goal_is_general(gn->g), + "View-shift separation requires a general goal"); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results endpoints = dest_sl_viewshift(goal_conclusion); + dest_binop_results source = dest_sl_sep(endpoints.tm1); + dest_binop_results target = dest_sl_sep(endpoints.tm2); + labeled_term_list lasmps = goal_lasmps(gn->g); + term first_ccl = mk_sl_viewshift(source.tm1, target.tm1); + goal first = general_goal_new(lasmps, first_ccl); + term second_ccl = mk_sl_viewshift(source.tm2, target.tm2); + goal second = general_goal_new(lasmps, second_ccl); + gnode_list expanded = gnode_expand( + gn, LIST_GOAL(first, second), viewshift_sep_tac_valid, NULL); + return expanded; +err: + ERR_FUN_PUTS("VIEWSHIFT_SEP_TAC", cstr_gnode(gn)); + return NULL; +} + +PROOF static thm viewshift_exists_tac_valid(thm* ths, const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + thm result = viewshift_exists_slrule(ths[0]); + return result; +err: + ERR_FUN_PUTS("viewshift_exists_tac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode VIEWSHIFT_EXISTS_TAC(const gnode gn) { + ENSURE_COND(sl_update_theory_is_installed(), + "No update theory is installed for the active SL theory"); + ENSURE_COND(goal_is_general(gn->g), + "Existential view shift requires a general goal"); + term goal_conclusion = goal_ccl(gn->g); + dest_binop_results endpoints = dest_sl_viewshift(goal_conclusion); + dest_binder_results source = dest_sl_exists(endpoints.tm1); + dest_binder_results target = dest_sl_exists(endpoints.tm2); + type source_type = type_of(source.v); + type target_type = type_of(target.v); + bool witness_types_equal = equals_type(source_type, target_type); + ENSURE_COND(witness_types_equal, + "View-shift existential witness types differ"); + + term witness = fresh_var_in_goal(source.v, gn->g); + term source_body = subst_one(witness, source.v, source.tm); + term target_body = subst_one(witness, target.v, target.tm); + term pointwise_body = mk_sl_viewshift(source_body, target_body); + term pointwise = list_mk_forall(TERM_LIST(witness), pointwise_body); + labeled_term_list lasmps = goal_lasmps(gn->g); + goal child = general_goal_new(lasmps, pointwise); + gnode_list expanded = + gnode_expand(gn, LIST_GOAL(child), viewshift_exists_tac_valid, NULL); + return expanded[0]; +err: + ERR_FUN_PUTS("VIEWSHIFT_EXISTS_TAC", cstr_gnode(gn)); + return empty_gnode; +} + /* * Labeled SL antecedent tactics * ---------------------------- @@ -202,7 +578,7 @@ PROOF static thm hant_disj_sltac_valid(thm* ths, gnode gn) { thm endpoint2 = acu_slrule(current2, framed2); thm parent_endpoint = acu_slrule(hant, framed_disj); thm res_ent = list_match_mp_rule( - sl_or_elim_frame(), + sl_or_elim_frame, THM_LIST(endpoint1, endpoint2, parent_endpoint, ths[0], ths[1])); return res_ent; } @@ -786,7 +1162,7 @@ PROOF static thm hant_conv_sltac_valid(thm* ths, gnode gn) { term new_hant = dest_sl_eq(eq_tm).tm2; term current_hant = dest_sl_ent(concl(res_th)).tm1; thm lift = sep_lift_slrule(current_hant, new_hant); - res_th = list_match_mp_rule(sl_ent_subst_frame(), + res_th = list_match_mp_rule(sl_ent_subst_frame, THM_LIST(eqs[i], lift, res_th)); } labeled_term_list lhants = goal_lhants(gn->g); @@ -859,7 +1235,7 @@ PROOF static thm sep_sltac_valid(thm* ths, gnode gn) { thm hcon_eq = acu_slrule(hcon, mk_sl_sep(child1.tm2, child2.tm2)); thm res_ent = list_match_mp_rule( - sl_sep_combine(), THM_LIST(hant_eq, hcon_eq, ths[0], ths[1])); + sl_sep_combine, THM_LIST(hant_eq, hcon_eq, ths[0], ths[1])); return res_ent; } @@ -884,13 +1260,23 @@ PROOF static thm hcon_apply_sltac_valid(thm* ths, gnode gn) { PROOF gnode HCON_APPLY_SLTAC(const gnode gn, const thm relation) { sl_goal_view view = dest_sl_goal(gn->g); sl_apply_match_env match = sl_apply_match_env_new(view, relation); + ENSURE_OK("Could not initialize consequent theorem matching"); term template_hcon = dest_sl_ent(concl(match.template_relation)).tm2; + term_list patterns = strip_sl_resources(template_hcon); + term_list candidates = strip_sl_resources(view.hcon); + ENSURE_COND(vector_size(patterns) == vector_size(candidates), + "The theorem consequent and current consequent have different " + "resource multiplicities"); ENSURE_COND(sl_apply_match_greedy( - &match, strip_sl_resources(template_hcon), - strip_sl_resources(view.hcon), true, NULL), + &match, patterns, candidates, true, NULL), "The theorem consequent does not match the current consequent"); thm consequent_ent = sl_apply_finish_match(&match); + ENSURE_COND(!IS_NULL(consequent_ent), + "Could not specialize the consequent theorem"); consequent_ent = rehcon_slrule(consequent_ent, view.hcon); + ENSURE_COND(!IS_NULL(consequent_ent), + "The specialized theorem consequent is not ACU-equivalent to " + "the current consequent"); term replacement = dest_sl_ent(concl(consequent_ent)).tm1; goal new_g = sl_goal_new(view.lasmps, view.lhants, replacement); @@ -902,6 +1288,38 @@ err: return empty_gnode; } +PROOF bool HCON_APPLY_SLTAC_APPLICABLE(const gnode gn, + const thm relation) { + ENSURE_COND(!proof_is_in_try(), + "HCON_APPLY_SLTAC_APPLICABLE cannot run inside proof_try"); + ENSURE_COND(gn != NULL && goal_is_sl(gn->g), + "Consequent applicability requires an SL goal"); + + gnode probe = gnode_new(gn->g); + proof_try_begin(); + gnode child = HCON_APPLY_SLTAC(probe, relation); + bool failed = NOT_OK || child == NULL; + if (failed) SET_OK(); + proof_try_end(); + if (failed) { + proof_clear_errors(); + return false; + } + + hcon_apply_sltac_env* env = + (hcon_apply_sltac_env*)probe->env; + ENSURE_COND(env != NULL && !IS_NULL(env->relation), + "Consequent probe did not retain its specialized relation"); + term_list assumptions = + labeled_term_list_to_term_list(goal_lasmps(gn->g)); + return term_list_is_subset(hyp(env->relation), assumptions); +err: + ERR_FUN_PUTS("HCON_APPLY_SLTAC_APPLICABLE", + gn == NULL ? GC_STRDUP("") : cstr_gnode(gn), + cstr_thm(relation)); + return false; +} + PROOF gnode_list SEP_SLTAC(const gnode gn, const const_cstr_list lbs) { sl_goal_view view = dest_sl_goal(gn->g); labeled_term_list lasmps = view.lasmps; @@ -1091,21 +1509,31 @@ err: return empty_gnode; } -PROOF static conv get_exists_pull_conv() { - static bool initialized = false; +/* PURE_REWRITE_CONV uses only the supplied distribution laws. In particular, + * it does not include HOL's basic beta rewrite, so caller-owned redexes outside + * those laws' left-hand sides are retained. Rebuild the remote conversion when + * the active assertion theory changes: its theorem handles belong to that + * theory generation. */ +PROOF static conv get_exists_pull_conv(void) { + static size_t generation = 0; static conv value; - if (!initialized) { - thm left = sl_sep_exists_left(); - thm right = sl_sep_exists_right(); - value = pure_rewrite_conv(THM_LIST(left, right)); - initialized = true; + size_t current_generation = sl_theory_generation(); + if (IS_NULL(value) || generation != current_generation) { + value = pure_rewrite_conv( + THM_LIST(sl_sep_exists_left(), sl_sep_exists_right())); + generation = current_generation; } return value; +err: + ERR_FUN_PUTS("get_exists_pull_conv"); + return empty_conversion; } PROOF gnode EXISTS_PULL_SLTAC(const gnode gn) { - gnode new_gn = HCON_CONV_SLTAC(gn, get_exists_pull_conv()); - return new_gn; + return HCON_CONV_SLTAC(gn, get_exists_pull_conv()); +err: + ERR_FUN_PUTS("EXISTS_PULL_SLTAC", cstr_gnode(gn)); + return empty_gnode; } PROOF typedef struct { @@ -1122,7 +1550,7 @@ PROOF static thm conv_sltac_valid(thm* ths, gnode gn) { ? refl_rule(parent_h) : alpha_rule(parent_h, child_h); thm res_ent = list_match_mp_rule( - sl_ent_restate(), THM_LIST(h_eq, env->eq, ths[0])); + sl_ent_restate, THM_LIST(h_eq, env->eq, ths[0])); res_ent = rehant_slrule(res_ent, parent_h); res_ent = rehcon_slrule(res_ent, view.hcon); return res_ent; @@ -1265,7 +1693,7 @@ PROOF static thm frame_sltac_valid(thm* ths, gnode gn) { thm hant_eq = acu_slrule(hant, mk_sl_sep(frame, child.tm1)); thm hcon_eq = acu_slrule(hcon, mk_sl_sep(frame, child.tm2)); thm res_ent = list_match_mp_rule( - sl_frame_restate(), THM_LIST(hant_eq, hcon_eq, ths[0])); + sl_frame_restate, THM_LIST(hant_eq, hcon_eq, ths[0])); return res_ent; } @@ -1409,7 +1837,7 @@ PROOF static thm clean_sltac_valid(thm* ths, gnode gn) { thm hant_eq = acu_slrule(hant, current.tm1); thm hcon_eq = acu_slrule(hcon, current.tm2); thm res_ent = list_match_mp_rule( - sl_ent_restate(), THM_LIST(hant_eq, hcon_eq, ths[0])); + sl_ent_restate, THM_LIST(hant_eq, hcon_eq, ths[0])); return res_ent; } diff --git a/proof_backward_sl.h b/proof_backward_sl.h index 2aeace7dfea0b714531d7c7693183b028308e592..8a86f4d86e4696080b56a82f34c7362e1b56c514 100644 --- a/proof_backward_sl.h +++ b/proof_backward_sl.h @@ -1,7 +1,7 @@ /** * Backward tactics for separation-logic entailments. * - * An `SL_GOAL` is displayed as + * An SL goal is displayed as * * ```text * [Γ; Δ ?⊢SL K] @@ -29,32 +29,63 @@ * tactic transition `G → [G₁, …, Gₙ]` describes the top-down proof-state * change and return order. Its soundness is a bottom-up derivation: the * validator maps child theorems T₁, …, Tₙ to a theorem achieving G. + * Returned nodes/frontier vectors and SL payload snapshots are prover/GC + * managed and share their HOL term handles. C failure sentinels are + * `empty_gnode` or `NULL`; they are not logical conclusions. * * Author: Jinkai Fan, Yiyuan Cao - * Last updated: 2026-07-19 + * Last updated: 2026-07-27 */ #pragma once +#include "proof/proof_sl.h" +#require "proof/proof_sl.c" #include "proof/proof_backward.h" #require "proof/proof_backward.c" -/*---------------------------- Goal access ----------------------------*/ +/*----------------------- Goal construction and access -----------------------*/ /** - * Return the ordered labeled spatial context of an `SL_GOAL`. + * Test whether a goal was created by `sl_goal_new`. * - * Return Δ by reference, preserving labels, order, and duplicates. Fail and - * return `NULL` when `g.type != SL_GOAL`; callers must not mutate the stored - * vector. + * Kind identity is compared by address. This predicate does not inspect the + * payload or require its recorded SL theory generation to remain active; use + * the accessors below when reading SL-specific fields. + */ +PROOF bool goal_is_sl(const goal g); + +/** + * Construct an SL goal from Γ, Δ, and a spatial consequent. + * + * Require every member of Δ and the consequent to have the active theory's + * `sl_prop()` type. Right-fold Δ with `**` (empty Δ becomes `emp`) and cache + * the complete HOL entailment to the consequent. The private immutable payload + * records a shallow vector snapshot of Δ, the consequent, and the active + * theory generation. Terms, labels, Γ, and the consequent remain shared. Every + * label pointer must remain valid for the goal lifetime; SL tactic clients + * should use non-null labels because label-directed operations and diagnostic + * rendering require them. On a type or construction error, report a prover + * error and return `empty_goal`. + */ +PROOF goal sl_goal_new(const labeled_term_list lasmps, + const labeled_term_list lhants, const term hcon); + +/** + * Return the ordered labeled spatial context of an SL goal. + * + * Return a shallow vector copy of Δ, preserving labels, order, and duplicates. + * Terms and label strings remain shared. Fail and return `NULL` when `g` is + * not an SL goal or its recorded theory generation is no longer active. */ PROOF labeled_term_list goal_lhants(const goal g); /** - * Return the spatial consequent of an `SL_GOAL`. + * Return the spatial consequent of an SL goal. * - * Return `g.hcon` unchanged. Fail and return `empty_term` when - * `g.type != SL_GOAL`. + * Return the private payload's consequent unchanged. Fail and return + * `empty_term` when `g` is not an SL goal or its recorded theory generation is + * no longer active. */ PROOF term goal_hcon(const goal g); @@ -63,7 +94,7 @@ PROOF term goal_hcon(const goal g); * * Return a `variant_label` absent from Δ, using `"H"` when `prefix == NULL`. * Preserve the context and fail as `goal_lhants` does when `g` is not an - * `SL_GOAL`. + * SL goal. The returned label string is GC-managed. */ PROOF const char* fresh_hants_label(const goal g, const char* prefix); @@ -93,19 +124,155 @@ PROOF const char* fresh_hants_label(const goal g, const char* prefix); PROOF gnode_list SL_MODE(const gnode gn, const char* pattern); /** - * Reduce equality between SL assertions to two entailment goals. + * Reduce logical equivalence between SL assertions to two entailment goals. * * ```text - * [Γ ?⊢ (H =ₕ K)] → [Γ; LH:H ?⊢SL K], [Γ; LK:K ?⊢SL H] + * [Γ ?⊢ (H ≃SL K)] → [Γ; LH:H ?⊢SL K], [Γ; LK:K ?⊢SL H] * ``` - * Children are returned in the displayed order. The validator applies SL - * antisymmetry to their theorems in that order. Both labels must be valid - * non-null C strings; this is a caller precondition. Fail if the conclusion is - * not equality at `hprop`. The labels may coincide because the branches are - * independent. + * Children are returned in the displayed order. The validator applies the + * active theory's logical-equivalence introduction theorem. Both labels must + * be valid non-null C strings; this is a caller precondition. Fail if the + * conclusion is not logical equivalence at the active assertion type. The + * labels may coincide because the branches are independent. + */ +PROOF gnode_list EQUIV_SLTAC(const gnode gn, const char* lb1, + const char* lb2); + +/** + * Compatibility variant of `EQUIV_SLTAC` for raw assertion equality. + * + * This tactic is sound only when the explicitly installed logical-equivalence + * operator is raw HOL equality. Otherwise it fails and directs callers to + * `EQUIV_SLTAC`; mutual validity-aware + * entailment is not sufficient to prove equality outside the valid domain. */ PROOF gnode_list EQ_SLTAC(const gnode gn, const char* lb1, const char* lb2); +/*---------------- Optional basic updates and view shifts ----------------*/ + +/** + * Introduce a basic update on an SL consequent. + * + * ```text + * [Γ; Δ ?⊢SL bupd Q] → [Γ; Δ ?⊢SL Q] + * ``` + * + * This tactic exposes exactly one outer `bupd`; it never unfolds the modality + * or searches for a resource update. Require an installed update theory, an + * SL goal, and a consequent with outer form `bupd Q`. Return the single child; + * on failure report a prover error and return `empty_gnode`. The validator + * preserves the parent HOL hypotheses by composing the child entailment with + * `∅ ⊢ (Q ⊢SL bupd Q)`. + */ +PROOF gnode BUPD_INTRO_SLTAC(const gnode gn); + +/** + * Reduce exact basic-update monotonicity to its underlying entailment. + * + * ```text + * [Γ; bupd P ?⊢SL bupd Q] → [Γ; P ?⊢SL Q] + * ``` + * + * Require an installed update theory, a singleton spatial antecedent, and an + * outer `bupd` on both endpoints. Return the single child and preserve Γ; on + * any shape/type failure report a prover error and return `empty_gnode`. The + * validator maps `ℬ ⊢ (P ⊢SL Q)` to + * `ℬ ⊢ (bupd P ⊢SL bupd Q)` without adding hypotheses. + */ +PROOF gnode BUPD_MONO_SLTAC(const gnode gn); + +/** + * Close the exact SL goal `bupd (bupd P) ⊢SL bupd P`. + * + * Require an installed update theory and alpha-equivalent occurrences of `P` + * at the two endpoints. On success install the closed primitive instance and + * return normally. On a non-SL goal, malformed `bupd` nesting, endpoint + * mismatch, or acceptance error, report a prover error and leave the node + * unsolved; this `void` function has no logical return value. + */ +PROOF void BUPD_IDEM_SLTAC(const gnode gn); + +/** + * Close the exact SL goal `bupd P ** F ⊢SL bupd (P ** F)`. + * + * Both outer `**` structure and the right frame are explicit; payload and + * frame matching is modulo alpha-equivalence, with no AC search. Require an + * installed update theory. A shape/matching/acceptance error is reported and + * leaves the node unsolved; the `void` C return is not a HOL proposition. + */ +PROOF void BUPD_FRAME_SLTAC(const gnode gn); + +/** + * Close a general goal whose conclusion is the exact view shift `P ⇛ P`. + * + * Require an installed update theory, a general rather than SL goal, and + * alpha-equivalent endpoints. On success accept `∅ ⊢ (P ⇛ P)`; otherwise + * report a prover error and leave the node unsolved. The `void` return carries + * no theorem object. + */ +PROOF void VIEWSHIFT_REFL_TAC(const gnode gn); + +/** + * Split `P ⇛ Q` at an explicit intermediate assertion `M`. + * + * ```text + * [Γ ?⊢ P ⇛ Q] → [Γ ?⊢ P ⇛ M], [Γ ?⊢ M ⇛ Q] + * ``` + * + * Require an installed update theory, a general view-shift goal, and + * `M:sl_prop()`. Return children in the displayed order; validation composes + * their theorem handles by view-shift transitivity and unions their HOL + * hypotheses. On error return `NULL` and do not create children. + */ +PROOF gnode_list VIEWSHIFT_TRANS_TAC(const gnode gn, const term mid); + +/** + * Remove an identical explicit right frame. + * + * ```text + * [Γ ?⊢ P ** F ⇛ Q ** F] → [Γ ?⊢ P ⇛ Q] + * ``` + * + * Matching is syntactic modulo alpha-equivalence; no AC frame search occurs. + * Require an installed update theory and a general goal with explicit `**` at + * both endpoints. Return the single child, or `empty_gnode` on a shape/frame + * mismatch. Validation preserves the child's HOL hypotheses. + */ +PROOF gnode VIEWSHIFT_FRAME_TAC(const gnode gn); + +/** + * Split a view shift over two explicit separating-conjunction nodes. + * + * ```text + * [Γ ?⊢ P1 ** P2 ⇛ Q1 ** Q2] + * → [Γ ?⊢ P1 ⇛ Q1], [Γ ?⊢ P2 ⇛ Q2] + * ``` + * + * Require an installed update theory and a general goal whose two endpoints + * both have explicit outer `**`. Return left-component then right-component + * child; the validator combines their hypotheses by HOL inference. Return + * `NULL` on malformed input. + */ +PROOF gnode_list VIEWSHIFT_SEP_TAC(const gnode gn); + +/** + * Reduce an existential-to-existential view shift to one pointwise theorem. + * + * ```text + * [Γ ?⊢ (∃SL x. P(x)) ⇛ (∃SL x. Q(x))] + * → [Γ ?⊢ ∀z. P(z) ⇛ Q(z)] + * ``` + * + * Both endpoints must be active SL existentials with the same witness type. + * The tactic chooses `z` fresh for the complete parent goal and substitutes + * it capture-avoidantly into both bodies, so different source/target binder + * names are handled correctly. The validator applies + * `viewshift_exists_slrule` to the proved pointwise theorem and preserves its + * hypotheses. Require an installed update theory and a general goal; on any + * shape/type/freshness error return `empty_gnode`. + */ +PROOF gnode VIEWSHIFT_EXISTS_TAC(const gnode gn); + /*----------------------- Antecedent transformations ------------------*/ /** @@ -115,7 +282,7 @@ PROOF gnode_list EQ_SLTAC(const gnode gn, const char* lb1, const char* lb2); * [Γ; Δ₀,L:H,Δ₁ ?⊢SL K] → [Γ; Δ₀,L':H,Δ₁ ?⊢SL K] * ``` * - * The assertion and index are preserved. The goal must be an `SL_GOAL`, `L` + * The assertion and index are preserved. The goal must be an SL goal, `L` * must exist, and the non-null label `L'` must be absent from Δ. */ PROOF gnode HANT_RENAME_SLTAC(const gnode gn, const char* lb, const char* new_lb); @@ -212,7 +379,7 @@ PROOF gnode_list HANT_DESTRUCT_SLTAC(const gnode gn, const char* lb, const char* * existentials until no such constructor remains; apply the scan independently * to every disjunction branch. Return open leaves depth-first, left-to-right. * - * Return `NULL` when the input is not an `SL_GOAL` or a delegated + * Return `NULL` when the input is not an SL goal or a delegated * decomposition fails. A successfully installed prefix is not rolled back. */ PROOF gnode_list AUTO_HANT_DESTRUCT_SLTAC(const gnode gn); @@ -221,8 +388,9 @@ PROOF gnode_list AUTO_HANT_DESTRUCT_SLTAC(const gnode gn); * Apply an equality or entailment theorem to selected spatial antecedents. * * Open the outer universal quantifiers of `relation` with fresh matching - * variables. After `undisch_all_rule`, convert an equality at `hprop` with - * `eq2ent`; otherwise require an entailment `L ⊢SL R`. Only the opened + * variables. After `undisch_all_rule`, convert an equality at the active + * assertion type with `eq2ent`; otherwise require an entailment `L ⊢SL R`. + * Only the opened * variables are instantiable; every other theorem or goal free term variable * is rigid. HOL type variables may be instantiated by matching. * @@ -336,6 +504,21 @@ PROOF gnode HANT_CONV_SLTAC(const gnode gn, const conv cv, const const_cstr_list */ PROOF gnode HCON_APPLY_SLTAC(const gnode gn, const thm relation); +/** + * Test whether `HCON_APPLY_SLTAC(gn, relation)` has an exact consequent match + * whose specialized ordinary theorem assumptions are already present in + * `gn`'s ordinary context. + * + * The test expands only a private probe node and never mutates `gn`. Ordinary + * matching failure returns false without leaving prover error status set. + * Unlike `HCON_APPLY_SLTAC` itself, this preflight includes the theorem- + * assumption check normally deferred to bottom-up `gnode_accept`; it is meant + * for committed-choice interpreters that must distinguish an inapplicable + * guarded rule before selecting it. It must not be called inside `proof_try`. + */ +PROOF bool HCON_APPLY_SLTAC_APPLICABLE(const gnode gn, + const thm relation); + /** * Split a separating consequent and partition antecedents linearly. * @@ -356,7 +539,7 @@ PROOF gnode_list SEP_SLTAC(const gnode gn, const const_cstr_list lbs); * Select the left branch of an additive-disjunction consequent. * * ```text - * [Γ; Δ ?⊢SL K₁ || K₂] → [Γ; Δ ?⊢SL K₁] + * [Γ; Δ ?⊢SL (K₁ || K₂)] → [Γ; Δ ?⊢SL K₁] * ``` * * The validator applies left disjunction introduction. Both contexts are @@ -368,7 +551,7 @@ PROOF gnode DISJ1_SLTAC(const gnode gn); * Select the right branch of an additive-disjunction consequent. * * ```text - * [Γ; Δ ?⊢SL K₁ || K₂] → [Γ; Δ ?⊢SL K₂] + * [Γ; Δ ?⊢SL (K₁ || K₂)] → [Γ; Δ ?⊢SL K₂] * ``` * * The validator applies right disjunction introduction. Both contexts are @@ -391,7 +574,7 @@ PROOF gnode DISJ2_SLTAC(const gnode gn); * introduced antecedent; `NULL` requests a fresh label and no decomposition. * * The validator applies `intro_wand_slrule` and restores the parent's exact - * antecedent modulo ≡ACU. Fail if the goal is not an `SL_GOAL`, the consequent + * antecedent modulo ≡ACU. Fail if the goal is not an SL goal, the consequent * is not an outermost magic wand, the leaf label conflicts in Δ, or pattern * decomposition fails. A successfully installed introduction child is not * rolled back when a later decomposition step fails. @@ -424,10 +607,14 @@ PROOF gnode LIST_EXISTS_SLTAC(const gnode gn, const term_list wits); /** * Pull consequent existentials outward through separating conjunction. * - * Rewrite only the consequent with the registered left/right `**`-existential - * equations until movable existentials are outermost. Do not rewrite Γ or Δ. - * Return the converted child and fail if the goal is not an `SL_GOAL` or a - * required conversion cannot be constructed or validated. + * Rewrite only the consequent until every existential movable through `**` is + * outermost. A single `PURE_REWRITE_CONV` uses only the active left/right + * existential-distribution laws; HOL's basic rewrite net, including its beta + * rewrite, is not present. Consequently caller-owned beta-redexes that do not + * match those laws are retained. The remote conversion is reused within one + * installed SL-theory generation and rebuilt after the generation changes. + * Do not rewrite Γ or Δ. Fail if the goal is not an SL goal or the conversion + * result cannot be validated. */ PROOF gnode EXISTS_PULL_SLTAC(const gnode gn); @@ -540,7 +727,7 @@ PROOF gnode INTRO_FACT_SLTAC(const gnode gn, const const_cstr_list lbs); * * `R` is the separating conjunction of the remaining consequent assertions; * it is `emp` when none remain. Preserve left-to-right order and duplicates. - * Fail unless the input is an `SL_GOAL` or a validator construction fails. + * Fail unless the input is an SL goal or a validator construction fails. */ PROOF gnode_list PURE_SLTAC(const gnode gn); @@ -550,7 +737,7 @@ PROOF gnode_list PURE_SLTAC(const gnode gn); * Normalize `emp` and `fact(T)` recursively in every labeled antecedent and * in the consequent. Remove antecedents whose normalized form is `emp`; retain * the labels and order of all others. Return the converted child. Fail if the - * input is not an `SL_GOAL` or a normalization theorem cannot be validated. + * input is not an SL goal or a normalization theorem cannot be validated. */ PROOF gnode CLEAN_SLTAC(const gnode gn); @@ -567,7 +754,7 @@ PROOF gnode CLEAN_SLTAC(const gnode gn); * returns the cleaned open descendant, even if no more complete antecedent can * be framed. * - * Return `empty_gnode` when the input is not an `SL_GOAL` or framing, + * Return `empty_gnode` when the input is not an SL goal or framing, * cleaning, or closing fails. A successfully installed prefix is not rolled * back. */ @@ -579,7 +766,7 @@ PROOF gnode AUTO_FRAME_SLTAC(const gnode gn); * Select all top-level `fact(p)` antecedents in Δ from left to right and call * `INTRO_FACT_SLTAC`; leave every non-fact antecedent in relative order. If * there are no facts, install and return an identity child. Fail only when the - * input is not an `SL_GOAL` or the delegated transformation fails. + * input is not an SL goal or the delegated transformation fails. */ PROOF gnode AUTO_INTRO_FACT_SLTAC(const gnode gn); diff --git a/proof_kernel.h b/proof_kernel.h index 5b90c880433eec60dd218d16671619120dd47e1e..b52fd9b73cf1ad276cdaff4e419d086a92e68a75 100644 --- a/proof_kernel.h +++ b/proof_kernel.h @@ -5,12 +5,15 @@ * A dependent header may extend it, but must not give these symbols another * meaning. * - * - t, u, v, p, q range over HOL terms, and α, β over HOL - * types. A HOL Boolean term is still a term; letters p, q merely - * emphasize that role. - * - 𝒜 and ℬ range over finite HOL hypothesis sets. 𝒜 ⊢ p denotes a HOL - * theorem with hypothesis set 𝒜 and conclusion p. ∅ is the empty hypothesis - * set and ∪ is set union. + * - `t:τ` means the intrinsically typed HOL term `t` satisfies + * `type_of(t) = τ`. Letters `t`, `u`, `v`, `p`, and `q` range over HOL + * terms, and `α`, `β`, and `τ` over HOL types. A Boolean term is still a + * term; `p` and `q` merely emphasize type `bool`. + * - `𝒜 ⊢ φ` is a HOL theorem whose finite hypothesis set is 𝒜 and whose + * Boolean conclusion is φ. `∅` is the empty hypothesis set and `∪` is set + * union. A C value of type `thm` is only an opaque handle to such a theorem; + * it is not itself the Boolean φ and a C function returning `thm` does not + * return a C truth value. * - t ≡α u means alpha-equivalence. Exact representation identity is stated * explicitly as `equals_term(t,u)`; object-level HOL equality remains a * term in the logic and is printed with `=`. @@ -25,56 +28,113 @@ * element types are C ABI preconditions: violating them is undefined behavior, * not a recoverable prover error. Opaque handles are likewise assumed valid * unless a function explicitly checks them. + * + * HOL handles and pointer/vector/string results created by the proof runtime + * are prover/GC managed: callers copy handles freely but never `free` them. + * A fresh vector owns only a new mutable container; its elements are shallow + * copies, and resizing may relocate the container. Unless an API explicitly + * accepts `NULL`, a successful empty vector is a non-null size-zero vector and + * `NULL` denotes failure or absence. Borrowed vectors must not be resized or + * mutated. String-vector constructors copy pointers rather than characters, so + * caller-provided strings must outlive every use of the resulting vector. */ #pragma once #cst_include "cstar.h" +/** C null-pointer sentinel used by proof-library pointer APIs. */ #define NULL ((void*)0) +/** Mark a declaration or definition for C* proof-time execution. */ #define PROOF [[cst::proof]] +/** Opaque, prover-managed handle to a HOL term `t` with some type `τ`. */ PROOF typedef struct hol_term term; +/** Opaque, prover-managed handle to a HOL theorem `𝒜 ⊢ φ`. */ PROOF typedef struct hol_theorem thm; +/** Opaque, prover-managed handle to a HOL type `τ`. */ PROOF typedef struct hol_type type; +/** Opaque handle to a conversion mapping `t` to a theorem `𝒜 ⊢ t = u`. */ PROOF typedef struct hol_conversion conv; +/** Opaque pair record with shared term fields `.fst` and `.snd`. */ PROOF typedef struct hol_term_pair term_pair; +/** Opaque pair record with shared theorem fields `.fst` and `.snd`. */ PROOF typedef struct hol_thm_pair thm_pair; +/** Opaque pair record with shared type fields `.fst` and `.snd`. */ PROOF typedef struct hol_type_pair type_pair; +/** Opaque HOL type-and-term substitution returned by matching APIs. */ PROOF typedef struct hol_instantiation instantiation; +/** Opaque constant descriptor with borrowed fields `.name` and `.type`. */ +PROOF typedef struct hol_const hol_const; +/** Datatype-definition result with theorem fields `.ind` and `.rec`. */ PROOF typedef struct new_datatype_definition_results indtype; +/** Inductive-definition result with theorem fields `.def`, `.ind`, `.cases`. */ PROOF typedef struct new_inductive_definition_results inddef; /* HOL client result records are defined by cstar.h at C compilation time. * These matching opaque typedefs make their names available to the C* frontend; * member accesses are preserved for the generated C compiler to type-check. */ +/** Result of decomposing an applied type: constructor `.s`, argument vector `.tys`. */ PROOF typedef struct dest_app_type_results dest_app_type_results; +/** Lambda result with binder `.v` and body `.tm`. */ PROOF typedef struct dest_abs_results dest_abs_results; +/** Generic binder result with variable `.v` and body `.tm`. */ PROOF typedef struct dest_binder_results dest_binder_results; +/** Generic binary result with left `.tm1` and right `.tm2`. */ PROOF typedef struct dest_binop_results dest_binop_results; +/** Combination result with operator `.tm1` and operand `.tm2`. */ PROOF typedef struct dest_comb_results dest_comb_results; +/** Conjunction result with left/right conjuncts `.tm1`/`.tm2`. */ PROOF typedef struct dest_conj_results dest_conj_results; +/** Constant result with borrowed name `.s` and instantiated type `.ty`. */ +PROOF typedef struct dest_const_results dest_const_results; +/** Disjunction result with alternatives `.tm1` and `.tm2`. */ PROOF typedef struct dest_disj_results dest_disj_results; +/** Equality result with left/right operands `.tm1`/`.tm2`. */ +PROOF typedef struct dest_eq_results dest_eq_results; +/** Existential result with binder `.v` and body `.tm`. */ PROOF typedef struct dest_exists_results dest_exists_results; +/** Universal result with binder `.v` and body `.tm`. */ PROOF typedef struct dest_forall_results dest_forall_results; +/** Boolean-equivalence result with sides `.tm1` and `.tm2`. */ PROOF typedef struct dest_iff_results dest_iff_results; +/** Implication result with antecedent `.tm1` and consequent `.tm2`. */ PROOF typedef struct dest_imp_results dest_imp_results; +/** Universal-prefix result with fresh binder vector `.vs` and body `.tm`. */ PROOF typedef struct strip_forall_results strip_forall_results; +/** Vector-backed ordered sequence of shared term handles. */ PROOF typedef term* term_list; +/** Vector-backed ordered sequence of shared theorem handles. */ PROOF typedef thm* thm_list; +/** Vector-backed ordered sequence of shared type handles. */ PROOF typedef type* type_list; +/** Vector-backed ordered sequence of term-pair values. */ PROOF typedef term_pair* term_pair_list; +/** Vector-backed ordered sequence of theorem-pair values. */ PROOF typedef thm_pair* thm_pair_list; +/** Vector-backed ordered sequence of type-pair values. */ PROOF typedef type_pair* type_pair_list; +/** Vector-backed ordered sequence of HOL constant descriptors. */ +PROOF typedef hol_const* hol_const_list; -/* Build a HOL conversion from an ordered theorem context. */ +/** + * Callback that builds a HOL conversion from an ordered theorem context. + * + * The input vector container and theorem handles are borrowed for the call. + * The callback returns a prover-managed conversion handle; failure is reported + * through the prover error channel and normally yields an empty conversion. + */ PROOF typedef conv (*conv_builder)(thm_list); +/** Mutable C-string pointer; ownership is specified by each producing API. */ PROOF typedef char* cstr; +/** Read-only C-string pointer; lifetime is specified by each producing API. */ PROOF typedef const char* const_cstr; +/** Vector-backed ordered sequence of mutable string pointers. */ PROOF typedef cstr* cstr_list; +/** Vector-backed ordered sequence of read-only string pointers. */ PROOF typedef const_cstr* const_cstr_list; /* C* frontend shadow for size_t. Generated C obtains the canonical definition @@ -85,17 +145,26 @@ PROOF typedef __SIZE_TYPE__ size_t; * from cstar.h. */ PROOF typedef __builtin_va_list va_list; -/* These macros exist here for C* preprocessing and in proof_runtime.h for the - * generated-C phase. Keep their spelling identical across the two phases. */ +/** + * Construct a fresh term-vector container from zero or more `term` values. + * + * This is the arity-safe source spelling of `term_list_n`; argument handles + * are shared and remain prover managed. Macro arguments are evaluated once by + * the generated call expression. + */ #define TERM_LIST(...) \ term_list_n(sizeof((term[]){__VA_ARGS__}) / sizeof(term) __VA_OPT__(, ) __VA_ARGS__) +/** Construct a fresh theorem-vector container; theorem handles are shared. */ #define THM_LIST(...) \ thm_list_n(sizeof((thm[]){__VA_ARGS__}) / sizeof(thm) __VA_OPT__(, ) __VA_ARGS__) +/** Construct a fresh term-pair-vector container from `term_pair` values. */ #define TERM_PAIR_LIST(...) \ term_pair_list_n(sizeof((term_pair[]){__VA_ARGS__}) / sizeof(term_pair) __VA_OPT__(, ) \ __VA_ARGS__) +/** Construct a fresh mutable-string-pointer vector without copying strings. */ #define STRING_LIST(...) \ string_list_n(sizeof((char*[]){__VA_ARGS__}) / sizeof(char*) __VA_OPT__(, ) __VA_ARGS__) +/** Construct a fresh read-only-string-pointer vector without copying strings. */ #define CONST_STRING_LIST(...) \ const_string_list_n(sizeof((const char*[]){__VA_ARGS__}) / sizeof(const char*) __VA_OPT__(, ) \ __VA_ARGS__) diff --git a/proof_lithium.c b/proof_lithium.c new file mode 100644 index 0000000000000000000000000000000000000000..603eb66246632b1a044549e3ca5a090d709f5048 --- /dev/null +++ b/proof_lithium.c @@ -0,0 +1,890 @@ +#include "proof/proof_lithium.h" + +/* ------------------------------------------------------------------------- */ +/* Rule sets */ +/* ------------------------------------------------------------------------- */ + +PROOF static bool lithium_rule_set_current(const lithium_rule_set* rules) { + if (rules == NULL) return true; + return rules->entries != NULL && + rules->theory_generation == sl_theory_generation(); +err: + ERR_FUN_PUTS("lithium_rule_set_current"); + return false; +} + +PROOF lithium_rule_set lithium_rule_set_new(void) { + ENSURE_COND(sl_theory_is_installed(), + "A Lithium rule set requires an active SL theory"); + return (lithium_rule_set){ + (lithium_rule*)vector_create(), 0, sl_theory_generation()}; +err: + ERR_FUN_PUTS("lithium_rule_set_new"); + return (lithium_rule_set){NULL, 0, 0}; +} + +PROOF static void lithium_insert_rule(lithium_rule_set* rules, + const lithium_rule entry) { + vector_add(&rules->entries, entry); + size_t i = vector_size(rules->entries) - 1; + while (i > 0) { + lithium_rule previous = rules->entries[i - 1]; + bool before = entry.priority < previous.priority || + (entry.priority == previous.priority && + entry.order < previous.order); + if (!before) break; + rules->entries[i] = previous; + --i; + } + rules->entries[i] = entry; +} + +PROOF static bool lithium_is_relation_theorem(const thm theorem) { + thm opened = spec_all_rule(theorem); + thm relation = undisch_all_rule(opened); + term ccl = concl(relation); + return is_sl_ent(ccl) || is_sl_eq(ccl); +err: + ERR_FUN_PUTS("lithium_is_relation_theorem", cstr_thm(theorem)); + return false; +} + +PROOF int lithium_rule_set_add_theorem(lithium_rule_set* rules, + const char* name, size_t priority, + lithium_rule_kind kind, + const thm theorem) { + ENSURE_COND(rules != NULL && rules->entries != NULL, + "Lithium rule set is null or uninitialized"); + ENSURE_COND(lithium_rule_set_current(rules), + "Lithium rule set belongs to a stale SL theory generation"); + ENSURE_COND(name != NULL && name[0] != '\0', + "Lithium rule name must not be empty"); + ENSURE_COND(kind == LITHIUM_ENTAIL_RULE || kind == LITHIUM_GOAL_RULE || + kind == LITHIUM_HYP_RULE, + "Theorem registration requires an entailment rule kind"); + ENSURE_COND(!IS_NULL(theorem), "Lithium theorem rule is empty"); + ENSURE_COND(lithium_is_relation_theorem(theorem), + "Lithium theorem must conclude an SL entailment or equality"); + + lithium_rule entry = { + GC_STRDUP(name), priority, rules->next_order++, kind, theorem, + NULL, NULL, NULL}; + lithium_insert_rule(rules, entry); + return 0; +err: + ERR_FUN_PUTS("lithium_rule_set_add_theorem", cstr_string(name), + cstr_thm(theorem)); + return -1; +} + +PROOF int lithium_rule_set_add_custom(lithium_rule_set* rules, + const char* name, size_t priority, + lithium_rule_matcher matches, + lithium_rule_tactic apply, + const void* data) { + ENSURE_COND(rules != NULL && rules->entries != NULL, + "Lithium rule set is null or uninitialized"); + ENSURE_COND(lithium_rule_set_current(rules), + "Lithium rule set belongs to a stale SL theory generation"); + ENSURE_COND(name != NULL && name[0] != '\0', + "Lithium rule name must not be empty"); + ENSURE_COND(matches != NULL && apply != NULL, + "Lithium custom rule callbacks must not be null"); + + lithium_rule entry = { + GC_STRDUP(name), priority, rules->next_order++, LITHIUM_CUSTOM_RULE, + empty_theorem, matches, apply, data}; + lithium_insert_rule(rules, entry); + return 0; +err: + ERR_FUN_PUTS("lithium_rule_set_add_custom", cstr_string(name)); + return -1; +} + +PROOF int lithium_rule_set_append(lithium_rule_set* destination, + const lithium_rule_set* source) { + ENSURE_COND(destination != NULL && destination->entries != NULL, + "Lithium destination rule set is null or uninitialized"); + ENSURE_COND(source != NULL && source->entries != NULL, + "Lithium source rule set is null or uninitialized"); + ENSURE_COND(destination != source, + "A Lithium rule set cannot be appended to itself"); + ENSURE_COND(destination->entries != source->entries, + "Aliased Lithium rule sets cannot be appended"); + ENSURE_COND(lithium_rule_set_current(destination) && + lithium_rule_set_current(source), + "Lithium rule-set append encountered a stale theory generation"); + + for (size_t i = 0; i < vector_size(source->entries); ++i) { + lithium_rule entry = source->entries[i]; + entry.name = GC_STRDUP(entry.name); + entry.order = destination->next_order++; + lithium_insert_rule(destination, entry); + } + return 0; +err: + ERR_FUN_PUTS("lithium_rule_set_append"); + return -1; +} + +PROOF size_t lithium_rule_set_size(const lithium_rule_set* rules) { + if (rules == NULL || rules->entries == NULL) return 0; + return vector_size(rules->entries); +} + +PROOF lithium_options lithium_options_default( + const lithium_rule_set* rules) { + return (lithium_options){rules, 4096, NULL, NULL}; +} + +/* ------------------------------------------------------------------------- */ +/* Missing deterministic SL introduction tactics */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm lithium_and_sltac_valid(thm* ths, gnode gn) { + (void)gn; + return conj_slrule(ths[0], ths[1]); +err: + ERR_FUN_PUTS("lithium_and_sltac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode_list LITHIUM_AND_SLTAC(const gnode gn) { + ENSURE_COND(gn != NULL && goal_is_sl(gn->g), + "LITHIUM_AND_SLTAC requires an SL goal"); + term hcon = goal_hcon(gn->g); + ENSURE_COND(is_sl_and(hcon), + "SL consequent is not an additive conjunction"); + dest_binop_results parts = dest_sl_and(hcon); + labeled_term_list lasmps = goal_lasmps(gn->g); + labeled_term_list lhants = goal_lhants(gn->g); + goal left = sl_goal_new(lasmps, lhants, parts.tm1); + goal right = sl_goal_new(lasmps, lhants, parts.tm2); + return gnode_expand(gn, LIST_GOAL(left, right), + lithium_and_sltac_valid, NULL); +err: + ERR_FUN_PUTS("LITHIUM_AND_SLTAC", cstr_gnode(gn)); + return NULL; +} + +PROOF typedef struct { + term eigenvariable; +} lithium_forall_sltac_env; + +PROOF static thm lithium_forall_sltac_valid(thm* ths, gnode gn) { + lithium_forall_sltac_env* env = + (lithium_forall_sltac_env*)gn->env; + return forall_slrule(env->eigenvariable, ths[0]); +err: + ERR_FUN_PUTS("lithium_forall_sltac_valid", cstr_gnode(gn)); + return empty_theorem; +} + +PROOF gnode LITHIUM_FORALL_SLTAC(const gnode gn, const char* var_name) { + ENSURE_COND(gn != NULL && goal_is_sl(gn->g), + "LITHIUM_FORALL_SLTAC requires an SL goal"); + term hcon = goal_hcon(gn->g); + ENSURE_COND(is_sl_forall(hcon), + "SL consequent is not universally quantified"); + dest_binder_results quantified = dest_sl_forall(hcon); + term eigenvariable = + var_name == NULL + ? fresh_var_in_goal(quantified.v, gn->g) + : mk_var(var_name, type_of(quantified.v)); + ENSURE_COND(!var_free_in_goal(eigenvariable, gn->g), + "Universal eigenvariable(`%s`) is free in the goal", + string_of_term(eigenvariable)); + + term body = subst_one(eigenvariable, quantified.v, quantified.tm); + goal child_goal = sl_goal_new(goal_lasmps(gn->g), goal_lhants(gn->g), body); + lithium_forall_sltac_env* env = + GC_MALLOC(sizeof(lithium_forall_sltac_env)); + env->eigenvariable = eigenvariable; + return gnode_expand(gn, LIST_GOAL(child_goal), + lithium_forall_sltac_valid, env)[0]; +err: + ERR_FUN_PUTS("LITHIUM_FORALL_SLTAC", cstr_gnode(gn), + cstr_string(var_name)); + return empty_gnode; +} + +/* ------------------------------------------------------------------------- */ +/* Interpreter utilities */ +/* ------------------------------------------------------------------------- */ + +PROOF static lithium_step_result lithium_step( + lithium_step_kind kind, const gnode_list leaves, const char* name) { + return (lithium_step_result){kind, leaves, name}; +} + +PROOF static char* lithium_cstr_gnode_or_null(const gnode gn) { + return gn == NULL ? GC_STRDUP("") : cstr_gnode(gn); +} + +PROOF static lithium_step_result lithium_no_match(void) { + return lithium_step(LITHIUM_NO_MATCH, NULL, NULL); +} + +PROOF static lithium_step_result lithium_error(const char* name) { + return lithium_step(LITHIUM_ERROR, NULL, name); +} + +PROOF static bool lithium_is_exact_frontier(const gnode gn, + const gnode_list leaves) { + if (gn == NULL || leaves == NULL) return false; + gnode_list actual = gnode_leaves(gn); + if (actual == NULL || vector_size(actual) != vector_size(leaves)) { + return false; + } + for (size_t i = 0; i < vector_size(leaves); ++i) { + if (leaves[i] == NULL || leaves[i] != actual[i]) return false; + } + return true; +} + +PROOF static lithium_step_result lithium_applied(const gnode gn, + const gnode_list leaves, + const char* name) { + if (leaves == NULL) return lithium_error(name); + if (!lithium_is_exact_frontier(gn, leaves)) return lithium_error(name); + lithium_step_kind kind = vector_size(leaves) == 0 + ? LITHIUM_CLOSED + : LITHIUM_APPLIED; + return lithium_step(kind, leaves, name); +} + +PROOF static bool lithium_same_goal(const goal left, const goal right) { + return alpha_compare(goal_ccl(left), goal_ccl(right)) == 0; +} + +PROOF static term_list lithium_acu_resources(const term assertion) { + term_list conjuncts = strip_sl_sep(assertion); + term_list resources = (term_list)vector_create(); + for (size_t i = 0; i < vector_size(conjuncts); ++i) { + if (!is_sl_emp(conjuncts[i])) vector_add(&resources, conjuncts[i]); + } + return resources; +} + +PROOF static bool lithium_same_goal_modulo_spatial_acu( + const goal left, const goal right) { + if (lithium_same_goal(left, right)) return true; + if (!goal_is_sl(left) || !goal_is_sl(right)) return false; + term_list left_resources = lithium_acu_resources(goal_hcon(left)); + term_list right_resources = lithium_acu_resources(goal_hcon(right)); + if (vector_size(left_resources) != vector_size(right_resources)) { + return false; + } + term_list remaining = NULL; + return term_list_try_subtract(left_resources, right_resources, + &remaining) && + vector_size(remaining) == 0; +} + +PROOF static term_list lithium_context_resources(const gnode gn) { + labeled_term_list lhants = goal_lhants(gn->g); + term_list resources = (term_list)vector_create(); + for (size_t i = 0; i < vector_size(lhants); ++i) { + term_list current = strip_sl_resources(lhants[i].tm); + vector_append(&resources, current); + } + return resources; +} + +PROOF static bool lithium_spatial_labels_valid(const gnode gn) { + labeled_term_list lhants = goal_lhants(gn->g); + for (size_t i = 0; i < vector_size(lhants); ++i) { + if (lhants[i].lb == NULL) return false; + for (size_t j = 0; j < i; ++j) { + if (strcmp(lhants[i].lb, lhants[j].lb) == 0) return false; + } + } + return true; +} + +/* Count the consequent occurrences greedily covered by complete labeled + * hypotheses. This mirrors AUTO_FRAME's linear, context-order policy. */ +PROOF static size_t lithium_frame_score(const gnode gn) { + term_list remaining = strip_sl_resources(goal_hcon(gn->g)); + labeled_term_list lhants = goal_lhants(gn->g); + size_t score = 0; + for (size_t i = 0; i < vector_size(lhants); ++i) { + term_list current = strip_sl_resources(lhants[i].tm); + term_list next = NULL; + if (term_list_try_subtract(remaining, current, &next)) { + score += vector_size(current); + remaining = next; + } + } + return score; +} + +PROOF static bool lithium_hyp_step_relevant(const gnode before, + const gnode after) { + if (lithium_same_goal(before->g, after->g)) return false; + size_t before_score = lithium_frame_score(before); + size_t after_score = lithium_frame_score(after); + size_t before_resources = vector_size(lithium_context_resources(before)); + size_t after_resources = vector_size(lithium_context_resources(after)); + return after_score > before_score || after_resources < before_resources; +} + +/* The SL apply tactics report ordinary mismatch as an error but guarantee + * that failure occurs before child installation. Probe a private tree so rule + * selection never mutates the caller. proof_try is process-global and not + * nestable, hence the explicit precondition. */ +PROOF static gnode lithium_probe_goal_rule(const gnode gn, const thm theorem) { + ENSURE_COND(!proof_is_in_try(), + "Lithium theorem matching cannot run inside proof_try"); + bool applicable = HCON_APPLY_SLTAC_APPLICABLE(gn, theorem); + ENSURE_OK("Lithium consequent-rule preflight failed"); + if (!applicable) return empty_gnode; + gnode probe = gnode_new(gn->g); + proof_try_begin(); + gnode child = HCON_APPLY_SLTAC(probe, theorem); + bool failed = NOT_OK || child == NULL; + if (failed) SET_OK(); + proof_try_end(); + if (failed) { + proof_clear_errors(); + return empty_gnode; + } + if (lithium_same_goal_modulo_spatial_acu(gn->g, child->g)) { + return empty_gnode; + } + return child; +err: + ERR_FUN_PUTS("lithium_probe_goal_rule", cstr_gnode(gn), + cstr_thm(theorem)); + return empty_gnode; +} + +PROOF static gnode lithium_probe_hyp_rule(const gnode gn, const thm theorem) { + ENSURE_COND(!proof_is_in_try(), + "Lithium theorem matching cannot run inside proof_try"); + gnode probe = gnode_new(gn->g); + proof_try_begin(); + gnode child = AUTO_HANT_APPLY_SLTAC(probe, NULL, theorem); + bool failed = NOT_OK || child == NULL; + if (failed) SET_OK(); + proof_try_end(); + if (failed) { + proof_clear_errors(); + return empty_gnode; + } + if (!lithium_hyp_step_relevant(probe, child)) return empty_gnode; + return child; +err: + ERR_FUN_PUTS("lithium_probe_hyp_rule", cstr_gnode(gn), + cstr_thm(theorem)); + return empty_gnode; +} + +PROOF typedef enum { + LITHIUM_REGISTERED_LEADING, + LITHIUM_REGISTERED_HYP +} lithium_registered_phase; + +PROOF static lithium_step_result lithium_try_registered( + const gnode gn, const lithium_rule_set* rules, + const lithium_registered_phase phase) { + if (rules == NULL) return lithium_no_match(); + ENSURE_COND(lithium_rule_set_current(rules), + "Lithium rule set belongs to a stale SL theory generation"); + + for (size_t i = 0; i < vector_size(rules->entries); ++i) { + lithium_rule rule = rules->entries[i]; + if (rule.kind == LITHIUM_CUSTOM_RULE) { + if (phase != LITHIUM_REGISTERED_LEADING) continue; + bool matches = rule.matches(gn, rule.data); + ENSURE_OK("Lithium custom matcher(`%s`) failed", rule.name); + ENSURE_COND(IS_NULL(gn->solved) && + vector_size(gn->children) == 0, + "Lithium custom matcher(`%s`) mutated its input goal", + rule.name); + if (!matches) continue; + gnode_list leaves = rule.apply(gn, rule.data); + ENSURE_OK("Committed Lithium rule(`%s`) failed", rule.name); + ENSURE_COND(leaves != NULL, + "Committed Lithium rule(`%s`) failed", rule.name); + return lithium_applied(gn, leaves, rule.name); + } + if (!goal_is_sl(gn->g)) continue; + + bool try_goal = phase == LITHIUM_REGISTERED_LEADING && + (rule.kind == LITHIUM_ENTAIL_RULE || + rule.kind == LITHIUM_GOAL_RULE); + if (try_goal && lithium_probe_goal_rule(gn, rule.theorem) != NULL) { + gnode child = HCON_APPLY_SLTAC(gn, rule.theorem); + ENSURE_COND(child != NULL, + "Selected Lithium goal rule(`%s`) failed on commit", + rule.name); + return lithium_applied(gn, LIST_GNODE(child), rule.name); + } + + bool try_hyp = phase == LITHIUM_REGISTERED_HYP && + (rule.kind == LITHIUM_ENTAIL_RULE || + rule.kind == LITHIUM_HYP_RULE); + if (try_hyp && lithium_probe_hyp_rule(gn, rule.theorem) != NULL) { + gnode child = AUTO_HANT_APPLY_SLTAC(gn, NULL, rule.theorem); + ENSURE_COND(child != NULL, + "Selected Lithium hypothesis rule(`%s`) failed on commit", + rule.name); + return lithium_applied(gn, LIST_GNODE(child), rule.name); + } + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_try_registered", cstr_gnode(gn)); + return lithium_error("registered-rule-error"); +} + +PROOF static bool lithium_resources_fit(const term target, + const term_list available) { + term_list needed = strip_sl_resources(target); + term_list ignored = NULL; + return term_list_try_subtract(available, needed, &ignored); +} + +PROOF static bool lithium_goal_has_fact(const term hcon) { + term_list conjuncts = strip_sl_sep(hcon); + for (size_t i = 0; i < vector_size(conjuncts); ++i) { + if (is_sl_fact(conjuncts[i])) return true; + } + return false; +} + +PROOF static bool lithium_goal_has_nested_exists(const term hcon) { + if (is_sl_exists(hcon)) return false; + term_list conjuncts = strip_sl_sep(hcon); + for (size_t i = 0; i < vector_size(conjuncts); ++i) { + if (is_sl_exists(conjuncts[i])) return true; + } + return false; +} + +PROOF static bool lithium_match_witness(const term binder, + const term pattern, + const term target, + term* witness) { + term_list local_constants = list_free_vars(TERM_LIST(pattern, target)); + local_constants = term_list_subtract(local_constants, TERM_LIST(binder)); + ENSURE_COND(!proof_is_in_try(), + "Existential witness matching cannot run inside proof_try"); + proof_try_begin(); + instantiation inst = term_match(local_constants, pattern, target); + bool failed = NOT_OK; + if (failed) SET_OK(); + proof_try_end(); + if (failed) { + proof_clear_errors(); + return false; + } + if (alpha_compare(instantiate(inst, pattern), target) != 0) return false; + term value = instantiate(inst, binder); + if (alpha_compare(value, binder) == 0) return false; + *witness = value; + return true; +err: + ERR_FUN_PUTS("lithium_match_witness", cstr_term(pattern), + cstr_term(target)); + return false; +} + +PROOF static bool lithium_infer_exists_witness(const gnode gn, + term* witness) { + dest_binder_results existential = dest_sl_exists(goal_hcon(gn->g)); + if (!var_free_in(existential.v, existential.tm)) { + *witness = genvar(type_of(existential.v)); + return true; + } + + term_list patterns = strip_sl_sep(existential.tm); + labeled_term_list lhants = goal_lhants(gn->g); + for (size_t i = 0; i < vector_size(patterns); ++i) { + if (!var_free_in(existential.v, patterns[i])) continue; + for (size_t j = 0; j < vector_size(lhants); ++j) { + term_list candidates = strip_sl_sep(lhants[j].tm); + for (size_t k = 0; k < vector_size(candidates); ++k) { + if (lithium_match_witness(existential.v, patterns[i], + candidates[k], witness)) { + return true; + } + } + } + labeled_term_list assumptions = goal_lasmps(gn->g); + for (size_t j = 0; j < vector_size(assumptions); ++j) { + term candidate = mk_sl_fact(assumptions[j].tm); + if (lithium_match_witness(existential.v, patterns[i], candidate, + witness)) { + return true; + } + } + } + return false; +} + +/* ------------------------------------------------------------------------- */ +/* Built-in deterministic steps */ +/* ------------------------------------------------------------------------- */ + +PROOF static lithium_step_result lithium_general_step( + const gnode gn, const lithium_options options) { + /* Like Lithium's leading liTactic entry, an explicitly registered custom + * rule may override the ordinary connective interpreter. */ + lithium_step_result registered = + lithium_try_registered(gn, options.rules, + LITHIUM_REGISTERED_LEADING); + if (registered.kind != LITHIUM_NO_MATCH) return registered; + + term ccl = goal_ccl(gn->g); + if (is_forall(ccl) || is_imp(ccl) || is_not(ccl)) { + gnode child = AUTO_INTROS_TAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "intro"); + } + if (is_sl_ent(ccl)) { + gnode_list leaves = SL_MODE(gn, "H"); + return lithium_applied(gn, leaves, "enter-sl"); + } + + labeled_term_list assumptions = goal_lasmps(gn->g); + for (size_t i = 0; i < vector_size(assumptions); ++i) { + if (alpha_compare(assumptions[i].tm, ccl) == 0) { + ACCEPT_TAC(gn, assume_rule(assumptions[i].tm)); + return lithium_applied(gn, LIST_GNODE(), "pure-assumption"); + } + } + if (is_true(ccl)) { + ACCEPT_TAC(gn, eqt_elim_rule(refl_rule(mk_true()))); + return lithium_applied(gn, LIST_GNODE(), "pure-true"); + } + if (is_eq(ccl)) { + dest_eq_results equality = dest_eq(ccl); + if (alpha_compare(equality.tm1, equality.tm2) == 0) { + ACCEPT_TAC(gn, refl_rule(equality.tm1)); + return lithium_applied(gn, LIST_GNODE(), "pure-reflexivity"); + } + } + if (is_conj(ccl)) { + return lithium_applied(gn, CONJ_TAC(gn), "pure-conjunction"); + } + if (is_disj(ccl)) { + dest_disj_results alternatives = dest_disj(ccl); + bool choose_left = false; + bool choose_right = false; + for (size_t i = 0; i < vector_size(assumptions); ++i) { + choose_left = choose_left || + alpha_compare(assumptions[i].tm, alternatives.tm1) == 0; + choose_right = choose_right || + alpha_compare(assumptions[i].tm, alternatives.tm2) == 0; + } + gnode child = (!choose_left && choose_right) + ? DISJ2_TAC(gn) + : DISJ1_TAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "pure-disjunction"); + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_general_step", cstr_gnode(gn)); + return lithium_error("general-step-error"); +} + +/* Spatial facts behave like the duplicable pure context in the currently + * installed C* logic. Expose them before linear cancellation, otherwise a + * greedy frame can consume the only syntactic fact occurrence before a + * duplicated fact obligation is generated. Only separating conjunctions on + * the path to a fact are opened here; unrelated structural assertions retain + * the ordinary left-step order. */ +PROOF static bool lithium_sep_contains_fact(const term assertion) { + term_list conjuncts = strip_sl_sep(assertion); + for (size_t i = 0; i < vector_size(conjuncts); ++i) { + if (is_sl_fact(conjuncts[i])) return true; + } + return false; +} + +PROOF static lithium_step_result lithium_fact_step(const gnode gn) { + labeled_term_list lhants = goal_lhants(gn->g); + for (size_t i = 0; i < vector_size(lhants); ++i) { + const char* label = lhants[i].lb; + term assertion = lhants[i].tm; + if (is_sl_fact(assertion)) { + term fact = dest_sl_fact(assertion); + if (is_false(fact)) { + CONTR_SLTAC(gn, label); + return lithium_applied(gn, LIST_GNODE(), "left-false"); + } + gnode child = INTRO_FACT_SLTAC(gn, CONST_STRING_LIST(label)); + return lithium_applied(gn, LIST_GNODE(child), "left-fact"); + } + if (is_sl_sep(assertion) && lithium_sep_contains_fact(assertion)) { + gnode child = HANT_SEP_SLTAC(gn, label, NULL, NULL); + return lithium_applied(gn, LIST_GNODE(child), "left-sep-to-fact"); + } + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_fact_step", cstr_gnode(gn)); + return lithium_error("fact-step-error"); +} + +PROOF static lithium_step_result lithium_left_step(const gnode gn) { + labeled_term_list lhants = goal_lhants(gn->g); + term_list goal_resources = strip_sl_resources(goal_hcon(gn->g)); + + /* A wand consumes its argument linearly and appends the codomain. Match in + * context order and commit the first exact domain occurrence. */ + for (size_t i = 0; i < vector_size(lhants); ++i) { + if (!is_sl_wand(lhants[i].tm)) continue; + term domain = dest_sl_wand(lhants[i].tm).tm1; + for (size_t j = 0; j < vector_size(lhants); ++j) { + if (i == j || alpha_compare(domain, lhants[j].tm) != 0) continue; + gnode child = WAND_MP_SLTAC( + gn, lhants[i].lb, lhants[j].lb, NULL); + return lithium_applied(gn, LIST_GNODE(child), "left-wand-apply"); + } + } + + for (size_t i = 0; i < vector_size(lhants); ++i) { + const char* label = lhants[i].lb; + term hant = lhants[i].tm; + if (is_sl_sep(hant)) { + gnode child = HANT_SEP_SLTAC(gn, label, NULL, NULL); + return lithium_applied(gn, LIST_GNODE(child), "left-sep"); + } + if (is_sl_or(hant)) { + return lithium_applied(gn, + HANT_DISJ_SLTAC(gn, label, NULL, NULL), + "left-disjunction"); + } + if (is_sl_exists(hant)) { + gnode child = HANT_EXISTS_SLTAC(gn, label, NULL); + return lithium_applied(gn, LIST_GNODE(child), "left-exists"); + } + if (is_sl_fact(hant)) { + term fact = dest_sl_fact(hant); + if (is_false(fact)) { + CONTR_SLTAC(gn, label); + return lithium_applied(gn, LIST_GNODE(), "left-false"); + } + gnode child = INTRO_FACT_SLTAC(gn, CONST_STRING_LIST(label)); + return lithium_applied(gn, LIST_GNODE(child), "left-fact"); + } + if (is_sl_emp(hant)) { + gnode child = CLEAN_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "left-unit"); + } + if (is_sl_and(hant)) { + dest_binop_results choices = dest_sl_and(hant); + term_list ignored = NULL; + bool left_fits = term_list_try_subtract( + goal_resources, strip_sl_resources(choices.tm1), &ignored); + bool right_fits = term_list_try_subtract( + goal_resources, strip_sl_resources(choices.tm2), &ignored); + if (left_fits || right_fits) { + size_t left_score = + left_fits ? vector_size(strip_sl_resources(choices.tm1)) : 0; + size_t right_score = + right_fits ? vector_size(strip_sl_resources(choices.tm2)) : 0; + bool select_left = left_fits && + (!right_fits || left_score >= right_score); + thm projection = + select_left + ? ispecl_rule(TERM_LIST(choices.tm1, choices.tm2), + sl_and_elim1()) + : ispecl_rule(TERM_LIST(choices.tm1, choices.tm2), + sl_and_elim2()); + gnode child = HANT_APPLY_SLTAC( + gn, CONST_STRING_LIST(label), label, projection); + return lithium_applied(gn, LIST_GNODE(child), "left-and-project"); + } + } + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_left_step", cstr_gnode(gn)); + return lithium_error("left-step-error"); +} + +PROOF static lithium_step_result lithium_frame_step(const gnode gn) { + labeled_term_list lhants = goal_lhants(gn->g); + term_list remaining = strip_sl_resources(goal_hcon(gn->g)); + const_cstr_list labels = (const_cstr_list)vector_create(); + for (size_t i = 0; i < vector_size(lhants); ++i) { + term_list resources = strip_sl_resources(lhants[i].tm); + term_list next = NULL; + if (vector_size(resources) != 0 && + term_list_try_subtract(remaining, resources, &next)) { + vector_add(&labels, lhants[i].lb); + remaining = next; + } + } + if (vector_size(labels) != 0) { + gnode child = FRAME_SLTAC(gn, labels); + return lithium_applied(gn, LIST_GNODE(child), "direct-frame"); + } + if (is_sl_emp(goal_hcon(gn->g)) && + vector_size(lithium_context_resources(gn)) == 0) { + EMP_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(), "emp"); + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_frame_step", cstr_gnode(gn)); + return lithium_error("frame-step-error"); +} + +PROOF static lithium_step_result lithium_right_step(const gnode gn) { + term hcon = goal_hcon(gn->g); + + if (sl_update_theory_is_installed() && is_sl_bupd(hcon)) { + labeled_term_list lhants = goal_lhants(gn->g); + if (vector_size(lhants) == 1 && is_sl_bupd(lhants[0].tm)) { + gnode child = BUPD_MONO_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "bupd-mono"); + } + gnode child = BUPD_INTRO_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "bupd-intro"); + } + if (lithium_goal_has_fact(hcon)) { + return lithium_applied(gn, PURE_SLTAC(gn), "right-fact"); + } + if (lithium_goal_has_nested_exists(hcon)) { + gnode child = EXISTS_PULL_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "pull-exists"); + } + if (is_sl_and(hcon)) { + return lithium_applied(gn, LITHIUM_AND_SLTAC(gn), "right-and"); + } + if (is_sl_or(hcon)) { + dest_binop_results alternatives = dest_sl_or(hcon); + term_list resources = lithium_context_resources(gn); + bool left_fits = lithium_resources_fit(alternatives.tm1, resources); + bool right_fits = lithium_resources_fit(alternatives.tm2, resources); + size_t left_score = + left_fits ? vector_size(strip_sl_resources(alternatives.tm1)) : 0; + size_t right_score = + right_fits ? vector_size(strip_sl_resources(alternatives.tm2)) : 0; + bool choose_right = right_fits && + (!left_fits || right_score > left_score); + gnode child = choose_right ? DISJ2_SLTAC(gn) : DISJ1_SLTAC(gn); + return lithium_applied(gn, LIST_GNODE(child), "right-disjunction"); + } + if (is_sl_wand(hcon)) { + return lithium_applied(gn, INTRO_WAND_SLTAC(gn, NULL), "right-wand"); + } + if (is_sl_exists(hcon)) { + term witness; + if (!lithium_infer_exists_witness(gn, &witness)) { + return lithium_no_match(); + } + gnode child = EXISTS_SLTAC(gn, witness); + return lithium_applied(gn, LIST_GNODE(child), "right-exists"); + } + if (is_sl_forall(hcon)) { + gnode child = LITHIUM_FORALL_SLTAC(gn, NULL); + return lithium_applied(gn, LIST_GNODE(child), "right-forall"); + } + return lithium_no_match(); +err: + ERR_FUN_PUTS("lithium_right_step", cstr_gnode(gn)); + return lithium_error("right-step-error"); +} + +PROOF lithium_step_result LITHIUM_STEP_SLTAC( + const gnode gn, const lithium_options options) { + ENSURE_COND(!proof_is_in_try(), + "Lithium cannot run inside an active proof_try region"); + ENSURE_COND(gn != NULL, "Lithium goal node is null"); + ENSURE_COND(IS_NULL(gn->solved), "Lithium goal node is already solved"); + ENSURE_COND(vector_size(gn->children) == 0, + "A Lithium step requires an open proof-tree leaf"); + ENSURE_COND(options.rules == NULL || + lithium_rule_set_current(options.rules), + "Lithium rule set belongs to a stale SL theory generation"); + + if (goal_is_general(gn->g)) { + return lithium_general_step(gn, options); + } + ENSURE_COND(goal_is_sl(gn->g), + "Lithium supports only general and SL goals"); + ENSURE_COND(lithium_spatial_labels_valid(gn), + "Lithium requires non-null, pairwise-distinct spatial labels"); + + /* Custom and consequent rules form a liTactic-style leading phase and may + * override the fixed connective interpreter. Forward hypothesis rewrites + * are delayed until direct lookup and structural exposure have had a chance + * to use the original resource. */ + lithium_step_result step = + lithium_try_registered(gn, options.rules, + LITHIUM_REGISTERED_LEADING); + if (step.kind != LITHIUM_NO_MATCH) return step; + step = lithium_fact_step(gn); + if (step.kind != LITHIUM_NO_MATCH) return step; + step = lithium_frame_step(gn); + if (step.kind != LITHIUM_NO_MATCH) return step; + step = lithium_left_step(gn); + if (step.kind != LITHIUM_NO_MATCH) return step; + step = lithium_try_registered(gn, options.rules, + LITHIUM_REGISTERED_HYP); + if (step.kind != LITHIUM_NO_MATCH) return step; + return lithium_right_step(gn); +err: + ERR_FUN_PUTS("LITHIUM_STEP_SLTAC", lithium_cstr_gnode_or_null(gn)); + return lithium_error("step-error"); +} + +PROOF gnode_list LITHIUM_SLTAC(const gnode gn, + const lithium_options options) { + ENSURE_COND(!proof_is_in_try(), + "Lithium cannot run inside an active proof_try region"); + ENSURE_COND(gn != NULL, "Lithium root node is null"); + ENSURE_COND(options.max_steps != 0, + "Lithium max_steps must be positive"); + ENSURE_COND(options.rules == NULL || + lithium_rule_set_current(options.rules), + "Lithium rule set belongs to a stale SL theory generation"); + + gnode_list work = gnode_leaves(gn); + ENSURE_COND(work != NULL, + "Could not obtain the Lithium input frontier"); + gnode_list stuck = (gnode_list)vector_create(); + size_t cursor = 0; + size_t committed = 0; + while (cursor < vector_size(work)) { + gnode current = work[cursor++]; + ENSURE_COND(current != NULL, + "Lithium worklist contains a null proof-tree leaf"); + if (!IS_NULL(current->solved)) continue; + gnode before = options.trace == NULL ? NULL : gnode_new(current->g); + lithium_step_result step = LITHIUM_STEP_SLTAC(current, options); + ENSURE_COND(step.kind != LITHIUM_ERROR, + "Lithium interpreter step failed"); + if (step.kind == LITHIUM_NO_MATCH) { + vector_add(&stuck, current); + continue; + } + ENSURE_COND(committed < options.max_steps, + "Lithium exhausted its %zu-step fuel", options.max_steps); + ++committed; + if (options.trace != NULL) { + options.trace(step.rule_name, before, step.leaves, + options.trace_data); + ENSURE_OK("Lithium trace callback failed"); + } + if (step.leaves != NULL) vector_append(&work, step.leaves); + } + + if (vector_size(stuck) == 0) { + thm proved = gnode_prove(gn); + ENSURE_COND(!IS_NULL(proved), + "Lithium produced an invalid completed proof tree"); + return (gnode_list)vector_create(); + } + /* Work is scheduled breadth-first, but the public frontier follows proof + * tree order just like `gnode_leaves`. */ + return gnode_leaves(gn); +err: + ERR_FUN_PUTS("LITHIUM_SLTAC", lithium_cstr_gnode_or_null(gn)); + return NULL; +} diff --git a/proof_lithium.h b/proof_lithium.h new file mode 100644 index 0000000000000000000000000000000000000000..468c74c7ce69e07bf8995c7cd7b0b06d5eb114ac --- /dev/null +++ b/proof_lithium.h @@ -0,0 +1,224 @@ +/** + * Lithium-inspired, rule-extensible goal-directed SL entailment automation. + * + * The interpreter is intentionally a search policy rather than a new proof + * rule. Every successful step expands an ordinary validated proof tree using + * `proof_backward`/`proof_backward_sl`; a registered theorem is accepted only + * through the same theorem-application validators as a handwritten proof. + * + * ## Search discipline + * + * Phase precedence is stronger than numeric priority: leading custom/GOAL + * rules are considered before structural interpretation, while HYP rules are + * considered later. Within either registered phase, rules are ordered by + * ascending numeric priority and then registration order. The first applicable + * rule in that phase is committed. Matchers may perform their own finite + * candidate search, but failure of selected recursive leaves never reopens the + * rule choice. + * + * `LITHIUM_GOAL_RULE` is the identity-modality C* analogue of RefinedC's + * `lemma_to_li_entails`: a theorem `P |-- Q` reduces a whole consequent that + * matches `Q` modulo spatial ACU to `P`, leaving the spatial context unchanged. + * It does not implicitly frame the theorem. `LITHIUM_HYP_RULE` is a smaller, + * binary forward-rewrite convenience, + * not a complete implementation of Lithium's continuation-aware + * `SimplifyHyp` or `Subsume` judgments. `LITHIUM_ENTAIL_RULE` opts into both + * directions. Leading theorem universals are matched; discharged HOL premises + * must already be available in the ordinary context before a rule can commit. + * + * The built-in interpreter normalizes left `**`, `||`, existential and fact + * assertions; consumes matching resources linearly; and handles right facts, + * additive conjunction/disjunction, wand, existential, universal, and an + * installed basic-update modality. It never silently weakens or duplicates a + * spatial resource. + */ + +#pragma once + +#include "proof/proof_backward_sl.h" +#require "proof/proof_backward_sl.c" + +/** How a registered rule is interpreted. */ +PROOF typedef enum { + /** C* convenience: enable both GOAL and HYP interpretations below. */ + LITHIUM_ENTAIL_RULE, + /** Exact consequent reduction; the `lemma_to_li_entails` analogue. */ + LITHIUM_GOAL_RULE, + /** Restricted binary forward rewrite of matching spatial hypotheses. */ + LITHIUM_HYP_RULE, + /** Delegate applicability and one committed proof-tree step to callbacks. */ + LITHIUM_CUSTOM_RULE +} lithium_rule_kind; + +/** + * Pure applicability test for a custom rule. + * + * Return false for an ordinary mismatch without setting prover error status or + * mutating `gn`. A true result commits the rule; its apply callback is then + * called exactly once on the real proof tree. + */ +PROOF typedef bool (*lithium_rule_matcher)(const gnode gn, + const void* data); + +/** + * Apply one already-selected custom rule. + * + * Return exactly the rule subtree's complete unsolved frontier in proof order, + * or an empty vector after closing the node. `NULL`, a null element, an omitted + * leaf, or an extra leaf is rejected as an actual tactic error. The callback + * must use validated tactics/proof-tree expansion; this interface does not + * make an unsafe callback sound. + */ +PROOF typedef gnode_list (*lithium_rule_tactic)(const gnode gn, + const void* data); + +/** One copied entry in a caller-owned rule set. */ +PROOF typedef struct { + const char* name; + size_t priority; + size_t order; + lithium_rule_kind kind; + thm theorem; + lithium_rule_matcher matches; + lithium_rule_tactic apply; + const void* data; +} lithium_rule; + +/** + * An ordered rule collection tied to one installed SL-theory generation. + * + * The vector is prover/GC managed. Copying this struct shares that vector, so + * pass a pointer to one logical owner while adding entries. + */ +PROOF typedef struct { + lithium_rule* entries; + size_t next_order; + size_t theory_generation; +} lithium_rule_set; + +/** Create an empty rule set for the active SL theory. */ +PROOF lithium_rule_set lithium_rule_set_new(void); + +/** + * Register a proved SL equality or entailment. + * + * Outer universals and leading implications are supported by the existing SL + * theorem matcher. `name` is copied. Within the rule's eligible phase, lower + * priorities run first and equal priorities retain registration order. Return + * zero on success and `-1` for a malformed theorem/rule set. + */ +PROOF int lithium_rule_set_add_theorem(lithium_rule_set* rules, + const char* name, size_t priority, + lithium_rule_kind kind, + const thm theorem); + +/** + * Register a callback rule with the same stable priority ordering. + * + * `data` is borrowed and must outlive every search using this set or a bundle + * produced from it by `lithium_rule_set_append`. + */ +PROOF int lithium_rule_set_add_custom(lithium_rule_set* rules, + const char* name, size_t priority, + lithium_rule_matcher matches, + lithium_rule_tactic apply, + const void* data); + +/** + * Append copied entries from another current-theory rule set. + * + * The backing vector is re-sorted by numeric priority, while dispatch still + * filters by phase first. At equal priority, existing destination entries + * precede appended entries, whose source order is retained. This lets + * independent modules publish rule bundles without process-global mutable + * registration. Self-append, aliased shallow-copy append, and stale sets fail. + */ +PROOF int lithium_rule_set_append(lithium_rule_set* destination, + const lithium_rule_set* source); + +/** Number of registered rules. */ +PROOF size_t lithium_rule_set_size(const lithium_rule_set* rules); + +/** Result of one interpreter step. */ +PROOF typedef enum { + LITHIUM_NO_MATCH, + LITHIUM_APPLIED, + LITHIUM_CLOSED, + LITHIUM_ERROR +} lithium_step_kind; + +PROOF typedef struct { + lithium_step_kind kind; + gnode_list leaves; + const char* rule_name; +} lithium_step_result; + +/** + * Optional trace called once after every committed step. + * + * `before` is a fresh shallow node containing the goal immediately before the + * step; it is an inspection snapshot, not the node that was expanded. `after` + * is the exact unresolved frontier of the real expanded subtree. + */ +PROOF typedef void (*lithium_trace_callback)(const char* rule_name, + const gnode before, + const gnode_list after, + const void* data); + +/** Solver configuration. A null rule set means structural rules only. */ +PROOF typedef struct { + const lithium_rule_set* rules; + size_t max_steps; + lithium_trace_callback trace; + const void* trace_data; +} lithium_options; + +/** Build options with 4096 steps and tracing disabled. */ +PROOF lithium_options lithium_options_default( + const lithium_rule_set* rules); + +/** + * Split a right additive conjunction using the full spatial context in both + * children. This fills a primitive gap in `proof_backward_sl` and validates + * with `conj_slrule`. + */ +PROOF gnode_list LITHIUM_AND_SLTAC(const gnode gn); + +/** + * Introduce a fresh eigenvariable for a right SL universal. + * + * A null name requests a fresh variant. Validation uses `forall_slrule` and + * therefore checks the eigenvariable side condition bottom-up. + */ +PROOF gnode LITHIUM_FORALL_SLTAC(const gnode gn, const char* var_name); + +/** + * Perform exactly one committed interpreter step on an open leaf. + * + * The leaf must be unsolved and have no children. SL leaves additionally need + * non-null, pairwise-distinct spatial labels. This function must not run inside + * an active `proof_try` region. + */ +PROOF lithium_step_result LITHIUM_STEP_SLTAC( + const gnode gn, const lithium_options options); + +/** + * Repeatedly solve every generated leaf until all close, no rule matches, or + * `max_steps` committed steps have been used. + * + * `gn` may be a fresh root or a partially expanded unsolved tree; search + * continues from its current leaves without replacing existing internal + * expansions. `LITHIUM_STEP_SLTAC` itself requires one open leaf. Neither API + * may be called inside an active `proof_try` region because theorem and witness + * probing use that process-global facility internally. + * + * General goals are first introduced and SL entailments enter SL mode. The + * return value is the ordered unresolved frontier; an empty vector means the + * input proof tree is complete. Getting stuck is a normal result and does not + * set prover error status. Malformed rules, callback failures, stale theory + * generations, or needing another committed step after exhausting fuel report + * an error and return `NULL`; a no-match leaf at the exact fuel boundary is + * still returned normally. + */ +PROOF gnode_list LITHIUM_SLTAC(const gnode gn, + const lithium_options options); diff --git a/proof_sl.c b/proof_sl.c index 1100463025f5f5c69e4859ca616c373c0d2c97bb..2841600b6e1bcf954ba70c22c6c16f4ce04ed95e 100644 --- a/proof_sl.c +++ b/proof_sl.c @@ -9,54 +9,716 @@ * functions then combine kernel theorems into derived separation-logic rules. */ -PROOF void sl_thm_lazy_init_check(const char* name, thm th, - const char* expected_str) { - if (NOT_OK) { - log_fatal("sl_thm_lazy_init(%s): prover error before check: %s", name, - get_last_error() ? get_last_error() : "(none)"); - } - if (IS_NULL(th)) { - log_fatal("sl_thm_lazy_init(%s): prove_%s() returned empty theorem", name, - name); - } - term expected = parse_term(expected_str); - if (NOT_OK) { - log_fatal( - "sl_thm_lazy_init(%s): failed to parse expected conclusion `%s`: %s", - name, expected_str, get_last_error() ? get_last_error() : "(none)"); - } - if (vector_size(hyp(th)) != 0) { - log_fatal("sl_thm_lazy_init(%s): expected unconditional `|-`, got `%s`", - name, string_of_thm(th)); +PROOF static sl_theory active_sl_theory; +PROOF static bool active_sl_theory_initialized = false; +PROOF static size_t active_sl_theory_generation = 0; +PROOF static const char* active_sl_exists_name = NULL; +PROOF static const char* active_sl_forall_name = NULL; +PROOF static sl_update_theory active_sl_update_theory; +PROOF static bool active_sl_update_theory_initialized = false; +PROOF static size_t active_sl_update_theory_generation = 0; + +PROOF thm sl_ent_sym_left; +PROOF thm sl_ent_restate; +PROOF thm sl_frame_restate; +PROOF thm sl_ent_frame_left; +PROOF thm sl_ent_frame_right; +PROOF thm sl_ent_subst_frame; +PROOF thm sl_sep_combine; +PROOF thm sl_ac_rule; +PROOF thm sl_disj_mono; +PROOF thm sl_or_elim_frame; +PROOF thm sl_exists_elim_frame; +PROOF thm sl_undisch; +PROOF thm sl_conj1; +PROOF thm sl_conj2; +PROOF thm sl_disj1_mono; +PROOF thm sl_disj2_mono; +PROOF thm sl_exists_wit; +/* Internal eta-short form used to instantiate existential monotonicity + * without repairing both endpoints after every binder. */ +PROOF static thm sl_exists_mono_eta; + +PROOF static thm prove_sl_ent_sym_left(void); +PROOF static thm prove_sl_ent_restate(void); +PROOF static thm prove_sl_frame_restate(void); +PROOF static thm prove_sl_ent_frame_left(void); +PROOF static thm prove_sl_ent_frame_right(void); +PROOF static thm prove_sl_ent_subst_frame(void); +PROOF static thm prove_sl_sep_combine(void); +PROOF static thm prove_sl_ac_rule(void); +PROOF static thm prove_sl_disj_mono(void); +PROOF static thm prove_sl_or_elim_frame(void); +PROOF static thm prove_sl_exists_elim_frame(void); +PROOF static thm prove_sl_undisch(void); +PROOF static thm prove_sl_conj1(void); +PROOF static thm prove_sl_conj2(void); +PROOF static thm prove_sl_disj1_mono(void); +PROOF static thm prove_sl_disj2_mono(void); +PROOF static thm prove_sl_exists_wit(void); +PROOF static thm prove_sl_exists_mono_eta(void); +PROOF static int sl_build_derived_theorems(void); + +PROOF static void sl_clear_update_theory(void) { + active_sl_update_theory = (sl_update_theory){0}; + active_sl_update_theory_initialized = false; + active_sl_update_theory_generation = 0; +} + +PROOF static int sl_check_exact_primitive(const char* name, const thm actual, + const term expected) { + ENSURE_COND(!IS_NULL(actual), + "SL primitive %s is empty", name); + term_list assumptions = hyp(actual); + ENSURE_COND(vector_size(assumptions) == 0, + "SL primitive %s has assumptions", name); + term actual_ccl = concl(actual); + term_list actual_frees = free_vars(actual_ccl); + ENSURE_COND(vector_size(actual_frees) == 0, + "SL primitive %s has free term variables", name); + int schema_order = alpha_compare(actual_ccl, expected); + ENSURE_COND(schema_order == 0, + "SL primitive %s does not match its schema", name); + return 0; +err: + ERR_FUN_PUTS("sl_check_exact_primitive", cstr_string(name), + cstr_thm(actual), cstr_term(expected)); + return -1; +} + +PROOF static int sl_check_exact_derived(const char* name, const thm actual, + const term expected) { + ENSURE_COND(!IS_NULL(actual), "Derived SL theorem %s is empty", name); + term_list assumptions = hyp(actual); + ENSURE_COND(vector_size(assumptions) == 0, + "Derived SL theorem %s has assumptions", name); + term actual_ccl = concl(actual); + term_list actual_frees = free_vars(actual_ccl); + ENSURE_COND(vector_size(actual_frees) == 0, + "Derived SL theorem %s has free term variables", name); + ENSURE_COND(equals_term(actual_ccl, expected), + "Derived SL theorem %s does not have its documented exact " + "conclusion; actual `%s`, expected `%s`", + name, string_of_term(actual_ccl), string_of_term(expected)); + return 0; +err: + ERR_FUN_PUTS("sl_check_exact_derived", cstr_string(name), + cstr_thm(actual), cstr_term(expected)); + return -1; +} + +PROOF static int sl_bind_exact_derived(const char* name, thm* binding, + const thm proved, + const term expected) { + thm aligned = proved; + term proved_ccl = concl(proved); + if (!equals_term(proved_ccl, expected)) { + ENSURE_COND(alpha_compare(proved_ccl, expected) == 0, + "Derived SL theorem %s is not alpha-equivalent to its " + "documented conclusion", + name); + thm alignment = alpha_rule(proved_ccl, expected); + aligned = eq_mp_rule(alignment, proved); } - term got = concl(th); - if (alpha_compare(got, expected) != 0) { - log_fatal( - "sl_thm_lazy_init(%s): conclusion mismatch modulo alpha-equivalence\n" - " got: `%s`\n " - "expected: `%s`", - name, string_of_term(got), string_of_term(expected)); + int check_status = sl_check_exact_derived(name, aligned, expected); + ENSURE_COND(check_status == 0, + "Derived SL theorem %s failed exact validation", name); + *binding = aligned; + return 0; +err: + ERR_FUN_PUTS("sl_bind_exact_derived", cstr_string(name), + cstr_thm(proved), cstr_term(expected)); + return -1; +} + +PROOF static int sl_check_existential_primitives(const sl_theory* theory) { + type_list intro_types = term_tyvars(concl(theory->exists_intro)); + type_list elim_types = term_tyvars(concl(theory->exists_elim)); + type_list mono_types = term_tyvars(concl(theory->exists_mono)); + type_list left_types = term_tyvars(concl(theory->sep_exists_left)); + type_list right_types = term_tyvars(concl(theory->sep_exists_right)); + ENSURE_COND(vector_size(intro_types) == 1, + "SL exists_intro must have exactly one witness type variable"); + ENSURE_COND(vector_size(elim_types) == 1, + "SL exists_elim must have exactly one witness type variable"); + ENSURE_COND(vector_size(mono_types) == 1, + "SL exists_mono must have exactly one witness type variable"); + ENSURE_COND(vector_size(left_types) == 1, + "SL sep_exists_left must have exactly one witness type variable"); + ENSURE_COND(vector_size(right_types) == 1, + "SL sep_exists_right must have exactly one witness type variable"); + + type prop_type = theory->prop_type; + type intro_witness_type = intro_types[0]; + type intro_family_type = mk_fun_type(intro_witness_type, prop_type); + term intro_P = mk_var("__sl_exists_intro_P", intro_family_type); + term intro_w = mk_var("__sl_exists_intro_w", intro_witness_type); + term intro_x = mk_var("__sl_exists_intro_x", intro_witness_type); + term intro_P_w = mk_comb(intro_P, intro_w); + term intro_P_x = mk_comb(intro_P, intro_x); + term intro_exists_P = + mk_icomb(theory->exists_op, mk_abs(intro_x, intro_P_x)); + term intro = mk_binop(theory->entails, intro_P_w, intro_exists_P); + term intro_schema = + list_mk_forall(TERM_LIST(intro_P, intro_w), intro); + ENSURE_COND(sl_check_exact_primitive( + "exists_intro", theory->exists_intro, intro_schema) == 0, + "Invalid SL primitive exists_intro"); + + type elim_witness_type = elim_types[0]; + type elim_family_type = mk_fun_type(elim_witness_type, prop_type); + term elim_P = mk_var("__sl_exists_elim_P", elim_family_type); + term elim_F = mk_var("__sl_exists_elim_F", prop_type); + term elim_x = mk_var("__sl_exists_elim_x", elim_witness_type); + term elim_P_x = mk_comb(elim_P, elim_x); + term elim_exists_P = + mk_icomb(theory->exists_op, mk_abs(elim_x, elim_P_x)); + term pointwise_elim = mk_forall( + elim_x, mk_binop(theory->entails, elim_P_x, elim_F)); + term elim = mk_imp( + pointwise_elim, + mk_binop(theory->entails, elim_exists_P, elim_F)); + term elim_schema = list_mk_forall(TERM_LIST(elim_P, elim_F), elim); + ENSURE_COND(sl_check_exact_primitive( + "exists_elim", theory->exists_elim, elim_schema) == 0, + "Invalid SL primitive exists_elim"); + + type mono_witness_type = mono_types[0]; + type mono_family_type = mk_fun_type(mono_witness_type, prop_type); + term mono_P = mk_var("__sl_exists_mono_P", mono_family_type); + term mono_Q = mk_var("__sl_exists_mono_Q", mono_family_type); + term mono_x = mk_var("__sl_exists_mono_x", mono_witness_type); + term mono_P_x = mk_comb(mono_P, mono_x); + term mono_Q_x = mk_comb(mono_Q, mono_x); + term mono_exists_P = + mk_icomb(theory->exists_op, mk_abs(mono_x, mono_P_x)); + term mono_exists_Q = + mk_icomb(theory->exists_op, mk_abs(mono_x, mono_Q_x)); + term pointwise_mono = mk_forall( + mono_x, mk_binop(theory->entails, mono_P_x, mono_Q_x)); + term mono = mk_imp( + pointwise_mono, + mk_binop(theory->entails, mono_exists_P, mono_exists_Q)); + term mono_schema = list_mk_forall(TERM_LIST(mono_P, mono_Q), mono); + ENSURE_COND(sl_check_exact_primitive( + "exists_mono", theory->exists_mono, mono_schema) == 0, + "Invalid SL primitive exists_mono"); + + type left_witness_type = left_types[0]; + type left_family_type = mk_fun_type(left_witness_type, prop_type); + term left_P = mk_var("__sl_exists_left_P", left_family_type); + term left_F = mk_var("__sl_exists_left_F", prop_type); + term left_x = mk_var("__sl_exists_left_x", left_witness_type); + term left_P_x = mk_comb(left_P, left_x); + term left_exists_P = + mk_icomb(theory->exists_op, mk_abs(left_x, left_P_x)); + term left_body = mk_binop(theory->sep, left_P_x, left_F); + term left_target = + mk_icomb(theory->exists_op, mk_abs(left_x, left_body)); + term left = mk_eq( + mk_binop(theory->sep, left_exists_P, left_F), left_target); + term left_schema = list_mk_forall(TERM_LIST(left_P, left_F), left); + ENSURE_COND(sl_check_exact_primitive( + "sep_exists_left", theory->sep_exists_left, + left_schema) == 0, + "Invalid SL primitive sep_exists_left"); + + type right_witness_type = right_types[0]; + type right_family_type = mk_fun_type(right_witness_type, prop_type); + term right_P = mk_var("__sl_exists_right_P", right_family_type); + term right_F = mk_var("__sl_exists_right_F", prop_type); + term right_x = mk_var("__sl_exists_right_x", right_witness_type); + term right_P_x = mk_comb(right_P, right_x); + term right_exists_P = + mk_icomb(theory->exists_op, mk_abs(right_x, right_P_x)); + term right_body = mk_binop(theory->sep, right_F, right_P_x); + term right_target = + mk_icomb(theory->exists_op, mk_abs(right_x, right_body)); + term right = mk_eq( + mk_binop(theory->sep, right_F, right_exists_P), right_target); + term right_schema = list_mk_forall(TERM_LIST(right_F, right_P), right); + ENSURE_COND(sl_check_exact_primitive( + "sep_exists_right", theory->sep_exists_right, + right_schema) == 0, + "Invalid SL primitive sep_exists_right"); + return 0; +err: + ERR_FUN_PUTS("sl_check_existential_primitives"); + return -1; +} + +PROOF static int sl_check_universal_primitives(const sl_theory* theory) { + type_list intro_types = term_tyvars(concl(theory->forall_intro)); + type_list elim_types = term_tyvars(concl(theory->forall_elim)); + ENSURE_COND(vector_size(intro_types) == 1, + "SL forall_intro must have exactly one witness type variable"); + ENSURE_COND(vector_size(elim_types) == 1, + "SL forall_elim must have exactly one witness type variable"); + + type prop_type = theory->prop_type; + type intro_witness_type = intro_types[0]; + type intro_family_type = mk_fun_type(intro_witness_type, prop_type); + term intro_P = mk_var("__sl_forall_intro_P", prop_type); + term intro_Q = mk_var("__sl_forall_intro_Q", intro_family_type); + term intro_x = mk_var("__sl_forall_intro_x", intro_witness_type); + term intro_Q_x = mk_comb(intro_Q, intro_x); + term intro_pointwise = mk_forall( + intro_x, mk_binop(theory->entails, intro_P, intro_Q_x)); + term intro_forall_Q = + mk_icomb(theory->forall_op, mk_abs(intro_x, intro_Q_x)); + term intro_result = mk_binop(theory->entails, intro_P, intro_forall_Q); + term intro_schema = list_mk_forall( + TERM_LIST(intro_P, intro_Q), mk_imp(intro_pointwise, intro_result)); + ENSURE_COND(sl_check_exact_primitive( + "forall_intro", theory->forall_intro, intro_schema) == 0, + "Invalid SL primitive forall_intro"); + + type elim_witness_type = elim_types[0]; + type elim_family_type = mk_fun_type(elim_witness_type, prop_type); + term elim_P = mk_var("__sl_forall_elim_P", elim_family_type); + term elim_Q = mk_var("__sl_forall_elim_Q", prop_type); + term elim_w = mk_var("__sl_forall_elim_w", elim_witness_type); + term elim_x = mk_var("__sl_forall_elim_x", elim_witness_type); + term elim_P_w = mk_comb(elim_P, elim_w); + term elim_P_x = mk_comb(elim_P, elim_x); + term elim_premise = mk_binop(theory->entails, elim_P_w, elim_Q); + term elim_forall_P = + mk_icomb(theory->forall_op, mk_abs(elim_x, elim_P_x)); + term elim_result = mk_binop(theory->entails, elim_forall_P, elim_Q); + term elim_schema = list_mk_forall( + TERM_LIST(elim_P, elim_Q, elim_w), + mk_imp(elim_premise, elim_result)); + ENSURE_COND(sl_check_exact_primitive( + "forall_elim", theory->forall_elim, elim_schema) == 0, + "Invalid SL primitive forall_elim"); + return 0; +err: + ERR_FUN_PUTS("sl_check_universal_primitives"); + return -1; +} + +PROOF const sl_theory* sl_current_theory(void) { + ENSURE_COND(active_sl_theory_initialized, + "No SL theory is installed; call sl_install_theory first"); + return &active_sl_theory; +err: + ERR_FUN_PUTS("sl_current_theory"); + return &active_sl_theory; +} + +PROOF bool sl_theory_is_installed(void) { + return active_sl_theory_initialized; +} + +PROOF size_t sl_theory_generation(void) { + ENSURE_COND(active_sl_theory_initialized, + "No SL theory is installed; call sl_install_theory first"); + return active_sl_theory_generation; +err: + ERR_FUN_PUTS("sl_theory_generation"); + return 0; +} + +PROOF int sl_install_theory(const sl_theory* theory) { + sl_theory previous_theory = active_sl_theory; + bool previous_initialized = active_sl_theory_initialized; + size_t previous_generation = active_sl_theory_generation; + const char* previous_exists_name = active_sl_exists_name; + const char* previous_forall_name = active_sl_forall_name; + thm previous_ent_sym_left = sl_ent_sym_left; + thm previous_ent_restate = sl_ent_restate; + thm previous_frame_restate = sl_frame_restate; + thm previous_ent_frame_left = sl_ent_frame_left; + thm previous_ent_frame_right = sl_ent_frame_right; + thm previous_ent_subst_frame = sl_ent_subst_frame; + thm previous_sep_combine = sl_sep_combine; + thm previous_ac_rule = sl_ac_rule; + thm previous_disj_mono = sl_disj_mono; + thm previous_or_elim_frame = sl_or_elim_frame; + thm previous_exists_elim_frame = sl_exists_elim_frame; + thm previous_undisch = sl_undisch; + thm previous_conj1 = sl_conj1; + thm previous_conj2 = sl_conj2; + thm previous_disj1_mono = sl_disj1_mono; + thm previous_disj2_mono = sl_disj2_mono; + thm previous_exists_wit = sl_exists_wit; + thm previous_exists_mono_eta = sl_exists_mono_eta; + bool candidate_active = false; + + ENSURE_COND(theory != NULL, "SL theory bundle is null"); + ENSURE_COND(!IS_NULL(theory->prop_type), + "SL theory assertion type is empty"); + + type prop_type = theory->prop_type; + type_list prop_tyvars = type_tyvars(prop_type); + ENSURE_COND(vector_size(prop_tyvars) == 0, + "SL assertion type must be monomorphic"); + type bool_type = mk_bool_type(); + type assertion_to_assertion = mk_fun_type(prop_type, prop_type); + type bin_assertion_type = + mk_fun_type(prop_type, assertion_to_assertion); + type assertion_to_bool = mk_fun_type(prop_type, bool_type); + type relation_type = mk_fun_type(prop_type, assertion_to_bool); + type emp_type = type_of(theory->emp); + ENSURE_COND(equals_type(emp_type, prop_type), + "SL emp has the wrong type"); + type sep_type = type_of(theory->sep); + ENSURE_COND(equals_type(sep_type, bin_assertion_type), + "SL separating conjunction has the wrong type"); + type wand_type = type_of(theory->wand); + ENSURE_COND(equals_type(wand_type, bin_assertion_type), + "SL wand has the wrong type"); + type and_type = type_of(theory->and_op); + ENSURE_COND(equals_type(and_type, bin_assertion_type), + "SL additive conjunction has the wrong type"); + type or_type = type_of(theory->or_op); + ENSURE_COND(equals_type(or_type, bin_assertion_type), + "SL additive disjunction has the wrong type"); + type entails_type = type_of(theory->entails); + ENSURE_COND(equals_type(entails_type, relation_type), + "SL entailment has the wrong type"); + type equiv_type = type_of(theory->equiv); + ENSURE_COND(equals_type(equiv_type, relation_type), + "SL logical equivalence has the wrong type"); + type fact_type = type_of(theory->fact); + type expected_fact_type = mk_fun_type(bool_type, prop_type); + ENSURE_COND(equals_type(fact_type, expected_fact_type), + "SL fact embedding has the wrong type"); + + /* Existential quantification is polymorphic in its witness type. Check one + * explicitly instantiated concrete instance without imposing a parser + * binder name. */ + type_list exists_tyvars = term_tyvars(theory->exists_op); + ENSURE_COND(is_const(theory->exists_op), + "SL existential operator must be a HOL constant"); + ENSURE_COND(vector_size(exists_tyvars) == 1, + "SL existential operator must have exactly one witness type " + "variable"); + type bool_predicate_type = mk_fun_type(bool_type, prop_type); + term bool_predicate = + mk_var("__sl_bool_predicate", bool_predicate_type); + term exists_probe = mk_icomb(theory->exists_op, bool_predicate); + type exists_probe_type = type_of(exists_probe); + ENSURE_COND(equals_type(exists_probe_type, prop_type), + "SL existential operator has the wrong result type"); + + type_list forall_tyvars = term_tyvars(theory->forall_op); + ENSURE_COND(is_const(theory->forall_op), + "SL universal operator must be a HOL constant"); + ENSURE_COND(vector_size(forall_tyvars) == 1, + "SL universal operator must have exactly one witness type " + "variable"); + term forall_probe = mk_icomb(theory->forall_op, bool_predicate); + type forall_probe_type = type_of(forall_probe); + ENSURE_COND(equals_type(forall_probe_type, prop_type), + "SL universal operator has the wrong result type"); + + ENSURE_COND( + !IS_NULL(theory->sep_emp_left) && + !IS_NULL(theory->sep_emp_right) && + !IS_NULL(theory->sep_assoc) && !IS_NULL(theory->sep_comm) && + !IS_NULL(theory->sep_mono) && + !IS_NULL(theory->wand_sep_adjoint) && + !IS_NULL(theory->and_intro) && !IS_NULL(theory->and_elim1) && + !IS_NULL(theory->and_elim2) && !IS_NULL(theory->or_intro1) && + !IS_NULL(theory->or_intro2) && !IS_NULL(theory->or_elim) && + !IS_NULL(theory->exists_intro) && + !IS_NULL(theory->exists_elim) && + !IS_NULL(theory->exists_mono) && + !IS_NULL(theory->sep_exists_left) && + !IS_NULL(theory->sep_exists_right) && + !IS_NULL(theory->forall_intro) && + !IS_NULL(theory->forall_elim) && + !IS_NULL(theory->ent_refl) && !IS_NULL(theory->ent_trans) && + !IS_NULL(theory->equiv_intro) && + !IS_NULL(theory->fact_intro) && !IS_NULL(theory->fact_elim) && + !IS_NULL(theory->fact_dup) && + !IS_NULL(theory->fact_true_emp), + "SL theory bundle contains an empty primitive theorem"); + + ENSURE_COND(sl_check_existential_primitives(theory) == 0, + "SL existential primitive validation failed"); + ENSURE_COND(sl_check_universal_primitives(theory) == 0, + "SL universal primitive validation failed"); + + active_sl_theory = *theory; + active_sl_theory_initialized = true; + active_sl_theory_generation = previous_generation + 1; + active_sl_exists_name = GC_STRDUP(dest_const(theory->exists_op).s); + active_sl_forall_name = GC_STRDUP(dest_const(theory->forall_op).s); + candidate_active = true; + int derived_status = sl_build_derived_theorems(); + ENSURE_COND(derived_status == 0, + "SL derived theorem construction failed"); + + sl_clear_update_theory(); + candidate_active = false; + return 0; +err: + if (candidate_active) { + active_sl_theory = previous_theory; + active_sl_theory_initialized = previous_initialized; + active_sl_theory_generation = previous_generation; + active_sl_exists_name = previous_exists_name; + active_sl_forall_name = previous_forall_name; + sl_ent_sym_left = previous_ent_sym_left; + sl_ent_restate = previous_ent_restate; + sl_frame_restate = previous_frame_restate; + sl_ent_frame_left = previous_ent_frame_left; + sl_ent_frame_right = previous_ent_frame_right; + sl_ent_subst_frame = previous_ent_subst_frame; + sl_sep_combine = previous_sep_combine; + sl_ac_rule = previous_ac_rule; + sl_disj_mono = previous_disj_mono; + sl_or_elim_frame = previous_or_elim_frame; + sl_exists_elim_frame = previous_exists_elim_frame; + sl_undisch = previous_undisch; + sl_conj1 = previous_conj1; + sl_conj2 = previous_conj2; + sl_disj1_mono = previous_disj1_mono; + sl_disj2_mono = previous_disj2_mono; + sl_exists_wit = previous_exists_wit; + sl_exists_mono_eta = previous_exists_mono_eta; } + ERR_FUN_PUTS("sl_install_theory"); + return -1; +} + +PROOF int sl_install_update_theory(const sl_update_theory* theory) { + ENSURE_COND(active_sl_theory_initialized, + "Install an SL theory before its update theory"); + ENSURE_COND(theory != NULL, "SL update theory bundle is null"); + ENSURE_COND(!IS_NULL(theory->bupd), + "SL basic-update operator is empty"); + ENSURE_COND(!IS_NULL(theory->viewshift), + "SL view-shift operator is empty"); + + type prop_type = active_sl_theory.prop_type; + type bool_type = mk_bool_type(); + type expected_bupd_type = mk_fun_type(prop_type, prop_type); + type bupd_type = type_of(theory->bupd); + ENSURE_COND(equals_type(bupd_type, expected_bupd_type), + "SL basic-update operator has the wrong type"); + type assertion_to_bool = mk_fun_type(prop_type, bool_type); + type expected_viewshift_type = + mk_fun_type(prop_type, assertion_to_bool); + type viewshift_type = type_of(theory->viewshift); + ENSURE_COND(equals_type(viewshift_type, expected_viewshift_type), + "SL view-shift operator has the wrong type"); + + ENSURE_COND( + !IS_NULL(theory->bupd_intro) && + !IS_NULL(theory->bupd_mono) && + !IS_NULL(theory->bupd_idem) && + !IS_NULL(theory->bupd_frame) && + !IS_NULL(theory->viewshift_refl) && + !IS_NULL(theory->viewshift_entails) && + !IS_NULL(theory->viewshift_trans) && + !IS_NULL(theory->viewshift_mono) && + !IS_NULL(theory->viewshift_frame) && + !IS_NULL(theory->viewshift_sep) && + !IS_NULL(theory->viewshift_fact) && + !IS_NULL(theory->viewshift_exists), + "SL update theory contains an empty primitive theorem"); + + term P = mk_var("__sl_update_P", prop_type); + term Q = mk_var("__sl_update_Q", prop_type); + term S = mk_var("__sl_update_S", prop_type); + term P2 = mk_var("__sl_update_P2", prop_type); + term Q2 = mk_var("__sl_update_Q2", prop_type); + term F = mk_var("__sl_update_F", prop_type); + + term bP = mk_comb(theory->bupd, P); + term bQ = mk_comb(theory->bupd, Q); + term bbP = mk_comb(theory->bupd, bP); + term sep_P_F = mk_binop(active_sl_theory.sep, P, F); + term sep_Q_F = mk_binop(active_sl_theory.sep, Q, F); + term b_sep_P_F = mk_comb(theory->bupd, sep_P_F); + + term ent_P_Q = mk_binop(active_sl_theory.entails, P, Q); + term ent_P2_P = mk_binop(active_sl_theory.entails, P2, P); + term ent_Q_Q2 = mk_binop(active_sl_theory.entails, Q, Q2); + term ent_bP_bQ = mk_binop(active_sl_theory.entails, bP, bQ); + term view_P_Q = mk_binop(theory->viewshift, P, Q); + term view_Q_S = mk_binop(theory->viewshift, Q, S); + +#define CHECK_UPDATE_PRIMITIVE(field, expected) \ + int field##_status = \ + sl_check_exact_primitive(#field, theory->field, (expected)); \ + ENSURE_COND(field##_status == 0, \ + "Invalid SL update primitive %s", #field) + + term ent_P_bP = mk_binop(active_sl_theory.entails, P, bP); + term bupd_intro_schema = list_mk_forall(TERM_LIST(P), ent_P_bP); + CHECK_UPDATE_PRIMITIVE(bupd_intro, bupd_intro_schema); + + term bupd_mono_body = mk_imp(ent_P_Q, ent_bP_bQ); + term bupd_mono_schema = + list_mk_forall(TERM_LIST(P, Q), bupd_mono_body); + CHECK_UPDATE_PRIMITIVE(bupd_mono, bupd_mono_schema); + + term ent_bbP_bP = mk_binop(active_sl_theory.entails, bbP, bP); + term bupd_idem_schema = list_mk_forall(TERM_LIST(P), ent_bbP_bP); + CHECK_UPDATE_PRIMITIVE(bupd_idem, bupd_idem_schema); + + term sep_bP_F = mk_binop(active_sl_theory.sep, bP, F); + term ent_sep_bP_F = + mk_binop(active_sl_theory.entails, sep_bP_F, b_sep_P_F); + term bupd_frame_schema = + list_mk_forall(TERM_LIST(P, F), ent_sep_bP_F); + CHECK_UPDATE_PRIMITIVE(bupd_frame, bupd_frame_schema); + + term view_P_P = mk_binop(theory->viewshift, P, P); + term viewshift_refl_schema = list_mk_forall(TERM_LIST(P), view_P_P); + CHECK_UPDATE_PRIMITIVE(viewshift_refl, viewshift_refl_schema); + + term viewshift_entails_body = mk_imp(ent_P_Q, view_P_Q); + term viewshift_entails_schema = + list_mk_forall(TERM_LIST(P, Q), viewshift_entails_body); + CHECK_UPDATE_PRIMITIVE(viewshift_entails, viewshift_entails_schema); + + term view_P_S = mk_binop(theory->viewshift, P, S); + term viewshift_trans_tail = mk_imp(view_Q_S, view_P_S); + term viewshift_trans_body = mk_imp(view_P_Q, viewshift_trans_tail); + term viewshift_trans_schema = + list_mk_forall(TERM_LIST(P, Q, S), viewshift_trans_body); + CHECK_UPDATE_PRIMITIVE(viewshift_trans, viewshift_trans_schema); + + term view_P2_Q2 = mk_binop(theory->viewshift, P2, Q2); + term viewshift_mono_post = mk_imp(ent_Q_Q2, view_P2_Q2); + term viewshift_mono_change = mk_imp(view_P_Q, viewshift_mono_post); + term viewshift_mono_body = mk_imp(ent_P2_P, viewshift_mono_change); + term viewshift_mono_schema = list_mk_forall( + TERM_LIST(P2, P, Q, Q2), viewshift_mono_body); + CHECK_UPDATE_PRIMITIVE(viewshift_mono, viewshift_mono_schema); + + term view_sep_P_F_Q_F = + mk_binop(theory->viewshift, sep_P_F, sep_Q_F); + term viewshift_frame_body = mk_imp(view_P_Q, view_sep_P_F_Q_F); + term viewshift_frame_schema = + list_mk_forall(TERM_LIST(P, Q, F), viewshift_frame_body); + CHECK_UPDATE_PRIMITIVE(viewshift_frame, viewshift_frame_schema); + + term P1 = mk_var("__sl_update_P1", prop_type); + term Q1 = mk_var("__sl_update_Q1", prop_type); + term view_P1_Q1 = mk_binop(theory->viewshift, P1, Q1); + term view_P2_Q2_for_sep = mk_binop(theory->viewshift, P2, Q2); + term sep_P1_P2 = mk_binop(active_sl_theory.sep, P1, P2); + term sep_Q1_Q2 = mk_binop(active_sl_theory.sep, Q1, Q2); + term view_sep_P1_P2_Q1_Q2 = + mk_binop(theory->viewshift, sep_P1_P2, sep_Q1_Q2); + term viewshift_sep_tail = + mk_imp(view_P2_Q2_for_sep, view_sep_P1_P2_Q1_Q2); + term viewshift_sep_body = mk_imp(view_P1_Q1, viewshift_sep_tail); + term viewshift_sep_schema = list_mk_forall( + TERM_LIST(P1, Q1, P2, Q2), viewshift_sep_body); + CHECK_UPDATE_PRIMITIVE(viewshift_sep, viewshift_sep_schema); + + term guard = mk_var("__sl_update_guard", bool_type); + term fact_guard = mk_comb(active_sl_theory.fact, guard); + term sep_fact_P = mk_binop(active_sl_theory.sep, fact_guard, P); + term sep_fact_Q = mk_binop(active_sl_theory.sep, fact_guard, Q); + term guarded_view = mk_imp(guard, view_P_Q); + term view_sep_fact = + mk_binop(theory->viewshift, sep_fact_P, sep_fact_Q); + term viewshift_fact_body = mk_imp(guarded_view, view_sep_fact); + term viewshift_fact_schema = list_mk_forall( + TERM_LIST(guard, P, Q), viewshift_fact_body); + CHECK_UPDATE_PRIMITIVE(viewshift_fact, viewshift_fact_schema); + + term viewshift_exists_ccl = concl(theory->viewshift_exists); + type_list witness_types = term_tyvars(viewshift_exists_ccl); + ENSURE_COND(vector_size(witness_types) == 1, + "SL viewshift_exists primitive must have exactly one witness " + "type variable"); + type witness_type = witness_types[0]; + type witness_family_type = mk_fun_type(witness_type, prop_type); + term PX = mk_var("__sl_update_PX", witness_family_type); + term QX = mk_var("__sl_update_QX", witness_family_type); + term x = mk_var("__sl_update_x", witness_type); + term P_x = mk_comb(PX, x); + term Q_x = mk_comb(QX, x); + /* The public existential interface is eta-long: the endpoint is the binder + * `exists x. P x`, never the merely eta-equivalent application `exists P`. */ + term exists_P = + mk_icomb(active_sl_theory.exists_op, mk_abs(x, P_x)); + term exists_Q = + mk_icomb(active_sl_theory.exists_op, mk_abs(x, Q_x)); + term pointwise_change = mk_binop(theory->viewshift, P_x, Q_x); + term pointwise = list_mk_forall(TERM_LIST(x), pointwise_change); + term exists_change = mk_binop(theory->viewshift, exists_P, exists_Q); + term viewshift_exists_body = mk_imp(pointwise, exists_change); + term viewshift_exists_schema = + list_mk_forall(TERM_LIST(PX, QX), viewshift_exists_body); + CHECK_UPDATE_PRIMITIVE(viewshift_exists, viewshift_exists_schema); + +#undef CHECK_UPDATE_PRIMITIVE + + active_sl_update_theory = *theory; + active_sl_update_theory_initialized = true; + active_sl_update_theory_generation = active_sl_theory_generation; + return 0; +err: + ERR_FUN_PUTS("sl_install_update_theory"); + return -1; +} + +PROOF bool sl_update_theory_is_installed(void) { + return active_sl_theory_initialized && + active_sl_update_theory_initialized && + active_sl_update_theory_generation == active_sl_theory_generation; +} + +PROOF const sl_update_theory* sl_current_update_theory(void) { + ENSURE_COND( + sl_update_theory_is_installed(), + "No update theory is installed for the active SL generation"); + return &active_sl_update_theory; +err: + ERR_FUN_PUTS("sl_current_update_theory"); + return &active_sl_update_theory; +} + +PROOF term sl_raw_eq(void) { + type prop_type = sl_prop(); + term probe = mk_var("__sl_eq_probe", prop_type); + term equation = mk_eq(probe, probe); + dest_comb_results rhs_application = dest_comb(equation); + dest_comb_results lhs_application = dest_comb(rhs_application.tm1); + return lhs_application.tm1; +err: + ERR_FUN_PUTS("sl_raw_eq"); + return empty_term; } PROOF bool is_sl_prop(const term tm) { - return equals_type(type_of(tm), sl_prop()); + type tm_type = type_of(tm); + type prop_type = sl_prop(); + bool result = equals_type(tm_type, prop_type); + return result; } PROOF term mk_sl_prop(const char* s) { - return mk_var(s, sl_prop()); + type prop_type = sl_prop(); + term result = mk_var(s, prop_type); + return result; } PROOF bool is_sl_emp(const term tm) { - return equals_term(tm, sl_emp()); + term emp = sl_emp(); + bool result = equals_term(tm, emp); + return result; } PROOF bool is_sl_sep(const term hp) { - return is_binop(sl_sep(), hp); + term sep = sl_sep(); + bool result = is_binop(sep, hp); + return result; } PROOF term mk_sl_sep(const term hp1, const term hp2) { - term res_tm = mk_binop(sl_sep(), hp1, hp2); + term sep = sl_sep(); + term res_tm = mk_binop(sep, hp1, hp2); return res_tm; err: ERR_FUN_PUTS("mk_sl_sep", cstr_term(hp1), cstr_term(hp2)); @@ -64,7 +726,8 @@ err: } PROOF dest_binop_results dest_sl_sep(const term hp) { - dest_binop_results res = dest_binop(sl_sep(), hp); + term sep = sl_sep(); + dest_binop_results res = dest_binop(sep, hp); return res; err: ERR_FUN_PUTS("dest_sl_sep", cstr_term(hp)); @@ -72,11 +735,14 @@ err: } PROOF bool is_sl_wand(const term hp) { - return is_binop(sl_wand(), hp); + term wand = sl_wand(); + bool result = is_binop(wand, hp); + return result; } PROOF term mk_sl_wand(const term hp1, const term hp2) { - term res_tm = mk_binop(sl_wand(), hp1, hp2); + term wand = sl_wand(); + term res_tm = mk_binop(wand, hp1, hp2); return res_tm; err: ERR_FUN_PUTS("mk_sl_wand", cstr_term(hp1), cstr_term(hp2)); @@ -84,7 +750,8 @@ err: } PROOF dest_binop_results dest_sl_wand(const term hp) { - dest_binop_results res = dest_binop(sl_wand(), hp); + term wand = sl_wand(); + dest_binop_results res = dest_binop(wand, hp); return res; err: ERR_FUN_PUTS("dest_sl_wand", cstr_term(hp)); @@ -92,11 +759,14 @@ err: } PROOF bool is_sl_and(const term hp) { - return is_binop(sl_and(), hp); + term and_op = sl_and(); + bool result = is_binop(and_op, hp); + return result; } PROOF term mk_sl_and(const term hp1, const term hp2) { - term res_tm = mk_binop(sl_and(), hp1, hp2); + term and_op = sl_and(); + term res_tm = mk_binop(and_op, hp1, hp2); return res_tm; err: ERR_FUN_PUTS("mk_sl_and", cstr_term(hp1), cstr_term(hp2)); @@ -104,7 +774,8 @@ err: } PROOF dest_binop_results dest_sl_and(const term hp) { - dest_binop_results res = dest_binop(sl_and(), hp); + term and_op = sl_and(); + dest_binop_results res = dest_binop(and_op, hp); return res; err: ERR_FUN_PUTS("dest_sl_and", cstr_term(hp)); @@ -112,11 +783,14 @@ err: } PROOF bool is_sl_or(const term hp) { - return is_binop(sl_or(), hp); + term or_op = sl_or(); + bool result = is_binop(or_op, hp); + return result; } PROOF term mk_sl_or(const term hp1, const term hp2) { - term res_tm = mk_binop(sl_or(), hp1, hp2); + term or_op = sl_or(); + term res_tm = mk_binop(or_op, hp1, hp2); return res_tm; err: ERR_FUN_PUTS("mk_sl_or", cstr_term(hp1), cstr_term(hp2)); @@ -124,19 +798,46 @@ err: } PROOF dest_binop_results dest_sl_or(const term hp) { - dest_binop_results res = dest_binop(sl_or(), hp); + term or_op = sl_or(); + dest_binop_results res = dest_binop(or_op, hp); return res; err: ERR_FUN_PUTS("dest_sl_or", cstr_term(hp)); return (dest_binop_results){empty_term, empty_term}; } +/* HOL constant names are unique within a session. The installer requires both + * binder operators to be constants and caches their names, so witness-type + * instances can be recognized without reconstructing or matching a term. */ +PROOF static bool is_sl_binder_application(const term tm, + const char* binder_name) { + if (!is_comb(tm)) return false; + + dest_comb_results application = dest_comb(tm); + if (!is_abs(application.tm2)) return false; + proof_try_begin(); + dest_const_results head = dest_const(application.tm1); + bool failed = NOT_OK; + if (failed) SET_OK(); + proof_try_end(); + return !failed && strcmp(head.s, binder_name) == 0; +} + PROOF bool is_sl_exists(const term tm) { - return is_binder(sl_exists_str(), tm); + if (active_sl_exists_name == NULL) { + sl_current_theory(); + return false; + } + return is_sl_binder_application(tm, active_sl_exists_name); } PROOF term mk_sl_exists(const term v, const term hp) { - term res_tm = mk_binder(sl_exists_str(), v, hp); + ENSURE_COND(is_var(v), "Term(`%s`) is not a variable", string_of_term(v)); + ENSURE_COND(is_sl_prop(hp), + "Term(`%s`) is not a separation logic proposition", + string_of_term(hp)); + term family = mk_abs(v, hp); + term res_tm = mk_icomb(sl_exists(), family); return res_tm; err: ERR_FUN_PUTS("mk_sl_exists", cstr_term(v), cstr_term(hp)); @@ -144,8 +845,11 @@ err: } PROOF dest_binder_results dest_sl_exists(const term hp) { - dest_binder_results res = dest_binder(sl_exists_str(), hp); - return res; + ENSURE_COND(is_sl_exists(hp), + "Term(`%s`) is not an SL existential", string_of_term(hp)); + dest_comb_results application = dest_comb(hp); + dest_abs_results abstraction = dest_abs(application.tm2); + return (dest_binder_results){abstraction.v, abstraction.tm}; err: ERR_FUN_PUTS("dest_sl_exists", cstr_term(hp)); return (dest_binder_results){empty_term, empty_term}; @@ -165,6 +869,37 @@ err: return empty_term; } +PROOF bool is_sl_forall(const term tm) { + if (active_sl_forall_name == NULL) { + sl_current_theory(); + return false; + } + return is_sl_binder_application(tm, active_sl_forall_name); +} + +PROOF term mk_sl_forall(const term v, const term hp) { + ENSURE_COND(is_var(v), "Term(`%s`) is not a variable", string_of_term(v)); + ENSURE_COND(is_sl_prop(hp), + "Term(`%s`) is not a separation logic proposition", + string_of_term(hp)); + term family = mk_abs(v, hp); + return mk_icomb(sl_forall(), family); +err: + ERR_FUN_PUTS("mk_sl_forall", cstr_term(v), cstr_term(hp)); + return empty_term; +} + +PROOF dest_binder_results dest_sl_forall(const term hp) { + ENSURE_COND(is_sl_forall(hp), + "Term(`%s`) is not an SL universal", string_of_term(hp)); + dest_comb_results application = dest_comb(hp); + dest_abs_results abstraction = dest_abs(application.tm2); + return (dest_binder_results){abstraction.v, abstraction.tm}; +err: + ERR_FUN_PUTS("dest_sl_forall", cstr_term(hp)); + return (dest_binder_results){empty_term, empty_term}; +} + PROOF strip_sl_exists_results strip_sl_exists(const term hp) { ENSURE_COND(is_sl_prop(hp), "Term(`%s`) is not a separation logic proposition", @@ -183,6 +918,70 @@ err: return (strip_sl_exists_results){NULL, empty_term}; } +PROOF bool is_sl_bupd(const term tm) { + if (!sl_update_theory_is_installed() || !is_comb(tm)) return false; + const sl_update_theory* update = &active_sl_update_theory; + dest_comb_results application = dest_comb(tm); + bool result = equals_term(application.tm1, update->bupd); + return result; +} + +PROOF term mk_sl_bupd(const term hp) { + bool hp_is_prop = is_sl_prop(hp); + ENSURE_COND(hp_is_prop, + "Term(`%s`) is not an active SL assertion", + string_of_term(hp)); + const sl_update_theory* update = sl_current_update_theory(); + term result = mk_comb(update->bupd, hp); + return result; +err: + ERR_FUN_PUTS("mk_sl_bupd", cstr_term(hp)); + return empty_term; +} + +PROOF term dest_sl_bupd(const term tm) { + bool tm_is_bupd = is_sl_bupd(tm); + ENSURE_COND(tm_is_bupd, "Term(`%s`) is not a basic update", + string_of_term(tm)); + dest_comb_results application = dest_comb(tm); + return application.tm2; +err: + ERR_FUN_PUTS("dest_sl_bupd", cstr_term(tm)); + return empty_term; +} + +PROOF bool is_sl_viewshift(const term tm) { + if (!sl_update_theory_is_installed()) return false; + const sl_update_theory* update = &active_sl_update_theory; + bool result = is_binop(update->viewshift, tm); + return result; +} + +PROOF term mk_sl_viewshift(const term hp1, const term hp2) { + bool hp1_is_prop = is_sl_prop(hp1); + bool hp2_is_prop = is_sl_prop(hp2); + ENSURE_COND(hp1_is_prop && hp2_is_prop, + "View-shift endpoints must have the active assertion type"); + const sl_update_theory* update = sl_current_update_theory(); + term result = mk_binop(update->viewshift, hp1, hp2); + return result; +err: + ERR_FUN_PUTS("mk_sl_viewshift", cstr_term(hp1), cstr_term(hp2)); + return empty_term; +} + +PROOF dest_binop_results dest_sl_viewshift(const term tm) { + bool tm_is_viewshift = is_sl_viewshift(tm); + ENSURE_COND(tm_is_viewshift, "Term(`%s`) is not a view shift", + string_of_term(tm)); + const sl_update_theory* update = sl_current_update_theory(); + dest_binop_results result = dest_binop(update->viewshift, tm); + return result; +err: + ERR_FUN_PUTS("dest_sl_viewshift", cstr_term(tm)); + return (dest_binop_results){empty_term, empty_term}; +} + PROOF bool is_sl_ent(const term tm) { return is_binop(sl_ent(), tm); } @@ -203,6 +1002,26 @@ err: return (dest_binop_results){empty_term, empty_term}; } +PROOF bool is_sl_equiv(const term tm) { + return is_binop(sl_equiv(), tm); +} + +PROOF term mk_sl_equiv(const term hp1, const term hp2) { + term res_tm = mk_binop(sl_equiv(), hp1, hp2); + return res_tm; +err: + ERR_FUN_PUTS("mk_sl_equiv", cstr_term(hp1), cstr_term(hp2)); + return empty_term; +} + +PROOF dest_binop_results dest_sl_equiv(const term tm) { + dest_binop_results res = dest_binop(sl_equiv(), tm); + return res; +err: + ERR_FUN_PUTS("dest_sl_equiv", cstr_term(tm)); + return (dest_binop_results){empty_term, empty_term}; +} + PROOF bool is_sl_eq(const term tm) { return is_binop(sl_eq(), tm); } @@ -276,7 +1095,7 @@ PROOF term_list strip_sl_resources(const term hp) { return resources; } -PROOF thm prove_sl_ent_sym_left() { +PROOF static thm prove_sl_ent_sym_left(void) { thm ent_refl_th = sl_ent_refl(); term hp1 = mk_sl_prop("hp1"); term hp2 = mk_sl_prop("hp2"); @@ -294,9 +1113,7 @@ PROOF thm prove_sl_ent_sym_left() { return res_th; } -SL_THM_LAZY_INIT(sl_ent_sym_left, "!hp1 hp2. (hp1 = hp2) ==> (hp1 |-- hp2)"); - -PROOF thm prove_sl_ent_restate() { +PROOF static thm prove_sl_ent_restate(void) { term original_h = mk_sl_prop("original_h"); term current_h = mk_sl_prop("current_h"); term original_k = mk_sl_prop("original_k"); @@ -323,14 +1140,7 @@ PROOF thm prove_sl_ent_restate() { return generalized; } -SL_THM_LAZY_INIT( - sl_ent_restate, - "!(original_h:hprop) (current_h:hprop) (original_k:hprop) " - "(current_k:hprop). (original_h -|- current_h) ==> " - "(original_k -|- current_k) ==> (current_h |-- current_k) ==> " - "(original_h |-- original_k)"); - -PROOF thm prove_sl_frame_restate() { +PROOF static thm prove_sl_frame_restate(void) { term original_h = mk_sl_prop("original_h"); term frame = mk_sl_prop("frame"); term child_h = mk_sl_prop("child_h"); @@ -345,7 +1155,7 @@ PROOF thm prove_sl_frame_restate() { thm child_ent = assume_rule(child_ent_tm); thm framed = frame_left_slrule(frame, child_ent); - thm result = list_match_mp_rule(sl_ent_restate(), + thm result = list_match_mp_rule(sl_ent_restate, THM_LIST(h_eq, k_eq, framed)); result = disch_rule(child_ent_tm, result); result = disch_rule(k_eq_tm, result); @@ -355,15 +1165,7 @@ PROOF thm prove_sl_frame_restate() { return generalized; } -SL_THM_LAZY_INIT( - sl_frame_restate, - "!(original_h:hprop) (frame:hprop) (child_h:hprop) " - "(original_k:hprop) (child_k:hprop). " - "(original_h -|- frame ** child_h) ==> " - "(original_k -|- frame ** child_k) ==> (child_h |-- child_k) ==> " - "(original_h |-- original_k)"); - -PROOF thm prove_sl_ent_frame_left() { +PROOF static thm prove_sl_ent_frame_left(void) { thm sep_mono_th = sl_sep_mono(); term hp1 = mk_sl_prop("hp1"); term hp2 = mk_sl_prop("hp2"); @@ -378,10 +1180,7 @@ PROOF thm prove_sl_ent_frame_left() { return res_th; } -SL_THM_LAZY_INIT(sl_ent_frame_left, - "!hp1 hp2 hp3. (hp1 |-- hp2) ==> (hp3 ** hp1 |-- hp3 ** hp2)"); - -PROOF thm prove_sl_ent_frame_right() { +PROOF static thm prove_sl_ent_frame_right(void) { thm sep_mono_th = sl_sep_mono(); term hp1 = mk_sl_prop("hp1"); term hp2 = mk_sl_prop("hp2"); @@ -396,10 +1195,7 @@ PROOF thm prove_sl_ent_frame_right() { return res_th; } -SL_THM_LAZY_INIT(sl_ent_frame_right, - "!hp1 hp2 hp3. (hp1 |-- hp2) ==> (hp1 ** hp3 |-- hp2 ** hp3)"); - -PROOF thm prove_sl_ent_subst_frame() { +PROOF static thm prove_sl_ent_subst_frame(void) { term old_hp = mk_sl_prop("old_hp"); term new_hp = mk_sl_prop("new_hp"); term frame = mk_sl_prop("frame"); @@ -426,14 +1222,7 @@ PROOF thm prove_sl_ent_subst_frame() { return generalized; } -SL_THM_LAZY_INIT( - sl_ent_subst_frame, - "!(old_hp:hprop) (new_hp:hprop) (frame:hprop) (current:hprop) " - "(hcon:hprop). (old_hp -|- new_hp) ==> " - "(current -|- new_hp ** frame) ==> (current |-- hcon) ==> " - "(old_hp ** frame |-- hcon)"); - -PROOF thm prove_sl_sep_combine() { +PROOF static thm prove_sl_sep_combine(void) { term parent_h = mk_sl_prop("parent_h"); term child_h1 = mk_sl_prop("child_h1"); term child_h2 = mk_sl_prop("child_h2"); @@ -452,7 +1241,7 @@ PROOF thm prove_sl_sep_combine() { thm combined = frame_mono_slrule(child1, child2); thm result = list_match_mp_rule( - sl_ent_restate(), THM_LIST(h_eq, k_eq, combined)); + sl_ent_restate, THM_LIST(h_eq, k_eq, combined)); result = disch_rule(child2_tm, result); result = disch_rule(child1_tm, result); result = disch_rule(k_eq_tm, result); @@ -463,16 +1252,7 @@ PROOF thm prove_sl_sep_combine() { return generalized; } -SL_THM_LAZY_INIT( - sl_sep_combine, - "!(parent_h:hprop) (child_h1:hprop) (child_h2:hprop) " - "(parent_k:hprop) (child_k1:hprop) (child_k2:hprop). " - "(parent_h -|- child_h1 ** child_h2) ==> " - "(parent_k -|- child_k1 ** child_k2) ==> " - "(child_h1 |-- child_k1) ==> (child_h2 |-- child_k2) ==> " - "(parent_h |-- parent_k)"); - -PROOF thm prove_sl_ac_rule() { +PROOF static thm prove_sl_ac_rule(void) { term hp1 = mk_sl_prop("hp1"); term hp2 = mk_sl_prop("hp2"); term hp3 = mk_sl_prop("hp3"); @@ -488,12 +1268,6 @@ PROOF thm prove_sl_ac_rule() { return conj_rule(sl_sep_comm(), conj_rule(sl_sep_assoc(), left_comm)); } -SL_THM_LAZY_INIT(sl_ac_rule, - "(!hp1 hp2. (hp1 ** hp2) = (hp2 ** hp1)) &&" - "(!hp1 hp2 hp3. ((hp1 ** hp2) ** hp3) = " - "(hp1 ** hp2 ** hp3)) &&" - "(!hp1 hp2 hp3. (hp1 ** hp2 ** hp3) = " - "(hp2 ** hp1 ** hp3))"); /* * Basic entailment/equality rules @@ -522,15 +1296,16 @@ PROOF thm trans_slrule(const thm ent1, const thm ent2) { string_of_thm(ent2)); thm trans_th = sl_ent_trans(); - thm res_ent = list_match_mp_rule(trans_th, THM_LIST(ent1, ent2)); - return res_ent; + thm_list premises = THM_LIST(ent1, ent2); + thm result = list_match_mp_rule(trans_th, premises); + return result; err: ERR_FUN_PUTS("trans_slrule", cstr_thm(ent1), cstr_thm(ent2)); return empty_theorem; } PROOF thm eq2ent(const thm eq) { - thm eq2ent_th = sl_ent_sym_left(); + thm eq2ent_th = sl_ent_sym_left; thm res_ent = match_mp_rule(eq2ent_th, eq); return res_ent; err: @@ -538,7 +1313,7 @@ err: return empty_theorem; } -PROOF thm antisym_slrule(const thm ent1, const thm ent2) { +PROOF thm equiv_slrule(const thm ent1, const thm ent2) { term ent1_tm = concl(ent1); term ent2_tm = concl(ent2); dest_binop_results ent1_dest = dest_sl_ent(ent1_tm); @@ -548,16 +1323,294 @@ PROOF thm antisym_slrule(const thm ent1, const thm ent2) { "Theorems(`%s`, `%s`) are not antisymmetric", string_of_thm(ent1), string_of_thm(ent2)); - thm antisym_th = sl_ent_antisym(); - thm res_ent = list_match_mp_rule(antisym_th, THM_LIST(ent1, ent2)); - return res_ent; + thm equiv_intro = sl_equiv_intro(); + thm res_equiv = + list_match_mp_rule(equiv_intro, THM_LIST(ent1, ent2)); + return res_equiv; +err: + ERR_FUN_PUTS("equiv_slrule", cstr_thm(ent1), cstr_thm(ent2)); + return empty_theorem; +} + +PROOF thm antisym_slrule(const thm ent1, const thm ent2) { + thm result = equiv_slrule(ent1, ent2); + return result; err: ERR_FUN_PUTS("antisym_slrule", cstr_thm(ent1), cstr_thm(ent2)); return empty_theorem; } +PROOF thm bupd_intro_slrule(const term hp) { + bool hp_is_prop = is_sl_prop(hp); + ENSURE_COND(hp_is_prop, + "Term(`%s`) is not an active SL assertion", + string_of_term(hp)); + thm primitive = sl_bupd_intro_primitive(); + thm result = ispec_rule(hp, primitive); + return result; +err: + ERR_FUN_PUTS("bupd_intro_slrule", cstr_term(hp)); + return empty_theorem; +} + +PROOF thm bupd_mono_slrule(const thm ent) { + term ent_ccl = concl(ent); + dest_binop_results endpoints = dest_sl_ent(ent_ccl); + thm primitive = sl_bupd_mono_primitive(); + thm instance = + ispecl_rule(TERM_LIST(endpoints.tm1, endpoints.tm2), primitive); + thm result = match_mp_rule(instance, ent); + return result; +err: + ERR_FUN_PUTS("bupd_mono_slrule", cstr_thm(ent)); + return empty_theorem; +} + +PROOF thm bupd_idem_slrule(const term hp) { + bool hp_is_prop = is_sl_prop(hp); + ENSURE_COND(hp_is_prop, + "Term(`%s`) is not an active SL assertion", + string_of_term(hp)); + thm primitive = sl_bupd_idem_primitive(); + thm result = ispec_rule(hp, primitive); + return result; +err: + ERR_FUN_PUTS("bupd_idem_slrule", cstr_term(hp)); + return empty_theorem; +} + +PROOF thm bupd_frame_slrule(const term hp, const term frame) { + bool hp_is_prop = is_sl_prop(hp); + bool frame_is_prop = is_sl_prop(frame); + ENSURE_COND(hp_is_prop && frame_is_prop, + "Basic-update frame endpoints must be active SL assertions"); + thm primitive = sl_bupd_frame_primitive(); + thm result = ispecl_rule(TERM_LIST(hp, frame), primitive); + return result; +err: + ERR_FUN_PUTS("bupd_frame_slrule", cstr_term(hp), cstr_term(frame)); + return empty_theorem; +} + +PROOF thm viewshift_refl_slrule(const term hp) { + bool hp_is_prop = is_sl_prop(hp); + ENSURE_COND(hp_is_prop, + "Term(`%s`) is not an active SL assertion", + string_of_term(hp)); + thm primitive = sl_viewshift_refl_primitive(); + thm result = ispec_rule(hp, primitive); + return result; +err: + ERR_FUN_PUTS("viewshift_refl_slrule", cstr_term(hp)); + return empty_theorem; +} + +PROOF thm entails_viewshift_slrule(const thm ent) { + term ent_ccl = concl(ent); + dest_binop_results endpoints = dest_sl_ent(ent_ccl); + thm primitive = sl_entails_viewshift_primitive(); + thm instance = + ispecl_rule(TERM_LIST(endpoints.tm1, endpoints.tm2), primitive); + thm result = match_mp_rule(instance, ent); + return result; +err: + ERR_FUN_PUTS("entails_viewshift_slrule", cstr_thm(ent)); + return empty_theorem; +} + +PROOF thm viewshift_trans_slrule(const thm first, const thm second) { + term first_ccl = concl(first); + dest_binop_results first_endpoints = dest_sl_viewshift(first_ccl); + term second_ccl = concl(second); + dest_binop_results second_endpoints = dest_sl_viewshift(second_ccl); + int endpoint_order = + alpha_compare(first_endpoints.tm2, second_endpoints.tm1); + ENSURE_COND(endpoint_order == 0, "View shifts are not composable"); + + thm primitive = sl_viewshift_trans_primitive(); + thm instance = ispecl_rule( + TERM_LIST(first_endpoints.tm1, first_endpoints.tm2, + second_endpoints.tm2), + primitive); + thm after_first = match_mp_rule(instance, first); + thm result = match_mp_rule(after_first, second); + return result; +err: + ERR_FUN_PUTS("viewshift_trans_slrule", cstr_thm(first), cstr_thm(second)); + return empty_theorem; +} + +PROOF thm viewshift_mono_slrule(const thm pre_ent, const thm change, + const thm post_ent) { + term pre_ccl = concl(pre_ent); + dest_binop_results pre = dest_sl_ent(pre_ccl); + term change_ccl = concl(change); + dest_binop_results middle = dest_sl_viewshift(change_ccl); + term post_ccl = concl(post_ent); + dest_binop_results post = dest_sl_ent(post_ccl); + int pre_order = alpha_compare(pre.tm2, middle.tm1); + int post_order = alpha_compare(middle.tm2, post.tm1); + ENSURE_COND(pre_order == 0 && post_order == 0, + "View-shift consequence theorems do not share endpoints"); + + thm primitive = sl_viewshift_mono_primitive(); + thm instance = ispecl_rule( + TERM_LIST(pre.tm1, pre.tm2, middle.tm2, post.tm2), primitive); + thm after_pre = match_mp_rule(instance, pre_ent); + thm after_change = match_mp_rule(after_pre, change); + thm result = match_mp_rule(after_change, post_ent); + return result; +err: + ERR_FUN_PUTS("viewshift_mono_slrule", cstr_thm(pre_ent), + cstr_thm(change), cstr_thm(post_ent)); + return empty_theorem; +} + +PROOF thm viewshift_frame_slrule(const thm change, const term frame) { + term change_ccl = concl(change); + dest_binop_results endpoints = dest_sl_viewshift(change_ccl); + bool frame_is_prop = is_sl_prop(frame); + ENSURE_COND(frame_is_prop, + "Term(`%s`) is not an active SL assertion", + string_of_term(frame)); + thm primitive = sl_viewshift_frame_primitive(); + thm instance = ispecl_rule( + TERM_LIST(endpoints.tm1, endpoints.tm2, frame), primitive); + thm result = match_mp_rule(instance, change); + return result; +err: + ERR_FUN_PUTS("viewshift_frame_slrule", cstr_thm(change), + cstr_term(frame)); + return empty_theorem; +} + +PROOF thm viewshift_sep_slrule(const thm first, const thm second) { + term first_ccl = concl(first); + dest_binop_results first_endpoints = dest_sl_viewshift(first_ccl); + term second_ccl = concl(second); + dest_binop_results second_endpoints = dest_sl_viewshift(second_ccl); + thm primitive = sl_viewshift_sep_primitive(); + thm instance = ispecl_rule( + TERM_LIST(first_endpoints.tm1, first_endpoints.tm2, + second_endpoints.tm1, second_endpoints.tm2), + primitive); + thm after_first = match_mp_rule(instance, first); + thm result = match_mp_rule(after_first, second); + return result; +err: + ERR_FUN_PUTS("viewshift_sep_slrule", cstr_thm(first), cstr_thm(second)); + return empty_theorem; +} + +PROOF thm viewshift_elim_fact_slrule(const term p, const thm change) { + ENSURE_COND(equals_type(type_of(p), mk_bool_type()), + "View-shift fact guard is not Boolean"); + dest_binop_results endpoints = dest_sl_viewshift(concl(change)); + thm guarded = disch_rule(p, change); + thm primitive = sl_viewshift_fact_primitive(); + thm instance = ispecl_rule( + TERM_LIST(p, endpoints.tm1, endpoints.tm2), + primitive); + return match_mp_rule(instance, guarded); +err: + ERR_FUN_PUTS( + "viewshift_elim_fact_slrule", + cstr_term(p), + cstr_thm(change)); + return empty_theorem; +} + +/* Contract only the four family applications introduced by specializing a + * pointwise existential law: + * + * (!x. (\v. H) x REL (\v. K) x) ==> + * EX (\x. (\v. H) x) REL EX (\x. (\v. K) x). + * + * The conversion never descends into H or K, so beta-redexes already present + * in caller assertions remain part of their exact syntax. */ +PROOF static thm beta_pointwise_family_instance(const thm instance) { + conv beta = get_conversion_by_name("BETA_CONV"); + conv premise = land_conv(binder_conv(binop_conv(beta))); + conv endpoints = rand_conv(binop_conv(binder_conv(beta))); + thm result = conv_rule(then_conv(premise, endpoints), instance); + return result; +err: + ERR_FUN_PUTS("beta_pointwise_family_instance", cstr_thm(instance)); + return empty_theorem; +} + +PROOF thm viewshift_exists_slrule(const thm pointwise) { + term pointwise_ccl = concl(pointwise); + dest_forall_results quantified = dest_forall(pointwise_ccl); + term witness = quantified.v; + dest_binop_results endpoints = dest_sl_viewshift(quantified.tm); + term source_family = mk_abs(witness, endpoints.tm1); + term target_family = mk_abs(witness, endpoints.tm2); + + thm primitive = sl_viewshift_exists_primitive(); + thm instance = ispecl_rule( + TERM_LIST(source_family, target_family), primitive); + instance = beta_pointwise_family_instance(instance); + thm result = match_mp_rule(instance, pointwise); + term exact_source = mk_sl_exists(witness, endpoints.tm1); + term exact_target = mk_sl_exists(witness, endpoints.tm2); + term exact_conclusion = mk_sl_viewshift(exact_source, exact_target); + term actual_conclusion = concl(result); + ENSURE_COND(alpha_compare(actual_conclusion, exact_conclusion) == 0, + "Existential view shift has conclusion `%s`; expected `%s`", + string_of_term(actual_conclusion), + string_of_term(exact_conclusion)); + if (!equals_term(actual_conclusion, exact_conclusion)) { + thm alignment = alpha_rule(actual_conclusion, exact_conclusion); + result = eq_mp_rule(alignment, result); + } + return result; +err: + ERR_FUN_PUTS("viewshift_exists_slrule", cstr_thm(pointwise)); + return empty_theorem; +} + +PROOF thm viewshift_frame_at_slrule(const thm change, + const term whole_source) { + term change_ccl = concl(change); + dest_binop_results change_endpoints = dest_sl_viewshift(change_ccl); + bool whole_source_is_prop = is_sl_prop(whole_source); + ENSURE_COND(whole_source_is_prop, + "Complete view-shift source is not an active SL assertion"); + + thm lifted = sep_lift_slrule(whole_source, change_endpoints.tm1); + term lifted_ccl = concl(lifted); + dest_binop_results lift_endpoints = dest_sl_eq(lifted_ccl); + dest_binop_results split = dest_sl_sep(lift_endpoints.tm2); + int source_order = alpha_compare(split.tm1, change_endpoints.tm1); + ENSURE_COND(source_order == 0, + "Extracted view-shift source is not alpha-equivalent to the change source"); + + thm framed = viewshift_frame_slrule(change, split.tm2); + term framed_ccl = concl(framed); + dest_binop_results framed_endpoints = dest_sl_viewshift(framed_ccl); + + type prop_type = sl_prop(); + term source = mk_var("__viewshift_complete_source", prop_type); + term viewshift_op = sl_viewshift(); + term relation_at_source = mk_comb(viewshift_op, source); + term relation_at_endpoint = + mk_comb(relation_at_source, framed_endpoints.tm2); + term relation_at_target = mk_abs(source, relation_at_endpoint); + thm proposition_eq_raw = ap_term_rule(relation_at_target, lifted); + conv beta = get_conversion_by_name("BETA_CONV"); + thm proposition_eq = conv_rule(binop_conv(beta), proposition_eq_raw); + thm symmetric_eq = sym_rule(proposition_eq); + thm result = eq_mp_rule(symmetric_eq, framed); + return result; +err: + ERR_FUN_PUTS("viewshift_frame_at_slrule", cstr_thm(change), + cstr_term(whole_source)); + return empty_theorem; +} + PROOF thm frame_left_slrule(const term hp, const thm ent) { - thm frame_left_th = sl_ent_frame_left(); + thm frame_left_th = sl_ent_frame_left; thm mid_th1 = match_mp_rule(frame_left_th, ent); thm res_ent = ispec_rule(hp, mid_th1); return res_ent; @@ -567,7 +1620,7 @@ err: } PROOF thm frame_right_slrule(const thm ent, const term hp) { - thm frame_right_th = sl_ent_frame_right(); + thm frame_right_th = sl_ent_frame_right; thm mid_th1 = match_mp_rule(frame_right_th, ent); thm res_ent = ispec_rule(hp, mid_th1); return res_ent; @@ -604,7 +1657,7 @@ err: } PROOF thm conj1_slrule(const thm ent) { - thm conj1_th = sl_conj1(); + thm conj1_th = sl_conj1; thm res_ent = match_mp_rule(conj1_th, ent); return res_ent; err: @@ -613,7 +1666,7 @@ err: } PROOF thm conj2_slrule(const thm ent) { - thm conj2_th = sl_conj2(); + thm conj2_th = sl_conj2; thm res_ent = match_mp_rule(conj2_th, ent); return res_ent; err: @@ -626,7 +1679,7 @@ PROOF thm disj1_slrule(const thm ent, const term hp) { dest_binop_results ent_dest = dest_sl_ent(ent_tm); term hant = ent_dest.tm1; term hcon = ent_dest.tm2; - thm disj1_th = sl_disj1_mono(); + thm disj1_th = sl_disj1_mono; thm inst = ispecl_rule(TERM_LIST(hant, hcon, hp), disj1_th); thm res_ent = match_mp_rule(inst, ent); return res_ent; @@ -640,7 +1693,7 @@ PROOF thm disj2_slrule(const term hp, const thm ent) { dest_binop_results ent_dest = dest_sl_ent(ent_tm); term hant = ent_dest.tm1; term hcon = ent_dest.tm2; - thm disj2_th = sl_disj2_mono(); + thm disj2_th = sl_disj2_mono; thm inst = ispecl_rule(TERM_LIST(hp, hant, hcon), disj2_th); thm res_ent = match_mp_rule(inst, ent); return res_ent; @@ -666,7 +1719,7 @@ err: return empty_theorem; } -PROOF thm prove_sl_disj_mono() { +PROOF static thm prove_sl_disj_mono(void) { thm or_intro1_th = sl_or_intro1(); thm or_intro2_th = sl_or_intro2(); thm or_elim_th = sl_or_elim(); @@ -704,12 +1757,7 @@ PROOF thm prove_sl_disj_mono() { return result; } -SL_THM_LAZY_INIT( - sl_disj_mono, - "!hp1 hp2 hp3 hp4. " - "(hp1 |-- hp3) ==> (hp2 |-- hp4) ==> ((hp1 || hp2) |-- (hp3 || hp4))"); - -PROOF thm prove_sl_or_elim_frame() { +PROOF static thm prove_sl_or_elim_frame(void) { term hp1 = mk_sl_prop("hp1"); term hp2 = mk_sl_prop("hp2"); term frame = mk_sl_prop("frame"); @@ -754,16 +1802,8 @@ PROOF thm prove_sl_or_elim_frame() { return generalized; } -SL_THM_LAZY_INIT( - sl_or_elim_frame, - "!(hp1:hprop) (hp2:hprop) (frame:hprop) (current1:hprop) " - "(current2:hprop) (parent_hp:hprop) (hcon:hprop). " - "(current1 -|- hp1 ** frame) ==> (current2 -|- hp2 ** frame) ==> " - "(parent_hp -|- (hp1 || hp2) ** frame) ==> (current1 |-- hcon) ==> " - "(current2 |-- hcon) ==> (parent_hp |-- hcon)"); - PROOF thm disj_mono_slrule(const thm ent1, const thm ent2) { - thm disj_mono_th = sl_disj_mono(); + thm disj_mono_th = sl_disj_mono; thm res_ent = list_match_mp_rule(disj_mono_th, THM_LIST(ent1, ent2)); return res_ent; err: @@ -771,37 +1811,130 @@ err: return empty_theorem; } -PROOF thm prove_sl_exists_elim_frame() { +PROOF static thm prove_sl_exists_elim_frame(void) { type a_type = mk_var_type("A"); term x = mk_var("x", a_type); - term body_fn = mk_var("body_fn", mk_fun_type(a_type, sl_prop())); + type proposition_type = sl_prop(); + type body_fn_type = mk_fun_type(a_type, proposition_type); + term body_fn = mk_var("body_fn", body_fn_type); term frame = mk_sl_prop("frame"); term hcon = mk_sl_prop("hcon"); term body = mk_comb(body_fn, x); term framed_body = mk_sl_sep(body, frame); - term premise_tm = mk_forall(x, mk_sl_ent(framed_body, hcon)); + term framed_entailment = mk_sl_ent(framed_body, hcon); + term premise_tm = mk_forall(x, framed_entailment); thm premise = assume_rule(premise_tm); term framed_body_fn = mk_abs(x, framed_body); - thm eliminate = - ispecl_rule(TERM_LIST(hcon, framed_body_fn), sl_exists_elim()); + thm exists_elim_th = sl_exists_elim(); + term_list eliminate_arguments = TERM_LIST(framed_body_fn, hcon); + thm eliminate = ispecl_rule(eliminate_arguments, exists_elim_th); eliminate = beta_rule(eliminate); thm eliminated = match_mp_rule(eliminate, premise); - thm pull_frame = - ispecl_rule(TERM_LIST(body_fn, frame), sl_sep_exists_left()); + term body_exists = mk_sl_exists(x, body); + thm pull_frame = sep_exists_left_slrule(body_exists, frame); thm pull_frame_ent = eq2ent(pull_frame); thm result = trans_slrule(pull_frame_ent, eliminated); result = disch_rule(premise_tm, result); - thm generalized = genl_rule(TERM_LIST(body_fn, frame, hcon), result); + term_list generalized_terms = TERM_LIST(body_fn, frame, hcon); + thm generalized = genl_rule(generalized_terms, result); return generalized; } -SL_THM_LAZY_INIT( - sl_exists_elim_frame, - "!(body_fn:A->hprop) (frame:hprop) (hcon:hprop). " - "(!x. body_fn x ** frame |-- hcon) ==> " - "((exists x. body_fn x) ** frame |-- hcon)"); +PROOF thm sep_exists_left_slrule(const term ehp, const term frame) { + dest_binder_results existential = dest_sl_exists(ehp); + ENSURE_COND(is_sl_prop(frame), + "Term(`%s`) is not an active SL assertion", + string_of_term(frame)); + + term family = dest_comb(ehp).tm2; + thm instance = ispecl_rule( + TERM_LIST(family, frame), sl_sep_exists_left()); + conv beta = get_conversion_by_name("BETA_CONV"); + conv source_application = + land_conv(land_conv(binder_conv(beta))); + conv target_application = + rand_conv(binder_conv(land_conv(beta))); + instance = conv_rule( + then_conv(source_application, target_application), instance); + + term exact_left = mk_sl_sep(ehp, frame); + dest_binop_results actual_endpoints = dest_sl_eq(concl(instance)); + term exact_right = actual_endpoints.tm2; + if (!var_free_in(existential.v, frame)) { + exact_right = mk_sl_exists( + existential.v, mk_sl_sep(existential.tm, frame)); + } else { + ENSURE_COND(is_sl_exists(exact_right), + "Instantiated left existential distribution lost its binder"); + dest_binder_results freshened = dest_sl_exists(exact_right); + ENSURE_COND(!var_free_in(freshened.v, frame), + "Instantiated left existential distribution captured its frame"); + } + term exact_conclusion = mk_sl_eq(exact_left, exact_right); + term actual_conclusion = concl(instance); + ENSURE_COND(alpha_compare(actual_conclusion, exact_conclusion) == 0, + "Instantiated left existential distribution has an unexpected " + "conclusion `%s`; expected `%s`", + string_of_term(actual_conclusion), + string_of_term(exact_conclusion)); + if (!equals_term(actual_conclusion, exact_conclusion)) { + thm alignment = alpha_rule(actual_conclusion, exact_conclusion); + instance = eq_mp_rule(alignment, instance); + } + return instance; +err: + ERR_FUN_PUTS("sep_exists_left_slrule", cstr_term(ehp), cstr_term(frame)); + return empty_theorem; +} + +PROOF thm sep_exists_right_slrule(const term frame, const term ehp) { + dest_binder_results existential = dest_sl_exists(ehp); + ENSURE_COND(is_sl_prop(frame), + "Term(`%s`) is not an active SL assertion", + string_of_term(frame)); + + term family = dest_comb(ehp).tm2; + thm instance = ispecl_rule( + TERM_LIST(frame, family), sl_sep_exists_right()); + conv beta = get_conversion_by_name("BETA_CONV"); + conv source_application = + land_conv(rand_conv(binder_conv(beta))); + conv target_application = + rand_conv(binder_conv(rand_conv(beta))); + instance = conv_rule( + then_conv(source_application, target_application), instance); + + term exact_left = mk_sl_sep(frame, ehp); + dest_binop_results actual_endpoints = dest_sl_eq(concl(instance)); + term exact_right = actual_endpoints.tm2; + if (!var_free_in(existential.v, frame)) { + exact_right = mk_sl_exists( + existential.v, mk_sl_sep(frame, existential.tm)); + } else { + ENSURE_COND(is_sl_exists(exact_right), + "Instantiated right existential distribution lost its binder"); + dest_binder_results freshened = dest_sl_exists(exact_right); + ENSURE_COND(!var_free_in(freshened.v, frame), + "Instantiated right existential distribution captured its frame"); + } + term exact_conclusion = mk_sl_eq(exact_left, exact_right); + term actual_conclusion = concl(instance); + ENSURE_COND(alpha_compare(actual_conclusion, exact_conclusion) == 0, + "Instantiated right existential distribution has an unexpected " + "conclusion `%s`; expected `%s`", + string_of_term(actual_conclusion), + string_of_term(exact_conclusion)); + if (!equals_term(actual_conclusion, exact_conclusion)) { + thm alignment = alpha_rule(actual_conclusion, exact_conclusion); + instance = eq_mp_rule(alignment, instance); + } + return instance; +err: + ERR_FUN_PUTS("sep_exists_right_slrule", cstr_term(frame), cstr_term(ehp)); + return empty_theorem; +} PROOF thm choose_slrule(const term v, const term ehp, const thm ent) { dest_binder_results ehp_dest = dest_sl_exists(ehp); @@ -828,8 +1961,14 @@ PROOF thm choose_slrule(const term v, const term ehp, const thm ent) { thm generalized = gen_rule(v, opened); term hp_fn = dest_comb(ehp).tm2; thm framed_elim = ispecl_rule( - TERM_LIST(hp_fn, frame, hcon), sl_exists_elim_frame()); - framed_elim = beta_rule(framed_elim); + TERM_LIST(hp_fn, frame, hcon), sl_exists_elim_frame); + conv beta = get_conversion_by_name("BETA_CONV"); + conv premise_application = + land_conv(binder_conv(land_conv(land_conv(beta)))); + conv source_application = + rand_conv(land_conv(land_conv(binder_conv(beta)))); + framed_elim = conv_rule( + then_conv(premise_application, source_application), framed_elim); thm result = match_mp_rule(framed_elim, generalized); if (vector_size(frames) == 0) { thm res_ent = rehant_slrule(result, ehp); @@ -848,11 +1987,16 @@ PROOF thm exists_slrule(const term ehp, const term wit, const thm ent) { term ent_tm = concl(ent); dest_binop_results ent_dest = dest_sl_ent(ent_tm); - thm exists_th = sl_exists_wit(); + thm exists_th = sl_exists_wit; term hant = ent_dest.tm1; term hcon_fn = mk_abs(ehp_dest.v, ehp_dest.tm); thm mid_th1 = ispecl_rule(TERM_LIST(wit, hant, hcon_fn), exists_th); - thm mid_th2 = beta_rule(mid_th1); + conv beta = get_conversion_by_name("BETA_CONV"); + conv premise_application = land_conv(rand_conv(beta)); + conv target_application = + rand_conv(rand_conv(binder_conv(beta))); + thm mid_th2 = conv_rule( + then_conv(premise_application, target_application), mid_th1); thm mid_th3 = match_mp_rule(mid_th2, ent); thm res_ent = rehcon_slrule(mid_th3, ehp); return res_ent; @@ -861,54 +2005,94 @@ err: return empty_theorem; } -PROOF static thm get_mp_eq_aux() { - static bool initialized = false; - static thm value; - if (!initialized) { - term statement = - parse_term("!A1 A2 B. ((A1 = A2) ==> (A1 ==> B) ==> A2 ==> B)"); - value = meson_solver((thm_list)vector_create(), statement); - initialized = true; - } - return value; -} +PROOF thm forall_slrule(const term v, const thm ent) { + ENSURE_COND(is_var(v), "Universal introduction binder must be a variable"); + dest_binop_results endpoints = dest_sl_ent(concl(ent)); + term hant = endpoints.tm1; + term hcon = endpoints.tm2; + ENSURE_COND(!var_free_in(v, hant), + "Universal introduction binder(`%s`) occurs in the antecedent", + string_of_term(v)); -PROOF static conv get_beta_eq_conv() { - static bool initialized = false; - static conv value; - if (!initialized) { - conv beta = get_conversion_by_name("BETA_CONV"); - conv beta_binop = binop_conv(beta); - value = binder_conv(beta_binop); - initialized = true; - } - return value; + term family = mk_abs(v, hcon); + thm intro = ispecl_rule(TERM_LIST(hant, family), sl_forall_intro()); + + /* Specialization creates exactly two applications of `family`: one in the + * universally quantified premise and one below the target SL binder. Keep + * beta conversion confined to those generated redexes. */ + conv beta = get_conversion_by_name("BETA_CONV"); + conv premise_application = land_conv(binder_conv(rand_conv(beta))); + conv target_application = + rand_conv(rand_conv(rand_conv(binder_conv(beta)))); + intro = conv_rule( + then_conv(premise_application, target_application), intro); + + thm pointwise = gen_rule(v, ent); + thm result = match_mp_rule(intro, pointwise); + term exact_hcon = mk_sl_forall(v, hcon); + result = rehant_slrule(result, hant); + result = rehcon_slrule(result, exact_hcon); + return result; +err: + ERR_FUN_PUTS("forall_slrule", cstr_term(v), cstr_thm(ent)); + return empty_theorem; } -PROOF thm exists_mono_slrule(const term v, const thm ent) { +/* Apply the cached eta-short monotonicity theorem once. Specializing its + * premise introduces exactly the two redexes selected below; its endpoints + * are already `EX (\v. H)` and `EX (\v. K)`. */ +PROOF static thm exists_mono_raw_slrule(const term v, const thm ent) { term ent_tm = concl(ent); dest_binop_results h_dest = dest_sl_ent(ent_tm); term hant = h_dest.tm1; term hcon = h_dest.tm2; - thm mono = sl_exists_mono(); - // Wrap hant, hcon as functions \v. hant and \v. hcon term fn_hant = mk_abs(v, hant); term fn_hcon = mk_abs(v, hcon); // Instantiate hpA, hpA' with the function wrappers - thm inst = ispecl_rule(TERM_LIST(fn_hant, fn_hcon), mono); - // inst: (!x. (\v. hant) x |-- (\v. hcon) x) ==> (hexists (\v. hant) |-- hexists (\v. hcon)) + thm inst = ispecl_rule( + TERM_LIST(fn_hant, fn_hcon), sl_exists_mono_eta); + conv beta = get_conversion_by_name("BETA_CONV"); + conv premise = land_conv(binder_conv(binop_conv(beta))); + inst = conv_rule(premise, inst); // GEN enforces that v is a variable and is not free in any hypothesis. thm gen = gen_rule(v, ent); - thm beta_equiv = - apply_conversion(get_beta_eq_conv(), dest_imp(concl(inst)).tm1); - // beta_equiv: !x. (\v. hant) x |-- (\v. hcon) x <=> !x. hant |-- hcon - thm res_ent = - list_match_mp_rule(get_mp_eq_aux(), THM_LIST(beta_equiv, inst, gen)); - return res_ent; + return match_mp_rule(inst, gen); +err: + ERR_FUN_PUTS("exists_mono_raw_slrule", cstr_term(v), cstr_thm(ent)); + return empty_theorem; +} + +PROOF thm exists_mono_many_slrule(const term_list vs, const thm ent) { + term ent_tm = concl(ent); + dest_binop_results endpoints = dest_sl_ent(ent_tm); + thm result = ent; + + for (int i = (int)vector_size(vs) - 1; i >= 0; --i) { + result = exists_mono_raw_slrule(vs[i], result); + } + + term exact_hant = list_mk_sl_exists(vs, endpoints.tm1); + term exact_hcon = list_mk_sl_exists(vs, endpoints.tm2); + term expected = mk_sl_ent(exact_hant, exact_hcon); + term actual = concl(result); + ENSURE_COND(alpha_compare(actual, expected) == 0, + "Batch existential monotonicity concluded `%s`; expected `%s`", + string_of_term(actual), string_of_term(expected)); + if (!equals_term(actual, expected)) { + result = eq_mp_rule(alpha_rule(actual, expected), result); + } + return result; +err: + ERR_FUN_PUTS("exists_mono_many_slrule", cstr_term_list(vs), cstr_thm(ent)); + return empty_theorem; +} + +PROOF thm exists_mono_slrule(const term v, const thm ent) { + return exists_mono_many_slrule(TERM_LIST(v), ent); err: ERR_FUN_PUTS("exists_mono_slrule", cstr_term(v), cstr_thm(ent)); return empty_theorem; @@ -936,7 +2120,7 @@ err: return empty_theorem; } -PROOF thm prove_sl_undisch() { +PROOF static thm prove_sl_undisch(void) { thm wand_sep_adjoint_th = sl_wand_sep_adjoint(); term a = mk_sl_prop("a"); @@ -963,10 +2147,8 @@ PROOF thm prove_sl_undisch() { return result; } -SL_THM_LAZY_INIT(sl_undisch, "!a b c. (a |-- b -* c) ==> (a ** b |-- c)"); - PROOF thm elim_wand_slrule(const thm ent) { - thm undisch_th = sl_undisch(); + thm undisch_th = sl_undisch; thm res_ent = match_mp_rule(undisch_th, ent); return res_ent; err: @@ -974,9 +2156,7 @@ err: return empty_theorem; } -// === NEW: prove_sl_conj1, prove_sl_conj2, prove_sl_disj1_mono, prove_sl_disj2_mono === - -PROOF thm prove_sl_conj1() { +PROOF static thm prove_sl_conj1(void) { thm and_elim1_th = sl_and_elim1(); term a = mk_sl_prop("a"); term b = mk_sl_prop("b"); @@ -994,9 +2174,7 @@ PROOF thm prove_sl_conj1() { return result; } -SL_THM_LAZY_INIT(sl_conj1, "!a b c. (a |-- b && c) ==> (a |-- b)"); - -PROOF thm prove_sl_conj2() { +PROOF static thm prove_sl_conj2(void) { thm and_elim2_th = sl_and_elim2(); term a = mk_sl_prop("a"); term b = mk_sl_prop("b"); @@ -1014,9 +2192,7 @@ PROOF thm prove_sl_conj2() { return result; } -SL_THM_LAZY_INIT(sl_conj2, "!a b c. (a |-- b && c) ==> (a |-- c)"); - -PROOF thm prove_sl_disj1_mono() { +PROOF static thm prove_sl_disj1_mono(void) { thm or_intro1_th = sl_or_intro1(); term a = mk_sl_prop("a"); term b = mk_sl_prop("b"); @@ -1034,9 +2210,7 @@ PROOF thm prove_sl_disj1_mono() { return result; } -SL_THM_LAZY_INIT(sl_disj1_mono, "!a b c. (a |-- b) ==> (a |-- b || c)"); - -PROOF thm prove_sl_disj2_mono() { +PROOF static thm prove_sl_disj2_mono(void) { thm or_intro2_th = sl_or_intro2(); term a = mk_sl_prop("a"); term b = mk_sl_prop("b"); @@ -1054,8 +2228,6 @@ PROOF thm prove_sl_disj2_mono() { return result; } -SL_THM_LAZY_INIT(sl_disj2_mono, "!a b c. (b |-- c) ==> (b |-- a || c)"); - PROOF thm intro_fact_slrule(const thm th, const thm ent) { thm fact_intro_th = sl_fact_intro(); thm res_ent = list_match_mp_rule(fact_intro_th, THM_LIST(th, ent)); @@ -1075,62 +2247,359 @@ err: return empty_theorem; } -PROOF thm prove_sl_exists_wit() { +PROOF static thm prove_sl_exists_wit(void) { thm exists_intro_th = sl_exists_intro(); type a_type = mk_var_type("A"); term wit = mk_var("wit", a_type); term h = mk_sl_prop("h"); - term body_fn = mk_var("body_fn", mk_fun_type(a_type, sl_prop())); + type proposition_type = sl_prop(); + type body_fn_type = mk_fun_type(a_type, proposition_type); + term body_fn = mk_var("body_fn", body_fn_type); - term ent_tm = mk_sl_ent(h, mk_comb(body_fn, wit)); + term body_at_wit = mk_comb(body_fn, wit); + term ent_tm = mk_sl_ent(h, body_at_wit); thm ent_th = assume_rule(ent_tm); - // exists_intro: !x hp hpA. (hp |-- hpA x) ==> (hp |-- (exists x. hpA x)) - thm intro_inst = ispecl_rule(TERM_LIST(wit, h, body_fn), exists_intro_th); - // intro_inst: (h |-- body_fn wit) ==> (h |-- (exists x. body_fn x)) - - thm step1 = match_mp_rule(intro_inst, ent_th); + // exists_intro: !P witness. P witness |-- (exists x. P x) + term_list intro_arguments = TERM_LIST(body_fn, wit); + thm intro_inst = ispecl_rule(intro_arguments, exists_intro_th); + // Compose h |-- body_fn wit with the primitive introduction entailment. + thm step1 = trans_slrule(ent_th, intro_inst); thm step2 = disch_rule(ent_tm, step1); - thm result = genl_rule(TERM_LIST(wit, h, body_fn), step2); + term_list generalized_terms = TERM_LIST(wit, h, body_fn); + thm result = genl_rule(generalized_terms, step2); return result; } -SL_THM_LAZY_INIT( - sl_exists_wit, - "!wit (h: hprop) (body_fn: A -> hprop). (h |-- body_fn wit) ==> " - "(h |-- (exists x. body_fn x))"); - -// `|- !hpA hpA'. (!x:A. hpA x |-- hpA' x) ==> (hexists hpA) |-- (hexists hpA' ))` -PROOF thm prove_sl_exists_mono() { - // `|- !hpA hpA'. (!x:A. hpA x |-- hpA' x) ==> (exists x. hpA x) |-- (exists x. hpA' x))` - thm init = get_hexists_monotone(); - term hpA = `hpA:A->hprop`; - term hpA1 = `hpA':A->hprop`; - init = specl_rule(TERM_LIST(hpA, hpA1), init); - thm help = apply_conversion((get_conversion_by_name("ETA_CONV")), - `\(x:A). (hpA:A->hprop) x`); - help = mk_comb_rule(refl_rule(`hexists:(A->hprop)->hprop`), help); - help = gen_rule(hpA, help); - thm result = pure_rewrite_rule( - THM_LIST(spec_rule(hpA, help), spec_rule(hpA1, help)), init); - result = genl_rule(TERM_LIST(hpA, hpA1), result); +/* The installed primitive intentionally has eta-long endpoints: + * + * (!x. P x |-- Q x) ==> (EX (\x. P x) |-- EX (\x. Q x)). + * + * ETA_AX is applied once to that closed schema, during theory installation, + * to obtain a reusable instantiation theorem with endpoints `EX P` and + * `EX Q`. No caller assertion participates in this rewrite. */ +PROOF static thm prove_sl_exists_mono_eta(void) { + thm eta = get_theorem_by_name("ETA_AX"); + thm result = pure_rewrite_rule(THM_LIST(eta), + sl_exists_mono_primitive()); return result; +err: + ERR_FUN_PUTS("prove_sl_exists_mono_eta"); + return empty_theorem; } -SL_THM_LAZY_INIT(sl_exists_mono, - "forall hpA:A->hprop hpA'. (forall x. hpA x |-- hpA' x) ==> " - "((exists) hpA |-- (exists) hpA')"); +PROOF static int sl_build_derived_theorems(void) { + { + thm proved = prove_sl_exists_mono_eta(); + type_list witness_types = term_tyvars(concl(proved)); + ENSURE_COND(vector_size(witness_types) == 1, + "sl_exists_mono_eta must have one witness type variable"); + type A = witness_types[0]; + term P = mk_var("P", mk_fun_type(A, sl_prop())); + term Q = mk_var("Q", mk_fun_type(A, sl_prop())); + term x = mk_var("x", A); + term pointwise = mk_forall( + x, mk_sl_ent(mk_comb(P, x), mk_comb(Q, x))); + term conclusion = mk_sl_ent( + mk_icomb(sl_exists(), P), mk_icomb(sl_exists(), Q)); + term expected = list_mk_forall( + TERM_LIST(P, Q), mk_imp(pointwise, conclusion)); + int status = sl_bind_exact_derived( + "sl_exists_mono_eta", &sl_exists_mono_eta, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_exists_mono_eta"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term premise = mk_sl_eq(H, K); + term conclusion = mk_sl_ent(H, K); + term expected = + list_mk_forall(TERM_LIST(H, K), mk_imp(premise, conclusion)); + thm proved = prove_sl_ent_sym_left(); + int status = sl_bind_exact_derived("sl_ent_sym_left", &sl_ent_sym_left, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ent_sym_left"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term premise = mk_sl_ent(H, K); + term conclusion = mk_sl_ent(mk_sl_sep(F, H), mk_sl_sep(F, K)); + term expected = + list_mk_forall(TERM_LIST(H, K, F), mk_imp(premise, conclusion)); + thm proved = prove_sl_ent_frame_left(); + int status = sl_bind_exact_derived("sl_ent_frame_left", &sl_ent_frame_left, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ent_frame_left"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term premise = mk_sl_ent(H, K); + term conclusion = mk_sl_ent(mk_sl_sep(H, F), mk_sl_sep(K, F)); + term expected = + list_mk_forall(TERM_LIST(H, K, F), mk_imp(premise, conclusion)); + thm proved = prove_sl_ent_frame_right(); + int status = sl_bind_exact_derived("sl_ent_frame_right", + &sl_ent_frame_right, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ent_frame_right"); + } + + { + term H = mk_sl_prop("H"); + term H1 = mk_sl_prop("H1"); + term K = mk_sl_prop("K"); + term K1 = mk_sl_prop("K1"); + term H_eq = mk_sl_eq(H, H1); + term K_eq = mk_sl_eq(K, K1); + term child = mk_sl_ent(H1, K1); + term conclusion = mk_sl_ent(H, K); + term body = mk_imp(H_eq, mk_imp(K_eq, mk_imp(child, conclusion))); + term expected = list_mk_forall(TERM_LIST(H, H1, K, K1), body); + thm proved = prove_sl_ent_restate(); + int status = sl_bind_exact_derived("sl_ent_restate", &sl_ent_restate, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ent_restate"); + } + + { + term H = mk_sl_prop("H"); + term F = mk_sl_prop("F"); + term H1 = mk_sl_prop("H1"); + term K = mk_sl_prop("K"); + term K1 = mk_sl_prop("K1"); + term H_eq = mk_sl_eq(H, mk_sl_sep(F, H1)); + term K_eq = mk_sl_eq(K, mk_sl_sep(F, K1)); + term child = mk_sl_ent(H1, K1); + term conclusion = mk_sl_ent(H, K); + term body = mk_imp(H_eq, mk_imp(K_eq, mk_imp(child, conclusion))); + term expected = list_mk_forall(TERM_LIST(H, F, H1, K, K1), body); + thm proved = prove_sl_frame_restate(); + int status = sl_bind_exact_derived("sl_frame_restate", &sl_frame_restate, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_frame_restate"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term C = mk_sl_prop("C"); + term G = mk_sl_prop("G"); + term H_eq = mk_sl_eq(H, K); + term C_eq = mk_sl_eq(C, mk_sl_sep(K, F)); + term child = mk_sl_ent(C, G); + term conclusion = mk_sl_ent(mk_sl_sep(H, F), G); + term body = mk_imp(H_eq, mk_imp(C_eq, mk_imp(child, conclusion))); + term expected = list_mk_forall(TERM_LIST(H, K, F, C, G), body); + thm proved = prove_sl_ent_subst_frame(); + int status = sl_bind_exact_derived("sl_ent_subst_frame", + &sl_ent_subst_frame, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ent_subst_frame"); + } + + { + term H = mk_sl_prop("H"); + term H1 = mk_sl_prop("H1"); + term H2 = mk_sl_prop("H2"); + term K = mk_sl_prop("K"); + term K1 = mk_sl_prop("K1"); + term K2 = mk_sl_prop("K2"); + term H_eq = mk_sl_eq(H, mk_sl_sep(H1, H2)); + term K_eq = mk_sl_eq(K, mk_sl_sep(K1, K2)); + term child1 = mk_sl_ent(H1, K1); + term child2 = mk_sl_ent(H2, K2); + term conclusion = mk_sl_ent(H, K); + term body = + mk_imp(H_eq, mk_imp(K_eq, mk_imp(child1, mk_imp(child2, conclusion)))); + term expected = list_mk_forall(TERM_LIST(H, H1, H2, K, K1, K2), body); + thm proved = prove_sl_sep_combine(); + int status = sl_bind_exact_derived("sl_sep_combine", &sl_sep_combine, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_sep_combine"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term left_comm = + mk_sl_eq(mk_sl_sep(H, mk_sl_sep(K, F)), mk_sl_sep(K, mk_sl_sep(H, F))); + term left_comm_law = list_mk_forall(TERM_LIST(H, K, F), left_comm); + term expected = mk_conj(concl(sl_sep_comm()), + mk_conj(concl(sl_sep_assoc()), left_comm_law)); + thm proved = prove_sl_ac_rule(); + int status = + sl_bind_exact_derived("sl_ac_rule", &sl_ac_rule, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_ac_rule"); + } + + { + term H1 = mk_sl_prop("H1"); + term H2 = mk_sl_prop("H2"); + term K1 = mk_sl_prop("K1"); + term K2 = mk_sl_prop("K2"); + term premise1 = mk_sl_ent(H1, K1); + term premise2 = mk_sl_ent(H2, K2); + term conclusion = mk_sl_ent(mk_sl_or(H1, H2), mk_sl_or(K1, K2)); + term body = mk_imp(premise1, mk_imp(premise2, conclusion)); + term expected = list_mk_forall(TERM_LIST(H1, H2, K1, K2), body); + thm proved = prove_sl_disj_mono(); + int status = + sl_bind_exact_derived("sl_disj_mono", &sl_disj_mono, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_disj_mono"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term G = mk_sl_prop("G"); + term premise = mk_sl_ent(H, mk_sl_wand(K, G)); + term conclusion = mk_sl_ent(mk_sl_sep(H, K), G); + term expected = + list_mk_forall(TERM_LIST(H, K, G), mk_imp(premise, conclusion)); + thm proved = prove_sl_undisch(); + int status = + sl_bind_exact_derived("sl_undisch", &sl_undisch, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_undisch"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term premise = mk_sl_ent(H, mk_sl_and(K, F)); + term conclusion = mk_sl_ent(H, K); + term expected = + list_mk_forall(TERM_LIST(H, K, F), mk_imp(premise, conclusion)); + thm proved = prove_sl_conj1(); + int status = sl_bind_exact_derived("sl_conj1", &sl_conj1, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_conj1"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term premise = mk_sl_ent(H, mk_sl_and(K, F)); + term conclusion = mk_sl_ent(H, F); + term expected = + list_mk_forall(TERM_LIST(H, K, F), mk_imp(premise, conclusion)); + thm proved = prove_sl_conj2(); + int status = sl_bind_exact_derived("sl_conj2", &sl_conj2, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_conj2"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term premise = mk_sl_ent(H, K); + term conclusion = mk_sl_ent(H, mk_sl_or(K, F)); + term expected = + list_mk_forall(TERM_LIST(H, K, F), mk_imp(premise, conclusion)); + thm proved = prove_sl_disj1_mono(); + int status = sl_bind_exact_derived("sl_disj1_mono", &sl_disj1_mono, proved, + expected); + ENSURE_COND(status == 0, "Failed to bind sl_disj1_mono"); + } + + { + term F = mk_sl_prop("F"); + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term premise = mk_sl_ent(H, K); + term conclusion = mk_sl_ent(H, mk_sl_or(F, K)); + term expected = + list_mk_forall(TERM_LIST(F, H, K), mk_imp(premise, conclusion)); + thm proved = prove_sl_disj2_mono(); + int status = sl_bind_exact_derived("sl_disj2_mono", &sl_disj2_mono, proved, + expected); + ENSURE_COND(status == 0, "Failed to bind sl_disj2_mono"); + } + + { + type A = mk_var_type("A"); + term w = mk_var("w", A); + term H = mk_sl_prop("H"); + term B = mk_var("B", mk_fun_type(A, sl_prop())); + term x = mk_var("x", A); + term B_w = mk_comb(B, w); + term B_x = mk_comb(B, x); + term premise = mk_sl_ent(H, B_w); + term conclusion = mk_sl_ent(H, mk_sl_exists(x, B_x)); + term expected = + list_mk_forall(TERM_LIST(w, H, B), mk_imp(premise, conclusion)); + thm proved = prove_sl_exists_wit(); + int status = sl_bind_exact_derived("sl_exists_wit", &sl_exists_wit, proved, + expected); + ENSURE_COND(status == 0, "Failed to bind sl_exists_wit"); + } + + { + type A = mk_var_type("A"); + term B = mk_var("B", mk_fun_type(A, sl_prop())); + term F = mk_sl_prop("F"); + term K = mk_sl_prop("K"); + term x = mk_var("x", A); + term B_x = mk_comb(B, x); + term pointwise = mk_forall(x, mk_sl_ent(mk_sl_sep(B_x, F), K)); + term conclusion = mk_sl_ent(mk_sl_sep(mk_sl_exists(x, B_x), F), K); + term expected = + list_mk_forall(TERM_LIST(B, F, K), mk_imp(pointwise, conclusion)); + thm proved = prove_sl_exists_elim_frame(); + int status = sl_bind_exact_derived("sl_exists_elim_frame", + &sl_exists_elim_frame, proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_exists_elim_frame"); + } + + { + term H = mk_sl_prop("H"); + term K = mk_sl_prop("K"); + term F = mk_sl_prop("F"); + term C1 = mk_sl_prop("C1"); + term C2 = mk_sl_prop("C2"); + term P = mk_sl_prop("P"); + term G = mk_sl_prop("G"); + term C1_eq = mk_sl_eq(C1, mk_sl_sep(H, F)); + term C2_eq = mk_sl_eq(C2, mk_sl_sep(K, F)); + term P_eq = mk_sl_eq(P, mk_sl_sep(mk_sl_or(H, K), F)); + term branch1 = mk_sl_ent(C1, G); + term branch2 = mk_sl_ent(C2, G); + term conclusion = mk_sl_ent(P, G); + term body = mk_imp( + C1_eq, + mk_imp(C2_eq, + mk_imp(P_eq, mk_imp(branch1, mk_imp(branch2, conclusion))))); + term expected = list_mk_forall(TERM_LIST(H, K, F, C1, C2, P, G), body); + thm proved = prove_sl_or_elim_frame(); + int status = sl_bind_exact_derived("sl_or_elim_frame", &sl_or_elim_frame, + proved, expected); + ENSURE_COND(status == 0, "Failed to bind sl_or_elim_frame"); + } + + return 0; +err: + ERR_FUN_PUTS("sl_build_derived_theorems"); + return -1; +} PROOF static conv normalize_sl_conv() { - static bool initialized = false; + static size_t generation = 0; static conv value; - if (!initialized) { + size_t current_generation = sl_theory_generation(); + if (generation != current_generation) { value = pure_rewrite_conv(THM_LIST(sl_fact_true_emp(), sl_sep_emp_left(), sl_sep_emp_right())); - initialized = true; + generation = current_generation; } return value; } @@ -1140,8 +2609,8 @@ PROOF thm normalize_slrule(const term hp) { "Term(`%s`) is not a separation logic proposition", string_of_term(hp)); - conv cv = normalize_sl_conv(); - thm res_eq = apply_conversion(cv, hp); + conv unit_normalize = normalize_sl_conv(); + thm res_eq = apply_conversion(unit_normalize, hp); return res_eq; err: ERR_FUN_PUTS("normalize_slrule", cstr_term(hp)); @@ -1172,7 +2641,7 @@ PROOF thm ac_slrule(const term hp1, const term hp2) { thm res_eq = alpha_rule(hp1, hp2); return res_eq; } - thm res_eq = ac_rule(sl_ac_rule(), eq_tm); + thm res_eq = ac_rule(sl_ac_rule, eq_tm); return res_eq; err: ERR_FUN_PUTS("ac_slrule", cstr_term(hp1), cstr_term(hp2)); @@ -1280,7 +2749,7 @@ PROOF static thm duplicate_checked_fact_slrule(const term symhp, vector_remove(remaining, (vec_size_t)checked_index); term frame = list_mk_sl_sep(remaining); - thm duplicate = spec_rule(checked, get_hfact_dup()); + thm duplicate = spec_rule(checked, sl_fact_dup()); duplicate = frame_right_slrule(duplicate, frame); duplicate = rehant_slrule(duplicate, symhp); return rehcon_slrule(duplicate, mk_sl_sep(checked_fact, symhp)); @@ -1350,17 +2819,7 @@ err: } PROOF thm list_exists_mono_slrule(const term_list vs, const thm ent) { - size_t sz = vector_size(vs); - thm res_ent = ent; - if (sz == 0) { - term ent_tm = concl(ent); - dest_sl_ent(ent_tm); - return res_ent; - } - for (int i = (int)sz - 1; i >= 0; i--) { - res_ent = exists_mono_slrule(vs[i], res_ent); - } - return res_ent; + return exists_mono_many_slrule(vs, ent); err: ERR_FUN_PUTS("list_exists_mono_slrule", cstr_term_list(vs), cstr_thm(ent)); return empty_theorem; diff --git a/proof_sl.h b/proof_sl.h index 94abbada6050dfb9b2cedef903afcfc157855ccc..8233982017c1f2f025f3613b32da077ba478e551 100644 --- a/proof_sl.h +++ b/proof_sl.h @@ -1,20 +1,26 @@ /** * Separation-logic assertion constructors and proof rules. * - * This header inherits the theorem, alpha-equivalence, sequence, truth, and - * capture-avoiding-substitution notation of `proof_kernel.h`, together with - * the occurrence-sensitive sequence relations of `proof_user.h`. It uses the + * This header inherits the typing notation `t:τ` and theorem judgment + * `𝒜 ⊢ φ` from `proof_kernel.h`, together with its alpha-equivalence, + * sequence, truth, and capture-avoiding-substitution notation and the + * occurrence-sensitive sequence relations of `proof_user.h`. A C value of + * type `thm` is an opaque handle to such a theorem; writing that a function + * "returns `𝒜 ⊢ φ`" specifies the conclusion and hypotheses of the referenced + * HOL theorem, not the C function's return proposition. This header uses the * following SL-specific extension consistently: * - * - `H`, `K`, and `F` range over SL assertions of type `hprop`; `p` and `q` - * range over pure HOL propositions of type `bool`; `x` and `y` are HOL - * terms whose types are written `α` and `β`. + * - `H`, `K`, and `F` range over the active theory's assertion type + * `sl_prop()`; `p` and `q` range over pure HOL propositions of type `bool`; + * `x` and `y` are HOL terms whose types are written `α` and `β`. * - `H ** K`, `H -* K`, `H && K`, and `H || K` denote separating * conjunction, magic wand, additive conjunction, and additive disjunction. * `emp` is the separating unit, `fact(p)` embeds a pure proposition, and * `∃SL x. H` is SL existential quantification. - * - `H ⊢SL K` is SL entailment. `H =ₕ K` is ordinary HOL equality at - * `hprop`; C* assertion syntax also writes it `H -|- K`. + * - `H ⊢SL K` is SL entailment, `H ≃SL K` is the active theory's logical + * equivalence, `H ⇛ K` is an installed view shift, and `H = K` is raw HOL + * equality at `sl_prop()`. Thus `𝒜 ⊢ (H ⊢SL K)`, `𝒜 ⊢ (H ⇛ K)`, and + * `𝒜 ⊢ (H = K)` are three different HOL theorem shapes. * - For a sequence `S = [H₀, …, Hₙ₋₁]`, `Sep(S)` is its right-associated * separating product: `Sep([]) = emp`, `Sep([H]) = H`, and * `Sep(H::S) = H ** Sep(S)` for nonempty `S`. Likewise, @@ -39,153 +45,328 @@ #require "proof/proof_user.c" /** - * Late-bound constants and primitive theorems of the SL theory. + * One installable separation-logic signature. * - * The current bindings select the classical heap model. The macros below keep - * the user proof library independent of the concrete getter names. + * The terms are already-specialized HOL operators. An RA-backed client first + * selects its file-local resource algebra and installs closed aliases for + * `r_emp R`, `r_sep R`, and the remaining operators. The binder aliases + * `exists_op` and `forall_op` must be HOL constants; their unique names are + * used to recognize polymorphic witness-type instances. The proof library + * never unfolds these operators and therefore has no dependency on the + * carrier's implementation or on bootstrapped physical-heap constants. + * + * Operator fields have these HOL types, where `Prop = prop_type`: + * + * ```text + * emp : Prop + * sep, wand, and_op, or_op : Prop -> Prop -> Prop + * exists_op : (α -> Prop) -> Prop (exactly α remains polymorphic) + * entails, equiv : Prop -> Prop -> bool + * fact : bool -> Prop + * ``` + * + * The theorem fields are borrowed handles intended to have exactly these + * closed schemas (all displayed variables are universally quantified): + * + * ```text + * sep_emp_left: emp ** P = P + * sep_emp_right: P ** emp = P + * sep_assoc: (P ** Q) ** S = P ** (Q ** S) + * sep_comm: P ** Q = Q ** P + * sep_mono: (P ⊢SL P2) ⇒ (Q ⊢SL Q2) ⇒ + * (P ** Q ⊢SL P2 ** Q2) + * wand_sep_adjoint: (P ** Q ⊢SL S) ⇔ (P ⊢SL Q -* S) + * and_intro: (P ⊢SL Q) ⇒ (P ⊢SL S) ⇒ (P ⊢SL (Q && S)) + * and_elim1: P && Q ⊢SL P + * and_elim2: P && Q ⊢SL Q + * or_intro1: P ⊢SL (P || Q) + * or_intro2: Q ⊢SL (P || Q) + * or_elim: (P ⊢SL S) ⇒ (Q ⊢SL S) ⇒ ((P || Q) ⊢SL S) + * exists_intro: P w ⊢SL (∃SL x. P x) + * exists_elim: (∀x. P x ⊢SL Q) ⇒ ((∃SL x. P x) ⊢SL Q) + * exists_mono: (∀x. P x ⊢SL Q x) ⇒ + * ((∃SL x. P x) ⊢SL (∃SL x. Q x)) + * sep_exists_left: (∃SL x. P x) ** Q = ∃SL x. P x ** Q + * sep_exists_right: P ** (∃SL x. Q x) = ∃SL x. P ** Q x + * ent_refl: P ⊢SL P + * ent_trans: (P ⊢SL Q) ⇒ (Q ⊢SL S) ⇒ (P ⊢SL S) + * equiv_intro: (P ⊢SL Q) ⇒ (Q ⊢SL P) ⇒ (P ≃SL Q) + * fact_intro: p ⇒ (P ⊢SL Q) ⇒ (P ⊢SL fact(p) ** Q) + * fact_elim: (p ⇒ (P ⊢SL Q)) ⇒ (fact(p) ** P ⊢SL Q) + * fact_dup: fact(p) ⊢SL fact(p) ** fact(p) + * fact_true_emp: fact(T) = emp + * ``` + * + * `P,Q,S,P2,Q2` have `prop_type`, `p:bool`, `w:α`, and the existential + * families have type `α -> prop_type`. The installer checks operator types, + * requires every primitive handle to be nonempty, and checks the five + * existential schemas exactly in the eta-long binder form displayed above. + * The remaining theorem conclusions are a trusted adapter obligation. The + * installed slot copies handles; it does not transfer or shorten their + * prover-managed lifetime. + * + * `equiv` is logical assertion equivalence. It is deliberately separate from + * raw HOL function equality: validity-aware entailment is antisymmetric only + * up to `equiv`, not on predicates outside the valid-resource domain. */ +PROOF typedef struct { + type prop_type; + + term emp; + term sep; + term wand; + term and_op; + term or_op; + term exists_op; + term forall_op; + term entails; + term equiv; + term fact; + + thm sep_emp_left; + thm sep_emp_right; + thm sep_assoc; + thm sep_comm; + thm sep_mono; + thm wand_sep_adjoint; + thm and_intro; + thm and_elim1; + thm and_elim2; + thm or_intro1; + thm or_intro2; + thm or_elim; + thm exists_intro; + thm exists_elim; + thm exists_mono; + thm sep_exists_left; + thm sep_exists_right; + thm forall_intro; + thm forall_elim; + thm ent_refl; + thm ent_trans; + thm equiv_intro; + thm fact_intro; + thm fact_elim; + thm fact_dup; + thm fact_true_emp; +} sl_theory; + +/** + * Optional, RA-scoped basic-update and view-shift signature. + * + * This bundle is installed only after its base `sl_theory`. `bupd` has type + * `sl_prop() -> sl_prop()` and `viewshift` has type + * `sl_prop() -> sl_prop() -> bool`. Every primitive theorem must already be + * specialized to the same resource algebra as the active SL signature. + * Installing another base signature invalidates this bundle. Unlike the base + * bundle, installation verifies the exact closed conclusion of every primitive: + * + * ```text + * ∀P. P ⊢SL bupd P + * ∀P Q. (P ⊢SL Q) ⇒ (bupd P ⊢SL bupd Q) + * ∀P. bupd (bupd P) ⊢SL bupd P + * ∀P F. bupd P ** F ⊢SL bupd (P ** F) + * ∀P. P ⇛ P + * ∀P Q. (P ⊢SL Q) ⇒ (P ⇛ Q) + * ∀P Q S. (P ⇛ Q) ⇒ (Q ⇛ S) ⇒ (P ⇛ S) + * ∀P2 P Q Q2. (P2 ⊢SL P) ⇒ (P ⇛ Q) ⇒ (Q ⊢SL Q2) ⇒ (P2 ⇛ Q2) + * ∀P Q F. (P ⇛ Q) ⇒ (P ** F ⇛ Q ** F) + * ∀P1 Q1 P2 Q2. (P1 ⇛ Q1) ⇒ (P2 ⇛ Q2) ⇒ + * (P1 ** P2 ⇛ Q1 ** Q2) + * ∀P Q. (∀x. P x ⇛ Q x) ⇒ ((∃SL x. P x) ⇛ (∃SL x. Q x)) + * ``` + * + * All primitive theorems are closed. The last schema alone may be polymorphic + * in the witness type. The installed slot copies handles and owns no caller + * storage. + */ +PROOF typedef struct { + term bupd; + term viewshift; -// `hprop`: the type of separation-logic assertions -#define sl_prop() get_hprop_type() - -// `emp`: the empty resource -#define sl_emp() get_hemp() - -// `**`: the separating conjunction -#define sl_sep() get_hconj() - -// `-*`: the magic wand -#define sl_wand() get_hwand() - -// `&&`: additive conjunction on SL assertions -#define sl_and() get_hand() - -// `||`: additive disjunction on SL assertions -#define sl_or() get_hor() - -// `hexists`: existential quantification over SL assertions -#define sl_exists() get_hexists() -#define sl_exists_str() "hexists" - -// `|--`: SL entailment -#define sl_ent() get_hentail() - -// Ordinary HOL equality specialized to `hprop`; `-|-` is only a syntax alias. -#define sl_eq() get_hequal() - -// `hfact`: the fact operator -#define sl_fact() get_hfact() - -// `|- !hp:hprop. (emp ** hp) = hp` -#define sl_sep_emp_left() get_hsep_hemp_left() - -// `|- !hp:hprop. (hp ** emp) = hp` -#define sl_sep_emp_right() get_hsep_hemp_right() - -// `|- !hp1 hp2 hp3:hprop. ((hp1 ** hp2) ** hp3) = (hp1 ** (hp2 ** hp3))` -#define sl_sep_assoc() get_hsep_assoc() - -// `|- !hp1 hp2:hprop. (hp1 ** hp2) = (hp2 ** hp1)` -#define sl_sep_comm() get_hsep_comm() - -// `|- !hp1 hp2 hp3 hp4. (hp1 |-- hp2) ==> (hp3 |-- hp4) ==> (hp1 ** hp3 |-- hp2 ** hp4)` -#define sl_sep_mono() get_hsep_monotone() - -// `|- !hp1 hp2 hp3:hprop. (hp1 ** hp2 |-- hp3) = (hp1 |-- hp2 -* hp3)` -#define sl_wand_sep_adjoint() get_hwand_hsep_adjoint() - -// `|- !hp1 hp2 hp3. (hp1 |-- hp2) ==> (hp1 |-- hp3) ==> (hp1 |-- hp2 && hp3)` -#define sl_and_intro() get_hand_intro() - -// `|- !hp1 hp2. (hp1 && hp2 |-- hp1)` -#define sl_and_elim1() get_hand_elim1() - -// `|- !hp1 hp2. (hp1 && hp2 |-- hp2)` -#define sl_and_elim2() get_hand_elim2() - -// `|- !hp1 hp2. (hp1 |-- hp1 || hp2)` -#define sl_or_intro1() get_hor_intro1() - -// `|- !hp1 hp2. (hp2 |-- hp1 || hp2)` -#define sl_or_intro2() get_hor_intro2() - -// `|- !hp1 hp2 hp3. (hp1 |-- hp3) ==> (hp2 |-- hp3) ==> (hp1 || hp2 |-- hp3)` -#define sl_or_elim() get_hor_elim() - -// `|- !(x : alpha) hp hpA. (hp |-- hpA x) ==> (hp |-- (exists x : alpha. hpA x))` -#define sl_exists_intro() get_hexists_intro() - -// `|- !hp hpA. (!x : alpha. hpA x |-- hp) ==> ((exists y : alpha. hpA y) |-- hp)` -#define sl_exists_elim() get_hexists_elim() - -// `|- !hpA hp. ((exists x:alpha. hpA x) ** hp) = (exists x:alpha. hpA x ** hp)` -#define sl_sep_exists_left() get_hsep_hexists_left() - -// `|- !hp hpA. (hp ** (exists x:alpha. hpA x)) = (exists x:alpha. hp ** hpA x)` -#define sl_sep_exists_right() get_hsep_hexists_right() - -// `|- !hp. hp |-- hp` -#define sl_ent_refl() get_hentail_refl() - -// `|- !hp1 hp2 hp3. (hp1 |-- hp2) ==> (hp2 |-- hp3) ==> (hp1 |-- hp3)` -#define sl_ent_trans() get_hentail_trans() - -// `|- !hp1 hp2:hprop. (hp1 |-- hp2) ==> (hp2 |-- hp1) ==> (hp1 = hp2)` -#define sl_ent_antisym() get_hentail_antisym() - -// `|- !p hp1 hp2. p ==> (hp1 |-- hp2) ==> (hp1 |-- fact(p) ** hp2)` -#define sl_fact_intro() get_hfact_intro() + thm bupd_intro; + thm bupd_mono; + thm bupd_idem; + thm bupd_frame; + thm viewshift_refl; + thm viewshift_entails; + thm viewshift_trans; + thm viewshift_mono; + thm viewshift_frame; + thm viewshift_sep; + thm viewshift_fact; + thm viewshift_exists; +} sl_update_theory; + +/** + * Install a complete signature and make it active until another installation. + * + * Check that the assertion type is monomorphic, check all connective types, + * require `exists_op` and `forall_op` to be HOL constants with exactly one + * polymorphic witness type, require their primitive laws in canonical eta-long + * schemas, and reject an empty primitive theorem handle. Return zero on success and + * `-1` after reporting a prover error on failure. Before returning success, + * installation proves and exact-checks every signature-dependent derived + * theorem, binds the public theorem globals below, increments + * `sl_theory_generation()`, and invalidates any installed update signature. + * A failure while constructing derived theorems restores the previously active + * signature and theorem globals. + */ +PROOF int sl_install_theory(const sl_theory* theory); + +/** + * Return whether a base SL signature is currently installed. + * + * Unlike `sl_current_theory()` this predicate never reports an error. It is + * intended for generic proof modules whose optional closed-theorem audits may + * be compiled as standalone verification roots before any assertion model is + * selected; proof rules themselves must still require an installed theory. + */ +PROOF bool sl_theory_is_installed(void); -// `|- !p hp1 hp2. (p ==> (hp1 |-- hp2)) ==> (fact(p) ** hp1 |-- hp2)` -#define sl_fact_elim() get_hfact_elim() +/** + * Return the active signature. + * + * A signature must have been installed explicitly. If none is active, report + * a prover error and return a borrowed pointer to the empty internal slot so + * macro accessors remain non-crashing while preserving the error status. The + * slot is replaced by a later successful install. + */ +PROOF const sl_theory* sl_current_theory(void); -// `|- fact(T) = emp` -#define sl_fact_true_emp() get_htrue_hemp() +/** + * Return the monotonically increasing key for the active theory. + * Report a prover error and return zero before the first successful install. + */ +PROOF size_t sl_theory_generation(void); /** - * Validate a theorem before caching it as a derived SL rule. + * Borrowed accessors for the active assertion type and connective handles. * - * Require `th` to be closed and its conclusion to be ≡α to - * `parse_term(expected_str)`. A mismatch is a library programming error and - * aborts the process; `name` is used only in the diagnostic. Parenthesize - * entailments inside implication strings, for example - * `p ==> q ==> (H |-- K)`. + * Every macro calls `sl_current_theory()` and returns the corresponding handle + * from its internal slot; no handle or storage is copied. Before installation, + * the accessor records a prover error and yields the empty member of that slot. + * Operator types are the ones documented for `sl_theory`. */ -PROOF void sl_thm_lazy_init_check(const char* name, thm th, const char* expected_str); +#define sl_prop() (sl_current_theory()->prop_type) +#define sl_emp() (sl_current_theory()->emp) +#define sl_sep() (sl_current_theory()->sep) +#define sl_wand() (sl_current_theory()->wand) +#define sl_and() (sl_current_theory()->and_op) +#define sl_or() (sl_current_theory()->or_op) +#define sl_exists() (sl_current_theory()->exists_op) +#define sl_forall() (sl_current_theory()->forall_op) +#define sl_ent() (sl_current_theory()->entails) +#define sl_equiv() (sl_current_theory()->equiv) +#define sl_fact() (sl_current_theory()->fact) + +/** + * Return raw HOL equality specialized to `sl_prop() -> sl_prop() -> bool`. + * + * Each call builds a probe equality at `sl_prop()` and returns its shared + * instantiated operator handle. Fail with `empty_term` if no base theory is + * active or equality specialization fails. + */ +PROOF term sl_raw_eq(void); +/** Borrowed compatibility accessor for `sl_raw_eq()`. */ +#define sl_eq() sl_raw_eq() + +/** + * Borrowed accessors for the primitive theorem handles in `sl_theory`. + * + * Their intended closed HOL schemas and the installer's validation boundary + * are documented on `sl_theory`. No accessor proves, instantiates, or copies a + * theorem; it returns the currently installed handle and inherits + * `sl_current_theory()` failure behavior and lifetime. + */ +#define sl_sep_emp_left() (sl_current_theory()->sep_emp_left) +#define sl_sep_emp_right() (sl_current_theory()->sep_emp_right) +#define sl_sep_assoc() (sl_current_theory()->sep_assoc) +#define sl_sep_comm() (sl_current_theory()->sep_comm) +#define sl_sep_mono() (sl_current_theory()->sep_mono) +#define sl_wand_sep_adjoint() (sl_current_theory()->wand_sep_adjoint) +#define sl_and_intro() (sl_current_theory()->and_intro) +#define sl_and_elim1() (sl_current_theory()->and_elim1) +#define sl_and_elim2() (sl_current_theory()->and_elim2) +#define sl_or_intro1() (sl_current_theory()->or_intro1) +#define sl_or_intro2() (sl_current_theory()->or_intro2) +#define sl_or_elim() (sl_current_theory()->or_elim) +#define sl_exists_intro() (sl_current_theory()->exists_intro) +#define sl_exists_elim() (sl_current_theory()->exists_elim) +#define sl_exists_mono_primitive() (sl_current_theory()->exists_mono) +#define sl_sep_exists_left() (sl_current_theory()->sep_exists_left) +#define sl_sep_exists_right() (sl_current_theory()->sep_exists_right) +#define sl_forall_intro() (sl_current_theory()->forall_intro) +#define sl_forall_elim() (sl_current_theory()->forall_elim) +#define sl_ent_refl() (sl_current_theory()->ent_refl) +#define sl_ent_trans() (sl_current_theory()->ent_trans) +#define sl_equiv_intro() (sl_current_theory()->equiv_intro) +#define sl_fact_intro() (sl_current_theory()->fact_intro) +#define sl_fact_elim() (sl_current_theory()->fact_elim) +#define sl_fact_dup() (sl_current_theory()->fact_dup) +#define sl_fact_true_emp() (sl_current_theory()->fact_true_emp) /** - * Define a checked, lazily initialized derived-theorem getter. + * Install an update signature for the currently active SL generation. * - * ```c - * thm prove_sl_conj1() { ... } - * SL_THM_LAZY_INIT(sl_conj1, "!a b c. (a |-- b && c) ==> (a |-- b)"); - * ``` + * Validate both operator types and the exact closed schema of every primitive + * theorem. Return zero on success and `-1` on failure. A failed install leaves + * any currently valid update signature unchanged. + */ +PROOF int sl_install_update_theory(const sl_update_theory* theory); + +/** Return whether an update signature is installed for the active SL theory. */ +PROOF bool sl_update_theory_is_installed(void); + +/** + * Return the update signature bound to the active SL generation. * - * The expansion defines a zero-argument function `name()`. Its first call - * invokes `prove_name()`, validates the resulting closed theorem against - * `expected_str` modulo alpha-equivalence with `sl_thm_lazy_init_check`, and - * caches the handle. Every later call returns that same handle without - * reproving or rechecking it. - */ -#define SL_THM_LAZY_INIT(name, expected_str) \ - PROOF thm name() { \ - static bool initialized = false; \ - static thm __##name; \ - if (!initialized) { \ - initialized = true; \ - __##name = prove_##name(); \ - sl_thm_lazy_init_check(#name, __##name, expected_str); \ - } \ - return __##name; \ - } + * Report a prover error when no matching signature is installed. As with + * `sl_current_theory`, the error return points at an empty internal slot so a + * term/theorem accessor yields an empty handle instead of dereferencing null. + */ +PROOF const sl_update_theory* sl_current_update_theory(void); + +/** + * Borrowed update-operator and primitive-theorem accessors. + * + * `sl_bupd()` and `sl_viewshift()` have the operator types documented on + * `sl_update_theory`; the remaining macros return the exact closed primitive + * theorem schemas listed there. No macro constructs or instantiates a theorem. + * Without a matching update bundle, each records a prover error and yields an + * empty handle from the internal slot. + */ +#define sl_bupd() (sl_current_update_theory()->bupd) +#define sl_viewshift() (sl_current_update_theory()->viewshift) +#define sl_bupd_intro_primitive() (sl_current_update_theory()->bupd_intro) +#define sl_bupd_mono_primitive() (sl_current_update_theory()->bupd_mono) +#define sl_bupd_idem_primitive() (sl_current_update_theory()->bupd_idem) +#define sl_bupd_frame_primitive() (sl_current_update_theory()->bupd_frame) +#define sl_viewshift_refl_primitive() \ + (sl_current_update_theory()->viewshift_refl) +#define sl_entails_viewshift_primitive() \ + (sl_current_update_theory()->viewshift_entails) +#define sl_viewshift_trans_primitive() \ + (sl_current_update_theory()->viewshift_trans) +#define sl_viewshift_mono_primitive() \ + (sl_current_update_theory()->viewshift_mono) +#define sl_viewshift_frame_primitive() \ + (sl_current_update_theory()->viewshift_frame) +#define sl_viewshift_sep_primitive() \ + (sl_current_update_theory()->viewshift_sep) +#define sl_viewshift_fact_primitive() \ + (sl_current_update_theory()->viewshift_fact) +#define sl_viewshift_exists_primitive() \ + (sl_current_update_theory()->viewshift_exists) + /*-------------------- Term Structure Analysis --------------------*/ /** * Recognize an SL assertion by its HOL type. * - * Return true exactly when `type_of(tm) = hprop`. This tests the type only; - * it does not inspect the assertion's outer constructor. + * Return true exactly when `type_of(tm) = sl_prop()`. This tests the type + * only; it does not inspect the assertion's outer constructor. */ PROOF bool is_sl_prop(const term tm); @@ -193,7 +374,7 @@ PROOF bool is_sl_prop(const term tm); * Create a named variable ranging over SL assertions. * * Return `mk_var(s, sl_prop())`; for example, `mk_sl_prop("H")` constructs - * `H:hprop`. Name handling and any malformed input are delegated to `mk_var`. + * `H:sl_prop()`. Name handling and malformed input are delegated to `mk_var`. */ PROOF term mk_sl_prop(const char* s); @@ -216,8 +397,8 @@ PROOF bool is_sl_sep(const term hp); /** * Construct the separating conjunction of two SL assertions. * - * For `H,K:hprop`, return `H ** K`. The HOL constructor reports a prover - * error if either operand is not an SL assertion. + * For assertions `H,K:sl_prop()`, return `H ** K`. The HOL constructor + * reports a prover error if either operand has another type. */ PROOF term mk_sl_sep(const term hp1, const term hp2); @@ -245,7 +426,7 @@ PROOF term list_mk_sl_sep(const term_list hps); * * Return `flat(H)` in left-to-right order, preserving duplicates and literal * unit leaves. Thus `flat((H ** K) ** F) = [H,K,F]` and `flat(emp) = [emp]`. - * A non-`hprop` input is a prover error. + * An input outside `sl_prop()` is a prover error. */ PROOF term_list strip_sl_sep(const term hp); @@ -270,8 +451,8 @@ PROOF bool is_sl_wand(const term hp); /** * Construct a magic wand between two SL assertions. * - * For `H,K:hprop`, return `H -* K`. The HOL constructor reports a prover error - * if either operand is not an SL assertion. + * For assertions `H,K:sl_prop()`, return `H -* K`. The HOL constructor + * reports a prover error if either operand has another type. */ PROOF term mk_sl_wand(const term hp1, const term hp2); @@ -294,8 +475,8 @@ PROOF bool is_sl_and(const term hp); /** * Create an additive conjunction from two SL assertions. * - * For `H,K:hprop`, return `H && K`. The HOL constructor reports a prover error - * if either operand is not an SL assertion. + * For assertions `H,K:sl_prop()`, return `H && K`. The HOL constructor + * reports a prover error if either operand has another type. */ PROOF term mk_sl_and(const term hp1, const term hp2); @@ -318,8 +499,8 @@ PROOF bool is_sl_or(const term tm); /** * Create an additive disjunction from two SL assertions. * - * For `H,K:hprop`, return `H || K`. The HOL constructor reports a prover error - * if either operand is not an SL assertion. + * For assertions `H,K:sl_prop()`, return `H || K`. The HOL constructor + * reports a prover error if either operand has another type. */ PROOF term mk_sl_or(const term hp1, const term hp2); @@ -334,16 +515,20 @@ PROOF dest_binop_results dest_sl_or(const term hp); /** * Recognize an outermost SL existential. * - * Return `is_binder("hexists", tm)`, so the result is true exactly for terms - * whose outer form is `∃SL x:α. H`. + * Recognize an application of the installed polymorphic `exists_op` to an + * abstraction. The application head's HOL constant name is compared with the + * name cached at theory installation; witness-type instances therefore need + * no term reconstruction or matching. The abstraction is not beta-reduced. */ PROOF bool is_sl_exists(const term tm); /** * Bind one variable existentially in an SL assertion. * - * For a variable `x:α` and `H:hprop`, return `∃SL x:α. H`. Report a - * prover error if `v` is not a variable or `hp` is not an SL assertion. + * For a variable `x:α` and assertion `H`, return the operator application + * `exists_op (\x. H)`. The operator's witness type is explicitly instantiated + * to `type_of(x)`. Report a prover error if `v` is not a variable or `hp` does + * not have the installed assertion type. */ PROOF term mk_sl_exists(const term v, const term hp); @@ -364,8 +549,25 @@ PROOF dest_binder_results dest_sl_exists(const term hp); */ PROOF term list_mk_sl_exists(const term_list vs, const term hp); +/** + * Recognize an outermost installed SL universal binder. + * + * This uses the installed universal constant name with the same shape + * guarantees as `is_sl_exists` and performs no beta reduction. + */ +PROOF bool is_sl_forall(const term tm); + +/** Return `forall_op (\v. hp)` using the installed assertion theory. */ +PROOF term mk_sl_forall(const term v, const term hp); + +/** Expose the variable and body of an outermost installed SL universal. */ +PROOF dest_binder_results dest_sl_forall(const term hp); + +/** Result of stripping the maximal leading SL-existential prefix. */ PROOF typedef struct { + /** Fresh binder vector ordered outermost first, or `NULL` when empty/error. */ term_list vs; // The list of variables. + /** Borrowed handle to the residual assertion after the syntactic prefix. */ term hp; // The SL assertion. } strip_sl_exists_results; @@ -373,11 +575,69 @@ PROOF typedef struct { * Remove the maximal leading prefix of SL existentials. * * If `E = Ex(V,H)` and `H` is not itself an outermost SL existential, return - * `{.vs = V, .hp = H}` with binders ordered outermost first. For a binder-free - * assertion return an empty `vs`; a non-SL input is a prover error. + * `{.vs = V, .hp = H}` with binders ordered outermost first. This is a purely + * syntactic destructor: it never performs beta reduction. Consequently an + * explicit `(\x. exists y. P) t` terminates the prefix scan at that redex; the + * constructor or rule that introduced it must reduce it explicitly. For a binder-free assertion + * return `.vs = NULL` and `.hp = hp`; this API explicitly uses `NULL` as its + * successful empty sequence representation. A non-SL input is an error and returns + * `{.vs = NULL, .hp = empty_term}`. A non-null vector container is fresh, but + * its binders and the residual assertion are shared HOL handles with prover-managed + * lifetime; callers do not free or mutate the handles themselves. */ PROOF strip_sl_exists_results strip_sl_exists(const term hp); +/*---------------- Optional update term structure ----------------*/ + +/** + * Recognize an outermost `bupd P` from the installed update signature. + * + * Return false without reporting an error when no update signature is active; + * otherwise compare only the outer operator and do no unfolding. + */ +PROOF bool is_sl_bupd(const term tm); + +/** + * Construct `bupd P` for an active-SL assertion `P`. + * + * Return a borrowed HOL term handle. Report a prover error and return + * `empty_term` if the update theory is absent or the application is ill typed. + */ +PROOF term mk_sl_bupd(const term hp); + +/** + * Return the borrowed operand `P` from an outermost `bupd P`. + * + * Report a prover error and return `empty_term` when the update theory is + * absent or the input has another outer constructor. + */ +PROOF term dest_sl_bupd(const term tm); + +/** + * Recognize the installed Boolean view-shift relation `P ⇛ Q`. + * + * Return false without reporting an error when no update signature is active; + * otherwise inspect only the outer binary operator. + */ +PROOF bool is_sl_viewshift(const term tm); + +/** + * Construct the Boolean proposition `P ⇛ Q` from active-SL assertions. + * + * Report a prover error and return `empty_term` if no update theory is active + * or either endpoint is ill typed. + */ +PROOF term mk_sl_viewshift(const term hp1, const term hp2); + +/** + * Decompose an outermost `P ⇛ Q` into borrowed source and target handles. + * + * Preserve endpoint order. Report a prover error and return the empty + * `dest_binop_results` record if the update theory is absent or the input has + * another outer constructor. + */ +PROOF dest_binop_results dest_sl_viewshift(const term tm); + /** * Recognize an outermost SL entailment. * @@ -389,8 +649,9 @@ PROOF bool is_sl_ent(const term tm); /** * Construct an SL entailment proposition. * - * For `H,K:hprop`, return the Boolean proposition `H ⊢SL K`. The HOL - * constructor reports a prover error if either endpoint is not an SL assertion. + * For assertions `H,K:sl_prop()`, return the Boolean proposition `H ⊢SL K`. + * The HOL constructor reports a prover error if either endpoint has another + * type. */ PROOF term mk_sl_ent(const term hp1, const term hp2); @@ -402,28 +663,56 @@ PROOF term mk_sl_ent(const term hp1, const term hp2); */ PROOF dest_binop_results dest_sl_ent(const term tm); +/** + * Recognize an outermost active-SL logical equivalence. + * + * Return `is_binop(sl_equiv(), tm)`, so the result is true exactly for terms + * whose outer form is `H ≃SL K`. This is distinct from raw `H = K`. With no + * active base theory, `sl_equiv()` records a prover error and the recognizer + * returns false. + */ +PROOF bool is_sl_equiv(const term tm); + +/** + * Construct active-SL logical equivalence. + * + * For `H,K:sl_prop()`, return the Boolean proposition `H ≃SL K`. Report a + * prover error and return `empty_term` when no base theory is active or either + * endpoint has another type. + */ +PROOF term mk_sl_equiv(const term hp1, const term hp2); + +/** + * Decompose an outermost active-SL logical equivalence. + * + * For `H ≃SL K`, return `{.tm1 = H, .tm2 = K}` in endpoint order. Report a + * prover error and return `{empty_term, empty_term}` when no base theory is + * active or the input has another outer constructor. + */ +PROOF dest_binop_results dest_sl_equiv(const term tm); + /** * Check for ordinary equality whose operands are SL assertions. * * Return `is_binop(sl_eq(), tm)`, so the result is true exactly for ordinary - * HOL equalities `H =ₕ K`. An SL entailment is not an SL equality. + * HOL equalities `H = K`. An SL entailment is not an SL equality. */ PROOF bool is_sl_eq(const term tm); /** * Create ordinary equality between two SL assertions. * - * For `H,K:hprop`, return `H =ₕ K`; C* assertion syntax may print this as - * `H -|- K`. The HOL constructor reports a prover error if either operand is - * not an SL assertion. + * For assertions `H,K:sl_prop()`, return ordinary HOL equality `H = K`. + * The HOL constructor reports a prover error if either operand has another + * type. */ PROOF term mk_sl_eq(const term hp1, const term hp2); /** * Decompose equality between two SL assertions. * - * For `H =ₕ K`, return `{.tm1 = H, .tm2 = K}`. Report a prover error - * when the input is not ordinary equality at `hprop`. + * For `H = K`, return `{.tm1 = H, .tm2 = K}`. Report a prover error + * when the input is not ordinary equality at `sl_prop()`. */ PROOF dest_binop_results dest_sl_eq(const term tm); @@ -454,164 +743,249 @@ PROOF term dest_sl_fact(const term tm); /*----------------------- Derived Theorems ------------------------*/ +/* + * The globals in this section are valid only after `sl_install_theory` + * succeeds. The installer constructs each displayed closed schema + * independently, alpha-aligns the proof to that schema when necessary, and + * requires `equals_term(concl(global), documented_schema)` before publishing + * the binding. A failed install publishes none of the candidate bindings. + */ + /** - * Return the cached theorem that turns SL-assertion equality into entailment. + * Globally bound theorem turning SL-assertion equality into entailment. + * + * HOL conclusion in the installed notation: + * + * ```text + * forall (H:sl_prop()) (K:sl_prop()). (H = K) ==> (H ⊢SL K) + * ``` * - * The result is exactly `∅ ⊢ ∀H K. (H =ₕ K) ⇒ (H ⊢SL K)`. Its first call - * proves and checks the closed theorem; later calls return the cached handle. + * 两个断言在 HOL 中相等时，前者在 SL 中蕴含后者。 */ -PROOF thm sl_ent_sym_left(); +PROOF extern thm sl_ent_sym_left; /** * Restate both endpoints of an entailment using supplied equalities. * * ```text - * H =ₕ H' K =ₕ K' H' ⊢SL K' + * H = H' K = K' H' ⊢SL K' * ----------------------------------- * H ⊢SL K * ``` * - * The result is closed and universally quantified over the displayed - * assertions. Applying it preserves the hypotheses of every premise. + * HOL conclusion in the installed notation: + * `forall (H:sl_prop()) (H1:sl_prop()) (K:sl_prop()) (K1:sl_prop()). + * (H = H1) ==> (K = K1) ==> (H1 ⊢SL K1) ==> (H ⊢SL K)`. + * + * 若等式把蕴含两端改写为 `H'` 与 `K'`，则可将 `H' ⊢SL K'` 还原为 `H ⊢SL K`。 */ -PROOF thm sl_ent_restate(); +PROOF extern thm sl_ent_restate; /** * Frame a child entailment and restate both endpoints in one derived rule. * * ```text - * H =ₕ F ** H' K =ₕ F ** K' H' ⊢SL K' + * H = F ** H' K = F ** K' H' ⊢SL K' * --------------------------------------------- * H ⊢SL K * ``` * - * The result is closed and universally quantified. The endpoint equalities - * determine the result syntax, and premise hypotheses are preserved. + * HOL conclusion in the installed notation: + * `forall (H:sl_prop()) (F:sl_prop()) (H1:sl_prop()) (K:sl_prop()) + * (K1:sl_prop()). (H = F ** H1) ==> (K = F ** K1) ==> (H1 ⊢SL K1) ==> + * (H ⊢SL K)`. + * + * 将蕴含两端改写为带同一左框架 `F` 的形式后，可由框架内的蕴含推出原目标。 */ -PROOF thm sl_frame_restate(); +PROOF extern thm sl_frame_restate; /** - * Return the cached theorem for left framing. + * Globally bound theorem for left framing. + * + * HOL conclusion in the installed notation: + * + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). (H ⊢SL K) ==> + * (F ** H ⊢SL F ** K) + * ``` * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL K) ⇒ (F ** H ⊢SL F ** K)`. It is proved, - * checked, and cached on first use. + * `H ⊢SL K` 在左侧加入同一框架 `F` 后仍成立。 */ -PROOF thm sl_ent_frame_left(); +PROOF extern thm sl_ent_frame_left; /** - * Return the cached theorem for right framing. + * Globally bound theorem for right framing. * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL K) ⇒ (H ** F ⊢SL K ** F)`. It is proved, - * checked, and cached on first use. + * HOL conclusion in the installed notation: + * + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). (H ⊢SL K) ==> + * (H ** F ⊢SL K ** F) + * ``` + * + * `H ⊢SL K` 在右侧加入同一框架 `F` 后仍成立。 */ -PROOF thm sl_ent_frame_right(); +PROOF extern thm sl_ent_frame_right; /** * Return framed substitution on an entailment antecedent. * * ```text - * H =ₕ K C =ₕ K ** F C ⊢SL G + * H = K C = K ** F C ⊢SL G * ------------------------------------- * H ** F ⊢SL G * ``` * - * The cached theorem is closed and universally quantified. It avoids first - * rewriting the supplied entailment endpoint. + * HOL conclusion in the installed notation: + * `forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()) (C:sl_prop()) + * (G:sl_prop()). (H = K) ==> (C = K ** F) ==> (C ⊢SL G) ==> + * (H ** F ⊢SL G)`. + * + * 若 `H` 可改写为 `K`，且已证明 `K ** F ⊢SL G`，则得到 `H ** F ⊢SL G`。 */ -PROOF thm sl_ent_subst_frame(); +PROOF extern thm sl_ent_subst_frame; /** * Combine two child entailments under `**` and restore the parent endpoints. * * ```text - * H =ₕ H₁ ** H₂ K =ₕ K₁ ** K₂ H₁ ⊢SL K₁ H₂ ⊢SL K₂ + * H = H₁ ** H₂ K = K₁ ** K₂ H₁ ⊢SL K₁ H₂ ⊢SL K₂ * ------------------------------------------------------------ * H ⊢SL K * ``` * - * The result is the closed, universally quantified theorem for this rule. It - * is proved and cached once for separating-conjunction validators. + * HOL conclusion in the installed notation: + * `forall (H:sl_prop()) (H1:sl_prop()) (H2:sl_prop()) (K:sl_prop()) + * (K1:sl_prop()) (K2:sl_prop()). (H = H1 ** H2) ==> (K = K1 ** K2) ==> + * (H1 ⊢SL K1) ==> (H2 ⊢SL K2) ==> (H ⊢SL K)`. + * + * 两个分量的蕴含可逐项合成为对应分离合取之间的蕴含。 */ -PROOF thm sl_sep_combine(); +PROOF extern thm sl_sep_combine; /** * Return the equality laws used by the HOL AC prover for `**`. * - * Return a closed conjunction containing, in order: commutativity - * `H ** K =ₕ K ** H`, associativity - * `(H ** K) ** F =ₕ H ** (K ** F)`, and lifted commutativity - * `H ** (K ** F) =ₕ K ** (H ** F)`, all universally quantified. Pass this - * theorem to `ac_rule`; units are not part of this AC theory. + * HOL conclusion in the installed notation: + * + * ```text + * (forall (H:sl_prop()) (K:sl_prop()). H ** K = K ** H) /\ ((forall + * (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). (H ** K) ** F = + * H ** (K ** F)) /\ (forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). + * H ** (K ** F) = K ** (H ** F))) + * ``` + * + * The conjunction order is commutativity, associativity, then lifted + * commutativity. Pass this theorem to `ac_rule`; units are not part of this + * AC theory. + * + * 将分离合取的交换律、结合律及嵌套交换律打包为不含单位元的 AC 重写规则。 */ -PROOF thm sl_ac_rule(); +PROOF extern thm sl_ac_rule; /** - * Return the cached theorem for monotonicity of additive disjunction. + * Globally bound theorem for monotonicity of additive disjunction. + * + * HOL conclusion in the installed notation: + * + * ```text + * forall (H1:sl_prop()) (H2:sl_prop()) (K1:sl_prop()) (K2:sl_prop()). + * (H1 ⊢SL K1) ==> (H2 ⊢SL K2) ==> ((H1 || H2) ⊢SL (K1 || K2)) + * ``` * - * The result is exactly - * `∅ ⊢ ∀H₁ H₂ K₁ K₂. (H₁ ⊢SL K₁) ⇒ (H₂ ⊢SL K₂) ⇒` - * `(H₁ || H₂ ⊢SL K₁ || K₂)`. It is proved, checked, and cached on first - * use. + * 两个分支分别按蕴含替换时，它们的加法析取也保持同方向的蕴含。 */ -PROOF thm sl_disj_mono(); +PROOF extern thm sl_disj_mono; /** * Return additive-disjunction elimination under a shared frame. * * ```text - * C₁ =ₕ H ** F C₂ =ₕ K ** F P =ₕ (H || K) ** F + * C₁ = H ** F C₂ = K ** F P = (H || K) ** F * C₁ ⊢SL G C₂ ⊢SL G * ---------------------------------------------------------- * P ⊢SL G * ``` * - * The result is closed and universally quantified. It is cached for - * disjunctive-antecedent validation. + * HOL conclusion in the installed notation: + * `forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()) (C1:sl_prop()) + * (C2:sl_prop()) (P:sl_prop()) (G:sl_prop()). (C1 = H ** F) ==> + * (C2 = K ** F) ==> (P = (H || K) ** F) ==> (C1 ⊢SL G) ==> + * (C2 ⊢SL G) ==> (P ⊢SL G)`. + * + * 若两个析取分支与共享框架 `F` 合并后都蕴含 `G`，则整个带框架的析取也蕴含 `G`。 */ -PROOF thm sl_or_elim_frame(); +PROOF extern thm sl_or_elim_frame; /** - * Return the cached theorem for magic-wand elimination. + * Globally bound theorem for magic-wand elimination. + * + * HOL conclusion in the installed notation: * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL (K -* F)) ⇒ (H ** K ⊢SL F)`. It is proved, - * checked, and cached on first use. + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (G:sl_prop()). + * (H ⊢SL (K -* G)) ==> (H ** K ⊢SL G) + * ``` + * + * 若 `H` 蕴含从 `K` 到 `G` 的魔杖，则把 `K` 分离合取进来即可推出 `G`。 */ -PROOF thm sl_undisch(); +PROOF extern thm sl_undisch; /** - * Return the cached theorem projecting the left additive conjunct. + * Globally bound theorem projecting the left additive conjunct. + * + * HOL conclusion in the installed notation: * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL K && F) ⇒ (H ⊢SL K)`. + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). + * (H ⊢SL (K && F)) ==> (H ⊢SL K) + * ``` + * + * 从 `H ⊢SL K && F` 可投影出左合取支 `H ⊢SL K`。 */ -PROOF thm sl_conj1(); +PROOF extern thm sl_conj1; /** - * Return the cached theorem projecting the right additive conjunct. + * Globally bound theorem projecting the right additive conjunct. + * + * HOL conclusion in the installed notation: * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL K && F) ⇒ (H ⊢SL F)`. + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). + * (H ⊢SL (K && F)) ==> (H ⊢SL F) + * ``` + * + * 从 `H ⊢SL K && F` 可投影出右合取支 `H ⊢SL F`。 */ -PROOF thm sl_conj2(); +PROOF extern thm sl_conj2; /** - * Return the cached theorem injecting into the left disjunct. + * Globally bound theorem injecting into the left disjunct. + * + * HOL conclusion in the installed notation: * - * The result is exactly - * `∅ ⊢ ∀H K F. (H ⊢SL K) ⇒ (H ⊢SL K || F)`. + * ```text + * forall (H:sl_prop()) (K:sl_prop()) (F:sl_prop()). + * (H ⊢SL K) ==> (H ⊢SL (K || F)) + * ``` + * + * `H` 蕴含 `K` 时，也蕴含以 `K` 为左分支的析取 `K || F`。 */ -PROOF thm sl_disj1_mono(); +PROOF extern thm sl_disj1_mono; /** - * Return the cached theorem injecting into the right disjunct. + * Globally bound theorem injecting into the right disjunct. + * + * HOL conclusion in the installed notation: * - * The result is exactly - * `∅ ⊢ ∀F H K. (H ⊢SL K) ⇒ (H ⊢SL F || K)`. + * ```text + * forall (F:sl_prop()) (H:sl_prop()) (K:sl_prop()). + * (H ⊢SL K) ==> (H ⊢SL (F || K)) + * ``` + * + * `H` 蕴含 `K` 时，也蕴含以 `K` 为右分支的析取 `F || K`。 */ -PROOF thm sl_disj2_mono(); +PROOF extern thm sl_disj2_mono; /** * Eliminate an SL existential while preserving a shared frame. @@ -620,28 +994,27 @@ PROOF thm sl_disj2_mono(); * ∅ ⊢ (∀x. (B(x) ** F ⊢SL K)) ⇒ ((∃SL x. B(x)) ** F ⊢SL K) * ``` * - * The theorem is closed, polymorphic in the witness type, proved once from - * the primitive existential and frame laws, and cached. - */ -PROOF thm sl_exists_elim_frame(); - -/** - * Return the cached theorem for SL-existential introduction. + * HOL conclusion in the installed notation: + * `forall (B:A->sl_prop()) (F:sl_prop()) (K:sl_prop()). + * (forall x:A. B x ** F ⊢SL K) ==> ((∃SL x:A. B x) ** F ⊢SL K)`. * - * For every type `α`, return exactly - * `∅ ⊢ ∀w:α H B:α→hprop. (H ⊢SL B(w)) ⇒` - * `(H ⊢SL ∃SL x:α. B(x))`. + * 若每个见证对应的 `B(x) ** F` 都蕴含 `K`，则消去存在量词时可保留共享框架 `F`。 */ -PROOF thm sl_exists_wit(); +PROOF extern thm sl_exists_elim_frame; /** - * Return the cached theorem for monotonicity of SL existentials. + * Globally bound theorem for SL-existential introduction. + * + * HOL conclusion in the installed notation: * - * For every type `α`, return exactly - * `∅ ⊢ ∀P Q:α→hprop. (∀x:α. (P(x) ⊢SL Q(x))) ⇒` - * `((∃SL x. P(x)) ⊢SL (∃SL x. Q(x)))`. + * ```text + * forall (w:A) (H:sl_prop()) (B:A->sl_prop()). + * (H ⊢SL B w) ==> (H ⊢SL ∃SL x:A. B x) + * ``` + * + * 给定见证 `w`，由 `H ⊢SL B(w)` 可引入存在断言 `H ⊢SL ∃x. B(x)`。 */ -PROOF thm sl_exists_mono(); +PROOF extern thm sl_exists_wit; /*------------------------- Derived Rules -------------------------*/ @@ -653,8 +1026,8 @@ PROOF thm sl_exists_mono(); * ∅ ⊢ (H ⊢SL H) * ``` * - * For `H:hprop`, return the displayed closed theorem. The underlying HOL - * specialization rejects a term not typed as an SL assertion. + * For `H:sl_prop()`, return the displayed closed theorem. The underlying HOL + * specialization rejects a term of another type. */ PROOF thm refl_slrule(const term hp); @@ -664,12 +1037,14 @@ PROOF thm refl_slrule(const term hp); * ```text * 𝒜 ⊢ (H ⊢SL K) ℬ ⊢ (K' ⊢SL F) K ≡α K' * ------------------------------------------------ trans_slrule - * 𝒜 ∪ ℬ ⊢ (H ⊢SL F) + * 𝒜 ∪ ℬ ⊢ (H ⊢SL F) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K)` and `ℬ ⊢ (K' ⊢SL F)` with `K ≡α K'`, return - * `𝒜 ∪ ℬ ⊢ (H ⊢SL F)`. A non-entailment or endpoints not matching - * modulo ≡α are prover errors. + * Given `𝒜 ⊢ (H ⊢SL K)` and `ℬ ⊢ (K' ⊢SL F)` with alpha-equivalent middle + * endpoints, return `𝒜 ∪ ℬ ⊢ (H ⊢SL F)` while retaining the original displayed + * endpoints `H` and `F`. No beta normalization is attempted; a producer of a + * beta-redex must construct its local conversion before composition. A + * non-entailment or non-alpha-equivalent endpoints are prover errors. */ PROOF thm trans_slrule(const thm ent1, const thm ent2); @@ -677,30 +1052,181 @@ PROOF thm trans_slrule(const thm ent1, const thm ent2); * Convert equality between SL assertions to left-to-right entailment. * * ```text - * 𝒜 ⊢ (H =ₕ K) + * 𝒜 ⊢ (H = K) * ---------------- eq2ent * 𝒜 ⊢ (H ⊢SL K) * ``` * - * Given `𝒜 ⊢ (H =ₕ K)`, return `𝒜 ⊢ (H ⊢SL K)`, preserving all hypotheses. - * Reject a theorem whose conclusion is not equality at `hprop`. + * Given `𝒜 ⊢ (H = K)`, return `𝒜 ⊢ (H ⊢SL K)`, preserving all hypotheses. + * Reject a theorem whose conclusion is not equality at `sl_prop()`. */ PROOF thm eq2ent(const thm eq); /** - * Turn mutually opposite entailments into `hprop` equality. + * Turn mutually opposite entailments into logical assertion equivalence. * * ```text * 𝒜 ⊢ (H ⊢SL K) ℬ ⊢ (K' ⊢SL H') H ≡α H' K ≡α K' - * --------------------------------------------------------- antisym_slrule - * 𝒜 ∪ ℬ ⊢ (H =ₕ K) + * --------------------------------------------------------- equiv_slrule + * 𝒜 ∪ ℬ ⊢ (H ≃SL K) * ``` * * Given `𝒜 ⊢ (H ⊢SL K)` and `ℬ ⊢ (K' ⊢SL H')` with `H ≡α H'` and - * `K ≡α K'`, return `𝒜 ∪ ℬ ⊢ (H =ₕ K)`. Reject mismatched directions. + * `K ≡α K'`, return `𝒜 ∪ ℬ ⊢ (H ≃SL K)`. Reject mismatched directions. + * This rule never concludes raw HOL equality merely from validity-aware + * entailments. */ +PROOF thm equiv_slrule(const thm ent1, const thm ent2); + +/** Compatibility spelling; returns logical equivalence, not raw equality. */ PROOF thm antisym_slrule(const thm ent1, const thm ent2); +/*--------------------- Optional update rules --------------------*/ + +/** + * Instantiate basic-update introduction at `P`. + * + * For `P:sl_prop()`, return the closed theorem `∅ ⊢ (P ⊢SL bupd P)`. + * Require an installed update theory; malformed or ill-typed input reports a + * prover error and returns `empty_theorem`. + */ +PROOF thm bupd_intro_slrule(const term hp); + +/** + * Lift an entailment through basic update. + * + * From `𝒜 ⊢ (P ⊢SL Q)`, return + * `𝒜 ⊢ (bupd P ⊢SL bupd Q)`. The exact hypothesis set is preserved. Require + * an installed update theory and an entailment conclusion; on failure return + * `empty_theorem` after reporting a prover error. + */ +PROOF thm bupd_mono_slrule(const thm ent); + +/** + * Instantiate basic-update idempotence. + * + * The argument `hp` is the underlying assertion `P`. Return + * `∅ ⊢ (bupd (bupd P) ⊢SL bupd P)`. An absent update theory or a non-SL + * argument reports a prover error and returns `empty_theorem`. + */ +PROOF thm bupd_idem_slrule(const term hp); + +/** + * Instantiate the right-frame law for basic update. + * + * `hp` is the underlying assertion `P` and `frame` is `F`; return the closed + * theorem `∅ ⊢ (bupd P ** F ⊢SL bupd (P ** F))`. Require both active-SL + * types and an installed update theory; otherwise return `empty_theorem`. + */ +PROOF thm bupd_frame_slrule(const term hp, const term frame); + +/** + * Instantiate view-shift reflexivity at `P`. + * + * Return `∅ ⊢ (P ⇛ P)`, or `empty_theorem` on an absent update theory or an + * ill-typed assertion. + */ +PROOF thm viewshift_refl_slrule(const term hp); + +/** + * Convert an entailment into a view shift. + * + * From `𝒜 ⊢ (P ⊢SL Q)`, return `𝒜 ⊢ (P ⇛ Q)` with exactly the same HOL + * hypotheses. Require an installed update theory and an entailment conclusion; + * otherwise report a prover error and return `empty_theorem`. + */ +PROOF thm entails_viewshift_slrule(const thm ent); + +/** + * Compose view shifts in the displayed order. + * + * From `𝒜 ⊢ (P ⇛ Q)` and `ℬ ⊢ (Q' ⇛ S)` with `Q ≡α Q'`, return + * `𝒜 ∪ ℬ ⊢ (P ⇛ S)`. Reject non-view-shift conclusions or mismatched middle + * endpoints and return `empty_theorem`. + */ +PROOF thm viewshift_trans_slrule(const thm first, const thm second); + +/** + * Apply view-shift consequence. + * + * From `𝒜₁ ⊢ (P2 ⊢SL P)`, `𝒜₂ ⊢ (P ⇛ Q)`, and + * `𝒜₃ ⊢ (Q ⊢SL Q2)`, derive `𝒜₁ ∪ 𝒜₂ ∪ 𝒜₃ ⊢ (P2 ⇛ Q2)`. + * Adjacent endpoints must match modulo alpha-equivalence. Hypotheses are + * combined by HOL inference; malformed conclusions yield `empty_theorem`. + */ +PROOF thm viewshift_mono_slrule(const thm pre_ent, const thm change, + const thm post_ent); + +/** + * Frame a view shift on the right. + * + * From `𝒜 ⊢ (P ⇛ Q)` and `F:sl_prop()`, return + * `𝒜 ⊢ (P ** F ⇛ Q ** F)`. Preserve hypotheses; reject an invalid conclusion + * or frame and return `empty_theorem`. + */ +PROOF thm viewshift_frame_slrule(const thm change, const term frame); + +/** + * Combine two view shifts under separating conjunction. + * + * From `𝒜 ⊢ (P1 ⇛ Q1)` and `ℬ ⊢ (P2 ⇛ Q2)`, return + * `𝒜 ∪ ℬ ⊢ (P1 ** P2 ⇛ Q1 ** Q2)`. Malformed inputs report a prover error + * and return `empty_theorem`. + */ +PROOF thm viewshift_sep_slrule(const thm first, const thm second); + +/** + * Internalize one Boolean hypothesis as a preserved spatial fact. + * + * ```text + * 𝒜 ⊢ P ⇛ Q + * -------------------------------- viewshift_elim_fact_slrule p + * 𝒜 ∖ {p} ⊢ fact(p) ** P ⇛ fact(p) ** Q + * ``` + * + * `p` must be Boolean and `change` must conclude an active view shift. The + * rule discharges one alpha-equivalent `p` hypothesis when present, preserves + * all other hypotheses, and uses the installed exact `viewshift_fact` law. + */ +PROOF thm viewshift_elim_fact_slrule(const term p, const thm change); + +/** + * Lift a pointwise universally quantified view shift through existential + * assertions. + * + * ```text + * 𝒜 ⊢ ∀x. P(x) ⇛ Q(x) + * ------------------------------------------------ + * 𝒜 ⊢ (∃SL x. P(x)) ⇛ (∃SL x. Q(x)) + * ``` + * + * The conclusion of `pointwise` must have exactly one outer universal binder + * whose body is an active view shift. The witness type and exact public binder + * syntax are taken from that binder. Only the four family applications + * introduced by specializing the installed primitive are beta-contracted; + * existing redexes inside `P(x)` or `Q(x)` are retained. Theorem hypotheses + * are preserved. + */ +PROOF thm viewshift_exists_slrule(const thm pointwise); + +/** + * Extract the source of a view shift from a complete assertion and preserve + * every unselected resource as its exact linear frame. + * + * ```text + * 𝒜 ⊢ P ⇛ Q ⊢ whole = P ** F + * -------------------------------------- + * 𝒜 ⊢ whole ⇛ Q ** F + * ``` + * + * `sep_lift_slrule` performs occurrence-sensitive multiset extraction. + * Source transport is certified in HOL by applying the fixed-target + * view-shift predicate to the equality and using `EQ_MP` on its symmetry; + * the endpoint is never replaced only in host code. + */ +PROOF thm viewshift_frame_at_slrule(const thm change, + const term whole_source); + /** * Frame an entailment with the same assertion on its left. * @@ -710,7 +1236,7 @@ PROOF thm antisym_slrule(const thm ent1, const thm ent2); * 𝒜 ⊢ (F ** H ⊢SL F ** K) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K)` and `F:hprop`, return + * Given `𝒜 ⊢ (H ⊢SL K)` and `F:sl_prop()`, return * `𝒜 ⊢ (F ** H ⊢SL F ** K)`. Hypotheses are unchanged; a malformed * entailment or non-SL frame is a prover error. */ @@ -725,7 +1251,7 @@ PROOF thm frame_left_slrule(const term hp, const thm ent); * 𝒜 ⊢ (H ** F ⊢SL K ** F) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K)` and `F:hprop`, return + * Given `𝒜 ⊢ (H ⊢SL K)` and `F:sl_prop()`, return * `𝒜 ⊢ (H ** F ⊢SL K ** F)`. Hypotheses are unchanged; a malformed * entailment or non-SL frame is a prover error. */ @@ -752,11 +1278,11 @@ PROOF thm frame_mono_slrule(const thm ent1, const thm ent2); * ```text * 𝒜 ⊢ (H ⊢SL K) ℬ ⊢ (H' ⊢SL F) H ≡α H' * --------------------------------------------- conj_slrule - * 𝒜 ∪ ℬ ⊢ (H ⊢SL K && F) + * 𝒜 ∪ ℬ ⊢ (H ⊢SL (K && F)) * ``` * * Given `𝒜 ⊢ (H ⊢SL K)` and `ℬ ⊢ (H' ⊢SL F)` with `H ≡α H'`, return - * `𝒜 ∪ ℬ ⊢ (H ⊢SL K && F)`. Non-entailments or antecedents not matching + * `𝒜 ∪ ℬ ⊢ (H ⊢SL (K && F))`. Non-entailments or antecedents not matching * modulo ≡α are prover errors. */ PROOF thm conj_slrule(const thm ent1, const thm ent2); @@ -765,12 +1291,12 @@ PROOF thm conj_slrule(const thm ent1, const thm ent2); * Project the left additive conjunct from an entailment consequent. * * ```text - * 𝒜 ⊢ (H ⊢SL K && F) + * 𝒜 ⊢ (H ⊢SL (K && F)) * ------------------------- conj1_slrule * 𝒜 ⊢ (H ⊢SL K) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K && F)`, return `𝒜 ⊢ (H ⊢SL K)`. Reject a consequent + * Given `𝒜 ⊢ (H ⊢SL (K && F))`, return `𝒜 ⊢ (H ⊢SL K)`. Reject a consequent * that is not an outermost additive conjunction. */ PROOF thm conj1_slrule(const thm ent); @@ -779,12 +1305,12 @@ PROOF thm conj1_slrule(const thm ent); * Project the right additive conjunct from an entailment consequent. * * ```text - * 𝒜 ⊢ (H ⊢SL K && F) + * 𝒜 ⊢ (H ⊢SL (K && F)) * ------------------------- conj2_slrule * 𝒜 ⊢ (H ⊢SL F) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K && F)`, return `𝒜 ⊢ (H ⊢SL F)`. Reject a consequent + * Given `𝒜 ⊢ (H ⊢SL (K && F))`, return `𝒜 ⊢ (H ⊢SL F)`. Reject a consequent * that is not an outermost additive conjunction. */ PROOF thm conj2_slrule(const thm ent); @@ -795,11 +1321,11 @@ PROOF thm conj2_slrule(const thm ent); * ```text * 𝒜 ⊢ (H ⊢SL K) * -------------------------- disj1_slrule F - * 𝒜 ⊢ (H ⊢SL K || F) + * 𝒜 ⊢ (H ⊢SL (K || F)) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K)` and `F:hprop`, return - * `𝒜 ⊢ (H ⊢SL K || F)`. A malformed entailment or non-SL alternative is a + * Given `𝒜 ⊢ (H ⊢SL K)` and `F:sl_prop()`, return + * `𝒜 ⊢ (H ⊢SL (K || F))`. A malformed entailment or non-SL alternative is a * prover error. */ PROOF thm disj1_slrule(const thm ent, const term hp); @@ -810,11 +1336,11 @@ PROOF thm disj1_slrule(const thm ent, const term hp); * ```text * 𝒜 ⊢ (H ⊢SL K) * -------------------------- disj2_slrule F - * 𝒜 ⊢ (H ⊢SL F || K) + * 𝒜 ⊢ (H ⊢SL (F || K)) * ``` * - * Given `𝒜 ⊢ (H ⊢SL K)` and `F:hprop`, return - * `𝒜 ⊢ (H ⊢SL F || K)`. A malformed entailment or non-SL alternative is a + * Given `𝒜 ⊢ (H ⊢SL K)` and `F:sl_prop()`, return + * `𝒜 ⊢ (H ⊢SL (F || K))`. A malformed entailment or non-SL alternative is a * prover error. */ PROOF thm disj2_slrule(const term hp, const thm ent); @@ -840,11 +1366,11 @@ PROOF thm disj_slrule(const thm ent1, const thm ent2); * ```text * 𝒜 ⊢ (H₁ ⊢SL K₁) ℬ ⊢ (H₂ ⊢SL K₂) * ----------------------------------------- disj_mono_slrule - * 𝒜 ∪ ℬ ⊢ (H₁ || H₂ ⊢SL K₁ || K₂) + * 𝒜 ∪ ℬ ⊢ ((H₁ || H₂) ⊢SL (K₁ || K₂)) * ``` * * Given `𝒜 ⊢ (H₁ ⊢SL K₁)` and `ℬ ⊢ (H₂ ⊢SL K₂)`, return - * `𝒜 ∪ ℬ ⊢ (H₁ || H₂ ⊢SL K₁ || K₂)`. Both inputs must conclude SL + * `𝒜 ∪ ℬ ⊢ ((H₁ || H₂) ⊢SL (K₁ || K₂))`. Both inputs must conclude SL * entailments. */ PROOF thm disj_mono_slrule(const thm ent1, const thm ent2); @@ -888,6 +1414,50 @@ PROOF thm choose_slrule(const term v, const term ehp, const thm ent); */ PROOF thm exists_slrule(const term ehp, const term wit, const thm ent); +/** + * Introduce an SL universal in an entailment consequent. + * + * ```text + * 𝒜 ⊢ (H ⊢SL K) + * ------------------------------------------ forall_slrule x + * 𝒜 ⊢ (H ⊢SL (∀SL x. K)) + * ``` + * + * Require `x` to be a variable absent from `H` and every theorem hypothesis. + * The result preserves the exact antecedent and binds the free occurrences of + * `x` in `K`. Existing beta-redexes in caller-owned assertions are retained; + * only the family applications introduced while specializing the installed + * universal-introduction theorem are contracted. + */ +PROOF thm forall_slrule(const term v, const thm ent); + +/** + * Pull an actual left existential through separating conjunction. + * + * For `E = ∃SL x. B`, return the capture-avoiding raw equality + * `∅ ⊢ E ** F = ∃SL y. (B[y/x] ** F)`, where `y = x` when `x` is not free + * in `F` and otherwise `y` is fresh for `F`. The rule specializes the + * installed family law to `E` and beta-contracts only the family application + * introduced in its result. The left endpoint retains the exact supplied `E` + * and `F`; the result binder is renamed only when retaining it would capture + * the frame. Existing beta-redexes inside `B` or `F` are not reduced. + * A non-existential `ehp` or a frame outside the active assertion type is a + * prover error. + */ +PROOF thm sep_exists_left_slrule(const term ehp, const term frame); + +/** + * Pull an actual right existential through separating conjunction. + * + * For `E = ∃SL x. B`, return the capture-avoiding raw equality + * `∅ ⊢ F ** E = ∃SL y. (F ** B[y/x])`, where `y = x` when safe and otherwise + * `y` is fresh for `F`. Beta reduction is confined to the generated family + * application in the specialized primitive instance. The left endpoint + * retains the exact supplied terms; the result binder is renamed only to + * avoid capturing the frame, and existing redexes in `B` or `F` are retained. + */ +PROOF thm sep_exists_right_slrule(const term frame, const term ehp); + /** * Quantify both sides of an entailment over one eigenvariable. * @@ -905,6 +1475,25 @@ PROOF thm exists_slrule(const term ehp, const term wit, const thm ent); */ PROOF thm exists_mono_slrule(const term v, const thm ent); +/** + * Quantify both sides of an entailment over a complete binder prefix. + * + * ```text + * 𝒜 ⊢ (H ⊢SL K) + * ------------------------------------------------ exists_mono_many_slrule V + * 𝒜 ⊢ (Ex(V,H) ⊢SL Ex(V,K)) + * ``` + * + * Given `V = [x₀, …, xₙ₋₁]`, introduce the binders in that exact outer-to- + * inner order. Every `xᵢ` must be a variable absent from the theorem's + * hypotheses. The implementation uses the cached eta-short instance theorem, + * contracts only the two family applications generated at each layer, and + * validates the complete exact endpoint syntax once after the whole prefix is + * installed. Existing beta-redexes in `H` and `K` are retained. For `V = []`, + * validate and return `ent` unchanged. + */ +PROOF thm exists_mono_many_slrule(const term_list vs, const thm ent); + /** * Move every selected antecedent resource into a magic wand. * @@ -976,13 +1565,13 @@ PROOF thm elim_fact_slrule(const term p, const thm ent); * * ```text * ------------------------------------------------- normalize_slrule - * ∅ ⊢ (H ** fact(T) ** emp ** K =ₕ H ** K) + * ∅ ⊢ (H ** fact(T) ** emp ** K = H ** K) * ``` * - * For `H:hprop`, recursively rewrite `fact(T)` to `emp` and + * For `H:sl_prop()`, recursively rewrite `fact(T)` to `emp` and * eliminate `emp` on either side of every `**` reached by that rewrite set. * If the resulting term is `N(H)`, return the closed equality - * `∅ ⊢ (H =ₕ N(H))`. No associativity or commutativity + * `∅ ⊢ (H = N(H))`. No associativity or commutativity * reordering is performed. A non-SL input is a prover error. */ PROOF thm normalize_slrule(const term hp); @@ -993,11 +1582,11 @@ PROOF thm normalize_slrule(const term hp); * ```text * H ≡AC K * ---------------- ac_slrule H K - * ∅ ⊢ (H =ₕ K) + * ∅ ⊢ (H = K) * ``` * * For SL assertions `H` and `K`, when the current HOL AC conversion establishes - * `H ≡AC K`, return the closed equality `∅ ⊢ (H =ₕ K)` with exactly the + * `H ≡AC K`, return the closed equality `∅ ⊢ (H = K)` with exactly the * caller-supplied endpoints. Otherwise report a prover error and return * `empty_theorem`. Units are not ignored. The underlying conversion is * incomplete for some combinations of AC reordering and binder renaming. @@ -1010,11 +1599,11 @@ PROOF thm ac_slrule(const term hp1, const term hp2); * ```text * H ≡ACU K * ------------------ acu_slrule H K - * ∅ ⊢ (H =ₕ K) + * ∅ ⊢ (H = K) * ``` * * For SL assertions `H` and `K`, normalize the units and invoke `ac_slrule`. - * On success, return the closed equality `∅ ⊢ (H =ₕ K)` with exactly the + * On success, return the closed equality `∅ ⊢ (H = K)` with exactly the * caller-supplied endpoints. `emp` and `fact(T)` are the normalized units. * Otherwise report a prover error and return `empty_theorem`; the same * binder-renaming completeness limitation applies. @@ -1027,12 +1616,12 @@ PROOF thm acu_slrule(const term hp1, const term hp2); * ```text * res(L) ⊑ₘ res(H) F = Sep(res(H) ∖ₘ res(L)) * ------------------------------------------------ sep_lift_slrule H L - * ∅ ⊢ (H =ₕ L ** F) + * ∅ ⊢ (H = L ** F) * ``` * * Require `res(lifted_hp) ⊑ₘ res(hp)` and put * `F = Sep(res(hp) ∖ₘ res(lifted_hp))`. Return the closed equality - * `∅ ⊢ (hp =ₕ lifted_hp ** F)`. Each selected occurrence is + * `∅ ⊢ (hp = lifted_hp ** F)`. Each selected occurrence is * consumed once modulo ≡α; unmatched occurrences retain their relative order * in `F`. Both equality endpoints retain the caller's exact syntax. Non-SL * inputs or an unavailable resource occurrence are prover errors. @@ -1135,8 +1724,8 @@ PROOF thm list_trans_slrule(const thm_list ents); * Given `V = [x₀, …, xₙ₋₁]` and `𝒜 ⊢ (H ⊢SL K)`, require every `xᵢ` to be a * variable not free in any hypothesis in `𝒜`. Return * `𝒜 ⊢ (Ex(V, H) ⊢SL Ex(V, K))`. Binder order follows `vs`; for `V = []` the - * input theorem is returned unchanged. A nonvariable binder, a binder that - * occurs free in 𝒜, or a malformed entailment is a prover error. + * input theorem is returned unchanged. This is the compatibility spelling of + * `exists_mono_many_slrule`; it has the same exact-syntax and error contract. */ PROOF thm list_exists_mono_slrule(const term_list vs, const thm ent); diff --git a/proof_symexec.h b/proof_symexec.h index 8632d1a3eda984b31f45a81706414a552824aa14..b6765ec89d4e71c8195a90ef52496567d6ca32f8 100644 --- a/proof_symexec.h +++ b/proof_symexec.h @@ -8,15 +8,17 @@ * equations. These are explicit runtime assumptions in the trusted computing * base, not user-proved or inherited derived lemmas. * - * This header inherits the canonical HOL and SL notation from - * `proof_backward.h`. In particular, Γ is the ordered labeled ordinary - * context and 𝒜 denotes theorem hypotheses. A tactic evolves a goal as - * `G → [G₁, …, Gₙ]`; validation runs in the opposite, bottom-up direction - * from the child theorems to a theorem for G. + * This header inherits the canonical HOL and SL notation from `proof_sl.h` + * and the generic goal representation from `proof_backward.h`. In particular, + * Γ is the ordered labeled ordinary context and 𝒜 denotes theorem hypotheses. A + * tactic evolves a goal as `G → [G₁, …, Gₙ]`; validation runs in the + * opposite, bottom-up direction from the child theorems to a theorem for G. */ #pragma once +#include "proof/proof_sl.h" +#require "proof/proof_sl.c" #include "proof/proof_backward.h" #require "proof/proof_backward.c" @@ -26,11 +28,14 @@ * For `[Γ ?⊢ H ⊢SL K]`, print `H` and `K`, invoke the active backend in * `Tagcancel` scope, parse its result `p`, and create `[Γ ?⊢ p]`. The * validator uses a fresh assumed bridge `p ⇒ (H ⊢SL K)`; it does not derive - * or independently check that bridge. + * or independently check that bridge. Thus a child theorem `𝒜 ⊢ p` validates + * to `𝒜 ⊢ (H ⊢SL K)` by modus ponens; the C `gnode` result is only the child + * node handle. * * Return the Boolean child. Fail for a non-entailment conclusion, backend - * failure, an empty result, or a parse/expansion error. This tactic enlarges - * the trusted computing base whenever it is used. + * failure, an empty result, or a parse/expansion error by reporting a prover + * error and returning `empty_gnode`. This tactic enlarges the trusted computing + * base whenever it is used. */ PROOF gnode PURIFY_TAC(gnode gn); @@ -46,7 +51,14 @@ PROOF gnode PURIFY_TAC(gnode gn); * unsupported SL subterms disappear. * * Return the conversion child, or a solved node when rewriting yields `T`. - * Conversion failures propagate normally. The three private equations are - * explicit trust assumptions, not derived SL rules. + * Conversion failures propagate as a prover error and `empty_gnode`. The three + * private equations are explicit trust assumptions, not derived SL rules. + * + * On the first call, those equations are created once with `new_axiom` using + * the then-active parser and SL operator heads, and their handles are retained + * in process-global static storage. They are not keyed by + * `sl_theory_generation()`. After `POST_PURIFY_TAC` has first been called, the + * process must not install a different SL theory and call it again; doing so + * may leave the retained equations ill-typed or headed by the previous theory. */ PROOF gnode POST_PURIFY_TAC(gnode gn); diff --git a/proof_user.c b/proof_user.c index 78a9a20a9f9761c9eee39a8a32cd239a64fb21b9..5215c96a9ed386157c425b7c4cbd3ca6f5fb534b 100644 --- a/proof_user.c +++ b/proof_user.c @@ -3,7 +3,7 @@ /* Scan the source once while consuming requested occurrences individually. */ PROOF static term_list term_list_subtract_once(const term_list source, const term_list removals, - size_t* unmatched_count) { + size_t *unmatched_count) { term_list unmatched = (term_list)vector_copy(removals); term_list remaining = (term_list)vector_create(); size_t source_size = vector_size(source); @@ -22,23 +22,28 @@ PROOF static term_list term_list_subtract_once(const term_list source, PROOF term_list term_list_subtract(const term_list tms1, const term_list tms2) { size_t unmatched_count = 0; - return term_list_subtract_once(tms1, tms2, &unmatched_count); + term_list result = term_list_subtract_once(tms1, tms2, &unmatched_count); + return result; } PROOF bool term_list_try_subtract(const term_list source, const term_list removals, - term_list* remaining) { + term_list *remaining) { ENSURE_COND(remaining != NULL, "Result slot is null"); size_t unmatched_count = 0; term_list result = term_list_subtract_once(source, removals, &unmatched_count); - if (unmatched_count != 0) return false; + if (unmatched_count != 0) + return false; *remaining = result; return true; err: - ERR_FUN_PUTS("term_list_try_subtract", cstr_term_list(source), - cstr_term_list(removals)); - return false; + { + char *source_text = cstr_term_list(source); + char *removals_text = cstr_term_list(removals); + ERR_FUN_PUTS("term_list_try_subtract", source_text, removals_text); + return false; + } } PROOF term_list term_list_subtract_checked(const term_list source, @@ -50,9 +55,12 @@ PROOF term_list term_list_subtract_checked(const term_list source, "the source terms"); return remaining; err: - ERR_FUN_PUTS("term_list_subtract_checked", cstr_term_list(source), - cstr_term_list(removals)); - return NULL; + { + char *source_text = cstr_term_list(source); + char *removals_text = cstr_term_list(removals); + ERR_FUN_PUTS("term_list_subtract_checked", source_text, removals_text); + return NULL; + } } PROOF bool term_list_is_subset(const term_list tms1, const term_list tms2) { @@ -69,7 +77,8 @@ PROOF bool term_list_is_subset(const term_list tms1, const term_list tms2) { PROOF bool term_list_is_submultiset(const term_list tms1, const term_list tms2) { term_list remaining = NULL; - return term_list_try_subtract(tms2, tms1, &remaining); + bool result = term_list_try_subtract(tms2, tms1, &remaining); + return result; } PROOF int term_list_index(const term_list tms, const term tm) { @@ -94,8 +103,8 @@ PROOF labeled_term_list labeled_term_list_n(const size_t size, ...) { return ltms; } -PROOF labeled_term_list labeled_term_list_subtract(const labeled_term_list ltms1, - const labeled_term_list ltms2) { +PROOF labeled_term_list labeled_term_list_subtract( + const labeled_term_list ltms1, const labeled_term_list ltms2) { labeled_term_list copy = (labeled_term_list)vector_copy(ltms1); size_t sz = vector_size(ltms2); for (size_t i = 0; i < sz; ++i) { @@ -107,7 +116,8 @@ PROOF labeled_term_list labeled_term_list_subtract(const labeled_term_list ltms1 return copy; } -PROOF int labeled_term_list_index(const labeled_term_list ltms, const char* lb) { +PROOF int labeled_term_list_index(const labeled_term_list ltms, + const char *lb) { size_t sz = vector_size(ltms); for (size_t i = 0; i < sz; ++i) { if (ltms[i].lb && strcmp(ltms[i].lb, lb) == 0) { @@ -118,7 +128,7 @@ PROOF int labeled_term_list_index(const labeled_term_list ltms, const char* lb) } PROOF labeled_term_list labeled_term_list_extract(const labeled_term_list ltms, - const char** lbs) { + const char **lbs) { labeled_term_list result = (labeled_term_list)vector_create(); size_t sz = vector_size(lbs); for (size_t i = 0; i < sz; ++i) { @@ -129,9 +139,12 @@ PROOF labeled_term_list labeled_term_list_extract(const labeled_term_list ltms, } return result; err: - ERR_FUN_PUTS("labeled_term_list_extract", cstr_labeled_term_list(ltms), - cstr_string_list(lbs)); - return NULL; + { + char *terms_text = cstr_labeled_term_list(ltms); + char *labels_text = cstr_string_list(lbs); + ERR_FUN_PUTS("labeled_term_list_extract", terms_text, labels_text); + return NULL; + } } PROOF term_list labeled_term_list_to_term_list(const labeled_term_list ltms) { @@ -143,10 +156,10 @@ PROOF term_list labeled_term_list_to_term_list(const labeled_term_list ltms) { return tms; } -PROOF const char* variant_label(const labeled_term_list ltms, const char* prefix) { - const char* requested = prefix == NULL ? "" : prefix; - if (requested[0] != '\0' && - labeled_term_list_index(ltms, requested) == -1) { +PROOF const char *variant_label(const labeled_term_list ltms, + const char *prefix) { + const char *requested = prefix == NULL ? "" : prefix; + if (requested[0] != '\0' && labeled_term_list_index(ltms, requested) == -1) { return GC_STRDUP(requested); } @@ -166,119 +179,209 @@ PROOF const char* variant_label(const labeled_term_list ltms, const char* prefix suffix_start = base_len; } - char* base = (char*)GC_MALLOC(suffix_start + 1); + char *base = (char *)GC_MALLOC(suffix_start + 1); memcpy(base, requested, suffix_start); base[suffix_start] = '\0'; while (true) { - const char* candidate = gc_sprintf("%s_%zu", base, n); - if (labeled_term_list_index(ltms, candidate) == -1) return candidate; + const char *candidate = gc_sprintf("%s_%zu", base, n); + if (labeled_term_list_index(ltms, candidate) == -1) + return candidate; ++n; } } -PROOF char* cstr_term_list(const term_list tms) { - char* buf = GRAY("["); +PROOF char *cstr_term_list(const term_list tms) { + char *buf = GRAY("["); + char *comma = GRAY(","); + char *close = GRAY("]"); bool first = true; size_t sz = vector_size(tms); for (size_t i = 0; i < sz; ++i) { - char* tm_cstr = cstr_term(tms[i]); + char *tm_cstr = cstr_term(tms[i]); if (!first) { - buf = gc_strcat(buf, GRAY(",")); + buf = gc_strcat(buf, comma); buf = gc_strcat(buf, tm_cstr); } else { buf = gc_strcat(buf, tm_cstr); first = false; } } - buf = gc_strcat(buf, GRAY("]")); + buf = gc_strcat(buf, close); return buf; } -PROOF char* cstr_thm_list(const thm_list ths) { - char* buf = GRAY("["); +PROOF char *cstr_thm_list(const thm_list ths) { + char *buf = GRAY("["); + char *comma = GRAY(","); + char *close = GRAY("]"); bool first = true; size_t sz = vector_size(ths); for (size_t i = 0; i < sz; ++i) { - char* th_cstr = cstr_thm(ths[i]); + char *th_cstr = cstr_thm(ths[i]); if (!first) { - buf = gc_strcat(buf, GRAY(",")); + buf = gc_strcat(buf, comma); buf = gc_strcat(buf, th_cstr); } else { buf = gc_strcat(buf, th_cstr); first = false; } } - buf = gc_strcat(buf, GRAY("]")); + buf = gc_strcat(buf, close); return buf; } -PROOF char* cstr_term_pair_list(const term_pair_list tmps) { - char* buf = GRAY("["); +PROOF char *cstr_term_pair_list(const term_pair_list tmps) { + char *buf = GRAY("["); + char *comma = GRAY(","); + char *close = GRAY("]"); bool first = true; size_t sz = vector_size(tmps); for (size_t i = 0; i < sz; ++i) { - char* tmp_cstr = cstr_term_pair(tmps[i]); + char *tmp_cstr = cstr_term_pair(tmps[i]); if (!first) { - buf = gc_strcat(buf, GRAY(",")); + buf = gc_strcat(buf, comma); buf = gc_strcat(buf, tmp_cstr); } else { buf = gc_strcat(buf, tmp_cstr); first = false; } } - buf = gc_strcat(buf, GRAY("]")); + buf = gc_strcat(buf, close); return buf; } -PROOF char* cstr_labeled_term(const labeled_term_list ltm) { - char* buf = GRAY(ltm->lb); - buf = gc_strcat(buf, GRAY(":")); - buf = gc_strcat(buf, cstr_term(ltm->tm)); +PROOF char *cstr_labeled_term(const labeled_term_list ltm) { + char *buf = GRAY(ltm->lb); + char *colon = GRAY(":"); + buf = gc_strcat(buf, colon); + char *term_text = cstr_term(ltm->tm); + buf = gc_strcat(buf, term_text); return buf; } -PROOF char* cstr_labeled_term_list(const labeled_term_list ltms) { - char* buf = GRAY("["); +PROOF char *cstr_labeled_term_list(const labeled_term_list ltms) { + char *buf = GRAY("["); + char *comma = GRAY(","); + char *close = GRAY("]"); bool first = true; size_t sz = vector_size(ltms); for (size_t i = 0; i < sz; ++i) { - char* ltm_cstr = cstr_labeled_term(<ms[i]); + char *ltm_cstr = cstr_labeled_term(<ms[i]); if (!first) { - buf = gc_strcat(buf, GRAY(",")); + buf = gc_strcat(buf, comma); buf = gc_strcat(buf, ltm_cstr); } else { buf = gc_strcat(buf, ltm_cstr); first = false; } } - buf = gc_strcat(buf, GRAY("]")); + buf = gc_strcat(buf, close); return buf; } -PROOF char* cstr_string_list(const char** strs) { - char* buf = GRAY("["); +PROOF char *cstr_string_list(const char **strs) { + char *buf = GRAY("["); + char *comma = GRAY(","); + char *close = GRAY("]"); bool first = true; size_t sz = vector_size(strs); for (size_t i = 0; i < sz; ++i) { - char* str_cstr = cstr_string(strs[i]); + char *str_cstr = cstr_string(strs[i]); if (!first) { - buf = gc_strcat(buf, GRAY(",")); + buf = gc_strcat(buf, comma); buf = gc_strcat(buf, str_cstr); } else { buf = gc_strcat(buf, str_cstr); first = false; } } - buf = gc_strcat(buf, GRAY("]")); + buf = gc_strcat(buf, close); return buf; } -PROOF bool term_is_matched(const term_list local_constants, - const term pattern, const term target) { +PROOF static int type_match_for_icomb(const type pattern, const type target, + type_pair_list *type_substitution) { + ENSURE_COND(type_substitution != NULL, + "type-instantiation output must not be null"); + ENSURE_COND(*type_substitution != NULL, + "type-instantiation vector must not be null"); + + if (is_var_type(pattern)) { + for (size_t i = 0; i < vector_size(*type_substitution); ++i) { + if (equals_type((*type_substitution)[i].snd, pattern)) { + bool repeated_match_is_consistent = + equals_type((*type_substitution)[i].fst, target); + ENSURE_COND(repeated_match_is_consistent, + "inconsistent repeated type-variable match"); + return 0; + } + } + vector_add(type_substitution, ((type_pair){target, pattern})); + return 0; + } + + bool target_is_application = is_app_type(target); + ENSURE_COND(target_is_application, + "type constructor cannot match a type variable"); + dest_app_type_results pattern_app = dest_app_type(pattern); + dest_app_type_results target_app = dest_app_type(target); + int constructor_name_order = strcmp(pattern_app.s, target_app.s); + size_t pattern_arity = vector_size(pattern_app.tys); + size_t target_arity = vector_size(target_app.tys); + bool constructors_match = + constructor_name_order == 0 && pattern_arity == target_arity; + ENSURE_COND(constructors_match, + "type constructors do not match"); + for (size_t i = 0; i < vector_size(pattern_app.tys); ++i) { + type_match_for_icomb(pattern_app.tys[i], target_app.tys[i], + type_substitution); + } + return 0; +err: + { + ERR_FUN_PUTS("type_match_for_icomb"); + return -1; + } +} + +PROOF term mk_icomb(const term f, const term x) { + bool f_is_empty = IS_NULL(f); + bool x_is_empty = IS_NULL(x); + ENSURE_COND(!f_is_empty && !x_is_empty, + "combination terms must not be empty"); + type f_type = type_of(f); + bool f_is_function = is_fun_type(f_type); + ENSURE_COND(f_is_function, "combination rator is not a function"); + dest_app_type_results function_app = dest_app_type(f_type); + int function_name_order = strcmp(function_app.s, "fun"); + size_t function_arity = vector_size(function_app.tys); + bool function_shape_is_valid = + function_name_order == 0 && function_arity == 2; + ENSURE_COND(function_shape_is_valid, + "combination rator has a malformed function type"); + + type_pair_list type_substitution = (type_pair_list)vector_create(); + type x_type = type_of(x); + type_match_for_icomb(function_app.tys[0], x_type, &type_substitution); + term specialized = tyvar_inst(type_substitution, f); + term result = mk_comb(specialized, x); + return result; +err: + { + char *function_text = cstr_term(f); + char *argument_text = cstr_term(x); + ERR_FUN_PUTS("mk_icomb", function_text, argument_text); + return empty_term; + } +} + +PROOF bool term_is_matched(const term_list local_constants, const term pattern, + const term target) { proof_try_begin(); term_match((term_list)local_constants, pattern, target); bool failed = NOT_OK; - if (failed) SET_OK(); + if (failed) + SET_OK(); proof_try_end(); return !failed; } @@ -288,8 +391,13 @@ PROOF term subst_one(term tm1, term tm2, term tm) { term ret = subst(pairs, tm); return ret; err: - ERR_FUN_PUTS("subst_one", cstr_term(tm1), cstr_term(tm2), cstr_term(tm)); - return empty_term; + { + char *replacement_text = cstr_term(tm1); + char *variable_text = cstr_term(tm2); + char *body_text = cstr_term(tm); + ERR_FUN_PUTS("subst_one", replacement_text, variable_text, body_text); + return empty_term; + } } PROOF thm list_trans_rule(const thm_list ths) { @@ -301,8 +409,11 @@ PROOF thm list_trans_rule(const thm_list ths) { } return res_th; err: - ERR_FUN_PUTS("list_trans_rule", cstr_thm_list(ths)); - return empty_theorem; + { + char *theorems_text = cstr_thm_list(ths); + ERR_FUN_PUTS("list_trans_rule", theorems_text); + return empty_theorem; + } } PROOF thm list_match_mp_rule(const thm th, const thm_list ths) { @@ -316,8 +427,12 @@ PROOF thm list_match_mp_rule(const thm th, const thm_list ths) { PROOF thm undisch_all_rule(const thm th) { thm res_th = th; - while (is_imp(concl(res_th))) { + term res_conclusion = concl(res_th); + bool res_is_implication = is_imp(res_conclusion); + while (res_is_implication) { res_th = undisch_rule(res_th); + res_conclusion = concl(res_th); + res_is_implication = is_imp(res_conclusion); } return res_th; } @@ -331,8 +446,12 @@ PROOF thm list_mk_binop_rule(term op, const thm_list eqs) { } return res_th; err: - ERR_FUN_PUTS("list_mk_binop_rule", cstr_term(op), cstr_thm_list(eqs)); - return empty_theorem; + { + char *operator_text = cstr_term(op); + char *equations_text = cstr_thm_list(eqs); + ERR_FUN_PUTS("list_mk_binop_rule", operator_text, equations_text); + return empty_theorem; + } } PROOF static thm get_not_elim_thm() { @@ -346,7 +465,8 @@ PROOF static thm get_not_elim_thm() { } PROOF thm not_elim_rule(const thm not_p, const thm p) { - thm eliminate = match_mp_rule(get_not_elim_thm(), not_p); + thm not_elim = get_not_elim_thm(); + thm eliminate = match_mp_rule(not_elim, not_p); thm result = match_mp_rule(eliminate, p); return result; } @@ -367,8 +487,12 @@ PROOF thm false_elim_rule(const thm fth, const term ccl) { thm res_th = match_mp_rule(mid_th, fth); return res_th; err: - ERR_FUN_PUTS("false_elim_rule", cstr_thm(fth), cstr_term(ccl)); - return empty_theorem; + { + char *false_theorem_text = cstr_thm(fth); + char *conclusion_text = cstr_term(ccl); + ERR_FUN_PUTS("false_elim_rule", false_theorem_text, conclusion_text); + return empty_theorem; + } } PROOF thm mk_binop_rule(term op, thm eq1, thm eq2) { diff --git a/proof_user.h b/proof_user.h index bf6ff94f865cc31d0554c853549e7c0e80a2b414..7721a7c329be766274cd225de58730066d5e63b9 100644 --- a/proof_user.h +++ b/proof_user.h @@ -4,8 +4,14 @@ * This header provides vector operations, term utilities, printers, and * derived HOL rules built on the proof kernel. * - * This header inherits the canonical notation from `proof_kernel.h` and adds - * occurrence-sensitive relations for vector operations. + * This header inherits the canonical typing notation `t:τ` and theorem + * judgment `𝒜 ⊢ φ` from `proof_kernel.h` and adds occurrence-sensitive relations for vector + * operations. As there, a C `thm` result is an opaque theorem handle; the HOL + * conclusion and hypotheses are stated separately in each rule's contract. + * Fresh vectors and rendered strings inherit the prover/GC lifetime rules of + * `proof_kernel.h`. Unless stated otherwise, a reported prover error makes a + * returned HOL handle/record unusable (the C boundary uses its documented empty + * sentinel); it does not establish the negation of the requested theorem. * * - For an element equivalence ≈, μ≈(X, a) counts occurrences in X * equivalent to a. Then X ⊑ₘ[≈] Y means μ≈(X, a) ≤ μ≈(Y, a) for every a. @@ -19,10 +25,21 @@ #pragma once +#include "proof/syntax/base.h" +#require "proof/syntax/base.c" + #include "proof/proof_kernel.h" +/** Vector length/index type used by the runtime vector API. */ PROOF typedef size_t vec_size_t; +/** + * Construct a fresh `labeled_term_list` container from record values. + * + * The macro computes arity from its arguments and delegates to + * `labeled_term_list_n`; term handles and label pointers are shared. Arguments + * must have type `labeled_term` and are evaluated once by the generated call. + */ #define LABELED_TERM_LIST(...) \ labeled_term_list_n(sizeof((labeled_term[]){__VA_ARGS__}) / sizeof(labeled_term), ##__VA_ARGS__) @@ -31,13 +48,22 @@ PROOF typedef size_t vec_size_t; /** * Pair a HOL term with an optional user-facing label. * - * `lb` may be `NULL` for an intentionally unlabeled record. APIs that select - * records by label state their stronger non-null requirements separately. + * `lb` may be `NULL` for an intentionally unlabeled record. It is a borrowed + * pointer and must remain valid for every API that consumes the record. APIs + * that select or print records by label state stronger non-null requirements. */ PROOF typedef struct labeled_term { + /** Shared, prover-managed HOL term handle. */ term tm; /* The term. */ + /** Borrowed label string, or `NULL` when intentionally unlabeled. */ const char* lb; /* The label. */ } labeled_term; +/** + * Mutable vector-backed sequence of record values. + * + * Resizing may relocate the container; term handles and label pointers remain + * shallow shared values and are never freed with the vector. + */ PROOF typedef labeled_term* labeled_term_list; /*------------------------- Vector constructors -------------------------*/ @@ -49,7 +75,8 @@ PROOF typedef labeled_term* labeled_term_list; * `r[0], ..., r[n-1]`, returns a fresh vector `R` with `|R| = n` and * `R[i] = r[i]` for `0 <= i < n`. Term handles and label pointers are copied * into the vector without copying their targets. The result is empty for - * `n = 0`. + * `n = 0`. The fresh container is GC-managed and non-null on success; supplied + * label strings must outlive all uses of it. * * The call must supply exactly `size` arguments of type `labeled_term`; * violating this C ABI precondition is undefined behavior. @@ -169,8 +196,11 @@ PROOF int labeled_term_list_index(const labeled_term_list ltms, const char* lb); * `[(x,"H"),(y,"K"),(z,"H")]` returns * `[(y,"K"),(x,"H"),(y,"K")]`. * - * Every entry of `lbs` must be a valid non-null C string. A missing label - * reports a prover error and returns `NULL`. + * Every entry of `lbs` and every label in the source `ltms` must be a valid + * non-null C string. The source-wide requirement is needed because the + * missing-label diagnostic renders the complete source with + * `cstr_labeled_term_list`. A missing requested label reports a prover error + * and returns `NULL` when these preconditions hold. */ PROOF labeled_term_list labeled_term_list_extract(const labeled_term_list ltms, const_cstr_list lbs); @@ -194,7 +224,7 @@ PROOF term_list labeled_term_list_to_term_list(const labeled_term_list ltms); * * With existing labels `"H"`, `"H_0"`, and `"H_2"`, prefix `"H"` produces * `"H_1"`, while an unused prefix `"K"` is returned unchanged. A null or - * empty prefix starts with `"_0"`. + * empty prefix starts with `"_0"`. The returned copy is GC-managed. */ PROOF const char* variant_label(const labeled_term_list ltms, const char* prefix); @@ -231,18 +261,18 @@ PROOF char* cstr_thm_list(const thm_list ths); * index order, enclosed in gray brackets and separated by gray commas without * spaces. * - * A visibly rendered pair `(x,y)` becomes `[(x,y)]` in a singleton vector. + * A visibly rendered pair `(x, y)` becomes `[(x, y)]` in a singleton vector. */ PROOF char* cstr_term_pair_list(const term_pair_list tmps); /** - * Render one labeled-term record, omitting a null label. - * - * For the record `r` pointed to by `ltm`, returns gray `r.lb`, gray `":"`, - * and `cstr_term(r.tm)` when the label is non-null; otherwise returns only - * `cstr_term(r.tm)`. + * Render one labeled-term record as `label:term`. * - * Thus `(x,"H")` visibly renders as `H:x`, while `(x,NULL)` renders as `x`. + * For the record `r` pointed to by `ltm`, return gray `r.lb`, gray `":"`, + * and `cstr_term(r.tm)`. Both `ltm` and `r.tm` must be valid, and `r.lb` must + * be a valid non-null C string; the current implementation unconditionally + * renders the label and colon. The returned string is GC-managed. + * Thus `(x,"H")` visibly renders as `H:x`. */ PROOF char* cstr_labeled_term(const labeled_term_list ltm); @@ -253,8 +283,9 @@ PROOF char* cstr_labeled_term(const labeled_term_list ltm); * `cstr_labeled_term(<ms[i])` in index order, enclosed in gray brackets and * separated by gray commas without spaces. * - * Ignoring color escapes, `[(x,"H"),(y,NULL)]` renders as `[H:x,y]` and an - * empty vector as `[]`. + * Every record must have a valid term and a non-null valid label. Ignoring + * color escapes, `[(x,"H"),(y,"K")]` renders as `[H:x,K:y]` and an empty + * vector as `[]`. The returned string is GC-managed. */ PROOF char* cstr_labeled_term_list(const labeled_term_list ltms); @@ -272,6 +303,18 @@ PROOF char* cstr_string_list(const_cstr_list strs); /*-------------------- Term Structure Analysis --------------------*/ +/** + * Make a HOL function application with rator type instantiation. + * + * This is the user-side analogue of HOL Light's `mk_icomb(f,x)`. Match the + * domain of `type_of(f)` against `type_of(x)`, instantiate only the type + * variables of `f`, and then return the kernel-checked `mk_comb(f',x)`. + * Repeated occurrences of a domain type variable must match the same concrete + * type. Report a prover error and return `empty_term` if `f` is not a function + * or its domain cannot be instantiated compatibly. + */ +PROOF term mk_icomb(const term f, const term x); + /** * Test whether HOL Light's term matcher accepts a pattern and target. * @@ -290,6 +333,9 @@ PROOF char* cstr_string_list(const_cstr_list strs); * with `z`. * * Callers cannot distinguish an ordinary mismatch from another matcher error. + * This wrapper uses the runtime's single global proof-try slot; the incoming + * prover status must be OK and no outer proof-try scope may be active. Nested + * use would overwrite the outer try state rather than form a safe nested catch. */ PROOF bool term_is_matched(const term_list local_constants, const term pattern, const term target); @@ -338,8 +384,8 @@ PROOF thm list_trans_rule(const thm_list ths); * theorem exactly as `match_mp_rule` does. An empty `ths` vector returns * `th` unchanged; any failed step propagates the underlying prover error. * - * For example, from `𝒜 ⊢ ∀x. P(x) ⇒ Q(x)` and `ℬ ⊢ P(a)`, one application - * returns `𝒜 ∪ ℬ ⊢ Q(a)`. + * For example, from `𝒜₁ ⊢ ∀x. P(x) ⇒ Q(x)` and `𝒜₂ ⊢ P(a)`, one application + * returns `𝒜₁ ∪ 𝒜₂ ⊢ Q(a)`. */ PROOF thm list_match_mp_rule(const thm th, const thm_list ths); @@ -384,9 +430,9 @@ PROOF thm list_mk_binop_rule(term op, const thm_list eqs); * Derive false from proofs of a proposition and its negation. * * ```text - * 𝒜 ⊢ ¬p ℬ ⊢ p + * 𝒜₁ ⊢ ¬p 𝒜₂ ⊢ p * ---------------- - * 𝒜∪ℬ ⊢ ⊥ + * 𝒜₁∪𝒜₂ ⊢ ⊥ * ``` * The conclusions must use the same proposition modulo the matching accepted * by the underlying specialization and modus-ponens rules; otherwise the diff --git a/syntax/base.c b/syntax/base.c new file mode 100644 index 0000000000000000000000000000000000000000..43ddc682aef660111f39ce9508d401def5fdb673 --- /dev/null +++ b/syntax/base.c @@ -0,0 +1,137 @@ +#include "proof/syntax/base.h" + +PROOF static bool proof_base_syntax_installed = false; + +PROOF int proof_install_base_syntax(void) { + if (proof_base_syntax_installed) return 0; + + type A = mk_var_type("A"); + type B = mk_var_type("B"); + type bool_type = mk_bool_type(); + type int_type = mk_int_type(); + type real_type = mk_real_type(); + type list_A = mk_list_type(A); + type A_to_A = mk_fun_type(A, A); + type binary_A = mk_fun_type(A, A_to_A); + type bool_to_bool = mk_fun_type(bool_type, bool_type); + type binary_bool = mk_fun_type(bool_type, bool_to_bool); + + /* Fixities are declared explicitly so this module does not depend on the + * order or presence of an OCaml bootstrap file. */ + parse_as_infix("/", 22, "left"); + parse_as_infix("%", 22, "left"); + parse_as_infix("::", 25, "right"); + parse_as_infix("++", 16, "right"); + parse_as_infix("==", 10, "right"); + parse_as_infix("<=>", 2, "right"); + parse_as_infix("||", 6, "right"); + parse_as_infix("&&", 8, "right"); + + /* Arithmetic and list notation. */ + make_overloadable("/", binary_A); + type real_to_real = mk_fun_type(real_type, real_type); + type binary_real = mk_fun_type(real_type, real_to_real); + term real_div = mk_const("real_div", binary_real); + overload_interface("/", real_div); + type int_to_int = mk_fun_type(int_type, int_type); + type binary_int = mk_fun_type(int_type, int_to_int); + + /* Re-establish HOL Light's `prioritize_int()` policy using only public + * parser-interface operations. The former OCaml bootstrap performed this + * mutation globally; without it an unconstrained `&n`, `+`, or comparison + * can silently be invented at type `real`. */ + type int_predicate = mk_fun_type(int_type, bool_type); + type binary_int_predicate = mk_fun_type(int_type, int_predicate); + type num_type = mk_nat_type(); + type num_to_int = mk_fun_type(num_type, int_type); + type int_pow_type = mk_fun_type(int_type, num_to_int); + term int_add = mk_const("int_add", binary_int); + term int_sub = mk_const("int_sub", binary_int); + term int_mul = mk_const("int_mul", binary_int); + term int_lt = mk_const("int_lt", binary_int_predicate); + term int_le = mk_const("int_le", binary_int_predicate); + term int_gt = mk_const("int_gt", binary_int_predicate); + term int_ge = mk_const("int_ge", binary_int_predicate); + term int_neg = mk_const("int_neg", int_to_int); + term int_pow = mk_const("int_pow", int_pow_type); + term int_abs = mk_const("int_abs", int_to_int); + term int_max = mk_const("int_max", binary_int); + term int_min = mk_const("int_min", binary_int); + term int_of_num = mk_const("int_of_num", num_to_int); + overload_interface("+", int_add); + overload_interface("-", int_sub); + overload_interface("*", int_mul); + overload_interface("<", int_lt); + overload_interface("<=", int_le); + overload_interface(">", int_gt); + overload_interface(">=", int_ge); + overload_interface("--", int_neg); + overload_interface("pow", int_pow); + overload_interface("abs", int_abs); + overload_interface("max", int_max); + overload_interface("min", int_min); + overload_interface("&", int_of_num); + + term int_div = mk_const("div", binary_int); + overload_interface("/", int_div); + term int_rem = mk_const("rem", binary_int); + override_interface("%", int_rem); + type list_to_list = mk_fun_type(list_A, list_A); + type cons_type = mk_fun_type(A, list_to_list); + term cons = mk_const("CONS", cons_type); + override_interface("::", cons); + type append_type = mk_fun_type(list_A, list_to_list); + term append = mk_const("APPEND", append_type); + override_interface("++", append); + + /* `==` retains the standard congruence interpretation while adding plain + * equality as the preferred boolean-result instance. */ + type A_to_B = mk_fun_type(A, B); + type equality_skeleton = mk_fun_type(A, A_to_B); + make_overloadable("==", equality_skeleton); + type A_to_bool = mk_fun_type(A, bool_type); + type equality_type = mk_fun_type(A, A_to_bool); + type equality_predicate_to_bool = mk_fun_type(equality_type, bool_type); + type A_to_equality_predicate_to_bool = + mk_fun_type(A, equality_predicate_to_bool); + type congruence_type = mk_fun_type(A, A_to_equality_predicate_to_bool); + term congruence = mk_const("==", congruence_type); + overload_interface("==", congruence); + term equality = mk_const("=", equality_type); + overload_interface("==", equality); + term boolean_equality = mk_const("=", binary_bool); + override_interface("<=>", boolean_equality); + + /* Boolean spellings remain overloadable so a selected resource assertion + * model can add its own conjunction, disjunction, and existential heads. */ + make_overloadable("&&", binary_A); + term conjunction = mk_const("/\\", binary_bool); + overload_interface("&&", conjunction); + make_overloadable("||", binary_A); + term disjunction = mk_const("\\/", binary_bool); + overload_interface("||", disjunction); + + make_overloadable("true", A); + term truth = mk_const("T", bool_type); + overload_interface("true", truth); + make_overloadable("false", A); + term falsehood = mk_const("F", bool_type); + overload_interface("false", falsehood); + + type binder_skeleton = mk_fun_type(A_to_B, B); + type bool_binder = mk_fun_type(A_to_bool, bool_type); + make_overloadable("forall", binder_skeleton); + term universal = mk_const("!", bool_binder); + overload_interface("forall", universal); + make_overloadable("exists", binder_skeleton); + term existential = mk_const("?", bool_binder); + overload_interface("exists", existential); + + proof_base_syntax_installed = true; + return 0; +err: + ERR_FUN_PUTS("proof_install_base_syntax"); + return -1; +} + +PROOF static int _PROOF_BASE_SYNTAX_INSTALLED = proof_install_base_syntax(); diff --git a/syntax/base.h b/syntax/base.h new file mode 100644 index 0000000000000000000000000000000000000000..ab9fd255923ca49285b01d9bfa13a1680bf82df8 --- /dev/null +++ b/syntax/base.h @@ -0,0 +1,32 @@ +/** + * @file base.h + * @brief Model-independent C* proof syntax. + * + * This module installs only parser/interface declarations that are shared by + * ordinary HOL and every resource model. Separation-logic notation is + * selected separately after a concrete resource algebra has been chosen. + * The operation is idempotent against the standard HOL Light baseline and + * against repeated inclusion by proof files. + */ + +#pragma once + +#include "proof/proof_kernel.h" + +/** + * Install the neutral C* proof dialect. + * + * The dialect gives overloaded arithmetic the same integer priority as HOL + * `prioritize_int()` and includes the former OCaml bootstrap's conveniences + * (`/`, `%`, `::`, `++`). It also provides the C* spelling `==` for HOL + * equality and `<=>` for Boolean equivalence, and the overloadable Boolean + * spellings `&&`, `||`, `true`, `false`, `forall`, and `exists`. Return zero + * on success and `-1` after setting prover error state. Installation changes + * global parser/fixity metadata incrementally. A process-local completion flag + * makes repeated installation through one dependency graph a no-op; a fresh + * verification process reinstalls the metadata after the server restores its + * checkpoint. No logical constant is introduced merely to record runtime + * state. A failure may leave a partially installed dialect and is + * proof-initialization fail-stop for the current session. + */ +PROOF int proof_install_base_syntax(void); diff --git a/test/auth_ra_regression.c b/test/auth_ra_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..3756ff3169c73c6ba08db540d22c336824e1ff24 --- /dev/null +++ b/test/auth_ra_regression.c @@ -0,0 +1,200 @@ +#include "proof/theory/logic/auth_ra.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/auth_ra.c" + +/* Exact public-v2 update signatures for auth_ra. */ +PROOF static void check_auth_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_auth_theorem", label); +} + +PROOF static thm ra_at_num_excl(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:(num)excl`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("ra_at_num_excl"); + return empty_theorem; +} + +PROOF static int audit_auth_ra_v2_regressions(void) { + term R = `excl_ra:((num)excl)ra`; + term a = `a:(num)excl`; + term f = `f:(num)excl`; + term b = `b:(num)excl`; + term g = `g:(num)excl`; + term residual = `residual:(num)excl`; + term piece = `piece:(num)excl`; + + /* Local updates are a five-argument relation; the residual is quantified + * by the definition rather than bundled into source/target pairs. */ + check_auth_theorem( + ra_at_num_excl(ra_local_update_def), + `ra_local_update + (R:((num)excl)ra) + (a:(num)excl) + (f:(num)excl) + (b:(num)excl) + (g:(num)excl) <=> + forall hidden:(num)excl. + ra_valid R a ==> + a == ra_op R f hidden ==> + ra_valid R b && + b == ra_op R g hidden`, + "ra_local_update_def"); + + check_auth_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g, residual), + ra_local_update_apply), + `ra_local_update + (excl_ra:((num)excl)ra) + (a:(num)excl) + (f:(num)excl) + (b:(num)excl) + (g:(num)excl) ==> + ra_valid (excl_ra:((num)excl)ra) a ==> + a == + ra_op + (excl_ra:((num)excl)ra) + f + (residual:(num)excl) ==> + ra_valid (excl_ra:((num)excl)ra) b && + b == ra_op (excl_ra:((num)excl)ra) g residual`, + "ra_local_update_apply"); + + check_auth_theorem( + ispec_rule(R, auth_ra_cancellative_iff), + `ra_cancellative + (auth_ra (excl_ra:((num)excl)ra)) <=> + ra_cancellative (excl_ra:((num)excl)ra)`, + "auth_ra_cancellative_iff"); + + check_auth_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g), + auth_ra_update_framewise_iff), + `ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (auth_both (b:(num)excl) (g:(num)excl)) <=> + forall external:(num)excl. + ra_valid (excl_ra:((num)excl)ra) a && + ra_included + (excl_ra:((num)excl)ra) + (ra_op (excl_ra:((num)excl)ra) f external) + a ==> + ra_valid (excl_ra:((num)excl)ra) b && + ra_included + (excl_ra:((num)excl)ra) + (ra_op (excl_ra:((num)excl)ra) g external) + b`, + "auth_ra_update_framewise_iff"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, f, b, g), auth_ra_update_local), + `ra_local_update + (excl_ra:((num)excl)ra) + (a:(num)excl) + (f:(num)excl) + (b:(num)excl) + (g:(num)excl) ==> + ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both a f) + (auth_both b g)`, + "auth_ra_update_local"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, b), auth_ra_update_auth_iff), + `ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) + (auth_auth (excl_ra:((num)excl)ra) (b:(num)excl)) <=> + (ra_valid (excl_ra:((num)excl)ra) a ==> + ra_valid (excl_ra:((num)excl)ra) b && + ra_included (excl_ra:((num)excl)ra) a b)`, + "auth_ra_update_auth_iff"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, b, g), auth_ra_update_alloc), + `ra_local_update + (excl_ra:((num)excl)ra) + (a:(num)excl) + (ra_unit (excl_ra:((num)excl)ra)) + (b:(num)excl) + (g:(num)excl) ==> + ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) a) + (auth_both b g)`, + "auth_ra_update_alloc"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, f), auth_ra_update_drop_local), + `ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (auth_auth (excl_ra:((num)excl)ra) a)`, + "auth_ra_update_drop_local"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, f), auth_ra_update_drop_auth), + `ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (auth_frag f)`, + "auth_ra_update_drop_auth"); + + check_auth_theorem( + ispecl_rule( + TERM_LIST(R, a, f, g), + auth_ra_update_weaken_frag), + `ra_included + (excl_ra:((num)excl)ra) + (g:(num)excl) + (f:(num)excl) ==> + ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) f) + (auth_both a g)`, + "auth_ra_update_weaken_frag"); + + check_auth_theorem( + ispecl_rule(TERM_LIST(R, a, piece), auth_ra_alloc), + `ra_valid + (excl_ra:((num)excl)ra) + (ra_op + (excl_ra:((num)excl)ra) + (a:(num)excl) + (piece:(num)excl)) ==> + ra_update + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) a) + (auth_both + (ra_op (excl_ra:((num)excl)ra) a piece) + piece)`, + "auth_ra_alloc"); + + return 0; +err: + ERR_FUN_PUTS("audit_auth_ra_v2_regressions"); + return -1; +} + +PROOF static int _AUTH_RA_V2_REGRESSION = + audit_auth_ra_v2_regressions(); diff --git a/test/auth_ra_structure_regression.c b/test/auth_ra_structure_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..4131b67be779a473b6aef6eef39c82cbbeb342fa --- /dev/null +++ b/test/auth_ra_structure_regression.c @@ -0,0 +1,179 @@ +#include "proof/theory/logic/auth_ra.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/auth_ra.c" + +/* Constructor-level checks intentionally stop at the v2 auth_ra.h boundary. */ +PROOF static void check_auth_structure_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_auth_structure_theorem", label); +} + +PROOF static int audit_auth_ra_structure_v2(void) { + term R = `excl_ra:((num)excl)ra`; + term a = `a:(num)excl`; + term f = `f:(num)excl`; + term b = `b:(num)excl`; + term g = `g:(num)excl`; + term frame = `frame:((num)excl)excl#(num)excl`; + + check_auth_structure_theorem( + ispec_rule(R, auth_ra_unit), + `ra_unit (auth_ra (excl_ra:((num)excl)ra)) == + auth_frag (ra_unit (excl_ra:((num)excl)ra))`, + "auth_ra_unit"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, a, f), auth_ra_auth_frag), + `ra_op + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) + (auth_frag (f:(num)excl)) == + auth_both a f`, + "auth_ra_auth_frag"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, f, g), auth_ra_frag_frag), + `ra_op + (auth_ra (excl_ra:((num)excl)ra)) + (auth_frag (f:(num)excl)) + (auth_frag (g:(num)excl)) == + auth_frag + (ra_op (excl_ra:((num)excl)ra) f g)`, + "auth_ra_frag_frag"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, a, f, g), auth_ra_both_frag), + `ra_op + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (auth_frag (g:(num)excl)) == + auth_both + a + (ra_op (excl_ra:((num)excl)ra) f g)`, + "auth_ra_both_frag"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, f), auth_ra_valid_frag), + `ra_valid + (auth_ra (excl_ra:((num)excl)ra)) + (auth_frag (f:(num)excl)) <=> + ra_valid (excl_ra:((num)excl)ra) f`, + "auth_ra_valid_frag"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, a, f), auth_ra_valid_both), + `ra_valid + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) <=> + ra_valid (excl_ra:((num)excl)ra) a && + ra_included (excl_ra:((num)excl)ra) f a`, + "auth_ra_valid_both"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, a), auth_ra_valid_auth), + `ra_valid + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) <=> + ra_valid (excl_ra:((num)excl)ra) a`, + "auth_ra_valid_auth"); + + check_auth_structure_theorem( + ispecl_rule( + TERM_LIST(R, a, f, frame), + auth_ra_valid_both_frame), + `ra_valid + (auth_ra (excl_ra:((num)excl)ra)) + (ra_op + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (frame:((num)excl)excl#(num)excl)) <=> + exists external:(num)excl. + frame == auth_frag external && + ra_valid (excl_ra:((num)excl)ra) a && + ra_included + (excl_ra:((num)excl)ra) + (ra_op (excl_ra:((num)excl)ra) f external) + a`, + "auth_ra_valid_both_frame"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, a, b), auth_ra_auth_conflict), + `~(ra_compatible + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) + (auth_auth (excl_ra:((num)excl)ra) (b:(num)excl)))`, + "auth_ra_auth_conflict"); + + check_auth_structure_theorem( + ispecl_rule(TERM_LIST(R, f, g), auth_ra_included_frag_frag), + `ra_included + (auth_ra (excl_ra:((num)excl)ra)) + (auth_frag (f:(num)excl)) + (auth_frag (g:(num)excl)) <=> + ra_included (excl_ra:((num)excl)ra) f g`, + "auth_ra_included_frag_frag"); + + check_auth_structure_theorem( + ispecl_rule( + TERM_LIST(R, f, a, g), + auth_ra_included_frag_both), + `ra_included + (auth_ra (excl_ra:((num)excl)ra)) + (auth_frag (f:(num)excl)) + (auth_both (a:(num)excl) (g:(num)excl)) <=> + ra_included (excl_ra:((num)excl)ra) f g`, + "auth_ra_included_frag_both"); + + check_auth_structure_theorem( + ispecl_rule( + TERM_LIST(R, a, b), + auth_ra_included_auth_auth), + `ra_included + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) + (auth_auth (excl_ra:((num)excl)ra) (b:(num)excl)) <=> + a == b`, + "auth_ra_included_auth_auth"); + + check_auth_structure_theorem( + ispecl_rule( + TERM_LIST(R, a, b, g), + auth_ra_included_auth_both), + `ra_included + (auth_ra (excl_ra:((num)excl)ra)) + (auth_auth (excl_ra:((num)excl)ra) (a:(num)excl)) + (auth_both (b:(num)excl) (g:(num)excl)) <=> + a == b`, + "auth_ra_included_auth_both"); + + check_auth_structure_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g), + auth_ra_included_both_both), + `ra_included + (auth_ra (excl_ra:((num)excl)ra)) + (auth_both (a:(num)excl) (f:(num)excl)) + (auth_both (b:(num)excl) (g:(num)excl)) <=> + a == b && + ra_included (excl_ra:((num)excl)ra) f g`, + "auth_ra_included_both_both"); + + return 0; +err: + ERR_FUN_PUTS("audit_auth_ra_structure_v2"); + return -1; +} + +PROOF static int _AUTH_RA_STRUCTURE_V2_REGRESSION = + audit_auth_ra_structure_v2(); diff --git a/test/basic_ra_constructors_regression.c b/test/basic_ra_constructors_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..690a42f5aa6f45d405e2d4623339e1e386843579 --- /dev/null +++ b/test/basic_ra_constructors_regression.c @@ -0,0 +1,312 @@ +#include "proof/theory/logic/excl_ra.h" +#include "proof/theory/logic/prod_ra.h" +#include "proof/theory/logic/unit_ra.h" + +#require "proof/theory/logic/excl_ra.c" +#require "proof/theory/logic/prod_ra.c" +#require "proof/theory/logic/unit_ra.c" + +PROOF static void check_basic_ra_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_basic_ra_theorem", label); +} + +PROOF static thm basic_ra_at_num(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("basic_ra_at_num"); + return empty_theorem; +} + +PROOF static int audit_unit_ra_regressions(void) { + check_basic_ra_theorem( + unit_ra_unit, + `ra_unit unit_ra == (one:1)`, + "unit_ra_unit"); + check_basic_ra_theorem( + unit_ra_op, + `forall a b:1. ra_op unit_ra a b == one`, + "unit_ra_op"); + check_basic_ra_theorem( + unit_ra_valid, + `forall a:1. ra_valid unit_ra a`, + "unit_ra_valid"); + check_basic_ra_theorem( + unit_ra_included, + `forall a b:1. ra_included unit_ra a b`, + "unit_ra_included"); + check_basic_ra_theorem( + unit_ra_maximal, + `forall a:1. ra_maximal unit_ra a`, + "unit_ra_maximal"); + check_basic_ra_theorem( + unit_ra_updateP_iff, + `forall (a:1) (P:1->bool). + ra_updateP unit_ra a P <=> P one`, + "unit_ra_updateP_iff"); + check_basic_ra_theorem( + unit_ra_local_update, + `forall a f b g:1. ra_local_update unit_ra a f b g`, + "unit_ra_local_update"); + return 0; +err: + ERR_FUN_PUTS("audit_unit_ra_regressions"); + return -1; +} + +PROOF static int audit_excl_ra_regressions(void) { + term a = `a:num`; + term b = `b:num`; + term x = `x:(num)excl`; + + check_basic_ra_theorem( + basic_ra_at_num(excl_ra_unit), + `ra_unit (excl_ra:((num)excl)ra) == ExclUnit`, + "excl_ra_unit"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(a, b), excl_ra_owned_conflict), + `ra_op + (excl_ra:((num)excl)ra) + (Excl (a:num)) + (Excl (b:num)) == + ExclInvalid`, + "excl_ra_owned_conflict"); + check_basic_ra_theorem( + basic_ra_at_num(excl_ra_valid_unit), + `ra_valid (excl_ra:((num)excl)ra) ExclUnit`, + "excl_ra_valid_unit"); + check_basic_ra_theorem( + ispec_rule(a, excl_ra_valid_owned), + `ra_valid (excl_ra:((num)excl)ra) (Excl (a:num))`, + "excl_ra_valid_owned"); + check_basic_ra_theorem( + basic_ra_at_num(excl_ra_invalid), + `~(ra_valid (excl_ra:((num)excl)ra) ExclInvalid)`, + "excl_ra_invalid"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(a, b), excl_ra_included_owned), + `ra_included + (excl_ra:((num)excl)ra) + (Excl (a:num)) + (Excl (b:num)) <=> + a == b`, + "excl_ra_included_owned"); + check_basic_ra_theorem( + ispec_rule(a, excl_ra_maximal), + `ra_maximal (excl_ra:((num)excl)ra) (Excl (a:num))`, + "excl_ra_maximal"); + check_basic_ra_theorem( + basic_ra_at_num(excl_ra_cancellative), + `ra_cancellative (excl_ra:((num)excl)ra)`, + "excl_ra_cancellative"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(a, x), excl_ra_update_owned_iff), + `ra_update + (excl_ra:((num)excl)ra) + (Excl (a:num)) + (x:(num)excl) <=> + ra_valid excl_ra x`, + "excl_ra_update_owned_iff"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(a, x), excl_ra_local_update_iff), + `ra_local_update + (excl_ra:((num)excl)ra) + (Excl (a:num)) + (Excl a) + (x:(num)excl) + x <=> + ra_valid excl_ra x`, + "excl_ra_local_update_iff"); + return 0; +err: + ERR_FUN_PUTS("audit_excl_ra_regressions"); + return -1; +} + +PROOF static int audit_prod_ra_regressions(void) { + term R = `unit_ra`; + term S = `excl_ra:((num)excl)ra`; + term x = `x:1#(num)excl`; + term y = `y:1#(num)excl`; + term a1 = `a1:1`; + term b1 = `b1:1`; + term a2 = `a2:(num)excl`; + term b2 = `b2:(num)excl`; + term f1 = `f1:1`; + term g1 = `g1:1`; + term f2 = `f2:(num)excl`; + term g2 = `g2:(num)excl`; + term P1 = `P1:1->bool`; + term P2 = `P2:(num)excl->bool`; + + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S), prod_ra_unit), + `ra_unit (prod_ra unit_ra (excl_ra:((num)excl)ra)) == + (ra_unit unit_ra,ra_unit excl_ra)`, + "prod_ra_unit"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, x, y), prod_ra_op), + `ra_op + (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (x:1#(num)excl) + (y:1#(num)excl) == + (ra_op unit_ra (FST x) (FST y), + ra_op excl_ra (SND x) (SND y))`, + "prod_ra_op"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, x), prod_ra_valid), + `ra_valid + (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (x:1#(num)excl) <=> + ra_valid unit_ra (FST x) && ra_valid excl_ra (SND x)`, + "prod_ra_valid"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, x, y), prod_ra_included), + `ra_included + (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (x:1#(num)excl) + (y:1#(num)excl) <=> + ra_included unit_ra (FST x) (FST y) && + ra_included excl_ra (SND x) (SND y)`, + "prod_ra_included"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S), prod_ra_cancellative_iff), + `ra_cancellative + (prod_ra unit_ra (excl_ra:((num)excl)ra)) <=> + ra_cancellative unit_ra && + ra_cancellative (excl_ra:((num)excl)ra)`, + "prod_ra_cancellative_iff"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, x), prod_ra_maximal_iff), + `ra_maximal + (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (x:1#(num)excl) <=> + ra_maximal unit_ra (FST x) && + ra_maximal excl_ra (SND x)`, + "prod_ra_maximal_iff"); + check_basic_ra_theorem( + ispecl_rule( + TERM_LIST(R, S, a1, a2, P1, P2), + prod_ra_updateP), + `ra_updateP unit_ra (a1:1) (P1:1->bool) ==> + ra_updateP excl_ra (a2:(num)excl) (P2:(num)excl->bool) ==> + ra_updateP + (prod_ra unit_ra excl_ra) + (a1,a2) + (\x:1#(num)excl. + exists b1:1. exists b2:(num)excl. + P1 b1 && P2 b2 && x == (b1,b2))`, + "prod_ra_updateP"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1, a2, b1), prod_ra_update_left), + `ra_update unit_ra (a1:1) (b1:1) ==> + ra_update (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (a1,(a2:(num)excl)) (b1,a2)`, + "prod_ra_update_left"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1, a2, b2), prod_ra_update_right), + `ra_update excl_ra (a2:(num)excl) (b2:(num)excl) ==> + ra_update (prod_ra unit_ra excl_ra) ((a1:1),a2) (a1,b2)`, + "prod_ra_update_right"); + check_basic_ra_theorem( + ispecl_rule( + TERM_LIST(R, S, a1, f1, b1, g1, a2, f2, b2, g2), + prod_ra_local_update), + `ra_local_update unit_ra (a1:1) (f1:1) (b1:1) (g1:1) ==> + ra_local_update excl_ra + (a2:(num)excl) (f2:(num)excl) (b2:(num)excl) (g2:(num)excl) ==> + ra_local_update (prod_ra unit_ra excl_ra) + (a1,a2) (f1,f2) (b1,b2) (g1,g2)`, + "prod_ra_local_update"); + + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1), prod_inl_def), + `prod_inl unit_ra (excl_ra:((num)excl)ra) (a1:1) == + (a1,ra_unit excl_ra)`, + "prod_inl_def"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a2), prod_inr_def), + `prod_inr unit_ra (excl_ra:((num)excl)ra) (a2:(num)excl) == + (ra_unit unit_ra,a2)`, + "prod_inr_def"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1, b1), prod_inl_op), + `prod_inl unit_ra (excl_ra:((num)excl)ra) + (ra_op unit_ra (a1:1) (b1:1)) == + ra_op (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (prod_inl unit_ra (excl_ra:((num)excl)ra) a1) + (prod_inl unit_ra (excl_ra:((num)excl)ra) b1)`, + "prod_inl_op"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a2, b2), prod_inr_op), + `prod_inr unit_ra excl_ra (ra_op excl_ra (a2:(num)excl) (b2:(num)excl)) == + ra_op (prod_ra unit_ra excl_ra) + (prod_inr unit_ra excl_ra a2) + (prod_inr unit_ra excl_ra b2)`, + "prod_inr_op"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1, P1), prod_inl_updateP), + `ra_updateP unit_ra (a1:1) (P1:1->bool) ==> + ra_updateP (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (prod_inl unit_ra (excl_ra:((num)excl)ra) a1) + (\x:1#(num)excl. exists b:1. + P1 b && + x == prod_inl unit_ra (excl_ra:((num)excl)ra) b)`, + "prod_inl_updateP"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a2, P2), prod_inr_updateP), + `ra_updateP excl_ra (a2:(num)excl) (P2:(num)excl->bool) ==> + ra_updateP (prod_ra unit_ra excl_ra) + (prod_inr unit_ra excl_ra a2) + (\x:1#(num)excl. exists b:(num)excl. + P2 b && x == prod_inr unit_ra excl_ra b)`, + "prod_inr_updateP"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a1, b1), prod_inl_update), + `ra_update unit_ra (a1:1) (b1:1) ==> + ra_update (prod_ra unit_ra (excl_ra:((num)excl)ra)) + (prod_inl unit_ra (excl_ra:((num)excl)ra) a1) + (prod_inl unit_ra (excl_ra:((num)excl)ra) b1)`, + "prod_inl_update"); + check_basic_ra_theorem( + ispecl_rule(TERM_LIST(R, S, a2, b2), prod_inr_update), + `ra_update excl_ra (a2:(num)excl) (b2:(num)excl) ==> + ra_update (prod_ra unit_ra excl_ra) + (prod_inr unit_ra excl_ra a2) + (prod_inr unit_ra excl_ra b2)`, + "prod_inr_update"); + return 0; +err: + ERR_FUN_PUTS("audit_prod_ra_regressions"); + return -1; +} + +PROOF static int audit_basic_ra_constructor_regressions(void) { + ENSURE_COND(audit_unit_ra_regressions() == 0, + "unit RA regressions failed"); + ENSURE_COND(audit_excl_ra_regressions() == 0, + "exclusive RA regressions failed"); + ENSURE_COND(audit_prod_ra_regressions() == 0, + "product RA regressions failed"); + return 0; +err: + ERR_FUN_PUTS("audit_basic_ra_constructor_regressions"); + return -1; +} + +PROOF static int _BASIC_RA_CONSTRUCTORS_REGRESSION = + audit_basic_ra_constructor_regressions(); diff --git a/test/c_resource_v2_regression.c b/test/c_resource_v2_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..94e343f365e0a8f4b246ccdfea34598944c6c9fa --- /dev/null +++ b/test/c_resource_v2_regression.c @@ -0,0 +1,175 @@ +#include "proof/theory/c_program_logic/c_ghost.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/c_ghost.c" + +PROOF static void check_c_resource_v2_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_c_resource_v2_theorem", label); +} + +PROOF static thm c_resource_v2_at_num(const thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one C ghost carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("c_resource_v2_at_num"); + return empty_theorem; +} + +PROOF static int audit_c_resource_v2_regressions(void) { + term G = `G:(num)ra`; + term ghost = `ghost:num`; + term result_pred = `result_pred:num->bool`; + term c_post = + `Q:(((int,(pmem_byte_state)excl)finmap)#num)->bool`; + term resource = + `resource:((int,(pmem_byte_state)excl)finmap)#num`; + + /* The complete user-supplied G is the right component. There is no + * implicit ghost heap, option layer, or hidden allocation state. */ + check_c_resource_v2_theorem( + c_resource_v2_at_num(c_resource_ra_def), + `c_resource_ra (G:(num)ra) == prod_ra mem_ra G`, + "c_resource_ra is the complete-global product carrier"); + + check_c_resource_v2_theorem( + c_resource_v2_at_num(c_lift_phys_def), + `c_lift_phys + (G:(num)ra) + (P:(int,(pmem_byte_state)excl)finmap->bool) == + r_lift_left mem_ra G P`, + "c_lift_phys is the exact left lift"); + + check_c_resource_v2_theorem( + c_resource_v2_at_num(c_lift_ghost_def), + `c_lift_ghost (G:(num)ra) (Q:num->bool) == + r_lift_right mem_ra G Q`, + "c_lift_ghost is the exact right lift"); + + check_c_resource_v2_theorem( + ispecl_rule(TERM_LIST(G, c_post, resource), c_bupd_preserves_phys), + `ra_valid + (c_resource_ra (G:(num)ra)) + (resource:((int,(pmem_byte_state)excl)finmap)#num) ==> + c_bupd G + (Q:(((int,(pmem_byte_state)excl)finmap)#num)->bool) + resource ==> + exists ghost':num. Q (FST resource,ghost')`, + "c_bupd_preserves_phys keeps the physical projection"); + + /* `sl_v2_regression.c` separately locks r_fact to `phi && a == unit`. + * This exact statement therefore makes validity consume an exact-unit + * fact, rather than admitting the resource-independent r_pure assertion. */ + check_c_resource_v2_theorem( + ispecl_rule(TERM_LIST(G, ghost), c_ghost_own_valid), + `r_entails + (c_resource_ra (G:(num)ra)) + (c_ghost_own G (ghost:num)) + (r_sep + (c_resource_ra G) + (r_fact (c_resource_ra G) (ra_valid G ghost)) + (c_ghost_own G ghost))`, + "c_ghost_own_valid exposes validity through exact-unit fact"); + + check_c_resource_v2_theorem( + ispecl_rule( + TERM_LIST(G, ghost, result_pred), + c_ghost_own_updateP), + `ra_updateP + (G:(num)ra) + (ghost:num) + (result_pred:num->bool) ==> + c_viewshift + G + (c_ghost_own G ghost) + (r_exists + (c_resource_ra G) + (\selected:num. + r_sep + (c_resource_ra G) + (r_fact + (c_resource_ra G) + (result_pred selected)) + (c_ghost_own G selected)))`, + "c_ghost_own_updateP returns an exact-unit result witness"); + + term R = `R:(num)ra`; + term name = `name:num`; + term payload = `payload:num`; + term named_result_pred = `named_result_pred:num->bool`; + term named_assertion = + `P_named: + (((int,(pmem_byte_state)excl)finmap)#(num,num)finmap)->bool`; + + check_c_resource_v2_theorem( + ispecl_rule( + TERM_LIST(R, name, payload, named_result_pred), + c_named_own_updateP), + `ra_updateP + (R:(num)ra) + (payload:num) + (named_result_pred:num->bool) ==> + c_viewshift + (named_ra R) + (c_named_own R (name:num) payload) + (r_exists + (c_resource_ra (named_ra R)) + (\selected:num. + r_sep + (c_resource_ra (named_ra R)) + (r_fact + (c_resource_ra (named_ra R)) + (named_result_pred selected)) + (c_named_own R name selected)))`, + "c_named_own_updateP preserves the result witness"); + + /* DROP is unconditional. In particular, its exact conclusion contains no + * freshness token or premise that could make later reuse of `name` illegal. */ + check_c_resource_v2_theorem( + ispecl_rule(TERM_LIST(R, name, payload), c_named_own_drop), + `c_viewshift + (named_ra (R:(num)ra)) + (c_named_own R (name:num) (payload:num)) + (r_emp (c_resource_ra (named_ra R)))`, + "c_named_own_drop is unconditional and freshness-free"); + + check_c_resource_v2_theorem( + ispecl_rule( + TERM_LIST(R, payload, named_assertion), + c_named_own_alloc), + `ra_valid (R:(num)ra) (payload:num) ==> + c_viewshift + (named_ra R) + (P_named: + (((int,(pmem_byte_state)excl)finmap)#(num,num)finmap)->bool) + (r_exists + (c_resource_ra (named_ra R)) + (\allocated:num. + r_sep + (c_resource_ra (named_ra R)) + (c_named_own R allocated payload) + P_named))`, + "c_named_own_alloc allocates into the complete named global RA"); + + return 0; +err: + ERR_FUN_PUTS("audit_c_resource_v2_regressions"); + return -1; +} + +PROOF static int _C_RESOURCE_V2_REGRESSION_AUDIT = + audit_c_resource_v2_regressions(); diff --git a/test/dependency_v2_regression.sh b/test/dependency_v2_regression.sh new file mode 100755 index 0000000000000000000000000000000000000000..6c6c3da1270e1abb1c3a42e9f3834b7717802b50 --- /dev/null +++ b/test/dependency_v2_regression.sh @@ -0,0 +1,176 @@ +#!/usr/bin/env bash + +# Static architecture/API regression for the RA/SL v2 boundary. +# +# This deliberately checks source-visible dependencies and public declarations; +# theorem-level semantic regressions live in the neighbouring *.c tests. + +set -eu + +script_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd) +proof_root=$(CDPATH= cd -- "$script_dir/.." && pwd) +logic_dir="$proof_root/theory/logic" +theory_dir="$proof_root/theory" + +if ! command -v rg >/dev/null 2>&1; then + echo "dependency_v2_regression: rg is required" >&2 + exit 2 +fi + +failed=0 + +reject_matches() { + description=$1 + pattern=$2 + shift 2 + + matches=$(rg -n --no-heading -- "$pattern" "$@" 2>/dev/null || true) + if [ -n "$matches" ]; then + echo "dependency_v2_regression: $description" >&2 + echo "$matches" >&2 + failed=1 + fi +} + +# These are the foundational algebra modules. The SL modules intentionally +# remain in theory/logic for now, so the boundary is expressed explicitly. +ra_file_names=( + ra.h ra.c ra_builder.h ra_internal.h + local_update.h local_update.c + unit_ra.h unit_ra.c + prod_ra.h prod_ra.c prod_ra_internal.h + option_ra.h option_ra.c option_ra_internal.h + excl_ra.h excl_ra.c excl_ra_internal.h + agree_ra.h agree_ra.c + finmap.h finmap.c + gmap_ra.h gmap_ra.c gmap_ra_internal.h + named_ra.h named_ra.c + auth_ra.h auth_ra.c + max_nat_ra.h max_nat_ra.c + frac_ra.h frac_ra.c +) + +existing_ra_files=() +for name in "${ra_file_names[@]}"; do + file="$logic_dir/$name" + if [ -f "$file" ]; then + existing_ra_files+=("$file") + fi +done + +ra_test_sources=() +while IFS= read -r source; do + ra_test_sources+=("$source") +done < <(find "$script_dir" -type f -name '*.c' -print) + +reject_matches \ + "foundational RA module depends on an SL module" \ + '^[[:space:]]*#(include|require)[[:space:]]+"proof/theory/logic/(resource_prop|basic_update|big_sep|product_resource|named_logic|ghost_own|ghost_update)\.(h|c)"' \ + "${existing_ra_files[@]}" + +reject_matches \ + "foundational RA module depends on c_program_logic" \ + '^[[:space:]]*#(include|require)[[:space:]]+"proof/theory/c_program_logic/' \ + "${existing_ra_files[@]}" + +# Internal headers are the only supported home for representation and raw +# rewrite helpers, so they are intentionally excluded from public-surface +# checks below. +public_headers=() +while IFS= read -r header; do + public_headers+=("$header") +done < <(find "$theory_dir" -type f -name '*.h' ! -name '*_internal.h' -print) + +reject_matches \ + "public header exposes removed ra_update_nd" \ + '\bra_update_nd\b' \ + "${public_headers[@]}" + +reject_matches \ + "public header exposes a deallocation API; use DROP" \ + '(_DEALLOC|_dealloc)(_|\b)|\bdealloc\b' \ + "${public_headers[@]}" + +reject_matches \ + "public header exposes an invalid-source vacuity theorem" \ + '^PROOF[[:space:]]+extern[[:space:]]+thm[[:space:]]+[[:alnum:]_]*(ra_update_invalid|ra_updateP_invalid|ra_invalid_exclusive|ra_invalid_maximal)[[:alnum:]_]*;' \ + "${public_headers[@]}" + +reject_matches \ + "public header exposes the old exclusive name for frame-maximality" \ + '\b(ra_exclusive|ra_local_update_exclusive|unit_ra_exclusive|prod_ra_exclusive_iff|excl_ra_exclusive|frac_ra_exclusive_full)\b' \ + "${public_headers[@]}" + +reject_matches \ + "RA implementation or test retains the old frame-maximal theorem name" \ + '\b[[:alnum:]_]*(ra_exclusive|ra_local_update_exclusive|agree_ra_not_exclusive_owned|max_nat_ra_not_exclusive|exclusive_source_valid|source_not_exclusive)[[:alnum:]_]*\b' \ + "${existing_ra_files[@]}" \ + "${ra_test_sources[@]}" + +reject_matches \ + "public assertion header exposes a raw-equality theorem handle" \ + '^PROOF[[:space:]]+extern[[:space:]]+thm[[:space:]]+r_[[:alnum:]_]*_eq;' \ + "$logic_dir/resource_prop.h" \ + "$logic_dir/basic_update.h" \ + "$logic_dir/big_sep.h" \ + "$logic_dir/product_resource.h" \ + "$logic_dir/named_logic.h" + +# Theorem handles use lower_snake_case. Mixed case is permitted only where a +# handle embeds the spelling of an object-language constant that is itself +# mixed case; semantic qualifiers such as none/some/map remain lowercase. +theorem_handles=$(rg --no-filename \ + '^PROOF[[:space:]]+((extern|static)[[:space:]]+)?thm[[:space:]]+[[:alnum:]_]+([[:space:]]*=|;)' \ + "$logic_dir" "$theory_dir/c_program_logic" 2>/dev/null | sed -E \ + 's/^PROOF[[:space:]]+((extern|static)[[:space:]]+)?thm[[:space:]]+([[:alnum:]_]+).*/\3/' || true) + +while IFS= read -r handle; do + [ -n "$handle" ] || continue + normalized=$handle + normalized=${normalized//updateP/updatep} + normalized=${normalized//Tuint64/tuint64} + normalized=${normalized//leftP/leftp} + normalized=${normalized//rightP/rightp} + case "$normalized" in + [!a-z]*|*[A-Z]*) + echo "dependency_v2_regression: theorem handle is not lower_snake_case: $handle" >&2 + failed=1 + ;; + esac +done <' \ + "$logic_dir/local_update.c"; then + echo "dependency_v2_regression: ra_local_update is not the five-argument v2 relation" >&2 + failed=1 +fi + +# The former ghost_* surface was replaced by named_ra/named_logic. Keeping +# those headers would leave both the old vocabulary and raw assertion laws +# publicly includable even if no current client happens to use them. +for obsolete_header in ghost_heap.h ghost_own.h ghost_update.h; do + if [ -e "$logic_dir/$obsolete_header" ]; then + echo "dependency_v2_regression: obsolete public header remains: theory/logic/$obsolete_header" >&2 + failed=1 + fi +done + +if [ "$failed" -ne 0 ]; then + exit 1 +fi + +echo "dependency_v2_regression: ok" diff --git a/test/gmap_ra_regression.c b/test/gmap_ra_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..111d49bff0f3d29a600fd25b7ba6bafd4f0cdb61 --- /dev/null +++ b/test/gmap_ra_regression.c @@ -0,0 +1,234 @@ +#include "proof/theory/logic/excl_ra.h" +#include "proof/theory/logic/gmap_ra.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/excl_ra.c" +#require "proof/theory/logic/gmap_ra.c" + +/* Public-v2 regression coverage. In particular, this file deliberately does + * not mention the representation lemmas used to construct gmap_ra. */ +PROOF static void check_gmap_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_gmap_theorem", label); +} + +PROOF static thm gmap_key_at_num(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one remaining key type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("gmap_key_at_num"); + return empty_theorem; +} + +PROOF static thm ra_at_num_excl_map(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one RA carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add( + &types, + ((type_pair){`:(num,(num)excl)finmap`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("ra_at_num_excl_map"); + return empty_theorem; +} + +PROOF static int audit_gmap_v2_regressions(void) { + term R = `excl_ra:((num)excl)ra`; + term key = `key:num`; + term a = `a:(num)excl`; + term f = `f:(num)excl`; + term b = `b:(num)excl`; + term g = `g:(num)excl`; + term m = `m:(num,(num)excl)finmap`; + term n = `n:(num,(num)excl)finmap`; + term P = `P:(num)excl->bool`; + term candidates = `candidates:num->bool`; + term payload = `payload:num->(num)excl`; + term forbidden = `forbidden:num->bool`; + + check_gmap_theorem( + gmap_key_at_num(ispec_rule(R, gmap_ra_unit)), + `ra_unit + (gmap_ra (excl_ra:((num)excl)ra)) == + (finmap_empty:(num,(num)excl)finmap)`, + "gmap_ra_unit"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, a), gmap_ra_valid_singleton), + `ra_valid + (gmap_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (key:num) (a:(num)excl)) <=> + ra_valid (excl_ra:((num)excl)ra) a`, + "gmap_ra_valid_singleton"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, a, m), gmap_ra_decompose), + `finmap_lookup + (m:(num,(num)excl)finmap) + (key:num) == SOME (a:(num)excl) ==> + m == + ra_op + (gmap_ra (excl_ra:((num)excl)ra)) + (finmap_singleton key a) + (finmap_delete key m)`, + "gmap_ra_decompose"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, m, n), gmap_ra_included_lookup_iff), + `ra_included + (gmap_ra (excl_ra:((num)excl)ra)) + (m:(num,(num)excl)finmap) + (n:(num,(num)excl)finmap) <=> + forall query:num. + ra_included + (option_ra (excl_ra:((num)excl)ra)) + (finmap_lookup m query) + (finmap_lookup n query)`, + "gmap_ra_included_lookup_iff"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, a, f, b, g, m), + gmap_ra_local_update_at), + `finmap_lookup + (m:(num,(num)excl)finmap) + (key:num) == SOME (a:(num)excl) ==> + ra_local_update + (excl_ra:((num)excl)ra) + a (f:(num)excl) (b:(num)excl) (g:(num)excl) ==> + ra_local_update + (gmap_ra (excl_ra:((num)excl)ra)) + m + (finmap_singleton key f) + (finmap_insert key b m) + (finmap_singleton key g)`, + "gmap_ra_local_update_at"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, a, b, m), gmap_ra_update_at), + `finmap_lookup + (m:(num,(num)excl)finmap) + (key:num) == SOME (a:(num)excl) ==> + ra_update + (excl_ra:((num)excl)ra) + a (b:(num)excl) ==> + ra_update + (gmap_ra (excl_ra:((num)excl)ra)) + m + (finmap_insert key b m)`, + "gmap_ra_update_at"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, a, P, m), gmap_ra_updateP_at), + `finmap_lookup + (m:(num,(num)excl)finmap) + (key:num) == SOME (a:(num)excl) ==> + ra_updateP + (excl_ra:((num)excl)ra) + a (P:(num)excl->bool) ==> + ra_updateP + (gmap_ra (excl_ra:((num)excl)ra)) + m + (\result:(num,(num)excl)finmap. + exists selected:(num)excl. + P selected && + result == finmap_insert key selected m)`, + "gmap_ra_updateP_at"); + + /* Drop only removes this fragment's binding. It has no freshness premise + * and makes no claim that this name remains unavailable to later allocs. */ + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, key, m), gmap_ra_drop_at), + `ra_update + (gmap_ra (excl_ra:((num)excl)ra)) + (m:(num,(num)excl)finmap) + (finmap_delete (key:num) m)`, + "gmap_ra_drop_at"); + + /* The existential result is inside the universal frame quantifier. This + * is the semantic regression that permits allocation's chosen fresh key to + * depend on the hidden frame. */ + check_gmap_theorem( + ra_at_num_excl_map(ra_updateP_def), + `ra_updateP + (R:((num,(num)excl)finmap)ra) + (a:(num,(num)excl)finmap) + (result:(num,(num)excl)finmap->bool) <=> + forall frame:(num,(num)excl)finmap. + ra_valid + R + (ra_op + R + a frame) ==> + exists selected:(num,(num)excl)finmap. + result selected && + ra_valid + R + (ra_op + R + selected frame)`, + "ra_updateP witness is frame dependent"); + + check_gmap_theorem( + ispecl_rule( + TERM_LIST(R, candidates, payload, m), + gmap_ra_alloc_strong_dep), + `INFINITE (candidates:num->bool) ==> + (forall candidate:num. + candidate IN candidates ==> + finmap_lookup + (m:(num,(num)excl)finmap) + candidate == NONE ==> + ra_valid + (excl_ra:((num)excl)ra) + ((payload:num->(num)excl) candidate)) ==> + ra_updateP + (gmap_ra (excl_ra:((num)excl)ra)) + m + (\result:(num,(num)excl)finmap. + exists candidate:num. + candidate IN candidates && + finmap_lookup m candidate == NONE && + result == + finmap_insert candidate (payload candidate) m)`, + "gmap_ra_alloc_strong_dep"); + + check_gmap_theorem( + ispecl_rule(TERM_LIST(R, forbidden, m, a), + gmap_ra_alloc_cofinite), + `INFINITE (UNIV:num->bool) ==> + FINITE (forbidden:num->bool) ==> + ra_valid (excl_ra:((num)excl)ra) (a:(num)excl) ==> + ra_updateP + (gmap_ra (excl_ra:((num)excl)ra)) + (m:(num,(num)excl)finmap) + (\result:(num,(num)excl)finmap. + exists candidate:num. + ~(candidate IN forbidden) && + finmap_lookup m candidate == NONE && + result == finmap_insert candidate a m)`, + "gmap_ra_alloc_cofinite"); + + return 0; +err: + ERR_FUN_PUTS("audit_gmap_v2_regressions"); + return -1; +} + +PROOF static int _GMAP_RA_V2_REGRESSION = + audit_gmap_v2_regressions(); diff --git a/test/named_ra_regression.c b/test/named_ra_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..0ace52eb8c0cd456604204794ad4ad9b3a81ffb6 --- /dev/null +++ b/test/named_ra_regression.c @@ -0,0 +1,241 @@ +#include "proof/theory/logic/excl_ra.h" +#include "proof/theory/logic/named_logic.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/excl_ra.c" +#require "proof/theory/logic/named_logic.c" + +/* The named layer is intentionally just the numeric specialization of gmap, + * exposed through exact singleton ownership. */ +PROOF static void check_named_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_named_theorem", label); +} + +PROOF static thm named_at_num_excl(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one named payload type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:(num)excl`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("named_at_num_excl"); + return empty_theorem; +} + +PROOF static int audit_named_v2_regressions(void) { + term R = `excl_ra:((num)excl)ra`; + term name = `name:num`; + term a = `a:(num)excl`; + term b = `b:(num)excl`; + term P = `P:(num)excl->bool`; + term m = `m:(num,(num)excl)finmap`; + term assertion = `Q:(num,(num)excl)finmap->bool`; + + check_named_theorem( + ispec_rule(R, named_ra_unit), + `ra_unit (named_ra (excl_ra:((num)excl)ra)) == + (finmap_empty:(num,(num)excl)finmap)`, + "named_ra_unit"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a, b), named_ra_singleton_op), + `ra_op + (named_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (name:num) (a:(num)excl)) + (finmap_singleton name (b:(num)excl)) == + finmap_singleton + name + (ra_op (excl_ra:((num)excl)ra) a b)`, + "named_ra_singleton_op"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a), named_ra_valid_singleton), + `ra_valid + (named_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (name:num) (a:(num)excl)) <=> + ra_valid (excl_ra:((num)excl)ra) a`, + "named_ra_valid_singleton"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a, b), named_ra_update_singleton), + `ra_update + (excl_ra:((num)excl)ra) + (a:(num)excl) + (b:(num)excl) ==> + ra_update + (named_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (name:num) a) + (finmap_singleton name b)`, + "named_ra_update_singleton"); + + check_named_theorem( + ispecl_rule( + TERM_LIST(R, name, a, P), + named_ra_updateP_singleton), + `ra_updateP + (excl_ra:((num)excl)ra) + (a:(num)excl) + (P:(num)excl->bool) ==> + ra_updateP + (named_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (name:num) a) + (\result:(num,(num)excl)finmap. + exists selected:(num)excl. + P selected && + result == finmap_singleton name selected)`, + "named_ra_updateP_singleton"); + + /* Dropping ownership produces the unit. There is intentionally no + * persistent tombstone or freshness conclusion. */ + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a), named_ra_drop), + `ra_update + (named_ra (excl_ra:((num)excl)ra)) + (finmap_singleton (name:num) (a:(num)excl)) + (finmap_empty:(num,(num)excl)finmap)`, + "named_ra_drop"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, m, a), named_ra_alloc), + `ra_valid + (excl_ra:((num)excl)ra) + (a:(num)excl) ==> + ra_updateP + (named_ra (excl_ra:((num)excl)ra)) + (m:(num,(num)excl)finmap) + (\result:(num,(num)excl)finmap. + exists allocated:num. + finmap_lookup m allocated == NONE && + result == finmap_insert allocated a m)`, + "named_ra_alloc"); + + check_named_theorem( + named_at_num_excl(named_own_def), + `named_own + (R:((num)excl)ra) + (name:num) + (a:(num)excl) == + r_own + (named_ra R) + (finmap_singleton name a)`, + "named_own_def"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a, b), named_own_op), + `r_equiv + (named_ra (excl_ra:((num)excl)ra)) + (named_own + (excl_ra:((num)excl)ra) + (name:num) + (ra_op + (excl_ra:((num)excl)ra) + (a:(num)excl) + (b:(num)excl))) + (r_sep + (named_ra (excl_ra:((num)excl)ra)) + (named_own (excl_ra:((num)excl)ra) name a) + (named_own (excl_ra:((num)excl)ra) name b))`, + "named_own_op"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a), named_own_valid), + `r_entails + (named_ra (excl_ra:((num)excl)ra)) + (named_own + (excl_ra:((num)excl)ra) + (name:num) + (a:(num)excl)) + (r_sep + (named_ra (excl_ra:((num)excl)ra)) + (r_fact + (named_ra (excl_ra:((num)excl)ra)) + (ra_valid (excl_ra:((num)excl)ra) a)) + (named_own (excl_ra:((num)excl)ra) name a))`, + "named_own_valid uses fact"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a, b), named_own_update), + `ra_update + (excl_ra:((num)excl)ra) + (a:(num)excl) + (b:(num)excl) ==> + r_viewshift + (named_ra (excl_ra:((num)excl)ra)) + (named_own (excl_ra:((num)excl)ra) (name:num) a) + (named_own (excl_ra:((num)excl)ra) name b)`, + "named_own_update"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a, P), named_own_updateP), + `ra_updateP + (excl_ra:((num)excl)ra) + (a:(num)excl) + (P:(num)excl->bool) ==> + r_viewshift + (named_ra (excl_ra:((num)excl)ra)) + (named_own (excl_ra:((num)excl)ra) (name:num) a) + (r_exists + (named_ra (excl_ra:((num)excl)ra)) + (\selected:(num)excl. + r_sep + (named_ra (excl_ra:((num)excl)ra)) + (r_fact + (named_ra (excl_ra:((num)excl)ra)) + (P selected)) + (named_own + (excl_ra:((num)excl)ra) + name + selected)))`, + "named_own_updateP uses fact"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, name, a), named_own_drop), + `r_viewshift + (named_ra (excl_ra:((num)excl)ra)) + (named_own + (excl_ra:((num)excl)ra) + (name:num) + (a:(num)excl)) + (r_emp (named_ra (excl_ra:((num)excl)ra)))`, + "named_own_drop"); + + check_named_theorem( + ispecl_rule(TERM_LIST(R, a, assertion), named_own_alloc), + `ra_valid + (excl_ra:((num)excl)ra) + (a:(num)excl) ==> + r_viewshift + (named_ra (excl_ra:((num)excl)ra)) + (Q:(num,(num)excl)finmap->bool) + (r_exists + (named_ra (excl_ra:((num)excl)ra)) + (\allocated:num. + r_sep + (named_ra (excl_ra:((num)excl)ra)) + (named_own + (excl_ra:((num)excl)ra) + allocated + a) + Q))`, + "named_own_alloc"); + + return 0; +err: + ERR_FUN_PUTS("audit_named_v2_regressions"); + return -1; +} + +PROOF static int _NAMED_V2_REGRESSION = + audit_named_v2_regressions(); diff --git a/test/proof_backward_regression.c b/test/proof_backward_regression.c index 9483bd9c9039283ae27aa6c46076691815ab6999..1e315e2195ce51339fd364a24036e11ea3036b93 100644 --- a/test/proof_backward_regression.c +++ b/test/proof_backward_regression.c @@ -1,4 +1,6 @@ #include "proof/proof.h" +#include "userlib/qcp/c_logic_default.h" +#require "userlib/qcp/c_logic_default.c" PROOF indtype induction_test_tree = new_datatype_definition( "induction_test_tree = IndLeaf A" @@ -70,6 +72,23 @@ PROOF static thm prove_negation_introduction() { ACCEPT_TAC(auto_body, assume_rule(mk_false())); ENSURE_COND(!IS_NULL(gnode_prove(auto_root)), "AUTO_INTROS_TAC did not validate a negation proof"); + + term redex_prop = `(\p:bool. p) F`; + term neg_redex = mk_not(redex_prop); + gnode redex_root = gnode_new_with_ccl(neg_redex); + gnode redex_body = DISCH_TAC(redex_root, "Hredex"); + labeled_term_list redex_asmps = goal_lasmps(redex_body->g); + ENSURE_COND(vector_size(redex_asmps) == 1 && + equals_term(redex_asmps[0].tm, redex_prop) && + is_false(goal_ccl(redex_body->g)), + "DISCH_TAC reduced a redex inside a negated antecedent"); + conv beta = get_conversion_by_name("BETA_CONV"); + thm redex_false = eq_mp_rule( + apply_conversion(beta, redex_prop), assume_rule(redex_prop)); + ACCEPT_TAC(redex_body, redex_false); + thm redex_result = gnode_prove(redex_root); + ENSURE_COND(equals_term(concl(redex_result), neg_redex), + "Negation validation changed a caller-owned beta-redex"); return result; err: ERR_FUN_PUTS("prove_negation_introduction"); @@ -578,10 +597,10 @@ PROOF static void check_goal_printing_context_names() { strstr(general, "H_keep") != NULL, "General goal uses inconsistent context headings"); - labeled_term spatial = {`hp:hprop`, "R_keep"}; + labeled_term spatial = {`hp:cprop`, "R_keep"}; char* sl = cstr_goal(sl_goal_new(LABELED_TERM_LIST(pure), LABELED_TERM_LIST(spatial), - `hq:hprop`)); + `hq:cprop`)); ENSURE_COND(strstr(sl, "Assumptions:") != NULL && strstr(sl, "Antecedents:") != NULL && strstr(sl, "Consequent:") != NULL && @@ -656,6 +675,21 @@ PROOF static void check_gnode_accept_boundary() { bool stored_aligned = equals_term(stored_ccl, original); ENSURE_COND(returned_aligned && stored_aligned, "gnode_prove did not preserve exact root-binder alignment"); + + term beta_prop = `(\x:num. (p:bool)) 0`; + labeled_term beta_assumption = {beta_prop, "HB"}; + goal beta_goal = + general_goal_new(LABELED_TERM_LIST(beta_assumption), p); + gnode beta_node = gnode_new(beta_goal); + thm beta_assumption_th = assume_rule(beta_prop); + proof_try_begin(); + gnode_accept(beta_node, beta_assumption_th); + bool beta_rejected = NOT_OK && IS_NULL(beta_node->solved); + if (NOT_OK) SET_OK(); + proof_try_end(); + proof_clear_errors(); + ENSURE_COND(beta_rejected, + "gnode_accept accepted a merely beta-equivalent conclusion"); return; err: ERR_FUN_PUTS("check_gnode_accept_boundary"); diff --git a/test/proof_lithium_regression.c b/test/proof_lithium_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..ba9ddfd346e41f67daeead3f66732d1636405876 --- /dev/null +++ b/test/proof_lithium_regression.c @@ -0,0 +1,547 @@ +#include "proof/proof.h" +#include "userlib/qcp/c_logic_default.h" +#require "userlib/qcp/c_logic_default.c" + +/** Regression coverage for the Lithium-inspired committed entailment solver. */ + +PROOF static thm lithium_prove(const term proposition, + const lithium_rule_set* rules) { + gnode root = gnode_new_with_ccl(proposition); + lithium_options options = lithium_options_default(rules); + gnode_list leaves = LITHIUM_SLTAC(root, options); + ENSURE_COND(leaves != NULL && vector_size(leaves) == 0, + "Lithium left an unexpected open goal"); + return gnode_prove(root); +err: + ERR_FUN_PUTS("lithium_prove", cstr_term(proposition)); + return empty_theorem; +} + +PROOF static gnode_list lithium_stuck(const term proposition, + const lithium_rule_set* rules) { + gnode root = gnode_new_with_ccl(proposition); + lithium_options options = lithium_options_default(rules); + gnode_list leaves = LITHIUM_SLTAC(root, options); + ENSURE_COND(leaves != NULL && vector_size(leaves) != 0, + "Lithium unexpectedly proved a negative regression"); + return leaves; +err: + ERR_FUN_PUTS("lithium_stuck", cstr_term(proposition)); + return NULL; +} + +PROOF typedef struct { + size_t count; + const char* sequence[64]; + bool invalid_before_snapshot; +} lithium_trace_log; + +PROOF static void record_lithium_trace(const char* rule_name, + const gnode before, + const gnode_list after, + const void* data) { + (void)before; + (void)after; + lithium_trace_log* log = (lithium_trace_log*)data; + if (before == NULL || !IS_NULL(before->solved) || + vector_size(before->children) != 0) { + log->invalid_before_snapshot = true; + } + if (log->count < 64) log->sequence[log->count] = rule_name; + ++log->count; +} + +PROOF static size_t lithium_trace_count(const lithium_trace_log* log, + const char* rule_name) { + size_t result = 0; + size_t limit = log->count < 64 ? log->count : 64; + for (size_t i = 0; i < limit; ++i) { + if (strcmp(log->sequence[i], rule_name) == 0) ++result; + } + return result; +} + +PROOF static int lithium_trace_index(const lithium_trace_log* log, + const char* rule_name) { + size_t limit = log->count < 64 ? log->count : 64; + for (size_t i = 0; i < limit; ++i) { + if (strcmp(log->sequence[i], rule_name) == 0) return (int)i; + } + return -1; +} + +PROOF static thm lithium_prove_traced(const term proposition, + const lithium_rule_set* rules, + lithium_trace_log* log) { + gnode root = gnode_new_with_ccl(proposition); + lithium_options options = lithium_options_default(rules); + options.trace = record_lithium_trace; + options.trace_data = log; + gnode_list leaves = LITHIUM_SLTAC(root, options); + ENSURE_COND(leaves != NULL && vector_size(leaves) == 0, + "Traced Lithium proof left an unexpected open goal"); + ENSURE_COND(!log->invalid_before_snapshot, + "Lithium trace did not receive a pre-step snapshot"); + return gnode_prove(root); +err: + ERR_FUN_PUTS("lithium_prove_traced", cstr_term(proposition)); + return empty_theorem; +} + +PROOF static gnode_list lithium_stuck_traced(const term proposition, + const lithium_rule_set* rules, + lithium_trace_log* log) { + gnode root = gnode_new_with_ccl(proposition); + lithium_options options = lithium_options_default(rules); + options.trace = record_lithium_trace; + options.trace_data = log; + gnode_list leaves = LITHIUM_SLTAC(root, options); + ENSURE_COND(leaves != NULL && vector_size(leaves) != 0, + "Traced Lithium negative regression unexpectedly closed"); + ENSURE_COND(!log->invalid_before_snapshot, + "Lithium trace did not receive a pre-step snapshot"); + return leaves; +err: + ERR_FUN_PUTS("lithium_stuck_traced", cstr_term(proposition)); + return NULL; +} + +PROOF static bool choose_right_matches(const gnode gn, const void* data) { + (void)data; + return goal_is_sl(gn->g) && is_sl_or(goal_hcon(gn->g)); +} + +PROOF static gnode_list choose_right_apply(const gnode gn, + const void* data) { + (void)data; + return LIST_GNODE(DISJ2_SLTAC(gn)); +} + +PROOF static bool always_matches(const gnode gn, const void* data) { + (void)gn; + (void)data; + return true; +} + +PROOF static gnode_list malformed_null_apply(const gnode gn, + const void* data) { + (void)gn; + (void)data; + return LIST_GNODE(NULL); +} + +PROOF static void check_committed_priority(void) { + term good = `hp_good:cprop`; + term bad = `hp_bad:cprop`; + term target = mk_sl_or(good, bad); + thm high_bad = ispecl_rule(TERM_LIST(good, bad), sl_or_intro2()); + thm low_good = ispecl_rule(TERM_LIST(good, bad), sl_or_intro1()); + + /* Register and compose in the opposite order from numeric priority. */ + lithium_rule_set low_bundle = lithium_rule_set_new(); + lithium_rule_set high_bundle = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &low_bundle, "low-good", 10, + LITHIUM_GOAL_RULE, low_good) == 0 && + lithium_rule_set_add_theorem( + &high_bundle, "high-bad", 1, + LITHIUM_GOAL_RULE, high_bad) == 0, + "Could not construct priority rule bundles"); + lithium_rule_set rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_append(&rules, &low_bundle) == 0 && + lithium_rule_set_append(&rules, &high_bundle) == 0 && + lithium_rule_set_size(&rules) == 2, + "Could not compose priority rule bundles"); + + gnode root = gnode_new_with_ccl(mk_sl_ent(good, target)); + lithium_trace_log log = {0}; + lithium_options options = lithium_options_default(&rules); + options.trace = record_lithium_trace; + options.trace_data = &log; + gnode_list leaves = LITHIUM_SLTAC(root, options); + ENSURE_COND(leaves != NULL && vector_size(leaves) == 1 && + log.count >= 2 && + strcmp(log.sequence[0], "enter-sl") == 0 && + strcmp(log.sequence[1], "high-bad") == 0, + "Committed-priority regression did not reach its selected rule"); + + /* The trace starts with enter-sl; inspect the selected goal-rule expansion + * itself. It must reduce the target to bad and must not try low-good after + * that recursive goal gets stuck. */ + gnode stuck = leaves[0]; + ENSURE_COND(goal_is_sl(stuck->g) && + alpha_compare(goal_hcon(stuck->g), bad) == 0 && + lithium_trace_count(&log, "high-bad") == 1 && + lithium_trace_count(&log, "low-good") == 0, + "Lithium backtracked from the committed high-priority rule"); + + /* Equal priorities retain registration order. */ + lithium_rule_set equal_first_bundle = lithium_rule_set_new(); + lithium_rule_set equal_second_bundle = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &equal_first_bundle, "first-bad", 5, + LITHIUM_GOAL_RULE, high_bad) == 0 && + lithium_rule_set_add_theorem( + &equal_second_bundle, "second-good", 5, + LITHIUM_GOAL_RULE, low_good) == 0, + "Could not register equal-priority rules"); + lithium_rule_set equal_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_append( + &equal_rules, &equal_first_bundle) == 0 && + lithium_rule_set_append( + &equal_rules, &equal_second_bundle) == 0, + "Could not append equal-priority rule bundles"); + lithium_trace_log equal_log = {0}; + gnode_list equal_leaves = lithium_stuck_traced( + mk_sl_ent(good, target), &equal_rules, &equal_log); + ENSURE_COND(equal_leaves != NULL && + lithium_trace_count(&equal_log, "first-bad") == 1 && + lithium_trace_count(&equal_log, "second-good") == 0, + "Equal-priority Lithium rules did not retain source order"); + + lithium_rule_set good_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &good_rules, "low-good", 10, + LITHIUM_GOAL_RULE, low_good) == 0, + "Could not register independently usable lower rule"); + lithium_trace_log low_log = {0}; + thm proved = lithium_prove_traced( + mk_sl_ent(good, target), &good_rules, &low_log); + ENSURE_COND(!IS_NULL(proved) && + lithium_trace_count(&low_log, "low-good") == 1, + "The lower-priority rule was not independently usable"); + return; +err: + ERR_FUN_PUTS("check_committed_priority"); +} + +PROOF static int proof_lithium_regression(void) { + thm reflexivity = lithium_prove( + `(hp_a:cprop) |-- hp_a`, NULL); + thm sep_unit = lithium_prove( + `emp ** (hp_a:cprop) |-- hp_a`, NULL); + thm sep_comm = lithium_prove( + `(hp_a:cprop) ** hp_b |-- hp_b ** hp_a`, NULL); + thm duplicate = lithium_prove( + `(hp_a:cprop) ** hp_b ** hp_a |-- hp_a ** hp_a ** hp_b`, NULL); + + gnode_list no_weakening = lithium_stuck( + `(hp_a:cprop) ** hp_b |-- hp_a`, NULL); + gnode_list no_duplication = lithium_stuck( + `(hp_a:cprop) |-- hp_a ** hp_a`, NULL); + + thm right_and = lithium_prove( + `(hp_a:cprop) |-- hp_a && hp_a`, NULL); + thm left_and_1 = lithium_prove( + `(hp_a:cprop) && hp_b |-- hp_a`, NULL); + thm left_and_2 = lithium_prove( + `(hp_a:cprop) && hp_b |-- hp_b`, NULL); + thm left_and_best = lithium_prove( + `(hp_a:cprop) && (hp_a ** hp_b) |-- hp_a ** hp_b`, NULL); + thm right_or_1 = lithium_prove( + `(hp_a:cprop) |-- hp_a || hp_b`, NULL); + thm right_or_2 = lithium_prove( + `(hp_b:cprop) |-- hp_a || hp_b`, NULL); + thm right_or_best = lithium_prove( + `(hp_a:cprop) ** hp_b |-- hp_a || (hp_a ** hp_b)`, NULL); + thm left_or = lithium_prove( + `(hp_a:cprop) || hp_b |-- hp_b || hp_a`, NULL); + + thm exists_round_trip = lithium_prove( + `(exists x. data_at p Tint x) |-- + (exists y. data_at p Tint y ** emp)`, NULL); + thm exists_with_fact = lithium_prove( + `data_at p Tint (c:int) |-- + (exists x. fact(x == c) ** data_at p Tint x)`, NULL); + thm exists_from_assumption = lithium_prove( + `(x:int) == c ==> (emp |-- (exists y. fact(y == c)))`, NULL); + thm exists_vacuous = lithium_prove( + `emp |-- (exists x:int. emp)`, NULL); + thm exists_pull = lithium_prove( + `data_at p Tint (c:int) ** (hp_a:cprop) |-- + (exists x. data_at p Tint x) ** (hp_a && hp_a)`, NULL); + lithium_trace_log unknown_witness_log = {0}; + gnode_list unknown_witness = lithium_stuck_traced( + `emp |-- (exists x:int. data_at p Tint x)`, + NULL, &unknown_witness_log); + ENSURE_COND(vector_size(unknown_witness) == 1 && + goal_is_sl(unknown_witness[0]->g) && + is_sl_exists(goal_hcon(unknown_witness[0]->g)) && + lithium_trace_count( + &unknown_witness_log, "right-exists") == 0, + "Lithium guessed an unknown existential witness"); + thm forall_intro = lithium_prove( + `(hp_a:cprop) |-- (forall x:int. hp_a)`, NULL); + thm forall_dependent = lithium_prove( + `emp |-- (forall x:int. fact(x == x))`, NULL); + + thm wand_intro = lithium_prove( + `(hp_f:cprop) |-- hp_a -* (hp_a ** hp_f)`, NULL); + thm wand_apply = lithium_prove( + `((hp_a:cprop) -* hp_b) ** hp_a |-- hp_b`, NULL); + + thm fact_round_trip = lithium_prove( + `fact(p) ** (hp_a:cprop) |-- fact(p) ** hp_a`, NULL); + thm fact_drop = lithium_prove( + `fact(p) ** (hp_a:cprop) |-- hp_a`, NULL); + thm fact_duplicate = lithium_prove( + `fact(p) ** (hp_a:cprop) |-- fact(p) ** fact(p) ** hp_a`, NULL); + thm fact_from_hol = lithium_prove( + `(p:bool) ==> ((hp_a:cprop) |-- fact(p) ** hp_a)`, NULL); + thm false_elim = lithium_prove( + `fact(F) ** (hp_a:cprop) |-- hp_b`, NULL); + + term update_a = `hp_update_a:cprop`; + term update_b = `hp_update_b:cprop`; + term bupd_a = mk_comb(sl_bupd(), update_a); + term bupd_or = mk_comb(sl_bupd(), mk_sl_or(update_a, update_b)); + thm bupd_intro = lithium_prove( + mk_sl_ent(update_a, bupd_a), NULL); + thm bupd_mono = lithium_prove( + mk_sl_ent(bupd_a, bupd_or), NULL); + + /* `lemma_to_li_entails`: a quantified registered theorem rewrites an exact + * RHS atom and recursively solves its LHS. */ + lithium_rule_set goal_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &goal_rules, "or-intro-goal", 10, + LITHIUM_GOAL_RULE, sl_or_intro1()) == 0, + "Could not register the goal theorem rule"); + lithium_trace_log goal_log = {0}; + thm registered_goal = lithium_prove_traced( + `(hp_a:cprop) ** hp_f |-- (hp_a || hp_b) ** hp_f`, + &goal_rules, &goal_log); + ENSURE_COND(lithium_trace_count(&goal_log, "or-intro-goal") == 1 && + lithium_trace_index(&goal_log, "direct-frame") >= 0 && + lithium_trace_index(&goal_log, "direct-frame") < + lithium_trace_index(&goal_log, "or-intro-goal"), + "The registered goal theorem was not selected"); + + /* A binary theorem can quantify an explicit separating frame parameter; + * unlike the unframed rule above, it can match before built-in framing. */ + term generic_p = `generic_p:cprop`; + term generic_q = `generic_q:cprop`; + term generic_k = `generic_k:cprop`; + thm generic_or = ispecl_rule( + TERM_LIST(generic_p, generic_q), sl_or_intro1()); + thm framed_or = frame_right_slrule(generic_or, generic_k); + framed_or = gen_rule(generic_p, framed_or); + framed_or = gen_rule(generic_q, framed_or); + framed_or = gen_rule(generic_k, framed_or); + lithium_rule_set framed_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &framed_rules, "framed-or-goal", 10, + LITHIUM_GOAL_RULE, framed_or) == 0, + "Could not register an explicit-frame goal theorem"); + lithium_trace_log framed_log = {0}; + thm registered_framed = lithium_prove_traced( + `(hp_a:cprop) ** hp_f |-- (hp_a || hp_b) ** hp_f`, + &framed_rules, &framed_log); + ENSURE_COND(framed_log.count >= 2 && + strcmp(framed_log.sequence[1], + "framed-or-goal") == 0, + "The explicit-frame theorem did not override framing"); + + /* A restricted forward-hypothesis analogue transforms one matching linear + * resource; this is intentionally not called full Lithium Subsume. */ + term hp_a = `hp_a:cprop`; + term hp_b = `hp_b:cprop`; + thm a_to_or = ispecl_rule(TERM_LIST(hp_a, hp_b), sl_or_intro1()); + lithium_rule_set hyp_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &hyp_rules, "or-intro-hyp", 10, + LITHIUM_HYP_RULE, a_to_or) == 0, + "Could not register the hypothesis theorem rule"); + lithium_trace_log hyp_log = {0}; + thm registered_hyp = lithium_prove_traced( + `(hp_a:cprop) |-- hp_a || hp_b`, &hyp_rules, &hyp_log); + ENSURE_COND(lithium_trace_count(&hyp_log, "or-intro-hyp") == 1, + "The registered hypothesis theorem was not selected"); + + lithium_trace_log irrelevant_hyp_log = {0}; + gnode_list irrelevant_hyp = lithium_stuck_traced( + `(hp_a:cprop) |-- hp_c`, &hyp_rules, &irrelevant_hyp_log); + ENSURE_COND(irrelevant_hyp != NULL && + lithium_trace_count( + &irrelevant_hyp_log, "or-intro-hyp") == 0, + "An immediately irrelevant HYP rewrite was committed"); + + /* The convenience ENTAIL kind participates in both phases. */ + lithium_rule_set entail_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &entail_rules, "dual-or-intro", 10, + LITHIUM_ENTAIL_RULE, a_to_or) == 0, + "Could not register a dual-direction theorem rule"); + lithium_trace_log entail_goal_log = {0}; + thm entail_goal = lithium_prove_traced( + `(hp_a:cprop) |-- hp_a || hp_b`, + &entail_rules, &entail_goal_log); + ENSURE_COND(lithium_trace_count( + &entail_goal_log, "dual-or-intro") == 1, + "ENTAIL did not use its GOAL interpretation"); + lithium_trace_log entail_hyp_log = {0}; + gnode_list entail_hyp = lithium_stuck_traced( + `(hp_a:cprop) ** hp_x |-- (hp_a || hp_b) ** hp_f`, + &entail_rules, &entail_hyp_log); + ENSURE_COND(entail_hyp != NULL && vector_size(entail_hyp) == 1 && + lithium_trace_count( + &entail_hyp_log, "dual-or-intro") == 1 && + alpha_compare(goal_hcon(entail_hyp[0]->g), + `hp_f:cprop`) == 0, + "ENTAIL did not use its HYP interpretation"); + + /* Phase order dominates numeric priority: leading GOAL is considered + * before a numerically earlier HYP rule. */ + lithium_rule_set phase_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &phase_rules, "hyp-priority-zero", 0, + LITHIUM_HYP_RULE, a_to_or) == 0 && + lithium_rule_set_add_theorem( + &phase_rules, "goal-priority-hundred", 100, + LITHIUM_GOAL_RULE, a_to_or) == 0, + "Could not register cross-phase priority rules"); + lithium_trace_log phase_log = {0}; + thm phase_precedence = lithium_prove_traced( + `(hp_a:cprop) |-- hp_a || hp_b`, &phase_rules, &phase_log); + ENSURE_COND(lithium_trace_count( + &phase_log, "goal-priority-hundred") == 1 && + lithium_trace_count( + &phase_log, "hyp-priority-zero") == 0, + "Numeric priority incorrectly overrode phase precedence"); + + /* Equality registrations use the same exact consequent path. */ + lithium_rule_set equality_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &equality_rules, "fact-true-equality", 10, + LITHIUM_GOAL_RULE, + sym_rule(sl_fact_true_emp())) == 0, + "Could not register an SL equality rule"); + lithium_trace_log equality_log = {0}; + thm registered_equality = lithium_prove_traced( + `emp |-- fact(T)`, + &equality_rules, &equality_log); + ENSURE_COND(lithium_trace_count( + &equality_log, "fact-true-equality") == 1, + "The registered equality theorem was not selected"); + + /* Leading HOL premises are checked against the ordinary context and are not + * silently assumed by theorem matching. */ + term guard = `guard:bool`; + thm guarded = disch_rule(guard, a_to_or); + lithium_rule_set guarded_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_theorem( + &guarded_rules, "guarded-or-intro", 1, + LITHIUM_GOAL_RULE, guarded) == 0 && + lithium_rule_set_add_theorem( + &guarded_rules, "unguarded-or-intro", 10, + LITHIUM_GOAL_RULE, a_to_or) == 0, + "Could not register guarded theorem rules"); + lithium_trace_log guarded_log = {0}; + thm registered_guard = lithium_prove_traced( + `guard ==> ((hp_a:cprop) |-- hp_a || hp_b)`, + &guarded_rules, &guarded_log); + ENSURE_COND(lithium_trace_count( + &guarded_log, "guarded-or-intro") == 1 && + lithium_trace_count( + &guarded_log, "unguarded-or-intro") == 0, + "An available HOL guard did not select the guarded rule"); + lithium_trace_log unguarded_log = {0}; + thm registered_without_guard = lithium_prove_traced( + `(hp_a:cprop) |-- hp_a || hp_b`, + &guarded_rules, &unguarded_log); + ENSURE_COND(lithium_trace_count( + &unguarded_log, "guarded-or-intro") == 0 && + lithium_trace_count( + &unguarded_log, "unguarded-or-intro") == 1, + "A theorem with an unavailable HOL guard was committed"); + + lithium_rule_set custom_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_custom( + &custom_rules, "choose-right", 0, + choose_right_matches, choose_right_apply, NULL) == 0, + "Could not register the custom rule"); + lithium_trace_log custom_log = {0}; + thm custom_rule = lithium_prove_traced( + `emp |-- (hp_a:cprop) || emp`, &custom_rules, &custom_log); + ENSURE_COND(lithium_trace_count(&custom_log, "choose-right") == 1, + "The registered custom rule was not selected"); + + /* A leading custom rule overrides a structurally solvable disjunction, and + * recursive failure does not fall back to the left built-in branch. */ + lithium_trace_log override_log = {0}; + gnode_list custom_override = lithium_stuck_traced( + `emp |-- emp || (hp_a:cprop)`, &custom_rules, &override_log); + ENSURE_COND(custom_override != NULL && + lithium_trace_count(&override_log, "choose-right") == 1, + "A selected custom rule did not override structural search"); + + lithium_trace_log custom_miss_log = {0}; + thm custom_miss = lithium_prove_traced( + `(hp_a:cprop) |-- hp_a`, &custom_rules, &custom_miss_log); + ENSURE_COND(lithium_trace_count(&custom_miss_log, "choose-right") == 0, + "A custom matcher miss was incorrectly traced as committed"); + + /* Malformed custom frontiers are rejected by one-step interpretation. */ + lithium_rule_set malformed_rules = lithium_rule_set_new(); + ENSURE_COND(lithium_rule_set_add_custom( + &malformed_rules, "malformed-null", 0, + always_matches, malformed_null_apply, NULL) == 0, + "Could not register malformed-frontier regression rule"); + gnode malformed_root = + gnode_new_with_ccl(`(hp_a:cprop) |-- hp_a`); + lithium_step_result malformed_step = LITHIUM_STEP_SLTAC( + malformed_root, lithium_options_default(&malformed_rules)); + ENSURE_COND(malformed_step.kind == LITHIUM_ERROR, + "Lithium accepted a malformed custom frontier"); + + /* Reaching the fuel limit is not an error when the next leaf is genuinely + * stuck and therefore requires no further committed step. */ + gnode fuel_root = + gnode_new_with_ccl(`(hp_fuel_a:cprop) |-- hp_fuel_b`); + lithium_options fuel_options = lithium_options_default(NULL); + fuel_options.max_steps = 1; + gnode_list fuel_frontier = LITHIUM_SLTAC(fuel_root, fuel_options); + ENSURE_COND(fuel_frontier != NULL && + vector_size(fuel_frontier) == 1 && + goal_is_sl(fuel_frontier[0]->g), + "Lithium misclassified a no-match leaf as fuel exhaustion"); + + check_committed_priority(); + + ENSURE_COND( + !IS_NULL(reflexivity) && !IS_NULL(sep_unit) && !IS_NULL(sep_comm) && + !IS_NULL(duplicate) && no_weakening != NULL && + no_duplication != NULL && !IS_NULL(right_and) && + !IS_NULL(left_and_1) && !IS_NULL(left_and_2) && + !IS_NULL(left_and_best) && + !IS_NULL(right_or_1) && !IS_NULL(right_or_2) && + !IS_NULL(right_or_best) && + !IS_NULL(left_or) && !IS_NULL(exists_round_trip) && + !IS_NULL(exists_with_fact) && + !IS_NULL(exists_from_assumption) && + !IS_NULL(exists_vacuous) && !IS_NULL(exists_pull) && + unknown_witness != NULL && + !IS_NULL(forall_intro) && !IS_NULL(forall_dependent) && + !IS_NULL(wand_intro) && + !IS_NULL(wand_apply) && !IS_NULL(fact_round_trip) && + !IS_NULL(fact_drop) && !IS_NULL(fact_duplicate) && + !IS_NULL(fact_from_hol) && !IS_NULL(false_elim) && + !IS_NULL(bupd_intro) && !IS_NULL(bupd_mono) && + !IS_NULL(registered_goal) && + !IS_NULL(registered_framed) && + !IS_NULL(registered_hyp) && irrelevant_hyp != NULL && + !IS_NULL(entail_goal) && entail_hyp != NULL && + !IS_NULL(phase_precedence) && + !IS_NULL(registered_equality) && + !IS_NULL(registered_guard) && + !IS_NULL(registered_without_guard) && + !IS_NULL(custom_rule) && custom_override != NULL && + !IS_NULL(custom_miss) && fuel_frontier != NULL, + "A Lithium regression returned an empty theorem or frontier"); + return 0; +err: + ERR_FUN_PUTS("proof_lithium_regression"); + return -1; +} + +PROOF int _proof_lithium_regression = proof_lithium_regression(); diff --git a/test/proof_sl_regression.c b/test/proof_sl_regression.c index dcce3ad918ee0707e292d927693036c2daf1a878..194cd34e5061d53c5106069d5bf49a8d6cae401d 100644 --- a/test/proof_sl_regression.c +++ b/test/proof_sl_regression.c @@ -1,11 +1,13 @@ #include "proof/proof.h" +#include "userlib/qcp/c_logic_default.h" +#require "userlib/qcp/c_logic_default.c" PROOF typedef struct hol_text_type_pair test_implicit_type_entry; PROOF typedef test_implicit_type_entry *test_implicit_type_entry_list; PROOF static thm prove_sep_partition() { gnode root = gnode_new_with_ccl( - `(hp_a:hprop) ** hp_b |-- hp_b ** hp_a`); + `(hp_a:cprop) ** hp_b |-- hp_b ** hp_a`); gnode sl = SL_MODE(root, "HA * HB")[0]; gnode_list parts = SEP_SLTAC(sl, CONST_STRING_LIST("HB")); AUTO_FRAME_SLTAC(parts[0]); @@ -15,7 +17,7 @@ PROOF static thm prove_sep_partition() { PROOF static thm prove_disj_swap() { gnode root = gnode_new_with_ccl( - `(hp_a:hprop) || hp_b |-- hp_b || hp_a`); + `(hp_a:cprop) || hp_b |-- hp_b || hp_a`); gnode_list branches = SL_MODE(root, "HA | HB"); AUTO_FRAME_SLTAC(DISJ2_SLTAC(branches[0])); AUTO_FRAME_SLTAC(DISJ1_SLTAC(branches[1])); @@ -24,7 +26,7 @@ PROOF static thm prove_disj_swap() { PROOF static thm prove_disj_reuses_selected_label() { gnode root = gnode_new_with_ccl( - `(hp_a:hprop) || hp_b |-- hp_a || hp_b`); + `(hp_a:cprop) || hp_b |-- hp_a || hp_b`); gnode sl = SL_MODE(root, "H")[0]; gnode_list branches = HANT_DISJ_SLTAC(sl, "H", "H", "H"); AUTO_FRAME_SLTAC(DISJ1_SLTAC(branches[0])); @@ -50,7 +52,7 @@ PROOF static thm prove_nested_exists_restores_exact_parent() { labeled_term existential = {nested, "HEX"}; goal g = sl_goal_new( (labeled_term_list)vector_create(), - LABELED_TERM_LIST(false_fact, existential), `hp_goal:hprop`); + LABELED_TERM_LIST(false_fact, existential), `hp_goal:cprop`); term expected_ccl = goal_ccl(g); gnode root = gnode_new(g); @@ -75,9 +77,41 @@ err: return empty_theorem; } +PROOF static void check_sl_binder_recognition() { + term hp = `hp_a:cprop`; + term int_witness = `x:int`; + term num_witness = `n:num`; + term int_exists = mk_sl_exists(int_witness, hp); + term num_exists = mk_sl_exists(num_witness, hp); + term int_forall = mk_sl_forall(int_witness, hp); + term num_forall = mk_sl_forall(num_witness, hp); + + ENSURE_COND(is_sl_exists(int_exists) && is_sl_exists(num_exists), + "SL existential recognition lost a witness type instance"); + ENSURE_COND(is_sl_forall(int_forall) && is_sl_forall(num_forall), + "SL universal recognition lost a witness type instance"); + ENSURE_COND(!is_sl_exists(int_forall) && !is_sl_forall(int_exists), + "SL exists/forall operator heads were confused"); + ENSURE_COND(!is_sl_exists(`?x:int. x == x`) && + !is_sl_forall(`!x:int. x == x`), + "A HOL boolean quantifier was accepted as an SL binder"); + + dest_binder_results exists_parts = dest_sl_exists(int_exists); + dest_binder_results forall_parts = dest_sl_forall(num_forall); + ENSURE_COND(equals_term(exists_parts.v, int_witness) && + equals_term(exists_parts.tm, hp) && + equals_term(forall_parts.v, num_witness) && + equals_term(forall_parts.tm, hp), + "SL binder recognition changed the original binder or body"); + return; +err: + ERR_FUN_PUTS("check_sl_binder_recognition"); + return; +} + PROOF static thm prove_wand_application_with_frame() { gnode root = gnode_new_with_ccl( - `(hp_r:hprop) ** ((hp_a -* hp_b) ** hp_a) |-- hp_b ** hp_r`); + `(hp_r:cprop) ** ((hp_a -* hp_b) ** hp_a) |-- hp_b ** hp_r`); gnode sl = SL_MODE(root, "HR * (HW * HA)")[0]; gnode applied = WAND_MP_SLTAC(sl, "HW", "HA", "HB"); @@ -85,7 +119,7 @@ PROOF static thm prove_wand_application_with_frame() { ENSURE_COND(vector_size(lhants) == 2 && strcmp(lhants[0].lb, "HR") == 0 && strcmp(lhants[1].lb, "HB") == 0 && - alpha_compare(lhants[1].tm, `hp_b:hprop`) == 0, + alpha_compare(lhants[1].tm, `hp_b:cprop`) == 0, "WAND_MP_SLTAC did not preserve context order or append its result"); AUTO_FRAME_SLTAC(applied); return gnode_prove(root); @@ -96,7 +130,7 @@ err: PROOF static thm prove_wand_intro_with_fact_pattern() { gnode root = gnode_new_with_ccl( - `(hp_r:hprop) |-- + `(hp_r:cprop) |-- (hp_a ** fact(p)) -* (fact(p) ** hp_a ** hp_r)`); gnode sl = SL_MODE(root, "HR")[0]; gnode_list leaves = INTRO_WAND_SLTAC(sl, "HA * [HP]"); @@ -124,7 +158,7 @@ err: PROOF static thm prove_wand_intro_with_disjunction_pattern() { gnode root = gnode_new_with_ccl( - `emp |-- ((hp_a:hprop) || hp_b) -* (hp_b || hp_a)`); + `emp |-- ((hp_a:cprop) || hp_b) -* (hp_b || hp_a)`); gnode sl = SL_MODE(root, "HE")[0]; gnode_list branches = INTRO_WAND_SLTAC(sl, "HA | HB"); ENSURE_COND(vector_size(branches) == 2, @@ -138,8 +172,10 @@ err: } PROOF static thm prove_exists_pull_changes_only_consequent() { - term assertion = - `(hp_a:hprop) ** (exists x. data_at p Tint x)`; + term caller_redex = `(\z:num. (hp_a:cprop)) 0`; + term assertion = mk_sl_sep( + caller_redex, + mk_sl_sep(`hp_b:cprop`, `exists x. data_at p Tint x`)); labeled_term whole = {assertion, "H"}; goal g = sl_goal_new((labeled_term_list)vector_create(), LABELED_TERM_LIST(whole), assertion); @@ -152,8 +188,13 @@ PROOF static thm prove_exists_pull_changes_only_consequent() { "EXISTS_PULL_SLTAC rewrote an SL antecedent"); ENSURE_COND(is_sl_exists(goal_hcon(pulled->g)), "EXISTS_PULL_SLTAC did not pull the consequent existential"); + dest_binder_results pulled_exists = dest_sl_exists(goal_hcon(pulled->g)); + dest_binop_results pulled_body = dest_sl_sep(pulled_exists.tm); + ENSURE_COND(equals_term(pulled_body.tm1, caller_redex), + "EXISTS_PULL_SLTAC reduced a caller-owned beta-redex"); - gnode opened = HANT_SEP_SLTAC(pulled, "H", "HA", "HEX"); + gnode opened = HANT_SEP_SLTAC(pulled, "H", "HRED", "HREST"); + opened = HANT_SEP_SLTAC(opened, "HREST", "HB", "HEX"); opened = HANT_EXISTS_SLTAC(opened, "HEX", "w"); gnode instantiated = EXISTS_SLTAC(opened, `w:int`); AUTO_FRAME_SLTAC(instantiated); @@ -194,7 +235,7 @@ err: PROOF static thm prove_duplicate_resource_frame() { gnode root = gnode_new_with_ccl( - `(hp_a:hprop) ** hp_a |-- hp_a ** hp_a`); + `(hp_a:cprop) ** hp_a |-- hp_a ** hp_a`); gnode sl = SL_MODE(root, "HA * HB")[0]; gnode remaining = FRAME_SLTAC(sl, CONST_STRING_LIST("HA")); AUTO_FRAME_SLTAC(remaining); @@ -203,7 +244,7 @@ PROOF static thm prove_duplicate_resource_frame() { PROOF static thm prove_sl_conversion() { gnode root = gnode_new_with_ccl( - `fact(true) ** (hp_a:hprop) |-- hp_a ** emp`); + `fact(true) ** (hp_a:cprop) |-- hp_a ** emp`); gnode sl = SL_MODE(root, "H")[0]; conv normalize = pure_rewrite_conv( THM_LIST(sl_fact_true_emp(), sl_sep_emp_left(), sl_sep_emp_right())); @@ -213,11 +254,11 @@ PROOF static thm prove_sl_conversion() { } PROOF static thm prove_hcon_conversion_with_hypothesis() { - term eq_tm = `((hp_b:hprop) = hp_a)`; + term eq_tm = `((hp_b:cprop) = hp_a)`; labeled_term asmp = {eq_tm, "E"}; - labeled_term lhant = {`hp_a:hprop`, "H"}; + labeled_term lhant = {`hp_a:cprop`, "H"}; goal g = sl_goal_new(LABELED_TERM_LIST(asmp), LABELED_TERM_LIST(lhant), - `hp_b:hprop`); + `hp_b:cprop`); term expected_ccl = goal_ccl(g); gnode root = gnode_new(g); @@ -266,16 +307,16 @@ err: PROOF static thm prove_hant_apply_equation_with_frame() { term guard = `apply_guard:bool`; term equation = - `((hp_a:hprop) ** hp_b) = (hp_b ** hp_a)`; + `((hp_a:cprop) ** hp_b) = (hp_b ** hp_a)`; labeled_term guard_asmp = {guard, "HG"}; labeled_term equation_asmp = {equation, "HE"}; - labeled_term hant_a = {`hp_a:hprop`, "HA"}; - labeled_term hant_f = {`hp_f:hprop`, "HF"}; - labeled_term hant_b = {`hp_b:hprop`, "HB"}; + labeled_term hant_a = {`hp_a:cprop`, "HA"}; + labeled_term hant_f = {`hp_f:cprop`, "HF"}; + labeled_term hant_b = {`hp_b:cprop`, "HB"}; goal g = sl_goal_new( LABELED_TERM_LIST(guard_asmp, equation_asmp), LABELED_TERM_LIST(hant_a, hant_f, hant_b), - `(hp_f:hprop) ** (hp_b ** hp_a)`); + `(hp_f:cprop) ** (hp_b ** hp_a)`); term expected_ccl = goal_ccl(g); gnode root = gnode_new(g); @@ -288,7 +329,7 @@ PROOF static thm prove_hant_apply_equation_with_frame() { strcmp(applied_hants[0].lb, "HF") == 0 && strcmp(applied_hants[1].lb, "HA") == 0 && alpha_compare(applied_hants[1].tm, - `(hp_b:hprop) ** hp_a`) == 0, + `(hp_b:cprop) ** hp_a`) == 0, "HANT_APPLY_SLTAC did not preserve the frame, reuse a selected label, " "or keep the RHS whole"); @@ -309,20 +350,20 @@ err: PROOF static thm prove_hant_apply_entailment() { term cell = `data_at p Tptr q`; - term forgotten = `undef_data_at p Tptr`; - term frame = `hp_f:hprop`; + term retained = `data_at p Tptr q`; + term frame = `hp_f:cprop`; gnode root = gnode_new_with_ccl( - mk_sl_ent(mk_sl_sep(cell, frame), mk_sl_sep(forgotten, frame))); + mk_sl_ent(mk_sl_sep(cell, frame), mk_sl_sep(retained, frame))); gnode sl = SL_MODE(root, "HC * HF")[0]; gnode applied = HANT_APPLY_SLTAC( sl, CONST_STRING_LIST("HC"), "HU", - get_data_at_to_undef_data_at()); + refl_slrule(cell)); labeled_term_list hants = goal_lhants(applied->g); ENSURE_COND(vector_size(hants) == 2 && strcmp(hants[0].lb, "HF") == 0 && strcmp(hants[1].lb, "HU") == 0 && - alpha_compare(hants[1].tm, forgotten) == 0, + alpha_compare(hants[1].tm, retained) == 0, "HANT_APPLY_SLTAC did not install an entailment RHS"); AUTO_FRAME_SLTAC(applied); return gnode_prove(root); @@ -332,7 +373,7 @@ err: } PROOF static thm prove_hant_apply_empty_selection() { - term frame = `hp_f:hprop`; + term frame = `hp_f:cprop`; labeled_term hant = {frame, "HF"}; goal g = sl_goal_new((labeled_term_list)vector_create(), LABELED_TERM_LIST(hant), frame); @@ -366,10 +407,10 @@ err: PROOF static thm prove_auto_hant_apply_partial_composite() { term equation = - `(((hp_a:hprop) ** hp_b) = hp_r)`; - term composite = `(hp_a:hprop) ** hp_f`; - term hp_b = `hp_b:hprop`; - term hp_x = `hp_x:hprop`; + `(((hp_a:cprop) ** hp_b) = hp_r)`; + term composite = `(hp_a:cprop) ** hp_f`; + term hp_b = `hp_b:cprop`; + term hp_x = `hp_x:cprop`; labeled_term equation_asmp = {equation, "HE"}; labeled_term composite_hant = {composite, "HC"}; labeled_term b_hant = {hp_b, "HB"}; @@ -377,7 +418,7 @@ PROOF static thm prove_auto_hant_apply_partial_composite() { goal g = sl_goal_new( LABELED_TERM_LIST(equation_asmp), LABELED_TERM_LIST(composite_hant, b_hant, x_hant), - `(hp_f:hprop) ** hp_x ** hp_r`); + `(hp_f:cprop) ** hp_x ** hp_r`); gnode root = gnode_new(g); gnode applied = @@ -385,11 +426,11 @@ PROOF static thm prove_auto_hant_apply_partial_composite() { labeled_term_list hants = goal_lhants(applied->g); ENSURE_COND(vector_size(hants) == 3 && strcmp(hants[0].lb, "HC") == 0 && - alpha_compare(hants[0].tm, `hp_f:hprop`) == 0 && + alpha_compare(hants[0].tm, `hp_f:cprop`) == 0 && strcmp(hants[1].lb, "HX") == 0 && alpha_compare(hants[1].tm, hp_x) == 0 && strcmp(hants[2].lb, "HB") == 0 && - alpha_compare(hants[2].tm, `hp_r:hprop`) == 0, + alpha_compare(hants[2].tm, `hp_r:cprop`) == 0, "AUTO_HANT_APPLY_SLTAC did not consume exact occurrences, " "preserve residual labels, or reuse a consumed label"); AUTO_FRAME_SLTAC(applied); @@ -400,13 +441,13 @@ err: } PROOF static thm prove_auto_hant_apply_duplicate_residual() { - term equation = `((hp_a:hprop) = hp_r)`; - term composite = `(hp_a:hprop) ** (hp_f ** hp_a)`; + term equation = `((hp_a:cprop) = hp_r)`; + term composite = `(hp_a:cprop) ** (hp_f ** hp_a)`; labeled_term equation_asmp = {equation, "HE"}; labeled_term composite_hant = {composite, "HC"}; goal g = sl_goal_new(LABELED_TERM_LIST(equation_asmp), LABELED_TERM_LIST(composite_hant), - `(hp_f:hprop) ** hp_a ** hp_r`); + `(hp_f:cprop) ** hp_a ** hp_r`); gnode root = gnode_new(g); gnode applied = @@ -415,7 +456,7 @@ PROOF static thm prove_auto_hant_apply_duplicate_residual() { ENSURE_COND(vector_size(hants) == 2 && strcmp(hants[0].lb, "HC") == 0 && alpha_compare(hants[0].tm, - `(hp_f:hprop) ** hp_a`) == 0 && + `(hp_f:cprop) ** hp_a`) == 0 && strcmp(hants[1].lb, "HR") == 0, "Automatic application lost the unconsumed duplicate " "occurrence"); @@ -430,7 +471,7 @@ PROOF static thm prove_auto_hant_apply_uses_assumption_binding() { term guard_a = `(a:int) == a`; term cell_a = `data_at p Tint (a:int)`; term cell_b = `data_at p Tint (b:int)`; - term frame = `hp_f:hprop`; + term frame = `hp_f:cprop`; labeled_term guard_asmp = {guard_a, "HG"}; labeled_term cell_b_hant = {cell_b, "HB"}; labeled_term frame_hant = {frame, "HF"}; @@ -459,7 +500,7 @@ err: } PROOF static thm prove_auto_hant_apply_empty_lhs() { - term frame = `hp_f:hprop`; + term frame = `hp_f:cprop`; labeled_term frame_hant = {frame, "HF"}; goal g = sl_goal_new((labeled_term_list)vector_create(), LABELED_TERM_LIST(frame_hant), frame); @@ -485,8 +526,8 @@ PROOF static thm prove_hant_apply_matching_and_fresh_label() { term a = `a:int`; term guard = `(a:int) == a`; term cell = `data_at p Tint (a:int)`; - term frame = `hp_f:hprop`; - term frame0 = `hp_g:hprop`; + term frame = `hp_f:cprop`; + term frame0 = `hp_g:cprop`; labeled_term guard_asmp = {guard, "HG"}; labeled_term frame_hant = {frame, "H"}; labeled_term frame0_hant = {frame0, "H_0"}; @@ -692,11 +733,11 @@ err: PROOF static void check_auto_hant_apply_respects_linearity() { term equation = - `(((hp_a:hprop) ** hp_a) = hp_r)`; + `(((hp_a:cprop) ** hp_a) = hp_r)`; labeled_term equation_asmp = {equation, "HE"}; - labeled_term a_hant = {`hp_a:hprop`, "HA"}; + labeled_term a_hant = {`hp_a:cprop`, "HA"}; goal g = sl_goal_new(LABELED_TERM_LIST(equation_asmp), - LABELED_TERM_LIST(a_hant), `hp_a:hprop`); + LABELED_TERM_LIST(a_hant), `hp_a:cprop`); gnode root = gnode_new(g); proof_try_begin(); @@ -733,19 +774,19 @@ err: PROOF static thm prove_hcon_apply_equation() { term guard = `consequent_guard:bool`; - term equation = `((hp_new:hprop) = hp_old)`; + term equation = `((hp_new:cprop) = hp_old)`; labeled_term guard_asmp = {guard, "HG"}; labeled_term equation_asmp = {equation, "HE"}; - labeled_term hant = {`hp_new:hprop`, "H"}; + labeled_term hant = {`hp_new:cprop`, "H"}; goal g = sl_goal_new( LABELED_TERM_LIST(guard_asmp, equation_asmp), - LABELED_TERM_LIST(hant), `hp_old:hprop`); + LABELED_TERM_LIST(hant), `hp_old:cprop`); term expected_ccl = goal_ccl(g); gnode root = gnode_new(g); thm relation = disch_rule(guard, assume_rule(equation)); gnode applied = HCON_APPLY_SLTAC(root, relation); - ENSURE_COND(alpha_compare(goal_hcon(applied->g), `hp_new:hprop`) == 0, + ENSURE_COND(alpha_compare(goal_hcon(applied->g), `hp_new:cprop`) == 0, "HCON_APPLY_SLTAC did not install an equality LHS"); AUTO_FRAME_SLTAC(applied); thm result = gnode_prove(root); @@ -763,14 +804,10 @@ err: PROOF static thm prove_hcon_apply_entailment() { term cell = `data_at p Tptr q`; - term forgotten = `undef_data_at p Tptr`; gnode root = gnode_new_with_ccl( - mk_sl_ent(cell, mk_sl_sep(forgotten, sl_emp()))); + mk_sl_ent(cell, mk_sl_sep(cell, sl_emp()))); gnode sl = SL_MODE(root, "HC")[0]; - thm forget = specl_rule( - TERM_LIST(`p:addr`, `Tptr:ctype`, `q:addr`), - get_data_at_to_undef_data_at()); - gnode applied = HCON_APPLY_SLTAC(sl, forget); + gnode applied = HCON_APPLY_SLTAC(sl, refl_slrule(cell)); ENSURE_COND(alpha_compare(goal_hcon(applied->g), cell) == 0, "HCON_APPLY_SLTAC did not install an entailment LHS"); AUTO_FRAME_SLTAC(applied); @@ -834,10 +871,10 @@ err: } PROOF static void check_apply_requires_current_assumptions() { - term equation = `((hp_a:hprop) = hp_b)`; - labeled_term hant = {`hp_a:hprop`, "HA"}; + term equation = `((hp_a:cprop) = hp_b)`; + labeled_term hant = {`hp_a:cprop`, "HA"}; goal g = sl_goal_new((labeled_term_list)vector_create(), - LABELED_TERM_LIST(hant), `hp_b:hprop`); + LABELED_TERM_LIST(hant), `hp_b:cprop`); gnode root = gnode_new(g); gnode applied = HCON_APPLY_SLTAC(root, assume_rule(equation)); AUTO_FRAME_SLTAC(applied); @@ -857,13 +894,13 @@ err: } PROOF static thm prove_hant_conv_multiple_with_frame() { - term old_a = `hp_a:hprop`; - term new_a = `hp_a1:hprop`; - term old_b = `hp_b:hprop`; - term new_b = `hp_b1:hprop`; - term frame = `hp_f:hprop`; - term eq_a = `((hp_a:hprop) = hp_a1)`; - term eq_b = `((hp_b:hprop) = hp_b1)`; + term old_a = `hp_a:cprop`; + term new_a = `hp_a1:cprop`; + term old_b = `hp_b:cprop`; + term new_b = `hp_b1:cprop`; + term frame = `hp_f:cprop`; + term eq_a = `((hp_a:cprop) = hp_a1)`; + term eq_b = `((hp_b:cprop) = hp_b1)`; labeled_term asmp_a = {eq_a, "EA"}; labeled_term asmp_b = {eq_b, "EB"}; @@ -897,7 +934,7 @@ err: PROOF static thm prove_hant_disj_with_frame() { term ccl = - `(((hp_a:hprop) || hp_b) ** hp_f) |-- + `(((hp_a:cprop) || hp_b) ** hp_f) |-- (hp_a ** hp_f) || (hp_b ** hp_f)`; gnode root = gnode_new_with_ccl(ccl); gnode sl = SL_MODE(root, "HD * HF")[0]; @@ -917,23 +954,23 @@ err: PROOF static thm prove_neutral_resource_frame() { gnode root = gnode_new_with_ccl( - `((hp_a:hprop) ** emp) |-- hp_a`); + `((hp_a:cprop) ** emp) |-- hp_a`); gnode sl = SL_MODE(root, "H")[0]; AUTO_FRAME_SLTAC(sl); return gnode_prove(root); } PROOF static thm prove_clean_nested_units() { - labeled_term lhant = {`emp ** ((hp_a:hprop) ** fact(true))`, "H"}; + labeled_term lhant = {`emp ** ((hp_a:cprop) ** fact(true))`, "H"}; goal g = sl_goal_new((labeled_term_list)vector_create(), LABELED_TERM_LIST(lhant), - `fact(true) ** ((hp_a:hprop) ** emp)`); + `fact(true) ** ((hp_a:cprop) ** emp)`); gnode root = gnode_new(g); gnode cleaned = CLEAN_SLTAC(root); labeled_term_list cleaned_hants = goal_lhants(cleaned->g); ENSURE_COND(vector_size(cleaned_hants) == 1 && - equals_term(cleaned_hants[0].tm, `hp_a:hprop`) && - equals_term(goal_hcon(cleaned->g), `hp_a:hprop`), + equals_term(cleaned_hants[0].tm, `hp_a:cprop`) && + equals_term(goal_hcon(cleaned->g), `hp_a:cprop`), "CLEAN_SLTAC did not normalize labeled SL assertions"); AUTO_FRAME_SLTAC(cleaned); return gnode_prove(root); @@ -954,7 +991,7 @@ PROOF static thm prove_emp_nested_units() { PROOF static thm prove_contr_nested_units() { labeled_term lhant = {`emp ** fact(false)`, "H"}; goal g = sl_goal_new((labeled_term_list)vector_create(), - LABELED_TERM_LIST(lhant), `hp_a:hprop`); + LABELED_TERM_LIST(lhant), `hp_a:cprop`); gnode root = gnode_new(g); CONTR_SLTAC(root, "H"); return gnode_prove(root); @@ -1008,8 +1045,8 @@ err: } PROOF static void check_hol_owned_sl_checks() { - term hp_a = `hp_a:hprop`; - term hp_b = `hp_b:hprop`; + term hp_a = `hp_a:cprop`; + term hp_b = `hp_b:cprop`; proof_try_begin(); term truth = mk_true(); @@ -1032,6 +1069,170 @@ PROOF static void check_hol_owned_sl_checks() { ENSURE_COND(bad_trans_failed, "trans_slrule bypassed HOL's composability check"); + term explicit_beta = `(\x:num. (hp_a:cprop)) 0`; + thm beta_left = refl_slrule(explicit_beta); + thm beta_right = refl_slrule(hp_a); + proof_try_begin(); + thm beta_trans = trans_slrule(beta_left, beta_right); + bool beta_trans_rejected = IS_NULL(beta_trans) && NOT_OK; + if (NOT_OK) SET_OK(); + proof_try_end(); + proof_clear_errors(); + ENSURE_COND(beta_trans_rejected, + "trans_slrule accepted merely beta-equivalent endpoints"); + + term beta_between_exists = + `exists x:num. (\z:num. exists y:num. (hp_a:cprop)) x`; + strip_sl_exists_results stripped_beta_exists = + strip_sl_exists(beta_between_exists); + term expected_beta_body = + `(\z:num. exists y:num. (hp_a:cprop)) (x:num)`; + ENSURE_COND(vector_size(stripped_beta_exists.vs) == 1 && + equals_term(stripped_beta_exists.hp, expected_beta_body), + "strip_sl_exists reduced through a head beta-redex"); + + term mono_x = `mono_x:num`; + thm mono_body = refl_slrule(hp_a); + thm exact_exists_mono = exists_mono_slrule(mono_x, mono_body); + term exact_exists_mono_ccl = concl(exact_exists_mono); + dest_binop_results exact_exists_mono_sides = + dest_sl_ent(exact_exists_mono_ccl); + term exact_exists_endpoint = mk_sl_exists(mono_x, hp_a); + ENSURE_COND(equals_term(exact_exists_mono_sides.tm1, + exact_exists_endpoint) && + equals_term(exact_exists_mono_sides.tm2, + exact_exists_endpoint), + "exists_mono_slrule leaked its internal beta-redex syntax"); + + term body = mk_sl_fact(mk_eq(mono_x, mono_x)); + term actual_exists = mk_sl_exists(mono_x, body); + thm exact_left_distribution = + sep_exists_left_slrule(actual_exists, hp_b); + dest_binop_results exact_left_sides = + dest_sl_eq(concl(exact_left_distribution)); + term expected_left = mk_sl_sep(actual_exists, hp_b); + term expected_left_target = + mk_sl_exists(mono_x, mk_sl_sep(body, hp_b)); + ENSURE_COND(equals_term(exact_left_sides.tm1, expected_left) && + equals_term(exact_left_sides.tm2, expected_left_target), + "left existential distribution did not retain exact binder syntax"); + + thm exact_right_distribution = + sep_exists_right_slrule(hp_b, actual_exists); + dest_binop_results exact_right_sides = + dest_sl_eq(concl(exact_right_distribution)); + term expected_right = mk_sl_sep(hp_b, actual_exists); + term expected_right_target = + mk_sl_exists(mono_x, mk_sl_sep(hp_b, body)); + ENSURE_COND(equals_term(exact_right_sides.tm1, expected_right) && + equals_term(exact_right_sides.tm2, expected_right_target), + "right existential distribution did not retain exact binder syntax"); + + term capture_x = `capture_x:num`; + term capture_body = mk_sl_fact(mk_eq(capture_x, `0`)); + term capture_frame = mk_sl_fact(mk_eq(capture_x, `1`)); + term capture_exists = mk_sl_exists(capture_x, capture_body); + + thm capture_left = + sep_exists_left_slrule(capture_exists, capture_frame); + dest_binop_results capture_left_sides = + dest_sl_eq(concl(capture_left)); + dest_binder_results capture_left_target = + dest_sl_exists(capture_left_sides.tm2); + term capture_left_renamed = subst_one( + capture_left_target.v, capture_x, capture_body); + term capture_left_expected_body = + mk_sl_sep(capture_left_renamed, capture_frame); + ENSURE_COND( + equals_term(capture_left_sides.tm1, + mk_sl_sep(capture_exists, capture_frame)) && + !var_free_in(capture_left_target.v, capture_frame) && + alpha_compare(capture_left_target.tm, + capture_left_expected_body) == 0, + "left existential distribution captured a free frame variable"); + + thm capture_right = + sep_exists_right_slrule(capture_frame, capture_exists); + dest_binop_results capture_right_sides = + dest_sl_eq(concl(capture_right)); + dest_binder_results capture_right_target = + dest_sl_exists(capture_right_sides.tm2); + term capture_right_renamed = subst_one( + capture_right_target.v, capture_x, capture_body); + term capture_right_expected_body = + mk_sl_sep(capture_frame, capture_right_renamed); + ENSURE_COND( + equals_term(capture_right_sides.tm1, + mk_sl_sep(capture_frame, capture_exists)) && + !var_free_in(capture_right_target.v, capture_frame) && + alpha_compare(capture_right_target.tm, + capture_right_expected_body) == 0, + "right existential distribution captured a free frame variable"); + + term redex_exists = mk_sl_exists(mono_x, explicit_beta); + term redex_sep = mk_sl_sep(explicit_beta, explicit_beta); + term redex_sep_exists = mk_sl_exists(mono_x, redex_sep); + thm redex_left_distribution = + sep_exists_left_slrule(redex_exists, explicit_beta); + dest_binop_results redex_left_sides = + dest_sl_eq(concl(redex_left_distribution)); + ENSURE_COND( + equals_term(redex_left_sides.tm1, + mk_sl_sep(redex_exists, explicit_beta)) && + equals_term(redex_left_sides.tm2, redex_sep_exists), + "left existential distribution reduced a caller-owned beta-redex"); + + thm redex_right_distribution = + sep_exists_right_slrule(explicit_beta, redex_exists); + dest_binop_results redex_right_sides = + dest_sl_eq(concl(redex_right_distribution)); + ENSURE_COND( + equals_term(redex_right_sides.tm1, + mk_sl_sep(explicit_beta, redex_exists)) && + equals_term(redex_right_sides.tm2, redex_sep_exists), + "right existential distribution reduced a caller-owned beta-redex"); + + thm redex_mono = + exists_mono_slrule(mono_x, refl_slrule(explicit_beta)); + dest_binop_results redex_mono_sides = dest_sl_ent(concl(redex_mono)); + ENSURE_COND(equals_term(redex_mono_sides.tm1, redex_exists) && + equals_term(redex_mono_sides.tm2, redex_exists), + "existential monotonicity reduced a caller-owned beta-redex"); + + term mono_y = `mono_y:num`; + term_list mono_prefix = TERM_LIST(mono_x, mono_y); + thm redex_mono_many = exists_mono_many_slrule( + mono_prefix, refl_slrule(explicit_beta)); + dest_binop_results redex_mono_many_sides = + dest_sl_ent(concl(redex_mono_many)); + term redex_many_exists = list_mk_sl_exists( + mono_prefix, explicit_beta); + ENSURE_COND( + equals_term(redex_mono_many_sides.tm1, redex_many_exists) && + equals_term(redex_mono_many_sides.tm2, redex_many_exists), + "batch existential monotonicity changed binder order or reduced a " + "caller-owned beta-redex"); + + thm redex_intro = + exists_slrule(redex_exists, `0`, refl_slrule(explicit_beta)); + dest_binop_results redex_intro_sides = dest_sl_ent(concl(redex_intro)); + ENSURE_COND(equals_term(redex_intro_sides.tm1, explicit_beta) && + equals_term(redex_intro_sides.tm2, redex_exists), + "existential introduction reduced a caller-owned beta-redex"); + + term choice_y = `choice_y:num`; + thm redex_elim = choose_slrule( + choice_y, redex_exists, refl_slrule(explicit_beta)); + dest_binop_results redex_elim_sides = dest_sl_ent(concl(redex_elim)); + ENSURE_COND(equals_term(redex_elim_sides.tm1, redex_exists) && + alpha_compare(redex_elim_sides.tm2, explicit_beta) == 0, + "existential elimination returned `%s |-- %s`; expected `%s |-- " + "%s`", + string_of_term(redex_elim_sides.tm1), + string_of_term(redex_elim_sides.tm2), + string_of_term(redex_exists), + string_of_term(explicit_beta)); + proof_try_begin(); thm bad_ac = ac_slrule(`x:num`, `x:num`); bool bad_ac_failed = IS_NULL(bad_ac) && NOT_OK; @@ -1086,9 +1287,9 @@ PROOF static void check_backward_sl_rejections() { ENSURE_COND(rejected_general, "An SL tactic accepted a general goal"); - labeled_term lhant = {`hp_a:hprop`, "H"}; + labeled_term lhant = {`hp_a:cprop`, "H"}; goal g = sl_goal_new((labeled_term_list)vector_create(), - LABELED_TERM_LIST(lhant), `hp_a:hprop`); + LABELED_TERM_LIST(lhant), `hp_a:cprop`); gnode sl = gnode_new(g); proof_try_begin(); @@ -1135,6 +1336,8 @@ PROOF int proof_sl_regression() { ENSURE_OK(""); check_dest_sl_fact_operator(); ENSURE_OK(""); + check_sl_binder_recognition(); + ENSURE_OK(""); check_hol_owned_sl_checks(); ENSURE_OK(""); check_backward_sl_rejections(); @@ -1174,9 +1377,9 @@ PROOF int proof_sl_regression() { ENSURE_COND(!IS_NULL(prove_hcon_apply_polymorphic_type_match()), "Polymorphic consequent application regression failed"); ENSURE_OK(""); - term hp_a = `hp_a:hprop`; - term hp_b = `hp_b:hprop`; - term hp_c = `hp_c:hprop`; + term hp_a = `hp_a:cprop`; + term hp_b = `hp_b:cprop`; + term hp_c = `hp_c:cprop`; ENSURE_COND( term_list_is_subset(TERM_LIST(hp_a, hp_a), TERM_LIST(hp_a)), @@ -1285,7 +1488,7 @@ PROOF int proof_sl_regression() { equals_term(alpha_rehcon_sides.tm2, alpha_ex_y), "An alpha endpoint rewrite did not retain caller syntax"); - thm ac = sl_ac_rule(); + thm ac = sl_ac_rule; ENSURE_COND(vector_size(hyp(ac)) == 0, "The AC package unexpectedly has hypotheses"); ENSURE_COND(alpha_compare( @@ -1320,19 +1523,19 @@ PROOF int proof_sl_regression() { thm conjunction = conj_slrule(refl_slrule(hp_a), refl_slrule(hp_a)); ENSURE_COND(alpha_compare(concl(conjunction), - `(hp_a:hprop) |-- hp_a && hp_a`) == 0, + `(hp_a:cprop) |-- hp_a && hp_a`) == 0, "Conjunction introduction produced the wrong entailment"); thm disjunction = disj_mono_slrule(refl_slrule(hp_a), refl_slrule(hp_b)); ENSURE_COND(alpha_compare(concl(disjunction), - `((hp_a:hprop) || hp_b) |-- hp_a || hp_b`) == 0, + `((hp_a:cprop) || hp_b) |-- hp_a || hp_b`) == 0, "Disjunction monotonicity produced the wrong entailment"); thm wand_application = elim_wand_slrule(refl_slrule(mk_sl_wand(hp_a, hp_b))); ENSURE_COND(alpha_compare(concl(wand_application), - `(((hp_a:hprop) -* hp_b) ** hp_a) |-- hp_b`) == 0, + `(((hp_a:cprop) -* hp_b) ** hp_a) |-- hp_b`) == 0, "Magic-wand application produced the wrong entailment"); term joined = mk_sl_sep(hp_a, hp_b); @@ -1359,7 +1562,7 @@ PROOF int proof_sl_regression() { intro_fact_slrule(assume_rule(pure_p), refl_slrule(hp_a))); ENSURE_COND(alpha_compare( concl(preserved_fact), - `fact(pure_p) ** (hp_a:hprop) |-- fact(pure_p) ** hp_a`) == 0, + `fact(pure_p) ** (hp_a:cprop) |-- fact(pure_p) ** hp_a`) == 0, "Fact introduction/elimination composition produced the wrong entailment"); term value = `value0:int`; @@ -1560,8 +1763,6 @@ PROOF int proof_sl_regression() { !IS_NULL(contr_nested_units) && !IS_NULL(disj_branch_fact_independence), "An SL backward tactic regression returned an empty theorem"); - ENSURE_COND(!IS_NULL(sl_exists_mono()), - "Existential monotonicity depended on implicit variable types"); set_the_implicit_types(previous_implicit_types); return 0; err: diff --git a/test/ra_core_regression.c b/test/ra_core_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..e9344f259b04d9f39688a0b84a7845f3300aaae8 --- /dev/null +++ b/test/ra_core_regression.c @@ -0,0 +1,291 @@ +#include "proof/theory/logic/ra.h" +#include "proof/theory/logic/local_update.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" +#require "proof/theory/logic/local_update.c" + +PROOF static void check_ra_core_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_ra_core_theorem", label); +} + +PROOF static thm ra_core_at_num(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("ra_core_at_num"); + return empty_theorem; +} + +/* A frame-maximal source is valid by construction. */ +PROOF static thm prove_maximal_source_valid(void) { + term goal_tm = ` + forall (R:(num)ra) (a:num). + ra_maximal R a ==> ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R:(num)ra) (a:num)`)); + ACCEPT_TAC(body, conjunct1_rule(maximal)); + return gnode_prove(root); +} + +/* Regression against invalid-source vacuity in frame-maximality. */ +PROOF static thm prove_invalid_source_not_maximal(void) { + term goal_tm = ` + forall (R:(num)ra) (a:num). + ~(ra_valid R a) ==> ~(ra_maximal R a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R:(num)ra) (a:num)`)); + CONTR_TAC( + body, + not_elim_rule( + assume_rule(`~(ra_valid (R:(num)ra) (a:num))`), + conjunct1_rule(maximal))); + return gnode_prove(root); +} + +PROOF static int audit_ra_core_regressions(void) { + term R = `R:(num)ra`; + term a = `a:num`; + term b = `b:num`; + term c = `c:num`; + term d = `d:num`; + term f = `f:num`; + term g = `g:num`; + term h = `h:num`; + term extra = `extra:num`; + term P = `P:num->bool`; + term Q = `Q:num->bool`; + + check_ra_core_theorem( + ra_core_at_num(ra_compatible_def), + `ra_compatible (R:(num)ra) (a:num) (b:num) <=> + ra_valid R (ra_op R a b)`, + "ra_compatible_def"); + + check_ra_core_theorem( + ra_core_at_num(ra_included_def), + `ra_included (R:(num)ra) (a:num) (b:num) <=> + exists frame:num. b == ra_op R a frame`, + "ra_included_def"); + + check_ra_core_theorem( + ra_core_at_num(ra_updateP_def), + `ra_updateP (R:(num)ra) (a:num) (result:num->bool) <=> + forall frame:num. + ra_valid R (ra_op R a frame) ==> + exists b:num. result b && ra_valid R (ra_op R b frame)`, + "ra_updateP_def"); + + check_ra_core_theorem( + ra_core_at_num(ra_update_def), + `ra_update (R:(num)ra) (a:num) (b:num) <=> + ra_updateP R a (\x:num. x == b)`, + "ra_update_def"); + + check_ra_core_theorem( + ra_core_at_num(ra_maximal_def), + `ra_maximal (R:(num)ra) (a:num) <=> + ra_valid R a && + (forall frame:num. + ra_valid R (ra_op R a frame) ==> + frame == ra_unit R)`, + "ra_maximal_def"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, b), ra_compat_comm), + `ra_compatible (R:(num)ra) (a:num) (b:num) <=> + ra_compatible R b a`, + "ra_compat_comm"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a), ra_compat_unit), + `ra_compatible (R:(num)ra) (a:num) (ra_unit R) <=> + ra_valid R a`, + "ra_compat_unit"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, b), ra_updateP_singleton), + `ra_updateP (R:(num)ra) (a:num) (\x:num. x == b) <=> + ra_update R a (b:num)`, + "ra_updateP_singleton"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, P, Q), ra_updateP_mono), + `ra_updateP (R:(num)ra) (a:num) (P:num->bool) ==> + (forall b:num. P b ==> Q b) ==> + ra_updateP R a Q`, + "ra_updateP_mono"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, P, Q), ra_updateP_trans), + `ra_updateP (R:(num)ra) (a:num) (P:num->bool) ==> + (forall b:num. P b ==> ra_updateP R b Q) ==> + ra_updateP R a Q`, + "ra_updateP_trans"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, P, extra), ra_updateP_frame), + `ra_updateP (R:(num)ra) (a:num) (P:num->bool) ==> + ra_updateP R (ra_op R a (extra:num)) + (\x:num. exists b:num. P b && x == ra_op R b extra)`, + "ra_updateP_frame"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, c, P, Q), ra_updateP_op), + `ra_updateP (R:(num)ra) (a:num) (P:num->bool) ==> + ra_updateP R (c:num) (Q:num->bool) ==> + ra_updateP R (ra_op R a c) + (\x:num. + exists b d:num. + P b && Q d && x == ra_op R b d)`, + "ra_updateP_op"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, b, extra), ra_update_frame), + `ra_update (R:(num)ra) (a:num) (b:num) ==> + ra_update R (ra_op R a (extra:num)) (ra_op R b extra)`, + "ra_update_frame"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, b, c, d), ra_update_op), + `ra_update (R:(num)ra) (a:num) (b:num) ==> + ra_update R (c:num) (d:num) ==> + ra_update R (ra_op R a c) (ra_op R b d)`, + "ra_update_op"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, b), ra_maximal_update), + `ra_maximal (R:(num)ra) (a:num) ==> + ra_valid R (b:num) ==> + ra_update R a b`, + "ra_maximal_update"); + + check_ra_core_theorem( + prove_maximal_source_valid(), + `forall (R:(num)ra) (a:num). + ra_maximal R a ==> ra_valid R a`, + "maximal source validity"); + + check_ra_core_theorem( + prove_invalid_source_not_maximal(), + `forall (R:(num)ra) (a:num). + ~(ra_valid R a) ==> ~(ra_maximal R a)`, + "invalid source is not maximal"); + + check_ra_core_theorem( + ra_core_at_num(ra_local_update_def), + `ra_local_update (R:(num)ra) (a:num) (f:num) (b:num) (g:num) <=> + forall residual:num. + ra_valid R a ==> + a == ra_op R f residual ==> + ra_valid R b && b == ra_op R g residual`, + "ra_local_update_def"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g, extra), + ra_local_update_apply), + `ra_local_update (R:(num)ra) (a:num) (f:num) (b:num) (g:num) ==> + ra_valid R a ==> + a == ra_op R f (extra:num) ==> + ra_valid R b && b == ra_op R g extra`, + "ra_local_update_apply"); + + check_ra_core_theorem( + ispecl_rule(TERM_LIST(R, a, f), ra_local_update_refl), + `ra_local_update (R:(num)ra) (a:num) (f:num) a f`, + "ra_local_update_refl"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g, c, h), + ra_local_update_trans), + `ra_local_update (R:(num)ra) (a:num) (f:num) (b:num) (g:num) ==> + ra_local_update R b g (c:num) (h:num) ==> + ra_local_update R a f c h`, + "ra_local_update_trans"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g, extra), + ra_local_update_frame), + `ra_local_update (R:(num)ra) (a:num) (f:num) (b:num) (g:num) ==> + ra_local_update R a (ra_op R f (extra:num)) b (ra_op R g extra)`, + "ra_local_update_frame"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b, g, extra), + ra_local_update_preserves_included), + `ra_local_update (R:(num)ra) (a:num) (f:num) (b:num) (g:num) ==> + ra_valid R a ==> + ra_included R (ra_op R f (extra:num)) a ==> + ra_valid R b && ra_included R (ra_op R g extra) b`, + "ra_local_update_preserves_included"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, extra), + ra_local_update_alloc), + `ra_valid (R:(num)ra) (ra_op R (a:num) (extra:num)) ==> + ra_local_update R a (f:num) (ra_op R a extra) (ra_op R f extra)`, + "ra_local_update_alloc"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, f, b), + ra_local_update_maximal), + `ra_maximal (R:(num)ra) (f:num) ==> + ra_valid R (b:num) ==> + ra_local_update R (a:num) f b b`, + "ra_local_update_maximal"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, extra, a, f), + ra_local_update_cancel), + `ra_cancellative (R:(num)ra) ==> + ra_local_update R + (ra_op R (extra:num) (a:num)) + (ra_op R extra (f:num)) + a f`, + "ra_local_update_cancel"); + + check_ra_core_theorem( + ispecl_rule( + TERM_LIST(R, a, b, extra), + ra_local_update_cancellative), + `ra_cancellative (R:(num)ra) ==> + ra_valid R (ra_op R (b:num) (extra:num)) ==> + ra_local_update R + (ra_op R (a:num) extra) a + (ra_op R b extra) b`, + "ra_local_update_cancellative"); + return 0; +} + +PROOF static int _RA_CORE_REGRESSION = + audit_ra_core_regressions(); diff --git a/test/sl_v2_regression.c b/test/sl_v2_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..9d8b865cc7228142ac3b21ce5b790bcab883c5b3 --- /dev/null +++ b/test/sl_v2_regression.c @@ -0,0 +1,150 @@ +#include "proof/theory/logic/big_sep.h" +#include "proof/theory/logic/product_resource.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/big_sep.c" +#require "proof/theory/logic/product_resource.c" + +PROOF static void check_sl_v2_theorem(const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_sl_v2_theorem", label); +} + +PROOF static thm sl_v2_at_num(const thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one assertion carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("sl_v2_at_num"); + return empty_theorem; +} + +PROOF static int audit_sl_v2_regressions(void) { + term R = `R:(num)ra`; + term S = `S:(bool)ra`; + term phi = `phi:bool`; + term resource = `resource:num`; + term a = `a:bool`; + term result_pred = `result_pred:bool->bool`; + term assertion = `P:(num#bool)->bool`; + term target = `Q:(num#bool)->bool`; + term family = `Phi:num->(num#bool)->bool`; + term target_family = `Psi:num->(num#bool)->bool`; + + /* The user override intentionally keeps these two notions distinct. */ + check_sl_v2_theorem( + sl_v2_at_num(r_pure_def), + `r_pure (R:(num)ra) (phi:bool) (resource:num) <=> phi`, + "r_pure remains resource-independent"); + check_sl_v2_theorem( + sl_v2_at_num(r_fact_def), + `r_fact (R:(num)ra) (phi:bool) (resource:num) <=> + phi && resource == ra_unit R`, + "r_fact remains exact-unit"); + + check_sl_v2_theorem( + ispecl_rule( + TERM_LIST( + `R:(num)ra`, + `S:(bool)ra`, + `a:bool`, + `result_pred:bool->bool`), + r_right_own_updateP), + `ra_updateP (S:(bool)ra) (a:bool) (result_pred:bool->bool) ==> + r_viewshift_right + (R:(num)ra) S + (r_lift_right R S (r_own S a)) + (r_exists + (prod_ra R S) + (\selected:bool. + r_sep + (prod_ra R S) + (r_fact (prod_ra R S) (result_pred selected)) + (r_lift_right R S (r_own S selected))))`, + "r_right_own_updateP uses exact-unit fact"); + + check_sl_v2_theorem( + ispecl_rule( + TERM_LIST( + R, + S, + phi, + assertion, + target), + r_viewshift_right_fact), + `((phi:bool) ==> + r_viewshift_right + (R:(num)ra) (S:(bool)ra) + (P:(num#bool)->bool) + (Q:(num#bool)->bool)) ==> + r_viewshift_right + R S + (r_sep + (prod_ra R S) + (r_fact (prod_ra R S) phi) + P) + (r_sep + (prod_ra R S) + (r_fact (prod_ra R S) phi) + Q)`, + "r_viewshift_right_fact schema"); + + check_sl_v2_theorem( + ispecl_rule( + TERM_LIST(R, S, family, target_family), + r_viewshift_right_exists), + `(forall witness:num. + r_viewshift_right + (R:(num)ra) (S:(bool)ra) + ((Phi:num->(num#bool)->bool) witness) + ((Psi:num->(num#bool)->bool) witness)) ==> + r_viewshift_right + R S + (r_exists + (prod_ra R S) + (\bound:num. (Phi:num->(num#bool)->bool) bound)) + (r_exists + (prod_ra R S) + (\bound:num. (Psi:num->(num#bool)->bool) bound))`, + "r_viewshift_right_exists schema"); + + check_sl_v2_theorem( + ispecl_rule( + TERM_LIST( + `R:(num)ra`, + `Item:bool->num->bool`, + `f:num->bool`, + `xs:(num)list`), + r_big_sep_list_map), + `r_equiv + (R:(num)ra) + (r_big_sep_list + R + (Item:bool->num->bool) + (MAP (f:num->bool) (xs:(num)list))) + (r_big_sep_list + R + (\x:num. (Item:bool->num->bool) (f x)) + xs)`, + "r_big_sep_list_map is list-only and r_equiv"); + + return 0; +err: + ERR_FUN_PUTS("audit_sl_v2_regressions"); + return -1; +} + +PROOF static int _SL_V2_REGRESSION_AUDIT = + audit_sl_v2_regressions(); diff --git a/test/value_ra_constructors_regression.c b/test/value_ra_constructors_regression.c new file mode 100644 index 0000000000000000000000000000000000000000..31c78bafecc095e8fac74e396830d76a6a794794 --- /dev/null +++ b/test/value_ra_constructors_regression.c @@ -0,0 +1,289 @@ +#include "proof/theory/logic/agree_ra.h" +#include "proof/theory/logic/frac_ra.h" +#include "proof/theory/logic/max_nat_ra.h" +#include "proof/theory/logic/option_ra.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/agree_ra.c" +#require "proof/theory/logic/frac_ra.c" +#require "proof/theory/logic/max_nat_ra.c" +#require "proof/theory/logic/option_ra.c" + +PROOF static void check_value_ra_theorem( + const thm theorem, + const term expected, + const char *label) { + ENSURE_COND(!IS_NULL(theorem), "%s is empty", label); + ENSURE_COND(vector_size(hyp(theorem)) == 0, + "%s unexpectedly has hypotheses", label); + ENSURE_COND(alpha_compare(concl(theorem), expected) == 0, + "%s has the wrong conclusion", label); + return; +err: + ERR_FUN_PUTS("check_value_ra_theorem", label); +} + +PROOF static thm value_ra_at_num(thm theorem) { + type_list variables = term_tyvars(concl(theorem)); + ENSURE_COND(vector_size(variables) == 1, + "expected exactly one carrier type variable"); + type_pair_list types = (type_pair_list)vector_create(); + vector_add(&types, ((type_pair){`:num`, variables[0]})); + return inst_type_rule(types, theorem); +err: + ERR_FUN_PUTS("value_ra_at_num"); + return empty_theorem; +} + +PROOF static int audit_agree_constructor_regressions(void) { + check_value_ra_theorem( + agree_ra_unit, + `ra_unit agree_ra == (AgreeUnit:(A)agree)`, + "agree_ra_unit"); + check_value_ra_theorem( + agree_ra_owned_op, + `forall a b:A. + ra_op agree_ra (Agree a) (Agree b) == + (if a == b then Agree a else (AgreeInvalid:(A)agree))`, + "agree_ra_owned_op"); + check_value_ra_theorem( + agree_ra_idempotent, + `forall a:A. + ra_op agree_ra (Agree a) (Agree a) == (Agree a:(A)agree)`, + "agree_ra_idempotent"); + check_value_ra_theorem( + agree_ra_valid_unit, + `ra_valid agree_ra (AgreeUnit:(A)agree)`, + "agree_ra_valid_unit"); + check_value_ra_theorem( + agree_ra_valid_owned, + `forall a:A. ra_valid agree_ra (Agree a)`, + "agree_ra_valid_owned"); + check_value_ra_theorem( + agree_ra_invalid, + `~(ra_valid agree_ra (AgreeInvalid:(A)agree))`, + "agree_ra_invalid"); + check_value_ra_theorem( + agree_ra_valid_combine_iff, + `forall a b:A. + ra_valid agree_ra (ra_op agree_ra (Agree a) (Agree b)) <=> + a == b`, + "agree_ra_valid_combine_iff"); + check_value_ra_theorem( + agree_ra_agreement, + `forall a b:A. + ra_compatible agree_ra (Agree a) (Agree b) ==> a == b`, + "agree_ra_agreement"); + check_value_ra_theorem( + agree_ra_included_owned, + `forall a b:A. + ra_included agree_ra (Agree a) (Agree b) <=> a == b`, + "agree_ra_included_owned"); + check_value_ra_theorem( + agree_ra_not_cancellative, + `~(ra_cancellative (agree_ra:((A)agree)ra))`, + "agree_ra_not_cancellative"); + check_value_ra_theorem( + agree_ra_update_iff, + `forall a b:A. + ra_update agree_ra (Agree a) (Agree b) <=> a == b`, + "agree_ra_update_iff"); + check_value_ra_theorem( + agree_ra_local_update_iff, + `forall a b:A. + ra_local_update agree_ra + (Agree a) (Agree a) (Agree b) (Agree b) <=> + a == b`, + "agree_ra_local_update_iff"); + return 0; +} + +PROOF static int audit_frac_constructor_regressions(void) { + check_value_ra_theorem( + frac_ra_unit, + `forall R:(A)ra. + ra_unit (frac_ra R) == (frac_empty:(A)frac)`, + "frac_ra_unit"); + check_value_ra_theorem( + frac_ra_full, + `forall a:A. frac_full a == frac_own (&1) a`, + "frac_ra_full"); + check_value_ra_theorem( + frac_ra_own_op, + `forall (R:(A)ra) (p:real) (q:real) (a:A) (b:A). + &0 < p ==> + &0 < q ==> + ra_op (frac_ra R) (frac_own p a) (frac_own q b) == + frac_own (p + q) (ra_op R a b)`, + "frac_ra_own_op"); + check_value_ra_theorem( + frac_ra_valid_own, + `forall (R:(A)ra) (p:real) (a:A). + &0 < p ==> + (ra_valid (frac_ra R) (frac_own p a) <=> + p <= &1 && ra_valid R a)`, + "frac_ra_valid_own"); + check_value_ra_theorem( + frac_ra_maximal_full, + `forall (R:(A)ra) (a:A). + ra_valid R a ==> + ra_maximal (frac_ra R) (frac_full a)`, + "frac_ra_maximal_full"); + check_value_ra_theorem( + frac_ra_update_weaken, + `forall (R:(A)ra) (p:real) (q:real) (a:A) (b:A). + &0 < q ==> + q <= p ==> + ra_update R a b ==> + ra_update + (frac_ra R) + (frac_own p a) + (frac_own q b)`, + "frac_ra_update_weaken"); + check_value_ra_theorem( + frac_ra_updateP_weaken, + `forall (R:(A)ra) (p:real) (q:real) (a:A) (P:A->bool). + &0 < q ==> + q <= p ==> + ra_updateP R a P ==> + ra_updateP + (frac_ra R) + (frac_own p a) + (\x:(A)frac. + exists b:A. P b && x == frac_own q b)`, + "frac_ra_updateP_weaken"); + check_value_ra_theorem( + frac_ra_update_full_iff, + `forall (R:(A)ra) (a:A) (b:A). + (ra_update + (frac_ra R) + (frac_full a) + (frac_full b) <=> + (ra_valid R a ==> ra_valid R b))`, + "frac_ra_update_full_iff"); + return 0; +} + +PROOF static int audit_option_constructor_regressions(void) { + check_value_ra_theorem( + option_ra_unit, + `forall R:(A)ra. ra_unit (option_ra R) == (NONE:A option)`, + "option_ra_unit"); + check_value_ra_theorem( + option_ra_op_none_l, + `forall (R:(A)ra) (x:A option). + ra_op (option_ra R) NONE x == x`, + "option_ra_op_none_l"); + check_value_ra_theorem( + option_ra_op_some_some, + `forall (R:(A)ra) (a:A) (b:A). + ra_op (option_ra R) (SOME a) (SOME b) == + SOME (ra_op R a b)`, + "option_ra_op_some_some"); + check_value_ra_theorem( + option_ra_valid_none, + `forall R:(A)ra. ra_valid (option_ra R) (NONE:A option)`, + "option_ra_valid_none"); + check_value_ra_theorem( + option_ra_valid_some, + `forall (R:(A)ra) (a:A). + ra_valid (option_ra R) (SOME a) <=> ra_valid R a`, + "option_ra_valid_some"); + check_value_ra_theorem( + option_ra_included_none, + `forall (R:(A)ra) (x:A option). + ra_included (option_ra R) NONE x`, + "option_ra_included_none"); + check_value_ra_theorem( + option_ra_included_some_some, + `forall (R:(A)ra) (a:A) (b:A). + ra_included (option_ra R) (SOME a) (SOME b) <=> + ra_included R a b`, + "option_ra_included_some_some"); + check_value_ra_theorem( + option_ra_not_included_some_none, + `forall (R:(A)ra) (a:A). + ~(ra_included (option_ra R) (SOME a) NONE)`, + "option_ra_not_included_some_none"); + check_value_ra_theorem( + option_ra_some_unit_ne_none, + `forall R:(A)ra. ~((SOME (ra_unit R):A option) == NONE)`, + "option_ra_some_unit_ne_none"); + check_value_ra_theorem( + option_ra_not_cancellative, + `forall R:(A)ra. + ~(ra_cancellative (option_ra R))`, + "option_ra_not_cancellative"); + check_value_ra_theorem( + option_ra_updateP_iff, + `forall (R:(A)ra) (a:A) (P:A->bool). + ra_updateP + (option_ra R) + (SOME a) + (\x:A option. exists b:A. P b && x == SOME b) <=> + ra_updateP R a P`, + "option_ra_updateP_iff"); + check_value_ra_theorem( + option_ra_update_iff, + `forall (R:(A)ra) (a:A) (b:A). + ra_update (option_ra R) (SOME a) (SOME b) <=> + ra_update R a b`, + "option_ra_update_iff"); + check_value_ra_theorem( + option_ra_local_update_iff, + `forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + ra_local_update + (option_ra R) + (SOME a) (SOME f) (SOME b) (SOME g) <=> + ra_local_update R a f b g`, + "option_ra_local_update_iff"); + return 0; +} + +PROOF static int audit_max_nat_constructor_regressions(void) { + check_value_ra_theorem( + max_nat_ra_unit, + `ra_unit max_nat_ra == 0`, + "max_nat_ra_unit"); + check_value_ra_theorem( + max_nat_ra_op, + `forall a b:num. ra_op max_nat_ra a b == MAX a b`, + "max_nat_ra_op"); + check_value_ra_theorem( + max_nat_ra_valid, + `forall n:num. ra_valid max_nat_ra n`, + "max_nat_ra_valid"); + check_value_ra_theorem( + max_nat_ra_included, + `forall a b:num. + ra_included max_nat_ra a b <=> a <= b`, + "max_nat_ra_included"); + check_value_ra_theorem( + max_nat_ra_idempotent, + `forall n:num. ra_op max_nat_ra n n == n`, + "max_nat_ra_idempotent"); + check_value_ra_theorem( + max_nat_ra_update, + `forall a b:num. ra_update max_nat_ra a b`, + "max_nat_ra_update"); + return 0; +} + +PROOF static int audit_value_ra_constructor_regressions(void) { + ENSURE_COND(audit_agree_constructor_regressions() == 0, + "agreement constructor regressions failed"); + ENSURE_COND(audit_frac_constructor_regressions() == 0, + "fractional constructor regressions failed"); + ENSURE_COND(audit_option_constructor_regressions() == 0, + "option constructor regressions failed"); + ENSURE_COND(audit_max_nat_constructor_regressions() == 0, + "max-nat constructor regressions failed"); + return 0; +err: + ERR_FUN_PUTS("audit_value_ra_constructor_regressions"); + return -1; +} + +PROOF static int _VALUE_RA_CONSTRUCTORS_REGRESSION = + audit_value_ra_constructor_regressions(); diff --git a/theory/c_program_logic/c_basic_update.c b/theory/c_program_logic/c_basic_update.c new file mode 100644 index 0000000000000000000000000000000000000000..0d2e19af00858e48200deaf97688e920ddd8a106 --- /dev/null +++ b/theory/c_program_logic/c_basic_update.c @@ -0,0 +1,96 @@ +#include "proof/theory/c_program_logic/c_basic_update.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/c_resource.c" + +PROOF static size_t C_BASIC_UPDATE_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm c_bupd_def = new_fun_definition(` + c_bupd + (G:(A)ra) = + r_bupd_right mem_ra G +`); + +PROOF thm c_viewshift_def = new_fun_definition(` + c_viewshift + (G:(A)ra) = + r_viewshift_right mem_ra G +`); + +PROOF static thm prove_c_bupd_preserves_phys(void) { + gnode root = gnode_new_with_ccl(` + forall + (G:(A)ra) + (Q:(((int,(pmem_byte_state)excl)finmap)#A)->bool) + (resource:((int,(pmem_byte_state)excl)finmap)#A). + ra_valid (c_resource_ra G) resource ==> + c_bupd G Q resource ==> + exists ghost':A. Q (FST resource,ghost') + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + c_resource_ra_def, + c_bupd_def, + r_bupd_right_def, + prod_ra_valid))); + body = GEN_TAC(body, "G"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hupdate"); + + thm ghost_valid = conjunct2_rule( + assume_rule(` + ra_valid mem_ra + (FST (resource:((int,(pmem_byte_state)excl)finmap)#A)) && + ra_valid (G:(A)ra) (SND resource) + `)); + term_list update_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hupdate")); + thm result = match_mp_rule( + ra_updateP_valid, + assume_rule(update_terms[0])); + result = match_mp_rule(result, ghost_valid); + result = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + result); + body = ASSUME_TAC(body, result, "Hresult"); + body = ASMP_EXISTS_TAC(body, "Hresult", "ghost'"); + body = ASMP_CONJ_TAC(body, "Hresult", "Hpost", "Hvalid_result"); + term_list post_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hpost")); + body = EXISTS_TAC(body, `ghost':A`); + ACCEPT_TAC( + body, + assume_rule(post_terms[0])); + return gnode_prove(root); +} + +PROOF thm c_bupd_preserves_phys = + prove_c_bupd_preserves_phys(); + +PROOF static int audit_c_basic_update(void) { + thm_list public_theorems = THM_LIST( + c_bupd_def, + c_viewshift_def, + c_bupd_preserves_phys); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "C update theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "C update theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == C_BASIC_UPDATE_AXIOMS_BEFORE, + "C update theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_c_basic_update"); + return -1; +} + +PROOF static int _C_BASIC_UPDATE_AUDIT = audit_c_basic_update(); diff --git a/theory/c_program_logic/c_basic_update.h b/theory/c_program_logic/c_basic_update.h new file mode 100644 index 0000000000000000000000000000000000000000..6f8a12b3344f8e18213e4688c6d1a805fc706555 --- /dev/null +++ b/theory/c_program_logic/c_basic_update.h @@ -0,0 +1,49 @@ +/** + * @file c_basic_update.h + * @brief Ghost-only updates for the complete C resource. + * + * These aliases specialize the generic product modality to + * `c_resource_ra G == prod_ra mem_ra G`. A C view shift may update only the + * complete global ghost projection `G`; it cannot perform an algebraic update + * of physical memory. Physical-memory changes remain the responsibility of + * certified C command semantics. + */ + +#pragma once + +#include "proof/theory/c_program_logic/c_resource.h" + +/** + * ```text + * c_bupd (G:(A)ra) == r_bupd_right mem_ra G + * ``` + * + * `c_bupd G` 是完整 C 资源上的右侧 basic update：物理内存固定，仅允许 ghost 分量按 `G` 更新。 + */ +PROOF extern thm c_bupd_def; + +/** + * ```text + * c_viewshift (G:(A)ra) == r_viewshift_right mem_ra G + * ``` + * + * `c_viewshift G` 是完整 C 资源上的右侧 view shift，其代数更新能力只作用于 ghost 分量。 + */ +PROOF extern thm c_viewshift_def; + +/** + * Safety boundary for valid sources: + * + * ```text + * forall + * (G:(A)ra) + * (Q:(((int,(pmem_byte_state)excl)finmap)#A)->bool) + * (resource:((int,(pmem_byte_state)excl)finmap)#A). + * ra_valid (c_resource_ra G) resource ==> + * c_bupd G Q resource ==> + * exists ghost':A. Q (FST resource,ghost') + * ``` + * + * 若有效资源满足 `c_bupd G Q`，则 `Q` 接受某个物理投影仍为 `FST resource`、仅 ghost 投影改变的目标资源。 + */ +PROOF extern thm c_bupd_preserves_phys; diff --git a/theory/c_program_logic/c_fnspec.c b/theory/c_program_logic/c_fnspec.c new file mode 100644 index 0000000000000000000000000000000000000000..fae39bb05dbffe6bf02a3d5c73a0a87c5ae6b1ad --- /dev/null +++ b/theory/c_program_logic/c_fnspec.c @@ -0,0 +1,73 @@ +#include "proof/theory/c_program_logic/c_fnspec.h" + +#require "proof/theory/c_program_logic/c_resource.c" +#require "proof/theory/c_program_logic/c_types.c" + +PROOF static size_t C_FNSPEC_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static int c_fnspec_declare_markers(void) { + type cell_type = mk_var_type("A"); + type parameter_type = mk_var_type("B"); + type int_type = mk_int_type(); + type bool_type = mk_bool_type(); + + type_list nullary_arguments = empty_list(type); + type byte_state_type = + mk_app_type("pmem_byte_state", nullary_arguments); + type ctype_type = mk_app_type("ctype", nullary_arguments); + + type_list excl_arguments = empty_list(type); + vector_add(&excl_arguments, byte_state_type); + type byte_ownership_type = mk_app_type("excl", excl_arguments); + + type_list memory_arguments = empty_list(type); + vector_add(&memory_arguments, int_type); + vector_add(&memory_arguments, byte_ownership_type); + type memory_type = mk_app_type("finmap", memory_arguments); + + /* G is the complete global ghost RA, so its carrier is A itself. */ + type resource_type = mk_prod_type(memory_type, cell_type); + type assertion_type = mk_fun_type(resource_type, bool_type); + + type_list ra_arguments = empty_list(type); + vector_add(&ra_arguments, cell_type); + type ghost_ra_type = mk_app_type("ra", ra_arguments); + + type fnspec_post_type = mk_fun_type(assertion_type, assertion_type); + type fnspec_pre_type = mk_fun_type(assertion_type, fnspec_post_type); + type fnspec_ctype_type = mk_fun_type(ctype_type, fnspec_pre_type); + type fnspec_subject_type = mk_fun_type(int_type, fnspec_ctype_type); + type fnspec_type = mk_fun_type(ghost_ra_type, fnspec_subject_type); + new_const("c_fnspec", fnspec_type); + + type assertion_family_type = + mk_fun_type(parameter_type, assertion_type); + type fnspec_w_post_type = + mk_fun_type(assertion_family_type, assertion_type); + type fnspec_w_pre_type = + mk_fun_type(assertion_family_type, fnspec_w_post_type); + type fnspec_w_ctype_type = mk_fun_type(ctype_type, fnspec_w_pre_type); + type fnspec_w_subject_type = + mk_fun_type(int_type, fnspec_w_ctype_type); + type fnspec_w_type = + mk_fun_type(ghost_ra_type, fnspec_w_subject_type); + new_const("c_fnspec_w", fnspec_w_type); + + type installed_fnspec_type = get_const_type("c_fnspec"); + type installed_fnspec_w_type = get_const_type("c_fnspec_w"); + ENSURE_COND(equals_type(installed_fnspec_type, fnspec_type), + "installed c_fnspec marker has the wrong exact type"); + ENSURE_COND(equals_type(installed_fnspec_w_type, fnspec_w_type), + "installed c_fnspec_w marker has the wrong exact type"); + + ENSURE_COND(vector_size(get_all_axioms()) == C_FNSPEC_AXIOMS_BEFORE, + "C function-specification markers introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("c_fnspec_declare_markers"); + return -1; +} + +PROOF static int _C_FNSPEC_MARKERS_DECLARED = + c_fnspec_declare_markers(); diff --git a/theory/c_program_logic/c_fnspec.h b/theory/c_program_logic/c_fnspec.h new file mode 100644 index 0000000000000000000000000000000000000000..5da714267f0b1ae5d33878cc8375f099be2f569a --- /dev/null +++ b/theory/c_program_logic/c_fnspec.h @@ -0,0 +1,29 @@ +/** + * @file c_fnspec.h + * @brief Generic markers for QCP function-pointer specifications. + * + * For `G:(A)ra`, the implementation declares the opaque constants + * + * ```text + * c_fnspec G : + * int -> ctype -> Prop_G -> Prop_G -> Prop_G + * + * c_fnspec_w G : + * int -> ctype -> (B -> Prop_G) -> (B -> Prop_G) -> Prop_G + * ``` + * + * where `Prop_G = carrier(c_resource_ra G) -> bool` and `G` denotes the whole + * global ghost algebra, not a payload RA hidden under an implicit name map. + * The markers are deliberately opaque: their operational meaning belongs to + * the certified C-logic/QCP boundary, not to an RA or BI equation. + * + * The named-resource installer `c_logic_install_named(R)` explicitly selects + * `G = named_ra R`, creates scoped `fnspec`/`fnspec_w` aliases, and includes + * them in its immutable runtime descriptor. This header declares no theorem + * equations for the two opaque markers. + */ + +#pragma once + +#include "proof/theory/c_program_logic/c_resource.h" +#include "proof/theory/c_program_logic/c_types.h" diff --git a/theory/c_program_logic/c_ghost.c b/theory/c_program_logic/c_ghost.c new file mode 100644 index 0000000000000000000000000000000000000000..81dd5587ec9ea327a3d6d46086c17d973d0fc222 --- /dev/null +++ b/theory/c_program_logic/c_ghost.c @@ -0,0 +1,875 @@ +#include "proof/theory/c_program_logic/c_ghost.h" +#include "proof/theory/logic/gmap_ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/c_basic_update.c" +#require "proof/theory/logic/named_ra.c" + +PROOF static size_t C_GHOST_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm prove_c_ghost_own_op(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (a:A) (b:A). + r_equiv + (c_resource_ra G) + (c_ghost_own G (ra_op G a b)) + (r_sep + (c_resource_ra G) + (c_ghost_own G a) + (c_ghost_own G b)) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + c_resource_ra_def, + c_ghost_own_def, + c_lift_ghost_def))); + + thm own_equiv = rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST(`G:(A)ra`, `a:A`, `b:A`), + r_own_op)); + thm own_forward = conjunct1_rule(own_equiv); + thm own_reverse = conjunct2_rule(own_equiv); + thm lifted_forward = mp_rule( + ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `r_own G (ra_op G (a:A) (b:A))`, + `r_sep G (r_own G (a:A)) (r_own G (b:A))`), + r_lift_right_entails), + own_forward); + thm lifted_reverse = mp_rule( + ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `r_sep G (r_own G (a:A)) (r_own G (b:A))`, + `r_own G (ra_op G (a:A) (b:A))`), + r_lift_right_entails), + own_reverse); + thm sep_equiv = rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `r_own G (a:A)`, `r_own G (b:A)`), + r_lift_right_sep)); + thm sep_forward = conjunct1_rule(sep_equiv); + thm sep_reverse = conjunct2_rule(sep_equiv); + + thm forward = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra mem_ra (G:(A)ra)`, + `r_lift_right mem_ra G + (r_own G (ra_op G (a:A) (b:A)))`, + `r_lift_right mem_ra G + (r_sep G (r_own G (a:A)) (r_own G (b:A)))`, + `r_sep (prod_ra mem_ra G) + (r_lift_right mem_ra G (r_own G (a:A))) + (r_lift_right mem_ra G (r_own G (b:A)))`), + r_entails_trans), + lifted_forward), + sep_forward); + thm reverse = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra mem_ra (G:(A)ra)`, + `r_sep (prod_ra mem_ra G) + (r_lift_right mem_ra G (r_own G (a:A))) + (r_lift_right mem_ra G (r_own G (b:A)))`, + `r_lift_right mem_ra G + (r_sep G (r_own G (a:A)) (r_own G (b:A)))`, + `r_lift_right mem_ra G + (r_own G (ra_op G (a:A) (b:A)))`), + r_entails_trans), + sep_reverse), + lifted_reverse); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra mem_ra (G:(A)ra)`, + `r_lift_right mem_ra G + (r_own G (ra_op G (a:A) (b:A)))`, + `r_sep (prod_ra mem_ra G) + (r_lift_right mem_ra G (r_own G (a:A))) + (r_lift_right mem_ra G (r_own G (b:A)))`), + r_equiv_intro), + forward), + reverse); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_ghost_own_op = prove_c_ghost_own_op(); + +PROOF static thm prove_c_ghost_own_valid(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (a:A). + r_entails + (c_resource_ra G) + (c_ghost_own G a) + (r_sep + (c_resource_ra G) + (r_fact (c_resource_ra G) (ra_valid G a)) + (c_ghost_own G a)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + c_resource_ra_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def, + r_sep_def, + r_fact_def, + prod_ra_valid))); + body = GEN_TAC(body, "G"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hown"); + body = ASMP_CONJ_TAC(body, "Hvalid", "Hvalid_mem", "Hvalid_ghost"); + body = ASMP_CONJ_TAC(body, "Hown", "Hphys_unit", "Hghost_owned"); + + thm valid_a = eq_mp_rule( + ap_term_rule( + `ra_valid (G:(A)ra):A->bool`, + assume_rule(` + SND (resource:((int,(pmem_byte_state)excl)finmap)#A) == (a:A) + `)), + assume_rule(` + ra_valid (G:(A)ra) + (SND (resource:((int,(pmem_byte_state)excl)finmap)#A)) + `)); + body = EXISTS_TAC(body, `ra_unit (prod_ra mem_ra (G:(A)ra))`); + body = EXISTS_TAC(body, `resource:((int,(pmem_byte_state)excl)finmap)#A`); + gnode_list split = CONJ_TAC(body); + ACCEPT_TAC( + split[0], + gsym_rule(ispecl_rule( + TERM_LIST( + `prod_ra mem_ra (G:(A)ra)`, + `resource:((int,(pmem_byte_state)excl)finmap)#A`), + ra_unit_l))); + gnode_list predicates = CONJ_TAC(split[1]); + gnode_list fact = CONJ_TAC(predicates[0]); + ACCEPT_TAC(fact[0], valid_a); + ACCEPT_TAC(fact[1], refl_rule(`ra_unit (prod_ra mem_ra (G:(A)ra))`)); + gnode_list owned = CONJ_TAC(predicates[1]); + ACCEPT_TAC( + owned[0], + assume_rule(` + FST (resource:((int,(pmem_byte_state)excl)finmap)#A) == + ra_unit mem_ra + `)); + ACCEPT_TAC( + owned[1], + assume_rule(` + SND (resource:((int,(pmem_byte_state)excl)finmap)#A) == (a:A) + `)); + return gnode_prove(root); +} + +PROOF thm c_ghost_own_valid = prove_c_ghost_own_valid(); + +PROOF static thm prove_c_ghost_own_update(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (a:A) (b:A). + ra_update G a b ==> + c_viewshift G (c_ghost_own G a) (c_ghost_own G b) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + c_viewshift_def, + c_ghost_own_def, + c_lift_ghost_def))); + thm result = mp_rule( + ispecl_rule( + TERM_LIST(`mem_ra`, `G:(A)ra`, `a:A`, `b:A`), + r_right_own_update), + assume_rule(`ra_update (G:(A)ra) (a:A) (b:A)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_ghost_own_update = prove_c_ghost_own_update(); + +PROOF static thm prove_c_ghost_own_updateP(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (a:A) (P:A->bool). + ra_updateP G a P ==> + c_viewshift + G + (c_ghost_own G a) + (r_exists + (c_resource_ra G) + (\b:A. + r_sep + (c_resource_ra G) + (r_fact (c_resource_ra G) (P b)) + (c_ghost_own G b))) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + c_resource_ra_def, + c_viewshift_def, + c_ghost_own_def, + c_lift_ghost_def))); + thm result = mp_rule( + ispecl_rule( + TERM_LIST(`mem_ra`, `G:(A)ra`, `a:A`, `P:A->bool`), + r_right_own_updateP), + assume_rule(`ra_updateP (G:(A)ra) (a:A) (P:A->bool)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_ghost_own_updateP = prove_c_ghost_own_updateP(); + +PROOF static thm prove_c_ghost_own_drop(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (a:A). + c_viewshift + G + (c_ghost_own G a) + (r_emp (c_resource_ra G)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + c_viewshift_def, + r_viewshift_right_def, + r_entails_def, + r_bupd_right_def, + c_resource_ra_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def, + r_emp_def, + ra_updateP_def, + prod_ra_valid, + prod_ra_unit))); + body = CONV_TAC(body, depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "G"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hsource"); + body = ASMP_CONJ_TAC(body, "Hsource", "Hphys_unit", "Hghost_owned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm valid_frame = conjunct2_rule(mp_rule( + ispecl_rule( + TERM_LIST( + `G:(A)ra`, + `SND (owned:((int,(pmem_byte_state)excl)finmap)#A)`, + `frame:A`), + ra_valid_op), + assume_rule(` + ra_valid + (G:(A)ra) + (ra_op G + (SND (owned:((int,(pmem_byte_state)excl)finmap)#A)) + (frame:A)) + `))); + body = EXISTS_TAC(body, `ra_unit (G:(A)ra)`); + gnode_list result = CONJ_TAC(body); + thm pair_eq = get_theorem_by_name("PAIR_EQ"); + pair_eq = ispec_rule( + `FST (owned:((int,(pmem_byte_state)excl)finmap)#A)`, pair_eq); + pair_eq = ispec_rule(`ra_unit (G:(A)ra)`, pair_eq); + pair_eq = ispec_rule(`ra_unit mem_ra`, pair_eq); + pair_eq = ispec_rule(`ra_unit (G:(A)ra)`, pair_eq); + thm physical_pair = eq_mp_rule( + gsym_rule(pair_eq), + conj_rule( + assume_rule(` + FST (owned:((int,(pmem_byte_state)excl)finmap)#A) == + ra_unit mem_ra + `), + refl_rule(`ra_unit (G:(A)ra)`))); + ACCEPT_TAC(result[0], physical_pair); + ACCEPT_TAC( + result[1], + eq_mp_rule( + ap_term_rule( + `ra_valid (G:(A)ra):A->bool`, + gsym_rule(ispecl_rule( + TERM_LIST(`G:(A)ra`, `frame:A`), + ra_unit_l))), + valid_frame)); + return gnode_prove(root); +} + +PROOF thm c_ghost_own_drop = prove_c_ghost_own_drop(); + +PROOF thm c_named_own_def = new_fun_definition(` + c_named_own + (R:(A)ra) + (name:num) + (a:A) = + c_ghost_own + (named_ra R) + (finmap_singleton name a) +`); + +PROOF static thm prove_c_named_own_op(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (name:num) (a:A) (b:A). + r_equiv + (c_resource_ra (named_ra R)) + (c_named_own R name (ra_op R a b)) + (r_sep + (c_resource_ra (named_ra R)) + (c_named_own R name a) + (c_named_own R name b)) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(c_named_own_def))); + thm result = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`, + `finmap_singleton (name:num) (b:A)`), + c_ghost_own_op); + result = rewrite_rule( + THM_LIST(named_ra_singleton_op), + result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_named_own_op = prove_c_named_own_op(); + +PROOF static thm prove_c_named_own_valid(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (name:num) (a:A). + r_entails + (c_resource_ra (named_ra R)) + (c_named_own R name a) + (r_sep + (c_resource_ra (named_ra R)) + (r_fact + (c_resource_ra (named_ra R)) + (ra_valid R a)) + (c_named_own R name a)) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(c_named_own_def))); + thm result = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`), + c_ghost_own_valid); + result = rewrite_rule( + THM_LIST(named_ra_valid_singleton), + result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_named_own_valid = prove_c_named_own_valid(); + +PROOF static thm prove_c_named_own_update(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (name:num) (a:A) (b:A). + ra_update R a b ==> + c_viewshift + (named_ra R) + (c_named_own R name a) + (c_named_own R name b) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(c_named_own_def))); + thm map_update = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `name:num`, `a:A`, `b:A`), + named_ra_update_singleton), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`, + `finmap_singleton (name:num) (b:A)`), + c_ghost_own_update), + map_update); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_named_own_update = prove_c_named_own_update(); + +PROOF static thm prove_c_named_own_updateP(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (name:num) (a:A) (P:A->bool). + ra_updateP R a P ==> + c_viewshift + (named_ra R) + (c_named_own R name a) + (r_exists + (c_resource_ra (named_ra R)) + (\b:A. + r_sep + (c_resource_ra (named_ra R)) + (r_fact (c_resource_ra (named_ra R)) (P b)) + (c_named_own R name b))) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + c_viewshift_def, + r_viewshift_right_def, + r_entails_def, + r_bupd_right_def, + c_resource_ra_def, + c_named_own_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def, + r_exists_def, + r_sep_def, + r_fact_def, + ra_updateP_def))); + body = CONV_TAC(body, depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "name"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hpayload_update"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hsource"); + body = ASMP_CONJ_TAC(body, "Hsource", "Hphys_unit", "Hghost_owned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + term_list payload_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hpayload_update")); + thm payload_update = eq_mp_rule( + gsym_rule(inst_rule( + TERM_PAIR_LIST( + (term_pair){`P:A->bool`, `result:A->bool`}), + ra_updateP_def)), + assume_rule(payload_terms[0])); + thm map_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `name:num`, `a:A`, `P:A->bool`), + named_ra_updateP_singleton), + payload_update); + map_update = rewrite_rule(THM_LIST(ra_updateP_def), map_update); + thm source_eq = beta_rule(ap_term_rule( + `\ghost:(num,A)finmap. + ra_valid + (named_ra (R:(A)ra)) + (ra_op (named_ra R) ghost (frame:(num,A)finmap))`, + assume_rule(` + SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap) == + finmap_singleton (name:num) (a:A) + `))); + thm source_valid = eq_mp_rule( + source_eq, + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)) + (frame:(num,A)finmap)) + `)); + thm selected = mp_rule( + spec_rule(`frame:(num,A)finmap`, map_update), + source_valid); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, "Hselected", "Himage", "Hvalid_selected"); + body = ASMP_EXISTS_TAC(body, "Himage", "b"); + body = ASMP_CONJ_TAC(body, "Himage", "HP", "Hselected_eq"); + + body = EXISTS_TAC(body, `selected:(num,A)finmap`); + gnode_list result = CONJ_TAC(body); + gnode post = CONV_TAC( + result[0], + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `b:A`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST( + r_sep_def, + r_fact_def, + c_named_own_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC( + post, + `ra_unit + (prod_ra mem_ra (named_ra (R:(A)ra)))`); + post = EXISTS_TAC( + post, + `(FST + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap), + selected:(num,A)finmap)`); + gnode_list post_split = CONJ_TAC(post); + ACCEPT_TAC( + post_split[0], + gsym_rule(ispecl_rule( + TERM_LIST( + `prod_ra mem_ra (named_ra (R:(A)ra))`, + `(FST + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap), + selected:(num,A)finmap)`), + ra_unit_l))); + gnode_list predicates = CONJ_TAC(post_split[1]); + gnode_list fact = CONJ_TAC(predicates[0]); + ACCEPT_TAC(fact[0], assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC( + fact[1], + refl_rule(`ra_unit (prod_ra mem_ra (named_ra (R:(A)ra)))`)); + gnode_list named_owned = CONJ_TAC(predicates[1]); + term_list physical_terms = gnode_get_asmps( + named_owned[0], CONST_STRING_LIST("Hphys_unit")); + ACCEPT_TAC( + named_owned[0], + trans_rule( + ispecl_rule( + TERM_LIST( + `FST + (owned: + ((int,(pmem_byte_state)excl)finmap)# + (num,A)finmap)`, + `selected:(num,A)finmap`), + get_theorem_by_name("FST")), + assume_rule(physical_terms[0]))); + ACCEPT_TAC( + named_owned[1], + trans_rule( + ispecl_rule( + TERM_LIST( + `FST + (owned: + ((int,(pmem_byte_state)excl)finmap)# + (num,A)finmap)`, + `selected:(num,A)finmap`), + get_theorem_by_name("SND")), + assume_rule(` + (selected:(num,A)finmap) == + finmap_singleton (name:num) (b:A) + `))); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (selected:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + return gnode_prove(root); +} + +PROOF thm c_named_own_updateP = + prove_c_named_own_updateP(); + +PROOF static thm prove_c_named_own_drop(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (name:num) (a:A). + c_viewshift + (named_ra R) + (c_named_own R name a) + (r_emp (c_resource_ra (named_ra R))) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(c_named_own_def))); + thm result = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`), + c_ghost_own_drop); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm c_named_own_drop = prove_c_named_own_drop(); + +PROOF static thm prove_c_named_own_alloc(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (a:A) + (P:(((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)->bool). + ra_valid R a ==> + c_viewshift + (named_ra R) + P + (r_exists + (c_resource_ra (named_ra R)) + (\name:num. + r_sep + (c_resource_ra (named_ra R)) + (c_named_own R name a) + P)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + c_viewshift_def, + r_viewshift_right_def, + r_entails_def, + r_bupd_right_def, + c_resource_ra_def, + c_named_own_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def, + r_exists_def, + r_sep_def, + ra_updateP_def, + prod_ra_op))); + body = CONV_TAC(body, depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hvalid_a"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "HP"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + term_list valid_a_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hvalid_a")); + term_list source_pred_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("HP")); + thm source_pred = assume_rule(source_pred_terms[0]); + + thm allocation = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)`, + `a:A`), + named_ra_alloc), + assume_rule(valid_a_terms[0])); + allocation = rewrite_rule(THM_LIST(ra_updateP_def), allocation); + thm selected = mp_rule( + spec_rule(`frame:(num,A)finmap`, allocation), + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)) + (frame:(num,A)finmap)) + `)); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "result"); + body = ASMP_CONJ_TAC( + body, "Hselected", "Hallocated", "Hvalid_result"); + body = ASMP_EXISTS_TAC(body, "Hallocated", "name"); + body = ASMP_CONJ_TAC( + body, "Hallocated", "Hfresh", "Hresult_eq"); + + body = EXISTS_TAC(body, `result:(num,A)finmap`); + gnode_list update_result = CONJ_TAC(body); + gnode post = CONV_TAC( + update_result[0], + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `name:num`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST( + r_sep_def, + c_named_own_def, + c_ghost_own_def, + c_lift_ghost_def, + r_lift_right_def, + r_own_def))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC( + post, + `(ra_unit mem_ra,finmap_singleton (name:num) (a:A))`); + post = EXISTS_TAC( + post, + `owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap`); + gnode_list split = CONJ_TAC(post); + + thm op_fresh = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `name:num`, + `a:A`, + `SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)`), + gmap_ra_singleton_op_fresh), + assume_rule(` + finmap_lookup + (SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)) + (name:num) == + NONE + `)); + op_fresh = rewrite_rule( + THM_LIST(gsym_rule(named_ra_def)), + op_fresh); + thm physical_eq = gsym_rule(ispecl_rule( + TERM_LIST( + `mem_ra`, + `FST + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)`), + ra_unit_l)); + thm ghost_eq = trans_rule( + assume_rule(` + (result:(num,A)finmap) == + finmap_insert + (name:num) + (a:A) + (SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)) + `), + gsym_rule(op_fresh)); + thm pair_eq = get_theorem_by_name("PAIR_EQ"); + pair_eq = ispec_rule( + `FST + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)`, + pair_eq); + pair_eq = ispec_rule(`result:(num,A)finmap`, pair_eq); + pair_eq = ispec_rule( + `ra_op mem_ra + (ra_unit mem_ra) + (FST + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap))`, + pair_eq); + pair_eq = ispec_rule( + `ra_op (named_ra (R:(A)ra)) + (finmap_singleton (name:num) (a:A)) + (SND + (owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap))`, + pair_eq); + thm prod_op = ispecl_rule( + TERM_LIST( + `mem_ra`, + `named_ra (R:(A)ra)`, + `(ra_unit mem_ra,finmap_singleton (name:num) (a:A))`, + `owned:((int,(pmem_byte_state)excl)finmap)#(num,A)finmap`), + prod_ra_op); + prod_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + prod_op); + ACCEPT_TAC( + split[0], + trans_rule( + eq_mp_rule( + gsym_rule(pair_eq), + conj_rule(physical_eq, ghost_eq)), + gsym_rule(prod_op))); + gnode_list predicates = CONJ_TAC(split[1]); + gnode_list named_owned = CONJ_TAC(predicates[0]); + ACCEPT_TAC( + named_owned[0], + ispecl_rule( + TERM_LIST( + `ra_unit mem_ra`, + `finmap_singleton (name:num) (a:A)`), + get_theorem_by_name("FST"))); + ACCEPT_TAC( + named_owned[1], + ispecl_rule( + TERM_LIST( + `ra_unit mem_ra`, + `finmap_singleton (name:num) (a:A)`), + get_theorem_by_name("SND"))); + ACCEPT_TAC( + predicates[1], + source_pred); + ACCEPT_TAC( + update_result[1], + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (result:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + return gnode_prove(root); +} + +PROOF thm c_named_own_alloc = prove_c_named_own_alloc(); + +PROOF static int audit_c_ghost(void) { + thm_list public_theorems = THM_LIST( + c_ghost_own_op, + c_ghost_own_valid, + c_ghost_own_update, + c_ghost_own_updateP, + c_ghost_own_drop, + c_named_own_def, + c_named_own_op, + c_named_own_valid, + c_named_own_update, + c_named_own_updateP, + c_named_own_drop, + c_named_own_alloc); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "C ghost theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "C ghost theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == C_GHOST_AXIOMS_BEFORE, + "C ghost theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_c_ghost"); + return -1; +} + +PROOF static int _C_GHOST_AUDIT = audit_c_ghost(); diff --git a/theory/c_program_logic/c_ghost.h b/theory/c_program_logic/c_ghost.h new file mode 100644 index 0000000000000000000000000000000000000000..f5fca1b06b5738427174d15263a18c39f544d9a4 --- /dev/null +++ b/theory/c_program_logic/c_ghost.h @@ -0,0 +1,194 @@ +/** + * @file c_ghost.h + * @brief Ownership and ghost-only updates for a complete global ghost RA. + * + * `c_ghost_own G a` is the exact right lift of `r_own G a`; its physical + * projection is therefore exactly `ra_unit mem_ra`. The update laws below + * use `c_viewshift G`, so physical memory is preserved by construction. + * + * Resource-independent propositions and spatial facts remain distinct. In + * particular, validity and predicate-update witnesses are returned as + * exact-unit `r_fact` assertions next to the retained/new ownership; they are + * not encoded as resource-independent `r_pure` assertions. + */ + +#pragma once + +#include "proof/theory/c_program_logic/c_basic_update.h" +#include "proof/theory/logic/named_ra.h" + +/* Generic laws for an arbitrary complete global RA `G`. */ +/** + * ```text + * forall (G:(A)ra) (a:A) (b:A). + * r_equiv + * (c_resource_ra G) + * (c_ghost_own G (ra_op G a b)) + * (r_sep (c_resource_ra G) + * (c_ghost_own G a) (c_ghost_own G b)) + * ``` + * + * 在完整 C 资源中，拥有 ghost 组合 `ra_op G a b` 与分别拥有 `a`、`b` 的分离合取在 `r_equiv` 下等价。 + */ +PROOF extern thm c_ghost_own_op; + +/** + * ```text + * forall (G:(A)ra) (a:A). + * r_entails + * (c_resource_ra G) + * (c_ghost_own G a) + * (r_sep (c_resource_ra G) + * (r_fact (c_resource_ra G) (ra_valid G a)) + * (c_ghost_own G a)) + * ``` + * + * 拥有 ghost 片段 `a` 可分离出 `ra_valid G a` 这一 exact-unit fact，同时保留原所有权。 + */ +PROOF extern thm c_ghost_own_valid; + +/** + * ```text + * forall (G:(A)ra) (a:A) (b:A). + * ra_update G a b ==> + * c_viewshift G (c_ghost_own G a) (c_ghost_own G b) + * ``` + * + * ghost RA 中从 `a` 到 `b` 的 frame-preserving update 可提升为保持物理内存不变的 C view shift。 + */ +PROOF extern thm c_ghost_own_update; + +/** + * ```text + * forall (G:(A)ra) (a:A) (P:A->bool). + * ra_updateP G a P ==> + * c_viewshift G + * (c_ghost_own G a) + * (r_exists (c_resource_ra G) (\b:A. + * r_sep (c_resource_ra G) + * (r_fact (c_resource_ra G) (P b)) + * (c_ghost_own G b))) + * ``` + * + * 对 `a` 的谓词更新可经 C view shift 选择 `b`，分离得到 `P b` 的 exact-unit fact 和 ghost 所有权；物理投影不变。 + */ +PROOF extern thm c_ghost_own_updateP; + +/** + * ```text + * forall (G:(A)ra) (a:A). + * c_viewshift G + * (c_ghost_own G a) + * (r_emp (c_resource_ra G)) + * ``` + * + * 任意 ghost 片段的精确所有权都可经 C view shift 丢弃为 `emp`；该 shift 只更新 ghost，物理 frame 保持不变。 + */ +PROOF extern thm c_ghost_own_drop; + +/** + * Convenience layer for `G = named_ra R`, the finite name map of payload RA + * `R`. Updates and drops affect one fixed name. Allocation requires a valid + * payload and returns an existential fresh name while framing the source + * assertion. “Drop” is intentional: this API does not call the operation + * deallocation. + */ +/** + * ```text + * c_named_own (R:(A)ra) (name:num) (a:A) = + * c_ghost_own (named_ra R) (finmap_singleton name a) + * ``` + * + * `c_named_own R name a` 精确拥有 `named_ra R` 中键 `name` 映射到载荷 `a` 的单点 ghost 片段。 + */ +PROOF extern thm c_named_own_def; + +/** + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). + * r_equiv + * (c_resource_ra (named_ra R)) + * (c_named_own R name (ra_op R a b)) + * (r_sep (c_resource_ra (named_ra R)) + * (c_named_own R name a) + * (c_named_own R name b)) + * ``` + * + * 同一名字下拥有组合载荷 `ra_op R a b`，与在该名字下分别拥有 `a`、`b` 的分离合取在 `r_equiv` 下等价。 + */ +PROOF extern thm c_named_own_op; + +/** + * ```text + * forall (R:(A)ra) (name:num) (a:A). + * r_entails + * (c_resource_ra (named_ra R)) + * (c_named_own R name a) + * (r_sep (c_resource_ra (named_ra R)) + * (r_fact (c_resource_ra (named_ra R)) (ra_valid R a)) + * (c_named_own R name a)) + * ``` + * + * 固定名字下拥有载荷 `a` 可分离出 `ra_valid R a` 的 exact-unit fact，并保留该命名所有权。 + */ +PROOF extern thm c_named_own_valid; + +/** + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). + * ra_update R a b ==> + * c_viewshift (named_ra R) + * (c_named_own R name a) + * (c_named_own R name b) + * ``` + * + * 若载荷可由 `a` frame-preserving update 为 `b`，则固定名字的所有权可经 C view shift 同步更新。 + */ +PROOF extern thm c_named_own_update; + +/** + * ```text + * forall (R:(A)ra) (name:num) (a:A) (P:A->bool). + * ra_updateP R a P ==> + * c_viewshift (named_ra R) + * (c_named_own R name a) + * (r_exists (c_resource_ra (named_ra R)) (\b:A. + * r_sep (c_resource_ra (named_ra R)) + * (r_fact (c_resource_ra (named_ra R)) (P b)) + * (c_named_own R name b))) + * ``` + * + * 载荷谓词更新可在固定名字下选择某个 `b`，返回 `P b` 的 exact-unit fact 与更新后的命名所有权。 + */ +PROOF extern thm c_named_own_updateP; + +/** + * ```text + * forall (R:(A)ra) (name:num) (a:A). + * c_viewshift (named_ra R) + * (c_named_own R name a) + * (r_emp (c_resource_ra (named_ra R))) + * ``` + * + * 固定名字的单点 ghost 所有权可经 C view shift 丢弃为 `emp`；这只移除当前 singleton，不断言 frame 中没有同名资源。 + */ +PROOF extern thm c_named_own_drop; + +/** + * ```text + * forall + * (R:(A)ra) + * (a:A) + * (P:(((int,(pmem_byte_state)excl)finmap)#(num,A)finmap)->bool). + * ra_valid R a ==> + * c_viewshift (named_ra R) + * P + * (r_exists (c_resource_ra (named_ra R)) (\name:num. + * r_sep (c_resource_ra (named_ra R)) + * (c_named_own R name a) + * P)) + * ``` + * + * 对有效载荷 `a`，任意断言 `P` 可经 C view shift 分配一个与其 frame 兼容的新名字，并得到该命名所有权 `** P`。 + */ +PROOF extern thm c_named_own_alloc; diff --git a/theory/c_program_logic/c_integer.c b/theory/c_program_logic/c_integer.c new file mode 100644 index 0000000000000000000000000000000000000000..026a5b83be0e666012df9423c84f8fff352a17fc --- /dev/null +++ b/theory/c_program_logic/c_integer.c @@ -0,0 +1,248 @@ +#include "proof/theory/c_program_logic/c_integer.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" + +PROOF static size_t C_INTEGER_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +/* ------------------------------------------------------------------------- */ +/* Width-generic C integer conversion */ +/* ------------------------------------------------------------------------- */ + +PROOF thm c_exp_2_def = new_fun_definition(` + exp_2 (width:int) : int = &(2 EXP num_of_int width) +`); + +PROOF thm c_max_unsigned_def = new_fun_definition(` + max_unsigned (width:int) : int = exp_2 width - &1 +`); + +PROOF thm c_max_signed_def = new_fun_definition(` + max_signed (width:int) : int = exp_2 (width - &1) - &1 +`); + +PROOF thm c_min_signed_def = new_fun_definition(` + min_signed (width:int) : int = --(exp_2 (width - &1)) +`); + +PROOF thm cast_unsigned_def = new_fun_definition(` + cast_unsigned (width:int) (value:int) : int = + value rem exp_2 width +`); + +PROOF thm cast_signed_def = new_fun_definition(` + cast_signed (width:int) (value:int) : int = + let unsigned_value = cast_unsigned width value in + if unsigned_value < exp_2 (width - &1) + then unsigned_value + else unsigned_value - exp_2 width +`); + +PROOF thm unsigned_last_nbits_def = new_fun_definition(` + unsigned_last_nbits (value:int) (width:int) : int = + cast_unsigned width value +`); + +PROOF thm signed_last_nbits_def = new_fun_definition(` + signed_last_nbits (value:int) (width:int) : int = + cast_signed width value +`); + +PROOF static thm prove_unsigned_last_nbits_id(void) { + gnode root = gnode_new_with_ccl(` + forall (value:int) (width:int). + &0 <= value && value < exp_2 width ==> + unsigned_last_nbits value width = value + `); + gnode reduced = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + unsigned_last_nbits_def, + cast_unsigned_def))); + gnode body = AUTO_INTROS_TAC(reduced); + thm identity = ispecl_rule( + TERM_LIST(`value:int`, `exp_2 (width:int)`), + get_theorem_by_name("INT_REM_LT")); + thm bounds = + assume_rule(`&0 <= value && value < exp_2 (width:int)`); + thm guarded_nonnegative = disch_rule( + `~(exp_2 (width:int) == &0)`, + conjunct1_rule(bounds)); + identity = mp_rule( + identity, + conj_rule(guarded_nonnegative, conjunct2_rule(bounds))); + ACCEPT_TAC(body, identity); + return gnode_prove(root); +} + +PROOF thm unsigned_last_nbits_id = + prove_unsigned_last_nbits_id(); + +/* ------------------------------------------------------------------------- */ +/* Fixed-width bit operations */ +/* ------------------------------------------------------------------------- */ + +PROOF thm i32_and_def = new_fun_definition(` + i32_and (x:int) (y:int) : int = + ival (word_and ((iword x):(32)word) ((iword y):(32)word)) +`); +PROOF thm i32_or_def = new_fun_definition(` + i32_or (x:int) (y:int) : int = + ival (word_or ((iword x):(32)word) ((iword y):(32)word)) +`); +PROOF thm i32_xor_def = new_fun_definition(` + i32_xor (x:int) (y:int) : int = + ival (word_xor ((iword x):(32)word) ((iword y):(32)word)) +`); +PROOF thm i32_not_def = new_fun_definition(` + i32_not (x:int) : int = ival (word_not ((iword x):(32)word)) +`); +PROOF thm i32_shl_def = new_fun_definition(` + i32_shl (x:int) (y:int) : int = + ival (word_shl ((iword x):(32)word) (num_of_int y)) +`); +PROOF thm i32_shr_def = new_fun_definition(` + i32_shr (x:int) (y:int) : int = + ival (word_ishr ((iword x):(32)word) (num_of_int y)) +`); + +PROOF thm u32_and_def = new_fun_definition(` + u32_and (x:int) (y:int) : int = + &(val (word_and ((iword x):(32)word) ((iword y):(32)word))) +`); +PROOF thm u32_or_def = new_fun_definition(` + u32_or (x:int) (y:int) : int = + &(val (word_or ((iword x):(32)word) ((iword y):(32)word))) +`); +PROOF thm u32_xor_def = new_fun_definition(` + u32_xor (x:int) (y:int) : int = + &(val (word_xor ((iword x):(32)word) ((iword y):(32)word))) +`); +PROOF thm u32_not_def = new_fun_definition(` + u32_not (x:int) : int = &(val (word_not ((iword x):(32)word))) +`); +PROOF thm u32_shl_def = new_fun_definition(` + u32_shl (x:int) (y:int) : int = + &(val (word_shl ((iword x):(32)word) (num_of_int y))) +`); +PROOF thm u32_shr_def = new_fun_definition(` + u32_shr (x:int) (y:int) : int = + &(val (word_ushr ((iword x):(32)word) (num_of_int y))) +`); + +PROOF thm i64_and_def = new_fun_definition(` + i64_and (x:int) (y:int) : int = + ival (word_and ((iword x):(64)word) ((iword y):(64)word)) +`); +PROOF thm i64_or_def = new_fun_definition(` + i64_or (x:int) (y:int) : int = + ival (word_or ((iword x):(64)word) ((iword y):(64)word)) +`); +PROOF thm i64_xor_def = new_fun_definition(` + i64_xor (x:int) (y:int) : int = + ival (word_xor ((iword x):(64)word) ((iword y):(64)word)) +`); +PROOF thm i64_not_def = new_fun_definition(` + i64_not (x:int) : int = ival (word_not ((iword x):(64)word)) +`); +PROOF thm i64_shl_def = new_fun_definition(` + i64_shl (x:int) (y:int) : int = + ival (word_shl ((iword x):(64)word) (num_of_int y)) +`); +PROOF thm i64_shr_def = new_fun_definition(` + i64_shr (x:int) (y:int) : int = + ival (word_ishr ((iword x):(64)word) (num_of_int y)) +`); + +PROOF thm u64_and_def = new_fun_definition(` + u64_and (x:int) (y:int) : int = + &(val (word_and ((iword x):(64)word) ((iword y):(64)word))) +`); +PROOF thm u64_or_def = new_fun_definition(` + u64_or (x:int) (y:int) : int = + &(val (word_or ((iword x):(64)word) ((iword y):(64)word))) +`); +PROOF thm u64_xor_def = new_fun_definition(` + u64_xor (x:int) (y:int) : int = + &(val (word_xor ((iword x):(64)word) ((iword y):(64)word))) +`); +PROOF thm u64_not_def = new_fun_definition(` + u64_not (x:int) : int = &(val (word_not ((iword x):(64)word))) +`); +PROOF thm u64_shl_def = new_fun_definition(` + u64_shl (x:int) (y:int) : int = + &(val (word_shl ((iword x):(64)word) (num_of_int y))) +`); +PROOF thm u64_shr_def = new_fun_definition(` + u64_shr (x:int) (y:int) : int = + &(val (word_ushr ((iword x):(64)word) (num_of_int y))) +`); + +/* ------------------------------------------------------------------------- */ +/* Searchable theorem database */ +/* ------------------------------------------------------------------------- */ + +PROOF static int c_integer_register_theorems(void) { +#define REGISTER_THEOREM(name, theorem) \ + ENSURE_COND(add_theorem((name), (theorem)), \ + "duplicate C-integer theorem name: " name) + + thm exp_2_api = gen_rule(`width:int`, c_exp_2_def); + REGISTER_THEOREM("int_exp_2_def", exp_2_api); + REGISTER_THEOREM("max_unsigned_def", c_max_unsigned_def); + REGISTER_THEOREM("max_signed_def", c_max_signed_def); + REGISTER_THEOREM("min_signed_def", c_min_signed_def); + REGISTER_THEOREM("cast_unsigned_def", cast_unsigned_def); + REGISTER_THEOREM("cast_signed_def", cast_signed_def); + REGISTER_THEOREM("unsigned_last_nbits_def", unsigned_last_nbits_def); + REGISTER_THEOREM("signed_last_nbits_def", signed_last_nbits_def); + REGISTER_THEOREM("unsigned_last_nbits_id", unsigned_last_nbits_id); + + REGISTER_THEOREM("i32_and_def", i32_and_def); + REGISTER_THEOREM("i32_or_def", i32_or_def); + REGISTER_THEOREM("i32_xor_def", i32_xor_def); + REGISTER_THEOREM("i32_not_def", i32_not_def); + REGISTER_THEOREM("i32_shl_def", i32_shl_def); + REGISTER_THEOREM("i32_shr_def", i32_shr_def); + REGISTER_THEOREM("u32_and_def", u32_and_def); + REGISTER_THEOREM("u32_or_def", u32_or_def); + REGISTER_THEOREM("u32_xor_def", u32_xor_def); + REGISTER_THEOREM("u32_not_def", u32_not_def); + REGISTER_THEOREM("u32_shl_def", u32_shl_def); + REGISTER_THEOREM("u32_shr_def", u32_shr_def); + REGISTER_THEOREM("i64_and_def", i64_and_def); + REGISTER_THEOREM("i64_or_def", i64_or_def); + REGISTER_THEOREM("i64_xor_def", i64_xor_def); + REGISTER_THEOREM("i64_not_def", i64_not_def); + REGISTER_THEOREM("i64_shl_def", i64_shl_def); + REGISTER_THEOREM("i64_shr_def", i64_shr_def); + REGISTER_THEOREM("u64_and_def", u64_and_def); + REGISTER_THEOREM("u64_or_def", u64_or_def); + REGISTER_THEOREM("u64_xor_def", u64_xor_def); + REGISTER_THEOREM("u64_not_def", u64_not_def); + REGISTER_THEOREM("u64_shl_def", u64_shl_def); + REGISTER_THEOREM("u64_shr_def", u64_shr_def); + +#undef REGISTER_THEOREM + return 0; +err: + ERR_FUN_PUTS("c_integer_register_theorems"); + return -1; +} + +PROOF static int _C_INTEGER_THEOREMS_REGISTERED = + c_integer_register_theorems(); + +PROOF static int c_integer_check_axiom_free(void) { + thm_list final_axioms = get_all_axioms(); + ENSURE_COND(vector_size(final_axioms) == C_INTEGER_AXIOMS_BEFORE, + "c_integer introduced a new axiom"); + return 0; +err: + ERR_FUN_PUTS("c_integer_check_axiom_free"); + return -1; +} + +PROOF static int _C_INTEGER_AXIOM_CHECK = + c_integer_check_axiom_free(); diff --git a/theory/c_program_logic/c_integer.h b/theory/c_program_logic/c_integer.h new file mode 100644 index 0000000000000000000000000000000000000000..5aec1586366e6dec549dd2585fab55c6a1b86c97 --- /dev/null +++ b/theory/c_program_logic/c_integer.h @@ -0,0 +1,342 @@ +/** + * @file c_integer.h + * @brief Width-generic C integer conversions and fixed-width operations. + * + * This theory is independent of C object layout and physical memory. It + * exposes the integer operations emitted by the C* frontend over HOL `int`. + */ + +#pragma once + +#include "proof/proof_kernel.h" + +/* ------------------------------------------------------------------------- */ +/* Width-generic C integer conversion */ +/* ------------------------------------------------------------------------- */ + +/** + * ```text + * exp_2 (width:int) = &(2 EXP num_of_int width) + * ``` + * + * `exp_2 width` 是整数 `2^(num_of_int width)`；负的 `width` 先由 `num_of_int` 截为零。 + */ +PROOF extern thm c_exp_2_def; +/** + * ```text + * max_unsigned (width:int) = exp_2 width - &1 + * ``` + * + * `max_unsigned width` 定义为 `exp_2 width - 1`；`width >= 0` 时即通常的 `2^width - 1`。 + */ +PROOF extern thm c_max_unsigned_def; +/** + * ```text + * max_signed (width:int) = exp_2 (width - &1) - &1 + * ``` + * + * `max_signed width` 定义为 `exp_2 (width - 1) - 1`；`width >= 1` 时即 `2^(width-1)-1`。 + */ +PROOF extern thm c_max_signed_def; +/** + * ```text + * min_signed (width:int) = --(exp_2 (width - &1)) + * ``` + * + * `min_signed width` 定义为 `-exp_2 (width - 1)`；`width >= 1` 时即 `-2^(width-1)`。 + */ +PROOF extern thm c_min_signed_def; +/** + * ```text + * cast_unsigned (width:int) (value:int) = value rem exp_2 width + * ``` + * + * `cast_unsigned width value` 取 `value rem exp_2 width`；非负宽度时即保留低 `width` 位。 + */ +PROOF extern thm cast_unsigned_def; + +/** + * ```text + * cast_signed (width:int) (value:int) = + * let unsigned_value = cast_unsigned width value in + * if unsigned_value < exp_2 (width - &1) + * then unsigned_value + * else unsigned_value - exp_2 width. + * ``` + * + * 令 `u = cast_unsigned width value`；低于 `exp_2(width-1)` 时返回 `u`，否则返回 `u - exp_2 width`。 + */ +PROOF extern thm cast_signed_def; + +/** + * ```text + * unsigned_last_nbits (value:int) (width:int) = + * cast_unsigned width value + * ``` + * + * `unsigned_last_nbits value width` 严格定义为 `cast_unsigned width value`；非负宽度时表示截取低位。 + */ +PROOF extern thm unsigned_last_nbits_def; + +/** + * ```text + * signed_last_nbits (value:int) (width:int) = + * cast_signed width value + * ``` + * + * `signed_last_nbits value width` 严格定义为 `cast_signed width value`；正宽度时采用补码解释。 + */ +PROOF extern thm signed_last_nbits_def; + +/** + * Conversion identity in the unsigned range: + * + * ```text + * forall (value:int) (width:int). + * &0 <= value && value < exp_2 width ==> + * unsigned_last_nbits value width = value + * ``` + * + * 若 `0 <= value < exp_2 width`，则无符号截取不改变 `value`，也就是模运算保持模范围内的数。 + */ +PROOF extern thm unsigned_last_nbits_id; + +/* ------------------------------------------------------------------------- */ +/* Fixed-width bit operations */ +/* ------------------------------------------------------------------------- */ + +/** + * ```text + * i32_and (x:int) (y:int) = + * ival (word_and ((iword x):(32)word) ((iword y):(32)word)) + * ``` + * + * `i32_and` 在 32 位字表示上逐位与，并把结果按 32 位有符号整数解释。 + */ +PROOF extern thm i32_and_def; + +/** + * ```text + * i32_or (x:int) (y:int) = + * ival (word_or ((iword x):(32)word) ((iword y):(32)word)) + * ``` + * + * `i32_or` 在 32 位字表示上逐位或，并把结果按 32 位有符号整数解释。 + */ +PROOF extern thm i32_or_def; + +/** + * ```text + * i32_xor (x:int) (y:int) = + * ival (word_xor ((iword x):(32)word) ((iword y):(32)word)) + * ``` + * + * `i32_xor` 在 32 位字表示上逐位异或，并把结果按 32 位有符号整数解释。 + */ +PROOF extern thm i32_xor_def; + +/** + * ```text + * i32_not (x:int) = ival (word_not ((iword x):(32)word)) + * ``` + * + * `i32_not` 对 32 位字表示逐位取反，并把结果按 32 位有符号整数解释。 + */ +PROOF extern thm i32_not_def; + +/** + * ```text + * i32_shl (x:int) (y:int) = + * ival (word_shl ((iword x):(32)word) (num_of_int y)) + * ``` + * + * `i32_shl` 将 32 位字表示左移 `num_of_int y` 位，再按 32 位有符号整数解释结果。 + */ +PROOF extern thm i32_shl_def; + +/** + * ```text + * i32_shr (x:int) (y:int) = + * ival (word_ishr ((iword x):(32)word) (num_of_int y)) + * ``` + * + * `i32_shr` 将 32 位字表示算术右移 `num_of_int y` 位，再用 `ival` 作有符号解释。 + */ +PROOF extern thm i32_shr_def; + +/** + * ```text + * u32_and (x:int) (y:int) = + * &(val (word_and ((iword x):(32)word) ((iword y):(32)word))) + * ``` + * + * `u32_and` 在 32 位字表示上逐位与，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u32_and_def; + +/** + * ```text + * u32_or (x:int) (y:int) = + * &(val (word_or ((iword x):(32)word) ((iword y):(32)word))) + * ``` + * + * `u32_or` 在 32 位字表示上逐位或，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u32_or_def; + +/** + * ```text + * u32_xor (x:int) (y:int) = + * &(val (word_xor ((iword x):(32)word) ((iword y):(32)word))) + * ``` + * + * `u32_xor` 在 32 位字表示上逐位异或，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u32_xor_def; + +/** + * ```text + * u32_not (x:int) = &(val (word_not ((iword x):(32)word))) + * ``` + * + * `u32_not` 对 32 位字表示逐位取反，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u32_not_def; + +/** + * ```text + * u32_shl (x:int) (y:int) = + * &(val (word_shl ((iword x):(32)word) (num_of_int y))) + * ``` + * + * `u32_shl` 将 32 位字表示左移 `num_of_int y` 位，并以无符号整数读出截断后的结果。 + */ +PROOF extern thm u32_shl_def; + +/** + * ```text + * u32_shr (x:int) (y:int) = + * &(val (word_ushr ((iword x):(32)word) (num_of_int y))) + * ``` + * + * `u32_shr` 将 32 位字表示逻辑右移 `num_of_int y` 位，再用 `val` 读为非负整数。 + */ +PROOF extern thm u32_shr_def; + +/** + * ```text + * i64_and (x:int) (y:int) = + * ival (word_and ((iword x):(64)word) ((iword y):(64)word)) + * ``` + * + * `i64_and` 在 64 位字表示上逐位与，并把结果按 64 位有符号整数解释。 + */ +PROOF extern thm i64_and_def; + +/** + * ```text + * i64_or (x:int) (y:int) = + * ival (word_or ((iword x):(64)word) ((iword y):(64)word)) + * ``` + * + * `i64_or` 在 64 位字表示上逐位或，并把结果按 64 位有符号整数解释。 + */ +PROOF extern thm i64_or_def; + +/** + * ```text + * i64_xor (x:int) (y:int) = + * ival (word_xor ((iword x):(64)word) ((iword y):(64)word)) + * ``` + * + * `i64_xor` 在 64 位字表示上逐位异或，并把结果按 64 位有符号整数解释。 + */ +PROOF extern thm i64_xor_def; + +/** + * ```text + * i64_not (x:int) = ival (word_not ((iword x):(64)word)) + * ``` + * + * `i64_not` 对 64 位字表示逐位取反，并把结果按 64 位有符号整数解释。 + */ +PROOF extern thm i64_not_def; + +/** + * ```text + * i64_shl (x:int) (y:int) = + * ival (word_shl ((iword x):(64)word) (num_of_int y)) + * ``` + * + * `i64_shl` 将 64 位字表示左移 `num_of_int y` 位，再按 64 位有符号整数解释结果。 + */ +PROOF extern thm i64_shl_def; + +/** + * ```text + * i64_shr (x:int) (y:int) = + * ival (word_ishr ((iword x):(64)word) (num_of_int y)) + * ``` + * + * `i64_shr` 将 64 位字表示算术右移 `num_of_int y` 位，再用 `ival` 作有符号解释。 + */ +PROOF extern thm i64_shr_def; + +/** + * ```text + * u64_and (x:int) (y:int) = + * &(val (word_and ((iword x):(64)word) ((iword y):(64)word))) + * ``` + * + * `u64_and` 在 64 位字表示上逐位与，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u64_and_def; + +/** + * ```text + * u64_or (x:int) (y:int) = + * &(val (word_or ((iword x):(64)word) ((iword y):(64)word))) + * ``` + * + * `u64_or` 在 64 位字表示上逐位或，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u64_or_def; + +/** + * ```text + * u64_xor (x:int) (y:int) = + * &(val (word_xor ((iword x):(64)word) ((iword y):(64)word))) + * ``` + * + * `u64_xor` 在 64 位字表示上逐位异或，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u64_xor_def; + +/** + * ```text + * u64_not (x:int) = &(val (word_not ((iword x):(64)word))) + * ``` + * + * `u64_not` 对 64 位字表示逐位取反，并把结果解释为非负无符号整数。 + */ +PROOF extern thm u64_not_def; + +/** + * ```text + * u64_shl (x:int) (y:int) = + * &(val (word_shl ((iword x):(64)word) (num_of_int y))) + * ``` + * + * `u64_shl` 将 64 位字表示左移 `num_of_int y` 位，并以无符号整数读出截断后的结果。 + */ +PROOF extern thm u64_shl_def; + +/** + * ```text + * u64_shr (x:int) (y:int) = + * &(val (word_ushr ((iword x):(64)word) (num_of_int y))) + * ``` + * + * `u64_shr` 将 64 位字表示逻辑右移 `num_of_int y` 位，再用 `val` 读为非负整数。 + */ +PROOF extern thm u64_shr_def; diff --git a/theory/c_program_logic/c_memory.c b/theory/c_program_logic/c_memory.c new file mode 100644 index 0000000000000000000000000000000000000000..7bbd37f9279a02dc44dd172186490c3b10eb6c4c --- /dev/null +++ b/theory/c_program_logic/c_memory.c @@ -0,0 +1,740 @@ +#include "proof/theory/c_program_logic/c_memory.h" +#include "proof/theory/logic/product_resource_internal.h" +#include "proof/theory/logic/resource_prop_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/c_types.c" +#require "proof/theory/c_program_logic/c_resource.c" +#require "proof/theory/c_program_logic/mem_value.c" + +PROOF static thm_list C_MEMORY_INITIAL_AXIOMS = get_all_axioms(); +PROOF static size_t C_MEMORY_AXIOMS_BEFORE = + vector_size(C_MEMORY_INITIAL_AXIOMS); + +PROOF thm pmem_ctype_distinct = get_datatype_distinctness("ctype"); + +/* ------------------------------------------------------------------------- */ +/* Scalar ABI descriptor */ +/* ------------------------------------------------------------------------- */ + +PROOF thm pmem_c_scalar_type_def = new_fun_definition(` + pmem_c_scalar_type (ty:ctype) <=> + ty == Tchar || ty == Tuchar || + ty == Tshort || ty == Tushort || + ty == Tint || ty == Tuint || + ty == Tint64 || ty == Tuint64 || + ty == Tptr +`); + +PROOF thm pmem_c_width_def = new_fun_definition(` + pmem_c_width (ty:ctype) : num = + if ty == Tchar then 1 else + if ty == Tuchar then 1 else + if ty == Tshort then 2 else + if ty == Tushort then 2 else + if ty == Tint then 4 else + if ty == Tuint then 4 else + if ty == Tint64 then 8 else + if ty == Tuint64 then 8 else + if ty == Tptr then 8 else + 0 +`); + +PROOF thm pmem_c_min_def = new_fun_definition(` + pmem_c_min (ty:ctype) : int = + if ty == Tchar then --(&128) else + if ty == Tuchar then &0 else + if ty == Tshort then --(&32768) else + if ty == Tushort then &0 else + if ty == Tint then --(&2147483648) else + if ty == Tuint then &0 else + if ty == Tint64 then --(&9223372036854775808) else + if ty == Tuint64 then &0 else + if ty == Tptr then &0 else + &0 +`); + +PROOF thm pmem_c_max_def = new_fun_definition(` + pmem_c_max (ty:ctype) : int = + if ty == Tchar then &127 else + if ty == Tuchar then &255 else + if ty == Tshort then &32767 else + if ty == Tushort then &65535 else + if ty == Tint then &2147483647 else + if ty == Tuint then &4294967295 else + if ty == Tint64 then &9223372036854775807 else + if ty == Tuint64 then &18446744073709551615 else + if ty == Tptr then &18446744073709551615 else + &0 +`); + +PROOF thm pmem_c_address_ok_def = new_fun_definition(` + pmem_c_address_ok (address:int) (ty:ctype) <=> + pmem_c_scalar_type ty && + &0 <= address && + address + &(pmem_c_width ty) - &1 <= + &18446744073709551615 && + address rem &(pmem_c_width ty) == &0 +`); + +PROOF thm pmem_uint64_address_ok_def = new_fun_definition(` + pmem_uint64_address_ok (address:int) <=> + pmem_c_address_ok address Tuint64 +`); + +PROOF thm pmem_ptr_address_ok_def = new_fun_definition(` + pmem_ptr_address_ok (address:int) <=> + pmem_c_address_ok address Tptr +`); + +PROOF thm pmem_c_value_ok_def = new_fun_definition(` + pmem_c_value_ok (ty:ctype) (integer_value:int) <=> + pmem_c_scalar_type ty && + pmem_c_min ty <= integer_value && + integer_value <= pmem_c_max ty +`); + +PROOF static thm prove_pmem_c_address_ok_tuint64(void) { + gnode root = gnode_new_with_ccl(` + forall address:int. + pmem_c_address_ok address Tuint64 <=> + &0 <= address && + address + &7 <= &18446744073709551615 && + address rem &8 == &0 + `); + thm range_normalization = int_ring_rule(` + forall address:int. + address + &8 - &1 == address + &7 + `); + CONV_TAC(root, rewrite_conv(THM_LIST( + pmem_c_address_ok_def, + pmem_c_scalar_type_def, + pmem_c_width_def, + pmem_ctype_distinct, + range_normalization))); + return gnode_prove(root); +} + +PROOF thm pmem_c_address_ok_Tuint64 = + prove_pmem_c_address_ok_tuint64(); + +/* ------------------------------------------------------------------------- */ +/* Pure physical-memory atoms */ +/* ------------------------------------------------------------------------- */ + +PROOF thm pmem_data_at_def = new_fun_definition(` + pmem_data_at + (address:int) + (ty:ctype) + (integer_value:int) : + (int,(pmem_byte_state)excl)finmap->bool = + r_and + mem_ra + (r_pure + mem_ra + (pmem_c_address_ok address ty && + pmem_c_value_ok ty integer_value)) + (pmem_scalar_at address (pmem_c_width ty) integer_value) +`); + +PROOF thm pmem_undef_data_at_def = new_fun_definition(` + pmem_undef_data_at + (address:int) + (ty:ctype) : + (int,(pmem_byte_state)excl)finmap->bool = + r_and + mem_ra + (r_pure mem_ra (pmem_c_address_ok address ty)) + (pmem_allocated_at address (pmem_c_width ty)) +`); + +PROOF thm c_allocated_at_def = new_fun_definition(` + c_allocated_at + (G:(A)ra) + (address:int) + (count:num) : + (((int,(pmem_byte_state)excl)finmap)#A)->bool = + c_lift_phys G (pmem_allocated_at address count) +`); + +PROOF static thm prove_c_allocated_at_zero(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (address:int). + c_allocated_at G address 0 == + r_emp (c_resource_ra G) + `); + CONV_TAC(root, rewrite_conv(THM_LIST( + c_allocated_at_def, + pmem_allocated_at_zero, + c_lift_phys_def, + c_resource_ra_def, + r_lift_left_emp_eq))); + return gnode_prove(root); +} + +PROOF thm c_allocated_at_zero = + prove_c_allocated_at_zero(); + +PROOF static thm prove_c_allocated_at_append(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (address:int) (m:num) (n:num). + c_allocated_at G address (m + n) == + r_sep + (c_resource_ra G) + (c_allocated_at G address m) + (c_allocated_at G (address + &m) n) + `); + CONV_TAC(root, rewrite_conv(THM_LIST( + c_allocated_at_def, + pmem_allocated_at_append, + c_lift_phys_def, + c_resource_ra_def, + r_lift_left_sep_eq))); + return gnode_prove(root); +} + +PROOF thm c_allocated_at_append = + prove_c_allocated_at_append(); + +PROOF static thm prove_pmem_data_at_allocated_at(void) { + gnode root = gnode_new_with_ccl(` + forall (address:int) (ty:ctype) (integer_value:int). + r_entails + mem_ra + (pmem_data_at address ty integer_value) + (pmem_allocated_at address (pmem_c_width ty)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + pmem_data_at_def, + r_and_def, + r_pure_def))); + body = GEN_TAC(body, "address"); + body = GEN_TAC(body, "ty"); + body = GEN_TAC(body, "integer_value"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hdata"); + body = ASMP_CONJ_TAC(body, "Hdata", "Hpure", "Hscalar"); + + thm allocated = ispecl_rule( + TERM_LIST( + `address:int`, + `pmem_c_width (ty:ctype)`, + `integer_value:int`), + pmem_scalar_at_allocated); + allocated = pure_once_rewrite_rule( + THM_LIST(r_entails_def), allocated); + allocated = spec_rule(` + resource:(int,(pmem_byte_state)excl)finmap + `, allocated); + allocated = mp_rule( + allocated, + assume_rule(` + ra_valid mem_ra + (resource:(int,(pmem_byte_state)excl)finmap) + `)); + allocated = mp_rule( + allocated, + assume_rule(` + pmem_scalar_at + (address:int) + (pmem_c_width (ty:ctype)) + (integer_value:int) + (resource:(int,(pmem_byte_state)excl)finmap) + `)); + ACCEPT_TAC(body, allocated); + return gnode_prove(root); +} + +PROOF thm pmem_data_at_allocated_at = + prove_pmem_data_at_allocated_at(); + +PROOF static thm prove_pmem_undef_data_at_allocated_at(void) { + term target = `pmem_allocated_at + (address:int) (pmem_c_width (ty:ctype))`; + thm eliminate_wrapper = ispecl_rule( + TERM_LIST( + `mem_ra`, + `r_pure mem_ra (pmem_c_address_ok (address:int) (ty:ctype))`, + target), + r_and_elim_r); + eliminate_wrapper = pure_once_rewrite_rule( + THM_LIST(gsym_rule(pmem_undef_data_at_def)), + eliminate_wrapper); + return genl_rule( + TERM_LIST(`address:int`, `ty:ctype`), eliminate_wrapper); +} + +PROOF thm pmem_undef_data_at_allocated_at = + prove_pmem_undef_data_at_allocated_at(); + +PROOF static thm prove_pmem_allocated_at_to_undef_data_at(void) { + gnode root = gnode_new_with_ccl(` + forall (address:int) (ty:ctype). + pmem_c_address_ok address ty ==> + r_entails + mem_ra + (pmem_allocated_at address (pmem_c_width ty)) + (pmem_undef_data_at address ty) + `); + gnode body = AUTO_INTROS_TAC(root); + term allocated = `pmem_allocated_at + (address:int) (pmem_c_width (ty:ctype))`; + thm reflexivity = ispecl_rule( + TERM_LIST(`mem_ra`, allocated), r_entails_refl); + thm introduce = ispecl_rule( + TERM_LIST( + `mem_ra`, + `pmem_c_address_ok (address:int) (ty:ctype)`, + allocated, + allocated), + r_pure_and_intro); + thm with_address = match_mp_rule( + introduce, + assume_rule(`pmem_c_address_ok (address:int) (ty:ctype)`)); + thm result = match_mp_rule(with_address, reflexivity); + result = pure_once_rewrite_rule( + THM_LIST(gsym_rule(pmem_undef_data_at_def)), result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm pmem_allocated_at_to_undef_data_at = + prove_pmem_allocated_at_to_undef_data_at(); + +PROOF static thm prove_pmem_data_at_to_undef_data_at(void) { + gnode root = gnode_new_with_ccl(` + forall (address:int) (ty:ctype) (integer_value:int). + r_entails + mem_ra + (pmem_data_at address ty integer_value) + (pmem_undef_data_at address ty) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + pmem_data_at_def, + pmem_undef_data_at_def, + r_and_def, + r_pure_def))); + body = GEN_TAC(body, "address"); + body = GEN_TAC(body, "ty"); + body = GEN_TAC(body, "integer_value"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hdata"); + body = ASMP_CONJ_TAC(body, "Hdata", "Hpure", "Hscalar"); + body = ASMP_CONJ_TAC( + body, "Hpure", "Haddress_ok", "Hvalue_ok"); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`pmem_c_address_ok (address:int) (ty:ctype)`)); + + thm allocated = ispecl_rule( + TERM_LIST( + `address:int`, + `pmem_c_width (ty:ctype)`, + `integer_value:int`), + pmem_scalar_at_allocated); + allocated = pure_once_rewrite_rule( + THM_LIST(r_entails_def), allocated); + allocated = spec_rule(` + resource:(int,(pmem_byte_state)excl)finmap + `, allocated); + allocated = mp_rule( + allocated, + assume_rule(` + ra_valid mem_ra + (resource:(int,(pmem_byte_state)excl)finmap) + `)); + allocated = mp_rule( + allocated, + assume_rule(` + pmem_scalar_at + (address:int) + (pmem_c_width (ty:ctype)) + (integer_value:int) + (resource:(int,(pmem_byte_state)excl)finmap) + `)); + ACCEPT_TAC(result[1], allocated); + return gnode_prove(root); +} + +PROOF thm pmem_data_at_to_undef_data_at = + prove_pmem_data_at_to_undef_data_at(); + +PROOF static thm prove_pmem_undef_scalar_at_tuint64(void) { + gnode root = gnode_new_with_ccl(` + forall address:int. + pmem_c_address_ok address Tuint64 ==> + r_entails + mem_ra + (pmem_undef_scalar_at address 8) + (pmem_undef_data_at address Tuint64) + `); + gnode body = GEN_TAC(root, "address"); + body = DISCH_TAC(body, "Haddress_ok"); + + term source = `pmem_undef_scalar_at (address:int) 8`; + term allocated = `pmem_allocated_at (address:int) 8`; + term address_ok = `pmem_c_address_ok (address:int) Tuint64`; + thm strict_to_allocated = ispecl_rule( + TERM_LIST(`8:num`, `address:int`), + pmem_undef_scalar_at_allocated); + thm introduce_pure = ispecl_rule( + TERM_LIST(`mem_ra`, address_ok, source, allocated), + r_pure_and_intro); + thm with_address = match_mp_rule( + introduce_pure, + assume_rule(address_ok)); + thm untyped_to_conjunction = match_mp_rule( + with_address, + strict_to_allocated); + + thm typed_definition = inst_rule( + TERM_PAIR_LIST( + (term_pair){`Tuint64:ctype`, `ty:ctype`}), + pmem_undef_data_at_def); + typed_definition = rewrite_rule( + THM_LIST(pmem_c_width_def, pmem_ctype_distinct), + typed_definition); + thm typed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(typed_definition)), + untyped_to_conjunction); + ACCEPT_TAC(body, typed); + return gnode_prove(root); +} + +PROOF thm pmem_undef_scalar_at_Tuint64 = + prove_pmem_undef_scalar_at_tuint64(); + +/* ------------------------------------------------------------------------- */ +/* Complete C-resource atoms */ +/* ------------------------------------------------------------------------- */ + +PROOF thm c_data_at_def = new_fun_definition(` + c_data_at + (G:(A)ra) + (address:int) + (ty:ctype) + (integer_value:int) : + (((int,(pmem_byte_state)excl)finmap)#A)->bool = + c_lift_phys G (pmem_data_at address ty integer_value) +`); + +PROOF thm c_undef_data_at_def = new_fun_definition(` + c_undef_data_at + (G:(A)ra) + (address:int) + (ty:ctype) : + (((int,(pmem_byte_state)excl)finmap)#A)->bool = + c_lift_phys G (pmem_undef_data_at address ty) +`); + +PROOF static thm prove_c_allocated_at_to_undef_data_at(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (address:int) (ty:ctype). + pmem_c_address_ok address ty ==> + r_entails + (c_resource_ra G) + (c_allocated_at G address (pmem_c_width ty)) + (c_undef_data_at G address ty) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, pure_rewrite_conv(THM_LIST( + c_allocated_at_def, + c_undef_data_at_def, + c_lift_phys_def, + c_resource_ra_def))); + thm lift = ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `pmem_allocated_at + (address:int) (pmem_c_width (ty:ctype))`, + `pmem_undef_data_at (address:int) (ty:ctype)`), + r_lift_left_entails); + thm physical = ispecl_rule( + TERM_LIST(`address:int`, `ty:ctype`), + pmem_allocated_at_to_undef_data_at); + physical = match_mp_rule( + physical, + assume_rule(`pmem_c_address_ok (address:int) (ty:ctype)`)); + ACCEPT_TAC(body, match_mp_rule(lift, physical)); + return gnode_prove(root); +} + +PROOF thm c_allocated_at_to_undef_data_at = + prove_c_allocated_at_to_undef_data_at(); + +PROOF static thm prove_c_data_at_to_undef_data_at(void) { + gnode root = gnode_new_with_ccl(` + forall + (G:(A)ra) + (address:int) + (ty:ctype) + (integer_value:int). + r_entails + (c_resource_ra G) + (c_data_at G address ty integer_value) + (c_undef_data_at G address ty) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, pure_rewrite_conv(THM_LIST( + c_data_at_def, + c_undef_data_at_def, + c_lift_phys_def, + c_resource_ra_def))); + thm lift = ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `pmem_data_at + (address:int) (ty:ctype) (integer_value:int)`, + `pmem_undef_data_at (address:int) (ty:ctype)`), + r_lift_left_entails); + thm physical = ispecl_rule( + TERM_LIST(`address:int`, `ty:ctype`, `integer_value:int`), + pmem_data_at_to_undef_data_at); + ACCEPT_TAC(body, match_mp_rule(lift, physical)); + return gnode_prove(root); +} + +PROOF thm c_data_at_to_undef_data_at = + prove_c_data_at_to_undef_data_at(); + +PROOF static thm prove_c_data_at_allocated_at(void) { + gnode root = gnode_new_with_ccl(` + forall + (G:(A)ra) + (address:int) + (ty:ctype) + (integer_value:int). + r_entails + (c_resource_ra G) + (c_data_at G address ty integer_value) + (c_allocated_at G address (pmem_c_width ty)) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, pure_rewrite_conv(THM_LIST( + c_data_at_def, + c_allocated_at_def, + c_lift_phys_def, + c_resource_ra_def))); + thm lift = ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `pmem_data_at + (address:int) (ty:ctype) (integer_value:int)`, + `pmem_allocated_at + (address:int) (pmem_c_width (ty:ctype))`), + r_lift_left_entails); + thm physical = ispecl_rule( + TERM_LIST(`address:int`, `ty:ctype`, `integer_value:int`), + pmem_data_at_allocated_at); + ACCEPT_TAC(body, match_mp_rule(lift, physical)); + return gnode_prove(root); +} + +PROOF thm c_data_at_allocated_at = + prove_c_data_at_allocated_at(); + +PROOF static thm prove_c_undef_data_at_allocated_at(void) { + gnode root = gnode_new_with_ccl(` + forall (G:(A)ra) (address:int) (ty:ctype). + r_entails + (c_resource_ra G) + (c_undef_data_at G address ty) + (c_allocated_at G address (pmem_c_width ty)) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, pure_rewrite_conv(THM_LIST( + c_undef_data_at_def, + c_allocated_at_def, + c_lift_phys_def, + c_resource_ra_def))); + thm lift = ispecl_rule( + TERM_LIST( + `mem_ra`, `G:(A)ra`, + `pmem_undef_data_at (address:int) (ty:ctype)`, + `pmem_allocated_at + (address:int) (pmem_c_width (ty:ctype))`), + r_lift_left_entails); + thm physical = ispecl_rule( + TERM_LIST(`address:int`, `ty:ctype`), + pmem_undef_data_at_allocated_at); + ACCEPT_TAC(body, match_mp_rule(lift, physical)); + return gnode_prove(root); +} + +PROOF thm c_undef_data_at_allocated_at = + prove_c_undef_data_at_allocated_at(); + +PROOF static thm prove_c_data_at_pure_range(void) { + term goal_tm = ` + forall + (G:(A)ra) + (address:int) + (ty:ctype) + (integer_value:int). + r_entails + (c_resource_ra G) + (c_data_at G address ty integer_value) + (r_pure + (c_resource_ra G) + (pmem_c_min ty <= integer_value && + integer_value <= pmem_c_max ty)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + c_data_at_def, + c_lift_phys_def, + r_lift_left_def, + pmem_data_at_def, + r_and_def, + r_pure_def, + pmem_c_value_ok_def))); + body = GEN_TAC(body, "G"); + body = GEN_TAC(body, "address"); + body = GEN_TAC(body, "ty"); + body = GEN_TAC(body, "integer_value"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hdata"); + body = ASMP_CONJ_TAC(body, "Hdata", "Hphysical", "Hghost_unit"); + body = ASMP_CONJ_TAC(body, "Hphysical", "Hpure", "Hscalar"); + body = ASMP_CONJ_TAC(body, "Hpure", "Haddress_ok", "Hvalue_ok"); + body = ASMP_CONJ_TAC(body, "Hvalue_ok", "Hscalar_type", "Hbounds"); + ACCEPT_TAC( + body, + assume_rule(` + pmem_c_min (ty:ctype) <= (integer_value:int) && + integer_value <= pmem_c_max ty + `)); + return gnode_prove(root); +} + +PROOF static thm c_data_at_pure_range = + prove_c_data_at_pure_range(); + +PROOF static thm prove_c_data_at_value_range(void) { + term goal_tm = ` + forall + (G:(A)ra) + (address:int) + (ty:ctype) + (integer_value:int). + r_entails + (c_resource_ra G) + (c_data_at G address ty integer_value) + (r_sep + (c_resource_ra G) + (c_data_at G address ty integer_value) + (r_fact + (c_resource_ra G) + (pmem_c_min ty <= integer_value && + integer_value <= pmem_c_max ty))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term R = `c_resource_ra (G:(A)ra)`; + term source = `c_data_at + (G:(A)ra) (address:int) (ty:ctype) (integer_value:int)`; + term bounds = `pmem_c_min (ty:ctype) <= (integer_value:int) && + integer_value <= pmem_c_max ty`; + term pure_bounds = `r_pure + (c_resource_ra (G:(A)ra)) + (pmem_c_min (ty:ctype) <= (integer_value:int) && + integer_value <= pmem_c_max ty)`; + + thm range_rule = ispecl_rule( + TERM_LIST( + `G:(A)ra`, `address:int`, `ty:ctype`, `integer_value:int`), + c_data_at_pure_range); + thm reflexivity = ispecl_rule(TERM_LIST(R, source), r_entails_refl); + thm combined = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST(R, source, pure_bounds, source), + r_and_intro), + range_rule), + reflexivity); + + thm fact_sep = ispecl_rule( + TERM_LIST(R, bounds, source), + r_fact_sep_r_eq); + thm replace_target = beta_rule(ap_term_rule( + `\target:(((int,(pmem_byte_state)excl)finmap)#A)->bool. + r_entails + (c_resource_ra (G:(A)ra)) + (c_data_at G (address:int) (ty:ctype) (integer_value:int)) + target`, + gsym_rule(fact_sep))); + ACCEPT_TAC(body, eq_mp_rule(replace_target, combined)); + return gnode_prove(root); +} + +PROOF thm c_data_at_value_range = + prove_c_data_at_value_range(); + +/* ------------------------------------------------------------------------- */ +/* Conservative-extension audit */ +/* ------------------------------------------------------------------------- */ + +PROOF static int audit_c_memory(void) { + thm_list public_theorems = THM_LIST( + pmem_ctype_distinct, + pmem_c_scalar_type_def, + pmem_c_width_def, + pmem_c_min_def, + pmem_c_max_def, + pmem_c_address_ok_def, + pmem_uint64_address_ok_def, + pmem_ptr_address_ok_def, + pmem_c_value_ok_def, + pmem_c_address_ok_Tuint64, + pmem_data_at_def, + pmem_undef_data_at_def, + c_allocated_at_def, + c_allocated_at_zero, + c_allocated_at_append, + pmem_data_at_allocated_at, + pmem_undef_data_at_allocated_at, + pmem_allocated_at_to_undef_data_at, + pmem_data_at_to_undef_data_at, + pmem_undef_scalar_at_Tuint64, + c_data_at_def, + c_undef_data_at_def, + c_allocated_at_to_undef_data_at, + c_data_at_to_undef_data_at, + c_data_at_allocated_at, + c_undef_data_at_allocated_at, + c_data_at_value_range); + + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "C memory theorem %zu is empty", i); + term_list theorem_hypotheses = hyp(public_theorems[i]); + size_t hypothesis_count = vector_size(theorem_hypotheses); + ENSURE_COND(hypothesis_count == 0, + "C memory theorem %zu has hypotheses", i); + } + thm_list final_axioms = get_all_axioms(); + size_t final_axiom_count = vector_size(final_axioms); + ENSURE_COND(final_axiom_count == C_MEMORY_AXIOMS_BEFORE, + "C memory theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_c_memory"); + return -1; +} + +PROOF static int _C_MEMORY_AUDIT = audit_c_memory(); diff --git a/theory/c_program_logic/c_memory.h b/theory/c_program_logic/c_memory.h new file mode 100644 index 0000000000000000000000000000000000000000..26b45b59197fc44f195620587fd12bd2f56ac5e3 --- /dev/null +++ b/theory/c_program_logic/c_memory.h @@ -0,0 +1,471 @@ +/** + * @file c_memory.h + * @brief Scalar C-memory assertions over the byte-addressed physical resource. + * + * This module is the only layer here that interprets the existing C* `ctype` + * ABI. It supports exactly the nine scalar constructors + * + * Tchar, Tuchar, Tshort, Tushort, Tint, Tuint, + * Tint64, Tuint64, Tptr. + * + * `Tstruct` and `Tfun` are not scalar object types. The width/min/max functions + * are total and return zero on unsupported types, but every public memory + * predicate carries an explicit scalar guard, so that fallback has no storage + * semantics. + * + * The ABI is provisional and self-contained: 8-bit bytes, little-endian + * scalar representations, 16/32/64-bit integer widths, 64-bit pointers, and a + * 64-bit concrete address space. This theory does not use the legacy + * `sizeof`, `min_of`, `max_of`, or `isvalidptr_*` constants. + * + * `pmem_*` assertions have type `Mem -> bool`; `c_*` assertions are their + * exact lifts to `Prop_G = (Mem # Ghost_G) -> bool`. In formulas below, + * `P ⊢_mem Q` abbreviates `r_entails mem_ra P Q`, while `P ⊢_G Q` + * abbreviates `r_entails (c_resource_ra G) P Q`. + * + * ABI guards are embedded with resource-independent `r_pure` under additive + * `r_and`, so they constrain the same owned bytes without consuming a second + * resource. When a side condition is exposed as a separating conjunct, this + * layer instead uses exact-unit `r_fact`. + * + * Raw equalities in this header are concrete computation or normalization + * equations for the named memory predicates. They are not generic BI + * connective laws; public laws of the core BI assertion algebra remain stated + * with validity-sensitive `r_equiv`. + */ + +#pragma once + +#include "proof/theory/c_program_logic/c_types.h" +#include "proof/theory/c_program_logic/c_resource.h" +#include "proof/theory/c_program_logic/mem_value.h" + +/* ------------------------------------------------------------------------- */ +/* Scalar ABI descriptor */ +/* ------------------------------------------------------------------------- */ + +/* + * Constructor distinctness for the built-in `ctype` datatype. This theorem + * is obtained from HOL Light's datatype package (not postulated): + * + * ```text + * ~(Ti args_i == Tj args_j) + * ``` + * + * for every pair of distinct `ctype` constructors `Ti` and `Tj`, with all + * constructor arguments universally quantified. This is the conjunction + * returned by `get_datatype_distinctness("ctype")`. + * + * It is deliberately a proof-side normalization rule. Clients specialize a + * memory theorem to a concrete `ctype`, rewrite with this theorem, and only + * then expose the resulting `ctype`-free assertion to QCP. + * + * `ctype` 的任意两个不同构造子都不相等，具体类型实例因而可用这些判别式消去不可能分支。 + */ +PROOF extern thm pmem_ctype_distinct; + +/* + * Scalar-type discriminator: + * + * ```text + * pmem_c_scalar_type ty ⇔ + * ty = Tchar ∨ ty = Tuchar ∨ + * ty = Tshort ∨ ty = Tushort ∨ + * ty = Tint ∨ ty = Tuint ∨ + * ty = Tint64 ∨ ty = Tuint64 ∨ + * ty = Tptr + * ``` + * + * In particular every `Tstruct name fields types` and + * `Tfun argument_names argument_types return_type` yields false. + * + * `pmem_c_scalar_type` 只接受九种内建整数或指针类型，并明确排除结构体与函数类型。 + */ +PROOF extern thm pmem_c_scalar_type_def; + +/* + * ```text + * pmem_c_width (ty:ctype) = + * if ty == Tchar then 1 else + * if ty == Tuchar then 1 else + * if ty == Tshort then 2 else + * if ty == Tushort then 2 else + * if ty == Tint then 4 else + * if ty == Tuint then 4 else + * if ty == Tint64 then 8 else + * if ty == Tuint64 then 8 else + * if ty == Tptr then 8 else 0 + * ``` + * + * C 标量宽度依次为 1、2、4 或 8 字节；不受支持的结构体和函数类型落到零宽度。 + */ +PROOF extern thm pmem_c_width_def; + +/* + * ```text + * pmem_c_min (ty:ctype) = + * if ty == Tchar then --(&128) else + * if ty == Tuchar then &0 else + * if ty == Tshort then --(&32768) else + * if ty == Tushort then &0 else + * if ty == Tint then --(&2147483648) else + * if ty == Tuint then &0 else + * if ty == Tint64 then --(&9223372036854775808) else + * if ty == Tuint64 then &0 else + * if ty == Tptr then &0 else &0 + * ``` + * + * 有符号标量的下界分别采用对应补码最小值，无符号整数和指针下界为零，不支持类型也返回零。 + */ +PROOF extern thm pmem_c_min_def; + +/* + * ```text + * pmem_c_max (ty:ctype) = + * if ty == Tchar then &127 else + * if ty == Tuchar then &255 else + * if ty == Tshort then &32767 else + * if ty == Tushort then &65535 else + * if ty == Tint then &2147483647 else + * if ty == Tuint then &4294967295 else + * if ty == Tint64 then &9223372036854775807 else + * if ty == Tuint64 then &18446744073709551615 else + * if ty == Tptr then &18446744073709551615 else &0 + * ``` + * + * 各标量上界按其 8、16、32 或 64 位有符号性计算，64 位指针与 `Tuint64` 共用 `2^64-1`。 + */ +PROOF extern thm pmem_c_max_def; + +/* + * Address validity, with public atom argument order `(address,type)`: + * + * ```text + * pmem_c_address_ok address ty ⇔ + * pmem_c_scalar_type ty ∧ + * &0 <= address ∧ + * address + &(pmem_c_width ty) - &1 <= + * &18446744073709551615 ∧ + * address rem &(pmem_c_width ty) = &0 + * ``` + * + * Thus the complete byte interval is in the concrete 64-bit address space + * and the base is naturally aligned to the scalar width. + * + * 地址合法要求类型为受支持标量、完整字节区间落在 64 位地址空间内，并按标量宽度自然对齐。 + */ +PROOF extern thm pmem_c_address_ok_def; + +/** + * QCP-safe closed specialization: + * + * ```text + * pmem_uint64_address_ok address ⇔ pmem_c_address_ok address Tuint64 + * ``` + * + * The unary predicate avoids placing a `ctype` term inside an ordinary QCP + * pure predicate. + * + * `pmem_uint64_address_ok` 是 `Tuint64` 地址合法性的闭合一元版本，便于在不暴露 `ctype` 参数时使用。 + */ +PROOF extern thm pmem_uint64_address_ok_def; + +/** + * ```text + * pmem_ptr_address_ok (address:int) <=> + * pmem_c_address_ok address Tptr + * ``` + * + * `pmem_ptr_address_ok` 恰好把通用 C 地址合法性专门化到 64 位指针类型 `Tptr`。 + */ +PROOF extern thm pmem_ptr_address_ok_def; + +/* + * Scalar value range: + * + * ```text + * pmem_c_value_ok ty integer_value ⇔ + * pmem_c_scalar_type ty ∧ + * pmem_c_min ty <= integer_value ∧ + * integer_value <= pmem_c_max ty. + * ``` + * + * 值合法要求 `ty` 是受支持标量，且整数值位于该类型的闭区间 `[pmem_c_min ty, pmem_c_max ty]`。 + */ +PROOF extern thm pmem_c_value_ok_def; + +/** + * Exact ABI characterization for a `Tuint64` lvalue address: + * + * ```text + * ⊢ ∀address:int. pmem_c_address_ok address Tuint64 ⇔ + * 0 ≤ address ∧ + * address + 7 ≤ 18446744073709551615 ∧ + * address rem 8 = 0. + * ``` + * + * In particular, ownership of eight consecutive bytes does not imply this + * theorem's alignment conjunct; callers carving a typed cell must establish + * it as a separate resource-independent HOL side condition. + * + * `Tuint64` 的合法基址恰好是非负、八字节区间不越过 `2^64-1` 且能被 8 整除的地址。 + */ +PROOF extern thm pmem_c_address_ok_Tuint64; + +/* ------------------------------------------------------------------------- */ +/* Physical-only typed-memory assertions */ +/* ------------------------------------------------------------------------- */ + +/* + * Initialized scalar storage: + * + * ```text + * pmem_data_at address ty integer_value == + * r_and mem_ra + * (r_pure mem_ra + * (pmem_c_address_ok address ty ∧ + * pmem_c_value_ok ty integer_value)) + * (pmem_scalar_at address (pmem_c_width ty) integer_value). + * ``` + * + * The second conjunct owns the exact little-endian bytes; the first imposes + * the C ABI side conditions without consuming a second resource. + * + * `pmem_data_at` 在同一资源上同时要求地址和值满足 C ABI，并精确拥有该值按类型宽度编码的小端字节。 + */ +PROOF extern thm pmem_data_at_def; + +/* + * Owned scalar storage of unknown current contents at a valid C address: + * + * ```text + * pmem_undef_data_at address ty == + * r_and mem_ra + * (r_pure mem_ra (pmem_c_address_ok address ty)) + * (pmem_allocated_at address (pmem_c_width ty)). + * ``` + * + * Each byte may be physically uninitialized or initialized. The predicate + * grants writable ownership but no readable value; QCP therefore permits an + * overwriting store but not a load. `pmem_undef_scalar_at` remains available + * separately when strict physical uninitialization matters to a proof. + * + * `pmem_undef_data_at` 要求合法类型地址并拥有相应宽度的任意状态字节；它保证可写分配，但不声称字节为 `PMemUninit`。 + */ +PROOF extern thm pmem_undef_data_at_def; + +/** + * ```text + * forall (address:int) (ty:ctype) (integer_value:int). + * r_entails mem_ra + * (pmem_data_at address ty integer_value) + * (pmem_allocated_at address (pmem_c_width ty)) + * ``` + * + * 精确的物理 `data_at` 可遗忘类型约束和具体字节值，留下同地址、类型宽度大小的 allocated 区域。 + */ +PROOF extern thm pmem_data_at_allocated_at; + +/** + * ```text + * forall (address:int) (ty:ctype). + * r_entails mem_ra + * (pmem_undef_data_at address ty) + * (pmem_allocated_at address (pmem_c_width ty)) + * ``` + * + * 物理 `undef_data_at` 可遗忘其合法地址守卫，留下同地址、类型宽度大小的任意状态 allocated 区域。 + */ +PROOF extern thm pmem_undef_data_at_allocated_at; + +/** + * A valid-address allocated range can be viewed as unknown-content typed + * storage: + * + * ```text + * forall (address:int) (ty:ctype). + * pmem_c_address_ok address ty ==> + * r_entails mem_ra + * (pmem_allocated_at address (pmem_c_width ty)) + * (pmem_undef_data_at address ty) + * ``` + * + * 若地址对类型 `ty` 合法，则该地址起 `pmem_c_width ty` 个 allocated 字节足以建立物理 `undef_data_at`。 + */ +PROOF extern thm pmem_allocated_at_to_undef_data_at; + +/** + * ```text + * forall (address:int) (ty:ctype) (integer_value:int). + * r_entails mem_ra + * (pmem_data_at address ty integer_value) + * (pmem_undef_data_at address ty) + * ``` + * + * 物理 `data_at` 可遗忘已初始化字节承载的具体值，得到同地址同类型的 unknown-content `undef_data_at`。 + */ +PROOF extern thm pmem_data_at_to_undef_data_at; + +/** + * View eight strictly uninitialized bytes as unknown-content `Tuint64` + * cell, provided the independent ABI address obligation has been proved: + * + * ```text + * ⊢ ∀address. pmem_c_address_ok address Tuint64 ⇒ + * pmem_undef_scalar_at address 8 ⊢_mem + * pmem_undef_data_at address Tuint64. + * ``` + * + * 在独立证明 `Tuint64` 地址合法后，连续八个确为 `PMemUninit` 的字节可弱化为该地址的 `Tuint64` unknown-content 单元。 + */ +PROOF extern thm pmem_undef_scalar_at_Tuint64; + +/* ------------------------------------------------------------------------- */ +/* Exact lifts to the complete C resource */ +/* ------------------------------------------------------------------------- */ + +/** + * Exact physical lift of `count` arbitrary allocated bytes. This assertion + * carries no C type, value, initialization-state uniformity, alignment, or + * QCP load/store role: + * + * ```text + * c_allocated_at G address count == + * c_lift_phys G (pmem_allocated_at address count). + * ``` + * + * `c_allocated_at G address count` 精确提升物理 allocated 区域到完整 C 资源，并要求 ghost 投影为空。 + */ +PROOF extern thm c_allocated_at_def; + +/* + * Exact physical lift with an empty ghost projection: + * + * ```text + * c_data_at G address ty integer_value == + * c_lift_phys G (pmem_data_at address ty integer_value). + * ``` + * + * `c_data_at G address ty value` 精确提升物理 typed initialized 单元到完整 C 资源，不携带 ghost 片段。 + */ +PROOF extern thm c_data_at_def; + +/* + * Exact physical lift with an empty ghost projection: + * + * ```text + * c_undef_data_at G address ty == + * c_lift_phys G (pmem_undef_data_at address ty). + * ``` + * + * `c_undef_data_at G address ty` 精确提升物理 unknown-content typed 单元到完整 C 资源，不携带 ghost 片段。 + */ +PROOF extern thm c_undef_data_at_def; + +/** + * ```text + * forall (G:(A)ra) (address:int). + * c_allocated_at G address 0 == r_emp (c_resource_ra G) + * ``` + * This is a raw equation for the named memory predicate, not a generic BI + * connective law. + * + * 零长度 `c_allocated_at` 不占有物理字节且 ghost 投影为空，因此原始断言等于完整 C 资源的 `emp`。 + */ +PROOF extern thm c_allocated_at_zero; + +/** + * Concrete normalization for adjacent arbitrary allocated byte ranges: + * + * ```text + * forall G address m n. + * c_allocated_at G address (m + n) == + * r_sep (c_resource_ra G) + * (c_allocated_at G address m) + * (c_allocated_at G (address + &m) n). + * ``` + * + * The equation only regroups the same physical byte range. It adds neither + * C typing nor initialization information. + * + * 长度 `m+n` 的 C allocated 区域等于长度 `m` 的前缀与从 `address+m` 开始的长度 `n` 后缀之分离合取。 + */ +PROOF extern thm c_allocated_at_append; + +/** + * ```text + * forall (G:(A)ra) (address:int) (ty:ctype). + * pmem_c_address_ok address ty ==> + * r_entails (c_resource_ra G) + * (c_allocated_at G address (pmem_c_width ty)) + * (c_undef_data_at G address ty) + * ``` + * + * 若 `address` 对 `ty` 合法，则完整 C 资源中的类型宽度 allocated 区域蕴含同地址同类型的 `c_undef_data_at`。 + */ +PROOF extern thm c_allocated_at_to_undef_data_at; + +/** + * ```text + * forall (G:(A)ra) (address:int) (ty:ctype) (integer_value:int). + * r_entails (c_resource_ra G) + * (c_data_at G address ty integer_value) + * (c_undef_data_at G address ty) + * ``` + * + * 完整 C 资源中的 `c_data_at` 可遗忘具体已初始化值，得到同地址同类型的 `c_undef_data_at`。 + */ +PROOF extern thm c_data_at_to_undef_data_at; + +/** + * ```text + * forall (G:(A)ra) (address:int) (ty:ctype) (integer_value:int). + * r_entails (c_resource_ra G) + * (c_data_at G address ty integer_value) + * (c_allocated_at G address (pmem_c_width ty)) + * ``` + * + * 完整 C 资源中的 `c_data_at` 可遗忘类型和值，得到同地址、类型宽度大小的 `c_allocated_at`。 + */ +PROOF extern thm c_data_at_allocated_at; + +/** + * ```text + * forall (G:(A)ra) (address:int) (ty:ctype). + * r_entails (c_resource_ra G) + * (c_undef_data_at G address ty) + * (c_allocated_at G address (pmem_c_width ty)) + * ``` + * + * 完整 C 资源中的 `c_undef_data_at` 可遗忘合法地址守卫，得到同地址、类型宽度大小的 `c_allocated_at`。 + */ +PROOF extern thm c_undef_data_at_allocated_at; + +/** + * Initialized scalar ownership exposes its represented-value bounds while + * retaining the cell: + * + * ```text + * forall + * (G:(A)ra) + * (address:int) + * (ty:ctype) + * (integer_value:int). + * r_entails + * (c_resource_ra G) + * (c_data_at G address ty integer_value) + * (r_sep + * (c_resource_ra G) + * (c_data_at G address ty integer_value) + * (r_fact + * (c_resource_ra G) + * (pmem_c_min ty <= integer_value && + * integer_value <= pmem_c_max ty))) + * ``` + * + * `r_fact`, rather than resource-independent `r_pure`, makes the exposed + * bounds an exact-unit spatial conjunct. + * + * `c_data_at` 可保留原 typed 单元所有权，同时分离出 `value` 位于该类型上下界之间的 exact-unit fact。 + */ +PROOF extern thm c_data_at_value_range; diff --git a/theory/c_program_logic/c_resource.c b/theory/c_program_logic/c_resource.c new file mode 100644 index 0000000000000000000000000000000000000000..c2473761e7aac6e2368e747481f497fbf96ab6d6 --- /dev/null +++ b/theory/c_program_logic/c_resource.c @@ -0,0 +1,131 @@ +#include "proof/theory/c_program_logic/c_resource.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/mem_own.c" +#require "proof/theory/logic/product_resource.c" + +PROOF static size_t C_RESOURCE_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm c_resource_ra_def = new_fun_definition(` + c_resource_ra + (G:(A)ra) : + (((int,(pmem_byte_state)excl)finmap)#A)ra = + prod_ra mem_ra G +`); + +PROOF static thm prove_c_resource_ra_unit(void) { + term goal_tm = ` + forall G:(A)ra. + ra_unit (c_resource_ra G) == + (ra_unit mem_ra,ra_unit G) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(c_resource_ra_def, prod_ra_unit))); + return gnode_prove(root); +} + +PROOF thm c_resource_ra_unit = prove_c_resource_ra_unit(); + +PROOF static thm prove_c_resource_ra_op(void) { + term goal_tm = ` + forall + (G:(A)ra) + (x:((int,(pmem_byte_state)excl)finmap)#A) + (y:((int,(pmem_byte_state)excl)finmap)#A). + ra_op (c_resource_ra G) x y == + (ra_op mem_ra (FST x) (FST y), + ra_op G (SND x) (SND y)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(c_resource_ra_def, prod_ra_op))); + return gnode_prove(root); +} + +PROOF thm c_resource_ra_op = prove_c_resource_ra_op(); + +PROOF static thm prove_c_resource_ra_valid(void) { + term goal_tm = ` + forall + (G:(A)ra) + (resource:((int,(pmem_byte_state)excl)finmap)#A). + ra_valid (c_resource_ra G) resource <=> + ra_valid mem_ra (FST resource) && + ra_valid G (SND resource) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(c_resource_ra_def, prod_ra_valid))); + return gnode_prove(root); +} + +PROOF thm c_resource_ra_valid = prove_c_resource_ra_valid(); + +PROOF thm c_lift_phys_def = new_fun_definition(` + c_lift_phys + (G:(A)ra) + (P:(int,(pmem_byte_state)excl)finmap->bool) = + r_lift_left mem_ra G P +`); + +PROOF thm c_lift_ghost_def = new_fun_definition(` + c_lift_ghost + (G:(A)ra) + (Q:A->bool) = + r_lift_right mem_ra G Q +`); + +PROOF thm c_ghost_own_def = new_fun_definition(` + c_ghost_own + (G:(A)ra) + (ghost:A) = + c_lift_ghost G (r_own G ghost) +`); + +PROOF thm c_pmem_uninit_at_def = new_fun_definition(` + c_pmem_uninit_at + (G:(A)ra) + (address:int) = + c_lift_phys G (r_own mem_ra (pmem_uninit address)) +`); + +PROOF thm c_pmem_byte_at_def = new_fun_definition(` + c_pmem_byte_at + (G:(A)ra) + (address:int) + (byte:int) = + c_lift_phys G (r_own mem_ra (pmem_byte address byte)) +`); + +PROOF static int audit_c_resource(void) { + thm_list public_theorems = THM_LIST( + c_resource_ra_def, + c_resource_ra_unit, + c_resource_ra_op, + c_resource_ra_valid, + c_lift_phys_def, + c_lift_ghost_def, + c_ghost_own_def, + c_pmem_uninit_at_def, + c_pmem_byte_at_def); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "C resource theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "C resource theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == C_RESOURCE_AXIOMS_BEFORE, + "C resource theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_c_resource"); + return -1; +} + +PROOF static int _C_RESOURCE_AUDIT = audit_c_resource(); diff --git a/theory/c_program_logic/c_resource.h b/theory/c_program_logic/c_resource.h new file mode 100644 index 0000000000000000000000000000000000000000..aecf6998df1292fa0b49093178682a80b2499922 --- /dev/null +++ b/theory/c_program_logic/c_resource.h @@ -0,0 +1,130 @@ +/** + * @file c_resource.h + * @brief Physical memory paired with one complete global ghost RA. + * + * The caller supplies `G:(A)ra` as the algebra of the entire global ghost + * state. `c_resource_ra` does not insert an implicit name map: + * + * ```text + * c_resource_ra G == prod_ra mem_ra G + * carrier = Mem # A. + * ``` + * + * When names are required, callers choose `G = named_ra R` explicitly; when + * several protocols are required, they compose their complete global algebra + * explicitly before selecting `G`. + * + * `c_lift_phys` and `c_lift_ghost` are exact product lifts: the complementary + * projection must be the corresponding RA unit. The primitive one-byte + * physical assertions are kept in this boundary module alongside the lifts, + * so this header intentionally depends on the physical ownership layer + * `mem_own.h` as well as generic product-resource logic. + */ + +#pragma once + +#include "proof/theory/c_program_logic/mem_own.h" +#include "proof/theory/logic/product_resource.h" + +/* Complete C resource and its componentwise algebra. */ +/** + * ```text + * c_resource_ra (G:(A)ra) == prod_ra mem_ra G + * ``` + * Both sides have type + * `(((int,(pmem_byte_state)excl)finmap)#A)ra`. + * + * 完整 C 资源代数正是物理内存 `mem_ra` 与调用者提供的全局 ghost 代数 `G` 的乘积。 + */ +PROOF extern thm c_resource_ra_def; + +/** + * ```text + * forall G:(A)ra. ra_unit (c_resource_ra G) == + * (ra_unit mem_ra,ra_unit G) + * ``` + * + * 完整 C 资源的单位元逐分量组成，即空物理内存与 `G` 的单位元配对。 + */ +PROOF extern thm c_resource_ra_unit; + +/** + * ```text + * forall (G:(A)ra) (x:Mem#A) (y:Mem#A). + * ra_op (c_resource_ra G) x y == + * (ra_op mem_ra (FST x) (FST y), + * ra_op G (SND x) (SND y)) + * ``` + * Here `Mem` abbreviates `(int,(pmem_byte_state)excl)finmap`. + * + * 两个完整 C 资源组合时，物理投影按 `mem_ra` 组合，ghost 投影独立按 `G` 组合。 + */ +PROOF extern thm c_resource_ra_op; + +/** + * ```text + * forall (G:(A)ra) (resource:Mem#A). + * ra_valid (c_resource_ra G) resource <=> + * ra_valid mem_ra (FST resource) && + * ra_valid G (SND resource) + * ``` + * Here `Mem` abbreviates `(int,(pmem_byte_state)excl)finmap`. + * + * 一对完整 C 资源有效，当且仅当其物理内存投影和 ghost 投影在各自代数中都有效。 + */ +PROOF extern thm c_resource_ra_valid; + +/* Exact product lifts; the unselected projection is exactly unit. */ +/** + * ```text + * c_lift_phys (G:(A)ra) (P:Mem->bool) = + * r_lift_left mem_ra G P + * ``` + * + * Here `Mem` abbreviates `(int,(pmem_byte_state)excl)finmap`. + * + * `c_lift_phys G P` 将物理断言 `P` 精确嵌入乘积资源，并要求 ghost 投影恰为 `G` 的单位元。 + */ +PROOF extern thm c_lift_phys_def; + +/** + * ```text + * c_lift_ghost (G:(A)ra) (Q:A->bool) = + * r_lift_right mem_ra G Q + * ``` + * + * `c_lift_ghost G Q` 将 ghost 断言 `Q` 精确嵌入乘积资源，并要求物理投影恰为空内存单位元。 + */ +PROOF extern thm c_lift_ghost_def; + +/* Exact ownership of an arbitrary fragment of the complete global ghost RA. */ +/** + * ```text + * c_ghost_own (G:(A)ra) (ghost:A) = + * c_lift_ghost G (r_own G ghost) + * ``` + * + * `c_ghost_own G ghost` 是 `r_own G ghost` 的精确 ghost 提升，因此不携带任何物理内存资源。 + */ +PROOF extern thm c_ghost_own_def; + +/* Exact physical lifts of canonical uninitialized and initialized bytes. */ +/** + * ```text + * c_pmem_uninit_at (G:(A)ra) (address:int) = + * c_lift_phys G (r_own mem_ra (pmem_uninit address)) + * ``` + * + * `c_pmem_uninit_at G address` 精确拥有地址处一个物理未初始化字节，并要求 ghost 投影为空。 + */ +PROOF extern thm c_pmem_uninit_at_def; + +/** + * ```text + * c_pmem_byte_at (G:(A)ra) (address:int) (byte:int) = + * c_lift_phys G (r_own mem_ra (pmem_byte address byte)) + * ``` + * + * `c_pmem_byte_at G address byte` 精确拥有地址处值为 `byte` 的已初始化物理字节，并要求 ghost 投影为空。 + */ +PROOF extern thm c_pmem_byte_at_def; diff --git a/theory/c_program_logic/c_types.c b/theory/c_program_logic/c_types.c new file mode 100644 index 0000000000000000000000000000000000000000..b0fb31d43d11cf56137834161799246a3c19a4a4 --- /dev/null +++ b/theory/c_program_logic/c_types.c @@ -0,0 +1,86 @@ +#include "proof/theory/c_program_logic/c_types.h" + +PROOF static size_t C_TYPES_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF indtype ctype_type = new_datatype_definition( + "ctype = Tchar" + " | Tuchar" + " | Tshort" + " | Tushort" + " | Tint" + " | Tuint" + " | Tint64" + " | Tuint64" + " | Tptr" + " | Tstruct string (string)list (ctype)list" + " | Tfun (string)list (ctype)list ctype"); + +PROOF static int c_types_declare_layout_constants(void) { + new_tyconst("struct_name", 0); + new_tyconst("field", 0); + + type field_offset_type = parse_type("struct_name->field->int"); + new_const("field_offset", field_offset_type); + + /* A natural codomain makes nonnegative object size definitional while + * leaving padding and target-layout choices abstract. */ + type struct_size_type = + parse_type("string->(string)list->(ctype)list->num"); + new_const("c_struct_size", struct_size_type); + return 0; +} + +PROOF static int _C_TYPES_LAYOUT_CONSTANTS = + c_types_declare_layout_constants(); + +PROOF thm field_addr_prop = new_fun_definition(` + field_addr + (base:int) + (structure:struct_name) + (field_name:field) : int = + base + field_offset structure field_name +`); + +PROOF thm sizeof_def = new_fun_definition(` + (sizeof Tchar = &1) /\ + (sizeof Tuchar = &1) /\ + (sizeof Tshort = &2) /\ + (sizeof Tushort = &2) /\ + (sizeof Tint = &4) /\ + (sizeof Tuint = &4) /\ + (sizeof Tint64 = &8) /\ + (sizeof Tuint64 = &8) /\ + (sizeof Tptr = &8) /\ + (!argument_names argument_types return_type. + sizeof (Tfun argument_names argument_types return_type) = &8) /\ + (!name field_names field_types. + sizeof (Tstruct name field_names field_types) = + &(c_struct_size name field_names field_types)) +`); + +PROOF static int c_types_register_theorems(void) { + ENSURE_COND(add_theorem("field_addr_prop", field_addr_prop), + "duplicate C-types theorem name: field_addr_prop"); + ENSURE_COND(add_theorem("sizeof_def", sizeof_def), + "duplicate C-types theorem name: sizeof_def"); + return 0; +err: + ERR_FUN_PUTS("c_types_register_theorems"); + return -1; +} + +PROOF static int _C_TYPES_THEOREMS_REGISTERED = + c_types_register_theorems(); + +PROOF static int c_types_check_axiom_free(void) { + ENSURE_COND(vector_size(get_all_axioms()) == C_TYPES_AXIOMS_BEFORE, + "c_types introduced a new axiom"); + return 0; +err: + ERR_FUN_PUTS("c_types_check_axiom_free"); + return -1; +} + +PROOF static int _C_TYPES_AXIOM_CHECK = + c_types_check_axiom_free(); diff --git a/theory/c_program_logic/c_types.h b/theory/c_program_logic/c_types.h new file mode 100644 index 0000000000000000000000000000000000000000..a2f52345c8461d1b3f76b29aef965bd49cf58417 --- /dev/null +++ b/theory/c_program_logic/c_types.h @@ -0,0 +1,63 @@ +/** + * @file c_types.h + * @brief C scalar types and abstract object-layout operations. + * + * Concrete addresses are HOL `int`; there is intentionally no separate + * address type. Scalar sizes describe the provisional 64-bit ABI used by the + * current verifier. Structure size and field offsets remain abstract, so + * padding and target-specific layout must be supplied by layout facts. + */ + +#pragma once + +#include "proof/proof_kernel.h" + +/** + * Datatype definition for + * + * ```text + * ctype = Tchar | Tuchar | Tshort | Tushort | Tint | Tuint + * | Tint64 | Tuint64 | Tptr + * | Tstruct string (string list) (ctype list) + * | Tfun (string list) (ctype list) ctype. + * ``` + * + * `Tfun argument_names argument_types return_type` is specification metadata + * for function pointers. It is not a scalar object type and therefore is not + * accepted by `data_at`; `sizeof` assigns it the provisional pointer width so + * nested function-pointer declarators can be rendered uniformly at the QCP + * boundary. + */ +PROOF extern indtype ctype_type; + +/** + * ```text + * (sizeof Tchar = &1) /\ + * (sizeof Tuchar = &1) /\ + * (sizeof Tshort = &2) /\ + * (sizeof Tushort = &2) /\ + * (sizeof Tint = &4) /\ + * (sizeof Tuint = &4) /\ + * (sizeof Tint64 = &8) /\ + * (sizeof Tuint64 = &8) /\ + * (sizeof Tptr = &8) /\ + * (!argument_names argument_types return_type. + * sizeof (Tfun argument_names argument_types return_type) = &8) /\ + * (!name field_names field_types. + * sizeof (Tstruct name field_names field_types) = + * &(c_struct_size name field_names field_types)) + * ``` + * + * 字符、短整型、32 位量和 64 位量分别取 1、2、4、8 字节；结构体使用抽象布局，`Tfun` 按当前布局约定返回 8。 + */ +PROOF extern thm sizeof_def; + +/** + * ```text + * field_addr (base:int) (structure:struct_name) (field_name:field) == + * base + field_offset structure field_name + * ``` + * + * 结构体字段的地址由对象基址加上该结构体中字段的抽象偏移量得到。 + */ +PROOF extern thm field_addr_prop; diff --git a/theory/c_program_logic/mem_own.c b/theory/c_program_logic/mem_own.c new file mode 100644 index 0000000000000000000000000000000000000000..f63f501322fdbac045ad9f6ae129b140cd79741e --- /dev/null +++ b/theory/c_program_logic/mem_own.c @@ -0,0 +1,64 @@ +#include "proof/theory/c_program_logic/mem_own.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/mem_ra.c" +#require "proof/theory/logic/resource_prop.c" + +PROOF static thm_list MEM_OWN_INITIAL_AXIOMS = get_all_axioms(); +PROOF static size_t MEM_OWN_AXIOMS_BEFORE = + vector_size(MEM_OWN_INITIAL_AXIOMS); + +PROOF thm pmem_own_def = new_fun_definition(` + pmem_own + (memory:(int,(pmem_byte_state)excl)finmap) : + (int,(pmem_byte_state)excl)finmap->bool = + r_own mem_ra memory +`); + +PROOF thm pmem_uninit_at_def = new_fun_definition(` + pmem_uninit_at + (address:int) : + (int,(pmem_byte_state)excl)finmap->bool = + pmem_own (pmem_uninit address) +`); + +PROOF thm pmem_byte_at_def = new_fun_definition(` + pmem_byte_at + (address:int) + (byte:int) : + (int,(pmem_byte_state)excl)finmap->bool = + pmem_own (pmem_byte address byte) +`); + +/* ------------------------------------------------------------------------- */ +/* Conservative-extension audit */ +/* ------------------------------------------------------------------------- */ + +PROOF static int audit_mem_own(void) { + thm_list public_theorems = THM_LIST( + pmem_own_def, + pmem_uninit_at_def, + pmem_byte_at_def); + + size_t public_theorem_count = vector_size(public_theorems); + for (size_t i = 0; i < public_theorem_count; ++i) { + thm public_theorem = public_theorems[i]; + ENSURE_COND(!IS_NULL(public_theorem), + "physical ownership theorem %zu is empty", i); + term_list theorem_hypotheses = hyp(public_theorem); + size_t hypothesis_count = vector_size(theorem_hypotheses); + ENSURE_COND(hypothesis_count == 0, + "physical ownership theorem %zu has hypotheses", i); + } + thm_list final_axioms = get_all_axioms(); + size_t final_axiom_count = vector_size(final_axioms); + ENSURE_COND(final_axiom_count == MEM_OWN_AXIOMS_BEFORE, + "physical ownership assertions introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_mem_own"); + return -1; +} + +PROOF static int _MEM_OWN_AUDIT = audit_mem_own(); diff --git a/theory/c_program_logic/mem_own.h b/theory/c_program_logic/mem_own.h new file mode 100644 index 0000000000000000000000000000000000000000..ddfc1c254771a129d02bf222ad963bf64cf3fc2a --- /dev/null +++ b/theory/c_program_logic/mem_own.h @@ -0,0 +1,52 @@ +/** + * @file mem_own.h + * @brief Exact ownership assertions over the concrete physical-memory RA. + * + * This module layers the generic resource-proposition language over the + * concrete byte algebra from `mem_ra.h`. Keeping these predicates separate + * leaves the physical carrier and its algebraic laws independent of any + * assertion model. + * + * The declarations below are exact predicate definitions, so their defining + * theorems use raw function equality. Generic assertion-algebra laws remain + * exposed through `r_equiv` by `resource_prop.h`. + */ + +#pragma once + +#include "proof/theory/c_program_logic/mem_ra.h" +#include "proof/theory/logic/resource_prop.h" + +/** + * Defining theorem for exact memory ownership: + * + * ```text + * pmem_own memory == r_own mem_ra memory + * ``` + * + * `pmem_own memory` 就是在物理内存代数中精确拥有有限映射片段 `memory`。 + */ +PROOF extern thm pmem_own_def; + +/** + * Defining theorem for one allocated, uninitialized byte: + * + * ```text + * pmem_uninit_at address == pmem_own (pmem_uninit address) + * ``` + * + * `pmem_uninit_at address` 精确拥有地址 `address` 处一个状态为 `PMemUninit` 的字节。 + */ +PROOF extern thm pmem_uninit_at_def; + +/** + * Defining theorem for one initialized byte: + * + * ```text + * pmem_byte_at address byte == + * pmem_own (pmem_byte address byte) + * ``` + * + * `pmem_byte_at address byte` 精确拥有地址 `address` 处一个已初始化且值为 `byte` 的字节。 + */ +PROOF extern thm pmem_byte_at_def; diff --git a/theory/c_program_logic/mem_ra.c b/theory/c_program_logic/mem_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..40d465f619e5f506166298db453505791d76933e --- /dev/null +++ b/theory/c_program_logic/mem_ra.c @@ -0,0 +1,373 @@ +#include "proof/theory/c_program_logic/mem_ra.h" +#include "proof/theory/logic/excl_ra_internal.h" +#include "proof/theory/logic/gmap_ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/excl_ra.c" +#require "proof/theory/logic/gmap_ra.c" + +PROOF static thm_list MEM_RA_INITIAL_AXIOMS = get_all_axioms(); +PROOF static size_t MEM_RA_AXIOMS_BEFORE = + vector_size(MEM_RA_INITIAL_AXIOMS); + +/* ------------------------------------------------------------------------- */ +/* Byte payload and construction */ +/* ------------------------------------------------------------------------- */ + +PROOF indtype pmem_byte_state_type = new_datatype_definition( + "pmem_byte_state = PMemUninit" + " | PMemByte int"); + +PROOF thm mem_ra_def = new_fun_definition(` + mem_ra : ((int,(pmem_byte_state)excl)finmap)ra = + gmap_ra (excl_ra:((pmem_byte_state)excl)ra) +`); + +PROOF static thm prove_mem_ra_unit(void) { + term goal_tm = ` + ra_unit mem_ra == + (finmap_empty:(int,(pmem_byte_state)excl)finmap) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + mem_ra_def, + gmap_ra_unit); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm mem_ra_unit = prove_mem_ra_unit(); + +PROOF static thm prove_mem_ra_op_lookup(void) { + term goal_tm = ` + forall + (left:(int,(pmem_byte_state)excl)finmap) + (right:(int,(pmem_byte_state)excl)finmap) + (address:int). + finmap_lookup + (ra_op mem_ra left right) + address == + ra_op + (option_ra + (excl_ra:((pmem_byte_state)excl)ra)) + (finmap_lookup left address) + (finmap_lookup right address) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + mem_ra_def, + gmap_ra_op_lookup); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm mem_ra_op_lookup = + prove_mem_ra_op_lookup(); + +PROOF static thm prove_mem_ra_valid(void) { + term goal_tm = ` + forall memory:(int,(pmem_byte_state)excl)finmap. + (ra_valid mem_ra memory <=> + forall address:int. + ra_valid + (option_ra + (excl_ra:((pmem_byte_state)excl)ra)) + (finmap_lookup memory address)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + mem_ra_def, + gmap_ra_valid); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm mem_ra_valid = prove_mem_ra_valid(); + +/* ------------------------------------------------------------------------- */ +/* Canonical fragments */ +/* ------------------------------------------------------------------------- */ + +PROOF thm pmem_singleton_def = new_fun_definition(` + pmem_singleton + (address:int) + (state:pmem_byte_state) : + (int,(pmem_byte_state)excl)finmap = + finmap_singleton address (Excl state) +`); + +PROOF thm pmem_uninit_def = new_fun_definition(` + pmem_uninit + (address:int) : + (int,(pmem_byte_state)excl)finmap = + pmem_singleton address PMemUninit +`); + +PROOF thm pmem_byte_def = new_fun_definition(` + pmem_byte + (address:int) + (byte:int) : + (int,(pmem_byte_state)excl)finmap = + pmem_singleton address (PMemByte byte) +`); + +PROOF static thm prove_pmem_singleton_valid(void) { + term goal_tm = ` + forall + (address:int) + (state:pmem_byte_state). + ra_valid + mem_ra + (pmem_singleton address state) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + mem_ra_def, + pmem_singleton_def, + gmap_ra_valid_singleton, + excl_ra_valid_owned); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_singleton_valid = + prove_pmem_singleton_valid(); + +PROOF static thm prove_pmem_uninit_valid(void) { + term goal_tm = ` + forall address:int. + ra_valid mem_ra (pmem_uninit address) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + pmem_uninit_def, + pmem_singleton_valid); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_uninit_valid = + prove_pmem_uninit_valid(); + +PROOF static thm prove_pmem_byte_valid(void) { + term goal_tm = ` + forall (address:int) (byte:int). + ra_valid mem_ra (pmem_byte address byte) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + pmem_byte_def, + pmem_singleton_valid); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_byte_valid = + prove_pmem_byte_valid(); + +PROOF static thm prove_pmem_singleton_overlap_invalid(void) { + term goal_tm = ` + forall + (address:int) + (left:pmem_byte_state) + (right:pmem_byte_state). + ~(ra_valid + mem_ra + (ra_op + mem_ra + (pmem_singleton address left) + (pmem_singleton address right))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rewrites = THM_LIST( + mem_ra_def, + pmem_singleton_def, + gmap_ra_singleton_op, + gmap_ra_valid_singleton, + excl_ra_owned_conflict, + excl_ra_invalid); + conv rewrite = rewrite_conv(rewrites); + CONV_TAC(root, rewrite); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_singleton_overlap_invalid = + prove_pmem_singleton_overlap_invalid(); + +/* ------------------------------------------------------------------------- */ +/* Frame-preserving singleton updates */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm pmem_lift_excl_singleton_update( + const term address, + const term source_state, + const term target_state) { + term_list payload_arguments = TERM_LIST(source_state, target_state); + thm payload_update = ispecl_rule( + payload_arguments, + excl_ra_update); + term source_owned = mk_comb( + `Excl:pmem_byte_state->(pmem_byte_state)excl`, + source_state); + term target_owned = mk_comb( + `Excl:pmem_byte_state->(pmem_byte_state)excl`, + target_state); + term_list singleton_arguments = TERM_LIST( + `excl_ra:((pmem_byte_state)excl)ra`, + address, + source_owned, + target_owned); + thm singleton_update = ispecl_rule( + singleton_arguments, + gmap_ra_update_singleton); + thm lifted_update = mp_rule(singleton_update, payload_update); + return lifted_update; +} + +PROOF static thm prove_pmem_update_uninit_byte(void) { + term goal_tm = ` + forall (address:int) (byte:int). + ra_update + mem_ra + (pmem_uninit address) + (pmem_byte address byte) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm_list rewrites = THM_LIST( + mem_ra_def, + pmem_uninit_def, + pmem_byte_def, + pmem_singleton_def); + conv rewrite = pure_rewrite_conv(rewrites); + body = CONV_TAC(body, rewrite); + thm update = pmem_lift_excl_singleton_update( + `address:int`, + `PMemUninit:pmem_byte_state`, + `PMemByte (byte:int)`); + ACCEPT_TAC(body, update); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_update_uninit_byte = + prove_pmem_update_uninit_byte(); + +PROOF static thm prove_pmem_update_byte_uninit(void) { + term goal_tm = ` + forall (address:int) (byte:int). + ra_update + mem_ra + (pmem_byte address byte) + (pmem_uninit address) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm_list rewrites = THM_LIST( + mem_ra_def, + pmem_byte_def, + pmem_uninit_def, + pmem_singleton_def); + conv rewrite = pure_rewrite_conv(rewrites); + body = CONV_TAC(body, rewrite); + thm update = pmem_lift_excl_singleton_update( + `address:int`, + `PMemByte (byte:int)`, + `PMemUninit:pmem_byte_state`); + ACCEPT_TAC(body, update); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_update_byte_uninit = + prove_pmem_update_byte_uninit(); + +PROOF static thm prove_pmem_update_byte_byte(void) { + term goal_tm = ` + forall (address:int) (old_byte:int) (new_byte:int). + ra_update + mem_ra + (pmem_byte address old_byte) + (pmem_byte address new_byte) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm_list rewrites = THM_LIST( + mem_ra_def, + pmem_byte_def, + pmem_singleton_def); + conv rewrite = pure_rewrite_conv(rewrites); + body = CONV_TAC(body, rewrite); + thm update = pmem_lift_excl_singleton_update( + `address:int`, + `PMemByte (old_byte:int)`, + `PMemByte (new_byte:int)`); + ACCEPT_TAC(body, update); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_update_byte_byte = + prove_pmem_update_byte_byte(); + +/* ------------------------------------------------------------------------- */ +/* Conservative-extension audit */ +/* ------------------------------------------------------------------------- */ + +PROOF static int audit_mem_ra(void) { + thm_list public_theorems = THM_LIST( + pmem_byte_state_type.ind, + pmem_byte_state_type.rec, + mem_ra_def, + mem_ra_unit, + mem_ra_op_lookup, + mem_ra_valid, + pmem_singleton_def, + pmem_uninit_def, + pmem_byte_def, + pmem_singleton_valid, + pmem_uninit_valid, + pmem_byte_valid, + pmem_singleton_overlap_invalid, + pmem_update_uninit_byte, + pmem_update_byte_uninit, + pmem_update_byte_byte); + + size_t public_theorem_count = vector_size(public_theorems); + for (size_t i = 0; i < public_theorem_count; ++i) { + thm public_theorem = public_theorems[i]; + ENSURE_COND(!IS_NULL(public_theorem), + "physical-memory theorem %zu is empty", i); + term_list theorem_hypotheses = hyp(public_theorem); + size_t hypothesis_count = vector_size(theorem_hypotheses); + ENSURE_COND(hypothesis_count == 0, + "physical-memory theorem %zu has hypotheses", i); + } + thm_list final_axioms = get_all_axioms(); + size_t final_axiom_count = vector_size(final_axioms); + ENSURE_COND(final_axiom_count == MEM_RA_AXIOMS_BEFORE, + "physical-memory RA introduced an axiom"); + int pmem_byte_state_arity = get_tyconst_arity("pmem_byte_state"); + ENSURE_COND(pmem_byte_state_arity == 0, + "pmem_byte_state is not a nullary HOL type"); + return 0; +err: + ERR_FUN_PUTS("audit_mem_ra"); + return -1; +} + +PROOF static int _MEM_RA_AUDIT = audit_mem_ra(); diff --git a/theory/c_program_logic/mem_ra.h b/theory/c_program_logic/mem_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..ff5cb80e24979a67355af8b926b5c39551dede3d --- /dev/null +++ b/theory/c_program_logic/mem_ra.h @@ -0,0 +1,203 @@ +/** + * @file mem_ra.h + * @brief Concrete byte ownership as a construction-based resource algebra. + * + * The payload datatype distinguishes an allocated but uninitialized byte from + * an initialized byte carrying an integer value: + * + * pmem_byte_state = PMemUninit | PMemByte int. + * + * The memory carrier is the finite map + * + * (int,(pmem_byte_state)excl)finmap. + * + * A missing key (`NONE`) is the canonical representation of no ownership at + * that address. A present `Excl state` owns exactly one byte. Combining two + * present owned values at the same address produces `ExclInvalid`, so the + * resulting memory is invalid. The public singleton constructors never emit + * the noncanonical `ExclUnit` or `ExclInvalid` payloads admitted by the general + * carrier. + * + * This theory is independent of every assertion language. Exact ownership + * predicates over this algebra are layered separately in `mem_own.h`. + * Consequently, equalities in this header describe RA carrier data and + * operations; they are not assertion-function equality laws from the BI + * interface. + */ + +#pragma once + +#include "proof/theory/logic/excl_ra.h" +#include "proof/theory/logic/gmap_ra.h" + +/* ------------------------------------------------------------------------- */ +/* Byte payload and memory algebra */ +/* ------------------------------------------------------------------------- */ + +/** + * HOL datatype package for + * `pmem_byte_state = PMemUninit | PMemByte int`. + * + * The handle exposes the datatype's constructors and generated induction and + * recursion theorems through the ordinary `indtype` API. + */ +PROOF extern indtype pmem_byte_state_type; + +/** + * Construction equation: + * + * ```text + * ⊢ mem_ra == gmap_ra (excl_ra : ((pmem_byte_state)excl)ra). + * ``` + * + * 物理内存代数由“地址到 exclusive 字节状态”的有限映射代数构造而成。 + */ +PROOF extern thm mem_ra_def; + +/** + * The empty memory is the empty finite map: + * + * ```text + * ⊢ ra_unit mem_ra = + * (finmap_empty : (int,(pmem_byte_state)excl)finmap). + * ``` + * + * 物理内存代数的单位元是不拥有任何地址的空有限映射。 + */ +PROOF extern thm mem_ra_unit; + +/** + * Composition is pointwise through option and exclusive composition: + * + * ```text + * ⊢ ∀left right address. + * finmap_lookup (ra_op mem_ra left right) address = + * ra_op (option_ra (excl_ra : ((pmem_byte_state)excl)ra)) + * (finmap_lookup left address) + * (finmap_lookup right address). + * ``` + * + * 两个内存片段组合后，每个地址的查询结果由对应两个可选 exclusive 条目逐点组合得到。 + */ +PROOF extern thm mem_ra_op_lookup; + +/** + * Memory validity is pointwise option/exclusive validity: + * + * ```text + * ⊢ ∀memory. + * ra_valid mem_ra memory ⇔ + * ∀address:int. + * ra_valid (option_ra (excl_ra : ((pmem_byte_state)excl)ra)) + * (finmap_lookup memory address). + * ``` + * + * 内存有限映射有效，当且仅当每个地址查询到的可选 exclusive 字节状态都有效。 + */ +PROOF extern thm mem_ra_valid; + +/* ------------------------------------------------------------------------- */ +/* Canonical finite-memory fragments */ +/* ------------------------------------------------------------------------- */ + +/** + * Canonical singleton definition: + * + * ```text + * pmem_singleton address state == + * finmap_singleton address (Excl state) + * ``` + * + * `pmem_singleton address state` 是仅在 `address` 处存放 canonical `Excl state` 的内存片段。 + */ +PROOF extern thm pmem_singleton_def; + +/** + * Uninitialized singleton definition: + * + * ```text + * pmem_uninit address == + * pmem_singleton address PMemUninit + * ``` + * + * `pmem_uninit address` 是仅拥有 `address` 处一个未初始化字节的 canonical 单点片段。 + */ +PROOF extern thm pmem_uninit_def; + +/** + * Initialized singleton definition: + * + * ```text + * pmem_byte address byte == + * pmem_singleton address (PMemByte byte) + * ``` + * + * `pmem_byte address byte` 是仅拥有 `address` 处一个值为 `byte` 的已初始化字节的 canonical 单点片段。 + */ +PROOF extern thm pmem_byte_def; + +/** + * ```text + * ⊢ ∀address state. ra_valid mem_ra (pmem_singleton address state) + * ``` + * + * 任意地址和任意字节状态构成的 canonical 单点内存片段都有效。 + */ +PROOF extern thm pmem_singleton_valid; + +/** + * Two canonical owned singletons at the same address compose to an invalid + * memory, independently of their byte states: + * + * ```text + * ⊢ ∀address left right. + * ¬ ra_valid mem_ra + * (ra_op mem_ra (pmem_singleton address left) + * (pmem_singleton address right)). + * ``` + * + * 无论各自字节状态为何，两个拥有同一地址的 canonical 单点片段组合都会因 exclusive 冲突而无效。 + */ +PROOF extern thm pmem_singleton_overlap_invalid; + +/* ------------------------------------------------------------------------- */ +/* Frame-preserving updates */ +/* ------------------------------------------------------------------------- */ + +/* + * These deterministic `ra_update` theorems are singleton specializations of + * primitive `ra_updateP`. They are implementation lemmas for trusted C + * command semantic rules and must not be exposed as program-level viewshifts: + * changing physical memory requires execution of the corresponding command. + */ + +/** + * ```text + * ⊢ ∀address byte. ra_update mem_ra (pmem_uninit address) + * (pmem_byte address byte) + * ``` + * + * 同一地址的未初始化单点可更新为任意给定字节值；这是 `mem_ra` 层的代数更新，不是 C view shift。 + */ +PROOF extern thm pmem_update_uninit_byte; + +/** + * ```text + * ⊢ ∀address byte. ra_update mem_ra (pmem_byte address byte) + * (pmem_uninit address) + * ``` + * + * 同一地址的已初始化单点可更新回未初始化单点；这是 `mem_ra` 层的代数更新，不是 C view shift。 + */ +PROOF extern thm pmem_update_byte_uninit; + +/** + * ```text + * ⊢ ∀address old_byte new_byte. + * ra_update mem_ra (pmem_byte address old_byte) + * (pmem_byte address new_byte) + * ``` + * + * 同一地址的已初始化单点可改写为任意目标字节值；这是 `mem_ra` 层的代数更新，不是 C view shift。 + */ +PROOF extern thm pmem_update_byte_byte; diff --git a/theory/c_program_logic/mem_value.c b/theory/c_program_logic/mem_value.c new file mode 100644 index 0000000000000000000000000000000000000000..cc2bf3aa2399006148ff8d4cbb842aef0bedbe9d --- /dev/null +++ b/theory/c_program_logic/mem_value.c @@ -0,0 +1,682 @@ +#include "proof/theory/c_program_logic/mem_value.h" +#include "proof/theory/logic/resource_prop_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/c_program_logic/mem_own.c" + +PROOF static thm_list MEM_VALUE_INITIAL_AXIOMS = get_all_axioms(); +PROOF static size_t MEM_VALUE_AXIOMS_BEFORE = + vector_size(MEM_VALUE_INITIAL_AXIOMS); + +/* ------------------------------------------------------------------------- */ +/* Allocated bytes and contiguous regions */ +/* ------------------------------------------------------------------------- */ + +PROOF thm pmem_allocated_byte_at_def = new_fun_definition(` + pmem_allocated_byte_at + (address:int) : + (int,(pmem_byte_state)excl)finmap->bool = + r_exists + mem_ra + (\state:pmem_byte_state. + pmem_own (pmem_singleton address state)) +`); + +PROOF static thm mem_value_list_recursion = + get_theorem_by_name("list_RECURSION"); + +PROOF thm pmem_bytes_at_def = new_rec_definition( + mem_value_list_recursion, + ` + (pmem_bytes_at + (base:int) + ([]:(int)list) = + r_emp mem_ra) && + (pmem_bytes_at + base + ((byte:int) :: (bytes:(int)list)) = + r_sep + mem_ra + (pmem_byte_at base byte) + (pmem_bytes_at (base + &1) bytes)) + `); + +PROOF static thm prove_pmem_bytes_at_nil(void) { + gnode root = gnode_new_with_ccl(` + forall base:int. + pmem_bytes_at base ([]:(int)list) == r_emp mem_ra + `); + thm_list rewrites = THM_LIST(pmem_bytes_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_bytes_at_nil = + prove_pmem_bytes_at_nil(); + +PROOF static thm prove_pmem_bytes_at_cons(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (byte:int) (bytes:(int)list). + pmem_bytes_at base (byte :: bytes) == + r_sep + mem_ra + (pmem_byte_at base byte) + (pmem_bytes_at (base + &1) bytes) + `); + thm_list rewrites = THM_LIST(pmem_bytes_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_bytes_at_cons = + prove_pmem_bytes_at_cons(); + +PROOF static thm mem_value_num_recursion = + get_theorem_by_name("num_RECURSION"); + +PROOF thm pmem_allocated_at_def = new_rec_definition( + mem_value_num_recursion, + ` + (pmem_allocated_at + (base:int) + 0 = + r_emp mem_ra) && + (pmem_allocated_at + base + (SUC count) = + r_sep + mem_ra + (pmem_allocated_byte_at base) + (pmem_allocated_at (base + &1) count)) + `); + +PROOF static thm prove_pmem_allocated_at_zero(void) { + gnode root = gnode_new_with_ccl(` + forall base:int. + pmem_allocated_at base 0 == r_emp mem_ra + `); + thm_list rewrites = THM_LIST(pmem_allocated_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_allocated_at_zero = + prove_pmem_allocated_at_zero(); + +PROOF static thm prove_pmem_allocated_at_suc(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (count:num). + pmem_allocated_at base (SUC count) == + r_sep + mem_ra + (pmem_allocated_byte_at base) + (pmem_allocated_at (base + &1) count) + `); + thm_list rewrites = THM_LIST(pmem_allocated_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_allocated_at_suc = + prove_pmem_allocated_at_suc(); + +PROOF static thm prove_pmem_allocated_at_append(void) { + gnode root = gnode_new_with_ccl(` + forall m:num. forall base:int. forall n:num. + pmem_allocated_at base (m + n) == + r_sep mem_ra + (pmem_allocated_at base m) + (pmem_allocated_at (base + &m) n) + `); + gnode body = GEN_TAC(root, "m"); + gnode_list cases = INDUCT_TAC(body, `m:num`); + + gnode base = AUTO_INTROS_TAC(cases[0]); + thm zero_address = ispec_rule( + `base:int`, get_theorem_by_name("INT_ADD_RID")); + CONV_TAC(base, simp_conv(THM_LIST( + get_theorem_by_name("ADD_CLAUSES"), + zero_address, + pmem_allocated_at_zero, + r_sep_emp_l_eq))); + + gnode step = AUTO_INTROS_TAC(cases[1]); + thm ih_general = assume_rule( + gnode_get_asmps(step, CONST_STRING_LIST("H"))[0]); + thm ih = ispecl_rule( + TERM_LIST(`base + &1:int`, `n_:num`), + ih_general); + thm cast_successor = ispec_rule( + `n:num`, get_theorem_by_name("INT_OF_NUM_SUC")); + thm expose_successor = beta_rule(ap_term_rule( + `\z:int. base + z`, cast_successor)); + thm address_reassociation = int_ring_rule(` + forall (x:int) (y:int). + x + (y + &1) = (x + &1) + y + `); + address_reassociation = + ispec_rule(`base:int`, address_reassociation); + address_reassociation = + ispec_rule(`&n:int`, address_reassociation); + thm address = trans_rule( + sym_rule(expose_successor), address_reassociation); + step = CONV_TAC(step, simp_conv(THM_LIST( + get_theorem_by_name("ADD_CLAUSES"), + pmem_allocated_at_suc, + address, + r_sep_assoc_eq))); + thm lifted_ih = beta_rule(ap_term_rule(` + \tail:((int,(pmem_byte_state)excl)finmap)->bool. + r_sep mem_ra (pmem_allocated_byte_at base) tail + `, ih)); + ACCEPT_TAC(step, lifted_ih); + return gnode_prove(root); +} + +PROOF thm pmem_allocated_at_append = + prove_pmem_allocated_at_append(); + +PROOF static thm prove_pmem_allocated_at_split(void) { + gnode root = gnode_new_with_ccl(` + forall base:int. forall n k:num. + k <= n ==> + pmem_allocated_at base n == + r_sep mem_ra + (pmem_allocated_at base k) + (pmem_allocated_at (base + &k) (n - k)) + `); + gnode g = AUTO_INTROS_TAC(root); + thm decomposition = match_mp_rule( + arith_rule(`forall k n:num. k <= n ==> n = k + (n - k)`), + assume_rule(`k:num <= n`)); + thm appended = ispecl_rule( + TERM_LIST(`k:num`, `base:int`, `n - k:num`), + pmem_allocated_at_append); + appended = conv_rule( + once_rewrite_conv(THM_LIST(gsym_rule(decomposition))), + appended); + ACCEPT_TAC(g, appended); + return gnode_prove(root); +} + +PROOF thm pmem_allocated_at_split = + prove_pmem_allocated_at_split(); + +PROOF static thm prove_pmem_uninit_at_allocated_byte(void) { + term goal_tm = ` + forall address:int. + r_entails + mem_ra + (pmem_uninit_at address) + (pmem_allocated_byte_at address) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list definitions = THM_LIST( + r_entails_def, + pmem_uninit_at_def, + pmem_uninit_def, + pmem_allocated_byte_at_def, + pmem_own_def, + r_own_def, + r_exists_def); + conv unfold_definitions = pure_rewrite_conv(definitions); + gnode body = CONV_TAC(root, unfold_definitions); + body = GEN_TAC(body, "address"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid_resource"); + body = DISCH_TAC(body, "Hown"); + term uninitialized_tm = `PMemUninit:pmem_byte_state`; + body = EXISTS_TAC(body, uninitialized_tm); + conv beta = get_conversion_by_name("BETA_CONV"); + conv beta_depth = depth_conv(beta); + body = CONV_TAC(body, beta_depth); + thm_list own_definitions = THM_LIST(r_own_def); + conv unfold_own = pure_rewrite_conv(own_definitions); + body = CONV_TAC(body, unfold_own); + const_cstr_list own_labels = CONST_STRING_LIST("Hown"); + term_list own_terms = gnode_get_asmps(body, own_labels); + term own_tm = own_terms[0]; + thm own = assume_rule(own_tm); + ACCEPT_TAC(body, own); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_uninit_at_allocated_byte = + prove_pmem_uninit_at_allocated_byte(); + +PROOF static thm prove_pmem_byte_at_allocated_byte(void) { + term goal_tm = ` + forall (address:int) (byte:int). + r_entails + mem_ra + (pmem_byte_at address byte) + (pmem_allocated_byte_at address) + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list definitions = THM_LIST( + r_entails_def, + pmem_byte_at_def, + pmem_byte_def, + pmem_allocated_byte_at_def, + pmem_own_def, + r_own_def, + r_exists_def); + conv unfold_definitions = pure_rewrite_conv(definitions); + gnode body = CONV_TAC(root, unfold_definitions); + body = GEN_TAC(body, "address"); + body = GEN_TAC(body, "byte"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid_resource"); + body = DISCH_TAC(body, "Hown"); + term byte_state_tm = `PMemByte (byte:int):pmem_byte_state`; + body = EXISTS_TAC(body, byte_state_tm); + conv beta = get_conversion_by_name("BETA_CONV"); + conv beta_depth = depth_conv(beta); + body = CONV_TAC(body, beta_depth); + thm_list own_definitions = THM_LIST(r_own_def); + conv unfold_own = pure_rewrite_conv(own_definitions); + body = CONV_TAC(body, unfold_own); + const_cstr_list own_labels = CONST_STRING_LIST("Hown"); + term_list own_terms = gnode_get_asmps(body, own_labels); + term own_tm = own_terms[0]; + thm own = assume_rule(own_tm); + ACCEPT_TAC(body, own); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_byte_at_allocated_byte = + prove_pmem_byte_at_allocated_byte(); + +PROOF static thm prove_pmem_bytes_at_allocated(void) { + term goal_tm = ` + forall bytes:(int)list. + forall base:int. + r_entails + mem_ra + (pmem_bytes_at base bytes) + (pmem_allocated_at base (LENGTH bytes)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "bytes"); + term bytes_tm = `bytes:(int)list`; + gnode_list cases = INDUCT_TAC(body, bytes_tm); + + gnode nil_case = GEN_TAC(cases[0], "base"); + thm length = get_theorem_by_name("LENGTH"); + thm_list nil_rewrites = THM_LIST( + pmem_bytes_at_nil, + pmem_allocated_at_zero, + length); + conv simplify_nil = rewrite_conv(nil_rewrites); + nil_case = CONV_TAC(nil_case, simplify_nil); + term mem_ra_tm = `mem_ra:((int,(pmem_byte_state)excl)finmap)ra`; + term emp_tm = ` + r_emp mem_ra:(int,(pmem_byte_state)excl)finmap->bool + `; + term_list refl_arguments = TERM_LIST(mem_ra_tm, emp_tm); + thm entails_refl = ispecl_rule(refl_arguments, r_entails_refl); + ACCEPT_TAC(nil_case, entails_refl); + + gnode cons_case = GEN_TAC(cases[1], "base"); + thm_list cons_rewrites = THM_LIST( + pmem_bytes_at_cons, + pmem_allocated_at_suc, + length); + conv simplify_cons = rewrite_conv(cons_rewrites); + cons_case = CONV_TAC(cons_case, simplify_cons); + + term base_tm = `base:int`; + term head_tm = `a0:int`; + term_list head_arguments = TERM_LIST(base_tm, head_tm); + thm head_entails = ispecl_rule( + head_arguments, + pmem_byte_at_allocated_byte); + term induction_tm = ` + forall base:int. + r_entails + mem_ra + (pmem_bytes_at base (a1:(int)list)) + (pmem_allocated_at base (LENGTH a1)) + `; + thm induction = assume_rule(induction_tm); + term next_base_tm = `base + &1:int`; + thm tail_entails = spec_rule(next_base_tm, induction); + thm sep_after_head = match_mp_rule(r_sep_mono, head_entails); + thm region_entails = match_mp_rule(sep_after_head, tail_entails); + ACCEPT_TAC(cons_case, region_entails); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_bytes_at_allocated = + prove_pmem_bytes_at_allocated(); + +/* ------------------------------------------------------------------------- */ +/* Provisional little-endian scalar representation */ +/* ------------------------------------------------------------------------- */ + +PROOF thm pmem_le_bytes_def = new_rec_definition( + mem_value_num_recursion, + ` + (pmem_le_bytes + 0 + (integer_value:int) = + ([]:(int)list)) && + (pmem_le_bytes + (SUC count) + integer_value = + (integer_value rem &256) :: + pmem_le_bytes count (integer_value div &256)) + `); + +PROOF static thm prove_pmem_le_bytes_zero(void) { + gnode root = gnode_new_with_ccl(` + forall integer_value:int. + pmem_le_bytes 0 integer_value == ([]:(int)list) + `); + thm_list rewrites = THM_LIST(pmem_le_bytes_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_le_bytes_zero = + prove_pmem_le_bytes_zero(); + +PROOF static thm prove_pmem_le_bytes_suc(void) { + gnode root = gnode_new_with_ccl(` + forall (count:num) (integer_value:int). + pmem_le_bytes (SUC count) integer_value == + (integer_value rem &256) :: + pmem_le_bytes count (integer_value div &256) + `); + thm_list rewrites = THM_LIST(pmem_le_bytes_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_le_bytes_suc = + prove_pmem_le_bytes_suc(); + +PROOF static thm prove_pmem_le_bytes_length(void) { + gnode root = gnode_new_with_ccl(` + forall (count:num) (integer_value:int). + LENGTH (pmem_le_bytes count integer_value) == count + `); + gnode body = GEN_TAC(root, "count"); + term count_tm = `count:num`; + gnode_list cases = INDUCT_TAC(body, count_tm); + + thm length = get_theorem_by_name("LENGTH"); + + gnode zero_case = GEN_TAC(cases[0], "integer_value"); + thm_list zero_rewrites = THM_LIST( + pmem_le_bytes_zero, + length); + conv simplify_zero = rewrite_conv(zero_rewrites); + CONV_TAC(zero_case, simplify_zero); + + gnode suc_case = GEN_TAC(cases[1], "integer_value"); + term induction_assumption_tm = ` + forall integer_value:int. + LENGTH (pmem_le_bytes (n:num) integer_value) == n + `; + thm induction_assumption = assume_rule(induction_assumption_tm); + term quotient_tm = `(integer_value:int) div &256`; + thm induction = spec_rule(quotient_tm, induction_assumption); + thm_list suc_rewrites = THM_LIST( + pmem_le_bytes_suc, + length, + induction); + conv simplify_suc = rewrite_conv(suc_rewrites); + CONV_TAC(suc_case, simplify_suc); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_le_bytes_length = + prove_pmem_le_bytes_length(); + +PROOF thm pmem_scalar_at_def = new_fun_definition(` + pmem_scalar_at + (base:int) + (count:num) + (integer_value:int) : + (int,(pmem_byte_state)excl)finmap->bool = + pmem_bytes_at base (pmem_le_bytes count integer_value) +`); + +PROOF thm pmem_undef_scalar_at_def = new_rec_definition( + mem_value_num_recursion, + ` + (pmem_undef_scalar_at + (base:int) + 0 = + r_emp mem_ra) && + (pmem_undef_scalar_at + base + (SUC count) = + r_sep + mem_ra + (pmem_uninit_at base) + (pmem_undef_scalar_at (base + &1) count)) + `); + +PROOF static thm prove_pmem_scalar_at_zero(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (integer_value:int). + pmem_scalar_at base 0 integer_value == r_emp mem_ra + `); + thm_list rewrites = THM_LIST( + pmem_scalar_at_def, + pmem_le_bytes_zero, + pmem_bytes_at_nil); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_scalar_at_zero = + prove_pmem_scalar_at_zero(); + +PROOF static thm prove_pmem_scalar_at_suc(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (count:num) (integer_value:int). + pmem_scalar_at base (SUC count) integer_value == + r_sep + mem_ra + (pmem_byte_at base (integer_value rem &256)) + (pmem_scalar_at + (base + &1) + count + (integer_value div &256)) + `); + thm_list rewrites = THM_LIST( + pmem_scalar_at_def, + pmem_le_bytes_suc, + pmem_bytes_at_cons); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_scalar_at_suc = + prove_pmem_scalar_at_suc(); + +PROOF static thm prove_pmem_undef_scalar_at_zero(void) { + gnode root = gnode_new_with_ccl(` + forall base:int. + pmem_undef_scalar_at base 0 == r_emp mem_ra + `); + thm_list rewrites = THM_LIST(pmem_undef_scalar_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_undef_scalar_at_zero = + prove_pmem_undef_scalar_at_zero(); + +PROOF static thm prove_pmem_undef_scalar_at_suc(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (count:num). + pmem_undef_scalar_at base (SUC count) == + r_sep + mem_ra + (pmem_uninit_at base) + (pmem_undef_scalar_at (base + &1) count) + `); + thm_list rewrites = THM_LIST(pmem_undef_scalar_at_def); + conv simplify = rewrite_conv(rewrites); + CONV_TAC(root, simplify); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_undef_scalar_at_suc = + prove_pmem_undef_scalar_at_suc(); + +PROOF static thm prove_pmem_undef_scalar_at_allocated(void) { + gnode root = gnode_new_with_ccl(` + forall count:num. forall base:int. + r_entails + mem_ra + (pmem_undef_scalar_at base count) + (pmem_allocated_at base count) + `); + gnode body = GEN_TAC(root, "count"); + gnode_list cases = INDUCT_TAC(body, `count:num`); + + gnode zero = GEN_TAC(cases[0], "base"); + zero = CONV_TAC(zero, rewrite_conv(THM_LIST( + pmem_undef_scalar_at_zero, + pmem_allocated_at_zero))); + ACCEPT_TAC( + zero, + ispecl_rule( + TERM_LIST( + `mem_ra`, + `r_emp mem_ra: + (int,(pmem_byte_state)excl)finmap->bool`), + r_entails_refl)); + + gnode step = GEN_TAC(cases[1], "base"); + step = CONV_TAC(step, rewrite_conv(THM_LIST( + pmem_undef_scalar_at_suc, + pmem_allocated_at_suc))); + thm head = ispec_rule( + `base:int`, + pmem_uninit_at_allocated_byte); + thm induction = spec_rule( + `base + &1:int`, + assume_rule(` + forall base:int. + r_entails mem_ra + (pmem_undef_scalar_at base (n:num)) + (pmem_allocated_at base n) + `)); + ACCEPT_TAC( + step, + match_mp_rule(match_mp_rule(r_sep_mono, head), induction)); + return gnode_prove(root); +} + +PROOF thm pmem_undef_scalar_at_allocated = + prove_pmem_undef_scalar_at_allocated(); + +PROOF static thm prove_pmem_scalar_at_allocated(void) { + gnode root = gnode_new_with_ccl(` + forall (base:int) (count:num) (integer_value:int). + r_entails + mem_ra + (pmem_scalar_at base count integer_value) + (pmem_allocated_at base count) + `); + gnode body = AUTO_INTROS_TAC(root); + thm_list definitions = THM_LIST(pmem_scalar_at_def); + conv unfold_definitions = pure_rewrite_conv(definitions); + body = CONV_TAC(body, unfold_definitions); + term bytes_tm = `pmem_le_bytes (count:num) (integer_value:int)`; + term base_tm = `base:int`; + term_list allocated_arguments = TERM_LIST(bytes_tm, base_tm); + thm allocated = ispecl_rule( + allocated_arguments, + pmem_bytes_at_allocated); + thm_list length_rewrites = THM_LIST(pmem_le_bytes_length); + allocated = rewrite_rule(length_rewrites, allocated); + ACCEPT_TAC(body, allocated); + thm proved = gnode_prove(root); + return proved; +} + +PROOF thm pmem_scalar_at_allocated = + prove_pmem_scalar_at_allocated(); + +/* ------------------------------------------------------------------------- */ +/* Conservative-extension audit */ +/* ------------------------------------------------------------------------- */ + +PROOF static int audit_mem_value(void) { + thm_list public_theorems = THM_LIST( + pmem_allocated_byte_at_def, + pmem_bytes_at_def, + pmem_bytes_at_nil, + pmem_bytes_at_cons, + pmem_allocated_at_def, + pmem_allocated_at_zero, + pmem_allocated_at_suc, + pmem_allocated_at_append, + pmem_allocated_at_split, + pmem_uninit_at_allocated_byte, + pmem_byte_at_allocated_byte, + pmem_bytes_at_allocated, + pmem_le_bytes_def, + pmem_le_bytes_zero, + pmem_le_bytes_suc, + pmem_le_bytes_length, + pmem_scalar_at_def, + pmem_undef_scalar_at_def, + pmem_scalar_at_zero, + pmem_scalar_at_suc, + pmem_undef_scalar_at_zero, + pmem_undef_scalar_at_suc, + pmem_undef_scalar_at_allocated, + pmem_scalar_at_allocated); + + size_t public_theorem_count = vector_size(public_theorems); + for (size_t i = 0; i < public_theorem_count; ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "physical value theorem %zu is empty", i); + term_list theorem_hypotheses = hyp(public_theorems[i]); + size_t hypothesis_count = vector_size(theorem_hypotheses); + ENSURE_COND(hypothesis_count == 0, + "physical value theorem %zu has hypotheses", i); + } + thm_list final_axioms = get_all_axioms(); + size_t final_axiom_count = vector_size(final_axioms); + ENSURE_COND(final_axiom_count == MEM_VALUE_AXIOMS_BEFORE, + "physical value assertions introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_mem_value"); + return -1; +} + +PROOF static int _MEM_VALUE_AUDIT = audit_mem_value(); diff --git a/theory/c_program_logic/mem_value.h b/theory/c_program_logic/mem_value.h new file mode 100644 index 0000000000000000000000000000000000000000..08a7b4c4395669a32ee10832f50b63092a190bc7 --- /dev/null +++ b/theory/c_program_logic/mem_value.h @@ -0,0 +1,370 @@ +/** + * @file mem_value.h + * @brief Contiguous byte and scalar-value assertions over `mem_ra`. + * + * This module is the assertion-level bridge between exact byte ownership and + * the scalar `data_at`/`undef_data_at` atoms installed by a C-program logic. + * It deliberately contains no C type, alignment, signedness, range, combined + * physical/ghost resource, or QCP registration. Those target-dependent + * choices belong to the layer that lifts these physical-only `mem_ra` + * assertions. + * + * Addresses and scalar values are mathematical HOL integers. Scalar bytes + * use the provisional little-endian ABI described below. In particular, no + * premise that the scalar value is nonnegative is built into this theory. + * + * In this header `P ⊢_mem Q` abbreviates `r_entails mem_ra P Q` and + * `P **_mem Q` abbreviates `r_sep mem_ra P Q`. Both are documentation + * notation; the exported theorems use the `r_*` constants directly. + * + * The raw assertion equalities exported here are computation and + * normalization equations for these concrete recursive memory predicates. + * They do not expose raw equality as a generic BI connective law; the latter + * remains available to clients only through validity-sensitive `r_equiv`. + */ + +#pragma once + +#include "proof/theory/c_program_logic/mem_own.h" + +/* ------------------------------------------------------------------------- */ +/* Allocated bytes and contiguous regions */ +/* ------------------------------------------------------------------------- */ + +/** + * One allocated byte with unspecified initialization state: + * + * ```text + * pmem_allocated_byte_at (address:int) == + * r_exists mem_ra + * (\state:pmem_byte_state. + * pmem_own (pmem_singleton address state)) + * ``` + * + * Hence the witness may be `PMemUninit` or `PMemByte byte`. This is the + * content-forgetting assertion used for raw allocated memory. It is strictly + * weaker than the actually-uninitialized `pmem_uninit_at` assertion. It is + * also the per-byte basis of unknown-content `pmem_undef_data_at`; despite that + * later name, only `pmem_undef_scalar_at` guarantees physical `PMemUninit` + * states. + * + * `pmem_allocated_byte_at address` 存在性地隐藏字节状态，因此既接受 `PMemUninit`，也接受任意 `PMemByte byte`。 + */ +PROOF extern thm pmem_allocated_byte_at_def; + +/* + * Exact ownership of initialized bytes at consecutive addresses: + * + * ```text + * pmem_bytes_at base [] == r_emp mem_ra && + * pmem_bytes_at base (byte :: bytes) == + * r_sep mem_ra + * (pmem_byte_at base byte) + * (pmem_bytes_at (base + &1) bytes). + * ``` + * + * 连续已初始化字节的所有权按列表递归：空列表为 `emp`，非空列表分离拥有基址处首字节与后续地址的尾列表。 + */ +PROOF extern thm pmem_bytes_at_def; + +/** + * Raw computation equation: + * + * ```text + * ⊢ ∀base. pmem_bytes_at base [] == r_emp mem_ra + * ``` + * + * 从任意基址开始拥有空字节列表，恰好就是物理内存代数的 `emp`。 + */ +PROOF extern thm pmem_bytes_at_nil; + +/** + * Step equation: + * + * ```text + * ⊢ ∀base byte bytes. pmem_bytes_at base (byte::bytes) == + * pmem_byte_at base byte **_mem pmem_bytes_at (base + &1) bytes + * ``` + * + * 非空字节列表在 `base` 处分解为首字节的精确所有权，以及从 `base + 1` 开始的尾列表所有权。 + */ +PROOF extern thm pmem_bytes_at_cons; + +/* + * Exact ownership of `count` consecutive allocated bytes with unspecified + * contents: + * + * ```text + * pmem_allocated_at base 0 == r_emp mem_ra && + * pmem_allocated_at base (SUC count) == + * r_sep mem_ra + * (pmem_allocated_byte_at base) + * (pmem_allocated_at (base + &1) count) + * ``` + * + * 连续 allocated 区域按长度递归：零字节为 `emp`，后继长度分离拥有当前任意状态字节与下一地址的剩余区域。 + */ +PROOF extern thm pmem_allocated_at_def; + +/** + * Raw computation equation: + * + * ```text + * ⊢ ∀base. pmem_allocated_at base 0 == r_emp mem_ra + * ``` + * + * 从任意基址开始的零长度 allocated 区域不占有字节，因而等于 `emp`。 + */ +PROOF extern thm pmem_allocated_at_zero; + +/** + * Step equation: + * + * ```text + * ⊢ ∀base count. pmem_allocated_at base (SUC count) == + * pmem_allocated_byte_at base **_mem + * pmem_allocated_at (base + &1) count + * ``` + * + * 长度 `SUC count` 的 allocated 区域分解为 `base` 处任意状态的一字节和从 `base + 1` 开始的 `count` 字节。 + */ +PROOF extern thm pmem_allocated_at_suc; + +/** + * Raw normalization for composition of contiguous allocated ranges: + * + * ```text + * ⊢ ∀m base n. + * pmem_allocated_at base (m + n) == + * r_sep mem_ra + * (pmem_allocated_at base m) + * (pmem_allocated_at (base + &m) n). + * ``` + * + * 从 `base` 开始的 `m+n` 个 allocated 字节，等于长度 `m` 的前缀与从 `base+m` 开始的长度 `n` 后缀之分离合取。 + */ +PROOF extern thm pmem_allocated_at_append; + +/** + * Raw bounded-split normalization derived from `pmem_allocated_at_append`: + * + * ```text + * ⊢ ∀base n k. k ≤ n ⇒ + * pmem_allocated_at base n == + * r_sep mem_ra + * (pmem_allocated_at base k) + * (pmem_allocated_at (base + &k) (n - k)). + * ``` + * + * 若 `k ≤ n`，长度 `n` 的 allocated 区域可在偏移 `k` 处分为长度 `k` 与 `n-k` 的两个相邻片段。 + */ +PROOF extern thm pmem_allocated_at_split; + +/* + * An actually uninitialized singleton entails unspecified allocation: + * + * ```text + * ⊢ ∀address:int. + * r_entails mem_ra + * (pmem_uninit_at address) + * (pmem_allocated_byte_at address). + * ``` + * + * 精确拥有一个 `PMemUninit` 字节时，可遗忘初始化状态而得到同地址的 allocated-byte 所有权。 + */ +PROOF extern thm pmem_uninit_at_allocated_byte; + +/* + * An initialized singleton entails unspecified allocation: + * + * ```text + * ⊢ ∀(address:int) (byte:int). + * r_entails mem_ra + * (pmem_byte_at address byte) + * (pmem_allocated_byte_at address). + * ``` + * + * 精确拥有地址处值为 `byte` 的已初始化字节时，可遗忘其值和初始化状态而得到 allocated-byte 所有权。 + */ +PROOF extern thm pmem_byte_at_allocated_byte; + +/* + * Initialized consecutive bytes may be forgotten to allocated bytes: + * + * ```text + * ⊢ ∀(bytes:int list) (base:int). + * r_entails mem_ra + * (pmem_bytes_at base bytes) + * (pmem_allocated_at base (LENGTH bytes)). + * ``` + * + * 连续拥有列表 `bytes` 中的具体字节，可逐字节遗忘内容为从同一基址开始、长度 `LENGTH bytes` 的 allocated 区域。 + */ +PROOF extern thm pmem_bytes_at_allocated; + +/* ------------------------------------------------------------------------- */ +/* Provisional little-endian scalar representation */ +/* ------------------------------------------------------------------------- */ + +/* + * `pmem_le_bytes count value` is the low `count` base-256 digits of `value`, + * least-significant digit first: + * + * ```text + * pmem_le_bytes 0 integer_value == [] && + * pmem_le_bytes (SUC count) integer_value == + * (integer_value rem &256) :: + * pmem_le_bytes count (integer_value div &256) + * ``` + * + * Fixed-width recursion also gives negative HOL integers their usual + * truncated two's-complement byte representation; range and signedness are + * imposed only by the later C scalar-type layer. + * + * `pmem_le_bytes count value` 递归取 `value` 的低 `count` 个 base-256 数位，并按最低有效字节在前排列。 + */ +PROOF extern thm pmem_le_bytes_def; + +/** + * Data computation: + * + * ```text + * ⊢ ∀value. pmem_le_bytes 0 value == [] + * ``` + * + * 任意整数截取零个小端字节都得到空列表。 + */ +PROOF extern thm pmem_le_bytes_zero; + +/** + * Step equation: + * + * ```text + * ⊢ ∀count value. pmem_le_bytes (SUC count) value == + * (value rem &256)::pmem_le_bytes count (value div &256) + * ``` + * + * 非零长度的小端编码以 `value rem 256` 为首字节，并递归编码 `value div 256` 的剩余字节。 + */ +PROOF extern thm pmem_le_bytes_suc; + +/** + * ```text + * ⊢ ∀(count:num)(value:int). LENGTH (pmem_le_bytes count value) == count + * ``` + * + * `pmem_le_bytes count value` 对任意整数都恰好产生 `count` 个字节。 + */ +PROOF extern thm pmem_le_bytes_length; + +/* + * Exact initialized scalar storage at byte width `count`: + * + * ```text + * pmem_scalar_at base count integer_value == + * pmem_bytes_at base (pmem_le_bytes count integer_value) + * ``` + * + * `pmem_scalar_at base count value` 精确拥有从 `base` 起存放 `value` 的 `count` 字节小端编码。 + */ +PROOF extern thm pmem_scalar_at_def; + +/* + * Strictly uninitialized scalar storage: + * + * ```text + * pmem_undef_scalar_at base 0 == r_emp mem_ra && + * pmem_undef_scalar_at base (SUC count) == + * r_sep mem_ra + * (pmem_uninit_at base) + * (pmem_undef_scalar_at (base + &1) count) + * ``` + * + * Every owned byte is exactly `PMemUninit`; this assertion does not admit an + * initialized byte with an existentially hidden value. + * + * `pmem_undef_scalar_at` 递归要求范围内每个字节都精确处于 `PMemUninit`，而非仅隐藏其内容。 + */ +PROOF extern thm pmem_undef_scalar_at_def; + +/** + * Empty initialized scalar storage: + * + * ```text + * ⊢ ∀(base:int)(value:int). pmem_scalar_at base 0 value == r_emp mem_ra + * ``` + * + * 零宽度的已初始化标量不占有任何物理字节，因此等于 `emp`，与 `base` 和 `value` 无关。 + */ +PROOF extern thm pmem_scalar_at_zero; + +/* + * Little-endian head/tail equation: + * + * ```text + * ⊢ ∀(base:int)(count:num)(value:int). + * pmem_scalar_at base (SUC count) value == + * r_sep mem_ra + * (pmem_byte_at base (value rem &256)) + * (pmem_scalar_at + * (base + &1) count (value div &256)). + * ``` + * + * 非零宽度标量在 `base` 处存低字节 `value rem 256`，其余 `count` 字节在下一地址存 `value div 256`。 + */ +PROOF extern thm pmem_scalar_at_suc; + +/** + * Empty uninitialized scalar storage: + * + * ```text + * ⊢ ∀base:int. pmem_undef_scalar_at base 0 == r_emp mem_ra + * ``` + * + * 零宽度的严格未初始化标量不占有任何字节，因而等于 `emp`。 + */ +PROOF extern thm pmem_undef_scalar_at_zero; + +/* + * Uninitialized scalar storage unfolds by one uninitialized byte: + * + * ```text + * ⊢ ∀(base:int)(count:num). + * pmem_undef_scalar_at base (SUC count) == + * r_sep mem_ra + * (pmem_uninit_at base) + * (pmem_undef_scalar_at (base + &1) count). + * ``` + * + * 非零宽度的严格未初始化标量分离拥有 `base` 处一个 `PMemUninit` 字节及下一地址起的剩余字节。 + */ +PROOF extern thm pmem_undef_scalar_at_suc; + +/** + * Strictly uninitialized storage may be weakened to arbitrary allocated + * storage without claiming that initialized storage is uninitialized: + * + * ```text + * ⊢ ∀count base. + * pmem_undef_scalar_at base count ⊢_mem + * pmem_allocated_at base count. + * ``` + * + * 连续 `count` 个确为 `PMemUninit` 的字节可遗忘其状态，得到同地址、同长度的 allocated 区域。 + */ +PROOF extern thm pmem_undef_scalar_at_allocated; + +/* + * Initialized scalar contents can soundly be forgotten only to arbitrary + * allocated storage, not to uninitialized storage: + * + * ```text + * ⊢ ∀(base:int) (count:num) (value:int). + * r_entails mem_ra + * (pmem_scalar_at base count value) + * (pmem_allocated_at base count). + * ``` + * + * 存放具体标量值的 `count` 个已初始化字节可遗忘其内容，得到同地址、同长度的 allocated 区域。 + */ +PROOF extern thm pmem_scalar_at_allocated; diff --git a/theory/data/int_list.c b/theory/data/int_list.c new file mode 100644 index 0000000000000000000000000000000000000000..f2e4148f1cc958ace014c3be4fe5af047960f5f4 --- /dev/null +++ b/theory/data/int_list.c @@ -0,0 +1,175 @@ +#include "proof/theory/data/int_list.h" + +#include "proof/proof_backward.h" +#include "proof/theory/data/list.h" +#require "proof/proof_backward.c" +#require "proof/theory/data/list.c" + +PROOF static thm_list INT_LIST_INITIAL_AXIOMS = get_all_axioms(); +PROOF static size_t INT_LIST_AXIOMS_BEFORE = + vector_size(INT_LIST_INITIAL_AXIOMS); + +PROOF thm ILENGTH_DEF = new_rec_definition( + get_theorem_by_name("list_RECURSION"), + ` + (ilength ([]:(A)list) = &0) && + (ilength ((head:A) :: (tail:(A)list)) = &1 + ilength tail) + `); + +PROOF thm NTH_DEF = new_fun_definition(` + (NTH 0 ((head:A) :: (tail:(A)list)) = head) && + (NTH (SUC index) (head :: tail) = NTH index tail) +`); + +PROOF thm INTH_DEF = new_fun_definition(` + inth (index:int) (values:(A)list) = + NTH (num_of_int index) values +`); + +PROOF thm REPLACE_NTH_DEF = new_fun_definition(` + (REPLACE_NTH index (value:A) [] = []) && + (REPLACE_NTH 0 value ((head:A) :: tail) = value :: tail) && + (REPLACE_NTH (SUC index) value (head :: tail) = + head :: REPLACE_NTH index value tail) +`); + +PROOF thm REPLACE_INTH_DEF = new_fun_definition(` + replace_inth (index:int) (value:A) (values:(A)list) = + REPLACE_NTH (num_of_int index) value values +`); + +PROOF thm FIRSTN_DEF = new_fun_definition(` + (FIRSTN 0 (values:(A)list) = []) && + (FIRSTN (SUC count) ([]:(A)list) = []) && + (FIRSTN (SUC count) ((head:A) :: tail) = + head :: FIRSTN count tail) +`); + +PROOF thm IFIRSTN_DEF = new_fun_definition(` + ifirstn (count:int) (values:(A)list) = + FIRSTN (num_of_int count) values +`); + +PROOF thm SKIPN_DEF = new_fun_definition(` + (SKIPN 0 (values:(A)list) = values) && + (SKIPN (SUC count) ([]:(A)list) = []) && + (SKIPN (SUC count) ((head:A) :: tail) = SKIPN count tail) +`); + +PROOF thm ISKIPN_DEF = new_fun_definition(` + iskipn (count:int) (values:(A)list) = + SKIPN (num_of_int count) values +`); + +PROOF thm IREPLICATE_DEF = new_fun_definition(` + ireplicate (count:int) (value:A) = + REPLICATE (num_of_int count) value +`); + +PROOF thm SUBLIST_DEF = new_fun_definition(` + sublist (lower:int) (upper:int) (values:(A)list) = + SKIPN (num_of_int lower) (FIRSTN (num_of_int upper) values) +`); + +PROOF static thm prove_ilength_nonnegative(void) { + gnode root = gnode_new_with_ccl(` + forall values:(A)list. &0 <= ilength values + `); + gnode body = GEN_TAC(root, "values"); + gnode_list cases = INDUCT_TAC(body, `values:(A)list`); + + gnode reduced_base = CONV_TAC( + cases[0], + rewrite_conv(THM_LIST(conjunct1_rule(ILENGTH_DEF)))); + ACCEPT_TAC(reduced_base, int_arith_rule(`&0 <= &0`)); + + thm induction_hypothesis = assume_rule( + gnode_get_asmps(cases[1], CONST_STRING_LIST("H"))[0]); + thm successor_step = int_arith_rule(` + &0 <= ilength (a1:(A)list) ==> + &0 <= &1 + ilength a1 + `); + thm successor_nonnegative = + mp_rule(successor_step, induction_hypothesis); + thm cons_length = inst_rule( + TERM_PAIR_LIST( + (term_pair){`head:A`, `head:A`}, + (term_pair){`a1:(A)list`, `tail:(A)list`}), + conjunct2_rule(ILENGTH_DEF)); + gnode reduced_step = CONV_TAC( + cases[1], + rewrite_conv(THM_LIST( + conjunct1_rule(ILENGTH_DEF), cons_length))); + ACCEPT_TAC(reduced_step, successor_nonnegative); + return gnode_prove(root); +} + +PROOF thm ILENGTH_NONNEG = prove_ilength_nonnegative(); + +PROOF static thm prove_ilength_append(void) { + gnode root = gnode_new_with_ccl(` + forall left:(A)list. forall right:(A)list. + ilength (left ++ right) = ilength left + ilength right + `); + gnode body = GEN_TAC(root, "left"); + gnode_list cases = INDUCT_TAC(body, `left:(A)list`); + + gnode base = AUTO_INTROS_TAC(cases[0]); + gnode reduced_base = CONV_TAC(base, pure_rewrite_conv(THM_LIST( + ILENGTH_DEF, + HOL_APPEND, + get_theorem_by_name("INT_ADD_LID")))); + RULE_TAC(reduced_base, int_arith_rule); + + gnode step = AUTO_INTROS_TAC(cases[1]); + gnode reduced_step = CONV_WITH_ASMP_TAC( + step, pure_rewrite_conv, THM_LIST( + ILENGTH_DEF, + HOL_APPEND, + get_theorem_by_name("INT_ADD_ASSOC"))); + RULE_TAC(reduced_step, int_arith_rule); + return gnode_prove(root); +} + +PROOF thm ILENGTH_APPEND = prove_ilength_append(); + +PROOF static int int_list_register_theorems(void) { +#define REGISTER_THEOREM(name, theorem) \ + ENSURE_COND(add_theorem((name), (theorem)), \ + "duplicate integer-list theorem name: " name) + + REGISTER_THEOREM("ILENGTH_DEF", ILENGTH_DEF); + REGISTER_THEOREM("NTH_DEF", NTH_DEF); + REGISTER_THEOREM("INTH_DEF", INTH_DEF); + REGISTER_THEOREM("REPLACE_NTH_DEF", REPLACE_NTH_DEF); + REGISTER_THEOREM("REPLACE_INTH_DEF", REPLACE_INTH_DEF); + REGISTER_THEOREM("FIRSTN_DEF", FIRSTN_DEF); + REGISTER_THEOREM("IFIRSTN_DEF", IFIRSTN_DEF); + REGISTER_THEOREM("SKIPN_DEF", SKIPN_DEF); + REGISTER_THEOREM("ISKIPN_DEF", ISKIPN_DEF); + REGISTER_THEOREM("IREPLICATE_DEF", IREPLICATE_DEF); + REGISTER_THEOREM("SUBLIST_DEF", SUBLIST_DEF); + REGISTER_THEOREM("ILENGTH_NONNEG", ILENGTH_NONNEG); + REGISTER_THEOREM("ILENGTH_APPEND", ILENGTH_APPEND); + +#undef REGISTER_THEOREM + return 0; +err: + ERR_FUN_PUTS("int_list_register_theorems"); + return -1; +} + +PROOF static int _INT_LIST_THEOREMS_REGISTERED = + int_list_register_theorems(); + +PROOF static int int_list_check_axiom_free(void) { + thm_list final_axioms = get_all_axioms(); + ENSURE_COND(vector_size(final_axioms) == INT_LIST_AXIOMS_BEFORE, + "int_list introduced a new axiom"); + return 0; +err: + ERR_FUN_PUTS("int_list_check_axiom_free"); + return -1; +} + +PROOF static int _INT_LIST_AXIOM_CHECK = int_list_check_axiom_free(); diff --git a/theory/data/int_list.h b/theory/data/int_list.h new file mode 100644 index 0000000000000000000000000000000000000000..621c22116b42d9c5967c5df00a45d01752288f42 --- /dev/null +++ b/theory/data/int_list.h @@ -0,0 +1,155 @@ +/** + * @file int_list.h + * @brief Integer-indexed wrappers around HOL lists. + * + * This language-independent theory contains the list constants historically + * created by the OCaml C* bootstrap. Integer indices are converted with + * `num_of_int`; clients should establish nonnegativity before applying bounded + * indexing theorems. No C type, memory model, assertion model, or RA occurs + * in this module. + */ + +#pragma once + +#include "proof/proof_kernel.h" + +/** + * HOL conclusion: + * + * ```text + * (ilength ([]:(A)list) = &0) && (ilength ((head:A) :: (tail:(A)list)) = &1 + + * ilength tail) + * ``` + * + * 整数长度在空列表上为零，在非空列表上等于表尾长度加一。 + */ +PROOF extern thm ILENGTH_DEF; +/** + * HOL conclusion: + * + * ```text + * (NTH 0 ((head:A) :: (tail:(A)list)) = head) && (NTH (SUC index) + * (head :: tail) = NTH index tail) + * ``` + * + * 非空列表的第零项是表头，第 `SUC index` 项递归为表尾的第 `index` 项。 + */ +PROOF extern thm NTH_DEF; +/** + * HOL conclusion: + * + * ```text + * inth (index:int) (values:(A)list) = NTH (num_of_int index) values + * ``` + * + * 整数索引访问先用 `num_of_int` 转为自然数，再调用 `NTH`。 + */ +PROOF extern thm INTH_DEF; +/** + * HOL conclusion: + * + * ```text + * (REPLACE_NTH index (value:A) [] = []) && (REPLACE_NTH 0 value ((head:A) :: + * tail) = value :: tail) && (REPLACE_NTH (SUC index) value (head :: tail) = + * head :: REPLACE_NTH index value tail) + * ``` + * + * 按自然数索引替换时，空列表不变、零索引替换表头、后继索引递归替换表尾。 + */ +PROOF extern thm REPLACE_NTH_DEF; +/** + * HOL conclusion: + * + * ```text + * replace_inth (index:int) (value:A) (values:(A)list) = REPLACE_NTH + * (num_of_int index) value values + * ``` + * + * 整数索引替换先把索引转为自然数，再调用 `REPLACE_NTH`。 + */ +PROOF extern thm REPLACE_INTH_DEF; +/** + * HOL conclusion: + * + * ```text + * (FIRSTN 0 (values:(A)list) = []) && (FIRSTN (SUC count) ([]:(A)list) = []) + * && (FIRSTN (SUC count) ((head:A) :: tail) = head :: FIRSTN count tail) + * ``` + * + * `FIRSTN` 在计数为零或列表为空时返回空表，否则保留表头并递归取剩余前缀。 + */ +PROOF extern thm FIRSTN_DEF; +/** + * HOL conclusion: + * + * ```text + * ifirstn (count:int) (values:(A)list) = FIRSTN (num_of_int count) values + * ``` + * + * 整数计数的前缀操作先转为自然数计数，再调用 `FIRSTN`。 + */ +PROOF extern thm IFIRSTN_DEF; +/** + * HOL conclusion: + * + * ```text + * (SKIPN 0 (values:(A)list) = values) && (SKIPN (SUC count) ([]:(A)list) = + * []) && (SKIPN (SUC count) ((head:A) :: tail) = SKIPN count tail) + * ``` + * + * `SKIPN` 在计数为零时返回原表，正计数时逐个丢弃表头，空表始终返回空表。 + */ +PROOF extern thm SKIPN_DEF; +/** + * HOL conclusion: + * + * ```text + * iskipn (count:int) (values:(A)list) = SKIPN (num_of_int count) values + * ``` + * + * 整数计数的跳过操作先转为自然数计数，再调用 `SKIPN`。 + */ +PROOF extern thm ISKIPN_DEF; +/** + * HOL conclusion: + * + * ```text + * ireplicate (count:int) (value:A) = REPLICATE (num_of_int count) value + * ``` + * + * 整数次数的复制先把次数转为自然数，再调用 `REPLICATE`。 + */ +PROOF extern thm IREPLICATE_DEF; +/** + * HOL conclusion: + * + * ```text + * sublist (lower:int) (upper:int) (values:(A)list) = SKIPN (num_of_int lower) + * (FIRSTN (num_of_int upper) values) + * ``` + * + * 子列表先截取到整数上界对应的前缀，再跳过整数下界对应的元素数。 + */ +PROOF extern thm SUBLIST_DEF; + +/** + * HOL conclusion: + * + * ```text + * forall values:(A)list. &0 <= ilength values + * ``` + * + * 任意列表的整数长度都不小于零。 + */ +PROOF extern thm ILENGTH_NONNEG; +/** + * HOL conclusion: + * + * ```text + * forall left:(A)list. forall right:(A)list. ilength (left ++ right) = + * ilength left + ilength right + * ``` + * + * 两个列表拼接后的整数长度等于各自整数长度之和。 + */ +PROOF extern thm ILENGTH_APPEND; diff --git a/theory/data/list.c b/theory/data/list.c new file mode 100644 index 0000000000000000000000000000000000000000..bd09b0ece949ea5e60531cc6adcb9a9c7a18c220 --- /dev/null +++ b/theory/data/list.c @@ -0,0 +1,62 @@ +#include "proof/theory/data/list.h" + +PROOF static thm prove_HOL_LENGTH(void) { + thm result = get_theorem_by_name("LENGTH"); + term expected = ` + (LENGTH ([]:(A)list) = 0) /\ + (!h:A. !t. LENGTH (CONS h t) = SUC (LENGTH t)) + `; + ENSURE_COND(equals_term(concl(result), expected), + "HOL LENGTH theorem has an unexpected conclusion"); + return result; +err: + ERR_FUN_PUTS("prove_HOL_LENGTH", cstr_thm(result), cstr_term(expected)); + return empty_theorem; +} + +PROOF static thm prove_HOL_APPEND(void) { + thm result = get_theorem_by_name("APPEND"); + term expected = ` + (!l:(A)list. APPEND [] l = l) /\ + (!h:A. !t l. APPEND (CONS h t) l = CONS h (APPEND t l)) + `; + ENSURE_COND(equals_term(concl(result), expected), + "HOL APPEND theorem has an unexpected conclusion"); + return result; +err: + ERR_FUN_PUTS("prove_HOL_APPEND", cstr_thm(result), cstr_term(expected)); + return empty_theorem; +} + +PROOF static thm prove_HOL_REVERSE(void) { + thm result = get_theorem_by_name("REVERSE"); + term expected = ` + (REVERSE ([]:(A)list) = []) /\ + (REVERSE (CONS (x:A) l) = APPEND (REVERSE l) (CONS x [])) + `; + ENSURE_COND(equals_term(concl(result), expected), + "HOL REVERSE theorem has an unexpected conclusion"); + return result; +err: + ERR_FUN_PUTS("prove_HOL_REVERSE", cstr_thm(result), cstr_term(expected)); + return empty_theorem; +} + +PROOF static thm prove_HOL_REPLICATE(void) { + thm result = get_theorem_by_name("REPLICATE"); + term expected = ` + (REPLICATE 0 (x:A) = []) /\ + (REPLICATE (SUC n) x = CONS x (REPLICATE n x)) + `; + ENSURE_COND(equals_term(concl(result), expected), + "HOL REPLICATE theorem has an unexpected conclusion"); + return result; +err: + ERR_FUN_PUTS("prove_HOL_REPLICATE", cstr_thm(result), cstr_term(expected)); + return empty_theorem; +} + +PROOF thm HOL_LENGTH = prove_HOL_LENGTH(); +PROOF thm HOL_APPEND = prove_HOL_APPEND(); +PROOF thm HOL_REVERSE = prove_HOL_REVERSE(); +PROOF thm HOL_REPLICATE = prove_HOL_REPLICATE(); diff --git a/theory/data/list.h b/theory/data/list.h new file mode 100644 index 0000000000000000000000000000000000000000..9f4160eec8027ebf87eabd65d927793431c7ccd6 --- /dev/null +++ b/theory/data/list.h @@ -0,0 +1,58 @@ +/** + * @file list.h + * @brief Stable proof-stdlib bindings for HOL's primitive list equations. + * + * These language-independent theorems are resolved once during proof + * initialization. They live in the proof stdlib rather than the native + * verification runtime, so runtime initialization does not depend on which + * user-level data theory a proof happens to use. + */ + +#pragma once + +#include "proof/proof_kernel.h" + +/** + * HOL conclusion: + * + * ```text + * (LENGTH ([]:(A)list) = 0) /\ (!h:A. !t. LENGTH (CONS h t) = SUC + * (LENGTH t)) + * ``` + * + * 空列表长度为零，向表头加入一个元素会使长度增加一。 + */ +PROOF extern thm HOL_LENGTH; +/** + * HOL conclusion: + * + * ```text + * (!l:(A)list. APPEND [] l = l) /\ (!h:A. !t l. APPEND (CONS h t) l = + * CONS h (APPEND t l)) + * ``` + * + * 空列表作为左参数时拼接不变，非空左参数的表头保留并递归拼接表尾。 + */ +PROOF extern thm HOL_APPEND; +/** + * HOL conclusion: + * + * ```text + * (REVERSE ([]:(A)list) = []) /\ (REVERSE (CONS (x:A) l) = APPEND + * (REVERSE l) (CONS x [])) + * ``` + * + * 空列表反转后仍为空，非空列表反转时把原表头追加到反转后表尾。 + */ +PROOF extern thm HOL_REVERSE; +/** + * HOL conclusion: + * + * ```text + * (REPLICATE 0 (x:A) = []) /\ (REPLICATE (SUC n) x = CONS x + * (REPLICATE n x)) + * ``` + * + * 重复零次得到空列表，重复后继次数会在递归结果前再加入一个给定元素。 + */ +PROOF extern thm HOL_REPLICATE; diff --git a/theory/logic/agree_ra.c b/theory/logic/agree_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..718b7c2d191a91b7bfdb0d4c63c4987e78b372d4 --- /dev/null +++ b/theory/logic/agree_ra.c @@ -0,0 +1,1047 @@ +#include "proof/theory/logic/agree_ra.h" +#include "proof/theory/logic/ra_builder.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" +#require "proof/theory/logic/local_update.c" + +PROOF static size_t AGREE_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static indtype agree_type = new_datatype_definition( + "agree = AgreeUnit" + " | Agree A" + " | AgreeInvalid"); + +PROOF static thm agree_owned_op_def = new_rec_definition( + agree_type.rec, + ` + agree_owned_op + (a:A) + (AgreeUnit:(A)agree) = + Agree a && + agree_owned_op + (a:A) + (Agree b) = + (if a == b + then Agree a + else (AgreeInvalid:(A)agree)) && + agree_owned_op + (a:A) + (AgreeInvalid:(A)agree) = + AgreeInvalid + `); + +PROOF static thm agree_op_def = new_rec_definition( + agree_type.rec, + ` + agree_op + (AgreeUnit:(A)agree) + (y:(A)agree) = + y && + agree_op + (Agree a) + (y:(A)agree) = + agree_owned_op a y && + agree_op + (AgreeInvalid:(A)agree) + (y:(A)agree) = + AgreeInvalid + `); + +PROOF static thm agree_valid_def = new_rec_definition( + agree_type.rec, + ` + (agree_valid (AgreeUnit:(A)agree) <=> T) && + (agree_valid (Agree a) <=> T) && + (agree_valid (AgreeInvalid:(A)agree) <=> F) + `); + +PROOF static thm prove_agree_owned_assoc(void) { + term goal_tm = ` + forall a b c:A. + agree_op + (agree_owned_op a (Agree b)) + (Agree c) == + agree_owned_op + a + (agree_owned_op b (Agree c)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list ab_cases = BOOL_CASES_TAC( + body, `(a:A) == (b:A)`, "Hab"); + for (size_t i = 0; i < vector_size(ab_cases); ++i) { + gnode_list bc_cases = BOOL_CASES_TAC( + ab_cases[i], `(b:A) == (c:A)`, "Hbc"); + for (size_t j = 0; j < vector_size(bc_cases); ++j) { + gnode reduced = CONV_WITH_ASMP_TAC( + bc_cases[j], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def)); + if (i == 1 && j == 0) { + thm not_ac = pure_once_rewrite_rule( + THM_LIST(assume_rule(`(b:A) == (c:A)`)), + assume_rule(`~((a:A) == (b:A))`)); + CONV_TAC( + reduced, + rewrite_conv(THM_LIST(not_ac))); + } + } + } + return gnode_prove(root); +} + +PROOF static thm agree_owned_assoc = + prove_agree_owned_assoc(); + +PROOF static thm prove_agree_owned_comm(void) { + term goal_tm = ` + forall a b:A. + agree_owned_op a (Agree b) == + agree_owned_op b (Agree a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list cases = BOOL_CASES_TAC( + body, `(a:A) == (b:A)`, "Hab"); + + gnode equal = CONV_TAC( + cases[0], + subs_conv(THM_LIST( + assume_rule(`(a:A) == (b:A)`)))); + CONV_TAC( + equal, + rewrite_conv(THM_LIST(agree_owned_op_def))); + + thm eqsym = ispecl_rule( + TERM_LIST(`a:A`, `b:A`), + get_theorem_by_name("EQ_SYM_EQ")); + thm reverse_unequal = pure_once_rewrite_rule( + THM_LIST(eqsym), + assume_rule(`~((a:A) == (b:A))`)); + CONV_TAC( + cases[1], + rewrite_conv(THM_LIST( + agree_owned_op_def, + assume_rule(`~((a:A) == (b:A))`), + reverse_unequal))); + return gnode_prove(root); +} + +PROOF static thm agree_owned_comm = + prove_agree_owned_comm(); + +PROOF static thm prove_agree_ra_laws(void) { + term goal_tm = ` + ra_laws + (AgreeUnit:(A)agree) + agree_op + agree_valid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode unfolded = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + gnode_list assoc_x = CASES_TAC( + assoc, `a:(A)agree`, NULL); + for (size_t i = 0; i < vector_size(assoc_x); ++i) { + gnode_list assoc_y = CASES_TAC( + assoc_x[i], `b:(A)agree`, NULL); + for (size_t j = 0; j < vector_size(assoc_y); ++j) { + gnode_list assoc_z = CASES_TAC( + assoc_y[j], `c:(A)agree`, NULL); + for (size_t k = 0; k < vector_size(assoc_z); ++k) { + if (i == 1 && j == 1 && k == 1) { + gnode substituted = CONV_WITH_ASMP_TAC( + assoc_z[k], + subs_conv, + THM_LIST()); + gnode normalized = substituted; + for (size_t l = 0; l < 3; ++l) { + normalized = CONV_TAC( + normalized, + once_rewrite_conv(THM_LIST(agree_op_def))); + } + gnode associated = CONV_TAC( + normalized, + once_rewrite_conv(THM_LIST(agree_owned_assoc))); + CONV_TAC( + associated, + rewrite_conv(THM_LIST())); + } else if (i == 1 && j == 1) { + gnode_list payload_cases = BOOL_CASES_TAC( + assoc_z[k], `(a:A) == (a_:A)`, "Hab_payload"); + for (size_t l = 0; l < vector_size(payload_cases); ++l) { + CONV_WITH_ASMP_TAC( + payload_cases[l], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def)); + } + } else { + CONV_WITH_ASMP_TAC( + assoc_z[k], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def)); + } + } + } + } + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + gnode_list comm_x = CASES_TAC( + comm, `a:(A)agree`, NULL); + for (size_t i = 0; i < vector_size(comm_x); ++i) { + gnode_list comm_y = CASES_TAC( + comm_x[i], `b:(A)agree`, NULL); + for (size_t j = 0; j < vector_size(comm_y); ++j) { + CONV_WITH_ASMP_TAC( + comm_y[j], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def, + agree_owned_comm)); + } + } + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = AUTO_INTROS_TAC(law3[0]); + gnode_list unit_cases = CASES_TAC( + unit, `a:(A)agree`, NULL); + for (size_t i = 0; i < vector_size(unit_cases); ++i) { + CONV_WITH_ASMP_TAC( + unit_cases[i], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def)); + } + + gnode_list law4 = CONJ_TAC(law3[1]); + CONV_TAC( + law4[0], + rewrite_conv(THM_LIST(agree_valid_def))); + + gnode valid_down = GEN_TAC(law4[1], "a"); + valid_down = GEN_TAC(valid_down, "b"); + gnode_list valid_x = CASES_TAC( + valid_down, `a:(A)agree`, NULL); + for (size_t i = 0; i < vector_size(valid_x); ++i) { + gnode_list valid_y = CASES_TAC( + valid_x[i], `b:(A)agree`, NULL); + for (size_t j = 0; j < vector_size(valid_y); ++j) { + CONV_WITH_ASMP_TAC( + valid_y[j], + rewrite_conv, + THM_LIST( + agree_op_def, + agree_owned_op_def, + agree_valid_def)); + } + } + return gnode_prove(root); +} + +PROOF static thm agree_ra_laws = + prove_agree_ra_laws(); + +PROOF static thm agree_ra_def = new_fun_definition(` + agree_ra : ((A)agree)ra = + ra_abs + ((AgreeUnit:(A)agree), + (agree_op:(A)agree->(A)agree->(A)agree, + agree_valid:(A)agree->bool)) +`); + +PROOF static thm prove_agree_ra_unit(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `AgreeUnit:(A)agree`, + `agree_op:(A)agree->(A)agree->(A)agree`, + `agree_valid:(A)agree->bool`), + ra_unit_abs), + agree_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(agree_ra_def)), + computed); +} + +PROOF thm agree_ra_unit = + prove_agree_ra_unit(); + +PROOF static thm prove_agree_ra_op_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `AgreeUnit:(A)agree`, + `agree_op:(A)agree->(A)agree->(A)agree`, + `agree_valid:(A)agree->bool`), + ra_op_abs), + agree_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(agree_ra_def)), + computed); +} + +PROOF static thm agree_ra_op_fn = + prove_agree_ra_op_fn(); + +PROOF static thm prove_agree_ra_valid_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `AgreeUnit:(A)agree`, + `agree_op:(A)agree->(A)agree->(A)agree`, + `agree_valid:(A)agree->bool`), + ra_valid_abs), + agree_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(agree_ra_def)), + computed); +} + +PROOF static thm agree_ra_valid_fn = + prove_agree_ra_valid_fn(); + +PROOF static thm prove_agree_ra_owned_op(void) { + term goal_tm = ` + forall a b:A. + ra_op agree_ra (Agree a) (Agree b) == + (if a == b + then Agree a + else (AgreeInvalid:(A)agree)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + agree_ra_op_fn, + agree_op_def, + agree_owned_op_def))); + return gnode_prove(root); +} + +PROOF thm agree_ra_owned_op = + prove_agree_ra_owned_op(); + +PROOF static thm prove_agree_ra_idempotent(void) { + term goal_tm = ` + forall a:A. + ra_op agree_ra (Agree a) (Agree a) == + (Agree a:(A)agree) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(agree_ra_owned_op))); + return gnode_prove(root); +} + +PROOF thm agree_ra_idempotent = + prove_agree_ra_idempotent(); + +PROOF static thm prove_agree_ra_owned_inj(void) { + term goal_tm = ` + forall (a:A) (b:A). + (Agree a:(A)agree) == Agree b <=> a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_datatype_injectivity("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_owned_inj = + prove_agree_ra_owned_inj(); + +PROOF static thm prove_agree_ra_owned_ne_unit(void) { + term goal_tm = ` + forall a:A. ~((Agree a:(A)agree) == AgreeUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_datatype_distinctness("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_owned_ne_unit = + prove_agree_ra_owned_ne_unit(); + +PROOF static thm prove_agree_ra_invalid_ne_unit(void) { + term goal_tm = ` + ~((AgreeInvalid:(A)agree) == AgreeUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_datatype_distinctness("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_invalid_ne_unit = + prove_agree_ra_invalid_ne_unit(); + +PROOF static thm prove_agree_ra_invalid_ne_owned(void) { + term goal_tm = ` + forall a:A. ~((AgreeInvalid:(A)agree) == Agree a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_datatype_distinctness("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_invalid_ne_owned = + prove_agree_ra_invalid_ne_owned(); + +PROOF static thm prove_agree_ra_valid_unit_public(void) { + term goal_tm = `ra_valid agree_ra (AgreeUnit:(A)agree)`; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + agree_ra_valid_fn, + agree_valid_def))); + return gnode_prove(root); +} + +PROOF thm agree_ra_valid_unit = + prove_agree_ra_valid_unit_public(); + +PROOF static thm prove_agree_ra_valid_owned(void) { + term goal_tm = ` + forall a:A. + ra_valid agree_ra (Agree a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + agree_ra_valid_fn, + agree_valid_def))); + return gnode_prove(root); +} + +PROOF thm agree_ra_valid_owned = + prove_agree_ra_valid_owned(); + +PROOF static thm prove_agree_ra_invalid(void) { + term goal_tm = ` + ~(ra_valid agree_ra (AgreeInvalid:(A)agree)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + agree_ra_valid_fn, + agree_valid_def))); + return gnode_prove(root); +} + +PROOF thm agree_ra_invalid = + prove_agree_ra_invalid(); + +PROOF static thm prove_agree_ra_valid_combine_iff(void) { + term goal_tm = ` + forall a b:A. + ra_valid agree_ra + (ra_op agree_ra (Agree a) (Agree b)) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list cases = BOOL_CASES_TAC( + body, `(a:A) == (b:A)`, "Hab"); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + agree_ra_owned_op, + agree_ra_valid_owned, + agree_ra_invalid)); + } + return gnode_prove(root); +} + +PROOF thm agree_ra_valid_combine_iff = + prove_agree_ra_valid_combine_iff(); + +PROOF static thm prove_agree_ra_agreement(void) { + term a = `a:A`; + term b = `b:A`; + term combined_valid = ` + ra_compatible agree_ra (Agree (a:A)) (Agree (b:A)) + `; + thm equivalence = ispecl_rule( + TERM_LIST(a, b), + agree_ra_valid_combine_iff); + thm conclusion = eq_mp_rule( + equivalence, + rewrite_rule( + THM_LIST(ra_compatible_def), + assume_rule(combined_valid))); + conclusion = disch_rule(combined_valid, conclusion); + conclusion = gen_rule(b, conclusion); + return gen_rule(a, conclusion); +} + +PROOF thm agree_ra_agreement = + prove_agree_ra_agreement(); + +/* ------------------------------------------------------------------------- */ +/* Updates */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_agree_ra_update_iff(void) { + term goal_tm = ` + forall a b:A. + ra_update + agree_ra + (Agree a) + (Agree b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + thm source_op = ispec_rule( + `a:A`, + agree_ra_idempotent); + thm source_valid_eq = ap_term_rule( + `ra_valid agree_ra:(A)agree->bool`, + source_op); + thm source_valid = eq_mp_rule( + sym_rule(source_valid_eq), + ispec_rule(`a:A`, agree_ra_valid_owned)); + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (a:A):(A)agree`, + `Agree (b:A):(A)agree`, + `Agree (a:A):(A)agree`), + ra_update_frame), + assume_rule(` + ra_update agree_ra (Agree (a:A)) (Agree (b:A)) + `)); + thm target_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `ra_op agree_ra (Agree (a:A)) (Agree (a:A))`, + `ra_op agree_ra (Agree (b:A)) (Agree (a:A))`), + ra_update_valid), + framed_update); + target_valid = mp_rule( + target_valid, + source_valid); + thm target_agrees = mp_rule( + ispecl_rule( + TERM_LIST(`b:A`, `a:A`), + agree_ra_agreement), + rewrite_rule( + THM_LIST(gsym_rule(ra_compatible_def)), + target_valid)); + ACCEPT_TAC(forward, sym_rule(target_agrees)); + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + thm owned_eq = ap_term_rule( + `Agree:A->(A)agree`, + assume_rule(`(a:A) == (b:A)`)); + thm target_transport = beta_rule(ap_term_rule( + `\x:(A)agree. + ra_update agree_ra (Agree (a:A)) x`, + owned_eq)); + thm reflexive = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (a:A):(A)agree`), + ra_update_refl); + ACCEPT_TAC( + reverse, + eq_mp_rule(target_transport, reflexive)); + return gnode_prove(root); +} + +PROOF thm agree_ra_update_iff = + prove_agree_ra_update_iff(); + +PROOF static thm prove_agree_ra_local_update_iff(void) { + term goal_tm = ` + forall a b:A. + ra_local_update + agree_ra + (Agree a) + (Agree a) + (Agree b) + (Agree b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hlocal"); + thm updated = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (a:A):(A)agree`, + `Agree (a:A):(A)agree`, + `Agree (b:A):(A)agree`, + `Agree (b:A):(A)agree`, + `Agree (a:A):(A)agree`), + ra_local_update_apply); + updated = mp_rule( + updated, + assume_rule(` + ra_local_update + agree_ra + (Agree (a:A)) + (Agree (a:A)) + (Agree (b:A)) + (Agree (b:A)) + `)); + updated = mp_rule( + updated, + ispec_rule(`a:A`, agree_ra_valid_owned)); + updated = mp_rule( + updated, + gsym_rule(ispec_rule(`a:A`, agree_ra_idempotent))); + thm target_valid = conjunct1_rule(updated); + thm target_decomposition = conjunct2_rule(updated); + thm target_op_valid = eq_mp_rule( + ap_term_rule( + `ra_valid agree_ra:(A)agree->bool`, + target_decomposition), + target_valid); + thm payload_eq = mp_rule( + ispecl_rule( + TERM_LIST(`b:A`, `a:A`), + agree_ra_agreement), + rewrite_rule( + THM_LIST(gsym_rule(ra_compatible_def)), + target_op_valid)); + ACCEPT_TAC(forward, sym_rule(payload_eq)); + + gnode reverse = DISCH_TAC( + directions[1], "Heq"); + thm owned_eq = ap_term_rule( + `Agree:A->(A)agree`, + assume_rule(`(a:A) == (b:A)`)); + thm whole_transport = beta_rule(ap_term_rule( + `\target:(A)agree. + ra_local_update agree_ra + (Agree (a:A)) (Agree (a:A)) target (Agree (b:A))`, + owned_eq)); + thm local_transport = beta_rule(ap_term_rule( + `\target:(A)agree. + ra_local_update agree_ra + (Agree (a:A)) (Agree (a:A)) (Agree (a:A)) target`, + owned_eq)); + thm reflexive = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (a:A):(A)agree`, + `Agree (a:A):(A)agree`), + ra_local_update_refl); + ACCEPT_TAC( + reverse, + eq_mp_rule( + whole_transport, + eq_mp_rule(local_transport, reflexive))); + return gnode_prove(root); +} + +PROOF thm agree_ra_local_update_iff = + prove_agree_ra_local_update_iff(); + +/* ------------------------------------------------------------------------- */ +/* Order */ +/* ------------------------------------------------------------------------- */ + +/* + * An inclusion Agree a <= Agree b permits the generic update that discards + * the extension, Agree b ~~> Agree a. The exact owned-update theorem then + * forces b = a. The reverse direction is inclusion reflexivity. + */ +PROOF static thm prove_agree_ra_included_owned(void) { + term goal_tm = ` + forall a b:A. + ra_included + agree_ra + (Agree a) + (Agree b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + thm discard_extension = mp_rule( + ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (b:A):(A)agree`, + `Agree (a:A):(A)agree`), + ra_update_included), + assume_rule(` + ra_included + agree_ra + (Agree (a:A)) + (Agree (b:A)) + `)); + thm payload_eq = eq_mp_rule( + ispecl_rule( + TERM_LIST(`b:A`, `a:A`), + agree_ra_update_iff), + discard_extension); + ACCEPT_TAC(forward, sym_rule(payload_eq)); + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + thm owned_eq = ap_term_rule( + `Agree:A->(A)agree`, + assume_rule(`(a:A) == (b:A)`)); + thm target_transport = beta_rule(ap_term_rule( + `\x:(A)agree. + ra_included agree_ra (Agree (a:A)) x`, + owned_eq)); + thm reflexive = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `Agree (a:A):(A)agree`), + ra_included_refl); + ACCEPT_TAC( + reverse, + eq_mp_rule(target_transport, reflexive)); + return gnode_prove(root); +} + +PROOF thm agree_ra_included_owned = + prove_agree_ra_included_owned(); + +PROOF static thm prove_agree_ra_included_unit(void) { + term goal_tm = ` + forall x:(A)agree. + ra_included agree_ra AgreeUnit x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "x"); + thm included = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + `x:(A)agree`), + ra_included_unit); + included = rewrite_rule( + THM_LIST(agree_ra_unit), + included); + ACCEPT_TAC(body, included); + return gnode_prove(root); +} + +PROOF thm agree_ra_included_unit = + prove_agree_ra_included_unit(); + +PROOF static thm prove_agree_unit_ne_owned_result(void) { + term goal_tm = ` + forall a b:A. + ~((AgreeUnit:(A)agree) == + (if a == b + then Agree a + else AgreeInvalid)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "b"); + gnode_list cases = BOOL_CASES_TAC( + body, `(a:A) == (b:A)`, "Heq"); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST(get_datatype_distinctness("agree"))); + } + return gnode_prove(root); +} + +PROOF static thm agree_unit_ne_owned_result = + prove_agree_unit_ne_owned_result(); + +PROOF static thm prove_agree_ra_unit_ne_owned_op(void) { + term goal_tm = ` + forall (a:A) (frame:(A)agree). + ~((AgreeUnit:(A)agree) == + ra_op agree_ra (Agree a) frame) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "frame"); + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)agree`, "Hframe"); + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + CONV_WITH_ASMP_TAC( + frame_cases[i], + rewrite_conv, + THM_LIST( + agree_ra_op_fn, + agree_op_def, + agree_owned_op_def, + agree_unit_ne_owned_result, + get_datatype_distinctness("agree"))); + } + return gnode_prove(root); +} + +PROOF static thm agree_ra_unit_ne_owned_op = + prove_agree_ra_unit_ne_owned_op(); + +PROOF static thm prove_agree_ra_not_included_owned_unit(void) { + term goal_tm = ` + forall a:A. + ~(ra_included agree_ra (Agree a) AgreeUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = DISCH_TAC(body, "Hincluded"); + thm included = rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + agree_ra + (Agree (a:A)) + (AgreeUnit:(A)agree) + `)); + body = ASSUME_TAC(body, included, "Hextension"); + body = ASMP_EXISTS_TAC(body, "Hextension", "frame"); + thm contradiction = not_elim_rule( + ispecl_rule( + TERM_LIST(`a:A`, `frame:(A)agree`), + agree_ra_unit_ne_owned_op), + assume_rule(` + (AgreeUnit:(A)agree) == + ra_op + agree_ra + (Agree (a:A)) + (frame:(A)agree) + `)); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm agree_ra_not_included_owned_unit = + prove_agree_ra_not_included_owned_unit(); + +PROOF static thm prove_agree_ra_included_owned_invalid(void) { + term goal_tm = ` + forall a:A. + ra_included agree_ra (Agree a) AgreeInvalid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = EXISTS_TAC(body, `AgreeInvalid:(A)agree`); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + agree_ra_op_fn, + agree_op_def, + agree_owned_op_def))); + return gnode_prove(root); +} + +PROOF thm agree_ra_included_owned_invalid = + prove_agree_ra_included_owned_invalid(); + +PROOF static thm prove_agree_ra_not_included_invalid_unit(void) { + term goal_tm = ` + ~(ra_included agree_ra AgreeInvalid AgreeUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + ra_included_def, + agree_ra_op_fn, + agree_op_def, + get_datatype_distinctness("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_not_included_invalid_unit = + prove_agree_ra_not_included_invalid_unit(); + +PROOF static thm prove_agree_ra_not_included_invalid_owned(void) { + term goal_tm = ` + forall a:A. + ~(ra_included agree_ra AgreeInvalid (Agree a)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + ra_included_def, + agree_ra_op_fn, + agree_op_def, + get_datatype_distinctness("agree")))); + return gnode_prove(root); +} + +PROOF thm agree_ra_not_included_invalid_owned = + prove_agree_ra_not_included_invalid_owned(); + +PROOF static thm prove_agree_ra_not_maximal_owned(void) { + term goal_tm = ` + forall a:A. ~(ra_maximal agree_ra (Agree a)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = DISCH_TAC(body, "Hmaximal"); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal agree_ra (Agree (a:A))`)); + thm combined_valid = eq_mp_rule( + gsym_rule(ap_term_rule( + `ra_valid agree_ra:(A)agree->bool`, + ispec_rule(`a:A`, agree_ra_idempotent))), + ispec_rule(`a:A`, agree_ra_valid_owned)); + thm frame_is_unit = mp_rule( + spec_rule( + `Agree (a:A):(A)agree`, + conjunct2_rule(maximal)), + combined_valid); + frame_is_unit = rewrite_rule( + THM_LIST(agree_ra_unit), + frame_is_unit); + thm contradiction = not_elim_rule( + ispec_rule(`a:A`, agree_ra_owned_ne_unit), + frame_is_unit); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm agree_ra_not_maximal_owned = + prove_agree_ra_not_maximal_owned(); + +PROOF static thm prove_agree_ra_not_cancellative(void) { + term goal_tm = `~(ra_cancellative (agree_ra:((A)agree)ra))`; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = DISCH_TAC(root, "Hcancellative"); + term owned = `Agree (a:A):(A)agree`; + thm source_op = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + owned), + ra_unit_r); + source_op = rewrite_rule( + THM_LIST(agree_ra_unit), + source_op); + thm source_valid = eq_mp_rule( + gsym_rule(ap_term_rule( + `ra_valid agree_ra:(A)agree->bool`, + source_op)), + ispec_rule(`a:A`, agree_ra_valid_owned)); + thm right_op = ispec_rule(`a:A`, agree_ra_idempotent); + thm forced_equal = ispecl_rule( + TERM_LIST( + `agree_ra:((A)agree)ra`, + owned, + `AgreeUnit:(A)agree`, + owned), + ra_cancellative_apply); + forced_equal = mp_rule( + forced_equal, + assume_rule(`ra_cancellative (agree_ra:((A)agree)ra)`)); + forced_equal = mp_rule(forced_equal, source_valid); + forced_equal = mp_rule( + forced_equal, + trans_rule(source_op, gsym_rule(right_op))); + thm contradiction = not_elim_rule( + ispec_rule(`a:A`, agree_ra_owned_ne_unit), + gsym_rule(forced_equal)); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm agree_ra_not_cancellative = + prove_agree_ra_not_cancellative(); + +PROOF static int audit_agree_ra(void) { + thm_list audited_theorems = THM_LIST( + agree_type.ind, + agree_type.rec, + agree_owned_op_def, + agree_op_def, + agree_valid_def, + agree_ra_laws, + agree_ra_def, + agree_ra_unit, + agree_ra_op_fn, + agree_ra_valid_fn, + agree_ra_owned_op, + agree_ra_idempotent, + agree_ra_owned_inj, + agree_ra_owned_ne_unit, + agree_ra_invalid_ne_unit, + agree_ra_invalid_ne_owned, + agree_ra_valid_unit, + agree_ra_valid_owned, + agree_ra_invalid, + agree_ra_valid_combine_iff, + agree_ra_included_owned, + agree_ra_included_unit, + agree_unit_ne_owned_result, + agree_ra_unit_ne_owned_op, + agree_ra_not_included_owned_unit, + agree_ra_included_owned_invalid, + agree_ra_not_included_invalid_unit, + agree_ra_not_included_invalid_owned, + agree_ra_not_maximal_owned, + agree_ra_not_cancellative, + agree_ra_agreement, + agree_ra_update_iff, + agree_ra_local_update_iff); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "agreement RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "agreement RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == AGREE_RA_AXIOMS_BEFORE, + "agreement RA introduced an axiom"); + ENSURE_COND(get_tyconst_arity("agree") == 1, + "agree is not a unary HOL type constructor"); + return 0; +err: + ERR_FUN_PUTS("audit_agree_ra"); + return -1; +} + +PROOF static int _AGREE_RA_AUDIT = + audit_agree_ra(); diff --git a/theory/logic/agree_ra.h b/theory/logic/agree_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..6d5299b489846d8c62abe8979bfd5d0f09372abc --- /dev/null +++ b/theory/logic/agree_ra.h @@ -0,0 +1,135 @@ +#pragma once + +/* + * Public semantic interface for the discrete agreement resource algebra. + * + * Equal `Agree` tokens compose idempotently; unequal payloads compose to the + * invalid value `AgreeInvalid`. Thus compatible owned tokens determine the + * same payload even though the surrounding separation logic remains linear. + */ + +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Operation and validity */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_unit agree_ra == AgreeUnit + * ``` + * + * agree RA 的 unit 是不持有 payload 的 `AgreeUnit`。 + */ +PROOF extern thm agree_ra_unit; + +/* + * ```text + * forall a b. + * ra_op agree_ra (Agree a) (Agree b) == + * (if a == b then Agree a else AgreeInvalid) + * ``` + * + * 两个 agreement token 的 payload 相等时组合为同一 token，不相等时则组合为 `AgreeInvalid`。 + */ +PROOF extern thm agree_ra_owned_op; + +/* + * ```text + * forall a. ra_op agree_ra (Agree a) (Agree a) == Agree a + * ``` + * + * 同一 agreement token `Agree a` 与自身组合仍等于 `Agree a`。 + */ +PROOF extern thm agree_ra_idempotent; + +/* + * ```text + * ra_valid agree_ra AgreeUnit + * ``` + * + * agree RA 的 unit `AgreeUnit` 是有效资源。 + */ +PROOF extern thm agree_ra_valid_unit; + +/* + * ```text + * forall a. ra_valid agree_ra (Agree a) + * ``` + * + * 每个 agreement token `Agree a` 都是有效资源。 + */ +PROOF extern thm agree_ra_valid_owned; + +/* + * ```text + * ~ra_valid agree_ra AgreeInvalid + * ``` + * + * 冲突值 `AgreeInvalid` 在 agree RA 中无效。 + */ +PROOF extern thm agree_ra_invalid; + +/* ------------------------------------------------------------------------- */ +/* Agreement, inclusion, and cancellation */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a b. ra_valid agree_ra (ra_op agree_ra (Agree a) (Agree b)) <=> a == b + * ``` + * + * `Agree a` 与 `Agree b` 的组合有效，当且仅当 payload `a` 与 `b` 相等。 + */ +PROOF extern thm agree_ra_valid_combine_iff; + +/* + * ```text + * forall a b. ra_compatible agree_ra (Agree a) (Agree b) ==> a == b + * ``` + * + * 若两个 agreement token 兼容，则它们的 payload 必须相等。 + */ +PROOF extern thm agree_ra_agreement; + +/* + * ```text + * forall a b. ra_included agree_ra (Agree a) (Agree b) <=> a == b + * ``` + * + * agreement token `Agree a` 包含于 `Agree b`，当且仅当 payload `a` 与 `b` 相等。 + */ +PROOF extern thm agree_ra_included_owned; + +/* + * ```text + * ~ra_cancellative agree_ra + * ``` + * + * agree RA 不可消去，因为 agreement token 的幂等组合会隐去是否额外组合了同值 token。 + */ +PROOF extern thm agree_ra_not_cancellative; + +/* ------------------------------------------------------------------------- */ +/* Agreement-preserving updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a b. ra_update agree_ra (Agree a) (Agree b) <=> a == b + * ``` + * + * agreement token `Agree a` 可更新为 `Agree b`，当且仅当 payload 不变，即 `a = b`。 + */ +PROOF extern thm agree_ra_update_iff; + +/* + * ```text + * forall a b. + * ra_local_update agree_ra (Agree a) (Agree a) (Agree b) (Agree b) <=> + * a == b + * ``` + * + * whole/local 均为 `Agree a` 的对可局部更新为 `(Agree b,Agree b)`，当且仅当 `a = b`。 + */ +PROOF extern thm agree_ra_local_update_iff; diff --git a/theory/logic/auth_ra.c b/theory/logic/auth_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..282559e4513874491a060053539a21dd631d6e56 --- /dev/null +++ b/theory/logic/auth_ra.c @@ -0,0 +1,2509 @@ +#include "proof/theory/logic/auth_ra.h" +#include "proof/theory/logic/excl_ra_internal.h" +#include "proof/theory/logic/prod_ra_internal.h" +#include "proof/theory/logic/ra_builder.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/excl_ra.c" +#require "proof/theory/logic/local_update.c" +#require "proof/theory/logic/prod_ra.c" + +PROOF static size_t AUTH_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm auth_op_def = new_fun_definition(` + auth_op + (R:(A)ra) + (x:(A)excl#A) + (y:(A)excl#A) : (A)excl#A = + ra_op + (prod_ra (excl_ra:((A)excl)ra) R) + x + y +`); + +PROOF static thm auth_valid_at_def = new_rec_definition( + excl_type.rec, + ` + (auth_valid_at + (R:(A)ra) + (ExclUnit:(A)excl) + (fragment:A) <=> + ra_valid R fragment) && + (auth_valid_at + (R:(A)ra) + (Excl authoritative) + (fragment:A) <=> + ra_valid R authoritative && + ra_included R fragment authoritative) && + (auth_valid_at + (R:(A)ra) + (ExclInvalid:(A)excl) + (fragment:A) <=> + F) + `); + +PROOF static thm auth_valid_def = new_fun_definition(` + auth_valid + (R:(A)ra) + (x:(A)excl#A) <=> + auth_valid_at R (FST x) (SND x) +`); + +/* Hidden constructor equations. The constants are public logical syntax; + * clients use the abstract computation rules from auth_ra.h rather than + * unfolding these representation equations. */ +PROOF static thm auth_auth_def = new_fun_definition(` + auth_auth + (R:(A)ra) + (authoritative:A) : (A)excl#A = + (Excl authoritative,ra_unit R) +`); + +PROOF static thm auth_frag_def = new_fun_definition(` + auth_frag (fragment:A) : (A)excl#A = + (ExclUnit,fragment) +`); + +PROOF static thm auth_both_def = new_fun_definition(` + auth_both + (authoritative:A) + (fragment:A) : (A)excl#A = + (Excl authoritative,fragment) +`); + +PROOF static conv auth_reduce_conv(thm_list local_theorems) { + thm_list rules = vector_concat(THM_LIST( + auth_op_def, + auth_valid_def, + auth_valid_at_def, + prod_ra_op, + excl_ra_op_fn, + excl_op_def, + excl_owned_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + local_theorems); + return rewrite_conv(rules); +} + +PROOF static thm prove_auth_ra_laws(void) { + term goal_tm = ` + forall R:(A)ra. + ra_laws + ((ExclUnit:(A)excl),ra_unit R) + (auth_op R) + (auth_valid R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode unfolded = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + term product = ` + prod_ra (excl_ra:((A)excl)ra) (R:(A)ra) + `; + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + assoc = CONV_TAC( + assoc, + pure_rewrite_conv(THM_LIST(auth_op_def))); + ACCEPT_TAC( + assoc, + ispecl_rule( + TERM_LIST( + product, + `a:(A)excl#A`, + `b:(A)excl#A`, + `c:(A)excl#A`), + ra_assoc)); + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + comm = CONV_TAC( + comm, + pure_rewrite_conv(THM_LIST(auth_op_def))); + ACCEPT_TAC( + comm, + ispecl_rule( + TERM_LIST( + product, + `a:(A)excl#A`, + `b:(A)excl#A`), + ra_comm)); + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = AUTO_INTROS_TAC(law3[0]); + unit = CONV_TAC( + unit, + pure_rewrite_conv(THM_LIST(auth_op_def))); + thm product_unit = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `R:(A)ra`), + prod_ra_unit); + product_unit = pure_once_rewrite_rule( + THM_LIST(excl_ra_unit), + product_unit); + unit = CONV_TAC( + unit, + once_rewrite_conv(THM_LIST(gsym_rule(product_unit)))); + ACCEPT_TAC( + unit, + ispecl_rule( + TERM_LIST(product, `a:(A)excl#A`), + ra_unit_l)); + + gnode_list law4 = CONJ_TAC(law3[1]); + CONV_TAC( + law4[0], + rewrite_conv(THM_LIST( + auth_valid_def, + auth_valid_at_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_valid_unit))); + + gnode valid_down = GEN_TAC(law4[1], "x"); + valid_down = GEN_TAC(valid_down, "y"); + gnode_list x_tags = CASES_TAC( + valid_down, + `FST (x:(A)excl#A)`, + NULL); + for (size_t i = 0; i < vector_size(x_tags); ++i) { + gnode_list y_tags = CASES_TAC( + x_tags[i], + `FST (y:(A)excl#A)`, + NULL); + for (size_t j = 0; j < vector_size(y_tags); ++j) { + if (i == 0 && j == 0) { + gnode reduced = CONV_WITH_ASMP_TAC( + y_tags[j], + auth_reduce_conv, + THM_LIST()); + reduced = DISCH_TAC(reduced, "Hvalid_product"); + thm valid_left = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `SND (x:(A)excl#A)`, + `SND (y:(A)excl#A)`), + ra_valid_op_l), + assume_rule(` + ra_valid (R:(A)ra) + (ra_op R + (SND (x:(A)excl#A)) + (SND (y:(A)excl#A))) + `)); + ACCEPT_TAC(reduced, valid_left); + } else if (i == 0 && j == 1) { + gnode reduced = CONV_WITH_ASMP_TAC( + y_tags[j], + auth_reduce_conv, + THM_LIST()); + reduced = DISCH_TAC(reduced, "Hvalid_combined"); + reduced = ASMP_CONJ_TAC( + reduced, + "Hvalid_combined", + "Hvalid_authoritative", + "Hincluded_product"); + + term_list premises = gnode_get_asmps( + reduced, + CONST_STRING_LIST( + "Hincluded_product", + "Hvalid_authoritative")); + thm valid_product = match_mp_rule( + match_mp_rule( + ra_included_valid, + assume_rule(premises[0])), + assume_rule(premises[1])); + thm valid_left = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `SND (x:(A)excl#A)`, + `SND (y:(A)excl#A)`), + ra_valid_op_l), + valid_product); + ACCEPT_TAC(reduced, valid_left); + } else if (i == 1 && j == 0) { + gnode reduced = CONV_WITH_ASMP_TAC( + y_tags[j], + auth_reduce_conv, + THM_LIST()); + reduced = DISCH_TAC(reduced, "Hvalid_combined"); + reduced = ASMP_CONJ_TAC( + reduced, + "Hvalid_combined", + "Hvalid_authoritative", + "Hincluded_product"); + gnode_list result = CONJ_TAC(reduced); + ACCEPT_TAC( + result[0], + assume_rule(gnode_get_asmps( + result[0], + CONST_STRING_LIST( + "Hvalid_authoritative"))[0])); + + thm left_in_product = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `SND (x:(A)excl#A)`, + `SND (y:(A)excl#A)`), + ra_included_op_l); + thm left_in_authoritative = match_mp_rule( + match_mp_rule( + ra_included_trans, + left_in_product), + assume_rule(gnode_get_asmps( + result[1], + CONST_STRING_LIST( + "Hincluded_product"))[0])); + ACCEPT_TAC(result[1], left_in_authoritative); + } else { + CONV_WITH_ASMP_TAC( + y_tags[j], + auth_reduce_conv, + THM_LIST()); + } + } + } + return gnode_prove(root); +} + +PROOF static thm auth_ra_laws = + prove_auth_ra_laws(); + +PROOF static thm auth_ra_def = new_fun_definition(` + auth_ra (R:(A)ra) : ((A)excl#A)ra = + ra_abs + (((ExclUnit:(A)excl),ra_unit R), + (auth_op R: + ((A)excl#A)->((A)excl#A)->((A)excl#A), + auth_valid R:((A)excl#A)->bool)) +`); + +PROOF static thm prove_auth_ra_unit(void) { + term R = `R:(A)ra`; + term unit = `((ExclUnit:(A)excl),ra_unit (R:(A)ra))`; + term op = ` + auth_op (R:(A)ra): + ((A)excl#A)->((A)excl#A)->((A)excl#A) + `; + term valid = ` + auth_valid (R:(A)ra):((A)excl#A)->bool + `; + thm laws = ispec_rule(R, auth_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(unit, op, valid), + ra_unit_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(auth_ra_def)), + computed); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(auth_frag_def)), + computed); + return gen_rule(R, computed); +} + +PROOF thm auth_ra_unit = + prove_auth_ra_unit(); + +PROOF static thm prove_auth_ra_op(void) { + term R = `R:(A)ra`; + term unit = `((ExclUnit:(A)excl),ra_unit (R:(A)ra))`; + term op = ` + auth_op (R:(A)ra): + ((A)excl#A)->((A)excl#A)->((A)excl#A) + `; + term valid = ` + auth_valid (R:(A)ra):((A)excl#A)->bool + `; + thm laws = ispec_rule(R, auth_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(unit, op, valid), + ra_op_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(auth_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm auth_ra_op_fn = + prove_auth_ra_op(); + +PROOF static thm prove_auth_ra_valid(void) { + term R = `R:(A)ra`; + term unit = `((ExclUnit:(A)excl),ra_unit (R:(A)ra))`; + term op = ` + auth_op (R:(A)ra): + ((A)excl#A)->((A)excl#A)->((A)excl#A) + `; + term valid = ` + auth_valid (R:(A)ra):((A)excl#A)->bool + `; + thm laws = ispec_rule(R, auth_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(unit, op, valid), + ra_valid_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(auth_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm auth_ra_valid_fn = + prove_auth_ra_valid(); + +PROOF static thm prove_auth_ra_op_components(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)excl#A) + (y:(A)excl#A). + ra_op (auth_ra R) x y == + (excl_op (FST x) (FST y), + ra_op R (SND x) (SND y)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_op_fn, + auth_op_def, + prod_ra_op, + excl_ra_op_fn))); + return gnode_prove(root); +} + +PROOF static thm auth_ra_op_components = + prove_auth_ra_op_components(); + +PROOF static thm prove_auth_ra_valid_components(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)excl#A). + ra_valid (auth_ra R) x <=> + auth_valid_at R (FST x) (SND x) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_valid_fn, + auth_valid_def))); + return gnode_prove(root); +} + +PROOF static thm auth_ra_valid_components = + prove_auth_ra_valid_components(); + +/* The authoritative operation is the product operation used by its raw + * construction. Keep this bridge private: clients reason with the more + * useful constructor equations below. */ +PROOF static thm prove_auth_ra_op_as_product(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)excl#A) + (y:(A)excl#A). + ra_op (auth_ra R) x y == + ra_op + (prod_ra (excl_ra:((A)excl)ra) R) + x + y + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_op_components, + prod_ra_op, + excl_ra_op_fn))); + return gnode_prove(root); +} + +PROOF static thm auth_ra_op_as_product = + prove_auth_ra_op_as_product(); + +/* Inclusion depends only on the carrier operation, so authoritative + * inclusion is exactly inclusion in the product used by the construction. */ +PROOF static thm prove_auth_ra_included_as_product(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)excl#A) + (y:(A)excl#A). + ra_included (auth_ra R) x y <=> + ra_included + (prod_ra (excl_ra:((A)excl)ra) R) + x + y + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + ra_included_def, + auth_ra_op_as_product))); + return gnode_prove(root); +} + +PROOF static thm auth_ra_included_as_product = + prove_auth_ra_included_as_product(); + +/* Private representation bridge used to derive the constructor-level public + * inclusion API below. */ +PROOF static thm prove_auth_ra_included_components(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)excl#A) + (y:(A)excl#A). + ra_included (auth_ra R) x y <=> + ra_included + (excl_ra:((A)excl)ra) + (FST x) + (FST y) && + ra_included R (SND x) (SND y) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_included_as_product, + prod_ra_included))); + return gnode_prove(root); +} + +PROOF static thm auth_ra_included_components = + prove_auth_ra_included_components(); + +/* Authoritative validity is stronger than validity in the carrier product. + * In the owned case, fragment validity follows by downward closure from its + * inclusion in the valid authoritative value. */ +PROOF static thm prove_auth_ra_valid_imp_product_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (x:(A)excl#A). + ra_valid (auth_ra R) x ==> + ra_valid + (prod_ra (excl_ra:((A)excl)ra) R) + x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "x"); + body = DISCH_TAC(body, "Hauth_valid"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(prod_ra_valid))); + gnode_list tag_cases = CASES_TAC( + body, `FST (x:(A)excl#A)`, "Htag"); + + for (size_t i = 0; i < vector_size(tag_cases); ++i) { + gnode branch = tag_cases[i]; + term tag_eq_tm = gnode_get_asmps( + branch, + CONST_STRING_LIST("Htag"))[0]; + thm tag_eq = assume_rule(tag_eq_tm); + thm auth_details = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `x:(A)excl#A`), + auth_ra_valid_components), + assume_rule(` + ra_valid (auth_ra (R:(A)ra)) (x:(A)excl#A) + `)); + auth_details = rewrite_rule( + THM_LIST(tag_eq, auth_valid_at_def), + auth_details); + + if (i == 0) { + gnode_list result = CONJ_TAC(branch); + thm excl_valid = pure_once_rewrite_rule( + THM_LIST(gsym_rule(tag_eq)), + excl_ra_valid_unit); + ACCEPT_TAC(result[0], excl_valid); + ACCEPT_TAC(result[1], auth_details); + } else if (i == 1) { + term owned = dest_comb(dest_eq(tag_eq_tm).tm2).tm2; + gnode_list result = CONJ_TAC(branch); + thm excl_valid = ispec_rule( + owned, + excl_ra_valid_owned); + excl_valid = pure_once_rewrite_rule( + THM_LIST(gsym_rule(tag_eq)), + excl_valid); + ACCEPT_TAC(result[0], excl_valid); + + thm fragment_valid = match_mp_rule( + match_mp_rule( + ra_included_valid, + conjunct2_rule(auth_details)), + conjunct1_rule(auth_details)); + ACCEPT_TAC(result[1], fragment_valid); + } else { + CONTR_TAC(branch, auth_details); + } + } + return gnode_prove(root); +} + +PROOF static thm auth_ra_valid_imp_product_valid = + prove_auth_ra_valid_imp_product_valid(); + +PROOF static thm prove_auth_ra_auth_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (fragment:A). + ra_op + (auth_ra R) + (auth_auth R a) + (auth_frag fragment) == + auth_both a fragment + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm unit_left = ispecl_rule( + TERM_LIST(`R:(A)ra`, `fragment:A`), + ra_unit_l); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_op_components, + auth_auth_def, + auth_frag_def, + auth_both_def, + excl_op_def, + excl_owned_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + unit_left))); + return gnode_prove(root); +} + +PROOF thm auth_ra_auth_frag = + prove_auth_ra_auth_frag(); + +PROOF static thm prove_auth_ra_frag_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (f:A) (g:A). + ra_op + (auth_ra R) + (auth_frag f) + (auth_frag g) == + auth_frag (ra_op R f g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_op_components, + auth_frag_def, + excl_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_frag_frag = + prove_auth_ra_frag_frag(); + +PROOF static thm prove_auth_ra_both_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (g:A). + ra_op + (auth_ra R) + (auth_both a f) + (auth_frag g) == + auth_both a (ra_op R f g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_op_components, + auth_both_def, + auth_frag_def, + excl_op_def, + excl_owned_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_both_frag = + prove_auth_ra_both_frag(); + +/* The combined constructor at the base unit is exactly authority-only. + * Derive this through the public composition and unit equations so the raw + * constructor representation remains private. */ +PROOF static thm prove_auth_ra_both_unit(void) { + term R = `R:(A)ra`; + term a = `a:A`; + thm composed = ispecl_rule( + TERM_LIST(R, a, `ra_unit (R:(A)ra)`), + auth_ra_auth_frag); + thm unit_equation = ispec_rule(R, auth_ra_unit); + thm replace_fragment = gsym_rule(beta_rule(ap_term_rule( + `\x:(A)excl#A. + ra_op + (auth_ra (R:(A)ra)) + (auth_auth R (a:A)) + x`, + unit_equation))); + thm remove_unit = ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_auth R (a:A)`), + ra_unit_r); + thm result = trans_rule( + gsym_rule(composed), + trans_rule(replace_fragment, remove_unit)); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm auth_ra_both_unit = + prove_auth_ra_both_unit(); + +/* The excl implementation keeps its raw constructor-injectivity theorem + * private. Recover the same fact through the public owned-inclusion + * characterization so auth constructor proofs do not enlarge that API. */ +PROOF static thm prove_auth_excl_owned_inj(void) { + term goal_tm = ` + forall a b:A. + ((Excl a:(A)excl) == Excl b) <=> a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Heq"); + thm included_refl = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`), + ra_included_refl); + thm replace_target = beta_rule(ap_term_rule( + `\x:(A)excl. + ra_included + (excl_ra:((A)excl)ra) + (Excl (a:A)) + x`, + assume_rule(`(Excl (a:A):(A)excl) == Excl (b:A)`))); + thm included = eq_mp_rule(replace_target, included_refl); + thm payloads_equal = eq_mp_rule( + ispecl_rule( + TERM_LIST(`a:A`, `b:A`), + excl_ra_included_owned), + included); + ACCEPT_TAC(forward, payloads_equal); + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + ACCEPT_TAC( + reverse, + ap_term_rule( + `Excl:A->(A)excl`, + assume_rule(`(a:A) == (b:A)`))); + return gnode_prove(root); +} + +PROOF static thm auth_excl_owned_inj = + prove_auth_excl_owned_inj(); + +PROOF static thm prove_auth_ra_frag_inj(void) { + term goal_tm = ` + forall (f:A) (g:A). + (auth_frag f:(A)excl#A) == auth_frag g <=> f == g + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_frag_def, + get_theorem_by_name("PAIR_EQ")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_frag_inj = + prove_auth_ra_frag_inj(); + +PROOF static thm prove_auth_ra_both_inj(void) { + term goal_tm = ` + forall (a:A) (f:A) (b:A) (g:A). + (auth_both a f:(A)excl#A) == auth_both b g <=> + a == b && f == g + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_both_def, + get_theorem_by_name("PAIR_EQ"), + auth_excl_owned_inj))); + return gnode_prove(root); +} + +PROOF thm auth_ra_both_inj = + prove_auth_ra_both_inj(); + +PROOF static thm prove_auth_ra_both_ne_frag(void) { + term goal_tm = ` + forall (a:A) (f:A) (g:A). + ~((auth_both a f:(A)excl#A) == auth_frag g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_both_def, + auth_frag_def, + get_theorem_by_name("PAIR_EQ"), + excl_owned_ne_unit))); + return gnode_prove(root); +} + +PROOF thm auth_ra_both_ne_frag = + prove_auth_ra_both_ne_frag(); + +PROOF static thm prove_auth_ra_auth_inj(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + auth_auth R a == auth_auth R b <=> a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_auth_def, + get_theorem_by_name("PAIR_EQ"), + auth_excl_owned_inj))); + return gnode_prove(root); +} + +PROOF thm auth_ra_auth_inj = + prove_auth_ra_auth_inj(); + +PROOF static thm prove_auth_ra_auth_ne_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ~(auth_auth R a == auth_frag f) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_auth_def, + auth_frag_def, + get_theorem_by_name("PAIR_EQ"), + excl_owned_ne_unit))); + return gnode_prove(root); +} + +PROOF thm auth_ra_auth_ne_frag = + prove_auth_ra_auth_ne_frag(); + +PROOF static thm prove_auth_ra_auth_eq_both(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (f:A). + auth_auth R a == auth_both b f <=> + a == b && f == ra_unit R + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm unit_symmetry = ispecl_rule( + TERM_LIST(`ra_unit (R:(A)ra)`, `f:A`), + get_theorem_by_name("EQ_SYM_EQ")); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_auth_def, + auth_both_def, + get_theorem_by_name("PAIR_EQ"), + auth_excl_owned_inj, + unit_symmetry))); + return gnode_prove(root); +} + +PROOF thm auth_ra_auth_eq_both = + prove_auth_ra_auth_eq_both(); + +PROOF static thm prove_auth_ra_valid_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (fragment:A). + ra_valid (auth_ra R) (auth_frag fragment) <=> + ra_valid R fragment + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_valid_components, + auth_frag_def, + auth_valid_at_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_frag = + prove_auth_ra_valid_frag(); + +PROOF static thm prove_auth_ra_valid_both(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (fragment:A). + ra_valid (auth_ra R) (auth_both a fragment) <=> + ra_valid R a && + ra_included R fragment a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_valid_components, + auth_both_def, + auth_valid_at_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both = + prove_auth_ra_valid_both(); + +PROOF static thm prove_auth_ra_valid_both_intro(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ra_valid R a ==> + ra_included R f a ==> + ra_valid (auth_ra R) (auth_both a f) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm details = conj_rule( + assume_rule(`ra_valid (R:(A)ra) (a:A)`), + assume_rule(`ra_included (R:(A)ra) (f:A) (a:A)`)); + thm characterization = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `f:A`), + auth_ra_valid_both); + ACCEPT_TAC(body, eq_mp_rule(gsym_rule(characterization), details)); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both_intro = + prove_auth_ra_valid_both_intro(); + +PROOF static thm prove_auth_ra_valid_both_elim_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ra_valid (auth_ra R) (auth_both a f) ==> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm details = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `f:A`), + auth_ra_valid_both), + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (auth_both (a:A) (f:A)) + `)); + ACCEPT_TAC(body, conjunct1_rule(details)); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both_elim_valid = + prove_auth_ra_valid_both_elim_valid(); + +PROOF static thm prove_auth_ra_valid_both_elim_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ra_valid (auth_ra R) (auth_both a f) ==> + ra_included R f a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm details = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `f:A`), + auth_ra_valid_both), + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (auth_both (a:A) (f:A)) + `)); + ACCEPT_TAC(body, conjunct2_rule(details)); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both_elim_included = + prove_auth_ra_valid_both_elim_included(); + +PROOF static thm prove_auth_ra_valid_auth(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_valid (auth_ra R) (auth_auth R a) <=> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm unit_included = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_included_unit); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_valid_components, + auth_auth_def, + auth_valid_at_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + unit_included))); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_auth = + prove_auth_ra_valid_auth(); + +PROOF static thm prove_auth_ra_valid_auth_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ra_valid + (auth_ra R) + (ra_op + (auth_ra R) + (auth_auth R a) + (auth_frag f)) <=> + ra_valid R a && ra_included R f a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_auth_frag, + auth_ra_valid_both))); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_auth_frag = + prove_auth_ra_valid_auth_frag(); + +PROOF static thm prove_auth_ra_valid_both_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (g:A). + ra_valid + (auth_ra R) + (ra_op + (auth_ra R) + (auth_both a f) + (auth_frag g)) <=> + ra_valid R a && + ra_included R (ra_op R f g) a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + auth_ra_both_frag, + auth_ra_valid_both))); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both_frag = + prove_auth_ra_valid_both_frag(); + +PROOF static thm prove_auth_ra_auth_conflict(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ~(ra_compatible + (auth_ra R) + (auth_auth R a) + (auth_auth R b)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + ra_compatible_def, + auth_ra_op_components, + auth_ra_valid_components, + auth_auth_def, + auth_valid_at_def, + excl_op_def, + excl_owned_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm auth_ra_auth_conflict = + prove_auth_ra_auth_conflict(); + +/* A valid frame for an authoritative owner cannot itself contain authority. + * The remaining SND component is exactly the external fragment observed by + * the general update rules below. */ +PROOF static thm prove_auth_ra_valid_both_frame_components(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (frame:(A)excl#A). + ra_valid + (auth_ra R) + (ra_op + (auth_ra R) + (auth_both a f) + frame) <=> + FST frame == (ExclUnit:(A)excl) && + ra_valid R a && + ra_included R (ra_op R f (SND frame)) a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list cases = CASES_TAC( + body, + `FST (frame:(A)excl#A)`, + NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + auth_reduce_conv, + THM_LIST( + auth_ra_op_components, + auth_ra_valid_components, + auth_both_def, + excl_owned_ne_unit, + excl_invalid_ne_unit)); + } + return gnode_prove(root); +} + +PROOF static thm auth_ra_valid_both_frame_components = + prove_auth_ra_valid_both_frame_components(); + +/* Constructor-level form of the frame characterization. This is the public + * abstraction boundary: a compatible frame is exactly a fragment-only auth + * resource, without exposing carrier projections to clients. */ +PROOF static thm prove_auth_ra_valid_both_frame(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (frame:(A)excl#A). + ra_valid + (auth_ra R) + (ra_op + (auth_ra R) + (auth_both a f) + frame) <=> + exists external:A. + frame == auth_frag external && + ra_valid R a && + ra_included R (ra_op R f external) a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hvalid"); + thm frame_components = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `frame:(A)excl#A`), + auth_ra_valid_both_frame_components), + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (ra_op + (auth_ra R) + (auth_both (a:A) (f:A)) + (frame:(A)excl#A)) + `)); + forward = EXISTS_TAC(forward, `SND (frame:(A)excl#A)`); + gnode_list forward_parts = CONJ_TAC(forward); + + thm frame_eta = gsym_rule(ispec_rule( + `frame:(A)excl#A`, + get_theorem_by_name("PAIR"))); + thm replace_tag = beta_rule(ap_term_rule( + `\tag:(A)excl. (tag,SND (frame:(A)excl#A))`, + conjunct1_rule(frame_components))); + thm fragment_definition = inst_rule( + TERM_PAIR_LIST( + (term_pair){ + `SND (frame:(A)excl#A)`, + `fragment:A`}), + auth_frag_def); + thm frame_is_fragment = trans_rule( + frame_eta, + trans_rule(replace_tag, gsym_rule(fragment_definition))); + ACCEPT_TAC(forward_parts[0], frame_is_fragment); + ACCEPT_TAC(forward_parts[1], conjunct2_rule(frame_components)); + + gnode reverse = DISCH_TAC(directions[1], "Hdetails"); + reverse = ASMP_EXISTS_TAC(reverse, "Hdetails", "external"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hdetails", + "Hframe", + "Hsource"); + + thm frame_eq = assume_rule(` + (frame:(A)excl#A) == auth_frag (external:A) + `); + thm frame_fst = ap_term_rule( + `FST:((A)excl#A)->(A)excl`, + frame_eq); + frame_fst = rewrite_rule( + THM_LIST( + auth_frag_def, + get_theorem_by_name("FST")), + frame_fst); + thm frame_snd = ap_term_rule( + `SND:((A)excl#A)->A`, + frame_eq); + frame_snd = rewrite_rule( + THM_LIST( + auth_frag_def, + get_theorem_by_name("SND")), + frame_snd); + thm source_components = pure_once_rewrite_rule( + THM_LIST(gsym_rule(frame_snd)), + assume_rule(` + ra_valid (R:(A)ra) (a:A) && + ra_included R (ra_op R (f:A) (external:A)) a + `)); + thm raw_components = conj_rule(frame_fst, source_components); + thm raw_characterization = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `frame:(A)excl#A`), + auth_ra_valid_both_frame_components); + ACCEPT_TAC( + reverse, + eq_mp_rule(gsym_rule(raw_characterization), raw_components)); + return gnode_prove(root); +} + +PROOF thm auth_ra_valid_both_frame = + prove_auth_ra_valid_both_frame(); + +/* Authority-only is the unit-fragment specialization of the public combined + * frame theorem. */ +PROOF static thm prove_auth_ra_valid_auth_frame(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term frame = `frame:(A)excl#A`; + thm result = ispecl_rule( + TERM_LIST(R, a, `ra_unit (R:(A)ra)`, frame), + auth_ra_valid_both_frame); + result = rewrite_rule( + THM_LIST( + auth_ra_both_unit, + ra_unit_l), + result); + result = gen_rule(frame, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm auth_ra_valid_auth_frame = + prove_auth_ra_valid_auth_frame(); + +/* Any two combined resources carry two exclusive authoritative owners. The + * exact valid-frame characterization exposes that impossible first component + * without unfolding the public constructors in the resulting theorem. */ +PROOF static thm prove_auth_ra_both_conflict(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + ~(ra_valid + (auth_ra R) + (ra_op + (auth_ra R) + (auth_both a f) + (auth_both b g))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "f"); + body = GEN_TAC(body, "b"); + body = GEN_TAC(body, "g"); + body = DISCH_TAC(body, "Hvalid"); + + thm frame_details = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `auth_both (b:A) (g:A)`), + auth_ra_valid_both_frame_components), + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (ra_op + (auth_ra R) + (auth_both (a:A) (f:A)) + (auth_both (b:A) (g:A))) + `)); + thm frame_is_unit = pure_once_rewrite_rule( + THM_LIST(auth_both_def), + conjunct1_rule(frame_details)); + frame_is_unit = pure_once_rewrite_rule( + THM_LIST(get_theorem_by_name("FST")), + frame_is_unit); + thm contradiction = not_elim_rule( + ispec_rule(`b:A`, excl_owned_ne_unit), + frame_is_unit); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm auth_ra_both_conflict = + prove_auth_ra_both_conflict(); + +PROOF static thm prove_auth_ra_auth_both_conflict(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term b = `b:A`; + term g = `g:A`; + thm result = ispecl_rule( + TERM_LIST(R, a, `ra_unit (R:(A)ra)`, b, g), + auth_ra_both_conflict); + result = pure_once_rewrite_rule( + THM_LIST(auth_ra_both_unit), + result); + result = gen_rule(g, result); + result = gen_rule(b, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm auth_ra_auth_both_conflict = + prove_auth_ra_auth_both_conflict(); + +/* ExclUnit is the exclusive RA unit and is therefore included in every + * exclusive carrier element. */ +PROOF static thm prove_auth_excl_unit_included(void) { + thm result = ispec_rule( + `excl_ra:((A)excl)ra`, + ra_included_unit); + return pure_rewrite_rule( + THM_LIST(excl_ra_unit), + result); +} + +PROOF static thm auth_excl_unit_included = + prove_auth_excl_unit_included(); + +/* An owned Excl element cannot extend to ExclUnit. Deriving this from its + * frame-maximality avoids unfolding the raw exclusive operation. */ +PROOF static thm prove_auth_excl_owned_not_included_unit(void) { + term goal_tm = ` + forall a:A. + ~(ra_included + (excl_ra:((A)excl)ra) + (Excl a) + (ExclUnit:(A)excl)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = DISCH_TAC(body, "Hincluded"); + thm forced_equal = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `ExclUnit:(A)excl`), + ra_maximal_included); + forced_equal = mp_rule( + forced_equal, + ispec_rule(`a:A`, excl_ra_maximal)); + forced_equal = mp_rule( + forced_equal, + excl_ra_valid_unit); + forced_equal = mp_rule( + forced_equal, + assume_rule(` + ra_included + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (ExclUnit:(A)excl) + `)); + thm contradiction = not_elim_rule( + ispec_rule(`a:A`, excl_owned_ne_unit), + forced_equal); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF static thm auth_excl_owned_not_included_unit = + prove_auth_excl_owned_not_included_unit(); + +/* Shared reduction for the complete constructor-inclusion table. */ +PROOF static conv auth_included_reduce_conv(void) { + return rewrite_conv(THM_LIST( + auth_ra_included_components, + auth_auth_def, + auth_frag_def, + auth_both_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + auth_excl_unit_included, + auth_excl_owned_not_included_unit, + excl_ra_included_owned, + ra_included_unit)); +} + +PROOF static thm prove_auth_ra_included_frag_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (f:A) (g:A). + ra_included + (auth_ra R) + (auth_frag f) + (auth_frag g) <=> + ra_included R f g + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_frag_frag = + prove_auth_ra_included_frag_frag(); + +PROOF static thm prove_auth_ra_included_frag_auth(void) { + term goal_tm = ` + forall (R:(A)ra) (f:A) (a:A). + ra_included + (auth_ra R) + (auth_frag f) + (auth_auth R a) <=> + ra_included R f (ra_unit R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_frag_auth = + prove_auth_ra_included_frag_auth(); + +PROOF static thm prove_auth_ra_included_frag_both(void) { + term goal_tm = ` + forall (R:(A)ra) (f:A) (a:A) (g:A). + ra_included + (auth_ra R) + (auth_frag f) + (auth_both a g) <=> + ra_included R f g + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_frag_both = + prove_auth_ra_included_frag_both(); + +PROOF static thm prove_auth_ra_included_auth_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (g:A). + ~(ra_included + (auth_ra R) + (auth_auth R a) + (auth_frag g)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_auth_frag = + prove_auth_ra_included_auth_frag(); + +PROOF static thm prove_auth_ra_included_auth_auth(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included + (auth_ra R) + (auth_auth R a) + (auth_auth R b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_auth_auth = + prove_auth_ra_included_auth_auth(); + +PROOF static thm prove_auth_ra_included_auth_both(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (g:A). + ra_included + (auth_ra R) + (auth_auth R a) + (auth_both b g) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_auth_both = + prove_auth_ra_included_auth_both(); + +PROOF static thm prove_auth_ra_included_both_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (g:A). + ~(ra_included + (auth_ra R) + (auth_both a f) + (auth_frag g)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_both_frag = + prove_auth_ra_included_both_frag(); + +PROOF static thm prove_auth_ra_included_both_auth(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A). + ra_included + (auth_ra R) + (auth_both a f) + (auth_auth R b) <=> + a == b && ra_included R f (ra_unit R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_both_auth = + prove_auth_ra_included_both_auth(); + +PROOF static thm prove_auth_ra_included_both_both(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + ra_included + (auth_ra R) + (auth_both a f) + (auth_both b g) <=> + a == b && ra_included R f g + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, auth_included_reduce_conv()); + return gnode_prove(root); +} + +PROOF thm auth_ra_included_both_both = + prove_auth_ra_included_both_both(); + +/* Cancellativity follows from the carrier product. Auth validity supplies + * the stronger source premise needed by that product, while the operation + * bridge normalizes both sides without exposing the raw descriptor. */ +PROOF static thm prove_auth_ra_cancellative(void) { + term goal_tm = ` + forall R:(A)ra. + ra_cancellative R ==> + ra_cancellative (auth_ra R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = DISCH_TAC(body, "Hbase_cancellative"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = GEN_TAC(body, "frame"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hsource_valid"); + body = DISCH_TAC(body, "Hops_equal"); + + thm product_cancellative = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `R:(A)ra`), + prod_ra_cancellative); + product_cancellative = mp_rule( + product_cancellative, + excl_ra_cancellative); + product_cancellative = mp_rule( + product_cancellative, + assume_rule(`ra_cancellative (R:(A)ra)`)); + product_cancellative = pure_once_rewrite_rule( + THM_LIST(ra_cancellative_def), + product_cancellative); + + thm left_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `frame:(A)excl#A`, + `a:(A)excl#A`), + auth_ra_op_as_product); + thm right_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `frame:(A)excl#A`, + `b:(A)excl#A`), + auth_ra_op_as_product); + + thm source_product_at_auth_op = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op + (auth_ra (R:(A)ra)) + (frame:(A)excl#A) + (a:(A)excl#A)`), + auth_ra_valid_imp_product_valid), + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (ra_op + (auth_ra R) + (frame:(A)excl#A) + (a:(A)excl#A)) + `)); + thm source_validity_eq = ap_term_rule( + `ra_valid + (prod_ra + (excl_ra:((A)excl)ra) + (R:(A)ra)): + ((A)excl#A)->bool`, + left_op); + thm source_product_valid = eq_mp_rule( + source_validity_eq, + source_product_at_auth_op); + + thm product_ops_equal = trans_rule( + gsym_rule(left_op), + trans_rule( + assume_rule(` + ra_op + (auth_ra (R:(A)ra)) + (frame:(A)excl#A) + (a:(A)excl#A) == + ra_op + (auth_ra R) + frame + (b:(A)excl#A) + `), + right_op)); + thm result = ispecl_rule( + TERM_LIST( + `frame:(A)excl#A`, + `a:(A)excl#A`, + `b:(A)excl#A`), + product_cancellative); + result = mp_rule(result, source_product_valid); + result = mp_rule(result, product_ops_equal); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm auth_ra_cancellative = + prove_auth_ra_cancellative(); + +PROOF static thm prove_auth_ra_cancellative_iff(void) { + term goal_tm = ` + forall R:(A)ra. + ra_cancellative (auth_ra R) <=> ra_cancellative R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], + "Hauth_cancellative"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + forward = GEN_TAC(forward, "frame"); + forward = GEN_TAC(forward, "a"); + forward = GEN_TAC(forward, "b"); + forward = DISCH_TAC(forward, "Hsource_valid"); + forward = DISCH_TAC(forward, "Hops_equal"); + + term source = `ra_op (R:(A)ra) (frame:A) (a:A)`; + thm lifted_source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, source), + auth_ra_valid_frag)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (frame:A) (a:A)) + `)); + thm left_op = ispecl_rule( + TERM_LIST(`R:(A)ra`, `frame:A`, `a:A`), + auth_ra_frag_frag); + thm lifted_source_eq = ap_term_rule( + `ra_valid (auth_ra (R:(A)ra))`, + left_op); + lifted_source_valid = eq_mp_rule( + gsym_rule(lifted_source_eq), + lifted_source_valid); + + thm lifted_base_eq = ap_term_rule( + `auth_frag:A->(A)excl#A`, + assume_rule(` + ra_op (R:(A)ra) (frame:A) (a:A) == + ra_op R frame (b:A) + `)); + thm right_op = ispecl_rule( + TERM_LIST(`R:(A)ra`, `frame:A`, `b:A`), + auth_ra_frag_frag); + thm lifted_ops_equal = trans_rule( + left_op, + trans_rule(lifted_base_eq, gsym_rule(right_op))); + + thm fragment_equality = ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_frag (frame:A)`, + `auth_frag (a:A)`, + `auth_frag (b:A)`), + ra_cancellative_apply); + fragment_equality = mp_rule( + fragment_equality, + assume_rule(`ra_cancellative (auth_ra (R:(A)ra))`)); + fragment_equality = mp_rule(fragment_equality, lifted_source_valid); + fragment_equality = mp_rule(fragment_equality, lifted_ops_equal); + thm payload_equality = eq_mp_rule( + ispecl_rule( + TERM_LIST(`a:A`, `b:A`), + auth_ra_frag_inj), + fragment_equality); + ACCEPT_TAC(forward, payload_equality); + + gnode reverse = DISCH_TAC( + directions[1], + "Hbase_cancellative"); + ACCEPT_TAC( + reverse, + mp_rule( + ispec_rule(`R:(A)ra`, auth_ra_cancellative), + assume_rule(`ra_cancellative (R:(A)ra)`))); + return gnode_prove(root); +} + +PROOF thm auth_ra_cancellative_iff = + prove_auth_ra_cancellative_iff(); + +/* ------------------------------------------------------------------------- */ +/* General frame-preserving updates */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_auth_ra_update_framewise(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (b:A) + (g:A). + (forall external:A. + ra_valid R a && + ra_included R (ra_op R f external) a ==> + ra_valid R b && + ra_included R (ra_op R g external) b) ==> + ra_update + (auth_ra R) + (auth_both a f) + (auth_both b g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_update_def, ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `auth_both (b:A) (g:A)`); + gnode_list update_result = CONJ_TAC(body); + ACCEPT_TAC( + update_result[0], + refl_rule(`auth_both (b:A) (g:A)`)); + body = update_result[1]; + + thm source_characterization = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `frame:(A)excl#A`), + auth_ra_valid_both_frame_components); + thm source_details = eq_mp_rule( + source_characterization, + assume_rule(` + ra_valid + (auth_ra (R:(A)ra)) + (ra_op + (auth_ra R) + (auth_both (a:A) (f:A)) + (frame:(A)excl#A)) + `)); + thm frame_is_fragment = conjunct1_rule(source_details); + thm source_condition = conjunct2_rule(source_details); + + thm target_condition = mp_rule( + spec_rule( + `SND (frame:(A)excl#A)`, + assume_rule(` + forall external:A. + ra_valid (R:(A)ra) (a:A) && + ra_included R (ra_op R (f:A) external) a ==> + ra_valid R (b:A) && + ra_included R (ra_op R (g:A) external) b + `)), + source_condition); + thm target_details = conj_rule( + frame_is_fragment, + target_condition); + thm target_characterization = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `g:A`, + `frame:(A)excl#A`), + auth_ra_valid_both_frame_components); + ACCEPT_TAC( + body, + eq_mp_rule(gsym_rule(target_characterization), target_details)); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_framewise = + prove_auth_ra_update_framewise(); + +PROOF static thm prove_auth_ra_update_framewise_iff(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (b:A) + (g:A). + ra_update + (auth_ra R) + (auth_both a f) + (auth_both b g) <=> + forall external:A. + ra_valid R a && + ra_included R (ra_op R f external) a ==> + ra_valid R b && + ra_included R (ra_op R g external) b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + forward = GEN_TAC(forward, "external"); + forward = DISCH_TAC(forward, "Hsource"); + thm source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `external:A`), + auth_ra_valid_both_frag)), + assume_rule(` + ra_valid (R:(A)ra) (a:A) && + ra_included + R + (ra_op R (f:A) (external:A)) + a + `)); + thm target_valid = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_both (a:A) (f:A)`, + `auth_both (b:A) (g:A)`, + `auth_frag (external:A)`), + ra_update_apply), + assume_rule(` + ra_update + (auth_ra (R:(A)ra)) + (auth_both (a:A) (f:A)) + (auth_both (b:A) (g:A)) + `)), + source_valid); + thm target_details = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `g:A`, + `external:A`), + auth_ra_valid_both_frag), + target_valid); + ACCEPT_TAC(forward, target_details); + + gnode reverse = DISCH_TAC(directions[1], "Hframewise"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`), + auth_ra_update_framewise), + assume_rule(` + forall external:A. + ra_valid (R:(A)ra) (a:A) && + ra_included R (ra_op R (f:A) external) a ==> + ra_valid R (b:A) && + ra_included R (ra_op R (g:A) external) b + `))); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_framewise_iff = + prove_auth_ra_update_framewise_iff(); + +/* Iris-style auth update. A local update preserves the exact residual + * witness behind any source inclusion; the framewise auth criterion then + * turns that base fact into a frame-preserving update of authoritative + * resources. */ +PROOF static thm prove_auth_ra_update_local(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (b:A) + (g:A). + ra_local_update R a f b g ==> + ra_update + (auth_ra R) + (auth_both a f) + (auth_both b g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = MATCH_MP_TAC( + body, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`), + auth_ra_update_framewise)); + body = GEN_TAC(body, "external"); + body = DISCH_TAC(body, "Hsource"); + body = ASMP_CONJ_TAC( + body, + "Hsource", + "Hauthoritative_valid", + "Hincluded"); + thm preserved = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`, + `external:A`), + ra_local_update_preserves_included); + preserved = mp_rule( + preserved, + assume_rule(`ra_local_update (R:(A)ra) (a:A) (f:A) (b:A) (g:A)`)); + preserved = mp_rule( + preserved, + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + preserved = mp_rule( + preserved, + assume_rule(` + ra_included + (R:(A)ra) + (ra_op R (f:A) (external:A)) + (a:A) + `)); + ACCEPT_TAC(body, preserved); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_local = + prove_auth_ra_update_local(); + +/* ------------------------------------------------------------------------- */ +/* Exact authority and weakening updates */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_auth_ra_update_auth_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_update + (auth_ra R) + (auth_auth R a) + (auth_auth R b) <=> + (ra_valid R a ==> + ra_valid R b && ra_included R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + thm framewise_characterization = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `ra_unit (R:(A)ra)`, + `b:A`, + `ra_unit (R:(A)ra)`), + auth_ra_update_framewise_iff); + framewise_characterization = rewrite_rule( + THM_LIST( + auth_ra_both_unit, + ra_unit_l), + framewise_characterization); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + forward = DISCH_TAC(forward, "Hsource_valid"); + thm framewise = eq_mp_rule( + framewise_characterization, + assume_rule(` + ra_update + (auth_ra (R:(A)ra)) + (auth_auth R (a:A)) + (auth_auth R (b:A)) + `)); + thm source_at_self = conj_rule( + assume_rule(`ra_valid (R:(A)ra) (a:A)`), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_included_refl)); + thm target_at_self = mp_rule( + spec_rule(`a:A`, framewise), + source_at_self); + ACCEPT_TAC(forward, target_at_self); + + gnode reverse = DISCH_TAC(directions[1], "Hcondition"); + thm update_rule = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `ra_unit (R:(A)ra)`, + `b:A`, + `ra_unit (R:(A)ra)`), + auth_ra_update_framewise); + update_rule = rewrite_rule( + THM_LIST( + auth_ra_both_unit, + ra_unit_l), + update_rule); + reverse = MATCH_MP_TAC(reverse, update_rule); + reverse = GEN_TAC(reverse, "external"); + reverse = DISCH_TAC(reverse, "Hsource"); + thm target_base = mp_rule( + assume_rule(` + ra_valid (R:(A)ra) (a:A) ==> + ra_valid R (b:A) && ra_included R a b + `), + conjunct1_rule(assume_rule(` + ra_valid (R:(A)ra) (a:A) && + ra_included R (external:A) a + `))); + thm target_included = match_mp_rule( + match_mp_rule( + ra_included_trans, + conjunct2_rule(assume_rule(` + ra_valid (R:(A)ra) (a:A) && + ra_included R (external:A) a + `))), + conjunct2_rule(target_base)); + ACCEPT_TAC( + reverse, + conj_rule(conjunct1_rule(target_base), target_included)); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_auth_iff = + prove_auth_ra_update_auth_iff(); + +PROOF static thm prove_auth_ra_update_auth_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_valid R b ==> + ra_included R a b ==> + ra_update + (auth_ra R) + (auth_auth R a) + (auth_auth R b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(auth_ra_update_auth_iff))); + body = DISCH_TAC(body, "Hsource_valid"); + ACCEPT_TAC( + body, + conj_rule( + assume_rule(`ra_valid (R:(A)ra) (b:A)`), + assume_rule(`ra_included (R:(A)ra) (a:A) (b:A)`))); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_auth_included = + prove_auth_ra_update_auth_included(); + +PROOF static thm prove_auth_ra_update_drop_local(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term f = `f:A`; + term auth = `auth_ra (R:(A)ra)`; + term authority = `auth_auth (R:(A)ra) (a:A)`; + term fragment = `auth_frag (f:A)`; + term combined = `auth_both (a:A) (f:A)`; + thm included = ispecl_rule( + TERM_LIST(auth, authority, fragment), + ra_included_op_l); + included = rewrite_rule( + THM_LIST(auth_ra_auth_frag), + included); + thm result = mp_rule( + ispecl_rule( + TERM_LIST(auth, combined, authority), + ra_update_included), + included); + result = gen_rule(f, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm auth_ra_update_drop_local = + prove_auth_ra_update_drop_local(); + +PROOF static thm prove_auth_ra_update_drop_auth(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term f = `f:A`; + term auth = `auth_ra (R:(A)ra)`; + term authority = `auth_auth (R:(A)ra) (a:A)`; + term fragment = `auth_frag (f:A)`; + term combined = `auth_both (a:A) (f:A)`; + thm included = ispecl_rule( + TERM_LIST(auth, authority, fragment), + ra_included_op_r); + included = rewrite_rule( + THM_LIST(auth_ra_auth_frag), + included); + thm result = mp_rule( + ispecl_rule( + TERM_LIST(auth, combined, fragment), + ra_update_included), + included); + result = gen_rule(f, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm auth_ra_update_drop_auth = + prove_auth_ra_update_drop_auth(); + +PROOF static thm prove_auth_ra_update_weaken_frag(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (g:A). + ra_included R g f ==> + ra_update + (auth_ra R) + (auth_both a f) + (auth_both a g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm details = conj_rule( + refl_rule(`a:A`), + assume_rule(`ra_included (R:(A)ra) (g:A) (f:A)`)); + thm included = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `g:A`, + `a:A`, + `f:A`), + auth_ra_included_both_both)), + details); + thm updated = mp_rule( + ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_both (a:A) (f:A)`, + `auth_both (a:A) (g:A)`), + ra_update_included), + included); + ACCEPT_TAC(body, updated); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_weaken_frag = + prove_auth_ra_update_weaken_frag(); + +PROOF static thm prove_auth_ra_frag_update_included(void) { + term goal_tm = ` + forall (R:(A)ra) (f:A) (g:A). + ra_included R g f ==> + ra_update + (auth_ra R) + (auth_frag f) + (auth_frag g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm included = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `g:A`, `f:A`), + auth_ra_included_frag_frag)), + assume_rule(`ra_included (R:(A)ra) (g:A) (f:A)`)); + thm updated = mp_rule( + ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_frag (f:A)`, + `auth_frag (g:A)`), + ra_update_included), + included); + ACCEPT_TAC(body, updated); + return gnode_prove(root); +} + +PROOF thm auth_ra_frag_update_included = + prove_auth_ra_frag_update_included(); + +PROOF static thm prove_auth_ra_update_both_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (f:A). + ra_valid R b ==> + ra_included R a b ==> + ra_update + (auth_ra R) + (auth_both a f) + (auth_both b f) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm authority_update = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`), + auth_ra_update_auth_included), + assume_rule(`ra_valid (R:(A)ra) (b:A)`)), + assume_rule(`ra_included (R:(A)ra) (a:A) (b:A)`)); + thm framed = mp_rule( + ispecl_rule( + TERM_LIST( + `auth_ra (R:(A)ra)`, + `auth_auth (R:(A)ra) (a:A)`, + `auth_auth (R:(A)ra) (b:A)`, + `auth_frag (f:A)`), + ra_update_frame), + authority_update); + framed = rewrite_rule( + THM_LIST(auth_ra_auth_frag), + framed); + ACCEPT_TAC(body, framed); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_both_included = + prove_auth_ra_update_both_included(); + +/* Iris `auth_update_alloc`: authority-only is the unit-fragment instance of + * the general local-update lifting rule. */ +PROOF static thm prove_auth_ra_update_alloc(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (g:A). + ra_local_update R a (ra_unit R) b g ==> + ra_update + (auth_ra R) + (auth_auth R a) + (auth_both b g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm updated = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `ra_unit (R:(A)ra)`, + `b:A`, + `g:A`), + auth_ra_update_local), + assume_rule(` + ra_local_update + (R:(A)ra) + (a:A) + (ra_unit R) + (b:A) + (g:A) + `)); + updated = rewrite_rule( + THM_LIST(auth_ra_both_unit), + updated); + ACCEPT_TAC(body, updated); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_alloc = + prove_auth_ra_update_alloc(); + +/* ------------------------------------------------------------------------- */ +/* Allocation and cancellative specializations */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_auth_ra_alloc_both(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (f:A) + (piece:A). + ra_valid R (ra_op R a piece) ==> + ra_update + (auth_ra R) + (auth_both a f) + (auth_both + (ra_op R a piece) + (ra_op R f piece)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm local = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `piece:A`), + ra_local_update_alloc), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (piece:A)) + `)); + thm updated = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `ra_op (R:(A)ra) (a:A) (piece:A)`, + `ra_op (R:(A)ra) (f:A) (piece:A)`), + auth_ra_update_local), + local); + ACCEPT_TAC(body, updated); + return gnode_prove(root); +} + +PROOF thm auth_ra_alloc_both = + prove_auth_ra_alloc_both(); + +PROOF static thm prove_auth_ra_alloc(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (piece:A). + ra_valid R (ra_op R a piece) ==> + ra_update + (auth_ra R) + (auth_auth R a) + (auth_both (ra_op R a piece) piece) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm allocated = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `ra_unit (R:(A)ra)`, + `piece:A`), + auth_ra_alloc_both), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (piece:A)) + `)); + thm_list reductions = THM_LIST( + auth_ra_both_unit, + ra_unit_l); + ACCEPT_TAC(body, rewrite_rule(reductions, allocated)); + return gnode_prove(root); +} + +PROOF thm auth_ra_alloc = + prove_auth_ra_alloc(); + +PROOF static thm prove_auth_ra_update_cancellative(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (b:A) + (frame:A). + ra_cancellative R ==> + ra_valid R (ra_op R b frame) ==> + ra_update + (auth_ra R) + (auth_both (ra_op R a frame) a) + (auth_both (ra_op R b frame) b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm local = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`, + `frame:A`), + ra_local_update_cancellative), + assume_rule(`ra_cancellative (R:(A)ra)`)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (b:A) (frame:A)) + `)); + thm updated = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (frame:A)`, + `a:A`, + `ra_op (R:(A)ra) (b:A) (frame:A)`, + `b:A`), + auth_ra_update_local), + local); + ACCEPT_TAC(body, updated); + return gnode_prove(root); +} + +PROOF thm auth_ra_update_cancellative = + prove_auth_ra_update_cancellative(); + +PROOF static int audit_auth_ra(void) { + thm_list implementation_theorems = THM_LIST( + auth_op_def, + auth_valid_at_def, + auth_valid_def, + auth_auth_def, + auth_frag_def, + auth_both_def, + auth_ra_laws, + auth_ra_def, + auth_ra_op_fn, + auth_ra_valid_fn, + auth_ra_op_components, + auth_ra_valid_components, + auth_ra_op_as_product, + auth_ra_included_as_product, + auth_ra_included_components, + auth_ra_valid_imp_product_valid, + auth_ra_unit, + auth_ra_auth_frag, + auth_ra_frag_frag, + auth_ra_both_frag, + auth_ra_both_unit, + auth_excl_owned_inj, + auth_ra_frag_inj, + auth_ra_both_inj, + auth_ra_both_ne_frag, + auth_ra_auth_inj, + auth_ra_auth_ne_frag, + auth_ra_auth_eq_both, + auth_ra_valid_frag, + auth_ra_valid_both, + auth_ra_valid_both_intro, + auth_ra_valid_both_elim_valid, + auth_ra_valid_both_elim_included, + auth_ra_valid_auth, + auth_ra_valid_auth_frag, + auth_ra_valid_both_frag, + auth_ra_auth_conflict, + auth_ra_valid_both_frame_components, + auth_ra_valid_both_frame, + auth_ra_valid_auth_frame, + auth_ra_both_conflict, + auth_ra_auth_both_conflict, + auth_excl_unit_included, + auth_excl_owned_not_included_unit, + auth_ra_included_frag_frag, + auth_ra_included_frag_auth, + auth_ra_included_frag_both, + auth_ra_included_auth_frag, + auth_ra_included_auth_auth, + auth_ra_included_auth_both, + auth_ra_included_both_frag, + auth_ra_included_both_auth, + auth_ra_included_both_both, + auth_ra_cancellative, + auth_ra_cancellative_iff, + auth_ra_update_framewise, + auth_ra_update_framewise_iff, + auth_ra_update_local, + auth_ra_update_auth_iff, + auth_ra_update_auth_included, + auth_ra_update_drop_local, + auth_ra_update_drop_auth, + auth_ra_update_weaken_frag, + auth_ra_frag_update_included, + auth_ra_update_both_included, + auth_ra_update_alloc, + auth_ra_alloc_both, + auth_ra_alloc, + auth_ra_update_cancellative); + + for (size_t i = 0; i < vector_size(implementation_theorems); ++i) { + ENSURE_COND(!IS_NULL(implementation_theorems[i]), + "authoritative RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(implementation_theorems[i])) == 0, + "authoritative RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == AUTH_RA_AXIOMS_BEFORE, + "authoritative RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_auth_ra"); + return -1; +} + +PROOF static int _AUTH_RA_AUDIT = + audit_auth_ra(); diff --git a/theory/logic/auth_ra.h b/theory/logic/auth_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..3714ffa679d0e4b8c371064a02cb413143cb0d03 --- /dev/null +++ b/theory/logic/auth_ra.h @@ -0,0 +1,332 @@ +#pragma once + +/* + * Public semantic interface for the authoritative RA over a base RA `R`. + * + * `auth_auth R a` owns authority only, `auth_frag f` owns a fragment only, + * and `auth_both a f` owns both. Authority is exclusive. A combined value is + * valid exactly when `a` is valid and the complete visible fragment is + * included in `a`. Raw constructor equations and datatype elimination stay + * in implementation-only headers. + */ + +#include "proof/theory/logic/excl_ra.h" +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Unit and composition */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R:(A)ra. + * ra_unit (auth_ra R) == auth_frag (ra_unit R) + * ``` + * + * authoritative RA 的 unit 是不含 authority、且 fragment 为底层 unit 的资源。 + */ +PROOF extern thm auth_ra_unit; + +/* + * ```text + * forall (R:(A)ra) (a:A) (fragment:A). + * ra_op + * (auth_ra R) + * (auth_auth R a) + * (auth_frag fragment) == + * auth_both a fragment + * ``` + * + * 单独的 authority `a` 与 fragment `fragment` 组合后得到同时持有二者的 `auth_both a fragment`。 + */ +PROOF extern thm auth_ra_auth_frag; + +/* + * ```text + * forall (R:(A)ra) (f:A) (g:A). + * ra_op (auth_ra R) (auth_frag f) (auth_frag g) == + * auth_frag (ra_op R f g) + * ``` + * + * 两个 fragment 组合后仍是 fragment，其 payload 是底层组合 `ra_op R f g`。 + */ +PROOF extern thm auth_ra_frag_frag; + +/* + * ```text + * forall (R:(A)ra) (a:A) (f:A) (g:A). + * ra_op (auth_ra R) (auth_both a f) (auth_frag g) == + * auth_both a (ra_op R f g) + * ``` + * + * `auth_both a f` 与 fragment `g` 组合时保留 authority `a`，并将 fragment 合并为 `ra_op R f g`。 + */ +PROOF extern thm auth_ra_both_frag; + +/* ------------------------------------------------------------------------- */ +/* Validity and compatibility */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall (R:(A)ra) (fragment:A). + * ra_valid (auth_ra R) (auth_frag fragment) <=> + * ra_valid R fragment + * ``` + * + * 纯 fragment 在 authoritative RA 中有效，当且仅当其 payload 在底层 `R` 中有效。 + */ +PROOF extern thm auth_ra_valid_frag; + +/* + * ```text + * forall (R:(A)ra) (a:A) (fragment:A). + * ra_valid (auth_ra R) (auth_both a fragment) <=> + * ra_valid R a && ra_included R fragment a + * ``` + * + * `auth_both a fragment` 有效，当且仅当 authority `a` 有效，且可见 fragment `fragment` 在底层 `R` 中包含于 `a`。 + */ +PROOF extern thm auth_ra_valid_both; + +/* + * ```text + * forall (R:(A)ra) (a:A). + * ra_valid (auth_ra R) (auth_auth R a) <=> + * ra_valid R a + * ``` + * + * 纯 authority `auth_auth R a` 有效，当且仅当 `a` 在底层 `R` 中有效。 + */ +PROOF extern thm auth_ra_valid_auth; + +/* + * ```text + * forall + * (R:(A)ra) + * (a:A) + * (f:A) + * (frame:(A)excl#A). + * ra_valid + * (auth_ra R) + * (ra_op (auth_ra R) (auth_both a f) frame) <=> + * exists external:A. + * frame == auth_frag external && + * ra_valid R a && + * ra_included R (ra_op R f external) a + * ``` + * + * `auth_both a f` 与 frame 的组合有效，当且仅当该 frame 是某个纯 fragment `external`，且 `a` 有效并包含 `f ⋅ external`。 + */ +PROOF extern thm auth_ra_valid_both_frame; + +/* + * ```text + * forall (R:(A)ra) (a:A) (b:A). + * ~(ra_compatible + * (auth_ra R) + * (auth_auth R a) + * (auth_auth R b)) + * ``` + * + * 任意两个纯 authority 都不兼容，因为 authoritative owner 具有排他性。 + */ +PROOF extern thm auth_ra_auth_conflict; + +/* ------------------------------------------------------------------------- */ +/* Inclusion */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall (R:(A)ra) (f:A) (g:A). + * ra_included (auth_ra R) (auth_frag f) (auth_frag g) <=> + * ra_included R f g + * ``` + * + * 纯 fragment `f` 在 authoritative RA 中包含于纯 fragment `g`，当且仅当 `f` 在底层 `R` 中包含于 `g`。 + */ +PROOF extern thm auth_ra_included_frag_frag; + +/* + * ```text + * forall (R:(A)ra) (f:A) (a:A) (g:A). + * ra_included (auth_ra R) (auth_frag f) (auth_both a g) <=> + * ra_included R f g + * ``` + * + * 纯 fragment `f` 包含于 `auth_both a g`，当且仅当 `f` 在底层 `R` 中包含于可见 fragment `g`。 + */ +PROOF extern thm auth_ra_included_frag_both; + +/* + * ```text + * forall (R:(A)ra) (a:A) (b:A). + * ra_included (auth_ra R) (auth_auth R a) (auth_auth R b) <=> + * a == b + * ``` + * + * 纯 authority `a` 包含于纯 authority `b`，当且仅当两个 authoritative payload 相等。 + */ +PROOF extern thm auth_ra_included_auth_auth; + +/* + * ```text + * forall (R:(A)ra) (a:A) (b:A) (g:A). + * ra_included (auth_ra R) (auth_auth R a) (auth_both b g) <=> + * a == b + * ``` + * + * 纯 authority `a` 包含于 `auth_both b g`，当且仅当 authoritative payload `a` 与 `b` 相等。 + */ +PROOF extern thm auth_ra_included_auth_both; + +/* + * ```text + * forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + * ra_included (auth_ra R) (auth_both a f) (auth_both b g) <=> + * a == b && ra_included R f g + * ``` + * + * `auth_both a f` 包含于 `auth_both b g`，当且仅当 authority 相等且 `f` 在底层 `R` 中包含于 `g`。 + */ +PROOF extern thm auth_ra_included_both_both; + +/* + * ```text + * forall R:(A)ra. + * ra_cancellative (auth_ra R) <=> ra_cancellative R + * ``` + * + * authoritative RA 可消去，当且仅当底层 RA `R` 可消去。 + */ +PROOF extern thm auth_ra_cancellative_iff; + +/* ------------------------------------------------------------------------- */ +/* Authoritative updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall + * (R:(A)ra) + * (a:A) + * (f:A) + * (b:A) + * (g:A). + * ra_update + * (auth_ra R) + * (auth_both a f) + * (auth_both b g) <=> + * forall external:A. + * ra_valid R a && + * ra_included R (ra_op R f external) a ==> + * ra_valid R b && + * ra_included R (ra_op R g external) b + * ``` + * + * 将 `auth_both a f` 更新为 `auth_both b g` 可行，当且仅当对任意外部 fragment `external`，`a` 有效且包含 `f ⋅ external` 都能推出 `b` 有效且包含 `g ⋅ external`。 + */ +PROOF extern thm auth_ra_update_framewise_iff; + +/* + * ```text + * forall + * (R:(A)ra) + * (a:A) + * (f:A) + * (b:A) + * (g:A). + * ra_local_update R a f b g ==> + * ra_update + * (auth_ra R) + * (auth_both a f) + * (auth_both b g) + * ``` + * + * 底层的局部更新 `(a,f) -> (b,g)` 可提升为 authoritative RA 中从 `auth_both a f` 到 `auth_both b g` 的更新。 + */ +PROOF extern thm auth_ra_update_local; + +/* + * ```text + * forall (R:(A)ra) (a:A) (b:A). + * ra_update + * (auth_ra R) + * (auth_auth R a) + * (auth_auth R b) <=> + * (ra_valid R a ==> + * ra_valid R b && ra_included R a b) + * ``` + * + * 纯 authority `a` 可更新为 `b`，当且仅当 `a` 一旦有效，`b` 就有效且在底层 `R` 中包含 `a`。 + */ +PROOF extern thm auth_ra_update_auth_iff; + +/* + * ```text + * forall (R:(A)ra) (a:A) (b:A) (g:A). + * ra_local_update R a (ra_unit R) b g ==> + * ra_update + * (auth_ra R) + * (auth_auth R a) + * (auth_both b g) + * ``` + * + * 若底层局部更新能把 `(a, unit)` 变为 `(b,g)`，则纯 authority `a` 可更新为同时持有 authority `b` 和 fragment `g`。 + */ +PROOF extern thm auth_ra_update_alloc; + +/* + * ```text + * forall (R:(A)ra) (a:A) (f:A). + * ra_update + * (auth_ra R) + * (auth_both a f) + * (auth_auth R a) + * ``` + * + * `auth_both a f` 可更新为纯 authority `a`，即丢弃本地持有的 fragment `f`。 + */ +PROOF extern thm auth_ra_update_drop_local; + +/* + * ```text + * forall (R:(A)ra) (a:A) (f:A). + * ra_update + * (auth_ra R) + * (auth_both a f) + * (auth_frag f) + * ``` + * + * `auth_both a f` 可更新为纯 fragment `f`，即丢弃排他的 authoritative owner。 + */ +PROOF extern thm auth_ra_update_drop_auth; + +/* + * ```text + * forall (R:(A)ra) (a:A) (f:A) (g:A). + * ra_included R g f ==> + * ra_update + * (auth_ra R) + * (auth_both a f) + * (auth_both a g) + * ``` + * + * 若 `g` 在底层 `R` 中包含于 `f`，则可保留 authority `a` 不变并将可见 fragment 从 `f` 弱化为 `g`。 + */ +PROOF extern thm auth_ra_update_weaken_frag; + +/* + * ```text + * forall (R:(A)ra) (a:A) (piece:A). + * ra_valid R (ra_op R a piece) ==> + * ra_update + * (auth_ra R) + * (auth_auth R a) + * (auth_both (ra_op R a piece) piece) + * ``` + * + * 若 `a ⋅ piece` 在底层 `R` 中有效，则纯 authority `a` 可更新为 authority `a ⋅ piece` 并同时分配 fragment `piece`。 + */ +PROOF extern thm auth_ra_alloc; diff --git a/theory/logic/basic_update.c b/theory/logic/basic_update.c new file mode 100644 index 0000000000000000000000000000000000000000..21176624797f6391286e9eddb3f7b8f911b169a7 --- /dev/null +++ b/theory/logic/basic_update.c @@ -0,0 +1,1123 @@ +#include "proof/theory/logic/basic_update.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/resource_prop.c" + +PROOF static size_t BASIC_UPDATE_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm r_bupd_def = new_fun_definition(` + r_bupd + (R:(A)ra) + (Q:A->bool) + (owned:A) <=> + ra_updateP R owned Q +`); + +PROOF thm r_viewshift_def = new_fun_definition(` + r_viewshift + (R:(A)ra) + (P:A->bool) + (Q:A->bool) <=> + r_entails R P (r_bupd R Q) +`); + +PROOF static thm prove_r_bupd_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool). + r_entails R P (r_bupd R P) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_def, + ra_updateP_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `resource:A`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (resource:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm r_bupd_intro = + prove_r_bupd_intro(); + +PROOF static thm prove_r_bupd_mono(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R P Q ==> + r_entails + R + (r_bupd R P) + (r_bupd R Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_def, + ra_updateP_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hmono"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm selected = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid + (R:(A)ra) + (ra_op R (owned:A) frame) ==> + exists selected:A. + (P:A->bool) selected && + ra_valid R (ra_op R selected frame) + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (owned:A) (frame:A)) + `)); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP", + "Hvalid_selected_frame"); + + thm valid_selected = conjunct1_rule(mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `selected:A`, + `frame:A`), + ra_valid_op), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (selected:A) (frame:A)) + `))); + thm q_selected = mp_rule( + mp_rule( + spec_rule( + `selected:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + valid_selected), + assume_rule(`(P:A->bool) (selected:A)`)); + + body = EXISTS_TAC(body, `selected:A`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], q_selected); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (selected:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm r_bupd_mono = + prove_r_bupd_mono(); + +PROOF static thm prove_r_bupd_idem(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool). + r_entails + R + (r_bupd R (r_bupd R P)) + (r_bupd R P) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_def, + ra_updateP_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hnested"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm middle = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid + (R:(A)ra) + (ra_op R (owned:A) frame) ==> + exists middle:A. + (forall hidden:A. + ra_valid R (ra_op R middle hidden) ==> + exists result:A. + (P:A->bool) result && + ra_valid R (ra_op R result hidden)) && + ra_valid R (ra_op R middle frame) + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (owned:A) (frame:A)) + `)); + body = ASSUME_TAC(body, middle, "Hmiddle"); + body = ASMP_EXISTS_TAC(body, "Hmiddle", "middle"); + body = ASMP_CONJ_TAC( + body, + "Hmiddle", + "Hmiddle_update", + "Hvalid_middle_frame"); + + thm result = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall hidden:A. + ra_valid + (R:(A)ra) + (ra_op R (middle:A) hidden) ==> + exists result:A. + (P:A->bool) result && + ra_valid R (ra_op R result hidden) + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (middle:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_bupd_idem = + prove_r_bupd_idem(); + +PROOF static thm prove_r_bupd_frame(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (frame_pred:A->bool). + r_entails + R + (r_sep R (r_bupd R P) frame_pred) + (r_bupd R (r_sep R P frame_pred)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_sep_def, + r_bupd_def, + ra_updateP_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "frame_pred"); + body = GEN_TAC(body, "owned_total"); + body = DISCH_TAC(body, "Hvalid_owned_total"); + body = DISCH_TAC(body, "Hsep"); + body = ASMP_EXISTS_TAC(body, "Hsep", "updated"); + body = ASMP_EXISTS_TAC(body, "Hsep", "explicit_frame"); + body = ASMP_CONJ_TAC( + body, + "Hsep", + "Hsplit", + "Hpreds"); + body = ASMP_CONJ_TAC( + body, + "Hpreds", + "Hupdate", + "Hframe_pred"); + body = GEN_TAC(body, "hidden"); + body = DISCH_TAC(body, "Hvalid_with_hidden"); + + thm split_with_hidden = beta_rule(ap_term_rule( + `\base:A. + ra_op (R:(A)ra) base (hidden:A)`, + assume_rule(` + (owned_total:A) == + ra_op + (R:(A)ra) + (updated:A) + (explicit_frame:A) + `))); + thm source_validity_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + split_with_hidden); + thm valid_grouped_left = eq_mp_rule( + source_validity_eq, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (owned_total:A) (hidden:A)) + `)); + thm source_assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `updated:A`, + `explicit_frame:A`, + `hidden:A`), + ra_assoc); + thm source_assoc_validity = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + source_assoc); + thm valid_normalized = eq_mp_rule( + source_assoc_validity, + valid_grouped_left); + + thm selected = mp_rule( + spec_rule( + `ra_op + (R:(A)ra) + (explicit_frame:A) + (hidden:A)`, + assume_rule(` + forall frame:A. + ra_valid + (R:(A)ra) + (ra_op R (updated:A) frame) ==> + exists selected:A. + (P:A->bool) selected && + ra_valid R (ra_op R selected frame) + `)), + valid_normalized); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP", + "Hvalid_selected"); + + body = EXISTS_TAC( + body, + `ra_op + (R:(A)ra) + (selected:A) + (explicit_frame:A)`); + gnode_list result = CONJ_TAC(body); + + gnode post = EXISTS_TAC(result[0], `selected:A`); + post = EXISTS_TAC(post, `explicit_frame:A`); + gnode_list post1 = CONJ_TAC(post); + ACCEPT_TAC( + post1[0], + refl_rule(` + ra_op + (R:(A)ra) + (selected:A) + (explicit_frame:A) + `)); + gnode_list post2 = CONJ_TAC(post1[1]); + ACCEPT_TAC( + post2[0], + assume_rule(`(P:A->bool) (selected:A)`)); + ACCEPT_TAC( + post2[1], + assume_rule(` + (frame_pred:A->bool) (explicit_frame:A) + `)); + + thm result_assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `selected:A`, + `explicit_frame:A`, + `hidden:A`), + ra_assoc); + thm result_assoc_validity = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + gsym_rule(result_assoc)); + ACCEPT_TAC( + result[1], + eq_mp_rule( + result_assoc_validity, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op + R + (selected:A) + (ra_op + R + (explicit_frame:A) + (hidden:A))) + `))); + return gnode_prove(root); +} + +PROOF thm r_bupd_frame = + prove_r_bupd_frame(); + +PROOF static thm prove_r_viewshift_refl(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool). + r_viewshift R P P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC( + body, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`), + r_bupd_intro)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_refl = + prove_r_viewshift_refl(); + +PROOF static thm prove_r_entails_to_viewshift(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R P Q ==> + r_viewshift R P Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `Q:A->bool`, + `r_bupd (R:(A)ra) (Q:A->bool)`), + r_entails_trans), + assume_rule(` + r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) + `)), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`), + r_bupd_intro)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_entails_to_viewshift = + prove_r_entails_to_viewshift(); + +PROOF static thm prove_r_viewshift_trans(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_viewshift R P Q ==> + r_viewshift R Q S ==> + r_viewshift R P S + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + + thm lifted_second = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `r_bupd (R:(A)ra) (S:A->bool)`), + r_bupd_mono), + assume_rule(` + r_entails + (R:(A)ra) + (Q:A->bool) + (r_bupd R (S:A->bool)) + `)); + thm collapsed_second = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_bupd (R:(A)ra) (Q:A->bool)`, + `r_bupd R (r_bupd R (S:A->bool))`, + `r_bupd R (S:A->bool)`), + r_entails_trans), + lifted_second), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:A->bool`), + r_bupd_idem)); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `r_bupd R (Q:A->bool)`, + `r_bupd R (S:A->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (R:(A)ra) + (P:A->bool) + (r_bupd R (Q:A->bool)) + `)), + collapsed_second); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_trans = + prove_r_viewshift_trans(); + +PROOF static thm prove_r_viewshift_mono(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P2:A->bool) + (P:A->bool) + (Q:A->bool) + (Q2:A->bool). + r_entails R P2 P ==> + r_viewshift R P Q ==> + r_entails R Q Q2 ==> + r_viewshift R P2 Q2 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + + thm lifted_post = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `Q2:A->bool`), + r_bupd_mono), + assume_rule(` + r_entails (R:(A)ra) (Q:A->bool) (Q2:A->bool) + `)); + thm changed_post = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `r_bupd R (Q:A->bool)`, + `r_bupd R (Q2:A->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (R:(A)ra) + (P:A->bool) + (r_bupd R (Q:A->bool)) + `)), + lifted_post); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P2:A->bool`, + `P:A->bool`, + `r_bupd R (Q2:A->bool)`), + r_entails_trans), + assume_rule(` + r_entails (R:(A)ra) (P2:A->bool) (P:A->bool) + `)), + changed_post); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_mono = + prove_r_viewshift_mono(); + +PROOF static thm prove_r_viewshift_frame(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (frame_pred:A->bool). + r_viewshift R P Q ==> + r_viewshift + R + (r_sep R P frame_pred) + (r_sep R Q frame_pred) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + + thm explicit_frame = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `r_bupd R (Q:A->bool)`, + `frame_pred:A->bool`), + r_sep_frame_l), + assume_rule(` + r_entails + (R:(A)ra) + (P:A->bool) + (r_bupd R (Q:A->bool)) + `)); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep + R + (P:A->bool) + (frame_pred:A->bool)`, + `r_sep + R + (r_bupd R (Q:A->bool)) + (frame_pred:A->bool)`, + `r_bupd + R + (r_sep + R + (Q:A->bool) + (frame_pred:A->bool))`), + r_entails_trans), + explicit_frame), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `frame_pred:A->bool`), + r_bupd_frame)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_frame = + prove_r_viewshift_frame(); + +PROOF static thm prove_r_viewshift_sep(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P1:A->bool) + (Q1:A->bool) + (P2:A->bool) + (Q2:A->bool). + r_viewshift R P1 Q1 ==> + r_viewshift R P2 Q2 ==> + r_viewshift + R + (r_sep R P1 P2) + (r_sep R Q1 Q2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "P1"); + body = GEN_TAC(body, "Q1"); + body = GEN_TAC(body, "P2"); + body = GEN_TAC(body, "Q2"); + body = DISCH_TAC(body, "Hchange1"); + body = DISCH_TAC(body, "Hchange2"); + + thm first_framed = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P1:A->bool`, + `Q1:A->bool`, + `P2:A->bool`), + r_viewshift_frame), + assume_rule(` + r_viewshift (R:(A)ra) (P1:A->bool) (Q1:A->bool) + `)); + thm second_framed = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P2:A->bool`, + `Q2:A->bool`, + `Q1:A->bool`), + r_viewshift_frame), + assume_rule(` + r_viewshift (R:(A)ra) (P2:A->bool) (Q2:A->bool) + `)); + + thm source_commute = rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q1:A->bool`, + `P2:A->bool`), + r_sep_comm)); + + thm target_commute = rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q2:A->bool`, + `Q1:A->bool`), + r_sep_comm)); + thm second_aligned = mp_rule( + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep R (Q1:A->bool) (P2:A->bool)`, + `r_sep R (P2:A->bool) (Q1:A->bool)`, + `r_sep R (Q2:A->bool) (Q1:A->bool)`, + `r_sep R (Q1:A->bool) (Q2:A->bool)`), + r_viewshift_mono), + conjunct1_rule(source_commute)), + second_framed), + conjunct1_rule(target_commute)); + + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep R (P1:A->bool) (P2:A->bool)`, + `r_sep R (Q1:A->bool) (P2:A->bool)`, + `r_sep R (Q1:A->bool) (Q2:A->bool)`), + r_viewshift_trans), + first_framed), + second_aligned); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_sep = + prove_r_viewshift_sep(); + +PROOF static thm prove_r_viewshift_exists_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:A->bool). + (forall witness:B. + r_viewshift R (P witness) Q) ==> + r_viewshift R (r_exists R (\bound:B. P bound)) Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:B->A->bool`, + `r_bupd R (Q:A->bool)`), + r_exists_elim), + assume_rule(` + forall witness:B. + r_entails + (R:(A)ra) + ((P:B->A->bool) witness) + (r_bupd R (Q:A->bool)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_exists_l = + prove_r_viewshift_exists_l(); + +PROOF static thm prove_r_viewshift_exists_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:B->A->bool) + (witness:B). + r_viewshift R P (Q witness) ==> + r_viewshift R P (r_exists R (\bound:B. Q bound)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_def))); + body = AUTO_INTROS_TAC(body); + + thm post_inclusion = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:B->A->bool`, + `witness:B`), + r_exists_intro); + thm lifted_post = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `(Q:B->A->bool) (witness:B)`, + `r_exists R (\bound:B. (Q:B->A->bool) bound)`), + r_bupd_mono), + post_inclusion); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `r_bupd R ((Q:B->A->bool) (witness:B))`, + `r_bupd R + (r_exists R (\bound:B. (Q:B->A->bool) bound))`), + r_entails_trans), + assume_rule(` + r_entails + (R:(A)ra) + (P:A->bool) + (r_bupd + R + ((Q:B->A->bool) (witness:B))) + `)), + lifted_post); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_exists_r = + prove_r_viewshift_exists_r(); + +PROOF static thm prove_r_viewshift_exists(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:B->A->bool). + (forall witness:B. + r_viewshift R (P witness) (Q witness)) ==> + r_viewshift + R + (r_exists R (\bound:B. P bound)) + (r_exists R (\bound:B. Q bound)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hall"); + body = MATCH_MP_TAC( + body, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:B->A->bool`, + `r_exists R (\bound:B. (Q:B->A->bool) bound)`), + r_viewshift_exists_l)); + body = GEN_TAC(body, "witness"); + thm selected = spec_rule( + `witness:B`, + assume_rule(` + forall witness:B. + r_viewshift + (R:(A)ra) + ((P:B->A->bool) witness) + ((Q:B->A->bool) witness) + `)); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `(P:B->A->bool) (witness:B)`, + `Q:B->A->bool`, + `witness:B`), + r_viewshift_exists_r), + selected); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_exists = + prove_r_viewshift_exists(); + +PROOF static thm prove_r_own_update(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (b:A). + ra_update R a b ==> + r_viewshift + R + (r_own R a) + (r_own R b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_def, + r_entails_def, + r_bupd_def, + r_own_def, + ra_updateP_def, + ra_update_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Howned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm replace_owned = beta_rule(ap_term_rule( + `\base:A. + ra_op (R:(A)ra) base (frame:A)`, + assume_rule(`(owned:A) == (a:A)`))); + thm source_validity_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + replace_owned); + thm valid_a_frame = eq_mp_rule( + source_validity_eq, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (owned:A) (frame:A)) + `)); + thm selected = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid + (R:(A)ra) + (ra_op R (a:A) frame) ==> + exists selected:A. + selected == (b:A) && + ra_valid R (ra_op R selected frame) + `)), + valid_a_frame); + ACCEPT_TAC(body, selected); + return gnode_prove(root); +} + +PROOF thm r_own_update = + prove_r_own_update(); + +PROOF static thm prove_r_own_updateP(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (result_pred:A->bool). + ra_updateP R a result_pred ==> + r_viewshift + R + (r_own R a) + (r_exists + R + (\selected:A. + r_sep + R + (r_fact R (result_pred selected)) + (r_own R selected))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_def, + r_entails_def, + r_bupd_def, + r_own_def, + r_exists_def, + r_sep_def, + r_fact_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "result_pred"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Howned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm replace_owned = beta_rule(ap_term_rule( + `\base:A. + ra_op (R:(A)ra) base (frame:A)`, + assume_rule(`(owned:A) == (a:A)`))); + thm source_validity_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + replace_owned); + thm valid_a_frame = eq_mp_rule( + source_validity_eq, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (owned:A) (frame:A)) + `)); + thm selected = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid + (R:(A)ra) + (ra_op R (a:A) frame) ==> + exists selected:A. + (result_pred:A->bool) selected && + ra_valid R (ra_op R selected frame) + `)), + valid_a_frame); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "Hresult", + "Hvalid_selected"); + + body = EXISTS_TAC(body, `selected:A`); + gnode_list result = CONJ_TAC(body); + gnode post = EXISTS_TAC(result[0], `selected:A`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST( + r_sep_def, + r_fact_def, + r_own_def))); + post = EXISTS_TAC(post, `ra_unit (R:(A)ra)`); + post = EXISTS_TAC(post, `selected:A`); + gnode_list post_split = CONJ_TAC(post); + ACCEPT_TAC( + post_split[0], + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `selected:A`), + ra_unit_l))); + gnode_list post_preds = CONJ_TAC(post_split[1]); + gnode_list post_fact = CONJ_TAC(post_preds[0]); + ACCEPT_TAC( + post_fact[0], + assume_rule(` + (result_pred:A->bool) (selected:A) + `)); + ACCEPT_TAC( + post_fact[1], + refl_rule(`ra_unit (R:(A)ra)`)); + ACCEPT_TAC(post_preds[1], refl_rule(`selected:A`)); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (selected:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm r_own_updateP = + prove_r_own_updateP(); + +PROOF static int audit_basic_update(void) { + thm_list public_theorems = THM_LIST( + r_bupd_def, + r_viewshift_def, + r_bupd_intro, + r_bupd_mono, + r_bupd_idem, + r_bupd_frame, + r_viewshift_refl, + r_entails_to_viewshift, + r_viewshift_trans, + r_viewshift_mono, + r_viewshift_frame, + r_viewshift_sep, + r_viewshift_exists_l, + r_viewshift_exists_r, + r_viewshift_exists, + r_own_update, + r_own_updateP); + + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND( + !IS_NULL(public_theorems[i]), + "basic-update theorem %zu is null", + i); + ENSURE_COND( + vector_size(hyp(public_theorems[i])) == 0, + "basic-update theorem %zu has hypotheses", + i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == + BASIC_UPDATE_AXIOMS_BEFORE, + "basic-update theory introduced axioms"); + return 0; +err: + ERR_FUN_PUTS("audit_basic_update"); + return -1; +} + +PROOF static int _BASIC_UPDATE_AUDIT = + audit_basic_update(); diff --git a/theory/logic/basic_update.h b/theory/logic/basic_update.h new file mode 100644 index 0000000000000000000000000000000000000000..f55c4b54c657f34cb96261a34cd6e33916f76203 --- /dev/null +++ b/theory/logic/basic_update.h @@ -0,0 +1,190 @@ +/** + * @file basic_update.h + * @brief Generic frame-preserving updates for one complete RA. + * + * `r_bupd R` is interpreted directly by primitive predicate update + * `ra_updateP R`; consequently it may change any part of the resource owned by + * `R`. It is appropriate for an algebraic or ghost-only logic. A program + * logic whose resource contains physical state must instead use a restricted + * modality such as the right-only product update in `product_resource.h`. + */ + +#pragma once + +#include "proof/theory/logic/resource_prop.h" + +/** + * HOL conclusion: + * + * ```text + * r_bupd (R:(A)ra) (Q:A->bool) (owned:A) <=> ra_updateP R owned Q + * ``` + * + * `r_bupd R Q` 对整份 `R` 资源执行 `ra_updateP`，允许更新当前拥有资源的任意部分。 + */ +PROOF extern thm r_bupd_def; + +/** + * HOL conclusion: + * + * ```text + * r_viewshift (R:(A)ra) (P:A->bool) (Q:A->bool) <=> r_entails R P + * (r_bupd R Q) + * ``` + * + * 从 `P` 到 `Q` 的 view shift 定义为 `P` 蕴含一次可到达 `Q` 的完整 RA 更新。 + */ +PROOF extern thm r_viewshift_def; + +/* Basic-update modality laws. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_entails R P (r_bupd R P) + * ``` + * + * 不改变资源的自反更新把任意 `P` 引入为 `r_bupd P`。 + */ +PROOF extern thm r_bupd_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R P Q ==> r_entails R + * (r_bupd R P) (r_bupd R Q) + * ``` + * + * 若 `P` 蕴含 `Q`，则更新后满足 `P` 也蕴含更新后满足 `Q`。 + */ +PROOF extern thm r_bupd_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_entails R (r_bupd R (r_bupd R P)) (r_bupd R + * P) + * ``` + * + * 两层连续 basic update 可合并为一层，即 `bupd (bupd P) ⊢ bupd P`。 + */ +PROOF extern thm r_bupd_idem; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (frame_pred:A->bool). r_entails R (r_sep R + * (r_bupd R P) frame_pred) (r_bupd R (r_sep R P frame_pred)) + * ``` + * + * 若一部分资源可 basic-update 到 `P`，则与 `frame` 分离合取后，整体可更新到 `P ** frame`，且框架保持不变。 + */ +PROOF extern thm r_bupd_frame; + +/* View-shift consequence, composition, framing, and logical lifting. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_viewshift R P P + * ``` + * + * 任意断言都可通过不改变资源的更新 view shift 到自身。 + */ +PROOF extern thm r_viewshift_refl; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R P Q ==> r_viewshift R + * P Q + * ``` + * + * 普通资源蕴含可提升为完整 RA 的 view shift。 + */ +PROOF extern thm r_entails_to_viewshift; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_viewshift R P Q ==> + * r_viewshift R Q S ==> r_viewshift R P S + * ``` + * + * 从 `P` 更新到 `Q` 再从 `Q` 更新到 `S`，可合成为从 `P` 到 `S` 的 view shift。 + */ +PROOF extern thm r_viewshift_trans; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P2:A->bool) (P:A->bool) (Q:A->bool) (Q2:A->bool). + * r_entails R P2 P ==> r_viewshift R P Q ==> r_entails R Q Q2 ==> r_viewshift + * R P2 Q2 + * ``` + * + * `P2 ⊢ P` 可加强 view shift 的前件，`Q ⊢ Q2` 可放宽后件，从而由 `P ⇛ Q` 得到 `P2 ⇛ Q2`。 + */ +PROOF extern thm r_viewshift_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (frame_pred:A->bool). r_viewshift R + * P Q ==> r_viewshift R (r_sep R P frame_pred) (r_sep R Q frame_pred) + * ``` + * + * 从 `P` 到 `Q` 的完整 RA 更新可携带同一分离框架，得到 `P ** frame ⇛ Q ** frame`。 + */ +PROOF extern thm r_viewshift_frame; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P1:A->bool) (Q1:A->bool) (P2:A->bool) (Q2:A->bool). + * r_viewshift R P1 Q1 ==> r_viewshift R P2 Q2 ==> r_viewshift R (r_sep R P1 + * P2) (r_sep R Q1 Q2) + * ``` + * + * 两个 view shift 可逐分量组合为分离合取整体上的 view shift。 + */ +PROOF extern thm r_viewshift_sep; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:B->A->bool). (forall witness:B. + * r_viewshift R (P witness) (Q witness)) ==> r_viewshift R (r_exists R + * (\bound:B. P bound)) (r_exists R (\bound:B. Q bound)) + * ``` + * + * 若每个见证下 `P(w)` 都可更新到 `Q(w)`，则取存在量词后仍可执行该 view shift。 + */ +PROOF extern thm r_viewshift_exists; + +/* Ownership rules induced by deterministic and predicate RA updates. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A) (b:A). ra_update R a b ==> r_viewshift R (r_own R a) + * (r_own R b) + * ``` + * + * 确定性 RA 更新 `a ↝ b` 可将 `a` 的精确所有权 view shift 为 `b` 的精确所有权。 + */ +PROOF extern thm r_own_update; + +/* The predicate rule returns a witness, an exact-unit `r_fact`, and ownership. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A) (result_pred:A->bool). ra_updateP R a result_pred ==> + * r_viewshift R (r_own R a) (r_exists R (\selected:A. r_sep R (r_fact R + * (result_pred selected)) (r_own R selected))) + * ``` + * + * 谓词更新可从 `own(a)` 选择目标 `selected`，并分离返回 exact-unit 的 `result_pred(selected)` fact 与 `own(selected)`。 + */ +PROOF extern thm r_own_updateP; diff --git a/theory/logic/big_sep.c b/theory/logic/big_sep.c new file mode 100644 index 0000000000000000000000000000000000000000..dec37acbd47faef4cf5821a974dbb2baf0f5c86e --- /dev/null +++ b/theory/logic/big_sep.c @@ -0,0 +1,705 @@ +#include "proof/theory/logic/big_sep.h" +#include "proof/theory/logic/resource_prop_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/data/list.c" +#require "proof/theory/logic/resource_prop.c" + +PROOF static size_t BIG_SEP_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm prove_reflexive_equality_goal(term goal_tm) { + ENSURE_COND(is_eq(goal_tm), "big-sep goal is not an equality"); + struct dest_eq_results equality = dest_eq(goal_tm); + ENSURE_COND( + alpha_compare(equality.tm1, equality.tm2) == 0, + "big-sep equality is not reflexive"); + return refl_rule(equality.tm1); +err: + ERR_FUN_PUTS( + "prove_reflexive_equality_goal", + cstr_term(goal_tm)); + return empty_theorem; +} + +PROOF static thm prove_r_equiv_of_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool). + P == Q ==> + r_equiv R P Q + `); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = beta_rule(ap_term_rule( + `\X:A->bool. r_equiv (R:(A)ra) (P:A->bool) X`, + assume_rule(`(P:A->bool) == (Q:A->bool)`))); + ACCEPT_TAC( + body, + eq_mp_rule( + lifted, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_equiv_refl))); + return gnode_prove(root); +} + +PROOF static thm r_equiv_of_eq_big_sep = + prove_r_equiv_of_eq(); + +PROOF static thm prove_r_sep_ac(void) { + term R = `R:(A)ra`; + term P = `P:A->bool`; + term Q = `Q:A->bool`; + term S = `S:A->bool`; + thm commute = ispecl_rule( + TERM_LIST(R, P, Q), + r_sep_comm_eq); + thm associate = ispecl_rule( + TERM_LIST(R, P, Q, S), + r_sep_assoc_eq); + thm expose_pair = gsym_rule(associate); + thm swap_pair = beta_rule(ap_term_rule( + `\pair:A->bool. + r_sep (R:(A)ra) pair (S:A->bool)`, + commute)); + thm regroup = ispecl_rule( + TERM_LIST(R, Q, P, S), + r_sep_assoc_eq); + thm left_commute = trans_rule( + expose_pair, + trans_rule(swap_pair, regroup)); + return conj_rule( + commute, + conj_rule(associate, left_commute)); +} + +PROOF static thm r_sep_ac = + prove_r_sep_ac(); + +PROOF thm r_big_sep_list_def = new_rec_definition( + get_theorem_by_name("list_RECURSION"), + ` + (r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + ([]:(B)list) = + r_emp R) && + (r_big_sep_list + R + Phi + ((x:B) :: (xs:(B)list)) = + r_sep R (Phi x) (r_big_sep_list R Phi xs)) + `); + +/* Definitional equations and algebraic folds are first proved as private raw + * equalities. The stable handles below lift them to r_equiv. */ +PROOF static thm prove_r_big_sep_list_nil_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (Phi:B->A->bool). + r_big_sep_list R Phi ([]:(B)list) == r_emp R + `); + CONV_TAC(root, rewrite_conv(THM_LIST(r_big_sep_list_def))); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_nil_eq = + prove_r_big_sep_list_nil_eq(); + +PROOF static thm prove_r_big_sep_list_cons_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (x:B) + (xs:(B)list). + r_big_sep_list R Phi (x :: xs) == + r_sep R (Phi x) (r_big_sep_list R Phi xs) + `); + CONV_TAC(root, rewrite_conv(THM_LIST(r_big_sep_list_def))); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_cons_eq = + prove_r_big_sep_list_cons_eq(); + +PROOF static thm prove_r_big_sep_list_singleton_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (Phi:B->A->bool) (x:B). + r_big_sep_list R Phi (x :: []) == Phi x + `); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + r_big_sep_list_cons_eq, + r_big_sep_list_nil_eq, + r_sep_emp_r_eq))); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_singleton_eq = + prove_r_big_sep_list_singleton_eq(); + +PROOF static thm prove_r_big_sep_list_append_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (left:(B)list) + (right:(B)list). + r_big_sep_list R Phi (APPEND left right) == + r_sep + R + (r_big_sep_list R Phi left) + (r_big_sep_list R Phi right) + `); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "Phi"); + body = GEN_TAC(body, "left"); + gnode_list cases = INDUCT_TAC(body, `left:(B)list`); + + gnode base = AUTO_INTROS_TAC(cases[0]); + base = CONV_TAC( + base, + pure_rewrite_conv(THM_LIST( + HOL_APPEND, + r_big_sep_list_nil_eq, + r_sep_emp_l_eq))); + RULE_TAC(base, prove_reflexive_equality_goal); + + gnode step = AUTO_INTROS_TAC(cases[1]); + step = CONV_WITH_ASMP_TAC( + step, + pure_rewrite_conv, + THM_LIST( + HOL_APPEND, + r_big_sep_list_cons_eq, + r_sep_assoc_eq)); + RULE_TAC(step, prove_reflexive_equality_goal); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_append_eq = + prove_r_big_sep_list_append_eq(); + +PROOF static thm prove_r_big_sep_list_map_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (f:C->B) + (xs:(C)list). + r_big_sep_list R Phi (MAP f xs) == + r_big_sep_list R (\x:C. Phi (f x)) xs + `); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "Phi"); + body = GEN_TAC(body, "f"); + body = GEN_TAC(body, "xs"); + gnode_list cases = INDUCT_TAC(body, `xs:(C)list`); + CONV_TAC( + cases[0], + rewrite_conv(THM_LIST( + get_theorem_by_name("MAP"), + r_big_sep_list_nil_eq))); + gnode step = CONV_WITH_ASMP_TAC( + cases[1], + pure_rewrite_conv, + THM_LIST( + get_theorem_by_name("MAP"), + r_big_sep_list_cons_eq)); + step = CONV_TAC( + step, + depth_conv(get_conversion_by_name("BETA_CONV"))); + RULE_TAC(step, prove_reflexive_equality_goal); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_map_eq = + prove_r_big_sep_list_map_eq(); + +PROOF static thm prove_r_big_sep_list_sep_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (Psi:B->A->bool) + (xs:(B)list). + r_big_sep_list + R + (\x:B. r_sep R (Phi x) (Psi x)) + xs == + r_sep + R + (r_big_sep_list R Phi xs) + (r_big_sep_list R Psi xs) + `); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "Phi"); + body = GEN_TAC(body, "Psi"); + body = GEN_TAC(body, "xs"); + gnode_list cases = INDUCT_TAC(body, `xs:(B)list`); + CONV_TAC( + cases[0], + rewrite_conv(THM_LIST( + r_big_sep_list_nil_eq, + r_sep_emp_l_eq))); + gnode step = CONV_WITH_ASMP_TAC( + cases[1], + pure_rewrite_conv, + THM_LIST(r_big_sep_list_cons_eq)); + step = CONV_TAC( + step, + depth_conv(get_conversion_by_name("BETA_CONV"))); + ACCEPT_TAC( + step, + ac_rule(r_sep_ac, goal_ccl(step->g))); + return gnode_prove(root); +} + +PROOF static thm r_big_sep_list_sep_eq = + prove_r_big_sep_list_sep_eq(); + +PROOF static thm prove_r_big_sep_list_nil(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (Phi:B->A->bool). + r_equiv R (r_big_sep_list R Phi ([]:(B)list)) (r_emp R) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + ([]:(B)list)`, + `r_emp (R:(A)ra)`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `Phi:B->A->bool`), + r_big_sep_list_nil_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_nil = + prove_r_big_sep_list_nil(); + +PROOF static thm prove_r_big_sep_list_cons(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (x:B) + (xs:(B)list). + r_equiv + R + (r_big_sep_list R Phi (x :: xs)) + (r_sep R (Phi x) (r_big_sep_list R Phi xs)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + ((x:B) :: (xs:(B)list))`, + `r_sep (R:(A)ra) + ((Phi:B->A->bool) (x:B)) + (r_big_sep_list R Phi (xs:(B)list))`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Phi:B->A->bool`, + `x:B`, + `xs:(B)list`), + r_big_sep_list_cons_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_cons = + prove_r_big_sep_list_cons(); + +PROOF static thm prove_r_big_sep_list_singleton(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (Phi:B->A->bool) (x:B). + r_equiv R (r_big_sep_list R Phi (x :: [])) (Phi x) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + ((x:B) :: [])`, + `(Phi:B->A->bool) (x:B)`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `Phi:B->A->bool`, `x:B`), + r_big_sep_list_singleton_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_singleton = + prove_r_big_sep_list_singleton(); + +PROOF static thm prove_r_big_sep_list_append(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (left:(B)list) + (right:(B)list). + r_equiv + R + (r_big_sep_list R Phi (APPEND left right)) + (r_sep R + (r_big_sep_list R Phi left) + (r_big_sep_list R Phi right)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + (APPEND (left:(B)list) (right:(B)list))`, + `r_sep (R:(A)ra) + (r_big_sep_list R Phi (left:(B)list)) + (r_big_sep_list R Phi (right:(B)list))`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Phi:B->A->bool`, + `left:(B)list`, + `right:(B)list`), + r_big_sep_list_append_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_append = + prove_r_big_sep_list_append(); + +PROOF static thm prove_r_big_sep_list_mono(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (Psi:B->A->bool) + (xs:(B)list). + (forall x:B. + MEM x xs ==> + r_entails R (Phi x) (Psi x)) ==> + r_entails + R + (r_big_sep_list R Phi xs) + (r_big_sep_list R Psi xs) + `); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "Phi"); + body = GEN_TAC(body, "Psi"); + body = GEN_TAC(body, "xs"); + gnode_list cases = INDUCT_TAC(body, `xs:(B)list`); + + gnode base = DISCH_TAC(cases[0], "Hpointwise"); + base = CONV_TAC( + base, + pure_rewrite_conv(THM_LIST(r_big_sep_list_nil_eq))); + ACCEPT_TAC( + base, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `r_emp (R:(A)ra)`), + r_entails_refl)); + + gnode step = DISCH_TAC(cases[1], "Hpointwise"); + step = CONV_TAC( + step, + pure_rewrite_conv(THM_LIST(r_big_sep_list_cons_eq))); + thm pointwise = assume_rule(` + forall x:B. + MEM x ((a0:B) :: (a1:(B)list)) ==> + r_entails + (R:(A)ra) + ((Phi:B->A->bool) x) + ((Psi:B->A->bool) x) + `); + thm mem_head_equiv = apply_conversion( + pure_rewrite_conv(THM_LIST(get_theorem_by_name("MEM"))), + `MEM (a0:B) ((a0:B) :: (a1:(B)list))`); + thm mem_head = eq_mp_rule( + gsym_rule(mem_head_equiv), + disj1_rule( + refl_rule(`a0:B`), + `MEM (a0:B) (a1:(B)list)`)); + thm head_entails = mp_rule( + spec_rule(`a0:B`, pointwise), + mem_head); + + term x = `x:B`; + term mem_tail_tm = `MEM (x:B) (a1:(B)list)`; + thm mem_tail = assume_rule(mem_tail_tm); + thm mem_tail_equiv = apply_conversion( + pure_rewrite_conv(THM_LIST(get_theorem_by_name("MEM"))), + `MEM (x:B) ((a0:B) :: (a1:(B)list))`); + thm mem_whole = eq_mp_rule( + gsym_rule(mem_tail_equiv), + disj2_rule(`(x:B) == (a0:B)`, mem_tail)); + thm entails_at_x = mp_rule( + spec_rule(x, pointwise), + mem_whole); + thm tail_pointwise = gen_rule( + x, + disch_rule(mem_tail_tm, entails_at_x)); + thm tail_entails = mp_rule( + assume_rule(` + (forall x:B. + MEM x (a1:(B)list) ==> + r_entails + (R:(A)ra) + ((Phi:B->A->bool) x) + ((Psi:B->A->bool) x)) ==> + r_entails + R + (r_big_sep_list R Phi a1) + (r_big_sep_list R Psi a1) + `), + tail_pointwise); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `(Phi:B->A->bool) (a0:B)`, + `(Psi:B->A->bool) (a0:B)`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + (a1:(B)list)`, + `r_big_sep_list + (R:(A)ra) + (Psi:B->A->bool) + (a1:(B)list)`), + r_sep_mono), + head_entails), + tail_entails); + ACCEPT_TAC(step, result); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_mono = + prove_r_big_sep_list_mono(); + +PROOF static thm prove_r_big_sep_list_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (Psi:B->A->bool) + (xs:(B)list). + (forall x:B. + MEM x xs ==> + r_equiv R (Phi x) (Psi x)) ==> + r_equiv + R + (r_big_sep_list R Phi xs) + (r_big_sep_list R Psi xs) + `); + gnode body = AUTO_INTROS_TAC(root); + thm pointwise_equiv = assume_rule(` + forall x:B. + MEM x (xs:(B)list) ==> + r_equiv + (R:(A)ra) + ((Phi:B->A->bool) x) + ((Psi:B->A->bool) x) + `); + term x = `x:B`; + term member_tm = `MEM (x:B) (xs:(B)list)`; + thm member = assume_rule(member_tm); + thm at_x = mp_rule( + spec_rule(x, pointwise_equiv), + member); + thm both_at_x = rewrite_rule( + THM_LIST(r_equiv_def), + at_x); + thm forward_pointwise = gen_rule( + x, + disch_rule(member_tm, conjunct1_rule(both_at_x))); + thm reverse_pointwise = gen_rule( + x, + disch_rule(member_tm, conjunct2_rule(both_at_x))); + thm forward = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Phi:B->A->bool`, + `Psi:B->A->bool`, + `xs:(B)list`), + r_big_sep_list_mono), + forward_pointwise); + thm reverse = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Psi:B->A->bool`, + `Phi:B->A->bool`, + `xs:(B)list`), + r_big_sep_list_mono), + reverse_pointwise); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + (R:(A)ra) + (Phi:B->A->bool) + (xs:(B)list)`, + `r_big_sep_list + (R:(A)ra) + (Psi:B->A->bool) + (xs:(B)list)`), + r_equiv_intro), + forward), + reverse)); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_equiv = + prove_r_big_sep_list_equiv(); + +PROOF static thm prove_r_big_sep_list_map(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (f:C->B) + (xs:(C)list). + r_equiv + R + (r_big_sep_list R Phi (MAP f xs)) + (r_big_sep_list R (\x:C. Phi (f x)) xs) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list R (Phi:B->A->bool) + (MAP (f:C->B) (xs:(C)list))`, + `r_big_sep_list R + (\x:C. (Phi:B->A->bool) ((f:C->B) x)) + (xs:(C)list)`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Phi:B->A->bool`, + `f:C->B`, + `xs:(C)list`), + r_big_sep_list_map_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_map = + prove_r_big_sep_list_map(); + +PROOF static thm prove_r_big_sep_list_sep(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (Phi:B->A->bool) + (Psi:B->A->bool) + (xs:(B)list). + r_equiv + R + (r_big_sep_list + R + (\x:B. r_sep R (Phi x) (Psi x)) + xs) + (r_sep R + (r_big_sep_list R Phi xs) + (r_big_sep_list R Psi xs)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_big_sep_list + R + (\x:B. + r_sep R + ((Phi:B->A->bool) x) + ((Psi:B->A->bool) x)) + (xs:(B)list)`, + `r_sep (R:(A)ra) + (r_big_sep_list R Phi (xs:(B)list)) + (r_big_sep_list R Psi (xs:(B)list))`), + r_equiv_of_eq_big_sep), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Phi:B->A->bool`, + `Psi:B->A->bool`, + `xs:(B)list`), + r_big_sep_list_sep_eq))); + return gnode_prove(root); +} + +PROOF thm r_big_sep_list_sep = + prove_r_big_sep_list_sep(); + +PROOF static int audit_big_sep(void) { + thm_list public_theorems = THM_LIST( + r_big_sep_list_def, + r_big_sep_list_nil, + r_big_sep_list_cons, + r_big_sep_list_singleton, + r_big_sep_list_append, + r_big_sep_list_mono, + r_big_sep_list_equiv, + r_big_sep_list_map, + r_big_sep_list_sep); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND( + !IS_NULL(public_theorems[i]), + "big-sep theorem %zu is null", + i); + ENSURE_COND( + vector_size(hyp(public_theorems[i])) == 0, + "big-sep theorem %zu has hypotheses", + i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == BIG_SEP_AXIOMS_BEFORE, + "big-sep theory introduced axioms"); + return 0; +err: + ERR_FUN_PUTS("audit_big_sep"); + return -1; +} + +PROOF static int _BIG_SEP_AUDIT = + audit_big_sep(); diff --git a/theory/logic/big_sep.h b/theory/logic/big_sep.h new file mode 100644 index 0000000000000000000000000000000000000000..c1665e3b862b3a02395f5255b431d566a274aed8 --- /dev/null +++ b/theory/logic/big_sep.h @@ -0,0 +1,130 @@ +/** + * @file big_sep.h + * @brief List-indexed iterated separating conjunction. + * + * The module and file intentionally contain both the right-fold definition + * and its useful list laws; `big_sep` is not split into core/extras modules. + * The container surface is nevertheless list-only. In particular, + * `r_big_sep_list_map` is a naturality law for the ordinary list `MAP` + * operation, not a finite-map big-separation binder. + * + * The recursive definition has raw computation equations. Every exported + * assertion-algebra normalization below is stated with `r_equiv`; its raw + * equality proof remains private to `big_sep.c`. + */ + +#pragma once + +#include "proof/theory/data/list.h" +#include "proof/theory/logic/resource_prop.h" + +/** + * HOL conclusion: + * + * ```text + * (r_big_sep_list (R:(A)ra) (Phi:B->A->bool) ([]:(B)list) = r_emp R) && + * (r_big_sep_list R Phi ((x:B) :: (xs:(B)list)) = r_sep R (Phi x) + * (r_big_sep_list R Phi xs)) + * ``` + * + * 列表 big-sep 是右折叠：空表得到 `emp`，非空表把表头断言与表尾结果分离合取。 + */ +PROOF extern thm r_big_sep_list_def; + +/* Fold computation and append laws, exposed as `r_equiv`. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool). r_equiv R (r_big_sep_list R Phi + * ([]:(B)list)) (r_emp R) + * ``` + * + * 空列表的 big-sep 在 `r_equiv` 下等价于 `emp`。 + */ +PROOF extern thm r_big_sep_list_nil; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (x:B) (xs:(B)list). r_equiv R + * (r_big_sep_list R Phi (x :: xs)) (r_sep R (Phi x) (r_big_sep_list R Phi xs)) + * ``` + * + * 非空列表的 big-sep 等价于表头对应断言与表尾 big-sep 的分离合取。 + */ +PROOF extern thm r_big_sep_list_cons; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (x:B). r_equiv R (r_big_sep_list R Phi (x + * :: [])) (Phi x) + * ``` + * + * 单元素列表的 big-sep 等价于该元素对应的断言。 + */ +PROOF extern thm r_big_sep_list_singleton; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (left:(B)list) (right:(B)list). r_equiv R + * (r_big_sep_list R Phi (APPEND left right)) (r_sep R (r_big_sep_list R Phi + * left) (r_big_sep_list R Phi right)) + * ``` + * + * 拼接列表的 big-sep 等价于左右两个列表 big-sep 的分离合取。 + */ +PROOF extern thm r_big_sep_list_append; + +/* Member-restricted pointwise entailment and equivalence lifting. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (Psi:B->A->bool) (xs:(B)list). (forall + * x:B. MEM x xs ==> r_entails R (Phi x) (Psi x)) ==> r_entails R + * (r_big_sep_list R Phi xs) (r_big_sep_list R Psi xs) + * ``` + * + * 只要列表中每个元素的 `Phi` 都蕴含 `Psi`，整个列表的两个 big-sep 就保持该蕴含。 + */ +PROOF extern thm r_big_sep_list_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (Psi:B->A->bool) (xs:(B)list). (forall + * x:B. MEM x xs ==> r_equiv R (Phi x) (Psi x)) ==> r_equiv R (r_big_sep_list R + * Phi xs) (r_big_sep_list R Psi xs) + * ``` + * + * 只要列表中每个元素的 `Phi` 与 `Psi` 等价，两个列表 big-sep 就在 `r_equiv` 下等价。 + */ +PROOF extern thm r_big_sep_list_equiv; + +/* List MAP naturality and pointwise separation. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (f:C->B) (xs:(C)list). r_equiv R + * (r_big_sep_list R Phi (MAP f xs)) (r_big_sep_list R (\x:C. Phi (f x)) xs) + * ``` + * + * 对普通列表先执行 `MAP f` 再取 big-sep，等价于在原列表上逐项使用 `Phi(f(x))`。 + */ +PROOF extern thm r_big_sep_list_map; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (Phi:B->A->bool) (Psi:B->A->bool) (xs:(B)list). r_equiv R + * (r_big_sep_list R (\x:B. r_sep R (Phi x) (Psi x)) xs) (r_sep R + * (r_big_sep_list R Phi xs) (r_big_sep_list R Psi xs)) + * ``` + * + * 逐项分离合取后再做 big-sep，等价于分别聚合全部 `Phi`、`Psi` 后再分离合取。 + */ +PROOF extern thm r_big_sep_list_sep; diff --git a/theory/logic/excl_ra.c b/theory/logic/excl_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..f487a5f4f0350e884f5832938b1d28e489435922 --- /dev/null +++ b/theory/logic/excl_ra.c @@ -0,0 +1,1121 @@ +#include "proof/theory/logic/excl_ra_internal.h" +#include "proof/theory/logic/ra_builder.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/local_update.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t EXCL_RA_AXIOMS_BEFORE = vector_size(get_all_axioms()); + +PROOF indtype excl_type = new_datatype_definition( + "excl = ExclUnit" + " | Excl A" + " | ExclInvalid"); + +/* + * Multiplication with an owned value on the left, defined by cases on the + * right operand. + */ +PROOF thm excl_owned_op_def = new_rec_definition( + excl_type.rec, + ` + excl_owned_op (a:A) (ExclUnit:(A)excl) = Excl a && + excl_owned_op (a:A) (Excl b) = (ExclInvalid:(A)excl) && + excl_owned_op (a:A) ExclInvalid = (ExclInvalid:(A)excl) + `); + +PROOF thm excl_op_def = new_rec_definition( + excl_type.rec, + ` + excl_op (ExclUnit:(A)excl) (y:(A)excl) = y && + excl_op (Excl a) (y:(A)excl) = excl_owned_op a y && + excl_op (ExclInvalid:(A)excl) (y:(A)excl) = ExclInvalid + `); + +PROOF static thm excl_valid_def = new_rec_definition( + excl_type.rec, + ` + (excl_valid (ExclUnit:(A)excl) <=> T) && + (excl_valid (Excl a) <=> T) && + (excl_valid (ExclInvalid:(A)excl) <=> F) + `); + +/* + * Internal discriminator used to derive constructor-distinct facts. C*'s + * datatype wrapper returns induction and recursion theorems but does not + * register a named `excl_DISTINCT` theorem in the live theorem database. + */ +PROOF static thm excl_is_unit_def = new_rec_definition( + excl_type.rec, + ` + (excl_is_unit (ExclUnit:(A)excl) <=> T) && + (excl_is_unit (Excl a) <=> F) && + (excl_is_unit (ExclInvalid:(A)excl) <=> F) + `); + +PROOF static thm prove_excl_owned_ne_unit(void) { + term goal_tm = ` + forall a:A. ~((Excl a:(A)excl) == ExclUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = DISCH_TAC(body, "Heq"); + thm distinguished = ap_term_rule( + `excl_is_unit:(A)excl->bool`, + assume_rule(`(Excl (a:A):(A)excl) == ExclUnit`)); + thm contradiction = rewrite_rule( + THM_LIST(excl_is_unit_def), + distinguished); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm excl_owned_ne_unit = + prove_excl_owned_ne_unit(); + +PROOF static thm prove_excl_invalid_ne_unit(void) { + term goal_tm = ` + ~((ExclInvalid:(A)excl) == ExclUnit) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = DISCH_TAC(root, "Heq"); + thm distinguished = ap_term_rule( + `excl_is_unit:(A)excl->bool`, + assume_rule(`(ExclInvalid:(A)excl) == ExclUnit`)); + thm contradiction = rewrite_rule( + THM_LIST(excl_is_unit_def), + distinguished); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm excl_invalid_ne_unit = + prove_excl_invalid_ne_unit(); + +/* Internal constructor discriminator used to derive injectivity and the + * remaining owned/invalid distinction without assuming generated theorem + * names for this user-defined datatype. */ +PROOF static thm excl_matches_def = new_rec_definition( + excl_type.rec, + ` + (excl_matches (a:A) (ExclUnit:(A)excl) <=> F) && + (excl_matches (a:A) (Excl b) <=> a == b) && + (excl_matches (a:A) ExclInvalid <=> F) + `); + +PROOF static thm prove_excl_owned_injective(void) { + term goal_tm = ` + forall a b:A. + ((Excl a:(A)excl) == Excl b) <=> a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Heq"); + thm observed = ap_term_rule( + `excl_matches (a:A):(A)excl->bool`, + assume_rule(`(Excl (a:A):(A)excl) == Excl (b:A)`)); + observed = rewrite_rule( + THM_LIST(excl_matches_def, get_theorem_by_name("EQ_REFL")), + observed); + ACCEPT_TAC(forward, observed); + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + ACCEPT_TAC( + reverse, + ap_term_rule(`Excl:A->(A)excl`, assume_rule(`(a:A) == (b:A)`))); + thm proved = gnode_prove(root); + ENSURE_COND(equals_term(concl(proved), goal_tm), + "excl_ra_owned_inj has the wrong conclusion"); + return proved; +err: + ERR_FUN_PUTS("prove_excl_owned_injective"); + return empty_theorem; +} + +PROOF thm excl_ra_owned_inj = + prove_excl_owned_injective(); + +PROOF static thm prove_excl_invalid_ne_owned(void) { + term goal_tm = ` + forall a:A. + ~((ExclInvalid:(A)excl) == Excl a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm observed = ap_term_rule( + `excl_matches (a:A):(A)excl->bool`, + assume_rule(`(ExclInvalid:(A)excl) == Excl (a:A)`)); + thm contradiction = rewrite_rule( + THM_LIST(excl_matches_def, get_theorem_by_name("EQ_REFL")), + observed); + CONTR_TAC(body, contradiction); + thm proved = gnode_prove(root); + ENSURE_COND(equals_term(concl(proved), goal_tm), + "excl_invalid_ne_owned has the wrong conclusion"); + return proved; +err: + ERR_FUN_PUTS("prove_excl_invalid_ne_owned"); + return empty_theorem; +} + +PROOF static thm excl_invalid_ne_owned = + prove_excl_invalid_ne_owned(); + +/* Public constructor facts preserve the smaller internal ABI used by auth. */ +PROOF static thm expose_excl_owned_ne_unit(void) { + return excl_owned_ne_unit; +} + +PROOF thm excl_ra_owned_ne_unit = + expose_excl_owned_ne_unit(); + +PROOF static thm expose_excl_invalid_ne_unit(void) { + return excl_invalid_ne_unit; +} + +PROOF thm excl_ra_invalid_ne_unit = + expose_excl_invalid_ne_unit(); + +PROOF static thm expose_excl_invalid_ne_owned(void) { + return excl_invalid_ne_owned; +} + +PROOF thm excl_ra_invalid_ne_owned = + expose_excl_invalid_ne_owned(); + +PROOF static conv excl_reduce_conv(void) { + return rewrite_conv(THM_LIST( + excl_op_def, + excl_owned_op_def, + excl_valid_def)); +} + +PROOF static thm excl_reduce_goal_rule(const term goal_tm) { + thm reduced = apply_conversion(excl_reduce_conv(), goal_tm); + return eqt_elim_rule(reduced); +} + +PROOF static thm prove_excl_ra_laws(void) { + term goal_tm = ` + ra_laws + (ExclUnit:(A)excl) + excl_op + excl_valid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode unfolded = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + gnode_list assoc_a = CASES_TAC( + assoc, `a:(A)excl`, NULL); + for (size_t i = 0; i < vector_size(assoc_a); ++i) { + gnode_list assoc_b = CASES_TAC( + assoc_a[i], `b:(A)excl`, NULL); + for (size_t j = 0; j < vector_size(assoc_b); ++j) { + gnode_list assoc_c = CASES_TAC( + assoc_b[j], `c:(A)excl`, NULL); + for (size_t k = 0; k < vector_size(assoc_c); ++k) { + CONV_WITH_ASMP_TAC( + assoc_c[k], + rewrite_conv, + THM_LIST( + excl_op_def, + excl_owned_op_def, + excl_valid_def)); + } + } + } + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + gnode_list comm_a = CASES_TAC( + comm, `a:(A)excl`, NULL); + for (size_t i = 0; i < vector_size(comm_a); ++i) { + gnode_list comm_b = CASES_TAC( + comm_a[i], `b:(A)excl`, NULL); + for (size_t j = 0; j < vector_size(comm_b); ++j) { + CONV_WITH_ASMP_TAC( + comm_b[j], + rewrite_conv, + THM_LIST( + excl_op_def, + excl_owned_op_def, + excl_valid_def)); + } + } + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = AUTO_INTROS_TAC(law3[0]); + gnode_list unit_a = CASES_TAC( + unit, `a:(A)excl`, NULL); + for (size_t i = 0; i < vector_size(unit_a); ++i) { + CONV_WITH_ASMP_TAC( + unit_a[i], + rewrite_conv, + THM_LIST( + excl_op_def, + excl_owned_op_def, + excl_valid_def)); + } + + gnode_list law4 = CONJ_TAC(law3[1]); + RULE_TAC(law4[0], excl_reduce_goal_rule); + + gnode valid_down = GEN_TAC(law4[1], "a"); + valid_down = GEN_TAC(valid_down, "b"); + gnode_list valid_a = CASES_TAC( + valid_down, `a:(A)excl`, NULL); + for (size_t i = 0; i < vector_size(valid_a); ++i) { + gnode_list valid_b = CASES_TAC( + valid_a[i], `b:(A)excl`, NULL); + for (size_t j = 0; j < vector_size(valid_b); ++j) { + CONV_WITH_ASMP_TAC( + valid_b[j], + rewrite_conv, + THM_LIST( + excl_op_def, + excl_owned_op_def, + excl_valid_def)); + } + } + return gnode_prove(root); +} + +PROOF static thm excl_ra_laws = prove_excl_ra_laws(); + +PROOF static thm excl_ra_def = new_fun_definition(` + excl_ra : ((A)excl)ra = + ra_abs + ((ExclUnit:(A)excl),(excl_op,excl_valid)) +`); + +PROOF static thm prove_excl_ra_unit(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `ExclUnit:(A)excl`, + `excl_op:(A)excl->(A)excl->(A)excl`, + `excl_valid:(A)excl->bool`), + ra_unit_abs), + excl_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(excl_ra_def)), + computed); +} + +PROOF thm excl_ra_unit = prove_excl_ra_unit(); + +PROOF static thm prove_excl_ra_op_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `ExclUnit:(A)excl`, + `excl_op:(A)excl->(A)excl->(A)excl`, + `excl_valid:(A)excl->bool`), + ra_op_abs), + excl_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(excl_ra_def)), + computed); +} + +PROOF thm excl_ra_op_fn = prove_excl_ra_op_fn(); + +PROOF static thm prove_excl_ra_valid_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `ExclUnit:(A)excl`, + `excl_op:(A)excl->(A)excl->(A)excl`, + `excl_valid:(A)excl->bool`), + ra_valid_abs), + excl_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(excl_ra_def)), + computed); +} + +PROOF static thm excl_ra_valid_fn = prove_excl_ra_valid_fn(); + +PROOF static thm prove_excl_ra_owned_conflict(void) { + term goal_tm = ` + forall a b:A. + ra_op excl_ra (Excl a) (Excl b) == + (ExclInvalid:(A)excl) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + excl_ra_op_fn, + excl_op_def, + excl_owned_op_def))); + return gnode_prove(root); +} + +PROOF thm excl_ra_owned_conflict = prove_excl_ra_owned_conflict(); + +PROOF static thm prove_excl_ra_valid_unit(void) { + term goal_tm = ` + ra_valid excl_ra (ExclUnit:(A)excl) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + excl_ra_valid_fn, + excl_valid_def))); + return gnode_prove(root); +} + +PROOF thm excl_ra_valid_unit = prove_excl_ra_valid_unit(); + +PROOF static thm prove_excl_ra_valid_owned(void) { + term goal_tm = ` + forall a:A. ra_valid excl_ra (Excl a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + excl_ra_valid_fn, + excl_valid_def))); + return gnode_prove(root); +} + +PROOF thm excl_ra_valid_owned = prove_excl_ra_valid_owned(); + +PROOF static thm prove_excl_ra_invalid(void) { + term goal_tm = ` + ~(ra_valid excl_ra (ExclInvalid:(A)excl)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + excl_ra_valid_fn, + excl_valid_def))); + return gnode_prove(root); +} + +PROOF thm excl_ra_invalid = prove_excl_ra_invalid(); + +/* Exactly the distinguished invalid constructor is invalid. */ +PROOF static thm prove_excl_ra_valid_iff(void) { + term goal_tm = ` + forall x:(A)excl. + ra_valid (excl_ra:((A)excl)ra) x <=> + ~(x == (ExclInvalid:(A)excl)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "x"); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hvalid"); + forward = DISCH_TAC(forward, "Heq"); + thm validity_eq = ap_term_rule( + `ra_valid (excl_ra:((A)excl)ra):(A)excl->bool`, + assume_rule(`(x:(A)excl) == ExclInvalid`)); + thm invalid_valid = eq_mp_rule( + validity_eq, + assume_rule(`ra_valid (excl_ra:((A)excl)ra) (x:(A)excl)`)); + CONTR_TAC( + forward, + not_elim_rule(excl_ra_invalid, invalid_valid)); + + gnode reverse = DISCH_TAC(directions[1], "Hnot_invalid"); + gnode_list cases = CASES_TAC( + reverse, `x:(A)excl`, "Hx"); + thm unit_eq = assume_rule(gnode_get_asmps( + cases[0], CONST_STRING_LIST("Hx"))[0]); + ACCEPT_TAC( + cases[0], + pure_rewrite_rule( + THM_LIST(gsym_rule(unit_eq)), + excl_ra_valid_unit)); + + thm owned_eq = assume_rule(gnode_get_asmps( + cases[1], CONST_STRING_LIST("Hx"))[0]); + thm owned_valid = ispec_rule( + `a:A`, + excl_ra_valid_owned); + ACCEPT_TAC( + cases[1], + pure_rewrite_rule( + THM_LIST(gsym_rule(owned_eq)), + owned_valid)); + + thm invalid_eq = assume_rule(gnode_get_asmps( + cases[2], CONST_STRING_LIST("Hx"))[0]); + thm contradiction = not_elim_rule( + assume_rule(`~((x:(A)excl) == ExclInvalid)`), + invalid_eq); + CONTR_TAC(cases[2], contradiction); + return gnode_prove(root); +} + +PROOF thm excl_ra_valid_iff = + prove_excl_ra_valid_iff(); + +/* + * An owned token is frame-maximal: it is compatible only with ExclUnit. An + * owned or invalid frame reduces the composition to ExclInvalid, contradicting + * the compatibility premise in ra_maximal. + */ +PROOF static thm prove_excl_ra_maximal(void) { + term goal_tm = ` + forall a:A. + ra_maximal + (excl_ra:((A)excl)ra) + (Excl a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + body = GEN_TAC(body, "a"); + gnode_list maximal = CONJ_TAC(body); + ACCEPT_TAC( + maximal[0], + ispec_rule(`a:A`, excl_ra_valid_owned)); + body = GEN_TAC(maximal[1], "frame"); + gnode_list frame_cases = CASES_TAC( + body, + `frame:(A)excl`, + "Hframe"); + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + CONV_WITH_ASMP_TAC( + frame_cases[i], + rewrite_conv, + THM_LIST( + excl_ra_unit, + excl_ra_op_fn, + excl_ra_valid_fn, + excl_op_def, + excl_owned_op_def, + excl_valid_def)); + } + return gnode_prove(root); +} + +PROOF thm excl_ra_maximal = + prove_excl_ra_maximal(); + +PROOF static thm prove_excl_ra_included_owned(void) { + term goal_tm = ` + forall a b:A. + ra_included + (excl_ra:((A)excl)ra) + (Excl a) + (Excl b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + forward = ASMP_EXISTS_TAC(forward, "Hincluded", "frame"); + gnode_list frame_cases = CASES_TAC( + forward, `frame:(A)excl`, "Hframe"); + thm unit_frame = assume_rule(gnode_get_asmps( + frame_cases[0], CONST_STRING_LIST("Hframe"))[0]); + thm unit_extension = rewrite_rule( + THM_LIST( + unit_frame, + excl_ra_op_fn, + excl_op_def, + excl_owned_op_def), + assume_rule(` + (Excl (b:A):(A)excl) == + ra_op + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (frame:(A)excl)`)); + thm unit_payloads = eq_mp_rule( + ispecl_rule(TERM_LIST(`b:A`, `a:A`), excl_ra_owned_inj), + unit_extension); + ACCEPT_TAC(frame_cases[0], gsym_rule(unit_payloads)); + + for (size_t i = 1; i < vector_size(frame_cases); ++i) { + thm frame_eq = assume_rule(gnode_get_asmps( + frame_cases[i], CONST_STRING_LIST("Hframe"))[0]); + thm invalid_extension = rewrite_rule( + THM_LIST( + frame_eq, + excl_ra_op_fn, + excl_op_def, + excl_owned_op_def), + assume_rule(` + (Excl (b:A):(A)excl) == + ra_op + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (frame:(A)excl)`)); + thm impossible = not_elim_rule( + ispec_rule(`b:A`, excl_invalid_ne_owned), + gsym_rule(invalid_extension)); + CONTR_TAC(frame_cases[i], impossible); + } + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + reverse = EXISTS_TAC(reverse, `ExclUnit:(A)excl`); + thm unit_op = pure_once_rewrite_rule( + THM_LIST(excl_ra_unit), + ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`), + ra_unit_r)); + thm payload_eq = ap_term_rule( + `Excl:A->(A)excl`, + gsym_rule(assume_rule(`(a:A) == (b:A)`))); + ACCEPT_TAC(reverse, trans_rule(payload_eq, gsym_rule(unit_op))); + + thm proved = gnode_prove(root); + ENSURE_COND(equals_term(concl(proved), goal_tm), + "excl_ra_included_owned has the wrong conclusion"); + return proved; +err: + ERR_FUN_PUTS("prove_excl_ra_included_owned"); + return empty_theorem; +} + +PROOF thm excl_ra_included_owned = + prove_excl_ra_included_owned(); + +/* Owned values extend either trivially or to the inconsistent element. */ +PROOF static thm prove_excl_ra_included_owned_iff(void) { + term goal_tm = ` + forall (a:A) (x:(A)excl). + ra_included + (excl_ra:((A)excl)ra) + (Excl a) + x <=> + x == Excl a \/ x == (ExclInvalid:(A)excl) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + gnode_list cases = CASES_TAC( + forward, `x:(A)excl`, "Hx"); + + thm source_eq_unit = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `x:(A)excl`), + ra_maximal_included); + source_eq_unit = mp_rule( + source_eq_unit, + ispec_rule(`a:A`, excl_ra_maximal)); + thm case_unit_eq = assume_rule(gnode_get_asmps( + cases[0], CONST_STRING_LIST("Hx"))[0]); + thm case_unit_valid = pure_rewrite_rule( + THM_LIST(gsym_rule(case_unit_eq)), + excl_ra_valid_unit); + source_eq_unit = mp_rule(source_eq_unit, case_unit_valid); + source_eq_unit = mp_rule( + source_eq_unit, + assume_rule(` + ra_included + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (x:(A)excl) + `)); + thm owned_eq_unit = trans_rule(source_eq_unit, case_unit_eq); + CONTR_TAC( + cases[0], + not_elim_rule( + ispec_rule(`a:A`, excl_ra_owned_ne_unit), + owned_eq_unit)); + + thm source_eq_owned = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `x:(A)excl`), + ra_maximal_included); + source_eq_owned = mp_rule( + source_eq_owned, + ispec_rule(`a:A`, excl_ra_maximal)); + thm case_owned_eq = assume_rule(gnode_get_asmps( + cases[1], CONST_STRING_LIST("Hx"))[0]); + term case_owned_payload = dest_comb( + dest_eq(concl(case_owned_eq)).tm2).tm2; + thm case_owned_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (excl_ra:((A)excl)ra):(A)excl->bool`, + gsym_rule(case_owned_eq)), + ispec_rule(case_owned_payload, excl_ra_valid_owned)); + source_eq_owned = mp_rule(source_eq_owned, case_owned_valid); + source_eq_owned = mp_rule( + source_eq_owned, + assume_rule(` + ra_included + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (x:(A)excl) + `)); + gnode left = DISJ1_TAC(cases[1]); + ACCEPT_TAC(left, gsym_rule(source_eq_owned)); + + gnode right = DISJ2_TAC(cases[2]); + ACCEPT_TAC( + right, + assume_rule(gnode_get_asmps( + cases[2], CONST_STRING_LIST("Hx"))[0])); + + gnode reverse = DISCH_TAC(directions[1], "Htarget"); + gnode_list target_cases = ASMP_DISJ_TAC( + reverse, + "Htarget", + "Howned", + "Hinvalid"); + thm target_owned = assume_rule(` + (x:(A)excl) == Excl (a:A) + `); + thm reflexive = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`), + ra_included_refl); + ACCEPT_TAC( + target_cases[0], + eq_mp_rule( + beta_rule(ap_term_rule( + `\target:(A)excl. + ra_included + (excl_ra:((A)excl)ra) + (Excl (a:A)) + target`, + gsym_rule(target_owned))), + reflexive)); + + gnode invalid_target = CONV_TAC( + target_cases[1], + once_rewrite_conv(THM_LIST(ra_included_def))); + invalid_target = EXISTS_TAC(invalid_target, `Excl (a:A):(A)excl`); + thm target_invalid = assume_rule(` + (x:(A)excl) == (ExclInvalid:(A)excl) + `); + thm conflict = ispecl_rule( + TERM_LIST(`a:A`, `a:A`), + excl_ra_owned_conflict); + ACCEPT_TAC( + invalid_target, + trans_rule(target_invalid, gsym_rule(conflict))); + return gnode_prove(root); +} + +PROOF thm excl_ra_included_owned_iff = + prove_excl_ra_included_owned_iff(); + +/* Invalid is absorbing, so it includes only itself. */ +PROOF static thm prove_excl_ra_included_invalid_iff(void) { + term goal_tm = ` + forall x:(A)excl. + ra_included + (excl_ra:((A)excl)ra) + (ExclInvalid:(A)excl) + x <=> + x == ExclInvalid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "x"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + forward = ASMP_EXISTS_TAC(forward, "Hincluded", "frame"); + thm extension = assume_rule(` + (x:(A)excl) == + ra_op + (excl_ra:((A)excl)ra) + ExclInvalid + (frame:(A)excl) + `); + extension = rewrite_rule( + THM_LIST(excl_ra_op_fn, excl_op_def), + extension); + ACCEPT_TAC(forward, extension); + + gnode reverse = DISCH_TAC(directions[1], "Heq"); + reverse = EXISTS_TAC(reverse, `ExclUnit:(A)excl`); + thm target_eq = assume_rule(` + (x:(A)excl) == (ExclInvalid:(A)excl) + `); + thm unit_extension = pure_once_rewrite_rule( + THM_LIST(excl_ra_unit), + ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `ExclInvalid:(A)excl`), + ra_unit_r)); + ACCEPT_TAC( + reverse, + trans_rule(target_eq, gsym_rule(unit_extension))); + return gnode_prove(root); +} + +PROOF thm excl_ra_included_invalid_iff = + prove_excl_ra_included_invalid_iff(); + +/* Exclusive composition is cancellative on valid sources. Explicit cases + * keep the proof local: an owned common frame admits only ExclUnit on the + * source side, while an invalid common frame admits no valid source at all. */ +PROOF static thm prove_excl_ra_cancellative(void) { + term goal_tm = `ra_cancellative (excl_ra:((A)excl)ra)`; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = GEN_TAC(body, "frame"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hsource_valid"); + body = DISCH_TAC(body, "Hops_equal"); + + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)excl`, "Hframe"); + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + gnode_list a_cases = CASES_TAC( + frame_cases[i], `a:(A)excl`, "Ha"); + for (size_t j = 0; j < vector_size(a_cases); ++j) { + gnode_list b_cases = CASES_TAC( + a_cases[j], `b:(A)excl`, "Hb"); + for (size_t k = 0; k < vector_size(b_cases); ++k) { + gnode branch = b_cases[k]; + thm frame_eq = assume_rule(gnode_get_asmps( + branch, + CONST_STRING_LIST("Hframe"))[0]); + thm a_eq = assume_rule(gnode_get_asmps( + branch, + CONST_STRING_LIST("Ha"))[0]); + thm b_eq = assume_rule(gnode_get_asmps( + branch, + CONST_STRING_LIST("Hb"))[0]); + thm source_valid = assume_rule(gnode_get_asmps( + branch, + CONST_STRING_LIST("Hsource_valid"))[0]); + thm ops_equal = assume_rule(gnode_get_asmps( + branch, + CONST_STRING_LIST("Hops_equal"))[0]); + + if (i == 0 && j < 2) { + thm result = rewrite_rule( + THM_LIST( + frame_eq, + excl_ra_op_fn, + excl_op_def), + ops_equal); + ACCEPT_TAC(branch, result); + } else if (i == 1 && j == 0 && k == 0) { + ACCEPT_TAC( + branch, + trans_rule(a_eq, gsym_rule(b_eq))); + } else if (i == 1 && j == 0) { + thm validity_eq = ap_term_rule( + `ra_valid + (excl_ra:((A)excl)ra): + (A)excl->bool`, + ops_equal); + thm target_valid = eq_mp_rule( + validity_eq, + source_valid); + thm contradiction = rewrite_rule( + THM_LIST( + frame_eq, + b_eq, + excl_ra_op_fn, + excl_ra_valid_fn, + excl_op_def, + excl_owned_op_def, + excl_valid_def), + target_valid); + CONTR_TAC(branch, contradiction); + } else { + thm contradiction = rewrite_rule( + THM_LIST( + frame_eq, + a_eq, + excl_ra_op_fn, + excl_ra_valid_fn, + excl_op_def, + excl_owned_op_def, + excl_valid_def), + source_valid); + CONTR_TAC(branch, contradiction); + } + } + } + } + return gnode_prove(root); +} + +PROOF thm excl_ra_cancellative = + prove_excl_ra_cancellative(); + +/* Any valid target may replace this frame-maximal source. */ +PROOF static thm prove_excl_ra_update(void) { + term a = `a:A`; + term b = `b:A`; + thm result = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `Excl (b:A):(A)excl`), + ra_maximal_update); + result = mp_rule( + result, + ispec_rule(a, excl_ra_maximal)); + result = mp_rule( + result, + ispec_rule(b, excl_ra_valid_owned)); + result = gen_rule(b, result); + return gen_rule(a, result); +} + +PROOF thm excl_ra_update = prove_excl_ra_update(); + +/* Generic maximal replacement, with an arbitrary valid target. */ +PROOF static thm prove_excl_ra_update_valid(void) { + term goal_tm = ` + forall (a:A) (x:(A)excl). + ra_valid (excl_ra:((A)excl)ra) x ==> + ra_update excl_ra (Excl a) x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm result = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `x:(A)excl`), + ra_maximal_update); + result = mp_rule( + result, + ispec_rule(`a:A`, excl_ra_maximal)); + result = mp_rule( + result, + assume_rule(`ra_valid (excl_ra:((A)excl)ra) (x:(A)excl)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm excl_ra_update_valid = + prove_excl_ra_update_valid(); + +/* Unit framing makes target validity necessary as well as sufficient. */ +PROOF static thm prove_excl_ra_update_owned_iff(void) { + term goal_tm = ` + forall (a:A) (x:(A)excl). + ra_update + (excl_ra:((A)excl)ra) + (Excl a) + x <=> + ra_valid excl_ra x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + thm preserved = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `x:(A)excl`), + ra_update_valid); + preserved = mp_rule( + preserved, + assume_rule(` + ra_update + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (x:(A)excl) + `)); + preserved = mp_rule( + preserved, + ispec_rule(`a:A`, excl_ra_valid_owned)); + ACCEPT_TAC(forward, preserved); + + gnode reverse = DISCH_TAC(directions[1], "Hvalid"); + thm result = ispecl_rule( + TERM_LIST(`a:A`, `x:(A)excl`), + excl_ra_update_valid); + ACCEPT_TAC( + reverse, + mp_rule( + result, + assume_rule(`ra_valid (excl_ra:((A)excl)ra) (x:(A)excl)`))); + return gnode_prove(root); +} + +PROOF thm excl_ra_update_owned_iff = + prove_excl_ra_update_owned_iff(); + +/* The generic maximal local update gives full owned replacement directly. */ +PROOF static thm prove_excl_ra_local_update_valid(void) { + term goal_tm = ` + forall (a:A) (x:(A)excl). + ra_valid (excl_ra:((A)excl)ra) x ==> + ra_local_update + excl_ra + (Excl a) + (Excl a) + x + x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm result = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `Excl (a:A):(A)excl`, + `x:(A)excl`), + ra_local_update_maximal); + result = mp_rule( + result, + ispec_rule(`a:A`, excl_ra_maximal)); + result = mp_rule( + result, + assume_rule(`ra_valid (excl_ra:((A)excl)ra) (x:(A)excl)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm excl_ra_local_update_valid = + prove_excl_ra_local_update_valid(); + +/* Unit residual exposes target validity, making the local rule exact. */ +PROOF static thm prove_excl_ra_local_update_iff(void) { + term goal_tm = ` + forall (a:A) (x:(A)excl). + ra_local_update + (excl_ra:((A)excl)ra) + (Excl a) + (Excl a) + x + x <=> + ra_valid excl_ra x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + thm applied = ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`, + `Excl (a:A):(A)excl`, + `x:(A)excl`, + `x:(A)excl`, + `ExclUnit:(A)excl`), + ra_local_update_apply); + applied = mp_rule( + applied, + assume_rule(` + ra_local_update + (excl_ra:((A)excl)ra) + (Excl (a:A)) + (Excl (a:A)) + (x:(A)excl) + x + `)); + applied = mp_rule( + applied, + ispec_rule(`a:A`, excl_ra_valid_owned)); + thm source_unit = pure_once_rewrite_rule( + THM_LIST(excl_ra_unit), + ispecl_rule( + TERM_LIST( + `excl_ra:((A)excl)ra`, + `Excl (a:A):(A)excl`), + ra_unit_r)); + applied = mp_rule(applied, gsym_rule(source_unit)); + ACCEPT_TAC(forward, conjunct1_rule(applied)); + + gnode reverse = DISCH_TAC(directions[1], "Hvalid"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST(`a:A`, `x:(A)excl`), + excl_ra_local_update_valid), + assume_rule(`ra_valid (excl_ra:((A)excl)ra) (x:(A)excl)`))); + return gnode_prove(root); +} + +PROOF thm excl_ra_local_update_iff = + prove_excl_ra_local_update_iff(); + +PROOF static int audit_excl_ra(void) { + thm_list audited_theorems = THM_LIST( + excl_type.ind, + excl_type.rec, + excl_owned_op_def, + excl_op_def, + excl_valid_def, + excl_is_unit_def, + excl_matches_def, + excl_owned_ne_unit, + excl_invalid_ne_unit, + excl_ra_owned_inj, + excl_invalid_ne_owned, + excl_ra_owned_ne_unit, + excl_ra_invalid_ne_unit, + excl_ra_invalid_ne_owned, + excl_ra_laws, + excl_ra_def, + excl_ra_unit, + excl_ra_op_fn, + excl_ra_valid_fn, + excl_ra_owned_conflict, + excl_ra_valid_unit, + excl_ra_valid_owned, + excl_ra_invalid, + excl_ra_valid_iff, + excl_ra_maximal, + excl_ra_included_owned, + excl_ra_included_owned_iff, + excl_ra_included_invalid_iff, + excl_ra_cancellative, + excl_ra_update, + excl_ra_update_valid, + excl_ra_update_owned_iff, + excl_ra_local_update_valid, + excl_ra_local_update_iff); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "exclusive RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "exclusive RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == EXCL_RA_AXIOMS_BEFORE, + "exclusive RA introduced an axiom"); + ENSURE_COND(get_tyconst_arity("excl") == 1, + "excl is not a unary HOL type constructor"); + return 0; +err: + ERR_FUN_PUTS("audit_excl_ra"); + return -1; +} + +PROOF static int _EXCL_RA_AUDIT = audit_excl_ra(); diff --git a/theory/logic/excl_ra.h b/theory/logic/excl_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..13d0ceaae72aa03f86e45e9c3048dec70391744a --- /dev/null +++ b/theory/logic/excl_ra.h @@ -0,0 +1,115 @@ +#pragma once + +/* + * Public semantic interface for the exclusive resource algebra. + * + * `ExclUnit` is the unit, each `Excl a` is a valid owned token, and + * composing two owned tokens produces the invalid value `ExclInvalid`. + * Datatype elimination, constructor distinctions, and raw operation equations + * are confined to `excl_ra_internal.h`. + */ + +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Operation and validity */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_unit excl_ra == ExclUnit + * ``` + * + * exclusive RA 的 unit 是不持有 payload 的 `ExclUnit`。 + */ +PROOF extern thm excl_ra_unit; + +/* + * ```text + * forall a b. ra_op excl_ra (Excl a) (Excl b) == ExclInvalid + * ``` + * + * 任意两个 owned token `Excl a` 与 `Excl b` 组合都产生冲突值 `ExclInvalid`。 + */ +PROOF extern thm excl_ra_owned_conflict; + +/* + * ```text + * ra_valid excl_ra ExclUnit + * ``` + * + * exclusive RA 的 unit `ExclUnit` 是有效资源。 + */ +PROOF extern thm excl_ra_valid_unit; + +/* + * ```text + * forall a. ra_valid excl_ra (Excl a) + * ``` + * + * 每个 owned token `Excl a` 在 exclusive RA 中都有效。 + */ +PROOF extern thm excl_ra_valid_owned; + +/* + * ```text + * ~ra_valid excl_ra ExclInvalid + * ``` + * + * 冲突值 `ExclInvalid` 在 exclusive RA 中无效。 + */ +PROOF extern thm excl_ra_invalid; + +/* ------------------------------------------------------------------------- */ +/* Inclusion and algebraic properties */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a b. ra_included excl_ra (Excl a) (Excl b) <=> a == b + * ``` + * + * owned token `Excl a` 包含于 `Excl b`，当且仅当它们的 payload `a` 与 `b` 相等。 + */ +PROOF extern thm excl_ra_included_owned; + +/* + * ```text + * forall a. ra_maximal excl_ra (Excl a) + * ``` + * + * 每个 owned token `Excl a` 都是 maximal，因为它只能与 `ExclUnit` frame 兼容。 + */ +PROOF extern thm excl_ra_maximal; + +/* + * ```text + * ra_cancellative excl_ra + * ``` + * + * exclusive RA 满足消去性。 + */ +PROOF extern thm excl_ra_cancellative; + +/* ------------------------------------------------------------------------- */ +/* Replacement updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a x. ra_update excl_ra (Excl a) x <=> ra_valid excl_ra x + * ``` + * + * owned token `Excl a` 可更新为 `x`，当且仅当目标 `x` 在 exclusive RA 中有效。 + */ +PROOF extern thm excl_ra_update_owned_iff; + +/* + * ```text + * forall a x. + * ra_local_update excl_ra (Excl a) (Excl a) x x <=> ra_valid excl_ra x + * ``` + * + * whole/local 均为 `Excl a` 的对可局部更新为 `(x,x)`，当且仅当 `x` 有效。 + */ +PROOF extern thm excl_ra_local_update_iff; diff --git a/theory/logic/excl_ra_internal.h b/theory/logic/excl_ra_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..fe806e735b0d38642068e33e7459a63b6070900d --- /dev/null +++ b/theory/logic/excl_ra_internal.h @@ -0,0 +1,81 @@ +#pragma once + +/* + * INTERNAL CONSTRUCTION INTERFACE for the exclusive RA. + * + * Ordinary clients use `excl_ra.h`. This header is limited to constructor + * implementations such as `auth_ra` and `mem_ra` that must eliminate the + * exclusive datatype or normalize its raw operation. It must not be + * re-exported from a public protocol header. + */ + +#include "proof/theory/logic/excl_ra.h" + +/* ------------------------------------------------------------------------- */ +/* Raw datatype and operation */ +/* ------------------------------------------------------------------------- */ + +/* Datatype package for `excl = ExclUnit | Excl A | ExclInvalid`. */ +PROOF extern indtype excl_type; + +/* + * ```text + * excl_owned_op a ExclUnit == Excl a && + * excl_owned_op a (Excl b) == ExclInvalid && + * excl_owned_op a ExclInvalid == ExclInvalid + * ``` + * + * `excl_owned_op a` 遇到 unit 时返回 `Excl a`，遇到 owned token 或已无效值时都返回 `ExclInvalid`。 + */ +PROOF extern thm excl_owned_op_def; + +/* + * ```text + * excl_op ExclUnit y == y && + * excl_op (Excl a) y == excl_owned_op a y && + * excl_op ExclInvalid y == ExclInvalid + * ``` + * + * `excl_op` 以 `ExclUnit` 为左 unit，对左侧 owned token 调用 `excl_owned_op`，而左侧已无效时始终返回 `ExclInvalid`。 + */ +PROOF extern thm excl_op_def; + +/* ------------------------------------------------------------------------- */ +/* Representation normalization */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a. ~(Excl a == ExclUnit) + * ``` + * + * 任意 owned token `Excl a` 都不等于 unit `ExclUnit`。 + */ +PROOF extern thm excl_owned_ne_unit; + +/* + * ```text + * ~(ExclInvalid == ExclUnit) + * ``` + * + * 冲突值 `ExclInvalid` 不等于 unit `ExclUnit`。 + */ +PROOF extern thm excl_invalid_ne_unit; + +/* + * ```text + * ra_op excl_ra == excl_op + * ``` + * + * exclusive RA 的组合函数正是原始操作 `excl_op`。 + */ +PROOF extern thm excl_ra_op_fn; + +/* + * ```text + * forall a b. ra_update excl_ra (Excl a) (Excl b) + * ``` + * + * 任意 owned token `Excl a` 都可更新为另一个 owned token `Excl b`。 + */ +PROOF extern thm excl_ra_update; diff --git a/theory/logic/finmap.c b/theory/logic/finmap.c new file mode 100644 index 0000000000000000000000000000000000000000..aecfb62486c118d63e5bb5c1ffbd8d509b9fe3cf --- /dev/null +++ b/theory/logic/finmap.c @@ -0,0 +1,1791 @@ +#include "proof/theory/logic/finmap.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" + +PROOF static size_t FINMAP_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm finmap_finite_def = new_fun_definition(` + finmap_finite (f:K->V option) <=> + FINITE {k | ~(f k == NONE)} +`); + +PROOF static thm prove_finmap_rep_exists(void) { + term goal_tm = ` + exists f:K->V option. finmap_finite f + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = EXISTS_TAC(root, `\k:K. (NONE:V option)`); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST( + finmap_finite_def, + get_theorem_by_name("EMPTY_GSPEC"), + get_theorem_by_name("FINITE_EMPTY")))); + return gnode_prove(root); +} + +PROOF static thm finmap_rep_exists = + prove_finmap_rep_exists(); + +PROOF thm finmap_type_bijection = new_type_bijection_definition( + "finmap", "finmap_abs", "finmap_rep", finmap_rep_exists); + +PROOF static thm prove_finmap_rep_finite(void) { + term goal_tm = ` + forall m:(K,V)finmap. + finmap_finite (finmap_rep m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST(finmap_type_bijection))); + return gnode_prove(root); +} + +PROOF thm finmap_rep_finite = + prove_finmap_rep_finite(); + +PROOF static thm prove_finmap_eq(void) { + term goal_tm = ` + forall m n:(K,V)finmap. + m == n <=> finmap_rep m == finmap_rep n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode quantified = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(quantified); + + gnode forward = DISCH_TAC(directions[0], "Heq"); + ACCEPT_TAC( + forward, + ap_term_rule( + `finmap_rep:(K,V)finmap->K->V option`, + assume_rule(`m:(K,V)finmap == n`))); + + gnode reverse = DISCH_TAC(directions[1], "Hrep"); + thm abstract_eq = ap_term_rule( + `finmap_abs:(K->V option)->(K,V)finmap`, + assume_rule(` + finmap_rep (m:(K,V)finmap) == finmap_rep n + `)); + abstract_eq = rewrite_rule( + THM_LIST(conjunct1_rule(finmap_type_bijection)), + abstract_eq); + ACCEPT_TAC(reverse, abstract_eq); + return gnode_prove(root); +} + +PROOF thm finmap_eq = prove_finmap_eq(); + +PROOF static thm prove_finmap_empty_finite(void) { + term goal_tm = ` + finmap_finite (\k:K. (NONE:V option)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_finite_def, + get_theorem_by_name("EMPTY_GSPEC"), + get_theorem_by_name("FINITE_EMPTY")))); + return gnode_prove(root); +} + +PROOF static thm finmap_empty_finite = + prove_finmap_empty_finite(); + +PROOF thm finmap_empty_def = new_fun_definition(` + finmap_empty : (K,V)finmap = + finmap_abs (\k:K. (NONE:V option)) +`); + +PROOF thm finmap_lookup_def = new_fun_definition(` + finmap_lookup (m:(K,V)finmap) (k:K) : V option = + finmap_rep m k +`); + +PROOF static thm prove_finmap_empty_rep(void) { + term raw_empty = `\k:K. (NONE:V option)`; + thm inverse = ispec_rule( + raw_empty, + conjunct2_rule(finmap_type_bijection)); + thm represented = eq_mp_rule(inverse, finmap_empty_finite); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(finmap_empty_def)), + represented); +} + +PROOF thm finmap_empty_rep = + prove_finmap_empty_rep(); + +PROOF static thm prove_finmap_empty_lookup(void) { + term goal_tm = ` + forall k:K. + finmap_lookup (finmap_empty:(K,V)finmap) k == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_lookup_def, + finmap_empty_rep))); + return gnode_prove(root); +} + +PROOF thm finmap_empty_lookup = + prove_finmap_empty_lookup(); + +PROOF static thm prove_finmap_singleton_support(void) { + term goal_tm = ` + forall (key:K) (v:V). + {k:K | + ~((if k == key then SOME v else NONE) == NONE)} == + {key} + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "k"); + gnode_list branches = BOOL_CASES_TAC( + body, `(k:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(branches); ++i) { + CONV_WITH_ASMP_TAC( + branches[i], + rewrite_conv, + THM_LIST( + get_theorem_by_name("IN_ELIM_THM"), + get_theorem_by_name("IN_SING"), + get_theorem_by_name("option_DISTINCT"))); + } + return gnode_prove(root); +} + +PROOF thm finmap_singleton_support = + prove_finmap_singleton_support(); + +PROOF static thm prove_finmap_singleton_finite(void) { + term goal_tm = ` + forall (key:K) (v:V). + finmap_finite + (\k:K. if k == key then SOME v else NONE) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term key = `key:K`; + term v = `v:V`; + term raw = ` + \k:K. if k == (key:K) then SOME (v:V) else NONE + `; + thm support = ispecl_rule( + TERM_LIST(key, v), + finmap_singleton_support); + thm finite_singleton = ispec_rule( + key, + get_theorem_by_name("FINITE_SING")); + thm finite_support = eq_mp_rule( + gsym_rule(ap_term_rule( + `FINITE:(K->bool)->bool`, + support)), + finite_singleton); + thm finite_definition = inst_rule( + TERM_PAIR_LIST( + (term_pair){raw, `f:K->V option`}), + finmap_finite_def); + finite_definition = beta_rule(finite_definition); + thm finite_map = eq_mp_rule( + gsym_rule(finite_definition), + finite_support); + ACCEPT_TAC(body, finite_map); + return gnode_prove(root); +} + +PROOF static thm finmap_singleton_finite = + prove_finmap_singleton_finite(); + +PROOF thm finmap_singleton_def = new_fun_definition(` + finmap_singleton (key:K) (v:V) : (K,V)finmap = + finmap_abs + (\k:K. if k == key then SOME v else NONE) +`); + +PROOF static thm prove_finmap_singleton_rep(void) { + term key = `key:K`; + term v = `v:V`; + term raw = ` + \k:K. if k == (key:K) then SOME (v:V) else NONE + `; + thm finite = ispecl_rule( + TERM_LIST(key, v), + finmap_singleton_finite); + thm inverse = ispec_rule( + raw, + conjunct2_rule(finmap_type_bijection)); + thm represented = eq_mp_rule(inverse, finite); + represented = pure_once_rewrite_rule( + THM_LIST(gsym_rule(finmap_singleton_def)), + represented); + represented = gen_rule(v, represented); + return gen_rule(key, represented); +} + +PROOF thm finmap_singleton_rep = + prove_finmap_singleton_rep(); + +PROOF static thm prove_finmap_singleton_lookup(void) { + term goal_tm = ` + forall (key:K) (v:V) (k:K). + finmap_lookup (finmap_singleton key v) k == + if k == key then SOME v else NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_lookup_def, + finmap_singleton_rep))); + return gnode_prove(root); +} + +PROOF thm finmap_singleton_lookup = + prove_finmap_singleton_lookup(); + +PROOF static thm prove_finmap_insert_support(void) { + term goal_tm = ` + forall (key:K) (v:V) (f:K->V option). + {k:K | + ~((if k == key then SOME v else f k) == NONE)} == + key INSERT {k | ~(f k == NONE)} + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "k"); + gnode_list branches = BOOL_CASES_TAC( + body, `(k:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(branches); ++i) { + CONV_WITH_ASMP_TAC( + branches[i], + rewrite_conv, + THM_LIST( + get_theorem_by_name("IN_ELIM_THM"), + get_theorem_by_name("IN_INSERT"), + get_theorem_by_name("option_DISTINCT"))); + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_support = + prove_finmap_insert_support(); + +PROOF static thm prove_finmap_insert_finite(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_finite + (\k:K. + if k == key then SOME v else finmap_rep m k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term key = `key:K`; + term v = `v:V`; + term m = `m:(K,V)finmap`; + term support = ` + {k:K | ~(finmap_rep (m:(K,V)finmap) k == NONE)} + `; + term raw = ` + \k:K. + if k == (key:K) then SOME (v:V) + else finmap_rep (m:(K,V)finmap) k + `; + + thm finite_support = rewrite_rule( + THM_LIST(finmap_finite_def), + ispec_rule(m, finmap_rep_finite)); + thm finite_insert = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(support, key), + get_theorem_by_name("FINITE_INSERT"))), + finite_support); + thm support_eq = ispecl_rule( + TERM_LIST( + key, + v, + `finmap_rep (m:(K,V)finmap)`), + finmap_insert_support); + thm finite_raw_support = eq_mp_rule( + gsym_rule(ap_term_rule( + `FINITE:(K->bool)->bool`, + support_eq)), + finite_insert); + thm finite_definition = inst_rule( + TERM_PAIR_LIST( + (term_pair){raw, `f:K->V option`}), + finmap_finite_def); + finite_definition = beta_rule(finite_definition); + ACCEPT_TAC( + body, + eq_mp_rule( + gsym_rule(finite_definition), + finite_raw_support)); + return gnode_prove(root); +} + +PROOF static thm finmap_insert_finite = + prove_finmap_insert_finite(); + +PROOF thm finmap_insert_def = new_fun_definition(` + finmap_insert + (key:K) + (v:V) + (m:(K,V)finmap) : (K,V)finmap = + finmap_abs + (\k:K. + if k == key then SOME v else finmap_rep m k) +`); + +PROOF static thm prove_finmap_insert_rep(void) { + term key = `key:K`; + term v = `v:V`; + term m = `m:(K,V)finmap`; + term raw = ` + \k:K. + if k == (key:K) then SOME (v:V) + else finmap_rep (m:(K,V)finmap) k + `; + thm finite = ispecl_rule( + TERM_LIST(key, v, m), + finmap_insert_finite); + thm inverse = ispec_rule( + raw, + conjunct2_rule(finmap_type_bijection)); + thm represented = eq_mp_rule(inverse, finite); + represented = pure_once_rewrite_rule( + THM_LIST(gsym_rule(finmap_insert_def)), + represented); + represented = gen_rule(m, represented); + represented = gen_rule(v, represented); + return gen_rule(key, represented); +} + +PROOF thm finmap_insert_rep = + prove_finmap_insert_rep(); + +PROOF static thm prove_finmap_insert_lookup(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap) + (k:K). + finmap_lookup (finmap_insert key v m) k == + if k == key then SOME v else finmap_lookup m k + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_lookup_def, + finmap_insert_rep))); + return gnode_prove(root); +} + +PROOF thm finmap_insert_lookup = + prove_finmap_insert_lookup(); + +PROOF static thm prove_finmap_insert_lookup_eq(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_lookup (finmap_insert key v m) key == SOME v + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(finmap_insert_lookup))); + return gnode_prove(root); +} + +PROOF thm finmap_insert_lookup_eq = + prove_finmap_insert_lookup_eq(); + +PROOF static thm prove_finmap_insert_lookup_ne(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap) + (k:K). + ~(k == key) ==> + finmap_lookup (finmap_insert key v m) k == + finmap_lookup m k + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_WITH_ASMP_TAC( + body, + rewrite_conv, + THM_LIST(finmap_insert_lookup)); + return gnode_prove(root); +} + +PROOF thm finmap_insert_lookup_ne = + prove_finmap_insert_lookup_ne(); + +PROOF static thm prove_finmap_delete_support(void) { + term goal_tm = ` + forall (key:K) (f:K->V option). + {k:K | + ~((if k == key then NONE else f k) == NONE)} == + {k | ~(f k == NONE)} DELETE key + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "k"); + gnode_list branches = BOOL_CASES_TAC( + body, `(k:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(branches); ++i) { + CONV_WITH_ASMP_TAC( + branches[i], + rewrite_conv, + THM_LIST( + get_theorem_by_name("IN_ELIM_THM"), + get_theorem_by_name("IN_DELETE"))); + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_support = + prove_finmap_delete_support(); + +PROOF static thm prove_finmap_delete_finite(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap). + finmap_finite + (\k:K. + if k == key then NONE else finmap_rep m k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term key = `key:K`; + term m = `m:(K,V)finmap`; + term support = ` + {k:K | ~(finmap_rep (m:(K,V)finmap) k == NONE)} + `; + term raw = ` + \k:K. + if k == (key:K) then (NONE:V option) + else finmap_rep (m:(K,V)finmap) k + `; + + thm finite_support = rewrite_rule( + THM_LIST(finmap_finite_def), + ispec_rule(m, finmap_rep_finite)); + thm finite_delete = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(support, key), + get_theorem_by_name("FINITE_DELETE"))), + finite_support); + thm support_eq = ispecl_rule( + TERM_LIST( + key, + `finmap_rep (m:(K,V)finmap)`), + finmap_delete_support); + thm finite_raw_support = eq_mp_rule( + gsym_rule(ap_term_rule( + `FINITE:(K->bool)->bool`, + support_eq)), + finite_delete); + thm finite_definition = inst_rule( + TERM_PAIR_LIST( + (term_pair){raw, `f:K->V option`}), + finmap_finite_def); + finite_definition = beta_rule(finite_definition); + ACCEPT_TAC( + body, + eq_mp_rule( + gsym_rule(finite_definition), + finite_raw_support)); + return gnode_prove(root); +} + +PROOF static thm finmap_delete_finite = + prove_finmap_delete_finite(); + +PROOF thm finmap_delete_def = new_fun_definition(` + finmap_delete + (key:K) + (m:(K,V)finmap) : (K,V)finmap = + finmap_abs + (\k:K. + if k == key then NONE else finmap_rep m k) +`); + +PROOF static thm prove_finmap_delete_rep(void) { + term key = `key:K`; + term m = `m:(K,V)finmap`; + term raw = ` + \k:K. + if k == (key:K) then (NONE:V option) + else finmap_rep (m:(K,V)finmap) k + `; + thm finite = ispecl_rule( + TERM_LIST(key, m), + finmap_delete_finite); + thm inverse = ispec_rule( + raw, + conjunct2_rule(finmap_type_bijection)); + thm represented = eq_mp_rule(inverse, finite); + represented = pure_once_rewrite_rule( + THM_LIST(gsym_rule(finmap_delete_def)), + represented); + represented = gen_rule(m, represented); + return gen_rule(key, represented); +} + +PROOF thm finmap_delete_rep = + prove_finmap_delete_rep(); + +PROOF static thm prove_finmap_delete_lookup(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap) + (k:K). + finmap_lookup (finmap_delete key m) k == + if k == key then NONE else finmap_lookup m k + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_lookup_def, + finmap_delete_rep))); + return gnode_prove(root); +} + +PROOF thm finmap_delete_lookup = + prove_finmap_delete_lookup(); + +PROOF static thm prove_finmap_delete_lookup_eq(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap). + finmap_lookup (finmap_delete key m) key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(finmap_delete_lookup))); + return gnode_prove(root); +} + +PROOF thm finmap_delete_lookup_eq = + prove_finmap_delete_lookup_eq(); + +PROOF static thm prove_finmap_delete_lookup_ne(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap) + (k:K). + ~(k == key) ==> + finmap_lookup (finmap_delete key m) k == + finmap_lookup m k + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_WITH_ASMP_TAC( + body, + rewrite_conv, + THM_LIST(finmap_delete_lookup)); + return gnode_prove(root); +} + +PROOF thm finmap_delete_lookup_ne = + prove_finmap_delete_lookup_ne(); + +PROOF static thm prove_finmap_eq_lookup(void) { + term goal_tm = ` + forall (m:(K,V)finmap) (n:(K,V)finmap). + m == n <=> + forall k:K. + finmap_lookup m k == finmap_lookup n k + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq))); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("FUN_EQ_THM")))); + CONV_TAC( + body, + rewrite_conv(THM_LIST(finmap_lookup_def))); + return gnode_prove(root); +} + +PROOF thm finmap_eq_lookup = + prove_finmap_eq_lookup(); + +PROOF static thm prove_finmap_insert_empty(void) { + term goal_tm = ` + forall (key:K) (v:V). + finmap_insert key v (finmap_empty:(K,V)finmap) == + finmap_singleton key v + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_insert_lookup, + finmap_empty_lookup, + finmap_singleton_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_empty = + prove_finmap_insert_empty(); + +PROOF static thm prove_finmap_delete_empty(void) { + term goal_tm = ` + forall key:K. + finmap_delete key (finmap_empty:(K,V)finmap) == + finmap_empty + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_delete_lookup, + finmap_empty_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_empty = + prove_finmap_delete_empty(); + +PROOF static thm prove_finmap_insert_overwrite(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (w:V) + (m:(K,V)finmap). + finmap_insert key v (finmap_insert key w m) == + finmap_insert key v m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST(finmap_insert_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_overwrite = + prove_finmap_insert_overwrite(); + +PROOF static thm prove_finmap_insert_comm(void) { + term goal_tm = ` + forall + (key1:K) + (v1:V) + (key2:K) + (v2:V) + (m:(K,V)finmap). + ~(key1 == key2) ==> + finmap_insert key1 v1 (finmap_insert key2 v2 m) == + finmap_insert key2 v2 (finmap_insert key1 v1 m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list key1_cases = BOOL_CASES_TAC( + body, `(query:K) == (key1:K)`, NULL); + for (size_t i = 0; i < vector_size(key1_cases); ++i) { + gnode_list key2_cases = BOOL_CASES_TAC( + key1_cases[i], `(query:K) == (key2:K)`, NULL); + for (size_t j = 0; j < vector_size(key2_cases); ++j) { + CONV_WITH_ASMP_TAC( + key2_cases[j], + rewrite_conv, + THM_LIST(finmap_insert_lookup)); + } + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_comm = + prove_finmap_insert_comm(); + +PROOF static thm prove_finmap_delete_idempotent(void) { + term goal_tm = ` + forall (key:K) (m:(K,V)finmap). + finmap_delete key (finmap_delete key m) == + finmap_delete key m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST(finmap_delete_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_idempotent = + prove_finmap_delete_idempotent(); + +PROOF static thm prove_finmap_delete_comm(void) { + term goal_tm = ` + forall + (key1:K) + (key2:K) + (m:(K,V)finmap). + finmap_delete key1 (finmap_delete key2 m) == + finmap_delete key2 (finmap_delete key1 m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list key_cases = BOOL_CASES_TAC( + body, `(key1:K) == (key2:K)`, NULL); + for (size_t i = 0; i < vector_size(key_cases); ++i) { + gnode_list key1_cases = BOOL_CASES_TAC( + key_cases[i], `(query:K) == (key1:K)`, NULL); + for (size_t j = 0; j < vector_size(key1_cases); ++j) { + gnode_list key2_cases = BOOL_CASES_TAC( + key1_cases[j], `(query:K) == (key2:K)`, NULL); + for (size_t k = 0; k < vector_size(key2_cases); ++k) { + CONV_WITH_ASMP_TAC( + key2_cases[k], + rewrite_conv, + THM_LIST(finmap_delete_lookup)); + } + } + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_comm = + prove_finmap_delete_comm(); + +PROOF static thm prove_finmap_delete_insert(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_delete key (finmap_insert key v m) == + finmap_delete key m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_delete_lookup, + finmap_insert_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_insert = + prove_finmap_delete_insert(); + +PROOF static thm prove_finmap_delete_insert_ne(void) { + term goal_tm = ` + forall + (deleted:K) + (inserted:K) + (v:V) + (m:(K,V)finmap). + ~(deleted == inserted) ==> + finmap_delete deleted (finmap_insert inserted v m) == + finmap_insert inserted v (finmap_delete deleted m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list deleted_cases = BOOL_CASES_TAC( + body, `(query:K) == (deleted:K)`, NULL); + for (size_t i = 0; i < vector_size(deleted_cases); ++i) { + gnode_list inserted_cases = BOOL_CASES_TAC( + deleted_cases[i], `(query:K) == (inserted:K)`, NULL); + for (size_t j = 0; j < vector_size(inserted_cases); ++j) { + CONV_WITH_ASMP_TAC( + inserted_cases[j], + rewrite_conv, + THM_LIST( + finmap_delete_lookup, + finmap_insert_lookup)); + } + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_insert_ne = + prove_finmap_delete_insert_ne(); + +PROOF static thm prove_finmap_insert_delete(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_insert key v (finmap_delete key m) == + finmap_insert key v m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_insert_lookup, + finmap_delete_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_delete = + prove_finmap_insert_delete(); + +PROOF static thm prove_finmap_insert_id(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME v ==> + finmap_insert key v m == m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST(finmap_insert_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_insert_id = + prove_finmap_insert_id(); + +PROOF static thm prove_finmap_delete_id(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap). + finmap_lookup m key == NONE ==> + finmap_delete key m == m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST(finmap_delete_lookup)); + } + return gnode_prove(root); +} + +PROOF thm finmap_delete_id = + prove_finmap_delete_id(); + +PROOF static thm prove_finmap_decompose(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME v ==> + finmap_insert key v (finmap_delete key m) == m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm remove_then_restore = ispecl_rule( + TERM_LIST( + `key:K`, + `v:V`, + `m:(K,V)finmap`), + finmap_insert_delete); + thm insert_existing = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `v:V`, + `m:(K,V)finmap`), + finmap_insert_id), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (v:V) + `)); + ACCEPT_TAC( + body, + trans_rule(remove_then_restore, insert_existing)); + return gnode_prove(root); +} + +PROOF thm finmap_decompose = + prove_finmap_decompose(); + +PROOF thm finmap_dom_def = new_fun_definition(` + finmap_dom (m:(K,V)finmap) : K->bool = + {k | ~(finmap_lookup m k == NONE)} +`); + +PROOF static thm prove_finmap_dom_finite(void) { + term goal_tm = ` + forall m:(K,V)finmap. + FINITE (finmap_dom m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "m"); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST( + finmap_dom_def, + finmap_lookup_def))); + thm finite = ispec_rule( + `m:(K,V)finmap`, + finmap_rep_finite); + finite = rewrite_rule( + THM_LIST(finmap_finite_def), + finite); + ACCEPT_TAC(body, finite); + return gnode_prove(root); +} + +PROOF thm finmap_dom_finite = + prove_finmap_dom_finite(); + +PROOF static thm prove_finmap_dom_empty(void) { + term goal_tm = ` + finmap_dom (finmap_empty:(K,V)finmap) == {} + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_dom_def, + finmap_empty_lookup, + get_theorem_by_name("EMPTY_GSPEC")))); + return gnode_prove(root); +} + +PROOF thm finmap_dom_empty = + prove_finmap_dom_empty(); + +PROOF static thm prove_finmap_dom_singleton(void) { + term goal_tm = ` + forall (key:K) (v:V). + finmap_dom (finmap_singleton key v) == {key} + `; + gnode root = gnode_new_with_ccl(goal_tm); + thm_list rules = THM_LIST( + finmap_dom_def, + finmap_singleton_lookup, + finmap_singleton_support); + conv normalize = rewrite_conv(rules); + CONV_TAC(root, normalize); + thm result = gnode_prove(root); + return result; +} + +PROOF thm finmap_dom_singleton = + prove_finmap_dom_singleton(); + +PROOF static thm prove_finmap_in_dom(void) { + term goal_tm = ` + forall (key:K) (m:(K,V)finmap). + key IN finmap_dom m <=> + ~(finmap_lookup m key == NONE) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_dom_def, + get_theorem_by_name("IN_ELIM_THM")))); + return gnode_prove(root); +} + +PROOF thm finmap_in_dom = + prove_finmap_in_dom(); + +PROOF static thm prove_finmap_in_dom_some(void) { + term goal_tm = ` + forall (key:K) (m:(K,V)finmap). + key IN finmap_dom m <=> + exists v:V. finmap_lookup m key == SOME v + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list cases = CASES_TAC( + body, + `finmap_lookup (m:(K,V)finmap) (key:K)`, + "Hlookup"); + + thm none_lookup = assume_rule(gnode_get_asmps( + cases[0], CONST_STRING_LIST("Hlookup"))[0]); + gnode_list none_directions = EQ_TAC(cases[0]); + gnode none_forward = DISCH_TAC( + none_directions[0], "Hin"); + thm non_none = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_in_dom), + assume_rule(` + (key:K) IN finmap_dom (m:(K,V)finmap) + `)); + CONTR_TAC( + none_forward, + not_elim_rule(non_none, none_lookup)); + + gnode none_reverse = DISCH_TAC( + none_directions[1], "Hsome"); + none_reverse = ASMP_EXISTS_TAC( + none_reverse, "Hsome", "v"); + thm claimed_some = assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (v:V) + `); + thm none_is_some = trans_rule( + gsym_rule(claimed_some), + none_lookup); + CONTR_TAC( + none_reverse, + not_elim_rule( + ispec_rule( + `v:V`, + get_theorem_by_name("option_DISTINCT")), + none_is_some)); + + thm some_lookup = assume_rule(gnode_get_asmps( + cases[1], CONST_STRING_LIST("Hlookup"))[0]); + term payload = dest_comb(dest_eq(concl(some_lookup)).tm2).tm2; + gnode_list some_directions = EQ_TAC(cases[1]); + gnode some_forward = DISCH_TAC( + some_directions[0], "Hin"); + some_forward = EXISTS_TAC(some_forward, payload); + ACCEPT_TAC(some_forward, some_lookup); + + gnode some_reverse = DISCH_TAC( + some_directions[1], "Hsome"); + thm payload_non_none = ispec_rule( + payload, + get_theorem_by_name("option_DISTINCT")); + payload_non_none = rewrite_rule( + THM_LIST(gsym_rule(some_lookup)), + payload_non_none); + ACCEPT_TAC( + some_reverse, + eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_in_dom)), + payload_non_none)); + return gnode_prove(root); +} + +PROOF thm finmap_in_dom_some = + prove_finmap_in_dom_some(); + +PROOF static thm prove_finmap_not_in_dom(void) { + term goal_tm = ` + forall (key:K) (m:(K,V)finmap). + ~(key IN finmap_dom m) <=> + finmap_lookup m key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_in_dom, + get_theorem_by_name("NOT_CLAUSES")))); + return gnode_prove(root); +} + +PROOF thm finmap_not_in_dom = + prove_finmap_not_in_dom(); + +/* Every infinite set has an element outside a finite forbidden set. Keep + * this set-theoretic lemma private: the public interface phrases freshness + * directly in terms of finite maps. */ +PROOF static thm prove_finmap_infinite_avoid(void) { + term goal_tm = ` + forall (candidates:K->bool) (forbidden:K->bool). + INFINITE candidates ==> + FINITE forbidden ==> + exists key:K. + key IN candidates && ~(key IN forbidden) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term remainder = `(candidates:K->bool) DIFF (forbidden:K->bool)`; + thm remainder_infinite = mp_rule( + ispecl_rule( + TERM_LIST(`candidates:K->bool`, `forbidden:K->bool`), + get_theorem_by_name("INFINITE_DIFF_FINITE")), + conj_rule( + assume_rule(`INFINITE (candidates:K->bool)`), + assume_rule(`FINITE (forbidden:K->bool)`))); + thm remainder_nonempty = mp_rule( + ispec_rule( + remainder, + get_theorem_by_name("INFINITE_NONEMPTY")), + remainder_infinite); + thm witness = eq_mp_rule( + gsym_rule(ispec_rule( + remainder, + get_theorem_by_name("MEMBER_NOT_EMPTY"))), + remainder_nonempty); + witness = rewrite_rule( + THM_LIST(get_theorem_by_name("IN_DIFF")), + witness); + ACCEPT_TAC(body, witness); + return gnode_prove(root); +} + +PROOF static thm finmap_infinite_avoid = + prove_finmap_infinite_avoid(); + +PROOF static thm prove_finmap_fresh_in(void) { + term goal_tm = ` + forall (candidates:K->bool) (m:(K,V)finmap). + INFINITE candidates ==> + exists key:K. + key IN candidates && + finmap_lookup m key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fresh = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `candidates:K->bool`, + `finmap_dom (m:(K,V)finmap)`), + finmap_infinite_avoid), + assume_rule(`INFINITE (candidates:K->bool)`)), + ispec_rule( + `m:(K,V)finmap`, + finmap_dom_finite)); + fresh = rewrite_rule( + THM_LIST(finmap_not_in_dom), + fresh); + ACCEPT_TAC(body, fresh); + return gnode_prove(root); +} + +PROOF thm finmap_fresh_in = + prove_finmap_fresh_in(); + +PROOF static thm prove_finmap_fresh_in_pair(void) { + term goal_tm = ` + forall + (candidates:K->bool) + (m:(K,V)finmap) + (n:(K,W)finmap). + INFINITE candidates ==> + exists key:K. + key IN candidates && + finmap_lookup m key == NONE && + finmap_lookup n key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term m_dom = `finmap_dom (m:(K,V)finmap)`; + term n_dom = `finmap_dom (n:(K,W)finmap)`; + term forbidden = ` + finmap_dom (m:(K,V)finmap) UNION + finmap_dom (n:(K,W)finmap) + `; + thm forbidden_finite = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(m_dom, n_dom), + get_theorem_by_name("FINITE_UNION"))), + conj_rule( + ispec_rule( + `m:(K,V)finmap`, + finmap_dom_finite), + ispec_rule( + `n:(K,W)finmap`, + finmap_dom_finite))); + thm fresh = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST(`candidates:K->bool`, forbidden), + finmap_infinite_avoid), + assume_rule(`INFINITE (candidates:K->bool)`)), + forbidden_finite); + fresh = rewrite_rule( + THM_LIST( + get_theorem_by_name("IN_UNION"), + get_theorem_by_name("DE_MORGAN_THM"), + finmap_not_in_dom), + fresh); + ACCEPT_TAC(body, fresh); + return gnode_prove(root); +} + +PROOF thm finmap_fresh_in_pair = + prove_finmap_fresh_in_pair(); + +PROOF static thm prove_finmap_fresh(void) { + term goal_tm = ` + forall m:(K,V)finmap. + INFINITE (UNIV:K->bool) ==> + exists key:K. + finmap_lookup m key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fresh = mp_rule( + ispecl_rule( + TERM_LIST( + `UNIV:K->bool`, + `m:(K,V)finmap`), + finmap_fresh_in), + assume_rule(`INFINITE (UNIV:K->bool)`)); + fresh = rewrite_rule( + THM_LIST( + get_theorem_by_name("IN_UNIV"), + get_theorem_by_name("AND_CLAUSES")), + fresh); + ACCEPT_TAC(body, fresh); + return gnode_prove(root); +} + +PROOF thm finmap_fresh = + prove_finmap_fresh(); + +PROOF static thm prove_finmap_fresh_pair(void) { + term goal_tm = ` + forall + (m:(K,V)finmap) + (n:(K,W)finmap). + INFINITE (UNIV:K->bool) ==> + exists key:K. + finmap_lookup m key == NONE && + finmap_lookup n key == NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fresh = mp_rule( + ispecl_rule( + TERM_LIST( + `UNIV:K->bool`, + `m:(K,V)finmap`, + `n:(K,W)finmap`), + finmap_fresh_in_pair), + assume_rule(`INFINITE (UNIV:K->bool)`)); + fresh = rewrite_rule( + THM_LIST( + get_theorem_by_name("IN_UNIV"), + get_theorem_by_name("AND_CLAUSES")), + fresh); + ACCEPT_TAC(body, fresh); + return gnode_prove(root); +} + +PROOF thm finmap_fresh_pair = + prove_finmap_fresh_pair(); + +PROOF static thm prove_finmap_dom_eq_empty(void) { + term goal_tm = ` + forall m:(K,V)finmap. + finmap_dom m == {} <=> + m == finmap_empty + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "m"); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hdom"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + forward = GEN_TAC(forward, "key"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(finmap_empty_lookup))); + thm not_in_empty = ispec_rule( + `key:K`, + get_theorem_by_name("NOT_IN_EMPTY")); + thm not_in_dom = rewrite_rule( + THM_LIST(gsym_rule(assume_rule(` + finmap_dom (m:(K,V)finmap) == {} + `))), + not_in_empty); + ACCEPT_TAC( + forward, + eq_mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_not_in_dom), + not_in_dom)); + + gnode reverse = DISCH_TAC(directions[1], "Hmap"); + thm domains_equal = ap_term_rule( + `finmap_dom:(K,V)finmap->K->bool`, + assume_rule(` + (m:(K,V)finmap) == finmap_empty + `)); + domains_equal = rewrite_rule( + THM_LIST(finmap_dom_empty), + domains_equal); + ACCEPT_TAC(reverse, domains_equal); + return gnode_prove(root); +} + +PROOF thm finmap_dom_eq_empty = + prove_finmap_dom_eq_empty(); + +PROOF static thm prove_finmap_dom_insert(void) { + term goal_tm = ` + forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_dom (finmap_insert key v m) == + key INSERT finmap_dom m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_in_dom, + finmap_insert_lookup, + get_theorem_by_name("IN_INSERT"), + get_theorem_by_name("option_DISTINCT"))); + } + return gnode_prove(root); +} + +PROOF thm finmap_dom_insert = + prove_finmap_dom_insert(); + +PROOF static thm prove_finmap_dom_delete(void) { + term goal_tm = ` + forall + (key:K) + (m:(K,V)finmap). + finmap_dom (finmap_delete key m) == + finmap_dom m DELETE key + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_in_dom, + finmap_delete_lookup, + get_theorem_by_name("IN_DELETE"))); + } + return gnode_prove(root); +} + +PROOF thm finmap_dom_delete = + prove_finmap_dom_delete(); + +PROOF static thm prove_finmap_induct(void) { + term goal_tm = ` + forall P:((K,V)finmap)->bool. + P finmap_empty ==> + (forall + (key:K) + (v:V) + (m:(K,V)finmap). + finmap_lookup m key == NONE ==> + P m ==> + P (finmap_insert key v m)) ==> + forall m:(K,V)finmap. P m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "P"); + body = DISCH_TAC(body, "Hempty"); + body = DISCH_TAC(body, "Hinsert"); + body = GEN_TAC(body, "m"); + + term domain_predicate = ` + \s:K->bool. + forall n:(K,V)finmap. + finmap_dom n == s ==> P n + `; + thm finite_induction = beta_rule(ispec_rule( + domain_predicate, + get_theorem_by_name("FINITE_INDUCT_STRONG"))); + dest_imp_results induction_imp = dest_imp(concl(finite_induction)); + term induction_cases = induction_imp.tm1; + gnode_list asserted = ASSERT_TAC( + body, induction_cases, "Hdomain_induction"); + + thm all_finite_domains = mp_rule( + finite_induction, + assume_rule(induction_cases)); + thm current_domain_case = mp_rule( + ispec_rule( + `finmap_dom (m:(K,V)finmap)`, + all_finite_domains), + ispec_rule( + `m:(K,V)finmap`, + finmap_dom_finite)); + current_domain_case = beta_rule(current_domain_case); + thm current_map_case = mp_rule( + ispec_rule( + `m:(K,V)finmap`, + current_domain_case), + refl_rule(`finmap_dom (m:(K,V)finmap)`)); + ACCEPT_TAC(asserted[0], current_map_case); + + gnode induction_cases_goal = CONV_TAC( + asserted[1], + depth_conv(get_conversion_by_name("BETA_CONV"))); + gnode_list cases = CONJ_TAC(induction_cases_goal); + + gnode empty_case = GEN_TAC(cases[0], "n"); + empty_case = DISCH_TAC(empty_case, "Hdom_empty"); + thm map_is_empty = eq_mp_rule( + ispec_rule( + `n:(K,V)finmap`, + finmap_dom_eq_empty), + assume_rule(` + finmap_dom (n:(K,V)finmap) == {} + `)); + thm predicates_equal = ap_term_rule( + `P:((K,V)finmap)->bool`, + map_is_empty); + ACCEPT_TAC( + empty_case, + eq_mp_rule( + gsym_rule(predicates_equal), + assume_rule(` + (P:((K,V)finmap)->bool) finmap_empty + `))); + + gnode insert_case = GEN_TAC(cases[1], "key"); + insert_case = GEN_TAC(insert_case, "s"); + insert_case = DISCH_TAC(insert_case, "Hcase"); + insert_case = ASMP_CONJ_TAC( + insert_case, "Hcase", "Hsmaller", "Hside"); + insert_case = ASMP_CONJ_TAC( + insert_case, "Hside", "Hfresh", "Hfinite"); + insert_case = GEN_TAC(insert_case, "n"); + insert_case = DISCH_TAC(insert_case, "Hdom_insert"); + + thm in_insert = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `key:K`, + `key:K`, + `s:K->bool`), + get_theorem_by_name("IN_INSERT"))), + disj1_rule( + refl_rule(`key:K`), + `(key:K) IN (s:K->bool)`)); + thm in_domain = rewrite_rule( + THM_LIST(gsym_rule(assume_rule(` + finmap_dom (n:(K,V)finmap) == + (key:K) INSERT (s:K->bool) + `))), + in_insert); + thm payload_exists = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `n:(K,V)finmap`), + finmap_in_dom_some), + in_domain); + insert_case = ASSUME_TAC( + insert_case, payload_exists, "Hpayload"); + insert_case = ASMP_EXISTS_TAC( + insert_case, "Hpayload", "v"); + + thm domain_without_key = ispecl_rule( + TERM_LIST( + `key:K`, + `n:(K,V)finmap`), + finmap_dom_delete); + thm delete_domain_congruence = beta_rule(ap_term_rule( + `\d:K->bool. d DELETE (key:K)`, + assume_rule(` + finmap_dom (n:(K,V)finmap) == + (key:K) INSERT (s:K->bool) + `))); + thm delete_inserted_key = ispecl_rule( + TERM_LIST( + `key:K`, + `key:K`, + `s:K->bool`), + get_theorem_by_name("DELETE_INSERT")); + delete_inserted_key = rewrite_rule( + THM_LIST(get_theorem_by_name("COND_CLAUSES")), + delete_inserted_key); + thm delete_absent_key = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `s:K->bool`), + get_theorem_by_name("DELETE_NON_ELEMENT")), + assume_rule(`~((key:K) IN (s:K->bool))`)); + domain_without_key = trans_rule( + domain_without_key, + trans_rule( + delete_domain_congruence, + trans_rule( + delete_inserted_key, + delete_absent_key))); + + thm smaller_property = mp_rule( + ispec_rule( + `finmap_delete (key:K) (n:(K,V)finmap)`, + assume_rule(` + forall smaller:(K,V)finmap. + finmap_dom smaller == (s:K->bool) ==> + (P:((K,V)finmap)->bool) smaller + `)), + domain_without_key); + thm insert_step = ispecl_rule( + TERM_LIST( + `key:K`, + `v:V`, + `finmap_delete (key:K) (n:(K,V)finmap)`), + assume_rule(` + forall + (insert_key:K) + (insert_value:V) + (base:(K,V)finmap). + finmap_lookup base insert_key == NONE ==> + (P:((K,V)finmap)->bool) base ==> + P (finmap_insert insert_key insert_value base) + `)); + thm restored_property = mp_rule( + mp_rule( + insert_step, + ispecl_rule( + TERM_LIST( + `key:K`, + `n:(K,V)finmap`), + finmap_delete_lookup_eq)), + smaller_property); + thm restored_map = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `v:V`, + `n:(K,V)finmap`), + finmap_decompose), + assume_rule(` + finmap_lookup (n:(K,V)finmap) (key:K) == SOME (v:V) + `)); + ACCEPT_TAC( + insert_case, + eq_mp_rule( + ap_term_rule( + `P:((K,V)finmap)->bool`, + restored_map), + restored_property)); + return gnode_prove(root); +} + +PROOF thm finmap_induct = + prove_finmap_induct(); + +PROOF static int audit_finmap(void) { + thm_list public_theorems = THM_LIST( + finmap_finite_def, + finmap_type_bijection, + finmap_rep_finite, + finmap_eq, + finmap_empty_def, + finmap_lookup_def, + finmap_singleton_def, + finmap_insert_def, + finmap_delete_def, + finmap_dom_def, + finmap_empty_rep, + finmap_empty_lookup, + finmap_singleton_support, + finmap_singleton_rep, + finmap_singleton_lookup, + finmap_insert_support, + finmap_insert_rep, + finmap_insert_lookup, + finmap_insert_lookup_eq, + finmap_insert_lookup_ne, + finmap_delete_support, + finmap_delete_rep, + finmap_delete_lookup, + finmap_delete_lookup_eq, + finmap_delete_lookup_ne, + finmap_eq_lookup, + finmap_insert_empty, + finmap_delete_empty, + finmap_insert_overwrite, + finmap_insert_comm, + finmap_delete_idempotent, + finmap_delete_comm, + finmap_delete_insert, + finmap_delete_insert_ne, + finmap_insert_delete, + finmap_insert_id, + finmap_delete_id, + finmap_decompose, + finmap_dom_finite, + finmap_dom_empty, + finmap_dom_singleton, + finmap_in_dom, + finmap_in_dom_some, + finmap_not_in_dom, + finmap_fresh_in, + finmap_fresh_in_pair, + finmap_fresh, + finmap_fresh_pair, + finmap_dom_eq_empty, + finmap_dom_insert, + finmap_dom_delete, + finmap_induct); + + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "finite-map theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "finite-map theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == FINMAP_AXIOMS_BEFORE, + "finite-map carrier introduced an axiom"); + ENSURE_COND(get_tyconst_arity("finmap") == 2, + "finmap is not a binary HOL type constructor"); + return 0; +err: + ERR_FUN_PUTS("audit_finmap"); + return -1; +} + +PROOF static int _FINMAP_AUDIT = audit_finmap(); diff --git a/theory/logic/finmap.h b/theory/logic/finmap.h new file mode 100644 index 0000000000000000000000000000000000000000..84f6c4298cfd9a5723a8573f902bce9ceb6d7764 --- /dev/null +++ b/theory/logic/finmap.h @@ -0,0 +1,647 @@ +#pragma once + +/* + * Finite-support maps. + * + * `(K,V)finmap` is the conservative HOL subtype of total functions + * `K->V option` satisfying + * + * forall f:K->V option. + * finmap_finite f <=> FINITE {k:K | ~(f k == NONE)}. + * + * `NONE` is absence; a `SOME v` entry remains present for every payload `v`. + * The abstraction/representation functions are public theorem terms because + * RA constructions need extensional and finiteness facts at the subtype + * boundary. Clients should normally use lookup equations instead. + * Contracts use C* surface spelling: `==` is HOL equality, `==>` is + * implication, and `<=>` is Boolean equivalence. + */ + +#include "proof/proof_kernel.h" + +/* ------------------------------------------------------------------------- */ +/* Core representation */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * finmap_finite (f:K->V option) <=> FINITE {k:K | ~(f k == NONE)} + * ``` + * + * 函数 `f` 表示有限映射，当且仅当取值不为 `NONE` 的键只有有限个。 + */ +PROOF extern thm finmap_finite_def; + +/* + * Type-bijection theorem for + * `finmap_abs:(K->V option)->(K,V)finmap` and + * `finmap_rep:(K,V)finmap->K->V option`: + * + * ```text + * (forall m:(K,V)finmap. + * finmap_abs (finmap_rep m) == m) && + * (forall f:K->V option. + * finmap_finite f <=> + * finmap_rep (finmap_abs f) == f) + * ``` + * + * `finmap_abs` 与 `finmap_rep` 在有限支撑函数和有限映射之间构成互逆对应。 + */ +PROOF extern thm finmap_type_bijection; + +/* + * ```text + * forall m:(K,V)finmap. finmap_finite (finmap_rep m) + * ``` + * + * 任意有限映射的表示函数都只在有限个键上取非 `NONE` 值。 + */ +PROOF extern thm finmap_rep_finite; + +/* + * ```text + * forall (m:(K,V)finmap) (n:(K,V)finmap). + * m == n <=> finmap_rep m == finmap_rep n + * ``` + * + * 两个有限映射相等，当且仅当它们的表示函数相等。 + */ +PROOF extern thm finmap_eq; + +/* ------------------------------------------------------------------------- */ +/* Constructors and observations */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * finmap_empty:(K,V)finmap == finmap_abs (\k:K. NONE) + * ``` + * + * 空映射由处处返回 `NONE` 的函数抽象而成。 + */ +PROOF extern thm finmap_empty_def; + +/* + * ```text + * finmap_lookup (m:(K,V)finmap) (k:K) == finmap_rep m k + * ``` + * + * 在键 `k` 上查找映射 `m` 就是计算其表示函数 `finmap_rep m k`。 + */ +PROOF extern thm finmap_lookup_def; + +/* + * ```text + * finmap_singleton (key:K) (v:V) == + * finmap_abs (\k:K. if k == key then SOME v else NONE) + * ``` + * + * 单点映射只在 `key` 处返回 `SOME v`，其他键均返回 `NONE`。 + */ +PROOF extern thm finmap_singleton_def; + +/* + * ```text + * finmap_insert (key:K) (v:V) (m:(K,V)finmap) == + * finmap_abs (\k:K. if k == key then SOME v else finmap_rep m k) + * ``` + * + * 插入 `key -> v` 会覆盖 `key` 处的值，并保留 `m` 在其他键上的值。 + */ +PROOF extern thm finmap_insert_def; + +/* + * ```text + * finmap_delete (key:K) (m:(K,V)finmap) == + * finmap_abs (\k:K. if k == key then NONE else finmap_rep m k) + * ``` + * + * 删除 `key` 会使该键返回 `NONE`，并保留 `m` 在其他键上的值。 + */ +PROOF extern thm finmap_delete_def; + +/* + * ```text + * finmap_dom (m:(K,V)finmap) == + * {k:K | ~(finmap_lookup m k == NONE)} + * ``` + * + * `finmap_dom m` 正是在 `m` 中查找结果不为 `NONE` 的键集合。 + */ +PROOF extern thm finmap_dom_def; + +/* ------------------------------------------------------------------------- */ +/* Laws: representation and lookup */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * finmap_rep (finmap_empty:(K,V)finmap) == (\k:K. NONE) + * ``` + * + * 空映射的表示函数处处为 `NONE`。 + */ +PROOF extern thm finmap_empty_rep; + +/* + * ```text + * forall k:K. finmap_lookup (finmap_empty:(K,V)finmap) k == NONE + * ``` + * + * 在空映射中查找任意键都得到 `NONE`。 + */ +PROOF extern thm finmap_empty_lookup; + +/* + * ```text + * forall (key:K) (v:V). + * {k:K | ~((if k == key then SOME v else NONE) == NONE)} == + * {key} + * ``` + * + * 单点函数的非 `NONE` 支撑集恰为 `{key}`。 + */ +PROOF extern thm finmap_singleton_support; + +/* + * ```text + * forall (key:K) (v:V). + * finmap_rep (finmap_singleton key v) == + * (\k:K. if k == key then SOME v else NONE) + * ``` + * + * 单点映射的表示函数仅在 `key` 处取 `SOME v`。 + */ +PROOF extern thm finmap_singleton_rep; + +/* + * ```text + * forall (key:K) (v:V) (k:K). + * finmap_lookup (finmap_singleton key v) k == + * if k == key then SOME v else NONE + * ``` + * + * 在单点映射中，查找 `key` 得到 `SOME v`，查找其他键得到 `NONE`。 + */ +PROOF extern thm finmap_singleton_lookup; + +/* + * ```text + * forall (key:K) (v:V) (f:K->V option). + * {k:K | ~((if k == key then SOME v else f k) == NONE)} == + * key INSERT {k:K | ~(f k == NONE)} + * ``` + * + * 将 `key` 设为 `SOME v` 后，函数的非 `NONE` 支撑集等于原支撑集加上 `key`。 + */ +PROOF extern thm finmap_insert_support; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_rep (finmap_insert key v m) == + * (\k:K. + * if k == key then SOME v else finmap_rep m k) + * ``` + * + * 插入后的表示函数在 `key` 处取 `SOME v`，其他键沿用 `m` 的表示。 + */ +PROOF extern thm finmap_insert_rep; + +/* + * ```text + * forall + * (key:K) + * (v:V) + * (m:(K,V)finmap) + * (k:K). + * finmap_lookup (finmap_insert key v m) k == + * if k == key then SOME v else finmap_lookup m k + * ``` + * + * 插入 `key -> v` 后，查找 `key` 返回 `SOME v`，查找其他键与原映射相同。 + */ +PROOF extern thm finmap_insert_lookup; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_lookup (finmap_insert key v m) key == SOME v + * ``` + * + * 插入 `key -> v` 后立即查找 `key` 必得 `SOME v`。 + */ +PROOF extern thm finmap_insert_lookup_eq; + +/* + * ```text + * forall + * (key:K) + * (v:V) + * (m:(K,V)finmap) + * (k:K). + * ~(k == key) ==> + * finmap_lookup (finmap_insert key v m) k == finmap_lookup m k + * ``` + * + * 当 `k` 不等于插入键 `key` 时，插入前后在 `k` 处的查找结果不变。 + */ +PROOF extern thm finmap_insert_lookup_ne; + +/* + * ```text + * forall (key:K) (f:K->V option). + * {k:K | ~((if k == key then NONE else f k) == NONE)} == + * {k:K | ~(f k == NONE)} DELETE key + * ``` + * + * 将 `key` 设为 `NONE` 后，函数的非 `NONE` 支撑集等于原支撑集删去 `key`。 + */ +PROOF extern thm finmap_delete_support; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * finmap_rep (finmap_delete key m) == + * (\k:K. if k == key then NONE else finmap_rep m k) + * ``` + * + * 删除后的表示函数在 `key` 处取 `NONE`，其他键沿用 `m` 的表示。 + */ +PROOF extern thm finmap_delete_rep; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap) (k:K). + * finmap_lookup (finmap_delete key m) k == + * if k == key then NONE else finmap_lookup m k + * ``` + * + * 删除 `key` 后，查找 `key` 返回 `NONE`，查找其他键与原映射相同。 + */ +PROOF extern thm finmap_delete_lookup; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * finmap_lookup (finmap_delete key m) key == NONE + * ``` + * + * 删除 `key` 后立即查找该键必得 `NONE`。 + */ +PROOF extern thm finmap_delete_lookup_eq; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap) (k:K). + * ~(k == key) ==> + * finmap_lookup (finmap_delete key m) k == finmap_lookup m k + * ``` + * + * 当 `k` 不等于被删键 `key` 时，删除前后在 `k` 处的查找结果不变。 + */ +PROOF extern thm finmap_delete_lookup_ne; + +/* + * ```text + * forall (m:(K,V)finmap) (n:(K,V)finmap). + * m == n <=> + * forall k:K. finmap_lookup m k == finmap_lookup n k + * ``` + * + * 两个有限映射相等，当且仅当它们在每个键上的查找结果都相等。 + */ +PROOF extern thm finmap_eq_lookup; + +/* ------------------------------------------------------------------------- */ +/* Laws: insertion and deletion */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall (key:K) (v:V). + * finmap_insert key v (finmap_empty:(K,V)finmap) == + * finmap_singleton key v + * ``` + * + * 向空映射插入 `key -> v` 恰得单点映射 `finmap_singleton key v`。 + */ +PROOF extern thm finmap_insert_empty; + +/* + * ```text + * forall key:K. + * finmap_delete key (finmap_empty:(K,V)finmap) == finmap_empty + * ``` + * + * 从空映射删除任意键仍然得到空映射。 + */ +PROOF extern thm finmap_delete_empty; + +/* + * ```text + * forall + * (key:K) + * (v:V) + * (w:V) + * (m:(K,V)finmap). + * finmap_insert key v (finmap_insert key w m) == + * finmap_insert key v m + * ``` + * + * 对同一键连续插入时，最后插入的 `v` 覆盖先前的 `w`。 + */ +PROOF extern thm finmap_insert_overwrite; + +/* + * ```text + * forall + * (key1:K) + * (v1:V) + * (key2:K) + * (v2:V) + * (m:(K,V)finmap). + * ~(key1 == key2) ==> + * finmap_insert key1 v1 (finmap_insert key2 v2 m) == + * finmap_insert key2 v2 (finmap_insert key1 v1 m) + * ``` + * + * 对两个不同键的插入可以互换顺序。 + */ +PROOF extern thm finmap_insert_comm; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * finmap_delete key (finmap_delete key m) == finmap_delete key m + * ``` + * + * 对同一键删除两次与删除一次的结果相同。 + */ +PROOF extern thm finmap_delete_idempotent; + +/* + * ```text + * forall (key1:K) (key2:K) (m:(K,V)finmap). + * finmap_delete key1 (finmap_delete key2 m) == + * finmap_delete key2 (finmap_delete key1 m) + * ``` + * + * 删除两个键的顺序不影响最终映射。 + */ +PROOF extern thm finmap_delete_comm; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_delete key (finmap_insert key v m) == finmap_delete key m + * ``` + * + * 在 `key` 处插入后再删除该键，结果等于直接从原映射删除 `key`。 + */ +PROOF extern thm finmap_delete_insert; + +/* + * Deletion commutes with insertion at a different key: + * + * ```text + * forall + * (deleted:K) + * (inserted:K) + * (v:V) + * (m:(K,V)finmap). + * ~(deleted == inserted) ==> + * finmap_delete deleted (finmap_insert inserted v m) == + * finmap_insert inserted v (finmap_delete deleted m) + * ``` + * + * 删除键与在另一不同键上插入可以互换顺序。 + */ +PROOF extern thm finmap_delete_insert_ne; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_insert key v (finmap_delete key m) == + * finmap_insert key v m + * ``` + * + * 先删除 `key` 再插入 `key -> v`，结果等于直接覆盖该键。 + */ +PROOF extern thm finmap_insert_delete; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_lookup m key == SOME v ==> + * finmap_insert key v m == m + * ``` + * + * 若 `m` 在 `key` 处已是 `SOME v`，再插入同一键值不改变 `m`。 + */ +PROOF extern thm finmap_insert_id; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * finmap_lookup m key == NONE ==> + * finmap_delete key m == m + * ``` + * + * 若 `key` 本就不在 `m` 中，删除它不改变 `m`。 + */ +PROOF extern thm finmap_delete_id; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_lookup m key == SOME v ==> + * finmap_insert key v (finmap_delete key m) == m + * ``` + * + * 若 `m` 在 `key` 处的值为 `v`，则删除该键后再插回 `v` 可恢复 `m`。 + */ +PROOF extern thm finmap_decompose; + +/* ------------------------------------------------------------------------- */ +/* Laws: finite domain */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall m:(K,V)finmap. FINITE (finmap_dom m) + * ``` + * + * 每个有限映射的定义域都是有限集。 + */ +PROOF extern thm finmap_dom_finite; + +/* + * ```text + * finmap_dom (finmap_empty:(K,V)finmap) == {} + * ``` + * + * 空映射的定义域是空集。 + */ +PROOF extern thm finmap_dom_empty; + +/* + * ```text + * forall (key:K) (v:V). + * finmap_dom (finmap_singleton key v) == {key} + * ``` + * + * 单点映射 `key -> v` 的定义域恰为 `{key}`。 + */ +PROOF extern thm finmap_dom_singleton; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * key IN finmap_dom m <=> ~(finmap_lookup m key == NONE) + * ``` + * + * `key` 属于 `m` 的定义域，当且仅当在该键上的查找结果不为 `NONE`。 + */ +PROOF extern thm finmap_in_dom; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * key IN finmap_dom m <=> + * exists v:V. finmap_lookup m key == SOME v + * ``` + * + * `key` 属于 `m` 的定义域，当且仅当存在 `v` 使查找结果为 `SOME v`。 + */ +PROOF extern thm finmap_in_dom_some; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * ~(key IN finmap_dom m) <=> finmap_lookup m key == NONE + * ``` + * + * `key` 不在 `m` 的定义域中，当且仅当在该键上查找得到 `NONE`。 + */ +PROOF extern thm finmap_not_in_dom; + +/* + * An infinite candidate set contains a key outside any one finite map: + * + * ```text + * forall (candidates:K->bool) (m:(K,V)finmap). + * INFINITE candidates ==> + * exists key:K. + * key IN candidates && + * finmap_lookup m key == NONE + * ``` + * + * 若候选键集无限，则其中必有一个键在有限映射 `m` 中缺失。 + */ +PROOF extern thm finmap_fresh_in; + +/* + * An infinite candidate set contains a key outside two finite maps at once: + * + * ```text + * forall + * (candidates:K->bool) + * (m:(K,V)finmap) + * (n:(K,W)finmap). + * INFINITE candidates ==> + * exists key:K. + * key IN candidates && + * finmap_lookup m key == NONE && + * finmap_lookup n key == NONE + * ``` + * + * 若候选键集无限，则其中必有一个键同时在有限映射 `m` 和 `n` 中缺失。 + */ +PROOF extern thm finmap_fresh_in_pair; + +/* + * If the key type is infinite, every finite map has a fresh key: + * + * ```text + * forall m:(K,V)finmap. + * INFINITE (UNIV:K->bool) ==> + * exists key:K. + * finmap_lookup m key == NONE + * ``` + * + * 若键类型无限，则每个有限映射都有一个查找为 `NONE` 的新键。 + */ +PROOF extern thm finmap_fresh; + +/* + * If the key type is infinite, two finite maps have a common fresh key: + * + * ```text + * forall + * (m:(K,V)finmap) + * (n:(K,W)finmap). + * INFINITE (UNIV:K->bool) ==> + * exists key:K. + * finmap_lookup m key == NONE && + * finmap_lookup n key == NONE + * ``` + * + * 若键类型无限，则任意两个有限映射都共享一个查找为 `NONE` 的新键。 + */ +PROOF extern thm finmap_fresh_pair; + +/* + * ```text + * forall m:(K,V)finmap. + * finmap_dom m == {} <=> m == finmap_empty + * ``` + * + * 有限映射的定义域为空，当且仅当该映射是空映射。 + */ +PROOF extern thm finmap_dom_eq_empty; + +/* + * ```text + * forall (key:K) (v:V) (m:(K,V)finmap). + * finmap_dom (finmap_insert key v m) == + * key INSERT finmap_dom m + * ``` + * + * 插入 `key -> v` 会将 `key` 加入原映射的定义域。 + */ +PROOF extern thm finmap_dom_insert; + +/* + * ```text + * forall (key:K) (m:(K,V)finmap). + * finmap_dom (finmap_delete key m) == finmap_dom m DELETE key + * ``` + * + * 删除 `key` 会从原映射的定义域中去掉该键。 + */ +PROOF extern thm finmap_dom_delete; + +/* ------------------------------------------------------------------------- */ +/* Induction */ +/* ------------------------------------------------------------------------- */ + +/* + * Fresh-key induction: + * + * ```text + * forall P:((K,V)finmap)->bool. + * P finmap_empty ==> + * (forall + * (key:K) + * (v:V) + * (m:(K,V)finmap). + * finmap_lookup m key == NONE ==> + * P m ==> + * P (finmap_insert key v m)) ==> + * forall m:(K,V)finmap. P m + * ``` + * + * 要证明性质 `P` 对所有有限映射成立，只需证明空映射情形和在新键上插入的归纳步。 + */ +PROOF extern thm finmap_induct; diff --git a/theory/logic/frac_ra.c b/theory/logic/frac_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..605121069be9938502797c07dae0994e8044f261 --- /dev/null +++ b/theory/logic/frac_ra.c @@ -0,0 +1,2382 @@ +#include "proof/theory/logic/frac_ra.h" +#include "proof/theory/logic/ra_builder.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t FRAC_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +/* ------------------------------------------------------------------------- */ +/* Positive-real weights */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_frac_weight_rep_exists(void) { + term goal_tm = `exists p:real. &0 < p`; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = EXISTS_TAC(root, `&1:real`); + ACCEPT_TAC(body, get_theorem_by_name("REAL_LT_01")); + return gnode_prove(root); +} + +PROOF static thm frac_weight_rep_exists = + prove_frac_weight_rep_exists(); + +PROOF static thm frac_weight_type_bijection = + new_type_bijection_definition( + "frac_weight", + "frac_weight_abs", + "frac_weight_rep", + frac_weight_rep_exists); + +PROOF static thm frac_weight_value_def = + new_fun_definition(` + frac_weight_value (q:frac_weight) : real = + frac_weight_rep q + `); + +PROOF static thm frac_weight_of_real_def = + new_fun_definition(` + frac_weight_of_real (p:real) : frac_weight = + frac_weight_abs p + `); + +PROOF static thm frac_weight_add_def = + new_fun_definition(` + frac_weight_add + (q:frac_weight) + (r:frac_weight) : frac_weight = + frac_weight_of_real + (frac_weight_value q + frac_weight_value r) + `); + +PROOF static thm prove_frac_weight_value_pos(void) { + term goal_tm = ` + forall q:frac_weight. + &0 < frac_weight_value q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + frac_weight_value_def, + frac_weight_type_bijection))); + return gnode_prove(root); +} + +PROOF static thm frac_weight_value_pos = + prove_frac_weight_value_pos(); + +PROOF static thm prove_frac_weight_of_real_value(void) { + term goal_tm = ` + forall p:real. + &0 < p ==> + frac_weight_value (frac_weight_of_real p) == p + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm inverse = spec_rule( + `p:real`, + conjunct2_rule(frac_weight_type_bijection)); + thm represented = eq_mp_rule( + inverse, + assume_rule(`&0 < (p:real)`)); + thm reduced_goal = apply_conversion( + pure_rewrite_conv(THM_LIST( + frac_weight_value_def, + frac_weight_of_real_def)), + ` + frac_weight_value + (frac_weight_of_real (p:real)) == p + `); + ACCEPT_TAC( + body, + eq_mp_rule( + sym_rule(reduced_goal), + represented)); + return gnode_prove(root); +} + +PROOF static thm frac_weight_of_real_value = + prove_frac_weight_of_real_value(); + +PROOF static thm prove_frac_weight_add_value(void) { + term goal_tm = ` + forall q r:frac_weight. + frac_weight_value (frac_weight_add q r) == + frac_weight_value q + frac_weight_value r + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(frac_weight_add_def))); + + thm q_pos = ispec_rule( + `q:frac_weight`, + frac_weight_value_pos); + thm r_pos = ispec_rule( + `r:frac_weight`, + frac_weight_value_pos); + thm sum_pos = mp_rule( + ispecl_rule( + TERM_LIST( + `frac_weight_value (q:frac_weight)`, + `frac_weight_value (r:frac_weight)`), + get_theorem_by_name("REAL_LT_ADD")), + conj_rule(q_pos, r_pos)); + ACCEPT_TAC( + body, + mp_rule( + ispec_rule( + `frac_weight_value (q:frac_weight) + + frac_weight_value (r:frac_weight)`, + frac_weight_of_real_value), + sum_pos)); + return gnode_prove(root); +} + +PROOF static thm frac_weight_add_value = + prove_frac_weight_add_value(); + +PROOF static thm prove_frac_weight_eq(void) { + term goal_tm = ` + forall q r:frac_weight. + q == r <=> + frac_weight_value q == frac_weight_value r + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Heq"); + ACCEPT_TAC( + forward, + ap_term_rule( + `frac_weight_value:frac_weight->real`, + assume_rule(`q:frac_weight == r`))); + + gnode reverse = DISCH_TAC(directions[1], "Hvalue"); + thm rep_eq = pure_rewrite_rule( + THM_LIST(frac_weight_value_def), + assume_rule(` + frac_weight_value (q:frac_weight) == + frac_weight_value (r:frac_weight) + `)); + thm abs_eq = ap_term_rule( + `frac_weight_abs:real->frac_weight`, + rep_eq); + abs_eq = rewrite_rule( + THM_LIST(conjunct1_rule( + frac_weight_type_bijection)), + abs_eq); + ACCEPT_TAC(reverse, abs_eq); + return gnode_prove(root); +} + +PROOF static thm frac_weight_eq = + prove_frac_weight_eq(); + +PROOF static thm prove_frac_weight_add_assoc(void) { + term goal_tm = ` + forall q r s:frac_weight. + frac_weight_add (frac_weight_add q r) s == + frac_weight_add q (frac_weight_add r s) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + ispecl_rule( + TERM_LIST( + `frac_weight_add + (frac_weight_add + (q:frac_weight) + (r:frac_weight)) + (s:frac_weight)`, + `frac_weight_add + (q:frac_weight) + (frac_weight_add + (r:frac_weight) + (s:frac_weight))`), + frac_weight_eq)))); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + frac_weight_add_value, + get_theorem_by_name("REAL_ADD_ASSOC")))); + return gnode_prove(root); +} + +PROOF static thm frac_weight_add_assoc = + prove_frac_weight_add_assoc(); + +PROOF static thm prove_frac_weight_add_comm(void) { + term goal_tm = ` + forall q r:frac_weight. + frac_weight_add q r == frac_weight_add r q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + ispecl_rule( + TERM_LIST( + `frac_weight_add + (q:frac_weight) + (r:frac_weight)`, + `frac_weight_add + (r:frac_weight) + (q:frac_weight)`), + frac_weight_eq)))); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + frac_weight_add_value, + get_theorem_by_name("REAL_ADD_SYM")))); + return gnode_prove(root); +} + +PROOF static thm frac_weight_add_comm = + prove_frac_weight_add_comm(); + +PROOF static thm prove_frac_weight_add_le_left(void) { + term goal_tm = ` + forall q r:frac_weight. + frac_weight_value (frac_weight_add q r) <= &1 ==> + frac_weight_value q <= &1 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm sum_bound = pure_once_rewrite_rule( + THM_LIST(ispecl_rule( + TERM_LIST( + `q:frac_weight`, + `r:frac_weight`), + frac_weight_add_value)), + assume_rule(` + frac_weight_value + (frac_weight_add + (q:frac_weight) + (r:frac_weight)) <= &1 + `)); + thm r_pos = ispec_rule( + `r:frac_weight`, + frac_weight_value_pos); + thm left_bound = mp_rule( + mp_rule( + real_arith_rule(` + &0 < frac_weight_value (r:frac_weight) ==> + frac_weight_value (q:frac_weight) + + frac_weight_value r <= &1 ==> + frac_weight_value q <= &1 + `), + r_pos), + sum_bound); + ACCEPT_TAC(body, left_bound); + return gnode_prove(root); +} + +PROOF static thm frac_weight_add_le_left = + prove_frac_weight_add_le_left(); + +/* ------------------------------------------------------------------------- */ +/* Raw fractional descriptor */ +/* ------------------------------------------------------------------------- */ + +PROOF static indtype frac_type = new_datatype_definition( + "frac = FracUnit" + " | Frac frac_weight A"); + +PROOF static thm frac_token_op_def = new_rec_definition( + frac_type.rec, + ` + frac_token_op + (R:(A)ra) + (q:frac_weight) + (a:A) + (FracUnit:(A)frac) = + Frac q a && + frac_token_op + (R:(A)ra) + (q:frac_weight) + (a:A) + (Frac r b) = + Frac + (frac_weight_add q r) + (ra_op R a b) + `); + +PROOF static thm frac_op_def = new_rec_definition( + frac_type.rec, + ` + frac_op + (R:(A)ra) + (FracUnit:(A)frac) + (y:(A)frac) = + y && + frac_op + (R:(A)ra) + (Frac q a) + (y:(A)frac) = + frac_token_op R q a y + `); + +PROOF static thm frac_valid_def = new_rec_definition( + frac_type.rec, + ` + (frac_valid + (R:(A)ra) + (FracUnit:(A)frac) <=> + T) && + (frac_valid + (R:(A)ra) + (Frac q a) <=> + frac_weight_value q <= &1 && + ra_valid R a) + `); + +PROOF static thm prove_frac_op_assoc(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)frac) + (y:(A)frac) + (z:(A)frac). + frac_op R (frac_op R x y) z == + frac_op R x (frac_op R y z) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:(A)frac`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:(A)frac`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + gnode_list z_cases = CASES_TAC( + y_cases[j], `z:(A)frac`, NULL); + for (size_t k = 0; k < vector_size(z_cases); ++k) { + CONV_WITH_ASMP_TAC( + z_cases[k], + rewrite_conv, + THM_LIST( + frac_op_def, + frac_token_op_def, + frac_weight_add_assoc, + ra_assoc)); + } + } + } + return gnode_prove(root); +} + +PROOF static thm frac_op_assoc = + prove_frac_op_assoc(); + +PROOF static thm prove_frac_op_comm(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)frac) + (y:(A)frac). + frac_op R x y == frac_op R y x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:(A)frac`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:(A)frac`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + CONV_WITH_ASMP_TAC( + y_cases[j], + rewrite_conv, + THM_LIST( + frac_op_def, + frac_token_op_def, + frac_weight_add_comm, + ra_comm)); + } + } + return gnode_prove(root); +} + +PROOF static thm frac_op_comm = + prove_frac_op_comm(); + +PROOF static thm prove_frac_op_unit_l(void) { + term goal_tm = ` + forall (R:(A)ra) (x:(A)frac). + frac_op R FracUnit x == x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST(frac_op_def))); + return gnode_prove(root); +} + +PROOF static thm frac_op_unit_l = + prove_frac_op_unit_l(); + +PROOF static thm prove_frac_valid_unit(void) { + term goal_tm = ` + forall R:(A)ra. + frac_valid R (FracUnit:(A)frac) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(frac_valid_def))); + return gnode_prove(root); +} + +PROOF static thm frac_valid_unit = + prove_frac_valid_unit(); + +PROOF static thm prove_frac_valid_op_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:(A)frac) + (y:(A)frac). + frac_valid R (frac_op R x y) ==> + frac_valid R x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:(A)frac`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:(A)frac`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + if (i == 0) { + CONV_WITH_ASMP_TAC( + y_cases[j], + rewrite_conv, + THM_LIST(frac_valid_def)); + } else { + thm source_valid = rewrite_rule( + THM_LIST( + assume_rule(` + (x:(A)frac) == Frac a0 a1 + `), + j == 0 + ? assume_rule(` + (y:(A)frac) == FracUnit + `) + : assume_rule(` + (y:(A)frac) == Frac a0_ a1_ + `), + frac_op_def, + frac_token_op_def, + frac_valid_def), + assume_rule(` + frac_valid + (R:(A)ra) + (frac_op R (x:(A)frac) (y:(A)frac)) + `)); + + thm target_components; + if (j == 0) { + target_components = source_valid; + } else { + thm source_weight = conjunct1_rule(source_valid); + thm source_payload = conjunct2_rule(source_valid); + thm target_weight = mp_rule( + ispecl_rule( + TERM_LIST( + `a0:frac_weight`, + `a0_:frac_weight`), + frac_weight_add_le_left), + source_weight); + thm target_payload = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a1:A`, + `a1_:A`), + ra_valid_op_l), + source_payload); + target_components = + conj_rule(target_weight, target_payload); + } + + thm reduced_target = apply_conversion( + pure_rewrite_conv(THM_LIST( + assume_rule(` + (x:(A)frac) == Frac a0 a1 + `), + frac_valid_def)), + `frac_valid (R:(A)ra) (x:(A)frac)`); + ACCEPT_TAC( + y_cases[j], + eq_mp_rule( + sym_rule(reduced_target), + target_components)); + } + } + } + return gnode_prove(root); +} + +PROOF static thm frac_valid_op_l = + prove_frac_valid_op_l(); + +PROOF static thm prove_frac_ra_laws(void) { + term goal_tm = ` + forall R:(A)ra. + ra_laws + (FracUnit:(A)frac) + (frac_op R) + (frac_valid R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + gnode unfolded = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + ACCEPT_TAC( + law1[0], + spec_rule(`R:(A)ra`, frac_op_assoc)); + + gnode_list law2 = CONJ_TAC(law1[1]); + ACCEPT_TAC( + law2[0], + spec_rule(`R:(A)ra`, frac_op_comm)); + + gnode_list law3 = CONJ_TAC(law2[1]); + ACCEPT_TAC( + law3[0], + spec_rule(`R:(A)ra`, frac_op_unit_l)); + + gnode_list law4 = CONJ_TAC(law3[1]); + ACCEPT_TAC( + law4[0], + spec_rule(`R:(A)ra`, frac_valid_unit)); + ACCEPT_TAC( + law4[1], + spec_rule(`R:(A)ra`, frac_valid_op_l)); + return gnode_prove(root); +} + +PROOF static thm frac_ra_laws = + prove_frac_ra_laws(); + +PROOF static thm frac_ra_def = new_fun_definition(` + frac_ra (R:(A)ra) : ((A)frac)ra = + ra_abs + ((FracUnit:(A)frac), + (frac_op R,frac_valid R)) +`); + +PROOF static thm prove_frac_ra_unit_raw(void) { + term R = `R:(A)ra`; + thm laws = ispec_rule(R, frac_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `FracUnit:(A)frac`, + `frac_op (R:(A)ra):(A)frac->(A)frac->(A)frac`, + `frac_valid (R:(A)ra):(A)frac->bool`), + ra_unit_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(frac_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm frac_ra_unit_raw = + prove_frac_ra_unit_raw(); + +PROOF static thm prove_frac_ra_op_fn(void) { + term R = `R:(A)ra`; + thm laws = ispec_rule(R, frac_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `FracUnit:(A)frac`, + `frac_op (R:(A)ra):(A)frac->(A)frac->(A)frac`, + `frac_valid (R:(A)ra):(A)frac->bool`), + ra_op_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(frac_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm frac_ra_op_fn = + prove_frac_ra_op_fn(); + +PROOF static thm prove_frac_ra_valid_fn(void) { + term R = `R:(A)ra`; + thm laws = ispec_rule(R, frac_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `FracUnit:(A)frac`, + `frac_op (R:(A)ra):(A)frac->(A)frac->(A)frac`, + `frac_valid (R:(A)ra):(A)frac->bool`), + ra_valid_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(frac_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm frac_ra_valid_fn = + prove_frac_ra_valid_fn(); + +/* ------------------------------------------------------------------------- */ +/* Public smart constructors and semantic rules */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm frac_empty_def = new_fun_definition(` + frac_empty : (A)frac = FracUnit +`); + +PROOF static thm frac_own_def = new_fun_definition(` + frac_own (p:real) (a:A) : (A)frac = + Frac (frac_weight_of_real p) a +`); + +PROOF static thm frac_full_def = new_fun_definition(` + frac_full (a:A) : (A)frac = + frac_own (&1) a +`); + +PROOF static thm prove_frac_ra_unit(void) { + term goal_tm = ` + forall R:(A)ra. + ra_unit (frac_ra R) == + (frac_empty:(A)frac) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + frac_ra_unit_raw, + frac_empty_def))); + return gnode_prove(root); +} + +PROOF thm frac_ra_unit = + prove_frac_ra_unit(); + +PROOF static thm prove_frac_ra_full(void) { + term goal_tm = ` + forall a:A. + frac_full a == frac_own (&1) a + `; + thm reduced = apply_conversion( + rewrite_conv(THM_LIST(frac_full_def)), + goal_tm); + return eqt_elim_rule(reduced); +} + +PROOF thm frac_ra_full = + prove_frac_ra_full(); + +PROOF static thm prove_frac_ra_own_op(void) { + term goal_tm = ` + forall + (R:(A)ra) + (p:real) + (q:real) + (a:A) + (b:A). + &0 < (p:real) ==> + &0 < (q:real) ==> + ra_op + (frac_ra R) + (frac_own (p:real) (a:A)) + (frac_own (q:real) (b:A)) == + frac_own + ((p:real) + (q:real)) + (ra_op R (a:A) (b:A)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term conclusion_tm = ` + ra_op + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + (frac_own (q:real) (b:A)) == + frac_own + ((p:real) + (q:real)) + (ra_op R (a:A) (b:A)) + `; + thm p_value = mp_rule( + ispec_rule( + `p:real`, + frac_weight_of_real_value), + assume_rule(`&0 < (p:real)`)); + thm q_value = mp_rule( + ispec_rule( + `q:real`, + frac_weight_of_real_value), + assume_rule(`&0 < (q:real)`)); + thm reduced = apply_conversion( + rewrite_conv(THM_LIST( + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_own_def, + frac_weight_add_def, + p_value, + q_value)), + conclusion_tm); + ACCEPT_TAC(body, eqt_elim_rule(reduced)); + return gnode_prove(root); +} + +PROOF thm frac_ra_own_op = + prove_frac_ra_own_op(); + +PROOF static thm prove_frac_ra_own_inj(void) { + term goal_tm = ` + forall (p:real) (q:real) (a:A) (b:A). + &0 < (p:real) ==> + &0 < (q:real) ==> + (frac_own (p:real) (a:A) == + frac_own (q:real) (b:A) <=> + (p:real) == (q:real) && (a:A) == (b:A)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm p_value = mp_rule( + ispec_rule(`p:real`, frac_weight_of_real_value), + assume_rule(`&0 < (p:real)`)); + thm q_value = mp_rule( + ispec_rule(`q:real`, frac_weight_of_real_value), + assume_rule(`&0 < (q:real)`)); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + frac_own_def, + get_datatype_injectivity("frac"), + frac_weight_eq, + p_value, + q_value))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_own_inj = + prove_frac_ra_own_inj(); + +PROOF static thm prove_frac_ra_own_ne_empty(void) { + term goal_tm = ` + forall (p:real) (a:A). + ~(frac_own p a == (frac_empty:(A)frac)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + frac_own_def, + frac_empty_def, + get_datatype_distinctness("frac")))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_own_ne_empty = + prove_frac_ra_own_ne_empty(); + +PROOF static thm prove_frac_ra_full_inj(void) { + term goal_tm = ` + forall (a:A) (b:A). + frac_full a == frac_full b <=> a == b + `; + thm one_inj = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST(`&1:real`, `&1:real`, `a:A`, `b:A`), + frac_ra_own_inj), + get_theorem_by_name("REAL_LT_01")), + get_theorem_by_name("REAL_LT_01")); + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + frac_full_def, + one_inj))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_full_inj = + prove_frac_ra_full_inj(); + +PROOF static thm prove_frac_ra_full_ne_empty(void) { + term goal_tm = ` + forall a:A. + ~(frac_full a == (frac_empty:(A)frac)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + frac_full_def, + frac_ra_own_ne_empty))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_full_ne_empty = + prove_frac_ra_full_ne_empty(); + +PROOF static thm prove_frac_ra_valid_empty(void) { + term goal_tm = ` + forall R:(A)ra. + ra_valid + (frac_ra R) + (frac_empty:(A)frac) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + frac_ra_valid_fn, + frac_valid_def, + frac_empty_def))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_valid_empty = + prove_frac_ra_valid_empty(); + +PROOF static thm prove_frac_ra_valid_own(void) { + term goal_tm = ` + forall (R:(A)ra) (p:real) (a:A). + &0 < p ==> + (ra_valid + (frac_ra R) + (frac_own p a) <=> + p <= &1 && ra_valid R a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm p_value = mp_rule( + ispec_rule( + `p:real`, + frac_weight_of_real_value), + assume_rule(`&0 < (p:real)`)); + thm reduced = apply_conversion( + rewrite_conv(THM_LIST( + frac_ra_valid_fn, + frac_valid_def, + frac_own_def, + p_value)), + ` + ra_valid + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) <=> + p <= &1 && ra_valid R a + `); + ACCEPT_TAC(body, eqt_elim_rule(reduced)); + return gnode_prove(root); +} + +PROOF thm frac_ra_valid_own = + prove_frac_ra_valid_own(); + +PROOF static thm prove_frac_ra_valid_full(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_valid + (frac_ra R) + (frac_full a) <=> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm owned_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `&1:real`, + `a:A`), + frac_ra_valid_own), + get_theorem_by_name("REAL_LT_01")); + owned_valid = rewrite_rule( + THM_LIST(get_theorem_by_name("REAL_LE_REFL")), + owned_valid); + thm reduced_target = apply_conversion( + pure_once_rewrite_conv(THM_LIST(frac_full_def)), + ` + ra_valid + (frac_ra (R:(A)ra)) + (frac_full (a:A)) <=> + ra_valid R a + `); + ACCEPT_TAC( + body, + eq_mp_rule( + sym_rule(reduced_target), + owned_valid)); + return gnode_prove(root); +} + +PROOF static thm frac_ra_valid_full = + prove_frac_ra_valid_full(); + +/* ------------------------------------------------------------------------- */ +/* Inclusion */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_frac_ra_included_empty(void) { + term goal_tm = ` + forall (R:(A)ra) (x:(A)frac). + ra_included (frac_ra R) frac_empty x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm included = ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `x:(A)frac`), + ra_included_unit); + ACCEPT_TAC( + body, + pure_once_rewrite_rule( + THM_LIST(ispec_rule(`R:(A)ra`, frac_ra_unit)), + included)); + return gnode_prove(root); +} + +PROOF static thm frac_ra_included_empty = + prove_frac_ra_included_empty(); + +PROOF static thm prove_frac_ra_included_own(void) { + term goal_tm = ` + forall + (R:(A)ra) + (p:real) + (q:real) + (a:A) + (b:A). + &0 < p ==> + &0 < q ==> + (ra_included + (frac_ra R) + (frac_own p a) + (frac_own q b) <=> + (p == q && a == b) || + (p < q && ra_included R a b)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm p_value = mp_rule( + ispec_rule(`p:real`, frac_weight_of_real_value), + assume_rule(`&0 < (p:real)`)); + thm q_value = mp_rule( + ispec_rule(`q:real`, frac_weight_of_real_value), + assume_rule(`&0 < (q:real)`)); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + thm included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + (frac_own (q:real) (b:A)) + `)); + forward = ASSUME_TAC(forward, included, "Hextension"); + forward = ASMP_EXISTS_TAC( + forward, "Hextension", "frame"); + gnode_list frame_cases = CASES_TAC( + forward, `frame:(A)frac`, "Hframe"); + + term unit_frame_eq_tm = gnode_get_asmps( + frame_cases[0], + CONST_STRING_LIST("Hframe"))[0]; + thm unit_extension = rewrite_rule( + THM_LIST( + assume_rule(unit_frame_eq_tm), + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_own_def), + assume_rule(` + frac_own (q:real) (b:A) == + ra_op + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + (frame:(A)frac) + `)); + thm unit_components = rewrite_rule( + THM_LIST( + get_datatype_injectivity("frac"), + frac_weight_eq, + p_value, + q_value), + unit_extension); + gnode unit_result = DISJ1_TAC(frame_cases[0]); + gnode_list unit_parts = CONJ_TAC(unit_result); + ACCEPT_TAC( + unit_parts[0], + sym_rule(conjunct1_rule(unit_components))); + ACCEPT_TAC( + unit_parts[1], + sym_rule(conjunct2_rule(unit_components))); + + term owned_frame_eq_tm = gnode_get_asmps( + frame_cases[1], + CONST_STRING_LIST("Hframe"))[0]; + thm owned_components = rewrite_rule( + THM_LIST( + assume_rule(owned_frame_eq_tm), + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_own_def, + get_datatype_injectivity("frac")), + assume_rule(` + frac_own (q:real) (b:A) == + ra_op + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + (frame:(A)frac) + `)); + thm owned_weight_value_eq = ap_term_rule( + `frac_weight_value:frac_weight->real`, + conjunct1_rule(owned_components)); + owned_weight_value_eq = pure_rewrite_rule( + THM_LIST( + frac_weight_add_value, + p_value, + q_value), + owned_weight_value_eq); + thm strict_weight = mp_rule( + mp_rule( + real_arith_rule(` + &0 < frac_weight_value (a0:frac_weight) ==> + (q:real) == + p + frac_weight_value a0 ==> + p < q + `), + ispec_rule( + `a0:frac_weight`, + frac_weight_value_pos)), + owned_weight_value_eq); + gnode owned_result = DISJ2_TAC(frame_cases[1]); + gnode_list owned_parts = CONJ_TAC(owned_result); + ACCEPT_TAC(owned_parts[0], strict_weight); + gnode base_included = CONV_TAC( + owned_parts[1], + once_rewrite_conv(THM_LIST(ra_included_def))); + base_included = EXISTS_TAC(base_included, `a1:A`); + ACCEPT_TAC( + base_included, + conjunct2_rule(owned_components)); + + gnode reverse = DISCH_TAC(directions[1], "Hcases"); + gnode_list cases = ASMP_DISJ_TAC( + reverse, + "Hcases", + "Hequal", + "Hstrict"); + + gnode equal_case = ASMP_CONJ_TAC( + cases[0], + "Hequal", + "Hweight_eq", + "Hpayload_eq"); + thm equal_components = conj_rule( + assume_rule(`(p:real) == (q:real)`), + assume_rule(`(a:A) == (b:A)`)); + thm token_eq = eq_mp_rule( + sym_rule(mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `p:real`, `q:real`, `a:A`, `b:A`), + frac_ra_own_inj), + assume_rule(`&0 < (p:real)`)), + assume_rule(`&0 < (q:real)`))), + equal_components); + thm equal_refl = ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `frac_own (p:real) (a:A)`), + ra_included_refl); + thm equal_transport = beta_rule(ap_term_rule( + `\x:(A)frac. + ra_included + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + x`, + token_eq)); + ACCEPT_TAC( + equal_case, + eq_mp_rule(equal_transport, equal_refl)); + + gnode strict_case = ASMP_CONJ_TAC( + cases[1], + "Hstrict", + "Hweight_lt", + "Hbase_included"); + thm base_extension = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included (R:(A)ra) (a:A) (b:A) + `)); + strict_case = ASSUME_TAC( + strict_case, base_extension, "Hbase_extension"); + strict_case = ASMP_EXISTS_TAC( + strict_case, "Hbase_extension", "base_frame"); + gnode frac_extension = CONV_TAC( + strict_case, + once_rewrite_conv(THM_LIST(ra_included_def))); + frac_extension = EXISTS_TAC( + frac_extension, + `frac_own ((q:real) - p) (base_frame:A)`); + thm delta_pos = mp_rule( + real_arith_rule(` + (p:real) < q ==> &0 < q - p + `), + assume_rule(`(p:real) < (q:real)`)); + thm composition = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `p:real`, + `(q:real) - p`, + `a:A`, + `base_frame:A`), + frac_ra_own_op), + assume_rule(`&0 < (p:real)`)), + delta_pos); + thm payload_lift = beta_rule(ap_term_rule( + `\x:A. frac_own (q:real) x`, + assume_rule(` + (b:A) == + ra_op (R:(A)ra) (a:A) (base_frame:A) + `))); + thm weight_eq = mp_rule( + real_arith_rule(` + (p:real) < q ==> q == p + (q - p) + `), + assume_rule(`(p:real) < (q:real)`)); + thm weight_lift = beta_rule(ap_term_rule( + `\r:real. + frac_own + r + (ra_op (R:(A)ra) (a:A) (base_frame:A))`, + weight_eq)); + ACCEPT_TAC( + frac_extension, + trans_rule( + payload_lift, + trans_rule( + weight_lift, + sym_rule(composition)))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_included_own = + prove_frac_ra_included_own(); + +PROOF static thm prove_frac_ra_not_included_own_empty(void) { + term goal_tm = ` + forall (R:(A)ra) (p:real) (a:A). + &0 < p ==> + ~(ra_included + (frac_ra R) + (frac_own p a) + frac_empty) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + frac_empty + `)); + body = ASSUME_TAC(body, included, "Hextension"); + body = ASMP_EXISTS_TAC(body, "Hextension", "frame"); + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)frac`, "Hframe"); + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + term frame_eq_tm = gnode_get_asmps( + frame_cases[i], + CONST_STRING_LIST("Hframe"))[0]; + thm contradiction = rewrite_rule( + THM_LIST( + assume_rule(frame_eq_tm), + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_empty_def, + frac_own_def, + get_datatype_distinctness("frac")), + assume_rule(` + (frac_empty:(A)frac) == + ra_op + (frac_ra (R:(A)ra)) + (frac_own (p:real) (a:A)) + (frame:(A)frac) + `)); + CONTR_TAC(frame_cases[i], contradiction); + } + return gnode_prove(root); +} + +PROOF static thm frac_ra_not_included_own_empty = + prove_frac_ra_not_included_own_empty(); + +PROOF static thm prove_frac_ra_included_full(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included + (frac_ra R) + (frac_full a) + (frac_full b) <=> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm included = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `&1:real`, + `&1:real`, + `a:A`, + `b:A`), + frac_ra_included_own), + get_theorem_by_name("REAL_LT_01")), + get_theorem_by_name("REAL_LT_01")); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + frac_full_def, + included, + real_arith_rule(`~((&1:real) < &1)`)))); + return gnode_prove(root); +} + +PROOF static thm frac_ra_included_full = + prove_frac_ra_included_full(); + +/* ------------------------------------------------------------------------- */ +/* Frame-maximal elements */ +/* ------------------------------------------------------------------------- */ + +/* + * A full token already contributes weight one. A unit frame is therefore + * the only compatible frame: every owned frame contributes a strictly + * positive weight and would make the combined weight exceed one. + */ +PROOF static thm prove_frac_ra_maximal_full(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_valid R a ==> + ra_maximal + (frac_ra R) + (frac_full a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + body = AUTO_INTROS_TAC(body); + gnode_list maximal_parts = CONJ_TAC(body); + + thm full_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + frac_ra_valid_full)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + ACCEPT_TAC(maximal_parts[0], full_valid); + + gnode frames = AUTO_INTROS_TAC(maximal_parts[1]); + gnode_list frame_cases = CASES_TAC( + frames, `frame:(A)frac`, NULL); + + thm frame_is_unit = assume_rule(` + (frame:(A)frac) == FracUnit + `); + thm ra_unit_is_unit = spec_rule( + `R:(A)ra`, + frac_ra_unit_raw); + ACCEPT_TAC( + frame_cases[0], + trans_rule( + frame_is_unit, + sym_rule(ra_unit_is_unit))); + + thm one_value = mp_rule( + ispec_rule( + `&1:real`, + frac_weight_of_real_value), + get_theorem_by_name("REAL_LT_01")); + thm source_valid = rewrite_rule( + THM_LIST( + assume_rule(` + (frame:(A)frac) == Frac a0 a1 + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_full_def, + frac_own_def, + frac_weight_add_value, + one_value), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_full (a:A)) + (frame:(A)frac)) + `)); + thm frame_pos = ispec_rule( + `a0:frac_weight`, + frac_weight_value_pos); + thm impossible = mp_rule( + mp_rule( + real_arith_rule(` + &0 < frac_weight_value (a0:frac_weight) ==> + &1 + frac_weight_value a0 <= &1 ==> + F + `), + frame_pos), + conjunct1_rule(source_valid)); + CONTR_TAC(frame_cases[1], impossible); + return gnode_prove(root); +} + +PROOF thm frac_ra_maximal_full = + prove_frac_ra_maximal_full(); + +/* ------------------------------------------------------------------------- */ +/* Optional algebraic properties */ +/* ------------------------------------------------------------------------- */ + +/* + * Positive weights make cancellation of an owned fractional frame possible: + * mixed unit/owned targets would force a positive added weight to be zero, + * while two owned targets reduce to weight cancellation and cancellativity of + * the base payload operation. + */ +PROOF static thm prove_frac_ra_cancellative(void) { + term goal_tm = ` + forall R:(A)ra. + ra_cancellative R ==> + ra_cancellative (frac_ra R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = AUTO_INTROS_TAC(body); + + thm frac_injective = + get_datatype_injectivity("frac"); + term weight_value_fn = ` + frac_weight_value:frac_weight->real + `; + thm positive_not_zero = real_arith_rule(` + forall z:real. + &0 < z ==> + z == &0 ==> + F + `); + + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)frac`, "Hframe"); + + thm frame_unit_eq = assume_rule( + gnode_get_asmps( + frame_cases[0], + CONST_STRING_LIST("Hframe"))[0]); + thm unit_combination_eq = rewrite_rule( + THM_LIST( + frame_unit_eq, + frac_ra_op_fn, + frac_op_def), + assume_rule(` + ra_op + (frac_ra (R:(A)ra)) + (frame:(A)frac) + (a:(A)frac) == + ra_op + (frac_ra R) + frame + (b:(A)frac) + `)); + ACCEPT_TAC( + frame_cases[0], + unit_combination_eq); + + term frame_eq_tm = gnode_get_asmps( + frame_cases[1], + CONST_STRING_LIST("Hframe"))[0]; + thm frame_owned_eq = assume_rule(frame_eq_tm); + term frame_owned_tm = dest_eq(frame_eq_tm).tm2; + term frame_weight = dest_comb( + dest_comb(frame_owned_tm).tm1).tm2; + term frame_payload = dest_comb(frame_owned_tm).tm2; + term frame_value = mk_comb( + weight_value_fn, frame_weight); + + gnode_list left_cases = CASES_TAC( + frame_cases[1], `a:(A)frac`, "Hleft"); + + gnode_list unit_left_right_cases = CASES_TAC( + left_cases[0], `b:(A)frac`, "Hright"); + + thm unit_left_eq = assume_rule( + gnode_get_asmps( + unit_left_right_cases[0], + CONST_STRING_LIST("Hleft"))[0]); + thm unit_right_eq = assume_rule( + gnode_get_asmps( + unit_left_right_cases[0], + CONST_STRING_LIST("Hright"))[0]); + ACCEPT_TAC( + unit_left_right_cases[0], + trans_rule( + unit_left_eq, + sym_rule(unit_right_eq))); + + term unit_owned_right_eq_tm = gnode_get_asmps( + unit_left_right_cases[1], + CONST_STRING_LIST("Hright"))[0]; + thm unit_owned_left_eq = assume_rule( + gnode_get_asmps( + unit_left_right_cases[1], + CONST_STRING_LIST("Hleft"))[0]); + thm unit_owned_right_eq = assume_rule( + unit_owned_right_eq_tm); + term unit_owned_right_tm = + dest_eq(unit_owned_right_eq_tm).tm2; + term unit_owned_right_weight = dest_comb( + dest_comb(unit_owned_right_tm).tm1).tm2; + term unit_owned_right_value = mk_comb( + weight_value_fn, + unit_owned_right_weight); + thm unit_owned_combination = rewrite_rule( + THM_LIST( + frame_owned_eq, + unit_owned_left_eq, + unit_owned_right_eq, + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_injective), + assume_rule(` + ra_op + (frac_ra (R:(A)ra)) + (frame:(A)frac) + (a:(A)frac) == + ra_op + (frac_ra R) + frame + (b:(A)frac) + `)); + thm unit_owned_weight_eq = ap_term_rule( + weight_value_fn, + conjunct1_rule(unit_owned_combination)); + unit_owned_weight_eq = pure_rewrite_rule( + THM_LIST(frac_weight_add_value), + unit_owned_weight_eq); + unit_owned_weight_eq = sym_rule( + unit_owned_weight_eq); + thm unit_owned_zero = eq_mp_rule( + ispecl_rule( + TERM_LIST( + frame_value, + unit_owned_right_value), + get_theorem_by_name( + "REAL_EQ_ADD_LCANCEL_0")), + unit_owned_weight_eq); + thm unit_owned_impossible = mp_rule( + mp_rule( + spec_rule( + unit_owned_right_value, + positive_not_zero), + ispec_rule( + unit_owned_right_weight, + frac_weight_value_pos)), + unit_owned_zero); + CONTR_TAC( + unit_left_right_cases[1], + unit_owned_impossible); + + term owned_left_eq_tm = gnode_get_asmps( + left_cases[1], + CONST_STRING_LIST("Hleft"))[0]; + term owned_left_tm = dest_eq(owned_left_eq_tm).tm2; + term owned_left_weight = dest_comb( + dest_comb(owned_left_tm).tm1).tm2; + term owned_left_payload = dest_comb(owned_left_tm).tm2; + term owned_left_value = mk_comb( + weight_value_fn, + owned_left_weight); + gnode_list owned_left_right_cases = CASES_TAC( + left_cases[1], `b:(A)frac`, "Hright"); + + thm owned_unit_left_eq = assume_rule( + gnode_get_asmps( + owned_left_right_cases[0], + CONST_STRING_LIST("Hleft"))[0]); + thm owned_unit_right_eq = assume_rule( + gnode_get_asmps( + owned_left_right_cases[0], + CONST_STRING_LIST("Hright"))[0]); + thm owned_unit_combination = rewrite_rule( + THM_LIST( + frame_owned_eq, + owned_unit_left_eq, + owned_unit_right_eq, + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_injective), + assume_rule(` + ra_op + (frac_ra (R:(A)ra)) + (frame:(A)frac) + (a:(A)frac) == + ra_op + (frac_ra R) + frame + (b:(A)frac) + `)); + thm owned_unit_weight_eq = ap_term_rule( + weight_value_fn, + conjunct1_rule(owned_unit_combination)); + owned_unit_weight_eq = pure_rewrite_rule( + THM_LIST(frac_weight_add_value), + owned_unit_weight_eq); + thm owned_unit_zero = eq_mp_rule( + ispecl_rule( + TERM_LIST( + frame_value, + owned_left_value), + get_theorem_by_name( + "REAL_EQ_ADD_LCANCEL_0")), + owned_unit_weight_eq); + thm owned_unit_impossible = mp_rule( + mp_rule( + spec_rule( + owned_left_value, + positive_not_zero), + ispec_rule( + owned_left_weight, + frac_weight_value_pos)), + owned_unit_zero); + CONTR_TAC( + owned_left_right_cases[0], + owned_unit_impossible); + + term owned_right_eq_tm = gnode_get_asmps( + owned_left_right_cases[1], + CONST_STRING_LIST("Hright"))[0]; + thm owned_owned_left_eq = assume_rule( + gnode_get_asmps( + owned_left_right_cases[1], + CONST_STRING_LIST("Hleft"))[0]); + thm owned_owned_right_eq = assume_rule( + owned_right_eq_tm); + term owned_right_tm = dest_eq(owned_right_eq_tm).tm2; + term owned_right_weight = dest_comb( + dest_comb(owned_right_tm).tm1).tm2; + term owned_right_payload = dest_comb(owned_right_tm).tm2; + term owned_right_value = mk_comb( + weight_value_fn, + owned_right_weight); + + thm owned_owned_combination = rewrite_rule( + THM_LIST( + frame_owned_eq, + owned_owned_left_eq, + owned_owned_right_eq, + frac_ra_op_fn, + frac_op_def, + frac_token_op_def, + frac_injective), + assume_rule(` + ra_op + (frac_ra (R:(A)ra)) + (frame:(A)frac) + (a:(A)frac) == + ra_op + (frac_ra R) + frame + (b:(A)frac) + `)); + thm owned_owned_weight_value_eq = ap_term_rule( + weight_value_fn, + conjunct1_rule(owned_owned_combination)); + owned_owned_weight_value_eq = pure_rewrite_rule( + THM_LIST(frac_weight_add_value), + owned_owned_weight_value_eq); + thm owned_owned_value_eq = eq_mp_rule( + ispecl_rule( + TERM_LIST( + frame_value, + owned_left_value, + owned_right_value), + get_theorem_by_name( + "REAL_EQ_ADD_LCANCEL")), + owned_owned_weight_value_eq); + thm owned_owned_weight_eq = eq_mp_rule( + sym_rule(ispecl_rule( + TERM_LIST( + owned_left_weight, + owned_right_weight), + frac_weight_eq)), + owned_owned_value_eq); + + thm source_owned_valid = rewrite_rule( + THM_LIST( + frame_owned_eq, + owned_owned_left_eq, + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frame:(A)frac) + (a:(A)frac)) + `)); + thm owned_owned_payload_eq = mp_rule( + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + frame_payload, + owned_left_payload, + owned_right_payload), + ra_cancellative_apply), + assume_rule(` + ra_cancellative (R:(A)ra) + `)), + conjunct2_rule(source_owned_valid)), + conjunct2_rule(owned_owned_combination)); + gnode owned_owned_goal = CONV_TAC( + owned_left_right_cases[1], + rewrite_conv(THM_LIST( + owned_owned_left_eq, + owned_owned_right_eq, + frac_injective))); + ACCEPT_TAC( + owned_owned_goal, + conj_rule( + owned_owned_weight_eq, + owned_owned_payload_eq)); + return gnode_prove(root); +} + +PROOF static thm frac_ra_cancellative = + prove_frac_ra_cancellative(); + +/* ------------------------------------------------------------------------- */ +/* Weight weakening and lifted payload updates */ +/* ------------------------------------------------------------------------- */ + +/* + * Lowering the positive weight can only make each source-compatible frame + * satisfy a weaker weight bound. Payload compatibility is preserved by the + * base frame-preserving update at the payload carried by that same frame. + */ +PROOF static thm prove_frac_ra_update_weaken(void) { + term goal_tm = ` + forall + (R:(A)ra) + (p:real) + (q:real) + (a:A) + (b:A). + &0 < q ==> + q <= p ==> + ra_update R a b ==> + ra_update + (frac_ra R) + (frac_own p a) + (frac_own q b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm p_pos = mp_rule( + ispecl_rule( + TERM_LIST( + `&0:real`, + `q:real`, + `p:real`), + get_theorem_by_name("REAL_LTE_TRANS")), + conj_rule( + assume_rule(`&0 < (q:real)`), + assume_rule(`(q:real) <= (p:real)`))); + thm p_value = mp_rule( + ispec_rule( + `p:real`, + frac_weight_of_real_value), + p_pos); + thm q_value = mp_rule( + ispec_rule( + `q:real`, + frac_weight_of_real_value), + assume_rule(`&0 < (q:real)`)); + + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + ra_update_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)frac`, NULL); + + thm source_unit = rewrite_rule( + THM_LIST( + assume_rule(` + (frame:(A)frac) == FracUnit + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + p_value), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_own (p:real) (a:A)) + (frame:(A)frac)) + `)); + thm target_unit_payload = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`), + ra_update_valid), + assume_rule(` + ra_update (R:(A)ra) (a:A) (b:A) + `)), + conjunct2_rule(source_unit)); + thm target_unit_weight = mp_rule( + ispecl_rule( + TERM_LIST( + `q:real`, + `p:real`, + `&1:real`), + get_theorem_by_name("REAL_LE_TRANS")), + conj_rule( + assume_rule(`(q:real) <= (p:real)`), + conjunct1_rule(source_unit))); + gnode unit_result = EXISTS_TAC( + frame_cases[0], `frac_own (q:real) (b:A)`); + gnode_list unit_parts = CONJ_TAC(unit_result); + ACCEPT_TAC( + unit_parts[0], + refl_rule(`frac_own (q:real) (b:A)`)); + gnode target_unit = CONV_TAC( + unit_parts[1], + rewrite_conv(THM_LIST( + assume_rule(` + (frame:(A)frac) == FracUnit + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + q_value))); + ACCEPT_TAC( + target_unit, + conj_rule( + target_unit_weight, + target_unit_payload)); + + thm source_owned = rewrite_rule( + THM_LIST( + assume_rule(` + (frame:(A)frac) == Frac a0 a1 + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + frac_weight_add_value, + p_value), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_own (p:real) (a:A)) + (frame:(A)frac)) + `)); + thm target_owned_payload = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`, + `a1:A`), + ra_update_apply), + assume_rule(` + ra_update (R:(A)ra) (a:A) (b:A) + `)), + conjunct2_rule(source_owned)); + thm weakened_sum = eq_mp_rule( + sym_rule(ispecl_rule( + TERM_LIST( + `q:real`, + `p:real`, + `frac_weight_value (a0:frac_weight)`), + get_theorem_by_name("REAL_LE_RADD"))), + assume_rule(`(q:real) <= (p:real)`)); + thm target_owned_weight = mp_rule( + ispecl_rule( + TERM_LIST( + `(q:real) + frac_weight_value (a0:frac_weight)`, + `(p:real) + frac_weight_value (a0:frac_weight)`, + `&1:real`), + get_theorem_by_name("REAL_LE_TRANS")), + conj_rule( + weakened_sum, + conjunct1_rule(source_owned))); + gnode owned_result = EXISTS_TAC( + frame_cases[1], `frac_own (q:real) (b:A)`); + gnode_list owned_parts = CONJ_TAC(owned_result); + ACCEPT_TAC( + owned_parts[0], + refl_rule(`frac_own (q:real) (b:A)`)); + gnode target_owned = CONV_TAC( + owned_parts[1], + rewrite_conv(THM_LIST( + assume_rule(` + (frame:(A)frac) == Frac a0 a1 + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + frac_weight_add_value, + q_value))); + ACCEPT_TAC( + target_owned, + conj_rule( + target_owned_weight, + target_owned_payload)); + return gnode_prove(root); +} + +PROOF thm frac_ra_update_weaken = + prove_frac_ra_update_weaken(); + +/* + * The predicate-update rule selects a base result separately for each source-compatible + * fractional frame, while exposing only the exact fixed-weight image of P. + */ +PROOF static thm prove_frac_ra_updateP_weaken(void) { + term goal_tm = ` + forall + (R:(A)ra) + (p:real) + (q:real) + (a:A) + (P:A->bool). + &0 < q ==> + q <= p ==> + ra_updateP R a P ==> + ra_updateP + (frac_ra R) + (frac_own p a) + (\x:(A)frac. + exists b:A. + P b && x == frac_own q b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm p_pos = mp_rule( + ispecl_rule( + TERM_LIST( + `&0:real`, + `q:real`, + `p:real`), + get_theorem_by_name("REAL_LTE_TRANS")), + conj_rule( + assume_rule(`&0 < (q:real)`), + assume_rule(`(q:real) <= (p:real)`))); + thm p_value = mp_rule( + ispec_rule( + `p:real`, + frac_weight_of_real_value), + p_pos); + thm q_value = mp_rule( + ispec_rule( + `q:real`, + frac_weight_of_real_value), + assume_rule(`&0 < (q:real)`)); + + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + gnode_list frame_cases = CASES_TAC( + body, `frame:(A)frac`, NULL); + + thm source_unit = rewrite_rule( + THM_LIST( + assume_rule(` + (frame:(A)frac) == FracUnit + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + p_value), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_own (p:real) (a:A)) + (frame:(A)frac)) + `)); + thm selected_unit = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `P:A->bool`), + ra_updateP_valid), + assume_rule(` + ra_updateP + (R:(A)ra) + (a:A) + (P:A->bool) + `)), + conjunct2_rule(source_unit)); + gnode unit_branch = ASSUME_TAC( + frame_cases[0], selected_unit, "Hselected"); + unit_branch = ASMP_EXISTS_TAC( + unit_branch, "Hselected", "b"); + unit_branch = ASMP_CONJ_TAC( + unit_branch, + "Hselected", + "HP_b", + "Hb_valid"); + unit_branch = EXISTS_TAC( + unit_branch, `frac_own (q:real) (b:A)`); + gnode_list unit_result = CONJ_TAC(unit_branch); + gnode unit_predicate = EXISTS_TAC( + unit_result[0], `b:A`); + gnode_list unit_predicate_parts = CONJ_TAC( + unit_predicate); + ACCEPT_TAC( + unit_predicate_parts[0], + assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC( + unit_predicate_parts[1], + refl_rule(`frac_own (q:real) (b:A)`)); + + thm target_unit_weight = mp_rule( + ispecl_rule( + TERM_LIST( + `q:real`, + `p:real`, + `&1:real`), + get_theorem_by_name("REAL_LE_TRANS")), + conj_rule( + assume_rule(`(q:real) <= (p:real)`), + conjunct1_rule(source_unit))); + gnode target_unit = CONV_TAC( + unit_result[1], + rewrite_conv(THM_LIST( + assume_rule(` + (frame:(A)frac) == FracUnit + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + q_value))); + ACCEPT_TAC( + target_unit, + conj_rule( + target_unit_weight, + assume_rule(`ra_valid (R:(A)ra) (b:A)`))); + + thm source_owned = rewrite_rule( + THM_LIST( + assume_rule(` + (frame:(A)frac) == Frac a0 a1 + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + frac_weight_add_value, + p_value), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_own (p:real) (a:A)) + (frame:(A)frac)) + `)); + thm base_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(` + ra_updateP + (R:(A)ra) + (a:A) + (P:A->bool) + `)); + thm selected_owned = mp_rule( + spec_rule(`a1:A`, base_update), + conjunct2_rule(source_owned)); + gnode owned_branch = ASSUME_TAC( + frame_cases[1], selected_owned, "Hselected"); + owned_branch = ASMP_EXISTS_TAC( + owned_branch, "Hselected", "b"); + owned_branch = ASMP_CONJ_TAC( + owned_branch, + "Hselected", + "HP_b", + "Hb_valid"); + owned_branch = EXISTS_TAC( + owned_branch, `frac_own (q:real) (b:A)`); + gnode_list owned_result = CONJ_TAC(owned_branch); + gnode owned_predicate = EXISTS_TAC( + owned_result[0], `b:A`); + gnode_list owned_predicate_parts = CONJ_TAC( + owned_predicate); + ACCEPT_TAC( + owned_predicate_parts[0], + assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC( + owned_predicate_parts[1], + refl_rule(`frac_own (q:real) (b:A)`)); + + thm weakened_sum = eq_mp_rule( + sym_rule(ispecl_rule( + TERM_LIST( + `q:real`, + `p:real`, + `frac_weight_value (a0:frac_weight)`), + get_theorem_by_name("REAL_LE_RADD"))), + assume_rule(`(q:real) <= (p:real)`)); + thm target_owned_weight = mp_rule( + ispecl_rule( + TERM_LIST( + `(q:real) + frac_weight_value (a0:frac_weight)`, + `(p:real) + frac_weight_value (a0:frac_weight)`, + `&1:real`), + get_theorem_by_name("REAL_LE_TRANS")), + conj_rule( + weakened_sum, + conjunct1_rule(source_owned))); + gnode target_owned = CONV_TAC( + owned_result[1], + rewrite_conv(THM_LIST( + assume_rule(` + (frame:(A)frac) == Frac a0 a1 + `), + frac_ra_op_fn, + frac_ra_valid_fn, + frac_op_def, + frac_token_op_def, + frac_valid_def, + frac_own_def, + frac_weight_add_value, + q_value))); + ACCEPT_TAC( + target_owned, + conj_rule( + target_owned_weight, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (b:A) (a1:A)) + `))); + return gnode_prove(root); +} + +PROOF thm frac_ra_updateP_weaken = + prove_frac_ra_updateP_weaken(); + +PROOF static thm prove_frac_ra_update_full_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + (ra_update + (frac_ra R) + (frac_full a) + (frac_full b) <=> + (ra_valid R a ==> ra_valid R b)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + forward = DISCH_TAC(forward, "Hsource_valid"); + thm source_full_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + frac_ra_valid_full)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + thm target_full_valid = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `frac_full (a:A)`, + `frac_full (b:A)`), + ra_update_valid), + assume_rule(` + ra_update + (frac_ra (R:(A)ra)) + (frac_full (a:A)) + (frac_full (b:A)) + `)), + source_full_valid); + ACCEPT_TAC( + forward, + eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`), + frac_ra_valid_full), + target_full_valid)); + + gnode reverse = DISCH_TAC(directions[1], "Hvalid"); + reverse = CONV_TAC( + reverse, + pure_rewrite_conv(THM_LIST( + ra_update_def, + ra_updateP_def))); + reverse = CONV_TAC( + reverse, + depth_conv(get_conversion_by_name("BETA_CONV"))); + reverse = AUTO_INTROS_TAC(reverse); + + thm source_parts = mp_rule( + ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `frac_full (a:A)`, + `frame:(A)frac`), + ra_valid_op), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_full (a:A)) + (frame:(A)frac)) + `)); + thm source_base_valid = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + frac_ra_valid_full), + conjunct1_rule(source_parts)); + thm target_base_valid = mp_rule( + assume_rule(` + ra_valid (R:(A)ra) (a:A) ==> + ra_valid R (b:A) + `), + source_base_valid); + thm reverse_target_full_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`), + frac_ra_valid_full)), + target_base_valid); + + thm maximal = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + frac_ra_maximal_full), + source_base_valid); + thm frame_is_unit = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `frac_full (a:A)`, + `frame:(A)frac`), + ra_maximal_apply), + maximal), + assume_rule(` + ra_valid + (frac_ra (R:(A)ra)) + (ra_op + (frac_ra R) + (frac_full (a:A)) + (frame:(A)frac)) + `)); + + thm target_unit_eq = ispecl_rule( + TERM_LIST( + `frac_ra (R:(A)ra)`, + `frac_full (b:A)`), + ra_unit_r); + thm target_with_unit = eq_mp_rule( + gsym_rule(beta_rule(ap_term_rule( + `\x:(A)frac. + ra_valid (frac_ra (R:(A)ra)) x`, + target_unit_eq))), + reverse_target_full_valid); + thm target_frame_eq = beta_rule(ap_term_rule( + `\x:(A)frac. + ra_valid + (frac_ra (R:(A)ra)) + (ra_op (frac_ra R) (frac_full (b:A)) x)`, + frame_is_unit)); + thm target_with_frame = eq_mp_rule( + gsym_rule(target_frame_eq), + target_with_unit); + + reverse = EXISTS_TAC(reverse, `frac_full (b:A)`); + gnode_list result = CONJ_TAC(reverse); + ACCEPT_TAC(result[0], refl_rule(`frac_full (b:A)`)); + ACCEPT_TAC(result[1], target_with_frame); + return gnode_prove(root); +} + +PROOF thm frac_ra_update_full_iff = + prove_frac_ra_update_full_iff(); + +PROOF static int audit_frac_ra(void) { + thm_list audited_theorems = THM_LIST( + frac_weight_rep_exists, + frac_weight_type_bijection, + frac_weight_value_def, + frac_weight_of_real_def, + frac_weight_add_def, + frac_weight_value_pos, + frac_weight_of_real_value, + frac_weight_add_value, + frac_weight_eq, + frac_weight_add_assoc, + frac_weight_add_comm, + frac_weight_add_le_left, + frac_type.ind, + frac_type.rec, + frac_token_op_def, + frac_op_def, + frac_valid_def, + frac_op_assoc, + frac_op_comm, + frac_op_unit_l, + frac_valid_unit, + frac_valid_op_l, + frac_ra_laws, + frac_ra_def, + frac_ra_unit_raw, + frac_ra_op_fn, + frac_ra_valid_fn, + frac_empty_def, + frac_own_def, + frac_full_def, + frac_ra_unit, + frac_ra_full, + frac_ra_own_op, + frac_ra_own_inj, + frac_ra_own_ne_empty, + frac_ra_full_inj, + frac_ra_full_ne_empty, + frac_ra_valid_empty, + frac_ra_valid_own, + frac_ra_valid_full, + frac_ra_included_empty, + frac_ra_included_own, + frac_ra_not_included_own_empty, + frac_ra_included_full, + frac_ra_maximal_full, + frac_ra_cancellative, + frac_ra_update_weaken, + frac_ra_updateP_weaken, + frac_ra_update_full_iff); + + for (size_t i = 0; + i < vector_size(audited_theorems); + ++i) { + ENSURE_COND( + !IS_NULL(audited_theorems[i]), + "fractional RA theorem %zu is empty", + i); + ENSURE_COND( + vector_size(hyp(audited_theorems[i])) == 0, + "fractional RA theorem %zu has hypotheses", + i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == + FRAC_RA_AXIOMS_BEFORE, + "fractional RA introduced an axiom"); + ENSURE_COND( + get_tyconst_arity("frac_weight") == 0, + "frac_weight is not a monomorphic HOL type"); + ENSURE_COND( + get_tyconst_arity("frac") == 1, + "frac is not a unary HOL type constructor"); + return 0; +err: + ERR_FUN_PUTS("audit_frac_ra"); + return -1; +} + +PROOF static int _FRAC_RA_AUDIT = + audit_frac_ra(); diff --git a/theory/logic/frac_ra.h b/theory/logic/frac_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..65cf0675b0ec9752acc38bae832b03888a2d3840 --- /dev/null +++ b/theory/logic/frac_ra.h @@ -0,0 +1,113 @@ +#pragma once + +/* + * Public interface for the optional positive-fraction RA construction. + * + * `frac_ra R : ((A)frac)ra` contains an empty unit and positive-share tokens + * `frac_own p a`. Shares compose by addition while payloads compose in `R`; + * validity bounds the total share by one. This module is an optional extra, + * not part of the foundational RA construction dependency graph. + */ + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Constructors and composition */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R. ra_unit (frac_ra R) == frac_empty + * ``` + * + * 分数 RA 的 unit 是不持有份额或 payload 的 `frac_empty`。 + */ +PROOF extern thm frac_ra_unit; + +/* + * ```text + * forall a. frac_full a == frac_own (&1) a + * ``` + * + * payload `a` 的完整所有权 `frac_full a` 就是份额为 `1` 的 `frac_own`。 + */ +PROOF extern thm frac_ra_full; + +/* + * ```text + * forall R p q a b. + * &0 < p + * ==> &0 < q + * ==> ra_op (frac_ra R) (frac_own p a) (frac_own q b) == + * frac_own (p + q) (ra_op R a b) + * ``` + * + * 对正份额 `p` 和 `q`，两个 `frac_own` 组合时份额相加，payload 则在底层 `R` 中组合。 + */ +PROOF extern thm frac_ra_own_op; + +/* ------------------------------------------------------------------------- */ +/* Validity and maximality */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R p a. + * &0 < p + * ==> (ra_valid (frac_ra R) (frac_own p a) <=> p <= &1 && ra_valid R a) + * ``` + * + * 对正份额 `p`，`frac_own p a` 有效，当且仅当 `p <= 1` 且 payload `a` 在底层 `R` 中有效。 + */ +PROOF extern thm frac_ra_valid_own; + +/* + * ```text + * forall R a. ra_valid R a ==> ra_maximal (frac_ra R) (frac_full a) + * ``` + * + * 当 payload `a` 有效时，份额已达 `1` 的 `frac_full a` 为 maximal，不能再兼容非空份额。 + */ +PROOF extern thm frac_ra_maximal_full; + +/* ------------------------------------------------------------------------- */ +/* Share and payload updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R p q a b. + * &0 < q + * ==> q <= p + * ==> ra_update R a b + * ==> ra_update (frac_ra R) (frac_own p a) (frac_own q b) + * ``` + * + * 若 `a -> b` 在底层 `R` 中成立，则可把份额 `p` 的 `a` 更新为份额不超过 `p` 的正份额 `q` 和 payload `b`。 + */ +PROOF extern thm frac_ra_update_weaken; + +/* + * ```text + * forall R p q a P. + * &0 < q + * ==> q <= p + * ==> ra_updateP R a P + * ==> ra_updateP (frac_ra R) (frac_own p a) + * (\x. exists b. P b && x == frac_own q b) + * ``` + * + * 若 `a` 在底层 `R` 中可更新到 `P`，则可将份额 `p` 弱化为不超过它的正份额 `q`，并选择满足 `P` 的目标 payload。 + */ +PROOF extern thm frac_ra_updateP_weaken; + +/* + * ```text + * forall R a b. + * ra_update (frac_ra R) (frac_full a) (frac_full b) <=> + * ra_valid R a ==> ra_valid R b + * ``` + * + * `frac_full a` 可更新为 `frac_full b`，当且仅当 `ra_valid R a ==> ra_valid R b`；源无效时条件真空成立。 + */ +PROOF extern thm frac_ra_update_full_iff; diff --git a/theory/logic/gmap_ra.c b/theory/logic/gmap_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..bd53ff34a3acac0fca61b229f1d981f28de047f2 --- /dev/null +++ b/theory/logic/gmap_ra.c @@ -0,0 +1,3186 @@ +#include "proof/theory/logic/gmap_ra.h" +#include "proof/theory/logic/option_ra_internal.h" +#include "proof/theory/logic/ra_builder.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/finmap.c" +#require "proof/theory/logic/option_ra.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t GMAP_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm gmap_raw_op_def = new_fun_definition(` + gmap_raw_op + (R:(V)ra) + (f:K->V option) + (g:K->V option) + (k:K) : V option = + ra_op (option_ra R) (f k) (g k) +`); + +PROOF static thm prove_gmap_raw_op_support(void) { + term goal_tm = ` + forall (R:(V)ra) (f:K->V option) (g:K->V option). + {k | ~(gmap_raw_op R f g k == NONE)} == + {k | ~(f k == NONE)} UNION {k | ~(g k == NONE)} + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "k"); + gnode_list f_cases = CASES_TAC( + body, `(f:K->V option) (k:K)`, NULL); + for (size_t i = 0; i < vector_size(f_cases); ++i) { + gnode_list g_cases = CASES_TAC( + f_cases[i], `(g:K->V option) (k:K)`, NULL); + for (size_t j = 0; j < vector_size(g_cases); ++j) { + CONV_WITH_ASMP_TAC( + g_cases[j], + rewrite_conv, + THM_LIST( + gmap_raw_op_def, + option_ra_op_none_l, + option_ra_op_none_r, + option_ra_op_some_some, + get_theorem_by_name("IN_ELIM_THM"), + get_theorem_by_name("IN_UNION"), + get_theorem_by_name("option_DISTINCT"))); + } + } + return gnode_prove(root); +} + +PROOF static thm gmap_raw_op_support = + prove_gmap_raw_op_support(); + +PROOF static thm prove_gmap_raw_op_finite(void) { + term goal_tm = ` + forall (R:(V)ra) (f:K->V option) (g:K->V option). + finmap_finite f ==> + finmap_finite g ==> + finmap_finite (gmap_raw_op R f g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(finmap_finite_def))); + body = AUTO_INTROS_TAC(body); + + term f_support = `{k:K | ~((f:K->V option) k == NONE)}`; + term g_support = `{k:K | ~((g:K->V option) k == NONE)}`; + thm union_finite = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(f_support, g_support), + get_theorem_by_name("FINITE_UNION"))), + conj_rule( + assume_rule(` + FINITE {k:K | ~((f:K->V option) k == NONE)} + `), + assume_rule(` + FINITE {k:K | ~((g:K->V option) k == NONE)} + `))); + thm support = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `f:K->V option`, + `g:K->V option`), + gmap_raw_op_support); + thm raw_finite = rewrite_rule( + THM_LIST(gsym_rule(support)), + union_finite); + ACCEPT_TAC(body, raw_finite); + return gnode_prove(root); +} + +PROOF static thm gmap_raw_op_finite = + prove_gmap_raw_op_finite(); + +PROOF static thm gmap_op_def = new_fun_definition(` + gmap_op + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap) : (K,V)finmap = + finmap_abs + (gmap_raw_op R (finmap_rep m) (finmap_rep n)) +`); + +PROOF static thm prove_gmap_op_rep(void) { + term R = `R:(V)ra`; + term m = `m:(K,V)finmap`; + term n = `n:(K,V)finmap`; + term raw = ` + gmap_raw_op + (R:(V)ra) + (finmap_rep (m:(K,V)finmap)) + (finmap_rep (n:(K,V)finmap)) + `; + thm finite = ispecl_rule( + TERM_LIST( + R, + `finmap_rep (m:(K,V)finmap)`, + `finmap_rep (n:(K,V)finmap)`), + gmap_raw_op_finite); + finite = mp_rule( + finite, + ispec_rule(m, finmap_rep_finite)); + finite = mp_rule( + finite, + ispec_rule(n, finmap_rep_finite)); + + thm inverse = ispec_rule( + raw, + conjunct2_rule(finmap_type_bijection)); + thm represented = eq_mp_rule(inverse, finite); + represented = pure_once_rewrite_rule( + THM_LIST(gsym_rule(gmap_op_def)), + represented); + represented = gen_rule(n, represented); + represented = gen_rule(m, represented); + return gen_rule(R, represented); +} + +PROOF static thm gmap_op_rep = + prove_gmap_op_rep(); + +PROOF static thm prove_gmap_op_lookup(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap) + (k:K). + finmap_lookup (gmap_op R m n) k == + ra_op + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + finmap_lookup_def, + gmap_op_rep, + gmap_raw_op_def))); + return gnode_prove(root); +} + +PROOF static thm gmap_op_lookup = + prove_gmap_op_lookup(); + +PROOF static thm gmap_valid_def = new_fun_definition(` + gmap_valid + (R:(V)ra) + (m:(K,V)finmap) <=> + forall k:K. + ra_valid (option_ra R) (finmap_lookup m k) +`); + +PROOF static thm prove_gmap_op_assoc(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap) + (p:(K,V)finmap). + gmap_op R (gmap_op R m n) p == + gmap_op R m (gmap_op R n p) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "k"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(gmap_op_lookup))); + ACCEPT_TAC( + body, + ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `finmap_lookup (m:(K,V)finmap) (k:K)`, + `finmap_lookup (n:(K,V)finmap) (k:K)`, + `finmap_lookup (p:(K,V)finmap) (k:K)`), + ra_assoc)); + return gnode_prove(root); +} + +PROOF static thm gmap_op_assoc = + prove_gmap_op_assoc(); + +PROOF static thm prove_gmap_op_comm(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + gmap_op R m n == gmap_op R n m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "k"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(gmap_op_lookup))); + ACCEPT_TAC( + body, + ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `finmap_lookup (m:(K,V)finmap) (k:K)`, + `finmap_lookup (n:(K,V)finmap) (k:K)`), + ra_comm)); + return gnode_prove(root); +} + +PROOF static thm gmap_op_comm = + prove_gmap_op_comm(); + +PROOF static thm prove_gmap_op_unit_l(void) { + term goal_tm = ` + forall (R:(V)ra) (m:(K,V)finmap). + gmap_op R finmap_empty m == m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "k"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + gmap_op_lookup, + finmap_empty_lookup))); + thm unit = ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `finmap_lookup (m:(K,V)finmap) (k:K)`), + ra_unit_l); + unit = rewrite_rule( + THM_LIST(option_ra_unit), + unit); + ACCEPT_TAC(body, unit); + return gnode_prove(root); +} + +PROOF static thm gmap_op_unit_l = + prove_gmap_op_unit_l(); + +PROOF static thm prove_gmap_valid_empty(void) { + term goal_tm = ` + forall R:(V)ra. + gmap_valid R (finmap_empty:(K,V)finmap) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(gmap_valid_def))); + body = GEN_TAC(body, "k"); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + finmap_empty_lookup, + option_ra_valid_none))); + return gnode_prove(root); +} + +PROOF static thm gmap_valid_empty = + prove_gmap_valid_empty(); + +PROOF static thm prove_gmap_valid_op_l(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + gmap_valid R (gmap_op R m n) ==> + gmap_valid R m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(gmap_valid_def))); + body = AUTO_INTROS_TAC(body); + + thm source_valid = spec_rule( + `k:K`, + assume_rule(` + forall k:K. + ra_valid + (option_ra (R:(V)ra)) + (finmap_lookup + (gmap_op R + (m:(K,V)finmap) + (n:(K,V)finmap)) + k) + `)); + source_valid = rewrite_rule( + THM_LIST(gmap_op_lookup), + source_valid); + thm both_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `finmap_lookup (m:(K,V)finmap) (k:K)`, + `finmap_lookup (n:(K,V)finmap) (k:K)`), + ra_valid_op), + source_valid); + thm left_valid = conjunct1_rule(both_valid); + ACCEPT_TAC(body, left_valid); + return gnode_prove(root); +} + +PROOF static thm gmap_valid_op_l = + prove_gmap_valid_op_l(); + +PROOF static thm prove_gmap_ra_laws(void) { + term goal_tm = ` + forall R:(V)ra. + ra_laws + (finmap_empty:(K,V)finmap) + (gmap_op R) + (gmap_valid R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + gnode unfolded = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + ACCEPT_TAC( + law1[0], + spec_rule(`R:(V)ra`, gmap_op_assoc)); + + gnode_list law2 = CONJ_TAC(law1[1]); + ACCEPT_TAC( + law2[0], + spec_rule(`R:(V)ra`, gmap_op_comm)); + + gnode_list law3 = CONJ_TAC(law2[1]); + ACCEPT_TAC( + law3[0], + spec_rule(`R:(V)ra`, gmap_op_unit_l)); + + gnode_list law4 = CONJ_TAC(law3[1]); + ACCEPT_TAC( + law4[0], + spec_rule(`R:(V)ra`, gmap_valid_empty)); + ACCEPT_TAC( + law4[1], + spec_rule(`R:(V)ra`, gmap_valid_op_l)); + return gnode_prove(root); +} + +PROOF static thm gmap_ra_laws = + prove_gmap_ra_laws(); + +PROOF static thm gmap_ra_def = new_fun_definition(` + gmap_ra (R:(V)ra) : ((K,V)finmap)ra = + ra_abs + ((finmap_empty:(K,V)finmap), + ((gmap_op R: + (K,V)finmap->(K,V)finmap->(K,V)finmap), + (gmap_valid R:(K,V)finmap->bool))) +`); + +PROOF static thm prove_gmap_ra_unit(void) { + term R = `R:(V)ra`; + term empty = `finmap_empty:(K,V)finmap`; + term op = ` + gmap_op (R:(V)ra): + (K,V)finmap->(K,V)finmap->(K,V)finmap + `; + term valid = ` + gmap_valid (R:(V)ra):(K,V)finmap->bool + `; + thm laws = ispec_rule(R, gmap_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(empty, op, valid), + ra_unit_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(gmap_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF thm gmap_ra_unit = + prove_gmap_ra_unit(); + +PROOF static thm prove_gmap_ra_op_fn(void) { + term R = `R:(V)ra`; + term empty = `finmap_empty:(K,V)finmap`; + term op = ` + gmap_op (R:(V)ra): + (K,V)finmap->(K,V)finmap->(K,V)finmap + `; + term valid = ` + gmap_valid (R:(V)ra):(K,V)finmap->bool + `; + thm laws = ispec_rule(R, gmap_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(empty, op, valid), + ra_op_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(gmap_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm gmap_ra_op_fn = + prove_gmap_ra_op_fn(); + +PROOF static thm prove_gmap_ra_valid_fn(void) { + term R = `R:(V)ra`; + term empty = `finmap_empty:(K,V)finmap`; + term op = ` + gmap_op (R:(V)ra): + (K,V)finmap->(K,V)finmap->(K,V)finmap + `; + term valid = ` + gmap_valid (R:(V)ra):(K,V)finmap->bool + `; + thm laws = ispec_rule(R, gmap_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(empty, op, valid), + ra_valid_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(gmap_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm gmap_ra_valid_fn = + prove_gmap_ra_valid_fn(); + +PROOF static thm prove_gmap_ra_op_lookup(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap) + (k:K). + finmap_lookup (ra_op (gmap_ra R) m n) k == + ra_op + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + gmap_ra_op_fn, + gmap_op_lookup))); + return gnode_prove(root); +} + +PROOF thm gmap_ra_op_lookup = + prove_gmap_ra_op_lookup(); + +PROOF static thm prove_gmap_ra_op_insert_insert(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (b:V) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_op + (gmap_ra R) + (finmap_insert key a m) + (finmap_insert key b n) == + finmap_insert + key + (ra_op R a b) + (ra_op (gmap_ra R) m n) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + gmap_ra_op_lookup, + finmap_insert_lookup, + option_ra_op_some_some)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_op_insert_insert = + prove_gmap_ra_op_insert_insert(); + +PROOF static thm prove_gmap_ra_op_delete(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_op + (gmap_ra R) + (finmap_delete key m) + (finmap_delete key n) == + finmap_delete key (ra_op (gmap_ra R) m n) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + gmap_ra_op_lookup, + finmap_delete_lookup, + option_ra_op_none_l)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_op_delete = + prove_gmap_ra_op_delete(); + +PROOF static thm prove_gmap_ra_valid(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap). + ra_valid (gmap_ra R) m <=> + forall k:K. + ra_valid + (option_ra R) + (finmap_lookup m k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + gmap_ra_valid_fn, + gmap_valid_def))); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid = + prove_gmap_ra_valid(); + +/* + * Isolating one key partitions the pointwise validity obligation into the + * optional value at that key and all remaining keys. The reverse direction + * simply puts those two disjoint cases back together. + */ +PROOF static thm prove_gmap_ra_valid_lookup_delete(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (m:(K,V)finmap). + ra_valid (gmap_ra R) m <=> + ra_valid + (option_ra R) + (finmap_lookup m key) && + ra_valid + (gmap_ra R) + (finmap_delete key m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hm_valid"); + thm source_all = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`), + gmap_ra_valid), + assume_rule(`ra_valid (gmap_ra (R:(V)ra)) (m:(K,V)finmap)`)); + gnode_list forward_parts = CONJ_TAC(forward); + ACCEPT_TAC( + forward_parts[0], + spec_rule(`key:K`, source_all)); + + gnode deleted = CONV_TAC( + forward_parts[1], + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + deleted = GEN_TAC(deleted, "query"); + deleted = ASSUME_TAC( + deleted, + spec_rule(`query:K`, source_all), + "Hsource_at"); + gnode_list delete_cases = BOOL_CASES_TAC( + deleted, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(delete_cases); ++i) { + thm branch = i == 0 + ? assume_rule(`query:K == key`) + : assume_rule(`~(query:K == key)`); + gnode reduced_goal = CONV_TAC( + delete_cases[i], + rewrite_conv(THM_LIST( + branch, + finmap_delete_lookup))); + if (i == 0) { + ACCEPT_TAC( + reduced_goal, + ispec_rule(`R:(V)ra`, option_ra_valid_none)); + } else { + ACCEPT_TAC( + reduced_goal, + assume_rule(` + ra_valid + (option_ra (R:(V)ra)) + (finmap_lookup (m:(K,V)finmap) (query:K)) + `)); + } + } + + gnode reverse = DISCH_TAC(directions[1], "Hparts"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hparts", + "Hlookup_valid", + "Hdelete_valid"); + thm deleted_all = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `finmap_delete (key:K) (m:(K,V)finmap)`), + gmap_ra_valid), + assume_rule(` + ra_valid + (gmap_ra (R:(V)ra)) + (finmap_delete (key:K) (m:(K,V)finmap)) + `)); + reverse = CONV_TAC( + reverse, + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + reverse = GEN_TAC(reverse, "query"); + reverse = ASSUME_TAC( + reverse, + spec_rule(`query:K`, deleted_all), + "Hdelete_at"); + gnode_list restore_cases = BOOL_CASES_TAC( + reverse, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(restore_cases); ++i) { + thm branch = i == 0 + ? assume_rule(`query:K == key`) + : assume_rule(`~(query:K == key)`); + if (i == 0) { + gnode reduced_goal = CONV_TAC( + restore_cases[i], + rewrite_conv(THM_LIST(branch))); + ACCEPT_TAC( + reduced_goal, + assume_rule(` + ra_valid + (option_ra (R:(V)ra)) + (finmap_lookup (m:(K,V)finmap) (key:K)) + `)); + } else { + thm restored = rewrite_rule( + THM_LIST( + branch, + finmap_delete_lookup), + assume_rule(` + ra_valid + (option_ra (R:(V)ra)) + (finmap_lookup + (finmap_delete (key:K) (m:(K,V)finmap)) + (query:K)) + `)); + ACCEPT_TAC(restore_cases[i], restored); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_lookup_delete = + prove_gmap_ra_valid_lookup_delete(); + +PROOF static thm prove_gmap_ra_valid_delete_some(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + (ra_valid (gmap_ra R) m <=> + ra_valid R a && + ra_valid (gmap_ra R) (finmap_delete key m)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm split_validity = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `m:(K,V)finmap`), + gmap_ra_valid_lookup_delete); + split_validity = rewrite_rule( + THM_LIST( + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `), + option_ra_valid_some), + split_validity); + ACCEPT_TAC(body, split_validity); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_delete_some = + prove_gmap_ra_valid_delete_some(); + +PROOF static thm prove_gmap_ra_valid_lookup(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + ra_valid (gmap_ra R) m ==> + finmap_lookup m key == SOME a ==> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm payload_split = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_valid_delete_some), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)); + thm split_validity = eq_mp_rule( + payload_split, + assume_rule(`ra_valid (gmap_ra (R:(V)ra)) (m:(K,V)finmap)`)); + ACCEPT_TAC(body, conjunct1_rule(split_validity)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_lookup = + prove_gmap_ra_valid_lookup(); + +PROOF static thm prove_gmap_ra_valid_delete(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (m:(K,V)finmap). + ra_valid (gmap_ra R) m ==> + ra_valid (gmap_ra R) (finmap_delete key m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm split_validity = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `m:(K,V)finmap`), + gmap_ra_valid_lookup_delete), + assume_rule(`ra_valid (gmap_ra (R:(V)ra)) (m:(K,V)finmap)`)); + ACCEPT_TAC(body, conjunct2_rule(split_validity)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_delete = + prove_gmap_ra_valid_delete(); + +PROOF static thm prove_gmap_ra_valid_insert(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + ra_valid + (gmap_ra R) + (finmap_insert key a m) <=> + ra_valid R a && + ra_valid + (gmap_ra R) + (finmap_delete key m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm split_validity = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `finmap_insert (key:K) (a:V) (m:(K,V)finmap)`), + gmap_ra_valid_lookup_delete); + split_validity = rewrite_rule( + THM_LIST( + finmap_insert_lookup_eq, + option_ra_valid_some, + finmap_delete_insert), + split_validity); + ACCEPT_TAC(body, split_validity); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_insert = + prove_gmap_ra_valid_insert(); + +PROOF static thm prove_gmap_ra_valid_insert_of_valid(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + ra_valid R a ==> + ra_valid (gmap_ra R) m ==> + ra_valid + (gmap_ra R) + (finmap_insert key a m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm deleted_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `m:(K,V)finmap`), + gmap_ra_valid_delete), + assume_rule(`ra_valid (gmap_ra (R:(V)ra)) (m:(K,V)finmap)`)); + thm insert_characterization = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_valid_insert); + thm inserted_valid = eq_mp_rule( + gsym_rule(insert_characterization), + conj_rule( + assume_rule(`ra_valid (R:(V)ra) (a:V)`), + deleted_valid)); + ACCEPT_TAC(body, inserted_valid); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_insert_of_valid = + prove_gmap_ra_valid_insert_of_valid(); + +PROOF static thm prove_gmap_ra_valid_insert_fresh(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + finmap_lookup m key == NONE ==> + (ra_valid + (gmap_ra R) + (finmap_insert key a m) <=> + ra_valid R a && ra_valid (gmap_ra R) m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm delete_id = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_delete_id), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == NONE + `)); + thm insert_validity = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_valid_insert); + ACCEPT_TAC( + body, + rewrite_rule(THM_LIST(delete_id), insert_validity)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_insert_fresh = + prove_gmap_ra_valid_insert_fresh(); + +/* + * Two singletons at the same key compose to the singleton of the base + * composition. Map extensionality reduces the proof to the selected key and + * every other key, where the option operation computes directly. + */ +PROOF static thm prove_gmap_ra_singleton_op(void) { + term goal_tm = ` + forall (R:(V)ra) (key:K) (a:V) (b:V). + ra_op + (gmap_ra R) + (finmap_singleton key a) + (finmap_singleton key b) == + finmap_singleton key (ra_op R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l, + option_ra_op_some_some)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_singleton_op = + prove_gmap_ra_singleton_op(); + +/* An existing binding composes with a singleton frame only at that key. */ +PROOF static thm prove_gmap_ra_op_singleton_at(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (frame:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + ra_op + (gmap_ra R) + m + (finmap_singleton key frame) == + finmap_insert key (ra_op R a frame) m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + gmap_ra_op_lookup, + finmap_singleton_lookup, + finmap_insert_lookup, + option_ra_op_none_r, + option_ra_op_some_some)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_op_singleton_at = + prove_gmap_ra_op_singleton_at(); + +PROOF static thm prove_gmap_ra_singleton_op_fresh(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + finmap_lookup m key == NONE ==> + ra_op + (gmap_ra R) + (finmap_singleton key a) + m == + finmap_insert key a m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, NULL); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + gmap_ra_op_lookup, + finmap_singleton_lookup, + finmap_insert_lookup, + option_ra_op_none_l, + option_ra_op_none_r)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_singleton_op_fresh = + prove_gmap_ra_singleton_op_fresh(); + +PROOF static thm prove_gmap_ra_decompose(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + m == + ra_op + (gmap_ra R) + (finmap_singleton key a) + (finmap_delete key m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm restored = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `a:V`, + `m:(K,V)finmap`), + finmap_decompose), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)); + thm singleton_op = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `finmap_delete (key:K) (m:(K,V)finmap)`), + gmap_ra_singleton_op_fresh), + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_delete_lookup_eq)); + ACCEPT_TAC( + body, + trans_rule( + gsym_rule(restored), + gsym_rule(singleton_op))); + return gnode_prove(root); +} + +PROOF thm gmap_ra_decompose = + prove_gmap_ra_decompose(); + +/* The deleted remainder is always fresh at key, so recombining it with a + * singleton is exactly overwrite insertion into the original map. */ +PROOF static thm prove_gmap_ra_singleton_op_delete(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + ra_op + (gmap_ra R) + (finmap_singleton key a) + (finmap_delete key m) == + finmap_insert key a m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fresh_composition = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `finmap_delete (key:K) (m:(K,V)finmap)`), + gmap_ra_singleton_op_fresh), + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_delete_lookup_eq)); + thm restore_insertion = ispecl_rule( + TERM_LIST( + `key:K`, + `a:V`, + `m:(K,V)finmap`), + finmap_insert_delete); + ACCEPT_TAC( + body, + trans_rule(fresh_composition, restore_insertion)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_singleton_op_delete = + prove_gmap_ra_singleton_op_delete(); + +PROOF static thm prove_gmap_ra_dom_op(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + finmap_dom (ra_op (gmap_ra R) m n) == + finmap_dom m UNION finmap_dom n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("EXTENSION")))); + body = GEN_TAC(body, "query"); + gnode_list m_cases = CASES_TAC( + body, + `finmap_lookup (m:(K,V)finmap) (query:K)`, + "Hm"); + for (size_t i = 0; i < vector_size(m_cases); ++i) { + gnode_list n_cases = CASES_TAC( + m_cases[i], + `finmap_lookup (n:(K,V)finmap) (query:K)`, + "Hn"); + for (size_t j = 0; j < vector_size(n_cases); ++j) { + CONV_WITH_ASMP_TAC( + n_cases[j], + rewrite_conv, + THM_LIST( + finmap_in_dom, + get_theorem_by_name("IN_UNION"), + gmap_ra_op_lookup, + option_ra_op_none_l, + option_ra_op_none_r, + option_ra_op_some_some, + get_theorem_by_name("option_DISTINCT"))); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_dom_op = + prove_gmap_ra_dom_op(); + +/* + * Pointwise validity of a singleton has one nontrivial point. The selected + * key reduces to SOME payload validity and all other keys reduce to NONE. + */ +PROOF static thm prove_gmap_ra_valid_singleton(void) { + term goal_tm = ` + forall (R:(V)ra) (key:K) (a:V). + ra_valid (gmap_ra R) (finmap_singleton key a) <=> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hall"); + thm at_key = spec_rule( + `key:K`, + assume_rule(` + forall query:K. + ra_valid + (option_ra (R:(V)ra)) + (finmap_lookup + (finmap_singleton (key:K) (a:V)) + query) + `)); + at_key = rewrite_rule( + THM_LIST( + finmap_singleton_lookup, + option_ra_valid_some), + at_key); + ACCEPT_TAC(forward, at_key); + + gnode reverse = DISCH_TAC(directions[1], "Ha"); + reverse = GEN_TAC(reverse, "query"); + gnode_list cases = BOOL_CASES_TAC( + reverse, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + CONV_WITH_ASMP_TAC( + cases[i], + rewrite_conv, + THM_LIST( + finmap_singleton_lookup, + option_ra_valid_none, + option_ra_valid_some)); + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_valid_singleton = + prove_gmap_ra_valid_singleton(); + +/* ------------------------------------------------------------------------- */ +/* Inclusion */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm gmap_lookup_included_def = new_fun_definition(` + gmap_lookup_included + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap) <=> + forall k:K. + ra_included + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k) +`); + +/* A finite-map extension supplies one option-RA extension at every key. The + * pointwise witness is the corresponding lookup in the finite-map frame. */ +PROOF static thm prove_gmap_ra_included_lookup(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_included (gmap_ra R) m n ==> + forall k:K. + ra_included + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "m"); + body = GEN_TAC(body, "n"); + body = DISCH_TAC(body, "Hincluded"); + body = GEN_TAC(body, "k"); + + thm included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (n:(K,V)finmap) + `)); + body = ASSUME_TAC(body, included, "Hextension"); + body = ASMP_EXISTS_TAC( + body, "Hextension", "frame"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = EXISTS_TAC( + body, + `finmap_lookup (frame:(K,V)finmap) (k:K)`); + + thm extension_at = ap_term_rule( + `\map:(K,V)finmap. finmap_lookup map (k:K)`, + assume_rule(` + (n:(K,V)finmap) == + ra_op + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (frame:(K,V)finmap) + `)); + extension_at = rewrite_rule( + THM_LIST(gmap_ra_op_lookup), + extension_at); + ACCEPT_TAC(body, extension_at); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_lookup = + prove_gmap_ra_included_lookup(); + +/* At a fixed singleton key, finite-map inclusion is exactly payload + * inclusion. The forward direction selects the pointwise option inclusion; + * the reverse direction lifts a base frame to a singleton-map frame. */ +PROOF static thm prove_gmap_ra_included_singleton(void) { + term goal_tm = ` + forall (R:(V)ra) (key:K) (a:V) (b:V). + ra_included + (gmap_ra R) + (finmap_singleton key a) + (finmap_singleton key b) <=> + ra_included R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hgmap_included"); + thm pointwise = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `finmap_singleton (key:K) (a:V)`, + `finmap_singleton (key:K) (b:V)`), + gmap_ra_included_lookup), + assume_rule(` + ra_included + (gmap_ra (R:(V)ra)) + (finmap_singleton (key:K) (a:V)) + (finmap_singleton (key:K) (b:V)) + `)); + thm at_key = spec_rule(`key:K`, pointwise); + at_key = rewrite_rule( + THM_LIST( + finmap_singleton_lookup, + option_ra_included_some_some), + at_key); + ACCEPT_TAC(forward, at_key); + + gnode reverse = DISCH_TAC( + directions[1], "Hbase_included"); + thm base_included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(`ra_included (R:(V)ra) (a:V) (b:V)`)); + reverse = ASSUME_TAC( + reverse, base_included, "Hbase_extension"); + reverse = ASMP_EXISTS_TAC( + reverse, "Hbase_extension", "base_frame"); + reverse = CONV_TAC( + reverse, + once_rewrite_conv(THM_LIST(ra_included_def))); + reverse = EXISTS_TAC( + reverse, + `finmap_singleton (key:K) (base_frame:V)`); + + thm lifted_extension = beta_rule(ap_term_rule( + `\x:V. finmap_singleton (key:K) x`, + assume_rule(` + (b:V) == + ra_op (R:(V)ra) (a:V) (base_frame:V) + `))); + thm singleton_composition = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `base_frame:V`), + gmap_ra_singleton_op); + ACCEPT_TAC( + reverse, + trans_rule( + lifted_extension, + gsym_rule(singleton_composition))); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_singleton = + prove_gmap_ra_included_singleton(); + +PROOF static thm prove_gmap_lookup_included_empty(void) { + term goal_tm = ` + forall (R:(V)ra) (n:(K,V)finmap). + gmap_lookup_included R finmap_empty n ==> + ra_included (gmap_ra R) finmap_empty n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm unit_included = ispecl_rule( + TERM_LIST( + `gmap_ra (R:(V)ra):((K,V)finmap)ra`, + `n:(K,V)finmap`), + ra_included_unit); + unit_included = rewrite_rule( + THM_LIST(gmap_ra_unit), + unit_included); + ACCEPT_TAC(body, unit_included); + return gnode_prove(root); +} + +PROOF static thm gmap_lookup_included_empty = + prove_gmap_lookup_included_empty(); + +PROOF static thm prove_gmap_lookup_included_insert(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (m:(K,V)finmap). + finmap_lookup m key == NONE ==> + (forall n:(K,V)finmap. + gmap_lookup_included R m n ==> + ra_included (gmap_ra R) m n) ==> + forall n:(K,V)finmap. + gmap_lookup_included R (finmap_insert key a m) n ==> + ra_included + (gmap_ra R) + (finmap_insert key a m) + n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "key"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "m"); + body = DISCH_TAC(body, "Hfresh"); + body = DISCH_TAC(body, "Hsmaller"); + body = GEN_TAC(body, "n"); + body = DISCH_TAC(body, "Hpointwise"); + + thm pointwise = pure_once_rewrite_rule( + THM_LIST(gmap_lookup_included_def), + assume_rule(` + gmap_lookup_included + (R:(V)ra) + (finmap_insert (key:K) (a:V) (m:(K,V)finmap)) + (n:(K,V)finmap) + `)); + thm included_at_key = spec_rule(`key:K`, pointwise); + included_at_key = rewrite_rule( + THM_LIST(finmap_insert_lookup), + included_at_key); + + gnode_list target_cases = CASES_TAC( + body, + `finmap_lookup (n:(K,V)finmap) (key:K)`, + "Htarget"); + + thm target_none = assume_rule(gnode_get_asmps( + target_cases[0], CONST_STRING_LIST("Htarget"))[0]); + thm impossible_inclusion = rewrite_rule( + THM_LIST(target_none), + included_at_key); + CONTR_TAC( + target_cases[0], + not_elim_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `a:V`), + option_ra_not_included_some_none), + impossible_inclusion)); + + thm target_some = assume_rule(gnode_get_asmps( + target_cases[1], CONST_STRING_LIST("Htarget"))[0]); + term b = dest_comb(dest_eq(concl(target_some)).tm2).tm2; + term singleton_b = mk_comb( + `finmap_singleton (key:K):V->(K,V)finmap`, + b); + thm payload_included = rewrite_rule( + THM_LIST( + target_some, + option_ra_included_some_some), + included_at_key); + + term rest_pointwise = ` + gmap_lookup_included + (R:(V)ra) + (m:(K,V)finmap) + (finmap_delete (key:K) (n:(K,V)finmap)) + `; + gnode_list rest_assertion = ASSERT_TAC( + target_cases[1], rest_pointwise, "Hrest_pointwise"); + + gnode rest_goal = CONV_TAC( + rest_assertion[1], + once_rewrite_conv(THM_LIST(gmap_lookup_included_def))); + rest_goal = GEN_TAC(rest_goal, "query"); + gnode_list query_cases = BOOL_CASES_TAC( + rest_goal, `(query:K) == (key:K)`, NULL); + + CONV_WITH_ASMP_TAC( + query_cases[0], + rewrite_conv, + THM_LIST( + finmap_delete_lookup, + option_ra_included_none)); + + thm original_query = spec_rule(`query:K`, pointwise); + original_query = rewrite_rule( + THM_LIST( + assume_rule(`~((query:K) == (key:K))`), + finmap_insert_lookup, + finmap_delete_lookup), + original_query); + gnode rest_ne = CONV_WITH_ASMP_TAC( + query_cases[1], + rewrite_conv, + THM_LIST(finmap_delete_lookup)); + ACCEPT_TAC(rest_ne, original_query); + + thm rest_included = mp_rule( + ispec_rule( + `finmap_delete (key:K) (n:(K,V)finmap)`, + assume_rule(` + forall target:(K,V)finmap. + gmap_lookup_included + (R:(V)ra) + (m:(K,V)finmap) + target ==> + ra_included (gmap_ra R) m target + `)), + assume_rule(rest_pointwise)); + thm singleton_included = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + b), + gmap_ra_included_singleton)), + payload_included); + thm combined_included = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `gmap_ra (R:(V)ra):((K,V)finmap)ra`, + `finmap_singleton (key:K) (a:V)`, + singleton_b, + `m:(K,V)finmap`, + `finmap_delete (key:K) (n:(K,V)finmap)`), + ra_included_op_mono), + singleton_included), + rest_included); + thm source_composition = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_singleton_op_fresh), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == NONE + `)); + thm target_composition = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + b, + `n:(K,V)finmap`), + gmap_ra_decompose), + target_some); + combined_included = rewrite_rule( + THM_LIST( + source_composition, + gsym_rule(target_composition)), + combined_included); + ACCEPT_TAC(rest_assertion[0], combined_included); + return gnode_prove(root); +} + +PROOF static thm gmap_lookup_included_insert = + prove_gmap_lookup_included_insert(); + +PROOF static thm prove_gmap_ra_included_of_lookup(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + (forall k:K. + ra_included + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k)) ==> + ra_included (gmap_ra R) m n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term property = ` + \source:(K,V)finmap. + forall target:(K,V)finmap. + gmap_lookup_included (R:(V)ra) source target ==> + ra_included (gmap_ra R) source target + `; + thm induction = beta_rule(ispec_rule(property, finmap_induct)); + induction = mp_rule( + induction, + ispec_rule( + `R:(V)ra`, + gmap_lookup_included_empty)); + induction = mp_rule( + induction, + ispec_rule( + `R:(V)ra`, + gmap_lookup_included_insert)); + thm selected_source = ispec_rule( + `m:(K,V)finmap`, + induction); + thm selected_target = ispec_rule( + `n:(K,V)finmap`, + selected_source); + thm pointwise = pure_once_rewrite_rule( + THM_LIST(gsym_rule(gmap_lookup_included_def)), + assume_rule(` + forall k:K. + ra_included + (option_ra (R:(V)ra)) + (finmap_lookup (m:(K,V)finmap) k) + (finmap_lookup (n:(K,V)finmap) k) + `)); + ACCEPT_TAC( + body, + mp_rule(selected_target, pointwise)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_of_lookup = + prove_gmap_ra_included_of_lookup(); + +PROOF static thm prove_gmap_ra_included_lookup_iff(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_included (gmap_ra R) m n <=> + forall k:K. + ra_included + (option_ra R) + (finmap_lookup m k) + (finmap_lookup n k) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + ACCEPT_TAC( + forward, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`, + `n:(K,V)finmap`), + gmap_ra_included_lookup), + assume_rule(` + ra_included + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (n:(K,V)finmap) + `))); + gnode reverse = DISCH_TAC(directions[1], "Hpointwise"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`, + `n:(K,V)finmap`), + gmap_ra_included_of_lookup), + assume_rule(` + forall k:K. + ra_included + (option_ra (R:(V)ra)) + (finmap_lookup (m:(K,V)finmap) k) + (finmap_lookup (n:(K,V)finmap) k) + `))); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_lookup_iff = + prove_gmap_ra_included_lookup_iff(); + +PROOF static thm prove_gmap_ra_included_delete(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (m:(K,V)finmap). + ra_included + (gmap_ra R) + (finmap_delete key m) + m + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + gmap_ra_included_lookup_iff))); + body = GEN_TAC(body, "query"); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + thm branch = i == 0 + ? assume_rule(`query:K == key`) + : assume_rule(`~(query:K == key)`); + gnode reduced_goal = CONV_TAC( + cases[i], + rewrite_conv(THM_LIST( + branch, + finmap_delete_lookup))); + if (i == 0) { + ACCEPT_TAC( + reduced_goal, + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `finmap_lookup (m:(K,V)finmap) (key:K)`), + option_ra_included_none)); + } else { + ACCEPT_TAC( + reduced_goal, + ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `finmap_lookup (m:(K,V)finmap) (query:K)`), + ra_included_refl)); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_delete = + prove_gmap_ra_included_delete(); + +PROOF static thm prove_gmap_ra_included_lookup_some(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_included (gmap_ra R) m n <=> + forall (key:K) (a:V). + finmap_lookup m key == SOME a ==> + exists b:V. + finmap_lookup n key == SOME b && + ra_included R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + thm pointwise = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`, + `n:(K,V)finmap`), + gmap_ra_included_lookup), + assume_rule(` + ra_included + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (n:(K,V)finmap) + `)); + forward = GEN_TAC(forward, "key"); + forward = GEN_TAC(forward, "a"); + forward = DISCH_TAC(forward, "Hsource"); + thm at_key = spec_rule(`key:K`, pointwise); + at_key = rewrite_rule( + THM_LIST(assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)), + at_key); + gnode_list target_cases = CASES_TAC( + forward, + `finmap_lookup (n:(K,V)finmap) (key:K)`, + "Htarget"); + + thm target_none = assume_rule(gnode_get_asmps( + target_cases[0], CONST_STRING_LIST("Htarget"))[0]); + thm impossible = rewrite_rule( + THM_LIST(target_none), + at_key); + CONTR_TAC( + target_cases[0], + not_elim_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `a:V`), + option_ra_not_included_some_none), + impossible)); + + thm target_some = assume_rule(gnode_get_asmps( + target_cases[1], CONST_STRING_LIST("Htarget"))[0]); + term b = dest_comb(dest_eq(concl(target_some)).tm2).tm2; + gnode some_branch = EXISTS_TAC(target_cases[1], b); + gnode_list some_parts = CONJ_TAC(some_branch); + ACCEPT_TAC(some_parts[0], target_some); + thm base_included = rewrite_rule( + THM_LIST( + target_some, + option_ra_included_some_some), + at_key); + ACCEPT_TAC(some_parts[1], base_included); + + gnode reverse = DISCH_TAC(directions[1], "Hpayload"); + reverse = MATCH_MP_TAC( + reverse, + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`, + `n:(K,V)finmap`), + gmap_ra_included_of_lookup)); + reverse = GEN_TAC(reverse, "key"); + gnode_list source_cases = CASES_TAC( + reverse, + `finmap_lookup (m:(K,V)finmap) (key:K)`, + "Hsource"); + + CONV_WITH_ASMP_TAC( + source_cases[0], + rewrite_conv, + THM_LIST(option_ra_included_none)); + + thm source_some = assume_rule(gnode_get_asmps( + source_cases[1], CONST_STRING_LIST("Hsource"))[0]); + term a = dest_comb(dest_eq(concl(source_some)).tm2).tm2; + thm selected_target = mp_rule( + ispecl_rule( + TERM_LIST(`key:K`, a), + assume_rule(` + forall (query:K) (source_value:V). + finmap_lookup (m:(K,V)finmap) query == + SOME source_value ==> + exists target_value:V. + finmap_lookup (n:(K,V)finmap) query == + SOME target_value && + ra_included (R:(V)ra) source_value target_value + `)), + source_some); + gnode some_source = ASSUME_TAC( + source_cases[1], selected_target, "Hselected"); + some_source = ASMP_EXISTS_TAC( + some_source, "Hselected", "b"); + some_source = ASMP_CONJ_TAC( + some_source, "Hselected", "Htarget", "Hbase"); + thm base_inclusion = assume_rule(gnode_get_asmps( + some_source, CONST_STRING_LIST("Hbase"))[0]); + thm lifted_inclusion = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(V)ra`, + a, + `b:V`), + option_ra_included_some_some)), + base_inclusion); + lifted_inclusion = rewrite_rule( + THM_LIST( + gsym_rule(source_some), + gsym_rule(assume_rule(` + finmap_lookup (n:(K,V)finmap) (key:K) == SOME (b:V) + `))), + lifted_inclusion); + ACCEPT_TAC(some_source, lifted_inclusion); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_lookup_some = + prove_gmap_ra_included_lookup_some(); + +PROOF static thm prove_gmap_ra_included_dom(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (n:(K,V)finmap). + ra_included (gmap_ra R) m n ==> + finmap_dom m SUBSET finmap_dom n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm payloads = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `m:(K,V)finmap`, + `n:(K,V)finmap`), + gmap_ra_included_lookup_some), + assume_rule(` + ra_included + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (n:(K,V)finmap) + `)); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("SUBSET")))); + body = GEN_TAC(body, "key"); + body = DISCH_TAC(body, "Hin"); + thm source_exists = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `m:(K,V)finmap`), + finmap_in_dom_some), + assume_rule(` + (key:K) IN finmap_dom (m:(K,V)finmap) + `)); + body = ASSUME_TAC(body, source_exists, "Hsource"); + body = ASMP_EXISTS_TAC(body, "Hsource", "a"); + thm target_exists = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `a:V`), + payloads), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)); + body = ASSUME_TAC(body, target_exists, "Htarget"); + body = ASMP_EXISTS_TAC(body, "Htarget", "b"); + body = ASMP_CONJ_TAC( + body, "Htarget", "Hlookup", "Hbase"); + term target_some_exists = ` + exists value:V. + finmap_lookup (n:(K,V)finmap) (key:K) == SOME value + `; + thm target_present = exists_rule( + target_some_exists, + `b:V`, + assume_rule(` + finmap_lookup (n:(K,V)finmap) (key:K) == SOME (b:V) + `)); + ACCEPT_TAC( + body, + eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `key:K`, + `n:(K,V)finmap`), + finmap_in_dom_some)), + target_present)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_included_dom = + prove_gmap_ra_included_dom(); + +/* Lift an existing-key base local update while retaining the original map at + * every other key. The proof applies the option local update to the selected + * lookup and reuses the source decomposition pointwise elsewhere. */ +PROOF static thm prove_gmap_ra_local_update_at(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) (f:V) + (b:V) (g:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + ra_local_update R a f b g ==> + ra_local_update + (gmap_ra R) + m + (finmap_singleton key f) + (finmap_insert key b m) + (finmap_singleton key g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + body = AUTO_INTROS_TAC(body); + + thm source_all = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(V)ra`, `m:(K,V)finmap`), + gmap_ra_valid), + assume_rule(` + ra_valid + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + (m:(K,V)finmap) + `)); + thm source_key_valid = rewrite_rule( + THM_LIST(assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)), + spec_rule(`key:K`, source_all)); + + thm source_key_eq = beta_rule(ap_term_rule( + `\whole:(K,V)finmap. finmap_lookup whole (key:K)`, + assume_rule(` + (m:(K,V)finmap) == + ra_op + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + (finmap_singleton (key:K) (f:V)) + (residual:(K,V)finmap) + `))); + source_key_eq = rewrite_rule( + THM_LIST( + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `), + gmap_ra_op_lookup, + finmap_singleton_lookup), + source_key_eq); + + thm option_local = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `a:V`, + `f:V`, + `b:V`, + `g:V`), + option_ra_local_update_iff)), + assume_rule(` + ra_local_update + (R:(V)ra) + (a:V) + (f:V) + (b:V) + (g:V) + `)); + thm option_apply = ispecl_rule( + TERM_LIST( + `option_ra (R:(V)ra)`, + `SOME (a:V)`, + `SOME (f:V)`, + `SOME (b:V)`, + `SOME (g:V)`, + `finmap_lookup + (residual:(K,V)finmap) + (key:K)`), + ra_local_update_apply); + thm option_result = mp_rule( + mp_rule( + mp_rule(option_apply, option_local), + source_key_valid), + source_key_eq); + + gnode_list result = CONJ_TAC(body); + + thm target_payload_valid = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(V)ra`, `b:V`), + option_ra_valid_some), + conjunct1_rule(option_result)); + thm source_delete_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `m:(K,V)finmap`), + gmap_ra_valid_delete), + assume_rule(` + ra_valid + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + (m:(K,V)finmap) + `)); + thm target_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `b:V`, + `m:(K,V)finmap`), + gmap_ra_valid_insert)), + conj_rule(target_payload_valid, source_delete_valid)); + ACCEPT_TAC(result[0], target_valid); + + gnode target_eq = CONV_TAC( + result[1], + once_rewrite_conv(THM_LIST(finmap_eq_lookup))); + target_eq = GEN_TAC(target_eq, "query"); + gnode_list query_cases = BOOL_CASES_TAC( + target_eq, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(query_cases); ++i) { + thm branch = i == 0 + ? assume_rule(`(query:K) == (key:K)`) + : assume_rule(`~((query:K) == (key:K))`); + gnode reduced = CONV_TAC( + query_cases[i], + rewrite_conv(THM_LIST( + branch, + finmap_insert_lookup, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l))); + if (i == 0) { + thm target_key_eq = rewrite_rule( + THM_LIST(branch), + conjunct2_rule(option_result)); + ACCEPT_TAC(reduced, target_key_eq); + } else { + thm source_at = beta_rule(ap_term_rule( + `\whole:(K,V)finmap. finmap_lookup whole (query:K)`, + assume_rule(` + (m:(K,V)finmap) == + ra_op + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + (finmap_singleton (key:K) (f:V)) + (residual:(K,V)finmap) + `))); + source_at = rewrite_rule( + THM_LIST( + branch, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l), + source_at); + ACCEPT_TAC(reduced, source_at); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_local_update_at = + prove_gmap_ra_local_update_at(); + +/* + * Lift a deterministic base update through SOME at the selected key. At all + * other keys both source and target singletons contribute NONE, so the source + * pointwise validity is reused unchanged. + */ +PROOF static thm prove_gmap_ra_update_singleton(void) { + term goal_tm = ` + forall (R:(V)ra) (key:K) (a:V) (b:V). + ra_update R a b ==> + ra_update + (gmap_ra R) + (finmap_singleton key a) + (finmap_singleton key b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + ra_update_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC( + body, + `finmap_singleton (key:K) (b:V)`); + gnode_list update_result = CONJ_TAC(body); + ACCEPT_TAC( + update_result[0], + refl_rule(`finmap_singleton (key:K) (b:V)`)); + body = update_result[1]; + + thm source_valid_rule = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `ra_op + (gmap_ra (R:(V)ra)) + (finmap_singleton (key:K) (a:V)) + (frame:(K,V)finmap)`), + gmap_ra_valid); + thm source_all = eq_mp_rule( + source_valid_rule, + assume_rule(` + ra_valid + (gmap_ra (R:(V)ra)) + (ra_op + (gmap_ra R) + (finmap_singleton (key:K) (a:V)) + (frame:(K,V)finmap)) + `)); + + thm option_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `a:V`, + `b:V`), + option_ra_update), + assume_rule(`ra_update (R:(V)ra) (a:V) (b:V)`)); + + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + body = GEN_TAC(body, "query"); + thm source_at = spec_rule(`query:K`, source_all); + gnode_list cases = BOOL_CASES_TAC( + body, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + thm branch = i == 0 + ? assume_rule(`query:K == key`) + : assume_rule(`~(query:K == key)`); + thm normalized_source = rewrite_rule( + THM_LIST( + branch, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l), + source_at); + gnode reduced_goal = CONV_TAC( + cases[i], + rewrite_conv(THM_LIST( + branch, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l))); + if (i == 0) { + thm updated = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `(option_ra (R:(V)ra)):((V)option)ra`, + `SOME (a:V):(V)option`, + `SOME (b:V):(V)option`, + `finmap_lookup + (frame:(K,V)finmap) + (key:K)`), + ra_update_apply), + option_update), + normalized_source); + ACCEPT_TAC(reduced_goal, updated); + } else { + ACCEPT_TAC(reduced_goal, normalized_source); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_update_singleton = + prove_gmap_ra_update_singleton(); + +/* Factor an inserted map into a singleton and the deleted remainder, frame + * the singleton update, and normalize both factorizations back to inserts. */ +PROOF static thm prove_gmap_ra_update_insert(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (b:V) + (m:(K,V)finmap). + ra_update R a b ==> + ra_update + (gmap_ra R) + (finmap_insert key a m) + (finmap_insert key b m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm singleton_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `b:V`), + gmap_ra_update_singleton), + assume_rule(`ra_update (R:(V)ra) (a:V) (b:V)`)); + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `(gmap_ra (R:(V)ra)):((K,V)finmap)ra`, + `finmap_singleton (key:K) (a:V)`, + `finmap_singleton (key:K) (b:V)`, + `finmap_delete (key:K) (m:(K,V)finmap)`), + ra_update_frame), + singleton_update); + thm source_factorization = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_singleton_op_delete); + thm target_factorization = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `b:V`, + `m:(K,V)finmap`), + gmap_ra_singleton_op_delete); + ACCEPT_TAC( + body, + rewrite_rule( + THM_LIST( + source_factorization, + target_factorization), + framed_update)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_update_insert = + prove_gmap_ra_update_insert(); + +PROOF static thm prove_gmap_ra_update_at(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (b:V) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + ra_update R a b ==> + ra_update + (gmap_ra R) + m + (finmap_insert key b m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm inserted_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `b:V`, + `m:(K,V)finmap`), + gmap_ra_update_insert), + assume_rule(`ra_update (R:(V)ra) (a:V) (b:V)`)); + thm source_identity = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `a:V`, + `m:(K,V)finmap`), + finmap_insert_id), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)); + ACCEPT_TAC( + body, + rewrite_rule(THM_LIST(source_identity), inserted_update)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_update_at = + prove_gmap_ra_update_at(); + +PROOF static thm prove_gmap_ra_drop_at(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (m:(K,V)finmap). + ra_update + (gmap_ra R) + m + (finmap_delete key m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm delete_included = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `m:(K,V)finmap`), + gmap_ra_included_delete); + thm delete_update = mp_rule( + ispecl_rule( + TERM_LIST( + `(gmap_ra (R:(V)ra)):((K,V)finmap)ra`, + `m:(K,V)finmap`, + `finmap_delete (key:K) (m:(K,V)finmap)`), + ra_update_included), + delete_included); + ACCEPT_TAC(body, delete_update); + return gnode_prove(root); +} + +PROOF thm gmap_ra_drop_at = + prove_gmap_ra_drop_at(); + +/* + * The nondeterministic lift selects an exact SOME payload at the chosen key + * using option_ra_updateP, then packages that payload as an exact singleton + * map. Other keys again retain the source frame validity unchanged. + */ +PROOF static thm prove_gmap_ra_updateP_singleton(void) { + term goal_tm = ` + forall (R:(V)ra) (key:K) (a:V) (P:V->bool). + ra_updateP R a P ==> + ra_updateP + (gmap_ra R) + (finmap_singleton key a) + (\m:(K,V)finmap. + exists b:V. + P b && m == finmap_singleton key b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + + thm source_valid_rule = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `ra_op + (gmap_ra (R:(V)ra)) + (finmap_singleton (key:K) (a:V)) + (frame:(K,V)finmap)`), + gmap_ra_valid); + thm source_all = eq_mp_rule( + source_valid_rule, + assume_rule(` + ra_valid + (gmap_ra (R:(V)ra)) + (ra_op + (gmap_ra R) + (finmap_singleton (key:K) (a:V)) + (frame:(K,V)finmap)) + `)); + thm source_key = spec_rule(`key:K`, source_all); + source_key = rewrite_rule( + THM_LIST( + gmap_ra_op_lookup, + finmap_singleton_lookup), + source_key); + + thm option_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `a:V`, + `P:V->bool`), + option_ra_updateP), + assume_rule(` + ra_updateP (R:(V)ra) (a:V) (P:V->bool) + `)); + option_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + option_update); + option_update = beta_rule(option_update); + thm selected = mp_rule( + spec_rule( + `finmap_lookup + (frame:(K,V)finmap) + (key:K)`, + option_update), + source_key); + + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC( + body, "Hselected", "selected_option"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "Hselected_image", + "Hselected_valid"); + body = ASMP_EXISTS_TAC( + body, "Hselected_image", "b"); + body = ASMP_CONJ_TAC( + body, + "Hselected_image", + "HP_b", + "Hselected_some"); + thm selected_key_valid = rewrite_rule( + THM_LIST(assume_rule(` + (selected_option:V option) == SOME (b:V) + `)), + assume_rule(` + ra_valid + (option_ra (R:(V)ra)) + (ra_op + (option_ra R) + (selected_option:V option) + (finmap_lookup + (frame:(K,V)finmap) + (key:K))) + `)); + body = ASSUME_TAC( + body, selected_key_valid, "Hb_key_valid"); + + body = EXISTS_TAC( + body, + `finmap_singleton (key:K) (b:V)`); + gnode_list result_parts = CONJ_TAC(body); + gnode predicate = EXISTS_TAC(result_parts[0], `b:V`); + gnode_list predicate_parts = CONJ_TAC(predicate); + ACCEPT_TAC( + predicate_parts[0], + assume_rule(`(P:V->bool) (b:V)`)); + ACCEPT_TAC( + predicate_parts[1], + refl_rule(`finmap_singleton (key:K) (b:V)`)); + + gnode validity = CONV_TAC( + result_parts[1], + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + validity = GEN_TAC(validity, "query"); + thm source_at = spec_rule(`query:K`, source_all); + gnode_list cases = BOOL_CASES_TAC( + validity, `(query:K) == (key:K)`, "Hkey"); + for (size_t i = 0; i < vector_size(cases); ++i) { + thm branch = i == 0 + ? assume_rule(`query:K == key`) + : assume_rule(`~(query:K == key)`); + gnode reduced_goal = CONV_TAC( + cases[i], + rewrite_conv(THM_LIST( + branch, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l))); + if (i == 0) { + ACCEPT_TAC( + reduced_goal, + assume_rule(` + ra_valid + (option_ra (R:(V)ra)) + (ra_op + (option_ra R) + (SOME (b:V)) + (finmap_lookup + (frame:(K,V)finmap) + (key:K))) + `)); + } else { + thm normalized_source = rewrite_rule( + THM_LIST( + branch, + gmap_ra_op_lookup, + finmap_singleton_lookup, + option_ra_op_none_l), + source_at); + ACCEPT_TAC(reduced_goal, normalized_source); + } + } + return gnode_prove(root); +} + +PROOF thm gmap_ra_updateP_singleton = + prove_gmap_ra_updateP_singleton(); + +/* Frame the exact singleton image by the deleted remainder. ND + * monotonicity then normalizes each selected singleton back to an insertion; + * the selected payload remains free to depend on the hidden frame. */ +PROOF static thm prove_gmap_ra_updateP_insert(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (P:V->bool) + (m:(K,V)finmap). + ra_updateP R a P ==> + ra_updateP + (gmap_ra R) + (finmap_insert key a m) + (\result:(K,V)finmap. + exists b:V. + P b && result == finmap_insert key b m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + term singleton_image = ` + \selected:(K,V)finmap. + exists b:V. + (P:V->bool) b && + selected == finmap_singleton (key:K) b + `; + term framed_image = ` + \result:(K,V)finmap. + exists selected:(K,V)finmap. + (exists b:V. + (P:V->bool) b && + selected == finmap_singleton (key:K) b) && + result == + ra_op + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + selected + (finmap_delete (key:K) (m:(K,V)finmap)) + `; + term insert_image = ` + \result:(K,V)finmap. + exists b:V. + (P:V->bool) b && + result == + finmap_insert (key:K) b (m:(K,V)finmap) + `; + + thm singleton_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `P:V->bool`), + gmap_ra_updateP_singleton), + assume_rule(` + ra_updateP (R:(V)ra) (a:V) (P:V->bool) + `)); + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `(gmap_ra (R:(V)ra)):((K,V)finmap)ra`, + `finmap_singleton (key:K) (a:V)`, + singleton_image, + `finmap_delete (key:K) (m:(K,V)finmap)`), + ra_updateP_frame), + singleton_update); + framed_update = beta_rule(framed_update); + + thm source_factorization = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `m:(K,V)finmap`), + gmap_ra_singleton_op_delete); + framed_update = rewrite_rule( + THM_LIST(source_factorization), + framed_update); + + thm weakened = ispecl_rule( + TERM_LIST( + `(gmap_ra (R:(V)ra)):((K,V)finmap)ra`, + `finmap_insert (key:K) (a:V) (m:(K,V)finmap)`, + framed_image, + insert_image), + ra_updateP_mono); + weakened = mp_rule(weakened, framed_update); + weakened = beta_rule(weakened); + body = MATCH_MP_TAC(body, weakened); + body = GEN_TAC(body, "result"); + body = DISCH_TAC(body, "Hframed"); + body = ASMP_EXISTS_TAC( + body, "Hframed", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hframed", + "Hselected_image", + "Hresult_op"); + body = ASMP_EXISTS_TAC( + body, "Hselected_image", "b"); + body = ASMP_CONJ_TAC( + body, + "Hselected_image", + "HP_b", + "Hselected_singleton"); + body = EXISTS_TAC(body, `b:V`); + gnode_list result_parts = CONJ_TAC(body); + ACCEPT_TAC( + result_parts[0], + assume_rule(`(P:V->bool) (b:V)`)); + + thm target_factorization = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `b:V`, + `m:(K,V)finmap`), + gmap_ra_singleton_op_delete); + thm result_equality = rewrite_rule( + THM_LIST( + assume_rule(` + (selected:(K,V)finmap) == + finmap_singleton (key:K) (b:V) + `), + target_factorization), + assume_rule(` + (result:(K,V)finmap) == + ra_op + ((gmap_ra (R:(V)ra)):((K,V)finmap)ra) + (selected:(K,V)finmap) + (finmap_delete (key:K) (m:(K,V)finmap)) + `)); + ACCEPT_TAC(result_parts[1], result_equality); + return gnode_prove(root); +} + +PROOF thm gmap_ra_updateP_insert = + prove_gmap_ra_updateP_insert(); + +PROOF static thm prove_gmap_ra_updateP_at(void) { + term goal_tm = ` + forall + (R:(V)ra) + (key:K) + (a:V) + (P:V->bool) + (m:(K,V)finmap). + finmap_lookup m key == SOME a ==> + ra_updateP R a P ==> + ra_updateP + (gmap_ra R) + m + (\result:(K,V)finmap. + exists b:V. + P b && result == finmap_insert key b m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm inserted_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `key:K`, + `a:V`, + `P:V->bool`, + `m:(K,V)finmap`), + gmap_ra_updateP_insert), + assume_rule(` + ra_updateP (R:(V)ra) (a:V) (P:V->bool) + `)); + thm source_identity = mp_rule( + ispecl_rule( + TERM_LIST( + `key:K`, + `a:V`, + `m:(K,V)finmap`), + finmap_insert_id), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == SOME (a:V) + `)); + ACCEPT_TAC( + body, + rewrite_rule(THM_LIST(source_identity), inserted_update)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_updateP_at = + prove_gmap_ra_updateP_at(); + +/* Pick the fresh key only after the hidden map frame has been introduced. + * The common-freshness theorem is precisely where infinitude is used: both + * finite domains can be avoided at once. */ +PROOF static thm prove_gmap_ra_alloc_strong_dep(void) { + term goal_tm = ` + forall + (R:(V)ra) + (candidates:K->bool) + (payload:K->V) + (m:(K,V)finmap). + INFINITE candidates ==> + (forall key:K. + key IN candidates ==> + finmap_lookup m key == NONE ==> + ra_valid R (payload key)) ==> + ra_updateP + (gmap_ra R) + m + (\result:(K,V)finmap. + exists key:K. + key IN candidates && + finmap_lookup m key == NONE && + result == finmap_insert key (payload key) m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + + thm source_all = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `ra_op + (gmap_ra (R:(V)ra)) + (m:(K,V)finmap) + (frame:(K,V)finmap)`), + gmap_ra_valid), + assume_rule(` + ra_valid + (gmap_ra (R:(V)ra)) + (ra_op + (gmap_ra R) + (m:(K,V)finmap) + (frame:(K,V)finmap)) + `)); + thm fresh = mp_rule( + ispecl_rule( + TERM_LIST( + `candidates:K->bool`, + `m:(K,V)finmap`, + `frame:(K,V)finmap`), + finmap_fresh_in_pair), + assume_rule(`INFINITE (candidates:K->bool)`)); + body = ASSUME_TAC(body, fresh, "Hfresh"); + body = ASMP_EXISTS_TAC(body, "Hfresh", "key"); + body = ASMP_CONJ_TAC( + body, + "Hfresh", + "Hcandidate", + "Hmap_freshness"); + body = ASMP_CONJ_TAC( + body, + "Hmap_freshness", + "Hm_fresh", + "Hframe_fresh"); + + thm payload_valid = mp_rule( + mp_rule( + spec_rule( + `key:K`, + assume_rule(` + forall query:K. + query IN (candidates:K->bool) ==> + finmap_lookup (m:(K,V)finmap) query == NONE ==> + ra_valid (R:(V)ra) ((payload:K->V) query) + `)), + assume_rule(`(key:K) IN (candidates:K->bool)`)), + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == NONE + `)); + + body = EXISTS_TAC( + body, + `finmap_insert + (key:K) + ((payload:K->V) key) + (m:(K,V)finmap)`); + gnode_list result_parts = CONJ_TAC(body); + + gnode image = EXISTS_TAC(result_parts[0], `key:K`); + gnode_list image_parts = CONJ_TAC(image); + ACCEPT_TAC( + image_parts[0], + assume_rule(`(key:K) IN (candidates:K->bool)`)); + gnode_list fresh_and_result = CONJ_TAC(image_parts[1]); + ACCEPT_TAC( + fresh_and_result[0], + assume_rule(` + finmap_lookup (m:(K,V)finmap) (key:K) == NONE + `)); + ACCEPT_TAC( + fresh_and_result[1], + refl_rule(` + finmap_insert + (key:K) + ((payload:K->V) key) + (m:(K,V)finmap) + `)); + + gnode validity = CONV_TAC( + result_parts[1], + once_rewrite_conv(THM_LIST(gmap_ra_valid))); + validity = GEN_TAC(validity, "query"); + thm source_at = spec_rule(`query:K`, source_all); + source_at = rewrite_rule( + THM_LIST(gmap_ra_op_lookup), + source_at); + gnode_list cases = BOOL_CASES_TAC( + validity, + `(query:K) == (key:K)`, + "Hkey"); + + thm equal_key = assume_rule(`query:K == key`); + gnode at_key = CONV_TAC( + cases[0], + rewrite_conv(THM_LIST( + equal_key, + gmap_ra_op_lookup, + finmap_insert_lookup, + assume_rule(` + finmap_lookup + (frame:(K,V)finmap) + (key:K) == NONE + `), + option_ra_op_none_r, + option_ra_valid_some))); + ACCEPT_TAC(at_key, payload_valid); + + thm unequal_key = assume_rule(`~(query:K == key)`); + gnode away = CONV_TAC( + cases[1], + rewrite_conv(THM_LIST( + unequal_key, + gmap_ra_op_lookup, + finmap_insert_lookup))); + ACCEPT_TAC(away, source_at); + return gnode_prove(root); +} + +PROOF thm gmap_ra_alloc_strong_dep = + prove_gmap_ra_alloc_strong_dep(); + +PROOF static thm prove_gmap_ra_alloc_strong(void) { + term goal_tm = ` + forall + (R:(V)ra) + (candidates:K->bool) + (m:(K,V)finmap) + (a:V). + INFINITE candidates ==> + ra_valid R a ==> + ra_updateP + (gmap_ra R) + m + (\result:(K,V)finmap. + exists key:K. + key IN candidates && + finmap_lookup m key == NONE && + result == finmap_insert key a m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm allocated = ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `candidates:K->bool`, + `\key:K. a:V`, + `m:(K,V)finmap`), + gmap_ra_alloc_strong_dep); + allocated = beta_rule(allocated); + allocated = mp_rule( + allocated, + assume_rule(`INFINITE (candidates:K->bool)`)); + body = MATCH_MP_TAC(body, allocated); + body = GEN_TAC(body, "key"); + body = DISCH_TAC(body, "Hcandidate"); + body = DISCH_TAC(body, "Hfresh"); + ACCEPT_TAC(body, assume_rule(`ra_valid (R:(V)ra) (a:V)`)); + return gnode_prove(root); +} + +PROOF thm gmap_ra_alloc_strong = + prove_gmap_ra_alloc_strong(); + +PROOF static thm prove_gmap_ra_alloc(void) { + term goal_tm = ` + forall + (R:(V)ra) + (m:(K,V)finmap) + (a:V). + INFINITE (UNIV:K->bool) ==> + ra_valid R a ==> + ra_updateP + (gmap_ra R) + m + (\result:(K,V)finmap. + exists key:K. + finmap_lookup m key == NONE && + result == finmap_insert key a m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm allocated = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `UNIV:K->bool`, + `m:(K,V)finmap`, + `a:V`), + gmap_ra_alloc_strong), + assume_rule(`INFINITE (UNIV:K->bool)`)), + assume_rule(`ra_valid (R:(V)ra) (a:V)`)); + allocated = rewrite_rule( + THM_LIST( + get_theorem_by_name("IN_UNIV"), + get_theorem_by_name("AND_CLAUSES")), + allocated); + ACCEPT_TAC(body, allocated); + return gnode_prove(root); +} + +PROOF thm gmap_ra_alloc = + prove_gmap_ra_alloc(); + +PROOF static thm prove_gmap_ra_alloc_cofinite(void) { + term goal_tm = ` + forall + (R:(V)ra) + (forbidden:K->bool) + (m:(K,V)finmap) + (a:V). + INFINITE (UNIV:K->bool) ==> + FINITE forbidden ==> + ra_valid R a ==> + ra_updateP + (gmap_ra R) + m + (\result:(K,V)finmap. + exists key:K. + ~(key IN forbidden) && + finmap_lookup m key == NONE && + result == finmap_insert key a m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term candidates = `(UNIV:K->bool) DIFF (forbidden:K->bool)`; + thm candidates_infinite = mp_rule( + ispecl_rule( + TERM_LIST(`UNIV:K->bool`, `forbidden:K->bool`), + get_theorem_by_name("INFINITE_DIFF_FINITE")), + conj_rule( + assume_rule(`INFINITE (UNIV:K->bool)`), + assume_rule(`FINITE (forbidden:K->bool)`))); + thm allocated = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + candidates, + `m:(K,V)finmap`, + `a:V`), + gmap_ra_alloc_strong), + candidates_infinite), + assume_rule(`ra_valid (R:(V)ra) (a:V)`)); + allocated = rewrite_rule( + THM_LIST( + get_theorem_by_name("IN_DIFF"), + get_theorem_by_name("IN_UNIV"), + get_theorem_by_name("AND_CLAUSES")), + allocated); + ACCEPT_TAC(body, allocated); + return gnode_prove(root); +} + +PROOF thm gmap_ra_alloc_cofinite = + prove_gmap_ra_alloc_cofinite(); + +PROOF static thm prove_gmap_ra_alloc_empty(void) { + term goal_tm = ` + forall (R:(V)ra) (a:V). + INFINITE (UNIV:K->bool) ==> + ra_valid R a ==> + ra_updateP + (gmap_ra R) + (finmap_empty:(K,V)finmap) + (\result:(K,V)finmap. + exists key:K. + result == finmap_singleton key a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm allocated = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(V)ra`, + `finmap_empty:(K,V)finmap`, + `a:V`), + gmap_ra_alloc), + assume_rule(`INFINITE (UNIV:K->bool)`)), + assume_rule(`ra_valid (R:(V)ra) (a:V)`)); + allocated = rewrite_rule( + THM_LIST( + finmap_empty_lookup, + finmap_insert_empty, + get_theorem_by_name("AND_CLAUSES")), + allocated); + ACCEPT_TAC(body, allocated); + return gnode_prove(root); +} + +PROOF thm gmap_ra_alloc_empty = + prove_gmap_ra_alloc_empty(); + +PROOF static int audit_gmap_ra(void) { + thm_list audited_theorems = THM_LIST( + gmap_raw_op_def, + gmap_raw_op_support, + gmap_raw_op_finite, + gmap_op_def, + gmap_op_rep, + gmap_op_lookup, + gmap_valid_def, + gmap_op_assoc, + gmap_op_comm, + gmap_op_unit_l, + gmap_valid_empty, + gmap_valid_op_l, + gmap_ra_laws, + gmap_ra_def, + gmap_ra_unit, + gmap_ra_op_fn, + gmap_ra_valid_fn, + gmap_ra_op_lookup, + gmap_ra_op_singleton_at, + gmap_ra_op_insert_insert, + gmap_ra_op_delete, + gmap_ra_valid, + gmap_ra_valid_lookup_delete, + gmap_ra_valid_delete_some, + gmap_ra_valid_lookup, + gmap_ra_valid_delete, + gmap_ra_valid_insert, + gmap_ra_valid_insert_of_valid, + gmap_ra_valid_insert_fresh, + gmap_ra_singleton_op, + gmap_ra_singleton_op_fresh, + gmap_ra_decompose, + gmap_ra_singleton_op_delete, + gmap_ra_dom_op, + gmap_ra_valid_singleton, + gmap_lookup_included_def, + gmap_ra_included_lookup, + gmap_ra_included_singleton, + gmap_lookup_included_empty, + gmap_lookup_included_insert, + gmap_ra_included_of_lookup, + gmap_ra_included_lookup_iff, + gmap_ra_included_delete, + gmap_ra_included_lookup_some, + gmap_ra_included_dom, + gmap_ra_local_update_at, + gmap_ra_update_singleton, + gmap_ra_update_insert, + gmap_ra_update_at, + gmap_ra_drop_at, + gmap_ra_updateP_singleton, + gmap_ra_updateP_insert, + gmap_ra_updateP_at, + gmap_ra_alloc_strong_dep, + gmap_ra_alloc_strong, + gmap_ra_alloc, + gmap_ra_alloc_cofinite, + gmap_ra_alloc_empty); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "gmap RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "gmap RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == GMAP_RA_AXIOMS_BEFORE, + "gmap RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_gmap_ra"); + return -1; +} + +PROOF static int _GMAP_RA_AUDIT = audit_gmap_ra(); diff --git a/theory/logic/gmap_ra.h b/theory/logic/gmap_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..90f345fde26181b1a23c71f0cdbbcaf61f5442fa --- /dev/null +++ b/theory/logic/gmap_ra.h @@ -0,0 +1,287 @@ +#pragma once + +/* + * Public interface for pointwise finite-map resource algebras. + * + * `gmap_ra R : ((K,V)finmap)ra` interprets every lookup in `option_ra R`, so + * absent keys contribute the option-RA unit. Clients observe maps through the + * public finite-map lookup/domain API and the semantic rules below. Raw map + * representation and support computation remain private to `finmap`. + */ + +#include "proof/theory/logic/finmap.h" +#include "proof/theory/logic/local_update.h" +#include "proof/theory/logic/option_ra.h" + +/* ------------------------------------------------------------------------- */ +/* Pointwise algebra and validity */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R:(V)ra. + * ra_unit (gmap_ra R) == (finmap_empty:(K,V)finmap) + * ``` + * + * `gmap_ra R` 的 unit 是不含任何键的空映射。 + */ +PROOF extern thm gmap_ra_unit; + +/* + * ```text + * forall + * (R:(V)ra) + * (m:(K,V)finmap) + * (n:(K,V)finmap) + * (k:K). + * finmap_lookup (ra_op (gmap_ra R) m n) k == + * ra_op + * (option_ra R) + * (finmap_lookup m k) + * (finmap_lookup n k) + * ``` + * + * 两个 gmap 组合后在键 `k` 处的值，是两边查找结果在 `option_ra R` 中的组合。 + */ +PROOF extern thm gmap_ra_op_lookup; + +/* + * ```text + * forall (R:(V)ra) (m:(K,V)finmap). + * ra_valid (gmap_ra R) m <=> + * forall k:K. + * ra_valid (option_ra R) (finmap_lookup m k) + * ``` + * + * gmap `m` 有效，当且仅当每个键的查找结果在 `option_ra R` 中都有效。 + */ +PROOF extern thm gmap_ra_valid; + +/* + * ```text + * forall (R:(V)ra) (key:K) (a:V). + * ra_valid (gmap_ra R) (finmap_singleton key a) <=> + * ra_valid R a + * ``` + * + * 单点 gmap `key -> a` 有效，当且仅当 payload `a` 在 `R` 中有效。 + */ +PROOF extern thm gmap_ra_valid_singleton; + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) + * (m:(K,V)finmap). + * ra_valid (gmap_ra R) m ==> + * finmap_lookup m key == SOME a ==> + * ra_valid R a + * ``` + * + * 若 gmap `m` 有效且在 `key` 处存有 `a`，则 payload `a` 在 `R` 中有效。 + */ +PROOF extern thm gmap_ra_valid_lookup; + +/* ------------------------------------------------------------------------- */ +/* Inclusion and decomposition */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall + * (R:(V)ra) + * (m:(K,V)finmap) + * (n:(K,V)finmap). + * ra_included (gmap_ra R) m n <=> + * forall k:K. + * ra_included + * (option_ra R) + * (finmap_lookup m k) + * (finmap_lookup n k) + * ``` + * + * gmap `m` 包含于 `n`，当且仅当每个键上 `m` 的查找结果都在 `option_ra R` 中包含于 `n` 的结果。 + */ +PROOF extern thm gmap_ra_included_lookup_iff; + +/* + * ```text + * forall + * (R:(V)ra) + * (m:(K,V)finmap) + * (n:(K,V)finmap). + * ra_included (gmap_ra R) m n ==> + * finmap_dom m SUBSET finmap_dom n + * ``` + * + * 若 gmap `m` 包含于 `n`，则 `m` 中出现的每个键也出现在 `n` 中。 + */ +PROOF extern thm gmap_ra_included_dom; + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) + * (m:(K,V)finmap). + * finmap_lookup m key == SOME a ==> + * m == + * ra_op + * (gmap_ra R) + * (finmap_singleton key a) + * (finmap_delete key m) + * ``` + * + * 若 `m` 在 `key` 处存有 `a`，则 `m` 可分解为单点资源 `key -> a` 与删去该键后余部的 RA 组合。 + */ +PROOF extern thm gmap_ra_decompose; + +/* ------------------------------------------------------------------------- */ +/* Existing-key transformations */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) (f:V) + * (b:V) (g:V) + * (m:(K,V)finmap). + * finmap_lookup m key == SOME a ==> + * ra_local_update R a f b g ==> + * ra_local_update + * (gmap_ra R) + * m + * (finmap_singleton key f) + * (finmap_insert key b m) + * (finmap_singleton key g) + * ``` + * + * 若 `m[key] = a` 且 `(a,f) -> (b,g)` 是 payload 局部更新，则 whole map `m` 与单点片段 `key -> f` 可局部更新为插入 `key -> b` 的 map 与单点 `key -> g`。 + */ +PROOF extern thm gmap_ra_local_update_at; + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) + * (b:V) + * (m:(K,V)finmap). + * finmap_lookup m key == SOME a ==> + * ra_update R a b ==> + * ra_update (gmap_ra R) m (finmap_insert key b m) + * ``` + * + * 若 `m[key] = a` 且 `a` 可更新为 `b`，则 gmap `m` 可更新为在 `key` 处插入 `b` 的映射。 + */ +PROOF extern thm gmap_ra_update_at; + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) + * (P:V->bool) + * (m:(K,V)finmap). + * finmap_lookup m key == SOME a ==> + * ra_updateP R a P ==> + * ra_updateP + * (gmap_ra R) + * m + * (\result:(K,V)finmap. + * exists b:V. + * P b && result == finmap_insert key b m) + * ``` + * + * 若 `m[key] = a` 且 `a` 可更新到满足 `P` 的 payload，则 `m` 可更新到在 `key` 处插入某个满足 `P` 的 `b` 所得的映射。 + */ +PROOF extern thm gmap_ra_updateP_at; + +/* + * ```text + * forall (R:(V)ra) (key:K) (m:(K,V)finmap). + * ra_update (gmap_ra R) m (finmap_delete key m) + * ``` + * + * 任意 gmap 片段 `m` 都可更新为 `finmap_delete key m`；这只删除当前片段在 `key` 处的资源，兼容 frame 保持不变。 + */ +PROOF extern thm gmap_ra_drop_at; + +/* ------------------------------------------------------------------------- */ +/* Fresh allocation */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall + * (R:(V)ra) + * (candidates:K->bool) + * (payload:K->V) + * (m:(K,V)finmap). + * INFINITE candidates ==> + * (forall key:K. + * key IN candidates ==> + * finmap_lookup m key == NONE ==> + * ra_valid R (payload key)) ==> + * ra_updateP + * (gmap_ra R) + * m + * (\result:(K,V)finmap. + * exists key:K. + * key IN candidates && + * finmap_lookup m key == NONE && + * result == finmap_insert key (payload key) m) + * ``` + * + * 若无限候选集中每个当前空缺键的 `payload key` 都有效，则 `m` 可更新为在其中某个空缺键上插入该 payload 的映射。 + */ +PROOF extern thm gmap_ra_alloc_strong_dep; + +/* + * ```text + * forall (R:(V)ra) (m:(K,V)finmap) (a:V). + * INFINITE (UNIV:K->bool) ==> + * ra_valid R a ==> + * ra_updateP + * (gmap_ra R) + * m + * (\result:(K,V)finmap. + * exists key:K. + * finmap_lookup m key == NONE && + * result == finmap_insert key a m) + * ``` + * + * 键类型无限且 `a` 有效时，`m` 可更新为在某个空缺键上插入 `a` 的映射。 + */ +PROOF extern thm gmap_ra_alloc; + +/* + * ```text + * forall + * (R:(V)ra) + * (forbidden:K->bool) + * (m:(K,V)finmap) + * (a:V). + * INFINITE (UNIV:K->bool) ==> + * FINITE forbidden ==> + * ra_valid R a ==> + * ra_updateP + * (gmap_ra R) + * m + * (\result:(K,V)finmap. + * exists key:K. + * ~(key IN forbidden) && + * finmap_lookup m key == NONE && + * result == finmap_insert key a m) + * ``` + * + * 键类型无限、禁用集有限且 `a` 有效时，`m` 可在一个既空缺又不在禁用集中的键上分配 `a`。 + */ +PROOF extern thm gmap_ra_alloc_cofinite; diff --git a/theory/logic/gmap_ra_internal.h b/theory/logic/gmap_ra_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..ba4e015cecd73ae4da81e335d6f14ba3d24c656b --- /dev/null +++ b/theory/logic/gmap_ra_internal.h @@ -0,0 +1,91 @@ +#pragma once + +/* + * INTERNAL finite-map RA rules for dependent constructors and adapters. + * Ordinary clients use `gmap_ra.h`; this header must not be re-exported. + */ + +#include "proof/theory/logic/gmap_ra.h" + +/* + * ```text + * forall (R:(V)ra) (key:K) (a:V) (b:V). + * ra_op + * (gmap_ra R) + * (finmap_singleton key a) + * (finmap_singleton key b) == + * finmap_singleton key (ra_op R a b) + * ``` + * + * 同一键上两个单点 gmap 的 RA 组合，等于在该键上放置 payload 组合 `a ⋅ b` 的单点 gmap。 + */ +PROOF extern thm gmap_ra_singleton_op; + +/* + * ```text + * forall + * (R:(V)ra) + * (key:K) + * (a:V) + * (m:(K,V)finmap). + * finmap_lookup m key == NONE ==> + * ra_op (gmap_ra R) (finmap_singleton key a) m == + * finmap_insert key a m + * ``` + * + * 若 `key` 在 `m` 中空缺，则单点资源 `key -> a` 与 `m` 组合恰等于向 `m` 插入该键值。 + */ +PROOF extern thm gmap_ra_singleton_op_fresh; + +/* + * ```text + * forall (R:(V)ra) (key:K) (a:V) (b:V). + * ra_update R a b ==> + * ra_update + * (gmap_ra R) + * (finmap_singleton key a) + * (finmap_singleton key b) + * ``` + * + * payload `a` 可更新为 `b` 时，单点 gmap `key -> a` 也可更新为 `key -> b`。 + */ +PROOF extern thm gmap_ra_update_singleton; + +/* + * ```text + * forall (R:(V)ra) (key:K) (a:V) (P:V->bool). + * ra_updateP R a P ==> + * ra_updateP + * (gmap_ra R) + * (finmap_singleton key a) + * (\m:(K,V)finmap. + * exists b:V. + * P b && m == finmap_singleton key b) + * ``` + * + * payload `a` 可更新到满足 `P` 的值时，单点 gmap `key -> a` 可更新到以同一键承载某个满足 `P` 的 `b`。 + */ +PROOF extern thm gmap_ra_updateP_singleton; + +/* + * ```text + * forall + * (R:(V)ra) + * (candidates:K->bool) + * (m:(K,V)finmap) + * (a:V). + * INFINITE candidates ==> + * ra_valid R a ==> + * ra_updateP + * (gmap_ra R) + * m + * (\result:(K,V)finmap. + * exists key:K. + * key IN candidates && + * finmap_lookup m key == NONE && + * result == finmap_insert key a m) + * ``` + * + * 候选键集无限且 `a` 有效时，`m` 可更新为在某个候选空缺键上插入 `a` 的映射。 + */ +PROOF extern thm gmap_ra_alloc_strong; diff --git a/theory/logic/local_update.c b/theory/logic/local_update.c new file mode 100644 index 0000000000000000000000000000000000000000..19f5c162dad28f4344d1b4b8782c8091dc54a617 --- /dev/null +++ b/theory/logic/local_update.c @@ -0,0 +1,543 @@ +#include "proof/theory/logic/local_update.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t LOCAL_UPDATE_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm ra_local_update_def = new_fun_definition(` + ra_local_update (R:(A)ra) (a:A) (f:A) (b:A) (g:A) <=> + forall residual:A. + ra_valid R a ==> + a == ra_op R f residual ==> + ra_valid R b && b == ra_op R g residual +`); + +/* The public eliminator avoids unfolding the relation at each call site. */ +PROOF static thm prove_ra_local_update_apply(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A) (residual:A). + ra_local_update R a f b g ==> + ra_valid R a ==> + a == ra_op R f residual ==> + ra_valid R b && b == ra_op R g residual + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + mp_rule( + spec_rule( + `residual:A`, + assume_rule(` + forall residual:A. + ra_valid (R:(A)ra) (a:A) ==> + a == ra_op R (f:A) residual ==> + ra_valid R (b:A) && + b == ra_op R (g:A) residual + `)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)), + assume_rule(` + (a:A) == ra_op (R:(A)ra) (f:A) (residual:A) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_local_update_apply = + prove_ra_local_update_apply(); + +PROOF static thm prove_ra_local_update_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A). + ra_local_update R a f a f + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + ACCEPT_TAC( + result[1], + assume_rule(` + (a:A) == ra_op (R:(A)ra) (f:A) (residual:A) + `)); + return gnode_prove(root); +} + +PROOF thm ra_local_update_refl = + prove_ra_local_update_refl(); + +PROOF static thm prove_ra_local_update_trans(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A) (c:A) (h:A). + ra_local_update R a f b g ==> + ra_local_update R b g c h ==> + ra_local_update R a f c h + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + + thm middle_result = mp_rule( + mp_rule( + spec_rule( + `residual:A`, + assume_rule(` + forall residual:A. + ra_valid (R:(A)ra) (a:A) ==> + a == ra_op R (f:A) residual ==> + ra_valid R (b:A) && + b == ra_op R (g:A) residual + `)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)), + assume_rule(` + (a:A) == ra_op (R:(A)ra) (f:A) (residual:A) + `)); + thm target_result = mp_rule( + mp_rule( + spec_rule( + `residual:A`, + assume_rule(` + forall residual:A. + ra_valid (R:(A)ra) (b:A) ==> + b == ra_op R (g:A) residual ==> + ra_valid R (c:A) && + c == ra_op R (h:A) residual + `)), + conjunct1_rule(middle_result)), + conjunct2_rule(middle_result)); + ACCEPT_TAC(body, target_result); + return gnode_prove(root); +} + +PROOF thm ra_local_update_trans = + prove_ra_local_update_trans(); + +PROOF static thm prove_ra_local_update_frame(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) (f:A) + (b:A) (g:A) + (extra:A). + ra_local_update R a f b g ==> + ra_local_update R a (ra_op R f extra) b (ra_op R g extra) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + + thm source_reassociated = trans_rule( + assume_rule(` + (a:A) == + ra_op + (R:(A)ra) + (ra_op R (f:A) (extra:A)) + (residual:A) + `), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `f:A`, `extra:A`, `residual:A`), + ra_assoc)); + thm updated = mp_rule( + mp_rule( + spec_rule( + `ra_op (R:(A)ra) (extra:A) (residual:A)`, + assume_rule(` + forall residual:A. + ra_valid (R:(A)ra) (a:A) ==> + a == ra_op R (f:A) residual ==> + ra_valid R (b:A) && + b == ra_op R (g:A) residual + `)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)), + source_reassociated); + + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], conjunct1_rule(updated)); + thm target_reassociated = trans_rule( + conjunct2_rule(updated), + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `g:A`, `extra:A`, `residual:A`), + ra_assoc))); + ACCEPT_TAC(result[1], target_reassociated); + return gnode_prove(root); +} + +PROOF thm ra_local_update_frame = + prove_ra_local_update_frame(); + +PROOF static thm prove_ra_local_update_preserves_included(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) (f:A) + (b:A) (g:A) + (external:A). + ra_local_update R a f b g ==> + ra_valid R a ==> + ra_included R (ra_op R f external) a ==> + ra_valid R b && + ra_included R (ra_op R g external) b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm included = rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (R:(A)ra) + (ra_op R (f:A) (external:A)) + (a:A) + `)); + body = ASSUME_TAC(body, included, "Hincluded_witness"); + body = ASMP_EXISTS_TAC(body, "Hincluded_witness", "slack"); + + thm source_reassociated = trans_rule( + assume_rule(` + (a:A) == + ra_op + (R:(A)ra) + (ra_op R (f:A) (external:A)) + (slack:A) + `), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `f:A`, `external:A`, `slack:A`), + ra_assoc)); + thm local_at_residual = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`, + `ra_op (R:(A)ra) (external:A) (slack:A)`), + ra_local_update_apply); + thm updated = mp_rule( + mp_rule( + mp_rule( + local_at_residual, + assume_rule(`ra_local_update (R:(A)ra) (a:A) (f:A) (b:A) (g:A)`)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)), + source_reassociated); + + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], conjunct1_rule(updated)); + gnode included_target = CONV_TAC( + result[1], + pure_once_rewrite_conv(THM_LIST(ra_included_def))); + included_target = EXISTS_TAC(included_target, `slack:A`); + ACCEPT_TAC( + included_target, + trans_rule( + conjunct2_rule(updated), + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `g:A`, `external:A`, `slack:A`), + ra_assoc)))); + return gnode_prove(root); +} + +PROOF thm ra_local_update_preserves_included = + prove_ra_local_update_preserves_included(); + +PROOF static thm prove_ra_local_update_op(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (piece:A). + (ra_valid R a ==> + ra_valid R (ra_op R a piece)) ==> + ra_local_update R a f (ra_op R a piece) (ra_op R f piece) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + mp_rule( + assume_rule(` + ra_valid (R:(A)ra) (a:A) ==> + ra_valid R (ra_op R a (piece:A)) + `), + assume_rule(`ra_valid (R:(A)ra) (a:A)`))); + + thm lifted_source = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) x (piece:A)`, + assume_rule(` + (a:A) == + ra_op (R:(A)ra) (f:A) (residual:A) + `))); + thm swapped = ispecl_rule( + TERM_LIST(`R:(A)ra`, `f:A`, `residual:A`, `piece:A`), + ra_op_swap_right); + ACCEPT_TAC(result[1], trans_rule(lifted_source, swapped)); + return gnode_prove(root); +} + +PROOF static thm ra_local_update_op = + prove_ra_local_update_op(); + +PROOF static thm prove_ra_local_update_alloc(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (piece:A). + ra_valid R (ra_op R a piece) ==> + ra_local_update R a f (ra_op R a piece) (ra_op R f piece) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = MATCH_MP_TAC( + body, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `f:A`, `piece:A`), + ra_local_update_op)); + body = DISCH_TAC(body, "Hvalid_source"); + ACCEPT_TAC( + body, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (piece:A)) + `)); + return gnode_prove(root); +} + +PROOF thm ra_local_update_alloc = + prove_ra_local_update_alloc(); + +PROOF static thm prove_ra_local_update_maximal(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A). + ra_maximal R f ==> + ra_valid R b ==> + ra_local_update R a f b b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + + thm source_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (R:(A)ra)`, + assume_rule(` + (a:A) == + ra_op (R:(A)ra) (f:A) (residual:A) + `)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R:(A)ra) (f:A)`)); + maximal = conjunct2_rule(maximal); + thm frame_is_unit = mp_rule( + spec_rule(`residual:A`, maximal), + source_valid); + + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], assume_rule(`ra_valid (R:(A)ra) (b:A)`)); + thm replace_frame = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) (b:A) x`, + frame_is_unit)); + ACCEPT_TAC( + result[1], + trans_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`), + ra_unit_r)), + gsym_rule(replace_frame))); + return gnode_prove(root); +} + +PROOF thm ra_local_update_maximal = + prove_ra_local_update_maximal(); + +PROOF static thm prove_ra_local_update_cancel(void) { + term goal_tm = ` + forall (R:(A)ra) (common:A) (a:A) (f:A). + ra_cancellative R ==> + ra_local_update R (ra_op R common a) (ra_op R common f) a f + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `common:A`, `a:A`), + ra_valid_op_r), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (common:A) (a:A)) + `))); + + thm normalized_source = trans_rule( + assume_rule(` + ra_op (R:(A)ra) (common:A) (a:A) == + ra_op R + (ra_op R common (f:A)) + (residual:A) + `), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `common:A`, `f:A`, `residual:A`), + ra_assoc)); + thm cancelled = mp_rule( + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `common:A`, + `a:A`, + `ra_op (R:(A)ra) (f:A) (residual:A)`), + ra_cancellative_apply), + assume_rule(`ra_cancellative (R:(A)ra)`)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (common:A) (a:A)) + `)), + normalized_source); + ACCEPT_TAC(result[1], cancelled); + return gnode_prove(root); +} + +PROOF thm ra_local_update_cancel = + prove_ra_local_update_cancel(); + +PROOF static thm prove_ra_local_update_cancel_unit(void) { + term goal_tm = ` + forall (R:(A)ra) (common:A) (a:A). + ra_cancellative R ==> + ra_local_update R (ra_op R common a) common a (ra_unit R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm result = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `common:A`, + `a:A`, + `ra_unit (R:(A)ra)`), + ra_local_update_cancel); + result = mp_rule(result, assume_rule(`ra_cancellative (R:(A)ra)`)); + result = rewrite_rule( + THM_LIST(ispecl_rule( + TERM_LIST(`R:(A)ra`, `common:A`), + ra_unit_r)), + result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF static thm ra_local_update_cancel_unit = + prove_ra_local_update_cancel_unit(); + +PROOF static thm prove_ra_local_update_cancellative(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (common:A). + ra_cancellative R ==> + ra_valid R (ra_op R b common) ==> + ra_local_update R (ra_op R a common) a (ra_op R b common) b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm cancelled = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `common:A`), + ra_local_update_cancel_unit), + assume_rule(`ra_cancellative (R:(A)ra)`)); + thm allocated = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `common:A`, + `ra_unit (R:(A)ra)`, + `b:A`), + ra_local_update_alloc), + eq_mp_rule( + ap_term_rule( + `ra_valid (R:(A)ra)`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`, `common:A`), + ra_comm)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (b:A) (common:A)) + `))); + thm composed = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (common:A)`, + `a:A`, + `common:A`, + `ra_unit (R:(A)ra)`, + `ra_op (R:(A)ra) (common:A) (b:A)`, + `ra_op (R:(A)ra) (ra_unit R) (b:A)`), + ra_local_update_trans), + cancelled), + allocated); + thm normalized = rewrite_rule( + THM_LIST( + ispecl_rule(TERM_LIST(`R:(A)ra`, `common:A`, `b:A`), ra_comm), + ispecl_rule(TERM_LIST(`R:(A)ra`, `b:A`), ra_unit_l)), + composed); + ACCEPT_TAC(body, normalized); + return gnode_prove(root); +} + +PROOF thm ra_local_update_cancellative = + prove_ra_local_update_cancellative(); + +PROOF static int audit_local_update(void) { + thm_list public_theorems = THM_LIST( + ra_local_update_def, + ra_local_update_apply, + ra_local_update_refl, + ra_local_update_trans, + ra_local_update_frame, + ra_local_update_preserves_included, + ra_local_update_alloc, + ra_local_update_maximal, + ra_local_update_cancel, + ra_local_update_cancellative); + + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "local-update theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "local-update theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == LOCAL_UPDATE_AXIOMS_BEFORE, + "local-update theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_local_update"); + return -1; +} + +PROOF static int _LOCAL_UPDATE_AUDIT = + audit_local_update(); diff --git a/theory/logic/local_update.h b/theory/logic/local_update.h new file mode 100644 index 0000000000000000000000000000000000000000..d6e9e33a2ec73c2c149be31b341171af1ab512fc --- /dev/null +++ b/theory/logic/local_update.h @@ -0,0 +1,137 @@ +#pragma once + +/* + * Five-argument local updates. + * + * `ra_local_update R a f b g` changes whole/local ownership `(a,f)` to + * `(b,g)` while preserving the same unknown residual. Here `a` and `b` are + * whole resources and `f` and `g` are the visible local fragments. + */ + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Definition and elimination */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_local_update R a f b g <=> + * (forall residual. + * ra_valid R a + * ==> a == ra_op R f residual + * ==> ra_valid R b && b == ra_op R g residual) + * ``` + * + * `(a,f)` 可局部更新为 `(b,g)`，当且仅当每种将有效 `a` 分解为 `f ⋅ residual` 的方式都能保留该 residual，并得到有效的 `b = g ⋅ residual`。 + */ +PROOF extern thm ra_local_update_def; + +/* + * ```text + * forall R a f b g residual. + * ra_local_update R a f b g + * ==> ra_valid R a + * ==> a == ra_op R f residual + * ==> ra_valid R b && b == ra_op R g residual + * ``` + * + * 若局部更新 `(a,f) -> (b,g)` 成立，且有效的 `a` 等于 `f ⋅ residual`，则 `b` 有效且等于 `g ⋅ residual`。 + */ +PROOF extern thm ra_local_update_apply; + +/* ------------------------------------------------------------------------- */ +/* Structural rules */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a f. ra_local_update R a f a f + * ``` + * + * 任意 whole/local 对 `(a,f)` 都可保持不变地局部更新为自身。 + */ +PROOF extern thm ra_local_update_refl; + +/* + * ```text + * forall R a f b g c h. + * ra_local_update R a f b g + * ==> ra_local_update R b g c h + * ==> ra_local_update R a f c h + * ``` + * + * 局部更新可传递：`(a,f) -> (b,g)` 与 `(b,g) -> (c,h)` 可串联为 `(a,f) -> (c,h)`。 + */ +PROOF extern thm ra_local_update_trans; + +/* + * ```text + * forall R a f b g extra. + * ra_local_update R a f b g + * ==> ra_local_update R a (ra_op R f extra) b (ra_op R g extra) + * ``` + * + * 对局部更新 `(a,f) -> (b,g)`，在新旧可见片段上同时附加 `extra` 后仍是局部更新。 + */ +PROOF extern thm ra_local_update_frame; + +/* + * ```text + * forall R a f b g external. + * ra_local_update R a f b g + * ==> ra_valid R a + * ==> ra_included R (ra_op R f external) a + * ==> ra_valid R b && ra_included R (ra_op R g external) b + * ``` + * + * 若 `(a,f) -> (b,g)` 是局部更新、`a` 有效且包含 `f ⋅ external`，则 `b` 有效且包含 `g ⋅ external`。 + */ +PROOF extern thm ra_local_update_preserves_included; + +/* ------------------------------------------------------------------------- */ +/* Standard local updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a f piece. + * ra_valid R (ra_op R a piece) + * ==> ra_local_update R a f (ra_op R a piece) (ra_op R f piece) + * ``` + * + * 若 `a ⋅ piece` 有效，则可将 whole 从 `a` 扩展为 `a ⋅ piece`，并在 local 片段 `f` 上同步分配 `piece`。 + */ +PROOF extern thm ra_local_update_alloc; + +/* + * ```text + * forall R a f b. ra_maximal R f ==> ra_valid R b ==> ra_local_update R a f b b + * ``` + * + * 若可见片段 `f` 为 maximal 且 `b` 有效，则 whole/local 对 `(a,f)` 可局部更新为 `(b,b)`。 + */ +PROOF extern thm ra_local_update_maximal; + +/* + * ```text + * forall R common a f. + * ra_cancellative R + * ==> ra_local_update R (ra_op R common a) (ra_op R common f) a f + * ``` + * + * 在可消去 RA 中，可从 whole 和 local 片段中同时消去公共分量 `common`，将 `(common ⋅ a, common ⋅ f)` 更新为 `(a,f)`。 + */ +PROOF extern thm ra_local_update_cancel; + +/* + * ```text + * forall R a b common. + * ra_cancellative R + * ==> ra_valid R (ra_op R b common) + * ==> ra_local_update R (ra_op R a common) a (ra_op R b common) b + * ``` + * + * 在可消去 RA 中，若 `b ⋅ common` 有效，则可保留隐含的 `common` 并将 whole/local 对从 `(a ⋅ common,a)` 更新为 `(b ⋅ common,b)`。 + */ +PROOF extern thm ra_local_update_cancellative; diff --git a/theory/logic/max_nat_ra.c b/theory/logic/max_nat_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..187d9a9263a6866556f769f2517b8012f211784e --- /dev/null +++ b/theory/logic/max_nat_ra.c @@ -0,0 +1,768 @@ +#include "proof/theory/logic/max_nat_ra.h" +#include "proof/theory/logic/ra_builder.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t MAX_NAT_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +/* ------------------------------------------------------------------------- */ +/* Natural-number maximum facts used by the raw descriptor */ +/* ------------------------------------------------------------------------- */ + +/* + * HOL Light exposes `MAX` by its conditional definition but does not register + * the usual natural-number semilattice equations as separate named theorems. + * We obtain them predictably from the corresponding integer maximum laws and + * the injective natural-to-integer embedding. + */ +PROOF static thm prove_max_nat_assoc_raw(void) { + term a = `a:num`; + term b = `b:num`; + term c = `c:num`; + thm integer_assoc = ispecl_rule( + TERM_LIST(`&(a:num):int`, `&(b:num):int`, `&(c:num):int`), + get_theorem_by_name("INT_MAX_ASSOC")); + thm natural_assoc = rewrite_rule( + THM_LIST( + get_theorem_by_name("INT_OF_NUM_MAX"), + get_theorem_by_name("INT_OF_NUM_EQ")), + integer_assoc); + natural_assoc = gsym_rule(natural_assoc); + natural_assoc = gen_rule(c, natural_assoc); + natural_assoc = gen_rule(b, natural_assoc); + return gen_rule(a, natural_assoc); +} + +PROOF static thm max_nat_assoc_raw = + prove_max_nat_assoc_raw(); + +PROOF static thm prove_max_nat_comm_raw(void) { + term a = `a:num`; + term b = `b:num`; + thm integer_comm = ispecl_rule( + TERM_LIST(`&(a:num):int`, `&(b:num):int`), + get_theorem_by_name("INT_MAX_SYM")); + thm natural_comm = rewrite_rule( + THM_LIST( + get_theorem_by_name("INT_OF_NUM_MAX"), + get_theorem_by_name("INT_OF_NUM_EQ")), + integer_comm); + natural_comm = gen_rule(b, natural_comm); + return gen_rule(a, natural_comm); +} + +PROOF static thm max_nat_comm_raw = + prove_max_nat_comm_raw(); + +PROOF static thm prove_max_nat_zero_left_raw(void) { + term n = `n:num`; + thm unfolded = ispecl_rule( + TERM_LIST(`0`, n), + get_theorem_by_name("MAX")); + thm reduced = rewrite_rule( + THM_LIST(spec_rule(n, get_theorem_by_name("LE_0"))), + unfolded); + return gen_rule(n, reduced); +} + +PROOF static thm max_nat_zero_left_raw = + prove_max_nat_zero_left_raw(); + +PROOF static thm prove_max_nat_le_left_raw(void) { + term a = `a:num`; + term b = `b:num`; + thm integer_bounds = ispecl_rule( + TERM_LIST(`&(a:num):int`, `&(b:num):int`), + get_theorem_by_name("INT_MAX_MAX")); + thm natural_bounds = rewrite_rule( + THM_LIST( + get_theorem_by_name("INT_OF_NUM_MAX"), + get_theorem_by_name("INT_OF_NUM_LE")), + integer_bounds); + thm result = conjunct1_rule(natural_bounds); + result = gen_rule(b, result); + return gen_rule(a, result); +} + +PROOF static thm max_nat_le_left_raw = + prove_max_nat_le_left_raw(); + +PROOF static thm prove_max_nat_le_raw(void) { + term a = `a:num`; + term b = `b:num`; + term bound = `bound:num`; + thm integer_bound = ispecl_rule( + TERM_LIST( + `&(a:num):int`, + `&(b:num):int`, + `&(bound:num):int`), + get_theorem_by_name("INT_MAX_LE")); + thm natural_bound = rewrite_rule( + THM_LIST( + get_theorem_by_name("INT_OF_NUM_MAX"), + get_theorem_by_name("INT_OF_NUM_LE")), + integer_bound); + natural_bound = gen_rule(bound, natural_bound); + natural_bound = gen_rule(b, natural_bound); + return gen_rule(a, natural_bound); +} + +PROOF static thm max_nat_le_raw = + prove_max_nat_le_raw(); + +PROOF static thm prove_max_nat_eq_right_raw(void) { + term goal_tm = ` + forall a b:num. + a <= b ==> MAX a b == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hab"); + + thm unfolded = ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + get_theorem_by_name("MAX")); + thm reduced = pure_once_rewrite_rule( + THM_LIST(assume_rule(`(a:num) <= (b:num)`)), + unfolded); + reduced = rewrite_rule( + THM_LIST(get_theorem_by_name("COND_CLAUSES")), + reduced); + ACCEPT_TAC(body, reduced); + return gnode_prove(root); +} + +PROOF static thm max_nat_eq_right_raw = + prove_max_nat_eq_right_raw(); + +/* ------------------------------------------------------------------------- */ +/* Raw descriptor and intrinsic laws */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm max_nat_op_def = new_fun_definition(` + max_nat_op (a:num) (b:num) : num = MAX a b +`); + +PROOF static thm max_nat_valid_def = new_fun_definition(` + max_nat_valid (a:num) <=> T +`); + +PROOF static thm prove_max_nat_ra_laws(void) { + term goal_tm = ` + ra_laws (0:num) max_nat_op max_nat_valid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode unfolded = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + CONV_TAC( + assoc, + rewrite_conv(THM_LIST( + max_nat_op_def, + max_nat_assoc_raw))); + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + CONV_TAC( + comm, + rewrite_conv(THM_LIST( + max_nat_op_def, + max_nat_comm_raw))); + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = AUTO_INTROS_TAC(law3[0]); + CONV_TAC( + unit, + rewrite_conv(THM_LIST( + max_nat_op_def, + max_nat_zero_left_raw))); + + gnode_list law4 = CONJ_TAC(law3[1]); + CONV_TAC( + law4[0], + rewrite_conv(THM_LIST(max_nat_valid_def))); + CONV_TAC( + law4[1], + rewrite_conv(THM_LIST(max_nat_valid_def))); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_laws = + prove_max_nat_ra_laws(); + +PROOF static thm max_nat_ra_def = new_fun_definition(` + max_nat_ra : (num)ra = + ra_abs ((0:num),(max_nat_op,max_nat_valid)) +`); + +/* ------------------------------------------------------------------------- */ +/* Abstract projections */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_max_nat_ra_unit(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `0:num`, + `max_nat_op:num->num->num`, + `max_nat_valid:num->bool`), + ra_unit_abs), + max_nat_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(max_nat_ra_def)), + computed); +} + +PROOF thm max_nat_ra_unit = + prove_max_nat_ra_unit(); + +PROOF static thm prove_max_nat_ra_op_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `0:num`, + `max_nat_op:num->num->num`, + `max_nat_valid:num->bool`), + ra_op_abs), + max_nat_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(max_nat_ra_def)), + computed); +} + +PROOF static thm max_nat_ra_op_fn = + prove_max_nat_ra_op_fn(); + +PROOF static thm prove_max_nat_ra_valid_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `0:num`, + `max_nat_op:num->num->num`, + `max_nat_valid:num->bool`), + ra_valid_abs), + max_nat_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(max_nat_ra_def)), + computed); +} + +PROOF static thm max_nat_ra_valid_fn = + prove_max_nat_ra_valid_fn(); + +PROOF static thm prove_max_nat_ra_op(void) { + term goal_tm = ` + forall a b:num. + ra_op max_nat_ra a b == MAX a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + max_nat_ra_op_fn, + max_nat_op_def))); + return gnode_prove(root); +} + +PROOF thm max_nat_ra_op = + prove_max_nat_ra_op(); + +PROOF static thm prove_max_nat_ra_valid(void) { + term goal_tm = ` + forall n:num. ra_valid max_nat_ra n + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + max_nat_ra_valid_fn, + max_nat_valid_def))); + return gnode_prove(root); +} + +PROOF thm max_nat_ra_valid = + prove_max_nat_ra_valid(); + +/* ------------------------------------------------------------------------- */ +/* Inclusion and maximum laws */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_max_nat_ra_included(void) { + term goal_tm = ` + forall a b:num. + ra_included max_nat_ra a b <=> a <= b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "b"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + forward = ASMP_EXISTS_TAC( + forward, + "Hincluded", + "frame"); + thm framed = trans_rule( + assume_rule(` + (b:num) == + ra_op max_nat_ra (a:num) (frame:num) + `), + ispecl_rule( + TERM_LIST(`a:num`, `frame:num`), + max_nat_ra_op)); + thm transport = beta_rule(ap_term_rule( + `\x:num. (a:num) <= x`, + framed)); + thm lower_bound = ispecl_rule( + TERM_LIST(`a:num`, `frame:num`), + max_nat_le_left_raw); + ACCEPT_TAC( + forward, + eq_mp_rule(gsym_rule(transport), lower_bound)); + + gnode reverse = DISCH_TAC(directions[1], "Hle"); + reverse = EXISTS_TAC(reverse, `b:num`); + thm op_computation = ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_ra_op); + thm maximum = mp_rule( + ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_eq_right_raw), + assume_rule(`(a:num) <= (b:num)`)); + ACCEPT_TAC( + reverse, + gsym_rule(trans_rule(op_computation, maximum))); + return gnode_prove(root); +} + +PROOF thm max_nat_ra_included = + prove_max_nat_ra_included(); + +PROOF static thm prove_max_nat_ra_included_zero(void) { + term goal_tm = ` + forall n:num. ra_included max_nat_ra 0 n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "n"); + thm characterization = ispecl_rule( + TERM_LIST(`0`, `n:num`), + max_nat_ra_included); + thm zero_bound = spec_rule( + `n:num`, + get_theorem_by_name("LE_0")); + ACCEPT_TAC( + body, + eq_mp_rule(gsym_rule(characterization), zero_bound)); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_included_zero = + prove_max_nat_ra_included_zero(); + +PROOF static thm prove_max_nat_ra_included_op(void) { + term goal_tm = ` + forall a b bound:num. + ra_included + max_nat_ra + (ra_op max_nat_ra a b) + bound <=> + a <= bound && b <= bound + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + max_nat_ra_included, + max_nat_ra_op, + max_nat_le_raw))); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_included_op = + prove_max_nat_ra_included_op(); + +PROOF static thm prove_max_nat_ra_idempotent(void) { + term goal_tm = ` + forall n:num. ra_op max_nat_ra n n == n + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "n"); + thm op_computation = ispecl_rule( + TERM_LIST(`n:num`, `n:num`), + max_nat_ra_op); + thm maximum = mp_rule( + ispecl_rule( + TERM_LIST(`n:num`, `n:num`), + max_nat_eq_right_raw), + spec_rule(`n:num`, get_theorem_by_name("LE_REFL"))); + ACCEPT_TAC( + body, + trans_rule(op_computation, maximum)); + return gnode_prove(root); +} + +PROOF thm max_nat_ra_idempotent = + prove_max_nat_ra_idempotent(); + +PROOF static thm prove_max_nat_ra_op_eq_right(void) { + term goal_tm = ` + forall a b:num. + a <= b ==> ra_op max_nat_ra a b == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hab"); + thm op_computation = ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_ra_op); + thm maximum = mp_rule( + ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_eq_right_raw), + assume_rule(`(a:num) <= (b:num)`)); + ACCEPT_TAC( + body, + trans_rule(op_computation, maximum)); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_op_eq_right = + prove_max_nat_ra_op_eq_right(); + +PROOF static thm prove_max_nat_ra_op_eq_left(void) { + term goal_tm = ` + forall a b:num. + b <= a ==> ra_op max_nat_ra a b == a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hba"); + + thm op_computation = ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_ra_op); + thm commute = ispecl_rule( + TERM_LIST(`a:num`, `b:num`), + max_nat_comm_raw); + thm maximum = mp_rule( + ispecl_rule( + TERM_LIST(`b:num`, `a:num`), + max_nat_eq_right_raw), + assume_rule(`(b:num) <= (a:num)`)); + ACCEPT_TAC( + body, + trans_rule( + op_computation, + trans_rule(commute, maximum))); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_op_eq_left = + prove_max_nat_ra_op_eq_left(); + +/* All frames are compatible because validity is total; choosing frame one + * refutes frame-maximality for every source. */ +PROOF static thm prove_max_nat_ra_not_maximal(void) { + term goal_tm = ` + forall n:num. ~(ra_maximal max_nat_ra n) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "n"); + body = DISCH_TAC(body, "Hmaximal"); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal max_nat_ra (n:num)`)); + maximal = conjunct2_rule(maximal); + thm frame_is_unit = mp_rule( + spec_rule(`1`, maximal), + ispec_rule( + `ra_op max_nat_ra (n:num) 1`, + max_nat_ra_valid)); + frame_is_unit = rewrite_rule( + THM_LIST(max_nat_ra_unit), + frame_is_unit); + thm contradiction = not_elim_rule( + arith_rule(`~((1:num) == 0)`), + frame_is_unit); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_not_maximal = + prove_max_nat_ra_not_maximal(); + +/* The common frame one absorbs both zero and one, witnessing failure of + * cancellativity. */ +PROOF static thm prove_max_nat_ra_not_cancellative(void) { + term goal_tm = `~(ra_cancellative max_nat_ra)`; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = DISCH_TAC(root, "Hcancellative"); + thm left_op = mp_rule( + ispecl_rule( + TERM_LIST(`1`, `0`), + max_nat_ra_op_eq_left), + spec_rule(`1`, get_theorem_by_name("LE_0"))); + thm right_op = ispec_rule(`1`, max_nat_ra_idempotent); + thm forced_equal = ispecl_rule( + TERM_LIST( + `max_nat_ra`, + `1`, + `0`, + `1`), + ra_cancellative_apply); + forced_equal = mp_rule( + forced_equal, + assume_rule(`ra_cancellative max_nat_ra`)); + forced_equal = mp_rule( + forced_equal, + ispec_rule( + `ra_op max_nat_ra 1 0`, + max_nat_ra_valid)); + forced_equal = mp_rule( + forced_equal, + trans_rule(left_op, gsym_rule(right_op))); + thm contradiction = not_elim_rule( + arith_rule(`~((0:num) == 1)`), + forced_equal); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_not_cancellative = + prove_max_nat_ra_not_cancellative(); + +PROOF static thm prove_max_nat_ra_included_mono_right(void) { + term goal_tm = ` + forall old new fragment:num. + old <= new ==> + ra_included max_nat_ra fragment old ==> + ra_included max_nat_ra fragment new + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "old"); + body = GEN_TAC(body, "new"); + body = GEN_TAC(body, "fragment"); + body = DISCH_TAC(body, "Hmonotone"); + body = DISCH_TAC(body, "Hincluded"); + + thm old_characterization = ispecl_rule( + TERM_LIST(`fragment:num`, `old:num`), + max_nat_ra_included); + thm fragment_le_old = eq_mp_rule( + old_characterization, + assume_rule(` + ra_included max_nat_ra (fragment:num) (old:num) + `)); + thm fragment_le_new = mp_rule( + ispecl_rule( + TERM_LIST( + `fragment:num`, + `old:num`, + `new:num`), + get_theorem_by_name("LE_TRANS")), + conj_rule( + fragment_le_old, + assume_rule(`(old:num) <= (new:num)`))); + thm new_characterization = ispecl_rule( + TERM_LIST(`fragment:num`, `new:num`), + max_nat_ra_included); + ACCEPT_TAC( + body, + eq_mp_rule(gsym_rule(new_characterization), fragment_le_new)); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_included_mono_right = + prove_max_nat_ra_included_mono_right(); + +/* ------------------------------------------------------------------------- */ +/* Frame-preserving updates */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prove_max_nat_ra_update(void) { + term goal_tm = ` + forall old new:num. + ra_update max_nat_ra old new + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + ra_update_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `new:num`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], refl_rule(`new:num`)); + ACCEPT_TAC( + result[1], + spec_rule( + `ra_op max_nat_ra (new:num) (frame:num)`, + max_nat_ra_valid)); + return gnode_prove(root); +} + +PROOF thm max_nat_ra_update = + prove_max_nat_ra_update(); + +PROOF static thm prove_max_nat_ra_updateP(void) { + term goal_tm = ` + forall (old:num) (P:num->bool). + (exists new:num. P new) ==> + ra_updateP max_nat_ra old P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "old"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hinhabited"); + body = ASMP_EXISTS_TAC( + body, + "Hinhabited", + "new"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hsource_valid"); + body = EXISTS_TAC(body, `new:num`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`(P:num->bool) (new:num)`)); + ACCEPT_TAC( + result[1], + spec_rule( + `ra_op max_nat_ra (new:num) (frame:num)`, + max_nat_ra_valid)); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_updateP = + prove_max_nat_ra_updateP(); + +PROOF static thm prove_max_nat_ra_updateP_iff(void) { + term goal_tm = ` + forall (old:num) (P:num->bool). + ra_updateP max_nat_ra old P <=> + exists new:num. P new + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hupdate"); + thm selected = ispecl_rule( + TERM_LIST( + `max_nat_ra:(num)ra`, + `old:num`, + `P:num->bool`), + ra_updateP_valid); + selected = mp_rule( + selected, + assume_rule(` + ra_updateP + max_nat_ra + (old:num) + (P:num->bool) + `)); + selected = mp_rule( + selected, + ispec_rule(`old:num`, max_nat_ra_valid)); + forward = ASSUME_TAC( + forward, selected, "Hselected"); + forward = ASMP_EXISTS_TAC( + forward, "Hselected", "new"); + forward = ASMP_CONJ_TAC( + forward, + "Hselected", + "HP_new", + "Hvalid_new"); + forward = EXISTS_TAC(forward, `new:num`); + ACCEPT_TAC( + forward, + assume_rule(`(P:num->bool) (new:num)`)); + + gnode reverse = DISCH_TAC( + directions[1], "Hinhabited"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST(`old:num`, `P:num->bool`), + max_nat_ra_updateP), + assume_rule(`exists new:num. (P:num->bool) new`))); + return gnode_prove(root); +} + +PROOF static thm max_nat_ra_updateP_iff = + prove_max_nat_ra_updateP_iff(); + +/* ------------------------------------------------------------------------- */ +/* Construction audit */ +/* ------------------------------------------------------------------------- */ + +PROOF static int audit_max_nat_ra(void) { + thm_list audited_theorems = THM_LIST( + max_nat_assoc_raw, + max_nat_comm_raw, + max_nat_zero_left_raw, + max_nat_le_left_raw, + max_nat_le_raw, + max_nat_eq_right_raw, + max_nat_op_def, + max_nat_valid_def, + max_nat_ra_laws, + max_nat_ra_def, + max_nat_ra_unit, + max_nat_ra_op_fn, + max_nat_ra_valid_fn, + max_nat_ra_op, + max_nat_ra_valid, + max_nat_ra_included, + max_nat_ra_included_zero, + max_nat_ra_included_op, + max_nat_ra_idempotent, + max_nat_ra_op_eq_right, + max_nat_ra_op_eq_left, + max_nat_ra_not_maximal, + max_nat_ra_not_cancellative, + max_nat_ra_included_mono_right, + max_nat_ra_update, + max_nat_ra_updateP, + max_nat_ra_updateP_iff); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "max-nat RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "max-nat RA theorem %zu has hypotheses", i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == MAX_NAT_RA_AXIOMS_BEFORE, + "max-nat RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_max_nat_ra"); + return -1; +} + +PROOF static int _MAX_NAT_RA_AUDIT = + audit_max_nat_ra(); diff --git a/theory/logic/max_nat_ra.h b/theory/logic/max_nat_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..b72a0985917440c897fba3c954ce841fff4369f2 --- /dev/null +++ b/theory/logic/max_nat_ra.h @@ -0,0 +1,74 @@ +#pragma once + +/* + * Public interface for the natural-number maximum resource algebra. + * + * `max_nat_ra:(num)ra` has unit `0`, operation `MAX`, and total validity. + * It is a useful idempotent fragment algebra; monotone authority protocols + * are obtained by placing it under `auth_ra`, not by restricting this base + * RA's universal frame-preserving update relation. + */ + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Algebra, validity, and order */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_unit max_nat_ra == 0 + * ``` + * + * max-nat RA 的 unit 是自然数 `0`。 + */ +PROOF extern thm max_nat_ra_unit; + +/* + * ```text + * forall a b. ra_op max_nat_ra a b == MAX a b + * ``` + * + * max-nat RA 中两个数的组合结果是它们的最大值。 + */ +PROOF extern thm max_nat_ra_op; + +/* + * ```text + * forall n. ra_valid max_nat_ra n + * ``` + * + * 每个自然数在 max-nat RA 中都有效。 + */ +PROOF extern thm max_nat_ra_valid; + +/* + * ```text + * forall a b. ra_included max_nat_ra a b <=> a <= b + * ``` + * + * `a` 在 max-nat RA 中包含于 `b`，当且仅当数值上 `a <= b`。 + */ +PROOF extern thm max_nat_ra_included; + +/* + * ```text + * forall n. ra_op max_nat_ra n n == n + * ``` + * + * 任意自然数 `n` 与自身取最大值仍等于 `n`。 + */ +PROOF extern thm max_nat_ra_idempotent; + +/* ------------------------------------------------------------------------- */ +/* Updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall old new. ra_update max_nat_ra old new + * ``` + * + * max-nat RA 中所有数及其与任意 frame 的组合都有效，因此任意 `old` 都可更新为任意 `new`。 + */ +PROOF extern thm max_nat_ra_update; diff --git a/theory/logic/named_logic.c b/theory/logic/named_logic.c new file mode 100644 index 0000000000000000000000000000000000000000..123b3221446229ceb535af124187a4079f07e6e0 --- /dev/null +++ b/theory/logic/named_logic.c @@ -0,0 +1,452 @@ +#include "proof/theory/logic/named_logic.h" +#include "proof/theory/logic/gmap_ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/basic_update.c" +#require "proof/theory/logic/named_ra.c" + +PROOF static size_t NAMED_LOGIC_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm named_own_def = new_fun_definition(` + named_own + (R:(A)ra) + (name:num) + (a:A) : (num,A)finmap->bool = + r_own (named_ra R) (finmap_singleton name a) +`); + +PROOF static thm prove_named_own_op(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (b:A). + r_equiv + (named_ra R) + (named_own R name (ra_op R a b)) + (r_sep + (named_ra R) + (named_own R name a) + (named_own R name b)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(named_own_def))); + thm result = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`, + `finmap_singleton (name:num) (b:A)`), + r_own_op); + result = rewrite_rule( + THM_LIST(named_ra_singleton_op), + result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm named_own_op = prove_named_own_op(); + +PROOF static thm prove_named_own_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A). + r_entails + (named_ra R) + (named_own R name a) + (r_sep + (named_ra R) + (r_fact (named_ra R) (ra_valid R a)) + (named_own R name a)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(named_own_def))); + thm result = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`), + r_own_valid); + result = rewrite_rule( + THM_LIST(named_ra_valid_singleton), + result); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm named_own_valid = prove_named_own_valid(); + +PROOF static thm prove_named_own_update(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (b:A). + ra_update R a b ==> + r_viewshift + (named_ra R) + (named_own R name a) + (named_own R name b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(named_own_def))); + thm map_update = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `name:num`, `a:A`, `b:A`), + named_ra_update_singleton), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`, + `finmap_singleton (name:num) (b:A)`), + r_own_update), + map_update); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm named_own_update = prove_named_own_update(); + +PROOF static thm prove_named_own_updateP(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (P:A->bool). + ra_updateP R a P ==> + r_viewshift + (named_ra R) + (named_own R name a) + (r_exists + (named_ra R) + (\b:A. + r_sep + (named_ra R) + (r_fact (named_ra R) (P b)) + (named_own R name b))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_def, + r_entails_def, + r_bupd_def, + named_own_def, + r_own_def, + r_exists_def, + r_sep_def, + r_fact_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "name"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hpayload_update"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Howned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + term_list payload_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hpayload_update")); + thm payload_update = eq_mp_rule( + gsym_rule(inst_rule( + TERM_PAIR_LIST( + (term_pair){`P:A->bool`, `result:A->bool`}), + ra_updateP_def)), + assume_rule(payload_terms[0])); + thm map_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `name:num`, + `a:A`, + `P:A->bool`), + named_ra_updateP_singleton), + payload_update); + thm unfolded = rewrite_rule(THM_LIST(ra_updateP_def), map_update); + thm source_eq = beta_rule(ap_term_rule( + `\base:(num,A)finmap. + ra_valid + (named_ra (R:(A)ra)) + (ra_op (named_ra R) base (frame:(num,A)finmap))`, + assume_rule(` + (owned:(num,A)finmap) == + finmap_singleton (name:num) (a:A) + `))); + thm source_valid = eq_mp_rule( + source_eq, + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (owned:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + thm selected = mp_rule( + spec_rule(`frame:(num,A)finmap`, unfolded), + source_valid); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC(body, "Hselected", "Himage", "Hvalid_selected"); + body = ASMP_EXISTS_TAC(body, "Himage", "b"); + body = ASMP_CONJ_TAC(body, "Himage", "HP", "Hselected_eq"); + + body = EXISTS_TAC(body, `selected:(num,A)finmap`); + gnode_list update_result = CONJ_TAC(body); + gnode post = EXISTS_TAC(update_result[0], `b:A`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST(r_sep_def, r_fact_def, r_own_def))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `ra_unit (named_ra (R:(A)ra))`); + post = EXISTS_TAC(post, `selected:(num,A)finmap`); + gnode_list split = CONJ_TAC(post); + ACCEPT_TAC( + split[0], + gsym_rule(ispecl_rule( + TERM_LIST(`named_ra (R:(A)ra)`, `selected:(num,A)finmap`), + ra_unit_l))); + gnode_list predicates = CONJ_TAC(split[1]); + gnode_list fact = CONJ_TAC(predicates[0]); + ACCEPT_TAC(fact[0], assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC(fact[1], refl_rule(`ra_unit (named_ra (R:(A)ra))`)); + ACCEPT_TAC( + predicates[1], + assume_rule(` + (selected:(num,A)finmap) == + finmap_singleton (name:num) (b:A) + `)); + ACCEPT_TAC( + update_result[1], + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (selected:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + return gnode_prove(root); +} + +PROOF thm named_own_updateP = prove_named_own_updateP(); + +PROOF static thm prove_named_own_drop(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A). + r_viewshift + (named_ra R) + (named_own R name a) + (r_emp (named_ra R)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(named_own_def))); + thm dropped = ispecl_rule( + TERM_LIST(`R:(A)ra`, `name:num`, `a:A`), + named_ra_drop); + thm own_update = mp_rule( + ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `finmap_singleton (name:num) (a:A)`, + `finmap_empty:(num,A)finmap`), + r_own_update), + dropped); + thm own_unit = ispec_rule(`named_ra (R:(A)ra)`, r_own_unit); + own_unit = rewrite_rule(THM_LIST(named_ra_unit, r_equiv_def), own_unit); + thm post_entails = conjunct1_rule(own_unit); + thm consequence = ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `r_own (named_ra (R:(A)ra)) + (finmap_singleton (name:num) (a:A))`, + `r_own (named_ra (R:(A)ra)) + (finmap_singleton (name:num) (a:A))`, + `r_own (named_ra (R:(A)ra)) + (finmap_empty:(num,A)finmap)`, + `r_emp (named_ra (R:(A)ra))`), + r_viewshift_mono); + consequence = mp_rule( + consequence, + ispecl_rule( + TERM_LIST( + `named_ra (R:(A)ra)`, + `r_own (named_ra (R:(A)ra)) + (finmap_singleton (name:num) (a:A))`), + r_entails_refl)); + consequence = mp_rule(consequence, own_update); + consequence = mp_rule(consequence, post_entails); + ACCEPT_TAC(body, consequence); + return gnode_prove(root); +} + +PROOF thm named_own_drop = prove_named_own_drop(); + +PROOF static thm prove_named_own_alloc(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (P:(num,A)finmap->bool). + ra_valid R a ==> + r_viewshift + (named_ra R) + P + (r_exists + (named_ra R) + (\name:num. + r_sep + (named_ra R) + (named_own R name a) + P)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_def, + r_entails_def, + r_bupd_def, + r_exists_def, + r_sep_def, + named_own_def, + r_own_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hvalid_a"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "HP"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + term_list valid_a_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hvalid_a")); + term_list source_pred_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("HP")); + thm source_pred = assume_rule(source_pred_terms[0]); + + thm allocation = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `owned:(num,A)finmap`, + `a:A`), + named_ra_alloc), + assume_rule(valid_a_terms[0])); + allocation = rewrite_rule(THM_LIST(ra_updateP_def), allocation); + thm selected = mp_rule( + spec_rule(`frame:(num,A)finmap`, allocation), + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (owned:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "result"); + body = ASMP_CONJ_TAC(body, "Hselected", "Hallocated", "Hvalid_result"); + body = ASMP_EXISTS_TAC(body, "Hallocated", "name"); + body = ASMP_CONJ_TAC(body, "Hallocated", "Hfresh", "Hresult_eq"); + + body = EXISTS_TAC(body, `result:(num,A)finmap`); + gnode_list update_result = CONJ_TAC(body); + gnode post = EXISTS_TAC(update_result[0], `name:num`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST(r_sep_def, named_own_def, r_own_def))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `finmap_singleton (name:num) (a:A)`); + post = EXISTS_TAC(post, `owned:(num,A)finmap`); + gnode_list split = CONJ_TAC(post); + thm op_fresh = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `name:num`, + `a:A`, + `owned:(num,A)finmap`), + gmap_ra_singleton_op_fresh), + assume_rule(` + finmap_lookup (owned:(num,A)finmap) (name:num) == NONE + `)); + thm named_eq = gsym_rule(named_ra_def); + op_fresh = rewrite_rule(THM_LIST(named_eq), op_fresh); + ACCEPT_TAC( + split[0], + trans_rule( + assume_rule(` + (result:(num,A)finmap) == + finmap_insert (name:num) (a:A) (owned:(num,A)finmap) + `), + gsym_rule(op_fresh))); + gnode_list predicates = CONJ_TAC(split[1]); + ACCEPT_TAC( + predicates[0], + refl_rule(`finmap_singleton (name:num) (a:A)`)); + ACCEPT_TAC( + predicates[1], + source_pred); + ACCEPT_TAC( + update_result[1], + assume_rule(` + ra_valid + (named_ra (R:(A)ra)) + (ra_op + (named_ra R) + (result:(num,A)finmap) + (frame:(num,A)finmap)) + `)); + return gnode_prove(root); +} + +PROOF thm named_own_alloc = prove_named_own_alloc(); + +PROOF static int audit_named_logic(void) { + thm_list public_theorems = THM_LIST( + named_own_def, + named_own_op, + named_own_valid, + named_own_update, + named_own_updateP, + named_own_drop, + named_own_alloc); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "named logic theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "named logic theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == NAMED_LOGIC_AXIOMS_BEFORE, + "named logic introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_named_logic"); + return -1; +} + +PROOF static int _NAMED_LOGIC_AUDIT = audit_named_logic(); diff --git a/theory/logic/named_logic.h b/theory/logic/named_logic.h new file mode 100644 index 0000000000000000000000000000000000000000..44e961d2977fcf22d693e4ff319e172ee50b4ecc --- /dev/null +++ b/theory/logic/named_logic.h @@ -0,0 +1,88 @@ +#pragma once + +/* Generic separation logic over one numerically named RA. */ + +#include "proof/theory/logic/basic_update.h" +#include "proof/theory/logic/named_ra.h" + +/** + * HOL conclusion: + * + * ```text + * named_own (R:(A)ra) (name:num) (a:A) : (num,A)finmap->bool = r_own (named_ra + * R) (finmap_singleton name a) + * ``` + * + * `named_own R name a` 精确拥有仅在 `name` 处存放 `a` 的单点有限映射。 + */ +PROOF extern thm named_own_def; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). r_equiv (named_ra R) (named_own R + * name (ra_op R a b)) (r_sep (named_ra R) (named_own R name a) (named_own R + * name b)) + * ``` + * + * 同一名字下 `a ⋅ b` 的所有权与该名字下 `a`、`b` 所有权的分离合取在 `r_equiv` 下等价。 + */ +PROOF extern thm named_own_op; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (name:num) (a:A). r_entails (named_ra R) (named_own R name + * a) (r_sep (named_ra R) (r_fact (named_ra R) (ra_valid R a)) (named_own R + * name a)) + * ``` + * + * 从名字 `name` 下 `a` 的所有权可分离导出 exact-unit 的 `ra_valid R a` fact，同时保留该所有权。 + */ +PROOF extern thm named_own_valid; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). ra_update R a b ==> r_viewshift + * (named_ra R) (named_own R name a) (named_own R name b) + * ``` + * + * 底层确定性更新 `a ↝ b` 可在固定名字 `name` 处把 `own(a)` 更新为 `own(b)`。 + */ +PROOF extern thm named_own_update; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (name:num) (a:A) (P:A->bool). ra_updateP R a P ==> + * r_viewshift (named_ra R) (named_own R name a) (r_exists (named_ra R) (\b:A. + * r_sep (named_ra R) (r_fact (named_ra R) (P b)) (named_own R name b))) + * ``` + * + * 底层谓词更新在固定名字处选择目标 `b`，并返回 exact-unit 的 `P(b)` fact 和 `b` 的命名所有权。 + */ +PROOF extern thm named_own_updateP; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (name:num) (a:A). r_viewshift (named_ra R) (named_own R + * name a) (r_emp (named_ra R)) + * ``` + * + * 单点命名所有权可更新为 `emp`，只丢弃当前 singleton 片段，并不声称全局不存在同名资源。 + */ +PROOF extern thm named_own_drop; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A) (P:(num,A)finmap->bool). ra_valid R a ==> r_viewshift + * (named_ra R) P (r_exists (named_ra R) (\name:num. r_sep (named_ra R) + * (named_own R name a) P)) + * ``` + * + * `a` 有效时，可在保留原断言 `P` 的同时分配一个新名字并取得该名字下 `a` 的所有权。 + */ +PROOF extern thm named_own_alloc; diff --git a/theory/logic/named_ra.c b/theory/logic/named_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..773aac6cbc09f39874e2250932964b6f1340a0fa --- /dev/null +++ b/theory/logic/named_ra.c @@ -0,0 +1,191 @@ +#include "proof/theory/logic/named_ra.h" +#include "proof/theory/logic/gmap_ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/gmap_ra.c" + +PROOF static size_t NAMED_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm named_ra_def = new_fun_definition(` + named_ra (R:(A)ra) : ((num,A)finmap)ra = gmap_ra R +`); + +PROOF static thm prove_named_ra_unit(void) { + term goal_tm = ` + forall R:(A)ra. + ra_unit (named_ra R) == (finmap_empty:(num,A)finmap) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC(root, rewrite_conv(THM_LIST(named_ra_def, gmap_ra_unit))); + return gnode_prove(root); +} + +PROOF thm named_ra_unit = prove_named_ra_unit(); + +PROOF static thm prove_named_ra_singleton_op(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (b:A). + ra_op + (named_ra R) + (finmap_singleton name a) + (finmap_singleton name b) == + finmap_singleton name (ra_op R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(named_ra_def, gmap_ra_singleton_op))); + return gnode_prove(root); +} + +PROOF thm named_ra_singleton_op = + prove_named_ra_singleton_op(); + +PROOF static thm prove_named_ra_valid_singleton(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A). + ra_valid (named_ra R) (finmap_singleton name a) <=> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST(named_ra_def, gmap_ra_valid_singleton))); + return gnode_prove(root); +} + +PROOF thm named_ra_valid_singleton = + prove_named_ra_valid_singleton(); + +PROOF static thm prove_named_ra_update_singleton(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (b:A). + ra_update R a b ==> + ra_update + (named_ra R) + (finmap_singleton name a) + (finmap_singleton name b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, once_rewrite_conv(THM_LIST(named_ra_def))); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `name:num`, `a:A`, `b:A`), + gmap_ra_update_singleton), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`))); + return gnode_prove(root); +} + +PROOF thm named_ra_update_singleton = + prove_named_ra_update_singleton(); + +PROOF static thm prove_named_ra_updateP_singleton(void) { + term goal_tm = ` + forall (R:(A)ra) (name:num) (a:A) (P:A->bool). + ra_updateP R a P ==> + ra_updateP + (named_ra R) + (finmap_singleton name a) + (\m:(num,A)finmap. + exists b:A. P b && m == finmap_singleton name b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, once_rewrite_conv(THM_LIST(named_ra_def))); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `name:num`, + `a:A`, + `P:A->bool`), + gmap_ra_updateP_singleton), + assume_rule(`ra_updateP (R:(A)ra) (a:A) (P:A->bool)`))); + return gnode_prove(root); +} + +PROOF thm named_ra_updateP_singleton = + prove_named_ra_updateP_singleton(); + +PROOF static thm prove_named_ra_drop(void) { + term R = `R:(A)ra`; + term name = `name:num`; + term a = `a:A`; + term source = `finmap_singleton (name:num) (a:A)`; + term target = `finmap_empty:(num,A)finmap`; + thm included = ispecl_rule( + TERM_LIST(`named_ra (R:(A)ra)`, source), + ra_included_unit); + included = rewrite_rule(THM_LIST(named_ra_unit), included); + thm dropped = mp_rule( + ispecl_rule( + TERM_LIST(`named_ra (R:(A)ra)`, source, target), + ra_update_included), + included); + dropped = gen_rule(a, dropped); + dropped = gen_rule(name, dropped); + return gen_rule(R, dropped); +} + +PROOF thm named_ra_drop = prove_named_ra_drop(); + +PROOF static thm prove_named_ra_alloc(void) { + term goal_tm = ` + forall (R:(A)ra) (m:(num,A)finmap) (a:A). + ra_valid R a ==> + ra_updateP + (named_ra R) + m + (\result:(num,A)finmap. + exists name:num. + finmap_lookup m name == NONE && + result == finmap_insert name a m) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC(body, once_rewrite_conv(THM_LIST(named_ra_def))); + thm allocated = ispecl_rule( + TERM_LIST(`R:(A)ra`, `m:(num,A)finmap`, `a:A`), + gmap_ra_alloc); + allocated = mp_rule(allocated, get_theorem_by_name("num_INFINITE")); + allocated = mp_rule( + allocated, + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + ACCEPT_TAC(body, allocated); + return gnode_prove(root); +} + +PROOF thm named_ra_alloc = prove_named_ra_alloc(); + +PROOF static int audit_named_ra(void) { + thm_list public_theorems = THM_LIST( + named_ra_def, + named_ra_unit, + named_ra_singleton_op, + named_ra_valid_singleton, + named_ra_update_singleton, + named_ra_updateP_singleton, + named_ra_drop, + named_ra_alloc); + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND(!IS_NULL(public_theorems[i]), + "named RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_theorems[i])) == 0, + "named RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == NAMED_RA_AXIOMS_BEFORE, + "named RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_named_ra"); + return -1; +} + +PROOF static int _NAMED_RA_AUDIT = audit_named_ra(); diff --git a/theory/logic/named_ra.h b/theory/logic/named_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..89b555c7bd0d5681a10f62b1ed96a56f214b0fb5 --- /dev/null +++ b/theory/logic/named_ra.h @@ -0,0 +1,126 @@ +#pragma once + +/* + * Public interface for optional numeric naming of ghost resources. + * + * `named_ra R` is a transparent `num`-keyed specialization of `gmap_ra R`, + * not a distinct algebraic construction. Fixed-name laws specialize the + * generic singleton-map rules; allocation selects a fresh natural-number key. + */ + +#include "proof/theory/logic/gmap_ra.h" + +/* ------------------------------------------------------------------------- */ +/* Specialization and pointwise semantics */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * named_ra (R:(A)ra) == (gmap_ra R:((num,A)finmap)ra) + * ``` + * + * `named_ra R` 就是以自然数为键、以 `R` 中资源为 payload 的 gmap RA。 + */ +PROOF extern thm named_ra_def; + +/* + * ```text + * forall R:(A)ra. + * ra_unit (named_ra R) == (finmap_empty:(num,A)finmap) + * ``` + * + * `named_ra R` 的 unit 是不含任何名字的空映射。 + */ +PROOF extern thm named_ra_unit; + +/* + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). + * ra_op + * (named_ra R) + * (finmap_singleton name a) + * (finmap_singleton name b) == + * finmap_singleton name (ra_op R a b) + * ``` + * + * 同一名字下两个单点资源的组合，等于在该名字下放置 `ra_op R a b` 的单点资源。 + */ +PROOF extern thm named_ra_singleton_op; + +/* + * ```text + * forall (R:(A)ra) (name:num) (a:A). + * ra_valid (named_ra R) (finmap_singleton name a) <=> + * ra_valid R a + * ``` + * + * 名字 `name` 下的单点资源有效，当且仅当 payload `a` 在 `R` 中有效。 + */ +PROOF extern thm named_ra_valid_singleton; + +/* ------------------------------------------------------------------------- */ +/* Fixed-name updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall (R:(A)ra) (name:num) (a:A) (b:A). + * ra_update R a b ==> + * ra_update + * (named_ra R) + * (finmap_singleton name a) + * (finmap_singleton name b) + * ``` + * + * payload `a` 可更新为 `b` 时，名字 `name` 下的单点资源也可保持名字不变地更新为 `b`。 + */ +PROOF extern thm named_ra_update_singleton; + +/* + * ```text + * forall (R:(A)ra) (name:num) (a:A) (P:A->bool). + * ra_updateP R a P ==> + * ra_updateP + * (named_ra R) + * (finmap_singleton name a) + * (\m:(num,A)finmap. + * exists b:A. P b && m == finmap_singleton name b) + * ``` + * + * payload `a` 可更新到满足 `P` 的值时，名字 `name` 下的单点资源可更新到以同一名字承载某个满足 `P` 的 `b`。 + */ +PROOF extern thm named_ra_updateP_singleton; + +/* ------------------------------------------------------------------------- */ +/* Fragment lifecycle */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall (R:(A)ra) (name:num) (a:A). + * ra_update + * (named_ra R) + * (finmap_singleton name a) + * (finmap_empty:(num,A)finmap) + * ``` + * + * 名字 `name` 下的 singleton 可更新为空映射；只删除当前片段，兼容 frame 保持不变且仍可能含同名资源。 + */ +PROOF extern thm named_ra_drop; + +/* + * ```text + * forall (R:(A)ra) (m:(num,A)finmap) (a:A). + * ra_valid R a ==> + * ra_updateP + * (named_ra R) + * m + * (\result:(num,A)finmap. + * exists name:num. + * finmap_lookup m name == NONE && + * result == finmap_insert name a m) + * ``` + * + * payload `a` 有效时，`m` 可更新到在某个对 `m` 空缺的自然数名字下插入 `a` 的结果；名字可按兼容 frame 选择。 + */ +PROOF extern thm named_ra_alloc; diff --git a/theory/logic/option_ra.c b/theory/logic/option_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..1d4e2eb65d8e36d0dafda859df4de88b41fc3ca4 --- /dev/null +++ b/theory/logic/option_ra.c @@ -0,0 +1,1406 @@ +#include "proof/theory/logic/option_ra.h" +#include "proof/theory/logic/ra_builder.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/local_update.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t OPTION_RA_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm option_ra_some_op_def = new_rec_definition( + get_theorem_by_name("option_RECURSION"), + ` + option_ra_some_op + (R:(A)ra) + (a:A) + (NONE:A option) = + SOME a && + option_ra_some_op + (R:(A)ra) + (a:A) + (SOME b) = + SOME (ra_op R a b) + `); + +PROOF static thm option_ra_op_def = new_rec_definition( + get_theorem_by_name("option_RECURSION"), + ` + option_ra_op + (R:(A)ra) + (NONE:A option) + (y:A option) = + y && + option_ra_op + (R:(A)ra) + (SOME a) + (y:A option) = + option_ra_some_op R a y + `); + +PROOF static thm option_ra_valid_def = new_rec_definition( + get_theorem_by_name("option_RECURSION"), + ` + (option_ra_valid + (R:(A)ra) + (NONE:A option) <=> T) && + (option_ra_valid + (R:(A)ra) + (SOME a) <=> ra_valid R a) + `); + +PROOF static thm prove_option_ra_op_assoc(void) { + term goal_tm = ` + forall + (R:(A)ra) + (x:A option) + (y:A option) + (z:A option). + option_ra_op R (option_ra_op R x y) z == + option_ra_op R x (option_ra_op R y z) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:A option`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:A option`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + gnode_list z_cases = CASES_TAC( + y_cases[j], `z:A option`, NULL); + for (size_t k = 0; k < vector_size(z_cases); ++k) { + CONV_WITH_ASMP_TAC( + z_cases[k], + rewrite_conv, + THM_LIST( + option_ra_op_def, + option_ra_some_op_def, + ra_assoc)); + } + } + } + return gnode_prove(root); +} + +PROOF static thm option_ra_op_assoc = + prove_option_ra_op_assoc(); + +PROOF static thm prove_option_ra_op_comm(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option) (y:A option). + option_ra_op R x y == + option_ra_op R y x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:A option`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:A option`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + CONV_WITH_ASMP_TAC( + y_cases[j], + rewrite_conv, + THM_LIST( + option_ra_op_def, + option_ra_some_op_def, + ra_comm)); + } + } + return gnode_prove(root); +} + +PROOF static thm option_ra_op_comm = + prove_option_ra_op_comm(); + +PROOF static thm prove_option_ra_op_unit_l(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option). + option_ra_op R NONE x == x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST(option_ra_op_def))); + return gnode_prove(root); +} + +PROOF static thm option_ra_op_unit_l = + prove_option_ra_op_unit_l(); + +PROOF static thm prove_option_ra_valid_unit(void) { + term goal_tm = ` + forall R:(A)ra. + option_ra_valid R NONE + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST(option_ra_valid_def))); + return gnode_prove(root); +} + +PROOF static thm option_ra_valid_unit = + prove_option_ra_valid_unit(); + +PROOF static thm prove_option_ra_valid_op_l(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option) (y:A option). + option_ra_valid R (option_ra_op R x y) ==> + option_ra_valid R x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "x"); + body = GEN_TAC(body, "y"); + gnode_list x_cases = CASES_TAC( + body, `x:A option`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + gnode_list y_cases = CASES_TAC( + x_cases[i], `y:A option`, NULL); + for (size_t j = 0; j < vector_size(y_cases); ++j) { + CONV_WITH_ASMP_TAC( + y_cases[j], + rewrite_conv, + THM_LIST( + option_ra_op_def, + option_ra_some_op_def, + option_ra_valid_def, + ra_valid_op_l)); + } + } + return gnode_prove(root); +} + +PROOF static thm option_ra_valid_op_l = + prove_option_ra_valid_op_l(); + +PROOF static thm prove_option_ra_laws(void) { + term goal_tm = ` + forall R:(A)ra. + ra_laws + (NONE:A option) + (option_ra_op R) + (option_ra_valid R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + gnode unfolded = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + ACCEPT_TAC( + law1[0], + spec_rule(`R:(A)ra`, option_ra_op_assoc)); + + gnode_list law2 = CONJ_TAC(law1[1]); + ACCEPT_TAC( + law2[0], + spec_rule(`R:(A)ra`, option_ra_op_comm)); + + gnode_list law3 = CONJ_TAC(law2[1]); + ACCEPT_TAC( + law3[0], + spec_rule(`R:(A)ra`, option_ra_op_unit_l)); + + gnode_list law4 = CONJ_TAC(law3[1]); + ACCEPT_TAC( + law4[0], + spec_rule(`R:(A)ra`, option_ra_valid_unit)); + ACCEPT_TAC( + law4[1], + spec_rule(`R:(A)ra`, option_ra_valid_op_l)); + return gnode_prove(root); +} + +PROOF static thm option_ra_laws = + prove_option_ra_laws(); + +PROOF static thm option_ra_def = new_fun_definition(` + option_ra (R:(A)ra) : ((A)option)ra = + ra_abs + ((NONE:A option), + (option_ra_op R:A option->A option->A option, + option_ra_valid R:A option->bool)) +`); + +PROOF static thm prove_option_ra_unit(void) { + term R = `R:(A)ra`; + term none = `NONE:A option`; + term op = ` + option_ra_op (R:(A)ra): + A option->A option->A option + `; + term valid = ` + option_ra_valid (R:(A)ra):A option->bool + `; + thm laws = ispec_rule(R, option_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(none, op, valid), + ra_unit_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(option_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF thm option_ra_unit = + prove_option_ra_unit(); + +PROOF static thm prove_option_ra_op_fn(void) { + term R = `R:(A)ra`; + term none = `NONE:A option`; + term op = ` + option_ra_op (R:(A)ra): + A option->A option->A option + `; + term valid = ` + option_ra_valid (R:(A)ra):A option->bool + `; + thm laws = ispec_rule(R, option_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(none, op, valid), + ra_op_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(option_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm option_ra_op_fn = + prove_option_ra_op_fn(); + +PROOF static thm prove_option_ra_valid_fn(void) { + term R = `R:(A)ra`; + term none = `NONE:A option`; + term op = ` + option_ra_op (R:(A)ra): + A option->A option->A option + `; + term valid = ` + option_ra_valid (R:(A)ra):A option->bool + `; + thm laws = ispec_rule(R, option_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST(none, op, valid), + ra_valid_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(option_ra_def)), + computed); + return gen_rule(R, computed); +} + +PROOF static thm option_ra_valid_fn = + prove_option_ra_valid_fn(); + +PROOF static thm prove_option_ra_op_none_l(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option). + ra_op (option_ra R) NONE x == x + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + option_ra_op_fn, + option_ra_op_def))); + return gnode_prove(root); +} + +PROOF thm option_ra_op_none_l = + prove_option_ra_op_none_l(); + +PROOF static thm prove_option_ra_op_none_r(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option). + ra_op (option_ra R) x NONE == x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list x_cases = CASES_TAC( + body, `x:A option`, NULL); + for (size_t i = 0; i < vector_size(x_cases); ++i) { + CONV_WITH_ASMP_TAC( + x_cases[i], + rewrite_conv, + THM_LIST( + option_ra_op_fn, + option_ra_op_def, + option_ra_some_op_def)); + } + return gnode_prove(root); +} + +PROOF thm option_ra_op_none_r = + prove_option_ra_op_none_r(); + +PROOF static thm prove_option_ra_op_some_some(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_op (option_ra R) (SOME a) (SOME b) == + SOME (ra_op R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + option_ra_op_fn, + option_ra_op_def, + option_ra_some_op_def))); + return gnode_prove(root); +} + +PROOF thm option_ra_op_some_some = + prove_option_ra_op_some_some(); + +PROOF static thm prove_option_ra_some_inj(void) { + term goal_tm = ` + forall (a:A) (b:A). + (SOME a:A option) == SOME b <=> a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_theorem_by_name("option_INJ")))); + return gnode_prove(root); +} + +PROOF thm option_ra_some_inj = + prove_option_ra_some_inj(); + +PROOF static thm prove_option_ra_some_ne_none(void) { + term goal_tm = ` + forall a:A. ~((SOME a:A option) == NONE) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_theorem_by_name("option_DISTINCT")))); + return gnode_prove(root); +} + +PROOF thm option_ra_some_ne_none = + prove_option_ra_some_ne_none(); + +PROOF static thm prove_option_ra_some_unit_ne_none(void) { + term goal_tm = ` + forall R:(A)ra. + ~((SOME (ra_unit R):A option) == NONE) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + get_theorem_by_name("option_DISTINCT")))); + return gnode_prove(root); +} + +PROOF thm option_ra_some_unit_ne_none = + prove_option_ra_some_unit_ne_none(); + +PROOF static thm prove_option_ra_valid_none(void) { + term goal_tm = ` + forall R:(A)ra. + ra_valid (option_ra R) (NONE:A option) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + option_ra_valid_fn, + option_ra_valid_def))); + return gnode_prove(root); +} + +PROOF thm option_ra_valid_none = + prove_option_ra_valid_none(); + +PROOF static thm prove_option_ra_valid_some(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_valid (option_ra R) (SOME a) <=> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + option_ra_valid_fn, + option_ra_valid_def))); + return gnode_prove(root); +} + +PROOF thm option_ra_valid_some = + prove_option_ra_valid_some(); + +/* ------------------------------------------------------------------------- */ +/* Inclusion */ +/* ------------------------------------------------------------------------- */ + +/* NONE is the option RA unit, hence it is included in every option value. */ +PROOF static thm prove_option_ra_included_none(void) { + term goal_tm = ` + forall (R:(A)ra) (x:A option). + ra_included (option_ra R) NONE x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm included_unit = ispecl_rule( + TERM_LIST( + `option_ra (R:(A)ra)`, + `x:A option`), + ra_included_unit); + thm unit_equation = ispec_rule( + `R:(A)ra`, + option_ra_unit); + ACCEPT_TAC( + body, + pure_once_rewrite_rule( + THM_LIST(unit_equation), + included_unit)); + return gnode_prove(root); +} + +PROOF thm option_ra_included_none = + prove_option_ra_included_none(); + +/* Inclusion between present values is exactly base inclusion. The adjoined + * NONE frame denotes the base unit; a SOME frame denotes its payload. */ +PROOF static thm prove_option_ra_included_some_some(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included + (option_ra R) + (SOME a) + (SOME b) <=> + ra_included R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hoption_included"); + thm option_included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (option_ra (R:(A)ra)) + (SOME (a:A)) + (SOME (b:A)) + `)); + forward = ASSUME_TAC( + forward, option_included, "Hoption_extension"); + forward = ASMP_EXISTS_TAC( + forward, "Hoption_extension", "frame"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_included_def))); + gnode_list frame_cases = CASES_TAC( + forward, `frame:A option`, "Hframe"); + + term none_eq_tm = gnode_get_asmps( + frame_cases[0], + CONST_STRING_LIST("Hframe"))[0]; + thm none_extension = rewrite_rule( + THM_LIST( + assume_rule(none_eq_tm), + option_ra_op_none_r, + get_theorem_by_name("option_INJ")), + assume_rule(` + SOME (b:A) == + ra_op + (option_ra (R:(A)ra)) + (SOME (a:A)) + (frame:A option) + `)); + gnode none_branch = EXISTS_TAC( + frame_cases[0], + `ra_unit (R:(A)ra)`); + thm base_unit_extension = trans_rule( + none_extension, + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r))); + ACCEPT_TAC(none_branch, base_unit_extension); + + term some_eq_tm = gnode_get_asmps( + frame_cases[1], + CONST_STRING_LIST("Hframe"))[0]; + term some_frame = dest_comb(dest_eq(some_eq_tm).tm2).tm2; + thm some_extension = rewrite_rule( + THM_LIST( + assume_rule(some_eq_tm), + option_ra_op_some_some, + get_theorem_by_name("option_INJ")), + assume_rule(` + SOME (b:A) == + ra_op + (option_ra (R:(A)ra)) + (SOME (a:A)) + (frame:A option) + `)); + gnode some_branch = EXISTS_TAC( + frame_cases[1], + some_frame); + ACCEPT_TAC(some_branch, some_extension); + + gnode reverse = DISCH_TAC( + directions[1], "Hbase_included"); + thm base_included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(`ra_included (R:(A)ra) (a:A) (b:A)`)); + reverse = ASSUME_TAC( + reverse, base_included, "Hbase_extension"); + reverse = ASMP_EXISTS_TAC( + reverse, "Hbase_extension", "base_frame"); + reverse = CONV_TAC( + reverse, + once_rewrite_conv(THM_LIST(ra_included_def))); + reverse = EXISTS_TAC( + reverse, + `SOME (base_frame:A)`); + + thm lifted_extension = beta_rule(ap_term_rule( + `\x:A. SOME x`, + assume_rule(` + (b:A) == + ra_op (R:(A)ra) (a:A) (base_frame:A) + `))); + thm option_composition = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `base_frame:A`), + option_ra_op_some_some); + ACCEPT_TAC( + reverse, + trans_rule( + lifted_extension, + gsym_rule(option_composition))); + return gnode_prove(root); +} + +PROOF thm option_ra_included_some_some = + prove_option_ra_included_some_some(); + +/* A present value cannot be extended back to the freshly adjoined unit. */ +PROOF static thm prove_option_ra_not_included_some_none(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ~(ra_included + (option_ra R) + (SOME a) + NONE) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "a"); + body = DISCH_TAC(body, "Hincluded"); + thm included = pure_once_rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (option_ra (R:(A)ra)) + (SOME (a:A)) + NONE + `)); + body = ASSUME_TAC(body, included, "Hextension"); + body = ASMP_EXISTS_TAC(body, "Hextension", "frame"); + gnode_list frame_cases = CASES_TAC( + body, `frame:A option`, "Hframe"); + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + term frame_eq_tm = gnode_get_asmps( + frame_cases[i], + CONST_STRING_LIST("Hframe"))[0]; + thm contradiction = rewrite_rule( + THM_LIST( + assume_rule(frame_eq_tm), + option_ra_op_none_r, + option_ra_op_some_some, + get_theorem_by_name("option_DISTINCT")), + assume_rule(` + (NONE:A option) == + ra_op + (option_ra (R:(A)ra)) + (SOME (a:A)) + (frame:A option) + `)); + CONTR_TAC(frame_cases[i], contradiction); + } + return gnode_prove(root); +} + +PROOF thm option_ra_not_included_some_none = + prove_option_ra_not_included_some_none(); + +PROOF static thm prove_option_ra_not_cancellative(void) { + term goal_tm = ` + forall R:(A)ra. ~(ra_cancellative (option_ra R)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = DISCH_TAC(body, "Hcancellative"); + + term some_unit = `SOME (ra_unit (R:(A)ra))`; + thm source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `ra_unit (R:(A)ra)`), + option_ra_valid_some)), + ispec_rule(`R:(A)ra`, ra_valid_unit)); + thm source_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + some_unit), + option_ra_op_none_r); + thm framed_source_valid = eq_mp_rule( + gsym_rule(ap_term_rule( + `ra_valid (option_ra (R:(A)ra)):A option->bool`, + source_op)), + source_valid); + + thm right_op = trans_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_unit (R:(A)ra)`, + `ra_unit (R:(A)ra)`), + option_ra_op_some_some), + ap_term_rule( + `SOME:A->A option`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `ra_unit (R:(A)ra)`), + ra_unit_l))); + thm ops_equal = trans_rule(source_op, gsym_rule(right_op)); + thm forced_equal = ispecl_rule( + TERM_LIST( + `option_ra (R:(A)ra)`, + some_unit, + `NONE:A option`, + some_unit), + ra_cancellative_apply); + forced_equal = mp_rule( + forced_equal, + assume_rule(`ra_cancellative (option_ra (R:(A)ra))`)); + forced_equal = mp_rule(forced_equal, framed_source_valid); + forced_equal = mp_rule(forced_equal, ops_equal); + thm contradiction = not_elim_rule( + ispec_rule(`ra_unit (R:(A)ra)`, option_ra_some_ne_none), + gsym_rule(forced_equal)); + CONTR_TAC(body, contradiction); + return gnode_prove(root); +} + +PROOF thm option_ra_not_cancellative = + prove_option_ra_not_cancellative(); + +/* ------------------------------------------------------------------------- */ +/* Frame-preserving updates */ +/* ------------------------------------------------------------------------- */ + +/* A residual option frame is either NONE, corresponding to the base unit, or + * SOME of the exact base residual. In both cases the base local update + * preserves the residual without changing its option shape. */ +PROOF static thm prove_option_ra_local_update_some(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + ra_local_update R a f b g ==> + ra_local_update + (option_ra R) + (SOME a) + (SOME f) + (SOME b) + (SOME g) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + gnode_list residual_cases = CASES_TAC( + body, `residual:A option`, "Hresidual"); + + for (size_t i = 0; i < vector_size(residual_cases); ++i) { + term residual_eq_tm = gnode_get_asmps( + residual_cases[i], + CONST_STRING_LIST("Hresidual"))[0]; + thm residual_eq = assume_rule(residual_eq_tm); + thm source_valid = rewrite_rule( + THM_LIST( + option_ra_valid_some), + assume_rule(` + ra_valid + (option_ra (R:(A)ra)) + (SOME (a:A)) + `)); + thm source_decomposition = rewrite_rule( + THM_LIST( + residual_eq, + option_ra_op_none_r, + option_ra_op_some_some, + get_theorem_by_name("option_INJ")), + assume_rule(` + SOME (a:A) == + ra_op + (option_ra (R:(A)ra)) + (SOME (f:A)) + (residual:A option) + `)); + + term base_residual = i == 0 + ? `ra_unit (R:(A)ra)` + : dest_comb(dest_eq(residual_eq_tm).tm2).tm2; + if (i == 0) { + source_decomposition = trans_rule( + source_decomposition, + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `f:A`), + ra_unit_r))); + } + + thm updated = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`, + base_residual), + ra_local_update_apply); + updated = mp_rule( + updated, + assume_rule(` + ra_local_update + (R:(A)ra) + (a:A) + (f:A) + (b:A) + (g:A) + `)); + updated = mp_rule(updated, source_valid); + updated = mp_rule(updated, source_decomposition); + updated = rewrite_rule( + THM_LIST(ra_unit_r), + updated); + + gnode target = CONV_WITH_ASMP_TAC( + residual_cases[i], + rewrite_conv, + THM_LIST( + residual_eq, + option_ra_op_none_r, + option_ra_op_some_some, + option_ra_valid_some, + get_theorem_by_name("option_INJ"), + ra_unit_r)); + ACCEPT_TAC(target, updated); + } + return gnode_prove(root); +} + +PROOF static thm option_ra_local_update_some = + prove_option_ra_local_update_some(); + +PROOF static thm prove_option_ra_local_update_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (f:A) (b:A) (g:A). + ra_local_update + (option_ra R) + (SOME a) + (SOME f) + (SOME b) + (SOME g) <=> + ra_local_update R a f b g + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hoption_local"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_local_update_def))); + forward = AUTO_INTROS_TAC(forward); + + thm source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + option_ra_valid_some)), + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + thm base_decomposition = assume_rule(` + (a:A) == + ra_op (R:(A)ra) (f:A) (residual:A) + `); + thm lifted_decomposition = beta_rule(ap_term_rule( + `\x:A. SOME x`, + base_decomposition)); + lifted_decomposition = trans_rule( + lifted_decomposition, + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `f:A`, + `residual:A`), + option_ra_op_some_some))); + + thm updated = ispecl_rule( + TERM_LIST( + `option_ra (R:(A)ra)`, + `SOME (a:A):A option`, + `SOME (f:A):A option`, + `SOME (b:A):A option`, + `SOME (g:A):A option`, + `SOME (residual:A)`), + ra_local_update_apply); + updated = mp_rule( + updated, + assume_rule(` + ra_local_update + (option_ra (R:(A)ra)) + (SOME (a:A)) + (SOME (f:A)) + (SOME (b:A)) + (SOME (g:A)) + `)); + updated = mp_rule(updated, source_valid); + updated = mp_rule(updated, lifted_decomposition); + updated = rewrite_rule( + THM_LIST( + option_ra_valid_some, + option_ra_op_some_some, + get_theorem_by_name("option_INJ")), + updated); + ACCEPT_TAC(forward, updated); + + gnode reverse = DISCH_TAC( + directions[1], "Hbase_local"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `f:A`, + `b:A`, + `g:A`), + option_ra_local_update_some), + assume_rule(` + ra_local_update + (R:(A)ra) + (a:A) + (f:A) + (b:A) + (g:A) + `))); + return gnode_prove(root); +} + +PROOF thm option_ra_local_update_iff = + prove_option_ra_local_update_iff(); + +/* + * A base update lifts through SOME. The option frame is inspected + * explicitly: NONE reduces to ordinary validity preservation, while a SOME + * frame is exactly the corresponding base frame. + */ +PROOF static thm prove_option_ra_update(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_update R a b ==> + ra_update (option_ra R) (SOME a) (SOME b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_update_def))); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + gnode_list frame_cases = CASES_TAC( + body, `frame:A option`, "Hframe"); + + term frame_none_eq = gnode_get_asmps( + frame_cases[0], + CONST_STRING_LIST("Hframe"))[0]; + gnode none_result = EXISTS_TAC( + frame_cases[0], `SOME (b:A)`); + gnode_list none_parts = CONJ_TAC(none_result); + ACCEPT_TAC(none_parts[0], refl_rule(`SOME (b:A)`)); + + thm source_none = rewrite_rule( + THM_LIST( + assume_rule(frame_none_eq), + option_ra_op_none_r, + option_ra_valid_some), + assume_rule(` + ra_valid + (option_ra (R:(A)ra)) + (ra_op + (option_ra R) + (SOME (a:A)) + (frame:A option)) + `)); + thm target_none = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`), + ra_update_valid), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)), + source_none); + gnode target_none_goal = CONV_TAC( + none_parts[1], + rewrite_conv(THM_LIST( + assume_rule(frame_none_eq), + option_ra_op_none_r, + option_ra_valid_some))); + ACCEPT_TAC(target_none_goal, target_none); + + term frame_some_eq = gnode_get_asmps( + frame_cases[1], + CONST_STRING_LIST("Hframe"))[0]; + term base_frame = dest_comb( + dest_eq(frame_some_eq).tm2).tm2; + gnode some_result = EXISTS_TAC( + frame_cases[1], `SOME (b:A)`); + gnode_list some_parts = CONJ_TAC(some_result); + ACCEPT_TAC(some_parts[0], refl_rule(`SOME (b:A)`)); + thm source_some = rewrite_rule( + THM_LIST( + assume_rule(frame_some_eq), + option_ra_op_some_some, + option_ra_valid_some), + assume_rule(` + ra_valid + (option_ra (R:(A)ra)) + (ra_op + (option_ra R) + (SOME (a:A)) + (frame:A option)) + `)); + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`, + base_frame), + ra_update_frame), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + thm target_some = mp_rule( + match_mp_rule(ra_update_valid, framed_update), + source_some); + gnode target_some_goal = CONV_TAC( + some_parts[1], + rewrite_conv(THM_LIST( + assume_rule(frame_some_eq), + option_ra_op_some_some, + option_ra_valid_some))); + ACCEPT_TAC(target_some_goal, target_some); + return gnode_prove(root); +} + +PROOF thm option_ra_update = + prove_option_ra_update(); + +PROOF static thm prove_option_ra_update_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_update + (option_ra R) + (SOME a) + (SOME b) <=> + ra_update R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hoption_update"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_update_def))); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + forward = CONV_TAC( + forward, + depth_conv(get_conversion_by_name("BETA_CONV"))); + forward = AUTO_INTROS_TAC(forward); + forward = EXISTS_TAC(forward, `b:A`); + gnode_list result = CONJ_TAC(forward); + ACCEPT_TAC(result[0], refl_rule(`b:A`)); + thm source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (frame:A)`), + option_ra_valid_some)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + source_valid = eq_mp_rule( + gsym_rule(ap_term_rule( + `ra_valid (option_ra (R:(A)ra)):A option->bool`, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `frame:A`), + option_ra_op_some_some))), + source_valid); + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `option_ra (R:(A)ra)`, + `SOME (a:A):A option`, + `SOME (b:A):A option`, + `SOME (frame:A):A option`), + ra_update_frame), + assume_rule(` + ra_update + (option_ra (R:(A)ra)) + (SOME (a:A)) + (SOME (b:A)) + `)); + thm target_valid = mp_rule( + match_mp_rule(ra_update_valid, framed_update), + source_valid); + target_valid = rewrite_rule( + THM_LIST( + option_ra_op_some_some, + option_ra_valid_some), + target_valid); + ACCEPT_TAC(result[1], target_valid); + + gnode reverse = DISCH_TAC( + directions[1], "Hbase_update"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`), + option_ra_update), + assume_rule(` + ra_update (R:(A)ra) (a:A) (b:A) + `))); + return gnode_prove(root); +} + +PROOF thm option_ra_update_iff = + prove_option_ra_update_iff(); + +/* Predicate updates lift to the exact SOME image. */ +PROOF static thm prove_option_ra_updateP(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool). + ra_updateP R a P ==> + ra_updateP + (option_ra R) + (SOME a) + (\x:A option. exists b:A. P b && x == SOME b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + gnode_list frame_cases = CASES_TAC( + body, `frame:A option`, "Hframe"); + + for (size_t i = 0; i < vector_size(frame_cases); ++i) { + term frame_eq_tm = gnode_get_asmps( + frame_cases[i], + CONST_STRING_LIST("Hframe"))[0]; + thm frame_eq = assume_rule(frame_eq_tm); + thm source_valid = rewrite_rule( + THM_LIST( + frame_eq, + option_ra_op_none_r, + option_ra_op_some_some, + option_ra_valid_some), + assume_rule(` + ra_valid + (option_ra (R:(A)ra)) + (ra_op + (option_ra R) + (SOME (a:A)) + (frame:A option)) + `)); + + thm selected; + if (i == 0) { + selected = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `P:A->bool`), + ra_updateP_valid), + assume_rule(` + ra_updateP + (R:(A)ra) + (a:A) + (P:A->bool) + `)), + source_valid); + } else { + thm base_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(` + ra_updateP + (R:(A)ra) + (a:A) + (P:A->bool) + `)); + term base_frame = dest_comb( + dest_eq(frame_eq_tm).tm2).tm2; + selected = mp_rule( + spec_rule(base_frame, base_update), + source_valid); + } + + gnode branch = ASSUME_TAC( + frame_cases[i], selected, "Hselected"); + branch = ASMP_EXISTS_TAC( + branch, "Hselected", "b"); + branch = ASMP_CONJ_TAC( + branch, + "Hselected", + "HP_b", + "Hb_valid"); + branch = EXISTS_TAC(branch, `SOME (b:A)`); + gnode_list result_parts = CONJ_TAC(branch); + + gnode predicate = EXISTS_TAC( + result_parts[0], `b:A`); + gnode_list predicate_parts = CONJ_TAC(predicate); + ACCEPT_TAC( + predicate_parts[0], + assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC( + predicate_parts[1], + refl_rule(`SOME (b:A)`)); + + gnode target_valid = CONV_TAC( + result_parts[1], + rewrite_conv(THM_LIST( + frame_eq, + option_ra_op_none_r, + option_ra_op_some_some, + option_ra_valid_some))); + ACCEPT_TAC( + target_valid, + assume_rule(gnode_get_asmps( + target_valid, + CONST_STRING_LIST("Hb_valid"))[0])); + } + return gnode_prove(root); +} + +PROOF thm option_ra_updateP = + prove_option_ra_updateP(); + +PROOF static thm prove_option_ra_updateP_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool). + (ra_updateP + (option_ra R) + (SOME a) + (\x:A option. + exists b:A. P b && x == SOME b) <=> + ra_updateP R a P) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC( + directions[0], "Hoption_update"); + forward = CONV_TAC( + forward, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + forward = AUTO_INTROS_TAC(forward); + + thm source_valid = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (frame:A)`), + option_ra_valid_some)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + source_valid = eq_mp_rule( + gsym_rule(ap_term_rule( + `ra_valid (option_ra (R:(A)ra)):A option->bool`, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `frame:A`), + option_ra_op_some_some))), + source_valid); + + thm option_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(` + ra_updateP + (option_ra (R:(A)ra)) + (SOME (a:A)) + (\x:A option. + exists b:A. + (P:A->bool) b && x == SOME b) + `)); + option_update = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + option_update); + thm selected = mp_rule( + spec_rule(`SOME (frame:A)`, option_update), + source_valid); + forward = ASSUME_TAC( + forward, selected, "Hselected"); + forward = ASMP_EXISTS_TAC( + forward, "Hselected", "x"); + forward = ASMP_CONJ_TAC( + forward, + "Hselected", + "Himage", + "Htarget_valid"); + forward = ASMP_EXISTS_TAC( + forward, "Himage", "b"); + forward = ASMP_CONJ_TAC( + forward, + "Himage", + "HP_b", + "Hx"); + forward = EXISTS_TAC(forward, `b:A`); + gnode_list result = CONJ_TAC(forward); + ACCEPT_TAC( + result[0], + assume_rule(`(P:A->bool) (b:A)`)); + thm target_valid = rewrite_rule( + THM_LIST( + assume_rule(`(x:A option) == SOME (b:A)`), + option_ra_op_some_some, + option_ra_valid_some), + assume_rule(` + ra_valid + (option_ra (R:(A)ra)) + (ra_op + (option_ra R) + (x:A option) + (SOME (frame:A))) + `)); + ACCEPT_TAC(result[1], target_valid); + + gnode reverse = DISCH_TAC( + directions[1], "Hbase_update"); + ACCEPT_TAC( + reverse, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `P:A->bool`), + option_ra_updateP), + assume_rule(` + ra_updateP + (R:(A)ra) + (a:A) + (P:A->bool) + `))); + return gnode_prove(root); +} + +PROOF thm option_ra_updateP_iff = + prove_option_ra_updateP_iff(); + +PROOF static int audit_option_ra(void) { + thm_list audited_theorems = THM_LIST( + option_ra_some_op_def, + option_ra_op_def, + option_ra_valid_def, + option_ra_op_assoc, + option_ra_op_comm, + option_ra_op_unit_l, + option_ra_valid_unit, + option_ra_valid_op_l, + option_ra_laws, + option_ra_def, + option_ra_unit, + option_ra_op_fn, + option_ra_valid_fn, + option_ra_op_none_l, + option_ra_op_none_r, + option_ra_op_some_some, + option_ra_some_inj, + option_ra_some_ne_none, + option_ra_some_unit_ne_none, + option_ra_valid_none, + option_ra_valid_some, + option_ra_included_none, + option_ra_included_some_some, + option_ra_not_included_some_none, + option_ra_not_cancellative, + option_ra_local_update_some, + option_ra_local_update_iff, + option_ra_update, + option_ra_update_iff, + option_ra_updateP, + option_ra_updateP_iff); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "option RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "option RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == OPTION_RA_AXIOMS_BEFORE, + "option RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_option_ra"); + return -1; +} + +PROOF static int _OPTION_RA_AUDIT = audit_option_ra(); diff --git a/theory/logic/option_ra.h b/theory/logic/option_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..134f97efdef1767aeb2e97f236fd403f20ebd392 --- /dev/null +++ b/theory/logic/option_ra.h @@ -0,0 +1,145 @@ +#pragma once + +/* + * Public interface for the option (lift) resource algebra. + * + * `option_ra R : (A option)ra` adjoins `NONE` as a new unit and embeds base + * resources as `SOME a`. Consequently `NONE` (absence) remains distinct from + * `SOME (ra_unit R)` (a present slot carrying an empty payload). + */ + +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Operation and validity */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R. ra_unit (option_ra R) == NONE + * ``` + * + * `option_ra R` 把缺失值 `NONE` 作为新的 RA unit。 + */ +PROOF extern thm option_ra_unit; + +/* + * ```text + * forall R x. ra_op (option_ra R) NONE x == x + * ``` + * + * `NONE` 从左侧与任意 option 资源 `x` 组合都保持 `x` 不变。 + */ +PROOF extern thm option_ra_op_none_l; + +/* + * ```text + * forall R a b. ra_op (option_ra R) (SOME a) (SOME b) == SOME (ra_op R a b) + * ``` + * + * 两个存在的 option 资源通过在底层 `R` 中组合 payload，得到 `SOME (a ⋅ b)`。 + */ +PROOF extern thm option_ra_op_some_some; + +/* + * ```text + * forall R. ra_valid (option_ra R) NONE + * ``` + * + * 表示缺失的 `NONE` 在 option RA 中始终有效。 + */ +PROOF extern thm option_ra_valid_none; + +/* + * ```text + * forall R a. ra_valid (option_ra R) (SOME a) <=> ra_valid R a + * ``` + * + * `SOME a` 在 option RA 中有效，当且仅当 payload `a` 在底层 `R` 中有效。 + */ +PROOF extern thm option_ra_valid_some; + +/* ------------------------------------------------------------------------- */ +/* Inclusion and algebraic properties */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R x. ra_included (option_ra R) NONE x + * ``` + * + * 缺失资源 `NONE` 包含于任意 option 资源。 + */ +PROOF extern thm option_ra_included_none; + +/* + * ```text + * forall R a b. + * ra_included (option_ra R) (SOME a) (SOME b) <=> ra_included R a b + * ``` + * + * `SOME a` 包含于 `SOME b`，当且仅当 payload `a` 在底层 `R` 中包含于 `b`。 + */ +PROOF extern thm option_ra_included_some_some; + +/* + * ```text + * forall R a. ~ra_included (option_ra R) (SOME a) NONE + * ``` + * + * 任何存在的资源 `SOME a` 都不包含于缺失资源 `NONE`。 + */ +PROOF extern thm option_ra_not_included_some_none; + +/* + * ```text + * forall R. ~(SOME (ra_unit R) == NONE) + * ``` + * + * 存在但 payload 为底层 unit 的 `SOME (ra_unit R)` 与表示缺失的 `NONE` 不相等。 + */ +PROOF extern thm option_ra_some_unit_ne_none; + +/* + * ```text + * forall R. ~ra_cancellative (option_ra R) + * ``` + * + * option RA 始终不可消去，因为新增的 `NONE` 与 `SOME (ra_unit R)` 是不同的 unit-like 片段。 + */ +PROOF extern thm option_ra_not_cancellative; + +/* ------------------------------------------------------------------------- */ +/* Exact lifting rules */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a P. + * ra_updateP (option_ra R) (SOME a) (\x. exists b. P b && x == SOME b) <=> + * ra_updateP R a P + * ``` + * + * `SOME a` 在 option RA 中更新到承载某个满足 `P` 的 payload，当且仅当 `a` 在底层 `R` 中可更新到 `P`。 + */ +PROOF extern thm option_ra_updateP_iff; + +/* + * ```text + * forall R a b. ra_update (option_ra R) (SOME a) (SOME b) <=> ra_update R a b + * ``` + * + * `SOME a -> SOME b` 在 option RA 中成立，当且仅当 `a -> b` 在底层 `R` 中成立。 + */ +PROOF extern thm option_ra_update_iff; + +/* + * ```text + * forall R a f b g. + * ra_local_update (option_ra R) (SOME a) (SOME f) (SOME b) (SOME g) <=> + * ra_local_update R a f b g + * ``` + * + * option RA 中存在值之间的局部更新，当且仅当对应 payload 之间的底层局部更新成立。 + */ +PROOF extern thm option_ra_local_update_iff; diff --git a/theory/logic/option_ra_internal.h b/theory/logic/option_ra_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..264747c74fb8c8c54bb7433d8304a8d7fcf73f73 --- /dev/null +++ b/theory/logic/option_ra_internal.h @@ -0,0 +1,37 @@ +#pragma once + +/* + * INTERNAL option-RA normalization rules for container constructors. + * Ordinary clients use `option_ra.h`; this header must not be re-exported. + */ + +#include "proof/theory/logic/option_ra.h" + +/* + * ```text + * forall R x. ra_op (option_ra R) x NONE == x + * ``` + * + * `NONE` 从右侧与任意 option 资源 `x` 组合都保持 `x` 不变。 + */ +PROOF extern thm option_ra_op_none_r; + +/* + * ```text + * forall R a b. ra_update R a b ==> ra_update (option_ra R) (SOME a) (SOME b) + * ``` + * + * 底层更新 `a -> b` 可提升为 option RA 中的 `SOME a -> SOME b`。 + */ +PROOF extern thm option_ra_update; + +/* + * ```text + * forall R a P. + * ra_updateP R a P + * ==> ra_updateP (option_ra R) (SOME a) (\x. exists b. P b && x == SOME b) + * ``` + * + * `a` 在底层 `R` 中可更新到 `P` 时，`SOME a` 可更新到承载某个满足 `P` 的 payload。 + */ +PROOF extern thm option_ra_updateP; diff --git a/theory/logic/prod_ra.c b/theory/logic/prod_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..e200f345e92f972c1c8e2b60308873f348a8a00c --- /dev/null +++ b/theory/logic/prod_ra.c @@ -0,0 +1,2560 @@ +#include "proof/theory/logic/prod_ra.h" +#include "proof/theory/logic/ra_builder.h" +#include "proof/theory/logic/ra_internal.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/local_update.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t PROD_RA_AXIOMS_BEFORE = vector_size(get_all_axioms()); + +PROOF static thm prod_ra_op_def = new_fun_definition(` + prod_ra_op + (R1:(A)ra) + (R2:(B)ra) + (x:A#B) + (y:A#B) : A#B = + (ra_op R1 (FST x) (FST y), + ra_op R2 (SND x) (SND y)) +`); + +PROOF static thm prod_ra_valid_def = new_fun_definition(` + prod_ra_valid + (R1:(A)ra) + (R2:(B)ra) + (x:A#B) <=> + ra_valid R1 (FST x) && + ra_valid R2 (SND x) +`); + +PROOF static thm prove_prod_ra_laws(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra). + ra_laws + (ra_unit R1,ra_unit R2) + (prod_ra_op R1 R2) + (prod_ra_valid R1 R2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode unfolded = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + assoc = CONV_TAC( + assoc, + pure_rewrite_conv(THM_LIST( + prod_ra_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + assoc = CONV_TAC( + assoc, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("PAIR_EQ")))); + gnode_list assoc_parts = CONJ_TAC(assoc); + ACCEPT_TAC( + assoc_parts[0], + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `FST (a:A#B)`, + `FST (b:A#B)`, + `FST (c:A#B)`), + ra_assoc)); + ACCEPT_TAC( + assoc_parts[1], + ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `SND (a:A#B)`, + `SND (b:A#B)`, + `SND (c:A#B)`), + ra_assoc)); + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + comm = CONV_TAC( + comm, + pure_rewrite_conv(THM_LIST(prod_ra_op_def))); + comm = CONV_TAC( + comm, + once_rewrite_conv(THM_LIST( + get_theorem_by_name("PAIR_EQ")))); + gnode_list comm_parts = CONJ_TAC(comm); + ACCEPT_TAC( + comm_parts[0], + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `FST (a:A#B)`, + `FST (b:A#B)`), + ra_comm)); + ACCEPT_TAC( + comm_parts[1], + ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `SND (a:A#B)`, + `SND (b:A#B)`), + ra_comm)); + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = AUTO_INTROS_TAC(law3[0]); + CONV_TAC( + unit, + rewrite_conv(THM_LIST( + prod_ra_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_unit_l, + get_theorem_by_name("PAIR")))); + + gnode_list law4 = CONJ_TAC(law3[1]); + CONV_TAC( + law4[0], + rewrite_conv(THM_LIST( + prod_ra_valid_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_valid_unit))); + + gnode valid_down = CONV_TAC( + law4[1], + pure_rewrite_conv(THM_LIST( + prod_ra_valid_def, + prod_ra_op_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + valid_down = AUTO_INTROS_TAC(valid_down); + valid_down = ASMP_CONJ_TAC( + valid_down, + "H", + "Hvalid_fst", + "Hvalid_snd"); + gnode_list valid_parts = CONJ_TAC(valid_down); + ACCEPT_TAC( + valid_parts[0], + mp_rule( + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `FST (a:A#B)`, + `FST (b:A#B)`), + ra_valid_op_l), + assume_rule(` + ra_valid (R1:(A)ra) + (ra_op R1 (FST (a:A#B)) (FST (b:A#B))) + `))); + ACCEPT_TAC( + valid_parts[1], + mp_rule( + ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `SND (a:A#B)`, + `SND (b:A#B)`), + ra_valid_op_l), + assume_rule(` + ra_valid (R2:(B)ra) + (ra_op R2 (SND (a:A#B)) (SND (b:A#B))) + `))); + return gnode_prove(root); +} + +PROOF static thm prod_ra_laws = prove_prod_ra_laws(); + +PROOF static thm prod_ra_def = new_fun_definition(` + prod_ra (R1:(A)ra) (R2:(B)ra) : (A#B)ra = + ra_abs + ((ra_unit R1,ra_unit R2), + (prod_ra_op R1 R2,prod_ra_valid R1 R2)) +`); + +PROOF static thm prove_prod_ra_unit(void) { + term R1 = `R1:(A)ra`; + term R2 = `R2:(B)ra`; + thm laws = ispecl_rule(TERM_LIST(R1, R2), prod_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `(ra_unit (R1:(A)ra),ra_unit (R2:(B)ra))`, + `prod_ra_op (R1:(A)ra) (R2:(B)ra)`, + `prod_ra_valid (R1:(A)ra) (R2:(B)ra)`), + ra_unit_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(prod_ra_def)), + computed); + computed = gen_rule(R2, computed); + return gen_rule(R1, computed); +} + +PROOF thm prod_ra_unit = prove_prod_ra_unit(); + +PROOF static thm prove_prod_ra_op_fn(void) { + term R1 = `R1:(A)ra`; + term R2 = `R2:(B)ra`; + thm laws = ispecl_rule(TERM_LIST(R1, R2), prod_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `(ra_unit (R1:(A)ra),ra_unit (R2:(B)ra))`, + `prod_ra_op (R1:(A)ra) (R2:(B)ra)`, + `prod_ra_valid (R1:(A)ra) (R2:(B)ra)`), + ra_op_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(prod_ra_def)), + computed); + computed = gen_rule(R2, computed); + return gen_rule(R1, computed); +} + +PROOF static thm prod_ra_op_fn = prove_prod_ra_op_fn(); + +PROOF static thm prove_prod_ra_valid_fn(void) { + term R1 = `R1:(A)ra`; + term R2 = `R2:(B)ra`; + thm laws = ispecl_rule(TERM_LIST(R1, R2), prod_ra_laws); + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `(ra_unit (R1:(A)ra),ra_unit (R2:(B)ra))`, + `prod_ra_op (R1:(A)ra) (R2:(B)ra)`, + `prod_ra_valid (R1:(A)ra) (R2:(B)ra)`), + ra_valid_abs), + laws); + computed = pure_once_rewrite_rule( + THM_LIST(gsym_rule(prod_ra_def)), + computed); + computed = gen_rule(R2, computed); + return gen_rule(R1, computed); +} + +PROOF static thm prod_ra_valid_fn = prove_prod_ra_valid_fn(); + +PROOF static thm prove_prod_ra_op(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B) (y:A#B). + ra_op (prod_ra R1 R2) x y == + (ra_op R1 (FST x) (FST y), + ra_op R2 (SND x) (SND y)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + prod_ra_op_fn, + prod_ra_op_def))); + return gnode_prove(root); +} + +PROOF thm prod_ra_op = prove_prod_ra_op(); + +PROOF static thm prove_prod_ra_valid(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B). + ra_valid (prod_ra R1 R2) x <=> + ra_valid R1 (FST x) && ra_valid R2 (SND x) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + prod_ra_valid_fn, + prod_ra_valid_def))); + return gnode_prove(root); +} + +PROOF thm prod_ra_valid = prove_prod_ra_valid(); + +/* + * A product is included in another product exactly when both projections are + * included. The forward direction projects the single product frame; the + * reverse direction pairs the two component frames and reconstructs the + * arbitrary target with pair eta. + */ +PROOF static thm prove_prod_ra_included(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B) (y:A#B). + ra_included (prod_ra R1 R2) x y <=> + ra_included R1 (FST x) (FST y) && + ra_included R2 (SND x) (SND y) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hincluded"); + forward = ASMP_EXISTS_TAC(forward, "Hincluded", "frame"); + thm product_extension = assume_rule(` + (y:A#B) == + ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (x:A#B) + (frame:A#B) + `); + thm product_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `x:A#B`, + `frame:A#B`), + prod_ra_op); + thm fst_extension = ap_term_rule( + `FST:(A#B)->A`, + product_extension); + fst_extension = pure_rewrite_rule( + THM_LIST( + product_op, + get_theorem_by_name("FST")), + fst_extension); + thm snd_extension = ap_term_rule( + `SND:(A#B)->B`, + product_extension); + snd_extension = pure_rewrite_rule( + THM_LIST( + product_op, + get_theorem_by_name("SND")), + snd_extension); + + gnode_list forward_components = CONJ_TAC(forward); + gnode left = EXISTS_TAC( + forward_components[0], + `FST (frame:A#B)`); + ACCEPT_TAC(left, fst_extension); + gnode right = EXISTS_TAC( + forward_components[1], + `SND (frame:A#B)`); + ACCEPT_TAC(right, snd_extension); + + gnode reverse = DISCH_TAC(directions[1], "Hcomponents"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hcomponents", + "Hleft", + "Hright"); + reverse = ASMP_EXISTS_TAC(reverse, "Hleft", "left_frame"); + reverse = ASMP_EXISTS_TAC(reverse, "Hright", "right_frame"); + reverse = EXISTS_TAC( + reverse, + `((left_frame:A),(right_frame:B))`); + + thm component_extensions = conj_rule( + assume_rule(` + FST (y:A#B) == + ra_op (R1:(A)ra) (FST (x:A#B)) (left_frame:A) + `), + assume_rule(` + SND (y:A#B) == + ra_op (R2:(B)ra) (SND (x:A#B)) (right_frame:B) + `)); + thm pair_equivalence = ispecl_rule( + TERM_LIST( + `FST (y:A#B)`, + `SND (y:A#B)`, + `ra_op (R1:(A)ra) (FST (x:A#B)) (left_frame:A)`, + `ra_op (R2:(B)ra) (SND (x:A#B)) (right_frame:B)`), + get_theorem_by_name("PAIR_EQ")); + thm projected_target = eq_mp_rule( + gsym_rule(pair_equivalence), + component_extensions); + thm target_eta = ispec_rule( + `y:A#B`, + get_theorem_by_name("PAIR")); + thm target_as_pair = trans_rule( + gsym_rule(target_eta), + projected_target); + + thm paired_product_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `x:A#B`, + `((left_frame:A),(right_frame:B))`), + prod_ra_op); + paired_product_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + paired_product_op); + ACCEPT_TAC( + reverse, + trans_rule(target_as_pair, gsym_rule(paired_product_op))); + return gnode_prove(root); +} + +PROOF thm prod_ra_included = prove_prod_ra_included(); + +/* A product is frame-maximal exactly when both projections are + * frame-maximal: a compatible pair frame is then the pair of units. */ +PROOF static thm prove_prod_ra_maximal(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B). + ra_maximal R1 (FST x) ==> + ra_maximal R2 (SND x) ==> + ra_maximal (prod_ra R1 R2) x + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + gnode_list maximal = CONJ_TAC(body); + + thm left_maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R1:(A)ra) (FST (x:A#B))`)); + thm right_maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R2:(B)ra) (SND (x:A#B))`)); + thm source_components = conj_rule( + conjunct1_rule(left_maximal), + conjunct1_rule(right_maximal)); + thm source_validity = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_valid); + ACCEPT_TAC( + maximal[0], + eq_mp_rule(gsym_rule(source_validity), source_components)); + + body = GEN_TAC(maximal[1], "frame"); + body = DISCH_TAC(body, "Hcompatible"); + + thm product_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (x:A#B) + (frame:A#B)`), + prod_ra_valid); + thm components = eq_mp_rule( + product_validity, + assume_rule(` + ra_valid + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (ra_op + (prod_ra R1 R2) + (x:A#B) + (frame:A#B)) + `)); + components = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + components); + + thm left_frame = spec_rule( + `FST (frame:A#B)`, + conjunct2_rule(left_maximal)); + left_frame = mp_rule(left_frame, conjunct1_rule(components)); + + thm right_frame = spec_rule( + `SND (frame:A#B)`, + conjunct2_rule(right_maximal)); + right_frame = mp_rule(right_frame, conjunct2_rule(components)); + + thm pair_components = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `FST (frame:A#B)`, + `SND (frame:A#B)`, + `ra_unit (R1:(A)ra)`, + `ra_unit (R2:(B)ra)`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule(left_frame, right_frame)); + thm frame_eta = ispec_rule( + `frame:A#B`, + get_theorem_by_name("PAIR")); + thm product_unit = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`), + prod_ra_unit); + ACCEPT_TAC( + body, + trans_rule( + gsym_rule(frame_eta), + trans_rule(pair_components, gsym_rule(product_unit)))); + return gnode_prove(root); +} + +PROOF thm prod_ra_maximal = + prove_prod_ra_maximal(); + +/* Embed a left frame together with the right unit. Validity of the source + * product supplies the compatible right component needed for the embedding. */ +PROOF static thm prove_prod_ra_maximal_elim_left(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B). + ra_valid (prod_ra R1 R2) x ==> + ra_maximal (prod_ra R1 R2) x ==> + ra_maximal R1 (FST x) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + gnode_list maximal = CONJ_TAC(body); + + thm source_components = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_valid), + assume_rule(`ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + ACCEPT_TAC(maximal[0], conjunct1_rule(source_components)); + body = GEN_TAC(maximal[1], "frame"); + body = DISCH_TAC(body, "Hcompatible"); + thm right_unit = ispecl_rule( + TERM_LIST(`R2:(B)ra`, `SND (x:A#B)`), + ra_unit_r); + thm right_compatible = eq_mp_rule( + ap_term_rule( + `ra_valid (R2:(B)ra):B->bool`, + gsym_rule(right_unit)), + conjunct2_rule(source_components)); + thm framed_components = conj_rule( + assume_rule(` + ra_valid + (R1:(A)ra) + (ra_op R1 (FST (x:A#B)) (frame:A)) + `), + right_compatible); + + term product_frame = `((frame:A),ra_unit (R2:(B)ra))`; + term framed_source = ` + ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (x:A#B) + ((frame:A),ra_unit R2) + `; + thm framed_validity = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, framed_source), + prod_ra_valid); + framed_validity = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + framed_validity); + thm framed_pair_valid = eq_mp_rule( + gsym_rule(framed_validity), + framed_components); + thm framed_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `x:A#B`, + product_frame), + prod_ra_op); + framed_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + framed_op); + thm framed_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(framed_op)), + framed_pair_valid); + + thm product_maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + thm unit_frame = spec_rule( + product_frame, + conjunct2_rule(product_maximal)); + unit_frame = mp_rule(unit_frame, framed_valid); + thm projected = ap_term_rule(`FST:(A#B)->A`, unit_frame); + projected = pure_rewrite_rule( + THM_LIST( + prod_ra_unit, + get_theorem_by_name("FST")), + projected); + ACCEPT_TAC(body, projected); + return gnode_prove(root); +} + +PROOF thm prod_ra_maximal_elim_left = + prove_prod_ra_maximal_elim_left(); + +/* Symmetric embedding of a right frame with the left unit. */ +PROOF static thm prove_prod_ra_maximal_elim_right(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B). + ra_valid (prod_ra R1 R2) x ==> + ra_maximal (prod_ra R1 R2) x ==> + ra_maximal R2 (SND x) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + gnode_list maximal = CONJ_TAC(body); + + thm source_components = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_valid), + assume_rule(`ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + ACCEPT_TAC(maximal[0], conjunct2_rule(source_components)); + body = GEN_TAC(maximal[1], "frame"); + body = DISCH_TAC(body, "Hcompatible"); + thm left_unit = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `FST (x:A#B)`), + ra_unit_r); + thm left_compatible = eq_mp_rule( + ap_term_rule( + `ra_valid (R1:(A)ra):A->bool`, + gsym_rule(left_unit)), + conjunct1_rule(source_components)); + thm framed_components = conj_rule( + left_compatible, + assume_rule(` + ra_valid + (R2:(B)ra) + (ra_op R2 (SND (x:A#B)) (frame:B)) + `)); + + term product_frame = `(ra_unit (R1:(A)ra),(frame:B))`; + term framed_source = ` + ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (x:A#B) + (ra_unit R1,(frame:B)) + `; + thm framed_validity = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, framed_source), + prod_ra_valid); + framed_validity = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + framed_validity); + thm framed_pair_valid = eq_mp_rule( + gsym_rule(framed_validity), + framed_components); + thm framed_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `x:A#B`, + product_frame), + prod_ra_op); + framed_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + framed_op); + thm framed_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(framed_op)), + framed_pair_valid); + + thm product_maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + thm unit_frame = spec_rule( + product_frame, + conjunct2_rule(product_maximal)); + unit_frame = mp_rule(unit_frame, framed_valid); + thm projected = ap_term_rule(`SND:(A#B)->B`, unit_frame); + projected = pure_rewrite_rule( + THM_LIST( + prod_ra_unit, + get_theorem_by_name("SND")), + projected); + ACCEPT_TAC(body, projected); + return gnode_prove(root); +} + +PROOF thm prod_ra_maximal_elim_right = + prove_prod_ra_maximal_elim_right(); + +PROOF static thm prove_prod_ra_maximal_iff(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) (x:A#B). + (ra_maximal (prod_ra R1 R2) x <=> + ra_maximal R1 (FST x) && + ra_maximal R2 (SND x)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hmaximal"); + thm product_maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + gnode_list components = CONJ_TAC(forward); + thm left = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_maximal_elim_left); + left = mp_rule( + left, + conjunct1_rule(product_maximal)); + left = mp_rule( + left, + assume_rule(`ra_maximal (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + ACCEPT_TAC(components[0], left); + + thm right = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_maximal_elim_right); + right = mp_rule( + right, + conjunct1_rule(product_maximal)); + right = mp_rule( + right, + assume_rule(`ra_maximal (prod_ra (R1:(A)ra) (R2:(B)ra)) (x:A#B)`)); + ACCEPT_TAC(components[1], right); + + gnode reverse = DISCH_TAC(directions[1], "Hcomponents"); + thm result = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, `x:A#B`), + prod_ra_maximal); + result = mp_rule( + result, + conjunct1_rule(assume_rule(` + ra_maximal (R1:(A)ra) (FST (x:A#B)) && + ra_maximal (R2:(B)ra) (SND x) + `))); + result = mp_rule( + result, + conjunct2_rule(assume_rule(` + ra_maximal (R1:(A)ra) (FST (x:A#B)) && + ra_maximal (R2:(B)ra) (SND x) + `))); + ACCEPT_TAC(reverse, result); + return gnode_prove(root); +} + +PROOF thm prod_ra_maximal_iff = + prove_prod_ra_maximal_iff(); + +/* + * Component cancellativity lifts to products. Product validity is + * specialized at the source composition, and product equality is first + * normalized to an explicit pair equality before PAIR_EQ is applied once. + */ +PROOF static thm prove_prod_ra_cancellative(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra). + ra_cancellative R1 ==> + ra_cancellative R2 ==> + ra_cancellative (prod_ra R1 R2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R1"); + body = GEN_TAC(body, "R2"); + body = DISCH_TAC(body, "Hcancel_left"); + body = DISCH_TAC(body, "Hcancel_right"); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = GEN_TAC(body, "frame"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hsource_valid"); + body = DISCH_TAC(body, "Hops_equal"); + + thm source_valid_rule = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (frame:A#B) + (a:A#B)`), + prod_ra_valid); + thm source_components = eq_mp_rule( + source_valid_rule, + assume_rule(` + ra_valid + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (ra_op + (prod_ra R1 R2) + (frame:A#B) + (a:A#B)) + `)); + thm source_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `frame:A#B`, + `a:A#B`), + prod_ra_op); + source_components = pure_rewrite_rule( + THM_LIST( + source_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_components); + + thm target_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `frame:A#B`, + `b:A#B`), + prod_ra_op); + thm product_ops_equal = pure_rewrite_rule( + THM_LIST(source_op, target_op), + assume_rule(` + ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (frame:A#B) + (a:A#B) == + ra_op + (prod_ra R1 R2) + frame + (b:A#B) + `)); + thm operation_pair_equivalence = ispecl_rule( + TERM_LIST( + `ra_op (R1:(A)ra) (FST (frame:A#B)) (FST (a:A#B))`, + `ra_op (R2:(B)ra) (SND (frame:A#B)) (SND (a:A#B))`, + `ra_op (R1:(A)ra) (FST (frame:A#B)) (FST (b:A#B))`, + `ra_op (R2:(B)ra) (SND (frame:A#B)) (SND (b:A#B))`), + get_theorem_by_name("PAIR_EQ")); + thm operation_components = eq_mp_rule( + operation_pair_equivalence, + product_ops_equal); + + thm left_equal = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `FST (frame:A#B)`, + `FST (a:A#B)`, + `FST (b:A#B)`), + ra_cancellative_apply); + left_equal = mp_rule( + left_equal, + assume_rule(`ra_cancellative (R1:(A)ra)`)); + left_equal = mp_rule( + left_equal, + conjunct1_rule(source_components)); + left_equal = mp_rule( + left_equal, + conjunct1_rule(operation_components)); + + thm right_equal = ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `SND (frame:A#B)`, + `SND (a:A#B)`, + `SND (b:A#B)`), + ra_cancellative_apply); + right_equal = mp_rule( + right_equal, + assume_rule(`ra_cancellative (R2:(B)ra)`)); + right_equal = mp_rule( + right_equal, + conjunct2_rule(source_components)); + right_equal = mp_rule( + right_equal, + conjunct2_rule(operation_components)); + + thm target_pair_equivalence = ispecl_rule( + TERM_LIST( + `FST (a:A#B)`, + `SND (a:A#B)`, + `FST (b:A#B)`, + `SND (b:A#B)`), + get_theorem_by_name("PAIR_EQ")); + thm projected_equal = eq_mp_rule( + gsym_rule(target_pair_equivalence), + conj_rule(left_equal, right_equal)); + thm source_eta = ispec_rule( + `a:A#B`, + get_theorem_by_name("PAIR")); + thm target_eta = ispec_rule( + `b:A#B`, + get_theorem_by_name("PAIR")); + ACCEPT_TAC( + body, + trans_rule( + gsym_rule(source_eta), + trans_rule(projected_equal, target_eta))); + return gnode_prove(root); +} + +PROOF thm prod_ra_cancellative = prove_prod_ra_cancellative(); + +/* Recover left cancellation by embedding the right component at its unit. */ +PROOF static thm prove_prod_ra_cancellative_elim_left(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra). + ra_cancellative (prod_ra R1 R2) ==> + ra_cancellative R1 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = AUTO_INTROS_TAC(body); + + term product_frame = `((frame:A),ra_unit (R2:(B)ra))`; + term product_a = `((a:A),ra_unit (R2:(B)ra))`; + term product_b = `((b:A),ra_unit (R2:(B)ra))`; + thm right_unit_valid = ra_valid_unit; + right_unit_valid = ispec_rule(`R2:(B)ra`, right_unit_valid); + thm right_unit_op = ispecl_rule( + TERM_LIST(`R2:(B)ra`, `ra_unit (R2:(B)ra)`), + ra_unit_l); + thm right_composition_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (R2:(B)ra):B->bool`, + gsym_rule(right_unit_op)), + right_unit_valid); + thm explicit_source_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `(ra_op (R1:(A)ra) (frame:A) (a:A), + ra_op (R2:(B)ra) (ra_unit R2) (ra_unit R2))`), + prod_ra_valid); + explicit_source_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + explicit_source_validity); + thm explicit_source_valid = eq_mp_rule( + gsym_rule(explicit_source_validity), + conj_rule( + assume_rule(` + ra_valid + (R1:(A)ra) + (ra_op R1 (frame:A) (a:A)) + `), + right_composition_valid)); + thm source_op = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, product_frame, product_a), + prod_ra_op); + source_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_op); + thm source_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(source_op)), + explicit_source_valid); + + thm explicit_ops_equal = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `ra_op (R1:(A)ra) (frame:A) (a:A)`, + `ra_op (R2:(B)ra) (ra_unit R2) (ra_unit R2)`, + `ra_op (R1:(A)ra) (frame:A) (b:A)`, + `ra_op (R2:(B)ra) (ra_unit R2) (ra_unit R2)`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + assume_rule(` + ra_op (R1:(A)ra) (frame:A) (a:A) == + ra_op R1 frame (b:A) + `), + refl_rule(`ra_op (R2:(B)ra) (ra_unit R2) (ra_unit R2)`))); + thm target_op = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, product_frame, product_b), + prod_ra_op); + target_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_op); + thm product_ops_equal = trans_rule( + source_op, + trans_rule(explicit_ops_equal, gsym_rule(target_op))); + + thm cancelled = ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + product_frame, + product_a, + product_b), + ra_cancellative_apply); + cancelled = mp_rule( + cancelled, + assume_rule(`ra_cancellative (prod_ra (R1:(A)ra) (R2:(B)ra))`)); + cancelled = mp_rule(cancelled, source_valid); + cancelled = mp_rule(cancelled, product_ops_equal); + thm projected = ap_term_rule(`FST:(A#B)->A`, cancelled); + projected = pure_rewrite_rule( + THM_LIST(get_theorem_by_name("FST")), + projected); + ACCEPT_TAC(body, projected); + return gnode_prove(root); +} + +PROOF static thm prod_ra_cancellative_elim_left = + prove_prod_ra_cancellative_elim_left(); + +/* Symmetric embedding at the valid left unit. */ +PROOF static thm prove_prod_ra_cancellative_elim_right(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra). + ra_cancellative (prod_ra R1 R2) ==> + ra_cancellative R2 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_cancellative_def))); + body = AUTO_INTROS_TAC(body); + + term product_frame = `(ra_unit (R1:(A)ra),(frame:B))`; + term product_a = `(ra_unit (R1:(A)ra),(a:B))`; + term product_b = `(ra_unit (R1:(A)ra),(b:B))`; + thm left_unit_valid = ispec_rule(`R1:(A)ra`, ra_valid_unit); + thm left_unit_op = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `ra_unit (R1:(A)ra)`), + ra_unit_l); + thm left_composition_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (R1:(A)ra):A->bool`, + gsym_rule(left_unit_op)), + left_unit_valid); + thm explicit_source_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `(ra_op (R1:(A)ra) (ra_unit R1) (ra_unit R1), + ra_op (R2:(B)ra) (frame:B) (a:B))`), + prod_ra_valid); + explicit_source_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + explicit_source_validity); + thm explicit_source_valid = eq_mp_rule( + gsym_rule(explicit_source_validity), + conj_rule( + left_composition_valid, + assume_rule(` + ra_valid + (R2:(B)ra) + (ra_op R2 (frame:B) (a:B)) + `))); + thm source_op = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, product_frame, product_a), + prod_ra_op); + source_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_op); + thm source_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(source_op)), + explicit_source_valid); + + thm explicit_ops_equal = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `ra_op (R1:(A)ra) (ra_unit R1) (ra_unit R1)`, + `ra_op (R2:(B)ra) (frame:B) (a:B)`, + `ra_op (R1:(A)ra) (ra_unit R1) (ra_unit R1)`, + `ra_op (R2:(B)ra) (frame:B) (b:B)`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + refl_rule(`ra_op (R1:(A)ra) (ra_unit R1) (ra_unit R1)`), + assume_rule(` + ra_op (R2:(B)ra) (frame:B) (a:B) == + ra_op R2 frame (b:B) + `))); + thm target_op = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`, product_frame, product_b), + prod_ra_op); + target_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_op); + thm product_ops_equal = trans_rule( + source_op, + trans_rule(explicit_ops_equal, gsym_rule(target_op))); + + thm cancelled = ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + product_frame, + product_a, + product_b), + ra_cancellative_apply); + cancelled = mp_rule( + cancelled, + assume_rule(`ra_cancellative (prod_ra (R1:(A)ra) (R2:(B)ra))`)); + cancelled = mp_rule(cancelled, source_valid); + cancelled = mp_rule(cancelled, product_ops_equal); + thm projected = ap_term_rule(`SND:(A#B)->B`, cancelled); + projected = pure_rewrite_rule( + THM_LIST(get_theorem_by_name("SND")), + projected); + ACCEPT_TAC(body, projected); + return gnode_prove(root); +} + +PROOF static thm prod_ra_cancellative_elim_right = + prove_prod_ra_cancellative_elim_right(); + +PROOF static thm prove_prod_ra_cancellative_iff(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra). + ra_cancellative (prod_ra R1 R2) <=> + ra_cancellative R1 && ra_cancellative R2 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hproduct"); + gnode_list components = CONJ_TAC(forward); + ACCEPT_TAC( + components[0], + mp_rule( + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`), + prod_ra_cancellative_elim_left), + assume_rule(`ra_cancellative (prod_ra (R1:(A)ra) (R2:(B)ra))`))); + ACCEPT_TAC( + components[1], + mp_rule( + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`), + prod_ra_cancellative_elim_right), + assume_rule(`ra_cancellative (prod_ra (R1:(A)ra) (R2:(B)ra))`))); + + gnode reverse = DISCH_TAC(directions[1], "Hcomponents"); + thm result = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `R2:(B)ra`), + prod_ra_cancellative); + result = mp_rule( + result, + conjunct1_rule(assume_rule(` + ra_cancellative (R1:(A)ra) && ra_cancellative (R2:(B)ra) + `))); + result = mp_rule( + result, + conjunct2_rule(assume_rule(` + ra_cancellative (R1:(A)ra) && ra_cancellative (R2:(B)ra) + `))); + ACCEPT_TAC(reverse, result); + return gnode_prove(root); +} + +PROOF thm prod_ra_cancellative_iff = + prove_prod_ra_cancellative_iff(); + +/* + * Select one result from each component update at the corresponding + * component of an arbitrary product frame. The result predicate is kept as + * an exact existential pair, rather than weakened to projections of an + * otherwise unconstrained product value. + */ +PROOF static thm prove_prod_ra_updateP(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (P1:A->bool) (P2:B->bool). + ra_updateP R1 a1 P1 ==> + ra_updateP R2 a2 P2 ==> + ra_updateP + (prod_ra R1 R2) + (a1,a2) + (\x:A#B. + exists b1:A. exists b2:B. + P1 b1 && P2 b2 && x == (b1,b2)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + + thm source_valid = assume_rule(` + ra_valid + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (ra_op + (prod_ra R1 R2) + ((a1:A),(a2:B)) + (frame:A#B)) + `); + thm source_valid_rule = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + (frame:A#B)`), + prod_ra_valid); + thm source_components = eq_mp_rule(source_valid_rule, source_valid); + thm source_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((a1:A),(a2:B))`, + `frame:A#B`), + prod_ra_op); + source_components = pure_rewrite_rule( + THM_LIST( + source_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_components); + + thm left_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(` + ra_updateP (R1:(A)ra) (a1:A) (P1:A->bool) + `)); + thm left_selected = mp_rule( + spec_rule(`FST (frame:A#B)`, left_update), + conjunct1_rule(source_components)); + body = ASSUME_TAC(body, left_selected, "Hleft_selected"); + body = ASMP_EXISTS_TAC(body, "Hleft_selected", "b1"); + body = ASMP_CONJ_TAC( + body, + "Hleft_selected", + "HP1_b1", + "Hb1_valid"); + + thm right_update = pure_once_rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(` + ra_updateP (R2:(B)ra) (a2:B) (P2:B->bool) + `)); + thm right_selected = mp_rule( + spec_rule(`SND (frame:A#B)`, right_update), + conjunct2_rule(source_components)); + body = ASSUME_TAC(body, right_selected, "Hright_selected"); + body = ASMP_EXISTS_TAC(body, "Hright_selected", "b2"); + body = ASMP_CONJ_TAC( + body, + "Hright_selected", + "HP2_b2", + "Hb2_valid"); + + body = EXISTS_TAC(body, `((b1:A),(b2:B))`); + gnode_list result_parts = CONJ_TAC(body); + + gnode predicate = EXISTS_TAC(result_parts[0], `b1:A`); + predicate = EXISTS_TAC(predicate, `b2:B`); + gnode_list predicate_left = CONJ_TAC(predicate); + ACCEPT_TAC( + predicate_left[0], + assume_rule(`(P1:A->bool) (b1:A)`)); + gnode_list predicate_right = CONJ_TAC(predicate_left[1]); + ACCEPT_TAC( + predicate_right[0], + assume_rule(`(P2:B->bool) (b2:B)`)); + ACCEPT_TAC( + predicate_right[1], + refl_rule(`((b1:A),(b2:B))`)); + + thm result_valid_rule = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((b1:A),(b2:B)) + (frame:A#B)`), + prod_ra_valid); + thm result_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((b1:A),(b2:B))`, + `frame:A#B`), + prod_ra_op); + result_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + result_op); + thm result_fst = ap_term_rule( + `FST:(A#B)->A`, + result_op); + result_fst = pure_once_rewrite_rule( + THM_LIST(get_theorem_by_name("FST")), + result_fst); + thm result_snd = ap_term_rule( + `SND:(A#B)->B`, + result_op); + result_snd = pure_once_rewrite_rule( + THM_LIST(get_theorem_by_name("SND")), + result_snd); + thm result_fst_valid = ap_term_rule( + `ra_valid (R1:(A)ra):A->bool`, + result_fst); + thm result_snd_valid = ap_term_rule( + `ra_valid (R2:(B)ra):B->bool`, + result_snd); + thm result_components = conj_rule( + eq_mp_rule( + gsym_rule(result_fst_valid), + assume_rule(` + ra_valid + (R1:(A)ra) + (ra_op R1 (b1:A) (FST (frame:A#B))) + `)), + eq_mp_rule( + gsym_rule(result_snd_valid), + assume_rule(` + ra_valid + (R2:(B)ra) + (ra_op R2 (b2:B) (SND (frame:A#B))) + `))); + ACCEPT_TAC( + result_parts[1], + eq_mp_rule(gsym_rule(result_valid_rule), result_components)); + return gnode_prove(root); +} + +PROOF thm prod_ra_updateP = prove_prod_ra_updateP(); + +/* Deterministic component updates preserve every product frame pointwise. */ +PROOF static thm prove_prod_ra_update(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b1:A) (b2:B). + ra_update R1 a1 b1 ==> + ra_update R2 a2 b2 ==> + ra_update (prod_ra R1 R2) (a1,a2) (b1,b2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_update_def))); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `((b1:A),(b2:B))`); + gnode_list update_result = CONJ_TAC(body); + ACCEPT_TAC(update_result[0], refl_rule(`((b1:A),(b2:B))`)); + + thm source_valid = assume_rule(` + ra_valid + (prod_ra (R1:(A)ra) (R2:(B)ra)) + (ra_op + (prod_ra R1 R2) + ((a1:A),(a2:B)) + (frame:A#B)) + `); + thm source_valid_rule = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + (frame:A#B)`), + prod_ra_valid); + thm source_components = eq_mp_rule(source_valid_rule, source_valid); + thm source_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((a1:A),(a2:B))`, + `frame:A#B`), + prod_ra_op); + source_components = pure_rewrite_rule( + THM_LIST( + source_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_components); + + thm left_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `a1:A`, + `b1:A`, + `FST (frame:A#B)`), + ra_update_frame), + assume_rule(`ra_update (R1:(A)ra) (a1:A) (b1:A)`)); + thm left_valid = mp_rule( + match_mp_rule(ra_update_valid, left_update), + conjunct1_rule(source_components)); + thm right_update = mp_rule( + ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `a2:B`, + `b2:B`, + `SND (frame:A#B)`), + ra_update_frame), + assume_rule(`ra_update (R2:(B)ra) (a2:B) (b2:B)`)); + thm right_valid = mp_rule( + match_mp_rule(ra_update_valid, right_update), + conjunct2_rule(source_components)); + + thm result_valid_rule = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((b1:A),(b2:B)) + (frame:A#B)`), + prod_ra_valid); + thm result_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((b1:A),(b2:B))`, + `frame:A#B`), + prod_ra_op); + result_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + result_op); + thm result_fst = ap_term_rule( + `FST:(A#B)->A`, + result_op); + result_fst = pure_once_rewrite_rule( + THM_LIST(get_theorem_by_name("FST")), + result_fst); + thm result_snd = ap_term_rule( + `SND:(A#B)->B`, + result_op); + result_snd = pure_once_rewrite_rule( + THM_LIST(get_theorem_by_name("SND")), + result_snd); + thm result_fst_valid = ap_term_rule( + `ra_valid (R1:(A)ra):A->bool`, + result_fst); + thm result_snd_valid = ap_term_rule( + `ra_valid (R2:(B)ra):B->bool`, + result_snd); + ACCEPT_TAC( + update_result[1], + eq_mp_rule( + gsym_rule(result_valid_rule), + conj_rule( + eq_mp_rule(gsym_rule(result_fst_valid), left_valid), + eq_mp_rule(gsym_rule(result_snd_valid), right_valid)))); + return gnode_prove(root); +} + +PROOF thm prod_ra_update = prove_prod_ra_update(); + +/* Observe a product update through a frame in one component and the valid + * unit frame in the other. The other source component must itself be valid + * or the product update may be vacuous. */ +PROOF static thm prove_prod_ra_update_elim_left(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b1:A) (b2:B). + ra_update (prod_ra R1 R2) (a1,a2) (b1,b2) ==> + ra_valid R2 a2 ==> + ra_update R1 a1 b1 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_update_def))); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `b1:A`); + gnode_list update_result = CONJ_TAC(body); + ACCEPT_TAC(update_result[0], refl_rule(`b1:A`)); + + thm right_unit = ispecl_rule( + TERM_LIST(`R2:(B)ra`, `a2:B`), + ra_unit_r); + thm right_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (R2:(B)ra):B->bool`, + gsym_rule(right_unit)), + assume_rule(`ra_valid (R2:(B)ra) (a2:B)`)); + thm source_pair_valid = conj_rule( + assume_rule(`ra_valid (R1:(A)ra) (ra_op R1 (a1:A) (frame:A))`), + right_valid); + + term product_frame = `((frame:A),ra_unit (R2:(B)ra))`; + thm source_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `(ra_op (R1:(A)ra) (a1:A) (frame:A), + ra_op (R2:(B)ra) (a2:B) (ra_unit R2))`), + prod_ra_valid); + source_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_validity); + thm source_explicit_valid = eq_mp_rule( + gsym_rule(source_validity), + source_pair_valid); + thm source_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((a1:A),(a2:B))`, + product_frame), + prod_ra_op); + source_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_op); + thm source_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(source_op)), + source_explicit_valid); + + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + `((a1:A),(a2:B))`, + `((b1:A),(b2:B))`, + product_frame), + ra_update_frame), + assume_rule(` + ra_update + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + ((b1:A),(b2:B)) + `)); + thm target_valid = mp_rule( + match_mp_rule(ra_update_valid, framed_update), + source_valid); + + thm target_components = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((b1:A),(b2:B)) + ((frame:A),ra_unit R2)`), + prod_ra_valid), + target_valid); + target_components = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_components); + ACCEPT_TAC(update_result[1], conjunct1_rule(target_components)); + return gnode_prove(root); +} + +PROOF thm prod_ra_update_elim_left = + prove_prod_ra_update_elim_left(); + +PROOF static thm prove_prod_ra_update_elim_right(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b1:A) (b2:B). + ra_update (prod_ra R1 R2) (a1,a2) (b1,b2) ==> + ra_valid R1 a1 ==> + ra_update R2 a2 b2 + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_update_def))); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `b2:B`); + gnode_list update_result = CONJ_TAC(body); + ACCEPT_TAC(update_result[0], refl_rule(`b2:B`)); + + thm left_unit = ispecl_rule( + TERM_LIST(`R1:(A)ra`, `a1:A`), + ra_unit_r); + thm left_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (R1:(A)ra):A->bool`, + gsym_rule(left_unit)), + assume_rule(`ra_valid (R1:(A)ra) (a1:A)`)); + thm source_pair_valid = conj_rule( + left_valid, + assume_rule(`ra_valid (R2:(B)ra) (ra_op R2 (a2:B) (frame:B))`)); + + term product_frame = `(ra_unit (R1:(A)ra),(frame:B))`; + thm source_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `(ra_op (R1:(A)ra) (a1:A) (ra_unit R1), + ra_op (R2:(B)ra) (a2:B) (frame:B))`), + prod_ra_valid); + source_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_validity); + thm source_explicit_valid = eq_mp_rule( + gsym_rule(source_validity), + source_pair_valid); + thm source_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((a1:A),(a2:B))`, + product_frame), + prod_ra_op); + source_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_op); + thm source_valid = eq_mp_rule( + ap_term_rule( + `ra_valid (prod_ra (R1:(A)ra) (R2:(B)ra)):A#B->bool`, + gsym_rule(source_op)), + source_explicit_valid); + + thm framed_update = mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + `((a1:A),(a2:B))`, + `((b1:A),(b2:B))`, + product_frame), + ra_update_frame), + assume_rule(` + ra_update + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + ((b1:A),(b2:B)) + `)); + thm target_valid = mp_rule( + match_mp_rule(ra_update_valid, framed_update), + source_valid); + + thm target_components = eq_mp_rule( + ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((b1:A),(b2:B)) + (ra_unit R1,(frame:B))`), + prod_ra_valid), + target_valid); + target_components = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_components); + ACCEPT_TAC(update_result[1], conjunct2_rule(target_components)); + return gnode_prove(root); +} + +PROOF thm prod_ra_update_elim_right = + prove_prod_ra_update_elim_right(); + +PROOF static thm prove_prod_ra_update_iff(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b1:A) (b2:B). + ra_valid R1 a1 ==> + ra_valid R2 a2 ==> + (ra_update (prod_ra R1 R2) (a1,a2) (b1,b2) <=> + ra_update R1 a1 b1 && ra_update R2 a2 b2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + gnode_list components = CONJ_TAC(forward); + thm left = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, `R2:(B)ra`, + `a1:A`, `a2:B`, `b1:A`, `b2:B`), + prod_ra_update_elim_left); + left = mp_rule(left, assume_rule(` + ra_update + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + ((b1:A),(b2:B)) + `)); + left = mp_rule(left, assume_rule(`ra_valid (R2:(B)ra) (a2:B)`)); + ACCEPT_TAC(components[0], left); + + thm right = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, `R2:(B)ra`, + `a1:A`, `a2:B`, `b1:A`, `b2:B`), + prod_ra_update_elim_right); + right = mp_rule(right, assume_rule(` + ra_update + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + ((b1:A),(b2:B)) + `)); + right = mp_rule(right, assume_rule(`ra_valid (R1:(A)ra) (a1:A)`)); + ACCEPT_TAC(components[1], right); + + gnode reverse = DISCH_TAC(directions[1], "Hcomponents"); + thm result = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, `R2:(B)ra`, + `a1:A`, `a2:B`, `b1:A`, `b2:B`), + prod_ra_update); + result = mp_rule( + result, + conjunct1_rule(assume_rule(` + ra_update (R1:(A)ra) (a1:A) (b1:A) && + ra_update (R2:(B)ra) (a2:B) (b2:B) + `))); + result = mp_rule( + result, + conjunct2_rule(assume_rule(` + ra_update (R1:(A)ra) (a1:A) (b1:A) && + ra_update (R2:(B)ra) (a2:B) (b2:B) + `))); + ACCEPT_TAC(reverse, result); + return gnode_prove(root); +} + +PROOF thm prod_ra_update_iff = + prove_prod_ra_update_iff(); + +/* + * Pure predicate normalization used after combining a left update with ND + * reflexivity on the right. The equality-selected right result is + * substituted into the exact pair image; no unrelated product is admitted. + */ +PROOF static thm prove_prod_ra_left_image_imp(void) { + term goal_tm = ` + forall (P:A->bool) (a2:B) (x:A#B). + (exists b1:A. exists b2:B. + P b1 && b2 == a2 && x == (b1,b2)) ==> + exists b1:A. + P b1 && x == (b1,a2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "P"); + body = GEN_TAC(body, "a2"); + body = GEN_TAC(body, "x"); + body = DISCH_TAC(body, "Himage"); + body = ASMP_EXISTS_TAC(body, "Himage", "b1"); + body = ASMP_EXISTS_TAC(body, "Himage", "b2"); + body = ASMP_CONJ_TAC( + body, "Himage", "HP", "Himage_rest"); + body = ASMP_CONJ_TAC( + body, "Himage_rest", "Hfixed", "Hpair"); + body = EXISTS_TAC(body, `b1:A`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`(P:A->bool) (b1:A)`)); + ACCEPT_TAC( + result[1], + rewrite_rule( + THM_LIST(assume_rule(`(b2:B) == (a2:B)`)), + assume_rule(` + (x:A#B) == ((b1:A),(b2:B)) + `))); + return gnode_prove(root); +} + +PROOF static thm prod_ra_left_image_imp = + prove_prod_ra_left_image_imp(); + +/* + * Update only the left component by combining the requested ND update with + * right-side ND reflexivity, then normalize the exact product image. + */ +PROOF static thm prove_prod_ra_update_leftP(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (P:A->bool). + ra_updateP R1 a1 P ==> + ra_updateP + (prod_ra R1 R2) + (a1,a2) + (\x:A#B. exists b1:A. P b1 && x == (b1,a2)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term fixed_right = ` + \b2:B. b2 == (a2:B) + `; + term combined_predicate = ` + \x:A#B. + exists b1:A. exists b2:B. + (P:A->bool) b1 && + b2 == (a2:B) && + x == (b1,b2) + `; + term left_image = ` + \x:A#B. + exists b1:A. + (P:A->bool) b1 && x == (b1,(a2:B)) + `; + + thm combined = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `a1:A`, + `a2:B`, + `P:A->bool`, + fixed_right), + prod_ra_updateP); + combined = mp_rule( + combined, + assume_rule(` + ra_updateP (R1:(A)ra) (a1:A) (P:A->bool) + `)); + combined = mp_rule( + combined, + ispecl_rule( + TERM_LIST(`R2:(B)ra`, `a2:B`), + ra_updateP_refl)); + combined = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + combined); + + thm weakened = ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + `((a1:A),(a2:B))`, + combined_predicate, + left_image), + ra_updateP_mono); + weakened = mp_rule(weakened, combined); + weakened = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + weakened); + thm image_implication = ispecl_rule( + TERM_LIST(`P:A->bool`, `a2:B`), + prod_ra_left_image_imp); + ACCEPT_TAC( + body, + mp_rule(weakened, image_implication)); + return gnode_prove(root); +} + +PROOF static thm prod_ra_update_leftP = prove_prod_ra_update_leftP(); + +/* The deterministic one-sided rule is product update plus reflexivity. */ +PROOF static thm prove_prod_ra_update_left(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b1:A). + ra_update R1 a1 b1 ==> + ra_update (prod_ra R1 R2) (a1,a2) (b1,a2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm combined = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `a1:A`, + `a2:B`, + `b1:A`, + `a2:B`), + prod_ra_update); + combined = mp_rule( + combined, + assume_rule(`ra_update (R1:(A)ra) (a1:A) (b1:A)`)); + combined = mp_rule( + combined, + ispecl_rule( + TERM_LIST(`R2:(B)ra`, `a2:B`), + ra_update_refl)); + ACCEPT_TAC(body, combined); + return gnode_prove(root); +} + +PROOF thm prod_ra_update_left = prove_prod_ra_update_left(); + +/* Symmetric exact-image normalization for a fixed left component. */ +PROOF static thm prove_prod_ra_right_image_imp(void) { + term goal_tm = ` + forall (a1:A) (P:B->bool) (x:A#B). + (exists b1:A. exists b2:B. + b1 == a1 && P b2 && x == (b1,b2)) ==> + exists b2:B. + P b2 && x == (a1,b2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a1"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "x"); + body = DISCH_TAC(body, "Himage"); + body = ASMP_EXISTS_TAC(body, "Himage", "b1"); + body = ASMP_EXISTS_TAC(body, "Himage", "b2"); + body = ASMP_CONJ_TAC( + body, "Himage", "Hfixed", "Himage_rest"); + body = ASMP_CONJ_TAC( + body, "Himage_rest", "HP", "Hpair"); + body = EXISTS_TAC(body, `b2:B`); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`(P:B->bool) (b2:B)`)); + ACCEPT_TAC( + result[1], + rewrite_rule( + THM_LIST(assume_rule(`(b1:A) == (a1:A)`)), + assume_rule(` + (x:A#B) == ((b1:A),(b2:B)) + `))); + return gnode_prove(root); +} + +PROOF static thm prod_ra_right_image_imp = + prove_prod_ra_right_image_imp(); + +/* Combine left-side ND reflexivity with the requested right update. */ +PROOF static thm prove_prod_ra_update_rightP(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (P:B->bool). + ra_updateP R2 a2 P ==> + ra_updateP + (prod_ra R1 R2) + (a1,a2) + (\x:A#B. exists b2:B. P b2 && x == (a1,b2)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + term fixed_left = ` + \b1:A. b1 == (a1:A) + `; + term combined_predicate = ` + \x:A#B. + exists b1:A. exists b2:B. + b1 == (a1:A) && + (P:B->bool) b2 && + x == (b1,b2) + `; + term right_image = ` + \x:A#B. + exists b2:B. + (P:B->bool) b2 && x == ((a1:A),b2) + `; + + thm combined = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `a1:A`, + `a2:B`, + fixed_left, + `P:B->bool`), + prod_ra_updateP); + combined = mp_rule( + combined, + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `a1:A`), + ra_updateP_refl)); + combined = mp_rule( + combined, + assume_rule(` + ra_updateP (R2:(B)ra) (a2:B) (P:B->bool) + `)); + combined = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + combined); + + thm weakened = ispecl_rule( + TERM_LIST( + `prod_ra (R1:(A)ra) (R2:(B)ra)`, + `((a1:A),(a2:B))`, + combined_predicate, + right_image), + ra_updateP_mono); + weakened = mp_rule(weakened, combined); + weakened = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + weakened); + thm image_implication = ispecl_rule( + TERM_LIST(`a1:A`, `P:B->bool`), + prod_ra_right_image_imp); + ACCEPT_TAC( + body, + mp_rule(weakened, image_implication)); + return gnode_prove(root); +} + +PROOF static thm prod_ra_update_rightP = prove_prod_ra_update_rightP(); + +/* The deterministic right-only rule is product update plus reflexivity. */ +PROOF static thm prove_prod_ra_update_right(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (a2:B) (b2:B). + ra_update R2 a2 b2 ==> + ra_update (prod_ra R1 R2) (a1,a2) (a1,b2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm combined = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `a1:A`, + `a2:B`, + `a1:A`, + `b2:B`), + prod_ra_update); + combined = mp_rule( + combined, + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `a1:A`), + ra_update_refl)); + combined = mp_rule( + combined, + assume_rule(`ra_update (R2:(B)ra) (a2:B) (b2:B)`)); + ACCEPT_TAC(body, combined); + return gnode_prove(root); +} + +PROOF thm prod_ra_update_right = prove_prod_ra_update_right(); + +/* Iris's product local update specializes directly to the discrete unital + * relation used here: project validity and the shared residual frame, run the + * two component updates, then pair their exact residual equations again. */ +PROOF static thm prove_prod_ra_local_update(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (f1:A) (b1:A) (g1:A) + (a2:B) (f2:B) (b2:B) (g2:B). + ra_local_update R1 a1 f1 b1 g1 ==> + ra_local_update R2 a2 f2 b2 g2 ==> + ra_local_update + (prod_ra R1 R2) + (a1,a2) + (f1,f2) + (b1,b2) + (g1,g2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + + thm source_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((a1:A),(a2:B))`), + prod_ra_valid); + source_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + source_validity); + thm source_components = eq_mp_rule( + source_validity, + assume_rule(` + ra_valid + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((a1:A),(a2:B)) + `)); + + thm source_extension = assume_rule(` + ((a1:A),(a2:B)) == + ra_op + (prod_ra (R1:(A)ra) (R2:(B)ra)) + ((f1:A),(f2:B)) + (residual:A#B) + `); + thm left_extension = ap_term_rule(`FST:(A#B)->A`, source_extension); + left_extension = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + left_extension); + thm right_extension = ap_term_rule(`SND:(A#B)->B`, source_extension); + right_extension = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + right_extension); + + thm left_result = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `a1:A`, + `f1:A`, + `b1:A`, + `g1:A`, + `FST (residual:A#B)`), + ra_local_update_apply); + left_result = mp_rule( + left_result, + assume_rule(` + ra_local_update + (R1:(A)ra) + (a1:A) + (f1:A) + (b1:A) + (g1:A) + `)); + left_result = mp_rule(left_result, conjunct1_rule(source_components)); + left_result = mp_rule(left_result, left_extension); + + thm right_result = ispecl_rule( + TERM_LIST( + `R2:(B)ra`, + `a2:B`, + `f2:B`, + `b2:B`, + `g2:B`, + `SND (residual:A#B)`), + ra_local_update_apply); + right_result = mp_rule( + right_result, + assume_rule(` + ra_local_update + (R2:(B)ra) + (a2:B) + (f2:B) + (b2:B) + (g2:B) + `)); + right_result = mp_rule(right_result, conjunct2_rule(source_components)); + right_result = mp_rule(right_result, right_extension); + + gnode_list target = CONJ_TAC(body); + thm target_validity = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((b1:A),(b2:B))`), + prod_ra_valid); + target_validity = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_validity); + ACCEPT_TAC( + target[0], + eq_mp_rule( + gsym_rule(target_validity), + conj_rule( + conjunct1_rule(left_result), + conjunct1_rule(right_result)))); + + thm paired_extensions = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `b1:A`, + `b2:B`, + `ra_op (R1:(A)ra) (g1:A) (FST (residual:A#B))`, + `ra_op (R2:(B)ra) (g2:B) (SND (residual:A#B))`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + conjunct2_rule(left_result), + conjunct2_rule(right_result))); + thm target_op = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, + `R2:(B)ra`, + `((g1:A),(g2:B))`, + `residual:A#B`), + prod_ra_op); + target_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + target_op); + ACCEPT_TAC( + target[1], + trans_rule(paired_extensions, gsym_rule(target_op))); + return gnode_prove(root); +} + +PROOF thm prod_ra_local_update = + prove_prod_ra_local_update(); + +/* One-sided rules are the product rule plus local-update reflexivity. */ +PROOF static thm prove_prod_ra_local_update_left(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (f1:A) (b1:A) (g1:A) + (a2:B) (f2:B). + ra_local_update R1 a1 f1 b1 g1 ==> + ra_local_update + (prod_ra R1 R2) + (a1,a2) + (f1,f2) + (b1,a2) + (g1,f2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm result = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, `R2:(B)ra`, + `a1:A`, `f1:A`, `b1:A`, `g1:A`, + `a2:B`, `f2:B`, `a2:B`, `f2:B`), + prod_ra_local_update); + result = mp_rule( + result, + assume_rule(` + ra_local_update + (R1:(A)ra) + (a1:A) + (f1:A) + (b1:A) + (g1:A) + `)); + result = mp_rule( + result, + ispecl_rule( + TERM_LIST(`R2:(B)ra`, `a2:B`, `f2:B`), + ra_local_update_refl)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF static thm prod_ra_local_update_left = + prove_prod_ra_local_update_left(); + +PROOF static thm prove_prod_ra_local_update_right(void) { + term goal_tm = ` + forall (R1:(A)ra) (R2:(B)ra) + (a1:A) (f1:A) + (a2:B) (f2:B) (b2:B) (g2:B). + ra_local_update R2 a2 f2 b2 g2 ==> + ra_local_update + (prod_ra R1 R2) + (a1,a2) + (f1,f2) + (a1,b2) + (f1,g2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm result = ispecl_rule( + TERM_LIST( + `R1:(A)ra`, `R2:(B)ra`, + `a1:A`, `f1:A`, `a1:A`, `f1:A`, + `a2:B`, `f2:B`, `b2:B`, `g2:B`), + prod_ra_local_update); + result = mp_rule( + result, + ispecl_rule( + TERM_LIST(`R1:(A)ra`, `a1:A`, `f1:A`), + ra_local_update_refl)); + result = mp_rule( + result, + assume_rule(` + ra_local_update + (R2:(B)ra) + (a2:B) + (f2:B) + (b2:B) + (g2:B) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF static thm prod_ra_local_update_right = + prove_prod_ra_local_update_right(); + +/* ------------------------------------------------------------------------- */ +/* Canonical embeddings */ +/* ------------------------------------------------------------------------- */ + +PROOF static thm prod_inl_raw_def = new_fun_definition(` + prod_inl (R:(A)ra) (S:(B)ra) (a:A) : A#B = + (a,ra_unit S) +`); + +PROOF static thm prove_prod_inl_def(void) { + term R = `R:(A)ra`; + term S = `S:(B)ra`; + term a = `a:A`; + return gen_rule(R, gen_rule(S, gen_rule(a, prod_inl_raw_def))); +} + +PROOF thm prod_inl_def = prove_prod_inl_def(); + +PROOF static thm prod_inr_raw_def = new_fun_definition(` + prod_inr (R:(A)ra) (S:(B)ra) (b:B) : A#B = + (ra_unit R,b) +`); + +PROOF static thm prove_prod_inr_def(void) { + term R = `R:(A)ra`; + term S = `S:(B)ra`; + term b = `b:B`; + return gen_rule(R, gen_rule(S, gen_rule(b, prod_inr_raw_def))); +} + +PROOF thm prod_inr_def = prove_prod_inr_def(); + +PROOF static thm prove_prod_inl_op(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:A) (b:A). + prod_inl R S (ra_op R a b) == + ra_op (prod_ra R S) (prod_inl R S a) (prod_inl R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + prod_inl_def, + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_unit_l))); + return gnode_prove(root); +} + +PROOF thm prod_inl_op = prove_prod_inl_op(); + +PROOF static thm prove_prod_inr_op(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:B) (b:B). + prod_inr R S (ra_op S a b) == + ra_op (prod_ra R S) (prod_inr R S a) (prod_inr R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + prod_inr_def, + prod_ra_op, + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_unit_l))); + return gnode_prove(root); +} + +PROOF thm prod_inr_op = prove_prod_inr_op(); + +PROOF static thm prove_prod_inl_updateP(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:A) (P:A->bool). + ra_updateP R a P ==> + ra_updateP + (prod_ra R S) + (prod_inl R S a) + (\x:A#B. exists b:A. P b && x == prod_inl R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `a:A`, + `ra_unit (S:(B)ra)`, + `P:A->bool`), + prod_ra_update_leftP), + assume_rule(`ra_updateP (R:(A)ra) (a:A) (P:A->bool)`)); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST(prod_inl_def))); + ACCEPT_TAC(body, lifted); + return gnode_prove(root); +} + +PROOF thm prod_inl_updateP = prove_prod_inl_updateP(); + +PROOF static thm prove_prod_inr_updateP(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:B) (P:B->bool). + ra_updateP S a P ==> + ra_updateP + (prod_ra R S) + (prod_inr R S a) + (\x:A#B. exists b:B. P b && x == prod_inr R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `ra_unit (R:(A)ra)`, + `a:B`, + `P:B->bool`), + prod_ra_update_rightP), + assume_rule(`ra_updateP (S:(B)ra) (a:B) (P:B->bool)`)); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST(prod_inr_def))); + ACCEPT_TAC(body, lifted); + return gnode_prove(root); +} + +PROOF thm prod_inr_updateP = prove_prod_inr_updateP(); + +PROOF static thm prove_prod_inl_update(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:A) (b:A). + ra_update R a b ==> + ra_update + (prod_ra R S) + (prod_inl R S a) + (prod_inl R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `a:A`, + `ra_unit (S:(B)ra)`, + `b:A`), + prod_ra_update_left), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST(prod_inl_def))); + ACCEPT_TAC(body, lifted); + return gnode_prove(root); +} + +PROOF thm prod_inl_update = prove_prod_inl_update(); + +PROOF static thm prove_prod_inr_update(void) { + term goal_tm = ` + forall (R:(A)ra) (S:(B)ra) (a:B) (b:B). + ra_update S a b ==> + ra_update + (prod_ra R S) + (prod_inr R S a) + (prod_inr R S b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `ra_unit (R:(A)ra)`, + `a:B`, + `b:B`), + prod_ra_update_right), + assume_rule(`ra_update (S:(B)ra) (a:B) (b:B)`)); + body = CONV_TAC( + body, + rewrite_conv(THM_LIST(prod_inr_def))); + ACCEPT_TAC(body, lifted); + return gnode_prove(root); +} + +PROOF thm prod_inr_update = prove_prod_inr_update(); + +PROOF static int audit_prod_ra(void) { + thm_list source_theorems = THM_LIST( + prod_ra_op_def, + prod_ra_valid_def, + prod_ra_laws, + prod_ra_def, + prod_ra_unit, + prod_ra_op_fn, + prod_ra_valid_fn, + prod_ra_op, + prod_ra_valid, + prod_ra_included, + prod_ra_maximal, + prod_ra_maximal_elim_left, + prod_ra_maximal_elim_right, + prod_ra_maximal_iff, + prod_ra_cancellative, + prod_ra_cancellative_elim_left, + prod_ra_cancellative_elim_right, + prod_ra_cancellative_iff, + prod_ra_updateP, + prod_ra_update, + prod_ra_update_elim_left, + prod_ra_update_elim_right, + prod_ra_update_iff, + prod_ra_left_image_imp, + prod_ra_update_leftP, + prod_ra_update_left, + prod_ra_right_image_imp, + prod_ra_update_rightP, + prod_ra_update_right, + prod_ra_local_update, + prod_ra_local_update_left, + prod_ra_local_update_right, + prod_inl_raw_def, + prod_inl_def, + prod_inr_raw_def, + prod_inr_def, + prod_inl_op, + prod_inr_op, + prod_inl_updateP, + prod_inr_updateP, + prod_inl_update, + prod_inr_update); + + for (size_t i = 0; i < vector_size(source_theorems); ++i) { + ENSURE_COND(!IS_NULL(source_theorems[i]), + "product RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(source_theorems[i])) == 0, + "product RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == PROD_RA_AXIOMS_BEFORE, + "product RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_prod_ra"); + return -1; +} + +PROOF static int _PROD_RA_AUDIT = audit_prod_ra(); diff --git a/theory/logic/prod_ra.h b/theory/logic/prod_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..9467c78e01bfbfaeebae56c503df08b53e5a852d --- /dev/null +++ b/theory/logic/prod_ra.h @@ -0,0 +1,218 @@ +#pragma once + +/* + * Public interface for binary product resource algebras. + * + * `prod_ra R S : (A#B)ra` combines, validates, and updates both coordinates + * pointwise. `prod_inl` and `prod_inr` embed one coordinate while fixing the + * other coordinate at its unit; they are the canonical way to address one + * component of a larger global ghost RA. + */ + +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Pointwise algebra */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R1 R2. ra_unit (prod_ra R1 R2) == ra_unit R1,ra_unit R2 + * ``` + * + * 乘积 RA 的 unit 由两个分量 RA 的 unit 组成。 + */ +PROOF extern thm prod_ra_unit; + +/* + * ```text + * forall R1 R2 x y. + * ra_op (prod_ra R1 R2) x y == + * ra_op R1 (FST x) (FST y),ra_op R2 (SND x) (SND y) + * ``` + * + * 乘积 RA 中的组合逐分量进行，结果分别为两个底层 RA 的组合。 + */ +PROOF extern thm prod_ra_op; + +/* + * ```text + * forall R1 R2 x. + * ra_valid (prod_ra R1 R2) x <=> ra_valid R1 (FST x) && ra_valid R2 (SND x) + * ``` + * + * 乘积资源 `x` 有效，当且仅当其两个分量在各自 RA 中都有效。 + */ +PROOF extern thm prod_ra_valid; + +/* + * ```text + * forall R1 R2 x y. + * ra_included (prod_ra R1 R2) x y <=> + * ra_included R1 (FST x) (FST y) && ra_included R2 (SND x) (SND y) + * ``` + * + * 乘积资源 `x` 包含于 `y`，当且仅当 `x` 的两个分量分别包含于 `y` 的对应分量。 + */ +PROOF extern thm prod_ra_included; + +/* + * ```text + * forall R1 R2. + * ra_cancellative (prod_ra R1 R2) <=> + * ra_cancellative R1 && ra_cancellative R2 + * ``` + * + * 乘积 RA 可消去，当且仅当两个分量 RA 都可消去。 + */ +PROOF extern thm prod_ra_cancellative_iff; + +/* + * ```text + * forall R1 R2 x. + * ra_maximal (prod_ra R1 R2) x <=> + * ra_maximal R1 (FST x) && ra_maximal R2 (SND x) + * ``` + * + * 乘积资源 `x` 为 maximal，当且仅当它的两个分量在各自 RA 中都为 maximal。 + */ +PROOF extern thm prod_ra_maximal_iff; + +/* ------------------------------------------------------------------------- */ +/* Componentwise updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R1 R2 a1 a2 P1 P2. + * ra_updateP R1 a1 P1 + * ==> ra_updateP R2 a2 P2 + * ==> ra_updateP (prod_ra R1 R2) (a1,a2) + * (\x. exists b1 b2. P1 b1 && P2 b2 && x == b1,b2) + * ``` + * + * 若两个分量分别可更新到 `P1` 和 `P2`，则乘积资源 `(a1,a2)` 可更新到分量分别满足两个谓词的数对。 + */ +PROOF extern thm prod_ra_updateP; + +/* + * ```text + * forall R1 R2 a1 a2 b1. + * ra_update R1 a1 b1 ==> ra_update (prod_ra R1 R2) (a1,a2) (b1,a2) + * ``` + * + * 若第一分量可从 `a1` 更新为 `b1`，则乘积中可保留第二分量 `a2` 不变地执行该更新。 + */ +PROOF extern thm prod_ra_update_left; + +/* + * ```text + * forall R1 R2 a1 a2 b2. + * ra_update R2 a2 b2 ==> ra_update (prod_ra R1 R2) (a1,a2) (a1,b2) + * ``` + * + * 若第二分量可从 `a2` 更新为 `b2`，则乘积中可保留第一分量 `a1` 不变地执行该更新。 + */ +PROOF extern thm prod_ra_update_right; + +/* + * ```text + * forall R1 R2 a1 f1 b1 g1 a2 f2 b2 g2. + * ra_local_update R1 a1 f1 b1 g1 + * ==> ra_local_update R2 a2 f2 b2 g2 + * ==> ra_local_update (prod_ra R1 R2) (a1,a2) (f1,f2) (b1,b2) (g1,g2) + * ``` + * + * 两个分量上的局部更新可合并为乘积 RA 中逐分量的 whole/local 更新。 + */ +PROOF extern thm prod_ra_local_update; + +/* ------------------------------------------------------------------------- */ +/* Canonical component embeddings */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R S a. prod_inl R S a == a,ra_unit S + * ``` + * + * `prod_inl R S a` 将 `a` 放在左分量，并将右分量固定为 `S` 的 unit。 + */ +PROOF extern thm prod_inl_def; + +/* + * ```text + * forall R S b. prod_inr R S b == ra_unit R,b + * ``` + * + * `prod_inr R S b` 将 `b` 放在右分量，并将左分量固定为 `R` 的 unit。 + */ +PROOF extern thm prod_inr_def; + +/* + * ```text + * forall R S a b. + * prod_inl R S (ra_op R a b) == + * ra_op (prod_ra R S) (prod_inl R S a) (prod_inl R S b) + * ``` + * + * 先在 `R` 中组合 `a` 与 `b` 再左嵌入，等于分别左嵌入后在乘积 RA 中组合。 + */ +PROOF extern thm prod_inl_op; + +/* + * ```text + * forall R S a b. + * prod_inr R S (ra_op S a b) == + * ra_op (prod_ra R S) (prod_inr R S a) (prod_inr R S b) + * ``` + * + * 先在 `S` 中组合 `a` 与 `b` 再右嵌入，等于分别右嵌入后在乘积 RA 中组合。 + */ +PROOF extern thm prod_inr_op; + +/* + * ```text + * forall R S a P. + * ra_updateP R a P + * ==> ra_updateP (prod_ra R S) (prod_inl R S a) + * (\x. exists b. P b && x == prod_inl R S b) + * ``` + * + * `a` 在 `R` 中可更新到 `P` 时，其左嵌入可更新到某个左嵌入的满足 `P` 的结果。 + */ +PROOF extern thm prod_inl_updateP; + +/* + * ```text + * forall R S a P. + * ra_updateP S a P + * ==> ra_updateP (prod_ra R S) (prod_inr R S a) + * (\x. exists b. P b && x == prod_inr R S b) + * ``` + * + * `a` 在 `S` 中可更新到 `P` 时，其右嵌入可更新到某个右嵌入的满足 `P` 的结果。 + */ +PROOF extern thm prod_inr_updateP; + +/* + * ```text + * forall R S a b. + * ra_update R a b + * ==> ra_update (prod_ra R S) (prod_inl R S a) (prod_inl R S b) + * ``` + * + * `a -> b` 在 `R` 中成立时，左嵌入后的 `prod_inl a -> prod_inl b` 在乘积 RA 中也成立。 + */ +PROOF extern thm prod_inl_update; + +/* + * ```text + * forall R S a b. + * ra_update S a b + * ==> ra_update (prod_ra R S) (prod_inr R S a) (prod_inr R S b) + * ``` + * + * `a -> b` 在 `S` 中成立时，右嵌入后的 `prod_inr a -> prod_inr b` 在乘积 RA 中也成立。 + */ +PROOF extern thm prod_inr_update; diff --git a/theory/logic/prod_ra_internal.h b/theory/logic/prod_ra_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..047e8ffe9d327bec40ad71e63907dfae8c675fbe --- /dev/null +++ b/theory/logic/prod_ra_internal.h @@ -0,0 +1,20 @@ +#pragma once + +/* + * INTERNAL product-RA proof rules for dependent constructor implementations. + * Ordinary clients use `prod_ra.h`; this header must not be re-exported. + */ + +#include "proof/theory/logic/prod_ra.h" + +/* + * ```text + * forall R1 R2. + * ra_cancellative R1 + * ==> ra_cancellative R2 + * ==> ra_cancellative (prod_ra R1 R2) + * ``` + * + * 若两个分量 RA 都可消去，则它们的乘积 RA 也可消去。 + */ +PROOF extern thm prod_ra_cancellative; diff --git a/theory/logic/product_resource.c b/theory/logic/product_resource.c new file mode 100644 index 0000000000000000000000000000000000000000..3fdceb649befe008e6fe243abcb8b6cce7e317ba --- /dev/null +++ b/theory/logic/product_resource.c @@ -0,0 +1,2074 @@ +#include "proof/theory/logic/product_resource.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/prod_ra.c" +#require "proof/theory/logic/resource_prop.c" + +PROOF static size_t PRODUCT_RESOURCE_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF static thm prove_r_equiv_of_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool). + P == Q ==> r_equiv R P Q + `); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = beta_rule(ap_term_rule( + `\X:A->bool. r_equiv (R:(A)ra) (P:A->bool) X`, + assume_rule(`(P:A->bool) == (Q:A->bool)`))); + ACCEPT_TAC( + body, + eq_mp_rule( + lifted, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_equiv_refl))); + return gnode_prove(root); +} + +PROOF static thm r_equiv_of_eq_product = + prove_r_equiv_of_eq(); + +PROOF thm r_lift_left_def = new_fun_definition(` + r_lift_left + (R:(A)ra) + (S:(B)ra) + (P:A->bool) + (resource:A#B) <=> + P (FST resource) && + SND resource == ra_unit S +`); + +PROOF thm r_lift_right_def = new_fun_definition(` + r_lift_right + (R:(A)ra) + (S:(B)ra) + (Q:B->bool) + (resource:A#B) <=> + FST resource == ra_unit R && + Q (SND resource) +`); + +PROOF thm r_bupd_right_def = new_fun_definition(` + r_bupd_right + (R:(A)ra) + (S:(B)ra) + (Q:(A#B)->bool) + (resource:A#B) <=> + ra_updateP + S + (SND resource) + (\right':B. Q (FST resource,right')) +`); + +PROOF thm r_viewshift_right_def = new_fun_definition(` + r_viewshift_right + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:(A#B)->bool) <=> + r_entails (prod_ra R S) P (r_bupd_right R S Q) +`); + +PROOF static thm prove_r_lift_left_emp_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra). + r_lift_left R S (r_emp R) == + r_emp (prod_ra R S) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ispecl_rule( + TERM_LIST( + `r_lift_left (R:(A)ra) (S:(B)ra) (r_emp R)`, + `r_emp (prod_ra (R:(A)ra) (S:(B)ra))`), + get_theorem_by_name("FUN_EQ_THM"))))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + r_lift_left_def, + r_emp_def, + prod_ra_unit))); + thm pair_components = ispecl_rule( + TERM_LIST( + `FST (resource:A#B)`, + `SND (resource:A#B)`, + `ra_unit (R:(A)ra)`, + `ra_unit (S:(B)ra)`), + get_theorem_by_name("PAIR_EQ")); + thm resource_eta = ispec_rule( + `resource:A#B`, + get_theorem_by_name("PAIR")); + thm resource_eq_pair = beta_rule(ap_term_rule( + `\candidate:A#B. + candidate == + (ra_unit (R:(A)ra),ra_unit (S:(B)ra))`, + resource_eta)); + ACCEPT_TAC( + body, + trans_rule(gsym_rule(pair_components), resource_eq_pair)); + return gnode_prove(root); +} + +PROOF thm r_lift_left_emp_eq = + prove_r_lift_left_emp_eq(); + +PROOF static thm prove_r_lift_right_emp_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra). + r_lift_right R S (r_emp S) == + r_emp (prod_ra R S) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ispecl_rule( + TERM_LIST( + `r_lift_right (R:(A)ra) (S:(B)ra) (r_emp S)`, + `r_emp (prod_ra (R:(A)ra) (S:(B)ra))`), + get_theorem_by_name("FUN_EQ_THM"))))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + r_lift_right_def, + r_emp_def, + prod_ra_unit))); + thm pair_components = ispecl_rule( + TERM_LIST( + `FST (resource:A#B)`, + `SND (resource:A#B)`, + `ra_unit (R:(A)ra)`, + `ra_unit (S:(B)ra)`), + get_theorem_by_name("PAIR_EQ")); + thm resource_eta = ispec_rule( + `resource:A#B`, + get_theorem_by_name("PAIR")); + thm resource_eq_pair = beta_rule(ap_term_rule( + `\candidate:A#B. + candidate == + (ra_unit (R:(A)ra),ra_unit (S:(B)ra))`, + resource_eta)); + ACCEPT_TAC( + body, + trans_rule(gsym_rule(pair_components), resource_eq_pair)); + return gnode_prove(root); +} + +PROOF thm r_lift_right_emp_eq = + prove_r_lift_right_emp_eq(); + +PROOF static thm prove_r_lift_left_emp(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra). + r_equiv + (prod_ra R S) + (r_lift_left R S (r_emp R)) + (r_emp (prod_ra R S)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_lift_left (R:(A)ra) (S:(B)ra) (r_emp R)`, + `r_emp (prod_ra (R:(A)ra) (S:(B)ra))`), + r_equiv_of_eq_product), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`), + r_lift_left_emp_eq))); + return gnode_prove(root); +} + +PROOF thm r_lift_left_emp = + prove_r_lift_left_emp(); + +PROOF static thm prove_r_lift_right_emp(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra). + r_equiv + (prod_ra R S) + (r_lift_right R S (r_emp S)) + (r_emp (prod_ra R S)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_lift_right (R:(A)ra) (S:(B)ra) (r_emp S)`, + `r_emp (prod_ra (R:(A)ra) (S:(B)ra))`), + r_equiv_of_eq_product), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`), + r_lift_right_emp_eq))); + return gnode_prove(root); +} + +PROOF thm r_lift_right_emp = + prove_r_lift_right_emp(); + +PROOF static thm prove_r_lift_left_entails(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:A->bool) + (Q:A->bool). + r_entails R P Q ==> + r_entails + (prod_ra R S) + (r_lift_left R S P) + (r_lift_left R S Q) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_lift_left_def))); + body = AUTO_INTROS_TAC(body); + thm components = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `resource:A#B`), + prod_ra_valid), + assume_rule(` + ra_valid + (prod_ra (R:(A)ra) (S:(B)ra)) + (resource:A#B) + `)); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + mp_rule( + mp_rule( + spec_rule( + `FST (resource:A#B)`, + assume_rule(` + forall owned:A. + ra_valid (R:(A)ra) owned ==> + (P:A->bool) owned ==> + (Q:A->bool) owned + `)), + conjunct1_rule(components)), + conjunct1_rule(assume_rule(` + (P:A->bool) (FST (resource:A#B)) && + SND resource == ra_unit (S:(B)ra) + `)))); + ACCEPT_TAC( + result[1], + conjunct2_rule(assume_rule(` + (P:A->bool) (FST (resource:A#B)) && + SND resource == ra_unit (S:(B)ra) + `))); + return gnode_prove(root); +} + +PROOF thm r_lift_left_entails = + prove_r_lift_left_entails(); + +PROOF static thm prove_r_lift_right_entails(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:B->bool) + (Q:B->bool). + r_entails S P Q ==> + r_entails + (prod_ra R S) + (r_lift_right R S P) + (r_lift_right R S Q) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_lift_right_def))); + body = AUTO_INTROS_TAC(body); + thm components = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `resource:A#B`), + prod_ra_valid), + assume_rule(` + ra_valid + (prod_ra (R:(A)ra) (S:(B)ra)) + (resource:A#B) + `)); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + conjunct1_rule(assume_rule(` + FST (resource:A#B) == ra_unit (R:(A)ra) && + (P:B->bool) (SND resource) + `))); + ACCEPT_TAC( + result[1], + mp_rule( + mp_rule( + spec_rule( + `SND (resource:A#B)`, + assume_rule(` + forall owned:B. + ra_valid (S:(B)ra) owned ==> + (P:B->bool) owned ==> + (Q:B->bool) owned + `)), + conjunct2_rule(components)), + conjunct2_rule(assume_rule(` + FST (resource:A#B) == ra_unit (R:(A)ra) && + (P:B->bool) (SND resource) + `)))); + return gnode_prove(root); +} + +PROOF thm r_lift_right_entails = + prove_r_lift_right_entails(); + +PROOF static thm prove_r_lift_left_sep_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:A->bool) + (Q:A->bool). + r_lift_left R S (r_sep R P Q) == + r_sep + (prod_ra R S) + (r_lift_left R S P) + (r_lift_left R S Q) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ispecl_rule( + TERM_LIST( + `r_lift_left (R:(A)ra) (S:(B)ra) + (r_sep R (P:A->bool) (Q:A->bool))`, + `r_sep (prod_ra (R:(A)ra) (S:(B)ra)) + (r_lift_left (R:(A)ra) (S:(B)ra) (P:A->bool)) + (r_lift_left (R:(A)ra) (S:(B)ra) (Q:A->bool))`), + get_theorem_by_name("FUN_EQ_THM"))))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(r_lift_left_def, r_sep_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsource"); + forward = ASMP_CONJ_TAC( + forward, "Hsource", "Hcomponent_sep", "Hright_unit"); + forward = ASMP_EXISTS_TAC( + forward, "Hcomponent_sep", "component_left"); + forward = ASMP_EXISTS_TAC( + forward, "Hcomponent_sep", "component_right"); + forward = ASMP_CONJ_TAC( + forward, "Hcomponent_sep", "Hcomponent_split", "Hcomponent_preds"); + forward = ASMP_CONJ_TAC( + forward, "Hcomponent_preds", "HP", "HQ"); + forward = EXISTS_TAC( + forward, + `((component_left:A),(ra_unit (S:(B)ra)))`); + forward = EXISTS_TAC( + forward, + `((component_right:A),(ra_unit (S:(B)ra)))`); + gnode_list forward1 = CONJ_TAC(forward); + thm pair_components = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `FST (resource:A#B)`, + `SND (resource:A#B)`, + `ra_op R (component_left:A) (component_right:A)`, + `ra_unit (S:(B)ra)`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + assume_rule(` + FST (resource:A#B) == + ra_op (R:(A)ra) (component_left:A) (component_right:A) + `), + assume_rule(`SND (resource:A#B) == ra_unit (S:(B)ra)`))); + thm resource_pair = trans_rule( + gsym_rule(ispec_rule( + `resource:A#B`, + get_theorem_by_name("PAIR"))), + pair_components); + thm combined_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `((component_left:A),(ra_unit (S:(B)ra)))`, + `((component_right:A),(ra_unit (S:(B)ra)))`), + prod_ra_op); + combined_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_unit_l), + combined_op); + ACCEPT_TAC( + forward1[0], + trans_rule(resource_pair, gsym_rule(combined_op))); + gnode_list forward2 = CONJ_TAC(forward1[1]); + gnode_list left_lift = CONJ_TAC(forward2[0]); + gnode left_pred = CONV_TAC( + left_lift[0], + rewrite_conv(THM_LIST(get_theorem_by_name("FST")))); + ACCEPT_TAC(left_pred, assume_rule(`(P:A->bool) (component_left:A)`)); + CONV_TAC( + left_lift[1], + rewrite_conv(THM_LIST(get_theorem_by_name("SND")))); + gnode_list right_lift = CONJ_TAC(forward2[1]); + gnode right_pred = CONV_TAC( + right_lift[0], + rewrite_conv(THM_LIST(get_theorem_by_name("FST")))); + ACCEPT_TAC(right_pred, assume_rule(`(Q:A->bool) (component_right:A)`)); + CONV_TAC( + right_lift[1], + rewrite_conv(THM_LIST(get_theorem_by_name("SND")))); + + gnode reverse = DISCH_TAC(directions[1], "Hcombined"); + reverse = ASMP_EXISTS_TAC(reverse, "Hcombined", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hcombined", "right"); + reverse = ASMP_CONJ_TAC( + reverse, "Hcombined", "Hsplit", "Hlifts"); + reverse = ASMP_CONJ_TAC(reverse, "Hlifts", "Hleft", "Hright"); + reverse = ASMP_CONJ_TAC(reverse, "Hleft", "HP", "Hleft_unit"); + reverse = ASMP_CONJ_TAC(reverse, "Hright", "HQ", "Hright_unit"); + gnode_list reverse_parts = CONJ_TAC(reverse); + gnode component_sep = EXISTS_TAC(reverse_parts[0], `FST (left:A#B)`); + component_sep = EXISTS_TAC(component_sep, `FST (right:A#B)`); + gnode_list component_parts = CONJ_TAC(component_sep); + thm fst_split = ap_term_rule( + `FST:(A#B)->A`, + assume_rule(` + (resource:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (left:A#B) (right:A#B) + `)); + fst_split = pure_rewrite_rule( + THM_LIST(prod_ra_op, get_theorem_by_name("FST")), + fst_split); + ACCEPT_TAC(component_parts[0], fst_split); + gnode_list component_preds = CONJ_TAC(component_parts[1]); + ACCEPT_TAC(component_preds[0], assume_rule(`(P:A->bool) (FST (left:A#B))`)); + ACCEPT_TAC(component_preds[1], assume_rule(`(Q:A->bool) (FST (right:A#B))`)); + thm snd_split = ap_term_rule( + `SND:(A#B)->B`, + assume_rule(` + (resource:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (left:A#B) (right:A#B) + `)); + snd_split = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("SND"), + assume_rule(`SND (left:A#B) == ra_unit (S:(B)ra)`), + assume_rule(`SND (right:A#B) == ra_unit (S:(B)ra)`), + ra_unit_l), + snd_split); + ACCEPT_TAC(reverse_parts[1], snd_split); + return gnode_prove(root); +} + +PROOF thm r_lift_left_sep_eq = + prove_r_lift_left_sep_eq(); + +PROOF static thm prove_r_lift_right_sep_eq(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:B->bool) + (Q:B->bool). + r_lift_right R S (r_sep S P Q) == + r_sep + (prod_ra R S) + (r_lift_right R S P) + (r_lift_right R S Q) + `); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ispecl_rule( + TERM_LIST( + `r_lift_right (R:(A)ra) (S:(B)ra) + (r_sep S (P:B->bool) (Q:B->bool))`, + `r_sep (prod_ra (R:(A)ra) (S:(B)ra)) + (r_lift_right (R:(A)ra) (S:(B)ra) (P:B->bool)) + (r_lift_right (R:(A)ra) (S:(B)ra) (Q:B->bool))`), + get_theorem_by_name("FUN_EQ_THM"))))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(r_lift_right_def, r_sep_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsource"); + forward = ASMP_CONJ_TAC( + forward, "Hsource", "Hleft_unit", "Hcomponent_sep"); + forward = ASMP_EXISTS_TAC( + forward, "Hcomponent_sep", "component_left"); + forward = ASMP_EXISTS_TAC( + forward, "Hcomponent_sep", "component_right"); + forward = ASMP_CONJ_TAC( + forward, "Hcomponent_sep", "Hcomponent_split", "Hcomponent_preds"); + forward = ASMP_CONJ_TAC( + forward, "Hcomponent_preds", "HP", "HQ"); + forward = EXISTS_TAC( + forward, + `((ra_unit (R:(A)ra)),(component_left:B))`); + forward = EXISTS_TAC( + forward, + `((ra_unit (R:(A)ra)),(component_right:B))`); + gnode_list forward1 = CONJ_TAC(forward); + thm pair_components = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `FST (resource:A#B)`, + `SND (resource:A#B)`, + `ra_unit (R:(A)ra)`, + `ra_op S (component_left:B) (component_right:B)`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + assume_rule(`FST (resource:A#B) == ra_unit (R:(A)ra)`), + assume_rule(` + SND (resource:A#B) == + ra_op (S:(B)ra) (component_left:B) (component_right:B) + `))); + thm resource_pair = trans_rule( + gsym_rule(ispec_rule( + `resource:A#B`, + get_theorem_by_name("PAIR"))), + pair_components); + thm combined_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `((ra_unit (R:(A)ra)),(component_left:B))`, + `((ra_unit (R:(A)ra)),(component_right:B))`), + prod_ra_op); + combined_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND"), + ra_unit_l), + combined_op); + ACCEPT_TAC( + forward1[0], + trans_rule(resource_pair, gsym_rule(combined_op))); + gnode_list forward2 = CONJ_TAC(forward1[1]); + gnode_list left_lift = CONJ_TAC(forward2[0]); + CONV_TAC( + left_lift[0], + rewrite_conv(THM_LIST(get_theorem_by_name("FST")))); + gnode left_pred = CONV_TAC( + left_lift[1], + rewrite_conv(THM_LIST(get_theorem_by_name("SND")))); + ACCEPT_TAC(left_pred, assume_rule(`(P:B->bool) (component_left:B)`)); + gnode_list right_lift = CONJ_TAC(forward2[1]); + CONV_TAC( + right_lift[0], + rewrite_conv(THM_LIST(get_theorem_by_name("FST")))); + gnode right_pred = CONV_TAC( + right_lift[1], + rewrite_conv(THM_LIST(get_theorem_by_name("SND")))); + ACCEPT_TAC(right_pred, assume_rule(`(Q:B->bool) (component_right:B)`)); + + gnode reverse = DISCH_TAC(directions[1], "Hcombined"); + reverse = ASMP_EXISTS_TAC(reverse, "Hcombined", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hcombined", "right"); + reverse = ASMP_CONJ_TAC( + reverse, "Hcombined", "Hsplit", "Hlifts"); + reverse = ASMP_CONJ_TAC(reverse, "Hlifts", "Hleft", "Hright"); + reverse = ASMP_CONJ_TAC(reverse, "Hleft", "Hleft_unit", "HP"); + reverse = ASMP_CONJ_TAC(reverse, "Hright", "Hright_unit", "HQ"); + gnode_list reverse_parts = CONJ_TAC(reverse); + thm fst_split = ap_term_rule( + `FST:(A#B)->A`, + assume_rule(` + (resource:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (left:A#B) (right:A#B) + `)); + fst_split = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST"), + assume_rule(`FST (left:A#B) == ra_unit (R:(A)ra)`), + assume_rule(`FST (right:A#B) == ra_unit (R:(A)ra)`), + ra_unit_l), + fst_split); + ACCEPT_TAC(reverse_parts[0], fst_split); + gnode component_sep = EXISTS_TAC(reverse_parts[1], `SND (left:A#B)`); + component_sep = EXISTS_TAC(component_sep, `SND (right:A#B)`); + gnode_list component_parts = CONJ_TAC(component_sep); + thm snd_split = ap_term_rule( + `SND:(A#B)->B`, + assume_rule(` + (resource:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (left:A#B) (right:A#B) + `)); + snd_split = pure_rewrite_rule( + THM_LIST(prod_ra_op, get_theorem_by_name("SND")), + snd_split); + ACCEPT_TAC(component_parts[0], snd_split); + gnode_list component_preds = CONJ_TAC(component_parts[1]); + ACCEPT_TAC(component_preds[0], assume_rule(`(P:B->bool) (SND (left:A#B))`)); + ACCEPT_TAC(component_preds[1], assume_rule(`(Q:B->bool) (SND (right:A#B))`)); + return gnode_prove(root); +} + +PROOF thm r_lift_right_sep_eq = + prove_r_lift_right_sep_eq(); + +PROOF static thm prove_r_lift_left_sep(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra) (P:A->bool) (Q:A->bool). + r_equiv + (prod_ra R S) + (r_lift_left R S (r_sep R P Q)) + (r_sep (prod_ra R S) + (r_lift_left R S P) + (r_lift_left R S Q)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_lift_left (R:(A)ra) (S:(B)ra) + (r_sep R (P:A->bool) (Q:A->bool))`, + `r_sep (prod_ra (R:(A)ra) (S:(B)ra)) + (r_lift_left R S (P:A->bool)) + (r_lift_left R S (Q:A->bool))`), + r_equiv_of_eq_product), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `P:A->bool`, `Q:A->bool`), + r_lift_left_sep_eq))); + return gnode_prove(root); +} + +PROOF thm r_lift_left_sep = + prove_r_lift_left_sep(); + +PROOF static thm prove_r_lift_right_sep(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra) (P:B->bool) (Q:B->bool). + r_equiv + (prod_ra R S) + (r_lift_right R S (r_sep S P Q)) + (r_sep (prod_ra R S) + (r_lift_right R S P) + (r_lift_right R S Q)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_lift_right (R:(A)ra) (S:(B)ra) + (r_sep S (P:B->bool) (Q:B->bool))`, + `r_sep (prod_ra (R:(A)ra) (S:(B)ra)) + (r_lift_right R S (P:B->bool)) + (r_lift_right R S (Q:B->bool))`), + r_equiv_of_eq_product), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `P:B->bool`, `Q:B->bool`), + r_lift_right_sep_eq))); + return gnode_prove(root); +} + +PROOF thm r_lift_right_sep = + prove_r_lift_right_sep(); + +PROOF static thm prove_r_bupd_right_intro(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool). + r_entails (prod_ra R S) P (r_bupd_right R S P) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_right_def, + ra_updateP_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `SND (resource:A#B)`); + gnode_list result = CONJ_TAC(body); + gnode post = CONV_TAC( + result[0], + get_conversion_by_name("BETA_CONV")); + thm eta = ispec_rule( + `resource:A#B`, + get_theorem_by_name("PAIR")); + thm pred_eta = ap_term_rule(`P:(A#B)->bool`, eta); + ACCEPT_TAC( + post, + eq_mp_rule( + gsym_rule(pred_eta), + assume_rule(`(P:(A#B)->bool) (resource:A#B)`))); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (SND (resource:A#B)) (frame:B)) + `)); + return gnode_prove(root); +} + +PROOF thm r_bupd_right_intro = + prove_r_bupd_right_intro(); + +PROOF static thm prove_r_bupd_right_mono(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:(A#B)->bool). + r_entails (prod_ra R S) P Q ==> + r_entails + (prod_ra R S) + (r_bupd_right R S P) + (r_bupd_right R S Q) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_right_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hmono"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + + thm selected = mp_rule( + spec_rule( + `frame:B`, + assume_rule(` + forall frame:B. + ra_valid + (S:(B)ra) + (ra_op S (SND (owned:A#B)) frame) ==> + exists selected:B. + (P:(A#B)->bool) (FST owned,selected) && + ra_valid S (ra_op S selected frame) + `)), + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (SND (owned:A#B)) (frame:B)) + `)); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP", + "Hvalid_selected_frame"); + + thm owned_components = eq_mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `owned:A#B`), + prod_ra_valid), + assume_rule(` + ra_valid (prod_ra (R:(A)ra) (S:(B)ra)) (owned:A#B) + `)); + thm selected_valid = conjunct1_rule(mp_rule( + ispecl_rule( + TERM_LIST(`S:(B)ra`, `selected:B`, `frame:B`), + ra_valid_op), + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (selected:B) (frame:B)) + `))); + thm selected_pair_rule = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `((FST (owned:A#B)),(selected:B))`), + prod_ra_valid); + selected_pair_rule = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + selected_pair_rule); + thm selected_pair_valid = eq_mp_rule( + gsym_rule(selected_pair_rule), + conj_rule(conjunct1_rule(owned_components), selected_valid)); + thm q_selected = mp_rule( + mp_rule( + spec_rule( + `((FST (owned:A#B)),(selected:B))`, + assume_rule(` + forall resource:A#B. + ra_valid (prod_ra (R:(A)ra) (S:(B)ra)) resource ==> + (P:(A#B)->bool) resource ==> + (Q:(A#B)->bool) resource + `)), + selected_pair_valid), + assume_rule(` + (P:(A#B)->bool) (FST (owned:A#B),selected:B) + `)); + + body = EXISTS_TAC(body, `selected:B`); + gnode_list result = CONJ_TAC(body); + gnode post = result[0]; + ACCEPT_TAC(post, q_selected); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (selected:B) (frame:B)) + `)); + return gnode_prove(root); +} + +PROOF thm r_bupd_right_mono = + prove_r_bupd_right_mono(); + +PROOF static thm prove_r_bupd_right_idem(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool). + r_entails + (prod_ra R S) + (r_bupd_right R S (r_bupd_right R S P)) + (r_bupd_right R S P) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_bupd_right_def, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Houter_update"); + + term post = ` + \selected:B. (P:(A#B)->bool) (FST (owned:A#B),selected) + `; + term middle_post = ` + \middle:B. ra_updateP (S:(B)ra) middle + (\selected:B. (P:(A#B)->bool) (FST (owned:A#B),selected)) + `; + thm composed = ispecl_rule( + TERM_LIST( + `S:(B)ra`, + `SND (owned:A#B)`, + middle_post, + post), + ra_updateP_trans); + term_list outer_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Houter_update")); + composed = mp_rule(composed, assume_rule(outer_terms[0])); + composed = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + composed); + + term middle_update = ` + ra_updateP + (S:(B)ra) + (middle:B) + (\selected:B. (P:(A#B)->bool) (FST (owned:A#B),selected)) + `; + thm step = assume_rule(middle_update); + step = disch_rule(middle_update, step); + step = gen_rule(`middle:B`, step); + composed = mp_rule(composed, step); + ACCEPT_TAC(body, composed); + return gnode_prove(root); +} + +PROOF thm r_bupd_right_idem = + prove_r_bupd_right_idem(); + +PROOF static thm prove_r_bupd_right_frame(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Frame:(A#B)->bool). + r_entails + (prod_ra R S) + (r_sep (prod_ra R S) (r_bupd_right R S P) Frame) + (r_bupd_right R S (r_sep (prod_ra R S) P Frame)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_sep_def, + r_bupd_right_def, + ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Frame"); + body = GEN_TAC(body, "owned_total"); + body = DISCH_TAC(body, "Hvalid_owned_total"); + body = DISCH_TAC(body, "Hsep"); + body = ASMP_EXISTS_TAC(body, "Hsep", "updated"); + body = ASMP_EXISTS_TAC(body, "Hsep", "explicit_frame"); + body = ASMP_CONJ_TAC( + body, + "Hsep", + "Hsplit", + "Hpreds"); + body = ASMP_CONJ_TAC( + body, + "Hpreds", + "Hupdate", + "Hframe_pred"); + body = GEN_TAC(body, "hidden"); + body = DISCH_TAC(body, "Hvalid_with_hidden"); + + thm snd_split = ap_term_rule( + `SND:(A#B)->B`, + assume_rule(` + (owned_total:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (updated:A#B) + (explicit_frame:A#B) + `)); + snd_split = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("SND")), + snd_split); + thm split_with_hidden = beta_rule(ap_term_rule( + `\base:B. ra_op (S:(B)ra) base (hidden:B)`, + snd_split)); + thm source_validity_eq = ap_term_rule( + `ra_valid (S:(B)ra):B->bool`, + split_with_hidden); + thm valid_grouped_left = eq_mp_rule( + source_validity_eq, + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (SND (owned_total:A#B)) (hidden:B)) + `)); + thm source_assoc = ispecl_rule( + TERM_LIST( + `S:(B)ra`, + `SND (updated:A#B)`, + `SND (explicit_frame:A#B)`, + `hidden:B`), + ra_assoc); + thm source_assoc_validity = ap_term_rule( + `ra_valid (S:(B)ra):B->bool`, + source_assoc); + thm valid_normalized = eq_mp_rule( + source_assoc_validity, + valid_grouped_left); + + thm selected = mp_rule( + spec_rule( + `ra_op + (S:(B)ra) + (SND (explicit_frame:A#B)) + (hidden:B)`, + assume_rule(` + forall frame:B. + ra_valid + (S:(B)ra) + (ra_op S (SND (updated:A#B)) frame) ==> + exists selected:B. + (P:(A#B)->bool) (FST updated,selected) && + ra_valid S (ra_op S selected frame) + `)), + valid_normalized); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP", + "Hvalid_selected"); + + body = EXISTS_TAC( + body, + `ra_op + (S:(B)ra) + (selected:B) + (SND (explicit_frame:A#B))`); + gnode_list result = CONJ_TAC(body); + gnode post = CONV_TAC( + result[0], + pure_rewrite_conv(THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `((FST (updated:A#B)),(selected:B))`); + post = EXISTS_TAC(post, `explicit_frame:A#B`); + gnode_list post1 = CONJ_TAC(post); + + thm fst_split = ap_term_rule( + `FST:(A#B)->A`, + assume_rule(` + (owned_total:A#B) == + ra_op + (prod_ra (R:(A)ra) (S:(B)ra)) + (updated:A#B) + (explicit_frame:A#B) + `)); + fst_split = pure_rewrite_rule( + THM_LIST( + prod_ra_op, + get_theorem_by_name("FST")), + fst_split); + thm pair_rule = ispecl_rule( + TERM_LIST( + `FST (owned_total:A#B)`, + `ra_op S (selected:B) (SND (explicit_frame:A#B))`, + `ra_op R (FST (updated:A#B)) (FST (explicit_frame:A#B))`, + `ra_op S (selected:B) (SND (explicit_frame:A#B))`), + get_theorem_by_name("PAIR_EQ")); + thm lhs_to_components = eq_mp_rule( + gsym_rule(pair_rule), + conj_rule( + fst_split, + refl_rule(` + ra_op + (S:(B)ra) + (selected:B) + (SND (explicit_frame:A#B)) + `))); + thm combined_op = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `((FST (updated:A#B)),(selected:B))`, + `explicit_frame:A#B`), + prod_ra_op); + combined_op = pure_rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + combined_op); + ACCEPT_TAC( + post1[0], + trans_rule(lhs_to_components, gsym_rule(combined_op))); + gnode_list post2 = CONJ_TAC(post1[1]); + ACCEPT_TAC( + post2[0], + assume_rule(` + (P:(A#B)->bool) (FST (updated:A#B),selected:B) + `)); + ACCEPT_TAC( + post2[1], + assume_rule(`(Frame:(A#B)->bool) (explicit_frame:A#B)`)); + + thm result_assoc = ispecl_rule( + TERM_LIST( + `S:(B)ra`, + `selected:B`, + `SND (explicit_frame:A#B)`, + `hidden:B`), + ra_assoc); + thm result_assoc_validity = ap_term_rule( + `ra_valid (S:(B)ra):B->bool`, + gsym_rule(result_assoc)); + ACCEPT_TAC( + result[1], + eq_mp_rule( + result_assoc_validity, + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op + S + (selected:B) + (ra_op + S + (SND (explicit_frame:A#B)) + (hidden:B))) + `))); + return gnode_prove(root); +} + +PROOF thm r_bupd_right_frame = + prove_r_bupd_right_frame(); + +PROOF static thm prove_r_viewshift_right_refl(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool). + r_viewshift_right R S P P + `); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC( + body, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `P:(A#B)->bool`), + r_bupd_right_intro)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_refl = + prove_r_viewshift_right_refl(); + +PROOF static thm prove_r_viewshift_right_entails(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:(A#B)->bool). + r_entails (prod_ra R S) P Q ==> + r_viewshift_right R S P Q + `); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `Q:(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P:(A#B)->bool) + (Q:(A#B)->bool) + `)), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `Q:(A#B)->bool`), + r_bupd_right_intro)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_entails = + prove_r_viewshift_right_entails(); + +PROOF static thm prove_r_viewshift_right_trans(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:(A#B)->bool) + (U:(A#B)->bool). + r_viewshift_right R S P Q ==> + r_viewshift_right R S Q U ==> + r_viewshift_right R S P U + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm lifted_second = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `Q:(A#B)->bool`, + `r_bupd_right R S (U:(A#B)->bool)`), + r_bupd_right_mono), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (Q:(A#B)->bool) + (r_bupd_right R S (U:(A#B)->bool)) + `)); + thm collapsed = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_bupd_right R S (Q:(A#B)->bool)`, + `r_bupd_right R S + (r_bupd_right R S (U:(A#B)->bool))`, + `r_bupd_right R S (U:(A#B)->bool)`), + r_entails_trans), + lifted_second), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `S:(B)ra`, `U:(A#B)->bool`), + r_bupd_right_idem)); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`, + `r_bupd_right R S (U:(A#B)->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P:(A#B)->bool) + (r_bupd_right R S (Q:(A#B)->bool)) + `)), + collapsed)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_trans = + prove_r_viewshift_right_trans(); + +PROOF static thm prove_r_viewshift_right_frame(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:(A#B)->bool) + (Frame:(A#B)->bool). + r_viewshift_right R S P Q ==> + r_viewshift_right + R S + (r_sep (prod_ra R S) P Frame) + (r_sep (prod_ra R S) Q Frame) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm explicit_frame = mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`, + `Frame:(A#B)->bool`), + r_sep_frame_l), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P:(A#B)->bool) + (r_bupd_right R S (Q:(A#B)->bool)) + `)); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `r_sep (prod_ra R S) + (P:(A#B)->bool) + (Frame:(A#B)->bool)`, + `r_sep (prod_ra R S) + (r_bupd_right R S (Q:(A#B)->bool)) + (Frame:(A#B)->bool)`, + `r_bupd_right R S + (r_sep (prod_ra R S) + (Q:(A#B)->bool) + (Frame:(A#B)->bool))`), + r_entails_trans), + explicit_frame), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `Q:(A#B)->bool`, + `Frame:(A#B)->bool`), + r_bupd_right_frame))); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_frame = + prove_r_viewshift_right_frame(); + +PROOF static thm prove_r_viewshift_right_mono(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P2:(A#B)->bool) + (P:(A#B)->bool) + (Q:(A#B)->bool) + (Q2:(A#B)->bool). + r_entails (prod_ra R S) P2 P ==> + r_viewshift_right R S P Q ==> + r_entails (prod_ra R S) Q Q2 ==> + r_viewshift_right R S P2 Q2 + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm lifted_post = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `Q:(A#B)->bool`, `Q2:(A#B)->bool`), + r_bupd_right_mono), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (Q:(A#B)->bool) + (Q2:(A#B)->bool) + `)); + thm changed_post = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`, + `r_bupd_right R S (Q2:(A#B)->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P:(A#B)->bool) + (r_bupd_right R S (Q:(A#B)->bool)) + `)), + lifted_post); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P2:(A#B)->bool`, + `P:(A#B)->bool`, + `r_bupd_right R S (Q2:(A#B)->bool)`), + r_entails_trans), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P2:(A#B)->bool) + (P:(A#B)->bool) + `)), + changed_post)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_mono = + prove_r_viewshift_right_mono(); + +PROOF static thm prove_r_viewshift_right_sep(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P1:(A#B)->bool) + (Q1:(A#B)->bool) + (P2:(A#B)->bool) + (Q2:(A#B)->bool). + r_viewshift_right R S P1 Q1 ==> + r_viewshift_right R S P2 Q2 ==> + r_viewshift_right + R S + (r_sep (prod_ra R S) P1 P2) + (r_sep (prod_ra R S) Q1 Q2) + `); + gnode body = AUTO_INTROS_TAC(root); + thm first_framed = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `P1:(A#B)->bool`, `Q1:(A#B)->bool`, + `P2:(A#B)->bool`), + r_viewshift_right_frame), + assume_rule(` + r_viewshift_right + (R:(A)ra) (S:(B)ra) + (P1:(A#B)->bool) (Q1:(A#B)->bool) + `)); + thm second_framed = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `P2:(A#B)->bool`, `Q2:(A#B)->bool`, + `Q1:(A#B)->bool`), + r_viewshift_right_frame), + assume_rule(` + r_viewshift_right + (R:(A)ra) (S:(B)ra) + (P2:(A#B)->bool) (Q2:(A#B)->bool) + `)); + thm source_commute = conjunct1_rule(rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `Q1:(A#B)->bool`, + `P2:(A#B)->bool`), + r_sep_comm))); + thm target_commute = conjunct1_rule(rewrite_rule( + THM_LIST(r_equiv_def), + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `Q2:(A#B)->bool`, + `Q1:(A#B)->bool`), + r_sep_comm))); + thm second_aligned = mp_rule( + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `r_sep (prod_ra R S) + (Q1:(A#B)->bool) (P2:(A#B)->bool)`, + `r_sep (prod_ra R S) + (P2:(A#B)->bool) (Q1:(A#B)->bool)`, + `r_sep (prod_ra R S) + (Q2:(A#B)->bool) (Q1:(A#B)->bool)`, + `r_sep (prod_ra R S) + (Q1:(A#B)->bool) (Q2:(A#B)->bool)`), + /* Consequence follows by unfolding the right view shift. */ + r_viewshift_right_mono), + source_commute), + second_framed), + target_commute); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `S:(B)ra`, + `r_sep (prod_ra R S) + (P1:(A#B)->bool) (P2:(A#B)->bool)`, + `r_sep (prod_ra R S) + (Q1:(A#B)->bool) (P2:(A#B)->bool)`, + `r_sep (prod_ra R S) + (Q1:(A#B)->bool) (Q2:(A#B)->bool)`), + r_viewshift_right_trans), + first_framed), + second_aligned)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_sep = + prove_r_viewshift_right_sep(); + +PROOF static thm prove_r_viewshift_right_fact(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (guard:bool) + (P:(A#B)->bool) + (Q:(A#B)->bool). + (guard ==> r_viewshift_right R S P Q) ==> + r_viewshift_right + R S + (r_sep + (prod_ra R S) + (r_fact (prod_ra R S) guard) + P) + (r_sep + (prod_ra R S) + (r_fact (prod_ra R S) guard) + Q) + `); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "guard"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hconditional"); + body = MATCH_MP_TAC( + body, + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `guard:bool`, + `P:(A#B)->bool`, + `r_bupd_right + R S + (r_sep + (prod_ra R S) + (r_fact (prod_ra R S) (guard:bool)) + (Q:(A#B)->bool))`), + r_fact_elim)); + body = DISCH_TAC(body, "Hguard"); + + term_list conditional_terms = gnode_get_asmps( + body, + CONST_STRING_LIST("Hconditional")); + thm change = mp_rule( + assume_rule(conditional_terms[0]), + assume_rule(`guard:bool`)); + change = pure_rewrite_rule( + THM_LIST(r_viewshift_right_def), + change); + + thm post_inclusion = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `guard:bool`, + `Q:(A#B)->bool`, + `Q:(A#B)->bool`), + r_fact_intro), + assume_rule(`guard:bool`)), + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `Q:(A#B)->bool`), + r_entails_refl)); + thm lifted_post = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `Q:(A#B)->bool`, + `r_sep + (prod_ra R S) + (r_fact (prod_ra R S) (guard:bool)) + (Q:(A#B)->bool)`), + r_bupd_right_mono), + post_inclusion); + ACCEPT_TAC( + body, + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`, + `r_bupd_right + R S + (r_sep + (prod_ra R S) + (r_fact + (prod_ra R S) + (guard:bool)) + (Q:(A#B)->bool))`), + r_entails_trans), + change), + lifted_post)); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_fact = + prove_r_viewshift_right_fact(); + +PROOF static thm prove_r_viewshift_right_exists_l(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:C->(A#B)->bool) + (Q:(A#B)->bool). + (forall witness:C. + r_viewshift_right R S (P witness) Q) ==> + r_viewshift_right + R S + (r_exists (prod_ra R S) (\bound:C. P bound)) + Q + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:C->(A#B)->bool`, + `r_bupd_right R S (Q:(A#B)->bool)`), + r_exists_elim), + assume_rule(` + forall witness:C. + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + ((P:C->(A#B)->bool) witness) + (r_bupd_right R S (Q:(A#B)->bool)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF static thm r_viewshift_right_exists_l = + prove_r_viewshift_right_exists_l(); + +PROOF static thm prove_r_viewshift_right_exists_r(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:(A#B)->bool) + (Q:C->(A#B)->bool) + (witness:C). + r_viewshift_right R S P (Q witness) ==> + r_viewshift_right + R S P + (r_exists (prod_ra R S) (\bound:C. Q bound)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_viewshift_right_def))); + body = AUTO_INTROS_TAC(body); + thm post_inclusion = ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `Q:C->(A#B)->bool`, + `witness:C`), + r_exists_intro); + thm lifted_post = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `(Q:C->(A#B)->bool) (witness:C)`, + `r_exists + (prod_ra R S) + (\bound:C. (Q:C->(A#B)->bool) bound)`), + r_bupd_right_mono), + post_inclusion); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `P:(A#B)->bool`, + `r_bupd_right + R S + ((Q:C->(A#B)->bool) (witness:C))`, + `r_bupd_right + R S + (r_exists + (prod_ra R S) + (\bound:C. (Q:C->(A#B)->bool) bound))`), + r_entails_trans), + assume_rule(` + r_entails + (prod_ra (R:(A)ra) (S:(B)ra)) + (P:(A#B)->bool) + (r_bupd_right + R S + ((Q:C->(A#B)->bool) (witness:C))) + `)), + lifted_post); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF static thm r_viewshift_right_exists_r = + prove_r_viewshift_right_exists_r(); + +PROOF static thm prove_r_viewshift_right_exists(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (P:C->(A#B)->bool) + (Q:C->(A#B)->bool). + (forall witness:C. + r_viewshift_right R S (P witness) (Q witness)) ==> + r_viewshift_right + R S + (r_exists (prod_ra R S) (\bound:C. P bound)) + (r_exists (prod_ra R S) (\bound:C. Q bound)) + `); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hall"); + body = MATCH_MP_TAC( + body, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `P:C->(A#B)->bool`, + `r_exists + (prod_ra R S) + (\bound:C. (Q:C->(A#B)->bool) bound)`), + r_viewshift_right_exists_l)); + body = GEN_TAC(body, "witness"); + thm selected = spec_rule( + `witness:C`, + assume_rule(` + forall witness:C. + r_viewshift_right + (R:(A)ra) (S:(B)ra) + ((P:C->(A#B)->bool) witness) + ((Q:C->(A#B)->bool) witness) + `)); + thm result = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:(B)ra`, + `(P:C->(A#B)->bool) (witness:C)`, + `Q:C->(A#B)->bool`, + `witness:C`), + r_viewshift_right_exists_r), + selected); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_viewshift_right_exists = + prove_r_viewshift_right_exists(); + +PROOF static thm prove_r_right_own_update(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (a:B) + (b:B). + ra_update S a b ==> + r_viewshift_right + R S + (r_lift_right R S (r_own S a)) + (r_lift_right R S (r_own S b)) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_right_def, + r_entails_def, + r_bupd_right_def, + ra_updateP_def, + ra_update_def, + r_lift_right_def, + r_own_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hsource"); + body = ASMP_CONJ_TAC( + body, + "Hsource", + "Hleft_unit", + "Hright_owned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + thm replace_right = beta_rule(ap_term_rule( + `\right:B. ra_op (S:(B)ra) right (frame:B)`, + assume_rule(`SND (owned:A#B) == (a:B)`))); + thm valid_a_frame = eq_mp_rule( + ap_term_rule(`ra_valid (S:(B)ra):B->bool`, replace_right), + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (SND (owned:A#B)) (frame:B)) + `)); + thm selected = mp_rule( + spec_rule( + `frame:B`, + assume_rule(` + forall hidden:B. + ra_valid (S:(B)ra) (ra_op S (a:B) hidden) ==> + exists selected:B. + selected == (b:B) && + ra_valid S (ra_op S selected hidden) + `)), + valid_a_frame); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "Hselected_b", + "Hvalid_selected"); + body = EXISTS_TAC(body, `selected:B`); + gnode_list result = CONJ_TAC(body); + gnode post = CONV_TAC( + result[0], + pure_rewrite_conv(THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + gnode_list post_parts = CONJ_TAC(post); + term_list left_unit_terms = gnode_get_asmps( + post_parts[0], + CONST_STRING_LIST("Hleft_unit")); + ACCEPT_TAC( + post_parts[0], + assume_rule(left_unit_terms[0])); + + term_list selected_b_terms = gnode_get_asmps( + post_parts[1], + CONST_STRING_LIST("Hselected_b")); + ACCEPT_TAC( + post_parts[1], + assume_rule(selected_b_terms[0])); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (selected:B) (frame:B)) + `)); + return gnode_prove(root); +} + +PROOF thm r_right_own_update = + prove_r_right_own_update(); + +PROOF static thm prove_r_right_own_updateP(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (S:(B)ra) + (a:B) + (P:B->bool). + ra_updateP S a P ==> + r_viewshift_right + R S + (r_lift_right R S (r_own S a)) + (r_exists + (prod_ra R S) + (\b:B. + r_sep + (prod_ra R S) + (r_fact (prod_ra R S) (P b)) + (r_lift_right R S (r_own S b)))) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_viewshift_right_def, + r_entails_def, + r_bupd_right_def, + ra_updateP_def, + r_lift_right_def, + r_own_def, + r_exists_def, + r_sep_def, + r_fact_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "S"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "P"); + body = DISCH_TAC(body, "Hupdate"); + body = GEN_TAC(body, "owned"); + body = DISCH_TAC(body, "Hvalid_owned"); + body = DISCH_TAC(body, "Hsource"); + body = ASMP_CONJ_TAC( + body, + "Hsource", + "Hleft_unit", + "Hright_owned"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hvalid_source"); + thm replace_right = beta_rule(ap_term_rule( + `\right:B. ra_op (S:(B)ra) right (frame:B)`, + assume_rule(`SND (owned:A#B) == (a:B)`))); + thm valid_a_frame = eq_mp_rule( + ap_term_rule(`ra_valid (S:(B)ra):B->bool`, replace_right), + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (SND (owned:A#B)) (frame:B)) + `)); + thm selected = mp_rule( + spec_rule( + `frame:B`, + assume_rule(` + forall hidden:B. + ra_valid (S:(B)ra) (ra_op S (a:B) hidden) ==> + exists selected:B. + (P:B->bool) selected && + ra_valid S (ra_op S selected hidden) + `)), + valid_a_frame); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP", + "Hvalid_selected"); + + body = EXISTS_TAC(body, `selected:B`); + gnode_list result = CONJ_TAC(body); + gnode post = CONV_TAC( + result[0], + pure_rewrite_conv(THM_LIST( + r_sep_def, + r_fact_def, + r_lift_right_def, + r_own_def))); + post = CONV_TAC( + post, + depth_conv(get_conversion_by_name("BETA_CONV"))); + post = EXISTS_TAC(post, `selected:B`); + post = EXISTS_TAC(post, `ra_unit (prod_ra (R:(A)ra) (S:(B)ra))`); + post = EXISTS_TAC(post, `((ra_unit (R:(A)ra)),(selected:B))`); + post = CONV_TAC( + post, + pure_rewrite_conv(THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + gnode_list post1 = CONJ_TAC(post); + thm target_pair = eq_mp_rule( + gsym_rule(ispecl_rule( + TERM_LIST( + `FST (owned:A#B)`, + `selected:B`, + `ra_unit (R:(A)ra)`, + `selected:B`), + get_theorem_by_name("PAIR_EQ"))), + conj_rule( + assume_rule(`FST (owned:A#B) == ra_unit (R:(A)ra)`), + refl_rule(`selected:B`))); + ACCEPT_TAC( + post1[0], + trans_rule( + target_pair, + gsym_rule(ispecl_rule( + TERM_LIST( + `prod_ra (R:(A)ra) (S:(B)ra)`, + `((ra_unit (R:(A)ra)),(selected:B))`), + ra_unit_l)))); + gnode_list post2 = CONJ_TAC(post1[1]); + gnode_list fact_parts = CONJ_TAC(post2[0]); + ACCEPT_TAC( + fact_parts[0], + assume_rule(`(P:B->bool) (selected:B)`)); + ACCEPT_TAC( + fact_parts[1], + refl_rule(`ra_unit (prod_ra (R:(A)ra) (S:(B)ra))`)); + gnode_list lifted_own = CONJ_TAC(post2[1]); + ACCEPT_TAC( + lifted_own[0], + refl_rule(`ra_unit (R:(A)ra)`)); + ACCEPT_TAC(lifted_own[1], refl_rule(`selected:B`)); + ACCEPT_TAC( + result[1], + assume_rule(` + ra_valid + (S:(B)ra) + (ra_op S (selected:B) (frame:B)) + `)); + return gnode_prove(root); +} + +PROOF thm r_right_own_updateP = + prove_r_right_own_updateP(); + +PROOF static int audit_product_resource(void) { + thm_list exported_theorems = THM_LIST( + r_lift_left_def, + r_lift_right_def, + r_lift_left_emp, + r_lift_right_emp, + r_lift_left_sep, + r_lift_right_sep, + r_lift_left_entails, + r_lift_right_entails, + r_bupd_right_def, + r_viewshift_right_def, + r_bupd_right_intro, + r_bupd_right_mono, + r_bupd_right_idem, + r_bupd_right_frame, + r_viewshift_right_refl, + r_viewshift_right_entails, + r_viewshift_right_trans, + r_viewshift_right_mono, + r_viewshift_right_frame, + r_viewshift_right_sep, + r_viewshift_right_fact, + r_viewshift_right_exists, + r_right_own_update, + r_right_own_updateP, + r_lift_left_emp_eq, + r_lift_right_emp_eq, + r_lift_left_sep_eq, + r_lift_right_sep_eq); + for (size_t i = 0; i < vector_size(exported_theorems); ++i) { + ENSURE_COND( + !IS_NULL(exported_theorems[i]), + "product resource theorem %zu is null", + i); + ENSURE_COND( + vector_size(hyp(exported_theorems[i])) == 0, + "product resource theorem %zu has hypotheses", + i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == PRODUCT_RESOURCE_AXIOMS_BEFORE, + "product resource theory introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_product_resource"); + return -1; +} + +PROOF static int _PRODUCT_RESOURCE_AUDIT = + audit_product_resource(); diff --git a/theory/logic/product_resource.h b/theory/logic/product_resource.h new file mode 100644 index 0000000000000000000000000000000000000000..40affbe3ac0a25905da48a3b9d321e9efe85d65d --- /dev/null +++ b/theory/logic/product_resource.h @@ -0,0 +1,315 @@ +/** + * @file product_resource.h + * @brief Exact assertion lifts and right-only updates for product resources. + * + * An exact left lift requires the right projection to be `ra_unit S`; an + * exact right lift symmetrically requires the left projection to be + * `ra_unit R`. Their public separating-monoid laws use `r_equiv`; raw + * function equalities are confined to `product_resource_internal.h`. + * + * The restricted update is defined by + * + * ```text + * r_bupd_right R S Q (left,right) <=> + * ra_updateP S right (\right'. Q (left,right')). + * ``` + * + * Thus the left projection is definitionally unchanged while only the right + * RA participates in the frame-preserving update. Frames may still contain + * resources in both projections and are preserved by the laws below. + */ + +#pragma once + +#include "proof/theory/logic/prod_ra.h" +#include "proof/theory/logic/resource_prop.h" + +/** + * HOL conclusion: + * + * ```text + * r_lift_left (R:(A)ra) (S:(B)ra) (P:A->bool) (resource:A#B) <=> P (FST + * resource) && SND resource == ra_unit S + * ``` + * + * 左提升在左投影上检查 `P`，并要求未使用的右投影精确等于 `S` 的单位元。 + */ +PROOF extern thm r_lift_left_def; +/** + * HOL conclusion: + * + * ```text + * r_lift_right (R:(A)ra) (S:(B)ra) (Q:B->bool) (resource:A#B) <=> FST resource + * == ra_unit R && Q (SND resource) + * ``` + * + * 右提升要求未使用的左投影精确等于 `R` 的单位元，并在右投影上检查 `Q`。 + */ +PROOF extern thm r_lift_right_def; + +/* Exact-lift separating-monoid and entailment laws. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra). r_equiv (prod_ra R S) (r_lift_left R S (r_emp + * R)) (r_emp (prod_ra R S)) + * ``` + * + * 将左 RA 的 `emp` 精确提升后，在乘积 RA 上与乘积 `emp` 资源等价。 + */ +PROOF extern thm r_lift_left_emp; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra). r_equiv (prod_ra R S) (r_lift_right R S (r_emp + * S)) (r_emp (prod_ra R S)) + * ``` + * + * 将右 RA 的 `emp` 精确提升后，在乘积 RA 上与乘积 `emp` 资源等价。 + */ +PROOF extern thm r_lift_right_emp; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:A->bool) (Q:A->bool). r_equiv (prod_ra R S) + * (r_lift_left R S (r_sep R P Q)) (r_sep (prod_ra R S) (r_lift_left R S P) + * (r_lift_left R S Q)) + * ``` + * + * 左侧分离合取的精确提升，等价于分别提升两个左断言后在乘积 RA 中分离合取。 + */ +PROOF extern thm r_lift_left_sep; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:B->bool) (Q:B->bool). r_equiv (prod_ra R S) + * (r_lift_right R S (r_sep S P Q)) (r_sep (prod_ra R S) (r_lift_right R S P) + * (r_lift_right R S Q)) + * ``` + * + * 右侧分离合取的精确提升，等价于分别提升两个右断言后在乘积 RA 中分离合取。 + */ +PROOF extern thm r_lift_right_sep; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:A->bool) (Q:A->bool). r_entails R P Q ==> + * r_entails (prod_ra R S) (r_lift_left R S P) (r_lift_left R S Q) + * ``` + * + * 左 RA 上的 `P ⊢ Q` 经精确左提升后仍是乘积 RA 上的蕴含。 + */ +PROOF extern thm r_lift_left_entails; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:B->bool) (Q:B->bool). r_entails S P Q ==> + * r_entails (prod_ra R S) (r_lift_right R S P) (r_lift_right R S Q) + * ``` + * + * 右 RA 上的 `P ⊢ Q` 经精确右提升后仍是乘积 RA 上的蕴含。 + */ +PROOF extern thm r_lift_right_entails; + +/* Right-only basic update and view shift. */ +/** + * HOL conclusion: + * + * ```text + * r_bupd_right (R:(A)ra) (S:(B)ra) (Q:(A#B)->bool) (resource:A#B) <=> + * ra_updateP S (SND resource) (\right':B. Q (FST resource,right')) + * ``` + * + * 右侧 basic update 仅对 `SND resource` 执行 `S` 的谓词更新，并把原左投影原样交给后置条件。 + */ +PROOF extern thm r_bupd_right_def; +/** + * HOL conclusion: + * + * ```text + * r_viewshift_right (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Q:(A#B)->bool) <=> + * r_entails (prod_ra R S) P (r_bupd_right R S Q) + * ``` + * + * 右侧 view shift 定义为乘积 RA 上蕴含一次只更新右投影的 basic update。 + */ +PROOF extern thm r_viewshift_right_def; + +/* Right-only basic-update modality laws. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool). r_entails (prod_ra R S) P + * (r_bupd_right R S P) + * ``` + * + * 不改变右投影的自反更新把任意 `P` 引入为右侧 basic update。 + */ +PROOF extern thm r_bupd_right_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Q:(A#B)->bool). r_entails + * (prod_ra R S) P Q ==> r_entails (prod_ra R S) (r_bupd_right R S P) + * (r_bupd_right R S Q) + * ``` + * + * 乘积断言 `P ⊢ Q` 可提升为右侧 basic update 后的 `bupd_right P ⊢ bupd_right Q`。 + */ +PROOF extern thm r_bupd_right_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool). r_entails (prod_ra R S) + * (r_bupd_right R S (r_bupd_right R S P)) (r_bupd_right R S P) + * ``` + * + * 两层连续右侧 basic update 可合并为一层，而左投影始终保持不变。 + */ +PROOF extern thm r_bupd_right_idem; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Frame:(A#B)->bool). r_entails + * (prod_ra R S) (r_sep (prod_ra R S) (r_bupd_right R S P) Frame) (r_bupd_right + * R S (r_sep (prod_ra R S) P Frame)) + * ``` + * + * 右投影更新可携带含左右资源的任意分离框架，并把框架保留到更新后的结论中。 + */ +PROOF extern thm r_bupd_right_frame; + +/* Right-only view-shift laws, including exact-fact and existential lifting. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool). r_viewshift_right R S P P + * ``` + * + * 任意乘积断言都可经不改变右投影的更新 view shift 到自身。 + */ +PROOF extern thm r_viewshift_right_refl; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Q:(A#B)->bool). r_entails + * (prod_ra R S) P Q ==> r_viewshift_right R S P Q + * ``` + * + * 乘积 RA 上的普通蕴含可提升为只更新右投影的 view shift。 + */ +PROOF extern thm r_viewshift_right_entails; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Q:(A#B)->bool) (U:(A#B)->bool). + * r_viewshift_right R S P Q ==> r_viewshift_right R S Q U ==> + * r_viewshift_right R S P U + * ``` + * + * 两个首尾相接的右侧 view shift 可合成为一次右侧 view shift。 + */ +PROOF extern thm r_viewshift_right_trans; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P2:(A#B)->bool) (P:(A#B)->bool) (Q:(A#B)->bool) + * (Q2:(A#B)->bool). r_entails (prod_ra R S) P2 P ==> r_viewshift_right R S P Q + * ==> r_entails (prod_ra R S) Q Q2 ==> r_viewshift_right R S P2 Q2 + * ``` + * + * 右侧 view shift 可用 `P2 ⊢ P` 加强前件、用 `Q ⊢ Q2` 放宽后件。 + */ +PROOF extern thm r_viewshift_right_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:(A#B)->bool) (Q:(A#B)->bool) + * (Frame:(A#B)->bool). r_viewshift_right R S P Q ==> r_viewshift_right R S + * (r_sep (prod_ra R S) P Frame) (r_sep (prod_ra R S) Q Frame) + * ``` + * + * 右侧 view shift 可在两端加入同一分离框架，且不更新乘积的左投影。 + */ +PROOF extern thm r_viewshift_right_frame; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P1:(A#B)->bool) (Q1:(A#B)->bool) + * (P2:(A#B)->bool) (Q2:(A#B)->bool). r_viewshift_right R S P1 Q1 ==> + * r_viewshift_right R S P2 Q2 ==> r_viewshift_right R S (r_sep (prod_ra R S) + * P1 P2) (r_sep (prod_ra R S) Q1 Q2) + * ``` + * + * 两个右侧 view shift 可逐分量组合为分离合取整体上的右侧 view shift。 + */ +PROOF extern thm r_viewshift_right_sep; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (guard:bool) (P:(A#B)->bool) (Q:(A#B)->bool). + * (guard ==> r_viewshift_right R S P Q) ==> r_viewshift_right R S (r_sep + * (prod_ra R S) (r_fact (prod_ra R S) guard) P) (r_sep (prod_ra R S) (r_fact + * (prod_ra R S) guard) Q) + * ``` + * + * 若 `guard` 为真时 `P` 可右移到 `Q`，则把同一精确单位元事实 `fact(guard)` 分离放在两端后仍可右移。 + */ +PROOF extern thm r_viewshift_right_fact; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:C->(A#B)->bool) (Q:C->(A#B)->bool). (forall + * witness:C. r_viewshift_right R S (P witness) (Q witness)) ==> + * r_viewshift_right R S (r_exists (prod_ra R S) (\bound:C. P bound)) (r_exists + * (prod_ra R S) (\bound:C. Q bound)) + * ``` + * + * 若每个见证下 `P(w)` 都可只更新右投影到 `Q(w)`，则两侧取存在量词后仍可右移。 + */ +PROOF extern thm r_viewshift_right_exists; + +/* Ownership rules for deterministic and predicate updates of the right RA. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (a:B) (b:B). ra_update S a b ==> + * r_viewshift_right R S (r_lift_right R S (r_own S a)) (r_lift_right R S + * (r_own S b)) + * ``` + * + * 右 RA 的确定性更新 `a ↝ b` 将精确提升的 `own(a)` 右移为 `own(b)`，不触及左投影。 + */ +PROOF extern thm r_right_own_update; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (a:B) (P:B->bool). ra_updateP S a P ==> + * r_viewshift_right R S (r_lift_right R S (r_own S a)) (r_exists (prod_ra R S) + * (\b:B. r_sep (prod_ra R S) (r_fact (prod_ra R S) (P b)) (r_lift_right R S + * (r_own S b)))) + * ``` + * + * 右 RA 的谓词更新选择目标 `b`，并分离返回 exact-unit 的 `P(b)` fact 与精确提升后的 `own(b)`；左投影不变。 + */ +PROOF extern thm r_right_own_updateP; diff --git a/theory/logic/product_resource_internal.h b/theory/logic/product_resource_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..c52faa66d2ee55f6351a963174ff670e312d8b7e --- /dev/null +++ b/theory/logic/product_resource_internal.h @@ -0,0 +1,57 @@ +/** + * @file product_resource_internal.h + * @brief Raw exact-lift equalities for implementations and adapters. + * + * The public product-resource interface exposes the corresponding laws only + * through validity-sensitive `r_equiv`. This header is intentionally not a + * stable client surface and must not be re-exported by umbrella headers. + */ + +#pragma once + +#include "proof/theory/logic/product_resource.h" + +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra). r_lift_left R S (r_emp R) == r_emp + * (prod_ra R S) + * ``` + * + * 左 RA 的 `emp` 经精确提升后与乘积 `emp` 是严格相同的 HOL 断言函数。 + */ +PROOF extern thm r_lift_left_emp_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra). r_lift_right R S (r_emp S) == r_emp (prod_ra R + * S) + * ``` + * + * 右 RA 的 `emp` 经精确提升后与乘积 `emp` 是严格相同的 HOL 断言函数。 + */ +PROOF extern thm r_lift_right_emp_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:A->bool) (Q:A->bool). r_lift_left R S (r_sep R + * P Q) == r_sep (prod_ra R S) (r_lift_left R S P) (r_lift_left R S Q) + * ``` + * + * 精确左提升把分离合取逐分量提升，等式两侧是原始 HOL 相等而非 `r_equiv`。 + */ +PROOF extern thm r_lift_left_sep_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (S:(B)ra) (P:B->bool) (Q:B->bool). r_lift_right R S (r_sep + * S P Q) == r_sep (prod_ra R S) (r_lift_right R S P) (r_lift_right R S Q) + * ``` + * + * 精确右提升把分离合取逐分量提升，等式两侧是原始 HOL 相等而非 `r_equiv`。 + */ +PROOF extern thm r_lift_right_sep_eq; diff --git a/theory/logic/ra.c b/theory/logic/ra.c new file mode 100644 index 0000000000000000000000000000000000000000..ed88b2ccf5a2194ae6bbe48526adb952599eec1d --- /dev/null +++ b/theory/logic/ra.c @@ -0,0 +1,2435 @@ +#include "proof/theory/logic/ra_builder.h" + +#include "proof/syntax/base.h" +#require "proof/syntax/base.c" +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" + +/* ------------------------------------------------------------------------- */ +/* Printing utility functions */ +/* ------------------------------------------------------------------------- */ + +PROOF static inline char *cst_string_of_term(const term tm) { + if (IS_NULL(tm)) return ""; + return cstr_term(tm); +} + +PROOF static inline char *cst_string_of_thm(const thm th) { + if (IS_NULL(th)) return ""; + return cstr_thm(th); +} + +PROOF static inline char *cst_string_of_type(const type ty) { + if (IS_NULL(ty)) return ""; + return cstr_type(ty); +} + +PROOF static inline char *cst_string_of_gnode(const gnode gn) { + if (gn == NULL) return ""; + return cstr_gnode(gn); +} + +PROOF static inline char *cst_string_of_gnode_list(const gnode_list gns) { + return cstr_gnode_list(gns); +} + + +PROOF static size_t RA_AXIOMS_BEFORE = vector_size(get_all_axioms()); + +/* + * Laws stored in the representation subset. + * + * `ra_laws e op valid` is intentionally a predicate on a raw descriptor, not + * a predicate on `(A)ra`: the type definition below admits exactly the + * descriptors satisfying these laws. + */ +PROOF thm ra_laws_def = new_fun_definition(` + ra_laws (e:A) (op:A->A->A) (valid:A->bool) <=> + (forall a b c. + op (op a b) c == op a (op b c)) && + (forall a b. op a b == op b a) && + (forall a. op e a == a) && + valid e && + (forall a b. valid (op a b) ==> valid a) +`); + +/* + * Every nonempty HOL type admits a commutative monoid. ARB is the unit. If + * the carrier has a non-unit element, Hilbert choice selects one as an + * absorbing result for products of two non-unit elements; in a singleton + * carrier the final branch is unreachable. + */ +PROOF static thm ra_witness_op_def = new_fun_definition(` + ra_witness_op (a:A) (b:A) = + if a == (ARB:A) then b + else if b == (ARB:A) then a + else (@z:A. ~(z == (ARB:A))) +`); + +PROOF static thm prove_ra_witness_absorb_nonunit(void) { + term goal_tm = ` + forall a:A. + ~(a == (ARB:A)) ==> + ~((@z:A. ~(z == (ARB:A))) == (ARB:A)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "a"); + body = DISCH_TAC(body, "Ha"); + + thm selected = specl_rule( + TERM_LIST( + `\z:A. ~(z == (ARB:A))`, + `a:A`), + get_theorem_by_name("SELECT_AX")); + selected = beta_rule(selected); + selected = mp_rule( + selected, + assume_rule(`~((a:A) == (ARB:A))`)); + ACCEPT_TAC(body, selected); + return gnode_prove(root); +} + +PROOF static thm ra_witness_absorb_nonunit = + prove_ra_witness_absorb_nonunit(); + +PROOF static thm prove_ra_witness_assoc(void) { + term goal_tm = ` + forall a b c:A. + ra_witness_op (ra_witness_op a b) c == + ra_witness_op a (ra_witness_op b c) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list a_cases = + BOOL_CASES_TAC(body, `(a:A) == (ARB:A)`, "Ha"); + thm absorb_nonunit_from_a = mp_rule( + spec_rule(`a:A`, ra_witness_absorb_nonunit), + assume_rule(`~((a:A) == (ARB:A))`)); + + for (size_t i = 0; i < vector_size(a_cases); ++i) { + gnode_list b_cases = + BOOL_CASES_TAC(a_cases[i], `(b:A) == (ARB:A)`, "Hb"); + for (size_t j = 0; j < vector_size(b_cases); ++j) { + gnode_list c_cases = + BOOL_CASES_TAC(b_cases[j], `(c:A) == (ARB:A)`, "Hc"); + for (size_t k = 0; k < vector_size(c_cases); ++k) { + if (i == 0) { + CONV_WITH_ASMP_TAC( + c_cases[k], + rewrite_conv, + THM_LIST(ra_witness_op_def)); + } else { + CONV_WITH_ASMP_TAC( + c_cases[k], + rewrite_conv, + THM_LIST( + ra_witness_op_def, + absorb_nonunit_from_a)); + } + } + } + } + return gnode_prove(root); +} + +PROOF static thm ra_witness_assoc = prove_ra_witness_assoc(); + +PROOF static thm prove_ra_witness_comm(void) { + term goal_tm = ` + forall a b:A. + ra_witness_op a b == ra_witness_op b a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list a_cases = + BOOL_CASES_TAC(body, `(a:A) == (ARB:A)`, "Ha"); + + for (size_t i = 0; i < vector_size(a_cases); ++i) { + gnode_list b_cases = + BOOL_CASES_TAC(a_cases[i], `(b:A) == (ARB:A)`, "Hb"); + for (size_t j = 0; j < vector_size(b_cases); ++j) { + CONV_WITH_ASMP_TAC( + b_cases[j], + rewrite_conv, + THM_LIST( + ra_witness_op_def, + ra_witness_absorb_nonunit)); + } + } + return gnode_prove(root); +} + +PROOF static thm ra_witness_comm = prove_ra_witness_comm(); + +PROOF static thm prove_ra_witness_unit(void) { + term goal_tm = ` + forall a:A. ra_witness_op (ARB:A) a == a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC(body, rewrite_conv(THM_LIST(ra_witness_op_def))); + return gnode_prove(root); +} + +PROOF static thm ra_witness_unit = prove_ra_witness_unit(); + +PROOF static thm prove_ra_witness_laws(void) { + term goal_tm = ` + ra_laws (ARB:A) (ra_witness_op:A->A->A) (\x:A. T) + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + ra_laws_def, + ra_witness_assoc, + ra_witness_comm, + ra_witness_unit))); + return gnode_prove(root); +} + +PROOF static thm ra_witness_laws = prove_ra_witness_laws(); + +PROOF static thm prove_ra_rep_exists(void) { + term descriptor = ` + ((ARB:A), + ((ra_witness_op:A->A->A),(\x:A. T))) + `; + term body = ` + ra_laws + (FST (d:A#((A->A->A)#(A->bool)))) + (FST (SND d)) + (SND (SND d)) + `; + term existence = mk_exists(`d:A#((A->A->A)#(A->bool))`, body); + + term witness_body = subst( + (term_pair_list)TERM_PAIR_LIST( + ((term_pair){descriptor, `d:A#((A->A->A)#(A->bool))`})), + body); + thm projected = apply_conversion( + rewrite_conv(THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND"))), + witness_body); + thm witness_laws = eq_mp_rule(sym_rule(projected), ra_witness_laws); + return exists_rule(existence, descriptor, witness_laws); +} + +PROOF static thm ra_rep_exists = prove_ra_rep_exists(); + +/* + * This call creates the genuine unary type constructor `(A)ra`. + * + * The representation predicate is exactly: + * ra_laws (FST d) (FST (SND d)) (SND (SND d)). + */ +PROOF thm ra_type_bijection = new_type_bijection_definition( + "ra", "ra_abs", "ra_rep", ra_rep_exists); + +/* Public projections from the abstract descriptor. */ +PROOF static thm ra_unit_def = new_fun_definition(` + ra_unit (R:(A)ra) : A = FST (ra_rep R) +`); + +PROOF static thm ra_op_def = new_fun_definition(` + ra_op (R:(A)ra) : A->A->A = FST (SND (ra_rep R)) +`); + +PROOF static thm ra_valid_def = new_fun_definition(` + ra_valid (R:(A)ra) : A->bool = SND (SND (ra_rep R)) +`); + +/* + * Generic extension and frame-preserving update relations. + * + * Predicate update returns any element selected by `result`; deterministic + * update is only its singleton specialization. + */ +PROOF thm ra_compatible_def = new_fun_definition(` + ra_compatible (R:(A)ra) (a:A) (b:A) <=> + ra_valid R (ra_op R a b) +`); + +PROOF thm ra_included_def = new_fun_definition(` + ra_included (R:(A)ra) (a:A) (b:A) <=> + exists frame:A. b == ra_op R a frame +`); + +PROOF thm ra_updateP_def = new_fun_definition(` + ra_updateP (R:(A)ra) (a:A) (result:A->bool) <=> + forall frame:A. + ra_valid R (ra_op R a frame) ==> + exists b:A. + result b && ra_valid R (ra_op R b frame) +`); + +PROOF thm ra_update_def = new_fun_definition(` + ra_update (R:(A)ra) (a:A) (b:A) <=> + ra_updateP R a (\x:A. x == b) +`); + +/* + * Optional left cancellativity. Validity is required only for the left-hand + * composition, matching the standard RA/PCM cancellation property. This is a + * property of a particular bundled RA, not an intrinsic law of the `ra` type. + */ +PROOF thm ra_cancellative_def = new_fun_definition(` + ra_cancellative (R:(A)ra) <=> + forall (frame:A) (a:A) (b:A). + ra_valid R (ra_op R frame a) ==> + ra_op R frame a == ra_op R frame b ==> + a == b +`); + +/* + * A frame-maximal element is valid and every compatible frame is the unit. + * This strong formulation justifies replacement by any valid target, + * including in non-cancellative resource algebras. It is not a definition + * of self-conflict exclusivity. + */ +PROOF thm ra_maximal_def = new_fun_definition(` + ra_maximal (R:(A)ra) (a:A) <=> + ra_valid R a && + (forall frame:A. + ra_valid R (ra_op R a frame) ==> + frame == ra_unit R) +`); + +/* + * The representation selected for any abstract RA satisfies the subtype + * predicate. This is the central consequence of new_type_definition. + */ +PROOF static thm prove_ra_rep_laws(void) { + term goal_tm = ` + forall R:(A)ra. + ra_laws + (FST (ra_rep R)) + (FST (SND (ra_rep R))) + (SND (SND (ra_rep R))) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC(body, rewrite_conv(THM_LIST(ra_type_bijection))); + return gnode_prove(root); +} + +PROOF thm ra_rep_laws = prove_ra_rep_laws(); + +PROOF static thm prove_ra_laws(void) { + term goal_tm = ` + forall R:(A)ra. + ra_laws (ra_unit R) (ra_op R) (ra_valid R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC(body, rewrite_conv(THM_LIST( + ra_unit_def, ra_op_def, ra_valid_def, ra_rep_laws))); + return gnode_prove(root); +} + +PROOF thm ra_laws = prove_ra_laws(); + +/* + * Stable projections of the intrinsic laws. Downstream RA constructors use + * these facts instead of unfolding the representation predicate. + */ +PROOF static thm expanded_ra_laws(const term R) { + return rewrite_rule( + THM_LIST(ra_laws_def), + spec_rule(R, ra_laws)); +} + +PROOF static thm prove_ra_assoc(void) { + term R = `R:(A)ra`; + return gen_rule(R, conjunct1_rule(expanded_ra_laws(R))); +} + +PROOF thm ra_assoc = prove_ra_assoc(); + +PROOF static thm prove_ra_comm(void) { + term R = `R:(A)ra`; + thm law_tail = conjunct2_rule(expanded_ra_laws(R)); + return gen_rule(R, conjunct1_rule(law_tail)); +} + +PROOF thm ra_comm = prove_ra_comm(); + +/* + * A compact AC-normalization rule for the common case where the leftmost + * factor should remain fixed and the two trailing factors should swap. + */ +PROOF static thm prove_ra_op_swap_right(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term b = `b:A`; + term c = `c:A`; + thm associated_left = ispecl_rule( + TERM_LIST(R, a, b, c), + ra_assoc); + thm commute_inner = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) (a:A) x`, + ispecl_rule( + TERM_LIST(R, b, c), + ra_comm))); + thm associated_right = gsym_rule(ispecl_rule( + TERM_LIST(R, a, c, b), + ra_assoc)); + thm result = trans_rule( + associated_left, + trans_rule(commute_inner, associated_right)); + result = gen_rule(c, result); + result = gen_rule(b, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm ra_op_swap_right = + prove_ra_op_swap_right(); + +PROOF static thm prove_ra_unit_l(void) { + term R = `R:(A)ra`; + thm law_tail = conjunct2_rule(expanded_ra_laws(R)); + law_tail = conjunct2_rule(law_tail); + return gen_rule(R, conjunct1_rule(law_tail)); +} + +PROOF thm ra_unit_l = prove_ra_unit_l(); + +PROOF static thm prove_ra_unit_r(void) { + term R = `R:(A)ra`; + term a = `a:A`; + thm commuted = ispecl_rule( + TERM_LIST(R, a, `ra_unit (R:(A)ra)`), + ra_comm); + thm reduced = ispecl_rule( + TERM_LIST(R, a), + ra_unit_l); + thm result = trans_rule(commuted, reduced); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm ra_unit_r = + prove_ra_unit_r(); + +PROOF static thm prove_ra_valid_unit(void) { + term R = `R:(A)ra`; + thm law_tail = conjunct2_rule(expanded_ra_laws(R)); + law_tail = conjunct2_rule(law_tail); + law_tail = conjunct2_rule(law_tail); + return gen_rule(R, conjunct1_rule(law_tail)); +} + +PROOF thm ra_valid_unit = prove_ra_valid_unit(); + +PROOF static thm prove_ra_valid_op_l(void) { + term R = `R:(A)ra`; + thm law_tail = conjunct2_rule(expanded_ra_laws(R)); + law_tail = conjunct2_rule(law_tail); + law_tail = conjunct2_rule(law_tail); + return gen_rule(R, conjunct2_rule(law_tail)); +} + +PROOF thm ra_valid_op_l = prove_ra_valid_op_l(); + +PROOF static thm prove_ra_valid_op_r(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_valid R (ra_op R a b) ==> + ra_valid R b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm commuted_valid = pure_once_rewrite_rule( + THM_LIST(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`), + ra_comm)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (b:A)) + `)); + thm right_valid = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `a:A`), + ra_valid_op_l), + commuted_valid); + ACCEPT_TAC(body, right_valid); + return gnode_prove(root); +} + +PROOF thm ra_valid_op_r = + prove_ra_valid_op_r(); + +/* + * Package the two one-sided downward-validity projections into one rule. + * This proof is a forward derivation: both conjuncts consume the same + * validity hypothesis and are then discharged together. + */ +PROOF static thm prove_ra_valid_op(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term b = `b:A`; + term valid_pair = ` + ra_valid (R:(A)ra) (ra_op R (a:A) (b:A)) + `; + thm pair_assumption = assume_rule(valid_pair); + thm left_valid = mp_rule( + ispecl_rule( + TERM_LIST(R, a, b), + ra_valid_op_l), + pair_assumption); + thm right_valid = mp_rule( + ispecl_rule( + TERM_LIST(R, a, b), + ra_valid_op_r), + pair_assumption); + thm result = disch_rule( + valid_pair, + conj_rule(left_valid, right_valid)); + result = gen_rule(b, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm ra_valid_op = + prove_ra_valid_op(); + +PROOF static thm prove_ra_compat_comm(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_compatible R a b <=> ra_compatible R b a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_compatible_def, + ra_comm))); + return gnode_prove(root); +} + +PROOF thm ra_compat_comm = prove_ra_compat_comm(); + +PROOF static thm prove_ra_compat_unit(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_compatible R a (ra_unit R) <=> ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_compatible_def, + ra_unit_r))); + return gnode_prove(root); +} + +PROOF thm ra_compat_unit = prove_ra_compat_unit(); + +/* + * Apply the optional cancellativity property without exposing its quantified + * definition to client proofs. The proof specializes each operand and + * discharges both premises explicitly. + */ +PROOF static thm prove_ra_cancellative_apply(void) { + term goal_tm = ` + forall (R:(A)ra) (frame:A) (a:A) (b:A). + ra_cancellative R ==> + ra_valid R (ra_op R frame a) ==> + ra_op R frame a == ra_op R frame b ==> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm cancellative = rewrite_rule( + THM_LIST(ra_cancellative_def), + assume_rule(`ra_cancellative (R:(A)ra)`)); + cancellative = specl_rule( + TERM_LIST(`frame:A`, `a:A`, `b:A`), + cancellative); + cancellative = mp_rule( + cancellative, + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (frame:A) (a:A)) + `)); + cancellative = mp_rule( + cancellative, + assume_rule(` + ra_op (R:(A)ra) (frame:A) (a:A) == + ra_op R frame (b:A) + `)); + ACCEPT_TAC(body, cancellative); + return gnode_prove(root); +} + +PROOF thm ra_cancellative_apply = + prove_ra_cancellative_apply(); + +/* Direct eliminators keep goal-directed proofs from unfolding quantified + * property definitions at every use site. */ +PROOF static thm prove_ra_maximal_apply(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (frame:A). + ra_maximal R a ==> + ra_valid R (ra_op R a frame) ==> + frame == ra_unit R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R:(A)ra) (a:A)`)); + maximal = conjunct2_rule(maximal); + thm result = mp_rule( + spec_rule(`frame:A`, maximal), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_maximal_apply = + prove_ra_maximal_apply(); + +PROOF static thm prove_ra_update_apply(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (frame:A). + ra_update R a b ==> + ra_valid R (ra_op R a frame) ==> + ra_valid R (ra_op R b frame) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm update = rewrite_rule( + THM_LIST(ra_update_def, ra_updateP_def), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + update = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + update); + thm candidates = mp_rule( + spec_rule(`frame:A`, update), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + body = ASSUME_TAC(body, candidates, "Hcandidate"); + body = ASMP_EXISTS_TAC(body, "Hcandidate", "candidate"); + body = ASMP_CONJ_TAC( + body, + "Hcandidate", + "Hcandidate_eq", + "Hcandidate_valid"); + thm selected_valid = rewrite_rule( + THM_LIST(assume_rule(`candidate:A == (b:A)`)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (candidate:A) (frame:A)) + `)); + ACCEPT_TAC(body, selected_valid); + return gnode_prove(root); +} + +PROOF thm ra_update_apply = + prove_ra_update_apply(); + +PROOF static thm prove_ra_updateP_apply(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool) (frame:A). + ra_updateP R a P ==> + ra_valid R (ra_op R a frame) ==> + exists b:A. P b && ra_valid R (ra_op R b frame) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm update = rewrite_rule( + THM_LIST(ra_updateP_def), + assume_rule(`ra_updateP (R:(A)ra) (a:A) (P:A->bool)`)); + thm result = mp_rule( + spec_rule(`frame:A`, update), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_updateP_apply = + prove_ra_updateP_apply(); + +/* + * Inclusion is reflexive: choose the unit as the missing frame. + */ +PROOF static thm prove_ra_included_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_included R a a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `ra_unit (R:(A)ra)`); + ACCEPT_TAC( + body, + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r))); + return gnode_prove(root); +} + +PROOF thm ra_included_refl = + prove_ra_included_refl(); + +/* + * The unit is included in every element: the element itself is the frame. + */ +PROOF static thm prove_ra_included_unit(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_included R (ra_unit R) a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `a:A`); + ACCEPT_TAC( + body, + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_l))); + return gnode_prove(root); +} + +PROOF thm ra_included_unit = + prove_ra_included_unit(); + +PROOF static thm prove_ra_included_op_l(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included R a (ra_op R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `b:A`); + CONV_TAC(body, rewrite_conv(THM_LIST())); + return gnode_prove(root); +} + +PROOF thm ra_included_op_l = + prove_ra_included_op_l(); + +/* + * The right operand is also included in a composition. Choose the left + * operand as its frame and commute the composition. + */ +PROOF static thm prove_ra_included_op_r(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included R b (ra_op R a b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `a:A`); + ACCEPT_TAC( + body, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`), + ra_comm)); + return gnode_prove(root); +} + +PROOF thm ra_included_op_r = + prove_ra_included_op_r(); + +PROOF static thm prove_ra_included_trans(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (c:A). + ra_included R a b ==> + ra_included R b c ==> + ra_included R a c + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_included_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = GEN_TAC(body, "c"); + body = DISCH_TAC(body, "Hab"); + body = DISCH_TAC(body, "Hbc"); + body = ASMP_EXISTS_TAC(body, "Hab", "frame_ab"); + body = ASMP_EXISTS_TAC(body, "Hbc", "frame_bc"); + body = EXISTS_TAC( + body, + `ra_op (R:(A)ra) (frame_ab:A) (frame_bc:A)`); + + gnode c_substituted = CONV_TAC( + body, + subs_conv(THM_LIST( + assume_rule(` + (c:A) == + ra_op (R:(A)ra) (b:A) (frame_bc:A) + `)))); + gnode b_substituted = CONV_TAC( + c_substituted, + subs_conv(THM_LIST( + assume_rule(` + (b:A) == + ra_op (R:(A)ra) (a:A) (frame_ab:A) + `)))); + thm assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `frame_ab:A`, + `frame_bc:A`), + ra_assoc); + CONV_TAC( + b_substituted, + rewrite_conv(THM_LIST(assoc))); + return gnode_prove(root); +} + +PROOF thm ra_included_trans = + prove_ra_included_trans(); + +/* + * If a2 = a1 · extension, then + * + * a2 · b = (a1 · extension) · b + * = (a1 · b) · extension. + * + * Thus the original inclusion witness is also a witness after composition. + */ +PROOF static thm prove_ra_included_op_mono_l(void) { + term goal_tm = ` + forall (R:(A)ra) (a1:A) (a2:A) (b:A). + ra_included R a1 a2 ==> + ra_included R (ra_op R a1 b) (ra_op R a2 b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_included_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a1"); + body = GEN_TAC(body, "a2"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hincluded"); + body = ASMP_EXISTS_TAC(body, "Hincluded", "extension"); + body = EXISTS_TAC(body, `extension:A`); + + thm lifted_witness = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) x (b:A)`, + assume_rule(` + (a2:A) == + ra_op (R:(A)ra) (a1:A) (extension:A) + `))); + thm swapped_extension = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a1:A`, + `extension:A`, + `b:A`), + ra_op_swap_right); + ACCEPT_TAC( + body, + trans_rule(lifted_witness, swapped_extension)); + return gnode_prove(root); +} + +PROOF thm ra_included_op_mono_l = + prove_ra_included_op_mono_l(); + +/* Right monotonicity is left monotonicity transported through commutativity. */ +PROOF static thm prove_ra_included_op_mono_r(void) { + term goal_tm = ` + forall (R:(A)ra) (a1:A) (a2:A) (b:A). + ra_included R a1 a2 ==> + ra_included R (ra_op R b a1) (ra_op R b a2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm monotone_left = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a1:A`, + `a2:A`, + `b:A`), + ra_included_op_mono_l), + assume_rule(`ra_included (R:(A)ra) (a1:A) (a2:A)`)); + thm commute_source = beta_rule(ap_term_rule( + `\x:A. + ra_included + (R:(A)ra) + x + (ra_op R (a2:A) (b:A))`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a1:A`, `b:A`), + ra_comm))); + thm commute_target = beta_rule(ap_term_rule( + `\x:A. + ra_included + (R:(A)ra) + (ra_op R (b:A) (a1:A)) + x`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a2:A`, `b:A`), + ra_comm))); + thm normalized = eq_mp_rule( + trans_rule(commute_source, commute_target), + monotone_left); + ACCEPT_TAC(body, normalized); + return gnode_prove(root); +} + +PROOF thm ra_included_op_mono_r = + prove_ra_included_op_mono_r(); + +/* Monotonicity in both operands is the transitive closure of the two sides. */ +PROOF static thm prove_ra_included_op_mono(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a1:A) + (a2:A) + (b1:A) + (b2:A). + ra_included R a1 a2 ==> + ra_included R b1 b2 ==> + ra_included R (ra_op R a1 b1) (ra_op R a2 b2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm left_step = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a1:A`, + `a2:A`, + `b1:A`), + ra_included_op_mono_l), + assume_rule(`ra_included (R:(A)ra) (a1:A) (a2:A)`)); + thm right_step = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b1:A`, + `b2:A`, + `a2:A`), + ra_included_op_mono_r), + assume_rule(`ra_included (R:(A)ra) (b1:A) (b2:A)`)); + thm result = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a1:A) (b1:A)`, + `ra_op (R:(A)ra) (a2:A) (b1:A)`, + `ra_op (R:(A)ra) (a2:A) (b2:A)`), + ra_included_trans); + result = mp_rule(result, left_step); + result = mp_rule(result, right_step); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_included_op_mono = + prove_ra_included_op_mono(); + +PROOF static thm prove_ra_included_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included R a b ==> + ra_valid R b ==> + ra_valid R a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hab"); + body = ASMP_EXISTS_TAC(body, "Hab", "frame"); + body = DISCH_TAC(body, "Hvalid_b"); + + thm valid_extension = rewrite_rule( + THM_LIST(assume_rule(` + (b:A) == + ra_op (R:(A)ra) (a:A) (frame:A) + `)), + assume_rule(`ra_valid (R:(A)ra) (b:A)`)); + thm valid_left = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `frame:A`), + ra_valid_op_l), + valid_extension); + ACCEPT_TAC(body, valid_left); + return gnode_prove(root); +} + +PROOF thm ra_included_valid = + prove_ra_included_valid(); + +/* + * Compatibility is downward closed in the owned resource. First compose + * the inclusion with the common frame, then apply ordinary downward validity. + */ +PROOF static thm prove_ra_included_valid_frame(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (frame:A). + ra_included R a b ==> + ra_valid R (ra_op R b frame) ==> + ra_valid R (ra_op R a frame) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm framed_inclusion = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`, + `frame:A`), + ra_included_op_mono_l), + assume_rule(`ra_included (R:(A)ra) (a:A) (b:A)`)); + thm result = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (frame:A)`, + `ra_op (R:(A)ra) (b:A) (frame:A)`), + ra_included_valid); + result = mp_rule(result, framed_inclusion); + result = mp_rule( + result, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (b:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_included_valid_frame = + prove_ra_included_valid_frame(); + +/* Unpack the inclusion witness, reassociate it behind the common prefix, + * cancel that prefix, and reuse the same witness for the base inclusion. */ +PROOF static thm prove_ra_included_cancel_l(void) { + term goal_tm = ` + forall (R:(A)ra) (common:A) (a:A) (b:A). + ra_cancellative R ==> + ra_valid R (ra_op R common b) ==> + ra_included + R + (ra_op R common a) + (ra_op R common b) ==> + ra_included R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm framed_inclusion = rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(` + ra_included + (R:(A)ra) + (ra_op R (common:A) (a:A)) + (ra_op R common (b:A)) + `)); + body = ASSUME_TAC( + body, + framed_inclusion, + "Hframed_inclusion"); + body = ASMP_EXISTS_TAC( + body, + "Hframed_inclusion", + "extension"); + + thm framed_eq = rewrite_rule( + THM_LIST(ra_assoc), + assume_rule(` + ra_op (R:(A)ra) (common:A) (b:A) == + ra_op R (ra_op R common (a:A)) (extension:A) + `)); + thm cancelled = mp_rule( + mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `common:A`, + `b:A`, + `ra_op (R:(A)ra) (a:A) (extension:A)`), + ra_cancellative_apply), + assume_rule(`ra_cancellative (R:(A)ra)`)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (common:A) (b:A)) + `)), + framed_eq); + + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = EXISTS_TAC(body, `extension:A`); + ACCEPT_TAC(body, cancelled); + return gnode_prove(root); +} + +PROOF thm ra_included_cancel_l = + prove_ra_included_cancel_l(); + +/* + * Frame-maximal elements are maximal among valid extensions. Unpack the + * inclusion witness, use validity of the extension to show that witness is + * a compatible frame, then reduce it to the unit. + */ +PROOF static thm prove_ra_maximal_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_maximal R a ==> + ra_valid R b ==> + ra_included R a b ==> + a == b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hmaximal"); + body = DISCH_TAC(body, "Hvalid_b"); + body = DISCH_TAC(body, "Hincluded"); + + thm included = rewrite_rule( + THM_LIST(ra_included_def), + assume_rule(`ra_included (R:(A)ra) (a:A) (b:A)`)); + body = ASSUME_TAC(body, included, "Hincluded_witness"); + body = ASMP_EXISTS_TAC( + body, + "Hincluded_witness", + "frame"); + + thm extension_eq = assume_rule(` + (b:A) == + ra_op (R:(A)ra) (a:A) (frame:A) + `); + thm framed_valid = rewrite_rule( + THM_LIST(extension_eq), + assume_rule(`ra_valid (R:(A)ra) (b:A)`)); + thm maximal = rewrite_rule( + THM_LIST(ra_maximal_def), + assume_rule(`ra_maximal (R:(A)ra) (a:A)`)); + maximal = conjunct2_rule(maximal); + thm frame_is_unit = mp_rule( + spec_rule(`frame:A`, maximal), + framed_valid); + thm replace_frame = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) (a:A) x`, + frame_is_unit)); + thm extension_is_a = trans_rule( + extension_eq, + trans_rule( + replace_frame, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r))); + ACCEPT_TAC(body, gsym_rule(extension_is_a)); + return gnode_prove(root); +} + +PROOF thm ra_maximal_included = + prove_ra_maximal_included(); + +/* For a frame-maximal source, compatibility is exactly ordinary source + * validity together with the unit frame. */ +PROOF static thm prove_ra_maximal_valid_op_iff(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (frame:A). + ra_maximal R a ==> + (ra_valid R (ra_op R a frame) <=> + ra_valid R a && frame == ra_unit R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hcompatible"); + gnode_list components = CONJ_TAC(forward); + thm compatible = assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `); + ACCEPT_TAC( + components[0], + mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `frame:A`), + ra_valid_op_l), + compatible)); + thm frame_is_unit = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `frame:A`), + ra_maximal_apply); + frame_is_unit = mp_rule( + frame_is_unit, + assume_rule(`ra_maximal (R:(A)ra) (a:A)`)); + frame_is_unit = mp_rule(frame_is_unit, compatible); + ACCEPT_TAC(components[1], frame_is_unit); + + gnode reverse = DISCH_TAC(directions[1], "Hcomponents"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hcomponents", + "Hvalid_source", + "Hframe_unit"); + thm framed_eq = trans_rule( + beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) (a:A) x`, + assume_rule(`(frame:A) == ra_unit (R:(A)ra)`))), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r)); + thm valid_eq = ap_term_rule(`ra_valid (R:(A)ra)`, framed_eq); + ACCEPT_TAC( + reverse, + eq_mp_rule( + gsym_rule(valid_eq), + assume_rule(`ra_valid (R:(A)ra) (a:A)`))); + return gnode_prove(root); +} + +PROOF thm ra_maximal_valid_op_iff = + prove_ra_maximal_valid_op_iff(); + +/* Deterministic update is definitionally the singleton specialization. */ +PROOF static thm prove_ra_updateP_singleton(void) { + term R = `R:(A)ra`; + term a = `a:A`; + term b = `b:A`; + thm result = sym_rule(ra_update_def); + result = gen_rule(b, result); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm ra_updateP_singleton = prove_ra_updateP_singleton(); + +/* Internal first-order view of the singleton update. */ +PROOF static thm prove_ra_update_direct(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_update R a b <=> + forall frame:A. + ra_valid R (ra_op R a frame) ==> + ra_valid R (ra_op R b frame) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode unfolded = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + ra_update_def, + ra_updateP_def))); + gnode body = CONV_TAC( + unfolded, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + gnode_list directions = EQ_TAC(body); + + gnode forward = AUTO_INTROS_TAC(directions[0]); + thm candidates = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid (R:(A)ra) (ra_op R (a:A) frame) ==> + exists candidate:A. + candidate == (b:A) && + ra_valid R (ra_op R candidate frame) + `)), + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + forward = ASSUME_TAC(forward, candidates, "Hcandidate"); + forward = ASMP_EXISTS_TAC(forward, "Hcandidate", "candidate"); + forward = ASMP_CONJ_TAC( + forward, + "Hcandidate", + "Hcandidate_eq", + "Hcandidate_valid"); + ACCEPT_TAC( + forward, + rewrite_rule( + THM_LIST(assume_rule(`candidate:A == (b:A)`)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (candidate:A) (frame:A)) + `))); + + gnode reverse = AUTO_INTROS_TAC(directions[1]); + reverse = EXISTS_TAC(reverse, `b:A`); + gnode_list result_parts = CONJ_TAC(reverse); + CONV_TAC(result_parts[0], rewrite_conv(THM_LIST())); + ACCEPT_TAC( + result_parts[1], + mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid (R:(A)ra) (ra_op R (a:A) frame) ==> + ra_valid R (ra_op R (b:A) frame) + `)), + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `))); + return gnode_prove(root); +} + +PROOF static thm ra_update_direct = prove_ra_update_direct(); + +/* + * Nondeterministic update is reflexive. Select the source itself and retain + * the assumed frame-validity fact. + */ +PROOF static thm prove_ra_updateP_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + ra_updateP R a (\x:A. x == a) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `a:A`); + gnode_list result_parts = CONJ_TAC(body); + CONV_TAC(result_parts[0], rewrite_conv(THM_LIST())); + ACCEPT_TAC( + result_parts[1], + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm ra_updateP_refl = + prove_ra_updateP_refl(); + +/* + * Predicate-valued updates compose by selecting the intermediate result and + * then applying the second update to that result. + */ +PROOF static thm prove_ra_updateP_trans(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool) (Q:A->bool). + ra_updateP R a P ==> + (forall b:A. P b ==> ra_updateP R b Q) ==> + ra_updateP R a Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + body = AUTO_INTROS_TAC(body); + + thm intermediate = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `P:A->bool`, `frame:A`), + ra_updateP_apply); + intermediate = mp_rule( + intermediate, + assume_rule(`ra_updateP (R:(A)ra) (a:A) (P:A->bool)`)); + intermediate = mp_rule( + intermediate, + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + body = ASSUME_TAC(body, intermediate, "Hintermediate"); + body = ASMP_EXISTS_TAC(body, "Hintermediate", "middle"); + body = ASMP_CONJ_TAC( + body, "Hintermediate", "HP_middle", "Hmiddle_valid"); + + thm middle_update = mp_rule( + spec_rule( + `middle:A`, + assume_rule(` + forall b:A. + (P:A->bool) b ==> + ra_updateP (R:(A)ra) b (Q:A->bool) + `)), + assume_rule(`(P:A->bool) (middle:A)`)); + thm result = ispecl_rule( + TERM_LIST(`R:(A)ra`, `middle:A`, `Q:A->bool`, `frame:A`), + ra_updateP_apply); + result = mp_rule(result, middle_update); + result = mp_rule( + result, + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (middle:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_updateP_trans = prove_ra_updateP_trans(); + +/* + * Enlarging the allowed result set preserves a predicate update. + */ +PROOF static thm prove_ra_updateP_mono(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool) (Q:A->bool). + ra_updateP R a P ==> + (forall b:A. P b ==> Q b) ==> + ra_updateP R a Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_updateP_def))); + body = AUTO_INTROS_TAC(body); + + thm selected = mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall frame:A. + ra_valid (R:(A)ra) (ra_op R (a:A) frame) ==> + exists b:A. + (P:A->bool) b && + ra_valid R (ra_op R b frame) + `)), + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, "Hselected", "HP_selected", "Hselected_valid"); + body = EXISTS_TAC(body, `selected:A`); + gnode_list result_parts = CONJ_TAC(body); + + thm selected_in_Q = mp_rule( + spec_rule( + `selected:A`, + assume_rule(` + forall b:A. (P:A->bool) b ==> (Q:A->bool) b + `)), + assume_rule(`(P:A->bool) (selected:A)`)); + ACCEPT_TAC(result_parts[0], selected_in_Q); + ACCEPT_TAC( + result_parts[1], + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (selected:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm ra_updateP_mono = + prove_ra_updateP_mono(); + +/* + * A deterministic result can be embedded into any predicate postcondition + * that contains it. The singleton bridge supplies the exact result, and + * monotonicity widens that singleton to P. + */ +PROOF static thm prove_ra_updateP_of_update(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (P:A->bool). + ra_update R a b ==> + P b ==> + ra_updateP R a P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm singleton = eq_mp_rule( + sym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`), + ra_updateP_singleton)), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + term singleton_pred = `\x:A. x == (b:A)`; + thm weakened = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + singleton_pred, + `P:A->bool`), + ra_updateP_mono); + weakened = mp_rule(weakened, singleton); + weakened = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + weakened); + body = MATCH_MP_TAC(body, weakened); + body = GEN_TAC(body, "candidate"); + body = DISCH_TAC(body, "Hcandidate"); + + thm predicate_equality = ap_term_rule( + `P:A->bool`, + assume_rule(`(candidate:A) == (b:A)`)); + thm selected = eq_mp_rule( + gsym_rule(predicate_equality), + assume_rule(`(P:A->bool) (b:A)`)); + ACCEPT_TAC(body, selected); + return gnode_prove(root); +} + +PROOF thm ra_updateP_of_update = + prove_ra_updateP_of_update(); + +/* + * Applying a predicate update to a valid source yields a valid selected + * result. Instantiate the update with the unit frame and eliminate that + * frame using the right-unit law. + */ +PROOF static thm prove_ra_updateP_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool). + ra_updateP R a P ==> + ra_valid R a ==> + exists b:A. P b && ra_valid R b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm source_unit_eq = gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r)); + thm source_valid_eq = ap_term_rule( + `ra_valid (R:(A)ra)`, + source_unit_eq); + thm source_with_unit = eq_mp_rule( + source_valid_eq, + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + thm selected = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `P:A->bool`, + `ra_unit (R:(A)ra)`), + ra_updateP_apply); + selected = mp_rule( + selected, + assume_rule(`ra_updateP (R:(A)ra) (a:A) (P:A->bool)`)); + selected = mp_rule(selected, source_with_unit); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "selected"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP_selected", + "Hselected_valid"); + body = EXISTS_TAC(body, `selected:A`); + gnode_list result_parts = CONJ_TAC(body); + ACCEPT_TAC( + result_parts[0], + assume_rule(`(P:A->bool) (selected:A)`)); + + thm selected_unit_eq = ispecl_rule( + TERM_LIST(`R:(A)ra`, `selected:A`), + ra_unit_r); + thm selected_valid_eq = ap_term_rule( + `ra_valid (R:(A)ra)`, + selected_unit_eq); + thm selected_valid = eq_mp_rule( + selected_valid_eq, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (selected:A) (ra_unit R)) + `)); + ACCEPT_TAC(result_parts[1], selected_valid); + return gnode_prove(root); +} + +PROOF thm ra_updateP_valid = + prove_ra_updateP_valid(); + +/* + * General maximal update: a source-compatible frame is the unit, so a + * valid target remains valid with that same frame. + */ +PROOF static thm prove_ra_maximal_update(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_maximal R a ==> + ra_valid R b ==> + ra_update R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_update_direct))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "b"); + body = DISCH_TAC(body, "Hmaximal"); + body = DISCH_TAC(body, "Hvalid_b"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hsource_valid"); + + thm frame_is_unit = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `frame:A`), + ra_maximal_apply); + frame_is_unit = mp_rule( + frame_is_unit, + assume_rule(`ra_maximal (R:(A)ra) (a:A)`)); + frame_is_unit = mp_rule( + frame_is_unit, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + thm target_unit_eq = ap_term_rule( + `ra_valid (R:(A)ra)`, + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`), + ra_unit_r))); + thm target_with_unit = eq_mp_rule( + target_unit_eq, + assume_rule(`ra_valid (R:(A)ra) (b:A)`)); + thm target_frame_eq = beta_rule(ap_term_rule( + `\x:A. + ra_valid + (R:(A)ra) + (ra_op R (b:A) x)`, + frame_is_unit)); + thm target_with_frame = eq_mp_rule( + gsym_rule(target_frame_eq), + target_with_unit); + ACCEPT_TAC(body, target_with_frame); + return gnode_prove(root); +} + +PROOF thm ra_maximal_update = + prove_ra_maximal_update(); + +PROOF static thm prove_ra_update_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). ra_update R a a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_update_direct))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC( + body, + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + return gnode_prove(root); +} + +PROOF thm ra_update_refl = prove_ra_update_refl(); + +/* + * A larger resource may always update to one of its included parts: every + * frame compatible with the larger source is compatible with the smaller + * target by ra_included_valid_frame. + */ +PROOF static thm prove_ra_update_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_included R b a ==> + ra_update R a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_update_direct))); + body = AUTO_INTROS_TAC(body); + thm result = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `a:A`, + `frame:A`), + ra_included_valid_frame); + result = mp_rule( + result, + assume_rule(`ra_included (R:(A)ra) (b:A) (a:A)`)); + result = mp_rule( + result, + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (a:A) (frame:A)) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_update_included = + prove_ra_update_included(); + +/* The unit update is the unit-inclusion instance of ra_update_included. */ +PROOF static thm prove_ra_update_unit(void) { + term R = `R:(A)ra`; + term a = `a:A`; + thm result = ispecl_rule( + TERM_LIST(R, a, `ra_unit (R:(A)ra)`), + ra_update_included); + result = mp_rule( + result, + ispecl_rule( + TERM_LIST(R, a), + ra_included_unit)); + result = gen_rule(a, result); + return gen_rule(R, result); +} + +PROOF thm ra_update_unit = + prove_ra_update_unit(); + +PROOF static thm prove_ra_update_trans(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (c:A). + ra_update R a b ==> + ra_update R b c ==> + ra_update R a c + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_update_direct))); + body = AUTO_INTROS_TAC(body); + + thm b_valid = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`, `frame:A`), + ra_update_apply); + b_valid = mp_rule( + b_valid, + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + b_valid = mp_rule( + b_valid, + assume_rule(` + ra_valid (R:(A)ra) (ra_op R (a:A) (frame:A)) + `)); + thm c_valid = ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`, `c:A`, `frame:A`), + ra_update_apply); + c_valid = mp_rule( + c_valid, + assume_rule(`ra_update (R:(A)ra) (b:A) (c:A)`)); + c_valid = mp_rule(c_valid, b_valid); + ACCEPT_TAC(body, c_valid); + return gnode_prove(root); +} + +PROOF thm ra_update_trans = prove_ra_update_trans(); + +/* Weaken the selected target by composing the original update with the + * generic discard-to-an-included-part update. */ +PROOF static thm prove_ra_update_target_included(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (c:A). + ra_update R a b ==> + ra_included R c b ==> + ra_update R a c + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm discard = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`, `c:A`), + ra_update_included), + assume_rule(`ra_included (R:(A)ra) (c:A) (b:A)`)); + thm result = ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`, `c:A`), + ra_update_trans); + result = mp_rule( + result, + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + result = mp_rule(result, discard); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_update_target_included = + prove_ra_update_target_included(); + +/* + * A deterministic update maps a valid source to a valid result. As for the + * predicate-update rule above, the unit witnesses ordinary validity. + */ +PROOF static thm prove_ra_update_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + ra_update R a b ==> + ra_valid R a ==> + ra_valid R b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm source_unit_eq = gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_r)); + thm source_valid_eq = ap_term_rule( + `ra_valid (R:(A)ra)`, + source_unit_eq); + thm source_with_unit = eq_mp_rule( + source_valid_eq, + assume_rule(`ra_valid (R:(A)ra) (a:A)`)); + thm result_with_unit = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `b:A`, + `ra_unit (R:(A)ra)`), + ra_update_apply); + result_with_unit = mp_rule( + result_with_unit, + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + result_with_unit = mp_rule(result_with_unit, source_with_unit); + thm result_unit_eq = ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`), + ra_unit_r); + thm result_valid_eq = ap_term_rule( + `ra_valid (R:(A)ra)`, + result_unit_eq); + thm result_valid = eq_mp_rule( + result_valid_eq, + result_with_unit); + ACCEPT_TAC(body, result_valid); + return gnode_prove(root); +} + +PROOF thm ra_update_valid = + prove_ra_update_valid(); + +/* + * A deterministic update remains valid after appending the same resource to + * both sides. The only algebraic fact used here is associativity. + */ +PROOF static thm prove_ra_update_frame(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (extra:A). + ra_update R a b ==> + ra_update R (ra_op R a extra) (ra_op R b extra) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_update_direct))); + body = AUTO_INTROS_TAC(body); + + thm source_assoc = specl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `extra:A`, + `frame:A`), + ra_assoc); + thm normalized_source = rewrite_rule( + THM_LIST(source_assoc), + assume_rule(` + ra_valid (R:(A)ra) + (ra_op R (ra_op R (a:A) (extra:A)) (frame:A)) + `)); + + thm normalized_result = mp_rule( + spec_rule( + `ra_op (R:(A)ra) (extra:A) (frame:A)`, + assume_rule(` + forall frame:A. + ra_valid (R:(A)ra) (ra_op R (a:A) frame) ==> + ra_valid R (ra_op R (b:A) frame) + `)), + normalized_source); + + thm result_assoc = specl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `extra:A`, + `frame:A`), + ra_assoc); + thm framed_result = rewrite_rule( + THM_LIST(gsym_rule(result_assoc)), + normalized_result); + ACCEPT_TAC(body, framed_result); + return gnode_prove(root); +} + +PROOF thm ra_update_frame = prove_ra_update_frame(); + +/* + * Update the two operands independently. Frame the first update by c, frame + * the second by b, commute the latter source and target, and compose the two + * deterministic steps. + */ +PROOF static thm prove_ra_update_op(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A) (c:A) (d:A). + ra_update R a b ==> + ra_update R c d ==> + ra_update R (ra_op R a c) (ra_op R b d) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm first_step = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`, `c:A`), + ra_update_frame), + assume_rule(`ra_update (R:(A)ra) (a:A) (b:A)`)); + + thm second_step = mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `c:A`, `d:A`, `b:A`), + ra_update_frame), + assume_rule(`ra_update (R:(A)ra) (c:A) (d:A)`)); + second_step = rewrite_rule( + THM_LIST( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `c:A`, `b:A`), + ra_comm), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `d:A`, `b:A`), + ra_comm)), + second_step); + + thm result = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_op (R:(A)ra) (a:A) (c:A)`, + `ra_op (R:(A)ra) (b:A) (c:A)`, + `ra_op (R:(A)ra) (b:A) (d:A)`), + ra_update_trans); + result = mp_rule(result, first_step); + result = mp_rule(result, second_step); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm ra_update_op = + prove_ra_update_op(); + +PROOF static thm prove_ra_updateP_frame(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (P:A->bool) (extra:A). + ra_updateP R a P ==> + ra_updateP + R + (ra_op R a extra) + (\x:A. + exists b:A. + P b && x == ra_op R b extra) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + + thm source_assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `extra:A`, + `frame:A`), + ra_assoc); + thm normalized_source = rewrite_rule( + THM_LIST(source_assoc), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R + (ra_op R (a:A) (extra:A)) + (frame:A)) + `)); + thm selected = mp_rule( + spec_rule( + `ra_op (R:(A)ra) (extra:A) (frame:A)`, + assume_rule(` + forall frame:A. + ra_valid (R:(A)ra) + (ra_op R (a:A) frame) ==> + exists b:A. + (P:A->bool) b && + ra_valid R (ra_op R b frame) + `)), + normalized_source); + body = ASSUME_TAC(body, selected, "Hselected"); + body = ASMP_EXISTS_TAC(body, "Hselected", "b"); + body = ASMP_CONJ_TAC( + body, + "Hselected", + "HP_b", + "Hb_valid"); + body = EXISTS_TAC( + body, + `ra_op (R:(A)ra) (b:A) (extra:A)`); + gnode_list result_parts = CONJ_TAC(body); + + term predicate_existence = ` + exists candidate:A. + (P:A->bool) candidate && + ra_op (R:(A)ra) (b:A) (extra:A) == + ra_op R candidate extra + `; + thm predicate_body = conj_rule( + assume_rule(`(P:A->bool) (b:A)`), + refl_rule(`ra_op (R:(A)ra) (b:A) (extra:A)`)); + thm predicate_witness = exists_rule( + predicate_existence, + `b:A`, + predicate_body); + ACCEPT_TAC(result_parts[0], predicate_witness); + + thm result_assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `extra:A`, + `frame:A`), + ra_assoc); + thm framed_valid = rewrite_rule( + THM_LIST(gsym_rule(result_assoc)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R + (b:A) + (ra_op R (extra:A) (frame:A))) + `)); + ACCEPT_TAC(result_parts[1], framed_valid); + return gnode_prove(root); +} + +PROOF thm ra_updateP_frame = + prove_ra_updateP_frame(); + +/* + * Combine two independent predicate updates. The first sees c · frame as + * its hidden frame and selects b. The second then sees b · frame and selects + * d. Associativity and commutativity transport the intermediate validity + * facts to exactly those two frame shapes. + */ +PROOF static thm prove_ra_updateP_op(void) { + term goal_tm = ` + forall + (R:(A)ra) + (a:A) + (c:A) + (P:A->bool) + (Q:A->bool). + ra_updateP R a P ==> + ra_updateP R c Q ==> + ra_updateP + R + (ra_op R a c) + (\x:A. + exists b d:A. + P b && + Q d && + x == ra_op R b d) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(ra_updateP_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "c"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Ha_update"); + body = DISCH_TAC(body, "Hc_update"); + body = GEN_TAC(body, "frame"); + body = DISCH_TAC(body, "Hsource_valid"); + + thm source_assoc = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `a:A`, + `c:A`, + `frame:A`), + ra_assoc); + thm source_for_a = rewrite_rule( + THM_LIST(source_assoc), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R + (ra_op R (a:A) (c:A)) + (frame:A)) + `)); + thm selected_b = mp_rule( + spec_rule( + `ra_op (R:(A)ra) (c:A) (frame:A)`, + assume_rule(` + forall hidden:A. + ra_valid + (R:(A)ra) + (ra_op R (a:A) hidden) ==> + exists b:A. + (P:A->bool) b && + ra_valid R (ra_op R b hidden) + `)), + source_for_a); + body = ASSUME_TAC(body, selected_b, "Hselected_b"); + body = ASMP_EXISTS_TAC(body, "Hselected_b", "b"); + body = ASMP_CONJ_TAC( + body, + "Hselected_b", + "HP_b", + "Hb_valid"); + + thm regroup_bc = gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `b:A`, + `c:A`, + `frame:A`), + ra_assoc)); + thm commute_bc = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) x (frame:A)`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `b:A`, `c:A`), + ra_comm))); + thm expose_c = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `c:A`, + `b:A`, + `frame:A`), + ra_assoc); + thm c_source_eq = trans_rule( + regroup_bc, + trans_rule(commute_bc, expose_c)); + thm c_source_valid = eq_mp_rule( + ap_term_rule(`ra_valid (R:(A)ra)`, c_source_eq), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R + (b:A) + (ra_op R (c:A) (frame:A))) + `)); + + thm selected_d = mp_rule( + spec_rule( + `ra_op (R:(A)ra) (b:A) (frame:A)`, + assume_rule(` + forall hidden:A. + ra_valid + (R:(A)ra) + (ra_op R (c:A) hidden) ==> + exists d:A. + (Q:A->bool) d && + ra_valid R (ra_op R d hidden) + `)), + c_source_valid); + body = ASSUME_TAC(body, selected_d, "Hselected_d"); + body = ASMP_EXISTS_TAC(body, "Hselected_d", "d"); + body = ASMP_CONJ_TAC( + body, + "Hselected_d", + "HQ_d", + "Hd_valid"); + + body = EXISTS_TAC( + body, + `ra_op (R:(A)ra) (b:A) (d:A)`); + gnode_list result_parts = CONJ_TAC(body); + + gnode predicate = EXISTS_TAC(result_parts[0], `b:A`); + predicate = EXISTS_TAC(predicate, `d:A`); + gnode_list predicate_parts = CONJ_TAC(predicate); + ACCEPT_TAC( + predicate_parts[0], + assume_rule(`(P:A->bool) (b:A)`)); + gnode_list predicate_tail = CONJ_TAC(predicate_parts[1]); + ACCEPT_TAC( + predicate_tail[0], + assume_rule(`(Q:A->bool) (d:A)`)); + CONV_TAC(predicate_tail[1], rewrite_conv(THM_LIST())); + + thm regroup_db = gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `d:A`, + `b:A`, + `frame:A`), + ra_assoc)); + thm commute_db = beta_rule(ap_term_rule( + `\x:A. ra_op (R:(A)ra) x (frame:A)`, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `d:A`, `b:A`), + ra_comm))); + thm result_eq = trans_rule(regroup_db, commute_db); + thm result_valid = eq_mp_rule( + ap_term_rule(`ra_valid (R:(A)ra)`, result_eq), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R + (d:A) + (ra_op R (b:A) (frame:A))) + `)); + ACCEPT_TAC(result_parts[1], result_valid); + return gnode_prove(root); +} + +PROOF thm ra_updateP_op = + prove_ra_updateP_op(); + +/* + * Abstraction computes to the supplied descriptor only when that descriptor + * satisfies the laws. For an ill-formed raw descriptor `ra_abs` still + * returns an inhabitant of `(A)ra`, but the subtype bijection deliberately + * gives no representation equation for it. + */ +PROOF static thm prove_ra_abs_rep(void) { + term e = `e:A`; + term op = `op:A->A->A`; + term valid = `valid:A->bool`; + term descriptor = `(e:A,(op:A->A->A,valid:A->bool))`; + term laws = `ra_laws (e:A) (op:A->A->A) (valid:A->bool)`; + + thm inverse = spec_rule( + descriptor, + conjunct2_rule(ra_type_bijection)); + inverse = rewrite_rule( + THM_LIST( + get_theorem_by_name("FST"), + get_theorem_by_name("SND")), + inverse); + + thm abstracted = eq_mp_rule(inverse, assume_rule(laws)); + abstracted = disch_rule(laws, abstracted); + abstracted = gen_rule(valid, abstracted); + abstracted = gen_rule(op, abstracted); + return gen_rule(e, abstracted); +} + +PROOF thm ra_abs_rep = prove_ra_abs_rep(); + +PROOF static thm prove_ra_unit_abs(void) { + term goal_tm = ` + forall (e:A) (op:A->A->A) (valid:A->bool). + ra_laws e op valid ==> + ra_unit (ra_abs (e,(op,valid))) == e + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm abstracted = mp_rule( + specl_rule( + TERM_LIST(`e:A`, `op:A->A->A`, `valid:A->bool`), + ra_abs_rep), + assume_rule(`ra_laws (e:A) (op:A->A->A) (valid:A->bool)`)); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_unit_def, + abstracted, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm ra_unit_abs = prove_ra_unit_abs(); + +PROOF static thm prove_ra_op_abs(void) { + term goal_tm = ` + forall (e:A) (op:A->A->A) (valid:A->bool). + ra_laws e op valid ==> + ra_op (ra_abs (e,(op,valid))) == op + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm abstracted = mp_rule( + specl_rule( + TERM_LIST(`e:A`, `op:A->A->A`, `valid:A->bool`), + ra_abs_rep), + assume_rule(`ra_laws (e:A) (op:A->A->A) (valid:A->bool)`)); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_op_def, + abstracted, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm ra_op_abs = prove_ra_op_abs(); + +PROOF static thm prove_ra_valid_abs(void) { + term goal_tm = ` + forall (e:A) (op:A->A->A) (valid:A->bool). + ra_laws e op valid ==> + ra_valid (ra_abs (e,(op,valid))) == valid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm abstracted = mp_rule( + specl_rule( + TERM_LIST(`e:A`, `op:A->A->A`, `valid:A->bool`), + ra_abs_rep), + assume_rule(`ra_laws (e:A) (op:A->A->A) (valid:A->bool)`)); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_valid_def, + abstracted, + get_theorem_by_name("FST"), + get_theorem_by_name("SND")))); + return gnode_prove(root); +} + +PROOF thm ra_valid_abs = prove_ra_valid_abs(); + +PROOF static thm prove_ra_abs_eta(void) { + term goal_tm = ` + forall R:(A)ra. + ra_abs (ra_unit R,(ra_op R,ra_valid R)) == R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + ra_type_bijection, + ra_unit_def, + ra_op_def, + ra_valid_def, + get_theorem_by_name("PAIR")))); + return gnode_prove(root); +} + +PROOF thm ra_abs_eta = prove_ra_abs_eta(); + +PROOF static int audit_ra_core(void) { + thm_list public_definitions = THM_LIST( + ra_compatible_def, + ra_included_def, + ra_updateP_def, + ra_update_def, + ra_cancellative_def, + ra_maximal_def); + thm_list public_rules = THM_LIST( + ra_laws, + ra_assoc, + ra_comm, + ra_unit_l, + ra_unit_r, + ra_valid_unit, + ra_valid_op, + ra_compat_comm, + ra_compat_unit, + ra_included_refl, + ra_included_unit, + ra_included_op_l, + ra_included_op_r, + ra_included_trans, + ra_included_op_mono, + ra_included_valid, + ra_updateP_singleton, + ra_updateP_refl, + ra_updateP_mono, + ra_updateP_trans, + ra_updateP_valid, + ra_updateP_frame, + ra_updateP_op, + ra_update_refl, + ra_update_trans, + ra_update_frame, + ra_update_op, + ra_update_included, + ra_update_target_included, + ra_update_valid, + ra_maximal_included, + ra_maximal_update, + ra_cancellative_apply); + thm_list builder_theorems = THM_LIST( + ra_laws_def, + ra_type_bijection, + ra_rep_laws, + ra_abs_rep, + ra_unit_abs, + ra_op_abs, + ra_valid_abs, + ra_abs_eta); + + for (size_t i = 0; i < vector_size(public_definitions); ++i) { + ENSURE_COND(!IS_NULL(public_definitions[i]), + "RA public definition %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_definitions[i])) == 0, + "RA public definition %zu has hypotheses", i); + } + for (size_t i = 0; i < vector_size(public_rules); ++i) { + ENSURE_COND(!IS_NULL(public_rules[i]), + "RA public rule %zu is empty", i); + ENSURE_COND(vector_size(hyp(public_rules[i])) == 0, + "RA public rule %zu has hypotheses", i); + } + for (size_t i = 0; i < vector_size(builder_theorems); ++i) { + ENSURE_COND(!IS_NULL(builder_theorems[i]), + "RA builder theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(builder_theorems[i])) == 0, + "RA builder theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == RA_AXIOMS_BEFORE, + "RA core introduced an axiom"); + ENSURE_COND(get_tyconst_arity("ra") == 1, + "ra is not a unary HOL type constructor"); + return 0; +err: + ERR_FUN_PUTS("audit_ra_core"); + return -1; +} + +PROOF static int _RA_CORE_AUDIT = audit_ra_core(); diff --git a/theory/logic/ra.h b/theory/logic/ra.h new file mode 100644 index 0000000000000000000000000000000000000000..ef3f14aca0bec7feb92647ce4a59bc3e4012d619 --- /dev/null +++ b/theory/logic/ra.h @@ -0,0 +1,426 @@ +#pragma once + +/* + * Public interface for discrete unital resource algebras. + * + * `(A)ra` bundles a unit, a commutative associative operation, and a validity + * predicate closed under taking fragments. This header exposes only the + * semantic projections, relations, and laws used by ordinary clients. + * Constructor authors use `ra_builder.h`; implementation proofs may also use + * `ra_internal.h`. + * + * `ra_updateP` is the primitive frame-preserving update. `ra_update` is its + * singleton specialization. `ra_maximal` is the strong, frame-based notion + * of maximality: the source is valid and its only compatible frame is the + * unit. It is deliberately distinct from self-conflict exclusivity. + */ + +#include "proof/proof_kernel.h" + +/* ------------------------------------------------------------------------- */ +/* Derived relations */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_compatible R a b <=> ra_valid R (ra_op R a b) + * ``` + * + * 资源 `a` 与 `b` 兼容，当且仅当它们的 RA 组合有效。 + */ +PROOF extern thm ra_compatible_def; + +/* + * ```text + * ra_included R a b <=> (exists frame. b == ra_op R a frame) + * ``` + * + * `a` 包含于 `b`，当且仅当存在 frame 使 `b = a ⋅ frame`。 + */ +PROOF extern thm ra_included_def; + +/* + * ```text + * ra_updateP R a result <=> + * (forall frame. + * ra_valid R (ra_op R a frame) + * ==> (exists b. result b && ra_valid R (ra_op R b frame))) + * ``` + * + * `a` 可更新到谓词 `result`，当且仅当对每个与 `a` 兼容的 frame，都能选出满足 `result` 且与该 frame 兼容的目标资源。 + */ +PROOF extern thm ra_updateP_def; + +/* + * ```text + * ra_update R a b <=> ra_updateP R a (\x. x == b) + * ``` + * + * 确定性更新 `a -> b` 就是目标谓词只接受 `b` 的谓词更新。 + */ +PROOF extern thm ra_update_def; + +/* + * ```text + * ra_cancellative R <=> + * (forall frame a b. + * ra_valid R (ra_op R frame a) + * ==> ra_op R frame a == ra_op R frame b + * ==> a == b) + * ``` + * + * RA 可消去，当且仅当在 `frame ⋅ a` 有效时，等式 `frame ⋅ a = frame ⋅ b` 总能推出 `a = b`。 + */ +PROOF extern thm ra_cancellative_def; + +/* + * ```text + * ra_maximal R a <=> + * ra_valid R a && + * (forall frame. ra_valid R (ra_op R a frame) ==> frame == ra_unit R) + * ``` + * + * `a` 为 maximal，当且仅当 `a` 有效且与它兼容的每个 frame 都是 unit。 + */ +PROOF extern thm ra_maximal_def; + +/* ------------------------------------------------------------------------- */ +/* Intrinsic RA laws */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R. ra_laws (ra_unit R) (ra_op R) (ra_valid R) + * ``` + * + * 每个 RA 的组合满足结合律和交换律，unit 是有效单位元，且组合有效会推出两个分量都有效。 + */ +PROOF extern thm ra_laws; + +/* + * ```text + * forall R a b c. ra_op R (ra_op R a b) c == ra_op R a (ra_op R b c) + * ``` + * + * RA 组合满足结合律，`(a ⋅ b) ⋅ c` 与 `a ⋅ (b ⋅ c)` 相等。 + */ +PROOF extern thm ra_assoc; + +/* + * ```text + * forall R a b. ra_op R a b == ra_op R b a + * ``` + * + * RA 组合满足交换律，`a ⋅ b` 与 `b ⋅ a` 相等。 + */ +PROOF extern thm ra_comm; + +/* + * ```text + * forall R a. ra_op R (ra_unit R) a == a + * ``` + * + * unit 与任意资源从左侧组合仍得到原资源。 + */ +PROOF extern thm ra_unit_l; + +/* + * ```text + * forall R a. ra_op R a (ra_unit R) == a + * ``` + * + * unit 与任意资源从右侧组合仍得到原资源。 + */ +PROOF extern thm ra_unit_r; + +/* + * ```text + * forall R. ra_valid R (ra_unit R) + * ``` + * + * 每个 RA 的 unit 都是有效资源。 + */ +PROOF extern thm ra_valid_unit; + +/* + * ```text + * forall R a b. ra_valid R (ra_op R a b) ==> ra_valid R a && ra_valid R b + * ``` + * + * 若组合资源 `a ⋅ b` 有效，则它的两个分量 `a` 和 `b` 都有效。 + */ +PROOF extern thm ra_valid_op; + +/* ------------------------------------------------------------------------- */ +/* Compatibility and inclusion */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a b. ra_compatible R a b <=> ra_compatible R b a + * ``` + * + * RA 兼容性是对称的，`a` 与 `b` 兼容等价于 `b` 与 `a` 兼容。 + */ +PROOF extern thm ra_compat_comm; + +/* + * ```text + * forall R a. ra_compatible R a (ra_unit R) <=> ra_valid R a + * ``` + * + * `a` 与 unit 兼容，当且仅当 `a` 本身有效。 + */ +PROOF extern thm ra_compat_unit; + +/* + * ```text + * forall R a. ra_included R a a + * ``` + * + * 任意资源都包含于自身。 + */ +PROOF extern thm ra_included_refl; + +/* + * ```text + * forall R a. ra_included R (ra_unit R) a + * ``` + * + * unit 包含于任意资源。 + */ +PROOF extern thm ra_included_unit; + +/* + * ```text + * forall R a b. ra_included R a (ra_op R a b) + * ``` + * + * 组合资源 `a ⋅ b` 总是包含左分量 `a`。 + */ +PROOF extern thm ra_included_op_l; + +/* + * ```text + * forall R a b. ra_included R b (ra_op R a b) + * ``` + * + * 组合资源 `a ⋅ b` 总是包含右分量 `b`。 + */ +PROOF extern thm ra_included_op_r; + +/* + * ```text + * forall R a b c. ra_included R a b ==> ra_included R b c ==> ra_included R a c + * ``` + * + * 包含关系可传递：`a` 包含于 `b` 且 `b` 包含于 `c` 时，`a` 包含于 `c`。 + */ +PROOF extern thm ra_included_trans; + +/* + * ```text + * forall R a1 a2 b1 b2. + * ra_included R a1 a2 + * ==> ra_included R b1 b2 + * ==> ra_included R (ra_op R a1 b1) (ra_op R a2 b2) + * ``` + * + * 若 `a1` 包含于 `a2` 且 `b1` 包含于 `b2`，则 `a1 ⋅ b1` 包含于 `a2 ⋅ b2`。 + */ +PROOF extern thm ra_included_op_mono; + +/* + * ```text + * forall R a b. ra_included R a b ==> ra_valid R b ==> ra_valid R a + * ``` + * + * 若 `a` 包含于有效资源 `b`，则片段 `a` 也有效。 + */ +PROOF extern thm ra_included_valid; + +/* ------------------------------------------------------------------------- */ +/* Predicate updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a b. ra_updateP R a (\x. x == b) <=> ra_update R a b + * ``` + * + * 目标只接受 `b` 的谓词更新，与确定性更新 `a -> b` 等价。 + */ +PROOF extern thm ra_updateP_singleton; + +/* + * ```text + * forall R a. ra_updateP R a (\x. x == a) + * ``` + * + * 任意资源 `a` 都可谓词更新到只接受自身的目标。 + */ +PROOF extern thm ra_updateP_refl; + +/* + * ```text + * forall R a P Q. + * ra_updateP R a P ==> (forall b. P b ==> Q b) ==> ra_updateP R a Q + * ``` + * + * 若 `a` 可更新到 `P`，且 `P` 蕴含 `Q`，则可将目标放宽为 `Q`。 + */ +PROOF extern thm ra_updateP_mono; + +/* + * ```text + * forall R a P Q. + * ra_updateP R a P + * ==> (forall b. P b ==> ra_updateP R b Q) + * ==> ra_updateP R a Q + * ``` + * + * 若 `a` 可更新到 `P`，且每个满足 `P` 的结果都可继续更新到 `Q`，则 `a` 可直接更新到 `Q`。 + */ +PROOF extern thm ra_updateP_trans; + +/* + * ```text + * forall R a P. + * ra_updateP R a P ==> ra_valid R a ==> (exists b. P b && ra_valid R b) + * ``` + * + * 若源 `a` 有效且可更新到 `P`，则存在一个既有效又满足 `P` 的结果。 + */ +PROOF extern thm ra_updateP_valid; + +/* + * ```text + * forall R a P extra. + * ra_updateP R a P + * ==> ra_updateP R (ra_op R a extra) + * (\x. exists b. P b && x == ra_op R b extra) + * ``` + * + * 若 `a` 可谓词更新到 `P`，则 `a ⋅ extra` 可更新到形如 `b ⋅ extra` 的结果，其中 `P b`，而 `extra` 保持不变。 + */ +PROOF extern thm ra_updateP_frame; + +/* + * ```text + * forall R a c P Q. + * ra_updateP R a P + * ==> ra_updateP R c Q + * ==> ra_updateP R (ra_op R a c) + * (\x. exists b d. P b && Q d && x == ra_op R b d) + * ``` + * + * `a` 更新到 `P` 且 `c` 更新到 `Q` 时，`a ⋅ c` 可更新为某个 `b ⋅ d`，其中 `P b` 与 `Q d` 同时成立。 + */ +PROOF extern thm ra_updateP_op; + +/* ------------------------------------------------------------------------- */ +/* Deterministic updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a. ra_update R a a + * ``` + * + * 任意资源都可更新为自身。 + */ +PROOF extern thm ra_update_refl; + +/* + * ```text + * forall R a b c. ra_update R a b ==> ra_update R b c ==> ra_update R a c + * ``` + * + * 确定性更新可传递：`a -> b` 与 `b -> c` 可串联为 `a -> c`。 + */ +PROOF extern thm ra_update_trans; + +/* + * ```text + * forall R a b extra. + * ra_update R a b ==> ra_update R (ra_op R a extra) (ra_op R b extra) + * ``` + * + * 若 `a` 可更新为 `b`，则保留 `extra` 不变可将 `a ⋅ extra` 更新为 `b ⋅ extra`。 + */ +PROOF extern thm ra_update_frame; + +/* + * ```text + * forall R a b c d. + * ra_update R a b + * ==> ra_update R c d + * ==> ra_update R (ra_op R a c) (ra_op R b d) + * ``` + * + * 更新 `a -> b` 与 `c -> d` 可同步执行，得到组合资源的更新 `a ⋅ c -> b ⋅ d`。 + */ +PROOF extern thm ra_update_op; + +/* + * ```text + * forall R a b. ra_included R b a ==> ra_update R a b + * ``` + * + * 若 `b` 是 `a` 已包含的片段，则 `a` 可通过 frame-preserving 更新丢弃余部而变为 `b`。 + */ +PROOF extern thm ra_update_included; + +/* + * ```text + * forall R a b c. ra_update R a b ==> ra_included R c b ==> ra_update R a c + * ``` + * + * 若 `a` 可更新为 `b` 且 `c` 是 `b` 包含的片段，则 `a` 也可直接更新为 `c`。 + */ +PROOF extern thm ra_update_target_included; + +/* + * ```text + * forall R a b. ra_update R a b ==> ra_valid R a ==> ra_valid R b + * ``` + * + * 若更新 `a -> b` 成立且源 `a` 有效，则目标 `b` 也有效。 + */ +PROOF extern thm ra_update_valid; + +/* ------------------------------------------------------------------------- */ +/* Optional algebraic properties */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a b. + * ra_maximal R a ==> ra_valid R b ==> ra_included R a b ==> a == b + * ``` + * + * 若 maximal 资源 `a` 包含于有效资源 `b`，则 `b` 不能多出非 unit 片段，因而 `a = b`。 + */ +PROOF extern thm ra_maximal_included; + +/* + * ```text + * forall R a b. ra_maximal R a ==> ra_valid R b ==> ra_update R a b + * ``` + * + * maximal 资源只有 unit frame，因此它可更新为任意有效资源。 + */ +PROOF extern thm ra_maximal_update; + +/* + * ```text + * forall R frame a b. + * ra_cancellative R + * ==> ra_valid R (ra_op R frame a) + * ==> ra_op R frame a == ra_op R frame b + * ==> a == b + * ``` + * + * 在可消去 RA 中，若 `frame ⋅ a` 有效且等于 `frame ⋅ b`，则可消去公共 frame 得到 `a = b`。 + */ +PROOF extern thm ra_cancellative_apply; diff --git a/theory/logic/ra_builder.h b/theory/logic/ra_builder.h new file mode 100644 index 0000000000000000000000000000000000000000..a5d566f888bde7325bda9c0a27a2e929c1be6bc5 --- /dev/null +++ b/theory/logic/ra_builder.h @@ -0,0 +1,102 @@ +#pragma once + +/* + * INTERNAL CONSTRUCTOR-AUTHOR INTERFACE for defining lawful `(A)ra` values. + * + * Ordinary clients should include `ra.h`. This header deliberately exposes + * the raw descriptor predicate and abstraction/representation machinery + * needed by constructor implementations. It must not be re-exported from a + * public constructor header. + */ + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Raw descriptor laws and representation */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_laws e op valid <=> + * (forall a b c. op (op a b) c == op a (op b c)) && + * (forall a b. op a b == op b a) && + * (forall a. op e a == a) && + * valid e && + * (forall a b. valid (op a b) ==> valid a) + * ``` + * + * `(e, op, valid)` 满足 RA laws，当且仅当 `op` 结合且交换、`e` 为有效左单位元，并且组合有效能推出左分量有效。 + */ +PROOF extern thm ra_laws_def; + +/* + * ```text + * (forall a. ra_abs (ra_rep a) == a) && + * (forall r. + * ra_laws (FST r) (FST (SND r)) (SND (SND r)) <=> ra_rep (ra_abs r) == r) + * ``` + * + * `ra_abs` 与 `ra_rep` 在 RA 抽象值和满足 `ra_laws` 的表示三元组之间构成互逆对应。 + */ +PROOF extern thm ra_type_bijection; + +/* + * ```text + * forall R. + * ra_laws (FST (ra_rep R)) (FST (SND (ra_rep R))) (SND (SND (ra_rep R))) + * ``` + * + * 任意 RA 的表示三元组所给出的 unit、组合运算和有效性谓词都满足 `ra_laws`。 + */ +PROOF extern thm ra_rep_laws; + +/* + * ```text + * forall e op valid. + * ra_laws e op valid ==> ra_rep (ra_abs (e,op,valid)) == e,op,valid + * ``` + * + * 对满足 `ra_laws` 的三元组 `(e,op,valid)`，先抽象为 RA 再取表示会恢复该三元组。 + */ +PROOF extern thm ra_abs_rep; + +/* ------------------------------------------------------------------------- */ +/* Constructor computation rules */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall e op valid. ra_laws e op valid ==> ra_unit (ra_abs (e,op,valid)) == e + * ``` + * + * 对满足 `ra_laws` 的 `(e,op,valid)`，由它构造的 RA 的 unit 正是 `e`。 + */ +PROOF extern thm ra_unit_abs; + +/* + * ```text + * forall e op valid. ra_laws e op valid ==> ra_op (ra_abs (e,op,valid)) == op + * ``` + * + * 对满足 `ra_laws` 的 `(e,op,valid)`，由它构造的 RA 的组合运算正是 `op`。 + */ +PROOF extern thm ra_op_abs; + +/* + * ```text + * forall e op valid. + * ra_laws e op valid ==> ra_valid (ra_abs (e,op,valid)) == valid + * ``` + * + * 对满足 `ra_laws` 的 `(e,op,valid)`，由它构造的 RA 的有效性谓词正是 `valid`。 + */ +PROOF extern thm ra_valid_abs; + +/* + * ```text + * forall R. ra_abs (ra_unit R,ra_op R,ra_valid R) == R + * ``` + * + * 用任意 RA 的 unit、组合运算和有效性谓词重新抽象，得到的仍是原 RA。 + */ +PROOF extern thm ra_abs_eta; diff --git a/theory/logic/ra_internal.h b/theory/logic/ra_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..01799aadfff97c315d328b0d3393c09a5ccb65e9 --- /dev/null +++ b/theory/logic/ra_internal.h @@ -0,0 +1,158 @@ +#pragma once + +/* + * INTERNAL DERIVED RULES for RA and constructor implementations. + * + * Ordinary protocol/client headers must include only `ra.h`. These helpers + * expose convenient eliminators and normalization rules that are intentionally + * absent from the public compatibility surface. + */ + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Operation and validity normalization */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a b c. ra_op R (ra_op R a b) c == ra_op R (ra_op R a c) b + * ``` + * + * 在保留左分量 `a` 的嵌套组合中，可交换右侧的 `b` 与 `c`。 + */ +PROOF extern thm ra_op_swap_right; + +/* + * ```text + * forall R a b. ra_valid R (ra_op R a b) ==> ra_valid R a + * ``` + * + * 若组合资源 `a ⋅ b` 有效，则左分量 `a` 有效。 + */ +PROOF extern thm ra_valid_op_l; + +/* + * ```text + * forall R a b. ra_valid R (ra_op R a b) ==> ra_valid R b + * ``` + * + * 若组合资源 `a ⋅ b` 有效，则右分量 `b` 有效。 + */ +PROOF extern thm ra_valid_op_r; + +/* + * ```text + * forall R a frame. + * ra_maximal R a ==> ra_valid R (ra_op R a frame) ==> frame == ra_unit R + * ``` + * + * maximal 资源 `a` 与 frame 组合后若有效，则该 frame 必为 unit。 + */ +PROOF extern thm ra_maximal_apply; + +/* + * ```text + * forall R a b frame. + * ra_update R a b + * ==> ra_valid R (ra_op R a frame) + * ==> ra_valid R (ra_op R b frame) + * ``` + * + * 若 `a -> b` 是 frame-preserving 更新，则任何使 `a ⋅ frame` 有效的 frame 也使 `b ⋅ frame` 有效。 + */ +PROOF extern thm ra_update_apply; + +/* + * ```text + * forall R a P frame. + * ra_updateP R a P + * ==> ra_valid R (ra_op R a frame) + * ==> (exists b. P b && ra_valid R (ra_op R b frame)) + * ``` + * + * 若 `a` 可谓词更新到 `P`，则对每个与 `a` 兼容的 frame，都存在满足 `P` 且与同一 frame 兼容的结果 `b`。 + */ +PROOF extern thm ra_updateP_apply; + +/* ------------------------------------------------------------------------- */ +/* Inclusion and cancellation helpers */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a1 a2 b. + * ra_included R a1 a2 ==> ra_included R (ra_op R a1 b) (ra_op R a2 b) + * ``` + * + * 若 `a1` 包含于 `a2`，则在两边右侧组合同一 `b` 后仍保持包含。 + */ +PROOF extern thm ra_included_op_mono_l; + +/* + * ```text + * forall R a1 a2 b. + * ra_included R a1 a2 ==> ra_included R (ra_op R b a1) (ra_op R b a2) + * ``` + * + * 若 `a1` 包含于 `a2`，则在两边左侧组合同一 `b` 后仍保持包含。 + */ +PROOF extern thm ra_included_op_mono_r; + +/* + * ```text + * forall R a b frame. + * ra_included R a b + * ==> ra_valid R (ra_op R b frame) + * ==> ra_valid R (ra_op R a frame) + * ``` + * + * 若 `a` 包含于 `b` 且 `b ⋅ frame` 有效，则替换为更小片段后的 `a ⋅ frame` 也有效。 + */ +PROOF extern thm ra_included_valid_frame; + +/* + * ```text + * forall R common a b. + * ra_cancellative R + * ==> ra_valid R (ra_op R common b) + * ==> ra_included R (ra_op R common a) (ra_op R common b) + * ==> ra_included R a b + * ``` + * + * 在可消去 RA 中，若 `common ⋅ b` 有效且 `common ⋅ a` 包含于它，则可消去公共分量得到 `a` 包含于 `b`。 + */ +PROOF extern thm ra_included_cancel_l; + +/* + * ```text + * forall R a frame. + * ra_maximal R a + * ==> (ra_valid R (ra_op R a frame) <=> ra_valid R a && frame == ra_unit R) + * ``` + * + * 对 maximal 资源 `a`，`a ⋅ frame` 有效当且仅当 `a` 有效且 `frame` 是 unit。 + */ +PROOF extern thm ra_maximal_valid_op_iff; + +/* ------------------------------------------------------------------------- */ +/* Update bridges */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall R a b P. ra_update R a b ==> P b ==> ra_updateP R a P + * ``` + * + * 若 `a` 可确定性更新为满足 `P` 的 `b`，则 `a` 可谓词更新到 `P`。 + */ +PROOF extern thm ra_updateP_of_update; + +/* + * ```text + * forall R a. ra_update R a (ra_unit R) + * ``` + * + * 任意 RA 资源都可更新为 unit，即丢弃自身的全部资源。 + */ +PROOF extern thm ra_update_unit; diff --git a/theory/logic/resource_prop.c b/theory/logic/resource_prop.c new file mode 100644 index 0000000000000000000000000000000000000000..fe174e21f353612848e8d989000a1b0b1a1d0f98 --- /dev/null +++ b/theory/logic/resource_prop.c @@ -0,0 +1,3430 @@ +#include "proof/theory/logic/resource_prop.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/ra.c" + +/* + * The proof helpers come directly from the proof stdlib's backward-reasoning + * layer. This module does not register any constant or rule with QCP. + */ + +PROOF static size_t RESOURCE_PROP_AXIOMS_BEFORE = + vector_size(get_all_axioms()); + +PROOF thm r_entails_def = new_fun_definition(` + r_entails + (R:(A)ra) + (P:A->bool) + (Q:A->bool) <=> + forall resource:A. + ra_valid R resource ==> + P resource ==> + Q resource +`); + +PROOF thm r_equiv_def = new_fun_definition(` + r_equiv + (R:(A)ra) + (P:A->bool) + (Q:A->bool) <=> + r_entails R P Q && + r_entails R Q P +`); + +PROOF thm r_emp_def = new_fun_definition(` + r_emp + (R:(A)ra) + (resource:A) <=> + resource == ra_unit R +`); + +PROOF thm r_sep_def = new_fun_definition(` + r_sep + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (resource:A) <=> + exists left right:A. + resource == ra_op R left right && + P left && + Q right +`); + +PROOF thm r_own_def = new_fun_definition(` + r_own + (R:(A)ra) + (owned:A) + (resource:A) <=> + resource == owned +`); + +PROOF thm r_top_def = new_fun_definition(` + r_top + (R:(A)ra) + (resource:A) <=> + T +`); + +PROOF thm r_bottom_def = new_fun_definition(` + r_bottom + (R:(A)ra) + (resource:A) <=> + F +`); + +PROOF thm r_and_def = new_fun_definition(` + r_and + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (resource:A) <=> + P resource && + Q resource +`); + +PROOF thm r_or_def = new_fun_definition(` + r_or + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (resource:A) <=> + P resource || + Q resource +`); + +PROOF thm r_impl_def = new_fun_definition(` + r_impl + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (resource:A) <=> + P resource ==> + Q resource +`); + +PROOF thm r_exists_def = new_fun_definition(` + r_exists + (R:(A)ra) + (P:B->A->bool) + (resource:A) <=> + exists witness:B. + P witness resource +`); + +PROOF thm r_forall_def = new_fun_definition(` + r_forall + (R:(A)ra) + (P:B->A->bool) + (resource:A) <=> + forall witness:B. + P witness resource +`); + +PROOF thm r_pure_def = new_fun_definition(` + r_pure + (R:(A)ra) + (phi:bool) + (resource:A) <=> + phi +`); + +PROOF thm r_fact_def = new_fun_definition(` + r_fact + (R:(A)ra) + (phi:bool) + (resource:A) <=> + phi && + resource == ra_unit R +`); + +PROOF thm r_wand_def = new_fun_definition(` + r_wand + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (resource:A) <=> + forall frame:A. + ra_valid R (ra_op R resource frame) ==> + P frame ==> + Q (ra_op R resource frame) +`); + +PROOF static thm prove_r_entails_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (P:A->bool). + r_entails R P P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_entails_def))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC(body, assume_rule(`(P:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_entails_refl = + prove_r_entails_refl(); + +PROOF static thm prove_r_entails_trans(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails R P Q ==> + r_entails R Q S ==> + r_entails R P S + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_entails_def))); + body = AUTO_INTROS_TAC(body); + + thm q_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + thm s_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (Q:A->bool) resource ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + q_resource); + ACCEPT_TAC(body, s_resource); + return gnode_prove(root); +} + +PROOF thm r_entails_trans = + prove_r_entails_trans(); + +PROOF static thm prove_r_entails_pointwise(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + (forall resource:A. + P resource ==> Q resource) ==> + r_entails R P Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_entails_def))); + body = AUTO_INTROS_TAC(body); + thm result = mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_entails_pointwise = + prove_r_entails_pointwise(); + +PROOF static thm prove_r_equiv_pointwise(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_equiv R P Q <=> + forall resource:A. + ra_valid R resource ==> + (P resource <=> Q resource) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_equiv_def, + r_entails_def))); + body = AUTO_INTROS_TAC(body); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hboth"); + forward = ASMP_CONJ_TAC( + forward, + "Hboth", + "HPQ", + "HQP"); + forward = GEN_TAC(forward, "resource"); + forward = DISCH_TAC(forward, "Hvalid"); + gnode_list iff_directions = EQ_TAC(forward); + + gnode pq = DISCH_TAC(iff_directions[0], "HP"); + thm q_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(pq, q_resource); + + gnode qp = DISCH_TAC(iff_directions[1], "HQ"); + thm p_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (Q:A->bool) resource ==> + (P:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(Q:A->bool) (resource:A)`)); + ACCEPT_TAC(qp, p_resource); + + gnode reverse = DISCH_TAC(directions[1], "Hpointwise"); + gnode_list both = CONJ_TAC(reverse); + + gnode reverse_pq = AUTO_INTROS_TAC(both[0]); + thm pointwise_pq = mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + ((P:A->bool) resource <=> + (Q:A->bool) resource) + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)); + ACCEPT_TAC( + reverse_pq, + eq_mp_rule( + pointwise_pq, + assume_rule(`(P:A->bool) (resource:A)`))); + + gnode reverse_qp = AUTO_INTROS_TAC(both[1]); + thm pointwise_qp = mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + ((P:A->bool) resource <=> + (Q:A->bool) resource) + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)); + ACCEPT_TAC( + reverse_qp, + eq_mp_rule( + gsym_rule(pointwise_qp), + assume_rule(`(Q:A->bool) (resource:A)`))); + return gnode_prove(root); +} + +PROOF thm r_equiv_pointwise = + prove_r_equiv_pointwise(); + +PROOF static thm prove_r_equiv_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R P Q ==> + r_entails R Q P ==> + r_equiv R P Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_equiv_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + assume_rule(`r_entails (R:(A)ra) (P:A->bool) (Q:A->bool)`)); + ACCEPT_TAC( + result[1], + assume_rule(`r_entails (R:(A)ra) (Q:A->bool) (P:A->bool)`)); + return gnode_prove(root); +} + +PROOF thm r_equiv_intro = + prove_r_equiv_intro(); + +PROOF static thm prove_r_equiv_refl(void) { + term goal_tm = ` + forall (R:(A)ra) (P:A->bool). + r_equiv R P P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(r_equiv_def))); + body = AUTO_INTROS_TAC(body); + gnode_list parts = CONJ_TAC(body); + ACCEPT_TAC( + parts[0], + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)); + ACCEPT_TAC( + parts[1], + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)); + return gnode_prove(root); +} + +PROOF thm r_equiv_refl = + prove_r_equiv_refl(); + +/* Raw function equality is useful inside implementations, but the public + * connective API is validity-sensitive equivalence. */ +PROOF static thm prove_r_equiv_of_eq(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool). + P == Q ==> + r_equiv R P Q + `); + gnode body = AUTO_INTROS_TAC(root); + thm lifted = beta_rule(ap_term_rule( + `\X:A->bool. r_equiv (R:(A)ra) (P:A->bool) X`, + assume_rule(`(P:A->bool) == (Q:A->bool)`))); + ACCEPT_TAC( + body, + eq_mp_rule( + lifted, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_equiv_refl))); + return gnode_prove(root); +} + +PROOF static thm r_equiv_of_eq = + prove_r_equiv_of_eq(); + +PROOF static thm prove_r_equiv_sym(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_equiv R P Q ==> + r_equiv R Q P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_equiv_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hboth"); + body = ASMP_CONJ_TAC( + body, + "Hboth", + "HPQ", + "HQP"); + gnode_list parts = CONJ_TAC(body); + ACCEPT_TAC( + parts[0], + assume_rule(`r_entails (R:(A)ra) (Q:A->bool) (P:A->bool)`)); + ACCEPT_TAC( + parts[1], + assume_rule(`r_entails (R:(A)ra) (P:A->bool) (Q:A->bool)`)); + return gnode_prove(root); +} + +PROOF thm r_equiv_sym = + prove_r_equiv_sym(); + +PROOF static thm prove_r_equiv_trans(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_equiv R P Q ==> + r_equiv R Q S ==> + r_equiv R P S + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_equiv_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "S"); + body = DISCH_TAC(body, "HPQ_and_QP"); + body = DISCH_TAC(body, "HQS_and_SQ"); + body = ASMP_CONJ_TAC( + body, + "HPQ_and_QP", + "HPQ", + "HQP"); + body = ASMP_CONJ_TAC( + body, + "HQS_and_SQ", + "HQS", + "HSQ"); + gnode_list parts = CONJ_TAC(body); + + thm ps = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `Q:A->bool`, + `S:A->bool`), + r_entails_trans), + assume_rule(` + r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) + `)), + assume_rule(` + r_entails (R:(A)ra) (Q:A->bool) (S:A->bool) + `)); + ACCEPT_TAC(parts[0], ps); + + thm sp = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `S:A->bool`, + `Q:A->bool`, + `P:A->bool`), + r_entails_trans), + assume_rule(` + r_entails (R:(A)ra) (S:A->bool) (Q:A->bool) + `)), + assume_rule(` + r_entails (R:(A)ra) (Q:A->bool) (P:A->bool) + `)); + ACCEPT_TAC(parts[1], sp); + return gnode_prove(root); +} + +PROOF thm r_equiv_trans = + prove_r_equiv_trans(); + +PROOF static thm prove_r_top_intro(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool). + r_entails R P (r_top R) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_entails_def, r_top_def))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC(body, eqt_elim_rule(refl_rule(mk_true()))); + return gnode_prove(root); +} + +PROOF thm r_top_intro = + prove_r_top_intro(); + +PROOF static thm prove_r_bottom_elim(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool). + r_entails R (r_bottom R) P + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_entails_def, r_bottom_def))); + body = AUTO_INTROS_TAC(body); + CONTR_TAC(body, assume_rule(`F`)); + return gnode_prove(root); +} + +PROOF thm r_bottom_elim = + prove_r_bottom_elim(); + +PROOF static thm prove_r_sep_comm(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_sep R P Q == + r_sep R Q P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_sep (R:(A)ra) (P:A->bool) (Q:A->bool)`, + `r_sep (R:(A)ra) (Q:A->bool) (P:A->bool)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(r_sep_def))); + gnode_list directions = EQ_TAC(body); + + for (size_t i = 0; i < vector_size(directions); ++i) { + const char* first_pred = i == 0 ? "HP" : "HQ"; + const char* second_pred = i == 0 ? "HQ" : "HP"; + gnode branch = DISCH_TAC(directions[i], "Hsep"); + branch = ASMP_EXISTS_TAC(branch, "Hsep", "left"); + branch = ASMP_EXISTS_TAC(branch, "Hsep", "right"); + branch = ASMP_CONJ_TAC( + branch, + "Hsep", + "Hsplit", + "Hpreds"); + branch = ASMP_CONJ_TAC( + branch, + "Hpreds", + first_pred, + second_pred); + branch = EXISTS_TAC(branch, `right:A`); + branch = EXISTS_TAC(branch, `left:A`); + gnode_list result1 = CONJ_TAC(branch); + thm swapped = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `left:A`, + `right:A`), + ra_comm)); + ACCEPT_TAC(result1[0], swapped); + gnode_list result2 = CONJ_TAC(result1[1]); + ACCEPT_TAC( + result2[0], + assume_rule( + i == 0 + ? `(Q:A->bool) (right:A)` + : `(P:A->bool) (right:A)`)); + ACCEPT_TAC( + result2[1], + assume_rule( + i == 0 + ? `(P:A->bool) (left:A)` + : `(Q:A->bool) (left:A)`)); + } + return gnode_prove(root); +} + +PROOF thm r_sep_comm_eq = + prove_r_sep_comm(); + +PROOF static thm prove_r_sep_comm_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool). + r_equiv R (r_sep R P Q) (r_sep R Q P) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) (P:A->bool) (Q:A->bool)`, + `r_sep (R:(A)ra) (Q:A->bool) (P:A->bool)`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`, `Q:A->bool`), + r_sep_comm_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_comm = + prove_r_sep_comm_equiv(); + +PROOF static thm prove_r_sep_emp_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool). + r_sep R (r_emp R) P == + P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_sep + (R:(A)ra) + (r_emp R) + (P:A->bool)`, + `P:A->bool`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + r_sep_def, + r_emp_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsep"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "left"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "right"); + forward = ASMP_CONJ_TAC( + forward, + "Hsep", + "Hsplit", + "Hpreds"); + forward = ASMP_CONJ_TAC( + forward, + "Hpreds", + "Hleft_unit", + "HP"); + + thm replace_left = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) replacement (right:A)`, + assume_rule(` + (left:A) == ra_unit (R:(A)ra) + `))); + thm resource_eq_right = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `), + trans_rule( + replace_left, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `right:A`), + ra_unit_l))); + thm pred_eq = ap_term_rule( + `P:A->bool`, + gsym_rule(resource_eq_right)); + ACCEPT_TAC( + forward, + eq_mp_rule( + pred_eq, + assume_rule(`(P:A->bool) (right:A)`))); + + gnode reverse = DISCH_TAC(directions[1], "HP"); + reverse = EXISTS_TAC(reverse, `ra_unit (R:(A)ra)`); + reverse = EXISTS_TAC(reverse, `resource:A`); + gnode_list result1 = CONJ_TAC(reverse); + ACCEPT_TAC( + result1[0], + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `resource:A`), + ra_unit_l))); + gnode_list result2 = CONJ_TAC(result1[1]); + ACCEPT_TAC( + result2[0], + refl_rule(`ra_unit (R:(A)ra)`)); + ACCEPT_TAC( + result2[1], + assume_rule(`(P:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_sep_emp_l_eq = + prove_r_sep_emp_l(); + +PROOF static thm prove_r_sep_emp_l_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool). + r_equiv R (r_sep R (r_emp R) P) P + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) (r_emp R) (P:A->bool)`, + `P:A->bool`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_sep_emp_l_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_emp_l = + prove_r_sep_emp_l_equiv(); + +PROOF static thm prove_r_sep_emp_r(void) { + term R = `R:(A)ra`; + term P = `P:A->bool`; + thm commute = ispecl_rule( + TERM_LIST( + R, + P, + `r_emp (R:(A)ra)`), + r_sep_comm_eq); + thm left_unit = ispecl_rule( + TERM_LIST(R, P), + r_sep_emp_l_eq); + thm result = trans_rule(commute, left_unit); + result = gen_rule(P, result); + return gen_rule(R, result); +} + +PROOF thm r_sep_emp_r_eq = + prove_r_sep_emp_r(); + +PROOF static thm prove_r_sep_emp_r_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool). + r_equiv R (r_sep R P (r_emp R)) P + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) (P:A->bool) (r_emp R)`, + `P:A->bool`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_sep_emp_r_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_emp_r = + prove_r_sep_emp_r_equiv(); + +PROOF static thm prove_r_sep_assoc(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_sep R (r_sep R P Q) S == + r_sep R P (r_sep R Q S) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_sep + (R:(A)ra) + (r_sep R (P:A->bool) (Q:A->bool)) + (S:A->bool)`, + `r_sep + (R:(A)ra) + (P:A->bool) + (r_sep R (Q:A->bool) (S:A->bool))`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST(r_sep_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Houter"); + forward = ASMP_EXISTS_TAC(forward, "Houter", "left_pair"); + forward = ASMP_EXISTS_TAC(forward, "Houter", "right"); + forward = ASMP_CONJ_TAC( + forward, + "Houter", + "Houter_split", + "Houter_preds"); + forward = ASMP_CONJ_TAC( + forward, + "Houter_preds", + "Hinner", + "HS"); + forward = ASMP_EXISTS_TAC(forward, "Hinner", "left"); + forward = ASMP_EXISTS_TAC(forward, "Hinner", "middle"); + forward = ASMP_CONJ_TAC( + forward, + "Hinner", + "Hinner_split", + "Hinner_preds"); + forward = ASMP_CONJ_TAC( + forward, + "Hinner_preds", + "HP", + "HQ"); + forward = EXISTS_TAC(forward, `left:A`); + forward = EXISTS_TAC( + forward, + `ra_op (R:(A)ra) (middle:A) (right:A)`); + gnode_list f1 = CONJ_TAC(forward); + thm replace_left_pair = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) replacement (right:A)`, + assume_rule(` + (left_pair:A) == + ra_op (R:(A)ra) (left:A) (middle:A) + `))); + thm regrouped = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left_pair:A) (right:A) + `), + trans_rule( + replace_left_pair, + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `left:A`, + `middle:A`, + `right:A`), + ra_assoc))); + ACCEPT_TAC(f1[0], regrouped); + gnode_list f2 = CONJ_TAC(f1[1]); + ACCEPT_TAC( + f2[0], + assume_rule(`(P:A->bool) (left:A)`)); + gnode forward_inner = EXISTS_TAC(f2[1], `middle:A`); + forward_inner = EXISTS_TAC(forward_inner, `right:A`); + gnode_list f3 = CONJ_TAC(forward_inner); + ACCEPT_TAC( + f3[0], + refl_rule(` + ra_op (R:(A)ra) (middle:A) (right:A) + `)); + gnode_list f4 = CONJ_TAC(f3[1]); + ACCEPT_TAC( + f4[0], + assume_rule(`(Q:A->bool) (middle:A)`)); + ACCEPT_TAC( + f4[1], + assume_rule(`(S:A->bool) (right:A)`)); + + gnode reverse = DISCH_TAC(directions[1], "Houter"); + reverse = ASMP_EXISTS_TAC(reverse, "Houter", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Houter", "right_pair"); + reverse = ASMP_CONJ_TAC( + reverse, + "Houter", + "Houter_split", + "Houter_preds"); + reverse = ASMP_CONJ_TAC( + reverse, + "Houter_preds", + "HP", + "Hinner"); + reverse = ASMP_EXISTS_TAC(reverse, "Hinner", "middle"); + reverse = ASMP_EXISTS_TAC(reverse, "Hinner", "right"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hinner", + "Hinner_split", + "Hinner_preds"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hinner_preds", + "HQ", + "HS"); + reverse = EXISTS_TAC( + reverse, + `ra_op (R:(A)ra) (left:A) (middle:A)`); + reverse = EXISTS_TAC(reverse, `right:A`); + gnode_list r1 = CONJ_TAC(reverse); + thm replace_right_pair = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) (left:A) replacement`, + assume_rule(` + (right_pair:A) == + ra_op (R:(A)ra) (middle:A) (right:A) + `))); + thm ungrouped = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right_pair:A) + `), + trans_rule( + replace_right_pair, + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `left:A`, + `middle:A`, + `right:A`), + ra_assoc)))); + ACCEPT_TAC(r1[0], ungrouped); + gnode_list r2 = CONJ_TAC(r1[1]); + gnode reverse_inner = EXISTS_TAC(r2[0], `left:A`); + reverse_inner = EXISTS_TAC(reverse_inner, `middle:A`); + gnode_list r3 = CONJ_TAC(reverse_inner); + ACCEPT_TAC( + r3[0], + refl_rule(` + ra_op (R:(A)ra) (left:A) (middle:A) + `)); + gnode_list r4 = CONJ_TAC(r3[1]); + ACCEPT_TAC( + r4[0], + assume_rule(`(P:A->bool) (left:A)`)); + ACCEPT_TAC( + r4[1], + assume_rule(`(Q:A->bool) (middle:A)`)); + ACCEPT_TAC( + r2[1], + assume_rule(`(S:A->bool) (right:A)`)); + return gnode_prove(root); +} + +PROOF thm r_sep_assoc_eq = + prove_r_sep_assoc(); + +PROOF static thm prove_r_sep_assoc_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). + r_equiv + R + (r_sep R (r_sep R P Q) S) + (r_sep R P (r_sep R Q S)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) + (r_sep R (P:A->bool) (Q:A->bool)) + (S:A->bool)`, + `r_sep (R:(A)ra) + (P:A->bool) + (r_sep R (Q:A->bool) (S:A->bool))`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, `P:A->bool`, `Q:A->bool`, `S:A->bool`), + r_sep_assoc_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_assoc = + prove_r_sep_assoc_equiv(); + +PROOF static thm prove_r_sep_mono(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (P2:A->bool) + (Q:A->bool) + (Q2:A->bool). + r_entails R P P2 ==> + r_entails R Q Q2 ==> + r_entails + R + (r_sep R P Q) + (r_sep R P2 Q2) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_sep_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "P2"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "Q2"); + body = DISCH_TAC(body, "Hmono_P"); + body = DISCH_TAC(body, "Hmono_Q"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hsep"); + body = ASMP_EXISTS_TAC(body, "Hsep", "left"); + body = ASMP_EXISTS_TAC(body, "Hsep", "right"); + body = ASMP_CONJ_TAC( + body, + "Hsep", + "Hsplit", + "Hpreds"); + body = ASMP_CONJ_TAC( + body, + "Hpreds", + "HP", + "HQ"); + + thm valid_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `)); + thm valid_pair = eq_mp_rule( + valid_eq, + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)); + thm valid_parts = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `left:A`, + `right:A`), + ra_valid_op), + valid_pair); + thm valid_left = conjunct1_rule(valid_parts); + thm valid_right = conjunct2_rule(valid_parts); + + thm p2_left = mp_rule( + mp_rule( + spec_rule( + `left:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (P2:A->bool) resource + `)), + valid_left), + assume_rule(`(P:A->bool) (left:A)`)); + thm q2_right = mp_rule( + mp_rule( + spec_rule( + `right:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (Q:A->bool) resource ==> + (Q2:A->bool) resource + `)), + valid_right), + assume_rule(`(Q:A->bool) (right:A)`)); + + body = EXISTS_TAC(body, `left:A`); + body = EXISTS_TAC(body, `right:A`); + gnode_list result1 = CONJ_TAC(body); + ACCEPT_TAC( + result1[0], + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `)); + gnode_list result2 = CONJ_TAC(result1[1]); + ACCEPT_TAC(result2[0], p2_left); + ACCEPT_TAC(result2[1], q2_right); + return gnode_prove(root); +} + +PROOF thm r_sep_mono = + prove_r_sep_mono(); + +PROOF static thm prove_r_sep_frame_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (frame_pred:A->bool). + r_entails R P Q ==> + r_entails + R + (r_sep R P frame_pred) + (r_sep R Q frame_pred) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm framed = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `Q:A->bool`, + `frame_pred:A->bool`, + `frame_pred:A->bool`), + r_sep_mono), + assume_rule(` + r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) + `)), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `frame_pred:A->bool`), + r_entails_refl)); + ACCEPT_TAC(body, framed); + return gnode_prove(root); +} + +PROOF thm r_sep_frame_l = + prove_r_sep_frame_l(); + +PROOF static thm prove_r_sep_frame_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (frame_pred:A->bool). + r_entails R P Q ==> + r_entails + R + (r_sep R frame_pred P) + (r_sep R frame_pred Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm framed = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `frame_pred:A->bool`, + `frame_pred:A->bool`, + `P:A->bool`, + `Q:A->bool`), + r_sep_mono), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `frame_pred:A->bool`), + r_entails_refl)), + assume_rule(` + r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) + `)); + ACCEPT_TAC(body, framed); + return gnode_prove(root); +} + +PROOF thm r_sep_frame_r = + prove_r_sep_frame_r(); + +PROOF static thm prove_r_sep_exists_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:A->bool). + r_sep R (r_exists R (\x:B. P x)) Q == + r_exists R (\witness:B. r_sep R (P witness) Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fun_eq_thm = get_theorem_by_name("FUN_EQ_THM"); + term_list funext_arguments = TERM_LIST( + `r_sep + (R:(A)ra) + (r_exists R (\x:B. (P:B->A->bool) x)) + (Q:A->bool)`, + `r_exists + (R:(A)ra) + (\witness:B. + r_sep R ((P:B->A->bool) witness) (Q:A->bool))`); + thm funext = ispecl_rule( + funext_arguments, + fun_eq_thm); + thm_list funext_rewrites = THM_LIST(funext); + conv funext_rewrite = once_rewrite_conv(funext_rewrites); + body = CONV_TAC(body, funext_rewrite); + body = GEN_TAC(body, "resource"); + thm_list outer_definitions = THM_LIST( + r_sep_def, + r_exists_def); + conv outer_rewrite = pure_rewrite_conv(outer_definitions); + body = CONV_TAC(body, outer_rewrite); + conv beta = get_conversion_by_name("BETA_CONV"); + conv beta_depth = depth_conv(beta); + body = CONV_TAC(body, beta_depth); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsep"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "left"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "right"); + forward = ASMP_CONJ_TAC( + forward, + "Hsep", + "Hsplit", + "Hpreds"); + forward = ASMP_CONJ_TAC( + forward, + "Hpreds", + "Hexists_left", + "HQ"); + forward = ASMP_EXISTS_TAC( + forward, + "Hexists_left", + "witness"); + forward = EXISTS_TAC(forward, `witness:B`); + thm_list forward_sep_definitions = THM_LIST(r_sep_def); + conv forward_sep_rewrite = + once_rewrite_conv(forward_sep_definitions); + forward = CONV_TAC(forward, forward_sep_rewrite); + forward = EXISTS_TAC(forward, `left:A`); + forward = EXISTS_TAC(forward, `right:A`); + gnode_list forward1 = CONJ_TAC(forward); + thm forward_split = assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `); + ACCEPT_TAC(forward1[0], forward_split); + gnode_list forward2 = CONJ_TAC(forward1[1]); + thm forward_p = assume_rule(` + (P:B->A->bool) (witness:B) (left:A) + `); + ACCEPT_TAC(forward2[0], forward_p); + thm forward_q = assume_rule(`(Q:A->bool) (right:A)`); + ACCEPT_TAC(forward2[1], forward_q); + + gnode reverse = DISCH_TAC(directions[1], "Hexists"); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "witness"); + thm_list reverse_sep_definitions = THM_LIST(r_sep_def); + conv reverse_sep_rewrite = + once_rewrite_conv(reverse_sep_definitions); + const_cstr_list reverse_sep_assumption = + CONST_STRING_LIST("Hexists"); + reverse = ASMP_CONV_TAC( + reverse, + reverse_sep_rewrite, + reverse_sep_assumption); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "right"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hexists", + "Hsplit", + "Hpreds"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hpreds", + "HP", + "HQ"); + reverse = EXISTS_TAC(reverse, `left:A`); + reverse = EXISTS_TAC(reverse, `right:A`); + gnode_list reverse1 = CONJ_TAC(reverse); + thm reverse_split = assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `); + ACCEPT_TAC(reverse1[0], reverse_split); + gnode_list reverse2 = CONJ_TAC(reverse1[1]); + gnode reverse_exists_left = + EXISTS_TAC(reverse2[0], `witness:B`); + thm reverse_p = assume_rule(` + (P:B->A->bool) (witness:B) (left:A) + `); + ACCEPT_TAC(reverse_exists_left, reverse_p); + thm reverse_q = assume_rule(`(Q:A->bool) (right:A)`); + ACCEPT_TAC(reverse2[1], reverse_q); + thm result = gnode_prove(root); + return result; +} + +PROOF thm r_sep_exists_l_eq = + prove_r_sep_exists_l(); + +PROOF static thm prove_r_sep_exists_l_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:B->A->bool) (Q:A->bool). + r_equiv + R + (r_sep R (r_exists R (\x:B. P x)) Q) + (r_exists R (\x:B. r_sep R (P x) Q)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) + (r_exists R (\x:B. (P:B->A->bool) x)) + (Q:A->bool)`, + `r_exists (R:(A)ra) + (\x:B. r_sep R ((P:B->A->bool) x) (Q:A->bool))`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:B->A->bool`, `Q:A->bool`), + r_sep_exists_l_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_exists_l = + prove_r_sep_exists_l_equiv(); + +PROOF static thm prove_r_sep_exists_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:B->A->bool). + r_sep R P (r_exists R (\x:B. Q x)) == + r_exists R (\witness:B. r_sep R P (Q witness)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm fun_eq_thm = get_theorem_by_name("FUN_EQ_THM"); + term_list funext_arguments = TERM_LIST( + `r_sep + (R:(A)ra) + (P:A->bool) + (r_exists R (\x:B. (Q:B->A->bool) x))`, + `r_exists + (R:(A)ra) + (\witness:B. + r_sep R (P:A->bool) ((Q:B->A->bool) witness))`); + thm funext = ispecl_rule( + funext_arguments, + fun_eq_thm); + thm_list funext_rewrites = THM_LIST(funext); + conv funext_rewrite = once_rewrite_conv(funext_rewrites); + body = CONV_TAC(body, funext_rewrite); + body = GEN_TAC(body, "resource"); + thm_list outer_definitions = THM_LIST( + r_sep_def, + r_exists_def); + conv outer_rewrite = pure_rewrite_conv(outer_definitions); + body = CONV_TAC(body, outer_rewrite); + conv beta = get_conversion_by_name("BETA_CONV"); + conv beta_depth = depth_conv(beta); + body = CONV_TAC(body, beta_depth); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsep"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "left"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "right"); + forward = ASMP_CONJ_TAC( + forward, + "Hsep", + "Hsplit", + "Hpreds"); + forward = ASMP_CONJ_TAC( + forward, + "Hpreds", + "HP", + "Hexists_right"); + forward = ASMP_EXISTS_TAC( + forward, + "Hexists_right", + "witness"); + forward = EXISTS_TAC(forward, `witness:B`); + thm_list forward_sep_definitions = THM_LIST(r_sep_def); + conv forward_sep_rewrite = + once_rewrite_conv(forward_sep_definitions); + forward = CONV_TAC(forward, forward_sep_rewrite); + forward = EXISTS_TAC(forward, `left:A`); + forward = EXISTS_TAC(forward, `right:A`); + gnode_list forward1 = CONJ_TAC(forward); + thm forward_split = assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `); + ACCEPT_TAC(forward1[0], forward_split); + gnode_list forward2 = CONJ_TAC(forward1[1]); + thm forward_p = assume_rule(`(P:A->bool) (left:A)`); + ACCEPT_TAC(forward2[0], forward_p); + thm forward_q = assume_rule(` + (Q:B->A->bool) (witness:B) (right:A) + `); + ACCEPT_TAC(forward2[1], forward_q); + + gnode reverse = DISCH_TAC(directions[1], "Hexists"); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "witness"); + thm_list reverse_sep_definitions = THM_LIST(r_sep_def); + conv reverse_sep_rewrite = + once_rewrite_conv(reverse_sep_definitions); + const_cstr_list reverse_sep_assumption = + CONST_STRING_LIST("Hexists"); + reverse = ASMP_CONV_TAC( + reverse, + reverse_sep_rewrite, + reverse_sep_assumption); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hexists", "right"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hexists", + "Hsplit", + "Hpreds"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hpreds", + "HP", + "HQ"); + reverse = EXISTS_TAC(reverse, `left:A`); + reverse = EXISTS_TAC(reverse, `right:A`); + gnode_list reverse1 = CONJ_TAC(reverse); + thm reverse_split = assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `); + ACCEPT_TAC(reverse1[0], reverse_split); + gnode_list reverse2 = CONJ_TAC(reverse1[1]); + thm reverse_p = assume_rule(`(P:A->bool) (left:A)`); + ACCEPT_TAC(reverse2[0], reverse_p); + gnode reverse_exists_right = + EXISTS_TAC(reverse2[1], `witness:B`); + thm reverse_q = assume_rule(` + (Q:B->A->bool) (witness:B) (right:A) + `); + ACCEPT_TAC(reverse_exists_right, reverse_q); + thm result = gnode_prove(root); + return result; +} + +PROOF thm r_sep_exists_r_eq = + prove_r_sep_exists_r(); + +PROOF static thm prove_r_sep_exists_r_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:B->A->bool). + r_equiv + R + (r_sep R P (r_exists R (\x:B. Q x))) + (r_exists R (\x:B. r_sep R P (Q x))) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) + (P:A->bool) + (r_exists R (\x:B. (Q:B->A->bool) x))`, + `r_exists (R:(A)ra) + (\x:B. r_sep R (P:A->bool) ((Q:B->A->bool) x))`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`, `Q:B->A->bool`), + r_sep_exists_r_eq))); + return gnode_prove(root); +} + +PROOF thm r_sep_exists_r = + prove_r_sep_exists_r_equiv(); + +PROOF static thm prove_r_and_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails R P Q ==> + r_entails R P S ==> + r_entails R P (r_and R Q S) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + + thm q_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(result[0], q_resource); + + thm s_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(result[1], s_resource); + return gnode_prove(root); +} + +PROOF thm r_and_intro = + prove_r_and_intro(); + +PROOF static thm prove_r_and_elim_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R (r_and R P Q) P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hboth"); + body = ASMP_CONJ_TAC( + body, + "Hboth", + "HP", + "HQ"); + ACCEPT_TAC(body, assume_rule(`(P:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_and_elim_l = + prove_r_and_elim_l(); + +PROOF static thm prove_r_and_elim_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R (r_and R P Q) Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hboth"); + body = ASMP_CONJ_TAC( + body, + "Hboth", + "HP", + "HQ"); + ACCEPT_TAC(body, assume_rule(`(Q:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_and_elim_r = + prove_r_and_elim_r(); + +PROOF static thm prove_r_or_intro_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R P (r_or R P Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_or_def))); + body = AUTO_INTROS_TAC(body); + body = DISJ1_TAC(body); + ACCEPT_TAC(body, assume_rule(`(P:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_or_intro_l = + prove_r_or_intro_l(); + +PROOF static thm prove_r_or_intro_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool). + r_entails R Q (r_or R P Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_or_def))); + body = AUTO_INTROS_TAC(body); + body = DISJ2_TAC(body); + ACCEPT_TAC(body, assume_rule(`(Q:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_or_intro_r = + prove_r_or_intro_r(); + +PROOF static thm prove_r_or_elim(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails R P S ==> + r_entails R Q S ==> + r_entails R (r_or R P Q) S + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_or_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "S"); + body = DISCH_TAC(body, "HPS"); + body = DISCH_TAC(body, "HQS"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hor"); + gnode_list cases = ASMP_DISJ_TAC( + body, + "Hor", + "HP", + "HQ"); + + thm from_p = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(cases[0], from_p); + + thm from_q = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (Q:A->bool) resource ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(Q:A->bool) (resource:A)`)); + ACCEPT_TAC(cases[1], from_q); + return gnode_prove(root); +} + +PROOF thm r_or_elim = + prove_r_or_elim(); + +PROOF static thm prove_r_exists_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (witness:B). + r_entails + R + (P witness) + (r_exists R (\bound:B. P bound)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_exists_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `witness:B`); + ACCEPT_TAC( + body, + assume_rule(`(P:B->A->bool) (witness:B) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_exists_intro = + prove_r_exists_intro(); + +PROOF static thm prove_r_exists_elim(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:A->bool). + (forall witness:B. + r_entails R (P witness) Q) ==> + r_entails R (r_exists R (\bound:B. P bound)) Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_exists_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hall"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hexists"); + body = ASMP_EXISTS_TAC(body, "Hexists", "witness"); + + thm selected_entailment = spec_rule( + `witness:B`, + assume_rule(` + forall witness:B. + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:B->A->bool) witness resource ==> + (Q:A->bool) resource + `)); + thm result = mp_rule( + mp_rule( + spec_rule(`resource:A`, selected_entailment), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(` + (P:B->A->bool) (witness:B) (resource:A) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_exists_elim = + prove_r_exists_elim(); + +PROOF static thm prove_r_exists_mono(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:B->A->bool). + (forall witness:B. + r_entails R (P witness) (Q witness)) ==> + r_entails + R + (r_exists R (\bound:B. P bound)) + (r_exists R (\bound:B. Q bound)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_exists_def))); + body = CONV_TAC( + body, + depth_conv(get_conversion_by_name("BETA_CONV"))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hall"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hexists"); + body = ASMP_EXISTS_TAC(body, "Hexists", "witness"); + body = EXISTS_TAC(body, `witness:B`); + + thm selected_entailment = spec_rule( + `witness:B`, + assume_rule(` + forall witness:B. + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:B->A->bool) witness resource ==> + (Q:B->A->bool) witness resource + `)); + thm result = mp_rule( + mp_rule( + spec_rule(`resource:A`, selected_entailment), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(` + (P:B->A->bool) (witness:B) (resource:A) + `)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_exists_mono = + prove_r_exists_mono(); + +PROOF static thm prove_r_forall_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:B->A->bool). + (forall witness:B. + r_entails R P (Q witness)) ==> + r_entails + R + P + (r_forall R (\bound:B. Q bound)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_forall_def))); + /* Contract only `(\bound. Q bound) witness`, the redex introduced by the + * eta-long public theorem schema. Do not descend into P or Q. */ + conv beta = get_conversion_by_name("BETA_CONV"); + conv generated_redex = binder_conv(binder_conv(binder_conv( + rand_conv(binder_conv(rand_conv(rand_conv( + binder_conv(rator_conv(beta))))))))); + body = CONV_TAC(body, generated_redex); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hall"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "HP"); + body = GEN_TAC(body, "witness"); + + thm selected_entailment = spec_rule( + `witness:B`, + assume_rule(` + forall witness:B. + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:B->A->bool) witness resource + `)); + thm result = mp_rule( + mp_rule( + spec_rule(`resource:A`, selected_entailment), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_forall_intro = + prove_r_forall_intro(); + +PROOF static thm prove_r_forall_elim(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:B->A->bool) + (witness:B). + r_entails + R + (r_forall R P) + (P witness) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_forall_def))); + body = AUTO_INTROS_TAC(body); + ACCEPT_TAC( + body, + spec_rule( + `witness:B`, + assume_rule(` + forall selected:B. + (P:B->A->bool) selected (resource:A) + `))); + return gnode_prove(root); +} + +PROOF thm r_forall_elim = + prove_r_forall_elim(); + +PROOF static thm prove_r_forall_elim_cont(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (P:B->A->bool) + (Q:A->bool) + (witness:B). + r_entails R (P witness) Q ==> + r_entails + R + (r_forall R (\x:B. P x)) + Q + `); + gnode body = AUTO_INTROS_TAC(root); + thm selected = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `\x:B. (P:B->A->bool) x`, + `witness:B`), + r_forall_elim); + selected = conv_rule( + depth_conv(get_conversion_by_name("BETA_CONV")), + selected); + thm composed = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_forall R (\x:B. (P:B->A->bool) x)`, + `(P:B->A->bool) (witness:B)`, + `Q:A->bool`), + r_entails_trans); + composed = mp_rule(composed, selected); + composed = mp_rule( + composed, + assume_rule(` + r_entails + (R:(A)ra) + ((P:B->A->bool) (witness:B)) + (Q:A->bool) + `)); + ACCEPT_TAC(body, composed); + return gnode_prove(root); +} + +PROOF thm r_forall_elim_cont = + prove_r_forall_elim_cont(); + +PROOF static thm prove_r_pure_and_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool) + (P:A->bool) + (Q:A->bool). + phi ==> + r_entails R P Q ==> + r_entails + R + P + (r_and R (r_pure R phi) Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def, + r_pure_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC(result[0], assume_rule(`phi:bool`)); + + thm q_resource = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(result[1], q_resource); + return gnode_prove(root); +} + +PROOF thm r_pure_and_intro = + prove_r_pure_and_intro(); + +PROOF static thm prove_r_pure_and_elim(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool) + (P:A->bool) + (Q:A->bool). + (phi ==> r_entails R P Q) ==> + r_entails + R + (r_and R (r_pure R phi) P) + Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def, + r_pure_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "phi"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hconditional"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hboth"); + body = ASMP_CONJ_TAC( + body, + "Hboth", + "Hphi", + "HP"); + + thm entailment = mp_rule( + assume_rule(` + (phi:bool) ==> + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource + `), + assume_rule(`phi:bool`)); + thm result = mp_rule( + mp_rule( + spec_rule(`resource:A`, entailment), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_pure_and_elim = + prove_r_pure_and_elim(); + +PROOF static thm prove_r_fact_as_pure_and_emp(void) { + term goal_tm = ` + forall (R:(A)ra) (phi:bool). + r_fact R phi == + r_and R (r_pure R phi) (r_emp R) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_fact (R:(A)ra) (phi:bool)`, + `r_and + (R:(A)ra) + (r_pure R phi) + (r_emp R)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + r_fact_def, + r_and_def, + r_pure_def, + r_emp_def))); + return gnode_prove(root); +} + +PROOF thm r_fact_as_pure_and_emp_eq = + prove_r_fact_as_pure_and_emp(); + +PROOF static thm prove_r_fact_as_pure_and_emp_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (phi:bool). + r_equiv R + (r_fact R phi) + (r_and R (r_pure R phi) (r_emp R)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_fact (R:(A)ra) (phi:bool)`, + `r_and (R:(A)ra) + (r_pure R (phi:bool)) + (r_emp R)`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `phi:bool`), + r_fact_as_pure_and_emp_eq))); + return gnode_prove(root); +} + +PROOF thm r_fact_as_pure_and_emp = + prove_r_fact_as_pure_and_emp_equiv(); + +PROOF static thm prove_r_fact_true(void) { + term goal_tm = ` + forall R:(A)ra. + r_fact R T == + r_emp R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_fact (R:(A)ra) T`, + `r_emp (R:(A)ra)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + r_fact_def, + r_emp_def))); + return gnode_prove(root); +} + +PROOF thm r_fact_true_eq = + prove_r_fact_true(); + +PROOF static thm prove_r_fact_true_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall R:(A)ra. + r_equiv R (r_fact R T) (r_emp R) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_fact (R:(A)ra) T`, + `r_emp (R:(A)ra)`), + r_equiv_of_eq), + spec_rule(`R:(A)ra`, r_fact_true_eq))); + return gnode_prove(root); +} + +PROOF thm r_fact_true = + prove_r_fact_true_equiv(); + +PROOF static thm prove_r_fact_false(void) { + term goal_tm = ` + forall R:(A)ra. + r_fact R F == + r_bottom R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_fact (R:(A)ra) F`, + `r_bottom (R:(A)ra)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + r_fact_def, + r_bottom_def))); + return gnode_prove(root); +} + +PROOF thm r_fact_false_eq = + prove_r_fact_false(); + +PROOF static thm prove_r_fact_false_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall R:(A)ra. + r_equiv R (r_fact R F) (r_bottom R) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_fact (R:(A)ra) F`, + `r_bottom (R:(A)ra)`), + r_equiv_of_eq), + spec_rule(`R:(A)ra`, r_fact_false_eq))); + return gnode_prove(root); +} + +PROOF thm r_fact_false = + prove_r_fact_false_equiv(); + +PROOF static thm prove_r_fact_sep_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool) + (P:A->bool). + r_sep R (r_fact R phi) P == + r_and R (r_pure R phi) P + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_sep + (R:(A)ra) + (r_fact R (phi:bool)) + (P:A->bool)`, + `r_and + (R:(A)ra) + (r_pure R phi) + (P:A->bool)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + r_sep_def, + r_fact_def, + r_and_def, + r_pure_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsep"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "left"); + forward = ASMP_EXISTS_TAC(forward, "Hsep", "right"); + forward = ASMP_CONJ_TAC( + forward, + "Hsep", + "Hsplit", + "Hpreds"); + forward = ASMP_CONJ_TAC( + forward, + "Hpreds", + "Hfact", + "HP"); + forward = ASMP_CONJ_TAC( + forward, + "Hfact", + "Hphi", + "Hleft_unit"); + gnode_list forward_result = CONJ_TAC(forward); + ACCEPT_TAC(forward_result[0], assume_rule(`phi:bool`)); + + thm replace_left = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) replacement (right:A)`, + assume_rule(` + (left:A) == ra_unit (R:(A)ra) + `))); + thm resource_eq_right = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `), + trans_rule( + replace_left, + ispecl_rule( + TERM_LIST(`R:(A)ra`, `right:A`), + ra_unit_l))); + thm pred_eq = ap_term_rule( + `P:A->bool`, + gsym_rule(resource_eq_right)); + ACCEPT_TAC( + forward_result[1], + eq_mp_rule( + pred_eq, + assume_rule(`(P:A->bool) (right:A)`))); + + gnode reverse = DISCH_TAC(directions[1], "Hboth"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hboth", + "Hphi", + "HP"); + reverse = EXISTS_TAC(reverse, `ra_unit (R:(A)ra)`); + reverse = EXISTS_TAC(reverse, `resource:A`); + gnode_list reverse1 = CONJ_TAC(reverse); + ACCEPT_TAC( + reverse1[0], + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `resource:A`), + ra_unit_l))); + gnode_list reverse2 = CONJ_TAC(reverse1[1]); + gnode_list fact_parts = CONJ_TAC(reverse2[0]); + ACCEPT_TAC(fact_parts[0], assume_rule(`phi:bool`)); + ACCEPT_TAC( + fact_parts[1], + refl_rule(`ra_unit (R:(A)ra)`)); + ACCEPT_TAC( + reverse2[1], + assume_rule(`(P:A->bool) (resource:A)`)); + return gnode_prove(root); +} + +PROOF thm r_fact_sep_l_eq = + prove_r_fact_sep_l(); + +PROOF static thm prove_r_fact_sep_l_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (phi:bool) (P:A->bool). + r_equiv R + (r_sep R (r_fact R phi) P) + (r_and R (r_pure R phi) P) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) + (r_fact R (phi:bool)) + (P:A->bool)`, + `r_and (R:(A)ra) + (r_pure R (phi:bool)) + (P:A->bool)`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `phi:bool`, `P:A->bool`), + r_fact_sep_l_eq))); + return gnode_prove(root); +} + +PROOF thm r_fact_sep_l = + prove_r_fact_sep_l_equiv(); + +PROOF static thm prove_r_fact_sep_r(void) { + term R = `R:(A)ra`; + term phi = `phi:bool`; + term P = `P:A->bool`; + thm commute = ispecl_rule( + TERM_LIST( + R, + P, + `r_fact (R:(A)ra) (phi:bool)`), + r_sep_comm_eq); + thm bridge = ispecl_rule( + TERM_LIST(R, phi, P), + r_fact_sep_l_eq); + thm result = trans_rule(commute, bridge); + result = gen_rule(P, result); + result = gen_rule(phi, result); + return gen_rule(R, result); +} + +PROOF thm r_fact_sep_r_eq = + prove_r_fact_sep_r(); + +PROOF static thm prove_r_fact_sep_r_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (phi:bool) (P:A->bool). + r_equiv R + (r_sep R P (r_fact R phi)) + (r_and R (r_pure R phi) P) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep (R:(A)ra) + (P:A->bool) + (r_fact R (phi:bool))`, + `r_and (R:(A)ra) + (r_pure R (phi:bool)) + (P:A->bool)`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `phi:bool`, `P:A->bool`), + r_fact_sep_r_eq))); + return gnode_prove(root); +} + +PROOF thm r_fact_sep_r = + prove_r_fact_sep_r_equiv(); + +PROOF static thm prove_r_fact_intro(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool) + (P:A->bool) + (Q:A->bool). + phi ==> + r_entails R P Q ==> + r_entails R P (r_sep R (r_fact R phi) Q) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "phi"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hphi"); + body = DISCH_TAC(body, "Hentails"); + + thm pure_intro = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `phi:bool`, + `P:A->bool`, + `Q:A->bool`), + r_pure_and_intro), + assume_rule(`phi:bool`)), + assume_rule(`r_entails (R:(A)ra) (P:A->bool) (Q:A->bool)`)); + thm fact_sep = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `phi:bool`, + `Q:A->bool`), + r_fact_sep_l_eq); + thm target_eq = beta_rule(ap_term_rule( + `\target:A->bool. + r_entails (R:(A)ra) (P:A->bool) target`, + gsym_rule(fact_sep))); + ACCEPT_TAC(body, eq_mp_rule(target_eq, pure_intro)); + return gnode_prove(root); +} + +PROOF thm r_fact_intro = + prove_r_fact_intro(); + +PROOF static thm prove_r_fact_elim(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool) + (P:A->bool) + (Q:A->bool). + (phi ==> r_entails R P Q) ==> + r_entails R (r_sep R (r_fact R phi) P) Q + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = GEN_TAC(root, "R"); + body = GEN_TAC(body, "phi"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = DISCH_TAC(body, "Hconditional"); + + thm pure_elim = mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `phi:bool`, + `P:A->bool`, + `Q:A->bool`), + r_pure_and_elim), + assume_rule(` + (phi:bool) ==> + r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) + `)); + thm fact_sep = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `phi:bool`, + `P:A->bool`), + r_fact_sep_l_eq); + thm source_eq = beta_rule(ap_term_rule( + `\source:A->bool. + r_entails (R:(A)ra) source (Q:A->bool)`, + fact_sep)); + ACCEPT_TAC(body, eq_mp_rule(gsym_rule(source_eq), pure_elim)); + return gnode_prove(root); +} + +PROOF thm r_fact_elim = + prove_r_fact_elim(); + +PROOF static thm prove_r_fact_dup(void) { + term goal_tm = ` + forall + (R:(A)ra) + (phi:bool). + r_entails + R + (r_fact R phi) + (r_sep R (r_fact R phi) (r_fact R phi)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_fact_def, + r_sep_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "phi"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Hfact"); + body = ASMP_CONJ_TAC( + body, + "Hfact", + "Hphi", + "Hresource_unit"); + body = EXISTS_TAC(body, `ra_unit (R:(A)ra)`); + body = EXISTS_TAC(body, `ra_unit (R:(A)ra)`); + gnode_list result1 = CONJ_TAC(body); + ACCEPT_TAC( + result1[0], + trans_rule( + assume_rule(` + (resource:A) == ra_unit (R:(A)ra) + `), + gsym_rule(ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `ra_unit (R:(A)ra)`), + ra_unit_l)))); + gnode_list result2 = CONJ_TAC(result1[1]); + gnode_list left_fact = CONJ_TAC(result2[0]); + ACCEPT_TAC(left_fact[0], assume_rule(`phi:bool`)); + ACCEPT_TAC( + left_fact[1], + refl_rule(`ra_unit (R:(A)ra)`)); + gnode_list right_fact = CONJ_TAC(result2[1]); + ACCEPT_TAC(right_fact[0], assume_rule(`phi:bool`)); + ACCEPT_TAC( + right_fact[1], + refl_rule(`ra_unit (R:(A)ra)`)); + return gnode_prove(root); +} + +PROOF thm r_fact_dup = + prove_r_fact_dup(); + +PROOF static thm prove_r_own_unit(void) { + term goal_tm = ` + forall R:(A)ra. + r_own R (ra_unit R) == + r_emp R + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_own (R:(A)ra) (ra_unit R)`, + `r_emp (R:(A)ra)`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + CONV_TAC( + body, + rewrite_conv(THM_LIST( + r_own_def, + r_emp_def))); + return gnode_prove(root); +} + +PROOF thm r_own_unit_eq = + prove_r_own_unit(); + +PROOF static thm prove_r_own_unit_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall R:(A)ra. + r_equiv R (r_own R (ra_unit R)) (r_emp R) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_own (R:(A)ra) (ra_unit R)`, + `r_emp (R:(A)ra)`), + r_equiv_of_eq), + spec_rule(`R:(A)ra`, r_own_unit_eq))); + return gnode_prove(root); +} + +PROOF thm r_own_unit = + prove_r_own_unit_equiv(); + +PROOF static thm prove_r_own_op(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A) (b:A). + r_own R (ra_op R a b) == + r_sep R (r_own R a) (r_own R b) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + thm funext = ispecl_rule( + TERM_LIST( + `r_own + (R:(A)ra) + (ra_op R (a:A) (b:A))`, + `r_sep + (R:(A)ra) + (r_own R (a:A)) + (r_own R (b:A))`), + get_theorem_by_name("FUN_EQ_THM")); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(funext))); + body = GEN_TAC(body, "resource"); + body = CONV_TAC( + body, + pure_rewrite_conv(THM_LIST( + r_own_def, + r_sep_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Howned"); + forward = EXISTS_TAC(forward, `a:A`); + forward = EXISTS_TAC(forward, `b:A`); + gnode_list forward1 = CONJ_TAC(forward); + ACCEPT_TAC( + forward1[0], + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (a:A) (b:A) + `)); + gnode_list forward2 = CONJ_TAC(forward1[1]); + ACCEPT_TAC(forward2[0], refl_rule(`a:A`)); + ACCEPT_TAC(forward2[1], refl_rule(`b:A`)); + + gnode reverse = DISCH_TAC(directions[1], "Hsep"); + reverse = ASMP_EXISTS_TAC(reverse, "Hsep", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hsep", "right"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hsep", + "Hsplit", + "Howned_parts"); + reverse = ASMP_CONJ_TAC( + reverse, + "Howned_parts", + "Hleft", + "Hright"); + thm replace_left = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) replacement (right:A)`, + assume_rule(`(left:A) == (a:A)`))); + thm replace_right = beta_rule(ap_term_rule( + `\replacement:A. + ra_op (R:(A)ra) (a:A) replacement`, + assume_rule(`(right:A) == (b:A)`))); + thm result = trans_rule( + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `), + trans_rule(replace_left, replace_right)); + ACCEPT_TAC(reverse, result); + return gnode_prove(root); +} + +PROOF thm r_own_op_eq = + prove_r_own_op(); + +PROOF static thm prove_r_own_op_equiv(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (a:A) (b:A). + r_equiv R + (r_own R (ra_op R a b)) + (r_sep R (r_own R a) (r_own R b)) + `); + gnode body = AUTO_INTROS_TAC(root); + ACCEPT_TAC( + body, + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_own (R:(A)ra) (ra_op R (a:A) (b:A))`, + `r_sep (R:(A)ra) + (r_own R (a:A)) + (r_own R (b:A))`), + r_equiv_of_eq), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`, `b:A`), + r_own_op_eq))); + return gnode_prove(root); +} + +PROOF thm r_own_op = + prove_r_own_op_equiv(); + +PROOF static thm prove_r_own_valid(void) { + term goal_tm = ` + forall (R:(A)ra) (a:A). + r_entails + R + (r_own R a) + (r_sep + R + (r_fact R (ra_valid R a)) + (r_own R a)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_own_def, + r_sep_def, + r_fact_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "a"); + body = GEN_TAC(body, "resource"); + body = DISCH_TAC(body, "Hvalid"); + body = DISCH_TAC(body, "Howned"); + thm validity_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + assume_rule(`(resource:A) == (a:A)`)); + thm valid_a = eq_mp_rule( + validity_eq, + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)); + body = EXISTS_TAC(body, `ra_unit (R:(A)ra)`); + body = EXISTS_TAC(body, `a:A`); + gnode_list result1 = CONJ_TAC(body); + ACCEPT_TAC( + result1[0], + trans_rule( + assume_rule(`(resource:A) == (a:A)`), + gsym_rule(ispecl_rule( + TERM_LIST(`R:(A)ra`, `a:A`), + ra_unit_l)))); + gnode_list result2 = CONJ_TAC(result1[1]); + gnode_list fact = CONJ_TAC(result2[0]); + ACCEPT_TAC(fact[0], valid_a); + ACCEPT_TAC(fact[1], refl_rule(`ra_unit (R:(A)ra)`)); + ACCEPT_TAC(result2[1], refl_rule(`a:A`)); + return gnode_prove(root); +} + +PROOF thm r_own_valid = + prove_r_own_valid(); + +PROOF static thm prove_r_impl_adjunction(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails R (r_and R P Q) S <=> + r_entails R P (r_impl R Q S) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_and_def, + r_impl_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "S"); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hleft"); + forward = GEN_TAC(forward, "resource"); + forward = DISCH_TAC(forward, "Hvalid"); + forward = DISCH_TAC(forward, "HP"); + forward = DISCH_TAC(forward, "HQ"); + thm both = conj_rule( + assume_rule(`(P:A->bool) (resource:A)`), + assume_rule(`(Q:A->bool) (resource:A)`)); + thm forward_result = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + ((P:A->bool) resource && + (Q:A->bool) resource) ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + both); + ACCEPT_TAC(forward, forward_result); + + gnode reverse = DISCH_TAC(directions[1], "Hright"); + reverse = GEN_TAC(reverse, "resource"); + reverse = DISCH_TAC(reverse, "Hvalid"); + reverse = DISCH_TAC(reverse, "Hboth"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hboth", + "HP", + "HQ"); + thm implication = mp_rule( + mp_rule( + spec_rule( + `resource:A`, + assume_rule(` + forall resource:A. + ra_valid (R:(A)ra) resource ==> + (P:A->bool) resource ==> + (Q:A->bool) resource ==> + (S:A->bool) resource + `)), + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)), + assume_rule(`(P:A->bool) (resource:A)`)); + ACCEPT_TAC( + reverse, + mp_rule( + implication, + assume_rule(`(Q:A->bool) (resource:A)`))); + return gnode_prove(root); +} + +PROOF thm r_impl_adjunction = + prove_r_impl_adjunction(); + +PROOF static thm prove_r_wand_adjunction(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails R (r_sep R P Q) S <=> + r_entails R P (r_wand R Q S) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST( + r_entails_def, + r_sep_def, + r_wand_def))); + body = GEN_TAC(body, "R"); + body = GEN_TAC(body, "P"); + body = GEN_TAC(body, "Q"); + body = GEN_TAC(body, "S"); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hsep_entails"); + forward = GEN_TAC(forward, "resource"); + forward = DISCH_TAC(forward, "Hvalid_resource"); + forward = DISCH_TAC(forward, "HP"); + forward = GEN_TAC(forward, "frame"); + forward = DISCH_TAC(forward, "Hvalid_total"); + forward = DISCH_TAC(forward, "HQ"); + + term inner_existence = ` + exists right:A. + ra_op (R:(A)ra) (resource:A) (frame:A) == + ra_op R resource right && + (P:A->bool) resource && + (Q:A->bool) right + `; + thm split_body = conj_rule( + refl_rule(` + ra_op (R:(A)ra) (resource:A) (frame:A) + `), + conj_rule( + assume_rule(`(P:A->bool) (resource:A)`), + assume_rule(`(Q:A->bool) (frame:A)`))); + thm inner_witness = exists_rule( + inner_existence, + `frame:A`, + split_body); + term outer_existence = ` + exists left right:A. + ra_op (R:(A)ra) (resource:A) (frame:A) == + ra_op R left right && + (P:A->bool) left && + (Q:A->bool) right + `; + thm sep_witness = exists_rule( + outer_existence, + `resource:A`, + inner_witness); + thm forward_result = mp_rule( + mp_rule( + spec_rule( + `ra_op + (R:(A)ra) + (resource:A) + (frame:A)`, + assume_rule(` + forall total:A. + ra_valid (R:(A)ra) total ==> + (exists left right:A. + total == ra_op R left right && + (P:A->bool) left && + (Q:A->bool) right) ==> + (S:A->bool) total + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (resource:A) (frame:A)) + `)), + sep_witness); + ACCEPT_TAC(forward, forward_result); + + gnode reverse = DISCH_TAC(directions[1], "Hwand_entails"); + reverse = GEN_TAC(reverse, "resource"); + reverse = DISCH_TAC(reverse, "Hvalid_resource"); + reverse = DISCH_TAC(reverse, "Hsep"); + reverse = ASMP_EXISTS_TAC(reverse, "Hsep", "left"); + reverse = ASMP_EXISTS_TAC(reverse, "Hsep", "right"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hsep", + "Hsplit", + "Hpreds"); + reverse = ASMP_CONJ_TAC( + reverse, + "Hpreds", + "HP", + "HQ"); + + thm validity_eq = ap_term_rule( + `ra_valid (R:(A)ra):A->bool`, + assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `)); + thm valid_pair = eq_mp_rule( + validity_eq, + assume_rule(`ra_valid (R:(A)ra) (resource:A)`)); + thm valid_left = conjunct1_rule(mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `left:A`, + `right:A`), + ra_valid_op), + valid_pair)); + thm wand_left = mp_rule( + mp_rule( + spec_rule( + `left:A`, + assume_rule(` + forall owned:A. + ra_valid (R:(A)ra) owned ==> + (P:A->bool) owned ==> + forall frame:A. + ra_valid R (ra_op R owned frame) ==> + (Q:A->bool) frame ==> + (S:A->bool) (ra_op R owned frame) + `)), + valid_left), + assume_rule(`(P:A->bool) (left:A)`)); + thm s_pair = mp_rule( + mp_rule( + spec_rule(`right:A`, wand_left), + valid_pair), + assume_rule(`(Q:A->bool) (right:A)`)); + thm predicate_eq = ap_term_rule( + `S:A->bool`, + gsym_rule(assume_rule(` + (resource:A) == + ra_op (R:(A)ra) (left:A) (right:A) + `))); + ACCEPT_TAC( + reverse, + eq_mp_rule(predicate_eq, s_pair)); + return gnode_prove(root); +} + +PROOF thm r_wand_adjunction = + prove_r_wand_adjunction(); + +PROOF static thm prove_r_wand_elim(void) { + gnode root = gnode_new_with_ccl(` + forall (R:(A)ra) (P:A->bool) (Q:A->bool). + r_entails R (r_sep R (r_wand R P Q) P) Q + `); + gnode body = AUTO_INTROS_TAC(root); + thm adjunction = ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_wand (R:(A)ra) (P:A->bool) (Q:A->bool)`, + `P:A->bool`, + `Q:A->bool`), + r_wand_adjunction); + ACCEPT_TAC( + body, + eq_mp_rule( + gsym_rule(adjunction), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_wand (R:(A)ra) (P:A->bool) (Q:A->bool)`), + r_entails_refl))); + return gnode_prove(root); +} + +PROOF thm r_wand_elim = + prove_r_wand_elim(); + +PROOF static thm prove_r_wand_mono(void) { + gnode root = gnode_new_with_ccl(` + forall + (R:(A)ra) + (P2:A->bool) + (P:A->bool) + (Q:A->bool) + (Q2:A->bool). + r_entails R P2 P ==> + r_entails R Q Q2 ==> + r_entails R (r_wand R P Q) (r_wand R P2 Q2) + `); + gnode body = CONV_TAC( + root, + pure_rewrite_conv(THM_LIST(r_entails_def, r_wand_def))); + body = AUTO_INTROS_TAC(body); + thm valid_frame = conjunct2_rule(mp_rule( + ispecl_rule( + TERM_LIST(`R:(A)ra`, `resource:A`, `frame:A`), + ra_valid_op), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (resource:A) (frame:A)) + `))); + thm p_frame = mp_rule( + mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall owned:A. + ra_valid (R:(A)ra) owned ==> + (P2:A->bool) owned ==> + (P:A->bool) owned + `)), + valid_frame), + assume_rule(`(P2:A->bool) (frame:A)`)); + thm q_total = mp_rule( + mp_rule( + spec_rule( + `frame:A`, + assume_rule(` + forall hidden:A. + ra_valid + (R:(A)ra) + (ra_op R (resource:A) hidden) ==> + (P:A->bool) hidden ==> + (Q:A->bool) (ra_op R resource hidden) + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (resource:A) (frame:A)) + `)), + p_frame); + thm q2_total = mp_rule( + mp_rule( + spec_rule( + `ra_op (R:(A)ra) (resource:A) (frame:A)`, + assume_rule(` + forall owned:A. + ra_valid (R:(A)ra) owned ==> + (Q:A->bool) owned ==> + (Q2:A->bool) owned + `)), + assume_rule(` + ra_valid + (R:(A)ra) + (ra_op R (resource:A) (frame:A)) + `)), + q_total); + ACCEPT_TAC(body, q2_total); + return gnode_prove(root); +} + +PROOF thm r_wand_mono = + prove_r_wand_mono(); + +PROOF static thm prove_r_sep_and_forward_r(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails + R + (r_sep R P (r_and R Q S)) + (r_and + R + (r_sep R P Q) + (r_sep R P S)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm left_projection = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `P:A->bool`, + `r_and + (R:(A)ra) + (Q:A->bool) + (S:A->bool)`, + `Q:A->bool`), + r_sep_mono), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `S:A->bool`), + r_and_elim_l)); + thm right_projection = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `P:A->bool`, + `P:A->bool`, + `r_and + (R:(A)ra) + (Q:A->bool) + (S:A->bool)`, + `S:A->bool`), + r_sep_mono), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `S:A->bool`), + r_and_elim_r)); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep + (R:(A)ra) + (P:A->bool) + (r_and R (Q:A->bool) (S:A->bool))`, + `r_sep R (P:A->bool) (Q:A->bool)`, + `r_sep R (P:A->bool) (S:A->bool)`), + r_and_intro), + left_projection), + right_projection); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_sep_and_forward_r = + prove_r_sep_and_forward_r(); + +PROOF static thm prove_r_sep_and_forward_l(void) { + term goal_tm = ` + forall + (R:(A)ra) + (P:A->bool) + (Q:A->bool) + (S:A->bool). + r_entails + R + (r_sep R (r_and R Q S) P) + (r_and + R + (r_sep R Q P) + (r_sep R S P)) + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + + thm left_projection = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_and + (R:(A)ra) + (Q:A->bool) + (S:A->bool)`, + `Q:A->bool`, + `P:A->bool`, + `P:A->bool`), + r_sep_mono), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `S:A->bool`), + r_and_elim_l)), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)); + thm right_projection = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_and + (R:(A)ra) + (Q:A->bool) + (S:A->bool)`, + `S:A->bool`, + `P:A->bool`, + `P:A->bool`), + r_sep_mono), + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `Q:A->bool`, + `S:A->bool`), + r_and_elim_r)), + ispecl_rule( + TERM_LIST(`R:(A)ra`, `P:A->bool`), + r_entails_refl)); + thm result = mp_rule( + mp_rule( + ispecl_rule( + TERM_LIST( + `R:(A)ra`, + `r_sep + (R:(A)ra) + (r_and R (Q:A->bool) (S:A->bool)) + (P:A->bool)`, + `r_sep R (Q:A->bool) (P:A->bool)`, + `r_sep R (S:A->bool) (P:A->bool)`), + r_and_intro), + left_projection), + right_projection); + ACCEPT_TAC(body, result); + return gnode_prove(root); +} + +PROOF thm r_sep_and_forward_l = + prove_r_sep_and_forward_l(); + +PROOF static int audit_resource_prop(void) { + thm_list public_theorems = THM_LIST( + r_entails_def, + r_equiv_def, + r_emp_def, + r_sep_def, + r_own_def, + r_top_def, + r_bottom_def, + r_and_def, + r_or_def, + r_impl_def, + r_exists_def, + r_forall_def, + r_pure_def, + r_fact_def, + r_wand_def, + r_entails_refl, + r_entails_trans, + r_entails_pointwise, + r_equiv_pointwise, + r_equiv_intro, + r_equiv_refl, + r_equiv_sym, + r_equiv_trans, + r_top_intro, + r_bottom_elim, + r_sep_assoc, + r_sep_comm, + r_sep_emp_l, + r_sep_emp_r, + r_sep_mono, + r_sep_frame_l, + r_sep_frame_r, + r_sep_exists_l, + r_sep_exists_r, + r_and_intro, + r_and_elim_l, + r_and_elim_r, + r_or_intro_l, + r_or_intro_r, + r_or_elim, + r_exists_intro, + r_exists_elim, + r_exists_mono, + r_forall_intro, + r_forall_elim, + r_pure_and_intro, + r_pure_and_elim, + r_fact_as_pure_and_emp, + r_fact_true, + r_fact_false, + r_fact_sep_l, + r_fact_sep_r, + r_fact_intro, + r_fact_elim, + r_fact_dup, + r_own_unit, + r_own_op, + r_own_valid, + r_impl_adjunction, + r_wand_adjunction, + r_wand_elim, + r_wand_mono, + r_sep_and_forward_r, + r_sep_and_forward_l); + + for (size_t i = 0; i < vector_size(public_theorems); ++i) { + ENSURE_COND( + !IS_NULL(public_theorems[i]), + "resource proposition theorem %zu is null", + i); + ENSURE_COND( + vector_size(hyp(public_theorems[i])) == 0, + "resource proposition theorem %zu has hypotheses", + i); + } + ENSURE_COND( + vector_size(get_all_axioms()) == + RESOURCE_PROP_AXIOMS_BEFORE, + "resource proposition theory introduced axioms"); + return 0; +err: + ERR_FUN_PUTS("audit_resource_prop"); + return -1; +} + +PROOF static int _RESOURCE_PROP_AUDIT = + audit_resource_prop(); diff --git a/theory/logic/resource_prop.h b/theory/logic/resource_prop.h new file mode 100644 index 0000000000000000000000000000000000000000..957099c2821ad890624551715ffd7bc55cf5f824 --- /dev/null +++ b/theory/logic/resource_prop.h @@ -0,0 +1,747 @@ +/** + * @file resource_prop.h + * @brief Linear BI assertions over an arbitrary resource algebra. + * + * For `R:(A)ra`, an assertion is a predicate `A -> bool`. Entailment and + * logical equivalence observe only resources that are valid in `R`: + * + * ```text + * r_entails R P Q <=> forall a. ra_valid R a ==> P a ==> Q a + * r_equiv R P Q <=> r_entails R P Q && r_entails R Q P. + * ``` + * + * This interface deliberately keeps two HOL-proposition embeddings distinct: + * + * - `r_pure R phi a <=> phi` is resource-independent. It is useful in + * additive conjunctions and for carrying non-spatial side conditions. + * - `r_fact R phi a <=> phi && a == ra_unit R` is an exact-unit assertion. + * Use it when a HOL fact is a separating conjunct, including validity and + * predicate-update witnesses. + * + * Public assertion-algebra laws are stated with validity-sensitive `r_equiv`. + * Raw assertion-function equalities are implementation details declared only + * by `resource_prop_internal.h`. + */ + +#pragma once + +#include "proof/theory/logic/ra.h" + +/* ------------------------------------------------------------------------- */ +/* Observation relations and assertion constructors */ +/* ------------------------------------------------------------------------- */ + +/** + * HOL conclusion: + * + * ```text + * r_entails (R:(A)ra) (P:A->bool) (Q:A->bool) <=> forall resource:A. ra_valid + * R resource ==> P resource ==> Q resource + * ``` + * + * `P` 蕴含 `Q`，正是指每个有效且满足 `P` 的资源也满足 `Q`。 + */ +PROOF extern thm r_entails_def; +/** + * HOL conclusion: + * + * ```text + * r_equiv (R:(A)ra) (P:A->bool) (Q:A->bool) <=> r_entails R P Q && r_entails R + * Q P + * ``` + * + * 资源断言等价定义为两个方向的有效资源蕴含，而非谓词的原始 HOL 相等。 + */ +PROOF extern thm r_equiv_def; + +/** + * HOL conclusion: + * + * ```text + * r_emp (R:(A)ra) (resource:A) <=> resource == ra_unit R + * ``` + * + * `r_emp` 精确描述 RA 单位元：当前资源必须等于 `ra_unit R`。 + */ +PROOF extern thm r_emp_def; +/** + * HOL conclusion: + * + * ```text + * r_sep (R:(A)ra) (P:A->bool) (Q:A->bool) (resource:A) <=> exists left + * right:A. resource == ra_op R left right && P left && Q right + * ``` + * + * 分离合取成立，当且仅当资源可拆为满足 `P`、`Q` 的两部分之 RA 乘积。 + */ +PROOF extern thm r_sep_def; +/** + * HOL conclusion: + * + * ```text + * r_wand (R:(A)ra) (P:A->bool) (Q:A->bool) (resource:A) <=> forall frame:A. + * ra_valid R (ra_op R resource frame) ==> P frame ==> Q (ra_op R resource + * frame) + * ``` + * + * 魔杖要求：任意与当前资源组合后仍有效且满足 `P` 的框架，都使组合资源满足 `Q`。 + */ +PROOF extern thm r_wand_def; +/** + * HOL conclusion: + * + * ```text + * r_own (R:(A)ra) (owned:A) (resource:A) <=> resource == owned + * ``` + * + * `r_own R owned` 只在当前资源精确等于 `owned` 时成立。 + */ +PROOF extern thm r_own_def; +/** + * HOL conclusion: + * + * ```text + * r_top (R:(A)ra) (resource:A) <=> T + * ``` + * + * `r_top` 对每个资源都成立。 + */ +PROOF extern thm r_top_def; +/** + * HOL conclusion: + * + * ```text + * r_bottom (R:(A)ra) (resource:A) <=> F + * ``` + * + * `r_bottom` 对任何资源都不成立。 + */ +PROOF extern thm r_bottom_def; +/** + * HOL conclusion: + * + * ```text + * r_and (R:(A)ra) (P:A->bool) (Q:A->bool) (resource:A) <=> P resource && Q + * resource + * ``` + * + * 加法合取要求同一份当前资源同时满足 `P` 和 `Q`。 + */ +PROOF extern thm r_and_def; +/** + * HOL conclusion: + * + * ```text + * r_or (R:(A)ra) (P:A->bool) (Q:A->bool) (resource:A) <=> P resource || Q + * resource + * ``` + * + * 加法析取要求同一份当前资源至少满足 `P`、`Q` 之一。 + */ +PROOF extern thm r_or_def; +/** + * HOL conclusion: + * + * ```text + * r_impl (R:(A)ra) (P:A->bool) (Q:A->bool) (resource:A) <=> P resource ==> Q + * resource + * ``` + * + * 加法蕴含在当前资源上把 `P resource` 蕴含 `Q resource`。 + */ +PROOF extern thm r_impl_def; +/** + * HOL conclusion: + * + * ```text + * r_exists (R:(A)ra) (P:B->A->bool) (resource:A) <=> exists witness:B. P + * witness resource + * ``` + * + * 资源存在量词在同一资源上选择一个见证，使对应断言成立。 + */ +PROOF extern thm r_exists_def; +/** + * HOL conclusion: + * + * ```text + * r_forall (R:(A)ra) (P:B->A->bool) (resource:A) <=> forall witness:B. P + * witness resource + * ``` + * + * 资源全称量词要求同一资源满足每个见证对应的断言。 + */ +PROOF extern thm r_forall_def; + +/** + * HOL conclusion: + * + * ```text + * r_pure (R:(A)ra) (phi:bool) (resource:A) <=> phi + * ``` + * + * `r_pure R phi` 仅取决于 `phi` 的真假，对当前资源没有任何限制。 + */ +PROOF extern thm r_pure_def; + +/** + * HOL conclusion: + * + * ```text + * r_fact (R:(A)ra) (phi:bool) (resource:A) <=> phi && resource == ra_unit R + * ``` + * + * `r_fact R phi` 同时要求 `phi` 为真且当前资源精确为 RA 单位元，因而不同于 `r_pure`。 + */ +PROOF extern thm r_fact_def; + +/* ------------------------------------------------------------------------- */ +/* Entailment, equivalence, and connective laws */ +/* ------------------------------------------------------------------------- */ + +/* Entailment and validity-sensitive equivalence. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_entails R P P + * ``` + * + * 每个资源断言都蕴含自身。 + */ +PROOF extern thm r_entails_refl; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R P Q ==> + * r_entails R Q S ==> r_entails R P S + * ``` + * + * 资源蕴含可传递组合：`P ⊢ Q` 与 `Q ⊢ S` 推出 `P ⊢ S`。 + */ +PROOF extern thm r_entails_trans; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). (forall resource:A. P resource ==> + * Q resource) ==> r_entails R P Q + * ``` + * + * 若 `P resource` 对所有资源都推出 `Q resource`，则尤其得到有效资源上的 `P ⊢ Q`。 + */ +PROOF extern thm r_entails_pointwise; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_equiv R P Q <=> forall + * resource:A. ra_valid R resource ==> (P resource <=> Q resource) + * ``` + * + * `P` 与 `Q` 资源等价，当且仅当它们在每个有效资源上的真假一致。 + */ +PROOF extern thm r_equiv_pointwise; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R P Q ==> r_entails R Q + * P ==> r_equiv R P Q + * ``` + * + * 两个方向的资源蕴含共同引入 `r_equiv`。 + */ +PROOF extern thm r_equiv_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_equiv R P P + * ``` + * + * 每个资源断言都与自身资源等价。 + */ +PROOF extern thm r_equiv_refl; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_equiv R P Q ==> r_equiv R Q P + * ``` + * + * 交换资源等价的两端仍得到资源等价。 + */ +PROOF extern thm r_equiv_sym; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_equiv R P Q ==> + * r_equiv R Q S ==> r_equiv R P S + * ``` + * + * 资源等价可传递组合：`P ≡ Q` 与 `Q ≡ S` 推出 `P ≡ S`。 + */ +PROOF extern thm r_equiv_trans; + +/* Additive truth and falsehood. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_entails R P (r_top R) + * ``` + * + * 任意资源断言都蕴含恒真的加法断言 `r_top`。 + */ +PROOF extern thm r_top_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_entails R (r_bottom R) P + * ``` + * + * 恒假的加法断言 `r_bottom` 蕴含任意资源断言。 + */ +PROOF extern thm r_bottom_elim; + +/* Separating conjunction. Algebraic laws expose `r_equiv`, never raw + * assertion-function equality. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_equiv R (r_sep R + * (r_sep R P Q) S) (r_sep R P (r_sep R Q S)) + * ``` + * + * 分离合取的两种括号方式在有效资源上等价；结论是 `r_equiv` 而非原始相等。 + */ +PROOF extern thm r_sep_assoc; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_equiv R (r_sep R P Q) (r_sep R Q + * P) + * ``` + * + * 交换分离合取的左右断言在有效资源上等价；结论是 `r_equiv` 而非原始相等。 + */ +PROOF extern thm r_sep_comm; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_equiv R (r_sep R (r_emp R) P) P + * ``` + * + * 在 `r_equiv` 下，左侧的 `r_emp` 是分离合取单位元。 + */ +PROOF extern thm r_sep_emp_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_equiv R (r_sep R P (r_emp R)) P + * ``` + * + * 在 `r_equiv` 下，右侧的 `r_emp` 是分离合取单位元。 + */ +PROOF extern thm r_sep_emp_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (P2:A->bool) (Q:A->bool) (Q2:A->bool). + * r_entails R P P2 ==> r_entails R Q Q2 ==> r_entails R (r_sep R P Q) (r_sep R + * P2 Q2) + * ``` + * + * 两个分离分量分别按蕴含替换时，整个分离合取也保持同方向的蕴含。 + */ +PROOF extern thm r_sep_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (frame_pred:A->bool). r_entails R P + * Q ==> r_entails R (r_sep R P frame_pred) (r_sep R Q frame_pred) + * ``` + * + * `P ⊢ Q` 可在右侧保留同一框架，得到 `P ** frame ⊢ Q ** frame`。 + */ +PROOF extern thm r_sep_frame_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (frame_pred:A->bool). r_entails R P + * Q ==> r_entails R (r_sep R frame_pred P) (r_sep R frame_pred Q) + * ``` + * + * `P ⊢ Q` 可在左侧保留同一框架，得到 `frame ** P ⊢ frame ** Q`。 + */ +PROOF extern thm r_sep_frame_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:A->bool). r_equiv R (r_sep R (r_exists R + * (\x:B. P x)) Q) (r_exists R (\x:B. r_sep R (P x) Q)) + * ``` + * + * 左分量中的存在量词可穿过分离合取，见证同时作用于该左分量。 + */ +PROOF extern thm r_sep_exists_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:B->A->bool). r_equiv R (r_sep R P (r_exists + * R (\x:B. Q x))) (r_exists R (\x:B. r_sep R P (Q x))) + * ``` + * + * 右分量中的存在量词可穿过分离合取，见证同时作用于该右分量。 + */ +PROOF extern thm r_sep_exists_r; + +/* Additive connectives and quantifiers. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R (r_and R P + * Q) S <=> r_entails R P (r_impl R Q S) + * ``` + * + * 加法合取与加法蕴含满足伴随：`P && Q ⊢ S` 当且仅当 `P ⊢ Q → S`。 + */ +PROOF extern thm r_impl_adjunction; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R P Q ==> + * r_entails R P S ==> r_entails R P (r_and R Q S) + * ``` + * + * 若 `P` 分别蕴含 `Q` 和 `S`，则 `P` 蕴含二者的加法合取。 + */ +PROOF extern thm r_and_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R (r_and R P Q) P + * ``` + * + * 加法合取蕴含其左分量。 + */ +PROOF extern thm r_and_elim_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R (r_and R P Q) Q + * ``` + * + * 加法合取蕴含其右分量。 + */ +PROOF extern thm r_and_elim_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R P (r_or R P Q) + * ``` + * + * 左断言 `P` 蕴含包含它的加法析取 `P || Q`。 + */ +PROOF extern thm r_or_intro_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R Q (r_or R P Q) + * ``` + * + * 右断言 `Q` 蕴含包含它的加法析取 `P || Q`。 + */ +PROOF extern thm r_or_intro_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R P S ==> + * r_entails R Q S ==> r_entails R (r_or R P Q) S + * ``` + * + * 若析取的两个分支都蕴含 `S`，则整个加法析取蕴含 `S`。 + */ +PROOF extern thm r_or_elim; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (witness:B). r_entails R (P witness) + * (r_exists R (\bound:B. P bound)) + * ``` + * + * 任一具体见证的断言都蕴含对应的资源存在量词。 + */ +PROOF extern thm r_exists_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:A->bool). (forall witness:B. r_entails R + * (P witness) Q) ==> r_entails R (r_exists R (\bound:B. P bound)) Q + * ``` + * + * 若每个见证对应的断言都蕴含 `Q`，则资源存在量词也蕴含 `Q`。 + */ +PROOF extern thm r_exists_elim; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:B->A->bool). (forall witness:B. r_entails + * R (P witness) (Q witness)) ==> r_entails R (r_exists R (\bound:B. P bound)) + * (r_exists R (\bound:B. Q bound)) + * ``` + * + * 若每个见证下 `P` 都蕴含 `Q`，则对二者取资源存在量词后仍保持蕴含。 + */ +PROOF extern thm r_exists_mono; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:B->A->bool). (forall witness:B. r_entails R + * P (Q witness)) ==> r_entails R P (r_forall R (\bound:B. Q bound)) + * ``` + * + * 若 `P` 蕴含每个见证对应的 `Q`，则 `P` 蕴含这些断言的资源全称量词。 + */ +PROOF extern thm r_forall_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (witness:B). r_entails R (r_forall R P) (P + * witness) + * ``` + * + * 资源全称量词可实例化为任意给定见证对应的断言。 + */ +PROOF extern thm r_forall_elim; + +/* Magic wand. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R (r_sep R P + * Q) S <=> r_entails R P (r_wand R Q S) + * ``` + * + * 分离合取与魔杖满足伴随：`P ** Q ⊢ S` 当且仅当 `P ⊢ Q -* S`。 + */ +PROOF extern thm r_wand_adjunction; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_entails R (r_sep R (r_wand R P + * Q) P) Q + * ``` + * + * 将 `P -* Q` 与 `P` 分离合取即可消去魔杖并推出 `Q`。 + */ +PROOF extern thm r_wand_elim; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P2:A->bool) (P:A->bool) (Q:A->bool) (Q2:A->bool). + * r_entails R P2 P ==> r_entails R Q Q2 ==> r_entails R (r_wand R P Q) (r_wand + * R P2 Q2) + * ``` + * + * 魔杖对前件逆变、对后件协变：`P2 ⊢ P` 且 `Q ⊢ Q2` 推出 `(P -* Q) ⊢ (P2 -* Q2)`。 + */ +PROOF extern thm r_wand_mono; + +/* Resource-independent pure propositions, combined additively with `r_and`. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool) (Q:A->bool). phi ==> r_entails R P Q + * ==> r_entails R P (r_and R (r_pure R phi) Q) + * ``` + * + * 当 `phi` 为真且 `P ⊢ Q` 时，可在结论中加入资源无关的 `pure(phi)` 加法合取。 + */ +PROOF extern thm r_pure_and_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool) (Q:A->bool). (phi ==> r_entails R P + * Q) ==> r_entails R (r_and R (r_pure R phi) P) Q + * ``` + * + * 若假设 `phi` 后可由 `P` 推出 `Q`，则可从 `pure(phi) && P` 直接推出 `Q`。 + */ +PROOF extern thm r_pure_and_elim; + +/* Exact-unit facts. The normalization laws below are `r_equiv` statements. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool). r_equiv R (r_fact R phi) (r_and R (r_pure R + * phi) (r_emp R)) + * ``` + * + * 在 `r_equiv` 下，精确单位元事实 `fact(phi)` 等于 `pure(phi)` 与 `emp` 的加法合取。 + */ +PROOF extern thm r_fact_as_pure_and_emp; +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_equiv R (r_fact R T) (r_emp R) + * ``` + * + * 真命题的精确单位元事实在 `r_equiv` 下就是 `emp`。 + */ +PROOF extern thm r_fact_true; +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_equiv R (r_fact R F) (r_bottom R) + * ``` + * + * 假命题的精确单位元事实在 `r_equiv` 下就是 `r_bottom`。 + */ +PROOF extern thm r_fact_false; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool). r_equiv R (r_sep R (r_fact R phi) + * P) (r_and R (r_pure R phi) P) + * ``` + * + * 左侧精确事实与 `P` 分离合取，等价于资源无关的 `pure(phi)` 与 `P` 加法合取。 + */ +PROOF extern thm r_fact_sep_l; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool). r_equiv R (r_sep R P (r_fact R + * phi)) (r_and R (r_pure R phi) P) + * ``` + * + * 右侧精确事实与 `P` 分离合取，等价于资源无关的 `pure(phi)` 与 `P` 加法合取。 + */ +PROOF extern thm r_fact_sep_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool) (Q:A->bool). phi ==> r_entails R P Q + * ==> r_entails R P (r_sep R (r_fact R phi) Q) + * ``` + * + * 当 `phi` 为真且 `P ⊢ Q` 时，可把精确单位元事实 `fact(phi)` 分离加入结论。 + */ +PROOF extern thm r_fact_intro; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool) (Q:A->bool). (phi ==> r_entails R P + * Q) ==> r_entails R (r_sep R (r_fact R phi) P) Q + * ``` + * + * 若在 `phi` 为真时 `P ⊢ Q`，则可消去前件中的 `fact(phi)` 并推出 `Q`。 + */ +PROOF extern thm r_fact_elim; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool). r_entails R (r_fact R phi) (r_sep R (r_fact R + * phi) (r_fact R phi)) + * ``` + * + * 精确单位元事实可复制为两个相同事实的分离合取。 + */ +PROOF extern thm r_fact_dup; + +/* Exact ownership. `r_own_valid` returns validity as a spatial `r_fact`. */ +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_equiv R (r_own R (ra_unit R)) (r_emp R) + * ``` + * + * RA 单位元的精确所有权在 `r_equiv` 下等价于 `r_emp`。 + */ +PROOF extern thm r_own_unit; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A) (b:A). r_equiv R (r_own R (ra_op R a b)) (r_sep R + * (r_own R a) (r_own R b)) + * ``` + * + * RA 乘积 `a ⋅ b` 的精确所有权等价于 `a` 与 `b` 的所有权之分离合取。 + */ +PROOF extern thm r_own_op; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A). r_entails R (r_own R a) (r_sep R (r_fact R (ra_valid + * R a)) (r_own R a)) + * ``` + * + * 从 `a` 的精确所有权可分离导出 exact-unit 的 `ra_valid R a` fact，同时保留原所有权。 + */ +PROOF extern thm r_own_valid; + +/* Sound one-way distribution of `r_sep` through additive conjunction. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R (r_sep R P + * (r_and R Q S)) (r_and R (r_sep R P Q) (r_sep R P S)) + * ``` + * + * `P ** (Q && S)` 单向蕴含 `(P ** Q) && (P ** S)`，把同一左分量投影到两个加法分支。 + */ +PROOF extern thm r_sep_and_forward_r; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_entails R (r_sep R + * (r_and R Q S) P) (r_and R (r_sep R Q P) (r_sep R S P)) + * ``` + * + * `(Q && S) ** P` 单向蕴含 `(Q ** P) && (S ** P)`，把同一右分量投影到两个加法分支。 + */ +PROOF extern thm r_sep_and_forward_l; diff --git a/theory/logic/resource_prop_internal.h b/theory/logic/resource_prop_internal.h new file mode 100644 index 0000000000000000000000000000000000000000..2f4ea057f0f120f36bed0dbf26c127852b903799 --- /dev/null +++ b/theory/logic/resource_prop_internal.h @@ -0,0 +1,170 @@ +/** + * @file resource_prop_internal.h + * @brief Implementation-only theorem shapes for the resource logic. + * + * Most declarations below are raw assertion-function equalities used for + * rewriting inside logic implementations and adapters. Client proofs should + * include `resource_prop.h` and use its validity-sensitive `r_equiv` laws. + * This header is not a stable proof API and must not be re-exported by an + * umbrella client header. + */ + +#pragma once + +#include "proof/theory/logic/resource_prop.h" + +/* Raw equality normalizations for separating conjunction. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool). r_sep R P Q == r_sep R Q P + * ``` + * + * 交换分离合取两端得到相同的断言函数；这里是原始 HOL 相等而非 `r_equiv`。 + */ +PROOF extern thm r_sep_comm_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_sep R (r_emp R) P == P + * ``` + * + * 左侧加入 `r_emp` 后的分离合取与原断言函数在 HOL 中严格相等。 + */ +PROOF extern thm r_sep_emp_l_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool). r_sep R P (r_emp R) == P + * ``` + * + * 右侧加入 `r_emp` 后的分离合取与原断言函数在 HOL 中严格相等。 + */ +PROOF extern thm r_sep_emp_r_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:A->bool) (S:A->bool). r_sep R (r_sep R P Q) + * S == r_sep R P (r_sep R Q S) + * ``` + * + * 分离合取的两种括号方式给出严格相同的 HOL 断言函数。 + */ +PROOF extern thm r_sep_assoc_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:A->bool). r_sep R (r_exists R (\x:B. P + * x)) Q == r_exists R (\witness:B. r_sep R (P witness) Q) + * ``` + * + * 左分量上的存在量词可移到分离合取外，且两侧断言函数在 HOL 中严格相等。 + */ +PROOF extern thm r_sep_exists_l_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:A->bool) (Q:B->A->bool). r_sep R P (r_exists R (\x:B. Q + * x)) == r_exists R (\witness:B. r_sep R P (Q witness)) + * ``` + * + * 右分量上的存在量词可移到分离合取外，且两侧断言函数在 HOL 中严格相等。 + */ +PROOF extern thm r_sep_exists_r_eq; + +/* Adapter-only continuation schema derived from public `r_forall_elim`. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (P:B->A->bool) (Q:A->bool) (witness:B). r_entails R (P + * witness) Q ==> r_entails R (r_forall R (\x:B. P x)) Q + * ``` + * + * 若某个实例 `P(witness)` 蕴含 `Q`，则更强的全称断言也蕴含 `Q`。 + */ +PROOF extern thm r_forall_elim_cont; + +/* Raw equality normalizations for exact-unit facts. */ +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool). r_fact R phi == r_and R (r_pure R phi) (r_emp + * R) + * ``` + * + * `fact(phi)` 与 `pure(phi) && emp` 是严格相同的 HOL 断言函数。 + */ +PROOF extern thm r_fact_as_pure_and_emp_eq; +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_fact R T == r_emp R + * ``` + * + * 真命题的精确单位元事实与 `r_emp` 在 HOL 中严格相等。 + */ +PROOF extern thm r_fact_true_eq; +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_fact R F == r_bottom R + * ``` + * + * 假命题的精确单位元事实与 `r_bottom` 在 HOL 中严格相等。 + */ +PROOF extern thm r_fact_false_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool). r_sep R (r_fact R phi) P == r_and R + * (r_pure R phi) P + * ``` + * + * 左侧 `fact(phi)` 与 `P` 的分离合取严格等于 `pure(phi) && P`。 + */ +PROOF extern thm r_fact_sep_l_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (phi:bool) (P:A->bool). r_sep R P (r_fact R phi) == r_and R + * (r_pure R phi) P + * ``` + * + * 右侧 `fact(phi)` 与 `P` 的分离合取严格等于 `pure(phi) && P`。 + */ +PROOF extern thm r_fact_sep_r_eq; + +/* Raw equality normalizations for exact ownership. */ +/** + * HOL conclusion: + * + * ```text + * forall R:(A)ra. r_own R (ra_unit R) == r_emp R + * ``` + * + * RA 单位元的精确所有权与 `r_emp` 是严格相同的 HOL 断言函数。 + */ +PROOF extern thm r_own_unit_eq; +/** + * HOL conclusion: + * + * ```text + * forall (R:(A)ra) (a:A) (b:A). r_own R (ra_op R a b) == r_sep R (r_own R a) + * (r_own R b) + * ``` + * + * 组合资源的精确所有权严格等于两个分量所有权的分离合取。 + */ +PROOF extern thm r_own_op_eq; diff --git a/theory/logic/unit_ra.c b/theory/logic/unit_ra.c new file mode 100644 index 0000000000000000000000000000000000000000..0ee87931db69f5758c2d226df17ba28f14b3bc42 --- /dev/null +++ b/theory/logic/unit_ra.c @@ -0,0 +1,319 @@ +#include "proof/theory/logic/unit_ra.h" +#include "proof/theory/logic/ra_builder.h" + +#include "proof/proof_backward.h" +#require "proof/proof_backward.c" +#require "proof/theory/logic/local_update.c" +#require "proof/theory/logic/ra.c" + +PROOF static size_t UNIT_RA_AXIOMS_BEFORE = vector_size(get_all_axioms()); + +PROOF static thm unit_ra_op_def = new_fun_definition(` + unit_ra_op (a:1) (b:1) : 1 = one +`); + +PROOF static thm unit_ra_valid_def = new_fun_definition(` + unit_ra_valid (a:1) <=> T +`); + +/* + * All five RA obligations normalize by the two definitions and the singleton + * theorem `|- forall v:1. v == one`. + */ +PROOF static thm prove_unit_ra_laws(void) { + term goal_tm = ` + ra_laws (one:1) unit_ra_op unit_ra_valid + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode unfolded = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_laws_def))); + + gnode_list law1 = CONJ_TAC(unfolded); + gnode assoc = AUTO_INTROS_TAC(law1[0]); + CONV_TAC(assoc, rewrite_conv(THM_LIST(unit_ra_op_def))); + + gnode_list law2 = CONJ_TAC(law1[1]); + gnode comm = AUTO_INTROS_TAC(law2[0]); + CONV_TAC(comm, rewrite_conv(THM_LIST(unit_ra_op_def))); + + gnode_list law3 = CONJ_TAC(law2[1]); + gnode unit = GEN_TAC(law3[0], "a"); + unit = CONV_TAC( + unit, + once_rewrite_conv(THM_LIST(unit_ra_op_def))); + ACCEPT_TAC( + unit, + sym_rule(spec_rule( + `a:1`, + get_theorem_by_name("one")))); + + gnode_list law4 = CONJ_TAC(law3[1]); + CONV_TAC( + law4[0], + rewrite_conv(THM_LIST(unit_ra_valid_def))); + CONV_TAC( + law4[1], + rewrite_conv(THM_LIST(unit_ra_valid_def))); + return gnode_prove(root); +} + +PROOF static thm unit_ra_laws = prove_unit_ra_laws(); + +PROOF static thm unit_ra_def = new_fun_definition(` + unit_ra : (1)ra = + ra_abs ((one:1),(unit_ra_op,unit_ra_valid)) +`); + +PROOF static thm prove_unit_ra_unit(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `one:1`, + `unit_ra_op:1->1->1`, + `unit_ra_valid:1->bool`), + ra_unit_abs), + unit_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(unit_ra_def)), + computed); +} + +PROOF thm unit_ra_unit = prove_unit_ra_unit(); + +PROOF static thm prove_unit_ra_op_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `one:1`, + `unit_ra_op:1->1->1`, + `unit_ra_valid:1->bool`), + ra_op_abs), + unit_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(unit_ra_def)), + computed); +} + +PROOF static thm unit_ra_op_fn = prove_unit_ra_op_fn(); + +PROOF static thm prove_unit_ra_valid_fn(void) { + thm computed = mp_rule( + ispecl_rule( + TERM_LIST( + `one:1`, + `unit_ra_op:1->1->1`, + `unit_ra_valid:1->bool`), + ra_valid_abs), + unit_ra_laws); + return pure_once_rewrite_rule( + THM_LIST(gsym_rule(unit_ra_def)), + computed); +} + +PROOF static thm unit_ra_valid_fn = prove_unit_ra_valid_fn(); + +PROOF static thm prove_unit_ra_op(void) { + term goal_tm = ` + forall a b:1. ra_op unit_ra a b == one + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + unit_ra_op_fn, + unit_ra_op_def))); + return gnode_prove(root); +} + +PROOF thm unit_ra_op = prove_unit_ra_op(); + +PROOF static thm prove_unit_ra_valid(void) { + term goal_tm = ` + forall a:1. ra_valid unit_ra a + `; + gnode root = gnode_new_with_ccl(goal_tm); + CONV_TAC( + root, + rewrite_conv(THM_LIST( + unit_ra_valid_fn, + unit_ra_valid_def))); + return gnode_prove(root); +} + +PROOF thm unit_ra_valid = prove_unit_ra_valid(); + +/* The unique carrier value extends to the unique carrier value. */ +PROOF static thm prove_unit_ra_included(void) { + term goal_tm = ` + forall a b:1. ra_included unit_ra a b + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_included_def))); + body = AUTO_INTROS_TAC(body); + body = EXISTS_TAC(body, `one:1`); + thm b_is_one = spec_rule( + `b:1`, + get_theorem_by_name("one")); + thm extension_is_one = ispecl_rule( + TERM_LIST(`a:1`, `one:1`), + unit_ra_op); + ACCEPT_TAC( + body, + trans_rule(b_is_one, gsym_rule(extension_is_one))); + return gnode_prove(root); +} + +PROOF thm unit_ra_included = prove_unit_ra_included(); + +/* Every frame in the singleton carrier is the RA unit. */ +PROOF static thm prove_unit_ra_maximal(void) { + term goal_tm = ` + forall a:1. ra_maximal unit_ra a + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_maximal_def))); + body = GEN_TAC(body, "a"); + gnode_list maximal = CONJ_TAC(body); + ACCEPT_TAC( + maximal[0], + ispec_rule(`a:1`, unit_ra_valid)); + body = GEN_TAC(maximal[1], "frame"); + body = DISCH_TAC(body, "Hcompatible"); + thm frame_is_one = spec_rule( + `frame:1`, + get_theorem_by_name("one")); + ACCEPT_TAC( + body, + trans_rule(frame_is_one, gsym_rule(unit_ra_unit))); + return gnode_prove(root); +} + +PROOF thm unit_ra_maximal = + prove_unit_ra_maximal(); + +/* Predicate update has exactly one possible result, namely `one`. */ +PROOF static thm prove_unit_ra_updateP_iff(void) { + term goal_tm = ` + forall (a:1) (P:1->bool). + ra_updateP unit_ra a P <=> P one + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = AUTO_INTROS_TAC(root); + body = CONV_TAC( + body, + once_rewrite_conv(THM_LIST(ra_updateP_def))); + gnode_list directions = EQ_TAC(body); + + gnode forward = DISCH_TAC(directions[0], "Hupdate"); + thm selected = spec_rule( + `one:1`, + assume_rule(` + forall frame:1. + ra_valid unit_ra (ra_op unit_ra (a:1) frame) ==> + exists b:1. + (P:1->bool) b && + ra_valid unit_ra (ra_op unit_ra b frame) + `)); + selected = mp_rule( + selected, + ispec_rule( + `ra_op unit_ra (a:1) (one:1)`, + unit_ra_valid)); + forward = ASSUME_TAC(forward, selected, "Hselected"); + forward = ASMP_EXISTS_TAC(forward, "Hselected", "b"); + thm predicate = conjunct1_rule(assume_rule(` + (P:1->bool) (b:1) && + ra_valid unit_ra (ra_op unit_ra b one) + `)); + thm b_is_one = spec_rule( + `b:1`, + get_theorem_by_name("one")); + ACCEPT_TAC( + forward, + eq_mp_rule( + ap_term_rule(`P:1->bool`, b_is_one), + predicate)); + + gnode reverse = DISCH_TAC(directions[1], "Hresult"); + reverse = GEN_TAC(reverse, "frame"); + reverse = DISCH_TAC(reverse, "Hcompatible"); + reverse = EXISTS_TAC(reverse, `one:1`); + gnode_list result = CONJ_TAC(reverse); + ACCEPT_TAC(result[0], assume_rule(`(P:1->bool) one`)); + ACCEPT_TAC( + result[1], + ispec_rule( + `ra_op unit_ra (one:1) (frame:1)`, + unit_ra_valid)); + return gnode_prove(root); +} + +PROOF thm unit_ra_updateP_iff = + prove_unit_ra_updateP_iff(); + +/* Local-update obligations normalize completely in the singleton carrier. */ +PROOF static thm prove_unit_ra_local_update(void) { + term goal_tm = ` + forall a f b g:1. + ra_local_update unit_ra a f b g + `; + gnode root = gnode_new_with_ccl(goal_tm); + gnode body = CONV_TAC( + root, + once_rewrite_conv(THM_LIST(ra_local_update_def))); + body = AUTO_INTROS_TAC(body); + gnode_list result = CONJ_TAC(body); + ACCEPT_TAC( + result[0], + ispec_rule(`b:1`, unit_ra_valid)); + thm target_is_one = spec_rule( + `b:1`, + get_theorem_by_name("one")); + thm extension_is_one = ispecl_rule( + TERM_LIST(`g:1`, `residual:1`), + unit_ra_op); + ACCEPT_TAC( + result[1], + trans_rule(target_is_one, gsym_rule(extension_is_one))); + return gnode_prove(root); +} + +PROOF thm unit_ra_local_update = + prove_unit_ra_local_update(); + +PROOF static int audit_unit_ra(void) { + thm_list audited_theorems = THM_LIST( + unit_ra_op_def, + unit_ra_valid_def, + unit_ra_laws, + unit_ra_def, + unit_ra_unit, + unit_ra_op_fn, + unit_ra_valid_fn, + unit_ra_op, + unit_ra_valid, + unit_ra_included, + unit_ra_maximal, + unit_ra_updateP_iff, + unit_ra_local_update); + + for (size_t i = 0; i < vector_size(audited_theorems); ++i) { + ENSURE_COND(!IS_NULL(audited_theorems[i]), + "unit RA theorem %zu is empty", i); + ENSURE_COND(vector_size(hyp(audited_theorems[i])) == 0, + "unit RA theorem %zu has hypotheses", i); + } + ENSURE_COND(vector_size(get_all_axioms()) == UNIT_RA_AXIOMS_BEFORE, + "unit RA introduced an axiom"); + return 0; +err: + ERR_FUN_PUTS("audit_unit_ra"); + return -1; +} + +PROOF static int _UNIT_RA_AUDIT = audit_unit_ra(); diff --git a/theory/logic/unit_ra.h b/theory/logic/unit_ra.h new file mode 100644 index 0000000000000000000000000000000000000000..c297a4b1bebe11042a22eccc07377523087ca2cd --- /dev/null +++ b/theory/logic/unit_ra.h @@ -0,0 +1,79 @@ +#pragma once + +/* + * Public interface for the singleton resource algebra on HOL type `1`. + * Its only carrier value, `one`, is the unit and is always valid. + */ + +#include "proof/theory/logic/local_update.h" + +/* ------------------------------------------------------------------------- */ +/* Algebra and validity */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * ra_unit unit_ra == one + * ``` + * + * `unit_ra` 的 unit 是单元类型中唯一的值 `one`。 + */ +PROOF extern thm unit_ra_unit; + +/* + * ```text + * forall a b. ra_op unit_ra a b == one + * ``` + * + * `unit_ra` 中任意两个载体值的组合结果都是 `one`。 + */ +PROOF extern thm unit_ra_op; + +/* + * ```text + * forall a. ra_valid unit_ra a + * ``` + * + * `unit_ra` 的任意载体值都有效。 + */ +PROOF extern thm unit_ra_valid; + +/* + * ```text + * forall a b. ra_included unit_ra a b + * ``` + * + * `unit_ra` 中任意资源都包含于任意其他资源。 + */ +PROOF extern thm unit_ra_included; + +/* + * ```text + * forall a. ra_maximal unit_ra a + * ``` + * + * `unit_ra` 中的任意资源都是 maximal，因为唯一可能的 frame 就是 unit。 + */ +PROOF extern thm unit_ra_maximal; + +/* ------------------------------------------------------------------------- */ +/* Updates */ +/* ------------------------------------------------------------------------- */ + +/* + * ```text + * forall a P. ra_updateP unit_ra a P <=> P one + * ``` + * + * `unit_ra` 中从任意源更新到谓词 `P` 可行，当且仅当 `P one` 成立。 + */ +PROOF extern thm unit_ra_updateP_iff; + +/* + * ```text + * forall a f b g. ra_local_update unit_ra a f b g + * ``` + * + * `unit_ra` 只有一个资源值，因此任意 whole/local 对之间的局部更新都成立。 + */ +PROOF extern thm unit_ra_local_update;