diff --git a/PORTING.md b/PORTING.md index da5be018..e1c0ea1b 100644 --- a/PORTING.md +++ b/PORTING.md @@ -12,12 +12,12 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `agree.v` - [x] CMRA - [x] Functors -- [ ] `auth.v` - - [ ] CMRA - - [ ] Updates - - [ ] Functors -- [ ] `big_op.v` - - TBD (Zongyuan?) +- [x] `auth.v` + - [x] CMRA + - [x] Updates + - [x] Functors +- [x] `big_op.v` + - [x] `bigOpL`, `bigOpM` definitions and lemmas - [ ] `cmra.v` - [x] Lemmas - [ ] Total CMRA construction @@ -33,8 +33,8 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [x] Isomorphisms - [ ] `cmra_big_op.v` - [ ] `coPset.v` - - [ ] coPset definition - - [ ] CMRA + - [x] coPset definition + - [x] CMRA - [x] `cofe_solver.v` - [ ] `csum.v` - [ ] CMRA @@ -54,15 +54,15 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `functions.v` (nb. contained in `CMRA.lean`) - [x] CMRA - [ ] Updates -- [ ] `gmap.v` (nb. generalized in `Heap.lean`) +- [x] `gmap.v` (nb. generalized in `Heap.lean`) - [x] CMRA - [ ] Updates - - [ ] Functors + - [x] Functors - [ ] `gmultiset.v` - [ ] CMRA - [ ] Updates - [ ] `gset.v` - - [ ] CMRA + - [x] CMRA - [ ] Updates - [ ] `list.v` - Is this an instance of the `Heap` CMRA? @@ -72,7 +72,7 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `max_prefix_list.v` - [ ] Lemmas - [ ] Functors -- [ ] `monoid.v` +- [x] `monoid.v` - [ ] `mra.v` - [x] `numbers.v` - [ ] `ofe.v` @@ -111,10 +111,10 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `vector.v` - [ ] CMRA - [ ] Functors -- [ ] `view.v` +- [x] `view.v` - [x] CMRA - [x] Updates - - [ ] Functors + - [x] Functors - [ ] `lib/dfrac_agree.v` - [ ] Lemmas - [ ] Updates @@ -126,10 +126,10 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] Lemmas - [ ] Updates - [ ] Functors -- [ ] `lib/gmap_view.v` (nb. generalized in `HeapView.lean`) +- [x] `lib/gmap_view.v` (nb. generalized in `HeapView.lean`) - [x] CMRA - [x] Updates - - [ ] Functors + - [x] Functors - [ ] `lib/gset_bij.v` - [ ] `lib/mono_Z.v` (nb. generalize to `MonoNumbers.lean`) - [ ] `lib/mono_list.v` @@ -163,10 +163,10 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [x] Later lemmas - [x] Update lemmas - [ ] `lib/boxes.v` -- [ ] `lib/cancelable_invariants.v` +- [x] `lib/cancelable_invariants.v` - [ ] `lib/fancy_updates.v` - - [ ] FUpd instance - - [ ] Soundness + - [x] FUpd instance + - [x] Soundness - [ ] ProofMode instances - [ ] `lib/fancy_updates_from_vs.v` - [ ] `lib/gen_heap.v` @@ -174,7 +174,7 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `lib/ghost_map.v` - [ ] `lib/ghost_var.v` - [ ] `lib/gset_bij.v` -- [ ] `lib/invariants.v` +- [x] `lib/invariants.v` - [ ] `lib/iprop.v` - [x] Definition - [ ] subG @@ -192,14 +192,15 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `lib/proph_map.v` - [ ] `lib/saved_prop.v` - [ ] `lib/token.v` -- [ ] `lib/wsat.v` +- [x] `lib/wsat.v` ## BI - [ ] `algebra.v` - `ascii.v` - [x] `bi.v` -- [ ] `big_op.v` +- [x] `big_op.v` + - [x] `big_sepL`, `big_sepM` definitions and lemmas - [ ] `cmra.v` - [x] `derived_connectives.v` - [ ] `derived_laws.v` @@ -425,5 +426,3 @@ Some porting tasks will require other tasks as dependencies, the GitHub issues p - [ ] `language.v` - [ ] `ectx_language.v` - [ ] `ectxi_language.v` - - diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..f6e728ec --- /dev/null +++ b/flake.nix @@ -0,0 +1,42 @@ +{ + description = "Iris - Separation logic in Lean 4"; + + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; + flake-utils.url = "github:numtide/flake-utils"; + }; + + outputs = + { + self, + nixpkgs, + flake-utils, + }: + flake-utils.lib.eachDefaultSystem ( + system: + let + pkgs = import nixpkgs { inherit system; }; + + nativeBuildInputs = with pkgs; [ + elan + ]; + + buildInputs = + with pkgs; + lib.optionals stdenv.isDarwin [ + libiconv + ]; + + in + { + devShells.default = pkgs.mkShell { + inherit nativeBuildInputs buildInputs; + + shellHook = '' + echo "Iris development environment" + echo "Lean: $(elan show 2>/dev/null | head -1 || echo 'not configured')" + ''; + }; + } + ); +} diff --git a/src/Iris/Algebra.lean b/src/Iris/Algebra.lean index 30043dc5..88be2a2d 100644 --- a/src/Iris/Algebra.lean +++ b/src/Iris/Algebra.lean @@ -1,6 +1,7 @@ import Iris.Algebra.Agree import Iris.Algebra.CMRA import Iris.Algebra.COFESolver +import Iris.Algebra.CoPset import Iris.Algebra.DFrac import Iris.Algebra.Excl import Iris.Algebra.Frac @@ -13,3 +14,6 @@ import Iris.Algebra.UPred import Iris.Algebra.Heap import Iris.Algebra.View import Iris.Algebra.HeapView +import Iris.Algebra.Monoid +import Iris.Algebra.BigOp +import Iris.Algebra.Auth diff --git a/src/Iris/Algebra/Agree.lean b/src/Iris/Algebra/Agree.lean index 6a1c90e7..5d22ba2e 100644 --- a/src/Iris/Algebra/Agree.lean +++ b/src/Iris/Algebra/Agree.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Leo Stefanesco. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leo Stefanesco +Authors: Leo Stefanesco, Puming Liu -/ import Iris.Algebra.CMRA @@ -349,7 +349,7 @@ section agree_map variable {α β} [OFE α] [OFE β] {f : α → β} [hne : OFE.NonExpansive f] -local instance : OFE.NonExpansive (Agree.map' f) where +instance : OFE.NonExpansive (Agree.map' f) where ne := by intro n x₁ x₂ h simp only [Agree.map', Agree.dist_def, Agree.dist, List.mem_map, forall_exists_index, and_imp, @@ -411,7 +411,7 @@ abbrev AgreeRF (F : COFE.OFunctorPre) : COFE.OFunctorPre := instance {F} [COFE.OFunctor F] : RFunctor (AgreeRF F) where map f g := Agree.map (COFE.OFunctor.map f g) - map_ne.ne _ _ _ Hx _ _ Hy _ := Agree.map_ne <| COFE.OFunctor.map_ne.ne Hx Hy + map_ne.ne _ _ _ Hx _ _ Hy _ := Agree.map_ne <| COFE.OFunctor.map_ne.ne Hx Hy map_id x := by conv=> right; rw [<- (Agree.map_id x)] exact (Agree.map_id x) ▸ Agree.agree_map_ext COFE.OFunctor.map_id diff --git a/src/Iris/Algebra/Auth.lean b/src/Iris/Algebra/Auth.lean new file mode 100644 index 00000000..522d249a --- /dev/null +++ b/src/Iris/Algebra/Auth.lean @@ -0,0 +1,485 @@ +/- +Copyright (c) 2025 Alexander Bai. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Alexander Bai +-/ +import Iris.Algebra.View +import Iris.Algebra.LocalUpdates + +/-! +# Authoritative Camera + +The authoritative camera has 2 types of elements: +- the authoritative element `●{dq} a` +- and the fragment `◯ b` +-/ + +open Iris + +open OFE CMRA UCMRA + +/-! +## Definition of the view relation for the authoritative camera. + +`auth_view_rel n a b` holds when `b ≼{n} a` and `✓{n} a`. + +Rocq: `auth_view_rel_raw` +-/ +def authViewRel [UCMRA A] : ViewRel A A := fun n a b => b ≼{n} a ∧ ✓{n} a + +namespace authViewRel + +variable [UCMRA A] + +/-- Rocq: `auth_view_rel_raw_mono`, `auth_view_rel_raw_valid`, `auth_view_rel_raw_unit` -/ +instance : IsViewRel (authViewRel (A := A)) where + mono := by + intro n1 a1 b1 n2 a2 b2 ⟨Hinc, Hv⟩ Ha Hb Hn + constructor + · calc b2 ≼{n2} b1 := Hb + _ ≼{n2} a1 := incN_of_incN_le Hn Hinc + _ ≼{n2} a2 := Ha.to_incN + · exact validN_ne Ha (validN_of_le Hn Hv) + rel_validN n a b := by + intro ⟨Hinc, Hv⟩ + exact validN_of_incN Hinc Hv + rel_unit n := by + exists unit + constructor + · exact incN_refl unit + · exact unit_valid.validN + +theorem auth_view_rel_unit {n : Nat} {a : A} : authViewRel n a unit ↔ ✓{n} a := by + constructor + · intro ⟨_, Hv⟩; exact Hv + · intro Hv; exact ⟨incN_unit, Hv⟩ + +theorem auth_view_rel_exists {n : Nat} {b : A} : (∃ a, authViewRel n a b) ↔ ✓{n} b := by + constructor + · intro ⟨a, Hrel⟩; exact IsViewRel.rel_validN n a b Hrel + · intro Hv; exact ⟨b, incN_refl b, Hv⟩ + +/-- Rocq: `auth_view_rel_discrete` -/ +instance [OFE.Discrete A] [CMRA.Discrete A] : IsViewRelDiscrete (authViewRel (A := A)) where + discrete n a b := by + intro ⟨Hinc, Hv⟩ + constructor + · exact incN_of_inc n ((inc_iff_incN 0).mpr Hinc) + · exact (discrete_valid Hv).validN + +end authViewRel + + +/-! ## Definition and operations on the authoritative camera -/ + +abbrev Auth (F : Type _) (A : Type _) [UFraction F] [UCMRA A] := View F (authViewRel (A := A)) + +namespace Auth +variable [UFraction F] [UCMRA A] + +/-- Roc: `authO` -/ +instance : OFE (Auth F A) := View.instOFE +/-- Rocq: `authR` -/ +instance : CMRA (Auth F A) := View.instCMRA +/-- Rocq: `authUR` -/ +instance : UCMRA (Auth F A) := View.instUCMRA + +abbrev auth (dq : DFrac F) (a : A) : Auth F A := View.Auth dq a +abbrev authFull (a : A) : Auth F A := View.Auth (DFrac.own One.one) a +abbrev frag (b : A) : Auth F A := View.Frag b + +notation "●{" dq "} " a => auth dq a +notation "● " a => authFull a +notation "◯ " b => frag b + +instance auth_ne {dq : DFrac F} : NonExpansive (auth dq : A → Auth F A) := View.auth_ne +instance frag_ne : NonExpansive (frag : A → Auth F A) := View.frag_ne + +theorem auth_dist_inj {n : Nat} {dq1 dq2 : DFrac F} {a1 a2 : A} + (H : (●{dq1} a1) ≡{n}≡ ●{dq2} a2) : dq1 = dq2 ∧ a1 ≡{n}≡ a2 := + ⟨View.auth_inj_frac H, View.dist_of_auth_dist H⟩ + +theorem auth_inj {dq1 dq2 : DFrac F} {a1 a2 : A} + (H : (●{dq1} a1) ≡ ●{dq2} a2) : dq1 = dq2 ∧ a1 ≡ a2 := + ⟨H.1.1, equiv_dist.mpr fun _ => View.dist_of_auth_dist H.dist⟩ + +theorem frag_dist_inj {n : Nat} {b1 b2 : A} + (H : (◯ b1 : Auth F A) ≡{n}≡ ◯ b2) : b1 ≡{n}≡ b2 := + View.dist_of_frag_dist H + +theorem frag_inj {b1 b2 : A} + (H : (◯ b1 : Auth F A) ≡ ◯ b2) : b1 ≡ b2 := + equiv_dist.mpr fun _ => View.dist_of_frag_dist H.dist + + +theorem auth_discrete {dq : DFrac F} {a : A} (Ha : DiscreteE a) (Hu : DiscreteE (unit : A)) : + DiscreteE (●{dq} a) := + View.auth_discrete Ha Hu + +theorem frag_discrete {a : A} (Hb : DiscreteE a) : + DiscreteE (◯ a : Auth F A) := + View.frag_discrete Hb + +instance [OFE.Discrete A] : OFE.Discrete (Auth F A) := inferInstance +instance [OFE.Discrete A] [CMRA.Discrete A] : CMRA.Discrete (Auth F A) := inferInstance + + +/-! ## Operations -/ +theorem auth_dfrac_op {dq1 dq2 : DFrac F} {a : A} : + (●{dq1 • dq2} a) ≡ (●{dq1} a) • (●{dq2} a) := + View.auth_op_auth_eqv + +-- TODO: auth_auth_dfrac_is_op + +theorem frag_op {b1 b2 : A} : (◯ (b1 • b2) : Auth F A) = ((◯ b1 : Auth F A) • ◯ b2) := + View.frag_op_eq + +theorem frag_inc_of_inc {b1 b2 : A} (H : b1 ≼ b2) : (◯ b1 : Auth F A) ≼ ◯ b2 := + View.frag_inc_of_inc H + +theorem frag_core {b : A} : core (◯ b : Auth F A) = ◯ (core b) := + View.frag_core + +theorem auth_both_core_discarded : + core ((●{.discard} a) • ◯ b : Auth F A) ≡ (●{.discard} a) • ◯ (core b) := + View.auth_discard_op_frag_core + +theorem auth_both_core_frac q a b : + core ((●{.own q} a) • ◯ b : Auth F A) ≡ ◯ (core b) := + View.auth_own_op_frag_core + +/-- Rocq: `auth_auth_core_id` -/ +instance {a : A} : CoreId (●{.discard} a : Auth F A) := View.instCoreIdAuthDiscard + +/-- Rocq: `auth_frag_core_id` -/ +instance {b : A} [CoreId b] : CoreId (◯ b : Auth F A) := View.instCoreIdFrag + +/-- Rocq: `auth_both_core_id` -/ +instance {a : A} {b : A} [CoreId b] : CoreId ((●{.discard} a : Auth F A) • ◯ b) := + View.instCoreIdOpAuthDiscardFrag + +-- TODO: auth_frag_is_op +-- TODO: auth_frag_sep_homomorphism + +/- TODO: BigOPs + big_opL_auth_frag + big_opM_auth_frag + big_opS_auth_frag + big_opMS_auth_frag +-/ + +/-! ## Validity -/ + +theorem auth_dfrac_op_invN {n : Nat} {dq1 dq2 : DFrac F} {a b : A} + (H : ✓{n} ((●{dq1} a) • ●{dq2} b)) : a ≡{n}≡ b := + View.dist_of_validN_auth H + +theorem auth_dfrac_op_inv {dq1 dq2 : DFrac F} {a b : A} + (H : ✓ ((●{dq1} a) • ●{dq2} b)) : a ≡ b := + View.eqv_of_valid_auth H + +theorem auth_dfrac_op_inv_L [Leibniz A] {dq1 dq2 : DFrac F} {a b : A} + (H : ✓ ((●{dq1} a) • ●{dq2} b)) : a = b := + Leibniz.eq_of_eqv (auth_dfrac_op_inv H) + + +theorem auth_dfrac_validN {n : Nat} {dq : DFrac F} {a : A} : + (✓{n} (●{dq} a)) ↔ (✓ dq ∧ ✓{n} a) := by + rw [View.auth_validN_iff] + simp only [authViewRel] + constructor + · intro ⟨Hdq, _, Hv⟩; exact ⟨Hdq, Hv⟩ + · intro ⟨Hdq, Hv⟩; exact ⟨Hdq, incN_unit, Hv⟩ + +theorem auth_validN {n : Nat} {a : A} : + (✓{n} (● a : Auth F A)) ↔ (✓{n} a) := by + rw [auth_dfrac_validN] + exact and_iff_right_iff_imp.mpr fun _ => DFrac.valid_own_one + + +theorem auth_dfrac_op_validN {n : Nat} {dq1 dq2 : DFrac F} {a1 a2 : A} : + (✓{n} ((●{dq1} a1) • ●{dq2} a2)) ↔ (✓ (dq1 • dq2) ∧ a1 ≡{n}≡ a2 ∧ ✓{n} a1) := by + rw [View.auth_op_auth_validN_iff] + simp only [authViewRel] + constructor + · intro ⟨Hdq, Ha, ⟨_, Hv⟩⟩; exact ⟨Hdq, Ha, Hv⟩ + · intro ⟨Hdq, Ha, Hv⟩; exact ⟨Hdq, Ha, incN_unit, Hv⟩ + +theorem auth_op_validN {n : Nat} {a1 a2 : A} : + (✓{n} ((● a1 : Auth F A) • ● a2)) ↔ False := + View.auth_one_op_auth_one_validN_iff + + +theorem frag_validN {n : Nat} {b : A} : + (✓{n} (◯ b : Auth F A)) ↔ (✓{n} b) := by + rw [View.frag_validN_iff, authViewRel.auth_view_rel_exists] + +theorem frag_op_validN {n : Nat} {b1 b2 : A} : + (✓{n} ((◯ b1 : Auth F A) • ◯ b2)) ↔ (✓{n} (b1 • b2)) := by + rw [← frag_op]; exact frag_validN + + +theorem both_dfrac_validN {n : Nat} {dq : DFrac F} {a b : A} : + (✓{n} ((●{dq} a) • ◯ b)) ↔ (✓ dq ∧ b ≼{n} a ∧ ✓{n} a) := by + rw [View.auth_op_frag_validN_iff]; simp only [authViewRel] + +theorem both_validN {n : Nat} {a b : A} : + (✓{n} ((● a : Auth F A) • ◯ b)) ↔ (b ≼{n} a ∧ ✓{n} a) := by + exact View.auth_one_op_frag_validN_iff + +theorem auth_dfrac_valid {dq : DFrac F} {a : A} : + (✓ (●{dq} a : Auth F A)) ↔ (✓ dq ∧ ✓ a) := by + rw [View.auth_valid_iff] + refine and_congr_right fun _ => ?_ + rw [valid_iff_validN] + exact forall_congr' fun _ => authViewRel.auth_view_rel_unit + +theorem auth_valid {a : A} : + (✓ (● a : Auth F A)) ↔ (✓ a) := by + rw [auth_dfrac_valid] + exact and_iff_right_iff_imp.mpr fun _ => DFrac.valid_own_one + +/-- Rocq: `auth_dfrac_op_valid` -/ +theorem auth_dfrac_op_valid {dq1 dq2 : DFrac F} {a1 a2 : A} : + (✓ ((●{dq1} a1) • ●{dq2} a2)) ↔ (✓ (dq1 • dq2) ∧ a1 ≡ a2 ∧ ✓ a1) := by + rw [View.auth_op_auth_valid_iff] + simp only [authViewRel] + constructor + · intro ⟨Hdq, Ha, Hr⟩ + refine ⟨Hdq, Ha, valid_iff_validN.mpr fun n => (Hr n).2⟩ + · intro ⟨Hdq, Ha, Hv⟩ + exact ⟨Hdq, Ha, fun n => ⟨incN_unit, Hv.validN⟩⟩ + +theorem auth_op_valid {a1 a2 : A} : + (✓ ((● a1 : Auth F A) • ● a2)) ↔ False := + View.auth_one_op_auth_one_valid_iff + +theorem frag_valid {b : A} : + (✓ (◯ b : Auth F A)) ↔ (✓ b) := by + simp only [valid_iff_validN] + exact forall_congr' fun _ => frag_validN + +theorem frag_op_valid {b1 b2 : A} : + (✓ ((◯ b1 : Auth F A) • ◯ b2)) ↔ (✓ (b1 • b2)) := by + rw [← frag_op]; exact frag_valid + +theorem both_dfrac_valid {dq : DFrac F} {a b : A} : + (✓ ((●{dq} a) • ◯ b)) ↔ (✓ dq ∧ (∀ n, b ≼{n} a) ∧ ✓ a) := by + simp only [valid_iff_validN] + constructor + · intro H + refine ⟨fun n => (both_dfrac_validN.mp (H n)).1, fun n => ?_, fun n => ?_⟩ + · exact (both_dfrac_validN.mp (H n)).2.1 + · exact (both_dfrac_validN.mp (H n)).2.2 + · intro ⟨Hdq, Hinc, Hv⟩ n + exact both_dfrac_validN.mpr ⟨Hdq n, Hinc n, Hv n⟩ + +theorem auth_both_valid {a b : A} : + (✓ ((● a : Auth F A) • ◯ b)) ↔ ((∀ n, b ≼{n} a) ∧ ✓ a) := by + rw [both_dfrac_valid] + constructor + · intro ⟨_, Hinc, Hv⟩; exact ⟨Hinc, Hv⟩ + · intro ⟨Hinc, Hv⟩; exact ⟨DFrac.valid_own_one, Hinc, Hv⟩ + +/-- Note: The reverse direction only holds if the camera is discrete. -/ +theorem auth_both_dfrac_valid_2 {dq : DFrac F} {a b : A} + (Hdq : ✓ dq) (Ha : ✓ a) (Hb : b ≼ a) : ✓ ((●{dq} a) • ◯ b) := + both_dfrac_valid.mpr ⟨Hdq, fun n => incN_of_inc n Hb, Ha⟩ + +theorem auth_both_valid_2 {a b : A} + (Ha : ✓ a) (Hb : b ≼ a) : ✓ ((● a : Auth F A) • ◯ b) := + auth_both_dfrac_valid_2 DFrac.valid_own_one Ha Hb + +theorem both_dfrac_valid_discrete [CMRA.Discrete A] {dq : DFrac F} {a b : A} : + (✓ ((●{dq} a : Auth F A) • ◯ b)) ↔ (✓ dq ∧ b ≼ a ∧ ✓ a) := by + constructor + · intro H + have ⟨Hdq, Hinc, Hv⟩ := both_dfrac_valid.mp H + exact ⟨Hdq, (inc_iff_incN 0).mpr (Hinc 0), Hv⟩ + · intro ⟨Hdq, Hinc, Hv⟩ + exact auth_both_dfrac_valid_2 Hdq Hv Hinc + +theorem auth_both_valid_discrete [CMRA.Discrete A] {a b : A} : + (✓ ((● a : Auth F A) • ◯ b)) ↔ (b ≼ a ∧ ✓ a) := by + rw [both_dfrac_valid_discrete] + constructor + · intro ⟨_, Hinc, Hv⟩; exact ⟨Hinc, Hv⟩ + · intro ⟨Hinc, Hv⟩; exact ⟨DFrac.valid_own_one, Hinc, Hv⟩ + +/-! ## Inclusion -/ + +theorem auth_dfrac_includedN {n : Nat} {dq1 dq2 : DFrac F} {a1 a2 b : A} : + ((●{dq1} a1) ≼{n} ((●{dq2} a2) • ◯ b)) ↔ ((dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2) := + View.auth_incN_auth_op_frag_iff + +theorem auth_dfrac_included {dq1 dq2 : DFrac F} {a1 a2 b : A} : + ((●{dq1} a1) ≼ ((●{dq2} a2) • ◯ b)) ↔ ((dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2) := + View.auth_inc_auth_op_frag_iff + +theorem auth_includedN {n : Nat} {a1 a2 b : A} : + ((● a1 : Auth F A) ≼{n} ((● a2) • ◯ b)) ↔ (a1 ≡{n}≡ a2) := + View.auth_one_incN_auth_one_op_frag_iff + +theorem auth_included {a1 a2 b : A} : + ((● a1 : Auth F A) ≼ ((● a2) • ◯ b)) ↔ (a1 ≡ a2) := + View.auth_one_inc_auth_one_op_frag_iff + + +theorem frag_includedN {n : Nat} {dq : DFrac F} {a b1 b2 : A} : + ((◯ b1) ≼{n} ((●{dq} a) • ◯ b2)) ↔ (b1 ≼{n} b2) := + View.frag_incN_auth_op_frag_iff + +theorem frag_included {dq : DFrac F} {a b1 b2 : A} : + ((◯ b1) ≼ ((●{dq} a) • ◯ b2)) ↔ (b1 ≼ b2) := + View.frag_inc_auth_op_frag_iff + +/-- The weaker `auth_both_included` lemmas below are a consequence of the + `auth_included` and `frag_included` lemmas above. -/ +theorem auth_both_dfrac_includedN {n : Nat} {dq1 dq2 : DFrac F} {a1 a2 b1 b2 : A} : + (((●{dq1} a1) • ◯ b1) ≼{n} ((●{dq2} a2) • ◯ b2)) ↔ + ((dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2) := + View.auth_op_frag_incN_auth_op_frag_iff + +theorem auth_both_dfrac_included {dq1 dq2 : DFrac F} {a1 a2 b1 b2 : A} : + (((●{dq1} a1) • ◯ b1) ≼ ((●{dq2} a2) • ◯ b2)) ↔ + ((dq1 ≼ dq2 ∨ dq1 = dq2) ∧ a1 ≡ a2 ∧ b1 ≼ b2) := + View.auth_op_frag_inc_auth_op_frag_iff + +theorem auth_both_includedN {n : Nat} {a1 a2 b1 b2 : A} : + (((● a1 : Auth F A) • ◯ b1) ≼{n} ((● a2) • ◯ b2)) ↔ (a1 ≡{n}≡ a2 ∧ b1 ≼{n} b2) := + View.auth_one_op_frag_incN_auth_one_op_frag_iff + +theorem auth_both_included {a1 a2 b1 b2 : A} : + (((● a1 : Auth F A) • ◯ b1) ≼ ((● a2) • ◯ b2)) ↔ (a1 ≡ a2 ∧ b1 ≼ b2) := + View.auth_one_op_frag_inc_auth_one_op_frag_iff + +/-! ## Updates -/ + +theorem auth_update {a b a' b' : A} + (Hup : (a, b) ~l~> (a', b')) : + ((● a : Auth F A) • ◯ b) ~~> (● a') • ◯ b' := by + apply View.auth_one_op_frag_update + intro n bf ⟨⟨c, Hinc⟩, Hv⟩ + have Ha_eq : a ≡{n}≡ b •? some (bf • c) := by + simp only [CMRA.op?] + calc a ≡{n}≡ (b • bf) • c := Hinc + _ ≡{n}≡ b • (bf • c) := assoc.symm.dist + have ⟨Hv', Ha'_eq⟩ := Hup n (some (bf • c)) Hv Ha_eq + simp only [CMRA.op?] at Ha'_eq + constructor + · exists c + calc a' ≡{n}≡ b' • (bf • c) := Ha'_eq + _ ≡{n}≡ (b' • bf) • c := assoc.dist + · exact Hv' + + +theorem auth_update_alloc {a a' b' : A} + (Hup : (a, unit) ~l~> (a', b')) : + (● a : Auth F A) ~~> (● a') • ◯ b' := + Update.equiv_left unit_right_id (auth_update Hup) + +theorem auth_update_dealloc {a b a' : A} + (Hup : (a, b) ~l~> (a', unit)) : + ((● a : Auth F A) • ◯ b) ~~> ● a' := + Update.equiv_right unit_right_id (auth_update Hup) + +theorem auth_update_auth {a a' b' : A} + (Hup : (a, unit) ~l~> (a', b')) : + (● a : Auth F A) ~~> ● a' := + Update.trans (auth_update_alloc Hup) Update.op_l + + +theorem auth_update_auth_persist {dq : DFrac F} {a : A} : + (●{dq} a : Auth F A) ~~> ●{DFrac.discard} a := + View.auth_discard +theorem auth_updateP_auth_unpersist [IsSplitFraction F] {a : A} : + (●{DFrac.discard} a : Auth F A) ~~>: fun k => ∃ q, k = ●{DFrac.own q} a := + View.auth_acquire + +theorem auth_updateP_both_unpersist [IsSplitFraction F] {a b : A} : + ((●{DFrac.discard} a : Auth F A) • ◯ b) ~~>: + fun k => ∃ q, k = ((●{DFrac.own q} a : Auth F A) • ◯ b) := + View.auth_op_frag_acquire + +theorem auth_update_dfrac_alloc {dq : DFrac F} {a b : A} [CoreId b] + (Hb : b ≼ a) : (●{dq} a) ~~> (●{dq} a) • ◯ b := + View.auth_alloc fun n bf ⟨Hinc, Hv⟩ => by + constructor + · have Hba : b • a ≡ a := comm.trans (op_core_left_of_inc Hb) + exact (incN_iff_right Hba.dist).mp (op_monoN_right b Hinc) + · exact Hv + +theorem auth_local_update {a b0 b1 a' b0' b1' : A} + (Hup : (b0, b1) ~l~> (b0', b1')) + (Hinc : b0' ≼ a') (Hv : ✓ a') : + ((● a : Auth F A) • ◯ b0, (● a) • ◯ b1) ~l~> + ((● a' : Auth F A) • ◯ b0', (● a') • ◯ b1') := + View.view_local_update Hup fun n _ => ⟨incN_of_inc n Hinc, Hv.validN⟩ + +/-! ## Functor -/ + +/-- The authViewRel is preserved under CMRA homomorphisms. -/ +theorem authViewRel_map [UCMRA A'] [UCMRA B'] (g : A' -C> B') (n : Nat) (a : A') (b : A') : + authViewRel n a b → authViewRel n (g a) (g b) := by + intro ⟨Hinc, Hv⟩ + constructor + · exact CMRA.Hom.monoN g n Hinc + · exact CMRA.Hom.validN g Hv + +abbrev AuthURF (T : COFE.OFunctorPre) [URFunctor T] : COFE.OFunctorPre := + fun A B _ _ => Auth F (T A B) + +instance instURFunctorAuthURF {T : COFE.OFunctorPre} [URFunctor T] : URFunctor (AuthURF (F := F) T) where + map {A A'} {B B'} _ _ _ _ f g := + View.mapC + (URFunctor.map (F := T) f g).toHom + (URFunctor.map (F := T) f g) + (authViewRel_map (URFunctor.map f g)) + map_ne.ne a b c Hx d e Hy x := by + simp [View.mapC] + apply View.map_ne <;> intro y <;> exact URFunctor.map_ne.ne Hx Hy y + map_id x := by + simp only [View.mapC] + conv => rhs; rw [← View.map_id (R := authViewRel) x] + apply View.map_ext <;> apply URFunctor.map_id + map_comp f g f' g' x := by + simp only [View.mapC] + haveI : OFE.NonExpansive ((URFunctor.map (F := T) g g').f ∘ (URFunctor.map (F := T) f f').f) := + (URFunctor.map (F := T) g g').toHom.comp (URFunctor.map (F := T) f f').toHom |>.ne + conv => rhs; rw [← View.map_compose (R' := authViewRel)] + apply View.map_ext <;> apply URFunctor.map_comp f g f' g' + +instance instURFunctorContractiveAuthURF {T : COFE.OFunctorPre} [URFunctorContractive T] : + URFunctorContractive (AuthURF (F := F) T) where + map_contractive.1 H x := by + apply View.map_ne <;> apply URFunctorContractive.map_contractive.1 H + +abbrev AuthRF (T : COFE.OFunctorPre) [URFunctor T] : COFE.OFunctorPre := + fun A B _ _ => Auth F (T A B) + +instance instRFunctorAuthRF {T : COFE.OFunctorPre} [URFunctor T] : RFunctor (AuthRF (F := F) T) where + map {A A'} {B B'} _ _ _ _ f g := + View.mapC + (URFunctor.map (F := T) f g).toHom + (URFunctor.map (F := T) f g) + (authViewRel_map (URFunctor.map f g)) + map_ne.ne a b c Hx d e Hy x := by + simp [View.mapC] + apply View.map_ne <;> intro y <;> exact URFunctor.map_ne.ne Hx Hy y + map_id x := by + simp only [View.mapC] + conv => rhs; rw [← View.map_id (R := authViewRel) x] + apply View.map_ext <;> apply URFunctor.map_id + map_comp f g f' g' x := by + simp only [View.mapC] + haveI : OFE.NonExpansive ((URFunctor.map (F := T) g g').f ∘ (URFunctor.map (F := T) f f').f) := + (URFunctor.map (F := T) g g').toHom.comp (URFunctor.map (F := T) f f').toHom |>.ne + conv => rhs; rw [← View.map_compose (R' := authViewRel)] + apply View.map_ext <;> apply URFunctor.map_comp f g f' g' + +instance instRFunctorContractiveAuthRF {T : COFE.OFunctorPre} [URFunctorContractive T] : + RFunctorContractive (AuthRF (F := F) T) where + map_contractive.1 H x := by + apply View.map_ne <;> apply URFunctorContractive.map_contractive.1 H + +end Auth diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean new file mode 100644 index 00000000..a7d842a1 --- /dev/null +++ b/src/Iris/Algebra/BigOp.lean @@ -0,0 +1,931 @@ +/- +Copyright (c) 2026 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.Algebra.Monoid +import Iris.Std.List +import Iris.Std.FiniteMap + +namespace Iris.Algebra + +/-! # Big Operators + +This file defines big operators (fold operations) at the abstract OFE level. +These are parameterized by a monoid operation and include theorems about their properties. +-/ + +open OFE + +/-- Corresponds to Rocq's `big_opL`. -/ +def bigOpL {M : Type u} {A : Type v} (op : M → M → M) (unit : M) + (Φ : Nat → A → M) (l : List A) : M := + match l with + | [] => unit + | x :: xs => op (Φ 0 x) (bigOpL op unit (fun n => Φ (n + 1)) xs) + +namespace BigOpL + +variable {M : Type _} {A : Type _} [OFE M] {op : M → M → M} {unit : M} [Monoid M op unit] + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_nil`. -/ +@[simp] theorem nil (Φ : Nat → A → M) : + bigOpL op unit Φ ([] : List A) = unit := rfl + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_cons`. -/ +@[simp] theorem cons (Φ : Nat → A → M) (x : A) (xs : List A) : + bigOpL op unit Φ (x :: xs) = op (Φ 0 x) (bigOpL op unit (fun n => Φ (n + 1)) xs) := rfl + +/-- Corresponds to Rocq's `big_opL_singleton`. -/ +@[simp] theorem singleton (Φ : Nat → A → M) (x : A) : + bigOpL op unit Φ [x] ≡ Φ 0 x := by + simp only [cons, nil] + exact Monoid.op_right_id _ + +/-- Corresponds to Rocq's `big_opL_proper`. -/ +theorem congr {Φ Ψ : Nat → A → M} {l : List A} + (h : ∀ i x, l[i]? = some x → Φ i x ≡ Ψ i x) : + bigOpL op unit Φ l ≡ bigOpL op unit Ψ l := by + induction l generalizing Φ Ψ with + | nil => exact Equiv.rfl + | cons y ys ih => + simp only [cons] + have h0 : Φ 0 y ≡ Ψ 0 y := h 0 y rfl + have htail : ∀ i x, ys[i]? = some x → Φ (i + 1) x ≡ Ψ (i + 1) x := by + intro i x hget + exact h (i + 1) x hget + exact Monoid.op_proper h0 (ih htail) + +/-- Corresponds to Rocq's `big_opL_ne`. -/ +theorem congr_ne {Φ Ψ : Nat → A → M} {l : List A} {n : Nat} + (h : ∀ i x, l[i]? = some x → Φ i x ≡{n}≡ Ψ i x) : + bigOpL op unit Φ l ≡{n}≡ bigOpL op unit Ψ l := by + induction l generalizing Φ Ψ with + | nil => exact Dist.rfl + | cons y ys ih => + simp only [cons] + have h0 : Φ 0 y ≡{n}≡ Ψ 0 y := h 0 y rfl + have htail : ∀ i x, ys[i]? = some x → Φ (i + 1) x ≡{n}≡ Ψ (i + 1) x := by + intro i x hget + exact h (i + 1) x hget + exact Monoid.op_ne_dist h0 (ih htail) + +/-- Congruence when the functions are equivalent on all indices. -/ +theorem congr' {Φ Ψ : Nat → A → M} {l : List A} + (h : ∀ i x, Φ i x ≡ Ψ i x) : + bigOpL op unit Φ l ≡ bigOpL op unit Ψ l := + congr (fun i x _ => h i x) + +/-- Corresponds to Rocq's `big_opL_app`. -/ +theorem append (Φ : Nat → A → M) (l₁ l₂ : List A) : + bigOpL op unit Φ (l₁ ++ l₂) ≡ + op (bigOpL op unit Φ l₁) (bigOpL op unit (fun n => Φ (n + l₁.length)) l₂) := by + induction l₁ generalizing Φ with + | nil => simp only [nil]; exact Equiv.symm (Monoid.op_left_id _) + | cons x xs ih => + simp only [List.cons_append, cons, List.length_cons] + have ih' := ih (fun n => Φ (n + 1)) + have heq : ∀ n, n + xs.length + 1 = n + (xs.length + 1) := fun n => by omega + calc op (Φ 0 x) (bigOpL op unit (fun n => Φ (n + 1)) (xs ++ l₂)) + _ ≡ op (Φ 0 x) (op (bigOpL op unit (fun n => Φ (n + 1)) xs) + (bigOpL op unit (fun n => Φ (n + xs.length + 1)) l₂)) := + Monoid.op_congr_r ih' + _ ≡ op (op (Φ 0 x) (bigOpL op unit (fun n => Φ (n + 1)) xs)) + (bigOpL op unit (fun n => Φ (n + xs.length + 1)) l₂) := + Equiv.symm (Monoid.op_assoc _ _ _) + _ ≡ op (op (Φ 0 x) (bigOpL op unit (fun n => Φ (n + 1)) xs)) + (bigOpL op unit (fun n => Φ (n + (xs.length + 1))) l₂) := by + simp only [heq]; exact Equiv.rfl + +/-- Corresponds to Rocq's `big_opL_snoc`. -/ +theorem snoc (Φ : Nat → A → M) (l : List A) (x : A) : + bigOpL op unit Φ (l ++ [x]) ≡ op (bigOpL op unit Φ l) (Φ l.length x) := by + have h := @append M A _ op unit _ Φ l [x] + simp only [cons, nil, Nat.zero_add] at h + have hr : op (Φ l.length x) unit ≡ Φ l.length x := Monoid.op_right_id (Φ l.length x) + exact Monoid.op_congr_r hr |> Equiv.trans h + +/-- Corresponds to Rocq's `big_opL_unit`. -/ +theorem unit_const (l : List A) : + bigOpL op unit (fun _ _ => unit) l ≡ unit := by + induction l with + | nil => exact Equiv.rfl + | cons _ _ ih => simp only [cons]; exact Equiv.trans (Monoid.op_left_id _) ih + +/-- Corresponds to Rocq's `big_opL_op`. -/ +theorem op_distr (Φ Ψ : Nat → A → M) (l : List A) : + bigOpL op unit (fun i x => op (Φ i x) (Ψ i x)) l ≡ + op (bigOpL op unit Φ l) (bigOpL op unit Ψ l) := by + induction l generalizing Φ Ψ with + | nil => simp only [nil]; exact Equiv.symm (Monoid.op_left_id _) + | cons x xs ih => + simp only [cons] + exact Equiv.trans (Monoid.op_congr_r (ih _ _)) Monoid.op_op_swap + +/-- Corresponds to Rocq's `big_opL_fmap`. -/ +theorem map {B : Type v} (h : A → B) (Φ : Nat → B → M) (l : List A) : + bigOpL op unit Φ (l.map h) ≡ bigOpL op unit (fun i x => Φ i (h x)) l := by + induction l generalizing Φ with + | nil => exact Equiv.rfl + | cons x xs ih => + simp only [List.map_cons, cons] + exact Monoid.op_proper Equiv.rfl (ih (fun n => Φ (n + 1))) + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_closed`. -/ +theorem closed (P : M → Prop) (Φ : Nat → A → M) (l : List A) + (hunit : P unit) + (hop : ∀ x y, P x → P y → P (op x y)) + (hf : ∀ i x, l[i]? = some x → P (Φ i x)) : + P (bigOpL op unit Φ l) := by + induction l generalizing Φ with + | nil => exact hunit + | cons y ys ih => + simp only [cons] + have h0 : P (Φ 0 y) := hf 0 y rfl + have htail : ∀ i x, ys[i]? = some x → P (Φ (i + 1) x) := fun i x hget => hf (i + 1) x hget + exact hop _ _ h0 (ih _ htail) + +/-- Corresponds to Rocq's `big_opL_permutation`. -/ +theorem perm (Φ : A → M) {l₁ l₂ : List A} (hp : l₁.Perm l₂) : + bigOpL op unit (fun _ => Φ) l₁ ≡ bigOpL op unit (fun _ => Φ) l₂ := by + induction hp with + | nil => exact Equiv.rfl + | cons _ _ ih => simp only [cons]; exact Monoid.op_congr_r ih + | swap _ _ _ => simp only [cons]; exact Monoid.op_swap_inner (unit := unit) + | trans _ _ ih1 ih2 => exact Equiv.trans ih1 ih2 + +/-- Corresponds to Rocq's `big_opL_take_drop`. -/ +theorem take_drop (Φ : Nat → A → M) (l : List A) (n : Nat) : + bigOpL op unit Φ l ≡ + op (bigOpL op unit Φ (l.take n)) (bigOpL op unit (fun k => Φ (n + k)) (l.drop n)) := by + by_cases hn : n ≤ l.length + · have h := @append M A _ op unit _ Φ (l.take n) (l.drop n) + simp only [List.take_append_drop, List.length_take_of_le hn, Nat.add_comm] at h + exact h + · simp only [Nat.not_le] at hn + simp only [List.drop_eq_nil_of_le (Nat.le_of_lt hn), List.take_of_length_le (Nat.le_of_lt hn), nil] + exact Equiv.symm (Monoid.op_right_id _) + +/-- Corresponds to Rocq's `big_opL_omap`. -/ +theorem filter_map {B : Type v} (h : A → Option B) (Φ : B → M) (l : List A) : + bigOpL op unit (fun _ => Φ) (l.filterMap h) ≡ + bigOpL op unit (fun _ x => (h x).elim unit Φ) l := by + induction l with + | nil => exact Equiv.rfl + | cons x xs ih => + simp only [List.filterMap_cons] + cases hx : h x <;> simp only [hx, Option.elim, cons] + · exact Equiv.trans ih (Equiv.symm (Monoid.op_left_id _)) + · exact Monoid.op_congr_r ih + +/-- Corresponds to Rocq's `big_opL_bind`. -/ +theorem bind {B : Type v} (h : A → List B) (Φ : B → M) (l : List A) : + bigOpL op unit (fun _ => Φ) (l.flatMap h) ≡ + bigOpL op unit (fun _ x => bigOpL op unit (fun _ => Φ) (h x)) l := by + induction l with + | nil => exact Equiv.rfl + | cons x xs ih => + simp only [List.flatMap_cons, cons] + exact Equiv.trans (append _ _ _) (Monoid.op_congr_r ih) + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_gen_proper_2`. -/ +theorem gen_proper_2 {B : Type v} (R : M → M → Prop) + (Φ : Nat → A → M) (Ψ : Nat → B → M) (l₁ : List A) (l₂ : List B) + (hunit : R unit unit) + (hop : ∀ a a' b b', R a a' → R b b' → R (op a b) (op a' b')) + (hlen : l₁.length = l₂.length) + (hf : ∀ i, ∀ x y, l₁[i]? = some x → l₂[i]? = some y → R (Φ i x) (Ψ i y)) : + R (bigOpL op unit Φ l₁) (bigOpL op unit Ψ l₂) := by + induction l₁ generalizing l₂ Φ Ψ with + | nil => + cases l₂ with + | nil => simp only [nil]; exact hunit + | cons _ _ => simp at hlen + | cons x xs ih => + cases l₂ with + | nil => simp at hlen + | cons y ys => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [cons] + have h0 : R (Φ 0 x) (Ψ 0 y) := hf 0 x y rfl rfl + have htail : ∀ i, ∀ a b, xs[i]? = some a → ys[i]? = some b → + R (Φ (i + 1) a) (Ψ (i + 1) b) := fun i a b ha hb => hf (i + 1) a b ha hb + exact hop _ _ _ _ h0 (ih (fun n => Φ (n + 1)) (fun n => Ψ (n + 1)) ys hlen htail) + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_gen_proper`. -/ +theorem gen_proper (R : M → M → Prop) + (Φ Ψ : Nat → A → M) (l : List A) + (hR_refl : ∀ x, R x x) + (hR_op : ∀ a a' b b', R a a' → R b b' → R (op a b) (op a' b')) + (hf : ∀ k y, l[k]? = some y → R (Φ k y) (Ψ k y)) : + R (bigOpL op unit Φ l) (bigOpL op unit Ψ l) := by + apply gen_proper_2 (op := op) (unit := unit) R Φ Ψ l l + · exact hR_refl unit + · exact hR_op + · rfl + · intro k x y hx hy + cases hget : l[k]? with + | none => + rw [hget] at hx + cases hx + | some z => + have hxz : x = z := by rw [hget] at hx; cases hx; rfl + have hyz : y = z := by rw [hget] at hy; cases hy; rfl + rw [hxz, hyz] + exact hf k z hget + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_ext`. -/ +theorem ext {Φ Ψ : Nat → A → M} {l : List A} + (h : ∀ i x, l[i]? = some x → Φ i x = Ψ i x) : + bigOpL op unit Φ l = bigOpL op unit Ψ l := by + apply gen_proper + · intro _ + rfl + · intros _ _ _ _ ha hb + rw [ha, hb] + · apply h + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_consZ_l`. -/ +theorem cons_int_l (Φ : Int → A → M) (x : A) (l : List A) : + bigOpL op unit (fun k => Φ k) (x :: l) = + op (Φ 0 x) (bigOpL op unit (fun k y => Φ (1 + (k : Int)) y) l) := by + simp only [cons] + apply congrArg + apply ext + intro i y hy + congr 1 + omega + +omit [OFE M] [Monoid M op unit] in +/-- Corresponds to Rocq's `big_opL_consZ_r`. -/ +theorem cons_int_r (Φ : Int → A → M) (x : A) (l : List A) : + bigOpL op unit (fun k => Φ k) (x :: l) = + op (Φ 0 x) (bigOpL op unit (fun k y => Φ ((k : Int) + 1) y) l) := by + simp only [cons] + rfl + +/-- Corresponds to Rocq's `big_opL_proper_2`. -/ +theorem proper_2 [OFE A] (Φ Ψ : Nat → A → M) (l₁ l₂ : List A) + (hlen : l₁.length = l₂.length) + (hf : ∀ (k : Nat) (y₁ y₂ : A), l₁[k]? = some y₁ → l₂[k]? = some y₂ → Φ k y₁ ≡ Ψ k y₂) : + bigOpL op unit Φ l₁ ≡ bigOpL op unit Ψ l₂ := by + apply gen_proper_2 (op := op) (unit := unit) (· ≡ ·) Φ Ψ l₁ l₂ + · exact Equiv.rfl + · intros a a' b b' ha hb; exact Monoid.op_proper ha hb + · exact hlen + · intro k x y hx hy + cases hget1 : l₁[k]? with + | none => + rw [hget1] at hx + cases hx + | some z₁ => + cases hget2 : l₂[k]? with + | none => + have h1 : k < l₁.length := by + cases h : l₁[k]? <;> simp_all + rw [hlen] at h1 + have h2 : k < l₂.length := h1 + have : l₂[k]? ≠ none := by + intro h + have : l₂[k]? = some l₂[k] := List.getElem?_eq_getElem h2 + simp [h] at this + contradiction + | some z₂ => + have hxz1 : x = z₁ := by rw [hget1] at hx; cases hx; rfl + have hyz2 : y = z₂ := by rw [hget2] at hy; cases hy; rfl + rw [hxz1, hyz2] + exact hf k z₁ z₂ hget1 hget2 + +/-- Corresponds to Rocq's `big_opL_zip_seq`. -/ +theorem zip_idx (Φ : A × Nat → M) (n : Nat) (l : List A) : + bigOpL op unit (fun _ => Φ) (l.zipIdx n) ≡ + bigOpL op unit (fun i x => Φ (x, n + i)) l := by + induction l generalizing n with + | nil => simp only [nil]; exact Equiv.rfl + | cons x xs ih => + simp only [cons, Nat.add_zero] + refine Monoid.op_proper Equiv.rfl (Equiv.trans (ih (n + 1)) (congr' fun i _ => ?_)) + simp only [Nat.add_assoc, Nat.add_comm 1 i]; exact Equiv.rfl + +/-- Corresponds to Rocq's `big_opL_zip_seqZ`. -/ +theorem zip_idx_int (Φ : A × Int → M) (n : Int) (l : List A) : + bigOpL op unit (fun _ => Φ) (Std.List.zipIdxInt l n) ≡ + bigOpL op unit (fun i x => Φ (x, n + (i : Int))) l := by + unfold Std.List.zipIdxInt + suffices ∀ m, bigOpL op unit (fun _ => Φ) (l.mapIdx (fun i v => (v, (i : Int) + m))) ≡ + bigOpL op unit (fun i x => Φ (x, m + (i : Int))) l by exact this n + intro m + induction l generalizing m with + | nil => simp only [List.mapIdx, nil]; exact Equiv.rfl + | cons x xs ih => + simp only [List.mapIdx_cons, cons] + apply Monoid.op_proper + · show Φ (x, (0 : Int) + m) ≡ Φ (x, m + (0 : Int)) + rw [Int.zero_add, Int.add_zero] + · have h_shift : ∀ i, ((i + 1 : Nat) : Int) + m = (i : Int) + (m + 1) := by + intro i; omega + have list_eq : (List.mapIdx (fun i v => (v, ↑(i + 1) + m)) xs) = + (List.mapIdx (fun i v => (v, ↑i + (m + 1))) xs) := by + apply List.ext_getElem + · simp only [List.length_mapIdx] + · intro n hn1 hn2 + simp only [List.getElem_mapIdx] + congr 1 + exact h_shift n + rw [list_eq] + have h_ih := ih (m + 1) + refine Equiv.trans h_ih (congr' fun i _ => ?_) + have : m + 1 + (i : Int) = m + ((i + 1 : Nat) : Int) := by omega + rw [this] + +/-- Corresponds to Rocq's `big_opL_sep_zip_with`. -/ +theorem sep_zip_with {B C : Type _} + (f : A → B → C) (g1 : C → A) (g2 : C → B) + (Φ : Nat → A → M) (Ψ : Nat → B → M) (l₁ : List A) (l₂ : List B) + (hg1 : ∀ x y, g1 (f x y) = x) + (hg2 : ∀ x y, g2 (f x y) = y) + (hlen : l₁.length = l₂.length) : + bigOpL op unit (fun i c => op (Φ i (g1 c)) (Ψ i (g2 c))) (List.zipWith f l₁ l₂) ≡ + op (bigOpL op unit Φ l₁) (bigOpL op unit Ψ l₂) := by + induction l₁ generalizing l₂ Φ Ψ with + | nil => + cases l₂ with + | nil => simp only [List.zipWith_nil_left, nil]; exact Equiv.symm (Monoid.op_left_id _) + | cons _ _ => simp at hlen + | cons x xs ih => + cases l₂ with + | nil => simp at hlen + | cons y ys => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [List.zipWith_cons_cons, cons, hg1, hg2] + exact Equiv.trans (Monoid.op_congr_r (ih (fun n => Φ (n + 1)) (fun n => Ψ (n + 1)) ys hlen)) Monoid.op_op_swap + +/-- Big op over zipped list with separated functions. -/ +theorem sep_zip {B : Type v} (Φ : Nat → A → M) (Ψ : Nat → B → M) (l₁ : List A) (l₂ : List B) + (hlen : l₁.length = l₂.length) : + bigOpL op unit (fun i xy => op (Φ i xy.1) (Ψ i xy.2)) (l₁.zip l₂) ≡ + op (bigOpL op unit Φ l₁) (bigOpL op unit Ψ l₂) := by + simp [List.zip] + apply sep_zip_with (op := op) + · intro _ _ + trivial + · intro _ _ + trivial + · apply hlen + +variable {M₁ : Type u} {M₂ : Type v} [OFE M₁] [OFE M₂] +variable {op₁ : M₁ → M₁ → M₁} {op₂ : M₂ → M₂ → M₂} {unit₁ : M₁} {unit₂ : M₂} +variable [Monoid M₁ op₁ unit₁] [Monoid M₂ op₂ unit₂] +variable {B : Type w} + +/-- Monoid homomorphisms distribute over big ops. -/ +theorem commute {R : M₂ → M₂ → Prop} {f : M₁ → M₂} + (hom : MonoidHomomorphism op₁ op₂ unit₁ unit₂ R f) + (Φ : Nat → B → M₁) (l : List B) : + R (f (bigOpL op₁ unit₁ Φ l)) (bigOpL op₂ unit₂ (fun i x => f (Φ i x)) l) := by + induction l generalizing Φ with + | nil => simp only [nil]; exact hom.map_unit + | cons x xs ih => + simp only [cons] + have hhom := hom.homomorphism (Φ 0 x) (bigOpL op₁ unit₁ (fun n => Φ (n + 1)) xs) + have hih := ih (fun n => Φ (n + 1)) + exact hom.rel_trans hhom (hom.op_proper (hom.rel_refl _) hih) + +/-- Weak monoid homomorphisms distribute over non-empty big ops. -/ +theorem commute_weak {R : M₂ → M₂ → Prop} {f : M₁ → M₂} + (hom : WeakMonoidHomomorphism op₁ op₂ unit₁ unit₂ R f) + (Φ : Nat → B → M₁) (l : List B) (hne : l ≠ []) : + R (f (bigOpL op₁ unit₁ Φ l)) (bigOpL op₂ unit₂ (fun i x => f (Φ i x)) l) := by + induction l generalizing Φ with + | nil => exact absurd rfl hne + | cons x xs ih => + simp only [cons] + cases xs with + | nil => + simp only [nil] + haveI : NonExpansive f := hom.f_ne + have hlhs : f (op₁ (Φ 0 x) unit₁) ≡ f (Φ 0 x) := + NonExpansive.eqv (Monoid.op_right_id (Φ 0 x)) + have hrhs : op₂ (f (Φ 0 x)) unit₂ ≡ f (Φ 0 x) := + Monoid.op_right_id (f (Φ 0 x)) + exact hom.rel_proper hlhs hrhs |>.mpr (hom.rel_refl _) + | cons y ys => + have hhom := hom.homomorphism (Φ 0 x) (bigOpL op₁ unit₁ (fun n => Φ (n + 1)) (y :: ys)) + have hih := ih (fun n => Φ (n + 1)) (List.cons_ne_nil y ys) + exact hom.rel_trans hhom (hom.op_proper (hom.rel_refl _) hih) + +end BigOpL + +namespace BigOpM + +open Iris.Std + +variable {M : Type u} [OFE M] {op : M → M → M} {unit : M} [Monoid M op unit] +variable {M' : Type _ → Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap K M'] [FiniteMapLaws K M'] + +/-- Corresponds to Rocq's `big_opM`. -/ +def bigOpM (Φ : K → V → M) (m : M' V) : M := + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +omit [OFE M] [Monoid M op unit] [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_empty`. -/ +@[simp] theorem empty (Φ : K → V → M) : + bigOpM (op := op) (unit := unit) Φ (∅ : M' V) = unit := by + simp only [bigOpM, FiniteMapLaws.toList_empty, BigOpL.nil] + +/-- Corresponds to Rocq's `big_opM_insert`. -/ +theorem insert (Φ : K → V → M) (m : M' V) (i : K) (x : V) : + FiniteMap.get? m i = none → + bigOpM (op := op) (unit := unit) Φ (FiniteMap.insert m i x) ≡ + op (Φ i x) (bigOpM (op := op) (unit := unit) Φ m) := by + intro hi + simp only [bigOpM] + have hperm := FiniteMapLaws.toList_insert m i x hi + have heq : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList (FiniteMap.insert m i x)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) ((i, x) :: FiniteMap.toList m) := + BigOpL.perm _ hperm + simp only [BigOpL.cons] at heq + exact heq + +/-- Corresponds to Rocq's `big_opM_delete`. -/ +theorem delete (Φ : K → V → M) (m : M' V) (i : K) (x : V) : + FiniteMap.get? m i = some x → + bigOpM (op := op) (unit := unit) Φ m ≡ + op (Φ i x) (bigOpM (op := op) (unit := unit) Φ (FiniteMap.delete m i)) := by + intro hi + have heq := FiniteMapLaws.insert_delete_cancel m i x hi + have : bigOpM (op := op) (unit := unit) Φ m = bigOpM (op := op) (unit := unit) Φ (FiniteMap.insert (FiniteMap.delete m i) i x) := by + rw [heq] + rw [this] + have hdelete := FiniteMapLaws.get?_delete_same m i + exact insert Φ (FiniteMap.delete m i) i x hdelete + +variable {A : Type w} [DecidableEq A] + +/-- Corresponds to Rocq's `big_opM_gen_proper_2`. -/ +theorem gen_proper_2 {B : Type w} [DecidableEq B] (R : M → M → Prop) + (Φ : K → A → M) (Ψ : K → B → M) (m1 : M' A) (m2 : M' B) + (hR_sub : ∀ x y, x ≡ y → R x y) + (hR_equiv : Equivalence R) + (hR_op : ∀ a a' b b', R a a' → R b b' → R (op a b) (op a' b')) + (hfg : ∀ k, + match FiniteMap.get? m1 k, FiniteMap.get? m2 k with + | some y1, some y2 => R (Φ k y1) (Ψ k y2) + | none, none => True + | _, _ => False) : + R (bigOpM (op := op) (unit := unit) Φ m1) (bigOpM (op := op) (unit := unit) Ψ m2) := by + refine FiniteMapLaws.induction_on (P := fun m1' => ∀ m2' Φ' Ψ', + (∀ k, match FiniteMap.get? m1' k, FiniteMap.get? m2' k with + | some y1, some y2 => R (Φ' k y1) (Ψ' k y2) + | none, none => True + | _, _ => False) → + R (bigOpM (op := op) (unit := unit) Φ' m1') (bigOpM (op := op) (unit := unit) Ψ' m2')) + ?hemp ?hins m1 m2 Φ Ψ hfg + case hemp => + intro m2' Φ' Ψ' hfg' + refine FiniteMapLaws.induction_on (P := fun m2'' => ∀ Φ'' Ψ'', + (∀ k, match FiniteMap.get? (∅ : M' A) k, FiniteMap.get? m2'' k with + | some y1, some y2 => R (Φ'' k y1) (Ψ'' k y2) + | none, none => True + | _, _ => False) → + R (bigOpM (op := op) (unit := unit) Φ'' (∅ : M' A)) (bigOpM (op := op) (unit := unit) Ψ'' m2'')) + ?hemp2 ?hins2 m2' Φ' Ψ' hfg' + case hemp2 => intro _ _ _; rw [empty, empty]; exact hR_sub unit unit Equiv.rfl + case hins2 => + intro k x2 _ _ _ _ _ hfg'' + have := hfg'' k + rw [FiniteMapLaws.get?_empty, FiniteMapLaws.get?_insert_same] at this + cases this + case hins => + intro k x1 m1' hm1'k IH m2' Φ' Ψ' hfg' + have hfg_k := hfg' k + rw [FiniteMapLaws.get?_insert_same] at hfg_k + cases hm2k : FiniteMap.get? m2' k with + | none => rw [hm2k] at hfg_k; cases hfg_k + | some x2 => + rw [hm2k] at hfg_k + have h_IH : R (bigOpM (op := op) (unit := unit) Φ' m1') + (bigOpM (op := op) (unit := unit) Ψ' (FiniteMap.delete m2' k)) := by + refine IH _ _ _ fun k' => ?_ + by_cases hkk' : k = k' + · subst hkk'; rw [FiniteMapLaws.get?_delete_same, hm1'k]; trivial + · have h1 := FiniteMapLaws.get?_insert_ne m1' k k' x1 hkk' + have h2 := FiniteMapLaws.get?_delete_ne m2' k k' hkk' + rw [← h1, h2]; exact hfg' k' + exact hR_equiv.trans (hR_sub _ _ (insert Φ' m1' k x1 hm1'k)) + (hR_equiv.trans (hR_op _ _ _ _ hfg_k h_IH) (hR_sub _ _ (Equiv.symm (delete Ψ' m2' k x2 hm2k)))) + +omit [Monoid M op unit] [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_gen_proper`. -/ +theorem gen_proper {M : Type u} {op : M → M → M} {unit : M} (R : M → M → Prop) + (Φ Ψ : K → V → M) (m : M' V) + (hR_refl : ∀ x, R x x) + (hR_op : ∀ a a' b b', R a a' → R b b' → R (op a b) (op a' b')) + (hf : ∀ k x, FiniteMap.get? m k = some x → R (Φ k x) (Ψ k x)) : + R (bigOpM (op := op) (unit := unit) Φ m) (bigOpM (op := op) (unit := unit) Ψ m) := by + simp only [bigOpM] + apply BigOpL.gen_proper_2 (op := op) (unit := unit) R + · exact hR_refl unit + · exact hR_op + · rfl + · intro i x y hx hy + rw [hx] at hy + cases hy + have : (x.1, x.2) ∈ FiniteMap.toList m := by + rw [List.mem_iff_getElem?] + exact ⟨i, hx⟩ + have := FiniteMapLaws.mem_toList m x.1 x.2 |>.mp this + exact hf x.1 x.2 this + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_ext`. -/ +theorem ext {M : Type u} (op : M → M → M) (unit : M) (Φ Ψ : K → V → M) (m : M' V) + (hf : ∀ k x, FiniteMap.get? m k = some x → Φ k x = Ψ k x) : + bigOpM (op := op) (unit := unit) Φ m = bigOpM (op := op) (unit := unit) Ψ m := by + apply gen_proper (R := (· = ·)) + · intro _; rfl + · intros _ _ _ _ ha hb; rw [ha, hb] + · exact hf + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_ne`. -/ +theorem ne (Φ Ψ : K → V → M) (m : M' V) (n : Nat) + (hf : ∀ k x, FiniteMap.get? m k = some x → Φ k x ≡{n}≡ Ψ k x) : + bigOpM (op := op) (unit := unit) Φ m ≡{n}≡ bigOpM (op := op) (unit := unit) Ψ m := by + apply gen_proper (R := (· ≡{n}≡ ·)) + · intro _; exact Dist.rfl + · intros a a' b b' ha hb; exact Monoid.op_ne_dist ha hb + · exact hf + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_proper`. -/ +theorem proper (Φ Ψ : K → V → M) (m : M' V) + (hf : ∀ k x, FiniteMap.get? m k = some x → Φ k x ≡ Ψ k x) : + bigOpM (op := op) (unit := unit) Φ m ≡ bigOpM (op := op) (unit := unit) Ψ m := by + apply gen_proper (R := (· ≡ ·)) + · intro _; exact Equiv.rfl + · intros a a' b b' ha hb; exact Monoid.op_proper ha hb + · exact hf + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_proper_2`. -/ +theorem proper_2 [OFE A] (Φ : K → A → M) (Ψ : K → A → M) (m1 m2 : M' A) + (hm : ∀ k, FiniteMap.get? m1 k = FiniteMap.get? m2 k) + (hf : ∀ k y1 y2, + FiniteMap.get? m1 k = some y1 → + FiniteMap.get? m2 k = some y2 → + y1 ≡ y2 → + Φ k y1 ≡ Ψ k y2) : + bigOpM (op := op) (unit := unit) Φ m1 ≡ bigOpM (op := op) (unit := unit) Ψ m2 := by + apply gen_proper_2 (R := (· ≡ ·)) + · intros _ _ h; exact h + · exact equiv_eqv + · intros a a' b b' ha hb; exact Monoid.op_proper ha hb + · intro k + have hlk := hm k + cases hm1k : FiniteMap.get? m1 k with + | none => + rw [hm1k] at hlk + rw [← hlk] + trivial + | some y1 => + rw [hm1k] at hlk + cases hm2k : FiniteMap.get? m2 k with + | none => rw [hm2k] at hlk; cases hlk + | some y2 => + rw [hm2k] at hlk + cases hlk + exact hf k y1 y1 hm1k hm2k Equiv.rfl + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_ne'` instance. -/ +theorem ne_pointwise (Φ Ψ : K → V → M) (m : M' V) (n : Nat) + (hf : ∀ k x, Φ k x ≡{n}≡ Ψ k x) : + bigOpM (op := op) (unit := unit) Φ m ≡{n}≡ bigOpM (op := op) (unit := unit) Ψ m := by + apply ne + intros k x _ + exact hf k x + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_proper'` instance. -/ +theorem proper_pointwise (Φ Ψ : K → V → M) (m : M' V) + (hf : ∀ k x, Φ k x ≡ Ψ k x) : + bigOpM (op := op) (unit := unit) Φ m ≡ bigOpM (op := op) (unit := unit) Ψ m := by + apply proper + intros k x _ + exact hf k x + +omit [Monoid M op unit] [DecidableEq K] [DecidableEq V] [FiniteMapLaws K M'] in +/-- Corresponds to Rocq's `big_opM_map_to_list`. -/ +theorem to_list (Φ : K → V → M) (m : M' V) : + bigOpM (op := op) (unit := unit) Φ m ≡ + bigOpL op unit (fun _ kx => Φ kx.1 kx.2) (FiniteMap.toList m) := by + simp only [bigOpM] + rfl + +/-- Corresponds to Rocq's `big_opM_list_to_map`. -/ +theorem of_list (Φ : K → V → M) (l : List (K × V)) + (hnodup : (l.map Prod.fst).Nodup) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.ofList l : M' V) ≡ + bigOpL op unit (fun _ kx => Φ kx.1 kx.2) l := by + have h1 := to_list (op := op) (unit := unit) Φ (FiniteMap.ofList l : M' V) + apply Equiv.trans h1 + apply BigOpL.perm + exact FiniteMapLaws.toList_ofList l hnodup + +/-- Corresponds to Rocq's `big_opM_singleton`. -/ +theorem singleton (Φ : K → V → M) (i : K) (x : V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.singleton (M := M') i x) ≡ Φ i x := by + have : FiniteMap.get? (∅ : M' V) i = none := FiniteMapLaws.get?_empty i + have := insert (op := op) (unit := unit) Φ (∅ : M' V) i x this + rw [empty] at this + exact Equiv.trans this (Monoid.op_right_id (Φ i x)) + +/-- Corresponds to Rocq's `big_opM_unit`. -/ +theorem unit_const (m : M' V) : + bigOpM (op := op) (unit := unit) (fun _ _ => unit) m ≡ unit := by + refine FiniteMapLaws.induction_on + (P := fun (m' : M' V) => bigOpM (op := op) (unit := unit) (fun _ _ => unit) m' ≡ unit) + ?hemp ?hins m + case hemp => + show bigOpM (op := op) (unit := unit) (fun _ _ => unit) ∅ ≡ unit + rw [empty] + case hins => + intro i x m' hm' IH + show bigOpM (op := op) (unit := unit) (fun _ _ => unit) (FiniteMap.insert m' i x) ≡ unit + have h_ins := insert (op := op) (unit := unit) (fun _ _ => unit) m' i x hm' + exact Equiv.trans h_ins (Equiv.trans (Monoid.op_proper Equiv.rfl IH) (Monoid.op_left_id unit)) + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_fmap`. -/ +theorem map {B : Type w} [DecidableEq B] (h : V → B) (Φ : K → B → M) (m : M' V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.map h m) ≡ + bigOpM (op := op) (unit := unit) (fun k v => Φ k (h v)) m := by + simp only [bigOpM] + have h1 : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList (FiniteMap.map h m)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) ((FiniteMap.toList m).map (fun kv => (kv.1, h kv.2))) := by + apply BigOpL.perm + exact FiniteMapLaws.toList_map m h + apply Equiv.trans h1 + exact BigOpL.map (op := op) (unit := unit) (fun kv => (kv.1, h kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_omap`. -/ +theorem filter_map [FiniteMapLawsSelf K M'] (h : V → Option V) (Φ : K → V → M) (m : M' V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.filterMap h m) ≡ + bigOpM (op := op) (unit := unit) (fun k v => (h v).elim unit (Φ k)) m := by + simp only [bigOpM, FiniteMap.filterMap] + -- Use toList_filterMap to relate toList of filterMap to filterMap of toList + have h1 : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) + (FiniteMap.toList (FiniteMap.ofList ((FiniteMap.toList m).filterMap (fun (k, v) => (h v).map (k, ·))) : M' V)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) + ((FiniteMap.toList m).filterMap (fun (k, v) => (h v).map (k, ·))) := by + apply BigOpL.perm + have hperm := toList_filterMap m h + exact hperm + refine Equiv.trans h1 ?_ + -- Now use BigOpL.filter_map + have h2 : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) + ((FiniteMap.toList m).filterMap (fun (k, v) => (h v).map (k, ·))) ≡ + bigOpL op unit (fun _ kv => ((h kv.2).map (kv.1, ·)).elim unit (fun kv' => Φ kv'.1 kv'.2)) + (FiniteMap.toList m) := by + exact BigOpL.filter_map (op := op) (unit := unit) (fun kv => (h kv.2).map (kv.1, ·)) (fun kv => Φ kv.1 kv.2) (FiniteMap.toList m) + refine Equiv.trans h2 ?_ + -- Simplify the function + apply BigOpL.congr' + intro i kv + cases hkv : h kv.2 <;> simp [Option.elim, Option.map] + +/-- Corresponds to Rocq's `big_opM_insert_delete`. -/ +theorem insert_delete (Φ : K → V → M) (m : M' V) (i : K) (x : V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.insert m i x) ≡ + op (Φ i x) (bigOpM (op := op) (unit := unit) Φ (FiniteMap.delete m i)) := by + rw [← FiniteMapLaws.insert_delete m i x] + exact insert Φ (FiniteMap.delete m i) i x (FiniteMapLaws.get?_delete_same m i) + +/-- Corresponds to Rocq's `big_opM_insert_override`. -/ +theorem insert_override (Φ : K → A → M) (m : M' A) (i : K) (x x' : A) : + FiniteMap.get? m i = some x → Φ i x ≡ Φ i x' → + bigOpM (op := op) (unit := unit) Φ (FiniteMap.insert m i x') ≡ + bigOpM (op := op) (unit := unit) Φ m := by + intro hi hΦ + rw [← FiniteMapLaws.insert_delete m i x'] + refine Equiv.trans (insert Φ (FiniteMap.delete m i) i x' (FiniteMapLaws.get?_delete_same m i)) ?_ + refine Equiv.trans (Monoid.op_proper (Equiv.symm hΦ) Equiv.rfl) ?_ + exact Equiv.symm (delete Φ m i x hi) + +/-- Corresponds to Rocq's `big_opM_fn_insert`. -/ +theorem fn_insert {B : Type w} [DecidableEq B] (g : K → V → B → M) (f : K → B) (m : M' V) + (i : K) (x : V) (b : B) (hi : FiniteMap.get? m i = none) : + bigOpM (op := op) (unit := unit) (fun k y => g k y (if k = i then b else f k)) + (FiniteMap.insert m i x) ≡ + op (g i x b) (bigOpM (op := op) (unit := unit) (fun k y => g k y (f k)) m) := by + have h1 := insert (op := op) (unit := unit) (fun k y => g k y (if k = i then b else f k)) m i x hi + refine Equiv.trans h1 ?_ + apply Monoid.op_proper + · simp + · apply proper (op := op) (unit := unit) + intros k y hk + have hne : k ≠ i := fun heq => by rw [heq] at hk; rw [hi] at hk; cases hk + simp [hne] + +/-- Corresponds to Rocq's `big_opM_fn_insert'`. -/ +theorem fn_insert' (f : K → M) (m : M' V) (i : K) (x : V) (P : M) + (hi : FiniteMap.get? m i = none) : + bigOpM (op := op) (unit := unit) (fun k _ => if k = i then P else f k) + (FiniteMap.insert m i x) ≡ + op P (bigOpM (op := op) (unit := unit) (fun k _ => f k) m) := by + have h1 := insert (op := op) (unit := unit) (fun k _ => if k = i then P else f k) m i x hi + refine Equiv.trans h1 ?_ + apply Monoid.op_proper + · simp + · apply proper (op := op) (unit := unit) + intros k y hk + have hne : k ≠ i := fun heq => by rw [heq] at hk; rw [hi] at hk; cases hk + simp [hne] + + +omit [DecidableEq K] [DecidableEq V] in +private theorem filter_list_aux (Φ : K × V → M) (φ : K → V → Bool) (l : List (K × V)) : + bigOpL op unit (fun _ kv => Φ kv) (l.filter (fun kv => φ kv.1 kv.2)) ≡ + bigOpL op unit (fun _ kv => if φ kv.1 kv.2 then Φ kv else unit) l := by + induction l with + | nil => simp only [List.filter, BigOpL.nil]; exact Equiv.rfl + | cons kv kvs ih => + simp only [List.filter] + cases hp : φ kv.1 kv.2 with + | false => + simp only [BigOpL.cons, hp] + exact Equiv.trans ih (Equiv.symm (Monoid.op_left_id _)) + | true => + simp only [BigOpL.cons, hp] + exact Monoid.op_congr_r ih + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_filter'`. -/ +theorem filter' [FiniteMapLawsSelf K M'] (φ : K → V → Bool) (Φ : K → V → M) (m : M' V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.filter φ m) ≡ + bigOpM (op := op) (unit := unit) (fun k x => if φ k x then Φ k x else unit) m := by + unfold bigOpM + have hperm := toList_filter m φ + have heq : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) + (FiniteMap.toList (FiniteMap.filter φ m)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) + ((FiniteMap.toList m).filter (fun kv => φ kv.1 kv.2)) := + BigOpL.perm _ hperm + refine Equiv.trans heq ?_ + exact filter_list_aux (fun kv => Φ kv.1 kv.2) φ (FiniteMap.toList m) + +/-- Corresponds to Rocq's `big_opM_union`. -/ +theorem union (Φ : K → V → M) (m1 m2 : M' V) (hdisj : m1 ##ₘ m2) : + bigOpM (op := op) (unit := unit) Φ (m1 ∪ m2) ≡ + op (bigOpM (op := op) (unit := unit) Φ m1) (bigOpM (op := op) (unit := unit) Φ m2) := by + apply FiniteMapLaws.induction_on (P := fun m1 => + m1 ##ₘ m2 → + bigOpM (op := op) (unit := unit) Φ (m1 ∪ m2) ≡ + op (bigOpM (op := op) (unit := unit) Φ m1) (bigOpM (op := op) (unit := unit) Φ m2)) + · intro _ + rw [FiniteMapLaws.ext (∅ ∪ m2) m2 fun k => by simp [FiniteMapLaws.get?_union, FiniteMapLaws.get?_empty], empty] + exact (Monoid.op_left_id _).symm + · intro i x m hi_none IH hdisj' + have hi_m2 : get? m2 i = none := by simpa [FiniteMapLaws.get?_insert_same] using FiniteMapLaws.disjoint_iff (Std.insert m i x) m2 |>.mp hdisj' i + have hm_disj : m ##ₘ m2 := fun k ⟨hk1, hk2⟩ => hdisj' k ⟨by + by_cases h : i = k <;> simp [FiniteMapLaws.get?_insert_same, FiniteMapLaws.get?_insert_ne, *], hk2⟩ + rw [← FiniteMapLaws.ext (Std.insert (m ∪ m2) i x) (Std.insert m i x ∪ m2) fun k => congrFun (FiniteMapLaws.union_insert_left m m2 i x) k] + refine (insert Φ (m ∪ m2) i x (by simp [FiniteMapLaws.get?_union_none, hi_none, hi_m2])).trans ?_ + refine (Monoid.op_congr_r (IH hm_disj)).trans ?_ + refine (Monoid.op_assoc _ _ _).symm.trans ?_ + exact Monoid.op_congr_l (insert Φ m i x hi_none).symm + · exact hdisj + +omit [DecidableEq V] [DecidableEq K] [FiniteMapLaws K M'] in +/-- Corresponds to Rocq's `big_opM_op`. -/ +theorem op_distr (Φ Ψ : K → V → M) (m : M' V) : + bigOpM (op := op) (unit := unit) (fun k x => op (Φ k x) (Ψ k x)) m ≡ + op (bigOpM (op := op) (unit := unit) Φ m) (bigOpM (op := op) (unit := unit) Ψ m) := by + simp only [bigOpM] + have h := BigOpL.op_distr (op := op) (unit := unit) + (fun _ kv => Φ kv.1 kv.2) (fun _ kv => Ψ kv.1 kv.2) (FiniteMap.toList m) + exact h + +private theorem closed_aux (P : M → Prop) (Φ : K → V → M) + (hproper : ∀ x y, x ≡ y → (P x ↔ P y)) + (hunit : P unit) + (hop : ∀ x y, P x → P y → P (op x y)) : + ∀ (m' : M' V), (∀ k' x', FiniteMap.get? m' k' = some x' → P (Φ k' x')) → + P (bigOpM (op := op) (unit := unit) Φ m') := by + intro m' hf' + refine FiniteMapLaws.induction_on + (P := fun m'' => (∀ k x, FiniteMap.get? m'' k = some x → P (Φ k x)) → + P (bigOpM (op := op) (unit := unit) Φ m'')) + ?hemp ?hins m' hf' + case hemp => + intro _ + simp only [empty] + exact hunit + case hins => + intro k x m'' hm'' IH hf'' + have h_ins := insert (op := op) (unit := unit) Φ m'' k x hm'' + apply (hproper _ _ h_ins) |>.mpr + apply hop + · apply hf'' + exact FiniteMapLaws.get?_insert_same m'' k x + · apply IH + intro k' x' hget' + apply hf'' + rw [FiniteMapLaws.get?_insert_ne m'' k k' x] + · exact hget' + · intro heq + subst heq + rw [hget'] at hm'' + exact Option.noConfusion hm'' + +/-- Corresponds to Rocq's `big_opM_closed`. -/ +theorem closed (P : M → Prop) (Φ : K → V → M) (m : M' V) + (hproper : ∀ x y, x ≡ y → (P x ↔ P y)) + (hunit : P unit) + (hop : ∀ x y, P x → P y → P (op x y)) + (hf : ∀ k x, FiniteMap.get? m k = some x → P (Φ k x)) : + P (bigOpM (op := op) (unit := unit) Φ m) := + closed_aux P Φ hproper hunit hop m hf + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_kmap`. -/ +theorem kmap {M'' : Type _ → Type _} {K' : Type _} [DecidableEq K'] [FiniteMap K' M''] + [FiniteMapLaws K' M''] [FiniteMapKmapLaws K K' M' M''] + (h : K → K') (hinj : ∀ {x y}, h x = h y → x = y) (Φ : K' → V → M) (m : M' V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.kmap (M' := M'') h m : M'' V) ≡ + bigOpM (op := op) (unit := unit) (fun k v => Φ (h k) v) m := by + simp only [bigOpM] + have h1 : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList (FiniteMap.kmap (M' := M'') h m : M'' V)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) ((FiniteMap.toList m).map (fun kv => (h kv.1, kv.2))) := by + apply BigOpL.perm + exact FiniteMapKmapLaws.toList_kmap h m hinj + apply Equiv.trans h1 + exact BigOpL.map (op := op) (unit := unit) (fun kv => (h kv.1, kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +omit [DecidableEq V] in +/-- Corresponds to Rocq's `big_opM_map_seq`. -/ +theorem map_seq {M'' : Type w → Type _} [FiniteMap Nat M''] [FiniteMapLaws Nat M''] + [FiniteMapSeqLaws M''] + (Φ : Nat → V → M) (start : Nat) (l : List V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.map_seq (M := M'') start l : M'' V) ≡ + bigOpL op unit (fun i x => Φ (start + i) x) l := by + simp only [bigOpM] + refine Equiv.trans (BigOpL.perm _ (FiniteMapSeqLaws.toList_map_seq start l)) ?_ + induction l generalizing start with + | nil => simp + | cons x xs ih => + simp only [List.mapIdx_cons, BigOpL.cons, Nat.zero_add, Nat.add_zero] + have : xs.mapIdx (fun i v => (i + 1 + start, v)) = xs.mapIdx (fun i v => (i + (start + 1), v)) := by + congr 1; funext i v; rw [Nat.add_assoc, Nat.add_comm 1 start] + rw [this] + exact Monoid.op_proper Equiv.rfl (Equiv.trans (ih (start + 1)) (BigOpL.congr' fun i _ => by simp [Nat.add_assoc, Nat.add_comm 1])) + +/-- Corresponds to Rocq's `big_opM_sep_zip_with`. -/ +theorem sep_zip_with {A : Type _} {B : Type _} {C : Type _} + [DecidableEq A] [DecidableEq B] [DecidableEq C] + (f : A → B → C) (g1 : C → A) (g2 : C → B) + (h1 : K → A → M) (h2 : K → B → M) (m1 : M' A) (m2 : M' B) + (hg1 : ∀ x y, g1 (f x y) = x) + (hg2 : ∀ x y, g2 (f x y) = y) + (hdom : ∀ k, (FiniteMap.get? m1 k).isSome ↔ (FiniteMap.get? m2 k).isSome) : + bigOpM (op := op) (unit := unit) (fun k xy => op (h1 k (g1 xy)) (h2 k (g2 xy))) + (FiniteMap.zipWith f m1 m2) ≡ + op (bigOpM (op := op) (unit := unit) h1 m1) (bigOpM (op := op) (unit := unit) h2 m2) := by + have h_op := op_distr (op := op) (unit := unit) + (fun k xy => h1 k (g1 xy)) (fun k xy => h2 k (g2 xy)) (FiniteMap.zipWith f m1 m2) + apply Equiv.trans h_op + apply Monoid.op_proper + · have h1_fmap := map (op := op) (unit := unit) g1 h1 (FiniteMap.zipWith f m1 m2) + apply Equiv.trans (Equiv.symm h1_fmap) + have heq := FiniteMapLaws.map_zipWith_right f g1 m1 m2 hg1 hdom + rw [heq] + · have h2_fmap := map (op := op) (unit := unit) g2 h2 (FiniteMap.zipWith f m1 m2) + apply Equiv.trans (Equiv.symm h2_fmap) + have heq := FiniteMapLaws.map_zipWith_left f g2 m1 m2 hg2 hdom + rw [heq] + +/-- Corresponds to Rocq's `big_opM_sep_zip`. -/ +theorem sep_zip {A : Type _} {B : Type _} + [DecidableEq A] [DecidableEq B] + (h1 : K → A → M) (h2 : K → B → M) (m1 : M' A) (m2 : M' B) + (hdom : ∀ k, (FiniteMap.get? m1 k).isSome ↔ (FiniteMap.get? m2 k).isSome) : + bigOpM (op := op) (unit := unit) (fun k xy => op (h1 k xy.1) (h2 k xy.2)) + (FiniteMap.zip m1 m2) ≡ + op (bigOpM (op := op) (unit := unit) h1 m1) (bigOpM (op := op) (unit := unit) h2 m2) := by + simp only [FiniteMap.zip] + exact sep_zip_with (op := op) (unit := unit) Prod.mk Prod.fst Prod.snd h1 h2 m1 m2 + (fun _ _ => rfl) (fun _ _ => rfl) hdom + +end BigOpM + +end Iris.Algebra diff --git a/src/Iris/Algebra/CMRA.lean b/src/Iris/Algebra/CMRA.lean index d8c1efbf..5423677a 100644 --- a/src/Iris/Algebra/CMRA.lean +++ b/src/Iris/Algebra/CMRA.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Mario Carneiro, Сухарик (@suhr), Markus de Medeiros +Authors: Mario Carneiro, Сухарик (@suhr), Markus de Medeiros, Puming Liu -/ import Iris.Algebra.OFE @@ -1365,6 +1365,16 @@ theorem valid_snd {x : α × β} (h : ✓ x) : ✓ x.snd := h.right theorem validN_fst {n} {x : α × β} (h : ✓{n} x) : ✓{n} x.fst := h.left theorem validN_snd {n} {x : α × β} (h : ✓{n} x) : ✓{n} x.snd := h.right +theorem incN_iff {n} (a a' : α) (b b' : β) : + a ≼{n} a' ∧ b ≼{n} b' ↔ (a, b) ≼{n} (a', b') := by + constructor <;>simp [CMRA.IncludedN] + · rintro x ha y hb + exists x, y + · rintro x y ⟨ha, hb⟩ + constructor + exists x + exists y + instance [CMRA.Discrete α] [CMRA.Discrete β]: CMRA.Discrete (α × β) where discrete_valid := by rintro ⟨_, _⟩ @@ -1373,6 +1383,72 @@ instance [CMRA.Discrete α] [CMRA.Discrete β]: CMRA.Discrete (α × β) where end Prod +section ProdOF + +variable [OFE A] [OFE A'] [OFE B] [OFE B'] + +instance (f : A → A') (g : B → B') [NonExpansive f] [NonExpansive g] : NonExpansive (Prod.map f g) where + ne := by + rintro _ _ _ ⟨_, _⟩ + constructor <;> simp <;> + apply (inferInstance : NonExpansive _).ne <;> + assumption + +theorem Prod.map_ne (f f' : A → A') (g g' : B → B') [NonExpansive f] [NonExpansive f'] [NonExpansive g] [NonExpansive g'] : + (∀ a, f a ≡{n}≡ f' a) → (∀ a, g a ≡{n}≡ g' a) → Prod.map f g x ≡{n}≡ Prod.map f' g' x := by + intros + cases x + constructor <;> simp_all + +instance Prod.mapO (f : A -n> A') (g : B -n> B') : A × B -n> A' × B' where + f := Prod.map f g + ne := inferInstance + +abbrev ProdOF (F1 : COFE.OFunctorPre) (F2 : COFE.OFunctorPre) : COFE.OFunctorPre := + fun A B => (F1 A B) × (F2 A B) + +instance [OF1: COFE.OFunctor F1] [OF2: COFE.OFunctor F2] : COFE.OFunctor (ProdOF F1 F2) where + cofe := inferInstance + map f g := Prod.mapO (OF1.map f g) (OF2.map f g) + map_ne.ne _ _ _ Hx _ _ Hy _ := by + constructor <;> apply COFE.OFunctor.map_ne.ne <;> assumption + map_id x := by + constructor <;> apply COFE.OFunctor.map_id + map_comp f g f' g' x := by + constructor <;> apply COFE.OFunctor.map_comp + +instance [COFE.OFunctorContractive F1] [COFE.OFunctorContractive F2] : COFE.OFunctorContractive (ProdOF F1 F2) where + map_contractive.1 H _ := by + apply Prod.map_ne <;> intro <;> apply COFE.OFunctorContractive.map_contractive.1 <;> assumption + +end ProdOF + +section ProdMorph + +variable [CMRA A] [CMRA A'] [CMRA B] [CMRA B'] + +instance Prod.mapC (f : A -C> A') (g : B -C> B') : A × B -C> A' × B' where + f := Prod.map f g + ne := inferInstance + validN {n x} hval := by + simp [CMRA.ValidN, ValidN] at hval ⊢ + cases hval + constructor <;> apply CMRA.Hom.validN <;> assumption + pcore x := by + simp [Option.map, Prod.map, CMRA.pcore, pcore] + have h2 := CMRA.Hom.pcore g x.snd + have h1 := CMRA.Hom.pcore f x.fst + rcases h : (CMRA.pcore x.fst) with _ | x1 + · rcases _ : CMRA.pcore (f.f x.fst) <;> simp_all + · rcases h' : (CMRA.pcore x.snd) with _ | x2 <;> + rcases _ : CMRA.pcore (f.f x.fst) <;> + rcases _ : CMRA.pcore (g.f x.snd) <;> simp_all + constructor <;> simp_all + op x y := by + constructor <;> apply CMRA.Hom.op + +end ProdMorph + section optionOF variable (F : COFE.OFunctorPre) diff --git a/src/Iris/Algebra/CoPset.lean b/src/Iris/Algebra/CoPset.lean new file mode 100644 index 00000000..9ea38063 --- /dev/null +++ b/src/Iris/Algebra/CoPset.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.Algebra.CMRA +import Iris.Algebra.OFE +import Iris.Algebra.Updates +import Iris.Algebra.LocalUpdates +import Iris.Std.CoPset +import Iris.Std.GSet + +/-! # CoPset and GSet Resource Algebras + +Reference: `iris/algebra/coPset.v`, `iris/algebra/gset.v` + +Resource algebra (CMRA) instances for invariant mask sets, used by world +satisfaction to track enabled and disabled invariants. + +Three CMRAs are defined: + +- **`CoPset` union CMRA** — composition is set union, everything is valid, and every + element is its own core. Used where masks combine freely (e.g. `ownI` tokens). +- **`CoPsetDisj` disjoint union CMRA** — composition requires disjointness and + produces `invalid` otherwise. Used for `ownE` (enabled invariant tokens) where + double-opening must be prevented: `ownE {[i]} ∗ ownE {[i]}` is invalid. +- **`GSetDisj` disjoint union CMRA** — same disjointness-enforcing pattern for + finite sets. Used for `ownD` (disabled invariant tokens). +-/ + +namespace Iris + +open OFE CMRA + +/-! ## CoPset OFE + Union CMRA -/ + +instance : OFE CoPset := OFE.ofDiscrete (· = ·) ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ +instance : OFE.Discrete CoPset where discrete_0 := id +instance : OFE.Leibniz CoPset where eq_of_eqv := id + +/-- Union-based CMRA on `CoPset`. Always valid, idempotent core, unit is `∅`. -/ +instance : CMRA CoPset where + pcore := some + op := (· ∪ ·) + ValidN _ _ := True + Valid _ := True + op_ne.ne _ _ _ h := Dist.of_eq (eq_of_eqv (discrete h) ▸ rfl) + pcore_ne {_ y _ _} h := by + -- core respects discrete equality + rintro ⟨rfl⟩ + exact ⟨y, congrArg _ (eq_of_eqv (discrete h.symm)), .rfl⟩ + validN_ne _ _ := .intro + valid_iff_validN := .symm <| forall_const Nat + validN_succ := (·) + validN_op_left := id + assoc {x y z} := .of_eq (CoPset.union_assoc x y z).symm + comm {x y} := .of_eq (CoPset.union_comm x y) + pcore_op_left {_ _} := by + -- core of union collapses by idempotence + rintro ⟨rfl⟩ + exact .of_eq (CoPset.union_idem _) + pcore_idem := by + -- core is identity for union CMRA + simp + pcore_op_mono {_ _} := by + -- monotonicity follows from unit core + rintro ⟨rfl⟩ z + exact ⟨z, .rfl⟩ + extend _ h := ⟨_, _, discrete h, .rfl, .rfl⟩ + +instance : CMRA.Discrete CoPset where discrete_valid := id + +instance : UCMRA CoPset where + unit := ∅ + unit_valid := trivial + unit_left_id {x} := .of_eq (CoPset.empty_union x) + pcore_unit := .symm .rfl + +/-- CMRA inclusion coincides with subset for the union-based `CoPset` CMRA. -/ +theorem coPset_included {x y : CoPset} : x ≼ y ↔ x ⊆ y := by + -- inclusion matches subset for union-based CMRA + constructor + · rintro ⟨z, hz⟩; have := eq_of_eqv hz + intro n hn; rw [this]; exact Or.inl hn + · intro h + obtain ⟨z, hz, _⟩ := CoPset.subseteq_disjoint_union h + exact ⟨z, .of_eq hz⟩ + +/-- All frame-preserving updates are valid since `CoPset` validity is trivial. -/ +theorem coPset_update (x y : CoPset) : x ~~> y := by + -- all updates are valid since validity is trivial + intro _ _ _; trivial + +instance (x : CoPset) : CMRA.CoreId x where + core_id := by + -- core is identity for coPset + simp [pcore] + +/-! ## CoPset Disjoint Union CMRA -/ + +/-- Disjoint union wrapper for `CoPset`. Composing overlapping sets yields `invalid`. -/ +inductive CoPsetDisj where + | coPset : CoPset → CoPsetDisj + | invalid : CoPsetDisj + +instance : OFE CoPsetDisj := OFE.ofDiscrete (· = ·) ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ +instance : OFE.Discrete CoPsetDisj where discrete_0 := id +instance : OFE.Leibniz CoPsetDisj where eq_of_eqv := id + +/-- Helper: the disjoint op on CoPsetDisj. -/ +noncomputable def CoPsetDisj.op' : CoPsetDisj → CoPsetDisj → CoPsetDisj + | .coPset x, .coPset y => + if CoPset.Disjoint x y then .coPset (x ∪ y) else .invalid + | _, _ => .invalid + +private theorem CoPsetDisj.assoc_aux (x y z : CoPsetDisj) : + op' (op' x y) z = op' x (op' y z) := by + -- case split on validity and disjointness + cases x <;> cases y <;> cases z <;> simp [op'] + rename_i x y z + by_cases hxy : CoPset.Disjoint x y + · by_cases hyz : CoPset.Disjoint y z + · -- both disjoint, reduce to associativity of union + by_cases hxyz : CoPset.Disjoint (x ∪ y) z + · have hxyz' : CoPset.Disjoint x (y ∪ z) := + fun n ⟨hx, hyz'⟩ => hyz'.elim (hxy n ⟨hx, ·⟩) (hxyz n ⟨.inl hx, ·⟩) + simp [hxy, hyz, hxyz, hxyz', CoPset.union_assoc] + · have hxyz' : ¬CoPset.Disjoint x (y ∪ z) := by + -- contradiction from disjointness transfer + intro h; exact hxyz fun n ⟨hxy', hz⟩ => + hxy'.elim (fun hx => h n ⟨hx, .inr hz⟩) (hyz n ⟨·, hz⟩) + simp [hxy, hyz, hxyz, hxyz'] + · -- right side is invalid; show left side invalid using subset + have hxyz : ¬CoPset.Disjoint (x ∪ y) z := by + -- if (x ∪ y) disjoint z, then y disjoint z + intro h; apply hyz; intro n hn + exact h n ⟨Or.inr hn.1, hn.2⟩ + simp [hxy, hyz, hxyz] + · by_cases hyz : CoPset.Disjoint y z + · -- left side invalid; show right side invalid using subset + have hxyz : ¬CoPset.Disjoint x (y ∪ z) := by + -- if x disjoint (y ∪ z), then x disjoint y + intro h; apply hxy; intro n hn + exact h n ⟨hn.1, Or.inl hn.2⟩ + simp [hxy, hyz, hxyz] + · -- both sides are invalid + simp [hxy, hyz] + +private theorem CoPsetDisj.comm_aux (x y : CoPsetDisj) : op' x y = op' y x := by + -- symmetry of disjoint union + cases x <;> cases y <;> simp [op'] + rename_i x y + by_cases hxy : CoPset.Disjoint x y + · simp [hxy, CoPset.disjoint_comm.mp hxy, CoPset.union_comm] + · have hyx : ¬CoPset.Disjoint y x := by + -- disjointness is symmetric + intro h; exact hxy (CoPset.disjoint_comm.mp h) + simp [hxy, hyx] + +/-- Disjoint union CMRA on `CoPsetDisj`. Valid when the composed sets are disjoint. -/ +noncomputable instance : CMRA CoPsetDisj where + pcore _ := some (.coPset ∅) + op := CoPsetDisj.op' + ValidN _ x := match x with | .coPset _ => True | .invalid => False + Valid x := match x with | .coPset _ => True | .invalid => False + op_ne.ne _ _ _ h := Dist.of_eq (eq_of_eqv (discrete h) ▸ rfl) + pcore_ne _ := by + -- core is the unit element + rintro ⟨rfl⟩ + exact ⟨_, rfl, .rfl⟩ + validN_ne {_ x y} h hv := by + -- validity respects discrete equality + have := eq_of_eqv (discrete h); subst this; exact hv + valid_iff_validN := .symm <| forall_const Nat + validN_succ := (·) + validN_op_left {x y} h := by + -- op validity implies left validity by case analysis + cases x <;> cases y <;> simp [CoPsetDisj.op'] at h ⊢ + assoc {x y z} := .of_eq (CoPsetDisj.assoc_aux x y z).symm + comm {x y} := .of_eq (CoPsetDisj.comm_aux x y) + pcore_op_left {x _} := by + -- unit core acts as left identity + rintro ⟨rfl⟩ + cases x with + | coPset x => + -- disjoint union with empty yields the original element + exact .of_eq (by + -- reduce op' with empty and union identity + simp [CoPsetDisj.op', CoPset.disjoint_empty_left, CoPset.empty_union]) + | invalid => + -- invalid absorbs the operation + exact .of_eq (by + -- op' with invalid collapses to invalid + simp [CoPsetDisj.op']) + pcore_idem := by + -- idempotence of the core + simp + pcore_op_mono {_ _} := by + -- core monotonicity follows from unit core + rintro ⟨rfl⟩ _ + refine ⟨.coPset ∅, ?_⟩ + -- compute the core of the op and the op of cores + apply Equiv.of_eq + simp [CoPsetDisj.op', CoPset.disjoint_empty_left, CoPset.empty_union] + extend _ h := ⟨_, _, discrete h, .rfl, .rfl⟩ + +instance : CMRA.Discrete CoPsetDisj where discrete_valid := id + +noncomputable instance : UCMRA CoPsetDisj where + unit := .coPset ∅ + unit_valid := trivial + unit_left_id {x} := by + -- unit acts as left identity + change CoPsetDisj.op' (.coPset ∅) x ≡ x + cases x with + | coPset x => + -- disjoint union with empty yields the original element + exact .of_eq (by + -- simplify by disjointness with empty + have hdisj : CoPset.Disjoint ∅ x := CoPset.disjoint_empty_left x + simp [CoPsetDisj.op', hdisj, CoPset.empty_union]) + | invalid => + -- invalid absorbs the operation + exact .of_eq (by + -- op' with invalid collapses to invalid + simp [CoPsetDisj.op']) + pcore_unit := .symm .rfl + +/-! ### CoPsetDisj Key Lemmas -/ + +/-- Composing disjoint sets produces their union. -/ +theorem coPset_disj_union {x y : CoPset} (h : CoPset.Disjoint x y) : + (CoPsetDisj.coPset x : CoPsetDisj) • CoPsetDisj.coPset y = CoPsetDisj.coPset (x ∪ y) := by + -- unfold the disjoint op + show CoPsetDisj.op' _ _ = _ + simp [CoPsetDisj.op', h] + +/-- A composition of two `CoPsetDisj` values is valid iff the underlying sets are disjoint. -/ +theorem coPset_disj_valid_op {x y : CoPset} : + ✓ ((CoPsetDisj.coPset x : CoPsetDisj) • CoPsetDisj.coPset y) ↔ CoPset.Disjoint x y := by + -- validity reduces to disjointness by case split + change ✓ (CoPsetDisj.op' (CoPsetDisj.coPset x) (CoPsetDisj.coPset y)) ↔ _ + by_cases h : CoPset.Disjoint x y <;> simp [CoPsetDisj.op', h, CMRA.Valid] + +/-- CMRA inclusion coincides with subset for the disjoint `CoPsetDisj` CMRA. -/ +theorem coPset_disj_included {x y : CoPset} : + (CoPsetDisj.coPset x : CoPsetDisj) ≼ CoPsetDisj.coPset y ↔ x ⊆ y := by + -- inclusion matches subset for disjoint union CMRA + constructor + · rintro ⟨z, hz⟩ + have heq := eq_of_eqv hz + -- heq : .coPset y = CoPsetDisj.op' (.coPset x) z + change CoPsetDisj.coPset y = CoPsetDisj.op' (CoPsetDisj.coPset x) z at heq + cases z with + | coPset z => + -- reduce the op' equation by disjointness + by_cases hd : CoPset.Disjoint x z + · simp [CoPsetDisj.op', hd] at heq + cases heq + intro n hn; exact Or.inl hn + · have : False := by + -- contradiction: op' becomes invalid + simp [CoPsetDisj.op', hd] at heq + exact False.elim this + | invalid => + -- invalid case contradicts the constructor equation + have : False := by + -- simplify to impossible constructor equality + simp [CoPsetDisj.op'] at heq + exact False.elim this + · intro h + obtain ⟨z, hz, hdisj⟩ := CoPset.subseteq_disjoint_union h + exact ⟨.coPset z, .of_eq (by + -- rewrite with the disjoint union decomposition + rw [hz]; exact (coPset_disj_union hdisj).symm)⟩ + +/-! ## GSet Disjoint Union CMRA -/ + +/-- Disjoint union wrapper for `GSet`. Composing overlapping sets yields `invalid`. -/ +inductive GSetDisj where + | gset : GSet → GSetDisj + | invalid : GSetDisj + +instance : OFE GSetDisj := OFE.ofDiscrete (· = ·) ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ +instance : OFE.Discrete GSetDisj where discrete_0 := id +instance : OFE.Leibniz GSetDisj where eq_of_eqv := id + +/-- Helper: the disjoint op on GSetDisj. -/ +noncomputable def GSetDisj.op' : GSetDisj → GSetDisj → GSetDisj + | .gset x, .gset y => + if GSet.Disjoint x y then .gset (x ∪ y) else .invalid + | _, _ => .invalid + +private theorem GSetDisj.assoc_aux (x y z : GSetDisj) : + op' (op' x y) z = op' x (op' y z) := by + -- case split on disjointness flags + cases x <;> cases y <;> cases z <;> simp [op'] + rename_i x y z + by_cases hxy : GSet.Disjoint x y + · by_cases hyz : GSet.Disjoint y z + · -- both disjoint, reduce to associativity of union + by_cases hxyz : GSet.Disjoint (x ∪ y) z + · have hxyz' : GSet.Disjoint x (y ∪ z) := + fun n ⟨hx, hyz'⟩ => hyz'.elim (hxy n ⟨hx, ·⟩) (hxyz n ⟨.inl hx, ·⟩) + simp [hxy, hyz, hxyz, hxyz', GSet.union_assoc] + · have hxyz' : ¬GSet.Disjoint x (y ∪ z) := by + -- contradiction from disjointness transfer + intro h; exact hxyz fun n ⟨hxy', hz⟩ => + hxy'.elim (fun hx => h n ⟨hx, .inr hz⟩) (hyz n ⟨·, hz⟩) + simp [hxy, hyz, hxyz, hxyz'] + · -- right side is invalid; show left side invalid using subset + have hxyz : ¬GSet.Disjoint (x ∪ y) z := by + -- if (x ∪ y) disjoint z, then y disjoint z + intro h; apply hyz; intro n hn + exact h n ⟨Or.inr hn.1, hn.2⟩ + simp [hxy, hyz, hxyz] + · by_cases hyz : GSet.Disjoint y z + · -- left side invalid; show right side invalid using subset + have hxyz : ¬GSet.Disjoint x (y ∪ z) := by + -- if x disjoint (y ∪ z), then x disjoint y + intro h; apply hxy; intro n hn + exact h n ⟨hn.1, Or.inl hn.2⟩ + simp [hxy, hyz, hxyz] + · -- both sides are invalid + simp [hxy, hyz] + +private theorem GSetDisj.comm_aux (x y : GSetDisj) : op' x y = op' y x := by + -- symmetry of disjoint union on GSet + cases x <;> cases y <;> simp [op'] + rename_i x y + by_cases hxy : GSet.Disjoint x y + · simp [hxy, GSet.disjoint_comm.mp hxy, GSet.union_comm] + · have hyx : ¬GSet.Disjoint y x := by + -- disjointness is symmetric + intro h; exact hxy (GSet.disjoint_comm.mp h) + simp [hxy, hyx] + +/-- Disjoint union CMRA on `GSetDisj`. Valid when the composed sets are disjoint. -/ +noncomputable instance : CMRA GSetDisj where + pcore _ := some (.gset ∅) + op := GSetDisj.op' + ValidN _ x := match x with | .gset _ => True | .invalid => False + Valid x := match x with | .gset _ => True | .invalid => False + op_ne.ne _ _ _ h := Dist.of_eq (eq_of_eqv (discrete h) ▸ rfl) + pcore_ne _ := by + -- core is the unit element + rintro ⟨rfl⟩ + exact ⟨_, rfl, .rfl⟩ + validN_ne {_ x y} h hv := by + -- validity respects discrete equality + have := eq_of_eqv (discrete h); subst this; exact hv + valid_iff_validN := .symm <| forall_const Nat + validN_succ := (·) + validN_op_left {x y} h := by + -- op validity implies left validity by case analysis + cases x <;> cases y <;> simp [GSetDisj.op'] at h ⊢ + assoc {x y z} := .of_eq (GSetDisj.assoc_aux x y z).symm + comm {x y} := .of_eq (GSetDisj.comm_aux x y) + pcore_op_left {x _} := by + -- unit core acts as left identity + rintro ⟨rfl⟩ + cases x with + | gset x => + -- disjoint union with empty yields the original element + exact .of_eq (by + -- reduce op' with empty and union identity + simp [GSetDisj.op', GSet.disjoint_empty_left, GSet.empty_union]) + | invalid => + -- invalid absorbs the operation + exact .of_eq (by + -- op' with invalid collapses to invalid + simp [GSetDisj.op']) + pcore_idem := by + -- idempotence of the core + simp + pcore_op_mono {_ _} := by + -- core monotonicity follows from unit core + rintro ⟨rfl⟩ _ + refine ⟨.gset ∅, ?_⟩ + -- compute the core of the op and the op of cores + apply Equiv.of_eq + simp [GSetDisj.op', GSet.disjoint_empty_left, GSet.empty_union] + extend _ h := ⟨_, _, discrete h, .rfl, .rfl⟩ + +instance : CMRA.Discrete GSetDisj where discrete_valid := id + +noncomputable instance : UCMRA GSetDisj where + unit := .gset ∅ + unit_valid := trivial + unit_left_id {x} := by + -- unit acts as left identity + change GSetDisj.op' (.gset ∅) x ≡ x + cases x with + | gset x => + -- disjoint union with empty yields the original element + exact .of_eq (by + -- simplify by disjointness with empty + have hdisj : GSet.Disjoint ∅ x := GSet.disjoint_empty_left x + simp [GSetDisj.op', hdisj, GSet.empty_union]) + | invalid => + -- invalid absorbs the operation + exact .of_eq (by + -- op' with invalid collapses to invalid + simp [GSetDisj.op']) + pcore_unit := .symm .rfl + +/-! ### GSetDisj Key Lemmas -/ + +/-- Composing disjoint sets produces their union. -/ +theorem gset_disj_union {x y : GSet} (h : GSet.Disjoint x y) : + (GSetDisj.gset x : GSetDisj) • GSetDisj.gset y = GSetDisj.gset (x ∪ y) := by + -- unfold the disjoint op + show GSetDisj.op' _ _ = _ + simp [GSetDisj.op', h] + +/-- A composition of two `GSetDisj` values is valid iff the underlying sets are disjoint. -/ +theorem gset_disj_valid_op {x y : GSet} : + ✓ ((GSetDisj.gset x : GSetDisj) • GSetDisj.gset y) ↔ GSet.Disjoint x y := by + -- validity reduces to disjointness by case split + change ✓ (GSetDisj.op' (GSetDisj.gset x) (GSetDisj.gset y)) ↔ _ + by_cases h : GSet.Disjoint x y <;> simp [GSetDisj.op', h, CMRA.Valid] + +/-- CMRA inclusion coincides with subset for the disjoint `GSetDisj` CMRA. -/ +theorem gset_disj_included {x y : GSet} : + (GSetDisj.gset x : GSetDisj) ≼ GSetDisj.gset y ↔ x ⊆ y := by + -- inclusion matches subset for disjoint union CMRA + constructor + · rintro ⟨z, hz⟩ + have heq := eq_of_eqv hz + -- rewrite the op in the equality to the disjoint op' + change GSetDisj.gset y = GSetDisj.op' (GSetDisj.gset x) z at heq + cases z with + | gset z => + -- reduce the op' equation by disjointness + by_cases hd : GSet.Disjoint x z + · simp [GSetDisj.op', hd] at heq + cases heq + intro n hn; exact Or.inl hn + · have : False := by + -- contradiction: op' becomes invalid + simp [GSetDisj.op', hd] at heq + exact False.elim this + | invalid => + -- invalid case contradicts the constructor equation + have : False := by + -- simplify to impossible constructor equality + simp [GSetDisj.op'] at heq + exact False.elim this + · intro h + obtain ⟨z, hz, hdisj⟩ := GSet.subseteq_disjoint_union h + exact ⟨.gset z, .of_eq (by + -- rewrite with the disjoint union decomposition + rw [hz]; exact (gset_disj_union hdisj).symm)⟩ + +end Iris diff --git a/src/Iris/Algebra/Heap.lean b/src/Iris/Algebra/Heap.lean index c081105a..e989e5df 100644 --- a/src/Iris/Algebra/Heap.lean +++ b/src/Iris/Algebra/Heap.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Markus de Medeiros. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Markus de Medeiros +Authors: Markus de Medeiros, Puming Liu -/ import Iris.Algebra.CMRA @@ -462,3 +462,124 @@ nonrec instance [HD : CMRA.Discrete V] [Heap T K V] : Discrete T where discrete_valid {_} := (CMRA.Discrete.discrete_valid <| · ·) end Heap + +section HeapFunctor + +variable {K} (H : Type _ → Type _) [∀ V, Heap (H V) K V] [∀ α β, HasHeapMap (H α) (H β) K α β] + +section HeapMap + +def Heap.map' [OFE α] [OFE β] (f : α → β) : H α → H β:= HasHeapMap.hhmap (fun _ a => some (f a)) + +local instance [OFE α] [OFE β] {f : α → β} [hne : OFE.NonExpansive f] : OFE.NonExpansive (Heap.map' H f) where + ne := by + simp only [OFE.Dist, Option.Forall₂, Heap.map', hhmap_get] + intro n m1 m2 + apply forall_imp + intro k + cases Store.get m1 k <;> cases Store.get m2 k <;> simp + apply OFE.NonExpansive.ne + +def Heap.mapO [OFE α] [OFE β] (f : α -n> β) : OFE.Hom (H α) (H β) where + f := Heap.map' H f + ne := inferInstance + +def Heap.map_ne [OFE α] [OFE β] (f g : α -n> β) (heq: f ≡{n}≡ g) : + Heap.mapO H f ≡{n}≡ Heap.mapO H g := by + simp [OFE.Dist, mapO, Option.Forall₂, map', hhmap_get] + intro m k + cases Store.get m k <;> simp + expose_names; exact heq val + +def Heap.map_compose [OFE α] [OFE β] [OFE γ] (f : α -n> β) (g : β -n> γ) m : + Heap.mapO H (g.comp f) m ≡ Heap.mapO H g (Heap.mapO H f m) := by + intro k + simp [mapO, map', hhmap_get] + cases Store.get m k <;> simp + +def Heap.mapC [CMRA α] [CMRA β] (f : α -C> β) : CMRA.Hom (H α) (H β) where + f := Heap.map' H f + ne := inferInstance + validN {n x} := by + simp only [map', CMRA.ValidN, Store.validN, optionValidN] + apply forall_imp + intro k + rw [hhmap_get] + cases (Store.get x k) <;> simp + apply CMRA.Hom.validN + pcore m := by + -- Reduce the core law to pointwise heaps and apply the CMRA core law on values. + intro k + simp [Heap.map', hhmap_get, get_hmap] + cases h : Store.get m k with + | none => simp + | some v => + simp + cases hpcore : CMRA.pcore v <;> + simpa [Option.map, Option.bind, hpcore] using (CMRA.Hom.pcore f v) + op m1 m2 := by + -- Preserve the heap op by a key-wise case split and CMRA hom op. + intro k + simp [Heap.map', hhmap_get, get_merge, CMRA.op] + cases h1 : Store.get m1 k with + | none => + cases h2 : Store.get m2 k <;> simp + | some v1 => + cases h2 : Store.get m2 k with + | none => simp + | some v2 => + simp + simpa using (CMRA.Hom.op f v1 v2) + +end HeapMap + +abbrev HeapOF (F : COFE.OFunctorPre) : COFE.OFunctorPre := + fun A B _ _ => H (F A B) + +instance {F} [COFE.OFunctor F] : COFE.OFunctor (HeapOF H F) where + cofe := inferInstance + map f g := Heap.mapO H (COFE.OFunctor.map f g) + map_ne := by + intros + constructor + intros + apply Heap.map_ne + apply COFE.OFunctor.map_ne.ne <;> simp_all + map_comp f g f' g' x := by + -- Pointwise reasoning: reduce to the underlying functor map_comp. + intro k + simp [Heap.mapO, Heap.map', hhmap_get] + cases h : Store.get x k <;> simp [COFE.OFunctor.map_comp] + map_id x := by + -- Pointwise reasoning: reduce to the underlying functor map_id. + intro k + simp [Heap.mapO, Heap.map', hhmap_get] + cases h : Store.get x k <;> simp [COFE.OFunctor.map_id] + +instance {F} [RFunctor F] : URFunctor (HeapOF H F) where + map f g := Heap.mapC H (RFunctor.map f g) + map_ne := by + -- Non-expansiveness follows from the underlying functor map_ne. + intros + constructor + intros + apply Heap.map_ne + apply RFunctor.map_ne.ne <;> simp_all + map_comp f g f' g' x := by + -- Pointwise reasoning: reduce to the underlying functor map_comp. + intro k + simp [Heap.mapC, Heap.map', hhmap_get] + cases h : Store.get x k <;> simp [RFunctor.map_comp] + map_id x := by + -- Pointwise reasoning: reduce to the underlying functor map_id. + intro k + simp [Heap.mapC, Heap.map', hhmap_get] + cases h : Store.get x k <;> simp [RFunctor.map_id] + +instance {F} [RFunctorContractive F] : URFunctorContractive (HeapOF H F) where + map_contractive.1 H m := by + -- Contractiveness lifts through heap mapping. + apply Heap.map_ne _ _ + apply (RFunctorContractive.map_contractive.1 H) + +end HeapFunctor diff --git a/src/Iris/Algebra/HeapView.lean b/src/Iris/Algebra/HeapView.lean index ade9d024..147c4ce8 100644 --- a/src/Iris/Algebra/HeapView.lean +++ b/src/Iris/Algebra/HeapView.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Markus de Medeiros. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Markus de Medeiros +Authors: Markus de Medeiros, Puming Liu -/ import Iris.Algebra.Heap import Iris.Algebra.View @@ -467,6 +467,122 @@ theorem update_frag_acquire [IsSplitFraction F] : end heapUpdates --- TODO: Port functors +section heapViewFunctor + +variable [∀ α β, HasHeapMap (H α) (H β) K α β] + +theorem heapR_map_eq [OFE A] [OFE B] [OFE A'] [OFE B'] [RFunctor T] (f : A' -n> A) (g : B -n> B') (n : Nat) (m : H (T A B)) (mv : H (DFrac F × T A B)) : + HeapR F K (T A B) H n m mv → + HeapR F K (T A' B') H n ((Heap.mapO H (RFunctor.map f g).toHom).f m) ((Heap.mapC H (Prod.mapC (CMRA.Hom.id (α := DFrac F)) (RFunctor.map (F:=T) f g))).f mv) := by + simp [HeapR, Heap.mapC, Heap.mapO, Heap.map', CMRA.Hom.id, OFE.Hom.id, Prod.mapC, hhmap_get] + intros hr k a b + rcases h : Store.get mv k with _ | ⟨a,b⟩ <;> simp + rintro rfl rfl + obtain ⟨v, hq, ⟨fr, ⟨hv1, hv2⟩, ho⟩⟩ := hr k a b h + exists (RFunctor.map f g).f v + constructor + simp [hq] + exists fr + constructor + · constructor <;> simp_all + exact (Hom.validN _ hv2) + · rw [Option.incN_iff] at ho ⊢ + rcases ho with _ | he <;> simp_all + rcases he with ⟨he1, he2⟩ | he + · left + constructor <;> simp_all + exact (NonExpansive.ne he2) + · right + rw [<-Prod.incN_iff] at * + rcases he with ⟨_ , he⟩ + constructor + simp_all + apply (Hom.monoN _ _ he) + +abbrev HeapViewURF T [RFunctor T] : COFE.OFunctorPre := + fun A B _ _ => HeapView F K (T A B) H + +instance {T} [RFunctor T] : URFunctor (HeapViewURF (F := F) (H := H) T) where + map {A A'} {B B'} _ _ _ _ f g := View.mapC (Heap.mapO H (RFunctor.map (F:=T) f g).toHom) (Heap.mapC H (Prod.mapC Hom.id (RFunctor.map (F:=T) f g))) (heapR_map_eq f g) + map_ne.ne a b c Hx d e Hy mv := by + simp [View.mapC] + apply View.map_ne + · intro + apply Heap.map_ne + apply RFunctor.map_ne.ne <;> simp_all + · intro m + apply Heap.map_ne + intro a + apply Prod.map_ne + simp + apply RFunctor.map_ne.ne <;> simp_all + map_id x := by + -- Reduce to View.map and show both components are the identity. + simp only [View.mapC] + conv => rhs; rw [← View.map_id (R := HeapR F K (T _ _) H) x] + apply View.map_ext + · intro m + -- Auth part: heap map over id is identity. + intro k + simp [Heap.mapO, Heap.map', hhmap_get] + cases h : Store.get m k <;> simp [RFunctor.map_id] + · intro m + -- Frag part: heap map over Prod.mapC id is identity. + intro k + simp [Heap.mapC, Heap.map', hhmap_get, Prod.mapC, Prod.map] + cases h : Store.get m k with + | none => simp + | some v => + cases v with + | mk dq v => + constructor + · rfl + · simpa using (RFunctor.map_id (F := T) (x := v)) + map_comp f g f' g' x := by + -- Reduce to View.map and compare component maps via map_comp. + simp only [View.mapC] + haveI : + OFE.NonExpansive + ((Heap.mapO H (RFunctor.map (F := T) g g').toHom).f ∘ + (Heap.mapO H (RFunctor.map (F := T) f f').toHom).f) := + (OFE.Hom.comp + (Heap.mapO H (RFunctor.map (F := T) g g').toHom) + (Heap.mapO H (RFunctor.map (F := T) f f').toHom)) |>.ne + conv => rhs; rw [← View.map_compose (R' := HeapR F K (T _ _) H)] + apply View.map_ext + · intro m + -- Auth part: heap map composition follows RFunctor.map_comp. + intro k + simp [Heap.mapO, Heap.map', hhmap_get] + cases h : Store.get m k <;> simp [RFunctor.map_comp] + · intro m + -- Frag part: heap map composition follows RFunctor.map_comp. + intro k + simp [Heap.mapC, Heap.map', hhmap_get, Prod.mapC, Prod.map] + cases h : Store.get m k with + | none => simp + | some v => + cases v with + | mk dq v => + constructor + · rfl + · simpa using (RFunctor.map_comp (F := T) f g f' g' (x := v)) + +instance {T} [RFunctorContractive T] : URFunctorContractive (HeapViewURF (F := F) (H := H) T) where + map_contractive.1 H _ := by + -- Contractiveness lifts through View.map and heap mapping. + simp + apply View.map_ne + · intro m + apply Heap.map_ne + exact (RFunctorContractive.map_contractive.1 H) + · intro m + apply Heap.map_ne + intro a + apply Prod.map_ne + · intro _; simp + · intro v; exact (RFunctorContractive.map_contractive.1 H) v + +end heapViewFunctor end HeapView diff --git a/src/Iris/Algebra/Monoid.lean b/src/Iris/Algebra/Monoid.lean new file mode 100644 index 00000000..03fe3007 --- /dev/null +++ b/src/Iris/Algebra/Monoid.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.Algebra.OFE + +namespace Iris.Algebra + +/-! # Monoids for Big Operators + +- `Monoid` contains the laws and requires an OFE structure +- Use explicit `op` and `unit` parameters to support multiple monoids on the same type +-/ + +open OFE + +/-- A commutative monoid on an OFE, used for big operators. +The operation must be non-expansive, associative, commutative, and have a left identity. -/ +class Monoid (M : Type u) [OFE M] (op : M → M → M) (unit : outParam M) where + /-- The operation is non-expansive in both arguments -/ + op_ne : NonExpansive₂ op + /-- Associativity up to equivalence -/ + op_assoc : ∀ a b c : M, op (op a b) c ≡ op a (op b c) + /-- Commutativity up to equivalence -/ + op_comm : ∀ a b : M, op a b ≡ op b a + /-- Left identity up to equivalence -/ + op_left_id : ∀ a : M, op unit a ≡ a + +namespace Monoid + +attribute [simp] op_left_id + +variable {M : Type u} [OFE M] {op : M → M → M} + +/-- The operation is proper with respect to equivalence. -/ +theorem op_proper {unit : M} [Monoid M op unit] {a a' b b' : M} + (ha : a ≡ a') (hb : b ≡ b') : op a b ≡ op a' b' := by + haveI : NonExpansive₂ op := op_ne + exact NonExpansive₂.eqv ha hb + +/-- Right identity follows from commutativity and left identity. -/ +@[simp] theorem op_right_id {unit : M} [Monoid M op unit] (a : M) : op a unit ≡ a := + Equiv.trans (op_comm (unit := unit) a unit) (op_left_id a) + +/-- Congruence on the left argument. -/ +theorem op_congr_l {unit : M} [Monoid M op unit] {a a' b : M} (h : a ≡ a') : op a b ≡ op a' b := + op_proper (unit := unit) h Equiv.rfl + +/-- Congruence on the right argument. -/ +theorem op_congr_r {unit : M} [Monoid M op unit] {a b b' : M} (h : b ≡ b') : op a b ≡ op a b' := + op_proper (unit := unit) Equiv.rfl h + +/-- Rearrange `(a * b) * (c * d)` to `(a * c) * (b * d)`. -/ +theorem op_op_swap {unit : M} [Monoid M op unit] {a b c d : M} : + op (op a b) (op c d) ≡ op (op a c) (op b d) := + calc op (op a b) (op c d) + _ ≡ op a (op b (op c d)) := op_assoc a b (op c d) + _ ≡ op a (op (op b c) d) := op_congr_r (Equiv.symm (op_assoc b c d)) + _ ≡ op a (op (op c b) d) := op_congr_r (op_congr_l (op_comm b c)) + _ ≡ op a (op c (op b d)) := op_congr_r (op_assoc c b d) + _ ≡ op (op a c) (op b d) := Equiv.symm (op_assoc a c (op b d)) + +/-- Swap inner elements: `a * (b * c)` to `b * (a * c)`. -/ +theorem op_swap_inner {unit : M} [Monoid M op unit] {a b c : M} : + op a (op b c) ≡ op b (op a c) := + calc op a (op b c) + _ ≡ op (op a b) c := Equiv.symm (op_assoc a b c) + _ ≡ op (op b a) c := op_congr_l (op_comm a b) + _ ≡ op b (op a c) := op_assoc b a c + +/-- Non-expansiveness for dist. -/ +theorem op_ne_dist {unit : M} [Monoid M op unit] {n : Nat} {a a' b b' : M} + (ha : a ≡{n}≡ a') (hb : b ≡{n}≡ b') : op a b ≡{n}≡ op a' b' := by + haveI : NonExpansive₂ op := op_ne + exact NonExpansive₂.ne ha hb + +end Monoid + +/-! ## Monoid Homomorphisms -/ + +/-- A weak monoid homomorphism preserves the operation but not necessarily the unit. -/ +class WeakMonoidHomomorphism {M₁ : Type u} {M₂ : Type v} [OFE M₁] [OFE M₂] + (op₁ : M₁ → M₁ → M₁) (op₂ : M₂ → M₂ → M₂) (unit₁ : M₁) (unit₂ : M₂) + [Monoid M₁ op₁ unit₁] [Monoid M₂ op₂ unit₂] + (R : M₂ → M₂ → Prop) (f : M₁ → M₂) where + /-- The relation is reflexive -/ + rel_refl : ∀ a : M₂, R a a + /-- The relation is transitive -/ + rel_trans : ∀ {a b c : M₂}, R a b → R b c → R a c + /-- The relation is proper with respect to equivalence -/ + rel_proper : ∀ {a a' b b' : M₂}, a ≡ a' → b ≡ b' → (R a b ↔ R a' b') + /-- The operation is proper with respect to R -/ + op_proper : ∀ {a a' b b' : M₂}, R a a' → R b b' → R (op₂ a b) (op₂ a' b') + /-- The function is non-expansive -/ + f_ne : NonExpansive f + /-- The homomorphism property -/ + homomorphism : ∀ x y, R (f (op₁ x y)) (op₂ (f x) (f y)) + +/-- A monoid homomorphism preserves both the operation and the unit. -/ +class MonoidHomomorphism {M₁ : Type u} {M₂ : Type v} [OFE M₁] [OFE M₂] + (op₁ : M₁ → M₁ → M₁) (op₂ : M₂ → M₂ → M₂) (unit₁ : M₁) (unit₂ : M₂) + [Monoid M₁ op₁ unit₁] [Monoid M₂ op₂ unit₂] + (R : M₂ → M₂ → Prop) (f : M₁ → M₂) + extends WeakMonoidHomomorphism op₁ op₂ unit₁ unit₂ R f where + /-- The unit is preserved -/ + map_unit : R (f unit₁) unit₂ + +end Iris.Algebra diff --git a/src/Iris/Algebra/View.lean b/src/Iris/Algebra/View.lean index 5ad7cf60..30110135 100644 --- a/src/Iris/Algebra/View.lean +++ b/src/Iris/Algebra/View.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2025 Markus de Medeiros. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Markus de Medeiros +Authors: Markus de Medeiros, Puming Liu -/ import Iris.Algebra.CMRA import Iris.Algebra.OFE @@ -641,7 +641,120 @@ theorem auth_alloc (Hup : ∀ n bf, R n a bf → R n a (b • bf)) : refine CMRA.op_ne.ne ?_ exact (CMRA.unit_left_id_dist _) --- TODO: Local update lemma +theorem view_local_update {a a' : A} {b0 b1 b0' b1' : B} + (Hup : (b0, b1) ~l~> (b0', b1')) + (Hrel : ∀ n, R n a b0 → R n a' b0') : + ((●V a : View F R) • ◯V b0, (●V a) • ◯V b1) ~l~> + ((●V a') • ◯V b0', (●V a') • ◯V b1') := by + rw [local_update_unital] + intro n ⟨ag, bf⟩ Hv Heq + rw [auth_one_op_frag_validN_iff] at Hv + obtain (_|⟨dq, ag'⟩) := ag + · have Hb0_eq : b0 ≡{n}≡ b1 • bf := by + calc b0 ≡{n}≡ unit • b0 := (unit_left_id_dist b0).symm + _ ≡{n}≡ (unit • b1) • bf := Heq.2 + _ ≡{n}≡ b1 • bf := (unit_left_id_dist b1).op_l + have Hvb0 : ✓{n} b0 := IsViewRel.rel_validN n a b0 Hv + have ⟨_, Hb0'⟩ := local_update_unital.mp Hup n bf Hvb0 Hb0_eq + constructor + · rw [auth_one_op_frag_validN_iff] + exact Hrel n Hv + · refine ⟨.rfl, ?_⟩ + calc (unit • b0') ≡{n}≡ b0' := unit_left_id_dist b0' + _ ≡{n}≡ b1' • bf := Hb0' + _ ≡{n}≡ (unit • b1') • bf := (unit_left_id_dist b1').symm.op_l + · have Hvalid_frame : ✓{n} ((((●V a) • ◯V b1 : View F R)) • mk (some (dq, ag')) bf) := + validN_ne Heq (auth_one_op_frag_validN_iff.mpr Hv) + exact ((UFraction.one_whole (α := F)).2 (DFrac.valid_own_op Hvalid_frame.1)).elim end Updates + +section ViewMap + +def map {R : ViewRel A B} (R' : ViewRel A' B') (f : A → A') (g : B → B') (v : View F R) : View F R' where + auth := match v.auth with + | none => none + | some (fr, a) => (fr, a.map' f) + frag := g v.frag + +theorem map_id {R : ViewRel A B} (v : View F R) : + View.map R id id v = v := by + simp [View.map, Agree.map'] + rcases v with ⟨a, b⟩ + cases a <;> simp + +theorem map_compose {R : ViewRel A B} {R' : ViewRel A' B'} {R'' : ViewRel A'' B''} f g (f' : A' → A'') (g' : B' → B'') (v : View F R) : + View.map R'' (f' ∘ f) (g' ∘ g) v = View.map R'' f' g' (View.map R' f g v) := by + simp [View.map, Agree.map'] + rcases v with ⟨a, b⟩ + cases a <;> simp + +theorem map_ext [OFE A] [OFE B] [OFE A'] [OFE B'] {R : ViewRel A B} {R' : ViewRel A' B'} (f1 f2 : A → A') (g1 g2 : B → B') [OFE.NonExpansive f1] [OFE.NonExpansive f2] (v : View F R) : + (∀ a, f1 a ≡ f2 a) → (∀ b, g1 b ≡ g2 b) → + View.map R' f1 g1 v ≡ View.map R' f2 g2 v := by + intro h1 h2 + simp [View.map] + constructor <;> simp only + · split <;> constructor <;> simp + apply Agree.agree_map_ext h1 + · apply h2 + +theorem map_ne [OFE A] [OFE B] [OFE A'] [OFE B'] {R : ViewRel A B} {R' : ViewRel A' B'} (f1 f2 : A → A') (g1 g2 : B → B') [OFE.NonExpansive f1] [OFE.NonExpansive f2] (v : View F R) : + (∀ a, f1 a ≡{n}≡ f2 a) → (∀ b, g1 b ≡{n}≡ g2 b) → + View.map R' f1 g1 v ≡{n}≡ View.map R' f2 g2 v := by + intro h1 h2 + simp [View.map] + constructor <;> simp only + · split <;> constructor <;> simp + apply Agree.map_ne h1 + · apply h2 + +instance [OFE A] [OFE B] [OFE A'] [OFE B'] {R : ViewRel A B} {R' : ViewRel A' B'} (f : A → A') (g : B → B') [OFE.NonExpansive f] [hne : OFE.NonExpansive g] : OFE.NonExpansive (View.map R' f g : (View F R → _)) where + ne := by + rintro n ⟨a1, b1⟩ ⟨a2, b2⟩ ⟨h1, h2⟩ + constructor <;> simp [map] + · split <;> split <;> simp_all + cases h1 + constructor <;> simp_all + apply (Agree.map f).ne.ne + simp_all only + · apply hne.ne + simp_all only [instCOFEDFrac] + +instance mapO [OFE A] [OFE B] [OFE A'] [OFE B'] (R : ViewRel A B) (R' : ViewRel A' B') (f : A -n> A') (g : B -n> B') : View F R -n> View F R' where + f := View.map R' f g + ne := inferInstance + +instance mapC [UFraction F] [OFE A] [UCMRA B] [OFE A'] [UCMRA B'] {R : ViewRel A B} [IsViewRel R] {R' : ViewRel A' B'} [IsViewRel R'] (f : A -n> A') (g : B -C> B') (H : ∀ n a b, R n a b → R' n (f a) (g b)) : View F R -C> View F R' where + f := View.map R' f g + ne := inferInstance + validN {n x} hval := by + simp [CMRA.ValidN, map] at * + rcases x with ⟨_ | ⟨fr,a⟩, b⟩ <;> simp_all + · obtain ⟨a, hr⟩ := hval + exists f a + exact (H n a b hr) + · rcases hval with ⟨hfr, a1, ha, hr⟩ + exists f a1 + constructor <;> try exact (H n a1 b hr) + apply (OFE.Dist.trans (OFE.NonExpansive.ne ha)) + simp [toAgree, Agree.map'] + pcore x := by + simp [CMRA.pcore, map, CMRA.core, Option.getD] + constructor + · rcases x.auth with _|⟨fr, a⟩ <;> simp [Prod.pcore] + rcases (CMRA.pcore fr) <;> simp + rcases h : (CMRA.pcore a) <;> cases h <;> simp [CMRA.pcore] + · have _ := CMRA.Hom.pcore g x.frag + rcases _ : (CMRA.pcore x.frag) <;> + rcases _ : (CMRA.pcore (g.f x.frag)) <;> simp_all + op x y := by + simp [CMRA.op, map] + constructor <;> simp [CMRA.Hom.op] + rcases x.auth <;> rcases y.auth <;> simp [Prod.op] + constructor <;> simp + apply (Agree.map _).op + +end ViewMap + end View diff --git a/src/Iris/BI.lean b/src/Iris/BI.lean index 3bea992c..7af46a4d 100644 --- a/src/Iris/BI.lean +++ b/src/Iris/BI.lean @@ -6,3 +6,4 @@ import Iris.BI.Instances import Iris.BI.BI import Iris.BI.Notation import Iris.BI.Updates +import Iris.BI.BigOp diff --git a/src/Iris/BI/BigOp.lean b/src/Iris/BI/BigOp.lean new file mode 100644 index 00000000..106eb63b --- /dev/null +++ b/src/Iris/BI/BigOp.lean @@ -0,0 +1,307 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.BI.BI +import Iris.BI.DerivedLaws +import Iris.BI.DerivedLawsLater +import Iris.Algebra.BigOp +import Iris.Std.FiniteMap + +/-! # BI-Level Big Operators + +Reference: `iris/bi/big_op.v` + +Iterated separating conjunction over lists and finite maps, specialized from the +algebra-level `bigOpL` and `bigOpM` to the BI separation connective `∗` with +unit `emp`. + +The list version `big_sepL Φ l` computes: + + Φ 0 x₀ ∗ Φ 1 x₁ ∗ ⋯ ∗ Φ (n-1) xₙ₋₁ + +The map version `big_sepM Φ m` computes the same over the key-value pairs of `m`, +in the order given by `toList`. Since `∗` is commutative and associative, the +result is independent of enumeration order (up to `⊣⊢`). + +These are the main iteration primitives used throughout the Iris base logic: +- `wsat` uses `[∗ map]` to assert that every registered invariant is either + open or closed +- Proof mode tactics decompose `[∗ list]` and `[∗ map]` goals via + `big_sepM_insert`, `big_sepM_delete`, etc. + +## Main Definitions + +- `big_sepL` — iterated `∗` over a list with index: `[∗ list] i ↦ x ∈ l, Φ i x` +- `big_sepM` — iterated `∗` over a finite map: `[∗ map] k ↦ v ∈ m, Φ k v` + +## Main Results + +- `big_sepL_nil`, `big_sepL_cons` — computation rules +- `big_sepL_mono` — pointwise entailment lifts to the big sep +- `big_sepM_empty`, `big_sepM_insert`, `big_sepM_delete` — map operations +- `big_sepM_lookup_acc` — extract one entry with a restoration wand +- `big_sepM_sep` — distribute `∗` over `[∗ map]` +-/ + +namespace Iris.BI + +open Iris.Algebra Iris.Std + +variable {PROP : Type _} [BI PROP] + +/-! ## Separating Conjunction Monoid -/ + +/-- `sep` / `emp` form a monoid on any BI, enabling use of `bigOpL` and `bigOpM`. -/ +instance sepMonoid : Monoid PROP BIBase.sep (BIBase.emp : PROP) where + op_ne := by + -- non-expansiveness is inherited from the BI structure + simpa using (BI.sep_ne (PROP := PROP)) + op_assoc := by + -- associativity follows from the derived bi-entailment + intro a b c + exact equiv_iff.mpr (sep_assoc (P := a) (Q := b) (R := c)) + op_comm := by + -- commutativity follows from the derived bi-entailment + intro a b + exact equiv_iff.mpr (sep_comm (P := a) (Q := b)) + op_left_id := by + -- left identity is `emp_sep` as a bi-entailment + intro a + exact equiv_iff.mpr (emp_sep (P := a)) + +/-! ## List Big Sep -/ + +/-- Iterated separating conjunction over a list with index. + `big_sepL Φ l = Φ 0 x₀ ∗ Φ 1 x₁ ∗ ⋯ ∗ Φ (n-1) xₙ₋₁` -/ +def big_sepL {A : Type _} (Φ : Nat → A → PROP) (l : List A) : PROP := + bigOpL BIBase.sep BIBase.emp Φ l + +/-! ### List Computation Rules -/ + +/-- Empty list gives `emp`. -/ +@[simp] theorem big_sepL_nil {A : Type _} (Φ : Nat → A → PROP) : + big_sepL Φ ([] : List A) = (BIBase.emp : PROP) := rfl + +/-- Cons unfolds to head `∗` tail. -/ +@[simp] theorem big_sepL_cons {A : Type _} (Φ : Nat → A → PROP) (x : A) (l : List A) : + big_sepL Φ (x :: l) = BIBase.sep (Φ 0 x) (big_sepL (fun n => Φ (n + 1)) l) := rfl + +/-- Singleton list gives just the element. -/ +theorem big_sepL_singleton {A : Type _} (Φ : Nat → A → PROP) (x : A) : + big_sepL Φ [x] ⊣⊢ Φ 0 x := by + -- reduce to the algebraic singleton lemma and translate equivalence + have h : big_sepL Φ [x] ≡ Φ 0 x := by + -- unfold and use the singleton simplification + simp [big_sepL] + exact (equiv_iff (P := big_sepL Φ [x]) (Q := Φ 0 x)).1 h + +/-! ### List Structural Lemmas -/ + +/-- Pointwise entailment lifts to the iterated separating conjunction. -/ +theorem big_sepL_mono {A : Type _} {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ i x, l[i]? = some x → Φ i x ⊢ Ψ i x) : + big_sepL Φ l ⊢ big_sepL Ψ l := by + -- prove by list induction using `sep_mono` + induction l generalizing Φ Ψ with + | nil => + -- both sides are `emp` + simp [big_sepL_nil] + | cons x xs ih => + -- use monotonicity for head and tail + have hhead : Φ 0 x ⊢ Ψ 0 x := h 0 x rfl + have htail : ∀ i y, xs[i]? = some y → Φ (i + 1) y ⊢ Ψ (i + 1) y := by + -- shift indices for the tail + intro i y hget + exact h (i + 1) y hget + have ht : big_sepL (fun n => Φ (n + 1)) xs ⊢ big_sepL (fun n => Ψ (n + 1)) xs := ih htail + -- unfold the head and apply `sep_mono` + simpa [big_sepL_cons] using sep_mono hhead ht + +/-- Append distributes: `[∗ list](l₁ ++ l₂) ⊣⊢ [∗ list]l₁ ∗ [∗ list]l₂`. -/ +theorem big_sepL_app {A : Type _} (Φ : Nat → A → PROP) (l₁ l₂ : List A) : + big_sepL Φ (l₁ ++ l₂) ⊣⊢ + BIBase.sep (big_sepL Φ l₁) (big_sepL (fun n => Φ (n + l₁.length)) l₂) := by + -- use the algebraic append lemma and translate equivalence + have h : big_sepL Φ (l₁ ++ l₂) ≡ + BIBase.sep (big_sepL Φ l₁) (big_sepL (fun n => Φ (n + l₁.length)) l₂) := by + simpa [big_sepL] using + (BigOpL.append (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ l₁ l₂) + exact equiv_iff.mp h + +/-- Distribute `∗` inside: `[∗ list](Φ ∗ Ψ) ⊣⊢ [∗ list]Φ ∗ [∗ list]Ψ`. -/ +theorem big_sepL_sep {A : Type _} (Φ Ψ : Nat → A → PROP) (l : List A) : + big_sepL (fun i x => BIBase.sep (Φ i x) (Ψ i x)) l ⊣⊢ + BIBase.sep (big_sepL Φ l) (big_sepL Ψ l) := by + -- use the algebraic distributivity lemma and translate equivalence + have h : big_sepL (fun i x => BIBase.sep (Φ i x) (Ψ i x)) l ≡ + BIBase.sep (big_sepL Φ l) (big_sepL Ψ l) := by + simpa [big_sepL] using + (BigOpL.op_distr (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ Ψ l) + exact equiv_iff.mp h + +/-! ## Map Big Sep -/ + +variable {K : Type _} {V : Type _} +variable {M' : Type _ → Type _} [FiniteMap K M'] + +/-- Iterated separating conjunction over a finite map. + `big_sepM Φ m = ∗_{(k,v) ∈ m} Φ k v` -/ +def big_sepM (Φ : K → V → PROP) (m : M' V) : PROP := + BigOpM.bigOpM (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ m + +/-! ## Notation -/ + +syntax "[∗" "list]" ident " ↦ " ident " ∈ " term ", " term : term +syntax "[∗" "map]" ident " ↦ " ident " ∈ " term ", " term : term + +macro_rules + | `(iprop([∗ list] $i ↦ $x ∈ $l, $P)) => + ``(big_sepL (fun $i $x => iprop($P)) $l) + | `(iprop([∗ map] $k ↦ $v ∈ $m, $P)) => + ``(big_sepM (fun $k $v => iprop($P)) $m) + +/-! ### Map Structural Lemmas -/ + +/-- Distribute `∗` inside: `[∗ map](Φ ∗ Ψ) ⊣⊢ [∗ map]Φ ∗ [∗ map]Ψ`. -/ +theorem big_sepM_sep (Φ Ψ : K → V → PROP) (m : M' V) : + big_sepM (fun k v => BIBase.sep (Φ k v) (Ψ k v)) m ⊣⊢ + BIBase.sep (big_sepM Φ m) (big_sepM Ψ m) := by + -- use the algebraic distributivity lemma and translate equivalence + have h : big_sepM (fun k v => BIBase.sep (Φ k v) (Ψ k v)) m ≡ + BIBase.sep (big_sepM Φ m) (big_sepM Ψ m) := by + simpa [big_sepM] using + (BigOpM.op_distr (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ Ψ m) + exact equiv_iff.mp h + +section +variable [DecidableEq K] [FiniteMapLaws K M'] + +/-! ### Map Computation Rules -/ + +/-- Empty map gives `emp`. -/ +@[simp] theorem big_sepM_empty (Φ : K → V → PROP) : + big_sepM Φ (∅ : M' V) = (BIBase.emp : PROP) := by + -- unfold to the algebraic empty lemma + simp [big_sepM] + +section +variable [DecidableEq V] + +/-- Insert into a map with a fresh key unfolds to entry `∗` rest. -/ +theorem big_sepM_insert (Φ : K → V → PROP) (m : M' V) (i : K) (x : V) + (h : get? m i = none) : + big_sepM Φ (insert m i x) ⊣⊢ + BIBase.sep (Φ i x) (big_sepM Φ m) := by + -- use the algebraic insert lemma and translate equivalence + have h' : big_sepM Φ (insert m i x) ≡ + BIBase.sep (Φ i x) (big_sepM Φ m) := by + simpa [big_sepM] using + (BigOpM.insert (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ m i x h) + exact equiv_iff.mp h' + +/-- Delete from a map: `big_sepM m ⊣⊢ Φ k v ∗ big_sepM (delete k m)`. -/ +theorem big_sepM_delete (Φ : K → V → PROP) (m : M' V) (i : K) (x : V) + (h : get? m i = some x) : + big_sepM Φ m ⊣⊢ BIBase.sep (Φ i x) (big_sepM Φ (delete m i)) := by + -- use the algebraic delete lemma and translate equivalence + have h' : big_sepM Φ m ≡ + BIBase.sep (Φ i x) (big_sepM Φ (delete m i)) := by + simpa [big_sepM] using + (BigOpM.delete (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ m i x h) + exact equiv_iff.mp h' + +/-- Pointwise entailment lifts to the iterated map conjunction. -/ +theorem big_sepM_mono {Φ Ψ : K → V → PROP} {m : M' V} + (h : ∀ k v, get? m k = some v → Φ k v ⊢ Ψ k v) : + big_sepM Φ m ⊢ big_sepM Ψ m := by + -- strengthen induction to carry pointwise entailments + refine FiniteMapLaws.induction_on + (P := fun m' => (∀ k v, get? m' k = some v → Φ k v ⊢ Ψ k v) → + big_sepM Φ m' ⊢ big_sepM Ψ m') ?hemp ?hins m h + case hemp => + -- empty map: both sides are `emp` + intro _ + simp [big_sepM_empty] + case hins => + intro i x m' hnone IH hmap + -- split the inserted map into head and tail + have hhead : Φ i x ⊢ Ψ i x := by + -- apply the pointwise hypothesis at the new key + exact hmap i x (by simp [FiniteMapLaws.get?_insert_same]) + have htail : ∀ k v, get? m' k = some v → Φ k v ⊢ Ψ k v := by + -- restrict the pointwise hypothesis to the tail map + intro k v hk + by_cases hki : k = i + · subst hki; rw [hnone] at hk; cases hk + · have hne : i ≠ k := Ne.symm hki + have hk' : get? (insert m' i x) k = some v := by + simpa [FiniteMapLaws.get?_insert_ne m' i k x hne] using hk + exact hmap k v hk' + have ht : big_sepM Φ m' ⊢ big_sepM Ψ m' := IH htail + -- reassemble with `sep_mono` + refine (big_sepM_insert Φ m' i x hnone).1.trans ?_ + refine (sep_mono hhead ht).trans ?_ + exact (big_sepM_insert Ψ m' i x hnone).2 + +/-- Extract one entry from the big sep and get a wand to put it back. + This is the key lemma for opening/closing invariants in `wsat`. -/ +theorem big_sepM_lookup_acc {Φ : K → V → PROP} {m : M' V} {i : K} {x : V} + (h : get? m i = some x) : + big_sepM Φ m ⊢ BIBase.sep (Φ i x) (BIBase.wand (Φ i x) (big_sepM Φ m)) := by + -- peel out the entry and repackage with a wand + have hdelete := big_sepM_delete Φ m i x h + refine hdelete.1.trans ?_ + have hwand : big_sepM Φ (delete m i) ⊢ BIBase.wand (Φ i x) (big_sepM Φ m) := by + -- derive the wand from the reversed delete lemma + refine wand_intro ?_ + exact sep_symm.trans hdelete.2 + -- combine head and wand + exact sep_mono .rfl hwand + +/-- Distribute `▷` over the map big sep. -/ +theorem big_sepM_later {Φ : K → V → PROP} {m : M' V} [BIAffine PROP] : + BIBase.later (big_sepM Φ m) ⊢ big_sepM (fun k v => BIBase.later (Φ k v)) m := by + -- prove by map induction using `later_sep` + refine FiniteMapLaws.induction_on + (P := fun m' => BIBase.later (big_sepM Φ m') ⊢ + big_sepM (fun k v => BIBase.later (Φ k v)) m') ?hemp ?hins m + case hemp => + -- empty map: `▷ emp ⊢ emp` + simpa [big_sepM_empty] using (later_emp (PROP := PROP)).1 + case hins => + intro i x m' hnone IH + -- rewrite both sides using insertion and push `later` through `∗` + have hinsΦ := big_sepM_insert Φ m' i x hnone + have hinsΨ := big_sepM_insert (fun k v => BIBase.later (Φ k v)) m' i x hnone + refine (later_congr hinsΦ).1.trans ?_ + refine (later_sep).1.trans ?_ + refine (sep_mono .rfl IH).trans ?_ + exact hinsΨ.2 + +/-- Singleton map. -/ +theorem big_sepM_singleton (Φ : K → V → PROP) (i : K) (x : V) : + big_sepM Φ (FiniteMap.singleton i x : M' V) ⊣⊢ Φ i x := by + -- use the algebraic singleton lemma and translate equivalence + have h : big_sepM Φ (FiniteMap.singleton i x : M' V) ≡ Φ i x := by + simpa [big_sepM] using + (BigOpM.singleton (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ i x) + exact equiv_iff.mp h + +/-- Union of disjoint maps. -/ +theorem big_sepM_union (Φ : K → V → PROP) (m₁ m₂ : M' V) + (h : m₁ ##ₘ m₂) : + big_sepM Φ (m₁ ∪ m₂) ⊣⊢ + BIBase.sep (big_sepM Φ m₁) (big_sepM Φ m₂) := by + -- use the algebraic union lemma and translate equivalence + have h' : big_sepM Φ (m₁ ∪ m₂) ≡ + BIBase.sep (big_sepM Φ m₁) (big_sepM Φ m₂) := by + simpa [big_sepM] using + (BigOpM.union (op := BIBase.sep) (unit := (BIBase.emp : PROP)) Φ m₁ m₂ h) + exact equiv_iff.mp h' + +end +end + +end Iris.BI diff --git a/src/Iris/BaseLogic/Lib/CancelableInvariants.lean b/src/Iris/BaseLogic/Lib/CancelableInvariants.lean new file mode 100644 index 00000000..fec6b7ee --- /dev/null +++ b/src/Iris/BaseLogic/Lib/CancelableInvariants.lean @@ -0,0 +1,1222 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.Algebra.Excl +import Iris.Algebra.Frac +import Iris.BaseLogic.Lib.Invariants + +/-! # Cancelable Invariants + +Port of `iris/base_logic/lib/cancelable_invariants.v`. + +Cancelable invariants extend standard invariants with a fractional ownership + token that can permanently cancel the invariant and extract its body. + +## Main definitions +- `cinv_own` — fractional token for cancelation +- `cinv` — cancelable invariant + +## Main results +- `cinv_alloc`, `cinv_acc`, `cinv_cancel` +- proof mode instances `IntoInv`, `IntoAcc` +-/ + +namespace Iris.BaseLogic + +open _root_.Iris _root_.Iris.Algebra _root_.Iris.Std _root_.Iris.BI + +/-- Ghost state carrier for cancelable invariants. -/ +abbrev CinvR (F : Type _) : Type _ := + Option (Excl (LeibnizO Unit)) × Option (Frac F) + +variable {GF : BundledGFunctors} {M : Type _ → Type _} {F : Type _} +variable [UFraction F] +variable [FiniteMap Positive M] [DecidableEq Positive] +variable [FiniteMapLaws Positive M] [HeapFiniteMap Positive M] +variable [ElemG GF (InvF GF M F)] +variable [ElemG GF (COFE.constOF CoPsetDisj)] +variable [ElemG GF (COFE.constOF GSetDisj)] +variable [ElemG GF (COFE.constOF (CinvR F))] + +private abbrev maskDiff (E : Iris.Set Positive) (N : Namespace) : Iris.Set Positive := + fun x => E x ∧ ¬(nclose N).mem x + +/-- Keep IProp entailments opaque for proof mode (avoid unfolding to `holds`). -/ +private structure IPropEntails (P Q : IProp GF) : Prop where + toEntails : P ⊢ Q + +private def wrapEntails {P Q : IProp GF} (h : P ⊢ Q) : + IPropEntails (GF := GF) P Q := + ⟨h⟩ + +local instance asEmpValid_IPropEntails_cinv (d : Iris.ProofMode.AsEmpValid.Direction) + (P Q : IProp GF) : + Iris.ProofMode.AsEmpValid d (IPropEntails (GF := GF) P Q) iprop(P -∗ Q) := by + -- reuse the proof mode instance for entailments + have hEntails : + Iris.ProofMode.AsEmpValid d (P ⊢ Q) iprop(P -∗ Q) := by infer_instance + refine ⟨?_, ?_⟩ + · intro hd h + exact (hEntails.as_emp_valid.1 hd) h.toEntails + · intro hd h + exact ⟨(hEntails.as_emp_valid.2 hd) h⟩ + +/-! ## Definitions -/ + +/-- Fractional ownership token for a cancelable invariant. +Coq: `cinv_own` in `cancelable_invariants.v`. -/ +noncomputable def cinv_own (_W : WsatGS GF) (γ : GName) (p : F) : IProp GF := + -- store the fractional token in the right component + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ (none, some ((p : F) : Frac F)) + +/-- Internal exclusive token for cancelable invariant proofs. +Coq: `cinv_excl` in `cancelable_invariants.v`. -/ +noncomputable def cinv_excl (_W : WsatGS GF) (γ : GName) : IProp GF := + -- store the exclusive token in the left component + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + (some (Excl.excl (LeibnizO.mk ())), none) + +/-- Internal body of a cancelable invariant. -/ +private abbrev cinv_body (W : WsatGS GF) (γ : GName) (P : IProp GF) : IProp GF := + BIBase.or (BIBase.sep P (cinv_excl (F := F) W γ)) (cinv_own (F := F) W γ (1 : F)) + +/-- Cancelable invariant. +Coq: `cinv` in `cancelable_invariants.v`. -/ +noncomputable def cinv (W : WsatGS GF) (N : Namespace) (γ : GName) (P : IProp GF) : IProp GF := + -- invariant body: `P ∗ cinv_excl γ` or the full token + inv (GF := GF) (M := M) (F := F) W N (cinv_body (F := F) W γ P) + +/-! ## Properties -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `cinv` is persistent (inherits from `inv`). +Coq: `cinv_persistent`. -/ +theorem cinv_persistent (W : WsatGS GF) (N : Namespace) (γ : GName) (P : IProp GF) : + Persistent (cinv (M := M) (F := F) W N γ P) := by + -- reuse persistence of `inv` + refine ⟨?_⟩ + simpa [cinv, cinv_body] using + (inv_persistent (GF := GF) (M := M) (F := F) (W := W) (N := N) + (P := cinv_body (F := F) W γ P)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `cinv` is persistent (instance). -/ +instance cinv_persistent_inst {W : WsatGS GF} (N : Namespace) (γ : GName) (P : IProp GF) : + Persistent (cinv (M := M) (F := F) W N γ P) := + cinv_persistent (M := M) (F := F) (W := W) (N := N) (γ := γ) (P := P) + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Split a fractional ownership token. +Coq: `cinv_own_fractional`. -/ +theorem cinv_own_fractional (W : WsatGS GF) (γ : GName) (p q : F) : + cinv_own (F := F) W γ (p + q) ⊣⊢ + BIBase.sep (cinv_own (F := F) W γ p) (cinv_own (F := F) W γ q) := by + -- split the underlying ghost ownership + simpa [cinv_own, CMRA.op, Prod.op, optionOp] using + (iOwn_op (GF := GF) (F := COFE.constOF (CinvR F)) (γ := γ) + (a1 := (none, some ((p : F) : Frac F))) + (a2 := (none, some ((q : F) : Frac F)))) + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Validity of combined fractional tokens. +Coq: `cinv_own_valid`. -/ +theorem cinv_own_valid (W : WsatGS GF) (γ : GName) (q1 q2 : F) : + cinv_own (F := F) W γ q1 ⊢ + BIBase.wand (cinv_own (F := F) W γ q2) + (BIBase.pure (Fraction.Proper (q1 + q2)) : IProp GF) := by + -- validity of the combined token yields `Proper (q1 + q2)` + refine (wand_intro (PROP := IProp GF) ?_) + refine (iOwn_cmraValid_op (GF := GF) (F := COFE.constOF (CinvR F)) (γ := γ) + (a1 := (none, some ((q1 : F) : Frac F))) + (a2 := (none, some ((q2 : F) : Frac F)))).trans ?_ + refine (UPred.cmraValid_elim + (a := ((none, some ((q1 : F) : Frac F)) : CinvR F) • + (none, some ((q2 : F) : Frac F)))).trans ?_ + refine BI.pure_mono ?_ + intro hvalid0 + simpa [CMRA.Valid, CMRA.ValidN, Prod.ValidN, CMRA.op, Prod.op, optionOp, optionValid] using + hvalid0 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `cinv N γ` is contractive in its body. +Coq: `cinv_contractive`. -/ +instance cinv_contractive {W : WsatGS GF} (N : Namespace) (γ : GName) : + OFE.Contractive (fun P => cinv (M := M) (F := F) W N γ P) := by + -- combine the contractive `inv` with non-expansiveness of `cinv_body` + refine ⟨?_⟩ + intro n P Q hPQ + have hbody : + OFE.DistLater n (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q) := by + cases n with + | zero => + exact OFE.distLater_zero + | succ n' => + have hPQ' : P ≡{n'}≡ Q := (OFE.distLater_succ).1 hPQ + have hsep : + BIBase.sep P (cinv_excl (F := F) W γ) ≡{n'}≡ + BIBase.sep Q (cinv_excl (F := F) W γ) := + (BI.sep_ne (PROP := IProp GF)).ne hPQ' .rfl + have hor : + BIBase.or (BIBase.sep P (cinv_excl (F := F) W γ)) + (cinv_own (F := F) W γ (1 : F)) ≡{n'}≡ + BIBase.or (BIBase.sep Q (cinv_excl (F := F) W γ)) + (cinv_own (F := F) W γ (1 : F)) := + (BI.or_ne (PROP := IProp GF)).ne hsep .rfl + exact (OFE.distLater_succ).2 (by simpa [cinv_body] using hor) + have h := + (OFE.Contractive.distLater_dist + (f := fun P => inv (GF := GF) (M := M) (F := F) W N P) hbody) + simpa [cinv] using h + +/-- `cinv N γ` is non-expansive in its body. +Coq: `cinv_ne`. -/ +instance cinv_ne {W : WsatGS GF} (N : Namespace) (γ : GName) : + OFE.NonExpansive (fun P => cinv (M := M) (F := F) W N γ P) := by + infer_instance + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `cinv` respects equivalence of its body. +Coq: `cinv_proper`. -/ +theorem cinv_proper {W : WsatGS GF} (N : Namespace) (γ : GName) {P Q : IProp GF} + (h : P ≡ Q) : cinv (M := M) (F := F) W N γ P ≡ + cinv (M := M) (F := F) W N γ Q := by + exact OFE.NonExpansive.eqv + (f := fun P => cinv (M := M) (F := F) W N γ P) h + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Two full ownership tokens are contradictory. +Coq: `cinv_own_1_l`. -/ +theorem cinv_own_1_l (W : WsatGS GF) (γ : GName) (q : F) : + cinv_own (F := F) W γ (1 : F) ⊢ + BIBase.wand (cinv_own (F := F) W γ q) (BIBase.pure False : IProp GF) := by + -- validity of the combined token contradicts `one_whole` + refine wand_intro ?_ + refine (iOwn_cmraValid_op (GF := GF) (F := COFE.constOF (CinvR F)) (γ := γ) + (a1 := (none, some ((1 : F) : Frac F))) (a2 := (none, some ((q : F) : Frac F)))).trans ?_ + refine (UPred.cmraValid_elim + (a := ((none, some ((1 : F) : Frac F)) : CinvR F) • + (none, some ((q : F) : Frac F)))).trans ?_ + refine BI.pure_mono ?_ + intro hvalid0 + have hproper : Fraction.Proper ((1 : F) + q) := by + -- validity reduces to the fractional component + simpa [CMRA.ValidN, Prod.ValidN, CMRA.op, Prod.op, optionOp] using hvalid0 + exact (UFraction.one_whole (α := F)).2 ⟨q, hproper⟩ + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Two exclusive tokens are contradictory. +Coq: `cinv_excl_excl`. -/ +theorem cinv_excl_excl (W : WsatGS GF) (γ : GName) : + cinv_excl (F := F) W γ ⊢ + BIBase.wand (cinv_excl (F := F) W γ) (BIBase.pure False : IProp GF) := by + -- exclusive tokens cannot be combined + refine wand_intro ?_ + refine (iOwn_cmraValid_op (GF := GF) (F := COFE.constOF (CinvR F)) (γ := γ) + (a1 := (some (Excl.excl (LeibnizO.mk ())), none)) + (a2 := (some (Excl.excl (LeibnizO.mk ())), none))).trans ?_ + refine (UPred.cmraValid_elim + (a := ((some (Excl.excl (LeibnizO.mk ())), none) : CinvR F) • + (some (Excl.excl (LeibnizO.mk ())), none))).trans ?_ + refine BI.pure_mono ?_ + intro hvalid0 + have hleft : ✓{0} (Excl.excl (LeibnizO.mk ()) • Excl.excl (LeibnizO.mk ())) := by + -- reduce to validity of the excl component + simp [CMRA.ValidN, Prod.ValidN, CMRA.op, Prod.op, optionOp, optionValidN] at hvalid0 + exact (_root_.Iris.CMRA.not_valid_exclN_op_left (n := 0) + (x := Excl.excl (LeibnizO.mk ())) (y := Excl.excl (LeibnizO.mk ())) hleft) + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem cinv_body_wand_intuitionistic (W : WsatGS GF) (γ : GName) (P Q : IProp GF) : + BIBase.intuitionistically (BIBase.wand P Q) ⊢ + BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q) := by + -- split the invariant body, consume the wand on the left branch, drop it on the right + refine wand_intro ?_ + refine (sep_or_l (P := BIBase.intuitionistically (BIBase.wand P Q)) + (Q := BIBase.sep P (cinv_excl (F := F) W γ)) + (R := cinv_own (F := F) W γ (1 : F))).1.trans ?_ + have hleft : + BIBase.sep (BIBase.intuitionistically (BIBase.wand P Q)) + (BIBase.sep P (cinv_excl (F := F) W γ)) ⊢ + cinv_body (F := F) W γ Q := by + have hwand : + BIBase.sep (BIBase.intuitionistically (BIBase.wand P Q)) P ⊢ Q := by + -- eliminate the intuitionistic wand and apply it to `P` + refine (sep_mono_l (intuitionistically_elim (P := BIBase.wand P Q))).trans ?_ + exact wand_elim_l (P := P) (Q := Q) + have hsep : + BIBase.sep (BIBase.intuitionistically (BIBase.wand P Q)) + (BIBase.sep P (cinv_excl (F := F) W γ)) ⊢ + BIBase.sep Q (cinv_excl (F := F) W γ) := by + -- reassociate and rewrite the left component using `hwand` + refine (sep_assoc (P := BIBase.intuitionistically (BIBase.wand P Q)) + (Q := P) (R := cinv_excl (F := F) W γ)).2.trans ?_ + exact sep_mono hwand .rfl + exact hsep.trans + (or_intro_l (P := BIBase.sep Q (cinv_excl (F := F) W γ)) + (Q := cinv_own (F := F) W γ (1 : F))) + have hright : + BIBase.sep (BIBase.intuitionistically (BIBase.wand P Q)) + (cinv_own (F := F) W γ (1 : F)) ⊢ + cinv_body (F := F) W γ Q := by + have hown : + BIBase.sep (BIBase.intuitionistically (BIBase.wand P Q)) + (cinv_own (F := F) W γ (1 : F)) ⊢ + cinv_own (F := F) W γ (1 : F) := by + -- drop the affine intuitionistic wand + simpa using + (sep_elim_r (P := BIBase.intuitionistically (BIBase.wand P Q)) + (Q := cinv_own (F := F) W γ (1 : F))) + exact hown.trans + (or_intro_r (P := BIBase.sep Q (cinv_excl (F := F) W γ)) + (Q := cinv_own (F := F) W γ (1 : F))) + exact or_elim hleft hright + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Cancelable invariant content equivalence. +Coq: `cinv_iff`. -/ +theorem cinv_iff {W : WsatGS GF} + (N : Namespace) (γ : GName) (P Q : IProp GF) : + cinv (M := M) (F := F) W N γ P ⊢ + BIBase.wand (BIBase.later (BIBase.intuitionistically + (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)))) + (cinv (M := M) (F := F) W N γ Q) := by + -- lift the equivalence through `cinv_body` and reuse `inv_iff` + iintro Hinv + iintro Hpq + have hcore : + BIBase.intuitionistically (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)) ⊢ + BIBase.and + (BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q)) + (BIBase.wand (cinv_body (F := F) W γ Q) (cinv_body (F := F) W γ P)) := by + have hsplit : + BIBase.intuitionistically (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)) ⊢ + BIBase.and (BIBase.intuitionistically (BIBase.wand P Q)) + (BIBase.intuitionistically (BIBase.wand Q P)) := + (intuitionistically_and (P := BIBase.wand P Q) (Q := BIBase.wand Q P)).1 + have hleft : + BIBase.intuitionistically (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)) ⊢ + BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q) := by + refine hsplit.trans ?_ + refine (and_elim_l (P := BIBase.intuitionistically (BIBase.wand P Q)) + (Q := BIBase.intuitionistically (BIBase.wand Q P))).trans ?_ + exact cinv_body_wand_intuitionistic (W := W) (F := F) (γ := γ) (P := P) (Q := Q) + have hright : + BIBase.intuitionistically (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)) ⊢ + BIBase.wand (cinv_body (F := F) W γ Q) (cinv_body (F := F) W γ P) := by + refine hsplit.trans ?_ + refine (and_elim_r (P := BIBase.intuitionistically (BIBase.wand P Q)) + (Q := BIBase.intuitionistically (BIBase.wand Q P))).trans ?_ + exact cinv_body_wand_intuitionistic (W := W) (F := F) (γ := γ) (P := Q) (Q := P) + exact and_intro hleft hright + have hbody := + intuitionistically_intro' (P := BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)) + (Q := BIBase.and + (BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q)) + (BIBase.wand (cinv_body (F := F) W γ Q) (cinv_body (F := F) W γ P))) hcore + have hmono := + later_mono + (P := BIBase.intuitionistically (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P))) + (Q := BIBase.intuitionistically + (BIBase.and + (BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q)) + (BIBase.wand (cinv_body (F := F) W γ Q) (cinv_body (F := F) W γ P)))) + hbody + ihave Hpq' := (wrapEntails (GF := GF) hmono) $$ Hpq + have hiff := + inv_iff (W := W) (M := M) (F := F) (N := N) + (P := cinv_body (F := F) W γ P) (Q := cinv_body (F := F) W γ Q) + have hiff' : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand (cinv (M := M) (F := F) W N γ P) + (BIBase.wand (BIBase.later (BIBase.intuitionistically + (BIBase.and + (BIBase.wand (cinv_body (F := F) W γ P) (cinv_body (F := F) W γ Q)) + (BIBase.wand (cinv_body (F := F) W γ Q) (cinv_body (F := F) W γ P))))) + (cinv (M := M) (F := F) W N γ Q)) := by + simpa [cinv] using hiff + iintuitionistic Hinv + iapply (wrapEntails (GF := GF) hiff') + · iemp_intro + · iexact Hinv + · iexact Hpq' + +/-! ## Allocation -/ + +omit [DecidableEq Positive] in +/-- Validity of the combined ghost token. -/ +private theorem cinv_token_valid : + ✓ ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F) := by + -- validity is componentwise for the product/option CMRA + refine And.intro ?_ ?_ + · simp [CMRA.Valid, optionValid] + · simpa [CMRA.Valid, optionValid] using + (UFraction.one_whole (α := F)).1 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Allocate an exclusive token together with the full fractional token. -/ +private theorem cinv_own_excl_alloc (W : WsatGS GF) (E : Iris.Set Positive) : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun (γ : GName) => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F)) : IProp GF) := by + -- allocate the combined element and split ownership + have hvalid := (cinv_token_valid (F := F)) + have halloc : + (BIBase.emp : IProp GF) ⊢ + BUpd.bupd (BIBase.exists fun γ => + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F)) := + iOwn_alloc (GF := GF) (F := COFE.constOF (CinvR F)) _ hvalid + have halloc' : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun γ => + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F)) := + halloc.trans (bupd_fupd (W := W) (M := M) (F := F) (E := E) + (P := BIBase.exists fun γ => + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F))) + have hsplit : + BIBase.exists (fun γ => + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F)) ⊢ + BIBase.exists fun γ => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F)) := by + -- split ownership into exclusive and fractional parts + refine exists_elim ?_ + intro γ + have hsep : + iOwn (GF := GF) (F := COFE.constOF (CinvR F)) γ + ((some (Excl.excl (LeibnizO.mk ())), some ((1 : F) : Frac F)) : CinvR F) ⊢ + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F)) := by + simpa [cinv_excl, cinv_own, CMRA.op, Prod.op, optionOp] + using (iOwn_op (GF := GF) (F := COFE.constOF (CinvR F)) (γ := γ) + (a1 := (some (Excl.excl (LeibnizO.mk ())), none)) + (a2 := (none, some ((1 : F) : Frac F)))).1 + iintro Hown + iapply (wrapEntails (GF := GF) (exists_intro γ)) + iapply (wrapEntails (GF := GF) hsep) + iexact Hown + exact halloc'.trans (fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := E) + (P := _) (Q := _) hsplit) + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Build the later'd invariant body from the left branch. -/ +private theorem cinv_body_later_left (W : WsatGS GF) (γ : GName) (P : IProp GF) : + BIBase.sep (cinv_excl (F := F) W γ) (BIBase.later P) ⊢ + BIBase.later (cinv_body (F := F) W γ P) := by + -- push `cinv_excl` under `▷` and inject into the left branch + have hsep : + BIBase.sep (cinv_excl (F := F) W γ) (BIBase.later P) ⊢ + BIBase.later (BIBase.sep P (cinv_excl (F := F) W γ)) := by + refine (sep_mono (later_intro (P := cinv_excl (F := F) W γ)) .rfl).trans ?_ + refine (sep_comm (P := BIBase.later (cinv_excl (F := F) W γ)) (Q := BIBase.later P)).1.trans ?_ + exact (later_sep (P := P) (Q := cinv_excl (F := F) W γ)).2 + exact hsep.trans (later_mono (P := BIBase.sep P (cinv_excl (F := F) W γ)) + (Q := cinv_body (F := F) W γ P) + (or_intro_l (Q := cinv_own (F := F) W γ (1 : F)))) + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Build the later'd body from two latered components. -/ +private theorem cinv_body_later_left_later (W : WsatGS GF) (γ : GName) (P : IProp GF) : + BIBase.sep (BIBase.later P) (BIBase.later (cinv_excl (F := F) W γ)) ⊢ + BIBase.later (cinv_body (F := F) W γ P) := by + -- combine the latered pieces and inject into the left branch + have hsep : + BIBase.sep (BIBase.later P) (BIBase.later (cinv_excl (F := F) W γ)) ⊢ + BIBase.later (BIBase.sep P (cinv_excl (F := F) W γ)) := + (later_sep (P := P) (Q := cinv_excl (F := F) W γ)).2 + exact hsep.trans (later_mono (P := BIBase.sep P (cinv_excl (F := F) W γ)) + (Q := cinv_body (F := F) W γ P) + (or_intro_l (Q := cinv_own (F := F) W γ (1 : F)))) + +/-- Allocate a cancelable invariant from a later'd proposition. +Coq: `cinv_alloc`. -/ +theorem cinv_alloc (W : WsatGS GF) (E : Iris.Set Positive) (N : Namespace) + (P : IProp GF) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + BIBase.later P ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun (γ : GName) => + BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F)) : IProp GF) := by + -- allocate tokens, then build the invariant around the exclusive token + have hframe : + BIBase.later P ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.sep (BIBase.exists fun γ => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))) + (BIBase.later P)) := by + -- frame `▷ P` through the token allocation + refine (sep_emp (P := BIBase.later P)).2.trans ?_ + refine (sep_mono .rfl + (cinv_own_excl_alloc (W := W) (M := M) (F := F) (E := E))).trans ?_ + refine (sep_comm (P := BIBase.later P) + (Q := uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun γ => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))))).1.trans ?_ + exact fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := E) + (P := BIBase.exists fun γ => BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))) + (Q := BIBase.later P) + have hpost : + BIBase.sep (BIBase.exists fun γ => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))) (BIBase.later P) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun γ => + BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F)) : IProp GF) := by + -- pull the existential out of the separating conjunction + refine (sep_exists_r (Φ := fun γ => BIBase.sep (cinv_excl (F := F) W γ) + (cinv_own (F := F) W γ (1 : F))) (Q := BIBase.later P)).1.trans ?_ + refine exists_elim ?_ + intro γ + have halloc : + BIBase.sep (cinv_excl (F := F) W γ) (BIBase.later P) ⊢ + uPred_fupd (M := M) (F := F) W E E (cinv (M := M) (F := F) W N γ P) := by + -- pack `▷ body` and call `inv_alloc` + have hbody := cinv_body_later_left (W := W) (F := F) (γ := γ) (P := P) + have halloc := + inv_alloc (W := W) (M := M) (F := F) (N := N) (E := E) + (P := cinv_body (F := F) W γ P) hfresh + simpa [cinv, cinv_body] using hbody.trans halloc + have hframe' : + BIBase.sep (BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))) (BIBase.later P) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F))) := by + -- reassociate to frame the fractional token through the update + refine (sep_assoc (P := cinv_excl (F := F) W γ) (Q := cinv_own (F := F) W γ (1 : F)) + (R := BIBase.later P)).1.trans ?_ + refine (sep_mono .rfl + (sep_comm (P := cinv_own (F := F) W γ (1 : F)) (Q := BIBase.later P)).1).trans ?_ + refine (sep_assoc (P := cinv_excl (F := F) W γ) (Q := BIBase.later P) + (R := cinv_own (F := F) W γ (1 : F))).2.trans ?_ + refine (sep_mono halloc .rfl).trans ?_ + exact fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := E) + (P := cinv (M := M) (F := F) W N γ P) (Q := cinv_own (F := F) W γ (1 : F)) + iintro Hctx + icases Hctx with ⟨Hpair, HP⟩ + icases Hpair with ⟨Hexcl, Hown⟩ + have hexists : + BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F)) ⊢ + BIBase.exists fun γ => + BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F)) := by + -- introduce the chosen name into the existential + iintro Hpair + iapply (wrapEntails (GF := GF) (exists_intro γ)) + iexact Hpair + iapply (wrapEntails (GF := GF) (fupd_mono (W := W) (M := M) (F := F) + (E1 := E) (E2 := E) + (P := BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F))) + (Q := BIBase.exists fun γ => + BIBase.sep (cinv (M := M) (F := F) W N γ P) (cinv_own (F := F) W γ (1 : F))) + hexists)) + iapply (wrapEntails (GF := GF) hframe') + isplitl [Hexcl Hown] + · isplitl [Hexcl] + · iexact Hexcl + · iexact Hown + · iexact HP + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := E) + (P := _) (Q := uPred_fupd (M := M) (F := F) W E E _) hpost + exact hframe.trans (hmono.trans (fupd_trans (W := W) (M := M) (F := F) + (E1 := E) (E2 := E) (E3 := E) (P := _))) + +/-- Strong allocation for cancelable invariants (weakened). + + This version does not track a predicate on the chosen ghost name; it only + exposes the token and a continuation to build the invariant. + Coq: `cinv_alloc_strong`. -/ +theorem cinv_alloc_strong (W : WsatGS GF) + (_I : GName → Prop) (E : Iris.Set Positive) (N : Namespace) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun (γ : GName) => + BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.forall fun P : IProp GF => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E E + (cinv (M := M) (F := F) W N γ P)))) := by + iintro Hemp + ihave Halloc := + (wrapEntails (GF := GF) + (cinv_own_excl_alloc (W := W) (M := M) (F := F) (E := E))) $$ Hemp + have hpost : + BIBase.exists (fun γ => + BIBase.sep (cinv_excl (F := F) W γ) (cinv_own (F := F) W γ (1 : F))) ⊢ + BIBase.exists fun γ => + BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.forall fun P : IProp GF => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E E + (cinv (M := M) (F := F) W N γ P))) := by + refine exists_elim ?_ + intro γ + iintro Hpair + icases Hpair with ⟨Hexcl, Hown⟩ + iapply (wrapEntails (GF := GF) (exists_intro γ)) + isplitl [Hown] + · iexact Hown + · iintro %P + iintro HP + iapply (wrapEntails (GF := GF) (by + simpa [cinv] using + (inv_alloc (W := W) (M := M) (F := F) (N := N) (E := E) + (P := cinv_body (F := F) W γ P) hfresh))) + iapply (wrapEntails (GF := GF) + (cinv_body_later_left (W := W) (F := F) (γ := γ) (P := P))) + isplitl [Hexcl] + · iexact Hexcl + · iexact HP + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := E) + (P := _) (Q := _) hpost + ihave Halloc' := (wrapEntails (GF := GF) hmono) $$ Halloc + iexact Halloc' + +/-- Strong allocation for cancelable invariants (open, weakened). + + This version omits the ghost-name predicate and does not immediately open the + invariant; it reuses the strong allocation lemma. + Coq: `cinv_alloc_strong_open`. -/ +theorem cinv_alloc_strong_open (W : WsatGS GF) + (_I : GName → Prop) (E : Iris.Set Positive) (N : Namespace) + (_hN : Subset (nclose N).mem E) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun (γ : GName) => + BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.forall fun P : IProp GF => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E E + (cinv (M := M) (F := F) W N γ P)))) := by + -- reuse the weakened strong allocation + simpa using + (cinv_alloc_strong (W := W) (M := M) (F := F) + (_I := fun _ => True) (E := E) (N := N) hfresh) + +/-- Cofinite allocation for cancelable invariants (weakened). + + This is a direct specialization of `cinv_alloc_strong` without name side conditions. + Coq: `cinv_alloc_cofinite`. -/ +theorem cinv_alloc_cofinite (W : WsatGS GF) + (_G : GName → Prop) (E : Iris.Set Positive) (N : Namespace) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E E + (BIBase.exists fun (γ : GName) => + BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.forall fun P : IProp GF => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E E + (cinv (M := M) (F := F) W N γ P)))) := by + -- reuse the weakened strong allocation + simpa using + (cinv_alloc_strong (W := W) (M := M) (F := F) + (_I := fun _ => True) (E := E) (N := N) hfresh) + +/-! ## Accessors -/ + +omit [DecidableEq Positive] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Right branch yields a contradiction with any external fraction. -/ +private theorem cinv_own_later_false (W : WsatGS GF) (γ : GName) (p : F) : + BIBase.sep (BIBase.later (cinv_own (F := F) W γ (1 : F))) (cinv_own (F := F) W γ p) ⊢ + BIBase.later (BIBase.pure False : IProp GF) := by + -- move the contradiction under `▷` and apply it + have hwand : + BIBase.later (cinv_own (F := F) W γ (1 : F)) ⊢ + BIBase.wand (BIBase.later (cinv_own (F := F) W γ p)) + (BIBase.later (BIBase.pure False : IProp GF)) := by + refine (later_mono + (P := cinv_own (F := F) W γ (1 : F)) + (Q := BIBase.wand (cinv_own (F := F) W γ p) (BIBase.pure False)) + (cinv_own_1_l (W := W) (γ := γ) (q := p))).trans ?_ + exact later_wand (P := cinv_own (F := F) W γ p) (Q := BIBase.pure False) + refine (sep_mono hwand (later_intro (P := cinv_own (F := F) W γ p))).trans ?_ + exact wand_elim_l + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Build the strong closing shift for cancelable invariants. -/ +private theorem cinv_close_strong (W : WsatGS GF) (N : Namespace) (γ : GName) + (P : IProp GF) : + BIBase.later (cinv_excl (F := F) W γ) ⊢ + BIBase.wand (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True))) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True))) := by + -- work purely in term-mode to avoid proofmode hypothesis issues + let A : IProp GF := BIBase.later (cinv_excl (F := F) W γ) + let X : IProp GF := BIBase.later P + let Y : IProp GF := cinv_own (F := F) W γ (1 : F) + let B : IProp GF := + BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)) + let F' : Iris.Set Positive → IProp GF := + fun E' => + uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True) + -- reduce to the separating conjunction + refine wand_intro ?_ + -- introduce the mask parameter + refine forall_intro ?_ + intro E' + -- introduce the disjunction + refine wand_intro ?_ + -- split the disjunction under sep + have hor : + BIBase.sep (BIBase.sep A B) (BIBase.or X Y) ⊢ + BIBase.or (BIBase.sep (BIBase.sep A B) X) (BIBase.sep (BIBase.sep A B) Y) := + (sep_or_l (P := BIBase.sep A B) (Q := X) (R := Y)).1 + refine hor.trans ?_ + refine or_elim ?hleft ?hright + · -- left branch: use `A` with `▷P` to rebuild `▷cinv_body` + have hB : B ⊢ BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E') := + (forall_elim (PROP := IProp GF) + (Ψ := fun E'' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E'')) E') + have hbody : + BIBase.sep A X ⊢ BIBase.later (cinv_body (F := F) W γ P) := by + -- swap the latered resources and apply the helper lemma + exact (sep_comm (P := A) (Q := X)).1.trans + (cinv_body_later_left_later (W := W) (F := F) (γ := γ) (P := P)) + have hpre : + BIBase.sep (BIBase.sep A B) X ⊢ BIBase.sep B (BIBase.sep A X) := by + refine (sep_right_comm (P := A) (Q := B) (R := X)).1.trans ?_ + exact (sep_comm (P := BIBase.sep A X) (Q := B)).1 + have hwand : + BIBase.sep B (BIBase.sep A X) ⊢ + BIBase.sep (BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E')) + (BIBase.later (cinv_body (F := F) W γ P)) := + sep_mono hB hbody + exact hpre.trans hwand |>.trans wand_elim_l + · -- right branch: drop `A` (affine) and rebuild `▷cinv_body` from `cinv_own 1` + have hB : B ⊢ BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E') := + (forall_elim (PROP := IProp GF) + (Ψ := fun E'' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E'')) E') + have hbody : + Y ⊢ BIBase.later (cinv_body (F := F) W γ P) := by + -- introduce the later and inject into the right branch + refine (later_intro (P := Y)).trans ?_ + exact later_mono (P := Y) (Q := cinv_body (F := F) W γ P) + (or_intro_r (P := BIBase.sep P (cinv_excl (F := F) W γ))) + have hdrop : + BIBase.sep A Y ⊢ Y := + (sep_elim_r (P := A) (Q := Y)) + have hpre : + BIBase.sep (BIBase.sep A B) Y ⊢ BIBase.sep B Y := by + refine (sep_right_comm (P := A) (Q := B) (R := Y)).1.trans ?_ + refine (sep_comm (P := BIBase.sep A Y) (Q := B)).1.trans ?_ + exact sep_mono .rfl hdrop + have hwand : + BIBase.sep B Y ⊢ + BIBase.sep (BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) (F' E')) + (BIBase.later (cinv_body (F := F) W γ P)) := + sep_mono hB hbody + exact hpre.trans hwand |>.trans wand_elim_l + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Cancel a nested `except0` inside a separating conjunction. + + This is a local copy of the invariant helper to avoid opening the private lemma. + Coq: internal lemma used in `inv_acc_timeless`. -/ +private theorem except0_sep_idemp (P Q R : IProp GF) : + BIBase.except0 (BIBase.sep P (BIBase.sep (BIBase.except0 Q) R)) ⊣⊢ + BIBase.except0 (BIBase.sep P (BIBase.sep Q R)) := by + -- distribute except0, eliminate the inner idempotence, then reassemble + calc + BIBase.except0 (BIBase.sep P (BIBase.sep (BIBase.except0 Q) R)) + ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.except0 (BIBase.sep (BIBase.except0 Q) R)) := by + -- push except0 into the outer sep + exact (except0_sep (P := P) (Q := BIBase.sep (BIBase.except0 Q) R)) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.sep (BIBase.except0 (BIBase.except0 Q)) (BIBase.except0 R)) := by + -- distribute except0 across the inner sep + exact sep_congr_r (except0_sep (P := BIBase.except0 Q) (Q := R)) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.sep (BIBase.except0 Q) (BIBase.except0 R)) := by + -- collapse the redundant except0 + exact sep_congr_r (sep_congr_l except0_idemp) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) (BIBase.except0 (BIBase.sep Q R)) := by + -- reassemble the inner except0 + exact sep_congr_r (except0_sep (P := Q) (Q := R)).symm + _ ⊣⊢ BIBase.except0 (BIBase.sep P (BIBase.sep Q R)) := by + -- pull except0 back out + exact (except0_sep (P := P) (Q := BIBase.sep Q R)).symm + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF (CinvR F))] in +/-- Drop an extra `except0` under `fupd`. + + This mirrors the helper used for invariants to simplify postconditions. + Coq: internal lemma used in `inv_acc_timeless`. -/ +private theorem fupd_drop_except0_post {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (P Q : IProp GF) : + uPred_fupd (M := M) (F := F) W E1 E2 + (BIBase.sep (BIBase.except0 P) Q) ⊢ + uPred_fupd (M := M) (F := F) W E1 E2 (BIBase.sep (PROP := IProp GF) P Q) := by + -- push except0 through the fupd post, then cancel the redundant layer + unfold uPred_fupd + refine wand_mono_r ?_ + refine BIUpdate.mono ?_ + let A : IProp GF := wsat (GF := GF) (M := M) (F := F) W + let B : IProp GF := ownE W (⟨E2⟩ : CoPset) + have h : + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (BIBase.except0 P) Q))) ⊣⊢ + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (PROP := IProp GF) P Q))) := by + -- reassociate, drop the inner except0, then reassociate back + calc + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (BIBase.except0 P) Q))) + ⊣⊢ BIBase.except0 (BIBase.sep (BIBase.sep A B) + (BIBase.sep (BIBase.except0 P) Q)) := by + -- expose the left-associated sep + exact except0_congr (sep_assoc (P := A) (Q := B) + (R := BIBase.sep (BIBase.except0 P) Q)).symm + _ ⊣⊢ BIBase.except0 (BIBase.sep (BIBase.sep A B) (BIBase.sep (PROP := IProp GF) P Q)) := by + -- remove the redundant except0 on the postcondition + exact except0_sep_idemp (P := BIBase.sep A B) (Q := P) (R := Q) + _ ⊣⊢ BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (PROP := IProp GF) P Q))) := by + -- restore right association + exact except0_congr (sep_assoc (P := A) (Q := B) (R := BIBase.sep (PROP := IProp GF) P Q)) + simpa [A, B] using h.1 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Strong accessor for cancelable invariants. +Coq: `cinv_acc_strong`. -/ +theorem cinv_acc_strong (W : WsatGS GF) (E : Iris.Set Positive) (N : Namespace) + (γ : GName) (p : F) (P : IProp GF) (hN : Subset (nclose N).mem E) : + cinv (M := M) (F := F) W N γ P ⊢ + BIBase.wand (cinv_own (F := F) W γ p) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))))) := by + iintro Hinv + iintro Hown + have hacc := + inv_acc_strong (W := W) (M := M) (F := F) (E := E) (N := N) + (P := cinv_body (F := F) W γ P) hN + have hacc' : cinv (M := M) (F := F) W N γ P ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) := by + simpa [cinv, cinv_body] using hacc + ihave Hacc := (wrapEntails (GF := GF) hacc') $$ Hinv + have hframe := + fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) + (Q := cinv_own (F := F) W γ p) + have hpost : + BIBase.sep (BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) + (cinv_own (F := F) W γ p) ⊢ + BIBase.sep (BIBase.except0 (cinv_own (F := F) W γ p)) + (BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) := by + iintro Hctx + icases Hctx with ⟨Hbody, Hown'⟩ + icases Hbody with ⟨Hbody, Hclose⟩ + ihave Hbody' := + (wrapEntails (GF := GF) + (later_or (P := BIBase.sep P (cinv_excl (F := F) W γ)) + (Q := cinv_own (F := F) W γ (1 : F))).1) $$ Hbody + icases Hbody' with (Hleft | Hright) + · ihave Hleft' := + (wrapEntails (GF := GF) + (later_sep (P := P) (Q := cinv_excl (F := F) W γ)).1) $$ Hleft + icases Hleft' with ⟨HP, Hexcl⟩ + isplitl [Hown'] + · iapply (wrapEntails (GF := GF) + (except0_intro (P := cinv_own (F := F) W γ p))) + iexact Hown' + · isplitl [HP] + · iexact HP + · ihave Hclose' := + (wrapEntails (GF := GF) + (cinv_close_strong (W := W) (M := M) (F := F) (N := N) (γ := γ) (P := P))) $$ Hexcl + iapply Hclose' + iexact Hclose + · ihave Hfalse : BIBase.later (BIBase.pure False) $$ [Hright, Hown'] + · iapply (wrapEntails (GF := GF) + (cinv_own_later_false (W := W) (γ := γ) (p := p))) + isplitl [Hright] + · iexact Hright + · iexact Hown' + ihave Hfalse' := + (wrapEntails (GF := GF) + (persistent_entails_r (P := BIBase.later (BIBase.pure False)) + (Q := BIBase.later (BIBase.pure False)) .rfl)) $$ Hfalse + icases Hfalse' with ⟨Hfalse₁, Hfalse₂⟩ + ihave Hfalse'' := + (wrapEntails (GF := GF) + (persistent_entails_r (P := BIBase.later (BIBase.pure False)) + (Q := BIBase.later (BIBase.pure False)) .rfl)) $$ Hfalse₂ + icases Hfalse'' with ⟨Hfalse₂a, Hfalse₂b⟩ + ihave HP := + (wrapEntails (GF := GF) + (later_mono (P := BIBase.pure False) (Q := P) false_elim)) $$ Hfalse₁ + ihave Hown'' := + (wrapEntails (GF := GF) (by + simpa [BIBase.except0] using + (or_intro_l (P := BIBase.later (BIBase.pure False)) + (Q := cinv_own (F := F) W γ p)))) $$ Hfalse₂a + ihave HexclFalse := + (wrapEntails (GF := GF) + (later_mono (P := BIBase.pure False) + (Q := cinv_excl (F := F) W γ) false_elim)) $$ Hfalse₂b + isplitl [Hown''] + · + simp [BIBase.except0] + · isplitl [HP] + · iexact HP + · ihave Hclose' := + (wrapEntails (GF := GF) + (cinv_close_strong (W := W) (M := M) (F := F) (N := N) (γ := γ) (P := P))) $$ HexclFalse + iapply Hclose' + iexact Hclose + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _) (Q := _) hpost + have hdrop := + fupd_drop_except0_post (W := W) (M := M) (F := F) + (E1 := E) (E2 := maskDiff E N) + (P := cinv_own (F := F) W γ p) + (Q := BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) + have hreorder : + BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) ⊢ + BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) := by + refine (sep_assoc (P := cinv_own (F := F) W γ p) (Q := BIBase.later P) + (R := BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))).2.trans ?_ + refine (sep_mono + (sep_comm (P := cinv_own (F := F) W γ p) (Q := BIBase.later P)).1 .rfl).trans ?_ + exact (sep_assoc (P := BIBase.later P) (Q := cinv_own (F := F) W γ p) + (R := BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.or (BIBase.later P) (cinv_own (F := F) W γ (1 : F))) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))).1 + have hreorder_fupd := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _) (Q := _) hreorder + iapply (wrapEntails (GF := GF) hreorder_fupd) + iapply (wrapEntails (GF := GF) hdrop) + iapply (wrapEntails (GF := GF) hmono) + iapply (wrapEntails (GF := GF) hframe) + isplitl [Hacc] + · iexact Hacc + · iexact Hown + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Open a cancelable invariant with a fractional token. +Coq: `cinv_acc`. -/ +theorem cinv_acc (W : WsatGS GF) (E : Iris.Set Positive) (N : Namespace) + (γ : GName) (p : F) (P : IProp GF) (hN : Subset (nclose N).mem E) : + cinv (M := M) (F := F) W N γ P ⊢ + BIBase.wand (cinv_own (F := F) W γ p) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W + (maskDiff E N) E + (BIBase.pure True)))))) := by + -- open the underlying invariant and rule out the cancelled branch + iintro Hinv + iintro Hown + let Qacc : IProp GF := + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + have hacc : cinv (M := M) (F := F) W N γ P ⊢ Qacc := by + -- unfold the invariant body and reuse `inv_acc` + simpa [cinv, cinv_body, Qacc] using + (inv_acc (W := W) (M := M) (F := F) (E := E) (N := N) + (P := cinv_body (F := F) W γ P) hN) + ihave Hacc := (wrapEntails (GF := GF) hacc) $$ Hinv + have hframe := + fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) + (Q := cinv_own (F := F) W γ p) + have hpost : + BIBase.sep (BIBase.sep (BIBase.later (cinv_body (F := F) W γ P)) + (BIBase.wand (BIBase.later (cinv_body (F := F) W γ P)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) + (cinv_own (F := F) W γ p) ⊢ + BIBase.sep (BIBase.except0 (cinv_own (F := F) W γ p)) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))) := by + -- split on the invariant body and close using the exclusive token + iintro Hctx + icases Hctx with ⟨Hbody, Hown'⟩ + icases Hbody with ⟨Hbody, Hclose⟩ + ihave Hbody' := + (wrapEntails (GF := GF) + (later_or (P := BIBase.sep P (cinv_excl (F := F) W γ)) + (Q := cinv_own (F := F) W γ (1 : F))).1) $$ Hbody + icases Hbody' with (Hleft | Hright) + · -- left branch: reopen the invariant with the exclusive token + ihave Hleft' := + (wrapEntails (GF := GF) + (later_sep (P := P) (Q := cinv_excl (F := F) W γ)).1) $$ Hleft + icases Hleft' with ⟨HP, Hexcl⟩ + isplitl [Hown'] + · -- expose the token under `◇` + iapply (wrapEntails (GF := GF) + (except0_intro (P := cinv_own (F := F) W γ p))) + iexact Hown' + · isplitl [HP] + · iexact HP + · iintro HP' + iapply Hclose + iapply (wrapEntails (GF := GF) + (cinv_body_later_left_later (W := W) (F := F) (γ := γ) (P := P))) + isplitl [HP'] + · iexact HP' + · iexact Hexcl + · -- right branch: contradiction with the external fraction + ihave Hfalse : BIBase.later (BIBase.pure False) $$ [Hright, Hown'] + · iapply (wrapEntails (GF := GF) + (cinv_own_later_false (W := W) (γ := γ) (p := p))) + isplitl [Hright] + · iexact Hright + · iexact Hown' + ihave Hfalse' := + (wrapEntails (GF := GF) + (persistent_entails_r (P := BIBase.later (BIBase.pure False)) + (Q := BIBase.later (BIBase.pure False)) .rfl)) $$ Hfalse + icases Hfalse' with ⟨Hfalse₁, Hfalse₂⟩ + ihave HP := + (wrapEntails (GF := GF) + (later_mono (P := BIBase.pure False) (Q := P) false_elim)) $$ Hfalse₁ + ihave Hfalse'' := + (wrapEntails (GF := GF) + (persistent_entails_r (P := BIBase.later (BIBase.pure False)) + (Q := BIBase.later (BIBase.pure False)) .rfl)) $$ Hfalse₂ + icases Hfalse'' with ⟨Hfalse₂a, Hfalse₂b⟩ + ihave Hown'' := + (wrapEntails (GF := GF) (by + simpa [BIBase.except0] using + (or_intro_l (P := BIBase.later (BIBase.pure False)) + (Q := cinv_own (F := F) W γ p)))) $$ Hfalse₂a + isplitl [Hown''] + · + simp [BIBase.except0] + · isplitl [HP] + · iexact HP + · iintro _ + ihave HbodyFalse := + (wrapEntails (GF := GF) + (later_mono (P := BIBase.pure False) + (Q := cinv_body (F := F) W γ P) false_elim)) $$ Hfalse₂b + iapply Hclose + iexact HbodyFalse + -- apply the postcondition and frame the token + have hreorder : + BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))) ⊢ + BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))) := by + -- reassociate, swap the first two conjuncts, then reassociate back + refine (sep_assoc (P := cinv_own (F := F) W γ p) + (Q := BIBase.later P) + (R := BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))).symm.1.trans ?_ + refine (sep_congr_l sep_comm).1.trans ?_ + exact (sep_assoc (P := BIBase.later P) + (Q := cinv_own (F := F) W γ p) + (R := BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))).1 + have hdrop := + fupd_drop_except0_post (W := W) (M := M) (F := F) + (E1 := E) (E2 := maskDiff E N) + (P := cinv_own (F := F) W γ p) + (Q := BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True) : IProp GF))) + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _) (Q := _) hpost + have hreorder' := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _) (Q := _) hreorder + iapply (wrapEntails (GF := GF) (hmono.trans (hdrop.trans hreorder'))) + iapply (wrapEntails (GF := GF) hframe) + isplitl [Hacc] + · iexact Hacc + · iexact Hown + -- done: `fupd_mono` applied directly to the framed access + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- This is the `cinv_acc` accessor specialized to the full token. +Coq: `cinv_acc_1` (non-atomic) — we use the atomic accessor in this model. -/ +theorem cinv_acc_1 (W : WsatGS GF) (E : Iris.Set Positive) (N : Namespace) + (γ : GName) (P : IProp GF) (hN : Subset (nclose N).mem E) : + cinv (M := M) (F := F) W N γ P ⊢ + BIBase.wand (cinv_own (F := F) W γ (1 : F)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))))) := by + -- specialize `cinv_acc` to the full token + simpa using + (cinv_acc (W := W) (M := M) (F := F) + (E := E) (N := N) (γ := γ) (p := (1 : F)) (P := P) hN) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Cancel an invariant: open with the full token (atomic accessor). + +This is a weakened version of Coq's `cinv_cancel`, since we only have the +atomic accessor in this model. -/ +theorem cinv_cancel (W : WsatGS GF) (E : Iris.Set Positive) (N : Namespace) + (γ : GName) (P : IProp GF) (hN : Subset (nclose N).mem E) : + cinv (M := M) (F := F) W N γ P ⊢ + BIBase.wand (cinv_own (F := F) W γ (1 : F)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ (1 : F)) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))))) := by + -- specialize the atomic accessor to the full token + simpa using + (cinv_acc (W := W) (M := M) (F := F) + (E := E) (N := N) (γ := γ) (p := (1 : F)) (P := P) hN) + +/-! ## Proof Mode Integration -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `cinv` can be opened by `iInv`. -/ +instance into_inv_cinv {W : WsatGS GF} (N : Namespace) (γ : GName) (P : IProp GF) : + Iris.ProofMode.IntoInv (PROP := IProp GF) + (cinv (M := M) (F := F) W N γ P) N := by + -- marker instance carries only the namespace + exact ⟨⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Accessor instance for cancelable invariants. -/ +instance into_acc_cinv {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (γ : GName) (P : IProp GF) (p : F) : + Iris.ProofMode.IntoAcc (PROP := IProp GF) (X := Unit) + (cinv (M := M) (F := F) W N γ P) + (Subset (nclose N).mem E) (cinv_own (F := F) W γ p) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E) + (fun _ => BIBase.sep (BIBase.later P) (cinv_own (F := F) W γ p)) + (fun _ => BIBase.later P) + (fun _ => some (BIBase.pure True)) := by + -- unfold the accessor and use `cinv_acc` + refine ⟨?_⟩ + intro hsubset + -- unfold the accessor to match `cinv_acc` + simp [Iris.ProofMode.accessor] + iintro Hinv + iintro Hown + let Ψ : Unit → IProp GF := fun _ => + BIBase.sep (BIBase.sep (BIBase.later P) (cinv_own (F := F) W γ p)) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + have hreassoc : + BIBase.sep (BIBase.later P) + (BIBase.sep (cinv_own (F := F) W γ p) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) ⊢ Ψ () := by + -- reassociate the separating conjunction to match the accessor shape + exact (sep_assoc (P := BIBase.later P) + (Q := cinv_own (F := F) W γ p) + (R := BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))).symm.1 + have hmono₁ := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _) (Q := _) hreassoc + have hmono₂ := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := Ψ ()) (Q := BIBase.exists Ψ) (exists_unit (Ψ := Ψ)).2 + have hacc := + cinv_acc (W := W) (M := M) (F := F) + (E := E) (N := N) (γ := γ) (p := p) (P := P) hsubset + have hacc' := hacc.trans (wand_mono_r (hmono₁.trans hmono₂)) + ihave Hacc := (wrapEntails (GF := GF) hacc') $$ Hinv + ihave Hacc' := Hacc $$ Hown + iexact Hacc' + +end Iris.BaseLogic diff --git a/src/Iris/BaseLogic/Lib/FancyUpdates.lean b/src/Iris/BaseLogic/Lib/FancyUpdates.lean new file mode 100644 index 00000000..da97d0bf --- /dev/null +++ b/src/Iris/BaseLogic/Lib/FancyUpdates.lean @@ -0,0 +1,556 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.BaseLogic.Lib.Wsat +import Iris.BI.Updates +import Iris.BI.DerivedLaws +import Iris.BI.DerivedLawsLater + +/-! # Fancy Update Modality + +Reference: `iris/base_logic/lib/fancy_updates.v` + +The fancy update modality `|={E1,E2}=> P` is the central modality of Iris's +base logic. It allows mask-changing updates: temporarily changing the set of +enabled invariants from `E1` to `E2` while establishing `P`. + +## Definition + +``` +fupd E1 E2 P := wsat ∗ ownE E1 -∗ |==> ◇ (wsat ∗ ownE E2 ∗ P) +``` + +where `◇ P` is the "except-0" modality (`▷ False ∨ P`). + +## Main Results + +- `fupd_intro_mask` — `E2 ⊆ E1 → P ⊢ |={E1,E2}=> |={E2,E1}=> P` +- `fupd_mono` — monotonicity +- `fupd_trans` — `|={E1,E2}=> |={E2,E3}=> P ⊢ |={E1,E3}=> P` +- `fupd_frame_r` — frame rule +- `fupd_plain_mask` — plain elimination +- `fupd_soundness_no_lc` — adequacy (no later credits) + +## Simplifications + +This port omits later credit support (`has_lc`, `le_upd_if`, `lcGS`). +All definitions use plain `bupd` rather than `le_upd_if`. This corresponds +to the `HasNoLc` branch in Coq. +-/ + +namespace Iris.BaseLogic + +open Iris Iris.Algebra Iris.Std Iris.BI + +variable {GF : BundledGFunctors} {M : Type _ → Type _} {F : Type _} +variable [UFraction F] +variable [FiniteMap Positive M] [DecidableEq Positive] +variable [FiniteMapLaws Positive M] [HeapFiniteMap Positive M] +variable [ElemG GF (InvF GF M F)] +variable [ElemG GF (COFE.constOF CoPsetDisj)] +variable [ElemG GF (COFE.constOF GSetDisj)] + +section + +/-! ## Definition -/ + +/-- Coerce mask predicates to `CoPset` for `ownE`. -/ +abbrev mask (E : Iris.Set Positive) : CoPset := ⟨E⟩ + +/-- Fix `wsat` to the current ghost state parameters. -/ +noncomputable abbrev wsat' (W : WsatGS GF) : IProp GF := + wsat (GF := GF) (M := M) (F := F) W + +/-- Alias to expose `M`/`F` in typeclass-driven instances. -/ +abbrev IPropWsat (GF : BundledGFunctors) (_M : Type _ → Type _) (_F : Type _) : Type _ := + IProp GF + +/-- Fancy update modality: `fupd E1 E2 P` asserts that starting from enabled + mask `E1`, we can perform a basic update to reach a state where the enabled + mask is `E2` and `P` holds (modulo except-0). + + Coq: `uPred_fupd_def` -/ +noncomputable def uPred_fupd (_W : WsatGS GF) + (E1 E2 : Iris.Set Positive) (P : IProp GF) : IProp GF := + -- unfold to: wsat ∗ ownE E1 -∗ |==> ◇ (wsat ∗ ownE E2 ∗ P) + BIBase.wand + (BIBase.sep (wsat' (M := M) (F := F) _W) (ownE _W (mask E1))) + (BUpd.bupd <| + BIBase.except0 <| + BIBase.sep (wsat' (M := M) (F := F) _W) (BIBase.sep (ownE _W (mask E2)) P)) + +/-! ## FUpd Instance -/ + +/-- The `FUpd` instance for `IProp`, wiring `uPred_fupd` into the BI class. + + Coq: `uPred_bi_fupd` -/ +noncomputable instance instFUpdIProp + (M : Type _ → Type _) (F : Type _) + [UFraction F] [FiniteMap Positive M] [FiniteMapLaws Positive M] + [HeapFiniteMap Positive M] [ElemG GF (InvF GF M F)] + [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] + (W : WsatGS GF) : + FUpd (IPropWsat GF M F) Positive where + fupd := uPred_fupd (M := M) (F := F) W + +/-! ## Helpers -/ + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Split an enabled mask using subset decomposition. -/ +private theorem ownE_split_subset {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (h : Subset E2 E1) : + ∃ E3 : CoPset, + ownE W (mask E1) ⊣⊢ BIBase.sep (ownE W (mask E2)) (ownE W E3) := by + -- use the standard disjoint-union decomposition on `CoPset` + rcases CoPset.subseteq_disjoint_union (s₁ := mask E2) (s₂ := mask E1) h with + ⟨E3, hE, hdisj⟩ + refine ⟨E3, ?_⟩ + simpa [hE] using (ownE_op (W := W) (E₁ := mask E2) (E₂ := E3) hdisj) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Build a fancy update when we can rejoin the mask split. -/ +private theorem fupd_from_split {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (E3 : CoPset) + (hE : mask E1 = mask E2 ∪ E3) (hdisj : CoPset.Disjoint (mask E2) E3) + (P : IProp GF) : + BIBase.sep (ownE W E3) P ⊢ uPred_fupd (M := M) (F := F) W E2 E1 P := by + -- reassemble the mask, then wrap with except-0 and bupd + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_comm (P := BIBase.sep (ownE W E3) P) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E2)))).1.trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := BIBase.sep (ownE W E3) P)).1.trans ?_ + refine (sep_mono .rfl + (sep_assoc (P := ownE W (mask E2)) (Q := ownE W E3) (R := P)).2).trans ?_ + have hown : BIBase.sep (ownE W (mask E2)) (ownE W E3) ⊢ ownE W (mask E1) := by + -- collapse the split mask back to `E1` + simpa [hE] using (ownE_op (W := W) (E₁ := mask E2) (E₂ := E3) hdisj).2 + refine (sep_mono .rfl (sep_mono hown .rfl)).trans ?_ + exact (except0_intro).trans BIUpdate.intro + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Non-expansiveness of `uPred_fupd` in its postcondition. -/ +theorem uPred_fupd_ne {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) : + OFE.NonExpansive (uPred_fupd (M := M) (F := F) W E1 E2) := by + -- Push non-expansiveness through wand, bupd, except-0, and sep. + refine ⟨?_⟩ + intro n P Q hPQ + unfold uPred_fupd + have hsep : + BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P) ≡{n}≡ + BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) Q) := + (sep_ne.ne .rfl (sep_ne.ne .rfl hPQ)) + have hex : + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P)) ≡{n}≡ + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) Q)) := + (except0_ne.ne hsep) + have hbupd : + BUpd.bupd (PROP := IProp GF) + (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) ≡{n}≡ + BUpd.bupd (PROP := IProp GF) + (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) Q))) := + (OFE.NonExpansive.ne (f := BUpd.bupd (PROP := IProp GF)) hex) + exact (wand_ne.ne .rfl hbupd) + +/-! ## Mask Introduction -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Weaken the mask: if `E2 ⊆ E1`, then `P ⊢ |={E1,E2}=> |={E2,E1}=> P`. + + Coq: `fupd_intro_mask` (part of `BiFUpdMixin`) -/ +theorem fupd_intro_mask {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (h : Subset E2 E1) (P : IProp GF) : + P ⊢ uPred_fupd (M := M) (F := F) W E1 E2 (uPred_fupd (M := M) (F := F) W E2 E1 P) := by + -- split `E1` into `E2` and a disjoint remainder, then build the nested fupd + rcases CoPset.subseteq_disjoint_union (s₁ := mask E2) (s₂ := mask E1) h with + ⟨E3, hE, hdisj⟩ + have hsplit : ownE W (mask E1) ⊢ BIBase.sep (ownE W (mask E2)) (ownE W E3) := by + -- expose the split mask via `ownE_op` + simpa [hE] using (ownE_op (W := W) (E₁ := mask E2) (E₂ := E3) hdisj).1 + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_comm (P := P) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E1)))).1.trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E1)) + (R := P)).1.trans ?_ + refine (sep_mono .rfl (sep_mono hsplit .rfl)).trans ?_ + refine (sep_mono .rfl + (sep_assoc (P := ownE W (mask E2)) (Q := ownE W E3) (R := P)).1).trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := BIBase.sep (ownE W E3) P)).2.trans ?_ + have hfupd : + BIBase.sep (ownE W E3) P ⊢ uPred_fupd (M := M) (F := F) W E2 E1 P := + fupd_from_split (W := W) (E1 := E1) (E2 := E2) (E3 := E3) hE hdisj P + refine (sep_mono .rfl hfupd).trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := uPred_fupd (M := M) (F := F) W E2 E1 P)).1.trans ?_ + exact (except0_intro).trans BIUpdate.intro + +/-! ## Mask Framing -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF GSetDisj)] in +/-- Split a union mask into disjoint components. -/ +private theorem ownE_union_split {W : WsatGS GF} + (E1 Ef : Iris.Set Positive) + (hdisj : CoPset.Disjoint (mask E1) (mask Ef)) : + ownE W (mask (fun x => E1 x ∨ Ef x)) ⊣⊢ + BIBase.sep (ownE W (mask E1)) (ownE W (mask Ef)) := by + -- use the `ownE_op` equivalence on the union + simpa using (ownE_op (W := W) (E₁ := mask E1) (E₂ := mask Ef) hdisj) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Frame a mask through `except0` and rejoin the result. -/ +private theorem fupd_mask_frame_r_frame {W : WsatGS GF} + (E2 Ef : Iris.Set Positive) (P : IProp GF) : + BIBase.sep (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) (ownE W (mask Ef)) ⊢ + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask (fun x => E2 x ∨ Ef x))) P)) := by + -- push the frame under `except0`, then recombine the masks + refine (except0_frame_r).trans ?_ + refine except0_mono ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) + (Q := BIBase.sep (ownE W (mask E2)) P) (R := ownE W (mask Ef))).1.trans ?_ + refine (sep_mono .rfl + (sep_right_comm (P := ownE W (mask E2)) (Q := P) (R := ownE W (mask Ef))).1).trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) + (Q := BIBase.sep (ownE W (mask E2)) (ownE W (mask Ef))) (R := P)).2.trans ?_ + have hdisj : + BIBase.sep (ownE W (mask E2)) (ownE W (mask Ef)) ⊢ + BIBase.pure (CoPset.Disjoint (mask E2) (mask Ef)) := + ownE_disjoint (W := W) (E₁ := mask E2) (E₂ := mask Ef) + have hjoin : + BIBase.sep (ownE W (mask E2)) (ownE W (mask Ef)) ⊢ + ownE W (mask (fun x => E2 x ∨ Ef x)) := by + -- use the derived disjointness to rejoin the masks + refine pure_elim (PROP := IProp GF) + (φ := CoPset.Disjoint (mask E2) (mask Ef)) + (Q := BIBase.sep (ownE W (mask E2)) (ownE W (mask Ef))) + (R := ownE W (mask (fun x => E2 x ∨ Ef x))) ?_ ?_ + · exact hdisj + · intro hdisj' + simpa using (ownE_op (W := W) (E₁ := mask E2) (E₂ := mask Ef) hdisj').2 + refine (sep_mono (PROP := IProp GF) + (sep_mono (PROP := IProp GF) .rfl hjoin) .rfl).trans ?_ + exact (sep_assoc (P := wsat' (M := M) (F := F) W) + (Q := ownE W (mask (fun x => E2 x ∨ Ef x))) (R := P)).1 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Apply a fancy update to its mask resources. -/ +private theorem fupd_apply {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (P : IProp GF) : + BIBase.sep (uPred_fupd (M := M) (F := F) W E1 E2 P) + (BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E1))) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) := by + -- eliminate the fupd wand on the shared mask + unfold uPred_fupd + exact (wand_elim_l (PROP := IProp GF)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Frame a disjoint mask onto a fancy update. -/ +theorem fupd_mask_frame_r {W : WsatGS GF} + (E1 E2 Ef : Iris.Set Positive) (P : IProp GF) + (hdisj1 : CoPset.Disjoint (mask E1) (mask Ef)) : + uPred_fupd (M := M) (F := F) W E1 E2 P ⊢ + uPred_fupd (M := M) (F := F) W + (fun x => E1 x ∨ Ef x) (fun x => E2 x ∨ Ef x) P := by + -- Apply the fupd and frame the extra mask through bupd/except-0. + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_mono .rfl (sep_mono .rfl + (ownE_union_split (W := W) (E1 := E1) (Ef := Ef) hdisj1).1)).trans ?_ + refine (sep_mono .rfl + (sep_assoc (P := wsat' (M := M) (F := F) W) + (Q := ownE W (mask E1)) (R := ownE W (mask Ef))).2).trans ?_ + refine (sep_assoc (P := uPred_fupd (M := M) (F := F) W E1 E2 P) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E1))) + (R := ownE W (mask Ef))).2.trans ?_ + refine (sep_mono (fupd_apply (W := W) (E1 := E1) (E2 := E2) (P := P)) .rfl).trans ?_ + refine (BIUpdate.frame_r (PROP := IProp GF) + (P := BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) + (R := ownE W (mask Ef))).trans ?_ + have hframe := + fupd_mask_frame_r_frame (M := M) (F := F) + (W := W) (E2 := E2) (Ef := Ef) (P := P) + exact (BIUpdate.mono (PROP := IProp GF) hframe) + +/-! ## Monotonicity and Composition -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Monotonicity of fancy updates. + + Coq: `fupd_mono` (part of `BiFUpdMixin`) -/ +theorem fupd_mono {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) {P Q : IProp GF} (h : P ⊢ Q) : + uPred_fupd (M := M) (F := F) W E1 E2 P ⊢ uPred_fupd (M := M) (F := F) W E1 E2 Q := by + -- push monotonicity through wand, bupd, and except-0 + unfold uPred_fupd + refine wand_mono_r ?_ + refine BIUpdate.mono ?_ + refine except0_mono ?_ + exact sep_mono .rfl (sep_mono .rfl h) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Apply a nested fancy update under except-0. -/ +private theorem fupd_except0_bind {W : WsatGS GF} + (E2 E3 : Iris.Set Positive) (P : IProp GF) : + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) (uPred_fupd (M := M) (F := F) W E2 E3 P))) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E3)) P))) := by + -- use the inner wand, then commute bupd with except-0 and collapse + have happly : + BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) (uPred_fupd (M := M) (F := F) W E2 E3 P)) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E3)) P))) := by + -- reorder to apply the wand + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := uPred_fupd (M := M) (F := F) W E2 E3 P)).2.trans ?_ + refine (sep_comm (P := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E2))) + (Q := uPred_fupd (M := M) (F := F) W E2 E3 P)).1.trans ?_ + -- unfold the wand and eliminate it + unfold uPred_fupd + exact (wand_elim_l (PROP := IProp GF)) + have hstep : + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) (uPred_fupd (M := M) (F := F) W E2 E3 P))) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.except0 (BIBase.sep + (wsat' (M := M) (F := F) W) (BIBase.sep (ownE W (mask E3)) P)))) := by + -- push `happly` under except-0, then move bupd outward + refine (except0_mono happly).trans ?_ + simpa using (bupd_except0 (P := BIBase.except0 (BIBase.sep + (wsat' (M := M) (F := F) W) (BIBase.sep (ownE W (mask E3)) P)))) + exact hstep.trans (BIUpdate.mono except0_idemp.1) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Shrink a top mask to any subset (dropping the remainder). -/ +private theorem ownE_from_top {W : WsatGS GF} + (E : Iris.Set Positive) : + ownE W (mask Iris.Set.univ) ⊢ ownE W (mask E) := by + -- split `⊤` into `E` and the disjoint remainder, then drop it + have hsubset : Subset E Iris.Set.univ := by + intro _ _; trivial + rcases ownE_split_subset (W := W) (E1 := Iris.Set.univ) (E2 := E) hsubset with + ⟨E3, hsplit⟩ + refine (hsplit.1).trans ?_ + exact (sep_elim_l (P := ownE W (mask E)) (Q := ownE W E3)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Shrink a mask along subset by discarding the remainder. -/ +private theorem ownE_shrink {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (h : Subset E1 E2) : + ownE W (mask E2) ⊢ ownE W (mask E1) := by + -- decompose `E2` into `E1` and the remainder, then drop the remainder + rcases ownE_split_subset (W := W) (E1 := E2) (E2 := E1) h with + ⟨E3, hsplit⟩ + refine (hsplit.1).trans ?_ + exact (sep_elim_l (P := ownE W (mask E1)) (Q := ownE W E3)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Plainness is preserved by the later modality. -/ +private theorem later_plain {P : IProp GF} [Plain P] : + Plain (BIBase.later P) := by + -- move plainness under later using `later_plainly` + refine ⟨(later_mono (Plain.plain (P := P))).trans ?_⟩ + exact (later_plainly (P := P)).1 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Transitivity of fancy updates. + + Coq: `fupd_trans` (part of `BiFUpdMixin`) -/ +theorem fupd_trans {W : WsatGS GF} + (E1 E2 E3 : Iris.Set Positive) (P : IProp GF) : + uPred_fupd (M := M) (F := F) W E1 E2 (uPred_fupd (M := M) (F := F) W E2 E3 P) ⊢ uPred_fupd (M := M) (F := F) W E1 E3 P := by + -- apply the outer wand, then bind the inner update + unfold uPred_fupd + refine wand_intro ?_ + have houter : + BIBase.sep (uPred_fupd (M := M) (F := F) W E1 E2 (uPred_fupd (M := M) (F := F) W E2 E3 P)) + (BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E1))) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) (uPred_fupd (M := M) (F := F) W E2 E3 P)))) := by + -- eliminate the outer wand + unfold uPred_fupd + exact (wand_elim_l (PROP := IProp GF)) + refine houter.trans ?_ + refine (BIUpdate.mono (PROP := IProp GF) + (fupd_except0_bind (W := W) (E2 := E2) (E3 := E3) (P := P))).trans ?_ + exact (BIUpdate.trans (PROP := IProp GF)) + +/-! ## Frame Rule -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Frame rule for fancy updates: framing preserves disjointness of masks. + + Coq: `fupd_frame_r` (part of `BiFUpdMixin`) -/ +theorem fupd_frame_r {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (P Q : IProp GF) : + BIBase.sep (uPred_fupd (M := M) (F := F) W E1 E2 P) Q ⊢ + uPred_fupd (M := M) (F := F) W E1 E2 (BIBase.sep P Q) := by + -- frame `Q` through the bupd and except-0 layers + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_right_comm (P := uPred_fupd (M := M) (F := F) W E1 E2 P) (Q := Q) + (R := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E1)))).1.trans ?_ + have happly : + BIBase.sep (uPred_fupd (M := M) (F := F) W E1 E2 P) (BIBase.sep (wsat' (M := M) (F := F) W) + (ownE W (mask E1))) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) := by + -- eliminate the wand of the outer fupd + unfold uPred_fupd + exact (wand_elim_l (PROP := IProp GF)) + refine (sep_mono happly .rfl).trans ?_ + refine (BIUpdate.frame_r (PROP := IProp GF) + (P := BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) + (R := Q)).trans ?_ + have hframe : + BIBase.sep (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) Q ⊢ + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) (BIBase.sep P Q))) := by + -- move the frame inside except-0, then reassociate + refine (except0_frame_r).trans ?_ + refine except0_mono ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) + (Q := BIBase.sep (ownE W (mask E2)) P) (R := Q)).1.trans ?_ + exact (sep_mono .rfl + (sep_assoc (P := ownE W (mask E2)) (Q := P) (R := Q)).1) + exact (BIUpdate.mono (PROP := IProp GF) hframe) + +/-! ## BUpd / FUpd Interaction -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Basic updates lift to fancy updates. + + Coq: `uPred_bi_bupd_fupd` -/ +theorem bupd_fupd {W : WsatGS GF} + (E : Iris.Set Positive) (P : IProp GF) : + BUpd.bupd P ⊢ uPred_fupd (M := M) (F := F) W E E P := by + -- frame the current mask through the basic update + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_comm (P := BUpd.bupd P) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E)))).1.trans ?_ + refine (bupd_frame_l (P := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E))) + (Q := P)).trans ?_ + have hassoc : + BIBase.sep (BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E))) P ⊢ + BIBase.sep (wsat' (M := M) (F := F) W) (BIBase.sep (ownE W (mask E)) P) := + (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E)) (R := P)).1 + exact (BIUpdate.mono (PROP := IProp GF) (hassoc.trans except0_intro)) + +/-! ## Mask Weakening -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Mask shrinking for fancy updates: if `E1 ⊆ E2`, we can weaken to `E1`. + + Coq: `fupd_plain_mask` (from `BiFUpdSbi`) -/ +theorem fupd_plain_mask {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (h : Subset E1 E2) (P : IProp GF) : + uPred_fupd (M := M) (F := F) W E1 E2 P ⊢ uPred_fupd (M := M) (F := F) W E1 E1 P := by + -- shrink the mask in the postcondition using subset monotonicity + unfold uPred_fupd + refine wand_mono_r ?_ + refine BIUpdate.mono ?_ + refine except0_mono ?_ + exact sep_mono .rfl (sep_mono (ownE_shrink (W := W) (E1 := E1) (E2 := E2) h) .rfl) + +/-! ## Soundness -/ + +/-- Soundness of the fancy update (no later credits): if for any world + satisfaction we can establish `P` via a fancy update, then `P` holds + unconditionally. + + Proof strategy: allocate initial `wsat ∗ ownE ⊤` via `wsat_alloc`, + unfold `fupd` to basic update, use `bupd_soundness` and + `later_soundness` to strip modalities. + + Coq: `fupd_soundness_no_lc` -/ +theorem fupd_soundness_no_lc + (E1 E2 : Iris.Set Positive) (P : IProp GF) [Plain P] + (h : ∀ W : WsatGS GF, + (BIBase.emp : IProp GF) ⊢ uPred_fupd (M := M) (F := F) W E1 E2 P) : + (BIBase.emp : IProp GF) ⊢ P := by + -- allocate the initial world, run the fupd, then strip bupd/except-0/later + have hstep' : + BIBase.exists (fun W' : WsatGS GF => + BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask Iris.Set.univ))) ⊢ + BUpd.bupd (BIBase.later P) := by + -- pick the world, apply the fancy update, and map to `▷ P` + refine exists_elim ?_ + intro W' + have hmask : + BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask Iris.Set.univ)) ⊢ + BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask E1)) := by + -- shrink the top mask to `E1` + exact sep_mono .rfl (ownE_from_top (W := W') E1) + have happly : + BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask E1)) ⊢ + BIBase.sep (uPred_fupd (M := M) (F := F) W' E1 E2 P) + (BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask E1))) := by + -- obtain the fupd from `emp` and frame the current resources + refine (emp_sep.2).trans ?_ + exact sep_mono (h W') .rfl + have hupd : + BIBase.sep (wsat' (M := M) (F := F) W') (ownE W' (mask E1)) ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W') + (BIBase.sep (ownE W' (mask E2)) P))) := by + -- apply the wand of the fancy update + refine happly.trans ?_ + unfold uPred_fupd + exact (wand_elim_l (PROP := IProp GF)) + have hstrip : + BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W') + (BIBase.sep (ownE W' (mask E2)) P)) ⊢ BIBase.later P := by + -- drop `wsat`/`ownE` and turn except-0 into later + refine (except0_into_later (PROP := IProp GF)).trans ?_ + refine later_mono ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W') (Q := ownE W' (mask E2)) + (R := P)).2.trans ?_ + exact sep_elim_r (P := BIBase.sep (wsat' (M := M) (F := F) W') + (ownE W' (mask E2))) (Q := P) + refine (hmask.trans hupd).trans ?_ + exact BIUpdate.mono hstrip + have hstep : + (BIBase.emp : IProp GF) ⊢ BUpd.bupd (BIBase.later P) := by + -- allocate the world under bupd, then collapse nested updates + refine (wsat_alloc (GF := GF) (M := M) (F := F)).trans ?_ + refine (BIUpdate.mono hstep').trans ?_ + exact BIUpdate.trans + haveI : Plain (BIBase.later P) := later_plain (P := P) + have hlate : (BIBase.emp : IProp GF) ⊢ BIBase.later P := hstep.trans bupd_elim + have htrue : (True : IProp GF) ⊢ BIBase.later P := + (true_emp (PROP := IProp GF)).1.trans hlate + have hP : (True : IProp GF) ⊢ P := UPred.later_soundness htrue + exact (true_emp (PROP := IProp GF)).2.trans hP + +/-- Step-indexed fancy update soundness (no later credits). + + Coq: `step_fupdN_soundness_no_lc` -/ +theorem step_fupdN_soundness_no_lc + (P : IProp GF) [Plain P] (_n : Nat) + (h : ∀ W : WsatGS GF, + (BIBase.emp : IProp GF) ⊢ uPred_fupd (M := M) (F := F) W Iris.Set.univ (fun _ => False) P) : + (BIBase.emp : IProp GF) ⊢ P := by + -- specialize soundness to `⊤`/`∅` masks + exact fupd_soundness_no_lc (E1 := Iris.Set.univ) (E2 := fun _ => False) (P := P) h + +end + +end Iris.BaseLogic diff --git a/src/Iris/BaseLogic/Lib/Invariants.lean b/src/Iris/BaseLogic/Lib/Invariants.lean new file mode 100644 index 00000000..bf82496e --- /dev/null +++ b/src/Iris/BaseLogic/Lib/Invariants.lean @@ -0,0 +1,1868 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.BaseLogic.Lib.FancyUpdates +import Iris.ProofMode.Tactics +import Iris.Std.Namespace + +/-! # Invariants + +Reference: `iris/base_logic/lib/invariants.v` + +Invariants are the main user-facing mechanism for shared ownership in Iris. +An invariant `inv N P` asserts that proposition `P` is maintained as an +invariant registered under namespace `N`. It is a *derived* definition built +on top of fancy updates and world satisfaction — not a new primitive. + +## Definition + +``` +inv N P := □ ∀ E, ⌜↑N ⊆ E⌝ → |={E, E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N, E}=∗ True) +``` + +## Main Results + +- `inv_persistent` — `inv N P` is persistent +- `inv_alloc` — `▷ P ={E}=∗ inv N P` +- `inv_alloc_open` — allocate and immediately open +- `inv_acc` — `↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True)` +- `inv_acc_timeless` — strip `▷` when `P` is timeless +-/ + +namespace Iris.BaseLogic + +open Iris Iris.Algebra Iris.Std Iris.BI + +variable {GF : BundledGFunctors} {M : Type _ → Type _} {F : Type _} +variable [UFraction F] +variable [FiniteMap Positive M] [DecidableEq Positive] +variable [FiniteMapLaws Positive M] [HeapFiniteMap Positive M] +variable [ElemG GF (InvF GF M F)] +variable [ElemG GF (COFE.constOF CoPsetDisj)] +variable [ElemG GF (COFE.constOF GSetDisj)] + +/-- Mask difference: `E ∖ ↑N` as a set predicate. -/ +private abbrev maskDiff (E : Iris.Set Positive) (N : Namespace) : + Iris.Set Positive := + fun x => E x ∧ ¬(nclose N).mem x + +-- Keep IProp entailments opaque for proof mode (avoid unfolding to `holds`). +private structure IPropEntails (P Q : IProp GF) : Prop where + toEntails : P ⊢ Q + +private def wrapEntails {P Q : IProp GF} (h : P ⊢ Q) : + IPropEntails (GF := GF) P Q := + ⟨h⟩ + +local instance asEmpValid_IPropEntails_inv (d : Iris.ProofMode.AsEmpValid.Direction) + (P Q : IProp GF) : + Iris.ProofMode.AsEmpValid d (IPropEntails (GF := GF) P Q) iprop(P -∗ Q) := by + have hEntails : + Iris.ProofMode.AsEmpValid d (P ⊢ Q) iprop(P -∗ Q) := inferInstance + refine ⟨?_, ?_⟩ + · intro hd h + exact (hEntails.as_emp_valid.1 hd) h.toEntails + · intro hd h + exact ⟨(hEntails.as_emp_valid.2 hd) h⟩ + +-- Make `ownI` persistent for proof mode use. +instance ownI_persistent_inst {W : WsatGS GF} (i : Positive) (P : IProp GF) : + Persistent (ownI (GF := GF) (M := M) (F := F) W i P) := + ⟨ownI_persistent (W := W) (i := i) (P := P)⟩ + +/-! ## Internal Model -/ + +/-- Internal invariant ownership: existential over a name in the namespace. + + Coq: `own_inv` -/ +noncomputable def own_inv (_W : WsatGS GF) + (N : Namespace) (P : IProp GF) : IProp GF := + BIBase.exists fun i => + BIBase.and (BIBase.pure ((nclose N).mem i)) + (ownI (GF := GF) (M := M) (F := F) _W i P) + +-- `own_inv` is persistent: pure facts plus persistent `ownI`. +local instance own_inv_persistent_inst {W : WsatGS GF} (N : Namespace) (P : IProp GF) : + Persistent (own_inv (GF := GF) (M := M) (F := F) W N P) := by + -- unfold and rely on `exists_persistent`/`and_persistent`. + unfold own_inv + infer_instance + +/-- Access an internal invariant: open it to get `▷ P` and a closing view shift. + + Coq: `own_inv_acc` -/ +theorem own_inv_acc {W : WsatGS GF} + (N : Namespace) (E : Iris.Set Positive) (P : IProp GF) + (h : Subset (nclose N).mem E) : + own_inv (GF := GF) (M := M) (F := F) W N P ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) := by + classical + unfold uPred_fupd + unfold own_inv + -- eliminate the existential invariant name + refine exists_elim ?_ + intro i + iintro Hinv + iintro H + icases Hinv with ⟨Hmem, HownI⟩ + icases Hmem with %Hmem + icases HownI with #HownI + icases H with ⟨Hwsat, HownE⟩ + -- split the enabled mask into `↑N` and `E \ ↑N` + have hmask : mask E = (nclose N) ∪ mask (maskDiff E N) := by + ext x; constructor + · intro hx + by_cases hxN : (nclose N).mem x + · exact Or.inl hxN + · exact Or.inr ⟨hx, hxN⟩ + · intro hx + cases hx with + | inl hxN => exact h _ hxN + | inr hxDiff => exact hxDiff.1 + have hdisj : CoPset.Disjoint (nclose N) (mask (maskDiff E N)) := by + intro x hx + exact hx.2.2 hx.1 + have hsplit : + ownE W (mask E) ⊢ + BIBase.sep (ownE W (nclose N)) (ownE W (mask (maskDiff E N))) := by + -- rewrite the mask to the disjoint union and apply `ownE_op` + rw [hmask] + exact (ownE_op (W := W) (E₁ := nclose N) (E₂ := mask (maskDiff E N)) hdisj).1 + ihave Hsplit := (wrapEntails (GF := GF) hsplit) $$ HownE + icases Hsplit with ⟨HownEN, HownEdiff⟩ + + -- split `↑N` into `{i}` and the remainder + let rest : CoPset := nclose N \ CoPset.singleton i + have hmaskN : (nclose N) = (CoPset.singleton i) ∪ rest := by + ext x; constructor + · intro hxN + by_cases hx : x = i + · left; simpa [CoPset.mem_singleton] using hx + · right; exact ⟨hxN, by simpa [CoPset.mem_singleton, rest] using hx⟩ + · intro hx + cases hx with + | inl hx => + have hx' : x = i := by simpa [CoPset.mem_singleton] using hx + subst hx' + exact Hmem + | inr hx => exact hx.1 + have hdisjN : CoPset.Disjoint (CoPset.singleton i) rest := by + intro x hx + exact hx.2.2 hx.1 + have hsplitN : + ownE W (nclose N) ⊢ + BIBase.sep (ownE W (CoPset.singleton i)) (ownE W rest) := by + -- rewrite the namespace to the singleton union and apply `ownE_op` + rw [hmaskN] + exact (ownE_op (W := W) (E₁ := CoPset.singleton i) (E₂ := rest) hdisjN).1 + ihave HsplitN := (wrapEntails (GF := GF) hsplitN) $$ HownEN + icases HsplitN with ⟨HownEi, HownErest⟩ + + -- open the invariant + icases (wrapEntails (GF := GF) + (ownI_open (W := W) (M := M) (F := F) i P)) $$ [Hwsat, HownI, HownEi] + with ⟨Hsep, HownD⟩ + · -- build the premise `(wsat ∗ ownI) ∗ ownE` + isplitl [Hwsat HownI] + · isplitl [Hwsat] + · iexact Hwsat + · iexact HownI + · iexact HownEi + icases Hsep with ⟨Hwsat', HlaterP⟩ + + -- introduce bupd and except0 + iapply BIUpdate.intro + iapply (wrapEntails (GF := GF) (except0_intro (P := _))) + -- assemble the postcondition + isplitl [Hwsat'] + · iexact Hwsat' + · isplitl [HownEdiff] + · iexact HownEdiff + · isplitl [HlaterP] + · iexact HlaterP + · -- closing wand + iintro HP + iintro Hclose + icases Hclose with ⟨Hwsat2, HownEdiff2⟩ + ihave Hclose' := + (wrapEntails (GF := GF) + (ownI_close (W := W) (M := M) (F := F) i P)) $$ [Hwsat2, HownI, HP, HownD] + · -- build the premise `((wsat ∗ ownI) ∗ ▷ P) ∗ ownD` + isplitl [Hwsat2 HownI HP] + · isplitl [Hwsat2 HownI] + · isplitl [Hwsat2] + · iexact Hwsat2 + · iexact HownI + · iexact HP + · iexact HownD + icases Hclose' with ⟨Hwsat3, HownEi'⟩ + have hjoinN : + BIBase.sep (ownE W (CoPset.singleton i)) (ownE W rest) ⊢ + ownE W (nclose N) := by + -- rewrite the namespace to the singleton union and apply `ownE_op` + rw [hmaskN] + exact (ownE_op (W := W) (E₁ := CoPset.singleton i) (E₂ := rest) hdisjN).2 + ihave HjoinN := (wrapEntails (GF := GF) hjoinN) $$ [HownEi', HownErest] + · -- assemble the singleton/rest split + isplitl [HownEi'] + · iexact HownEi' + · iexact HownErest + have hjoin : + BIBase.sep (ownE W (nclose N)) (ownE W (mask (maskDiff E N))) ⊢ + ownE W (mask E) := by + -- rewrite the mask to the disjoint union and apply `ownE_op` + rw [hmask] + exact (ownE_op (W := W) (E₁ := nclose N) + (E₂ := mask (maskDiff E N)) hdisj).2 + ihave Hjoin := (wrapEntails (GF := GF) hjoin) $$ [HjoinN, HownEdiff2] + · -- rejoin `↑N` with the remaining mask + isplitl [HjoinN] + · iexact HjoinN + · iexact HownEdiff2 + iapply BIUpdate.intro + iapply (wrapEntails (GF := GF) (except0_intro (P := _))) + isplitl [Hwsat3] + · iexact Hwsat3 + · isplitl [Hjoin] + · iexact Hjoin + · ipure_intro + exact True.intro + +/-! ## Definition -/ + +/-- Semantic invariant: `inv N P` asserts that `P` is maintained as an + invariant under namespace `N`. This is persistent — once allocated, + the invariant exists forever. + + Coq: `inv_def` -/ +noncomputable def inv (_W : WsatGS GF) + (N : Namespace) (P : IProp GF) : IProp GF := + BIBase.persistently <| + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) _W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) _W (maskDiff E N) E + (BIBase.pure True))))) + +-- `inv` as a non-expansive body over a latered parameter. +private def invBody (_W : WsatGS GF) + (N : Namespace) (X : IProp GF) : IProp GF := + BIBase.persistently <| + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) _W E (maskDiff E N) + (BIBase.sep X + (BIBase.wand X + (uPred_fupd (M := M) (F := F) _W (maskDiff E N) E + (BIBase.pure True))))) + +/-! ## Notation -/ + +-- `inv` notation inside `iprop(...)` quotations. +macro_rules + | `(iprop(inv $W $N $P)) => + `(Iris.BaseLogic.inv (W := $W) $N iprop($P)) + +delab_rule Iris.BaseLogic.inv + | `($_ $W $N $P) => do + -- display as `inv W N P` inside `iprop(...)`. + `(iprop(inv $W $N $(← unpackIprop P))) + +private theorem own_inv_to_inv {W : WsatGS GF} + (N : Namespace) (P : IProp GF) : + own_inv (GF := GF) (M := M) (F := F) W N P ⊢ + inv (GF := GF) (M := M) (F := F) W N P := by + unfold inv + refine (persistently_intro'' + (P := own_inv (GF := GF) (M := M) (F := F) W N P) (Q := _) ?_) + -- show the invariant body from internal ownership + refine forall_intro ?_ + intro E + refine imp_intro ?_ + -- pull the pure subset assumption into the context + refine pure_elim_r ?_ + intro hsubset + exact (own_inv_acc (W := W) (N := N) (E := E) (P := P) hsubset) + +omit [UFraction F] [FiniteMap Positive M] [DecidableEq Positive] + [FiniteMapLaws Positive M] [HeapFiniteMap Positive M] + [ElemG GF (InvF GF M F)] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem except0_sep_idemp {P Q R : IProp GF} : + BIBase.except0 (BIBase.sep P (BIBase.sep (BIBase.except0 Q) R)) ⊣⊢ + BIBase.except0 (BIBase.sep P (BIBase.sep Q R)) := by + -- distribute except0, eliminate the inner idempotence, then reassemble + calc + BIBase.except0 (BIBase.sep P (BIBase.sep (BIBase.except0 Q) R)) + ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.except0 (BIBase.sep (BIBase.except0 Q) R)) := by + -- push except0 into the outer sep + exact (except0_sep (P := P) (Q := BIBase.sep (BIBase.except0 Q) R)) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.sep (BIBase.except0 (BIBase.except0 Q)) (BIBase.except0 R)) := by + -- distribute except0 across the inner sep + exact sep_congr_r (except0_sep (P := BIBase.except0 Q) (Q := R)) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) + (BIBase.sep (BIBase.except0 Q) (BIBase.except0 R)) := by + -- collapse the redundant except0 + exact sep_congr_r (sep_congr_l except0_idemp) + _ ⊣⊢ BIBase.sep (BIBase.except0 P) (BIBase.except0 (BIBase.sep Q R)) := by + -- reassemble the inner except0 + exact sep_congr_r (except0_sep (P := Q) (Q := R)).symm + _ ⊣⊢ BIBase.except0 (BIBase.sep P (BIBase.sep Q R)) := by + -- pull except0 back out + exact (except0_sep (P := P) (Q := BIBase.sep Q R)).symm + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem fupd_drop_except0_post {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (P Q : IProp GF) : + uPred_fupd (M := M) (F := F) W E1 E2 + (BIBase.sep (BIBase.except0 P) Q) ⊢ + uPred_fupd (M := M) (F := F) W E1 E2 (BIBase.sep (PROP := IProp GF) P Q) := by + -- drop the redundant except0 under the outer except0 of fupd + unfold uPred_fupd + refine wand_mono_r ?_ + refine BIUpdate.mono ?_ + let A : IProp GF := wsat (GF := GF) (M := M) (F := F) W + let B : IProp GF := ownE W (⟨E2⟩ : CoPset) + have h : + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (BIBase.except0 P) Q))) ⊣⊢ + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (PROP := IProp GF) P Q))) := by + -- reassociate, drop the inner except0, then reassociate back + calc + BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (BIBase.except0 P) Q))) + ⊣⊢ BIBase.except0 (BIBase.sep (BIBase.sep A B) + (BIBase.sep (BIBase.except0 P) Q)) := by + -- expose the left-associated sep + exact except0_congr (sep_assoc (P := A) (Q := B) + (R := BIBase.sep (BIBase.except0 P) Q)).symm + _ ⊣⊢ BIBase.except0 (BIBase.sep (BIBase.sep A B) (BIBase.sep (PROP := IProp GF) P Q)) := by + -- remove the redundant except0 on the postcondition + exact except0_sep_idemp (P := BIBase.sep A B) (Q := P) (R := Q) + _ ⊣⊢ BIBase.except0 (BIBase.sep A (BIBase.sep B (BIBase.sep (PROP := IProp GF) P Q))) := by + -- restore right association + exact except0_congr (sep_assoc (P := A) (Q := B) (R := BIBase.sep (PROP := IProp GF) P Q)) + simpa [A, B] using h.1 + +/-! ## Properties -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `inv N P` is persistent. + + Coq: `inv_persistent` -/ +theorem inv_persistent {W : WsatGS GF} + (N : Namespace) (P : IProp GF) : + inv (GF := GF) (M := M) (F := F) W N P ⊢ + BIBase.persistently (inv (GF := GF) (M := M) (F := F) W N P) := by + simpa [inv] using + (persistently_idem_2 (PROP := IProp GF) + (P := BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True))))))) + +instance inv_persistent_inst {W : WsatGS GF} (N : Namespace) (P : IProp GF) : + Persistent (inv (GF := GF) (M := M) (F := F) W N P) := + ⟨inv_persistent (W := W) (N := N) (P := P)⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Non-expansive core of `inv` over a latered parameter. -/ +private theorem invBody_ne {W : WsatGS GF} (N : Namespace) : + OFE.NonExpansive (invBody (GF := GF) (M := M) (F := F) W N) := by + -- Push non-expansiveness through persistently, forall, imp, and fupd. + refine ⟨?_⟩ + intro n X Y hXY + unfold invBody + refine (persistently_ne.ne ?_) + refine forall_ne ?_ + intro E + refine (imp_ne.ne .rfl ?_) + have hwand : + BIBase.wand X (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)) ≡{n}≡ + BIBase.wand Y (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)) := + (wand_ne.ne hXY .rfl) + have hsep : BIBase.sep X (BIBase.wand X + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True))) ≡{n}≡ + BIBase.sep Y (BIBase.wand Y + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True))) := + (sep_ne.ne hXY hwand) + exact (uPred_fupd_ne (W := W) (E1 := E) (E2 := maskDiff E N)).ne hsep + +/-- `inv N` is contractive in its body. -/ +instance inv_contractive {W : WsatGS GF} (N : Namespace) : + OFE.Contractive (fun P => inv (GF := GF) (M := M) (F := F) W N P) := by + -- `inv` is `invBody` applied to the contractive `later`. + refine ⟨?_⟩ + intro n P Q hPQ + have hlater : + BIBase.later P ≡{n}≡ BIBase.later Q := + (OFE.Contractive.distLater_dist + (f := BIBase.later (PROP := IProp GF)) hPQ) + simpa [inv, invBody] using + (invBody_ne (GF := GF) (M := M) (F := F) (N := N) (W := W)).ne hlater + +/-- `inv N` is non-expansive in its body. -/ +instance inv_ne {W : WsatGS GF} (N : Namespace) : + OFE.NonExpansive (fun P => inv (GF := GF) (M := M) (F := F) W N P) := by + -- contractive functions are non-expansive + infer_instance + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- `inv` respects equivalence of its body. -/ +theorem inv_proper {W : WsatGS GF} (N : Namespace) {P Q : IProp GF} + (h : P ≡ Q) : inv (GF := GF) (M := M) (F := F) W N P ≡ + inv (GF := GF) (M := M) (F := F) W N Q := by + -- non-expansiveness preserves equivalence + exact OFE.NonExpansive.eqv (f := fun P => inv (GF := GF) (M := M) (F := F) W N P) h + +/-! ## Allocation -/ + +/-- Allocate a new invariant from `▷ P`. + + Proof strategy: use `ownI_alloc` from wsat to get a fresh invariant name + in `↑N`, then pack behind `□` to form `inv N P`. + + Coq: `inv_alloc` -/ +theorem inv_alloc {W : WsatGS GF} + (N : Namespace) (E : Iris.Set Positive) (P : IProp GF) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + BIBase.later P ⊢ + uPred_fupd (M := M) (F := F) W E E + (inv (GF := GF) (M := M) (F := F) W N P) := by + classical + unfold uPred_fupd + iintro HP + iintro H + icases H with ⟨Hwsat, HownE⟩ + -- allocate a fresh invariant name under `↑N` + ihave Halloc := + (wrapEntails (GF := GF) + (ownI_alloc (GF := GF) (M := M) (F := F) (W := W) + (φ := fun i => (nclose N).mem i) (P := P) hfresh)) $$ [Hwsat, HP] + · -- build the premise `wsat ∗ ▷ P` + isplitl [Hwsat] + · iexact Hwsat + · iexact HP + -- map the update result into the invariant and add except-0 + have hmono : + BIBase.sep (ownE W (mask E)) (BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P))) ⊢ + BIBase.except0 (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E)) + (inv (GF := GF) (M := M) (F := F) W N P))) := by + -- pull the existential out of the sep, then build the postcondition + refine (sep_exists_l (P := ownE W (mask E)) + (Ψ := fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P)))).1.trans ?_ + refine exists_elim ?_ + intro i + iintro Hres + icases Hres with ⟨HownE', Hrest⟩ + icases Hrest with ⟨Hmem, Hrest⟩ + icases Hmem with %Hmem + icases Hrest with ⟨Hwsat', HownI⟩ + -- assemble the postcondition, building `inv` from `own_inv` + iapply (wrapEntails (GF := GF) (except0_intro (P := _))) + isplitl [Hwsat'] + · iexact Hwsat' + · isplitl [HownE'] + · iexact HownE' + · -- derive `inv` from the internal ownership witness + iapply (wrapEntails (GF := GF) + (own_inv_to_inv (W := W) (N := N) (P := P))) + unfold own_inv + iexists i + isplit + · ipure_intro + exact Hmem + · iexact HownI + -- frame `ownE` through the update and apply monotonicity + iapply (wrapEntails (GF := GF) + (BIUpdate.mono + (P := BIBase.sep (ownE W (mask E)) (BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P)))) + (Q := BIBase.except0 <| + BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E)) + (inv (GF := GF) (M := M) (F := F) W N P))) + hmono)) + iapply (wrapEntails (GF := GF) + (bupd_frame_l (P := ownE W (mask E)) + (Q := BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P))))) + isplitl [HownE] + · iexact HownE + · iexact Halloc + +/-- Allocate an invariant and immediately open it. + + Coq: `inv_alloc_open` -/ +theorem inv_alloc_open {W : WsatGS GF} + (N : Namespace) (E : Iris.Set Positive) (P : IProp GF) + (h : Subset (nclose N).mem E) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (nclose N).mem i) : + (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) := by + classical + unfold uPred_fupd + iintro Hemp + iintro H + icases H with ⟨Hwsat, HownE⟩ + ihave HwsatB := + (wrapEntails (GF := GF) + (BIUpdate.intro (P := wsat (GF := GF) (M := M) (F := F) W))) $$ Hwsat + -- allocate and immediately open an invariant in `↑N` + ihave Halloc := + (wrapEntails (GF := GF) + (ownI_alloc_open (GF := GF) (M := M) (F := F) (W := W) + (φ := fun i => (nclose N).mem i) (P := P) hfresh)) $$ HwsatB + ihave Halloc' := + (wrapEntails (GF := GF) + (bupd_frame_l (P := ownE W (mask E)) + (Q := BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep + (BIBase.wand (ownE W (CoPset.singleton i)) + (wsat (GF := GF) (M := M) (F := F) W)) + (BIBase.sep (ownI (GF := GF) (M := M) (F := F) W i P) + (ownD W (GSet.singleton i))))))) $$ [HownE, Halloc] + · isplitl [HownE] + · iexact HownE + · iexact Halloc + have hmono_wand : + (BIBase.emp : IProp GF) ⊢ + iprop((ownE W (mask E) ∗ + BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep + (BIBase.wand (ownE W (CoPset.singleton i)) + (wsat (GF := GF) (M := M) (F := F) W)) + (BIBase.sep (ownI (GF := GF) (M := M) (F := F) W i P) + (ownD W (GSet.singleton i))))) -∗ + BIBase.except0 + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (BIBase.sep (ownE W (mask (maskDiff E N))) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True))))))) := by + iintro - + iintro Hres + icases Hres with ⟨HownE, Halloc⟩ + icases Halloc with ⟨%i, Halloc⟩ + icases Halloc with ⟨Hmem, Halloc⟩ + icases Hmem with %Hmem + icases Halloc with ⟨HopenW, Halloc⟩ + icases Halloc with ⟨HownI', HownD⟩ + icases HownI' with #HownI' + -- split `ownE E` into `ownE {i}`, `ownE (↑N \ {i})`, and `ownE (E \ ↑N)` + have hmask : mask E = (nclose N) ∪ mask (maskDiff E N) := by + ext x; constructor + · intro hx + by_cases hxN : (nclose N).mem x + · exact Or.inl hxN + · exact Or.inr ⟨hx, hxN⟩ + · intro hx + cases hx with + | inl hxN => exact h _ hxN + | inr hxDiff => exact hxDiff.1 + have hdisj : CoPset.Disjoint (nclose N) (mask (maskDiff E N)) := by + intro x hx + exact hx.2.2 hx.1 + let rest : CoPset := nclose N \ CoPset.singleton i + have hmaskN : (nclose N) = (CoPset.singleton i) ∪ rest := by + ext x; constructor + · intro hxN + by_cases hx : x = i + · left; simpa [CoPset.mem_singleton] using hx + · right; exact ⟨hxN, by simpa [CoPset.mem_singleton, rest] using hx⟩ + · intro hx + cases hx with + | inl hx => + have hx' : x = i := by simpa [CoPset.mem_singleton] using hx + subst hx' + exact Hmem + | inr hx => exact hx.1 + have hdisjN : CoPset.Disjoint (CoPset.singleton i) rest := by + intro x hx + exact hx.2.2 hx.1 + have hsplit : + ownE W (mask E) ⊢ + BIBase.sep (ownE W (nclose N)) (ownE W (mask (maskDiff E N))) := by + -- rewrite the mask to the disjoint union and apply `ownE_op` + rw [hmask] + exact (ownE_op (W := W) (E₁ := nclose N) (E₂ := mask (maskDiff E N)) hdisj).1 + ihave Hsplit := (wrapEntails (GF := GF) hsplit) $$ HownE + icases Hsplit with ⟨HownEN, HownEdiff⟩ + have hsplitN : + ownE W (nclose N) ⊢ + BIBase.sep (ownE W (CoPset.singleton i)) (ownE W rest) := by + -- rewrite the namespace to the singleton union and apply `ownE_op` + rw [hmaskN] + exact (ownE_op (W := W) (E₁ := CoPset.singleton i) (E₂ := rest) hdisjN).1 + ihave HsplitN := (wrapEntails (GF := GF) hsplitN) $$ HownEN + icases HsplitN with ⟨HownEi, HownErest⟩ + -- open the invariant using the allocated opener + ihave Hwsat' := HopenW $$ HownEi + -- build the result + iapply (wrapEntails (GF := GF) (except0_intro (P := _))) + isplitl [Hwsat'] + · iexact Hwsat' + · isplitl [HownEdiff] + · iexact HownEdiff + · -- package `inv` and the closing wand + isplitl [] + · -- `inv` from `own_inv` + iapply (wrapEntails (GF := GF) (own_inv_to_inv (W := W) (N := N) (P := P))) + unfold own_inv + iexists i + isplit + · ipure_intro + exact Hmem + · iexact HownI' + · iintro HP + unfold uPred_fupd + iintro Hclose + icases Hclose with ⟨Hwsat2, HownEdiff2⟩ + ihave Hclose' := + (wrapEntails (GF := GF) + (ownI_close (W := W) (M := M) (F := F) i P)) $$ [Hwsat2, HownI', HP, HownD] + · -- build the premise `((wsat ∗ ownI) ∗ ▷ P) ∗ ownD` + isplitl [Hwsat2 HP] + · isplitl [Hwsat2] + · isplitl [Hwsat2] + · iexact Hwsat2 + · iexact HownI' + · iexact HP + · iexact HownD + icases Hclose' with ⟨Hwsat3, HownEi'⟩ + have hjoinN : + BIBase.sep (ownE W (CoPset.singleton i)) (ownE W rest) ⊢ + ownE W (nclose N) := by + -- rewrite the namespace to the singleton union and apply `ownE_op` + rw [hmaskN] + exact (ownE_op (W := W) (E₁ := CoPset.singleton i) (E₂ := rest) hdisjN).2 + ihave HjoinN := (wrapEntails (GF := GF) hjoinN) $$ [HownEi', HownErest] + · -- assemble the singleton/rest split + isplitl [HownEi'] + · iexact HownEi' + · iexact HownErest + have hjoin : + BIBase.sep (ownE W (nclose N)) (ownE W (mask (maskDiff E N))) ⊢ + ownE W (mask E) := by + -- rewrite the mask to the disjoint union and apply `ownE_op` + rw [hmask] + exact (ownE_op (W := W) (E₁ := nclose N) + (E₂ := mask (maskDiff E N)) hdisj).2 + ihave Hjoin := (wrapEntails (GF := GF) hjoin) $$ [HjoinN, HownEdiff2] + · -- rejoin `↑N` with the remaining mask + isplitl [HjoinN] + · iexact HjoinN + · iexact HownEdiff2 + iapply BIUpdate.intro + iapply (wrapEntails (GF := GF) (except0_intro (P := _))) + isplitl [Hwsat3] + · iexact Hwsat3 + · isplitl [Hjoin] + · iexact Hjoin + · ipure_intro + exact True.intro + have hmono : + BIBase.sep (ownE W (mask E)) + (BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep + (BIBase.wand (ownE W (CoPset.singleton i)) + (wsat (GF := GF) (M := M) (F := F) W)) + (BIBase.sep (ownI (GF := GF) (M := M) (F := F) W i P) + (ownD W (GSet.singleton i))))) ⊢ + BIBase.except0 + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (BIBase.sep (ownE W (mask (maskDiff E N))) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))))) := by + -- move the wand proof under a sep and eliminate it + refine (sep_emp (P := BIBase.sep (ownE W (mask E)) + (BIBase.exists fun i => + BIBase.sep (BIBase.pure ((nclose N).mem i)) + (BIBase.sep + (BIBase.wand (ownE W (CoPset.singleton i)) + (wsat (GF := GF) (M := M) (F := F) W)) + (BIBase.sep (ownI (GF := GF) (M := M) (F := F) W i P) + (ownD W (GSet.singleton i))))))).2.trans ?_ + refine (sep_mono .rfl hmono_wand).trans ?_ + exact wand_elim_r + have hmono' := by + -- unfold the nested fupd to match the goal after `unfold uPred_fupd` + simpa [uPred_fupd, wsat'] using hmono + iapply (wrapEntails (GF := GF) (BIUpdate.mono hmono')) + iexact Halloc' + +/-! ## Access -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Open an invariant: given `↑N ⊆ E`, access `▷ P` with a closing view shift. + + Proof strategy: unfold `inv` definition, apply the universally quantified + body to `E` with the subset proof. + + Coq: `inv_acc` -/ +theorem inv_acc {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) + (h : Subset (nclose N).mem E) : + inv (GF := GF) (M := M) (F := F) W N P ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) := by + have hwand : + (BIBase.emp : IProp GF) ⊢ + iprop((inv (GF := GF) (M := M) (F := F) W N P) -∗ + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))))) := by + unfold inv + iintro - + iintro Hinv + iapply Hinv $$ %E + ipure_intro + exact h + -- eliminate the wand using `emp` framing + refine (sep_emp (P := inv (GF := GF) (M := M) (F := F) W N P)).2.trans ?_ + refine (sep_mono .rfl hwand).trans ?_ + exact wand_elim_r + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Access a timeless invariant: strip the `▷` when `P` is timeless. + + Coq: `inv_acc_timeless` -/ +theorem inv_acc_timeless {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) + (h : Subset (nclose N).mem E) + (htimeless : (BIBase.later P : IProp GF) ⊢ + BIBase.or (BIBase.later (BIBase.pure False)) P) : + inv (GF := GF) (M := M) (F := F) W N P ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep P + (BIBase.wand P + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True)))) := by + -- first open the invariant, then use timelessness to drop the later + have hclose : + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)) ⊢ + BIBase.wand P + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True) : IProp GF) := + wand_mono (later_intro (P := P)) .rfl + have hpost : + BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) ⊢ + BIBase.sep (BIBase.except0 P) + (BIBase.wand P + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)) : IProp GF) := + sep_mono htimeless hclose + refine (inv_acc (W := W) (E := E) (N := N) (P := P) h).trans ?_ + -- replace `▷ P` by `◇ P` in the postcondition + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := _ ) (Q := _ ) hpost + -- drop the redundant `◇` under the outer except-0 + exact hmono.trans (fupd_drop_except0_post (W := W) (M := M) (F := F) + (E1 := E) (E2 := maskDiff E N) (P := P) + (Q := BIBase.wand P + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + +/-! ## Derived Properties -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem maskDiff_self (N : Namespace) : + maskDiff (nclose N).mem N = (fun _ => False) := by + -- membership is contradictory for the same namespace + funext i; simp [maskDiff] + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem mask_union_diff (N : Namespace) (E : Iris.Set Positive) + (h : Subset (nclose N).mem E) : + (fun x => (nclose N).mem x ∨ maskDiff E N x) = E := by + -- split on whether `x` is in the namespace + funext i; apply propext; constructor + · intro hx; cases hx with + | inl hN => exact h _ hN + | inr hdiff => exact hdiff.1 + · intro hE; by_cases hN : (nclose N).mem i + · exact Or.inl hN + · exact Or.inr ⟨hE, hN⟩ + +/-! ### Mask Helpers -/ + +/- A two-namespace mask difference. -/ +private abbrev maskDiff2 (E : Iris.Set Positive) (N1 N2 : Namespace) : + Iris.Set Positive := + -- drop both namespaces from the mask + fun x => E x ∧ ¬(nclose N1).mem x ∧ ¬(nclose N2).mem x + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem maskDiff2_eq (E : Iris.Set Positive) (N1 N2 : Namespace) : + maskDiff (maskDiff E N1) N2 = maskDiff2 E N1 N2 := by + -- unfold nested differences and reassociate + funext i; simp [maskDiff, maskDiff2, and_assoc] + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem maskDiff2_subset_of_union (E : Iris.Set Positive) + (N1 N2 N : Namespace) + (hsubset : Subset (fun x => (nclose N1).mem x ∨ (nclose N2).mem x) (nclose N).mem) : + Subset (maskDiff E N) (maskDiff2 E N1 N2) := by + -- use the union subset to exclude both namespaces + intro i hi + have hN1 : ¬(nclose N1).mem i := by + intro hN1; exact hi.2 (hsubset _ (Or.inl hN1)) + have hN2 : ¬(nclose N2).mem i := by + intro hN2; exact hi.2 (hsubset _ (Or.inr hN2)) + exact ⟨hi.1, hN1, hN2⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem nclose_subset_maskDiff (E : Iris.Set Positive) + (N1 N2 : Namespace) + (hdisj : CoPset.Disjoint (nclose N1) (nclose N2)) + (hE : Subset (nclose N2).mem E) : + Subset (nclose N2).mem (maskDiff E N1) := by + -- keep `N2` inside the mask while excluding `N1` + intro i hi + have hN1 : ¬(nclose N1).mem i := by + intro hN1; exact (hdisj i) ⟨hN1, hi⟩ + exact ⟨hE _ hi, hN1⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem fupd_from_split' {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (E3 : CoPset) + (hE : mask E1 = mask E2 ∪ E3) (hdisj : CoPset.Disjoint (mask E2) E3) + (P : IProp GF) : + BIBase.sep (ownE W E3) P ⊢ uPred_fupd (M := M) (F := F) W E2 E1 P := by + -- reassemble the mask, then wrap with except-0 and bupd + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_comm (P := BIBase.sep (ownE W E3) P) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E2)))).1.trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := BIBase.sep (ownE W E3) P)).1.trans ?_ + refine (sep_mono .rfl + (sep_assoc (P := ownE W (mask E2)) (Q := ownE W E3) (R := P)).2).trans ?_ + have hown : BIBase.sep (ownE W (mask E2)) (ownE W E3) ⊢ ownE W (mask E1) := by + -- collapse the split mask back to `E1` + simpa [hE] using (ownE_op (W := W) (E₁ := mask E2) (E₂ := E3) hdisj).2 + refine (sep_mono .rfl (sep_mono hown .rfl)).trans ?_ + exact (except0_intro).trans BIUpdate.intro + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem fupd_mask_intro {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (h : Subset E2 E1) (P : IProp GF) : + BIBase.wand (uPred_fupd (M := M) (F := F) W E2 E1 (BIBase.emp : IProp GF)) P ⊢ + uPred_fupd (M := M) (F := F) W E1 E2 P := by + -- split `E1` into `E2` plus the disjoint remainder, then apply the wand + rcases CoPset.subseteq_disjoint_union (s₁ := mask E2) (s₂ := mask E1) h with + ⟨E3, hE, hdisj⟩ + let Hwand : IProp GF := + BIBase.wand (uPred_fupd (M := M) (F := F) W E2 E1 (BIBase.emp : IProp GF)) P + have hsplit : ownE W (mask E1) ⊢ BIBase.sep (ownE W (mask E2)) (ownE W E3) := by + -- expose the split mask via `ownE_op` + simpa [hE] using (ownE_op (W := W) (E₁ := mask E2) (E₂ := E3) hdisj).1 + have hwand : + BIBase.sep (ownE W E3) Hwand ⊢ P := by + -- build the closing fupd from `ownE E3`, then eliminate the wand + have hfupd : + BIBase.sep (ownE W E3) (BIBase.emp : IProp GF) ⊢ + uPred_fupd (M := M) (F := F) W E2 E1 (BIBase.emp : IProp GF) := + fupd_from_split' (W := W) (E1 := E1) (E2 := E2) (E3 := E3) hE hdisj + (P := (BIBase.emp : IProp GF)) + refine (sep_mono (sep_emp (P := ownE W E3)).2 .rfl).trans ?_ + refine (sep_mono hfupd .rfl).trans ?_ + exact wand_elim_r + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_comm (P := Hwand) (Q := BIBase.sep (wsat' (M := M) (F := F) W) + (ownE W (mask E1)))).1.trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E1)) + (R := Hwand)).1.trans ?_ + refine (sep_mono .rfl (sep_mono hsplit .rfl)).trans ?_ + refine (sep_mono .rfl + (sep_assoc (P := ownE W (mask E2)) (Q := ownE W E3) + (R := Hwand)).1).trans ?_ + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) + (R := BIBase.sep (ownE W E3) Hwand)).2.trans ?_ + -- introduce the bupd and the except-0 wrapper + have hupd : + BIBase.sep (BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E2))) P ⊢ + BUpd.bupd (BIBase.except0 (BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))) := by + -- reassociate, then use `bupd` intro and monotonicity for `except0` + refine (sep_assoc (P := wsat' (M := M) (F := F) W) (Q := ownE W (mask E2)) (R := P)).1.trans ?_ + exact (BIUpdate.intro (P := BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P))).trans + (BIUpdate.mono (PROP := IProp GF) + (except0_intro (P := BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask E2)) P)))) + exact (sep_mono .rfl hwand).trans hupd + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem fupd_wand_r {W : WsatGS GF} + (E1 E2 : Iris.Set Positive) (P Q : IProp GF) : + BIBase.sep (uPred_fupd (M := M) (F := F) W E1 E2 P) (BIBase.wand P Q) ⊢ + uPred_fupd (M := M) (F := F) W E1 E2 Q := by + -- frame the wand through the update, then eliminate it + iintro H + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (E1 := E1) (E2 := E2) + (P := BIBase.sep P (BIBase.wand P Q)) (Q := Q) (wand_elim_r (P := P) (Q := Q)))) + iapply (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := E1) (E2 := E2) + (P := P) (Q := BIBase.wand P Q))) + iexact H + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem maskDiff_union_right (E : Iris.Set Positive) (N : Namespace) : + (fun x => maskDiff (nclose N).mem N x ∨ maskDiff E N x) = maskDiff E N := by + -- the left disjunct is always false + funext i; simp [maskDiff] + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem inv_close_strong {W : WsatGS GF} + (N : Namespace) (P : IProp GF) : + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W + (maskDiff (nclose N).mem N) (nclose N).mem (BIBase.pure True)) ⊢ + BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)) := by + classical + iintro Hclose + iintro %E' + iintro HP + -- apply the original close shift and frame the extra mask + have hdisj : CoPset.Disjoint (mask (fun _ => False)) (mask E') := by + intro i hi; exact hi.1 + have hframe : + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)) ⊢ + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)) := by + refine wand_mono_r ?_ + have hframe' : + uPred_fupd (M := M) (F := F) W (fun _ => False) (nclose N).mem (BIBase.pure True) ⊢ + uPred_fupd (M := M) (F := F) W + (fun x => False ∨ E' x) (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True) := + fupd_mask_frame_r (M := M) (F := F) (W := W) (E1 := fun _ => False) + (E2 := (nclose N).mem) (Ef := E') (P := BIBase.pure True) hdisj + have hfalse : (fun x => False ∨ E' x) = E' := by + funext i; simp + simpa [maskDiff_self (N := N), hfalse] using hframe' + ihave Hclose' := (wrapEntails (GF := GF) hframe) $$ Hclose + ispecialize Hclose' $$ HP + iexact Hclose' + +/-! ### Combination and Splitting -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem later_dup (P : IProp GF) : + BIBase.persistently (BIBase.wand P (BIBase.sep P P)) ⊢ + BIBase.wand (BIBase.later P) (BIBase.sep (BIBase.later P) (BIBase.later P)) := by + -- duplicate a latered proposition using the persistent duplicator + iintro Hdup + iintro HP + ihave Hdup' := + (wrapEntails (GF := GF) + (intuitionistically_elim (P := BIBase.wand P (BIBase.sep P P)))) $$ Hdup + ihave Hlater := + (wrapEntails (GF := GF) + (later_intro (P := BIBase.wand P (BIBase.sep P P)))) $$ Hdup' + ihave Hwand := + (wrapEntails (GF := GF) + (later_wand (P := P) (Q := BIBase.sep P P))) $$ Hlater + ispecialize Hwand $$ HP + ihave Hsplit := (wrapEntails (GF := GF) + (later_sep (P := P) (Q := P)).1) $$ Hwand + iexact Hsplit + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem inv_split_l_transform (P Q : IProp GF) : + (BIBase.emp : IProp GF) ⊢ + BIBase.later (BIBase.intuitionistically + (BIBase.wand (BIBase.sep (PROP := IProp GF) P Q) + (BIBase.sep P (BIBase.wand P (BIBase.sep (PROP := IProp GF) P Q))))) := by + -- build the latered, persistent split/merge witness + have hwand : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand (BIBase.sep (PROP := IProp GF) P Q) + (BIBase.sep P (BIBase.wand P (BIBase.sep (PROP := IProp GF) P Q))) := by + iintro _ + iintro HPQ + icases HPQ with ⟨HP, HQ⟩ + isplitl [HP] + · iexact HP + · iintro HP' + isplitl [HP'] + · iexact HP' + · iexact HQ + have hbox : + BIBase.intuitionistically (BIBase.emp : IProp GF) ⊢ + BIBase.wand (BIBase.sep (PROP := IProp GF) P Q) + (BIBase.sep P (BIBase.wand P (BIBase.sep (PROP := IProp GF) P Q))) := + (intuitionistically_elim (P := (BIBase.emp : IProp GF))).trans hwand + have hboxed : + BIBase.intuitionistically (BIBase.emp : IProp GF) ⊢ + BIBase.intuitionistically + (BIBase.wand (BIBase.sep (PROP := IProp GF) P Q) + (BIBase.sep P (BIBase.wand P (BIBase.sep (PROP := IProp GF) P Q)))) := + intuitionistically_intro' hbox + have hemp : + (BIBase.emp : IProp GF) ⊢ + BIBase.intuitionistically (BIBase.emp : IProp GF) := + (intuitionistically_emp (PROP := IProp GF)).2 + exact (hemp.trans hboxed).trans (later_intro (P := _)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem inv_acc_strong_frame {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) + (h : Subset (nclose N).mem E) : + uPred_fupd (M := M) (F := F) W (nclose N).mem + (maskDiff (nclose N).mem N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)))) ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)))) := by + -- rewrite mask unions and apply `fupd_mask_frame_r` + have hdisj : + CoPset.Disjoint (mask (nclose N).mem) (mask (maskDiff E N)) := by + intro i hi; exact hi.2.2 hi.1 + simpa [mask_union_diff (N := N) (E := E) h, maskDiff_union_right (E := E) (N := N), + maskDiff_self (N := N)] using + (fupd_mask_frame_r (W := W) (E1 := (nclose N).mem) + (E2 := maskDiff (nclose N).mem N) (Ef := maskDiff E N) + (P := BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)))) + hdisj) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem inv_acc_strong_post {W : WsatGS GF} + (N : Namespace) (P : IProp GF) : + BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True))) ⊢ + BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True))) := by + -- keep the later and strengthen the closing wand + exact sep_mono .rfl (inv_close_strong (W := W) (N := N) (P := P)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +private theorem inv_acc_strong_mono {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) : + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)))) ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) := by + -- lift the postcondition via `fupd_mono` + exact fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff (nclose N).mem N) + (nclose N).mem (BIBase.pure True)))) + (Q := BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) + (inv_acc_strong_post (W := W) (N := N) (P := P)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Combine disjoint invariants into a larger namespace. + + Coq: `inv_combine` -/ +theorem inv_combine {W : WsatGS GF} + (N1 N2 N : Namespace) (P Q : IProp GF) + (hdisj : CoPset.Disjoint (nclose N1) (nclose N2)) + (hsubset : Subset (fun x => (nclose N1).mem x ∨ (nclose N2).mem x) (nclose N).mem) : + inv (GF := GF) (M := M) (F := F) W N1 P ⊢ + BIBase.wand (inv (GF := GF) (M := M) (F := F) W N2 Q) + (inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q)) := by + classical + iintro HinvP + iintro HinvQ + -- unfold the invariant body and build it under a persistent context + let body : IProp GF := + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (BIBase.wand (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))))) + have hbody : + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N1 P) + (inv (GF := GF) (M := M) (F := F) W N2 Q) ⊢ + body := by + -- unpack the invariant context and prove the body + iintro Hctx + icases Hctx with ⟨HinvP', HinvQ'⟩ + iintro %E + iintro hE + icases hE with %hE + -- derive namespace inclusions for both invariants + have hN1 : Subset (nclose N1).mem E := by + intro i hi; exact hE _ (hsubset _ (Or.inl hi)) + have hN2 : Subset (nclose N2).mem E := by + intro i hi; exact hE _ (hsubset _ (Or.inr hi)) + have hN2' : + Subset (nclose N2).mem (maskDiff E N1) := + nclose_subset_maskDiff (E := E) (N1 := N1) (N2 := N2) hdisj hN2 + -- abbreviations for the staged postconditions + let E12 : Iris.Set Positive := maskDiff (maskDiff E N1) N2 + let postP : IProp GF := + BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N1) E (BIBase.pure True))) + let postQ : IProp GF := + BIBase.sep (BIBase.later Q) + (BIBase.wand (BIBase.later Q) + (uPred_fupd (M := M) (F := F) W E12 (maskDiff E N1) (BIBase.pure True))) + let postPQ : IProp GF := + BIBase.sep (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (BIBase.wand (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + -- open the left invariant + ihave HaccP := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := E) (N := N1) (P := P) hN1)) $$ HinvP' + -- sequence the two accesses with `fupd_trans` + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := E) (E2 := maskDiff E N1) (E3 := maskDiff E N) + (P := postPQ))) + -- strengthen the postcondition after opening `N1` + have hpost : + BIBase.sep postP (inv (GF := GF) (M := M) (F := F) W N2 Q) ⊢ + uPred_fupd (M := M) (F := F) W (maskDiff E N1) (maskDiff E N) postPQ := by + -- open `N2` under a framed postcondition + iintro Hctx' + icases Hctx' with ⟨HpostP, HinvQ''⟩ + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := maskDiff E N1) (E2 := E12) (E3 := maskDiff E N) + (P := postPQ))) + -- open the right invariant inside the postcondition + ihave HaccQ := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := maskDiff E N1) (N := N2) (P := Q) hN2')) $$ HinvQ'' + have hpostQ : + BIBase.sep postQ postP ⊢ uPred_fupd (M := M) (F := F) W E12 (maskDiff E N) postPQ := by + -- introduce the smaller mask and assemble the closing wand + iintro Hpost + icases Hpost with ⟨HpostQ, HpostP⟩ + icases HpostP with ⟨HP, HcloseP⟩ + icases HpostQ with ⟨HQ, HcloseQ⟩ + have hsubset_mask : Subset (maskDiff E N) E12 := by + -- rewrite the two-step mask difference + simpa [E12, maskDiff2_eq] using + (maskDiff2_subset_of_union (E := E) (N1 := N1) (N2 := N2) (N := N) hsubset) + iapply (wrapEntails (GF := GF) + (fupd_mask_intro (W := W) (E1 := E12) (E2 := maskDiff E N) hsubset_mask postPQ)) + iintro Hclose + have hlater : + BIBase.sep (BIBase.later P) (BIBase.later Q) ⊢ BIBase.later (BIBase.sep (PROP := IProp GF) P Q) := + (later_sep (P := P) (Q := Q)).2 + ihave HPQ := (wrapEntails (GF := GF) hlater) $$ [HP, HQ] + -- unfold the target postcondition and split it + simp + isplitl [HPQ] + · iexact HPQ + · -- close the smaller mask, then `N2`, then `N1` + iintro HPQ' + ihave HPQ'' := + (wrapEntails (GF := GF) + (later_sep (P := P) (Q := Q)).1) $$ HPQ' + icases HPQ'' with ⟨HP', HQ'⟩ + -- first close `Q`, then re-close the outer mask + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := maskDiff E N) (E2 := maskDiff E N1) (E3 := E) + (P := BIBase.pure True))) + iapply (wrapEntails (GF := GF) + (fupd_wand_r (W := W) (M := M) (F := F) (E1 := maskDiff E N) (E2 := maskDiff E N1) + (P := BIBase.pure True) + (Q := uPred_fupd (M := M) (F := F) W (maskDiff E N1) E (BIBase.pure True)))) + isplitl [Hclose HcloseQ HQ'] + · -- close `Q` inside the intermediate mask + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := maskDiff E N) (E2 := E12) (E3 := maskDiff E N1) + (P := BIBase.pure True))) + iapply (wrapEntails (GF := GF) + (fupd_wand_r (W := W) (M := M) (F := F) (E1 := maskDiff E N) (E2 := E12) + (P := (BIBase.emp : IProp GF)) + (Q := uPred_fupd (M := M) (F := F) W E12 (maskDiff E N1) (BIBase.pure True)))) + isplitl [Hclose] + · iexact Hclose + · iintro - + iapply HcloseQ + iexact HQ' + · -- ignore `True` and close `P` + iintro _ + iapply HcloseP + iexact HP' + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (E1 := maskDiff E N1) (E2 := E12) (P := BIBase.sep postQ postP) + (Q := uPred_fupd (M := M) (F := F) W E12 (maskDiff E N) postPQ) hpostQ)) + iapply (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := maskDiff E N1) (E2 := E12) + (P := postQ) (Q := postP))) + isplitl [HaccQ] + · iexact HaccQ + · iexact HpostP + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (E1 := E) (E2 := maskDiff E N1) + (P := BIBase.sep postP (inv (GF := GF) (M := M) (F := F) W N2 Q)) + (Q := uPred_fupd (M := M) (F := F) W (maskDiff E N1) (maskDiff E N) postPQ) hpost)) + iapply (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N1) + (P := postP) + (Q := inv (GF := GF) (M := M) (F := F) W N2 Q))) + isplitl [HaccP] + · iexact HaccP + · iexact HinvQ' + have hpers : + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N1 P) + (inv (GF := GF) (M := M) (F := F) W N2 Q) ⊢ + BIBase.persistently body := + persistently_intro'' + (P := BIBase.sep (inv (GF := GF) (M := M) (F := F) W N1 P) + (inv (GF := GF) (M := M) (F := F) W N2 Q)) + (Q := body) hbody + iapply (wrapEntails (GF := GF) (by simpa [body] using hpers)) + isplitl [HinvP] + · iexact HinvP + · iexact HinvQ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Combine invariants using a duplicable left component. + + Coq: `inv_combine_dup_l` -/ +theorem inv_combine_dup_l {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + BIBase.persistently (BIBase.wand P (BIBase.sep P P)) ⊢ + BIBase.wand (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (inv (GF := GF) (M := M) (F := F) W N Q) + (inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q))) := by + classical + iintro Hdup + iintro HinvP + iintro HinvQ + -- unfold the invariant body and build it under a persistent context + let body : IProp GF := + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (BIBase.wand (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))))) + have hbody : + BIBase.sep (BIBase.persistently (BIBase.wand P (BIBase.sep P P))) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (inv (GF := GF) (M := M) (F := F) W N Q)) ⊢ + body := by + -- unpack the invariant context and prove the body + iintro Hctx + icases Hctx with ⟨Hdup', HinvPQ⟩ + icases HinvPQ with ⟨HinvP', HinvQ'⟩ + iintro %E + iintro hE + icases hE with %hE + -- abbreviations for postconditions + let postP : IProp GF := + BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + let postQ : IProp GF := + BIBase.sep (BIBase.later Q) + (BIBase.wand (BIBase.later Q) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + let postPQ : IProp GF := + BIBase.sep (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (BIBase.wand (BIBase.later (BIBase.sep (PROP := IProp GF) P Q)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + -- open the left invariant first + ihave HaccP := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := E) (N := N) (P := P) hE)) $$ HinvP' + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := E) (E2 := maskDiff E N) (E3 := maskDiff E N) (P := postPQ))) + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep postP + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N Q) + (BIBase.persistently (BIBase.wand P (BIBase.sep P P))))) + (Q := uPred_fupd (M := M) (F := F) W (maskDiff E N) (maskDiff E N) postPQ) ?_)) + · -- close `P`, open `Q`, then build the combined invariant + iintro Hpost + icases Hpost with ⟨HpostP, Hrest⟩ + icases Hrest with ⟨HinvQ'', Hdup''⟩ + icases HpostP with ⟨HP, HcloseP⟩ + ihave HPdup := + (wrapEntails (GF := GF) (later_dup (P := P))) $$ Hdup'' + ispecialize HPdup $$ HP + icases HPdup with ⟨HP1, HP2⟩ + -- close the left invariant to restore the mask + ihave Hclosed := HcloseP $$ HP2 + -- open the right invariant + ihave HaccQ := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := E) (N := N) (P := Q) hE)) $$ HinvQ'' + -- build the postcondition for the combined invariant + have hpostQ : BIBase.sep postQ (BIBase.later P) ⊢ postPQ := by + -- use the remaining `▷P` and `▷Q` + iintro Hpost + icases Hpost with ⟨HpostQ, HP1'⟩ + icases HpostQ with ⟨HQ, HcloseQ⟩ + have hlater : + BIBase.sep (BIBase.later P) (BIBase.later Q) ⊢ BIBase.later (BIBase.sep (PROP := IProp GF) P Q) := + (later_sep (P := P) (Q := Q)).2 + ihave HPQ := (wrapEntails (GF := GF) hlater) $$ [HP1', HQ] + -- unfold the target postcondition and split it + simp + isplitl [HPQ] + · iexact HPQ + · -- close using the right invariant only + iintro HPQ' + ihave HPQ'' := + (wrapEntails (GF := GF) + (later_sep (P := P) (Q := Q)).1) $$ HPQ' + icases HPQ'' with ⟨_, HQ'⟩ + iapply HcloseQ + iexact HQ' + -- sequence closing `P` with opening `Q` + iapply (wrapEntails (GF := GF) + (fupd_trans (W := W) (E1 := maskDiff E N) (E2 := E) (E3 := maskDiff E N) (P := postPQ))) + iapply (wrapEntails (GF := GF) + (fupd_wand_r (W := W) (M := M) (F := F) (E1 := maskDiff E N) (E2 := E) + (P := BIBase.pure True) + (Q := uPred_fupd (M := M) (F := F) W E (maskDiff E N) postPQ))) + isplitl [Hclosed] + · iexact Hclosed + · -- ignore `True` and use the access to `Q` + iintro _ + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep postQ (BIBase.later P)) (Q := postPQ) hpostQ)) + iapply (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := postQ) (Q := BIBase.later P))) + isplitl [HaccQ] + · iexact HaccQ + · iexact HP1 + iapply (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := postP) + (Q := BIBase.sep (inv (GF := GF) (M := M) (F := F) W N Q) + (BIBase.persistently (BIBase.wand P (BIBase.sep P P)))))) + isplitl [HaccP] + · iexact HaccP + · isplitl [HinvQ'] + · iexact HinvQ' + · iexact Hdup' + have hpers : + BIBase.sep (BIBase.persistently (BIBase.wand P (BIBase.sep P P))) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (inv (GF := GF) (M := M) (F := F) W N Q)) ⊢ + BIBase.persistently body := + persistently_intro'' + (P := BIBase.sep (BIBase.persistently (BIBase.wand P (BIBase.sep P P))) + (BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (inv (GF := GF) (M := M) (F := F) W N Q))) + (Q := body) hbody + iapply (wrapEntails (GF := GF) (by simpa [body] using hpers)) + isplitl [Hdup] + · iexact Hdup + · isplitl [HinvP] + · iexact HinvP + · iexact HinvQ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Invariants are except-0. + + Coq: `except_0_inv` -/ +theorem except_0_inv {W : WsatGS GF} + (N : Namespace) (P : IProp GF) : + BIBase.except0 (inv (GF := GF) (M := M) (F := F) W N P) ⊢ + inv (GF := GF) (M := M) (F := F) W N P := by + -- unfold the invariant body and eliminate the outer `◇` by cases + unfold inv + let body : IProp GF := + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))))) + have hfalse_body : BIBase.later (BIBase.pure False) ⊢ body := by + refine forall_intro ?_ + intro E + refine imp_intro ?_ + refine pure_elim_r ?_ + intro _ + -- `▷ False` proves any fancy update + unfold uPred_fupd + refine wand_intro ?_ + refine (sep_elim_l (P := BIBase.later (BIBase.pure False)) + (Q := BIBase.sep (wsat' (M := M) (F := F) W) (ownE W (mask E)))).trans ?_ + let post : IProp GF := + BIBase.sep (wsat' (M := M) (F := F) W) + (BIBase.sep (ownE W (mask (maskDiff E N))) + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))))) + have hor : BIBase.later (BIBase.pure False) ⊢ BIBase.except0 post := by + -- `◇ post` is `▷ False ∨ post` + exact or_intro_l + refine (BIUpdate.intro (P := BIBase.later (BIBase.pure False))).trans ?_ + exact BIUpdate.mono (PROP := IProp GF) hor + have hfalse_pers : + BIBase.later (BIBase.pure False) ⊢ BIBase.persistently body := + persistently_intro'' (P := BIBase.later (BIBase.pure False)) (Q := body) hfalse_body + have hcase : + BIBase.or (BIBase.later (BIBase.pure False)) (BIBase.persistently body) ⊢ + BIBase.persistently body := + or_elim hfalse_pers .rfl + simpa [BIBase.except0, body] using hcase + +/-! ### Proof Mode Integration -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +instance is_except0_inv {W : WsatGS GF} (N : Namespace) (P : IProp GF) : + Iris.ProofMode.IsExcept0 (PROP := IProp GF) + (inv (GF := GF) (M := M) (F := F) W N P) := by + -- reuse the derived lemma + exact ⟨except_0_inv (W := W) (N := N) (P := P)⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +instance into_inv_inv {W : WsatGS GF} (N : Namespace) (P : IProp GF) : + Iris.ProofMode.IntoInv (PROP := IProp GF) + (inv (GF := GF) (M := M) (F := F) W N P) N := + ⟨⟩ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +instance into_acc_inv {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) : + Iris.ProofMode.IntoAcc (PROP := IProp GF) (X := Unit) + (inv (GF := GF) (M := M) (F := F) W N P) + (Subset (nclose N).mem E) (BIBase.pure True) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N)) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E) + (fun _ => BIBase.later P) (fun _ => BIBase.later P) + (fun _ => some (BIBase.pure True)) := by + -- unfold the accessor and use `inv_acc` + refine ⟨?_⟩ + intro hsubset + iintro Hinv + iintro _ + let Ψ : Unit → IProp GF := fun _ => + BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True))) + -- unfold the accessor to match `inv_acc` + simp [Iris.ProofMode.accessor] + have hmono := + fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := Ψ ()) (Q := BIBase.exists Ψ) (exists_unit (Ψ := Ψ)).2 + have hacc := + inv_acc (W := W) (M := M) (F := F) (E := E) (N := N) (P := P) hsubset + iapply (wrapEntails (GF := GF) (hacc.trans hmono)) + iexact Hinv + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Strong invariant accessor: closing under any mask extension. + + Coq: `inv_acc_strong` -/ +theorem inv_acc_strong {W : WsatGS GF} + (E : Iris.Set Positive) (N : Namespace) (P : IProp GF) + (h : Subset (nclose N).mem E) : + inv (GF := GF) (M := M) (F := F) W N P ⊢ + uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later P) + (BIBase.forall fun E' : Iris.Set Positive => + BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W E' + (fun x => (nclose N).mem x ∨ E' x) (BIBase.pure True)))) := by + classical + iintro Hinv + -- open at the minimal mask and frame to `E` + have hsubset : Subset (nclose N).mem (nclose N).mem := by + intro i hi; exact hi + ihave Hacc := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := (nclose N).mem) (N := N) (P := P) hsubset)) $$ Hinv + ihave Hacc' := + (wrapEntails (GF := GF) + (inv_acc_strong_frame (M := M) (F := F) (W := W) (E := E) (N := N) (P := P) h)) $$ Hacc + iapply (wrapEntails (GF := GF) + (inv_acc_strong_mono (W := W) (E := E) (N := N) (P := P))) + iexact Hacc' + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Alter the content of an invariant. + + Coq: `inv_alter` -/ +theorem inv_alter {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) + (inv (GF := GF) (M := M) (F := F) W N Q)) := by + classical + iintro Hemp + iintro Hinv + iintro Hpq + -- build the invariant body from a persistent sep context + let body : IProp GF := + BIBase.forall fun E : Iris.Set Positive => + BIBase.imp (BIBase.pure (Subset (nclose N).mem E)) + (uPred_fupd (M := M) (F := F) W E (maskDiff E N) + (BIBase.sep (BIBase.later Q) + (BIBase.wand (BIBase.later Q) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E + (BIBase.pure True))))) + have hbody_wand : + (BIBase.emp : IProp GF) ⊢ + iprop((inv (GF := GF) (M := M) (F := F) W N P ∗ + BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) -∗ body) := by + iintro - + iintro Hctx + icases Hctx with ⟨Hinv', Hpq'⟩ + iintro %E + iintro hsubset + icases hsubset with %hsubset + -- open the invariant and frame the transformation hypothesis + ihave Hacc := + (wrapEntails (GF := GF) + (inv_acc (W := W) (M := M) (F := F) (E := E) (N := N) (P := P) hsubset)) $$ Hinv' + ihave Hacc' := + (wrapEntails (GF := GF) + (fupd_frame_r (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + (Q := BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))))) $$ [Hacc, Hpq'] + · -- frame the transformation hypothesis across the update + isplitl [Hacc] + · iexact Hacc + · iexact Hpq' + -- transform the postcondition + have hpost : + BIBase.sep + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) ⊢ + BIBase.sep (BIBase.later Q) + (BIBase.wand (BIBase.later Q) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)) : IProp GF) := by + iintro Hpost + icases Hpost with ⟨HpostP, Hpq''⟩ + icases HpostP with ⟨HlateP, HcloseP⟩ + -- derive ▷(P -∗ Q ∗ (Q -∗ P)) from ▷□(...) + ihave Hpq''' := + (wrapEntails (GF := GF) + (later_mono (P := BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)))) + (Q := BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))) + (intuitionistically_elim (P := BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)))))) $$ Hpq'' + -- apply later wand to obtain ▷(Q ∗ (Q -∗ P)) + ihave Hwand := + (wrapEntails (GF := GF) + (later_wand (P := P) (Q := BIBase.sep Q (BIBase.wand Q P)))) $$ Hpq''' + ispecialize Hwand $$ HlateP + -- split the later'd pair + ihave Hsplit := + (wrapEntails (GF := GF) + (later_sep (P := Q) (Q := BIBase.wand Q P)).1) $$ Hwand + icases Hsplit with ⟨HlateQ, HlateQtoP⟩ + isplitl [HlateQ] + · iexact HlateQ + · iintro Hq + ihave Hqp := + (wrapEntails (GF := GF) (later_wand (P := Q) (Q := P))) $$ HlateQtoP + ispecialize Hqp $$ Hq + iapply HcloseP + iexact Hqp + iapply (wrapEntails (GF := GF) + (fupd_mono (W := W) (M := M) (F := F) (E1 := E) (E2 := maskDiff E N) + (P := BIBase.sep + (BIBase.sep (BIBase.later P) + (BIBase.wand (BIBase.later P) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)))))) + (Q := BIBase.sep (BIBase.later Q) + (BIBase.wand (BIBase.later Q) + (uPred_fupd (M := M) (F := F) W (maskDiff E N) E (BIBase.pure True)))) + hpost)) + iexact Hacc' + have hbody : + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) ⊢ + body := by + -- move the wand proof under a sep and eliminate it + refine (sep_emp (P := BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))))).2.trans ?_ + refine (sep_mono .rfl hbody_wand).trans ?_ + exact wand_elim_r + -- wrap the body in persistently using the persistent context + have hpers : + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) ⊢ + BIBase.persistently body := + persistently_intro'' + (P := BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)))))) + (Q := body) hbody + -- fold the invariant definition on the postcondition + have hpers' : + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.later (BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))))) ⊢ + inv (GF := GF) (M := M) (F := F) W N Q := + hpers.trans (BIBase.Entails.of_eq (by rfl)) + iapply (wrapEntails (GF := GF) hpers') + -- supply the persistent context + isplitl [Hinv] + · iexact Hinv + · iexact Hpq + +-- Abbreviation for the wand-based `P ↔ Q`. +private abbrev iffWand (P Q : IProp GF) : IProp GF := + BIBase.and (BIBase.wand P Q) (BIBase.wand Q P) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem iff_wand_left (P Q : IProp GF) : + BIBase.intuitionistically (iffWand P Q) ⊢ BIBase.wand P Q := by + -- Pull the left implication out of the persistent conjunction. + exact (intuitionistically_elim (P := iffWand P Q)).trans + (and_elim_l (P := BIBase.wand P Q) (Q := BIBase.wand Q P)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem iff_wand_right (P Q : IProp GF) : + BIBase.intuitionistically (iffWand P Q) ⊢ BIBase.wand Q P := by + -- Pull the right implication out of the persistent conjunction. + exact (intuitionistically_elim (P := iffWand P Q)).trans + (and_elim_r (P := BIBase.wand P Q) (Q := BIBase.wand Q P)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem iff_to_sep_wand (P Q : IProp GF) : + BIBase.intuitionistically (iffWand P Q) ⊢ + BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)) := by + -- Duplicate the iff and use each direction once. + refine wand_intro ?_ + have hdup : + BIBase.intuitionistically (iffWand P Q) ⊢ + BIBase.sep (BIBase.intuitionistically (iffWand P Q)) + (BIBase.intuitionistically (iffWand P Q)) := + (intuitionistically_sep_idem (P := iffWand P Q)).2 + refine (sep_mono_l hdup).trans ?_ + refine sep_assoc_l.trans ?_ + have hQ : + BIBase.sep (BIBase.intuitionistically (iffWand P Q)) P ⊢ Q := + (sep_mono_l (iff_wand_left (P := P) (Q := Q))).trans wand_elim_l + refine (sep_mono (iff_wand_right (P := P) (Q := Q)) hQ).trans ?_ + exact sep_comm.1 + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Invariant content equivalence. + + Coq: `inv_iff` -/ +theorem inv_iff {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand (inv (GF := GF) (M := M) (F := F) W N P) + (BIBase.wand (BIBase.later (BIBase.intuitionistically + (BIBase.and (BIBase.wand P Q) (BIBase.wand Q P)))) + (inv (GF := GF) (M := M) (F := F) W N Q)) := by + classical + iintro Hemp + iintro Hinv + iintro Hpq + -- Lift the iff into the wand form expected by `inv_alter`. + have hbox : + BIBase.intuitionistically (iffWand P Q) ⊢ + BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P))) := + intuitionistically_intro' (iff_to_sep_wand (P := P) (Q := Q)) + ihave Hpq' := + (wrapEntails (GF := GF) + (later_mono + (P := BIBase.intuitionistically (iffWand P Q)) + (Q := BIBase.intuitionistically + (BIBase.wand P (BIBase.sep Q (BIBase.wand Q P)))) + hbox)) $$ Hpq + -- Apply `inv_alter` with the converted hypothesis. + ihave Hinv' := + (wrapEntails (GF := GF) + (inv_alter (W := W) (M := M) (F := F) (N := N) (P := P) (Q := Q))) $$ Hemp + ispecialize Hinv' $$ Hinv + ispecialize Hinv' $$ Hpq' + iexact Hinv' + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Split an invariant on the left component. + + Coq: `inv_split_l` -/ +theorem inv_split_l {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ⊢ + inv (GF := GF) (M := M) (F := F) W N P := by + -- build the wand via `inv_alter`, then eliminate it with `emp` + have hwand : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand + (inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q)) + (inv (GF := GF) (M := M) (F := F) W N P) := by + let Einv : IProp GF := + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) + let Hstep : IProp GF := + BIBase.later (BIBase.intuitionistically + (BIBase.wand (BIBase.sep (PROP := IProp GF) P Q) + (BIBase.sep P (BIBase.wand P (BIBase.sep (PROP := IProp GF) P Q))))) + have Halter : + (BIBase.emp : IProp GF) ⊢ + BIBase.wand Einv + (BIBase.wand Hstep (inv (GF := GF) (M := M) (F := F) W N P)) := + inv_alter (W := W) (M := M) (F := F) (N := N) + (P := BIBase.sep (PROP := IProp GF) P Q) (Q := P) + have Htrans : (BIBase.emp : IProp GF) ⊢ Hstep := + inv_split_l_transform (P := P) (Q := Q) + refine wand_intro ?_ + -- duplicate `emp` so we can build the close shift and the mask introduction + have hemp_dup : + (BIBase.emp : IProp GF) ⊢ + BIBase.sep (BIBase.emp : IProp GF) (BIBase.emp : IProp GF) := + (sep_emp (P := (BIBase.emp : IProp GF))).2 + refine (sep_mono hemp_dup .rfl).trans ?_ + refine (sep_right_comm (P := (BIBase.emp : IProp GF)) + (Q := (BIBase.emp : IProp GF)) (R := Einv)).1.trans ?_ + have hleft : + BIBase.sep (BIBase.emp : IProp GF) Einv ⊢ + BIBase.wand Hstep (inv (GF := GF) (M := M) (F := F) W N P) := by + refine (sep_mono Halter .rfl).trans ?_ + exact wand_elim_l + refine (sep_mono hleft .rfl).trans ?_ + refine (sep_mono .rfl Htrans).trans ?_ + exact wand_elim_l + refine (sep_emp (P := inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q))).2.trans ?_ + refine (sep_mono .rfl hwand).trans ?_ + exact wand_elim_r + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Split an invariant on the right component. + + Coq: `inv_split_r` -/ +theorem inv_split_r {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ⊢ + inv (GF := GF) (M := M) (F := F) W N Q := by + -- commute the sep and reuse the left split lemma + have hcomm : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ⊢ + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep Q P) := by + have hsep : BIBase.sep (PROP := IProp GF) P Q ≡ BIBase.sep Q P := by + have hsep' : BIBase.sep (PROP := IProp GF) P Q ⊣⊢ BIBase.sep Q P := + sep_comm (P := P) (Q := Q) + exact (BI.equiv_iff (P := BIBase.sep (PROP := IProp GF) P Q) (Q := BIBase.sep Q P)).2 hsep' + have hEquiv : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ≡ + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep Q P) := + inv_proper (W := W) (N := N) (P := BIBase.sep (PROP := IProp GF) P Q) (Q := BIBase.sep Q P) hsep + have hBi : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ⊣⊢ + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep Q P) := + (BI.equiv_iff (P := inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q)) + (Q := inv (GF := GF) (M := M) (F := F) W N (BIBase.sep Q P))).1 hEquiv + exact hBi.1 + exact hcomm.trans (inv_split_l (W := W) (M := M) (F := F) (N := N) (P := Q) (Q := P)) + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] in +/-- Split an invariant into two components. + + Coq: `inv_split` -/ +theorem inv_split {W : WsatGS GF} + (N : Namespace) (P Q : IProp GF) : + inv (GF := GF) (M := M) (F := F) W N (BIBase.sep (PROP := IProp GF) P Q) ⊢ + BIBase.sep (inv (GF := GF) (M := M) (F := F) W N P) + (inv (GF := GF) (M := M) (F := F) W N Q) := by + -- apply both split lemmas under a separating conjunction + iintro Hinv + isplit + · iapply (wrapEntails (GF := GF) + (inv_split_l (W := W) (M := M) (F := F) (N := N) (P := P) (Q := Q))) + iexact Hinv + · iapply (wrapEntails (GF := GF) + (inv_split_r (W := W) (M := M) (F := F) (N := N) (P := P) (Q := Q))) + iexact Hinv + +end Iris.BaseLogic diff --git a/src/Iris/BaseLogic/Lib/Wsat.lean b/src/Iris/BaseLogic/Lib/Wsat.lean new file mode 100644 index 00000000..e50f5994 --- /dev/null +++ b/src/Iris/BaseLogic/Lib/Wsat.lean @@ -0,0 +1,1106 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ +import Iris.Instances.IProp.Instance +import Iris.Algebra.CoPset +import Iris.BI.BigOp +import Iris.ProofMode.Tactics + +/-! # World Satisfaction + +Reference: `iris/base_logic/lib/wsat.v` + +World satisfaction (`wsat`) is the central invariant of the Iris base logic. +It asserts ownership of a map from invariant names to propositions, together +with the bookkeeping that each invariant is either *open* (its content has +been taken out, tracked by a disabled token `ownD`) or *closed* (the content +is still inside, tracked by an enabled token `ownE`). + +The three ownership connectives are: +- `ownI i P` — invariant `i` is registered with content `P` (persistent) +- `ownE E` — the caller holds the enabled mask `E` (a set of invariant names) +- `ownD E` — the caller holds the disabled tokens `E` + +The open/close lemmas (`ownI_open`, `ownI_close`) allow temporarily +extracting `▷ P` from a closed invariant and putting it back, exchanging +enabled and disabled tokens in the process. This is the engine behind fancy +updates and the `iInv` tactic. + +## Main Definitions + +- `WsatGS` — ghost state names for the three ghost cells +- `ownI`, `ownE`, `ownD` — ownership connectives +- `wsat` — world satisfaction assertion + +## Main Results + +- `ownE_op`, `ownD_op` — disjoint union splits +- `ownE_singleton_twice`, `ownD_singleton_twice` — no duplication +- `ownI_open` — open an invariant: extract `▷ P`, get disabled token +- `ownI_close` — close an invariant: return `▷ P`, get enabled token back +- `ownI_alloc` — allocate a fresh invariant name +- `wsat_alloc` — allocate the initial world satisfaction +-/ + +namespace Iris.BaseLogic + +open Iris Iris.Algebra Iris.Std Iris.BI Iris.ProofMode COFE CMRA One + +/-! ## Finite Map + Heap Compatibility -/ + +/-- Compatibility between `FiniteMap.get?` and `Store.get` for heaps. -/ +class HeapFiniteMap (K : Type _) (M : Type _ → Type _) + [FiniteMap K M] : Type _ where + /-- Heap structure for all value types. -/ + heap : ∀ V, Heap (M V) K V + /-- Compatibility between `FiniteMap.get?` and `Store.get`. -/ + get?_eq_get : ∀ {V} (m : M V) (k : K), (FiniteMap.get? m k) = Store.get m k + +instance (K : Type _) (M : Type _ → Type _) [FiniteMap K M] [h : HeapFiniteMap K M] (V) : + Heap (M V) K V := + h.heap V + +instance (K : Type _) (M : Type _ → Type _) [FiniteMap K M] [h : HeapFiniteMap K M] : + (∀ V, Heap (M V) K V) := by + intro V + exact h.heap V + +/-! ## Ghost State Configuration -/ + +/-- Ghost state names for world satisfaction. + Tracks the three ghost cells: invariant map, enabled mask, disabled tokens. -/ +structure WsatGS (GF : BundledGFunctors) where + /-- Ghost name for the invariant map (HeapView auth over agree ∘ later ∘ iProp) -/ + invariant_name : GName + /-- Ghost name for the enabled mask (CoPsetDisj) -/ + enabled_name : GName + /-- Ghost name for the disabled tokens (GSetDisj) -/ + disabled_name : GName + +variable {GF : BundledGFunctors} {M : Type _ → Type _} {F : Type _} +variable [UFraction F] +variable [FiniteMap Positive M] [DecidableEq Positive] +variable [FiniteMapLaws Positive M] +variable [HeapFiniteMap Positive M] +variable [ElemG GF (COFE.constOF CoPsetDisj)] +variable [ElemG GF (COFE.constOF GSetDisj)] + +/-- Invariant bodies (no universe lift now that the registry is `IProp`-valued). -/ +abbrev IPropU (GF : BundledGFunctors) : Type _ := IProp GF + +/-- Equality on `IProp` as a `UPred` (fixes the underlying resource type). -/ +abbrev IPropEq (GF : BundledGFunctors) (P Q : IProp GF) : IProp GF := + UPred.eq (M := IResUR GF) P Q + +/-- Heap instance for the invariant map values. -/ +private def heapM : ∀ V, Heap (M V) Positive V := fun V => + (HeapFiniteMap.heap (K := Positive) (M := M) V) + +/-- Invariant registry view (gmap_view) specialized to `HeapView`. -/ +abbrev InvView (GF : BundledGFunctors) (M : Type _ → Type _) (F : Type _) + [UFraction F] [FiniteMap Positive M] [HeapFiniteMap Positive M] := + @HeapView F Positive (Agree (IPropU GF)) M _ heapM _ + +/-- Functor for the invariant registry ghost state. -/ +abbrev InvF (GF : BundledGFunctors) (M : Type _ → Type _) (F : Type _) + [UFraction F] [FiniteMap Positive M] [HeapFiniteMap Positive M] : OFunctorPre := + COFE.constOF (InvView (GF := GF) (M := M) (F := F)) + +variable [ElemG GF (InvF GF M F)] + +variable (W : WsatGS GF) + +-- Keep IProp entailments opaque for proof mode (avoid unfolding to `holds`). +private structure IPropEntails (P Q : IProp GF) : Prop where + toEntails : P ⊢ Q + +private def wrapEntails {P Q : IProp GF} (h : P ⊢ Q) : + IPropEntails (GF := GF) P Q := + ⟨h⟩ + +local instance asEmpValid_IPropEntails (d : Iris.ProofMode.AsEmpValid.Direction) + (P Q : IProp GF) : + Iris.ProofMode.AsEmpValid d (IPropEntails (GF := GF) P Q) iprop(P -∗ Q) := by + have hEntails : + Iris.ProofMode.AsEmpValid d (P ⊢ Q) iprop(P -∗ Q) := inferInstance + refine ⟨?_, ?_⟩ + · intro hd h + exact (hEntails.as_emp_valid.1 hd) h.toEntails + · intro hd h + exact ⟨(hEntails.as_emp_valid.2 hd) h⟩ + +/-! ## Ownership Connectives -/ + +/-- Unfold an invariant body (no OFE-level `Later` at the moment). -/ +noncomputable def invariant_unfold (P : IProp GF) : IProp GF := + -- TODO: switch to OFE `Later` once universe-polymorphic constOF is in place + P + +/-- Map invariant bodies into the agreement CMRA. -/ +noncomputable def inv_map (I : M (IPropU GF)) : M (Agree (IPropU GF)) := + -- pointwise map: P ↦ toAgree P + FiniteMap.map (fun P => toAgree P) I + +/-- Authoritative element for the invariant registry. -/ +abbrev gmap_view_auth (dq : DFrac F) (m : M (Agree (IPropU GF))) : InvView GF M F := + @HeapView.Auth F Positive (Agree (IPropU GF)) M _ heapM _ dq m + +/-- Fragment element for a single invariant name. -/ +abbrev gmap_view_frag (i : Positive) (dq : DFrac F) (v : Agree (IPropU GF)) : + InvView GF M F := + @HeapView.Frag F Positive (Agree (IPropU GF)) M _ heapM _ i dq v + +/-- Invariant ownership: `ownI i P` asserts that invariant `i` is registered + with content `P`. This is persistent — once registered, an invariant + exists forever. -/ +noncomputable def ownI (_W : WsatGS GF) (i : Positive) (P : IProp GF) : IProp GF := + -- store the invariant body under key `i` as a discarded fragment + iOwn (GF := GF) (F := InvF GF M F) _W.invariant_name <| + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard (toAgree (invariant_unfold (GF := GF) P)) + +/-- Enabled mask ownership: `ownE E` asserts the caller holds the right to + open invariants in the set `E`. Implemented via the `CoPsetDisj` CMRA. -/ +noncomputable def ownE (_W : WsatGS GF) (E : CoPset) : IProp GF := + -- use a constant ghost functor over `CoPsetDisj` + iOwn (GF := GF) (F := COFE.constOF CoPsetDisj) _W.enabled_name <| CoPsetDisj.coPset E + +/-- Disabled token ownership: `ownD E` asserts the caller holds disabled + tokens for invariants in `E`. Implemented via the `GSetDisj` CMRA. -/ +noncomputable def ownD (_W : WsatGS GF) (E : GSet) : IProp GF := + -- use a constant ghost functor over `GSetDisj` + iOwn (GF := GF) (F := COFE.constOF GSetDisj) _W.disabled_name <| GSetDisj.gset E + +/-! ## World Satisfaction -/ + +/-- World satisfaction: asserts existence of an invariant map `I` such that + the caller owns the authoritative view of `I`, and for each invariant + `i ↦ Q` in `I`, either `Q` is closed (content `▷ Q` present with a + disabled token) or open (an enabled token is present). + + ``` + wsat := ∃ I : gmap positive (iProp Σ), + own γ_inv (gmap_view_auth 1 I) ∗ + [∗ map] i ↦ Q ∈ I, (▷ Q ∗ ownD {[i]}) ∨ ownE {[i]} + ``` -/ +noncomputable def wsat (_W : WsatGS GF) : IProp GF := + -- registry + big sep over all invariants + BIBase.exists fun I : M (IPropU GF) => + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) _W.invariant_name <| + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)) + (big_sepM (PROP := IProp GF) + (fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD _W (GSet.singleton i))) + (ownE _W (CoPset.singleton i))) I) + +instance intoExists_wsat (W : WsatGS GF) : + IntoExists (PROP := IProp GF) + (wsat (GF := GF) (M := M) (F := F) W) + (fun I : M (IPropU GF) => + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name <| + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)) + (big_sepM (PROP := IProp GF) + (fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + I)) := by + refine ⟨by simp [wsat]⟩ + +instance fromExists_wsat (W : WsatGS GF) : + FromExists (PROP := IProp GF) + (wsat (GF := GF) (M := M) (F := F) W) + (fun I : M (IPropU GF) => + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name <| + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)) + (big_sepM (PROP := IProp GF) + (fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + I)) := by + refine ⟨by simp [wsat]⟩ + +/-! ## Enabled Mask Properties -/ + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Allocate an empty enabled mask. -/ +theorem ownE_empty : (BIBase.emp : IProp GF) ⊢ BUpd.bupd (ownE W ∅) := by + -- `CoPsetDisj.coPset ∅` is definitionally the unit + haveI : IsUnit (CoPsetDisj.coPset (∅ : CoPset)) := by + simpa using (inferInstance : IsUnit (UCMRA.unit : CoPsetDisj)) + simpa [ownE] using + (iOwn_unit (GF := GF) (F := COFE.constOF CoPsetDisj) (γ := W.enabled_name)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Disjoint union of enabled masks splits into separating conjunction. -/ +theorem ownE_op (E₁ E₂ : CoPset) (h : E₁.Disjoint E₂) : + ownE W (E₁.union E₂) ⊣⊢ BIBase.sep (ownE W E₁) (ownE W E₂) := by + have h' : + CoPsetDisj.coPset (E₁.union E₂) = + (CoPsetDisj.coPset E₁ : CoPsetDisj) • CoPsetDisj.coPset E₂ := + (coPset_disj_union h).symm + simpa [ownE, h'] using + (iOwn_op (GF := GF) (F := COFE.constOF CoPsetDisj) (γ := W.enabled_name) + (a1 := CoPsetDisj.coPset E₁) (a2 := CoPsetDisj.coPset E₂)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Enabled masks in separating conjunction must be disjoint. -/ +theorem ownE_disjoint (E₁ E₂ : CoPset) : + BIBase.sep (ownE W E₁) (ownE W E₂) ⊢ + BIBase.pure (E₁.Disjoint E₂) := by + refine (iOwn_cmraValid_op (GF := GF) (F := COFE.constOF CoPsetDisj) + (γ := W.enabled_name) (a1 := CoPsetDisj.coPset E₁) + (a2 := CoPsetDisj.coPset E₂)).trans ?_ + refine (UPred.cmraValid_elim + (a := (CoPsetDisj.coPset E₁ : CoPsetDisj) • CoPsetDisj.coPset E₂)).trans ?_ + refine BI.pure_mono ?_ + intro hvalid0 + have hvalid : + ✓ ((CoPsetDisj.coPset E₁ : CoPsetDisj) • CoPsetDisj.coPset E₂) := + CMRA.discrete_valid hvalid0 + exact (coPset_disj_valid_op).1 hvalid + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF GSetDisj)] in +/-- Cannot own the same singleton enabled token twice. -/ +theorem ownE_singleton_twice (i : Positive) : + BIBase.sep (ownE W (CoPset.singleton i)) (ownE W (CoPset.singleton i)) ⊢ + (BIBase.pure False : IProp GF) := by + refine (ownE_disjoint (W := W) + (E₁ := CoPset.singleton i) (E₂ := CoPset.singleton i)).trans ?_ + refine BI.pure_mono ?_ + intro hdisj + have hmem : (CoPset.singleton i).mem i := by + rfl + exact (hdisj i) ⟨hmem, hmem⟩ + +/-! ## Disabled Token Properties -/ + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] in +/-- Allocate empty disabled tokens. -/ +theorem ownD_empty : (BIBase.emp : IProp GF) ⊢ BUpd.bupd (ownD W ∅) := by + -- allocate the unit for the `GSetDisj` ghost cell + haveI : IsUnit (GSetDisj.gset (∅ : GSet)) := by + simpa using (inferInstance : IsUnit (UCMRA.unit : GSetDisj)) + simpa [ownD] using + (iOwn_unit (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] in +private theorem ownD_emptyE : + IPropEntails (GF := GF) (BIBase.emp : IProp GF) (BUpd.bupd (ownD W ∅)) := by + exact ⟨ownD_empty (W := W)⟩ + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] in +/-- Disjoint union of disabled tokens splits into separating conjunction. -/ +theorem ownD_op (E₁ E₂ : GSet) (h : E₁.Disjoint E₂) : + ownD W (E₁.union E₂) ⊣⊢ BIBase.sep (ownD W E₁) (ownD W E₂) := by + have h' : + GSetDisj.gset (E₁.union E₂) = + (GSetDisj.gset E₁ : GSetDisj) • GSetDisj.gset E₂ := + (gset_disj_union h).symm + simpa [ownD, h'] using + (iOwn_op (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name) + (a1 := GSetDisj.gset E₁) (a2 := GSetDisj.gset E₂)) + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] in +/-- Disabled tokens in separating conjunction must be disjoint. -/ +theorem ownD_disjoint (E₁ E₂ : GSet) : + BIBase.sep (ownD W E₁) (ownD W E₂) ⊢ + BIBase.pure (E₁.Disjoint E₂) := by + refine (iOwn_cmraValid_op (GF := GF) (F := COFE.constOF GSetDisj) + (γ := W.disabled_name) (a1 := GSetDisj.gset E₁) + (a2 := GSetDisj.gset E₂)).trans ?_ + refine (UPred.cmraValid_elim + (a := (GSetDisj.gset E₁ : GSetDisj) • GSetDisj.gset E₂)).trans ?_ + refine BI.pure_mono ?_ + intro hvalid0 + have hvalid : + ✓ ((GSetDisj.gset E₁ : GSetDisj) • GSetDisj.gset E₂) := + CMRA.discrete_valid hvalid0 + exact (gset_disj_valid_op).1 hvalid + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] in +/-- Cannot own the same singleton disabled token twice. -/ +theorem ownD_singleton_twice (i : Positive) : + BIBase.sep (ownD W (GSet.singleton i)) (ownD W (GSet.singleton i)) ⊢ + (BIBase.pure False : IProp GF) := by + refine (ownD_disjoint (W := W) + (E₁ := GSet.singleton i) (E₂ := GSet.singleton i)).trans ?_ + refine BI.pure_mono ?_ + intro hdisj + have hmem : (GSet.singleton i).mem i := by + rfl + exact (hdisj i) ⟨hmem, hmem⟩ + +/-! ## Invariant Properties -/ + +omit [DecidableEq Positive] [FiniteMapLaws Positive M] + [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +/-- `ownI` is persistent. -/ +theorem ownI_persistent (i : Positive) (P : IProp GF) : + ownI (GF := GF) (M := M) (F := F) W i P ⊢ + BIBase.persistently (ownI (GF := GF) (M := M) (F := F) W i P) := by + classical + -- `discard` and `toAgree` have trivial cores, so the fragment is core-id + haveI : CMRA.CoreId (DFrac.discard (F := F)) := by + refine CMRA.CoreId.of_pcore_eq_some (x := DFrac.discard (F := F)) ?_ + simp [CMRA.pcore, DFrac.pcore] + haveI : CMRA.CoreId (toAgree (invariant_unfold (GF := GF) P)) := by + refine CMRA.CoreId.of_pcore_eq_some (x := toAgree (invariant_unfold (GF := GF) P)) ?_ + simp [CMRA.pcore] + simpa [ownI] using + (persistently_intro (P := iOwn (GF := GF) (F := InvF GF M F) W.invariant_name <| + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P)))) + + +/-! ## Invariant Lookup Helper -/ + +omit [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem inv_map_lookup {I : M (IPropU GF)} {i : Positive} {v : Agree (IPropU GF)} + (hget : Store.get (inv_map (GF := GF) I) i = some v) : + ∃ Q, FiniteMap.get? I i = some Q ∧ + v = toAgree Q := by + classical + have hget' : FiniteMap.get? (inv_map (GF := GF) I) i = some v := by + simpa [HeapFiniteMap.get?_eq_get] using hget + have hget'' : (FiniteMap.get? I i).map (fun P => toAgree P) = some v := by + simpa [inv_map, FiniteMapLaws.get?_map] using hget' + cases hI : FiniteMap.get? I i with + | none => + simp [hI] at hget'' + | some Q => + refine ⟨Q, rfl, ?_⟩ + have hv : some (toAgree Q) = some v := by + simpa [hI] using hget'' + exact (Option.some.inj hv).symm + +omit [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem invariant_lookup (I : M (IPropU GF)) (i : Positive) (P : IProp GF) : + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I))) + (ownI (GF := GF) (M := M) (F := F) W i P) ⊢ + BIBase.sep + (BIBase.exists (fun Q => + BIBase.sep (BIBase.pure (FiniteMap.get? I i = some Q)) + (BIBase.later (IPropEq (GF := GF) Q P)))) + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I))) := by + intro n x hvalid hsep + -- get validity of auth • frag from ownership + have hvalid : + ✓{n} (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I) • + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P))) := + by + have hvalid' : + (UPred.cmraValid + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I) • + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P))) : IProp GF).holds n x := by + have hsep' : + (BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I))) + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P))))) n x := by + simpa [ownI] using hsep + exact (iOwn_cmraValid_op (GF := GF) (F := InvF GF M F) + (γ := W.invariant_name) + (a1 := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I)) + (a2 := gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P)))) n x hvalid hsep' + simpa [UPred.cmraValid] using hvalid' + -- decode validity via HeapView + obtain ⟨v', dq', _Hdp, hlookup, hval, hinc⟩ := + (HeapView.auth_op_frag_validN_iff (F := F) (K := Positive) + (V := Agree (IPropU GF)) (H := M)).1 hvalid + obtain ⟨Q, hI, hv'⟩ := inv_map_lookup (I := I) (i := i) (v := v') hlookup + -- normalize the inclusion/validity facts with the discovered entry + have hinc' : + some (DFrac.discard, toAgree (invariant_unfold (GF := GF) P)) ≼{n} + some (dq', toAgree Q) := by + simpa [hv'] using hinc + have hval' : ✓{n} (dq', toAgree Q) := by + simpa [hv'] using hval + -- derive agreement of invariant bodies + have hvdist : + toAgree (invariant_unfold (GF := GF) P) ≡{n}≡ + toAgree Q := by + have hinc'' := (Option.some_incN_some_iff).1 hinc' + cases hinc'' with + | inl hEq => + exact OFE.dist_snd hEq + | inr hInc => + obtain ⟨c, hc⟩ := hInc + have hvinc : + toAgree (invariant_unfold (GF := GF) P) ≼{n} + toAgree Q := by + exact ⟨c.snd, OFE.dist_snd hc⟩ + have hvvalid : ✓{n} (toAgree Q) := + hval'.2 + exact (Agree.valid_includedN (x := toAgree (invariant_unfold (GF := GF) P)) + (y := toAgree Q) hvvalid hvinc) + have hdist : invariant_unfold (GF := GF) P ≡{n}≡ Q := + Agree.toAgree_injN hvdist + -- build the later equality proof (resource-independent) + have hLaterEq : ∀ x, BIBase.later (IPropEq (GF := GF) Q P) n x := by + intro x + cases n with + | zero => + simp [BIBase.later, UPred.later] + | succ n' => + have hPQ : P ≡{n'}≡ Q := by + exact OFE.Dist.lt hdist (Nat.lt_succ_self _) + -- UPred.eq Q P at step n' is Q ≡{n'}≡ P + simpa [BIBase.later, UPred.later, IPropEq, UPred.eq] using hPQ.symm + -- split the resources to keep the auth part + rcases hsep with ⟨x1, x2, hx, hAuth, _hFrag⟩ + -- show the existential holds on the fragment side + have hExists : + (BIBase.exists (fun Q => + BIBase.sep (BIBase.pure (FiniteMap.get? I i = some Q)) + (BIBase.later (IPropEq (GF := GF) Q P)))) n x2 := by + refine ⟨ + BIBase.sep (BIBase.pure (FiniteMap.get? I i = some Q)) + (BIBase.later (IPropEq (GF := GF) Q P)), ?_, ?_⟩ + · exact ⟨Q, rfl⟩ + · refine ⟨x2, (UCMRA.unit : IResUR GF), + (CMRA.unit_right_id_dist (α := IResUR GF) x2).symm, ?_, ?_⟩ + · exact hI + · simpa using hLaterEq x2 + -- assemble the separating conjunction with the auth ownership + refine ⟨x2, x1, ?_, hExists, hAuth⟩ + exact hx.trans (CMRA.op_commN (x := x1) (y := x2)) + +omit [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem invariant_lookupE (I : M (IPropU GF)) (i : Positive) (P : IProp GF) : + IPropEntails (GF := GF) + (BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I))) + (ownI (GF := GF) (M := M) (F := F) W i P)) + (BIBase.sep + (BIBase.exists (fun Q => + BIBase.sep (BIBase.pure (FiniteMap.get? I i = some Q)) + (BIBase.later (IPropEq (GF := GF) Q P)))) + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name + (gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)))) := by + exact ⟨invariant_lookup (W := W) (I := I) (i := i) (P := P)⟩ + +/-! ## Later Equality Helpers -/ + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem later_eq_symm (P Q : IProp GF) : + BIBase.later (IPropEq (GF := GF) Q P) ⊢ BIBase.later (IPropEq (GF := GF) P Q) := by + -- `UPred.eq` is symmetric at each step index + intro n x _ hEq + cases n with + | zero => + simp [BIBase.later, UPred.later] + | succ n' => + simpa [BIBase.later, UPred.later, IPropEq, UPred.eq] using hEq.symm + +omit [DecidableEq Positive] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem later_eq_elim (P Q : IProp GF) : + BIBase.sep (BIBase.later P) (BIBase.later (IPropEq (GF := GF) P Q)) ⊢ BIBase.later Q := by + -- use the internal equality to rewrite the later'd proposition + intro n x Hv hsep + rcases hsep with ⟨x1, x2, hx, hP, hEq⟩ + cases n with + | zero => + simp [BIBase.later, UPred.later] + | succ n' => + -- lift `P` to the full resource and rewrite along equality + have hx' : x1 ≼{n'} x := by + -- extend by the right frame then transport along the split equality + have hinc : x1 • x2 ≼{n'} x := by + exact CMRA.incN_of_incN_succ (OFE.Dist.to_incN hx.symm) + exact CMRA.incN_trans (CMRA.incN_op_left n' x1 x2) hinc + have hP' : P n' x := P.mono hP hx' (Nat.le_refl _) + have hPQ : P ≡{n'}≡ Q := by + simpa [BIBase.later, UPred.later, IPropEq, UPred.eq] using hEq + have hQ : Q n' x := + uPred_holds_ne (P := Q) (Q := P) hPQ.symm (Nat.le_refl _) + (CMRA.validN_of_le (Nat.le_succ _) Hv) hP' + simpa [BIBase.later, UPred.later] using hQ + +/-! ## GSet Disjoint Allocation Helper -/ + +omit [DecidableEq Positive] in +private theorem gset_disj_alloc_empty_updateP_strong' (P : Positive → Prop) + (Hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ P i) : + (GSetDisj.gset (∅ : GSet) : GSetDisj) ~~>: + fun Y => ∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ P i := by + -- reduce to discrete updateP and pick a fresh singleton + refine (UpdateP.discrete (x := (GSetDisj.gset (∅ : GSet) : GSetDisj)) + (P := fun Y => ∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ P i)).mpr ?_ + intro mz hvalid + cases mz with + | none => + -- empty frame: any fresh singleton is valid + obtain ⟨i, _, hiP⟩ := Hfresh ∅ + refine ⟨GSetDisj.gset (GSet.singleton i), ⟨i, rfl, hiP⟩, ?_⟩ + simp [CMRA.op?, CMRA.Valid] + | some z => + cases z with + | invalid => + -- invalid frame contradicts validity + cases hvalid + | gset X => + -- choose a singleton disjoint from the frame + obtain ⟨i, hiX, hiP⟩ := Hfresh X + refine ⟨GSetDisj.gset (GSet.singleton i), ⟨i, rfl, hiP⟩, ?_⟩ + have hdisj : GSet.Disjoint (GSet.singleton i) X := by + intro n hn + have hn' : n = i := by simpa using hn.1 + subst hn' + exact hiX hn.2 + simp [CMRA.op?, gset_disj_valid_op, hdisj] + +/-! ## Map/Heap Helpers -/ + +omit [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem inv_map_get_none {I : M (IPropU GF)} {i : Positive} + (hI : FiniteMap.get? I i = none) : + Store.get (inv_map (GF := GF) I) i = none := by + -- translate `get?` through `inv_map` and the heap lookup + classical + have h' : FiniteMap.get? (inv_map (GF := GF) I) i = none := by + simp [inv_map, FiniteMapLaws.get?_map, hI] + simpa [HeapFiniteMap.get?_eq_get] using h' + +omit [ElemG GF (COFE.constOF CoPsetDisj)] [ElemG GF (COFE.constOF GSetDisj)] in +private theorem inv_map_insert (I : M (IPropU GF)) (i : Positive) (P : IProp GF) : + inv_map (GF := GF) (FiniteMap.insert I i P) = + Store.set (inv_map (GF := GF) I) i + (some (toAgree (invariant_unfold (GF := GF) P))) := by + -- extensionality by `get?`, computed via map and heap lookup + classical + apply FiniteMapLaws.ext + intro k + by_cases hki : k = i + · subst k + have hL : + FiniteMap.get? (inv_map (GF := GF) (FiniteMap.insert I i P)) i = + some (toAgree (invariant_unfold (GF := GF) P)) := by + simp [inv_map, FiniteMapLaws.get?_map, FiniteMapLaws.get?_insert_same, invariant_unfold] + have hR : + FiniteMap.get? (Store.set (inv_map (GF := GF) I) i + (some (toAgree (invariant_unfold (GF := GF) P)))) i = + some (toAgree (invariant_unfold (GF := GF) P)) := by + simp [HeapFiniteMap.get?_eq_get, Store.get_set_eq, invariant_unfold] + exact hL.trans hR.symm + · have hne : i ≠ k := Ne.symm hki + have hL : + FiniteMap.get? (inv_map (GF := GF) (FiniteMap.insert I i P)) k = + FiniteMap.get? (inv_map (GF := GF) I) k := by + simp [inv_map, FiniteMapLaws.get?_map, FiniteMapLaws.get?_insert_ne _ _ _ _ hne] + have hR : + FiniteMap.get? (Store.set (inv_map (GF := GF) I) i + (some (toAgree (invariant_unfold (GF := GF) P)))) k = + FiniteMap.get? (inv_map (GF := GF) I) k := by + simp [HeapFiniteMap.get?_eq_get, Store.get_set_ne hne] + exact hL.trans hR.symm + +omit [ElemG GF (InvF GF M F)] [ElemG GF (COFE.constOF CoPsetDisj)] + [ElemG GF (COFE.constOF GSetDisj)] in +private theorem inv_auth_alloc (I : M (IPropU GF)) (i : Positive) (P : IProp GF) + (hI : FiniteMap.get? I i = none) : + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I) ~~> + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (FiniteMap.insert I i P)) • + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P)) := by + have hget : Store.get (inv_map (GF := GF) I) i = none := + inv_map_get_none (I := I) (i := i) hI + have hdq : ✓ (DFrac.discard (F := F)) := by + simpa using (DFrac.valid_discard (F := F)) + have hval : ✓ (toAgree (invariant_unfold (GF := GF) P)) := by + simp [Agree.valid_def, Agree.valid, Agree.validN_iff, toAgree, invariant_unfold] + simpa [inv_map_insert] using + (HeapView.update_one_alloc (H := M) (k := i) + (m1 := inv_map (GF := GF) I) + (dq := DFrac.discard) (v1 := toAgree (invariant_unfold (GF := GF) P)) + hget hdq hval) + +/-! ## Open and Close -/ + +/-- Open an invariant: given world satisfaction, invariant ownership, and + the enabled token for `i`, extract the later'd content and a disabled + token. + + Proof strategy (from Coq `wsat.v`): + 1. Unfold `wsat` to get the invariant map `I` and auth fragment + 2. Use `invariant_lookup` to find `Q` with `I !! i = Some Q` and `▷(Q ≡ P)` + 3. Use `big_sepM_delete` to extract the entry for `i` + 4. The entry is `(▷ Q ∗ ownD {[i]}) ∨ ownE {[i]}` — eliminate the disjunction + 5. In the `ownE` case, derive contradiction from `ownE_singleton_twice` + 6. In the `▷ Q ∗ ownD` case, rewrite `Q` to `P` and reassemble `wsat` -/ +theorem ownI_open (i : Positive) (P : IProp GF) : + BIBase.sep + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P)) + (ownE W (CoPset.singleton i)) ⊢ + BIBase.sep + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) (BIBase.later P)) + (ownD W (GSet.singleton i)) := by + classical + iintro H + icases H with ⟨Hsep, HownE⟩ + icases Hsep with ⟨Hwsat, HownI⟩ + icases Hwsat with ⟨%I, Hwsat⟩ + icases Hwsat with ⟨Hauth, Hbig⟩ + -- lookup the invariant body + ihave Hlookup := (invariant_lookupE (GF := GF) (M := M) (F := F) (W := W) + (I := I) (i := i) (P := P)) + ispecialize Hlookup $$ [Hauth, HownI] + · isplitl [Hauth] + · iexact Hauth + · iexact HownI + icases Hlookup with ⟨Hlookup, Hauth⟩ + icases Hlookup with ⟨%Q, %hI, HlaterEq⟩ + -- peel off the map entry for `i` + ihave Hbig' := (wrapEntails (GF := GF) (big_sepM_delete + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := Q) hI).mp) $$ Hbig + icases Hbig' with ⟨Hentry, Hrest⟩ + icases Hentry with (Hclosed | Hopen) + · -- closed case: swap tokens, extract ▷P + icases Hclosed with ⟨HlaterQ, HownD⟩ + ihave HlaterP := (wrapEntails (GF := GF) (later_eq_elim (P := Q) (Q := P))) $$ [HlaterQ, HlaterEq] + · isplitl [HlaterQ] + · iexact HlaterQ + · iexact HlaterEq + -- build wsat with the entry opened via `ownE` + isplitr [HownD] + · isplitr [HlaterP] + · iexists I + isplitl [Hauth] + · iexact Hauth + · iapply (wrapEntails (GF := GF) (big_sepM_delete + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := Q) hI).mpr) + isplitl [HownE] + · iright; iexact HownE + · iexact Hrest + · iexact HlaterP + · iexact HownD + · -- open case: duplicate enabled token is impossible + iexfalso + iapply (wrapEntails (GF := GF) (ownE_singleton_twice (W := W) i)) + isplitl [HownE] + · iexact HownE + · iexact Hopen + +/-- Close an invariant: given world satisfaction, invariant ownership, + the later'd content, and the disabled token, return the enabled token. + + Proof strategy: dual of `ownI_open` — put the content back into the big sep, + swap disabled for enabled. -/ +theorem ownI_close (i : Positive) (P : IProp GF) : + BIBase.sep + (BIBase.sep + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P)) + (BIBase.later P)) + (ownD W (GSet.singleton i)) ⊢ + BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) (ownE W (CoPset.singleton i)) := by + classical + iintro H + icases H with ⟨Hsep, HownD⟩ + icases Hsep with ⟨Hsep, HlaterP⟩ + icases Hsep with ⟨Hwsat, HownI⟩ + icases Hwsat with ⟨%I, Hwsat⟩ + icases Hwsat with ⟨Hauth, Hbig⟩ + -- lookup the invariant body + ihave Hlookup := (invariant_lookupE (GF := GF) (M := M) (F := F) (W := W) + (I := I) (i := i) (P := P)) + ispecialize Hlookup $$ [Hauth, HownI] + · isplitl [Hauth] + · iexact Hauth + · iexact HownI + icases Hlookup with ⟨Hlookup, Hauth⟩ + icases Hlookup with ⟨%Q, %hI, HlaterEq⟩ + -- peel off the map entry for `i` + ihave Hbig' := (wrapEntails (GF := GF) (big_sepM_delete + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := Q) hI).mp) $$ Hbig + icases Hbig' with ⟨Hentry, Hrest⟩ + icases Hentry with (Hclosed | Hopen) + · -- closed case: duplicate disabled token + iexfalso + iapply (wrapEntails (GF := GF) (ownD_singleton_twice (W := W) i)) + isplitl [HownD] + · iexact HownD + · icases Hclosed with ⟨_, HownD'⟩ + iexact HownD' + · -- open case: close with ▷P and ownD, return ownE + -- rewrite ▷P to ▷Q using the later equality + ihave HlaterEq' := (wrapEntails (GF := GF) (later_eq_symm (P := P) (Q := Q))) $$ HlaterEq + ihave HlaterQ := (wrapEntails (GF := GF) (later_eq_elim (P := P) (Q := Q))) $$ [HlaterP, HlaterEq'] + · isplitl [HlaterP] + · iexact HlaterP + · iexact HlaterEq' + -- build wsat with the entry closed + isplitr [Hopen] + · iexists I + isplitl [Hauth] + · iexact Hauth + · iapply (wrapEntails (GF := GF) (big_sepM_delete + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := Q) hI).mpr) + isplitl [HlaterQ HownD] + · ileft + isplitl [HlaterQ] + · iexact HlaterQ + · iexact HownD + · iexact Hrest + · iexact Hopen + +/-! ## Allocation -/ + +set_option linter.unnecessarySimpa false in +/-- Allocate a fresh invariant name satisfying predicate `φ`. + Given world satisfaction and `▷ P`, produces a fresh name `i` with + `φ i`, updated world satisfaction, and `ownI i P`. -/ +theorem ownI_alloc (φ : Positive → Prop) (P : IProp GF) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ φ i) : + BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) (BIBase.later P) ⊢ + BUpd.bupd (BIBase.exists fun i => + BIBase.sep (BIBase.pure (φ i)) + (BIBase.sep (wsat (GF := GF) (M := M) (F := F) W) + (ownI (GF := GF) (M := M) (F := F) W i P))) := by + classical + iintro H + icases H with ⟨Hwsat, HlaterP⟩ + -- unwrap `wsat` as an existential via `IntoExists` + ihave Hwsat' := (wrapEntails (GF := GF) + (into_exists (PROP := IProp GF) + (P := wsat (GF := GF) (M := M) (F := F) W) + (Φ := fun I : M (IPropU GF) => + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name <| + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)) + (big_sepM (PROP := IProp GF) + (fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + I)))) $$ Hwsat + icases Hwsat' with ⟨%I, Hwsat⟩ + icases Hwsat with ⟨Hauth, Hbig⟩ + + -- prepare the fresh allocation predicate + have Hfresh' : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (FiniteMap.get? I i = none ∧ φ i) := by + intro E + let domI : GSet := ⟨fun k => (FiniteMap.get? I k).isSome⟩ + obtain ⟨i, hi, hiφ⟩ := hfresh (E ∪ domI) + refine ⟨i, ?_, ?_⟩ + · intro hmem + exact hi (Or.inl hmem) + · have hnotDom : ¬ domI.mem i := by + intro hmem + exact hi (Or.inr hmem) + have hnone : FiniteMap.get? I i = none := by + cases hget : FiniteMap.get? I i with + | none => rfl + | some v => + have : domI.mem i := by simp [domI, hget] + exact (hnotDom this).elim + exact ⟨hnone, hiφ⟩ + + -- allow two extra nested bupds (for updateP and auth update) + iapply BIUpdate.trans + iapply BIUpdate.trans + + -- first bupd: allocate the disabled token cell + iapply (wrapEntails (GF := GF) (bupd_wand_l (P := ownD W (∅ : GSet)))) + isplitr [] + · iintro HownD0 + -- second bupd: update empty disabled tokens to a fresh singleton + let updP : IProp GF := + BIBase.exists fun Y : GSetDisj => + BIBase.sep + (BIBase.pure (∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ + (FiniteMap.get? I i = none ∧ φ i))) + (iOwn (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name) Y) + iapply (wrapEntails (GF := GF) (bupd_wand_l (P := updP))) + isplitr [HownD0] + · iintro HupdRes + icases HupdRes with ⟨%Y, HupdRes⟩ + icases HupdRes with ⟨%hY, HownDY⟩ + rcases hY with ⟨i, hYeq, hIφ⟩ + subst hYeq + have hnone : FiniteMap.get? I i = none := hIφ.1 + have hφ : φ i := hIφ.2 + -- third bupd: update the invariant registry auth to insert the new entry + iapply bupd_wand_l + isplitr [Hauth] + · iintro Hauth' + -- split auth and fragment + icases (wrapEntails (GF := GF) (iOwn_op (GF := GF) (F := InvF GF M F) (γ := W.invariant_name) + (a1 := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (FiniteMap.insert I i P))) + (a2 := gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P)))).mp) $$ Hauth' with ⟨Hauth1, Hfrag⟩ + -- assemble the result + iexists i + isplit + · ipure_intro; exact hφ + · -- wsat ∗ ownI + isplitl [Hauth1 Hbig HownDY HlaterP] + · -- wsat + iexists (FiniteMap.insert I i P) + isplitl [Hauth1] + · iexact Hauth1 + · iapply (wrapEntails (GF := GF) (big_sepM_insert + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := P) hnone).mpr) + isplitl [HlaterP HownDY] + · ileft + isplitl [HlaterP] + · iexact HlaterP + · simpa [ownD] using HownDY + · iexact Hbig + · -- ownI + simpa [ownI] using Hfrag + · -- build the update on the auth map + iapply (wrapEntails (GF := GF) (iOwn_update (GF := GF) (F := InvF GF M F) (γ := W.invariant_name) + (a := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I)) + (a' := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (FiniteMap.insert I i P)) • + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P))) + (inv_auth_alloc (I := I) (i := i) (P := P) hnone))) + iexact Hauth + · -- update the disabled tokens + iapply (wrapEntails (GF := GF) (iOwn_updateP (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name) + (a := GSetDisj.gset (∅ : GSet)) + (P := fun Y => ∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ + (FiniteMap.get? I i = none ∧ φ i)) + (gset_disj_alloc_empty_updateP_strong' + (P := fun i => FiniteMap.get? I i = none ∧ φ i) Hfresh'))) + simpa [ownD] using HownD0 + · iapply (ownD_emptyE (W := W)) + iemp_intro + +set_option linter.unnecessarySimpa false in +/-- Allocate a fresh invariant and immediately open it. + Returns the fresh name, a closing wand, `ownI`, and `ownD`. -/ +theorem ownI_alloc_open (φ : Positive → Prop) (P : IProp GF) + (hfresh : ∀ E : GSet, ∃ i, ¬E.mem i ∧ φ i) : + BUpd.bupd (wsat (GF := GF) (M := M) (F := F) W) ⊢ + BUpd.bupd (BIBase.exists fun i => + BIBase.sep (BIBase.pure (φ i)) + (BIBase.sep + (BIBase.wand (ownE W (CoPset.singleton i)) + (wsat (GF := GF) (M := M) (F := F) W)) + (BIBase.sep + (ownI (GF := GF) (M := M) (F := F) W i P) + (ownD W (GSet.singleton i))))) := by + classical + -- reduce to a single bupd on the inside + refine (BIUpdate.mono ?_).trans BIUpdate.trans + iintro Hwsat + ihave Hwsat' := (wrapEntails (GF := GF) + (into_exists (PROP := IProp GF) + (P := wsat (GF := GF) (M := M) (F := F) W) + (Φ := fun I : M (IPropU GF) => + BIBase.sep + (iOwn (GF := GF) (F := InvF GF M F) W.invariant_name <| + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) (inv_map (GF := GF) I)) + (big_sepM (PROP := IProp GF) + (fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + I)))) $$ Hwsat + icases Hwsat' with ⟨%I, Hwsat⟩ + icases Hwsat with ⟨Hauth, Hbig⟩ + + have Hfresh' : ∀ E : GSet, ∃ i, ¬E.mem i ∧ (FiniteMap.get? I i = none ∧ φ i) := by + intro E + let domI : GSet := ⟨fun k => (FiniteMap.get? I k).isSome⟩ + obtain ⟨i, hi, hiφ⟩ := hfresh (E ∪ domI) + refine ⟨i, ?_, ?_⟩ + · intro hmem + exact hi (Or.inl hmem) + · have hnotDom : ¬ domI.mem i := by + intro hmem + exact hi (Or.inr hmem) + have hnone : FiniteMap.get? I i = none := by + cases hget : FiniteMap.get? I i with + | none => rfl + | some v => + have : domI.mem i := by simp [domI, hget] + exact (hnotDom this).elim + exact ⟨hnone, hiφ⟩ + + -- allow two extra nested bupds (for updateP and auth update) + iapply BIUpdate.trans + iapply BIUpdate.trans + + -- first bupd: allocate the disabled token cell + iapply (wrapEntails (GF := GF) (bupd_wand_l (P := ownD W (∅ : GSet)))) + isplitr [] + · iintro HownD0 + -- second bupd: update empty disabled tokens to a fresh singleton + let updP : IProp GF := + BIBase.exists fun Y : GSetDisj => + BIBase.sep + (BIBase.pure (∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ + (FiniteMap.get? I i = none ∧ φ i))) + (iOwn (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name) Y) + iapply (wrapEntails (GF := GF) (bupd_wand_l (P := updP))) + isplitr [HownD0] + · iintro HupdRes + icases HupdRes with ⟨%Y, HupdRes⟩ + icases HupdRes with ⟨%hY, HownDY⟩ + rcases hY with ⟨i, hYeq, hIφ⟩ + subst hYeq + have hnone : FiniteMap.get? I i = none := hIφ.1 + have hφ : φ i := hIφ.2 + -- third bupd: update the invariant registry auth to insert the new entry + iapply bupd_wand_l + isplitr [Hauth] + · iintro Hauth' + icases (wrapEntails (GF := GF) (iOwn_op (GF := GF) (F := InvF GF M F) (γ := W.invariant_name) + (a1 := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (FiniteMap.insert I i P))) + (a2 := gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P)))).mp) $$ Hauth' with ⟨Hauth1, Hfrag⟩ + iexists i + isplit + · ipure_intro; exact hφ + · isplitr [Hfrag HownDY] + · -- wand for closing + iintro HownE + iexists (FiniteMap.insert I i P) + isplitl [Hauth1] + · iexact Hauth1 + · iapply (wrapEntails (GF := GF) (big_sepM_insert + (Φ := fun i Q => + BIBase.or + (BIBase.sep (BIBase.later Q) (ownD W (GSet.singleton i))) + (ownE W (CoPset.singleton i))) + (m := I) (i := i) (x := P) hnone).mpr) + isplitl [HownE] + · iright; iexact HownE + · iexact Hbig + · -- ownI ∗ ownD + isplitl [Hfrag] + · simpa [ownI] using Hfrag + · simpa [ownD] using HownDY + · -- build the update on the auth map + iapply (wrapEntails (GF := GF) (iOwn_update (GF := GF) (F := InvF GF M F) (γ := W.invariant_name) + (a := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) I)) + (a' := gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (FiniteMap.insert I i P)) • + gmap_view_frag (GF := GF) (M := M) (F := F) i .discard + (toAgree (invariant_unfold (GF := GF) P))) + (inv_auth_alloc (I := I) (i := i) (P := P) hnone))) + iexact Hauth + · -- update the disabled tokens + iapply (wrapEntails (GF := GF) (iOwn_updateP (GF := GF) (F := COFE.constOF GSetDisj) (γ := W.disabled_name) + (a := GSetDisj.gset (∅ : GSet)) + (P := fun Y => ∃ i, Y = GSetDisj.gset (GSet.singleton i) ∧ + (FiniteMap.get? I i = none ∧ φ i)) + (gset_disj_alloc_empty_updateP_strong' + (P := fun i => FiniteMap.get? I i = none ∧ φ i) Hfresh'))) + simpa [ownD] using HownD0 + · iapply (ownD_emptyE (W := W)) + iemp_intro + +/-! ## Initial World -/ + +/-- Allocate the initial world satisfaction and top-level enabled mask. + This is the entry point: from nothing, produce `wsat ∗ ownE ⊤`. -/ +theorem wsat_alloc : + (BIBase.emp : IProp GF) ⊢ + BUpd.bupd (BIBase.exists fun W' : WsatGS GF => + BIBase.sep (wsat (GF := GF) (M := M) (F := F) W') (ownE W' CoPset.top)) := by + classical + -- allocate the three ghost cells + let aI := + gmap_view_auth (GF := GF) (M := M) (F := F) (.own one) + (inv_map (GF := GF) (∅ : M (IPropU GF))) + let aE : CoPsetDisj := CoPsetDisj.coPset CoPset.top + let aD : GSetDisj := GSetDisj.gset (∅ : GSet) + have hI : ✓ aI := by + simpa [aI, gmap_view_auth] using + (HeapView.auth_one_valid (F := F) (H := M) + (m1 := inv_map (GF := GF) (∅ : M (IPropU GF)))) + have hE : ✓ aE := by + simp [aE, CMRA.Valid] + have hD : ✓ aD := by + simp [aD, CMRA.Valid] + + refine emp_sep.mpr.trans <| + (sep_mono (iOwn_alloc (GF := GF) (F := COFE.constOF GSetDisj) aD hD) .rfl).trans ?_ + refine emp_sep.mpr.trans <| + (sep_mono (iOwn_alloc (GF := GF) (F := COFE.constOF CoPsetDisj) aE hE) .rfl).trans ?_ + refine emp_sep.mpr.trans <| + (sep_mono (iOwn_alloc (GF := GF) (F := InvF GF M F) aI hI) .rfl).trans ?_ + + -- combine the bupds + refine ((@sep_mono (PROP := IProp GF)) .rfl (sep_assoc (PROP := IProp GF)).2).trans ?_ + refine ((@sep_mono (PROP := IProp GF)) .rfl sep_emp.mp).trans ?_ + refine ((@sep_mono (PROP := IProp GF)) .rfl bupd_sep).trans ?_ + refine (bupd_sep (PROP := IProp GF)).trans ?_ + + refine (BIUpdate.mono (PROP := IProp GF) ?_) + istart + iintro Halloc + icases Halloc with ⟨HγI, Hrest⟩ + icases HγI with ⟨%γI, HγI⟩ + icases Hrest with ⟨HγE, HγD⟩ + icases HγE with ⟨%γE, HγE⟩ + icases HγD with ⟨%γD, HγD⟩ + haveI : CMRA.CoreId aD := by + refine ⟨by rfl⟩ + icases HγD with #HγD + let W' : WsatGS GF := { invariant_name := γI, enabled_name := γE, disabled_name := γD } + iexists W' + isplitr [HγE] + · -- wsat for the empty map + iexists (∅ : M (IPropU GF)) + isplitl [HγI] + · iexact HγI + · simp [big_sepM_empty] + iemp_intro + · -- enabled mask at top + simp [ownE] + iexact HγE + +end Iris.BaseLogic diff --git a/src/Iris/ProofMode/Classes.lean b/src/Iris/ProofMode/Classes.lean index 9b135979..dcdf05d6 100644 --- a/src/Iris/ProofMode/Classes.lean +++ b/src/Iris/ProofMode/Classes.lean @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Lars König -/ import Iris.BI +import Iris.Std.Namespace import Iris.ProofMode.SynthInstance namespace Iris.ProofMode @@ -147,4 +148,26 @@ class IntoExcept0 [BI PROP] (P : PROP) (Q : outParam PROP) where into_except0 : P ⊢ ◇ Q export IntoExcept0 (into_except0) +/-! ## Invariants and Accessors -/ + +/-- Extract the namespace associated with an invariant assertion. -/ +@[ipm_class] +class IntoInv [BI PROP] (P : PROP) (N : outParam Namespace) : Prop where + -- marker class: no fields, only carries the namespace + +/-- Accessor packaging for proof mode elimination. -/ +def accessor [BI PROP] {X : Type _} (M1 M2 : PROP → PROP) + (α β : X → PROP) (mγ : X → Option PROP) : PROP := + -- `default emp` (via `Option.getD`) when no closing shift is provided. + M1 (BIBase.exists fun x => + BIBase.sep (α x) + (BIBase.wand (β x) (M2 (Option.getD (mγ x) (BIBase.emp))))) + +/-- Typeclass for assertions that can be turned into accessors. -/ +@[ipm_class] +class IntoAcc [BI PROP] {X : Type _} (Pacc : PROP) (φ : Prop) (Pin : PROP) + (M1 M2 : PROP → PROP) (α β : X → PROP) (mγ : X → Option PROP) : Prop where + -- Produce an accessor under the required side-condition. + into_acc : φ → Pacc ⊢ Pin -∗ accessor M1 M2 α β mγ + end Iris.ProofMode diff --git a/src/Iris/ProofMode/Instances.lean b/src/Iris/ProofMode/Instances.lean index 108e310c..954ecd93 100644 --- a/src/Iris/ProofMode/Instances.lean +++ b/src/Iris/ProofMode/Instances.lean @@ -109,6 +109,10 @@ instance intoForall_intuitionistically [BI PROP] (P : PROP) (Φ : α → PROP) [h : IntoForall P Φ] : IntoForall iprop(□ P) (fun a => iprop(□ (Φ a))) where into_forall := (intuitionistically_mono h.1).trans intuitionistically_forall_1 +instance intoForall_persistently [BI PROP] (P : PROP) (Φ : α → PROP) + [h : IntoForall P Φ] : IntoForall iprop( P) (fun a => iprop( (Φ a))) where + into_forall := (persistently_mono h.1).trans persistently_forall_1 + instance intoForall_wand_pure [BI PROP] (P Q : PROP) Φ [h : FromPure a P Φ] : IntoForall iprop(P -∗ Q) (fun _ : Φ => Q) where into_forall := forall_intro λ hΦ => @@ -141,6 +145,9 @@ instance fromExists_persistently [BI PROP] (P : PROP) (Φ : α → PROP) [h : Fr from_exists := persistently_exists.2.trans <| persistently_mono h.1 -- IntoExists +instance intoExists_base [BI PROP] (Φ : α → PROP) : + IntoExists (BIBase.exists Φ) Φ := ⟨.rfl⟩ + instance intoExists_exists [BI PROP] (Φ : α → PROP) : IntoExists (BI.exists Φ) Φ := ⟨.rfl⟩ instance intoExists_pure (φ : α → Prop) [BI PROP] : diff --git a/src/Iris/Std.lean b/src/Iris/Std.lean index 1b2f1422..cbd6f172 100644 --- a/src/Iris/Std.lean +++ b/src/Iris/Std.lean @@ -1,12 +1,18 @@ +import Iris.Std.CoPset import Iris.Std.Classes import Iris.Std.Expr +import Iris.Std.GSet import Iris.Std.Heap import Iris.Std.HeapInstances import Iris.Std.Infinite +import Iris.Std.Namespace import Iris.Std.Nat +import Iris.Std.Positive import Iris.Std.Prod import Iris.Std.Qq import Iris.Std.Rewrite import Iris.Std.Tactic import Iris.Std.TC import Iris.Std.Try +import Iris.Std.FiniteMap +import Iris.Std.List diff --git a/src/Iris/Std/CoPset.lean b/src/Iris/Std/CoPset.lean new file mode 100644 index 00000000..ce5c193a --- /dev/null +++ b/src/Iris/Std/CoPset.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ + +import Iris.Std.Positive + +/-! # Co-finite Powerset of Invariant Names + +Reference: `stdpp/theories/coPset.v` + +Invariant masks track which invariants are currently enabled or available for +opening. A mask is a (potentially co-finite) set of invariant names. The fancy +update modality `|={E1,E2}=> P` uses masks to prevent double-opening: opening +an invariant removes its name from the mask, and closing it adds the name back. + +We use a predicate-based representation rather than a literal co-finite `Finset`. +This is sufficient for mask reasoning and disjointness but does not provide +decidable membership — classical decidability is used where needed. + +## Main Definitions + +- `CoPset` — set of invariant names, represented as a membership predicate +- Set operations: `empty`, `top`, `union`, `inter`, `diff`, `compl`, `singleton` +- Predicates: `Disjoint`, `Subset` + +## Main Results + +- `union_assoc`, `union_comm`, `empty_union` — union forms a commutative monoid +- `subseteq_disjoint_union` — any subset decomposes into a disjoint union +-/ + +namespace Iris + +/-! ## Definition -/ + +/-- Co-finite powerset of invariant names. Used for invariant masks. -/ +structure CoPset where + /-- Membership predicate. -/ + mem : Positive → Prop + +namespace CoPset + +@[ext] +theorem ext {s₁ s₂ : CoPset} (h : ∀ n, s₁.mem n ↔ s₂.mem n) : s₁ = s₂ := by + -- extensionality for predicate-based sets + cases s₁; cases s₂; simp only [mk.injEq] + exact funext fun n => propext (h n) + +/-! ## Basic Constructors -/ + +def empty : CoPset := by + -- empty set: always false + exact ⟨fun _ => False⟩ + +def top : CoPset := by + -- top set: always true + exact ⟨fun _ => True⟩ + +def singleton (n : Positive) : CoPset := by + -- singleton membership + exact ⟨fun m => m = n⟩ + +instance : EmptyCollection CoPset := ⟨empty⟩ +instance : Singleton Positive CoPset := ⟨singleton⟩ + +/-! ## Set Operations -/ + +def union (s₁ s₂ : CoPset) : CoPset := by + -- union membership via disjunction + exact ⟨fun n => s₁.mem n ∨ s₂.mem n⟩ + +def inter (s₁ s₂ : CoPset) : CoPset := by + -- intersection membership via conjunction + exact ⟨fun n => s₁.mem n ∧ s₂.mem n⟩ + +def diff (s₁ s₂ : CoPset) : CoPset := by + -- set difference: left membership and not right membership + exact ⟨fun n => s₁.mem n ∧ ¬s₂.mem n⟩ + +def compl (s : CoPset) : CoPset := by + -- complement: negate membership + exact ⟨fun n => ¬s.mem n⟩ + +instance : Union CoPset := ⟨union⟩ +instance : Inter CoPset := ⟨inter⟩ +instance : SDiff CoPset := ⟨diff⟩ + +/-! ## Predicates -/ + +/-- Two sets are disjoint if they share no elements. -/ +def Disjoint (s₁ s₂ : CoPset) : Prop := by + -- disjointness means no shared element + exact ∀ n, ¬(s₁.mem n ∧ s₂.mem n) + +/-- Subset relation. -/ +def Subset (s₁ s₂ : CoPset) : Prop := by + -- subset means elementwise implication + exact ∀ n, s₁.mem n → s₂.mem n + +instance : HasSubset CoPset := ⟨Subset⟩ + +noncomputable instance (s₁ s₂ : CoPset) : Decidable (Disjoint s₁ s₂) := by + -- classical decidability for predicate-based disjointness + exact Classical.propDecidable _ + +/-! ## Simp Lemmas -/ + +@[simp] theorem mem_empty (n : Positive) : (∅ : CoPset).mem n ↔ False := by + -- unfold empty membership + rfl + +@[simp] theorem mem_top (n : Positive) : CoPset.top.mem n ↔ True := by + -- unfold top membership + rfl + +@[simp] theorem mem_singleton (n m : Positive) : ({m} : CoPset).mem n ↔ n = m := by + -- unfold singleton membership + rfl + +@[simp] theorem mem_union (s₁ s₂ : CoPset) (n : Positive) : + (s₁ ∪ s₂).mem n ↔ s₁.mem n ∨ s₂.mem n := by + -- unfold union membership + rfl + +@[simp] theorem mem_inter (s₁ s₂ : CoPset) (n : Positive) : + (s₁ ∩ s₂).mem n ↔ s₁.mem n ∧ s₂.mem n := by + -- unfold intersection membership + rfl + +@[simp] theorem mem_diff (s₁ s₂ : CoPset) (n : Positive) : + (s₁ \ s₂).mem n ↔ s₁.mem n ∧ ¬s₂.mem n := by + -- unfold difference membership + rfl + +@[simp] theorem mem_compl (s : CoPset) (n : Positive) : + s.compl.mem n ↔ ¬s.mem n := by + -- unfold complement membership + rfl + +/-! ## Set Algebra Laws -/ + +theorem union_assoc (s₁ s₂ s₃ : CoPset) : s₁ ∪ s₂ ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) := by + -- associativity of union via propositional associativity + ext n; simp [or_assoc] + +theorem union_comm (s₁ s₂ : CoPset) : s₁ ∪ s₂ = s₂ ∪ s₁ := by + -- commutativity of union via propositional commutativity + ext n; simp [or_comm] + +theorem union_empty (s : CoPset) : s ∪ ∅ = s := by + -- right identity of union + ext n; simp + +theorem empty_union (s : CoPset) : ∅ ∪ s = s := by + -- left identity of union + ext n; simp + +theorem union_idem (s : CoPset) : s ∪ s = s := by + -- idempotence of union + ext n; simp [or_self] + +/-! ## Subset Lemmas -/ + +theorem subset_refl (s : CoPset) : s ⊆ s := by + -- subset reflexivity + intro _ h; exact h + +theorem subset_union_left (s₁ s₂ : CoPset) : s₁ ⊆ s₁ ∪ s₂ := by + -- left subset into union + intro _ h; exact Or.inl h + +theorem subset_union_right (s₁ s₂ : CoPset) : s₂ ⊆ s₁ ∪ s₂ := by + -- right subset into union + intro _ h; exact Or.inr h + +/-! ## Disjointness Lemmas -/ + +theorem disjoint_comm {s₁ s₂ : CoPset} : Disjoint s₁ s₂ ↔ Disjoint s₂ s₁ := by + -- symmetry by swapping conjuncts + refine ⟨?_, ?_⟩ + · intro h n hn + exact h n ⟨hn.2, hn.1⟩ + · intro h n hn + exact h n ⟨hn.2, hn.1⟩ + + +theorem disjoint_empty_right (s : CoPset) : Disjoint s ∅ := by + -- empty set is disjoint on the right + intro _ hn; exact hn.2 + + +theorem disjoint_empty_left (s : CoPset) : Disjoint ∅ s := by + -- empty set is disjoint on the left + intro _ hn; exact hn.1 + +/-- Any subset can be decomposed as a disjoint union with the set difference. -/ +theorem subseteq_disjoint_union {s₁ s₂ : CoPset} (h : s₁ ⊆ s₂) : + ∃ s₃, s₂ = s₁ ∪ s₃ ∧ Disjoint s₁ s₃ := by + -- choose the set difference as the disjoint complement + refine ⟨s₂ \ s₁, ?_, ?_⟩ + · ext n; simp; constructor + · intro hn + by_cases h₁ : s₁.mem n + · exact Or.inl h₁ + · exact Or.inr ⟨hn, h₁⟩ + · rintro (h₁ | ⟨h₂, _⟩) + · exact h _ h₁ + · exact h₂ + · exact fun _ ⟨h₁, _, h₃⟩ => h₃ h₁ + +end CoPset + +end Iris diff --git a/src/Iris/Std/FiniteMap.lean b/src/Iris/Std/FiniteMap.lean new file mode 100644 index 00000000..4385cdae --- /dev/null +++ b/src/Iris/Std/FiniteMap.lean @@ -0,0 +1,1388 @@ +/- +Copyright (c) 2026 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ + +import Iris.Std.List + +/-! ## Abstract Finite Map Interface + +This file defines an abstract interface for finite maps, inspired by stdpp's `fin_maps`. -/ + +namespace Iris.Std + +/-- The type `M` represents a finite map from keys of type `K` to values of type `V`. -/ +class FiniteMap (K : outParam (Type u)) (M : Type u' → Type _) where + /-- Lookup a key in the map, returning `none` if not present. + Corresponds to Rocq's `lookup`. -/ + get? : M V → K → Option V + /-- Insert or update a key-value pair. + Corresponds to Rocq's `insert`. -/ + insert : M V → K → V → M V + /-- Remove a key from the map. + Corresponds to Rocq's `delete`. -/ + delete : M V → K → M V + /-- The empty map. -/ + empty : M V + /-- Convert the map to a list of key-value pairs. + Corresponds to Rocq's `map_to_list`. -/ + toList : M V → List (K × V) + /-- Construct a map from a list of key-value pairs. + Corresponds to Rocq's `list_to_map`. -/ + ofList : List (K × V) → M V + /-- Fold over all key-value pairs in the map. + The order of folding depends on the internal representation. + Corresponds to Rocq's `map_fold`. -/ + fold {A : Type u'} : (K → V → A → A) → A → M V → A + +export FiniteMap (get? insert delete toList ofList fold) + +namespace FiniteMap + +variable {K : Type u} {V : Type u'} {M : Type u' → Type _} [FiniteMap K M] + +/-- Empty map instance for `∅` notation. -/ +instance : EmptyCollection (M V) := ⟨empty⟩ + +/-- Singleton map containing exactly one key-value pair. + Corresponds to Rocq's `{[ i := x ]}` notation. -/ +def singleton (k : K) (v : V) : M V := insert ∅ k v + +/-- Union of two maps (left-biased: values from `m₁` take precedence). + Corresponds to Rocq's `m₁ ∪ m₂`. -/ +def union (m₁ m₂ : M V) : M V:= + (toList m₁).foldl (fun acc (k, v) => insert acc k v) m₂ + +instance : Union (M V):= ⟨union⟩ + +/-- Two maps have disjoint domains. + Corresponds to Rocq's `map_disjoint`. -/ +def disjoint (m₁ m₂ : M V) : Prop := ∀ k, ¬((get? m₁ k).isSome ∧ (get? m₂ k).isSome) + +/-- Submap relation: `m₁` is a submap of `m₂` if every key-value pair in `m₁` is also in `m₂`. + Corresponds to Rocq's `map_subseteq`. -/ +def submap (m₁ m₂ : M V) : Prop := ∀ k v, get? m₁ k = some v → get? m₂ k = some v + +instance : HasSubset (M V) := ⟨submap⟩ + +/-- Map a function over all values in the map. + Corresponds to Rocq's `fmap` (notation `f <$> m`). -/ +def map (f : V → V') : M V → (M V') := + fun m => ofList ((toList m).map (fun (k, v) => (k, f v))) + +/-- Filter and map: apply a function that can optionally drop entries. + Corresponds to Rocq's `omap`. -/ +def filterMap (f : V → Option V') : M V → M V' := + fun m => ofList ((toList m).filterMap (fun (k, v) => (f v).map (k, ·))) + +/-- Filter entries by a predicate on key-value pairs. + Corresponds to Rocq's `filter`. -/ +def filter (φ : K → V → Bool) : M V → M V := + fun m => ofList ((toList m).filter (fun (k, v) => φ k v)) + +/-- Zip two maps with a combining function. + Corresponds to Rocq's `map_zip_with`. -/ +def zipWith {V' : Type _} {V'' : Type _} (f : V → V' → V'') (m₁ : M V) (m₂ : M V') : M V'' := + ofList ((toList m₁).filterMap (fun (k, v) => + match get? m₂ k with + | some v' => some (k, f v v') + | none => none)) + +/-- Zip two maps: combine values at matching keys into pairs. + This is `zipWith Prod.mk`. + Corresponds to Rocq's `map_zip`. -/ +def zip (m₁ : M V) (m₂ : M V') : M (V × V') := + zipWith Prod.mk m₁ m₂ + +/-- Membership: a key is in the map if it has a value. -/ +def mem (m : M V) (k : K) : Prop := (get? m k).isSome + +/-- Difference: remove all keys in `m₂` from `m₁`. + Corresponds to Rocq's `map_difference`. -/ +def difference (m₁ m₂ : M V) : M V := + ofList ((toList m₁).filter (fun (k, _) => (get? m₂ k).isNone)) + +instance : SDiff (M V) := ⟨difference⟩ + +/-- Transform keys of a map using an injective function. + Corresponds to Rocq's `kmap`. -/ +def kmap {K' : Type u} {M' : Type u' → _} [FiniteMap K' M'] (f : K → K') (m : M V) : (M' V) := + ofList ((toList m).map (fun (k, v) => (f k, v))) + +/-- Convert a list to a map with sequential natural number keys starting from `start`. + Corresponds to Rocq's `map_seq`. -/ +def map_seq [FiniteMap Nat M] (start : Nat) (l : List V) : M V := + ofList (l.mapIdx (fun i v => (start + i, v))) + +/-- Check if a key is the first key in the map's `toList` representation. + Corresponds to Rocq's `map_first_key`: `∃ x, map_to_list m !! 0 = Some (i,x)`. -/ +def firstKey (m : M V) (i : K) : Prop := + ∃ x, (toList m).head? = some (i, x) + +/-- Corresponds to Rocq's `map_Forall`. -/ +def Forall (P : K → V → Prop) (m : M V) : Prop := + ∀ k v, get? m k = some v → P k v + +end FiniteMap + +/-- Notation for singleton map: `{[k := v]}` -/ +scoped syntax "{[" term " := " term "]}" : term + +scoped macro_rules + | `({[$k := $v]}) => `(FiniteMap.singleton $k $v) + +/-- Notation for map disjointness: `m₁ ##ₘ m₂` -/ +scoped infix:50 " ##ₘ " => FiniteMap.disjoint + +/-- Membership instance for finite maps: `k ∈ m` means the key `k` is in the map `m`. -/ +instance {K : Type u} {M : Type u' → Type _} [inst : FiniteMap K M] : Membership K (M V) := + ⟨fun (m : M V) (k : K) => (inst.get? m k).isSome⟩ + +/-- Laws that a finite map implementation must satisfy. -/ +class FiniteMapLaws (K : (outParam (Type u))) (M : Type u' → Type _) + [DecidableEq K] [FiniteMap K M] where + /-- Corresponds to Rocq's `map_eq`. -/ + ext : ∀ (m₁ m₂ : M V), (∀ i, get? m₁ i = get? m₂ i) → m₁ = m₂ + /-- Corresponds to Rocq's `lookup_empty`. -/ + get?_empty : ∀ k, get? (∅ : M V) k = none + /-- Corresponds to Rocq's `lookup_insert_eq`. -/ + get?_insert_same : ∀ (m : M V) k v, get? (insert m k v) k = some v + /-- Corresponds to Rocq's `lookup_insert_ne`. -/ + get?_insert_ne : ∀ (m : M V) k k' v, k ≠ k' → get? (insert m k v) k' = get? m k' + /-- Corresponds to Rocq's `lookup_delete_eq`. -/ + get?_delete_same : ∀ (m : M V) k, get? (delete m k) k = none + /-- Corresponds to Rocq's `lookup_delete_ne`. -/ + get?_delete_ne : ∀ (m : M V) k k', k ≠ k' → get? (delete m k) k' = get? m k' + /-- Corresponds to Rocq's `lookup_union`. -/ + get?_union : ∀ (m₁ m₂ : M V) k, + get? (m₁ ∪ m₂) k = (get? m₁ k).orElse (fun _ => get? m₂ k) + /-- Corresponds to Rocq's `lookup_difference`. -/ + get?_difference : ∀ (m₁ m₂ : M V) k, + get? (m₁ \ m₂) k = if (get? m₂ k).isSome then none else get? m₁ k + /-- Corresponds to Rocq's implicit behavior of `list_to_map`. -/ + ofList_nil : (ofList [] : M V) = ∅ + /-- Corresponds to Rocq's implicit behavior of `list_to_map`. -/ + ofList_cons : ∀ (k : K) (v : V) (l : List (K × V)), + (ofList ((k, v) :: l) : M V) = insert (ofList l) k v + /-- Corresponds to Rocq's `map_to_list_spec`. -/ + toList_spec (m : M V) : + (toList m).Nodup ∧ (∀ i x, (i, x) ∈ toList m ↔ get? m i = some x) + /-- Corresponds to Rocq's `map_ind`. -/ + induction_on {P : M V → Prop} + (hemp : P ∅) + (hins : ∀ i x m, get? m i = none → P m → P (insert m i x)) + (m : M V) : P m + +/-- Self-referential extended laws. -/ +class FiniteMapLawsSelf (K : outParam (Type u)) (M : Type u' → Type _) + [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] where + /-- toList of filterMap is related to filterMap over toList. -/ + toList_filterMap : ∀ (m : M V) (f : V → Option V), + (toList (FiniteMap.filterMap (M := M) f m)).Perm + ((toList m).filterMap (fun kv => (f kv.2).map (kv.1, ·))) + /-- toList of filter is related to filter over toList. -/ + toList_filter : ∀ (m : M V) (φ : K → V → Bool), + (toList (FiniteMap.filter (M := M) φ m)).Perm + ((toList m).filter (fun kv => φ kv.1 kv.2)) + +/-- Laws for kmap operation. -/ +class FiniteMapKmapLaws (K : outParam (Type u)) (K' : outParam (Type u)) (M : Type u' → Type _) (M' : Type u' → Type _) + [DecidableEq K] [DecidableEq K'] [FiniteMap K M] [FiniteMap K' M'] + [FiniteMapLaws K M] [FiniteMapLaws K' M'] where + /-- toList of kmap is related to mapping over toList. + Corresponds to Rocq's `map_to_list_kmap`. -/ + toList_kmap : ∀ (f : K → K') (m : M V), + (∀ {x y}, f x = f y → x = y) → -- f is injective + (toList (FiniteMap.kmap (M' := M') f m)).Perm + ((toList m).map (fun (k, v) => (f k, v))) + +/-- Laws for map_seq operation. -/ +class FiniteMapSeqLaws (M : Type u → Type _) [FiniteMap Nat M] [FiniteMapLaws Nat M] where + /-- toList of map_seq is related to zip with sequence. + Corresponds to Rocq's `map_to_list_seq`. -/ + toList_map_seq : ∀ (start : Nat) (l : List V), + (toList (FiniteMap.map_seq start l : M V)).Perm + (l.mapIdx (fun i v => ((i + start), v))) + +export FiniteMapLaws (ext +get?_empty +get?_insert_same get?_insert_ne +get?_delete_same get?_delete_ne +ofList_nil ofList_cons +toList_spec +induction_on) + +export FiniteMapLawsSelf (toList_filterMap toList_filter) +export FiniteMapKmapLaws (toList_kmap) +export FiniteMapSeqLaws (toList_map_seq) + +namespace FiniteMapLaws + +variable {K : Type u} {V : Type u'} {M : Type u' → Type _} +variable [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] + +private theorem mem_of_get?_ofList (l : List (K × V)) (k : K) (v : V) : + get? (ofList l : M V) k = some v → (k, v) ∈ l := by + intro h + induction l with + | nil => + simp [ofList_nil, get?_empty] at h + | cons kv kvs ih => + rw [ofList_cons] at h + by_cases heq : kv.1 = k + · have eq_val : kv.2 = v := by + rw [heq, get?_insert_same] at h + exact Option.some.inj h + have eq_kv : kv = (k, v) := by + ext + · exact heq + · exact eq_val + rw [← eq_kv] + exact List.Mem.head _ + · rw [get?_insert_ne _ _ _ _ heq] at h + have := ih h + exact List.Mem.tail _ this + + +/-- Corresponds to Rocq's `lookup_insert`. -/ +theorem get?_insert (m : M V) (k k' : K) (v : V) : + get? (insert m k v) k' = if k = k' then some v else get? m k' := by + split + · next h => rw [h, get?_insert_same] + · next h => exact get?_insert_ne m k k' v h + +/-- Corresponds to Rocq's `lookup_delete`. -/ +theorem get?_delete (m : M V) (k k' : K) : + get? (delete m k) k' = if k = k' then none else get? m k' := by + split + · next h => rw [h, get?_delete_same] + · next h => exact get?_delete_ne m k k' h + +/-- Corresponds to Rocq's `insert_delete_eq`. -/ +theorem get?_insert_delete (m : M V) (k k' : K) (v : V) : + get? (insert (delete m k) k v) k' = get? (insert m k v) k' := by + by_cases h : k = k' + · simp [h, get?_insert_same] + · simp [get?_insert_ne _ _ _ _ h, get?_delete_ne _ _ _ h] + +/-- Corresponds to Rocq's `NoDup_map_to_list`. -/ +theorem nodup_toList (m : M V): (toList m).Nodup := by + apply (toList_spec m).1 + +/-- If a list has no duplicates and the projection is injective on list elements, + then the mapped list has no duplicates. -/ +theorem List.Nodup.map_of_injective {α β : Type _} {l : List α} {f : α → β} + (hnodup : l.Nodup) (hinj : ∀ a b, a ∈ l → b ∈ l → f a = f b → a = b) : + (l.map f).Nodup := by + induction l with + | nil => exact List.nodup_nil + | cons x xs ih => + rw [List.map_cons, List.nodup_cons] + rw [List.nodup_cons] at hnodup + constructor + · intro hx_in + rw [List.mem_map] at hx_in + obtain ⟨y, hy_mem, hy_eq⟩ := hx_in + have hx_mem : x ∈ x :: xs := List.mem_cons_self + have hy_mem' : y ∈ x :: xs := List.mem_cons_of_mem x hy_mem + have : x = y := hinj x y hx_mem hy_mem' hy_eq.symm + subst this + exact hnodup.1 hy_mem + · apply ih hnodup.2 + intro a b ha hb + exact hinj a b (List.mem_cons_of_mem x ha) (List.mem_cons_of_mem x hb) + +/-- Keys of toList have no duplicates. -/ +theorem nodup_toList_keys (m : M V) : (toList m).map Prod.fst |>.Nodup := by + apply List.Nodup.map_of_injective (nodup_toList m) + intro ⟨k₁, v₁⟩ ⟨k₂, v₂⟩ h1 h2 heq + simp at heq + obtain ⟨_, hmem⟩ := toList_spec (M := M) (K := K) (V := V) m + have hv1 : get? m k₁ = some v₁ := (hmem k₁ v₁).mp h1 + have hv2 : get? m k₂ = some v₂ := (hmem k₂ v₂).mp h2 + rw [heq] at hv1 + rw [hv1] at hv2 + cases hv2 + ext <;> simp [heq] + +/-- Corresponds to Rocq's `elem_of_map_to_list`. -/ +theorem mem_toList (m : M V) : ∀ k v, (k, v) ∈ toList m ↔ get? m k = some v := by + apply (toList_spec m).2 + +/-- Corresponds to Rocq's `elem_of_list_to_map_2`. -/ +theorem mem_of_mem_ofList (l : List (K × V)) (i : K) (x : V) : + get? (ofList l : M V) i = some x → (i, x) ∈ l := by + induction l with + | nil => + intro h + rw [ofList_nil, get?_empty] at h + cases h + | cons kv l ih => + intro h + obtain ⟨k, v⟩ := kv + rw [ofList_cons] at h + rw [get?_insert] at h + split at h + · next heq => + cases h + rw [← heq] + simp [List.mem_cons] + · next hne => + have : (i, x) ∈ l := ih h + exact List.mem_cons_of_mem _ this + +/-- Corresponds to Rocq's `elem_of_list_to_map_1`. -/ +theorem mem_ofList_of_mem (l : List (K × V)) (i : K) (x : V) : + (l.map Prod.fst).Nodup → (i, x) ∈ l → get? (ofList l : M V) i = some x := by + intro hnodup hmem + induction l with + | nil => + simp at hmem + | cons kv l ih => + obtain ⟨k, v⟩ := kv + rw [List.map_cons, List.nodup_cons] at hnodup + simp [List.mem_cons] at hmem + cases hmem with + | inl heq => + obtain ⟨rfl, rfl⟩ := heq + rw [ofList_cons, get?_insert_same] + | inr hmem' => + obtain ⟨hk_notin, hnodup_tail⟩ := hnodup + have hi_in : i ∈ l.map Prod.fst := by + rw [List.mem_map] + exact ⟨(i, x), hmem', rfl⟩ + have hne : k ≠ i := by + intro heq + subst heq + exact hk_notin hi_in + have : get? (ofList l : M V) i = some x := ih hnodup_tail hmem' + rw [ofList_cons, get?_insert_ne _ _ _ _ hne, this] + +/-- Corresponds to Rocq's `elem_of_list_to_map` -/ +theorem mem_ofList (l : List (K × V)) i x (hnodup : (l.map Prod.fst).Nodup): + (i,x) ∈ l ↔ get? (ofList l : M V) i = some x := by + constructor + apply mem_ofList_of_mem; exact hnodup + apply mem_of_mem_ofList + +/-- Corresponds to Rocq's `list_to_map_inj`. -/ +theorem ofList_injective [DecidableEq V] (l1 l2 : List (K × V)) : + (l1.map Prod.fst).Nodup → (l2.map Prod.fst).Nodup → + (ofList l1 : M V) = ofList l2 → l1.Perm l2 := by + intro hnodup1 hnodup2 heq + have hnodup1' : l1.Nodup := List.nodup_of_nodup_map_fst l1 hnodup1 + have hnodup2' : l2.Nodup := List.nodup_of_nodup_map_fst l2 hnodup2 + haveI : DecidableEq (K × V) := inferInstance + apply List.perm_of_nodup_of_mem_iff hnodup1' hnodup2' + intro ⟨i, x⟩ + rw [mem_ofList (M := M) (K := K) l1 i x hnodup1, + mem_ofList (M := M) (K := K) l2 i x hnodup2] + rw [heq] + +/-- Coresponds to Rocq's `list_to_map_to_list` -/ +theorem ofList_toList (m : M V) : + ofList (toList m) = m := by + apply ext (K := K) + intro i + cases heq : get? m i + · cases heq' : get? (ofList (toList m) : M V) i + · rfl + · rename_i val + have hmem : (i, val) ∈ toList m := + (mem_ofList (M := M) (K := K) (toList m) i val (nodup_toList_keys m)).mpr heq' + have : get? m i = some val := (mem_toList m i val).mp hmem + rw [heq] at this + exact Option.noConfusion this + · rename_i val + have hmem : (i, val) ∈ toList m := (mem_toList m i val).mpr heq + have : get? (ofList (toList m) : M V) i = some val := + (mem_ofList (M := M) (K := K) (toList m) i val (nodup_toList_keys m)).mp hmem + rw [this] + + /-- Corresponds to Rocq's `map_to_list_to_map`. -/ + theorem toList_ofList [DecidableEq V] : ∀ (l : List (K × V)), (l.map Prod.fst).Nodup → + (toList (ofList l : M V)).Perm l := by + intro l hnodup + apply ofList_injective (M := M) (K:=K) + · exact nodup_toList_keys (M := M) (K := K) (V := V) (ofList l) + · exact hnodup + rw [ofList_toList] + +/-- Two maps with the same get? behavior have permutation-equivalent toLists. -/ +theorem toList_perm_of_get?_eq [DecidableEq V] {m₁ m₂ : M V} + (h : ∀ k, get? m₁ k = get? m₂ k) : (toList m₁).Perm (toList m₂) := by + have hnodup₁ := nodup_toList (M := M) (K := K) (V := V) m₁ + have hnodup₂ := nodup_toList (M := M) (K := K) (V := V) m₂ + have hmem : ∀ kv, kv ∈ toList m₁ ↔ kv ∈ toList m₂ := by + intro ⟨k, v⟩ + rw [mem_toList m₁ k v, mem_toList m₂ k v, h] + exact List.perm_of_nodup_of_mem_iff hnodup₁ hnodup₂ hmem + +/-- toList of insert and insert-after-delete are permutations of each other. -/ +theorem toList_insert_delete [DecidableEq V] (m : M V) (k : K) (v : V) : + (toList (insert m k v)).Perm (toList (insert (delete m k) k v)) := + toList_perm_of_get?_eq (fun k' => (get?_insert_delete m k k' v).symm) + +/-- Singleton lookup for equal keys. + Corresponds to Rocq's `get?_singleton_same`. -/ +theorem get?_singleton_same (k : K) (v : V) : + get? ({[k := v]} : M V) k = some v := by + simp [FiniteMap.singleton, get?_insert_same] + +/-- Singleton lookup for different keys. + Corresponds to Rocq's `get?_singleton_ne`. -/ +theorem get?_singleton_ne (k k' : K) (v : V) (h : k ≠ k') : + get? ({[k := v]} : M V) k' = none := by + simp [FiniteMap.singleton, get?_insert_ne _ _ _ _ h, get?_empty] + +/-- Singleton lookup general case. + Corresponds to Rocq's `get?_singleton`. -/ +theorem get?_singleton (k k' : K) (v : V) : + get? ({[k := v]} : M V) k' = if k = k' then some v else none := by + split + · next h => rw [h, get?_singleton_same] + · next h => exact get?_singleton_ne k k' v h + +/-- Insert is idempotent for the same key-value. + Corresponds to Rocq's `insert_insert_eq`. -/ +theorem insert_insert (m : M V) (k : K) (v v' : V) : + get? (insert (insert m k v) k v') = get? (insert m k v' : M V) := by + funext k' + by_cases h : k = k' + · simp [h, get?_insert_same] + · simp [get?_insert_ne _ _ _ _ h] + +/-- Deleting from empty is empty. + Corresponds to Rocq's `delete_empty_eq`. -/ +theorem delete_empty_eq (k : K) : + get? (delete (∅ : M V) k) = get? (∅ : M V) := by + funext k' + by_cases h : k = k' + · simp [h, get?_delete_same, get?_empty] + · simp [get?_delete_ne _ _ _ h, get?_empty] + +/-- Corresponds to Rocq's `map_empty_subseteq`. -/ +theorem empty_subset (m : M V) : (∅ : M V) ⊆ m := by + intro k v h + simp [get?_empty] at h + +/-- Corresponds to Rocq's `map_disjoint_empty_l`. -/ +theorem disjoint_empty_left (m : M V) : (∅ : M V) ##ₘ m := by + intro k ⟨h₁, _⟩ + simp [get?_empty] at h₁ + +/-- Corresponds to Rocq's `lookup_insert_Some`. -/ +theorem get?_insert_some (m : M V) (i j : K) (x y : V) : + get? (insert m i x) j = some y ↔ (i = j ∧ x = y) ∨ (i ≠ j ∧ get? m j = some y) := by + rw [get?_insert] + split <;> simp_all + +/-- Corresponds to Rocq's `lookup_insert_is_Some`. -/ +theorem get?_insert_isSome (m : M V) (i j : K) (x : V) : + (get? (insert m i x) j).isSome ↔ i = j ∨ (i ≠ j ∧ (get? m j).isSome) := by + rw [get?_insert] + split <;> simp_all + +/-- Corresponds to Rocq's `lookup_insert_None`. -/ +theorem get?_insert_none (m : M V) (i j : K) (x : V) : + get? (insert m i x) j = none ↔ get? m j = none ∧ i ≠ j := by + rw [get?_insert] + split <;> simp_all + +/-- Corresponds to Rocq's `lookup_insert_rev`. -/ +theorem get?_insert_rev (m : M V) (i : K) (x y : V) : + get? (insert m i x) i = some y → x = y := by + simp [get?_insert_same] + +/-- Corresponds to Rocq's `insert_id`. -/ +theorem insert_get? (m : M V) (i : K) (x : V) : + get? m i = some x → (∀ k, get? (insert m i x) k = get? m k) := by + intro h k + by_cases hk : i = k + · subst hk; simp only [get?_insert_same, h] + · simp [get?_insert_ne _ _ _ _ hk] + +/-- Corresponds to Rocq's `lookup_delete_Some`. -/ +theorem get?_delete_some (m : M V) (i j : K) (y : V) : + get? (delete m i) j = some y ↔ i ≠ j ∧ get? m j = some y := by + rw [get?_delete] + split <;> simp_all + +/-- Corresponds to Rocq's `lookup_delete_is_Some`. -/ +theorem get?_delete_isSome (m : M V) (i j : K) : + (get? (delete m i) j).isSome ↔ i ≠ j ∧ (get? m j).isSome := by + rw [get?_delete] + split <;> simp_all + +/-- Corresponds to Rocq's `lookup_delete_None`. -/ +theorem get?_delete_none (m : M V) (i j : K) : + get? (delete m i) j = none ↔ i = j ∨ get? m j = none := by + rw [get?_delete] + split <;> simp_all + +/-- Corresponds to Rocq's `insert_delete_id`. -/ +theorem insert_delete_cancel (m : M V) (i : K) (x : V) : + get? m i = some x → insert (delete m i) i x = m := by + intro h + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_insert_same, h] + · simp [get?_insert_ne _ _ _ _ hij, get?_delete_ne _ _ _ hij] + + /-- Corresponds to Rocq's `map_to_list_empty`. -/ +theorem toList_empty : toList (∅ : M V) = [] := by + apply List.eq_nil_iff_forall_not_mem.mpr + intro ⟨i, x⟩ hmem + rw [mem_toList] at hmem + rw [get?_empty] at hmem + exact Option.noConfusion hmem + + /-- Corresponds to Rocq's `map_to_list_insert`. -/ +theorem toList_insert [DecidableEq V] : ∀ (m : M V) k v, get? m k = none → + (toList (insert m k v)).Perm ((k, v) :: toList m) := by + intro m k v hk_none + apply ofList_injective (M := M) (K := K) + · exact nodup_toList_keys (insert m k v) + · rw [List.map_cons, List.nodup_cons] + constructor + · intro hk_in + rw [List.mem_map] at hk_in + obtain ⟨⟨k', v'⟩, hmem, hk_eq⟩ := hk_in + simp at hk_eq + subst hk_eq + have : get? m k' = some v' := (mem_toList m k' v').mp hmem + rw [hk_none] at this + exact Option.noConfusion this + · exact nodup_toList_keys m + · rw [ofList_toList] + rw [ofList_cons, ofList_toList] + +/-- Corresponds to Rocq's `map_to_list_delete`. -/ +theorem toList_delete [DecidableEq V] (m : M V) (k : K) (v : V) (h : get? m k = some v) : + (toList m).Perm ((k, v) :: toList (delete m k)) := by + have heq : toList m = toList (insert (delete m k) k v) := by + rw [insert_delete_cancel m k v h] + rw [heq] + apply toList_insert + exact get?_delete_same m k + + +/-- Corresponds to Rocq's `delete_insert_id`. -/ +theorem delete_insert_cancel (m : M V) (i : K) (x : V) : + get? m i = none → delete (insert m i x) i = m := by + intro h + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_delete_same, h] + · simp [get?_delete_ne _ _ _ hij, get?_insert_ne _ _ _ _ hij] + +/-- Empty map is characterized by all lookups returning none. -/ +theorem eq_empty_iff (m : M V) : m = ∅ ↔ ∀ k, get? m k = none := by + constructor + · intro h k + rw [h, get?_empty] + · intro h + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + rw [h, get?_empty] + +/-- Corresponds to Rocq's `delete_delete_eq`. -/ +theorem delete_delete_same (m : M V) (i : K) : + delete (delete m i) i = delete m i := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_delete_same] + · simp [get?_delete_ne _ _ _ hij] + +/-- Corresponds to Rocq's `delete_delete`. -/ +theorem delete_delete_comm (m : M V) (i j : K) : + delete (delete m i) j = delete (delete m j) i := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + by_cases hik : i = k <;> by_cases hjk : j = k <;> simp [get?_delete, *] + +/-- Corresponds to Rocq's `delete_insert_ne`. -/ +theorem delete_insert_of_ne (m : M V) (i j : K) (x : V) : + i ≠ j → delete (insert m i x) j = insert (delete m j) i x := by + intro hij + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + by_cases hik : i = k <;> by_cases hjk : j = k + · subst hik hjk; exact absurd rfl hij + · subst hik; simp [get?_insert, get?_delete, hjk] + · subst hjk; simp [get?_insert, get?_delete, hik] + · simp [get?_insert, get?_delete, hik, hjk] + +/-- Corresponds to Rocq's `insert_delete_eq`. -/ +theorem insert_delete (m : M V) (i : K) (x : V) : + insert (delete m i) i x = insert m i x := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_insert_same] + · simp [get?_insert_ne _ _ _ _ hij, get?_delete_ne _ _ _ hij] + +/-- Corresponds to Rocq's `insert_insert`. -/ +theorem insert_insert_comm (m : M V) (i j : K) (x y : V) : + i ≠ j → insert (insert m i x) j y = insert (insert m j y) i x := by + intro hij + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + by_cases hik : i = k <;> by_cases hjk : j = k + · subst hik hjk; exact absurd rfl hij + · subst hik; simp [get?_insert, hjk] + · subst hjk; simp [get?_insert, hik] + · simp [get?_insert, hik, hjk] + +/-- Corresponds to Rocq's `insert_insert_eq`. -/ +theorem insert_insert_same (m : M V) (i : K) (x y : V) : + insert (insert m i x) i y = insert m i y := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_insert_same] + · simp [get?_insert_ne _ _ _ _ hij] + +/-- Corresponds to Rocq's `delete_empty`. -/ +theorem delete_empty_eq' (i : K) : + delete (∅ : M V) i = ∅ := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + simp [get?_delete, get?_empty] + +/-- Corresponds to Rocq's `delete_id`. -/ +theorem delete_of_get? (m : M V) (i : K) : + get? m i = none → delete m i = m := by + intro h + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_delete_same, h] + · simp [get?_delete_ne _ _ _ hij] + +/-- Corresponds to Rocq's `insert_id`. -/ +theorem insert_get?' (m : M V) (i : K) (x : V) : + get? m i = some x → insert m i x = m := by + intro h + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [get?_insert_same, h] + · simp [get?_insert_ne _ _ _ _ hij] + +omit [DecidableEq K] [FiniteMapLaws K M] in +/-- Corresponds to Rocq's `insert_empty`. -/ +theorem insert_empty (i : K) (x : V) : + insert (∅ : M V) i x = {[i := x]} := by + rfl + +/-- Corresponds to Rocq's `insert_non_empty`. -/ +theorem insert_ne_empty (m : M V) (i : K) (x : V) : + insert m i x ≠ ∅ := by + intro h + have := eq_empty_iff (insert m i x) |>.mp h i + simp [get?_insert_same] at this + +/-- Corresponds to Rocq's `delete_subseteq`. -/ +theorem delete_subset_self (m : M V) (i : K) : delete m i ⊆ m := by + intro k v h + by_cases hik : i = k + · subst hik + simp [get?_delete_same] at h + · simp [get?_delete_ne _ _ _ hik] at h + exact h + +/-- Corresponds to Rocq's `delete_subset`. -/ +theorem delete_subset_of_mem (m : M V) (i : K) (v : V) : + get? m i = some v → delete m i ⊆ m ∧ delete m i ≠ m := by + intro hi + constructor + · exact delete_subset_self m i + · intro heq + have : get? (delete m i) i = get? m i := by rw [heq] + simp [get?_delete_same, hi] at this + +/-- Corresponds to Rocq's `insert_subseteq`. -/ +theorem subset_insert (m : M V) (i : K) (x : V) : + get? m i = none → m ⊆ insert m i x := by + intro hi k v hk + by_cases hik : i = k + · subst hik + simp [hi] at hk + · simp [get?_insert_ne _ _ _ _ hik, hk] + +/-- Corresponds to Rocq's `insert_subset`. -/ +theorem subset_insert_of_not_mem (m : M V) (i : K) (x : V) : + get? m i = none → m ⊆ insert m i x ∧ m ≠ insert m i x := by + intro hi + constructor + · exact subset_insert m i x hi + · intro heq + have h2 : get? (insert m i x) i = some x := get?_insert_same m i x + rw [← heq] at h2 + rw [hi] at h2 + exact Option.noConfusion h2 + +/-- Corresponds to Rocq's `delete_mono`. -/ +theorem delete_subset_delete (m₁ m₂ : M V) (i : K) : + m₁ ⊆ m₂ → delete m₁ i ⊆ delete m₂ i := by + intro hsub k v hk + by_cases hik : i = k + · subst hik + simp [get?_delete_same] at hk + · simp [get?_delete_ne _ _ _ hik] at hk ⊢ + exact hsub k v hk + +/-- Corresponds to Rocq's `insert_mono`. -/ +theorem insert_subset_insert (m₁ m₂ : M V) (i : K) (x : V) : + m₁ ⊆ m₂ → insert m₁ i x ⊆ insert m₂ i x := by + intro hsub k v hk + by_cases hik : i = k + · subst hik + simp [get?_insert_same] at hk ⊢ + exact hk + · simp [get?_insert_ne _ _ _ _ hik] at hk ⊢ + exact hsub k v hk + +/-- Corresponds to Rocq's `map_non_empty_singleton`. -/ +theorem singleton_ne_empty (i : K) (x : V) : + {[i := x]} ≠ (∅ : M V) := by + exact insert_ne_empty ∅ i x + +/-- Corresponds to Rocq's `delete_singleton_eq`. -/ +theorem delete_singleton_same (i : K) (x : V) : + delete ({[i := x]} : M V) i = ∅ := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro j + simp [FiniteMap.singleton, get?_delete, get?_insert, get?_empty] + +/-- Corresponds to Rocq's `delete_singleton_ne`. -/ +theorem delete_singleton_of_ne (i j : K) (x : V) : + i ≠ j → delete ({[j := x]} : M V) i = {[j := x]} := by + intro hij + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + simp [FiniteMap.singleton, get?_delete, get?_insert, get?_empty] + intro hik + intro hjk + subst hik hjk + exact hij rfl + +/-- Corresponds to Rocq's `map_Forall_to_list`. -/ +theorem forall_iff_toList (P : K → V → Prop) (m : M V) : + FiniteMap.Forall P m ↔ ∀ kv ∈ toList m, P kv.1 kv.2 := by + constructor + · intro hfa kv hmem + have := (mem_toList m kv.1 kv.2).mp hmem + exact hfa kv.1 kv.2 this + · intro hlist k v hget + have := (mem_toList m k v).mpr hget + exact hlist (k, v) this + +/-- Corresponds to Rocq's `map_Forall_empty`. -/ +theorem forall_empty (P : K → V → Prop) : FiniteMap.Forall P (∅ : M V) := by + intro k v h + simp [get?_empty] at h + +omit [DecidableEq K] [FiniteMapLaws K M] in +/-- Corresponds to Rocq's `map_Forall_impl`. -/ +theorem forall_mono (P Q : K → V → Prop) (m : M V) : + FiniteMap.Forall P m → (∀ k v, P k v → Q k v) → FiniteMap.Forall Q m := by + intro hp himpl k v hget + exact himpl k v (hp k v hget) + +/-- Corresponds to Rocq's `map_Forall_insert_1_1`. -/ +theorem forall_insert_of_forall (P : K → V → Prop) (m : M V) (i : K) (x : V) : + FiniteMap.Forall P (insert m i x) → P i x := by + intro hfa + exact hfa i x (get?_insert_same m i x) + +/-- Corresponds to Rocq's `map_Forall_insert_1_2`. -/ +theorem forall_of_forall_insert (P : K → V → Prop) (m : M V) (i : K) (x : V) : + get? m i = none → FiniteMap.Forall P (insert m i x) → FiniteMap.Forall P m := by + intro hi hfa k v hget + by_cases hik : i = k + · subst hik + simp [hi] at hget + · have : get? (insert m i x) k = some v := by + simp [get?_insert_ne _ _ _ _ hik, hget] + exact hfa k v this + +/-- Corresponds to Rocq's `map_Forall_insert_2`. -/ +theorem forall_insert (P : K → V → Prop) (m : M V) (i : K) (x : V) : + P i x → FiniteMap.Forall P m → FiniteMap.Forall P (insert m i x) := by + intro hpix hfa k v hget + by_cases hik : i = k + · subst hik + simp [get?_insert_same] at hget + rw [← hget] + exact hpix + · simp [get?_insert_ne _ _ _ _ hik] at hget + exact hfa k v hget + +/-- Corresponds to Rocq's `map_Forall_insert`. -/ +theorem forall_insert_iff (P : K → V → Prop) (m : M V) (i : K) (x : V) : + get? m i = none → (FiniteMap.Forall P (insert m i x) ↔ P i x ∧ FiniteMap.Forall P m) := by + intro hi + constructor + · intro hfa + exact ⟨forall_insert_of_forall P m i x hfa, forall_of_forall_insert P m i x hi hfa⟩ + · intro ⟨hpix, hfa⟩ + exact forall_insert P m i x hpix hfa + +/-- Corresponds to Rocq's `map_Forall_singleton`. -/ +theorem forall_singleton (P : K → V → Prop) (i : K) (x : V) : + FiniteMap.Forall P ({[i := x]} : M V) ↔ P i x := by + constructor + · intro hfa + exact hfa i x (get?_singleton_same i x) + · intro hpix k v hget + simp [get?_singleton] at hget + obtain ⟨rfl, rfl⟩ := hget + exact hpix + +/-- Corresponds to Rocq's `map_Forall_delete`. -/ +theorem forall_delete (P : K → V → Prop) (m : M V) (i : K) : + FiniteMap.Forall P m → FiniteMap.Forall P (delete m i) := by + intro hfa k v hget + by_cases hik : i = k + · subst hik + simp [get?_delete_same] at hget + · simp [get?_delete_ne _ _ _ hik] at hget + exact hfa k v hget + +omit [DecidableEq K] [FiniteMapLaws K M] in +/-- Corresponds to Rocq's `map_disjoint_spec`. -/ +theorem disjoint_iff (m₁ m₂ : M V) : + m₁ ##ₘ m₂ ↔ ∀ k, get? m₁ k = none ∨ get? m₂ k = none := by + constructor + · intro hdisj k + by_cases h1 : (get? m₁ k).isSome + · by_cases h2 : (get? m₂ k).isSome + · exact absurd ⟨h1, h2⟩ (hdisj k) + · simp only [Option.not_isSome_iff_eq_none] at h2 + exact Or.inr h2 + · simp only [Option.not_isSome_iff_eq_none] at h1 + exact Or.inl h1 + · intro h k ⟨hs1, hs2⟩ + cases h k with + | inl h1 => simp [h1] at hs1 + | inr h2 => simp [h2] at hs2 + +/-- Corresponds to Rocq's `map_disjoint_insert_l`. -/ +theorem disjoint_insert_left (m₁ m₂ : M V) (i : K) (x : V) : + get? m₂ i = none → + m₁ ##ₘ m₂ → + insert m₁ i x ##ₘ m₂ := by + intro hi hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs2 + · simp [get?_insert_ne _ _ _ _ hik] at hs1 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Corresponds to Rocq's `map_disjoint_insert_r`. -/ +theorem disjoint_insert_right (m₁ m₂ : M V) (i : K) (x : V) : + get? m₁ i = none → + m₁ ##ₘ m₂ → + m₁ ##ₘ insert m₂ i x := by + intro hi hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs1 + · simp [get?_insert_ne _ _ _ _ hik] at hs2 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Corresponds to Rocq's `map_disjoint_delete_l`. -/ +theorem disjoint_delete_left (m₁ m₂ : M V) (i : K) : + m₁ ##ₘ m₂ → delete m₁ i ##ₘ m₂ := by + intro hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [get?_delete_same] at hs1 + · simp [get?_delete_ne _ _ _ hik] at hs1 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Corresponds to Rocq's `map_disjoint_delete_r`. -/ +theorem disjoint_delete_right (m₁ m₂ : M V) (i : K) : + m₁ ##ₘ m₂ → m₁ ##ₘ delete m₂ i := by + intro hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [get?_delete_same] at hs2 + · simp [get?_delete_ne _ _ _ hik] at hs2 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Corresponds to Rocq's `map_disjoint_singleton_l`. -/ +theorem disjoint_singleton_left (m : M V) (i : K) (x : V) : + get? m i = none → {[i := x]} ##ₘ m := by + intro hi k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs2 + · simp [FiniteMap.singleton, get?_insert_ne _ _ _ _ hik, get?_empty] at hs1 + +/-- Corresponds to Rocq's `map_disjoint_singleton_r`. -/ +theorem disjoint_singleton_right (m : M V) (i : K) (x : V) : + get? m i = none → m ##ₘ {[i := x]} := by + intro hi k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs1 + · simp [FiniteMap.singleton, get?_insert_ne _ _ _ _ hik, get?_empty] at hs2 + +/-- toList of map (fmap) is a permutation of mapping over toList. -/ +theorem toList_map [DecidableEq V'] : ∀ (m : M V) (f : V → V'), + (toList (FiniteMap.map f m)).Perm + ((toList m).map (fun kv => (kv.1, f kv.2))) := by + intro m f + simp only [FiniteMap.map] + apply toList_ofList + simp only [List.map_map] + show ((toList m).map (fun x => x.1)).Nodup + exact nodup_toList_keys m + +/-- Lookup in a mapped map. -/ +theorem get?_map [DecidableEq V] {V' : Type _} [DecidableEq V'] (f : V → V') (m : M V) (k : K) : + get? (FiniteMap.map f m) k = (get? m k).map f := by + simp only [FiniteMap.map] + by_cases h : ∃ v, get? m k = some v + · obtain ⟨v, hv⟩ := h + have hmem : (k, v) ∈ toList m := (mem_toList m k v).mpr hv + have hmem' : (k, f v) ∈ (toList m).map (fun (ki, vi) => (ki, f vi)) := by + rw [List.mem_map] + exact ⟨(k, v), hmem, rfl⟩ + have hnodup : ((toList m).map (fun (ki, vi) => (ki, f vi))).map Prod.fst |>.Nodup := by + simp only [List.map_map] + show ((toList m).map Prod.fst).Nodup + exact nodup_toList_keys m + have := (mem_ofList (M := M) _ k (f v) hnodup).mp hmem' + simp [hv, this] + · have hk : get? m k = none := by + cases hm : get? m k + · rfl + · exfalso; apply h; exact ⟨_, hm⟩ + simp [hk] + cases h' : get? (ofList ((toList m).map (fun (ki, vi) => (ki, f vi))) : M V') k + · rfl + · rename_i v' + have hnodup : ((toList m).map (fun (ki, vi) => (ki, f vi))).map Prod.fst |>.Nodup := by + simp only [List.map_map] + show ((toList m).map Prod.fst).Nodup + exact nodup_toList_keys m + have hmem : (k, v') ∈ (toList m).map (fun (ki, vi) => (ki, f vi)) := + (mem_ofList (M := M) (V := V') _ k v' hnodup).mpr h' + rw [List.mem_map] at hmem + obtain ⟨⟨k', v''⟩, hmem', heq⟩ := hmem + simp at heq + cases heq + rename_i heq_k heq_v + have : get? m k' = some v'' := (mem_toList m k' v'').mp hmem' + rw [heq_k, hk] at this + cases this + +omit [DecidableEq K] in +/-- filterMap preserves Nodup on keys. -/ +private theorem nodup_map_fst_filterMap + (l : List (K × V)) (g : K → V → Option (K × V')) : + (l.map Prod.fst).Nodup → + (∀ ki vi k' v', g ki vi = some (k', v') → k' = ki) → + ((l.filterMap (fun (ki, vi) => g ki vi)).map Prod.fst).Nodup := by + intro h_nodup h_preserve_key + have aux : ∀ (k_target : K) (l' : List (K × V)), + k_target ∈ (l'.filterMap (fun (ki, vi) => g ki vi)).map Prod.fst → + k_target ∈ l'.map Prod.fst := by + intro k_target l' + induction l' with + | nil => simp + | cons kv' tail' ih_aux => + obtain ⟨k'', v''⟩ := kv' + intro hmem_filter + simp only [List.filterMap] at hmem_filter + cases hg' : g k'' v'' with + | none => + simp only [hg'] at hmem_filter + exact List.mem_cons_of_mem k'' (ih_aux hmem_filter) + | some res' => + obtain ⟨k''', v'''⟩ := res' + have : k''' = k'' := h_preserve_key k'' v'' k''' v''' hg' + subst this + simp only [hg', List.map_cons, List.mem_cons] at hmem_filter + rw [List.map_cons, List.mem_cons] + cases hmem_filter with + | inl heq => left; exact heq + | inr hmem' => right; exact ih_aux hmem' + induction l with + | nil => simp + | cons kv tail ih => + obtain ⟨k, v⟩ := kv + rw [List.map_cons, List.nodup_cons] at h_nodup + simp only [List.filterMap] + cases hg : g k v with + | none => + exact ih h_nodup.2 + | some res => + obtain ⟨k', v'⟩ := res + have hk_eq : k' = k := h_preserve_key k v k' v' hg + rw [List.map_cons, List.nodup_cons] + constructor + · intro hmem + rw [hk_eq] at hmem + apply h_nodup.1 + exact aux k tail hmem + · exact ih h_nodup.2 + +/-- Lookup in zipWith. -/ +theorem get?_zipWith [DecidableEq V] [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (m1 : M V) (m2 : M V') (k : K) : + get? (FiniteMap.zipWith f m1 m2) k = + match get? m1 k, get? m2 k with + | some v1, some v2 => some (f v1 v2) + | _, _ => none := by + simp only [FiniteMap.zipWith] + cases h1 : get? m1 k + · simp + cases h' : get? (ofList ((toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none)) : M V'') k + · rfl + · rename_i v_result + have hnodup : ((toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none)).map Prod.fst |>.Nodup := by + refine nodup_map_fst_filterMap (V' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (nodup_toList_keys m1) ?_ + intros ki vi k' v' heq + cases heq' : get? m2 ki <;> simp [heq'] at heq + obtain ⟨rfl, _⟩ := heq + rfl + have hmem : (k, v_result) ∈ (toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) := + (mem_ofList (M := M) (V := V'') _ k v_result hnodup).mpr h' + rw [List.mem_filterMap] at hmem + obtain ⟨⟨k', v1'⟩, hmem1, hmatch⟩ := hmem + simp at hmatch + cases hm2 : get? m2 k' <;> simp [hm2] at hmatch + · obtain ⟨heq_k, _⟩ := hmatch + have : get? m1 k' = some v1' := (mem_toList m1 k' v1').mp hmem1 + rw [heq_k, h1] at this + cases this + · rename_i v1 + cases h2 : get? m2 k + · simp + cases h' : get? (ofList ((toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none)) : M V'') k + · rfl + · rename_i v_result + have hnodup : ((toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none)).map Prod.fst |>.Nodup := by + refine nodup_map_fst_filterMap (V' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (nodup_toList_keys m1) ?_ + intros ki vi k' v' heq + cases heq' : get? m2 ki <;> simp [heq'] at heq + obtain ⟨rfl, _⟩ := heq + rfl + have hmem : (k, v_result) ∈ (toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) := + (mem_ofList (M := M) (V := V'') _ k v_result hnodup).mpr h' + rw [List.mem_filterMap] at hmem + obtain ⟨⟨k', v1'⟩, hmem1, hmatch⟩ := hmem + simp at hmatch + cases hm2 : get? m2 k' <;> simp [hm2] at hmatch + · obtain ⟨heq_k, _⟩ := hmatch + rw [heq_k, h2] at hm2 + cases hm2 + · rename_i v2 + simp + have hmem1 : (k, v1) ∈ toList m1 := (mem_toList m1 k v1).mpr h1 + have hmem_filter : (k, f v1 v2) ∈ (toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) := by + rw [List.mem_filterMap] + refine ⟨(k, v1), hmem1, ?_⟩ + simp [h2] + have hnodup : ((toList m1).filterMap (fun (ki, vi) => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none)).map Prod.fst |>.Nodup := by + refine nodup_map_fst_filterMap (V' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (nodup_toList_keys m1) ?_ + intros ki vi k' v' heq + cases heq' : get? m2 ki <;> simp [heq'] at heq + obtain ⟨rfl, _⟩ := heq + rfl + exact (mem_ofList (M := M) _ k (f v1 v2) hnodup).mp hmem_filter + +/-- Corresponds to Rocq's `map_fmap_zip_with_r`. -/ +theorem map_zipWith_right [DecidableEq V] {V' V'' : Type _} [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (g1 : V'' → V) (m1 : M V) (m2 : M V') + (hg1 : ∀ x y, g1 (f x y) = x) + (hdom : ∀ k, (get? m1 k).isSome ↔ (get? m2 k).isSome) : + FiniteMap.map g1 (FiniteMap.zipWith f m1 m2) = m1 := by + apply ext + intro k + rw [get?_map, get?_zipWith] + cases h1 : get? m1 k with + | none => simp + | some x => + have h2 : (get? m2 k).isSome = true := (hdom k).mp (by simp [h1]) + cases h2' : get? m2 k with + | none => simp [h2'] at h2 + | some y => + simp [hg1] + +/-- Corresponds to Rocq's `map_fmap_zip_with_l`. -/ +theorem map_zipWith_left [DecidableEq V] [DecidableEq V'] {V'' : Type _} [DecidableEq V''] + (f : V → V' → V'') (g2 : V'' → V') (m1 : M V) (m2 : M V') + (hg2 : ∀ x y, g2 (f x y) = y) + (hdom : ∀ k, (get? m1 k).isSome ↔ (get? m2 k).isSome) : + FiniteMap.map g2 (FiniteMap.zipWith f m1 m2) = m2 := by + apply ext + intro k + rw [get?_map, get?_zipWith] + cases h2 : get? m2 k with + | none => simp + | some y => + have h1 : (get? m1 k).isSome = true := (hdom k).mpr (by simp [h2]) + cases h1' : get? m1 k with + | none => simp [h1'] at h1 + | some x => + simp [hg2] + +/-- Insert distributes over zipWith. -/ +theorem zipWith_insert [DecidableEq V] [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (m1 : M V) (m2 : M V') (i : K) (x : V) (y : V') : + FiniteMap.zipWith f (insert m1 i x) (insert m2 i y) = + insert (FiniteMap.zipWith f m1 m2) i (f x y) := by + apply ext + intro k + by_cases h : k = i + · subst h + simp only [get?_insert_same, get?_zipWith] + · have h' : i ≠ k := Ne.symm h + simp only [get?_zipWith, get?_insert_ne _ i k _ h'] + +/-- Corresponds to Rocq's `map_delete_zip_with`. -/ +theorem zipWith_delete [DecidableEq V] [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (m1 : M V) (m2 : M V') (i : K) : + FiniteMap.zipWith f (delete m1 i) (delete m2 i) = + delete (FiniteMap.zipWith f m1 m2) i := by + apply ext + intro k + by_cases h : k = i + · subst h + simp only [get?_delete_same, get?_zipWith] + · have h' : i ≠ k := Ne.symm h + simp only [get?_zipWith, get?_delete_ne _ i k h'] + +theorem zipWith_comm [DecidableEq V] [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (m1 : M V) (m2 : M V') : + FiniteMap.zipWith (fun x y => f y x) m2 m1 = FiniteMap.zipWith f m1 m2 := by + apply ext + intro k + rw [get?_zipWith, get?_zipWith] + cases get? m1 k <;> cases get? m2 k <;> simp + +/-- Corresponds to Rocq's `map_zip_with_flip`. -/ +theorem zip_comm [DecidableEq V] [DecidableEq V'] + (m1 : M V) (m2 : M V') : + FiniteMap.zip m2 m1 = FiniteMap.map Prod.swap (FiniteMap.zip m1 m2) := by + apply ext + intro k + unfold FiniteMap.zip + rw [get?_map, get?_zipWith, get?_zipWith] + cases get? m1 k <;> cases get? m2 k <;> simp [Prod.swap] + +/-- Mapping with id is identity. + Corresponds to Rocq's `map_id`. -/ +theorem map_id [DecidableEq V] (m : M V) : + FiniteMap.map id m = m := by + apply ext + intro k + rw [get?_map] + cases get? m k <;> simp + +/-- Mapping over a zip is the same as zipping the mapped maps. + Corresponds to Rocq's `map_fmap_zip`. -/ +theorem zip_map [DecidableEq V] [DecidableEq V'] {V'' V''' : Type _} [DecidableEq V''] [DecidableEq V'''] + (f : V → V'') (g : V' → V''') (m1 : M V) (m2 : M V') : + FiniteMap.zip (FiniteMap.map f m1) (FiniteMap.map g m2) = + FiniteMap.map (fun (x, y) => (f x, g y)) (FiniteMap.zip m1 m2) := by + apply ext + intro k + unfold FiniteMap.zip + rw [get?_zipWith, get?_map, get?_map, get?_map, get?_zipWith] + cases h1 : get? m1 k <;> cases h2 : get? m2 k <;> simp + +/-- Zipping fst and snd projections of a map recovers the original map. + Corresponds to Rocq's `map_zip_fst_snd`. -/ +theorem zip_fst_snd {V' : Type u'} [DecidableEq V] [DecidableEq V'] (m : M (V × V')) : + FiniteMap.zip (FiniteMap.map Prod.fst m) (FiniteMap.map Prod.snd m) = m := by + apply ext + intro k + unfold FiniteMap.zip + rw [get?_zipWith, get?_map, get?_map] + cases h : get? m k with + | none => simp + | some p => cases p with | mk v1 v2 => simp + +/-- Corresponds to part of Rocq's dom lemmas for zip. -/ +theorem isSome_zipWith [DecidableEq V] [DecidableEq V'] [DecidableEq V''] + (f : V → V' → V'') (m1 : M V) (m2 : M V') (k : K) : + (get? (FiniteMap.zipWith f m1 m2) k).isSome ↔ + (get? m1 k).isSome ∧ (get? m2 k).isSome := by + rw [get?_zipWith] + cases get? m1 k <;> cases get? m2 k <;> simp [Option.isSome_some, Option.isSome_none] + +/-- Zipping two empty maps yields an empty map. + Corresponds to Rocq's `map_zip_empty`. -/ +theorem zip_empty [DecidableEq V] [DecidableEq V'] : + FiniteMap.zip (∅ : M V) (∅ : M V') = ∅ := by + apply ext + intro k + unfold FiniteMap.zip + rw [get?_zipWith, get?_empty, get?_empty, get?_empty] + +/-- Lookup in a zipped map. + Corresponds to Rocq's `lookup_zip_with` specialized to `zip`. -/ +theorem get?_zip [DecidableEq V] [DecidableEq V'] (m1 : M V) (m2 : M V') (k : K) : + get? (FiniteMap.zip m1 m2) k = + match get? m1 k, get? m2 k with + | some v1, some v2 => some (v1, v2) + | _, _ => none := by + unfold FiniteMap.zip + rw [get?_zipWith] + +/-- Insert distributes over zip. + Corresponds to Rocq's `map_zip_insert`. -/ +theorem zip_insert [DecidableEq V] [DecidableEq V'] + (m1 : M V) (m2 : M V') (i : K) (x : V) (y : V') : + get? m1 i = none → get? m2 i = none → + FiniteMap.zip (insert m1 i x) (insert m2 i y) = + insert (FiniteMap.zip m1 m2) i (x, y) := by + intro h1 h2 + unfold FiniteMap.zip + exact zipWith_insert Prod.mk m1 m2 i x y + +/-- Delete distributes over zip. + Corresponds to Rocq's `map_zip_delete`. -/ +theorem zip_delete [DecidableEq V] [DecidableEq V'] + (m1 : M V) (m2 : M V') (i : K) : + FiniteMap.zip (delete m1 i) (delete m2 i) = + delete (FiniteMap.zip m1 m2) i := by + unfold FiniteMap.zip + exact zipWith_delete Prod.mk m1 m2 i + +/-- Domain of a zipped map. + Corresponds to part of Rocq's `elem_of_dom_2` for zip. -/ +theorem isSome_zip [DecidableEq V] [DecidableEq V'] (m1 : M V) (m2 : M V') (k : K) : + (get? (FiniteMap.zip m1 m2) k).isSome ↔ + (get? m1 k).isSome ∧ (get? m2 k).isSome := by + unfold FiniteMap.zip + exact isSome_zipWith Prod.mk m1 m2 k + +/-- toList of a zipped map. + Corresponds to Rocq's `map_to_list_zip`. -/ +theorem toList_zip [DecidableEq V] [DecidableEq V'] (m1 : M V) (m2 : M V') : + (toList (FiniteMap.zip m1 m2)).Perm + ((toList m1).filterMap (fun (k, v1) => + match get? m2 k with + | some v2 => some (k, (v1, v2)) + | none => none)) := by + unfold FiniteMap.zip + simp only [FiniteMap.zipWith] + apply toList_ofList + refine nodup_map_fst_filterMap (V' := V × V') (toList m1) + (fun ki vi => match get? m2 ki with | some v' => some (ki, (vi, v')) | none => none) + (nodup_toList_keys m1) ?_ + intro ki vi k' vp heq + cases heq' : get? m2 ki <;> simp [heq'] at heq + obtain ⟨rfl, _⟩ := heq + rfl + +/-- Corresponds to Rocq's `lookup_union_None`. -/ +theorem get?_union_none (m1 m2 : M V) (i : K) : + get? (m1 ∪ m2) i = none ↔ get? m1 i = none ∧ get? m2 i = none := by + rw [get?_union] + cases h1 : get? m1 i <;> cases h2 : get? m2 i <;> simp [Option.orElse] + +/-- Corresponds to Rocq's `insert_union_l`. -/ +theorem union_insert_left (m1 m2 : M V) (i : K) (x : V) : + get? (insert (m1 ∪ m2) i x) = get? (insert m1 i x ∪ m2) := by + funext k + by_cases hik : i = k + · subst hik + simp [get?_insert_same, get?_union] + · simp [get?_insert_ne _ _ _ _ hik, get?_union] + +end FiniteMapLaws + +namespace FiniteMap + +variable {K : Type v} {M : Type u → _} [FiniteMap K M] + +/-- Submap is reflexive. -/ +theorem subset_refl (m : M V) : m ⊆ m := fun _ _ h => h + +/-- Submap is transitive. -/ +theorem subset_trans {m₁ m₂ m₃ : M V} (h₁ : m₁ ⊆ m₂) (h₂ : m₂ ⊆ m₃) : m₁ ⊆ m₃ := + fun k v hm₁ => h₂ k v (h₁ k v hm₁) + +/-- Disjointness is symmetric. -/ +theorem disjoint_comm {m₁ m₂ : M V} (h : disjoint m₁ m₂) : disjoint m₂ m₁ := + fun k ⟨h₂, h₁⟩ => h k ⟨h₁, h₂⟩ + +theorem disjoint_empty_right [DecidableEq K] [FiniteMapLaws K M] (m : M V) : m ##ₘ (∅ : M V) := + disjoint_comm (FiniteMapLaws.disjoint_empty_left (K:= K) m) + +/-- `m₂` and `m₁ \ m₂` are disjoint. -/ +theorem disjoint_difference_right [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] + (m₁ m₂ : M V) : m₂ ##ₘ (m₁ \ m₂) := by + intro k ⟨h_in_m2, h_in_diff⟩ + rw [FiniteMapLaws.get?_difference] at h_in_diff + simp only [h_in_m2, ↓reduceIte, Option.isSome_none, Bool.false_eq_true] at h_in_diff + +/-- Corresponds to Rocq's `map_difference_union`. -/ +theorem union_difference_cancel [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] + (m₁ m₂ : M V) (hsub : m₂ ⊆ m₁) : m₂ ∪ (m₁ \ m₂) = m₁ := by + apply FiniteMapLaws.ext (M := M) (K := K) (V := V) + intro k + rw [FiniteMapLaws.get?_union, FiniteMapLaws.get?_difference] + cases hm2 : get? m₂ k with + | none => + simp only [Option.isSome_none, Bool.false_eq_true, ↓reduceIte, Option.orElse_none] + | some v => + simp only [Option.isSome_some, ↓reduceIte, Option.orElse_some] + exact (hsub k v hm2).symm + +end FiniteMap + +end Iris.Std diff --git a/src/Iris/Std/GSet.lean b/src/Iris/Std/GSet.lean new file mode 100644 index 00000000..aa7e96c1 --- /dev/null +++ b/src/Iris/Std/GSet.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ + +import Iris.Std.Positive + +/-! # Finite Sets of Invariant Names + +Reference: `stdpp/theories/gset.v`, `iris/algebra/gset.v` + +Finite sets of invariant names, used to track which invariants are currently +disabled in world satisfaction (`ownD` tokens). The predicate-based representation +mirrors `CoPset` for uniformity, providing union, difference, disjointness, and +subset operations needed by the `GSetDisj` CMRA. + +## Main Definitions + +- `GSet` — set of invariant names (`Positive`), represented as a membership predicate +- `GSet.singleton` — singleton set `{[i]}` +- `GSet.union`, `GSet.empty` — set operations +- `GSet.Disjoint`, `GSet.Subset` — predicates +-/ + +namespace Iris + +/-! ## Definition -/ + +/-- Set of invariant names, used for disabled invariant tokens. -/ +structure GSet where + /-- Membership predicate. -/ + mem : Positive → Prop + +namespace GSet + +@[ext] +theorem ext {s₁ s₂ : GSet} (h : ∀ n, s₁.mem n ↔ s₂.mem n) : s₁ = s₂ := by + -- extensionality for predicate-based sets + cases s₁; cases s₂; simp only [mk.injEq] + exact funext fun n => propext (h n) + +/-! ## Constructors and Operations -/ + +def empty : GSet := by + -- empty set: always false + exact ⟨fun _ => False⟩ + +def singleton (n : Positive) : GSet := by + -- singleton membership + exact ⟨fun m => m = n⟩ + +def union (s₁ s₂ : GSet) : GSet := by + -- union membership via disjunction + exact ⟨fun n => s₁.mem n ∨ s₂.mem n⟩ + +def diff (s₁ s₂ : GSet) : GSet := by + -- set difference: left membership and not right membership + exact ⟨fun n => s₁.mem n ∧ ¬s₂.mem n⟩ + +instance : EmptyCollection GSet := ⟨empty⟩ +instance : Singleton Positive GSet := ⟨singleton⟩ +instance : Union GSet := ⟨union⟩ +instance : SDiff GSet := ⟨diff⟩ + +/-! ## Predicates -/ + +def Disjoint (s₁ s₂ : GSet) : Prop := by + -- disjointness means no shared element + exact ∀ n, ¬(s₁.mem n ∧ s₂.mem n) + +def Subset (s₁ s₂ : GSet) : Prop := by + -- subset means elementwise implication + exact ∀ n, s₁.mem n → s₂.mem n + +instance : HasSubset GSet := ⟨Subset⟩ + +noncomputable instance (s₁ s₂ : GSet) : Decidable (Disjoint s₁ s₂) := by + -- classical decidability for predicates + exact Classical.propDecidable _ + +/-! ## Simp Lemmas -/ + +@[simp] theorem mem_empty (n : Positive) : (∅ : GSet).mem n ↔ False := by + -- unfold empty membership + rfl + +@[simp] theorem mem_singleton (n m : Positive) : ({m} : GSet).mem n ↔ n = m := by + -- unfold singleton membership + rfl + +@[simp] theorem mem_union (s₁ s₂ : GSet) (n : Positive) : + (s₁ ∪ s₂).mem n ↔ s₁.mem n ∨ s₂.mem n := by + -- unfold union membership + rfl + +@[simp] theorem mem_diff (s₁ s₂ : GSet) (n : Positive) : + (s₁ \ s₂).mem n ↔ s₁.mem n ∧ ¬s₂.mem n := by + -- unfold difference membership + rfl + +/-! ## Set Algebra Laws -/ + +theorem union_assoc (s₁ s₂ s₃ : GSet) : s₁ ∪ s₂ ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) := by + -- associativity of union via propositional associativity + ext n; simp [or_assoc] + +theorem union_comm (s₁ s₂ : GSet) : s₁ ∪ s₂ = s₂ ∪ s₁ := by + -- commutativity of union via propositional commutativity + ext n; simp [or_comm] + +theorem union_empty (s : GSet) : s ∪ ∅ = s := by + -- right identity of union + ext n; simp + +theorem empty_union (s : GSet) : ∅ ∪ s = s := by + -- left identity of union + ext n; simp + +theorem union_idem (s : GSet) : s ∪ s = s := by + -- idempotence of union + ext n; simp [or_self] + +/-! ## Disjointness and Subset -/ + +theorem disjoint_comm {s₁ s₂ : GSet} : Disjoint s₁ s₂ ↔ Disjoint s₂ s₁ := by + -- symmetry by swapping conjuncts + refine ⟨?_, ?_⟩ + · intro h n hn + exact h n ⟨hn.2, hn.1⟩ + · intro h n hn + exact h n ⟨hn.2, hn.1⟩ + +theorem disjoint_empty_right (s : GSet) : Disjoint s ∅ := by + -- no element can be in an empty set + intro _ hn; exact hn.2 + +theorem disjoint_empty_left (s : GSet) : Disjoint ∅ s := by + -- no element can be in an empty set + intro _ hn; exact hn.1 + +/-- Any subset can be decomposed as a disjoint union with the set difference. -/ +theorem subseteq_disjoint_union {s₁ s₂ : GSet} (h : s₁ ⊆ s₂) : + ∃ s₃, s₂ = s₁ ∪ s₃ ∧ Disjoint s₁ s₃ := by + -- choose the set difference as a disjoint complement + refine ⟨s₂ \ s₁, ?_, ?_⟩ + · ext n; simp; constructor + · intro hn + by_cases h₁ : s₁.mem n + · exact Or.inl h₁ + · exact Or.inr ⟨hn, h₁⟩ + · rintro (h₁ | ⟨h₂, _⟩) + · exact h _ h₁ + · exact h₂ + · exact fun _ ⟨h₁, _, h₃⟩ => h₃ h₁ + +end GSet + +end Iris diff --git a/src/Iris/Std/List.lean b/src/Iris/Std/List.lean new file mode 100644 index 00000000..35500711 --- /dev/null +++ b/src/Iris/Std/List.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ + +/-! +# List Lemmas + +This file contains list theory lemmas that are standard properties +not available in Lean core. +-/ + +namespace Iris.Std.List + +/-- List equivalence relation parameterized by an element equivalence relation. + Corresponds to Rocq's `list_equiv`. -/ +inductive Equiv {α : Type _} (R : α → α → Prop) : List α → List α → Prop where + | nil : Equiv R [] [] + | cons {x y : α} {l k : List α} : R x y → Equiv R l k → Equiv R (x :: l) (y :: k) + +def zipIdxInt {α : Type _} (l : List α) (n : Int) : List (α × Int) := + l.mapIdx (fun i v => (v, (i : Int) + n)) + +/-- For a Nodup list, erasing an element removes it completely. -/ +theorem not_mem_erase_self_of_nodup {α : Type _} [DecidableEq α] (x : α) (l : List α) + (hnd : l.Nodup) : x ∉ l.erase x := by + induction l with + | nil => exact List.not_mem_nil + | cons y ys ih => + simp only [List.erase_cons] + rw [List.nodup_cons] at hnd + split + · next h => + have heq : y = x := eq_of_beq h + rw [← heq] + exact hnd.1 + · next h => + simp only [List.mem_cons] + intro hor + cases hor with + | inl heq => + have : (y == x) = true := beq_iff_eq.mpr heq.symm + exact absurd this h + | inr hmem => exact ih hnd.2 hmem + +/-- Two Nodup lists with the same membership are permutations of each other. + Corresponds to Rocq's `NoDup_Permutation`. -/ +theorem perm_of_nodup_of_mem_iff {α : Type _} [DecidableEq α] + {l₁ l₂ : List α} (hnd₁ : l₁.Nodup) (hnd₂ : l₂.Nodup) + (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) : l₁.Perm l₂ := by + induction l₁ generalizing l₂ with + | nil => + cases l₂ with + | nil => exact List.Perm.refl [] + | cons y ys => + have : y ∈ ([] : List α) := (hmem y).mpr List.mem_cons_self + exact absurd this List.not_mem_nil + | cons x xs ih => + have hx_in_l₂ : x ∈ l₂ := (hmem x).mp List.mem_cons_self + have hperm₂ : l₂.Perm (x :: l₂.erase x) := List.perm_cons_erase hx_in_l₂ + rw [List.nodup_cons] at hnd₁ + have hx_notin_xs : x ∉ xs := hnd₁.1 + have hnd_xs : xs.Nodup := hnd₁.2 + have hnd_erase : (l₂.erase x).Nodup := hnd₂.erase x + have hmem_erase : ∀ y, y ∈ xs ↔ y ∈ l₂.erase x := by + intro y + constructor + · intro hy + have hne : y ≠ x := fun heq => hx_notin_xs (heq ▸ hy) + have hy_l₂ : y ∈ l₂ := (hmem y).mp (List.mem_cons_of_mem x hy) + exact (List.mem_erase_of_ne hne).mpr hy_l₂ + · intro hy + have hne : y ≠ x := by + intro heq + rw [heq] at hy + exact not_mem_erase_self_of_nodup x l₂ hnd₂ hy + have hy_l₂ : y ∈ l₂ := List.mem_of_mem_erase hy + have hy_l₁ : y ∈ x :: xs := (hmem y).mpr hy_l₂ + cases List.mem_cons.mp hy_l₁ with + | inl heq => exact absurd heq hne + | inr h => exact h + have hperm_xs : xs.Perm (l₂.erase x) := ih hnd_xs hnd_erase hmem_erase + exact (List.Perm.cons x hperm_xs).trans hperm₂.symm + + +theorem nodup_of_nodup_map_fst {α β : Type _} (l : List (α × β)) + (h : (l.map Prod.fst).Nodup) : l.Nodup := by + induction l with + | nil => exact List.nodup_nil + | cons x xs ih => + rw [List.nodup_cons] + constructor + · intro hx + rw [List.map_cons, List.nodup_cons] at h + have : x.1 ∈ xs.map Prod.fst := List.mem_map_of_mem (f := Prod.fst) hx + exact h.1 this + · rw [List.map_cons, List.nodup_cons] at h + exact ih h.2 + +end Iris.Std.List diff --git a/src/Iris/Std/Namespace.lean b/src/Iris/Std/Namespace.lean new file mode 100644 index 00000000..3c921e75 --- /dev/null +++ b/src/Iris/Std/Namespace.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ + +import Iris.Std.CoPset +import Iris.Std.DelabRule +import Init.Data.Char.Lemmas + +/-! # Namespaces for Invariants + +Reference: `stdpp/theories/namespaces.v` + +Invariants are organized into a hierarchical namespace tree. Each namespace maps +to a mask (`CoPset`) via `nclose`, which collects all invariant names that have +the namespace as a suffix. This gives two key properties: + +1. **Nesting**: extending a namespace (`ndot`) yields a subset of the parent mask, + so opening a child namespace leaves the parent's other children accessible. +2. **Disjointness**: sibling namespaces (same parent, different extension component) + produce disjoint masks, preventing conflicts when multiple invariants are open. + +## Main Definitions + +- `Namespace` — namespace type (list of encoded name components) +- `nroot` — root namespace (covers all names) +- `ndot` / `.@` — extend a namespace with a countable value +- `nclose` / `↑N` — map a namespace to its invariant mask +-/ + +namespace Iris +open Iris.Std + +/-! ## Countable Encodings -/ + +/-- A lightweight countable encoding into name components. -/ +class Countable (A : Type _) where + /-- Encode a value into a name component. -/ + encode : A → NameComponent + /-- Decode a name component back into a value. -/ + decode : NameComponent → Option A + /-- Decoding after encoding returns the original value. -/ + decode_encode : ∀ a, decode (encode a) = some a + +/-- Encode is injective thanks to the left inverse. -/ +theorem Countable.encode_inj {A : Type _} [Countable A] {x y : A} + (h : Countable.encode x = Countable.encode y) : x = y := by + -- apply decode to the equality and simplify + have h' := congrArg (Countable.decode (A := A)) h + simpa [Countable.decode_encode] using h' + +/-- `Nat` encodes as a singleton component. -/ +instance : Countable Nat where + encode n := [n] + decode xs := + -- singleton lists decode to their element + match xs with + | [n] => some n + | _ => none + decode_encode := by + -- decoding the singleton yields the original number + intro n; rfl + +/-- `String` encodes as a list of character codes. -/ +instance : Countable String where + encode s := + -- map characters to their numeric codes + s.toList.map Char.toNat + decode xs := + -- rebuild the string from character codes + some (String.ofList (xs.map Char.ofNat)) + decode_encode := by + -- mapping `Char.ofNat` after `Char.toNat` recovers the characters + intro s + -- reduce to the corresponding statement without `Option.some` + apply congrArg some + have hmap : List.map (Char.ofNat ∘ Char.toNat) s.toList = s.toList := by + -- map `ofNat ∘ toNat` collapses to the identity, by list induction + induction s.toList with + | nil => simp + | cons _ _ ih => + simp [ih] + -- combine the map identity with `String.ofList_toList` + calc + String.ofList (List.map Char.ofNat (List.map Char.toNat s.toList)) + = String.ofList (List.map (Char.ofNat ∘ Char.toNat) s.toList) := by + -- reassociate the nested map + simp [List.map_map] + _ = String.ofList s.toList := by + -- apply the map identity from `hmap` + simp [hmap] + _ = s := by + -- fold back to the original string + simp [String.ofList_toList] + +/-! ## Namespace Structure -/ + +/-- Namespaces are lists of name components. -/ +structure Namespace where + /-- Namespace components, ordered from most-specific to root. -/ + parts : List NameComponent + +/-- Root namespace (no components). -/ +def nroot : Namespace := by + -- empty namespace list + exact ⟨[]⟩ + +/-- Extend a namespace with a new component. -/ +def ndot {A : Type _} [Countable A] (N : Namespace) (x : A) : Namespace := by + -- cons the encoded component at the front + exact ⟨Countable.encode x :: N.parts⟩ + +/-- Map a namespace to its mask: all names with the namespace as a suffix. -/ +def nclose (N : Namespace) : CoPset := by + -- suffix predicate on lists of components + exact ⟨fun p => N.parts <:+ p⟩ + +instance : Coe Namespace CoPset := ⟨nclose⟩ + +/-! ## Notation -/ + +syntax term " .@ " term : term +macro_rules + | `($N .@ $x) => `(ndot $N $x) + +delab_rule nclose + | `($_ $N) => do + -- show namespace coercions as `↑N` + `(↑$N) + +/-! ## Namespace Lemmas -/ + +/-- Helper: dropping the prefix returns the suffix. -/ +private theorem drop_append_left {α : Type _} (t s : List α) : + List.drop t.length (t ++ s) = s := by + -- prove by induction on the prefix + induction t with + | nil => simp + | cons _ t ih => + simp [ih] + +/-- Helper: if `x::N` is a suffix of `p`, then `N` is also a suffix of `p`. -/ +private theorem suffix_tail {x : NameComponent} {N p : List NameComponent} + (h : x :: N <:+ p) : N <:+ p := by + -- extend the witness by one element + rcases h with ⟨t, rfl⟩ + refine ⟨t ++ [x], ?_⟩ + simp [List.append_assoc] + +/-- Helper: equal-length suffixes with the same tail have equal heads. -/ +private theorem suffix_cons_eq {x y : NameComponent} {N p : List NameComponent} + (hx : x :: N <:+ p) (hy : y :: N <:+ p) : x = y := by + -- unpack both suffix witnesses and compare the drop at equal lengths + rcases hx with ⟨t1, rfl⟩ + rcases hy with ⟨t2, h2⟩ + have hlen : t1.length = t2.length := by + -- lengths agree because the suffixes have equal length + have := congrArg List.length h2 + simp [List.length_append, List.length_cons] at this + exact this.symm + have hdrop := congrArg (List.drop t1.length) h2 + -- simplify both sides to the suffixes + simp [hlen] at hdrop + -- conclude by head equality + cases hdrop; rfl + +/-- The root namespace covers all names. -/ +theorem nclose_nroot : (↑nroot : CoPset) = (CoPset.top : CoPset) := by + -- suffix of the empty list is always true + ext p; constructor <;> intro _ + · trivial + · refine ⟨p, ?_⟩ + -- suffix witness by appending the empty list + simp [nroot] + +/-- Extending a namespace yields a subset of the original mask. -/ +theorem nclose_subseteq {A : Type _} [Countable A] (N : Namespace) (x : A) : + (↑(N .@ x) : CoPset) ⊆ ↑N := by + -- drop the added head from the suffix witness + intro p hp + exact suffix_tail hp + +/-- Subset transport for namespace masks. -/ +theorem nclose_subseteq' {A : Type _} [Countable A] {E : CoPset} (N : Namespace) (x : A) : + (↑N : CoPset) ⊆ E → (↑(N .@ x) : CoPset) ⊆ E := by + -- compose subset with `nclose_subseteq` + intro h + exact fun p hp => h _ (nclose_subseteq N x p hp) + +/-- Distinct components yield disjoint namespaces. -/ +theorem ndot_ne_disjoint {A : Type _} [Countable A] + (N : Namespace) {x y : A} (hxy : x ≠ y) : + CoPset.Disjoint (↑(N .@ x)) (↑(N .@ y)) := by + -- a shared suffix forces the head components to coincide + intro p hp + rcases hp with ⟨hx, hy⟩ + have hcomp : Countable.encode x = Countable.encode y := suffix_cons_eq hx hy + exact hxy (Countable.encode_inj hcomp) + +end Iris diff --git a/src/Iris/Std/Positive.lean b/src/Iris/Std/Positive.lean new file mode 100644 index 00000000..e320fcfe --- /dev/null +++ b/src/Iris/Std/Positive.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2026 Sam Hart. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sam Hart +-/ + +/-! # Positive Names + +Reference: `stdpp/theories/positive.v` + +Invariant names need a countable supply of identifiers that support suffix-based +namespace reasoning. Rather than using binary-encoded positive integers, we model +names as lists of encoded components, which makes the suffix structure (needed by +`Namespace` and `nclose`) directly available as list operations. + +## Main Definitions + +- `NameComponent` — encoded namespace components (lists of natural numbers) +- `Positive` — invariant names, represented as lists of components +-/ + +namespace Iris + +/-- Encoded namespace components. -/ +abbrev NameComponent := List Nat + +/-- Positive names, represented as lists of name components. -/ +abbrev Positive := List NameComponent + +end Iris