From 0d155336425255fc4fb1edfff9fdbd188dc81782 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 07:14:19 +0000 Subject: [PATCH 1/7] feat: preserve the Iris ordered resource algebra model --- LeanPool/IrisAlgebra.lean | 43 + LeanPool/IrisAlgebra/Algebra/CMRA.lean | 3132 +++++++++++++++++ .../IrisAlgebra/Algebra/CMRAConstructors.lean | 283 ++ LeanPool/IrisAlgebra/Algebra/COFESolver.lean | 321 ++ LeanPool/IrisAlgebra/Algebra/GenMap.lean | 500 +++ LeanPool/IrisAlgebra/Algebra/IProp.lean | 105 + LeanPool/IrisAlgebra/Algebra/Monoid.lean | 97 + LeanPool/IrisAlgebra/Algebra/OFE.lean | 2086 +++++++++++ LeanPool/IrisAlgebra/Algebra/UPred.lean | 165 + LeanPool/IrisAlgebra/Algebra/Updates.lean | 234 ++ LeanPool/IrisAlgebra/Imports.lean | 20 + LeanPool/IrisAlgebra/Std/Nat.lean | 48 + LeanPool/IrisAlgebra/Std/Option.lean | 40 + LeanPool/projects/iris-algebra.yaml | 78 + 14 files changed, 7152 insertions(+) create mode 100644 LeanPool/IrisAlgebra.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/CMRA.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/COFESolver.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/GenMap.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/IProp.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/Monoid.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/OFE.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/UPred.lean create mode 100644 LeanPool/IrisAlgebra/Algebra/Updates.lean create mode 100644 LeanPool/IrisAlgebra/Imports.lean create mode 100644 LeanPool/IrisAlgebra/Std/Nat.lean create mode 100644 LeanPool/IrisAlgebra/Std/Option.lean create mode 100644 LeanPool/projects/iris-algebra.yaml diff --git a/LeanPool/IrisAlgebra.lean b/LeanPool/IrisAlgebra.lean new file mode 100644 index 0000000000..f55d292645 --- /dev/null +++ b/LeanPool/IrisAlgebra.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2022 The Iris-Lean Contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: The Iris-Lean Contributors +-/ + +module + +public import LeanPool.IrisAlgebra.Algebra.CMRAConstructors +public import LeanPool.IrisAlgebra.Algebra.IProp + +/-! +# Ordered resource algebras and the Iris recursive domain model + +Source: arxiv:2609.24252, url:https://github.com/leanprover-community/iris-lean +Authors: The Iris-Lean Contributors +Status: verified +Main declarations: `Iris.IProp.fold_unfold`, `Iris.IProp.unfold_fold` +Tags: program-semantics, separation-logic, resource-algebras, guarded-recursion, domain-equations +MSC: 03B70, 68Q55, 68N30 +-/ + +/-! +# Ordered resource algebras and the Iris recursive domain model + +This is the algebraic dependency closure of `Iris.Algebra.IProp` from +`leanprover-community/iris-lean` at `81bc35088ba67d465db008f5261a9b341eb6cf6c`. +It includes the ordered resource algebras added on October 14, 2026, and retains +the general complete step-indexed space and guarded recursive domain constructions. +The separation logic proof mode, program logics, HeapLang, and verification automation +are outside this import's scope. + +Upstream NOTICE: + +Iris-Lean — Copyright (c) 2022–2026 The Iris-Lean Contributors. +Prior per-file copyright notices are preserved in the upstream repository's git history +(tag `copyright-notices`). Individual authors are retained in file headers; the project YAML +also preserves the original notices verbatim, including names transliterated in Lean headers. + +The upstream code is Apache-2.0. The port removes source-tracking commands, replaces +implemented opaque definitions by ordinary irreducible definitions, and adapts proofs +to Lean Pool's pinned Lean and Mathlib. No program-logic soundness theorem is claimed here. +-/ diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean new file mode 100644 index 0000000000..8b1a8ec595 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -0,0 +1,3132 @@ +/- +Copyright (c) 2025 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Sukharik (@suhr), Markus de Medeiros, Puming Liu, Janine Lohse +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.OFE +public import LeanPool.IrisAlgebra.Algebra.Monoid + +/-! Ordered resource algebras and their morphisms. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris +open OFE + +/-- The underlying operation of a resource. -/ +class Op (α : Type _) [OFE α] where + /-- The composition operation. -/ + op : α → α → α + op_ne : NonExpansive (op x) + assoc : op x (op y z) = op (op x y) z + comm : op x y = op y x + +namespace Op + +@[inherit_doc] infix:60 " • " => op + +variable [OFE α] [Op α] + +/-- The composition operation with an optional right argument. -/ +def optionalOp (x : α) : Option α → α + | some y => x • y + | none => x +@[inherit_doc] infix:60 " •? " => optionalOp + +end Op + +/-- The partial core operator for a resource algebra. -/ +class PCore (α : Type _) [OFE α] where + /-- The partial core of a resource. -/ + pcore : α → Option α + pcore_ne {n : Nat} {x y cx : α} : x ≡{n}≡ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx + ≡{n}≡ cy + pcore_idem {x cx : α} : pcore x = some cx → pcore cx = some cx + +namespace PCore +variable [OFE α] [PCore α] + +/-- The total core operation. -/ +def core (x : α) := (pcore x).getD x + +end PCore + +/-- A resource algebra whose core is total. -/ +class IsTotal (α : Type _) [OFE α] [PCore α] : Prop where + total (x : α) : ∃ cx, PCore.pcore x = some cx + +/-- The validity predicates of a resource algebra. -/ +class Validity (α : Type _) [OFE α] where + /-- The step-indexed validity predicate. -/ + ValidN : Nat → α → Prop + /-- The validity predicate. -/ + Valid : α → Prop + validN_ne : x ≡{n}≡ y → ValidN n x → ValidN n y + valid_iff_validN : Valid x ↔ ∀ n, ValidN n x + validN_succ : ValidN n.succ x → ValidN n x + +namespace Validity + +@[inherit_doc] prefix:50 "✓ " => Validity.Valid +@[inherit_doc] notation:50 "✓{" n "} " x:51 => Validity.ValidN n x + +end Validity + +/-- The ordering predicate on a resource algebra. -/ +class Ordered (α : Type _) [OFE α] where + /-- The indexed ordering predicate. This is the generic ORA order predicate; if your ORA is + `OrdInc`, the lemma `ordN_incN` converts it to the extension order typical of Iris CMRAs. -/ + OrderN : Nat → α → α → Prop + /-- The ordering predicate. This is the generic ORA order predicate; if your ORA is `OrdInc`, + the lemma `ord_inc` converts it to the extension order typical of Iris CMRAs. -/ + Order : α → α → Prop + ordN_ne {n} {x x' y y' : α} : x ≡{n}≡ x' → y ≡{n}≡ y' → OrderN n x y → OrderN n x' y' + ordN_succ {n} {x y : α} : OrderN n.succ x y → OrderN n x y + ordN_trans {n} {x y z : α} : OrderN n x y → OrderN n y z → OrderN n x z + ord_trans {x y z : α} : Order x y → Order y z → Order x z + ordN_of_ord {x y : α} (n) : Order x y → OrderN n x y + +namespace Ordered + +@[inherit_doc] notation:50 x " ≼ₒ{" n "} " y:51 => OrderN n x y +@[inherit_doc] infix:50 " ≼ₒ " => Order + +variable [OFE α] [Ordered α] + +/-- The reflexive closure of the step-indexed order. -/ +def OrderNR (n : Nat) (x y : α) : Prop := x ≡{n}≡ y ∨ x ≼ₒ{n} y +@[inherit_doc] notation:50 x " ≼ₒ*{" n "} " y:51 => OrderNR n x y + +/-- The reflexive closure of the order. -/ +def OrderR (x y : α) : Prop := x = y ∨ x ≼ₒ y +@[inherit_doc] infix:50 " ≼ₒ* " => OrderR + +theorem OrderN.ordNR {n} {x y : α} : x ≼ₒ{n} y → x ≼ₒ*{n} y := .inr +theorem Order.ordR {x y : α} : x ≼ₒ y → x ≼ₒ* y := .inr + +@[refl] theorem OrderNR.rfl {n} {x : α} : x ≼ₒ*{n} x := .inl .rfl +@[refl] theorem OrderR.rfl {x : α} : x ≼ₒ* x := .inl (Eq.refl x) + +theorem OrderNR.ne {n} {x x' y y' : α} (ex : x ≡{n}≡ x') (ey : y ≡{n}≡ y') : + x ≼ₒ*{n} y → x' ≼ₒ*{n} y' + | .inl e => .inl (ex.symm.trans (e.trans ey)) + | .inr h => .inr (ordN_ne ex ey h) + +theorem OrderNR.succ {n} {x y : α} : x ≼ₒ*{n.succ} y → x ≼ₒ*{n} y + | .inl e => .inl (e.le (Nat.le_succ n)) + | .inr h => .inr (ordN_succ h) + +theorem OrderNR.trans {n} {x y z : α} : x ≼ₒ*{n} y → y ≼ₒ*{n} z → x ≼ₒ*{n} z + | .inl e₁, .inl e₂ => .inl (e₁.trans e₂) + | .inl e₁, .inr h₂ => .inr (ordN_ne e₁.symm .rfl h₂) + | .inr h₁, .inl e₂ => .inr (ordN_ne .rfl e₂ h₁) + | .inr h₁, .inr h₂ => .inr (ordN_trans h₁ h₂) + +theorem OrderR.trans {x y z : α} : x ≼ₒ* y → y ≼ₒ* z → x ≼ₒ* z + | .inl e₁, h₂ => e₁ ▸ h₂ + | h₁, .inl e₂ => e₂ ▸ h₁ + | .inr h₁, .inr h₂ => .inr (ord_trans h₁ h₂) + +theorem OrderR.ordNR (n) {x y : α} : x ≼ₒ* y → x ≼ₒ*{n} y + | .inl e => .inl (e ▸ .rfl) + | .inr h => .inr (ordN_of_ord n h) + +end Ordered + +/-- Reflexivity of the order: the order law of unital algebras (`UORA`), also enjoyed by +total algebras under their extension inclusion. -/ +class OrderRefl (α : Type _) [OFE α] [Ordered α] : Prop where + ord_refl (x : α) : x ≼ₒ x + +/-- An element `x` is increasing if composing with it never shrinks a resource. Cores and units +are increasing; in an affine algebra every element is. -/ +class Increasing {α : Type _} [OFE α] [Op α] [Ordered α] (x : α) : Prop where + increasing (y : α) : y ≼ₒ x • y + +/-- The step-indexed extension inclusion: `y` is `x` composed with some frame. This is the +inclusion of classical resource algebras. -/ +def IncludedN {α : Type _} [OFE α] [Op α] (n : Nat) (x y : α) : Prop := ∃ z : α, y ≡{n}≡ x • z +@[inherit_doc] notation:50 x " ≼{" n "} " y:51 => IncludedN n x y + +/-- The extension inclusion: `y` is `x` composed with some frame. -/ +def Included {α : Type _} [OFE α] [Op α] (x y : α) : Prop := ∃ z : α, y = x • z +@[inherit_doc] infix:50 " ≼ " => Included + +/-- The extension inclusion is contained in the order: every element is increasing. -/ +class IncOrd (α : Type _) [OFE α] [Op α] [Ordered α] : Prop where + inc_ord {x y : α} : x ≼ y → x ≼ₒ y + +/-- An algebra is affine when extension inclusion implies its resource order. -/ +@[reducible] def ORA.Affine (α : Type _) [OFE α] [Op α] [Ordered α] : Prop := IncOrd α + +/-- The order is contained in the extension inclusion: every ordered pair has a frame. -/ +class OrdInc (α : Type _) [OFE α] [Op α] [Ordered α] : Prop where + ord_inc {x y : α} : x ≼ₒ y → x ≼ y + ordN_incN {n} {x y : α} : x ≼ₒ{n} y → x ≼{n} y + +/-- The order is the extension inclusion. -/ +class IsInc (α : Type _) [OFE α] [Op α] [Ordered α] : Prop extends IncOrd α, OrdInc α + +section +variable {α : Type _} [OFE α] [Op α] [Ordered α] + +theorem IncOrd.increasing [IncOrd α] (x : α) : Increasing x := + ⟨fun _ => IncOrd.inc_ord ⟨x, Op.comm⟩⟩ + +theorem IncOrd.of_increasing (h : ∀ x : α, Increasing x) : IncOrd α where + inc_ord {x _} := fun ⟨z, e⟩ => by subst e; rw [Op.comm]; exact (h z).increasing x + +instance instIncreasingOfIncOrd [IncOrd α] (x : α) : Increasing x := IncOrd.increasing x + +theorem inc_iff_ord [IncOrd α] [OrdInc α] {x y : α} : x ≼ y ↔ x ≼ₒ y := + ⟨IncOrd.inc_ord, OrdInc.ord_inc⟩ + +theorem IncOrd.incN_ordN [IncOrd α] {n} {x y : α} : x ≼{n} y → x ≼ₒ{n} y + | ⟨z, hz⟩ => Ordered.ordN_ne .rfl hz.symm (Ordered.ordN_of_ord n (IncOrd.inc_ord ⟨z, rfl⟩)) + +theorem incN_iff_ordN [IncOrd α] [OrdInc α] {n} {x y : α} : x ≼{n} y ↔ x ≼ₒ{n} y := + ⟨IncOrd.incN_ordN, OrdInc.ordN_incN⟩ + +end + +/-! ## Order-free theory -/ + +namespace ORA +variable [OFE α] [Op α] + +export Op (op optionalOp op_ne assoc comm) +export PCore (pcore pcore_ne pcore_idem core) +export Validity (Valid ValidN validN_ne valid_iff_validN validN_succ) +export IsTotal (total) + +/-! ## Op -/ +theorem comm' {x y : α} : x • y = y • x := comm + +theorem assoc' {x y z : α} : x • (y • z) = (x • y) • z := assoc + +theorem op_right_dist (x : α) {y z : α} (e : y ≡{n}≡ z) : x • y ≡{n}≡ x • z := + op_ne.ne e +theorem _root_.Iris.OFE.Dist.op_r {x y z : α} : y ≡{n}≡ z → x • y ≡{n}≡ x • z := op_right_dist _ + +theorem op_commN {x y : α} : x • y ≡{n}≡ y • x := Dist.of_eq comm + +theorem op_assocN {x y z : α} : x • (y • z) ≡{n}≡ (x • y) • z := Dist.of_eq assoc + +theorem op_left_dist {x y : α} (z : α) (e : x ≡{n}≡ y) : x • z ≡{n}≡ y • z := + op_commN.trans <| e.op_r.trans op_commN +theorem _root_.Iris.OFE.Dist.op_l {x y z : α} : x ≡{n}≡ y → x • z ≡{n}≡ y • z := op_left_dist _ + +theorem _root_.Iris.OFE.Dist.op {x x' y y' : α} + (ex : x ≡{n}≡ x') (ey : y ≡{n}≡ y') : x • y ≡{n}≡ x' • y' := ex.op_l.trans ey.op_r + +theorem _root_.Iris.OFE.Dist.opM {x₁ x₂ : α} {y₁ y₂ : Option α} + (H1 : x₁ ≡{n}≡ x₂) (H2 : y₁ ≡{n}≡ y₂) : x₁ •? y₁ ≡{n}≡ x₂ •? y₂ := + match y₁, y₂, H2 with + | none, none, _ => H1 + | some _, some _, H2 => H1.op H2 + +theorem opM_left_dist {n} {x y : α} (z : Option α) (e : x ≡{n}≡ y) : x •? z ≡{n}≡ y •? z := + e.opM Dist.rfl +theorem opM_right_dist {n} (x : α) {y z : Option α} (e : y ≡{n}≡ z) : x •? y ≡{n}≡ x •? z := + Dist.rfl.opM e + +theorem op_opM_assoc (x y : α) (mz : Option α) : (x • y) •? mz = x • (y •? mz) := by + unfold optionalOp; cases mz <;> simp [assoc] + +theorem op_opM_assoc_dist (x y : α) (mz : Option α) : (x • y) •? mz ≡{n}≡ x • (y •? mz) := by + unfold optionalOp; cases mz <;> simp [op_assocN, Dist.symm] + +theorem incN_ne {n} {x x' y y' : α} (ex : x ≡{n}≡ x') (ey : y ≡{n}≡ y') : + x ≼{n} y → x' ≼{n} y' + | ⟨z, hz⟩ => ⟨z, ey.symm.trans (hz.trans ex.op_l)⟩ + +theorem incN_of_incN_of_dist (h : (a : α) ≼{n} b) (e : b ≡{n}≡ c) : a ≼{n} c := incN_ne .rfl e h + +instance {n : Nat} : Trans (IncludedN (α := α) n) (Dist n) (IncludedN n) where + trans := incN_of_incN_of_dist + +theorem incN_of_dist_of_incN (e : (a : α) ≡{n}≡ b) (h : b ≼{n} c) : a ≼{n} c := + incN_ne e.symm .rfl h + +instance {n : Nat} : Trans (Dist (α := α) n) (IncludedN n) (IncludedN n) where + trans := incN_of_dist_of_incN + +theorem incN_of_inc (n) {x y : α} : x ≼ y → x ≼{n} y + | ⟨z, hz⟩ => ⟨z, hz.dist⟩ + +theorem incN_iff_left (e : (a : α) ≡{n}≡ b) : a ≼{n} c ↔ b ≼{n} c := + ⟨incN_ne e .rfl, incN_ne e.symm .rfl⟩ +theorem _root_.Iris.OFE.Dist.incN_l : (a : α) ≡{n}≡ b → (a ≼{n} c ↔ b ≼{n} c) := incN_iff_left + +theorem incN_iff_right (e : (b : α) ≡{n}≡ c) : a ≼{n} b ↔ a ≼{n} c := + ⟨incN_ne .rfl e, incN_ne .rfl e.symm⟩ +theorem _root_.Iris.OFE.Dist.incN_r : (b : α) ≡{n}≡ c → (a ≼{n} b ↔ a ≼{n} c) := incN_iff_right + +theorem incN_dist_iff (ea : (a : α) ≡{n}≡ a') (eb : (b : α) ≡{n}≡ b') : + a ≼{n} b ↔ a' ≼{n} b' := + ⟨incN_ne ea eb, incN_ne ea.symm eb.symm⟩ +theorem _root_.Iris.OFE.Dist.incN : + (a : α) ≡{n}≡ a' → b ≡{n}≡ b' → (a ≼{n} b ↔ a' ≼{n} b') := + incN_dist_iff + +theorem inc_trans {x y z : α} : x ≼ y → y ≼ z → x ≼ z + | ⟨w, hw⟩, ⟨t, ht⟩ => ⟨w • t, ht.trans (hw ▸ assoc.symm)⟩ + +instance : Trans (Included (α := α)) Included Included where + trans := inc_trans + +theorem incN_trans {x y z : α} : x ≼{n} y → y ≼{n} z → x ≼{n} z + | ⟨w, hw⟩, ⟨t, ht⟩ => ⟨w • t, ht.trans (hw.op_l.trans op_assocN.symm)⟩ + +instance : Trans (IncludedN (α := α) n) (IncludedN n) (IncludedN n) where + trans := incN_trans + +theorem incN_of_incN_le {n n'} {x y : α} (l1 : n' ≤ n) : x ≼{n} y → x ≼{n'} y + | ⟨z, hz⟩ => ⟨z, Dist.le hz l1⟩ +theorem inc0_of_incN {n} {x y : α} : x ≼{n} y → x ≼{0} y := incN_of_incN_le (Nat.zero_le n) + +theorem incN_of_incN_succ {n} {x y : α} : x ≼{n.succ} y → x ≼{n} y := + incN_of_incN_le (Nat.le_succ n) + +theorem incN_op_left (n) (x y : α) : x ≼{n} x • y := ⟨y, Dist.rfl⟩ + +theorem inc_op_left (x y : α) : x ≼ x • y := ⟨y, rfl⟩ + +theorem inc_op_right (x y : α) : y ≼ x • y := ⟨x, comm⟩ + +theorem incN_op_right (n) (x y : α) : y ≼{n} x • y := ⟨x, op_commN⟩ + +theorem op_mono_right {x y} (z : α) : x ≼ y → z • x ≼ z • y + | ⟨w, hw⟩ => ⟨w, (congrArg (z • ·) hw).trans assoc⟩ + +theorem op_monoN_right {n x y} (z : α) : x ≼{n} y → z • x ≼{n} z • y + | ⟨w, hw⟩ => ⟨w, hw.op_r.trans op_assocN⟩ + +theorem op_monoN_left {n x y} (z : α) (h : x ≼{n} y) : x • z ≼{n} y • z := + (op_commN.incN op_commN).1 (op_monoN_right z h) + +theorem op_mono_left {x y} (z : α) (h : x ≼ y) : x • z ≼ y • z := by + rw [comm' (x := x) (y := z), comm' (x := y) (y := z)]; exact op_mono_right z h + +theorem op_monoN {n} {x x' y y' : α} (hx : x ≼{n} x') (hy : y ≼{n} y') : + x • y ≼{n} x' • y' := + incN_trans (op_monoN_left _ hx) (op_monoN_right _ hy) + +theorem op_mono {x x' y y' : α} (hx : x ≼ x') (hy : y ≼ y') : + x • y ≼ x' • y' := + inc_trans (op_mono_left _ hx) (op_mono_right _ hy) + +/-- Equip a resource operation with its extension-inclusion order. -/ +@[reducible] def extOrdered : Ordered α where + OrderN := IncludedN + Order := Included + ordN_ne := incN_ne + ordN_succ := incN_of_incN_succ + ordN_trans := incN_trans + ord_trans := inc_trans + ordN_of_ord n h := incN_of_inc n h + +section pcore +variable [PCore α] + +instance : NonExpansive (pcore (α := α)) where + ne n x {y} e := by + suffices ∀ ox oy, pcore x = ox → pcore y = oy → pcore x ≡{n}≡ pcore y from + this (pcore x) (pcore y) rfl rfl + intro ox oy ex ey + match ox, oy with + | .some a, .some b => + let ⟨w, hw, ew⟩ := pcore_ne e ex + calc + pcore x ≡{n}≡ some a := .of_eq ex + _ ≡{n}≡ some w := ew + _ ≡{n}≡ pcore y := .of_eq hw.symm + | .some a, .none => + let ⟨w, hw, ew⟩ := pcore_ne e ex + cases hw.symm ▸ ey + | .none, .some b => + let ⟨w, hw, ew⟩ := pcore_ne e.symm ey + cases hw.symm ▸ ex + | .none, .none => rw [ex, ey] + +section total +variable [IsTotal α] + +omit [Op α] in +theorem pcore_eq_core (x : α) : pcore x = some (core x) := by + unfold core + have ⟨cx, hcx⟩ := IsTotal.total x + simp [hcx] + +end total +end pcore + +end ORA + +/-! ## Ordered resource algebras -/ + +/-- An ordered resource algebra: composition, core and validity together with the laws relating +them, and a step-indexed order that they respect. The order is neither required to be reflexive +(`OrderRefl`) nor to contain the extension inclusion (`IncOrd`). -/ +class ORA (α : Type _) extends OFE α, Op α, PCore α, Validity α, Ordered α where + validN_op_left {n} {x y : α} : ✓{n} (x • y) → ✓{n} x + pcore_op_left {x cx : α} : pcore x = some cx → cx • x = x + /-- Split a valid resource into factors matching an approximate decomposition. -/ + extend {n} {x y₁ y₂ : α} : ✓{n} x → x ≡{n}≡ y₁ • y₂ → + Σ' z₁ z₂ : α, x = z₁ • z₂ ∧ z₁ ≡{n}≡ y₁ ∧ z₂ ≡{n}≡ y₂ + op_monoN_left_ord {n} {x y : α} (z : α) : x ≼ₒ{n} y → x • z ≼ₒ{n} y • z + op_mono_left_ord {x y : α} (z : α) : x ≼ₒ y → x • z ≼ₒ y • z + validN_of_ordN {n} {x y : α} : x ≼ₒ{n} y → ✓{n} y → ✓{n} x + pcore_monoN_ord {n} {x y cx : α} : x ≼ₒ{n} y → pcore x = some cx → + ∃ cy, pcore y = some cy ∧ cx ≼ₒ{n} cy + pcore_mono_ord {x y cx : α} : x ≼ₒ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx ≼ₒ cy + pcore_order_op {x cx : α} : pcore x = some cx → ∀ y, ∃ cxy, pcore (x • y) = some cxy ∧ cx ≼ₒ cxy + pcore_increasing {x cx : α} : pcore x = some cx → Increasing cx + increasing_closed {n} {x y : α} : Increasing x → x ≼ₒ*{n} y → Increasing y + ordN_extend {n} {x y : α} : ✓{n} y → x ≼ₒ{n} y → ∃ z, z ≼ₒ{n.succ} y ∧ z ≡{n}≡ x + +namespace ORA +variable [ORA α] + +/-- A resource equal to its own partial core. -/ +class CoreId (x : α) where + core_id : pcore x = some x +export CoreId (core_id) + +/-- A resource that cannot be composed validly with any further resource. -/ +class Exclusive (x : α) where + exclusive0_l y : ¬✓{0} x • y +export Exclusive (exclusive0_l) + +/-- A resource cancellable from valid compositions at each step index. -/ +class Cancelable (x : α) where + cancelableN : ✓{n} x • y → x • y ≡{n}≡ x • z → y ≡{n}≡ z +export Cancelable (cancelableN) + +/-- A valid resource that cannot absorb a right factor at index zero. -/ +class IdFree (x : α) where + id_free0_r y : ✓{0} x → ¬x • y ≡{0}≡ x +export IdFree (id_free0_r) + +theorem pcore_l {x cx : α} (e : pcore x = some cx) : cx • x = x := pcore_op_left e + +theorem pcore_idemp {x cx : α} (e : pcore x = some cx) : pcore cx = some cx := pcore_idem e + +/-- A dependent-pair form of the resource decomposition operation. -/ +def extend' {n} {x y₁ y₂ : α} (v : ✓{n} x) (e : x ≡{n}≡ y₁ • y₂) : + Σ' z₁ z₂, x = (z₁ • z₂ : α) ∧ z₁ ≡{n}≡ y₁ ∧ z₂ ≡{n}≡ y₂ := + let ⟨z₁, z₂, hx, hz, hw⟩ := extend (y₁ := y₁) (y₂ := y₂) v e + ⟨z₁, z₂, hx, hz, hw⟩ + +theorem validN_op_l {n} {x y : α} : ✓{n} (x • y) → ✓{n} x := validN_op_left + +theorem valid_validN {x : α} : ✓ x ↔ ∀ n, ✓{n} x := valid_iff_validN + +theorem op_ne' {x : α} : NonExpansive (x • ·) := op_ne + +theorem pcore_ne' {n} {x y : α} {cx} (h : x ≡{n}≡ y) (e : pcore x = some cx) : + ∃ cy, pcore y = some cy ∧ cx ≡{n}≡ cy := pcore_ne h e + +theorem validN_ne' {n} {x y : α} (h : x ≡{n}≡ y) : ✓{n} x → ✓{n} y := validN_ne h + +theorem opM_ne_right {n} {x : α} {y₁ y₂ : Option α} (h : y₁ ≡{n}≡ y₂) : x •? y₁ ≡{n}≡ x •? y₂ := + match y₁, y₂, h with + | none, none, _ => .rfl + | some _, some _, h => op_ne.ne h + +instance : NonExpansive₂ (optionalOp (α := α)) where + ne _ x₁ _ e₁ y₁ y₂ e₂ := match y₁, y₂, e₂ with + | none, none, _ => e₁ + | some _, some y₂, e₂ => + ((op_ne (x := x₁)).ne e₂).trans (Dist.of_eq comm |>.trans <| + ((op_ne (x := y₂)).ne e₁).trans (Dist.of_eq comm)) + +/-! ## Validity -/ + +theorem _root_.Iris.Validity.Valid.validN : ✓ (x : α) → ✓{n} x := (valid_iff_validN.1 · _) +protected theorem Valid.validN : ✓ (x : α) → ✓{n} x := Iris.Validity.Valid.validN + +theorem valid_mapN {x y : α} (f : ∀ n, ✓{n} x → ✓{n} y) (v : ✓ x) : ✓ y := + valid_iff_validN.mpr fun n => f n v.validN + +theorem validN_dist_iff {x y : α} (e : x ≡{n}≡ y) : ✓{n} x ↔ ✓{n} y := + ⟨validN_ne e, validN_ne e.symm⟩ +theorem _root_.Iris.OFE.Dist.validN : (x : α) ≡{n}≡ y → (✓{n} x ↔ ✓{n} y) := validN_dist_iff + +theorem validN_of_le {n n'} {x : α} (le : n' ≤ n) : ✓{n} x → ✓{n'} x := + le.recOn id fun _ ih vs => ih (validN_succ vs) + +theorem validN_of_lt {n n'} {x : α} (lt : n' < n) : ✓{n} x → ✓{n'} x := + validN_of_le (Nat.le_of_lt lt) + +theorem valid0_of_validN {n} {x : α} : ✓{n} x → ✓{0} x := validN_of_le (Nat.zero_le n) + +theorem validN_op_right {n} {x y : α} : ✓{n} (x • y) → ✓{n} y := + fun v => validN_op_left (comm' (x := x) (y := y) ▸ v) + +theorem valid_op_right (x y : α) : ✓ (x • y) → ✓ y := valid_mapN fun _ => validN_op_right + +theorem valid_op_left {x y : α} : ✓ (x • y) → ✓ x := + fun v => valid_op_right y x (comm' (x := x) (y := y) ▸ v) + +theorem validN_opM {x : α} {my : Option α} : ✓{n} (x •? my) → ✓{n} x := match my with + | none => id | some _ => validN_op_left + +theorem valid_opM {x : α} {my : Option α} : ✓ (x •? my) → ✓ x := match my with + | none => id | some _ => valid_op_left + +theorem validN_op_opM_left {mz : Option α} : ✓{n} (x • y : α) •? mz → ✓{n} x •? mz := match mz with + | .none => validN_op_left + | .some z => fun h => + have := calc + (x • y) • z ≡{n}≡ x • (y • z) := op_assocN.symm + _ ≡{n}≡ x • (z • y) := op_right_dist x op_commN + _ ≡{n}≡ (x • z) • y := op_assocN + validN_op_left ((Dist.validN this).mp h) + +theorem validN_op_opM_right {mz : Option α} (h : ✓{n} (x • y : α) •? mz) : ✓{n} y •? mz := + validN_op_opM_left (validN_ne (opM_left_dist mz op_commN) h) + +/-! ## Core -/ +instance cmra_op_ne2 : NonExpansive₂ (op (α := α)) where + ne _ _ _ e₁ _ _ e₂ := e₁.op e₂ + +theorem pcore_op_left' {x : α} {cx} (e : pcore x = some cx) : cx • x = x := pcore_l e + +theorem pcore_op_right {x : α} {cx} (e : pcore x = some cx) : x • cx = x := comm'.trans (pcore_l e) + +theorem pcore_op_right' {x : α} {cx} (e : pcore x = some cx) : x • cx = x := pcore_op_right e + +theorem pcore_idem' {x : α} {cx} (e : pcore x = some cx) : pcore cx = some cx := pcore_idemp e + +theorem pcore_op_self {x : α} {cx} (e : pcore x = some cx) : cx • cx = cx := + pcore_op_right' (pcore_idem e) + +theorem pcore_op_self' {x : α} {cx} (e : pcore x = some cx) : cx • cx = cx := pcore_op_self e + +theorem pcore_validN {n} {x : α} {cx} (e : pcore x = some cx) (v : ✓{n} x) : ✓{n} cx := + validN_op_right ((pcore_op_right e).symm ▸ v) + +theorem pcore_valid {x : α} {cx} (e : pcore x = some cx) : ✓ x → ✓ cx := + valid_mapN fun _ => pcore_validN e + +theorem op_self (x : α) [CoreId x] : x • x = x := pcore_op_self' CoreId.core_id + +theorem CoreId.of_pcore_eq_some {x y : α} (e : pcore x = some y) : CoreId y where + core_id := pcore_idem e + +/-! ## Exclusive elements -/ +theorem not_valid_exclN_op_left {n} {x : α} [Exclusive x] {y} : ¬✓{n} (x • y) := + n.recOn (Exclusive.exclusive0_l _) fun _ ih => ih ∘ validN_succ + +theorem not_valid_exclN_op_right {n} {x : α} [Exclusive x] {y} : ¬✓{n} (y • x) := + fun v => not_valid_exclN_op_left (comm' (x := y) (y := x) ▸ v) + +theorem not_valid_excl_op_left {x : α} [Exclusive x] {y} : ¬✓ (x • y) := + fun v => Exclusive.exclusive0_l _ v.validN + +theorem not_excl_op_right {x : α} [Exclusive x] {y} : ¬✓ (y • x) := + fun v => not_valid_excl_op_left (comm' (x := y) (y := x) ▸ v) + +theorem none_of_excl_valid_op {n} {x : α} [Exclusive x] {my} : ✓{n} (x •? my) → my = none := by + cases my <;> simp [optionalOp, not_valid_exclN_op_left] + +/-! ## Total cores -/ + +section total +variable [IsTotal α] + +theorem op_core (x : α) : x • core x = x := pcore_op_right (pcore_eq_core x) + +theorem core_op (x : α) : core x • x = x := comm'.trans (op_core x) + +theorem op_core_dist (x : α) : x • core x ≡{n}≡ x := Dist.of_eq (op_core x) +theorem core_op_dist (x : α) : core x • x ≡{n}≡ x := Dist.of_eq (core_op x) + +theorem core_op_core {x : α} : core x • core x = core x := pcore_op_self (pcore_eq_core x) + +theorem validN_core {n} {x : α} (v : ✓{n} x) : ✓{n} core x := pcore_validN (pcore_eq_core x) v + +theorem valid_core {x : α} (v : ✓ x) : ✓ core x := pcore_valid (pcore_eq_core x) v + +instance (y : α) : CoreId (core y) := CoreId.of_pcore_eq_some (pcore_eq_core _) + +theorem core_ne : NonExpansive (core : α → α) where + ne n x₁ x₂ H := by + change some (core x₁) ≡{n}≡ some (core x₂) + rw [← pcore_eq_core, ← pcore_eq_core] + exact NonExpansive.ne H + +theorem _root_.Iris.OFE.Dist.core : + ∀ {n} {x₁ x₂ : α}, x₁ ≡{n}≡ x₂ → core x₁ ≡{n}≡ core x₂ := @core_ne.ne + +theorem core_eqv_self (x : α) [CoreId x] : core (x : α) = x := + Option.some.inj ((pcore_eq_core x).symm.trans CoreId.core_id) + +theorem coreId_iff_core_eqv_self : CoreId (x : α) ↔ core x = x := + ⟨fun _ => core_eqv_self x, fun e => { core_id := (pcore_eq_core x).trans (congrArg some e) }⟩ + +theorem core_idem (x : α) : core (core x) = core x := core_eqv_self _ + +instance instOrderReflOfIsTotal : OrderRefl α where + ord_refl x := + (congrArg (x ≼ₒ ·) (core_op x)).mp ((pcore_increasing (pcore_eq_core x)).increasing x) + +end total + +/-! ## Discrete elements -/ +theorem discrete_op {x y : α} (Hv : ✓{0} x • y) [Hx : DiscreteE x] [Hy : DiscreteE y] : + DiscreteE (x • y) where + discrete h := by + obtain ⟨_w, _t, wt, wx, ty⟩ := extend ((Dist.validN h).mp Hv) h.symm + rw [Hx.discrete wx.symm, Hy.discrete ty.symm, wt] + +end ORA + +namespace ORA +export Ordered (OrderN Order ordN_ne ordN_succ ordN_trans ord_trans ordN_of_ord) +export OrderRefl (ord_refl) +end ORA + +/-! ## The extension inclusion -/ + +namespace ORA + +variable [ORA α] + +theorem valid_of_inc {x y : α} : x ≼ y → ✓ y → ✓ x + | ⟨_, hz⟩, v => valid_op_left (hz ▸ v) + +theorem validN_of_incN {n} {x y : α} : x ≼{n} y → ✓{n} y → ✓{n} x + | ⟨_, hz⟩, v => validN_op_left (validN_ne hz v) + +theorem validN_of_inc {n} {x y : α} : x ≼ y → ✓{n} y → ✓{n} x + | ⟨_, hz⟩, v => validN_op_left (validN_ne hz.dist v) + +theorem pcore_inc_self {x : α} {cx} (e : pcore x = some cx) : cx ≼ x := ⟨x, (pcore_op_left e).symm⟩ + +theorem op_core_right_of_inc {x y : α} [CoreId x] : x ≼ y → x • y = y + | ⟨z, hz⟩ => hz ▸ assoc'.trans (congrArg (· • z) (op_self x)) + +theorem op_core_left_of_inc {x y : α} [CoreId x] (le : x ≼ y) : y • x = y := + comm'.trans (op_core_right_of_inc le) + +theorem included_dist_l {n} {x1 x2 x1' : α} : + x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2 + | ⟨y, hy⟩, e => ⟨x1' • y, inc_op_left x1' y, e.op_l.trans hy.symm.dist⟩ + +theorem not_valid_of_exclN_inc {n} {x : α} [Exclusive x] {y} : x ≼{n} y → ¬✓{n} y + | ⟨_, hz⟩, v => not_valid_exclN_op_left (validN_ne hz v) + +theorem not_valid_of_excl_inc {x : α} [Exclusive x] {y} : x ≼ y → ¬✓ y + | ⟨_, hz⟩, v => Exclusive.exclusive0_l _ <| hz ▸ v.validN + +theorem incN_extend {n} {x y : α} (v : ✓{n} y) : + x ≼{n} y → ∃ z, z ≼{n.succ} y ∧ z ≡{n}≡ x + | ⟨_, hw⟩ => + let ⟨z₁, z₂, hy, hz₁, _⟩ := extend v hw + ⟨z₁, ⟨z₂, hy.dist⟩, hz₁⟩ + +theorem incN_map {β : Type _} [ORA β] (f : α → β) [NonExpansive f] + (hop : ∀ x y, f (x • y) = f x • f y) {n} {x y : α} : x ≼{n} y → f x ≼{n} f y + | ⟨z, hz⟩ => ⟨f z, (NonExpansive.ne hz).trans (hop x z).dist⟩ + +theorem inc_map {β : Type _} [ORA β] (f : α → β) + (hop : ∀ x y, f (x • y) = f x • f y) {x y : α} : x ≼ y → f x ≼ f y + | ⟨z, hz⟩ => ⟨f z, (congrArg f hz).trans (hop x z)⟩ + +section total +variable [IsTotal α] + +theorem inc_refl (x : α) : x ≼ x := ⟨core x, (op_core x).symm⟩ + +theorem incN_refl (x : α) : x ≼{n} x := incN_of_inc _ (inc_refl _) + +theorem incN_of_dist {n} {x y : α} (h : x ≡{n}≡ y) : x ≼{n} y := incN_ne .rfl h (incN_refl x) +theorem _root_.Iris.OFE.Dist.to_incN {n} {x y : α} : x ≡{n}≡ y → x ≼{n} y := incN_of_dist + +theorem core_inc_self {x : α} : core x ≼ x := ⟨x, (core_op x).symm⟩ + +end total + +section discrete + +theorem inc_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼ y ↔ x ≼{n} y := + ⟨incN_of_inc _, fun ⟨z, hz⟩ => ⟨z, discrete hz⟩⟩ + +theorem inc_0_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼{0} y ↔ x ≼{n} y := + ⟨fun ⟨z, hz⟩ => ⟨z, (discrete hz).dist⟩, inc0_of_incN⟩ + +theorem inc_of_inc0 [OFE.Discrete α] {x y : α} : x ≼{0} y → x ≼ y := (inc_iff_incN 0).mpr + +theorem discrete_inc_l {x y : α} [HD : DiscreteE x] (Hv : ✓{0} y) (Hle : x ≼{0} y) : + x ≼ y := + have ⟨_, hz⟩ := Hle + let ⟨_, t, wt, wx, _⟩ := extend Hv hz + ⟨t, wt.trans (congrArg (· • t) (HD.discrete wx.symm).symm)⟩ + +theorem discrete_inc_r {x y : α} [HD : DiscreteE y] : x ≼{0} y → x ≼ y + | ⟨z, hz⟩ => ⟨z, HD.discrete hz⟩ + +end discrete + +end ORA + +/-- A classical resource algebra: composition, core and validity together with the laws +relating them, and the monotonicity of the partial core along frames. It is not itself an +ordered resource algebra; `ORA.ofCMRAData` makes one of it, taking the order to be the extension +inclusion. -/ +class CMRAData (α : Type _) [OFE α] extends Op α, PCore α, Validity α where + validN_op_left {n} {x y : α} : ✓{n} (x • y) → ✓{n} x + pcore_op_left {x cx : α} : pcore x = some cx → cx • x = x + /-- Decompose a valid classical resource along an approximate composition. -/ + extend {n} {x y₁ y₂ : α} : ✓{n} x → x ≡{n}≡ y₁ • y₂ → + Σ' z₁ z₂ : α, x = z₁ • z₂ ∧ z₁ ≡{n}≡ y₁ ∧ z₂ ≡{n}≡ y₂ + pcore_op_mono {x cx : α} : pcore x = some cx → ∀ y, ∃ cy : α, pcore (x • y) = some (cx • cy) + +namespace CMRAData +open ORA + +/-- The frame law follows from monotonicity of the partial core along the extension inclusion, +the form of the law in Iris-Rocq (`cmra_pcore_mono`). -/ +theorem pcore_op_mono_of_pcore_mono [OFE α] [Op α] [PCore α] + (h : ∀ {x y cx : α}, x ≼ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx ≼ cy) + {x cx : α} (e : pcore x = some cx) (y) : ∃ cy : α, pcore (x • y) = some (cx • cy) := + let ⟨_, hcy, z, hz⟩ := h (inc_op_left _ y) e + ⟨z, hcy.trans (congrArg some hz)⟩ + +theorem pcore_op_mono_of_core_mono [OFE α] [Op α] [PCore α] [IsTotal α] + (h : ∀ x y : α, x ≼ y → core x ≼ core y) + {x cx : α} (e : pcore x = some cx) (y) : ∃ cy : α, pcore (x • y) = some (cx • cy) := + pcore_op_mono_of_pcore_mono (fun {x y cx} hxy e => + have hcx : cx = core x := Option.some.inj (e.symm.trans (pcore_eq_core x)) + ⟨core y, pcore_eq_core y, hcx ▸ h x y hxy⟩) e y + +variable [OFE α] [CMRAData α] + +theorem validN_of_incN {n} {x y : α} : x ≼{n} y → ✓{n} y → ✓{n} x + | ⟨_, hz⟩, v => validN_op_left (validN_ne hz v) + +theorem incN_extend {n} {x y : α} (v : ✓{n} y) : + x ≼{n} y → ∃ z, z ≼{n.succ} y ∧ z ≡{n}≡ x + | ⟨_, hw⟩ => + let ⟨z₁, z₂, hy, hz₁, _⟩ := extend v hw + ⟨z₁, ⟨z₂, hy.dist⟩, hz₁⟩ + +theorem pcore_mono {x y cx : α} : + x ≼ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx ≼ cy + | ⟨_, hw⟩, e => + have ⟨z, hz⟩ := pcore_op_mono e _ + let ⟨t, ht, et⟩ := OFE.equiv_some ((congrArg pcore hw).trans hz) + ⟨t, ht, z, et⟩ + +theorem pcore_mono' {x y : α} {cx} (le : x ≼ y) (e : pcore x = some cx) : + ∃ cy, pcore y = some cy ∧ cx ≼ cy := + pcore_mono le e + +theorem pcore_monoN' {n} {x y : α} {cx} : + x ≼{n} y → pcore x ≡{n}≡ some cx → ∃ cy, pcore y = some cy ∧ cx ≼{n} cy + | ⟨z, hz⟩, e => + let ⟨_, hw, ew⟩ := OFE.dist_some e + let ⟨t, ht⟩ := pcore_op_mono hw z + let ⟨r, hr, er⟩ := PCore.pcore_ne hz.symm ht + ⟨r, hr, incN_ne ew.symm er (incN_op_left n _ t)⟩ + +theorem pcore_monoN {n} {x y : α} {cx} (h : x ≼{n} y) (e : pcore x = some cx) : + ∃ cy, pcore y = some cy ∧ cx ≼{n} cy := + pcore_monoN' h (Dist.of_eq e) + +section total +variable [IsTotal α] + +theorem core_incN_core {n} {x y : α} (le : x ≼{n} y) : core x ≼{n} core y := + let ⟨_, hcy, icy⟩ := pcore_monoN' le (Dist.of_eq (pcore_eq_core x)) + Option.some.inj ((pcore_eq_core y).symm.trans hcy) ▸ icy + +theorem core_op_mono (x y : α) : core x ≼ core (x • y) := by + have ⟨cy, hcy⟩ := pcore_op_mono (pcore_eq_core x) y + simp only [pcore_eq_core, Option.some.injEq] at hcy + exact ⟨_, hcy⟩ + +theorem core_mono {x y : α} (Hinc : x ≼ y) : core x ≼ core y := by + have ⟨z, hz⟩ := Hinc + rw [hz]; exact core_op_mono x z + +theorem inc_refl (x : α) : x ≼ x := ⟨core x, (Op.comm.trans (pcore_op_left (pcore_eq_core x))).symm⟩ + +end total + +section extOrder +attribute [local instance] extOrdered + +theorem increasing (x : α) : Increasing x where + increasing y := inc_op_right x y + +instance instOrderRefl [IsTotal α] : OrderRefl α where + ord_refl := inc_refl + +/-- Give classical resource algebra data its extension-inclusion order. -/ +@[reducible] def toORA : ORA α where + toOrdered := extOrdered + validN_op_left := validN_op_left + pcore_op_left := pcore_op_left + extend := extend + op_monoN_left_ord := op_monoN_left + op_mono_left_ord := op_mono_left + validN_of_ordN := validN_of_incN + pcore_monoN_ord := pcore_monoN + pcore_mono_ord := pcore_mono + pcore_order_op {_ cx} e y := + let ⟨cy, hcy⟩ := pcore_op_mono e y + ⟨cx • cy, hcy, inc_op_left cx cy⟩ + pcore_increasing _ := increasing _ + increasing_closed _ _ := increasing _ + ordN_extend := incN_extend + +theorem isInc : @IsInc α _ _ (toORA (α := α)).toOrdered := + { inc_ord := id, ord_inc := id, ordN_incN := id } + +end extOrder + +end CMRAData + +/-- An ordered resource algebra whose order is exactly extension inclusion. -/ +class CMRA (α : Type _) extends ORA α, IsInc α + +instance (priority := low) CMRA.ofIsInc [ORA α] [IsInc α] : CMRA α := {} + +/-- Construct a classical ordered resource algebra from its operation and core. -/ +@[reducible] def ORA.ofCMRAData [OFE α] (d : CMRAData α) : CMRA α := + { toORA := @CMRAData.toORA α _ d, toIsInc := @CMRAData.isInc α _ d } + +namespace CMRA +open ORA +variable [CMRA α] + +theorem ord_of_ord0 [OFE.Discrete α] {x y : α} (h : x ≼ₒ{0} y) : x ≼ₒ y := + inc_iff_ord.mp (inc_of_inc0 (incN_iff_ordN.mpr h)) + +end CMRA + +section +open ORA +variable [OFE α] [Op α] + +theorem Included.incN {n} {x y : α} : x ≼ y → x ≼{n} y := incN_of_inc _ +theorem Included.trans : (x : α) ≼ y → y ≼ z → x ≼ z := inc_trans +theorem IncludedN.trans : (x : α) ≼{n} y → y ≼{n} z → x ≼{n} z := incN_trans +theorem IncludedN.le {n n'} {x y : α} : n' ≤ n → x ≼{n} y → x ≼{n'} y := incN_of_incN_le +theorem IncludedN.succ {n} {x y : α} : x ≼{n.succ} y → x ≼{n} y := incN_of_incN_succ + +end + +section +open ORA +variable [ORA α] + +theorem Included.validN {n} {x y : α} : x ≼ y → ✓{n} y → ✓{n} x := validN_of_inc +theorem IncludedN.validN {n} {x y : α} : x ≼{n} y → ✓{n} y → ✓{n} x := validN_of_incN + +variable [IsTotal α] + +@[refl] theorem Included.rfl {x : α} : x ≼ x := inc_refl x +@[refl] theorem IncludedN.rfl {x : α} : x ≼{n} x := incN_refl x + +end + +/-! ## Discrete and affine algebras -/ + +namespace ORA +variable [ORA α] + +/-- An algebra with discrete equivalence, validity, and resource order. -/ +class Discrete (α : Type _) [ORA α] extends OFE.Discrete α where + discrete_valid {x : α} : ✓{0} x → ✓ x + discrete_ord {x y : α} : x ≼ₒ{0} y → x ≼ₒ y := by + first | exact CMRA.ord_of_ord0 | exact fun ⟨z, hz⟩ => ⟨z, hz⟩ +export Discrete (discrete_valid discrete_ord) + +end ORA + +/-! ## Unital algebras -/ + +/-- A unital ordered resource algebra: an ordered resource algebra with a unit, whose order is +reflexive. -/ +class UORA (α : Type _) extends ORA α, OrderRefl α where + /-- The unit resource. -/ + unit : α + unit_valid : ✓ unit + unit_left_id : unit • x = x + pcore_unit : pcore unit = some unit + +/-- The unit of a classical unital resource algebra; the input of `UORA.ofUCMRAData`. -/ +class UCMRAData (α : Type _) [CMRA α] where + /-- The proposed unit of a classical resource algebra. -/ + unit : α + unit_valid : ✓ unit + unit_left_id : unit • x = x + pcore_unit : ORA.pcore unit = some unit + +/-- A classical resource algebra equipped with a unit. -/ +class UCMRA (α : Type _) extends CMRA α, UORA α + +instance (priority := low) UCMRA.ofIsInc [UORA α] [IsInc α] : UCMRA α := {} + +/-- Add a specified unit to a classical resource algebra. -/ +@[reducible] def UORA.ofUCMRAData [CMRA α] (d : UCMRAData α) : UCMRA α where + unit := d.unit + unit_valid := d.unit_valid + unit_left_id := d.unit_left_id + pcore_unit := d.pcore_unit + ord_refl _ := IncOrd.inc_ord ⟨d.unit, (Op.comm.trans d.unit_left_id).symm⟩ + +/-- The laws asserting that a specified resource is a valid unit with itself as core. -/ +class IsUnit [ORA α] (ε : α) : Prop where + unit_valid : ✓ ε + unit_left_id : ε • x = x + pcore_unit : ORA.pcore ε = some ε + +instance [UORA α] : IsUnit (UORA.unit : α) where + unit_valid := UORA.unit_valid + unit_left_id := UORA.unit_left_id + pcore_unit := UORA.pcore_unit + +namespace ORA + +export UORA (unit unit_valid unit_left_id pcore_unit) + +/-! ## Order -/ + +section orderN +variable [OFE α] [Ordered α] + +theorem ordN_of_ordN_of_dist (h : (a : α) ≼ₒ{n} b) (e : b ≡{n}≡ c) : a ≼ₒ{n} c := ordN_ne .rfl e h + +instance instTransOrderNDist {n : Nat} : Trans (OrderN (α := α) n) (Dist n) (OrderN n) where + trans := ordN_of_ordN_of_dist + +theorem ordN_of_dist_of_ordN (e : (a : α) ≡{n}≡ b) (h : b ≼ₒ{n} c) : a ≼ₒ{n} c := + ordN_ne e.symm .rfl h + +instance {n : Nat} : Trans (Dist (α := α) n) (OrderN n) (OrderN n) where + trans := ordN_of_dist_of_ordN + +theorem _root_.Iris.Ordered.Order.ordN {n} {x y : α} : x ≼ₒ y → x ≼ₒ{n} y := ordN_of_ord _ + +theorem ordN_iff_left (e : (a : α) ≡{n}≡ b) : a ≼ₒ{n} c ↔ b ≼ₒ{n} c := + ⟨ordN_ne e .rfl, ordN_ne e.symm .rfl⟩ +theorem _root_.Iris.OFE.Dist.ordN_l : (a : α) ≡{n}≡ b → (a ≼ₒ{n} c ↔ b ≼ₒ{n} c) := ordN_iff_left + +theorem ordN_iff_right (e : (b : α) ≡{n}≡ c) : a ≼ₒ{n} b ↔ a ≼ₒ{n} c := + ⟨ordN_ne .rfl e, ordN_ne .rfl e.symm⟩ +theorem _root_.Iris.OFE.Dist.ordN_r : (b : α) ≡{n}≡ c → (a ≼ₒ{n} b ↔ a ≼ₒ{n} c) := ordN_iff_right + +theorem ordN_dist_iff (ea : (a : α) ≡{n}≡ a') (eb : (b : α) ≡{n}≡ b') : a ≼ₒ{n} b ↔ a' ≼ₒ{n} b' := + ⟨ordN_ne ea eb, ordN_ne ea.symm eb.symm⟩ +theorem _root_.Iris.OFE.Dist.ordN : + (a : α) ≡{n}≡ a' → b ≡{n}≡ b' → (a ≼ₒ{n} b ↔ a' ≼ₒ{n} b') := ordN_dist_iff + +theorem _root_.Iris.Ordered.Order.trans : (x : α) ≼ₒ y → y ≼ₒ z → x ≼ₒ z := ord_trans + +instance instTransOrder : Trans (Order (α := α)) Order Order where + trans := ord_trans + +theorem _root_.Iris.Ordered.OrderN.trans : (x : α) ≼ₒ{n} y → y ≼ₒ{n} z → x ≼ₒ{n} z := ordN_trans + +instance instTransOrderN : Trans (OrderN (α := α) n) (OrderN n) (OrderN n) where + trans := ordN_trans + +theorem ordN_of_ordN_le {n n'} {x y : α} (l1 : n' ≤ n) : x ≼ₒ{n} y → x ≼ₒ{n'} y := + l1.recOn id fun _ ih h => ih (ordN_succ h) +theorem ord0_of_ordN {n} {x y : α} : x ≼ₒ{n} y → x ≼ₒ{0} y := ordN_of_ordN_le (Nat.zero_le n) +theorem _root_.Iris.Ordered.OrderN.le {n n'} {x y : α} : + n' ≤ n → x ≼ₒ{n} y → x ≼ₒ{n'} y := ordN_of_ordN_le + +theorem ordN_of_ordN_succ {n} {x y : α} : x ≼ₒ{n.succ} y → x ≼ₒ{n} y := ordN_succ +theorem _root_.Iris.Ordered.OrderN.succ {n} {x y : α} : x ≼ₒ{n.succ} y → x ≼ₒ{n} y := ordN_succ + +section ordRefl +variable [OrderRefl α] + +theorem ordN_refl (x : α) : x ≼ₒ{n} x := (ord_refl x).ordN +@[refl] theorem _root_.Iris.Ordered.Order.rfl {x : α} : x ≼ₒ x := ord_refl x +@[refl] theorem _root_.Iris.Ordered.OrderN.rfl {x : α} : x ≼ₒ{n} x := ordN_refl x + +theorem ordN_of_dist {n} {x y : α} (h : x ≡{n}≡ y) : x ≼ₒ{n} y := ordN_ne .rfl h (ordN_refl x) +theorem _root_.Iris.OFE.Dist.to_ordN {n} {x y : α} : x ≡{n}≡ y → x ≼ₒ{n} y := ordN_of_dist + +end ordRefl + +end orderN + +variable [ORA α] + +theorem valid_of_ord {x y : α} (h : x ≼ₒ y) : ✓ y → ✓ x := + valid_mapN fun n => validN_of_ordN (ordN_of_ord n h) + +theorem _root_.Iris.Ordered.OrderN.validN {n} {x y : α} : x ≼ₒ{n} y → ✓{n} y → ✓{n} x := + validN_of_ordN + +theorem validN_of_ord {n} {x y : α} (h : x ≼ₒ y) : ✓{n} y → ✓{n} x := + validN_of_ordN (ordN_of_ord n h) +theorem _root_.Iris.Ordered.Order.validN {n} {x y : α} : x ≼ₒ y → ✓{n} y → ✓{n} x := validN_of_ord + +theorem pcore_mono_ord' {x y : α} {cx} (le : x ≼ₒ y) (e : pcore x = some cx) : + ∃ cy, pcore y = some cy ∧ cx ≼ₒ cy := + pcore_mono_ord le e + +theorem pcore_monoN_ord' {n} {x y : α} {cx} (h : x ≼ₒ{n} y) (e : pcore x ≡{n}≡ some cx) : + ∃ cy, pcore y = some cy ∧ cx ≼ₒ{n} cy := + let ⟨_, hw, ew⟩ := OFE.dist_some e + let ⟨cy, hcy, hi⟩ := pcore_monoN_ord h hw + ⟨cy, hcy, ordN_of_dist_of_ordN ew hi⟩ + +theorem pcore_mono [OrdInc α] {x y cx : α} : + x ≼ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx ≼ cy + | ⟨z, hz⟩, e => + let ⟨cy, hcy, o⟩ := pcore_order_op e z + ⟨cy, hz ▸ hcy, OrdInc.ord_inc o⟩ + +theorem pcore_mono' [OrdInc α] {x y : α} {cx} (le : x ≼ y) (e : pcore x = some cx) : + ∃ cy, pcore y = some cy ∧ cx ≼ cy := + pcore_mono le e + +theorem pcore_monoN' [OrdInc α] {n} {x y : α} {cx} : + x ≼{n} y → pcore x ≡{n}≡ some cx → ∃ cy, pcore y = some cy ∧ cx ≼{n} cy + | ⟨z, hz⟩, e => + let ⟨_, hw, ew⟩ := OFE.dist_some e + let ⟨_, ht, o⟩ := pcore_order_op hw z + let ⟨r, hr, er⟩ := pcore_ne' hz.symm ht + ⟨r, hr, incN_ne ew.symm er (incN_of_inc n (OrdInc.ord_inc o))⟩ + +theorem pcore_op_mono [OrdInc α] {x cx : α} (e : pcore x = some cx) (y : α) : + ∃ cy, pcore (x • y) = some (cx • cy) := + let ⟨_, h, o⟩ := pcore_order_op e y + let ⟨z, hz⟩ := OrdInc.ord_inc o + ⟨z, h.trans (congrArg some hz)⟩ + +theorem op_monoN_right_ord {n x y} (z : α) (h : x ≼ₒ{n} y) : z • x ≼ₒ{n} z • y := + (op_commN.ordN op_commN).1 (op_monoN_left_ord z h) + +theorem op_mono_right_ord {x y} (z : α) (h : x ≼ₒ y) : z • x ≼ₒ z • y := by + rw [comm' (x := z) (y := x), comm' (x := z) (y := y)]; exact op_mono_left_ord z h + +theorem op_monoN_ord {n} {x x' y y' : α} (hx : x ≼ₒ{n} x') (hy : y ≼ₒ{n} y') : + x • y ≼ₒ{n} x' • y' := + (op_monoN_left_ord _ hx).trans (op_monoN_right_ord _ hy) + +theorem op_mono_ord {x x' y y' : α} (hx : x ≼ₒ x') (hy : y ≼ₒ y') : x • y ≼ₒ x' • y' := + (op_mono_left_ord _ hx).trans (op_mono_right_ord _ hy) + +theorem optionalOp_monoN_left_ord {n} {x y : α} (mz : Option α) (h : x ≼ₒ{n} y) : + x •? mz ≼ₒ{n} y •? mz := + match mz with + | none => h + | some z => op_monoN_left_ord z h + +theorem optionalOp_mono_left_ord {x y : α} (mz : Option α) (h : x ≼ₒ y) : x •? mz ≼ₒ y •? mz := + match mz with + | none => h + | some z => op_mono_left_ord z h + +theorem _root_.Iris.Ordered.OrderNR.op_left {n} {x y : α} (z : α) : + x ≼ₒ*{n} y → x • z ≼ₒ*{n} y • z + | .inl e => .inl e.op_l + | .inr h => .inr (op_monoN_left_ord z h) + +theorem _root_.Iris.Ordered.OrderR.op_left {x y : α} (z : α) : x ≼ₒ* y → x • z ≼ₒ* y • z + | .inl e => .inl (e ▸ rfl) + | .inr h => .inr (op_mono_left_ord z h) + +theorem _root_.Iris.Ordered.OrderNR.validN {n} {x y : α} : x ≼ₒ*{n} y → ✓{n} y → ✓{n} x + | .inl e, v => validN_ne e.symm v + | .inr h, v => validN_of_ordN h v + +theorem _root_.Iris.Ordered.OrderR.validN {n} {x y : α} : x ≼ₒ* y → ✓{n} y → ✓{n} x + | .inl e, v => e ▸ v + | .inr h, v => validN_of_ord h v + +theorem op_extend_ord {n} {x y₁ y₂ : α} (v : ✓{n} x) (h : y₁ • y₂ ≼ₒ{n} x) : + ∃ z₁ z₂ : α, z₁ • z₂ ≼ₒ{n.succ} x ∧ z₁ ≡{n}≡ y₁ ∧ z₂ ≡{n}≡ y₂ := + let ⟨_, hx', e⟩ := ordN_extend v h + let ⟨z₁, z₂, hz, hz₁, hz₂⟩ := extend (validN_of_ordN (ordN_succ hx') v) e + ⟨z₁, z₂, hz ▸ hx', hz₁, hz₂⟩ + +end ORA + +/-! ## Increasing elements -/ + +section +open ORA +variable [ORA α] + +namespace Increasing + +theorem of_ordNR {n} {x y : α} (h : Increasing x) (hxy : x ≼ₒ*{n} y) : Increasing y := + increasing_closed h hxy +theorem of_dist {n} {x y : α} (h : Increasing x) (e : x ≡{n}≡ y) : Increasing y := + h.of_ordNR (.inl e) +theorem of_ordN {n} {x y : α} (h : Increasing x) (hxy : x ≼ₒ{n} y) : Increasing y := + h.of_ordNR (.inr hxy) +theorem of_ord {x y : α} (h : Increasing x) (hxy : x ≼ₒ y) : Increasing y := + h.of_ordN (ordN_of_ord 0 hxy) +theorem of_ordR {x y : α} (h : Increasing x) : x ≼ₒ* y → Increasing y + | .inl e => e ▸ h + | .inr hxy => h.of_ord hxy + +theorem ordN {n} {x : α} (h : Increasing x) (y : α) : y ≼ₒ{n} x • y := + ordN_of_ord n (h.increasing y) + +instance op (x y : α) [Increasing x] [Increasing y] : Increasing (x • y) where + increasing z := calc + z ≼ₒ y • z := Increasing.increasing z + _ ≼ₒ x • (y • z) := Increasing.increasing _ + _ = (x • y) • z := assoc' + +end Increasing + +instance instIncreasingOfCoreId (x : α) [CoreId x] : Increasing x := pcore_increasing core_id + +end + +namespace ORA +variable [ORA α] + +section total +variable [IsTotal α] + +theorem core_ordN_core {n} {x y : α} (le : x ≼ₒ{n} y) : core x ≼ₒ{n} core y := + let ⟨_, hcy, icy⟩ := pcore_monoN_ord le (pcore_eq_core x) + Option.some.inj (hcy.symm.trans (pcore_eq_core y)) ▸ icy + +theorem core_mono_ord {x y : α} (le : x ≼ₒ y) : core x ≼ₒ core y := + let ⟨_, hcy, icy⟩ := pcore_mono_ord le (pcore_eq_core x) + Option.some.inj (hcy.symm.trans (pcore_eq_core y)) ▸ icy + +theorem core_op_mono_ord (x y : α) : core x ≼ₒ core (x • y) := + let ⟨_, hcxy, h⟩ := pcore_order_op (pcore_eq_core x) y + Option.some.inj (hcxy.symm.trans (pcore_eq_core _)) ▸ h + +theorem core_incN_core [OrdInc α] {n} {x y : α} (le : x ≼{n} y) : core x ≼{n} core y := + let ⟨_, hcy, icy⟩ := pcore_monoN' le (Dist.of_eq (pcore_eq_core x)) + Option.some.inj (hcy.symm.trans (pcore_eq_core y)) ▸ icy + +theorem core_op_mono [OrdInc α] (x y : α) : core x ≼ core (x • y) := + OrdInc.ord_inc (core_op_mono_ord x y) + +theorem core_mono [OrdInc α] {x y : α} : x ≼ y → core x ≼ core y + | ⟨z, hz⟩ => hz ▸ core_op_mono x z + +instance increasing_core (x : α) : Increasing (core x) := pcore_increasing (pcore_eq_core x) + +end total + +/-! ## Composition with increasing elements -/ + +section increasing + +theorem ord_op_right (x y : α) [Increasing x] : y ≼ₒ x • y := Increasing.increasing y +theorem ord_op_left (x y : α) [Increasing y] : x ≼ₒ x • y := + comm' (x := y) (y := x) ▸ ord_op_right y x +theorem ordN_op_left (n) (x y : α) [Increasing y] : x ≼ₒ{n} x • y := (ord_op_left x y).ordN +theorem ordN_op_right (n) (x y : α) [Increasing x] : y ≼ₒ{n} x • y := (ord_op_right x y).ordN + +theorem pcore_ord_self {x : α} {cx} [Increasing x] (e : pcore x = some cx) : cx ≼ₒ x := + pcore_op_left e ▸ ord_op_left cx x + +theorem core_ord_self [IsTotal α] {x : α} [Increasing x] : core x ≼ₒ x := + pcore_ord_self (pcore_eq_core x) + +end increasing + +section discreteORA + +theorem valid_iff_validN' [Discrete α] (n) {x : α} : ✓ x ↔ ✓{n} x := + ⟨Valid.validN, fun v => discrete_valid <| validN_of_le (Nat.zero_le n) v⟩ + +theorem valid_0_iff_validN [Discrete α] (n) {x : α} : ✓{0} x ↔ ✓{n} x := + ⟨Valid.validN ∘ discrete_valid, validN_of_le (Nat.zero_le n)⟩ + +theorem ord_iff_ordN [Discrete α] (n) {x y : α} : x ≼ₒ y ↔ x ≼ₒ{n} y := + ⟨ordN_of_ord _, fun h => discrete_ord (ord0_of_ordN h)⟩ + +theorem ord_0_iff_ordN [Discrete α] (n) {x y : α} : x ≼ₒ{0} y ↔ x ≼ₒ{n} y := + ⟨fun h => ordN_of_ord n (discrete_ord h), ord0_of_ordN⟩ + +end discreteORA + +section cancelableElements + +theorem cancelable {x y z : α} [Cancelable x] (v : ✓ (x • y)) (e : x • y = x • z) : y = z := + OFE.eq_dist_2 fun _ => cancelableN v.validN e.dist + +theorem discrete_cancelable {x : α} [Discrete α] + (H : ∀ {y z : α}, ✓ (x • y) → x • y = x • z → y = z) : Cancelable x where + cancelableN {n} {_ _} v e := (H ((valid_iff_validN' n).mpr v) (Discrete.discrete e)).dist + +instance cancelable_op {x y : α} [Cancelable x] [Cancelable y] : Cancelable (x • y) where + cancelableN {n w _} v e := + have v1 : ✓{n} x • (y • w) := validN_ne op_assocN.symm v + have v2 := validN_op_right v1 + cancelableN v2 <| cancelableN v1 <| op_assocN.trans <| e.trans op_assocN.symm + +instance exclusive_cancelable {x : α} [Exclusive x] : Cancelable x where + cancelableN v _ := absurd v not_valid_exclN_op_left + +theorem op_opM_cancel_dist {x y z : α} {mw : Option α} [Cancelable x] + (vxy : ✓{n} x • y) (h : x • y ≡{n}≡ (x • z) •? mw) : y ≡{n}≡ z •? mw := + match mw with + | none => cancelableN vxy h + | some _ => cancelableN vxy (h.trans (op_assocN.symm)) + +end cancelableElements + +section idFreeElements + +theorem IdFree.of_dist {x₁ x₂ : α} {n} (e : x₁ ≡{n}≡ x₂) (h : IdFree x₁) : IdFree x₂ where + id_free0_r z v := fun h₂ => + have ee := Dist.le e (Nat.zero_le _) + have := calc + x₁ • z ≡{0}≡ x₂ • z := op_left_dist z ee + _ ≡{0}≡ x₂ := h₂ + _ ≡{0}≡ x₁ := ee.symm + h.id_free0_r _ ((validN_dist_iff ee).mpr v) this + +theorem _root_.Iris.OFE.Dist.idFree {x₁ x₂ : α} (e : x₁ ≡{n}≡ x₂) : IdFree x₁ ↔ IdFree x₂ := + ⟨.of_dist e, .of_dist e.symm⟩ + +theorem id_freeN_r {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(x • y ≡{n'}≡ x) := + id_free0_r _ (validN_of_le (Nat.zero_le _) v) |>.imp (·.le (Nat.zero_le _)) + +theorem id_freeN_l {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(y • x ≡{n'}≡ x) := + id_freeN_r v ∘ comm'.dist.trans + +theorem id_free_r {x : α} [IdFree x] {y} (v : ✓ x) : ¬(x • y = x) := + fun h => id_free0_r y (valid_iff_validN.mp v 0) h.dist + +theorem id_free_l {x : α} [IdFree x] {y} (v : ✓ x) : ¬(y • x = x) := + id_free_r v ∘ comm'.trans + +theorem discrete_id_free {x : α} [Discrete α] (H : ∀ y, ✓ x → ¬(x • y = x)) : IdFree x where + id_free0_r y v h := H y (Discrete.discrete_valid v) (Discrete.discrete_0 h) + +instance idFree_op_r {x y : α} [IdFree y] [Cancelable x] : IdFree (x • y) where + id_free0_r z v h := + id_free0_r z (validN_op_right v) (cancelableN v (op_assocN.trans h).symm).symm + +instance idFree_op_l {x y : α} [IdFree x] [Cancelable y] : IdFree (x • y) := by + rw [comm']; exact inferInstance + +instance exclusive_idFree {x : α} [Exclusive x] : IdFree x where + id_free0_r z v h := exclusive0_l z ((validN_dist_iff h.symm).mp v) + +end idFreeElements + +section ucmra + +variable {α : Type _} [UORA α] + +theorem unit_validN {n} : ✓{n} (unit : α) := valid_iff_validN.mp (unit_valid) n + +theorem unit_left_id_dist {n} (x : α) : unit • x ≡{n}≡ x := unit_left_id.dist + +theorem unit_right_id {x : α} : x • unit = x := comm'.trans unit_left_id + +theorem unit_right_id_dist (x : α) : x • unit ≡{n}≡ x := comm'.dist.trans (unit_left_id_dist x) + +theorem incN_unit {n} {x : α} : unit ≼{n} x := ⟨x, unit_left_id.symm.dist⟩ + +theorem inc_unit {x : α} : unit ≼ x := ⟨x, unit_left_id.symm⟩ + +instance unit_CoreId : CoreId (unit : α) where + core_id := pcore_unit + +instance unit_total : IsTotal α where + total x := + let ⟨cx, hcx, _⟩ := pcore_order_op (pcore_unit (α := α)) x + ⟨cx, unit_left_id (x := x) ▸ hcx⟩ + +instance empty_cancelable : Cancelable (unit : α) where + cancelableN {n w t} _ e := calc + w ≡{n}≡ unit • w := unit_left_id.dist.symm + _ ≡{n}≡ unit • t := e + _ ≡{n}≡ t := unit_left_id.dist + +theorem increasing_iff_unit_ord {x : α} : Increasing x ↔ unit ≼ₒ x := + ⟨fun h => unit_right_id (x := x) ▸ h.increasing unit, + fun h => ⟨fun y => calc + y = unit • y := unit_left_id.symm + _ ≼ₒ x • y := op_mono_left_ord y h⟩⟩ + +theorem ordN_op_right_of_unit_ordN {n} {x : α} (y : α) (h : unit ≼ₒ{n} x) : y ≼ₒ{n} x • y := + calc y ≡{n}≡ unit • y := (unit_left_id_dist y).symm + _ ≼ₒ{n} x • y := op_monoN_left_ord y h + +theorem unit_ord_core (x : α) : unit ≼ₒ core x := increasing_iff_unit_ord.mp (increasing_core x) + +theorem unit_ordN_core {n} (x : α) : unit ≼ₒ{n} core x := (unit_ord_core x).ordN + +theorem exists_op_ordN_iff_ordN [IncOrd α] {n} {x y : α} : (∃ c, x • c ≼ₒ{n} y) ↔ x ≼ₒ{n} y := + ⟨fun ⟨c, h⟩ => (ordN_op_left n x c).trans h, fun h => ⟨unit, (unit_right_id (x := x)).symm ▸ h⟩⟩ + +theorem exists_op_ord_iff_ord [IncOrd α] {x y : α} : (∃ c, x • c ≼ₒ y) ↔ x ≼ₒ y := + ⟨fun ⟨c, h⟩ => (ord_op_left x c).trans h, fun h => ⟨unit, (unit_right_id (x := x)).symm ▸ h⟩⟩ + +theorem exists_op_ordN_iff_incN [OrdInc α] {n} {x y : α} : (∃ c, x • c ≼ₒ{n} y) ↔ x ≼{n} y := + ⟨fun ⟨c, h⟩ => (incN_op_left n x c).trans (OrdInc.ordN_incN h), + fun ⟨c, hc⟩ => ⟨c, hc.symm.to_ordN⟩⟩ + +theorem exists_op_ord_iff_inc [OrdInc α] {x y : α} : (∃ c, x • c ≼ₒ y) ↔ x ≼ y := + ⟨fun ⟨c, h⟩ => (inc_op_left x c).trans (OrdInc.ord_inc h), fun ⟨c, hc⟩ => ⟨c, hc ▸ .rfl⟩⟩ + +section increasing + +theorem ordN_unit {n} {x : α} [Increasing x] : unit ≼ₒ{n} x := + unit_left_id (x := x) ▸ ordN_op_left n unit x + +theorem ord_unit {x : α} [Increasing x] : unit ≼ₒ x := unit_left_id (x := x) ▸ ord_op_left unit x + +end increasing + +instance ucmraMonoidOps {α : Type _} [UORA α] : Algebra.MonoidOps (op (α := α)) unit where + op_ne := ⟨fun _ _ _ hx _ _ hy => hx.op hy⟩ + op_assoc := assoc.symm + op_comm := comm + op_left_id := unit_left_id + +end ucmra + +section Leibniz + +theorem assoc_L {x y z : α} : x • (y • z) = (x • y) • z := assoc + +theorem comm_L {x y : α} : x • y = y • x := comm + +theorem pcore_op_left_L {x cx : α} (h : pcore x = some cx) : cx • x = x := + pcore_op_left h + +theorem pcore_idem_L {x cx : α} (h : pcore x = some cx) : pcore cx = some cx := + pcore_idem h + +theorem op_opM_assoc_L {x y : α} {mz} : (x • y) •? mz = x • (y •? mz) := + op_opM_assoc _ _ _ + +theorem pcore_op_right_L {x cx : α} (h : pcore x = some cx) : x • cx = x := + pcore_op_right h + +theorem pcore_op_self_L {x cx : α} (h : pcore x = some cx) : cx • cx = cx := + pcore_op_self h + +theorem core_id_dup_L {x : α} [CoreId x] : x • x = x := + op_self x + +theorem op_core_L {x : α} [IsTotal α] : x • core x = x := + op_core x + +theorem core_op_L {x : α} [IsTotal α] : core x • x = x := + core_op x + +theorem core_idem_L {x : α} [IsTotal α] : core (core x) = core x := + core_idem x + +theorem core_op_core_L {x : α} [IsTotal α] : core x • core x = core x := + core_op_core + +theorem coreId_iff_core_eq_self {x : α} [IsTotal α] : CoreId x ↔ core x = x := + coreId_iff_core_eqv_self + +theorem core_eq_self {x : α} [IsTotal α] [c : CoreId x] : core x = x := + coreId_iff_core_eq_self.mp c + +end Leibniz + +section UORA + +variable {α : Type _} [UORA α] + +theorem ucmra_unit_valid : ✓ (unit : α) := unit_valid + +theorem ucmra_unit_left_id {x : α} : unit • x = x := unit_left_id + +theorem ucmra_pcore_unit : pcore (unit : α) = some unit := pcore_unit + +theorem unit_left_id_L {x : α} : unit • x = x := unit_left_id + +theorem unit_right_id_L {x : α} : x • unit = x := unit_right_id + +end UORA + +end ORA + +/-- A morphism between CMRAs is defined to be a non-expansive function which +preserves `validN`, `pcore` and `op`. -/ +structure CMRA.Hom (α β : Type _) [OFE α] [Op α] [PCore α] [Validity α] + [OFE β] [Op β] [PCore β] [Validity β] extends OFE.Hom α β where + protected validN {n x} : ✓{n} x → ✓{n} (f x) + protected pcore x : (PCore.pcore x).map f = PCore.pcore (f x) + protected op x y : f (x • y) = f x • f y + +namespace ORA +variable [ORA α] + +section Hom + +/-- A morphism between ORAs, written `α -C> β`, is defined to be a non-expansive function which +preserves `validN`, `pcore`, `op`, the order and increasing elements. -/ +@[ext] +structure Hom (α β : Type _) [ORA α] [ORA β] extends toCMRAHom : CMRA.Hom α β where + protected monoN_ord {n x₁ x₂} : x₁ ≼ₒ{n} x₂ → f x₁ ≼ₒ{n} f x₂ + protected mono_ord {x₁ x₂} : x₁ ≼ₒ x₂ → f x₁ ≼ₒ f x₂ + protected increasing {x} : Increasing x → Increasing (f x) + +@[inherit_doc] +infixr:25 " -C> " => Hom + +instance [ORA β] : CoeFun (α -C> β) (fun _ => α → β) := ⟨fun F => F.f⟩ + +instance [ORA β] : OFE (α -C> β) where + Dist n f g := f.toHom ≡{n}≡ g.toHom + dist_eqv := { + refl _ := dist_eqv.refl _ + symm h := dist_eqv.symm h + trans h1 h2 := dist_eqv.trans h1 h2 + } + eq_dist' {_ _} := Hom.ext_iff.trans eq_dist + dist_lt := dist_lt + +/-- The identity morphism of an ordered resource algebra. -/ +protected def Hom.id : α -C> α where + toHom := OFE.Hom.id + validN := id + pcore x := by dsimp; cases pcore x <;> rfl + op _ _ := rfl + monoN_ord := id + mono_ord := id + increasing := id + +/-- Composition of ordered resource algebra morphisms. -/ +protected def Hom.comp [ORA β] [ORA γ] (g : β -C> γ) (f : α -C> β) : α -C> γ where + toHom := OFE.Hom.comp g.toHom f.toHom + validN v := g.validN (f.validN v) + pcore x := ((Option.map_map ..).symm.trans (congrArg _ (f.pcore x))).trans (g.pcore (f x)) + op x y := (congrArg g.f (f.op x y)).trans (g.op ..) + monoN_ord h := g.monoN_ord (f.monoN_ord h) + mono_ord h := g.mono_ord (f.mono_ord h) + increasing h := g.increasing (f.increasing h) + +protected theorem Hom.core [ORA β] (f : α -C> β) {x : α} : core (f x) = f (core x) := by + have h := f.pcore x + unfold core + cases hx : pcore x <;> rw [hx] at h <;> simp only [Option.map] at h <;> simp [← h] + +protected theorem Hom.mono [ORA β] (f : α -C> β) {x₁ x₂ : α} : + x₁ ≼ x₂ → f x₁ ≼ f x₂ := + inc_map f.f f.op + +protected theorem Hom.monoN [ORA β] (f : α -C> β) n {x₁ x₂ : α} : + x₁ ≼{n} x₂ → f x₁ ≼{n} f x₂ := + incN_map f.f f.op + +protected theorem Hom.valid [ORA β] (f : α -C> β) {x : α} (H : ✓ x) : ✓ f x := + valid_iff_validN.mpr fun _ => f.validN H.validN + +end Hom +end ORA + +section HomExt +open ORA +variable [ORA α] [ORA β] [OrdInc α] [IncOrd β] + +/-- A morphism between classical resource algebras needs only the classical fields: under the +extension order, `monoN_ord`, `mono_ord` and `increasing` follow from `op`. -/ +@[reducible] def CMRA.Hom.toORA (g : CMRA.Hom α β) : α -C> β where + toCMRAHom := g + monoN_ord h := IncOrd.incN_ordN (incN_map g.f g.op (OrdInc.ordN_incN h)) + mono_ord h := IncOrd.inc_ord (inc_map g.f g.op (OrdInc.ord_inc h)) + increasing _ := IncOrd.increasing _ + +end HomExt + +section rFunctor + +/-- A mixed-variance family of ordered resource algebras with a non-expansive action. -/ +class RFunctor (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) where + [cmra [COFE α] [COFE β] : ORA (F α β)] + /-- The contravariant and covariant action on non-expansive maps. -/ + map [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + (α₂ -n> α₁) → (β₁ -n> β₂) → F α₁ β₁ -C> F α₂ β₂ + map_ne [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + NonExpansive₂ (@map α₁ α₂ β₁ β₂ _ _ _ _) + map_id [COFE α] [COFE β] (x : F α β) : map (Hom.id (α := α)) (Hom.id (α := β)) x = x + map_comp [COFE α₁] [COFE α₂] [COFE α₃] [COFE β₁] [COFE β₂] [COFE β₃] + (f : α₂ -n> α₁) (g : α₃ -n> α₂) (f' : β₁ -n> β₂) (g' : β₂ -n> β₃) (x : F α₁ β₁) : + map (f.comp g) (g'.comp f') x = map g g' (map f f' x) + +/-- A resource functor whose action on morphisms is contractive. -/ +class RFunctorContractive (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type + _)) extends (RFunctor F) where + map_contractive [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + Contractive (Function.uncurry (@map α₁ α₂ β₁ β₂ _ _ _ _)) + +attribute [reducible, instance] RFunctor.cmra + +instance RFunctor.toOFunctor [R : RFunctor F] : COFE.OFunctor F where + ofe := RFunctor.cmra.toOFE + map a b := (RFunctor.map a b).toHom + map_ne.ne := RFunctor.map_ne.ne + map_id x := RFunctor.map_id x + map_comp f g f' g' x := RFunctor.map_comp f g f' g' x + +instance RFunctorContractive.toOFunctorContractive + [RFunctorContractive F] : COFE.OFunctorContractive F where + map_contractive.1 := map_contractive.1 + +end rFunctor + +section urFunctor +open ORA + +/-- A resource functor whose values are unital ordered resource algebras. -/ +class URFunctor (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) where + [cmra [COFE α] [COFE β] : UORA (F α β)] + /-- The action on morphisms of a unital resource functor. -/ + map [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + (α₂ -n> α₁) → (β₁ -n> β₂) → F α₁ β₁ -C> F α₂ β₂ + map_ne [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + NonExpansive₂ (@map α₁ α₂ β₁ β₂ _ _ _ _) + map_id [COFE α] [COFE β] (x : F α β) : map (Hom.id (α := α)) (Hom.id (α := β)) x = x + map_comp [COFE α₁] [COFE α₂] [COFE α₃] [COFE β₁] [COFE β₂] [COFE β₃] + (f : α₂ -n> α₁) (g : α₃ -n> α₂) (f' : β₁ -n> β₂) (g' : β₂ -n> β₃) (x : F α₁ β₁) : + map (f.comp g) (g'.comp f') x = map g g' (map f f' x) + +/-- A unital resource functor with a contractive action on morphisms. -/ +class URFunctorContractive (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type + _)) extends URFunctor F where + map_contractive [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + Contractive (Function.uncurry (@map α₁ α₂ β₁ β₂ _ _ _ _)) + +attribute [reducible, instance] URFunctor.cmra + +/-- A resource functor whose values have increasing composition. -/ +class RFunctorAffine (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [RFunctor F] : Prop where + affine [COFE α] [COFE β] : IncOrd (F α β) + +attribute [instance] RFunctorAffine.affine + +instance URFunctor.toRFunctor [UF : URFunctor F] : RFunctor F where + cmra := URFunctor.cmra.toORA + map f g := URFunctor.map f g + map_ne := URFunctor.map_ne + map_id := URFunctor.map_id + map_comp := URFunctor.map_comp + +instance URFunctorContractive.toRFunctorContractive + [URFunctorContractive F] : RFunctorContractive F where + map_contractive := map_contractive + +end urFunctor + +section ComposeRF + +open COFE + +theorem RFunctorContractive.map_distLater {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)} [RFunctorContractive F] + [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] {n} {f₁ f₂ : α₂ -n> α₁} {g₁ g₂ : β₁ -n> β₂} + (hf : DistLater n f₁ f₂) (hg : DistLater n g₁ g₂) (x : F α₁ β₁) : + RFunctor.map f₁ g₁ x ≡{n}≡ RFunctor.map f₂ g₂ x := + map_contractive.1 (x := (f₁, g₁)) (y := (f₂, g₂)) (fun m hm => ⟨hf m hm, hg m hm⟩) x + +theorem URFunctorContractive.map_distLater {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)} [URFunctorContractive F] + [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] {n} {f₁ f₂ : α₂ -n> α₁} {g₁ g₂ : β₁ -n> β₂} + (hf : DistLater n f₁ f₂) (hg : DistLater n g₁ g₂) (x : F α₁ β₁) : + URFunctor.map f₁ g₁ x ≡{n}≡ URFunctor.map f₂ g₂ x := + map_contractive.1 (x := (f₁, g₁)) (y := (f₂, g₂)) (fun m hm => ⟨hf m hm, hg m hm⟩) x + +variable {F₁ F₂ : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)} [OFunctor + F₂] [∀ α β, [COFE α] → [COFE β] → IsCOFE (F₂ α β)] + +open OFunctor in +instance rFunctorComposeOF [RFunctor F₁] : RFunctor (ComposeOF F₁ F₂) where + cmra := RFunctor.cmra (F := F₁) + map f g := RFunctor.map (F := F₁) (map (F := F₂) g f) (map (F := F₂) f g) + map_ne.ne _ _ _ hf _ _ hg _ := + (RFunctor.map_ne (F := F₁)).ne (fun _ => (map_ne (F := F₂)).ne hg hf _) + (fun _ => (map_ne (F := F₂)).ne hf hg _) _ + map_id _ := by + simp only [map_id_eq] + exact RFunctor.map_id (F := F₁) _ + map_comp _ _ _ _ _ := by + simp only [map_comp_eq] + exact RFunctor.map_comp (F := F₁) _ _ _ _ _ + +open OFunctor in +instance urFunctorComposeOF [URFunctor F₁] : URFunctor (ComposeOF F₁ F₂) where + cmra := URFunctor.cmra (F := F₁) + map f g := URFunctor.map (F := F₁) (map (F := F₂) g f) (map (F := F₂) f g) + map_ne.ne _ _ _ hf _ _ hg _ := + (URFunctor.map_ne (F := F₁)).ne (fun _ => (map_ne (F := F₂)).ne hg hf _) + (fun _ => (map_ne (F := F₂)).ne hf hg _) _ + map_id _ := by + simp only [map_id_eq] + exact URFunctor.map_id (F := F₁) _ + map_comp _ _ _ _ _ := by + simp only [map_comp_eq] + exact URFunctor.map_comp (F := F₁) _ _ _ _ _ + +instance instRFunctorAffineComposeOF [RFunctor F₁] [RFunctorAffine F₁] : + RFunctorAffine (ComposeOF F₁ F₂) where + affine := RFunctorAffine.affine (F := F₁) + +open OFunctor in +instance rFunctorComposeOFContractiveLeft [RFunctorContractive F₁] : + RFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + RFunctorContractive.map_distLater (F := F₁) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).2 (h m hm).1 _) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).1 (h m hm).2 _) x⟩ + +open OFunctor in +instance urFunctorComposeOFContractiveLeft [URFunctorContractive F₁] : + URFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + URFunctorContractive.map_distLater (F := F₁) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).2 (h m hm).1 _) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).1 (h m hm).2 _) x⟩ + +end ComposeRF + +section ComposeRFContractive + +open COFE OFunctorContractive + +variable {F₁ F₂ : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)} + [OFunctorContractive F₂] + [∀ α β, [COFE α] → [COFE β] → IsCOFE (F₂ α β)] + +instance rFunctorComposeOFContractiveRight [RFunctor F₁] : + RFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + (RFunctor.map_ne (F := F₁)).ne + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).2) (fun m hm => (h m hm).1) _) + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).1) (fun m hm => (h m hm).2) _) x⟩ + +instance urFunctorComposeOFContractiveRight [URFunctor F₁] : + URFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + (URFunctor.map_ne (F := F₁)).ne + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).2) (fun m hm => (h m hm).1) _) + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).1) (fun m hm => (h m hm).2) _) x⟩ + +end ComposeRFContractive + +section Id +open ORA + +instance COFE.OFunctor.constOFRFunctor [ORA B] : RFunctor (constOF B) where + cmra := inferInstance + map _ _ := (Hom.id : B -C> B) + map_ne.ne _ _ _ _ _ _ _ := .rfl + map_id _ := rfl + map_comp _ _ _ _ _ := rfl + +instance COFE.OFunctor.constOF_RFunctorAffine [ORA B] [IncOrd B] : RFunctorAffine (constOF B) where + affine := inferInstance + +instance OFunctor.constOFRFunctorContractive [ORA B] : RFunctorContractive (constOF B) where + map_contractive.1 := fun _ => .rfl + +instance COFE.OFunctor.constOFURFunctor [UORA B] : URFunctor (constOF B) where + cmra := inferInstance + map _ _ := (Hom.id : B -C> B) + map_ne.ne _ _ _ _ _ _ _ := .rfl + map_id _ := rfl + map_comp _ _ _ _ _ := rfl + +instance OFunctor.constOFURFunctorContractive [UORA B] : URFunctorContractive (constOF B) where + map_contractive.1 _ := .rfl + +end Id + +/-! ## Transporting a CMRA equality + +Rocq bundles a CMRA as a record, so a proof of `A = B` transports the whole algebra. In Lean +`ORA` is a type class, and an equality of carriers says nothing about the two instances, so the +transport lemmas are replaced by `transpAp` and the `OFE.transpAp_*` family in +`Iris.Instances.IProp.Instance`, which carry the equality of the instances explicitly. -/ + +section DiscreteFunO +open ORA + +namespace DiscreteFun + +variable {α : Type _} {β : α → Type _} + +section +variable [∀ x, ORA (β x)] + +/-- The resource order on dependent functions. -/ +@[reducible] def raOrdered : Ordered (∀ x, β x) where + OrderN n f g := ∀ x, f x ≼ₒ{n} g x + Order f g := ∀ x, f x ≼ₒ g x + ordN_ne ef eg h x := ordN_ne (ef x) (eg x) (h x) + ordN_succ h x := ordN_succ (h x) + ordN_trans h₁ h₂ x := ordN_trans (h₁ x) (h₂ x) + ord_trans h₁ h₂ x := ord_trans (h₁ x) (h₂ x) + ordN_of_ord n h x := ordN_of_ord n (h x) + +attribute [local instance] raOrdered + +theorem ordNR_apply {n} {f g : ∀ x, β x} (h : f ≼ₒ*{n} g) (x : α) : f x ≼ₒ*{n} g x := + h.imp (· x) (· x) + +variable [∀ x, IsTotal (β x)] + +/-- Composition on dependent functions. -/ +@[reducible] +def raOp : Op (∀ x, β x) where + op f g x := f x • g x + op_ne.ne _ _ _ H y := (H y).op_r + assoc := funext fun _ => assoc + comm := funext fun _ => comm + +/-- The partial core on dependent functions. -/ +@[reducible] +def raPCore : PCore (∀ x, β x) where + pcore f := some fun x => core (f x) + pcore_ne {n f g _} H := by rintro ⟨⟩; exact ⟨_, rfl, fun x => (H _).core⟩ + pcore_idem := by + rintro f _ ⟨⟩; exact congrArg some (funext fun x => core_idem (f x)) + +/-- Validity on dependent functions. -/ +@[reducible] +def raValid : _root_.Iris.Validity (∀ x, β x) where + ValidN n f := ∀ x, ✓{n} f x + Valid f := ∀ x, ✓ f x + validN_ne {n x y} H H1 y := (H y).validN.mp (H1 y) + valid_iff_validN {g} := by simpa [valid_iff_validN] using forall_comm + validN_succ H _ := validN_succ (H _) + +attribute [local instance] raOp raPCore raValid + +omit [∀ (x : α), IsTotal (β x)] in +open Classical in +theorem increasing_apply {f : ∀ x, β x} (h : Increasing f) (x : α) : Increasing (f x) where + increasing y := by + let g : ∀ x', β x' := fun x' => if e : x' = x then e ▸ y else f x' + have hg : g x = y := dite_eq_left rfl + rw [← hg] + exact h.increasing g x + +omit [∀ (x : α), IsTotal (β x)] in +theorem increasing_iff {f : ∀ x, β x} : Increasing f ↔ ∀ x, Increasing (f x) := + ⟨increasing_apply, fun h => { increasing := fun g x => (h x).increasing (g x) }⟩ + +end + +end DiscreteFun + +section +open DiscreteFun +variable {α : Type _} {β : α → Type _} [∀ x, ORA (β x)] [∀ x, IsTotal (β x)] +attribute [local instance] raOp raPCore raValid raOrdered + +variable (β) in +instance cmraDiscreteFunO : ORA (∀ x, β x) where + toOp := raOp + toPCore := raPCore + toValidity := raValid + validN_op_left H _ := validN_op_left (H _) + pcore_op_left := by rintro f _ ⟨⟩; exact funext fun x => core_op (f x) + extend {n f f1 f2} Hv He := by + let F x := extend (Hv x) (He x) + exact ⟨fun x => (F x).1, fun x => (F x).2.1, + funext fun x => (F x).2.2.1, fun x => (F x).2.2.2.1, fun x => (F x).2.2.2.2⟩ + toOrdered := raOrdered + op_monoN_left_ord h H x := op_monoN_left_ord (h x) (H x) + op_mono_left_ord h H x := op_mono_left_ord (h x) (H x) + validN_of_ordN H V x := validN_of_ordN (H x) (V x) + pcore_monoN_ord := by rintro n f g _ H ⟨⟩; exact ⟨_, rfl, fun x => core_ordN_core (H x)⟩ + pcore_mono_ord := by rintro f g _ H ⟨⟩; exact ⟨_, rfl, fun x => core_mono_ord (H x)⟩ + pcore_order_op := by rintro f _ ⟨⟩ g; exact ⟨_, rfl, fun x => core_op_mono_ord (f x) (g x)⟩ + pcore_increasing := by rintro f _ ⟨⟩; exact increasing_iff.mpr fun x => inferInstance + increasing_closed H₁ H₂ := + increasing_iff.mpr fun x => increasing_closed (increasing_apply H₁ x) (ordNR_apply H₂ x) + ordN_extend V H := + let ⟨z, hz⟩ := Classical.skolem.mp fun x => ordN_extend (V x) (H x) + ⟨z, fun x => (hz x).1, fun x => (hz x).2⟩ + +end + +instance ucmraDiscreteFunO {α : Type _} (β : α → Type _) [∀ x, UORA (β x)] : + UORA (∀ x, β x) where + unit _ := unit + unit_valid _ := unit_valid + unit_left_id := funext fun _ => unit_left_id + pcore_unit := congrArg some (funext fun _ => core_eqv_self _) + ord_refl f x := ord_refl (f x) + +namespace DiscreteFun + +variable {α : Type _} {β : α → Type _} + +attribute [local instance] raOp in +theorem op_apply [∀ x, ORA (β x)] (f g : ∀ x, β x) (x : α) : + (f • g) x = f x • g x := rfl + +theorem core_apply [∀ x, ORA (β x)] [∀ x, IsTotal (β x)] (f : ∀ x, β x) (x : α) : + core f x = core (f x) := rfl + +theorem unit_apply [∀ x, UORA (β x)] (x : α) : (unit : ∀ x, β x) x = unit := rfl + +instance [∀ x, UORA (β x)] [∀ x, OFE.DiscreteE (unit : β x)] : OFE.DiscreteE (unit : ∀ x, β x) where + discrete h := funext fun x => OFE.DiscreteE.discrete (h x) + +variable [∀ x, ORA (β x)] [∀ x, IsTotal (β x)] + +theorem ord_apply {f g : ∀ x, β x} (h : f ≼ₒ g) (x : α) : f x ≼ₒ g x := h x + +theorem ord_iff {f g : ∀ x, β x} : f ≼ₒ g ↔ ∀ x, f x ≼ₒ g x := .rfl + +theorem ordN_iff {n} {f g : ∀ x, β x} : f ≼ₒ{n} g ↔ ∀ x, f x ≼ₒ{n} g x := .rfl + +theorem inc_apply {f g : ∀ x, β x} : f ≼ g → ∀ x, f x ≼ g x + | ⟨h, hh⟩, x => ⟨h x, congrFun hh x⟩ + +/-- Note: The finiteness assumption from Iris-Rocq is removed using choice. -/ +theorem inc_iff {f g : ∀ x, β x} : f ≼ g ↔ ∀ x, f x ≼ g x := by + refine ⟨inc_apply, fun h => ?_⟩ + obtain ⟨z, hz⟩ := Classical.skolem.mp h + exact ⟨z, funext hz⟩ + +theorem incN_apply {n} {f g : ∀ x, β x} : f ≼{n} g → ∀ x, f x ≼{n} g x + | ⟨h, hh⟩, x => ⟨h x, hh x⟩ + +/-- Note: The finiteness assumption from Iris-Rocq is removed using choice. -/ +theorem incN_iff {n} {f g : ∀ x, β x} : f ≼{n} g ↔ ∀ x, f x ≼{n} g x := + ⟨incN_apply, Classical.skolem.mp⟩ + +instance instOrderRefl [∀ x, OrderRefl (β x)] : OrderRefl (∀ x, β x) where + ord_refl f x := ord_refl (f x) + +instance instIncOrd [∀ x, IncOrd (β x)] : IncOrd (∀ x, β x) := + IncOrd.of_increasing fun f => increasing_iff.mpr fun x => IncOrd.increasing (f x) + +instance instOrdInc [∀ x, OrdInc (β x)] : OrdInc (∀ x, β x) where + ord_inc h := inc_iff.mpr fun x => OrdInc.ord_inc (h x) + ordN_incN h := incN_iff.mpr fun x => OrdInc.ordN_incN (h x) + +instance instIsInc [∀ x, IsInc (β x)] : IsInc (∀ x, β x) := {} + +end DiscreteFun + +/-- Apply a family of resource morphisms pointwise to dependent functions. -/ +def mapCodHomC {α : Type _} {β₁ β₂ : α → Type _} + [∀ x, UORA (β₁ x)] [∀ x, UORA (β₂ x)] + (F : ∀ x, β₁ x -C> β₂ x) : (∀ x, β₁ x) -C> (∀ x, β₂ x) where + toHom := mapCodHom fun x => (F x).toHom + validN h x := (F x).validN (h x) + pcore _ := congrArg some (funext fun x => (F x).core.symm) + op f g := funext fun x => (F x).op (f x) (g x) + monoN_ord h x := (F x).monoN_ord (h x) + mono_ord h x := (F x).mono_ord (h x) + increasing h := DiscreteFun.increasing_iff.mpr fun x => + (F x).increasing (DiscreteFun.increasing_apply h x) + +end DiscreteFunO + +section DiscreteFunURF +open ORA + +instance urFunctorDiscreteFunOF {C} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)) [∀ c, URFunctor (F c)] : + URFunctor (DiscreteFunOF F) where + map f g := { + toHom := COFE.OFunctor.map f g + validN hv _ := (URFunctor.map f g).validN (hv _) + pcore x := by + simp only [pcore, Option.map] + exact congrArg some (funext fun c => ((URFunctor.map f g).core).symm) + op x y := funext fun c => (URFunctor.map f g).op (x c) (y c) + monoN_ord h c := (URFunctor.map f g).monoN_ord (h c) + mono_ord h c := (URFunctor.map f g).mono_ord (h c) + increasing h := DiscreteFun.increasing_iff.mpr fun c => + (URFunctor.map f g).increasing (DiscreteFun.increasing_apply h c) + } + map_ne.ne := COFE.OFunctor.map_ne.ne + map_id x := COFE.OFunctor.map_id x + map_comp f g f' g' x := COFE.OFunctor.map_comp f g f' g' x + +instance instRFunctorAffineDiscreteFunOF {C} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE α] + → [Iris.COFE β] → Type _)) [∀ c, URFunctor (F c)] + [∀ c, RFunctorAffine (F c)] : RFunctorAffine (DiscreteFunOF F) where + affine := inferInstance + +instance DiscreteFunOFURFC {C} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE + β] → Type _)) [HURF : ∀ c, URFunctorContractive (F c)] : + URFunctorContractive (DiscreteFunOF F) where + map_contractive.1 h _ _ := URFunctorContractive.map_contractive.distLater_dist h _ + +end DiscreteFunURF + +section option + +open ORA Iris.Option Iris.OFE.Option + +variable [ORA α] + +/-- Lift the partial core to an optional resource. -/ +@[simp] +def optionCore (x : Option α) : Option α := x.bind pcore + +/-- Compose optional resources, taking absence as the unit. -/ +@[simp] +def optionOp (x y : Option α) : Option α := + match x, y with + | some x', some y' => some (op x' y') + | none, _ => y + | _, none => x + +/-- Step-indexed validity of an optional resource; absence is valid. -/ +@[simp] +def optionValidN (n : Nat) : Option α → Prop + | some x => ✓{n} x + | none => True + +/-- Validity of an optional resource; absence is valid. -/ +@[simp] +def optionValid : Option α → Prop + | some x => ✓ x + | none => True + +/-- The step-indexed order on `Option α`: `none` lies below `none` and below every increasing +element, `some` is monotone up to `n`-equivalence, and nothing but `none` lies below `none`. -/ +@[simp] +def optionOrderN (n : Nat) : Option α → Option α → Prop + | none, none => True + | none, some y => Increasing y + | some x, some y => x ≼ₒ*{n} y + | some _, none => False + +/-- Resource order on optional values, with absence below increasing resources. -/ +@[simp] +def optionOrder : Option α → Option α → Prop + | none, none => True + | none, some y => Increasing y + | some x, some y => x ≼ₒ* y + | some _, none => False + +namespace Option + +/-- Composition on optional resources. -/ +@[reducible] +def raOp : Op (Option α) where + op := optionOp + op_ne.ne n x1 x2 H := by + rename_i x + rcases x1, x2, x with ⟨_|_, _|_, _|_⟩ <;> simp_all [op_right_dist] + assoc {x y z} := by + rcases x, y, z with ⟨_|_, _|_, _|_⟩ <;> first | rfl | exact congrArg some assoc + comm {x y} := by + rcases x, y with ⟨_|_, _|_⟩ <;> first | rfl | exact congrArg some comm + +/-- The partial core on optional resources. -/ +@[reducible] +def raPCore : PCore (Option α) where + pcore x := some (optionCore x) + pcore_ne {n} x y cx H := by + simp only [Option.some.injEq]; rintro rfl + rcases x, y with ⟨_|x, _|y⟩ <;> simp_all only [Dist, Option.Forall₂, optionCore, + Option.bind_none, exists_eq_left', Option.bind_some] + cases Hv : pcore x <;> cases Hv' : pcore y <;> simp only [] + · cases pcore_ne H.symm Hv'; simp_all + · cases pcore_ne H Hv; simp_all + · obtain ⟨w, Hw1, Hw2⟩ := pcore_ne H.symm Hv' + cases Hv.symm.trans Hw1 + exact Hw2.symm + pcore_idem := by + rintro (_|x) <;> simp only [optionCore, Option.bind_none, Option.some.injEq, forall_eq', + Option.bind_some] + rcases H : pcore x with _|y <;> simp only [Option.bind_none, Option.bind_some] + exact pcore_idem H + +/-- Validity on optional resources. -/ +@[reducible] +def raValid : _root_.Iris.Validity (Option α) where + ValidN := optionValidN + Valid := optionValid + validN_ne {n} x y H := by + rcases x, y with ⟨_|_, _|_⟩ <;> simp_all only [Dist, Option.Forall₂, optionValidN, imp_self] + exact Dist.validN H |>.mp + valid_iff_validN {x} := by + rcases x with ⟨_|_⟩ <;> simp [valid_iff_validN] + validN_succ {x n} := by + rcases x with ⟨_|_⟩ <;> simp_all [validN_succ] + +/-- The resource order on optional resources. -/ +@[reducible] def raOrdered : Ordered (Option α) where + OrderN := optionOrderN + Order := optionOrder + ordN_ne {n x x' y y'} ex ey h := by + rcases x, x', y, y' with ⟨_|x, _|x', _|y, _|y'⟩ <;> simp_all only [Dist, Option.Forall₂, + optionOrderN] + · exact h.of_dist ey + · exact Ordered.OrderNR.ne ex ey h + ordN_succ {n x y} h := by + rcases x, y with ⟨_|x, _|y⟩ <;> simp_all only [optionOrderN, Nat.succ_eq_add_one] + exact Ordered.OrderNR.succ h + ordN_trans {n x y z} h₁ h₂ := by + rcases x, y, z with ⟨_|x, _|y, _|z⟩ <;> simp_all only [optionOrderN] + · exact h₁.of_ordNR h₂ + · exact Ordered.OrderNR.trans h₁ h₂ + ord_trans {x y z} h₁ h₂ := by + rcases x, y, z with ⟨_|x, _|y, _|z⟩ <;> simp_all only [optionOrder] + · exact h₁.of_ordR h₂ + · exact Ordered.OrderR.trans h₁ h₂ + ordN_of_ord {x y} n h := by + rcases x, y with ⟨_|x, _|y⟩ <;> simp_all only [optionOrder, optionOrderN] + exact Ordered.OrderR.ordNR n h + +section +attribute [local instance] raOp raPCore raValid raOrdered + +theorem some_ordN_some_iff {n} {a b : α} : some a ≼ₒ{n} some b ↔ a ≡{n}≡ b ∨ a ≼ₒ{n} b := .rfl + +theorem some_ord_some_iff {a b : α} : some a ≼ₒ some b ↔ a = b ∨ a ≼ₒ b := .rfl + +theorem none_ordN_some_iff {n} {b : α} : none ≼ₒ{n} some b ↔ Increasing b := .rfl + +theorem none_ord_some_iff {b : α} : none ≼ₒ some b ↔ Increasing b := .rfl + +theorem not_some_ordN_none {n} {a : α} : ¬some a ≼ₒ{n} none := id + +theorem eq_none_of_ordN_none {n} {ma : Option α} : ma ≼ₒ{n} none → ma = none := + match ma with | none => fun _ => rfl | some _ => False.elim + +theorem exists_of_some_ordN {n} {a : α} {mb : Option α} : + some a ≼ₒ{n} mb → ∃ b, mb = some b ∧ some a ≼ₒ{n} some b := + match mb with | none => False.elim | some b => fun h => ⟨b, rfl, h⟩ + +theorem exists_of_some_ord {a : α} {mb : Option α} : + some a ≼ₒ mb → ∃ b, mb = some b ∧ some a ≼ₒ some b := + match mb with | none => False.elim | some b => fun h => ⟨b, rfl, h⟩ + +theorem not_some_ord_none {a : α} : ¬some a ≼ₒ none := id + +instance instOrderRefl : OrderRefl (Option α) where + ord_refl | none => trivial | some _ => Or.inl rfl + +theorem increasing_some_iff {a : α} : Increasing (some a) ↔ Increasing a where + mp h := h.increasing none + mpr h := ⟨fun | none => h | some b => Or.inr (h.increasing b)⟩ + +instance instIncreasingNone : Increasing (none : Option α) := + ⟨fun | none => trivial | some _ => Or.inl rfl⟩ + +theorem increasing_pcore (x : α) : Increasing (pcore x : Option α) := match h : pcore x with + | none => inferInstance + | some _ => increasing_some_iff.mpr (pcore_increasing h) + +theorem none_ord_pcore (x : α) : none ≼ₒ pcore x := match h : pcore x with + | none => trivial + | some _ => pcore_increasing h + +theorem none_ordN_pcore {n} (x : α) : none ≼ₒ{n} pcore x := Ordered.ordN_of_ord n (none_ord_pcore x) + +theorem pcore_ordN_pcore {n} {x y : α} : x ≼ₒ*{n} y → pcore x ≼ₒ{n} pcore y + | .inl e => (NonExpansive.ne (f := pcore) e).to_ordN + | .inr i => match hx : pcore x with + | none => none_ordN_pcore y + | some _ => let ⟨_, hcy, icy⟩ := pcore_monoN_ord i hx; hcy ▸ Or.inr icy + +theorem pcore_ord_pcore {x y : α} : x ≼ₒ* y → pcore x ≼ₒ pcore y + | .inl rfl => .rfl + | .inr i => match hx : pcore x with + | none => none_ord_pcore y + | some _ => let ⟨_, hcy, icy⟩ := pcore_mono_ord i hx; hcy ▸ Or.inr icy + +theorem pcore_ord_pcore_op (x y : α) : (pcore x : Option α) ≼ₒ pcore (x • y) := + match hx : pcore x with + | none => none_ord_pcore _ + | some _ => let ⟨_, hcxy, i⟩ := pcore_order_op hx y; hcxy ▸ Or.inr i + +end + +end Option + +section +attribute [local instance] Option.raOp Option.raPCore Option.raValid Option.raOrdered + +instance cmraOption : ORA (Option α) where + toOp := Option.raOp + toPCore := Option.raPCore + toValidity := Option.raValid + validN_op_left {n x y} := by + rcases x, y with ⟨_|_, _|_⟩ <;> simp_all only [ValidN, optionValidN, op, optionOp, imp_self, + implies_true] + apply validN_op_left + pcore_op_left {x cx} := by + rcases x, cx with ⟨_|_, _|_⟩ <;> simp_all only [pcore, optionCore, Option.bind_none, op, + optionOp, imp_self, Option.some.injEq, not_none_eqv_some, not_some_eqv_none, implies_true, + Option.bind_some] + intro h; exact pcore_op_left h + extend {n} := by + rintro (_|x) (_|mb1) (_|mb2) Hx Hx' <;> simp only [op, optionOp, Dist.refl, + not_none_dist_some, not_some_dist_none, some_dist_some] at Hx' ⊢ + · exists none, none + · exists none, some x + · exists some x, none + · rcases extend Hx Hx' with ⟨mc1, mc2, hx, h1, h2⟩ + exact ⟨some mc1, some mc2, congrArg some hx, h1, h2⟩ + toOrdered := Option.raOrdered + op_monoN_left_ord {n x y} z h := match x, y, z, h with + | none, none, _, _ => .rfl + | none, some _, none, h => h + | none, some _, some z, h => Or.inr (Increasing.ordN h z) + | some _, none, _, h => False.elim h + | some _, some _, none, h => h + | some _, some _, some z, h => Ordered.OrderNR.op_left z h + op_mono_left_ord {x y} z h := match x, y, z, h with + | none, none, _, _ => .rfl + | none, some _, none, h => h + | none, some _, some z, h => Or.inr (h.increasing z) + | some _, none, _, h => False.elim h + | some _, some _, none, h => h + | some _, some _, some z, h => Ordered.OrderR.op_left z h + validN_of_ordN {n x y} h v := match x, y, h with + | none, _, _ => trivial + | some _, none, h => False.elim h + | some _, some _, h => Ordered.OrderNR.validN h v + pcore_monoN_ord {n x y _} h := by + rintro ⟨⟩ + refine ⟨_, rfl, ?_⟩ + match x, y, h with + | none, none, _ => trivial + | none, some y, _ => exact none_ordN_pcore y + | some _, none, h => exact False.elim h + | some x, some y, h => exact pcore_ordN_pcore h + pcore_mono_ord {x y _} h := by + rintro ⟨⟩ + refine ⟨_, rfl, ?_⟩ + match x, y, h with + | none, none, _ => trivial + | none, some y, _ => exact none_ord_pcore y + | some _, none, h => exact False.elim h + | some x, some y, h => exact pcore_ord_pcore h + pcore_order_op {x _} := by + rintro ⟨⟩ y + refine ⟨_, rfl, ?_⟩ + match x, y with + | none, none => trivial + | none, some y => exact none_ord_pcore y + | some x, none => exact ord_refl _ + | some x, some y => exact pcore_ord_pcore_op x y + pcore_increasing {x _} := by + rintro ⟨⟩ + match x with + | none => exact (inferInstance : Increasing (none : Option α)) + | some x => exact increasing_pcore x + increasing_closed {n x y} h h' := match x, y, h' with + | none, none, _ => inferInstance + | none, some _, .inl e => False.elim e + | none, some _, .inr i => increasing_some_iff.mpr i + | some _, none, .inl e => False.elim e + | some _, none, .inr i => False.elim i + | some _, some _, h' => + increasing_some_iff.mpr ((increasing_some_iff.mp h).of_ordNR (h'.elim .inl id)) + ordN_extend {n x y} v h := match x, y, h with + | none, none, _ => ⟨none, trivial, .rfl⟩ + | none, some _, h => ⟨none, h, .rfl⟩ + | some _, none, h => False.elim h + | some _, some y, .inl e => ⟨some y, Or.inl .rfl, e.symm⟩ + | some _, some _, .inr i => + let ⟨z, hz, ez⟩ := ordN_extend v i + ⟨some z, Or.inr hz, ez⟩ + +instance ucmraOption : UORA (Option α) where + unit := none + unit_valid := trivial + unit_left_id := by rintro ⟨⟩ <;> rfl + pcore_unit := by rfl + ord_refl := ord_refl + +end + +namespace Option + +theorem some_op (a b : α) : some (a • b) = some a • some b := rfl + +theorem some_valid {a : α} : ✓ (some a) ↔ ✓ a := .rfl + +theorem some_validN {n} {a : α} : ✓{n} (some a) ↔ ✓{n} a := .rfl + +theorem pcore_some (a : α) : + pcore (some a) = (some (pcore a) : Option (Option α)) := rfl + +theorem some_core [IsTotal α] (a : α) : some (core a) = core (some a) := by + simp [core, pcore, optionCore] + obtain ⟨c, hc⟩ := IsTotal.total a + simp [hc] + +instance some_core_id (a : α) [CoreId a] : CoreId (some a : Option α) where + core_id := by simp only [pcore_some, Option.some.injEq]; exact CoreId.core_id + +instance none_core_id : CoreId (none : Option α) := ⟨rfl⟩ + +instance option_core_id (ma : Option α) [∀ x : α, CoreId x] : CoreId ma where + core_id := by + rcases ma with _|a + · rfl + · exact (some_core_id a).core_id + +theorem op_none_iff (ma mb : Option α) : ma • mb = none ↔ ma = none ∧ mb = none := by + cases ma <;> cases mb <;> simp [op, optionOp] + +theorem op_isSome (ma mb : Option α) : (ma • mb).isSome ↔ ma.isSome ∨ mb.isSome := by + cases ma <;> cases mb <;> simp [op, optionOp] + +theorem op_none_left_id (a : Option α) : (none : Option α) • a = a := by + cases a <;> rfl + +theorem op_none_right_id (a : Option α) : a • (none : Option α) = a := by + cases a <;> rfl + +theorem dist_of_some_dist_some {n} {x y : α} (H : some x ≡{n}≡ some y) : x ≡{n}≡ y := H + +theorem eq_none_of_op_eq_none_left {x y : Option α} (h : x • y = none) : x = none := by + match x, y with + | none, _ => rfl + | some _, none => simp [op] at h + | some _, some _ => simp [op] at h + +theorem eq_none_of_op_eq_none_right {x y : Option α} (h : x • y = none) : y = none := by + match x, y with + | _, none => rfl + | none, some _ => simp [op] at h + | some _, some _ => simp [op] at h + +theorem op_some_opM_assoc {x y : α} {mz : Option α} : (x • y) •? mz = x •? (some y • mz) := + match mz with | none => rfl | some _ => assoc'.symm + +theorem some_op_opM {a : α} {ma : Option α} : some a • ma = some (a •? ma) := by + rcases ma with ⟨_|_⟩ <;> simp [optionalOp, op] + +theorem opM_opM_assoc {x : α} {y z : Option α} : (x •? y) •? z = x •? (y • z) := by + rcases y, z with ⟨_|_, _|_⟩ <;> simp [optionalOp, op, assoc.symm] + +theorem opM_opM_swap {x : α} {y z : Option α} : (x •? y) •? z = (x •? z) •? y := + opM_opM_assoc.trans <| (congrArg (x •? ·) comm).trans opM_opM_assoc.symm + +theorem opM_map_some {ma₁ ma₂ : Option α} : ma₁ •? ma₂.map some = ma₁ • ma₂ := by + rcases ma₁, ma₂ with ⟨_|_, _|_⟩ <;> rfl + +theorem op_some_opM_assoc_dist {x y : α} {mz : Option α} : (x • y) •? mz ≡{n}≡ x •? (some y • mz) := + match mz with | none => .rfl | some _ => assoc.dist.symm + +theorem exists_op_some_eqv_some (x : Option α) (y : α) : ∃ z, x • some y = some z := + match x with | .none => ⟨y, rfl⟩ | .some w => ⟨w • y, rfl⟩ + +theorem exists_op_some_dist_some {n} (x : Option α) (y : α) : ∃ z, x • some y ≡{n}≡ some z := + exists_op_some_eqv_some x y |>.elim (⟨·, ·.dist⟩) + +theorem not_valid_some_exclN_op_left {n} {x : α} [Exclusive x] {y : α} : ¬✓{n} (some x • some y) := + not_valid_exclN_op_left (α := α) + +theorem exclusiveN_some_left {n} {a : α} [Exclusive a] {mb : Option α} + (h : ✓{n} (some a • mb)) : mb = none := by + cases mb with + | none => rfl + | some b => exact (not_valid_some_exclN_op_left h).elim + +theorem exclusiveN_some_right {n} {a : α} [Exclusive a] {mb : Option α} + (h : ✓{n} (mb • some a)) : mb = none := + exclusiveN_some_left (validN_ne op_commN h) + +theorem exclusive_some_left {a : α} [Exclusive a] {mb : Option α} + (h : ✓ (some a • mb)) : mb = none := + exclusiveN_some_left (n := 0) h.validN + +theorem exclusive_some_right {a : α} [Exclusive a] {mb : Option α} + (h : ✓ (mb • some a)) : mb = none := + exclusiveN_some_right (n := 0) h.validN + +theorem validN_op_unit {n} {x : Option α} (vx : ✓{n} x) : ✓{n} x • unit := by + rcases x with ⟨_|_⟩ <;> trivial + +/-! ### The order on `Option α` -/ +theorem dist_or_ordN_of_some_ordN_some {n} {a b : α} (h : some a ≼ₒ{n} some b) : + a ≡{n}≡ b ∨ a ≼ₒ{n} b := h + +theorem some_ordN_some_of_dist_or_ordN {n} {a b : α} (h : a ≡{n}≡ b ∨ a ≼ₒ{n} b) : + some a ≼ₒ{n} some b := h + +theorem some_ordN_some_of_ordN {n} {a b : α} (h : a ≼ₒ{n} b) : some a ≼ₒ{n} some b := Or.inr h + +theorem some_ordN_some_of_dist {n} {a b : α} (h : a ≡{n}≡ b) : some a ≼ₒ{n} some b := Or.inl h + +theorem isSome_of_some_ordN {n} {a : α} {mb : Option α} (h : some a ≼ₒ{n} mb) : mb.isSome := + match mb, h with + | some _, _ => rfl + | none, h => False.elim h + +theorem eq_or_ord_of_some_ord_some {a b : α} (h : some a ≼ₒ some b) : a = b ∨ a ≼ₒ b := h + +theorem some_ord_some_of_eq_or_ord {a b : α} (h : a = b ∨ a ≼ₒ b) : some a ≼ₒ some b := h + +theorem some_ord_some_of_ord {a b : α} (h : a ≼ₒ b) : some a ≼ₒ some b := Or.inr h + +theorem some_ord_some_of_eq {a b : α} (h : a = b) : some a ≼ₒ some b := Or.inl h + +theorem isSome_of_some_ord {a : α} {mb : Option α} (h : some a ≼ₒ mb) : mb.isSome := + match mb, h with + | some _, _ => rfl + | none, h => False.elim h + +theorem isSome_monoN_ord {n} {ma mb : Option α} (h : ma ≼ₒ{n} mb) : ma.isSome → mb.isSome := by + cases ma with + | none => simp + | some _ => exact fun _ => isSome_of_some_ordN h + +theorem isSome_mono_ord {ma mb : Option α} (h : ma ≼ₒ mb) : ma.isSome → mb.isSome := by + cases ma with + | none => simp + | some _ => exact fun _ => isSome_of_some_ord h + +theorem ord_of_some_ord_some [OrderRefl α] {x y : α} (H : some y ≼ₒ some x) : y ≼ₒ x := + Or.elim H (· ▸ ord_refl y) id + +theorem ordN_of_some_ordN_some [OrderRefl α] {n} {x y : α} (H : some y ≼ₒ{n} some x) : + y ≼ₒ{n} x := + Or.elim H Dist.to_ordN id + +theorem some_ord_some_iff_orderRefl [OrderRefl α] {a b : α} : some a ≼ₒ some b ↔ a ≼ₒ b := + ⟨ord_of_some_ord_some, Or.inr⟩ + +theorem some_ordN_some_iff_orderRefl [OrderRefl α] {n} {a b : α} : + some a ≼ₒ{n} some b ↔ a ≼ₒ{n} b := + ⟨ordN_of_some_ordN_some, Or.inr⟩ + +theorem validN_of_ordN_validN {n} {a b : α} (Hv : ✓{n} a) (Hinc : some b ≼ₒ{n} some a) : + ✓{n} b := + validN_of_ordN (α := Option α) Hinc Hv + +theorem valid_of_ord_valid {a b : α} (Hv : ✓ a) (Hinc : some b ≼ₒ some a) : ✓ b := + valid_of_ord (α := Option α) Hinc Hv + +theorem ord_iff [IncOrd α] {ma mb : Option α} : + ma ≼ₒ mb ↔ + ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ (a = b ∨ a ≼ₒ b) := + match ma, mb with + | none, none => ⟨fun _ => .inl rfl, fun _ => trivial⟩ + | none, some b => ⟨fun _ => .inl rfl, fun _ => IncOrd.increasing b⟩ + | some _, none => ⟨False.elim, nofun⟩ + | some a, some b => ⟨fun h => .inr ⟨a, b, rfl, rfl, h⟩, fun | .inr ⟨_, _, rfl, rfl, h⟩ => h⟩ + +theorem ordN_iff [IncOrd α] {n} {ma mb : Option α} : + ma ≼ₒ{n} mb ↔ + ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ (a ≡{n}≡ b ∨ a ≼ₒ{n} b) := + match ma, mb with + | none, none => ⟨fun _ => .inl rfl, fun _ => trivial⟩ + | none, some b => ⟨fun _ => .inl rfl, fun _ => IncOrd.increasing b⟩ + | some _, none => ⟨False.elim, nofun⟩ + | some a, some b => ⟨fun h => .inr ⟨a, b, rfl, rfl, h⟩, fun | .inr ⟨_, _, rfl, rfl, h⟩ => h⟩ + +theorem ord_iff_orderRefl [IncOrd α] [OrderRefl α] {ma mb : Option α} : + ma ≼ₒ mb ↔ ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ a ≼ₒ b := + ord_iff.trans <| or_congr_right <| exists₂_congr fun _ _ => + and_congr_right fun _ => and_congr_right fun _ => some_ord_some_iff_orderRefl + +theorem ordN_iff_orderRefl [IncOrd α] [OrderRefl α] {n} {ma mb : Option α} : + ma ≼ₒ{n} mb ↔ ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ a ≼ₒ{n} b := + ordN_iff.trans <| or_congr_right <| exists₂_congr fun _ _ => + and_congr_right fun _ => and_congr_right fun _ => some_ordN_some_iff_orderRefl + +theorem eqv_of_ord_exclusive [OrdInc α] [Exclusive (a : α)] {b : α} (H : some a ≼ₒ some b) + (Hv : ✓ b) : a = b := + H.elim id fun h => (not_valid_of_excl_inc (OrdInc.ord_inc h) Hv).elim + +theorem dist_of_ord_exclusive [OrdInc α] [Exclusive (a : α)] {n} {b : α} + (H : some a ≼ₒ{n} some b) (Hv : ✓{n} b) : a ≡{n}≡ b := + H.elim id fun h => (not_valid_of_exclN_inc (OrdInc.ordN_incN h) Hv).elim + +theorem map_mono_ord {β : Type _} [ORA β] [IncOrd β] (f : α → β) {ma mb : Option α} + (hf : ∀ x y : α, x ≼ₒ y → f x ≼ₒ f y) (h : ma ≼ₒ mb) : + ma.map f ≼ₒ mb.map f := + match ma, mb, h with + | none, none, _ => trivial + | none, some b, _ => IncOrd.increasing (f b) + | some a, some b, h => h.elim (fun e => .inl (congrArg f e)) fun i => .inr (hf a b i) + +instance instIncOrd [IncOrd α] : IncOrd (Option α) := IncOrd.of_increasing fun + | none => inferInstance + | some a => increasing_some_iff.mpr (IncOrd.increasing a) + +instance instOrdInc [OrdInc α] : OrdInc (Option α) where + ord_inc {mx my} h := match mx, my, h with + | none, none, _ => ⟨none, rfl⟩ + | none, some b, _ => ⟨some b, rfl⟩ + | some _, some _, .inl e => ⟨none, congrArg some e.symm⟩ + | some _, some _, .inr i => + let ⟨z, hz⟩ := OrdInc.ord_inc i + ⟨some z, congrArg some hz⟩ + ordN_incN {_ mx my} h := match mx, my, h with + | none, none, _ => ⟨none, .rfl⟩ + | none, some b, _ => ⟨some b, .rfl⟩ + | some _, some _, .inl e => ⟨none, OFE.some_dist_some.mpr e.symm⟩ + | some _, some _, .inr i => + let ⟨z, hz⟩ := OrdInc.ordN_incN i + ⟨some z, OFE.some_dist_some.mpr hz⟩ + +instance instIsInc [IsInc α] : IsInc (Option α) := {} + +/-! ### The extension inclusion on `Option α` -/ +theorem some_inc_some_of_dist_opM {n} {x y : α} {mz : Option α} (H : x ≡{n}≡ y •? mz) : + some y ≼{n} some x := + match mz with | none => ⟨none, H⟩ | some z => ⟨some z, H⟩ + +theorem some_ordN_some_of_dist_opM [IncOrd α] {n} {x y : α} {mz : Option α} + (H : x ≡{n}≡ y •? mz) : some y ≼ₒ{n} some x := + IncOrd.incN_ordN (some_inc_some_of_dist_opM H) + +theorem inc_of_some_inc_some [IsTotal α] {x y : α} (H : some y ≼ some x) : + y ≼ x := + let ⟨mz, hmz⟩ := H + match mz with + | none => ⟨core y, (Option.some.inj hmz).trans (op_core y).symm⟩ + | some z => ⟨z, Option.some.inj hmz⟩ + +theorem some_incN_some_iff_some [IsTotal α] {n} {x y : α} : + some y ≼{n} some x → y ≼{n} x + | ⟨none, hmz⟩ => ⟨core y, dist_of_some_dist_some hmz |>.trans (op_core_dist y).symm⟩ + | ⟨some z, hmz⟩ => ⟨z, hmz⟩ + +theorem inc_iff {ma mb : Option α} : + ma ≼ mb ↔ + ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ (a = b ∨ a ≼ b) := by + refine ⟨fun ⟨mc, Hmc⟩ => ?_, ?_⟩ + · rcases ma with _|a + · exact .inl rfl + rcases mb with _|b + · rcases mc with _|c <;> simp [op, optionOp] at Hmc + refine .inr ⟨a, b, rfl, rfl, ?_⟩ + rcases mc with _|c <;> simp only [op, optionOp, Option.some.injEq] at Hmc + · exact .inl Hmc.symm + · exact .inr ⟨c, Hmc⟩ + · rintro (H|⟨_, _, _, _, (H|⟨z, _⟩)⟩) <;> subst_eqs + · exists mb + · exists none + · exists some z + +theorem incN_iff {n} {ma mb : Option α} : + ma ≼{n} mb ↔ + ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ (a ≡{n}≡ b ∨ a ≼{n} b) := by + refine ⟨fun ⟨mc, Hmc⟩ => ?_, ?_⟩ + · rcases ma, mb, mc with ⟨_|_, _|_, _|_⟩ <;> simp_all only [op, optionOp, Dist.refl, + not_none_eqv_some, false_and, and_self, exists_false, or_false, not_none_dist_some, + not_some_dist_none, some_dist_some, Option.some.injEq, not_some_eqv_none, exists_and_left, + exists_eq_left', false_or] + · exact .inl Hmc.symm + · exact .inr ⟨_, Hmc⟩ + · rintro (H|⟨_, _, _, _, (H|⟨z, _⟩)⟩) <;> subst_eqs + · exists mb + · exists none; simp only [op, optionOp, some_dist_some]; exact H.symm + · exists some z + +theorem inc_iff_isTotal [IsTotal α] {ma mb : Option α} : + ma ≼ mb ↔ ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ a ≼ b := + inc_iff.trans <| or_congr_right <| exists₂_congr fun _ _ => and_congr_right fun _ => + and_congr_right fun _ => ⟨fun h => h.elim (· ▸ inc_refl _) id, .inr⟩ + +theorem incN_iff_is_total [IsTotal α] {n} {ma mb : Option α} : + ma ≼{n} mb ↔ ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ a ≼{n} b := + incN_iff.trans <| or_congr_right <| exists₂_congr fun a _ => and_congr_right fun _ => + and_congr_right fun _ => + ⟨fun h => h.elim (⟨core a, ·.symm.trans (op_core_dist a).symm⟩) id, .inr⟩ + +theorem some_incN_some_iff {n} {a b : α} : + some a ≼{n} some b ↔ a ≡{n}≡ b ∨ a ≼{n} b := by + apply incN_iff.trans; simp + +theorem dist_or_incN_of_some_incN_some {n} {a b : α} (h : some a ≼{n} some b) : + a ≡{n}≡ b ∨ a ≼{n} b := some_incN_some_iff.mp h + +theorem some_incN_some_of_dist_or_incN {n} {a b : α} (h : a ≡{n}≡ b ∨ a ≼{n} b) : + some a ≼{n} some b := some_incN_some_iff.mpr h + +theorem some_incN_some_of_incN {n} {a b : α} (h : a ≼{n} b) : some a ≼{n} some b := + some_incN_some_iff.mpr (.inr h) + +theorem some_incN_some_of_dist {n} {a b : α} (h : a ≡{n}≡ b) : some a ≼{n} some b := + some_incN_some_iff.mpr (.inl h) + +theorem isSome_of_some_incN {n} {a : α} {mb : Option α} (h : some a ≼{n} mb) : + mb.isSome := by + rcases incN_iff.mp h with h | ⟨_, _, _, rfl, _⟩ <;> simp_all + +theorem some_inc_some_iff {a b : α} : some a ≼ some b ↔ a = b ∨ a ≼ b := by + apply inc_iff.trans; simp + +theorem eq_or_inc_of_some_inc_some {a b : α} (h : some a ≼ some b) : + a = b ∨ a ≼ b := + some_inc_some_iff.mp h + +theorem some_inc_some_of_eq_or_inc {a b : α} (h : a = b ∨ a ≼ b) : + some a ≼ some b := + some_inc_some_iff.mpr h + +theorem some_inc_some_of_inc {a b : α} (h : a ≼ b) : some a ≼ some b := + some_inc_some_iff.mpr (.inr h) + +theorem some_inc_some_of_eq {a b : α} (h : a = b) : some a ≼ some b := + some_inc_some_iff.mpr (.inl h) + +theorem isSome_of_some_inc {a : α} {mb : Option α} (h : some a ≼ mb) : mb.isSome := by + rcases inc_iff.mp h with h | ⟨_, _, _, rfl, _⟩ <;> simp_all + +theorem isSome_monoN {n} {ma mb : Option α} (h : ma ≼{n} mb) : + ma.isSome → mb.isSome := by + cases ma with + | none => simp + | some _ => exact fun _ => isSome_of_some_incN h + +theorem isSome_mono {ma mb : Option α} (h : ma ≼ mb) : ma.isSome → mb.isSome := by + cases ma with + | none => simp + | some _ => exact fun _ => isSome_of_some_inc h + +theorem eqv_of_inc_exclusive [Exclusive (a : α)] {b : α} (H : some a ≼ some b) + (Hv : ✓ b) : a = b := + (eq_or_inc_of_some_inc_some H).elim id fun h => (not_valid_of_excl_inc h Hv).elim + +theorem dist_of_inc_exclusive [Exclusive (a : α)] {n} {b : α} (H : some a ≼{n} some b) + (Hv : ✓{n} b) : a ≡{n}≡ b := + (dist_or_incN_of_some_incN_some H).elim id fun h => (not_valid_of_exclN_inc h Hv).elim + +theorem some_inc_some_iff_is_total [IsTotal α] {a b : α} : + some a ≼ some b ↔ a ≼ b := + ⟨inc_of_some_inc_some, some_inc_some_of_inc⟩ + +theorem map_mono {β : Type _} [ORA β] (f : α → β) {ma mb : Option α} + (hf : ∀ x y : α, x ≼ y → f x ≼ f y) (h : ma ≼ mb) : + ma.map f ≼ mb.map f := by + rcases inc_iff.mp h with rfl | ⟨a, b, rfl, rfl, hab⟩ + · exact ⟨mb.map f, by cases mb.map f <;> rfl⟩ + · rcases hab with rfl | hab + · exact inc_refl _ + · exact some_inc_some_iff.mpr (.inr (hf a b hab)) + +theorem some_incN_some_iff_is_total [IsTotal α] {n} {a b : α} : + some a ≼{n} some b ↔ a ≼{n} b := + ⟨some_incN_some_iff_some, some_incN_some_of_incN⟩ + +instance {a : α} [IdFree a] [Cancelable a] : Cancelable (some a) := by + refine ⟨@fun n b c Hv He => ?_⟩ + rcases b, c with ⟨_|b, _|c⟩ + · trivial + · exact id_free0_r c (valid0_of_validN Hv) (He.symm.le <| n.zero_le) + · refine id_free0_r b ?_ (He.le <| n.zero_le) + exact valid0_of_validN (He.validN.mp Hv) + · exact cancelableN (α := α) Hv He + +instance {ma : Option α} [∀ a : α, IdFree a] [∀ a : α, Cancelable a] : Cancelable ma := by + rcases ma with ⟨_|_⟩ + constructor + · simp [op] + · infer_instance + +theorem validN_of_incN_validN {n} {a b : α} (Hv : ✓{n} a) (Hinc : some b ≼{n} some a) : + ✓{n} b := + validN_of_incN (α := Option α) Hinc Hv + +theorem valid_of_inc_valid {a b : α} (Hv : ✓ a) (Hinc : some b ≼ some a) : ✓ b := + valid_of_inc (α := Option α) Hinc Hv + +theorem some_inc_some_iff_opM {a b : α} : some a ≼ some b ↔ ∃ mc, b = a •? mc := by + simp only [inc_iff, not_some_eqv_none, Option.some.injEq, exists_and_left, exists_eq_left', + false_or] + constructor + · rintro (Heqv | ⟨mc', Hinc⟩) + · exact ⟨none, by simpa [optionalOp] using Heqv.symm⟩ + · exact ⟨some mc', Hinc⟩ + · rintro ⟨_|z, H⟩ + · exact .inl H.symm + · exact .inr ⟨z, H⟩ + +theorem some_incN_some_iff_opM {n} {a b : α} : + some a ≼{n} some b ↔ ∃ mc, b ≡{n}≡ a •? mc := by + simp only [incN_iff, not_some_eqv_none, Option.some.injEq, exists_and_left, exists_eq_left', + false_or] + constructor + · rintro (H|H) + · exists none; simpa [optionalOp] using H.symm + · rcases H with ⟨mc', H⟩ + exists (some mc') + · rintro ⟨(_|z), H⟩ + · exact .inl H.symm + · right; exists z + +instance [ORA.Discrete α] : ORA.Discrete (Option α) where + discrete_valid {x} := match x with + | none => fun _ => trivial + | some _ => discrete_valid (α := α) + discrete_ord {x y} h := match x, y, h with + | none, none, _ => trivial + | none, some _, h => h + | some _, none, h => False.elim h + | some _, some _, h => + Or.elim h (fun e => Or.inl (OFE.Discrete.discrete_0 e)) + fun i => Or.inr (discrete_ord (α := α) i) + +end Option +end option + +section unit +open ORA + +/-- The classical resource algebra on the one-element type. -/ +@[instance_reducible] def Unit.cmraData : CMRAData Unit where + pcore _ := some () + op _ _ := () + ValidN _ _ := True + Valid _ := True + op_ne.ne _ _ _ := id + pcore_ne _ _ := ⟨(), rfl, .rfl⟩ + validN_ne _ := id + valid_iff_validN := ⟨fun _ _ => ⟨⟩, fun _ => ⟨⟩⟩ + validN_succ := id + validN_op_left := id + assoc := rfl + comm := rfl + pcore_op_left _ := rfl + pcore_idem _ := rfl + extend _ _ := ⟨(), (), rfl, .rfl, .rfl⟩ + pcore_op_mono _ _ := ⟨.unit, rfl⟩ + +instance cmraUnit : CMRA Unit := ofCMRAData Unit.cmraData + +/-- The unique element is the unit of the one-element resource algebra. -/ +@[instance_reducible] def Unit.ucmraData : UCMRAData Unit where + unit := () + unit_valid := ⟨⟩ + unit_left_id := rfl + pcore_unit := rfl + +instance ucmraUnit : UCMRA Unit := UORA.ofUCMRAData Unit.ucmraData + +instance : ORA.Discrete Unit where + discrete_valid _ := ⟨⟩ + +end unit + +section empty +open ORA + +/-- The classical resource algebra on the empty type. -/ +@[instance_reducible] def Empty.cmraData : CMRAData Empty where + pcore x := some x + op x _ := x + ValidN _ _ := False + Valid _ := False + op_ne.ne _ _ _ _ := .rfl + pcore_ne {_ x} := x.elim + validN_ne _ := id + valid_iff_validN {x} := x.elim + validN_succ := id + validN_op_left := id + assoc {x} := x.elim + comm {x} := x.elim + pcore_op_left {x} := x.elim + pcore_idem {x} := x.elim + extend {_ x} := x.elim + pcore_op_mono {x} := x.elim + +instance cmraEmpty : CMRA Empty := ofCMRAData Empty.cmraData + +instance : ORA.Discrete Empty where + discrete_valid := id + +instance (x : Empty) : CoreId x where + core_id := rfl + +instance (x : Empty) : Cancelable x where + cancelableN := x.elim + +end empty + +namespace Prod +open ORA + +variable {α β : Type _} [ORA α] [ORA β] + +/-- The partial core of a pair, defined when both component cores exist. -/ +abbrev pcore (x : α × β) : Option (α × β) := (ORA.pcore x.fst).bind fun a => + (ORA.pcore x.snd).bind fun b => + return (a, b) + +/-- Componentwise composition of a pair of resources. -/ +abbrev op (x y : α × β) : α × β := + (x.1 • y.1, x.2 • y.2) + +/-- A pair is valid at an index when both components are valid there. -/ +abbrev ValidN n (x : α × β) := ✓{n} x.fst ∧ ✓{n} x.snd + +/-- A pair is valid when both components are valid. -/ +abbrev Valid (x : α × β) := ✓ x.fst ∧ ✓ x.snd + +/-- The componentwise step-indexed order on resource pairs. -/ +abbrev OrderN n (x y : α × β) := x.fst ≼ₒ{n} y.fst ∧ x.snd ≼ₒ{n} y.snd + +/-- The componentwise order on resource pairs. -/ +abbrev Order (x y : α × β) := x.fst ≼ₒ y.fst ∧ x.snd ≼ₒ y.snd + +/-- Composition on resource pairs. -/ +@[reducible] +def raOp : Op (α × β) where + op := op + op_ne.ne _ _ _ h := dist_prod_ext (Dist.op_r <| dist_fst h) (Dist.op_r <| dist_snd h) + assoc := equiv_prod_ext assoc assoc + comm := equiv_prod_ext comm comm + +/-- The partial core on resource pairs. -/ +@[reducible] +def raPCore : PCore (α × β) where + pcore := pcore + pcore_ne {n x y cx} h ph := by + have ⟨cx₁, hcx₁, this⟩ := Option.bind_eq_some_iff.mp ph + have ⟨cx₂, hcx₂, hcx⟩ := Option.bind_eq_some_iff.mp this + have ⟨cy₁, hcy₁, hxy₁⟩ := pcore_ne (dist_fst h) hcx₁ + have ⟨cy₂, hcy₂, hxy₂⟩ := pcore_ne (dist_snd h) hcx₂ + suffices g : cx ≡{n}≡ (cy₁, cy₂) by simp [hcy₁, hcy₂, g, pcore] + calc + cx ≡{n}≡ (cx₁, cx₂) := Dist.of_eq (Option.some.inj hcx).symm + _ ≡{n}≡ (cy₁, cy₂) := dist_prod_ext hxy₁ hxy₂ + pcore_idem {x cx} h := by + have ⟨cx₁, hcx₁, this⟩ := Option.bind_eq_some_iff.mp h + have ⟨cx₂, hcx₂, hcx⟩ := Option.bind_eq_some_iff.mp this + have ⟨a, ha, ea⟩ := equiv_some (pcore_idem hcx₁) + have ⟨b, hb, eb⟩ := equiv_some (pcore_idem hcx₂) + have g : (a, b) = (cx₁, cx₂) := equiv_prod_ext ea eb + rw [Option.some.inj hcx.symm] + simp only [ha, hb, pcore] + exact congrArg some g + +/-- Validity on resource pairs. -/ +@[reducible] +def raValid : _root_.Iris.Validity (α × β) where + ValidN := ValidN + Valid := Valid + validN_ne {_} x y H := fun ⟨vx1, vx2⟩ => ⟨H.1.validN.mp vx1, H.2.validN.mp vx2⟩ + valid_iff_validN {x} := by + refine ⟨fun ⟨va, vb⟩ n => ⟨va.validN, vb.validN⟩, fun h => ⟨?_, ?_⟩⟩ + · exact valid_iff_validN.mpr fun n => (h n).left + · exact valid_iff_validN.mpr fun n => (h n).right + validN_succ {x n} := fun ⟨va, vb⟩ => ⟨validN_succ va, validN_succ vb⟩ + +/-- The resource order on resource pairs. -/ +@[reducible] def raOrdered : Ordered (α × β) where + OrderN := OrderN + Order := Order + ordN_ne ex ey h := + ⟨ordN_ne (dist_fst ex) (dist_fst ey) h.1, ordN_ne (dist_snd ex) (dist_snd ey) h.2⟩ + ordN_succ h := ⟨ordN_succ h.1, ordN_succ h.2⟩ + ordN_trans h₁ h₂ := ⟨ordN_trans h₁.1 h₂.1, ordN_trans h₁.2 h₂.2⟩ + ord_trans h₁ h₂ := ⟨ord_trans h₁.1 h₂.1, ord_trans h₁.2 h₂.2⟩ + ordN_of_ord n h := ⟨ordN_of_ord n h.1, ordN_of_ord n h.2⟩ + +section +open ORA +attribute [local instance] raOp raPCore raValid raOrdered + +theorem pcore_eq_some {x cx : α × β} : + ORA.pcore x = some cx ↔ ORA.pcore x.1 = some cx.1 ∧ ORA.pcore x.2 = some cx.2 := by + refine ⟨fun h => ?_, fun ⟨h₁, h₂⟩ => + Option.bind_eq_some_iff.mpr ⟨cx.1, h₁, Option.bind_eq_some_iff.mpr ⟨cx.2, h₂, rfl⟩⟩⟩ + obtain ⟨c₁, h₁, h⟩ := Option.bind_eq_some_iff.mp h + obtain ⟨c₂, h₂, h⟩ := Option.bind_eq_some_iff.mp h + cases Option.some.inj h + exact ⟨h₁, h₂⟩ + +theorem increasing_iff {x : α × β} : Increasing x ↔ Increasing x.1 ∧ Increasing x.2 := ⟨fun h => + ⟨⟨fun y => (h.increasing (y, x.2)).1⟩, ⟨fun y => (h.increasing (x.1, y)).2⟩⟩, + fun ⟨h₁, h₂⟩ => ⟨fun y => ⟨h₁.increasing y.1, h₂.increasing y.2⟩⟩⟩ + +theorem ordNR_fst {n} {x y : α × β} (h : x ≼ₒ*{n} y) : x.1 ≼ₒ*{n} y.1 := h.imp dist_fst And.left +theorem ordNR_snd {n} {x y : α × β} (h : x ≼ₒ*{n} y) : x.2 ≼ₒ*{n} y.2 := h.imp dist_snd And.right + +instance cmraProd : ORA (α × β) where + toOp := raOp + toPCore := raPCore + toValidity := raValid + validN_op_left := fun ⟨va, vb⟩ => ⟨validN_op_left va, validN_op_left vb⟩ + pcore_op_left h := + let ⟨_, ha, ho⟩ := Option.bind_eq_some_iff.mp h + let ⟨_, hb, hh⟩ := Option.bind_eq_some_iff.mp ho + (Option.some.inj hh) ▸ (equiv_prod_ext (pcore_op_left ha) (pcore_op_left hb)) + extend := fun ⟨vx₁, vx₂⟩ e => + let ⟨z₁, w₁, hx₁, hz₁, hw₁⟩ := extend vx₁ (OFE.dist_fst e) + let ⟨z₂, w₂, hx₂, hz₂, hw₂⟩ := extend vx₂ (OFE.dist_snd e) + ⟨(z₁, z₂), (w₁, w₂), equiv_prod_ext hx₁ hx₂, ⟨hz₁, hz₂⟩, ⟨hw₁, hw₂⟩⟩ + toOrdered := raOrdered + op_monoN_left_ord z h := ⟨op_monoN_left_ord z.1 h.1, op_monoN_left_ord z.2 h.2⟩ + op_mono_left_ord z h := ⟨op_mono_left_ord z.1 h.1, op_mono_left_ord z.2 h.2⟩ + validN_of_ordN h v := ⟨validN_of_ordN h.1 v.1, validN_of_ordN h.2 v.2⟩ + pcore_monoN_ord h e := + let ⟨e₁, e₂⟩ := pcore_eq_some.mp e + let ⟨cy₁, hcy₁, i₁⟩ := pcore_monoN_ord h.1 e₁ + let ⟨cy₂, hcy₂, i₂⟩ := pcore_monoN_ord h.2 e₂ + ⟨(cy₁, cy₂), pcore_eq_some.mpr ⟨hcy₁, hcy₂⟩, i₁, i₂⟩ + pcore_mono_ord h e := + let ⟨e₁, e₂⟩ := pcore_eq_some.mp e + let ⟨cy₁, hcy₁, i₁⟩ := pcore_mono_ord h.1 e₁ + let ⟨cy₂, hcy₂, i₂⟩ := pcore_mono_ord h.2 e₂ + ⟨(cy₁, cy₂), pcore_eq_some.mpr ⟨hcy₁, hcy₂⟩, i₁, i₂⟩ + pcore_order_op e y := + let ⟨e₁, e₂⟩ := pcore_eq_some.mp e + let ⟨cxy₁, h₁, i₁⟩ := pcore_order_op e₁ y.1 + let ⟨cxy₂, h₂, i₂⟩ := pcore_order_op e₂ y.2 + ⟨(cxy₁, cxy₂), pcore_eq_some.mpr ⟨h₁, h₂⟩, i₁, i₂⟩ + pcore_increasing e := + let ⟨e₁, e₂⟩ := pcore_eq_some.mp e + increasing_iff.mpr ⟨pcore_increasing e₁, pcore_increasing e₂⟩ + increasing_closed h h' := + let ⟨h₁, h₂⟩ := increasing_iff.mp h + increasing_iff.mpr ⟨increasing_closed h₁ (ordNR_fst h'), increasing_closed h₂ (ordNR_snd h')⟩ + ordN_extend v h := + let ⟨z₁, h₁, e₁⟩ := ordN_extend v.1 h.1 + let ⟨z₂, h₂, e₂⟩ := ordN_extend v.2 h.2 + ⟨(z₁, z₂), ⟨h₁, h₂⟩, dist_prod_ext e₁ e₂⟩ + +end + +theorem valid_fst {x : α × β} (h : ✓ x) : ✓ x.fst := h.left +theorem valid_snd {x : α × β} (h : ✓ x) : ✓ x.snd := h.right + +theorem validN_fst {n} {x : α × β} (h : ✓{n} x) : ✓{n} x.fst := h.left +theorem validN_snd {n} {x : α × β} (h : ✓{n} x) : ✓{n} x.snd := h.right + +attribute [local instance] raOp in +theorem mk_op_mk (a a' : α) (b b' : β) : (a, b) • (a', b') = (a • a', b • b') := rfl + +theorem mk_valid (a : α) (b : β) : ✓ (a, b) ↔ ✓ a ∧ ✓ b := .rfl + +theorem mk_validN {n} (a : α) (b : β) : ✓{n} (a, b) ↔ ✓{n} a ∧ ✓{n} b := .rfl + +theorem mk_pcore (a : α) (b : β) : + ORA.pcore (a, b) = (ORA.pcore a).bind fun c₁ => (ORA.pcore b).bind fun c₂ => some (c₁, c₂) := + rfl + +theorem mk_core [IsTotal α] [IsTotal β] (a : α) (b : β) : + core (a, b) = (core a, core b) := + congrArg (Option.getD · (a, b)) (pcore_eq_some.mpr ⟨pcore_eq_core a, pcore_eq_core b⟩) + +theorem ord_def {x y : α × β} : x ≼ₒ y ↔ x.1 ≼ₒ y.1 ∧ x.2 ≼ₒ y.2 := .rfl + +theorem ordN_def {n} {x y : α × β} : x ≼ₒ{n} y ↔ x.1 ≼ₒ{n} y.1 ∧ x.2 ≼ₒ{n} y.2 := .rfl + +theorem mk_ord_mk (a a' : α) (b b' : β) : (a, b) ≼ₒ (a', b') ↔ a ≼ₒ a' ∧ b ≼ₒ b' := .rfl + +theorem mk_ordN_mk {n} (a a' : α) (b b' : β) : + (a, b) ≼ₒ{n} (a', b') ↔ a ≼ₒ{n} a' ∧ b ≼ₒ{n} b' := .rfl + +theorem inc_def {x y : α × β} : x ≼ y ↔ x.1 ≼ y.1 ∧ x.2 ≼ y.2 := + ⟨fun ⟨z, hz⟩ => ⟨⟨z.1, congrArg Prod.fst hz⟩, ⟨z.2, congrArg Prod.snd hz⟩⟩, + fun ⟨⟨z₁, hz₁⟩, ⟨z₂, hz₂⟩⟩ => ⟨(z₁, z₂), Prod.ext hz₁ hz₂⟩⟩ + +theorem incN_def {n} {x y : α × β} : + x ≼{n} y ↔ x.1 ≼{n} y.1 ∧ x.2 ≼{n} y.2 := + ⟨fun ⟨z, hz⟩ => ⟨⟨z.1, dist_fst hz⟩, ⟨z.2, dist_snd hz⟩⟩, + fun ⟨⟨z₁, hz₁⟩, ⟨z₂, hz₂⟩⟩ => ⟨(z₁, z₂), dist_prod_ext hz₁ hz₂⟩⟩ + +theorem mk_inc_mk (a a' : α) (b b' : β) : + (a, b) ≼ (a', b') ↔ a ≼ a' ∧ b ≼ b' := inc_def + +theorem mk_incN_mk {n} (a a' : α) (b b' : β) : + (a, b) ≼{n} (a', b') ↔ a ≼{n} a' ∧ b ≼{n} b' := incN_def + +instance instIsTotalProd [IsTotal α] [IsTotal β] : IsTotal (α × β) where + total x := + let ⟨ca, ha⟩ := total x.1 + let ⟨cb, hb⟩ := total x.2 + ⟨(ca, cb), pcore_eq_some.mpr ⟨ha, hb⟩⟩ + +instance instCmraDiscreteProd [ORA.Discrete α] [ORA.Discrete β] : ORA.Discrete (α × β) where + discrete_valid v := ⟨discrete_valid v.1, discrete_valid v.2⟩ + discrete_ord h := ⟨discrete_ord h.1, discrete_ord h.2⟩ + +instance instOrderRefl [OrderRefl α] [OrderRefl β] : OrderRefl (α × β) where + ord_refl x := ⟨ord_refl x.1, ord_refl x.2⟩ + +instance instIncOrd [IncOrd α] [IncOrd β] : IncOrd (α × β) := + IncOrd.of_increasing fun x => increasing_iff.mpr ⟨IncOrd.increasing x.1, IncOrd.increasing x.2⟩ + +instance instOrdInc [OrdInc α] [OrdInc β] : OrdInc (α × β) where + ord_inc h := inc_def.mpr (h.imp OrdInc.ord_inc OrdInc.ord_inc) + ordN_incN h := incN_def.mpr (h.imp OrdInc.ordN_incN OrdInc.ordN_incN) + +instance instIsInc [IsInc α] [IsInc β] : IsInc (α × β) := {} + +instance instCoreIdPair {x : α} {y : β} [CoreId x] [CoreId y] : CoreId (x, y) where + core_id := pcore_eq_some.mpr ⟨CoreId.core_id, CoreId.core_id⟩ + +instance instExclusivePairLeft {x : α} [Exclusive x] {y : β} : Exclusive (x, y) where + exclusive0_l z hv := exclusive0_l z.1 hv.1 + +instance instExclusivePairRight {x : α} {y : β} [Exclusive y] : Exclusive (x, y) where + exclusive0_l z hv := exclusive0_l z.2 hv.2 + +instance instCancelablePair {x : α} {y : β} [Cancelable x] [Cancelable y] : Cancelable (x, y) where + cancelableN hv he := ⟨cancelableN hv.1 he.1, cancelableN hv.2 he.2⟩ + +instance instIdFreePairLeft {x : α} [IdFree x] {y : β} : IdFree (x, y) where + id_free0_r z hv he := id_free0_r z.1 hv.1 he.1 + +instance instIdFreePairRight {x : α} {y : β} [IdFree y] : IdFree (x, y) where + id_free0_r z hv he := id_free0_r z.2 hv.2 he.2 + +end Prod + +section ProdUnit +namespace Prod +open ORA + +variable {α β : Type _} [UORA α] [UORA β] + +instance ucmraProd : UORA (α × β) where + unit := (unit, unit) + unit_valid := ⟨unit_valid, unit_valid⟩ + unit_left_id := Prod.ext unit_left_id unit_left_id + pcore_unit := pcore_eq_some.mpr ⟨pcore_unit, pcore_unit⟩ + +theorem mk_split (a : α) (b : β) : (a, b) = ((a, unit) : α × β) • (unit, b) := + Prod.ext unit_right_id.symm unit_left_id.symm + +theorem mk_op_fst (a a' : α) : + ((a • a', unit) : α × β) = ((a, unit) : α × β) • (a', unit) := + Prod.ext rfl unit_left_id.symm + +theorem mk_op_snd (b b' : β) : + ((unit, b • b') : α × β) = ((unit, b) : α × β) • (unit, b') := + Prod.ext unit_left_id.symm rfl + +end Prod +end ProdUnit + +section OptionProd + +open ORA Iris.Option Iris.OFE.Option + +variable {α β : Type _} [ORA α] [ORA β] + +namespace Option + +theorem some_mk_ordN {n} {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ{n} some (a₂, b₂)) : + some a₁ ≼ₒ{n} some a₂ ∧ some b₁ ≼ₒ{n} some b₂ := + h.elim (·.imp .inl .inl) (·.imp .inr .inr) + +theorem some_mk_ordN_left {n} {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ{n} some (a₂, b₂)) : + some a₁ ≼ₒ{n} some a₂ := (some_mk_ordN h).1 + +theorem some_mk_ordN_right {n} {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ{n} some (a₂, b₂)) : + some b₁ ≼ₒ{n} some b₂ := (some_mk_ordN h).2 + +theorem some_mk_ord {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ some (a₂, b₂)) : + some a₁ ≼ₒ some a₂ ∧ some b₁ ≼ₒ some b₂ := + h.elim (fun e => (Prod.mk.inj e).imp .inl .inl) (·.imp .inr .inr) + +theorem some_mk_ord_left {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ some (a₂, b₂)) : + some a₁ ≼ₒ some a₂ := (some_mk_ord h).1 + +theorem some_mk_ord_right {a₁ a₂ : α} {b₁ b₂ : β} (h : some (a₁, b₁) ≼ₒ some (a₂, b₂)) : + some b₁ ≼ₒ some b₂ := (some_mk_ord h).2 + +theorem some_op_ordN_snd {n} {x y : α × β} {c : Option (α × β)} (h : some x • c ≼ₒ{n} some y) : + some x.2 • c.map Prod.snd ≼ₒ{n} some y.2 := by + cases c <;> exact h.imp (·.2) (·.2) + +theorem some_mk_incN {n} {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼{n} some (a₂, b₂)) : + some a₁ ≼{n} some a₂ ∧ some b₁ ≼{n} some b₂ := by + rcases some_incN_some_iff.mp h with hd | hi + · exact ⟨some_incN_some_of_dist hd.1, some_incN_some_of_dist hd.2⟩ + · have ⟨h₁, h₂⟩ := Prod.incN_def.mp hi + exact ⟨some_incN_some_of_incN h₁, some_incN_some_of_incN h₂⟩ + +theorem some_mk_incN_left {n} {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼{n} some (a₂, b₂)) : some a₁ ≼{n} some a₂ := + (some_mk_incN h).1 + +theorem some_mk_incN_right {n} {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼{n} some (a₂, b₂)) : some b₁ ≼{n} some b₂ := + (some_mk_incN h).2 + +theorem some_mk_incN_total_fst [IsTotal α] {n} {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼{n} some (a₂, b₂)) : + a₁ ≼{n} a₂ ∧ some b₁ ≼{n} some b₂ := + let ⟨h₁, h₂⟩ := some_mk_incN h + ⟨some_incN_some_iff_is_total.mp h₁, h₂⟩ + +theorem some_mk_incN_total_snd [IsTotal β] {n} {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼{n} some (a₂, b₂)) : + some a₁ ≼{n} some a₂ ∧ b₁ ≼{n} b₂ := + let ⟨h₁, h₂⟩ := some_mk_incN h + ⟨h₁, some_incN_some_iff_is_total.mp h₂⟩ + +theorem some_mk_inc {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼ some (a₂, b₂)) : + some a₁ ≼ some a₂ ∧ some b₁ ≼ some b₂ := by + rcases some_inc_some_iff.mp h with he | hi + · exact ⟨some_inc_some_of_eq (congrArg Prod.fst he), + some_inc_some_of_eq (congrArg Prod.snd he)⟩ + · have ⟨h₁, h₂⟩ := Prod.inc_def.mp hi + exact ⟨some_inc_some_of_inc h₁, some_inc_some_of_inc h₂⟩ + +theorem some_mk_inc_left {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼ some (a₂, b₂)) : some a₁ ≼ some a₂ := + (some_mk_inc h).1 + +theorem some_mk_inc_right {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼ some (a₂, b₂)) : some b₁ ≼ some b₂ := + (some_mk_inc h).2 + +theorem some_mk_inc_total_fst [IsTotal α] {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼ some (a₂, b₂)) : + a₁ ≼ a₂ ∧ some b₁ ≼ some b₂ := + let ⟨h₁, h₂⟩ := some_mk_inc h + ⟨some_inc_some_iff_is_total.mp h₁, h₂⟩ + +theorem some_mk_inc_total_snd [IsTotal β] {a₁ a₂ : α} {b₁ b₂ : β} + (h : some (a₁, b₁) ≼ some (a₂, b₂)) : + some a₁ ≼ some a₂ ∧ b₁ ≼ b₂ := + let ⟨h₁, h₂⟩ := some_mk_inc h + ⟨h₁, some_inc_some_iff_is_total.mp h₂⟩ + +end Option +end OptionProd + +section OptionMor + +open ORA + +variable {α β : Type _} [ORA α] [ORA β] + +/-- Lift a resource morphism to optional resources. -/ +def Option.mapC (f : α -C> β) : Option α -C> Option β where + toHom := optionMap f.toHom + validN {_ x} h := by cases x with | none => trivial | some a => exact f.validN h + pcore x := by + cases x with | none => rfl | some a => exact congrArg some (f.pcore a) + op x y := by + cases x <;> cases y <;> try rfl + exact congrArg some (f.op ..) + monoN_ord {n x y} h := match x, y, h with + | none, none, _ => trivial + | none, some _, h => f.increasing h + | some _, some _, h => h.imp (f.ne.ne ·) f.monoN_ord + mono_ord {x y} h := match x, y, h with + | none, none, _ => trivial + | none, some _, h => f.increasing h + | some _, some _, h => h.imp (congrArg f) f.mono_ord + increasing {x} h := match x, h with + | none, _ => (inferInstance : Increasing (none : Option β)) + | some _, h => Option.increasing_some_iff.mpr (f.increasing (Option.increasing_some_iff.mp h)) + +end OptionMor + +section ProdMor + +open ORA + +variable [ORA A] [ORA A'] [ORA B] [ORA B'] + +/-- The product of two ordered resource algebra morphisms. -/ +def Prod.mapC (f : A -C> A') (g : B -C> B') : A × B -C> A' × B' where + f := Prod.map f g + ne := inferInstance + validN {n x} := fun ⟨h1, h2⟩ => ⟨f.validN h1, g.validN h2⟩ + pcore x := by + simp [Option.map, Prod.map, ORA.pcore, pcore] + have h2 := g.pcore x.snd + have h1 := f.pcore x.fst + cases _ : ORA.pcore x.fst + · cases _ : ORA.pcore (f.f x.fst) <;> simp_all + · cases _ : ORA.pcore x.snd <;> + cases _ : ORA.pcore (f.f x.fst) <;> + cases _ : ORA.pcore (g.f x.snd) <;> + simp_all + op x y := equiv_prod_ext (f.op x.fst y.fst) (g.op x.snd y.snd) + monoN_ord h := ⟨f.monoN_ord h.1, g.monoN_ord h.2⟩ + mono_ord h := ⟨f.mono_ord h.1, g.mono_ord h.2⟩ + increasing h := + Prod.increasing_iff.mpr <| (Prod.increasing_iff.mp h).imp f.increasing g.increasing + +end ProdMor + +section ProdRF + +open RFunctor + +instance instRFunctorProdOF [RFunctor F1] [RFunctor F2] : RFunctor (ProdOF F1 F2) where + map f g := Prod.mapC (map f g) (map f g) + map_ne.ne _ _ _ Hx _ _ Hy _ := + Prod.map_ne (fun _ => map_ne.ne Hx Hy _) (fun _ => map_ne.ne Hx Hy _) + map_id _ := equiv_prod_ext (map_id _) (map_id _) + map_comp _ _ _ _ _ := + equiv_prod_ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) + +instance instRFunctorAffineProdOF [RFunctor F1] [RFunctor F2] [RFunctorAffine F1] + [RFunctorAffine F2] : RFunctorAffine (ProdOF F1 F2) where + affine := inferInstance + +instance instRFunctorContractiveProdOF + [RFunctorContractive F1] [RFunctorContractive F2] : + RFunctorContractive (ProdOF F1 F2) where + map_contractive.1 H _ := + Prod.map_ne (fun _ => RFunctorContractive.map_contractive.1 H _) + (fun _ => RFunctorContractive.map_contractive.1 H _) + +instance instURFunctorProdOF [URFunctor F1] [URFunctor F2] : URFunctor (ProdOF F1 F2) where + map f g := Prod.mapC (URFunctor.map f g) (URFunctor.map f g) + map_ne.ne _ _ _ Hx _ _ Hy _ := + Prod.map_ne (fun _ => URFunctor.map_ne.ne Hx Hy _) (fun _ => URFunctor.map_ne.ne Hx Hy _) + map_id _ := equiv_prod_ext (URFunctor.map_id _) (URFunctor.map_id _) + map_comp _ _ _ _ _ := + equiv_prod_ext (URFunctor.map_comp _ _ _ _ _) (URFunctor.map_comp _ _ _ _ _) + +instance instURFunctorContractiveProdOF + [URFunctorContractive F1] [URFunctorContractive F2] : + URFunctorContractive (ProdOF F1 F2) where + map_contractive.1 H _ := + Prod.map_ne (fun _ => URFunctorContractive.map_contractive.1 H _) + (fun _ => URFunctorContractive.map_contractive.1 H _) + +end ProdRF + +section optionOF + +variable {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)} + +instance urFunctorOptionOF [RFunctor F] : URFunctor (OptionOF F) where + cmra := ucmraOption + map f g := Option.mapC (RFunctor.map f g) + map_ne.ne := COFE.OFunctor.map_ne.ne + map_id x := COFE.OFunctor.map_id x + map_comp f g f' g' x := COFE.OFunctor.map_comp f g f' g' x + +instance instRFunctorAffineOptionOF [RFunctor F] [RFunctorAffine F] : + RFunctorAffine (OptionOF F) where + affine := inferInstance + +instance urFunctorContractiveOptionOF + [RFunctorContractive F] : URFunctorContractive (OptionOF F) where + map_contractive.1 := COFE.OFunctorContractive.map_contractive.1 + +end optionOF + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean b/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean new file mode 100644 index 0000000000..935aa8514f --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2025 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Sukharik (@suhr), Markus de Medeiros, Puming Liu, Janine Lohse +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.CMRA + +/-! Resource algebra construction from embeddings and discrete data. -/ + +@[expose] public section + +namespace Iris +open OFE + +section CmraMixin + +namespace CMRA +open ORA + +variable {α β : Type _} + +/-- Constructing a CMRA `β` through a mapping into a CMRA `α`. + +The mapping may restrict the domain (i.e., we have an injection from `β` to `α`, not a +bijection) and validity. These two restrictions work on opposite "ends" of `α` according to +`≼`: domain restriction must prove that when an element is in the domain, so is its +composition with other elements; validity restriction must prove that if the composition of +two elements is valid, then so are both of the elements. The "domain" is the image of `g` in +`α`, or equivalently the part of `α` where `f` returns `some`. -/ +@[reducible] +def ofInjRestrictValidity [CMRA α] [OFE β] + (pcore : β → Option β) (op : β → β → β) (Valid : β → Prop) (ValidN : Nat → β → Prop) + (f : α → Option β) (g : β → α) + -- `g` is non-expansive and injective w.r.t. OFE equality + (g_dist : ∀ n (y₁ y₂ : β), y₁ ≡{n}≡ y₂ ↔ g y₁ ≡{n}≡ g y₂) + -- `g` is surjective into the part of `α` where `f` returns `some`, and `f` is its inverse + (gf_dist : ∀ (x : α) (y : β) n, f x ≡{n}≡ some y ↔ g y ≡{n}≡ x) + -- `g` commutes with `pcore` (where it is defined) and with `op` + (g_pcore_dist : ∀ (y cy : β) n, pcore y ≡{n}≡ some cy ↔ ORA.pcore (g y) ≡{n}≡ some (g cy)) + (g_op : ∀ y₁ y₂, g (op y₁ y₂) = g y₁ • g y₂) + -- `g` commutes with `opM` when the right-hand side is produced by `f`, cancelling it + (g_opM_f : ∀ (x : α) (y : β), g ((f x).elim y (op y)) = g y • x) + -- the validity predicate on `β` restricts the one on `α` + (g_validN : ∀ n (y : β), ValidN n y → ✓{n} (g y)) + -- the validity predicate on `β` satisfies the laws of validity + (validN_ne : ∀ n (y₁ y₂ : β), y₁ ≡{n}≡ y₂ → ValidN n y₁ → ValidN n y₂) + (valid_validN : ∀ y : β, Valid y ↔ ∀ n, ValidN n y) + (validN_le : ∀ n n' (y : β), ValidN n y → n' ≤ n → ValidN n' y) + (validN_op_left : ∀ n (y₁ y₂ : β), ValidN n (op y₁ y₂) → ValidN n y₁) : + CMRA β := + have g_ne : ∀ {n} {y₁ y₂ : β}, y₁ ≡{n}≡ y₂ → g y₁ ≡{n}≡ g y₂ := (g_dist ..).mp + have g_eq : ∀ {y₁ y₂ : β}, y₁ = y₂ ↔ g y₁ = g y₂ := + eq_dist.trans <| (forall_congr' fun n => g_dist n _ _).trans eq_dist.symm + have g_pcore : ∀ {y cy : β}, pcore y = some cy ↔ ORA.pcore (g y) = some (g cy) := + eq_dist.trans <| (forall_congr' fun n => g_pcore_dist _ _ n).trans eq_dist.symm + have gf : ∀ {x : α} {y : β}, f x = some y ↔ g y = x := + eq_dist.trans <| (forall_congr' fun n => gf_dist _ _ n).trans eq_dist.symm + have pcore_idem' : ∀ {y cy : β}, pcore y = some cy → pcore cy = some cy := + fun h => g_pcore.mpr <| pcore_idem (g_pcore.mp h) + have pcore_op_left' : ∀ {y cy : β}, pcore y = some cy → op cy y = y := + fun h => g_eq.mpr <| (g_op ..).trans <| pcore_op_left (g_pcore.mp h) + ofCMRAData { + pcore, op, Valid, ValidN + op_ne.ne _ _ _ h := (g_dist ..).mpr <| + (g_op ..).dist.trans <| (g_ne h).op_r.trans (g_op ..).symm.dist + pcore_ne h hcy := + let ⟨c, hc, hcd⟩ := pcore_ne (g_ne h) (g_pcore.mp hcy) + dist_some <| (g_pcore_dist ..).mpr <| hc.dist.trans <| some_dist_some.mpr hcd.symm + validN_ne h hv := validN_ne _ _ _ h hv + valid_iff_validN := valid_validN _ + validN_succ hv := validN_le _ _ _ hv (Nat.le_succ _) + validN_op_left hv := validN_op_left _ _ _ hv + assoc := g_eq.mpr <| by + simp only [g_op] + exact assoc + comm := g_eq.mpr <| (g_op ..).trans <| comm.trans (g_op ..).symm + pcore_op_left := pcore_op_left' + pcore_idem := pcore_idem' + extend := fun hv he => by + obtain ⟨x₁, x₂, hx, hx₁, hx₂⟩ := + extend (g_validN _ _ hv) (((g_dist ..).mp he).trans (g_op ..).dist) + obtain ⟨w₁, hw₁, hd₁⟩ := distSome ((gf_dist ..).mpr hx₁.symm) + obtain ⟨w₂, hw₂, hd₂⟩ := distSome ((gf_dist ..).mpr hx₂.symm) + refine ⟨w₁, w₂, g_eq.mpr ?_, hd₁.symm, hd₂.symm⟩ + rw [g_op, gf.mp hw₁, gf.mp hw₂] + exact hx + pcore_op_mono := fun {y cy} h z => by + obtain ⟨c, hc⟩ := ORA.pcore_op_mono (g_pcore.mp h) (g z) + obtain ⟨w, hw⟩ : ∃ w, (f c).elim cy (op cy) = op cy w := match f c with + | some w => ⟨w, rfl⟩ + | none => ⟨cy, (pcore_op_left' (pcore_idem' h)).symm⟩ + rw [← g_op, ← g_opM_f c cy, hw] at hc + exact ⟨w, g_pcore.mpr hc⟩ } + +/-- Constructing a CMRA through an isomorphism that may restrict validity. -/ +@[reducible] +def ofIsoRestrictValidity [CMRA α] [OFE β] + (pcore : β → Option β) (op : β → β → β) (Valid : β → Prop) (ValidN : Nat → β → Prop) + (f : α → β) (g : β → α) + -- `g` is non-expansive and injective w.r.t. OFE equality + (g_dist : ∀ n (y₁ y₂ : β), y₁ ≡{n}≡ y₂ ↔ g y₁ ≡{n}≡ g y₂) + -- `g` is surjective, and `f` is its inverse + (gf : ∀ x : α, g (f x) = x) + -- `g` commutes with `pcore` and with `op` + (g_pcore : ∀ y : β, ORA.pcore (g y) = (pcore y).map g) + (g_op : ∀ y₁ y₂, g (op y₁ y₂) = g y₁ • g y₂) + -- the validity predicate on `β` restricts the one on `α` + (g_validN : ∀ n (y : β), ValidN n y → ✓{n} (g y)) + -- the validity predicate on `β` satisfies the laws of validity + (validN_ne : ∀ n (y₁ y₂ : β), y₁ ≡{n}≡ y₂ → ValidN n y₁ → ValidN n y₂) + (valid_validN : ∀ y : β, Valid y ↔ ∀ n, ValidN n y) + (validN_le : ∀ n n' (y : β), ValidN n y → n' ≤ n → ValidN n' y) + (validN_op_left : ∀ n (y₁ y₂ : β), ValidN n (op y₁ y₂) → ValidN n y₁) : + CMRA β := + ofInjRestrictValidity pcore op Valid ValidN (fun x => some (f x)) g g_dist + (fun x y n => ⟨fun h => ((g_dist ..).mp h.symm).trans (gf x).dist, + fun h => (g_dist ..).mpr <| (gf x).dist.trans h.symm⟩) + (fun y cy n => by + rw [g_pcore] + cases pcore y with + | none => simp + | some z => exact g_dist n z cy) + g_op (fun x y => (g_op y (f x)).trans <| congrArg (g y • ·) (gf x)) + g_validN validN_ne valid_validN validN_le validN_op_left + +/-- Constructing a CMRA through an isomorphism. -/ +@[reducible] +def ofIso [CMRA α] [OFE β] + (pcore : β → Option β) (op : β → β → β) (Valid : β → Prop) (ValidN : Nat → β → Prop) + (f : α → β) (g : β → α) + -- `g` is non-expansive and injective w.r.t. OFE equality + (g_dist : ∀ n (y₁ y₂ : β), y₁ ≡{n}≡ y₂ ↔ g y₁ ≡{n}≡ g y₂) + -- `g` is surjective, and `f` is its inverse + (gf : ∀ x : α, g (f x) = x) + -- `g` commutes with `pcore`, `op`, `Valid` and `ValidN` + (g_pcore : ∀ y : β, ORA.pcore (g y) = (pcore y).map g) + (g_op : ∀ y₁ y₂, g (op y₁ y₂) = g y₁ • g y₂) + (g_valid : ∀ y : β, ✓ (g y) ↔ Valid y) + (g_validN : ∀ n (y : β), ✓{n} (g y) ↔ ValidN n y) : + CMRA β := + ofIsoRestrictValidity pcore op Valid ValidN f g g_dist gf g_pcore g_op + (fun n y => (g_validN n y).mpr) + (fun n y₁ y₂ h hv => + (g_validN n y₂).mp <| validN_ne ((g_dist ..).mp h) <| (g_validN n y₁).mpr hv) + (fun y => (g_valid y).symm.trans <| + valid_iff_validN.trans <| forall_congr' fun n => g_validN n y) + (fun n n' y hv hle => (g_validN n' y).mp <| validN_of_le hle <| (g_validN n y).mpr hv) + (fun n y₁ y₂ hv => (g_validN n y₁).mp <| validN_op_left <| + g_op y₁ y₂ ▸ (g_validN n (op y₁ y₂)).mpr hv) + +/-- Build a discrete classical resource algebra from unindexed algebraic laws. -/ +@[reducible] +def ofDiscrete [OFE α] [OFE.Discrete α] + (pcore : α → Option α) (op : α → α → α) (Valid : α → Prop) + (assoc : ∀ x y z : α, op x (op y z) = op (op x y) z) + (comm : ∀ x y : α, op x y = op y x) + (pcore_op_left : ∀ x cx : α, pcore x = some cx → op cx x = x) + (pcore_idem : ∀ x cx : α, pcore x = some cx → pcore cx = some cx) + (valid_op_left : ∀ x y : α, Valid (op x y) → Valid x) + (pcore_op_mono : ∀ x cx : α, pcore x = some cx → ∀ y, ∃ cy, pcore (op x y) = some (op cx cy)) : + CMRA α := ofCMRAData { + pcore := pcore + op := op + ValidN _ := Valid + Valid := Valid + op_ne.ne _ _ _ h := (congrArg (op _) (OFE.discrete h)).dist + pcore_ne h hcx := ⟨_, (OFE.discrete h) ▸ hcx, .rfl⟩ + validN_ne h hv := (OFE.discrete h) ▸ hv + valid_iff_validN := (forall_const Nat).symm + validN_succ := id + validN_op_left := valid_op_left _ _ + assoc := assoc .. + comm := comm .. + pcore_op_left := pcore_op_left _ _ + pcore_idem := pcore_idem _ _ + extend _ h := ⟨_, _, OFE.discrete h, .rfl, .rfl⟩ + pcore_op_mono := pcore_op_mono _ _ } + +/-- Build a discrete classical resource algebra whose core is total. -/ +@[reducible] +def ofDiscreteTotal [OFE α] [OFE.Discrete α] + (core : α → α) (op : α → α → α) (Valid : α → Prop) + (assoc : ∀ x y z : α, op x (op y z) = op (op x y) z) + (comm : ∀ x y : α, op x y = op y x) + (core_op_left : ∀ x : α, op (core x) x = x) + (core_idem : ∀ x : α, core (core x) = core x) + (valid_op_left : ∀ x y : α, Valid (op x y) → Valid x) + (core_op_mono : ∀ x y : α, ∃ cy, core (op x y) = op (core x) cy) : + CMRA α := + ofDiscrete (fun x => some (core x)) op Valid assoc comm + (fun _ _ h => Option.some.inj h ▸ core_op_left _) + (fun _ _ h => Option.some.inj h ▸ congrArg some (core_idem _)) + valid_op_left + (fun _ _ h y => Option.some.inj h ▸ (core_op_mono _ y).imp fun _ e => congrArg some e) + +section OfDiscrete + +instance ofDiscrete_discrete [OFE α] [OFE.Discrete α] (pcore : α → Option α) + (op : α → α → α) (Valid : α → Prop) h₁ h₂ h₃ h₄ h₅ h₆ : + @Discrete α (ofDiscrete pcore op Valid h₁ h₂ h₃ h₄ h₅ h₆).toORA := + letI := ofDiscrete pcore op Valid h₁ h₂ h₃ h₄ h₅ h₆ + { discrete_valid := id } + +end OfDiscrete +end CMRA + +/-- Smart constructor for discrete ORA instances. -/ +class DiscreteORAData (α : Type _) where + /-- The partial core operation of the proposed discrete algebra. -/ + pcore : α → Option α + /-- The composition operation of the proposed discrete algebra. -/ + op : α → α → α + /-- The validity predicate of the proposed discrete algebra. -/ + Valid : α → Prop + /-- The resource order of the proposed discrete algebra. -/ + Order : α → α → Prop + assoc : ∀ x y z : α, op x (op y z) = op (op x y) z + comm : ∀ x y : α, op x y = op y x + pcore_op_left : ∀ x cx : α, pcore x = some cx → op cx x = x + pcore_idem : ∀ x cx : α, pcore x = some cx → pcore cx = some cx + valid_op_left : ∀ x y : α, Valid (op x y) → Valid x + ord_trans : ∀ x y z : α, Order x y → Order y z → Order x z + op_mono_left : ∀ x y z : α, Order x y → Order (op x z) (op y z) + valid_of_ord : ∀ x y : α, Order x y → Valid y → Valid x + pcore_mono : ∀ x y cx : α, Order x y → pcore x = some cx → + ∃ cy, pcore y = some cy ∧ Order cx cy + pcore_order_op : ∀ x cx : α, pcore x = some cx → + ∀ y, ∃ cxy, pcore (op x y) = some cxy ∧ Order cx cxy + pcore_increasing : ∀ x cx : α, pcore x = some cx → ∀ y, Order y (op cx y) + increasing_closed : ∀ x y : α, (∀ z, Order z (op x z)) → Order x y → ∀ z, Order z (op y z) + +namespace ORA + +/-- Construct a discrete ordered resource algebra from unindexed laws. -/ +@[reducible] def ofDiscreteORAData [OFE α] [OFE.Discrete α] (d : DiscreteORAData α) : ORA α := + letI : Op α := + { op := d.op + op_ne.ne _ _ _ h := (congrArg (d.op _) (OFE.discrete h)).dist + assoc := d.assoc .. + comm := d.comm .. } + letI : PCore α := + { pcore := d.pcore + pcore_ne h hcx := ⟨_, (OFE.discrete h) ▸ hcx, .rfl⟩ + pcore_idem := d.pcore_idem _ _ } + letI : _root_.Iris.Validity α := + { Valid := d.Valid + ValidN _ := d.Valid + validN_ne h hv := (OFE.discrete h) ▸ hv + valid_iff_validN := (forall_const Nat).symm + validN_succ := id } + letI : Ordered α := + { Order := d.Order + OrderN _ := d.Order + ordN_ne ex ey h := (OFE.discrete ex) ▸ (OFE.discrete ey) ▸ h + ordN_succ := id + ordN_trans := d.ord_trans _ _ _ + ord_trans := d.ord_trans _ _ _ + ordN_of_ord _ := id } + { validN_op_left := d.valid_op_left _ _ + pcore_op_left := d.pcore_op_left _ _ + extend _ h := ⟨_, _, OFE.discrete h, .rfl, .rfl⟩ + op_monoN_left_ord z h := d.op_mono_left _ _ z h + op_mono_left_ord z h := d.op_mono_left _ _ z h + validN_of_ordN := d.valid_of_ord _ _ + pcore_monoN_ord h e := d.pcore_mono _ _ _ h e + pcore_mono_ord h e := d.pcore_mono _ _ _ h e + pcore_order_op e y := d.pcore_order_op _ _ e y + pcore_increasing e := ⟨d.pcore_increasing _ _ e⟩ + increasing_closed {_ x y} hx h := ⟨fun z => match h with + | .inl e => (OFE.discrete e) ▸ hx.increasing z + | .inr ho => d.increasing_closed x y (fun w => hx.increasing w) ho z⟩ + ordN_extend _ h := ⟨_, h, .rfl⟩ } + +instance ofDiscreteORAData_discrete [OFE α] [OFE.Discrete α] (d : DiscreteORAData α) : + @Discrete α (ofDiscreteORAData d) := + letI := ofDiscreteORAData d + { discrete_valid := id, discrete_ord := id } + +end ORA +end CmraMixin +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/COFESolver.lean b/LeanPool/IrisAlgebra/Algebra/COFESolver.lean new file mode 100644 index 0000000000..3854c11f75 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/COFESolver.lean @@ -0,0 +1,321 @@ +/- +Copyright (c) 2025 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Sebastian Graf +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.OFE + +/-! A guarded recursive domain equation solver. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris.COFE.OFunctor +open OFE + +variable {F : ∀ α β [COFE α] [COFE β], Type u} [OFunctorContractive F] +variable [∀ α [COFE α], IsCOFE (F α α)] +variable [inh : Inhabited (F (ULift Unit) (ULift Unit))] + +namespace Fix.Impl + +variable (F) in +/-- The approximation carriers bundled with their complete space structures. -/ +def A' : Nat → Σ α : Type u, COFE α + | 0 => ⟨ULift Unit, inferInstance⟩ + | n+1 => let ⟨A, _⟩ := A' n; ⟨F A A, inferInstance⟩ + +variable (F) in +/-- The carrier at one level of the recursive-domain approximation. -/ +@[implicit_reducible] def A (n : Nat) : Type u := (A' F n).1 + +instance instA' (n) : COFE (A' F n).1 := (A' F n).2 +instance instA (n) : COFE (A F n) := (A' F n).2 + +variable (F) in +/-- The section/retraction pair at every level, computed by a single recursion so +that evaluating either component at level `k` costs `O(k)` (the naive mutual +recursion recomputes both branches at every level, which is `2^k`). -/ +def updown : ∀ k, (A F k -n> A F (k+1)) × (A F (k+1) -n> A F k) + | 0 => (⟨fun _ => inh.default, ⟨fun _ _ _ _ => .rfl⟩⟩, ⟨fun _ => ⟨()⟩, ⟨fun _ _ _ _ => .rfl⟩⟩) + | k+1 => let (u, d) := updown k; (map d u, map u d) + +variable (F) in +/-- The section from one approximation level to its successor. -/ +def up (k : Nat) : A F k -n> A F (k+1) := (updown F k).1 + +variable (F) in +/-- The retraction from a successor approximation to its predecessor. -/ +def down (k : Nat) : A F (k+1) -n> A F k := (updown F k).2 + +theorem down_up : ∀ {k} x, down F k (up F k x) = x + | 0, ⟨()⟩ => rfl + | _+1, x => OFE.eq_dist_2 fun _ => (map_comp _ _ _ _ _).dist.symm.trans <| + Dist.trans + (map_ne.ne (fun y => (down_up y).dist) (fun y => (down_up y).dist) x) + (map_id _).dist + +theorem up_down {k} (x) : up F (k+1) (down F (k+1) x) ≡{k}≡ x := by + refine (map_comp _ _ _ _ _).dist.symm.trans <| .trans ?_ (map_id _).dist + open OFunctorContractive in exact match k with + | 0 => map_contractive.zero (x := (_, _)) (y := (_, _)) _ _ + | k+1 => map_contractive.succ (x := (_, _)) (y := (_, _)) _ ⟨up_down, up_down⟩ _ + +variable (F) in +/-- A family of approximations compatible with all one-step retractions. -/ +@[ext] +structure Tower : Type u where + /-- The approximation at each tower level. -/ + val k : A F k + protected down {k} : down F k (val (k+1)) = val k + +instance : CoeFun (Tower F) (fun _ => ∀ k, A F k) := ⟨Tower.val⟩ + +instance : OFE (Tower F) where + Dist n f g := ∀ k, f k ≡{n}≡ g k + dist_eqv := { + refl _ _ := dist_eqv.refl _ + symm h _ := dist_eqv.symm (h _) + trans h1 h2 _ := dist_eqv.trans (h1 _) (h2 _) + } + eq_dist' {_ _} := by rw [Tower.ext_iff, funext_iff]; simpa only [eq_dist] using forall_comm + dist_lt h1 h2 _ := dist_lt (h1 _) h2 + +/-- Evaluate a chain of coherent towers at one level. -/ +def towerChain (c : Chain (Tower F)) (k : Nat) : Chain (A F k) where + chain i := c.1 i k + cauchy h := c.cauchy h k + +instance : COFE (Tower F) where + compl c := by + refine ⟨fun k => compl ⟨fun i => c.1 i k, fun h => c.cauchy h k⟩, ?_⟩ + refine OFE.eq_dist_2 (fun n => ?_) + refine ((down ..).ne.1 conv_compl).trans <| .trans ?_ conv_compl.symm + exact (c.chain n).down.dist + conv_compl _ := conv_compl + +variable (F) in +/-- Compose the sections through a specified number of approximation levels. -/ +def upN {k} : ∀ n, A F k -n> A F (k + n) + | 0 => .id + | n+1 => (up F (k + n)).comp (upN n) + +variable (F) in +/-- Compose the retractions through a specified number of approximation levels. -/ +def downN {k} : ∀ n, A F (k + n) -n> A F k + | 0 => .id + | n+1 => (downN n).comp (down F (k + n)) + +theorem downN_upN {k} (x : A F k) : ∀ {i}, downN F i (upN F i x) = x + | 0 => rfl + | n+1 => (congrArg (fun a => (downN F n) a) (down_up _)).trans (downN_upN _) + +protected theorem Tower.up (X : Tower F) : up F (k+1) (X (k+1)) ≡{k}≡ X (k+2) := + ((up ..).ne.1 X.down.symm.dist).trans <| up_down _ + +protected theorem Tower.upN (X : Tower F) : ∀ i, upN F i (X (k+1)) ≡{k}≡ X (k+1+i) + | 0 => .rfl + | n+1 => by + have : ∀ j, k+n+1 = j → up F j (X j) ≡{k}≡ X (j+1) := by + rintro _ rfl; exact X.up.le (Nat.le_add_right ..) + exact ((up ..).ne.1 (X.upN _)).trans <| this _ (Nat.add_right_comm ..) + +protected theorem Tower.downN (X : Tower F) : ∀ i, downN F i (X (k+i)) = X k + | 0 => rfl + | _+1 => (congrArg (fun a => (downN ..) a) X.down).trans (X.downN _) + +instance (k : Nat) : NonExpansive (fun X : Tower F => X.val k) := ⟨fun _ _ _ => (· _)⟩ + +/-- Project a coherent tower to one approximation level. -/ +def Tower.proj (k) : Tower F -n> A F k := ⟨(· k), ⟨fun _ _ _ => (· _)⟩⟩ + +/-- Transport an approximation along an equality of its level indices. -/ +def eqToHom (e : i = k) : A F i -n> A F k := e ▸ .id + +theorem eqToHom_up {k k'} {x : A F k} (e : k = k') : + eqToHom (congrArg Nat.succ e) (up F k x) = up F k' (eqToHom e x) := by + cases e; rfl + +theorem down_eqToHom {k k'} {x : A F (k + 1)} (e : k = k') : + down F k' (eqToHom (congrArg Nat.succ e) x) = eqToHom e (down F k x) := by + cases e; rfl + +/-- Embed or retract between any two approximation levels. -/ +def embed : A F k -n> A F i := + if h : k ≤ i then (eqToHom (Nat.add_sub_cancel' h)).comp (upN ..) + else (downN ..).comp (eqToHom (Nat.add_sub_cancel' (Nat.le_of_not_ge h)).symm) + +/-- Extend one approximation to a coherent tower. -/ +protected def Tower.embed (k) : A F k -n> Tower F := by + refine ⟨fun n => ⟨fun _ => embed n, fun {i} => ?_⟩, ⟨fun _ _ _ h _ => embed.ne.1 h⟩⟩ + dsimp [embed]; split <;> rename_i h₁ + · split <;> rename_i h₂ + · suffices ∀ a b (e₁ : k+a = i+1) (e₂ : k+b = i), + down F i (eqToHom e₁ (upN F a n)) = eqToHom e₂ (upN F b n) from this _ _ _ _ + rintro a _ eq rfl + rw [Nat.add_assoc, Nat.add_left_cancel_iff] at eq; subst a + exact down_up _ + · cases (Nat.lt_or_eq_of_le h₁).resolve_left (h₂ ∘ Nat.lt_succ_iff.1) + have {a b} (e₁ : i+1+a = i+1) (e₂ : i+1 = i+b) : + down F i (eqToHom e₁ (upN F a n)) = downN F b (eqToHom e₂ n) := by + cases Nat.add_left_cancel (k := 0) e₁; cases Nat.add_left_cancel e₂ + rfl + apply this + · rw [dite_eq_right (mt Nat.le_succ_of_le h₁)] + suffices ∀ k a b (e₁ : k = i+1+a) (e₂ : k = i+b) (n : A F k), + down F i (downN F a (eqToHom e₁ n)) = downN F b (eqToHom e₂ n) from this _ _ _ _ _ _ + rintro k a b eq rfl n + rw [Nat.add_assoc, Nat.add_left_cancel_iff, Nat.add_comm] at eq; subst eq + change _ = downN F a (down F (i+a) n) + induction a with + | zero => rfl + | succ a ih => + dsimp [downN, Hom.comp] + rw [down_eqToHom (Nat.add_right_comm i a 1)] + apply ih + +theorem Tower.embed_up (x : A F k) : + Tower.embed (k+1) (up F k x) = Tower.embed k x := by + refine OFE.eq_dist_2 (fun (n : Nat) i => ?_) + dsimp [Tower.embed, embed]; split <;> rename_i h₁ + · simp only [Hom.comp_apply, Nat.le_of_succ_le h₁, ↓reduceDIte] + suffices ∀ a b (e₁ : k + 1 + a = i) (e₂ : k+b = i), + eqToHom e₁ (upN F a (up F k x)) = eqToHom e₂ (upN F b x) from this .. ▸ .rfl + rintro a b eq rfl + rw [Nat.add_right_comm, Nat.add_assoc, Nat.add_left_cancel_iff] at eq; subst b + change _ = up F (k + a) (upN F a x); clear h₁ + induction a with + | zero => rfl + | succ a ih => + dsimp [upN, Hom.comp] + rw [eqToHom_up (by omega : k + 1 + a = k + (a + 1))]; congr 1; apply ih + · split <;> rename_i h₂ + · cases Nat.le_antisymm h₂ (Nat.not_lt.1 h₁) + have {a b} {e₁ : k+1 = k+a} {e₂ : k+b = k+0} : + downN F a (eqToHom e₁ (up F k x)) ≡{n}≡ eqToHom e₂ (upN F b x) := by + cases Nat.add_left_cancel e₁; cases Nat.add_left_cancel e₂ + exact (down_up _).dist + exact this + · dsimp [Hom.comp] + suffices ∀ a b (e₁ : k + 1 = i + a) (e₂ : k = i + b), + downN F a (eqToHom e₁ (up F k x)) ≡{n}≡ + downN F b (eqToHom e₂ x) from this .. + rintro a b eq rfl; cases Nat.add_left_cancel (m := b+1) eq + exact (downN ..).ne.1 (down_up x).dist + +theorem Tower.embed_self (X : Tower F) : + Tower.embed (k+1) (X (k+1)) ≡{k}≡ X := by + refine fun i => ?_ + dsimp [Tower.embed, embed]; split <;> rename_i h₁ + · refine ((eqToHom _).ne.1 (X.upN _)).trans ?_ + suffices ∀ a e, eqToHom e (X a) = X i from this .. ▸ .rfl + rintro _ rfl; rfl + · suffices ∀ a e, downN F a (eqToHom e (X (k + 1))) ≡{k}≡ X i from this .. + rintro (_|a) eq + · cases show k+1=i from eq; exact .rfl + · cases show k=i+a from Nat.succ.inj eq + exact (X.downN _).dist + +instance : Inhabited (Tower F) := ⟨Tower.embed 0 ⟨()⟩⟩ + +/-- The Cauchy chain of functor images used to unfold a coherent tower. -/ +def unfoldChain (X : Tower F) : Chain (F (Tower F) (Tower F)) where + chain n := map (Tower.proj _) (Tower.embed _) (X (n+1)) + cauchy {n i} h := by + obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h; clear h + induction k with + | zero => exact .rfl + | succ k ih => + exact (((map ..).ne.1 X.up).le (Nat.le_add_right ..)).symm.trans <| + (map_comp _ _ _ _ _).dist.symm.trans <| + (map_ne.ne (·.down.dist) (fun Y => (Tower.embed_up Y).dist) _).trans ih + +/-- The explicit isomorphism between a coherent tower and its functor image. -/ +def Tower.isoAux : OFE.Iso (F (Tower F) (Tower F)) (Tower F) where + hom.f X := { + val n := (down F n).comp (map (Tower.embed _) (Tower.proj _)) X + down {n} := OFE.eq_dist_2 fun m => (down ..).ne.1 <| + (map_comp _ _ _ _ _).dist.symm.trans <| + map_ne.ne (fun Y => (Tower.embed_up Y).dist) (fun Y => Y.down.dist) _ + } + hom.ne.1 _ _ _ h _ := by dsimp only; exact (Hom.ne _).1 h + inv.f X := compl (unfoldChain X) + inv.ne.1 n _ _ h := by + refine conv_compl.trans <| .trans ?_ conv_compl.symm + exact (map ..).ne.1 (h (n+1)) + hom_inv {X} := OFE.eq_dist_2 fun n => by + intro k + refine ((down ..).ne.1 (.trans ?_ (X.downN n).dist)).trans X.down.dist + refine ((map ..).ne.1 (conv_compl.trans + ((unfoldChain ..).cauchy (show n ≤ k+n+1 by omega)).symm)).trans ?_ + refine (((map ..).comp _).ne.1 (X.up.le (Nat.le_add_left ..)).symm).trans ?_ + refine ((map_comp _ _ _ _ _).trans + (congrArg (fun a => (map ..) a) (map_comp _ _ _ _ _))).symm.dist.trans ?_ + refine .trans (y := map (upN F n) (downN F n) (X (k+n+1))) ?_ ?_ + · refine map_ne.ne (fun Y => ?_) (fun Y => ?_) _ + · simp only [Hom.comp, proj, Tower.embed, embed, Function.comp_apply, (by omega : k ≤ k + n + + 1), ↓reduceDIte] + have {a e} : down F (k + n) (eqToHom e (upN F a Y)) = upN F n Y := by + cases Nat.add_left_cancel (k := n+1) e; exact down_up _ + exact this.dist + · simp only [Hom.comp, proj, Tower.embed, embed, Function.comp_apply, show ¬k + n + 1 ≤ k by + omega, ↓reduceDIte] + have {a e} : downN F a (eqToHom e (up F (k + n) Y)) = downN F n Y := by + cases Nat.add_left_cancel (m := n+1) e; exact congrArg (fun a => (downN ..) a) (down_up _) + exact this.dist + · have e : k+n+1 = k+1+n := by omega + suffices ∀ x y, eqToHom e x = y → ∀ m, map (upN F n) (downN F n) x ≡{m}≡ downN F n y by + refine this _ _ ?_ n + clear this; revert e; generalize k+1+n = a; rintro rfl; rfl + rintro x _ rfl m + induction n with + | zero => exact (map_id _).dist + | succ n ih => + refine (map_comp _ _ _ _ _).dist.trans <| + (ih (Nat.succ.inj e) _).trans (congrArg (fun a => (downN ..) a) ?_).dist + exact (down_eqToHom _).symm + inv_hom := OFE.eq_dist_2 fun n => by + refine (conv_compl' n.le_succ).trans ?_ + dsimp [unfoldChain]; rw [down] + refine ((map_comp _ _ _ _ _).trans + (congrArg (fun a => (map ..) a) (map_comp _ _ _ _ _))).dist.symm.trans ?_ + refine (map_ne.ne (fun Y => ?_) (fun Y => ?_) _).trans (map_id _).dist + · exact ((Tower.embed _).ne.1 Y.up).trans (Y.embed_self.le (by omega)) + · exact ((Tower.embed _).ne.1 Y.down.dist).trans Y.embed_self + +/-- The tower isomorphism, kept irreducible during elaboration. -/ +@[irreducible] def Tower.iso : OFE.Iso (F (Tower F) (Tower F)) (Tower F) := Tower.isoAux + +end Fix.Impl +open Fix.Impl + +variable (F) in +/-- The recursive domain constructed as a tower of finite approximations. -/ +def Fix : Type u := Tower F + +instance : Inhabited (Fix F) := inferInstanceAs (Inhabited (Tower F)) +instance : COFE (Fix F) := inferInstanceAs (COFE (Tower F)) + +/-- The isomorphism from the functor image to the constructed recursive domain. -/ +def Fix.iso : OFE.Iso (F (Fix F) (Fix F)) (Fix F) := Tower.iso + +/-- Fold a functor value into the constructed recursive domain. -/ +def Fix.fold : F (Fix F) (Fix F) -n> Fix F := Fix.iso.hom + +/-- Unfold a recursive-domain value into its functor image. -/ +def Fix.unfold : Fix F -n> F (Fix F) (Fix F) := Fix.iso.inv +theorem Fix.fold_unfold (X : Fix F) : Fix.fold (Fix.unfold X) = X := Fix.iso.hom_inv +theorem Fix.unfold_fold (X : F (Fix F) (Fix F)) : Fix.unfold (Fix.fold X) = X := + Fix.iso.inv_hom + +attribute [irreducible] Fix Fix.fold Fix.unfold Fix.iso + +end OFunctor + +end COFE + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/GenMap.lean b/LeanPool/IrisAlgebra/Algebra/GenMap.lean new file mode 100644 index 0000000000..5b98062375 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/GenMap.lean @@ -0,0 +1,500 @@ +/- +Copyright (c) 2025 The Iris-Lean Contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Markus de Medeiros, Janine Lohse +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.OFE +public import LeanPool.IrisAlgebra.Algebra.CMRA +public import LeanPool.IrisAlgebra.Algebra.Updates + +/-! Finite-support ghost maps and their resource algebras. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris +open OFE + +section GenMap + +/-! ## GenMap + +The OFE over gmaps is equivalent to a non-dependent discrete function to an `Option` type with a +OFE of keys, and a finite number of allocated elements. + +In this setting, the ORA is always unital, and as a consequence the oFunctors do not require +unitality in order to act as a `URFunctor(Contractive)`. + +GenMap is only intended to be used in the construction of the core IProp model. +It is a stripped-down version of the generic heap constructions, which you should +use instead. -/ +/-- Replace the value of a natural-number-indexed function at one key. -/ +def alter (f : Nat → β) (a : Nat) (b : β) : Nat → β := + fun a' => if a = a' then b else f a' + +/-- A GenMap is a partial map from `Nat` to `β` with finite support. +The `bound` field witnesses that all keys ≥ some `N` map to `none`. -/ +structure GenMap (β : Type _) where + /-- The optional value stored at each natural-number key. -/ + car : Nat → Option β + bound : ∃ N, ∀ k, N ≤ k → car k = none + +instance : CoeFun (GenMap β) (fun _ => Nat → Option β) where + coe := GenMap.car + +/-- Replace one ghost-map entry while preserving bounded support. -/ +nonrec def GenMap.alter (g : GenMap β) (a : Nat) (b : Option β) : GenMap β where + car := alter g.car a b + bound := by + obtain ⟨N, hN⟩ := g.bound + refine ⟨max N (a + 1), fun k hk => ?_⟩ + simp only [Iris.alter] + split + next heq => subst heq; omega + next => exact hN k (by omega) + +/-- The ghost map with no allocated keys. -/ +def GenMap.empty : GenMap β := ⟨fun _ => none, ⟨0, fun _ _ => rfl⟩⟩ + +/-- The ghost map allocating one value at one key. -/ +def GenMap.singleton (x : Nat) (y : β) : GenMap β := + empty.alter x y + +theorem GenMap.empty_map_lookup (γ : Nat) : (GenMap.empty : GenMap β).car γ = none := rfl + +theorem GenMap.singleton_map_in (x : Nat) (y : β) : + (GenMap.singleton x y).car x = some y := by + simp [GenMap.singleton, GenMap.alter, GenMap.empty, Iris.alter] + +theorem GenMap.singleton_map_none {x : Nat} {y : β} {x' : Nat} (h : x' ≠ x) : + (GenMap.singleton x y).car x' = none := by + simp only [singleton, alter, empty, Iris.alter, ite_eq_right_iff, reduceCtorEq, imp_false] + rintro rfl + contradiction + +/-- Any GenMap has a fresh key (one mapping to `none`). -/ +theorem GenMap.exists_fresh (g : GenMap β) : ∃ k, g.car k = none := by + obtain ⟨N, hN⟩ := g.bound + exact ⟨N, hN N (Nat.le_refl N)⟩ + +/-- Given a GenMap and a predicate that is satisfied by infinitely many naturals +(witnessed by: for any N, there exists k ≥ N with P k), we can find a fresh key +satisfying P. -/ +theorem GenMap.exists_fresh_sat (g : GenMap β) {P : Nat → Prop} + (hP : ∀ N, ∃ k, N ≤ k ∧ P k) : ∃ k, g.car k = none ∧ P k := by + obtain ⟨N, hN⟩ := g.bound + obtain ⟨k, hk_ge, hk_P⟩ := hP N + exact ⟨k, hN k hk_ge, hk_P⟩ + +/-- `IsFree f a` means key `a` maps to `none` in `f`. Retained for compatibility +with downstream proofs that pattern-match on this. -/ +def IsFree {β : α → Type _} (f : (a : α) → Option (β a)) : α → Prop := + fun a => f a = none + +/-! ## OFE -/ + +section OFE +variable (β : Type _) [OFE β] + +instance instOFEGenMap : OFE (GenMap β) where + Dist n := (·.car ≡{n}≡ ·.car) + dist_eqv.refl _ := Dist.of_eq rfl + dist_eqv.symm := Dist.symm + dist_eqv.trans := Dist.trans + eq_dist' {x y} := by + refine ⟨fun h _ => h ▸ .rfl, fun h => ?_⟩ + obtain ⟨cx, bx⟩ := x; obtain ⟨cy, by'⟩ := y + have : cx = cy := eq_dist_2 h + subst this; rfl + dist_lt := Dist.lt +end OFE + +theorem GenMap.singleton_discreteE {v : β} [OFE β] [DiscreteE v] : + DiscreteE (GenMap.singleton (β := β) k v) where + discrete {y} H := OFE.eq_dist_2 <| by + intro n γ' + specialize H γ' + simp only [GenMap.singleton, GenMap.alter, GenMap.empty, Iris.alter] at H ⊢ + split + · next heq => simp only [heq, ite_true] at H ⊢; exact (Option.some_is_discrete.discrete H).dist + · next hne => simp only [hne, ite_false] at H ⊢; exact (Option.none_is_discrete.discrete H).dist + +theorem GenMap.empty_discreteE [OFE β] : DiscreteE (GenMap.empty (β := β)) where + discrete {y} H := OFE.eq_dist_2 <| by + intro n γ' + specialize H γ' + simp only [GenMap.empty] at H ⊢ + exact (Option.none_is_discrete.discrete H).dist + +@[ext] theorem GenMap.ext {a b : GenMap β} (h : a.car = b.car) : a = b := by + obtain ⟨ca, ba⟩ := a + obtain ⟨cb, bb⟩ := b + simp only [] at h; subst h; rfl + +theorem GenMap.alter_of_lookup {g : GenMap β} {x : Nat} {y : Option β} (h : g.car x = y) : + g.alter x y = g := + GenMap.ext <| funext fun k => by + simp only [alter, Iris.alter] + grind + +theorem GenMap.alter_alter (g : GenMap β) (x : Nat) (y y' : Option β) : + (g.alter x y).alter x y' = g.alter x y' := + GenMap.ext <| funext fun _ => by simp only [alter, Iris.alter]; split <;> rfl + +/-! ## ORA -/ + +section ORA +open ORA GenMap + +variable (β : Type _) [ORA β] + +theorem op_bound (x y : GenMap β) : + ∃ N, ∀ k, N ≤ k → (x.car • y.car) k = none := by + obtain ⟨Nx, hx⟩ := x.bound + obtain ⟨Ny, hy⟩ := y.bound + refine ⟨max Nx Ny, fun k hk => ?_⟩ + simp [op, optionOp, hx k (by omega), hy k (by omega)] + +theorem pcore_bound (x : GenMap β) (cx : Nat → Option β) + (hpc : pcore x.car = some cx) : + ∃ N, ∀ k, N ≤ k → cx k = none := by + obtain ⟨N, hN⟩ := x.bound + have hcx : cx = fun k => core (x.car k) := (Option.some.inj hpc).symm + refine ⟨N, fun k hk => ?_⟩ + rw [hcx] + simp [core, pcore, optionCore, hN k hk] + +theorem extend_bound {n : Nat} {x : GenMap β} + {y1 y2 : Nat → Option β} (Hv : ✓{n} x.car) (He : x.car ≡{n}≡ y1 • y2) : + let F k := extend (Hv k) (He k) + (∃ N, ∀ k, N ≤ k → (fun k => (F k).1) k = none) ∧ + (∃ N, ∀ k, N ≤ k → (fun k => (F k).2.1) k = none) := by + obtain ⟨N, hN⟩ := x.bound + have aux : ∀ k, N ≤ k → ∀ (z₁ z₂ : Option β), + x.car k = z₁ • z₂ → z₁ = none ∧ z₂ = none := by + intro k hk z₁ z₂ hp1 + have h : none = z₁ • z₂ := (hN k hk) ▸ hp1 + cases z₁ <;> cases z₂ + · exact ⟨rfl, rfl⟩ + all_goals exact absurd h (by simp [op, optionOp]) + constructor + · exact ⟨N, fun k hk => (aux k hk _ _ (extend (Hv k) (He k)).2.2.1).1⟩ + · exact ⟨N, fun k hk => (aux k hk _ _ (extend (Hv k) (He k)).2.2.1).2⟩ + +/-- The total partial-core operation on finite-support ghost maps. -/ +def pcoreGenMap (x : GenMap β) : Option (GenMap β) := some ⟨fun k => core (x.car k), by + obtain ⟨N, hN⟩ := x.bound + refine ⟨N, fun k hk => ?_⟩ + simp [core, pcore, optionCore, hN k hk]⟩ + +/-- Composition on finite-support ghost maps. -/ +@[reducible] def GenMap.raOp : Op (GenMap β) where + op x y := ⟨x.car • y.car, op_bound β x y⟩ + op_ne.ne {_ _ _} H := op_ne (α := Nat → Option β) |>.ne H + assoc {x y z} := OFE.eq_dist_2 fun _ a => by + cases _ : x.car a <;> cases _ : y.car a <;> cases _ : z.car a <;> + simp_all only [op, optionOp, Dist.refl, some_dist_some] + exact assoc.dist + comm {x y} := OFE.eq_dist_2 fun _ a => by + cases _ : x.car a <;> cases _ : y.car a <;> + simp_all only [op, optionOp, Dist.refl, some_dist_some] + exact comm.dist + +/-- The partial core on finite-support ghost maps. -/ +@[reducible] def GenMap.raPCore : PCore (GenMap β) where + pcore := pcoreGenMap β + pcore_ne {n x y cx} H Hm := by + refine ⟨⟨fun k => core (y.car k), ?_⟩, by simp [pcoreGenMap], fun k => ?_⟩ + · obtain ⟨N, hN⟩ := y.bound + exact ⟨N, fun k hk => by simp [core, pcore, optionCore, hN k hk]⟩ + · suffices hcx : cx.car = fun k => core (x.car k) by rw [hcx]; exact (H k).core + simp only [pcoreGenMap, Option.some.injEq] at Hm + exact (congrArg GenMap.car Hm).symm + pcore_idem {x _} H := by + obtain rfl := Option.some.inj H + exact congrArg some (GenMap.ext (funext fun k => core_idem (x.car k))) + +/-- Validity on finite-support ghost maps. -/ +@[reducible] def GenMap.raValid : _root_.Iris.Validity (GenMap β) where + ValidN n x := ✓{n} x.car + Valid x := ✓ x.car + validN_ne {_n _x _y H} := Dist.validN H |>.mp + valid_iff_validN {_x} := ⟨fun Hv _ => Hv.validN, fun H => valid_iff_validN.mpr (H ·)⟩ + validN_succ {_x _n} := validN_succ + +/-- The resource order on finite-support ghost maps. -/ +@[reducible] def GenMap.raOrdered : Ordered (GenMap β) where + OrderN n x y := x.car ≼ₒ{n} y.car + Order x y := x.car ≼ₒ y.car + ordN_ne ex ey h := ordN_ne ex ey h + ordN_succ := ordN_succ + ordN_trans := ordN_trans + ord_trans := ord_trans + ordN_of_ord n h := ordN_of_ord n h + +section +attribute [local instance] GenMap.raOp GenMap.raPCore GenMap.raValid GenMap.raOrdered + +@[simp] theorem GenMap.op_car (x y : GenMap β) : (x • y).car = x.car • y.car := rfl + +theorem GenMap.increasing_apply {x : GenMap β} (h : Increasing x) (k : Nat) : + Increasing (x.car k) where + increasing b := by + simpa [alter, Iris.alter, DiscreteFun.op_apply] using h.increasing (empty.alter k b) k + +theorem GenMap.increasing_car {x : GenMap β} (h : Increasing x) : Increasing x.car := + DiscreteFun.increasing_iff.mpr (increasing_apply β h) + +theorem GenMap.increasing_of_car {x : GenMap β} (h : Increasing x.car) : Increasing x where + increasing z := h.increasing z.car + +instance instORAGenMap : ORA (GenMap β) where + toOp := GenMap.raOp β + toPCore := GenMap.raPCore β + toValidity := GenMap.raValid β + validN_op_left {n x y} h := validN_op_left (x := x.car) (y := y.car) h + pcore_op_left {x _} H := by + obtain rfl := Option.some.inj H + exact GenMap.ext (funext fun k => core_op (x.car k)) + extend {n x y1 y2} := by + intro Hv H + have eb := extend_bound β Hv H + let F k := extend (Hv k) (H k) + exact ⟨⟨fun k => (F k).1, eb.1⟩, ⟨fun k => (F k).2.1, eb.2⟩, + OFE.eq_dist_2 fun _ k => ((F k).2.2.1).dist, fun k => (F k).2.2.2.1, fun k => (F k).2.2.2.2⟩ + toOrdered := GenMap.raOrdered β + op_monoN_left_ord z h := op_monoN_left_ord z.car h + op_mono_left_ord z h := op_mono_left_ord z.car h + validN_of_ordN {_ x y} h v := validN_of_ordN (x := x.car) (y := y.car) h v + pcore_monoN_ord {_ x y _} h e := by + obtain rfl := Option.some.inj e + exact ⟨_, rfl, core_ordN_core (x := x.car) (y := y.car) h⟩ + pcore_mono_ord {x y _} h e := by + obtain rfl := Option.some.inj e + exact ⟨_, rfl, core_mono_ord (x := x.car) (y := y.car) h⟩ + pcore_order_op {x _} e y := by + obtain rfl := Option.some.inj e + exact ⟨_, rfl, core_op_mono_ord x.car y.car⟩ + pcore_increasing {x _} e := by + obtain rfl := Option.some.inj e + exact increasing_of_car β (inferInstance : Increasing (core x.car)) + increasing_closed h h' := increasing_of_car β (increasing_closed (increasing_car β h) h') + ordN_extend {n x y} v h := + let ⟨z, hz, ez⟩ := ordN_extend v h + let ⟨N, hN⟩ := x.bound + ⟨⟨z, N, fun k hk => dist_none.mp (hN k hk ▸ ez k)⟩, hz, ez⟩ + +end + +instance instUORAGenMap : UORA (GenMap β) where + toORA := instORAGenMap β + unit := GenMap.empty + unit_valid _ := trivial + unit_left_id {x} := GenMap.ext <| OFE.eq_dist_2 fun _ k => by + simp only [op, optionOp, empty] + cases x.car k <;> simp + pcore_unit := congrArg some <| GenMap.ext <| OFE.eq_dist_2 fun _ k => by + simp [empty, core, pcore, optionCore] + ord_refl x := ord_refl x.car + +instance : IsTotal (GenMap β) := unit_total + +instance instIncOrdGenMap [IncOrd β] : IncOrd (GenMap β) := + IncOrd.of_increasing fun x => GenMap.increasing_of_car β (IncOrd.increasing x.car) + +instance instOrdIncGenMap [OrdInc β] : OrdInc (GenMap β) where + ord_inc {_ y} h := + let ⟨z, hz⟩ := OrdInc.ord_inc (α := Nat → Option β) h + let ⟨N, hN⟩ := y.bound + ⟨⟨z, N, fun k hk => Option.eq_none_of_op_eq_none_right ((congrFun hz k).symm.trans (hN k hk))⟩, + GenMap.ext hz⟩ + ordN_incN {_ _ y} h := + let ⟨z, hz⟩ := OrdInc.ordN_incN (α := Nat → Option β) h + let ⟨N, hN⟩ := y.bound + ⟨⟨z, N, fun k hk => + Option.eq_none_of_op_eq_none_right (dist_none.mp ((hz k).symm.trans (.of_eq (hN k hk))))⟩, hz⟩ + +instance instIsIncGenMap [IsInc β] : IsInc (GenMap β) := {} + +theorem GenMap.singleton_ord_mono {x : Nat} {y y' : β} (h : y ≼ₒ y') : + (singleton x y : GenMap β) ≼ₒ singleton x y' := fun x' => by + by_cases hx : x' = x + · subst hx; rw [singleton_map_in, singleton_map_in]; exact .inr h + · rw [singleton_map_none hx, singleton_map_none hx]; trivial + +theorem GenMap.alter_valid {g : GenMap β} (Hb : ✓{n} b) (Hg : ✓{n} g) : + ✓{n} g.alter a b := by + intro k + simp only [GenMap.alter, Iris.alter] + split + · exact Hb + · exact Hg k + +theorem GenMap.valid_exists_fresh {g : GenMap β} (_Hv : ✓{n} g) : ∃ a : Nat, g.car a = none := + g.exists_fresh + +theorem GenMap.singleton_map_op (x : Nat) (y1 y2 : β) : + (singleton x y1 : GenMap β) • singleton x y2 = singleton x (y1 • y2) := by + apply GenMap.ext + funext γ + simp only [op, optionOp] + by_cases h : γ = x + · subst h; simp [singleton, empty, alter, Iris.alter] + · simp only [singleton, empty, alter, Iris.alter] + have : x ≠ γ := Ne.symm h + simp [ite_eq_right this] + +theorem GenMap.singleton_map_pcore (x : Nat) (y : β) (γ : Nat) : + ((singleton x y : GenMap β).car γ).bind pcore = + if γ = x then pcore y else none := by + by_cases h : γ = x + · subst h + simp [singleton_map_in] + · simp_all [singleton_map_none h] + +theorem GenMap.validN_singleton_map_in (x : Nat) (y : β) (n : Nat) : + ✓{n} (singleton x y).car x → ✓{n} y := by + rw [singleton_map_in] + simp [ValidN, optionValidN] + +theorem GenMap.op_singleton_comm {mf : GenMap β} {x : Nat} (y : β) + (H_free : IsFree mf.car x) : + GenMap.singleton x y • mf = mf.alter x (some y) := by + refine OFE.eq_dist_2 ?_ + intro n k + simp only [IsFree] at H_free + by_cases heq : k = x + · subst heq + simp only [op, optionOp, alter, Iris.alter, singleton, empty, ↓reduceIte] + simp [H_free] + · simp only [op, optionOp, alter, Iris.alter, singleton, empty] + have : x ≠ k := Ne.symm heq + simp [ite_eq_right this] + +theorem GenMap.singleton_op_alter_none {g : GenMap β} {x : Nat} {y : β} (h : g.car x = some y) : + GenMap.singleton x y • g.alter x none = g := by + rw [op_singleton_comm _ y (by simp [IsFree, alter, Iris.alter]), alter_alter, + alter_of_lookup h] + +theorem GenMap.validN_op_comm {m mf : GenMap β} (x : Nat) (y : β) (H : IsFree mf.car x) : + ✓{n} m.alter x (some y) • mf ↔ ✓{n} (m • mf).alter x (some y) := by + apply Dist.validN + intro k + simp only [IsFree] at H + by_cases heq : k = x + · subst heq + simp only [op, alter, Iris.alter, ↓reduceIte, optionOp] + simp [H] + · simp only [op, alter, Iris.alter] + have : x ≠ k := Ne.symm heq + simp [ite_eq_right this] + +end ORA + +/-! ## OFunctors -/ + +section OFunctors +open COFE ORA + +/-- Lift a mixed-variance family to finite-support ghost maps. -/ +abbrev GenMapOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : (∀ + (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun A B _ _ => GenMap (F A B) + +/-- Map a non-expansive function over every allocated ghost-map entry. -/ +abbrev GenMap.lift [OFE α] [OFE β] (f : α -n> β) : GenMap α -n> GenMap β where + f g := ⟨fun t => Option.map f (g.car t), by + obtain ⟨N, hN⟩ := g.bound + exact ⟨N, fun k hk => by simp [Option.map, hN k hk]⟩⟩ + ne.ne {n x1 x2} H γ := by + specialize H γ + simp only [Option.map] + split <;> split <;> simp_all only [some_dist_some, not_some_dist_none, not_none_dist_some, + Dist.refl] + exact NonExpansive.ne H + +instance instOFunctorGenMapOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → + Type _)) [OFunctor F] : + OFunctor (GenMapOF F) where + ofe {A B _ _} := instOFEGenMap (F A B) + map f₁ f₂ := GenMap.lift <| OFunctor.map (F := F) f₁ f₂ + map_ne.ne {n x1 x2} Hx {y1 y2} Hy k γ := by + simp only [OFE.Dist, Option.Forall₂, Option.map] + cases _ : k.car γ <;> simp only [] + exact OFunctor.map_ne.ne Hx Hy _ + map_id {α β _ _} x := OFE.eq_dist_2 <| by + intro _ γ + simp only [Option.map]; cases _ : x.car γ <;> simp only [Dist.refl, some_dist_some] + exact (OFunctor.map_id _).dist + map_comp _ _ _ _ x := OFE.eq_dist_2 <| by + intro _ γ + simp only [Option.map]; cases _ : x.car γ <;> simp only [Dist.refl, some_dist_some] + exact (OFunctor.map_comp _ _ _ _ _).dist + +instance instURFunctorGenMapOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → + Type _)) [RFunctor F] : + URFunctor (GenMapOF F) where + map f g := { + toHom := GenMap.lift <| OFunctor.map f g + validN {n x} hv z := by + cases h : x.car z with + | none => simp [Option.map, h, ValidN, optionValidN] + | some v => + simp only [Option.map, ValidN, optionValidN, h] + have Hvalid := @(URFunctor.map (F := OptionOF F) f g).validN n v + simp only [ValidN, optionValidN, URFunctor.map] at Hvalid + have hv' := hv z + simp only [h, ValidN, optionValidN] at hv' + exact Hvalid hv' + pcore x := OFE.eq_dist_2 <| by + intro _ γ + have Hcore := @(URFunctor.map (F := OptionOF F) f g).pcore (x.car γ) + simp only [pcore, optionCore, Option.bind, Option.map, URFunctor.map, + OFunctor.map, core] at Hcore ⊢ + cases h : x.car γ with + | none => simp + | some v => + revert Hcore + cases h' : pcore v <;> cases h'' : pcore ((OFunctor.map f g).f v) <;> + simp_all [Option.mapC, optionMap] + op z x := OFE.eq_dist_2 <| by + intro _ γ + have Hop := @(URFunctor.map (F := OptionOF F) f g).op (z.car γ) (x.car γ) + simp only [Option.map, op, optionOp, URFunctor.map] at Hop ⊢ + cases h : z.car γ <;> cases h' : x.car γ <;> simp_all only [Dist.refl, OFunctor.map, + some_dist_some] + exact ((RFunctor.map f g).op _ _).dist + monoN_ord h t := (URFunctor.map (F := OptionOF F) f g).monoN_ord (h t) + mono_ord h t := (URFunctor.map (F := OptionOF F) f g).mono_ord (h t) + increasing h := GenMap.increasing_of_car _ <| DiscreteFun.increasing_iff.mpr fun t => + (URFunctor.map (F := OptionOF F) f g).increasing (GenMap.increasing_apply _ h t) + } + map_ne.ne := OFunctor.map_ne.ne + map_id x := OFunctor.map_id x + map_comp f g f' g' x := OFunctor.map_comp f g f' g' x + +instance instRFunctorAffineGenMapOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE + β] → Type _)) [RFunctor F] [RFunctorAffine F] : + RFunctorAffine (GenMapOF F) where + affine := inferInstance + +instance instURFunctorContractiveGenMapOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)) [RFunctorContractive F] : + URFunctorContractive (GenMapOF F) where + map_contractive.1 h x γ := by + next n x' y' => + have Heqv := @(URFunctorContractive.map_contractive (F := OptionOF F)).1 _ x' y' h (x.car γ) + simp only [Function.uncurry, URFunctor.map, Option.map] at Heqv ⊢ + cases hc : x.car γ <;> simp only [Dist, Option.Forall₂] + rw [hc] at Heqv + exact Heqv + +end OFunctors + +end GenMap + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/IProp.lean b/LeanPool/IrisAlgebra/Algebra/IProp.lean new file mode 100644 index 0000000000..b4c467134a --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/IProp.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2025 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Markus de Medeiros, Janine Lohse +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.CMRA +public import LeanPool.IrisAlgebra.Algebra.OFE +public import LeanPool.IrisAlgebra.Algebra.UPred +public import LeanPool.IrisAlgebra.Algebra.GenMap +public import LeanPool.IrisAlgebra.Algebra.COFESolver +public import Init.Data.Vector + +/-! The recursive Iris proposition model over ordered ghost resources. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris + +open COFE + +/-- The index type for the global family of ghost-resource functors. -/ +abbrev GType := Nat + +universe u v w + +/-- A resource functor admissible in the global ghost state: contractive, with affine algebras. -/ +structure GFunctor where + /-- The underlying mixed-variance family of resource carriers. -/ + F : ∀ (α : Type u) (β : Type v), [COFE α] → [COFE β] → Type w + /-- Contractiveness of the resource functor action. -/ + [contractive : RFunctorContractive F] + [affine : RFunctorAffine F] + +/-- A global family of admissible ghost-resource functors. -/ +structure BundledGFunctors where + /-- The resource functor assigned to each ghost-resource index. -/ + get : GType → GFunctor.{u, v, w} + +instance : CoeFun BundledGFunctors.{u, v, w} (fun _ => GType → GFunctor.{u, v, w}) := + ⟨BundledGFunctors.get⟩ + +/-- The global family assigning the constant unit resource to every index. -/ +def BundledGFunctors.default : BundledGFunctors := ⟨fun _ => ⟨constOF Unit⟩⟩ + +/-- Replace the resource functor at one global index. -/ +def BundledGFunctors.set (GF : BundledGFunctors) (i : Nat) (FB : GFunctor) : + BundledGFunctors := + ⟨fun j => if j = i then FB else GF j⟩ + +/-- The natural-number names used for ghost-resource allocations. -/ +abbrev GName := Nat + +/-- The global ghost-resource functor, built from finite-support maps. -/ +abbrev IResF (GF : BundledGFunctors) : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] + → Type _) := DiscreteFunOF (fun i => GenMapOF (GF i).F) + +instance (GF : BundledGFunctors) (i : GType) : RFunctorContractive (GF i).F := (GF i).contractive + +instance instRFunctorAffineGF (GF : BundledGFunctors) (i : GType) : RFunctorAffine (GF i).F := (GF + i).affine + +section IProp +open ORA + +variable (GF : BundledGFunctors.{u, u, u}) + +/-- The complete recursive domain used to define Iris propositions. -/ +def IPre : Type _ := OFunctor.Fix (UPredOF (IResF GF)) + +instance : COFE (IPre GF) := inferInstanceAs (COFE (OFunctor.Fix _)) + +/-- The global unital ordered resource algebra over the recursive pre-propositions. -/ +def IResUR : Type u := (i : GType) → GenMap ((GF i).F (IPre GF) (IPre GF)) + +instance : UORA (IResUR GF) := + ucmraDiscreteFunO (β := fun (i : GType) => GenMap ((GF i).F (IPre GF) (IPre GF))) + +instance instIncOrdIResUR : IncOrd (IResUR GF) := + inferInstanceAs (IncOrd ((i : GType) → GenMap ((GF i).F (IPre GF) (IPre GF)))) + +/-- Monotone step-indexed predicates over the global ghost-resource algebra. -/ +abbrev IProp : Type u := UPred (IResUR GF) + +/-- Map a proposition to its recursive pre-proposition representation. -/ +def IProp.unfold : IProp GF -n> IPre GF := + OFE.Iso.hom <| OFunctor.Fix.iso (F := (UPredOF (IResF GF))) + +/-- Map a recursive pre-proposition back to its proposition representation. -/ +def IProp.fold : IPre GF -n> IProp GF := + OFE.Iso.inv <| OFunctor.Fix.iso (F := (UPredOF (IResF GF))) + +theorem IProp.fold_unfold (P : IProp GF) : IProp.fold GF (IProp.unfold GF P) = P := + OFunctor.Fix.iso (F := UPredOF (IResF GF)) |>.inv_hom + +theorem IProp.unfold_fold (P : IPre GF) : IProp.unfold GF (IProp.fold GF P) = P := + OFunctor.Fix.iso (F := UPredOF (IResF GF)) |>.hom_inv + +end IProp + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/Monoid.lean b/LeanPool/IrisAlgebra/Algebra/Monoid.lean new file mode 100644 index 0000000000..1ca894c8a7 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/Monoid.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Zongyuan Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Zongyuan Liu +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.OFE + +/-! Non-expansive commutative monoids and their morphisms. -/ + +public section + +namespace Iris.Algebra + +/-! # Monoids for Big Operators + +- `Monoid` contains the laws and requires an OFE structure. +- Uses explicit `op` parameters to support multiple monoids on the same type. +-/ + +open OFE + +/-- A commutative monoid on an OFE, used for big operators. +The operation must be non-expansive, associative, commutative, and have a left identity. -/ +class MonoidOps {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 -/ + op_assoc : ∀ {a b c : M}, op (op a b) c = op a (op b c) + /-- Commutativity -/ + op_comm : ∀ {a b : M}, op a b = op b a + /-- Left identity -/ + op_left_id : ∀ {a : M}, op unit a = a + +namespace MonoidOps + +attribute [instance] op_ne + +variable {M : Type u} [OFE M] {unit : M} {op : M → M → M} + +/-- Right identity follows from commutativity and left identity. -/ +theorem op_right_id [MonoidOps op unit] : op a unit = a := + op_comm.trans op_left_id + +/-- Rearrange `(a * b) * (c * d)` to `(a * c) * (b * d)`. -/ +theorem op_op_op_comm [MonoidOps 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 + _ = op a (op (op b c) d) := congrArg (op a) op_assoc.symm + _ = op a (op (op c b) d) := congrArg (op a) (congrArg (op · d) op_comm) + _ = op a (op c (op b d)) := congrArg (op a) op_assoc + _ = op (op a c) (op b d) := op_assoc.symm + +/-- Swap inner elements: `a * (b * c)` to `b * (a * c)`. -/ +theorem op_left_comm [MonoidOps 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 := op_assoc.symm + _ = op (op b a) c := congrArg (op · c) op_comm + _ = op b (op a c) := op_assoc + +/-- Non-expansiveness for dist. -/ +theorem op_dist [MonoidOps op unit] (ha : a ≡{n}≡ a') (hb : b ≡{n}≡ b') : + op a b ≡{n}≡ op a' b' := NonExpansive₂.ne ha hb + +end MonoidOps + +/-! ## Monoid Homomorphisms -/ + +/-- A weak monoid homomorphism preserves the operation but not necessarily the unit. -/ +class WeakMonoidHomomorphism {M₁ : Type u} {M₂ : Type v} [OFE M₁] [OFE M₂] + (op₁ : M₁ → M₁ → M₁) (op₂ : M₂ → M₂ → M₂) (unit₁ : M₁) (unit₂ : M₂) + [MonoidOps op₁ unit₁] [MonoidOps 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 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 -/ + map_ne : NonExpansive f + /-- The homomorphism property -/ + map_op : ∀ {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₂) + [MonoidOps op₁ unit₁] [MonoidOps op₂ unit₂] + (R : M₂ → M₂ → Prop) (f : M₁ → M₂) + extends WeakMonoidHomomorphism op₁ op₂ unit₁ unit₂ R f where + /-- The unit is preserved -/ + map_unit : R (f unit₁) unit₂ + +end Iris.Algebra diff --git a/LeanPool/IrisAlgebra/Algebra/OFE.lean b/LeanPool/IrisAlgebra/Algebra/OFE.lean new file mode 100644 index 0000000000..f7b61c0c21 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/OFE.lean @@ -0,0 +1,2086 @@ +/- +Copyright (c) 2023 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Sebastian Graf, Sergei Stepanenko, Markus de Medeiros +-/ +module + +public import LeanPool.IrisAlgebra.Std.Nat +public import LeanPool.IrisAlgebra.Std.Option + +/-! Ordered families of equivalences and complete step-indexed spaces. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris + +/-- Ordered family of equivalences -/ +class OFE (α : Type _) where + /-- The equivalence relation at a specified step index. -/ + Dist : Nat → α → α → Prop + dist_eqv : Equivalence (Dist n) + eq_dist' : x = y ↔ ∀ n, Dist n x y + dist_lt : Dist n x y → m < n → Dist m x y + +open OFE + +/-- Notation for equivalence at a specified step index. -/ +scoped notation:40 x " ≡{" n "}≡ " y:41 => OFE.Dist n x y + +/- `OFE.eq_dist` is `OFE.eq_dist'` restated in preparation for +generalizing over the type of step-indices -/ +theorem OFE.eq_dist {α} [self : OFE α] {x y : α} : + x = y ↔ ∀ n, OFE.Dist n x y := OFE.eq_dist' + +theorem OFE.eq_dist_1 {α} [self : OFE α] {x y : α} : + x = y → ∀ n, OFE.Dist n x y := OFE.eq_dist.mp +theorem OFE.eq_dist_2 {α} [self : OFE α] {x y : α} : + (∀ n, OFE.Dist n x y) → x = y := OFE.eq_dist.mpr + +namespace OFE + +theorem dist_equivalence [OFE α] {n} : Equivalence (Dist (α := α) n) := dist_eqv + +theorem Dist.lt [OFE α] {m n} {x y : α} : x ≡{n}≡ y → m < n → x ≡{m}≡ y := dist_lt + +theorem Dist.le [OFE α] {m n} {x y : α} (h : x ≡{n}≡ y) (h' : m ≤ n) : x ≡{m}≡ y := + if hm : m = n then hm ▸ h else h.lt (Nat.lt_of_le_of_ne h' hm) + +@[refl] theorem Dist.rfl [OFE α] {n} {x : α} : x ≡{n}≡ x := dist_eqv.1 _ +@[simp, refl] theorem Dist.refl [OFE α] {n} (x : α) : x ≡{n}≡ x := dist_eqv.1 _ +@[symm] theorem Dist.symm [OFE α] {n} {x : α} : x ≡{n}≡ y → y ≡{n}≡ x := dist_eqv.2 +theorem Dist.trans [OFE α] {n} {x : α} : x ≡{n}≡ y → y ≡{n}≡ z → x ≡{n}≡ z := dist_eqv.3 +theorem Dist.of_eq [OFE α] {x y : α} : x = y → x ≡{n}≡ y := (· ▸ .rfl) + +theorem _root_.Eq.dist [OFE α] {x y : α} (h : x = y) : x ≡{n}≡ y := h ▸ .rfl + +instance [OFE α] {n} : Trans (OFE.Dist n) (OFE.Dist n) (OFE.Dist n : α → α → Prop) where + trans := Dist.trans + +/-- A function `f : α → β` is non-expansive if it preserves `n`-equivalence. -/ +class NonExpansive [OFE α] [OFE β] (f : α → β) where + ne : ∀ ⦃n x₁ x₂⦄, x₁ ≡{n}≡ x₂ → f x₁ ≡{n}≡ f x₂ + +instance id_ne [OFE α] : NonExpansive (@id α) := ⟨fun _ _ _ h => h⟩ + +instance const_ne [OFE α] [OFE β] {x : α} : NonExpansive (Function.const β x) := ⟨fun _ _ _ _ => + .rfl⟩ + +/-- Note: Not an instance, as any function can be decomposed as a composition in multiple ways. -/ +theorem NonExpansive.comp [OFE α] [OFE β] [OFE γ] {g : β → γ} {f : α → β} + (hg : NonExpansive g) (hf : NonExpansive f) : NonExpansive (g ∘ f) := + ⟨fun {_ _ _} h => hg.ne (hf.ne h)⟩ + +/-- A function `f : α → β → γ` is non-expansive if it preserves `n`-equivalence in each argument. -/ +class NonExpansive₂ [OFE α] [OFE β] [OFE γ] (f : α → β → γ) where + ne : ∀ ⦃n x₁ x₂⦄, x₁ ≡{n}≡ x₂ → ∀ ⦃y₁ y₂⦄, y₁ ≡{n}≡ y₂ → f x₁ y₁ ≡{n}≡ f x₂ y₂ + +/-- Note: Not an instance, for symmetry with NonExpansive₂.ne_left, which cannot be an instance. -/ +theorem NonExpansive₂.ne_right [OFE α] [OFE β] [OFE γ] (f : α → β → γ) [NonExpansive₂ f] + (a : α) : NonExpansive (f a) := + ⟨fun {_ _ _} h => ne Dist.rfl h⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive₂.ne_left [OFE α] [OFE β] [OFE γ] (f : α → β → γ) [NonExpansive₂ f] + (b : β) : NonExpansive (f · b) := + ⟨fun {_ _ _} h => ne h Dist.rfl⟩ + +/-- A function `f : α → β → γ → δ` is non-expansive if it preserves `n`-equivalence in each +argument. -/ +class NonExpansive₃ [OFE α] [OFE β] [OFE γ] [OFE δ] (f : α → β → γ → δ) where + ne : ∀ ⦃n x₁ x₂⦄, x₁ ≡{n}≡ x₂ → ∀ ⦃y₁ y₂⦄, y₁ ≡{n}≡ y₂ → ∀ ⦃z₁ z₂⦄, z₁ ≡{n}≡ z₂ → + f x₁ y₁ z₁ ≡{n}≡ f x₂ y₂ z₂ + +/-- A function `f : α → β → γ → δ → ε` is non-expansive if it preserves `n`-equivalence in each +argument. -/ +class NonExpansive₄ [OFE α] [OFE β] [OFE γ] [OFE δ] [OFE ε] (f : α → β → γ → δ → ε) where + ne : ∀ ⦃n x₁ x₂⦄, x₁ ≡{n}≡ x₂ → ∀ ⦃y₁ y₂⦄, y₁ ≡{n}≡ y₂ → ∀ ⦃z₁ z₂⦄, z₁ ≡{n}≡ z₂ → + ∀ ⦃w₁ w₂⦄, w₁ ≡{n}≡ w₂ → f x₁ y₁ z₁ w₁ ≡{n}≡ f x₂ y₂ z₂ w₂ + +/-- `DistLater n x y` means that `x` and `y` are `m`-equivalent for all `m < n`. -/ +def DistLater [OFE α] (n : Nat) (x y : α) : Prop := ∀ m, m < n → x ≡{m}≡ y + +@[refl] theorem DistLater.rfl [OFE α] {n} {x : α} : DistLater n x x := fun _ _ => .rfl +@[simp, refl] theorem DistLater.refl [OFE α] {n} (x : α) : DistLater n x x := fun _ _ => .rfl +@[symm] theorem DistLater.symm [OFE α] {n} {x : α} (h : DistLater n x y) : DistLater n y x := + fun _ hm => (h _ hm).symm +theorem DistLater.trans [OFE α] {n} {x : α} (h1 : DistLater n x y) (h2 : DistLater n y z) : + DistLater n x z := fun _ hm => (h1 _ hm).trans (h2 _ hm) + +/-- `DistLater n`-equivalence is an equivalence relation. -/ +theorem distLater_eqv [OFE α] {n} : Equivalence (α := α) (DistLater n) where + refl := DistLater.refl + symm h := h.symm + trans h1 := h1.trans + +/-- `n`-equivalence implies `DistLater n`-equivalence. -/ +theorem Dist.distLater [OFE α] {n} {x y : α} (h : x ≡{n}≡ y) : DistLater n x y := + fun _ => dist_lt h + +/-- `DistLater n`-equivalence implies `m`-equivalence for all `m < n`. -/ +theorem DistLater.dist_lt [OFE α] {m n} {x y : α} (h : DistLater n x y) (hm : m < n) : x ≡{m}≡ y := + h _ hm + +/-- `DistLater 0`-equivalence is trivial. -/ +@[simp] theorem distLater_zero [OFE α] {x y : α} : DistLater 0 x y := nofun + +/-- `DistLater (n + 1)`-equivalence is equivalent to `n`-equivalence. -/ +theorem distLater_succ [OFE α] {n} {x y : α} : DistLater n.succ x y ↔ x ≡{n}≡ y := + ⟨(·.dist_lt (Nat.lt_succ_self _)), fun h1 _ h2 => h1.le (Nat.le_of_lt_succ h2)⟩ + +theorem distLater_soundness [OFE α] {x y : α} (H : ∀ n, DistLater n x y → x ≡{n}≡ y) : x = y := by + refine eq_dist_2 fun n => ?_ + induction n with + | zero => exact H 0 distLater_zero + | succ n IH => exact H (n + 1) (distLater_succ.mpr IH) + +/-- A function `f : α → β` is contractive if it sends `DistLater n`-equivalent inputs to +`n`-equivalent outputs. -/ +class Contractive [OFE α] [OFE β] (f : α → β) where + distLater_dist : DistLater n x y → f x ≡{n}≡ f y + +@[simp] theorem Contractive.zero [OFE α] [OFE β] (f : α → β) + [Contractive f] {x y} : f x ≡{0}≡ f y := + Contractive.distLater_dist distLater_zero + +theorem Contractive.succ [OFE α] [OFE β] (f : α → β) [Contractive f] {n x y} + (h : x ≡{n}≡ y) : f x ≡{n.succ}≡ f y := + Contractive.distLater_dist (distLater_succ.2 h) + +/-- A contractive function is non-expansive. -/ +instance ne_of_contractive [OFE α] [OFE β] (f : α → β) [Contractive f] : NonExpansive f where + ne := fun _ _ _ h => Contractive.distLater_dist (Dist.distLater h) + +theorem Contractive.dist_later_dist [OFE α] [OFE β] (f : α → β) [Contractive f] {n x y} + (h : DistLater n x y) : f x ≡{n}≡ f y := Contractive.distLater_dist h + +/-- Pre-composing a non-expansive function preserves `DistLater`. -/ +theorem ne_dist_later [OFE α] [OFE β] (f : α → β) [NonExpansive f] {n x y} + (h : DistLater n x y) : DistLater n (f x) (f y) := fun m hm => NonExpansive.ne (h m hm) + +theorem dist_pointwise_lt [OFE β] {n m} {f g : α → β} (hlt : m < n) + (hp : ∀ a, DistLater n (f a) (g a)) : ∀ a, f a ≡{m}≡ g a := fun a => hp a m hlt + +/-- Constant functions are contractive. -/ +instance [OFE α] [OFE β] {x : β} : Contractive (fun _ : α => x) where + distLater_dist := fun _ => Dist.rfl + +/-- The discrete OFE obtained from an equality relation `Eq` -/ +@[reducible] +def ofDiscrete (α : Type _) : OFE α where + Dist _ := Eq + dist_eqv := ⟨congrFun rfl, (Eq.symm ·), (· ▸ ·)⟩ + eq_dist' := (forall_const _).symm + dist_lt h _ := h + +/-- A discrete element in an OFE -/ +class DiscreteE {α : Type _} [OFE α] (x : α) : Prop where + discrete : x ≡{0}≡ y → x = y + +/-- A discrete OFE is one where equality is implied by `0`-equivalence. -/ +class Discrete (α : Type _) [OFE α] where + discrete_0 {x y : α} : x ≡{0}≡ y → x = y +export OFE.Discrete (discrete_0) + +theorem discreteE_eq [OFE α] {x y : α} (h : x = y) : DiscreteE x ↔ DiscreteE y := h ▸ Iff.rfl + +/-- For discrete OFEs, `n`-equivalence implies equality. -/ +theorem Discrete.discrete [OFE α] [Discrete α] {n} {x y : α} (h : x ≡{n}≡ y) : x = y := + discrete_0 (h.le (Nat.zero_le _)) +export OFE.Discrete (discrete) + +instance Discrete.toDiscreteE [OFE α] [Discrete α] (x : α) : DiscreteE x := ⟨discrete_0⟩ + +/-- For discrete OFEs, `0`-equivalence implies equivalence for any `n`. -/ +theorem Discrete.discrete_n [OFE α] [Discrete α] {n} {x y : α} (h : x ≡{0}≡ y) : x ≡{n}≡ y := + (discrete h).dist +export OFE.Discrete (discrete_n) + +theorem Discrete.discrete_iff [OFE α] [Discrete α] (n) {x y : α} : x = y ↔ x ≡{n}≡ y := + ⟨Eq.dist, discrete⟩ + +theorem Discrete.discrete_iff_0 [OFE α] [Discrete α] (n) {x y : α} : x ≡{0}≡ y ↔ x ≡{n}≡ y := + ⟨discrete_n, fun h => h.le (Nat.zero_le _)⟩ + +/-- Build a Leibniz OFE on `Quotient s` from a step-indexed distance `dist` on the carrier, +given that the setoid relation coincides with the OFE equivalence `fun x y => ∀ n, dist n x y` +(hypothesis `hs`). Quotienting forces the resulting OFE equality to be Leibniz, while +`Quotient.sound`/`Quotient.exact` keep speaking about the domain relation `s.r`. See +https://leanprover.zulipchat.com/#narrow/channel/490604-iris-lean/topic/Evaluating.20a.20specialization.20to.20Leibnize.20OFE.27s/with/606745235 +-/ +@[reducible] def ofQuotient {X : Type u} {s : Setoid X} (dist : Nat → X → X → Prop) + (heqv : ∀ {n}, Equivalence (dist n)) + (hlt : ∀ {n m} {x y : X}, dist n x y → m < n → dist m x y) + (hs : ∀ x y : X, s.r x y ↔ ∀ n, dist n x y) : OFE (Quotient s) := + letI D : Nat → Quotient s → Quotient s → Prop := + fun n => Quotient.lift₂ (dist n) fun _ _ _ _ hac hbd => propext <| + have hac' := (hs _ _).mp hac + have hbd' := (hs _ _).mp hbd + ⟨fun h => heqv.trans (heqv.trans (heqv.symm (hac' n)) h) (hbd' n), + fun h => heqv.trans (heqv.trans (hac' n) h) (heqv.symm (hbd' n))⟩ + { Dist := D + dist_eqv := by + refine ⟨Quotient.ind fun a => heqv.refl a, fun {x y} h => ?_, fun {x y z} h₁ h₂ => ?_⟩ + · induction x, y using Quotient.ind₂ with | _ a b => exact heqv.symm h + · induction x, y using Quotient.ind₂ with | _ a b => + induction z using Quotient.ind with | _ c => exact heqv.trans h₁ h₂ + eq_dist' {x y} := by + induction x, y using Quotient.ind₂ with | _ a b => + exact ⟨fun h n => (hs _ _).mp (Quotient.exact h) n, + fun h => Quotient.sound ((hs _ _).mpr h)⟩ + dist_lt := fun {n x y m} h hlt' => by + induction x, y using Quotient.ind₂ with | _ a b => exact hlt h hlt' } + +namespace ofQuotient + +variable {X : Type u} {s : Setoid X} + +/-- Form an equivalence class in the quotient equivalence space. -/ +@[reducible] def mk (s : Setoid X) (x : X) : Quotient s := Quotient.mk s x + +@[elab_as_elim] theorem ind {motive : Quotient s → Prop} + (mk : ∀ x : X, motive (mk s x)) (q : Quotient s) : motive q := + Quotient.ind mk q + +@[elab_as_elim] theorem ind₂ {motive : Quotient s → Quotient s → Prop} + (mk : ∀ x y : X, motive (mk s x) (mk s y)) (x y : Quotient s) : motive x y := + Quotient.ind₂ mk x y + +@[elab_as_elim] theorem ind₃ {motive : Quotient s → Quotient s → Quotient s → Prop} + (mk : ∀ x y z : X, motive (mk s x) (mk s y) (mk s z)) (x y z : Quotient s) : + motive x y z := + ind₂ (fun x y => Quotient.ind (mk x y)) x y z + +theorem sound {x y : X} (h : s.r x y) : mk s x = mk s y := Quotient.sound h + +theorem exact {x y : X} (h : mk s x = mk s y) : s.r x y := Quotient.exact h + +theorem mk_eq {x y : X} : mk s x = mk s y ↔ s.r x y := ⟨exact, sound⟩ + +/-- Lift a class-invariant function from a quotient equivalence space. -/ +@[reducible] def lift {β : Sort v} (f : X → β) + (resp : ∀ x y, s.r x y → f x = f y) : Quotient s → β := Quotient.lift f resp + +@[simp] theorem lift_mk {β : Sort v} (f : X → β) (resp) (x : X) : + lift (s := s) f resp (mk s x) = f x := rfl + +/-- Lift a binary class-invariant function from quotient equivalence spaces. -/ +@[reducible] def lift₂ {β : Sort v} (f : X → X → β) + (resp : ∀ a b c d, s.r a c → s.r b d → f a b = f c d) : + Quotient s → Quotient s → β := Quotient.lift₂ f resp + +@[simp] theorem lift₂_mk {β : Sort v} (f : X → X → β) (resp) (x y : X) : + lift₂ (s := s) f resp (mk s x) (mk s y) = f x y := rfl + +/-- Map a relation-preserving function between quotient equivalence spaces. -/ +@[reducible] def map {X' : Type u'} {s' : Setoid X'} (f : X → X') + (hf : ∀ x y, s.r x y → s'.r (f x) (f y)) : Quotient s → Quotient s' := + Quotient.lift (fun x => mk s' (f x)) (fun _ _ h => sound (hf _ _ h)) + +@[simp] theorem map_mk {X' : Type u'} {s' : Setoid X'} (f : X → X') (hf) (x : X) : + map (s := s) (s' := s') f hf (mk s x) = mk s' (f x) := rfl + +theorem dist_mk {dist : Nat → X → X → Prop} {heqv : ∀ {n}, Equivalence (dist n)} + {hlt : ∀ {n m} {x y : X}, dist n x y → m < n → dist m x y} + {hs : ∀ x y : X, s.r x y ↔ ∀ n, dist n x y} {n} {x y : X} : + (ofQuotient dist heqv hlt hs).Dist n (mk s x) (mk s y) ↔ dist n x y := Iff.rfl + +end ofQuotient + +/-- A morphism between OFEs, written `α -n> β`, is defined to be a function that is +non-expansive. -/ +@[ext] structure Hom (α β : Type _) [OFE α] [OFE β] where + /-- The underlying function of a non-expansive morphism. -/ + f : α → β + ne : NonExpansive f + +@[inherit_doc] +infixr:25 " -n> " => Hom + +instance [OFE α] [OFE β] : CoeFun (α -n> β) (fun _ => α → β) := ⟨Hom.f⟩ +instance [OFE α] [OFE β] (f : α -n> β) : NonExpansive f := f.ne + +/-- The identity morphism on an OFE. -/ +protected def Hom.id [OFE α] : α -n> α where + f := id + ne.ne _ _ _ := id + +/-- The composition of two morphisms between OFEs. -/ +protected def Hom.comp [OFE α] [OFE β] [OFE γ] (g : β -n> γ) (f : α -n> β) : α -n> γ where + f := g.f ∘ f.f + ne.1 _ _ _ h := g.ne.1 (f.ne.1 h) + +@[simp] theorem Hom.id_apply [OFE α] {x} : (Hom.id : α -n> α) x = x := rfl +@[simp] theorem Hom.comp_apply [OFE α] [OFE β] [OFE γ] {g : β -n> γ} {f : α -n> β} {x} : + (g.comp f) x = g (f x) := rfl + +@[simp] theorem Hom.id_comp [OFE α] [OFE β] {f : α -n> β} : Hom.id.comp f = f := rfl +@[simp] theorem Hom.comp_id [OFE α] [OFE β] {f : α -n> β} : f.comp Hom.id = f := rfl + +theorem Hom.comp_assoc [OFE α] [OFE β] [OFE γ] [OFE δ] + (h : γ -n> δ) (g : β -n> γ) (f : α -n> β) : (h.comp g).comp f = h.comp (g.comp f) := rfl + +/-- The constant non-expansive morphism with a specified value. -/ +protected def Hom.const [OFE α] [OFE β] (x : β) : α -n> β where + f := Function.const α x + ne.ne _ _ _ _ := Dist.rfl + +@[simp] theorem Hom.const_apply [OFE α] [OFE β] {x : β} {a : α} : + (Hom.const x : α -n> β) a = x := rfl + +/-- Construct a `Hom` from a subtype bundling a function with its nonexpansiveness proof. -/ +def Hom.ofSubtype [OFE α] [OFE β] (f : { f : α → β // NonExpansive f }) : α -n> β := + ⟨f.val, f.property⟩ + +/-- A bundled contractive function between ordered equivalence spaces. -/ +@[ext] structure ContractiveHom (α β : Type _) [OFE α] [OFE β] extends Hom α β where + [contractive : Contractive f] + ne := ne_of_contractive f + +/-- Notation for a bundled contractive map. -/ +infixr:25 " -c> " => ContractiveHom + +instance [OFE α] [OFE β] : CoeFun (α -c> β) (fun _ => α → β) := ⟨fun x => x.toHom.f⟩ +instance [OFE α] [OFE β] (f : α -c> β) : Contractive f := f.contractive + +/-- Bundle a function with its available contractiveness instance. -/ +def _root_.Function.toContractiveHom (f : α → β) [OFE α] [OFE β] [ι : OFE.Contractive f] : α -c> β + where + f := f + contractive := ι + +@[simp] theorem _root_.Function.toContractiveHom_apply {f : α → β} [OFE α] [OFE β] [ι : + OFE.Contractive f] {x} : + f.toContractiveHom x = f x := by rfl + +theorem InvImage.equivalence {α : Sort u} {β : Sort v} + {r : β → β → Prop} {f : α → β} (H : Equivalence r) : Equivalence (InvImage r f) where + refl _ := H.refl _ + symm := H.symm + trans := H.trans + +instance unitOFE : OFE Unit where + Dist _ _ _ := True + dist_eqv := ⟨fun _ => ⟨⟩, id, fun _ => id⟩ + eq_dist' := by simp + dist_lt _ _ := ⟨⟩ + +instance : DiscreteE (() : Unit) := ⟨fun _ => Subsingleton.elim _ _⟩ + +instance : OFE Empty where + Dist _ _ _ := True + dist_eqv := ⟨fun _ => ⟨⟩, id, fun _ => id⟩ + eq_dist' {x} := x.elim + dist_lt _ _ := ⟨⟩ + +instance [OFE α] : OFE (ULift α) where + Dist n x y := x.down ≡{n}≡ y.down + dist_eqv := InvImage.equivalence dist_eqv + eq_dist' {x y} := by cases x; cases y; rw [ULift.up.injEq]; exact eq_dist + dist_lt := dist_lt + +/-- The non-expansive injection into a universe lift. -/ +def uliftUpHom [OFE α] : α -n> ULift α where + f := .up + ne.1 _ _ _ := id + +/-- The non-expansive projection from a universe lift. -/ +def uliftDownHom [OFE α] : ULift α -n> α where + f := ULift.down + ne.1 _ _ _ := id + +instance [OFE α] : OFE (Option α) where + Dist n := Option.Forall₂ (Dist n) + dist_eqv := Option.Forall₂.equivalence dist_eqv + eq_dist' {x y} := by cases x <;> cases y <;> simp [Option.Forall₂, eq_dist] + dist_lt {_ x y _} := by cases x <;> cases y <;> simp only [Option.Forall₂, implies_true, + imp_false, Nat.not_lt, false_implies]; apply dist_lt + +instance [OFE α] [OFE.Discrete α] : OFE.Discrete (Option α) where + discrete_0 {mx my} e := + match mx, my with + | none, none => rfl + | none, some _ => e.elim + | some _, none => e.elim + | some _, some _ => congrArg some (discrete_0 e) + +@[simp] theorem not_some_eqv_none {x : α} : ¬some x = none := Option.some_ne_none x +@[simp] theorem not_none_eqv_some {x : α} : ¬none = some x := fun h => Option.some_ne_none + x h.symm + +@[simp] +theorem some_dist_some [OFE α] {n} {x y : α} : (some x ≡{n}≡ some y) ↔ x ≡{n}≡ y := .rfl +@[simp] theorem not_some_dist_none [OFE α] {n} {x : α} : ¬some x ≡{n}≡ none := id +@[simp] theorem not_none_dist_some [OFE α] {n} {x : α} : ¬none ≡{n}≡ some x := id + +theorem equiv_some {o : Option α} {y : α} (e : o = some y) : + ∃ z, o = some z ∧ z = y := ⟨y, e, rfl⟩ + + +theorem dist_none [OFE α] {o : Option α} : o ≡{n}≡ none ↔ o = none := + ⟨fun h => by cases o with | none => rfl | some _ => exact h.elim, (· ▸ .rfl)⟩ + +theorem dist_some [OFE α] {n mx y} (h : mx ≡{n}≡ some y) : + ∃ z : α, mx = some z ∧ y ≡{n}≡ z := + suffices hh : ∀ mx my y, mx ≡{n}≡ my → my = some y → ∃ t, mx = some t ∧ t ≡{n}≡ y from + (hh mx (some y) _ h rfl).elim (fun t h => ⟨t, h.left, h.right.symm⟩) + fun mx _ y e1 e2 => + match mx with + | some t => ⟨t, rfl, (e2 ▸ e1 : some t ≡{n}≡ some y)⟩ + | none => False.elim (e2 ▸ e1 : none ≡{n}≡ some y) + +/-- Data-valued form of `dist_some`, for building the witnesses of `ORA.extend`. -/ +def distSome [OFE α] {n} {mx : Option α} {y : α} (h : mx ≡{n}≡ some y) : + (z : α) ×' mx = some z ∧ y ≡{n}≡ z := + match mx, h with + | some _, h => ⟨_, rfl, h.symm⟩ + | none, h => h.elim + +theorem dist_some_inv_l [OFE α] {n} {mx my : Option α} {x} (h : mx ≡{n}≡ my) + (e : mx = some x) : ∃ y, my = some y ∧ x ≡{n}≡ y := by + subst e; exact dist_some h.symm + +theorem dist_some_inv_r [OFE α] {n} {mx my : Option α} {y} (h : mx ≡{n}≡ my) + (e : my = some y) : ∃ x, mx = some x ∧ x ≡{n}≡ y := by + subst e; obtain ⟨z, hz, hd⟩ := dist_some h; exact ⟨z, hz, hd.symm⟩ + +theorem dist_some_inv_l' [OFE α] {n} {my : Option α} {x} (h : some x ≡{n}≡ my) : + ∃ x', some x' = my ∧ x ≡{n}≡ x' := + let ⟨y, hy, hd⟩ := dist_some_inv_l h rfl; ⟨y, hy.symm, hd⟩ + +theorem fmap_some_dist [OFE β] (f : α → β) {mx : Option α} {y : β} {n} : + (Option.map f mx ≡{n}≡ some y) ↔ ∃ x, mx = some x ∧ y ≡{n}≡ f x := by + refine ⟨fun h => ?_, ?_⟩ + · match mx with + | none => exact absurd h not_none_dist_some + | some x => exact ⟨x, rfl, (some_dist_some.mp h).symm⟩ + · rintro ⟨x, rfl, hd⟩; exact some_dist_some.mpr hd.symm + +instance [OFE α] [Discrete α] : Discrete (Option α) where + discrete_0 {x y} H := + match x, y with + | none, none => rfl + | some _, some _ => congrArg some (discrete_0 H) + | none, some _ => H.elim + | some _, none => H.elim + +instance Option.some.ne [OFE α] : OFE.NonExpansive (some : α → Option α) := ⟨fun _ _ _ => id⟩ + +instance Option.some_is_discrete [OFE α] {e : α} [OFE.DiscreteE e] : OFE.DiscreteE (some e) where + discrete {y} h := + match y with + | .none => absurd h not_some_dist_none + | .some _ => congrArg some (DiscreteE.discrete h) + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem Option.ne_match [OFE α] {B : Type _} [OFE B] + (f : α → B) (hf : NonExpansive f) (g : B) : + NonExpansive (fun x : Option α => match x with | some a => f a | none => g) := + ⟨fun {n x' y'} (h : Option.Forall₂ (Dist n) x' y') => + match x', y', h with | some _, some _, h => hf.ne h | none, none, _ => Dist.rfl⟩ + +instance Option.none_is_discrete [OFE α] : DiscreteE (none : Option α) := by + constructor; rintro (_|_) <;> simp + +instance Option.merge_ne [OFE α] {op : α → α → α} [NonExpansive₂ op] : + NonExpansive₂ (Option.merge op) where + ne n x1 x2 Hx y1 y2 Hy := by + rcases x1, x2, y1, y2 with ⟨_|_, _|_, _|_, _|_⟩ <;> simp_all only [Dist.refl, + Option.merge_none_right, not_none_dist_some, not_some_dist_none, some_dist_some, + Option.merge_none_left, Option.merge_some_some] + exact NonExpansive₂.ne Hx Hy + +instance Option.bind_fun_ne [OFE α] [OFE β] (f : α → Option β) [NonExpansive f] : NonExpansive + (flip Option.bind f) where + ne _ _ x2 Hx := match x2 with + | some _ => (dist_some Hx).choose_spec.left ▸ (NonExpansive.ne (f := f) (dist_some + Hx).choose_spec.right.symm) + | none => (dist_none.mp Hx).symm ▸ .rfl + +theorem Option.bind_dist [OFE β] {x : Option α} {f g : α → Option β} (H : ∀ x, f x ≡{n}≡ g + x) : Option.bind x f ≡{n}≡ Option.bind x g := + match x with + | some _ => H _ + | none => .rfl + +theorem Option.bind_equiv {x : Option α} {f g : α → Option β} (H : ∀ x, f x = g x) + : Option.bind x f = Option.bind x g := + match x with + | some _ => H _ + | none => rfl + +/-- A pointwise family of ordered equivalence structures. -/ +abbrev OFEFun {α : Type _} (β : α → Type _) := ∀ a, OFE (β a) + +instance [OFEFun (β : α → _)] : OFE ((x : α) → β x) where + Dist n f g := ∀ x, f x ≡{n}≡ g x + dist_eqv := { + refl _ _ := dist_eqv.refl _ + symm h _ := dist_eqv.symm (h _) + trans h1 h2 _ := dist_eqv.trans (h1 _) (h2 _) + } + eq_dist' {_ _} := by rw [funext_iff]; simpa only [eq_dist] using forall_comm + dist_lt h1 h2 _ := dist_lt (h1 _) h2 + +instance [OFE α] [OFE β] : OFE (α -n> β) where + Dist n f g := f.f ≡{n}≡ g.f + dist_eqv := { + refl _ := dist_eqv.refl _ + symm h := dist_eqv.symm h + trans h1 h2 := dist_eqv.trans h1 h2 + } + eq_dist' {_ _} := Hom.ext_iff.trans eq_dist + dist_lt := dist_lt + +instance ofe_mor_car_ne [OFE α] [OFE β] : + NonExpansive₂ (fun (f : α -n> β) (x : α) => f x) where + ne _ _ _ hf _ _ hx := dist_eqv.trans (hf _) (NonExpansive.ne hx) + +theorem ofe_mor_car_proper [OFE α] [OFE β] ⦃f g : α -n> β⦄ (hfg : f = g) + ⦃x y : α⦄ (hxy : x = y) : f x = g y := by + subst hfg; subst hxy; rfl + +instance [OFE α] [OFE β] [Inhabited β] : Inhabited (α -n> β) where + default := { f := Function.const α default, ne := const_ne } + +instance [OFE α] [OFE β] : OFE (α -c> β) where + Dist n f g := Dist n f.toHom g.toHom + dist_eqv := { + refl _ := dist_eqv.refl _ + symm h := dist_eqv.symm h + trans h1 h2 := dist_eqv.trans h1 h2 + } + eq_dist' {_ _} := ContractiveHom.ext_iff.trans eq_dist + dist_lt := dist_lt + +/-- Evaluate a dependent function at a specified argument. -/ +def applyHom [OFEFun (β : α → _)] (x : α) : ((x : α) → β x) -n> β x where + f f := f x + ne.1 _ _ _ H := H x + +/-- Evaluate a bundled non-expansive morphism at a specified argument. -/ +def applyNe [OFE α] [OFE β] (x : α) : (α -n> β) -n> β where + f f := f x + ne.1 _ _ _ H := H x + +instance [OFE α] [OFE β] : NonExpansive (applyNe (α := α) (β := β)) where + ne _ _ _ H f := f.ne.1 H + +/-- Apply a family of non-expansive maps pointwise to dependent functions. -/ +def mapCodHom [OFEFun (β₁ : α → _)] [OFEFun β₂] + (F : ∀ x, β₁ x -n> β₂ x) : ((x : α) → β₁ x) -n> ((x : α) → β₂ x) where + f f x := F x (f x) + ne.1 _ _ _ H x := (F x).ne.1 (H x) + +theorem mapCodHom_id [OFEFun (β : α → _)] (g : (x : α) → β x) : + mapCodHom (fun _ => Hom.id) g = g := rfl + +theorem mapCodHom_compose [OFEFun (β₁ : α → _)] [OFEFun β₂] [OFEFun β₃] + (f₁ : ∀ x, β₁ x -n> β₂ x) (f₂ : ∀ x, β₂ x -n> β₃ x) (g : (x : α) → β₁ x) : + mapCodHom (fun x => (f₂ x).comp (f₁ x)) g = mapCodHom f₂ (mapCodHom f₁ g) := rfl + +open Classical in +instance mapCod_lookup_discrete [OFEFun (β : α → _)] + (f : (x : α) → β x) (x : α) [hf : DiscreteE f] : DiscreteE (f x) where + discrete {y} h := by + let g : (x' : α) → β x' := fun x' => if e : x = x' then e ▸ y else f x' + have hgx : g x = y := dite_eq_left rfl + have hne : ∀ x', x ≠ x' → g x' = f x' := fun x' e => dite_eq_right e + refine (congrFun (hf.discrete fun x' => ?_) x).trans hgx + by_cases e : x = x' + · grind + · exact .of_eq (hne x' e).symm + +instance [OFE α] [OFE β] : OFE (α × β) where + Dist n a b := a.1 ≡{n}≡ b.1 ∧ a.2 ≡{n}≡ b.2 + dist_eqv := { + refl _ := ⟨dist_eqv.refl _, dist_eqv.refl _⟩ + symm h := ⟨dist_eqv.symm h.1, dist_eqv.symm h.2⟩ + trans h1 h2 := ⟨dist_eqv.trans h1.1 h2.1, dist_eqv.trans h1.2 h2.2⟩ + } + eq_dist' {_ _} := by rw [Prod.ext_iff]; simp only [eq_dist, forall_and] + dist_lt h1 h2 := ⟨dist_lt h1.1 h2, dist_lt h1.2 h2⟩ + +theorem equiv_fst {x y : α × β} (h : x = y) : x.fst = y.fst := congrArg Prod.fst h +theorem equiv_snd {x y : α × β} (h : x = y) : x.snd = y.snd := congrArg Prod.snd h +theorem equiv_prod_ext {x₁ x₂ : α} {y₁ y₂ : β} + (ex : x₁ = x₂) (ey : y₁ = y₂) : (x₁, y₁) = (x₂, y₂) := by subst ex; subst ey; rfl + +theorem dist_fst {n} [OFE α] [OFE β] {x y : α × β} (h : x ≡{n}≡ y) : x.fst ≡{n}≡ y.fst := h.left +theorem dist_snd {n} [OFE α] [OFE β] {x y : α × β} (h : x ≡{n}≡ y) : x.snd ≡{n}≡ y.snd := h.right + +theorem dist_prod_ext {n} [OFE α] [OFE β] {x₁ x₂ : α} {y₁ y₂ : β} + (ex : x₁ ≡{n}≡ x₂) (ey : y₁ ≡{n}≡ y₂) : (x₁, y₁) ≡{n}≡ (x₂, y₂) := ⟨ex, ey⟩ + +instance Prod.mk_ne [OFE α] [OFE β] : NonExpansive₂ (Prod.mk (α := α) (β := β)) where + ne _ _ _ hx _ _ hy := dist_prod_ext hx hy + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem prod_mk_ne_left [OFE α] [OFE β] (b : β) : NonExpansive (β := α × β) (·, b) := + ⟨fun {_ _ _} h => dist_prod_ext h Dist.rfl⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem prod_mk_ne_right [OFE α] [OFE β] (a : α) : NonExpansive (β := α × β) (a, ·) := + ⟨fun {_ _ _} h => dist_prod_ext Dist.rfl h⟩ + +instance [OFE α] [OFE β] : NonExpansive (Prod.fst (α := α) (β := β)) := + ⟨fun {_ _ _} h => dist_fst h⟩ + +instance [OFE α] [OFE β] : NonExpansive (Prod.snd (α := α) (β := β)) := + ⟨fun {_ _ _} h => dist_snd h⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive₂.uncurry [OFE α] [OFE β] [OFE γ] {f : α → β → γ} (hf : NonExpansive₂ f) : + NonExpansive (Function.uncurry f) := + ⟨fun {_ _ _} (h : _ ∧ _) => hf.ne h.1 h.2⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive.curry [OFE α] [OFE β] [OFE γ] {f : α × β → γ} (hf : NonExpansive f) : + NonExpansive₂ (Function.curry f) := + ⟨fun _ _ _ hx _ _ hy => hf.ne ⟨hx, hy⟩⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive.curry₃ [OFE α] [OFE β] [OFE γ] [OFE δ] {f : α × β × γ → δ} + (hf : NonExpansive f) : NonExpansive₃ fun a b c => f (a, b, c) := + ⟨fun _ _ _ hx _ _ hy _ _ hz => hf.ne ⟨hx, hy, hz⟩⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive₃.uncurry [OFE α] [OFE β] [OFE γ] [OFE δ] {f : α → β → γ → δ} + (hf : NonExpansive₃ f) : NonExpansive fun p : α × β × γ => f p.1 p.2.1 p.2.2 := + ⟨fun {_ _ _} (h : _ ∧ _ ∧ _) => hf.ne h.1 h.2.1 h.2.2⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive.curry₄ [OFE α] [OFE β] [OFE γ] [OFE δ] [OFE ε] {f : α × β × γ × δ → ε} + (hf : NonExpansive f) : NonExpansive₄ fun a b c d => f (a, b, c, d) := + ⟨fun _ _ _ hx _ _ hy _ _ hz _ _ hw => hf.ne ⟨hx, hy, hz, hw⟩⟩ + +/-- Note: Not an instance, due to instance coherence problems. -/ +theorem NonExpansive₄.uncurry [OFE α] [OFE β] [OFE γ] [OFE δ] [OFE ε] {f : α → β → γ → δ → ε} + (hf : NonExpansive₄ f) : NonExpansive fun p : α × β × γ × δ => f p.1 p.2.1 p.2.2.1 p.2.2.2 := + ⟨fun {_ _ _} (h : _ ∧ _ ∧ _ ∧ _) => hf.ne h.1 h.2.1 h.2.2.1 h.2.2.2⟩ + +instance prod.is_discrete [OFE α] [OFE β] {a : α} {b : β} [DiscreteE a] [DiscreteE b] : + DiscreteE (a, b) := by + constructor + intro y H; exact Prod.ext (DiscreteE.discrete H.1) (DiscreteE.discrete H.2) + +instance instDiscreteProd [OFE α] [OFE β] [Discrete α] [Discrete β] : Discrete (α × β) where + discrete_0 H := Prod.ext (discrete_0 H.1) (discrete_0 H.2) + +section sum + +theorem equiv_inl {x y : α} (h : x = y) : (.inl x : α ⊕ β) = .inl y := congrArg Sum.inl h +theorem equiv_inr {x y : β} (h : x = y) : (.inr x : α ⊕ β) = .inr y := congrArg Sum.inr h +theorem equiv_ext_left {x y : α} (h : (.inl x : α ⊕ β) = .inl y) : x = y := Sum.inl.inj h +theorem equiv_ext_right {x y : β} (h : (.inr x : α ⊕ β) = .inr y) : x = y := Sum.inr.inj h + +variable [OFE α] [OFE β] + +instance : OFE (α ⊕ β) where + Dist n + | .inl a, .inl b => a ≡{n}≡ b + | .inr a, .inr b => a ≡{n}≡ b + | _, _ => False + dist_eqv := { + refl + | .inl _ => dist_eqv.refl _ + | .inr _ => dist_eqv.refl _ + symm {a b} h := match a, b with + | .inl _, .inl _ => h.symm + | .inr _, .inr _ => h.symm + | .inr _, .inl _ => h + | .inl _, .inr _ => h + trans {a b c} h1 h2 := match a, b, c with + | .inl _, .inl _, .inl _ => h1.trans h2 + | .inr _, .inr _, .inr _ => h1.trans h2 + | .inr _, .inl _, _ => h1.elim + | .inl _, .inr _, _ => h1.elim + | _, .inr _, .inl _ => h2.elim + } + eq_dist' {a b} := by + match a, b with + | .inl _, .inl _ => rw [Sum.inl.injEq]; exact eq_dist + | .inr _, .inr _ => rw [Sum.inr.injEq]; exact eq_dist + | .inl _, .inr _ => exact ⟨fun h => (nomatch h), fun x => (x 0).elim⟩ + | .inr _, .inl _ => exact ⟨fun h => (nomatch h), fun x => (x 0).elim⟩ + dist_lt {_ a b} := match a, b with + | .inl _, .inl _ => dist_lt + | .inr _, .inr _ => dist_lt + | .inl _, .inr _ => (False.elim ·) + | .inr _, .inl _ => (False.elim ·) + +theorem dist_inl (h : x ≡{n}≡ y) : (.inl x : α ⊕ β) ≡{n}≡ .inl y := h +theorem dist_inr {x y : β} (h : x ≡{n}≡ y) : (.inr x : α ⊕ β) ≡{n}≡ .inr y := h + +theorem dist_ext_left {x y : α} (h : (.inl x : α ⊕ β) ≡{n}≡ .inl y) : x ≡{n}≡ y := h + +theorem dist_ext_right {x y : β} (h : (.inr x : α ⊕ β) ≡{n}≡ .inr y) : x ≡{n}≡ y := h + +instance instNonExpansiveInl : NonExpansive (Sum.inl (α := α) (β := β)) where + ne {_ _ _} H := dist_inl H + +instance instNonExpansiveInr : NonExpansive (Sum.inr (α := α) (β := β)) where + ne {_ _ _} H := dist_inr H + +instance instNonExpansiveElim [OFE γ] {f₁ : α → γ} {f₂ : β → γ} [NonExpansive f₁] [NonExpansive + f₂] : + NonExpansive (Sum.elim f₁ f₂) where + ne {_ x y} := match x, y with + | .inl _, .inl _ => (NonExpansive.ne (f := f₁) <| dist_ext_left ·) + | .inr _, .inr _ => (NonExpansive.ne (f := f₂) <| dist_ext_right ·) + | .inl _, .inr _ => (False.elim ·) + | .inr _, .inl _ => (False.elim ·) + +theorem discreteE_inl {a : α} (Ha : DiscreteE a) : DiscreteE (.inl a : α ⊕ β) := by + constructor + rintro (_|_) H + · exact congrArg Sum.inl (Ha.discrete H) + · exact H.elim + +theorem discreteE_inr {a : β} (Ha : DiscreteE a) : DiscreteE (.inr a : α ⊕ β) := by + constructor + rintro (_|_) H + · exact H.elim + · exact congrArg Sum.inr (Ha.discrete H) + +instance instDiscreteSum [Discrete α] [Discrete β] : Discrete (α ⊕ β) where + discrete_0 {x y} := match x, y with + | .inl _, .inl _ => (equiv_inl <| discrete_0 (α := α) <| dist_ext_left ·) + | .inr _, .inr _ => (equiv_inr <| discrete_0 (α := β) <| dist_ext_right ·) + | .inl _, .inr _ => (False.elim ·) + | .inr _, .inl _ => (False.elim ·) + +end sum + +instance [OFE α] (P : α → Prop) : OFE (Subtype P) where + Dist n x y := x.val ≡{n}≡ y.val + dist_eqv := ⟨fun _ => .rfl, Dist.symm, Dist.trans⟩ + eq_dist' {_ _} := Subtype.ext_iff.trans eq_dist + dist_lt := dist_lt + +instance [OFE α] (P : α → Prop) (x : Subtype P) [DiscreteE x.val] : DiscreteE x where + discrete h := Subtype.ext (DiscreteE.discrete h) + +instance [OFE α] [Discrete α] (P : α → Prop) : Discrete (Subtype P) where + discrete_0 h := Subtype.ext (Discrete.discrete_0 (α := α) h) + +theorem exist_ne [OFE α] {P : α → Prop} {n} {a1 a2 : α} (H1 : P a1) (H2 : P a2) + (h : a1 ≡{n}≡ a2) : (⟨a1, H1⟩ : Subtype P) ≡{n}≡ ⟨a2, H2⟩ := h + +instance [OFE α] (P : α → Prop) : NonExpansive (Subtype.val : Subtype P → α) where + ne {_ _ _} := id + +instance Hom.ofSubtype_ne [OFE α] [OFE β] : NonExpansive (Hom.ofSubtype (α := α) (β := β)) := + ⟨fun {_ _ _} h => h⟩ + +/-- Extract the underlying subtype from a `Hom`. -/ +def Hom.toSubtype [OFE α] [OFE β] (f : α -n> β) : { f : α → β // NonExpansive f } := + ⟨f.f, f.ne⟩ + +instance Hom.toSubtype_ne [OFE α] [OFE β] : NonExpansive (Hom.toSubtype (α := α) (β := β)) := + ⟨fun {_ _ _} h => h⟩ + +instance instOFESigma (P : α → Type _) [∀ x, OFE (P x)] : OFE (Sigma P) where + Dist n x y := ∃ heq : x.fst = y.fst, heq ▸ x.snd ≡{n}≡ y.snd + dist_eqv := { + refl _ := ⟨rfl, .rfl⟩ + symm {x y} := match x, y with + | ⟨x, xH⟩, ⟨y, yH⟩ => fun + | ⟨heq, H⟩ => ⟨heq.symm, by simp only at heq; subst heq; exact H.symm⟩ + trans {x y z} := match x, y, z with + | ⟨x, xH⟩, ⟨y, yH⟩, ⟨z, zH⟩ => fun + | ⟨heq, H⟩, ⟨heq', H'⟩ => + ⟨heq.trans heq', by simp only at heq heq'; subst heq; subst heq'; exact H.trans H'⟩ + } + eq_dist' {x y} := by + refine ⟨fun h n => h ▸ ⟨rfl, .rfl⟩, fun h => ?_⟩ + obtain ⟨heq, _⟩ := h 0 + obtain ⟨xf, xs⟩ := x; obtain ⟨yf, ys⟩ := y + simp only at heq; subst heq + exact congrArg _ (eq_dist_2 fun n => (h n).2) + dist_lt {_ x y} := match x, y with + | ⟨x, xH⟩, ⟨y, yH⟩ => fun + | ⟨heq, H⟩ => fun hlt => ⟨heq, by simp only at heq; subst heq; exact dist_lt H hlt⟩ + +instance instDiscreteESigma {P : α → Type _} [∀ x, OFE (P x)] {x : Sigma P} [inst : DiscreteE + x.snd] : + DiscreteE x where + discrete {y} := by + rcases x, y with ⟨⟨x, xH⟩, ⟨y, yH⟩⟩; rintro ⟨heq, H⟩ + simp only at heq; subst heq + exact congrArg _ (inst.discrete H) + +instance instDiscreteSigma {P : α → Type _} [∀ x, OFE (P x)] [∀ x, Discrete (P x)] : + Discrete (Sigma P) where + discrete_0 {x y} H := match x, y, H with + | ⟨x, xH⟩, ⟨y, yH⟩, ⟨heq, H⟩ => by simp only at heq; subst heq; exact congrArg _ (discrete_0 H) + +theorem Sigma.equiv_eq_alt {P : α → Type _} {x1 x2 : Sigma P} : + x1 = x2 ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd = x2.snd := by + refine ⟨fun h => h ▸ ⟨rfl, rfl⟩, fun ⟨heq, h⟩ => ?_⟩ + obtain ⟨x1f, x1s⟩ := x1; obtain ⟨x2f, x2s⟩ := x2 + simp only at heq; subst heq; simp only at h; subst h; rfl + +theorem Sigma.equiv_eq {P : α → Type _} [∀ x, OFE (P x)] {x1 x2 : Sigma P} : + x1 = x2 ↔ ∀ n, x1 ≡{n}≡ x2 := eq_dist + +theorem Sigma.dist_eq {P : α → Type _} [∀ x, OFE (P x)] {n} {x1 x2 : Sigma P} : + (x1 ≡{n}≡ x2) ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd ≡{n}≡ x2.snd := Iff.rfl + +theorem Sigma.dist_proj1 {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P} + (h : x ≡{n}≡ y) : x.fst = y.fst := h.1 + +theorem Sigma.equiv_proj1 {P : α → Type _} {x y : Sigma P} + (h : x = y) : x.fst = y.fst := congrArg Sigma.fst h + +instance Sigma.fst_ne {P : α → Type _} [OFE α] [∀ x, OFE (P x)] : + NonExpansive (Sigma.fst : Sigma P → α) where + ne {_ _ _} h := Dist.of_eq h.1 + +/-- The first components of `n`-equivalent dependent pairs are equal. + +Split out of `Sigma.dist_snd` so that the projection happens in a body rather than in a statement: +in a statement the `OFE (Sigma P)` instance argument is still an unsolved metavariable, so `h`'s +type cannot be reduced to the `∃ heq, ..` of `instOFESigma` to project out of. -/ +theorem Sigma.dist_fst {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P} + (h : x ≡{n}≡ y) : x.fst = y.fst := h.1 + +theorem Sigma.dist_snd {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P} + (h : x ≡{n}≡ y) : Sigma.dist_fst h ▸ x.snd ≡{n}≡ y.snd := h.2 + +theorem Sigma.equiv_snd {P : α → Type _} {x y : Sigma P} + (h : x = y) : congrArg Sigma.fst h ▸ x.snd = y.snd := by + subst h; rfl + +theorem Sigma.mk_dist {P : α → Type _} [∀ x, OFE (P x)] {n} {i1 i2 : α} {v1 : P i1} {v2 : P i2} + (heq : i1 = i2) (h : heq ▸ v1 ≡{n}≡ v2) : Sigma.mk i1 v1 ≡{n}≡ Sigma.mk i2 v2 := + ⟨heq, h⟩ + +theorem Sigma.mk_equiv {P : α → Type _} {i1 i2 : α} {v1 : P i1} {v2 : P i2} + (heq : i1 = i2) (h : heq ▸ v1 = v2) : Sigma.mk i1 v1 = Sigma.mk i2 v2 := by + subst heq; subst h; rfl + +instance Sigma.mk_ne {P : α → Type _} [∀ x, OFE (P x)] (a : α) : + NonExpansive (Sigma.mk a : P a → Sigma P) where + ne {_ _ _} h := ⟨rfl, h⟩ + +/-- An isomorphism between two OFEs is a pair of morphisms whose composition is equivalent to the +identity morphism. -/ +@[ext] structure Iso (α β : Type _) [OFE α] [OFE β] where + /-- The forward non-expansive map of an isomorphism. -/ + hom : α -n> β + /-- The inverse non-expansive map of an isomorphism. -/ + inv : β -n> α + hom_inv : hom (inv x) = x + inv_hom : inv (hom x) = x + +attribute [simp] Iso.hom_inv Iso.inv_hom + +instance [OFE α] [OFE β] : CoeFun (Iso α β) (fun _ => α -n> β) := ⟨Iso.hom⟩ +instance [OFE α] [OFE β] (iso : Iso α β) : NonExpansive iso.hom := iso.hom.ne +instance [OFE α] [OFE β] (iso : Iso α β) : NonExpansive iso.inv := iso.inv.ne + +theorem Iso.hom_inv_dist [OFE α] [OFE β] (iso : Iso α β) {n} {x} : + iso.hom (iso.inv x) ≡{n}≡ x := + (Iso.hom_inv iso).dist + +theorem Iso.inv_hom_dist [OFE α] [OFE β] (iso : Iso α β) {n} {x} : + iso.inv (iso.hom x) ≡{n}≡ x := + (Iso.inv_hom iso).dist + +/-- OFE isomorphisms preserve equivalence. -/ +theorem Iso.hom_eqv [OFE α] [OFE β] (iso : Iso α β) ⦃x y⦄ : + x = y ↔ iso.hom x = iso.hom y := + ⟨fun h => h ▸ rfl, + fun h => iso.inv_hom.symm.trans ((congrArg iso.inv h).trans iso.inv_hom)⟩ + +/-- The inverse of an OFE isomorphism preserves equivalence. -/ +theorem Iso.inv_eqv [OFE α] [OFE β] (iso : Iso α β) ⦃x y⦄ : + x = y ↔ iso.inv x = iso.inv y := + ⟨fun h => h ▸ rfl, + fun h => iso.hom_inv.symm.trans ((congrArg iso.hom h).trans iso.hom_inv)⟩ + +/-- OFE isomorphisms preserve `n`-equivalence. -/ +theorem Iso.hom_dist [OFE α] [OFE β] (iso : Iso α β) {n} ⦃x y⦄ : + x ≡{n}≡ y ↔ iso.hom x ≡{n}≡ iso.hom y := + ⟨fun h => NonExpansive.ne h, fun h => Dist.trans (Dist.symm iso.inv_hom_dist) <| + Dist.trans (NonExpansive.ne h) (iso.inv_hom_dist)⟩ + +/-- The inverse of an OFE isomorphism preserves `n`-equivalence. -/ +theorem Iso.inv_dist [OFE α] [OFE β] (iso : Iso α β) {n} ⦃x y⦄ : + x ≡{n}≡ y ↔ iso.inv x ≡{n}≡ iso.inv y := + ⟨fun h => NonExpansive.ne h, fun h => Dist.trans (Dist.symm iso.hom_inv_dist) <| + Dist.trans (NonExpansive.ne h) (iso.hom_inv_dist)⟩ + +/-- The identity OFE isomorphism -/ +def Iso.id [OFE α] : Iso α α where + hom := Hom.id + inv := Hom.id + hom_inv := by intro x; simp + inv_hom := by intro x; simp + +@[simp] theorem Iso.id_apply [OFE α] {x} : ((Iso.id : Iso α α) : α -n> α) x = x := rfl + +/-- The inverse of an OFE isomorphism -/ +def Iso.symm [OFE α] [OFE β] (iso : Iso α β) : Iso β α where + hom := iso.inv + inv := iso.hom + hom_inv := by intro x; simp + inv_hom := by intro x; simp + +/-- Composition of OFE isomorphisms -/ +def Iso.comp [OFE α] [OFE β] [OFE γ] (iso1 : Iso β γ) (iso2 : Iso α β) : Iso α γ where + hom := iso1.hom.comp iso2.hom + inv := iso2.inv.comp iso1.inv + hom_inv := by intro x; simp + inv_hom := by intro x; simp + +end OFE + +/-- A chain in an OFE is a `Nat`-indexed sequence of elements that is upward-closed in terms of +`n`-equivalence. -/ +structure Chain (α : Type _) [OFE α] where + /-- The approximation at each natural-number index. -/ + chain : Nat → α + cauchy : n ≤ i → chain i ≡{n}≡ chain n + +instance [OFE α] : CoeFun (Chain α) (fun _ => Nat → α) := ⟨Chain.chain⟩ + +namespace Chain + +/-- The constant chain. -/ +def const [OFE α] (a : α) : Chain α where + chain := fun _ => a + cauchy _ := OFE.Dist.rfl + +@[simp] theorem const_apply [OFE α] {a : α} {n} : const a n = a := rfl + +/-- Mapping a chain through a non-expansive function. -/ +def map [OFE α] [OFE β] (f : α -n> β) (c : Chain α) : Chain β where + chain n := f (c n) + cauchy h := f.ne.1 (c.cauchy h) + +@[simp] theorem map_apply [OFE α] [OFE β] {f : α -n> β} {c : Chain α} {n} : + map f c n = f (c n) := rfl + +@[simp] theorem map_id [OFE α] {c : Chain α} : map (Hom.id : α -n> α) c = c := by + simp [map] + +theorem map_comp [OFE α] [OFE β] [OFE γ] {f : α -n> β} {g : β -n> γ} {c : Chain α} : + map (g.comp f) c = map g (map f c) := by + simp [map] + +/-- If a chain of Option is ever none, is the constant none chain. -/ +theorem chain_none_const [OFE V] {c : Chain (Option V)} (H : c n = none) : + c = Chain.const none := by + rcases c with ⟨c, Hc⟩ + congr 1; refine funext (fun k => ?_) + rcases Nat.le_or_ge n k with (Hnk|Hnk) + · suffices c k ≡{n}≡ c n by cases _ : c k <;> simp_all + exact Hc Hnk + · suffices c k ≡{k}≡ c n by cases _ : c k <;> simp_all + exact (Hc Hnk).symm + +/-- If a chain of Option is ever some, it is the lift a chain by some. -/ +theorem chain_option_some [OFE V] {c : Chain (Option V)} (H : c n = some v) : + ∃ c' : Chain V, c = Chain.map ⟨some, OFE.Option.some.ne⟩ c' := by + have HVc (k) : ∃ v', c k = some v' := by + rcases h : c.chain k with (_|v') + · simp [chain_none_const h] at H + · exists v' + let c' : Chain V := + ⟨fun n => Classical.choose <| HVc n, + by + intro n i Hni + have HR := c.cauchy Hni + rw [Classical.choose_spec (HVc n), Classical.choose_spec (HVc i)] at HR + exact HR ⟩ + exists c' + rcases hcc : c with ⟨cc, Hcc⟩ + simp only [Chain.map, Chain.mk.injEq] + refine funext (fun i => ?_) + simp only [c'] + have Hchoose := Classical.choose_spec (HVc i) + rw [← Hchoose] + simp [hcc] + +end Chain + +/-- Complete ordered family of equivalences -/ +class IsCOFE (α : Type _) [OFE α] where + /-- Complete a Cauchy chain in the ordered equivalence space. -/ + compl : Chain α → α + conv_compl {c : Chain α} : compl c ≡{n}≡ c n + +/-- Complete ordered family of equivalences -/ +class COFE (α : Type _) extends OFE α, IsCOFE α + +instance [OFE α] [IsCOFE α] : COFE α := {} + +namespace COFE +export IsCOFE (compl conv_compl) + +theorem conv_compl' [COFE α] {c : Chain α} {n i} (h : n ≤ i) : compl c ≡{n}≡ c i := + conv_compl.trans (c.cauchy h).symm + +/-- Chain maps commute with completion. -/ +theorem compl_map [COFE α] [COFE β] (f : α -n> β) (c : Chain α) : + compl (Chain.map f c) = f (compl c) := by + refine OFE.eq_dist_2 (fun n => ?_) + exact Dist.trans conv_compl (NonExpansive.ne (Dist.symm conv_compl)) + +/-- Constant chains complete to their constant value -/ +@[simp] +theorem compl_const [COFE α] (a : α) : compl (Chain.const a) = a := + OFE.eq_dist_2 (fun _ => conv_compl) + +/-- Completion of discrete COFEs is the constant value. -/ +@[simp] theorem discrete_cofe_compl [COFE α] [OFE.Discrete α] (c : Chain α) : compl c = c 0 := + Discrete.discrete_0 conv_compl + +/-- The discrete COFE obtained from an equality relation `Eq` -/ +@[reducible] +def ofDiscrete (α : Type _) : COFE α := + letI : OFE α := OFE.ofDiscrete α + { + compl := fun c => c 0 + conv_compl := fun {n c} => (c.cauchy (Nat.zero_le n)).symm + } + +instance [COFE α] : COFE (ULift α) where + compl c := ⟨compl (c.map uliftDownHom)⟩ + conv_compl := conv_compl + +instance : Discrete Unit where + discrete_0 _ := Subsingleton.elim _ _ + +instance : COFE Unit where + compl _ := () + conv_compl := ⟨⟩ + +instance : Discrete Empty where + discrete_0 {x} _ := x.elim + +instance : COFE Empty where + compl c := (c 0).elim + conv_compl {_ c} := (c 0).elim + +/-- Pointwise completeness of a family of ordered equivalence spaces. -/ +abbrev IsCOFEFun {α : Type _} (β : α → Type _) [OFEFun β] := ∀ x : α, IsCOFE (β x) + +instance {α : Type _} (β : α → Type _) [∀ x, COFE (β x)] : COFE ((x : α) → β x) where + compl c x := compl (c.map (applyHom x)) + conv_compl _ := IsCOFE.conv_compl + +instance instIsCOFEHom [OFE α] [OFE β] [IsCOFE β] : IsCOFE (α -n> β) where + compl c := by + refine ⟨(compl <| c.map <| applyNe ·), ⟨fun n _ _ H => ?_⟩⟩ + refine conv_compl.trans (.trans ?_ conv_compl.symm) + exact NonExpansive.ne (f := c.chain n) H + conv_compl _ := IsCOFE.conv_compl + +instance instIsCOFEProd [OFE α] [OFE β] [IsCOFE α] [IsCOFE β] : IsCOFE (α × β) where + compl c := ⟨compl (c.map ⟨Prod.fst, inferInstance⟩), compl (c.map ⟨Prod.snd, inferInstance⟩)⟩ + conv_compl := ⟨conv_compl, conv_compl⟩ + +instance instIsCOFESum [OFE α] [OFE β] [IsCOFE α] [IsCOFE β] : IsCOFE (α ⊕ β) where + compl c := match c 0 with + | .inl seed => .inl (compl (c.map ⟨Sum.elim id (Function.const _ seed), inferInstance⟩)) + | .inr seed => .inr (compl (c.map ⟨Sum.elim (Function.const _ seed) id, inferInstance⟩)) + conv_compl {n c} := by + cases h1 : c.chain 0 with + | inl seed => + refine (dist_inl conv_compl).trans ?_ + dsimp only [Chain.map_apply] + cases h2 : c.chain n with + | inl _ => simp + | inr _ => exact (h1 ▸ h2 ▸ c.cauchy (by omega : 0 ≤ n)).elim + | inr seed => + refine (dist_inr conv_compl).trans ?_ + dsimp only [Chain.map_apply] + cases h2 : c.chain n with + | inl _ => exact (h1 ▸ h2 ▸ c.cauchy (by omega : 0 ≤ n)).elim + | inr _ => simp + +theorem Sigma.chain_const_proj1 {P : α → Type _} [∀ x, OFE (P x)] + (c : Chain (Sigma P)) n : (c n).fst = (c 0).fst := (c.cauchy (by omega : 0 ≤ n)).choose + +/-- Transport a dependent-pair chain into the fiber of its constant first component. -/ +def Sigma.chainMapSnd {P : α → Type _} [∀ x, OFE (P x)] (c : Chain (Sigma P)) : + Chain (P (c 0).fst) where + chain n := Sigma.chain_const_proj1 c n ▸ (c n).snd + cauchy {n i} hle := by + obtain ⟨heq, hequiv⟩ := c.cauchy hle + clear hle + rw [show Sigma.chain_const_proj1 c i = heq.trans (Sigma.chain_const_proj1 c n) by rfl] + generalize Sigma.chain_const_proj1 c n = heq' + revert heq' hequiv heq; cases c.chain i; cases c.chain n + rintro ⟨⟩ hequiv ⟨⟩ + exact hequiv + +instance {P : α → Type _} [∀ x, OFE (P x)] [∀ x, IsCOFE (P x)] : IsCOFE (Sigma P) where + compl c := ⟨(c 0).fst, compl (Sigma.chainMapSnd c)⟩ + conv_compl {n c} := by + refine ⟨(Sigma.chain_const_proj1 c n).symm, ?_⟩ + have hequiv := conv_compl (c := Sigma.chainMapSnd c) (n := n) + revert hequiv + dsimp only [Sigma.chainMapSnd] + generalize Sigma.chain_const_proj1 c n = heq + revert heq; cases c.chain n + rintro ⟨⟩ hequiv + exact hequiv + +/-- A mixed-variance family of ordered equivalence spaces with a non-expansive action. -/ +class OFunctor (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) where + ofe [COFE α] [COFE β] : OFE (F α β) + /-- The contravariant and covariant action on non-expansive maps. -/ + map [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + (α₂ -n> α₁) → (β₁ -n> β₂) → F α₁ β₁ -n> F α₂ β₂ + map_ne [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + NonExpansive₂ (@map α₁ α₂ β₁ β₂ _ _ _ _) + map_id [COFE α] [COFE β] (x : F α β) : map (Hom.id (α := α)) (Hom.id (α := β)) x = x + map_comp [COFE α₁] [COFE α₂] [COFE α₃] [COFE β₁] [COFE β₂] [COFE β₃] + (f : α₂ -n> α₁) (g : α₃ -n> α₂) (f' : β₁ -n> β₂) (g' : β₂ -n> β₃) (x : F α₁ β₁) : + map (f.comp g) (g'.comp f') x = map g g' (map f f' x) + +/-- A mixed-variance space functor whose action on morphisms is contractive. -/ +class OFunctorContractive (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type + _)) extends OFunctor F where + map_contractive [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] : + Contractive (Function.uncurry (@map α₁ α₂ β₁ β₂ _ _ _ _)) + +attribute [reducible, instance] OFunctor.ofe + +end COFE + +/-- A type equipped with equality as its step-indexed equivalence. -/ +@[ext] structure DiscreteO (α : Type _) where + /-- The underlying element of a discrete ordered equivalence space. -/ + car : α + +section DiscreteO +instance : COFE (DiscreteO α) := COFE.ofDiscrete _ +instance {α : Type _} : OFE.Discrete (DiscreteO α) := ⟨fun h => h⟩ + +theorem DiscreteO.eqv_inj {x y : α} (H : DiscreteO.mk x = DiscreteO.mk y) : x = y := + congrArg DiscreteO.car H + +theorem DiscreteO.dist_inj {x y : α} {n} (H : DiscreteO.mk x ≡{n}≡ DiscreteO.mk y) : x = y := + DiscreteO.eqv_inj <| discrete H + +end DiscreteO + +section ComposeOF +open COFE + +/-- The composition of two functors, `F₁` applied to `F₂`. -/ +abbrev ComposeOF (F₁ F₂ : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [OFunctor F₂] + [∀ α β, [COFE α] → [COFE β] → IsCOFE (F₂ α β)] : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _) := + fun α β _ _ => F₁ (F₂ β α) (F₂ α β) + +theorem COFE.OFunctor.map_id_eq {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → + Type _)} [OFunctor F] [COFE α] [COFE β] : + OFunctor.map (F := F) (Hom.id (α := α)) (Hom.id (α := β)) = Hom.id := + Hom.ext (funext fun y => OFunctor.map_id y) + +theorem COFE.OFunctor.map_comp_eq {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] + → Type _)} [OFunctor F] + [COFE α₁] [COFE α₂] [COFE α₃] [COFE β₁] [COFE β₂] [COFE β₃] + (f : α₂ -n> α₁) (g : α₃ -n> α₂) (f' : β₁ -n> β₂) (g' : β₂ -n> β₃) : + OFunctor.map (F := F) (f.comp g) (g'.comp f') = + (OFunctor.map g g').comp (OFunctor.map f f') := + Hom.ext (funext fun y => OFunctor.map_comp f g f' g' y) + +theorem COFE.OFunctorContractive.map_distLater {F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)} [OFunctorContractive F] + [COFE α₁] [COFE α₂] [COFE β₁] [COFE β₂] {n} {f₁ f₂ : α₂ -n> α₁} {g₁ g₂ : β₁ -n> β₂} + (hf : DistLater n f₁ f₂) (hg : DistLater n g₁ g₂) (x : F α₁ β₁) : + OFunctor.map f₁ g₁ x ≡{n}≡ OFunctor.map f₂ g₂ x := + map_contractive.1 (x := (f₁, g₁)) (y := (f₂, g₂)) (fun m hm => ⟨hf m hm, hg m hm⟩) x + +variable {F₁ F₂ : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)} [OFunctor + F₂] [∀ α β, [COFE α] → [COFE β] → IsCOFE (F₂ α β)] + +open OFunctor in +instance oFunctorComposeOF [OFunctor F₁] : OFunctor (ComposeOF F₁ F₂) where + ofe := _ + map f g := map (F := F₁) (map (F := F₂) g f) (map (F := F₂) f g) + map_ne.ne _ _ _ hf _ _ hg _ := + (map_ne (F := F₁)).ne (fun _ => (map_ne (F := F₂)).ne hg hf _) + (fun _ => (map_ne (F := F₂)).ne hf hg _) _ + map_id _ := by + simp only [map_id_eq] + rfl + map_comp _ _ _ _ _ := by + simp only [map_comp_eq] + rfl + +open OFunctor OFunctorContractive in +instance oFunctorComposeOFContractiveLeft [OFunctorContractive F₁] : + OFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + map_distLater (F := F₁) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).2 (h m hm).1 _) + (fun m hm _ => (map_ne (F := F₂)).ne (h m hm).1 (h m hm).2 _) x⟩ + +end ComposeOF + +section ComposeOFContractive +open COFE OFunctor OFunctorContractive + +variable {F₁ F₂ : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)} + [OFunctorContractive F₂] + [∀ α β, [COFE α] → [COFE β] → IsCOFE (F₂ α β)] + +instance oFunctorComposeOFContractiveRight [OFunctor F₁] : + OFunctorContractive (ComposeOF F₁ F₂) where + map_contractive := ⟨fun {_ _ _} h x => + (map_ne (F := F₁)).ne + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).2) (fun m hm => (h m hm).1) _) + (fun _ => map_distLater (F := F₂) (fun m hm => (h m hm).1) (fun m hm => (h m hm).2) _) x⟩ + +end ComposeOFContractive + +section DiscreteFunOF +open COFE + +/-- The pointwise product of an indexed family of space functors. -/ +abbrev DiscreteFunOF {C : Type _} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)) : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type + _) := + fun A B _ _ => (c : C) → F c A B + +instance oFunctorDiscreteFunOF {C} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → + [Iris.COFE β] → Type _)) [∀ c, OFunctor (F c)] : + OFunctor (DiscreteFunOF F) where + ofe := _ + map f₁ f₂ := mapCodHom fun _ => OFunctor.map f₁ f₂ + map_ne.ne _ _ _ Hx _ _ Hy _ _ := OFunctor.map_ne.ne Hx Hy .. + map_id x := funext fun c => OFunctor.map_id (x c) + map_comp f g f' g' x := funext fun c => OFunctor.map_comp f g f' g' (x c) + +instance oFunctorDiscreteFunOFContractive {C} (F : C → (∀ (α : Type _) (β : Type _), [Iris.COFE + α] → [Iris.COFE β] → Type _)) + [∀ c, OFunctorContractive (F c)] : OFunctorContractive (DiscreteFunOF F) where + map_contractive.1 h _ _ := OFunctorContractive.map_contractive.distLater_dist h _ + +end DiscreteFunOF + +section Option +variable [OFE α] + +/-- Extract a chain of values from an optional chain, using a fallback for absence. -/ +def optionChain (c : Chain (Option α)) (x : α) : Chain α := by + refine ⟨fun n => (c n).getD x, fun {n i} H => ?_⟩ + have := c.cauchy H; revert this + cases c.chain i <;> cases c.chain n <;> simp [OFE.Dist, Option.Forall₂] + +instance isCOFEOption [IsCOFE α] : IsCOFE (Option α) where + compl c := (c 0).map fun x => IsCOFE.compl (optionChain c x) + conv_compl {n} c := by + have := c.cauchy (Nat.zero_le n); revert this + rcases c.chain 0 with _|x' <;> rcases e : c.chain n with _|y' <;> simp only [Dist, + Option.Forall₂, Option.map_none, imp_self, Option.map_some] + refine fun _ => OFE.dist_eqv.trans IsCOFE.conv_compl ?_ + simp [optionChain, e] + +/-- Lift a non-expansive map to optional values. -/ +def optionMap {α β : Type _} [OFE α] [OFE β] (f : α -n> β) : Option α -n> Option β := by + refine ⟨Option.map f, ⟨?_⟩⟩ + rintro _ ⟨⟩ ⟨⟩ H <;> simp_all only [Dist, Option.Forall₂, Option.map_none, Option.map_some] + exact f.ne.ne H + +theorem Option.map_ne [OFE β] {f g : α → β} {x y : Option α} {n} : + (∀ x y, x ≡{n}≡ y → f x ≡{n}≡ g y) → x ≡{n}≡ y → Option.map f x ≡{n}≡ Option.map g y := by + intro hf hxy + cases x with + | none => cases y with + | none => exact .rfl + | some _ => exact hxy.elim + | some a => cases y with + | none => exact hxy.elim + | some b => exact hf a b hxy + +theorem Option.map_forall₂ {α β : Type _} (f : α → β) + {o1 o2 : Option α} (h : o1 = o2) : o1.map f = o2.map f := congrArg (Option.map f) h + +instance optionMap_ne [OFE β] : NonExpansive (optionMap (α := α) (β := β)) where + ne _ f _ h o := + Option.map_ne (fun _ _ hab => dist_eqv.trans (f.ne.ne hab) (h _)) (dist_eqv.refl o) + +theorem Option.bind_ne [OFE β] {f g : α → Option β} {x y : Option α} {n} + (hf : ∀ x y, x ≡{n}≡ y → f x ≡{n}≡ g y) (hxy : x ≡{n}≡ y) : x.bind f ≡{n}≡ y.bind g := by + cases x with + | none => cases y with + | none => exact .rfl + | some _ => exact hxy.elim + | some a => cases y with + | none => exact hxy.elim + | some b => exact hf a b hxy + +theorem Option.join_ne {x y : Option (Option α)} {n} (hxy : x ≡{n}≡ y) : x.join ≡{n}≡ y.join := by + cases x with + | none => cases y with + | none => exact .rfl + | some _ => exact hxy.elim + | some a => cases y with + | none => exact hxy.elim + | some b => exact hxy + +theorem Option.elim_ne {β : Type _} (R : β → β → Prop) {f g : α → β} {d d' : β} + {x y : Option α} {n} (hf : ∀ x y, x ≡{n}≡ y → R (f x) (g y)) (hd : R d d') + (hxy : x ≡{n}≡ y) : R (x.elim d f) (y.elim d' g) := by + cases x with + | none => cases y with + | none => exact hd + | some _ => exact hxy.elim + | some a => cases y with + | none => exact hxy.elim + | some b => exact hf a b hxy + +end Option + +section OptionOF +open COFE + +/-- Lift a space functor to optional values. -/ +abbrev OptionOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : (∀ + (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun A B _ _ => Option (F A B) + +variable (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + +instance oFunctorOption [OFunctor F] : OFunctor (OptionOF F) where + ofe := _ + map f g := optionMap (OFunctor.map f g) + map_ne.ne _ _ _ Hx _ _ Hy z := by + cases z <;> simp only [Dist, Option.Forall₂, optionMap, Option.map_none, Option.map_some] + exact OFunctor.map_ne.ne Hx Hy .. + map_id z := by + cases z with + | none => rfl + | some c => exact congrArg some (OFunctor.map_id c) + map_comp f g f' g' z := by + cases z with + | none => rfl + | some c => exact congrArg some (OFunctor.map_comp f g f' g' c) + +instance [OFunctorContractive F] : OFunctorContractive (OptionOF F) where + map_contractive.1 H z := by + have := (OFunctorContractive.map_contractive (F := F)).distLater_dist H + cases z <;> simp_all [optionMap, OFE.Dist, Option.Forall₂, Function.uncurry, OFunctor.map] + +end OptionOF + +section ProdOF + +open COFE + +variable [OFE A] [OFE A'] [OFE B] [OFE B'] + +instance instNonExpansiveProdMap (f : A → A') (g : B → B') [NonExpansive f] [NonExpansive g] : + NonExpansive (Prod.map f g) where + ne _ _ _ H := by + constructor + · rw [Prod.map_fst] + exact NonExpansive.ne H.1 + · rw [Prod.map_snd] + exact NonExpansive.ne H.2 + +omit [OFE A] [OFE A'] [OFE B] [OFE B'] in +theorem Prod.map_ext {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a = f' a) + (Hg : ∀ a, g a = g' a) : Prod.map f g x = Prod.map f' g' x := + Prod.ext (Hf x.fst) (Hg x.snd) + +omit [OFE A] [OFE B] in +theorem Prod.map_ne {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a ≡{n}≡ f' a) + (Hg : ∀ a, g a ≡{n}≡ g' a) : Prod.map f g x ≡{n}≡ Prod.map f' g' x := + ⟨Hf x.fst, Hg x.snd⟩ + +/-- The product of two non-expansive maps. -/ +def Prod.mapO (f : A -n> A') (g : B -n> B') : A × B -n> A' × B' where + f := .map f g + ne := inferInstance + +instance Prod.mapO_ne : NonExpansive₂ (Prod.mapO (A := A) (A' := A') (B := B) (B' := B')) where + ne _ _ _ Hf _ _ Hg _ := Prod.map_ne Hf Hg + +/-- The pointwise product of two mixed-variance space functors. -/ +abbrev ProdOF (F1 F2 : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : (∀ + (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun A B => (F1 A B) × (F2 A B) + +open OFunctor in +instance instOFunctorProdOF [OFunctor F1] [OFunctor F2] : OFunctor (ProdOF F1 F2) where + ofe := inferInstance + map f g := Prod.mapO (map f g) (map f g) + map_ne.ne _ _ _ Hx _ _ Hy _ := ⟨map_ne.ne Hx Hy _, map_ne.ne Hx Hy _⟩ + map_id _ := equiv_prod_ext (map_id _) (map_id _) + map_comp _ _ _ _ _ := equiv_prod_ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) + +open OFunctorContractive in +instance instOFunctorContractiveProdOF [OFunctorContractive F1] [OFunctorContractive F2] : + OFunctorContractive (ProdOF F1 F2) where + map_contractive.1 H _ := + Prod.map_ne (fun _ => map_contractive.1 H _) (fun _ => map_contractive.1 H _) + +end ProdOF + +section SumOF + +open COFE + +variable [OFE A] [OFE A'] [OFE B] [OFE B'] + +instance instNonExpansiveSumMap (f : A → A') (g : B → B') [NonExpansive f] [NonExpansive g] : + NonExpansive (Sum.map f g) where + ne _ x y H := match x, y with + | .inl _, .inl _ => NonExpansive.ne (f := Sum.inl) (NonExpansive.ne (dist_ext_left H)) + | .inr _, .inr _ => NonExpansive.ne (f := Sum.inr) (NonExpansive.ne (dist_ext_right H)) + +omit [OFE A] [OFE A'] [OFE B] [OFE B'] in +theorem Sum.map_ext {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a = f' a) + (Hg : ∀ a, g a = g' a) : Sum.map f g x = Sum.map f' g' x := + match x with + | .inl _ => equiv_inl (Hf _) + | .inr _ => equiv_inr (Hg _) + +omit [OFE A] [OFE B] in +theorem Sum.map_ne {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a ≡{n}≡ f' a) + (Hg : ∀ a, g a ≡{n}≡ g' a) : Sum.map f g x ≡{n}≡ Sum.map f' g' x := + match x with + | .inl _ => dist_inl (Hf _) + | .inr _ => dist_inr (Hg _) + +/-- The sum of two non-expansive maps. -/ +def Sum.mapO (f : A -n> A') (g : B -n> B') : A ⊕ B -n> A' ⊕ B' where + f := .map f g + ne := inferInstance + +instance Sum.mapO_ne : NonExpansive₂ (Sum.mapO (A := A) (A' := A') (B := B) (B' := B')) where + ne _ _ _ Hf _ _ Hg _ := Sum.map_ne Hf Hg + +/-- The pointwise sum of two mixed-variance space functors. -/ +abbrev SumOF (F1 F2 : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : (∀ + (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := fun A B => (F1 A B) ⊕ + (F2 A B) + +open OFunctor in +instance instOFunctorSumOF [OFunctor F1] [OFunctor F2] : OFunctor (SumOF F1 F2) where + ofe := inferInstance + map f g := Sum.mapO (map f g) (map f g) + map_ne.ne _ _ _ Hx _ _ Hy x := match x with + | .inl _ => dist_inl (map_ne.ne Hx Hy _) + | .inr _ => dist_inr (map_ne.ne Hx Hy _) + map_id x := match x with + | .inl _ => equiv_inl (map_id _) + | .inr _ => equiv_inr (map_id _) + map_comp _ _ _ _ x := match x with + | .inl _ => equiv_inl (map_comp _ _ _ _ _) + | .inr _ => equiv_inr (map_comp _ _ _ _ _) + +open OFunctorContractive in +instance instOFunctorContractiveSumOF [OFunctorContractive F1] [OFunctorContractive F2] : + OFunctorContractive (SumOF F1 F2) where + map_contractive.1 H _ := + Sum.map_ne (fun _ => map_contractive.1 H _) (fun _ => map_contractive.1 H _) + +end SumOF + +section SigmaOF + +open COFE + +/-- Map non-expansive fiber maps over dependent pairs. -/ +def Sigma.mapO {P1 P2 : A → Type _} [∀ x, OFE (P1 x)] [∀ x, OFE (P2 x)] : + ((a : A) → P1 a -n> P2 a) -n> Sigma P1 -n> Sigma P2 where + f g := ⟨fun x => ⟨_, g x.fst x.snd⟩, ⟨by rintro n ⟨x, xH⟩ ⟨y, yH⟩ ⟨⟨⟩, hdist⟩; exact ⟨rfl, (g + x).ne.ne hdist⟩⟩⟩ + ne := ⟨fun n f g hdist x => ⟨rfl, hdist _ _⟩⟩ + +open OFunctor in +/-- The dependent sum of an indexed family of space functors. -/ +abbrev SigmaOF (F : A → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : + (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun B C => Sigma (fun (a : A) => (F a) B C) + +open OFunctor in +instance instOFunctorSigmaOF {F : A → (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] + → Type _)} [∀ a, OFunctor (F a)] : OFunctor (SigmaOF F) where + ofe := inferInstance + map f g := Sigma.mapO (fun _ => map f g) + map_ne.ne _ _ _ Hx _ _ Hy := NonExpansive.ne (fun _ => map_ne.ne Hx Hy) + map_id x := by obtain ⟨a, v⟩ := x; exact congrArg (Sigma.mk a) (OFunctor.map_id v) + map_comp f g f' g' x := by + obtain ⟨a, v⟩ := x; exact congrArg (Sigma.mk a) (OFunctor.map_comp f g f' g' v) + +open OFunctorContractive in +instance instOFunctorContractiveSigmaOF [∀ a, OFunctorContractive (F a)] : + OFunctorContractive (SigmaOF F) where + map_contractive.1 H := Sigma.mapO.ne.ne (fun _ => map_contractive.1 H) + +end SigmaOF + +section ConstantFunctor + +open COFE + +/-- The constant mixed-variance space family. -/ +notation "constOF" => + (fun (B : Type _) (A : Type _) (C : Type _) [COFE A] [COFE C] => B) + +instance oFunctorConstOF [COFE B] : OFunctor (constOF B) where + ofe := _ + map _ _ := ⟨id, id_ne⟩ + map_ne := by intros; constructor; simp + map_id := by simp + map_comp := by simp + +instance OFunctor.constOFContractive [COFE B] : OFunctorContractive (constOF B) where + map_contractive.1 _ _ := .rfl + +end ConstantFunctor + +section IdentityFunctor + +open COFE + +/-- The space family selecting its covariant argument. -/ +notation "IdOF" => + (fun (A : Type _) (B : Type _) [COFE A] [COFE B] => B) + +open OFunctor in +instance : OFunctor IdOF where + ofe := inferInstance + map _ g := g + map_ne.ne _ _ _ _ _ _ Hy := Hy + map_id _ := rfl + map_comp _ _ _ _ _ := rfl + +end IdentityFunctor + +section HomOF + +open COFE + +variable [OFE A] [OFE A'] [OFE B] [OFE B'] + +/-- Precompose and postcompose a non-expansive map. -/ +def Hom.map (pre : A' -n> A) (post : B -n> B') : (A -n> B) -n> (A' -n> B') where + f h := post.comp (h.comp pre) + ne.ne _ _ _ Hh := fun x => post.ne.ne (Hh (pre x)) + +instance instNonExpansive₂HomMap : + NonExpansive₂ (Hom.map (A := A) (A' := A') (B := B) (B' := B')) where + ne {_ _ _} Hx {y₁ _} Hy f g := + (NonExpansive.ne (f := y₁) (NonExpansive.ne (f := f) (Hx g))).trans (Hy _) + +/-- The mixed-variance family of non-expansive maps between two space functors. -/ +abbrev HomOF (F1 F2 : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [OFunctor F1] [OFunctor F2] : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → + Type _) := + fun (A : Type _) (B : Type _) (_ : COFE A) (_ : COFE B) => @F1 B A _ _ -n> @F2 A B _ _ + +open OFunctor in +instance instOFunctorHomOF [OFunctor F1] [OFunctor F2] : OFunctor (HomOF F1 F2) where + ofe := inferInstance + map f g := Hom.map (map (F := F1) g f) (map (F := F2) f g) + map_ne.ne _ _ _ Hf _ _ Hg := NonExpansive₂.ne (map_ne.ne Hg Hf) (map_ne.ne Hf Hg) + map_id x := OFE.eq_dist_2 fun _ a => ((map_id _).trans (congrArg x.f (map_id a))).dist + map_comp _ _ _ _ x := OFE.eq_dist_2 fun _ _ => + ((map_comp _ _ _ _ _).trans (congrArg _ (congrArg _ (congrArg x.f (map_comp _ _ _ _ _))))).dist + +open OFunctorContractive in +instance instOFunctorContractiveHomOF [OFunctorContractive F1] [OFunctorContractive F2] : + OFunctorContractive (HomOF F1 F2) where + map_contractive.1 {n} ab ab' h := match ab, ab' with + | ⟨a, b⟩, ⟨a', b'⟩ => by + simp only [Function.uncurry_apply_pair, OFunctor.map] + have h' : DistLater n (b, a) (b', a') := + fun m hm => ⟨(h m hm).right, (h m hm).left⟩ + refine NonExpansive₂.ne ?_ ?_ + · exact (map_contractive (F := F1)).1 h' + · exact (map_contractive (F := F2)).1 h + +end HomOF + +section Fixpoint + +/-- A predicate closed under completion of Cauchy approximation chains. -/ +structure LimitPreserving [COFE α] (P : α → Prop) : Prop where + compl : ∀ (c : Chain α), (∀ n, P (c n)) → P (COFE.compl c) + +theorem LimitPreserving.const [COFE α] {P : Prop} : LimitPreserving fun (_ : α) => P where + compl _ H := H 0 + +theorem LimitPreserving.discrete [COFE α] {P : α → Prop} + (hdisc : ∀ {x y : α}, x ≡{0}≡ y → (P x → P y)) : LimitPreserving P where + compl _ H := hdisc COFE.conv_compl.symm (H _) + +theorem LimitPreserving.and [COFE α] {P Q : α → Prop} (HP : LimitPreserving P) + (HQ : LimitPreserving Q) : LimitPreserving fun a => P a ∧ Q a where + compl _ HPQ := ⟨HP.compl _ (fun n => (HPQ n).left), HQ.compl _ (fun n => (HPQ n).right)⟩ + +theorem LimitPreserving.forall [COFE α] (P : β → α → Prop) (Hlim : ∀ y, LimitPreserving (P y)) : + LimitPreserving (∀ y, P y ·) where + compl c H y := (Hlim y).compl c (H · y) + +theorem LimitPreserving.impl [COFE α] (P1 P2 : α → Prop) + (HP1 : ∀ {x y : α}, x ≡{0}≡ y → P1 x → P1 y) + (Hcompl : LimitPreserving P2) : + LimitPreserving (fun x => P1 x → P2 x) where + compl _ Hc HP1c := Hcompl.compl _ <| fun n => Hc _ (HP1 (COFE.conv_compl' (Nat.zero_le n)) HP1c) + +theorem LimitPreserving.impl' [COFE α] (P1 P2 : α → Prop) + (HP1 : ∀ {x y : α}, x ≡{0}≡ y → (P1 x ↔ P1 y)) + (Hcompl : LimitPreserving P2) : + LimitPreserving (fun x => P1 x → P2 x) := + LimitPreserving.impl P1 P2 (fun h => (HP1 h).mp) Hcompl + +theorem LimitPreserving.equiv [COFE α] [COFE β] (f g : α -n> β) : + LimitPreserving (fun x => f x = g x) where + compl := by + intro c Hfg + refine eq_dist_2 fun n => ?_ + apply (COFE.compl_map _ _).symm.dist.trans + apply (COFE.conv_compl' (Nat.le_refl n)).trans + apply (Hfg _).dist.trans + exact g.ne.ne COFE.conv_compl.symm + +theorem LimitPreserving.ext {α} [COFE α] {P Q : α -> Prop} (he : ∀ {x}, (P x ↔ Q x)) + (hp : LimitPreserving P) : LimitPreserving Q where + compl _ := (he.1 <| hp.compl _ <| fun _ => he.2 <| · _) + +/-- The Cauchy chain obtained by iterating a contractive endomorphism. -/ +def Fixpoint.chain [OFE α] [Inhabited α] (f : α → α) [Contractive f] : Chain α where + chain n := Nat.repeat f (n + 1) default + cauchy {n} := by + induction n with simp only [Nat.repeat, Nat.zero_le, Contractive.zero, imp_self, implies_true] + | succ n IH + rintro (_|i) <;> simp only [Nat.le_zero_eq, Nat.add_eq_zero_iff, Nat.succ_ne_self, and_false, + false_implies, Nat.add_le_add_iff_right] + intro H + apply Contractive.distLater_dist + intro _ Hm + exact (IH H).le (Nat.le_of_lt_succ Hm) + +/-- The chain construction of the Banach fixpoint. `fixpointP` packages it, together with +its unfolding equation, in an irreducible definition. -/ +def fixpointAux [COFE α] [Inhabited α] (f : α → α) [Contractive f] : α := + COFE.compl <| Fixpoint.chain f + +theorem fixpointAux_unfold [COFE α] [Inhabited α] (f : α -c> α) : + fixpointAux f = f (fixpointAux f) := by + refine eq_dist_2 fun n => ?_ + apply COFE.conv_compl.trans + refine .trans ?_ (NonExpansive.ne COFE.conv_compl.symm) + induction n with + | zero => exact Contractive.zero f.f + | succ _ IH => exact (Contractive.succ f.f IH.symm).symm + +/-- The Banach fixed point together with its unfolding equation. Irreducibility keeps +elaboration from unfolding the approximation chain implicitly. -/ +@[irreducible] def fixpointP [COFE α] [Inhabited α] (f : α → α) [Contractive f] : { x : α // x = f + x } := + ⟨fixpointAux f, fixpointAux_unfold f.toContractiveHom⟩ + +/-- Fixpoints inside of a COFE -/ +def fixpoint [COFE α] [Inhabited α] (f : α → α) [Contractive f] : α := + (fixpointP f).val + +/-- The fixed point of a bundled contractive endomorphism. -/ +nonrec abbrev OFE.ContractiveHom.fixpoint [COFE α] [Inhabited α] (f : α -c> α) : α := fixpoint f.f + +theorem fixpoint_unfold [COFE α] [Inhabited α] (f : α -c> α) : + fixpoint f = f (fixpoint f) := + (fixpointP f).property + +theorem fixpoint_unique [COFE α] [Inhabited α] {f : α -c> α} {x : α} (H : x = f x) : + x = fixpoint f := by + refine eq_dist_2 fun n => ?_ + induction n with refine H.dist.trans <| .trans ?_ (fixpoint_unfold f).dist.symm + | zero => exact Contractive.zero f.f + | succ _ IH => exact Contractive.succ f.f IH + +instance OFE.ContractiveHom.fixpoint_ne [COFE α] [Inhabited α] : + NonExpansive (ContractiveHom.fixpoint (α := α)) where + ne n f1 f2 H := by + induction n with + refine (fixpoint_unfold f1).dist.trans <| + ((H _).trans ?_).trans (fixpoint_unfold f2).dist.symm + | zero => exact Contractive.zero f2.f + | succ _ IH => exact Contractive.succ f2.f <| IH <| Dist.lt H (Nat.lt_add_one _) + +theorem fixpoint_dist [COFE α] [Inhabited α] {f g : α → α} [Contractive f] [Contractive g] {n} + (H : ∀ z, f z ≡{n}≡ g z) : fixpoint f ≡{n}≡ fixpoint g := + (OFE.ContractiveHom.fixpoint_ne (α := α)).ne + (x₁ := f.toContractiveHom) (x₂ := g.toContractiveHom) H + +theorem fixpoint_proper [COFE α] [Inhabited α] {f g : α → α} [Contractive f] [Contractive g] + (H : ∀ x, f x = g x) : fixpoint f = fixpoint g := + funext H ▸ rfl + +@[elab_as_elim] +theorem OFE.ContractiveHom.fixpoint_ind [COFE α] [Inhabited α] (f : α -c> α) + (P : α → Prop) (HProper : ∀ A B : α, A = B → P A → P B) (x : α) (Hbase : P x) + (Hind : ∀ x, P x → P (f x)) (Hlim : LimitPreserving P) : + P f.fixpoint := by + let chain : Chain α := by + refine ⟨fun i => Nat.repeat f (i + 1) x, fun {n i} H => ?_⟩ + induction n generalizing i with + | zero => simp [Nat.repeat] + | succ _ IH => + cases i <;> simp only [Nat.le_zero_eq, Nat.add_eq_zero_iff, Nat.succ_ne_self, and_false, + Nat.add_le_add_iff_right] at H + exact Contractive.succ _ <| IH H + refine HProper _ _ (fixpoint_unique (f := f) (x := COFE.compl chain) ?_) ?_ + · refine eq_dist_2 fun n => ?_ + apply COFE.conv_compl.trans + refine .trans ?_ (f.ne.ne COFE.conv_compl).symm + induction n + · exact Contractive.zero f.f + · rename_i IH; apply Contractive.succ _ IH + · apply Hlim.compl; intro n + induction n with + | zero => exact Hind (Nat.repeat f.f 0 x) Hbase + | succ _ IH => apply Hind (Nat.repeat f.f _ x) IH + +theorem repeat_dist [OFE α] (f g : α → α) [NonExpansive f] {n} (Hfg : ∀ z, f z ≡{n}≡ g z) : + ∀ k z, Nat.repeat f k z ≡{n}≡ Nat.repeat g k z := + Nat.repeat_rel dist_eqv (fun h => NonExpansive.ne h) Hfg + +/-- The fixed point obtained when a specified iterate is contractive. -/ +def fixpointK [COFE α] [Inhabited α] (k : Nat) (f : α → α) + [Contractive (Nat.repeat f k)] : α := fixpoint (Nat.repeat f k) + +theorem fixpointK_unfold [COFE α] [Inhabited α] (k : Nat) (f : α → α) + [Contractive (Nat.repeat f k)] : fixpointK k f = f (fixpointK k f) := by + refine (fixpoint_unique (f := (Nat.repeat f k).toContractiveHom) ?_).symm + change f (fixpointK k f) = Nat.repeat f k (f (fixpointK k f)) + refine ((Nat.repeat_apply_comm f k (fixpointK k f)).trans (congrArg f ?_)).symm + exact (fixpoint_unfold (Nat.repeat f k).toContractiveHom).symm + +theorem fixpointK_unique [COFE α] [Inhabited α] (k : Nat) (f : α → α) + [Contractive (Nat.repeat f k)] {x : α} (H : x = f x) : x = fixpointK k f := + fixpoint_unique (f := (Nat.repeat f k).toContractiveHom) (Nat.repeat_fixed f H k) + +theorem fixpointK_ne [COFE α] [Inhabited α] (k : Nat) (f g : α → α) + [Contractive (Nat.repeat f k)] [Contractive (Nat.repeat g k)] [NonExpansive f] {n} + (Hfg : ∀ z, f z ≡{n}≡ g z) : fixpointK k f ≡{n}≡ fixpointK k g := + fixpoint_dist (repeat_dist f g Hfg k) + +theorem fixpointK_proper [COFE α] [Inhabited α] (k : Nat) (f g : α → α) + [Contractive (Nat.repeat f k)] [Contractive (Nat.repeat g k)] [NonExpansive f] + (Hfg : ∀ z, f z = g z) : fixpointK k f = fixpointK k g := + eq_dist.mpr fun _ => fixpointK_ne k f g fun z => (Hfg z).dist + +@[elab_as_elim] +theorem fixpointK_ind [COFE α] [Inhabited α] (k : Nat) (f : α → α) [Contractive (Nat.repeat f k)] + (P : α → Prop) (HProper : ∀ A B : α, A = B → P A → P B) (x : α) (Hbase : P x) + (Hind : ∀ x, P x → P (f x)) (Hlim : LimitPreserving P) : P (fixpointK k f) := + OFE.ContractiveHom.fixpoint_ind (Nat.repeat f k).toContractiveHom P HProper x Hbase + (fun _ Hy => Nat.repeat_ind f Hind Hy k) Hlim + +end Fixpoint + +section FixpointAB + +open OFE + +instance [OFE α] [OFE β] [OFE γ] : CoeFun (α -c> β -n> γ) (fun _ => α → β → γ) := ⟨fun f x => (f.f + x).f⟩ +instance [OFE α] [OFE β] [OFE γ] : CoeFun (α -c> β -c> γ) (fun _ => α → β → γ) := ⟨fun f x => (f.f + x).f⟩ + +/-- A Contractive function with NonExpansive function codomain is NonExpansive₂. -/ +instance ne₂_of_contractive_ne [OFE α] [OFE β] [OFE γ] (fA : α -c> β -n> γ) : NonExpansive₂ fA where + ne n x₁ x₂ Hx y₁ y₂ Hy := by + refine .trans ?_ ((fA.f x₂).ne.ne Hy) + apply fA.ne.ne Hx + +/-- A Contractive function with Contractive function codomain is NonExpansive₂. -/ +instance ne₂_of_contractive [OFE α] [OFE β] [OFE γ] (fB : α -c> β -c> γ) : NonExpansive₂ fB where + ne n x₁ x₂ Hx y₁ y₂ Hy := by + refine .trans ?_ ((fB.f x₂).ne.ne Hy) + apply fB.ne.ne Hx + +/-- The fixed point in the second variable for a given first argument. -/ +def fixpointAB [COFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) (x : α) : β := by + let con_hom : β -c> β := { + f := fB x, + contractive := ⟨fB.f x |>.contractive.distLater_dist⟩ + } + exact con_hom.fixpoint + +theorem fixpointAB_contractive [COFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) : + Contractive (fixpointAB fB) where + distLater_dist {n _ _} Dl := by + apply ContractiveHom.fixpoint_ne.ne + apply fB.contractive.distLater_dist + exact Dl + +/-- Substitute the second-variable fixed point into the first component. -/ +def fixpointAA [COFE α] [COFE β] [Inhabited β] (fA : α -c> β -n> α) + (fB : α -c> β -c> β) (x : α) : α := + fA x (fixpointAB fB x) + +theorem fixpointAA_contractive [COFE α] [COFE β] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) : Contractive (fixpointAA fA fB) where + distLater_dist {_ _ x₂} Dl := by + refine .trans ?_ ((fA.f x₂).ne.ne ((fixpointAB_contractive fB).distLater_dist Dl)) + apply fA.contractive.distLater_dist + exact Dl + +/-- The first component of a simultaneous guarded fixed point. -/ +def fixpointA [COFE α] [COFE β] [Inhabited α] [Inhabited β] (fA : α -c> β -n> α) + (fB : α -c> β -c> β) : α := by + let con_hom : α -c> α := { + f := fixpointAA fA fB, + contractive := ⟨(fixpointAA_contractive fA fB).distLater_dist⟩ + } + exact con_hom.fixpoint + +/-- The second component of a simultaneous guarded fixed point. -/ +def fixpointB [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) : β := + fixpointAB fB <| fixpointA fA fB + +theorem fixpointA_unfold [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) : + fA (fixpointA fA fB) (fixpointB fA fB) = (fixpointA fA fB) := by + exact .symm (fixpoint_unfold _) + +theorem fixpointB_unfold [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) : + fB (fixpointA fA fB) (fixpointB fA fB) = (fixpointB fA fB) := by + exact .symm (fixpoint_unfold _) + +theorem fixpointA_unique [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) (Hp : fA p q = p) (Hq : fB p q = q) : + p = (fixpointA fA fB) := + fixpoint_unique <| Hp.symm.trans <| congrArg (fA p) (fixpoint_unique Hq.symm) + +theorem fixpointB_unique [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA : α -c> β -n> α) (fB : α -c> β -c> β) (Hp : fA p q = p) (Hq : fB p q = q) : + q = (fixpointB fA fB) := by + apply fixpoint_unique + exact Hq.symm.trans (congrArg (fun z => fB z q) (fixpointA_unique fA fB Hp Hq)) + +instance fixpointA_ne [COFE α] [COFE β] [Inhabited α] [Inhabited β] : + NonExpansive₂ (fixpointA (α := α) (β := β)) where + ne n fA fA' HfA fB fB' HfB := by + apply OFE.ContractiveHom.fixpoint_ne.ne + intro z₁ + refine ((ne₂_of_contractive_ne fA).ne .rfl ?_).trans (HfA z₁ _) + exact ContractiveHom.fixpoint_ne.ne (HfB z₁) + +instance fixpointB_ne [COFE α] [COFE β] [Inhabited α] [Inhabited β] : + NonExpansive₂ (fixpointB (α := α) (β := β)) where + ne n fA fA' HfA fB fB' HfB := by + apply ContractiveHom.fixpoint_ne.ne + intro z₁ + refine ((ne₂_of_contractive fB).ne ?_ .rfl).trans (HfB _ z₁) + exact fixpointA_ne.ne HfA HfB + +theorem fixpointA_proper [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA fA' : α -c> β -n> α) (fB fB' : α -c> β -c> β) + (HA : ∀ x y, fA x y = fA' x y) (HB : ∀ x y, fB x y = fB' x y) : + fixpointA fA fB = fixpointA fA' fB' := + eq_dist.mpr fun _ => fixpointA_ne.ne (fun x y => (HA x y).dist) (fun x y => (HB x y).dist) + +theorem fixpointB_proper [COFE α] [COFE β] [Inhabited α] [Inhabited β] + (fA fA' : α -c> β -n> α) (fB fB' : α -c> β -c> β) + (HA : ∀ x y, fA x y = fA' x y) (HB : ∀ x y, fB x y = fB' x y) : + fixpointB fA fB = fixpointB fA' fB' := + eq_dist.mpr fun _ => fixpointB_ne.ne (fun x y => (HA x y).dist) (fun x y => (HB x y).dist) + +end FixpointAB + +section Later + +/-- Delay equivalence by one step index. -/ +structure Later (A : Type u) : Type u where + next :: + /-- The underlying value of a delayed equivalence space. -/ + car : A + +instance isOFELater [OFE A] : OFE (Later A) where + Dist n x y := DistLater n x.car y.car + dist_eqv := ⟨fun _ => .rfl, .symm, .trans⟩ + eq_dist' {x y} := by + obtain ⟨a⟩ := x; obtain ⟨b⟩ := y + simp only [Later.next.injEq, eq_dist] + exact ⟨fun H n => (H n).distLater, fun H n => (H (n+1)).dist_lt (Nat.lt_succ_self n)⟩ + dist_lt Hxy Hmn _ Hkm := Hxy _ (Nat.lt_trans Hkm Hmn) + +instance NextContractive {A : Type _} [OFE A] : Contractive (@Later.next A) where + distLater_dist := id + +theorem Later.uninj {A : Type _} (x : Later A) : ∃ a, x = Later.next a := ⟨x.car, rfl⟩ + +theorem contractive_alt [OFE A] [OFE B] (f : A → B) : + Contractive f ↔ ∃ g : Later A → B, NonExpansive g ∧ ∀ x, f x = g (Later.next x) := by + refine ⟨fun hf => ⟨fun x => f x.car, ⟨fun _ _ _ h => hf.distLater_dist h⟩, fun _ => rfl⟩, ?_⟩ + rintro ⟨g, hg, hf⟩ + refine ⟨fun {n x y} h => ?_⟩ + rw [hf, hf]; exact hg.ne h + +/-- Remove the delay from a chain by advancing every index. -/ +def laterChain [OFE A] (c : Chain (Later A)) : Chain A where + chain n := (c (Nat.succ n)).car + cauchy Hle := c.cauchy (Nat.succ_le_succ Hle) _ (Nat.lt_succ_self _) + +instance isCOFELater [OFE A] [IsCOFE A] : IsCOFE (Later A) where + compl c := Later.next (IsCOFE.compl (laterChain c)) + conv_compl {n} c := by + rcases n with _|n' <;> simp only [Dist, DistLater, Nat.not_lt_zero, false_implies, implies_true] + intros m Hlt + exact (IsCOFE.conv_compl (n := n') (c := laterChain c)).le (Nat.le_of_lt_succ Hlt) + +/-- Lift a non-expansive map through the one-step delay. -/ +def laterMap [OFE A] [OFE B] (f : A -n> B) : Later A -n> Later B := by + refine ⟨fun x => Later.next (f x.car), ⟨?_⟩⟩ + rintro _ ⟨⟩ ⟨⟩ H; simp_all only [OFE.Dist, DistLater] + intros m Hlt; exact f.ne.ne (H m Hlt) + +@[simp] +theorem laterMap_next [OFE A] [OFE B] (f : A -n> B) (x : A) : + laterMap f (Later.next x) = Later.next (f x) := rfl + +theorem laterMap_id [OFE A] (x : Later A) : laterMap Hom.id x = x := rfl + +theorem laterMap_compose [OFE A] [OFE B] [OFE C] (f : A -n> B) (g : B -n> C) (x : Later A) : + laterMap (g.comp f) x = laterMap g (laterMap f x) := rfl + +theorem laterMap_ext [OFE A] [OFE B] {f g : A -n> B} (x : Later A) (h : ∀ a, f a = g a) : + laterMap f x = laterMap g x := congrArg Later.next (h x.car) + +instance laterMap_contractive [OFE A] [OFE B] : + Contractive (laterMap : (A -n> B) → Later A -n> Later B) where + distLater_dist H x m hm := H m hm x.car + +end Later + +section LaterOF +open COFE + +/-- Apply one-step delay to a mixed-variance space functor. -/ +abbrev LaterOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) : (∀ (α + : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun A B _ _ => Later (F A B) + +variable (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + +instance instOFunctorLater [OFunctor F] : OFunctor (LaterOF F) where + ofe := _ + map f g := laterMap (OFunctor.map f g) + map_ne.ne _ _ _ Hx _ _ Hy _ _ := (OFunctor.map_ne.ne Hx Hy _).lt + map_id x := congrArg Later.next (OFunctor.map_id x.car) + map_comp f g f' g' x := congrArg Later.next (OFunctor.map_comp f g f' g' x.car) + +instance instOFunctorContractiveLater [OFunctor F] : OFunctorContractive (LaterOF F) where + map_contractive.1 H _ _ hlt := + OFunctor.map_ne.ne (DistLater.dist_lt H hlt).1 (DistLater.dist_lt H hlt).2 _ + +end LaterOF + +section IsoCofe +open OFE COFE + +variable {α β : Type _} + +/-- Transport completeness through a map onto a completion-closed subtype. -/ +@[reducible] +def isoCofeSubtype [COFE α] [OFE β] (P : α → Prop) (f : ∀ x, P x → β) (g : β -n> α) + (g_dist : ∀ n (y1 y2 : β), y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) + (gf : ∀ x (Hx : P x), g (f x Hx) = x) + (Hlimit : ∀ c : Chain β, P (COFE.compl (c.map g))) : IsCOFE β where + compl c := f (COFE.compl (c.map g)) (Hlimit c) + conv_compl {n c} := by + refine (g_dist n _ _).mpr ?_ + rw [gf]; exact COFE.conv_compl + +/-- Transport completeness using a limit-preserving predicate on the source. -/ +@[reducible] +def isoCofeSubtype' [COFE α] [OFE β] (P : α → Prop) (f : ∀ x, P x → β) (g : β -n> α) + (Pg : ∀ y, P (g y)) + (g_dist : ∀ n (y1 y2 : β), y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) + (gf : ∀ x (Hx : P x), g (f x Hx) = x) (Hlimit : LimitPreserving P) : IsCOFE β := + isoCofeSubtype P f g g_dist gf fun c => Hlimit.compl (c.map g) fun n => Pg (c n) + +/-- Transport completeness along an isomorphism of ordered equivalence spaces. -/ +@[reducible] +def isoCofe [COFE α] [OFE β] (f : α → β) (g : β -n> α) + (g_dist : ∀ n (y1 y2 : β), y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) + (gf : ∀ x, g (f x) = x) : IsCOFE β := + isoCofeSubtype (fun _ => True) (fun x _ => f x) g g_dist (fun x _ => gf x) fun _ => trivial + +/-- Completeness of a subtype defined by a limit-preserving predicate. -/ +@[reducible] +def sigCofe [COFE α] {P : α → Prop} (H : LimitPreserving P) : IsCOFE (Subtype P) := + isoCofeSubtype' P (fun x h => ⟨x, h⟩) ⟨Subtype.val, inferInstance⟩ (fun y => y.property) + (fun _ _ _ => Iff.rfl) (fun _ _ => rfl) H + +instance [OFE α] [OFE β] : OFE (Iso α β) where + Dist n I1 I2 := I1.hom ≡{n}≡ I2.hom ∧ I1.inv ≡{n}≡ I2.inv + dist_eqv := ⟨fun _ => ⟨.rfl, .rfl⟩, fun ⟨h1, h2⟩ => ⟨h1.symm, h2.symm⟩, + fun ⟨a1, a2⟩ ⟨b1, b2⟩ => ⟨a1.trans b1, a2.trans b2⟩⟩ + eq_dist' {_ _} := ⟨fun h _ => h ▸ ⟨.rfl, .rfl⟩, + fun H => Iso.ext (eq_dist.mpr fun n => (H n).1) (eq_dist.mpr fun n => (H n).2)⟩ + dist_lt h hlt := ⟨h.1.lt hlt, h.2.lt hlt⟩ + +instance ofeIsoCofe [COFE α] [COFE β] : IsCOFE (Iso α β) := by + refine isoCofeSubtype' + (P := fun I : (α -n> β) × (β -n> α) => (∀ y, I.1 (I.2 y) = y) ∧ (∀ x, I.2 (I.1 x) = x)) + (fun I HI => ⟨I.1, I.2, fun {x} => HI.1 x, fun {x} => HI.2 x⟩) + ⟨fun I => (I.hom, I.inv), ⟨fun _ _ _ h => h⟩⟩ + (fun I => ⟨fun _ => I.hom_inv, fun _ => I.inv_hom⟩) + (fun _ _ _ => Iff.rfl) (fun _ _ => rfl) ?_ + refine LimitPreserving.and ?_ ?_ + · refine LimitPreserving.forall _ fun y => ?_ + refine LimitPreserving.equiv + ⟨fun I : (α -n> β) × (β -n> α) => I.1 (I.2 y), ⟨fun _ I I' h => ?_⟩⟩ (Hom.const y) + exact (h.1 _).trans (I'.1.ne.ne (h.2 y)) + · refine LimitPreserving.forall _ fun x => ?_ + refine LimitPreserving.equiv + ⟨fun I : (α -n> β) × (β -n> α) => I.2 (I.1 x), ⟨fun _ I I' h => ?_⟩⟩ (Hom.const x) + exact (h.2 _).trans (I'.2.ne.ne (h.1 x)) + +/-- Lift an isomorphism through both arguments of a mixed-variance space functor. -/ +def isoOfeCong (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [OFunctor F] {A B : Type _} [COFE A] [COFE B] (I : Iso A B) : + Iso (F A A) (F B B) where + hom := OFunctor.map I.inv I.hom + inv := OFunctor.map I.hom I.inv + hom_inv {x} := by + rw [← OFunctor.map_comp I.hom I.inv I.inv I.hom x, + show I.hom.comp I.inv = Hom.id from Hom.ext (funext fun _ => I.hom_inv), OFunctor.map_id] + inv_hom {x} := by + rw [← OFunctor.map_comp I.inv I.hom I.hom I.inv x, + show I.inv.comp I.hom = Hom.id from Hom.ext (funext fun _ => I.inv_hom), OFunctor.map_id] + +instance isoOfeCong_ne (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [OFunctor F] {A B : Type _} [COFE A] [COFE B] : + NonExpansive (isoOfeCong F (A := A) (B := B)) where + ne _ _ _ h := ⟨OFunctor.map_ne.ne h.2 h.1, OFunctor.map_ne.ne h.1 h.2⟩ + +instance isoOfeCong_contractive (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → + Type _)) [OFunctorContractive F] {A B : Type _} + [COFE A] [COFE B] : Contractive (isoOfeCong F (A := A) (B := B)) where + distLater_dist H := + ⟨fun x => OFunctorContractive.map_distLater (fun m hm => (H m hm).2) (fun m hm => (H m hm).1) x, + fun x => OFunctorContractive.map_distLater (fun m hm => (H m hm).1) (fun m hm => (H m hm).2) x⟩ + +end IsoCofe + +theorem OFE.cast_dist [Iα : OFE α] [Iβ : OFE β] {x y : α} + (Ht : α = β) (HIt : Iα = Ht ▸ Iβ) (H : x ≡{n}≡ y) : + (Ht ▸ x) ≡{n}≡ (Ht ▸ y) := by + subst Ht; subst HIt; exact H + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/UPred.lean b/LeanPool/IrisAlgebra/Algebra/UPred.lean new file mode 100644 index 0000000000..09a56567d8 --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/UPred.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2025 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Markus de Medeiros +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.CMRA +public import LeanPool.IrisAlgebra.Algebra.OFE + +/-! Monotone step-indexed predicates over ordered resources. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris +open ORA + +/- +Upstream discussion of identifying monotone predicates by equality: +https://leanprover.zulipchat.com/#narrow/channel/490604-iris-lean/topic/Bi-entailment.20and.20generalized.20rewriting/with/565019365 +-/ +/-- A resource together with its validity at one step index. -/ +@[ext] +structure ValidAt (M : Type _) [UORA M] (n : Nat) where + /-- The underlying valid resource. -/ + val : M + property : ✓{n} val + +instance {M : Type _} [UORA M] {n : Nat} : CoeOut (ValidAt M n) M where + coe := (·.val) + +/-- View a valid resource at an earlier step index. -/ +def ValidAt.le {M : Type _} [UORA M] {n m : Nat} (Hle : m ≤ n) : ValidAt M n → ValidAt M m := + fun v => ⟨v.val, validN_of_le Hle v.property⟩ + +@[simp] +theorem ValidAt.le_val {M : Type _} [UORA M] {n m : Nat} {Hle : m ≤ n} {v : ValidAt M n} : + (v.le Hle).val = v.val := by rfl + +@[simp] +theorem ValidAt.le_rfl {M : Type _} [UORA M] {n : Nat} {Hle : n ≤ n} {v : ValidAt M n} : + v.le Hle = v := by rfl + +/-- The data of a UPred object is an indexed proposition over M (Bundled version) -/ +@[ext] +structure UPred (M : Type _) [UORA M] where + /-- The proposition asserted at a step index and valid resource. -/ + holds : (n : Nat) → ValidAt M n → Prop + mono {n1 n2} {x1 : ValidAt M n1} {x2 : ValidAt M n2} : + holds n1 x1 → (x1 : M) ≼ₒ{n2} (x2 : M) → (Hle : n2 ≤ n1) → holds n2 x2 + +/-- Evaluate a predicate with validity supplied as a separate proof. -/ +def UPred.holdsUnpacked {M : Type _} [UORA M] (P : UPred M) (n : Nat) (x : M) (Hx : ✓{n} x) : + Prop := + P.holds n ⟨x, Hx⟩ + +theorem UPred.mono_unpacked {M : Type _} [UORA M] (P : UPred M) {n1 n2 : Nat} {x1 x2 : M} + (Hx1 : ✓{n1} x1) (Hx2 : ✓{n2} x2) (HP : P.holdsUnpacked n1 x1 Hx1) (Hxle : x1 ≼ₒ{n2} x2) + (Hle : n2 ≤ n1) : P.holdsUnpacked n2 x2 Hx2 := + P.mono HP Hxle Hle + +/-- The definition of UPred is equivalent to separately proving pointwise down-closure, +non-expansivity, and monotonicity. -/ +theorem uPred_alt {M : Type _} [UORA M] (P : Nat → M → Prop) : + (∀ {n1 n2} {x1 x2 : M}, P n1 x1 → x1 ≼ₒ{n1} x2 → n2 ≤ n1 → P n2 x2) ↔ + ((∀ {x : M} {n1 n2}, n2 ≤ n1 → P n1 x → P n2 x) ∧ + (∀ {n} {x1 x2 : M}, x1 ≡{n}≡ x2 → ∀ m, m ≤ n → (P m x1 ↔ P m x2)) ∧ + (∀ {n} {x1 x2 : M}, x1 ≼ₒ{n} x2 → ∀ m, m ≤ n → P m x1 → P m x2)) := by + constructor + · intro H + refine ⟨fun Hle HP => H HP .rfl Hle, ?_, ?_⟩ + · refine fun He m Hm => ⟨fun HP => ?_, fun HP => ?_⟩ + · exact H HP (ordN_of_dist_of_ordN (He.le Hm) .rfl) (Nat.le_refl _) + · exact H HP (ordN_of_dist_of_ordN (He.le Hm).symm .rfl) (Nat.le_refl _) + · exact fun Hinc m Hm HP => H HP (ordN_of_ordN_le Hm Hinc) (Nat.le_refl _) + · refine fun ⟨Hdc, _, Hmono⟩ n1 n2 x1 x2 HP Hinc Hle => ?_ + exact Hmono (ordN_of_ordN_le Hle Hinc) n2 (Nat.le_refl _) (Hdc Hle HP) + +instance [UORA M] : Inhabited (UPred M) := ⟨fun _ _ => True, fun _ _ _ => ⟨⟩⟩ + +instance [UORA M] : CoeFun (UPred M) (fun _ => (n : Nat) → ValidAt M n → Prop) where + coe x := x.holds + +section UPred + +variable [UORA M] + +open UPred + +instance : OFE (UPred M) where + Dist n P Q := ∀ n' (x : M), n' ≤ n → (p : ✓{n'} x) → (P n' ⟨x, p⟩ ↔ Q n' ⟨x, p⟩) + dist_eqv := { + refl _ _ _ _ _ := .rfl + symm H _ _ A B := (H _ _ A B).symm + trans H1 H2 _ _ A B := (H1 _ _ A B).trans (H2 _ _ A B) } + eq_dist' {P Q} := by + refine ⟨fun h _ _ _ _ _ => h ▸ Iff.rfl, fun h => ?_⟩ + ext n e + exact h n n e.val (Nat.le_refl n) e.property + dist_lt Hdist Hlt _ _ Hle Hvalid := + Hdist _ _ (Nat.le_trans Hle (Nat.le_of_succ_le Hlt)) Hvalid + +theorem uPred_ne {P : UPred M} {n} {m₁ m₂ : ValidAt M n} (H : (m₁ : M) ≡{n}≡ (m₂ : M)) : P n m₁ ↔ + P n m₂ := + ⟨fun H' => P.mono H' H.to_ordN .refl, fun H' => P.mono H' H.symm.to_ordN .refl⟩ + +theorem uPred_holds_ne {P Q : UPred M} {n₁ n₂} {x : M} + (HPQ : P ≡{n₂}≡ Q) (Hn : n₂ ≤ n₁) (Hx : ✓{n₂} x) (Hx' : ✓{n₁} x) (HQ : Q n₁ ⟨x, Hx'⟩) : P n₂ + ⟨x, Hx⟩ := + (HPQ _ _ .refl Hx).mpr (Q.mono HQ .rfl Hn) + +instance : IsCOFE (UPred M) where + compl c := { + holds n x := ∀ n', (Hle : n' ≤ n) → (c n') n' (x.le Hle) + mono {n1 n2 x1 x2 HP Hx12 Hn12 n3 Hn23} := by + refine mono _ (HP n3 (Nat.le_trans Hn23 Hn12)) ?_ .refl + exact Hx12.le Hn23 + } + conv_compl {n c i x} Hin Hv := by + refine .trans ?_ (c.cauchy Hin _ _ .refl Hv).symm + refine ⟨fun H => H _ .refl, fun H n' Hn' => ?_⟩ + exact (c.cauchy Hn' _ _ .refl _).mp (mono _ H .rfl Hn') + +/-- The contravariant predicate functor induced by a unital resource functor. -/ +abbrev UPredOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _)) + [URFunctor F] : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.COFE β] → Type _) := + fun A B _ _ => UPred (F B A) + +/-- Pull a monotone step-indexed predicate back along a resource morphism. -/ +def uPredMap [UORA α] [UORA β] (f : β -C> α) : UPred α -n> UPred β := by + refine ⟨fun P => ⟨fun n x => P n ⟨(f x.val), f.validN x.property⟩, ?_⟩, ⟨?_⟩⟩ + · intro n1 n2 x1 x2 HP Hm Hn + exact P.mono HP (f.monoN_ord Hm) Hn + · intro n x1 x2 Hx1x2 n' y Hn' Hv + exact Hx1x2 _ _ Hn' (f.validN Hv) + +instance [URFunctor F] : COFE.OFunctor (UPredOF F) where + ofe := inferInstance + map f g := uPredMap (URFunctor.map (F := F) g f) + map_ne.ne _ _ _ Hx _ _ Hy _ _ z2 Hn _ := by + simp only [uPredMap] + exact uPred_ne <| URFunctor.map_ne.ne (Hy.le Hn) (Hx.le Hn) z2 + map_id x := OFE.eq_dist_2 <| by + intro _ _ z _ _ + simp only [uPredMap] + simp only [URFunctor.map_id] + map_comp f g f' g' x := OFE.eq_dist_2 <| by + intro _ _ H _ _ + simp only [uPredMap] + simp only [URFunctor.map_comp] + +instance instUPredOFunctorContractive [URFunctorContractive F] : COFE.OFunctorContractive (UPredOF + F) where + map_contractive.1 {n x y} HKL P m a Hmn Ha := by + refine uPred_ne (P := P) <| + ((URFunctorContractive.map_contractive.1 (x := (x.snd, x.fst)) (y := (y.snd, y.fst))) ?_ + a).le Hmn + exact fun m Hm => ⟨(HKL m Hm).2, (HKL m Hm).1⟩ + +end UPred + +end Iris diff --git a/LeanPool/IrisAlgebra/Algebra/Updates.lean b/LeanPool/IrisAlgebra/Algebra/Updates.lean new file mode 100644 index 0000000000..a6745b1e7e --- /dev/null +++ b/LeanPool/IrisAlgebra/Algebra/Updates.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2025 Sukharik. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sukharik (@suhr) +-/ +module + +public import LeanPool.IrisAlgebra.Algebra.CMRA + +/-! Frame-preserving updates of ordered resources. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Iris + +/-- A frame-preserving update to some resource satisfying a predicate. -/ +def UpdateP [ORA α] (x : α) (P : α → Prop) := ∀ n mz, ✓{n} (x •? mz) → ∃ y, P y ∧ ✓{n} (y •? mz) +/-- Notation for a frame-preserving update satisfying a predicate. -/ +infixr:50 " ~~>: " => UpdateP + +/-- A frame-preserving update to a specified resource. -/ +def Update [ORA α] (x y : α) := ∀ n mz, ✓{n} (x •? mz) → ✓{n} (y •? mz) +/-- Notation for a frame-preserving update to a specified resource. -/ +infixr:50 " ~~> " => Update + +section Updates +open ORA + +variable [ORA α] [ORA β] (f : α → β) (g : β → α) + +theorem Update.of_updateP {x y : α} (h : x ~~>: (y = ·)) : x ~~> y := + fun n mz v => let ⟨_, e, v⟩ := (h n mz v); e ▸ v + +theorem UpdateP.of_update {x y : α} (h : x ~~> y) : x ~~>: (y = ·) := + fun n mz v => ⟨y, rfl, h n mz v⟩ + +theorem UpdateP.id {P : α → Prop} {x} (h : P x) : x ~~>: P := + fun _ _ v => ⟨x, h, v⟩ + +@[refl] +theorem Update.id {x : α} : x ~~> x := fun _ _ h => h + +theorem Update.trans {x y z : α} (uxy : x ~~> y) (uyz : y ~~> z) : x ~~> z := + fun n mz v => uyz n mz (uxy n mz v) + +theorem UpdateP.trans {x : α} (ux : x ~~>: P) (upq : ∀ y, P y → y ~~>: Q) : x ~~>: Q := + fun n mz v => let ⟨y, py, vy⟩ := ux n mz v; upq y py n mz vy + +theorem Update.transP {x y : α} (uxy : x ~~> y) (uyq : y ~~>: Q) : x ~~>: Q := + fun n mz v => uyq n mz (uxy n mz v) + +theorem UpdateP.weaken {x : α} (uxp : x ~~>: P) (pq : ∀ y, P y → Q y) : x ~~>: Q := + fun n mz v => let ⟨y, py, vy⟩ := uxp n mz v; ⟨y, pq y py, vy⟩ + +theorem Update.exclusive {x y : α} [Exclusive x] (vy : ✓ y) : x ~~> y := + fun _ _ P => none_of_excl_valid_op P ▸ vy.validN + +instance : Std.Refl (Update (α := α)) where + refl _ := Update.id + +instance : Trans Update Update Update (α := α) where + trans := Update.trans + +instance : Trans Update UpdateP UpdateP (α := α) where + trans := Update.transP + +theorem UpdateP.op {P Q R : α → Prop} {x y} + (uxp : x ~~>: P) (uyq : y ~~>: Q) (pqr : ∀ z w, P z → Q w → R (z • w)) : x • y ~~>: R := by + intro n mz v + have e₁ : (x • y) •? mz ≡{n}≡ y •? some (x •? mz) := + (opM_left_dist mz op_commN).trans (op_opM_assoc_dist _ _ mz) + let ⟨w, pw, vw⟩ := uyq n (some (x •? mz)) (validN_ne e₁ v) + have e₂ : w •? some (x •? mz) ≡{n}≡ x •? some (w •? mz) := calc + w •? some (x •? mz) ≡{n}≡ (w • x) •? mz := (op_opM_assoc_dist w x mz).symm + _ ≡{n}≡ (x • w) •? mz := (opM_left_dist mz op_commN) + _ ≡{n}≡ x •? some (w •? mz) := op_opM_assoc_dist x w mz + let ⟨z, pz, vz⟩ := uxp n (some (w •? mz)) (validN_ne e₂ vw) + exact ⟨z • w, pqr z w pz pw, validN_ne (op_opM_assoc_dist z w mz).symm vz⟩ + +theorem UpdateP.op' {P Q : α → Prop} {x y : α} (uxp : x ~~>: P) (uyq : y ~~>: Q) : + (x • y : α) ~~>: fun t ↦ ∃ z w, t = (z • w : α) ∧ P z ∧ Q w := + .op uxp uyq fun z w pz qw => ⟨z, w, rfl, pz, qw⟩ + +theorem Update.op {x₁ x₂ y₁ y₂ : α} (xy₁ : x₁ ~~> y₁) (xy₂ : x₂ ~~> y₂) : x₁ • x₂ ~~> y₁ • y₂ := + .of_updateP <| .op (.of_update xy₁) (.of_update xy₂) fun _ _ ez ew => ez ▸ ew ▸ rfl + +theorem Update.op_l {x y : α} : x • y ~~> x := fun _ _ => validN_op_opM_left + +theorem Update.op_r {x y : α} : x • y ~~> y := fun _ _ => validN_op_opM_right + +theorem Update.ord {x y : α} (h : x ≼ₒ y) : y ~~> x := + fun _ mz => (optionalOp_mono_left_ord mz h).validN + +theorem Update.included {x y : α} : x ≼ y → y ~~> x := + fun ⟨_, ez⟩ => ez.symm ▸ Update.op_l + +theorem Update.valid0 {x y : α} : (✓{0} x → x ~~> y) → x ~~> y := + fun h n mz v => h (valid0_of_validN (validN_opM v)) n mz v + +/-! ## Frame preserving updates for total and discete CMRAs -/ +theorem UpdateP.total [IsTotal α] : + x ~~>: P ↔ ∀ (n : Nat) (z : α), ✓{n} (x • z) → ∃ y, P y ∧ ✓{n} (y • z) where + mp uxp := fun n z v => uxp n (some z) v + mpr h := fun n mz v => + match mz with + | none => + let ⟨y, py, vy⟩ := h n (core x) (validN_ne (op_core_dist x).symm v) + ⟨y, py, validN_op_opM_left vy⟩ + | some z => h n z v + +theorem Update.total [IsTotal α] : x ~~> y ↔ ∀ (n : Nat) (z : α), ✓{n} (x • z) → ✓{n} (y • z) where + mp uxy := fun n z v => uxy n (some z) v + mpr h := fun n mz v => + match mz with + | none => + validN_op_opM_left <| h n (core x) (validN_ne (op_core_dist x).symm v) + | some z => h n z v + +theorem UpdateP.discrete [Discrete α] : + x ~~>: P ↔ ∀ (mz : Option α), ✓ (x •? mz) → ∃ y, P y ∧ ✓ (y •? mz) where + mp uxp := fun mz v => + let ⟨y, py, vy⟩ := uxp 0 mz (Valid.validN v) + ⟨y, py, discrete_valid vy⟩ + mpr h := fun n mz v => + let ⟨y, py, vy⟩ := h mz ((valid_iff_validN' n).mpr v) + ⟨y, py, Valid.validN vy⟩ + +theorem Update.discrete [Discrete α] {x y : α} : + x ~~> y ↔ ∀ (mz : Option α), ✓ (x •? mz) → ✓ (y •? mz) where + mp uxp := fun mz v => discrete_valid <| uxp 0 mz (Valid.validN v) + mpr h := fun n mz v => Valid.validN <| h mz ((valid_iff_validN' n).mpr v) + +theorem UpdateP.discrete_total [Discrete α] [IsTotal α] : + x ~~>: P ↔ ∀ (z : α), ✓ (x • z) → ∃ y, P y ∧ ✓ (y • z) where + mp uxp := fun z vz => + let ⟨y, py, vy⟩ := UpdateP.total.mp uxp 0 z (Valid.validN vz) + ⟨y, py, discrete_valid vy⟩ + mpr h := + UpdateP.total.mpr fun n z v => + let ⟨y, py, vy⟩ := h z ((valid_iff_validN' n).mpr v) + ⟨y, py, Valid.validN vy⟩ + +theorem Update.discrete_total [Discrete α] [IsTotal α] : + x ~~> y ↔ ∀ (z : α), ✓ (x • z) → ✓ (y • z) where + mp uxp := fun z vz => + discrete_valid <| Update.total.mp uxp 0 z (Valid.validN vz) + mpr h := Update.total.mpr fun n z v => (h z ((valid_iff_validN' n).mpr v)).validN + +-- (** * Transport *) +-- `cmra_transport` itself is ignored (see `CMRA.lean`): equality `A = B` between CMRAs is +-- transported by `transpAp`, so these update lemmas are subsumed by rewriting along the +-- equality and using the plain `updateP` API. + +/-! ## Isomorphism -/ +theorem UpdateP.iso + (gf : ∀ x, g (f x) = x) + (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) + (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) + (uyp : y ~~>: P) + (pq : ∀ y', P y' → Q (g y')) : + g y ~~>: Q := by + intro n mz v + have : ✓{n} y •? Option.map f mz := + match mz with + | none => (g_validN n _).mp v + | some z => + have : g y • z = g (y • f z) := by rw [g_op, gf] + (g_validN n _).mp (validN_ne this.dist v) + have ⟨x, px, vx⟩ := uyp n (mz.map f) this + have : g (x •? Option.map f mz) = g x •? mz := + match mz with + | none => rfl + | some z => by simp only [Option.map_some, optionalOp, g_op, gf] + exact ⟨g x, pq x px, validN_ne this.dist ((g_validN n _).mpr vx)⟩ + +theorem UpdateP.iso' + (gf : ∀ x, g (f x) = x) + (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) + (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) + (uyp : y ~~>: P) : + g y ~~>: fun x ↦ ∃ y, x = g y ∧ P y := + .iso f g gf g_op g_validN uyp fun z pz => ⟨z, rfl, pz⟩ + +/-! ## Lift -/ +theorem Update.lift_updateP (x y : β) + (H : ∀ P, x ~~>: P → g x ~~>: fun a' ↦ ∃ b', a' = g b' ∧ P b') + (uxy : x ~~> y) : g x ~~> g y := + .of_updateP fun n mz v => + have ⟨z, hz, vz⟩ := H _ (.of_update uxy) n mz v + have hz : z = g y := by simp only [exists_eq_right'] at hz ⊢; exact hz + ⟨z, hz.symm, vz⟩ + +/-! ## Product -/ +theorem UpdateP.prod {P : α → Prop} {Q : β → Prop} {R : α × β → Prop} {x : α × β} + (uxp : x.fst ~~>: P) (uxq : x.snd ~~>: Q) (pq : ∀ a b, P a → Q b → R (a, b)) : + x ~~>: R := by + intro n mz v + match mz with + | none => + have ⟨y₁, py, vy₁⟩ := uxp n none v.1 + have ⟨y₂, qy, vy₂⟩ := uxq n none v.2 + exact ⟨(y₁, y₂), pq y₁ y₂ py qy, ⟨vy₁, vy₂⟩⟩ + | some z => + have ⟨y₁, py, vy₁⟩ := uxp n (some z.fst) v.1 + have ⟨y₂, qy, vy₂⟩ := uxq n (some z.snd) v.2 + exact ⟨(y₁, y₂), pq y₁ y₂ py qy, ⟨vy₁, vy₂⟩⟩ + +theorem UpdateP.prod' (P : α → Prop) (Q : β → Prop) (x : α × β) + (uxp : x.fst ~~>: P) (uxq : x.snd ~~>: Q) : x ~~>: fun y ↦ P (y.fst) ∧ Q (y.snd) := + .prod uxp uxq fun _ _ px qy => ⟨px, qy⟩ + +theorem Update.prod (x : α × β) (uxy₁ : x.fst ~~> y.fst) (uxy₂ : x.snd ~~> y.snd) : x ~~> y := + .of_updateP <| .prod (.of_update uxy₁) (.of_update uxy₂) fun _ _ ya yb => Prod.ext ya yb + +/-! ## Option -/ +theorem UpdateP.option {P : α → Prop} {Q : Option α → Prop} {x : α} + (uxp : x ~~>: P) (pq : ∀ y, P y → Q (some y)) : some x ~~>: Q := by + intro n mz v + match mz with + | none | some none => let ⟨w, pw, vw⟩ := uxp n none v; exact ⟨w, pq w pw, vw⟩ + | some (some z) => let ⟨w, pw, vw⟩ := uxp n (some z) v; exact ⟨w, pq w pw, vw⟩ + +theorem UpdateP.option' (P : α → Prop) (x : α) (uxp : x ~~>: P) : some x ~~>: Option.rec False P := + .option uxp fun _ py => py + +theorem Update.option (x y : α) (uxy : x ~~> y) : some x ~~> some y := + .of_updateP <| .option (.of_update uxy) fun _ => congrArg some + +end Updates + +end Iris diff --git a/LeanPool/IrisAlgebra/Imports.lean b/LeanPool/IrisAlgebra/Imports.lean new file mode 100644 index 0000000000..dbfc69779a --- /dev/null +++ b/LeanPool/IrisAlgebra/Imports.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Lean Pool contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Lean Pool contributors +-/ +module -- shake: keep-all --deprecated_module: ignore + +-- Generated project imports; run `lake exe mk_all`. +public import LeanPool.IrisAlgebra +public import LeanPool.IrisAlgebra.Algebra.CMRA +public import LeanPool.IrisAlgebra.Algebra.CMRAConstructors +public import LeanPool.IrisAlgebra.Algebra.COFESolver +public import LeanPool.IrisAlgebra.Algebra.GenMap +public import LeanPool.IrisAlgebra.Algebra.IProp +public import LeanPool.IrisAlgebra.Algebra.Monoid +public import LeanPool.IrisAlgebra.Algebra.OFE +public import LeanPool.IrisAlgebra.Algebra.UPred +public import LeanPool.IrisAlgebra.Algebra.Updates +public import LeanPool.IrisAlgebra.Std.Nat +public import LeanPool.IrisAlgebra.Std.Option diff --git a/LeanPool/IrisAlgebra/Std/Nat.lean b/LeanPool/IrisAlgebra/Std/Nat.lean new file mode 100644 index 0000000000..5ccb315397 --- /dev/null +++ b/LeanPool/IrisAlgebra/Std/Nat.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Markus de Medeiros +-/ +module + +public import Mathlib.Init + +/-! Iteration of functions on natural numbers. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Nat + +theorem repeat_add {A : Type _} (n1 n2 : Nat) (f : A → A) (x : A) : + (n1 + n2).repeat f x = n1.repeat f (n2.repeat f x) := by + induction n1 with + | zero => simp [«repeat»] + | succ n1 IH => simp [show n1 + 1 + n2 = (n1 + n2) + 1 by omega, «repeat», ← IH] + +theorem repeat_apply_comm (f : α → α) (k : Nat) (x : α) : + Nat.repeat f k (f x) = f (Nat.repeat f k x) := by + induction k with + | zero => rfl + | succ _ IH => exact congrArg f IH + +theorem repeat_fixed (f : α → α) {x : α} (H : x = f x) : ∀ k, x = Nat.repeat f k x + | 0 => rfl + | k + 1 => H.trans (congrArg f (repeat_fixed f H k)) + +/-- If `f` respects an equivalence `R` and is `R`-related to `g` pointwise, then iterating `f` +and `g` gives `R`-related results. -/ +theorem repeat_rel {R : α → α → Prop} (hR : Equivalence R) {f g : α → α} + (hf : ∀ {x y}, R x y → R (f x) (f y)) (hfg : ∀ z, R (f z) (g z)) : + ∀ k z, R (Nat.repeat f k z) (Nat.repeat g k z) + | 0, _ => hR.refl _ + | k + 1, z => hR.trans (hf (repeat_rel hR hf hfg k z)) (hfg _) + +theorem repeat_ind (f : α → α) {P : α → Prop} (Hind : ∀ x, P x → P (f x)) {x} (Hx : P x) : + ∀ k, P (Nat.repeat f k x) + | 0 => Hx + | k + 1 => Hind _ (repeat_ind f Hind Hx k) + +end Nat diff --git a/LeanPool/IrisAlgebra/Std/Option.lean b/LeanPool/IrisAlgebra/Std/Option.lean new file mode 100644 index 0000000000..8566e0e6fd --- /dev/null +++ b/LeanPool/IrisAlgebra/Std/Option.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Markus de Medeiros. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Markus de Medeiros +-/ + +module + +public import Mathlib.Init + +/-! Relations lifted to optional values. + +Copyright (c) The Iris-Lean Contributors. +-/ + +@[expose] public section + +namespace Option + +/-- Lift a relation to optional values, relating absence only to absence. -/ +def Forall₂ (R : α → β → Prop) : Option α → Option β → Prop + | none, none => True + | some a, some b => R a b + | _, _ => False + +theorem Forall₂.getD {R : α → β → Prop} {a : α} {b : β} (hab : R a b) : + ∀ {o : Option α} {o' : Option β}, Forall₂ R o o' → R (o.getD a) (o'.getD b) + | none, none, _ => hab + | some _, some _, h => h + | none, some _, h => h.elim + | some _, none, h => h.elim + +theorem Forall₂.equivalence {R : α → α → Prop} + (H : Equivalence R) : Equivalence (Option.Forall₂ R) where + refl | none => trivial | some _ => H.1 _ + symm {x y} := by cases x <;> cases y <;> simp only [Forall₂, imp_self]; apply H.2 + trans {x y z} := by cases x <;> cases y <;> cases z <;> simp only [Forall₂, imp_self, + implies_true, imp_false, false_implies, not_true_eq_false]; apply H.3 + +end Option diff --git a/LeanPool/projects/iris-algebra.yaml b/LeanPool/projects/iris-algebra.yaml new file mode 100644 index 0000000000..0635e22aec --- /dev/null +++ b/LeanPool/projects/iris-algebra.yaml @@ -0,0 +1,78 @@ +slug: iris-algebra +title: Ordered resource algebras and the Iris recursive domain model +summary: Constructs the algebraic core of the Iris proposition model from complete step-indexed + spaces, ordered resource algebras, finite-support ghost maps, and monotone predicates. Proves + guarded fixed-point unfolding and uniqueness, solves contractive mixed-variance domain equations, + and constructs mutually inverse folding and unfolding maps for the recursive proposition model. + Includes the October 2026 ordered-resource generalization and reusable morphism, product, optional-resource, + and frame-preserving update infrastructure. The import is the mathematical dependency closure + of IProp; it does not include the proof mode, HeapLang, program logics, or claims about their + soundness. +branch: program semantics +entry_module: LeanPool.IrisAlgebra +authors: +- The Iris-Lean Contributors +contributors: +- Mario Carneiro +- Sebastian Graf +- Sergei Stepanenko +- Markus de Medeiros +- Zongyuan Liu +- Puming Liu +- Janine Lohse +- Сухарик (@suhr) +source: + title: Iris in Lean and the ordered resource algebra extension + arxiv: '2609.24252' + url: https://github.com/leanprover-community/iris-lean + github_repo: leanprover-community/iris-lean + commit: 81bc35088ba67d465db008f5261a9b341eb6cf6c + announcement: https://leanprover.zulipchat.com/#narrow/channel/579630-Project-announcements/near/626551839 + announcement_date: '2026-09-24T08:53:06Z' + material_completion: https://github.com/leanprover-community/iris-lean/commit/81bc35088ba67d465db008f5261a9b341eb6cf6c + material_completion_date: '2026-10-14T14:22:42Z' + original_copyright_notices: + - Copyright (c) The Iris-Lean Contributors + - Copyright (c) 2025 Сухарик. All rights reserved. + - Copyright (c) 2025 Mario Carneiro. All rights reserved. + - Copyright (c) 2026 Zongyuan Liu. All rights reserved. + - Copyright (c) 2025 Markus de Medeiros. All rights reserved. + - Copyright (c) 2025. All rights reserved. + - Copyright (c) 2023 Mario Carneiro. All rights reserved. + - Copyright (c) 2026 Markus de Medeiros. All rights reserved. +license: Apache-2.0 +status: verified +provenance: human +main_declarations: +- Iris.IProp.fold_unfold +- Iris.IProp.unfold_fold +main_results: +- declaration: Iris.fixpoint_unfold + informal: Every contractive endomorphism of an inhabited complete ordered family of equivalences + has a constructed fixed point satisfying its unfolding equation. +- declaration: Iris.fixpoint_unique + informal: Any fixed point of a contractive endomorphism of an inhabited complete ordered family + of equivalences equals the constructed fixed point. +- declaration: Iris.COFE.OFunctor.Fix.fold_unfold + informal: For a contractive mixed-variance functor preserving complete step-indexed spaces, + with an inhabited value at the lifted unit space, folding after unfolding is the identity + on its constructed recursive domain. +- declaration: Iris.COFE.OFunctor.Fix.unfold_fold + informal: Under the same functor, completeness, and inhabitation hypotheses, unfolding after + folding is the identity on the functor applied to the recursive domain. +- declaration: Iris.IProp.fold_unfold + informal: For every family of contractive affine resource functors, folding after unfolding + is the identity on the associated monotone proposition model. +- declaration: Iris.IProp.unfold_fold + informal: For every such family of resource functors, unfolding after folding is the identity + on the associated guarded recursive pre-proposition domain. +tags: +- program-semantics +- separation-logic +- resource-algebras +- guarded-recursion +- domain-equations +msc: +- 03B70 +- 68Q55 +- 68N30 From 17dda2e511e3c0104c3214a1d1bfe8065624aee2 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 11:04:12 +0000 Subject: [PATCH 2/7] Remove redundant Iris instances and fixed-point premises --- LeanPool/IrisAlgebra/Algebra/CMRA.lean | 60 ------------------------ LeanPool/IrisAlgebra/Algebra/GenMap.lean | 3 -- LeanPool/IrisAlgebra/Algebra/OFE.lean | 20 +++----- 3 files changed, 6 insertions(+), 77 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean index 8b1a8ec595..3d43901abb 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRA.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -1301,66 +1301,6 @@ instance ucmraMonoidOps {α : Type _} [UORA α] : Algebra.MonoidOps (op (α := end ucmra -section Leibniz - -theorem assoc_L {x y z : α} : x • (y • z) = (x • y) • z := assoc - -theorem comm_L {x y : α} : x • y = y • x := comm - -theorem pcore_op_left_L {x cx : α} (h : pcore x = some cx) : cx • x = x := - pcore_op_left h - -theorem pcore_idem_L {x cx : α} (h : pcore x = some cx) : pcore cx = some cx := - pcore_idem h - -theorem op_opM_assoc_L {x y : α} {mz} : (x • y) •? mz = x • (y •? mz) := - op_opM_assoc _ _ _ - -theorem pcore_op_right_L {x cx : α} (h : pcore x = some cx) : x • cx = x := - pcore_op_right h - -theorem pcore_op_self_L {x cx : α} (h : pcore x = some cx) : cx • cx = cx := - pcore_op_self h - -theorem core_id_dup_L {x : α} [CoreId x] : x • x = x := - op_self x - -theorem op_core_L {x : α} [IsTotal α] : x • core x = x := - op_core x - -theorem core_op_L {x : α} [IsTotal α] : core x • x = x := - core_op x - -theorem core_idem_L {x : α} [IsTotal α] : core (core x) = core x := - core_idem x - -theorem core_op_core_L {x : α} [IsTotal α] : core x • core x = core x := - core_op_core - -theorem coreId_iff_core_eq_self {x : α} [IsTotal α] : CoreId x ↔ core x = x := - coreId_iff_core_eqv_self - -theorem core_eq_self {x : α} [IsTotal α] [c : CoreId x] : core x = x := - coreId_iff_core_eq_self.mp c - -end Leibniz - -section UORA - -variable {α : Type _} [UORA α] - -theorem ucmra_unit_valid : ✓ (unit : α) := unit_valid - -theorem ucmra_unit_left_id {x : α} : unit • x = x := unit_left_id - -theorem ucmra_pcore_unit : pcore (unit : α) = some unit := pcore_unit - -theorem unit_left_id_L {x : α} : unit • x = x := unit_left_id - -theorem unit_right_id_L {x : α} : x • unit = x := unit_right_id - -end UORA - end ORA /-- A morphism between CMRAs is defined to be a non-expansive function which diff --git a/LeanPool/IrisAlgebra/Algebra/GenMap.lean b/LeanPool/IrisAlgebra/Algebra/GenMap.lean index 5b98062375..0d44023e5c 100644 --- a/LeanPool/IrisAlgebra/Algebra/GenMap.lean +++ b/LeanPool/IrisAlgebra/Algebra/GenMap.lean @@ -334,9 +334,6 @@ theorem GenMap.alter_valid {g : GenMap β} (Hb : ✓{n} b) (Hg : ✓{n} g) : · exact Hb · exact Hg k -theorem GenMap.valid_exists_fresh {g : GenMap β} (_Hv : ✓{n} g) : ∃ a : Nat, g.car a = none := - g.exists_fresh - theorem GenMap.singleton_map_op (x : Nat) (y1 y2 : β) : (singleton x y1 : GenMap β) • singleton x y2 = singleton x (y1 • y2) := by apply GenMap.ext diff --git a/LeanPool/IrisAlgebra/Algebra/OFE.lean b/LeanPool/IrisAlgebra/Algebra/OFE.lean index f7b61c0c21..941090130d 100644 --- a/LeanPool/IrisAlgebra/Algebra/OFE.lean +++ b/LeanPool/IrisAlgebra/Algebra/OFE.lean @@ -459,14 +459,6 @@ theorem fmap_some_dist [OFE β] (f : α → β) {mx : Option α} {y : β} {n} : | some x => exact ⟨x, rfl, (some_dist_some.mp h).symm⟩ · rintro ⟨x, rfl, hd⟩; exact some_dist_some.mpr hd.symm -instance [OFE α] [Discrete α] : Discrete (Option α) where - discrete_0 {x y} H := - match x, y with - | none, none => rfl - | some _, some _ => congrArg some (discrete_0 H) - | none, some _ => H.elim - | some _, none => H.elim - instance Option.some.ne [OFE α] : OFE.NonExpansive (some : α → Option α) := ⟨fun _ _ _ => id⟩ instance Option.some_is_discrete [OFE α] {e : α} [OFE.DiscreteE e] : OFE.DiscreteE (some e) where @@ -1727,7 +1719,7 @@ theorem fixpoint_proper [COFE α] [Inhabited α] {f g : α → α} [Contractive @[elab_as_elim] theorem OFE.ContractiveHom.fixpoint_ind [COFE α] [Inhabited α] (f : α -c> α) - (P : α → Prop) (HProper : ∀ A B : α, A = B → P A → P B) (x : α) (Hbase : P x) + (P : α → Prop) (x : α) (Hbase : P x) (Hind : ∀ x, P x → P (f x)) (Hlim : LimitPreserving P) : P f.fixpoint := by let chain : Chain α := by @@ -1738,7 +1730,7 @@ theorem OFE.ContractiveHom.fixpoint_ind [COFE α] [Inhabited α] (f : α -c> α) cases i <;> simp only [Nat.le_zero_eq, Nat.add_eq_zero_iff, Nat.succ_ne_self, and_false, Nat.add_le_add_iff_right] at H exact Contractive.succ _ <| IH H - refine HProper _ _ (fixpoint_unique (f := f) (x := COFE.compl chain) ?_) ?_ + refine Eq.mp (congrArg P (fixpoint_unique (f := f) (x := COFE.compl chain) ?_)) ?_ · refine eq_dist_2 fun n => ?_ apply COFE.conv_compl.trans refine .trans ?_ (f.ne.ne COFE.conv_compl).symm @@ -1775,15 +1767,15 @@ theorem fixpointK_ne [COFE α] [Inhabited α] (k : Nat) (f g : α → α) fixpoint_dist (repeat_dist f g Hfg k) theorem fixpointK_proper [COFE α] [Inhabited α] (k : Nat) (f g : α → α) - [Contractive (Nat.repeat f k)] [Contractive (Nat.repeat g k)] [NonExpansive f] + [Contractive (Nat.repeat f k)] [Contractive (Nat.repeat g k)] (Hfg : ∀ z, f z = g z) : fixpointK k f = fixpointK k g := - eq_dist.mpr fun _ => fixpointK_ne k f g fun z => (Hfg z).dist + funext Hfg ▸ rfl @[elab_as_elim] theorem fixpointK_ind [COFE α] [Inhabited α] (k : Nat) (f : α → α) [Contractive (Nat.repeat f k)] - (P : α → Prop) (HProper : ∀ A B : α, A = B → P A → P B) (x : α) (Hbase : P x) + (P : α → Prop) (x : α) (Hbase : P x) (Hind : ∀ x, P x → P (f x)) (Hlim : LimitPreserving P) : P (fixpointK k f) := - OFE.ContractiveHom.fixpoint_ind (Nat.repeat f k).toContractiveHom P HProper x Hbase + OFE.ContractiveHom.fixpoint_ind (Nat.repeat f k).toContractiveHom P x Hbase (fun _ Hy => Nat.repeat_ind f Hind Hy k) Hlim end Fixpoint From 4cc81c0e332ecb43079f9e136eb1caad4ee8658b Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 12:08:48 +0000 Subject: [PATCH 3/7] Generalize Iris parameter spaces and consolidate canonical laws --- LeanPool/IrisAlgebra/Algebra/CMRA.lean | 88 +++++++------------------- LeanPool/IrisAlgebra/Algebra/OFE.lean | 22 ++----- 2 files changed, 29 insertions(+), 81 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean index 3d43901abb..5562279617 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRA.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -205,10 +205,6 @@ export Validity (Valid ValidN validN_ne valid_iff_validN validN_succ) export IsTotal (total) /-! ## Op -/ -theorem comm' {x y : α} : x • y = y • x := comm - -theorem assoc' {x y z : α} : x • (y • z) = (x • y) • z := assoc - theorem op_right_dist (x : α) {y z : α} (e : y ≡{n}≡ z) : x • y ≡{n}≡ x • z := op_ne.ne e theorem _root_.Iris.OFE.Dist.op_r {x y z : α} : y ≡{n}≡ z → x • y ≡{n}≡ x • z := op_right_dist _ @@ -311,7 +307,7 @@ theorem op_monoN_left {n x y} (z : α) (h : x ≼{n} y) : x • z ≼{n} y • z (op_commN.incN op_commN).1 (op_monoN_right z h) theorem op_mono_left {x y} (z : α) (h : x ≼ y) : x • z ≼ y • z := by - rw [comm' (x := x) (y := z), comm' (x := y) (y := z)]; exact op_mono_right z h + rw [Op.comm (x := x) (y := z), Op.comm (x := y) (y := z)]; exact op_mono_right z h theorem op_monoN {n} {x x' y y' : α} (hx : x ≼{n} x') (hy : y ≼{n} y') : x • y ≼{n} x' • y' := @@ -413,27 +409,6 @@ class IdFree (x : α) where id_free0_r y : ✓{0} x → ¬x • y ≡{0}≡ x export IdFree (id_free0_r) -theorem pcore_l {x cx : α} (e : pcore x = some cx) : cx • x = x := pcore_op_left e - -theorem pcore_idemp {x cx : α} (e : pcore x = some cx) : pcore cx = some cx := pcore_idem e - -/-- A dependent-pair form of the resource decomposition operation. -/ -def extend' {n} {x y₁ y₂ : α} (v : ✓{n} x) (e : x ≡{n}≡ y₁ • y₂) : - Σ' z₁ z₂, x = (z₁ • z₂ : α) ∧ z₁ ≡{n}≡ y₁ ∧ z₂ ≡{n}≡ y₂ := - let ⟨z₁, z₂, hx, hz, hw⟩ := extend (y₁ := y₁) (y₂ := y₂) v e - ⟨z₁, z₂, hx, hz, hw⟩ - -theorem validN_op_l {n} {x y : α} : ✓{n} (x • y) → ✓{n} x := validN_op_left - -theorem valid_validN {x : α} : ✓ x ↔ ∀ n, ✓{n} x := valid_iff_validN - -theorem op_ne' {x : α} : NonExpansive (x • ·) := op_ne - -theorem pcore_ne' {n} {x y : α} {cx} (h : x ≡{n}≡ y) (e : pcore x = some cx) : - ∃ cy, pcore y = some cy ∧ cx ≡{n}≡ cy := pcore_ne h e - -theorem validN_ne' {n} {x y : α} (h : x ≡{n}≡ y) : ✓{n} x → ✓{n} y := validN_ne h - theorem opM_ne_right {n} {x : α} {y₁ y₂ : Option α} (h : y₁ ≡{n}≡ y₂) : x •? y₁ ≡{n}≡ x •? y₂ := match y₁, y₂, h with | none, none, _ => .rfl @@ -467,12 +442,12 @@ theorem validN_of_lt {n n'} {x : α} (lt : n' < n) : ✓{n} x → ✓{n'} x := theorem valid0_of_validN {n} {x : α} : ✓{n} x → ✓{0} x := validN_of_le (Nat.zero_le n) theorem validN_op_right {n} {x y : α} : ✓{n} (x • y) → ✓{n} y := - fun v => validN_op_left (comm' (x := x) (y := y) ▸ v) + fun v => validN_op_left (Op.comm (x := x) (y := y) ▸ v) theorem valid_op_right (x y : α) : ✓ (x • y) → ✓ y := valid_mapN fun _ => validN_op_right theorem valid_op_left {x y : α} : ✓ (x • y) → ✓ x := - fun v => valid_op_right y x (comm' (x := x) (y := y) ▸ v) + fun v => valid_op_right y x (Op.comm (x := x) (y := y) ▸ v) theorem validN_opM {x : α} {my : Option α} : ✓{n} (x •? my) → ✓{n} x := match my with | none => id | some _ => validN_op_left @@ -496,18 +471,11 @@ theorem validN_op_opM_right {mz : Option α} (h : ✓{n} (x • y : α) •? mz) instance cmra_op_ne2 : NonExpansive₂ (op (α := α)) where ne _ _ _ e₁ _ _ e₂ := e₁.op e₂ -theorem pcore_op_left' {x : α} {cx} (e : pcore x = some cx) : cx • x = x := pcore_l e - -theorem pcore_op_right {x : α} {cx} (e : pcore x = some cx) : x • cx = x := comm'.trans (pcore_l e) - -theorem pcore_op_right' {x : α} {cx} (e : pcore x = some cx) : x • cx = x := pcore_op_right e - -theorem pcore_idem' {x : α} {cx} (e : pcore x = some cx) : pcore cx = some cx := pcore_idemp e +theorem pcore_op_right {x : α} {cx} (e : pcore x = some cx) : x • cx = x := + Op.comm.trans (pcore_op_left e) theorem pcore_op_self {x : α} {cx} (e : pcore x = some cx) : cx • cx = cx := - pcore_op_right' (pcore_idem e) - -theorem pcore_op_self' {x : α} {cx} (e : pcore x = some cx) : cx • cx = cx := pcore_op_self e + pcore_op_right (pcore_idem e) theorem pcore_validN {n} {x : α} {cx} (e : pcore x = some cx) (v : ✓{n} x) : ✓{n} cx := validN_op_right ((pcore_op_right e).symm ▸ v) @@ -515,7 +483,7 @@ theorem pcore_validN {n} {x : α} {cx} (e : pcore x = some cx) (v : ✓{n} x) : theorem pcore_valid {x : α} {cx} (e : pcore x = some cx) : ✓ x → ✓ cx := valid_mapN fun _ => pcore_validN e -theorem op_self (x : α) [CoreId x] : x • x = x := pcore_op_self' CoreId.core_id +theorem op_self (x : α) [CoreId x] : x • x = x := pcore_op_self CoreId.core_id theorem CoreId.of_pcore_eq_some {x y : α} (e : pcore x = some y) : CoreId y where core_id := pcore_idem e @@ -525,13 +493,13 @@ theorem not_valid_exclN_op_left {n} {x : α} [Exclusive x] {y} : ¬✓{n} (x • n.recOn (Exclusive.exclusive0_l _) fun _ ih => ih ∘ validN_succ theorem not_valid_exclN_op_right {n} {x : α} [Exclusive x] {y} : ¬✓{n} (y • x) := - fun v => not_valid_exclN_op_left (comm' (x := y) (y := x) ▸ v) + fun v => not_valid_exclN_op_left (Op.comm (x := y) (y := x) ▸ v) theorem not_valid_excl_op_left {x : α} [Exclusive x] {y} : ¬✓ (x • y) := fun v => Exclusive.exclusive0_l _ v.validN theorem not_excl_op_right {x : α} [Exclusive x] {y} : ¬✓ (y • x) := - fun v => not_valid_excl_op_left (comm' (x := y) (y := x) ▸ v) + fun v => not_valid_excl_op_left (Op.comm (x := y) (y := x) ▸ v) theorem none_of_excl_valid_op {n} {x : α} [Exclusive x] {my} : ✓{n} (x •? my) → my = none := by cases my <;> simp [optionalOp, not_valid_exclN_op_left] @@ -543,7 +511,7 @@ variable [IsTotal α] theorem op_core (x : α) : x • core x = x := pcore_op_right (pcore_eq_core x) -theorem core_op (x : α) : core x • x = x := comm'.trans (op_core x) +theorem core_op (x : α) : core x • x = x := Op.comm.trans (op_core x) theorem op_core_dist (x : α) : x • core x ≡{n}≡ x := Dist.of_eq (op_core x) theorem core_op_dist (x : α) : core x • x ≡{n}≡ x := Dist.of_eq (core_op x) @@ -611,10 +579,10 @@ theorem validN_of_inc {n} {x y : α} : x ≼ y → ✓{n} y → ✓{n} x theorem pcore_inc_self {x : α} {cx} (e : pcore x = some cx) : cx ≼ x := ⟨x, (pcore_op_left e).symm⟩ theorem op_core_right_of_inc {x y : α} [CoreId x] : x ≼ y → x • y = y - | ⟨z, hz⟩ => hz ▸ assoc'.trans (congrArg (· • z) (op_self x)) + | ⟨z, hz⟩ => hz ▸ Op.assoc.trans (congrArg (· • z) (op_self x)) theorem op_core_left_of_inc {x y : α} [CoreId x] (le : x ≼ y) : y • x = y := - comm'.trans (op_core_right_of_inc le) + Op.comm.trans (op_core_right_of_inc le) theorem included_dist_l {n} {x1 x2 x1' : α} : x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2 @@ -725,10 +693,6 @@ theorem pcore_mono {x y cx : α} : let ⟨t, ht, et⟩ := OFE.equiv_some ((congrArg pcore hw).trans hz) ⟨t, ht, z, et⟩ -theorem pcore_mono' {x y : α} {cx} (le : x ≼ y) (e : pcore x = some cx) : - ∃ cy, pcore y = some cy ∧ cx ≼ cy := - pcore_mono le e - theorem pcore_monoN' {n} {x y : α} {cx} : x ≼{n} y → pcore x ≡{n}≡ some cx → ∃ cy, pcore y = some cy ∧ cx ≼{n} cy | ⟨z, hz⟩, e => @@ -976,10 +940,6 @@ theorem validN_of_ord {n} {x y : α} (h : x ≼ₒ y) : ✓{n} y → ✓{n} x := validN_of_ordN (ordN_of_ord n h) theorem _root_.Iris.Ordered.Order.validN {n} {x y : α} : x ≼ₒ y → ✓{n} y → ✓{n} x := validN_of_ord -theorem pcore_mono_ord' {x y : α} {cx} (le : x ≼ₒ y) (e : pcore x = some cx) : - ∃ cy, pcore y = some cy ∧ cx ≼ₒ cy := - pcore_mono_ord le e - theorem pcore_monoN_ord' {n} {x y : α} {cx} (h : x ≼ₒ{n} y) (e : pcore x ≡{n}≡ some cx) : ∃ cy, pcore y = some cy ∧ cx ≼ₒ{n} cy := let ⟨_, hw, ew⟩ := OFE.dist_some e @@ -992,16 +952,12 @@ theorem pcore_mono [OrdInc α] {x y cx : α} : let ⟨cy, hcy, o⟩ := pcore_order_op e z ⟨cy, hz ▸ hcy, OrdInc.ord_inc o⟩ -theorem pcore_mono' [OrdInc α] {x y : α} {cx} (le : x ≼ y) (e : pcore x = some cx) : - ∃ cy, pcore y = some cy ∧ cx ≼ cy := - pcore_mono le e - theorem pcore_monoN' [OrdInc α] {n} {x y : α} {cx} : x ≼{n} y → pcore x ≡{n}≡ some cx → ∃ cy, pcore y = some cy ∧ cx ≼{n} cy | ⟨z, hz⟩, e => let ⟨_, hw, ew⟩ := OFE.dist_some e let ⟨_, ht, o⟩ := pcore_order_op hw z - let ⟨r, hr, er⟩ := pcore_ne' hz.symm ht + let ⟨r, hr, er⟩ := pcore_ne hz.symm ht ⟨r, hr, incN_ne ew.symm er (incN_of_inc n (OrdInc.ord_inc o))⟩ theorem pcore_op_mono [OrdInc α] {x cx : α} (e : pcore x = some cx) (y : α) : @@ -1014,7 +970,7 @@ theorem op_monoN_right_ord {n x y} (z : α) (h : x ≼ₒ{n} y) : z • x ≼ₒ (op_commN.ordN op_commN).1 (op_monoN_left_ord z h) theorem op_mono_right_ord {x y} (z : α) (h : x ≼ₒ y) : z • x ≼ₒ z • y := by - rw [comm' (x := z) (y := x), comm' (x := z) (y := y)]; exact op_mono_left_ord z h + rw [Op.comm (x := z) (y := x), Op.comm (x := z) (y := y)]; exact op_mono_left_ord z h theorem op_monoN_ord {n} {x x' y y' : α} (hx : x ≼ₒ{n} x') (hy : y ≼ₒ{n} y') : x • y ≼ₒ{n} x' • y' := @@ -1086,7 +1042,7 @@ instance op (x y : α) [Increasing x] [Increasing y] : Increasing (x • y) wher increasing z := calc z ≼ₒ y • z := Increasing.increasing z _ ≼ₒ x • (y • z) := Increasing.increasing _ - _ = (x • y) • z := assoc' + _ = (x • y) • z := Op.assoc end Increasing @@ -1132,7 +1088,7 @@ section increasing theorem ord_op_right (x y : α) [Increasing x] : y ≼ₒ x • y := Increasing.increasing y theorem ord_op_left (x y : α) [Increasing y] : x ≼ₒ x • y := - comm' (x := y) (y := x) ▸ ord_op_right y x + Op.comm (x := y) (y := x) ▸ ord_op_right y x theorem ordN_op_left (n) (x y : α) [Increasing y] : x ≼ₒ{n} x • y := (ord_op_left x y).ordN theorem ordN_op_right (n) (x y : α) [Increasing x] : y ≼ₒ{n} x • y := (ord_op_right x y).ordN @@ -1204,13 +1160,13 @@ theorem id_freeN_r {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(x • y id_free0_r _ (validN_of_le (Nat.zero_le _) v) |>.imp (·.le (Nat.zero_le _)) theorem id_freeN_l {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(y • x ≡{n'}≡ x) := - id_freeN_r v ∘ comm'.dist.trans + id_freeN_r v ∘ Op.comm.dist.trans theorem id_free_r {x : α} [IdFree x] {y} (v : ✓ x) : ¬(x • y = x) := fun h => id_free0_r y (valid_iff_validN.mp v 0) h.dist theorem id_free_l {x : α} [IdFree x] {y} (v : ✓ x) : ¬(y • x = x) := - id_free_r v ∘ comm'.trans + id_free_r v ∘ Op.comm.trans theorem discrete_id_free {x : α} [Discrete α] (H : ∀ y, ✓ x → ¬(x • y = x)) : IdFree x where id_free0_r y v h := H y (Discrete.discrete_valid v) (Discrete.discrete_0 h) @@ -1220,7 +1176,7 @@ instance idFree_op_r {x y : α} [IdFree y] [Cancelable x] : IdFree (x • y) whe id_free0_r z (validN_op_right v) (cancelableN v (op_assocN.trans h).symm).symm instance idFree_op_l {x y : α} [IdFree x] [Cancelable y] : IdFree (x • y) := by - rw [comm']; exact inferInstance + rw [Op.comm]; exact inferInstance instance exclusive_idFree {x : α} [Exclusive x] : IdFree x where id_free0_r z v h := exclusive0_l z ((validN_dist_iff h.symm).mp v) @@ -1235,9 +1191,9 @@ theorem unit_validN {n} : ✓{n} (unit : α) := valid_iff_validN.mp (unit_valid) theorem unit_left_id_dist {n} (x : α) : unit • x ≡{n}≡ x := unit_left_id.dist -theorem unit_right_id {x : α} : x • unit = x := comm'.trans unit_left_id +theorem unit_right_id {x : α} : x • unit = x := Op.comm.trans unit_left_id -theorem unit_right_id_dist (x : α) : x • unit ≡{n}≡ x := comm'.dist.trans (unit_left_id_dist x) +theorem unit_right_id_dist (x : α) : x • unit ≡{n}≡ x := Op.comm.dist.trans (unit_left_id_dist x) theorem incN_unit {n} {x : α} : unit ≼{n} x := ⟨x, unit_left_id.symm.dist⟩ @@ -2153,7 +2109,7 @@ theorem eq_none_of_op_eq_none_right {x y : Option α} (h : x • y = none) : y = | some _, some _ => simp [op] at h theorem op_some_opM_assoc {x y : α} {mz : Option α} : (x • y) •? mz = x •? (some y • mz) := - match mz with | none => rfl | some _ => assoc'.symm + match mz with | none => rfl | some _ => Op.assoc.symm theorem some_op_opM {a : α} {ma : Option α} : some a • ma = some (a •? ma) := by rcases ma with ⟨_|_⟩ <;> simp [optionalOp, op] diff --git a/LeanPool/IrisAlgebra/Algebra/OFE.lean b/LeanPool/IrisAlgebra/Algebra/OFE.lean index 941090130d..bffd891ee6 100644 --- a/LeanPool/IrisAlgebra/Algebra/OFE.lean +++ b/LeanPool/IrisAlgebra/Algebra/OFE.lean @@ -154,9 +154,6 @@ theorem Contractive.succ [OFE α] [OFE β] (f : α → β) [Contractive f] {n x instance ne_of_contractive [OFE α] [OFE β] (f : α → β) [Contractive f] : NonExpansive f where ne := fun _ _ _ h => Contractive.distLater_dist (Dist.distLater h) -theorem Contractive.dist_later_dist [OFE α] [OFE β] (f : α → β) [Contractive f] {n x y} - (h : DistLater n x y) : f x ≡{n}≡ f y := Contractive.distLater_dist h - /-- Pre-composing a non-expansive function preserves `DistLater`. -/ theorem ne_dist_later [OFE α] [OFE β] (f : α → β) [NonExpansive f] {n x y} (h : DistLater n x y) : DistLater n (f x) (f y) := fun m hm => NonExpansive.ne (h m hm) @@ -822,9 +819,6 @@ theorem Sigma.equiv_eq {P : α → Type _} [∀ x, OFE (P x)] {x1 x2 : Sigma P} theorem Sigma.dist_eq {P : α → Type _} [∀ x, OFE (P x)] {n} {x1 x2 : Sigma P} : (x1 ≡{n}≡ x2) ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd ≡{n}≡ x2.snd := Iff.rfl -theorem Sigma.dist_proj1 {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P} - (h : x ≡{n}≡ y) : x.fst = y.fst := h.1 - theorem Sigma.equiv_proj1 {P : α → Type _} {x y : Sigma P} (h : x = y) : x.fst = y.fst := congrArg Sigma.fst h @@ -1634,15 +1628,13 @@ theorem LimitPreserving.impl' [COFE α] (P1 P2 : α → Prop) LimitPreserving (fun x => P1 x → P2 x) := LimitPreserving.impl P1 P2 (fun h => (HP1 h).mp) Hcompl -theorem LimitPreserving.equiv [COFE α] [COFE β] (f g : α -n> β) : +theorem LimitPreserving.equiv [COFE α] [OFE β] (f g : α -n> β) : LimitPreserving (fun x => f x = g x) where compl := by intro c Hfg refine eq_dist_2 fun n => ?_ - apply (COFE.compl_map _ _).symm.dist.trans - apply (COFE.conv_compl' (Nat.le_refl n)).trans - apply (Hfg _).dist.trans - exact g.ne.ne COFE.conv_compl.symm + exact (f.ne.ne (COFE.conv_compl (c := c))).trans + ((Hfg n).dist.trans (g.ne.ne COFE.conv_compl.symm)) theorem LimitPreserving.ext {α} [COFE α] {P Q : α -> Prop} (he : ∀ {x}, (P x ↔ Q x)) (hp : LimitPreserving P) : LimitPreserving Q where @@ -1802,14 +1794,14 @@ instance ne₂_of_contractive [OFE α] [OFE β] [OFE γ] (fB : α -c> β -c> γ) apply fB.ne.ne Hx /-- The fixed point in the second variable for a given first argument. -/ -def fixpointAB [COFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) (x : α) : β := by +def fixpointAB [OFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) (x : α) : β := by let con_hom : β -c> β := { f := fB x, contractive := ⟨fB.f x |>.contractive.distLater_dist⟩ } exact con_hom.fixpoint -theorem fixpointAB_contractive [COFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) : +theorem fixpointAB_contractive [OFE α] [COFE β] [Inhabited β] (fB : α -c> β -c> β) : Contractive (fixpointAB fB) where distLater_dist {n _ _} Dl := by apply ContractiveHom.fixpoint_ne.ne @@ -1817,11 +1809,11 @@ theorem fixpointAB_contractive [COFE α] [COFE β] [Inhabited β] (fB : α -c> exact Dl /-- Substitute the second-variable fixed point into the first component. -/ -def fixpointAA [COFE α] [COFE β] [Inhabited β] (fA : α -c> β -n> α) +def fixpointAA [OFE α] [COFE β] [Inhabited β] (fA : α -c> β -n> α) (fB : α -c> β -c> β) (x : α) : α := fA x (fixpointAB fB x) -theorem fixpointAA_contractive [COFE α] [COFE β] [Inhabited β] +theorem fixpointAA_contractive [OFE α] [COFE β] [Inhabited β] (fA : α -c> β -n> α) (fB : α -c> β -c> β) : Contractive (fixpointAA fA fB) where distLater_dist {_ _ x₂} Dl := by refine .trans ?_ ((fA.f x₂).ne.ne ((fixpointAB_contractive fB).distLater_dist Dl)) From 21f9f0ef27be458219a86f3e2b7470f2dc915b44 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 14:13:31 +0000 Subject: [PATCH 4/7] Generalize Iris primitive laws and preserve upstream notices --- LeanPool/IrisAlgebra/Algebra/CMRA.lean | 73 +++++++++---------- .../IrisAlgebra/Algebra/CMRAConstructors.lean | 2 + LeanPool/IrisAlgebra/Algebra/COFESolver.lean | 2 + LeanPool/IrisAlgebra/Algebra/GenMap.lean | 4 +- LeanPool/IrisAlgebra/Algebra/IProp.lean | 2 + LeanPool/IrisAlgebra/Algebra/Monoid.lean | 2 + LeanPool/IrisAlgebra/Algebra/OFE.lean | 9 +-- LeanPool/IrisAlgebra/Algebra/UPred.lean | 2 + LeanPool/IrisAlgebra/Algebra/Updates.lean | 16 ++-- LeanPool/IrisAlgebra/Std/Nat.lean | 2 + LeanPool/IrisAlgebra/Std/Option.lean | 2 + LeanPool/projects/iris-algebra.yaml | 3 + 12 files changed, 69 insertions(+), 50 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean index 5562279617..a88fe952b3 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRA.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -5,6 +5,8 @@ Authors: Mario Carneiro, Sukharik (@suhr), Markus de Medeiros, Puming Liu, Janin -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.OFE public import LeanPool.IrisAlgebra.Algebra.Monoid @@ -75,6 +77,9 @@ namespace Validity @[inherit_doc] prefix:50 "✓ " => Validity.Valid @[inherit_doc] notation:50 "✓{" n "} " x:51 => Validity.ValidN n x +theorem Valid.validN [OFE α] [Validity α] : ✓ (x : α) → ✓{n} x := + (valid_iff_validN.1 · _) + end Validity /-- The ordering predicate on a resource algebra. -/ @@ -197,13 +202,35 @@ end /-! ## Order-free theory -/ namespace ORA -variable [OFE α] [Op α] +variable [OFE α] export Op (op optionalOp op_ne assoc comm) export PCore (pcore pcore_ne pcore_idem core) export Validity (Valid ValidN validN_ne valid_iff_validN validN_succ) export IsTotal (total) +section Validity +variable [Validity α] + +theorem valid_mapN {x y : α} (f : ∀ n, ✓{n} x → ✓{n} y) (v : ✓ x) : ✓ y := + valid_iff_validN.mpr fun n => f n v.validN + +theorem validN_dist_iff {x y : α} (e : x ≡{n}≡ y) : ✓{n} x ↔ ✓{n} y := + ⟨validN_ne e, validN_ne e.symm⟩ +theorem _root_.Iris.OFE.Dist.validN : (x : α) ≡{n}≡ y → (✓{n} x ↔ ✓{n} y) := validN_dist_iff + +theorem validN_of_le {n n'} {x : α} (le : n' ≤ n) : ✓{n} x → ✓{n'} x := + le.recOn id fun _ ih vs => ih (validN_succ vs) + +theorem validN_of_lt {n n'} {x : α} (lt : n' < n) : ✓{n} x → ✓{n'} x := + validN_of_le (Nat.le_of_lt lt) + +theorem valid0_of_validN {n} {x : α} : ✓{n} x → ✓{0} x := validN_of_le (Nat.zero_le n) + +end Validity + +variable [Op α] + /-! ## Op -/ theorem op_right_dist (x : α) {y z : α} (e : y ≡{n}≡ z) : x • y ≡{n}≡ x • z := op_ne.ne e @@ -231,6 +258,12 @@ theorem opM_left_dist {n} {x y : α} (z : Option α) (e : x ≡{n}≡ y) : x • theorem opM_right_dist {n} (x : α) {y z : Option α} (e : y ≡{n}≡ z) : x •? y ≡{n}≡ x •? z := Dist.rfl.opM e +instance cmra_op_ne2 : NonExpansive₂ (op (α := α)) where + ne _ _ _ e₁ _ _ e₂ := e₁.op e₂ + +instance : NonExpansive₂ (optionalOp (α := α)) where + ne _ _ _ e₁ _ _ e₂ := e₁.opM e₂ + theorem op_opM_assoc (x y : α) (mz : Option α) : (x • y) •? mz = x • (y •? mz) := by unfold optionalOp; cases mz <;> simp [assoc] @@ -409,38 +442,8 @@ class IdFree (x : α) where id_free0_r y : ✓{0} x → ¬x • y ≡{0}≡ x export IdFree (id_free0_r) -theorem opM_ne_right {n} {x : α} {y₁ y₂ : Option α} (h : y₁ ≡{n}≡ y₂) : x •? y₁ ≡{n}≡ x •? y₂ := - match y₁, y₂, h with - | none, none, _ => .rfl - | some _, some _, h => op_ne.ne h - -instance : NonExpansive₂ (optionalOp (α := α)) where - ne _ x₁ _ e₁ y₁ y₂ e₂ := match y₁, y₂, e₂ with - | none, none, _ => e₁ - | some _, some y₂, e₂ => - ((op_ne (x := x₁)).ne e₂).trans (Dist.of_eq comm |>.trans <| - ((op_ne (x := y₂)).ne e₁).trans (Dist.of_eq comm)) - /-! ## Validity -/ -theorem _root_.Iris.Validity.Valid.validN : ✓ (x : α) → ✓{n} x := (valid_iff_validN.1 · _) -protected theorem Valid.validN : ✓ (x : α) → ✓{n} x := Iris.Validity.Valid.validN - -theorem valid_mapN {x y : α} (f : ∀ n, ✓{n} x → ✓{n} y) (v : ✓ x) : ✓ y := - valid_iff_validN.mpr fun n => f n v.validN - -theorem validN_dist_iff {x y : α} (e : x ≡{n}≡ y) : ✓{n} x ↔ ✓{n} y := - ⟨validN_ne e, validN_ne e.symm⟩ -theorem _root_.Iris.OFE.Dist.validN : (x : α) ≡{n}≡ y → (✓{n} x ↔ ✓{n} y) := validN_dist_iff - -theorem validN_of_le {n n'} {x : α} (le : n' ≤ n) : ✓{n} x → ✓{n'} x := - le.recOn id fun _ ih vs => ih (validN_succ vs) - -theorem validN_of_lt {n n'} {x : α} (lt : n' < n) : ✓{n} x → ✓{n'} x := - validN_of_le (Nat.le_of_lt lt) - -theorem valid0_of_validN {n} {x : α} : ✓{n} x → ✓{0} x := validN_of_le (Nat.zero_le n) - theorem validN_op_right {n} {x y : α} : ✓{n} (x • y) → ✓{n} y := fun v => validN_op_left (Op.comm (x := x) (y := y) ▸ v) @@ -468,9 +471,6 @@ theorem validN_op_opM_right {mz : Option α} (h : ✓{n} (x • y : α) •? mz) validN_op_opM_left (validN_ne (opM_left_dist mz op_commN) h) /-! ## Core -/ -instance cmra_op_ne2 : NonExpansive₂ (op (α := α)) where - ne _ _ _ e₁ _ _ e₂ := e₁.op e₂ - theorem pcore_op_right {x : α} {cx} (e : pcore x = some cx) : x • cx = x := Op.comm.trans (pcore_op_left e) @@ -911,7 +911,6 @@ theorem ord0_of_ordN {n} {x y : α} : x ≼ₒ{n} y → x ≼ₒ{0} y := ordN_of theorem _root_.Iris.Ordered.OrderN.le {n n'} {x y : α} : n' ≤ n → x ≼ₒ{n} y → x ≼ₒ{n'} y := ordN_of_ordN_le -theorem ordN_of_ordN_succ {n} {x y : α} : x ≼ₒ{n.succ} y → x ≼ₒ{n} y := ordN_succ theorem _root_.Iris.Ordered.OrderN.succ {n} {x y : α} : x ≼ₒ{n.succ} y → x ≼ₒ{n} y := ordN_succ section ordRefl @@ -1103,10 +1102,10 @@ end increasing section discreteORA theorem valid_iff_validN' [Discrete α] (n) {x : α} : ✓ x ↔ ✓{n} x := - ⟨Valid.validN, fun v => discrete_valid <| validN_of_le (Nat.zero_le n) v⟩ + ⟨Validity.Valid.validN, fun v => discrete_valid <| validN_of_le (Nat.zero_le n) v⟩ theorem valid_0_iff_validN [Discrete α] (n) {x : α} : ✓{0} x ↔ ✓{n} x := - ⟨Valid.validN ∘ discrete_valid, validN_of_le (Nat.zero_le n)⟩ + ⟨Validity.Valid.validN ∘ discrete_valid, validN_of_le (Nat.zero_le n)⟩ theorem ord_iff_ordN [Discrete α] (n) {x y : α} : x ≼ₒ y ↔ x ≼ₒ{n} y := ⟨ordN_of_ord _, fun h => discrete_ord (ord0_of_ordN h)⟩ diff --git a/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean b/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean index 935aa8514f..d4ae1e1822 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRAConstructors.lean @@ -5,6 +5,8 @@ Authors: Mario Carneiro, Sukharik (@suhr), Markus de Medeiros, Puming Liu, Janin -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.CMRA /-! Resource algebra construction from embeddings and discrete data. -/ diff --git a/LeanPool/IrisAlgebra/Algebra/COFESolver.lean b/LeanPool/IrisAlgebra/Algebra/COFESolver.lean index 3854c11f75..0d23f43665 100644 --- a/LeanPool/IrisAlgebra/Algebra/COFESolver.lean +++ b/LeanPool/IrisAlgebra/Algebra/COFESolver.lean @@ -5,6 +5,8 @@ Authors: Mario Carneiro, Sebastian Graf -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.OFE /-! A guarded recursive domain equation solver. diff --git a/LeanPool/IrisAlgebra/Algebra/GenMap.lean b/LeanPool/IrisAlgebra/Algebra/GenMap.lean index 0d44023e5c..0c8c802aed 100644 --- a/LeanPool/IrisAlgebra/Algebra/GenMap.lean +++ b/LeanPool/IrisAlgebra/Algebra/GenMap.lean @@ -5,6 +5,8 @@ Authors: Markus de Medeiros, Janine Lohse -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.OFE public import LeanPool.IrisAlgebra.Algebra.CMRA public import LeanPool.IrisAlgebra.Algebra.Updates @@ -222,7 +224,7 @@ def pcoreGenMap (x : GenMap β) : Option (GenMap β) := some ⟨fun k => core (x @[reducible] def GenMap.raValid : _root_.Iris.Validity (GenMap β) where ValidN n x := ✓{n} x.car Valid x := ✓ x.car - validN_ne {_n _x _y H} := Dist.validN H |>.mp + validN_ne {_n _x _y H} := fun v k => (Dist.validN (H k)).mp (v k) valid_iff_validN {_x} := ⟨fun Hv _ => Hv.validN, fun H => valid_iff_validN.mpr (H ·)⟩ validN_succ {_x _n} := validN_succ diff --git a/LeanPool/IrisAlgebra/Algebra/IProp.lean b/LeanPool/IrisAlgebra/Algebra/IProp.lean index b4c467134a..c4453eb77a 100644 --- a/LeanPool/IrisAlgebra/Algebra/IProp.lean +++ b/LeanPool/IrisAlgebra/Algebra/IProp.lean @@ -5,6 +5,8 @@ Authors: Markus de Medeiros, Janine Lohse -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.CMRA public import LeanPool.IrisAlgebra.Algebra.OFE public import LeanPool.IrisAlgebra.Algebra.UPred diff --git a/LeanPool/IrisAlgebra/Algebra/Monoid.lean b/LeanPool/IrisAlgebra/Algebra/Monoid.lean index 1ca894c8a7..ae323410c2 100644 --- a/LeanPool/IrisAlgebra/Algebra/Monoid.lean +++ b/LeanPool/IrisAlgebra/Algebra/Monoid.lean @@ -5,6 +5,8 @@ Authors: Zongyuan Liu -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.OFE /-! Non-expansive commutative monoids and their morphisms. -/ diff --git a/LeanPool/IrisAlgebra/Algebra/OFE.lean b/LeanPool/IrisAlgebra/Algebra/OFE.lean index bffd891ee6..801394602e 100644 --- a/LeanPool/IrisAlgebra/Algebra/OFE.lean +++ b/LeanPool/IrisAlgebra/Algebra/OFE.lean @@ -5,6 +5,8 @@ Authors: Mario Carneiro, Sebastian Graf, Sergei Stepanenko, Markus de Medeiros -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Std.Nat public import LeanPool.IrisAlgebra.Std.Option @@ -813,9 +815,6 @@ theorem Sigma.equiv_eq_alt {P : α → Type _} {x1 x2 : Sigma P} : obtain ⟨x1f, x1s⟩ := x1; obtain ⟨x2f, x2s⟩ := x2 simp only at heq; subst heq; simp only at h; subst h; rfl -theorem Sigma.equiv_eq {P : α → Type _} [∀ x, OFE (P x)] {x1 x2 : Sigma P} : - x1 = x2 ↔ ∀ n, x1 ≡{n}≡ x2 := eq_dist - theorem Sigma.dist_eq {P : α → Type _} [∀ x, OFE (P x)] {n} {x1 x2 : Sigma P} : (x1 ≡{n}≡ x2) ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd ≡{n}≡ x2.snd := Iff.rfl @@ -1520,14 +1519,14 @@ open COFE notation "constOF" => (fun (B : Type _) (A : Type _) (C : Type _) [COFE A] [COFE C] => B) -instance oFunctorConstOF [COFE B] : OFunctor (constOF B) where +instance oFunctorConstOF [OFE B] : OFunctor (constOF B) where ofe := _ map _ _ := ⟨id, id_ne⟩ map_ne := by intros; constructor; simp map_id := by simp map_comp := by simp -instance OFunctor.constOFContractive [COFE B] : OFunctorContractive (constOF B) where +instance OFunctor.constOFContractive [OFE B] : OFunctorContractive (constOF B) where map_contractive.1 _ _ := .rfl end ConstantFunctor diff --git a/LeanPool/IrisAlgebra/Algebra/UPred.lean b/LeanPool/IrisAlgebra/Algebra/UPred.lean index 09a56567d8..1e8ebe08ab 100644 --- a/LeanPool/IrisAlgebra/Algebra/UPred.lean +++ b/LeanPool/IrisAlgebra/Algebra/UPred.lean @@ -5,6 +5,8 @@ Authors: Markus de Medeiros -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.CMRA public import LeanPool.IrisAlgebra.Algebra.OFE diff --git a/LeanPool/IrisAlgebra/Algebra/Updates.lean b/LeanPool/IrisAlgebra/Algebra/Updates.lean index a6745b1e7e..f3b860521a 100644 --- a/LeanPool/IrisAlgebra/Algebra/Updates.lean +++ b/LeanPool/IrisAlgebra/Algebra/Updates.lean @@ -5,6 +5,8 @@ Authors: Sukharik (@suhr) -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import LeanPool.IrisAlgebra.Algebra.CMRA /-! Frame-preserving updates of ordered resources. @@ -122,31 +124,31 @@ theorem Update.total [IsTotal α] : x ~~> y ↔ ∀ (n : Nat) (z : α), ✓{n} ( theorem UpdateP.discrete [Discrete α] : x ~~>: P ↔ ∀ (mz : Option α), ✓ (x •? mz) → ∃ y, P y ∧ ✓ (y •? mz) where mp uxp := fun mz v => - let ⟨y, py, vy⟩ := uxp 0 mz (Valid.validN v) + let ⟨y, py, vy⟩ := uxp 0 mz (Validity.Valid.validN v) ⟨y, py, discrete_valid vy⟩ mpr h := fun n mz v => let ⟨y, py, vy⟩ := h mz ((valid_iff_validN' n).mpr v) - ⟨y, py, Valid.validN vy⟩ + ⟨y, py, Validity.Valid.validN vy⟩ theorem Update.discrete [Discrete α] {x y : α} : x ~~> y ↔ ∀ (mz : Option α), ✓ (x •? mz) → ✓ (y •? mz) where - mp uxp := fun mz v => discrete_valid <| uxp 0 mz (Valid.validN v) - mpr h := fun n mz v => Valid.validN <| h mz ((valid_iff_validN' n).mpr v) + mp uxp := fun mz v => discrete_valid <| uxp 0 mz (Validity.Valid.validN v) + mpr h := fun n mz v => Validity.Valid.validN <| h mz ((valid_iff_validN' n).mpr v) theorem UpdateP.discrete_total [Discrete α] [IsTotal α] : x ~~>: P ↔ ∀ (z : α), ✓ (x • z) → ∃ y, P y ∧ ✓ (y • z) where mp uxp := fun z vz => - let ⟨y, py, vy⟩ := UpdateP.total.mp uxp 0 z (Valid.validN vz) + let ⟨y, py, vy⟩ := UpdateP.total.mp uxp 0 z (Validity.Valid.validN vz) ⟨y, py, discrete_valid vy⟩ mpr h := UpdateP.total.mpr fun n z v => let ⟨y, py, vy⟩ := h z ((valid_iff_validN' n).mpr v) - ⟨y, py, Valid.validN vy⟩ + ⟨y, py, Validity.Valid.validN vy⟩ theorem Update.discrete_total [Discrete α] [IsTotal α] : x ~~> y ↔ ∀ (z : α), ✓ (x • z) → ✓ (y • z) where mp uxp := fun z vz => - discrete_valid <| Update.total.mp uxp 0 z (Valid.validN vz) + discrete_valid <| Update.total.mp uxp 0 z (Validity.Valid.validN vz) mpr h := Update.total.mpr fun n z v => (h z ((valid_iff_validN' n).mpr v)).validN -- (** * Transport *) diff --git a/LeanPool/IrisAlgebra/Std/Nat.lean b/LeanPool/IrisAlgebra/Std/Nat.lean index 5ccb315397..d3ff6fc905 100644 --- a/LeanPool/IrisAlgebra/Std/Nat.lean +++ b/LeanPool/IrisAlgebra/Std/Nat.lean @@ -5,6 +5,8 @@ Authors: Markus de Medeiros -/ module +-- Adapted for Lean Pool from Iris-Lean. + public import Mathlib.Init /-! Iteration of functions on natural numbers. diff --git a/LeanPool/IrisAlgebra/Std/Option.lean b/LeanPool/IrisAlgebra/Std/Option.lean index 8566e0e6fd..5e2b532ff3 100644 --- a/LeanPool/IrisAlgebra/Std/Option.lean +++ b/LeanPool/IrisAlgebra/Std/Option.lean @@ -6,6 +6,8 @@ Authors: Markus de Medeiros module +-- Adapted for Lean Pool from Iris-Lean. + public import Mathlib.Init /-! Relations lifted to optional values. diff --git a/LeanPool/projects/iris-algebra.yaml b/LeanPool/projects/iris-algebra.yaml index 0635e22aec..892e4aa5f1 100644 --- a/LeanPool/projects/iris-algebra.yaml +++ b/LeanPool/projects/iris-algebra.yaml @@ -31,6 +31,9 @@ source: announcement_date: '2026-09-24T08:53:06Z' material_completion: https://github.com/leanprover-community/iris-lean/commit/81bc35088ba67d465db008f5261a9b341eb6cf6c material_completion_date: '2026-10-14T14:22:42Z' + upstream_notice: |- + Iris-Lean — Copyright (c) 2022–2026 The Iris-Lean Contributors. + Prior per-file copyright notices are preserved in this repository's git history (tag `copyright-notices`). original_copyright_notices: - Copyright (c) The Iris-Lean Contributors - Copyright (c) 2025 Сухарик. All rights reserved. From a4b706aa933c62ffcb7b31c3e88189a7f9c7aac3 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 14:59:26 +0000 Subject: [PATCH 5/7] Generalize Iris inclusion and reuse standard equality APIs --- LeanPool/IrisAlgebra/Algebra/CMRA.lean | 137 +++++++++++++------------ LeanPool/IrisAlgebra/Algebra/OFE.lean | 124 +++------------------- 2 files changed, 86 insertions(+), 175 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean index a88fe952b3..778a976b58 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRA.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -229,6 +229,36 @@ theorem valid0_of_validN {n} {x : α} : ✓{n} x → ✓{0} x := validN_of_le (N end Validity +section CoreProperties +variable [PCore α] + +/-- A resource equal to its own partial core. -/ +class CoreId (x : α) where + core_id : pcore x = some x +export CoreId (core_id) + +end CoreProperties + +section ResourceProperties +variable [Op α] [Validity α] + +/-- A resource that cannot be composed validly with any further resource. -/ +class Exclusive (x : α) where + exclusive0_l y : ¬✓{0} x • y +export Exclusive (exclusive0_l) + +/-- A resource cancellable from valid compositions at each step index. -/ +class Cancelable (x : α) where + cancelableN : ✓{n} x • y → x • y ≡{n}≡ x • z → y ≡{n}≡ z +export Cancelable (cancelableN) + +/-- A valid resource that cannot absorb a right factor at index zero. -/ +class IdFree (x : α) where + id_free0_r y : ✓{0} x → ¬x • y ≡{0}≡ x +export IdFree (id_free0_r) + +end ResourceProperties + variable [Op α] /-! ## Op -/ @@ -360,6 +390,29 @@ theorem op_mono {x x' y y' : α} (hx : x ≼ x') (hy : y ≼ y') : ord_trans := inc_trans ordN_of_ord n h := incN_of_inc n h +theorem included_dist_l {n} {x1 x2 x1' : α} : + x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2 + | ⟨y, hy⟩, e => ⟨x1' • y, inc_op_left x1' y, e.op_l.trans hy.symm.dist⟩ + +theorem incN_map {β : Type _} [OFE β] [Op β] (f : α → β) [NonExpansive f] + (hop : ∀ x y, f (x • y) = f x • f y) {n} {x y : α} : x ≼{n} y → f x ≼{n} f y + | ⟨z, hz⟩ => ⟨f z, (NonExpansive.ne hz).trans (hop x z).dist⟩ + +theorem inc_map {β : Type _} [OFE β] [Op β] (f : α → β) + (hop : ∀ x y, f (x • y) = f x • f y) {x y : α} : x ≼ y → f x ≼ f y + | ⟨z, hz⟩ => ⟨f z, (congrArg f hz).trans (hop x z)⟩ + +theorem inc_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼ y ↔ x ≼{n} y := + ⟨incN_of_inc _, fun ⟨z, hz⟩ => ⟨z, discrete hz⟩⟩ + +theorem inc_0_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼{0} y ↔ x ≼{n} y := + ⟨fun ⟨z, hz⟩ => ⟨z, (discrete hz).dist⟩, inc0_of_incN⟩ + +theorem inc_of_inc0 [OFE.Discrete α] {x y : α} : x ≼{0} y → x ≼ y := (inc_iff_incN 0).mpr + +theorem discrete_inc_r {x y : α} [HD : DiscreteE y] : x ≼{0} y → x ≼ y + | ⟨z, hz⟩ => ⟨z, HD.discrete hz⟩ + section pcore variable [PCore α] @@ -422,26 +475,6 @@ class ORA (α : Type _) extends OFE α, Op α, PCore α, Validity α, Ordered α namespace ORA variable [ORA α] -/-- A resource equal to its own partial core. -/ -class CoreId (x : α) where - core_id : pcore x = some x -export CoreId (core_id) - -/-- A resource that cannot be composed validly with any further resource. -/ -class Exclusive (x : α) where - exclusive0_l y : ¬✓{0} x • y -export Exclusive (exclusive0_l) - -/-- A resource cancellable from valid compositions at each step index. -/ -class Cancelable (x : α) where - cancelableN : ✓{n} x • y → x • y ≡{n}≡ x • z → y ≡{n}≡ z -export Cancelable (cancelableN) - -/-- A valid resource that cannot absorb a right factor at index zero. -/ -class IdFree (x : α) where - id_free0_r y : ✓{0} x → ¬x • y ≡{0}≡ x -export IdFree (id_free0_r) - /-! ## Validity -/ theorem validN_op_right {n} {x y : α} : ✓{n} (x • y) → ✓{n} y := @@ -584,10 +617,6 @@ theorem op_core_right_of_inc {x y : α} [CoreId x] : x ≼ y → x • y = y theorem op_core_left_of_inc {x y : α} [CoreId x] (le : x ≼ y) : y • x = y := Op.comm.trans (op_core_right_of_inc le) -theorem included_dist_l {n} {x1 x2 x1' : α} : - x1 ≼ x2 → x1' ≡{n}≡ x1 → ∃ x2', x1' ≼ x2' ∧ x2' ≡{n}≡ x2 - | ⟨y, hy⟩, e => ⟨x1' • y, inc_op_left x1' y, e.op_l.trans hy.symm.dist⟩ - theorem not_valid_of_exclN_inc {n} {x : α} [Exclusive x] {y} : x ≼{n} y → ¬✓{n} y | ⟨_, hz⟩, v => not_valid_exclN_op_left (validN_ne hz v) @@ -600,14 +629,6 @@ theorem incN_extend {n} {x y : α} (v : ✓{n} y) : let ⟨z₁, z₂, hy, hz₁, _⟩ := extend v hw ⟨z₁, ⟨z₂, hy.dist⟩, hz₁⟩ -theorem incN_map {β : Type _} [ORA β] (f : α → β) [NonExpansive f] - (hop : ∀ x y, f (x • y) = f x • f y) {n} {x y : α} : x ≼{n} y → f x ≼{n} f y - | ⟨z, hz⟩ => ⟨f z, (NonExpansive.ne hz).trans (hop x z).dist⟩ - -theorem inc_map {β : Type _} [ORA β] (f : α → β) - (hop : ∀ x y, f (x • y) = f x • f y) {x y : α} : x ≼ y → f x ≼ f y - | ⟨z, hz⟩ => ⟨f z, (congrArg f hz).trans (hop x z)⟩ - section total variable [IsTotal α] @@ -624,23 +645,12 @@ end total section discrete -theorem inc_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼ y ↔ x ≼{n} y := - ⟨incN_of_inc _, fun ⟨z, hz⟩ => ⟨z, discrete hz⟩⟩ - -theorem inc_0_iff_incN [OFE.Discrete α] (n) {x y : α} : x ≼{0} y ↔ x ≼{n} y := - ⟨fun ⟨z, hz⟩ => ⟨z, (discrete hz).dist⟩, inc0_of_incN⟩ - -theorem inc_of_inc0 [OFE.Discrete α] {x y : α} : x ≼{0} y → x ≼ y := (inc_iff_incN 0).mpr - theorem discrete_inc_l {x y : α} [HD : DiscreteE x] (Hv : ✓{0} y) (Hle : x ≼{0} y) : x ≼ y := have ⟨_, hz⟩ := Hle let ⟨_, t, wt, wx, _⟩ := extend Hv hz ⟨t, wt.trans (congrArg (· • t) (HD.discrete wx.symm).symm)⟩ -theorem discrete_inc_r {x y : α} [HD : DiscreteE y] : x ≼{0} y → x ≼ y - | ⟨z, hz⟩ => ⟨z, HD.discrete hz⟩ - end discrete end ORA @@ -690,8 +700,7 @@ theorem pcore_mono {x y cx : α} : x ≼ y → pcore x = some cx → ∃ cy, pcore y = some cy ∧ cx ≼ cy | ⟨_, hw⟩, e => have ⟨z, hz⟩ := pcore_op_mono e _ - let ⟨t, ht, et⟩ := OFE.equiv_some ((congrArg pcore hw).trans hz) - ⟨t, ht, z, et⟩ + ⟨cx • z, (congrArg pcore hw).trans hz, z, rfl⟩ theorem pcore_monoN' {n} {x y : α} {cx} : x ≼{n} y → pcore x ≡{n}≡ some cx → ∃ cy, pcore y = some cy ∧ cx ≼{n} cy @@ -1969,7 +1978,7 @@ instance cmraOption : ORA (Option α) where apply validN_op_left pcore_op_left {x cx} := by rcases x, cx with ⟨_|_, _|_⟩ <;> simp_all only [pcore, optionCore, Option.bind_none, op, - optionOp, imp_self, Option.some.injEq, not_none_eqv_some, not_some_eqv_none, implies_true, + optionOp, imp_self, Option.some.injEq, reduceCtorEq, implies_true, Option.bind_some] intro h; exact pcore_op_left h extend {n} := by @@ -2324,8 +2333,8 @@ theorem incN_iff {n} {ma mb : Option α} : ma = none ∨ ∃ a b, ma = some a ∧ mb = some b ∧ (a ≡{n}≡ b ∨ a ≼{n} b) := by refine ⟨fun ⟨mc, Hmc⟩ => ?_, ?_⟩ · rcases ma, mb, mc with ⟨_|_, _|_, _|_⟩ <;> simp_all only [op, optionOp, Dist.refl, - not_none_eqv_some, false_and, and_self, exists_false, or_false, not_none_dist_some, - not_some_dist_none, some_dist_some, Option.some.injEq, not_some_eqv_none, exists_and_left, + reduceCtorEq, false_and, and_self, exists_false, or_false, not_none_dist_some, + not_some_dist_none, some_dist_some, Option.some.injEq, exists_and_left, exists_eq_left', false_or] · exact .inl Hmc.symm · exact .inr ⟨_, Hmc⟩ @@ -2444,7 +2453,7 @@ theorem valid_of_inc_valid {a b : α} (Hv : ✓ a) (Hinc : some b ≼ some a) : valid_of_inc (α := Option α) Hinc Hv theorem some_inc_some_iff_opM {a b : α} : some a ≼ some b ↔ ∃ mc, b = a •? mc := by - simp only [inc_iff, not_some_eqv_none, Option.some.injEq, exists_and_left, exists_eq_left', + simp only [inc_iff, reduceCtorEq, Option.some.injEq, exists_and_left, exists_eq_left', false_or] constructor · rintro (Heqv | ⟨mc', Hinc⟩) @@ -2456,7 +2465,7 @@ theorem some_inc_some_iff_opM {a b : α} : some a ≼ some b ↔ ∃ mc, b = a theorem some_incN_some_iff_opM {n} {a b : α} : some a ≼{n} some b ↔ ∃ mc, b ≡{n}≡ a •? mc := by - simp only [incN_iff, not_some_eqv_none, Option.some.injEq, exists_and_left, exists_eq_left', + simp only [incN_iff, reduceCtorEq, Option.some.injEq, exists_and_left, exists_eq_left', false_or] constructor · rintro (H|H) @@ -2586,8 +2595,8 @@ abbrev Order (x y : α × β) := x.fst ≼ₒ y.fst ∧ x.snd ≼ₒ y.snd def raOp : Op (α × β) where op := op op_ne.ne _ _ _ h := dist_prod_ext (Dist.op_r <| dist_fst h) (Dist.op_r <| dist_snd h) - assoc := equiv_prod_ext assoc assoc - comm := equiv_prod_ext comm comm + assoc := Prod.ext assoc assoc + comm := Prod.ext comm comm /-- The partial core on resource pairs. -/ @[reducible] @@ -2605,12 +2614,12 @@ def raPCore : PCore (α × β) where pcore_idem {x cx} h := by have ⟨cx₁, hcx₁, this⟩ := Option.bind_eq_some_iff.mp h have ⟨cx₂, hcx₂, hcx⟩ := Option.bind_eq_some_iff.mp this - have ⟨a, ha, ea⟩ := equiv_some (pcore_idem hcx₁) - have ⟨b, hb, eb⟩ := equiv_some (pcore_idem hcx₂) - have g : (a, b) = (cx₁, cx₂) := equiv_prod_ext ea eb + have ha : PCore.pcore cx₁ = some cx₁ := PCore.pcore_idem hcx₁ + have hb : PCore.pcore cx₂ = some cx₂ := PCore.pcore_idem hcx₂ rw [Option.some.inj hcx.symm] - simp only [ha, hb, pcore] - exact congrArg some g + simp only [pcore] + rw [ha, hb] + rfl /-- Validity on resource pairs. -/ @[reducible] @@ -2663,11 +2672,11 @@ instance cmraProd : ORA (α × β) where pcore_op_left h := let ⟨_, ha, ho⟩ := Option.bind_eq_some_iff.mp h let ⟨_, hb, hh⟩ := Option.bind_eq_some_iff.mp ho - (Option.some.inj hh) ▸ (equiv_prod_ext (pcore_op_left ha) (pcore_op_left hb)) + (Option.some.inj hh) ▸ (Prod.ext (pcore_op_left ha) (pcore_op_left hb)) extend := fun ⟨vx₁, vx₂⟩ e => let ⟨z₁, w₁, hx₁, hz₁, hw₁⟩ := extend vx₁ (OFE.dist_fst e) let ⟨z₂, w₂, hx₂, hz₂, hw₂⟩ := extend vx₂ (OFE.dist_snd e) - ⟨(z₁, z₂), (w₁, w₂), equiv_prod_ext hx₁ hx₂, ⟨hz₁, hz₂⟩, ⟨hw₁, hw₂⟩⟩ + ⟨(z₁, z₂), (w₁, w₂), Prod.ext hx₁ hx₂, ⟨hz₁, hz₂⟩, ⟨hw₁, hw₂⟩⟩ toOrdered := raOrdered op_monoN_left_ord z h := ⟨op_monoN_left_ord z.1 h.1, op_monoN_left_ord z.2 h.2⟩ op_mono_left_ord z h := ⟨op_mono_left_ord z.1 h.1, op_mono_left_ord z.2 h.2⟩ @@ -2955,7 +2964,7 @@ def Prod.mapC (f : A -C> A') (g : B -C> B') : A × B -C> A' × B' where cases _ : ORA.pcore (f.f x.fst) <;> cases _ : ORA.pcore (g.f x.snd) <;> simp_all - op x y := equiv_prod_ext (f.op x.fst y.fst) (g.op x.snd y.snd) + op x y := Prod.ext (f.op x.fst y.fst) (g.op x.snd y.snd) monoN_ord h := ⟨f.monoN_ord h.1, g.monoN_ord h.2⟩ mono_ord h := ⟨f.mono_ord h.1, g.mono_ord h.2⟩ increasing h := @@ -2971,9 +2980,9 @@ instance instRFunctorProdOF [RFunctor F1] [RFunctor F2] : RFunctor (ProdOF F1 F2 map f g := Prod.mapC (map f g) (map f g) map_ne.ne _ _ _ Hx _ _ Hy _ := Prod.map_ne (fun _ => map_ne.ne Hx Hy _) (fun _ => map_ne.ne Hx Hy _) - map_id _ := equiv_prod_ext (map_id _) (map_id _) + map_id _ := Prod.ext (map_id _) (map_id _) map_comp _ _ _ _ _ := - equiv_prod_ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) + Prod.ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) instance instRFunctorAffineProdOF [RFunctor F1] [RFunctor F2] [RFunctorAffine F1] [RFunctorAffine F2] : RFunctorAffine (ProdOF F1 F2) where @@ -2990,9 +2999,9 @@ instance instURFunctorProdOF [URFunctor F1] [URFunctor F2] : URFunctor (ProdOF F map f g := Prod.mapC (URFunctor.map f g) (URFunctor.map f g) map_ne.ne _ _ _ Hx _ _ Hy _ := Prod.map_ne (fun _ => URFunctor.map_ne.ne Hx Hy _) (fun _ => URFunctor.map_ne.ne Hx Hy _) - map_id _ := equiv_prod_ext (URFunctor.map_id _) (URFunctor.map_id _) + map_id _ := Prod.ext (URFunctor.map_id _) (URFunctor.map_id _) map_comp _ _ _ _ _ := - equiv_prod_ext (URFunctor.map_comp _ _ _ _ _) (URFunctor.map_comp _ _ _ _ _) + Prod.ext (URFunctor.map_comp _ _ _ _ _) (URFunctor.map_comp _ _ _ _ _) instance instURFunctorContractiveProdOF [URFunctorContractive F1] [URFunctorContractive F2] : diff --git a/LeanPool/IrisAlgebra/Algebra/OFE.lean b/LeanPool/IrisAlgebra/Algebra/OFE.lean index 801394602e..75d73e2fa2 100644 --- a/LeanPool/IrisAlgebra/Algebra/OFE.lean +++ b/LeanPool/IrisAlgebra/Algebra/OFE.lean @@ -233,61 +233,11 @@ https://leanprover.zulipchat.com/#narrow/channel/490604-iris-lean/topic/Evaluati dist_lt := fun {n x y m} h hlt' => by induction x, y using Quotient.ind₂ with | _ a b => exact hlt h hlt' } -namespace ofQuotient - -variable {X : Type u} {s : Setoid X} - -/-- Form an equivalence class in the quotient equivalence space. -/ -@[reducible] def mk (s : Setoid X) (x : X) : Quotient s := Quotient.mk s x - -@[elab_as_elim] theorem ind {motive : Quotient s → Prop} - (mk : ∀ x : X, motive (mk s x)) (q : Quotient s) : motive q := - Quotient.ind mk q - -@[elab_as_elim] theorem ind₂ {motive : Quotient s → Quotient s → Prop} - (mk : ∀ x y : X, motive (mk s x) (mk s y)) (x y : Quotient s) : motive x y := - Quotient.ind₂ mk x y - -@[elab_as_elim] theorem ind₃ {motive : Quotient s → Quotient s → Quotient s → Prop} - (mk : ∀ x y z : X, motive (mk s x) (mk s y) (mk s z)) (x y z : Quotient s) : - motive x y z := - ind₂ (fun x y => Quotient.ind (mk x y)) x y z - -theorem sound {x y : X} (h : s.r x y) : mk s x = mk s y := Quotient.sound h - -theorem exact {x y : X} (h : mk s x = mk s y) : s.r x y := Quotient.exact h - -theorem mk_eq {x y : X} : mk s x = mk s y ↔ s.r x y := ⟨exact, sound⟩ - -/-- Lift a class-invariant function from a quotient equivalence space. -/ -@[reducible] def lift {β : Sort v} (f : X → β) - (resp : ∀ x y, s.r x y → f x = f y) : Quotient s → β := Quotient.lift f resp - -@[simp] theorem lift_mk {β : Sort v} (f : X → β) (resp) (x : X) : - lift (s := s) f resp (mk s x) = f x := rfl - -/-- Lift a binary class-invariant function from quotient equivalence spaces. -/ -@[reducible] def lift₂ {β : Sort v} (f : X → X → β) - (resp : ∀ a b c d, s.r a c → s.r b d → f a b = f c d) : - Quotient s → Quotient s → β := Quotient.lift₂ f resp - -@[simp] theorem lift₂_mk {β : Sort v} (f : X → X → β) (resp) (x y : X) : - lift₂ (s := s) f resp (mk s x) (mk s y) = f x y := rfl - -/-- Map a relation-preserving function between quotient equivalence spaces. -/ -@[reducible] def map {X' : Type u'} {s' : Setoid X'} (f : X → X') - (hf : ∀ x y, s.r x y → s'.r (f x) (f y)) : Quotient s → Quotient s' := - Quotient.lift (fun x => mk s' (f x)) (fun _ _ h => sound (hf _ _ h)) - -@[simp] theorem map_mk {X' : Type u'} {s' : Setoid X'} (f : X → X') (hf) (x : X) : - map (s := s) (s' := s') f hf (mk s x) = mk s' (f x) := rfl - -theorem dist_mk {dist : Nat → X → X → Prop} {heqv : ∀ {n}, Equivalence (dist n)} +theorem ofQuotient.dist_mk {X : Type u} {s : Setoid X} {dist : Nat → X → X → Prop} + {heqv : ∀ {n}, Equivalence (dist n)} {hlt : ∀ {n m} {x y : X}, dist n x y → m < n → dist m x y} {hs : ∀ x y : X, s.r x y ↔ ∀ n, dist n x y} {n} {x y : X} : - (ofQuotient dist heqv hlt hs).Dist n (mk s x) (mk s y) ↔ dist n x y := Iff.rfl - -end ofQuotient + (ofQuotient dist heqv hlt hs).Dist n (Quotient.mk s x) (Quotient.mk s y) ↔ dist n x y := Iff.rfl /-- A morphism between OFEs, written `α -n> β`, is defined to be a function that is non-expansive. -/ @@ -406,19 +356,11 @@ instance [OFE α] [OFE.Discrete α] : OFE.Discrete (Option α) where | some _, none => e.elim | some _, some _ => congrArg some (discrete_0 e) -@[simp] theorem not_some_eqv_none {x : α} : ¬some x = none := Option.some_ne_none x -@[simp] theorem not_none_eqv_some {x : α} : ¬none = some x := fun h => Option.some_ne_none - x h.symm - @[simp] theorem some_dist_some [OFE α] {n} {x y : α} : (some x ≡{n}≡ some y) ↔ x ≡{n}≡ y := .rfl @[simp] theorem not_some_dist_none [OFE α] {n} {x : α} : ¬some x ≡{n}≡ none := id @[simp] theorem not_none_dist_some [OFE α] {n} {x : α} : ¬none ≡{n}≡ some x := id -theorem equiv_some {o : Option α} {y : α} (e : o = some y) : - ∃ z, o = some z ∧ z = y := ⟨y, e, rfl⟩ - - theorem dist_none [OFE α] {o : Option α} : o ≡{n}≡ none ↔ o = none := ⟨fun h => by cases o with | none => rfl | some _ => exact h.elim, (· ▸ .rfl)⟩ @@ -497,12 +439,6 @@ theorem Option.bind_dist [OFE β] {x : Option α} {f g : α → Option β} (H : | some _ => H _ | none => .rfl -theorem Option.bind_equiv {x : Option α} {f g : α → Option β} (H : ∀ x, f x = g x) - : Option.bind x f = Option.bind x g := - match x with - | some _ => H _ - | none => rfl - /-- A pointwise family of ordered equivalence structures. -/ abbrev OFEFun {α : Type _} (β : α → Type _) := ∀ a, OFE (β a) @@ -530,10 +466,6 @@ instance ofe_mor_car_ne [OFE α] [OFE β] : NonExpansive₂ (fun (f : α -n> β) (x : α) => f x) where ne _ _ _ hf _ _ hx := dist_eqv.trans (hf _) (NonExpansive.ne hx) -theorem ofe_mor_car_proper [OFE α] [OFE β] ⦃f g : α -n> β⦄ (hfg : f = g) - ⦃x y : α⦄ (hxy : x = y) : f x = g y := by - subst hfg; subst hxy; rfl - instance [OFE α] [OFE β] [Inhabited β] : Inhabited (α -n> β) where default := { f := Function.const α default, ne := const_ne } @@ -595,11 +527,6 @@ instance [OFE α] [OFE β] : OFE (α × β) where eq_dist' {_ _} := by rw [Prod.ext_iff]; simp only [eq_dist, forall_and] dist_lt h1 h2 := ⟨dist_lt h1.1 h2, dist_lt h1.2 h2⟩ -theorem equiv_fst {x y : α × β} (h : x = y) : x.fst = y.fst := congrArg Prod.fst h -theorem equiv_snd {x y : α × β} (h : x = y) : x.snd = y.snd := congrArg Prod.snd h -theorem equiv_prod_ext {x₁ x₂ : α} {y₁ y₂ : β} - (ex : x₁ = x₂) (ey : y₁ = y₂) : (x₁, y₁) = (x₂, y₂) := by subst ex; subst ey; rfl - theorem dist_fst {n} [OFE α] [OFE β] {x y : α × β} (h : x ≡{n}≡ y) : x.fst ≡{n}≡ y.fst := h.left theorem dist_snd {n} [OFE α] [OFE β] {x y : α × β} (h : x ≡{n}≡ y) : x.snd ≡{n}≡ y.snd := h.right @@ -663,11 +590,6 @@ instance instDiscreteProd [OFE α] [OFE β] [Discrete α] [Discrete β] : Discre section sum -theorem equiv_inl {x y : α} (h : x = y) : (.inl x : α ⊕ β) = .inl y := congrArg Sum.inl h -theorem equiv_inr {x y : β} (h : x = y) : (.inr x : α ⊕ β) = .inr y := congrArg Sum.inr h -theorem equiv_ext_left {x y : α} (h : (.inl x : α ⊕ β) = .inl y) : x = y := Sum.inl.inj h -theorem equiv_ext_right {x y : β} (h : (.inr x : α ⊕ β) = .inr y) : x = y := Sum.inr.inj h - variable [OFE α] [OFE β] instance : OFE (α ⊕ β) where @@ -739,8 +661,8 @@ theorem discreteE_inr {a : β} (Ha : DiscreteE a) : DiscreteE (.inr a : α ⊕ instance instDiscreteSum [Discrete α] [Discrete β] : Discrete (α ⊕ β) where discrete_0 {x y} := match x, y with - | .inl _, .inl _ => (equiv_inl <| discrete_0 (α := α) <| dist_ext_left ·) - | .inr _, .inr _ => (equiv_inr <| discrete_0 (α := β) <| dist_ext_right ·) + | .inl _, .inl _ => (congrArg Sum.inl <| discrete_0 (α := α) <| dist_ext_left ·) + | .inr _, .inr _ => (congrArg Sum.inr <| discrete_0 (α := β) <| dist_ext_right ·) | .inl _, .inr _ => (False.elim ·) | .inr _, .inl _ => (False.elim ·) @@ -809,18 +731,9 @@ instance instDiscreteSigma {P : α → Type _} [∀ x, OFE (P x)] [∀ x, Discre discrete_0 {x y} H := match x, y, H with | ⟨x, xH⟩, ⟨y, yH⟩, ⟨heq, H⟩ => by simp only at heq; subst heq; exact congrArg _ (discrete_0 H) -theorem Sigma.equiv_eq_alt {P : α → Type _} {x1 x2 : Sigma P} : - x1 = x2 ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd = x2.snd := by - refine ⟨fun h => h ▸ ⟨rfl, rfl⟩, fun ⟨heq, h⟩ => ?_⟩ - obtain ⟨x1f, x1s⟩ := x1; obtain ⟨x2f, x2s⟩ := x2 - simp only at heq; subst heq; simp only at h; subst h; rfl - theorem Sigma.dist_eq {P : α → Type _} [∀ x, OFE (P x)] {n} {x1 x2 : Sigma P} : (x1 ≡{n}≡ x2) ↔ ∃ heq : x1.fst = x2.fst, heq ▸ x1.snd ≡{n}≡ x2.snd := Iff.rfl -theorem Sigma.equiv_proj1 {P : α → Type _} {x y : Sigma P} - (h : x = y) : x.fst = y.fst := congrArg Sigma.fst h - instance Sigma.fst_ne {P : α → Type _} [OFE α] [∀ x, OFE (P x)] : NonExpansive (Sigma.fst : Sigma P → α) where ne {_ _ _} h := Dist.of_eq h.1 @@ -836,18 +749,10 @@ theorem Sigma.dist_fst {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P theorem Sigma.dist_snd {P : α → Type _} [∀ x, OFE (P x)] {n} {x y : Sigma P} (h : x ≡{n}≡ y) : Sigma.dist_fst h ▸ x.snd ≡{n}≡ y.snd := h.2 -theorem Sigma.equiv_snd {P : α → Type _} {x y : Sigma P} - (h : x = y) : congrArg Sigma.fst h ▸ x.snd = y.snd := by - subst h; rfl - theorem Sigma.mk_dist {P : α → Type _} [∀ x, OFE (P x)] {n} {i1 i2 : α} {v1 : P i1} {v2 : P i2} (heq : i1 = i2) (h : heq ▸ v1 ≡{n}≡ v2) : Sigma.mk i1 v1 ≡{n}≡ Sigma.mk i2 v2 := ⟨heq, h⟩ -theorem Sigma.mk_equiv {P : α → Type _} {i1 i2 : α} {v1 : P i1} {v2 : P i2} - (heq : i1 = i2) (h : heq ▸ v1 = v2) : Sigma.mk i1 v1 = Sigma.mk i2 v2 := by - subst heq; subst h; rfl - instance Sigma.mk_ne {P : α → Type _} [∀ x, OFE (P x)] (a : α) : NonExpansive (Sigma.mk a : P a → Sigma P) where ne {_ _ _} h := ⟨rfl, h⟩ @@ -1291,9 +1196,6 @@ theorem Option.map_ne [OFE β] {f g : α → β} {x y : Option α} {n} : | none => exact hxy.elim | some b => exact hf a b hxy -theorem Option.map_forall₂ {α β : Type _} (f : α → β) - {o1 o2 : Option α} (h : o1 = o2) : o1.map f = o2.map f := congrArg (Option.map f) h - instance optionMap_ne [OFE β] : NonExpansive (optionMap (α := α) (β := β)) where ne _ f _ h o := Option.map_ne (fun _ _ hab => dist_eqv.trans (f.ne.ne hab) (h _)) (dist_eqv.refl o) @@ -1405,8 +1307,8 @@ instance instOFunctorProdOF [OFunctor F1] [OFunctor F2] : OFunctor (ProdOF F1 F2 ofe := inferInstance map f g := Prod.mapO (map f g) (map f g) map_ne.ne _ _ _ Hx _ _ Hy _ := ⟨map_ne.ne Hx Hy _, map_ne.ne Hx Hy _⟩ - map_id _ := equiv_prod_ext (map_id _) (map_id _) - map_comp _ _ _ _ _ := equiv_prod_ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) + map_id _ := Prod.ext (map_id _) (map_id _) + map_comp _ _ _ _ _ := Prod.ext (map_comp _ _ _ _ _) (map_comp _ _ _ _ _) open OFunctorContractive in instance instOFunctorContractiveProdOF [OFunctorContractive F1] [OFunctorContractive F2] : @@ -1432,8 +1334,8 @@ omit [OFE A] [OFE A'] [OFE B] [OFE B'] in theorem Sum.map_ext {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a = f' a) (Hg : ∀ a, g a = g' a) : Sum.map f g x = Sum.map f' g' x := match x with - | .inl _ => equiv_inl (Hf _) - | .inr _ => equiv_inr (Hg _) + | .inl _ => congrArg Sum.inl (Hf _) + | .inr _ => congrArg Sum.inr (Hg _) omit [OFE A] [OFE B] in theorem Sum.map_ne {f f' : A → A'} {g g' : B → B'} (Hf : ∀ a, f a ≡{n}≡ f' a) @@ -1463,11 +1365,11 @@ instance instOFunctorSumOF [OFunctor F1] [OFunctor F2] : OFunctor (SumOF F1 F2) | .inl _ => dist_inl (map_ne.ne Hx Hy _) | .inr _ => dist_inr (map_ne.ne Hx Hy _) map_id x := match x with - | .inl _ => equiv_inl (map_id _) - | .inr _ => equiv_inr (map_id _) + | .inl _ => congrArg Sum.inl (map_id _) + | .inr _ => congrArg Sum.inr (map_id _) map_comp _ _ _ _ x := match x with - | .inl _ => equiv_inl (map_comp _ _ _ _ _) - | .inr _ => equiv_inr (map_comp _ _ _ _ _) + | .inl _ => congrArg Sum.inl (map_comp _ _ _ _ _) + | .inr _ => congrArg Sum.inr (map_comp _ _ _ _ _) open OFunctorContractive in instance instOFunctorContractiveSumOF [OFunctorContractive F1] [OFunctorContractive F2] : From 8af8e3388f4ca4b36abf493a29a9e1e280ba1d97 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 15:44:14 +0000 Subject: [PATCH 6/7] Place Iris resource traits and laws at their primitive layers --- LeanPool/IrisAlgebra/Algebra/CMRA.lean | 175 +++++++++++++------------ 1 file changed, 90 insertions(+), 85 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/CMRA.lean b/LeanPool/IrisAlgebra/Algebra/CMRA.lean index 778a976b58..4bfb4e8361 100644 --- a/LeanPool/IrisAlgebra/Algebra/CMRA.lean +++ b/LeanPool/IrisAlgebra/Algebra/CMRA.lean @@ -237,6 +237,12 @@ class CoreId (x : α) where core_id : pcore x = some x export CoreId (core_id) +theorem CoreId.of_pcore_eq_some {x y : α} (e : pcore x = some y) : CoreId y where + core_id := pcore_idem e + +theorem core_eqv_self (x : α) [CoreId x] : core x = x := by + simp only [core, CoreId.core_id, Option.getD_some] + end CoreProperties section ResourceProperties @@ -259,6 +265,7 @@ export IdFree (id_free0_r) end ResourceProperties +section Operations variable [Op α] /-! ## Op -/ @@ -413,6 +420,72 @@ theorem inc_of_inc0 [OFE.Discrete α] {x y : α} : x ≼{0} y → x ≼ y := (in theorem discrete_inc_r {x y : α} [HD : DiscreteE y] : x ≼{0} y → x ≼ y | ⟨z, hz⟩ => ⟨z, HD.discrete hz⟩ +section ResourceLaws +variable [Validity α] + +theorem not_valid_exclN_op_left {n} {x : α} [Exclusive x] {y} : ¬✓{n} (x • y) := + n.recOn (Exclusive.exclusive0_l _) fun _ ih => ih ∘ validN_succ + +theorem not_valid_exclN_op_right {n} {x : α} [Exclusive x] {y} : ¬✓{n} (y • x) := + fun v => not_valid_exclN_op_left (Op.comm (x := y) (y := x) ▸ v) + +theorem not_valid_excl_op_left {x : α} [Exclusive x] {y} : ¬✓ (x • y) := + fun v => Exclusive.exclusive0_l _ v.validN + +theorem not_excl_op_right {x : α} [Exclusive x] {y} : ¬✓ (y • x) := + fun v => not_valid_excl_op_left (Op.comm (x := y) (y := x) ▸ v) + +theorem none_of_excl_valid_op {n} {x : α} [Exclusive x] {my} : ✓{n} (x •? my) → my = none := by + cases my <;> simp [optionalOp, not_valid_exclN_op_left] + +theorem not_valid_of_exclN_inc {n} {x : α} [Exclusive x] {y} : x ≼{n} y → ¬✓{n} y + | ⟨_, hz⟩, v => not_valid_exclN_op_left (validN_ne hz v) + +theorem not_valid_of_excl_inc {x : α} [Exclusive x] {y} : x ≼ y → ¬✓ y + | ⟨_, hz⟩, v => Exclusive.exclusive0_l _ <| hz ▸ v.validN + +theorem cancelable {x y z : α} [Cancelable x] (v : ✓ (x • y)) (e : x • y = x • z) : y = z := + OFE.eq_dist_2 fun _ => cancelableN v.validN e.dist + +instance exclusive_cancelable {x : α} [Exclusive x] : Cancelable x where + cancelableN v _ := absurd v not_valid_exclN_op_left + +theorem op_opM_cancel_dist {x y z : α} {mw : Option α} [Cancelable x] + (vxy : ✓{n} x • y) (h : x • y ≡{n}≡ (x • z) •? mw) : y ≡{n}≡ z •? mw := + match mw with + | none => cancelableN vxy h + | some _ => cancelableN vxy (h.trans (op_assocN.symm)) + +theorem IdFree.of_dist {x₁ x₂ : α} {n} (e : x₁ ≡{n}≡ x₂) (h : IdFree x₁) : IdFree x₂ where + id_free0_r z v := fun h₂ => + have ee := Dist.le e (Nat.zero_le _) + have := calc + x₁ • z ≡{0}≡ x₂ • z := op_left_dist z ee + _ ≡{0}≡ x₂ := h₂ + _ ≡{0}≡ x₁ := ee.symm + h.id_free0_r _ ((validN_dist_iff ee).mpr v) this + +theorem _root_.Iris.OFE.Dist.idFree {x₁ x₂ : α} (e : x₁ ≡{n}≡ x₂) : IdFree x₁ ↔ IdFree x₂ := + ⟨.of_dist e, .of_dist e.symm⟩ + +theorem id_freeN_r {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(x • y ≡{n'}≡ x) := + id_free0_r _ (validN_of_le (Nat.zero_le _) v) |>.imp (·.le (Nat.zero_le _)) + +theorem id_freeN_l {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(y • x ≡{n'}≡ x) := + id_freeN_r v ∘ Op.comm.dist.trans + +theorem id_free_r {x : α} [IdFree x] {y} (v : ✓ x) : ¬(x • y = x) := + fun h => id_free0_r y (valid_iff_validN.mp v 0) h.dist + +theorem id_free_l {x : α} [IdFree x] {y} (v : ✓ x) : ¬(y • x = x) := + id_free_r v ∘ Op.comm.trans + +instance exclusive_idFree {x : α} [Exclusive x] : IdFree x where + id_free0_r z v h := exclusive0_l z ((validN_dist_iff h.symm).mp v) + +end ResourceLaws +end Operations + section pcore variable [PCore α] @@ -439,12 +512,27 @@ instance : NonExpansive (pcore (α := α)) where section total variable [IsTotal α] -omit [Op α] in theorem pcore_eq_core (x : α) : pcore x = some (core x) := by unfold core have ⟨cx, hcx⟩ := IsTotal.total x simp [hcx] +instance (y : α) : CoreId (core y) := CoreId.of_pcore_eq_some (pcore_eq_core _) + +theorem core_ne : NonExpansive (core : α → α) where + ne n x₁ x₂ H := by + change some (core x₁) ≡{n}≡ some (core x₂) + rw [← pcore_eq_core, ← pcore_eq_core] + exact NonExpansive.ne H + +theorem _root_.Iris.OFE.Dist.core : + ∀ {n} {x₁ x₂ : α}, x₁ ≡{n}≡ x₂ → core x₁ ≡{n}≡ core x₂ := @core_ne.ne + +theorem coreId_iff_core_eqv_self : CoreId (x : α) ↔ core x = x := + ⟨fun _ => core_eqv_self x, fun e => { core_id := (pcore_eq_core x).trans (congrArg some e) }⟩ + +theorem core_idem (x : α) : core (core x) = core x := core_eqv_self _ + end total end pcore @@ -518,25 +606,6 @@ theorem pcore_valid {x : α} {cx} (e : pcore x = some cx) : ✓ x → ✓ cx := theorem op_self (x : α) [CoreId x] : x • x = x := pcore_op_self CoreId.core_id -theorem CoreId.of_pcore_eq_some {x y : α} (e : pcore x = some y) : CoreId y where - core_id := pcore_idem e - -/-! ## Exclusive elements -/ -theorem not_valid_exclN_op_left {n} {x : α} [Exclusive x] {y} : ¬✓{n} (x • y) := - n.recOn (Exclusive.exclusive0_l _) fun _ ih => ih ∘ validN_succ - -theorem not_valid_exclN_op_right {n} {x : α} [Exclusive x] {y} : ¬✓{n} (y • x) := - fun v => not_valid_exclN_op_left (Op.comm (x := y) (y := x) ▸ v) - -theorem not_valid_excl_op_left {x : α} [Exclusive x] {y} : ¬✓ (x • y) := - fun v => Exclusive.exclusive0_l _ v.validN - -theorem not_excl_op_right {x : α} [Exclusive x] {y} : ¬✓ (y • x) := - fun v => not_valid_excl_op_left (Op.comm (x := y) (y := x) ▸ v) - -theorem none_of_excl_valid_op {n} {x : α} [Exclusive x] {my} : ✓{n} (x •? my) → my = none := by - cases my <;> simp [optionalOp, not_valid_exclN_op_left] - /-! ## Total cores -/ section total @@ -555,25 +624,6 @@ theorem validN_core {n} {x : α} (v : ✓{n} x) : ✓{n} core x := pcore_validN theorem valid_core {x : α} (v : ✓ x) : ✓ core x := pcore_valid (pcore_eq_core x) v -instance (y : α) : CoreId (core y) := CoreId.of_pcore_eq_some (pcore_eq_core _) - -theorem core_ne : NonExpansive (core : α → α) where - ne n x₁ x₂ H := by - change some (core x₁) ≡{n}≡ some (core x₂) - rw [← pcore_eq_core, ← pcore_eq_core] - exact NonExpansive.ne H - -theorem _root_.Iris.OFE.Dist.core : - ∀ {n} {x₁ x₂ : α}, x₁ ≡{n}≡ x₂ → core x₁ ≡{n}≡ core x₂ := @core_ne.ne - -theorem core_eqv_self (x : α) [CoreId x] : core (x : α) = x := - Option.some.inj ((pcore_eq_core x).symm.trans CoreId.core_id) - -theorem coreId_iff_core_eqv_self : CoreId (x : α) ↔ core x = x := - ⟨fun _ => core_eqv_self x, fun e => { core_id := (pcore_eq_core x).trans (congrArg some e) }⟩ - -theorem core_idem (x : α) : core (core x) = core x := core_eqv_self _ - instance instOrderReflOfIsTotal : OrderRefl α where ord_refl x := (congrArg (x ≼ₒ ·) (core_op x)).mp ((pcore_increasing (pcore_eq_core x)).increasing x) @@ -617,12 +667,6 @@ theorem op_core_right_of_inc {x y : α} [CoreId x] : x ≼ y → x • y = y theorem op_core_left_of_inc {x y : α} [CoreId x] (le : x ≼ y) : y • x = y := Op.comm.trans (op_core_right_of_inc le) -theorem not_valid_of_exclN_inc {n} {x : α} [Exclusive x] {y} : x ≼{n} y → ¬✓{n} y - | ⟨_, hz⟩, v => not_valid_exclN_op_left (validN_ne hz v) - -theorem not_valid_of_excl_inc {x : α} [Exclusive x] {y} : x ≼ y → ¬✓ y - | ⟨_, hz⟩, v => Exclusive.exclusive0_l _ <| hz ▸ v.validN - theorem incN_extend {n} {x y : α} (v : ✓{n} y) : x ≼{n} y → ∃ z, z ≼{n.succ} y ∧ z ≡{n}≡ x | ⟨_, hw⟩ => @@ -859,7 +903,7 @@ instance (priority := low) UCMRA.ofIsInc [UORA α] [IsInc α] : UCMRA α := {} ord_refl _ := IncOrd.inc_ord ⟨d.unit, (Op.comm.trans d.unit_left_id).symm⟩ /-- The laws asserting that a specified resource is a valid unit with itself as core. -/ -class IsUnit [ORA α] (ε : α) : Prop where +class IsUnit [OFE α] [Op α] [PCore α] [Validity α] (ε : α) : Prop where unit_valid : ✓ ε unit_left_id : ε • x = x pcore_unit : ORA.pcore ε = some ε @@ -1126,9 +1170,6 @@ end discreteORA section cancelableElements -theorem cancelable {x y z : α} [Cancelable x] (v : ✓ (x • y)) (e : x • y = x • z) : y = z := - OFE.eq_dist_2 fun _ => cancelableN v.validN e.dist - theorem discrete_cancelable {x : α} [Discrete α] (H : ∀ {y z : α}, ✓ (x • y) → x • y = x • z → y = z) : Cancelable x where cancelableN {n} {_ _} v e := (H ((valid_iff_validN' n).mpr v) (Discrete.discrete e)).dist @@ -1139,43 +1180,10 @@ instance cancelable_op {x y : α} [Cancelable x] [Cancelable y] : Cancelable (x have v2 := validN_op_right v1 cancelableN v2 <| cancelableN v1 <| op_assocN.trans <| e.trans op_assocN.symm -instance exclusive_cancelable {x : α} [Exclusive x] : Cancelable x where - cancelableN v _ := absurd v not_valid_exclN_op_left - -theorem op_opM_cancel_dist {x y z : α} {mw : Option α} [Cancelable x] - (vxy : ✓{n} x • y) (h : x • y ≡{n}≡ (x • z) •? mw) : y ≡{n}≡ z •? mw := - match mw with - | none => cancelableN vxy h - | some _ => cancelableN vxy (h.trans (op_assocN.symm)) - end cancelableElements section idFreeElements -theorem IdFree.of_dist {x₁ x₂ : α} {n} (e : x₁ ≡{n}≡ x₂) (h : IdFree x₁) : IdFree x₂ where - id_free0_r z v := fun h₂ => - have ee := Dist.le e (Nat.zero_le _) - have := calc - x₁ • z ≡{0}≡ x₂ • z := op_left_dist z ee - _ ≡{0}≡ x₂ := h₂ - _ ≡{0}≡ x₁ := ee.symm - h.id_free0_r _ ((validN_dist_iff ee).mpr v) this - -theorem _root_.Iris.OFE.Dist.idFree {x₁ x₂ : α} (e : x₁ ≡{n}≡ x₂) : IdFree x₁ ↔ IdFree x₂ := - ⟨.of_dist e, .of_dist e.symm⟩ - -theorem id_freeN_r {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(x • y ≡{n'}≡ x) := - id_free0_r _ (validN_of_le (Nat.zero_le _) v) |>.imp (·.le (Nat.zero_le _)) - -theorem id_freeN_l {n n'} {x : α} [IdFree x] {y} (v : ✓{n} x) : ¬(y • x ≡{n'}≡ x) := - id_freeN_r v ∘ Op.comm.dist.trans - -theorem id_free_r {x : α} [IdFree x] {y} (v : ✓ x) : ¬(x • y = x) := - fun h => id_free0_r y (valid_iff_validN.mp v 0) h.dist - -theorem id_free_l {x : α} [IdFree x] {y} (v : ✓ x) : ¬(y • x = x) := - id_free_r v ∘ Op.comm.trans - theorem discrete_id_free {x : α} [Discrete α] (H : ∀ y, ✓ x → ¬(x • y = x)) : IdFree x where id_free0_r y v h := H y (Discrete.discrete_valid v) (Discrete.discrete_0 h) @@ -1186,9 +1194,6 @@ instance idFree_op_r {x y : α} [IdFree y] [Cancelable x] : IdFree (x • y) whe instance idFree_op_l {x y : α} [IdFree x] [Cancelable y] : IdFree (x • y) := by rw [Op.comm]; exact inferInstance -instance exclusive_idFree {x : α} [Exclusive x] : IdFree x where - id_free0_r z v h := exclusive0_l z ((validN_dist_iff h.symm).mp v) - end idFreeElements section ucmra From 930486d3b9d1824ec6be5deabbb170a8ae93be65 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 2 Nov 2026 16:26:01 +0000 Subject: [PATCH 7/7] Generalize Iris update and monotone predicate interfaces --- LeanPool/IrisAlgebra/Algebra/UPred.lean | 41 +++++----- LeanPool/IrisAlgebra/Algebra/Updates.lean | 92 ++++++++++++----------- 2 files changed, 72 insertions(+), 61 deletions(-) diff --git a/LeanPool/IrisAlgebra/Algebra/UPred.lean b/LeanPool/IrisAlgebra/Algebra/UPred.lean index 1e8ebe08ab..ea13b487b0 100644 --- a/LeanPool/IrisAlgebra/Algebra/UPred.lean +++ b/LeanPool/IrisAlgebra/Algebra/UPred.lean @@ -26,47 +26,50 @@ https://leanprover.zulipchat.com/#narrow/channel/490604-iris-lean/topic/Bi-entai -/ /-- A resource together with its validity at one step index. -/ @[ext] -structure ValidAt (M : Type _) [UORA M] (n : Nat) where +structure ValidAt (M : Type _) [OFE M] [Validity M] (n : Nat) where /-- The underlying valid resource. -/ val : M property : ✓{n} val -instance {M : Type _} [UORA M] {n : Nat} : CoeOut (ValidAt M n) M where +instance {M : Type _} [OFE M] [Validity M] {n : Nat} : CoeOut (ValidAt M n) M where coe := (·.val) /-- View a valid resource at an earlier step index. -/ -def ValidAt.le {M : Type _} [UORA M] {n m : Nat} (Hle : m ≤ n) : ValidAt M n → ValidAt M m := +def ValidAt.le {M : Type _} [OFE M] [Validity M] {n m : Nat} (Hle : m ≤ n) : + ValidAt M n → ValidAt M m := fun v => ⟨v.val, validN_of_le Hle v.property⟩ @[simp] -theorem ValidAt.le_val {M : Type _} [UORA M] {n m : Nat} {Hle : m ≤ n} {v : ValidAt M n} : +theorem ValidAt.le_val {M : Type _} [OFE M] [Validity M] {n m : Nat} + {Hle : m ≤ n} {v : ValidAt M n} : (v.le Hle).val = v.val := by rfl @[simp] -theorem ValidAt.le_rfl {M : Type _} [UORA M] {n : Nat} {Hle : n ≤ n} {v : ValidAt M n} : +theorem ValidAt.le_rfl {M : Type _} [OFE M] [Validity M] {n : Nat} {Hle : n ≤ n} {v : ValidAt M n} : v.le Hle = v := by rfl /-- The data of a UPred object is an indexed proposition over M (Bundled version) -/ @[ext] -structure UPred (M : Type _) [UORA M] where +structure UPred (M : Type _) [OFE M] [Validity M] [Ordered M] where /-- The proposition asserted at a step index and valid resource. -/ holds : (n : Nat) → ValidAt M n → Prop mono {n1 n2} {x1 : ValidAt M n1} {x2 : ValidAt M n2} : holds n1 x1 → (x1 : M) ≼ₒ{n2} (x2 : M) → (Hle : n2 ≤ n1) → holds n2 x2 /-- Evaluate a predicate with validity supplied as a separate proof. -/ -def UPred.holdsUnpacked {M : Type _} [UORA M] (P : UPred M) (n : Nat) (x : M) (Hx : ✓{n} x) : - Prop := +def UPred.holdsUnpacked {M : Type _} [OFE M] [Validity M] [Ordered M] + (P : UPred M) (n : Nat) (x : M) (Hx : ✓{n} x) : Prop := P.holds n ⟨x, Hx⟩ -theorem UPred.mono_unpacked {M : Type _} [UORA M] (P : UPred M) {n1 n2 : Nat} {x1 x2 : M} +theorem UPred.mono_unpacked {M : Type _} [OFE M] [Validity M] [Ordered M] + (P : UPred M) {n1 n2 : Nat} {x1 x2 : M} (Hx1 : ✓{n1} x1) (Hx2 : ✓{n2} x2) (HP : P.holdsUnpacked n1 x1 Hx1) (Hxle : x1 ≼ₒ{n2} x2) (Hle : n2 ≤ n1) : P.holdsUnpacked n2 x2 Hx2 := P.mono HP Hxle Hle /-- The definition of UPred is equivalent to separately proving pointwise down-closure, non-expansivity, and monotonicity. -/ -theorem uPred_alt {M : Type _} [UORA M] (P : Nat → M → Prop) : +theorem uPred_alt {M : Type _} [OFE M] [Ordered M] [OrderRefl M] (P : Nat → M → Prop) : (∀ {n1 n2} {x1 x2 : M}, P n1 x1 → x1 ≼ₒ{n1} x2 → n2 ≤ n1 → P n2 x2) ↔ ((∀ {x : M} {n1 n2}, n2 ≤ n1 → P n1 x → P n2 x) ∧ (∀ {n} {x1 x2 : M}, x1 ≡{n}≡ x2 → ∀ m, m ≤ n → (P m x1 ↔ P m x2)) ∧ @@ -81,14 +84,16 @@ theorem uPred_alt {M : Type _} [UORA M] (P : Nat → M → Prop) : · refine fun ⟨Hdc, _, Hmono⟩ n1 n2 x1 x2 HP Hinc Hle => ?_ exact Hmono (ordN_of_ordN_le Hle Hinc) n2 (Nat.le_refl _) (Hdc Hle HP) -instance [UORA M] : Inhabited (UPred M) := ⟨fun _ _ => True, fun _ _ _ => ⟨⟩⟩ +instance [OFE M] [Validity M] [Ordered M] : Inhabited (UPred M) := + ⟨fun _ _ => True, fun _ _ _ => ⟨⟩⟩ -instance [UORA M] : CoeFun (UPred M) (fun _ => (n : Nat) → ValidAt M n → Prop) where +instance [OFE M] [Validity M] [Ordered M] : + CoeFun (UPred M) (fun _ => (n : Nat) → ValidAt M n → Prop) where coe x := x.holds section UPred -variable [UORA M] +variable [OFE M] [Validity M] [Ordered M] open UPred @@ -105,16 +110,16 @@ instance : OFE (UPred M) where dist_lt Hdist Hlt _ _ Hle Hvalid := Hdist _ _ (Nat.le_trans Hle (Nat.le_of_succ_le Hlt)) Hvalid -theorem uPred_ne {P : UPred M} {n} {m₁ m₂ : ValidAt M n} (H : (m₁ : M) ≡{n}≡ (m₂ : M)) : P n m₁ ↔ - P n m₂ := +theorem uPred_ne [OrderRefl M] {P : UPred M} {n} {m₁ m₂ : ValidAt M n} + (H : (m₁ : M) ≡{n}≡ (m₂ : M)) : P n m₁ ↔ P n m₂ := ⟨fun H' => P.mono H' H.to_ordN .refl, fun H' => P.mono H' H.symm.to_ordN .refl⟩ -theorem uPred_holds_ne {P Q : UPred M} {n₁ n₂} {x : M} +theorem uPred_holds_ne [OrderRefl M] {P Q : UPred M} {n₁ n₂} {x : M} (HPQ : P ≡{n₂}≡ Q) (Hn : n₂ ≤ n₁) (Hx : ✓{n₂} x) (Hx' : ✓{n₁} x) (HQ : Q n₁ ⟨x, Hx'⟩) : P n₂ ⟨x, Hx⟩ := (HPQ _ _ .refl Hx).mpr (Q.mono HQ .rfl Hn) -instance : IsCOFE (UPred M) where +instance [OrderRefl M] : IsCOFE (UPred M) where compl c := { holds n x := ∀ n', (Hle : n' ≤ n) → (c n') n' (x.le Hle) mono {n1 n2 x1 x2 HP Hx12 Hn12 n3 Hn23} := by @@ -132,7 +137,7 @@ abbrev UPredOF (F : (∀ (α : Type _) (β : Type _), [Iris.COFE α] → [Iris.C fun A B _ _ => UPred (F B A) /-- Pull a monotone step-indexed predicate back along a resource morphism. -/ -def uPredMap [UORA α] [UORA β] (f : β -C> α) : UPred α -n> UPred β := by +def uPredMap [ORA α] [ORA β] (f : β -C> α) : UPred α -n> UPred β := by refine ⟨fun P => ⟨fun n x => P n ⟨(f x.val), f.validN x.property⟩, ?_⟩, ⟨?_⟩⟩ · intro n1 n2 x1 x2 HP Hm Hn exact P.mono HP (f.monoN_ord Hm) Hn diff --git a/LeanPool/IrisAlgebra/Algebra/Updates.lean b/LeanPool/IrisAlgebra/Algebra/Updates.lean index f3b860521a..a1198552e2 100644 --- a/LeanPool/IrisAlgebra/Algebra/Updates.lean +++ b/LeanPool/IrisAlgebra/Algebra/Updates.lean @@ -19,19 +19,21 @@ Copyright (c) The Iris-Lean Contributors. namespace Iris /-- A frame-preserving update to some resource satisfying a predicate. -/ -def UpdateP [ORA α] (x : α) (P : α → Prop) := ∀ n mz, ✓{n} (x •? mz) → ∃ y, P y ∧ ✓{n} (y •? mz) +def UpdateP [OFE α] [Op α] [Validity α] (x : α) (P : α → Prop) := + ∀ n mz, ✓{n} (x •? mz) → ∃ y, P y ∧ ✓{n} (y •? mz) /-- Notation for a frame-preserving update satisfying a predicate. -/ infixr:50 " ~~>: " => UpdateP /-- A frame-preserving update to a specified resource. -/ -def Update [ORA α] (x y : α) := ∀ n mz, ✓{n} (x •? mz) → ✓{n} (y •? mz) +def Update [OFE α] [Op α] [Validity α] (x y : α) := ∀ n mz, ✓{n} (x •? mz) → ✓{n} (y •? mz) /-- Notation for a frame-preserving update to a specified resource. -/ infixr:50 " ~~> " => Update section Updates open ORA -variable [ORA α] [ORA β] (f : α → β) (g : β → α) +section PrimitiveUpdates +variable [OFE α] [Op α] [Validity α] [OFE β] [Op β] [Validity β] (f : α → β) (g : β → α) theorem Update.of_updateP {x y : α} (h : x ~~>: (y = ·)) : x ~~> y := fun n mz v => let ⟨_, e, v⟩ := (h n mz v); e ▸ v @@ -89,6 +91,49 @@ theorem UpdateP.op' {P Q : α → Prop} {x y : α} (uxp : x ~~>: P) (uyq : y ~~> theorem Update.op {x₁ x₂ y₁ y₂ : α} (xy₁ : x₁ ~~> y₁) (xy₂ : x₂ ~~> y₂) : x₁ • x₂ ~~> y₁ • y₂ := .of_updateP <| .op (.of_update xy₁) (.of_update xy₂) fun _ _ ez ew => ez ▸ ew ▸ rfl +/-! ## Isomorphism -/ +theorem UpdateP.iso + (gf : ∀ x, g (f x) = x) + (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) + (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) + (uyp : y ~~>: P) + (pq : ∀ y', P y' → Q (g y')) : + g y ~~>: Q := by + intro n mz v + have : ✓{n} y •? Option.map f mz := + match mz with + | none => (g_validN n _).mp v + | some z => + have : g y • z = g (y • f z) := by rw [g_op, gf] + (g_validN n _).mp (validN_ne this.dist v) + have ⟨x, px, vx⟩ := uyp n (mz.map f) this + have : g (x •? Option.map f mz) = g x •? mz := + match mz with + | none => rfl + | some z => by simp only [Option.map_some, optionalOp, g_op, gf] + exact ⟨g x, pq x px, validN_ne this.dist ((g_validN n _).mpr vx)⟩ + +theorem UpdateP.iso' + (gf : ∀ x, g (f x) = x) + (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) + (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) + (uyp : y ~~>: P) : + g y ~~>: fun x ↦ ∃ y, x = g y ∧ P y := + .iso f g gf g_op g_validN uyp fun z pz => ⟨z, rfl, pz⟩ + +/-! ## Lift -/ +theorem Update.lift_updateP (x y : β) + (H : ∀ P, x ~~>: P → g x ~~>: fun a' ↦ ∃ b', a' = g b' ∧ P b') + (uxy : x ~~> y) : g x ~~> g y := + .of_updateP fun n mz v => + have ⟨z, hz, vz⟩ := H _ (.of_update uxy) n mz v + have hz : z = g y := by simp only [exists_eq_right'] at hz ⊢; exact hz + ⟨z, hz.symm, vz⟩ + +end PrimitiveUpdates + +variable [ORA α] [ORA β] + theorem Update.op_l {x y : α} : x • y ~~> x := fun _ _ => validN_op_opM_left theorem Update.op_r {x y : α} : x • y ~~> y := fun _ _ => validN_op_opM_right @@ -102,7 +147,7 @@ theorem Update.included {x y : α} : x ≼ y → y ~~> x := theorem Update.valid0 {x y : α} : (✓{0} x → x ~~> y) → x ~~> y := fun h n mz v => h (valid0_of_validN (validN_opM v)) n mz v -/-! ## Frame preserving updates for total and discete CMRAs -/ +/-! ## Frame preserving updates for total and discrete CMRAs -/ theorem UpdateP.total [IsTotal α] : x ~~>: P ↔ ∀ (n : Nat) (z : α), ✓{n} (x • z) → ∃ y, P y ∧ ✓{n} (y • z) where mp uxp := fun n z v => uxp n (some z) v @@ -156,45 +201,6 @@ theorem Update.discrete_total [Discrete α] [IsTotal α] : -- transported by `transpAp`, so these update lemmas are subsumed by rewriting along the -- equality and using the plain `updateP` API. -/-! ## Isomorphism -/ -theorem UpdateP.iso - (gf : ∀ x, g (f x) = x) - (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) - (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) - (uyp : y ~~>: P) - (pq : ∀ y', P y' → Q (g y')) : - g y ~~>: Q := by - intro n mz v - have : ✓{n} y •? Option.map f mz := - match mz with - | none => (g_validN n _).mp v - | some z => - have : g y • z = g (y • f z) := by rw [g_op, gf] - (g_validN n _).mp (validN_ne this.dist v) - have ⟨x, px, vx⟩ := uyp n (mz.map f) this - have : g (x •? Option.map f mz) = g x •? mz := - match mz with - | none => rfl - | some z => by simp only [Option.map_some, optionalOp, g_op, gf] - exact ⟨g x, pq x px, validN_ne this.dist ((g_validN n _).mpr vx)⟩ - -theorem UpdateP.iso' - (gf : ∀ x, g (f x) = x) - (g_op : ∀ y1 y2, g (y1 • y2) = g y1 • g y2) - (g_validN : ∀ n y, ✓{n} (g y) ↔ ✓{n} y) - (uyp : y ~~>: P) : - g y ~~>: fun x ↦ ∃ y, x = g y ∧ P y := - .iso f g gf g_op g_validN uyp fun z pz => ⟨z, rfl, pz⟩ - -/-! ## Lift -/ -theorem Update.lift_updateP (x y : β) - (H : ∀ P, x ~~>: P → g x ~~>: fun a' ↦ ∃ b', a' = g b' ∧ P b') - (uxy : x ~~> y) : g x ~~> g y := - .of_updateP fun n mz v => - have ⟨z, hz, vz⟩ := H _ (.of_update uxy) n mz v - have hz : z = g y := by simp only [exists_eq_right'] at hz ⊢; exact hz - ⟨z, hz.symm, vz⟩ - /-! ## Product -/ theorem UpdateP.prod {P : α → Prop} {Q : β → Prop} {R : α × β → Prop} {x : α × β} (uxp : x.fst ~~>: P) (uxq : x.snd ~~>: Q) (pq : ∀ a b, P a → Q b → R (a, b)) :