-- src/Iris/BI/DerivedLaws.lean

import Iris.BI.Classes

import Iris.BI.Extensions

import Iris.BI.BI

import Iris.Std.Classes

import Iris.Std.Rewrite

import Iris.Std.TC

namespace Iris.BI

open Iris.Std BI

-- Repository definitions used:
content: macro "∃" xs:explicitBinders ", " b:term : term => do
  return ⟨← expandExplicitBinders ``BIBase.exists xs b⟩

content: scoped notation:40 x " ≡{" n "}≡ " y:41 => OFE.Dist n x y

syntax:max "<pers> " term:40 : term

content: macro:25 P:term:29 " ⊢ " Q:term:25 : term => ``(BIBase.Entails iprop($P) iprop($Q))

delab_rule BIBase.Entails
  | `($_ $P $Q) => do ``($(← unpackIprop P) ⊢ $(← unpackIprop Q))

content: macro:25 P:term:29 " ⊣⊢ " Q:term:29 : term => ``(BiEntails iprop($P) iprop($Q))

delab_rule BIBase.Entails
  | `($_ iprop(emp) $P) => do ``(⊢ $(← unpackIprop P))

delab_rule BIBase.BiEntails
  | `($_ $P $Q) => do ``($(← unpackIprop P) ⊣⊢ $(← unpackIprop Q))

syntax "⌜" term "⌝" : term

syntax:max "▷ " term:40 : term

syntax:max "<affine> " term:40 : term

syntax:max "□ " term:40 : term

content: macro:max "iprop(" P:term " : " t:term ")" : term => `((iprop($P) : $t))

syntax:max "iprop(" term ")" : term

syntax:max "<absorb> " term:40 : term

content: macro_rules
  | `(iprop(term($t))) => pure t
  | `(iprop($t))       => pure t

content: macro_rules
  | `(iprop(($P)))                  => ``((iprop($P)))
  | `(iprop(if $c then $t else $e)) => ``(if $c then iprop($t) else iprop($e))
  | `(iprop(($P : $t)))             => ``((iprop($P) : $t))

content: macro_rules
  | `(iprop(emp))       => ``(BIBase.emp)
  | `(iprop(⌜$φ⌝))      => ``(BIBase.pure $φ)
  | `(iprop($P ∧ $Q))   => ``(BIBase.and iprop($P) iprop($Q))
  | `(iprop($P ∨ $Q))   => ``(BIBase.or iprop($P) iprop($Q))
  | `(iprop($P → $Q))   => ``(BIBase.imp iprop($P) iprop($Q))
  | `(iprop(∃ $xs, $Ψ)) => do expandExplicitBinders ``BIBase.exists xs (← ``(iprop($Ψ)))
  | `(iprop($P ∗ $Q))   => ``(BIBase.sep iprop($P) iprop($Q))
  | `(iprop($P -∗ $Q))  => ``(BIBase.wand iprop($P) iprop($Q))
  | `(iprop(<pers> $P)) => ``(BIBase.persistently iprop($P))
  | `(iprop(▷ $P))      => ``(BIBase.later iprop($P))

delab_rule BIBase.emp
  | `($_) => ``(iprop($(mkIdent `emp)))
delab_rule BIBase.pure
  | `($_ $φ) => ``(iprop(⌜$φ⌝))
delab_rule BIBase.and
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) ∧ $(← unpackIprop Q)))
delab_rule BIBase.or
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) ∨ $(← unpackIprop Q)))
delab_rule BIBase.imp
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) → $(← unpackIprop Q)))
delab_rule BIBase.forall
  | `($_ fun $x:ident => iprop(∀ $y:ident $[$z:ident]*, $Ψ)) => do
    ``(iprop(∀ $x:ident $y:ident $[$z:ident]*, $Ψ))
  | `($_ fun $x:ident => $Ψ) => do ``(iprop(∀ $x:ident, $(← unpackIprop Ψ)))
delab_rule BIBase.exists
  | `($_ fun $x:ident => iprop(∃ $y:ident $[$z:ident]*, $Ψ)) => do
    ``(iprop(∃ $x:ident $y:ident $[$z:ident]*, $Ψ))
  | `($_ fun $x:ident => $Ψ) => do ``(iprop(∃ $x:ident, $(← unpackIprop Ψ)))
delab_rule BIBase.sep
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) ∗ $(← unpackIprop Q)))
delab_rule BIBase.wand
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) -∗ $(← unpackIprop Q)))
delab_rule BIBase.persistently
  | `($_ $P) => do ``(iprop(<pers> $(← unpackIprop P)))

delab_rule BIBase.pure
  | `($_ True) => ``(iprop($(mkIdent `True)))
  | `($_ False) => ``(iprop($(mkIdent `False)))
delab_rule BIBase.imp
  | `($_ $P iprop(False)) => do ``(iprop(¬$(← unpackIprop P)))

content: macro_rules
  | `(iprop(∀ _%$tk, $Ψ)) => ``(BIBase.forall (fun _%$tk => iprop($Ψ)))

content: macro_rules
  | `(iprop(∀ $x:ident, $Ψ)) => ``(BIBase.forall (fun $x => iprop($Ψ)))

content: macro_rules
  | `(iprop(∀ (_%$tk : $t), $Ψ)) => ``(BIBase.forall (fun (_%$tk : $t) => iprop($Ψ)))
  | `(iprop(∀ (_%$tk $xs* : $t), $Ψ)) =>
    ``(BIBase.forall (fun (_%$tk : $t) => iprop(∀ ($xs* : $t), $Ψ)))

content: macro_rules
  | `(iprop(∀ ($x:ident : $t), $Ψ)) => ``(BIBase.forall (fun ($x : $t) => iprop($Ψ)))
  | `(iprop(∀ ($x:ident $xs* : $t), $Ψ)) =>
    ``(BIBase.forall (fun ($x : $t) => iprop(∀ ($xs* : $t), $Ψ)))

content: macro_rules
  | `(iprop(∀ {_%$tk : $t}, $Ψ)) =>
    ``(BIBase.forall (fun {_%$tk : $t}  => iprop($Ψ)))
  | `(iprop(∀ {_%$tk $xs* : $t}, $Ψ)) =>
    ``(BIBase.forall (fun {_%$tk : $t}  => iprop(∀ {$xs* : $t}, $Ψ)))

content: macro_rules
  | `(iprop(∀ {$x:ident : $t}, $Ψ)) =>
    ``(BIBase.forall (fun ($x : $t) => iprop($Ψ)))
  | `(iprop(∀ {$x:ident $xs* : $t}, $Ψ)) =>
    ``(BIBase.forall (fun ($x : $t) => iprop(∀ {$xs* : $t}, $Ψ)))

content: macro_rules
  | `(iprop(∀ $x $y $xs*, $Ψ)) => ``(iprop(∀ $x, ∀ $y $xs*, $Ψ))

content: macro_rules
  | `(iprop(True))  => ``(BIBase.pure True)
  | `(iprop(False)) => ``(BIBase.pure False)
  | `(iprop(¬$P))   => ``(iprop($P → False))

content: macro_rules
  | `(iprop($P ↔ $Q))   => ``(iff iprop($P) iprop($Q))
  | `(iprop($P ∗-∗ $Q)) => ``(wandIff iprop($P) iprop($Q))

delab_rule iff
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) ↔ $(← unpackIprop Q)))
delab_rule wandIff
  | `($_ $P $Q) => do ``(iprop($(← unpackIprop P) ∗-∗ $(← unpackIprop Q)))

content: macro_rules
  | `(iprop(<affine> $P)) => ``(affinely iprop($P))
  | `(iprop(<absorb> $P)) => ``(absorbingly iprop($P))

delab_rule affinely
  | `($_ $P) => do ``(iprop(<affine> $(← unpackIprop P)))
delab_rule absorbingly
  | `($_ $P) => do ``(iprop(<absorb> $(← unpackIprop P)))

content: macro_rules
  | `(iprop(□ $P)) => ``(intuitionistically iprop($P))

delab_rule intuitionistically
  | `($_ $P) => do ``(iprop(□ $(← unpackIprop P)))

content: macro_rules
  | `(iprop(<pers>?$p $P))   => ``(persistentlyIf $p iprop($P))
  | `(iprop(<affine>?$p $P)) => ``(affinelyIf $p iprop($P))
  | `(iprop(<absorb>?$p $P)) => ``(absorbinglyIf $p iprop($P))
  | `(iprop(□?$p $P))        => ``(intuitionisticallyIf $p iprop($P))

delab_rule persistentlyIf
  | `($_ $p $P) => do ``(iprop(<pers>?$p $(← unpackIprop P)))
delab_rule affinelyIf
  | `($_ $p $P) => do ``(iprop(<affine>?$p $(← unpackIprop P)))
delab_rule absorbinglyIf
  | `($_ $p $P) => do ``(iprop(<absorb>?$p $(← unpackIprop P)))
delab_rule intuitionisticallyIf
  | `($_ $p $P) => do ``(iprop(□?$p $(← unpackIprop P)))

content: macro_rules
  | `(iprop(▷^[$n] $P))   => ``(laterN $n iprop($P))

delab_rule laterN
  | `($_ $n $P) => do ``(iprop(▷^[$n] $(← unpackIprop P)))

content: macro_rules
  | `(iprop(◇ $P)) => ``(except0 iprop($P))

delab_rule except0
  | `($_ $P) => do ``(iprop(◇ $(← unpackIprop P)))

content: class BIBase (PROP : Type u) where
  Entails : PROP → PROP → Prop
  emp : PROP
  pure : Prop → PROP
  and : PROP → PROP → PROP
  or : PROP → PROP → PROP
  imp : PROP → PROP → PROP
  sForall : (PROP → Prop) → PROP
  sExists : (PROP → Prop) → PROP
  sep : PROP → PROP → PROP
  wand : PROP → PROP → PROP
  persistently : PROP → PROP
  later : PROP → PROP

content: class BI (PROP : Type _) extends COFE PROP, BI.BIBase PROP where
  Equiv P Q := P ⊣⊢ Q

  entails_preorder : Preorder Entails
  equiv_iff {P Q : PROP} : (P ≡ Q) ↔ P ⊣⊢ Q := by admit /- proof elided -/

content: class BILoeb (PROP : Type _) [BI PROP] where
  loeb_weak {P : PROP} : (▷ P ⊢ P) → True ⊢ P

content: def liftRel (R : α → β → Prop) (A : α → Prop) (B : β → Prop) : Prop :=
  (∀ a, A a → ∃ b, B b ∧ R a b) ∧ (∀ b, B b → ∃ a, A a ∧ R a b)

content: class Preorder (R : Relation α) extends Reflexive R, Transitive R

content: class Reflexive (R : Relation α) where
  refl {x : α} : R x x

content: abbrev Relation (α : Type _) := α → α → Prop

content: class Transitive (R : Relation α) where
  trans {x y z : α} : R x y → R y z → R x z

content: 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₂

content: instance OFE.ContractiveHom.fixpoint_ne [COFE α] [Inhabited α] :
    NonExpansive (ContractiveHom.fixpoint (α := α)) where
  ne n f1 f2 H := by admit /- proof elided -/

content: @[ext] structure ContractiveHom (α β : Type _) [OFE α] [OFE β] extends Hom α β where
  [contractive : Contractive f]
  ne := ne_of_contractive f

content: instance OFE.Option.some.ne [OFE α] : OFE.NonExpansive (some : α → Option α) := ⟨fun _ _ _ => id⟩

content: instance Option.merge_ne [OFE α] {op : α → α → α} [NonExpansive₂ op] :
    NonExpansive₂ (Option.merge op) where
  ne n x1 x2 Hx y1 y2 Hy := by admit /- proof elided -/

content: class NonExpansive [OFE α] [OFE β] (f : α → β) where
  ne : ∀ ⦃n x₁ x₂⦄, x₁ ≡{n}≡ x₂ → f x₁ ≡{n}≡ f x₂

content: instance COFE.OFunctor.constOF_RFunctor [CMRA B] : RFunctor (constOF B) where
  map f g := by admit /- proof elided -/

content: class IsCOFE (α : Type _) [OFE α] where
  compl : Chain α → α
  conv_compl {c : Chain α} : compl c ≡{n}≡ c n

content: structure Chain (α : Type _) [OFE α] where
  chain : Nat → α
  cauchy : n ≤ i → chain i ≡{n}≡ chain n

content: class Affine [BI PROP] (P : PROP) where
  affine : P ⊢ emp

content: class LawfulBigOp (f : PROP → PROP → PROP) (unit : outParam PROP)
    (eq : outParam (PROP → PROP → Prop)) where
  refl : eq a a
  symm : eq a b → eq b a
  trans : eq a b → eq b c → eq a c
  comm : eq (f a b) (f b a)
  assoc : eq (f (f a b) c) (f a (f b c))
  left_id : eq (f unit a) a
  congr_l : eq a a' → eq (f a b) (f a' b)

content: def intuitionistically [BIBase PROP] (P : PROP) : PROP := iprop(<affine> <pers> P)

content: def bigAnd [BIBase PROP] (Ps : List PROP) : PROP := bigOp and iprop(True) Ps

content: def bigOp (f : PROP → PROP → PROP) (unit : PROP) : List PROP → PROP
  | []      => unit
  | [P]     => P
  | P :: Ps => f P (bigOp f unit Ps)

content: def absorbingly [BIBase PROP] (P : PROP) : PROP := iprop(True ∗ P)

content: structure BiEntails [BIBase PROP] (P Q : PROP) where
  mp : P ⊢ Q
  mpr : Q ⊢ P

content: def persistentlyIf [BIBase PROP] (p : Bool) (P : PROP) : PROP := iprop(if p then <pers> P else P)

content: def intuitionisticallyIf [BIBase PROP] (p : Bool) (P : PROP) : PROP := iprop(if p then □ P else P)

content: def bigSep [BIBase PROP] (Ps : List PROP) : PROP := bigOp sep iprop(emp) Ps

content: def affinely    [BIBase PROP] (P : PROP) : PROP := iprop(emp ∧ P)

content: def bigOr [BIBase PROP] (Ps : List PROP) : PROP := bigOp or iprop(False) Ps

content: def absorbinglyIf [BIBase PROP] (p : Bool) (P : PROP) : PROP := iprop(if p then <absorb> P else P)

content: def affinelyIf [BIBase PROP] (p : Bool) (P : PROP) : PROP := iprop(if p then <affine> P else P)

content: def wandIff [BIBase PROP] (P Q : PROP) : PROP := iprop((P -∗ Q) ∧ (Q -∗ P))

content: scoped infix:40 " ≡ " => OFE.Equiv

content: scoped notation:40 x " ≡{" n "}≡ " y:41 => OFE.Dist n x y

content: infixr:25 " -c> " => ContractiveHom

content: notation:40 "[∧] " Ps:max => bigAnd Ps

content: notation:40 "[∨] " Ps:max => bigOr Ps

content: notation:40 "[∗] " Ps:max => bigSep Ps

-- Repository lemmas used:
content: theorem Dist.trans [OFE α] {n} {x : α} : x ≡{n}≡ y → y ≡{n}≡ z → x ≡{n}≡ z

content: theorem BIBase.BiEntails.trans [BI PROP] {P Q R : PROP} (h1 : P ⊣⊢ Q) (h2 : Q ⊣⊢ R) : P ⊣⊢ R

content: theorem BIBase.Entails.trans [BI PROP] {P Q R : PROP} (h1 : P ⊢ Q) (h2 : Q ⊢ R) : P ⊢ R

content: theorem Equiv.trans [OFE α] {x : α} : x ≡ y → y ≡ z → x ≡ z

content: theorem equiv_eqv [ofe : OFE α] : Equivalence ofe.Equiv

content: @[symm] theorem Dist.symm [OFE α] {n} {x : α} : x ≡{n}≡ y → y ≡{n}≡ x

content: @[simp, refl] theorem Dist.rfl [OFE α] {n} {x : α} : x ≡{n}≡ x

content: theorem DistLater.trans [OFE α] {n} {x : α} (h1 : DistLater n x y) (h2 : DistLater n y z) :
    DistLater n x z

-- Local definitions used:

-- Local lemmas used:
content: theorem and_elim_l' [BI PROP] {P Q R : PROP} (h : P ⊢ R) : P ∧ Q ⊢ R

content: theorem and_elim_r' [BI PROP] {P Q R : PROP} (h : Q ⊢ R) : P ∧ Q ⊢ R

content: theorem and_symm [BI PROP] {P Q : PROP} : P ∧ Q ⊢ Q ∧ P

content: theorem imp_intro' [BI PROP] {P Q R : PROP} (h : Q ∧ P ⊢ R) : P ⊢ Q → R

content: theorem imp_elim' [BI PROP] {P Q R : PROP} (h : Q ⊢ P → R) : P ∧ Q ⊢ R

content: theorem imp_elim_l [BI PROP] {P Q : PROP} : (P → Q) ∧ P ⊢ Q

content: theorem imp_elim_r [BI PROP] {P Q : PROP} : P ∧ (P → Q) ⊢ Q

content: theorem true_intro [BI PROP] {P : PROP} : P ⊢ True

content: @[rw_mono_rule]
theorem and_mono [BI PROP] {P P' Q Q' : PROP} (h1 : P ⊢ Q) (h2 : P' ⊢ Q') : P ∧ P' ⊢ Q ∧ Q'

content: theorem and_mono_l [BI PROP] {P P' Q : PROP} (h : P ⊢ P') : P ∧ Q ⊢ P' ∧ Q

content: theorem and_mono_r [BI PROP] {P Q Q' : PROP} (h : Q ⊢ Q') : P ∧ Q ⊢ P ∧ Q'

content: @[rw_mono_rule]
theorem and_congr [BI PROP] {P P' Q Q' : PROP} (h1 : P ⊣⊢ Q) (h2 : P' ⊣⊢ Q') : P ∧ P' ⊣⊢ Q ∧ Q'

content: theorem and_congr_r [BI PROP] {P Q Q' : PROP} (h : Q ⊣⊢ Q') : P ∧ Q ⊣⊢ P ∧ Q'

content: theorem and_self [BI PROP] {P : PROP} : P ∧ P ⊣⊢ P

content: theorem and_comm [BI PROP] {P Q : PROP} : P ∧ Q ⊣⊢ Q ∧ P

content: theorem and_assoc [BI PROP] {P Q R : PROP} : (P ∧ Q) ∧ R ⊣⊢ P ∧ Q ∧ R

content: theorem sep_mono_l [BI PROP] {P P' Q : PROP} (h : P ⊢ P') : P ∗ Q ⊢ P' ∗ Q

content: theorem sep_comm [BI PROP] {P Q : PROP} : P ∗ Q ⊣⊢ Q ∗ P

content: theorem sep_emp [BI PROP] {P : PROP} : P ∗ emp ⊣⊢ P

content: theorem true_sep_2 [BI PROP] {P : PROP} : P ⊢ True ∗ P

content: theorem wand_elim' [BI PROP] {P Q R : PROP} (h : Q ⊢ P -∗ R) : P ∗ Q ⊢ R

content: theorem wand_elim_r [BI PROP] {P Q : PROP} : P ∗ (P -∗ Q) ⊢ Q

content: theorem pure_elim [BI PROP] (φ : Prop) {Q R : PROP} (h1 : Q ⊢ ⌜φ⌝) (h2 : φ → Q ⊢ R) : Q ⊢ R

content: theorem pure_elim_l [BI PROP] {φ : Prop} {Q R : PROP} (h : φ → Q ⊢ R) : ⌜φ⌝ ∧ Q ⊢ R

content: theorem pure_elim_r [BI PROP] {φ : Prop} {Q R : PROP} (h : φ → Q ⊢ R) : Q ∧ ⌜φ⌝ ⊢ R

content: @[rw_mono_rule]
theorem affinely_congr [BI PROP] {P P' : PROP} (h : P ⊣⊢ P') :
    <affine> P ⊣⊢ <affine> P'

content: theorem affinely_elim [BI PROP] {P : PROP} : <affine> P ⊢ P

content: @[rw_mono_rule]
theorem affinely_mono [BI PROP] {P Q : PROP} : (P ⊢ Q) → <affine> P ⊢ <affine> Q

content: theorem absorbingly_intro [BI PROP] {P : PROP} : P ⊢ <absorb> P

content: theorem persistently_absorb_r [BI PROP] {P Q : PROP} : P ∗ <pers> Q ⊢ <pers> Q

content: theorem absorbingly_persistently [BI PROP] {P : PROP} : <absorb> <pers> P ⊣⊢ <pers> P

content: theorem persistently_and [BI PROP] {P Q : PROP} : <pers> (P ∧ Q) ⊣⊢ <pers> P ∧ <pers> Q

content: theorem persistently_emp_intro [BI PROP] {P : PROP} : P ⊢ <pers> emp

content: theorem persistently_affinely [BI PROP] {P : PROP} : <pers> <affine> P ⊣⊢ <pers> P

content: theorem intuitionistically_elim [BI PROP] {P : PROP} : □ P ⊢ P

content: theorem persistently_idem [BI PROP] {P : PROP} : <pers> <pers> P ⊣⊢ <pers> P

content: @[rw_mono_rule]
theorem intuitionistically_mono [BI PROP] {P Q : PROP} (h : P ⊢ Q) : □ P ⊢ □ Q

content: theorem intuitionistically_idem [BI PROP] {P : PROP} : □ □ P ⊣⊢ □ P

content: theorem persistently_of_intuitionistically [BI PROP] {P : PROP} : □ P ⊢ <pers> P

content: theorem later_impl [BI PROP] {P Q : PROP} : ▷ (P → Q) ⊢ ▷ P → ▷ Q

content: theorem entails_impl_true [BI PROP] {P Q : PROP} :
    (P ⊢ Q) ↔ iprop((True : PROP) ⊢ (P → Q))

content: theorem loeb [BI PROP] [BILoeb PROP] {P : PROP} : (▷ P → P) ⊢ P

-- Target theorem and proof:
theorem loeb_wand_intuitionistically [BI PROP] [BILoeb PROP] {P : PROP} :
    □ (□ ▷ P -∗ P) ⊢ P
:= by
  refine .trans ?_ intuitionistically_elim
  refine .trans ?_ loeb
  refine imp_intro' ?_
  refine (and_mono (later_mono persistently_of_intuitionistically) .rfl).trans ?_
  refine (and_mono later_persistently.mp .rfl).trans ?_
  refine persistently_and_intuitionistically_sep_l.mp.trans ?_
  refine (sep_mono intuitionistically_idem.mpr .rfl).trans ?_
  exact intuitionistically_sep_2.trans (intuitionistically_mono wand_elim_r)