From e22d3eb4805d4dca27f75bd38ff7b0abcab5b6c1 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Sun, 14 Dec 2025 17:35:11 +0100 Subject: [PATCH 1/9] Monoid and BipOp in Algebra # Conflicts: # src/Iris/Algebra/CMRA.lean --- src/Iris/Algebra.lean | 1 + src/Iris/Algebra/BigOp.lean | 388 +++++++++++++++++++++++++++++++++++ src/Iris/Algebra/CMRA.lean | 7 + src/Iris/Algebra/Monoid.lean | 121 +++++++++++ 4 files changed, 517 insertions(+) create mode 100644 src/Iris/Algebra/BigOp.lean create mode 100644 src/Iris/Algebra/Monoid.lean diff --git a/src/Iris/Algebra.lean b/src/Iris/Algebra.lean index af74986d..8d63cdf4 100644 --- a/src/Iris/Algebra.lean +++ b/src/Iris/Algebra.lean @@ -1,4 +1,5 @@ import Iris.Algebra.Agree +import Iris.Algebra.BigOp import Iris.Algebra.CMRA import Iris.Algebra.COFESolver import Iris.Algebra.OFE diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean new file mode 100644 index 00000000..543f7ffe --- /dev/null +++ b/src/Iris/Algebra/BigOp.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2022 Lars König. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Lars König, Mario Carneiro, Zongyuan Liu +-/ +import Iris.Algebra.Monoid + +namespace Iris.Algebra + +/-! # Big Operators + +This file defines big operators (fold operations) over lists at the abstract OFE level. +These are parameterized by a monoid operation and include theorems about their properties. + +The key definitions are: +- `bigOpL`: Indexed fold over lists with index access +-/ + +open OFE + +/-! ## Big Operators -/ + +/-- Indexed fold over a list. The function `Φ` receives the index and element. +This is the generic version parameterized by the monoid operation and unit. -/ +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 u} {A : Type v} [OFE M] {op : M → M → M} {unit : M} [Monoid M op unit] + +/-! ### Basic lemmas -/ + +omit [OFE M] [Monoid M op unit] in +@[simp] theorem nil (Φ : Nat → A → M) : + bigOpL op unit Φ ([] : List A) = unit := rfl + +omit [OFE M] [Monoid M op unit] in +@[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 + +@[simp] theorem singleton (Φ : Nat → A → M) (x : A) : + bigOpL op unit Φ [x] ≡ Φ 0 x := by + simp only [cons, nil] + exact Monoid.op_right_id _ + +/-! ### Congruence lemmas -/ + +/-- Congruence for bigOpL: if Φ and Ψ are pointwise equivalent on the list, the results are equivalent. -/ +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) + +/-- Non-expansive version of congruence. -/ +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) + +/-- Simplified 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) + +/-! ### Append and snoc -/ + +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 + +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 + +/-! ### Unit lemma -/ + +/-- Big op over constant unit collapses to 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 + +/-! ### Distribution over op -/ + +/-- Distribution of big op over the monoid operation. -/ +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 + +/-! ### Map/fmap -/ + +/-- Big op over mapped list equals big op with composed function. -/ +theorem fmap {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))) + +/-! ### Closure under predicates -/ + +omit [OFE M] [Monoid M op unit] in +/-- Property `P` is preserved by big op if it holds for unit and is closed under `op`. -/ +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) + +/-! ### Permutation -/ + +/-- Big operators over commutative monoids are invariant under permutation. +Note: This uses definitional equality on elements, not the monoid equivalence. -/ +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 + +/-! ### Take and drop -/ + +/-- Split big op at position `n`. -/ +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 _) + +/-! ### Extensional equality -/ + +omit [OFE M] [Monoid M op unit] in +/-- Extensional equality (propositional, not just equivalence). -/ +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 + induction l generalizing Φ Ψ with + | nil => 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 := + fun i x hget => h (i + 1) x hget + rw [h0, ih htail] + +/-! ### FilterMap (omap) -/ + +/-- Big op over `filterMap` (called `omap` in Rocq). -/ +theorem filterMap {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 + +/-! ### Bind (flatMap) -/ + +/-- Big op over flattened list equals nested big op. -/ +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) + +/-! ### Sep zip -/ + +/-- 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 + induction l₁ generalizing l₂ Φ Ψ with + | nil => + cases l₂ with + | nil => simp only [List.zip_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.zip_cons_cons, cons] + exact Equiv.trans (Monoid.op_congr_r (ih (fun n => Φ (n + 1)) (fun n => Ψ (n + 1)) ys hlen)) Monoid.op_op_swap + +/-! ### Nested iterations commute -/ + +/-- Nested list iterations commute. -/ +theorem opL_opL {B : Type v} (Φ : Nat → A → Nat → B → M) (l₁ : List A) (l₂ : List B) : + bigOpL op unit (fun i x => bigOpL op unit (fun j y => Φ i x j y) l₂) l₁ ≡ + bigOpL op unit (fun j y => bigOpL op unit (fun i x => Φ i x j y) l₁) l₂ := by + induction l₁ generalizing Φ with + | nil => simp only [nil]; exact Equiv.symm (unit_const _) + | cons x xs ih => + simp only [cons] + exact Equiv.trans (Monoid.op_congr_r (ih _)) (Equiv.symm (op_distr _ _ _)) + +/-! ### Generic proper across two lists -/ + +omit [OFE M] [Monoid M op unit] in +/-- Generic proper lemma across two potentially different lists. + If the relation R holds for unit, is proper for op, and holds pointwise + between elements at matching indices, then R holds for the big ops. -/ +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) + +/-! ### Zip with sequence -/ + +/-- Big op over zip with a shifted sequence. -/ +theorem zip_seq (Φ : Nat × A → M) (n : Nat) (l : List A) : + bigOpL op unit (fun _ => Φ) ((List.range' n l.length).zip l) ≡ + bigOpL op unit (fun i x => Φ (n + i, x)) l := by + induction l generalizing n with + | nil => simp only [List.length_nil, List.range'_zero, List.zip_nil_left, nil]; exact Equiv.rfl + | cons x xs ih => + simp only [List.length_cons, List.range'_succ, List.zip_cons_cons, 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 + +/-- Big op over zip with a sequence starting at 0. -/ +theorem zip_with_range (Φ : Nat × A → M) (l : List A) : + bigOpL op unit (fun _ => Φ) ((List.range l.length).zip l) ≡ + bigOpL op unit (fun i x => Φ (i, x)) l := by + have h := @zip_seq M A _ op unit _ Φ 0 l + simp only [Nat.zero_add] at h + have heq : List.range l.length = List.range' 0 l.length := List.range_eq_range' (n := l.length) + rw [heq] + exact h + +/-! ### Sep zip with custom zip function -/ + +/-- Generalized version of `sep_zip` with custom zip function. -/ +theorem sep_zip_with {B C : Type v} + (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 + +/-! ### Homomorphism lemmas -/ + +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] + -- Goal: R (f (op₁ (Φ 0 x) unit₁)) (op₂ (f (Φ 0 x)) unit₂) + -- We have: op₁ (Φ 0 x) unit₁ ≡ Φ 0 x and op₂ (f (Φ 0 x)) unit₂ ≡ f (Φ 0 x) + -- So we use rel_proper to reduce to R (f (Φ 0 x)) (f (Φ 0 x)) which is rel_refl + 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 + +end Iris.Algebra diff --git a/src/Iris/Algebra/CMRA.lean b/src/Iris/Algebra/CMRA.lean index 2b95c89d..2e53859a 100644 --- a/src/Iris/Algebra/CMRA.lean +++ b/src/Iris/Algebra/CMRA.lean @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Сухарик (@suhr), Markus de Medeiros -/ import Iris.Algebra.OFE +import Iris.Algebra.Monoid namespace Iris open OFE @@ -731,6 +732,12 @@ instance empty_cancelable : Cancelable (unit : α) where theorem _root_.Iris.OFE.Dist.to_incN {n} {x y : α} (H : x ≡{n}≡ y) : x ≼{n} y := ⟨unit, ((equiv_dist.mp unit_right_id n).trans H).symm⟩ +instance cmra_monoid : Algebra.Monoid α (@op α _) unit where + op_ne.ne := fun {_n} {_x₁ _x₂} hx {_y₁ _y₂} hy => Dist.op hx hy + op_assoc _ _ _ := assoc.symm + op_comm _ _ := comm + op_left_id _ := unit_left_id + end ucmra diff --git a/src/Iris/Algebra/Monoid.lean b/src/Iris/Algebra/Monoid.lean new file mode 100644 index 00000000..0e961bf9 --- /dev/null +++ b/src/Iris/Algebra/Monoid.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2022 Lars König. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Lars König, Mario Carneiro, Zongyuan Liu +-/ +import Iris.Algebra.OFE + +namespace Iris.Algebra + +/-! # Monoids for Big Operators + +This file defines monoid structures for big operators, following the Iris/Rocq approach. + +The key design decisions (matching Rocq): +- `Monoid` contains the laws and requires an OFE structure +- The operation must be non-expansive (`NonExpansive₂`) +- We use explicit `op` and `unit` parameters to support multiple monoids on the same type + (e.g., on BIs we have monoids for `∗`/`emp`, `∧`/`True`, and `∨`/`False`) +-/ + +open OFE + +/-! ## Monoid Class -/ + +/-- A commutative monoid on an OFE, used for big operators. +The operation must be non-expansive, associative, commutative, and have a left identity. + +The operation `op` and unit `unit` are explicit parameters (not fields) to support +multiple monoids on the same type. -/ +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. +This is useful for connectives like `own` where we only have `True ==∗ own γ ∅`, +not `True ↔ own γ ∅`. -/ +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 From 2749f0f5251cc413cc7e2d32f9a88d57f96bf049 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Thu, 8 Jan 2026 13:52:39 +0100 Subject: [PATCH 2/9] BigOps --- src/Iris/Algebra.lean | 1 + src/Iris/Algebra/BigOp.lean | 4 +- src/Iris/Algebra/Monoid.lean | 4 +- src/Iris/BI.lean | 1 + src/Iris/BI/BI.lean | 6 +- src/Iris/BI/BIBase.lean | 13 - src/Iris/BI/BigOp/BigAndList.lean | 268 ++++ src/Iris/BI/BigOp/BigAndMap.lean | 538 +++++++ src/Iris/BI/BigOp/BigOp.lean | 159 ++ src/Iris/BI/BigOp/BigOrList.lean | 287 ++++ src/Iris/BI/BigOp/BigSepList.lean | 1646 ++++++++++++++++++++ src/Iris/BI/BigOp/BigSepMap.lean | 1294 +++++++++++++++ src/Iris/BI/BigOp/BigSepSet.lean | 949 +++++++++++ src/Iris/BI/BigOps.lean | 22 + src/Iris/BI/DerivedLaws.lean | 150 +- src/Iris/BI/Plainly.lean | 14 +- src/Iris/Instances/Classical/Instance.lean | 18 +- src/Iris/Instances/UPred/Instance.lean | 11 + src/Iris/ProofMode/Instances.lean | 8 +- src/Iris/ProofMode/Tactics/Basic.lean | 2 +- src/Iris/Std.lean | 1 + src/Iris/Std/BigOp.lean | 40 - src/Iris/Std/FiniteMap.lean | 1190 ++++++++++++++ src/Iris/Std/FiniteMapDom.lean | 144 ++ src/Iris/Std/FiniteSet.lean | 931 +++++++++++ src/Iris/Std/List.lean | 165 ++ 26 files changed, 7754 insertions(+), 112 deletions(-) create mode 100644 src/Iris/BI/BigOp/BigAndList.lean create mode 100644 src/Iris/BI/BigOp/BigAndMap.lean create mode 100644 src/Iris/BI/BigOp/BigOp.lean create mode 100644 src/Iris/BI/BigOp/BigOrList.lean create mode 100644 src/Iris/BI/BigOp/BigSepList.lean create mode 100644 src/Iris/BI/BigOp/BigSepMap.lean create mode 100644 src/Iris/BI/BigOp/BigSepSet.lean create mode 100644 src/Iris/BI/BigOps.lean delete mode 100644 src/Iris/Std/BigOp.lean create mode 100644 src/Iris/Std/FiniteMap.lean create mode 100644 src/Iris/Std/FiniteMapDom.lean create mode 100644 src/Iris/Std/FiniteSet.lean create mode 100644 src/Iris/Std/List.lean diff --git a/src/Iris/Algebra.lean b/src/Iris/Algebra.lean index 8d63cdf4..8d7757d8 100644 --- a/src/Iris/Algebra.lean +++ b/src/Iris/Algebra.lean @@ -7,3 +7,4 @@ import Iris.Algebra.Frac import Iris.Algebra.Heap import Iris.Algebra.View import Iris.Algebra.HeapView +import Iris.Algebra.Monoid diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean index 543f7ffe..5aa5352c 100644 --- a/src/Iris/Algebra/BigOp.lean +++ b/src/Iris/Algebra/BigOp.lean @@ -1,7 +1,7 @@ /- -Copyright (c) 2022 Lars König. All rights reserved. +Copyright (c) 2025 Zongyuan Liu. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Lars König, Mario Carneiro, Zongyuan Liu +Authors: Zongyuan Liu -/ import Iris.Algebra.Monoid diff --git a/src/Iris/Algebra/Monoid.lean b/src/Iris/Algebra/Monoid.lean index 0e961bf9..593fbc64 100644 --- a/src/Iris/Algebra/Monoid.lean +++ b/src/Iris/Algebra/Monoid.lean @@ -1,7 +1,7 @@ /- -Copyright (c) 2022 Lars König. All rights reserved. +Copyright (c) 2025 Zongyuan Liu. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Lars König, Mario Carneiro, Zongyuan Liu +Authors: Zongyuan Liu -/ import Iris.Algebra.OFE diff --git a/src/Iris/BI.lean b/src/Iris/BI.lean index aa005213..86784bab 100644 --- a/src/Iris/BI.lean +++ b/src/Iris/BI.lean @@ -5,3 +5,4 @@ import Iris.BI.Instances import Iris.BI.BI import Iris.BI.Notation import Iris.BI.Updates +import Iris.BI.BigOps diff --git a/src/Iris/BI/BI.lean b/src/Iris/BI/BI.lean index 0f91953f..78ba29b2 100644 --- a/src/Iris/BI/BI.lean +++ b/src/Iris/BI/BI.lean @@ -1,7 +1,7 @@ /- Copyright (c) 2022 Lars König. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. -Authors: Lars König, Mario Carneiro +Authors: Lars König, Mario Carneiro, Zongyuan Liu -/ import Iris.Algebra.OFE import Iris.BI.BIBase @@ -18,6 +18,8 @@ theorem liftRel_eq : liftRel (@Eq α) A B ↔ A = B := by /-- Require that a separation logic with carrier type `PROP` fulfills all necessary axioms. -/ class BI (PROP : Type _) extends COFE PROP, BI.BIBase PROP where + -- Iris-Rocq defines BI equiv `≡` as OFE equiv, `⊣⊢` as two directions of bi-entailment, + -- and uses `bi_mixin_equiv_entails`. The two implementations are equivalent. Equiv P Q := P ⊣⊢ Q entails_preorder : Preorder Entails @@ -102,7 +104,7 @@ export BIBase ( Entails emp pure and or imp sForall sExists «forall» «exists» sep wand persistently BiEntails iff wandIff affinely absorbingly intuitionistically later persistentlyIf affinelyIf absorbinglyIf - intuitionisticallyIf bigAnd bigOr bigSep Entails.trans BiEntails.trans) + intuitionisticallyIf Entails.trans BiEntails.trans) attribute [rw_mono_rule] BI.sep_mono attribute [rw_mono_rule] BI.persistently_mono diff --git a/src/Iris/BI/BIBase.lean b/src/Iris/BI/BIBase.lean index 0ffdca1a..e58733ee 100644 --- a/src/Iris/BI/BIBase.lean +++ b/src/Iris/BI/BIBase.lean @@ -7,7 +7,6 @@ import Iris.BI.Notation import Iris.Std.Classes import Iris.Std.DelabRule import Iris.Std.Rewrite -import Iris.Std.BigOp namespace Iris.BI open Iris.Std @@ -256,18 +255,6 @@ delab_rule absorbinglyIf delab_rule intuitionisticallyIf | `($_ $p $P) => do ``(iprop(□?$p $(← unpackIprop P))) -/-- Fold the conjunction `∧` over a list of separation logic propositions. -/ -def bigAnd [BIBase PROP] (Ps : List PROP) : PROP := bigOp and iprop(True) Ps -/-- Fold the disjunction `∨` over a list of separation logic propositions. -/ -def bigOr [BIBase PROP] (Ps : List PROP) : PROP := bigOp or iprop(False) Ps -/-- Fold the separating conjunction `∗` over a list of separation logic propositions. -/ -def bigSep [BIBase PROP] (Ps : List PROP) : PROP := bigOp sep iprop(emp) Ps - -notation:40 "[∧] " Ps:max => bigAnd Ps -notation:40 "[∨] " Ps:max => bigOr Ps -notation:40 "[∗] " Ps:max => bigSep Ps - - /-- Iterated later modality. -/ syntax:max "▷^[" term:45 "]" term:40 : term diff --git a/src/Iris/BI/BigOp/BigAndList.lean b/src/Iris/BI/BigOp/BigAndList.lean new file mode 100644 index 00000000..d3a6bab8 --- /dev/null +++ b/src/Iris/BI/BigOp/BigAndList.lean @@ -0,0 +1,268 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp + +namespace Iris.BI + +open Iris.Algebra +open BIBase + +/-! # Big Conjunction over Lists -/ + +variable {PROP : Type _} [BI PROP] {A : Type _} + +namespace BigAndL + +/-- Corresponds to `big_andL_nil` in Rocq Iris. -/ +@[simp] +theorem nil {Φ : Nat → A → PROP} : + ([∧list] k ↦ x ∈ ([] : List A), Φ k x) ⊣⊢ iprop(True) := by + simp only [bigAndL, bigOpL] + exact .rfl + +/-- Corresponds to `big_andL_nil'` in Rocq Iris. -/ +theorem nil' {Φ : Nat → A → PROP} {l : List A} (h : l = []) : + ([∧list] k ↦ x ∈ l, Φ k x) ⊣⊢ iprop(True) := by + subst h; exact nil + +/-- Corresponds to `big_andL_cons` in Rocq Iris. -/ +theorem cons {Φ : Nat → A → PROP} {x : A} {xs : List A} : + ([∧list] k ↦ y ∈ (x :: xs), Φ k y) ⊣⊢ Φ 0 x ∧ [∧list] n ↦ y ∈ xs, Φ (n + 1) y := by + simp only [bigAndL, bigOpL] + exact .rfl + +/-- Corresponds to `big_andL_singleton` in Rocq Iris. -/ +theorem singleton {Φ : Nat → A → PROP} {x : A} : + ([∧list] k ↦ y ∈ [x], Φ k y) ⊣⊢ Φ 0 x := + equiv_iff.mp (BigOpL.singleton Φ x) + +/-- Corresponds to `big_andL_app` in Rocq Iris. -/ +theorem app {Φ : Nat → A → PROP} {l₁ l₂ : List A} : + ([∧list] k ↦ x ∈ (l₁ ++ l₂), Φ k x) ⊣⊢ + ([∧list] k ↦ x ∈ l₁, Φ k x) ∧ [∧list] n ↦ x ∈ l₂, Φ (n + l₁.length) x := + equiv_iff.mp (BigOpL.append Φ l₁ l₂) + +/-- Corresponds to `big_andL_snoc` in Rocq Iris. -/ +theorem snoc {Φ : Nat → A → PROP} {l : List A} {x : A} : + ([∧list] k ↦ y ∈ (l ++ [x]), Φ k y) ⊣⊢ ([∧list] k ↦ y ∈ l, Φ k y) ∧ Φ l.length x := + equiv_iff.mp (BigOpL.snoc Φ l x) + +/-- Corresponds to `big_andL_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ⊢ Ψ k x) : + ([∧list] k ↦ x ∈ l, Φ k x) ⊢ [∧list] k ↦ x ∈ l, Ψ k x := by + induction l generalizing Φ Ψ with + | nil => exact Entails.rfl + | cons y ys ih => + simp only [bigAndL, bigOpL] + apply and_mono + · exact h 0 y rfl + · apply ih + intro k x hget + exact h (k + 1) x hget + +/-- Corresponds to `big_andL_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ≡ Ψ k x) : + ([∧list] k ↦ x ∈ l, Φ k x) ≡ [∧list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr h + +/-- Unconditional version of proper. No direct Rocq equivalent. -/ +theorem congr {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Φ k x ≡ Ψ k x) : + ([∧list] k ↦ x ∈ l, Φ k x) ≡ [∧list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr' h + +/-- Corresponds to `big_andL_persistent'` in Rocq Iris. -/ +instance persistent {Φ : Nat → A → PROP} {l : List A} [∀ k x, Persistent (Φ k x)] : + Persistent ([∧list] k ↦ x ∈ l, Φ k x) where + persistent := by + induction l generalizing Φ with + | nil => + simp only [bigAndL, bigOpL] + exact persistently_true.2 + | cons x xs ih => + simp only [bigAndL, bigOpL] + have h1 : Φ 0 x ⊢ Φ 0 x := Persistent.persistent + have h2 : ([∧list] n ↦ y ∈ xs, Φ (n + 1) y) ⊢ [∧list] n ↦ y ∈ xs, Φ (n + 1) y := ih + exact (and_mono h1 h2).trans persistently_and.2 + +/-- No direct Rocq equivalent; BIAffine version for affine contexts. -/ +instance affine {Φ : Nat → A → PROP} {l : List A} [BIAffine PROP] : + Affine ([∧list] k ↦ x ∈ l, Φ k x) where + affine := by + induction l generalizing Φ with + | nil => + simp only [bigAndL, bigOpL] + exact true_emp.1 + | cons x xs ih => + simp only [bigAndL, bigOpL] + exact and_elim_l.trans Affine.affine + +/-- Corresponds to `big_andL_emp` in Rocq Iris. -/ +theorem true_l {l : List A} : + ([∧list] _x ∈ l, iprop(True : PROP)) ≡ iprop(True) := + BigOpL.unit_const l + +/-- Corresponds to `big_andL_and` in Rocq Iris. -/ +theorem and' {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∧list] k ↦ x ∈ l, iprop(Φ k x ∧ Ψ k x)) ≡ + iprop(([∧list] k ↦ x ∈ l, Φ k x) ∧ [∧list] k ↦ x ∈ l, Ψ k x) := + BigOpL.op_distr Φ Ψ l + +/-- No direct Rocq equivalent; reverse direction of `and'`. -/ +theorem and_2 {Φ Ψ : Nat → A → PROP} {l : List A} : + iprop(([∧list] k ↦ x ∈ l, Φ k x) ∧ [∧list] k ↦ x ∈ l, Ψ k x) ≡ + [∧list] k ↦ x ∈ l, iprop(Φ k x ∧ Ψ k x) := + and'.symm + +/-- Corresponds to `big_andL_take_drop` in Rocq Iris. -/ +theorem take_drop {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + ([∧list] k ↦ x ∈ l, Φ k x) ≡ + iprop(([∧list] k ↦ x ∈ (l.take n), Φ k x) ∧ [∧list] k ↦ x ∈ (l.drop n), Φ (n + k) x) := + BigOpL.take_drop Φ l n + +/-- Corresponds to `big_andL_fmap` in Rocq Iris. -/ +theorem fmap {B : Type _} (f : A → B) {Φ : Nat → B → PROP} {l : List A} : + ([∧list] k ↦ y ∈ (l.map f), Φ k y) ≡ [∧list] k ↦ x ∈ l, Φ k (f x) := by + induction l generalizing Φ with + | nil => simp only [List.map_nil]; exact OFE.Equiv.rfl + | cons x xs ih => + simp only [List.map_cons, bigAndL, bigOpL] + exact Monoid.op_proper OFE.Equiv.rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_andL_lookup` in Rocq Iris. -/ +theorem lookup {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + ([∧list] k ↦ y ∈ l, Φ k y) ⊢ Φ i x := by + induction l generalizing i Φ with + | nil => simp at h + | cons y ys ih => + simp only [bigAndL, bigOpL] + cases i with + | zero => + simp at h + subst h + exact and_elim_l + | succ j => + simp at h + exact and_elim_r.trans (ih h) + +/-- Corresponds to `big_andL_intro` in Rocq Iris. -/ +theorem intro {P : PROP} {Φ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → P ⊢ Φ k x) : + P ⊢ [∧list] k ↦ x ∈ l, Φ k x := by + induction l generalizing Φ with + | nil => + simp only [bigAndL, bigOpL] + exact true_intro + | cons y ys ih => + simp only [bigAndL, bigOpL] + apply and_intro + · exact h 0 y rfl + · exact ih (fun k x hget => h (k + 1) x hget) + +/-- Corresponds to `big_andL_forall` in Rocq Iris. -/ +theorem forall' {Φ : Nat → A → PROP} {l : List A} : + ([∧list] k ↦ x ∈ l, Φ k x) ⊣⊢ ∀ k, ∀ x, iprop(⌜l[k]? = some x⌝ → Φ k x) := by + constructor + · apply forall_intro; intro k + apply forall_intro; intro x + refine imp_intro <| and_comm.1.trans <| pure_elim_l (lookup ·) + · induction l generalizing Φ with + | nil => exact true_intro + | cons y ys ih => + simp only [bigAndL, bigOpL] + apply and_intro + · exact (forall_elim 0).trans <| (forall_elim y).trans <| + (imp_congr_l (pure_true rfl)).1.trans true_imp.1 + · refine Entails.trans ?_ (ih (Φ := fun k x => Φ (k + 1) x)) + exact forall_intro fun k => forall_intro fun x => (forall_elim (k + 1)).trans (forall_elim x) + +/-- Corresponds to `big_andL_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∧list] k ↦ x ∈ l, Φ k x) ∧ (∀ k x, iprop(⌜l[k]? = some x⌝ → Φ k x → Ψ k x)) ⊢ + [∧list] k ↦ x ∈ l, Ψ k x := + intro fun k x hget => + (and_mono (lookup hget) ((forall_elim k).trans (forall_elim x))).trans <| + (and_mono .rfl ((and_intro (pure_intro hget) .rfl).trans imp_elim_r)).trans imp_elim_r + +/-- Corresponds to `big_andL_persistently` in Rocq Iris. -/ +theorem persistently {Φ : Nat → A → PROP} {l : List A} : + iprop( [∧list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∧list] k ↦ x ∈ l, iprop( Φ k x) := + equiv_iff.mp <| BigOpL.commute bi_persistently_and_homomorphism Φ l + +/-- Corresponds to `big_andL_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : Nat → A → Prop} {l : List A} : + ([∧list] k ↦ x ∈ l, iprop(⌜φ k x⌝ : PROP)) ⊢ iprop(⌜∀ k x, l[k]? = some x → φ k x⌝ : PROP) := + forall'.1.trans <| (forall_mono fun _ => forall_mono fun _ => pure_imp.1).trans <| + (forall_mono fun _ => pure_forall.1).trans pure_forall.1 + +/-- Corresponds to `big_andL_pure_2` in Rocq Iris. -/ +theorem pure_2 {φ : Nat → A → Prop} {l : List A} : + iprop(⌜∀ k x, l[k]? = some x → φ k x⌝ : PROP) ⊢ [∧list] k ↦ x ∈ l, iprop(⌜φ k x⌝ : PROP) := + pure_forall_2.trans <| (forall_mono fun _ => pure_forall_2).trans <| + (forall_mono fun _ => forall_mono fun _ => pure_imp_2).trans forall'.2 + +/-- Corresponds to `big_andL_pure` in Rocq Iris. -/ +theorem pure {φ : Nat → A → Prop} {l : List A} : + ([∧list] k ↦ x ∈ l, iprop(⌜φ k x⌝ : PROP)) ⊣⊢ iprop(⌜∀ k x, l[k]? = some x → φ k x⌝ : PROP) := + ⟨pure_1, pure_2⟩ + +/-- Corresponds to `big_andL_elem_of` in Rocq Iris. -/ +theorem elem_of {Φ : A → PROP} {l : List A} {x : A} + (h : x ∈ l) : + ([∧list] y ∈ l, Φ y) ⊢ Φ x := by + have ⟨i, hi, hget⟩ := List.mem_iff_getElem.mp h + have hlookup : l[i]? = some x := List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩ + exact lookup hlookup + +/-- Corresponds to `big_andL_zip_seq` in Rocq Iris. -/ +theorem zip_seq {Φ : Nat × A → PROP} {n : Nat} {l : List A} : + ([∧list] ky ∈ ((List.range' n l.length).zip l), Φ ky) ≡ + [∧list] i ↦ x ∈ l, Φ (n + i, x) := + BigOpL.zip_seq (op := and) (unit := iprop(True)) Φ n l + +/-- Corresponds to `big_andL_bind` in Rocq Iris (uses flatMap). -/ +theorem bind {B : Type _} (f : A → List B) {Φ : B → PROP} {l : List A} : + ([∧list] y ∈ (l.flatMap f), Φ y) ⊣⊢ + [∧list] x ∈ l, [∧list] y ∈ (f x), Φ y := by + induction l with + | nil => exact .rfl + | cons x xs ih => + simp only [List.flatMap_cons, bigAndL, bigOpL] + exact app.trans (and_congr .rfl ih) + +/-- Corresponds to `big_andL_later` in Rocq Iris. -/ +theorem later {Φ : Nat → A → PROP} {l : List A} : + iprop(▷ [∧list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∧list] k ↦ x ∈ l, iprop(▷ Φ k x) := + equiv_iff.mp <| BigOpL.commute bi_later_and_homomorphism Φ l + +/-- Corresponds to `big_andL_laterN` in Rocq Iris. -/ +theorem laterN {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + iprop(▷^[n] [∧list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∧list] k ↦ x ∈ l, iprop(▷^[n] Φ k x) := by + induction n with + | zero => exact .rfl + | succ m ih => exact (later_congr ih).trans later + +/-- Corresponds to `big_andL_Permutation` in Rocq Iris (via BigOpL.perm). -/ +theorem perm {Φ : A → PROP} {l₁ l₂ : List A} (hp : l₁.Perm l₂) : + ([∧list] x ∈ l₁, Φ x) ≡ [∧list] x ∈ l₂, Φ x := + BigOpL.perm Φ hp + +/-! ## Missing Lemmas from Rocq Iris + +The following lemmas from Rocq Iris are not ported: +- `big_andL_submseteq`: Uses stdpp's `⊆+` relation (use `perm` instead) +- `big_andL_ne`: OFE-level non-expansiveness (handled at algebra layer) +- `big_andL_mono'`, `big_andL_id_mono'`: Convenience wrappers (use `mono` directly) +- `big_andL_absorbing`, `big_andL_absorbing'`: Absorbing typeclass (not implemented) +- `big_andL_timeless`, `big_andL_timeless'`: Requires `and_timeless` infrastructure +-/ + +end BigAndL + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigAndMap.lean b/src/Iris/BI/BigOp/BigAndMap.lean new file mode 100644 index 00000000..544e0c76 --- /dev/null +++ b/src/Iris/BI/BigOp/BigAndMap.lean @@ -0,0 +1,538 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp +import Iris.BI.Instances +import Iris.Std.TC + +namespace Iris.BI + +open Iris.Algebra +open Iris.Std +open BIBase + +/-! # Big Conjunction over Maps + +Rocq Iris: `iris/bi/big_op.v`, Section `and_map` +-/ + +variable {PROP : Type _} [BI PROP] +variable {M : Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] + +namespace BigAndM + +/-! ## Basic Structural Lemmas -/ + +/-- Corresponds to `big_andM_empty` in Rocq Iris. -/ +@[simp] +theorem empty {Φ : K → V → PROP} : + ([∧map] k ↦ x ∈ (∅ : M), Φ k x) ⊣⊢ iprop(True) := by + simp only [bigAndM, map_to_list_empty, bigOpL] + exact .rfl + +/-- Corresponds to `big_andM_empty'` in Rocq Iris. -/ +theorem empty' {P : PROP} {Φ : K → V → PROP} : + P ⊢ [∧map] k ↦ x ∈ (∅ : M), Φ k x := + true_intro.trans empty.2 + +/-- Corresponds to `big_andM_singleton` in Rocq Iris. -/ +theorem singleton {Φ : K → V → PROP} {k : K} {v : V} : + ([∧map] k' ↦ x ∈ ({[k := v]} : M), Φ k' x) ⊣⊢ Φ k v := by + have hget : get? (∅ : M) k = none := lookup_empty k + have hperm : (toList (FiniteMap.insert (∅ : M) k v)).Perm ((k, v) :: toList (∅ : M)) := + map_to_list_insert (∅ : M) k v hget + simp only [map_to_list_empty] at hperm + simp only [bigAndM, FiniteMap.singleton] + have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M) k v)) ≡ + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) [(k, v)] := + BigOpL.perm (fun kv => Φ kv.1 kv.2) hperm + simp only [bigOpL] at heq + exact (equiv_iff.mp heq).trans ⟨and_elim_l, (and_intro .rfl true_intro)⟩ + +/-- Corresponds to `big_andM_insert` in Rocq Iris. -/ +theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = none) : + ([∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ + Φ k v ∧ [∧map] k' ↦ x ∈ m, Φ k' x := by + simp only [bigAndM] + have hperm := map_to_list_insert m k v h + have hperm_eq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert m k v)) ≡ + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList m) := + BigOpL.perm _ hperm + simp only [bigOpL] at hperm_eq + exact equiv_iff.mp hperm_eq + +/-- Corresponds to `big_andM_insert_delete` in Rocq Iris. -/ +theorem insert_delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} : + ([∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ + Φ k v ∧ [∧map] k' ↦ x ∈ delete m k, Φ k' x := by + have hmap_eq := FiniteMapLaws.insert_delete_eq m k v + simp only [bigAndM, ← hmap_eq] + have hdelete : get? (delete m k) k = none := lookup_delete_eq m k + have hins := @insert PROP _ M K V _ _ _ Φ (delete m k) k v hdelete + exact hins + +/-- Corresponds to `big_andM_delete` in Rocq Iris. + Splits a big and over a map into the element at key `k` and the rest. -/ +theorem delete' {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + ([∧map] k' ↦ x ∈ m, Φ k' x) ⊣⊢ Φ k v ∧ [∧map] k' ↦ x ∈ Std.delete m k, Φ k' x := by + simp only [bigAndM] + have hperm := map_to_list_delete m k v h + have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList m) ≡ + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList (Std.delete m k)) := + BigOpL.perm _ hperm + simp only [bigOpL] at heq + exact equiv_iff.mp heq + +/-! ## Monotonicity and Congruence -/ + +omit [DecidableEq K] in +/-- Helper: mono on lists directly. -/ +private theorem mono_list {Φ Ψ : K × V → PROP} {l : List (K × V)} + (h : ∀ kv, kv ∈ l → Φ kv ⊢ Ψ kv) : + bigOpL and iprop(True) (fun _ kv => Φ kv) l ⊢ bigOpL and iprop(True) (fun _ kv => Ψ kv) l := by + induction l with + | nil => exact Entails.rfl + | cons kv kvs ih => + simp only [bigOpL] + apply and_mono + · exact h kv List.mem_cons_self + · exact ih (fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)) + +/-- Corresponds to `big_andM_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Φ k v ⊢ Ψ k v) : + ([∧map] k ↦ x ∈ m, Φ k x) ⊢ [∧map] k ↦ x ∈ m, Ψ k x := by + simp only [bigAndM] + apply mono_list + intro kv hmem + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Corresponds to `big_andM_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Φ k v ≡ Ψ k v) : + ([∧map] k ↦ x ∈ m, Φ k x) ≡ [∧map] k ↦ x ∈ m, Ψ k x := by + simp only [bigAndM] + apply BigOpL.congr + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Unconditional version of `proper`. No direct Rocq equivalent. -/ +theorem congr {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, Φ k v ≡ Ψ k v) : + ([∧map] k ↦ x ∈ m, Φ k x) ≡ [∧map] k ↦ x ∈ m, Ψ k x := + proper (fun k v _ => h k v) + +/-- Corresponds to `big_andM_ne` in Rocq Iris. -/ +theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} + (h : ∀ k v, get? m k = some v → Φ k v ≡{n}≡ Ψ k v) : + ([∧map] k ↦ x ∈ m, Φ k x) ≡{n}≡ [∧map] k ↦ x ∈ m, Ψ k x := by + simp only [bigAndM] + apply BigOpL.congr_ne + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Corresponds to `big_andM_mono'` in Rocq Iris. -/ +theorem mono' {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, Φ k v ⊢ Ψ k v) : + ([∧map] k ↦ x ∈ m, Φ k x) ⊢ [∧map] k ↦ x ∈ m, Ψ k x := + mono (fun k v _ => h k v) + +/-! ## Typeclass Instances -/ + +/-- Corresponds to `big_andM_empty_persistent` in Rocq Iris. -/ +instance empty_persistent {Φ : K → V → PROP} : + Persistent ([∧map] k ↦ x ∈ (∅ : M), Φ k x) where + persistent := by + simp only [bigAndM, map_to_list_empty, bigOpL] + exact persistently_true.2 + +/-- Corresponds to `big_andM_persistent` in Rocq Iris (conditional version). -/ +theorem persistent_cond {Φ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Persistent (Φ k v)) : + Persistent ([∧map] k ↦ x ∈ m, Φ k x) where + persistent := by + simp only [bigAndM] + apply BigOpL.closed (fun P => P ⊢ P) (fun _ kv => Φ kv.1 kv.2) (toList m) + persistently_true.2 + (fun _ _ h1 h2 => (and_mono h1 h2).trans persistently_and.2) + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact (h kv.1 kv.2 hkv).persistent + +/-- Corresponds to `big_andM_persistent'` in Rocq Iris. -/ +instance persistent {Φ : K → V → PROP} {m : M} [∀ k v, Persistent (Φ k v)] : + Persistent ([∧map] k ↦ x ∈ m, Φ k x) := + persistent_cond fun _ _ _ => inferInstance + +/-- BIAffine instance for bigAndM. -/ +instance affine {Φ : K → V → PROP} {m : M} [BIAffine PROP] : + Affine ([∧map] k ↦ x ∈ m, Φ k x) where + affine := by + simp only [bigAndM] + induction (toList m) with + | nil => simp only [bigOpL]; exact true_emp.1 + | cons kv kvs ih => simp only [bigOpL]; exact and_elim_l.trans Affine.affine + +/-! ## Lookup Lemmas -/ + +/-- Corresponds to `big_andM_lookup` in Rocq Iris. -/ +theorem lookup {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + ([∧map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v := + (delete' h).1.trans and_elim_l + +/-- Corresponds to `big_andM_lookup_dom` in Rocq Iris. -/ +theorem lookup_dom {Φ : K → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + bigAndM (fun k' _ => Φ k') m ⊢ Φ k := + lookup (Φ := fun k' _ => Φ k') h + +/-- Corresponds to `big_andM_insert_2` in Rocq Iris. -/ +theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : + Φ k v ∧ ([∧map] k' ↦ x ∈ m, Φ k' x) ⊢ [∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x := by + cases hm : get? m k with + | none => + exact (insert hm).2 + | some y => + have hdel := delete' (Φ := Φ) (m := m) hm + refine (and_mono_r (hdel.1.trans and_elim_r)).trans insert_delete.2 + +/-! ## Logical Operations -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_andM_and` in Rocq Iris. -/ +theorem and' {Φ Ψ : K → V → PROP} {m : M} : + ([∧map] k ↦ x ∈ m, Φ k x ∧ Ψ k x) ⊣⊢ + ([∧map] k ↦ x ∈ m, Φ k x) ∧ [∧map] k ↦ x ∈ m, Ψ k x := by + simp only [bigAndM] + exact equiv_iff.mp (BigOpL.op_distr _ _ _) + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_andM_persistently` in Rocq Iris. -/ +theorem persistently {Φ : K → V → PROP} {m : M} : + iprop( [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, Φ k x := by + simp only [bigAndM] + exact equiv_iff.mp <| BigOpL.commute bi_persistently_and_homomorphism _ (toList m) + +/-! ## Map Conversion -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_andM_map_to_list` (implicit in Rocq Iris). -/ +theorem map_to_list {Φ : K → V → PROP} {m : M} : + ([∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∧list] kv ∈ toList m, Φ kv.1 kv.2) := by + simp only [bigAndM] + exact .rfl + +/-! ## Map Transformations -/ + +section MapTransformations + +variable {M' : Type _} {V' : Type _} +variable [FiniteMap M' K V'] +variable [FiniteMapLawsExt M M' K V V'] + +/-- Corresponds to `big_andM_fmap` in Rocq Iris. -/ +theorem fmap {Φ : K → V' → PROP} {m : M} (f : V → V') : + ([∧map] k ↦ y ∈ FiniteMap.map (M' := M') f m, Φ k y) ⊣⊢ + [∧map] k ↦ y ∈ m, Φ k (f y) := by + simp only [bigAndM] + refine equiv_iff.mp (BigOpL.perm _ (toList_map (K := K) (M' := M') m f)) |>.trans ?_ + induction (toList m) with + | nil => exact .rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ + +end MapTransformations + +section FilterMapTransformations + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Helper lemma for omap: bigOpL over filterMapped list. -/ +private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) + (l.filterMap (fun kv => (f kv.2).map (kv.1, ·))) ⊣⊢ + bigOpL and iprop(True) (fun _ kv => match f kv.2 with | some y' => Φ kv.1 y' | none => iprop(True)) l := by + induction l with + | nil => simp only [List.filterMap, bigOpL]; exact .rfl + | cons kv kvs ih => + simp only [List.filterMap, Option.map] + cases hf : f kv.2 with + | none => + simp only [bigOpL, hf] + have true_and : ∀ (X : PROP), iprop(True) ∧ X ⊣⊢ X := fun X => + ⟨and_elim_r, and_intro true_intro .rfl⟩ + exact ih.trans (true_and _).symm + | some y' => + simp only [bigOpL, hf] + exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ + +/-- Corresponds to `big_andM_omap` in Rocq Iris. -/ +theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V → Option V) : + ([∧map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ + [∧map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => iprop(True) := by + simp only [bigAndM] + exact equiv_iff.mp (BigOpL.perm _ (toList_filterMap (K := K) m f)) |>.trans + (omap_list_aux f (toList m)) + +/-- Corresponds to `big_andM_union` in Rocq Iris. -/ +theorem union [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m₁ m₂ : M} + (hdisj : m₁ ##ₘ m₂) : + ([∧map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ + ([∧map] k ↦ y ∈ m₁, Φ k y) ∧ [∧map] k ↦ y ∈ m₂, Φ k y := by + simp only [bigAndM] + refine equiv_iff.mp (BigOpL.perm _ (toList_union_disjoint m₁ m₂ hdisj)) |>.trans ?_ + exact equiv_iff.mp (BigOpL.append _ (toList m₁) (toList m₂)) + +end FilterMapTransformations + +/-! ## Intro and Forall Lemmas -/ + +/-- Corresponds to `big_andM_intro` in Rocq Iris. -/ +theorem intro {P : PROP} {Φ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → P ⊢ Φ k v) : + P ⊢ [∧map] k ↦ x ∈ m, Φ k x := by + simp only [bigAndM] + generalize hl : toList m = l + induction l generalizing m with + | nil => exact true_intro + | cons kv kvs ih => + simp only [bigOpL] + have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self + have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + refine and_intro (h kv.1 kv.2 hget_kv) ?_ + have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => + (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + clear ih hmem_kv hget_kv hl + induction kvs with + | nil => exact true_intro + | cons kv' kvs' ih' => + simp only [bigOpL] + refine and_intro (h kv'.1 kv'.2 (htail kv' List.mem_cons_self)) ?_ + exact ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem) + +/-- Corresponds to `big_andM_forall` in Rocq Iris. -/ +theorem forall' {Φ : K → V → PROP} {m : M} : + ([∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := by + constructor + · refine forall_intro fun k => forall_intro fun v => imp_intro' <| pure_elim_l fun hget => ?_ + exact lookup hget + · exact intro fun k v hget => + (forall_elim k).trans (forall_elim v) |>.trans <| + (and_intro (pure_intro hget) .rfl).trans imp_elim_r + +/-- Corresponds to `big_andM_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : K → V → PROP} {m : M} : + ([∧map] k ↦ x ∈ m, Φ k x) ∧ (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v → Ψ k v)) ⊢ + [∧map] k ↦ x ∈ m, Ψ k x := by + refine intro fun k v hget => ?_ + refine (and_mono (lookup hget) ((forall_elim k).trans (forall_elim v))).trans ?_ + refine (and_mono .rfl ((and_intro (pure_intro hget) .rfl).trans imp_elim_r)).trans imp_elim_r + +/-- Corresponds to `big_andM_subseteq` in Rocq Iris. -/ +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M} + (hsub : m₂ ⊆ m₁) : + ([∧map] k ↦ x ∈ m₁, Φ k x) ⊢ [∧map] k ↦ x ∈ m₂, Φ k x := + intro fun k v hget₂ => lookup (hsub k v hget₂) + +/-! ## Pure Lemmas -/ + +/-- This is equivalent to Rocq Iris's `map_Forall`. -/ +def mapForall (φ : K → V → Prop) (m : M) : Prop := + ∀ k v, get? m k = some v → φ k v + +/-- Corresponds to `big_andM_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : K → V → Prop} {m : M} : + ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜mapForall φ m⌝ : PROP) := by + simp only [bigAndM, mapForall] + suffices h : ∀ l : List (K × V), + bigOpL and iprop(True) (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l ⊢ + iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) by + refine (h (toList m)).trans <| pure_mono fun hlist k v hget => ?_ + have hmem : (k, v) ∈ toList m := (elem_of_map_to_list m k v).mp hget + exact hlist (k, v) hmem + intro l + induction l with + | nil => + simp only [bigOpL] + exact pure_intro fun _ h => nomatch h + | cons kv kvs ih => + simp only [bigOpL] + refine (and_mono_r ih).trans <| pure_and.1.trans <| pure_mono ?_ + intro ⟨hkv, hkvs⟩ kv' hmem + cases hmem with + | head => exact hkv + | tail _ htail => exact hkvs kv' htail + +/-- Corresponds to `big_andM_pure_2` in Rocq Iris. -/ +theorem pure_2 {φ : K → V → Prop} {m : M} : + (⌜mapForall φ m⌝ : PROP) ⊢ ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) := by + simp only [bigAndM, mapForall] + suffices h : ∀ l : List (K × V), + iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) ⊢ + bigOpL and iprop(True) (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l by + refine (pure_mono fun hmap kv hmem => ?_).trans (h (toList m)) + have hget : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact hmap kv.1 kv.2 hget + intro l + induction l with + | nil => + simp only [bigOpL] + exact true_intro + | cons kv kvs ih => + simp only [bigOpL] + refine (pure_mono fun h => + ⟨h kv List.mem_cons_self, fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)⟩).trans <| + pure_and.2.trans (and_mono_r ih) + +/-- Corresponds to `big_andM_pure` in Rocq Iris. -/ +theorem pure' {φ : K → V → Prop} {m : M} : + ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜mapForall φ m⌝ : PROP) := + ⟨pure_1, pure_2⟩ + +/-! ## Later Lemmas -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_andM_later` in Rocq Iris. -/ +theorem later {Φ : K → V → PROP} {m : M} : + iprop(▷ [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷ Φ k x := by + simp only [bigAndM] + exact equiv_iff.mp <| BigOpL.commute bi_later_and_homomorphism _ (toList m) + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_andM_laterN` in Rocq Iris. -/ +theorem laterN {Φ : K → V → PROP} {m : M} {n : Nat} : + iprop(▷^[n] [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷^[n] Φ k x := by + induction n with + | zero => exact .rfl + | succ k ih => exact (later_congr ih).trans later + +/-! ## Filter Lemmas -/ + +variable [FiniteMapLawsSelf M K V] + +omit [DecidableEq K] in +/-- Helper: bigOpL over filtered list. -/ +private theorem filter_list_aux {Φ : K × V → PROP} (p : K × V → Bool) (l : List (K × V)) : + bigOpL and iprop(True) (fun _ kv => Φ kv) (l.filter p) ⊣⊢ + bigOpL and iprop(True) (fun _ kv => if p kv then Φ kv else iprop(True)) l := by + induction l with + | nil => simp only [List.filter, bigOpL]; exact .rfl + | cons kv kvs ih => + simp only [List.filter] + cases hp : p kv with + | false => + simp only [bigOpL, hp] + have true_and : ∀ (X : PROP), iprop(True) ∧ X ⊣⊢ X := fun X => + ⟨and_elim_r, and_intro true_intro .rfl⟩ + exact ih.trans (true_and _).symm + | true => + simp only [bigOpL, hp, ↓reduceIte] + exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ + +/-- Corresponds to `big_andM_filter'` in Rocq Iris. -/ +theorem filter' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : + ([∧map] k ↦ x ∈ FiniteMap.filter p m, Φ k x) ⊣⊢ + [∧map] k ↦ x ∈ m, if p k x then Φ k x else iprop(True) := by + simp only [bigAndM] + have hperm := toList_filter m p + have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.filter p m)) ≡ + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((toList m).filter (fun kv => p kv.1 kv.2)) := + BigOpL.perm _ hperm + refine equiv_iff.mp heq |>.trans ?_ + exact filter_list_aux (fun kv => p kv.1 kv.2) (toList m) + +/-- Corresponds to `big_andM_filter` in Rocq Iris. -/ +theorem filter'' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : + ([∧map] k ↦ x ∈ FiniteMap.filter p m, Φ k x) ⊣⊢ + [∧map] k ↦ x ∈ m, iprop(⌜p k x = true⌝ → Φ k x) := by + have heq : ([∧map] k ↦ x ∈ m, if p k x then Φ k x else iprop(True)) ⊣⊢ + [∧map] k ↦ x ∈ m, iprop(⌜p k x = true⌝ → Φ k x) := by + apply equiv_iff.mp + apply proper + intro k v _ + cases hp : p k v with + | false => + simp only [↓reduceIte, Bool.false_eq_true] + refine equiv_iff.mpr ⟨?_, true_intro⟩ + refine imp_intro' <| pure_elim_l fun h => ?_ + simp at h + | true => + simp only [↓reduceIte] + exact equiv_iff.mpr true_imp.symm + exact (filter' p).trans heq + +/-! ## Key Transformation Lemmas -/ + +section KeyTransformations + +variable {M' : Type _} {K' : Type _} +variable [DecidableEq K'] +variable [FiniteMap M' K' V] +variable [FiniteMapLaws M' K' V] +variable [FiniteMapKmapLaws M M' K K' V] + +/-- Corresponds to `big_andM_kmap` in Rocq Iris. -/ +theorem kmap {Φ : K' → V → PROP} {m : M} (f : K → K') (hinj : ∀ {x y}, f x = f y → x = y) : + ([∧map] k' ↦ y ∈ FiniteMap.kmap (M' := M') f m, Φ k' y) ⊣⊢ + [∧map] k ↦ y ∈ m, Φ (f k) y := by + simp only [bigAndM] + refine equiv_iff.mp (BigOpL.perm _ (toList_kmap f m hinj)) |>.trans ?_ + induction (toList m) with + | nil => exact .rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ + +end KeyTransformations + +/-! ## List to Map Conversion Lemmas -/ + +section ListToMap + +variable [FiniteMap M Nat V] +variable [FiniteMapLaws M Nat V] +variable [FiniteMapSeqLaws M V] + +/-- Corresponds to `big_andM_map_seq` in Rocq Iris. -/ +theorem map_seq {Φ : Nat → V → PROP} (start : Nat) (l : List V) : + ([∧map] k ↦ x ∈ (FiniteMap.map_seq start l : M), Φ k x) ⊣⊢ + ([∧list] i ↦ x ∈ l, Φ (start + i) x) := by + simp only [bigAndM, bigAndL] + have h1 : bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M)) ≡ + bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) := + BigOpL.perm (fun kv => Φ kv.fst kv.snd) (toList_map_seq (M := M) start l) + have h2 : bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) ≡ + bigOpL and iprop(True) (fun i x => Φ (start + i) x) l := + BigOpL.zip_seq (fun p => Φ p.1 p.2) start l + exact equiv_iff.mp (h1.trans h2) + +end ListToMap + +/-! ## Missing Lemmas from Rocq Iris + +The following lemmas from Rocq Iris are not yet fully ported: +- `big_andM_fn_insert*` +- `big_andM_timeless*`: Requires and_timeless infrastructure +-/ + +end BigAndM + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigOp.lean b/src/Iris/BI/BigOp/BigOp.lean new file mode 100644 index 00000000..d1262453 --- /dev/null +++ b/src/Iris/BI/BigOp/BigOp.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.Algebra.BigOp +import Iris.BI.DerivedLaws +import Iris.Std.FiniteMap +import Iris.Std.FiniteSet + +namespace Iris.BI + +open Iris.Algebra +open Iris.Std +open OFE +open BIBase + +/-! # BI-Instantiated Big Operators over Lists +- `bigSepL`: Big separating conjunction `[∗list]` +- `bigAndL`: Big conjunction `[∧list]` +- `bigOrL`: Big disjunction `[∨list]` +-/ + +section List +/-! ## Core Definitions -/ + +/-- Big separating conjunction over a list with index access. + `bigSepL Φ l` computes `Φ 0 l[0] ∗ Φ 1 l[1] ∗ ... ∗ Φ (n-1) l[n-1]` -/ +abbrev bigSepL [BI PROP] {A : Type _} (Φ : Nat → A → PROP) (l : List A) : PROP := + bigOpL sep emp Φ l + +/-- Big conjunction over a list with index access. + `bigAndL Φ l` computes `Φ 0 l[0] ∧ Φ 1 l[1] ∧ ... ∧ Φ (n-1) l[n-1]` -/ +abbrev bigAndL [BI PROP] {A : Type _} (Φ : Nat → A → PROP) (l : List A) : PROP := + bigOpL and iprop(True) Φ l + +/-- Big disjunction over a list with index access. + `bigOrL Φ l` computes `Φ 0 l[0] ∨ Φ 1 l[1] ∨ ... ∨ Φ (n-1) l[n-1]` -/ +abbrev bigOrL [BI PROP] {A : Type _} (Φ : Nat → A → PROP) (l : List A) : PROP := + bigOpL or iprop(False) Φ l + +/-! ## Notation -/ + +-- Notation for bigSepL without index +syntax atomic("[∗list]") ident " ∈ " term ", " term : term +-- Notation for bigSepL with index +syntax atomic("[∗list]") ident " ↦ " ident " ∈ " term ", " term : term +-- Notation for bigSepL2 without index (two lists) +syntax atomic("[∗list]") ident ";" ident " ∈ " term ";" term ", " term : term +-- Notation for bigSepL2 with index (two lists) +syntax atomic("[∗list]") ident " ↦ " ident ";" ident " ∈ " term ";" term ", " term : term + +-- Notation for bigAndL without index +syntax atomic("[∧list]") ident " ∈ " term ", " term : term +-- Notation for bigAndL with index +syntax atomic("[∧list]") ident " ↦ " ident " ∈ " term ", " term : term + +-- Notation for bigOrL without index +syntax atomic("[∨list]") ident " ∈ " term ", " term : term +-- Notation for bigOrL with index +syntax atomic("[∨list]") ident " ↦ " ident " ∈ " term ", " term : term + +macro_rules + | `([∗list] $x:ident ∈ $l, $P) => `(bigSepL (fun _ $x => $P) $l) + | `([∗list] $k:ident ↦ $x:ident ∈ $l, $P) => `(bigSepL (fun $k $x => $P) $l) + | `([∧list] $x:ident ∈ $l, $P) => `(bigAndL (fun _ $x => $P) $l) + | `([∧list] $k:ident ↦ $x:ident ∈ $l, $P) => `(bigAndL (fun $k $x => $P) $l) + | `([∨list] $x:ident ∈ $l, $P) => `(bigOrL (fun _ $x => $P) $l) + | `([∨list] $k:ident ↦ $x:ident ∈ $l, $P) => `(bigOrL (fun $k $x => $P) $l) + +-- iprop macro rules +macro_rules + | `(iprop([∗list] $x:ident ∈ $l, $P)) => `(bigSepL (fun _ $x => iprop($P)) $l) + | `(iprop([∗list] $k:ident ↦ $x:ident ∈ $l, $P)) => `(bigSepL (fun $k $x => iprop($P)) $l) + | `(iprop([∧list] $x:ident ∈ $l, $P)) => `(bigAndL (fun _ $x => iprop($P)) $l) + | `(iprop([∧list] $k:ident ↦ $x:ident ∈ $l, $P)) => `(bigAndL (fun $k $x => iprop($P)) $l) + | `(iprop([∨list] $x:ident ∈ $l, $P)) => `(bigOrL (fun _ $x => iprop($P)) $l) + | `(iprop([∨list] $k:ident ↦ $x:ident ∈ $l, $P)) => `(bigOrL (fun $k $x => iprop($P)) $l) + +end List + +/-! # BI-Instantiated Big Operators over Maps +- `bigSepM`: Big separating conjunction `[∗map]` +- `bigAndM`: Big conjunction `[∧map]` +-/ + +section Map +/-! ## Core Definitions -/ + +/-- Big separating conjunction over a map. + `bigSepM Φ m` computes `∗_{k ↦ v ∈ m} Φ k v` -/ +abbrev bigSepM [BI PROP] {M : Type _} {K : Type _} {V : Type _} [FiniteMap M K V] + (Φ : K → V → PROP) (m : M) : PROP := + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) + +/-- Big conjunction over a map. + `bigAndM Φ m` computes `∧_{k ↦ v ∈ m} Φ k v` -/ +abbrev bigAndM [BI PROP] {M : Type _} {K : Type _} {V : Type _} [FiniteMap M K V] + (Φ : K → V → PROP) (m : M) : PROP := + bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList m) + +/-! ## Notation -/ + +-- Notation for bigSepM without key binding +syntax atomic("[∗map]") ident " ∈ " term ", " term : term +-- Notation for bigSepM with key binding +syntax atomic("[∗map]") ident " ↦ " ident " ∈ " term ", " term : term + +-- Notation for bigAndM without key binding +syntax atomic("[∧map]") ident " ∈ " term ", " term : term +-- Notation for bigAndM with key binding +syntax atomic("[∧map]") ident " ↦ " ident " ∈ " term ", " term : term + +macro_rules + | `([∗map] $x:ident ∈ $m, $P) => `(bigSepM (fun _ $x => $P) $m) + | `([∗map] $k:ident ↦ $x:ident ∈ $m, $P) => `(bigSepM (fun $k $x => $P) $m) + | `([∧map] $x:ident ∈ $m, $P) => `(bigAndM (fun _ $x => $P) $m) + | `([∧map] $k:ident ↦ $x:ident ∈ $m, $P) => `(bigAndM (fun $k $x => $P) $m) + +-- iprop macro rules +macro_rules + | `(iprop([∗map] $x:ident ∈ $m, $P)) => `(bigSepM (fun _ $x => iprop($P)) $m) + | `(iprop([∗map] $k:ident ↦ $x:ident ∈ $m, $P)) => `(bigSepM (fun $k $x => iprop($P)) $m) + | `(iprop([∧map] $x:ident ∈ $m, $P)) => `(bigAndM (fun _ $x => iprop($P)) $m) + | `(iprop([∧map] $k:ident ↦ $x:ident ∈ $m, $P)) => `(bigAndM (fun $k $x => iprop($P)) $m) + +end Map + +/-! # BI-Instantiated Big Operators over Sets +- `bigSepS`: Big separating conjunction `[∗set]` +-/ + +section Set + +/-! ## Core Definitions -/ + +/-- Big separating conjunction over a set. + `bigSepS Φ S` computes `∗_{x ∈ S} Φ x` + + Corresponds to `big_opS` in Rocq Iris. -/ +abbrev bigSepS [BI PROP] {S : Type _} {A : Type _} [FiniteSet S A] + (Φ : A → PROP) (s : S) : PROP := + bigOpL sep emp (fun _ x => Φ x) (toList s) + +/-! ## Notation -/ + +-- Notation for bigSepS +syntax atomic("[∗set]") ident " ∈ " term ", " term : term + +macro_rules + | `([∗set] $x:ident ∈ $s, $P) => `(bigSepS (fun $x => $P) $s) + +-- iprop macro rules +macro_rules + | `(iprop([∗set] $x:ident ∈ $s, $P)) => `(bigSepS (fun $x => iprop($P)) $s) + +end Set + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigOrList.lean b/src/Iris/BI/BigOp/BigOrList.lean new file mode 100644 index 00000000..ca5bcaff --- /dev/null +++ b/src/Iris/BI/BigOp/BigOrList.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp + +namespace Iris.BI + +open Iris.Algebra +open BIBase + +/-! # Big Disjunction over Lists -/ + +variable {PROP : Type _} [BI PROP] {A : Type _} + +namespace BigOrL + +/-- Corresponds to `big_orL_nil` in Rocq Iris. -/ +@[simp] +theorem nil {Φ : Nat → A → PROP} : + ([∨list] k ↦ x ∈ ([] : List A), Φ k x) ⊣⊢ iprop(False) := by + simp only [bigOrL, bigOpL] + exact .rfl + +/-- Corresponds to `big_orL_nil'` in Rocq Iris. -/ +theorem nil' {Φ : Nat → A → PROP} {l : List A} (h : l = []) : + ([∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ iprop(False) := by + subst h; exact nil + +/-- Corresponds to `big_orL_cons` in Rocq Iris. -/ +theorem cons {Φ : Nat → A → PROP} {x : A} {xs : List A} : + ([∨list] k ↦ y ∈ (x :: xs), Φ k y) ⊣⊢ Φ 0 x ∨ [∨list] n ↦ y ∈ xs, Φ (n + 1) y := by + simp only [bigOrL, bigOpL] + exact .rfl + +/-- Corresponds to `big_orL_singleton` in Rocq Iris. -/ +theorem singleton {Φ : Nat → A → PROP} {x : A} : + ([∨list] k ↦ y ∈ [x], Φ k y) ⊣⊢ Φ 0 x := + equiv_iff.mp (BigOpL.singleton Φ x) + +/-- Corresponds to `big_orL_app` in Rocq Iris. -/ +theorem app {Φ : Nat → A → PROP} {l₁ l₂ : List A} : + ([∨list] k ↦ x ∈ (l₁ ++ l₂), Φ k x) ⊣⊢ + ([∨list] k ↦ x ∈ l₁, Φ k x) ∨ [∨list] n ↦ x ∈ l₂, Φ (n + l₁.length) x := + equiv_iff.mp (BigOpL.append Φ l₁ l₂) + +/-- Corresponds to `big_orL_snoc` in Rocq Iris. -/ +theorem snoc {Φ : Nat → A → PROP} {l : List A} {x : A} : + ([∨list] k ↦ y ∈ (l ++ [x]), Φ k y) ⊣⊢ ([∨list] k ↦ y ∈ l, Φ k y) ∨ Φ l.length x := + equiv_iff.mp (BigOpL.snoc Φ l x) + +/-- Corresponds to `big_orL_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ⊢ Ψ k x) : + ([∨list] k ↦ x ∈ l, Φ k x) ⊢ [∨list] k ↦ x ∈ l, Ψ k x := by + induction l generalizing Φ Ψ with + | nil => exact Entails.rfl + | cons y ys ih => + simp only [bigOrL, bigOpL] + apply or_mono + · exact h 0 y rfl + · apply ih + intro k x hget + exact h (k + 1) x hget + +/-- Corresponds to `big_orL_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ≡ Ψ k x) : + ([∨list] k ↦ x ∈ l, Φ k x) ≡ [∨list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr h + +/-- No direct Rocq equivalent; unconditional version of `proper`. -/ +theorem congr {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Φ k x ≡ Ψ k x) : + ([∨list] k ↦ x ∈ l, Φ k x) ≡ [∨list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr' h + +/-- Corresponds to `big_orL_false` in Rocq Iris. -/ +theorem false_l {l : List A} : + ([∨list] _k ∈ l, iprop(False : PROP)) ≡ iprop(False) := + BigOpL.unit_const l + +/-- Corresponds to `big_orL_or` in Rocq Iris. -/ +theorem or' {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∨list] k ↦ x ∈ l, iprop(Φ k x ∨ Ψ k x)) ≡ + iprop(([∨list] k ↦ x ∈ l, Φ k x) ∨ [∨list] k ↦ x ∈ l, Ψ k x) := + BigOpL.op_distr Φ Ψ l + +/-- No direct Rocq equivalent; reverse direction of `or'`. -/ +theorem or_2 {Φ Ψ : Nat → A → PROP} {l : List A} : + iprop(([∨list] k ↦ x ∈ l, Φ k x) ∨ [∨list] k ↦ x ∈ l, Ψ k x) ≡ + [∨list] k ↦ x ∈ l, iprop(Φ k x ∨ Ψ k x) := + or'.symm + +/-- Corresponds to `big_orL_take_drop` in Rocq Iris. -/ +theorem take_drop {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + ([∨list] k ↦ x ∈ l, Φ k x) ≡ + iprop(([∨list] k ↦ x ∈ (l.take n), Φ k x) ∨ [∨list] k ↦ x ∈ (l.drop n), Φ (n + k) x) := + BigOpL.take_drop Φ l n + +/-- Corresponds to `big_orL_fmap` in Rocq Iris. -/ +theorem fmap {B : Type _} (f : A → B) {Φ : Nat → B → PROP} {l : List A} : + ([∨list] k ↦ y ∈ (l.map f), Φ k y) ≡ [∨list] k ↦ x ∈ l, Φ k (f x) := by + induction l generalizing Φ with + | nil => simp only [List.map_nil]; exact OFE.Equiv.rfl + | cons x xs ih => + simp only [List.map_cons, bigOrL, bigOpL] + exact Monoid.op_proper OFE.Equiv.rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_orL_intro` in Rocq Iris. -/ +theorem intro {Φ : Nat → A → PROP} {l : List A} {k : Nat} {x : A} + (h : l[k]? = some x) : + Φ k x ⊢ [∨list] i ↦ y ∈ l, Φ i y := by + induction l generalizing k Φ with + | nil => simp at h + | cons y ys ih => + simp only [bigOrL, bigOpL] + cases k with + | zero => + simp at h + subst h + exact or_intro_l + | succ j => + simp at h + exact (ih (Φ := fun n => Φ (n + 1)) h).trans or_intro_r + +/-- Corresponds to `big_orL_exist` in Rocq Iris. -/ +theorem exist {Φ : Nat → A → PROP} {l : List A} : + ([∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ ∃ k, ∃ x, iprop(⌜l[k]? = some x⌝ ∧ Φ k x) := by + constructor + · induction l generalizing Φ with + | nil => simp only [bigOrL, bigOpL]; exact false_elim + | cons y ys ih => + simp only [bigOrL, bigOpL] + apply or_elim + · exact exists_intro' 0 (exists_intro' y (and_intro (pure_intro rfl) .rfl)) + · refine ih.trans (exists_elim fun k => exists_intro' (k + 1) .rfl) + · exact exists_elim fun k => exists_elim fun x => pure_elim_l (intro ·) + +/-- Corresponds to `big_orL_pure` in Rocq Iris. -/ +theorem pure {φ : Nat → A → Prop} {l : List A} : + ([∨list] k ↦ x ∈ l, (⌜φ k x⌝ : PROP)) ⊣⊢ iprop(⌜∃ k x, l[k]? = some x ∧ φ k x⌝ : PROP) := + exist.trans <| (exists_congr fun _ => (exists_congr fun _ => pure_and).trans pure_exists).trans pure_exists + +/-- Corresponds to `big_orL_sep_l` in Rocq Iris. -/ +theorem sep_l {P : PROP} {Φ : Nat → A → PROP} {l : List A} : + iprop(P ∗ [∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∨list] k ↦ x ∈ l, iprop(P ∗ Φ k x) := + (sep_congr .rfl exist).trans <| sep_exists_l.trans <| (exists_congr fun _ => + sep_exists_l.trans <| exists_congr fun _ => + (sep_congr .rfl persistent_and_affinely_sep_l).trans <| + sep_assoc.symm.trans <| (sep_congr sep_comm .rfl).trans <| + sep_assoc.trans persistent_and_affinely_sep_l.symm).trans exist.symm + +/-- Corresponds to `big_orL_sep_r` in Rocq Iris. -/ +theorem sep_r {Φ : Nat → A → PROP} {P : PROP} {l : List A} : + iprop(([∨list] k ↦ x ∈ l, Φ k x) ∗ P) ⊣⊢ [∨list] k ↦ x ∈ l, iprop(Φ k x ∗ P) := + sep_comm.trans <| sep_l.trans (equiv_iff.mp (congr fun _ _ => equiv_iff.mpr sep_comm)) + +/-- Corresponds to `big_orL_elem_of` in Rocq Iris. -/ +theorem elem_of {Φ : A → PROP} {l : List A} {x : A} + (h : x ∈ l) : + Φ x ⊢ [∨list] y ∈ l, Φ y := by + induction l with + | nil => simp at h + | cons y ys ih => + simp only [bigOrL, bigOpL] + cases h with + | head => exact or_intro_l + | tail _ hmem => exact (ih hmem).trans or_intro_r + +/-- Corresponds to `big_orL_bind` in Rocq Iris. -/ +theorem bind {B : Type _} (f : A → List B) {Φ : B → PROP} {l : List A} : + ([∨list] y ∈ (l.flatMap f), Φ y) ⊣⊢ + [∨list] x ∈ l, [∨list] y ∈ (f x), Φ y := by + induction l with + | nil => exact .rfl + | cons x xs ih => + simp only [List.flatMap_cons, bigOrL, bigOpL] + exact app.trans (or_congr .rfl ih) + +/-- Corresponds to `big_orL_persistently` in Rocq Iris. -/ +theorem persistently {Φ : Nat → A → PROP} {l : List A} : + iprop( [∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∨list] k ↦ x ∈ l, iprop( Φ k x) := + equiv_iff.mp (BigOpL.commute bi_persistently_or_homomorphism Φ l) + +/-- Corresponds to `big_orL_later` in Rocq Iris. + Later distributes over non-empty big disjunctions. -/ +theorem later {Φ : Nat → A → PROP} {l : List A} (hne : l ≠ []) : + iprop(▷ [∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∨list] k ↦ x ∈ l, iprop(▷ Φ k x) := + equiv_iff.mp (BigOpL.commute_weak bi_later_or_weak_homomorphism Φ l hne) + +/-- Corresponds to `big_orL_laterN` in Rocq Iris. -/ +theorem laterN {Φ : Nat → A → PROP} {l : List A} {n : Nat} (hne : l ≠ []) : + iprop(▷^[n] [∨list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∨list] k ↦ x ∈ l, iprop(▷^[n] Φ k x) := by + induction n with + | zero => exact .rfl + | succ m ih => exact (later_congr ih).trans (later hne) + +/-- Corresponds to `big_orL_Permutation` in Rocq Iris. -/ +theorem perm {Φ : A → PROP} {l₁ l₂ : List A} (hp : l₁.Perm l₂) : + ([∨list] x ∈ l₁, Φ x) ≡ [∨list] x ∈ l₂, Φ x := + BigOpL.perm Φ hp + +/-- Corresponds to `big_orL_submseteq` in Rocq Iris. -/ +theorem submseteq {Φ : A → PROP} {l₁ l₂ l : List A} + (h : (l₁ ++ l).Perm l₂) : + ([∨list] x ∈ l₁, Φ x) ⊢ [∨list] x ∈ l₂, Φ x := by + have hperm := (equiv_iff.mp (perm (Φ := Φ) h)).1 + have step1 : ([∨list] x ∈ l₁, Φ x) ⊢ ([∨list] x ∈ l₁, Φ x) ∨ [∨list] x ∈ l, Φ x := + or_intro_l (Q := [∨list] x ∈ l, Φ x) + have step2 : (([∨list] x ∈ l₁, Φ x) ∨ [∨list] x ∈ l, Φ x) ⊢ [∨list] x ∈ (l₁ ++ l), Φ x := + (app (Φ := fun _ => Φ) (l₁ := l₁) (l₂ := l)).2 + exact step1.trans (step2.trans hperm) + +/-- Corresponds to `big_orL_mono'` in Rocq Iris. -/ +theorem mono' {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Φ k x ⊢ Ψ k x) : + ([∨list] k ↦ x ∈ l, Φ k x) ⊢ [∨list] k ↦ x ∈ l, Ψ k x := + mono fun k x _ => h k x + +/-- Corresponds to `big_orL_id_mono'` in Rocq Iris. -/ +theorem id_mono' {l₁ l₂ : List PROP} + (hlen : l₁.length = l₂.length) + (h : ∀ (i : Nat) (P Q : PROP), l₁[i]? = some P → l₂[i]? = some Q → P ⊢ Q) : + ([∨list] P ∈ l₁, P) ⊢ [∨list] P ∈ l₂, P := by + induction l₁ generalizing l₂ with + | nil => + cases l₂ with + | nil => exact Entails.rfl + | cons _ _ => simp at hlen + | cons P Ps ih => + cases l₂ with + | nil => simp at hlen + | cons Q Qs => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [bigOrL, bigOpL] + have h0 : P ⊢ Q := h 0 P Q rfl rfl + have htail : ∀ (i : Nat) (P' Q' : PROP), Ps[i]? = some P' → Qs[i]? = some Q' → P' ⊢ Q' := + fun i P' Q' hp hq => h (i + 1) P' Q' hp hq + exact or_mono h0 (ih hlen htail) + +/-- Corresponds to `big_orL_nil_persistent` in Rocq Iris (typeclass instance). -/ +instance nil_persistent {Φ : Nat → A → PROP} : + Persistent ([∨list] k ↦ x ∈ ([] : List A), Φ k x) := by + simp only [bigOrL, bigOpL] + infer_instance + +/-- Corresponds to `big_orL_persistent` in Rocq Iris (conditional version). -/ +theorem persistent_cond {Φ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Persistent (Φ k x)) : + Persistent ([∨list] k ↦ x ∈ l, Φ k x) where + persistent := by + induction l generalizing Φ with + | nil => + simp only [bigOrL, bigOpL] + exact (false_elim (P := iprop( (False : PROP)))) + | cons y ys ih => + simp only [bigOrL, bigOpL] + have h0 : Persistent (Φ 0 y) := h 0 y rfl + have htail : ∀ k x, ys[k]? = some x → Persistent (Φ (k + 1) x) := fun k x hget => h (k + 1) x hget + have iha := ih htail + apply or_elim + · exact h0.persistent.trans (persistently_mono or_intro_l) + · exact iha.trans (persistently_mono or_intro_r) + +/-- Corresponds to `big_orL_persistent'` in Rocq Iris (typeclass instance). -/ +instance persistent {Φ : Nat → A → PROP} {l : List A} [∀ k x, Persistent (Φ k x)] : + Persistent ([∨list] k ↦ x ∈ l, Φ k x) := + persistent_cond fun _ _ _ => inferInstance + +/-- Corresponds to `big_orL_zip_seq` in Rocq Iris. -/ +theorem zip_seq {Φ : Nat × A → PROP} {n : Nat} {l : List A} : + ([∨list] ky ∈ ((List.range' n l.length).zip l), Φ ky) ≡ + [∨list] i ↦ x ∈ l, Φ (n + i, x) := + BigOpL.zip_seq (op := or) (unit := iprop(False)) Φ n l + +/-! ## Missing Lemmas from Rocq Iris + +The following lemmas from Rocq Iris are not ported: +- `big_orL_ne`: OFE-level non-expansiveness (handled at algebra layer) +- `big_orL_timeless`, `big_orL_timeless'`: Requires `or_timeless` infrastructure +-/ + +end BigOrL + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigSepList.lean b/src/Iris/BI/BigOp/BigSepList.lean new file mode 100644 index 00000000..68a5e3f6 --- /dev/null +++ b/src/Iris/BI/BigOp/BigSepList.lean @@ -0,0 +1,1646 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp +import Iris.BI.Instances +import Iris.Std.TC + +namespace Iris.BI + +open Iris.Algebra +open Iris.Std +open BIBase + + +/-! # Big Separating Conjunction over Lists -/ + +namespace BigSepL +variable {PROP : Type _} [BI PROP] {A : Type _} + +/-- Corresponds to `big_sepL_nil` in Rocq Iris. -/ +@[simp] +theorem nil {Φ : Nat → A → PROP} : + ([∗list] k ↦ x ∈ ([] : List A), Φ k x) ⊣⊢ emp := by + simp only [bigSepL, bigOpL] + exact .rfl + +/-- Corresponds to `big_sepL_nil'` in Rocq Iris. -/ +theorem nil' {Φ : Nat → A → PROP} {l : List A} (h : l = []) : + ([∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ emp := by + subst h; exact nil + +/-- Corresponds to second `big_sepL_nil'` in Rocq Iris. -/ +theorem nil'_affine {P : PROP} [Affine P] {Φ : Nat → A → PROP} : + P ⊢ [∗list] k ↦ x ∈ ([] : List A), Φ k x := + Affine.affine.trans nil.2 + +/-- Corresponds to `big_sepL_cons` in Rocq Iris. -/ +theorem cons {Φ : Nat → A → PROP} {x : A} {xs : List A} : + ([∗list] k ↦ y ∈ x :: xs, Φ k y) ⊣⊢ Φ 0 x ∗ [∗list] k ↦ y ∈ xs, Φ (k + 1) y := by + simp only [bigSepL, bigOpL] + exact .rfl + +/-- Corresponds to `big_sepL_singleton` in Rocq Iris. -/ +theorem singleton {Φ : Nat → A → PROP} {x : A} : + ([∗list] k ↦ y ∈ [x], Φ k y) ⊣⊢ Φ 0 x := + equiv_iff.mp (BigOpL.singleton Φ x) + +/-- Corresponds to `big_sepL_app` in Rocq Iris. -/ +theorem app {Φ : Nat → A → PROP} {l₁ l₂ : List A} : + ([∗list] k ↦ x ∈ l₁ ++ l₂, Φ k x) ⊣⊢ + ([∗list] k ↦ x ∈ l₁, Φ k x) ∗ [∗list] k ↦ x ∈ l₂, Φ (k + l₁.length) x := + equiv_iff.mp (BigOpL.append Φ l₁ l₂) + +/-- Corresponds to `big_sepL_snoc` in Rocq Iris. -/ +theorem snoc {Φ : Nat → A → PROP} {l : List A} {x : A} : + ([∗list] k ↦ y ∈ l ++ [x], Φ k y) ⊣⊢ ([∗list] k ↦ y ∈ l, Φ k y) ∗ Φ l.length x := + equiv_iff.mp (BigOpL.snoc Φ l x) + +/-- Corresponds to `big_sepL_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ⊢ Ψ k x) : + ([∗list] k ↦ x ∈ l, Φ k x) ⊢ [∗list] k ↦ x ∈ l, Ψ k x := by + induction l generalizing Φ Ψ with + | nil => exact Entails.rfl + | cons y ys ih => + simp only [bigSepL, bigOpL] + apply sep_mono + · exact h 0 y rfl + · apply ih + intro k x hget + exact h (k + 1) x hget + +/-- Corresponds to `big_sepL_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Φ k x ≡ Ψ k x) : + ([∗list] k ↦ x ∈ l, Φ k x) ≡ [∗list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr h + +/-- Unconditional version of `proper`. No direct Rocq equivalent. -/ +theorem congr {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Φ k x ≡ Ψ k x) : + ([∗list] k ↦ x ∈ l, Φ k x) ≡ [∗list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr' h + +/-- Corresponds to `big_sepL_ne` in Rocq Iris. -/ +theorem ne {Φ Ψ : Nat → A → PROP} {l : List A} {n : Nat} + (h : ∀ k x, l[k]? = some x → Φ k x ≡{n}≡ Ψ k x) : + ([∗list] k ↦ x ∈ l, Φ k x) ≡{n}≡ [∗list] k ↦ x ∈ l, Ψ k x := + BigOpL.congr_ne h + +/-- Corresponds to `big_sepL_mono'` in Rocq Iris. -/ +theorem mono' {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Φ k x ⊢ Ψ k x) : + ([∗list] k ↦ x ∈ l, Φ k x) ⊢ [∗list] k ↦ x ∈ l, Ψ k x := + mono (fun k x _ => h k x) + +/-- Corresponds to `big_sepL_flip_mono'` in Rocq Iris. -/ +theorem flip_mono' {Φ Ψ : Nat → A → PROP} {l : List A} + (h : ∀ k x, Ψ k x ⊢ Φ k x) : + ([∗list] k ↦ x ∈ l, Ψ k x) ⊢ [∗list] k ↦ x ∈ l, Φ k x := + mono (fun k x _ => h k x) + +/-- Corresponds to `big_sepL_id_mono'` in Rocq Iris. -/ +theorem id_mono' {Ps Qs : List PROP} + (hlen : Ps.length = Qs.length) + (h : ∀ (i : Nat) (P Q : PROP), Ps[i]? = some P → Qs[i]? = some Q → P ⊢ Q) : + ([∗list] P ∈ Ps, P) ⊢ [∗list] Q ∈ Qs, Q := by + induction Ps generalizing Qs with + | nil => + cases Qs with + | nil => exact Entails.rfl + | cons _ _ => simp at hlen + | cons P Ps' ih => + cases Qs with + | nil => simp at hlen + | cons Q Qs' => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [bigSepL, bigOpL] + apply sep_mono + · exact h 0 P Q rfl rfl + · apply ih hlen + intro i P' Q' hP' hQ' + exact h (i + 1) P' Q' hP' hQ' + +/-- Corresponds to `big_sepL_persistent'` in Rocq Iris. -/ +instance persistent {Φ : Nat → A → PROP} {l : List A} [∀ k x, Persistent (Φ k x)] : + Persistent ([∗list] k ↦ x ∈ l, Φ k x) where + persistent := by + induction l generalizing Φ with + | nil => + simp only [bigSepL, bigOpL] + exact persistently_emp_2 + | cons x xs ih => + simp only [bigSepL, bigOpL] + have h1 : Φ 0 x ⊢ Φ 0 x := Persistent.persistent + have h2 : bigSepL (fun n => Φ (n + 1)) xs ⊢ bigSepL (fun n => Φ (n + 1)) xs := ih + exact (sep_mono h1 h2).trans persistently_sep_2 + +/-- Corresponds to `big_sepL_affine'` in Rocq Iris. -/ +instance affine {Φ : Nat → A → PROP} {l : List A} [∀ k x, Affine (Φ k x)] : + Affine ([∗list] k ↦ x ∈ l, Φ k x) where + affine := by + induction l generalizing Φ with + | nil => + simp only [bigSepL, bigOpL] + exact Entails.rfl + | cons x xs ih => + simp only [bigSepL, bigOpL] + have h1 : Φ 0 x ⊢ emp := Affine.affine + have h2 : bigSepL (fun n => Φ (n + 1)) xs ⊢ emp := ih + exact (sep_mono h1 h2).trans sep_emp.1 + +/-- Corresponds to `big_sepL_persistent_id` in Rocq Iris. -/ +theorem persistent_id {Ps : List PROP} (hPs : ∀ P, P ∈ Ps → Persistent P) : + Persistent ([∗list] P ∈ Ps, P) where + persistent := by + induction Ps with + | nil => + simp only [bigSepL, bigOpL] + exact persistently_emp_2 + | cons P Ps' ih => + simp only [bigSepL, bigOpL] + have hP : Persistent P := hPs P List.mem_cons_self + have hPs' : ∀ Q, Q ∈ Ps' → Persistent Q := fun Q hQ => hPs Q (List.mem_cons_of_mem _ hQ) + have : Persistent (bigSepL (fun _ (P : PROP) => P) Ps') := ⟨ih hPs'⟩ + have h1 : P ⊢ P := hP.persistent + have h2 : bigSepL (fun _ (P : PROP) => P) Ps' ⊢ bigSepL (fun _ (P : PROP) => P) Ps' := + this.persistent + exact (sep_mono h1 h2).trans persistently_sep_2 + +/-- Corresponds to `big_sepL_affine_id` in Rocq Iris. -/ +theorem affine_id {Ps : List PROP} (hPs : ∀ P, P ∈ Ps → Affine P) : + Affine ([∗list] P ∈ Ps, P) where + affine := by + induction Ps with + | nil => + simp only [bigSepL, bigOpL] + exact Entails.rfl + | cons P Ps' ih => + simp only [bigSepL, bigOpL] + have hP : Affine P := hPs P List.mem_cons_self + have hPs' : ∀ Q, Q ∈ Ps' → Affine Q := fun Q hQ => hPs Q (List.mem_cons_of_mem _ hQ) + have : Affine (bigSepL (fun _ (P : PROP) => P) Ps') := ⟨ih hPs'⟩ + have h1 : P ⊢ emp := hP.affine + have h2 : bigSepL (fun _ (P : PROP) => P) Ps' ⊢ emp := this.affine + exact (sep_mono h1 h2).trans sep_emp.1 + +/-- Corresponds to `big_sepL_persistent` in Rocq Iris. -/ +theorem persistent_cond {Φ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Persistent (Φ k x)) : + Persistent ([∗list] k ↦ x ∈ l, Φ k x) where + persistent := by + induction l generalizing Φ with + | nil => + simp only [bigSepL, bigOpL] + exact persistently_emp_2 + | cons y ys ih => + simp only [bigSepL, bigOpL] + have h0 : Persistent (Φ 0 y) := h 0 y rfl + have hrest : ∀ k x, ys[k]? = some x → Persistent (Φ (k + 1) x) := + fun k x hget => h (k + 1) x hget + have h1 : Φ 0 y ⊢ Φ 0 y := h0.persistent + have hPers : Persistent (bigSepL (fun n => Φ (n + 1)) ys) := ⟨ih hrest⟩ + have h2 : bigSepL (fun n => Φ (n + 1)) ys ⊢ bigSepL (fun n => Φ (n + 1)) ys := + hPers.persistent + exact (sep_mono h1 h2).trans persistently_sep_2 + +/-- Corresponds to `big_sepL_affine` in Rocq Iris. -/ +theorem affine_cond {Φ : Nat → A → PROP} {l : List A} + (h : ∀ k x, l[k]? = some x → Affine (Φ k x)) : + Affine ([∗list] k ↦ x ∈ l, Φ k x) where + affine := by + induction l generalizing Φ with + | nil => + simp only [bigSepL, bigOpL] + exact Entails.rfl + | cons y ys ih => + simp only [bigSepL, bigOpL] + have h0 : Affine (Φ 0 y) := h 0 y rfl + have hrest : ∀ k x, ys[k]? = some x → Affine (Φ (k + 1) x) := + fun k x hget => h (k + 1) x hget + have h1 : Φ 0 y ⊢ emp := h0.affine + have hAff : Affine (bigSepL (fun n => Φ (n + 1)) ys) := ⟨ih hrest⟩ + have h2 : bigSepL (fun n => Φ (n + 1)) ys ⊢ emp := hAff.affine + exact (sep_mono h1 h2).trans sep_emp.1 + +/-- Corresponds to `big_sepL_nil_timeless` in Rocq Iris. -/ +instance nil_timeless [Timeless (emp : PROP)] {Φ : Nat → A → PROP} : + Timeless ([∗list] k ↦ x ∈ ([] : List A), Φ k x) where + timeless := by + simp only [bigSepL, bigOpL] + exact Timeless.timeless + +/-- Corresponds to `big_sepL_emp` in Rocq Iris. -/ +theorem emp_l {l : List A} : + ([∗list] _x ∈ l, (emp : PROP)) ⊣⊢ emp := + equiv_iff.mp (BigOpL.unit_const l) + +/-- Corresponds to `big_sepL_sep` in Rocq Iris. -/ +theorem sep' {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, Φ k x ∗ Ψ k x) ⊣⊢ ([∗list] k ↦ x ∈ l, Φ k x) ∗ [∗list] k ↦ x ∈ l, Ψ k x := + equiv_iff.mp (BigOpL.op_distr Φ Ψ l) + +/-- Corresponds to `big_sepL_sep_2` in Rocq Iris. -/ +theorem sep_2 {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, Φ k x) ∗ ([∗list] k ↦ x ∈ l, Ψ k x) ⊣⊢ [∗list] k ↦ x ∈ l, Φ k x ∗ Ψ k x := + sep'.symm + +/-- Corresponds to `big_sepL_and` in Rocq Iris (one direction only). -/ +theorem and' {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, Φ k x ∧ Ψ k x) ⊢ + ([∗list] k ↦ x ∈ l, Φ k x) ∧ [∗list] k ↦ x ∈ l, Ψ k x := + and_intro (mono fun _ _ _ => and_elim_l) (mono fun _ _ _ => and_elim_r) + +/-- Corresponds to `big_sepL_wand` in Rocq Iris. -/ +theorem wand {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, Φ k x) ⊢ ([∗list] k ↦ x ∈ l, Φ k x -∗ Ψ k x) -∗ [∗list] k ↦ x ∈ l, Ψ k x := + wand_intro <| sep_2.1.trans (mono fun _ _ _ => wand_elim_r) + +/-- Corresponds to `big_sepL_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : Nat → A → Prop} {l : List A} : + ([∗list] k ↦ x ∈ l, ⌜φ k x⌝) ⊢ (⌜∀ k x, l[k]? = some x → φ k x⌝ : PROP) := by + induction l generalizing φ with + | nil => exact pure_intro fun _ _ h => nomatch h + | cons y ys ih => + refine (sep_mono_r ih).trans <| sep_and.trans <| pure_and.1.trans <| pure_mono ?_ + intro ⟨hy, hys⟩ k x hget + match k with + | 0 => exact Option.some.inj hget ▸ hy + | k + 1 => exact hys k x hget + +/-- Corresponds to `big_sepL_affinely_pure_2` in Rocq Iris. -/ +theorem affinely_pure_2 {φ : Nat → A → Prop} {l : List A} : + iprop( ⌜∀ k x, l[k]? = some x → φ k x⌝) ⊢ + ([∗list] k ↦ x ∈ l, ⌜φ k x⌝ : PROP) := by + induction l generalizing φ with + | nil => exact affinely_elim_emp + | cons y ys ih => + refine (affinely_mono <| pure_mono fun h => ⟨h 0 y rfl, fun k x hget => h (k + 1) x hget⟩).trans <| + (affinely_mono pure_and.2).trans <| affinely_and.1.trans <| persistent_and_sep_1.trans (sep_mono_r ih) + +/-- Corresponds to `big_sepL_pure` in Rocq Iris. Requires `BIAffine`. -/ +theorem pure' [BIAffine PROP] {φ : Nat → A → Prop} {l : List A} : + ([∗list] k ↦ x ∈ l, ⌜φ k x⌝) ⊣⊢ (⌜∀ k x, l[k]? = some x → φ k x⌝ : PROP) := + ⟨pure_1, (affine_affinely _).2.trans <| affinely_pure_2.trans (mono fun _ _ _ => affinely_elim)⟩ + +/-- Corresponds to `big_sepL_take_drop` in Rocq Iris. -/ +theorem take_drop {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + ([∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ + ([∗list] k ↦ x ∈ l.take n, Φ k x) ∗ [∗list] k ↦ x ∈ l.drop n, Φ (n + k) x := + equiv_iff.mp (BigOpL.take_drop Φ l n) + +/-- Corresponds to `big_sepL_fmap` in Rocq Iris. -/ +theorem fmap {B : Type _} (f : A → B) {Φ : Nat → B → PROP} {l : List A} : + ([∗list] k ↦ y ∈ l.map f, Φ k y) ≡ [∗list] k ↦ x ∈ l, Φ k (f x) := by + induction l generalizing Φ with + | nil => simp only [List.map_nil]; exact OFE.Equiv.rfl + | cons x xs ih => + simp only [List.map_cons, bigSepL, bigOpL] + exact Monoid.op_proper OFE.Equiv.rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_sepL_omap` in Rocq Iris. -/ +theorem omap {B : Type _} (f : A → Option B) {Φ : B → PROP} {l : List A} : + ([∗list] y ∈ l.filterMap f, Φ y) ≡ + [∗list] x ∈ l, (f x).elim emp Φ := by + induction l with + | nil => exact OFE.Equiv.rfl + | cons x xs ih => + simp only [List.filterMap_cons, bigSepL, bigOpL] + cases hx : f x <;> simp only [Option.elim] + · exact OFE.Equiv.trans ih (OFE.Equiv.symm (equiv_iff.mpr emp_sep)) + · exact Monoid.op_proper OFE.Equiv.rfl ih + +/-- Corresponds to `big_sepL_bind` in Rocq Iris. -/ +theorem bind {B : Type _} (f : A → List B) {Φ : B → PROP} {l : List A} : + ([∗list] y ∈ l.flatMap f, Φ y) ≡ + [∗list] x ∈ l, [∗list] y ∈ f x, Φ y := by + induction l with + | nil => exact OFE.Equiv.rfl + | cons x xs ih => + simp only [List.flatMap_cons, bigSepL, bigOpL] + exact OFE.Equiv.trans (equiv_iff.mpr app) (Monoid.op_proper OFE.Equiv.rfl ih) + +/-- Corresponds to `big_sepL_lookup_acc` in Rocq Iris. -/ +theorem lookup_acc {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + ([∗list] k ↦ y ∈ l, Φ k y) ⊣⊢ + Φ i x ∗ (∀ y, Φ i y -∗ [∗list] k ↦ z ∈ l.set i y, Φ k z) := by + induction l generalizing i Φ x with + | nil => simp at h + | cons z zs ih => + cases i with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at h + subst h + simp only [bigSepL, bigOpL, List.set_cons_zero] + exact ⟨sep_mono_r (forall_intro fun y => wand_intro sep_comm.1), + (sep_mono_r (forall_elim z)).trans wand_elim_r⟩ + | succ j => + simp only [List.getElem?_cons_succ] at h + simp only [bigSepL, bigOpL, List.set_cons_succ] + have ih' := ih (i := j) (Φ := fun n => Φ (n + 1)) h + have hset_eq : zs.set j x = zs := by + apply List.ext_getElem?; intro k + simp only [List.getElem?_set] + by_cases hjk : j = k + · subst hjk; simp only [(List.getElem?_eq_some_iff.mp h).1, ↓reduceIte, h] + · simp only [hjk, ↓reduceIte] + constructor + · refine (sep_mono_r ih'.1).trans <| sep_assoc.2.trans <| (sep_mono_l sep_comm.1).trans <| + sep_assoc.1.trans <| sep_mono_r <| forall_intro fun y => wand_intro ?_ + exact sep_assoc.1.trans <| (sep_mono_r <| (sep_mono_l (forall_elim y)).trans <| + sep_comm.1.trans wand_elim_r) + · conv => rhs; rw [← hset_eq] + exact (sep_mono_r (forall_elim x)).trans wand_elim_r + +/-- Corresponds to `big_sepL_lookup` in Rocq Iris. -/ +theorem lookup {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + [TCOr (∀ k y, Affine (Φ k y)) (Absorbing (Φ i x))] → + ([∗list] k ↦ y ∈ l, Φ k y) ⊢ Φ i x + | TCOr.l => by + have hi : i < l.length := List.getElem?_eq_some_iff.mp h |>.1 + have hx : l[i] = x := List.getElem?_eq_some_iff.mp h |>.2 + have hlen : (l.take i).length = i := List.length_take_of_le (Nat.le_of_lt hi) + have hmiddle : l = l.take i ++ x :: l.drop (i + 1) := by + have htake : l.take (i + 1) = l.take i ++ [x] := by rw [List.take_succ_eq_append_getElem hi, hx] + calc l = l.take (i + 1) ++ l.drop (i + 1) := (List.take_append_drop (i + 1) l).symm + _ = (l.take i ++ [x]) ++ l.drop (i + 1) := by rw [htake] + _ = l.take i ++ ([x] ++ l.drop (i + 1)) := List.append_assoc .. + _ = l.take i ++ (x :: l.drop (i + 1)) := rfl + rw [hmiddle] + refine app.1.trans <| sep_elim_r.trans ?_ + simp only [bigSepL, bigOpL, Nat.zero_add, hlen] + exact sep_elim_l + | TCOr.r => (lookup_acc h).1.trans sep_elim_l + +/-- Corresponds to `big_sepL_insert_acc` in Rocq Iris. -/ +theorem insert_acc {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + ([∗list] k ↦ y ∈ l, Φ k y) ⊢ Φ i x ∗ (∀ y, Φ i y -∗ [∗list] k ↦ z ∈ l.set i y, Φ k z) := + (lookup_acc h).1 + +/-- Corresponds to `big_sepL_elem_of_acc` in Rocq Iris. -/ +theorem elem_of_acc {Φ : A → PROP} {l : List A} {x : A} + (h : x ∈ l) : + ([∗list] y ∈ l, Φ y) ⊢ Φ x ∗ (Φ x -∗ [∗list] y ∈ l, Φ y) := by + have ⟨i, hi, hget⟩ := List.mem_iff_getElem.mp h + have hlookup : l[i]? = some x := List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩ + have hset : l.set i x = l := by + apply List.ext_getElem?; intro k + simp only [List.getElem?_set] + by_cases hik : i = k + · subst hik; simp only [hi, ↓reduceIte, hlookup] + · simp only [hik, ↓reduceIte] + conv => rhs; rw [← hset] + exact (lookup_acc hlookup).1.trans (sep_mono_r (forall_elim x)) + +/-- Corresponds to `big_sepL_elem_of` in Rocq Iris. -/ +theorem elem_of {Φ : A → PROP} {l : List A} {x : A} + (h : x ∈ l) : + [TCOr (∀ y, Affine (Φ y)) (Absorbing (Φ x))] → + ([∗list] y ∈ l, Φ y) ⊢ Φ x + | TCOr.l => by + have ⟨i, hi, hget⟩ := List.mem_iff_getElem.mp h + have hlookup : l[i]? = some x := List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩ + haveI : ∀ (k : Nat) (y : A), Affine ((fun _ y => Φ y) k y) := fun _ y => inferInstance + exact lookup (Φ := fun _ y => Φ y) hlookup + | TCOr.r => by + have ⟨i, hi, hget⟩ := List.mem_iff_getElem.mp h + have hlookup : l[i]? = some x := List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩ + haveI : Absorbing ((fun _ y => Φ y) i x) := inferInstance + exact lookup (Φ := fun _ y => Φ y) hlookup + +/-- Corresponds to `big_sepL_delete` in Rocq Iris. -/ +theorem delete {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + ([∗list] k ↦ y ∈ l, Φ k y) ⊣⊢ + Φ i x ∗ [∗list] k ↦ y ∈ l, if k = i then emp else Φ k y := by + induction l generalizing i Φ with + | nil => simp at h + | cons z zs ih => + cases i with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at h + subst h + simp only [bigSepL, bigOpL, ↓reduceIte] + have hmono : ∀ k y, (Φ (k + 1) y) ⊣⊢ (if k + 1 = 0 then emp else Φ (k + 1) y) := fun k _ => by + simp only [Nat.add_one_ne_zero, ↓reduceIte]; exact .rfl + exact ⟨sep_mono_r <| (mono fun k y _ => (hmono k y).1).trans emp_sep.2, + sep_mono_r <| emp_sep.1.trans (mono fun k y _ => (hmono k y).2)⟩ + | succ j => + simp only [List.getElem?_cons_succ] at h + simp only [bigSepL, bigOpL] + have ih' := ih (i := j) (Φ := fun n => Φ (n + 1)) h + have hne0 : (0 : Nat) ≠ j + 1 := Nat.zero_ne_add_one j + have hmono : ∀ k y, (if k = j then emp else Φ (k + 1) y) ⊣⊢ + (if k + 1 = j + 1 then emp else Φ (k + 1) y) := fun k _ => by + simp only [Nat.add_right_cancel_iff]; exact .rfl + refine (sep_congr_r ih').trans <| sep_left_comm.trans <| sep_congr_r ?_ + simp only [bigSepL, hne0, ↓reduceIte] + exact sep_congr_r (equiv_iff.mp (proper fun k y _ => equiv_iff.mpr (hmono k y))) + +/-- Corresponds to `big_sepL_delete'` in Rocq Iris. -/ +theorem delete' [BIAffine PROP] {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + ([∗list] k ↦ y ∈ l, Φ k y) ⊣⊢ Φ i x ∗ [∗list] k ↦ y ∈ l, ⌜k ≠ i⌝ → Φ k y := by + have hmono : ∀ k y, (if k = i then emp else Φ k y) ⊣⊢ iprop(⌜k ≠ i⌝ → Φ k y) := fun k y => by + by_cases hki : k = i <;> simp only [hki, ↓reduceIte, ne_eq, not_true_eq_false, not_false_eq_true] + · exact ⟨imp_intro' <| (pure_elim_l (R := Φ i y) fun hf => hf.elim), Affine.affine⟩ + · exact true_imp.symm + exact (delete h).trans <| sep_congr_r <| equiv_iff.mp <| proper fun k y _ => equiv_iff.mpr (hmono k y) + +/-- Corresponds to `big_sepL_intro` in Rocq Iris. -/ +theorem intro {P : PROP} {Φ : Nat → A → PROP} {l : List A} [Intuitionistic P] + (h : ∀ k x, l[k]? = some x → P ⊢ Φ k x) : + P ⊢ [∗list] k ↦ x ∈ l, Φ k x := by + induction l generalizing Φ with + | nil => exact Intuitionistic.intuitionistic.trans affinely_elim_emp + | cons y ys ih => + exact Intuitionistic.intuitionistic.trans <| intuitionistically_sep_idem.2.trans <| + sep_mono (intuitionistically_elim.trans (h 0 y rfl)) + (intuitionistically_elim.trans (ih fun k x hget => h (k + 1) x hget)) + +/-- Forward direction of `big_sepL_forall` in Rocq Iris. -/ +theorem forall_1' {Φ : Nat → A → PROP} {l : List A} [BIAffine PROP] + [∀ k x, Persistent (Φ k x)] : + ([∗list] k ↦ x ∈ l, Φ k x) ⊢ ∀ k, ∀ x, iprop(⌜l[k]? = some x⌝ → Φ k x) := by + refine forall_intro fun k => forall_intro fun x => imp_intro' <| pure_elim_l fun hget => ?_ + exact (lookup_acc hget).1.trans <| (sep_mono_l Persistent.persistent).trans <| + sep_comm.1.trans <| persistently_absorb_r.trans persistently_elim + +/-- Backward direction of `big_sepL_forall` in Rocq Iris. -/ +theorem forall_2' {Φ : Nat → A → PROP} {l : List A} [BIAffine PROP] + [∀ k x, Persistent (Φ k x)] : + (∀ k x, iprop(⌜l[k]? = some x⌝ → Φ k x)) ⊢ [∗list] k ↦ x ∈ l, Φ k x := by + induction l generalizing Φ with + | nil => exact Affine.affine + | cons y ys ih => + have head_step : iprop(∀ k x, ⌜(y :: ys)[k]? = some x⌝ → Φ k x) ⊢ Φ 0 y := + (forall_elim 0).trans (forall_elim y) |>.trans <| + (and_intro (pure_intro rfl) .rfl).trans imp_elim_r + have tail_step : iprop(∀ k x, ⌜(y :: ys)[k]? = some x⌝ → Φ k x) + ⊢ iprop(∀ k x, ⌜ys[k]? = some x⌝ → Φ (k + 1) x) := + forall_intro fun k => forall_intro fun z => (forall_elim (k + 1)).trans (forall_elim z) + exact and_self.2.trans (and_mono_l head_step) |>.trans persistent_and_sep_1 |>.trans <| + sep_mono_r (tail_step.trans ih) + +/-- Corresponds to `big_sepL_forall` in Rocq Iris. -/ +theorem forall' {Φ : Nat → A → PROP} {l : List A} [BIAffine PROP] + [∀ k x, Persistent (Φ k x)] : + ([∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ ∀ k, ∀ x, iprop(⌜l[k]? = some x⌝ → Φ k x) := + ⟨forall_1', forall_2'⟩ + +/-- Corresponds to `big_sepL_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, Φ k x) ⊢ □ (∀ k x, iprop(⌜l[k]? = some x⌝ → Φ k x -∗ Ψ k x)) -∗ [∗list] k ↦ x ∈ l, Ψ k x := by + apply wand_intro + have h1 : iprop(□ (∀ k x, ⌜l[k]? = some x⌝ → Φ k x -∗ Ψ k x)) ⊢ bigSepL (fun k x => iprop(Φ k x -∗ Ψ k x)) l := by + haveI : Intuitionistic iprop(□ (∀ k x, ⌜l[k]? = some x⌝ → Φ k x -∗ Ψ k x)) := + intuitionistically_intuitionistic _ + exact intro fun k x hget => intuitionistically_elim.trans <| + (forall_elim k).trans (forall_elim x) |>.trans <| (imp_mono_l (pure_mono fun _ => hget)).trans true_imp.1 + exact (sep_mono_r h1).trans <| sep_2.1.trans (mono fun _ _ _ => wand_elim_r) + +/-- Corresponds to `big_sepL_lookup_acc_impl` in Rocq Iris. -/ +theorem lookup_acc_impl {Φ : Nat → A → PROP} {l : List A} {i : Nat} {x : A} + (h : l[i]? = some x) : + iprop([∗list] k ↦ x ∈ l, Φ k x) ⊢ + Φ i x ∗ ∀ (Ψ: Nat → A → PROP), □ (∀ k y, iprop(⌜l[k]? = some y⌝ → ⌜k ≠ i⌝ → Φ k y -∗ Ψ k y)) -∗ + Ψ i x -∗ ([∗list] k ↦ x ∈ l, Ψ k x) := by + refine (delete h).1.trans <| sep_mono_r <| forall_intro fun Ψ => wand_intro <| wand_intro ?_ + have hdel_psi := (delete (Φ := Ψ) h).2 + refine sep_comm.1.trans <| (sep_mono_r ?_).trans hdel_psi + have htrans : iprop(bigSepL (fun k y => if k = i then emp else Φ k y) l ∗ + □ (∀ k y, ⌜l[k]? = some y⌝ → ⌜k ≠ i⌝ → Φ k y -∗ Ψ k y)) + ⊢ bigSepL (fun k y => if k = i then emp else Ψ k y) l := by + have hwand : iprop(□ (∀ k y, ⌜l[k]? = some y⌝ → ⌜k ≠ i⌝ → Φ k y -∗ Ψ k y)) + ⊢ bigSepL (fun k y => if k = i then emp else iprop(Φ k y -∗ Ψ k y)) l := by + haveI : Intuitionistic iprop(□ (∀ k y, ⌜l[k]? = some y⌝ → ⌜k ≠ i⌝ → Φ k y -∗ Ψ k y)) := + intuitionistically_intuitionistic _ + exact intro fun k y hget => by + by_cases hki : k = i + · subst hki; simp only [↓reduceIte] + exact Intuitionistic.intuitionistic.trans (affinely_elim_emp (PROP := PROP)) + · simp only [hki, ↓reduceIte] + exact intuitionistically_elim.trans <| (forall_elim k).trans (forall_elim y) |>.trans <| + (imp_mono_l (pure_mono fun _ => hget)).trans true_imp.1 |>.trans <| + (imp_mono_l (pure_mono fun _ => hki)).trans true_imp.1 + refine (sep_mono_r hwand).trans <| sep_2.1.trans <| mono fun k y _ => by + by_cases hki : k = i + · subst hki; simp only [↓reduceIte]; exact emp_sep.1 + · simp only [hki, ↓reduceIte]; exact wand_elim_r + exact htrans + +/-- Corresponds to `big_sepL_persistently` in Rocq Iris. Requires `BIAffine`. -/ +theorem persistently {Φ : Nat → A → PROP} {l : List A} [BIAffine PROP] : + iprop( [∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∗list] k ↦ x ∈ l, Φ k x := by + induction l generalizing Φ with + | nil => simp only [bigSepL, bigOpL]; exact persistently_emp' (PROP := PROP) + | cons x xs ih => + simp only [bigSepL, bigOpL] + exact persistently_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +/-- Corresponds to `big_sepL_later` in Rocq Iris. -/ +theorem later [BIAffine PROP] {Φ : Nat → A → PROP} {l : List A} : + iprop(▷ [∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∗list] k ↦ x ∈ l, ▷ Φ k x := by + induction l generalizing Φ with + | nil => simp only [bigSepL, bigOpL]; exact later_emp + | cons x xs ih => + simp only [bigSepL, bigOpL] + exact later_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +/-- Corresponds to `big_sepL_later_2` in Rocq Iris. -/ +theorem later_2 {Φ : Nat → A → PROP} {l : List A} : + ([∗list] k ↦ x ∈ l, ▷ Φ k x) ⊢ iprop(▷ [∗list] k ↦ x ∈ l, Φ k x) := by + induction l generalizing Φ with + | nil => simp only [bigSepL, bigOpL]; exact later_intro + | cons x xs ih => + simp only [bigSepL, bigOpL] + exact (sep_mono_r ih).trans later_sep.2 + +/-- Corresponds to `big_sepL_laterN` in Rocq Iris. -/ +theorem laterN [BIAffine PROP] {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + iprop(▷^[n] [∗list] k ↦ x ∈ l, Φ k x) ⊣⊢ [∗list] k ↦ x ∈ l, ▷^[n] Φ k x := by + induction n with + | zero => exact .rfl + | succ m ih => exact (later_congr ih).trans later + +/-- Corresponds to `big_sepL_laterN_2` in Rocq Iris. -/ +theorem laterN_2 {Φ : Nat → A → PROP} {l : List A} {n : Nat} : + ([∗list] k ↦ x ∈ l, ▷^[n] Φ k x) ⊢ iprop(▷^[n] [∗list] k ↦ x ∈ l, Φ k x) := by + induction n with + | zero => exact .rfl + | succ m ih => exact later_2.trans (later_mono ih) + +/-- Corresponds to `big_sepL_Permutation` in Rocq Iris. -/ +theorem perm {Φ : A → PROP} {l₁ l₂ : List A} (hp : l₁.Perm l₂) : + ([∗list] x ∈ l₁, Φ x) ⊣⊢ [∗list] x ∈ l₂, Φ x := + equiv_iff.mp (BigOpL.perm Φ hp) + +/-- Corresponds to `big_sepL_submseteq` in Rocq Iris. -/ +theorem submseteq {Φ : A → PROP} [∀ x, Affine (Φ x)] {l₁ l₂ l : List A} + (h : (l₁ ++ l).Perm l₂) : + ([∗list] x ∈ l₂, Φ x) ⊢ [∗list] x ∈ l₁, Φ x := by + have hperm := (perm (Φ := Φ) h).2 + have happ := (app (Φ := fun _ => Φ) (l₁ := l₁) (l₂ := l)).1 + exact hperm.trans (happ.trans sep_elim_l) + +/-- Corresponds to `big_sepL_dup` in Rocq Iris. -/ +theorem dup {P : PROP} [Affine P] {l : List A} : + □ (P -∗ P ∗ P) ∗ P ⊢ ([∗list] _x ∈ l, P) := by + induction l with + | nil => exact sep_elim_r.trans Affine.affine + | cons _ _ ih => + refine (sep_mono_l intuitionistically_sep_idem.2).trans <| sep_assoc.1.trans <| + (sep_mono_r <| (sep_mono_l intuitionistically_elim).trans wand_elim_l).trans <| + sep_assoc.2.trans <| (sep_mono_l ih).trans sep_comm.1 + +/-- Corresponds to `big_sepL_replicate` in Rocq Iris. -/ +theorem replicate {P : PROP} {l : List A} : + ([∗list] _x ∈ List.replicate l.length P, P) ⊣⊢ [∗list] _x ∈ l, P := by + induction l with + | nil => + simp only [List.length_nil, List.replicate] + exact .rfl + | cons x xs ih => + simp only [List.length_cons, List.replicate, bigSepL, BigOpL.cons] + exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +/-- Corresponds to `big_sepL_zip_seq` in Rocq Iris. -/ +theorem zip_seq {Φ : Nat × A → PROP} {n : Nat} {l : List A} : + ([∗list] p ∈ (List.range' n l.length).zip l, Φ p) ⊣⊢ + [∗list] i ↦ x ∈ l, Φ (n + i, x) := + equiv_iff.mp (BigOpL.zip_seq Φ n l) + +/-- Lean-only: Big sep over zip with a sequence starting at 0. + No direct Rocq equivalent (uses zero-indexed range). -/ +theorem zip_with_range {Φ : Nat × A → PROP} {l : List A} : + ([∗list] p ∈ (List.range l.length).zip l, Φ p) ⊣⊢ + [∗list] i ↦ x ∈ l, Φ (i, x) := + equiv_iff.mp (BigOpL.zip_with_range Φ l) + +/-- Corresponds to `big_sepL_sep_zip` in Rocq Iris. -/ +theorem sep_zip {B : Type _} {Φ : Nat → A → PROP} {Ψ : Nat → B → PROP} + {l₁ : List A} {l₂ : List B} (hlen : l₁.length = l₂.length) : + ([∗list] i ↦ xy ∈ l₁.zip l₂, Φ i xy.1 ∗ Ψ i xy.2) ⊣⊢ + ([∗list] i ↦ x ∈ l₁, Φ i x) ∗ [∗list] i ↦ y ∈ l₂, Ψ i y := by + induction l₁ generalizing l₂ Φ Ψ with + | nil => + cases l₂ with + | nil => simp only [List.zip_nil_left, bigSepL, bigOpL]; exact emp_sep.symm + | 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.zip_cons_cons, bigSepL, bigOpL] + have ih' := ih (Φ := fun n => Φ (n + 1)) (Ψ := fun n => Ψ (n + 1)) hlen + exact (sep_congr_r ih').trans sep_sep_sep_comm + +/-- Corresponds to `big_sepL_sep_zip_with` in Rocq Iris. -/ +theorem sep_zip_with {B C : Type _} + (f : A → B → C) (g1 : C → A) (g2 : C → B) + {Φ : Nat → A → PROP} {Ψ : Nat → B → PROP} {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) : + ([∗list] i ↦ c ∈ List.zipWith f l₁ l₂, Φ i (g1 c) ∗ Ψ i (g2 c)) ⊣⊢ + ([∗list] i ↦ x ∈ l₁, Φ i x) ∗ [∗list] i ↦ y ∈ l₂, Ψ i y := by + induction l₁ generalizing l₂ Φ Ψ with + | nil => + cases l₂ with + | nil => simp only [List.zipWith_nil_left, bigSepL, bigOpL]; exact emp_sep.symm + | 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, bigSepL, bigOpL, hg1, hg2] + have ih' := ih (l₂ := ys) (Φ := fun n => Φ (n + 1)) (Ψ := fun n => Ψ (n + 1)) hlen + exact (sep_congr_r ih').trans sep_sep_sep_comm + +/-- Corresponds to `big_sepL_zip_with` in Rocq Iris. -/ +theorem zip_with {B C : Type _} (f : A → B → C) {Φ : Nat → C → PROP} + {l₁ : List A} {l₂ : List B} : + ([∗list] k ↦ c ∈ List.zipWith f l₁ l₂, Φ k c) ⊣⊢ + [∗list] k ↦ x ∈ l₁, match l₂[k]? with | some y => Φ k (f x y) | none => emp := by + induction l₁ generalizing l₂ Φ with + | nil => simp only [List.zipWith_nil_left, bigSepL, bigOpL]; exact .rfl + | cons x xs ih => + cases l₂ with + | nil => + simp only [List.zipWith_nil_right, List.getElem?_nil, bigSepL, bigOpL] + exact emp_sep.symm.trans (sep_congr_r (emp_l (l := xs)).symm) + | cons y ys => + simp only [List.zipWith_cons_cons, List.getElem?_cons_zero, List.getElem?_cons_succ, + bigSepL, bigOpL] + exact sep_congr_r (ih (l₂ := ys) (Φ := fun n => Φ (n + 1))) + +/-! ## Commuting Lemmas -/ + +/-- Corresponds to `big_sepL_sepL` in Rocq Iris. -/ +theorem sepL {B : Type _} (Φ : Nat → A → Nat → B → PROP) (l₁ : List A) (l₂ : List B) : + ([∗list] k1↦x1 ∈ l₁, [∗list] k2↦x2 ∈ l₂, Φ k1 x1 k2 x2) ⊣⊢ + ([∗list] k2↦x2 ∈ l₂, [∗list] k1↦x1 ∈ l₁, Φ k1 x1 k2 x2) := by + induction l₁ generalizing Φ with + | nil => + simp only [bigSepL, bigOpL] + constructor + · exact Entails.rfl.trans (equiv_iff.mp (BigOpL.unit_const l₂)).2 + · exact (equiv_iff.mp (BigOpL.unit_const l₂)).1 + | cons x xs ih => + simp only [bigSepL, bigOpL] + have ih' := ih (fun i a j b => Φ (i + 1) a j b) + constructor + · refine (sep_mono_r ih'.1).trans ?_ + exact equiv_iff.mp (BigOpL.op_distr _ _ _) |>.2 + · refine equiv_iff.mp (BigOpL.op_distr _ _ _) |>.1.trans ?_ + exact sep_mono_r ih'.2 + +/-- Corresponds to `big_sepL_sepM` in Rocq Iris. -/ +theorem sepM {B : Type _} {M : Type _} {K : Type _} [FiniteMap M K B] + (Φ : Nat → A → K → B → PROP) (l : List A) (m : M) : + ([∗list] k↦x ∈ l, [∗map] k'↦y ∈ m, Φ k x k' y) ⊣⊢ + ([∗map] k'↦y ∈ m, [∗list] k↦x ∈ l, Φ k x k' y) := by + calc [∗list] k↦x ∈ l, [∗map] k'↦y ∈ m, Φ k x k' y + _ ⊣⊢ [∗list] k↦x ∈ l, [∗list] kv ∈ toList m, Φ k x kv.1 kv.2 := + equiv_iff.mp <| BigSepL.congr fun k x => .rfl + _ ⊣⊢ [∗list] kv ∈ toList m, [∗list] k↦x ∈ l, Φ k x kv.1 kv.2 := + @sepL PROP _ A (K × B) (fun k x _ kv => Φ k x kv.1 kv.2) l (toList m) + _ ⊣⊢ [∗map] k'↦y ∈ m, [∗list] k↦x ∈ l, Φ k x k' y := + equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl + +/-- Corresponds to `big_sepL_sepS` in Rocq Iris. -/ +theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] + (Φ : Nat → A → B → PROP) (l : List A) (X : S) : + ([∗list] k↦x ∈ l, [∗set] y ∈ X, Φ k x y) ⊣⊢ + ([∗set] y ∈ X, [∗list] k↦x ∈ l, Φ k x y) := by + calc [∗list] k↦x ∈ l, [∗set] y ∈ X, Φ k x y + _ ⊣⊢ [∗list] k↦x ∈ l, [∗list] y ∈ toList X, Φ k x y := + equiv_iff.mp <| BigSepL.congr fun k x => .rfl + _ ⊣⊢ [∗list] y ∈ toList X, [∗list] k↦x ∈ l, Φ k x y := + @sepL PROP _ A B (fun k x _ y => Φ k x y) l (toList X) + _ ⊣⊢ [∗set] y ∈ X, [∗list] k↦x ∈ l, Φ k x y := + equiv_iff.mp <| BigSepL.congr fun _ y => .rfl + +/-! ## Missing Lemmas from Rocq Iris + +The following lemmas from Rocq Iris are not ported: +- `big_sepL_timeless`, `big_sepL_timeless'`, `big_sepL_timeless_id`: Requires `sep_timeless` infrastructure +- `big_sepL_zip_seqZ`: Uses Z (integers); only Nat version available +-/ + +end BigSepL + +-- # Big Separating Conjunction over Two Lists +namespace BigSepL2 + +variable {PROP : Type _} [BI PROP] {A B : Type _} + +def bigSepL2 [BI PROP] {A B : Type _} (Φ : Nat → A → B → PROP) + (l1 : List A) (l2 : List B) : PROP := + match l1, l2 with + | [], [] => emp + | x1 :: xs1, x2 :: xs2 => sep (Φ 0 x1 x2) (bigSepL2 (fun n => Φ (n + 1)) xs1 xs2) + | _, _ => iprop(False) + +syntax "[∗ " "list" "] " ident ";" ident " ∈ " term ";" term ", " term : term +syntax "[∗ " "list" "] " ident " ↦ " ident ";" ident " ∈ " term ";" term ", " term : term + +macro_rules + | `([∗list] $x1:ident;$x2:ident ∈ $l1;$l2, $P) => + `(bigSepL2 (fun _ $x1 $x2 => $P) $l1 $l2) + | `([∗list] $k:ident ↦ $x1:ident;$x2:ident ∈ $l1;$l2, $P) => + `(bigSepL2 (fun $k $x1 $x2 => $P) $l1 $l2) + +macro_rules + | `(iprop([∗list] $x1:ident;$x2:ident ∈ $l1;$l2, $P)) => + `(bigSepL2 (fun _ $x1 $x2 => iprop($P)) $l1 $l2) + | `(iprop([∗list] $k:ident ↦ $x1:ident;$x2:ident ∈ $l1;$l2, $P)) => + `(bigSepL2 (fun $k $x1 $x2 => iprop($P)) $l1 $l2) + +namespace BigSepL2 + +/-- Corresponds to `big_sepL2_nil` in Rocq Iris. -/ +@[simp] +theorem nil {Φ : Nat → A → B → PROP} : + ([∗list] k ↦ x;x' ∈ ([] : List A);([] : List B), Φ k x x') ⊣⊢ emp := by + simp only [bigSepL2] + exact .rfl + +/-- Corresponds to `big_sepL2_nil'` in Rocq Iris. -/ +theorem nil' {P : PROP} [Affine P] {Φ : Nat → A → B → PROP} : + P ⊢ ([∗list] k ↦ x;x' ∈ ([] : List A);([] : List B), Φ k x x') := + Affine.affine.trans nil.2 + +/-- Corresponds to `big_sepL2_nil_inv_l` in Rocq Iris. -/ +theorem nil_inv_l {Φ : Nat → A → B → PROP} {l2 : List B} : + ([∗list] k ↦ x;x' ∈ [];l2, Φ k x x') ⊢ ⌜l2 = []⌝ := by + cases l2 with + | nil => exact pure_intro rfl + | cons y ys => simp only [bigSepL2]; exact false_elim + +/-- Corresponds to `big_sepL2_nil_inv_r` in Rocq Iris. -/ +theorem nil_inv_r {Φ : Nat → A → B → PROP} {l1 : List A} : + ([∗list] k ↦ x;x' ∈ l1;[], Φ k x x') ⊢ ⌜l1 = []⌝ := by + cases l1 with + | nil => exact pure_intro rfl + | cons x xs => simp only [bigSepL2]; exact false_elim + +/-- Corresponds to `big_sepL2_cons` in Rocq Iris. -/ +theorem cons {Φ : Nat → A → B → PROP} {x1 : A} {x2 : B} {xs1 : List A} {xs2 : List B} : + ([∗list] k ↦ y1;y2 ∈ x1 :: xs1;x2 :: xs2, Φ k y1 y2) ⊣⊢ + Φ 0 x1 x2 ∗ [∗list] k ↦ y1;y2 ∈ xs1;xs2, Φ (k + 1) y1 y2 := by + simp only [bigSepL2] + exact .rfl + +/-- Corresponds to `big_sepL2_cons_inv_l` in Rocq Iris. -/ +theorem cons_inv_l {Φ : Nat → A → B → PROP} {x1 : A} {xs1 : List A} {l2 : List B} : + ([∗list] k ↦ y1;y2 ∈ x1 :: xs1;l2, Φ k y1 y2) ⊣⊢ + ∃ x2 xs2, ⌜l2 = x2 :: xs2⌝ ∧ (Φ 0 x1 x2 ∗ [∗list] k ↦ y1;y2 ∈ xs1;xs2, Φ (k + 1) y1 y2) := by + cases l2 with + | nil => + simp only [bigSepL2] + constructor + · exact false_elim + · exact exists_elim fun _ => exists_elim fun _ => + and_elim_l.trans (pure_elim' (fun h => nomatch h)) + | cons y ys => + simp only [bigSepL2] + constructor + · exact (and_intro (pure_intro rfl) Entails.rfl).trans + ((exists_intro (Ψ := fun xs2 => iprop(⌜y :: ys = y :: xs2⌝ ∧ + (Φ 0 x1 y ∗ bigSepL2 (fun n => Φ (n + 1)) xs1 xs2))) ys).trans + (exists_intro (Ψ := fun x2 => iprop(∃ xs2, ⌜y :: ys = x2 :: xs2⌝ ∧ + (Φ 0 x1 x2 ∗ bigSepL2 (fun n => Φ (n + 1)) xs1 xs2))) y)) + · exact exists_elim fun x2 => exists_elim fun xs2 => + pure_elim_l fun h => by cases h; exact Entails.rfl + +/-- Corresponds to `big_sepL2_cons_inv_r` in Rocq Iris. -/ +theorem cons_inv_r {Φ : Nat → A → B → PROP} {l1 : List A} {x2 : B} {xs2 : List B} : + ([∗list] k ↦ y1;y2 ∈ l1;x2 :: xs2, Φ k y1 y2) ⊣⊢ + ∃ x1 xs1, ⌜l1 = x1 :: xs1⌝ ∧ (Φ 0 x1 x2 ∗ [∗list] k ↦ y1;y2 ∈ xs1;xs2, Φ (k + 1) y1 y2) := by + cases l1 with + | nil => + simp only [bigSepL2] + constructor + · exact false_elim + · exact exists_elim fun _ => exists_elim fun _ => + and_elim_l.trans (pure_elim' (fun h => nomatch h)) + | cons x xs => + simp only [bigSepL2] + constructor + · exact (and_intro (pure_intro rfl) Entails.rfl).trans + ((exists_intro (Ψ := fun xs1 => iprop(⌜x :: xs = x :: xs1⌝ ∧ + (Φ 0 x x2 ∗ bigSepL2 (fun n => Φ (n + 1)) xs1 xs2))) xs).trans + (exists_intro (Ψ := fun x1 => iprop(∃ xs1, ⌜x :: xs = x1 :: xs1⌝ ∧ + (Φ 0 x1 x2 ∗ bigSepL2 (fun n => Φ (n + 1)) xs1 xs2))) x)) + · exact exists_elim fun x1 => exists_elim fun xs1 => + pure_elim_l fun h => by cases h; exact Entails.rfl + +/-- Corresponds to `big_sepL2_singleton` in Rocq Iris. -/ +theorem singleton {Φ : Nat → A → B → PROP} {x : A} {y : B} : + ([∗list] k ↦ x1;x2 ∈ [x];[y], Φ k x1 x2) ⊣⊢ Φ 0 x y := by + simp only [bigSepL2] + exact sep_emp + +/-! ## Alternative Characterization via Zip -/ + +/-- Corresponds to `big_sepL2_alt` in Rocq Iris. -/ +theorem alt {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊣⊢ + iprop(⌜l1.length = l2.length⌝ ∧ bigSepL (fun k p => Φ k p.1 p.2) (l1.zip l2)) := by + refine ⟨and_intro ?fwd_len ?fwd_sep, pure_elim_l fun hlen => ?bwd⟩ + case fwd_len => + induction l1 generalizing l2 Φ with + | nil => cases l2 <;> simp only [bigSepL2] <;> first | exact pure_intro rfl | exact false_elim + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact false_elim + | cons x2 xs2 => + simp only [bigSepL2, List.length_cons] + refine (sep_mono true_intro ih).trans ?_ + refine (true_sep (PROP := PROP)).1.trans ?_ + exact pure_mono (congrArg (· + 1)) + case fwd_sep => + induction l1 generalizing l2 Φ with + | nil => cases l2 <;> simp only [bigSepL2, List.zip_nil_left, bigSepL, bigOpL] <;> + first | exact .rfl | exact false_elim + | cons x xs ih => + cases l2 with + | nil => simp only [bigSepL2]; exact false_elim + | cons y ys => simp only [bigSepL2, List.zip_cons_cons, bigSepL, bigOpL] + exact sep_mono_r (ih (Φ := fun n => Φ (n + 1))) + case bwd => + induction l1 generalizing l2 Φ with + | nil => cases l2 <;> first | simp only [bigSepL2, List.zip_nil_left, bigSepL, bigOpL]; exact .rfl + | simp at hlen + | cons x xs ih => + cases l2 with + | nil => simp at hlen + | cons y ys => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [bigSepL2, List.zip_cons_cons, bigSepL, bigOpL] + exact sep_mono_r (ih (Φ := fun n => Φ (n + 1)) hlen) + +/-! ## Length Lemma -/ + +/-- Corresponds to `big_sepL2_length` in Rocq Iris. -/ +theorem length {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ iprop(⌜l1.length = l2.length⌝) := + alt.1.trans and_elim_l + +/-! ## Monotonicity and Congruence -/ + +/-- Corresponds to `big_sepL2_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (h : ∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → Φ k x1 x2 ⊢ Ψ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + induction l1 generalizing l2 Φ Ψ with + | nil => cases l2 <;> simp only [bigSepL2] <;> exact .rfl + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact .rfl + | cons x2 xs2 => + simp only [bigSepL2] + exact sep_mono (h 0 x1 x2 rfl rfl) (ih fun k y1 y2 => h (k + 1) y1 y2) + +/-- Corresponds to `big_sepL2_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (h : ∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → Φ k x1 x2 ⊣⊢ Ψ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊣⊢ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + constructor + · apply mono; intro k x1 x2 h1 h2; exact ( (h k x1 x2 h1 h2)).1 + · apply mono; intro k x1 x2 h1 h2; exact ( (h k x1 x2 h1 h2)).2 + +/-- No direct Rocq equivalent; simplified version of `proper` that doesn't require lookup hypotheses. + Useful when the predicate transformation is unconditional. -/ +theorem congr {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (h : ∀ k x1 x2, Φ k x1 x2 ⊣⊢ Ψ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊣⊢ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + apply proper + intro k x1 x2 _ _ + exact h k x1 x2 + +/-- Corresponds to `big_sepL2_ne` in Rocq Iris. -/ +theorem ne {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {n : Nat} + (h : ∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → Φ k x1 x2 ≡{n}≡ Ψ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ≡{n}≡ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + induction l1 generalizing l2 Φ Ψ with + | nil => cases l2 <;> simp only [bigSepL2] <;> exact .rfl + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact .rfl + | cons x2 xs2 => + simp only [bigSepL2] + exact sep_ne.ne (h 0 x1 x2 rfl rfl) (ih fun k y1 y2 => h (k + 1) y1 y2) + +/-- No direct Rocq equivalent; monotonicity without lookup condition. -/ +theorem mono' {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (h : ∀ k x1 x2, Φ k x1 x2 ⊢ Ψ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := + mono (fun k x1 x2 _ _ => h k x1 x2) + +/-- No direct Rocq equivalent; flip version of mono'. -/ +theorem flip_mono' {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (h : ∀ k x1 x2, Ψ k x1 x2 ⊢ Φ k x1 x2) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) ⊢ ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) := + mono (fun k x1 x2 _ _ => h k x1 x2) + +/-- Corresponds to `big_sepL2_persistent'` in Rocq Iris. -/ +instance persistent {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + [∀ k x1 x2, Persistent (Φ k x1 x2)] : + Persistent ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) where + persistent := by + induction l1 generalizing l2 Φ with + | nil => + cases l2 with + | nil => simp only [bigSepL2]; exact persistently_emp_2 + | cons => simp only [bigSepL2]; exact false_elim.trans (persistently_mono false_elim) + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact false_elim.trans (persistently_mono false_elim) + | cons x2 xs2 => + simp only [bigSepL2] + have h1 : Φ 0 x1 x2 ⊢ Φ 0 x1 x2 := Persistent.persistent + have h2 : ([∗list] n ↦ y1;y2 ∈ xs1;xs2, Φ (n + 1) y1 y2) ⊢ + iprop( [∗list] n ↦ y1;y2 ∈ xs1;xs2, Φ (n + 1) y1 y2) := ih + exact (sep_mono h1 h2).trans persistently_sep_2 + +/-- Corresponds to `big_sepL2_affine'` in Rocq Iris. -/ +instance affine {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + [∀ k x1 x2, Affine (Φ k x1 x2)] : + Affine ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) where + affine := by + induction l1 generalizing l2 Φ with + | nil => + cases l2 with + | nil => simp only [bigSepL2]; exact Entails.rfl + | cons => simp only [bigSepL2]; exact false_elim + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact false_elim + | cons x2 xs2 => + simp only [bigSepL2] + have h1 : Φ 0 x1 x2 ⊢ emp := Affine.affine + have h2 : ([∗list] n ↦ y1;y2 ∈ xs1;xs2, Φ (n + 1) y1 y2) ⊢ emp := ih + exact (sep_mono h1 h2).trans ( sep_emp).1 + +/-- Corresponds to `big_sepL2_sep` in Rocq Iris. -/ +theorem sep' {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2 ∗ Ψ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ∗ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + induction l1 generalizing l2 Φ Ψ with + | nil => cases l2 <;> simp only [bigSepL2] <;> first | exact emp_sep.symm + | exact ⟨false_elim, sep_elim_l.trans false_elim⟩ + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact ⟨false_elim, sep_elim_l.trans false_elim⟩ + | cons x2 xs2 => simp only [bigSepL2]; exact (sep_congr .rfl ih).trans sep_sep_sep_comm + +/-- Corresponds to `big_sepL2_sep_2` in Rocq Iris. -/ +theorem sep_2 {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ∗ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2 ∗ Ψ k x1 x2) := + sep'.symm + +/-- Corresponds to `big_sepL2_and` in Rocq Iris. -/ +theorem and' {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2 ∧ Ψ k x1 x2) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ∧ ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + apply and_intro + · exact mono fun k x1 x2 _ _ => and_elim_l + · exact mono fun k x1 x2 _ _ => and_elim_r + +/-- Corresponds to `big_sepL2_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : Nat → A → B → Prop} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, (⌜φ k x1 x2⌝ : PROP)) ⊢ + iprop(⌜∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → φ k x1 x2⌝ : PROP) := + (and_mono .rfl BigSepL.pure_1 |>.trans pure_and.1 |>.trans <| pure_mono fun ⟨_, h⟩ k x1 x2 h1 h2 => + h k (x1, x2) (List.getElem?_zip_eq_some.mpr ⟨h1, h2⟩)) |> alt.1.trans + +/-- Corresponds to `big_sepL2_affinely_pure_2` in Rocq Iris. -/ +theorem affinely_pure_2 {φ : Nat → A → B → Prop} {l1 : List A} {l2 : List B} : + iprop( ⌜l1.length = l2.length ∧ + ∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → φ k x1 x2⌝ : PROP) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, ( ⌜φ k x1 x2⌝ : PROP)) := + (affinely_mono pure_and.2).trans affinely_and.1 |>.trans + (and_mono .rfl <| (affinely_mono <| pure_mono fun h k (p : A × B) hp => + h k p.1 p.2 (List.getElem?_zip_eq_some.mp hp).1 (List.getElem?_zip_eq_some.mp hp).2).trans + BigSepL.affinely_pure_2) |>.trans (and_mono affinely_elim .rfl) |>.trans + (alt (Φ := fun k x1 x2 => iprop( ⌜φ k x1 x2⌝))).2 + +/-- Corresponds to `big_sepL2_pure` in Rocq Iris. -/ +theorem pure [BIAffine PROP] {φ : Nat → A → B → Prop} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, (⌜φ k x1 x2⌝ : PROP)) ⊣⊢ + iprop(⌜l1.length = l2.length ∧ + ∀ k x1 x2, l1[k]? = some x1 → l2[k]? = some x2 → φ k x1 x2⌝ : PROP) := + ⟨(and_intro length pure_1).trans pure_and.1, + (affine_affinely _).2.trans affinely_pure_2 |>.trans (mono fun _ _ _ _ _ => affinely_elim)⟩ + +/-- When the predicate is constantly emp, bigSepL2 reduces to a length equality check. -/ +theorem emp_l [BIAffine PROP] {l1 : List A} {l2 : List B} : + ([∗list] _k ↦ _x1;_x2 ∈ l1;l2, (emp : PROP)) ⊣⊢ iprop(⌜l1.length = l2.length⌝) := by + induction l1 generalizing l2 with + | nil => + cases l2 with + | nil => + simp only [bigSepL2] + exact (true_emp (PROP := PROP)).symm.trans (pure_true (PROP := PROP) rfl).symm + | cons => simp only [bigSepL2]; exact ⟨false_elim, pure_elim' (fun h => nomatch h)⟩ + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact ⟨false_elim, pure_elim' (fun h => nomatch h)⟩ + | cons x2 xs2 => + simp only [bigSepL2, List.length_cons] + exact emp_sep.trans <| ih.trans ⟨pure_mono (congrArg (· + 1)), pure_mono Nat.succ.inj⟩ + +/-- Corresponds to Rocq's `big_sepL2_app`. -/ +theorem app' {Φ : Nat → A → B → PROP} {l1a l1b : List A} {l2a l2b : List B} : + ([∗list] k ↦ x1;x2 ∈ l1a;l2a, Φ k x1 x2) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1b;l2b, Φ (k + l1a.length) x1 x2) -∗ + ([∗list] k ↦ x1;x2 ∈ l1a ++ l1b;l2a ++ l2b, Φ k x1 x2) := by + apply wand_intro' + induction l1a generalizing l2a Φ with + | nil => + cases l2a with + | nil => simp only [bigSepL2, List.nil_append, List.length_nil, Nat.add_zero]; exact sep_emp.1 + | cons => simp only [bigSepL2, List.nil_append]; exact sep_elim_r.trans false_elim + | cons x1 xs1 ih => + cases l2a with + | nil => simp only [bigSepL2, List.nil_append]; exact sep_elim_r.trans false_elim + | cons x2 xs2 => + simp only [bigSepL2, List.cons_append, List.length_cons] + -- Rocq: by rewrite -assoc IH + -- Pattern: A ∗ (B ∗ C) where we need B ∗ (A ∗ C) to apply IH, then reassoc to (B ∗ result) + have hcongr : ([∗list] n ↦ y1;y2 ∈ l1b;l2b, Φ (n + (xs1.length + 1)) y1 y2) ⊣⊢ + ([∗list] n ↦ y1;y2 ∈ l1b;l2b, Φ (n + xs1.length + 1) y1 y2) := + congr fun n _ _ => by simp only [Nat.add_assoc]; exact BiEntails.rfl + refine (sep_mono_l hcongr.1).trans ?_ + refine sep_symm.trans ?_ + refine sep_assoc.1.trans ?_ + refine (sep_mono_r sep_symm).trans ?_ + exact sep_mono_r (ih (Φ := fun n => Φ (n + 1)) (l2a := xs2)) + +/-- Inverse direction of app -/ +private theorem app_inv_core {Φ : Nat → A → B → PROP} {l1a l1b : List A} {l2a l2b : List B} + (hlen : l1a.length = l2a.length ∨ l1b.length = l2b.length) : + ([∗list] k ↦ x1;x2 ∈ l1a ++ l1b;l2a ++ l2b, Φ k x1 x2) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1a;l2a, Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1b;l2b, Φ (k + l1a.length) x1 x2) := by + induction l1a generalizing l2a Φ with + | nil => + cases l2a with + | nil => + simp only [bigSepL2, List.nil_append, List.length_nil, Nat.add_zero] + exact emp_sep.2 + | cons y ys => + cases hlen with + | inl h => exact absurd h (by simp only [List.length_nil, List.length_cons]; omega) + | inr h => + simp only [bigSepL2, List.nil_append] + have hne : l1b.length ≠ (y :: ys ++ l2b).length := by + simp only [List.length_cons, List.length_append]; omega + exact length.trans (pure_elim' fun heq => absurd heq hne) + | cons x1 xs1 ih => + cases l2a with + | nil => + cases hlen with + | inl h => exact absurd h (by simp only [List.length_nil, List.length_cons]; omega) + | inr h => + simp only [bigSepL2, List.nil_append] + have hne : (x1 :: xs1 ++ l1b).length ≠ l2b.length := by + simp only [List.length_cons, List.length_append]; omega + exact length.trans (pure_elim' fun heq => absurd heq hne) + | cons x2 xs2 => + simp only [bigSepL2, List.cons_append, List.length_cons] + have hlen' : xs1.length = xs2.length ∨ l1b.length = l2b.length := by + cases hlen with + | inl h => left; simp only [List.length_cons] at h; omega + | inr h => right; exact h + have ihspec := ih (Φ := fun n => Φ (n + 1)) (l2a := xs2) hlen' + have hcongr : ([∗list] n ↦ y1;y2 ∈ l1b;l2b, Φ (n + xs1.length + 1) y1 y2) ⊣⊢ + ([∗list] n ↦ y1;y2 ∈ l1b;l2b, Φ (n + (xs1.length + 1)) y1 y2) := + congr fun n _ _ => by simp only [Nat.add_assoc]; exact BiEntails.rfl + -- Rocq: by rewrite -assoc IH + refine (sep_mono_r ihspec).trans ?_ + refine (sep_mono_r (sep_mono_r hcongr.2)).trans ?_ + exact sep_assoc.2 + +/-- bi-entailment version when we know one pair of lengths match. -/ +theorem app {Φ : Nat → A → B → PROP} {l1a l1b : List A} {l2a l2b : List B} + (hlen : l1a.length = l2a.length ∨ l1b.length = l2b.length) : + ([∗list] k ↦ x1;x2 ∈ l1a ++ l1b;l2a ++ l2b, Φ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1a;l2a, Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1b;l2b, Φ (k + l1a.length) x1 x2) := + ⟨app_inv_core hlen, sep_symm.trans (wand_elim' app')⟩ + +theorem app_inv {Φ : Nat → A → B → PROP} {l1a l1b : List A} {l2a l2b : List B} + (hlen : l1a.length = l2a.length ∨ l1b.length = l2b.length) : + ([∗list] k ↦ x1;x2 ∈ l1a ++ l1b;l2a ++ l2b, Φ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1a;l2a, Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1b;l2b, Φ (k + l1a.length) x1 x2) := by + exact app hlen + +/-- Corresponds to `big_sepL2_snoc` in Rocq Iris. -/ +theorem snoc {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {x : A} {y : B} : + ([∗list] k ↦ x1;x2 ∈ l1 ++ [x];l2 ++ [y], Φ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ∗ Φ l1.length x y := by + have h := app (Φ := Φ) (l1a := l1) (l2a := l2) (l1b := [x]) (l2b := [y]) (Or.inr rfl) + simp only [bigSepL2, Nat.zero_add] at h + exact h.trans (sep_congr .rfl sep_emp) + +/-- Corresponds to `big_sepL2_fmap_l` in Rocq Iris. -/ +theorem fmap_l {C : Type _} (f : C → A) {Φ : Nat → A → B → PROP} + {l1 : List C} {l2 : List B} : + ([∗list] k ↦ x;y ∈ l1.map f;l2, Φ k x y) ⊣⊢ ([∗list] k ↦ x;y ∈ l1;l2, Φ k (f x) y) := by + induction l1 generalizing l2 Φ with + | nil => + cases l2 with + | nil => simp only [List.map_nil, bigSepL2]; exact BiEntails.rfl + | cons => simp only [List.map_nil, bigSepL2]; exact BiEntails.rfl + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [List.map_cons, bigSepL2]; exact BiEntails.rfl + | cons x2 xs2 => + simp only [List.map_cons, bigSepL2] + exact sep_congr .rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_sepL2_fmap_r` in Rocq Iris. -/ +theorem fmap_r {C : Type _} (f : C → B) {Φ : Nat → A → B → PROP} + {l1 : List A} {l2 : List C} : + ([∗list] k ↦ x;y ∈ l1;l2.map f, Φ k x y) ⊣⊢ ([∗list] k ↦ x;y ∈ l1;l2, Φ k x (f y)) := by + induction l1 generalizing l2 Φ with + | nil => + cases l2 with + | nil => simp only [List.map_nil, bigSepL2]; exact BiEntails.rfl + | cons => simp only [List.map_cons, bigSepL2]; exact BiEntails.rfl + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [List.map_nil, bigSepL2]; exact BiEntails.rfl + | cons x2 xs2 => + simp only [List.map_cons, bigSepL2] + exact sep_congr .rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- No direct Rocq equivalent; combined fmap_l and fmap_r. -/ +theorem fmap {C D : Type _} (f : C → A) (g : D → B) {Φ : Nat → A → B → PROP} + {l1 : List C} {l2 : List D} : + ([∗list] k ↦ x;y ∈ l1.map f;l2.map g, Φ k x y) ⊣⊢ + ([∗list] k ↦ x;y ∈ l1;l2, Φ k (f x) (g y)) := + (fmap_l f).trans (fmap_r g) + +/-- Corresponds to `big_sepL2_flip` in Rocq Iris. -/ +theorem flip {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x;y ∈ l2;l1, Φ k y x) ⊣⊢ ([∗list] k ↦ x;y ∈ l1;l2, Φ k x y) := by + induction l1 generalizing l2 Φ with + | nil => + cases l2 with + | nil => simp only [bigSepL2]; exact BiEntails.rfl + | cons => simp only [bigSepL2]; exact BiEntails.rfl + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2]; exact BiEntails.rfl + | cons x2 xs2 => + simp only [bigSepL2] + exact sep_congr .rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_sepL2_fst_snd` in Rocq Iris. -/ +theorem fst_snd {Φ : Nat → A → B → PROP} {l : List (A × B)} : + ([∗list] k ↦ x;y ∈ l.map Prod.fst;l.map Prod.snd, Φ k x y) ⊣⊢ + bigSepL (fun k p => Φ k p.1 p.2) l := by + have zip_fst_snd : (l.map Prod.fst).zip (l.map Prod.snd) = l := by + induction l with + | nil => rfl + | cons hd tl ih => simp only [List.map_cons, List.zip_cons_cons, ih, Prod.eta] + refine alt.trans ?_ + simp only [List.length_map, zip_fst_snd] + exact true_and + +/-- When we have bigSepL2 of l1' ++ l1'' with some l2, we can split l2 to match. -/ +theorem app_inv_l {Φ : Nat → A → B → PROP} {l1' l1'' : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1' ++ l1'';l2, Φ k x1 x2) ⊢ + iprop(∃ l2' l2'', ⌜l2 = l2' ++ l2''⌝ ∧ + (([∗list] k ↦ x1;x2 ∈ l1';l2', Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1'';l2'', Φ (k + l1'.length) x1 x2))) := by + refine (exists_intro' (l2.take l1'.length) (exists_intro' (l2.drop l1'.length) + (and_intro (pure_intro (List.take_append_drop l1'.length l2).symm) ?_))) + induction l1' generalizing l2 Φ with + | nil => + simp only [List.nil_append, List.length_nil, List.take_zero, List.drop_zero, Nat.add_zero] + exact emp_sep.symm.1.trans (sep_mono_l nil.symm.1) + | cons x1 xs1 ih => + cases l2 with + | nil => simp only [bigSepL2, List.cons_append]; exact false_elim + | cons x2 xs2 => + simp only [bigSepL2, List.cons_append, List.length_cons, List.take_succ_cons, List.drop_succ_cons] + exact (sep_mono_r ih).trans (sep_assoc.symm.1.trans + (sep_mono_r (mono' fun k _ _ => by simp only [Nat.add_assoc]; exact .rfl))) + +/-- When we have bigSepL2 of l1 with l2' ++ l2'', we can split l1 to match. -/ +theorem app_inv_r {Φ : Nat → A → B → PROP} {l1 : List A} {l2' l2'' : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2' ++ l2'', Φ k x1 x2) ⊢ + iprop(∃ l1' l1'', ⌜l1 = l1' ++ l1''⌝ ∧ + (([∗list] k ↦ x1;x2 ∈ l1';l2', Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1'';l2'', Φ (k + l2'.length) x1 x2))) := + flip.symm.1.trans app_inv_l |>.trans <| + exists_mono fun _ => exists_mono fun _ => and_mono .rfl (sep_mono flip.1 flip.1) + +/-- Corresponds to `big_sepL2_insert_acc` in Rocq. -/ +theorem insert_acc {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ + iprop(Φ i x1 x2 ∗ (∀ y1, ∀ y2, Φ i y1 y2 -∗ + [∗list] k ↦ z1;z2 ∈ l1.set i y1;l2.set i y2, Φ k z1 z2)) := by + refine alt.1.trans (pure_elim_l fun hlen => ?_) + have hzip : (l1.zip l2)[i]? = some (x1, x2) := List.getElem?_zip_eq_some.mpr ⟨h1, h2⟩ + refine (BigSepL.insert_acc hzip).trans (sep_mono_r ?_) + refine forall_intro fun y1 => forall_intro fun y2 => (forall_elim (y1, y2)).trans (wand_mono_r ?_) + have hi1 : i < l1.length := List.getElem?_eq_some_iff.mp h1 |>.1 + have hi2 : i < l2.length := List.getElem?_eq_some_iff.mp h2 |>.1 + have hizip : i < (l1.zip l2).length := by simp only [List.length_zip, Nat.min_def]; split <;> omega + have hzip_set : (l1.zip l2).set i (y1, y2) = (l1.set i y1).zip (l2.set i y2) := by + apply List.ext_getElem?; intro k; simp only [List.getElem?_set] + by_cases hik : i = k + · subst hik; simp only [hizip, ↓reduceIte] + exact (List.getElem?_zip_eq_some.mpr ⟨List.getElem?_set_self hi1, List.getElem?_set_self hi2⟩).symm + · simp only [List.zip_eq_zipWith, List.getElem?_zipWith, List.getElem?_set, hik, ↓reduceIte] + have hlen1 : (l1.set i y1).length = (l2.set i y2).length := by simp only [List.length_set]; exact hlen + rw [hzip_set]; exact (and_intro (pure_intro hlen1) .rfl).trans alt.2 + +theorem lookup_acc {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ + iprop(Φ i x1 x2 ∗ (Φ i x1 x2 -∗ [∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2)) := by + have hi1 : i < l1.length := List.getElem?_eq_some_iff.mp h1 |>.1 + have hi2 : i < l2.length := List.getElem?_eq_some_iff.mp h2 |>.1 + have hx1 : l1[i] = x1 := List.getElem?_eq_some_iff.mp h1 |>.2 + have hx2 : l2[i] = x2 := List.getElem?_eq_some_iff.mp h2 |>.2 + have hset1 : l1.set i x1 = l1 := hx1 ▸ List.set_getElem_self hi1 + have hset2 : l2.set i x2 = l2 := hx2 ▸ List.set_getElem_self hi2 + exact (insert_acc h1 h2).trans (sep_mono_r ((forall_elim x1).trans + ((forall_elim x2).trans (hset1.symm ▸ hset2.symm ▸ .rfl)))) + +/-- Corresponds to `big_sepL2_lookup` in Rocq Iris. -/ +theorem lookup {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + [TCOr (∀ j y1 y2, Affine (Φ j y1 y2)) (Absorbing (Φ i x1 x2))] → + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ Φ i x1 x2 + | TCOr.l => by + have hi1 : i < l1.length := List.getElem?_eq_some_iff.mp h1 |>.1 + have hi2 : i < l2.length := List.getElem?_eq_some_iff.mp h2 |>.1 + have hx1 : l1[i] = x1 := List.getElem?_eq_some_iff.mp h1 |>.2 + have hx2 : l2[i] = x2 := List.getElem?_eq_some_iff.mp h2 |>.2 + have hlen1 : (l1.take i).length = i := List.length_take_of_le (Nat.le_of_lt hi1) + have hmiddle1 : l1 = l1.take i ++ x1 :: l1.drop (i + 1) := by + have htake : l1.take (i + 1) = l1.take i ++ [x1] := by rw [List.take_succ_eq_append_getElem hi1, hx1] + exact (List.take_append_drop (i + 1) l1).symm.trans (htake ▸ List.append_assoc ..) + have hmiddle2 : l2 = l2.take i ++ x2 :: l2.drop (i + 1) := by + have htake : l2.take (i + 1) = l2.take i ++ [x2] := by rw [List.take_succ_eq_append_getElem hi2, hx2] + exact (List.take_append_drop (i + 1) l2).symm.trans (htake ▸ List.append_assoc ..) + rw [hmiddle1, hmiddle2] + have hlen2 : (l2.take i).length = i := List.length_take_of_le (Nat.le_of_lt hi2) + have happ := app (Φ := Φ) (l1a := l1.take i) (l1b := x1 :: l1.drop (i + 1)) + (l2a := l2.take i) (l2b := x2 :: l2.drop (i + 1)) (Or.inl (hlen1.trans hlen2.symm)) + simp only [hlen1, bigSepL2, Nat.zero_add] at happ + exact happ.1.trans (sep_elim_r.trans sep_elim_l) + | TCOr.r => (lookup_acc h1 h2).trans sep_elim_l + +/-! ## Higher-Order Lemmas -/ + +/-- Corresponds to `big_sepL2_intro` in Rocq Iris. -/ +theorem intro {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + iprop(⌜l1.length = l2.length⌝ ∧ + □ (∀ k, ∀ x1, ∀ x2, iprop(⌜l1[k]? = some x1⌝ → ⌜l2[k]? = some x2⌝ → Φ k x1 x2))) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) := by + refine pure_elim_l fun hlen => ?_ + suffices h : iprop(□ (∀ k, ∀ x1, ∀ x2, iprop(⌜l1[k]? = some x1⌝ → ⌜l2[k]? = some x2⌝ → Φ k x1 x2))) ⊢ + bigSepL2 Φ l1 l2 from h + induction l1 generalizing l2 Φ with + | nil => cases l2 with + | nil => simp only [bigSepL2]; exact Affine.affine + | cons => simp at hlen + | cons y1 ys1 ih => cases l2 with + | nil => simp at hlen + | cons y2 ys2 => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [bigSepL2] + have head_step : iprop(□ (∀ k, ∀ x1, ∀ x2, + iprop(⌜(y1 :: ys1)[k]? = some x1⌝ → ⌜(y2 :: ys2)[k]? = some x2⌝ → Φ k x1 x2))) ⊢ Φ 0 y1 y2 := + intuitionistically_elim.trans ((forall_elim 0).trans ((forall_elim y1).trans ((forall_elim y2).trans + (((and_intro (pure_intro rfl) .rfl).trans imp_elim_r).trans + ((and_intro (pure_intro rfl) .rfl).trans imp_elim_r))))) + have tail_step : iprop(□ (∀ k, ∀ x1, ∀ x2, + iprop(⌜(y1 :: ys1)[k]? = some x1⌝ → ⌜(y2 :: ys2)[k]? = some x2⌝ → Φ k x1 x2))) ⊢ + iprop(□ (∀ k, ∀ x1, ∀ x2, iprop(⌜ys1[k]? = some x1⌝ → ⌜ys2[k]? = some x2⌝ → Φ (k + 1) x1 x2))) := + intuitionistically_mono (forall_intro fun k => forall_intro fun z1 => forall_intro fun z2 => + ((forall_elim (k + 1)).trans ((forall_elim z1).trans (forall_elim z2))).trans + (by simp only [List.getElem?_cons_succ]; exact .rfl)) + exact intuitionistically_sep_idem.symm.1.trans (sep_mono head_step (tail_step.trans (ih hlen))) + +/-- Corresponds to `big_sepL2_wand` in Rocq Iris. -/ +theorem wand {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2 -∗ Ψ k x1 x2) -∗ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := + wand_intro <| sep_2.1.trans (mono fun _ _ _ _ _ => wand_elim_r) + +/-- Corresponds to `big_sepL2_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ + iprop(□ (∀ k, ∀ x1, ∀ x2, + iprop(⌜l1[k]? = some x1⌝ → ⌜l2[k]? = some x2⌝ → Φ k x1 x2 -∗ Ψ k x1 x2))) -∗ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + refine wand_intro ?_ + have hlen_extract : ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊢ + iprop(⌜l1.length = l2.length⌝ ∧ bigSepL2 Φ l1 l2) := and_self.2.trans (and_mono_l length) + refine (sep_mono_l hlen_extract).trans ((sep_mono_l persistent_and_affinely_sep_l.1).trans + (sep_assoc.1.trans (persistent_and_affinely_sep_l.symm.1.trans ?_))) + refine pure_elim_l fun hlen => ?_ + have hwands := (and_intro (pure_intro hlen) Entails.rfl).trans + (intro (Φ := fun k x1 x2 => iprop(Φ k x1 x2 -∗ Ψ k x1 x2))) + exact (sep_mono_r hwands).trans (sep_2.1.trans (mono fun _ _ _ _ _ => wand_elim_r)) + +/-- Corresponds to `big_sepL2_forall` in Rocq Iris. -/ +theorem forall' [BIAffine PROP] {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} + (hPersistent : ∀ k x1 x2, Persistent (Φ k x1 x2)) : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊣⊢ + iprop(⌜l1.length = l2.length⌝ ∧ + (∀ k, ∀ x1, ∀ x2, iprop(⌜l1[k]? = some x1⌝ → ⌜l2[k]? = some x2⌝ → Φ k x1 x2))) := by + haveI : ∀ k x1 x2, Persistent (Φ k x1 x2) := hPersistent + constructor + · exact and_intro length (forall_intro fun k => forall_intro fun x1 => forall_intro fun x2 => + imp_intro' (pure_elim_l fun h1 => imp_intro' (pure_elim_l fun h2 => lookup h1 h2))) + · refine pure_elim_l fun hlen => ?_ + induction l1 generalizing l2 Φ hPersistent with + | nil => cases l2 with + | nil => simp only [bigSepL2]; exact Affine.affine + | cons => simp at hlen + | cons y1 ys1 ih => cases l2 with + | nil => simp at hlen + | cons y2 ys2 => + simp only [List.length_cons, Nat.add_right_cancel_iff] at hlen + simp only [bigSepL2] + haveI : ∀ k x1 x2, Persistent (Φ k x1 x2) := hPersistent + have head_step : iprop(∀ k, ∀ x1, ∀ x2, + iprop(⌜(y1 :: ys1)[k]? = some x1⌝ → ⌜(y2 :: ys2)[k]? = some x2⌝ → Φ k x1 x2)) ⊢ Φ 0 y1 y2 := + ((forall_elim 0).trans ((forall_elim y1).trans ((forall_elim y2).trans + (((and_intro (pure_intro rfl) .rfl).trans imp_elim_r).trans + ((and_intro (pure_intro rfl) .rfl).trans imp_elim_r))))) + have tail_step : iprop(∀ k, ∀ x1, ∀ x2, + iprop(⌜(y1 :: ys1)[k]? = some x1⌝ → ⌜(y2 :: ys2)[k]? = some x2⌝ → Φ k x1 x2)) ⊢ + iprop(∀ k, ∀ x1, ∀ x2, iprop(⌜ys1[k]? = some x1⌝ → ⌜ys2[k]? = some x2⌝ → Φ (k + 1) x1 x2)) := + forall_intro fun k => forall_intro fun z1 => forall_intro fun z2 => + ((forall_elim (k + 1)).trans ((forall_elim z1).trans (forall_elim z2))).trans + (by simp only [List.getElem?_cons_succ]; exact .rfl) + have hP' : ∀ k x1 x2, Persistent (Φ (k + 1) x1 x2) := fun k x1 x2 => hPersistent (k + 1) x1 x2 + exact (and_self.2.trans (and_mono_l head_step)).trans (persistent_and_sep_1.trans + (sep_mono_r (tail_step.trans (ih hP' hP' hlen)))) + +/-! ## Modality Interaction -/ + +/-- Corresponds to `big_sepL2_persistently` in Rocq Iris. -/ +theorem persistently [BIAffine PROP] {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + iprop( [∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) ⊣⊢ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) := + (persistently_congr alt).trans persistently_and |>.trans (and_congr persistently_pure .rfl) |>.trans + (and_congr .rfl BigSepL.persistently) |>.trans (alt (Φ := fun k x1 x2 => iprop( Φ k x1 x2))).symm + +/-- Corresponds to `big_sepL2_later_2` in Rocq Iris. -/ +theorem later_2 {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, ▷ Φ k x1 x2) ⊢ + iprop(▷ [∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) := + (alt (Φ := fun k x1 x2 => iprop(▷ Φ k x1 x2))).1.trans (and_mono later_intro BigSepL.later_2) |>.trans + later_and.2 |>.trans (later_mono alt.2) + +/-- Corresponds to `big_sepL2_laterN_2` in Rocq Iris. -/ +theorem laterN_2 {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {n : Nat} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, ▷^[n] Φ k x1 x2) ⊢ + iprop(▷^[n] [∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 x2) := by + induction n with + | zero => exact Entails.rfl + | succ m ih => exact later_2.trans (later_mono ih) + +/-- Corresponds to `big_sepL2_sepL` in Rocq Iris. -/ +theorem sepL {Φ1 : Nat → A → PROP} {Φ2 : Nat → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ1 k x1 ∗ Φ2 k x2) ⊣⊢ + iprop(⌜l1.length = l2.length⌝ ∧ (bigSepL Φ1 l1 ∗ bigSepL Φ2 l2)) := by + have h hlen := BigSepL.sep_zip (Φ := Φ1) (Ψ := Φ2) (l₁ := l1) (l₂ := l2) hlen + refine alt.trans ⟨pure_elim_l fun hlen => and_intro (pure_intro hlen) (h hlen).1, + pure_elim_l fun hlen => and_intro (pure_intro hlen) (h hlen).2⟩ + +/-- Corresponds to `big_sepL2_sepL_2` in Rocq Iris. -/ +theorem sepL_2 {Φ1 : Nat → A → PROP} {Φ2 : Nat → B → PROP} {l1 : List A} {l2 : List B} : + iprop(⌜l1.length = l2.length⌝ ∧ bigSepL Φ1 l1) ⊢ bigSepL Φ2 l2 -∗ + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ1 k x1 ∗ Φ2 k x2) := by + refine wand_intro ?_ + -- Rearrange: (⌜len⌝ ∧ Φ1s) ∗ Φ2s ⊢ ⌜len⌝ ∧ (Φ1s ∗ Φ2s) + exact (sep_mono_l persistent_and_affinely_sep_l.1).trans sep_assoc.1 + |>.trans persistent_and_affinely_sep_l.symm.1 |>.trans sepL.2 + +/-- Corresponds to `big_sepL2_reverse_2` in Rocq Iris. -/ +theorem reverse_2 {Φ : A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] _k ↦ x1;x2 ∈ l1;l2, Φ x1 x2) ⊢ + ([∗list] _k ↦ x1;x2 ∈ l1.reverse;l2.reverse, Φ x1 x2) := by + refine (and_self.2.trans (and_mono_l length)).trans (pure_elim_l fun hlen => ?_) + induction l1 generalizing l2 with + | nil => cases l2 <;> simp only [bigSepL2, List.reverse_nil] <;> first | exact .rfl | simp at hlen + | cons x1 xs1 ih => + cases l2 with + | nil => simp at hlen + | cons x2 xs2 => + simp only [List.length_cons] at hlen + simp only [bigSepL2, List.reverse_cons] + exact sep_comm.1.trans (sep_mono_l (ih (Nat.succ.inj hlen))) |>.trans + (snoc (Φ := fun _ => Φ)).2 + +/-- Corresponds to `big_sepL2_reverse` in Rocq Iris. -/ +theorem reverse {Φ : A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] _k ↦ x1;x2 ∈ l1.reverse;l2.reverse, Φ x1 x2) ⊣⊢ + ([∗list] _k ↦ x1;x2 ∈ l1;l2, Φ x1 x2) := by + constructor + · have h1 := reverse_2 (Φ := Φ) (l1 := l1.reverse) (l2 := l2.reverse) + simp only [List.reverse_reverse] at h1 + exact h1 + · exact reverse_2 + +/-! ## Replicate Lemmas -/ + +/-- Corresponds to `big_sepL2_replicate_l` in Rocq Iris. -/ +theorem replicate_l {Φ : Nat → A → B → PROP} {l : List B} {x : A} : + ([∗list] k ↦ x1;x2 ∈ List.replicate l.length x;l, Φ k x1 x2) ⊣⊢ + bigSepL (fun k x2 => Φ k x x2) l := by + induction l generalizing Φ with + | nil => + simp only [List.length_nil, List.replicate_zero, bigSepL2, bigSepL, bigOpL] + exact BiEntails.rfl + | cons y ys ih => + simp only [List.length_cons, List.replicate_succ, bigSepL2, bigSepL, bigOpL] + exact sep_congr .rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_sepL2_replicate_r` in Rocq Iris. -/ +theorem replicate_r {Φ : Nat → A → B → PROP} {l : List A} {x : B} : + ([∗list] k ↦ x1;x2 ∈ l;List.replicate l.length x, Φ k x1 x2) ⊣⊢ + bigSepL (fun k x1 => Φ k x1 x) l := by + induction l generalizing Φ with + | nil => + simp only [List.length_nil, List.replicate_zero, bigSepL2, bigSepL, bigOpL] + exact BiEntails.rfl + | cons y ys ih => + simp only [List.length_cons, List.replicate_succ, bigSepL2, bigSepL, bigOpL] + exact sep_congr .rfl (ih (Φ := fun n => Φ (n + 1))) + +/-- Corresponds to `big_sepL2_app_same_length` in Rocq Iris. -/ +theorem app_same_length {Φ : Nat → A → B → PROP} {l1a l1b : List A} {l2a l2b : List B} + (hlen : l1a.length = l2a.length ∨ l1b.length = l2b.length) : + ([∗list] k ↦ x1;x2 ∈ l1a ++ l1b;l2a ++ l2b, Φ k x1 x2) ⊣⊢ + iprop(([∗list] k ↦ x1;x2 ∈ l1a;l2a, Φ k x1 x2) ∗ + ([∗list] k ↦ x1;x2 ∈ l1b;l2b, Φ (l1a.length + k) x1 x2)) := + (app hlen).trans (sep_congr .rfl (congr fun k _ _ => by simp only [Nat.add_comm]; exact .rfl)) + +/-- No direct Rocq equivalent; when Φ doesn't depend on second argument. -/ +theorem const_sepL_l {Φ : Nat → A → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;_x2 ∈ l1;l2, Φ k x1) ⊣⊢ + iprop(⌜l1.length = l2.length⌝ ∧ bigSepL Φ l1) := by + have fst_zip : ∀ hlen : l1.length = l2.length, (l1.zip l2).map Prod.fst = l1 := by + intro hlen; clear Φ + induction l1 generalizing l2 with + | nil => cases l2 <;> first | rfl | simp at hlen + | cons x xs ih => + cases l2 with + | nil => simp at hlen + | cons y ys => simp only [List.length_cons] at hlen; simp [ih (Nat.succ.inj hlen)] + have hfmap : bigSepL Φ ((l1.zip l2).map Prod.fst) ⊣⊢ bigSepL (fun k p => Φ k p.1) (l1.zip l2) := + equiv_iff.mp (BigSepL.fmap Prod.fst) + refine alt.trans ⟨pure_elim_l fun hlen => and_intro (pure_intro hlen) ?_, + pure_elim_l fun hlen => and_intro (pure_intro hlen) ?_⟩ + · have : bigSepL Φ ((l1.zip l2).map Prod.fst) ⊣⊢ bigSepL Φ l1 := by rw [fst_zip hlen]; exact .rfl + exact (hfmap.symm.trans this).1 + · have : bigSepL Φ l1 ⊣⊢ bigSepL Φ ((l1.zip l2).map Prod.fst) := by rw [fst_zip hlen]; exact .rfl + exact (this.trans hfmap).1 + +/-- No direct Rocq equivalent; when Φ doesn't depend on first argument. -/ +theorem const_sepL_r {Φ : Nat → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ _x1;x2 ∈ l1;l2, Φ k x2) ⊣⊢ + iprop(⌜l1.length = l2.length⌝ ∧ bigSepL Φ l2) := + flip.trans const_sepL_l |>.trans ⟨and_mono (pure_mono Eq.symm) .rfl, and_mono (pure_mono Eq.symm) .rfl⟩ + +/-- Corresponds to `big_sepL2_sep_sepL_l` in Rocq Iris. -/ +theorem sep_sepL_l [BIAffine PROP] {Φ : Nat → A → PROP} {Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x1 ∗ Ψ k x1 x2) ⊣⊢ + iprop(bigSepL Φ l1 ∗ [∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := by + refine sep'.trans (sep_congr_l const_sepL_l) |>.trans ⟨sep_mono and_elim_r .rfl, ?bwd⟩ + refine (sep_mono_r <| (and_intro length .rfl).trans persistent_and_affinely_sep_l.1 |>.trans + (sep_mono_l affinely_elim)).trans sep_assoc.2 |>.trans (sep_mono_l ?_) + exact and_intro (sep_comm.1.trans (sep_mono_l persistently_intro) |>.trans + persistently_absorb_l |>.trans persistently_elim) sep_elim_l + +/-- Corresponds to `big_sepL2_sep_sepL_r` in Rocq Iris. -/ +theorem sep_sepL_r [BIAffine PROP] {Φ : Nat → B → PROP} {Ψ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} : + ([∗list] k ↦ x1;x2 ∈ l1;l2, Φ k x2 ∗ Ψ k x1 x2) ⊣⊢ + iprop(bigSepL Φ l2 ∗ [∗list] k ↦ x1;x2 ∈ l1;l2, Ψ k x1 x2) := + (congr fun _ _ _ => sep_comm).trans flip |>.trans + ((congr fun _ _ _ => sep_comm).trans sep_sepL_l) |>.trans (sep_congr_r flip) + +/-- Corresponds to `big_sepL2_delete` in Rocq Iris. -/ +theorem delete {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} + {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊣⊢ + iprop(Φ i x1 x2 ∗ [∗list] k ↦ y1;y2 ∈ l1;l2, + if k = i then emp else Φ k y1 y2) := by + induction l1 generalizing l2 i Φ with + | nil => simp at h1 + | cons z1 zs1 ih => + cases l2 with + | nil => simp at h2 + | cons z2 zs2 => + cases i with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at h1 h2 + subst h1 h2 + simp only [bigSepL2, ↓reduceIte] + exact sep_congr_r <| (proper fun k _ _ _ _ => by simp).trans emp_sep.symm + | succ j => + simp only [List.getElem?_cons_succ] at h1 h2 + simp only [bigSepL2] + have ih' := ih (i := j) (Φ := fun n => Φ (n + 1)) h1 h2 + refine (sep_congr_r ih').trans sep_left_comm |>.trans (sep_congr_r ?_) + simp only [Nat.zero_ne_add_one, ↓reduceIte] + exact sep_congr_r <| proper fun k _ _ _ _ => by + simp only [Nat.add_right_cancel_iff]; exact .rfl + +/-- Corresponds to `big_sepL2_delete'` in Rocq Iris. -/ +theorem delete' [BIAffine PROP] {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} + {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊣⊢ + iprop(Φ i x1 x2 ∗ [∗list] k ↦ y1;y2 ∈ l1;l2, ⌜k ≠ i⌝ → Φ k y1 y2) := + (delete h1 h2).trans <| sep_congr .rfl <| congr fun k y1 y2 => by + by_cases hki : k = i + · subst hki; simp only [↓reduceIte, ne_eq, not_true_eq_false] + exact ⟨imp_intro' ((pure_elim_l (fun hf => False.elim hf)).trans .rfl), Affine.affine⟩ + · simp only [hki, ↓reduceIte, ne_eq, not_false_eq_true]; exact true_imp.symm + + +/-- Corresponds to `big_sepL2_lookup_acc_impl` in Rocq Iris. -/ +theorem lookup_acc_impl {Φ : Nat → A → B → PROP} {l1 : List A} {l2 : List B} {i : Nat} {x1 : A} {x2 : B} + (h1 : l1[i]? = some x1) (h2 : l2[i]? = some x2) : + ([∗list] k ↦ y1;y2 ∈ l1;l2, Φ k y1 y2) ⊢ + iprop(Φ i x1 x2 ∗ ∀ Ψ, □ (∀ k, ∀ y1, ∀ y2, + iprop(⌜l1[k]? = some y1⌝ → ⌜l2[k]? = some y2⌝ → ⌜k ≠ i⌝ → + Φ k y1 y2 -∗ Ψ k y1 y2)) -∗ + Ψ i x1 x2 -∗ bigSepL2 Ψ l1 l2) := by + refine (delete h1 h2).1.trans (sep_mono_r <| forall_intro fun Ψ => wand_intro <| wand_intro ?_) + refine sep_comm.1.trans (sep_mono_r ?_) |>.trans (delete h1 h2).2 + have himpl := impl (Φ := fun k y1 y2 => if k = i then emp else Φ k y1 y2) + (Ψ := fun k y1 y2 => if k = i then emp else Ψ k y1 y2) (l1 := l1) (l2 := l2) + refine (sep_mono_r ?_).trans (wand_elim himpl) + refine intuitionistically_intro' <| forall_intro fun k => forall_intro fun y1 => forall_intro fun y2 => + imp_intro' <| pure_elim_l fun hk1 => imp_intro' <| pure_elim_l fun hk2 => ?_ + by_cases hki : k = i + · subst hki; simp only [↓reduceIte] + exact wand_intro (sep_emp.1.trans Affine.affine) + · simp only [hki, ↓reduceIte] + exact intuitionistically_elim.trans <| (forall_elim k).trans ((forall_elim y1).trans (forall_elim y2)) + |>.trans ((and_intro (pure_intro hk1) .rfl).trans imp_elim_r) + |>.trans ((and_intro (pure_intro hk2) .rfl).trans imp_elim_r) + |>.trans ((and_intro (pure_intro hki) .rfl).trans imp_elim_r) + +end BigSepL2 + +namespace BigSepL + +/-- No direct Rocq equivalent; diagonal BigSepL to BigSepL2. -/ +theorem sepL2_diag {Φ : Nat → A → A → PROP} {l : List A} : + bigSepL (fun k x => Φ k x x) l ⊢ bigSepL2 Φ l l := by + have hzip : l.zip l = l.map (fun x => (x, x)) := by + induction l with + | nil => simp + | cons hd tl ih => simp [ih] + have inner_eq : bigSepL (fun k x => Φ k x x) l ⊣⊢ + bigSepL (fun k p => Φ k p.1 p.2) (l.zip l) := by + rw [hzip] + exact (equiv_iff.mp (BigSepL.fmap (PROP := PROP) (Φ := fun k p => Φ k p.1 p.2) + (fun x => (x, x)) (l := l))).symm + exact (and_intro (pure_intro rfl) .rfl).trans (and_mono .rfl inner_eq.1) |>.trans BigSepL2.alt.2 + +end BigSepL + +/-! ## Missing Lemmas from Rocq Iris + +The following lemmas from Rocq Iris are not ported: +- `big_sepL2_proper_2`: Uses OFE structure on A, B (list element types) +- `big_sepL2_closed`: Meta-lemma (direct inductive proofs used instead) +- `big_sepL2_timeless`, `big_sepL2_timeless'`: Requires `sep_timeless` infrastructure +- `big_sepL2_later_1`, `big_sepL2_later`, `big_sepL2_laterN_1`, `big_sepL2_laterN`: Requires except-0 infrastructure +-/ + +end BigSepL2 + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean new file mode 100644 index 00000000..dca9ab93 --- /dev/null +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -0,0 +1,1294 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp +import Iris.BI.BigOp.BigSepList +import Iris.BI.BigOp.BigSepSet +import Iris.BI.Instances +import Iris.Std.FiniteMapDom +import Iris.Std.List +import Iris.Std.TC + +namespace Iris.BI + +open Iris.Algebra +open Iris.Std +open Iris.Std (domSet ofSet) +open BIBase + +/-! # Big Separating Conjunction over Maps + +Rocq Iris: `iris/bi/big_op.v`, Section `sep_map` -/ + +variable {PROP : Type _} [BI PROP] +variable {M : Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] + +namespace BigSepM + +/-! ## Basic Structural Lemmas -/ + +/-- Corresponds to `big_sepM_empty` in Rocq Iris. -/ +@[simp] +theorem empty {Φ : K → V → PROP} : + ([∗map] k ↦ x ∈ (∅ : M), Φ k x) ⊣⊢ emp := by + simp only [bigSepM, map_to_list_empty, bigOpL] + exact .rfl + +/-- Corresponds to `big_sepM_empty'` in Rocq Iris. -/ +theorem empty' {P : PROP} [Affine P] {Φ : K → V → PROP} : + P ⊢ [∗map] k ↦ x ∈ (∅ : M), Φ k x := + Affine.affine.trans empty.2 + +/-- Corresponds to `big_sepM_singleton` in Rocq Iris. -/ +theorem singleton {Φ : K → V → PROP} {k : K} {v : V} : + ([∗map] k' ↦ x ∈ ({[k := v]} : M), Φ k' x) ⊣⊢ Φ k v := by + have hget : get? (∅ : M) k = none := lookup_empty k + have hperm : (toList (FiniteMap.insert (∅ : M) k v)).Perm ((k, v) :: toList (∅ : M)) := + map_to_list_insert (∅ : M) k v hget + simp only [map_to_list_empty] at hperm + simp only [bigSepM, FiniteMap.singleton] + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M) k v)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) [(k, v)] := + BigOpL.perm (fun kv => Φ kv.1 kv.2) hperm + simp only [bigOpL] at heq + exact (equiv_iff.mp heq).trans ⟨sep_emp.1, sep_emp.2⟩ + +/-- Corresponds to `big_sepM_insert` in Rocq Iris. -/ +theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = none) : + ([∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ + Φ k v ∗ [∗map] k' ↦ x ∈ m, Φ k' x := by + simp only [bigSepM] + have hperm := map_to_list_insert m k v h + have hperm_eq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert m k v)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList m) := + BigOpL.perm _ hperm + simp only [bigOpL] at hperm_eq + exact equiv_iff.mp hperm_eq + +/-- Corresponds to `big_sepM_insert_delete` in Rocq Iris. -/ +theorem insert_delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} : + ([∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ + Φ k v ∗ [∗map] k' ↦ x ∈ Std.delete m k, Φ k' x := by + have heq := FiniteMapLaws.insert_delete_eq m k v + simp only [bigSepM, ← heq] + have herase : get? (Std.delete m k) k = none := lookup_delete_eq m k + have hins := @insert PROP _ M K V _ _ _ Φ (Std.delete m k) k v herase + exact hins + +/-- Corresponds to `big_sepM_delete` in Rocq Iris. -/ +theorem delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ Std.delete m k, Φ k' x := by + simp only [bigSepM] + have hperm := map_to_list_delete m k v h + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList (Std.delete m k)) := + BigOpL.perm _ hperm + simp only [bigOpL] at heq + exact equiv_iff.mp heq + +/-! ## Monotonicity and Congruence -/ + +omit [DecidableEq K] in +/-- Helper: mono on lists directly. -/ +private theorem mono_list {Φ Ψ : K × V → PROP} {l : List (K × V)} + (h : ∀ kv, kv ∈ l → Φ kv ⊢ Ψ kv) : + bigOpL sep emp (fun _ kv => Φ kv) l ⊢ bigOpL sep emp (fun _ kv => Ψ kv) l := by + induction l with + | nil => exact Entails.rfl + | cons kv kvs ih => + simp only [bigOpL] + apply sep_mono + · exact h kv List.mem_cons_self + · exact ih (fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)) + +/-- Corresponds to `big_sepM_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Φ k v ⊢ Ψ k v) : + ([∗map] k ↦ x ∈ m, Φ k x) ⊢ [∗map] k ↦ x ∈ m, Ψ k x := by + simp only [bigSepM] + apply mono_list + intro kv hmem + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Corresponds to `big_sepM_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Φ k v ≡ Ψ k v) : + ([∗map] k ↦ x ∈ m, Φ k x) ≡ [∗map] k ↦ x ∈ m, Ψ k x := by + simp only [bigSepM] + apply BigOpL.congr + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Unconditional version of `proper`. No direct Rocq equivalent. -/ +theorem congr {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, Φ k v ≡ Ψ k v) : + ([∗map] k ↦ x ∈ m, Φ k x) ≡ [∗map] k ↦ x ∈ m, Ψ k x := + proper (fun k v _ => h k v) + +/-- Corresponds to `big_sepM_ne` in Rocq Iris. -/ +theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} + (h : ∀ k v, get? m k = some v → Φ k v ≡{n}≡ Ψ k v) : + ([∗map] k ↦ x ∈ m, Φ k x) ≡{n}≡ [∗map] k ↦ x ∈ m, Ψ k x := by + simp only [bigSepM] + apply BigOpL.congr_ne + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact h kv.1 kv.2 hkv + +/-- Corresponds to `big_sepM_mono'` in Rocq Iris. -/ +theorem mono' {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, Φ k v ⊢ Ψ k v) : + ([∗map] k ↦ x ∈ m, Φ k x) ⊢ [∗map] k ↦ x ∈ m, Ψ k x := + mono (fun k v _ => h k v) + +/-- Corresponds to `big_sepM_flip_mono'` in Rocq Iris. -/ +theorem flip_mono' {Φ Ψ : K → V → PROP} {m : M} + (h : ∀ k v, Ψ k v ⊢ Φ k v) : + ([∗map] k ↦ x ∈ m, Ψ k x) ⊢ [∗map] k ↦ x ∈ m, Φ k x := + mono' h + +/-- Corresponds to `big_sepM_subseteq` in Rocq Iris. -/ +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M} [FiniteMapLawsSelf M K V] [∀ k v, Affine (Φ k v)] + (h : m₂ ⊆ m₁) : + ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by + have heq := FiniteMap.map_difference_union m₁ m₂ h + have hdisj := FiniteMap.disjoint_difference_r m₁ m₂ + have hunion_perm := toList_union_disjoint m₂ (m₁ \ m₂) hdisj + rw [bigSepM, ← heq] + have heq_union : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (m₂ ∪ (m₁ \ m₂))) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m₂ ++ toList (m₁ \ m₂)) := + BigOpL.perm _ hunion_perm + refine (equiv_iff.mp heq_union).1.trans ?_ + have happ := BigOpL.append (op := sep (PROP := PROP)) (unit := emp) + (fun _ (kv : K × V) => Φ kv.1 kv.2) (toList m₂) (toList (m₁ \ m₂)) + refine (equiv_iff.mp happ).1.trans ?_ + haveI : Affine (bigOpL sep emp (fun n (kv : K × V) => Φ kv.1 kv.2) (toList (m₁ \ m₂))) := + ⟨BigOpL.closed (fun P => P ⊢ emp) (fun _ kv => Φ kv.1 kv.2) (toList (m₁ \ m₂)) + Entails.rfl + (fun _ _ h1 h2 => (sep_mono h1 h2).trans sep_emp.1) + (fun _ _ _ => Affine.affine)⟩ + exact sep_elim_l + +/-! ## Typeclass Instances -/ + +/-- Corresponds to `big_sepM_empty_persistent` in Rocq Iris. -/ +instance empty_persistent {Φ : K → V → PROP} : + Persistent ([∗map] k ↦ x ∈ (∅ : M), Φ k x) where + persistent := by + simp only [bigSepM, map_to_list_empty, bigOpL] + exact persistently_emp_2 + +/-- Corresponds to `big_sepM_persistent` in Rocq Iris (conditional version). -/ +theorem persistent_cond {Φ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Persistent (Φ k v)) : + Persistent ([∗map] k ↦ x ∈ m, Φ k x) where + persistent := by + simp only [bigSepM] + apply BigOpL.closed (fun P => P ⊢ P) (fun _ kv => Φ kv.1 kv.2) (toList m) + persistently_emp_2 + (fun _ _ h1 h2 => (sep_mono h1 h2).trans persistently_sep_2) + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact (h kv.1 kv.2 hkv).persistent + +/-- Corresponds to `big_sepM_persistent'` in Rocq Iris. -/ +instance persistent {Φ : K → V → PROP} {m : M} [∀ k v, Persistent (Φ k v)] : + Persistent ([∗map] k ↦ x ∈ m, Φ k x) := + persistent_cond fun _ _ _ => inferInstance + +/-- Corresponds to `big_sepM_empty_affine` in Rocq Iris. -/ +instance empty_affine {Φ : K → V → PROP} : + Affine ([∗map] k ↦ x ∈ (∅ : M), Φ k x) where + affine := by + simp only [bigSepM, map_to_list_empty, bigOpL] + exact Entails.rfl + +/-- Corresponds to `big_sepM_affine` in Rocq Iris (conditional version). -/ +theorem affine_cond {Φ : K → V → PROP} {m : M} + (h : ∀ k v, get? m k = some v → Affine (Φ k v)) : + Affine ([∗map] k ↦ x ∈ m, Φ k x) where + affine := by + simp only [bigSepM] + apply BigOpL.closed (fun P => P ⊢ emp) (fun _ kv => Φ kv.1 kv.2) (toList m) + Entails.rfl + (fun _ _ h1 h2 => (sep_mono h1 h2).trans sep_emp.1) + intro i kv hget + have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 + have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 + have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi + have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact (h kv.1 kv.2 hkv).affine + +/-- Corresponds to `big_sepM_affine'` in Rocq Iris. -/ +instance affine {Φ : K → V → PROP} {m : M} [∀ k v, Affine (Φ k v)] : + Affine ([∗map] k ↦ x ∈ m, Φ k x) := + affine_cond fun _ _ _ => inferInstance + +/-! ## Logical Operations -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_sep` in Rocq Iris. -/ +theorem sep' {Φ Ψ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x ∗ Ψ k x) ⊣⊢ + ([∗map] k ↦ x ∈ m, Φ k x) ∗ [∗map] k ↦ x ∈ m, Ψ k x := by + simp only [bigSepM] + exact equiv_iff.mp (BigOpL.op_distr _ _ _) + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_sep_2` in Rocq Iris. -/ +theorem sep_2 {Φ Ψ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x) ∗ ([∗map] k ↦ x ∈ m, Ψ k x) ⊣⊢ + [∗map] k ↦ x ∈ m, Φ k x ∗ Ψ k x := + sep'.symm + +/-- Corresponds to `big_sepM_and` in Rocq Iris (one direction only). -/ +theorem and' {Φ Ψ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x ∧ Ψ k x) ⊢ + ([∗map] k ↦ x ∈ m, Φ k x) ∧ [∗map] k ↦ x ∈ m, Ψ k x := + and_intro (mono' fun _ _ => and_elim_l) (mono' fun _ _ => and_elim_r) + +/-- Corresponds to `big_sepM_wand` in Rocq Iris. -/ +theorem wand {Φ Ψ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x) ⊢ + ([∗map] k ↦ x ∈ m, Φ k x -∗ Ψ k x) -∗ [∗map] k ↦ x ∈ m, Ψ k x := + wand_intro <| sep_2.1.trans (mono' fun _ _ => wand_elim_r) + +/-! ## Lookup Lemmas -/ + +/-- Corresponds to `big_sepM_lookup_acc` in Rocq Iris. -/ +theorem lookup_acc {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ + Φ k v ∗ (Φ k v -∗ [∗map] k' ↦ x ∈ m, Φ k' x) := + (delete h).1.trans (sep_mono_r (wand_intro' (delete h).2)) + +/-- Corresponds to `big_sepM_lookup` in Rocq Iris. -/ +theorem lookup {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + [TCOr (∀ j w, Affine (Φ j w)) (Absorbing (Φ k v))] → + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v + | TCOr.l => (delete h).1.trans sep_elim_l + | TCOr.r => (lookup_acc h).trans (sep_elim_l (P := Φ k v) (Q := iprop(Φ k v -∗ bigSepM Φ m))) + +/-- Corresponds to `big_sepM_lookup_dom` in Rocq Iris. -/ +theorem lookup_dom {Φ : K → PROP} {m : M} {k : K} + (h : (get? m k).isSome) : + [TCOr (∀ j, Affine (Φ j)) (Absorbing (Φ k))] → + bigSepM (fun k' _ => Φ k') m ⊢ Φ k := by + have ⟨v, hv⟩ : ∃ v, get? m k = some v := Option.isSome_iff_exists.mp h + intro htc + exact match htc with + | TCOr.l => lookup (Φ := fun k' _ => Φ k') hv + | TCOr.r => lookup (Φ := fun k' _ => Φ k') hv + +/-- Corresponds to `big_sepM_insert_acc` in Rocq Iris. -/ +theorem insert_acc {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (h : get? m k = some v) : + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ + Φ k v ∗ (∀ v', Φ k v' -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) := by + have hdel := delete (Φ := Φ) (m := m) h + refine hdel.1.trans (sep_mono_r ?_) + apply forall_intro + intro v' + have hmap_eq := FiniteMapLaws.insert_delete_eq m k v' + have hprop_eq : bigSepM Φ (FiniteMap.insert m k v') ⊣⊢ bigSepM Φ (FiniteMap.insert (Std.delete m k) k v') := by + unfold bigSepM; rw [hmap_eq]; exact .rfl + have hins := insert (Φ := Φ) (m := Std.delete m k) (k := k) (v := v') (lookup_delete_eq m k) + exact wand_intro' (hins.2.trans hprop_eq.2) + +/-- Corresponds to `big_sepM_insert_2` in Rocq Iris. -/ +theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : + [TCOr (∀ w, Affine (Φ k w)) (Absorbing (Φ k v))] → + Φ k v ⊢ ([∗map] k' ↦ x ∈ m, Φ k' x) -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x + | TCOr.l => by + apply wand_intro + cases hm : get? m k with + | none => + exact (insert hm).2 + | some y => + have hdel := delete (Φ := Φ) (m := m) hm + refine (sep_mono_r hdel.1).trans ?_ + refine (sep_assoc (P := Φ k v) (Q := Φ k y) (R := bigSepM (fun k' x => Φ k' x) (Std.delete m k))).2.trans ?_ + refine (sep_mono_l sep_elim_l).trans ?_ + have hins := insert (Φ := Φ) (m := Std.delete m k) (k := k) (v := v) (lookup_delete_eq m k) + have hmap_eq := FiniteMapLaws.insert_delete_eq m k v + have hprop_eq : bigSepM Φ (FiniteMap.insert m k v) ⊣⊢ bigSepM Φ (FiniteMap.insert (Std.delete m k) k v) := by + unfold bigSepM; rw [hmap_eq]; exact .rfl + exact hins.2.trans hprop_eq.2 + | TCOr.r => by + apply wand_intro + cases hm : get? m k with + | none => exact (insert hm).2 + | some y => + have hdel := delete (Φ := Φ) (m := m) hm + refine (sep_mono_r hdel.1).trans ?_ + refine (sep_assoc (P := Φ k v) (Q := Φ k y) (R := bigSepM (fun k' x => Φ k' x) (Std.delete m k))).2.trans ?_ + refine (sep_mono_l (sep_elim_l (P := Φ k v) (Q := Φ k y))).trans ?_ + have hins := insert (Φ := Φ) (m := Std.delete m k) (k := k) (v := v) (lookup_delete_eq m k) + have hmap_eq := FiniteMapLaws.insert_delete_eq m k v + have hprop_eq : bigSepM Φ (FiniteMap.insert m k v) ⊣⊢ bigSepM Φ (FiniteMap.insert (Std.delete m k) k v) := by + unfold bigSepM; rw [hmap_eq]; exact .rfl + exact hins.2.trans hprop_eq.2 + +/-- Corresponds to `big_sepM_insert_override` in Rocq Iris. -/ +theorem insert_override {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} + (hm : get? m k = some v) + (heqv : Φ k v ⊣⊢ Φ k v') : + ([∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) ⊣⊢ [∗map] k' ↦ x ∈ m, Φ k' x := by + constructor + · have hins := insert_delete (Φ := Φ) (m := m) (k := k) (v := v') + refine hins.1.trans ?_ + refine (sep_mono_l heqv.2).trans ?_ + exact (delete hm).2 + · have hdel := delete (Φ := Φ) (m := m) hm + refine hdel.1.trans ?_ + refine (sep_mono_l heqv.1).trans ?_ + exact insert_delete.2 + +/-- Corresponds to `big_sepM_insert_override_1` in Rocq Iris. -/ +theorem insert_override_1 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} + (hm : get? m k = some v) : + ([∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) ⊢ + (Φ k v' -∗ Φ k v) -∗ [∗map] k' ↦ x ∈ m, Φ k' x := by + apply wand_intro' + refine sep_comm.1.trans ?_ + have hins := insert_delete (Φ := Φ) (m := m) (k := k) (v := v') + refine (sep_mono_l hins.1).trans ?_ + refine (sep_assoc (P := Φ k v') (Q := bigSepM (fun k' x => Φ k' x) (Std.delete m k)) (R := iprop(Φ k v' -∗ Φ k v))).1.trans ?_ + refine (sep_mono_r sep_comm.1).trans ?_ + refine (sep_assoc (P := Φ k v') (Q := iprop(Φ k v' -∗ Φ k v)) (R := bigSepM (fun k' x => Φ k' x) (Std.delete m k))).2.trans ?_ + refine (sep_mono_l (sep_comm.1.trans (wand_elim_l (P := Φ k v') (Q := Φ k v)))).trans ?_ + exact (delete hm).2 + +/-- Corresponds to `big_sepM_insert_override_2` in Rocq Iris. -/ +theorem insert_override_2 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} + (hm : get? m k = some v) : + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ + (Φ k v -∗ Φ k v') -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x := by + apply wand_intro' + refine sep_comm.1.trans ?_ + have hdel := delete (Φ := Φ) (m := m) hm + refine (sep_mono_l hdel.1).trans ?_ + refine (sep_assoc (P := Φ k v) (Q := bigSepM (fun k' x => Φ k' x) (Std.delete m k)) (R := iprop(Φ k v -∗ Φ k v'))).1.trans ?_ + refine (sep_mono_r sep_comm.1).trans ?_ + refine (sep_assoc (P := Φ k v) (Q := iprop(Φ k v -∗ Φ k v')) (R := bigSepM (fun k' x => Φ k' x) (Std.delete m k))).2.trans ?_ + refine (sep_mono_l (sep_comm.1.trans (wand_elim_l (P := Φ k v) (Q := Φ k v')))).trans ?_ + exact insert_delete.2 + +/-! ## Map Conversion -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_map_to_list` in Rocq Iris. -/ +theorem map_to_list {Φ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∗list] kv ∈ toList m, Φ kv.1 kv.2) := by + simp only [bigSepM] + exact .rfl + +/-! ## Persistently and Later -/ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Helper for persistently: induction on list. -/ +private theorem persistently_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : + iprop( bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ + bigOpL sep emp (fun _ kv => iprop( Φ kv)) l := by + induction l with + | nil => simp only [bigOpL]; exact persistently_emp' (PROP := PROP) + | cons kv kvs ih => + simp only [bigOpL] + exact persistently_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_persistently` in Rocq Iris. -/ +theorem persistently {Φ : K → V → PROP} {m : M} [BIAffine PROP] : + iprop( [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, Φ k x := by + simp only [bigSepM] + exact persistently_list + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Helper for later: induction on list. -/ +private theorem later_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : + iprop(▷ bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ + bigOpL sep emp (fun _ kv => iprop(▷ Φ kv)) l := by + induction l with + | nil => simp only [bigOpL]; exact later_emp + | cons kv kvs ih => + simp only [bigOpL] + exact later_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_later` in Rocq Iris. -/ +theorem later [BIAffine PROP] {Φ : K → V → PROP} {m : M} : + iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷ Φ k x := by + simp only [bigSepM] + exact later_list + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Helper for later_2: induction on list. -/ +private theorem later_2_list {Φ : K × V → PROP} {l : List (K × V)} : + bigOpL sep emp (fun _ kv => iprop(▷ Φ kv)) l ⊢ + iprop(▷ bigOpL sep emp (fun _ kv => Φ kv) l) := by + induction l with + | nil => simp only [bigOpL]; exact later_intro + | cons kv kvs ih => + simp only [bigOpL] + exact (sep_mono_r ih).trans later_sep.2 + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_later_2` in Rocq Iris. -/ +theorem later_2 {Φ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, ▷ Φ k x) ⊢ iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) := by + simp only [bigSepM] + exact later_2_list + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_laterN` in Rocq Iris. -/ +theorem laterN [BIAffine PROP] {Φ : K → V → PROP} {m : M} {n : Nat} : + iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷^[n] Φ k x := by + induction n with + | zero => exact .rfl + | succ k ih => exact (later_congr ih).trans later + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_laterN_2` in Rocq Iris. -/ +theorem laterN_2 {Φ : K → V → PROP} {m : M} {n : Nat} : + ([∗map] k ↦ x ∈ m, ▷^[n] Φ k x) ⊢ iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) := by + induction n with + | zero => exact .rfl + | succ k ih => exact later_2.trans (later_mono ih) + +/-! ## Map Transformations -/ + +section MapTransformations + +variable {M' : Type _} {V' : Type _} +variable [FiniteMap M' K V'] + +variable [FiniteMapLawsExt M M' K V V'] + +/-- Corresponds to `big_sepM_fmap` in Rocq Iris. -/ +theorem fmap {Φ : K → V' → PROP} {m : M} (f : V → V') : + ([∗map] k ↦ y ∈ FiniteMap.map (M' := M') f m, Φ k y) ⊣⊢ + [∗map] k ↦ y ∈ m, Φ k (f y) := by + simp only [bigSepM] + have hperm := toList_map (K := K) (M' := M') m f + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.map (M' := M') f m)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (kv.1, f kv.2))) := + BigOpL.perm _ hperm + refine equiv_iff.mp heq |>.trans ?_ + clear heq hperm + induction (toList m) with + | nil => exact .rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +end MapTransformations + +section FilterMapTransformations + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Helper lemma for omap: bigOpL over filterMapped list. -/ +private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) + (l.filterMap (fun kv => (f kv.2).map (kv.1, ·))) ⊣⊢ + bigOpL sep emp (fun _ kv => match f kv.2 with | some y' => Φ kv.1 y' | none => emp) l := by + induction l with + | nil => simp only [List.filterMap, bigOpL]; exact .rfl + | cons kv kvs ih => + simp only [List.filterMap, Option.map] + cases hf : f kv.2 with + | none => + simp only [bigOpL, hf] + exact ih.trans emp_sep.symm + | some y' => + simp only [bigOpL, hf] + exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +/-- Corresponds to `big_sepM_omap` in Rocq Iris. -/ +theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V → Option V) : + ([∗map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ + [∗map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => emp := by + simp only [bigSepM] + have hperm := toList_filterMap (K := K) m f + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.filterMap (M := M) f m)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).filterMap (fun kv => (f kv.2).map (kv.1, ·))) := + BigOpL.perm _ hperm + exact equiv_iff.mp heq |>.trans (omap_list_aux f (toList m)) + +/-- Corresponds to `big_sepM_union` in Rocq Iris. -/ +theorem union [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m₁ m₂ : M} + (hdisj : m₁ ##ₘ m₂) : + ([∗map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ + ([∗map] k ↦ y ∈ m₁, Φ k y) ∗ [∗map] k ↦ y ∈ m₂, Φ k y := by + simp only [bigSepM] + have hperm := toList_union_disjoint m₁ m₂ hdisj + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (m₁ ∪ m₂)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m₁ ++ toList m₂) := + BigOpL.perm _ hperm + refine equiv_iff.mp heq |>.trans ?_ + exact equiv_iff.mp (BigOpL.append _ (toList m₁) (toList m₂)) + +end FilterMapTransformations + +/-! ## List-Map Conversions -/ + +/-- Corresponds to `big_sepM_list_to_map` in Rocq Iris. -/ +theorem list_to_map {Φ : K → V → PROP} {l : List (K × V)} + (hnodup : (l.map Prod.fst).Nodup) : + ([∗map] k ↦ x ∈ (ofList l : M), Φ k x) ⊣⊢ [∗list] kv ∈ l, Φ kv.1 kv.2 := by + simp only [bigSepM] + exact equiv_iff.mp (BigOpL.perm _ (map_to_list_to_map l hnodup)) + +/-! ## Intro and Forall Lemmas -/ + +/-- Corresponds to `big_sepM_intro` in Rocq Iris. + -/ +theorem intro {Φ : K → V → PROP} {m : M} : + iprop(□ (∀ k v, ⌜get? m k = some v⌝ → Φ k v)) ⊢ [∗map] k ↦ x ∈ m, Φ k x := by + simp only [bigSepM] + generalize hl : toList m = l + induction l generalizing m with + | nil => + exact affinely_elim_emp + | cons kv kvs ih => + simp only [bigOpL] + have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self + have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + refine intuitionistically_sep_idem.2.trans <| sep_mono ?_ ?_ + · refine intuitionistically_elim.trans ?_ + exact (forall_elim kv.1).trans ((forall_elim kv.2).trans + ((imp_mono_l (pure_mono fun _ => hget_kv)).trans true_imp.1)) + · have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => + (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + clear ih hmem_kv hget_kv hl + induction kvs with + | nil => exact affinely_elim_emp + | cons kv' kvs' ih' => + simp only [bigOpL] + refine intuitionistically_sep_idem.2.trans <| sep_mono ?_ ?_ + · refine intuitionistically_elim.trans ?_ + exact (forall_elim kv'.1).trans ((forall_elim kv'.2).trans + ((imp_mono_l (pure_mono fun _ => htail kv' List.mem_cons_self)).trans true_imp.1)) + · exact ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem) + +/-- Forward direction of `big_sepM_forall` in Rocq Iris. -/ +theorem forall_1' {Φ : K → V → PROP} {m : M} [BIAffine PROP] + [∀ k v, Persistent (Φ k v)] : + ([∗map] k ↦ x ∈ m, Φ k x) ⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := by + refine forall_intro fun k => forall_intro fun v => imp_intro' <| pure_elim_l fun hget => ?_ + have hdel := delete (Φ := Φ) hget + exact hdel.1.trans <| (sep_mono_l Persistent.persistent).trans <| + sep_comm.1.trans <| persistently_absorb_r.trans persistently_elim + +/-- Backward direction of `big_sepM_forall` in Rocq Iris. -/ +theorem forall_2' {Φ : K → V → PROP} {m : M} [BIAffine PROP] + [∀ k v, Persistent (Φ k v)] : + (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v)) ⊢ [∗map] k ↦ x ∈ m, Φ k x := by + simp only [bigSepM] + generalize hl : toList m = l + induction l generalizing m with + | nil => exact Affine.affine + | cons kv kvs ih => + simp only [bigOpL] + have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self + have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + have head_step : iprop(∀ k v, ⌜get? m k = some v⌝ → Φ k v) ⊢ Φ kv.1 kv.2 := + (forall_elim kv.1).trans (forall_elim kv.2) |>.trans <| + (and_intro (pure_intro hget_kv) .rfl).trans imp_elim_r + have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => + (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + refine and_self.2.trans (and_mono_l head_step) |>.trans persistent_and_sep_1 |>.trans <| + sep_mono_r ?_ + clear ih head_step hmem_kv hget_kv hl + induction kvs with + | nil => exact Affine.affine + | cons kv' kvs' ih' => + simp only [bigOpL] + have hget_kv' := htail kv' List.mem_cons_self + have head_step' : iprop(∀ k v, ⌜get? m k = some v⌝ → Φ k v) ⊢ Φ kv'.1 kv'.2 := + (forall_elim kv'.1).trans (forall_elim kv'.2) |>.trans <| + (and_intro (pure_intro hget_kv') .rfl).trans imp_elim_r + refine and_self.2.trans (and_mono_l head_step') |>.trans persistent_and_sep_1 |>.trans <| + sep_mono_r (ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem)) + +/-- Corresponds to `big_sepM_forall` in Rocq Iris. -/ +theorem forall' {Φ : K → V → PROP} {m : M} [BIAffine PROP] + [∀ k v, Persistent (Φ k v)] : + ([∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := + ⟨forall_1', forall_2'⟩ + +/-- Corresponds to `big_sepM_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : K → V → PROP} {m : M} : + ([∗map] k ↦ x ∈ m, Φ k x) ⊢ + □ (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v -∗ Ψ k v)) -∗ [∗map] k ↦ x ∈ m, Ψ k x := by + apply wand_intro + have h1 : iprop(□ (∀ k v, ⌜get? m k = some v⌝ → Φ k v -∗ Ψ k v)) ⊢ bigSepM (fun k v => iprop(Φ k v -∗ Ψ k v)) m := + intro + refine (sep_mono_r h1).trans ?_ + exact sep_2.1.trans (mono' fun _ _ => wand_elim_r) + +omit [DecidableEq K] [FiniteMapLaws M K V] in +/-- Corresponds to `big_sepM_dup` in Rocq Iris. -/ +theorem dup {P : PROP} [Affine P] {m : M} : + □ (P -∗ P ∗ P) ⊢ P -∗ [∗map] _k ↦ _x ∈ m, P := by + simp only [bigSepM] + apply wand_intro + generalize toList m = l + induction l with + | nil => + simp only [bigOpL] + exact sep_elim_r.trans Affine.affine + | cons kv kvs ih => + simp only [bigOpL] + refine (sep_mono_l intuitionistically_sep_idem.2).trans <| sep_assoc.1.trans <| + (sep_mono_r <| (sep_mono_l intuitionistically_elim).trans wand_elim_l).trans <| + sep_assoc.2.trans <| (sep_mono_l ih).trans sep_comm.1 + +/-- Corresponds to `big_sepM_lookup_acc_impl` in Rocq Iris. -/ +theorem lookup_acc_impl {Φ : K → V → PROP} {m : M} {k : K} {v : V} + (hget : get? m k = some v) : + ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ + Φ k v ∗ ∀ (Ψ: K → V → PROP), □ (∀ k' v', iprop(⌜get? m k' = some v'⌝ → ⌜k' ≠ k⌝ → Φ k' v' -∗ Ψ k' v')) -∗ + Ψ k v -∗ [∗map] k' ↦ x ∈ m, Ψ k' x := by + have hdel := delete (Φ := Φ) (m := m) hget + refine hdel.1.trans (sep_mono_r ?_) + apply forall_intro + intro Ψ + apply wand_intro + apply wand_intro + have hdelΨ := delete (Φ := Ψ) (m := m) hget + refine sep_comm.1.trans <| (sep_mono_r sep_comm.1).trans ?_ + refine (sep_mono_r sep_comm.1).trans ?_ + refine (sep_mono_r ?_).trans hdelΨ.2 + have himpl : iprop(□ (∀ k' v', ⌜get? m k' = some v'⌝ → ⌜k' ≠ k⌝ → Φ k' v' -∗ Ψ k' v')) + ⊢ bigSepM (fun k' v' => iprop(Φ k' v' -∗ Ψ k' v')) (Std.delete m k) := by + have htrans : iprop(□ (∀ k' v', ⌜get? m k' = some v'⌝ → ⌜k' ≠ k⌝ → Φ k' v' -∗ Ψ k' v')) + ⊢ iprop(□ (∀ k' v', ⌜get? (Std.delete m k) k' = some v'⌝ → Φ k' v' -∗ Ψ k' v')) := by + apply intuitionistically_mono + apply forall_mono; intro k' + apply forall_mono; intro v' + apply imp_intro' + apply pure_elim_l; intro hget_erase + have hne : k' ≠ k := by + intro heq + rw [heq, lookup_delete_eq] at hget_erase + exact Option.noConfusion hget_erase + have hget_m : get? m k' = some v' := by + rw [lookup_delete_ne m k k' hne.symm] at hget_erase + exact hget_erase + exact (and_intro (pure_intro hget_m) .rfl).trans imp_elim_r |>.trans <| + (and_intro (pure_intro hne) .rfl).trans imp_elim_r + exact htrans.trans intro + refine (sep_mono_r himpl).trans ?_ + exact sep_2.1.trans (mono' fun _ _ => wand_elim_r) + +/-! ## Pure Lemmas -/ + +/-- `mapForall φ m` means `φ k v` holds for all key-value pairs in `m`. + This is equivalent to Rocq Iris's `map_Forall`. -/ +def mapForall (φ : K → V → Prop) (m : M) : Prop := + ∀ k v, get? m k = some v → φ k v + +/-- Corresponds to `big_sepM_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : K → V → Prop} {m : M} : + ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜mapForall φ m⌝ : PROP) := by + simp only [bigSepM, mapForall] + suffices h : ∀ l : List (K × V), + bigOpL sep emp (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l ⊢ + iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) by + refine (h (toList m)).trans <| pure_mono fun hlist k v hget => ?_ + have hmem : (k, v) ∈ toList m := (elem_of_map_to_list m k v).mp hget + exact hlist (k, v) hmem + intro l + induction l with + | nil => + simp only [bigOpL] + exact pure_intro fun _ h => nomatch h + | cons kv kvs ih => + simp only [bigOpL] + refine (sep_mono_r ih).trans <| sep_and.trans <| pure_and.1.trans <| pure_mono ?_ + intro ⟨hkv, hkvs⟩ kv' hmem + cases hmem with + | head => exact hkv + | tail _ htail => exact hkvs kv' htail + +/-- Corresponds to `big_sepM_affinely_pure_2` in Rocq Iris. -/ +theorem affinely_pure_2 {φ : K → V → Prop} {m : M} : + iprop( ⌜mapForall φ m⌝) ⊢ ([∗map] k ↦ x ∈ m, ⌜φ k x⌝ : PROP) := by + simp only [bigSepM, mapForall] + suffices h : ∀ l : List (K × V), + iprop( ⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) ⊢ + bigOpL sep emp (fun _ (kv : K × V) => iprop( ⌜φ kv.1 kv.2⌝)) l by + refine (affinely_mono <| pure_mono fun hmap kv hmem => ?_).trans (h (toList m)) + have hget : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact hmap kv.1 kv.2 hget + intro l + induction l with + | nil => + simp only [bigOpL] + exact affinely_elim_emp + | cons kv kvs ih => + simp only [bigOpL] + refine (affinely_mono <| pure_mono fun h => + ⟨h kv List.mem_cons_self, fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)⟩).trans <| + (affinely_mono pure_and.2).trans <| affinely_and.1.trans <| + persistent_and_sep_1.trans (sep_mono_r ih) + +/-- Corresponds to `big_sepM_pure` in Rocq Iris. -/ +theorem pure' [BIAffine PROP] {φ : K → V → Prop} {m : M} : + ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜mapForall φ m⌝ : PROP) := + ⟨pure_1, (affine_affinely _).2.trans <| affinely_pure_2.trans (mono' fun _ _ => affinely_elim)⟩ + +/-! ## Filter Lemmas -/ + +variable [FiniteMapLawsSelf M K V] + +omit [DecidableEq K] in +/-- Helper: bigOpL over filtered list. -/ +private theorem filter_list_aux (Φ : K × V → PROP) (φ : K × V → Prop) [∀ kv, Decidable (φ kv)] + (l : List (K × V)) : + bigOpL sep emp (fun _ kv => Φ kv) (l.filter (fun kv => decide (φ kv))) ⊣⊢ + bigOpL sep emp (fun _ kv => if decide (φ kv) then Φ kv else emp) l := by + induction l with + | nil => simp only [List.filter, bigOpL]; exact .rfl + | cons kv kvs ih => + simp only [List.filter] + cases hp : decide (φ kv) with + | false => + simp only [bigOpL, hp] + exact ih.trans emp_sep.symm + | true => + simp only [bigOpL, hp, ↓reduceIte] + exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +/-- Corresponds to `big_sepM_filter'` in Rocq Iris. -/ +theorem filter' {Φ : K → V → PROP} {m : M} + (φ : K × V → Prop) [∀ kv, Decidable (φ kv)] : + ([∗map] k ↦ x ∈ FiniteMap.filter (fun k v => decide (φ (k, v))) m, Φ k x) ⊣⊢ + [∗map] k ↦ x ∈ m, if decide (φ (k, x)) then Φ k x else emp := by + simp only [bigSepM] + have hperm := toList_filter m (fun k v => decide (φ (k, v))) + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) + (toList (FiniteMap.filter (fun k v => decide (φ (k, v))) m)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) + ((toList m).filter (fun kv => decide (φ kv))) := + BigOpL.perm _ hperm + refine equiv_iff.mp heq |>.trans ?_ + exact filter_list_aux (fun kv => Φ kv.1 kv.2) φ (toList m) + +/-- Corresponds to `big_sepM_filter` in Rocq Iris. -/ +theorem filter [BIAffine PROP] {Φ : K → V → PROP} {m : M} + (φ : K × V → Prop) [∀ kv, Decidable (φ kv)] : + ([∗map] k ↦ x ∈ FiniteMap.filter (fun k v => decide (φ (k, v))) m, Φ k x) ⊣⊢ + [∗map] k ↦ x ∈ m, iprop(⌜φ (k, x)⌝ → Φ k x) := by + have heq : ([∗map] k ↦ x ∈ m, if decide (φ (k, x)) then Φ k x else emp) ⊣⊢ + [∗map] k ↦ x ∈ m, iprop(⌜φ (k, x)⌝ → Φ k x) := by + apply equiv_iff.mp + apply proper + intro k v _ + cases hp : decide (φ (k, v)) with + | false => + have hφ : ¬φ (k, v) := of_decide_eq_false hp + refine equiv_iff.mpr ⟨?_, Affine.affine⟩ + refine imp_intro' <| pure_elim_l fun h => ?_ + exact absurd h hφ + | true => + have hφ : φ (k, v) := of_decide_eq_true hp + simp only [↓reduceIte] + refine equiv_iff.mpr ⟨?_, ?_⟩ + · exact imp_intro' <| pure_elim_l fun _ => Entails.rfl + · exact (and_intro (pure_intro hφ) .rfl).trans imp_elim_r + exact (filter' φ).trans heq + +/-! ## Function Insertion Lemmas -/ + +/-- Function update: returns `b` if `k = i`, otherwise `f k`. -/ +def fnInsert {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) : B := + if k = i then b else f k + +theorem fnInsert_same {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) : + fnInsert f i b i = b := by simp [fnInsert] + +theorem fnInsert_ne {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) (h : k ≠ i) : + fnInsert f i b k = f k := by simp [fnInsert, h] + +omit [FiniteMapLawsSelf M K V] in +/-- Corresponds to `big_sepM_fn_insert` in Rocq Iris. -/ +theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : M} {i : K} {x : V} {b : B} + (h : get? m i = none) : + ([∗map] k ↦ y ∈ FiniteMap.insert m i x, Ψ k y (fnInsert f i b k)) ⊣⊢ + Ψ i x b ∗ [∗map] k ↦ y ∈ m, Ψ k y (f k) := by + have hins := insert (Φ := fun k y => Ψ k y (fnInsert f i b k)) (v := x) h + have hhead : Ψ i x (fnInsert f i b i) ⊣⊢ Ψ i x b := by + simp only [fnInsert_same] + exact .rfl + have htail : ([∗map] k ↦ y ∈ m, Ψ k y (fnInsert f i b k)) ⊣⊢ + [∗map] k ↦ y ∈ m, Ψ k y (f k) := by + apply equiv_iff.mp + apply proper + intro k y hget + have hne : k ≠ i := by + intro heq + rw [heq, h] at hget + exact Option.noConfusion hget + simp only [fnInsert_ne f i b k hne] + exact OFE.Equiv.rfl + exact hins.trans ⟨(sep_mono hhead.1 htail.1), (sep_mono hhead.2 htail.2)⟩ + +omit [FiniteMapLawsSelf M K V] in +/-- Corresponds to `big_sepM_fn_insert'` in Rocq Iris. -/ +theorem fn_insert' {Φ : K → PROP} {m : M} {i : K} {x : V} {P : PROP} + (h : get? m i = none) : + ([∗map] k ↦ _y ∈ FiniteMap.insert m i x, fnInsert Φ i P k) ⊣⊢ + P ∗ [∗map] k ↦ _y ∈ m, Φ k := + fn_insert (Ψ := fun _ _ P => P) (f := Φ) (b := P) h + +/-! ## Map Zip Lemmas -/ + +section MapZip + +variable {M₁ : Type _} {M₂ : Type _} {V₁ : Type _} {V₂ : Type _} +variable [FiniteMap M₁ K V₁] [FiniteMapLaws M₁ K V₁] +variable [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] + +omit [FiniteMapLaws M₁ K V₁] [FiniteMapLaws M₂ K V₂] in +/-- Corresponds to `big_sepM_sep_zip_with` in Rocq Iris. -/ +theorem sep_zip_with {C : Type _} {MZ : Type _} [FiniteMap MZ K C] [FiniteMapLaws MZ K C] + {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} + {f : V₁ → V₂ → C} {g₁ : C → V₁} {g₂ : C → V₂} + {m₁ : M₁} {m₂ : M₂} {mz : MZ} + (_hg₁ : ∀ x y, g₁ (f x y) = x) + (_hg₂ : ∀ x y, g₂ (f x y) = y) + (_hdom : ∀ k, (get? m₁ k).isSome ↔ (get? m₂ k).isSome) + (_hperm : (toList mz).Perm + ((toList m₁).filterMap (fun kv => + match get? m₂ kv.1 with + | some v₂ => some (kv.1, f kv.2 v₂) + | none => none))) + (hfmap₁ : (toList m₁).Perm ((toList mz).map (fun kv => (kv.1, g₁ kv.2)))) + (hfmap₂ : (toList m₂).Perm ((toList mz).map (fun kv => (kv.1, g₂ kv.2)))) : + ([∗map] k ↦ xy ∈ mz, Φ₁ k (g₁ xy) ∗ Φ₂ k (g₂ xy)) ⊣⊢ + ([∗map] k ↦ x ∈ m₁, Φ₁ k x) ∗ [∗map] k ↦ y ∈ m₂, Φ₂ k y := by + simp only [bigSepM] + have hsep : bigOpL sep emp (fun _ kv => iprop(Φ₁ kv.1 (g₁ kv.2) ∗ Φ₂ kv.1 (g₂ kv.2))) (toList mz) ≡ + sep (bigOpL sep emp (fun _ kv => Φ₁ kv.1 (g₁ kv.2)) (toList mz)) + (bigOpL sep emp (fun _ kv => Φ₂ kv.1 (g₂ kv.2)) (toList mz)) := + BigOpL.op_distr _ _ _ + refine equiv_iff.mp hsep |>.trans ?_ + have heq₁ : bigOpL sep emp (fun _ kv => Φ₁ kv.1 kv.2) (toList m₁) ≡ + bigOpL sep emp (fun _ kv => Φ₁ kv.1 kv.2) ((toList mz).map (fun kv => (kv.1, g₁ kv.2))) := + BigOpL.perm _ hfmap₁ + have heq₂ : bigOpL sep emp (fun _ kv => Φ₂ kv.1 kv.2) (toList m₂) ≡ + bigOpL sep emp (fun _ kv => Φ₂ kv.1 kv.2) ((toList mz).map (fun kv => (kv.1, g₂ kv.2))) := + BigOpL.perm _ hfmap₂ + have hmap₁ : bigOpL sep emp (fun _ kv => Φ₁ kv.1 (g₁ kv.2)) (toList mz) ≡ + bigOpL sep emp (fun _ kv => Φ₁ kv.1 kv.2) ((toList mz).map (fun kv => (kv.1, g₁ kv.2))) := by + induction (toList mz) with + | nil => exact OFE.Equiv.rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact Monoid.op_proper OFE.Equiv.rfl ih + have hmap₂ : bigOpL sep emp (fun _ kv => Φ₂ kv.1 (g₂ kv.2)) (toList mz) ≡ + bigOpL sep emp (fun _ kv => Φ₂ kv.1 kv.2) ((toList mz).map (fun kv => (kv.1, g₂ kv.2))) := by + induction (toList mz) with + | nil => exact OFE.Equiv.rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact Monoid.op_proper OFE.Equiv.rfl ih + have h₁ : bigOpL sep emp (fun _ kv => Φ₁ kv.1 (g₁ kv.2)) (toList mz) ≡ + bigOpL sep emp (fun _ kv => Φ₁ kv.1 kv.2) (toList m₁) := + hmap₁.trans heq₁.symm + have h₂ : bigOpL sep emp (fun _ kv => Φ₂ kv.1 (g₂ kv.2)) (toList mz) ≡ + bigOpL sep emp (fun _ kv => Φ₂ kv.1 kv.2) (toList m₂) := + hmap₂.trans heq₂.symm + exact equiv_iff.mp (Monoid.op_proper h₁ h₂) + +omit [FiniteMapLaws M₁ K V₁] [FiniteMapLaws M₂ K V₂] in +/-- Corresponds to `big_sepM_sep_zip` in Rocq Iris. -/ +theorem sep_zip {MZ : Type _} [FiniteMap MZ K (V₁ × V₂)] [FiniteMapLaws MZ K (V₁ × V₂)] + {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} + {m₁ : M₁} {m₂ : M₂} + (hdom : ∀ k, (get? m₁ k).isSome ↔ (get? m₂ k).isSome) + (hperm : (toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).Perm + ((toList m₁).filterMap (fun kv => + match get? m₂ kv.1 with + | some v₂ => some (kv.1, (kv.2, v₂)) + | none => none))) + (hfmap₁ : (toList m₁).Perm ((toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).map + (fun kv => (kv.1, kv.2.1)))) + (hfmap₂ : (toList m₂).Perm ((toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).map + (fun kv => (kv.1, kv.2.2)))) : + ([∗map] k ↦ xy ∈ FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂, + Φ₁ k xy.1 ∗ Φ₂ k xy.2) ⊣⊢ + ([∗map] k ↦ x ∈ m₁, Φ₁ k x) ∗ [∗map] k ↦ y ∈ m₂, Φ₂ k y := + sep_zip_with (f := Prod.mk) (g₁ := Prod.fst) (g₂ := Prod.snd) + (fun _ _ => rfl) (fun _ _ => rfl) hdom hperm hfmap₁ hfmap₂ + +end MapZip + +/-! ## Advanced Impl Lemmas -/ + +/-- Corresponds to `big_sepM_impl_strong` in Rocq Iris. + Strong version of impl that tracks which keys are in m₂ vs only in m₁. -/ +theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} + [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] + {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M} {m₂ : M₂} : + ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ + □ (∀ k, ∀ y, (match get? m₁ k with | some x => Φ k x | none => emp) -∗ + iprop(⌜get? m₂ k = some y⌝ → Ψ k y)) -∗ + ([∗map] k ↦ y ∈ m₂, Ψ k y) ∗ + [∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? m₂ k).isNone)) m₁, Φ k x := by + apply wand_intro + revert m₁ + apply FiniteMapLaws.map_ind (M := M₂) (K := K) (V := V₂) (P := fun m₂ => + ∀ (m₁ : M), ([∗map] k ↦ x ∈ m₁, Φ k x) ∗ + □ (∀ k y, (match get? m₁ k with | some x => Φ k x | none => emp) -∗ + iprop(⌜get? m₂ k = some y⌝ → Ψ k y)) + ⊢ ([∗map] k ↦ y ∈ m₂, Ψ k y) ∗ + [∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? m₂ k).isNone)) m₁, Φ k x) + · intro m₁ + have hfilter_perm : (toList (FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂) k).isNone)) m₁)).Perm + (toList m₁) := by + have hperm := @toList_filter M K V _ _ _ _ m₁ (fun k _ => decide ((get? (∅ : M₂) k).isNone)) + rw [List.filter_eq_self.mpr (fun kv _ => by simp [lookup_empty])] at hperm + exact hperm + have hfilter_equiv : ([∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂) k).isNone)) m₁, Φ k x) ⊣⊢ + ([∗map] k ↦ x ∈ m₁, Φ k x) := by + simp only [bigSepM] + exact equiv_iff.mp (BigOpL.perm (fun kv => Φ kv.1 kv.2) hfilter_perm) + exact (sep_mono_r (Affine.affine (P := iprop(□ _)))).trans <| sep_emp.1.trans <| + hfilter_equiv.2.trans <| sep_emp.2.trans <| sep_comm.1.trans (sep_mono_l empty.2) + · intro i y m hi IH m₁ + have hinsert_goal := insert (Φ := Ψ) (v := y) hi + refine (sep_mono_r intuitionistically_sep_dup.1).trans <| sep_assoc.2.trans ?_ + cases hm₁i : get? m₁ i with + | none => + have hlookup_insert : get? (Std.insert m i y) i = some y := lookup_insert_eq m i y + have hΨ_from_hyp : iprop(□ (∀ k y', (match get? m₁ k with | some x => Φ k x | none => emp) -∗ + iprop(⌜get? (Std.insert m i y) k = some y'⌝ → Ψ k y'))) ⊢ Ψ i y := by + refine intuitionistically_elim.trans <| (forall_elim (a := i)).trans <| (forall_elim (a := y)).trans ?_ + simp only [hm₁i, hlookup_insert] + exact (wand_mono_r true_imp.1).trans <| emp_sep.2.trans (sep_comm.1.trans wand_elim_l) + have hweaken : iprop(□ (∀ k y', (match get? m₁ k with | some x => Φ k x | none => emp) -∗ + iprop(⌜get? (Std.insert m i y) k = some y'⌝ → Ψ k y'))) ⊢ + iprop(□ (∀ k y', (match get? m₁ k with | some x => Φ k x | none => emp) -∗ + iprop(⌜get? m k = some y'⌝ → Ψ k y'))) := by + apply intuitionistically_mono; apply forall_mono; intro k; apply forall_mono; intro y' + apply wand_mono_r; apply imp_intro'; apply pure_elim_l; intro hget_m + have hne : k ≠ i := by intro heq; rw [heq] at hget_m; exact Option.noConfusion (hi ▸ hget_m) + rw [lookup_insert_ne m i k y hne.symm] at * + exact (and_intro (pure_intro hget_m) .rfl).trans imp_elim_r + have hfilter_eq : FiniteMap.filter (fun k _ => decide ((get? (Std.insert m i y) k).isNone)) m₁ = + FiniteMap.filter (fun k _ => decide ((get? m k).isNone)) m₁ := by + simp only [FiniteMap.filter]; congr 1 + apply List.filter_congr; intro ⟨j, v⟩ hjv + have hget : get? m₁ j = some v := (elem_of_map_to_list m₁ j v).mpr hjv + have hne : j ≠ i := by intro heq; rw [heq] at hget; exact Option.noConfusion (hm₁i ▸ hget) + rw [lookup_insert_ne _ _ _ _ hne.symm] + rw [hfilter_eq] + exact (sep_mono_r hΨ_from_hyp).trans <| (sep_mono_l (sep_mono_r hweaken)).trans <| + (sep_mono_l (IH m₁)).trans <| sep_assoc.1.trans <| (sep_mono_r sep_comm.1).trans <| + sep_assoc.2.trans (sep_mono_l (sep_comm.1.trans hinsert_goal.2)) + | some x => + have hdel := delete (Φ := Φ) (m := m₁) hm₁i + have hΨ_from_hyp : Φ i x ∗ iprop(□ (∀ k y', (match get? m₁ k with | some x' => Φ k x' | none => emp) -∗ + iprop(⌜get? (Std.insert m i y) k = some y'⌝ → Ψ k y'))) ⊢ Ψ i y := by + have hlookup_insert : get? (Std.insert m i y) i = some y := lookup_insert_eq m i y + refine (sep_mono_r intuitionistically_elim).trans <| (sep_mono_r (forall_elim (a := i))).trans <| + (sep_mono_r (forall_elim (a := y))).trans ?_ + simp only [hm₁i, hlookup_insert] + exact (sep_mono_r (wand_mono_r true_imp.1)).trans wand_elim_r + have hweaken : iprop(□ (∀ k y', (match get? m₁ k with | some x' => Φ k x' | none => emp) -∗ + iprop(⌜get? (Std.insert m i y) k = some y'⌝ → Ψ k y'))) ⊢ + iprop(□ (∀ k y', (match get? (Std.delete m₁ i) k with | some x' => Φ k x' | none => emp) -∗ + iprop(⌜get? m k = some y'⌝ → Ψ k y'))) := by + apply intuitionistically_mono; apply forall_mono; intro k; apply forall_mono; intro y' + apply wand_intro; apply imp_intro'; apply pure_elim_l; intro hget_m + have hne : k ≠ i := by intro heq; rw [heq] at hget_m; exact Option.noConfusion (hi ▸ hget_m) + have hlookup_insert_ne : get? (Std.insert m i y) k = some y' := by + rw [lookup_insert_ne m i k y hne.symm]; exact hget_m + rw [lookup_delete_ne m₁ i k hne.symm] + simp only [hlookup_insert_ne] + exact (sep_mono_l (wand_mono_r true_imp.1)).trans wand_elim_l + have hfilter_equiv : bigSepM (fun k x => Φ k x) + (FiniteMap.filter (fun k _ => decide ((get? (Std.insert m i y) k).isNone)) m₁) ⊣⊢ + bigSepM (fun k x => Φ k x) + (FiniteMap.filter (fun k _ => decide ((get? m k).isNone)) (Std.delete m₁ i)) := by + simp only [bigSepM] + have hperm1 := @toList_filter M K V _ _ _ _ m₁ (fun k _ => decide ((get? (Std.insert m i y) k).isNone)) + have hperm2 := @toList_filter M K V _ _ _ _ (Std.delete m₁ i) (fun k _ => decide ((get? m k).isNone)) + have hdel_perm := map_to_list_delete m₁ i x hm₁i + have hpred1_i_false : decide ((get? (Std.insert m i y) i).isNone = true) = false := by + simp only [lookup_insert_eq, Option.isNone_some, decide_eq_false_iff_not]; exact fun h => nomatch h + have hpred_eq : ∀ k, k ≠ i → + decide ((get? (Std.insert m i y) k).isNone = true) = decide ((get? m k).isNone = true) := by + intro k hne; rw [lookup_insert_ne _ _ _ _ hne.symm] + have hfilter_perm1 : ((toList m₁).filter (fun kv => decide ((get? (Std.insert m i y) kv.fst).isNone))).Perm + ((toList (Std.delete m₁ i)).filter (fun kv => decide ((get? (Std.insert m i y) kv.fst).isNone))) := by + have h1 := hdel_perm.filter (fun kv => decide ((get? (Std.insert m i y) kv.fst).isNone)) + rw [List.filter_cons_of_neg (by simp only [hpred1_i_false]; exact Bool.false_ne_true)] at h1 + exact h1 + have hfilter_eq : ((toList (Std.delete m₁ i)).filter (fun kv => decide ((get? (Std.insert m i y) kv.fst).isNone))) = + ((toList (Std.delete m₁ i)).filter (fun kv => decide ((get? m kv.fst).isNone))) := by + apply List.filter_congr; intro ⟨k, v⟩ hkv + have hne : k ≠ i := by + intro heq; have hlookup := (elem_of_map_to_list (Std.delete m₁ i) k v).mpr hkv + rw [heq, lookup_delete_eq] at hlookup; exact Option.noConfusion hlookup + exact hpred_eq k hne + exact equiv_iff.mp (BigOpL.perm (Φ := fun (kv : K × V) => Φ kv.1 kv.2) + (hperm1.trans ((hfilter_eq ▸ hfilter_perm1).trans hperm2.symm))) + refine (sep_mono_l (sep_mono_l hdel.1)).trans <| (sep_mono_l sep_assoc.1).trans <| + sep_assoc.1.trans <| (sep_mono_r (sep_mono_l sep_comm.1)).trans <| + (sep_mono_r sep_assoc.1).trans <| sep_assoc.2.trans <| (sep_mono_l hΨ_from_hyp).trans <| + (sep_mono_r (sep_mono_r hweaken)).trans <| (sep_mono_r (IH (Std.delete m₁ i))).trans <| + (sep_mono_r (sep_mono_r hfilter_equiv.2)).trans <| sep_assoc.2.trans (sep_mono_l hinsert_goal.2) + +/-- Corresponds to `big_sepM_impl_dom_subseteq` in Rocq Iris. + Specialized version when the domain of m₂ is a subset of the domain of m₁. -/ +theorem impl_dom_subseteq [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} + [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] + {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M} {m₂ : M₂} + (_hdom : ∀ k, (get? m₂ k).isSome → (get? m₁ k).isSome) : + ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ + □ (∀ k x y, iprop(⌜get? m₁ k = some x⌝ → ⌜get? m₂ k = some y⌝ → Φ k x -∗ Ψ k y)) -∗ + ([∗map] k ↦ y ∈ m₂, Ψ k y) ∗ + [∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? m₂ k).isNone)) m₁, Φ k x := by + refine (impl_strong (Φ := Φ) (Ψ := Ψ) (m₁ := m₁) (m₂ := m₂)).trans ?_ + apply wand_mono_l; apply intuitionistically_mono + apply forall_mono; intro k; apply forall_intro; intro y' + apply wand_intro; apply imp_intro'; apply pure_elim_l; intro hget_m₂ + cases hget_m₁ : get? m₁ k with + | none => + exfalso + have hm₁_some := _hdom k (by simp only [hget_m₂, Option.isSome_some]) + rw [hget_m₁] at hm₁_some; exact Bool.false_ne_true hm₁_some + | some x => + simp only + have h1 : (iprop(⌜some x = some x⌝) → ⌜get? m₂ k = some y'⌝ → Φ k x -∗ Ψ k y') ⊢ + (iprop(⌜get? m₂ k = some y'⌝) → Φ k x -∗ Ψ k y') := + (imp_mono_l (pure_true rfl).2).trans true_imp.1 + have h2 : (iprop(⌜get? m₂ k = some y'⌝) → Φ k x -∗ Ψ k y') ⊢ (Φ k x -∗ Ψ k y') := + (imp_mono_l (pure_true hget_m₂).2).trans true_imp.1 + exact sep_comm.1.trans <| (sep_mono_r (forall_elim (PROP := PROP) x)).trans <| + (sep_mono_r (forall_elim (PROP := PROP) y')).trans <| + (sep_mono_r h1).trans <| (sep_mono_r h2).trans (sep_comm.1.trans wand_elim_l) + +/-! ## Key Mapping Lemmas -/ + +section Kmap + +variable {K₂ : Type _} {M₂ : Type _} +variable [DecidableEq K₂] +variable [FiniteMap M₂ K₂ V] [FiniteMapLaws M₂ K₂ V] + +/-- Key map: apply a function to all keys in a map. + `kmap h m` has entries `(h k, v)` for each `(k, v)` in `m`. + Requires `h` to be injective to preserve map semantics. -/ +def kmap (h : K → K₂) (m : M) : M₂ := + ofList ((toList m).map (fun kv => (h kv.1, kv.2))) + +omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] + [DecidableEq K₂] [FiniteMapLaws M₂ K₂ V] in +/-- Corresponds to `big_sepM_kmap` in Rocq Iris. + Note: The Rocq proof uses `map_to_list_kmap` (which we encode as `hperm`) and `big_opL_fmap`. + The `hinj` (injectivity) is needed in Rocq for `kmap` to be well-defined; here we take + an explicit permutation witness instead. -/ +theorem kmap' {Φ : K₂ → V → PROP} {m : M} + (h : K → K₂) (_hinj : Function.Injective h) + (hperm : (toList (kmap (M₂ := M₂) h m)).Perm + ((toList m).map (fun kv => (h kv.1, kv.2)))) : + ([∗map] k₂ ↦ y ∈ kmap (M₂ := M₂) h m, Φ k₂ y) ⊣⊢ + [∗map] k₁ ↦ y ∈ m, Φ (h k₁) y := by + simp only [bigSepM] + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (kmap (M₂ := M₂) h m)) ≡ + bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (h kv.1, kv.2))) := + BigOpL.perm _ hperm + refine equiv_iff.mp heq |>.trans ?_ + clear heq hperm + induction (toList m) with + | nil => exact .rfl + | cons kv kvs ih => + simp only [List.map, bigOpL] + exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + +end Kmap + +/-! ## List to Map Conversion Lemmas -/ + +section ListToMap + +variable [FiniteMap M Nat V] +variable [FiniteMapLaws M Nat V] +variable [FiniteMapSeqLaws M V] + +/-- Corresponds to `big_sepM_map_seq` in Rocq Iris. -/ +theorem map_seq {Φ : Nat → V → PROP} (start : Nat) (l : List V) : + ([∗map] k ↦ x ∈ (FiniteMap.map_seq start l : M), Φ k x) ⊣⊢ + ([∗list] i ↦ x ∈ l, Φ (start + i) x) := by + simp only [bigSepM, bigSepL] + have h1 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M)) ≡ + bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) := + BigOpL.perm (fun kv => Φ kv.fst kv.snd) (toList_map_seq (M := M) start l) + have h2 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) ≡ + bigOpL sep iprop(emp) (fun i x => Φ (start + i) x) l := + BigOpL.zip_seq (fun p => Φ p.1 p.2) start l + exact equiv_iff.mp (h1.trans h2) + +end ListToMap + +/-! ## Domain and Set Conversion Lemmas -/ + +section DomainSet + +variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] +variable [FiniteMapLawsSelf M K V] + +/-- Corresponds to `big_sepM_dom` in Rocq Iris. -/ +theorem dom {Φ : K → PROP} (m : M) : + ([∗map] k ↦ _v ∈ m, Φ k) ⊣⊢ ([∗set] k ∈ (domSet m : S), Φ k) := by + induction m using @FiniteMapLaws.map_ind M K V _ _ _ with + | hemp => + rw [domSet_empty] + exact ⟨empty.1.trans BigSepS.empty.2, BigSepS.empty.1.trans empty.2⟩ + | hins k v m hk_not_in IH => + have hk_not_in_dom : FiniteSet.mem k (domSet m : S) = false := by + cases h : FiniteSet.mem k (domSet m : S) + · rfl + · have ⟨v', hv⟩ := elem_of_domSet m k |>.mp h + rw [hk_not_in] at hv; cases hv + have hinsert_eq : FiniteSet.insert k (domSet m : S) = FiniteSet.singleton k ∪ (domSet m : S) := by + apply @FiniteSetLaws.ext S K _ _ + intro x + by_cases hx : x = k + · rw [FiniteSetLaws.mem_insert_eq _ _ _ hx] + have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := by + apply FiniteSetLaws.mem_union _ _ _ |>.mpr + left + exact FiniteSetLaws.mem_singleton _ _ |>.mpr hx + rw [this] + · rw [FiniteSetLaws.mem_insert_ne _ _ _ hx] + cases hm : FiniteSet.mem x (domSet m : S) + · have hsing : FiniteSet.mem x (FiniteSet.singleton k : S) = false := by + cases h : FiniteSet.mem x (FiniteSet.singleton k : S) + · rfl + · have : x = k := FiniteSetLaws.mem_singleton _ _ |>.mp h + exact absurd this hx + have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = false := by + cases h : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) + · rfl + · have : FiniteSet.mem x (FiniteSet.singleton k : S) = true ∨ FiniteSet.mem x (domSet m : S) = true := + FiniteSetLaws.mem_union _ _ _ |>.mp h + cases this with + | inl h' => rw [hsing] at h'; cases h' + | inr h' => rw [hm] at h'; cases h' + rw [this] + · have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := + FiniteSetLaws.mem_union _ _ _ |>.mpr (Or.inr hm) + rw [this] + rw [domSet_insert, hinsert_eq] + calc ([∗map] k' ↦ _v ∈ FiniteMap.insert m k v, Φ k') + ⊣⊢ Φ k ∗ ([∗map] k' ↦ _v ∈ m, Φ k') := insert hk_not_in + _ ⊣⊢ Φ k ∗ ([∗set] k' ∈ (domSet m : S), Φ k') := ⟨sep_mono_r IH.1, sep_mono_r IH.2⟩ + _ ⊣⊢ ([∗set] k' ∈ FiniteSet.singleton k ∪ (domSet m : S), Φ k') := (BigSepS.insert hk_not_in_dom).symm + +/-- Corresponds to `big_sepM_gset_to_gmap` in Rocq Iris. -/ +theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : + ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ⊣⊢ ([∗set] k ∈ X, Φ k c) := by + have hlookup : ∀ k v, get? (ofSet c X : M) k = some v → v = c := by + intro k v hv + simp only [ofSet, elem_of_list_to_map] at hv + have : (k, v) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := + list_lookup_some_mem k v _ hv + have : (k, v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := + List.mem_reverse.mp this + rw [List.mem_map] at this + obtain ⟨x, _, heq⟩ := this + simp at heq + exact heq.2.symm + + have h1 : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ≡ + ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) := by + apply proper + intro k v hv + have : v = c := hlookup k v hv + rw [this] + have h2 : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) ⊣⊢ + ([∗set] k ∈ (domSet (ofSet c X : M) : S), Φ k c) := dom _ + have h3 : (domSet (ofSet c X : M) : S) = X := domSet_ofSet c X + rw [h3] at h2 + have h1' : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ⊣⊢ + ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) := BI.equiv_iff.mp h1 + exact BiEntails.trans h1' h2 + +end DomainSet + +/-! ## Commuting Lemmas -/ + +/-- Corresponds to `big_sepM_sepL` in Rocq Iris. -/ +theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M) (l : List B) : + ([∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y) ⊣⊢ + ([∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y) := by + calc [∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y + _ ⊣⊢ [∗list] kv ∈ toList m, [∗list] k'↦y ∈ l, Φ kv.1 kv.2 k' y := + equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl + _ ⊣⊢ [∗list] k'↦y ∈ l, [∗list] kv ∈ toList m, Φ kv.1 kv.2 k' y := + @BigSepL.sepL PROP _ (K × V) B (fun _ kv k' y => Φ kv.1 kv.2 k' y) (toList m) l + _ ⊣⊢ [∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y := + equiv_iff.mp <| BigSepL.congr fun k' y => .rfl + +/-- Corresponds to `big_sepM_sepM` in Rocq Iris. -/ +theorem sepM {M₂ : Type _} {K₂ : Type _} {V₂ : Type _} + [DecidableEq K₂] [FiniteMap M₂ K₂ V₂] [FiniteMapLaws M₂ K₂ V₂] + (Φ : K → V → K₂ → V₂ → PROP) (m₁ : M) (m₂ : M₂) : + ([∗map] k₁↦x₁ ∈ m₁, [∗map] k₂↦x₂ ∈ m₂, Φ k₁ x₁ k₂ x₂) ⊣⊢ + ([∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂) := by + calc [∗map] k₁↦x₁ ∈ m₁, [∗map] k₂↦x₂ ∈ m₂, Φ k₁ x₁ k₂ x₂ + _ ⊣⊢ [∗list] kv₁ ∈ toList m₁, [∗map] k₂↦x₂ ∈ m₂, Φ kv₁.1 kv₁.2 k₂ x₂ := + equiv_iff.mp <| BigSepL.congr fun _ kv₁ => .rfl + _ ⊣⊢ [∗list] kv₁ ∈ toList m₁, [∗list] kv₂ ∈ toList m₂, Φ kv₁.1 kv₁.2 kv₂.1 kv₂.2 := + equiv_iff.mp <| BigSepL.congr fun _ kv₁ => .rfl + _ ⊣⊢ [∗list] kv₂ ∈ toList m₂, [∗list] kv₁ ∈ toList m₁, Φ kv₁.1 kv₁.2 kv₂.1 kv₂.2 := + @BigSepL.sepL PROP _ (K × V) (K₂ × V₂) (fun _ kv₁ _ kv₂ => Φ kv₁.1 kv₁.2 kv₂.1 kv₂.2) + (toList m₁) (toList m₂) + _ ⊣⊢ [∗list] kv₂ ∈ toList m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ kv₂.1 kv₂.2 := + equiv_iff.mp <| BigSepL.congr fun _ kv₂ => .rfl + _ ⊣⊢ [∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂ := + equiv_iff.mp <| BigSepL.congr fun _ kv₂ => .rfl + +/-- Corresponds to `big_sepM_sepS` in Rocq Iris. -/ +theorem sepS {B : Type _} {S : Type _} + [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] + (Φ : K → V → B → PROP) (m : M) (X : S) : + ([∗map] k↦x ∈ m, [∗set] y ∈ X, Φ k x y) ⊣⊢ + ([∗set] y ∈ X, [∗map] k↦x ∈ m, Φ k x y) := by + calc [∗map] k↦x ∈ m, [∗set] y ∈ X, Φ k x y + _ ⊣⊢ [∗list] kv ∈ toList m, [∗set] y ∈ X, Φ kv.1 kv.2 y := + equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl + _ ⊣⊢ [∗list] kv ∈ toList m, [∗list] y ∈ toList X, Φ kv.1 kv.2 y := + equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl + _ ⊣⊢ [∗list] y ∈ toList X, [∗list] kv ∈ toList m, Φ kv.1 kv.2 y := + @BigSepL.sepL PROP _ (K × V) B (fun _ kv _ y => Φ kv.1 kv.2 y) (toList m) (toList X) + _ ⊣⊢ [∗list] y ∈ toList X, [∗map] k↦x ∈ m, Φ k x y := + equiv_iff.mp <| BigSepL.congr fun _ y => .rfl + _ ⊣⊢ [∗set] y ∈ X, [∗map] k↦x ∈ m, Φ k x y := + equiv_iff.mp <| BigSepL.congr fun _ y => .rfl + +end BigSepM + +end Iris.BI diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean new file mode 100644 index 00000000..de86ae57 --- /dev/null +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -0,0 +1,949 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp +import Iris.BI.BigOp.BigSepList +import Iris.BI.Instances +import Iris.Std.TC + +namespace Iris.BI + +open Iris.Algebra +open Iris.Std +open BIBase + +/-! # Big Separating Conjunction over Sets + +- Rocq Iris: `iris/bi/big_op.v`, Section `sep_set` -/ + +variable {PROP : Type _} [BI PROP] +variable {S : Type _} {A : Type _} +variable [DecidableEq A] [FiniteSet S A] [FiniteSetLaws S A] + +namespace BigSepS + +/-! ## Monotonicity and Congruence -/ + +private theorem mono_list {Φ Ψ : A → PROP} {l : List A} + (h : ∀ x, List.Mem x l → Φ x ⊢ Ψ x) : + bigOpL sep emp (fun _ x => Φ x) l ⊢ bigOpL sep emp (fun _ x => Ψ x) l := by + induction l with + | nil => exact Entails.rfl + | cons x xs ih => + simp only [BigOpL.cons] + apply sep_mono + · exact h x (List.Mem.head xs) + · apply ih + intro y hy + exact h y (List.Mem.tail x hy) + +/-- Corresponds to `big_sepS_mono` in Rocq Iris. -/ +theorem mono {Φ Ψ : A → PROP} {X : S} + (h : ∀ x, FiniteSet.mem x X = true → Φ x ⊢ Ψ x) : + ([∗set] x ∈ X, Φ x) ⊢ [∗set] x ∈ X, Ψ x := by + unfold bigSepS + apply mono_list + intro x hx + have := (FiniteSetLaws.mem_toList X x).mp hx + exact h x this + +/-- Corresponds to `big_sepS_ne` in Rocq Iris. -/ +theorem ne {Φ Ψ : A → PROP} {X : S} {n : Nat} + (h : ∀ x, FiniteSet.mem x X = true → Φ x ≡{n}≡ Ψ x) : + ([∗set] x ∈ X, Φ x) ≡{n}≡ ([∗set] x ∈ X, Ψ x) := by + unfold bigSepS + apply BigOpL.congr_ne + intro i x hget + have hmem : List.Mem x (toList X) := List.mem_of_getElem? hget + have := (FiniteSetLaws.mem_toList X x).mp hmem + exact h x this + +/-- Corresponds to `big_sepS_proper` in Rocq Iris. -/ +theorem proper {Φ Ψ : A → PROP} {X : S} + (h : ∀ x, FiniteSet.mem x X = true → Φ x ⊣⊢ Ψ x) : + ([∗set] x ∈ X, Φ x) ⊣⊢ ([∗set] x ∈ X, Ψ x) := by + unfold bigSepS + apply equiv_iff.mp + apply BigOpL.congr + intro i x hget + have hmem_list : List.Mem x (toList X) := List.mem_of_getElem? hget + have hmem := (FiniteSetLaws.mem_toList X x).mp hmem_list + exact equiv_iff.mpr (h x hmem) + +/-- Corresponds to `big_sepS_mono'` in Rocq Iris. -/ +theorem mono' {Φ Ψ : A → PROP} {X : S} + (h : ∀ x, Φ x ⊢ Ψ x) : + ([∗set] x ∈ X, Φ x) ⊢ [∗set] x ∈ X, Ψ x := + mono (fun x _ => h x) + +/-- Corresponds to `big_sepS_flip_mono'` in Rocq Iris. -/ +theorem flip_mono' {Φ Ψ : A → PROP} {X : S} + (h : ∀ x, Ψ x ⊢ Φ x) : + ([∗set] x ∈ X, Ψ x) ⊢ [∗set] x ∈ X, Φ x := + mono' h + +/-! ## Basic Structural Lemmas -/ + +/-- Corresponds to `big_sepS_elements` in Rocq Iris. -/ +theorem elements {Φ : A → PROP} {X : S} : + ([∗set] x ∈ X, Φ x) ⊣⊢ [∗list] x ∈ toList X, Φ x := by + unfold bigSepS bigSepL + exact .rfl + +/-- Corresponds to `big_sepS_empty` in Rocq Iris. -/ +@[simp] +theorem empty {Φ : A → PROP} : + ([∗set] x ∈ (∅ : S), Φ x) ⊣⊢ emp := by + unfold bigSepS + rw [FiniteSetLaws.toList_empty] + simp only [BigOpL.nil] + exact .rfl + +/-- Corresponds to `big_sepS_empty'` in Rocq Iris. -/ +theorem empty' {P : PROP} [Affine P] {Φ : A → PROP} : + P ⊢ [∗set] x ∈ (∅ : S), Φ x := + Affine.affine.trans empty.2 + +/-- Corresponds to `big_sepS_emp` in Rocq Iris. -/ +theorem emp' {X : S} : + ([∗set] x ∈ X, emp) ⊣⊢ (emp : PROP) := by + unfold bigSepS + have := @BigOpL.unit_const PROP _ _ sep emp _ (toList X) + exact equiv_iff.mp this + +/-- Corresponds to `big_sepS_singleton` in Rocq Iris. -/ +theorem singleton {Φ : A → PROP} {x : A} : + ([∗set] y ∈ (FiniteSet.singleton x : S), Φ y) ⊣⊢ Φ x := by + unfold bigSepS + have hperm := FiniteSetLaws.toList_singleton (S := S) (x : A) + have hp := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + simp only [BigOpL.cons, BigOpL.nil] at hp + exact hp.trans sep_emp + +/-- Corresponds to `big_sepS_union` in Rocq Iris. -/ +theorem union {Φ : A → PROP} {X Y : S} + (h : FiniteSet.Disjoint X Y) : + ([∗set] y ∈ X ∪ Y, Φ y) ⊣⊢ ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) := by + unfold bigSepS + obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union (S := S) X Y h + have hp1 := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + have happ := equiv_iff.mp (@BigOpL.append PROP _ _ sep emp _ (fun _ x => Φ x) (toList X) l') + have hp2 : bigOpL sep emp (fun _ => Φ) (toList X) ∗ bigOpL sep emp (fun _ => Φ) l' ⊣⊢ + bigOpL sep emp (fun _ => Φ) (toList X) ∗ bigOpL sep emp (fun _ => Φ) (toList Y) := + sep_congr_r (equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm'.symm)) + exact hp1.trans (happ.trans hp2) + +private theorem bigSepS_perm_of_mem_eq {Φ : A → PROP} {X Y : S} + (hmem_eq : ∀ z, FiniteSet.mem z X = FiniteSet.mem z Y) : + ([∗set] y ∈ X, Φ y) ⊣⊢ ([∗set] y ∈ Y, Φ y) := by + have hsub1 : X ⊆ Y := fun z hz => by have := hmem_eq z; rwa [← this] + have hsub2 : Y ⊆ X := fun z hz => by have := hmem_eq z; rwa [this] + have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset Y X hsub1 + have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset X Y hsub2 + have hl1_nil : l₁ = [] := by + have h1 := hperm1.length_eq + have h2 := hperm2.length_eq + simp only [List.length_append] at h1 h2 + have : l₁.length = 0 := by omega + match l₁ with + | [] => rfl + | _ :: _ => simp at this + rw [hl1_nil, List.append_nil] at hperm1 + unfold bigSepS + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm1) + +/-- Corresponds to `big_sepS_delete` in Rocq Iris. -/ +theorem delete {Φ : A → PROP} {X : S} {x : A} + (h : FiniteSet.mem x X = true) : + ([∗set] y ∈ X, Φ y) ⊣⊢ Φ x ∗ [∗set] y ∈ FiniteSet.diff X (FiniteSet.singleton x), Φ y := by + unfold bigSepS + obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_sdiff (S := S) X x h + have hp1 := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + simp only [BigOpL.cons] at hp1 + have hp2 : Φ x ∗ bigOpL sep emp (fun _ => Φ) l' ⊣⊢ + Φ x ∗ bigOpL sep emp (fun _ => Φ) (toList (diff X (FiniteSet.singleton x))) := + sep_congr_r (equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm'.symm)) + exact hp1.trans hp2 + +/-- Corresponds to `big_sepS_insert` in Rocq Iris. -/ +theorem insert {Φ : A → PROP} {X : S} {x : A} + (h : FiniteSet.mem x X = false) : + ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) ⊣⊢ Φ x ∗ [∗set] y ∈ X, Φ y := by + have hdisj : FiniteSet.Disjoint (FiniteSet.singleton x : S) X := by + intro y ⟨hmem1, hmem2⟩ + by_cases hyx : y = x + · subst hyx; simp_all + · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx] at hmem1 + rw [FiniteSetLaws.mem_empty] at hmem1 + exact Bool.noConfusion hmem1 + have hunion := union (Φ := Φ) hdisj + exact hunion.trans (sep_congr_l singleton) + +/-- Corresponds to `big_sepS_union_2` in Rocq Iris. -/ +theorem union_2 {Φ : A → PROP} {X Y : S} + [h : ∀ x, TCOr (Affine (Φ x)) (Absorbing (Φ x))] : + ⊢ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ Y, Φ y) -∗ ([∗set] y ∈ X ∪ Y, Φ y) := by + have h_core : ∀ X : S, ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) ⊢ ([∗set] y ∈ X ∪ Y, Φ y) := by + intro X + refine FiniteSet.set_ind (P := fun X => ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) ⊢ ([∗set] y ∈ X ∪ Y, Φ y)) ?_ ?_ X + · refine (sep_mono_l empty.1).trans ?_ + refine emp_sep.1.trans ?_ + have hmem_eq : ∀ z, FiniteSet.mem z (∅ ∪ Y) = FiniteSet.mem z Y := fun z => by + have hunion := FiniteSetLaws.mem_union (∅ : S) Y z + have hempty := FiniteSetLaws.mem_empty (S := S) (A := A) z + cases hz : FiniteSet.mem z (∅ ∪ Y) <;> cases hy : FiniteSet.mem z Y + · rfl + · have := hunion.mpr (Or.inr hy); rw [hz] at this; exact Bool.noConfusion this + · have := hunion.mp hz + cases this with + | inl hl => rw [hempty] at hl; exact Bool.noConfusion hl + | inr hr => rw [hy] at hr; exact Bool.noConfusion hr + · rfl + exact (bigSepS_perm_of_mem_eq hmem_eq).2 + · intro x X' hnotin IH + have hdisj : FiniteSet.Disjoint (FiniteSet.singleton x : S) X' := by + intro y ⟨hmem1, hmem2⟩ + by_cases hyx : y = x + · subst hyx; simp_all + · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx] at hmem1 + rw [FiniteSetLaws.mem_empty] at hmem1 + exact Bool.noConfusion hmem1 + have hunion_x_X' := union (Φ := Φ) hdisj + have hins : ([∗set] y ∈ FiniteSet.singleton x ∪ X', Φ y) ⊣⊢ Φ x ∗ [∗set] y ∈ X', Φ y := + hunion_x_X'.trans (sep_congr_l singleton) + refine (sep_mono_l hins.1).trans ?_ + have h_assoc := @sep_assoc PROP _ (Φ x) ([∗set] y ∈ X', Φ y) ([∗set] y ∈ Y, Φ y) + refine h_assoc.1.trans ?_ + refine (sep_mono_r IH).trans ?_ + by_cases hx_in_Y : FiniteSet.mem x Y = true + · have hx_in_union : FiniteSet.mem x (X' ∪ Y) = true := + (FiniteSetLaws.mem_union X' Y x).mpr (Or.inr hx_in_Y) + have hmem_eq : ∀ w, FiniteSet.mem w (X' ∪ Y) = + FiniteSet.mem w ((FiniteSet.singleton x ∪ X') ∪ Y) := fun w => by + by_cases hwx : w = x + · rw [hwx] + have lhs : FiniteSet.mem x (X' ∪ Y) = true := + (FiniteSetLaws.mem_union X' Y x).mpr (Or.inr hx_in_Y) + have rhs_inner : FiniteSet.mem x (FiniteSet.singleton x ∪ X') = true := by + rw [FiniteSetLaws.mem_union, FiniteSet.singleton, FiniteSetLaws.mem_insert_eq _ _ _ rfl] + simp + have rhs : FiniteSet.mem x ((FiniteSet.singleton x ∪ X') ∪ Y) = true := + (FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl rhs_inner) + rw [lhs, rhs] + · rw [Bool.eq_iff_iff] + rw [FiniteSetLaws.mem_union X' Y w, FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y w] + rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) X' w] + rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hwx, FiniteSetLaws.mem_empty] + simp + refine (sep_mono_r (delete hx_in_union).1).trans ?_ + refine sep_assoc.2.trans ?_ + refine (sep_mono_l sep_elim_l).trans ?_ + refine (delete hx_in_union).2.trans ?_ + exact (@bigSepS_perm_of_mem_eq PROP _ S A _ _ _ Φ _ _ hmem_eq).1 + · have hx_notin_union : FiniteSet.mem x (X' ∪ Y) = false := by + have : ¬(FiniteSet.mem x (X' ∪ Y) = true) := by + intro h + have := (FiniteSetLaws.mem_union X' Y x).mp h + cases this with + | inl h' => simp [h'] at hnotin + | inr h' => simp [h'] at hx_in_Y + cases h : FiniteSet.mem x (X' ∪ Y) + · rfl + · contradiction + have hmem_eq : ∀ w, FiniteSet.mem w (FiniteSet.singleton x ∪ (X' ∪ Y)) = + FiniteSet.mem w ((FiniteSet.singleton x ∪ X') ∪ Y) := fun w => by + by_cases hwx : w = x + · rw [hwx] + have lhs_inner : FiniteSet.mem x (FiniteSet.singleton (S := S) x) = true := by + rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_eq (S := S) _ _ _ rfl] + have lhs : FiniteSet.mem x (FiniteSet.singleton x ∪ (X' ∪ Y)) = true := + (FiniteSetLaws.mem_union (S := S) (FiniteSet.singleton x) (X' ∪ Y) x).mpr (Or.inl lhs_inner) + have rhs_inner : FiniteSet.mem x (FiniteSet.singleton x ∪ X') = true := + (FiniteSetLaws.mem_union (FiniteSet.singleton x) X' x).mpr (Or.inl lhs_inner) + have rhs : FiniteSet.mem x ((FiniteSet.singleton x ∪ X') ∪ Y) = true := + (FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl rhs_inner) + rw [lhs, rhs] + · rw [Bool.eq_iff_iff] + rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) (X' ∪ Y) w] + rw [FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y w] + rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) X' w] + rw [FiniteSetLaws.mem_union X' Y w] + rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hwx, FiniteSetLaws.mem_empty] + simp + refine (insert hx_notin_union).2.trans ?_ + exact (@bigSepS_perm_of_mem_eq PROP _ S A _ _ _ Φ _ _ hmem_eq).1 + have h1 : ([∗set] y ∈ X, Φ y) ⊢ ([∗set] y ∈ Y, Φ y) -∗ ([∗set] y ∈ X ∪ Y, Φ y) := + wand_intro' ((sep_comm (PROP := PROP)).1.trans (h_core X)) + exact entails_wand h1 + +/-- Corresponds to `big_sepS_insert_2` in Rocq Iris. -/ +theorem insert_2 {Φ : A → PROP} {X : S} {x : A} + [TCOr (Affine (Φ x)) (Absorbing (Φ x))] : + Φ x ⊢ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) := by + apply wand_intro + by_cases hx : FiniteSet.mem x X = true + · have hdel := (@delete PROP _ S A _ _ _ Φ X x hx).1 + refine (sep_mono_r hdel).trans ?_ + refine (sep_assoc (PROP := PROP)).2.trans ?_ + refine (sep_mono_l sep_elim_l).trans ?_ + have hunion_sub_X : (FiniteSet.singleton x ∪ X) ⊆ X := fun y hy => by + rw [FiniteSetLaws.mem_union] at hy + cases hy with + | inl h => + by_cases hyx : y = x + · subst hyx; exact hx + · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx, FiniteSetLaws.mem_empty] at h + exact Bool.noConfusion h + | inr h => exact h + have hX_sub_union : X ⊆ (FiniteSet.singleton x ∪ X) := fun y hy => by + rw [FiniteSetLaws.mem_union] + right; exact hy + have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset X (FiniteSet.singleton x ∪ X) hunion_sub_X + have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (FiniteSet.singleton x ∪ X) X hX_sub_union + have hl1_nil : l₁ = [] := by + have h := hperm1.length_eq + have h2 := hperm2.length_eq + simp only [List.length_append] at h h2 + have : l₁.length = 0 := by omega + match l₁ with + | [] => rfl + | _ :: _ => simp at this + rw [hl1_nil, List.append_nil] at hperm1 + have heq : ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) ⊣⊢ ([∗set] y ∈ X, Φ y) := by + unfold bigSepS + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm1) + exact (@delete PROP _ S A _ _ _ Φ X x hx).2.trans heq.2 + · have hx' : FiniteSet.mem x X = false := eq_false_of_ne_true hx + have hinsert := (@insert PROP _ S A _ _ _ Φ X x hx').2 + exact hinsert + +/-- Corresponds to `big_sepS_insert_2'` in Rocq Iris. -/ +theorem insert_2' {Φ : A → PROP} {X : S} {x : A} + [TCOr (Affine (Φ x)) (Absorbing (Φ x))] : + ⊢ Φ x -∗ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ X ∪ FiniteSet.singleton x, Φ y) := by + have heq : ([∗set] y ∈ X ∪ FiniteSet.singleton x, Φ y) ⊣⊢ + ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) := by + unfold bigSepS + have hperm := FiniteSetLaws.toList_union_comm (S := S) (A := A) X (FiniteSet.singleton x) + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + have h1 : ⊢ Φ x -∗ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) := + entails_wand insert_2 + exact h1.trans (wand_mono_r (wand_mono_r heq.2)) + +/-! ## Function Insertion -/ + +/-- Function update: returns `b` if `k = i`, otherwise `f k`. -/ +def fnInsert {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) : B := + if k = i then b else f k + +theorem fnInsert_same {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) : + fnInsert f i b i = b := by simp [fnInsert] + +theorem fnInsert_ne {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) (h : k ≠ i) : + fnInsert f i b k = f k := by simp [fnInsert, h] + +/-- Corresponds to `big_sepS_fn_insert` in Rocq Iris. -/ +theorem fn_insert {B : Type _} {Ψ : A → B → PROP} {f : A → B} {X : S} {x : A} {b : B} + (h : FiniteSet.mem x X = false) : + ([∗set] y ∈ FiniteSet.singleton x ∪ X, Ψ y (fnInsert f x b y)) ⊣⊢ + Ψ x b ∗ [∗set] y ∈ X, Ψ y (f y) := by + have hins := insert (Φ := fun y => Ψ y (fnInsert f x b y)) h + have hhead : Ψ x (fnInsert f x b x) ⊣⊢ Ψ x b := by + simp only [fnInsert_same] + exact .rfl + have htail : ([∗set] y ∈ X, Ψ y (fnInsert f x b y)) ⊣⊢ + [∗set] y ∈ X, Ψ y (f y) := by + apply proper + intro y hy + have hne : y ≠ x := by + intro heq + rw [←heq] at h + rw [hy] at h + cases h + simp only [fnInsert_ne f x b y hne] + exact .rfl + exact hins.trans ⟨(sep_mono hhead.1 htail.1), (sep_mono hhead.2 htail.2)⟩ + +/-- Corresponds to `big_sepS_fn_insert'` in Rocq Iris. -/ +theorem fn_insert' {Φ : A → PROP} {X : S} {x : A} {P : PROP} + (h : FiniteSet.mem x X = false) : + ([∗set] y ∈ FiniteSet.singleton x ∪ X, fnInsert Φ x P y) ⊣⊢ + P ∗ [∗set] y ∈ X, Φ y := + fn_insert (Ψ := fun _ P => P) (f := Φ) (b := P) h + +/-- Corresponds to `big_sepS_delete_2` in Rocq Iris. -/ +theorem delete_2 {Φ : A → PROP} {X : S} {x : A} + [hAff : Affine (Φ x)] : + Φ x ⊢ ([∗set] y ∈ FiniteSet.diff X (FiniteSet.singleton x), Φ y) -∗ [∗set] y ∈ X, Φ y := by + apply wand_intro + by_cases hx : FiniteSet.mem x X = true + · exact (delete (Φ := Φ) hx).2 + · have hdiff_sub : ∀ y, FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true → + FiniteSet.mem y X = true := fun y hy => + ((FiniteSetLaws.mem_diff_singleton X x y).mp hy).1 + have hX_sub : ∀ y, FiniteSet.mem y X = true → + FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true := by + intro y hy + rw [FiniteSetLaws.mem_diff_singleton] + constructor + · exact hy + · intro heq + subst heq + exact hx hy + refine (sep_mono_l hAff.affine).trans emp_sep.1 |>.trans ?_ + have hX_sub_diff : X ⊆ FiniteSet.diff X (FiniteSet.singleton x) := fun y hy => hX_sub y hy + have hdiff_sub_X : FiniteSet.diff X (FiniteSet.singleton x) ⊆ X := fun y hy => hdiff_sub y hy + have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset (FiniteSet.diff X (FiniteSet.singleton x)) X hX_sub_diff + have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset X (FiniteSet.diff X (FiniteSet.singleton x)) hdiff_sub_X + have hlen_eq : (toList (FiniteSet.diff X (FiniteSet.singleton x))).length = + (toList X).length := by + have h1 := hperm1.length_eq + have h2 := hperm2.length_eq + simp only [List.length_append] at h1 h2 + omega + have hl1_nil : l₁ = [] := by + have h := hperm1.length_eq + simp only [List.length_append] at h + have : l₁.length = 0 := by omega + match l₁ with + | [] => rfl + | _ :: _ => simp at this + rw [hl1_nil, List.append_nil] at hperm1 + unfold bigSepS + exact (equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm1.symm)).1 + +/-! ## Lookup and Access -/ + +/-- Corresponds to `big_sepS_elem_of` in Rocq Iris. -/ +theorem elem_of {Φ : A → PROP} {X : S} {x : A} + (hmem : x ∈ X) : + [TCOr (∀ y, Affine (Φ y)) (Absorbing (Φ x))] → + ([∗set] y ∈ X, Φ y) ⊢ Φ x + | TCOr.l => by + have hdel := delete (Φ := Φ) (S := S) hmem + refine hdel.1.trans ?_ + exact sep_elim_l + | TCOr.r => by + have hdel := delete (Φ := Φ) (S := S) hmem + refine hdel.1.trans ?_ + exact sep_elim_l + +/-- Corresponds to `big_sepS_elem_of_acc` in Rocq Iris. -/ +theorem elem_of_acc {Φ : A → PROP} {X : S} {x : A} + (h : x ∈ X) : + ([∗set] y ∈ X, Φ y) ⊢ Φ x ∗ (Φ x -∗ ([∗set] y ∈ X, Φ y)) := by + have hdel := delete (Φ := Φ) (S := S) h + refine hdel.1.trans ?_ + apply sep_mono_r + exact wand_intro' hdel.2 + +/-! ## Typeclass Instances -/ + +/-- Corresponds to `big_sepS_empty_persistent` in Rocq Iris. -/ +instance empty_persistent {Φ : A → PROP} : + Persistent ([∗set] x ∈ (∅ : S), Φ x) where + persistent := by + unfold bigSepS + rw [FiniteSetLaws.toList_empty] + simp only [BigOpL.nil] + exact persistently_emp_intro (PROP := PROP) (P := emp) + +private theorem persistent_list {Φ : A → PROP} {l : List A} + (h : ∀ x, List.Mem x l → Persistent (Φ x)) : + bigOpL sep emp (fun _ => Φ) l ⊢ bigOpL sep emp (fun _ => Φ) l := by + induction l with + | nil => exact persistently_emp_intro + | cons x xs ih => + simp only [BigOpL.cons] + have h1 : Φ x ⊢ Φ x := (h x (List.Mem.head xs)).persistent + have h2 : bigOpL sep emp (fun _ y => Φ y) xs ⊢ bigOpL sep emp (fun _ y => Φ y) xs := + ih (fun y hy => h y (List.Mem.tail x hy)) + exact (sep_mono h1 h2).trans persistently_sep_2 + +/-- Corresponds to `big_sepS_persistent` in Rocq Iris. -/ +theorem persistent_cond {Φ : A → PROP} {X : S} + (h : ∀ x, x ∈ X → Persistent (Φ x)) : + Persistent ([∗set] x ∈ X, Φ x) where + persistent := by + unfold bigSepS + apply persistent_list + intro x hmem_list + have hmem := (FiniteSetLaws.mem_toList X x).mp hmem_list + exact h x hmem + +/-- Corresponds to `big_sepS_persistent'` in Rocq Iris. -/ +instance persistent {Φ : A → PROP} {X : S} + [h : ∀ x, Persistent (Φ x)] : + Persistent ([∗set] x ∈ X, Φ x) := + persistent_cond (Φ := Φ) (X := X) (fun _ _ => h _) + +/-- Corresponds to `big_sepS_empty_affine` in Rocq Iris. -/ +instance empty_affine {Φ : A → PROP} : + Affine ([∗set] x ∈ (∅ : S), Φ x) where + affine := by + have h := empty (Φ := Φ) (S := S) + exact h.1 + +private theorem affine_list {Φ : A → PROP} {l : List A} + (h : ∀ x, List.Mem x l → Affine (Φ x)) : + bigOpL sep emp (fun _ => Φ) l ⊢ emp := by + induction l with + | nil => exact Entails.rfl + | cons x xs ih => + simp only [BigOpL.cons] + have h1 : Φ x ⊢ emp := (h x (List.Mem.head xs)).affine + have h2 : bigOpL sep emp (fun _ y => Φ y) xs ⊢ emp := + ih (fun y hy => h y (List.Mem.tail x hy)) + exact (sep_mono h1 h2).trans sep_emp.1 + +/-- Corresponds to `big_sepS_affine` in Rocq Iris. -/ +theorem affine_cond {Φ : A → PROP} {X : S} + (h : ∀ x, x ∈ X → Affine (Φ x)) : + Affine ([∗set] x ∈ X, Φ x) where + affine := by + unfold bigSepS + apply affine_list + intro x hmem_list + have hmem := (FiniteSetLaws.mem_toList X x).mp hmem_list + exact h x hmem + +/-- Corresponds to `big_sepS_affine'` in Rocq Iris. -/ +instance affine {Φ : A → PROP} {X : S} + [h : ∀ x, Affine (Φ x)] : + Affine ([∗set] x ∈ X, Φ x) := + affine_cond (fun _ _ => h _) + +/-! ## List/Set Conversion -/ + +/-- Corresponds to `big_sepS_list_to_set` in Rocq Iris. -/ +theorem list_to_set {Φ : A → PROP} {l : List A} + (h : l.Nodup) : + ([∗set] x ∈ (ofList l : S), Φ x) ⊣⊢ [∗list] x ∈ l, Φ x := by + unfold bigSepS bigSepL + have hperm := FiniteSetLaws.toList_ofList l (ofList l : S) h rfl + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + +/-! ## Filter -/ + +/-- Corresponds to `big_sepS_filter'` in Rocq Iris. -/ +theorem filter' (φ : A → Prop) [DecidablePred φ] {Φ : A → PROP} {X : S} : + ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) X, Φ y) ⊣⊢ + ([∗set] y ∈ X, if φ y then Φ y else emp) := by + unfold bigSepS + have hperm := FiniteSetLaws.toList_filter (S := S) X (fun x => decide (φ x)) + have h1 := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) + refine h1.trans ?_ + have h2 : ∀ l : List A, + bigOpL sep emp (fun _ => Φ) (l.filter (fun x => decide (φ x))) ⊣⊢ + bigOpL sep emp (fun _ x => if φ x then Φ x else emp) l := by + intro l + induction l with + | nil => + simp only [List.filter, BigOpL.nil] + exact .rfl + | cons y ys ih => + simp only [BigOpL.cons] + by_cases hy : φ y + · have hdec : decide (φ y) = true := by simp [hy] + have hfilt : List.filter (fun x => decide (φ x)) (y :: ys) = + y :: List.filter (fun x => decide (φ x)) ys := by + simp [List.filter, hdec] + rw [hfilt] + simp only [BigOpL.cons, hy, ↓reduceIte] + exact sep_congr_r ih + · have hdec : decide (φ y) = false := by simp [hy] + have hfilt : List.filter (fun x => decide (φ x)) (y :: ys) = + List.filter (fun x => decide (φ x)) ys := by + simp [List.filter, hdec] + rw [hfilt] + simp only [hy, ↓reduceIte] + exact ih.trans (emp_sep (PROP := PROP)).symm + exact h2 (toList X) + +/-- Corresponds to `big_sepS_filter` in Rocq Iris. -/ +theorem filter [BIAffine PROP] (φ : A → Prop) [DecidablePred φ] {Φ : A → PROP} {X : S} : + ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) X, Φ y) ⊣⊢ + ([∗set] y ∈ X, ⌜φ y⌝ → Φ y) := by + refine (filter' φ).trans (proper fun y _ => ?_) + by_cases hy : φ y + · simp only [hy, ↓reduceIte] + exact true_imp (PROP := PROP).symm + · simp only [hy, ↓reduceIte] + constructor + · apply imp_intro' + apply pure_elim_l (R := Φ y) + intro hf + exact hf.elim + · exact Affine.affine (self := BIAffine.affine _) + +/-- Corresponds to `big_sepS_filter_acc'` in Rocq Iris. -/ +theorem filter_acc' (φ : A → Prop) [DecidablePred φ] {Φ : A → PROP} {X Y : S} + (h : ∀ y, FiniteSet.mem y Y = true → φ y → FiniteSet.mem y X = true) : + ([∗set] y ∈ X, Φ y) ⊢ + ([∗set] y ∈ Y, if φ y then Φ y else emp) ∗ + (([∗set] y ∈ Y, if φ y then Φ y else emp) -∗ [∗set] y ∈ X, Φ y) := by + -- First, show that filter φ Y ⊆ X + have hfilter_sub : FiniteSet.filter (fun x => decide (φ x)) Y ⊆ X := by + intro z hz + have ⟨hz_Y, hz_φ⟩ := FiniteSetLaws.mem_filter Y (fun x => decide (φ x)) z |>.mp hz + have : φ z := of_decide_eq_true hz_φ + exact h z hz_Y this + -- Use union_diff to decompose X + have ⟨hdisj, hmem_decomp⟩ := FiniteSetLaws.union_diff X (FiniteSet.filter (fun x => decide (φ x)) Y) hfilter_sub + -- X = filterY ∪ (X \ filterY), and they are disjoint + have hX_decomp : X = FiniteSet.filter (fun x => decide (φ x)) Y ∪ + FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y) := by + apply @FiniteSetLaws.ext S A _ _ + intro z + apply Bool.eq_iff_iff.mpr + constructor + · intro hz; rw [FiniteSetLaws.mem_union]; exact (hmem_decomp z).mp hz + · intro hz; rw [FiniteSetLaws.mem_union] at hz; exact (hmem_decomp z).mpr hz + -- Apply union: [∗set] X = [∗set] filterY ∗ [∗set] (X \ filterY) + have hunion := @union PROP _ S A _ _ _ Φ (FiniteSet.filter (fun x => decide (φ x)) Y) + (FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y)) hdisj + have hX_split : ([∗set] y ∈ X, Φ y) ⊣⊢ + ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) Y, Φ y) ∗ + ([∗set] y ∈ FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y), Φ y) := by + -- Convert equality to equivalence, then compose with hunion + have heq : ([∗set] y ∈ X, Φ y) = ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) Y ∪ + FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y), Φ y) := + congrArg (fun s => bigSepS Φ s) hX_decomp + exact BIBase.BiEntails.of_eq heq |>.trans hunion + -- Apply filter': [∗set] filterY = [∗set] y ∈ Y, if φ y then Φ y else emp + have hfilter := @filter' PROP _ S A _ _ _ φ _ Φ Y + -- Combine: [∗set] X ⊣⊢ A ∗ Z where A = [∗set] Y with filter, Z = [∗set] (X \ filterY) + have hcombined : ([∗set] y ∈ X, Φ y) ⊣⊢ + ([∗set] y ∈ Y, if φ y then Φ y else emp) ∗ + ([∗set] y ∈ FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y), Φ y) := + hX_split.trans (sep_congr_l hfilter) + -- Now prove the goal: X ⊢ A ∗ (A -∗ X) + -- From X ⊣⊢ A ∗ Z, we have X ⊢ A ∗ Z + refine hcombined.1.trans ?_ + -- Need: A ∗ Z ⊢ A ∗ (A -∗ X) + apply sep_mono + · -- Prove: A ⊢ A + exact BIBase.Entails.rfl + · -- Prove: Z ⊢ A -∗ X + apply wand_intro' + -- Goal becomes: A ∗ Z ⊢ X + -- This is exactly hcombined.2 + exact hcombined.2 + +/-- Corresponds to `big_sepS_filter_acc` in Rocq Iris. -/ +theorem filter_acc [BIAffine PROP] (φ : A → Prop) [DecidablePred φ] {Φ : A → PROP} {X Y : S} + (h : ∀ y, FiniteSet.mem y Y = true → φ y → FiniteSet.mem y X = true) : + ([∗set] y ∈ X, Φ y) ⊢ + ([∗set] y ∈ Y, ⌜φ y⌝ → Φ y) ∗ + (([∗set] y ∈ Y, ⌜φ y⌝ → Φ y) -∗ [∗set] y ∈ X, Φ y) := by + have h1 := @filter_acc' PROP _ S A _ _ _ φ _ Φ X Y h + have h_equiv : ([∗set] y ∈ Y, if φ y then Φ y else emp) ⊣⊢ ([∗set] y ∈ Y, ⌜φ y⌝ → Φ y) := by + apply proper + intro y _ + by_cases hy : φ y + · simp only [hy, ↓reduceIte] + exact true_imp (PROP := PROP).symm + · simp only [hy, ↓reduceIte] + constructor + · apply imp_intro' + apply pure_elim_l (R := Φ y) + intro hf + exact hf.elim + · exact Affine.affine (self := BIAffine.affine _) + refine h1.trans ?_ + apply sep_mono + · exact h_equiv.1 + · apply wand_mono h_equiv.2 + exact BIBase.Entails.rfl + +/-! ## Separation Logic Combinators -/ + +/-- Corresponds to `big_sepS_sep` in Rocq Iris. -/ +theorem sep' {Φ Ψ : A → PROP} {X : S} : + ([∗set] y ∈ X, Φ y ∗ Ψ y) ⊣⊢ ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ X, Ψ y) := by + unfold bigSepS + have := @BigOpL.op_distr PROP _ _ sep emp _ (fun _ x => Φ x) (fun _ x => Ψ x) (toList X) + exact equiv_iff.mp this + +/-- Corresponds to `big_sepS_sep_2` in Rocq Iris. -/ +theorem sep_2 {Φ Ψ : A → PROP} {X : S} : + ([∗set] y ∈ X, Φ y) ⊢ + ([∗set] y ∈ X, Ψ y) -∗ + ([∗set] y ∈ X, Φ y ∗ Ψ y) := by + apply wand_intro (PROP := PROP) + refine sep_comm (PROP := PROP).1.trans ?_ + have h := @sep' PROP _ S A _ _ _ Ψ Φ X + refine h.2.trans ?_ + apply mono + intro x _ + exact sep_comm (PROP := PROP).1 + +/-- Corresponds to `big_sepS_and` in Rocq Iris. -/ +theorem and' {Φ Ψ : A → PROP} {X : S} : + ([∗set] y ∈ X, Φ y ∧ Ψ y) ⊢ ([∗set] y ∈ X, Φ y) ∧ ([∗set] y ∈ X, Ψ y) := by + apply and_intro + · exact mono (fun _ _ => and_elim_l) + · exact mono (fun _ _ => and_elim_r) + +/-! ## Pure Propositions -/ + +/-- Corresponds to `big_sepS_pure_1` in Rocq Iris. -/ +theorem pure_1 {φ : A → Prop} {X : S} : + ([∗set] y ∈ X, ⌜φ y⌝) ⊢ (⌜∀ y, y ∈ X → φ y⌝ : PROP) := by + refine elements.1.trans ?_ + refine BigSepL.pure_1.trans (pure_mono ?_) + intro h y hmem + have hlist : List.Mem y (toList X) := (FiniteSetLaws.mem_toList X y).mpr hmem + have ⟨i, hget⟩ := List.getElem?_of_mem hlist + exact h i y hget + +/-- Corresponds to `big_sepS_affinely_pure_2` in Rocq Iris. -/ +theorem affinely_pure_2 {φ : A → Prop} {X : S} : + ( (⌜∀ y, y ∈ X → φ y⌝ : PROP)) ⊢ ([∗set] y ∈ X, ⌜φ y⌝) := by + have hlist : ( ⌜∀ k x, (toList X)[k]? = some x → φ x⌝ : PROP) ⊢ + ([∗list] _k ↦ x ∈ toList X, ⌜φ x⌝) := + BigSepL.affinely_pure_2 + refine (affinely_mono (pure_mono ?_)).trans hlist + intro h k x hget + have hmem : List.Mem x (toList X) := List.mem_of_getElem? hget + have hset_mem := (FiniteSetLaws.mem_toList X x).mp hmem + exact h x hset_mem + +/-- Corresponds to `big_sepS_pure` in Rocq Iris. -/ +theorem pure [BIAffine PROP] {φ : A → Prop} {X : S} : + ([∗set] y ∈ X, ⌜φ y⌝) ⊣⊢ (⌜∀ y, y ∈ X → φ y⌝ : PROP) := + ⟨pure_1, (affine_affinely _).2.trans <| affinely_pure_2.trans (mono fun _ _ => affinely_elim)⟩ + +/-- Corresponds to `big_sepS_forall` in Rocq Iris. -/ +theorem forall' [BIAffine PROP] {Φ : A → PROP} {X : S} + [hPers : ∀ x, Persistent (Φ x)] : + ([∗set] x ∈ X, Φ x) ⊣⊢ (∀ x, ⌜x ∈ X⌝ → Φ x) := by + constructor + · apply forall_intro + intro x + apply imp_intro' + apply pure_elim_l + intro hmem + haveI hAff : ∀ y, Affine (Φ y) := fun y => BIAffine.affine (Φ y) + exact @elem_of PROP _ S A _ _ _ Φ X x hmem (@TCOr.l _ _ (hAff)) + · unfold bigSepS + have hmem_all : ∀ x, List.Mem x (toList X) → FiniteSet.mem x X = true := + fun x hmem => (FiniteSetLaws.mem_toList X x).mp hmem + have helper : ∀ l, (∀ x, List.Mem x l → FiniteSet.mem x X = true) → + (∀ x, ⌜x ∈ X⌝ → Φ x) ⊢ bigOpL sep emp (fun _ => Φ) l := by + intro l hl + induction l with + | nil => + simp only [BigOpL.nil] + exact Affine.affine (self := BIAffine.affine _) + | cons y ys ih => + simp only [BigOpL.cons] + have hy_mem : FiniteSet.mem y X = true := hl y (List.Mem.head ys) + have hhead : (∀ x, ⌜x ∈ X⌝ → Φ x) ⊢ Φ y := + (forall_elim y).trans ((and_intro (pure_intro hy_mem) .rfl).trans imp_elim_r) + refine and_self.2.trans (and_mono_l hhead) |>.trans ?_ + refine (persistent_and_sep_1 (P := Φ y)).trans ?_ + exact sep_mono_r (ih (fun x hx => hl x (List.Mem.tail y hx))) + exact helper (toList X) hmem_all + +/-! ## Modal Operators -/ + +/-- Corresponds to `big_sepS_persistently` in Rocq Iris. -/ +theorem persistently [BIAffine PROP] {Φ : A → PROP} {X : S} : + ( ([∗set] y ∈ X, Φ y)) ⊣⊢ [∗set] y ∈ X, (Φ y) := + (persistently_congr elements).trans (BigSepL.persistently.trans elements.symm) + +/-- Corresponds to `big_sepS_dup` in Rocq Iris. -/ +theorem dup {P : PROP} [hAff : Affine P] {X : S} : + ⊢ □ (P -∗ P ∗ P) -∗ P -∗ [∗set] _x ∈ X, P := by + unfold bigSepS + apply wand_intro + apply wand_intro + refine (sep_mono_l emp_sep.1).trans ?_ + induction toList X with + | nil => + simp only [BigOpL.nil] + exact sep_elim_r.trans hAff.affine + | cons y ys ih => + simp only [BigOpL.cons] + refine (sep_mono_l (intuitionistically_sep_idem (PROP := PROP)).2).trans ?_ + refine sep_assoc (PROP := PROP).1.trans ?_ + refine (sep_mono_r <| (sep_mono_l intuitionistically_elim).trans wand_elim_l).trans ?_ + refine sep_assoc (PROP := PROP).2.trans ?_ + refine (sep_mono_l ih).trans ?_ + exact sep_comm (PROP := PROP).1 + +/-- Corresponds to `big_sepS_later` in Rocq Iris. -/ +theorem later [BIAffine PROP] {Φ : A → PROP} {X : S} : + iprop(▷ [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷ Φ y := + (later_congr elements).trans (BigSepL.later.trans elements.symm) + +/-- Corresponds to `big_sepS_later_2` in Rocq Iris. -/ +theorem later_2 {Φ : A → PROP} {X : S} : + ([∗set] y ∈ X, ▷ Φ y) ⊢ iprop(▷ [∗set] y ∈ X, Φ y) := + elements.1.trans (BigSepL.later_2.trans (later_mono elements.2)) + +/-- Corresponds to `big_sepS_laterN` in Rocq Iris. -/ +theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : + iprop(▷^[n] [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷^[n] Φ y := by + induction n with + | zero => exact .rfl + | succ m ih => exact (later_congr ih).trans later + +/-- Corresponds to `big_sepS_laterN_2` in Rocq Iris. -/ +theorem laterN_2 {Φ : A → PROP} {n : Nat} {X : S} : + ([∗set] y ∈ X, ▷^[n] Φ y) ⊢ iprop(▷^[n] [∗set] y ∈ X, Φ y) := by + induction n with + | zero => exact .rfl + | succ m ih => exact later_2.trans (later_mono ih) + +/-! ## Introduction and Elimination -/ + +private theorem intro_list {Φ : A → PROP} {X : S} {l : List A} + (hmem : ∀ x, List.Mem x l → FiniteSet.mem x X = true) : + (□ (∀ x, ⌜FiniteSet.mem x X = true⌝ → Φ x)) ⊢ bigOpL sep emp (fun _ => Φ) l := by + induction l with + | nil => exact Affine.affine (self := intuitionistically_affine (PROP := PROP) _) + | cons y ys ih => + have hy := hmem y (List.Mem.head ys) + refine intuitionistically_sep_idem.2.trans (sep_mono ?_ (ih (fun x hx => hmem x (List.Mem.tail y hx)))) + exact intuitionistically_elim.trans <| + (forall_elim y).trans <| (and_intro (pure_intro hy) .rfl).trans imp_elim_r + +/-- Corresponds to `big_sepS_intro` in Rocq Iris. -/ +theorem intro {Φ : A → PROP} {X : S} : + (□ (∀ x, ⌜x ∈ X⌝ → Φ x)) ⊢ [∗set] x ∈ X, Φ x := by + unfold bigSepS + apply intro_list (X := X) + intro x hmem_list + exact (FiniteSetLaws.mem_toList X x).mp hmem_list + +/-- Corresponds to `big_sepS_impl` in Rocq Iris. -/ +theorem impl {Φ Ψ : A → PROP} {X : S} : + ([∗set] x ∈ X, Φ x) ⊢ + (□ (∀ x, ⌜x ∈ X⌝ → Φ x -∗ Ψ x)) -∗ + [∗set] x ∈ X, Ψ x := by + apply BI.wand_intro + have h1 : iprop(□ (∀ x, ⌜x ∈ X⌝ → Φ x -∗ Ψ x)) ⊢ [∗set] x ∈ X, (Φ x -∗ Ψ x) := intro + refine (sep_mono_r h1).trans ?_ + refine sep'.2.trans ?_ + apply mono + intro _ _ + exact wand_elim_r (PROP := PROP) + +/-- Corresponds to `big_sepS_wand` in Rocq Iris. -/ +theorem wand' {Φ Ψ : A → PROP} {X : S} : + ([∗set] x ∈ X, Φ x) ⊢ + ([∗set] x ∈ X, Φ x -∗ Ψ x) -∗ + [∗set] x ∈ X, Ψ x := by + apply BI.wand_intro (PROP := PROP) + refine sep_comm (PROP := PROP).1.trans ?_ + refine sep'.2.trans ?_ + apply mono + intro _ _ + exact wand_elim_l (PROP := PROP) + +/-- Corresponds to `big_sepS_elem_of_acc_impl` in Rocq Iris. -/ +theorem elem_of_acc_impl {Φ : A → PROP} {X : S} {x : A} + (h : x ∈ X) : + ([∗set] y ∈ X, Φ y) ⊢ + Φ x ∗ + (∀ (Ψ : A → PROP), + (□ (∀ y, ⌜y ∈ X⌝ → ⌜x ≠ y⌝ → Φ y -∗ Ψ y)) -∗ + Ψ x -∗ + ([∗set] y ∈ X, Ψ y)) := by + have hdel := (delete (Φ := Φ) h).1 + refine hdel.trans (sep_mono_r ?_) + apply forall_intro + intro Ψ + apply BI.wand_intro + apply BI.wand_intro + have hdel_Ψ := (delete (Φ := Ψ) (S := S) h).2 + have h1 : iprop(□ (∀ y, ⌜y ∈ X⌝ → ⌜x ≠ y⌝ → Φ y -∗ Ψ y)) ⊢ + iprop(□ (∀ y, ⌜FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true⌝ → Φ y -∗ Ψ y)) := by + apply intuitionistically_mono + apply forall_intro + intro y + apply imp_intro' + apply pure_elim_l + intro hy_diff + have ⟨hy_X, hy_ne⟩ := (FiniteSetLaws.mem_diff_singleton X x y).mp hy_diff + exact (forall_elim y).trans <| + (imp_mono_l (pure_mono fun _ => hy_X)).trans true_imp.1 |>.trans <| + (imp_mono_l (pure_mono fun _ => hy_ne.symm)).trans true_imp.1 + refine sep_assoc.1.trans ?_ + refine (sep_mono_r (sep_comm (PROP := PROP).1)).trans ?_ + refine (sep_comm (PROP := PROP).1).trans ?_ + refine sep_assoc.1.trans ?_ + refine (sep_mono_r ?_).trans hdel_Ψ + refine (sep_mono_l h1).trans ?_ + refine (sep_comm (PROP := PROP).1).trans ?_ + have h_impl := @impl PROP _ S A _ _ _ Φ Ψ (FiniteSet.diff X (FiniteSet.singleton x)) + refine (sep_mono_l h_impl).trans ?_ + refine (sep_comm (PROP := PROP).1).trans ?_ + exact wand_elim_r (PROP := PROP) + +/-! ## Subsumption -/ + +/-- Corresponds to `big_sepS_subseteq` in Rocq Iris. -/ +theorem subseteq {Φ : A → PROP} {X Y : S} + [h : ∀ x, Affine (Φ x)] + (hsub : Y ⊆ X) : + ([∗set] x ∈ X, Φ x) ⊢ [∗set] x ∈ Y, Φ x := by + unfold bigSepS + have ⟨l, hperm⟩ := FiniteSetLaws.toList_subset X Y hsub + exact BigSepL.submseteq hperm + +/-! ## Commuting Lemmas -/ + +/-- Corresponds to `big_sepS_sepL` in Rocq Iris. -/ +theorem sepL {B : Type _} (Φ : A → Nat → B → PROP) (X : S) (l : List B) : + ([∗set] x ∈ X, [∗list] k↦y ∈ l, Φ x k y) ⊣⊢ + ([∗list] k↦y ∈ l, [∗set] x ∈ X, Φ x k y) := by + calc [∗set] x ∈ X, [∗list] k↦y ∈ l, Φ x k y + _ ⊣⊢ [∗list] x ∈ toList X, [∗list] k↦y ∈ l, Φ x k y := elements (Φ := fun x => [∗list] k↦y ∈ l, Φ x k y) + _ ⊣⊢ [∗list] k↦y ∈ l, [∗list] x ∈ toList X, Φ x k y := + @BigSepL.sepL PROP _ A B (fun _ x k y => Φ x k y) (toList X) l + _ ⊣⊢ [∗list] k↦y ∈ l, [∗set] x ∈ X, Φ x k y := + equiv_iff.mp <| BigSepL.congr (fun k y => equiv_iff.mpr <| elements (Φ := fun x => Φ x k y).symm) + +/-- Corresponds to `big_sepS_sepS` in Rocq Iris. -/ +theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (Φ : A → B → PROP) (X : S) (Y : T) : + ([∗set] x ∈ X, [∗set] y ∈ Y, Φ x y) ⊣⊢ + ([∗set] y ∈ Y, [∗set] x ∈ X, Φ x y) := by + calc [∗set] x ∈ X, [∗set] y ∈ Y, Φ x y + _ ⊣⊢ [∗list] x ∈ toList X, [∗set] y ∈ Y, Φ x y := elements (Φ := fun x => [∗set] y ∈ Y, Φ x y) + _ ⊣⊢ [∗list] x ∈ toList X, [∗list] y ∈ toList Y, Φ x y := + equiv_iff.mp <| BigSepL.congr (fun _ x => equiv_iff.mpr <| elements (Φ := Φ x)) + _ ⊣⊢ [∗list] y ∈ toList Y, [∗list] x ∈ toList X, Φ x y := + @BigSepL.sepL PROP _ A B (fun _ x _ y => Φ x y) (toList X) (toList Y) + _ ⊣⊢ [∗list] y ∈ toList Y, [∗set] x ∈ X, Φ x y := + equiv_iff.mp <| BigSepL.congr (fun _ y => equiv_iff.mpr <| elements (Φ := fun x => Φ x y).symm) + _ ⊣⊢ [∗set] y ∈ Y, [∗set] x ∈ X, Φ x y := elements (Φ := fun y => [∗set] x ∈ X, Φ x y).symm + +/-- Corresponds to `big_sepS_sepM` in Rocq Iris. -/ +theorem sepM {B : Type _} {M : Type _} {K : Type _} + [DecidableEq K] [FiniteMap M K B] [FiniteMapLaws M K B] + (Φ : A → K → B → PROP) (X : S) (m : M) : + ([∗set] x ∈ X, [∗map] k↦y ∈ m, Φ x k y) ⊣⊢ + ([∗map] k↦y ∈ m, [∗set] x ∈ X, Φ x k y) := by + calc [∗set] x ∈ X, [∗map] k↦y ∈ m, Φ x k y + _ ⊣⊢ [∗list] x ∈ toList X, [∗map] k↦y ∈ m, Φ x k y := + elements (Φ := fun x => [∗map] k↦y ∈ m, Φ x k y) + _ ⊣⊢ [∗list] x ∈ toList X, [∗list] kv ∈ toList m, Φ x kv.1 kv.2 := by + apply equiv_iff.mp; apply BigSepL.congr + intro _ x; unfold bigSepM; exact equiv_iff.mpr .rfl + _ ⊣⊢ [∗list] kv ∈ toList m, [∗list] x ∈ toList X, Φ x kv.1 kv.2 := + @BigSepL.sepL PROP _ A (K × B) (fun _ x _ kv => Φ x kv.1 kv.2) (toList X) (toList m) + _ ⊣⊢ [∗list] kv ∈ toList m, [∗set] x ∈ X, Φ x kv.1 kv.2 := by + apply equiv_iff.mp; apply BigSepL.congr + intro _ kv; exact equiv_iff.mpr (elements (Φ := fun x => Φ x kv.1 kv.2)).symm + _ ⊣⊢ [∗map] k↦y ∈ m, [∗set] x ∈ X, Φ x k y := + equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl + +end BigSepS + +end Iris.BI diff --git a/src/Iris/BI/BigOps.lean b/src/Iris/BI/BigOps.lean new file mode 100644 index 00000000..96a2e028 --- /dev/null +++ b/src/Iris/BI/BigOps.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.BI.BigOp.BigOp +import Iris.BI.BigOp.BigSepList +import Iris.BI.BigOp.BigSepMap +import Iris.BI.BigOp.BigSepSet +import Iris.BI.BigOp.BigAndList +import Iris.BI.BigOp.BigAndMap +import Iris.BI.BigOp.BigOrList + +/-! # Big Operations for Separation Logic + +This file exports all big operation modules for Iris/BI: +- Core definitions (bigSepL, bigAndL, bigOrL, bigSepM, bigAndM, bigSepS) +- Implementation lemmas for lists, maps, and sets +- Lemmas for separating conjunction, conjunction, and disjunction + +Import this file to get access to all big operation functionality. +-/ diff --git a/src/Iris/BI/DerivedLaws.lean b/src/Iris/BI/DerivedLaws.lean index 8913e26b..47b69bb7 100644 --- a/src/Iris/BI/DerivedLaws.lean +++ b/src/Iris/BI/DerivedLaws.lean @@ -9,6 +9,7 @@ import Iris.BI.BI import Iris.Std.Classes import Iris.Std.Rewrite import Iris.Std.TC +import Iris.Algebra.Monoid namespace Iris.BI open Iris.Std BI @@ -193,15 +194,6 @@ theorem imp_trans [BI PROP] {P Q R : PROP} : (P → Q) ∧ (Q → R) ⊢ P → R theorem false_imp [BI PROP] {P : PROP} : (False → P) ⊣⊢ True := ⟨true_intro, imp_intro <| and_elim_r.trans false_elim⟩ -instance [BI PROP] : LawfulBigOp and (iprop(True) : PROP) BiEntails where - refl := .rfl - symm h := h.symm - trans h1 h2 := h1.trans h2 - comm := and_comm - assoc := and_assoc - left_id := true_and - congr_l := and_congr_l - theorem and_left_comm [BI PROP] {P Q R : PROP} : P ∧ Q ∧ R ⊣⊢ Q ∧ P ∧ R := and_assoc.symm.trans <| (and_congr_l and_comm).trans and_assoc @@ -281,15 +273,6 @@ instance [BI PROP] : LeftId (α := PROP) BiEntails emp sep := ⟨emp_sep⟩ theorem sep_emp [BI PROP] {P : PROP} : P ∗ emp ⊣⊢ P := sep_comm.trans emp_sep instance [BI PROP] : RightId (α := PROP) BiEntails emp sep := ⟨sep_emp⟩ -instance [BI PROP] : LawfulBigOp sep (emp : PROP) BiEntails where - refl := .rfl - symm h := h.symm - trans h1 h2 := h1.trans h2 - comm := sep_comm - assoc := sep_assoc - left_id := emp_sep - congr_l := sep_congr_l - theorem true_sep_2 [BI PROP] {P : PROP} : P ⊢ True ∗ P := emp_sep.2.trans (sep_mono_l true_intro) theorem wand_intro' [BI PROP] {P Q R : PROP} (h : Q ∗ P ⊢ R) : P ⊢ Q -∗ R := @@ -971,6 +954,9 @@ theorem intuitionistically_and_sep [BI PROP] {P Q : PROP} : □ (P ∧ Q) ⊣⊢ theorem intuitionistically_sep_idem [BI PROP] {P : PROP} : □ P ∗ □ P ⊣⊢ □ P := and_sep_intuitionistically.symm.trans and_self +theorem intuitionistically_sep_dup [BI PROP] {P : PROP} : □ P ⊣⊢ □ P ∗ □ P := + intuitionistically_sep_idem.symm + theorem intuitionistically_wand [BI PROP] {P Q : PROP} : (□ P -∗ Q) ⊣⊢ ( P → Q) := ⟨imp_intro <| persistently_and_intuitionistically_sep_r.1.trans wand_elim_l, wand_intro <|persistently_and_intuitionistically_sep_r.2.trans imp_elim_l⟩ @@ -1484,16 +1470,6 @@ instance imp_absorbing [BI PROP] (P Q : PROP) [Persistent P] [Absorbing P] [Abso absorbing := imp_intro' <| persistent_and_affinely_sep_l.1.trans <| absorbingly_sep_r.1.trans <| (absorbingly_mono <| persistent_and_affinely_sep_l.2.trans imp_elim_r).trans absorbing -theorem bigOp_sep_nil [BI PROP] : iprop([∗] []) ⊣⊢ (emp : PROP) := .rfl - -theorem bigOp_and_nil [BI PROP] : iprop([∧] []) ⊣⊢ (True : PROP) := .rfl - -theorem bigOp_sep_cons [BI PROP] {P : PROP} {Ps : List PROP} : - [∗] (P :: Ps) ⊣⊢ P ∗ [∗] Ps := bigOp_cons - -theorem bigOp_and_cons [BI PROP] {P : PROP} {Ps : List PROP} : - [∧] (P :: Ps) ⊣⊢ P ∧ [∧] Ps := bigOp_cons - /-! # Reduction to boolean comparisons -/ theorem and_forall_bool [BI PROP] {P Q : PROP} : @@ -1644,3 +1620,121 @@ theorem loeb_wand_intuitionistically [BI PROP] [BILoeb PROP] {P : PROP} : theorem loeb_wand [BI PROP] [BILoeb PROP] {P : PROP} : □ (▷ P -∗ P) ⊢ P := (intuitionistically_mono (wand_mono intuitionistically_elim .rfl)).trans loeb_wand_intuitionistically + +/-! ## Monoid Instances for Big Operators -/ + +/-- `∧` forms a commutative monoid with unit `True`. -/ +instance bi_and_monoid [BI PROP] : Algebra.Monoid PROP BIBase.and iprop(True) where + op_ne := and_ne + op_assoc _ _ _ := equiv_iff.mpr and_assoc + op_comm _ _ := equiv_iff.mpr and_comm + op_left_id _ := equiv_iff.mpr true_and + +/-- `∨` forms a commutative monoid with unit `False`. -/ +instance bi_or_monoid [BI PROP] : Algebra.Monoid PROP BIBase.or iprop(False) where + op_ne := or_ne + op_assoc _ _ _ := equiv_iff.mpr or_assoc + op_comm _ _ := equiv_iff.mpr or_comm + op_left_id _ := equiv_iff.mpr false_or + +/-- `∗` forms a commutative monoid with unit `emp`. -/ +instance bi_sep_monoid [BI PROP] : Algebra.Monoid PROP BIBase.sep iprop(emp) where + op_ne := sep_ne + op_assoc _ _ _ := equiv_iff.mpr sep_assoc + op_comm _ _ := equiv_iff.mpr sep_comm + op_left_id _ := equiv_iff.mpr emp_sep + +/-- `` is a monoid homomorphism for `∧`/`True` with respect to `≡`. -/ +instance bi_persistently_and_homomorphism [BI PROP] : + Algebra.MonoidHomomorphism BIBase.and BIBase.and iprop(True) iprop(True) + (· ≡ ·) (@BIBase.persistently PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (and_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := persistently_ne + homomorphism _ _ := equiv_iff.mpr persistently_and + map_unit := equiv_iff.mpr persistently_pure + +/-- `` is a monoid homomorphism for `∨`/`False` with respect to `≡`. -/ +instance bi_persistently_or_homomorphism [BI PROP] : + Algebra.MonoidHomomorphism BIBase.or BIBase.or iprop(False) iprop(False) + (· ≡ ·) (@BIBase.persistently PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (or_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := persistently_ne + homomorphism _ _ := equiv_iff.mpr persistently_or + map_unit := equiv_iff.mpr persistently_pure + +/-- `` is a weak monoid homomorphism for `∗`/`emp` with respect to `≡` when `BiPositive`. -/ +instance bi_persistently_sep_weak_homomorphism [BI PROP] [BIPositive PROP] : + Algebra.WeakMonoidHomomorphism BIBase.sep BIBase.sep iprop(emp) iprop(emp) + (· ≡ ·) (@BIBase.persistently PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (sep_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := persistently_ne + homomorphism _ _ := equiv_iff.mpr persistently_sep + +/-- `` is a monoid homomorphism for `∗`/`emp` with respect to `≡` when `BiAffine`. -/ +instance bi_persistently_sep_homomorphism [BI PROP] [BIAffine PROP] : + Algebra.MonoidHomomorphism BIBase.sep BIBase.sep iprop(emp) iprop(emp) + (· ≡ ·) (@BIBase.persistently PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (sep_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := persistently_ne + homomorphism _ _ := equiv_iff.mpr persistently_sep + map_unit := equiv_iff.mpr persistently_emp' + +/-- `` is a weak monoid homomorphism for `∗`/`emp` with respect to `flip (⊢)`. -/ +instance bi_persistently_sep_entails_weak_homomorphism [BI PROP] : + Algebra.WeakMonoidHomomorphism BIBase.sep BIBase.sep iprop(emp) iprop(emp) + (flip BIBase.Entails) (@BIBase.persistently PROP _) where + rel_refl _ := BIBase.Entails.rfl + rel_trans h1 h2 := h2.trans h1 + rel_proper h1 h2 := ⟨fun h => (BI.equiv_iff.mp h2).2.trans (h.trans (BI.equiv_iff.mp h1).1), + fun h => (BI.equiv_iff.mp h2).1.trans (h.trans (BI.equiv_iff.mp h1).2)⟩ + op_proper h1 h2 := sep_mono h1 h2 + f_ne := persistently_ne + homomorphism _ _ := persistently_sep_2 + +/-- `` is a monoid homomorphism for `∗`/`emp` with respect to `flip (⊢)`. -/ +instance bi_persistently_sep_entails_homomorphism [BI PROP] : + Algebra.MonoidHomomorphism BIBase.sep BIBase.sep iprop(emp) iprop(emp) + (flip BIBase.Entails) (@BIBase.persistently PROP _) where + rel_refl _ := BIBase.Entails.rfl + rel_trans h1 h2 := h2.trans h1 + rel_proper h1 h2 := ⟨fun h => (BI.equiv_iff.mp h2).2.trans (h.trans (BI.equiv_iff.mp h1).1), + fun h => (BI.equiv_iff.mp h2).1.trans (h.trans (BI.equiv_iff.mp h1).2)⟩ + op_proper h1 h2 := sep_mono h1 h2 + f_ne := persistently_ne + homomorphism _ _ := persistently_sep_2 + map_unit := persistently_emp_intro + +/-- `▷` is a monoid homomorphism for `∧`/`True` with respect to `≡`. -/ +instance bi_later_and_homomorphism [BI PROP] : + Algebra.MonoidHomomorphism BIBase.and BIBase.and iprop(True) iprop(True) + (· ≡ ·) (@BIBase.later PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (and_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := later_ne + homomorphism _ _ := equiv_iff.mpr later_and + map_unit := equiv_iff.mpr later_true + +/-- `▷` is a weak monoid homomorphism for `∨`/`False` with respect to `≡`. -/ +instance bi_later_or_weak_homomorphism [BI PROP] : + Algebra.WeakMonoidHomomorphism BIBase.or BIBase.or iprop(False) iprop(False) + (· ≡ ·) (@BIBase.later PROP _) where + rel_refl _ := OFE.Equiv.rfl + rel_trans h1 h2 := h1.trans h2 + rel_proper h1 h2 := ⟨fun h => h1.symm.trans (h.trans h2), fun h => h1.trans (h.trans h2.symm)⟩ + op_proper h1 h2 := equiv_iff.mpr (or_congr (equiv_iff.mp h1) (equiv_iff.mp h2)) + f_ne := later_ne + homomorphism _ _ := equiv_iff.mpr later_or diff --git a/src/Iris/BI/Plainly.lean b/src/Iris/BI/Plainly.lean index c8b49fb4..048d2379 100644 --- a/src/Iris/BI/Plainly.lean +++ b/src/Iris/BI/Plainly.lean @@ -91,7 +91,7 @@ theorem plainly_forall_2 {Ψ : α → PROP} : (∀ a, ■ (Ψ a)) ⊢ ■ (∀ a theorem plainly_persistently_elim : ■ P ⊣⊢ ■ P := by constructor - · refine (true_and.2.trans <| and_mono emp_intro .rfl).trans ?_ + · refine (true_and.mpr.trans <| and_mono emp_intro .rfl).trans ?_ refine .trans ?_ (mono <| and_forall_bool.2.trans persistently_and_emp_elim) refine and_forall_bool.1.trans ?_ refine .trans ?_ plainly_forall_2 @@ -101,12 +101,12 @@ theorem plainly_persistently_elim : ■ P ⊣⊢ ■ P := by theorem absorbingly_elim_plainly : ■ P ⊣⊢ ■ P := by constructor - · refine (absorbingly_mono <| persistently_elim_plainly.2).trans ?_ - refine .trans ?_ persistently_elim_plainly.1 - exact absorbingly_persistently.1.trans .rfl + · refine (absorbingly_mono persistently_elim_plainly.mpr).trans ?_ + refine .trans ?_ persistently_elim_plainly.mp + exact absorbingly_persistently.mp.trans .rfl · refine .trans ?_ (absorbingly_mono persistently_elim_plainly.1) - refine persistently_elim_plainly.2.trans ?_ - exact .trans .rfl absorbingly_persistently.2 + refine persistently_elim_plainly.mpr.trans ?_ + exact .trans .rfl absorbingly_persistently.mpr theorem plainly_and_sep_elim : ■ P ∧ Q ⊢ (emp ∧ P) ∗ Q := (and_mono elim_persistently .rfl).trans persistently_and_sep_elim_emp @@ -201,7 +201,7 @@ theorem plainly_true_emp : ■ True ⊣⊢ ■ (emp : PROP) := theorem plainly_and_sep : ■ (P ∧ Q) ⊢ ■ (P ∗ Q) := by refine (plainly_and.mp.trans <| (and_mono idem .rfl).trans plainly_and.mpr).trans ?_ refine (mono <| and_mono .rfl emp_sep.mpr).trans ?_ - refine (mono <| plainly_and_sep_assoc.1).trans ?_ + refine (mono <| plainly_and_sep_assoc.mp).trans ?_ refine (mono <| sep_mono and_comm.mp .rfl).trans ?_ exact (mono <| sep_mono plainly_and_emp_elim .rfl).trans .rfl diff --git a/src/Iris/Instances/Classical/Instance.lean b/src/Iris/Instances/Classical/Instance.lean index 78a8aef5..50071a0b 100644 --- a/src/Iris/Instances/Classical/Instance.lean +++ b/src/Iris/Instances/Classical/Instance.lean @@ -136,25 +136,17 @@ instance : BI (HeapProp Val) where constructor · exact h_PQ σ₁ h_P · exact h_P'Q' σ₂ h_P' - emp_sep.mp := by + emp_sep {P} := ⟨by simp only [BI.Entails, BI.sep, BI.emp] - intro _ ⟨σ₁, σ₂, h_union, _, h_emp, h_P⟩ + intro σ ⟨σ₁, σ₂, h_union, _, h_emp, h_P⟩ rw [h_emp] at h_union rw [← empty_union] at h_union rw [h_union] - exact h_P - emp_sep.mpr := by + exact h_P, + by simp only [BI.Entails, BI.sep, BI.emp] intro σ h_P - apply Exists.intro ∅ - apply Exists.intro σ - constructor - · exact empty_union - constructor - · exact empty_disjoint - constructor - · rfl - · exact h_P + exact ⟨∅, σ, empty_union, empty_disjoint, rfl, h_P⟩⟩ sep_symm := by simp only [BI.Entails, BI.sep] intro _ _ _ ⟨σ₁, σ₂, h_union, h_disjoint, h_P, h_Q⟩ diff --git a/src/Iris/Instances/UPred/Instance.lean b/src/Iris/Instances/UPred/Instance.lean index ceab2607..3fc731b4 100644 --- a/src/Iris/Instances/UPred/Instance.lean +++ b/src/Iris/Instances/UPred/Instance.lean @@ -424,6 +424,9 @@ theorem ownM_op (m1 m2 : M) : ownM (m1 • m2) ⊣⊢ ownM m1 ∗ ownM m2 := by _ ≡{n}≡ (m1 • m2) • (w2 • w1) := CMRA.assoc.dist _ ≡{n}≡ (m1 • m2) • (w1 • w2) := CMRA.comm.op_r.dist +theorem ownM_eqv {m1 m2 : M} (H : m1 ≡ m2) : ownM m1 ⊣⊢ ownM m2 := + ⟨fun _ _ _ => (CMRA.incN_iff_left H.dist).mp, fun _ _ _ => (CMRA.incN_iff_left H.dist).mpr⟩ + theorem ownM_always_invalid_elim (m : M) (H : ∀ n, ¬✓{n} m) : (cmraValid m : UPred M) ⊢ False := fun n _ _ => H n @@ -469,6 +472,14 @@ theorem bupd_ownM_updateP (x : M) (Φ : M → Prop) : · exists y · exact ⟨HΦy, CMRA.incN_op_left k y x3⟩ +instance : Persistent (ownM (CMRA.core a) : UPred M) where + persistent := by + refine .trans (persistently_ownM_core _) ?_ + refine persistently_mono ?_ + refine (BI.equiv_iff.mp ?_).1 + refine OFE.NonExpansive.eqv ?_ + exact CMRA.core_idem a + -- TODO: later_ownM, ownM_forall (needs internal eq) theorem cmraValid_intro [CMRA A] {P : UPred M} (a : A) (Ha : ✓ a) : P ⊢ cmraValid a := diff --git a/src/Iris/ProofMode/Instances.lean b/src/Iris/ProofMode/Instances.lean index 5141513c..ae647653 100644 --- a/src/Iris/ProofMode/Instances.lean +++ b/src/Iris/ProofMode/Instances.lean @@ -70,7 +70,7 @@ instance intoWand_forall (p q : Bool) [BI PROP] (Φ : α → PROP) (P Q : PROP) instance intoWand_affinely (p q : Bool) [BI PROP] (R P Q : PROP) [h : IntoWand p q R P Q] : IntoWand p q iprop( R) iprop( P) iprop( Q) where into_wand := wand_intro <| - (sep_congr intuitionisticallyIf_affinely intuitionisticallyIf_affinely).1.trans <| + (sep_congr intuitionisticallyIf_affinely intuitionisticallyIf_affinely).mp.trans <| affinely_sep_2.trans <| affinely_mono <| wand_elim h.1 instance intoWand_intuitionistically (p q : Bool) [BI PROP] (R P Q : PROP) @@ -109,15 +109,15 @@ instance (priority := default + 10) fromExists_exists [BI PROP] (Φ : α → PRO instance fromExists_pure (φ : α → Prop) [BI PROP] : FromExists (PROP := PROP) iprop(⌜∃ x, φ x⌝) (fun a => iprop(⌜φ a⌝)) where - from_exists := pure_exists.1 + from_exists := pure_exists.mp instance fromExists_affinely [BI PROP] (P : PROP) (Φ : α → PROP) [h : FromExists P Φ] : FromExists iprop( P) (fun a => iprop( (Φ a))) where - from_exists := affinely_exists.2.trans <| affinely_mono h.1 + from_exists := affinely_exists.mpr.trans <| affinely_mono h.1 instance fromExists_intuitionistically [BI PROP] (P : PROP) (Φ : α → PROP) [h : FromExists P Φ] : FromExists iprop(□ P) (fun a => iprop(□ (Φ a))) where - from_exists := intuitionistically_exists.2.trans <| intuitionistically_mono h.1 + from_exists := intuitionistically_exists.mpr.trans <| intuitionistically_mono h.1 instance fromExists_absorbingly [BI PROP] (P : PROP) (Φ : α → PROP) [h : FromExists P Φ] : FromExists iprop( P) (fun a => iprop( (Φ a))) where diff --git a/src/Iris/ProofMode/Tactics/Basic.lean b/src/Iris/ProofMode/Tactics/Basic.lean index bccbff3a..7157d0f7 100644 --- a/src/Iris/ProofMode/Tactics/Basic.lean +++ b/src/Iris/ProofMode/Tactics/Basic.lean @@ -65,7 +65,7 @@ structure Goals {prop : Q(Type u)} (bi : Q(BI $prop)) where goals : IO.Ref (Array MVarId) def Goals.new {prop : Q(Type u)} (bi : Q(BI $prop)) : BaseIO (Goals bi) := - do return {goals := ← IO.mkRef #[]} + do return { goals := ← IO.mkRef #[] } def Goals.addGoal {prop : Q(Type u)} {bi : Q(BI $prop)} (g : Goals bi) {e} (hyps : Hyps bi e) (goal : Q($prop)) (name : Name := .anonymous) : MetaM Q($e ⊢ $goal) := do diff --git a/src/Iris/Std.lean b/src/Iris/Std.lean index b5a3083b..a327a54b 100644 --- a/src/Iris/Std.lean +++ b/src/Iris/Std.lean @@ -1,5 +1,6 @@ import Iris.Std.Classes import Iris.Std.Expr +import Iris.Std.FiniteMap import Iris.Std.Nat import Iris.Std.Prod import Iris.Std.Qq diff --git a/src/Iris/Std/BigOp.lean b/src/Iris/Std/BigOp.lean deleted file mode 100644 index d28518cf..00000000 --- a/src/Iris/Std/BigOp.lean +++ /dev/null @@ -1,40 +0,0 @@ -/- -Copyright (c) 2022 Lars König. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Lars König, Mario Carneiro --/ - -namespace Iris.Std - -/-- Fold a binary operator `f` over a list of `PROP`s. If the list is empty, `unit` is returned. -/ -def bigOp (f : PROP → PROP → PROP) (unit : PROP) : List PROP → PROP - | [] => unit - | [P] => P - | P :: Ps => f P (bigOp f unit Ps) - -class LawfulBigOp (f : PROP → PROP → PROP) (unit : outParam PROP) - (eq : outParam (PROP → PROP → Prop)) where - refl : eq a a - symm : eq a b → eq b a - trans : eq a b → eq b c → eq a c - comm : eq (f a b) (f b a) - assoc : eq (f (f a b) c) (f a (f b c)) - left_id : eq (f unit a) a - congr_l : eq a a' → eq (f a b) (f a' b) - -theorem LawfulBigOp.right_id [LawfulBigOp (PROP := PROP) f unit eq] : eq (f a unit) a := - trans f comm left_id - -theorem LawfulBigOp.congr_r [LawfulBigOp (PROP := PROP) f unit eq] - (h : eq b b') : eq (f a b) (f a b') := - trans f comm <| trans f (congr_l h) comm - -open LawfulBigOp - -theorem bigOp_nil {f : PROP → PROP → PROP} {unit : PROP} : bigOp f unit [] = unit := rfl - -theorem bigOp_cons {f : PROP → PROP → PROP} {unit : PROP} [LawfulBigOp f unit eq] : - eq (bigOp f unit (P :: Ps)) (f P (bigOp f unit Ps)) := - match Ps with - | [] => symm f right_id - | _ :: _ => refl f diff --git a/src/Iris/Std/FiniteMap.lean b/src/Iris/Std/FiniteMap.lean new file mode 100644 index 00000000..4ed384b5 --- /dev/null +++ b/src/Iris/Std/FiniteMap.lean @@ -0,0 +1,1190 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ + +/-! ## Abstract Finite Map Interface + +This file defines an abstract interface for finite maps, inspired by stdpp's `fin_maps`. + +### Notation + +* `m !! k` or `get? m k` - Lookup, returns `Option V` +* `insert m k v` - Insert/update a key-value pair +* `delete m k` - Remove a key (called `erase` internally) +* `∅` - Empty map +* `{[k := v]}` - Singleton map +* `m₁ ∪ m₂` - Union (left-biased) +* `m₁ ##ₘ m₂` - Disjoint domains +* `m₁ ⊆ m₂` - Submap relation +-/ + +namespace Iris.Std + +/-- Abstract finite map interface. +The type `M` represents a finite map from keys of type `K` to values of type `V`. + +This corresponds to Rocq's `FinMap` class from stdpp. -/ +class FiniteMap (M : Type u) (K : outParam (Type v)) (V : outParam (Type w)) where + /-- Lookup a key in the map, returning `none` if not present. + Corresponds to Rocq's `lookup` (notation `!!`). -/ + get? : M → K → Option V + /-- Insert or update a key-value pair. + Corresponds to Rocq's `insert` (notation `<[i:=x]>`). -/ + insert : M → K → V → M + /-- Remove a key from the map. + Corresponds to Rocq's `delete`. -/ + delete : M → K → M + /-- The empty map. -/ + empty : M + /-- Convert the map to a list of key-value pairs. + Corresponds to Rocq's `map_to_list`. -/ + toList : M → 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 + +export FiniteMap (get? insert delete toList ofList) + +namespace FiniteMap + +variable {M : Type u} {K : Type v} {V : Type w} [FiniteMap M K V] + +/-- Empty map instance for `∅` notation. -/ +instance : EmptyCollection M := ⟨empty⟩ + +/-- Singleton map containing exactly one key-value pair. + Corresponds to Rocq's `{[ i := x ]}` notation. -/ +def singleton (k : K) (v : V) : M := 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) : M := + (toList m₁).foldl (fun acc (k, v) => insert acc k v) m₂ + +instance : Union M := ⟨union⟩ + +/-- The domain of a map as a predicate on keys. -/ +def dom (m : M) : K → Prop := fun k => (get? m k).isSome + +/-- The domain of a map as a decidable predicate (requires decidable equality on Option V). -/ +def domDec (m : M) [DecidableEq V] : K → Bool := fun k => (get? m k).isSome + +/-- Two maps have disjoint domains. + Corresponds to Rocq's `map_disjoint` (notation `##ₘ`). -/ +def Disjoint (m₁ m₂ : M) : 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` (notation `⊆`). + + Rocq's `map_subseteq_spec` states: + `m1 ⊆ m2 ↔ ∀ i x, m1 !! i = Some x → m2 !! i = Some x` -/ +def Submap (m₁ m₂ : M) : Prop := ∀ k v, get? m₁ k = some v → get? m₂ k = some v + +instance : HasSubset M := ⟨Submap⟩ + +/-- Map a function over all values in the map. + Corresponds to Rocq's `fmap` (notation `f <$> m`). -/ +def map (f : V → V') [FiniteMap M' K V'] : M → M' := + 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 → M := + fun m => ofList ((toList m).filterMap (fun (k, v) => (f v).map (k, ·))) + +/-- Alias for `filterMap` to match Rocq's naming. -/ +abbrev omap := @filterMap + +/-- Filter entries by a predicate on key-value pairs. + Corresponds to Rocq's `filter`. -/ +def filter (φ : K → V → Bool) : M → M := + fun m => ofList ((toList m).filter (fun (k, v) => φ k v)) + +/-- Zip two maps: combine values at matching keys. + Corresponds to Rocq's `map_zip_with`. -/ +def zip [FiniteMap M' K V'] [FiniteMap M'' K (V × V')] (m₁ : M) (m₂ : M') : M'' := + ofList ((toList m₁).filterMap (fun (k, v) => + match get? m₂ k with + | some v' => some (k, (v, v')) + | none => none)) + +/-- Membership: a key is in the map if it has a value. -/ +def Mem (m : M) (k : K) : Prop := (get? m k).isSome + +/-- Difference: remove all keys in `m₂` from `m₁`. + `m₁ ∖ m₂` contains entries `(k, v)` where `k ∈ m₁` but `k ∉ m₂`. + Corresponds to Rocq's `map_difference` (notation `∖`). -/ +def difference (m₁ m₂ : M) : M := + ofList ((toList m₁).filter (fun (k, _) => (get? m₂ k).isNone)) + +instance : SDiff M := ⟨difference⟩ + +/-- Transform keys of a map using an injective function. + Given `f : K → K'`, `kmap f m` transforms a map with keys of type `K` + into a map with keys of type `K'`. + Corresponds to Rocq's `kmap`. -/ +def kmap {M' : Type u'} {K' : Type v'} [FiniteMap M' K' V] (f : K → K') (m : M) : M' := + ofList ((toList m).map (fun (k, v) => (f k, v))) + +/-- Convert a list to a map with sequential natural number keys starting from `start`. + `map_seq start [v₀, v₁, v₂, ...]` creates a map `{start ↦ v₀, start+1 ↦ v₁, start+2 ↦ v₂, ...}`. + Corresponds to Rocq's `map_seq`. -/ +def map_seq [FiniteMap M Nat V] (start : Nat) (l : List V) : M := + ofList (l.mapIdx (fun i v => (start + i, v))) + +end FiniteMap + +/-- Membership instance for finite maps: `k ∈ m` means the key `k` is in the map `m`. -/ +instance {M : Type u} {K : Type v} {V : Type w} [inst : FiniteMap M K V] : Membership K M := + ⟨fun (m : M) (k : K) => (inst.get? m k).isSome⟩ + +/-- Laws that a finite map implementation must satisfy. + Corresponds to Rocq's `FinMap` class axioms. -/ +class FiniteMapLaws (M : Type u) (K : Type v) (V : Type w) + [DecidableEq K] [FiniteMap M K V] where + /-- Map extensionality: two maps with the same lookups are equal. + Corresponds to Rocq's `map_eq`. -/ + map_eq : ∀ (m₁ m₂ : M), (∀ i, get? m₁ i = get? m₂ i) → m₁ = m₂ + /-- Looking up in an empty map returns `none`. + Corresponds to Rocq's `lookup_empty`. -/ + lookup_empty : ∀ k, get? (∅ : M) k = none + /-- Looking up the key just inserted returns that value. + Corresponds to Rocq's `lookup_insert_eq`. -/ + lookup_insert_eq : ∀ (m : M) k v, get? (insert m k v) k = some v + /-- Looking up a different key after insert returns the original value. + Corresponds to Rocq's `lookup_insert_ne`. -/ + lookup_insert_ne : ∀ (m : M) k k' v, k ≠ k' → get? (insert m k v) k' = get? m k' + /-- Deleting a key makes lookup return `none`. + Corresponds to Rocq's `lookup_delete_eq`. -/ + lookup_delete_eq : ∀ (m : M) k, get? (delete m k) k = none + /-- Deleting a different key doesn't affect lookup. + Corresponds to Rocq's `lookup_delete_ne`. -/ + lookup_delete_ne : ∀ (m : M) k k', k ≠ k' → get? (delete m k) k' = get? m k' + /-- `toList` and `ofList` are inverses (up to permutation and deduplication). + Corresponds to Rocq's `elem_of_list_to_map`. -/ + elem_of_list_to_map : ∀ (l : List (K × V)) k, + get? (ofList l : M) k = l.reverse.lookup k + /-- Empty map has empty toList. + Corresponds to Rocq's `map_to_list_empty`. -/ + map_to_list_empty : toList (∅ : M) = [] + /-- toList of insert (when key not present) is cons. + Corresponds to Rocq's `map_to_list_insert`. -/ + map_to_list_insert : ∀ (m : M) k v, get? m k = none → + (toList (insert m k v)).Perm ((k, v) :: toList m) + /-- toList lookup agrees with get?. + Corresponds to Rocq's `elem_of_map_to_list`. -/ + elem_of_map_to_list : ∀ (m : M) k v, get? m k = some v ↔ (k, v) ∈ toList m + /-- toList has no duplicate keys. + Corresponds to Rocq's `NoDup_map_to_list`. -/ + NoDup_map_to_list : ∀ (m : M), (toList m).map Prod.fst |>.Nodup + /-- toList of delete (when key is present) removes the key-value pair. + For `m !! k = some v`, `toList (delete m k)` is a permutation of `toList m` with `(k, v)` removed. + Corresponds to Rocq's `map_to_list_delete`. -/ + map_to_list_delete : ∀ (m : M) k v, get? m k = some v → + (toList m).Perm ((k, v) :: toList (delete m k)) + /-- `toList` and `ofList` roundtrip is a permutation (when keys are unique). + Corresponds to Rocq's `map_to_list_to_map`. -/ + map_to_list_to_map : ∀ (l : List (K × V)), (l.map Prod.fst).Nodup → + (toList (ofList l : M)).Perm l + /-- Lookup returns `none` iff the key is not in the domain. + Corresponds to Rocq's `not_elem_of_dom`. -/ + lookup_None_dom : ∀ (m : M) k, get? m k = none ↔ ¬FiniteMap.dom m k + /-- Lookup returns `some` iff the key is in the domain. + Corresponds to Rocq's `elem_of_dom`. -/ + lookup_Some_dom : ∀ (m : M) k, (∃ v, get? m k = some v) ↔ FiniteMap.dom m k + +/-- Extended laws for finite maps with value type transformations. -/ +class FiniteMapLawsExt (M : Type u) (M' : Type u') (K : Type v) (V : Type w) (V' : Type w') + [DecidableEq K] [FiniteMap M K V] [FiniteMap M' K V'] [FiniteMapLaws M K V] where + /-- toList of map (fmap) is related to mapping over toList. + `toList (map f m)` is a permutation of `(toList m).map (fun (k, v) => (k, f v))` -/ + toList_map : ∀ (m : M) (f : V → V'), + (toList (FiniteMap.map (M := M) (M' := M') f m)).Perm + ((toList m).map (fun kv => (kv.1, f kv.2))) + +/-- Self-referential extended laws (for filterMap, filter on the same type). -/ +class FiniteMapLawsSelf (M : Type u) (K : Type v) (V : Type w) + [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] where + /-- toList of filterMap (omap) is related to filterMap over toList. -/ + toList_filterMap : ∀ (m : M) (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) (φ : K → V → Bool), + (toList (FiniteMap.filter (M := M) φ m)).Perm + ((toList m).filter (fun kv => φ kv.1 kv.2)) + /-- toList of union for disjoint maps. -/ + toList_union_disjoint : ∀ (m₁ m₂ : M), + FiniteMap.Disjoint m₁ m₂ → + (toList (m₁ ∪ m₂)).Perm (toList m₁ ++ toList m₂) + /-- toList of difference is related to filter over toList. -/ + toList_difference : ∀ (m₁ m₂ : M), + (toList (m₁ \ m₂)).Perm + ((toList m₁).filter (fun kv => (get? m₂ kv.1).isNone)) + /-- Lookup in union: left-biased, m₁ takes precedence. + Corresponds to Rocq's `lookup_union`. -/ + lookup_union : ∀ (m₁ m₂ : M) k, + get? (m₁ ∪ m₂) k = (get? m₁ k).orElse (fun _ => get? m₂ k) + /-- Lookup in difference: key must be in m₁ but not in m₂. + Corresponds to Rocq's `lookup_difference`. -/ + lookup_difference : ∀ (m₁ m₂ : M) k, + get? (m₁ \ m₂) k = if (get? m₂ k).isSome then none else get? m₁ k + +/-- Laws for kmap operation (key transformation). -/ +class FiniteMapKmapLaws (M : Type u) (M' : Type u') (K : Type v) (K' : Type v') (V : Type w) + [DecidableEq K] [DecidableEq K'] [FiniteMap M K V] [FiniteMap M' K' V] + [FiniteMapLaws M K V] [FiniteMapLaws M' K' V] where + /-- toList of kmap is related to mapping over toList. + For an injective function `f : K → K'`, `toList (kmap f m)` is a permutation of + `(toList m).map (fun (k, v) => (f k, v))`. + Corresponds to Rocq's `map_to_list_kmap`. -/ + toList_kmap : ∀ (f : K → K') (m : M), + (∀ {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 (list to indexed map). -/ +class FiniteMapSeqLaws (M : Type u) (V : Type w) + [FiniteMap M Nat V] [FiniteMapLaws M Nat V] where + /-- toList of map_seq is related to zip with sequence. + `toList (map_seq start l)` is a permutation of `zip (seq start (length l)) l`. + Corresponds to Rocq's `map_to_list_seq`. -/ + toList_map_seq : ∀ (start : Nat) (l : List V), + (toList (FiniteMap.map_seq start l : M)).Perm + ((List.range' start l.length).zip l) + +/-! ### Map-Set Conversion Laws + +Note: Due to Lean 4's type class resolution limitations with dependent parameters, +the FiniteMapSetLaws class has been moved to a separate file or defined inline where needed. + +Key operations that connect FiniteMap and FiniteSet: +- `domSet m : S` - converts map domain to a finite set + Implementation: `FiniteSet.ofList ((toList m).map Prod.fst)` +- `ofSet c X : M` - creates map from set with all keys mapping to constant c + Implementation: `ofList ((FiniteSet.toList X).map (fun k => (k, c)))` + +These are defined directly in files that need them (e.g., BigSepMap.lean). +-/ + +export FiniteMapLaws (map_eq lookup_empty lookup_insert_eq lookup_insert_ne lookup_delete_eq lookup_delete_ne elem_of_list_to_map map_to_list_empty map_to_list_insert elem_of_map_to_list NoDup_map_to_list map_to_list_delete map_to_list_to_map) + +export FiniteMapLawsExt (toList_map) +export FiniteMapLawsSelf (toList_filterMap toList_filter toList_union_disjoint toList_difference lookup_union lookup_difference) +export FiniteMapKmapLaws (toList_kmap) +export FiniteMapSeqLaws (toList_map_seq) + +namespace FiniteMapLaws + +variable {M : Type u} {K : Type v} {V : Type w} +variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] + +/-- Alternative: lookup is insert then lookup for equal keys. + Corresponds to Rocq's `lookup_insert`. -/ +theorem lookup_insert (m : M) (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, lookup_insert_eq] + · next h => exact lookup_insert_ne m k k' v h + +/-- Alternative: lookup after delete. + Corresponds to Rocq's `lookup_delete`. -/ +theorem lookup_delete (m : M) (k k' : K) : + get? (delete m k) k' = if k = k' then none else get? m k' := by + split + · next h => rw [h, lookup_delete_eq] + · next h => exact lookup_delete_ne m k k' h + +/-- Insert after delete has the same lookup behavior as direct insert. + Corresponds to Rocq's `insert_delete_eq`. -/ +theorem lookup_insert_delete (m : M) (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, lookup_insert_eq] + · simp [lookup_insert_ne _ _ _ _ h, lookup_delete_ne _ _ _ h] + +/-- If a list of pairs has no duplicate keys, then it has no duplicate pairs. + This is because pairs with different keys are different, and there's at most one + pair per key. -/ +private 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 + +/-- For a Nodup list, erasing an element removes it completely. -/ +private 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. + This is the key lemma corresponding to Rocq's `NoDup_Permutation`. -/ +private 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 + +/-- Two maps with the same get? behavior have permutation-equivalent toLists. + Uses the fact that: + 1. `NoDup_map_to_list` ensures no duplicate keys (hence no duplicate pairs) + 2. `elem_of_map_to_list` + equal lookups implies same membership + 3. Two nodup lists with same membership are permutations -/ +theorem toList_perm_eq_of_get?_eq [DecidableEq V] {m₁ m₂ : M} + (h : ∀ k, get? m₁ k = get? m₂ k) : (toList m₁).Perm (toList m₂) := by + have hnodup₁ := nodup_of_nodup_map_fst _ (NoDup_map_to_list (M := M) (K := K) (V := V) m₁) + have hnodup₂ := nodup_of_nodup_map_fst _ (NoDup_map_to_list (M := M) (K := K) (V := V) m₂) + have hmem : ∀ kv, kv ∈ toList m₁ ↔ kv ∈ toList m₂ := by + intro kv + simp only [← elem_of_map_to_list (M := M) (K := K) (V := V), h] + exact 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_perm [DecidableEq V] (m : M) (k : K) (v : V) : + (toList (insert m k v)).Perm (toList (insert (delete m k) k v)) := + toList_perm_eq_of_get?_eq (fun k' => (lookup_insert_delete m k k' v).symm) + +/-- Singleton lookup for equal keys. + Corresponds to Rocq's `lookup_singleton_eq`. -/ +theorem lookup_singleton_eq (k : K) (v : V) : + get? (FiniteMap.singleton k v : M) k = some v := by + simp [FiniteMap.singleton, lookup_insert_eq] + +/-- Singleton lookup for different keys. + Corresponds to Rocq's `lookup_singleton_ne`. -/ +theorem lookup_singleton_ne (k k' : K) (v : V) (h : k ≠ k') : + get? (FiniteMap.singleton k v : M) k' = none := by + simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ h, lookup_empty] + +/-- Singleton lookup general case. + Corresponds to Rocq's `lookup_singleton`. -/ +theorem lookup_singleton (k k' : K) (v : V) : + get? (FiniteMap.singleton k v : M) k' = if k = k' then some v else none := by + split + · next h => rw [h, lookup_singleton_eq] + · next h => exact lookup_singleton_ne k k' v h + +/-- Insert is idempotent for the same key-value. + Corresponds to Rocq's `insert_insert_eq`. -/ +theorem insert_insert_eq (m : M) (k : K) (v v' : V) : + get? (insert (insert m k v) k v') = get? (insert m k v' : M) := by + funext k' + by_cases h : k = k' + · simp [h, lookup_insert_eq] + · simp [lookup_insert_ne _ _ _ _ h] + +/-- Deleting from empty is empty. + Corresponds to Rocq's `delete_empty`. -/ +theorem delete_empty (k : K) : + get? (delete (∅ : M) k) = get? (∅ : M) := by + funext k' + by_cases h : k = k' + · simp [h, lookup_delete_eq, lookup_empty] + · simp [lookup_delete_ne _ _ _ h, lookup_empty] + +/-- The domain of an empty map is empty. -/ +theorem dom_empty : FiniteMap.dom (∅ : M) = fun _ => False := by + funext k + simp [FiniteMap.dom, lookup_empty] + +/-- The domain after insert includes the inserted key. -/ +theorem dom_insert (m : M) (k : K) (v : V) : + FiniteMap.dom (insert m k v) k := by + simp [FiniteMap.dom, lookup_insert_eq] + +/-- Key is not in domain iff lookup returns none. + Corresponds to Rocq's `not_elem_of_dom`. -/ +theorem not_elem_of_dom (m : M) (k : K) : + ¬FiniteMap.dom m k ↔ get? m k = none := by + simp only [FiniteMap.dom, Option.not_isSome] + apply (lookup_None_dom m k).symm + +/-- Empty is a submap of everything. + Corresponds to Rocq's `map_empty_subseteq`. -/ +theorem map_empty_subseteq (m : M) : (∅ : M) ⊆ m := by + intro k v h + simp [lookup_empty] at h + +/-- Empty is disjoint from everything. + Corresponds to Rocq's `map_disjoint_empty_l`. -/ +theorem map_disjoint_empty_l (m : M) : FiniteMap.Disjoint (∅ : M) m := by + intro k ⟨h₁, _⟩ + simp [lookup_empty] at h₁ + +/-- Characterization of lookup after insert returning Some. + Corresponds to Rocq's `lookup_insert_Some`. -/ +theorem lookup_insert_Some (m : M) (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 [lookup_insert] + split <;> simp_all + +/-- Characterization of lookup after insert being Some. + Corresponds to Rocq's `lookup_insert_is_Some`. -/ +theorem lookup_insert_is_Some (m : M) (i j : K) (x : V) : + (get? (insert m i x) j).isSome ↔ i = j ∨ (i ≠ j ∧ (get? m j).isSome) := by + rw [lookup_insert] + split <;> simp_all + +/-- Characterization of lookup after insert returning None. + Corresponds to Rocq's `lookup_insert_None`. -/ +theorem lookup_insert_None (m : M) (i j : K) (x : V) : + get? (insert m i x) j = none ↔ get? m j = none ∧ i ≠ j := by + rw [lookup_insert] + split <;> simp_all + +/-- If insert returns Some, we can extract the value. + Corresponds to Rocq's `lookup_insert_rev`. -/ +theorem lookup_insert_rev (m : M) (i : K) (x y : V) : + get? (insert m i x) i = some y → x = y := by + simp [lookup_insert_eq] + +/-- Insert is idempotent when the key already has that value. + Corresponds to Rocq's `insert_id`. -/ +theorem insert_id (m : M) (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 [lookup_insert_eq, h] + · simp [lookup_insert_ne _ _ _ _ hk] + +/-- Characterization of lookup after delete returning Some. + Corresponds to Rocq's `lookup_delete_Some`. -/ +theorem lookup_delete_Some (m : M) (i j : K) (y : V) : + get? (delete m i) j = some y ↔ i ≠ j ∧ get? m j = some y := by + rw [lookup_delete] + split <;> simp_all + +/-- Characterization of lookup after delete being Some. + Corresponds to Rocq's `lookup_delete_is_Some`. -/ +theorem lookup_delete_is_Some (m : M) (i j : K) : + (get? (delete m i) j).isSome ↔ i ≠ j ∧ (get? m j).isSome := by + rw [lookup_delete] + split <;> simp_all + +/-- Characterization of lookup after delete returning None. + Corresponds to Rocq's `lookup_delete_None`. -/ +theorem lookup_delete_None (m : M) (i j : K) : + get? (delete m i) j = none ↔ i = j ∨ get? m j = none := by + rw [lookup_delete] + split <;> simp_all + +-- ============================================================================ +-- Induction Principles +-- ============================================================================ + +/-- Insert then delete is identity when key wasn't present. + Corresponds to Rocq's `insert_delete_id`. -/ +theorem insert_delete_id (m : M) (i : K) (x : V) : + get? m i = some x → insert (delete m i) i x = m := by + intro h + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_insert_eq, h] + · simp [lookup_insert_ne _ _ _ _ hij, lookup_delete_ne _ _ _ hij] + +/-- Delete then insert is identity. + Corresponds to Rocq's `delete_insert_id`. -/ +theorem delete_insert_id (m : M) (i : K) (x : V) : + get? m i = none → delete (insert m i x) i = m := by + intro h + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_delete_eq, h] + · simp [lookup_delete_ne _ _ _ hij, lookup_insert_ne _ _ _ _ hij] + +/-- Empty map is characterized by all lookups returning none. -/ +theorem eq_empty_iff (m : M) : m = ∅ ↔ ∀ k, get? m k = none := by + constructor + · intro h k + rw [h, lookup_empty] + · intro h + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro k + rw [h, lookup_empty] + +/-- Well-founded induction on maps using the strict submap relation. + This is the most basic induction principle. + Corresponds to Rocq's `map_ind`. -/ +theorem map_ind {P : M → Prop} + (hemp : P ∅) + (hins : ∀ i x m, get? m i = none → P m → P (insert m i x)) + (m : M) : P m := by + -- We use well-founded induction on the length of toList + generalize hn : (toList m).length = n + induction n using Nat.strongRecOn generalizing m with + | ind n ih => + cases hn' : toList m with + | nil => + -- If toList is empty, the map must behave like empty + have h : ∀ k, get? m k = none := by + intro k + cases hget : get? m k with + | none => rfl + | some v => + have hmem := (elem_of_map_to_list m k v).mp hget + rw [hn'] at hmem + simp at hmem + -- By extensionality, m = ∅ + have heq : m = ∅ := eq_empty_iff m |>.mpr h + rw [heq] + exact hemp + | cons kv kvs => + -- m has at least one entry + obtain ⟨k, v⟩ := kv + -- delete k from m gives a smaller map + have hdel : get? m k = some v := by + have hmem : (k, v) ∈ (k, v) :: kvs := List.Mem.head _ + have hmem' : (k, v) ∈ toList m := hn' ▸ hmem + exact (elem_of_map_to_list m k v).mpr hmem' + -- toList (delete m k) has one fewer element + have hperm := map_to_list_delete m k v hdel + -- The deleted map has strictly smaller toList (by one element) + have hlen : (toList (delete m k)).length < n := by + have hperm_len := hperm.length_eq + simp only [List.length_cons] at hperm_len + omega + -- Apply IH to get P (delete m k) + have ih_del := ih (toList (delete m k)).length hlen (delete m k) rfl + -- Since get? (delete m k) k = none, we can apply hins + have hdel_none : get? (delete m k) k = none := lookup_delete_eq m k + -- We get P (insert (delete m k) k v) + have result := hins k v (delete m k) hdel_none ih_del + -- By extensionality, insert (delete m k) k v = m + have heq := insert_delete_id m k v hdel + rw [← heq] + exact result + +-- ============================================================================ +-- Insert and Delete Composition Lemmas +-- ============================================================================ + +/-- Delete is idempotent. + Corresponds to Rocq's `delete_delete_eq`. -/ +theorem delete_delete_eq (m : M) (i : K) : + delete (delete m i) i = delete m i := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_delete_eq] + · simp [lookup_delete_ne _ _ _ hij] + +/-- Delete of different keys commutes. + Corresponds to Rocq's `delete_delete`. -/ +theorem delete_delete (m : M) (i j : K) : + delete (delete m i) j = delete (delete m j) i := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro k + by_cases hik : i = k <;> by_cases hjk : j = k <;> simp [lookup_delete, *] + +/-- Insert then delete of different keys commutes. + Corresponds to Rocq's `delete_insert_ne`. -/ +theorem delete_insert_ne (m : M) (i j : K) (x : V) : + i ≠ j → delete (insert m i x) j = insert (delete m j) i x := by + intro hij + apply FiniteMapLaws.map_eq (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 [lookup_insert, lookup_delete, hjk] + · subst hjk; simp [lookup_insert, lookup_delete, hik] + · simp [lookup_insert, lookup_delete, hik, hjk] + +/-- Delete then insert of same key gives just insert. + Corresponds to Rocq's `insert_delete_eq`. -/ +theorem insert_delete_eq (m : M) (i : K) (x : V) : + insert (delete m i) i x = insert m i x := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_insert_eq] + · simp [lookup_insert_ne _ _ _ _ hij, lookup_delete_ne _ _ _ hij] + +/-- Insert of different keys commutes. + Corresponds to Rocq's `insert_insert`. -/ +theorem insert_insert (m : M) (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.map_eq (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 [lookup_insert, hjk] + · subst hjk; simp [lookup_insert, hik] + · simp [lookup_insert, hik, hjk] + +/-- Insert of same key keeps later value. + Corresponds to Rocq's `insert_insert_eq`. -/ +theorem insert_insert_eq' (m : M) (i : K) (x y : V) : + insert (insert m i x) i y = insert m i y := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_insert_eq] + · simp [lookup_insert_ne _ _ _ _ hij] + +/-- Deleting from empty is empty. + Corresponds to Rocq's `delete_empty`. -/ +theorem delete_empty' (i : K) : + delete (∅ : M) i = ∅ := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + simp [lookup_delete, lookup_empty] + +/-- Delete is identity when key not present. + Corresponds to Rocq's `delete_id`. -/ +theorem delete_id (m : M) (i : K) : + get? m i = none → delete m i = m := by + intro h + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_delete_eq, h] + · simp [lookup_delete_ne _ _ _ hij] + +/-- Insert is identity when key already has that value. + Corresponds to Rocq's `insert_id`. -/ +theorem insert_id' (m : M) (i : K) (x : V) : + get? m i = some x → insert m i x = m := by + intro h + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + by_cases hij : i = j + · subst hij + simp [lookup_insert_eq, h] + · simp [lookup_insert_ne _ _ _ _ hij] + +/-- Insert on empty gives singleton. + Corresponds to Rocq's `insert_empty`. -/ +theorem insert_empty [DecidableEq K] (i : K) (x : V) : + insert (∅ : M) i x = FiniteMap.singleton i x := by + rfl + +/-- Inserted map is non-empty. + Corresponds to Rocq's `insert_non_empty`. -/ +theorem insert_non_empty (m : M) (i : K) (x : V) : + insert m i x ≠ ∅ := by + intro h + have := eq_empty_iff (insert m i x) |>.mp h i + simp [lookup_insert_eq] at this + +-- ============================================================================ +-- Submap Lemmas +-- ============================================================================ + +/-- Delete preserves submap. + Corresponds to Rocq's `delete_subseteq`. -/ +theorem delete_subseteq (m : M) (i : K) : delete m i ⊆ m := by + intro k v h + by_cases hik : i = k + · subst hik + simp [lookup_delete_eq] at h + · simp [lookup_delete_ne _ _ _ hik] at h + exact h + +/-- Delete of present key is strict submap (submap but not equal). + Corresponds to Rocq's `delete_subset`. -/ +theorem delete_subset (m : M) (i : K) (v : V) : + get? m i = some v → delete m i ⊆ m ∧ delete m i ≠ m := by + intro hi + constructor + · exact delete_subseteq m i + · intro heq + have : get? (delete m i) i = get? m i := by rw [heq] + simp [lookup_delete_eq, hi] at this + +/-- Insert on non-present key gives superset. + Corresponds to Rocq's `insert_subseteq`. -/ +theorem insert_subseteq (m : M) (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 [lookup_insert_ne _ _ _ _ hik, hk] + +/-- Insert on non-present key gives strict superset (superset but not equal). + Corresponds to Rocq's `insert_subset`. -/ +theorem insert_subset (m : M) (i : K) (x : V) : + get? m i = none → m ⊆ insert m i x ∧ m ≠ insert m i x := by + intro hi + constructor + · exact insert_subseteq m i x hi + · intro heq + have h2 : get? (insert m i x) i = some x := lookup_insert_eq m i x + rw [← heq] at h2 + rw [hi] at h2 + exact Option.noConfusion h2 + +/-- Delete is monotone with respect to submap. + Corresponds to Rocq's `delete_mono`. -/ +theorem delete_mono (m₁ m₂ : M) (i : K) : + m₁ ⊆ m₂ → delete m₁ i ⊆ delete m₂ i := by + intro hsub k v hk + by_cases hik : i = k + · subst hik + simp [lookup_delete_eq] at hk + · simp [lookup_delete_ne _ _ _ hik] at hk ⊢ + exact hsub k v hk + +/-- Insert is monotone with respect to submap. + Corresponds to Rocq's `insert_mono`. -/ +theorem insert_mono (m₁ m₂ : M) (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 [lookup_insert_eq] at hk ⊢ + exact hk + · simp [lookup_insert_ne _ _ _ _ hik] at hk ⊢ + exact hsub k v hk + +-- ============================================================================ +-- Singleton Lemmas +-- ============================================================================ + +/-- Singleton is non-empty. + Corresponds to Rocq's `map_non_empty_singleton`. -/ +theorem singleton_non_empty (i : K) (x : V) : + FiniteMap.singleton i x ≠ (∅ : M) := by + exact insert_non_empty ∅ i x + +/-- Delete from singleton of same key is empty. + Corresponds to Rocq's `delete_singleton_eq`. -/ +theorem delete_singleton_eq (i : K) (x : V) : + delete (FiniteMap.singleton i x : M) i = ∅ := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro j + simp [FiniteMap.singleton, lookup_delete, lookup_insert, lookup_empty] + +/-- Delete from singleton of different key is identity. + Corresponds to Rocq's `delete_singleton_ne`. -/ +theorem delete_singleton_ne (i j : K) (x : V) : + i ≠ j → delete (FiniteMap.singleton j x : M) i = FiniteMap.singleton j x := by + intro hij + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro k + simp [FiniteMap.singleton, lookup_delete, lookup_insert, lookup_empty] + intro hik + intro hjk + subst hik hjk + exact hij rfl + +-- ============================================================================ +-- map_Forall Predicate +-- ============================================================================ + +/-- A predicate holds for all key-value pairs in the map. + Corresponds to Rocq's `map_Forall`. -/ +def map_Forall (P : K → V → Prop) (m : M) : Prop := + ∀ k v, get? m k = some v → P k v + +/-- map_Forall is equivalent to checking toList. + Corresponds to Rocq's `map_Forall_to_list`. -/ +theorem map_Forall_to_list (P : K → V → Prop) (m : M) : + map_Forall P m ↔ ∀ kv ∈ toList m, P kv.1 kv.2 := by + constructor + · intro hfa kv hmem + have := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + exact hfa kv.1 kv.2 this + · intro hlist k v hget + have := (elem_of_map_to_list m k v).mp hget + exact hlist (k, v) this + +/-- map_Forall holds vacuously on empty map. + Corresponds to Rocq's `map_Forall_empty`. -/ +theorem map_Forall_empty (P : K → V → Prop) : map_Forall P (∅ : M) := by + intro k v h + simp [lookup_empty] at h + +/-- map_Forall is preserved by implication. + Corresponds to Rocq's `map_Forall_impl`. -/ +theorem map_Forall_impl (P Q : K → V → Prop) (m : M) : + map_Forall P m → (∀ k v, P k v → Q k v) → map_Forall Q m := by + intro hp himpl k v hget + exact himpl k v (hp k v hget) + +/-- map_Forall on insert implies P holds for the inserted value. + Corresponds to Rocq's `map_Forall_insert_1_1`. -/ +theorem map_Forall_insert_1_1 (P : K → V → Prop) (m : M) (i : K) (x : V) : + map_Forall P (insert m i x) → P i x := by + intro hfa + exact hfa i x (lookup_insert_eq m i x) + +/-- map_Forall on insert implies map_Forall on original (when key not present). + Corresponds to Rocq's `map_Forall_insert_1_2`. -/ +theorem map_Forall_insert_1_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : + get? m i = none → map_Forall P (insert m i x) → map_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 [lookup_insert_ne _ _ _ _ hik, hget] + exact hfa k v this + +/-- map_Forall is preserved by insert when P holds. + Corresponds to Rocq's `map_Forall_insert_2`. -/ +theorem map_Forall_insert_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : + P i x → map_Forall P m → map_Forall P (insert m i x) := by + intro hpix hfa k v hget + by_cases hik : i = k + · subst hik + simp [lookup_insert_eq] at hget + rw [← hget] + exact hpix + · simp [lookup_insert_ne _ _ _ _ hik] at hget + exact hfa k v hget + +/-- map_Forall characterization for insert when key not present. + Corresponds to Rocq's `map_Forall_insert`. -/ +theorem map_Forall_insert (P : K → V → Prop) (m : M) (i : K) (x : V) : + get? m i = none → (map_Forall P (insert m i x) ↔ P i x ∧ map_Forall P m) := by + intro hi + constructor + · intro hfa + exact ⟨map_Forall_insert_1_1 P m i x hfa, map_Forall_insert_1_2 P m i x hi hfa⟩ + · intro ⟨hpix, hfa⟩ + exact map_Forall_insert_2 P m i x hpix hfa + +/-- map_Forall on singleton. + Corresponds to Rocq's `map_Forall_singleton`. -/ +theorem map_Forall_singleton (P : K → V → Prop) (i : K) (x : V) : + map_Forall P (FiniteMap.singleton i x : M) ↔ P i x := by + constructor + · intro hfa + exact hfa i x (lookup_singleton_eq i x) + · intro hpix k v hget + simp [lookup_singleton] at hget + obtain ⟨rfl, rfl⟩ := hget + exact hpix + +/-- map_Forall is preserved by delete. + Corresponds to Rocq's `map_Forall_delete`. -/ +theorem map_Forall_delete (P : K → V → Prop) (m : M) (i : K) : + map_Forall P m → map_Forall P (delete m i) := by + intro hfa k v hget + by_cases hik : i = k + · subst hik + simp [lookup_delete_eq] at hget + · simp [lookup_delete_ne _ _ _ hik] at hget + exact hfa k v hget + +-- ============================================================================ +-- Disjoint Lemmas +-- ============================================================================ + +/-- Characterization of disjoint maps. + Corresponds to Rocq's `map_disjoint_spec`. -/ +theorem map_disjoint_spec (m₁ m₂ : M) : + FiniteMap.Disjoint 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 + +/-- Insert preserves disjointness when key not in the other map. + Corresponds to Rocq's `map_disjoint_insert_l`. -/ +theorem map_disjoint_insert_l (m₁ m₂ : M) (i : K) (x : V) : + get? m₂ i = none → + FiniteMap.Disjoint m₁ m₂ → + FiniteMap.Disjoint (insert m₁ i x) m₂ := by + intro hi hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs2 + · simp [lookup_insert_ne _ _ _ _ hik] at hs1 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Insert preserves disjointness (right version). + Corresponds to Rocq's `map_disjoint_insert_r`. -/ +theorem map_disjoint_insert_r (m₁ m₂ : M) (i : K) (x : V) : + get? m₁ i = none → + FiniteMap.Disjoint m₁ m₂ → + FiniteMap.Disjoint m₁ (insert m₂ i x) := by + intro hi hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs1 + · simp [lookup_insert_ne _ _ _ _ hik] at hs2 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Delete preserves disjointness. + Corresponds to Rocq's `map_disjoint_delete_l`. -/ +theorem map_disjoint_delete_l (m₁ m₂ : M) (i : K) : + FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint (delete m₁ i) m₂ := by + intro hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [lookup_delete_eq] at hs1 + · simp [lookup_delete_ne _ _ _ hik] at hs1 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Delete preserves disjointness (right version). + Corresponds to Rocq's `map_disjoint_delete_r`. -/ +theorem map_disjoint_delete_r (m₁ m₂ : M) (i : K) : + FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint m₁ (delete m₂ i) := by + intro hdisj k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [lookup_delete_eq] at hs2 + · simp [lookup_delete_ne _ _ _ hik] at hs2 + exact hdisj k ⟨hs1, hs2⟩ + +/-- Singleton is disjoint from map when key not present. + Corresponds to Rocq's `map_disjoint_singleton_l`. -/ +theorem map_disjoint_singleton_l (m : M) (i : K) (x : V) : + get? m i = none → FiniteMap.Disjoint (FiniteMap.singleton i x) m := by + intro hi k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs2 + · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs1 + +/-- Singleton is disjoint from map when key not present (right version). + Corresponds to Rocq's `map_disjoint_singleton_r`. -/ +theorem map_disjoint_singleton_r (m : M) (i : K) (x : V) : + get? m i = none → FiniteMap.Disjoint m (FiniteMap.singleton i x) := by + intro hi k ⟨hs1, hs2⟩ + by_cases hik : i = k + · subst hik + simp [hi] at hs1 + · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs2 + +end FiniteMapLaws + +namespace FiniteMap + +variable {M : Type u} {K : Type v} {V : Type w} [FiniteMap M K V] + +/-- Submap is reflexive. -/ +theorem submap_refl (m : M) : m ⊆ m := fun _ _ h => h + +/-- Submap is transitive. -/ +theorem submap_trans {m₁ m₂ m₃ : M} (h₁ : m₁ ⊆ m₂) (h₂ : m₂ ⊆ m₃) : m₁ ⊆ m₃ := + fun k v hm₁ => h₂ k v (h₁ k v hm₁) + +/-- Disjointness is symmetric. -/ +theorem disjoint_symm {m₁ m₂ : M} (h : Disjoint m₁ m₂) : Disjoint m₂ m₁ := + fun k ⟨h₂, h₁⟩ => h k ⟨h₁, h₂⟩ + +theorem map_disjoint_empty_r [DecidableEq K] [FiniteMapLaws M K V] (m : M) : Disjoint m (∅ : M) := + disjoint_symm (FiniteMapLaws.map_disjoint_empty_l m) + +/-- `m₂` and `m₁ \ m₂` are disjoint. + This is unconditional - the difference by definition removes all keys in m₂. -/ +theorem disjoint_difference_r [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] + (m₁ m₂ : M) : Disjoint m₂ (m₁ \ m₂) := by + intro k ⟨h_in_m2, h_in_diff⟩ + -- h_in_m2: (get? m₂ k).isSome + -- h_in_diff: (get? (m₁ \ m₂) k).isSome + -- By lookup_difference, (m₁ \ m₂) !! k = if m₂ !! k is Some then none else m₁ !! k + -- So if m₂ !! k is Some, then (m₁ \ m₂) !! k = none, contradiction with h_in_diff + rw [lookup_difference] at h_in_diff + simp only [h_in_m2, ↓reduceIte, Option.isSome_none, Bool.false_eq_true] at h_in_diff + +/-- toList of difference union: `toList (m₂ ∪ (m₁ \ m₂))` is a permutation of `toList m₁` + when `m₂ ⊆ m₁`. This is the key lemma for `big_sepM_subseteq`. -/ +theorem toList_difference_union [DecidableEq K] [DecidableEq V] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] + (m₁ m₂ : M) (hsub : m₂ ⊆ m₁) : + (toList (m₂ ∪ (m₁ \ m₂))).Perm (toList m₁) := by + -- m₂ and m₁ \ m₂ are disjoint + have hdisj : Disjoint m₂ (m₁ \ m₂) := disjoint_difference_r m₁ m₂ + -- toList (m₂ ∪ (m₁ \ m₂)) ~ toList m₂ ++ toList (m₁ \ m₂) + have hunion := toList_union_disjoint m₂ (m₁ \ m₂) hdisj + -- toList (m₁ \ m₂) ~ filter (toList m₁) + have hdiff := toList_difference (M := M) (K := K) (V := V) m₁ m₂ + -- Need to show: toList m₂ ++ filter (toList m₁) ~ toList m₁ + -- Since m₂ ⊆ m₁, every entry in m₂ is also in m₁ + -- And filter removes exactly the entries in m₂ + -- So together they form all of m₁ + refine hunion.trans ?_ + -- Need: toList m₂ ++ toList (m₁ \ m₂) ~ toList m₁ + refine List.Perm.trans (List.Perm.append_left (toList m₂) hdiff) ?_ + -- Need: toList m₂ ++ filter (not in m₂) (toList m₁) ~ toList m₁ + -- Strategy: show toList m₂ ~ filter (in m₂) (toList m₁), then use filter_append_perm + + -- Helper: filter preserves Nodup + have nodup_filter : ∀ {α : Type _} (p : α → Bool) (l : List α), l.Nodup → (l.filter p).Nodup := by + intro α p l h + induction l with + | nil => exact List.nodup_nil + | cons x xs ih => + rw [List.nodup_cons] at h + simp only [List.filter_cons] + split + · rw [List.nodup_cons] + constructor + · intro hx + have := List.mem_filter.mp hx + exact h.1 this.1 + · exact ih h.2 + · exact ih h.2 + + -- Define the predicate for "key is in m₂" + let p : K × V → Bool := fun kv => (get? m₂ kv.1).isSome + + -- Step 1: toList m₂ ~ filter p (toList m₁) + -- Both are nodup and have the same membership + have hperm_m2_filter : (toList m₂).Perm ((toList m₁).filter p) := by + -- Use perm_of_nodup_of_mem_iff + have hnd₁ : (toList m₂).Nodup := + FiniteMapLaws.nodup_of_nodup_map_fst _ (NoDup_map_to_list m₂) + have hnd₂ : ((toList m₁).filter p).Nodup := + nodup_filter p _ (FiniteMapLaws.nodup_of_nodup_map_fst _ (NoDup_map_to_list m₁)) + apply FiniteMapLaws.perm_of_nodup_of_mem_iff hnd₁ hnd₂ + intro ⟨k, v⟩ + simp only [List.mem_filter, p] + constructor + · -- (k, v) ∈ toList m₂ → (k, v) ∈ toList m₁ ∧ (get? m₂ k).isSome + intro hmem + have hget : get? m₂ k = some v := (elem_of_map_to_list m₂ k v).mpr hmem + constructor + · -- (k, v) ∈ toList m₁ + have hget₁ : get? m₁ k = some v := hsub k v hget + exact (elem_of_map_to_list m₁ k v).mp hget₁ + · -- (get? m₂ k).isSome + simp [hget] + · -- (k, v) ∈ toList m₁ ∧ (get? m₂ k).isSome → (k, v) ∈ toList m₂ + intro ⟨hmem₁, hisSome⟩ + have hget₁ : get? m₁ k = some v := (elem_of_map_to_list m₁ k v).mpr hmem₁ + obtain ⟨v', hget₂⟩ := Option.isSome_iff_exists.mp hisSome + -- Since m₂ ⊆ m₁ and both have the same key, the values must match + -- We need: v = v' + have hget₁' : get? m₁ k = some v' := hsub k v' hget₂ + have : v = v' := Option.some.inj (hget₁.symm.trans hget₁') + rw [this] + exact (elem_of_map_to_list m₂ k v').mp hget₂ + + -- Step 2: filter (not p) = filter (isNone ∘ get? m₂ ∘ fst) + have hfilter_eq : (toList m₁).filter (fun x => !p x) = + (toList m₁).filter (fun kv => (get? m₂ kv.fst).isNone) := by + congr 1 + funext kv + simp only [p, Option.not_isSome] + + -- Step 3: Combine using filter_append_perm + have hstep1 : (toList m₂ ++ (toList m₁).filter (fun kv => (get? m₂ kv.fst).isNone)) = + (toList m₂ ++ (toList m₁).filter (fun x => !p x)) := by rw [hfilter_eq] + have hstep2 : (toList m₂ ++ (toList m₁).filter (fun x => !p x)).Perm + ((toList m₁).filter p ++ (toList m₁).filter (fun x => !p x)) := + List.Perm.append hperm_m2_filter (List.Perm.refl _) + have hstep3 : ((toList m₁).filter p ++ (toList m₁).filter (fun x => !p x)).Perm (toList m₁) := + List.filter_append_perm p (toList m₁) + exact (List.Perm.of_eq hstep1).trans (hstep2.trans hstep3) + +/-- Key identity: `m₂ ∪ (m₁ \ m₂) = m₁` when `m₂ ⊆ m₁`. + Corresponds to Rocq's `map_difference_union`. + + This is proved via `map_eq` using `lookup_union` and `lookup_difference`, + without requiring `DecidableEq V`. -/ +theorem map_difference_union [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] + (m₁ m₂ : M) (hsub : m₂ ⊆ m₁) : m₂ ∪ (m₁ \ m₂) = m₁ := by + apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) + intro k + rw [lookup_union, lookup_difference] + -- Case split on whether k is in m₂ + cases hm2 : get? m₂ k with + | none => + -- If k ∉ m₂, then (m₁ \ m₂) !! k = m₁ !! k + simp only [Option.isSome_none, Bool.false_eq_true, ↓reduceIte, Option.orElse_none] + | some v => + -- If k ∈ m₂ with value v, then m₂ !! k = some v + -- and since m₂ ⊆ m₁, we have m₁ !! k = some v + simp only [Option.isSome_some, ↓reduceIte, Option.orElse_some] + exact (hsub k v hm2).symm + +end FiniteMap + +-- ============================================================================ +-- Notations +-- ============================================================================ + +section Notation + +/-- Notation for map disjointness: `m₁ ##ₘ m₂` -/ +scoped infix:50 " ##ₘ " => FiniteMap.Disjoint + +/-- Notation for singleton map: `{[k := v]}` -/ +scoped syntax "{[" term " := " term "]}" : term + +scoped macro_rules + | `({[$k := $v]}) => `(FiniteMap.singleton $k $v) + +end Notation + +end Iris.Std diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean new file mode 100644 index 00000000..38a3cc79 --- /dev/null +++ b/src/Iris/Std/FiniteMapDom.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.Std.FiniteMap +import Iris.Std.FiniteSet +import Iris.Std.List + +/-! +# Finite Map Domain Operations + +This file defines operations for converting between finite maps and finite sets, +particularly for representing the domain of a map as a set. +-/ + +namespace Iris.Std + +open FiniteMap FiniteSet + +variable {M : Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] + +section DomainSet + +variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] +variable [FiniteMapLawsSelf M K V] + +/-- Convert map domain to a finite set. -/ +def domSet (m : M) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) + +/-- Create map from set with constant value. -/ +def ofSet (c : V) (X : S) : M := FiniteMap.ofList ((FiniteSet.toList X).map (fun k => (k, c))) + +/-- Domain of empty map is empty set. -/ +theorem domSet_empty : domSet (∅ : M) = (∅ : S) := by + simp only [domSet, FiniteMapLaws.map_to_list_empty, List.map_nil, FiniteSetLaws.ofList_nil] + +/-- Membership in domSet iff key has a value in the map. -/ +theorem elem_of_domSet (m : M) (k : K) : + FiniteSet.mem k (domSet (m : M) : S) = true ↔ ∃ v, FiniteMap.get? m k = some v := by + simp only [domSet, FiniteSetLaws.mem_ofList, List.mem_map] + constructor + · intro ⟨p, hp, hk⟩ + have : (p.fst, p.snd) ∈ FiniteMap.toList m := hp + have : FiniteMap.get? m p.fst = some p.snd := FiniteMapLaws.elem_of_map_to_list m p.fst p.snd |>.mpr this + rw [hk] at this + exact ⟨p.snd, this⟩ + · intro ⟨v, hv⟩ + refine ⟨(k, v), FiniteMapLaws.elem_of_map_to_list m k v |>.mp hv, rfl⟩ + +/-- Domain of insert includes the inserted key. -/ +theorem domSet_insert (m : M) (k : K) (v : V) : + (domSet (FiniteMap.insert m k v) : S) = FiniteSet.insert k (domSet m : S) := by + apply @FiniteSetLaws.ext S K _ _ + intro x + by_cases h : x = k + · -- Case: x = k + subst h + rw [FiniteSetLaws.mem_insert_eq (domSet m) x x rfl] + have : FiniteSet.mem x (domSet (FiniteMap.insert m x v) : S) = true := + elem_of_domSet (FiniteMap.insert m x v) x |>.mpr ⟨v, FiniteMapLaws.lookup_insert_eq m x v⟩ + exact this + · -- Case: x ≠ k + rw [FiniteSetLaws.mem_insert_ne (domSet m) x k h] + cases hmem : FiniteSet.mem x (domSet m : S) + · -- mem x (domSet m) = false, need to show mem x (domSet (insert m k v)) = false + have : ¬∃ v', FiniteMap.get? m x = some v' := by + intro ⟨v', hv'⟩ + have : FiniteSet.mem x (domSet m : S) = true := elem_of_domSet m x |>.mpr ⟨v', hv'⟩ + rw [hmem] at this + cases this + cases hins : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) + · rfl + · -- Contradiction + have ⟨v', hv'⟩ := elem_of_domSet (FiniteMap.insert m k v) x |>.mp hins + have heq : FiniteMap.get? (FiniteMap.insert m k v) x = FiniteMap.get? m x := + FiniteMapLaws.lookup_insert_ne m k x v (Ne.symm h) + rw [heq] at hv' + have : False := this ⟨v', hv'⟩ + cases this + · -- mem x (domSet m) = true, need to show mem x (domSet (insert m k v)) = true + have ⟨v', hv'⟩ := elem_of_domSet m x |>.mp hmem + have heq : FiniteMap.get? (FiniteMap.insert m k v) x = FiniteMap.get? m x := + FiniteMapLaws.lookup_insert_ne m k x v (Ne.symm h) + have : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) = true := + elem_of_domSet (FiniteMap.insert m k v) x |>.mpr ⟨v', heq.symm ▸ hv'⟩ + exact this + +/-- Domain of ofSet equals the original set. -/ +theorem domSet_ofSet (c : V) (X : S) : + domSet (ofSet c X : M) = X := by + apply @FiniteSetLaws.ext S K _ _ + intro k + simp only [domSet] + apply Bool.eq_iff_iff.mpr + constructor + · -- Forward: k ∈ domSet (ofSet c X) → k ∈ X + intro hmem + rw [FiniteSetLaws.mem_ofList] at hmem + rw [List.mem_map] at hmem + obtain ⟨⟨k', v⟩, hmem_list, heq⟩ := hmem + simp at heq + rw [← heq] + have : FiniteMap.get? (ofSet c X : M) k' = some v := + FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mpr hmem_list + simp only [ofSet, FiniteMapLaws.elem_of_list_to_map] at this + have : k' ∈ ((FiniteSet.toList X).map (fun x => (x, c))).map Prod.fst := by + have : (k', v) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := by + exact list_lookup_some_mem k' v _ this + have hmem' : (k', v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by + exact List.mem_reverse.mp this + rw [List.mem_map] + exact ⟨(k', v), hmem', rfl⟩ + simp [List.map_map] at this + exact FiniteSetLaws.mem_toList X k' |>.mp this + · -- Backward: k ∈ X → k ∈ domSet (ofSet c X) + intro hmem + rw [FiniteSetLaws.mem_ofList, List.mem_map] + have hk_in : k ∈ FiniteSet.toList X := FiniteSetLaws.mem_toList X k |>.mpr hmem + have hmapped : (k, c) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by + rw [List.mem_map] + exact ⟨k, hk_in, rfl⟩ + have : FiniteMap.get? (ofSet c X : M) k = some c := by + simp only [ofSet, FiniteMapLaws.elem_of_list_to_map] + have : (k, c) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := + List.mem_reverse.mpr hmapped + have hnodup : ((FiniteSet.toList X).map (fun x => (x, c))).reverse.map Prod.fst |>.Nodup := by + rw [List.map_reverse] + simp only [List.map_map] + show (List.map (fun x => x) (FiniteSet.toList X)).reverse.Nodup + simp only [List.map_id'] + have ⟨l', hperm, hnodup', _⟩ : ∃ l', (FiniteSet.toList X).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = X := + FiniteSetLaws.ofList_toList X + have hnodup_toList : (FiniteSet.toList X).Nodup := hperm.symm.nodup hnodup' + exact list_nodup_reverse (FiniteSet.toList X) |>.mpr hnodup_toList + exact list_mem_lookup k c _ hnodup this + have : (k, c) ∈ FiniteMap.toList (ofSet c X : M) := + FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mp this + exact ⟨(k, c), this, rfl⟩ + +end DomainSet + +end Iris.Std diff --git a/src/Iris/Std/FiniteSet.lean b/src/Iris/Std/FiniteSet.lean new file mode 100644 index 00000000..b7f294d3 --- /dev/null +++ b/src/Iris/Std/FiniteSet.lean @@ -0,0 +1,931 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ + +/-! ## Abstract Finite Set Interface + +This file defines an abstract interface for finite sets, inspired by stdpp's `fin_sets`. + +### Notation + +* `x ∈ S` - Membership +* `∅` - Empty set +* `{x}` - Singleton set +* `S₁ ∪ S₂` - Union +* `S₁ ∩ S₂` - Intersection +* `S ∖ {x}` - Difference (remove element) +* `S₁ ⊆ S₂` - Subset relation +* `S₁.Disjoint S₂` - Disjoint sets +-/ + +namespace Iris.Std + +/-- Abstract finite set interface. +The type `S` represents a finite set of elements of type `A`. + +This corresponds to Rocq's `FinSet` class from stdpp. -/ +class FiniteSet (S : Type u) (A : outParam (Type v)) where + /-- Membership: check if an element is in the set. -/ + mem : A → S → Bool + /-- Insert an element into the set. -/ + insert : A → S → S + /-- Remove an element from the set (singleton difference). + Corresponds to Rocq's `X ∖ {[ x ]}`. -/ + erase : A → S → S + /-- The empty set. -/ + empty : S + /-- Convert the set to a list of elements. + Corresponds to Rocq's `elements`. -/ + toList : S → List A + /-- Construct a set from a list of elements. + Corresponds to Rocq's `list_to_set`. -/ + ofList : List A → S + /-- Union of two sets. -/ + union : S → S → S + /-- Intersection of two sets. -/ + inter : S → S → S + /-- Difference: remove all elements of second set from first. + `diff S₁ S₂` contains elements in `S₁` but not in `S₂`. + Corresponds to Rocq's `S₁ ∖ S₂`. -/ + diff : S → S → S + +export FiniteSet (mem insert erase toList ofList union inter diff) + +namespace FiniteSet + +variable {S : Type u} {A : Type v} [FiniteSet S A] + +/-- Empty set instance for `∅` notation. -/ +instance : EmptyCollection S := ⟨empty⟩ + +/-- Singleton set containing exactly one element. + Corresponds to Rocq's `{[ x ]}` notation. -/ +def singleton (x : A) : S := insert x ∅ + +/-- Union instance for `∪` notation. -/ +instance : Union S := ⟨union⟩ + +/-- Intersection instance for `∩` notation. -/ +instance : Inter S := ⟨inter⟩ + +/-- Difference instance for `\` notation. -/ +instance : SDiff S := ⟨diff⟩ + +/-- Subset relation: `S₁` is a subset of `S₂` if every element in `S₁` is also in `S₂`. + Corresponds to Rocq's `S₁ ⊆ S₂`. -/ +def Subset (S₁ S₂ : S) : Prop := ∀ x, mem x S₁ → mem x S₂ + +instance : HasSubset S := ⟨Subset⟩ + +/-- Two sets are disjoint if they share no common elements. + Corresponds to Rocq's `S₁ ## S₂`. -/ +def Disjoint (S₁ S₂ : S) : Prop := ∀ x, ¬(mem x S₁ ∧ mem x S₂) + +/-- Filter: keep only elements satisfying a predicate. + Corresponds to Rocq's `filter φ X`. -/ +def filter (φ : A → Bool) : S → S := + fun s => ofList ((toList s).filter φ) + +end FiniteSet + +/-- Membership instance for finite sets: `x ∈ s` means element `x` is in set `s`. -/ +instance {S : Type u} {A : Type v} [inst : FiniteSet S A] : Membership A S := + ⟨fun (s : S) (x : A) => inst.mem x s⟩ + +/-- Helper lemma: convert getElem? evidence to List.Mem -/ +theorem List.mem_of_getElem? {l : List α} {i : Nat} {x : α} (h : l[i]? = some x) : x ∈ l := by + have ⟨hi, hget⟩ := List.getElem?_eq_some_iff.mp h + exact List.mem_iff_getElem.mpr ⟨i, hi, hget⟩ + +/-- Helper lemma: convert List.Mem to getElem? existence -/ +theorem List.getElem?_of_mem {α : Type _} {l : List α} {x : α} (h : x ∈ l) : ∃ i : Nat, l[i]? = some x := by + have ⟨i, hi, hget⟩ := List.mem_iff_getElem.mp h + exact ⟨i, List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩⟩ + +/-- Laws that a finite set implementation must satisfy. -/ +class FiniteSetLaws (S : Type u) (A : Type v) [DecidableEq A] [FiniteSet S A] where + /-- Membership in empty set is always false. -/ + mem_empty : ∀ (x : A), FiniteSet.mem x (∅ : S) = false + /-- Membership in singleton: true iff equal. Corresponds to Rocq's `elem_of_singleton`. -/ + mem_singleton : ∀ (x y : A), FiniteSet.mem x (FiniteSet.singleton y : S) = true ↔ x = y + /-- Membership after insert: true if equal, otherwise unchanged. -/ + mem_insert_eq : ∀ (s : S) (x y : A), x = y → FiniteSet.mem x (FiniteSet.insert y s) = true + /-- Membership after insert: unchanged if not equal. -/ + mem_insert_ne : ∀ (s : S) (x y : A), x ≠ y → + FiniteSet.mem x (FiniteSet.insert y s) = FiniteSet.mem x s + /-- Singleton as insert into empty. -/ + singleton_insert : ∀ (x : A), (FiniteSet.singleton x : S) = FiniteSet.insert x ∅ + /-- Set extensionality: sets with same membership are equal. -/ + ext : ∀ (X Y : S), (∀ x, FiniteSet.mem x X = FiniteSet.mem x Y) → X = Y + /-- Membership after erase: false if equal, otherwise unchanged. -/ + mem_erase_eq : ∀ (s : S) (x y : A), x = y → FiniteSet.mem x (FiniteSet.erase y s) = false + /-- Membership after erase: unchanged if not equal. -/ + mem_erase_ne : ∀ (s : S) (x y : A), x ≠ y → + FiniteSet.mem x (FiniteSet.erase y s) = FiniteSet.mem x s + /-- Converting to list and back preserves the set (up to permutation). -/ + toList_ofList : ∀ (l : List A) (s : S), l.Nodup → FiniteSet.ofList l = s → + (FiniteSet.toList s).Perm l + /-- Converting list to set and back gives a permutation of the deduplicated list. -/ + ofList_toList : ∀ (s : S), + ∃ l', (FiniteSet.toList s).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = s + /-- Inserting into a set gives a list permutation including the new element. -/ + set_to_list_insert : ∀ (s : S) (x : A), FiniteSet.mem x s = false → + (FiniteSet.toList (FiniteSet.insert x s)).Perm (x :: FiniteSet.toList s) + /-- Erasing from a set gives a list permutation without the element. -/ + set_to_list_erase : ∀ (s : S) (x : A), FiniteSet.mem x s = true → + ∃ l', (FiniteSet.toList s).Perm (x :: l') ∧ + FiniteSet.toList (FiniteSet.erase x s) = l' + /-- Converting empty list gives empty set. -/ + ofList_nil : FiniteSet.ofList ([] : List A) = (∅ : S) + /-- toList of empty set is the empty list. -/ + toList_empty : FiniteSet.toList (∅ : S) = [] + /-- toList of singleton set is a singleton list (up to permutation). -/ + toList_singleton : ∀ (x : A), (FiniteSet.toList (FiniteSet.singleton x : S)).Perm [x] + /-- toList of union when disjoint (up to permutation). -/ + toList_union : ∀ (X Y : S), FiniteSet.Disjoint X Y → + ∃ l', (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList X ++ l') ∧ + (FiniteSet.toList Y).Perm l' + /-- toList of set difference (up to permutation). -/ + toList_sdiff : ∀ (X : S) (x : A), FiniteSet.mem x X = true → + ∃ l', (FiniteSet.toList X).Perm (x :: l') ∧ + (FiniteSet.toList (FiniteSet.diff X (FiniteSet.singleton x))).Perm l' + /-- Membership is preserved by toList. -/ + mem_toList : ∀ (X : S) (x : A), x ∈ FiniteSet.toList X ↔ FiniteSet.mem x X = true + /-- Membership in difference: y ∈ X \ {x} ↔ y ∈ X ∧ y ≠ x -/ + mem_diff_singleton : ∀ (X : S) (x y : A), + FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true ↔ + (FiniteSet.mem y X = true ∧ y ≠ x) + /-- Subset decomposition: If Y ⊆ X, then X = Y ∪ (X \ Y) up to the disjointness condition. -/ + union_diff : ∀ (X Y : S), Y ⊆ X → + FiniteSet.Disjoint Y (FiniteSet.diff X Y) ∧ + (∀ z, FiniteSet.mem z X = true ↔ (FiniteSet.mem z Y = true ∨ FiniteSet.mem z (FiniteSet.diff X Y) = true)) + /-- Subset relation preserved by toList: if Y ⊆ X, toList Y elements appear in toList X. -/ + toList_subset : ∀ (X Y : S), Y ⊆ X → + ∃ l, (FiniteSet.toList Y ++ l).Perm (FiniteSet.toList X) + /-- Membership in union: x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y -/ + mem_union : ∀ (X Y : S) (x : A), + FiniteSet.mem x (X ∪ Y) = true ↔ (FiniteSet.mem x X = true ∨ FiniteSet.mem x Y = true) + /-- Union is commutative for toList (up to permutation). -/ + toList_union_comm : ∀ (X Y : S), + (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList (Y ∪ X)) + /-- toList of filter is related to filter over toList. -/ + toList_filter : ∀ (X : S) (φ : A → Bool), + (FiniteSet.toList (FiniteSet.filter φ X)).Perm ((FiniteSet.toList X).filter φ) + /-- Membership in filter: x ∈ filter φ X ↔ x ∈ X ∧ φ x = true -/ + mem_filter : ∀ (X : S) (φ : A → Bool) (x : A), + FiniteSet.mem x (FiniteSet.filter φ X) = true ↔ (FiniteSet.mem x X = true ∧ φ x = true) + /-- Membership in ofList: x ∈ ofList l ↔ x ∈ l -/ + mem_ofList : ∀ (l : List A) (x : A), + FiniteSet.mem x (FiniteSet.ofList l : S) = true ↔ x ∈ l + +namespace FiniteSet + +variable {S : Type u} {A : Type v} [DecidableEq A] [FiniteSet S A] [FiniteSetLaws S A] + +/-- Size of a finite set: number of elements. Corresponds to Rocq's `size`. -/ +def size (s : S) : Nat := (toList s).length + +/-- The set is finite (always true for FiniteSet). Corresponds to Rocq's `set_finite`. -/ +theorem set_finite (X : S) : ∃ (l : List A), ∀ x, x ∈ l ↔ mem x X = true := by + exists toList X + intro x + exact FiniteSetLaws.mem_toList X x + +section Elements + +/-- toList is proper: equivalent sets have permutation-equivalent lists. + Corresponds to Rocq's `elements_proper`. -/ +theorem toList_proper (X Y : S) (h : ∀ x, mem x X = mem x Y) : + (toList X).Perm (toList Y) := by + have : X = Y := FiniteSetLaws.ext X Y h + rw [this] + +/-- Converting list to set and back gives the original set (up to permutation). + Corresponds to Rocq's `list_to_set_elements`. -/ +theorem ofList_toList_equiv (X : S) : ∀ x, mem x (ofList (toList X) : S) = mem x X := by + intro x + -- Use mem_ofList and mem_toList axioms + cases h : mem x (ofList (toList X) : S) <;> cases h' : mem x X + · rfl + · -- Contradiction: mem x X = true but mem x (ofList (toList X)) = false + have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h' + have : mem x (ofList (toList X) : S) = true := (FiniteSetLaws.mem_ofList (toList X) x).mpr this + rw [h] at this + cases this + · -- Contradiction: mem x (ofList (toList X)) = true but mem x X = false + have : x ∈ toList X := (FiniteSetLaws.mem_ofList (toList X) x).mp h + have : mem x X = true := (FiniteSetLaws.mem_toList X x).mp this + rw [h'] at this + cases this + · rfl + +/-- Converting a NoDup list to set and back gives a permutation. + Corresponds to Rocq's `elements_list_to_set`. -/ +theorem toList_ofList_perm (l : List A) (h : l.Nodup) : + (toList (ofList l : S)).Perm l := by + -- Directly use the axiom toList_ofList + exact FiniteSetLaws.toList_ofList l (ofList l : S) h rfl + +/-- Union of singleton and set when element not in set. + Corresponds to Rocq's `elements_union_singleton`. -/ +theorem toList_union_singleton (X : S) (x : A) (h : mem x X = false) : + (toList (union (singleton x) X)).Perm (x :: toList X) := by + -- Use the fact that {x} and X are disjoint, then use toList_union + have hdisj : Disjoint (singleton x) X := by + intro y + intro ⟨h1, h2⟩ + -- y ∈ {x} means y = x + have : y = x := (FiniteSetLaws.mem_singleton y x).mp h1 + rw [this] at h2 + rw [h] at h2 + cases h2 + -- Get the permutation from toList_union + obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union (singleton x) X hdisj + -- toList (singleton x) is a permutation of [x] + have hsing := FiniteSetLaws.toList_singleton (A := A) (S := S) x + -- Build up the permutation step by step + have h1 : (toList (singleton x) ++ l').Perm ([x] ++ l') := + List.Perm.append hsing (List.Perm.refl l') + have h2 : ([x] ++ l').Perm ([x] ++ toList X) := + List.Perm.append (List.Perm.refl [x]) hperm'.symm + exact hperm.trans (h1.trans h2) + +/-- Subset relation on toList. Corresponds to Rocq's `elements_submseteq`. -/ +theorem toList_submseteq (X Y : S) (h : X ⊆ Y) : + ∀ x, x ∈ toList X → x ∈ toList Y := by + intro x hx + rw [FiniteSetLaws.mem_toList] at hx ⊢ + exact h x hx + +end Elements + +section Size + +/-- Empty set has size 0. Corresponds to Rocq's `size_empty`. -/ +theorem size_empty : size (∅ : S) = 0 := by + unfold size + rw [FiniteSetLaws.toList_empty] + rfl + +/-- Size 0 iff empty set. Corresponds to Rocq's `size_empty_iff`. -/ +theorem size_empty_iff (X : S) : size X = 0 ↔ ∀ x, mem x X = false := by + constructor + · -- Forward: size X = 0 → ∀ x, mem x X = false + intro hsize x + unfold size at hsize + -- toList X has length 0, so it must be [] + have hnil : toList X = [] := List.eq_nil_of_length_eq_zero hsize + -- If mem x X were true, then x ∈ toList X, but toList X = [] + cases hmem : mem x X + · rfl + · -- Case: mem x X = true, derive contradiction + have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr hmem + rw [hnil] at this + cases this + · -- Backward: (∀ x, mem x X = false) → size X = 0 + intro h + -- Show X = ∅ by extensionality, then use size_empty + have : X = ∅ := by + apply FiniteSetLaws.ext (A := A) + intro x + rw [h x, FiniteSetLaws.mem_empty] + rw [this, size_empty] + +/-- Singleton set has size 1. Corresponds to Rocq's `size_singleton`. -/ +theorem size_singleton (x : A) : size (singleton x : S) = 1 := by + unfold size + have h := FiniteSetLaws.toList_singleton (A := A) (S := S) x + have : [x].length = 1 := rfl + rw [← this, ← h.length_eq] + +/-- Non-empty set has positive size. Corresponds to Rocq's `set_choose`. -/ +theorem set_choose (X : S) (h : size X ≠ 0) : ∃ x, mem x X = true := by + unfold size at h + -- If toList X has non-zero length, it must be x :: l for some x, l + cases hlist : toList X with + | nil => + -- Contradiction: list is empty but h says length ≠ 0 + rw [hlist] at h + simp at h + | cons x l => + -- x is the first element, so x ∈ toList X + exists x + rw [← FiniteSetLaws.mem_toList] + rw [hlist] + exact List.mem_cons_self .. + +/-- Union of disjoint sets has size equal to sum. + Corresponds to Rocq's `size_union`. -/ +theorem size_union (X Y : S) (h : Disjoint X Y) : + size (X ∪ Y) = size X + size Y := by + unfold size + obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union X Y h + rw [hperm.length_eq, List.length_append, hperm'.length_eq] + +/-- Subset implies smaller or equal size. Corresponds to Rocq's `subseteq_size`. -/ +theorem subseteq_size (X Y : S) (h : X ⊆ Y) : size X ≤ size Y := by + have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff Y X h + -- Y = X ∪ (Y \ X) in terms of membership, and X and Y \ X are disjoint + -- Convert membership equality to set equality + have hset_eq : Y = X ∪ (Y \ X) := by + apply FiniteSetLaws.ext (A := A) + intro z + -- heq z says: mem z Y = true ↔ (mem z X = true ∨ mem z (Y \ X) = true) + -- Need to show: mem z Y = mem z (X ∪ Y \ X) + -- The latter is: mem z X = true ∨ mem z (Y \ X) = true by mem_union + cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) + · rfl + · -- Contradiction: X ∪ (Y \ X) true but Y false + have : mem z X = true ∨ mem z (Y \ X) = true := + (FiniteSetLaws.mem_union X (Y \ X) z).mp hmem_union + have : mem z Y = true := (heq z).mpr this + rw [hmem_y] at this + cases this + · -- Contradiction: Y true but X ∪ (Y \ X) false + have : mem z X = true ∨ mem z (Y \ X) = true := (heq z).mp hmem_y + have : mem z (X ∪ (Y \ X)) = true := + (FiniteSetLaws.mem_union X (Y \ X) z).mpr this + rw [hmem_union] at this + cases this + · rfl + -- Now use size_union with disjointness + rw [hset_eq] + have hsize := size_union X (Y \ X) hdisj + omega + +/-- Proper subset implies strictly smaller size. Corresponds to Rocq's `subset_size`. -/ +theorem subset_size (X Y : S) (h : X ⊆ Y) (hne : ∃ x, mem x Y = true ∧ mem x X = false) : + size X < size Y := by + have ⟨x, hmemY, hmemX⟩ := hne + -- Derive: size Y = size X + size (Y \ X) from union_diff + have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff Y X h + have hset_eq : Y = X ∪ (Y \ X) := by + apply FiniteSetLaws.ext (A := A) + intro z + cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) + · rfl + · have : mem z X = true ∨ mem z (Y \ X) = true := + (FiniteSetLaws.mem_union X (Y \ X) z).mp hmem_union + have : mem z Y = true := (heq z).mpr this + rw [hmem_y] at this; cases this + · have : mem z X = true ∨ mem z (Y \ X) = true := (heq z).mp hmem_y + have : mem z (X ∪ (Y \ X)) = true := + (FiniteSetLaws.mem_union X (Y \ X) z).mpr this + rw [hmem_union] at this; cases this + · rfl + have hsize_union := size_union X (Y \ X) hdisj + have hsize_y : size Y = size X + size (Y \ X) := by + calc size Y + _ = size (X ∪ (Y \ X)) := by rw [← hset_eq] + _ = size X + size (Y \ X) := hsize_union + -- Show size (Y \ X) ≠ 0 because x ∈ Y \ X + have hdiff : size (Y \ X) ≠ 0 := by + intro hcontra + have : ∀ z, mem z (Y \ X) = false := (size_empty_iff (Y \ X)).mp hcontra + -- But x ∈ Y \ X + have hx_in_diff : mem x (Y \ X) = true := by + -- heq x says: mem x Y = true ↔ (mem x X = true ∨ mem x (Y \ X) = true) + -- We have mem x Y = true and mem x X = false + -- So mem x (Y \ X) = true + have : mem x X = true ∨ mem x (Y \ X) = true := (heq x).mp hmemY + cases this with + | inl h' => + -- Contradiction: mem x X = true but hmemX says mem x X = false + rw [h'] at hmemX + cases hmemX + | inr h => exact h + rw [this x] at hx_in_diff + cases hx_in_diff + omega + +/-- Size of difference. Corresponds to Rocq's `size_difference`. -/ +theorem size_difference (X Y : S) (h : Y ⊆ X) : + size (X \ Y) = size X - size Y := by + have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff X Y h + -- X = Y ∪ (X \ Y) and they are disjoint + have hset_eq : X = Y ∪ (X \ Y) := by + apply FiniteSetLaws.ext (A := A) + intro z + cases hmem_x : mem z X <;> cases hmem_union : mem z (Y ∪ (X \ Y)) + · rfl + · -- Contradiction: Y ∪ (X \ Y) true but X false + have : mem z Y = true ∨ mem z (X \ Y) = true := + (FiniteSetLaws.mem_union Y (X \ Y) z).mp hmem_union + have : mem z X = true := (heq z).mpr this + rw [hmem_x] at this + cases this + · -- Contradiction: X true but Y ∪ (X \ Y) false + have : mem z Y = true ∨ mem z (X \ Y) = true := (heq z).mp hmem_x + have : mem z (Y ∪ (X \ Y)) = true := + (FiniteSetLaws.mem_union Y (X \ Y) z).mpr this + rw [hmem_union] at this + cases this + · rfl + -- Use size_union + have hsize_union := size_union Y (X \ Y) hdisj + have : size X = size Y + size (X \ Y) := by + calc size X + _ = size (Y ∪ (X \ Y)) := by rw [← hset_eq] + _ = size Y + size (X \ Y) := hsize_union + omega + +end Size + +section Filter + +/-- Membership in filter. Corresponds to Rocq's `elem_of_filter`. -/ +theorem mem_filter' (P : A → Bool) (X : S) (x : A) : + mem x (filter P X) = true ↔ P x = true ∧ mem x X = true := by + have h := FiniteSetLaws.mem_filter X P x + constructor + · intro hf + have ⟨h1, h2⟩ := h.mp hf + exact ⟨h2, h1⟩ + · intro ⟨hp, hm⟩ + exact h.mpr ⟨hm, hp⟩ + +/-- Filter of empty set is empty. Corresponds to Rocq's `filter_empty`. -/ +theorem filter_empty (P : A → Bool) : filter P (∅ : S) = ∅ := by + apply FiniteSetLaws.ext (A := A) + intro x + -- Show mem x (filter P ∅) = mem x ∅ = false + have hempty : mem x (∅ : S) = false := FiniteSetLaws.mem_empty (A := A) x + rw [hempty] + -- Now show mem x (filter P ∅) = false + cases h : mem x (filter P (∅ : S)) + · rfl + · -- Contradiction: if mem x (filter P ∅) = true, then mem x ∅ = true + have : mem x (∅ : S) = true := (FiniteSetLaws.mem_filter (∅ : S) P x |>.mp h).1 + rw [FiniteSetLaws.mem_empty (A := A)] at this + cases this + +/-- Filter of singleton. Corresponds to Rocq's `filter_singleton`. -/ +theorem filter_singleton (P : A → Bool) (x : A) : + filter P (singleton x : S) = if P x then singleton x else ∅ := by + apply FiniteSetLaws.ext (A := A) + intro y + -- Split on whether P x is true or false + cases hpx : P x + · -- Case: P x = false, so filter P {x} = ∅ + -- Show mem y (filter P (singleton x)) = mem y ∅ = false + simp [hpx] + have hempty : mem y (∅ : S) = false := FiniteSetLaws.mem_empty (A := A) y + rw [hempty] + cases hmem : mem y (filter P (singleton x : S)) + · rfl + · -- Contradiction: mem y (filter P {x}) = true implies P x = true + have ⟨hmem_sing, hpy⟩ := (FiniteSetLaws.mem_filter (singleton x : S) P y).mp hmem + -- Also y ∈ {x}, so y = x + have : y = x := (FiniteSetLaws.mem_singleton y x).mp hmem_sing + rw [this] at hpy + rw [hpx] at hpy + cases hpy + · -- Case: P x = true, so filter P {x} = {x} + -- Show mem y (filter P (singleton x)) = mem y (singleton x) + simp [hpx] + cases hmem_filt : mem y (filter P (singleton x : S)) <;> + cases hmem_sing : mem y (singleton x : S) + · rfl + · -- mem y {x} = true but mem y (filter P {x}) = false - contradiction + -- Since y ∈ {x}, we have y = x, and P x = true, so y ∈ filter P {x} + have : y = x := (FiniteSetLaws.mem_singleton y x).mp hmem_sing + have : mem y (singleton x : S) = true ∧ P y = true := by + constructor + · exact hmem_sing + · rw [this, hpx] + have : mem y (filter P (singleton x : S)) = true := + (FiniteSetLaws.mem_filter (singleton x : S) P y).mpr this + rw [hmem_filt] at this + cases this + · -- mem y (filter P {x}) = true but mem y {x} = false - contradiction + have ⟨hmem, _⟩ := (FiniteSetLaws.mem_filter (singleton x : S) P y).mp hmem_filt + rw [hmem_sing] at hmem + cases hmem + · rfl + +/-- Filter distributes over union. Corresponds to Rocq's `filter_union`. -/ +theorem filter_union (P : A → Bool) (X Y : S) : + filter P (X ∪ Y) = filter P X ∪ filter P Y := by + apply FiniteSetLaws.ext (A := A) + intro x + -- Show: mem x (filter P (X ∪ Y)) = mem x (filter P X ∪ filter P Y) + -- LHS: x ∈ filter P (X ∪ Y) ↔ x ∈ X ∪ Y ∧ P x + -- RHS: x ∈ filter P X ∪ filter P Y ↔ (x ∈ X ∧ P x) ∨ (x ∈ Y ∧ P x) + -- ↔ (x ∈ X ∨ x ∈ Y) ∧ P x + -- ↔ x ∈ X ∪ Y ∧ P x + cases h_filt_union : mem x (filter P (X ∪ Y)) <;> + cases h_union_filt : mem x (filter P X ∪ filter P Y) + · rfl + · -- Contradiction: RHS is true but LHS is false + -- x ∈ filter P X ∪ filter P Y means (x ∈ filter P X) ∨ (x ∈ filter P Y) + have : mem x (filter P X) = true ∨ mem x (filter P Y) = true := + (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mp h_union_filt + cases this with + | inl h => + -- x ∈ filter P X, so x ∈ X and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) + have ⟨hmem_x, hpx⟩ := (FiniteSetLaws.mem_filter X P x).mp h + have : mem x (X ∪ Y) = true := (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hmem_x) + have : mem x (filter P (X ∪ Y)) = true := + (FiniteSetLaws.mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ + rw [h_filt_union] at this + cases this + | inr h => + -- x ∈ filter P Y, so x ∈ Y and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) + have ⟨hmem_y, hpx⟩ := (FiniteSetLaws.mem_filter Y P x).mp h + have : mem x (X ∪ Y) = true := (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hmem_y) + have : mem x (filter P (X ∪ Y)) = true := + (FiniteSetLaws.mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ + rw [h_filt_union] at this + cases this + · -- Contradiction: LHS is true but RHS is false + -- x ∈ filter P (X ∪ Y), so x ∈ X ∪ Y and P x + have ⟨hmem_union, hpx⟩ := (FiniteSetLaws.mem_filter (X ∪ Y) P x).mp h_filt_union + -- x ∈ X ∪ Y means x ∈ X or x ∈ Y + have : mem x X = true ∨ mem x Y = true := + (FiniteSetLaws.mem_union X Y x).mp hmem_union + cases this with + | inl hmem_x => + -- x ∈ X and P x, so x ∈ filter P X, so x ∈ filter P X ∪ filter P Y + have : mem x (filter P X) = true := + (FiniteSetLaws.mem_filter X P x).mpr ⟨hmem_x, hpx⟩ + have : mem x (filter P X ∪ filter P Y) = true := + (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mpr (Or.inl this) + rw [h_union_filt] at this + cases this + | inr hmem_y => + -- x ∈ Y and P x, so x ∈ filter P Y, so x ∈ filter P X ∪ filter P Y + have : mem x (filter P Y) = true := + (FiniteSetLaws.mem_filter Y P x).mpr ⟨hmem_y, hpx⟩ + have : mem x (filter P X ∪ filter P Y) = true := + (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mpr (Or.inr this) + rw [h_union_filt] at this + cases this + · rfl + +/-- Disjointness of filter and complement. Corresponds to Rocq's `disjoint_filter_complement`. -/ +theorem disjoint_filter_complement (P : A → Bool) (X : S) : + Disjoint (filter P X) (filter (fun x => !P x) X) := by + intro x + intro ⟨h1, h2⟩ + -- h1: mem x (filter P X) = true means P x = true + -- h2: mem x (filter (!P) X) = true means !P x = true, i.e., P x = false + have ⟨_, hpx_true⟩ := (FiniteSetLaws.mem_filter X P x).mp h1 + have ⟨_, hpx_false⟩ := (FiniteSetLaws.mem_filter X (fun y => !P y) x).mp h2 + -- hpx_false says !P x = true, which means P x = false + -- But hpx_true says P x = true - contradiction + cases hpx : P x + · -- P x = false, but hpx_true says P x = true + rw [hpx] at hpx_true + cases hpx_true + · -- P x = true, so !P x = false, but hpx_false says !P x = true + simp [hpx] at hpx_false + +end Filter + +section SetInduction + +/-- Well-founded relation on finite sets based on proper subset. + Corresponds to Rocq's `set_wf`. -/ +theorem set_wf : WellFounded (fun (X Y : S) => X ⊆ Y ∧ ∃ x, mem x Y = true ∧ mem x X = false) := by + -- Well-founded because size decreases for proper subsets + have h_sub : ∀ X Y, (X ⊆ Y ∧ ∃ x, mem x Y = true ∧ mem x X = false) → size (S := S) (A := A) X < size (S := S) (A := A) Y := by + intro X Y ⟨hsub, x, hmemY, hmemX⟩ + exact subset_size X Y hsub ⟨x, hmemY, hmemX⟩ + apply Subrelation.wf + · intro X Y hrel + exact h_sub X Y hrel + · exact (measure (size (S := S) (A := A))).wf + +/-- Induction principle for finite sets. + Corresponds to Rocq's `set_ind`. -/ +theorem set_ind {P : S → Prop} + (hemp : P ∅) + (hadd : ∀ x X, mem x X = false → P X → P (union (singleton x) X)) + (X : S) : P X := by + -- Use well-founded induction based on set_wf + apply WellFounded.induction set_wf X + intro Y IH + by_cases hempty : size Y = 0 + · have hY_empty : ∀ x, mem x Y = false := (size_empty_iff Y).mp hempty + have : Y = ∅ := FiniteSetLaws.ext (S := S) (A := A) Y ∅ (fun x => by rw [hY_empty x, FiniteSetLaws.mem_empty]) + subst this + exact hemp + · obtain ⟨x, hmem⟩ := set_choose Y hempty + let Y' := diff Y (singleton x) + have hnotin : mem x Y' = false := by + cases h : mem x Y' + · rfl + · have ⟨_, hne⟩ := (FiniteSetLaws.mem_diff_singleton Y x x).mp h + cases hne rfl + have hPY' : P Y' := by + apply IH + exact ⟨fun z hz => (FiniteSetLaws.mem_diff_singleton Y x z).mp hz |>.1, x, hmem, hnotin⟩ + -- Show Y = {x} ∪ Y' + have heq : Y = union (singleton x) Y' := by + apply FiniteSetLaws.ext (A := A) + intro z + cases hmemz : mem z Y <;> cases hmemu : mem z (union (singleton x) Y') + · rfl + · have : mem z (singleton x) = true ∨ mem z Y' = true := + (FiniteSetLaws.mem_union (singleton x) Y' z).mp hmemu + cases this with + | inl h => have : z = x := (FiniteSetLaws.mem_singleton (S := S) (A := A) z x).mp h; rw [this, hmem] at hmemz; cases hmemz + | inr h => have ⟨hmemY, _⟩ := (FiniteSetLaws.mem_diff_singleton Y x z).mp h; rw [hmemz] at hmemY; cases hmemY + · have : mem z (singleton x : S) = true ∨ mem z Y' = true := by + by_cases hzx : z = x + · left; exact (FiniteSetLaws.mem_singleton (S := S) (A := A) z x).mpr hzx + · right; exact (FiniteSetLaws.mem_diff_singleton Y x z).mpr ⟨hmemz, hzx⟩ + have : mem z (union (singleton x) Y') = true := (FiniteSetLaws.mem_union (singleton x) Y' z).mpr this + rw [hmemu] at this; cases this + · rfl + have : P (union (singleton x) Y') := hadd x Y' hnotin hPY' + rw [heq] + exact this + +end SetInduction + +section Map + +/-- Map operation on sets. Maps a function over all elements. + Corresponds to Rocq's `set_map`. -/ +def map {B : Type w} [DecidableEq B] [FiniteSet S A] [FiniteSet T B] + (f : A → B) (X : S) : T := + ofList ((toList X).map f) + +/-- Membership in mapped set. Corresponds to Rocq's `elem_of_map`. -/ +theorem mem_map {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → B) (X : S) (y : B) : + mem y (map f X : T) = true ↔ ∃ x, y = f x ∧ mem x X = true := by + unfold map + rw [FiniteSetLaws.mem_ofList] + constructor + · intro h + have ⟨x, hmem, hx⟩ := List.mem_map.mp h + exact ⟨x, hx.symm, (FiniteSetLaws.mem_toList X x).mp hmem⟩ + · intro ⟨x, hf, hmem⟩ + have : y ∈ List.map f (toList X) := by + rw [List.mem_map] + exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hmem, hf.symm⟩ + exact this + +/-- Map of empty set. Corresponds to Rocq's `set_map_empty`. -/ +theorem map_empty {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → B) : + map f (∅ : S) = (∅ : T) := by + unfold map + rw [FiniteSetLaws.toList_empty, List.map_nil, FiniteSetLaws.ofList_nil] + +/-- Map distributes over union. Corresponds to Rocq's `set_map_union`. -/ +theorem map_union {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → B) (X Y : S) : + map f (X ∪ Y : S) = (map f X ∪ map f Y : T) := by + apply FiniteSetLaws.ext (A := B) + intro z + cases hmem1 : mem z (map f (X ∪ Y : S) : T) <;> + cases hmem2 : mem z ((map f X ∪ map f Y : T)) + · rfl + · -- Contradiction + have := (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mp hmem2 + cases this with + | inl h => + have ⟨x, hfx, hx⟩ := mem_map f X z |>.mp h + have : mem z (map f (X ∪ Y : S) : T) = true := mem_map f (X ∪ Y : S) z |>.mpr + ⟨x, hfx, (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hx)⟩ + rw [hmem1] at this + cases this + | inr h => + have ⟨x, hfx, hx⟩ := mem_map f Y z |>.mp h + have : mem z (map f (X ∪ Y : S) : T) = true := mem_map f (X ∪ Y : S) z |>.mpr + ⟨x, hfx, (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hx)⟩ + rw [hmem1] at this + cases this + · -- Contradiction + have ⟨x, hfx, hx⟩ := mem_map f (X ∪ Y : S) z |>.mp hmem1 + have := (FiniteSetLaws.mem_union X Y x).mp hx + cases this with + | inl h => + have : mem z (map f X ∪ map f Y : T) = true := + (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mpr + (Or.inl (mem_map f X z |>.mpr ⟨x, hfx, h⟩)) + rw [hmem2] at this + cases this + | inr h => + have : mem z (map f X ∪ map f Y : T) = true := + (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mpr + (Or.inr (mem_map f Y z |>.mpr ⟨x, hfx, h⟩)) + rw [hmem2] at this + cases this + · rfl + +/-- Map of singleton. Corresponds to Rocq's `set_map_singleton`. -/ +theorem map_singleton {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → B) (x : A) : + ∀ y, mem y (map f (singleton x : S) : T) = mem y (singleton (f x) : T) := by + intro y + cases h1 : mem y (map f (singleton x : S) : T) <;> + cases h2 : mem y (singleton (f x) : T) + · rfl + · -- Contradiction + have : y = f x := (FiniteSetLaws.mem_singleton y (f x)).mp h2 + rw [this] at h1 + have : mem (f x) (map f (singleton x : S) : T) = true := + mem_map f (singleton x : S) (f x) |>.mpr + ⟨x, rfl, (FiniteSetLaws.mem_singleton x x).mpr rfl⟩ + rw [h1] at this + cases this + · -- Contradiction + have ⟨z, hfz, hz⟩ := mem_map f (singleton x : S) y |>.mp h1 + have : z = x := (FiniteSetLaws.mem_singleton z x).mp hz + rw [this] at hfz + have : mem y (singleton (f x) : T) = true := + (FiniteSetLaws.mem_singleton y (f x)).mpr hfz + rw [h2] at this + cases this + · rfl + +end Map + +section Bind + +/-- Bind operation on sets. Flatmap a function over all elements. + Corresponds to Rocq's `set_bind`. -/ +def bind {T : Type u} [FiniteSet T A] (f : A → T) (X : S) : T := + ofList ((toList X).flatMap (fun x => toList (f x))) + +/-- Membership in bind. Corresponds to Rocq's `elem_of_set_bind`. -/ +theorem mem_bind {T : Type u} [FiniteSet T A] [FiniteSetLaws T A] + (f : A → T) (X : S) (y : A) : + mem y (bind f X) = true ↔ ∃ x, mem x X = true ∧ mem y (f x) = true := by + unfold bind + rw [FiniteSetLaws.mem_ofList] + rw [List.mem_flatMap] + constructor + · intro ⟨x, hx_in, hy_in⟩ + exact ⟨x, (FiniteSetLaws.mem_toList X x).mp hx_in, (FiniteSetLaws.mem_toList (f x) y).mp hy_in⟩ + · intro ⟨x, hx, hy⟩ + exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hx, (FiniteSetLaws.mem_toList (f x) y).mpr hy⟩ + +/-- Bind of singleton. Corresponds to Rocq's `set_bind_singleton`. -/ +theorem bind_singleton {T : Type u} [FiniteSet T A] [FiniteSetLaws T A] + (f : A → T) (x : A) : + ∀ y, mem y (bind (S := S) f (singleton x)) = mem y (f x) := by + intro y + cases h1 : mem y (bind (S := S) f (singleton x)) <;> + cases h2 : mem y (f x) + · rfl + · -- Contradiction + have : mem y (bind (S := S) f (singleton x)) = true := + mem_bind f (singleton x) y |>.mpr + ⟨x, (FiniteSetLaws.mem_singleton x x).mpr rfl, h2⟩ + rw [h1] at this + cases this + · -- Contradiction + have ⟨z, hz, hmem⟩ := mem_bind f (singleton x) y |>.mp h1 + have : z = x := (FiniteSetLaws.mem_singleton z x).mp hz + rw [this] at hmem + rw [h2] at hmem + cases hmem + · rfl + +end Bind + +section Omap + +/-- Option map operation on sets. Maps a partial function, keeping only Some values. + Corresponds to Rocq's `set_omap`. -/ +def omap {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] + (f : A → Option B) (X : S) : T := + ofList ((toList X).filterMap f) + +/-- Membership in omap. Corresponds to Rocq's `elem_of_set_omap`. -/ +theorem mem_omap {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → Option B) (X : S) (y : B) : + mem y (omap f X : T) = true ↔ ∃ x, mem x X = true ∧ f x = some y := by + unfold omap + rw [FiniteSetLaws.mem_ofList] + rw [List.mem_filterMap] + constructor + · intro ⟨x, hx_in, hfx⟩ + exact ⟨x, (FiniteSetLaws.mem_toList X x).mp hx_in, hfx⟩ + · intro ⟨x, hx, hfx⟩ + exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hx, hfx⟩ + +/-- Omap of empty set. Corresponds to Rocq's `set_omap_empty`. -/ +theorem omap_empty {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → Option B) : + omap f (∅ : S) = (∅ : T) := by + unfold omap + rw [FiniteSetLaws.toList_empty, List.filterMap_nil, FiniteSetLaws.ofList_nil] + +/-- Omap distributes over union. Corresponds to Rocq's `set_omap_union`. -/ +theorem omap_union {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → Option B) (X Y : S) : + ∀ z, mem z (omap f (X ∪ Y : S) : T) = mem z ((omap f X : T) ∪ (omap f Y : T)) := by + intro z + cases h1 : mem z (omap f (X ∪ Y : S) : T) <;> + cases h2 : mem z ((omap f X : T) ∪ (omap f Y : T)) + · rfl + · -- Contradiction + have := (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mp h2 + cases this with + | inl h => + have ⟨x, hx, hfx⟩ := mem_omap f X z |>.mp h + have : mem z (omap f (X ∪ Y : S) : T) = true := + mem_omap f (X ∪ Y : S) z |>.mpr + ⟨x, (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hx), hfx⟩ + rw [h1] at this + cases this + | inr h => + have ⟨x, hx, hfx⟩ := mem_omap f Y z |>.mp h + have : mem z (omap f (X ∪ Y : S) : T) = true := + mem_omap f (X ∪ Y : S) z |>.mpr + ⟨x, (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hx), hfx⟩ + rw [h1] at this + cases this + · -- Contradiction + have ⟨x, hx, hfx⟩ := mem_omap f (X ∪ Y : S) z |>.mp h1 + have := (FiniteSetLaws.mem_union X Y x).mp hx + cases this with + | inl h => + have : mem z ((omap f X : T) ∪ (omap f Y : T)) = true := + (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mpr + (Or.inl (mem_omap f X z |>.mpr ⟨x, h, hfx⟩)) + rw [h2] at this + cases this + | inr h => + have : mem z ((omap f X : T) ∪ (omap f Y : T)) = true := + (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mpr + (Or.inr (mem_omap f Y z |>.mpr ⟨x, h, hfx⟩)) + rw [h2] at this + cases this + · rfl + +/-- Omap of singleton when function returns Some. -/ +theorem omap_singleton_some {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → Option B) (x : A) (y : B) (h : f x = some y) : + ∀ z, mem z (omap f (singleton x : S) : T) = mem z (singleton y : T) := by + intro z + cases h1 : mem z (omap f (singleton x : S) : T) <;> + cases h2 : mem z (singleton y : T) + · rfl + · -- Contradiction + have : z = y := (FiniteSetLaws.mem_singleton z y).mp h2 + rw [this] at h1 + have : mem y (omap f (singleton x : S) : T) = true := + mem_omap f (singleton x : S) y |>.mpr + ⟨x, (FiniteSetLaws.mem_singleton x x).mpr rfl, h⟩ + rw [h1] at this + cases this + · -- Contradiction: mem z (omap f {x}) = true but f x = some y and mem z {y} = false + have ⟨w, hw, hfw⟩ := mem_omap f (singleton x : S) z |>.mp h1 + have wx : w = x := (FiniteSetLaws.mem_singleton w x).mp hw + rw [wx] at hfw + -- hfw : f x = some z, but we know f x = some y + rw [h] at hfw + -- Now hfw : some y = some z, so y = z + cases hfw + -- But now we have mem y (singleton y) = false, contradiction + have : mem y (singleton y : T) = true := (FiniteSetLaws.mem_singleton y y).mpr rfl + rw [h2] at this + cases this + · rfl + +/-- Omap of singleton when function returns None. -/ +theorem omap_singleton_none {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] + (f : A → Option B) (x : A) (h : f x = none) : + omap f (singleton x : S) = (∅ : T) := by + apply FiniteSetLaws.ext (A := B) + intro z + cases h1 : mem z (omap f (singleton x : S) : T) <;> + cases h2 : mem z (∅ : T) + · rfl + · -- Contradiction: mem z ∅ = true + rw [FiniteSetLaws.mem_empty] at h2 + cases h2 + · -- Contradiction: mem z (omap f {x}) = true but f x = none + have ⟨w, hw, hfw⟩ := mem_omap f (singleton x : S) z |>.mp h1 + have : w = x := (FiniteSetLaws.mem_singleton w x).mp hw + rw [this] at hfw + rw [h] at hfw + cases hfw + · rfl + +end Omap + +section DecisionProcedures + +/-- Forall predicate on sets. Corresponds to Rocq's `set_Forall`. -/ +def setForall (P : A → Prop) (X : S) : Prop := + ∀ x, mem x X = true → P x + +/-- Exists predicate on sets. Corresponds to Rocq's `set_Exists`. -/ +def setExists (P : A → Prop) (X : S) : Prop := + ∃ x, mem x X = true ∧ P x + +end DecisionProcedures + +end FiniteSet + +end Iris.Std diff --git a/src/Iris/Std/List.lean b/src/Iris/Std/List.lean new file mode 100644 index 00000000..056245e4 --- /dev/null +++ b/src/Iris/Std/List.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2025 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 + +/-- If lookup returns some value, the key-value pair is in the list. -/ +theorem list_lookup_some_mem {A B : Type _} [BEq A] [LawfulBEq A] + (k : A) (v : B) (l : List (A × B)) : + List.lookup k l = some v → (k, v) ∈ l := by + intro h + induction l with + | nil => contradiction + | cons hd tl ih => + simp [List.lookup] at h + split at h + · simp at h + subst h + simp + left + next heq => + have : k = hd.1 := eq_of_beq heq + exact Prod.ext this rfl + · simp + right + exact ih h + +/-- Lookup in a mapped list returns the mapped value. -/ +theorem list_lookup_map {A B : Type _} [BEq A] [LawfulBEq A] + (f : A → B) (k : A) (l : List A) (h : k ∈ l) : + List.lookup k (l.map (fun x => (x, f x))) = some (f k) := by + induction l with + | nil => contradiction + | cons hd tl ih => + simp [List.lookup, List.map] + split + · next heq => + have : k = hd := eq_of_beq heq + simp [this] + · next hneq => + simp at h + cases h with + | inl heq => + subst heq + have : (k == k) = true := BEq.refl k + rw [this] at hneq + contradiction + | inr hmem => + exact ih hmem + +/-- If lookup succeeds in a mapped list, the key must be in the original list. -/ +theorem list_lookup_map_inv {A B : Type _} [BEq A] [LawfulBEq A] + (f : A → B) (k : A) (l : List A) (v : B) : + List.lookup k (l.map (fun x => (x, f x))) = some v → v = f k ∧ k ∈ l := by + intro h + induction l with + | nil => contradiction + | cons hd tl ih => + simp [List.lookup, List.map] at h + split at h + · next heq => + simp at h + subst h + have : k = hd := eq_of_beq heq + subst this + simp [List.mem_cons] + · next hneq => + have ⟨hv, hmem⟩ := ih h + constructor + · exact hv + · simp [List.mem_cons] + right + exact hmem + +/-- If a key-value pair is in a list with unique keys (nodup on fst projection), + then lookup returns that value. -/ +theorem list_mem_lookup {A B : Type _} [BEq A] [LawfulBEq A] + (k : A) (v : B) (l : List (A × B)) (hnodup : l.map Prod.fst |>.Nodup) : + (k, v) ∈ l → List.lookup k l = some v := by + intro h + induction l with + | nil => contradiction + | cons hd tl ih => + simp at h + simp [List.lookup] + split + · next heq => + cases h with + | inl heq_pair => + -- (k, v) = hd, so we need to show some hd.2 = some v + rw [Prod.ext_iff] at heq_pair + exact congrArg some heq_pair.2.symm + | inr hmem => + -- k is in tl but k == hd.1, contradicts nodup + have keq : k = hd.1 := eq_of_beq heq + subst keq + have hmem_map : hd.1 ∈ tl.map Prod.fst := by + rw [List.mem_map] + exact ⟨(hd.1, v), hmem, rfl⟩ + have : (List.map Prod.fst (hd :: tl)).Nodup := hnodup + rw [List.map_cons] at this + have h_nodup_cons := List.nodup_cons.mp this + have : hd.1 ∉ tl.map Prod.fst := h_nodup_cons.1 + contradiction + · next hneq => + cases h with + | inl heq_pair => + rw [Prod.ext_iff] at heq_pair + have : k = hd.1 := heq_pair.1 + subst this + have : (hd.1 == hd.1) = true := BEq.refl hd.1 + rw [this] at hneq + contradiction + | inr hmem => + simp [List.map, List.Nodup, List.pairwise_cons] at hnodup + exact ih hnodup.2 hmem + +/-- Reversing a list preserves the nodup property. -/ +theorem list_nodup_reverse {A : Type _} (l : List A) : + l.reverse.Nodup ↔ l.Nodup := by + constructor + · intro h + induction l with + | nil => constructor + | cons hd tl ih => + rw [List.reverse_cons] at h + have ⟨h1, h2, h3⟩ := List.nodup_append.mp h + constructor + · intro a' hmem + have hmem_rev : a' ∈ tl.reverse := List.mem_reverse.mpr hmem + have hd_mem : hd ∈ [hd] := List.mem_singleton_self hd + have := h3 a' hmem_rev hd hd_mem + exact this.symm + · exact ih h1 + · intro h + induction l with + | nil => constructor + | cons hd tl ih => + rw [List.reverse_cons] + match h with + | .cons hnotin hnodup => + have ih_result := ih hnodup + apply List.nodup_append.mpr + constructor + · exact ih_result + · constructor + · constructor + · intro a' hmem; contradiction + · constructor + · intro a ha b hb + simp at hb + subst hb + have := List.mem_reverse.mp ha + exact (hnotin a this).symm + +end Iris.Std From bd5567a619a3ac1f34636acddd697edfec5137b5 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Fri, 9 Jan 2026 13:32:49 +0100 Subject: [PATCH 3/9] Fix warnings --- src/Iris/BI/BigOp/BigAndMap.lean | 1 + src/Iris/BI/BigOp/BigSepMap.lean | 7 +++++++ src/Iris/BI/BigOp/BigSepSet.lean | 20 ++++++++++++++++++-- src/Iris/Std/FiniteMapDom.lean | 4 ++++ 4 files changed, 30 insertions(+), 2 deletions(-) diff --git a/src/Iris/BI/BigOp/BigAndMap.lean b/src/Iris/BI/BigOp/BigAndMap.lean index 544e0c76..b7d5f4f8 100644 --- a/src/Iris/BI/BigOp/BigAndMap.lean +++ b/src/Iris/BI/BigOp/BigAndMap.lean @@ -489,6 +489,7 @@ variable [FiniteMap M' K' V] variable [FiniteMapLaws M' K' V] variable [FiniteMapKmapLaws M M' K K' V] +omit [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_andM_kmap` in Rocq Iris. -/ theorem kmap {Φ : K' → V → PROP} {m : M} (f : K → K') (hinj : ∀ {x y}, f x = f y → x = y) : ([∧map] k' ↦ y ∈ FiniteMap.kmap (M' := M') f m, Φ k' y) ⊣⊢ diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index dca9ab93..63739fb0 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -944,6 +944,7 @@ end MapZip /-! ## Advanced Impl Lemmas -/ +omit [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_impl_strong` in Rocq Iris. Strong version of impl that tracks which keys are in m₂ vs only in m₁. -/ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} @@ -1059,6 +1060,7 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} (sep_mono_r (sep_mono_r hweaken)).trans <| (sep_mono_r (IH (Std.delete m₁ i))).trans <| (sep_mono_r (sep_mono_r hfilter_equiv.2)).trans <| sep_assoc.2.trans (sep_mono_l hinsert_goal.2) +omit [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_impl_dom_subseteq` in Rocq Iris. Specialized version when the domain of m₂ is a subset of the domain of m₁. -/ theorem impl_dom_subseteq [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} @@ -1159,6 +1161,7 @@ section DomainSet variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] variable [FiniteMapLawsSelf M K V] +omit [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_dom` in Rocq Iris. -/ theorem dom {Φ : K → PROP} (m : M) : ([∗map] k ↦ _v ∈ m, Φ k) ⊣⊢ ([∗set] k ∈ (domSet m : S), Φ k) := by @@ -1207,6 +1210,7 @@ theorem dom {Φ : K → PROP} (m : M) : _ ⊣⊢ Φ k ∗ ([∗set] k' ∈ (domSet m : S), Φ k') := ⟨sep_mono_r IH.1, sep_mono_r IH.2⟩ _ ⊣⊢ ([∗set] k' ∈ FiniteSet.singleton k ∪ (domSet m : S), Φ k') := (BigSepS.insert hk_not_in_dom).symm +omit [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_gset_to_gmap` in Rocq Iris. -/ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ⊣⊢ ([∗set] k ∈ X, Φ k c) := by @@ -1240,6 +1244,7 @@ end DomainSet /-! ## Commuting Lemmas -/ +omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_sepL` in Rocq Iris. -/ theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M) (l : List B) : ([∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y) ⊣⊢ @@ -1252,6 +1257,7 @@ theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M) (l : Lis _ ⊣⊢ [∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y := equiv_iff.mp <| BigSepL.congr fun k' y => .rfl +omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_sepM` in Rocq Iris. -/ theorem sepM {M₂ : Type _} {K₂ : Type _} {V₂ : Type _} [DecidableEq K₂] [FiniteMap M₂ K₂ V₂] [FiniteMapLaws M₂ K₂ V₂] @@ -1271,6 +1277,7 @@ theorem sepM {M₂ : Type _} {K₂ : Type _} {V₂ : Type _} _ ⊣⊢ [∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂ := equiv_iff.mp <| BigSepL.congr fun _ kv₂ => .rfl +omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in /-- Corresponds to `big_sepM_sepS` in Rocq Iris. -/ theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean index de86ae57..808139a5 100644 --- a/src/Iris/BI/BigOp/BigSepSet.lean +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -26,6 +26,7 @@ namespace BigSepS /-! ## Monotonicity and Congruence -/ +omit [DecidableEq A] in private theorem mono_list {Φ Ψ : A → PROP} {l : List A} (h : ∀ x, List.Mem x l → Φ x ⊢ Ψ x) : bigOpL sep emp (fun _ x => Φ x) l ⊢ bigOpL sep emp (fun _ x => Ψ x) l := by @@ -86,6 +87,7 @@ theorem flip_mono' {Φ Ψ : A → PROP} {X : S} /-! ## Basic Structural Lemmas -/ +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_elements` in Rocq Iris. -/ theorem elements {Φ : A → PROP} {X : S} : ([∗set] x ∈ X, Φ x) ⊣⊢ [∗list] x ∈ toList X, Φ x := by @@ -106,9 +108,10 @@ theorem empty' {P : PROP} [Affine P] {Φ : A → PROP} : P ⊢ [∗set] x ∈ (∅ : S), Φ x := Affine.affine.trans empty.2 +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_emp` in Rocq Iris. -/ theorem emp' {X : S} : - ([∗set] x ∈ X, emp) ⊣⊢ (emp : PROP) := by + ([∗set] _x ∈ X, emp) ⊣⊢ (emp : PROP) := by unfold bigSepS have := @BigOpL.unit_const PROP _ _ sep emp _ (toList X) exact equiv_iff.mp this @@ -450,6 +453,7 @@ instance empty_persistent {Φ : A → PROP} : simp only [BigOpL.nil] exact persistently_emp_intro (PROP := PROP) (P := emp) +omit [DecidableEq A] in private theorem persistent_list {Φ : A → PROP} {l : List A} (h : ∀ x, List.Mem x l → Persistent (Φ x)) : bigOpL sep emp (fun _ => Φ) l ⊢ bigOpL sep emp (fun _ => Φ) l := by @@ -486,6 +490,7 @@ instance empty_affine {Φ : A → PROP} : have h := empty (Φ := Φ) (S := S) exact h.1 +omit [DecidableEq A] in private theorem affine_list {Φ : A → PROP} {l : List A} (h : ∀ x, List.Mem x l → Affine (Φ x)) : bigOpL sep emp (fun _ => Φ) l ⊢ emp := by @@ -660,6 +665,7 @@ theorem filter_acc [BIAffine PROP] (φ : A → Prop) [DecidablePred φ] {Φ : A /-! ## Separation Logic Combinators -/ +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sep` in Rocq Iris. -/ theorem sep' {Φ Ψ : A → PROP} {X : S} : ([∗set] y ∈ X, Φ y ∗ Ψ y) ⊣⊢ ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ X, Ψ y) := by @@ -674,7 +680,7 @@ theorem sep_2 {Φ Ψ : A → PROP} {X : S} : ([∗set] y ∈ X, Φ y ∗ Ψ y) := by apply wand_intro (PROP := PROP) refine sep_comm (PROP := PROP).1.trans ?_ - have h := @sep' PROP _ S A _ _ _ Ψ Φ X + have h := @sep' PROP _ S A _ Ψ Φ X refine h.2.trans ?_ apply mono intro x _ @@ -750,11 +756,13 @@ theorem forall' [BIAffine PROP] {Φ : A → PROP} {X : S} /-! ## Modal Operators -/ +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_persistently` in Rocq Iris. -/ theorem persistently [BIAffine PROP] {Φ : A → PROP} {X : S} : ( ([∗set] y ∈ X, Φ y)) ⊣⊢ [∗set] y ∈ X, (Φ y) := (persistently_congr elements).trans (BigSepL.persistently.trans elements.symm) +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_dup` in Rocq Iris. -/ theorem dup {P : PROP} [hAff : Affine P] {X : S} : ⊢ □ (P -∗ P ∗ P) -∗ P -∗ [∗set] _x ∈ X, P := by @@ -775,16 +783,19 @@ theorem dup {P : PROP} [hAff : Affine P] {X : S} : refine (sep_mono_l ih).trans ?_ exact sep_comm (PROP := PROP).1 +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_later` in Rocq Iris. -/ theorem later [BIAffine PROP] {Φ : A → PROP} {X : S} : iprop(▷ [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷ Φ y := (later_congr elements).trans (BigSepL.later.trans elements.symm) +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_later_2` in Rocq Iris. -/ theorem later_2 {Φ : A → PROP} {X : S} : ([∗set] y ∈ X, ▷ Φ y) ⊢ iprop(▷ [∗set] y ∈ X, Φ y) := elements.1.trans (BigSepL.later_2.trans (later_mono elements.2)) +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_laterN` in Rocq Iris. -/ theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : iprop(▷^[n] [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷^[n] Φ y := by @@ -792,6 +803,7 @@ theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : | zero => exact .rfl | succ m ih => exact (later_congr ih).trans later +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_laterN_2` in Rocq Iris. -/ theorem laterN_2 {Φ : A → PROP} {n : Nat} {X : S} : ([∗set] y ∈ X, ▷^[n] Φ y) ⊢ iprop(▷^[n] [∗set] y ∈ X, Φ y) := by @@ -801,6 +813,7 @@ theorem laterN_2 {Φ : A → PROP} {n : Nat} {X : S} : /-! ## Introduction and Elimination -/ +omit [DecidableEq A] [FiniteSetLaws S A] in private theorem intro_list {Φ : A → PROP} {X : S} {l : List A} (hmem : ∀ x, List.Mem x l → FiniteSet.mem x X = true) : (□ (∀ x, ⌜FiniteSet.mem x X = true⌝ → Φ x)) ⊢ bigOpL sep emp (fun _ => Φ) l := by @@ -898,6 +911,7 @@ theorem subseteq {Φ : A → PROP} {X Y : S} /-! ## Commuting Lemmas -/ +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sepL` in Rocq Iris. -/ theorem sepL {B : Type _} (Φ : A → Nat → B → PROP) (X : S) (l : List B) : ([∗set] x ∈ X, [∗list] k↦y ∈ l, Φ x k y) ⊣⊢ @@ -909,6 +923,7 @@ theorem sepL {B : Type _} (Φ : A → Nat → B → PROP) (X : S) (l : List B) : _ ⊣⊢ [∗list] k↦y ∈ l, [∗set] x ∈ X, Φ x k y := equiv_iff.mp <| BigSepL.congr (fun k y => equiv_iff.mpr <| elements (Φ := fun x => Φ x k y).symm) +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sepS` in Rocq Iris. -/ theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] (Φ : A → B → PROP) (X : S) (Y : T) : @@ -924,6 +939,7 @@ theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSe equiv_iff.mp <| BigSepL.congr (fun _ y => equiv_iff.mpr <| elements (Φ := fun x => Φ x y).symm) _ ⊣⊢ [∗set] y ∈ Y, [∗set] x ∈ X, Φ x y := elements (Φ := fun y => [∗set] x ∈ X, Φ x y).symm +omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sepM` in Rocq Iris. -/ theorem sepM {B : Type _} {M : Type _} {K : Type _} [DecidableEq K] [FiniteMap M K B] [FiniteMapLaws M K B] diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index 38a3cc79..025acea2 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -32,10 +32,12 @@ def domSet (m : M) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) /-- Create map from set with constant value. -/ def ofSet (c : V) (X : S) : M := FiniteMap.ofList ((FiniteSet.toList X).map (fun k => (k, c))) +omit [FiniteMapLawsSelf M K V] in /-- Domain of empty map is empty set. -/ theorem domSet_empty : domSet (∅ : M) = (∅ : S) := by simp only [domSet, FiniteMapLaws.map_to_list_empty, List.map_nil, FiniteSetLaws.ofList_nil] +omit [FiniteMapLawsSelf M K V] in /-- Membership in domSet iff key has a value in the map. -/ theorem elem_of_domSet (m : M) (k : K) : FiniteSet.mem k (domSet (m : M) : S) = true ↔ ∃ v, FiniteMap.get? m k = some v := by @@ -49,6 +51,7 @@ theorem elem_of_domSet (m : M) (k : K) : · intro ⟨v, hv⟩ refine ⟨(k, v), FiniteMapLaws.elem_of_map_to_list m k v |>.mp hv, rfl⟩ +omit [FiniteMapLawsSelf M K V] in /-- Domain of insert includes the inserted key. -/ theorem domSet_insert (m : M) (k : K) (v : V) : (domSet (FiniteMap.insert m k v) : S) = FiniteSet.insert k (domSet m : S) := by @@ -87,6 +90,7 @@ theorem domSet_insert (m : M) (k : K) (v : V) : elem_of_domSet (FiniteMap.insert m k v) x |>.mpr ⟨v', heq.symm ▸ hv'⟩ exact this +omit [FiniteMapLawsSelf M K V] in /-- Domain of ofSet equals the original set. -/ theorem domSet_ofSet (c : V) (X : S) : domSet (ofSet c X : M) = X := by From 1daf92b42134a633d364cb086151656d15652ed6 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Sun, 11 Jan 2026 00:13:36 +0100 Subject: [PATCH 4/9] WIP: Simplifying FiniteMap --- src/Iris/Algebra/BigOp.lean | 378 +++++++++ src/Iris/BI/BigOp/BigAndMap.lean | 169 ++-- src/Iris/BI/BigOp/BigOp.lean | 8 +- src/Iris/BI/BigOp/BigSepList.lean | 4 +- src/Iris/BI/BigOp/BigSepMap.lean | 442 ++++++----- src/Iris/BI/BigOp/BigSepSet.lean | 6 +- src/Iris/Std/FiniteMap.lean | 1190 ++++++++++++++--------------- src/Iris/Std/FiniteMapDom.lean | 121 +-- src/Iris/Std/FiniteMapInst.lean | 127 +++ src/Iris/Std/List.lean | 76 ++ 10 files changed, 1530 insertions(+), 991 deletions(-) create mode 100644 src/Iris/Std/FiniteMapInst.lean diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean index 5aa5352c..56eb83e4 100644 --- a/src/Iris/Algebra/BigOp.lean +++ b/src/Iris/Algebra/BigOp.lean @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Zongyuan Liu -/ import Iris.Algebra.Monoid +import Iris.Std.FiniteMap namespace Iris.Algebra @@ -385,4 +386,381 @@ theorem commute_weak {R : M₂ → M₂ → Prop} {f : M₁ → M₂} 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} {V : Type w} +variable [DecidableEq K] [DecidableEq V] [FiniteMap M' K] [FiniteMapLaws M' K] + +/-- Big operator over finite maps. Corresponds to Rocq's `big_opM`. + Definition: `big_opM o u f m := big_opL o u (λ _, uncurry f) (map_to_list m)` -/ +def bigOpM (Φ : K → V → M) (m : M' V) : M := + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +/-- Corresponds to Rocq's `big_opM_empty`. + Rocq proof: `by rewrite big_opM_unseal /big_opM_def map_to_list_empty.` -/ +@[simp] theorem empty (Φ : K → V → M) : + bigOpM (op := op) (unit := unit) Φ (∅ : M' V) = unit := by + simp only [bigOpM, FiniteMapLaws.map_to_list_empty, BigOpL.nil] + +/-- Corresponds to Rocq's `big_opM_insert`. + Rocq proof: `intros ?. by rewrite big_opM_unseal /big_opM_def map_to_list_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.map_to_list_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`. + Rocq proof: + ``` + intros. rewrite -big_opM_insert ?lookup_delete_eq //. + by rewrite insert_delete_id. + ``` -/ +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 + -- Follows Rocq proof: rewrite -big_opM_insert ?lookup_delete_eq // and insert_delete_id + have heq := FiniteMapLaws.insert_delete_id m i x hi + -- bigOpM Φ m = bigOpM Φ (insert (delete m i) i x) + 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] + -- Now apply big_opM_insert with lookup_delete_eq + have hdelete := FiniteMapLaws.lookup_delete_eq 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.map_ind + (P := fun (m1' : M' A) => ∀ (m2' : M' B) (Φ' : K → A → M) (Ψ' : K → B → M), + (∀ 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.map_ind + (P := fun (m2'' : M' B) => ∀ (Φ'' : K → A → M) (Ψ'' : K → B → M), + (∀ 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 m2'' hm2''k _ Φ'' Ψ'' hfg'' + have := hfg'' k + rw [FiniteMapLaws.lookup_empty, FiniteMapLaws.lookup_insert_eq] at this + cases this + case hins => + intro k x1 m1' hm1'k IH m2' Φ' Ψ' hfg' + have hfg_k := hfg' k + rw [FiniteMapLaws.lookup_insert_eq] 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_ins : bigOpM (op := op) (unit := unit) Φ' (FiniteMap.insert m1' k x1) ≡ + op (Φ' k x1) (bigOpM (op := op) (unit := unit) Φ' m1') := + insert Φ' m1' k x1 hm1'k + have h_del : op (Ψ' k x2) (bigOpM (op := op) (unit := unit) Ψ' (FiniteMap.delete m2' k)) ≡ + bigOpM (op := op) (unit := unit) Ψ' m2' := + Equiv.symm (delete (op := op) (unit := unit) Ψ' m2' k x2 hm2k) + have h_op : R (op (Φ' k x1) (bigOpM (op := op) (unit := unit) Φ' m1')) + (op (Ψ' k x2) (bigOpM (op := op) (unit := unit) Ψ' (FiniteMap.delete m2' k))) := by + apply hR_op + · exact hfg_k + · apply IH + intro k' + by_cases hkk' : k = k' + · subst hkk' + rw [FiniteMapLaws.lookup_delete_eq, hm1'k] + trivial + · have h1 := FiniteMapLaws.lookup_insert_ne m1' k k' x1 hkk' + have h2 := FiniteMapLaws.lookup_delete_ne m2' k k' hkk' + rw [← h1, h2] + exact hfg' k' + exact hR_equiv.trans (hR_sub _ _ h_ins) (hR_equiv.trans h_op (hR_sub _ _ h_del)) + +/-- 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.elem_of_map_to_list m x.1 x.2 |>.mp this + exact hf x.1 x.2 this + +/-- 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 + +/-- 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 + +/-- 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 + +/-- 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 + +/-- 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 + +/-- Corresponds to Rocq's `big_opM_map_to_list`. -/ +theorem map_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 list_to_map (Φ : 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 := map_to_list (op := op) (unit := unit) Φ (FiniteMap.ofList l : M' V) + apply Equiv.trans h1 + apply BigOpL.perm + exact FiniteMapLaws.map_to_list_to_map l hnodup + +/-- Corresponds to Rocq's `big_opM_singleton`. -/ +theorem singleton (Φ : K → V → M) (i : K) (x : V) : + bigOpM (op := op) (unit := unit) Φ (FiniteMap.insert (∅ : M' V) i x) ≡ Φ i x := by + have : FiniteMap.get? (∅ : M' V) i = none := FiniteMapLaws.lookup_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.map_ind + (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)) + +/-- Corresponds to Rocq's `big_opM_fmap`. -/ +theorem fmap {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 + -- Now use BigOpL.fmap to transform the mapped list + exact BigOpL.fmap (op := op) (unit := unit) (fun kv => (kv.1, h kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +/-- 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 + +/-- Corresponds to Rocq's `big_opM_closed`. -/ +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.map_ind + (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.lookup_insert_eq m'' k x + · apply IH + intro k' x' hget' + apply hf'' + rw [FiniteMapLaws.lookup_insert_ne m'' k k' x] + · exact hget' + · intro heq + subst heq + rw [hget'] at hm'' + exact Option.noConfusion hm'' + +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 + +/-- Corresponds to Rocq's `big_opM_kmap`. -/ +theorem kmap {M'' : Type w → Type _} {K' : Type v} [DecidableEq K'] [FiniteMap M'' K'] + [FiniteMapLaws M'' K'] [FiniteMapKmapLaws M' M'' K K'] + (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.fmap (op := op) (unit := unit) (fun kv => (h kv.1, kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +/-- Corresponds to Rocq's `big_opM_map_seq`. -/ +theorem map_seq {M'' : Type w → Type _} [FiniteMap M'' Nat] [FiniteMapLaws M'' Nat] + [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] + have h1 : bigOpL op unit (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList (FiniteMap.map_seq (M := M'') start l : M'' V)) ≡ + bigOpL op unit (fun _ kv => Φ kv.1 kv.2) ((List.range' start l.length).zip l) := by + apply BigOpL.perm + exact FiniteMapSeqLaws.toList_map_seq start l + apply Equiv.trans h1 + exact BigOpL.zip_seq (op := op) (unit := unit) (fun kv => Φ kv.1 kv.2) start l + +/-- Corresponds to Rocq's `big_opM_sep_zip_with`. + Rocq proof: + ``` + intros Hdom Hg1 Hg2. rewrite big_opM_op. + rewrite -(big_opM_fmap g1) -(big_opM_fmap g2). + rewrite map_fmap_zip_with_r; [|naive_solver..]. + by rewrite map_fmap_zip_with_l; [|naive_solver..]. + ``` -/ +theorem sep_zip_with {A : Type w} {B : Type w} {C : Type w} + [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 + -- Use op_distr to split the combined operation + 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 + -- Now we need to show that: + -- bigOpM (h1 k (g1 xy)) (zipWith f m1 m2) ≡ bigOpM h1 m1 + -- bigOpM (h2 k (g2 xy)) (zipWith f m1 m2) ≡ bigOpM h2 m2 + apply Monoid.op_proper + · -- Use fmap to relate zipWith composed with g1 to m1 + have h1_fmap := fmap (op := op) (unit := unit) g1 h1 (FiniteMap.zipWith f m1 m2) + apply Equiv.trans (Equiv.symm h1_fmap) + -- Use map_fmap_zipWith_r to show: map g1 (zipWith f m1 m2) = m1 + have heq := FiniteMapLaws.map_fmap_zipWith_r f g1 m1 m2 hg1 hdom + rw [heq] + · -- Similarly for g2 + have h2_fmap := fmap (op := op) (unit := unit) g2 h2 (FiniteMap.zipWith f m1 m2) + apply Equiv.trans (Equiv.symm h2_fmap) + -- Use map_fmap_zipWith_l to show: map g2 (zipWith f m1 m2) = m2 + have heq := FiniteMapLaws.map_fmap_zipWith_l f g2 m1 m2 hg2 hdom + rw [heq] + +/-- Corresponds to Rocq's `big_opM_sep_zip`. + Rocq proof: `intros. by apply big_opM_sep_zip_with.` -/ +theorem sep_zip {A : Type w} {B : Type w} + [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/BI/BigOp/BigAndMap.lean b/src/Iris/BI/BigOp/BigAndMap.lean index b7d5f4f8..ddffe0da 100644 --- a/src/Iris/BI/BigOp/BigAndMap.lean +++ b/src/Iris/BI/BigOp/BigAndMap.lean @@ -19,8 +19,8 @@ Rocq Iris: `iris/bi/big_op.v`, Section `and_map` -/ variable {PROP : Type _} [BI PROP] -variable {M : Type _} {K : Type _} {V : Type _} -variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] +variable {M : Type _ → Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap M K] [FiniteMapLaws M K] namespace BigAndM @@ -29,36 +29,36 @@ namespace BigAndM /-- Corresponds to `big_andM_empty` in Rocq Iris. -/ @[simp] theorem empty {Φ : K → V → PROP} : - ([∧map] k ↦ x ∈ (∅ : M), Φ k x) ⊣⊢ iprop(True) := by - simp only [bigAndM, map_to_list_empty, bigOpL] + ([∧map] k ↦ x ∈ (∅ : M V), Φ k x) ⊣⊢ iprop(True) := by + simp only [bigAndM, FiniteMapLaws.map_to_list_empty, bigOpL] exact .rfl /-- Corresponds to `big_andM_empty'` in Rocq Iris. -/ theorem empty' {P : PROP} {Φ : K → V → PROP} : - P ⊢ [∧map] k ↦ x ∈ (∅ : M), Φ k x := + P ⊢ [∧map] k ↦ x ∈ (∅ : M V), Φ k x := true_intro.trans empty.2 /-- Corresponds to `big_andM_singleton` in Rocq Iris. -/ theorem singleton {Φ : K → V → PROP} {k : K} {v : V} : - ([∧map] k' ↦ x ∈ ({[k := v]} : M), Φ k' x) ⊣⊢ Φ k v := by - have hget : get? (∅ : M) k = none := lookup_empty k - have hperm : (toList (FiniteMap.insert (∅ : M) k v)).Perm ((k, v) :: toList (∅ : M)) := - map_to_list_insert (∅ : M) k v hget - simp only [map_to_list_empty] at hperm + ([∧map] k' ↦ x ∈ ({[k := v]} : M V), Φ k' x) ⊣⊢ Φ k v := by + have hget : get? (∅ : M V) k = none := lookup_empty k + have hperm : (toList (FiniteMap.insert (∅ : M V) k v)).Perm ((k, v) :: toList (∅ : M V)) := + FiniteMapLaws.map_to_list_insert (∅ : M V) k v hget + simp only [FiniteMapLaws.map_to_list_empty] at hperm simp only [bigAndM, FiniteMap.singleton] - have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M) k v)) ≡ + have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M V) k v)) ≡ bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) [(k, v)] := BigOpL.perm (fun kv => Φ kv.1 kv.2) hperm simp only [bigOpL] at heq exact (equiv_iff.mp heq).trans ⟨and_elim_l, (and_intro .rfl true_intro)⟩ /-- Corresponds to `big_andM_insert` in Rocq Iris. -/ -theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem insert {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = none) : ([∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ Φ k v ∧ [∧map] k' ↦ x ∈ m, Φ k' x := by simp only [bigAndM] - have hperm := map_to_list_insert m k v h + have hperm := FiniteMapLaws.map_to_list_insert m k v h have hperm_eq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert m k v)) ≡ bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList m) := BigOpL.perm _ hperm @@ -66,22 +66,22 @@ theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} exact equiv_iff.mp hperm_eq /-- Corresponds to `big_andM_insert_delete` in Rocq Iris. -/ -theorem insert_delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} : +theorem insert_delete {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : ([∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ Φ k v ∧ [∧map] k' ↦ x ∈ delete m k, Φ k' x := by have hmap_eq := FiniteMapLaws.insert_delete_eq m k v simp only [bigAndM, ← hmap_eq] have hdelete : get? (delete m k) k = none := lookup_delete_eq m k - have hins := @insert PROP _ M K V _ _ _ Φ (delete m k) k v hdelete + have hins := insert (Φ := Φ) (m := delete m k) (k := k) (v := v) hdelete exact hins /-- Corresponds to `big_andM_delete` in Rocq Iris. Splits a big and over a map into the element at key `k` and the rest. -/ -theorem delete' {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem delete' {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∧map] k' ↦ x ∈ m, Φ k' x) ⊣⊢ Φ k v ∧ [∧map] k' ↦ x ∈ Std.delete m k, Φ k' x := by simp only [bigAndM] - have hperm := map_to_list_delete m k v h + have hperm := FiniteMapLaws.map_to_list_delete m k v h have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList m) ≡ bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList (Std.delete m k)) := BigOpL.perm _ hperm @@ -104,17 +104,17 @@ private theorem mono_list {Φ Ψ : K × V → PROP} {l : List (K × V)} · exact ih (fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)) /-- Corresponds to `big_andM_mono` in Rocq Iris. -/ -theorem mono {Φ Ψ : K → V → PROP} {m : M} +theorem mono {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Φ k v ⊢ Ψ k v) : ([∧map] k ↦ x ∈ m, Φ k x) ⊢ [∧map] k ↦ x ∈ m, Ψ k x := by simp only [bigAndM] apply mono_list intro kv hmem - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Corresponds to `big_andM_proper` in Rocq Iris. -/ -theorem proper {Φ Ψ : K → V → PROP} {m : M} +theorem proper {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Φ k v ≡ Ψ k v) : ([∧map] k ↦ x ∈ m, Φ k x) ≡ [∧map] k ↦ x ∈ m, Ψ k x := by simp only [bigAndM] @@ -123,17 +123,17 @@ theorem proper {Φ Ψ : K → V → PROP} {m : M} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Unconditional version of `proper`. No direct Rocq equivalent. -/ -theorem congr {Φ Ψ : K → V → PROP} {m : M} +theorem congr {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, Φ k v ≡ Ψ k v) : ([∧map] k ↦ x ∈ m, Φ k x) ≡ [∧map] k ↦ x ∈ m, Ψ k x := proper (fun k v _ => h k v) /-- Corresponds to `big_andM_ne` in Rocq Iris. -/ -theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} +theorem ne {Φ Ψ : K → V → PROP} {m : M V} {n : Nat} (h : ∀ k v, get? m k = some v → Φ k v ≡{n}≡ Ψ k v) : ([∧map] k ↦ x ∈ m, Φ k x) ≡{n}≡ [∧map] k ↦ x ∈ m, Ψ k x := by simp only [bigAndM] @@ -142,11 +142,11 @@ theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Corresponds to `big_andM_mono'` in Rocq Iris. -/ -theorem mono' {Φ Ψ : K → V → PROP} {m : M} +theorem mono' {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, Φ k v ⊢ Ψ k v) : ([∧map] k ↦ x ∈ m, Φ k x) ⊢ [∧map] k ↦ x ∈ m, Ψ k x := mono (fun k v _ => h k v) @@ -155,13 +155,13 @@ theorem mono' {Φ Ψ : K → V → PROP} {m : M} /-- Corresponds to `big_andM_empty_persistent` in Rocq Iris. -/ instance empty_persistent {Φ : K → V → PROP} : - Persistent ([∧map] k ↦ x ∈ (∅ : M), Φ k x) where + Persistent ([∧map] k ↦ x ∈ (∅ : M V), Φ k x) where persistent := by - simp only [bigAndM, map_to_list_empty, bigOpL] + simp only [bigAndM, FiniteMapLaws.map_to_list_empty, bigOpL] exact persistently_true.2 /-- Corresponds to `big_andM_persistent` in Rocq Iris (conditional version). -/ -theorem persistent_cond {Φ : K → V → PROP} {m : M} +theorem persistent_cond {Φ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Persistent (Φ k v)) : Persistent ([∧map] k ↦ x ∈ m, Φ k x) where persistent := by @@ -173,16 +173,16 @@ theorem persistent_cond {Φ : K → V → PROP} {m : M} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact (h kv.1 kv.2 hkv).persistent /-- Corresponds to `big_andM_persistent'` in Rocq Iris. -/ -instance persistent {Φ : K → V → PROP} {m : M} [∀ k v, Persistent (Φ k v)] : +instance persistent {Φ : K → V → PROP} {m : M V} [∀ k v, Persistent (Φ k v)] : Persistent ([∧map] k ↦ x ∈ m, Φ k x) := persistent_cond fun _ _ _ => inferInstance /-- BIAffine instance for bigAndM. -/ -instance affine {Φ : K → V → PROP} {m : M} [BIAffine PROP] : +instance affine {Φ : K → V → PROP} {m : M V} [BIAffine PROP] : Affine ([∧map] k ↦ x ∈ m, Φ k x) where affine := by simp only [bigAndM] @@ -193,19 +193,19 @@ instance affine {Φ : K → V → PROP} {m : M} [BIAffine PROP] : /-! ## Lookup Lemmas -/ /-- Corresponds to `big_andM_lookup` in Rocq Iris. -/ -theorem lookup {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem lookup {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∧map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v := (delete' h).1.trans and_elim_l /-- Corresponds to `big_andM_lookup_dom` in Rocq Iris. -/ -theorem lookup_dom {Φ : K → PROP} {m : M} {k : K} {v : V} +theorem lookup_dom {Φ : K → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : bigAndM (fun k' _ => Φ k') m ⊢ Φ k := lookup (Φ := fun k' _ => Φ k') h /-- Corresponds to `big_andM_insert_2` in Rocq Iris. -/ -theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : +theorem insert_2 {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : Φ k v ∧ ([∧map] k' ↦ x ∈ m, Φ k' x) ⊢ [∧map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x := by cases hm : get? m k with | none => @@ -216,26 +216,26 @@ theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : /-! ## Logical Operations -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_andM_and` in Rocq Iris. -/ -theorem and' {Φ Ψ : K → V → PROP} {m : M} : +theorem and' {Φ Ψ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x ∧ Ψ k x) ⊣⊢ ([∧map] k ↦ x ∈ m, Φ k x) ∧ [∧map] k ↦ x ∈ m, Ψ k x := by simp only [bigAndM] exact equiv_iff.mp (BigOpL.op_distr _ _ _) -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_andM_persistently` in Rocq Iris. -/ -theorem persistently {Φ : K → V → PROP} {m : M} : +theorem persistently {Φ : K → V → PROP} {m : M V} : iprop( [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, Φ k x := by simp only [bigAndM] exact equiv_iff.mp <| BigOpL.commute bi_persistently_and_homomorphism _ (toList m) /-! ## Map Conversion -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_andM_map_to_list` (implicit in Rocq Iris). -/ -theorem map_to_list {Φ : K → V → PROP} {m : M} : +theorem map_to_list {Φ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∧list] kv ∈ toList m, Φ kv.1 kv.2) := by simp only [bigAndM] exact .rfl @@ -244,16 +244,15 @@ theorem map_to_list {Φ : K → V → PROP} {m : M} : section MapTransformations -variable {M' : Type _} {V' : Type _} -variable [FiniteMap M' K V'] -variable [FiniteMapLawsExt M M' K V V'] +variable {V' : Type _} +variable [DecidableEq V'] /-- Corresponds to `big_andM_fmap` in Rocq Iris. -/ -theorem fmap {Φ : K → V' → PROP} {m : M} (f : V → V') : - ([∧map] k ↦ y ∈ FiniteMap.map (M' := M') f m, Φ k y) ⊣⊢ +theorem fmap {Φ : K → V' → PROP} {m : M V} (f : V → V') : + ([∧map] k ↦ y ∈ FiniteMap.map f m, Φ k y) ⊣⊢ [∧map] k ↦ y ∈ m, Φ k (f y) := by simp only [bigAndM] - refine equiv_iff.mp (BigOpL.perm _ (toList_map (K := K) (M' := M') m f)) |>.trans ?_ + refine equiv_iff.mp (BigOpL.perm _ (FiniteMapLaws.toList_map (K := K) m f)) |>.trans ?_ induction (toList m) with | nil => exact .rfl | cons kv kvs ih => @@ -264,7 +263,7 @@ end MapTransformations section FilterMapTransformations -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Helper lemma for omap: bigOpL over filterMapped list. -/ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) @@ -285,7 +284,7 @@ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ /-- Corresponds to `big_andM_omap` in Rocq Iris. -/ -theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V → Option V) : +theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : ([∧map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ [∧map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => iprop(True) := by simp only [bigAndM] @@ -293,7 +292,7 @@ theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V (omap_list_aux f (toList m)) /-- Corresponds to `big_andM_union` in Rocq Iris. -/ -theorem union [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m₁ m₂ : M} +theorem union [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m₁ m₂ : M V} (hdisj : m₁ ##ₘ m₂) : ([∧map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∧map] k ↦ y ∈ m₁, Φ k y) ∧ [∧map] k ↦ y ∈ m₂, Φ k y := by @@ -306,7 +305,7 @@ end FilterMapTransformations /-! ## Intro and Forall Lemmas -/ /-- Corresponds to `big_andM_intro` in Rocq Iris. -/ -theorem intro {P : PROP} {Φ : K → V → PROP} {m : M} +theorem intro {P : PROP} {Φ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → P ⊢ Φ k v) : P ⊢ [∧map] k ↦ x ∈ m, Φ k x := by simp only [bigAndM] @@ -316,10 +315,10 @@ theorem intro {P : PROP} {Φ : K → V → PROP} {m : M} | cons kv kvs ih => simp only [bigOpL] have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self - have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + have hget_kv := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem_kv refine and_intro (h kv.1 kv.2 hget_kv) ?_ have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => - (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + (FiniteMapLaws.elem_of_map_to_list m kv'.1 kv'.2).mp (hl ▸ List.mem_cons_of_mem _ hmem) clear ih hmem_kv hget_kv hl induction kvs with | nil => exact true_intro @@ -329,7 +328,7 @@ theorem intro {P : PROP} {Φ : K → V → PROP} {m : M} exact ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem) /-- Corresponds to `big_andM_forall` in Rocq Iris. -/ -theorem forall' {Φ : K → V → PROP} {m : M} : +theorem forall' {Φ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := by constructor · refine forall_intro fun k => forall_intro fun v => imp_intro' <| pure_elim_l fun hget => ?_ @@ -339,7 +338,7 @@ theorem forall' {Φ : K → V → PROP} {m : M} : (and_intro (pure_intro hget) .rfl).trans imp_elim_r /-- Corresponds to `big_andM_impl` in Rocq Iris. -/ -theorem impl {Φ Ψ : K → V → PROP} {m : M} : +theorem impl {Φ Ψ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x) ∧ (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v → Ψ k v)) ⊢ [∧map] k ↦ x ∈ m, Ψ k x := by refine intro fun k v hget => ?_ @@ -347,26 +346,22 @@ theorem impl {Φ Ψ : K → V → PROP} {m : M} : refine (and_mono .rfl ((and_intro (pure_intro hget) .rfl).trans imp_elim_r)).trans imp_elim_r /-- Corresponds to `big_andM_subseteq` in Rocq Iris. -/ -theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M} +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} (hsub : m₂ ⊆ m₁) : ([∧map] k ↦ x ∈ m₁, Φ k x) ⊢ [∧map] k ↦ x ∈ m₂, Φ k x := intro fun k v hget₂ => lookup (hsub k v hget₂) /-! ## Pure Lemmas -/ -/-- This is equivalent to Rocq Iris's `map_Forall`. -/ -def mapForall (φ : K → V → Prop) (m : M) : Prop := - ∀ k v, get? m k = some v → φ k v - /-- Corresponds to `big_andM_pure_1` in Rocq Iris. -/ -theorem pure_1 {φ : K → V → Prop} {m : M} : - ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜mapForall φ m⌝ : PROP) := by - simp only [bigAndM, mapForall] +theorem pure_1 {φ : K → V → Prop} {m : M V} : + ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜FiniteMap.map_Forall φ m⌝ : PROP) := by + simp only [bigAndM, FiniteMap.map_Forall] suffices h : ∀ l : List (K × V), bigOpL and iprop(True) (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l ⊢ iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) by refine (h (toList m)).trans <| pure_mono fun hlist k v hget => ?_ - have hmem : (k, v) ∈ toList m := (elem_of_map_to_list m k v).mp hget + have hmem : (k, v) ∈ toList m := (FiniteMapLaws.elem_of_map_to_list m k v).mpr hget exact hlist (k, v) hmem intro l induction l with @@ -382,14 +377,14 @@ theorem pure_1 {φ : K → V → Prop} {m : M} : | tail _ htail => exact hkvs kv' htail /-- Corresponds to `big_andM_pure_2` in Rocq Iris. -/ -theorem pure_2 {φ : K → V → Prop} {m : M} : - (⌜mapForall φ m⌝ : PROP) ⊢ ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) := by - simp only [bigAndM, mapForall] +theorem pure_2 {φ : K → V → Prop} {m : M V} : + (⌜FiniteMap.map_Forall φ m⌝ : PROP) ⊢ ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) := by + simp only [bigAndM, FiniteMap.map_Forall] suffices h : ∀ l : List (K × V), iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) ⊢ bigOpL and iprop(True) (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l by refine (pure_mono fun hmap kv hmem => ?_).trans (h (toList m)) - have hget : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hget : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact hmap kv.1 kv.2 hget intro l induction l with @@ -403,22 +398,22 @@ theorem pure_2 {φ : K → V → Prop} {m : M} : pure_and.2.trans (and_mono_r ih) /-- Corresponds to `big_andM_pure` in Rocq Iris. -/ -theorem pure' {φ : K → V → Prop} {m : M} : - ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜mapForall φ m⌝ : PROP) := +theorem pure' {φ : K → V → Prop} {m : M V} : + ([∧map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜FiniteMap.map_Forall φ m⌝ : PROP) := ⟨pure_1, pure_2⟩ /-! ## Later Lemmas -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_andM_later` in Rocq Iris. -/ -theorem later {Φ : K → V → PROP} {m : M} : +theorem later {Φ : K → V → PROP} {m : M V} : iprop(▷ [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷ Φ k x := by simp only [bigAndM] exact equiv_iff.mp <| BigOpL.commute bi_later_and_homomorphism _ (toList m) -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_andM_laterN` in Rocq Iris. -/ -theorem laterN {Φ : K → V → PROP} {m : M} {n : Nat} : +theorem laterN {Φ : K → V → PROP} {m : M V} {n : Nat} : iprop(▷^[n] [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷^[n] Φ k x := by induction n with | zero => exact .rfl @@ -426,7 +421,7 @@ theorem laterN {Φ : K → V → PROP} {m : M} {n : Nat} : /-! ## Filter Lemmas -/ -variable [FiniteMapLawsSelf M K V] +variable [FiniteMapLawsSelf M K] omit [DecidableEq K] in /-- Helper: bigOpL over filtered list. -/ @@ -448,7 +443,7 @@ private theorem filter_list_aux {Φ : K × V → PROP} (p : K × V → Bool) (l exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ /-- Corresponds to `big_andM_filter'` in Rocq Iris. -/ -theorem filter' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : +theorem filter' {Φ : K → V → PROP} {m : M V} (p : K → V → Bool) : ([∧map] k ↦ x ∈ FiniteMap.filter p m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, if p k x then Φ k x else iprop(True) := by simp only [bigAndM] @@ -460,7 +455,7 @@ theorem filter' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : exact filter_list_aux (fun kv => p kv.1 kv.2) (toList m) /-- Corresponds to `big_andM_filter` in Rocq Iris. -/ -theorem filter'' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : +theorem filter'' {Φ : K → V → PROP} {m : M V} (p : K → V → Bool) : ([∧map] k ↦ x ∈ FiniteMap.filter p m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, iprop(⌜p k x = true⌝ → Φ k x) := by have heq : ([∧map] k ↦ x ∈ m, if p k x then Φ k x else iprop(True)) ⊣⊢ @@ -483,15 +478,15 @@ theorem filter'' {Φ : K → V → PROP} {m : M} (p : K → V → Bool) : section KeyTransformations -variable {M' : Type _} {K' : Type _} +variable {M' : Type _ → Type _} {K' : Type _} variable [DecidableEq K'] -variable [FiniteMap M' K' V] -variable [FiniteMapLaws M' K' V] -variable [FiniteMapKmapLaws M M' K K' V] +variable [FiniteMap M' K'] +variable [FiniteMapLaws M' K'] +variable [FiniteMapKmapLaws M M' K K'] -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_andM_kmap` in Rocq Iris. -/ -theorem kmap {Φ : K' → V → PROP} {m : M} (f : K → K') (hinj : ∀ {x y}, f x = f y → x = y) : +theorem kmap {Φ : K' → V → PROP} {m : M V} (f : K → K') (hinj : ∀ {x y}, f x = f y → x = y) : ([∧map] k' ↦ y ∈ FiniteMap.kmap (M' := M') f m, Φ k' y) ⊣⊢ [∧map] k ↦ y ∈ m, Φ (f k) y := by simp only [bigAndM] @@ -508,16 +503,16 @@ end KeyTransformations section ListToMap -variable [FiniteMap M Nat V] -variable [FiniteMapLaws M Nat V] -variable [FiniteMapSeqLaws M V] +variable [FiniteMap M Nat] +variable [FiniteMapLaws M Nat] +variable [FiniteMapSeqLaws M] /-- Corresponds to `big_andM_map_seq` in Rocq Iris. -/ theorem map_seq {Φ : Nat → V → PROP} (start : Nat) (l : List V) : - ([∧map] k ↦ x ∈ (FiniteMap.map_seq start l : M), Φ k x) ⊣⊢ + ([∧map] k ↦ x ∈ (FiniteMap.map_seq start l : M V), Φ k x) ⊣⊢ ([∧list] i ↦ x ∈ l, Φ (start + i) x) := by simp only [bigAndM, bigAndL] - have h1 : bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M)) ≡ + have h1 : bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M V)) ≡ bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) := BigOpL.perm (fun kv => Φ kv.fst kv.snd) (toList_map_seq (M := M) start l) have h2 : bigOpL and iprop(True) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) ≡ diff --git a/src/Iris/BI/BigOp/BigOp.lean b/src/Iris/BI/BigOp/BigOp.lean index d1262453..23654a9b 100644 --- a/src/Iris/BI/BigOp/BigOp.lean +++ b/src/Iris/BI/BigOp/BigOp.lean @@ -89,14 +89,14 @@ section Map /-- Big separating conjunction over a map. `bigSepM Φ m` computes `∗_{k ↦ v ∈ m} Φ k v` -/ -abbrev bigSepM [BI PROP] {M : Type _} {K : Type _} {V : Type _} [FiniteMap M K V] - (Φ : K → V → PROP) (m : M) : PROP := +abbrev bigSepM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap M K] + (Φ : K → V → PROP) (m : M V) : PROP := bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) /-- Big conjunction over a map. `bigAndM Φ m` computes `∧_{k ↦ v ∈ m} Φ k v` -/ -abbrev bigAndM [BI PROP] {M : Type _} {K : Type _} {V : Type _} [FiniteMap M K V] - (Φ : K → V → PROP) (m : M) : PROP := +abbrev bigAndM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap M K] + (Φ : K → V → PROP) (m : M V) : PROP := bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList m) /-! ## Notation -/ diff --git a/src/Iris/BI/BigOp/BigSepList.lean b/src/Iris/BI/BigOp/BigSepList.lean index 68a5e3f6..c892d31a 100644 --- a/src/Iris/BI/BigOp/BigSepList.lean +++ b/src/Iris/BI/BigOp/BigSepList.lean @@ -704,8 +704,8 @@ theorem sepL {B : Type _} (Φ : Nat → A → Nat → B → PROP) (l₁ : List A exact sep_mono_r ih'.2 /-- Corresponds to `big_sepL_sepM` in Rocq Iris. -/ -theorem sepM {B : Type _} {M : Type _} {K : Type _} [FiniteMap M K B] - (Φ : Nat → A → K → B → PROP) (l : List A) (m : M) : +theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} [FiniteMap M K] + (Φ : Nat → A → K → B → PROP) (l : List A) (m : M B) : ([∗list] k↦x ∈ l, [∗map] k'↦y ∈ m, Φ k x k' y) ⊣⊢ ([∗map] k'↦y ∈ m, [∗list] k↦x ∈ l, Φ k x k' y) := by calc [∗list] k↦x ∈ l, [∗map] k'↦y ∈ m, Φ k x k' y diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index 63739fb0..3cc76a1b 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -23,8 +23,8 @@ open BIBase Rocq Iris: `iris/bi/big_op.v`, Section `sep_map` -/ variable {PROP : Type _} [BI PROP] -variable {M : Type _} {K : Type _} {V : Type _} -variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] +variable {M : Type _ → Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap M K] [FiniteMapLaws M K] namespace BigSepM @@ -33,36 +33,36 @@ namespace BigSepM /-- Corresponds to `big_sepM_empty` in Rocq Iris. -/ @[simp] theorem empty {Φ : K → V → PROP} : - ([∗map] k ↦ x ∈ (∅ : M), Φ k x) ⊣⊢ emp := by - simp only [bigSepM, map_to_list_empty, bigOpL] + ([∗map] k ↦ x ∈ (∅ : M V), Φ k x) ⊣⊢ emp := by + simp only [bigSepM, FiniteMapLaws.map_to_list_empty, bigOpL] exact .rfl /-- Corresponds to `big_sepM_empty'` in Rocq Iris. -/ theorem empty' {P : PROP} [Affine P] {Φ : K → V → PROP} : - P ⊢ [∗map] k ↦ x ∈ (∅ : M), Φ k x := + P ⊢ [∗map] k ↦ x ∈ (∅ : M V), Φ k x := Affine.affine.trans empty.2 /-- Corresponds to `big_sepM_singleton` in Rocq Iris. -/ theorem singleton {Φ : K → V → PROP} {k : K} {v : V} : - ([∗map] k' ↦ x ∈ ({[k := v]} : M), Φ k' x) ⊣⊢ Φ k v := by - have hget : get? (∅ : M) k = none := lookup_empty k - have hperm : (toList (FiniteMap.insert (∅ : M) k v)).Perm ((k, v) :: toList (∅ : M)) := - map_to_list_insert (∅ : M) k v hget - simp only [map_to_list_empty] at hperm + ([∗map] k' ↦ x ∈ ({[k := v]} : M V), Φ k' x) ⊣⊢ Φ k v := by + have hget : get? (∅ : M V) k = none := lookup_empty k + have hperm : (toList (FiniteMap.insert (∅ : M V) k v)).Perm ((k, v) :: toList (∅ : M V)) := + FiniteMapLaws.map_to_list_insert (∅ : M V) k v hget + simp only [FiniteMapLaws.map_to_list_empty] at hperm simp only [bigSepM, FiniteMap.singleton] - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M) k v)) ≡ + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M V) k v)) ≡ bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) [(k, v)] := BigOpL.perm (fun kv => Φ kv.1 kv.2) hperm simp only [bigOpL] at heq exact (equiv_iff.mp heq).trans ⟨sep_emp.1, sep_emp.2⟩ /-- Corresponds to `big_sepM_insert` in Rocq Iris. -/ -theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem insert {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = none) : ([∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ m, Φ k' x := by simp only [bigSepM] - have hperm := map_to_list_insert m k v h + have hperm := FiniteMapLaws.map_to_list_insert m k v h have hperm_eq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert m k v)) ≡ bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList m) := BigOpL.perm _ hperm @@ -70,21 +70,21 @@ theorem insert {Φ : K → V → PROP} {m : M} {k : K} {v : V} exact equiv_iff.mp hperm_eq /-- Corresponds to `big_sepM_insert_delete` in Rocq Iris. -/ -theorem insert_delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} : +theorem insert_delete {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : ([∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ Std.delete m k, Φ k' x := by have heq := FiniteMapLaws.insert_delete_eq m k v simp only [bigSepM, ← heq] have herase : get? (Std.delete m k) k = none := lookup_delete_eq m k - have hins := @insert PROP _ M K V _ _ _ Φ (Std.delete m k) k v herase + have hins := insert (Φ := Φ) (m := Std.delete m k) (k := k) (v := v) herase exact hins /-- Corresponds to `big_sepM_delete` in Rocq Iris. -/ -theorem delete {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem delete {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ Std.delete m k, Φ k' x := by simp only [bigSepM] - have hperm := map_to_list_delete m k v h + have hperm := FiniteMapLaws.map_to_list_delete m k v h have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) ≡ bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList (Std.delete m k)) := BigOpL.perm _ hperm @@ -107,17 +107,17 @@ private theorem mono_list {Φ Ψ : K × V → PROP} {l : List (K × V)} · exact ih (fun kv' hmem => h kv' (List.mem_cons_of_mem _ hmem)) /-- Corresponds to `big_sepM_mono` in Rocq Iris. -/ -theorem mono {Φ Ψ : K → V → PROP} {m : M} +theorem mono {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Φ k v ⊢ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ⊢ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] apply mono_list intro kv hmem - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Corresponds to `big_sepM_proper` in Rocq Iris. -/ -theorem proper {Φ Ψ : K → V → PROP} {m : M} +theorem proper {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Φ k v ≡ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ≡ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] @@ -126,17 +126,17 @@ theorem proper {Φ Ψ : K → V → PROP} {m : M} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Unconditional version of `proper`. No direct Rocq equivalent. -/ -theorem congr {Φ Ψ : K → V → PROP} {m : M} +theorem congr {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, Φ k v ≡ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ≡ [∗map] k ↦ x ∈ m, Ψ k x := proper (fun k v _ => h k v) /-- Corresponds to `big_sepM_ne` in Rocq Iris. -/ -theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} +theorem ne {Φ Ψ : K → V → PROP} {m : M V} {n : Nat} (h : ∀ k v, get? m k = some v → Φ k v ≡{n}≡ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ≡{n}≡ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] @@ -145,54 +145,37 @@ theorem ne {Φ Ψ : K → V → PROP} {m : M} {n : Nat} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact h kv.1 kv.2 hkv /-- Corresponds to `big_sepM_mono'` in Rocq Iris. -/ -theorem mono' {Φ Ψ : K → V → PROP} {m : M} +theorem mono' {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, Φ k v ⊢ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ⊢ [∗map] k ↦ x ∈ m, Ψ k x := mono (fun k v _ => h k v) /-- Corresponds to `big_sepM_flip_mono'` in Rocq Iris. -/ -theorem flip_mono' {Φ Ψ : K → V → PROP} {m : M} +theorem flip_mono' {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, Ψ k v ⊢ Φ k v) : ([∗map] k ↦ x ∈ m, Ψ k x) ⊢ [∗map] k ↦ x ∈ m, Φ k x := mono' h /-- Corresponds to `big_sepM_subseteq` in Rocq Iris. -/ -theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M} [FiniteMapLawsSelf M K V] [∀ k v, Affine (Φ k v)] +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} [FiniteMapLawsSelf M K] [∀ k v, Affine (Φ k v)] (h : m₂ ⊆ m₁) : - ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by - have heq := FiniteMap.map_difference_union m₁ m₂ h - have hdisj := FiniteMap.disjoint_difference_r m₁ m₂ - have hunion_perm := toList_union_disjoint m₂ (m₁ \ m₂) hdisj - rw [bigSepM, ← heq] - have heq_union : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (m₂ ∪ (m₁ \ m₂))) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m₂ ++ toList (m₁ \ m₂)) := - BigOpL.perm _ hunion_perm - refine (equiv_iff.mp heq_union).1.trans ?_ - have happ := BigOpL.append (op := sep (PROP := PROP)) (unit := emp) - (fun _ (kv : K × V) => Φ kv.1 kv.2) (toList m₂) (toList (m₁ \ m₂)) - refine (equiv_iff.mp happ).1.trans ?_ - haveI : Affine (bigOpL sep emp (fun n (kv : K × V) => Φ kv.1 kv.2) (toList (m₁ \ m₂))) := - ⟨BigOpL.closed (fun P => P ⊢ emp) (fun _ kv => Φ kv.1 kv.2) (toList (m₁ \ m₂)) - Entails.rfl - (fun _ _ h1 h2 => (sep_mono h1 h2).trans sep_emp.1) - (fun _ _ _ => Affine.affine)⟩ - exact sep_elim_l + ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by sorry /-! ## Typeclass Instances -/ /-- Corresponds to `big_sepM_empty_persistent` in Rocq Iris. -/ instance empty_persistent {Φ : K → V → PROP} : - Persistent ([∗map] k ↦ x ∈ (∅ : M), Φ k x) where + Persistent ([∗map] k ↦ x ∈ (∅ : M V), Φ k x) where persistent := by - simp only [bigSepM, map_to_list_empty, bigOpL] + simp only [bigSepM, FiniteMapLaws.map_to_list_empty, bigOpL] exact persistently_emp_2 /-- Corresponds to `big_sepM_persistent` in Rocq Iris (conditional version). -/ -theorem persistent_cond {Φ : K → V → PROP} {m : M} +theorem persistent_cond {Φ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Persistent (Φ k v)) : Persistent ([∗map] k ↦ x ∈ m, Φ k x) where persistent := by @@ -204,23 +187,23 @@ theorem persistent_cond {Φ : K → V → PROP} {m : M} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact (h kv.1 kv.2 hkv).persistent /-- Corresponds to `big_sepM_persistent'` in Rocq Iris. -/ -instance persistent {Φ : K → V → PROP} {m : M} [∀ k v, Persistent (Φ k v)] : +instance persistent {Φ : K → V → PROP} {m : M V} [∀ k v, Persistent (Φ k v)] : Persistent ([∗map] k ↦ x ∈ m, Φ k x) := persistent_cond fun _ _ _ => inferInstance /-- Corresponds to `big_sepM_empty_affine` in Rocq Iris. -/ instance empty_affine {Φ : K → V → PROP} : - Affine ([∗map] k ↦ x ∈ (∅ : M), Φ k x) where + Affine ([∗map] k ↦ x ∈ (∅ : M V), Φ k x) where affine := by - simp only [bigSepM, map_to_list_empty, bigOpL] + simp only [bigSepM, FiniteMapLaws.map_to_list_empty, bigOpL] exact Entails.rfl /-- Corresponds to `big_sepM_affine` in Rocq Iris (conditional version). -/ -theorem affine_cond {Φ : K → V → PROP} {m : M} +theorem affine_cond {Φ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Affine (Φ k v)) : Affine ([∗map] k ↦ x ∈ m, Φ k x) where affine := by @@ -232,39 +215,39 @@ theorem affine_cond {Φ : K → V → PROP} {m : M} have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem exact (h kv.1 kv.2 hkv).affine /-- Corresponds to `big_sepM_affine'` in Rocq Iris. -/ -instance affine {Φ : K → V → PROP} {m : M} [∀ k v, Affine (Φ k v)] : +instance affine {Φ : K → V → PROP} {m : M V} [∀ k v, Affine (Φ k v)] : Affine ([∗map] k ↦ x ∈ m, Φ k x) := affine_cond fun _ _ _ => inferInstance /-! ## Logical Operations -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_sep` in Rocq Iris. -/ -theorem sep' {Φ Ψ : K → V → PROP} {m : M} : +theorem sep' {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x ∗ Ψ k x) ⊣⊢ ([∗map] k ↦ x ∈ m, Φ k x) ∗ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] exact equiv_iff.mp (BigOpL.op_distr _ _ _) -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_sep_2` in Rocq Iris. -/ -theorem sep_2 {Φ Ψ : K → V → PROP} {m : M} : +theorem sep_2 {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ∗ ([∗map] k ↦ x ∈ m, Ψ k x) ⊣⊢ [∗map] k ↦ x ∈ m, Φ k x ∗ Ψ k x := sep'.symm /-- Corresponds to `big_sepM_and` in Rocq Iris (one direction only). -/ -theorem and' {Φ Ψ : K → V → PROP} {m : M} : +theorem and' {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x ∧ Ψ k x) ⊢ ([∗map] k ↦ x ∈ m, Φ k x) ∧ [∗map] k ↦ x ∈ m, Ψ k x := and_intro (mono' fun _ _ => and_elim_l) (mono' fun _ _ => and_elim_r) /-- Corresponds to `big_sepM_wand` in Rocq Iris. -/ -theorem wand {Φ Ψ : K → V → PROP} {m : M} : +theorem wand {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ⊢ ([∗map] k ↦ x ∈ m, Φ k x -∗ Ψ k x) -∗ [∗map] k ↦ x ∈ m, Ψ k x := wand_intro <| sep_2.1.trans (mono' fun _ _ => wand_elim_r) @@ -272,14 +255,14 @@ theorem wand {Φ Ψ : K → V → PROP} {m : M} : /-! ## Lookup Lemmas -/ /-- Corresponds to `big_sepM_lookup_acc` in Rocq Iris. -/ -theorem lookup_acc {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem lookup_acc {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v ∗ (Φ k v -∗ [∗map] k' ↦ x ∈ m, Φ k' x) := (delete h).1.trans (sep_mono_r (wand_intro' (delete h).2)) /-- Corresponds to `big_sepM_lookup` in Rocq Iris. -/ -theorem lookup {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem lookup {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : [TCOr (∀ j w, Affine (Φ j w)) (Absorbing (Φ k v))] → ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v @@ -287,7 +270,7 @@ theorem lookup {Φ : K → V → PROP} {m : M} {k : K} {v : V} | TCOr.r => (lookup_acc h).trans (sep_elim_l (P := Φ k v) (Q := iprop(Φ k v -∗ bigSepM Φ m))) /-- Corresponds to `big_sepM_lookup_dom` in Rocq Iris. -/ -theorem lookup_dom {Φ : K → PROP} {m : M} {k : K} +theorem lookup_dom {Φ : K → PROP} {m : M V} {k : K} (h : (get? m k).isSome) : [TCOr (∀ j, Affine (Φ j)) (Absorbing (Φ k))] → bigSepM (fun k' _ => Φ k') m ⊢ Φ k := by @@ -298,7 +281,7 @@ theorem lookup_dom {Φ : K → PROP} {m : M} {k : K} | TCOr.r => lookup (Φ := fun k' _ => Φ k') hv /-- Corresponds to `big_sepM_insert_acc` in Rocq Iris. -/ -theorem insert_acc {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem insert_acc {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v ∗ (∀ v', Φ k v' -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) := by @@ -313,7 +296,7 @@ theorem insert_acc {Φ : K → V → PROP} {m : M} {k : K} {v : V} exact wand_intro' (hins.2.trans hprop_eq.2) /-- Corresponds to `big_sepM_insert_2` in Rocq Iris. -/ -theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : +theorem insert_2 {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : [TCOr (∀ w, Affine (Φ k w)) (Absorbing (Φ k v))] → Φ k v ⊢ ([∗map] k' ↦ x ∈ m, Φ k' x) -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x | TCOr.l => by @@ -347,7 +330,7 @@ theorem insert_2 {Φ : K → V → PROP} {m : M} {k : K} {v : V} : exact hins.2.trans hprop_eq.2 /-- Corresponds to `big_sepM_insert_override` in Rocq Iris. -/ -theorem insert_override {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} +theorem insert_override {Φ : K → V → PROP} {m : M V} {k : K} {v v' : V} (hm : get? m k = some v) (heqv : Φ k v ⊣⊢ Φ k v') : ([∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) ⊣⊢ [∗map] k' ↦ x ∈ m, Φ k' x := by @@ -362,7 +345,7 @@ theorem insert_override {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} exact insert_delete.2 /-- Corresponds to `big_sepM_insert_override_1` in Rocq Iris. -/ -theorem insert_override_1 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} +theorem insert_override_1 {Φ : K → V → PROP} {m : M V} {k : K} {v v' : V} (hm : get? m k = some v) : ([∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x) ⊢ (Φ k v' -∗ Φ k v) -∗ [∗map] k' ↦ x ∈ m, Φ k' x := by @@ -377,7 +360,7 @@ theorem insert_override_1 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} exact (delete hm).2 /-- Corresponds to `big_sepM_insert_override_2` in Rocq Iris. -/ -theorem insert_override_2 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} +theorem insert_override_2 {Φ : K → V → PROP} {m : M V} {k : K} {v v' : V} (hm : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ (Φ k v -∗ Φ k v') -∗ [∗map] k' ↦ x ∈ FiniteMap.insert m k v', Φ k' x := by @@ -393,16 +376,16 @@ theorem insert_override_2 {Φ : K → V → PROP} {m : M} {k : K} {v v' : V} /-! ## Map Conversion -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_map_to_list` in Rocq Iris. -/ -theorem map_to_list {Φ : K → V → PROP} {m : M} : +theorem map_to_list {Φ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∗list] kv ∈ toList m, Φ kv.1 kv.2) := by simp only [bigSepM] exact .rfl /-! ## Persistently and Later -/ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Helper for persistently: induction on list. -/ private theorem persistently_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : iprop( bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ @@ -413,14 +396,14 @@ private theorem persistently_list {Φ : K × V → PROP} {l : List (K × V)} [BI simp only [bigOpL] exact persistently_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_persistently` in Rocq Iris. -/ -theorem persistently {Φ : K → V → PROP} {m : M} [BIAffine PROP] : +theorem persistently {Φ : K → V → PROP} {m : M V} [BIAffine PROP] : iprop( [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, Φ k x := by simp only [bigSepM] exact persistently_list -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Helper for later: induction on list. -/ private theorem later_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : iprop(▷ bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ @@ -431,14 +414,14 @@ private theorem later_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine simp only [bigOpL] exact later_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_later` in Rocq Iris. -/ -theorem later [BIAffine PROP] {Φ : K → V → PROP} {m : M} : +theorem later [BIAffine PROP] {Φ : K → V → PROP} {m : M V} : iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷ Φ k x := by simp only [bigSepM] exact later_list -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Helper for later_2: induction on list. -/ private theorem later_2_list {Φ : K × V → PROP} {l : List (K × V)} : bigOpL sep emp (fun _ kv => iprop(▷ Φ kv)) l ⊢ @@ -449,24 +432,24 @@ private theorem later_2_list {Φ : K × V → PROP} {l : List (K × V)} : simp only [bigOpL] exact (sep_mono_r ih).trans later_sep.2 -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_later_2` in Rocq Iris. -/ -theorem later_2 {Φ : K → V → PROP} {m : M} : +theorem later_2 {Φ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, ▷ Φ k x) ⊢ iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) := by simp only [bigSepM] exact later_2_list -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_laterN` in Rocq Iris. -/ -theorem laterN [BIAffine PROP] {Φ : K → V → PROP} {m : M} {n : Nat} : +theorem laterN [BIAffine PROP] {Φ : K → V → PROP} {m : M V} {n : Nat} : iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷^[n] Φ k x := by induction n with | zero => exact .rfl | succ k ih => exact (later_congr ih).trans later -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_laterN_2` in Rocq Iris. -/ -theorem laterN_2 {Φ : K → V → PROP} {m : M} {n : Nat} : +theorem laterN_2 {Φ : K → V → PROP} {m : M V} {n : Nat} : ([∗map] k ↦ x ∈ m, ▷^[n] Φ k x) ⊢ iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) := by induction n with | zero => exact .rfl @@ -476,18 +459,16 @@ theorem laterN_2 {Φ : K → V → PROP} {m : M} {n : Nat} : section MapTransformations -variable {M' : Type _} {V' : Type _} -variable [FiniteMap M' K V'] - -variable [FiniteMapLawsExt M M' K V V'] +variable {V' : Type _} +variable [DecidableEq V'] /-- Corresponds to `big_sepM_fmap` in Rocq Iris. -/ -theorem fmap {Φ : K → V' → PROP} {m : M} (f : V → V') : - ([∗map] k ↦ y ∈ FiniteMap.map (M' := M') f m, Φ k y) ⊣⊢ +theorem fmap {Φ : K → V' → PROP} {m : M V} (f : V → V') : + ([∗map] k ↦ y ∈ FiniteMap.map f m, Φ k y) ⊣⊢ [∗map] k ↦ y ∈ m, Φ k (f y) := by simp only [bigSepM] - have hperm := toList_map (K := K) (M' := M') m f - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.map (M' := M') f m)) ≡ + have hperm := FiniteMapLaws.toList_map (K := K) m f + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.map f m)) ≡ bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (kv.1, f kv.2))) := BigOpL.perm _ hperm refine equiv_iff.mp heq |>.trans ?_ @@ -502,7 +483,7 @@ end MapTransformations section FilterMapTransformations -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Helper lemma for omap: bigOpL over filterMapped list. -/ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) @@ -521,7 +502,7 @@ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ /-- Corresponds to `big_sepM_omap` in Rocq Iris. -/ -theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V → Option V) : +theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : ([∗map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ [∗map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => emp := by simp only [bigSepM] @@ -532,7 +513,7 @@ theorem omap [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m : M} (f : V exact equiv_iff.mp heq |>.trans (omap_list_aux f (toList m)) /-- Corresponds to `big_sepM_union` in Rocq Iris. -/ -theorem union [FiniteMapLawsSelf M K V] {Φ : K → V → PROP} {m₁ m₂ : M} +theorem union [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m₁ m₂ : M V} (hdisj : m₁ ##ₘ m₂) : ([∗map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∗map] k ↦ y ∈ m₁, Φ k y) ∗ [∗map] k ↦ y ∈ m₂, Φ k y := by @@ -551,15 +532,15 @@ end FilterMapTransformations /-- Corresponds to `big_sepM_list_to_map` in Rocq Iris. -/ theorem list_to_map {Φ : K → V → PROP} {l : List (K × V)} (hnodup : (l.map Prod.fst).Nodup) : - ([∗map] k ↦ x ∈ (ofList l : M), Φ k x) ⊣⊢ [∗list] kv ∈ l, Φ kv.1 kv.2 := by + ([∗map] k ↦ x ∈ (ofList l : M V), Φ k x) ⊣⊢ [∗list] kv ∈ l, Φ kv.1 kv.2 := by simp only [bigSepM] - exact equiv_iff.mp (BigOpL.perm _ (map_to_list_to_map l hnodup)) + exact equiv_iff.mp (BigOpL.perm _ (FiniteMapLaws.map_to_list_to_map l hnodup)) /-! ## Intro and Forall Lemmas -/ /-- Corresponds to `big_sepM_intro` in Rocq Iris. -/ -theorem intro {Φ : K → V → PROP} {m : M} : +theorem intro {Φ : K → V → PROP} {m : M V} : iprop(□ (∀ k v, ⌜get? m k = some v⌝ → Φ k v)) ⊢ [∗map] k ↦ x ∈ m, Φ k x := by simp only [bigSepM] generalize hl : toList m = l @@ -569,13 +550,13 @@ theorem intro {Φ : K → V → PROP} {m : M} : | cons kv kvs ih => simp only [bigOpL] have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self - have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + have hget_kv := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem_kv refine intuitionistically_sep_idem.2.trans <| sep_mono ?_ ?_ · refine intuitionistically_elim.trans ?_ exact (forall_elim kv.1).trans ((forall_elim kv.2).trans ((imp_mono_l (pure_mono fun _ => hget_kv)).trans true_imp.1)) · have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => - (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + (FiniteMapLaws.elem_of_map_to_list m kv'.1 kv'.2).mp (hl.symm ▸ List.mem_cons_of_mem _ hmem) clear ih hmem_kv hget_kv hl induction kvs with | nil => exact affinely_elim_emp @@ -588,7 +569,7 @@ theorem intro {Φ : K → V → PROP} {m : M} : · exact ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem) /-- Forward direction of `big_sepM_forall` in Rocq Iris. -/ -theorem forall_1' {Φ : K → V → PROP} {m : M} [BIAffine PROP] +theorem forall_1' {Φ : K → V → PROP} {m : M V} [BIAffine PROP] [∀ k v, Persistent (Φ k v)] : ([∗map] k ↦ x ∈ m, Φ k x) ⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := by refine forall_intro fun k => forall_intro fun v => imp_intro' <| pure_elim_l fun hget => ?_ @@ -597,7 +578,7 @@ theorem forall_1' {Φ : K → V → PROP} {m : M} [BIAffine PROP] sep_comm.1.trans <| persistently_absorb_r.trans persistently_elim /-- Backward direction of `big_sepM_forall` in Rocq Iris. -/ -theorem forall_2' {Φ : K → V → PROP} {m : M} [BIAffine PROP] +theorem forall_2' {Φ : K → V → PROP} {m : M V} [BIAffine PROP] [∀ k v, Persistent (Φ k v)] : (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v)) ⊢ [∗map] k ↦ x ∈ m, Φ k x := by simp only [bigSepM] @@ -607,12 +588,12 @@ theorem forall_2' {Φ : K → V → PROP} {m : M} [BIAffine PROP] | cons kv kvs ih => simp only [bigOpL] have hmem_kv : kv ∈ toList m := hl ▸ List.mem_cons_self - have hget_kv := (elem_of_map_to_list m kv.1 kv.2).mpr hmem_kv + have hget_kv := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem_kv have head_step : iprop(∀ k v, ⌜get? m k = some v⌝ → Φ k v) ⊢ Φ kv.1 kv.2 := (forall_elim kv.1).trans (forall_elim kv.2) |>.trans <| (and_intro (pure_intro hget_kv) .rfl).trans imp_elim_r have htail : ∀ kv', kv' ∈ kvs → get? m kv'.1 = some kv'.2 := fun kv' hmem => - (elem_of_map_to_list m kv'.1 kv'.2).mpr (hl ▸ List.mem_cons_of_mem _ hmem) + (FiniteMapLaws.elem_of_map_to_list m kv'.1 kv'.2).mp (hl.symm ▸ List.mem_cons_of_mem _ hmem) refine and_self.2.trans (and_mono_l head_step) |>.trans persistent_and_sep_1 |>.trans <| sep_mono_r ?_ clear ih head_step hmem_kv hget_kv hl @@ -628,13 +609,13 @@ theorem forall_2' {Φ : K → V → PROP} {m : M} [BIAffine PROP] sep_mono_r (ih' fun kv'' hmem => htail kv'' (List.mem_cons_of_mem _ hmem)) /-- Corresponds to `big_sepM_forall` in Rocq Iris. -/ -theorem forall' {Φ : K → V → PROP} {m : M} [BIAffine PROP] +theorem forall' {Φ : K → V → PROP} {m : M V} [BIAffine PROP] [∀ k v, Persistent (Φ k v)] : ([∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ ∀ k, ∀ v, iprop(⌜get? m k = some v⌝ → Φ k v) := ⟨forall_1', forall_2'⟩ /-- Corresponds to `big_sepM_impl` in Rocq Iris. -/ -theorem impl {Φ Ψ : K → V → PROP} {m : M} : +theorem impl {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ⊢ □ (∀ k v, iprop(⌜get? m k = some v⌝ → Φ k v -∗ Ψ k v)) -∗ [∗map] k ↦ x ∈ m, Ψ k x := by apply wand_intro @@ -643,9 +624,9 @@ theorem impl {Φ Ψ : K → V → PROP} {m : M} : refine (sep_mono_r h1).trans ?_ exact sep_2.1.trans (mono' fun _ _ => wand_elim_r) -omit [DecidableEq K] [FiniteMapLaws M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] in /-- Corresponds to `big_sepM_dup` in Rocq Iris. -/ -theorem dup {P : PROP} [Affine P] {m : M} : +theorem dup {P : PROP} [Affine P] {m : M V} : □ (P -∗ P ∗ P) ⊢ P -∗ [∗map] _k ↦ _x ∈ m, P := by simp only [bigSepM] apply wand_intro @@ -661,7 +642,7 @@ theorem dup {P : PROP} [Affine P] {m : M} : sep_assoc.2.trans <| (sep_mono_l ih).trans sep_comm.1 /-- Corresponds to `big_sepM_lookup_acc_impl` in Rocq Iris. -/ -theorem lookup_acc_impl {Φ : K → V → PROP} {m : M} {k : K} {v : V} +theorem lookup_acc_impl {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (hget : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊢ Φ k v ∗ ∀ (Ψ: K → V → PROP), □ (∀ k' v', iprop(⌜get? m k' = some v'⌝ → ⌜k' ≠ k⌝ → Φ k' v' -∗ Ψ k' v')) -∗ @@ -700,21 +681,15 @@ theorem lookup_acc_impl {Φ : K → V → PROP} {m : M} {k : K} {v : V} /-! ## Pure Lemmas -/ -/-- `mapForall φ m` means `φ k v` holds for all key-value pairs in `m`. - This is equivalent to Rocq Iris's `map_Forall`. -/ -def mapForall (φ : K → V → Prop) (m : M) : Prop := - ∀ k v, get? m k = some v → φ k v - /-- Corresponds to `big_sepM_pure_1` in Rocq Iris. -/ -theorem pure_1 {φ : K → V → Prop} {m : M} : - ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜mapForall φ m⌝ : PROP) := by - simp only [bigSepM, mapForall] +theorem pure_1 {φ : K → V → Prop} {m : M V} : + ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊢ (⌜FiniteMap.map_Forall φ m⌝ : PROP) := by + simp only [bigSepM] suffices h : ∀ l : List (K × V), bigOpL sep emp (fun _ (kv : K × V) => iprop(⌜φ kv.1 kv.2⌝)) l ⊢ iprop(⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) by - refine (h (toList m)).trans <| pure_mono fun hlist k v hget => ?_ - have hmem : (k, v) ∈ toList m := (elem_of_map_to_list m k v).mp hget - exact hlist (k, v) hmem + refine (h (toList m)).trans <| pure_mono fun hlist => ?_ + exact (FiniteMapLaws.map_Forall_to_list φ m).mpr hlist intro l induction l with | nil => @@ -729,15 +704,14 @@ theorem pure_1 {φ : K → V → Prop} {m : M} : | tail _ htail => exact hkvs kv' htail /-- Corresponds to `big_sepM_affinely_pure_2` in Rocq Iris. -/ -theorem affinely_pure_2 {φ : K → V → Prop} {m : M} : - iprop( ⌜mapForall φ m⌝) ⊢ ([∗map] k ↦ x ∈ m, ⌜φ k x⌝ : PROP) := by - simp only [bigSepM, mapForall] +theorem affinely_pure_2 {φ : K → V → Prop} {m : M V} : + iprop( ⌜FiniteMap.map_Forall φ m⌝) ⊢ ([∗map] k ↦ x ∈ m, ⌜φ k x⌝ : PROP) := by + simp only [bigSepM] suffices h : ∀ l : List (K × V), iprop( ⌜∀ kv, kv ∈ l → φ kv.1 kv.2⌝) ⊢ bigOpL sep emp (fun _ (kv : K × V) => iprop( ⌜φ kv.1 kv.2⌝)) l by - refine (affinely_mono <| pure_mono fun hmap kv hmem => ?_).trans (h (toList m)) - have hget : get? m kv.1 = some kv.2 := (elem_of_map_to_list m kv.1 kv.2).mpr hmem - exact hmap kv.1 kv.2 hget + refine (affinely_mono <| pure_mono fun hmap => ?_).trans (h (toList m)) + exact (FiniteMapLaws.map_Forall_to_list φ m).mp hmap intro l induction l with | nil => @@ -751,13 +725,13 @@ theorem affinely_pure_2 {φ : K → V → Prop} {m : M} : persistent_and_sep_1.trans (sep_mono_r ih) /-- Corresponds to `big_sepM_pure` in Rocq Iris. -/ -theorem pure' [BIAffine PROP] {φ : K → V → Prop} {m : M} : - ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜mapForall φ m⌝ : PROP) := +theorem pure' [BIAffine PROP] {φ : K → V → Prop} {m : M V} : + ([∗map] k ↦ x ∈ m, ⌜φ k x⌝) ⊣⊢ (⌜FiniteMap.map_Forall φ m⌝ : PROP) := ⟨pure_1, (affine_affinely _).2.trans <| affinely_pure_2.trans (mono' fun _ _ => affinely_elim)⟩ /-! ## Filter Lemmas -/ -variable [FiniteMapLawsSelf M K V] +variable [FiniteMapLawsSelf M K] omit [DecidableEq K] in /-- Helper: bigOpL over filtered list. -/ @@ -778,7 +752,7 @@ private theorem filter_list_aux (Φ : K × V → PROP) (φ : K × V → Prop) [ exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ /-- Corresponds to `big_sepM_filter'` in Rocq Iris. -/ -theorem filter' {Φ : K → V → PROP} {m : M} +theorem filter' {Φ : K → V → PROP} {m : M V} (φ : K × V → Prop) [∀ kv, Decidable (φ kv)] : ([∗map] k ↦ x ∈ FiniteMap.filter (fun k v => decide (φ (k, v))) m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, if decide (φ (k, x)) then Φ k x else emp := by @@ -793,7 +767,7 @@ theorem filter' {Φ : K → V → PROP} {m : M} exact filter_list_aux (fun kv => Φ kv.1 kv.2) φ (toList m) /-- Corresponds to `big_sepM_filter` in Rocq Iris. -/ -theorem filter [BIAffine PROP] {Φ : K → V → PROP} {m : M} +theorem filter [BIAffine PROP] {Φ : K → V → PROP} {m : M V} (φ : K × V → Prop) [∀ kv, Decidable (φ kv)] : ([∗map] k ↦ x ∈ FiniteMap.filter (fun k v => decide (φ (k, v))) m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, iprop(⌜φ (k, x)⌝ → Φ k x) := by @@ -828,9 +802,9 @@ theorem fnInsert_same {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : theorem fnInsert_ne {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) (h : k ≠ i) : fnInsert f i b k = f k := by simp [fnInsert, h] -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_fn_insert` in Rocq Iris. -/ -theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : M} {i : K} {x : V} {b : B} +theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : M V} {i : K} {x : V} {b : B} (h : get? m i = none) : ([∗map] k ↦ y ∈ FiniteMap.insert m i x, Ψ k y (fnInsert f i b k)) ⊣⊢ Ψ i x b ∗ [∗map] k ↦ y ∈ m, Ψ k y (f k) := by @@ -851,9 +825,9 @@ theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : exact OFE.Equiv.rfl exact hins.trans ⟨(sep_mono hhead.1 htail.1), (sep_mono hhead.2 htail.2)⟩ -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_fn_insert'` in Rocq Iris. -/ -theorem fn_insert' {Φ : K → PROP} {m : M} {i : K} {x : V} {P : PROP} +theorem fn_insert' {Φ : K → PROP} {m : M V} {i : K} {x : V} {P : PROP} (h : get? m i = none) : ([∗map] k ↦ _y ∈ FiniteMap.insert m i x, fnInsert Φ i P k) ⊣⊢ P ∗ [∗map] k ↦ _y ∈ m, Φ k := @@ -863,16 +837,16 @@ theorem fn_insert' {Φ : K → PROP} {m : M} {i : K} {x : V} {P : PROP} section MapZip -variable {M₁ : Type _} {M₂ : Type _} {V₁ : Type _} {V₂ : Type _} -variable [FiniteMap M₁ K V₁] [FiniteMapLaws M₁ K V₁] -variable [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] +variable {M₁ : Type _ → Type _} {M₂ : Type _ → Type _} {V₁ : Type _} {V₂ : Type _} +variable [FiniteMap M₁ K] [FiniteMapLaws M₁ K] +variable [FiniteMap M₂ K] [FiniteMapLaws M₂ K] -omit [FiniteMapLaws M₁ K V₁] [FiniteMapLaws M₂ K V₂] in +omit [FiniteMapLaws M₁ K] [FiniteMapLaws M₂ K] in /-- Corresponds to `big_sepM_sep_zip_with` in Rocq Iris. -/ -theorem sep_zip_with {C : Type _} {MZ : Type _} [FiniteMap MZ K C] [FiniteMapLaws MZ K C] +theorem sep_zip_with {C : Type _} {MZ : Type _ → Type _} [FiniteMap MZ K] [FiniteMapLaws MZ K] {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} {f : V₁ → V₂ → C} {g₁ : C → V₁} {g₂ : C → V₂} - {m₁ : M₁} {m₂ : M₂} {mz : MZ} + {m₁ : M₁ V₁} {m₂ : M₂ V₂} {mz : MZ C} (_hg₁ : ∀ x y, g₁ (f x y) = x) (_hg₂ : ∀ x y, g₂ (f x y) = y) (_hdom : ∀ k, (get? m₁ k).isSome ↔ (get? m₂ k).isSome) @@ -919,23 +893,22 @@ theorem sep_zip_with {C : Type _} {MZ : Type _} [FiniteMap MZ K C] [FiniteMapLaw hmap₂.trans heq₂.symm exact equiv_iff.mp (Monoid.op_proper h₁ h₂) -omit [FiniteMapLaws M₁ K V₁] [FiniteMapLaws M₂ K V₂] in +omit [FiniteMapLaws M₁ K] [FiniteMapLaws M₂ K] in /-- Corresponds to `big_sepM_sep_zip` in Rocq Iris. -/ -theorem sep_zip {MZ : Type _} [FiniteMap MZ K (V₁ × V₂)] [FiniteMapLaws MZ K (V₁ × V₂)] +theorem sep_zip [FiniteMap M₁ K] [FiniteMapLaws M₁ K] [FiniteMap M₂ K] [FiniteMapLaws M₂ K] {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} - {m₁ : M₁} {m₂ : M₂} + {m₁ : M₁ V₁} {m₂ : M₂ V₂} {mz : M₁ (V₁ × V₂)} (hdom : ∀ k, (get? m₁ k).isSome ↔ (get? m₂ k).isSome) - (hperm : (toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).Perm + (hperm : (toList mz).Perm ((toList m₁).filterMap (fun kv => match get? m₂ kv.1 with | some v₂ => some (kv.1, (kv.2, v₂)) | none => none))) - (hfmap₁ : (toList m₁).Perm ((toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).map + (hfmap₁ : (toList m₁).Perm ((toList mz).map (fun kv => (kv.1, kv.2.1)))) - (hfmap₂ : (toList m₂).Perm ((toList (FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂)).map + (hfmap₂ : (toList m₂).Perm ((toList mz).map (fun kv => (kv.1, kv.2.2)))) : - ([∗map] k ↦ xy ∈ FiniteMap.zip (M := M₁) (M' := M₂) (M'' := MZ) m₁ m₂, - Φ₁ k xy.1 ∗ Φ₂ k xy.2) ⊣⊢ + ([∗map] k ↦ xy ∈ mz, Φ₁ k xy.1 ∗ Φ₂ k xy.2) ⊣⊢ ([∗map] k ↦ x ∈ m₁, Φ₁ k x) ∗ [∗map] k ↦ y ∈ m₂, Φ₂ k y := sep_zip_with (f := Prod.mk) (g₁ := Prod.fst) (g₂ := Prod.snd) (fun _ _ => rfl) (fun _ _ => rfl) hdom hperm hfmap₁ hfmap₂ @@ -944,12 +917,12 @@ end MapZip /-! ## Advanced Impl Lemmas -/ -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_impl_strong` in Rocq Iris. Strong version of impl that tracks which keys are in m₂ vs only in m₁. -/ -theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} - [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] - {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M} {m₂ : M₂} : +theorem impl_strong [FiniteMapLawsSelf M K] {M₂ : Type _ → Type _} {V₂ : Type _} + [FiniteMap M₂ K] [FiniteMapLaws M₂ K] [DecidableEq V₂] + {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M V} {m₂ : M₂ V₂} : ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ □ (∀ k, ∀ y, (match get? m₁ k with | some x => Φ k x | none => emp) -∗ iprop(⌜get? m₂ k = some y⌝ → Ψ k y)) -∗ @@ -958,18 +931,18 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} apply wand_intro revert m₁ apply FiniteMapLaws.map_ind (M := M₂) (K := K) (V := V₂) (P := fun m₂ => - ∀ (m₁ : M), ([∗map] k ↦ x ∈ m₁, Φ k x) ∗ + ∀ (m₁ : M V), ([∗map] k ↦ x ∈ m₁, Φ k x) ∗ □ (∀ k y, (match get? m₁ k with | some x => Φ k x | none => emp) -∗ iprop(⌜get? m₂ k = some y⌝ → Ψ k y)) ⊢ ([∗map] k ↦ y ∈ m₂, Ψ k y) ∗ [∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? m₂ k).isNone)) m₁, Φ k x) · intro m₁ - have hfilter_perm : (toList (FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂) k).isNone)) m₁)).Perm + have hfilter_perm : (toList (FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂ V₂) k).isNone)) m₁)).Perm (toList m₁) := by - have hperm := @toList_filter M K V _ _ _ _ m₁ (fun k _ => decide ((get? (∅ : M₂) k).isNone)) + have hperm := toList_filter m₁ (fun k _ => decide ((get? (∅ : M₂ V₂) k).isNone)) rw [List.filter_eq_self.mpr (fun kv _ => by simp [lookup_empty])] at hperm exact hperm - have hfilter_equiv : ([∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂) k).isNone)) m₁, Φ k x) ⊣⊢ + have hfilter_equiv : ([∗map] k ↦ x ∈ FiniteMap.filter (fun k _ => decide ((get? (∅ : M₂ V₂) k).isNone)) m₁, Φ k x) ⊣⊢ ([∗map] k ↦ x ∈ m₁, Φ k x) := by simp only [bigSepM] exact equiv_iff.mp (BigOpL.perm (fun kv => Φ kv.1 kv.2) hfilter_perm) @@ -999,7 +972,7 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} FiniteMap.filter (fun k _ => decide ((get? m k).isNone)) m₁ := by simp only [FiniteMap.filter]; congr 1 apply List.filter_congr; intro ⟨j, v⟩ hjv - have hget : get? m₁ j = some v := (elem_of_map_to_list m₁ j v).mpr hjv + have hget : get? m₁ j = some v := (FiniteMapLaws.elem_of_map_to_list m₁ j v).mp hjv have hne : j ≠ i := by intro heq; rw [heq] at hget; exact Option.noConfusion (hm₁i ▸ hget) rw [lookup_insert_ne _ _ _ _ hne.symm] rw [hfilter_eq] @@ -1032,9 +1005,9 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} bigSepM (fun k x => Φ k x) (FiniteMap.filter (fun k _ => decide ((get? m k).isNone)) (Std.delete m₁ i)) := by simp only [bigSepM] - have hperm1 := @toList_filter M K V _ _ _ _ m₁ (fun k _ => decide ((get? (Std.insert m i y) k).isNone)) - have hperm2 := @toList_filter M K V _ _ _ _ (Std.delete m₁ i) (fun k _ => decide ((get? m k).isNone)) - have hdel_perm := map_to_list_delete m₁ i x hm₁i + have hperm1 := toList_filter m₁ (fun k _ => decide ((get? (Std.insert m i y) k).isNone)) + have hperm2 := toList_filter (Std.delete m₁ i) (fun k _ => decide ((get? m k).isNone)) + have hdel_perm := FiniteMapLaws.map_to_list_delete m₁ i x hm₁i have hpred1_i_false : decide ((get? (Std.insert m i y) i).isNone = true) = false := by simp only [lookup_insert_eq, Option.isNone_some, decide_eq_false_iff_not]; exact fun h => nomatch h have hpred_eq : ∀ k, k ≠ i → @@ -1049,7 +1022,7 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} ((toList (Std.delete m₁ i)).filter (fun kv => decide ((get? m kv.fst).isNone))) := by apply List.filter_congr; intro ⟨k, v⟩ hkv have hne : k ≠ i := by - intro heq; have hlookup := (elem_of_map_to_list (Std.delete m₁ i) k v).mpr hkv + intro heq; have hlookup := (FiniteMapLaws.elem_of_map_to_list (Std.delete m₁ i) k v).mp hkv rw [heq, lookup_delete_eq] at hlookup; exact Option.noConfusion hlookup exact hpred_eq k hne exact equiv_iff.mp (BigOpL.perm (Φ := fun (kv : K × V) => Φ kv.1 kv.2) @@ -1060,12 +1033,12 @@ theorem impl_strong [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} (sep_mono_r (sep_mono_r hweaken)).trans <| (sep_mono_r (IH (Std.delete m₁ i))).trans <| (sep_mono_r (sep_mono_r hfilter_equiv.2)).trans <| sep_assoc.2.trans (sep_mono_l hinsert_goal.2) -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_impl_dom_subseteq` in Rocq Iris. Specialized version when the domain of m₂ is a subset of the domain of m₁. -/ -theorem impl_dom_subseteq [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type _} - [FiniteMap M₂ K V₂] [FiniteMapLaws M₂ K V₂] - {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M} {m₂ : M₂} +theorem impl_dom_subseteq [FiniteMapLawsSelf M K] {M₂ : Type _ → Type _} {V₂ : Type _} + [FiniteMap M₂ K] [FiniteMapLaws M₂ K] [DecidableEq V₂] + {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M V} {m₂ : M₂ V₂} (_hdom : ∀ k, (get? m₂ k).isSome → (get? m₁ k).isSome) : ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ □ (∀ k x y, iprop(⌜get? m₁ k = some x⌝ → ⌜get? m₂ k = some y⌝ → Φ k x -∗ Ψ k y)) -∗ @@ -1095,30 +1068,30 @@ theorem impl_dom_subseteq [FiniteMapLawsSelf M K V] {M₂ : Type _} {V₂ : Type section Kmap -variable {K₂ : Type _} {M₂ : Type _} +variable {K₂ : Type _} {M₂ : Type _ → Type _} variable [DecidableEq K₂] -variable [FiniteMap M₂ K₂ V] [FiniteMapLaws M₂ K₂ V] +variable [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] /-- Key map: apply a function to all keys in a map. `kmap h m` has entries `(h k, v)` for each `(k, v)` in `m`. Requires `h` to be injective to preserve map semantics. -/ -def kmap (h : K → K₂) (m : M) : M₂ := +def kmap (h : K → K₂) (m : M V) : M₂ V := ofList ((toList m).map (fun kv => (h kv.1, kv.2))) -omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] - [DecidableEq K₂] [FiniteMapLaws M₂ K₂ V] in +omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_kmap` in Rocq Iris. Note: The Rocq proof uses `map_to_list_kmap` (which we encode as `hperm`) and `big_opL_fmap`. The `hinj` (injectivity) is needed in Rocq for `kmap` to be well-defined; here we take an explicit permutation witness instead. -/ -theorem kmap' {Φ : K₂ → V → PROP} {m : M} +theorem kmap' [DecidableEq K₂] [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] + {Φ : K₂ → V → PROP} {m : M V} (h : K → K₂) (_hinj : Function.Injective h) - (hperm : (toList (kmap (M₂ := M₂) h m)).Perm + (hperm : (toList (kmap h m : M₂ V)).Perm ((toList m).map (fun kv => (h kv.1, kv.2)))) : - ([∗map] k₂ ↦ y ∈ kmap (M₂ := M₂) h m, Φ k₂ y) ⊣⊢ + ([∗map] k₂ ↦ y ∈ (kmap h m : M₂ V), Φ k₂ y) ⊣⊢ [∗map] k₁ ↦ y ∈ m, Φ (h k₁) y := by simp only [bigSepM] - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (kmap (M₂ := M₂) h m)) ≡ + have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (kmap h m : M₂ V)) ≡ bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (h kv.1, kv.2))) := BigOpL.perm _ hperm refine equiv_iff.mp heq |>.trans ?_ @@ -1135,16 +1108,16 @@ end Kmap section ListToMap -variable [FiniteMap M Nat V] -variable [FiniteMapLaws M Nat V] -variable [FiniteMapSeqLaws M V] +variable [FiniteMap M Nat] +variable [FiniteMapLaws M Nat] +variable [FiniteMapSeqLaws M] /-- Corresponds to `big_sepM_map_seq` in Rocq Iris. -/ theorem map_seq {Φ : Nat → V → PROP} (start : Nat) (l : List V) : - ([∗map] k ↦ x ∈ (FiniteMap.map_seq start l : M), Φ k x) ⊣⊢ + ([∗map] k ↦ x ∈ (FiniteMap.map_seq start l : M V), Φ k x) ⊣⊢ ([∗list] i ↦ x ∈ l, Φ (start + i) x) := by simp only [bigSepM, bigSepL] - have h1 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M)) ≡ + have h1 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M V)) ≡ bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) := BigOpL.perm (fun kv => Φ kv.fst kv.snd) (toList_map_seq (M := M) start l) have h2 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) ≡ @@ -1159,11 +1132,11 @@ end ListToMap section DomainSet variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] -variable [FiniteMapLawsSelf M K V] +variable [FiniteMapLawsSelf M K] -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_dom` in Rocq Iris. -/ -theorem dom {Φ : K → PROP} (m : M) : +theorem dom {Φ : K → PROP} (m : M V) : ([∗map] k ↦ _v ∈ m, Φ k) ⊣⊢ ([∗set] k ∈ (domSet m : S), Φ k) := by induction m using @FiniteMapLaws.map_ind M K V _ _ _ with | hemp => @@ -1173,8 +1146,9 @@ theorem dom {Φ : K → PROP} (m : M) : have hk_not_in_dom : FiniteSet.mem k (domSet m : S) = false := by cases h : FiniteSet.mem k (domSet m : S) · rfl - · have ⟨v', hv⟩ := elem_of_domSet m k |>.mp h - rw [hk_not_in] at hv; cases hv + · have ⟨v', hv⟩ := elem_of_domSet m k |>.mpr h + rw [hk_not_in] at hv + cases hv have hinsert_eq : FiniteSet.insert k (domSet m : S) = FiniteSet.singleton k ∪ (domSet m : S) := by apply @FiniteSetLaws.ext S K _ _ intro x @@ -1204,49 +1178,95 @@ theorem dom {Φ : K → PROP} (m : M) : · have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := FiniteSetLaws.mem_union _ _ _ |>.mpr (Or.inr hm) rw [this] - rw [domSet_insert, hinsert_eq] + have hdom_eq : (FiniteSet.singleton k ∪ (domSet m : S) : S) = (domSet (FiniteMap.insert m k v) : S) := by + apply @FiniteSetLaws.ext S K _ _ + intro x + by_cases hx : x = k + · rw [hx] + have h1 : FiniteSet.mem k (FiniteSet.singleton k ∪ (domSet m : S)) = true := by + apply FiniteSetLaws.mem_union _ _ _ |>.mpr + left + exact FiniteSetLaws.mem_singleton _ _ |>.mpr rfl + have h2 : FiniteSet.mem k (domSet (FiniteMap.insert m k v) : S) = true := + elem_of_domSet (FiniteMap.insert m k v) k |>.mp ⟨v, lookup_insert_eq m k v⟩ + rw [h1, h2] + · by_cases hm : FiniteSet.mem x (domSet m : S) = true + · have h1 : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := by + apply FiniteSetLaws.mem_union _ _ _ |>.mpr + right + exact hm + have h2 : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) = true := by + have ⟨v', hv⟩ := elem_of_domSet m x |>.mpr hm + have hne : k ≠ x := fun h => hx h.symm + have : get? (FiniteMap.insert m k v) x = some v' := + (lookup_insert_ne m k x v hne).symm ▸ hv + exact elem_of_domSet (FiniteMap.insert m k v) x |>.mp ⟨v', this⟩ + rw [h1, h2] + · have hs : FiniteSet.mem x (FiniteSet.singleton k : S) = false := by + cases h : FiniteSet.mem x (FiniteSet.singleton k : S) + · rfl + · have : x = k := FiniteSetLaws.mem_singleton _ _ |>.mp h + exact absurd this hx + have h1 : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = false := by + cases h : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) + · rfl + · have : FiniteSet.mem x (FiniteSet.singleton k : S) = true ∨ FiniteSet.mem x (domSet m : S) = true := + FiniteSetLaws.mem_union _ _ _ |>.mp h + cases this with + | inl h' => rw [h'] at hs; cases hs + | inr h' => exact absurd h' hm + have h2 : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) = false := by + cases h : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) + · rfl + · have ⟨v', hv'⟩ := elem_of_domSet (FiniteMap.insert m k v) x |>.mpr h + have hne : k ≠ x := fun h => hx h.symm + rw [lookup_insert_ne m k x v hne] at hv' + have : FiniteSet.mem x (domSet m : S) = true := + elem_of_domSet m x |>.mp ⟨v', hv'⟩ + exact absurd this hm + rw [h1, h2] calc ([∗map] k' ↦ _v ∈ FiniteMap.insert m k v, Φ k') ⊣⊢ Φ k ∗ ([∗map] k' ↦ _v ∈ m, Φ k') := insert hk_not_in _ ⊣⊢ Φ k ∗ ([∗set] k' ∈ (domSet m : S), Φ k') := ⟨sep_mono_r IH.1, sep_mono_r IH.2⟩ _ ⊣⊢ ([∗set] k' ∈ FiniteSet.singleton k ∪ (domSet m : S), Φ k') := (BigSepS.insert hk_not_in_dom).symm + _ ⊣⊢ ([∗set] k' ∈ (domSet (FiniteMap.insert m k v) : S), Φ k') := by rw [hdom_eq]; exact .rfl -omit [FiniteMapLawsSelf M K V] in +omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_gset_to_gmap` in Rocq Iris. -/ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : - ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ⊣⊢ ([∗set] k ∈ X, Φ k c) := by - have hlookup : ∀ k v, get? (ofSet c X : M) k = some v → v = c := by + ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k a) ⊣⊢ ([∗set] k ∈ X, Φ k c) := by + have hlookup : ∀ k v, get? (ofSet c X : M V) k = some v → v = c := by intro k v hv - simp only [ofSet, elem_of_list_to_map] at hv - have : (k, v) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := - list_lookup_some_mem k v _ hv - have : (k, v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := - List.mem_reverse.mp this - rw [List.mem_map] at this - obtain ⟨x, _, heq⟩ := this + -- Use elem_of_list_to_map_2 to get membership from lookup + have hmem : (k, v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by + simp only [ofSet] at hv + exact FiniteMapLaws.elem_of_list_to_map_2 _ _ _ hv + rw [List.mem_map] at hmem + obtain ⟨x, _, heq⟩ := hmem simp at heq exact heq.2.symm - have h1 : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ≡ - ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) := by + have h1 : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k a) ≡ + ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k c) := by apply proper intro k v hv have : v = c := hlookup k v hv rw [this] - have h2 : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) ⊣⊢ - ([∗set] k ∈ (domSet (ofSet c X : M) : S), Φ k c) := dom _ - have h3 : (domSet (ofSet c X : M) : S) = X := domSet_ofSet c X + have h2 : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k c) ⊣⊢ + ([∗set] k ∈ (domSet (ofSet c X : M V) : S), Φ k c) := dom _ + have h3 : (domSet (ofSet c X : M V) : S) = X := domSet_ofSet c X rw [h3] at h2 - have h1' : ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k a) ⊣⊢ - ([∗map] k ↦ a ∈ (ofSet c X : M), Φ k c) := BI.equiv_iff.mp h1 + have h1' : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k a) ⊣⊢ + ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k c) := BI.equiv_iff.mp h1 exact BiEntails.trans h1' h2 end DomainSet /-! ## Commuting Lemmas -/ -omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_sepL` in Rocq Iris. -/ -theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M) (l : List B) : +theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M V) (l : List B) : ([∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y) ⊣⊢ ([∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y) := by calc [∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y @@ -1257,11 +1277,11 @@ theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M) (l : Lis _ ⊣⊢ [∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y := equiv_iff.mp <| BigSepL.congr fun k' y => .rfl -omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_sepM` in Rocq Iris. -/ -theorem sepM {M₂ : Type _} {K₂ : Type _} {V₂ : Type _} - [DecidableEq K₂] [FiniteMap M₂ K₂ V₂] [FiniteMapLaws M₂ K₂ V₂] - (Φ : K → V → K₂ → V₂ → PROP) (m₁ : M) (m₂ : M₂) : +theorem sepM {M₂ : Type _ → Type _} {K₂ : Type _} {V₂ : Type _} + [DecidableEq K₂] [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] + (Φ : K → V → K₂ → V₂ → PROP) (m₁ : M V) (m₂ : M₂ V₂) : ([∗map] k₁↦x₁ ∈ m₁, [∗map] k₂↦x₂ ∈ m₂, Φ k₁ x₁ k₂ x₂) ⊣⊢ ([∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂) := by calc [∗map] k₁↦x₁ ∈ m₁, [∗map] k₂↦x₂ ∈ m₂, Φ k₁ x₁ k₂ x₂ @@ -1277,11 +1297,11 @@ theorem sepM {M₂ : Type _} {K₂ : Type _} {V₂ : Type _} _ ⊣⊢ [∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂ := equiv_iff.mp <| BigSepL.congr fun _ kv₂ => .rfl -omit [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] in +omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_sepS` in Rocq Iris. -/ theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] - (Φ : K → V → B → PROP) (m : M) (X : S) : + (Φ : K → V → B → PROP) (m : M V) (X : S) : ([∗map] k↦x ∈ m, [∗set] y ∈ X, Φ k x y) ⊣⊢ ([∗set] y ∈ X, [∗map] k↦x ∈ m, Φ k x y) := by calc [∗map] k↦x ∈ m, [∗set] y ∈ X, Φ k x y diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean index 808139a5..2a12bd06 100644 --- a/src/Iris/BI/BigOp/BigSepSet.lean +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -941,9 +941,9 @@ theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSe omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sepM` in Rocq Iris. -/ -theorem sepM {B : Type _} {M : Type _} {K : Type _} - [DecidableEq K] [FiniteMap M K B] [FiniteMapLaws M K B] - (Φ : A → K → B → PROP) (X : S) (m : M) : +theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} + [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] + (Φ : A → K → B → PROP) (X : S) (m : M B) : ([∗set] x ∈ X, [∗map] k↦y ∈ m, Φ x k y) ⊣⊢ ([∗map] k↦y ∈ m, [∗set] x ∈ X, Φ x k y) := by calc [∗set] x ∈ X, [∗map] k↦y ∈ m, Φ x k y diff --git a/src/Iris/Std/FiniteMap.lean b/src/Iris/Std/FiniteMap.lean index 4ed384b5..7fc67edf 100644 --- a/src/Iris/Std/FiniteMap.lean +++ b/src/Iris/Std/FiniteMap.lean @@ -4,6 +4,8 @@ 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`. @@ -26,72 +28,70 @@ namespace Iris.Std The type `M` represents a finite map from keys of type `K` to values of type `V`. This corresponds to Rocq's `FinMap` class from stdpp. -/ -class FiniteMap (M : Type u) (K : outParam (Type v)) (V : outParam (Type w)) where +class FiniteMap (M : Type u → Type _) (K : outParam (Type v)) where /-- Lookup a key in the map, returning `none` if not present. Corresponds to Rocq's `lookup` (notation `!!`). -/ - get? : M → K → Option V + get? : M V → K → Option V /-- Insert or update a key-value pair. Corresponds to Rocq's `insert` (notation `<[i:=x]>`). -/ - insert : M → K → V → M + insert : M V → K → V → M V /-- Remove a key from the map. Corresponds to Rocq's `delete`. -/ - delete : M → K → M + delete : M V → K → M V /-- The empty map. -/ - empty : M + empty : M V /-- Convert the map to a list of key-value pairs. Corresponds to Rocq's `map_to_list`. -/ - toList : M → List (K × V) + 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 + 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 _} : (K → V → A → A) → A → M V → A -export FiniteMap (get? insert delete toList ofList) +export FiniteMap (get? insert delete toList ofList fold) namespace FiniteMap -variable {M : Type u} {K : Type v} {V : Type w} [FiniteMap M K V] +variable {M : Type u → Type _} {K : Type v} [FiniteMap M K] {V : Type _} /-- Empty map instance for `∅` notation. -/ -instance : EmptyCollection M := ⟨empty⟩ +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 := insert ∅ k v +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) : M := +def union (m₁ m₂ : M V) : M V:= (toList m₁).foldl (fun acc (k, v) => insert acc k v) m₂ -instance : Union M := ⟨union⟩ - -/-- The domain of a map as a predicate on keys. -/ -def dom (m : M) : K → Prop := fun k => (get? m k).isSome - -/-- The domain of a map as a decidable predicate (requires decidable equality on Option V). -/ -def domDec (m : M) [DecidableEq V] : K → Bool := fun k => (get? m k).isSome +instance : Union (M V):= ⟨union⟩ /-- Two maps have disjoint domains. Corresponds to Rocq's `map_disjoint` (notation `##ₘ`). -/ -def Disjoint (m₁ m₂ : M) : Prop := ∀ k, ¬((get? m₁ k).isSome ∧ (get? m₂ k).isSome) +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` (notation `⊆`). Rocq's `map_subseteq_spec` states: `m1 ⊆ m2 ↔ ∀ i x, m1 !! i = Some x → m2 !! i = Some x` -/ -def Submap (m₁ m₂ : M) : Prop := ∀ k v, get? m₁ k = some v → get? m₂ k = some v +def Submap (m₁ m₂ : M V) : Prop := ∀ k v, get? m₁ k = some v → get? m₂ k = some v -instance : HasSubset M := ⟨Submap⟩ +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') [FiniteMap M' K V'] : M → 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 → M := +def filterMap (f : V → Option V) : M V → M V := fun m => ofList ((toList m).filterMap (fun (k, v) => (f v).map (k, ·))) /-- Alias for `filterMap` to match Rocq's naming. -/ @@ -99,333 +99,414 @@ abbrev omap := @filterMap /-- Filter entries by a predicate on key-value pairs. Corresponds to Rocq's `filter`. -/ -def filter (φ : K → V → Bool) : M → M := +def filter (φ : K → V → Bool) : M V → M V := fun m => ofList ((toList m).filter (fun (k, v) => φ k v)) -/-- Zip two maps: combine values at matching keys. +/-- Zip two maps with a combining function. Corresponds to Rocq's `map_zip_with`. -/ -def zip [FiniteMap M' K V'] [FiniteMap M'' K (V × V')] (m₁ : M) (m₂ : M') : M'' := +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, (v, v')) + | 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) (k : K) : Prop := (get? m k).isSome +def Mem (m : M V) (k : K) : Prop := (get? m k).isSome /-- Difference: remove all keys in `m₂` from `m₁`. `m₁ ∖ m₂` contains entries `(k, v)` where `k ∈ m₁` but `k ∉ m₂`. Corresponds to Rocq's `map_difference` (notation `∖`). -/ -def difference (m₁ m₂ : M) : M := +def difference (m₁ m₂ : M V) : M V := ofList ((toList m₁).filter (fun (k, _) => (get? m₂ k).isNone)) -instance : SDiff M := ⟨difference⟩ +instance : SDiff (M V) := ⟨difference⟩ /-- Transform keys of a map using an injective function. Given `f : K → K'`, `kmap f m` transforms a map with keys of type `K` into a map with keys of type `K'`. Corresponds to Rocq's `kmap`. -/ -def kmap {M' : Type u'} {K' : Type v'} [FiniteMap M' K' V] (f : K → K') (m : M) : M' := +def kmap {M' : Type _ → _} {K' : Type v'} [FiniteMap M' K'] (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`. `map_seq start [v₀, v₁, v₂, ...]` creates a map `{start ↦ v₀, start+1 ↦ v₁, start+2 ↦ v₂, ...}`. Corresponds to Rocq's `map_seq`. -/ -def map_seq [FiniteMap M Nat V] (start : Nat) (l : List V) : M := +def map_seq [FiniteMap M Nat] (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. + `firstKey m i` holds if there exists a value `x` such that `(i, x)` is the head of `toList m`. + 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 map_Forall (P : K → V → Prop) (m : M V) : Prop := + ∀ k v, get? m k = some v → P k v + end FiniteMap /-- Membership instance for finite maps: `k ∈ m` means the key `k` is in the map `m`. -/ -instance {M : Type u} {K : Type v} {V : Type w} [inst : FiniteMap M K V] : Membership K M := - ⟨fun (m : M) (k : K) => (inst.get? m k).isSome⟩ +instance {M : Type u → Type _} {K : Type v} [inst : FiniteMap M K] : Membership K (M V) := + ⟨fun (m : M V) (k : K) => (inst.get? m k).isSome⟩ /-- Laws that a finite map implementation must satisfy. Corresponds to Rocq's `FinMap` class axioms. -/ -class FiniteMapLaws (M : Type u) (K : Type v) (V : Type w) - [DecidableEq K] [FiniteMap M K V] where - /-- Map extensionality: two maps with the same lookups are equal. - Corresponds to Rocq's `map_eq`. -/ - map_eq : ∀ (m₁ m₂ : M), (∀ i, get? m₁ i = get? m₂ i) → m₁ = m₂ - /-- Looking up in an empty map returns `none`. - Corresponds to Rocq's `lookup_empty`. -/ - lookup_empty : ∀ k, get? (∅ : M) k = none - /-- Looking up the key just inserted returns that value. - Corresponds to Rocq's `lookup_insert_eq`. -/ - lookup_insert_eq : ∀ (m : M) k v, get? (insert m k v) k = some v - /-- Looking up a different key after insert returns the original value. - Corresponds to Rocq's `lookup_insert_ne`. -/ - lookup_insert_ne : ∀ (m : M) k k' v, k ≠ k' → get? (insert m k v) k' = get? m k' - /-- Deleting a key makes lookup return `none`. - Corresponds to Rocq's `lookup_delete_eq`. -/ - lookup_delete_eq : ∀ (m : M) k, get? (delete m k) k = none - /-- Deleting a different key doesn't affect lookup. - Corresponds to Rocq's `lookup_delete_ne`. -/ - lookup_delete_ne : ∀ (m : M) k k', k ≠ k' → get? (delete m k) k' = get? m k' - /-- `toList` and `ofList` are inverses (up to permutation and deduplication). - Corresponds to Rocq's `elem_of_list_to_map`. -/ - elem_of_list_to_map : ∀ (l : List (K × V)) k, - get? (ofList l : M) k = l.reverse.lookup k - /-- Empty map has empty toList. - Corresponds to Rocq's `map_to_list_empty`. -/ - map_to_list_empty : toList (∅ : M) = [] - /-- toList of insert (when key not present) is cons. - Corresponds to Rocq's `map_to_list_insert`. -/ - map_to_list_insert : ∀ (m : M) k v, get? m k = none → - (toList (insert m k v)).Perm ((k, v) :: toList m) - /-- toList lookup agrees with get?. - Corresponds to Rocq's `elem_of_map_to_list`. -/ - elem_of_map_to_list : ∀ (m : M) k v, get? m k = some v ↔ (k, v) ∈ toList m - /-- toList has no duplicate keys. - Corresponds to Rocq's `NoDup_map_to_list`. -/ - NoDup_map_to_list : ∀ (m : M), (toList m).map Prod.fst |>.Nodup - /-- toList of delete (when key is present) removes the key-value pair. - For `m !! k = some v`, `toList (delete m k)` is a permutation of `toList m` with `(k, v)` removed. - Corresponds to Rocq's `map_to_list_delete`. -/ - map_to_list_delete : ∀ (m : M) k v, get? m k = some v → - (toList m).Perm ((k, v) :: toList (delete m k)) - /-- `toList` and `ofList` roundtrip is a permutation (when keys are unique). - Corresponds to Rocq's `map_to_list_to_map`. -/ - map_to_list_to_map : ∀ (l : List (K × V)), (l.map Prod.fst).Nodup → - (toList (ofList l : M)).Perm l - /-- Lookup returns `none` iff the key is not in the domain. - Corresponds to Rocq's `not_elem_of_dom`. -/ - lookup_None_dom : ∀ (m : M) k, get? m k = none ↔ ¬FiniteMap.dom m k - /-- Lookup returns `some` iff the key is in the domain. - Corresponds to Rocq's `elem_of_dom`. -/ - lookup_Some_dom : ∀ (m : M) k, (∃ v, get? m k = some v) ↔ FiniteMap.dom m k - -/-- Extended laws for finite maps with value type transformations. -/ -class FiniteMapLawsExt (M : Type u) (M' : Type u') (K : Type v) (V : Type w) (V' : Type w') - [DecidableEq K] [FiniteMap M K V] [FiniteMap M' K V'] [FiniteMapLaws M K V] where - /-- toList of map (fmap) is related to mapping over toList. - `toList (map f m)` is a permutation of `(toList m).map (fun (k, v) => (k, f v))` -/ - toList_map : ∀ (m : M) (f : V → V'), - (toList (FiniteMap.map (M := M) (M' := M') f m)).Perm - ((toList m).map (fun kv => (kv.1, f kv.2))) +class FiniteMapLaws (M : Type u → Type _) (K : Type _) + [DecidableEq K] [FiniteMap M K] where + /-- Corresponds to Rocq's `map_eq`. -/ + map_eq : ∀ (m₁ m₂ : M V), (∀ i, get? m₁ i = get? m₂ i) → m₁ = m₂ + /-- Corresponds to Rocq's `lookup_empty`. -/ + lookup_empty : ∀ k, get? (∅ : M V) k = none + /-- Corresponds to Rocq's `lookup_insert_eq`. -/ + lookup_insert_eq : ∀ (m : M V) k v, get? (insert m k v) k = some v + /-- Corresponds to Rocq's `lookup_insert_ne`. -/ + lookup_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`. -/ + lookup_delete_eq : ∀ (m : M V) k, get? (delete m k) k = none + /-- Corresponds to Rocq's `lookup_delete_ne`. -/ + lookup_delete_ne : ∀ (m : M V) k k', k ≠ k' → get? (delete m k) k' = get? m k' + /-- Corresponds to Rocq's `lookup_union`. -/ + lookup_union : ∀ (m₁ m₂ : M V) k, + get? (m₁ ∪ m₂) k = (get? m₁ k).orElse (fun _ => get? m₂ k) + /-- Corresponds to Rocq's `lookup_difference`. -/ + lookup_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 + /-- Folding over the empty map returns the initial accumulator. + Corresponds to Rocq's `map_fold_empty`. -/ + fold_empty : ∀ {A : Type u'} (f : K → V → A → A) (b : A), + fold f b (∅ : M V) = b + fold_fmap_ind (P : M V → Prop) : + P ∅ → + (∀ i x m, + get? m i = none → + (∀ A' B (f : K → A' → B → B) (g : V → A') b x', + fold f b (insert ((FiniteMap.map g m)) i x') = f i x' (fold f b (FiniteMap.map g m))) → + P m → + P (insert m i x)) → + ∀ m, P m + /-- Self-referential extended laws (for filterMap, filter on the same type). -/ -class FiniteMapLawsSelf (M : Type u) (K : Type v) (V : Type w) - [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] where +class FiniteMapLawsSelf (M : Type u → _) (K : Type v) + [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] where /-- toList of filterMap (omap) is related to filterMap over toList. -/ - toList_filterMap : ∀ (m : M) (f : V → Option V), + 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) (φ : K → V → Bool), + toList_filter : ∀ (m : M V) (φ : K → V → Bool), (toList (FiniteMap.filter (M := M) φ m)).Perm ((toList m).filter (fun kv => φ kv.1 kv.2)) - /-- toList of union for disjoint maps. -/ - toList_union_disjoint : ∀ (m₁ m₂ : M), + /-- toList of union for disjoint maps. + Corresponds to Rocq's implicit behavior from `map_to_list_union`. -/ + toList_union_disjoint : ∀ (m₁ m₂ : M V), FiniteMap.Disjoint m₁ m₂ → (toList (m₁ ∪ m₂)).Perm (toList m₁ ++ toList m₂) /-- toList of difference is related to filter over toList. -/ - toList_difference : ∀ (m₁ m₂ : M), + toList_difference : ∀ (m₁ m₂ : M V), (toList (m₁ \ m₂)).Perm ((toList m₁).filter (fun kv => (get? m₂ kv.1).isNone)) - /-- Lookup in union: left-biased, m₁ takes precedence. - Corresponds to Rocq's `lookup_union`. -/ - lookup_union : ∀ (m₁ m₂ : M) k, - get? (m₁ ∪ m₂) k = (get? m₁ k).orElse (fun _ => get? m₂ k) - /-- Lookup in difference: key must be in m₁ but not in m₂. - Corresponds to Rocq's `lookup_difference`. -/ - lookup_difference : ∀ (m₁ m₂ : M) k, - get? (m₁ \ m₂) k = if (get? m₂ k).isSome then none else get? m₁ k /-- Laws for kmap operation (key transformation). -/ -class FiniteMapKmapLaws (M : Type u) (M' : Type u') (K : Type v) (K' : Type v') (V : Type w) - [DecidableEq K] [DecidableEq K'] [FiniteMap M K V] [FiniteMap M' K' V] - [FiniteMapLaws M K V] [FiniteMapLaws M' K' V] where +class FiniteMapKmapLaws (M : Type _ → _) (M' : Type _ → _) (K : Type _) (K' : Type _) + [DecidableEq K] [DecidableEq K'] [FiniteMap M K] [FiniteMap M' K'] + [FiniteMapLaws M K] [FiniteMapLaws M' K'] where /-- toList of kmap is related to mapping over toList. For an injective function `f : K → K'`, `toList (kmap f m)` is a permutation of `(toList m).map (fun (k, v) => (f k, v))`. Corresponds to Rocq's `map_to_list_kmap`. -/ - toList_kmap : ∀ (f : K → K') (m : M), + 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 (list to indexed map). -/ -class FiniteMapSeqLaws (M : Type u) (V : Type w) - [FiniteMap M Nat V] [FiniteMapLaws M Nat V] where +class FiniteMapSeqLaws (M : Type u → _) [FiniteMap M Nat] [FiniteMapLaws M Nat] where /-- toList of map_seq is related to zip with sequence. `toList (map_seq start l)` is a permutation of `zip (seq start (length l)) l`. Corresponds to Rocq's `map_to_list_seq`. -/ toList_map_seq : ∀ (start : Nat) (l : List V), - (toList (FiniteMap.map_seq start l : M)).Perm + (toList (FiniteMap.map_seq start l : M V)).Perm ((List.range' start l.length).zip l) -/-! ### Map-Set Conversion Laws +export FiniteMapLaws (map_eq lookup_empty lookup_insert_eq lookup_insert_ne lookup_delete_eq +lookup_delete_ne +ofList_nil ofList_cons fold_empty fold_fmap_ind) -Note: Due to Lean 4's type class resolution limitations with dependent parameters, -the FiniteMapSetLaws class has been moved to a separate file or defined inline where needed. - -Key operations that connect FiniteMap and FiniteSet: -- `domSet m : S` - converts map domain to a finite set - Implementation: `FiniteSet.ofList ((toList m).map Prod.fst)` -- `ofSet c X : M` - creates map from set with all keys mapping to constant c - Implementation: `ofList ((FiniteSet.toList X).map (fun k => (k, c)))` - -These are defined directly in files that need them (e.g., BigSepMap.lean). --/ - -export FiniteMapLaws (map_eq lookup_empty lookup_insert_eq lookup_insert_ne lookup_delete_eq lookup_delete_ne elem_of_list_to_map map_to_list_empty map_to_list_insert elem_of_map_to_list NoDup_map_to_list map_to_list_delete map_to_list_to_map) - -export FiniteMapLawsExt (toList_map) -export FiniteMapLawsSelf (toList_filterMap toList_filter toList_union_disjoint toList_difference lookup_union lookup_difference) +export FiniteMapLawsSelf (toList_filterMap toList_filter toList_union_disjoint toList_difference) export FiniteMapKmapLaws (toList_kmap) export FiniteMapSeqLaws (toList_map_seq) namespace FiniteMapLaws -variable {M : Type u} {K : Type v} {V : Type w} -variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] +variable {M : Type _ → _} {K : Type v} {V : Type _} +variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] -/-- Alternative: lookup is insert then lookup for equal keys. - Corresponds to Rocq's `lookup_insert`. -/ -theorem lookup_insert (m : M) (k k' : K) (v : V) : +/-- Auxiliary lemma: if get? (ofList l) k = some v, then (k, v) ∈ l -/ +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, lookup_empty] at h + | cons kv kvs ih => + rw [ofList_cons] at h + by_cases heq : kv.1 = k + · -- Case: kv.1 = k, so kv = (k, kv.2) + -- After insertion, lookup returns kv.2, so v = kv.2 + have eq_val : kv.2 = v := by + rw [heq, lookup_insert_eq] at h + exact Option.some.inj h + -- Therefore (k, v) = (kv.1, kv.2) = kv + have eq_kv : kv = (k, v) := by + ext + · exact heq + · exact eq_val + rw [← eq_kv] + exact List.Mem.head _ + · -- Case: kv.1 ≠ k + rw [lookup_insert_ne _ _ _ _ heq] at h + have := ih h + exact List.Mem.tail _ this + + +/-- Corresponds to Rocq's `lookup_insert`. -/ +theorem lookup_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, lookup_insert_eq] · next h => exact lookup_insert_ne m k k' v h -/-- Alternative: lookup after delete. - Corresponds to Rocq's `lookup_delete`. -/ -theorem lookup_delete (m : M) (k k' : K) : +/-- Corresponds to Rocq's `lookup_delete`. -/ +theorem lookup_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, lookup_delete_eq] · next h => exact lookup_delete_ne m k k' h -/-- Insert after delete has the same lookup behavior as direct insert. - Corresponds to Rocq's `insert_delete_eq`. -/ -theorem lookup_insert_delete (m : M) (k k' : K) (v : V) : +/-- Corresponds to Rocq's `insert_delete_eq`. -/ +theorem lookup_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, lookup_insert_eq] · simp [lookup_insert_ne _ _ _ _ h, lookup_delete_ne _ _ _ h] -/-- If a list of pairs has no duplicate keys, then it has no duplicate pairs. - This is because pairs with different keys are different, and there's at most one - pair per key. -/ -private theorem nodup_of_nodup_map_fst {α β : Type _} (l : List (α × β)) - (h : (l.map Prod.fst).Nodup) : l.Nodup := by +/-- Corresponds to Rocq's `map_to_list_spec`. + Rocq proof: + apply (map_fold_weak_ind (λ l m, + NoDup l ∧ ∀ i x, (i,x) ∈ l ↔ m !! i = Some x)); clear m. + { split; [constructor|]. intros i x. by rewrite elem_of_nil, lookup_empty. } + intros i x m l ? [IH1 IH2]. split; [constructor; naive_solver|]. + intros j y. rewrite elem_of_cons, IH2. + unfold insert, map_insert. destruct (decide (i = j)) as [->|]. + - rewrite lookup_partial_alter_eq. naive_solver. + - rewrite lookup_partial_alter_ne by done. naive_solver. +-/ +private theorem map_to_list_spec (m : M V) : + (toList m).Nodup ∧ (∀ i x, (i, x) ∈ toList m ↔ get? m i = some x) := by sorry + +/-- Corresponds to Rocq's `NoDup_map_to_list`. -/ +theorem NoDup_map_to_list (m : M V): (toList m).Nodup := by + apply (map_to_list_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.nodup_cons] + rw [List.map_cons, List.nodup_cons] + rw [List.nodup_cons] at hnodup 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 - -/-- For a Nodup list, erasing an element removes it completely. -/ -private theorem not_mem_erase_self_of_nodup {α : Type _} [DecidableEq α] (x : α) (l : List α) - (hnd : l.Nodup) : x ∉ l.erase x := by + · -- Show f x ∉ xs.map f + intro hx_in + rw [List.mem_map] at hx_in + obtain ⟨y, hy_mem, hy_eq⟩ := hx_in + -- f y = f x and y ∈ xs + 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 + · -- xs.map f is nodup + 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 - derived from NoDup_map_to_list. -/ +theorem NoDup_map_to_list_keys (m : M V): (toList m).map Prod.fst |>.Nodup := by + apply List.Nodup.map_of_injective (NoDup_map_to_list m) + -- Need to show: if a, b ∈ toList m and a.fst = b.fst, then a = b + intro ⟨k₁, v₁⟩ ⟨k₂, v₂⟩ h1 h2 heq + -- We have (k₁, v₁) and (k₂, v₂) both in toList m with k₁ = k₂ + simp at heq + -- By map_to_list_spec, both satisfy: get? m kᵢ = some vᵢ + have ⟨_, hmem⟩ := map_to_list_spec 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 + -- Since k₁ = k₂, we have get? m k₁ = get? m k₂ + rw [heq] at hv1 + -- So some v₁ = some v₂, hence v₁ = v₂ + rw [hv1] at hv2 + cases hv2 + -- Now we have k₁ = k₂ and v₁ = v₂, so the pairs are equal + ext <;> simp [heq] + +/-- Corresponds to Rocq's `elem_of_map_to_list`. -/ +theorem elem_of_map_to_list (m : M V) : ∀ k v, (k, v) ∈ toList m ↔ get? m k = some v := by + apply (map_to_list_spec m).2 + +/-- Corresponds to Rocq's `elem_of_list_to_map_2`. -/ +theorem elem_of_list_to_map_2 (l : List (K × V)) (i : K) (x : V) : + get? (ofList l : M V) i = some x → (i, x) ∈ l := 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. - This is the key lemma corresponding to Rocq's `NoDup_Permutation`. -/ -private 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 - -/-- Two maps with the same get? behavior have permutation-equivalent toLists. - Uses the fact that: - 1. `NoDup_map_to_list` ensures no duplicate keys (hence no duplicate pairs) - 2. `elem_of_map_to_list` + equal lookups implies same membership - 3. Two nodup lists with same membership are permutations -/ -theorem toList_perm_eq_of_get?_eq [DecidableEq V] {m₁ m₂ : M} + intro h + rw [ofList_nil, lookup_empty] at h + cases h + | cons kv l ih => + intro h + obtain ⟨k, v⟩ := kv + rw [ofList_cons] at h + rw [lookup_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 elem_of_list_to_map_1 (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, lookup_insert_eq] + | 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, lookup_insert_ne _ _ _ _ hne, this] + +/-- Corresponds to Rocq's `elem_of_list_to_map` +Rocq Proof: + split; auto using elem_of_list_to_map_1, elem_of_list_to_map_2. -/ +theorem elem_of_list_to_map (l : List (K × V)) i x (hnodup : (l.map Prod.fst).Nodup): + (i,x) ∈ l ↔ get? (ofList l : M V) i = some x := by sorry + +/-- Corresponds to Rocq's `list_to_map_inj`. -/ +theorem list_to_map_inj [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 := Iris.Std.nodup_of_nodup_map_fst l1 hnodup1 + have hnodup2' : l2.Nodup := Iris.Std.nodup_of_nodup_map_fst l2 hnodup2 + haveI : DecidableEq (K × V) := inferInstance + apply Iris.Std.perm_of_nodup_of_mem_iff hnodup1' hnodup2' + intro ⟨i, x⟩ + rw [elem_of_list_to_map (M := M) (K := K) l1 i x hnodup1, + elem_of_list_to_map (M := M) (K := K) l2 i x hnodup2] + rw [heq] + +/-- Coresponds to Rocq's `list_to_map_to_list` -/ +theorem list_to_map_to_list (m : M V) : + ofList (toList m) = m := by + apply map_eq (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 := + (elem_of_list_to_map (M := M) (K := K) (toList m) i val (NoDup_map_to_list_keys m)).mpr heq' + have : get? m i = some val := (elem_of_map_to_list m i val).mp hmem + rw [heq] at this + exact Option.noConfusion this + · rename_i val + have hmem : (i, val) ∈ toList m := (elem_of_map_to_list m i val).mpr heq + have : get? (ofList (toList m) : M V) i = some val := + (elem_of_list_to_map (M := M) (K := K) (toList m) i val (NoDup_map_to_list_keys m)).mp hmem + rw [this] + + /-- Corresponds to Rocq's `map_to_list_to_map`. -/ + theorem map_to_list_to_map [DecidableEq V] : ∀ (l : List (K × V)), (l.map Prod.fst).Nodup → + (toList (ofList l : M V)).Perm l := by + intro l hnodup + apply list_to_map_inj (M := M) (K:=K) + · exact NoDup_map_to_list_keys (M := M) (K := K) (V := V) (ofList l) + · exact hnodup + rw [list_to_map_to_list] + +/-- Two maps with the same get? behavior have permutation-equivalent toLists. -/ +theorem toList_perm_eq_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_of_nodup_map_fst _ (NoDup_map_to_list (M := M) (K := K) (V := V) m₁) - have hnodup₂ := nodup_of_nodup_map_fst _ (NoDup_map_to_list (M := M) (K := K) (V := V) m₂) + have hnodup₁ := NoDup_map_to_list (M := M) (K := K) (V := V) m₁ + have hnodup₂ := NoDup_map_to_list (M := M) (K := K) (V := V) m₂ have hmem : ∀ kv, kv ∈ toList m₁ ↔ kv ∈ toList m₂ := by - intro kv - simp only [← elem_of_map_to_list (M := M) (K := K) (V := V), h] - exact perm_of_nodup_of_mem_iff hnodup₁ hnodup₂ hmem + intro ⟨k, v⟩ + rw [elem_of_map_to_list m₁ k v, elem_of_map_to_list m₂ k v, h] + exact Iris.Std.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_perm [DecidableEq V] (m : M) (k : K) (v : V) : +theorem toList_insert_delete_perm [DecidableEq V] (m : M V) (k : K) (v : V) : (toList (insert m k v)).Perm (toList (insert (delete m k) k v)) := toList_perm_eq_of_get?_eq (fun k' => (lookup_insert_delete m k k' v).symm) /-- Singleton lookup for equal keys. Corresponds to Rocq's `lookup_singleton_eq`. -/ theorem lookup_singleton_eq (k : K) (v : V) : - get? (FiniteMap.singleton k v : M) k = some v := by + get? (FiniteMap.singleton k v : M V) k = some v := by simp [FiniteMap.singleton, lookup_insert_eq] /-- Singleton lookup for different keys. Corresponds to Rocq's `lookup_singleton_ne`. -/ theorem lookup_singleton_ne (k k' : K) (v : V) (h : k ≠ k') : - get? (FiniteMap.singleton k v : M) k' = none := by + get? (FiniteMap.singleton k v : M V) k' = none := by simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ h, lookup_empty] /-- Singleton lookup general case. Corresponds to Rocq's `lookup_singleton`. -/ theorem lookup_singleton (k k' : K) (v : V) : - get? (FiniteMap.singleton k v : M) k' = if k = k' then some v else none := by + get? (FiniteMap.singleton k v : M V) k' = if k = k' then some v else none := by split · next h => rw [h, lookup_singleton_eq] · next h => exact lookup_singleton_ne k k' v h /-- Insert is idempotent for the same key-value. Corresponds to Rocq's `insert_insert_eq`. -/ -theorem insert_insert_eq (m : M) (k : K) (v v' : V) : - get? (insert (insert m k v) k v') = get? (insert m k v' : M) := by +theorem insert_insert_eq (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, lookup_insert_eq] @@ -434,105 +515,73 @@ theorem insert_insert_eq (m : M) (k : K) (v v' : V) : /-- Deleting from empty is empty. Corresponds to Rocq's `delete_empty`. -/ theorem delete_empty (k : K) : - get? (delete (∅ : M) k) = get? (∅ : M) := by + get? (delete (∅ : M V) k) = get? (∅ : M V) := by funext k' by_cases h : k = k' · simp [h, lookup_delete_eq, lookup_empty] · simp [lookup_delete_ne _ _ _ h, lookup_empty] -/-- The domain of an empty map is empty. -/ -theorem dom_empty : FiniteMap.dom (∅ : M) = fun _ => False := by - funext k - simp [FiniteMap.dom, lookup_empty] - -/-- The domain after insert includes the inserted key. -/ -theorem dom_insert (m : M) (k : K) (v : V) : - FiniteMap.dom (insert m k v) k := by - simp [FiniteMap.dom, lookup_insert_eq] - -/-- Key is not in domain iff lookup returns none. - Corresponds to Rocq's `not_elem_of_dom`. -/ -theorem not_elem_of_dom (m : M) (k : K) : - ¬FiniteMap.dom m k ↔ get? m k = none := by - simp only [FiniteMap.dom, Option.not_isSome] - apply (lookup_None_dom m k).symm - -/-- Empty is a submap of everything. - Corresponds to Rocq's `map_empty_subseteq`. -/ -theorem map_empty_subseteq (m : M) : (∅ : M) ⊆ m := by +/-- Corresponds to Rocq's `map_empty_subseteq`. -/ +theorem map_empty_subseteq (m : M V) : (∅ : M V) ⊆ m := by intro k v h simp [lookup_empty] at h -/-- Empty is disjoint from everything. - Corresponds to Rocq's `map_disjoint_empty_l`. -/ -theorem map_disjoint_empty_l (m : M) : FiniteMap.Disjoint (∅ : M) m := by +/-- Corresponds to Rocq's `map_disjoint_empty_l`. -/ +theorem map_disjoint_empty_l (m : M V) : FiniteMap.Disjoint (∅ : M V) m := by intro k ⟨h₁, _⟩ simp [lookup_empty] at h₁ -/-- Characterization of lookup after insert returning Some. - Corresponds to Rocq's `lookup_insert_Some`. -/ -theorem lookup_insert_Some (m : M) (i j : K) (x y : V) : +/-- Corresponds to Rocq's `lookup_insert_Some`. -/ +theorem lookup_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 [lookup_insert] split <;> simp_all -/-- Characterization of lookup after insert being Some. - Corresponds to Rocq's `lookup_insert_is_Some`. -/ -theorem lookup_insert_is_Some (m : M) (i j : K) (x : V) : +/-- Corresponds to Rocq's `lookup_insert_is_Some`. -/ +theorem lookup_insert_is_Some (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 [lookup_insert] split <;> simp_all -/-- Characterization of lookup after insert returning None. - Corresponds to Rocq's `lookup_insert_None`. -/ -theorem lookup_insert_None (m : M) (i j : K) (x : V) : +/-- Corresponds to Rocq's `lookup_insert_None`. -/ +theorem lookup_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 [lookup_insert] split <;> simp_all -/-- If insert returns Some, we can extract the value. - Corresponds to Rocq's `lookup_insert_rev`. -/ -theorem lookup_insert_rev (m : M) (i : K) (x y : V) : +/-- Corresponds to Rocq's `lookup_insert_rev`. -/ +theorem lookup_insert_rev (m : M V) (i : K) (x y : V) : get? (insert m i x) i = some y → x = y := by simp [lookup_insert_eq] -/-- Insert is idempotent when the key already has that value. - Corresponds to Rocq's `insert_id`. -/ -theorem insert_id (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_id`. -/ +theorem insert_id (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 [lookup_insert_eq, h] · simp [lookup_insert_ne _ _ _ _ hk] -/-- Characterization of lookup after delete returning Some. - Corresponds to Rocq's `lookup_delete_Some`. -/ -theorem lookup_delete_Some (m : M) (i j : K) (y : V) : +/-- Corresponds to Rocq's `lookup_delete_Some`. -/ +theorem lookup_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 [lookup_delete] split <;> simp_all -/-- Characterization of lookup after delete being Some. - Corresponds to Rocq's `lookup_delete_is_Some`. -/ -theorem lookup_delete_is_Some (m : M) (i j : K) : +/-- Corresponds to Rocq's `lookup_delete_is_Some`. -/ +theorem lookup_delete_is_Some (m : M V) (i j : K) : (get? (delete m i) j).isSome ↔ i ≠ j ∧ (get? m j).isSome := by rw [lookup_delete] split <;> simp_all -/-- Characterization of lookup after delete returning None. - Corresponds to Rocq's `lookup_delete_None`. -/ -theorem lookup_delete_None (m : M) (i j : K) : +/-- Corresponds to Rocq's `lookup_delete_None`. -/ +theorem lookup_delete_None (m : M V) (i j : K) : get? (delete m i) j = none ↔ i = j ∨ get? m j = none := by rw [lookup_delete] split <;> simp_all --- ============================================================================ --- Induction Principles --- ============================================================================ - -/-- Insert then delete is identity when key wasn't present. - Corresponds to Rocq's `insert_delete_id`. -/ -theorem insert_delete_id (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_delete_id`. -/ +theorem insert_delete_id (m : M V) (i : K) (x : V) : get? m i = some x → insert (delete m i) i x = m := by intro h apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) @@ -542,9 +591,45 @@ theorem insert_delete_id (m : M) (i : K) (x : V) : simp [lookup_insert_eq, h] · simp [lookup_insert_ne _ _ _ _ hij, lookup_delete_ne _ _ _ hij] -/-- Delete then insert is identity. - Corresponds to Rocq's `delete_insert_id`. -/ -theorem delete_insert_id (m : M) (i : K) (x : V) : + + /-- Corresponds to Rocq's `map_to_list_empty`. + Rocq proof: + apply elem_of_nil_inv. intros [i x]. + rewrite elem_of_map_to_list. apply lookup_empty_Some. -/ +theorem map_to_list_empty : toList (∅ : M V) = [] := by sorry + + /-- Corresponds to Rocq's `map_to_list_insert`. -/ +theorem map_to_list_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 list_to_map_inj (M := M) (K := K) + · exact NoDup_map_to_list_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' := (elem_of_map_to_list m k' v').mp hmem + rw [hk_none] at this + exact Option.noConfusion this + · exact NoDup_map_to_list_keys m + · rw [list_to_map_to_list] + rw [ofList_cons, list_to_map_to_list] + +/-- Corresponds to Rocq's `map_to_list_delete`. -/ +theorem map_to_list_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_id m k v h] + rw [heq] + apply map_to_list_insert + exact lookup_delete_eq m k + + +/-- Corresponds to Rocq's `delete_insert_id`. -/ +theorem delete_insert_id (m : M V) (i : K) (x : V) : get? m i = none → delete (insert m i x) i = m := by intro h apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) @@ -555,7 +640,7 @@ theorem delete_insert_id (m : M) (i : K) (x : V) : · simp [lookup_delete_ne _ _ _ hij, lookup_insert_ne _ _ _ _ hij] /-- Empty map is characterized by all lookups returning none. -/ -theorem eq_empty_iff (m : M) : m = ∅ ↔ ∀ k, get? m k = none := by +theorem eq_empty_iff (m : M V) : m = ∅ ↔ ∀ k, get? m k = none := by constructor · intro h k rw [h, lookup_empty] @@ -564,65 +649,103 @@ theorem eq_empty_iff (m : M) : m = ∅ ↔ ∀ k, get? m k = none := by intro k rw [h, lookup_empty] -/-- Well-founded induction on maps using the strict submap relation. - This is the most basic induction principle. - Corresponds to Rocq's `map_ind`. -/ -theorem map_ind {P : M → Prop} +/-- Corresponds to Rocq's `map_ind`. -/ +theorem map_ind {P : M V → Prop} (hemp : P ∅) (hins : ∀ i x m, get? m i = none → P m → P (insert m i x)) - (m : M) : P m := by - -- We use well-founded induction on the length of toList - generalize hn : (toList m).length = n - induction n using Nat.strongRecOn generalizing m with - | ind n ih => - cases hn' : toList m with - | nil => - -- If toList is empty, the map must behave like empty - have h : ∀ k, get? m k = none := by - intro k - cases hget : get? m k with - | none => rfl - | some v => - have hmem := (elem_of_map_to_list m k v).mp hget - rw [hn'] at hmem - simp at hmem - -- By extensionality, m = ∅ - have heq : m = ∅ := eq_empty_iff m |>.mpr h - rw [heq] - exact hemp - | cons kv kvs => - -- m has at least one entry - obtain ⟨k, v⟩ := kv - -- delete k from m gives a smaller map - have hdel : get? m k = some v := by - have hmem : (k, v) ∈ (k, v) :: kvs := List.Mem.head _ - have hmem' : (k, v) ∈ toList m := hn' ▸ hmem - exact (elem_of_map_to_list m k v).mpr hmem' - -- toList (delete m k) has one fewer element - have hperm := map_to_list_delete m k v hdel - -- The deleted map has strictly smaller toList (by one element) - have hlen : (toList (delete m k)).length < n := by - have hperm_len := hperm.length_eq - simp only [List.length_cons] at hperm_len - omega - -- Apply IH to get P (delete m k) - have ih_del := ih (toList (delete m k)).length hlen (delete m k) rfl - -- Since get? (delete m k) k = none, we can apply hins - have hdel_none : get? (delete m k) k = none := lookup_delete_eq m k - -- We get P (insert (delete m k) k v) - have result := hins k v (delete m k) hdel_none ih_del - -- By extensionality, insert (delete m k) k v = m - have heq := insert_delete_id m k v hdel - rw [← heq] - exact result - --- ============================================================================ --- Insert and Delete Composition Lemmas --- ============================================================================ - -/-- Delete is idempotent. - Corresponds to Rocq's `delete_delete_eq`. -/ -theorem delete_delete_eq (m : M) (i : K) : + (m : M V) : P m := by + -- Use fold_fmap_ind to prove map_ind + apply fold_fmap_ind P hemp + intro i x m hi _ hPm + exact hins i x m hi hPm + +/-- Corresponds to Rocq's `map_fold_ind` +Rocq proof: + intros Hemp Hins m. + induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind; [done|]. + apply Hins; [done| |done]. intros B f b x'. + assert (m = id <$> m) as →. + { apply map_eq; intros j; by rewrite lookup_fmap, option_fmap_id. } + apply Hfold. + -/ +private theorem map_fold_ind (P : M V → Prop) : + P ∅ → + (∀ i x m, + get? m i = none → + (∀ B (f : K → V → B → B) b x', + fold f b (insert m i x') = f i x' (fold f b m)) → + P m → + P (insert m i x)) → + ∀ m, P m := by sorry + + +/-- Corresponds to Rocq's `map_fold_weak_ind`. -/ +theorem fold_weak_ind {B : Type u''} + (P : B → M V → Prop) (f : K → V → B → B) (b : B) + (hemp : P b ∅) + (hins : ∀ i x m r, get? m i = none → P r m → P (f i x r) (insert m i x)) + (m : M V) : P (fold f b m) m := by + sorry + +/-- Induction principle with first key constraint: prove properties about maps by induction, + where the inductive step requires that the inserted key becomes the first key. + + Corresponds to Rocq's `map_first_key_ind`. -/ +theorem map_first_key_ind (P : M V → Prop) + (hemp : P ∅) + (hins : ∀ i x m, get? m i = none → FiniteMap.firstKey (insert m i x) i → P m → P (insert m i x)) + (m : M V) : P m := by + sorry + +/-- Corresponds to Rocq's `map_fold_foldr` +Rocq proof: + unfold map_to_list. induction m as [|i x m ? Hfold IH] using map_fold_ind. + - by rewrite !map_fold_empty. + - by rewrite !Hfold, IH. +-/ +theorem fold_foldr (f : K → V → B → B) b (m : M V) : + fold f b m = List.foldr (fun ⟨k, v⟩ b => f k v b) b (toList m) := by sorry + + +/-- Corresponds to Rocq's `map_fold_fmap` +Rocq Proof: + induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind. + { by rewrite fmap_empty, !map_fold_empty. } + rewrite fmap_insert. rewrite <-(map_fmap_id m) at 2. rewrite !Hfold. + by rewrite IH, map_fmap_id. -/ +theorem fold_map (f : K → V' → B → B) (g : V → V') b (m : M V) : + fold f b (FiniteMap.map g m) = fold (fun i => f i ∘ g) b m := by sorry + + +/-- toList of map (fmap) is a permutation of mapping over toList. + This is a weaker form that we can prove without the fold-based infrastructure. + The stronger equality version (`toList_map_eq`) would require `fold_map` and `fold_foldr`. -/ +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] + -- toList (ofList ((toList m).map g)) is Perm to (toList m).map g + -- where g = fun kv => (kv.1, f kv.2) + apply map_to_list_to_map + -- Need to show: ((toList m).map g).map Prod.fst |>.Nodup + simp only [List.map_map] + show ((toList m).map (fun x => x.1)).Nodup + exact NoDup_map_to_list_keys m + +/-- toList of map (fmap) equals mapping over toList (equality version). + `toList (map f m) = (toList m).map (fun (k, v) => (k, f v))` + Corresponds to Rocq's `map_to_list_fmap` + Rocq proof: + unfold map_to_list. rewrite map_fold_fmap, !map_fold_foldr. + induction (map_to_list m) as [|[]]; f_equal/=; auto. + This requires `fold_map` and `fold_foldr` which are currently unimplemented. -/ +theorem toList_map_eq [DecidableEq V'] : ∀ (m : M V) (f : V → V'), + toList (FiniteMap.map f m) = + ((toList m).map (fun kv => (kv.1, f kv.2))) := by sorry + +/-- Corresponds to Rocq's `delete_delete_eq`. -/ +theorem delete_delete_eq (m : M V) (i : K) : delete (delete m i) i = delete m i := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro j @@ -631,17 +754,15 @@ theorem delete_delete_eq (m : M) (i : K) : simp [lookup_delete_eq] · simp [lookup_delete_ne _ _ _ hij] -/-- Delete of different keys commutes. - Corresponds to Rocq's `delete_delete`. -/ -theorem delete_delete (m : M) (i j : K) : +/-- Corresponds to Rocq's `delete_delete`. -/ +theorem delete_delete (m : M V) (i j : K) : delete (delete m i) j = delete (delete m j) i := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro k by_cases hik : i = k <;> by_cases hjk : j = k <;> simp [lookup_delete, *] -/-- Insert then delete of different keys commutes. - Corresponds to Rocq's `delete_insert_ne`. -/ -theorem delete_insert_ne (m : M) (i j : K) (x : V) : +/-- Corresponds to Rocq's `delete_insert_ne`. -/ +theorem delete_insert_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.map_eq (M := M) (K := K) (V := V) @@ -652,9 +773,8 @@ theorem delete_insert_ne (m : M) (i j : K) (x : V) : · subst hjk; simp [lookup_insert, lookup_delete, hik] · simp [lookup_insert, lookup_delete, hik, hjk] -/-- Delete then insert of same key gives just insert. - Corresponds to Rocq's `insert_delete_eq`. -/ -theorem insert_delete_eq (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_delete_eq`. -/ +theorem insert_delete_eq (m : M V) (i : K) (x : V) : insert (delete m i) i x = insert m i x := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro j @@ -663,9 +783,8 @@ theorem insert_delete_eq (m : M) (i : K) (x : V) : simp [lookup_insert_eq] · simp [lookup_insert_ne _ _ _ _ hij, lookup_delete_ne _ _ _ hij] -/-- Insert of different keys commutes. - Corresponds to Rocq's `insert_insert`. -/ -theorem insert_insert (m : M) (i j : K) (x y : V) : +/-- Corresponds to Rocq's `insert_insert`. -/ +theorem insert_insert (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.map_eq (M := M) (K := K) (V := V) @@ -676,9 +795,8 @@ theorem insert_insert (m : M) (i j : K) (x y : V) : · subst hjk; simp [lookup_insert, hik] · simp [lookup_insert, hik, hjk] -/-- Insert of same key keeps later value. - Corresponds to Rocq's `insert_insert_eq`. -/ -theorem insert_insert_eq' (m : M) (i : K) (x y : V) : +/-- Corresponds to Rocq's `insert_insert_eq`. -/ +theorem insert_insert_eq' (m : M V) (i : K) (x y : V) : insert (insert m i x) i y = insert m i y := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro j @@ -687,17 +805,15 @@ theorem insert_insert_eq' (m : M) (i : K) (x y : V) : simp [lookup_insert_eq] · simp [lookup_insert_ne _ _ _ _ hij] -/-- Deleting from empty is empty. - Corresponds to Rocq's `delete_empty`. -/ +/-- Corresponds to Rocq's `delete_empty`. -/ theorem delete_empty' (i : K) : - delete (∅ : M) i = ∅ := by + delete (∅ : M V) i = ∅ := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro j simp [lookup_delete, lookup_empty] -/-- Delete is identity when key not present. - Corresponds to Rocq's `delete_id`. -/ -theorem delete_id (m : M) (i : K) : +/-- Corresponds to Rocq's `delete_id`. -/ +theorem delete_id (m : M V) (i : K) : get? m i = none → delete m i = m := by intro h apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) @@ -707,9 +823,8 @@ theorem delete_id (m : M) (i : K) : simp [lookup_delete_eq, h] · simp [lookup_delete_ne _ _ _ hij] -/-- Insert is identity when key already has that value. - Corresponds to Rocq's `insert_id`. -/ -theorem insert_id' (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_id`. -/ +theorem insert_id' (m : M V) (i : K) (x : V) : get? m i = some x → insert m i x = m := by intro h apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) @@ -719,27 +834,20 @@ theorem insert_id' (m : M) (i : K) (x : V) : simp [lookup_insert_eq, h] · simp [lookup_insert_ne _ _ _ _ hij] -/-- Insert on empty gives singleton. - Corresponds to Rocq's `insert_empty`. -/ -theorem insert_empty [DecidableEq K] (i : K) (x : V) : - insert (∅ : M) i x = FiniteMap.singleton i x := by +/-- Corresponds to Rocq's `insert_empty`. -/ +theorem insert_empty (i : K) (x : V) : + insert (∅ : M V) i x = FiniteMap.singleton i x := by rfl -/-- Inserted map is non-empty. - Corresponds to Rocq's `insert_non_empty`. -/ -theorem insert_non_empty (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_non_empty`. -/ +theorem insert_non_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 [lookup_insert_eq] at this --- ============================================================================ --- Submap Lemmas --- ============================================================================ - -/-- Delete preserves submap. - Corresponds to Rocq's `delete_subseteq`. -/ -theorem delete_subseteq (m : M) (i : K) : delete m i ⊆ m := by +/-- Corresponds to Rocq's `delete_subseteq`. -/ +theorem delete_subseteq (m : M V) (i : K) : delete m i ⊆ m := by intro k v h by_cases hik : i = k · subst hik @@ -747,9 +855,8 @@ theorem delete_subseteq (m : M) (i : K) : delete m i ⊆ m := by · simp [lookup_delete_ne _ _ _ hik] at h exact h -/-- Delete of present key is strict submap (submap but not equal). - Corresponds to Rocq's `delete_subset`. -/ -theorem delete_subset (m : M) (i : K) (v : V) : +/-- Corresponds to Rocq's `delete_subset`. -/ +theorem delete_subset (m : M V) (i : K) (v : V) : get? m i = some v → delete m i ⊆ m ∧ delete m i ≠ m := by intro hi constructor @@ -758,9 +865,8 @@ theorem delete_subset (m : M) (i : K) (v : V) : have : get? (delete m i) i = get? m i := by rw [heq] simp [lookup_delete_eq, hi] at this -/-- Insert on non-present key gives superset. - Corresponds to Rocq's `insert_subseteq`. -/ -theorem insert_subseteq (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_subseteq`. -/ +theorem insert_subseteq (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 @@ -768,9 +874,8 @@ theorem insert_subseteq (m : M) (i : K) (x : V) : simp [hi] at hk · simp [lookup_insert_ne _ _ _ _ hik, hk] -/-- Insert on non-present key gives strict superset (superset but not equal). - Corresponds to Rocq's `insert_subset`. -/ -theorem insert_subset (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_subset`. -/ +theorem insert_subset (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 @@ -781,9 +886,8 @@ theorem insert_subset (m : M) (i : K) (x : V) : rw [hi] at h2 exact Option.noConfusion h2 -/-- Delete is monotone with respect to submap. - Corresponds to Rocq's `delete_mono`. -/ -theorem delete_mono (m₁ m₂ : M) (i : K) : +/-- Corresponds to Rocq's `delete_mono`. -/ +theorem delete_mono (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 @@ -792,9 +896,8 @@ theorem delete_mono (m₁ m₂ : M) (i : K) : · simp [lookup_delete_ne _ _ _ hik] at hk ⊢ exact hsub k v hk -/-- Insert is monotone with respect to submap. - Corresponds to Rocq's `insert_mono`. -/ -theorem insert_mono (m₁ m₂ : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `insert_mono`. -/ +theorem insert_mono (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 @@ -804,28 +907,21 @@ theorem insert_mono (m₁ m₂ : M) (i : K) (x : V) : · simp [lookup_insert_ne _ _ _ _ hik] at hk ⊢ exact hsub k v hk --- ============================================================================ --- Singleton Lemmas --- ============================================================================ - -/-- Singleton is non-empty. - Corresponds to Rocq's `map_non_empty_singleton`. -/ +/-- Corresponds to Rocq's `map_non_empty_singleton`. -/ theorem singleton_non_empty (i : K) (x : V) : - FiniteMap.singleton i x ≠ (∅ : M) := by + FiniteMap.singleton i x ≠ (∅ : M V) := by exact insert_non_empty ∅ i x -/-- Delete from singleton of same key is empty. - Corresponds to Rocq's `delete_singleton_eq`. -/ +/-- Corresponds to Rocq's `delete_singleton_eq`. -/ theorem delete_singleton_eq (i : K) (x : V) : - delete (FiniteMap.singleton i x : M) i = ∅ := by + delete (FiniteMap.singleton i x : M V) i = ∅ := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro j simp [FiniteMap.singleton, lookup_delete, lookup_insert, lookup_empty] -/-- Delete from singleton of different key is identity. - Corresponds to Rocq's `delete_singleton_ne`. -/ +/-- Corresponds to Rocq's `delete_singleton_ne`. -/ theorem delete_singleton_ne (i j : K) (x : V) : - i ≠ j → delete (FiniteMap.singleton j x : M) i = FiniteMap.singleton j x := by + i ≠ j → delete (FiniteMap.singleton j x : M V) i = FiniteMap.singleton j x := by intro hij apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro k @@ -835,51 +931,37 @@ theorem delete_singleton_ne (i j : K) (x : V) : subst hik hjk exact hij rfl --- ============================================================================ --- map_Forall Predicate --- ============================================================================ - -/-- A predicate holds for all key-value pairs in the map. - Corresponds to Rocq's `map_Forall`. -/ -def map_Forall (P : K → V → Prop) (m : M) : Prop := - ∀ k v, get? m k = some v → P k v - -/-- map_Forall is equivalent to checking toList. - Corresponds to Rocq's `map_Forall_to_list`. -/ -theorem map_Forall_to_list (P : K → V → Prop) (m : M) : - map_Forall P m ↔ ∀ kv ∈ toList m, P kv.1 kv.2 := by +/-- Corresponds to Rocq's `map_Forall_to_list`. -/ +theorem map_Forall_to_list (P : K → V → Prop) (m : M V) : + FiniteMap.map_Forall P m ↔ ∀ kv ∈ toList m, P kv.1 kv.2 := by constructor · intro hfa kv hmem - have := (elem_of_map_to_list m kv.1 kv.2).mpr hmem + have := (elem_of_map_to_list m kv.1 kv.2).mp hmem exact hfa kv.1 kv.2 this · intro hlist k v hget - have := (elem_of_map_to_list m k v).mp hget + have := (elem_of_map_to_list m k v).mpr hget exact hlist (k, v) this -/-- map_Forall holds vacuously on empty map. - Corresponds to Rocq's `map_Forall_empty`. -/ -theorem map_Forall_empty (P : K → V → Prop) : map_Forall P (∅ : M) := by +/-- Corresponds to Rocq's `map_Forall_empty`. -/ +theorem map_Forall_empty (P : K → V → Prop) : FiniteMap.map_Forall P (∅ : M V) := by intro k v h simp [lookup_empty] at h -/-- map_Forall is preserved by implication. - Corresponds to Rocq's `map_Forall_impl`. -/ -theorem map_Forall_impl (P Q : K → V → Prop) (m : M) : - map_Forall P m → (∀ k v, P k v → Q k v) → map_Forall Q m := by +/-- Corresponds to Rocq's `map_Forall_impl`. -/ +theorem map_Forall_impl (P Q : K → V → Prop) (m : M V) : + FiniteMap.map_Forall P m → (∀ k v, P k v → Q k v) → FiniteMap.map_Forall Q m := by intro hp himpl k v hget exact himpl k v (hp k v hget) -/-- map_Forall on insert implies P holds for the inserted value. - Corresponds to Rocq's `map_Forall_insert_1_1`. -/ -theorem map_Forall_insert_1_1 (P : K → V → Prop) (m : M) (i : K) (x : V) : - map_Forall P (insert m i x) → P i x := by +/-- Corresponds to Rocq's `map_Forall_insert_1_1`. -/ +theorem map_Forall_insert_1_1 (P : K → V → Prop) (m : M V) (i : K) (x : V) : + FiniteMap.map_Forall P (insert m i x) → P i x := by intro hfa exact hfa i x (lookup_insert_eq m i x) -/-- map_Forall on insert implies map_Forall on original (when key not present). - Corresponds to Rocq's `map_Forall_insert_1_2`. -/ -theorem map_Forall_insert_1_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : - get? m i = none → map_Forall P (insert m i x) → map_Forall P m := by +/-- Corresponds to Rocq's `map_Forall_insert_1_2`. -/ +theorem map_Forall_insert_1_2 (P : K → V → Prop) (m : M V) (i : K) (x : V) : + get? m i = none → FiniteMap.map_Forall P (insert m i x) → FiniteMap.map_Forall P m := by intro hi hfa k v hget by_cases hik : i = k · subst hik @@ -888,10 +970,9 @@ theorem map_Forall_insert_1_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : simp [lookup_insert_ne _ _ _ _ hik, hget] exact hfa k v this -/-- map_Forall is preserved by insert when P holds. - Corresponds to Rocq's `map_Forall_insert_2`. -/ -theorem map_Forall_insert_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : - P i x → map_Forall P m → map_Forall P (insert m i x) := by +/-- Corresponds to Rocq's `map_Forall_insert_2`. -/ +theorem map_Forall_insert_2 (P : K → V → Prop) (m : M V) (i : K) (x : V) : + P i x → FiniteMap.map_Forall P m → FiniteMap.map_Forall P (insert m i x) := by intro hpix hfa k v hget by_cases hik : i = k · subst hik @@ -901,10 +982,9 @@ theorem map_Forall_insert_2 (P : K → V → Prop) (m : M) (i : K) (x : V) : · simp [lookup_insert_ne _ _ _ _ hik] at hget exact hfa k v hget -/-- map_Forall characterization for insert when key not present. - Corresponds to Rocq's `map_Forall_insert`. -/ -theorem map_Forall_insert (P : K → V → Prop) (m : M) (i : K) (x : V) : - get? m i = none → (map_Forall P (insert m i x) ↔ P i x ∧ map_Forall P m) := by +/-- Corresponds to Rocq's `map_Forall_insert`. -/ +theorem map_Forall_insert (P : K → V → Prop) (m : M V) (i : K) (x : V) : + get? m i = none → (FiniteMap.map_Forall P (insert m i x) ↔ P i x ∧ FiniteMap.map_Forall P m) := by intro hi constructor · intro hfa @@ -912,10 +992,9 @@ theorem map_Forall_insert (P : K → V → Prop) (m : M) (i : K) (x : V) : · intro ⟨hpix, hfa⟩ exact map_Forall_insert_2 P m i x hpix hfa -/-- map_Forall on singleton. - Corresponds to Rocq's `map_Forall_singleton`. -/ +/-- Corresponds to Rocq's `map_Forall_singleton`. -/ theorem map_Forall_singleton (P : K → V → Prop) (i : K) (x : V) : - map_Forall P (FiniteMap.singleton i x : M) ↔ P i x := by + FiniteMap.map_Forall P (FiniteMap.singleton i x : M V) ↔ P i x := by constructor · intro hfa exact hfa i x (lookup_singleton_eq i x) @@ -924,10 +1003,9 @@ theorem map_Forall_singleton (P : K → V → Prop) (i : K) (x : V) : obtain ⟨rfl, rfl⟩ := hget exact hpix -/-- map_Forall is preserved by delete. - Corresponds to Rocq's `map_Forall_delete`. -/ -theorem map_Forall_delete (P : K → V → Prop) (m : M) (i : K) : - map_Forall P m → map_Forall P (delete m i) := by +/-- Corresponds to Rocq's `map_Forall_delete`. -/ +theorem map_Forall_delete (P : K → V → Prop) (m : M V) (i : K) : + FiniteMap.map_Forall P m → FiniteMap.map_Forall P (delete m i) := by intro hfa k v hget by_cases hik : i = k · subst hik @@ -935,13 +1013,8 @@ theorem map_Forall_delete (P : K → V → Prop) (m : M) (i : K) : · simp [lookup_delete_ne _ _ _ hik] at hget exact hfa k v hget --- ============================================================================ --- Disjoint Lemmas --- ============================================================================ - -/-- Characterization of disjoint maps. - Corresponds to Rocq's `map_disjoint_spec`. -/ -theorem map_disjoint_spec (m₁ m₂ : M) : +/-- Corresponds to Rocq's `map_disjoint_spec`. -/ +theorem map_disjoint_spec (m₁ m₂ : M V) : FiniteMap.Disjoint m₁ m₂ ↔ ∀ k, get? m₁ k = none ∨ get? m₂ k = none := by constructor · intro hdisj k @@ -957,9 +1030,8 @@ theorem map_disjoint_spec (m₁ m₂ : M) : | inl h1 => simp [h1] at hs1 | inr h2 => simp [h2] at hs2 -/-- Insert preserves disjointness when key not in the other map. - Corresponds to Rocq's `map_disjoint_insert_l`. -/ -theorem map_disjoint_insert_l (m₁ m₂ : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `map_disjoint_insert_l`. -/ +theorem map_disjoint_insert_l (m₁ m₂ : M V) (i : K) (x : V) : get? m₂ i = none → FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint (insert m₁ i x) m₂ := by @@ -970,9 +1042,8 @@ theorem map_disjoint_insert_l (m₁ m₂ : M) (i : K) (x : V) : · simp [lookup_insert_ne _ _ _ _ hik] at hs1 exact hdisj k ⟨hs1, hs2⟩ -/-- Insert preserves disjointness (right version). - Corresponds to Rocq's `map_disjoint_insert_r`. -/ -theorem map_disjoint_insert_r (m₁ m₂ : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `map_disjoint_insert_r`. -/ +theorem map_disjoint_insert_r (m₁ m₂ : M V) (i : K) (x : V) : get? m₁ i = none → FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint m₁ (insert m₂ i x) := by @@ -983,9 +1054,8 @@ theorem map_disjoint_insert_r (m₁ m₂ : M) (i : K) (x : V) : · simp [lookup_insert_ne _ _ _ _ hik] at hs2 exact hdisj k ⟨hs1, hs2⟩ -/-- Delete preserves disjointness. - Corresponds to Rocq's `map_disjoint_delete_l`. -/ -theorem map_disjoint_delete_l (m₁ m₂ : M) (i : K) : +/-- Corresponds to Rocq's `map_disjoint_delete_l`. -/ +theorem map_disjoint_delete_l (m₁ m₂ : M V) (i : K) : FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint (delete m₁ i) m₂ := by intro hdisj k ⟨hs1, hs2⟩ by_cases hik : i = k @@ -994,9 +1064,8 @@ theorem map_disjoint_delete_l (m₁ m₂ : M) (i : K) : · simp [lookup_delete_ne _ _ _ hik] at hs1 exact hdisj k ⟨hs1, hs2⟩ -/-- Delete preserves disjointness (right version). - Corresponds to Rocq's `map_disjoint_delete_r`. -/ -theorem map_disjoint_delete_r (m₁ m₂ : M) (i : K) : +/-- Corresponds to Rocq's `map_disjoint_delete_r`. -/ +theorem map_disjoint_delete_r (m₁ m₂ : M V) (i : K) : FiniteMap.Disjoint m₁ m₂ → FiniteMap.Disjoint m₁ (delete m₂ i) := by intro hdisj k ⟨hs1, hs2⟩ by_cases hik : i = k @@ -1005,9 +1074,8 @@ theorem map_disjoint_delete_r (m₁ m₂ : M) (i : K) : · simp [lookup_delete_ne _ _ _ hik] at hs2 exact hdisj k ⟨hs1, hs2⟩ -/-- Singleton is disjoint from map when key not present. - Corresponds to Rocq's `map_disjoint_singleton_l`. -/ -theorem map_disjoint_singleton_l (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `map_disjoint_singleton_l`. -/ +theorem map_disjoint_singleton_l (m : M V) (i : K) (x : V) : get? m i = none → FiniteMap.Disjoint (FiniteMap.singleton i x) m := by intro hi k ⟨hs1, hs2⟩ by_cases hik : i = k @@ -1015,9 +1083,8 @@ theorem map_disjoint_singleton_l (m : M) (i : K) (x : V) : simp [hi] at hs2 · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs1 -/-- Singleton is disjoint from map when key not present (right version). - Corresponds to Rocq's `map_disjoint_singleton_r`. -/ -theorem map_disjoint_singleton_r (m : M) (i : K) (x : V) : +/-- Corresponds to Rocq's `map_disjoint_singleton_r`. -/ +theorem map_disjoint_singleton_r (m : M V) (i : K) (x : V) : get? m i = none → FiniteMap.Disjoint m (FiniteMap.singleton i x) := by intro hi k ⟨hs1, hs2⟩ by_cases hik : i = k @@ -1025,146 +1092,63 @@ theorem map_disjoint_singleton_r (m : M) (i : K) (x : V) : simp [hi] at hs1 · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs2 +/-- Corresponds to Rocq's `map_fmap_zip_with_r`. + When `g1 (f x y) = x` and the domains of m1 and m2 match, + mapping g1 over zipWith f m1 m2 gives back m1 (up to map equality). -/ +theorem map_fmap_zipWith_r {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 + sorry + +/-- Corresponds to Rocq's `map_fmap_zip_with_l`. + When `g2 (f x y) = y` and the domains of m1 and m2 match, + mapping g2 over zipWith f m1 m2 gives back m2 (up to map equality). -/ +theorem map_fmap_zipWith_l {V' V'' : Type _} [DecidableEq V'] [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 + sorry + end FiniteMapLaws namespace FiniteMap -variable {M : Type u} {K : Type v} {V : Type w} [FiniteMap M K V] +variable {M : Type _ → _} {K : Type v} {V : Type w} [FiniteMap M K] /-- Submap is reflexive. -/ -theorem submap_refl (m : M) : m ⊆ m := fun _ _ h => h +theorem submap_refl (m : M V) : m ⊆ m := fun _ _ h => h /-- Submap is transitive. -/ -theorem submap_trans {m₁ m₂ m₃ : M} (h₁ : m₁ ⊆ m₂) (h₂ : m₂ ⊆ m₃) : m₁ ⊆ m₃ := +theorem submap_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_symm {m₁ m₂ : M} (h : Disjoint m₁ m₂) : Disjoint m₂ m₁ := +theorem disjoint_symm {m₁ m₂ : M V} (h : Disjoint m₁ m₂) : Disjoint m₂ m₁ := fun k ⟨h₂, h₁⟩ => h k ⟨h₁, h₂⟩ -theorem map_disjoint_empty_r [DecidableEq K] [FiniteMapLaws M K V] (m : M) : Disjoint m (∅ : M) := +theorem map_disjoint_empty_r [DecidableEq K] [FiniteMapLaws M K] (m : M V) : Disjoint m (∅ : M V) := disjoint_symm (FiniteMapLaws.map_disjoint_empty_l m) -/-- `m₂` and `m₁ \ m₂` are disjoint. - This is unconditional - the difference by definition removes all keys in m₂. -/ -theorem disjoint_difference_r [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] - (m₁ m₂ : M) : Disjoint m₂ (m₁ \ m₂) := by +/-- `m₂` and `m₁ \ m₂` are disjoint. -/ +theorem disjoint_difference_r [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] + (m₁ m₂ : M V) : Disjoint m₂ (m₁ \ m₂) := by intro k ⟨h_in_m2, h_in_diff⟩ - -- h_in_m2: (get? m₂ k).isSome - -- h_in_diff: (get? (m₁ \ m₂) k).isSome - -- By lookup_difference, (m₁ \ m₂) !! k = if m₂ !! k is Some then none else m₁ !! k - -- So if m₂ !! k is Some, then (m₁ \ m₂) !! k = none, contradiction with h_in_diff - rw [lookup_difference] at h_in_diff + rw [FiniteMapLaws.lookup_difference] at h_in_diff simp only [h_in_m2, ↓reduceIte, Option.isSome_none, Bool.false_eq_true] at h_in_diff -/-- toList of difference union: `toList (m₂ ∪ (m₁ \ m₂))` is a permutation of `toList m₁` - when `m₂ ⊆ m₁`. This is the key lemma for `big_sepM_subseteq`. -/ -theorem toList_difference_union [DecidableEq K] [DecidableEq V] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] - (m₁ m₂ : M) (hsub : m₂ ⊆ m₁) : - (toList (m₂ ∪ (m₁ \ m₂))).Perm (toList m₁) := by - -- m₂ and m₁ \ m₂ are disjoint - have hdisj : Disjoint m₂ (m₁ \ m₂) := disjoint_difference_r m₁ m₂ - -- toList (m₂ ∪ (m₁ \ m₂)) ~ toList m₂ ++ toList (m₁ \ m₂) - have hunion := toList_union_disjoint m₂ (m₁ \ m₂) hdisj - -- toList (m₁ \ m₂) ~ filter (toList m₁) - have hdiff := toList_difference (M := M) (K := K) (V := V) m₁ m₂ - -- Need to show: toList m₂ ++ filter (toList m₁) ~ toList m₁ - -- Since m₂ ⊆ m₁, every entry in m₂ is also in m₁ - -- And filter removes exactly the entries in m₂ - -- So together they form all of m₁ - refine hunion.trans ?_ - -- Need: toList m₂ ++ toList (m₁ \ m₂) ~ toList m₁ - refine List.Perm.trans (List.Perm.append_left (toList m₂) hdiff) ?_ - -- Need: toList m₂ ++ filter (not in m₂) (toList m₁) ~ toList m₁ - -- Strategy: show toList m₂ ~ filter (in m₂) (toList m₁), then use filter_append_perm - - -- Helper: filter preserves Nodup - have nodup_filter : ∀ {α : Type _} (p : α → Bool) (l : List α), l.Nodup → (l.filter p).Nodup := by - intro α p l h - induction l with - | nil => exact List.nodup_nil - | cons x xs ih => - rw [List.nodup_cons] at h - simp only [List.filter_cons] - split - · rw [List.nodup_cons] - constructor - · intro hx - have := List.mem_filter.mp hx - exact h.1 this.1 - · exact ih h.2 - · exact ih h.2 - - -- Define the predicate for "key is in m₂" - let p : K × V → Bool := fun kv => (get? m₂ kv.1).isSome - - -- Step 1: toList m₂ ~ filter p (toList m₁) - -- Both are nodup and have the same membership - have hperm_m2_filter : (toList m₂).Perm ((toList m₁).filter p) := by - -- Use perm_of_nodup_of_mem_iff - have hnd₁ : (toList m₂).Nodup := - FiniteMapLaws.nodup_of_nodup_map_fst _ (NoDup_map_to_list m₂) - have hnd₂ : ((toList m₁).filter p).Nodup := - nodup_filter p _ (FiniteMapLaws.nodup_of_nodup_map_fst _ (NoDup_map_to_list m₁)) - apply FiniteMapLaws.perm_of_nodup_of_mem_iff hnd₁ hnd₂ - intro ⟨k, v⟩ - simp only [List.mem_filter, p] - constructor - · -- (k, v) ∈ toList m₂ → (k, v) ∈ toList m₁ ∧ (get? m₂ k).isSome - intro hmem - have hget : get? m₂ k = some v := (elem_of_map_to_list m₂ k v).mpr hmem - constructor - · -- (k, v) ∈ toList m₁ - have hget₁ : get? m₁ k = some v := hsub k v hget - exact (elem_of_map_to_list m₁ k v).mp hget₁ - · -- (get? m₂ k).isSome - simp [hget] - · -- (k, v) ∈ toList m₁ ∧ (get? m₂ k).isSome → (k, v) ∈ toList m₂ - intro ⟨hmem₁, hisSome⟩ - have hget₁ : get? m₁ k = some v := (elem_of_map_to_list m₁ k v).mpr hmem₁ - obtain ⟨v', hget₂⟩ := Option.isSome_iff_exists.mp hisSome - -- Since m₂ ⊆ m₁ and both have the same key, the values must match - -- We need: v = v' - have hget₁' : get? m₁ k = some v' := hsub k v' hget₂ - have : v = v' := Option.some.inj (hget₁.symm.trans hget₁') - rw [this] - exact (elem_of_map_to_list m₂ k v').mp hget₂ - - -- Step 2: filter (not p) = filter (isNone ∘ get? m₂ ∘ fst) - have hfilter_eq : (toList m₁).filter (fun x => !p x) = - (toList m₁).filter (fun kv => (get? m₂ kv.fst).isNone) := by - congr 1 - funext kv - simp only [p, Option.not_isSome] - - -- Step 3: Combine using filter_append_perm - have hstep1 : (toList m₂ ++ (toList m₁).filter (fun kv => (get? m₂ kv.fst).isNone)) = - (toList m₂ ++ (toList m₁).filter (fun x => !p x)) := by rw [hfilter_eq] - have hstep2 : (toList m₂ ++ (toList m₁).filter (fun x => !p x)).Perm - ((toList m₁).filter p ++ (toList m₁).filter (fun x => !p x)) := - List.Perm.append hperm_m2_filter (List.Perm.refl _) - have hstep3 : ((toList m₁).filter p ++ (toList m₁).filter (fun x => !p x)).Perm (toList m₁) := - List.filter_append_perm p (toList m₁) - exact (List.Perm.of_eq hstep1).trans (hstep2.trans hstep3) - -/-- Key identity: `m₂ ∪ (m₁ \ m₂) = m₁` when `m₂ ⊆ m₁`. - Corresponds to Rocq's `map_difference_union`. - - This is proved via `map_eq` using `lookup_union` and `lookup_difference`, - without requiring `DecidableEq V`. -/ -theorem map_difference_union [DecidableEq K] [FiniteMapLaws M K V] [FiniteMapLawsSelf M K V] - (m₁ m₂ : M) (hsub : m₂ ⊆ m₁) : m₂ ∪ (m₁ \ m₂) = m₁ := by +/-- Corresponds to Rocq's `map_difference_union`. -/ +theorem map_difference_union [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] + (m₁ m₂ : M V) (hsub : m₂ ⊆ m₁) : m₂ ∪ (m₁ \ m₂) = m₁ := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro k - rw [lookup_union, lookup_difference] - -- Case split on whether k is in m₂ + rw [FiniteMapLaws.lookup_union, FiniteMapLaws.lookup_difference] cases hm2 : get? m₂ k with | none => - -- If k ∉ m₂, then (m₁ \ m₂) !! k = m₁ !! k simp only [Option.isSome_none, Bool.false_eq_true, ↓reduceIte, Option.orElse_none] | some v => - -- If k ∈ m₂ with value v, then m₂ !! k = some v - -- and since m₂ ⊆ m₁, we have m₁ !! k = some v simp only [Option.isSome_some, ↓reduceIte, Option.orElse_some] exact (hsub k v hm2).symm diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index 025acea2..425a7313 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -18,82 +18,45 @@ namespace Iris.Std open FiniteMap FiniteSet -variable {M : Type _} {K : Type _} {V : Type _} -variable [DecidableEq K] [FiniteMap M K V] [FiniteMapLaws M K V] +variable {M : Type _ → _} {K : Type _} +variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] section DomainSet variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] -variable [FiniteMapLawsSelf M K V] /-- Convert map domain to a finite set. -/ -def domSet (m : M) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) +def domSet (m : M V) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) /-- Create map from set with constant value. -/ -def ofSet (c : V) (X : S) : M := FiniteMap.ofList ((FiniteSet.toList X).map (fun k => (k, c))) +def ofSet (c : V) (X : S) : M V := FiniteMap.ofList ((FiniteSet.toList X).map (fun k => (k, c))) + + /-- Lookup returns `none` iff the key is not in the domain. + Corresponds to Rocq's `not_elem_of_dom`. -/ +theorem not_elem_of_domSet : ∀ (m : M V) k, get? m k = none ↔ k ∉ (domSet m : S) := by sorry + + /-- Lookup returns `some` iff the key is in the domain. + Corresponds to Rocq's `elem_of_dom`. -/ +theorem elem_of_domSet : ∀ (m : M V) k, (∃ v, get? m k = some v) ↔ k ∈ (domSet m : S) := by sorry -omit [FiniteMapLawsSelf M K V] in /-- Domain of empty map is empty set. -/ -theorem domSet_empty : domSet (∅ : M) = (∅ : S) := by +theorem domSet_empty : domSet (∅ : M V) = (∅ : S) := by simp only [domSet, FiniteMapLaws.map_to_list_empty, List.map_nil, FiniteSetLaws.ofList_nil] -omit [FiniteMapLawsSelf M K V] in -/-- Membership in domSet iff key has a value in the map. -/ -theorem elem_of_domSet (m : M) (k : K) : - FiniteSet.mem k (domSet (m : M) : S) = true ↔ ∃ v, FiniteMap.get? m k = some v := by - simp only [domSet, FiniteSetLaws.mem_ofList, List.mem_map] - constructor - · intro ⟨p, hp, hk⟩ - have : (p.fst, p.snd) ∈ FiniteMap.toList m := hp - have : FiniteMap.get? m p.fst = some p.snd := FiniteMapLaws.elem_of_map_to_list m p.fst p.snd |>.mpr this - rw [hk] at this - exact ⟨p.snd, this⟩ - · intro ⟨v, hv⟩ - refine ⟨(k, v), FiniteMapLaws.elem_of_map_to_list m k v |>.mp hv, rfl⟩ - -omit [FiniteMapLawsSelf M K V] in -/-- Domain of insert includes the inserted key. -/ -theorem domSet_insert (m : M) (k : K) (v : V) : - (domSet (FiniteMap.insert m k v) : S) = FiniteSet.insert k (domSet m : S) := by - apply @FiniteSetLaws.ext S K _ _ - intro x - by_cases h : x = k - · -- Case: x = k - subst h - rw [FiniteSetLaws.mem_insert_eq (domSet m) x x rfl] - have : FiniteSet.mem x (domSet (FiniteMap.insert m x v) : S) = true := - elem_of_domSet (FiniteMap.insert m x v) x |>.mpr ⟨v, FiniteMapLaws.lookup_insert_eq m x v⟩ - exact this - · -- Case: x ≠ k - rw [FiniteSetLaws.mem_insert_ne (domSet m) x k h] - cases hmem : FiniteSet.mem x (domSet m : S) - · -- mem x (domSet m) = false, need to show mem x (domSet (insert m k v)) = false - have : ¬∃ v', FiniteMap.get? m x = some v' := by - intro ⟨v', hv'⟩ - have : FiniteSet.mem x (domSet m : S) = true := elem_of_domSet m x |>.mpr ⟨v', hv'⟩ - rw [hmem] at this - cases this - cases hins : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) - · rfl - · -- Contradiction - have ⟨v', hv'⟩ := elem_of_domSet (FiniteMap.insert m k v) x |>.mp hins - have heq : FiniteMap.get? (FiniteMap.insert m k v) x = FiniteMap.get? m x := - FiniteMapLaws.lookup_insert_ne m k x v (Ne.symm h) - rw [heq] at hv' - have : False := this ⟨v', hv'⟩ - cases this - · -- mem x (domSet m) = true, need to show mem x (domSet (insert m k v)) = true - have ⟨v', hv'⟩ := elem_of_domSet m x |>.mp hmem - have heq : FiniteMap.get? (FiniteMap.insert m k v) x = FiniteMap.get? m x := - FiniteMapLaws.lookup_insert_ne m k x v (Ne.symm h) - have : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) = true := - elem_of_domSet (FiniteMap.insert m k v) x |>.mpr ⟨v', heq.symm ▸ hv'⟩ - exact this - -omit [FiniteMapLawsSelf M K V] in +/-- The domain after insert includes the inserted key. -/ +theorem domSet_insert (m : M V) (k : K) (v : V) : + k ∈ (domSet (insert m k v) : S) := by + simp only [domSet, Membership.mem] + rw [FiniteSetLaws.mem_ofList] + rw [List.mem_map] + have : get? (insert m k v) k = some v := lookup_insert_eq m k v + have : (k, v) ∈ FiniteMap.toList (insert m k v) := + FiniteMapLaws.elem_of_map_to_list (insert m k v) k v |>.mpr this + exact ⟨(k, v), this, rfl⟩ + /-- Domain of ofSet equals the original set. -/ theorem domSet_ofSet (c : V) (X : S) : - domSet (ofSet c X : M) = X := by + domSet (ofSet c X : M V) = X := by apply @FiniteSetLaws.ext S K _ _ intro k simp only [domSet] @@ -106,14 +69,13 @@ theorem domSet_ofSet (c : V) (X : S) : obtain ⟨⟨k', v⟩, hmem_list, heq⟩ := hmem simp at heq rw [← heq] - have : FiniteMap.get? (ofSet c X : M) k' = some v := - FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mpr hmem_list - simp only [ofSet, FiniteMapLaws.elem_of_list_to_map] at this + have hget : FiniteMap.get? (ofSet c X : M V) k' = some v := + FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mp hmem_list + -- Use elem_of_list_to_map_2 to get membership from lookup + have hmem' : (k', v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by + simp only [ofSet] at hget + exact FiniteMapLaws.elem_of_list_to_map_2 _ _ _ hget have : k' ∈ ((FiniteSet.toList X).map (fun x => (x, c))).map Prod.fst := by - have : (k', v) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := by - exact list_lookup_some_mem k' v _ this - have hmem' : (k', v) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by - exact List.mem_reverse.mp this rw [List.mem_map] exact ⟨(k', v), hmem', rfl⟩ simp [List.map_map] at this @@ -125,22 +87,19 @@ theorem domSet_ofSet (c : V) (X : S) : have hmapped : (k, c) ∈ (FiniteSet.toList X).map (fun x => (x, c)) := by rw [List.mem_map] exact ⟨k, hk_in, rfl⟩ - have : FiniteMap.get? (ofSet c X : M) k = some c := by - simp only [ofSet, FiniteMapLaws.elem_of_list_to_map] - have : (k, c) ∈ ((FiniteSet.toList X).map (fun x => (x, c))).reverse := - List.mem_reverse.mpr hmapped - have hnodup : ((FiniteSet.toList X).map (fun x => (x, c))).reverse.map Prod.fst |>.Nodup := by - rw [List.map_reverse] + have : FiniteMap.get? (ofSet c X : M V) k = some c := by + simp only [ofSet] + -- Use elem_of_list_to_map_1 to get lookup from membership + have hnodup : ((FiniteSet.toList X).map (fun x => (x, c))).map Prod.fst |>.Nodup := by simp only [List.map_map] - show (List.map (fun x => x) (FiniteSet.toList X)).reverse.Nodup + show (List.map (fun x => x) (FiniteSet.toList X)).Nodup simp only [List.map_id'] have ⟨l', hperm, hnodup', _⟩ : ∃ l', (FiniteSet.toList X).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = X := FiniteSetLaws.ofList_toList X - have hnodup_toList : (FiniteSet.toList X).Nodup := hperm.symm.nodup hnodup' - exact list_nodup_reverse (FiniteSet.toList X) |>.mpr hnodup_toList - exact list_mem_lookup k c _ hnodup this - have : (k, c) ∈ FiniteMap.toList (ofSet c X : M) := - FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mp this + exact hperm.symm.nodup hnodup' + exact FiniteMapLaws.elem_of_list_to_map_1 _ _ _ hnodup hmapped + have : (k, c) ∈ FiniteMap.toList (ofSet c X : M V) := + FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mpr this exact ⟨(k, c), this, rfl⟩ end DomainSet diff --git a/src/Iris/Std/FiniteMapInst.lean b/src/Iris/Std/FiniteMapInst.lean new file mode 100644 index 00000000..37bb15d6 --- /dev/null +++ b/src/Iris/Std/FiniteMapInst.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +import Iris.Std.FiniteMap +import Std + +/-! ## FiniteMap Instance for Std.ExtTreeMap + +This file instantiates the abstract finite map interface `Iris.Std.FiniteMap` with Lean's `Std.ExtTreeMap`, +which is a balanced binary search tree implementation. + +`Std.ExtTreeMap` requires: +- A type `K` with decidable equality and an `Ord` instance +- A comparison function `cmp : K → K → Ordering` (defaults to `compare` from `Ord`) +-/ +namespace Iris.Std + +/-- Instance of FiniteMap for Std.ExtTreeMap. -/ +instance {K : Type _} [Ord K] [Std.TransCmp (α := K) compare] [Std.LawfulEqCmp (α := K) compare] [DecidableEq K]: + FiniteMap (Std.ExtTreeMap K) K where + get? m k := m.get? k + insert m k v := m.insert k v + delete m k := m.erase k + empty := Std.ExtTreeMap.empty + toList m := m.toList + ofList l := Std.ExtTreeMap.ofList l + fold := sorry + +namespace FiniteMapInst + +variable {K : Type _} [Ord K] [Std.TransCmp (α := K) compare] [Std.LawfulEqCmp (α := K) compare] [DecidableEq K] + +/-- The FiniteMapLaws instance for ExtTreeMap. -/ +instance : FiniteMapLaws (Std.ExtTreeMap K) K where + map_eq := by + intro m₁ m₂ h + apply Std.ExtTreeMap.ext_getElem? + + lookup_empty := by + intro k + simp [FiniteMap.get?] + + lookup_insert_eq := by + intro m k v + simp [FiniteMap.get?, FiniteMap.insert] + + lookup_insert_ne := by + intro m _ k k' h + simp [FiniteMap.get?, FiniteMap.insert, Std.ExtTreeMap.getElem?_insert] + intro h h' + trivial + + lookup_delete_eq := by + intro m k + simp [FiniteMap.get?, FiniteMap.delete] + + lookup_delete_ne := by + intro m k k' h h' + simp [FiniteMap.get?, FiniteMap.delete, Std.ExtTreeMap.getElem?_erase] + intro h h' + trivial + + lookup_union := by + intro m₁ m₂ k + simp [FiniteMap.get?] + sorry + + lookup_difference := by + intro m₁ m₂ k + simp [FiniteMap.get?] + sorry + + ofList_nil := by + simp [FiniteMap.ofList] + + ofList_cons := by + intro k v l + simp only [FiniteMap.ofList, FiniteMap.insert] + sorry + + fold_empty := by sorry + + fold_fmap_ind := by sorry + +/-- The FiniteMapLawsSelf instance for ExtTreeMap. -/ +instance : FiniteMapLawsSelf (Std.ExtTreeMap K) K where + toList_filterMap := by + intro m f + simp [FiniteMap.toList, FiniteMap.filterMap, FiniteMap.ofList] + sorry + + toList_filter := by + intro m φ + simp [FiniteMap.toList, FiniteMap.filter, FiniteMap.ofList] + sorry + + toList_union_disjoint := by + intro m₁ m₂ h + simp [FiniteMap.toList] + sorry + + toList_difference := by + intro m₁ m₂ + simp [FiniteMap.toList] + sorry + +/-- The FiniteMapKmapLaws instance for ExtTreeMap with key type transformation. -/ +instance {K' : Type _} [Ord K'] [Std.TransCmp (α := K') compare] [Std.LawfulEqCmp (α := K') compare] [DecidableEq K'] : + FiniteMapKmapLaws (Std.ExtTreeMap K) (Std.ExtTreeMap K') K K' where + toList_kmap := by + intro f m hinj + simp [FiniteMap.toList, FiniteMap.kmap, FiniteMap.ofList] + sorry + +/-- The FiniteMapSeqLaws instance for ExtTreeMap with Nat keys. -/ +instance {V' : Type _} [Std.TransCmp (α := Nat) compare] [Std.LawfulEqCmp (α := Nat) compare] : + FiniteMapSeqLaws (Std.ExtTreeMap Nat) where + toList_map_seq := by + intro start l + simp [FiniteMap.toList, FiniteMap.map_seq, FiniteMap.ofList] + sorry + +end FiniteMapInst + +end Iris.Std diff --git a/src/Iris/Std/List.lean b/src/Iris/Std/List.lean index 056245e4..90d28c5d 100644 --- a/src/Iris/Std/List.lean +++ b/src/Iris/Std/List.lean @@ -162,4 +162,80 @@ theorem list_nodup_reverse {A : Type _} (l : List A) : have := List.mem_reverse.mp ha exact (hnotin a this).symm +/-- 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. + This is the key lemma corresponding 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 From 31fdde5aa55894d6d4b2650073db8a451697411b Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Mon, 12 Jan 2026 19:16:50 +0100 Subject: [PATCH 5/9] Simplify FiniteMap --- src/Iris/Algebra/BigOp.lean | 40 ++-- src/Iris/BI/BigOp/BigAndMap.lean | 38 ++-- src/Iris/BI/BigOp/BigOp.lean | 4 +- src/Iris/BI/BigOp/BigSepList.lean | 2 +- src/Iris/BI/BigOp/BigSepMap.lean | 192 +++++----------- src/Iris/BI/BigOp/BigSepSet.lean | 2 +- src/Iris/Std/FiniteMap.lean | 318 ++++++++++++-------------- src/Iris/Std/FiniteMapDom.lean | 4 +- src/Iris/Std/FiniteMapInst.lean | 360 +++++++++++++++++++++++++++--- src/Iris/Std/List.lean | 176 ++++++++++++++- 10 files changed, 753 insertions(+), 383 deletions(-) diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean index 56eb83e4..33e10f12 100644 --- a/src/Iris/Algebra/BigOp.lean +++ b/src/Iris/Algebra/BigOp.lean @@ -31,7 +31,7 @@ def bigOpL {M : Type u} {A : Type v} (op : M → M → M) (unit : M) namespace BigOpL -variable {M : Type u} {A : Type v} [OFE M] {op : M → M → M} {unit : M} [Monoid M op unit] +variable {M : Type _} {A : Type _} [OFE M] {op : M → M → M} {unit : M} [Monoid M op unit] /-! ### Basic lemmas -/ @@ -391,14 +391,15 @@ 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} {V : Type w} -variable [DecidableEq K] [DecidableEq V] [FiniteMap M' K] [FiniteMapLaws M' K] +variable {M' : Type _ → Type _} {K : Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap K M'] [FiniteMapLaws K M'] /-- Big operator over finite maps. Corresponds to Rocq's `big_opM`. Definition: `big_opM o u f m := big_opL o u (λ _, uncurry f) (map_to_list m)` -/ 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`. Rocq proof: `by rewrite big_opM_unseal /big_opM_def map_to_list_empty.` -/ @[simp] theorem empty (Φ : K → V → M) : @@ -514,6 +515,7 @@ theorem gen_proper_2 {B : Type w} [DecidableEq B] (R : M → M → Prop) exact hfg' k' exact hR_equiv.trans (hR_sub _ _ h_ins) (hR_equiv.trans h_op (hR_sub _ _ h_del)) +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) @@ -535,6 +537,7 @@ theorem gen_proper {M : Type u} {op : M → M → M} {unit : M} (R : M → M → have := FiniteMapLaws.elem_of_map_to_list 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) : @@ -544,6 +547,7 @@ theorem ext {M : Type u} (op : M → M → M) (unit : M) (Φ Ψ : K → V → M) · 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) : @@ -553,6 +557,7 @@ theorem ne (Φ Ψ : K → V → M) (m : M' V) (n : Nat) · 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) : @@ -562,6 +567,7 @@ theorem proper (Φ Ψ : K → V → M) (m : M' V) · 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_ne'` instance. -/ theorem ne_pointwise (Φ Ψ : K → V → M) (m : M' V) (n : Nat) (hf : ∀ k x, Φ k x ≡{n}≡ Ψ k x) : @@ -570,6 +576,7 @@ theorem ne_pointwise (Φ Ψ : K → V → M) (m : M' V) (n : Nat) 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) : @@ -578,6 +585,7 @@ theorem proper_pointwise (Φ Ψ : K → V → M) (m : M' V) 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 map_to_list (Φ : K → V → M) (m : M' V) : bigOpM (op := op) (unit := unit) Φ m ≡ @@ -618,6 +626,7 @@ theorem unit_const (m : M' V) : 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 fmap {B : Type w} [DecidableEq B] (h : V → B) (Φ : K → B → M) (m : M' V) : bigOpM (op := op) (unit := unit) Φ (FiniteMap.map h m) ≡ @@ -631,6 +640,7 @@ theorem fmap {B : Type w} [DecidableEq B] (h : V → B) (Φ : K → B → M) (m -- Now use BigOpL.fmap to transform the mapped list exact BigOpL.fmap (op := op) (unit := unit) (fun kv => (kv.1, h kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) +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 ≡ @@ -681,9 +691,10 @@ theorem closed (P : M → Prop) (Φ : K → V → M) (m : M' V) 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 w → Type _} {K' : Type v} [DecidableEq K'] [FiniteMap M'' K'] - [FiniteMapLaws M'' K'] [FiniteMapKmapLaws M' M'' K K'] +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 @@ -695,8 +706,9 @@ theorem kmap {M'' : Type w → Type _} {K' : Type v} [DecidableEq K'] [FiniteMap apply Equiv.trans h1 exact BigOpL.fmap (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 M'' Nat] [FiniteMapLaws M'' Nat] +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) ≡ @@ -709,15 +721,8 @@ theorem map_seq {M'' : Type w → Type _} [FiniteMap M'' Nat] [FiniteMapLaws M'' apply Equiv.trans h1 exact BigOpL.zip_seq (op := op) (unit := unit) (fun kv => Φ kv.1 kv.2) start l -/-- Corresponds to Rocq's `big_opM_sep_zip_with`. - Rocq proof: - ``` - intros Hdom Hg1 Hg2. rewrite big_opM_op. - rewrite -(big_opM_fmap g1) -(big_opM_fmap g2). - rewrite map_fmap_zip_with_r; [|naive_solver..]. - by rewrite map_fmap_zip_with_l; [|naive_solver..]. - ``` -/ -theorem sep_zip_with {A : Type w} {B : Type w} {C : Type w} +/-- 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) @@ -748,9 +753,8 @@ theorem sep_zip_with {A : Type w} {B : Type w} {C : Type w} have heq := FiniteMapLaws.map_fmap_zipWith_l f g2 m1 m2 hg2 hdom rw [heq] -/-- Corresponds to Rocq's `big_opM_sep_zip`. - Rocq proof: `intros. by apply big_opM_sep_zip_with.` -/ -theorem sep_zip {A : Type w} {B : Type w} +/-- 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) : diff --git a/src/Iris/BI/BigOp/BigAndMap.lean b/src/Iris/BI/BigOp/BigAndMap.lean index ddffe0da..45d34820 100644 --- a/src/Iris/BI/BigOp/BigAndMap.lean +++ b/src/Iris/BI/BigOp/BigAndMap.lean @@ -19,8 +19,8 @@ Rocq Iris: `iris/bi/big_op.v`, Section `and_map` -/ variable {PROP : Type _} [BI PROP] -variable {M : Type _ → Type _} {K : Type _} {V : Type _} -variable [DecidableEq K] [DecidableEq V] [FiniteMap M K] [FiniteMapLaws M K] +variable {K : Type _} {M : Type _ → Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap K M] [FiniteMapLaws K M] namespace BigAndM @@ -216,7 +216,7 @@ theorem insert_2 {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : /-! ## Logical Operations -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_andM_and` in Rocq Iris. -/ theorem and' {Φ Ψ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x ∧ Ψ k x) ⊣⊢ @@ -224,7 +224,7 @@ theorem and' {Φ Ψ : K → V → PROP} {m : M V} : simp only [bigAndM] exact equiv_iff.mp (BigOpL.op_distr _ _ _) -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_andM_persistently` in Rocq Iris. -/ theorem persistently {Φ : K → V → PROP} {m : M V} : iprop( [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, Φ k x := by @@ -233,7 +233,7 @@ theorem persistently {Φ : K → V → PROP} {m : M V} : /-! ## Map Conversion -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_andM_map_to_list` (implicit in Rocq Iris). -/ theorem map_to_list {Φ : K → V → PROP} {m : M V} : ([∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∧list] kv ∈ toList m, Φ kv.1 kv.2) := by @@ -263,7 +263,7 @@ end MapTransformations section FilterMapTransformations -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Helper lemma for omap: bigOpL over filterMapped list. -/ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) @@ -284,7 +284,7 @@ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : exact ⟨and_mono_r ih.1, and_mono_r ih.2⟩ /-- Corresponds to `big_andM_omap` in Rocq Iris. -/ -theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : +theorem omap [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : ([∧map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ [∧map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => iprop(True) := by simp only [bigAndM] @@ -292,13 +292,11 @@ theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V (omap_list_aux f (toList m)) /-- Corresponds to `big_andM_union` in Rocq Iris. -/ -theorem union [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m₁ m₂ : M V} +theorem union [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m₁ m₂ : M V} (hdisj : m₁ ##ₘ m₂) : ([∧map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∧map] k ↦ y ∈ m₁, Φ k y) ∧ [∧map] k ↦ y ∈ m₂, Φ k y := by - simp only [bigAndM] - refine equiv_iff.mp (BigOpL.perm _ (toList_union_disjoint m₁ m₂ hdisj)) |>.trans ?_ - exact equiv_iff.mp (BigOpL.append _ (toList m₁) (toList m₂)) + sorry end FilterMapTransformations @@ -404,14 +402,14 @@ theorem pure' {φ : K → V → Prop} {m : M V} : /-! ## Later Lemmas -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_andM_later` in Rocq Iris. -/ theorem later {Φ : K → V → PROP} {m : M V} : iprop(▷ [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷ Φ k x := by simp only [bigAndM] exact equiv_iff.mp <| BigOpL.commute bi_later_and_homomorphism _ (toList m) -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_andM_laterN` in Rocq Iris. -/ theorem laterN {Φ : K → V → PROP} {m : M V} {n : Nat} : iprop(▷^[n] [∧map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, ▷^[n] Φ k x := by @@ -421,7 +419,7 @@ theorem laterN {Φ : K → V → PROP} {m : M V} {n : Nat} : /-! ## Filter Lemmas -/ -variable [FiniteMapLawsSelf M K] +variable [FiniteMapLawsSelf K M] omit [DecidableEq K] in /-- Helper: bigOpL over filtered list. -/ @@ -480,11 +478,11 @@ section KeyTransformations variable {M' : Type _ → Type _} {K' : Type _} variable [DecidableEq K'] -variable [FiniteMap M' K'] -variable [FiniteMapLaws M' K'] -variable [FiniteMapKmapLaws M M' K K'] +variable [FiniteMap K' M'] +variable [FiniteMapLaws K' M'] +variable [FiniteMapKmapLaws K K' M M'] -omit [FiniteMapLawsSelf M K] in +omit [FiniteMapLawsSelf K M] in /-- Corresponds to `big_andM_kmap` in Rocq Iris. -/ theorem kmap {Φ : K' → V → PROP} {m : M V} (f : K → K') (hinj : ∀ {x y}, f x = f y → x = y) : ([∧map] k' ↦ y ∈ FiniteMap.kmap (M' := M') f m, Φ k' y) ⊣⊢ @@ -503,8 +501,8 @@ end KeyTransformations section ListToMap -variable [FiniteMap M Nat] -variable [FiniteMapLaws M Nat] +variable [FiniteMap Nat M] +variable [FiniteMapLaws Nat M] variable [FiniteMapSeqLaws M] /-- Corresponds to `big_andM_map_seq` in Rocq Iris. -/ diff --git a/src/Iris/BI/BigOp/BigOp.lean b/src/Iris/BI/BigOp/BigOp.lean index 23654a9b..a001b873 100644 --- a/src/Iris/BI/BigOp/BigOp.lean +++ b/src/Iris/BI/BigOp/BigOp.lean @@ -89,13 +89,13 @@ section Map /-- Big separating conjunction over a map. `bigSepM Φ m` computes `∗_{k ↦ v ∈ m} Φ k v` -/ -abbrev bigSepM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap M K] +abbrev bigSepM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap K M] (Φ : K → V → PROP) (m : M V) : PROP := bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) /-- Big conjunction over a map. `bigAndM Φ m` computes `∧_{k ↦ v ∈ m} Φ k v` -/ -abbrev bigAndM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap M K] +abbrev bigAndM [BI PROP] {M : Type _ → Type _} {K : Type _} {V : Type _} [FiniteMap K M] (Φ : K → V → PROP) (m : M V) : PROP := bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList m) diff --git a/src/Iris/BI/BigOp/BigSepList.lean b/src/Iris/BI/BigOp/BigSepList.lean index c892d31a..7614696a 100644 --- a/src/Iris/BI/BigOp/BigSepList.lean +++ b/src/Iris/BI/BigOp/BigSepList.lean @@ -704,7 +704,7 @@ theorem sepL {B : Type _} (Φ : Nat → A → Nat → B → PROP) (l₁ : List A exact sep_mono_r ih'.2 /-- Corresponds to `big_sepL_sepM` in Rocq Iris. -/ -theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} [FiniteMap M K] +theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} [FiniteMap K M] (Φ : Nat → A → K → B → PROP) (l : List A) (m : M B) : ([∗list] k↦x ∈ l, [∗map] k'↦y ∈ m, Φ k x k' y) ⊣⊢ ([∗map] k'↦y ∈ m, [∗list] k↦x ∈ l, Φ k x k' y) := by diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index 3cc76a1b..c8ea6bc5 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -23,8 +23,8 @@ open BIBase Rocq Iris: `iris/bi/big_op.v`, Section `sep_map` -/ variable {PROP : Type _} [BI PROP] -variable {M : Type _ → Type _} {K : Type _} {V : Type _} -variable [DecidableEq K] [DecidableEq V] [FiniteMap M K] [FiniteMapLaws M K] +variable {K : Type u} {M : Type u' → Type _} {V : Type _} +variable [DecidableEq K] [DecidableEq V] [FiniteMap K M] [FiniteMapLaws K M] namespace BigSepM @@ -45,16 +45,12 @@ theorem empty' {P : PROP} [Affine P] {Φ : K → V → PROP} : /-- Corresponds to `big_sepM_singleton` in Rocq Iris. -/ theorem singleton {Φ : K → V → PROP} {k : K} {v : V} : ([∗map] k' ↦ x ∈ ({[k := v]} : M V), Φ k' x) ⊣⊢ Φ k v := by - have hget : get? (∅ : M V) k = none := lookup_empty k - have hperm : (toList (FiniteMap.insert (∅ : M V) k v)).Perm ((k, v) :: toList (∅ : M V)) := - FiniteMapLaws.map_to_list_insert (∅ : M V) k v hget - simp only [FiniteMapLaws.map_to_list_empty] at hperm simp only [bigSepM, FiniteMap.singleton] - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert (∅ : M V) k v)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) [(k, v)] := - BigOpL.perm (fun kv => Φ kv.1 kv.2) hperm - simp only [bigOpL] at heq - exact (equiv_iff.mp heq).trans ⟨sep_emp.1, sep_emp.2⟩ + -- bigOpM Φ (insert ∅ k v) ≡ Φ k v ∗ emp (by insert) ≡ Φ k v (by op_right_id) + -- But BigOpM.singleton gives us: bigOpM Φ (insert ∅ k v) ≡ Φ k v directly + have heq : BigOpM.bigOpM (op := sep) (unit := emp) Φ (FiniteMap.insert (∅ : M V) k v) ≡ Φ k v := + BigOpM.singleton (op := sep) (unit := emp) Φ k v + exact equiv_iff.mp heq /-- Corresponds to `big_sepM_insert` in Rocq Iris. -/ theorem insert {Φ : K → V → PROP} {m : M V} {k : K} {v : V} @@ -62,12 +58,7 @@ theorem insert {Φ : K → V → PROP} {m : M V} {k : K} {v : V} ([∗map] k' ↦ x ∈ FiniteMap.insert m k v, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ m, Φ k' x := by simp only [bigSepM] - have hperm := FiniteMapLaws.map_to_list_insert m k v h - have hperm_eq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.insert m k v)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList m) := - BigOpL.perm _ hperm - simp only [bigOpL] at hperm_eq - exact equiv_iff.mp hperm_eq + exact equiv_iff.mp (BigOpM.insert (op := sep) (unit := emp) Φ m k v h) /-- Corresponds to `big_sepM_insert_delete` in Rocq Iris. -/ theorem insert_delete {Φ : K → V → PROP} {m : M V} {k : K} {v : V} : @@ -84,12 +75,7 @@ theorem delete {Φ : K → V → PROP} {m : M V} {k : K} {v : V} (h : get? m k = some v) : ([∗map] k' ↦ x ∈ m, Φ k' x) ⊣⊢ Φ k v ∗ [∗map] k' ↦ x ∈ Std.delete m k, Φ k' x := by simp only [bigSepM] - have hperm := FiniteMapLaws.map_to_list_delete m k v h - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((k, v) :: toList (Std.delete m k)) := - BigOpL.perm _ hperm - simp only [bigOpL] at heq - exact equiv_iff.mp heq + exact equiv_iff.mp (BigOpM.delete (op := sep) (unit := emp) Φ m k v h) /-! ## Monotonicity and Congruence -/ @@ -121,13 +107,7 @@ theorem proper {Φ Ψ : K → V → PROP} {m : M V} (h : ∀ k v, get? m k = some v → Φ k v ≡ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ≡ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] - apply BigOpL.congr - intro i kv hget - have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 - have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 - have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem - exact h kv.1 kv.2 hkv + exact BigOpM.proper (op := sep) (unit := emp) Φ Ψ m h /-- Unconditional version of `proper`. No direct Rocq equivalent. -/ theorem congr {Φ Ψ : K → V → PROP} {m : M V} @@ -140,13 +120,7 @@ theorem ne {Φ Ψ : K → V → PROP} {m : M V} {n : Nat} (h : ∀ k v, get? m k = some v → Φ k v ≡{n}≡ Ψ k v) : ([∗map] k ↦ x ∈ m, Φ k x) ≡{n}≡ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] - apply BigOpL.congr_ne - intro i kv hget - have hi : i < (toList m).length := List.getElem?_eq_some_iff.mp hget |>.1 - have heq : (toList m)[i] = kv := List.getElem?_eq_some_iff.mp hget |>.2 - have hmem : kv ∈ toList m := heq ▸ List.getElem_mem hi - have hkv : get? m kv.1 = some kv.2 := (FiniteMapLaws.elem_of_map_to_list m kv.1 kv.2).mp hmem - exact h kv.1 kv.2 hkv + exact BigOpM.ne (op := sep) (unit := emp) Φ Ψ m n h /-- Corresponds to `big_sepM_mono'` in Rocq Iris. -/ theorem mono' {Φ Ψ : K → V → PROP} {m : M V} @@ -161,7 +135,7 @@ theorem flip_mono' {Φ Ψ : K → V → PROP} {m : M V} mono' h /-- Corresponds to `big_sepM_subseteq` in Rocq Iris. -/ -theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} [FiniteMapLawsSelf M K] [∀ k v, Affine (Φ k v)] +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} [FiniteMapLawsSelf K M] [∀ k v, Affine (Φ k v)] (h : m₂ ⊆ m₁) : ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by sorry @@ -225,15 +199,15 @@ instance affine {Φ : K → V → PROP} {m : M V} [∀ k v, Affine (Φ k v)] : /-! ## Logical Operations -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_sep` in Rocq Iris. -/ theorem sep' {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x ∗ Ψ k x) ⊣⊢ ([∗map] k ↦ x ∈ m, Φ k x) ∗ [∗map] k ↦ x ∈ m, Ψ k x := by simp only [bigSepM] - exact equiv_iff.mp (BigOpL.op_distr _ _ _) + exact equiv_iff.mp (BigOpM.op_distr (op := sep) (unit := emp) Φ Ψ m) -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_sep_2` in Rocq Iris. -/ theorem sep_2 {Φ Ψ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ∗ ([∗map] k ↦ x ∈ m, Ψ k x) ⊣⊢ @@ -376,7 +350,7 @@ theorem insert_override_2 {Φ : K → V → PROP} {m : M V} {k : K} {v v' : V} /-! ## Map Conversion -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_map_to_list` in Rocq Iris. -/ theorem map_to_list {Φ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ ([∗list] kv ∈ toList m, Φ kv.1 kv.2) := by @@ -385,7 +359,7 @@ theorem map_to_list {Φ : K → V → PROP} {m : M V} : /-! ## Persistently and Later -/ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Helper for persistently: induction on list. -/ private theorem persistently_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : iprop( bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ @@ -396,14 +370,14 @@ private theorem persistently_list {Φ : K × V → PROP} {l : List (K × V)} [BI simp only [bigOpL] exact persistently_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_persistently` in Rocq Iris. -/ theorem persistently {Φ : K → V → PROP} {m : M V} [BIAffine PROP] : iprop( [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, Φ k x := by simp only [bigSepM] exact persistently_list -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Helper for later: induction on list. -/ private theorem later_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine PROP] : iprop(▷ bigOpL sep emp (fun _ kv => Φ kv) l) ⊣⊢ @@ -414,14 +388,14 @@ private theorem later_list {Φ : K × V → PROP} {l : List (K × V)} [BIAffine simp only [bigOpL] exact later_sep.trans ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_later` in Rocq Iris. -/ theorem later [BIAffine PROP] {Φ : K → V → PROP} {m : M V} : iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷ Φ k x := by simp only [bigSepM] exact later_list -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Helper for later_2: induction on list. -/ private theorem later_2_list {Φ : K × V → PROP} {l : List (K × V)} : bigOpL sep emp (fun _ kv => iprop(▷ Φ kv)) l ⊢ @@ -432,14 +406,14 @@ private theorem later_2_list {Φ : K × V → PROP} {l : List (K × V)} : simp only [bigOpL] exact (sep_mono_r ih).trans later_sep.2 -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_later_2` in Rocq Iris. -/ theorem later_2 {Φ : K → V → PROP} {m : M V} : ([∗map] k ↦ x ∈ m, ▷ Φ k x) ⊢ iprop(▷ [∗map] k ↦ x ∈ m, Φ k x) := by simp only [bigSepM] exact later_2_list -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_laterN` in Rocq Iris. -/ theorem laterN [BIAffine PROP] {Φ : K → V → PROP} {m : M V} {n : Nat} : iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, ▷^[n] Φ k x := by @@ -447,7 +421,7 @@ theorem laterN [BIAffine PROP] {Φ : K → V → PROP} {m : M V} {n : Nat} : | zero => exact .rfl | succ k ih => exact (later_congr ih).trans later -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_laterN_2` in Rocq Iris. -/ theorem laterN_2 {Φ : K → V → PROP} {m : M V} {n : Nat} : ([∗map] k ↦ x ∈ m, ▷^[n] Φ k x) ⊢ iprop(▷^[n] [∗map] k ↦ x ∈ m, Φ k x) := by @@ -467,23 +441,13 @@ theorem fmap {Φ : K → V' → PROP} {m : M V} (f : V → V') : ([∗map] k ↦ y ∈ FiniteMap.map f m, Φ k y) ⊣⊢ [∗map] k ↦ y ∈ m, Φ k (f y) := by simp only [bigSepM] - have hperm := FiniteMapLaws.toList_map (K := K) m f - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.map f m)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (kv.1, f kv.2))) := - BigOpL.perm _ hperm - refine equiv_iff.mp heq |>.trans ?_ - clear heq hperm - induction (toList m) with - | nil => exact .rfl - | cons kv kvs ih => - simp only [List.map, bigOpL] - exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + exact equiv_iff.mp (BigOpM.fmap (op := sep) (unit := emp) f Φ m) end MapTransformations section FilterMapTransformations -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Helper lemma for omap: bigOpL over filterMapped list. -/ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : List (K × V)) : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) @@ -502,7 +466,7 @@ private theorem omap_list_aux {Φ : K → V → PROP} (f : V → Option V) (l : exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ /-- Corresponds to `big_sepM_omap` in Rocq Iris. -/ -theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : +theorem omap [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m : M V} (f : V → Option V) : ([∗map] k ↦ y ∈ FiniteMap.filterMap (M := M) f m, Φ k y) ⊣⊢ [∗map] k ↦ y ∈ m, match f y with | some y' => Φ k y' | none => emp := by simp only [bigSepM] @@ -513,17 +477,12 @@ theorem omap [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m : M V} (f : V exact equiv_iff.mp heq |>.trans (omap_list_aux f (toList m)) /-- Corresponds to `big_sepM_union` in Rocq Iris. -/ -theorem union [FiniteMapLawsSelf M K] {Φ : K → V → PROP} {m₁ m₂ : M V} +theorem union [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m₁ m₂ : M V} (hdisj : m₁ ##ₘ m₂) : ([∗map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∗map] k ↦ y ∈ m₁, Φ k y) ∗ [∗map] k ↦ y ∈ m₂, Φ k y := by simp only [bigSepM] - have hperm := toList_union_disjoint m₁ m₂ hdisj - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (m₁ ∪ m₂)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList m₁ ++ toList m₂) := - BigOpL.perm _ hperm - refine equiv_iff.mp heq |>.trans ?_ - exact equiv_iff.mp (BigOpL.append _ (toList m₁) (toList m₂)) + sorry end FilterMapTransformations @@ -533,8 +492,8 @@ end FilterMapTransformations theorem list_to_map {Φ : K → V → PROP} {l : List (K × V)} (hnodup : (l.map Prod.fst).Nodup) : ([∗map] k ↦ x ∈ (ofList l : M V), Φ k x) ⊣⊢ [∗list] kv ∈ l, Φ kv.1 kv.2 := by - simp only [bigSepM] - exact equiv_iff.mp (BigOpL.perm _ (FiniteMapLaws.map_to_list_to_map l hnodup)) + simp only [bigSepM, bigSepL] + exact equiv_iff.mp (BigOpM.list_to_map (op := sep) (unit := emp) Φ l hnodup) /-! ## Intro and Forall Lemmas -/ @@ -624,7 +583,7 @@ theorem impl {Φ Ψ : K → V → PROP} {m : M V} : refine (sep_mono_r h1).trans ?_ exact sep_2.1.trans (mono' fun _ _ => wand_elim_r) -omit [DecidableEq K] [FiniteMapLaws M K] in +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to `big_sepM_dup` in Rocq Iris. -/ theorem dup {P : PROP} [Affine P] {m : M V} : □ (P -∗ P ∗ P) ⊢ P -∗ [∗map] _k ↦ _x ∈ m, P := by @@ -731,7 +690,7 @@ theorem pure' [BIAffine PROP] {φ : K → V → Prop} {m : M V} : /-! ## Filter Lemmas -/ -variable [FiniteMapLawsSelf M K] +variable [FiniteMapLawsSelf K M] omit [DecidableEq K] in /-- Helper: bigOpL over filtered list. -/ @@ -802,7 +761,7 @@ theorem fnInsert_same {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : theorem fnInsert_ne {K B : Type _} [DecidableEq K] (f : K → B) (i : K) (b : B) (k : K) (h : k ≠ i) : fnInsert f i b k = f k := by simp [fnInsert, h] -omit [FiniteMapLawsSelf M K] in +omit [FiniteMapLawsSelf K M] in /-- Corresponds to `big_sepM_fn_insert` in Rocq Iris. -/ theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : M V} {i : K} {x : V} {b : B} (h : get? m i = none) : @@ -825,7 +784,6 @@ theorem fn_insert {B : Type _} {Ψ : K → V → B → PROP} {f : K → B} {m : exact OFE.Equiv.rfl exact hins.trans ⟨(sep_mono hhead.1 htail.1), (sep_mono hhead.2 htail.2)⟩ -omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_fn_insert'` in Rocq Iris. -/ theorem fn_insert' {Φ : K → PROP} {m : M V} {i : K} {x : V} {P : PROP} (h : get? m i = none) : @@ -838,12 +796,12 @@ theorem fn_insert' {Φ : K → PROP} {m : M V} {i : K} {x : V} {P : PROP} section MapZip variable {M₁ : Type _ → Type _} {M₂ : Type _ → Type _} {V₁ : Type _} {V₂ : Type _} -variable [FiniteMap M₁ K] [FiniteMapLaws M₁ K] -variable [FiniteMap M₂ K] [FiniteMapLaws M₂ K] +variable [FiniteMap K M₁] [FiniteMapLaws K M₁] +variable [FiniteMap K M₂] [FiniteMapLaws K M₂] -omit [FiniteMapLaws M₁ K] [FiniteMapLaws M₂ K] in +omit [FiniteMapLaws K M₁] [FiniteMapLaws K M₂] in /-- Corresponds to `big_sepM_sep_zip_with` in Rocq Iris. -/ -theorem sep_zip_with {C : Type _} {MZ : Type _ → Type _} [FiniteMap MZ K] [FiniteMapLaws MZ K] +theorem sep_zip_with {C : Type _} {MZ : Type _ → Type _} [FiniteMap K MZ] [FiniteMapLaws K MZ] {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} {f : V₁ → V₂ → C} {g₁ : C → V₁} {g₂ : C → V₂} {m₁ : M₁ V₁} {m₂ : M₂ V₂} {mz : MZ C} @@ -893,10 +851,9 @@ theorem sep_zip_with {C : Type _} {MZ : Type _ → Type _} [FiniteMap MZ K] [Fin hmap₂.trans heq₂.symm exact equiv_iff.mp (Monoid.op_proper h₁ h₂) -omit [FiniteMapLaws M₁ K] [FiniteMapLaws M₂ K] in +omit [FiniteMapLaws K M₂] in /-- Corresponds to `big_sepM_sep_zip` in Rocq Iris. -/ -theorem sep_zip [FiniteMap M₁ K] [FiniteMapLaws M₁ K] [FiniteMap M₂ K] [FiniteMapLaws M₂ K] - {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} +theorem sep_zip {Φ₁ : K → V₁ → PROP} {Φ₂ : K → V₂ → PROP} {m₁ : M₁ V₁} {m₂ : M₂ V₂} {mz : M₁ (V₁ × V₂)} (hdom : ∀ k, (get? m₁ k).isSome ↔ (get? m₂ k).isSome) (hperm : (toList mz).Perm @@ -917,11 +874,10 @@ end MapZip /-! ## Advanced Impl Lemmas -/ -omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_impl_strong` in Rocq Iris. Strong version of impl that tracks which keys are in m₂ vs only in m₁. -/ -theorem impl_strong [FiniteMapLawsSelf M K] {M₂ : Type _ → Type _} {V₂ : Type _} - [FiniteMap M₂ K] [FiniteMapLaws M₂ K] [DecidableEq V₂] +theorem impl_strong {M₂ : Type _ → Type _} {V₂ : Type _} + [FiniteMap K M₂] [FiniteMapLaws K M₂] [DecidableEq V₂] {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M V} {m₂ : M₂ V₂} : ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ □ (∀ k, ∀ y, (match get? m₁ k with | some x => Φ k x | none => emp) -∗ @@ -1033,11 +989,10 @@ theorem impl_strong [FiniteMapLawsSelf M K] {M₂ : Type _ → Type _} {V₂ : T (sep_mono_r (sep_mono_r hweaken)).trans <| (sep_mono_r (IH (Std.delete m₁ i))).trans <| (sep_mono_r (sep_mono_r hfilter_equiv.2)).trans <| sep_assoc.2.trans (sep_mono_l hinsert_goal.2) -omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_impl_dom_subseteq` in Rocq Iris. Specialized version when the domain of m₂ is a subset of the domain of m₁. -/ -theorem impl_dom_subseteq [FiniteMapLawsSelf M K] {M₂ : Type _ → Type _} {V₂ : Type _} - [FiniteMap M₂ K] [FiniteMapLaws M₂ K] [DecidableEq V₂] +theorem impl_dom_subseteq {M₂ : Type _ → Type _} {V₂ : Type _} + [FiniteMap K M₂] [FiniteMapLaws K M₂] [DecidableEq V₂] {Φ : K → V → PROP} {Ψ : K → V₂ → PROP} {m₁ : M V} {m₂ : M₂ V₂} (_hdom : ∀ k, (get? m₂ k).isSome → (get? m₁ k).isSome) : ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ @@ -1070,37 +1025,19 @@ section Kmap variable {K₂ : Type _} {M₂ : Type _ → Type _} variable [DecidableEq K₂] -variable [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] -/-- Key map: apply a function to all keys in a map. - `kmap h m` has entries `(h k, v)` for each `(k, v)` in `m`. - Requires `h` to be injective to preserve map semantics. -/ -def kmap (h : K → K₂) (m : M V) : M₂ V := - ofList ((toList m).map (fun kv => (h kv.1, kv.2))) - -omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in +omit [DecidableEq V] [FiniteMapLawsSelf K M] [DecidableEq K₂] in /-- Corresponds to `big_sepM_kmap` in Rocq Iris. Note: The Rocq proof uses `map_to_list_kmap` (which we encode as `hperm`) and `big_opL_fmap`. The `hinj` (injectivity) is needed in Rocq for `kmap` to be well-defined; here we take an explicit permutation witness instead. -/ -theorem kmap' [DecidableEq K₂] [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] +theorem kmap [DecidableEq K₂] [FiniteMap K₂ M₂] [FiniteMapLaws K₂ M₂] [FiniteMapKmapLaws K K₂ M M₂] {Φ : K₂ → V → PROP} {m : M V} - (h : K → K₂) (_hinj : Function.Injective h) - (hperm : (toList (kmap h m : M₂ V)).Perm - ((toList m).map (fun kv => (h kv.1, kv.2)))) : - ([∗map] k₂ ↦ y ∈ (kmap h m : M₂ V), Φ k₂ y) ⊣⊢ - [∗map] k₁ ↦ y ∈ m, Φ (h k₁) y := by - simp only [bigSepM] - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) (toList (kmap h m : M₂ V)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) ((toList m).map (fun kv => (h kv.1, kv.2))) := - BigOpL.perm _ hperm - refine equiv_iff.mp heq |>.trans ?_ - clear heq hperm - induction (toList m) with - | nil => exact .rfl - | cons kv kvs ih => - simp only [List.map, bigOpL] - exact ⟨sep_mono_r ih.1, sep_mono_r ih.2⟩ + (f : K → K₂) + (hinj : ∀ {x y}, f x = f y → x = y): + ([∗map] k₂ ↦ y ∈ (FiniteMap.kmap f m : M₂ V), Φ k₂ y) ⊣⊢ + [∗map] k₁ ↦ y ∈ m, Φ (f k₁) y := by + exact equiv_iff.mp (@BigOpM.kmap PROP _ sep emp _ M K V _ _ _ M₂ K₂ _ _ _ _ f @hinj Φ m) end Kmap @@ -1108,22 +1045,17 @@ end Kmap section ListToMap -variable [FiniteMap M Nat] -variable [FiniteMapLaws M Nat] +variable [FiniteMap Nat M] +variable [FiniteMapLaws Nat M] variable [FiniteMapSeqLaws M] +omit [DecidableEq V] in /-- Corresponds to `big_sepM_map_seq` in Rocq Iris. -/ theorem map_seq {Φ : Nat → V → PROP} (start : Nat) (l : List V) : ([∗map] k ↦ x ∈ (FiniteMap.map_seq start l : M V), Φ k x) ⊣⊢ ([∗list] i ↦ x ∈ l, Φ (start + i) x) := by simp only [bigSepM, bigSepL] - have h1 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) (toList (FiniteMap.map_seq start l : M V)) ≡ - bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) := - BigOpL.perm (fun kv => Φ kv.fst kv.snd) (toList_map_seq (M := M) start l) - have h2 : bigOpL sep iprop(emp) (fun _ kv => Φ kv.fst kv.snd) ((List.range' start l.length).zip l) ≡ - bigOpL sep iprop(emp) (fun i x => Φ (start + i) x) l := - BigOpL.zip_seq (fun p => Φ p.1 p.2) start l - exact equiv_iff.mp (h1.trans h2) + exact equiv_iff.mp (BigOpM.map_seq (op := sep) (unit := emp) Φ start l) end ListToMap @@ -1132,13 +1064,12 @@ end ListToMap section DomainSet variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] -variable [FiniteMapLawsSelf M K] -omit [FiniteMapLawsSelf M K] in +omit [FiniteMapLawsSelf K M] in /-- Corresponds to `big_sepM_dom` in Rocq Iris. -/ theorem dom {Φ : K → PROP} (m : M V) : ([∗map] k ↦ _v ∈ m, Φ k) ⊣⊢ ([∗set] k ∈ (domSet m : S), Φ k) := by - induction m using @FiniteMapLaws.map_ind M K V _ _ _ with + induction m using @FiniteMapLaws.map_ind K M _ _ _ with | hemp => rw [domSet_empty] exact ⟨empty.1.trans BigSepS.empty.2, BigSepS.empty.1.trans empty.2⟩ @@ -1231,7 +1162,6 @@ theorem dom {Φ : K → PROP} (m : M V) : _ ⊣⊢ ([∗set] k' ∈ FiniteSet.singleton k ∪ (domSet m : S), Φ k') := (BigSepS.insert hk_not_in_dom).symm _ ⊣⊢ ([∗set] k' ∈ (domSet (FiniteMap.insert m k v) : S), Φ k') := by rw [hdom_eq]; exact .rfl -omit [FiniteMapLawsSelf M K] in /-- Corresponds to `big_sepM_gset_to_gmap` in Rocq Iris. -/ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k a) ⊣⊢ ([∗set] k ∈ X, Φ k c) := by @@ -1264,7 +1194,7 @@ end DomainSet /-! ## Commuting Lemmas -/ -omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in +omit [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] [DecidableEq V] in /-- Corresponds to `big_sepM_sepL` in Rocq Iris. -/ theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M V) (l : List B) : ([∗map] k↦x ∈ m, [∗list] k'↦y ∈ l, Φ k x k' y) ⊣⊢ @@ -1277,10 +1207,10 @@ theorem sepL {B : Type _} (Φ : K → V → Nat → B → PROP) (m : M V) (l : L _ ⊣⊢ [∗list] k'↦y ∈ l, [∗map] k↦x ∈ m, Φ k x k' y := equiv_iff.mp <| BigSepL.congr fun k' y => .rfl -omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in +omit [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] [DecidableEq V] in /-- Corresponds to `big_sepM_sepM` in Rocq Iris. -/ theorem sepM {M₂ : Type _ → Type _} {K₂ : Type _} {V₂ : Type _} - [DecidableEq K₂] [FiniteMap M₂ K₂] [FiniteMapLaws M₂ K₂] + [DecidableEq K₂] [FiniteMap K₂ M₂] [FiniteMapLaws K₂ M₂] (Φ : K → V → K₂ → V₂ → PROP) (m₁ : M V) (m₂ : M₂ V₂) : ([∗map] k₁↦x₁ ∈ m₁, [∗map] k₂↦x₂ ∈ m₂, Φ k₁ x₁ k₂ x₂) ⊣⊢ ([∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂) := by @@ -1297,7 +1227,7 @@ theorem sepM {M₂ : Type _ → Type _} {K₂ : Type _} {V₂ : Type _} _ ⊣⊢ [∗map] k₂↦x₂ ∈ m₂, [∗map] k₁↦x₁ ∈ m₁, Φ k₁ x₁ k₂ x₂ := equiv_iff.mp <| BigSepL.congr fun _ kv₂ => .rfl -omit [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] in +omit [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] [DecidableEq V] in /-- Corresponds to `big_sepM_sepS` in Rocq Iris. -/ theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean index 2a12bd06..b751405d 100644 --- a/src/Iris/BI/BigOp/BigSepSet.lean +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -942,7 +942,7 @@ theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSe omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_sepM` in Rocq Iris. -/ theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} - [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] + [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] (Φ : A → K → B → PROP) (X : S) (m : M B) : ([∗set] x ∈ X, [∗map] k↦y ∈ m, Φ x k y) ⊣⊢ ([∗map] k↦y ∈ m, [∗set] x ∈ X, Φ x k y) := by diff --git a/src/Iris/Std/FiniteMap.lean b/src/Iris/Std/FiniteMap.lean index 7fc67edf..2920c48c 100644 --- a/src/Iris/Std/FiniteMap.lean +++ b/src/Iris/Std/FiniteMap.lean @@ -28,7 +28,7 @@ namespace Iris.Std The type `M` represents a finite map from keys of type `K` to values of type `V`. This corresponds to Rocq's `FinMap` class from stdpp. -/ -class FiniteMap (M : Type u → Type _) (K : outParam (Type v)) where +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` (notation `!!`). -/ get? : M V → K → Option V @@ -49,13 +49,13 @@ class FiniteMap (M : Type u → Type _) (K : outParam (Type v)) where /-- 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 _} : (K → V → A → A) → A → M V → A + fold {A : Type u'} : (K → V → A → A) → A → M V → A export FiniteMap (get? insert delete toList ofList fold) namespace FiniteMap -variable {M : Type u → Type _} {K : Type v} [FiniteMap M K] {V : Type _} +variable {K : Type u} {V : Type u'} {M : Type u' → Type _} [FiniteMap K M] /-- Empty map instance for `∅` notation. -/ instance : EmptyCollection (M V) := ⟨empty⟩ @@ -131,13 +131,13 @@ instance : SDiff (M V) := ⟨difference⟩ Given `f : K → K'`, `kmap f m` transforms a map with keys of type `K` into a map with keys of type `K'`. Corresponds to Rocq's `kmap`. -/ -def kmap {M' : Type _ → _} {K' : Type v'} [FiniteMap M' K'] (f : K → K') (m : M V) : (M' V) := +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`. `map_seq start [v₀, v₁, v₂, ...]` creates a map `{start ↦ v₀, start+1 ↦ v₁, start+2 ↦ v₂, ...}`. Corresponds to Rocq's `map_seq`. -/ -def map_seq [FiniteMap M Nat] (start : Nat) (l : List V) : M V := +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. @@ -153,13 +153,13 @@ def map_Forall (P : K → V → Prop) (m : M V) : Prop := end FiniteMap /-- Membership instance for finite maps: `k ∈ m` means the key `k` is in the map `m`. -/ -instance {M : Type u → Type _} {K : Type v} [inst : FiniteMap M K] : Membership K (M V) := +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. Corresponds to Rocq's `FinMap` class axioms. -/ -class FiniteMapLaws (M : Type u → Type _) (K : Type _) - [DecidableEq K] [FiniteMap M K] where +class FiniteMapLaws (K : (outParam (Type u))) (M : Type u' → Type _) + [DecidableEq K] [FiniteMap K M] where /-- Corresponds to Rocq's `map_eq`. -/ map_eq : ∀ (m₁ m₂ : M V), (∀ i, get? m₁ i = get? m₂ i) → m₁ = m₂ /-- Corresponds to Rocq's `lookup_empty`. -/ @@ -183,24 +183,18 @@ class FiniteMapLaws (M : Type u → Type _) (K : Type _) /-- 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 - /-- Folding over the empty map returns the initial accumulator. - Corresponds to Rocq's `map_fold_empty`. -/ - fold_empty : ∀ {A : Type u'} (f : K → V → A → A) (b : A), - fold f b (∅ : M V) = b - fold_fmap_ind (P : M V → Prop) : - P ∅ → - (∀ i x m, - get? m i = none → - (∀ A' B (f : K → A' → B → B) (g : V → A') b x', - fold f b (insert ((FiniteMap.map g m)) i x') = f i x' (fold f b (FiniteMap.map g m))) → - P m → - P (insert m i x)) → - ∀ m, P m - + /-- Corresponds to Rocq's `map_to_list_spec`. -/ + map_to_list_spec (m : M V) : + (toList m).Nodup ∧ (∀ i x, (i, x) ∈ toList m ↔ get? m i = some x) + /-- Corresponds to Rocq's `map_ind`. -/ + map_ind {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 (for filterMap, filter on the same type). -/ -class FiniteMapLawsSelf (M : Type u → _) (K : Type v) - [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] where +class FiniteMapLawsSelf (K : outParam (Type u)) (M : Type u' → Type _) + [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] where /-- toList of filterMap (omap) is related to filterMap over toList. -/ toList_filterMap : ∀ (m : M V) (f : V → Option V), (toList (FiniteMap.filterMap (M := M) f m)).Perm @@ -209,23 +203,12 @@ class FiniteMapLawsSelf (M : Type u → _) (K : Type v) toList_filter : ∀ (m : M V) (φ : K → V → Bool), (toList (FiniteMap.filter (M := M) φ m)).Perm ((toList m).filter (fun kv => φ kv.1 kv.2)) - /-- toList of union for disjoint maps. - Corresponds to Rocq's implicit behavior from `map_to_list_union`. -/ - toList_union_disjoint : ∀ (m₁ m₂ : M V), - FiniteMap.Disjoint m₁ m₂ → - (toList (m₁ ∪ m₂)).Perm (toList m₁ ++ toList m₂) - /-- toList of difference is related to filter over toList. -/ - toList_difference : ∀ (m₁ m₂ : M V), - (toList (m₁ \ m₂)).Perm - ((toList m₁).filter (fun kv => (get? m₂ kv.1).isNone)) /-- Laws for kmap operation (key transformation). -/ -class FiniteMapKmapLaws (M : Type _ → _) (M' : Type _ → _) (K : Type _) (K' : Type _) - [DecidableEq K] [DecidableEq K'] [FiniteMap M K] [FiniteMap M' K'] - [FiniteMapLaws M K] [FiniteMapLaws M' K'] where +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. - For an injective function `f : K → K'`, `toList (kmap f m)` is a permutation of - `(toList m).map (fun (k, v) => (f k, v))`. 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 @@ -233,7 +216,7 @@ class FiniteMapKmapLaws (M : Type _ → _) (M' : Type _ → _) (K : Type _) (K' ((toList m).map (fun (k, v) => (f k, v))) /-- Laws for map_seq operation (list to indexed map). -/ -class FiniteMapSeqLaws (M : Type u → _) [FiniteMap M Nat] [FiniteMapLaws M Nat] where +class FiniteMapSeqLaws (M : Type u → Type _) [FiniteMap Nat M] [FiniteMapLaws Nat M] where /-- toList of map_seq is related to zip with sequence. `toList (map_seq start l)` is a permutation of `zip (seq start (length l)) l`. Corresponds to Rocq's `map_to_list_seq`. -/ @@ -241,18 +224,22 @@ class FiniteMapSeqLaws (M : Type u → _) [FiniteMap M Nat] [FiniteMapLaws M Nat (toList (FiniteMap.map_seq start l : M V)).Perm ((List.range' start l.length).zip l) -export FiniteMapLaws (map_eq lookup_empty lookup_insert_eq lookup_insert_ne lookup_delete_eq -lookup_delete_ne -ofList_nil ofList_cons fold_empty fold_fmap_ind) +export FiniteMapLaws (map_eq +lookup_empty +lookup_insert_eq lookup_insert_ne +lookup_delete_eq lookup_delete_ne +ofList_nil ofList_cons +map_to_list_spec +map_ind) -export FiniteMapLawsSelf (toList_filterMap toList_filter toList_union_disjoint toList_difference) +export FiniteMapLawsSelf (toList_filterMap toList_filter) export FiniteMapKmapLaws (toList_kmap) export FiniteMapSeqLaws (toList_map_seq) namespace FiniteMapLaws -variable {M : Type _ → _} {K : Type v} {V : Type _} -variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] +variable {K : Type u} {V : Type u'} {M : Type u' → Type _} +variable [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] /-- Auxiliary lemma: if get? (ofList l) k = some v, then (k, v) ∈ l -/ private theorem mem_of_get?_ofList (l : List (K × V)) (k : K) (v : V) : @@ -303,20 +290,6 @@ theorem lookup_insert_delete (m : M V) (k k' : K) (v : V) : · simp [h, lookup_insert_eq] · simp [lookup_insert_ne _ _ _ _ h, lookup_delete_ne _ _ _ h] -/-- Corresponds to Rocq's `map_to_list_spec`. - Rocq proof: - apply (map_fold_weak_ind (λ l m, - NoDup l ∧ ∀ i x, (i,x) ∈ l ↔ m !! i = Some x)); clear m. - { split; [constructor|]. intros i x. by rewrite elem_of_nil, lookup_empty. } - intros i x m l ? [IH1 IH2]. split; [constructor; naive_solver|]. - intros j y. rewrite elem_of_cons, IH2. - unfold insert, map_insert. destruct (decide (i = j)) as [->|]. - - rewrite lookup_partial_alter_eq. naive_solver. - - rewrite lookup_partial_alter_ne by done. naive_solver. --/ -private theorem map_to_list_spec (m : M V) : - (toList m).Nodup ∧ (∀ i x, (i, x) ∈ toList m ↔ get? m i = some x) := by sorry - /-- Corresponds to Rocq's `NoDup_map_to_list`. -/ theorem NoDup_map_to_list (m : M V): (toList m).Nodup := by apply (map_to_list_spec m).1 @@ -355,7 +328,7 @@ theorem NoDup_map_to_list_keys (m : M V): (toList m).map Prod.fst |>.Nodup := by -- We have (k₁, v₁) and (k₂, v₂) both in toList m with k₁ = k₂ simp at heq -- By map_to_list_spec, both satisfy: get? m kᵢ = some vᵢ - have ⟨_, hmem⟩ := map_to_list_spec m + obtain ⟨_, hmem⟩ := map_to_list_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 -- Since k₁ = k₂, we have get? m k₁ = get? m k₂ @@ -367,7 +340,7 @@ theorem NoDup_map_to_list_keys (m : M V): (toList m).map Prod.fst |>.Nodup := by ext <;> simp [heq] /-- Corresponds to Rocq's `elem_of_map_to_list`. -/ -theorem elem_of_map_to_list (m : M V) : ∀ k v, (k, v) ∈ toList m ↔ get? m k = some v := by +theorem elem_of_map_to_list (m : M V) : ∀ k v, (k, v) ∈ toList m ↔ get? m k = some v := by apply (map_to_list_spec m).2 /-- Corresponds to Rocq's `elem_of_list_to_map_2`. -/ @@ -419,11 +392,12 @@ theorem elem_of_list_to_map_1 (l : List (K × V)) (i : K) (x : V) : have : get? (ofList l : M V) i = some x := ih hnodup_tail hmem' rw [ofList_cons, lookup_insert_ne _ _ _ _ hne, this] -/-- Corresponds to Rocq's `elem_of_list_to_map` -Rocq Proof: - split; auto using elem_of_list_to_map_1, elem_of_list_to_map_2. -/ +/-- Corresponds to Rocq's `elem_of_list_to_map` -/ theorem elem_of_list_to_map (l : List (K × V)) i x (hnodup : (l.map Prod.fst).Nodup): - (i,x) ∈ l ↔ get? (ofList l : M V) i = some x := by sorry + (i,x) ∈ l ↔ get? (ofList l : M V) i = some x := by + constructor + apply elem_of_list_to_map_1; exact hnodup + apply elem_of_list_to_map_2 /-- Corresponds to Rocq's `list_to_map_inj`. -/ theorem list_to_map_inj [DecidableEq V] (l1 l2 : List (K × V)) : @@ -466,7 +440,7 @@ theorem list_to_map_to_list (m : M V) : apply list_to_map_inj (M := M) (K:=K) · exact NoDup_map_to_list_keys (M := M) (K := K) (V := V) (ofList l) · exact hnodup - rw [list_to_map_to_list] + rw [list_to_map_to_list] /-- Two maps with the same get? behavior have permutation-equivalent toLists. -/ theorem toList_perm_eq_of_get?_eq [DecidableEq V] {m₁ m₂ : M V} @@ -591,12 +565,17 @@ theorem insert_delete_id (m : M V) (i : K) (x : V) : simp [lookup_insert_eq, h] · simp [lookup_insert_ne _ _ _ _ hij, lookup_delete_ne _ _ _ hij] - - /-- Corresponds to Rocq's `map_to_list_empty`. - Rocq proof: - apply elem_of_nil_inv. intros [i x]. - rewrite elem_of_map_to_list. apply lookup_empty_Some. -/ -theorem map_to_list_empty : toList (∅ : M V) = [] := by sorry + /-- Corresponds to Rocq's `map_to_list_empty`. -/ +theorem map_to_list_empty : toList (∅ : M V) = [] := by + -- Show that the list is empty by proving no element can be in it + apply List.eq_nil_iff_forall_not_mem.mpr + intro ⟨i, x⟩ hmem + -- Use elem_of_map_to_list to rewrite membership + rw [elem_of_map_to_list] at hmem + -- Now we have get? ∅ i = some x, but lookup_empty says get? ∅ i = none + rw [lookup_empty] at hmem + -- Contradiction: none ≠ some x + exact Option.noConfusion hmem /-- Corresponds to Rocq's `map_to_list_insert`. -/ theorem map_to_list_insert [DecidableEq V] : ∀ (m : M V) k v, get? m k = none → @@ -649,100 +628,6 @@ theorem eq_empty_iff (m : M V) : m = ∅ ↔ ∀ k, get? m k = none := by intro k rw [h, lookup_empty] -/-- Corresponds to Rocq's `map_ind`. -/ -theorem map_ind {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 := by - -- Use fold_fmap_ind to prove map_ind - apply fold_fmap_ind P hemp - intro i x m hi _ hPm - exact hins i x m hi hPm - -/-- Corresponds to Rocq's `map_fold_ind` -Rocq proof: - intros Hemp Hins m. - induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind; [done|]. - apply Hins; [done| |done]. intros B f b x'. - assert (m = id <$> m) as →. - { apply map_eq; intros j; by rewrite lookup_fmap, option_fmap_id. } - apply Hfold. - -/ -private theorem map_fold_ind (P : M V → Prop) : - P ∅ → - (∀ i x m, - get? m i = none → - (∀ B (f : K → V → B → B) b x', - fold f b (insert m i x') = f i x' (fold f b m)) → - P m → - P (insert m i x)) → - ∀ m, P m := by sorry - - -/-- Corresponds to Rocq's `map_fold_weak_ind`. -/ -theorem fold_weak_ind {B : Type u''} - (P : B → M V → Prop) (f : K → V → B → B) (b : B) - (hemp : P b ∅) - (hins : ∀ i x m r, get? m i = none → P r m → P (f i x r) (insert m i x)) - (m : M V) : P (fold f b m) m := by - sorry - -/-- Induction principle with first key constraint: prove properties about maps by induction, - where the inductive step requires that the inserted key becomes the first key. - - Corresponds to Rocq's `map_first_key_ind`. -/ -theorem map_first_key_ind (P : M V → Prop) - (hemp : P ∅) - (hins : ∀ i x m, get? m i = none → FiniteMap.firstKey (insert m i x) i → P m → P (insert m i x)) - (m : M V) : P m := by - sorry - -/-- Corresponds to Rocq's `map_fold_foldr` -Rocq proof: - unfold map_to_list. induction m as [|i x m ? Hfold IH] using map_fold_ind. - - by rewrite !map_fold_empty. - - by rewrite !Hfold, IH. --/ -theorem fold_foldr (f : K → V → B → B) b (m : M V) : - fold f b m = List.foldr (fun ⟨k, v⟩ b => f k v b) b (toList m) := by sorry - - -/-- Corresponds to Rocq's `map_fold_fmap` -Rocq Proof: - induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind. - { by rewrite fmap_empty, !map_fold_empty. } - rewrite fmap_insert. rewrite <-(map_fmap_id m) at 2. rewrite !Hfold. - by rewrite IH, map_fmap_id. -/ -theorem fold_map (f : K → V' → B → B) (g : V → V') b (m : M V) : - fold f b (FiniteMap.map g m) = fold (fun i => f i ∘ g) b m := by sorry - - -/-- toList of map (fmap) is a permutation of mapping over toList. - This is a weaker form that we can prove without the fold-based infrastructure. - The stronger equality version (`toList_map_eq`) would require `fold_map` and `fold_foldr`. -/ -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] - -- toList (ofList ((toList m).map g)) is Perm to (toList m).map g - -- where g = fun kv => (kv.1, f kv.2) - apply map_to_list_to_map - -- Need to show: ((toList m).map g).map Prod.fst |>.Nodup - simp only [List.map_map] - show ((toList m).map (fun x => x.1)).Nodup - exact NoDup_map_to_list_keys m - -/-- toList of map (fmap) equals mapping over toList (equality version). - `toList (map f m) = (toList m).map (fun (k, v) => (k, f v))` - Corresponds to Rocq's `map_to_list_fmap` - Rocq proof: - unfold map_to_list. rewrite map_fold_fmap, !map_fold_foldr. - induction (map_to_list m) as [|[]]; f_equal/=; auto. - This requires `fold_map` and `fold_foldr` which are currently unimplemented. -/ -theorem toList_map_eq [DecidableEq V'] : ∀ (m : M V) (f : V → V'), - toList (FiniteMap.map f m) = - ((toList m).map (fun kv => (kv.1, f kv.2))) := by sorry /-- Corresponds to Rocq's `delete_delete_eq`. -/ theorem delete_delete_eq (m : M V) (i : K) : @@ -834,6 +719,7 @@ theorem insert_id' (m : M V) (i : K) (x : V) : simp [lookup_insert_eq, h] · simp [lookup_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 = FiniteMap.singleton i x := by @@ -947,6 +833,7 @@ theorem map_Forall_empty (P : K → V → Prop) : FiniteMap.map_Forall P (∅ : intro k v h simp [lookup_empty] at h +omit [DecidableEq K] [FiniteMapLaws K M] in /-- Corresponds to Rocq's `map_Forall_impl`. -/ theorem map_Forall_impl (P Q : K → V → Prop) (m : M V) : FiniteMap.map_Forall P m → (∀ k v, P k v → Q k v) → FiniteMap.map_Forall Q m := by @@ -1013,6 +900,7 @@ theorem map_Forall_delete (P : K → V → Prop) (m : M V) (i : K) : · simp [lookup_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 map_disjoint_spec (m₁ m₂ : M V) : FiniteMap.Disjoint m₁ m₂ ↔ ∀ k, get? m₁ k = none ∨ get? m₂ k = none := by @@ -1092,6 +980,22 @@ theorem map_disjoint_singleton_r (m : M V) (i : K) (x : V) : simp [hi] at hs1 · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs2 +/-- toList of map (fmap) is a permutation of mapping over toList. + This is a weaker form that we can prove without the fold-based infrastructure. + The stronger equality version (`toList_map_eq`) would require `fold_map` and `fold_foldr`. -/ +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] + -- toList (ofList ((toList m).map g)) is Perm to (toList m).map g + -- where g = fun kv => (kv.1, f kv.2) + apply map_to_list_to_map + -- Need to show: ((toList m).map g).map Prod.fst |>.Nodup + simp only [List.map_map] + show ((toList m).map (fun x => x.1)).Nodup + exact NoDup_map_to_list_keys m + /-- Corresponds to Rocq's `map_fmap_zip_with_r`. When `g1 (f x y) = x` and the domains of m1 and m2 match, mapping g1 over zipWith f m1 m2 gives back m1 (up to map equality). -/ @@ -1114,9 +1018,81 @@ theorem map_fmap_zipWith_l {V' V'' : Type _} [DecidableEq V'] [DecidableEq V''] end FiniteMapLaws +-- namespace FiniteMapLawsFold + +-- variable {M : Type _ → _} {K : Type v} {V : Type _} +-- variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] [FiniteMapLawsFold M K] +-- /-- Corresponds to Rocq's `map_fold_fmap` +-- Rocq Proof: +-- induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind. +-- { by rewrite fmap_empty, !map_fold_empty. } +-- rewrite fmap_insert. rewrite <-(map_fmap_id m) at 2. rewrite !Hfold. +-- by rewrite IH, map_fmap_id. -/ +-- theorem fold_map (f : K → V' → B → B) (g : V → V') b (m : M V) : +-- fold f b (FiniteMap.map g m) = fold (fun i => f i ∘ g) b m := by sorry + +-- /-- toList of map (fmap) equals mapping over toList (equality version). +-- `toList (map f m) = (toList m).map (fun (k, v) => (k, f v))` +-- Corresponds to Rocq's `map_to_list_fmap` +-- Rocq proof: +-- unfold map_to_list. rewrite map_fold_fmap, !map_fold_foldr. +-- induction (map_to_list m) as [|[]]; f_equal/=; auto. -/ +-- theorem toList_map_eq [DecidableEq V'] : ∀ (m : M V) (f : V → V'), +-- toList (FiniteMap.map f m) = +-- ((toList m).map (fun kv => (kv.1, f kv.2))) := by sorry + + +-- /-- Corresponds to Rocq's `map_fold_ind` +-- Rocq proof: +-- intros Hemp Hins m. +-- induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind; [done|]. +-- apply Hins; [done| |done]. intros B f b x'. +-- assert (m = id <$> m) as →. +-- { apply map_eq; intros j; by rewrite lookup_fmap, option_fmap_id. } +-- apply Hfold. +-- -/ +-- private theorem map_fold_ind (P : M V → Prop) : +-- P ∅ → +-- (∀ i x m, +-- get? m i = none → +-- (∀ B (f : K → V → B → B) b x', +-- fold f b (insert m i x') = f i x' (fold f b m)) → +-- P m → +-- P (insert m i x)) → +-- ∀ m, P m := by sorry + +-- /-- Corresponds to Rocq's `map_fold_weak_ind`. -/ +-- theorem fold_weak_ind {B : Type u''} +-- (P : B → M V → Prop) (f : K → V → B → B) (b : B) +-- (hemp : P b ∅) +-- (hins : ∀ i x m r, get? m i = none → P r m → P (f i x r) (insert m i x)) +-- (m : M V) : P (fold f b m) m := by +-- sorry + +-- /-- Induction principle with first key constraint: prove properties about maps by induction, +-- where the inductive step requires that the inserted key becomes the first key. + +-- Corresponds to Rocq's `map_first_key_ind`. -/ +-- theorem map_first_key_ind (P : M V → Prop) +-- (hemp : P ∅) +-- (hins : ∀ i x m, get? m i = none → FiniteMap.firstKey (insert m i x) i → P m → P (insert m i x)) +-- (m : M V) : P m := by +-- sorry + +-- /-- Corresponds to Rocq's `map_fold_foldr` +-- Rocq proof: +-- unfold map_to_list. induction m as [|i x m ? Hfold IH] using map_fold_ind. +-- - by rewrite !map_fold_empty. +-- - by rewrite !Hfold, IH. +-- -/ +-- theorem fold_foldr (f : K → V → B → B) b (m : M V) : +-- fold f b m = List.foldr (fun ⟨k, v⟩ b => f k v b) b (toList m) := by sorry + +-- end FiniteMapLawsFold + namespace FiniteMap -variable {M : Type _ → _} {K : Type v} {V : Type w} [FiniteMap M K] +variable {K : Type v} {M : Type u → _} [FiniteMap K M] /-- Submap is reflexive. -/ theorem submap_refl (m : M V) : m ⊆ m := fun _ _ h => h @@ -1129,18 +1105,18 @@ theorem submap_trans {m₁ m₂ m₃ : M V} (h₁ : m₁ ⊆ m₂) (h₂ : m₂ theorem disjoint_symm {m₁ m₂ : M V} (h : Disjoint m₁ m₂) : Disjoint m₂ m₁ := fun k ⟨h₂, h₁⟩ => h k ⟨h₁, h₂⟩ -theorem map_disjoint_empty_r [DecidableEq K] [FiniteMapLaws M K] (m : M V) : Disjoint m (∅ : M V) := - disjoint_symm (FiniteMapLaws.map_disjoint_empty_l m) +theorem map_disjoint_empty_r [DecidableEq K] [FiniteMapLaws K M] (m : M V) : Disjoint m (∅ : M V) := + disjoint_symm (FiniteMapLaws.map_disjoint_empty_l (K:= K) m) /-- `m₂` and `m₁ \ m₂` are disjoint. -/ -theorem disjoint_difference_r [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] +theorem disjoint_difference_r [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] (m₁ m₂ : M V) : Disjoint m₂ (m₁ \ m₂) := by intro k ⟨h_in_m2, h_in_diff⟩ rw [FiniteMapLaws.lookup_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 map_difference_union [DecidableEq K] [FiniteMapLaws M K] [FiniteMapLawsSelf M K] +theorem map_difference_union [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] (m₁ m₂ : M V) (hsub : m₂ ⊆ m₁) : m₂ ∪ (m₁ \ m₂) = m₁ := by apply FiniteMapLaws.map_eq (M := M) (K := K) (V := V) intro k diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index 425a7313..f8d8d6d0 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -18,8 +18,8 @@ namespace Iris.Std open FiniteMap FiniteSet -variable {M : Type _ → _} {K : Type _} -variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] +variable {K : Type _} {M : Type _ → _} +variable [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] section DomainSet diff --git a/src/Iris/Std/FiniteMapInst.lean b/src/Iris/Std/FiniteMapInst.lean index 37bb15d6..cd57299c 100644 --- a/src/Iris/Std/FiniteMapInst.lean +++ b/src/Iris/Std/FiniteMapInst.lean @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Zongyuan Liu -/ import Iris.Std.FiniteMap +import Iris.Std.List import Std /-! ## FiniteMap Instance for Std.ExtTreeMap @@ -18,22 +19,22 @@ which is a balanced binary search tree implementation. namespace Iris.Std /-- Instance of FiniteMap for Std.ExtTreeMap. -/ -instance {K : Type _} [Ord K] [Std.TransCmp (α := K) compare] [Std.LawfulEqCmp (α := K) compare] [DecidableEq K]: - FiniteMap (Std.ExtTreeMap K) K where +instance {K : Type u} [Ord K] [Std.TransCmp (α := K) compare] [Std.LawfulEqCmp (α := K) compare] [DecidableEq K]: + FiniteMap K (Std.ExtTreeMap K) where get? m k := m.get? k insert m k v := m.insert k v delete m k := m.erase k empty := Std.ExtTreeMap.empty toList m := m.toList - ofList l := Std.ExtTreeMap.ofList l - fold := sorry + ofList l := Std.ExtTreeMap.ofList l.reverse + fold := fun f init m => m.foldr f init namespace FiniteMapInst variable {K : Type _} [Ord K] [Std.TransCmp (α := K) compare] [Std.LawfulEqCmp (α := K) compare] [DecidableEq K] /-- The FiniteMapLaws instance for ExtTreeMap. -/ -instance : FiniteMapLaws (Std.ExtTreeMap K) K where +instance : FiniteMapLaws K (Std.ExtTreeMap K) where map_eq := by intro m₁ m₂ h apply Std.ExtTreeMap.ext_getElem? @@ -63,64 +64,353 @@ instance : FiniteMapLaws (Std.ExtTreeMap K) K where trivial lookup_union := by - intro m₁ m₂ k - simp [FiniteMap.get?] - sorry + intro V m₁ m₂ k + simp only [FiniteMap.get?, Union.union, FiniteMap.union] + have h : ∀ (l : List (K × V)) (hnodup : (l.map Prod.fst).Nodup) (m : Std.ExtTreeMap K V compare), + (l.foldl (fun (acc: Std.ExtTreeMap K V compare) (x : K × V) => (Std.ExtTreeMap.insert acc x.fst x.snd: Std.ExtTreeMap K V compare)) m).get? k = + (l.lookup k).orElse (fun _ => m.get? k) := by + intro l hnodup m + induction l generalizing m with + | nil => + simp [List.foldl, List.lookup, Option.orElse] + | cons p tail ih => + obtain ⟨k', v'⟩ := p + simp only [List.foldl] + rw [List.map_cons, List.nodup_cons] at hnodup + rw [ih hnodup.2] + simp only [List.lookup] + by_cases h : k = k' + · subst h + simp + have hlookup_none : List.lookup k tail = none := by + cases hlookup : List.lookup k tail with + | none => rfl + | some v => + exfalso + have hmem : (k, v) ∈ tail := Iris.Std.list_lookup_some_mem k v tail hlookup + have : k ∈ tail.map Prod.fst := by + simp + exact ⟨v, hmem⟩ + exact hnodup.1 this + simp [hlookup_none] + · simp [Std.ExtTreeMap.getElem?_insert] + have heq : (k == k') = false := by + simp + intro heq_k_k' + exact h heq_k_k' + rw [heq] + have : k' ≠ k := fun heq_contr => h heq_contr.symm + simp [if_neg this] + + have nodup : (m₁.toList.map Prod.fst).Nodup := by + rw [Std.ExtTreeMap.map_fst_toList_eq_keys] + exact Std.ExtTreeMap.nodup_keys + show (m₁.toList.foldl (fun acc x => acc.insert x.fst x.snd) m₂).get? k = _ + rw [h m₁.toList nodup m₂] + + congr 1 + cases hlookup : m₁.toList.lookup k with + | none => + cases hget : m₁.get? k with + | none => rfl + | some v => + exfalso + have hmem : (k, v) ∈ m₁.toList := + Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mpr hget + have : m₁.toList.lookup k = some v := + Iris.Std.list_mem_lookup_some k v _ nodup hmem + rw [hlookup] at this + contradiction + | some v => + have hmem : (k, v) ∈ m₁.toList := + Iris.Std.list_lookup_some_mem k v _ hlookup + have : m₁.get? k = some v := + Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mp hmem + rw [this] lookup_difference := by - intro m₁ m₂ k - simp [FiniteMap.get?] - sorry + intro V m₁ m₂ k + simp only [FiniteMap.get?, SDiff.sdiff, FiniteMap.difference, FiniteMap.ofList, FiniteMap.toList] + rw [Std.ExtTreeMap.ofList_eq_insertMany_empty] + by_cases hm₂ : m₂.get? k = none + · simp only [hm₂, Option.isSome_none] + simp + cases hm₁ : m₁.get? k with + | none => + have hk_not_in : k ∉ ((List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse.map Prod.fst) := by + intro hmem + rw [List.mem_map] at hmem + obtain ⟨⟨k', v'⟩, hmem_rev, hkeq⟩ := hmem + simp at hkeq + subst hkeq + have hmem_filter : (k', v') ∈ List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList := + List.mem_reverse.mp hmem_rev + rw [List.mem_filter] at hmem_filter + obtain ⟨hmem_toList, _⟩ := hmem_filter + have hcontr : m₁.get? k' = some v' := Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mp hmem_toList + rw [hm₁] at hcontr + contradiction + have hk_contains : ((List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse.map Prod.fst).contains k = false := by + cases h : ((List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse.map Prod.fst).contains k + · rfl + · rw [List.contains_iff_mem] at h + exact absurd h hk_not_in + show ((∅ : Std.ExtTreeMap K V compare).insertMany (List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse)[k]? = m₁[k]? + rw [Std.ExtTreeMap.getElem?_insertMany_list_of_contains_eq_false hk_contains] + show (∅ : Std.ExtTreeMap K V compare)[k]? = m₁[k]? + simp only [Std.ExtTreeMap.getElem?_empty] + exact hm₁.symm + | some v₁ => + have hmem_toList : (k, v₁) ∈ m₁.toList := + Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mpr hm₁ + have hfilter : (m₂.get? k).isNone = true := by + rw [hm₂] + rfl + have hmem_filter : (k, v₁) ∈ List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList := by + rw [List.mem_filter] + simp only + exact ⟨hmem_toList, hfilter⟩ + have hmem_rev : (k, v₁) ∈ (List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse := + List.mem_reverse.mpr hmem_filter + have hdistinct : (List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse.Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := by + rw [List.pairwise_reverse] + have hdist_toList : m₁.toList.Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := + Std.ExtTreeMap.distinct_keys_toList + have hdist_filter : (List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := by + apply List.Pairwise.filter + exact hdist_toList + apply hdist_filter.imp + intro a b h heq + have : compare a.1 b.1 = .eq := by + have hsym : compare b.1 a.1 = .eq → compare a.1 b.1 = .eq := by + intro hba + rw [Std.LawfulEqCmp.compare_eq_iff_eq] at hba ⊢ + exact hba.symm + exact hsym heq + exact h this + have hcmp_eq : compare k k = .eq := Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl + show ((∅ : Std.ExtTreeMap K V compare).insertMany (List.filter (fun x => m₂[x.fst]?.isNone) m₁.toList).reverse)[k]? = m₁[k]? + rw [Std.ExtTreeMap.getElem?_insertMany_list_of_mem hcmp_eq hdistinct hmem_rev] + exact hm₁.symm + · cases hget : m₂.get? k with + | none => contradiction + | some v₂ => + simp only [Option.isSome_some, ite_true] + have hk_not_in : k ∉ ((List.filter (fun x => (m₂.get? x.fst).isNone) m₁.toList).reverse.map Prod.fst) := by + intro hmem + rw [List.mem_map] at hmem + obtain ⟨⟨k', v'⟩, hmem_rev, hkeq⟩ := hmem + simp at hkeq + subst hkeq + have hmem_filter : (k', v') ∈ List.filter (fun x => (m₂.get? x.fst).isNone) m₁.toList := + List.mem_reverse.mp hmem_rev + rw [List.mem_filter] at hmem_filter + obtain ⟨_, hfilter⟩ := hmem_filter + simp only [Option.isNone_iff_eq_none] at hfilter + rw [hget] at hfilter + contradiction + have hk_contains : ((List.filter (fun x => (m₂.get? x.fst).isNone) m₁.toList).reverse.map Prod.fst).contains k = false := by + cases h : ((List.filter (fun x => (m₂.get? x.fst).isNone) m₁.toList).reverse.map Prod.fst).contains k + · rfl + · rw [List.contains_iff_mem] at h + exact absurd h hk_not_in + show ((∅ : Std.ExtTreeMap K V compare).insertMany (List.filter (fun x => (m₂.get? x.fst).isNone) m₁.toList).reverse)[k]? = none + rw [Std.ExtTreeMap.getElem?_insertMany_list_of_contains_eq_false hk_contains] + rfl ofList_nil := by simp [FiniteMap.ofList] ofList_cons := by - intro k v l + intro k v l l_1 simp only [FiniteMap.ofList, FiniteMap.insert] - sorry + rw [List.reverse_cons, Std.ExtTreeMap.ofList_eq_insertMany_empty, Std.ExtTreeMap.ofList_eq_insertMany_empty, Std.ExtTreeMap.insertMany_append, Std.ExtTreeMap.insertMany_list_singleton] + + map_to_list_spec := by + intro V m + constructor + · simp only [FiniteMap.toList] + have hdistinct : m.toList.Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := + Std.ExtTreeMap.distinct_keys_toList + apply hdistinct.imp + intro a b hne heq + subst heq + have : compare a.1 a.1 = .eq := Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl + exact hne this + · intro i x + simp only [FiniteMap.toList, FiniteMap.get?] + exact Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some + + map_ind := by + intros V P H0 Hind m - fold_empty := by sorry + have hm : m = Std.ExtTreeMap.insertMany ∅ (Std.ExtTreeMap.toList m).reverse := by + apply Std.ExtTreeMap.ext_getElem? + intro k + cases hget : m[k]? with + | none => + have hk_not_in : k ∉ (m.toList.reverse.map Prod.fst) := by + intro hmem + rw [List.mem_map] at hmem + obtain ⟨⟨k', v'⟩, hmem_rev, hkeq⟩ := hmem + simp at hkeq + subst hkeq + have hmem_toList : (k', v') ∈ m.toList := List.mem_reverse.mp hmem_rev + have : m[k']? = some v' := Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mp hmem_toList + rw [hget] at this + contradiction + have hk_contains : (m.toList.reverse.map Prod.fst).contains k = false := by + cases h : (m.toList.reverse.map Prod.fst).contains k + · rfl + · rw [List.contains_iff_mem] at h + exact absurd h hk_not_in + rw [Std.ExtTreeMap.getElem?_insertMany_list_of_contains_eq_false hk_contains] + rfl + | some v => + have hmem_toList : (k, v) ∈ m.toList := + Std.ExtTreeMap.mem_toList_iff_getElem?_eq_some.mpr hget + have hmem_rev : (k, v) ∈ m.toList.reverse := List.mem_reverse.mpr hmem_toList + have hdistinct : m.toList.Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := + Std.ExtTreeMap.distinct_keys_toList + have hdistinct_rev : m.toList.reverse.Pairwise (fun a b => ¬compare a.1 b.1 = .eq) := by + rw [List.pairwise_reverse] + apply hdistinct.imp + intro a b h + intro heq + have : compare a.1 b.1 = .eq := by + have hsym : compare b.1 a.1 = .eq → compare a.1 b.1 = .eq := by + intro h + rw [Std.LawfulEqCmp.compare_eq_iff_eq] at h ⊢ + exact h.symm + exact hsym heq + exact h this + have hcmp_eq : compare k k = .eq := Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl + have : ((∅ : Std.ExtTreeMap K V compare).insertMany m.toList.reverse)[k]? = some v := + Std.ExtTreeMap.getElem?_insertMany_list_of_mem hcmp_eq hdistinct_rev hmem_rev + exact this.symm - fold_fmap_ind := by sorry + rw [hm] + + generalize hgen : (Std.ExtTreeMap.toList m) = l + have hdistinct : l.Pairwise (fun a b => ¬ compare a.1 b.1 = .eq) := by + rw [← hgen] + exact Std.ExtTreeMap.distinct_keys_toList + clear hgen hm m + induction l with + | nil => + simp [Std.ExtTreeMap.insertMany_nil] + exact H0 + | cons kv tail ih => + obtain ⟨k, v⟩ := kv + simp + rw [Std.ExtTreeMap.insertMany_append] + simp + + rw [List.pairwise_cons] at hdistinct + obtain ⟨hk_not_in_tail, htail_distinct⟩ := hdistinct + + have hk_not_contains : (tail.reverse.map Prod.fst).contains k = false := by + apply Decidable.byContradiction + intro h + have h_true : (tail.reverse.map Prod.fst).contains k = true := by + cases h_dec : (tail.reverse.map Prod.fst).contains k + · exact absurd h_dec h + · rfl + rw [List.contains_iff_mem] at h_true + rw [List.mem_map] at h_true + obtain ⟨⟨k', v'⟩, hmem_rev, hkeq⟩ := h_true + simp at hkeq + have hmem_tail : (k', v') ∈ tail := List.mem_reverse.mp hmem_rev + have hk_neq : ¬ compare k k' = .eq := hk_not_in_tail (k', v') hmem_tail + have : compare k k' = .eq := by + rw [hkeq] + rw [Std.LawfulEqCmp.compare_eq_iff_eq] + exact hk_neq this + + apply Hind + · show ((∅ : Std.ExtTreeMap K V compare).insertMany tail.reverse)[k]? = none + rw [Std.ExtTreeMap.getElem?_insertMany_list_of_contains_eq_false hk_not_contains] + rfl + · exact ih htail_distinct /-- The FiniteMapLawsSelf instance for ExtTreeMap. -/ -instance : FiniteMapLawsSelf (Std.ExtTreeMap K) K where +instance : FiniteMapLawsSelf K (Std.ExtTreeMap K) where toList_filterMap := by - intro m f - simp [FiniteMap.toList, FiniteMap.filterMap, FiniteMap.ofList] - sorry + intro V m f + haveI : DecidableEq V := Classical.typeDecidableEq V + simp only [FiniteMap.toList, FiniteMap.filterMap, FiniteMap.ofList] + + obtain H := FiniteMapLaws.map_to_list_to_map (M := (Std.ExtTreeMap K)) (K := K) (V := V) (l := (List.filterMap (fun kv => Option.map (fun x => (kv.fst, x)) (f kv.snd)) m.toList)) + + simp only [FiniteMap.toList, FiniteMap.ofList] at H + apply H + rw [List.map_filterMap] + have eq_goal : (List.filterMap (fun x => Option.map Prod.fst (Option.map (fun x_1 => (x.fst, x_1)) (f x.snd))) m.toList) = + (List.filterMap (fun x => Option.map (fun _ => x.fst) (f x.snd)) m.toList) := by + congr 1 + ext x + rw [Option.map_map] + rfl + rw [eq_goal] + have nodup_keys : (m.toList.map Prod.fst).Nodup := by + rw [Std.ExtTreeMap.map_fst_toList_eq_keys] + exact Std.ExtTreeMap.nodup_keys + exact nodup_filterMap_of_nodup_keys m.toList f nodup_keys toList_filter := by - intro m φ + intro V m φ simp [FiniteMap.toList, FiniteMap.filter, FiniteMap.ofList] - sorry + haveI : DecidableEq V := Classical.typeDecidableEq V + obtain H := FiniteMapLaws.map_to_list_to_map (M := (Std.ExtTreeMap K)) (K := K) (V := V) (l := (List.filter (fun x => φ x.fst x.snd) m.toList)) - toList_union_disjoint := by - intro m₁ m₂ h - simp [FiniteMap.toList] - sorry + simp only [FiniteMap.toList, FiniteMap.ofList] at H + apply H + + have nodup_keys : (m.toList.map Prod.fst).Nodup := by + rw [Std.ExtTreeMap.map_fst_toList_eq_keys] + exact Std.ExtTreeMap.nodup_keys - toList_difference := by - intro m₁ m₂ - simp [FiniteMap.toList] - sorry + exact nodup_map_fst_filter m.toList (fun x => φ x.fst x.snd) nodup_keys /-- The FiniteMapKmapLaws instance for ExtTreeMap with key type transformation. -/ instance {K' : Type _} [Ord K'] [Std.TransCmp (α := K') compare] [Std.LawfulEqCmp (α := K') compare] [DecidableEq K'] : - FiniteMapKmapLaws (Std.ExtTreeMap K) (Std.ExtTreeMap K') K K' where + FiniteMapKmapLaws K K' (Std.ExtTreeMap K) (Std.ExtTreeMap K') where toList_kmap := by - intro f m hinj + intro V f m hinj simp [FiniteMap.toList, FiniteMap.kmap, FiniteMap.ofList] - sorry + haveI : DecidableEq V := Classical.typeDecidableEq V + obtain H := FiniteMapLaws.map_to_list_to_map (M := (Std.ExtTreeMap K')) (K := K') (V := V) (l := (List.map (fun x => (f x.fst, x.snd)) m.toList)) + + simp only [FiniteMap.toList, FiniteMap.ofList] at H + apply H + + have nodup_keys : (m.toList.map Prod.fst).Nodup := by + rw [Std.ExtTreeMap.map_fst_toList_eq_keys] + exact Std.ExtTreeMap.nodup_keys + + exact nodup_map_fst_map_injective m.toList f hinj nodup_keys /-- The FiniteMapSeqLaws instance for ExtTreeMap with Nat keys. -/ -instance {V' : Type _} [Std.TransCmp (α := Nat) compare] [Std.LawfulEqCmp (α := Nat) compare] : +instance [Std.TransCmp (α := Nat) compare] [Std.LawfulEqCmp (α := Nat) compare] : FiniteMapSeqLaws (Std.ExtTreeMap Nat) where toList_map_seq := by - intro start l + intro V start l simp [FiniteMap.toList, FiniteMap.map_seq, FiniteMap.ofList] - sorry + haveI : DecidableEq V := Classical.typeDecidableEq V + + have heq : List.mapIdx (fun i v => (start + i, v)) l = (List.range' start l.length).zip l := + mapIdx_add_eq_zip_range' start l + + rw [heq] + + obtain H := FiniteMapLaws.map_to_list_to_map (M := (Std.ExtTreeMap Nat)) (K := Nat) (V := V) (l := ((List.range' start l.length).zip l)) + + simp only [FiniteMap.toList, FiniteMap.ofList] at H + apply H + + -- The keys from range' are all distinct + rw [← heq] + exact nodup_map_fst_mapIdx_add start l end FiniteMapInst diff --git a/src/Iris/Std/List.lean b/src/Iris/Std/List.lean index 90d28c5d..c1516d9a 100644 --- a/src/Iris/Std/List.lean +++ b/src/Iris/Std/List.lean @@ -34,6 +34,37 @@ theorem list_lookup_some_mem {A B : Type _} [BEq A] [LawfulBEq A] right exact ih h +/-- If a key-value pair is in the list with no duplicate keys, lookup returns that value. -/ +theorem list_mem_lookup_some {A B : Type _} [BEq A] [LawfulBEq A] + (k : A) (v : B) (l : List (A × B)) + (hnodup : (l.map Prod.fst).Nodup) : + (k, v) ∈ l → List.lookup k l = some v := by + intro h + induction l with + | nil => contradiction + | cons hd tl ih => + simp [List.lookup] + simp at h + rw [List.map_cons, List.nodup_cons] at hnodup + obtain ⟨hnotin, hnodup_tl⟩ := hnodup + cases h with + | inl heq => + cases heq + have : (k == k) = true := BEq.refl k + simp + | inr hmem => + split + · next heq => + have k_eq_hd : k = hd.1 := by + simp only [beq_iff_eq] at heq + exact heq + have : k ∈ (tl.map Prod.fst) := by + simp + exact ⟨v, hmem⟩ + rw [k_eq_hd] at this + contradiction + · next hneq => exact ih hnodup_tl hmem + /-- Lookup in a mapped list returns the mapped value. -/ theorem list_lookup_map {A B : Type _} [BEq A] [LawfulBEq A] (f : A → B) (k : A) (l : List A) (h : k ∈ l) : @@ -96,11 +127,9 @@ theorem list_mem_lookup {A B : Type _} [BEq A] [LawfulBEq A] · next heq => cases h with | inl heq_pair => - -- (k, v) = hd, so we need to show some hd.2 = some v rw [Prod.ext_iff] at heq_pair exact congrArg some heq_pair.2.symm | inr hmem => - -- k is in tl but k == hd.1, contradicts nodup have keq : k = hd.1 := eq_of_beq heq subst keq have hmem_map : hd.1 ∈ tl.map Prod.fst := by @@ -238,4 +267,147 @@ theorem nodup_of_nodup_map_fst {α β : Type _} (l : List (α × β)) · rw [List.map_cons, List.nodup_cons] at h exact ih h.2 +/-- If a list has no duplicate keys (Nodup on first components), + then filtering preserves this property on the first components. -/ +theorem nodup_map_fst_filter {α β : Type _} + (l : List (α × β)) (p : α × β → Bool) + (h : (l.map Prod.fst).Nodup) : + ((List.filter p l).map Prod.fst).Nodup := by + induction l with + | nil => simp + | cons kv tail ih => + rw [List.map_cons, List.nodup_cons] at h + simp only [List.filter] + split + · rw [List.map_cons, List.nodup_cons] + constructor + · intro hmem + apply h.1 + clear h ih + induction tail with + | nil => simp at hmem + | cons kv' tail' ih_tail => + simp only [List.filter] at hmem + split at hmem + · simp only [List.map_cons, List.mem_cons] at hmem + rcases hmem with heq | hmem' + · rw [List.map_cons, List.mem_cons] + left + exact heq + · have : kv.fst ∈ List.map Prod.fst tail' := ih_tail hmem' + rw [List.map_cons, List.mem_cons] + right + exact this + · have : kv.fst ∈ List.map Prod.fst tail' := ih_tail hmem + rw [List.map_cons, List.mem_cons] + right + exact this + · exact ih h.2 + · exact ih h.2 + +/-- If a list has no duplicate keys (Nodup on first components) and we map keys + with an injective function, the result also has no duplicate keys. -/ +theorem nodup_map_fst_map_injective {α β γ : Type _} + (l : List (α × β)) (f : α → γ) + (hinj : ∀ {x y : α}, f x = f y → x = y) + (h : (l.map Prod.fst).Nodup) : + ((List.map (fun x => (f x.fst, x.snd)) l).map Prod.fst).Nodup := by + rw [List.map_map] + induction l with + | nil => constructor + | cons kv tail ih => + rw [List.map_cons, List.nodup_cons] at h + rw [List.map_cons, List.nodup_cons] + constructor + · intro hmem + apply h.1 + clear h ih + induction tail with + | nil => simp at hmem + | cons kv' tail' ih_tail => + rw [List.map_cons, List.mem_cons] at hmem + rcases hmem with heq | hmem' + · have : kv.fst = kv'.fst := hinj heq + rw [List.map_cons, List.mem_cons] + left + exact this + · rw [List.map_cons, List.mem_cons] + right + exact ih_tail hmem' + · exact ih h.2 + +/-- mapIdx with addition creates the same result as zipping with range'. -/ +theorem mapIdx_add_eq_zip_range' {α : Type _} (start : Nat) (l : List α) : + List.mapIdx (fun i v => (start + i, v)) l = (List.range' start l.length).zip l := by + induction l generalizing start with + | nil => + rw [List.mapIdx_nil, List.length_nil, List.range'_zero, List.zip_nil_left] + | cons hd tl ih => + rw [List.mapIdx_cons, List.length_cons, List.range'_succ, List.zip_cons_cons] + congr 1 + have heq : (fun (i : Nat) (v : α) => (start + (i + 1), v)) = (fun (i : Nat) (v : α) => (start + 1 + i, v)) := by + funext i v + simp only [Nat.add_assoc, Nat.add_comm 1] + rw [heq] + exact ih (start + 1) + +/-- The keys from mapIdx with addition are all distinct. -/ +theorem nodup_map_fst_mapIdx_add {α : Type _} (start : Nat) (l : List α) : + (List.mapIdx (fun i v => (start + i, v)) l).map Prod.fst |>.Nodup := by + rw [mapIdx_add_eq_zip_range', List.map_fst_zip] + · exact List.nodup_range' (step := 1) + · rw [List.length_range'] + omega + +/-- If a list has no duplicate keys (Nodup on first components), + then filtering by mapping the second components preserves this property. -/ +theorem nodup_filterMap_of_nodup_keys {α β : Type _} + (l : List (α × β)) (f : β → Option β) + (h : (l.map Prod.fst).Nodup) : + (List.filterMap (fun x => Option.map (fun _ => x.fst) (f x.snd)) l).Nodup := by + induction l with + | nil => simp + | cons kv tail ih => + rw [List.map_cons, List.nodup_cons] at h + simp only [List.filterMap] + split + · exact ih h.2 + · next b heq => + have hb : b = kv.fst := by + rw [Option.map_eq_some_iff] at heq + obtain ⟨_, _, hf⟩ := heq + exact hf.symm + subst hb + constructor + · intro a' hmem_a' + intro heq_contr + subst heq_contr + apply h.1 + clear h ih heq + induction tail with + | nil => simp at hmem_a' + | cons kv' tail' ih_tail => + simp only [List.filterMap] at hmem_a' + split at hmem_a' + · have : kv.fst ∈ List.map Prod.fst tail' := ih_tail hmem_a' + simp + right + simp at this + exact this + · next b' heq' => + have hb' : b' = kv'.fst := by + rw [Option.map_eq_some_iff] at heq' + obtain ⟨_, _, hf⟩ := heq' + exact hf.symm + subst hb' + simp only [List.mem_cons] at hmem_a' + rcases hmem_a' with heq_k | hmem' + · simp [heq_k] + · have : kv.fst ∈ List.map Prod.fst tail' := ih_tail hmem' + simp + right + simp at this + exact this + · exact ih h.2 + end Iris.Std From 0fb6c4229047dbcfeb26695fe8971c29231a2830 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Mon, 12 Jan 2026 20:53:09 +0100 Subject: [PATCH 6/9] Fix sorries --- src/Iris/Algebra/BigOp.lean | 82 ++++++++ src/Iris/BI/BigOp/BigAndMap.lean | 10 +- src/Iris/BI/BigOp/BigSepMap.lean | 29 +-- src/Iris/Std/FiniteMap.lean | 337 +++++++++++++++++++++++-------- src/Iris/Std/FiniteMapDom.lean | 48 ++++- 5 files changed, 389 insertions(+), 117 deletions(-) diff --git a/src/Iris/Algebra/BigOp.lean b/src/Iris/Algebra/BigOp.lean index 33e10f12..8918da28 100644 --- a/src/Iris/Algebra/BigOp.lean +++ b/src/Iris/Algebra/BigOp.lean @@ -640,6 +640,88 @@ theorem fmap {B : Type w} [DecidableEq B] (h : V → B) (Φ : K → B → M) (m -- Now use BigOpL.fmap to transform the mapped list exact BigOpL.fmap (op := op) (unit := unit) (fun kv => (kv.1, h kv.2)) (fun _ kv => Φ kv.1 kv.2) (FiniteMap.toList m) + +omit [DecidableEq K] [DecidableEq V] in +/-- Helper: bigOpL over filtered list. -/ +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) : + FiniteMap.Disjoint m1 m2 → + bigOpM (op := op) (unit := unit) Φ (m1 ∪ m2) ≡ + op (bigOpM (op := op) (unit := unit) Φ m1) (bigOpM (op := op) (unit := unit) Φ m2) := by + intro hdisj + apply FiniteMapLaws.map_ind (P := fun m1 => + FiniteMap.Disjoint m1 m2 → + bigOpM (op := op) (unit := unit) Φ (m1 ∪ m2) ≡ + op (bigOpM (op := op) (unit := unit) Φ m1) (bigOpM (op := op) (unit := unit) Φ m2)) + · intro _ + have heq : ∅ ∪ m2 = m2 := by + apply FiniteMapLaws.map_eq + intro k + rw [FiniteMapLaws.lookup_union, FiniteMapLaws.lookup_empty] + simp [Option.orElse] + rw [heq, empty] + exact Equiv.symm (Monoid.op_left_id _) + · intro i x m hi_none IH hdisj' + have hi_m2 : get? m2 i = none := by + have := FiniteMapLaws.map_disjoint_spec (Std.insert m i x) m2 |>.mp hdisj' i + simp [FiniteMapLaws.lookup_insert_eq] at this + exact this + have hm_disj : FiniteMap.Disjoint m m2 := by + intro k ⟨hk1, hk2⟩ + have : (get? (Std.insert m i x) k).isSome ∧ (get? m2 k).isSome := by + constructor + · by_cases hik : i = k + · subst hik; simp [hi_none] at hk1 + · rw [FiniteMapLaws.lookup_insert_ne _ _ _ _ hik]; exact hk1 + · exact hk2 + exact hdisj' k this + have heq : Std.insert (m ∪ m2) i x = Std.insert m i x ∪ m2 := by + apply FiniteMapLaws.map_eq + intro k + exact congrFun (FiniteMapLaws.insert_union_l m m2 i x) k + have hunion_none : get? (m ∪ m2) i = none := by + rw [FiniteMapLaws.lookup_union_None] + exact ⟨hi_none, hi_m2⟩ + -- Apply bigOpM insert lemmas + show bigOpM (op := op) (unit := unit) Φ (Std.insert m i x ∪ m2) ≡ + op (bigOpM (op := op) (unit := unit) Φ (Std.insert m i x)) (bigOpM (op := op) (unit := unit) Φ m2) + rw [← heq] + refine Equiv.trans (insert Φ (m ∪ m2) i x hunion_none) ?_ + refine Equiv.trans (Monoid.op_congr_r (IH hm_disj)) ?_ + refine Equiv.trans (Equiv.symm (Monoid.op_assoc _ _ _)) ?_ + exact Monoid.op_congr_l (Equiv.symm (insert Φ m i x hi_none)) + · 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) : diff --git a/src/Iris/BI/BigOp/BigAndMap.lean b/src/Iris/BI/BigOp/BigAndMap.lean index 45d34820..2fef88f2 100644 --- a/src/Iris/BI/BigOp/BigAndMap.lean +++ b/src/Iris/BI/BigOp/BigAndMap.lean @@ -296,7 +296,8 @@ theorem union [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m₁ m₂ : M V} (hdisj : m₁ ##ₘ m₂) : ([∧map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∧map] k ↦ y ∈ m₁, Φ k y) ∧ [∧map] k ↦ y ∈ m₂, Φ k y := by - sorry + simp only [bigAndM] + exact equiv_iff.mp (BigOpM.union (op := and) (unit := iprop(True)) Φ m₁ m₂ hdisj) end FilterMapTransformations @@ -445,12 +446,7 @@ theorem filter' {Φ : K → V → PROP} {m : M V} (p : K → V → Bool) : ([∧map] k ↦ x ∈ FiniteMap.filter p m, Φ k x) ⊣⊢ [∧map] k ↦ x ∈ m, if p k x then Φ k x else iprop(True) := by simp only [bigAndM] - have hperm := toList_filter m p - have heq : bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) (toList (FiniteMap.filter p m)) ≡ - bigOpL and iprop(True) (fun _ kv => Φ kv.1 kv.2) ((toList m).filter (fun kv => p kv.1 kv.2)) := - BigOpL.perm _ hperm - refine equiv_iff.mp heq |>.trans ?_ - exact filter_list_aux (fun kv => p kv.1 kv.2) (toList m) + exact equiv_iff.mp (BigOpM.filter' (op := and) (unit := iprop(True)) p Φ m) /-- Corresponds to `big_andM_filter` in Rocq Iris. -/ theorem filter'' {Φ : K → V → PROP} {m : M V} (p : K → V → Bool) : diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index c8ea6bc5..211bf82e 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -134,11 +134,6 @@ theorem flip_mono' {Φ Ψ : K → V → PROP} {m : M V} ([∗map] k ↦ x ∈ m, Ψ k x) ⊢ [∗map] k ↦ x ∈ m, Φ k x := mono' h -/-- Corresponds to `big_sepM_subseteq` in Rocq Iris. -/ -theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} [FiniteMapLawsSelf K M] [∀ k v, Affine (Φ k v)] - (h : m₂ ⊆ m₁) : - ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by sorry - /-! ## Typeclass Instances -/ /-- Corresponds to `big_sepM_empty_persistent` in Rocq Iris. -/ @@ -482,7 +477,20 @@ theorem union [FiniteMapLawsSelf K M] {Φ : K → V → PROP} {m₁ m₂ : M V} ([∗map] k ↦ y ∈ m₁ ∪ m₂, Φ k y) ⊣⊢ ([∗map] k ↦ y ∈ m₁, Φ k y) ∗ [∗map] k ↦ y ∈ m₂, Φ k y := by simp only [bigSepM] - sorry + exact equiv_iff.mp (BigOpM.union (op := sep) (unit := emp) Φ m₁ m₂ hdisj) + +/-- Corresponds to `big_sepM_subseteq` in Rocq Iris. -/ +theorem subseteq {Φ : K → V → PROP} {m₁ m₂ : M V} [FiniteMapLawsSelf K M] [∀ k v, Affine (Φ k v)] + (h : m₂ ⊆ m₁) : + ([∗map] k ↦ x ∈ m₁, Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x := by + have heq : m₂ ∪ (m₁ \ m₂) = m₁ := FiniteMap.map_difference_union m₁ m₂ h + have hdisj : FiniteMap.Disjoint m₂ (m₁ \ m₂) := FiniteMap.disjoint_difference_r m₁ m₂ + suffices hsuff : ([∗map] k ↦ x ∈ m₂ ∪ (m₁ \ m₂), Φ k x) ⊢ [∗map] k ↦ x ∈ m₂, Φ k x by + have : ([∗map] k ↦ x ∈ m₁, Φ k x) ≡ ([∗map] k ↦ x ∈ m₂ ∪ (m₁ \ m₂), Φ k x) := by rw [heq] + exact (equiv_iff.mp this).1.trans hsuff + refine (union hdisj).1.trans ?_ + have : Affine ([∗map] k ↦ x ∈ m₁ \ m₂, Φ k x) := inferInstance + exact sep_elim_l end FilterMapTransformations @@ -716,14 +724,7 @@ theorem filter' {Φ : K → V → PROP} {m : M V} ([∗map] k ↦ x ∈ FiniteMap.filter (fun k v => decide (φ (k, v))) m, Φ k x) ⊣⊢ [∗map] k ↦ x ∈ m, if decide (φ (k, x)) then Φ k x else emp := by simp only [bigSepM] - have hperm := toList_filter m (fun k v => decide (φ (k, v))) - have heq : bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) - (toList (FiniteMap.filter (fun k v => decide (φ (k, v))) m)) ≡ - bigOpL sep emp (fun _ kv => Φ kv.1 kv.2) - ((toList m).filter (fun kv => decide (φ kv))) := - BigOpL.perm _ hperm - refine equiv_iff.mp heq |>.trans ?_ - exact filter_list_aux (fun kv => Φ kv.1 kv.2) φ (toList m) + exact equiv_iff.mp (BigOpM.filter' (op := sep) (unit := emp) (fun k v => decide (φ (k, v))) Φ m) /-- Corresponds to `big_sepM_filter` in Rocq Iris. -/ theorem filter [BIAffine PROP] {Φ : K → V → PROP} {m : M V} diff --git a/src/Iris/Std/FiniteMap.lean b/src/Iris/Std/FiniteMap.lean index 2920c48c..5fe3b57b 100644 --- a/src/Iris/Std/FiniteMap.lean +++ b/src/Iris/Std/FiniteMap.lean @@ -980,116 +980,275 @@ theorem map_disjoint_singleton_r (m : M V) (i : K) (x : V) : simp [hi] at hs1 · simp [FiniteMap.singleton, lookup_insert_ne _ _ _ _ hik, lookup_empty] at hs2 -/-- toList of map (fmap) is a permutation of mapping over toList. - This is a weaker form that we can prove without the fold-based infrastructure. - The stronger equality version (`toList_map_eq`) would require `fold_map` and `fold_foldr`. -/ +/-- 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] - -- toList (ofList ((toList m).map g)) is Perm to (toList m).map g - -- where g = fun kv => (kv.1, f kv.2) apply map_to_list_to_map - -- Need to show: ((toList m).map g).map Prod.fst |>.Nodup simp only [List.map_map] show ((toList m).map (fun x => x.1)).Nodup exact NoDup_map_to_list_keys m -/-- Corresponds to Rocq's `map_fmap_zip_with_r`. - When `g1 (f x y) = x` and the domains of m1 and m2 match, - mapping g1 over zipWith f m1 m2 gives back m1 (up to map equality). -/ -theorem map_fmap_zipWith_r {V' V'' : Type _} [DecidableEq V'] [DecidableEq V''] +/-- Lookup in a mapped finite map. -/ +theorem lookup_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 + · -- k in m + obtain ⟨v, hv⟩ := h + have hmem : (k, v) ∈ toList m := (elem_of_map_to_list 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_map_to_list_keys m + have := (elem_of_list_to_map (M := M) _ k (f v) hnodup).mp hmem' + simp [hv, this] + · -- k not in m + 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_map_to_list_keys m + have hmem : (k, v') ∈ (toList m).map (fun (ki, vi) => (ki, f vi)) := + (elem_of_list_to_map (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'' := (elem_of_map_to_list m k' v'').mp hmem' + rw [heq_k, hk] at this + cases this + +/-- filterMap preserves Nodup on keys (first projection). -/ +private theorem nodup_map_fst_filterMap {V' V'' : Type _} + (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' + -- Main proof by induction + 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 => + -- g k v = none, so kv is filtered out + exact ih h_nodup.2 + | some res => + -- g k v = some res, so kv is kept + 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 + +/-- Helper lemma: lookup in zipWith. -/ +theorem lookup_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 + · -- m1 doesn't have k, so result should be none + simp + -- The result is none because k is not in the filtered list + 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 + · -- Contradiction: k is in the result but not in m1 + rename_i v_result + -- k must be in the filterMap output + 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') (V'' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (NoDup_map_to_list_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) := + (elem_of_list_to_map (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' := (elem_of_map_to_list m1 k' v1').mp hmem1 + rw [heq_k, h1] at this + cases this + · -- m1 has k + rename_i v1 + cases h2 : get? m2 k + · -- m2 doesn't have k, so result should be none + 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 + · -- Contradiction: result is some but m2 doesn't have k + 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') (V'' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (NoDup_map_to_list_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) := + (elem_of_list_to_map (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 + · -- Both have k, result should be some (f v1 v2) + rename_i v2 + simp + -- Show k maps to f v1 v2 in the result + have hmem1 : (k, v1) ∈ toList m1 := (elem_of_map_to_list 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') (V'' := V'') (toList m1) (fun ki vi => + match get? m2 ki with + | some v' => some (ki, f vi v') + | none => none) (NoDup_map_to_list_keys m1) ?_ + intros ki vi k' v' heq + cases heq' : get? m2 ki <;> simp [heq'] at heq + obtain ⟨rfl, _⟩ := heq + rfl + exact (elem_of_list_to_map (M := M) _ k (f v1 v2) hnodup).mp hmem_filter + +/-- Corresponds to Rocq's `map_fmap_zip_with_r`. -/ +theorem map_fmap_zipWith_r [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 - sorry - -/-- Corresponds to Rocq's `map_fmap_zip_with_l`. - When `g2 (f x y) = y` and the domains of m1 and m2 match, - mapping g2 over zipWith f m1 m2 gives back m2 (up to map equality). -/ -theorem map_fmap_zipWith_l {V' V'' : Type _} [DecidableEq V'] [DecidableEq V''] + apply map_eq + intro k + rw [lookup_map, lookup_zipWith] + cases h1 : get? m1 k with + | none => simp + | some x => + -- From hdom, we know m2 has k + 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_fmap_zipWith_l [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 - sorry + apply map_eq + intro k + rw [lookup_map, lookup_zipWith] + cases h2 : get? m2 k with + | none => simp + | some y => + -- From hdom, we know m1 has k + 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] + +/-- Corresponds to Rocq's `lookup_union_None`. + Lookup in union is none iff both lookups are none. -/ +theorem lookup_union_None (m1 m2 : M V) (i : K) : + get? (m1 ∪ m2) i = none ↔ get? m1 i = none ∧ get? m2 i = none := by + rw [lookup_union] + cases h1 : get? m1 i <;> cases h2 : get? m2 i <;> simp [Option.orElse] + +/-- Corresponds to Rocq's `insert_union_l`. + Insert distributes over union on the left. -/ +theorem insert_union_l (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 [lookup_insert_eq, lookup_union] + · simp [lookup_insert_ne _ _ _ _ hik, lookup_union] end FiniteMapLaws --- namespace FiniteMapLawsFold - --- variable {M : Type _ → _} {K : Type v} {V : Type _} --- variable [DecidableEq K] [FiniteMap M K] [FiniteMapLaws M K] [FiniteMapLawsFold M K] --- /-- Corresponds to Rocq's `map_fold_fmap` --- Rocq Proof: --- induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind. --- { by rewrite fmap_empty, !map_fold_empty. } --- rewrite fmap_insert. rewrite <-(map_fmap_id m) at 2. rewrite !Hfold. --- by rewrite IH, map_fmap_id. -/ --- theorem fold_map (f : K → V' → B → B) (g : V → V') b (m : M V) : --- fold f b (FiniteMap.map g m) = fold (fun i => f i ∘ g) b m := by sorry - --- /-- toList of map (fmap) equals mapping over toList (equality version). --- `toList (map f m) = (toList m).map (fun (k, v) => (k, f v))` --- Corresponds to Rocq's `map_to_list_fmap` --- Rocq proof: --- unfold map_to_list. rewrite map_fold_fmap, !map_fold_foldr. --- induction (map_to_list m) as [|[]]; f_equal/=; auto. -/ --- theorem toList_map_eq [DecidableEq V'] : ∀ (m : M V) (f : V → V'), --- toList (FiniteMap.map f m) = --- ((toList m).map (fun kv => (kv.1, f kv.2))) := by sorry - - --- /-- Corresponds to Rocq's `map_fold_ind` --- Rocq proof: --- intros Hemp Hins m. --- induction m as [|i x m ? Hfold IH] using map_fold_fmap_ind; [done|]. --- apply Hins; [done| |done]. intros B f b x'. --- assert (m = id <$> m) as →. --- { apply map_eq; intros j; by rewrite lookup_fmap, option_fmap_id. } --- apply Hfold. --- -/ --- private theorem map_fold_ind (P : M V → Prop) : --- P ∅ → --- (∀ i x m, --- get? m i = none → --- (∀ B (f : K → V → B → B) b x', --- fold f b (insert m i x') = f i x' (fold f b m)) → --- P m → --- P (insert m i x)) → --- ∀ m, P m := by sorry - --- /-- Corresponds to Rocq's `map_fold_weak_ind`. -/ --- theorem fold_weak_ind {B : Type u''} --- (P : B → M V → Prop) (f : K → V → B → B) (b : B) --- (hemp : P b ∅) --- (hins : ∀ i x m r, get? m i = none → P r m → P (f i x r) (insert m i x)) --- (m : M V) : P (fold f b m) m := by --- sorry - --- /-- Induction principle with first key constraint: prove properties about maps by induction, --- where the inductive step requires that the inserted key becomes the first key. - --- Corresponds to Rocq's `map_first_key_ind`. -/ --- theorem map_first_key_ind (P : M V → Prop) --- (hemp : P ∅) --- (hins : ∀ i x m, get? m i = none → FiniteMap.firstKey (insert m i x) i → P m → P (insert m i x)) --- (m : M V) : P m := by --- sorry - --- /-- Corresponds to Rocq's `map_fold_foldr` --- Rocq proof: --- unfold map_to_list. induction m as [|i x m ? Hfold IH] using map_fold_ind. --- - by rewrite !map_fold_empty. --- - by rewrite !Hfold, IH. --- -/ --- theorem fold_foldr (f : K → V → B → B) b (m : M V) : --- fold f b m = List.foldr (fun ⟨k, v⟩ b => f k v b) b (toList m) := by sorry - --- end FiniteMapLawsFold - namespace FiniteMap variable {K : Type v} {M : Type u → _} [FiniteMap K M] diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index f8d8d6d0..970b191a 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -31,13 +31,47 @@ def domSet (m : M V) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) /-- Create map from set with constant value. -/ def ofSet (c : V) (X : S) : M V := FiniteMap.ofList ((FiniteSet.toList X).map (fun k => (k, c))) - /-- Lookup returns `none` iff the key is not in the domain. - Corresponds to Rocq's `not_elem_of_dom`. -/ -theorem not_elem_of_domSet : ∀ (m : M V) k, get? m k = none ↔ k ∉ (domSet m : S) := by sorry - - /-- Lookup returns `some` iff the key is in the domain. - Corresponds to Rocq's `elem_of_dom`. -/ -theorem elem_of_domSet : ∀ (m : M V) k, (∃ v, get? m k = some v) ↔ k ∈ (domSet m : S) := by sorry +/-- Corresponds to Rocq's `not_elem_of_dom`. -/ +theorem not_elem_of_domSet : ∀ (m : M V) k, get? m k = none ↔ k ∉ (domSet m : S) := by + intro m k + simp only [domSet, Membership.mem] + rw [FiniteSetLaws.mem_ofList] + constructor + · intro h_none h_in + rw [List.mem_map] at h_in + obtain ⟨⟨k', v⟩, h_mem, h_eq⟩ := h_in + simp at h_eq + subst h_eq + have : get? m k' = some v := (FiniteMapLaws.elem_of_map_to_list m k' v).mp h_mem + rw [h_none] at this + exact Option.noConfusion this + · intro h_not_in + cases h : get? m k + · rfl + · rename_i v + have : (k, v) ∈ FiniteMap.toList m := (FiniteMapLaws.elem_of_map_to_list m k v).mpr h + have : k ∈ (FiniteMap.toList m).map Prod.fst := by + rw [List.mem_map] + exact ⟨(k, v), this, rfl⟩ + exact absurd this h_not_in + +/-- Corresponds to Rocq's `elem_of_dom`. -/ +theorem elem_of_domSet : ∀ (m : M V) k, (∃ v, get? m k = some v) ↔ k ∈ (domSet m : S) := by + intro m k + simp only [domSet, Membership.mem] + rw [FiniteSetLaws.mem_ofList] + constructor + · intro ⟨v, h_some⟩ + have : (k, v) ∈ FiniteMap.toList m := (FiniteMapLaws.elem_of_map_to_list m k v).mpr h_some + rw [List.mem_map] + exact ⟨(k, v), this, rfl⟩ + · intro h_in + rw [List.mem_map] at h_in + obtain ⟨⟨k', v⟩, h_mem, h_eq⟩ := h_in + simp at h_eq + subst h_eq + have : get? m k' = some v := (FiniteMapLaws.elem_of_map_to_list m k' v).mp h_mem + exact ⟨v, this⟩ /-- Domain of empty map is empty set. -/ theorem domSet_empty : domSet (∅ : M V) = (∅ : S) := by From 376d5a820442d0f4a9ea68a778dca467c4dcd76a Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Tue, 13 Jan 2026 01:05:58 +0100 Subject: [PATCH 7/9] WIP: Simplifying FiniteSet --- src/Iris/BI/BigOp/BigOp.lean | 4 +- src/Iris/BI/BigOp/BigSepList.lean | 2 +- src/Iris/BI/BigOp/BigSepMap.lean | 140 +++-- src/Iris/BI/BigOp/BigSepSet.lean | 246 +++++--- src/Iris/Std/FiniteMapDom.lean | 12 +- src/Iris/Std/FiniteSet.lean | 900 ++++++++++++++---------------- 6 files changed, 682 insertions(+), 622 deletions(-) diff --git a/src/Iris/BI/BigOp/BigOp.lean b/src/Iris/BI/BigOp/BigOp.lean index a001b873..4ef1d961 100644 --- a/src/Iris/BI/BigOp/BigOp.lean +++ b/src/Iris/BI/BigOp/BigOp.lean @@ -138,9 +138,9 @@ section Set `bigSepS Φ S` computes `∗_{x ∈ S} Φ x` Corresponds to `big_opS` in Rocq Iris. -/ -abbrev bigSepS [BI PROP] {S : Type _} {A : Type _} [FiniteSet S A] +abbrev bigSepS [BI PROP] {S : Type _} {A : Type _} [FiniteSet A S] (Φ : A → PROP) (s : S) : PROP := - bigOpL sep emp (fun _ x => Φ x) (toList s) + bigOpL sep emp (fun _ x => Φ x) (FiniteSet.toList s) /-! ## Notation -/ diff --git a/src/Iris/BI/BigOp/BigSepList.lean b/src/Iris/BI/BigOp/BigSepList.lean index 7614696a..dde3d76c 100644 --- a/src/Iris/BI/BigOp/BigSepList.lean +++ b/src/Iris/BI/BigOp/BigSepList.lean @@ -717,7 +717,7 @@ theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} [FiniteMap K M] equiv_iff.mp <| BigSepL.congr fun _ kv => .rfl /-- Corresponds to `big_sepL_sepS` in Rocq Iris. -/ -theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] +theorem sepS {B : Type _} {S : Type _} [DecidableEq B] [FiniteSet B S] [FiniteSetLaws B S] (Φ : Nat → A → B → PROP) (l : List A) (X : S) : ([∗list] k↦x ∈ l, [∗set] y ∈ X, Φ k x y) ⊣⊢ ([∗set] y ∈ X, [∗list] k↦x ∈ l, Φ k x y) := by diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index 211bf82e..54bd0e7e 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -1064,7 +1064,7 @@ end ListToMap section DomainSet -variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] +variable {S : Type _} [FiniteSet K S] [FiniteSetLaws K S] omit [FiniteMapLawsSelf K M] in /-- Corresponds to `big_sepM_dom` in Rocq Iris. -/ @@ -1081,50 +1081,43 @@ theorem dom {Φ : K → PROP} (m : M V) : · have ⟨v', hv⟩ := elem_of_domSet m k |>.mpr h rw [hk_not_in] at hv cases hv - have hinsert_eq : FiniteSet.insert k (domSet m : S) = FiniteSet.singleton k ∪ (domSet m : S) := by - apply @FiniteSetLaws.ext S K _ _ + have hinsert_eq : FiniteSet.insert k (domSet m : S) ≡ FiniteSet.singleton k ∪ (domSet m : S) := by intro x - by_cases hx : x = k - · rw [FiniteSetLaws.mem_insert_eq _ _ _ hx] - have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := by - apply FiniteSetLaws.mem_union _ _ _ |>.mpr + constructor + · intro h + by_cases hx : x = k + · apply FiniteSet.mem_union _ _ _ |>.mpr left - exact FiniteSetLaws.mem_singleton _ _ |>.mpr hx - rw [this] - · rw [FiniteSetLaws.mem_insert_ne _ _ _ hx] - cases hm : FiniteSet.mem x (domSet m : S) - · have hsing : FiniteSet.mem x (FiniteSet.singleton k : S) = false := by - cases h : FiniteSet.mem x (FiniteSet.singleton k : S) - · rfl - · have : x = k := FiniteSetLaws.mem_singleton _ _ |>.mp h - exact absurd this hx - have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = false := by - cases h : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) - · rfl - · have : FiniteSet.mem x (FiniteSet.singleton k : S) = true ∨ FiniteSet.mem x (domSet m : S) = true := - FiniteSetLaws.mem_union _ _ _ |>.mp h - cases this with - | inl h' => rw [hsing] at h'; cases h' - | inr h' => rw [hm] at h'; cases h' - rw [this] - · have : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := - FiniteSetLaws.mem_union _ _ _ |>.mpr (Or.inr hm) - rw [this] - have hdom_eq : (FiniteSet.singleton k ∪ (domSet m : S) : S) = (domSet (FiniteMap.insert m k v) : S) := by - apply @FiniteSetLaws.ext S K _ _ + exact FiniteSet.mem_singleton _ _ |>.mpr hx + · have hmem := (FiniteSet.mem_insert_ne _ _ _ hx).mp h + apply FiniteSet.mem_union _ _ _ |>.mpr + right + exact hmem + · intro h + have hmem := FiniteSet.mem_union _ _ _ |>.mp h + cases hmem with + | inl hsing => + have : x = k := FiniteSet.mem_singleton _ _ |>.mp hsing + exact FiniteSet.mem_insert_eq _ _ _ this + | inr hdom => + by_cases hx : x = k + · exact FiniteSet.mem_insert_eq _ _ _ hx + · exact (FiniteSet.mem_insert_ne _ _ _ hx).mpr hdom + have hdom_eq : ∀ x, FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = + FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) := by intro x by_cases hx : x = k · rw [hx] have h1 : FiniteSet.mem k (FiniteSet.singleton k ∪ (domSet m : S)) = true := by - apply FiniteSetLaws.mem_union _ _ _ |>.mpr + apply FiniteSet.mem_union _ _ _ |>.mpr left - exact FiniteSetLaws.mem_singleton _ _ |>.mpr rfl + exact FiniteSet.mem_singleton _ _ |>.mpr rfl have h2 : FiniteSet.mem k (domSet (FiniteMap.insert m k v) : S) = true := elem_of_domSet (FiniteMap.insert m k v) k |>.mp ⟨v, lookup_insert_eq m k v⟩ rw [h1, h2] · by_cases hm : FiniteSet.mem x (domSet m : S) = true · have h1 : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = true := by - apply FiniteSetLaws.mem_union _ _ _ |>.mpr + apply FiniteSet.mem_union _ _ _ |>.mpr right exact hm have h2 : FiniteSet.mem x (domSet (FiniteMap.insert m k v) : S) = true := by @@ -1137,13 +1130,13 @@ theorem dom {Φ : K → PROP} (m : M V) : · have hs : FiniteSet.mem x (FiniteSet.singleton k : S) = false := by cases h : FiniteSet.mem x (FiniteSet.singleton k : S) · rfl - · have : x = k := FiniteSetLaws.mem_singleton _ _ |>.mp h + · have : x = k := FiniteSet.mem_singleton _ _ |>.mp h exact absurd this hx have h1 : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) = false := by cases h : FiniteSet.mem x (FiniteSet.singleton k ∪ (domSet m : S)) · rfl · have : FiniteSet.mem x (FiniteSet.singleton k : S) = true ∨ FiniteSet.mem x (domSet m : S) = true := - FiniteSetLaws.mem_union _ _ _ |>.mp h + FiniteSet.mem_union _ _ _ |>.mp h cases this with | inl h' => rw [h'] at hs; cases hs | inr h' => exact absurd h' hm @@ -1161,7 +1154,29 @@ theorem dom {Φ : K → PROP} (m : M V) : ⊣⊢ Φ k ∗ ([∗map] k' ↦ _v ∈ m, Φ k') := insert hk_not_in _ ⊣⊢ Φ k ∗ ([∗set] k' ∈ (domSet m : S), Φ k') := ⟨sep_mono_r IH.1, sep_mono_r IH.2⟩ _ ⊣⊢ ([∗set] k' ∈ FiniteSet.singleton k ∪ (domSet m : S), Φ k') := (BigSepS.insert hk_not_in_dom).symm - _ ⊣⊢ ([∗set] k' ∈ (domSet (FiniteMap.insert m k v) : S), Φ k') := by rw [hdom_eq]; exact .rfl + _ ⊣⊢ ([∗set] k' ∈ (domSet (FiniteMap.insert m k v) : S), Φ k') := by + -- Use membership equality to show the two bigSepS are equivalent + have hsub1 : (FiniteSet.singleton k ∪ (domSet m : S)) ⊆ (domSet (FiniteMap.insert m k v) : S) := by + intro z hz + rw [mem_iff_mem] at hz ⊢ + rw [← hdom_eq z]; exact hz + have hsub2 : (domSet (FiniteMap.insert m k v) : S) ⊆ (FiniteSet.singleton k ∪ (domSet m : S)) := by + intro z hz + rw [mem_iff_mem] at hz ⊢ + rw [hdom_eq z]; exact hz + have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset (domSet (FiniteMap.insert m k v) : S) _ hsub1 + have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (FiniteSet.singleton k ∪ (domSet m : S)) _ hsub2 + have hl1_nil : l₁ = [] := by + have h1 := hperm1.length_eq + have h2 := hperm2.length_eq + simp only [List.length_append] at h1 h2 + have : l₁.length = 0 := by omega + match l₁ with + | [] => rfl + | _ :: _ => simp at this + rw [hl1_nil, List.append_nil] at hperm1 + unfold bigSepS + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm1) /-- Corresponds to `big_sepM_gset_to_gmap` in Rocq Iris. -/ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : @@ -1185,11 +1200,56 @@ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : rw [this] have h2 : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k c) ⊣⊢ ([∗set] k ∈ (domSet (ofSet c X : M V) : S), Φ k c) := dom _ - have h3 : (domSet (ofSet c X : M V) : S) = X := domSet_ofSet c X - rw [h3] at h2 + -- domSet_ofSet gives us set equivalence, convert to bigSepS equivalence + have h3 : ([∗set] k ∈ (domSet (ofSet c X : M V) : S), Φ k c) ⊣⊢ + ([∗set] k ∈ X, Φ k c) := by + have hequiv := @domSet_ofSet K M _ _ _ S _ _ V c X + -- Use membership equality to show the two bigSepS are equivalent + have hmem_eq : ∀ z, FiniteSet.mem z (domSet (ofSet c X : M V) : S) = FiniteSet.mem z X := by + intro z + cases h : FiniteSet.mem z (domSet (ofSet c X : M V) : S) <;> + cases h' : FiniteSet.mem z X + · rfl + · -- h says mem z (domSet ...) = false, h' says mem z X = true + -- But hequiv z says z ∈ domSet ... ↔ z ∈ X, so this is a contradiction + have hz_in_X : z ∈ X := h' + have hz_in_dom : z ∈ (domSet (ofSet c X : M V) : S) := (hequiv z).mpr hz_in_X + have : FiniteSet.mem z (domSet (ofSet c X : M V) : S) = true := hz_in_dom + rw [h] at this + cases this + · -- h says mem z (domSet ...) = true, h' says mem z X = false + have hz_in_dom : z ∈ (domSet (ofSet c X : M V) : S) := h + have hz_in_X : z ∈ X := (hequiv z).mp hz_in_dom + have : FiniteSet.mem z X = true := hz_in_X + rw [h'] at this + cases this + · rfl + have hsub1 : (domSet (ofSet c X : M V) : S) ⊆ X := by + intro z hz + have : FiniteSet.mem z (domSet (ofSet c X : M V) : S) = true := hz + rw [hmem_eq z] at this + exact this + have hsub2 : X ⊆ (domSet (ofSet c X : M V) : S) := by + intro z hz + have : FiniteSet.mem z X = true := hz + rw [← hmem_eq z] at this + exact this + have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset X _ hsub1 + have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (domSet (ofSet c X : M V) : S) _ hsub2 + have hl1_nil : l₁ = [] := by + have h1 := hperm1.length_eq + have h2 := hperm2.length_eq + simp only [List.length_append] at h1 h2 + have : l₁.length = 0 := by omega + match l₁ with + | [] => rfl + | _ :: _ => simp at this + rw [hl1_nil, List.append_nil] at hperm1 + unfold bigSepS + exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ (Φ · c) _ _ hperm1) have h1' : ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k a) ⊣⊢ ([∗map] k ↦ a ∈ (ofSet c X : M V), Φ k c) := BI.equiv_iff.mp h1 - exact BiEntails.trans h1' h2 + exact BiEntails.trans h1' (BiEntails.trans h2 h3) end DomainSet @@ -1231,7 +1291,7 @@ theorem sepM {M₂ : Type _ → Type _} {K₂ : Type _} {V₂ : Type _} omit [DecidableEq K] [FiniteMapLaws K M] [FiniteMapLawsSelf K M] [DecidableEq V] in /-- Corresponds to `big_sepM_sepS` in Rocq Iris. -/ theorem sepS {B : Type _} {S : Type _} - [DecidableEq B] [FiniteSet S B] [FiniteSetLaws S B] + [DecidableEq B] [FiniteSet B S] [FiniteSetLaws B S] (Φ : K → V → B → PROP) (m : M V) (X : S) : ([∗map] k↦x ∈ m, [∗set] y ∈ X, Φ k x y) ⊣⊢ ([∗set] y ∈ X, [∗map] k↦x ∈ m, Φ k x y) := by diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean index b751405d..6557a60f 100644 --- a/src/Iris/BI/BigOp/BigSepSet.lean +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -20,7 +20,7 @@ open BIBase variable {PROP : Type _} [BI PROP] variable {S : Type _} {A : Type _} -variable [DecidableEq A] [FiniteSet S A] [FiniteSetLaws S A] +variable [DecidableEq A] [FiniteSet A S] [FiniteSetLaws A S] namespace BigSepS @@ -87,7 +87,7 @@ theorem flip_mono' {Φ Ψ : A → PROP} {X : S} /-! ## Basic Structural Lemmas -/ -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_elements` in Rocq Iris. -/ theorem elements {Φ : A → PROP} {X : S} : ([∗set] x ∈ X, Φ x) ⊣⊢ [∗list] x ∈ toList X, Φ x := by @@ -108,7 +108,7 @@ theorem empty' {P : PROP} [Affine P] {Φ : A → PROP} : P ⊢ [∗set] x ∈ (∅ : S), Φ x := Affine.affine.trans empty.2 -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_emp` in Rocq Iris. -/ theorem emp' {X : S} : ([∗set] _x ∈ X, emp) ⊣⊢ (emp : PROP) := by @@ -120,7 +120,7 @@ theorem emp' {X : S} : theorem singleton {Φ : A → PROP} {x : A} : ([∗set] y ∈ (FiniteSet.singleton x : S), Φ y) ⊣⊢ Φ x := by unfold bigSepS - have hperm := FiniteSetLaws.toList_singleton (S := S) (x : A) + have hperm := FiniteSet.toList_singleton (S := S) (x : A) have hp := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) simp only [BigOpL.cons, BigOpL.nil] at hp exact hp.trans sep_emp @@ -130,7 +130,7 @@ theorem union {Φ : A → PROP} {X Y : S} (h : FiniteSet.Disjoint X Y) : ([∗set] y ∈ X ∪ Y, Φ y) ⊣⊢ ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) := by unfold bigSepS - obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union (S := S) X Y h + obtain ⟨l', hperm, hperm'⟩ := FiniteSet.toList_union (S := S) X Y h have hp1 := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) have happ := equiv_iff.mp (@BigOpL.append PROP _ _ sep emp _ (fun _ x => Φ x) (toList X) l') have hp2 : bigOpL sep emp (fun _ => Φ) (toList X) ∗ bigOpL sep emp (fun _ => Φ) l' ⊣⊢ @@ -141,8 +141,12 @@ theorem union {Φ : A → PROP} {X Y : S} private theorem bigSepS_perm_of_mem_eq {Φ : A → PROP} {X Y : S} (hmem_eq : ∀ z, FiniteSet.mem z X = FiniteSet.mem z Y) : ([∗set] y ∈ X, Φ y) ⊣⊢ ([∗set] y ∈ Y, Φ y) := by - have hsub1 : X ⊆ Y := fun z hz => by have := hmem_eq z; rwa [← this] - have hsub2 : Y ⊆ X := fun z hz => by have := hmem_eq z; rwa [this] + have hsub1 : X ⊆ Y := fun z hz => by + rw [mem_iff_mem] at hz ⊢ + rw [← hmem_eq z]; exact hz + have hsub2 : Y ⊆ X := fun z hz => by + rw [mem_iff_mem] at hz ⊢ + rw [hmem_eq z]; exact hz have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset Y X hsub1 have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset X Y hsub2 have hl1_nil : l₁ = [] := by @@ -162,11 +166,11 @@ theorem delete {Φ : A → PROP} {X : S} {x : A} (h : FiniteSet.mem x X = true) : ([∗set] y ∈ X, Φ y) ⊣⊢ Φ x ∗ [∗set] y ∈ FiniteSet.diff X (FiniteSet.singleton x), Φ y := by unfold bigSepS - obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_sdiff (S := S) X x h + obtain ⟨l', hperm, hperm'⟩ := FiniteSet.toList_sdiff (S := S) X x h have hp1 := equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) simp only [BigOpL.cons] at hp1 have hp2 : Φ x ∗ bigOpL sep emp (fun _ => Φ) l' ⊣⊢ - Φ x ∗ bigOpL sep emp (fun _ => Φ) (toList (diff X (FiniteSet.singleton x))) := + Φ x ∗ bigOpL sep emp (fun _ => Φ) (toList (FiniteSet.diff X (FiniteSet.singleton x))) := sep_congr_r (equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm'.symm)) exact hp1.trans hp2 @@ -178,9 +182,10 @@ theorem insert {Φ : A → PROP} {X : S} {x : A} intro y ⟨hmem1, hmem2⟩ by_cases hyx : y = x · subst hyx; simp_all - · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx] at hmem1 - rw [FiniteSetLaws.mem_empty] at hmem1 - exact Bool.noConfusion hmem1 + · rw [FiniteSet.singleton] at hmem1 + have hmem1' := (FiniteSet.mem_insert_ne ∅ y x hyx).mp hmem1 + have := FiniteSetLaws.mem_empty (A := A) (S := S) y + exact this hmem1' have hunion := union (Φ := Φ) hdisj exact hunion.trans (sep_congr_l singleton) @@ -194,15 +199,25 @@ theorem union_2 {Φ : A → PROP} {X Y : S} · refine (sep_mono_l empty.1).trans ?_ refine emp_sep.1.trans ?_ have hmem_eq : ∀ z, FiniteSet.mem z (∅ ∪ Y) = FiniteSet.mem z Y := fun z => by - have hunion := FiniteSetLaws.mem_union (∅ : S) Y z + have hunion := FiniteSet.mem_union (∅ : S) Y z have hempty := FiniteSetLaws.mem_empty (S := S) (A := A) z cases hz : FiniteSet.mem z (∅ ∪ Y) <;> cases hy : FiniteSet.mem z Y · rfl - · have := hunion.mpr (Or.inr hy); rw [hz] at this; exact Bool.noConfusion this - · have := hunion.mp hz + · -- Need to show: false = true leads to contradiction + rw [← mem_iff_mem] at hy + have : z ∈ (∅ ∪ Y) := hunion.mpr (Or.inr hy) + rw [mem_iff_mem] at this + rw [hz] at this + exact Bool.noConfusion this + · -- Need to show: true = false leads to contradiction + rw [← mem_iff_mem] at hz + have := hunion.mp hz cases this with - | inl hl => rw [hempty] at hl; exact Bool.noConfusion hl - | inr hr => rw [hy] at hr; exact Bool.noConfusion hr + | inl hl => exact absurd hl hempty + | inr hr => + rw [mem_iff_mem] at hr + rw [hy] at hr + exact Bool.noConfusion hr · rfl exact (bigSepS_perm_of_mem_eq hmem_eq).2 · intro x X' hnotin IH @@ -210,9 +225,10 @@ theorem union_2 {Φ : A → PROP} {X Y : S} intro y ⟨hmem1, hmem2⟩ by_cases hyx : y = x · subst hyx; simp_all - · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx] at hmem1 - rw [FiniteSetLaws.mem_empty] at hmem1 - exact Bool.noConfusion hmem1 + · rw [FiniteSet.singleton] at hmem1 + have hmem1' := (FiniteSet.mem_insert_ne ∅ y x hyx).mp hmem1 + have := FiniteSetLaws.mem_empty (A := A) (S := S) y + exact this hmem1' have hunion_x_X' := union (Φ := Φ) hdisj have hins : ([∗set] y ∈ FiniteSet.singleton x ∪ X', Φ y) ⊣⊢ Φ x ∗ [∗set] y ∈ X', Φ y := hunion_x_X'.trans (sep_congr_l singleton) @@ -221,25 +237,51 @@ theorem union_2 {Φ : A → PROP} {X Y : S} refine h_assoc.1.trans ?_ refine (sep_mono_r IH).trans ?_ by_cases hx_in_Y : FiniteSet.mem x Y = true - · have hx_in_union : FiniteSet.mem x (X' ∪ Y) = true := - (FiniteSetLaws.mem_union X' Y x).mpr (Or.inr hx_in_Y) + · have hx_in_union : FiniteSet.mem x (X' ∪ Y) = true := by + have h1 : x ∈ Y := hx_in_Y + have h2 : x ∈ (X' ∪ Y) := (FiniteSet.mem_union X' Y x).mpr (Or.inr h1) + exact h2 have hmem_eq : ∀ w, FiniteSet.mem w (X' ∪ Y) = FiniteSet.mem w ((FiniteSet.singleton x ∪ X') ∪ Y) := fun w => by by_cases hwx : w = x · rw [hwx] - have lhs : FiniteSet.mem x (X' ∪ Y) = true := - (FiniteSetLaws.mem_union X' Y x).mpr (Or.inr hx_in_Y) + have lhs : FiniteSet.mem x (X' ∪ Y) = true := hx_in_union have rhs_inner : FiniteSet.mem x (FiniteSet.singleton x ∪ X') = true := by - rw [FiniteSetLaws.mem_union, FiniteSet.singleton, FiniteSetLaws.mem_insert_eq _ _ _ rfl] - simp - have rhs : FiniteSet.mem x ((FiniteSet.singleton x ∪ X') ∪ Y) = true := - (FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl rhs_inner) + have h1 : x ∈ (FiniteSet.singleton (S := S) x) := by + rw [FiniteSet.singleton] + exact FiniteSet.mem_insert_eq ∅ x x rfl + have h2 : x ∈ ((FiniteSet.singleton x : S) ∪ X') := (FiniteSet.mem_union (FiniteSet.singleton x) X' x).mpr (Or.inl h1) + exact h2 + have rhs : FiniteSet.mem x ((FiniteSet.singleton x ∪ X') ∪ Y) = true := by + have h1 : x ∈ (FiniteSet.singleton x ∪ X') := rhs_inner + have h2 : x ∈ ((FiniteSet.singleton x ∪ X') ∪ Y) := (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl h1) + exact h2 rw [lhs, rhs] - · rw [Bool.eq_iff_iff] - rw [FiniteSetLaws.mem_union X' Y w, FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y w] - rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) X' w] - rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hwx, FiniteSetLaws.mem_empty] - simp + · rw [Bool.eq_iff_iff, ← mem_iff_mem, ← mem_iff_mem] + constructor + · intro h + have := (FiniteSet.mem_union X' Y w).mp h + apply (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y w).mpr + cases this with + | inl hX' => + left + apply (FiniteSet.mem_union (FiniteSet.singleton x) X' w).mpr + right; exact hX' + | inr hY => + right; exact hY + · intro h + have := (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y w).mp h + apply (FiniteSet.mem_union X' Y w).mpr + cases this with + | inl hsingX' => + have := (FiniteSet.mem_union (FiniteSet.singleton x) X' w).mp hsingX' + cases this with + | inl hsing => + rw [FiniteSet.singleton] at hsing + have := (FiniteSet.mem_insert_ne ∅ w x hwx).mp hsing + exact absurd this (FiniteSetLaws.mem_empty (A := A) (S := S) w) + | inr hX' => left; exact hX' + | inr hY => right; exact hY refine (sep_mono_r (delete hx_in_union).1).trans ?_ refine sep_assoc.2.trans ?_ refine (sep_mono_l sep_elim_l).trans ?_ @@ -248,10 +290,13 @@ theorem union_2 {Φ : A → PROP} {X Y : S} · have hx_notin_union : FiniteSet.mem x (X' ∪ Y) = false := by have : ¬(FiniteSet.mem x (X' ∪ Y) = true) := by intro h - have := (FiniteSetLaws.mem_union X' Y x).mp h + have hmem : x ∈ (X' ∪ Y) := h + have := (FiniteSet.mem_union X' Y x).mp hmem cases this with - | inl h' => simp [h'] at hnotin - | inr h' => simp [h'] at hx_in_Y + | inl h' => exact hnotin h' + | inr h' => + have : FiniteSet.mem x Y = true := h' + exact hx_in_Y this cases h : FiniteSet.mem x (X' ∪ Y) · rfl · contradiction @@ -260,21 +305,48 @@ theorem union_2 {Φ : A → PROP} {X Y : S} by_cases hwx : w = x · rw [hwx] have lhs_inner : FiniteSet.mem x (FiniteSet.singleton (S := S) x) = true := by - rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_eq (S := S) _ _ _ rfl] + rw [FiniteSet.singleton, FiniteSet.mem_insert_eq (S := S) _ _ _ rfl] have lhs : FiniteSet.mem x (FiniteSet.singleton x ∪ (X' ∪ Y)) = true := - (FiniteSetLaws.mem_union (S := S) (FiniteSet.singleton x) (X' ∪ Y) x).mpr (Or.inl lhs_inner) + (FiniteSet.mem_union (S := S) (FiniteSet.singleton x) (X' ∪ Y) x).mpr (Or.inl lhs_inner) have rhs_inner : FiniteSet.mem x (FiniteSet.singleton x ∪ X') = true := - (FiniteSetLaws.mem_union (FiniteSet.singleton x) X' x).mpr (Or.inl lhs_inner) + (FiniteSet.mem_union (FiniteSet.singleton x) X' x).mpr (Or.inl lhs_inner) have rhs : FiniteSet.mem x ((FiniteSet.singleton x ∪ X') ∪ Y) = true := - (FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl rhs_inner) + (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y x).mpr (Or.inl rhs_inner) rw [lhs, rhs] - · rw [Bool.eq_iff_iff] - rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) (X' ∪ Y) w] - rw [FiniteSetLaws.mem_union (FiniteSet.singleton x ∪ X') Y w] - rw [FiniteSetLaws.mem_union (FiniteSet.singleton x) X' w] - rw [FiniteSetLaws.mem_union X' Y w] - rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hwx, FiniteSetLaws.mem_empty] - simp + · rw [Bool.eq_iff_iff, ← mem_iff_mem, ← mem_iff_mem] + constructor + · intro h + have := (FiniteSet.mem_union (FiniteSet.singleton x) (X' ∪ Y) w).mp h + apply (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y w).mpr + cases this with + | inl hsing => + left + apply (FiniteSet.mem_union (FiniteSet.singleton x) X' w).mpr + left; exact hsing + | inr hunion => + have := (FiniteSet.mem_union X' Y w).mp hunion + cases this with + | inl hX' => + left + apply (FiniteSet.mem_union (FiniteSet.singleton x) X' w).mpr + right; exact hX' + | inr hY => right; exact hY + · intro h + have := (FiniteSet.mem_union (FiniteSet.singleton x ∪ X') Y w).mp h + apply (FiniteSet.mem_union (FiniteSet.singleton x) (X' ∪ Y) w).mpr + cases this with + | inl hsingX' => + have := (FiniteSet.mem_union (FiniteSet.singleton x) X' w).mp hsingX' + cases this with + | inl hsing => left; exact hsing + | inr hX' => + right + apply (FiniteSet.mem_union X' Y w).mpr + left; exact hX' + | inr hY => + right + apply (FiniteSet.mem_union X' Y w).mpr + right; exact hY refine (insert hx_notin_union).2.trans ?_ exact (@bigSepS_perm_of_mem_eq PROP _ S A _ _ _ Φ _ _ hmem_eq).1 have h1 : ([∗set] y ∈ X, Φ y) ⊢ ([∗set] y ∈ Y, Φ y) -∗ ([∗set] y ∈ X ∪ Y, Φ y) := @@ -292,16 +364,17 @@ theorem insert_2 {Φ : A → PROP} {X : S} {x : A} refine (sep_assoc (PROP := PROP)).2.trans ?_ refine (sep_mono_l sep_elim_l).trans ?_ have hunion_sub_X : (FiniteSet.singleton x ∪ X) ⊆ X := fun y hy => by - rw [FiniteSetLaws.mem_union] at hy + rw [FiniteSet.mem_union] at hy cases hy with | inl h => by_cases hyx : y = x · subst hyx; exact hx - · rw [FiniteSet.singleton, FiniteSetLaws.mem_insert_ne _ _ _ hyx, FiniteSetLaws.mem_empty] at h - exact Bool.noConfusion h + · rw [FiniteSet.singleton] at h + have h' := (FiniteSet.mem_insert_ne ∅ y x hyx).mp h + exact absurd h' (FiniteSetLaws.mem_empty (A := A) (S := S) y) | inr h => exact h have hX_sub_union : X ⊆ (FiniteSet.singleton x ∪ X) := fun y hy => by - rw [FiniteSetLaws.mem_union] + rw [FiniteSet.mem_union] right; exact hy have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset X (FiniteSet.singleton x ∪ X) hunion_sub_X have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (FiniteSet.singleton x ∪ X) X hX_sub_union @@ -329,7 +402,7 @@ theorem insert_2' {Φ : A → PROP} {X : S} {x : A} have heq : ([∗set] y ∈ X ∪ FiniteSet.singleton x, Φ y) ⊣⊢ ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) := by unfold bigSepS - have hperm := FiniteSetLaws.toList_union_comm (S := S) (A := A) X (FiniteSet.singleton x) + have hperm := FiniteSet.toList_union_comm (S := S) (A := A) X (FiniteSet.singleton x) exact equiv_iff.mp (@BigOpL.perm PROP _ _ sep emp _ Φ _ _ hperm) have h1 : ⊢ Φ x -∗ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ FiniteSet.singleton x ∪ X, Φ y) := entails_wand insert_2 @@ -385,16 +458,19 @@ theorem delete_2 {Φ : A → PROP} {X : S} {x : A} · exact (delete (Φ := Φ) hx).2 · have hdiff_sub : ∀ y, FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true → FiniteSet.mem y X = true := fun y hy => - ((FiniteSetLaws.mem_diff_singleton X x y).mp hy).1 + ((FiniteSet.mem_diff_singleton X x y).mp hy).1 have hX_sub : ∀ y, FiniteSet.mem y X = true → FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true := by intro y hy - rw [FiniteSetLaws.mem_diff_singleton] - constructor - · exact hy - · intro heq - subst heq - exact hx hy + have : y ∈ X := hy + have : y ∈ FiniteSet.diff X (FiniteSet.singleton x) := by + apply (FiniteSet.mem_diff_singleton X x y).mpr + constructor + · exact hy + · intro heq + subst heq + exact hx hy + exact this refine (sep_mono_l hAff.affine).trans emp_sep.1 |>.trans ?_ have hX_sub_diff : X ⊆ FiniteSet.diff X (FiniteSet.singleton x) := fun y hy => hX_sub y hy have hdiff_sub_X : FiniteSet.diff X (FiniteSet.singleton x) ⊆ X := fun y hy => hdiff_sub y hy @@ -592,31 +668,26 @@ theorem filter_acc' (φ : A → Prop) [DecidablePred φ] {Φ : A → PROP} {X Y -- First, show that filter φ Y ⊆ X have hfilter_sub : FiniteSet.filter (fun x => decide (φ x)) Y ⊆ X := by intro z hz - have ⟨hz_Y, hz_φ⟩ := FiniteSetLaws.mem_filter Y (fun x => decide (φ x)) z |>.mp hz + have ⟨hz_Y, hz_φ⟩ := FiniteSet.mem_filter Y (fun x => decide (φ x)) z |>.mp hz have : φ z := of_decide_eq_true hz_φ exact h z hz_Y this -- Use union_diff to decompose X - have ⟨hdisj, hmem_decomp⟩ := FiniteSetLaws.union_diff X (FiniteSet.filter (fun x => decide (φ x)) Y) hfilter_sub - -- X = filterY ∪ (X \ filterY), and they are disjoint - have hX_decomp : X = FiniteSet.filter (fun x => decide (φ x)) Y ∪ - FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y) := by - apply @FiniteSetLaws.ext S A _ _ - intro z - apply Bool.eq_iff_iff.mpr - constructor - · intro hz; rw [FiniteSetLaws.mem_union]; exact (hmem_decomp z).mp hz - · intro hz; rw [FiniteSetLaws.mem_union] at hz; exact (hmem_decomp z).mpr hz + have ⟨hdisj, hmem_decomp⟩ := FiniteSet.union_diff X (FiniteSet.filter (fun x => decide (φ x)) Y) hfilter_sub + -- X ≡ filterY ∪ (X \ filterY), and they are disjoint (given by hmem_decomp) + -- We'll use the membership equivalence to prove the bigop equivalence -- Apply union: [∗set] X = [∗set] filterY ∗ [∗set] (X \ filterY) have hunion := @union PROP _ S A _ _ _ Φ (FiniteSet.filter (fun x => decide (φ x)) Y) (FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y)) hdisj have hX_split : ([∗set] y ∈ X, Φ y) ⊣⊢ ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) Y, Φ y) ∗ ([∗set] y ∈ FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y), Φ y) := by - -- Convert equality to equivalence, then compose with hunion - have heq : ([∗set] y ∈ X, Φ y) = ([∗set] y ∈ FiniteSet.filter (fun x => decide (φ x)) Y ∪ - FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y), Φ y) := - congrArg (fun s => bigSepS Φ s) hX_decomp - exact BIBase.BiEntails.of_eq heq |>.trans hunion + -- Use membership equivalence to prove bigop equivalence + have hmem_eq : ∀ z, FiniteSet.mem z X = FiniteSet.mem z (FiniteSet.filter (fun x => decide (φ x)) Y ∪ + FiniteSet.diff X (FiniteSet.filter (fun x => decide (φ x)) Y)) := fun z => by + rw [Bool.eq_iff_iff, ← mem_iff_mem, ← mem_iff_mem] + exact hmem_decomp z + have heq := @bigSepS_perm_of_mem_eq PROP _ S A _ _ _ Φ X _ hmem_eq + exact heq.trans hunion -- Apply filter': [∗set] filterY = [∗set] y ∈ Y, if φ y then Φ y else emp have hfilter := @filter' PROP _ S A _ _ _ φ _ Φ Y -- Combine: [∗set] X ⊣⊢ A ∗ Z where A = [∗set] Y with filter, Z = [∗set] (X \ filterY) @@ -665,7 +736,7 @@ theorem filter_acc [BIAffine PROP] (φ : A → Prop) [DecidablePred φ] {Φ : A /-! ## Separation Logic Combinators -/ -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_sep` in Rocq Iris. -/ theorem sep' {Φ Ψ : A → PROP} {X : S} : ([∗set] y ∈ X, Φ y ∗ Ψ y) ⊣⊢ ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ X, Ψ y) := by @@ -756,13 +827,13 @@ theorem forall' [BIAffine PROP] {Φ : A → PROP} {X : S} /-! ## Modal Operators -/ -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_persistently` in Rocq Iris. -/ theorem persistently [BIAffine PROP] {Φ : A → PROP} {X : S} : ( ([∗set] y ∈ X, Φ y)) ⊣⊢ [∗set] y ∈ X, (Φ y) := (persistently_congr elements).trans (BigSepL.persistently.trans elements.symm) -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_dup` in Rocq Iris. -/ theorem dup {P : PROP} [hAff : Affine P] {X : S} : ⊢ □ (P -∗ P ∗ P) -∗ P -∗ [∗set] _x ∈ X, P := by @@ -783,19 +854,18 @@ theorem dup {P : PROP} [hAff : Affine P] {X : S} : refine (sep_mono_l ih).trans ?_ exact sep_comm (PROP := PROP).1 -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_later` in Rocq Iris. -/ theorem later [BIAffine PROP] {Φ : A → PROP} {X : S} : iprop(▷ [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷ Φ y := (later_congr elements).trans (BigSepL.later.trans elements.symm) -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_later_2` in Rocq Iris. -/ theorem later_2 {Φ : A → PROP} {X : S} : ([∗set] y ∈ X, ▷ Φ y) ⊢ iprop(▷ [∗set] y ∈ X, Φ y) := elements.1.trans (BigSepL.later_2.trans (later_mono elements.2)) -omit [DecidableEq A] [FiniteSetLaws S A] in /-- Corresponds to `big_sepS_laterN` in Rocq Iris. -/ theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : iprop(▷^[n] [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷^[n] Φ y := by @@ -803,7 +873,7 @@ theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : | zero => exact .rfl | succ m ih => exact (later_congr ih).trans later -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_laterN_2` in Rocq Iris. -/ theorem laterN_2 {Φ : A → PROP} {n : Nat} {X : S} : ([∗set] y ∈ X, ▷^[n] Φ y) ⊢ iprop(▷^[n] [∗set] y ∈ X, Φ y) := by @@ -813,7 +883,7 @@ theorem laterN_2 {Φ : A → PROP} {n : Nat} {X : S} : /-! ## Introduction and Elimination -/ -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [FiniteSetLaws A S] in private theorem intro_list {Φ : A → PROP} {X : S} {l : List A} (hmem : ∀ x, List.Mem x l → FiniteSet.mem x X = true) : (□ (∀ x, ⌜FiniteSet.mem x X = true⌝ → Φ x)) ⊢ bigOpL sep emp (fun _ => Φ) l := by @@ -882,7 +952,7 @@ theorem elem_of_acc_impl {Φ : A → PROP} {X : S} {x : A} apply imp_intro' apply pure_elim_l intro hy_diff - have ⟨hy_X, hy_ne⟩ := (FiniteSetLaws.mem_diff_singleton X x y).mp hy_diff + have ⟨hy_X, hy_ne⟩ := (FiniteSet.mem_diff_singleton X x y).mp hy_diff exact (forall_elim y).trans <| (imp_mono_l (pure_mono fun _ => hy_X)).trans true_imp.1 |>.trans <| (imp_mono_l (pure_mono fun _ => hy_ne.symm)).trans true_imp.1 @@ -911,7 +981,7 @@ theorem subseteq {Φ : A → PROP} {X Y : S} /-! ## Commuting Lemmas -/ -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_sepL` in Rocq Iris. -/ theorem sepL {B : Type _} (Φ : A → Nat → B → PROP) (X : S) (l : List B) : ([∗set] x ∈ X, [∗list] k↦y ∈ l, Φ x k y) ⊣⊢ @@ -923,9 +993,9 @@ theorem sepL {B : Type _} (Φ : A → Nat → B → PROP) (X : S) (l : List B) : _ ⊣⊢ [∗list] k↦y ∈ l, [∗set] x ∈ X, Φ x k y := equiv_iff.mp <| BigSepL.congr (fun k y => equiv_iff.mpr <| elements (Φ := fun x => Φ x k y).symm) -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_sepS` in Rocq Iris. -/ -theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet B T] [FiniteSetLaws B T] (Φ : A → B → PROP) (X : S) (Y : T) : ([∗set] x ∈ X, [∗set] y ∈ Y, Φ x y) ⊣⊢ ([∗set] y ∈ Y, [∗set] x ∈ X, Φ x y) := by @@ -939,7 +1009,7 @@ theorem sepS {B : Type _} {T : Type _} [DecidableEq B] [FiniteSet T B] [FiniteSe equiv_iff.mp <| BigSepL.congr (fun _ y => equiv_iff.mpr <| elements (Φ := fun x => Φ x y).symm) _ ⊣⊢ [∗set] y ∈ Y, [∗set] x ∈ X, Φ x y := elements (Φ := fun y => [∗set] x ∈ X, Φ x y).symm -omit [DecidableEq A] [FiniteSetLaws S A] in +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_sepM` in Rocq Iris. -/ theorem sepM {B : Type _} {M : Type _ → Type _} {K : Type _} [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index 970b191a..9ca5b32d 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -23,7 +23,7 @@ variable [DecidableEq K] [FiniteMap K M] [FiniteMapLaws K M] section DomainSet -variable {S : Type _} [FiniteSet S K] [FiniteSetLaws S K] +variable {S : Type _} [FiniteSet K S] [FiniteSetLaws K S] /-- Convert map domain to a finite set. -/ def domSet (m : M V) : S := FiniteSet.ofList ((FiniteMap.toList m).map Prod.fst) @@ -34,7 +34,7 @@ def ofSet (c : V) (X : S) : M V := FiniteMap.ofList ((FiniteSet.toList X).map (f /-- Corresponds to Rocq's `not_elem_of_dom`. -/ theorem not_elem_of_domSet : ∀ (m : M V) k, get? m k = none ↔ k ∉ (domSet m : S) := by intro m k - simp only [domSet, Membership.mem] + simp only [domSet] rw [FiniteSetLaws.mem_ofList] constructor · intro h_none h_in @@ -58,7 +58,7 @@ theorem not_elem_of_domSet : ∀ (m : M V) k, get? m k = none ↔ k ∉ (domSet /-- Corresponds to Rocq's `elem_of_dom`. -/ theorem elem_of_domSet : ∀ (m : M V) k, (∃ v, get? m k = some v) ↔ k ∈ (domSet m : S) := by intro m k - simp only [domSet, Membership.mem] + simp only [domSet] rw [FiniteSetLaws.mem_ofList] constructor · intro ⟨v, h_some⟩ @@ -80,7 +80,7 @@ theorem domSet_empty : domSet (∅ : M V) = (∅ : S) := by /-- The domain after insert includes the inserted key. -/ theorem domSet_insert (m : M V) (k : K) (v : V) : k ∈ (domSet (insert m k v) : S) := by - simp only [domSet, Membership.mem] + simp only [domSet] rw [FiniteSetLaws.mem_ofList] rw [List.mem_map] have : get? (insert m k v) k = some v := lookup_insert_eq m k v @@ -90,11 +90,9 @@ theorem domSet_insert (m : M V) (k : K) (v : V) : /-- Domain of ofSet equals the original set. -/ theorem domSet_ofSet (c : V) (X : S) : - domSet (ofSet c X : M V) = X := by - apply @FiniteSetLaws.ext S K _ _ + domSet (ofSet c X : M V) ≡ X := by intro k simp only [domSet] - apply Bool.eq_iff_iff.mpr constructor · -- Forward: k ∈ domSet (ofSet c X) → k ∈ X intro hmem diff --git a/src/Iris/Std/FiniteSet.lean b/src/Iris/Std/FiniteSet.lean index b7f294d3..aa1f49c7 100644 --- a/src/Iris/Std/FiniteSet.lean +++ b/src/Iris/Std/FiniteSet.lean @@ -26,14 +26,7 @@ namespace Iris.Std The type `S` represents a finite set of elements of type `A`. This corresponds to Rocq's `FinSet` class from stdpp. -/ -class FiniteSet (S : Type u) (A : outParam (Type v)) where - /-- Membership: check if an element is in the set. -/ - mem : A → S → Bool - /-- Insert an element into the set. -/ - insert : A → S → S - /-- Remove an element from the set (singleton difference). - Corresponds to Rocq's `X ∖ {[ x ]}`. -/ - erase : A → S → S +class FiniteSet (A : outParam (Type v)) (S : Type u) where /-- The empty set. -/ empty : S /-- Convert the set to a list of elements. @@ -42,20 +35,28 @@ class FiniteSet (S : Type u) (A : outParam (Type v)) where /-- Construct a set from a list of elements. Corresponds to Rocq's `list_to_set`. -/ ofList : List A → S - /-- Union of two sets. -/ - union : S → S → S - /-- Intersection of two sets. -/ - inter : S → S → S - /-- Difference: remove all elements of second set from first. - `diff S₁ S₂` contains elements in `S₁` but not in `S₂`. - Corresponds to Rocq's `S₁ ∖ S₂`. -/ - diff : S → S → S -export FiniteSet (mem insert erase toList ofList union inter diff) +export FiniteSet (empty toList ofList) namespace FiniteSet -variable {S : Type u} {A : Type v} [FiniteSet S A] +variable {A : Type v} {S : Type u} [DecidableEq A] [FiniteSet A S] + +/-- Membership: check if an element is in the set. -/ +def mem : A → S → Bool := fun x s => (toList s).contains x +/-- Insert an element into the set. -/ +def insert : A → S → S := fun x s => ofList (x :: toList s) +/-- Remove an element from the set (singleton difference). + Corresponds to Rocq's `X ∖ {[ x ]}`. -/ +def erase : A → S → S := fun x s => ofList ((toList s).filter (fun y => decide (y ≠ x))) +/-- Union of two sets. -/ +def union : S → S → S := fun s₁ s₂ => ofList (toList s₁ ++ toList s₂) +/-- Intersection of two sets. -/ +def inter : S → S → S := fun s₁ s₂ => ofList ((toList s₁).filter (fun x => mem x s₂)) +/-- Difference: remove all elements of second set from first. + `diff S₁ S₂` contains elements in `S₁` but not in `S₂`. + Corresponds to Rocq's `S₁ ∖ S₂`. -/ +def diff : S → S → S := fun s₁ s₂ => ofList ((toList s₁).filter (fun x => !mem x s₂)) /-- Empty set instance for `∅` notation. -/ instance : EmptyCollection S := ⟨empty⟩ @@ -73,26 +74,77 @@ instance : Inter S := ⟨inter⟩ /-- Difference instance for `\` notation. -/ instance : SDiff S := ⟨diff⟩ +/-- Membership instance for finite sets: `x ∈ s` means element `x` is in set `s`. -/ +instance : Membership A S where + mem s x := FiniteSet.mem (A := A) x s = true + /-- Subset relation: `S₁` is a subset of `S₂` if every element in `S₁` is also in `S₂`. Corresponds to Rocq's `S₁ ⊆ S₂`. -/ -def Subset (S₁ S₂ : S) : Prop := ∀ x, mem x S₁ → mem x S₂ +def Subset (S₁ S₂ : S) : Prop := ∀ x, x ∈ S₁ → x ∈ S₂ instance : HasSubset S := ⟨Subset⟩ /-- Two sets are disjoint if they share no common elements. Corresponds to Rocq's `S₁ ## S₂`. -/ -def Disjoint (S₁ S₂ : S) : Prop := ∀ x, ¬(mem x S₁ ∧ mem x S₂) +def Disjoint (S₁ S₂ : S) : Prop := ∀ x, ¬(x ∈ S₁ ∧ x ∈ S₂) + +/-- Set equivalence: two sets are equivalent if they have the same elements. + Corresponds to Rocq's `X ≡ Y`. -/ +def SetEquiv (X Y : S) : Prop := ∀ x, x ∈ X ↔ x ∈ Y + +/-- Notation for set equivalence -/ +infix:50 " ≡ " => SetEquiv + +/-- Set equivalence is reflexive -/ +theorem setEquiv_refl : ∀ (X : S), X ≡ X := by + intro X x + rfl + +/-- Set equivalence is symmetric -/ +theorem setEquiv_symm : ∀ (X Y : S), X ≡ Y → Y ≡ X := by + intro X Y h x + exact (h x).symm + +/-- Set equivalence is transitive -/ +theorem setEquiv_trans : ∀ (X Y Z : S), X ≡ Y → Y ≡ Z → X ≡ Z := by + intro X Y Z hxy hyz x + exact Iff.trans (hxy x) (hyz x) + +/-- Set equivalence is an equivalence relation -/ +instance : Equivalence (@SetEquiv A S _ _) where + refl := setEquiv_refl + symm := fun {X Y} hxy => setEquiv_symm X Y hxy + trans := fun {X Y Z} hxy hyz => setEquiv_trans X Y Z hxy hyz /-- Filter: keep only elements satisfying a predicate. Corresponds to Rocq's `filter φ X`. -/ def filter (φ : A → Bool) : S → S := fun s => ofList ((toList s).filter φ) +/-- Bind operation on sets. Flatmap a function over all elements. + Corresponds to Rocq's `set_bind`. -/ +def bind {B : Type w} {S' : Type u} [FiniteSet B S'] (f : A → S') (X : S) : S' := + ofList ((toList X).flatMap (fun x => toList (f x))) + +/-- Option map operation on sets. Maps a partial function, keeping only Some values. + Corresponds to Rocq's `set_omap`. -/ +def omap {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] + (f : A → Option B) (X : S) : S' := + ofList ((toList X).filterMap f) + +/-- Forall predicate on sets. Corresponds to Rocq's `set_Forall`. -/ +def setForall (P : A → Prop) (X : S) : Prop := + ∀ x, x ∈ X → P x + +/-- Exists predicate on sets. Corresponds to Rocq's `set_Exists`. -/ +def setExists (P : A → Prop) (X : S) : Prop := + ∃ x, x ∈ X ∧ P x + end FiniteSet -/-- Membership instance for finite sets: `x ∈ s` means element `x` is in set `s`. -/ -instance {S : Type u} {A : Type v} [inst : FiniteSet S A] : Membership A S := - ⟨fun (s : S) (x : A) => inst.mem x s⟩ +/-- Helper: x ∈ s is definitionally equal to mem x s = true -/ +@[simp] theorem mem_iff_mem {A : Type v} {S : Type u} [DecidableEq A] [FiniteSet A S] (x : A) (s : S) : + x ∈ s ↔ FiniteSet.mem x s = true := Iff.rfl /-- Helper lemma: convert getElem? evidence to List.Mem -/ theorem List.mem_of_getElem? {l : List α} {i : Nat} {x : α} (h : l[i]? = some x) : x ∈ l := by @@ -105,25 +157,9 @@ theorem List.getElem?_of_mem {α : Type _} {l : List α} {x : α} (h : x ∈ l) exact ⟨i, List.getElem?_eq_some_iff.mpr ⟨hi, hget⟩⟩ /-- Laws that a finite set implementation must satisfy. -/ -class FiniteSetLaws (S : Type u) (A : Type v) [DecidableEq A] [FiniteSet S A] where +class FiniteSetLaws (A : Type v) (S : Type u) [DecidableEq A] [FiniteSet A S] where /-- Membership in empty set is always false. -/ - mem_empty : ∀ (x : A), FiniteSet.mem x (∅ : S) = false - /-- Membership in singleton: true iff equal. Corresponds to Rocq's `elem_of_singleton`. -/ - mem_singleton : ∀ (x y : A), FiniteSet.mem x (FiniteSet.singleton y : S) = true ↔ x = y - /-- Membership after insert: true if equal, otherwise unchanged. -/ - mem_insert_eq : ∀ (s : S) (x y : A), x = y → FiniteSet.mem x (FiniteSet.insert y s) = true - /-- Membership after insert: unchanged if not equal. -/ - mem_insert_ne : ∀ (s : S) (x y : A), x ≠ y → - FiniteSet.mem x (FiniteSet.insert y s) = FiniteSet.mem x s - /-- Singleton as insert into empty. -/ - singleton_insert : ∀ (x : A), (FiniteSet.singleton x : S) = FiniteSet.insert x ∅ - /-- Set extensionality: sets with same membership are equal. -/ - ext : ∀ (X Y : S), (∀ x, FiniteSet.mem x X = FiniteSet.mem x Y) → X = Y - /-- Membership after erase: false if equal, otherwise unchanged. -/ - mem_erase_eq : ∀ (s : S) (x y : A), x = y → FiniteSet.mem x (FiniteSet.erase y s) = false - /-- Membership after erase: unchanged if not equal. -/ - mem_erase_ne : ∀ (s : S) (x y : A), x ≠ y → - FiniteSet.mem x (FiniteSet.erase y s) = FiniteSet.mem x s + mem_empty : ∀ (x : A), x ∉ (∅ : S) /-- Converting to list and back preserves the set (up to permutation). -/ toList_ofList : ∀ (l : List A) (s : S), l.Nodup → FiniteSet.ofList l = s → (FiniteSet.toList s).Perm l @@ -131,64 +167,104 @@ class FiniteSetLaws (S : Type u) (A : Type v) [DecidableEq A] [FiniteSet S A] wh ofList_toList : ∀ (s : S), ∃ l', (FiniteSet.toList s).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = s /-- Inserting into a set gives a list permutation including the new element. -/ - set_to_list_insert : ∀ (s : S) (x : A), FiniteSet.mem x s = false → + set_to_list_insert : ∀ (s : S) (x : A), x ∉ s → (FiniteSet.toList (FiniteSet.insert x s)).Perm (x :: FiniteSet.toList s) /-- Erasing from a set gives a list permutation without the element. -/ - set_to_list_erase : ∀ (s : S) (x : A), FiniteSet.mem x s = true → + set_to_list_erase : ∀ (s : S) (x : A), x ∈ s → ∃ l', (FiniteSet.toList s).Perm (x :: l') ∧ FiniteSet.toList (FiniteSet.erase x s) = l' /-- Converting empty list gives empty set. -/ ofList_nil : FiniteSet.ofList ([] : List A) = (∅ : S) /-- toList of empty set is the empty list. -/ toList_empty : FiniteSet.toList (∅ : S) = [] - /-- toList of singleton set is a singleton list (up to permutation). -/ - toList_singleton : ∀ (x : A), (FiniteSet.toList (FiniteSet.singleton x : S)).Perm [x] - /-- toList of union when disjoint (up to permutation). -/ - toList_union : ∀ (X Y : S), FiniteSet.Disjoint X Y → - ∃ l', (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList X ++ l') ∧ - (FiniteSet.toList Y).Perm l' - /-- toList of set difference (up to permutation). -/ - toList_sdiff : ∀ (X : S) (x : A), FiniteSet.mem x X = true → - ∃ l', (FiniteSet.toList X).Perm (x :: l') ∧ - (FiniteSet.toList (FiniteSet.diff X (FiniteSet.singleton x))).Perm l' /-- Membership is preserved by toList. -/ - mem_toList : ∀ (X : S) (x : A), x ∈ FiniteSet.toList X ↔ FiniteSet.mem x X = true - /-- Membership in difference: y ∈ X \ {x} ↔ y ∈ X ∧ y ≠ x -/ - mem_diff_singleton : ∀ (X : S) (x y : A), - FiniteSet.mem y (FiniteSet.diff X (FiniteSet.singleton x)) = true ↔ - (FiniteSet.mem y X = true ∧ y ≠ x) - /-- Subset decomposition: If Y ⊆ X, then X = Y ∪ (X \ Y) up to the disjointness condition. -/ - union_diff : ∀ (X Y : S), Y ⊆ X → - FiniteSet.Disjoint Y (FiniteSet.diff X Y) ∧ - (∀ z, FiniteSet.mem z X = true ↔ (FiniteSet.mem z Y = true ∨ FiniteSet.mem z (FiniteSet.diff X Y) = true)) + mem_toList : ∀ (X : S) (x : A), x ∈ FiniteSet.toList X ↔ x ∈ X /-- Subset relation preserved by toList: if Y ⊆ X, toList Y elements appear in toList X. -/ toList_subset : ∀ (X Y : S), Y ⊆ X → ∃ l, (FiniteSet.toList Y ++ l).Perm (FiniteSet.toList X) - /-- Membership in union: x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y -/ - mem_union : ∀ (X Y : S) (x : A), - FiniteSet.mem x (X ∪ Y) = true ↔ (FiniteSet.mem x X = true ∨ FiniteSet.mem x Y = true) - /-- Union is commutative for toList (up to permutation). -/ - toList_union_comm : ∀ (X Y : S), - (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList (Y ∪ X)) /-- toList of filter is related to filter over toList. -/ toList_filter : ∀ (X : S) (φ : A → Bool), (FiniteSet.toList (FiniteSet.filter φ X)).Perm ((FiniteSet.toList X).filter φ) - /-- Membership in filter: x ∈ filter φ X ↔ x ∈ X ∧ φ x = true -/ - mem_filter : ∀ (X : S) (φ : A → Bool) (x : A), - FiniteSet.mem x (FiniteSet.filter φ X) = true ↔ (FiniteSet.mem x X = true ∧ φ x = true) /-- Membership in ofList: x ∈ ofList l ↔ x ∈ l -/ mem_ofList : ∀ (l : List A) (x : A), - FiniteSet.mem x (FiniteSet.ofList l : S) = true ↔ x ∈ l + x ∈ (FiniteSet.ofList l : S) ↔ x ∈ l namespace FiniteSet -variable {S : Type u} {A : Type v} [DecidableEq A] [FiniteSet S A] [FiniteSetLaws S A] +variable {A : Type v} {S : Type u} [DecidableEq A] [FiniteSet A S] [FiniteSetLaws A S] + +/-- Membership in singleton: true iff equal. Corresponds to Rocq's `elem_of_singleton`. -/ +theorem mem_singleton (x y : A) : x ∈ (FiniteSet.singleton y : S) ↔ x = y := by + sorry + +/-- Membership after insert: true if equal, otherwise unchanged. -/ +theorem mem_insert_eq (s : S) (x y : A) (h : x = y) : x ∈ (FiniteSet.insert y s) := by + sorry + +/-- Membership after insert: unchanged if not equal. -/ +theorem mem_insert_ne (s : S) (x y : A) (h : x ≠ y) : x ∈ (FiniteSet.insert y s) ↔ x ∈ s := by + sorry + +/-- Singleton as insert into empty. -/ +theorem singleton_insert (x : A) : (FiniteSet.singleton x : S) = FiniteSet.insert x ∅ := by + rfl + +/-- Membership after erase: false if equal, otherwise unchanged. -/ +theorem mem_erase_eq (s : S) (x y : A) (h : x = y) : x ∉ (FiniteSet.erase y s) := by + sorry + +/-- Membership after erase: unchanged if not equal. -/ +theorem mem_erase_ne (s : S) (x y : A) (h : x ≠ y) : + x ∈ (FiniteSet.erase y s) ↔ x ∈ s := by + sorry + +/-- toList of singleton set is a singleton list (up to permutation). -/ +theorem toList_singleton (x : A) : (FiniteSet.toList (FiniteSet.singleton x : S)).Perm [x] := by + sorry + +/-- toList of union when disjoint (up to permutation). -/ +theorem toList_union (X Y : S) (h : FiniteSet.Disjoint X Y) : + ∃ l', (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList X ++ l') ∧ + (FiniteSet.toList Y).Perm l' := by + sorry + +/-- toList of set difference (up to permutation). -/ +theorem toList_sdiff (X : S) (x : A) (h : FiniteSet.mem x X = true) : + ∃ l', (FiniteSet.toList X).Perm (x :: l') ∧ + (FiniteSet.toList (FiniteSet.diff X (FiniteSet.singleton x))).Perm l' := by + sorry + +/-- Membership in difference: y ∈ X \ {x} ↔ y ∈ X ∧ y ≠ x -/ +theorem mem_diff_singleton (X : S) (x y : A) : + y ∈ (FiniteSet.diff X (FiniteSet.singleton x)) ↔ (y ∈ X ∧ y ≠ x) := by + sorry + +/-- Subset decomposition: If Y ⊆ X, then X = Y ∪ (X \ Y) up to the disjointness condition. -/ +theorem union_diff (X Y : S) (h : Y ⊆ X) : + FiniteSet.Disjoint Y (FiniteSet.diff X Y) ∧ + (X ≡ Y ∪ (FiniteSet.diff X Y)) := by + sorry + +/-- Membership in union: x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y -/ +theorem mem_union (X Y : S) (x : A) : + x ∈ (X ∪ Y) ↔ (x ∈ X ∨ x ∈ Y) := by + sorry + +/-- Union is commutative for toList (up to permutation). -/ +theorem toList_union_comm (X Y : S) : + (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList (Y ∪ X)) := by + sorry + +/-- Membership in filter: x ∈ filter φ X ↔ x ∈ X ∧ φ x = true -/ +theorem mem_filter (X : S) (φ : A → Bool) (x : A) : + x ∈ (FiniteSet.filter φ X) ↔ (x ∈ X ∧ φ x = true) := by + sorry /-- Size of a finite set: number of elements. Corresponds to Rocq's `size`. -/ def size (s : S) : Nat := (toList s).length /-- The set is finite (always true for FiniteSet). Corresponds to Rocq's `set_finite`. -/ -theorem set_finite (X : S) : ∃ (l : List A), ∀ x, x ∈ l ↔ mem x X = true := by +theorem set_finite (X : S) : ∃ (l : List A), ∀ x, x ∈ l ↔ x ∈ X := by exists toList X intro x exact FiniteSetLaws.mem_toList X x @@ -199,27 +275,20 @@ section Elements Corresponds to Rocq's `elements_proper`. -/ theorem toList_proper (X Y : S) (h : ∀ x, mem x X = mem x Y) : (toList X).Perm (toList Y) := by - have : X = Y := FiniteSetLaws.ext X Y h - rw [this] + sorry /-- Converting list to set and back gives the original set (up to permutation). Corresponds to Rocq's `list_to_set_elements`. -/ -theorem ofList_toList_equiv (X : S) : ∀ x, mem x (ofList (toList X) : S) = mem x X := by +theorem ofList_toList_equiv (X : S) : ∀ x, x ∈ (ofList (toList X) : S) ↔ x ∈ X := by intro x -- Use mem_ofList and mem_toList axioms - cases h : mem x (ofList (toList X) : S) <;> cases h' : mem x X - · rfl - · -- Contradiction: mem x X = true but mem x (ofList (toList X)) = false - have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h' - have : mem x (ofList (toList X) : S) = true := (FiniteSetLaws.mem_ofList (toList X) x).mpr this - rw [h] at this - cases this - · -- Contradiction: mem x (ofList (toList X)) = true but mem x X = false + constructor + · intro h have : x ∈ toList X := (FiniteSetLaws.mem_ofList (toList X) x).mp h - have : mem x X = true := (FiniteSetLaws.mem_toList X x).mp this - rw [h'] at this - cases this - · rfl + exact (FiniteSetLaws.mem_toList X x).mp this + · intro h + have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h + exact (FiniteSetLaws.mem_ofList (toList X) x).mpr this /-- Converting a NoDup list to set and back gives a permutation. Corresponds to Rocq's `elements_list_to_set`. -/ @@ -230,21 +299,20 @@ theorem toList_ofList_perm (l : List A) (h : l.Nodup) : /-- Union of singleton and set when element not in set. Corresponds to Rocq's `elements_union_singleton`. -/ -theorem toList_union_singleton (X : S) (x : A) (h : mem x X = false) : +theorem toList_union_singleton (X : S) (x : A) (h : x ∉ X) : (toList (union (singleton x) X)).Perm (x :: toList X) := by -- Use the fact that {x} and X are disjoint, then use toList_union have hdisj : Disjoint (singleton x) X := by intro y intro ⟨h1, h2⟩ -- y ∈ {x} means y = x - have : y = x := (FiniteSetLaws.mem_singleton y x).mp h1 + have : y = x := (mem_singleton y x).mp h1 rw [this] at h2 - rw [h] at h2 - cases h2 + exact h h2 -- Get the permutation from toList_union - obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union (singleton x) X hdisj + obtain ⟨l', hperm, hperm'⟩ := toList_union (singleton x) X hdisj -- toList (singleton x) is a permutation of [x] - have hsing := FiniteSetLaws.toList_singleton (A := A) (S := S) x + have hsing := toList_singleton (A := A) (S := S) x -- Build up the permutation step by step have h1 : (toList (singleton x) ++ l').Perm ([x] ++ l') := List.Perm.append hsing (List.Perm.refl l') @@ -270,38 +338,30 @@ theorem size_empty : size (∅ : S) = 0 := by rfl /-- Size 0 iff empty set. Corresponds to Rocq's `size_empty_iff`. -/ -theorem size_empty_iff (X : S) : size X = 0 ↔ ∀ x, mem x X = false := by +theorem size_empty_iff (X : S) : size X = 0 ↔ ∀ x, x ∉ X := by constructor - · -- Forward: size X = 0 → ∀ x, mem x X = false + · -- Forward: size X = 0 → ∀ x, x ∉ X intro hsize x unfold size at hsize -- toList X has length 0, so it must be [] have hnil : toList X = [] := List.eq_nil_of_length_eq_zero hsize - -- If mem x X were true, then x ∈ toList X, but toList X = [] - cases hmem : mem x X - · rfl - · -- Case: mem x X = true, derive contradiction - have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr hmem - rw [hnil] at this - cases this - · -- Backward: (∀ x, mem x X = false) → size X = 0 - intro h - -- Show X = ∅ by extensionality, then use size_empty - have : X = ∅ := by - apply FiniteSetLaws.ext (A := A) - intro x - rw [h x, FiniteSetLaws.mem_empty] - rw [this, size_empty] + -- If x ∈ X were true, then x ∈ toList X, but toList X = [] + intro hmem + have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr hmem + rw [hnil] at this + cases this + · -- Backward: (∀ x, x ∉ X) → size X = 0 + sorry /-- Singleton set has size 1. Corresponds to Rocq's `size_singleton`. -/ theorem size_singleton (x : A) : size (singleton x : S) = 1 := by unfold size - have h := FiniteSetLaws.toList_singleton (A := A) (S := S) x + have h := toList_singleton (A := A) (S := S) x have : [x].length = 1 := rfl rw [← this, ← h.length_eq] /-- Non-empty set has positive size. Corresponds to Rocq's `set_choose`. -/ -theorem set_choose (X : S) (h : size X ≠ 0) : ∃ x, mem x X = true := by +theorem set_choose (X : S) (h : size X ≠ 0) : ∃ x, x ∈ X := by unfold size at h -- If toList X has non-zero length, it must be x :: l for some x, l cases hlist : toList X with @@ -312,89 +372,95 @@ theorem set_choose (X : S) (h : size X ≠ 0) : ∃ x, mem x X = true := by | cons x l => -- x is the first element, so x ∈ toList X exists x - rw [← FiniteSetLaws.mem_toList] - rw [hlist] - exact List.mem_cons_self .. + have : x ∈ toList X := by rw [hlist]; exact List.mem_cons_self .. + exact (FiniteSetLaws.mem_toList X x).mp this /-- Union of disjoint sets has size equal to sum. Corresponds to Rocq's `size_union`. -/ theorem size_union (X Y : S) (h : Disjoint X Y) : size (X ∪ Y) = size X + size Y := by unfold size - obtain ⟨l', hperm, hperm'⟩ := FiniteSetLaws.toList_union X Y h + obtain ⟨l', hperm, hperm'⟩ := toList_union X Y h rw [hperm.length_eq, List.length_append, hperm'.length_eq] /-- Subset implies smaller or equal size. Corresponds to Rocq's `subseteq_size`. -/ theorem subseteq_size (X Y : S) (h : X ⊆ Y) : size X ≤ size Y := by - have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff Y X h + have ⟨hdisj, heq⟩ := union_diff Y X h -- Y = X ∪ (Y \ X) in terms of membership, and X and Y \ X are disjoint - -- Convert membership equality to set equality - have hset_eq : Y = X ∪ (Y \ X) := by - apply FiniteSetLaws.ext (A := A) + -- We can use toList_proper to show Y and X ∪ (Y \ X) have the same size + have hmem_eq : ∀ z, mem z Y = mem z (X ∪ (Y \ X)) := by intro z - -- heq z says: mem z Y = true ↔ (mem z X = true ∨ mem z (Y \ X) = true) + -- heq z says: z ∈ Y ↔ z ∈ (X ∪ (Y \ X)) -- Need to show: mem z Y = mem z (X ∪ Y \ X) - -- The latter is: mem z X = true ∨ mem z (Y \ X) = true by mem_union cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) · rfl · -- Contradiction: X ∪ (Y \ X) true but Y false - have : mem z X = true ∨ mem z (Y \ X) = true := - (FiniteSetLaws.mem_union X (Y \ X) z).mp hmem_union - have : mem z Y = true := (heq z).mpr this - rw [hmem_y] at this - cases this + have h1 : z ∈ (X ∪ (Y \ X)) := hmem_union + have h2 : z ∈ Y := (heq z).mpr h1 + have h3 : mem z Y = true := h2 + rw [hmem_y] at h3 + cases h3 · -- Contradiction: Y true but X ∪ (Y \ X) false - have : mem z X = true ∨ mem z (Y \ X) = true := (heq z).mp hmem_y - have : mem z (X ∪ (Y \ X)) = true := - (FiniteSetLaws.mem_union X (Y \ X) z).mpr this - rw [hmem_union] at this - cases this + have h1 : z ∈ Y := hmem_y + have h2 : z ∈ (X ∪ (Y \ X)) := (heq z).mp h1 + have h3 : mem z (X ∪ (Y \ X)) = true := h2 + rw [hmem_union] at h3 + cases h3 · rfl - -- Now use size_union with disjointness - rw [hset_eq] + -- Use toList_proper to get that the lists have the same length + have hperm := toList_proper Y (X ∪ (Y \ X)) hmem_eq + have hsize_eq : size Y = size (X ∪ (Y \ X)) := by + unfold size + exact hperm.length_eq + rw [hsize_eq] have hsize := size_union X (Y \ X) hdisj omega /-- Proper subset implies strictly smaller size. Corresponds to Rocq's `subset_size`. -/ -theorem subset_size (X Y : S) (h : X ⊆ Y) (hne : ∃ x, mem x Y = true ∧ mem x X = false) : +theorem subset_size (X Y : S) (h : X ⊆ Y) (hne : ∃ x, x ∈ Y ∧ x ∉ X) : size X < size Y := by have ⟨x, hmemY, hmemX⟩ := hne -- Derive: size Y = size X + size (Y \ X) from union_diff - have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff Y X h - have hset_eq : Y = X ∪ (Y \ X) := by - apply FiniteSetLaws.ext (A := A) + have ⟨hdisj, heq⟩ := union_diff Y X h + have hmem_eq : ∀ z, mem z Y = mem z (X ∪ (Y \ X)) := by intro z cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) · rfl - · have : mem z X = true ∨ mem z (Y \ X) = true := - (FiniteSetLaws.mem_union X (Y \ X) z).mp hmem_union - have : mem z Y = true := (heq z).mpr this - rw [hmem_y] at this; cases this - · have : mem z X = true ∨ mem z (Y \ X) = true := (heq z).mp hmem_y - have : mem z (X ∪ (Y \ X)) = true := - (FiniteSetLaws.mem_union X (Y \ X) z).mpr this - rw [hmem_union] at this; cases this + · have h1 : z ∈ (X ∪ (Y \ X)) := hmem_union + have h2 : z ∈ Y := (heq z).mpr h1 + have h3 : mem z Y = true := h2 + rw [hmem_y] at h3; cases h3 + · have h1 : z ∈ Y := hmem_y + have h2 : z ∈ (X ∪ (Y \ X)) := (heq z).mp h1 + have h3 : mem z (X ∪ (Y \ X)) = true := h2 + rw [hmem_union] at h3; cases h3 · rfl have hsize_union := size_union X (Y \ X) hdisj have hsize_y : size Y = size X + size (Y \ X) := by + have hperm := toList_proper Y (X ∪ (Y \ X)) hmem_eq calc size Y - _ = size (X ∪ (Y \ X)) := by rw [← hset_eq] + _ = size (X ∪ (Y \ X)) := by unfold size; exact hperm.length_eq _ = size X + size (Y \ X) := hsize_union -- Show size (Y \ X) ≠ 0 because x ∈ Y \ X have hdiff : size (Y \ X) ≠ 0 := by intro hcontra - have : ∀ z, mem z (Y \ X) = false := (size_empty_iff (Y \ X)).mp hcontra + have hnotmem : ∀ z, z ∉ (Y \ X) := (size_empty_iff (Y \ X)).mp hcontra + have : ∀ z, mem z (Y \ X) = false := fun z => by + cases h : mem z (Y \ X) + · rfl + · have : z ∈ (Y \ X) := h + exact absurd this (hnotmem z) -- But x ∈ Y \ X have hx_in_diff : mem x (Y \ X) = true := by - -- heq x says: mem x Y = true ↔ (mem x X = true ∨ mem x (Y \ X) = true) - -- We have mem x Y = true and mem x X = false - -- So mem x (Y \ X) = true - have : mem x X = true ∨ mem x (Y \ X) = true := (heq x).mp hmemY - cases this with + -- heq x says: x ∈ Y ↔ x ∈ (X ∪ (Y \ X)) + -- We have x ∈ Y and ¬(x ∈ X) + -- So x ∈ (Y \ X) + have h1 : x ∈ (X ∪ (Y \ X)) := (heq x).mp hmemY + have h2 : x ∈ X ∨ x ∈ (Y \ X) := (mem_union X (Y \ X) x).mp h1 + cases h2 with | inl h' => - -- Contradiction: mem x X = true but hmemX says mem x X = false - rw [h'] at hmemX - cases hmemX + -- Contradiction: x ∈ X but hmemX says ¬(x ∈ X) + exact absurd h' hmemX | inr h => exact h rw [this x] at hx_in_diff cases hx_in_diff @@ -403,31 +469,31 @@ theorem subset_size (X Y : S) (h : X ⊆ Y) (hne : ∃ x, mem x Y = true ∧ mem /-- Size of difference. Corresponds to Rocq's `size_difference`. -/ theorem size_difference (X Y : S) (h : Y ⊆ X) : size (X \ Y) = size X - size Y := by - have ⟨hdisj, heq⟩ := FiniteSetLaws.union_diff X Y h + have ⟨hdisj, heq⟩ := union_diff X Y h -- X = Y ∪ (X \ Y) and they are disjoint - have hset_eq : X = Y ∪ (X \ Y) := by - apply FiniteSetLaws.ext (A := A) + have hmem_eq : ∀ z, mem z X = mem z (Y ∪ (X \ Y)) := by intro z cases hmem_x : mem z X <;> cases hmem_union : mem z (Y ∪ (X \ Y)) · rfl · -- Contradiction: Y ∪ (X \ Y) true but X false - have : mem z Y = true ∨ mem z (X \ Y) = true := - (FiniteSetLaws.mem_union Y (X \ Y) z).mp hmem_union - have : mem z X = true := (heq z).mpr this - rw [hmem_x] at this - cases this + have h1 : z ∈ (Y ∪ (X \ Y)) := hmem_union + have h2 : z ∈ X := (heq z).mpr h1 + have h3 : mem z X = true := h2 + rw [hmem_x] at h3 + cases h3 · -- Contradiction: X true but Y ∪ (X \ Y) false - have : mem z Y = true ∨ mem z (X \ Y) = true := (heq z).mp hmem_x - have : mem z (Y ∪ (X \ Y)) = true := - (FiniteSetLaws.mem_union Y (X \ Y) z).mpr this - rw [hmem_union] at this - cases this + have h1 : z ∈ X := hmem_x + have h2 : z ∈ (Y ∪ (X \ Y)) := (heq z).mp h1 + have h3 : mem z (Y ∪ (X \ Y)) = true := h2 + rw [hmem_union] at h3 + cases h3 · rfl -- Use size_union have hsize_union := size_union Y (X \ Y) hdisj have : size X = size Y + size (X \ Y) := by + have hperm := toList_proper X (Y ∪ (X \ Y)) hmem_eq calc size X - _ = size (Y ∪ (X \ Y)) := by rw [← hset_eq] + _ = size (Y ∪ (X \ Y)) := by unfold size; exact hperm.length_eq _ = size Y + size (X \ Y) := hsize_union omega @@ -437,8 +503,8 @@ section Filter /-- Membership in filter. Corresponds to Rocq's `elem_of_filter`. -/ theorem mem_filter' (P : A → Bool) (X : S) (x : A) : - mem x (filter P X) = true ↔ P x = true ∧ mem x X = true := by - have h := FiniteSetLaws.mem_filter X P x + x ∈ (filter P X) ↔ P x = true ∧ x ∈ X := by + have h := mem_filter X P x constructor · intro hf have ⟨h1, h2⟩ := h.mp hf @@ -447,122 +513,83 @@ theorem mem_filter' (P : A → Bool) (X : S) (x : A) : exact h.mpr ⟨hm, hp⟩ /-- Filter of empty set is empty. Corresponds to Rocq's `filter_empty`. -/ -theorem filter_empty (P : A → Bool) : filter P (∅ : S) = ∅ := by - apply FiniteSetLaws.ext (A := A) +theorem filter_empty (P : A → Bool) : filter P (∅ : S) ≡ ∅ := by intro x - -- Show mem x (filter P ∅) = mem x ∅ = false - have hempty : mem x (∅ : S) = false := FiniteSetLaws.mem_empty (A := A) x - rw [hempty] - -- Now show mem x (filter P ∅) = false - cases h : mem x (filter P (∅ : S)) - · rfl - · -- Contradiction: if mem x (filter P ∅) = true, then mem x ∅ = true - have : mem x (∅ : S) = true := (FiniteSetLaws.mem_filter (∅ : S) P x |>.mp h).1 - rw [FiniteSetLaws.mem_empty (A := A)] at this - cases this + constructor + · intro h + -- If x ∈ filter P ∅, then x ∈ ∅, contradiction + have : x ∈ (∅ : S) := (mem_filter (∅ : S) P x).mp h |>.1 + exact absurd this (FiniteSetLaws.mem_empty (A := A) x) + · intro h + -- If x ∈ ∅, that's a contradiction + exact absurd h (FiniteSetLaws.mem_empty (A := A) x) /-- Filter of singleton. Corresponds to Rocq's `filter_singleton`. -/ theorem filter_singleton (P : A → Bool) (x : A) : - filter P (singleton x : S) = if P x then singleton x else ∅ := by - apply FiniteSetLaws.ext (A := A) + filter P (singleton x : S) ≡ if P x then singleton x else ∅ := by intro y -- Split on whether P x is true or false - cases hpx : P x - · -- Case: P x = false, so filter P {x} = ∅ - -- Show mem y (filter P (singleton x)) = mem y ∅ = false - simp [hpx] - have hempty : mem y (∅ : S) = false := FiniteSetLaws.mem_empty (A := A) y - rw [hempty] - cases hmem : mem y (filter P (singleton x : S)) - · rfl - · -- Contradiction: mem y (filter P {x}) = true implies P x = true - have ⟨hmem_sing, hpy⟩ := (FiniteSetLaws.mem_filter (singleton x : S) P y).mp hmem + split + · -- Case: P x = true, so filter P {x} ≡ {x} + rename_i hpx + constructor + · intro h + -- If y ∈ filter P {x}, then y ∈ {x} + exact (mem_filter (singleton x : S) P y).mp h |>.1 + · intro h + -- If y ∈ {x}, then y = x and P y = P x = true, so y ∈ filter P {x} + have : y = x := (mem_singleton y x).mp h + have : P y = true := by rw [this, hpx] + exact (mem_filter (singleton x : S) P y).mpr ⟨h, this⟩ + · -- Case: P x = false, so filter P {x} ≡ ∅ + rename_i hpx + constructor + · intro h + -- If y ∈ filter P {x}, then y ∈ {x} and P y = true + have ⟨hmem_sing, hpy⟩ := (mem_filter (singleton x : S) P y).mp h -- Also y ∈ {x}, so y = x - have : y = x := (FiniteSetLaws.mem_singleton y x).mp hmem_sing - rw [this] at hpy - rw [hpx] at hpy - cases hpy - · -- Case: P x = true, so filter P {x} = {x} - -- Show mem y (filter P (singleton x)) = mem y (singleton x) - simp [hpx] - cases hmem_filt : mem y (filter P (singleton x : S)) <;> - cases hmem_sing : mem y (singleton x : S) - · rfl - · -- mem y {x} = true but mem y (filter P {x}) = false - contradiction - -- Since y ∈ {x}, we have y = x, and P x = true, so y ∈ filter P {x} - have : y = x := (FiniteSetLaws.mem_singleton y x).mp hmem_sing - have : mem y (singleton x : S) = true ∧ P y = true := by - constructor - · exact hmem_sing - · rw [this, hpx] - have : mem y (filter P (singleton x : S)) = true := - (FiniteSetLaws.mem_filter (singleton x : S) P y).mpr this - rw [hmem_filt] at this - cases this - · -- mem y (filter P {x}) = true but mem y {x} = false - contradiction - have ⟨hmem, _⟩ := (FiniteSetLaws.mem_filter (singleton x : S) P y).mp hmem_filt - rw [hmem_sing] at hmem - cases hmem - · rfl + have : y = x := (mem_singleton (S := S) (A := A) y x).mp hmem_sing + -- But then P x = P y = true, contradicting hpx + subst this + exact False.elim (hpx hpy) + · intro h + -- If y ∈ ∅, that's a contradiction + exact absurd h (FiniteSetLaws.mem_empty (A := A) y) /-- Filter distributes over union. Corresponds to Rocq's `filter_union`. -/ theorem filter_union (P : A → Bool) (X Y : S) : - filter P (X ∪ Y) = filter P X ∪ filter P Y := by - apply FiniteSetLaws.ext (A := A) + filter P (X ∪ Y) ≡ filter P X ∪ filter P Y := by intro x - -- Show: mem x (filter P (X ∪ Y)) = mem x (filter P X ∪ filter P Y) - -- LHS: x ∈ filter P (X ∪ Y) ↔ x ∈ X ∪ Y ∧ P x - -- RHS: x ∈ filter P X ∪ filter P Y ↔ (x ∈ X ∧ P x) ∨ (x ∈ Y ∧ P x) - -- ↔ (x ∈ X ∨ x ∈ Y) ∧ P x - -- ↔ x ∈ X ∪ Y ∧ P x - cases h_filt_union : mem x (filter P (X ∪ Y)) <;> - cases h_union_filt : mem x (filter P X ∪ filter P Y) - · rfl - · -- Contradiction: RHS is true but LHS is false - -- x ∈ filter P X ∪ filter P Y means (x ∈ filter P X) ∨ (x ∈ filter P Y) - have : mem x (filter P X) = true ∨ mem x (filter P Y) = true := - (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mp h_union_filt - cases this with - | inl h => - -- x ∈ filter P X, so x ∈ X and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) - have ⟨hmem_x, hpx⟩ := (FiniteSetLaws.mem_filter X P x).mp h - have : mem x (X ∪ Y) = true := (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hmem_x) - have : mem x (filter P (X ∪ Y)) = true := - (FiniteSetLaws.mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ - rw [h_filt_union] at this - cases this - | inr h => - -- x ∈ filter P Y, so x ∈ Y and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) - have ⟨hmem_y, hpx⟩ := (FiniteSetLaws.mem_filter Y P x).mp h - have : mem x (X ∪ Y) = true := (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hmem_y) - have : mem x (filter P (X ∪ Y)) = true := - (FiniteSetLaws.mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ - rw [h_filt_union] at this - cases this - · -- Contradiction: LHS is true but RHS is false + constructor + · intro h -- x ∈ filter P (X ∪ Y), so x ∈ X ∪ Y and P x - have ⟨hmem_union, hpx⟩ := (FiniteSetLaws.mem_filter (X ∪ Y) P x).mp h_filt_union + have ⟨hmem_union, hpx⟩ := (mem_filter (X ∪ Y) P x).mp h -- x ∈ X ∪ Y means x ∈ X or x ∈ Y - have : mem x X = true ∨ mem x Y = true := - (FiniteSetLaws.mem_union X Y x).mp hmem_union + have : x ∈ X ∨ x ∈ Y := (mem_union X Y x).mp hmem_union cases this with | inl hmem_x => -- x ∈ X and P x, so x ∈ filter P X, so x ∈ filter P X ∪ filter P Y - have : mem x (filter P X) = true := - (FiniteSetLaws.mem_filter X P x).mpr ⟨hmem_x, hpx⟩ - have : mem x (filter P X ∪ filter P Y) = true := - (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mpr (Or.inl this) - rw [h_union_filt] at this - cases this + have : x ∈ filter P X := (mem_filter X P x).mpr ⟨hmem_x, hpx⟩ + exact (mem_union (filter P X) (filter P Y) x).mpr (Or.inl this) | inr hmem_y => -- x ∈ Y and P x, so x ∈ filter P Y, so x ∈ filter P X ∪ filter P Y - have : mem x (filter P Y) = true := - (FiniteSetLaws.mem_filter Y P x).mpr ⟨hmem_y, hpx⟩ - have : mem x (filter P X ∪ filter P Y) = true := - (FiniteSetLaws.mem_union (filter P X) (filter P Y) x).mpr (Or.inr this) - rw [h_union_filt] at this - cases this - · rfl + have : x ∈ filter P Y := (mem_filter Y P x).mpr ⟨hmem_y, hpx⟩ + exact (mem_union (filter P X) (filter P Y) x).mpr (Or.inr this) + · intro h + -- x ∈ filter P X ∪ filter P Y means (x ∈ filter P X) ∨ (x ∈ filter P Y) + have : x ∈ filter P X ∨ x ∈ filter P Y := + (mem_union (filter P X) (filter P Y) x).mp h + cases this with + | inl h => + -- x ∈ filter P X, so x ∈ X and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) + have ⟨hmem_x, hpx⟩ := (mem_filter X P x).mp h + have : x ∈ X ∪ Y := (mem_union X Y x).mpr (Or.inl hmem_x) + exact (mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ + | inr h => + -- x ∈ filter P Y, so x ∈ Y and P x, so x ∈ X ∪ Y and P x, so x ∈ filter P (X ∪ Y) + have ⟨hmem_y, hpx⟩ := (mem_filter Y P x).mp h + have : x ∈ X ∪ Y := (mem_union X Y x).mpr (Or.inr hmem_y) + exact (mem_filter (X ∪ Y) P x).mpr ⟨this, hpx⟩ /-- Disjointness of filter and complement. Corresponds to Rocq's `disjoint_filter_complement`. -/ theorem disjoint_filter_complement (P : A → Bool) (X : S) : @@ -571,8 +598,8 @@ theorem disjoint_filter_complement (P : A → Bool) (X : S) : intro ⟨h1, h2⟩ -- h1: mem x (filter P X) = true means P x = true -- h2: mem x (filter (!P) X) = true means !P x = true, i.e., P x = false - have ⟨_, hpx_true⟩ := (FiniteSetLaws.mem_filter X P x).mp h1 - have ⟨_, hpx_false⟩ := (FiniteSetLaws.mem_filter X (fun y => !P y) x).mp h2 + have ⟨_, hpx_true⟩ := (mem_filter X P x).mp h1 + have ⟨_, hpx_false⟩ := (mem_filter X (fun y => !P y) x).mp h2 -- hpx_false says !P x = true, which means P x = false -- But hpx_true says P x = true - contradiction cases hpx : P x @@ -588,9 +615,9 @@ section SetInduction /-- Well-founded relation on finite sets based on proper subset. Corresponds to Rocq's `set_wf`. -/ -theorem set_wf : WellFounded (fun (X Y : S) => X ⊆ Y ∧ ∃ x, mem x Y = true ∧ mem x X = false) := by +theorem set_wf : WellFounded (fun (X Y : S) => X ⊆ Y ∧ ∃ x, x ∈ Y ∧ x ∉ X) := by -- Well-founded because size decreases for proper subsets - have h_sub : ∀ X Y, (X ⊆ Y ∧ ∃ x, mem x Y = true ∧ mem x X = false) → size (S := S) (A := A) X < size (S := S) (A := A) Y := by + have h_sub : ∀ X Y, (X ⊆ Y ∧ ∃ x, x ∈ Y ∧ x ∉ X) → size (S := S) (A := A) X < size (S := S) (A := A) Y := by intro X Y ⟨hsub, x, hmemY, hmemX⟩ exact subset_size X Y hsub ⟨x, hmemY, hmemX⟩ apply Subrelation.wf @@ -602,47 +629,12 @@ theorem set_wf : WellFounded (fun (X Y : S) => X ⊆ Y ∧ ∃ x, mem x Y = true Corresponds to Rocq's `set_ind`. -/ theorem set_ind {P : S → Prop} (hemp : P ∅) - (hadd : ∀ x X, mem x X = false → P X → P (union (singleton x) X)) + (hadd : ∀ x X, x ∉ X → P X → P (union (singleton x) X)) (X : S) : P X := by -- Use well-founded induction based on set_wf apply WellFounded.induction set_wf X intro Y IH - by_cases hempty : size Y = 0 - · have hY_empty : ∀ x, mem x Y = false := (size_empty_iff Y).mp hempty - have : Y = ∅ := FiniteSetLaws.ext (S := S) (A := A) Y ∅ (fun x => by rw [hY_empty x, FiniteSetLaws.mem_empty]) - subst this - exact hemp - · obtain ⟨x, hmem⟩ := set_choose Y hempty - let Y' := diff Y (singleton x) - have hnotin : mem x Y' = false := by - cases h : mem x Y' - · rfl - · have ⟨_, hne⟩ := (FiniteSetLaws.mem_diff_singleton Y x x).mp h - cases hne rfl - have hPY' : P Y' := by - apply IH - exact ⟨fun z hz => (FiniteSetLaws.mem_diff_singleton Y x z).mp hz |>.1, x, hmem, hnotin⟩ - -- Show Y = {x} ∪ Y' - have heq : Y = union (singleton x) Y' := by - apply FiniteSetLaws.ext (A := A) - intro z - cases hmemz : mem z Y <;> cases hmemu : mem z (union (singleton x) Y') - · rfl - · have : mem z (singleton x) = true ∨ mem z Y' = true := - (FiniteSetLaws.mem_union (singleton x) Y' z).mp hmemu - cases this with - | inl h => have : z = x := (FiniteSetLaws.mem_singleton (S := S) (A := A) z x).mp h; rw [this, hmem] at hmemz; cases hmemz - | inr h => have ⟨hmemY, _⟩ := (FiniteSetLaws.mem_diff_singleton Y x z).mp h; rw [hmemz] at hmemY; cases hmemY - · have : mem z (singleton x : S) = true ∨ mem z Y' = true := by - by_cases hzx : z = x - · left; exact (FiniteSetLaws.mem_singleton (S := S) (A := A) z x).mpr hzx - · right; exact (FiniteSetLaws.mem_diff_singleton Y x z).mpr ⟨hmemz, hzx⟩ - have : mem z (union (singleton x) Y') = true := (FiniteSetLaws.mem_union (singleton x) Y' z).mpr this - rw [hmemu] at this; cases this - · rfl - have : P (union (singleton x) Y') := hadd x Y' hnotin hPY' - rw [heq] - exact this + sorry end SetInduction @@ -650,114 +642,100 @@ section Map /-- Map operation on sets. Maps a function over all elements. Corresponds to Rocq's `set_map`. -/ -def map {B : Type w} [DecidableEq B] [FiniteSet S A] [FiniteSet T B] - (f : A → B) (X : S) : T := +def map {B : Type w} [DecidableEq B] [FiniteSet A S] [FiniteSet B S'] + (f : A → B) (X : S) : S' := ofList ((toList X).map f) /-- Membership in mapped set. Corresponds to Rocq's `elem_of_map`. -/ -theorem mem_map {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem mem_map {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] (f : A → B) (X : S) (y : B) : - mem y (map f X : T) = true ↔ ∃ x, y = f x ∧ mem x X = true := by + y ∈ (map f X : S') ↔ ∃ x, y = f x ∧ x ∈ X := by unfold map - rw [FiniteSetLaws.mem_ofList] + have h_ofList := FiniteSetLaws.mem_ofList (A := B) (S := S') (List.map f (toList X)) y constructor · intro h - have ⟨x, hmem, hx⟩ := List.mem_map.mp h + have : y ∈ (ofList (List.map f (toList X)) : S') := h + have : y ∈ List.map f (toList X) := h_ofList.mp this + have ⟨x, hmem, hx⟩ := List.mem_map.mp this exact ⟨x, hx.symm, (FiniteSetLaws.mem_toList X x).mp hmem⟩ · intro ⟨x, hf, hmem⟩ have : y ∈ List.map f (toList X) := by rw [List.mem_map] exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hmem, hf.symm⟩ + have : y ∈ (ofList (List.map f (toList X)) : S') := h_ofList.mpr this exact this /-- Map of empty set. Corresponds to Rocq's `set_map_empty`. -/ -theorem map_empty {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem map_empty {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] (f : A → B) : - map f (∅ : S) = (∅ : T) := by + map f (∅ : S) = (∅ : S') := by unfold map rw [FiniteSetLaws.toList_empty, List.map_nil, FiniteSetLaws.ofList_nil] /-- Map distributes over union. Corresponds to Rocq's `set_map_union`. -/ -theorem map_union {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem map_union {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] (f : A → B) (X Y : S) : - map f (X ∪ Y : S) = (map f X ∪ map f Y : T) := by - apply FiniteSetLaws.ext (A := B) + map f (X ∪ Y : S) ≡ (map f X ∪ map f Y : S') := by intro z - cases hmem1 : mem z (map f (X ∪ Y : S) : T) <;> - cases hmem2 : mem z ((map f X ∪ map f Y : T)) - · rfl - · -- Contradiction - have := (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mp hmem2 + constructor + · intro h + -- z ∈ map f (X ∪ Y), so ∃ x ∈ X ∪ Y such that z = f x + have ⟨x, hfx, hx⟩ := mem_map f (X ∪ Y : S) z |>.mp h + have := (mem_union X Y x).mp hx cases this with | inl h => - have ⟨x, hfx, hx⟩ := mem_map f X z |>.mp h - have : mem z (map f (X ∪ Y : S) : T) = true := mem_map f (X ∪ Y : S) z |>.mpr - ⟨x, hfx, (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hx)⟩ - rw [hmem1] at this - cases this + -- x ∈ X, so z = f x ∈ map f X, so z ∈ map f X ∪ map f Y + exact (mem_union (map f X : S') (map f Y : S') z).mpr + (Or.inl (mem_map f X z |>.mpr ⟨x, hfx, h⟩)) | inr h => - have ⟨x, hfx, hx⟩ := mem_map f Y z |>.mp h - have : mem z (map f (X ∪ Y : S) : T) = true := mem_map f (X ∪ Y : S) z |>.mpr - ⟨x, hfx, (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hx)⟩ - rw [hmem1] at this - cases this - · -- Contradiction - have ⟨x, hfx, hx⟩ := mem_map f (X ∪ Y : S) z |>.mp hmem1 - have := (FiniteSetLaws.mem_union X Y x).mp hx + -- x ∈ Y, so z = f x ∈ map f Y, so z ∈ map f X ∪ map f Y + exact (mem_union (map f X : S') (map f Y : S') z).mpr + (Or.inr (mem_map f Y z |>.mpr ⟨x, hfx, h⟩)) + · intro h + -- z ∈ map f X ∪ map f Y means z ∈ map f X or z ∈ map f Y + have := (mem_union (map f X : S') (map f Y : S') z).mp h cases this with | inl h => - have : mem z (map f X ∪ map f Y : T) = true := - (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mpr - (Or.inl (mem_map f X z |>.mpr ⟨x, hfx, h⟩)) - rw [hmem2] at this - cases this + -- z ∈ map f X, so ∃ x ∈ X such that z = f x, so z ∈ map f (X ∪ Y) + have ⟨x, hfx, hx⟩ := mem_map (A := A) (S := S) (S' := S') f X z |>.mp h + exact mem_map (A := A) (S := S) (S' := S') f (X ∪ Y : S) z |>.mpr + ⟨x, hfx, (mem_union X Y x).mpr (Or.inl hx)⟩ | inr h => - have : mem z (map f X ∪ map f Y : T) = true := - (FiniteSetLaws.mem_union (map f X : T) (map f Y : T) z).mpr - (Or.inr (mem_map f Y z |>.mpr ⟨x, hfx, h⟩)) - rw [hmem2] at this - cases this - · rfl + -- z ∈ map f Y, so ∃ x ∈ Y such that z = f x, so z ∈ map f (X ∪ Y) + have ⟨x, hfx, hx⟩ := mem_map (A := A) (S := S) (S' := S') f Y z |>.mp h + exact mem_map (A := A) (S := S) (S' := S') f (X ∪ Y : S) z |>.mpr + ⟨x, hfx, (mem_union X Y x).mpr (Or.inr hx)⟩ /-- Map of singleton. Corresponds to Rocq's `set_map_singleton`. -/ -theorem map_singleton {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem map_singleton {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] (f : A → B) (x : A) : - ∀ y, mem y (map f (singleton x : S) : T) = mem y (singleton (f x) : T) := by + (map f (singleton x : S) : S') ≡ (singleton (f x) : S') := by intro y - cases h1 : mem y (map f (singleton x : S) : T) <;> - cases h2 : mem y (singleton (f x) : T) - · rfl - · -- Contradiction - have : y = f x := (FiniteSetLaws.mem_singleton y (f x)).mp h2 - rw [this] at h1 - have : mem (f x) (map f (singleton x : S) : T) = true := - mem_map f (singleton x : S) (f x) |>.mpr - ⟨x, rfl, (FiniteSetLaws.mem_singleton x x).mpr rfl⟩ - rw [h1] at this - cases this - · -- Contradiction - have ⟨z, hfz, hz⟩ := mem_map f (singleton x : S) y |>.mp h1 - have : z = x := (FiniteSetLaws.mem_singleton z x).mp hz + constructor + · intro h + -- y ∈ map f {x}, so ∃ z ∈ {x} such that y = f z + have ⟨z, hfz, hz⟩ := mem_map f (singleton x : S) y |>.mp h + -- z ∈ {x} means z = x + have : z = x := (mem_singleton z x).mp hz rw [this] at hfz - have : mem y (singleton (f x) : T) = true := - (FiniteSetLaws.mem_singleton y (f x)).mpr hfz - rw [h2] at this - cases this - · rfl + -- So y = f x, meaning y ∈ {f x} + exact (mem_singleton y (f x)).mpr hfz + · intro h + -- y ∈ {f x} means y = f x + have : y = f x := (mem_singleton y (f x)).mp h + rw [this] + -- f x ∈ map f {x} because x ∈ {x} + exact mem_map f (singleton x : S) (f x) |>.mpr + ⟨x, rfl, (mem_singleton x x).mpr rfl⟩ end Map section Bind - -/-- Bind operation on sets. Flatmap a function over all elements. - Corresponds to Rocq's `set_bind`. -/ -def bind {T : Type u} [FiniteSet T A] (f : A → T) (X : S) : T := - ofList ((toList X).flatMap (fun x => toList (f x))) +variable {B : Type _} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] /-- Membership in bind. Corresponds to Rocq's `elem_of_set_bind`. -/ -theorem mem_bind {T : Type u} [FiniteSet T A] [FiniteSetLaws T A] - (f : A → T) (X : S) (y : A) : - mem y (bind f X) = true ↔ ∃ x, mem x X = true ∧ mem y (f x) = true := by +theorem mem_bind (f : A → S') (X : S) (y : B) : + y ∈ (bind f X) ↔ ∃ x, x ∈ X ∧ y ∈ (f x) := by unfold bind rw [FiniteSetLaws.mem_ofList] rw [List.mem_flatMap] @@ -768,41 +746,27 @@ theorem mem_bind {T : Type u} [FiniteSet T A] [FiniteSetLaws T A] exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hx, (FiniteSetLaws.mem_toList (f x) y).mpr hy⟩ /-- Bind of singleton. Corresponds to Rocq's `set_bind_singleton`. -/ -theorem bind_singleton {T : Type u} [FiniteSet T A] [FiniteSetLaws T A] - (f : A → T) (x : A) : - ∀ y, mem y (bind (S := S) f (singleton x)) = mem y (f x) := by +theorem bind_singleton (f : A → S') (x : A) : + ∀ y, y ∈ (bind f (singleton (S := S) x)) ↔ y ∈ (f x) := by intro y - cases h1 : mem y (bind (S := S) f (singleton x)) <;> - cases h2 : mem y (f x) - · rfl - · -- Contradiction - have : mem y (bind (S := S) f (singleton x)) = true := - mem_bind f (singleton x) y |>.mpr - ⟨x, (FiniteSetLaws.mem_singleton x x).mpr rfl, h2⟩ - rw [h1] at this - cases this - · -- Contradiction - have ⟨z, hz, hmem⟩ := mem_bind f (singleton x) y |>.mp h1 - have : z = x := (FiniteSetLaws.mem_singleton z x).mp hz + constructor + · intro h + have ⟨z, hz, hmem⟩ := (mem_bind f (singleton x) y).mp h + have : z = x := (mem_singleton z x).mp hz rw [this] at hmem - rw [h2] at hmem - cases hmem - · rfl + exact hmem + · intro h + exact (mem_bind f (singleton x) y).mpr ⟨x, (mem_singleton x x).mpr rfl, h⟩ end Bind section Omap - -/-- Option map operation on sets. Maps a partial function, keeping only Some values. - Corresponds to Rocq's `set_omap`. -/ -def omap {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] - (f : A → Option B) (X : S) : T := - ofList ((toList X).filterMap f) +variable {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] [FiniteSetLaws B S'] /-- Membership in omap. Corresponds to Rocq's `elem_of_set_omap`. -/ -theorem mem_omap {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] +theorem mem_omap (f : A → Option B) (X : S) (y : B) : - mem y (omap f X : T) = true ↔ ∃ x, mem x X = true ∧ f x = some y := by + y ∈ (omap f X : S') ↔ ∃ x, x ∈ X ∧ f x = some y := by unfold omap rw [FiniteSetLaws.mem_ofList] rw [List.mem_filterMap] @@ -813,119 +777,87 @@ theorem mem_omap {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [Fini exact ⟨x, (FiniteSetLaws.mem_toList X x).mpr hx, hfx⟩ /-- Omap of empty set. Corresponds to Rocq's `set_omap_empty`. -/ -theorem omap_empty {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] - (f : A → Option B) : - omap f (∅ : S) = (∅ : T) := by +theorem omap_empty (f : A → Option B) : omap f (∅ : S) = (∅ : S') := by unfold omap rw [FiniteSetLaws.toList_empty, List.filterMap_nil, FiniteSetLaws.ofList_nil] /-- Omap distributes over union. Corresponds to Rocq's `set_omap_union`. -/ -theorem omap_union {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] - (f : A → Option B) (X Y : S) : - ∀ z, mem z (omap f (X ∪ Y : S) : T) = mem z ((omap f X : T) ∪ (omap f Y : T)) := by +theorem omap_union (f : A → Option B) (X Y : S) : + ∀ z, z ∈ (omap f (X ∪ Y : S) : S') ↔ z ∈ ((omap f X : S') ∪ (omap f Y : S')) := by intro z - cases h1 : mem z (omap f (X ∪ Y : S) : T) <;> - cases h2 : mem z ((omap f X : T) ∪ (omap f Y : T)) - · rfl - · -- Contradiction - have := (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mp h2 + constructor + · intro h + have ⟨x, hx, hfx⟩ := (mem_omap f (X ∪ Y : S) z).mp h + have : x ∈ X ∨ x ∈ Y := (mem_union X Y x).mp hx cases this with - | inl h => - have ⟨x, hx, hfx⟩ := mem_omap f X z |>.mp h - have : mem z (omap f (X ∪ Y : S) : T) = true := - mem_omap f (X ∪ Y : S) z |>.mpr - ⟨x, (FiniteSetLaws.mem_union X Y x).mpr (Or.inl hx), hfx⟩ - rw [h1] at this - cases this - | inr h => - have ⟨x, hx, hfx⟩ := mem_omap f Y z |>.mp h - have : mem z (omap f (X ∪ Y : S) : T) = true := - mem_omap f (X ∪ Y : S) z |>.mpr - ⟨x, (FiniteSetLaws.mem_union X Y x).mpr (Or.inr hx), hfx⟩ - rw [h1] at this - cases this - · -- Contradiction - have ⟨x, hx, hfx⟩ := mem_omap f (X ∪ Y : S) z |>.mp h1 - have := (FiniteSetLaws.mem_union X Y x).mp hx + | inl hx_in_X => + have : z ∈ (omap f X : S') := (mem_omap f X z).mpr ⟨x, hx_in_X, hfx⟩ + exact (mem_union (omap f X : S') (omap f Y : S') z).mpr (Or.inl this) + | inr hx_in_Y => + have : z ∈ (omap f Y : S') := (mem_omap f Y z).mpr ⟨x, hx_in_Y, hfx⟩ + exact (mem_union (omap f X : S') (omap f Y : S') z).mpr (Or.inr this) + · intro h + have : z ∈ (omap f X : S') ∨ z ∈ (omap f Y : S') := + (mem_union (omap f X : S') (omap f Y : S') z).mp h cases this with - | inl h => - have : mem z ((omap f X : T) ∪ (omap f Y : T)) = true := - (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mpr - (Or.inl (mem_omap f X z |>.mpr ⟨x, h, hfx⟩)) - rw [h2] at this - cases this - | inr h => - have : mem z ((omap f X : T) ∪ (omap f Y : T)) = true := - (FiniteSetLaws.mem_union (omap f X : T) (omap f Y : T) z).mpr - (Or.inr (mem_omap f Y z |>.mpr ⟨x, h, hfx⟩)) - rw [h2] at this - cases this - · rfl + | inl hz_in_X => + have ⟨x, hx, hfx⟩ := (mem_omap f X z).mp hz_in_X + have : x ∈ (X ∪ Y) := (mem_union X Y x).mpr (Or.inl hx) + exact (mem_omap f (X ∪ Y : S) z).mpr ⟨x, this, hfx⟩ + | inr hz_in_Y => + have ⟨x, hx, hfx⟩ := (mem_omap f Y z).mp hz_in_Y + have : x ∈ (X ∪ Y) := (mem_union X Y x).mpr (Or.inr hx) + exact (mem_omap f (X ∪ Y : S) z).mpr ⟨x, this, hfx⟩ /-- Omap of singleton when function returns Some. -/ -theorem omap_singleton_some {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] - (f : A → Option B) (x : A) (y : B) (h : f x = some y) : - ∀ z, mem z (omap f (singleton x : S) : T) = mem z (singleton y : T) := by +theorem omap_singleton_some (f : A → Option B) (x : A) (y : B) (h : f x = some y) : + ∀ z, mem z (omap f (singleton x : S) : S') = mem z (singleton y : S') := by intro z - cases h1 : mem z (omap f (singleton x : S) : T) <;> - cases h2 : mem z (singleton y : T) + cases h1 : mem z (omap f (singleton x : S) : S') <;> + cases h2 : mem z (singleton y : S') · rfl · -- Contradiction - have : z = y := (FiniteSetLaws.mem_singleton z y).mp h2 + have : z = y := (mem_singleton z y).mp h2 rw [this] at h1 - have : mem y (omap f (singleton x : S) : T) = true := + have : mem y (omap f (singleton x : S) : S') = true := mem_omap f (singleton x : S) y |>.mpr - ⟨x, (FiniteSetLaws.mem_singleton x x).mpr rfl, h⟩ + ⟨x, (mem_singleton x x).mpr rfl, h⟩ rw [h1] at this cases this · -- Contradiction: mem z (omap f {x}) = true but f x = some y and mem z {y} = false have ⟨w, hw, hfw⟩ := mem_omap f (singleton x : S) z |>.mp h1 - have wx : w = x := (FiniteSetLaws.mem_singleton w x).mp hw + have wx : w = x := (mem_singleton w x).mp hw rw [wx] at hfw -- hfw : f x = some z, but we know f x = some y rw [h] at hfw -- Now hfw : some y = some z, so y = z cases hfw -- But now we have mem y (singleton y) = false, contradiction - have : mem y (singleton y : T) = true := (FiniteSetLaws.mem_singleton y y).mpr rfl + have : mem y (singleton y : S') = true := (mem_singleton y y).mpr rfl rw [h2] at this cases this · rfl /-- Omap of singleton when function returns None. -/ -theorem omap_singleton_none {B : Type w} {T : Type u} [DecidableEq B] [FiniteSet T B] [FiniteSetLaws T B] - (f : A → Option B) (x : A) (h : f x = none) : - omap f (singleton x : S) = (∅ : T) := by - apply FiniteSetLaws.ext (A := B) +theorem omap_singleton_none (f : A → Option B) (x : A) (h : f x = none) : + omap f (singleton x : S) ≡ (∅ : S') := by intro z - cases h1 : mem z (omap f (singleton x : S) : T) <;> - cases h2 : mem z (∅ : T) - · rfl - · -- Contradiction: mem z ∅ = true - rw [FiniteSetLaws.mem_empty] at h2 - cases h2 - · -- Contradiction: mem z (omap f {x}) = true but f x = none + constructor + · intro h1 + -- z ∈ omap f {x}, so ∃ w ∈ {x} such that f w = some z have ⟨w, hw, hfw⟩ := mem_omap f (singleton x : S) z |>.mp h1 - have : w = x := (FiniteSetLaws.mem_singleton w x).mp hw + -- w ∈ {x} means w = x + have : w = x := (mem_singleton w x).mp hw + -- So f x = some z, but h says f x = none - contradiction rw [this] at hfw rw [h] at hfw cases hfw - · rfl + · intro h2 + -- z ∈ ∅ is a contradiction + exact absurd h2 (FiniteSetLaws.mem_empty (A := B) z) end Omap -section DecisionProcedures - -/-- Forall predicate on sets. Corresponds to Rocq's `set_Forall`. -/ -def setForall (P : A → Prop) (X : S) : Prop := - ∀ x, mem x X = true → P x - -/-- Exists predicate on sets. Corresponds to Rocq's `set_Exists`. -/ -def setExists (P : A → Prop) (X : S) : Prop := - ∃ x, mem x X = true ∧ P x - -end DecisionProcedures - end FiniteSet end Iris.Std From a52e0864f839556869d61ead3eeb9634d12a1ef6 Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Tue, 13 Jan 2026 22:45:07 +0100 Subject: [PATCH 8/9] Simplify FiniteSet --- src/Iris/BI/BigOp/BigAndList.lean | 2 +- src/Iris/BI/BigOp/BigSepMap.lean | 8 +- src/Iris/BI/BigOp/BigSepSet.lean | 47 ++- src/Iris/Std/FiniteMapDom.lean | 4 +- src/Iris/Std/FiniteSet.lean | 521 ++++++++++++++++++++++-------- src/Iris/Std/FiniteSetInst.lean | 220 +++++++++++++ 6 files changed, 644 insertions(+), 158 deletions(-) create mode 100644 src/Iris/Std/FiniteSetInst.lean diff --git a/src/Iris/BI/BigOp/BigAndList.lean b/src/Iris/BI/BigOp/BigAndList.lean index d3a6bab8..b6a8ac39 100644 --- a/src/Iris/BI/BigOp/BigAndList.lean +++ b/src/Iris/BI/BigOp/BigAndList.lean @@ -256,7 +256,7 @@ theorem perm {Φ : A → PROP} {l₁ l₂ : List A} (hp : l₁.Perm l₂) : /-! ## Missing Lemmas from Rocq Iris The following lemmas from Rocq Iris are not ported: -- `big_andL_submseteq`: Uses stdpp's `⊆+` relation (use `perm` instead) +- `big_andL_submseteq`: Uses stdpp's `⊆+` relation - `big_andL_ne`: OFE-level non-expansiveness (handled at algebra layer) - `big_andL_mono'`, `big_andL_id_mono'`: Convenience wrappers (use `mono` directly) - `big_andL_absorbing`, `big_andL_absorbing'`: Absorbing typeclass (not implemented) diff --git a/src/Iris/BI/BigOp/BigSepMap.lean b/src/Iris/BI/BigOp/BigSepMap.lean index 54bd0e7e..f2141a8d 100644 --- a/src/Iris/BI/BigOp/BigSepMap.lean +++ b/src/Iris/BI/BigOp/BigSepMap.lean @@ -1164,8 +1164,8 @@ theorem dom {Φ : K → PROP} (m : M V) : intro z hz rw [mem_iff_mem] at hz ⊢ rw [hdom_eq z]; exact hz - have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset (domSet (FiniteMap.insert m k v) : S) _ hsub1 - have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (FiniteSet.singleton k ∪ (domSet m : S)) _ hsub2 + have ⟨l₁, hperm1⟩ := FiniteSet.toList_subset (domSet (FiniteMap.insert m k v) : S) _ hsub1 + have ⟨l₂, hperm2⟩ := FiniteSet.toList_subset (FiniteSet.singleton k ∪ (domSet m : S)) _ hsub2 have hl1_nil : l₁ = [] := by have h1 := hperm1.length_eq have h2 := hperm2.length_eq @@ -1234,8 +1234,8 @@ theorem ofSet' {Φ : K → V → PROP} (X : S) (c : V) : have : FiniteSet.mem z X = true := hz rw [← hmem_eq z] at this exact this - have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset X _ hsub1 - have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (domSet (ofSet c X : M V) : S) _ hsub2 + have ⟨l₁, hperm1⟩ := FiniteSet.toList_subset X _ hsub1 + have ⟨l₂, hperm2⟩ := FiniteSet.toList_subset (domSet (ofSet c X : M V) : S) _ hsub2 have hl1_nil : l₁ = [] := by have h1 := hperm1.length_eq have h2 := hperm2.length_eq diff --git a/src/Iris/BI/BigOp/BigSepSet.lean b/src/Iris/BI/BigOp/BigSepSet.lean index 6557a60f..351cbc97 100644 --- a/src/Iris/BI/BigOp/BigSepSet.lean +++ b/src/Iris/BI/BigOp/BigSepSet.lean @@ -147,8 +147,8 @@ private theorem bigSepS_perm_of_mem_eq {Φ : A → PROP} {X Y : S} have hsub2 : Y ⊆ X := fun z hz => by rw [mem_iff_mem] at hz ⊢ rw [hmem_eq z]; exact hz - have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset Y X hsub1 - have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset X Y hsub2 + have ⟨l₁, hperm1⟩ := FiniteSet.toList_subset Y X hsub1 + have ⟨l₂, hperm2⟩ := FiniteSet.toList_subset X Y hsub2 have hl1_nil : l₁ = [] := by have h1 := hperm1.length_eq have h2 := hperm2.length_eq @@ -195,8 +195,33 @@ theorem union_2 {Φ : A → PROP} {X Y : S} ⊢ ([∗set] y ∈ X, Φ y) -∗ ([∗set] y ∈ Y, Φ y) -∗ ([∗set] y ∈ X ∪ Y, Φ y) := by have h_core : ∀ X : S, ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) ⊢ ([∗set] y ∈ X ∪ Y, Φ y) := by intro X - refine FiniteSet.set_ind (P := fun X => ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) ⊢ ([∗set] y ∈ X ∪ Y, Φ y)) ?_ ?_ X - · refine (sep_mono_l empty.1).trans ?_ + refine FiniteSet.set_ind (P := fun X => ([∗set] y ∈ X, Φ y) ∗ ([∗set] y ∈ Y, Φ y) ⊢ ([∗set] y ∈ X ∪ Y, Φ y)) + ?proper ?base ?step X + case proper => + intro X₁ X₂ hequiv hent + have h1 : ([∗set] y ∈ X₁, Φ y) ⊣⊢ ([∗set] y ∈ X₂, Φ y) := bigSepS_perm_of_mem_eq (fun z => Bool.eq_iff_iff.mpr (hequiv z)) + have h2 : ([∗set] y ∈ X₁ ∪ Y, Φ y) ⊣⊢ ([∗set] y ∈ X₂ ∪ Y, Φ y) := by + apply bigSepS_perm_of_mem_eq + intro z + rw [Bool.eq_iff_iff, ← mem_iff_mem, ← mem_iff_mem] + constructor + · intro h + have := (FiniteSet.mem_union X₁ Y z).mp h + apply (FiniteSet.mem_union X₂ Y z).mpr + cases this with + | inl hl => left; exact (hequiv z).mp hl + | inr hr => right; exact hr + · intro h + have := (FiniteSet.mem_union X₂ Y z).mp h + apply (FiniteSet.mem_union X₁ Y z).mpr + cases this with + | inl hl => left; exact (hequiv z).mpr hl + | inr hr => right; exact hr + refine (sep_mono_l h1.2).trans ?_ + refine hent.trans ?_ + exact h2.1 + case base => + refine (sep_mono_l empty.1).trans ?_ refine emp_sep.1.trans ?_ have hmem_eq : ∀ z, FiniteSet.mem z (∅ ∪ Y) = FiniteSet.mem z Y := fun z => by have hunion := FiniteSet.mem_union (∅ : S) Y z @@ -220,7 +245,8 @@ theorem union_2 {Φ : A → PROP} {X Y : S} exact Bool.noConfusion hr · rfl exact (bigSepS_perm_of_mem_eq hmem_eq).2 - · intro x X' hnotin IH + case step => + intro x X' hnotin IH have hdisj : FiniteSet.Disjoint (FiniteSet.singleton x : S) X' := by intro y ⟨hmem1, hmem2⟩ by_cases hyx : y = x @@ -376,8 +402,8 @@ theorem insert_2 {Φ : A → PROP} {X : S} {x : A} have hX_sub_union : X ⊆ (FiniteSet.singleton x ∪ X) := fun y hy => by rw [FiniteSet.mem_union] right; exact hy - have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset X (FiniteSet.singleton x ∪ X) hunion_sub_X - have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset (FiniteSet.singleton x ∪ X) X hX_sub_union + have ⟨l₁, hperm1⟩ := FiniteSet.toList_subset X (FiniteSet.singleton x ∪ X) hunion_sub_X + have ⟨l₂, hperm2⟩ := FiniteSet.toList_subset (FiniteSet.singleton x ∪ X) X hX_sub_union have hl1_nil : l₁ = [] := by have h := hperm1.length_eq have h2 := hperm2.length_eq @@ -474,8 +500,8 @@ theorem delete_2 {Φ : A → PROP} {X : S} {x : A} refine (sep_mono_l hAff.affine).trans emp_sep.1 |>.trans ?_ have hX_sub_diff : X ⊆ FiniteSet.diff X (FiniteSet.singleton x) := fun y hy => hX_sub y hy have hdiff_sub_X : FiniteSet.diff X (FiniteSet.singleton x) ⊆ X := fun y hy => hdiff_sub y hy - have ⟨l₁, hperm1⟩ := FiniteSetLaws.toList_subset (FiniteSet.diff X (FiniteSet.singleton x)) X hX_sub_diff - have ⟨l₂, hperm2⟩ := FiniteSetLaws.toList_subset X (FiniteSet.diff X (FiniteSet.singleton x)) hdiff_sub_X + have ⟨l₁, hperm1⟩ := FiniteSet.toList_subset (FiniteSet.diff X (FiniteSet.singleton x)) X hX_sub_diff + have ⟨l₂, hperm2⟩ := FiniteSet.toList_subset X (FiniteSet.diff X (FiniteSet.singleton x)) hdiff_sub_X have hlen_eq : (toList (FiniteSet.diff X (FiniteSet.singleton x))).length = (toList X).length := by have h1 := hperm1.length_eq @@ -866,6 +892,7 @@ theorem later_2 {Φ : A → PROP} {X : S} : ([∗set] y ∈ X, ▷ Φ y) ⊢ iprop(▷ [∗set] y ∈ X, Φ y) := elements.1.trans (BigSepL.later_2.trans (later_mono elements.2)) +omit [DecidableEq A] [FiniteSetLaws A S] in /-- Corresponds to `big_sepS_laterN` in Rocq Iris. -/ theorem laterN [BIAffine PROP] {Φ : A → PROP} {n : Nat} {X : S} : iprop(▷^[n] [∗set] y ∈ X, Φ y) ⊣⊢ [∗set] y ∈ X, ▷^[n] Φ y := by @@ -976,7 +1003,7 @@ theorem subseteq {Φ : A → PROP} {X Y : S} (hsub : Y ⊆ X) : ([∗set] x ∈ X, Φ x) ⊢ [∗set] x ∈ Y, Φ x := by unfold bigSepS - have ⟨l, hperm⟩ := FiniteSetLaws.toList_subset X Y hsub + have ⟨l, hperm⟩ := FiniteSet.toList_subset X Y hsub exact BigSepL.submseteq hperm /-! ## Commuting Lemmas -/ diff --git a/src/Iris/Std/FiniteMapDom.lean b/src/Iris/Std/FiniteMapDom.lean index 9ca5b32d..ba2572f4 100644 --- a/src/Iris/Std/FiniteMapDom.lean +++ b/src/Iris/Std/FiniteMapDom.lean @@ -126,9 +126,7 @@ theorem domSet_ofSet (c : V) (X : S) : simp only [List.map_map] show (List.map (fun x => x) (FiniteSet.toList X)).Nodup simp only [List.map_id'] - have ⟨l', hperm, hnodup', _⟩ : ∃ l', (FiniteSet.toList X).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = X := - FiniteSetLaws.ofList_toList X - exact hperm.symm.nodup hnodup' + exact FiniteSetLaws.toList_nodup X exact FiniteMapLaws.elem_of_list_to_map_1 _ _ _ hnodup hmapped have : (k, c) ∈ FiniteMap.toList (ofSet c X : M V) := FiniteMapLaws.elem_of_map_to_list _ _ _ |>.mpr this diff --git a/src/Iris/Std/FiniteSet.lean b/src/Iris/Std/FiniteSet.lean index aa1f49c7..fd9e9220 100644 --- a/src/Iris/Std/FiniteSet.lean +++ b/src/Iris/Std/FiniteSet.lean @@ -116,30 +116,30 @@ instance : Equivalence (@SetEquiv A S _ _) where symm := fun {X Y} hxy => setEquiv_symm X Y hxy trans := fun {X Y Z} hxy hyz => setEquiv_trans X Y Z hxy hyz -/-- Filter: keep only elements satisfying a predicate. - Corresponds to Rocq's `filter φ X`. -/ +/-- Corresponds to Rocq's `filter φ X`. -/ def filter (φ : A → Bool) : S → S := fun s => ofList ((toList s).filter φ) -/-- Bind operation on sets. Flatmap a function over all elements. - Corresponds to Rocq's `set_bind`. -/ +/-- Corresponds to Rocq's `set_bind`. -/ def bind {B : Type w} {S' : Type u} [FiniteSet B S'] (f : A → S') (X : S) : S' := ofList ((toList X).flatMap (fun x => toList (f x))) -/-- Option map operation on sets. Maps a partial function, keeping only Some values. - Corresponds to Rocq's `set_omap`. -/ +/-- Corresponds to Rocq's `set_omap`. -/ def omap {B : Type w} {S' : Type u} [DecidableEq B] [FiniteSet B S'] (f : A → Option B) (X : S) : S' := ofList ((toList X).filterMap f) -/-- Forall predicate on sets. Corresponds to Rocq's `set_Forall`. -/ +/-- Corresponds to Rocq's `set_Forall`. -/ def setForall (P : A → Prop) (X : S) : Prop := ∀ x, x ∈ X → P x -/-- Exists predicate on sets. Corresponds to Rocq's `set_Exists`. -/ +/-- Corresponds to Rocq's `set_Exists`. -/ def setExists (P : A → Prop) (X : S) : Prop := ∃ x, x ∈ X ∧ P x +/-- Corresponds to Rocq's `size`. -/ +def size (s : S) : Nat := (toList s).length + end FiniteSet /-- Helper: x ∈ s is definitionally equal to mem x s = true -/ @@ -163,9 +163,8 @@ class FiniteSetLaws (A : Type v) (S : Type u) [DecidableEq A] [FiniteSet A S] wh /-- Converting to list and back preserves the set (up to permutation). -/ toList_ofList : ∀ (l : List A) (s : S), l.Nodup → FiniteSet.ofList l = s → (FiniteSet.toList s).Perm l - /-- Converting list to set and back gives a permutation of the deduplicated list. -/ - ofList_toList : ∀ (s : S), - ∃ l', (FiniteSet.toList s).Perm l' ∧ l'.Nodup ∧ FiniteSet.ofList l' = s + /-- Corresponds to Rocq's `NoDup_elements`. -/ + toList_nodup (X : S) : (toList X).Nodup /-- Inserting into a set gives a list permutation including the new element. -/ set_to_list_insert : ∀ (s : S) (x : A), x ∉ s → (FiniteSet.toList (FiniteSet.insert x s)).Perm (x :: FiniteSet.toList s) @@ -179,9 +178,6 @@ class FiniteSetLaws (A : Type v) (S : Type u) [DecidableEq A] [FiniteSet A S] wh toList_empty : FiniteSet.toList (∅ : S) = [] /-- Membership is preserved by toList. -/ mem_toList : ∀ (X : S) (x : A), x ∈ FiniteSet.toList X ↔ x ∈ X - /-- Subset relation preserved by toList: if Y ⊆ X, toList Y elements appear in toList X. -/ - toList_subset : ∀ (X Y : S), Y ⊆ X → - ∃ l, (FiniteSet.toList Y ++ l).Perm (FiniteSet.toList X) /-- toList of filter is related to filter over toList. -/ toList_filter : ∀ (X : S) (φ : A → Bool), (FiniteSet.toList (FiniteSet.filter φ X)).Perm ((FiniteSet.toList X).filter φ) @@ -195,15 +191,36 @@ variable {A : Type v} {S : Type u} [DecidableEq A] [FiniteSet A S] [FiniteSetLaw /-- Membership in singleton: true iff equal. Corresponds to Rocq's `elem_of_singleton`. -/ theorem mem_singleton (x y : A) : x ∈ (FiniteSet.singleton y : S) ↔ x = y := by - sorry + unfold singleton insert + constructor + · intro h + -- h : x ∈ ofList (y :: toList ∅) + have h1 : x ∈ (y :: toList (∅ : S)) := (FiniteSetLaws.mem_ofList _ x).mp h + simp [FiniteSetLaws.toList_empty] at h1 + exact h1 + · intro h + have : x ∈ (y :: toList (∅ : S)) := by simp [FiniteSetLaws.toList_empty, h] + exact (FiniteSetLaws.mem_ofList _ x).mpr this /-- Membership after insert: true if equal, otherwise unchanged. -/ theorem mem_insert_eq (s : S) (x y : A) (h : x = y) : x ∈ (FiniteSet.insert y s) := by - sorry + unfold insert + have : x ∈ (y :: toList s) := by simp [h] + exact (FiniteSetLaws.mem_ofList _ x).mpr this /-- Membership after insert: unchanged if not equal. -/ theorem mem_insert_ne (s : S) (x y : A) (h : x ≠ y) : x ∈ (FiniteSet.insert y s) ↔ x ∈ s := by - sorry + unfold insert + constructor + · intro hmem + have h1 : x ∈ (y :: toList s) := (FiniteSetLaws.mem_ofList _ x).mp hmem + cases h1 with + | head => exact absurd rfl h + | tail _ h' => exact (FiniteSetLaws.mem_toList s x).mp h' + · intro hmem + have h1 : x ∈ toList s := (FiniteSetLaws.mem_toList s x).mpr hmem + have : x ∈ (y :: toList s) := List.Mem.tail y h1 + exact (FiniteSetLaws.mem_ofList _ x).mpr this /-- Singleton as insert into empty. -/ theorem singleton_insert (x : A) : (FiniteSet.singleton x : S) = FiniteSet.insert x ∅ := by @@ -211,59 +228,207 @@ theorem singleton_insert (x : A) : (FiniteSet.singleton x : S) = FiniteSet.inser /-- Membership after erase: false if equal, otherwise unchanged. -/ theorem mem_erase_eq (s : S) (x y : A) (h : x = y) : x ∉ (FiniteSet.erase y s) := by - sorry + intro hmem + unfold erase at hmem + have h1 : x ∈ (toList s).filter (fun z => decide (z ≠ y)) := + (FiniteSetLaws.mem_ofList _ x).mp hmem + have h2 : x ∈ toList s ∧ decide (x ≠ y) = true := List.mem_filter.mp h1 + simp [h] at h2 /-- Membership after erase: unchanged if not equal. -/ theorem mem_erase_ne (s : S) (x y : A) (h : x ≠ y) : x ∈ (FiniteSet.erase y s) ↔ x ∈ s := by - sorry + unfold erase + constructor + · intro hmem + have h1 : x ∈ (toList s).filter (fun z => decide (z ≠ y)) := + (FiniteSetLaws.mem_ofList _ x).mp hmem + have h2 : x ∈ toList s := (List.mem_filter.mp h1).1 + exact (FiniteSetLaws.mem_toList s x).mp h2 + · intro hmem + have h1 : x ∈ toList s := (FiniteSetLaws.mem_toList s x).mpr hmem + have h2 : decide (x ≠ y) = true := by simp [h] + have : x ∈ (toList s).filter (fun z => decide (z ≠ y)) := + List.mem_filter.mpr ⟨h1, h2⟩ + exact (FiniteSetLaws.mem_ofList _ x).mpr this /-- toList of singleton set is a singleton list (up to permutation). -/ theorem toList_singleton (x : A) : (FiniteSet.toList (FiniteSet.singleton x : S)).Perm [x] := by - sorry + unfold singleton insert + -- toList (ofList (x :: toList ∅)) should be a permutation of [x] + have h_empty : toList (∅ : S) = [] := FiniteSetLaws.toList_empty + have h_nodup : [x].Nodup := by simp + have h_eq : ofList [x] = (ofList (x :: toList (∅ : S)) : S) := by simp [h_empty] + rw [← h_eq] + exact FiniteSetLaws.toList_ofList [x] (ofList [x]) h_nodup rfl + + + /-- Converting list to set and back gives a permutation of the deduplicated list. -/ + theorem ofList_toList : ∀ (s : S), + FiniteSet.ofList (FiniteSet.toList s) ≡ s := by + intro s x + constructor + · intro h + have : x ∈ toList s := (FiniteSetLaws.mem_ofList (toList s) x).mp h + exact (FiniteSetLaws.mem_toList s x).mp this + · intro h + have : x ∈ toList s := (FiniteSetLaws.mem_toList s x).mpr h + exact (FiniteSetLaws.mem_ofList (toList s) x).mpr this /-- toList of union when disjoint (up to permutation). -/ theorem toList_union (X Y : S) (h : FiniteSet.Disjoint X Y) : ∃ l', (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList X ++ l') ∧ (FiniteSet.toList Y).Perm l' := by - sorry - -/-- toList of set difference (up to permutation). -/ -theorem toList_sdiff (X : S) (x : A) (h : FiniteSet.mem x X = true) : - ∃ l', (FiniteSet.toList X).Perm (x :: l') ∧ - (FiniteSet.toList (FiniteSet.diff X (FiniteSet.singleton x))).Perm l' := by - sorry + -- Use toList Y as l' + exists toList Y + constructor + · -- Show toList (X ∪ Y) ~ toList X ++ toList Y + show (toList (union X Y)).Perm (toList X ++ toList Y) + -- union X Y = ofList (toList X ++ toList Y) by definition + unfold union + -- Now we need: toList (ofList (toList X ++ toList Y)) ~ toList X ++ toList Y + -- Get nodup property for toList X and toList Y + have hnodupX := @FiniteSetLaws.toList_nodup A S _ _ _ X + have hnodupY := @FiniteSetLaws.toList_nodup A S _ _ _ Y + -- Since X and Y are disjoint, toList X ++ toList Y is nodup + have hconcat_nodup : (toList X ++ toList Y).Nodup := by + apply List.nodup_append.mpr + constructor + · exact hnodupX + constructor + · exact hnodupY + · intro a ha b hb hab + subst hab + have hmemX : a ∈ X := (FiniteSetLaws.mem_toList X a).mp ha + have hmemY : a ∈ Y := (FiniteSetLaws.mem_toList Y a).mp hb + exact h a ⟨hmemX, hmemY⟩ + -- Apply toList_ofList axiom + exact @FiniteSetLaws.toList_ofList A S _ _ _ (toList X ++ toList Y) (ofList (toList X ++ toList Y)) hconcat_nodup rfl + · -- Show toList Y ~ toList Y + exact List.Perm.refl _ /-- Membership in difference: y ∈ X \ {x} ↔ y ∈ X ∧ y ≠ x -/ theorem mem_diff_singleton (X : S) (x y : A) : y ∈ (FiniteSet.diff X (FiniteSet.singleton x)) ↔ (y ∈ X ∧ y ≠ x) := by - sorry - -/-- Subset decomposition: If Y ⊆ X, then X = Y ∪ (X \ Y) up to the disjointness condition. -/ -theorem union_diff (X Y : S) (h : Y ⊆ X) : - FiniteSet.Disjoint Y (FiniteSet.diff X Y) ∧ - (X ≡ Y ∪ (FiniteSet.diff X Y)) := by - sorry + unfold diff + constructor + · intro h + have h1 : y ∈ (toList X).filter (fun z => !mem z (singleton x : S)) := + (FiniteSetLaws.mem_ofList _ y).mp h + have ⟨h2, h3⟩ := List.mem_filter.mp h1 + have h4 : y ∈ X := (FiniteSetLaws.mem_toList X y).mp h2 + -- h3 : !mem y (singleton x : S) = true, so mem y (singleton x : S) = false + have h5 : ¬(y ∈ (singleton x : S)) := by + intro hy + have : mem y (singleton x : S) = true := hy + simp [this] at h3 + have h7 : y ≠ x := by + intro heq + apply h5 + rw [heq] + exact (mem_singleton x x).mpr rfl + exact ⟨h4, h7⟩ + · intro ⟨h1, h2⟩ + have h3 : y ∈ toList X := (FiniteSetLaws.mem_toList X y).mpr h1 + have h4 : ¬(y ∈ (singleton x : S)) := by + intro h + have : y = x := (mem_singleton y x).mp h + exact h2 this + have h5 : mem y (singleton x : S) = false := by + cases h : mem y (singleton x : S) + · rfl + · exact absurd h h4 + have h6 : (fun z => !mem z (singleton x : S)) y = true := by + simp [h5] + have : y ∈ (toList X).filter (fun z => !mem z (singleton x : S)) := + List.mem_filter.mpr ⟨h3, h6⟩ + exact (FiniteSetLaws.mem_ofList _ y).mpr this /-- Membership in union: x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y -/ theorem mem_union (X Y : S) (x : A) : x ∈ (X ∪ Y) ↔ (x ∈ X ∨ x ∈ Y) := by - sorry + show mem x (union X Y) = true ↔ _ + unfold union + constructor + · intro h + have h1 : x ∈ (toList X ++ toList Y) := (FiniteSetLaws.mem_ofList _ x).mp h + have : x ∈ toList X ∨ x ∈ toList Y := List.mem_append.mp h1 + cases this with + | inl h => exact Or.inl ((FiniteSetLaws.mem_toList X x).mp h) + | inr h => exact Or.inr ((FiniteSetLaws.mem_toList Y x).mp h) + · intro h + cases h with + | inl h => + have h1 : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h + have : x ∈ (toList X ++ toList Y) := List.mem_append.mpr (Or.inl h1) + exact (FiniteSetLaws.mem_ofList _ x).mpr this + | inr h => + have h1 : x ∈ toList Y := (FiniteSetLaws.mem_toList Y x).mpr h + have : x ∈ (toList X ++ toList Y) := List.mem_append.mpr (Or.inr h1) + exact (FiniteSetLaws.mem_ofList _ x).mpr this -/-- Union is commutative for toList (up to permutation). -/ -theorem toList_union_comm (X Y : S) : - (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList (Y ∪ X)) := by - sorry +/-- Subset decomposition: If Y ⊆ X, then X = Y ∪ (X \ Y) up to the disjointness condition. -/ +theorem union_diff (X Y : S) (h : Y ⊆ X) : + FiniteSet.Disjoint Y (FiniteSet.diff X Y) ∧ + (X ≡ Y ∪ (FiniteSet.diff X Y)) := by + constructor + · -- Disjoint Y (X \ Y) + intro z + intro ⟨hz_in_Y, hz_in_diff⟩ + -- hz_in_diff : z ∈ X \ Y, so by diff definition z ∉ Y + unfold diff at hz_in_diff + have h1 : z ∈ (toList X).filter (fun w => !mem w Y) := + (FiniteSetLaws.mem_ofList _ z).mp hz_in_diff + have ⟨_, h3⟩ := List.mem_filter.mp h1 + have h4 : ¬(z ∈ Y) := by + intro hz + have : mem z Y = true := hz + simp [this] at h3 + exact h4 hz_in_Y + · -- X ≡ Y ∪ (X \ Y) + intro z + constructor + · intro hz_in_X + -- If z ∈ X, either z ∈ Y or z ∈ X \ Y + cases hz : mem z Y + · -- z ∉ Y, so z ∈ X \ Y + have : z ∈ diff X Y := by + unfold diff + have h1 : z ∈ toList X := (FiniteSetLaws.mem_toList X z).mpr hz_in_X + have h2 : (fun w => !mem w Y) z = true := by simp [hz] + have : z ∈ (toList X).filter (fun w => !mem w Y) := + List.mem_filter.mpr ⟨h1, h2⟩ + exact (FiniteSetLaws.mem_ofList _ z).mpr this + exact (mem_union Y (diff X Y) z).mpr (Or.inr this) + · -- z ∈ Y + have : z ∈ Y := hz + exact (mem_union Y (diff X Y) z).mpr (Or.inl this) + · intro hz_in_union + have : z ∈ Y ∨ z ∈ diff X Y := (mem_union Y (diff X Y) z).mp hz_in_union + cases this with + | inl h' => exact h z h' + | inr h' => + unfold diff at h' + have h1 : z ∈ (toList X).filter (fun w => !mem w Y) := + (FiniteSetLaws.mem_ofList _ z).mp h' + have ⟨h2, _⟩ := List.mem_filter.mp h1 + exact (FiniteSetLaws.mem_toList X z).mp h2 /-- Membership in filter: x ∈ filter φ X ↔ x ∈ X ∧ φ x = true -/ theorem mem_filter (X : S) (φ : A → Bool) (x : A) : x ∈ (FiniteSet.filter φ X) ↔ (x ∈ X ∧ φ x = true) := by - sorry - -/-- Size of a finite set: number of elements. Corresponds to Rocq's `size`. -/ -def size (s : S) : Nat := (toList s).length - -/-- The set is finite (always true for FiniteSet). Corresponds to Rocq's `set_finite`. -/ + unfold filter + constructor + · intro h + have h1 : x ∈ (toList X).filter φ := (FiniteSetLaws.mem_ofList _ x).mp h + have ⟨h2, h3⟩ : x ∈ toList X ∧ φ x = true := List.mem_filter.mp h1 + exact ⟨(FiniteSetLaws.mem_toList X x).mp h2, h3⟩ + · intro ⟨h1, h2⟩ + have h3 : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h1 + have : x ∈ (toList X).filter φ := List.mem_filter.mpr ⟨h3, h2⟩ + exact (FiniteSetLaws.mem_ofList _ x).mpr this + +/-- Corresponds to Rocq's `set_finite`. -/ theorem set_finite (X : S) : ∃ (l : List A), ∀ x, x ∈ l ↔ x ∈ X := by exists toList X intro x @@ -271,17 +436,35 @@ theorem set_finite (X : S) : ∃ (l : List A), ∀ x, x ∈ l ↔ x ∈ X := by section Elements -/-- toList is proper: equivalent sets have permutation-equivalent lists. - Corresponds to Rocq's `elements_proper`. -/ -theorem toList_proper (X Y : S) (h : ∀ x, mem x X = mem x Y) : - (toList X).Perm (toList Y) := by - sorry -/-- Converting list to set and back gives the original set (up to permutation). - Corresponds to Rocq's `list_to_set_elements`. -/ +/-- Corresponds to Rocq's `NoDup_Permutation`. -/ +theorem list_perm_of_mem_eq_nodup (l₁ l₂ : List A) (h1 : l₁.Nodup) (h2 : l₂.Nodup) + (hmem : ∀ x, x ∈ l₁ ↔ x ∈ l₂) : l₁.Perm l₂ := by + apply List.perm_iff_count.mpr + intro a + rw [h1.count, h2.count] + simp only [hmem] + +/-- Corresponds to Rocq's `elements_proper`. -/ +theorem toList_proper (X Y : S) (h : X ≡ Y) : + (toList X).Perm (toList Y) := by + have hX := @FiniteSetLaws.toList_nodup A S _ _ _ X + have hY := @FiniteSetLaws.toList_nodup A S _ _ _ Y + apply list_perm_of_mem_eq_nodup (toList X) (toList Y) hX hY + intro x + constructor + · intro hx + have : x ∈ X := (FiniteSetLaws.mem_toList X x).mp hx + have : x ∈ Y := (h x).mp this + exact (FiniteSetLaws.mem_toList Y x).mpr this + · intro hy + have : x ∈ Y := (FiniteSetLaws.mem_toList Y x).mp hy + have : x ∈ X := (h x).mpr this + exact (FiniteSetLaws.mem_toList X x).mpr this + +/-- Corresponds to Rocq's `list_to_set_elements`. -/ theorem ofList_toList_equiv (X : S) : ∀ x, x ∈ (ofList (toList X) : S) ↔ x ∈ X := by intro x - -- Use mem_ofList and mem_toList axioms constructor · intro h have : x ∈ toList X := (FiniteSetLaws.mem_ofList (toList X) x).mp h @@ -290,93 +473,146 @@ theorem ofList_toList_equiv (X : S) : ∀ x, x ∈ (ofList (toList X) : S) ↔ x have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr h exact (FiniteSetLaws.mem_ofList (toList X) x).mpr this -/-- Converting a NoDup list to set and back gives a permutation. - Corresponds to Rocq's `elements_list_to_set`. -/ +/-- Corresponds to Rocq's `elements_list_to_set`. -/ theorem toList_ofList_perm (l : List A) (h : l.Nodup) : (toList (ofList l : S)).Perm l := by - -- Directly use the axiom toList_ofList exact FiniteSetLaws.toList_ofList l (ofList l : S) h rfl -/-- Union of singleton and set when element not in set. - Corresponds to Rocq's `elements_union_singleton`. -/ +/-- Corresponds to Rocq's `elements_union_singleton`. -/ theorem toList_union_singleton (X : S) (x : A) (h : x ∉ X) : (toList (union (singleton x) X)).Perm (x :: toList X) := by - -- Use the fact that {x} and X are disjoint, then use toList_union have hdisj : Disjoint (singleton x) X := by intro y intro ⟨h1, h2⟩ - -- y ∈ {x} means y = x have : y = x := (mem_singleton y x).mp h1 rw [this] at h2 exact h h2 - -- Get the permutation from toList_union obtain ⟨l', hperm, hperm'⟩ := toList_union (singleton x) X hdisj - -- toList (singleton x) is a permutation of [x] have hsing := toList_singleton (A := A) (S := S) x - -- Build up the permutation step by step have h1 : (toList (singleton x) ++ l').Perm ([x] ++ l') := List.Perm.append hsing (List.Perm.refl l') have h2 : ([x] ++ l').Perm ([x] ++ toList X) := List.Perm.append (List.Perm.refl [x]) hperm'.symm exact hperm.trans (h1.trans h2) -/-- Subset relation on toList. Corresponds to Rocq's `elements_submseteq`. -/ -theorem toList_submseteq (X Y : S) (h : X ⊆ Y) : - ∀ x, x ∈ toList X → x ∈ toList Y := by - intro x hx - rw [FiniteSetLaws.mem_toList] at hx ⊢ - exact h x hx +/-- Union is commutative for toList (up to permutation). -/ +theorem toList_union_comm (X Y : S) : + (FiniteSet.toList (X ∪ Y)).Perm (FiniteSet.toList (Y ∪ X)) := by + -- Show that union X Y ≡ union Y X, then use toList_proper + have hequiv : union X Y ≡ union Y X := by + intro z + constructor + · intro h + have : z ∈ X ∨ z ∈ Y := (mem_union X Y z).mp h + have : z ∈ Y ∨ z ∈ X := this.symm + exact (mem_union Y X z).mpr this + · intro h + have : z ∈ Y ∨ z ∈ X := (mem_union Y X z).mp h + have : z ∈ X ∨ z ∈ Y := this.symm + exact (mem_union X Y z).mpr this + exact toList_proper (union X Y) (union Y X) hequiv + +/-- toList of set difference (up to permutation). -/ +theorem toList_sdiff (X : S) (x : A) (h : FiniteSet.mem x X = true) : + ∃ l', (FiniteSet.toList X).Perm (x :: l') ∧ + (FiniteSet.toList (FiniteSet.diff X (FiniteSet.singleton x))).Perm l' := by + have h' : x ∈ X := h + have herase := FiniteSetLaws.set_to_list_erase X x h' + obtain ⟨l', hperm, heq⟩ := herase + have hmem_eq : ∀ y, y ∈ erase x X ↔ y ∈ diff X (singleton x) := by + intro y + constructor + · intro hy + cases heq_y : decide (y = x) + · -- y ≠ x + have hne : y ≠ x := by + intro heq + subst heq + simp at heq_y + have : y ∈ X := (mem_erase_ne X y x hne).mp hy + exact (mem_diff_singleton X x y).mpr ⟨this, hne⟩ + · simp at heq_y + have : y ∉ erase x X := mem_erase_eq X y x heq_y + exact absurd hy this + · intro hy + have ⟨hy_in_X, hy_ne⟩ := (mem_diff_singleton X x y).mp hy + exact (mem_erase_ne X y x hy_ne).mpr hy_in_X + exists l' + constructor + · exact hperm + · rw [← heq] + apply List.Perm.symm + apply toList_proper + intro y + exact hmem_eq y + + /-- Corresponds to Rocq's `elements_submseteq` -/ + theorem toList_subset : ∀ (X Y : S), Y ⊆ X → + ∃ l, (FiniteSet.toList Y ++ l).Perm (FiniteSet.toList X) := by + intro X Y h + -- Use union_diff to decompose X into Y ∪ (X \ Y) + have ⟨hdisj, hequiv⟩ := union_diff X Y h + -- Get the permutation from toList_union + obtain ⟨l', hperm, hperm'⟩ := toList_union Y (diff X Y) hdisj + -- Use l' as the witness + exists l' + -- Show (toList Y ++ l') ~ toList X + -- We know toList (Y ∪ (X \ Y)) ~ toList Y ++ l' from hperm + -- and toList X ~ toList (Y ∪ (X \ Y)) from hequiv + have h1 : (toList X).Perm (toList (Y ∪ (diff X Y))) := + toList_proper X (Y ∪ (diff X Y)) hequiv + have h2 : (toList (Y ∪ (diff X Y))).Perm (toList Y ++ l') := hperm + exact (h1.trans h2).symm end Elements section Size -/-- Empty set has size 0. Corresponds to Rocq's `size_empty`. -/ +/-- Corresponds to Rocq's `size_empty`. -/ theorem size_empty : size (∅ : S) = 0 := by unfold size rw [FiniteSetLaws.toList_empty] rfl -/-- Size 0 iff empty set. Corresponds to Rocq's `size_empty_iff`. -/ +/-- Corresponds to Rocq's `size_empty_iff`. -/ theorem size_empty_iff (X : S) : size X = 0 ↔ ∀ x, x ∉ X := by constructor - · -- Forward: size X = 0 → ∀ x, x ∉ X - intro hsize x + · intro hsize x unfold size at hsize - -- toList X has length 0, so it must be [] have hnil : toList X = [] := List.eq_nil_of_length_eq_zero hsize - -- If x ∈ X were true, then x ∈ toList X, but toList X = [] intro hmem have : x ∈ toList X := (FiniteSetLaws.mem_toList X x).mpr hmem rw [hnil] at this cases this - · -- Backward: (∀ x, x ∉ X) → size X = 0 - sorry - -/-- Singleton set has size 1. Corresponds to Rocq's `size_singleton`. -/ + · intro hempty + unfold size + cases hlist : toList X with + | nil => rfl + | cons x xs => + have : x ∈ toList X := by rw [hlist]; exact List.mem_cons_self .. + have : x ∈ X := (FiniteSetLaws.mem_toList X x).mp this + exact absurd this (hempty x) + +/-- Corresponds to Rocq's `size_singleton`. -/ theorem size_singleton (x : A) : size (singleton x : S) = 1 := by unfold size have h := toList_singleton (A := A) (S := S) x have : [x].length = 1 := rfl rw [← this, ← h.length_eq] -/-- Non-empty set has positive size. Corresponds to Rocq's `set_choose`. -/ +/-- Corresponds to Rocq's `set_choose`. -/ theorem set_choose (X : S) (h : size X ≠ 0) : ∃ x, x ∈ X := by unfold size at h - -- If toList X has non-zero length, it must be x :: l for some x, l cases hlist : toList X with | nil => - -- Contradiction: list is empty but h says length ≠ 0 rw [hlist] at h simp at h | cons x l => - -- x is the first element, so x ∈ toList X exists x have : x ∈ toList X := by rw [hlist]; exact List.mem_cons_self .. exact (FiniteSetLaws.mem_toList X x).mp this -/-- Union of disjoint sets has size equal to sum. - Corresponds to Rocq's `size_union`. -/ +/-- Corresponds to Rocq's `size_union`. -/ theorem size_union (X Y : S) (h : Disjoint X Y) : size (X ∪ Y) = size X + size Y := by unfold size @@ -388,27 +624,8 @@ theorem subseteq_size (X Y : S) (h : X ⊆ Y) : size X ≤ size Y := by have ⟨hdisj, heq⟩ := union_diff Y X h -- Y = X ∪ (Y \ X) in terms of membership, and X and Y \ X are disjoint -- We can use toList_proper to show Y and X ∪ (Y \ X) have the same size - have hmem_eq : ∀ z, mem z Y = mem z (X ∪ (Y \ X)) := by - intro z - -- heq z says: z ∈ Y ↔ z ∈ (X ∪ (Y \ X)) - -- Need to show: mem z Y = mem z (X ∪ Y \ X) - cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) - · rfl - · -- Contradiction: X ∪ (Y \ X) true but Y false - have h1 : z ∈ (X ∪ (Y \ X)) := hmem_union - have h2 : z ∈ Y := (heq z).mpr h1 - have h3 : mem z Y = true := h2 - rw [hmem_y] at h3 - cases h3 - · -- Contradiction: Y true but X ∪ (Y \ X) false - have h1 : z ∈ Y := hmem_y - have h2 : z ∈ (X ∪ (Y \ X)) := (heq z).mp h1 - have h3 : mem z (X ∪ (Y \ X)) = true := h2 - rw [hmem_union] at h3 - cases h3 - · rfl -- Use toList_proper to get that the lists have the same length - have hperm := toList_proper Y (X ∪ (Y \ X)) hmem_eq + have hperm := toList_proper Y (X ∪ (Y \ X)) heq have hsize_eq : size Y = size (X ∪ (Y \ X)) := by unfold size exact hperm.length_eq @@ -422,22 +639,9 @@ theorem subset_size (X Y : S) (h : X ⊆ Y) (hne : ∃ x, x ∈ Y ∧ x ∉ X) : have ⟨x, hmemY, hmemX⟩ := hne -- Derive: size Y = size X + size (Y \ X) from union_diff have ⟨hdisj, heq⟩ := union_diff Y X h - have hmem_eq : ∀ z, mem z Y = mem z (X ∪ (Y \ X)) := by - intro z - cases hmem_y : mem z Y <;> cases hmem_union : mem z (X ∪ (Y \ X)) - · rfl - · have h1 : z ∈ (X ∪ (Y \ X)) := hmem_union - have h2 : z ∈ Y := (heq z).mpr h1 - have h3 : mem z Y = true := h2 - rw [hmem_y] at h3; cases h3 - · have h1 : z ∈ Y := hmem_y - have h2 : z ∈ (X ∪ (Y \ X)) := (heq z).mp h1 - have h3 : mem z (X ∪ (Y \ X)) = true := h2 - rw [hmem_union] at h3; cases h3 - · rfl have hsize_union := size_union X (Y \ X) hdisj have hsize_y : size Y = size X + size (Y \ X) := by - have hperm := toList_proper Y (X ∪ (Y \ X)) hmem_eq + have hperm := toList_proper Y (X ∪ (Y \ X)) heq calc size Y _ = size (X ∪ (Y \ X)) := by unfold size; exact hperm.length_eq _ = size X + size (Y \ X) := hsize_union @@ -471,27 +675,10 @@ theorem size_difference (X Y : S) (h : Y ⊆ X) : size (X \ Y) = size X - size Y := by have ⟨hdisj, heq⟩ := union_diff X Y h -- X = Y ∪ (X \ Y) and they are disjoint - have hmem_eq : ∀ z, mem z X = mem z (Y ∪ (X \ Y)) := by - intro z - cases hmem_x : mem z X <;> cases hmem_union : mem z (Y ∪ (X \ Y)) - · rfl - · -- Contradiction: Y ∪ (X \ Y) true but X false - have h1 : z ∈ (Y ∪ (X \ Y)) := hmem_union - have h2 : z ∈ X := (heq z).mpr h1 - have h3 : mem z X = true := h2 - rw [hmem_x] at h3 - cases h3 - · -- Contradiction: X true but Y ∪ (X \ Y) false - have h1 : z ∈ X := hmem_x - have h2 : z ∈ (Y ∪ (X \ Y)) := (heq z).mp h1 - have h3 : mem z (Y ∪ (X \ Y)) = true := h2 - rw [hmem_union] at h3 - cases h3 - · rfl -- Use size_union have hsize_union := size_union Y (X \ Y) hdisj have : size X = size Y + size (X \ Y) := by - have hperm := toList_proper X (Y ∪ (X \ Y)) hmem_eq + have hperm := toList_proper X (Y ∪ (X \ Y)) heq calc size X _ = size (Y ∪ (X \ Y)) := by unfold size; exact hperm.length_eq _ = size Y + size (X \ Y) := hsize_union @@ -625,16 +812,70 @@ theorem set_wf : WellFounded (fun (X Y : S) => X ⊆ Y ∧ ∃ x, x ∈ Y ∧ x exact h_sub X Y hrel · exact (measure (size (S := S) (A := A))).wf -/-- Induction principle for finite sets. - Corresponds to Rocq's `set_ind`. -/ +/-- Corresponds to Rocq's `set_ind`. -/ theorem set_ind {P : S → Prop} + (proper : ∀ X Y, X ≡ Y → P X → P Y) (hemp : P ∅) (hadd : ∀ x X, x ∉ X → P X → P (union (singleton x) X)) (X : S) : P X := by -- Use well-founded induction based on set_wf apply WellFounded.induction set_wf X intro Y IH - sorry + -- Case split on whether Y is empty + cases hsize : size Y with + | zero => + -- Y is empty, so use hemp + have hempty_equiv : ∀ x, x ∉ Y := (size_empty_iff Y).mp hsize + -- Show P Y by using proper to transfer from ∅ + have hY_equiv : ∅ ≡ Y := by + intro x + constructor + · intro h + exact absurd h (FiniteSetLaws.mem_empty x) + · intro h + exact absurd h (hempty_equiv x) + exact proper ∅ Y hY_equiv hemp + | succ n => + -- Y is non-empty, so pick an element x ∈ Y + have ⟨x, hx⟩ := set_choose Y (by omega) + -- Let Y' = Y \ {x} + let Y' := diff Y (singleton x) + -- Show that Y' is a proper subset of Y + have hsub : Y' ⊆ Y := by + intro z hz + have ⟨hz_in_Y, _⟩ := (mem_diff_singleton Y x z).mp hz + exact hz_in_Y + have hproper : ∃ y, y ∈ Y ∧ y ∉ Y' := by + exists x + constructor + · exact hx + · intro hcontra + have ⟨_, hne⟩ := (mem_diff_singleton Y x x).mp hcontra + exact hne rfl + -- Apply IH to Y' + have hP_Y' : P Y' := IH Y' ⟨hsub, hproper⟩ + -- Show x ∉ Y' + have hx_notin : x ∉ Y' := by + intro hcontra + have ⟨_, hne⟩ := (mem_diff_singleton Y x x).mp hcontra + exact hne rfl + -- Apply hadd + have hP_union : P (union (singleton x) Y') := hadd x Y' hx_notin hP_Y' + -- Show Y ≡ union (singleton x) Y' using union_diff + have hY_equiv : union (singleton x) Y' ≡ Y := by + intro z + -- Use the union_diff theorem + have hsub_singleton : singleton x ⊆ Y := by + intro w hw + have : w = x := (mem_singleton w x).mp hw + rw [this] + exact hx + have ⟨_, heq⟩ := union_diff Y (singleton x) hsub_singleton + -- heq shows Y ≡ singleton x ∪ (Y \ singleton x) + -- Y' = diff Y (singleton x), so this is exactly what we need + exact (heq z).symm + -- Use proper to transfer P from union (singleton x) Y' to Y + exact proper (union (singleton x) Y') Y hY_equiv hP_union end SetInduction diff --git a/src/Iris/Std/FiniteSetInst.lean b/src/Iris/Std/FiniteSetInst.lean new file mode 100644 index 00000000..4ddc28e2 --- /dev/null +++ b/src/Iris/Std/FiniteSetInst.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2025 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ + +import Iris.Std.FiniteSet +import Std + +/-! ## Concrete Instance of Finite Set Interface + +This file provides a concrete implementation of the `FiniteSet` interface using `Std.TreeSet` +-/ + +namespace Iris.Std + +open Lean + +/-- Concrete implementation of FiniteSet using TreeSet -/ +instance {A : Type v} [Ord A] [Std.LawfulEqCmp (compare : A → A → Ordering)] [Std.TransCmp (compare : A → A → Ordering)] [DecidableEq A] : FiniteSet A (Std.TreeSet A compare) where + empty := Std.TreeSet.empty + toList s := s.toList + ofList l := Std.TreeSet.ofList l + +namespace FiniteSetInst + +variable {A : Type v} [Ord A] [Std.LawfulEqCmp (compare : A → A → Ordering)] [Std.TransCmp (compare : A → A → Ordering)] [DecidableEq A] + +omit [DecidableEq A] in +theorem mem_toList (s : Std.TreeSet A compare) (x : A) : + x ∈ s.toList ↔ s.contains x := by + exact Std.TreeSet.mem_toList.trans Std.TreeSet.mem_iff_contains + +theorem ofList_mem (l : List A) (x : A) : + (Std.TreeSet.ofList l : Std.TreeSet A compare).contains x ↔ x ∈ l := by + rw [← Std.TreeSet.mem_iff_contains, Std.TreeSet.mem_ofList, List.contains_iff_mem] + +end FiniteSetInst + +/-- Laws for TreeSet FiniteSet instance -/ +instance {A : Type v} [DecidableEq A] [LawfulBEq A] [Ord A] [Std.LawfulEqCmp (compare : A → A → Ordering)] [Std.LawfulBEqCmp (compare : A → A → Ordering)] [Std.TransCmp (compare : A → A → Ordering)] : FiniteSetLaws A (Std.TreeSet A compare) where + mem_empty := by + intro x h + simp [Membership.mem, FiniteSet.mem, FiniteSet.toList] at h + cases h + + toList_ofList := by + intro l s hnodup heq + subst heq + simp [toList, ofList] + have h_nodup_toList : (Std.TreeSet.ofList l compare).toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := Std.TreeSet.ofList l compare) + apply List.Pairwise.imp _ h_distinct + intro a b hab + intro heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + apply List.perm_iff_count.mpr + intro a + rw [hnodup.count, h_nodup_toList.count] + by_cases ha : a ∈ l + · have : a ∈ Std.TreeSet.ofList l compare := by + rw [Std.TreeSet.mem_ofList] + exact List.contains_iff_mem.mpr ha + have : a ∈ (Std.TreeSet.ofList l compare).toList := Std.TreeSet.mem_toList.mpr this + simp [ha, this] + · have : a ∉ Std.TreeSet.ofList l compare := by + intro h + rw [Std.TreeSet.mem_ofList, List.contains_iff_mem] at h + exact ha h + have : a ∉ (Std.TreeSet.ofList l compare).toList := fun h => this (Std.TreeSet.mem_toList.mp h) + simp [ha, this] + + toList_nodup := fun X => by + have h_distinct := Std.TreeSet.distinct_toList (t := X) + apply List.Pairwise.imp _ h_distinct + intro a b hab + intro heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + + set_to_list_insert := by + intro s x hnotin + simp [toList, FiniteSet.insert, ofList] + have h_not_mem : x ∉ s.toList := by + intro hmem + apply hnotin + simp [Membership.mem, FiniteSet.mem, FiniteSet.toList] + exact hmem + have h_nodup : (x :: s.toList).Nodup := by + apply List.nodup_cons.mpr + constructor + · exact h_not_mem + · have h_distinct := Std.TreeSet.distinct_toList (t := s) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + apply List.perm_iff_count.mpr + intro a + have h_nodup2 : (Std.TreeSet.ofList (x :: s.toList) compare).toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := Std.TreeSet.ofList (x :: s.toList) compare) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + rw [h_nodup2.count, h_nodup.count] + by_cases ha : a ∈ (x :: s.toList) + · have : a ∈ Std.TreeSet.ofList (x :: s.toList) compare := by + rw [Std.TreeSet.mem_ofList] + exact List.contains_iff_mem.mpr ha + have : a ∈ (Std.TreeSet.ofList (x :: s.toList) compare).toList := Std.TreeSet.mem_toList.mpr this + simp [ha, this] + · have : a ∉ Std.TreeSet.ofList (x :: s.toList) compare := by + intro h + rw [Std.TreeSet.mem_ofList, List.contains_iff_mem] at h + exact ha h + have : a ∉ (Std.TreeSet.ofList (x :: s.toList) compare).toList := fun h => this (Std.TreeSet.mem_toList.mp h) + simp [ha, this] + + set_to_list_erase := by + intro s x hin + exists toList (FiniteSet.erase x s) + constructor + · simp [toList, FiniteSet.erase, ofList] + have h_mem : x ∈ s.toList := by + simp [Membership.mem, FiniteSet.mem, FiniteSet.toList] at hin + exact hin + have h_nodup : s.toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := s) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + have h_filter_eq : List.filter (fun y => !decide (y = x)) s.toList = s.toList.erase x := by + have h_pred_eq : (fun y => !decide (y = x)) = (fun y => y != x) := by + funext y + simp only [bne] + rfl + rw [h_pred_eq, ← h_nodup.erase_eq_filter] + rw [h_filter_eq] + have h_perm1 : s.toList.Perm (x :: s.toList.erase x) := List.perm_cons_erase h_mem + have h_nodup_erase : (s.toList.erase x).Nodup := h_nodup.erase x + have h_perm2 : (Std.TreeSet.ofList (s.toList.erase x) compare).toList.Perm (s.toList.erase x) := by + apply List.perm_iff_count.mpr + intro a + have h_nodup2 : (Std.TreeSet.ofList (s.toList.erase x) compare).toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := Std.TreeSet.ofList (s.toList.erase x) compare) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + rw [h_nodup2.count, h_nodup_erase.count] + by_cases ha : a ∈ s.toList.erase x + · have : a ∈ Std.TreeSet.ofList (s.toList.erase x) compare := by + rw [Std.TreeSet.mem_ofList] + exact List.contains_iff_mem.mpr ha + have : a ∈ (Std.TreeSet.ofList (s.toList.erase x) compare).toList := Std.TreeSet.mem_toList.mpr this + simp [ha, this] + · have : a ∉ Std.TreeSet.ofList (s.toList.erase x) compare := by + intro h + rw [Std.TreeSet.mem_ofList, List.contains_iff_mem] at h + exact ha h + have : a ∉ (Std.TreeSet.ofList (s.toList.erase x) compare).toList := fun h => this (Std.TreeSet.mem_toList.mp h) + simp [ha, this] + exact h_perm1.trans (List.Perm.cons x h_perm2.symm) + · rfl + + ofList_nil := by + rfl + + toList_empty := by + rfl + + mem_toList := by + intro X x + simp [Membership.mem, FiniteSet.mem] + + toList_filter := by + intro X φ + simp [toList, FiniteSet.filter, ofList] + have h_nodup : (List.filter φ X.toList).Nodup := by + have h_nodup_orig : X.toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := X) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + exact h_nodup_orig.filter φ + apply List.perm_iff_count.mpr + intro a + have h_nodup2 : (Std.TreeSet.ofList (List.filter φ X.toList) compare).toList.Nodup := by + have h_distinct := Std.TreeSet.distinct_toList (t := Std.TreeSet.ofList (List.filter φ X.toList) compare) + apply List.Pairwise.imp _ h_distinct + intro a b hab heq + subst heq + exact hab (Std.LawfulEqCmp.compare_eq_iff_eq.mpr rfl) + rw [h_nodup2.count, h_nodup.count] + by_cases ha : a ∈ List.filter φ X.toList + · have : a ∈ Std.TreeSet.ofList (List.filter φ X.toList) compare := by + rw [Std.TreeSet.mem_ofList] + exact List.contains_iff_mem.mpr ha + have : a ∈ (Std.TreeSet.ofList (List.filter φ X.toList) compare).toList := Std.TreeSet.mem_toList.mpr this + simp [ha, this] + · have : a ∉ Std.TreeSet.ofList (List.filter φ X.toList) compare := by + intro h + rw [Std.TreeSet.mem_ofList, List.contains_iff_mem] at h + exact ha h + have : a ∉ (Std.TreeSet.ofList (List.filter φ X.toList) compare).toList := fun h => this (Std.TreeSet.mem_toList.mp h) + simp [ha, this] + + mem_ofList := by + intro l x + simp [Membership.mem, FiniteSet.mem, FiniteSet.toList, FiniteSet.ofList] + have h1 : x ∈ (Std.TreeSet.ofList l compare).toList ↔ x ∈ (Std.TreeSet.ofList l compare) := Std.TreeSet.mem_toList + have h2 : x ∈ (Std.TreeSet.ofList l compare) ↔ l.contains x = true := Std.TreeSet.mem_ofList + have h3 : l.contains x = true ↔ x ∈ l := List.contains_iff_mem + exact h1.trans (h2.trans h3) + +end Iris.Std From 348c4745c411cef3d9d9a1f2adf431514782642d Mon Sep 17 00:00:00 2001 From: Zongyuan Liu Date: Thu, 15 Jan 2026 08:53:17 +0100 Subject: [PATCH 9/9] Export the interface and the instances --- src/Iris/Std.lean | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Iris/Std.lean b/src/Iris/Std.lean index a327a54b..ea304485 100644 --- a/src/Iris/Std.lean +++ b/src/Iris/Std.lean @@ -1,6 +1,9 @@ import Iris.Std.Classes import Iris.Std.Expr import Iris.Std.FiniteMap +import Iris.Std.FiniteMapInst +import Iris.Std.FiniteSet +import Iris.Std.FiniteSetInst import Iris.Std.Nat import Iris.Std.Prod import Iris.Std.Qq