import data.set
import tactic.linarith

/-!
# First-order predicate logic

In this file we define the syntax of intuitionistic first-order logic and a natural deduction
proof calculus.

## Main result

- `formula σ`      : the definition of first-order formulas over a signature σ
- `proof_term σ`   : the definition of proof terms of natural deduction over a signature σ

## Notations

We define the following notations for lifts and substitutions:

- `X ↑ m ＠ i` for `lift X s k`  where `X` can be a term or a formula .
- `X[ s ⁄ k ]` for `subst X s k` where `X` can be a term or a formula .
- `Γ ⊢ φ` for `proof_term Γ φ`

We use the following local notations

- `>>` for `set.insert`

## Notes

We wrote comments whenever we felt like a topic wasn't really covered by the literature referenced.
This includes some definitions that are not part of the actual implementation but simplify talking about it.

## References

* [N.G. de Bruijn, *Lambda calculus notation with nameless dummies*] [DB72]
  -- the original paper describing de Bruijn indices
* [J.M. Han, F.van Doorn, *A Formal Proof of the Independence of the Continuum Hypothesis*] [HD20]
  -- we followed their implementation of first-order logic using "partially applied" terms and formulas
  -- See also: https://flypitch.github.io/
* [I. Chiswell, W. Hodges,*Mathematical Logic*] [CH04]
  -- first order logic and natural deduction
* [M. Huth, M. Ryan, *Logic in computer science*] [HR04]
  -- first order logic and natural deduction
* [S. Berghofer, C. Urban, *A Head-to-Head Comparison of de Bruijn Indices and Names*] [BH07]
  -- for a good breakdown of the proof of the substitution lemma `subst_subst`
* https://github.com/coq-community/dblib/blob/master/src/DeBruijn.v
  -- as a good reference on lifting and substitution lemmas for de Bruijn indices
-/

-- use with `simp only with tls`
mk_simp_attribute tls
"Collection of definitions and lemmas for simplifying trivial  combinations of lifts and substitutions."

open nat set
universe variable u

namespace fol
/-- A signature of a first-order logic defining its function and predicate symbols with arities. -/
structure signature : Type (u+1) :=
(func_symb : ℕ → Type u) (pred_symb : ℕ → Type u)

def signature.constants (σ : signature) := σ.func_symb 0

inductive sorry_nothing : ℕ → Type u

def trivial_signature : signature :=
{ func_symb := sorry_nothing, pred_symb := sorry_nothing}

variable (σ : signature.{u})

/-! ### terms -/
/--
  `preterm σ a` is partially applied term of first-order logic over the signature `σ`.
  If applied to `a` terms it becomes a well-formed term.
-/
inductive preterm : ℕ → Type u
| var  (index : ℕ) : preterm 0
| func {arity : ℕ} (f : σ.func_symb arity) : preterm arity
| fapp {arity : ℕ} (t : preterm (arity+1))  (s : preterm 0) : preterm arity

export preterm

prefix `#`:max := preterm.var
@[reducible] def term := preterm σ 0

variable {σ}

namespace term

/-- `lift t m i` increases the index of each `i`-free variable in `t` by `m`. -/
def lift : ∀{a} , preterm σ a → ℕ → ℕ → preterm σ a
| _ #x          m i := #(if i ≤ x then x+m else x)
| _ (func f)    m i := func f
| _ (fapp t s)   m i := fapp (lift t m i) (lift s m i)

end term

-- we use ＠ (U+FF20) instead of the regular @ (U+0040)
notation t ` ↑ `:90 m ` ＠ `:90 i:90  := term.lift t m i

namespace term

-- unfolding lemmas for the simplifier
@[simp, tls] lemma lift_fapp {a} (t : preterm σ (a+1)) (s : preterm σ 0) (m i : ℕ)
  : (fapp t s) ↑ m ＠ i = fapp (t ↑ m ＠ i) (s ↑ m ＠ i) := by refl
@[simp, tls] lemma lift_func {a} (f : σ.func_symb a) (m i : ℕ)
  : (func f) ↑ m ＠ i = func f := by refl

-- lifting of variables by cases for the simplifier
@[simp] lemma lift_var_lt {x m i : ℕ} (H : x < i) : #x ↑ m ＠ i = (#x : term σ)
  := begin unfold lift, rw if_neg (not_le.mpr H), end
@[simp, tls] lemma lift_var_eq {x m}: ((#x ↑ m ＠ x) = (#(x+m) : term σ))
  := begin rw lift, rw if_pos x.le_refl, end
@[simp] lemma lift_var_gt {x m i} (H : i < x) : #x ↑ m ＠ i = (#(x+m) : term σ)
  := begin rw lift, rw if_pos (le_of_lt H), end
@[simp] lemma lift_var_ge {x m i} (H : i ≤ x) : #x ↑ m ＠ i = (#(x+m) : term σ)
  := begin rw lift, rw if_pos H, end
@[simp] lemma lift_var_nge {x m i : ℕ} (H : ¬ i ≤ x) : #x ↑ m ＠ i = (#x : term σ)
  := begin unfold lift, rw if_neg H, end

@[simp, tls] lemma lift_by_0: ∀ {a} (t : preterm σ a) {i}, t ↑ 0 ＠ i = t
| _ #x         i  := by simp[lift]
| _ (func f)   _  := by refl
| _ (fapp f t) _  := begin unfold lift, congr; apply lift_by_0, end

/- Various lifting lemmas. -/

lemma lift_lift: ∀ {a} (t : preterm σ a) (m) {i} (n) {j} (H : j ≤ i),
  (t ↑ m ＠ i) ↑ n ＠ j = (t ↑ n ＠ j) ↑ m ＠ (i+n)
| _ #x          m i n j H   :=
  begin by_cases h₀ : i ≤ x,
    { have h₁ : j ≤ x := le_trans H h₀,
      have h₂ : j ≤ x + m := le_trans h₁ (x.le_add_right m),
      simp[*, add_right_comm], },
    { have h₁ : ¬(i + n ≤  x + n) := begin intro h, exact  h₀ (le_of_add_le_add_right h) end,
      have h₂ : ¬(i + n ≤ x)      := begin intro h, exact h₁ (le_trans h (x.le_add_right n)) end,
      by_cases j ≤ x; simp[*], },
  end
| _ (func f)    _ _ _ _ _      := by refl
| _ (fapp f t)  _ _ _ _ _   := by simp*

lemma lift_lift_reverse {a} (t : preterm σ a) {m i} (n) {j} (H : i + m ≤ j) :
  (t ↑ m ＠ i) ↑ n ＠ j = (t ↑ n ＠ (j-m)) ↑ m ＠ i :=
begin
  have h : i ≤ (j-m) := nat.le_sub_right_of_add_le H,
  have h': m ≤ j := (le_trans (m.le_add_left i) H),
  rw [lift_lift t n m h, nat.sub_add_cancel h'],
end

lemma lift_lift_merge: ∀ {a} (t : preterm σ a) {m i} (n) {j} (H : i ≤ j) (H' : j ≤ i + m),
  (t ↑ m ＠ i) ↑ n ＠ j = t ↑ (m+n) ＠ i
| _ #x         m i n j H H' :=
  begin by_cases h₀ : i ≤ x,
    { have h₁ : j ≤ x + m  := le_trans H' (add_le_add_right h₀ m),
      simp[*, add_assoc], },
    { have h₁ : ¬ (j ≤ x) := (λ h,  h₀ (le_trans H h)),
      simp[*], },
  end
| _ (func f)   _ _ _ _ _ _  := by refl
| _ (fapp t s) _ _ _ _ _ _  := by simp*

lemma lift_by_succ {a} (t : preterm σ a) {m i} : t ↑ (m+1) ＠ i  = (t ↑ 1 ＠ i) ↑ m ＠ i
  := begin rw[lift_lift_merge, one_add], apply le_refl, apply le_succ, end

/--
  `subst t s k` substitutes `s ↑ k ＠ 0` for each variable at `k` in `t` and
  reduces the index of all `k+1`-free variables by `1`.
-/
def subst: ∀{a}, preterm σ a → term σ → ℕ → preterm σ a
| _ #x           s k := if x < k then #x else if k < x then #(x-1) else (s ↑ k ＠ 0)
| _ (func f)     s k := func f
| _ (fapp t₁ t₂) s k := fapp (subst t₁ s k) (subst t₂ s k)

end term

-- we use ⁄ (U+2044) instead of the usual slash / (U+002F) to avoid conflict with the division operator
notation t `[`:max s ` ⁄ `:95 n `]`:0 := term.subst t s n

namespace term

-- lemmas for the simplifier
@[simp, tls] lemma subst_fapp {a} (t₁ : preterm σ (a+1)) (t₂ s : preterm σ 0) (k : ℕ) :
  (fapp t₁ t₂) [s ⁄ k] = fapp (t₁ [s ⁄ k]) (t₂ [s ⁄ k]) := by refl
@[simp, tls] lemma subst_func {a} (f : σ.func_symb a) (s k) :
  (func f) [s ⁄ k] = func f := by refl

@[simp] lemma subst_var_lt (s : term σ) {x k : ℕ} (H : x < k) : #x[s ⁄ k] = #x :=
    begin rw subst, rw if_pos H, end
@[simp, tls] lemma subst_var_eq (s : term σ) {k : ℕ}  : #k[s ⁄ k] =  s ↑ k ＠ 0 :=
    begin rw subst, repeat{ rw if_neg (lt_irrefl k) }, end
@[simp] lemma subst_var_gt (s : term σ) {x k  : ℕ} (H : k < x) : #x[s ⁄ k] = #(x-1) :=
    begin rw subst, rw if_neg (lt_asymm H), rw if_pos H, end
@[simp] lemma subst_var_nle (s : term σ) {x k : ℕ} (H : ¬ (x ≤ k)) : #x[s ⁄ k] = #(x-1) :=
  subst_var_gt s (not_le.mp H)

@[simp, tls] lemma subst_var0 (s : term σ): #0[ s ⁄ 0 ] = s :=
    begin rw subst_var_eq, exact lift_by_0 s, end

/- Various substitution lemmas -/

lemma lift_subst : ∀ {a}  (t : preterm σ a) (s: term σ) (m) {i} (k) (H: i ≤ k),
    t [ s ⁄ k ] ↑ m ＠ i = (t ↑ m ＠ i)[ s ⁄ k+m ]
| _ #x s m i k H :=
  begin
    apply decidable.lt_by_cases x k; intro h₁,
    { -- x < k
      have h₂ : x < k + m, from nat.lt_add_right x k m h₁, by_cases i≤x;
      simp* , },
    { -- x = k
      subst h₁,
      simp[*, lift_lift_merge] , } ,
    { -- x > k
      have h₂ : i < x, by linarith,
      have : i ≤ x-1, from nat.le_sub_right_of_add_le (succ_le_of_lt h₂),
      have : i ≤ x, by linarith,
      have : 1 ≤ x, by linarith,
      simp[*, nat.sub_add_comm] },
  end
| _ (func f)   _ _ _ _ _ := by refl
| _ (fapp f t) _ _ _ _ _ := by simp*

lemma subst_lift: ∀  {a}  (t : preterm σ a) (s: term σ) {m i k : ℕ} (H: i ≤ k) (H' : k ≤ i + m),
    (t ↑ (m+1) ＠ i) [s ⁄ k] = t ↑ m ＠ i
| _ #x s m i k H H' :=
  begin by_cases h: i ≤ x,
    { have h₁ : k < x + (m + 1), from lt_succ_of_le (le_trans H' (add_le_add_right h m)), simp[*] , },
    { have h₁ : x < k, from lt_of_lt_of_le (lt_of_not_ge h) H, simp[*] , }
  end
| _ (func f)   _ _ _ _ _ _ := by refl
| _ (fapp f t) _ _ _ _ _ _ := by simp*

lemma subst_subst: ∀ {a} (t : preterm σ a) (s₁) {k₁}  (s₂) {k₂} (H : k₁ ≤ k₂),
    t[s₁ ⁄ k₁][s₂ ⁄ k₂] = t[s₂ ⁄ k₂ + 1][(s₁ [s₂ ⁄ k₂ - k₁]) ⁄ k₁]
| _ #x s₁ k₁ s₂ k₂ H :=
  begin apply decidable.lt_by_cases x k₁; intro h₁,
    { have h₂ : x < k₂, from lt_of_lt_of_le h₁ H,
      have h₃ : x < k₂ + 1, from lt.step h₂,
      simp[*] , },
    { subst h₁,
      have h₂ : x < k₂ + 1, from lt_succ_iff.mpr H,
      simp[*, lift_subst, nat.sub_add_cancel] , },
    { apply decidable.lt_by_cases (x-1) k₂; intro h₂,
      { have : x < k₂ + 1, from nat.lt_add_of_sub_lt_right h₂, simp*, },
      { have h₃: 1 ≤  x , from by linarith,
        have h₄: x  = k₂ + 1, from (nat.sub_eq_iff_eq_add h₃).mp h₂,
        subst h₄, clear h₃,
        simp[*, subst_lift, lt_irrefl] },
      { have: k₂+1 < x,   from nat.add_lt_of_lt_sub_right h₂,
        have: k₁ < x - 1, from gt_of_gt_of_ge h₂ H,
        simp[*], }, },
  end
| _ (func f) _ _ _ _ _ := by refl
| _ (fapp t s) _ _ _ _ _ := by simp*

lemma subst_lift_by_lift : ∀{a} (t : preterm σ a) (s : term σ) (m i k : ℕ),
    (t ↑ m ＠ (i + k + 1)) [ (s ↑ m ＠ i) ⁄ k] = (t [ s ⁄ k ]) ↑ m ＠ (i+k)
| _ #x s m i k :=
  begin by_cases h₁ : i + k + 1 ≤ x,
    { -- i + k + 1 ≤ x
      have h₂ : k < x := lt_of_le_of_lt (le_add_left k i) (lt_of_succ_le h₁),
      have : k < x + m := lt_add_right k x m h₂,
      have : i + k ≤ x - 1 := nat.le_sub_right_of_add_le h₁,
      have : 1 ≤ x := one_le_of_lt h₂,
      simp [*, nat.sub_add_comm] , },
    { -- ¬ i + k + 1 ≤ x
      apply decidable.lt_by_cases x k; intro h₂,
      { -- x < k
        have : ¬ i + k ≤ x := not_le_of_lt (lt_add_left x k i h₂), simp[*] , },
      { -- x = l
        subst h₂, simp[*, lift_lift] , },
      { -- k < x
        have h₁: ¬ i+k ≤ x - 1,
        begin
          intro h,
          have h₃ : i + k + 1 ≤ x - 1 + 1, from succ_le_succ h,
          rw nat.sub_add_cancel (one_le_of_lt h₂) at h₃,
          exact h₁ h₃,
        end,
        simp[*] , }, },
  end
| _ (func f)     _ _ _ _ := by refl
| _ (fapp t₁ t₂) _ _ _ _ := by simp*

lemma subst_var0_lift : ∀{a} (t : preterm σ a) (m i : ℕ), (t ↑ (m+1) ＠ (i+1))[ #0 ⁄ i] = t ↑ m ＠ (i+1)
| _ #x m i := begin apply decidable.lt_by_cases i x; intro h₀,
                { have: i+1 ≤ x, by linarith,
                  have: ¬ (x + (m + 1) < i), by linarith,
                  have: i < x + (m + 1), by linarith,
                  simp* , },
                { subst h₀, simp , },
                { have: ¬ (i + 1 ≤ x), by linarith, simp* , },
            end
| _ (func f) _ _ := by refl
| _ (fapp t s) _ _ := by simp*

@[simp, tls] lemma subst_var0_lift_by_1 {a} (t : preterm σ a) (i : ℕ) : (t ↑ (1) ＠ (i+1))[#0 ⁄ i] = t :=
begin
    have h:= subst_var0_lift t 0 i,
    rw lift_by_0 at h,
    exact h,
end

@[simp, tls] lemma subst_for_0_lift_by_1: ∀ {a} (t : preterm σ a) (s : term σ) , (t ↑ 1 ＠ 0)[s ⁄ 0] = t
| _ #x _         := by refl
| _ (func f) _   := by refl
| _ (fapp t s) _ := by simp*

/--
  Biggest (deepest) reference depth of variables occurring in a term (plus one).

  Examples:
  * `max_free_var #k = k+1` by definition.
  * `max_free_var t = 0` means no variables occur in `t`.
-/
def max_free_var: ∀ {a} (t : preterm σ a), ℕ
| _ #x := x+1
| _ (func f)  := 0
| _ (fapp t s) := max (max_free_var t) (max_free_var s)

/- If `t` is a fixed point for lifting at `i`, then its a fixed point for lifting at `j` for all `i≤j`  -/
lemma lift_fixed_points_monotone {a} {t:preterm σ a} {i j: ℕ} (h: i ≤ j) (H: t ↑ 1 ＠ i = t) : t ↑ 1 ＠ j = t :=
begin
  induction j with j,
  { rwa[le_zero_iff.mp h] at H,},
  {  by_cases h': i = j+1,
    { rwa h' at H, },
    { have h₁: i≤j, from lt_succ_iff.mp (lt_of_le_of_ne h h'),
      have h₂ := j_ih h₁,
      rw [←H, ←lift_lift t 1 1 h₁, h₂], },
  },
end

@[simp, tls] lemma lift_at_max_free_var {a} (t : preterm σ a) : t ↑ 1 ＠ (max_free_var t) = t :=
begin
  induction t with T,
  { simp[max_free_var], },
  { refl },
  { unfold lift max_free_var,
    congr,
    { have t_h := le_max_left (max_free_var t_t) (max_free_var t_s),
      exact lift_fixed_points_monotone t_h t_ih_t, },
    { have s_h := le_max_right (max_free_var t_t) (max_free_var t_s),
      exact lift_fixed_points_monotone s_h t_ih_s, } }
end

end term

/-! ### formulas -/
section formulas

variable (σ)
/--
  `preformula σ a` is a partially applied formula of first-order logic over the signature `σ`.
  If applied to `a` terms it becomes a well-formed formula.
-/
inductive preformula : ℕ → Type u
| bot                           : preformula 0
| eq   (t s : term σ)         : preformula 0
| imp  (φ ψ : preformula 0)   : preformula 0
| and  (φ ψ : preformula 0)   : preformula 0
| or   (φ ψ : preformula 0)   : preformula 0
| all  (φ : preformula 0)     : preformula 0
| ex   (φ : preformula 0)     : preformula 0
| pred {arity : ℕ} (P : σ.pred_symb arity)                  : preformula arity
| papp {arity : ℕ} (φ : preformula (arity+1)) (t : term σ) : preformula arity

@[reducible] def formula := preformula σ 0

variable {σ}

notation `⊥'`     := preformula.bot
infix ` =' `:100  := preformula.eq

infixr ` →' `:80  := preformula.imp
infixr ` ∨' `:85  := preformula.or
infixr ` ∧' `:90  := preformula.and

prefix `∀'`:110   := preformula.all
prefix `∃'`:110   := preformula.ex

@[simp] def preformula.iff (φ ψ : formula σ) : formula σ := (φ →' ψ) ∧' (ψ  →' φ)
infix ` ↔' `:70 := preformula.iff -- input \<=>

@[simp] def preformula.not (φ : formula σ) : formula σ := (φ →' ⊥')
prefix `¬'`:115 := preformula.not

def preformula.top : formula σ  := ¬' ⊥'
notation `⊤'` := preformula.top

export preformula

section lifts_and_substitutions

namespace formula

/-- `lift φ m i` increases the index of `i`-free variables in `φ` by `m`. -/
@[simp, reducible] def lift : ∀{a} , preformula σ a → ℕ → ℕ → preformula σ a
| _ ⊥'  _ _         := ⊥'
| _ (t =' s) m i    := (term.lift t m i) =' (term.lift s m i)
| _ (φ →' ψ) m i  := (lift φ m i) →' (lift ψ  m i)
| _ (φ ∧' ψ) m i  := (lift φ m i) ∧' (lift ψ  m i)
| _ (φ ∨' ψ) m i  := (lift φ m i) ∨' (lift ψ  m i)
| _ (∀' φ) m i    := ∀' (lift φ m (i+1))
| _ (∃' φ) m i    := ∃' (lift φ m (i+1))
| _ (pred P) _ _    := pred P
| _ (papp φ t) m i  := papp (lift φ m i) (term.lift t m i)

/-- `subst t s k` substitutes `s ↑ k ＠ 0` for each variable at `k` in `t` -/
@[simp, tls] def subst :  ∀{a} , preformula σ a → term σ → ℕ → preformula σ a
| _ ⊥'  _ _         := ⊥'
| _ (t₁ =' t₂) s k := (term.subst t₁ s k) =' (term.subst t₂ s k)
| _ (φ →' ψ) s k  := (subst φ s k) →' (subst ψ  s k)
| _ (φ ∧' ψ) s k  := (subst φ s k) ∧' (subst ψ  s k)
| _ (φ ∨' ψ) s k  := (subst φ s k) ∨' (subst ψ  s k)
| _ (∀' φ) s k    := ∀' (subst φ  s (k+1))
| _ (∃' φ) s k    := ∃' (subst φ  s (k+1))
| _ (pred P) _ _    := pred P
| _ (papp φ t) s k  := papp (subst φ s k) (term.subst t s k)

end formula

notation f ` ↑ `:90 m ` ＠ `:90 i :90 := formula.lift f m i
notation φ `[`:max t ` ⁄ `:95 n `]`:0 := formula.subst φ t n

-- #reduce #3 ↑ 3 ＠ 1
-- #reduce (#3 =' #0) ↑ 3 ＠ 1
-- #reduce #5[#2 ⁄ 1]
-- #reduce (#5 =' #4)[#0 ⁄ 5]

namespace formula
open preformula

-- lift and substitution lemmas for formulas
@[simp, tls] lemma lift_by_0: ∀ {a} (φ : preformula σ a) {i}, φ ↑ 0 ＠ i = φ
| _ ⊥' _          := by refl
| _ (t =' s) _    := by simp
| _ (φ →' ψ) _    := begin rw lift, congr; exact lift_by_0 _, end
| _ (φ ∧' ψ) _    := begin rw lift, congr; exact lift_by_0 _, end
| _ (φ ∨' ψ) _    := begin rw lift, congr; exact lift_by_0 _, end
| _ (∀' φ) _      := begin rw lift, congr, exact lift_by_0 φ, end
| _ (∃' φ) _      := begin rw lift, congr, exact lift_by_0 φ, end
| _ (pred P) _    := by refl
| _ (papp φ t) _  := begin rw lift, congr, exact lift_by_0 φ, exact term.lift_by_0 t, end

lemma lift_lift: ∀{a} (φ : preformula σ a) (m) {i} (n) {j} (H : j ≤ i),
    (φ ↑ m ＠ i) ↑ n ＠ j = (φ ↑ n ＠ j) ↑ m ＠ (i+n)
| _ ⊥' _ _ _ _ _           := by refl
| _ (t =' s) _ _ _ _ _     := by simp[*, term.lift_lift]
| _ (φ →' ψ) _ _ _ _ _     := by simp[*]
| _ (φ ∧' ψ) _ _ _ _ _     := by simp[*]
| _ (φ ∨' ψ) _ _ _ _ _     := by simp[*]
| _ (∀' φ) _ _ _ _ _       := by simp[*, add_right_comm]
| _ (∃' φ) _ _ _ _ _       := by simp[*, add_right_comm]
| _ (pred P) _ _ _ _ _     := by refl
| _ (papp φ t) _ _ _ _ _   := by simp[*, term.lift_lift]

lemma lift_lift_reverse {a} (φ : preformula σ a) {m i} (n) {j} (H : i + m ≤ j) :
    (φ ↑ m ＠ i) ↑ n ＠ j = (φ ↑ n ＠ (j-m)) ↑ m ＠ i :=
begin
    have h : i ≤ (j-m), from nat.le_sub_right_of_add_le H,
    have h': m ≤ j, from (le_trans (m.le_add_left i) H),
    rw [lift_lift φ n m h, nat.sub_add_cancel h'],
end

lemma lift_lift_merge: ∀ {a} (φ : preformula σ a) {m i} (n) {j} (H : i ≤ j) (H' : j ≤ i + m),
    (φ ↑ m ＠ i) ↑ n ＠ j = φ ↑ (m+n) ＠ i
| _ ⊥' _ _ _ _ _ _         := by refl
| _ (t =' s) _ _ _ _ _ _   := by simp[*, term.lift_lift_merge]
| _ (φ →' ψ) _ _ _ _ _ _   := by simp[*]
| _ (φ ∧' ψ) _ _ _ _ _ _   := by simp[*]
| _ (φ ∨' ψ) _ _ _ _ _ _   := by simp[*]
| _ (∀' φ) _ _ _ _ _ _     := by simp[*, add_right_comm]
| _ (∃' φ) _ _ _ _ _ _     := by simp[*, add_right_comm]
| _ (pred P) _ _ _ _ _ _   := by refl
| _ (papp φ t) _ _ _ _ _ _ := by simp[*, term.lift_lift_merge]

@[simp, tls] lemma lift_at_lift_merge {a} (φ : preformula σ a) (m i n):
    (φ ↑ m ＠ i) ↑ n ＠ i = φ ↑ (m+n) ＠ i := lift_lift_merge φ n (le_rfl) (i.le_add_right m)

lemma lambda_lift_lift {a} (m) {i} (n) {j} (H : j≤i) :
    (λ (φ :preformula σ a),  (φ ↑ m ＠ i) ↑ n ＠ j) = (λ φ, (φ ↑ n ＠ j) ↑ m ＠ (i+n)) :=
begin funext, apply lift_lift, exact H, end

lemma lift_subst: ∀ {a}  (φ : preformula σ a) (s: term σ) (m i k : ℕ) (h': i ≤ k),
     φ[s ⁄ k] ↑ m ＠ i = (φ ↑ m ＠ i)[s ⁄ (k+m)]
| _ ⊥' _ _ _ _ _          := by refl
| _ (t₁ =' t₂) _ _ _ _ _  := by simp[*, term.lift_subst]
| _ (φ →' ψ) _ _ _ _ _    := by simp[*]
| _ (φ ∧' ψ) _ _ _ _ _    := by simp[*]
| _ (φ ∨' ψ) _ _ _ _ _    := by simp[*]
| _ (∀' φ) _ _ _ _ _      := by simp[*, add_right_comm]
| _ (∃' φ) _ _ _ _ _      := by simp[*, add_right_comm]
| _ (pred P) _ _ _ _ _    := by refl
| _ (papp φ t) _ _ _ _ _  := by simp[*, term.lift_subst]

lemma lambda_lift_subst_formula {a} {s: term σ} { m i k : ℕ } (h': i ≤ k) :
  (λ (ϕ: preformula σ a), lift (subst ϕ s k) m i) = (λ ϕ, subst (lift ϕ m i) s (k+m)) :=
begin funext, apply lift_subst, assumption, end

lemma subst_lift : ∀ {a}  (φ : preformula σ a) (s: term σ) {m i k : ℕ } (H: i ≤ k) (H' : k ≤ i + m),
    (φ ↑ (m+1) ＠ i)[s ⁄ k] = φ ↑ m ＠ i
| _ ⊥' _ _ _ _ _ _          := by refl
| _ (t₁ =' t₂) _ _ _ _ _ _  := by simp[*, term.subst_lift]
| _ (φ →' ψ) _ _ _ _ _ _  := by simp[*]
| _ (φ ∧' ψ) _ _ _ _ _ _  := by simp[*]
| _ (φ ∨' ψ) _ _ _ _ _ _  := by simp[*]
| _ (∀' φ) _ _ _ _ _ _    := by simp[*, add_right_comm]
| _ (∃' φ) _ _ _ _ _ _    := by simp[*, add_right_comm]
| _ (pred P) _ _ _ _ _ _    := by refl
| _ (papp φ t) _ _ _ _ _ _ := by simp[*, term.subst_lift]

lemma subst_lift_in_lift : ∀{a} (φ : preformula σ a) (s : term σ) (m i k),
    (φ ↑ m ＠ (i + k + 1)) [ (s ↑ m ＠ i) ⁄ k] = φ[s ⁄ k] ↑ m ＠ (i+k)
| _ ⊥' _ _ _ _         := by refl
| _ (t₁ =' t₂) _ _ _ _ := by simp[*, term.subst_lift_by_lift]
| _ (φ →' ψ) _ _ _ _   := by simp[*]
| _ (φ ∧' ψ) _ _ _ _   := by simp[*]
| _ (φ ∨' ψ) _ _ _ _   := by simp[*]
| _ (∀' φ) s m i k     := begin have := subst_lift_in_lift φ s m i (k+1), rw[add_succ i k] at this, simp[*, add_right_comm], end
| _ (∃' φ) s m i k     := begin have := subst_lift_in_lift φ s m i (k+1), rw[add_succ i k] at this, simp[*, add_right_comm], end
| _ (pred P) _ _ _ _   := by refl
| _ (papp φ t) _ _ _ _ := by simp[*, term.subst_lift_by_lift]

@[tls] lemma subst0_lift_by_lift {a}  (φ : preformula σ a) {s : term σ} {m i:ℕ } :
  (φ ↑ m ＠ (i + 1)) [(s ↑ m ＠ i) ⁄ 0] = φ[s ⁄ 0] ↑ m ＠ i := subst_lift_in_lift φ s m i 0

@[tls] lemma subst_at_lift {a} (φ : preformula σ a) (m) (s : term σ) (k) :
  (φ ↑ (m+1) ＠ k)[s ⁄ k] =  φ ↑ m ＠ k := subst_lift φ s (le_refl k) (le.intro rfl)

@[tls] lemma subst_var0_lift : ∀{a} (φ : preformula σ a) (m i : ℕ),
  (φ ↑ (m+1) ＠ (i+1))[#0 ⁄ i] = φ ↑ m ＠ (i+1)
| _ ⊥'  _ _        := by refl
| _ (t₁ =' t₂) m i := by simp[term.subst_var0_lift]
| _ (φ →' ψ) m i   := by simp*
| _ (φ ∧' ψ) m i   := by simp*
| _ (φ ∨' ψ) m i   := by simp*
| _ (∀' φ) m i     := by simp*
| _ (∃' φ) m i     := by simp*
| _ (pred P) _ _   := by refl
| _ (papp φ t) m i := by simp[*, term.subst_var0_lift]

@[tls] lemma subst_var0_lift_by_1 {a}  (φ : preformula σ a)  (i : ℕ) :
  (φ ↑ 1 ＠ (i+1))[#0 ⁄ i] = φ :=
begin
  have h:= subst_var0_lift φ 0 i,
  rwa lift_by_0 at h,
end

@[tls] lemma subst_var0_for_0_lift_by_1 {a} (φ : preformula σ a) :
  (φ ↑ 1 ＠ 1)[#0 ⁄ 0] = φ := subst_var0_lift_by_1 φ 0

@[simp, tls] lemma subst_for_0_lift_by_1: ∀ {a} (φ : preformula σ a) (s : term σ),
  (φ ↑ 1 ＠ 0)[s ⁄ 0] = φ
| _ ⊥' _         := by refl
| _ (t₁ =' t₂) _ := by simp[*, term.subst_for_0_lift_by_1]
| _ (φ →' ψ) _   := by simp[*]
| _ (φ ∧' ψ) _   := by simp[*]
| _ (φ ∨' ψ) _   := by simp[*]
| _ (∀'φ) s      := begin dsimp, congr, have h:= subst_at_lift φ 0 s (0+1), rw lift_by_0 at h, exact h, end
| _ (∃'φ) s      := begin dsimp, congr, have h:= subst_at_lift φ 0 s (0+1), rw lift_by_0 at h, exact h, end
| _ (pred P) _   := by refl
| _ (papp φ t) _ := by simp[*, term.subst_lift_by_lift]

lemma subst_subst : ∀ {a} (φ : preformula σ a) (s₁) {k₁} (s₂) {k₂} (H : k₁ ≤ k₂),
    φ [ s₁ ⁄ k₁] [ s₂ ⁄ k₂] = φ [ s₂ ⁄ k₂ + 1] [ (s₁ [s₂ ⁄ k₂ - k₁]) ⁄ k₁ ]
| _ ⊥' _ _ _ _ _         := by refl
| _ (t₁ =' t₂) _ _ _ _ _ := by simp[*, term.subst_subst]
| _ (φ →' ψ) _ _ _ _ _   := by simp[*]
| _ (φ ∧' ψ) _ _ _ _ _   := by simp[*]
| _ (φ ∨' ψ) _ _ _ _ _   := by simp[*]
| _ (∀' φ) _ _ _ _ _     := by simp[*, add_right_comm]
| _ (∃' φ) _ _ _ _ _     := by simp[*, add_right_comm]
| _ (pred P) _ _ _ _ _   := by refl
| _ (papp φ t) _ _ _ _ _ := by simp[*, term.subst_subst]

/- If `φ` is a fixed point for lifting at `i`, then its a fixed point for lifting at `j` for all `i≤j`  -/
lemma lift_fixed_points_monotone {a} {φ : preformula σ a} {i j}
  (H : φ ↑ 1 ＠ i = φ) (h : i ≤ j) : φ ↑ 1 ＠ j = φ :=
begin
  induction j with j,
  { rwa[le_zero_iff.mp h] at H, },
  { by_cases h': i = j+1,
    { rwa h' at H, },
    { have h₁: i≤j, from lt_succ_iff.mp (lt_of_le_of_ne h h'),
      have h₂ := j_ih h₁,
      rw [←H, ←lift_lift φ 1 1 h₁, h₂], }, },
end

-- We can give improve this lemma a  bit:
-- - we can state this for fixed points of lifts by m
-- - we can state this for fixed points of lifts by m ≥ 1 at i
--   and conclude they are fixed points of lifts by n at j for j≥i
-- Note that we do not place any conditions on n.

/--
  `alls k φ` is the formula obtained by binding the the first `k` free variables in `φ`
  with universal quantifiers.

  In other words, we add `k` universal quantifier in from of `φ`
-/
def alls : ∀ (k:ℕ) (φ: formula σ) , formula σ
| 0     φ   := φ
| (k+1) φ   := ∀' (alls k φ)

-- lemmas about alls
lemma all_alls: ∀ (φ: formula σ) (k:ℕ) , ∀' (alls k φ) = alls k (∀'φ)
| φ 0 := by refl
| φ (k+1) := begin unfold alls, congr' 1, apply all_alls, end

lemma alls_succ (k) (φ : formula σ) : alls (k+1) φ = alls k (∀' φ) := begin rw [alls, all_alls], end

lemma alls_alls: ∀ (φ: formula σ) (m n:ℕ) , alls n (alls m φ) = alls m (alls n φ)
| φ 0 n := by refl
| φ (m+1) n := begin rw alls, rw ←all_alls _ _, rw alls_alls _ m n, refl, end

lemma alls_lift : ∀  (φ: formula σ) (m i n:ℕ), alls n (φ ↑ m ＠ (i+n)) = (alls n φ) ↑ m ＠ i
| φ m i 0 := by refl
| φ m i (n+1) := begin dsimp[alls], congr, rw ←succ_add_eq_succ_add i n, apply alls_lift,end

lemma alls_at_lift  (φ: formula σ) (m n:ℕ) : alls n (φ ↑ m ＠ n) = (alls n φ) ↑ m ＠ 0 :=
begin
  let h := alls_lift φ m 0 n,
  rwa zero_add at h,
end

/--
  `substs k i j φ` is the formula `φ[#(k+i) ⁄ k+j]...[#(1+i) ⁄ 1+j][#i ⁄ j]`.
-/
def substs : ∀(k i j: ℕ) (φ: formula σ), formula σ
| 0 i j φ  := φ
| (k+1) i j φ := substs k i j (φ [#(k+i) ⁄ (k+j)])

-- lemmas about substs
lemma substs_succ (k i j: ℕ) (φ : formula σ): substs (k+1) i j φ = (substs k (i+1) (j+1) φ) [ #i ⁄ j] :=
begin
  induction k generalizing φ,
  { simp[substs] },
  { simp[*,substs, succ_add_eq_succ_add] }
end

lemma all_substs {k i j}{φ : formula σ} :
  ∀'(substs k i (j+1) φ) = substs k i j ∀'φ :=
begin
  induction k generalizing φ,
  { dsimp[substs], refl },
  { simp[*,substs, succ_add_eq_succ_add, add_assoc] }
end

/--
  A formula `φ` is `k`-closed if it has no `k`-free variables,
  i.e. if lifting at `k` does not change the formula.
-/
@[simp, reducible] def closed {a} (k : ℕ) (φ : preformula σ a) := φ ↑ 1 ＠ k = φ

/-- A sentence is a `0`-closed formula, i.e. a formula without free variables. -/
@[simp, reducible] def sentence (φ : formula σ) := closed 0 φ
postfix ` is_sentence`:max := sentence

/- Various lemmas involving lifts and substitutions of closed formulas -/

lemma closed_all {φ : formula σ} {k} (H : closed (k+1) φ) : closed k (∀' φ) :=
begin dsimp, congr, exact H, end

lemma closed_ex {φ : formula σ} {k} (H : closed (k+1) φ) : closed k (∃' φ) :=
begin dsimp, congr, exact H end

lemma lift_closed_id_h { φ : formula σ} {k} (H : closed k φ) (m i) :
  φ ↑ m ＠ (k+i) = φ :=
begin
  induction m generalizing φ,
  { apply lift_by_0, },
  { rw [succ_eq_add_one, ←lift_lift_merge φ 1 (le_refl _) (le.intro rfl), m_ih H],
    apply lift_fixed_points_monotone H (le.intro rfl) },
end

-- `k`-closed formulas are fixed points for lifts at reference depth `≥k`
lemma lift_closed_id { φ : formula σ} {k} (H : closed k φ) (m) {l} (h : k ≤ l):
  (φ ↑ m ＠ l) = φ :=
begin
  cases le_iff_exists_add.mp h with i h_i,
  subst h_i,
  exact lift_closed_id_h H m i,
end

-- sentences are fixed points of all lifts
lemma lift_sentence_id {φ : formula σ} (H: sentence φ) { m i } :
  (φ ↑ m ＠ i) = φ := lift_closed_id H m (i.zero_le)

lemma lift_set_of_sentences_id {Γ : set $ formula σ} (H : ∀ ϕ ∈ Γ, sentence ϕ) {m i}
  : (λ ϕ: formula σ, ϕ ↑ m ＠ i) '' Γ = Γ :=
begin
  apply ext, intro x,
  apply iff.intro,
  { intro h_x, rw mem_image_eq at h_x,
    cases h_x with y h',
    have yx:= h'.right,
    have y_h := h'.left,
    subst yx, rwa lift_sentence_id (H y y_h), },
  { intro h, rw mem_image_eq, use x, exact ⟨h, lift_sentence_id (H x h)⟩, },
end

lemma subst_closed_id_h { φ : formula σ} (t:term σ) {k} (i) (H : closed k φ) :
  (φ [t ⁄ k+i]) = φ :=
begin
  have h := subst_at_lift φ 0 t (k+i),
  repeat {rwa lift_closed_id_h H _ _ at h,},
end

-- `k`-closed formulas are fixed points for substitutions at reference depth `≥k`
lemma subst_closed_id {φ : formula σ}{i}  (H : closed i φ)  (t:term σ) {k} (h : i≤k) :
  (φ [t ⁄ k]) = φ :=
begin
  cases le_iff_exists_add.mp h with j h_j,
  subst h_j, exact subst_closed_id_h t j H,
end

lemma subst_sentence_id { φ : formula σ} (H : sentence φ)  {t: term σ} {k:ℕ} :  (φ [t ⁄ k]) = φ
  := subst_closed_id H t (k.zero_le)

lemma subst_set_of_sentences_id {Γ : set $ formula σ} {t k} (H : ∀f ∈ Γ, sentence f) :
  (λ (ϕ: formula σ), ϕ[t ⁄ k]) '' Γ = Γ :=
begin
  apply ext, intro x,
  apply iff.intro,
  { intro h_x, rw mem_image_eq at h_x,
    cases h_x with y h',
    have yx := h'.right,
    have h_y := h'.left,
    subst yx, rwa subst_sentence_id (H y h_y), },
  { intro h, rw mem_image_eq, use x, exact ⟨h, subst_sentence_id (H x h)⟩, },
end

/--
  Biggest (deepest) reference depth of variables occurring in a formula (plus one).

  If equal to `0` the formula has no free variables.
-/
def max_free_var :  ∀ {a} (φ: preformula σ a), ℕ
| _ ⊥'         := 0
| _ (t₁ =' t₂) := max (term.max_free_var t₁) (term.max_free_var t₂)
| _ (∀'φ)      := (max_free_var φ) - 1
| _ (∃'φ)      := (max_free_var φ) - 1
| _ (φ →' ψ)   := max (max_free_var φ) (max_free_var ψ)
| _ (φ ∧' ψ)   := max (max_free_var φ) (max_free_var ψ)
| _ (φ ∨' ψ)   := max (max_free_var φ) (max_free_var ψ)
| _ (pred P)   := 0
| _ (papp φ t) := max (max_free_var φ) (term.max_free_var t)

/- This lemma shows that our definition of closed is exactly what our intuition tells us. -/
lemma closed_max_free_var {a} (φ : preformula σ a) : closed (max_free_var φ) φ :=
begin
  unfold closed,
  induction φ,
  { refl },
  { have h₁ := term.lift_fixed_points_monotone (le_max_left (term.max_free_var φ_t)  (term.max_free_var φ_s)) (term.lift_at_max_free_var φ_t),
    have h₂ := term.lift_fixed_points_monotone (le_max_right (term.max_free_var φ_t) (term.max_free_var φ_s)) (term.lift_at_max_free_var φ_s),
    rw[max_free_var, formula.lift, h₁,h₂] },
  { have h₁:= lift_fixed_points_monotone φ_ih_φ (le_max_left  (max_free_var φ_φ) (max_free_var φ_ψ)),
    have h₂:= lift_fixed_points_monotone φ_ih_ψ (le_max_right (max_free_var φ_φ) (max_free_var φ_ψ)),
    rw[max_free_var, formula.lift, h₁,h₂] },
  { have h₁:= lift_fixed_points_monotone φ_ih_φ (le_max_left  (max_free_var φ_φ) (max_free_var φ_ψ)),
    have h₂:= lift_fixed_points_monotone φ_ih_ψ (le_max_right (max_free_var φ_φ) (max_free_var φ_ψ)),
    rw[max_free_var, formula.lift, h₁,h₂] },
  { have h₁:= lift_fixed_points_monotone φ_ih_φ (le_max_left  (max_free_var φ_φ) (max_free_var φ_ψ)),
    have h₂:= lift_fixed_points_monotone φ_ih_ψ (le_max_right (max_free_var φ_φ) (max_free_var φ_ψ)),
    rw[max_free_var, formula.lift, h₁,h₂] },
  { have h := lift_fixed_points_monotone φ_ih (nat.le_sub_add (max_free_var φ_φ) 1),
    rw[formula.lift, max_free_var, h], },
  { have h := lift_fixed_points_monotone φ_ih (nat.le_sub_add (max_free_var φ_φ) 1),
    rw[formula.lift, max_free_var, h] },
  { refl },
  { have h₁:= lift_fixed_points_monotone φ_ih (le_max_left (max_free_var φ_φ) (term.max_free_var φ_t)),
    have h₂:= term.lift_fixed_points_monotone (le_max_right (max_free_var φ_φ) (term.max_free_var φ_t)) (term.lift_at_max_free_var φ_t) ,
    rw[max_free_var, formula.lift, h₁, h₂] }
end

/-- The (universal) closure of a `k`-closed formula, binding up to the `k`-th free variable -/
@[reducible] def closure (φ : formula σ) {k} (H: closed k φ) := alls k φ

lemma closure_is_sentence  {φ : formula σ} {k} (H : closed k φ) : (closure φ H) is_sentence :=
begin
  induction k generalizing φ,
  { exact H, },
  { unfold closure,
    rw[alls, all_alls],
    exact k_ih (closed_all H), },
end

def not_free (k) (φ : formula σ) : Prop := ∃ϕ, φ = ϕ ↑ 1 ＠ k

lemma not_free_trival_witness (k)  (φ : formula σ) (h : not_free k φ) : φ = φ[#0 ⁄ k] ↑ 1 ＠ k :=
begin
  cases h with ψ ψ_h,
  subst ψ_h,
  rw [subst_at_lift, lift_by_0],
end

-- /-- Lift operation on sets of formulas. -/
-- @[simp] def lift_set (Γ : set $ formula σ) (m i) : set $ formula σ := ((λ (ϕ : formula σ), ϕ ↑ m ＠ i) '' Γ)
-- /-- Substitution operation on sets of formulas. -/
-- @[simp] def subst_set  (Γ : set $ formula σ) (s k) : set $ formula σ := ((λ (ϕ : formula σ), ϕ [s ⁄ k]) '' Γ)

end formula

end lifts_and_substitutions

end formulas

export formula

/-!### Proof terms of natural deduction -/
section proof_terms

local notation φ >> Γ := insert φ Γ

/--
  An intuitionistic natural deduction proof calculus
  for first order predicate logic with rules for equality

  Fresh variables for universal quantifier introduction and existential quantifier elimination
  are introduced by lifting.
-/
inductive proof_term : (set $ formula σ) → formula σ → Type u
| hypI {Γ} {φ} (h : φ ∈ Γ) : proof_term Γ φ
| botE {Γ} {φ} (H : proof_term Γ  ⊥') : proof_term Γ φ
-- implication
| impI {Γ} {φ ψ}   (H : proof_term (φ>>Γ) ψ) : proof_term Γ (φ →' ψ)
| impE {Γ} (φ) {ψ} (H₁ : proof_term Γ φ) (H₂ : proof_term Γ (φ →' ψ)) : proof_term Γ ψ
-- conjunction
| andI  {Γ} {φ ψ} (H₁ : proof_term Γ φ)
                  (H₂ : proof_term Γ ψ) : proof_term Γ (φ ∧' ψ)
| andE₁ {Γ} {φ} (ψ) (H : proof_term Γ (φ ∧' ψ)) : proof_term Γ φ
| andE₂ {Γ} (φ) {ψ} (H : proof_term Γ (φ ∧' ψ)) : proof_term Γ ψ
-- disjunction
| orI₁ {Γ} {φ ψ} (H : proof_term Γ φ) : proof_term Γ (φ ∨' ψ)
| orI₂ {Γ} {φ ψ} (H : proof_term Γ ψ) : proof_term Γ (φ ∨' ψ)
| orE  {Γ}  (φ ψ) {χ} (H  : proof_term Γ (φ ∨' ψ))
                      (H₁ : proof_term (φ >> Γ) χ)
                      (H₂ : proof_term (ψ >> Γ) χ) : proof_term Γ χ
-- quantification
| allI  {Γ} {φ} (H : proof_term ((λ ϕ, ϕ ↑ 1 ＠ 0) '' Γ) φ) : proof_term Γ (∀'φ)
| allE  {Γ} (φ) {t} (H : proof_term Γ (∀'φ)) : proof_term Γ (φ [t ⁄ 0])
| exI   {Γ φ} (t) (H : proof_term Γ (φ[t ⁄ 0])) : proof_term Γ  (∃'φ)
| exE   {Γ ψ} (φ) (H₁ : proof_term Γ (∃'φ))
  (H₂ : proof_term  (φ >> (λ ϕ, ϕ ↑ 1 ＠ 0) '' Γ) (ψ ↑ 1 ＠ 0)) : proof_term Γ ψ
-- equality
| eqI {Γ} (t) : proof_term Γ (t =' t)
| eqE {Γ} {s t φ } (H₁ : proof_term Γ (s =' t)) (H₂ : proof_term Γ (φ[s ⁄ 0])) : proof_term Γ (φ [t ⁄ 0])
infix ` ⊢ `:55 := proof_term

/--
  `provable Γ φ` says that there exists a proof_term of `φ` under the hypotheses in `Γ`,
  i.e. it is a fancy way to say that the type `Γ ⊢ φ` is non-empty.
-/
def provable (φ : formula σ) (Γ)  : Prop := nonempty (Γ ⊢ φ)
infix ` is_provable_within `:100 := provable

/--
  The law of excluded middle for when we want to argue in classical logic.
-/
def lem : set $ formula σ := { (φ ∨' ¬'φ) | (φ: formula σ) (h: φ is_sentence) } -- do we need the extra condition?

namespace proof_term
/--
  Rule for weakening the context of a proof_term by allowing more premises.
-/
def weak {Δ φ}  (Γ: set $ formula σ) (H : Γ ⊢ φ) (h: Γ ⊆ Δ): (Δ ⊢ φ) :=
begin
  induction H generalizing Δ,
  { apply hypI (h H_h) },
  { apply botE, apply H_ih, assumption },

  { apply impI, apply H_ih, apply insert_subset_insert, assumption },
  { apply impE, apply H_ih_H₁, assumption,
    apply H_ih_H₂, assumption },

  { apply andI,  apply H_ih_H₁, exact h,
    apply H_ih_H₂, exact h},
  { apply andE₁, apply H_ih, exact h },
  { apply andE₂, apply H_ih, exact h },

  { apply orI₁, apply H_ih, exact h, },
  { apply orI₂, apply H_ih, exact h, },
  { apply orE,  apply H_ih_H, exact h,
    apply H_ih_H₁, apply insert_subset_insert, exact h,
    apply H_ih_H₂, apply insert_subset_insert, exact h},

  { apply allI, apply H_ih, exact image_subset _ h,},
  { apply allE, apply H_ih, exact h},

  { apply exI, apply H_ih, exact h},
  { apply exE, apply H_ih_H₁, exact h,
    apply H_ih_H₂, apply insert_subset_insert, exact image_subset _ h,},

  { apply eqI, },
  { apply eqE, apply H_ih_H₁ h, apply H_ih_H₂ h, },
end

/--
  Proof rule for weakening the context of a proof_term by inserting a single premise.
-/
def weak1 {Γ} {φ ψ: formula σ} (H: Γ ⊢ ψ) :  (φ>>Γ) ⊢ ψ := weak Γ H (subset_insert φ Γ)

/--
  Proof rule for weakening the context of a proof_term from a single premise.
-/
def weak_singleton {Γ} (φ) {ψ: formula σ} (H: { φ } ⊢ ψ) (h: φ ∈ Γ) :  Γ ⊢ ψ :=
begin
  apply weak {φ} H,
  assume x xh,
  rw mem_singleton_iff at xh,
  subst xh,
  assumption,
end

-- QoL rules for hypothesis
def hypI1 {Γ} (φ: formula σ)  : (φ >> Γ) ⊢ φ := hypI (mem_insert φ Γ)

def hypI2 {Γ} (φ ψ: formula σ)  : φ >> (ψ >> Γ) ⊢ ψ :=
begin
  apply hypI, right, exact mem_insert ψ Γ,
end
/--
  Rule for top introduction.
-/
def topI {Γ: set $ formula σ} : Γ ⊢ ⊤' := begin apply impI, apply hypI1, end

-- rules for implications
def impE_insert {Γ} {φ ψ: formula σ} (H₁ : Γ ⊢ (φ →' ψ)) : φ >> Γ ⊢ ψ  :=
begin
  apply impE φ,
  apply hypI1,
  apply weak1,
  assumption,
end

/--
  Proof rule for reflexivity of implications.
-/
def impI_refl {Γ} (φ : formula σ) : Γ ⊢ (φ →' φ) :=
begin
    apply impI, apply hypI1,
end

/--
  Proof rule for transitivity of implications.
-/
def impI_trans  {Γ} (φ ψ χ : formula σ) (H₁: Γ ⊢ (φ →' ψ)) (H₂ : Γ ⊢ (ψ  →' χ)) : Γ ⊢ (φ  →' χ) :=
begin
  apply impI,
  apply impE ψ,
  apply impE_insert H₁,
  apply weak1 H₂,
end

/--
  QoL proof_term rule for universal quantification elimination.
-/
def allE' {Γ} (φ) (t: term σ) {ψ}  (H : Γ ⊢ (∀'φ)) (h: ψ  = φ[t ⁄ 0]) : Γ ⊢ ψ :=
begin subst h, apply allE, assumption, end

/--
  Proof rule for a common case of universal quantification elimination.
-/
def allE_var0 {Γ} {φ: formula σ}  (H : Γ ⊢ (∀'φ) ↑ 1 ＠ 0) : Γ ⊢ φ  :=
begin
  apply allE' (φ ↑ 1 ＠ 1) #0,
  { exact H, },
  { symmetry, exact subst_var0_lift_by_1 φ 0, }
end

/--
  Proof rule for equality elimination. _(QoL)_
-/
def eqE' {Γ} {ψ}  (s t) (φ : formula σ) (H₁ : Γ ⊢ (s =' t)) (H₂ : Γ ⊢ (φ [s ⁄ 0])) (h:  ψ = φ[t ⁄ 0]) : Γ ⊢ ψ :=
begin rw h, apply eqE H₁ H₂, end

/-- Proof rule for congruence introduction. -/
def congrI {Γ} {t s₁ s₂: term σ} (H :  Γ ⊢ (s₁ =' s₂)) :  Γ ⊢ (t[s₁ ⁄ 0] =' t[s₂ ⁄ 0]):=
begin
  apply eqE' s₁ s₂ (((t[s₁⁄ 0] ↑ 1 ＠ 0)=' t)) H;
  rw [subst, term.subst_for_0_lift_by_1 (term.subst t _ 0) _],
  apply eqI,
end

/-- Proof rule for congruence introduction. -/
def congrI' {Γ} {t₁ s₁ t₂ s₂ : term σ} (t) (H: Γ ⊢ s₁ =' s₂)
  (h₁: t₁ = t[s₁ ⁄ 0]) (h₂: t₂ = t[s₂ ⁄ 0]) : Γ ⊢ (t₁ =' t₂) :=
begin rw [h₁, h₂], apply congrI H, end

/-- Proof rule for reflexivity of equality. -/
def eqI_refl {Γ} (t: term σ): Γ ⊢ (t =' t) := @eqI σ Γ t

/-- Proof rule for symmetry of equality. -/
def eqI_symm {Γ} (s t : term σ) (H : Γ ⊢ (s =' t)) : Γ ⊢ (t =' s) :=
begin
  apply eqE' s t (#0 =' (s ↑ 1 ＠ 0)) H;
  rw [subst, term.subst_var0, term.subst_for_0_lift_by_1],
  apply eqI,
end
/-- Proof rule for transitivity of equality. -/
def eqI_trans {Γ} (s t u : term σ) (H₁ : Γ ⊢ (s =' t)) (H₂ : Γ ⊢ (t =' u)) : proof_term Γ (s =' u) :=
begin
  apply eqE' t u ((s ↑ 1 ＠ 0) =' #0) H₂;
  rw[subst, term.subst_for_0_lift_by_1, term.subst_var0],
  assumption,
end

/- biconditionals -/

/-- Proof rule for introducing a biconditional. -/
def iffI {Γ} {φ ψ : formula σ} (H₁ : Γ ⊢ φ →' ψ) (H₂ : Γ ⊢ ψ →' φ)  : Γ ⊢ (φ  ↔' ψ) :=
begin apply andI; assumption, end

def iffE_r {Γ} {φ ψ : formula σ} (H : Γ ⊢ φ ↔' ψ)  : (Γ ⊢ φ →' ψ) := andE₁ _ H

def iffE_l {Γ} {φ ψ : formula σ} (H : Γ ⊢ φ ↔' ψ)  : (Γ ⊢ ψ →' φ) := andE₂ _ H

/--
  Proof rule for eliminating the right part of a biconditional.
-/
def iffE₁ {Γ} {φ: formula σ} (ψ : formula σ) (H₁ : Γ ⊢ ψ) (H₂ : Γ ⊢ φ ↔' ψ)  : Γ ⊢ φ :=
begin
  apply impE ψ,
  { exact H₁, },
  { apply andE₂, exact H₂, },
end

/-- Proof rule for eliminating the left part of a biconditional. -/
def iffE₂ {Γ} (φ) {ψ : formula σ} (H₁ : Γ ⊢ φ) (H₂ : Γ ⊢ φ ↔' ψ)  : (Γ ⊢  ψ) :=
begin
  apply impE φ,
  { exact H₁, },
  { apply andE₁, exact H₂, },
end

/-- Proof rule for reflexivity of biconditionals.-/
def iffI_refl {Γ} (φ : formula σ) : Γ ⊢ (φ ↔' φ) := begin apply iffI; apply impI_refl,end

/-- Proof rule for transitivity of biconditionals. -/
def iffI_trans {Γ} {φ} (ψ: formula σ) {χ}  (H₁: Γ ⊢ (φ ↔' ψ)) (H₂ : Γ ⊢ (ψ ↔' χ)) : Γ ⊢ (φ ↔' χ) :=
begin
    apply andI;
    apply impI_trans _ ψ _,
    apply andE₁ _ H₁, apply andE₁ _ H₂,
    apply andE₂ _ H₂, apply andE₂ _ H₁,
end

/-- Proof rule for symmetry of biconditionals. -/
def iffI_symm {Γ} {φ ψ: formula σ}  (H: Γ ⊢ (φ ↔' ψ)) : Γ ⊢ (ψ ↔' φ) :=
begin apply iffI, apply andE₂, exact H, apply andE₁, exact H, end

/-- Proof rule for substituting a term for free variable. -/
def substI {Γ} {φ : formula σ} (t k) (H: Γ ⊢ φ) : (λ ϕ, ϕ[t ⁄ k])'' Γ ⊢ φ[t ⁄ k] :=
begin
  induction H generalizing k,
  { apply hypI, exact mem_image_of_mem (λ (ϕ : preformula σ 0), ϕ [t ⁄ k]) H_h, },
  { apply botE, apply H_ih, },

  { apply impI, rw ← (@image_insert_eq _ _ (λ (x : preformula σ 0), x[t ⁄ k])), exact H_ih k, },
  { apply impE (H_φ [t ⁄ k]), exact H_ih_H₁ k, exact H_ih_H₂ k, },

  { apply andI, exact H_ih_H₁ k, exact H_ih_H₂ k, },
  { apply andE₁, exact H_ih k, },
  { apply andE₂, exact H_ih k, },

  { apply orI₁, exact H_ih k, },
  { apply orI₂, exact H_ih k, },
  { apply orE (H_φ [t ⁄ k]) (H_ψ [t ⁄ k]),
    apply H_ih_H k,
    have H₁:= H_ih_H₁ k, rw image_insert_eq at H₁, exact H₁,
    have H₂:= H_ih_H₂ k, rw image_insert_eq at H₂, exact H₂, },

  { apply allI, rw [image_image, lambda_lift_subst_formula(k.zero_le)],
    have H := H_ih (k+1), rw[image_image] at H, exact H, },
  { apply allE' _ (H_t[t ⁄ k]) (H_ih k), apply subst_subst, exact (k.zero_le), },

  { apply exI (H_t [t⁄ k]),
      have h:= subst_subst H_φ H_t t (k.zero_le),
      rw nat.sub_zero at h, rw ←h, exact H_ih k,},
  { apply exE (H_φ [t⁄(k+1)]), apply H_ih_H₁ k, rw lift_subst H_ψ t 1 0 k (k.zero_le),
      have h:= H_ih_H₂ (k+1),
      rw [image_insert_eq, image_image, ←lambda_lift_subst_formula(k.zero_le)] at h,
      rw [image_image], exact h, },

  { apply eqI_refl, },
  { apply eqE', apply H_ih_H₁ k,
    have h:= H_ih_H₂ k, rwa [subst_subst H_φ H_s t (k.zero_le), nat.sub_zero] at h,
    exact subst_subst H_φ H_t t (k.zero_le), }
end

/-- Proof rule for introducing `m` fresh variables at `i`. -/
def liftI {Γ} {φ : formula σ} (m i : ℕ) (H: Γ ⊢ φ)
  : (λ (ϕ :formula σ), ϕ ↑ m ＠ i) '' Γ ⊢ (φ ↑ m ＠ i) :=
begin
  induction H generalizing i,
  { apply hypI, exact mem_image_of_mem (λ (ϕ : preformula σ 0),  ϕ ↑ m ＠ i) H_h, },
  { apply botE, exact H_ih i, },

  { apply impI, have:= H_ih i, rwa image_insert_eq at this, },
  { apply impE (H_φ ↑ m ＠ i) , exact H_ih_H₁ i, exact H_ih_H₂ i,},

  { apply andI, apply H_ih_H₁ i, apply H_ih_H₂ i, },
  { apply andE₁, apply H_ih i, },
  { apply andE₂, apply H_ih i, },

  { apply orI₁, apply H_ih i, },
  { apply orI₂, apply H_ih i, },
  { apply orE, apply H_ih_H i,
    have H₁ := H_ih_H₁ i, rw image_insert_eq at H₁, exact H₁,
    have H₂ := H_ih_H₂ i, rw image_insert_eq at H₂, exact H₂, },

  { apply allI, rw[image_image, lambda_lift_lift _ _ (i.zero_le)],
    have h:= H_ih (i+1), rw[image_image] at h, exact h, },
  { apply allE' _ (H_t ↑ m ＠ i) (H_ih i),
    have h := eq.symm (subst_lift_in_lift H_φ H_t m i 0), exact h,},

  { apply exI (H_t ↑ m ＠ i),
    rw subst0_lift_by_lift H_φ,
    exact H_ih i,  },
  { apply exE (H_φ ↑ m ＠ (i+1)), apply H_ih_H₁ i,
    rw[image_image, lift_lift H_ψ m 1 (i.zero_le), lambda_lift_lift _ _ (i.zero_le)],
    have h := H_ih_H₂ (i+1), rw[image_insert_eq, image_image] at h, exact h, },

  { apply eqI_refl, },
  { apply eqE' _ _ _ (H_ih_H₁ i),
    have h₁:= symm (subst0_lift_by_lift H_φ),
    have h₂ := H_ih_H₂ i, rw h₁ at h₂, exact h₂,
    exact symm (subst0_lift_by_lift _), },
end

/-- Proof rule for removing a single fresh variables at `0`. -/
def liftE_h {Γ} {φ : formula σ} (m i : ℕ) (H:  (λ (ϕ :formula σ), ϕ ↑ 1 ＠ 0) '' Γ ⊢ (φ ↑ 1 ＠ 0))
  : Γ ⊢ φ :=
begin
  rw ←subst_for_0_lift_by_1 φ #0,
  apply allE,
  apply allI,
  exact H,
end

/-- Proof rule for binding the first `n` variables with universal quantifiers. -/
def allsI {Γ} {φ: formula σ}  (n) (H: (λ ϕ , ϕ ↑ n ＠ 0) '' Γ ⊢ φ) :  Γ ⊢ alls n φ  :=
begin
  induction n generalizing φ Γ,
  { simp [lift_by_0] at H, assumption,},
  { rw[alls],
    apply allI,
    have h : (λ (ϕ : preformula σ 0), ϕ ↑ n_n.succ ＠ 0)
      = (λ (ϕ : preformula σ 0), ϕ ↑ n_n ＠ 0) ∘ (λ (ϕ : preformula σ 0), ϕ ↑ 1＠ 0),
    begin funext, dsimp, rw lift_at_lift_merge, rw add_comm 1 n_n, end,
    rw [h, image_comp] at H,
    exact n_ih H, },
end
/-- Proof rule unbinding the `n` universal quantifiers. -/
def allsE  {Γ} {φ: formula σ}  (n i) (H :  Γ ⊢ (alls n φ)) :  Γ ⊢ substs n i 0 φ :=
begin
  induction n generalizing φ i,
  { exact H,},
  { rw substs_succ,
    apply allE,
    rw all_substs,
    rw [alls, all_alls] at H,
    exact n_ih (i+1) H, },
end

/-- Proof rule unbinding the `n` universal quantifiers. -/
def allsE' {Γ} (n) {φ  : formula σ} (H : Γ ⊢ (alls n φ)) : (λ ϕ , ϕ ↑ n ＠ 0) '' Γ ⊢ φ  :=
begin
  induction n generalizing φ Γ,
  { have h :  (λ (ϕ: formula σ) , ϕ ↑ 0 ＠ 0) = id, from begin funext, rw lift_by_0, refl, end,
    rw [h, image_id] at *,
    rwa alls at H, },
  { have h: (λ (ϕ : preformula σ 0), ϕ ↑ n_n.succ ＠ 0)
          = (λ (ϕ : preformula σ 0), ϕ ↑ 1 ＠ 0) ∘ (λ (ϕ : preformula σ 0), ϕ ↑ n_n ＠ 0),
    begin funext, dsimp, rw lift_at_lift_merge, end,
    rw [alls_succ] at H,
    apply allE_var0,
    rw [h,image_comp],
    apply liftI,
    exact n_ih H, },
end

-- def modus_tollens {Γ} {φ} (ψ: formula σ) (H₁: Γ ⊢ (φ →' ψ)) (H₂: Γ ⊢ ¬'ψ) : Γ ⊢ ¬'φ  :=
-- begin
--   apply impI,
--   apply impE ψ,
--   { apply impE_insert,
--    assumption, },
--   { apply weak1,
--     assumption, },
-- end
end proof_term

export proof_term

/-- Formal proof that there always exists an object of discourse. -/
def let_there_be_light : (∅ : set $ formula σ) ⊢ ∃'(#0 =' #0) :=
begin
  apply exI #0,
  apply eqI,
end

/- Two variants of
  "All men are mortal.
   Socrates is a man.
   Therefore, Socrates is mortal." .
-/

example {Γ:set $ formula σ}{φ ψ χ}  (H₁: Γ ⊢ ∀'(φ →' ψ))  (H₂: Γ ⊢ ∀'(ψ →' χ)) : Γ ⊢ ∀' (φ →' χ) :=
begin
  apply allI,
  apply impI,
  apply impE ψ,
  { apply impE_insert,
    apply allE' ((φ →' ψ) ↑ 1 ＠ 1) #0,
    rw ←formula.lift,
    apply liftI,
    exact H₁,
    rw subst_var0_lift_by_1, },
  { apply weak1,
    apply allE' ((ψ →' χ) ↑ 1 ＠ 1) #0,
    rw ←formula.lift,
    apply liftI,
    exact H₂,
    rw subst_var0_lift_by_1, },
end

example {Γ:set $ formula σ}{φ ψ χ}  (H₁: Γ ⊢ ∀'(φ →' ψ))  (H₂: Γ ⊢ ∀'(ψ →' χ)) : Γ ⊢ ∀' (φ →' χ) :=
begin
  apply allI,
  apply impI,
  apply impE ψ,
  apply impE_insert,
  swap,
  apply weak1,
  all_goals
  { apply allE' (_ ↑ 1 ＠ 1) #0,
    rw ←formula.lift,
    apply liftI,
    swap,
    rw subst_var0_lift_by_1,
    assumption, },
end

end proof_terms

end fol


import entanglement.basic

/-
/-- Thm. 1 in https://www.nature.com/articles/s41567-022-01873-9-/
theorem entanglement_theory_irreversible :
∃ ρ, distillable_entanglement ρ ≠ entanglement_cost ρ := sorry
-/


variables x : Type

constant duh : ℕ
constant doh : ℕ
constant dah : ℕ

lemma exercise : x = x := by refl

lemma another_exercise : 0 = 1 := sorry

lemma yet_another_exercise: ℕ × ℕ × ℕ := ⟨ duh, doh, dah ⟩


inductive Fam2 : Type → Type → Type 1 where
  | any : Fam2 α α
  | nat : Nat → Fam2 Nat Nat

example (a : α) (x : Fam2 α β) : β :=
  match α, β, a, x with
  | ?α, ?β, ?a, Fam2.any   => _
  | ?α, ?β, ?a, Fam2.nat n => _

example (a : α) (x : Fam2 α β) : β :=
  match x with
  | Fam2.any   => _
  | Fam2.nat n => _


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/

import category_theory.sites.grothendieck

/-!
# Grothendieck pretopologies

Definition and lemmas about Grothendieck pretopologies.
A Grothendieck pretopology for a category `C` is a set of families of morphisms with fixed codomain,
satisfying certain closure conditions.

We show that a pretopology generates a genuine Grothendieck topology, and every topology has
a maximal pretopology which generates it.

The pretopology associated to a topological space is defined in `spaces.lean`.

## Tags

coverage, pretopology, site

## References

* [nLab, *Grothendieck pretopology*](https://ncatlab.org/nlab/show/Grothendieck+pretopology)
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* [Stacks, *00VG*](https://stacks.math.columbia.edu/tag/00VG)
-/

universes v u
noncomputable theory

namespace category_theory

open category_theory category limits presieve

variables {C : Type u} [category.{v} C] [has_pullbacks C]

variables (C)

/--
A (Grothendieck) pretopology on `C` consists of a collection of families of morphisms with a fixed
target `X` for every object `X` in `C`, called "coverings" of `X`, which satisfies the following
three axioms:
1. Every family consisting of a single isomorphism is a covering family.
2. The collection of covering families is stable under pullback.
3. Given a covering family, and a covering family on each domain of the former, the composition
   is a covering family.

In some sense, a pretopology can be seen as Grothendieck topology with weaker saturation conditions,
in that each covering is not necessarily downward closed.

See: https://ncatlab.org/nlab/show/Grothendieck+pretopology, or
https://stacks.math.columbia.edu/tag/00VH, or [MM92] Chapter III, Section 2, Definition 2.
Note that Stacks calls a category together with a pretopology a site, and [MM92] calls this
a basis for a topology.
-/
@[ext]
structure pretopology :=
(coverings : Π (X : C), set (presieve X))
(has_isos : ∀ ⦃X Y⦄ (f : Y ⟶ X) [is_iso f], presieve.singleton f ∈ coverings X)
(pullbacks : ∀ ⦃X Y⦄ (f : Y ⟶ X) S, S ∈ coverings X → pullback_arrows f S ∈ coverings Y)
(transitive : ∀ ⦃X : C⦄ (S : presieve X)
               (Ti : Π ⦃Y⦄ (f : Y ⟶ X), S f → presieve Y), S ∈ coverings X →
               (∀ ⦃Y⦄ f (H : S f), Ti f H ∈ coverings Y) → S.bind Ti ∈ coverings X)

namespace pretopology

instance : has_coe_to_fun (pretopology C) (λ _, Π X : C, set (presieve X)) := ⟨coverings⟩

variable {C}

instance : has_le (pretopology C) :=
{ le := λ K₁ K₂, (K₁ : Π (X : C), set (presieve X)) ≤ K₂ }

lemma le_def {K₁ K₂ : pretopology C} : K₁ ≤ K₂ ↔ (K₁ : Π (X : C), set (presieve X)) ≤ K₂ := iff.rfl

variable (C)

instance : partial_order (pretopology C) :=
{ le_refl := λ K, le_def.mpr le_rfl,
  le_trans := λ K₁ K₂ K₃ h₁₂ h₂₃, le_def.mpr (le_trans h₁₂ h₂₃),
  le_antisymm := λ K₁ K₂ h₁₂ h₂₁, pretopology.ext _ _ (le_antisymm h₁₂ h₂₁),
  ..pretopology.has_le }

instance : order_top (pretopology C) :=
{ top :=
  { coverings := λ _, set.univ,
    has_isos := λ _ _ _ _, set.mem_univ _,
    pullbacks := λ _ _ _ _ _, set.mem_univ _,
    transitive := λ _ _ _ _ _, set.mem_univ _ },
  le_top := λ K X S hS, set.mem_univ _ }

instance : inhabited (pretopology C) := ⟨⊤⟩

/--
A pretopology `K` can be completed to a Grothendieck topology `J` by declaring a sieve to be
`J`-covering if it contains a family in `K`.

See <https://stacks.math.columbia.edu/tag/00ZC>, or [MM92] Chapter III, Section 2, Equation (2).
-/
def to_grothendieck (K : pretopology C) : grothendieck_topology C :=
{ sieves := λ X S, ∃ R ∈ K X, R ≤ (S : presieve _),
  top_mem' := λ X, ⟨presieve.singleton (𝟙 _), K.has_isos _, λ _ _ _, ⟨⟩⟩,
  pullback_stable' := λ X Y S g,
  begin
    rintro ⟨R, hR, RS⟩,
    refine ⟨_, K.pullbacks g _ hR, _⟩,
    rw [← sieve.sets_iff_generate, sieve.pullback_arrows_comm],
    apply sieve.pullback_monotone,
    rwa sieve.gi_generate.gc,
  end,
  transitive' :=
  begin
    rintro X S ⟨R', hR', RS⟩ R t,
    choose t₁ t₂ t₃ using t,
    refine ⟨_, K.transitive _ _ hR' (λ _ f hf, t₂ (RS _ hf)), _⟩,
    rintro Y _ ⟨Z, g, f, hg, hf, rfl⟩,
    apply t₃ (RS _ hg) _ hf,
  end }

lemma mem_to_grothendieck (K : pretopology C) (X S) :
  S ∈ to_grothendieck C K X ↔ ∃ R ∈ K X, R ≤ (S : presieve X) :=
iff.rfl

/--
The largest pretopology generating the given Grothendieck topology.

See [MM92] Chapter III, Section 2, Equations (3,4).
-/
def of_grothendieck (J : grothendieck_topology C) : pretopology C :=
{ coverings := λ X R, sieve.generate R ∈ J X,
  has_isos := λ X Y f i, by exactI J.covering_of_eq_top (by simp),
  pullbacks := λ X Y f R hR,
  begin
    rw [set.mem_def, sieve.pullback_arrows_comm],
    apply J.pullback_stable f hR,
  end,
  transitive := λ X S Ti hS hTi,
  begin
    apply J.transitive hS,
    intros Y f,
    rintros ⟨Z, g, f, hf, rfl⟩,
    rw sieve.pullback_comp,
    apply J.pullback_stable g,
    apply J.superset_covering _ (hTi _ hf),
    rintro Y g ⟨W, h, g, hg, rfl⟩,
    exact ⟨_, h, _, ⟨_, _, _, hf, hg, rfl⟩, by simp⟩,
  end }

/-- We have a galois insertion from pretopologies to Grothendieck topologies. -/
def gi : galois_insertion (to_grothendieck C) (of_grothendieck C) :=
{ gc :=
  λ K J,
  begin
    split,
    { intros h X R hR,
      exact h _ ⟨_, hR, sieve.le_generate R⟩ },
    { rintro h X S ⟨R, hR, RS⟩,
      apply J.superset_covering _ (h _ hR),
      rwa sieve.gi_generate.gc }
  end,
  le_l_u := λ J X S hS, ⟨S, J.superset_covering S.le_generate hS, le_rfl⟩,
  choice := λ x hx, to_grothendieck C x,
  choice_eq := λ _ _, rfl }

/--
The trivial pretopology, in which the coverings are exactly singleton isomorphisms. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See <https://stacks.math.columbia.edu/tag/07GE>
-/
def trivial : pretopology C :=
{ coverings := λ X S, ∃ Y (f : Y ⟶ X) (h : is_iso f), S = presieve.singleton f,
  has_isos := λ X Y f i, ⟨_, _, i, rfl⟩,
  pullbacks := λ X Y f S,
  begin
    rintro ⟨Z, g, i, rfl⟩,
    refine ⟨pullback g f, pullback.snd, _, _⟩,
    { resetI, refine ⟨⟨pullback.lift (f ≫ inv g) (𝟙 _) (by simp), ⟨_, by tidy⟩⟩⟩,
      apply pullback.hom_ext,
      { rw [assoc, pullback.lift_fst, ←pullback.condition_assoc],
        simp },
      { simp } },
    { apply pullback_singleton },
  end,
  transitive :=
  begin
    rintro X S Ti ⟨Z, g, i, rfl⟩ hS,
    rcases hS g (singleton_self g) with ⟨Y, f, i, hTi⟩,
    refine ⟨_, f ≫ g, _, _⟩,
    { resetI, apply_instance },
    ext W k,
    split,
    { rintro ⟨V, h, k, ⟨_⟩, hh, rfl⟩,
      rw hTi at hh,
      cases hh,
      apply singleton.mk },
    { rintro ⟨_⟩,
      refine bind_comp g presieve.singleton.mk _,
      rw hTi,
      apply presieve.singleton.mk }
  end }

instance : order_bot (pretopology C) :=
{ bot := trivial C,
  bot_le := λ K X R,
  begin
    rintro ⟨Y, f, hf, rfl⟩,
    exactI K.has_isos f,
  end }

/-- The trivial pretopology induces the trivial grothendieck topology. -/
lemma to_grothendieck_bot : to_grothendieck C ⊥ = ⊥ :=
(gi C).gc.l_bot

end pretopology

end category_theory


import data.bitvec
import data.dlist
import util.logic
import util.data.option
import util.control.applicative
import util.control.monad.non_termination
import util.control.monad.state
import util.meta.tactic
import util.predicate
import separation.heap
import separation.program

import logic.basic

universes u v w w'

open nat list function

namespace separation
open heap predicate
def hprop := pred' heap

def embed (p : Prop) : hprop :=
⟨ λ h, p ∧ h = heap.emp ⟩

notation `[| `p` |]` := embed p

def s_and (p q : hprop) : hprop :=
⟨ λ h, ∃ hp₀ hp₁,
         some h = part (some hp₀) (some hp₁) ∧
         p.apply hp₀ ∧
         q.apply hp₁ ⟩

infix ` :*: `:55 := s_and

def emp : hprop :=
⟨ λ h, h = heap.emp ⟩

@[simp]
protected lemma apply_emp (hp : heap)
: emp.apply hp ↔ hp = heap.emp :=
by refl

lemma exists_congr_elim {α : Sort u} {p : α → Prop} {q : Prop} (x : α)
  (h : ∀ y, p y ↔ y = x ∧ q)
: (∃ y, p y) ↔ q :=
by simp [h]

@[simp]
lemma s_and_emp (p : hprop)
: p :*: emp = p :=
by { cases p, funext i, simp_one_point [s_and], }

lemma s_and_comm (p q : hprop)
: p :*: q = q :*: p :=
begin
  cases p, cases q, simp [s_and],
  ext ihp,
  split ; simp ; intros hp₀ hp₁ hh h₀ h₁
  ; existsi [hp₁,hp₀]
  ; rw hh
  ; repeat { split <|> assumption <|> ac_refl },
end

@[simp]
lemma emp_s_and (p : hprop)
: emp :*: p = p :=
by rw [s_and_comm,s_and_emp]

def points_to (p : ℕ) (val : word) : hprop :=
⟨ λ h, h = maplet p val ⟩

infix ` ↦ `:60 := points_to

def points_to_multiple : ∀ (p : ℕ), list word → hprop
 | _ [] := emp
 | p (x :: xs) := p ↦ x :*: points_to_multiple (p+1) xs

infix ` ↦* `:60 := points_to_multiple

lemma points_to_multiple_iff_eq_heap_mk
  (p : pointer) (vs : list word) (hp : heap)
: (p ↦* vs).apply hp ↔ hp = heap.mk p vs :=
begin
  revert p hp,
  induction vs with v vs ; intros p hp,
  { simp [points_to_multiple], },
  { simp [points_to_multiple,heap.mk],
    split,
    { simp [s_and],
      intros hp₀ hp₁ H₀ H₁ H₂,
      rw vs_ih at H₂,
      change _ = _ at H₁,
      subst hp₁, subst hp₀,
      apply eq_part'_of_some_eq_part _ _ _ H₀, },
    { intros h₀,
      simp_one_point [s_and,(↦)],
      existsi [heap.mk (p + 1) vs],
      rw vs_ih, split,
      subst hp, rw [← some_part'],
      refl, apply maplet_disjoint_heap_mk,
      refl } }
end

structure spec (r : Type u) :=
  (pre : hprop)
  (post : r → hprop)

def sat {α} (p : program α) (s : spec α) : Prop :=
∀ (σ : hstate) hp₀ hp₁,
   some σ.heap = part (some hp₀) (some hp₁) →
   s.pre.apply hp₀ →
(∃ r σ' hp', p.run σ ~> (r, σ') ∧
            some σ'.heap = part (some hp') (some hp₁) ∧
            (s.post r).apply hp')

lemma s_and_part {hp₀ hp₁ : heap} {p₀ p₁ : hprop}
  (h : hp₀ ## hp₁)
  (Hp₀ : p₀.apply hp₀)
  (Hp₁ : p₁.apply hp₁)
: (p₀ :*: p₁).apply (part' hp₀ hp₁) :=
begin
  cases p₀, cases p₁, simp [s_and],
  split, split, split,
  rw [part], ite_cases, contradiction,
  split ; assumption,
end

lemma embed_eq_emp {p : Prop}
  (hp : p)
: [| p |] = emp :=
by simp [embed,emp,eq_true_intro hp]

@[simp]
lemma embed_s_and_apply {p : Prop} {q : hprop}
  (hp : heap)
: ([| p |] :*: q).apply hp ↔ p ∧ q.apply hp :=
by simp_one_point [s_and,embed]

def h_imp (p q : hprop) : Prop :=
p_entails p q

infix ` =*> `:41 := h_imp

lemma s_and_assoc (p q r : hprop)
: (p :*: q) :*: r = p :*: (q :*: r) :=
begin
  cases p with p, cases q with q, cases r with r,
  simp [s_and],
  ext hp,
  split ; simp,
  { intros hp_pq hp_r Hd_pqr ,
    intros hp_p hp_q Hpq Hp Hq,
    intros Hr,
    have Hd_qr : hp_q ## hp_r,
    { apply disjoint_of_is_some_part,
      apply is_some_of_is_some_part_right (some hp_p),
      apply is_some_of_eq_some hp,
      simp [Hd_pqr,Hpq], ac_refl },
    existsi [hp_p,part' hp_q hp_r Hd_qr], -- ],
    simp [Hd_pqr,Hpq],
    split, ac_refl,
    let hp_qr := part' hp_q hp_r,
    existsi [Hp,hp_q,hp_r,rfl],
    split ; assumption, },
  { intros hp_p hp_qr Hd_pqr Hp,
    intros hp_q hp_r H_qr Hq Hr,
    have Hd_pq : hp_p ## hp_q,
    { apply disjoint_of_is_some_part,
      apply is_some_of_is_some_part_right (some hp_r),
      apply is_some_of_eq_some hp,
      simp [Hd_pqr,H_qr], ac_refl },
    let hp_pq := part' hp_p hp_q,
    existsi [hp_pq,hp_r],
    split, simp [Hd_pqr,H_qr], ac_refl,
    split,
    { existsi [hp_p,hp_q], simp,
      split ; assumption, },
    assumption }
end

lemma embed_s_and_embed (p q : Prop)
: [| p |] :*: [| q |] = [| p ∧ q |] :=
begin
  unfold embed emp s_and, apply congr_arg,
  apply funext, intro, simp_one_point,
  ac_refl
end

@[simp]
lemma embed_s_and_self (p : Prop)
: [| p |] :*: [| p |] = [| p |] :=
by simp [embed_s_and_embed]

@[refl]
lemma s_imp_refl (p : hprop)
: p =*> p :=
by { lifted_pred }

@[trans]
lemma s_imp_trans {p : hprop} (q : hprop) {r : hprop}
  (h₀ : p =*> q)
  (h₁ : q =*> r)
: p =*> r :=
by { lifted_pred using h₀ h₁, intro ; solve_by_elim }

lemma s_exists_intro  {α : Type u}
  {p : hprop} {q : α → hprop} (x : α)
  (h : p =*> q x)
: p =*> ∃∃ x, q x :=
by { transitivity, apply h, apply p_exists_intro x, }

lemma s_exists_elim  {α : Type u}
  {p : α → hprop} {q : hprop} (x : α)
  (h : ∀ x, p x =*> q)
: (∃∃ x, p x) =*> q :=
begin
  simp [h_imp,p_exists_entails_eq_p_forall_entails],
  apply h,
end

lemma s_imp_of_eq {p q : hprop}
  (h : p = q)
: p =*> q :=
by rw h

-- @[congr]
-- lemma s_exists_congr {α : Type u}
--   {p q : α → hprop}
--   (h : ∀ x, p x = q x)
-- : hexists p = hexists q :=
-- begin
--   unfold hexists,
--   congr,
--   simp [h],
-- end

lemma s_exists_s_and_distr {α : Type u}
  (p : α → hprop) (q : hprop)
: (∃∃ x, p x) :*: q = (∃∃ x, p x :*: q) :=
begin
  simp [s_and,p_exists],
  congr, funext hp,
  apply iff.to_eq,
  split ; simp ; intros,
  { split, split, split,
    existsi a,
    existsi a_1,
    assumption },
  { split, split,
    existsi a,
    split, split, assumption,
    assumption },
end

lemma s_and_s_exists_distr {α : Type u}
  (p : α → hprop) (q : hprop)
: q :*: (∃∃ x, p x) = (∃∃ x, q :*: p x) :=
begin
  rw [s_and_comm,s_exists_s_and_distr], congr,
  funext hp, apply s_and_comm,
end

lemma s_and_s_imp_s_and
  {p q r s : hprop}
  (h₀ : p =*> r)
  (h₁ : q =*> s)
: p :*: q =*> r :*: s :=
begin
  lifted_pred ,
  simp only [s_and],
  intros_mono,
  apply and.imp
  ; apply entails_of_forall_impl _ _ ; assumption,
end

lemma s_and_s_imp_s_and_left
  (p : hprop) {q s : hprop}
  (h₁ : q =*> s)
: p :*: q =*> p :*: s :=
by { apply s_and_s_imp_s_and _ h₁, refl }

@[monotonic]
lemma s_and_s_imp_s_and_right
  {p : hprop} (q : hprop) {r : hprop}
  (h₀ : p =*> r)
: p :*: q =*> r :*: q :=
by { apply s_and_s_imp_s_and h₀, refl }

instance : comm_monoid hprop :=
{ mul := s_and
, one := emp
, mul_one := by { intros, simp [has_mul.mul] }
, one_mul := by { intros, simp [has_mul.mul] }
, mul_assoc := by { intros, simp [s_and_assoc] }
, mul_comm := by { intros, apply s_and_comm, } }

-- -- @[priority 1000]
-- instance : is_left_id hprop s_and emp :=
-- show is_left_id hprop has_mul.mul 1, by apply_instance

-- -- @[priority 1000]
-- instance : is_right_id hprop s_and emp :=
-- show is_right_id hprop has_mul.mul 1, by apply_instance

section

variables {α β : Type}
variables {P : program α}
variable {P' : α → program β}
variables {p p₀ p₁ q : hprop}
variables {r r₁ : α → hprop}
variables {r' : β → hprop}
variable {s : spec α}

lemma framing_right (q : hprop)
  (h : sat P { pre := p, post := r })
: sat P { pre := p :*: q, post := λ x, r x :*: q } :=
begin
  unfold sat spec.pre spec.post,
  introv Hpart Hpre,
  cases Hpre with hp₂ Hpre, cases Hpre with hp₃ Hpre,
  rw Hpre.left at Hpart,
  cases Hpre with Hpre₀ Hpre₁, cases Hpre₁ with Hpre₁ Hpre₂,
  simp [Hpart],
  have h' : hp₃ ## hp₁,
  { apply disjoint_of_is_some_part,
    apply is_some_of_is_some_part_right (some hp₂),
    apply is_some_of_eq_some σ.heap,
    simp [Hpart], ac_refl },
  specialize h σ hp₂ (part' hp₃ hp₁),
  simp [Hpart] at h, specialize h (by ac_refl) Hpre₁,
  revert h,
  intros_mono rr σ',
  simp, intros H_yield hp' H_p' Hr,
  have Hd_p'_p₃ : hp' ## hp₃,
  { apply disjoint_of_is_some_part,
    apply is_some_of_is_some_part_right (some hp₁),
    apply is_some_of_eq_some σ'.heap,
    simp [H_p'], ac_refl },
  existsi [H_yield,part' hp' hp₃],-- [s_and_part _ Hr Hpre₂,H_yield],
  simp [H_p'], split, ac_refl, apply s_and_part _ Hr Hpre₂,
end

lemma framing_left (q : hprop)
  (h : sat P { pre := p, post := r })
: sat P { pre := q :*: p, post := λ x, q :*: r x } :=
begin
  have h := framing_right q h,
  apply eq.mp _ h,
  apply congr_arg,
  apply congr, ac_refl,
  funext x,
  ac_refl,
end

lemma bind_spec (r : α → hprop)
  (h  : sat P { pre := p, post := r })
  (h' : ∀ x, sat (P' x) { pre := r x, post := r' })
: sat (P >>= P') { pre := p, post := r' } :=
begin
  unfold sat, introv h₂ h₃,
  specialize h σ hp₀ hp₁ h₂ h₃,
  cases h with x h,
  cases h with σ' h,
  cases h with hp' h,
  cases h with Hspec₀ h,
  cases h with Hspec₁ Hspec₂, simp at Hspec₂,
  specialize h' x σ' hp' hp₁ Hspec₁ Hspec₂,
  revert h',
  intros_mono r'' σ'' hp'',
  apply and.imp, intros h₀,
  apply nonterm.yields_bind _ _ Hspec₀,
  apply h₀, apply id,
end

lemma postcondition (r : α → hprop)
 (Hspec : sat P { pre := p, post := r })
 (Hside : ∀ x, r x = r₁ x)
: sat P { pre := p, post := r₁ } :=
begin
  apply eq.mp _ Hspec,
  congr, funext x,
  apply Hside,
end

lemma postcondition' (r : α → hprop)
 (Hspec : sat P { pre := p, post := r })
 (Hside : ∀ x, r x =*> r₁ x)
: sat P { pre := p, post := r₁ } :=
begin
  intros _ _ _ H₀ H₁,
  specialize Hspec _ _ _ H₀ H₁,
  revert Hspec,
  intros_mono x hp₀ hp₁ _ _,
  apply entails_of_forall_impl,
  apply Hside _,
end

lemma precondition (p : hprop)
 (Hspec : sat P { pre := p, post := r })
 (Hside : p = q)
: sat P { pre := q, post := r } :=
by { subst q, apply Hspec }

lemma precondition' (p : hprop)
 (Hspec : sat P { pre := p, post := r })
 (Hside : q =*> p)
: sat P { pre := q, post := r } :=
begin
  revert Hspec, unfold sat,
  intros_mono σ hp₀ hp₁ h _,
  apply entails_of_forall_impl,
  apply Hside ,
end

lemma bind_framing_left (p₁ : hprop)
  (H₀ : sat P { pre := p₀, post := r })
  (H₂ : p = p₀ :*: p₁)
  (H₁ : ∀ x, sat (P' x) { pre := r x :*: p₁, post := r' } )
: sat (P >>= P') { pre := p, post := r' } :=
begin
  apply precondition _ _ H₂.symm,
  apply bind_spec (λ x, r x :*: p₁),
  { apply framing_right _ H₀, },
  apply H₁,
end

lemma bind_framing_right (p₀ : hprop)
  (H₀ : sat P { pre := p₁, post := r })
  (H₂ : p = p₀ :*: p₁)
  (H₁ : ∀ x, sat (P' x) { pre := p₀ :*: r x, post := r' } )
: sat (P >>= P') { pre := p, post := r' } :=
begin
  simp [s_and_comm p₀ _] at H₁,
  apply bind_framing_left p₀ H₀ _ H₁,
  rw H₂, ac_refl
end

lemma s_exists_intro_pre {α : Type u} {P : program β} {r : α → hprop}
  (H : ∀ x, sat P { pre := r x, post := r' })
: sat P { pre := (∃∃ x, r x), post := r' } :=
begin
  intros _ _ _ H₀ H₁,
  cases H₁ with x H₁,
  apply H x _ _ _ H₀ H₁,
end

lemma s_exists_elim_pre {α : Type u} {P : program β} {r : α → hprop} (x : α)
  (H : sat P { pre := (∃∃ x, r x), post := r' })
: sat P { pre := r x, post := r' } :=
begin
  intros _ _ _ H₀ H₁,
  apply H _ _ _ H₀ ⟨_,H₁⟩,
end

lemma s_exists_replace_pre {t : Type w} {α : Type w'} {r : α → hprop} {P : program β}
  (f : t → α) (g : α → t) (I : left_inverse f g)
  (H : sat P { pre := (∃∃ x, r (f x)), post := r' })
: sat P { pre := (∃∃ x, r x), post := r' } :=
begin
  apply s_exists_intro_pre,
  intro x,
  rw ← I x,
  apply s_exists_elim_pre (g x) H
end

lemma s_exists_intro_post {P : program β} {b : α → β → hprop} (x : α)
  (H : sat P { pre := p, post := b x })
: sat P { pre := p, post := λ r, ∃∃ x, b x r } :=
begin
  intros _ _ _ H₀ H₁,
  specialize H _ _ _ H₀ H₁,
  revert H,
  intros_mono y hp hp' _ _,
  apply Exists.intro x
end

lemma adapt_spec
  (h : sat P { pre := p₁, post := r₁ })
  (Hpre : p = p₁)
  (Hpost : ∀ x, r x = r₁ x)
: sat P { pre := p, post := λ x, r x } :=
by simp [Hpre,Hpost,h]

lemma adapt_spec'
  (h : sat P { pre := p₁, post := r₁ })
  (Hpre : p =*> p₁)
  (Hpost : ∀ x, r x = r₁ x)
: sat P { pre := p, post := λ x, r x } :=
begin
  apply precondition' _ _ Hpre,
  apply postcondition r₁ h,
  intro, symmetry, apply Hpost
end

lemma framing_spec'  (q : hprop)
  (h : sat P { pre := p₁, post := r₁ })
  (Hpre : p =*> p₁ :*: q)
  (Hpost : ∀ x, r₁ x :*: q =*> r x)
: sat P { pre := p, post := λ x, r x } :=
begin
  apply precondition' _ _ Hpre,
  apply postcondition' _ _ Hpost,
  apply framing_right _ h,
end

lemma framing_spec  (q : hprop)
  (h : sat P { pre := p₁, post := r₁ })
  (Hpre : p = p₁ :*: q)
  (Hpost : ∀ x, r x = r₁ x :*: q)
: sat P { pre := p, post := λ x, r x } :=
begin
  simp [Hpre,Hpost],
  apply framing_right _ h
end

lemma context_left (p : Prop)
 (H : p → sat P { pre := q, post := r })
: sat P { pre := [| p |] :*: q, post := r } :=
begin
  intros _ _ _ H₀ H₁,
  simp at H₁,
  apply H H₁.1 _ _ _ H₀ H₁.2,
end

lemma context_right (p : Prop)
 (H : p → sat P { pre := q, post := r })
: sat P { pre := q :*: [| p |], post := r } :=
begin
  rw s_and_comm,
  apply context_left _ H
end

lemma return.spec {α : Type} (x : α) (p : α → hprop)
: sat (return x) { pre := p x, post := λ y, p y } :=
begin
  intros _ _ _ H₀ H₁,
  existsi [x,σ,hp₀,nonterm.pure_yields _,H₀],
  assumption
end

lemma return.spec' {α : Type} (x : α) (p : hprop)
: sat (return x) { pre := p, post := λ _, p } :=
return.spec _ _

lemma read.spec (p : pointer) (v : word)
: sat (read p) { pre := p ↦ v
               , post := λ r, [| r = v |] :*: p ↦ v } :=
begin
  intros _ _ _ H₀ H₁,
  existsi [v,σ,hp₀],
  simp at *, simp [H₀,H₁],
  simp [read,return,has_bind.bind,state_t.bind],
  apply nonterm.yields_bind,
  apply nonterm.pure_yields,
  simp [points_to] at H₁,
  simp [state_t.bind._match_1,state_t.lift],
  simp [H₁] at H₀,
  rw [← opt_apl_some (σ.heap) p,H₀,opt_apl_part_maplet],
  simp [pure_bind],
  apply nonterm.pure_yields,
  apply disjoint_of_is_some_part,
  apply is_some_of_eq_some σ.heap H₀,
end

lemma read_head.spec (p : pointer) (v : word) (vs : list word)
: sat (read p) { pre := p ↦* v :: vs
               , post := λ r, [| r = v |] :*: p ↦* v :: vs } :=
begin
  simp [points_to_multiple,s_and_assoc],
  apply framing_spec (p + 1 ↦* vs) (read.spec p v),
  { ac_refl },
  intro, ac_refl,
end

lemma read_nth.spec (p : pointer) (i : ℕ) (vs : list word)
  (H : i < vs.length)
: sat (read_nth p i _ H)
      { pre := p ↦* vs,
        post := λ r, [| r = nth_le vs i H |] :*: p ↦* vs } :=
begin
  revert p i,
  induction vs with x xs ; introv,
  { cases not_lt_zero _ H },
  cases i with i,
  { simp [read_nth,points_to_multiple],
    apply framing_spec (p+1 ↦* xs),
    apply read.spec _ x, refl,
    intros r,
    rw [← s_and_assoc], },
  { simp [read_nth,points_to_multiple],
    rw [add_succ,← succ_add],
    apply framing_spec (p ↦ x),
    { specialize vs_ih (p+1) i (lt_of_succ_lt_succ H),
      simp [add_one,read_nth] at vs_ih,
      rw [add_comm] at vs_ih, apply vs_ih },
    { rw s_and_comm },
    intro r, rw [s_and_comm  (p ↦ x), ← s_and_assoc],
    congr, }
end

lemma write.spec (p : pointer) (v v' : word)
: sat (write p v') { pre := p ↦ v, post := λ r, p ↦ v' } :=
begin
  intros _ _ _ H₀ H₁,
  unfold write,
  existsi (),
  split, existsi (hp₀.insert p v'),
  simp ,
  constructor_matching* (_ ∧ _),
  show heap.insert hp₀ p v' ⊨ p ↦ v',
  { change _ = _ at H₁,
    change _ = _, rw H₁,
    funext x,
    by_cases h : p = x ;
    simp [heap.insert,maplet,h], },
  show _ ~> _,
  { rw [dif_pos,state_t.put],
    apply nonterm.pure_yields,
    simp [points_to] at H₁,
    rw [← opt_apl_some σ.heap,H₀,H₁,opt_apl_part_maplet ],
    exact rfl,
    subst hp₀,
    apply disjoint_of_part_eq_some H₀ },
  { have H := disjoint_of_part_eq_some H₀,
    rw [← some_part',part'_insert _ _ _ _ _ H],
    rw ← some_part' _ _ H at H₀, injection H₀,
    simp, rw [h_1],
    { change _ = _ at H₁, subst hp₀,
      rw maplet_insert_disjoint_iff,
      assumption }, }
end

def replace {α} (f : α → α) : ℕ → list α → list α
  | i [] := []
  | 0 (x :: xs) := f x :: xs
  | (succ i) (x :: xs) := x :: replace i xs

lemma write_head.spec (p : pointer) (v v' : word) (vs : list word)
: sat (write p v') { pre := p ↦* v :: vs, post := λ _, p ↦* v' :: vs } :=
begin
  simp [(↦*)],
  apply framing_right,
  apply write.spec,
end

lemma write_nth.spec (p : pointer) (v' : word) (i : ℕ) (vs : list word)
  (H : i < vs.length)
: sat (write_nth p i _ v' H)
   { pre := p ↦* vs
   , post := λ _, p ↦* replace (const _ v') i vs } :=
begin
  revert p i,
  induction vs with v vs ; intros p i H,
  { cases not_lt_zero _ H },
  cases i with i,
  { simp [write_nth],
    apply write_head.spec },
  { simp [write_nth,add_succ,replace,(↦*)],
    rw ← succ_add,
    apply framing_left,
    apply vs_ih,
    apply lt_of_succ_lt_succ H, }
end

lemma modify.spec (p : pointer) (f : word → word) (v : word)
: sat (modify p f) { pre := p ↦ v, post := λ _, p ↦ f v } :=
begin
  unfold modify,
  apply bind_spec _ (read.spec p v),
  intro x, simp [function.comp],
  apply context_left,
  intro, subst x,
  apply write.spec
end

lemma modify_head.spec (p : pointer) (f : word → word) (v : word) (vs : list word)
: sat (modify p f) { pre := p ↦* v :: vs, post := λ _, p ↦* f v :: vs } :=
begin
  unfold points_to_multiple,
  apply framing_right,
  apply modify.spec,
end

lemma modify_nth.spec (p : pointer) (f : word → word) (i : ℕ) (vs : list word)
  (H : i < vs.length)
: sat (modify (p+i) f) { pre := p ↦* vs, post := λ _, p ↦* replace f i vs } :=
begin
  revert i p,
  induction vs with v vs
  ; intros i p H,
  { cases nat.not_lt_zero _ H, },
  cases i,
  case zero
  { simp [replace],
    apply modify_head.spec },
  case succ : i
  { simp [replace,points_to_multiple],
    apply framing_left,
    rw [add_succ,add_succ,← succ_add,add_zero],
    apply vs_ih i (succ p),
    apply lt_of_succ_lt_succ H, }
end

lemma alloc.spec (vs : list word)
: sat (alloc vs) { pre := emp, post := λ r, [| r ≠ 0 |] :*: r ↦* vs } :=
begin
  simp [alloc,sat],
  intros _ _ _ H₀ H₁,
  -- simp [state_t.get_bind],
  existsi σ.next+1,
  existsi { hstate . .. }, split,
  { apply nonterm.pure_yields, },
  have : ¬σ.next+1 = 0,
  { apply ne_of_gt,
    apply zero_lt_succ, },
  { simp [hstate.heap,this], simp [H₁] at H₀,
    let p := σ.next+1,
    have h' : heap.mk p vs ## σ.heap,
    { apply is_free, apply le_succ, },
    subst hp₁,
    simp_one_point [points_to_multiple_iff_eq_heap_mk,some_insert_left_eq_part h'] },
end

lemma alloc1.spec (v : word)
: sat (alloc1 v) { pre := emp, post := λ r, [| r ≠ 0 |] :*: r ↦ v } :=
begin
  have h := alloc.spec [v],
  unfold points_to_multiple at h,
  simp [s_and_emp] at h,
  apply h
end

lemma free.spec (p : pointer) (n : ℕ) (vs : list word)
  (h : n = length vs)
: sat (free p n) { pre := p ↦* vs, post := λ r, emp } :=
begin
  unfold sat,
  introv H₀ H₁,
  existsi [()],
  split, existsi heap.emp,
  simp [free,nonterm.pure_yields],
  split, apply nonterm.pure_yields,
  simp, subst n,
  rw points_to_multiple_iff_eq_heap_mk at H₁,
  rw H₁ at H₀,
  have H₂ := eq_part'_of_some_eq_part _ _ _ H₀,
  rw [H₂,delete_part'_heap_mk],
end

lemma free1.spec (p : pointer) (v : word)
: sat (free1 p) { pre := p ↦ v, post := λ r, emp } :=
begin
  have h := free.spec p 1 [v] rfl,
  simp [points_to_multiple] at h,
  apply h,
end

lemma copy.spec (p q : pointer) (v₀ v₁ : word)
: sat (copy p q) { pre := p ↦ v₀ :*: q ↦ v₁
                 , post := λ _, p ↦ v₁ :*: q ↦ v₁ } :=
begin
  apply bind_spec (λ r, p ↦ v₀ :*: ([| r = v₁ |] :*: q ↦ v₁)),
  { apply framing_left, apply read.spec },
  { intro r, simp,
    apply precondition (p ↦ v₀ :*: q ↦ v₁ :*: [| r = v₁ |]),
    { apply context_right, intro, subst r,
      apply framing_right,
      apply write.spec },
    { ac_refl } }
end

end

end separation


import logic.function.basic
import tactic

lemma aux_1
  {α β : Type}
  [decidable_eq α]
  (g : α → β)
  (f f' : α → α)
  (x : α)
  (a : β)
  (h1 : f' ∘ f = id) :
  (function.update g (f x) a) ∘ f = function.update (g ∘ f) x a :=
begin
  have s1 : function.left_inverse f' f,
  exact congr_fun h1,

  apply function.update_comp_eq_of_injective,
  exact function.left_inverse.injective s1,
end

lemma aux_2
  {α β : Type}
  [decidable_eq α]
  (g : α → β)
  (f f' : α → α)
  (x : α)
  (a : β)
  (h1 : f' ∘ f = id)
  (h2 : f ∘ f' = id) :
  (function.update g x a) ∘ f = function.update (g ∘ f) (f' x) a :=
begin
  rewrite <- aux_1 g f f' (f' x) a h1,
  congr,
  rewrite <- function.comp_app f f' x,
  rewrite h2,
  exact id.def x,
end

lemma aux_3
  {α β : Type}
  [decidable_eq α]
  (f g : α → β)
  (x : α)
  (h1 : ∀ (y : α), ¬ y = x → f y = g y) :
  function.update f x (g x) = g :=
begin
  apply funext, intros y,
  by_cases c1 : y = x,
  {
    rewrite c1,
    simp only [function.update_same],
  },
  {
    simp only [function.update_noteq c1],
    exact h1 y c1,
  },
end

lemma nodup_eq_len_imp_eqv
  {α : Type}
  (l1 l2 : list α)
  (h1 : l1.length = l2.length)
  (h2 : l1.nodup)
  (h3 : l2.nodup) :
  ∃ (f : α ≃ α), l1.map f = l2 :=
begin
  classical,
  induction l1 with x l1 ih generalizing l2,
  { rw [list.length, eq_comm] at h1,
    cases list.eq_nil_of_length_eq_zero h1,
    use equiv.refl _,
    refl, },
  cases l2 with y l2,
  { cases h1 },
  simp only [list.length, add_left_inj] at h1,
  simp only [list.nodup_cons] at h2 h3,
  obtain ⟨f, hf⟩ := ih h2.2 l2 h1 h3.2,
  have : f x ∉ l2 := by simp [← hf, h2],
  use f.trans (equiv.swap y (f x)),
  simp only [list.map, equiv.coe_trans, function.comp_app, equiv.swap_apply_right,
    eq_self_iff_true, true_and],
  rw ← hf,
  refine list.map_congr (λ z hz, _),
  simp only [function.comp_app],
  apply equiv.swap_apply_of_ne_of_ne,
  { rintro rfl,
    apply h3.1,
    simpa only [←hf, list.mem_map, embedding_like.apply_eq_iff_eq, exists_eq_right] using hz },
  { intro h,
    apply this,
    rw [← h, ← hf],
    simpa using hz }
end

lemma list.nth_le_mem_zip
  {α β : Type}
  [decidable_eq α]
  (l1 : list α)
  (l2 : list β)
  (n : ℕ)
  (h1 : n < l1.length)
  (h2 : n < l2.length) :
  ((l1.nth_le n h1, l2.nth_le n h2) ∈ l1.zip l2) :=
begin
  have s1 : n < (l1.zip l2).length,
  simp only [list.length_zip, lt_min_iff],
  split,
  {
    exact h1,
  },
  {
    exact h2,
  },

  have s2 : (list.zip l1 l2).nth_le n s1 = (l1.nth_le n h1, l2.nth_le n h2),
  exact list.nth_le_zip,

  rewrite <- s2,
  exact (list.zip l1 l2).nth_le_mem n s1,
end

lemma list.map_fst_zip_is_prefix
  {α β : Type}
  (l1 : list α)
  (l2 : list β) :
  list.map prod.fst (l1.zip l2) <+: l1 :=
begin
  induction l1 generalizing l2,
  case list.nil : l2
  {
    simp only [list.zip_nil_left, list.map_nil],
  },
  case list.cons : l1_hd l1_tl l1_ih l2
  {
    induction l2,
    case list.nil
    {
      unfold list.is_prefix,
      apply exists.intro (l1_hd :: l1_tl),
      simp only [list.zip_nil_right, list.map_nil, list.nil_append, eq_self_iff_true, and_self],
    },
    case list.cons : l2_hd l2_tl l2_ih
    {
      simp only [list.map, list.zip_cons_cons],
      rewrite list.prefix_cons_inj,
      exact l1_ih l2_tl,
    },
  },
end

lemma list.map_fst_zip_nodup
  {α β : Type}
  (l1 : list α)
  (l2 : list β)
  (h1 : l1.nodup) :
  (list.map prod.fst (l1.zip l2)).nodup :=
begin
  have s1 : list.map prod.fst (l1.zip l2) <+ l1,
  apply list.is_prefix.sublist,
  exact l1.map_fst_zip_is_prefix l2,

  exact list.nodup.sublist s1 h1,
end

def function.update_list
  {α β : Type}
  [decidable_eq α]
  (f : α → β) :
  list (α × β) → α → β
| [] := f
| (hd :: tl) := function.update (function.update_list tl) hd.fst hd.snd

#eval function.update_list (fun (n : ℕ), n) [(0,1), (3,2), (0,2)] 0

lemma function.update_list_mem
  {α β : Type}
  [decidable_eq α]
  (f : α → β)
  (l : list (α × β))
  (x : α × β)
  (h1 : list.nodup (list.map prod.fst l))
  (h2 : x ∈ l) :
  function.update_list f l x.fst = x.snd :=
begin
  induction l,
  case list.nil
  {
    simp only [list.not_mem_nil] at h2,
    contradiction,
  },
  case list.cons : hd tl ih
  {
    simp only [list.map, list.nodup_cons, list.mem_map, prod.exists,
      exists_and_distrib_right, exists_eq_right, not_exists] at h1,
    cases h1,

    simp only [list.mem_cons_iff] at h2,

    unfold function.update_list,
    cases h2,
    {
      rewrite h2,
      simp only [function.update_same],
    },
    {
      have s1 : ¬ x.fst = hd.fst,
      intro contra,
      apply h1_left x.snd,
      rewrite <- contra,
      simp only [prod.mk.eta],
      exact h2,

      simp only [function.update_noteq s1],
      exact ih h1_right h2,
    }
  },
end

lemma function.update_list_not_mem
  {α β : Type}
  [decidable_eq α]
  (f : α → β)
  (l : list (α × β))
  (x : α)
  (h1 : x ∉ list.map prod.fst l) :
  function.update_list f l x = f x :=
begin
  induction l,
  case list.nil
  {
    unfold function.update_list,
  },
  case list.cons : hd tl ih
  {
    simp only [list.map, list.mem_cons_iff, list.mem_map, prod.exists,
      exists_and_distrib_right, exists_eq_right] at h1,
    push_neg at h1,
    cases h1,

    unfold function.update_list,
    simp only [function.update_noteq h1_left],
    apply ih,
    simp only [list.mem_map, prod.exists, exists_and_distrib_right, exists_eq_right, not_exists],
    exact h1_right,
  },
end

lemma function.update_list_mem_ext
  {α β : Type}
  [decidable_eq α]
  (f g : α → β)
  (l : list (α × β))
  (x : α)
  (h1 : x ∈ list.map prod.fst l) :
  function.update_list f l x = function.update_list g l x :=
begin
  induction l,
  case list.nil
  {
    simp only [list.map_nil, list.not_mem_nil] at h1,
    contradiction,
  },
  case list.cons : hd tl ih
  {
    simp only [list.map, list.mem_cons_iff] at h1,

    unfold function.update_list,
    by_cases c1 : x = hd.fst,
    {
      rewrite c1,
      simp only [function.update_same],
    },
    {
      simp only [function.update_noteq c1],
      cases h1,
      {
        contradiction,
      },
      {
        exact ih h1,
      }
    },
  },
end

lemma function.update_list_zip_mem_ext
  {α β : Type}
  [decidable_eq α]
  (f g : α → β)
  (l1 : list α)
  (l2 : list β)
  (x : α)
  (h1 : l1.length ≤ l2.length)
  (h2 : x ∈ l1) :
  function.update_list f (l1.zip l2) x =
    function.update_list g (l1.zip l2) x :=
begin
  have s1 : x ∈ list.map prod.fst (l1.zip l2),
  rewrite list.map_fst_zip l1 l2 h1,
  exact h2,

  exact function.update_list_mem_ext f g (list.zip l1 l2) x s1,
end

lemma function.update_list_zip_map_mem_ext
  {α β : Type}
  [decidable_eq α]
  (l1 l2 : list α)
  (f g h : α → β)
  (x : α)
  (h1 : l1.length ≤ l2.length)
  (h2 : x ∈ l1) :
  function.update_list f (l1.zip (list.map h l2)) x =
    function.update_list g (l1.zip (list.map h l2)) x :=
begin
  have s1 : l1.length ≤ (list.map h l2).length,
  simp only [list.length_map],
  exact h1,

  exact function.update_list_zip_mem_ext f g l1 (list.map h l2) x s1 h2,
end

lemma function.update_list_zip_map_mem_ext'
  {α β : Type}
  [decidable_eq α]
  (l1 l2 : list α)
  (f g h h' : α → β)
  (x : α)
  (h1 : ∀ (y : α), y ∈ l2 → h y = h' y)
  (h2 : l1.length ≤ l2.length)
  (h3 : x ∈ l1) :
  function.update_list f (l1.zip (list.map h l2)) x =
    function.update_list g (l1.zip (list.map h' l2)) x :=
begin
  have s1 : list.map h l2 = list.map h' l2,
  rewrite list.map_eq_map_iff,
  exact h1,

  rewrite s1,
  exact function.update_list_zip_map_mem_ext l1 l2 f g h' x h2 h3,
end

lemma function.update_list_zip_map_mem
  {α β : Type}
  [decidable_eq α]
  (f g : α → β)
  (l : list α)
  (x : α)
  (h1 : x ∈ l) :
  function.update_list f (l.zip (list.map g l)) x = g x :=
begin
  induction l,
  case list.nil
  {
    simp only [list.not_mem_nil] at h1,
    contradiction,
  },
  case list.cons : hd tl ih
  {
    simp only [list.mem_cons_iff] at h1,

    simp only [list.map, list.zip_cons_cons],
    unfold function.update_list,
    by_cases c1 : x = hd,
    {
      rewrite c1,
      simp only [function.update_same],
    },
    {
      cases h1,
      {
        contradiction,
      },
      {
        simp only [function.update_noteq c1],
        exact ih h1,
      }
    }
  },
end

lemma function.update_list_update
  {α β : Type}
  [decidable_eq α]
  (f g : α → β)
  (l1 l2 : list α)
  (v : α)
  (a : β)
  (x : α)
  (h1 : ∀ (y : α), y ∈ l2 → ¬ y = v)
  (h2 : l1.length ≤ l2.length)
  (h3 : x ∈ l1) :
  function.update_list g (l1.zip (list.map (function.update f v a) l2)) x =
    function.update_list f (l1.zip (list.map f l2)) x:=
begin
  have s1 : ∀ (y : α), y ∈ l2 → function.update f v a y = f y,
  intros y a1,
  exact function.update_noteq (h1 y a1) a f,

  exact function.update_list_zip_map_mem_ext' l1 l2 g f (function.update f v a) f x s1 h2 h3,
end

lemma function.update_list_nth_le_zip
  {α β : Type}
  [decidable_eq α]
  (f : α → β)
  (l1 : list α)
  (l2 : list β)
  (n : ℕ)
  (h1 : n < l1.length)
  (h2 : n < l2.length)
  (h3 : l1.nodup) :
  (function.update_list f (l1.zip l2)) (l1.nth_le n h1) = l2.nth_le n h2 :=
begin
  have s1 : (list.map prod.fst (l1.zip l2)).nodup,
  exact list.map_fst_zip_nodup l1 l2 h3,

  have s2 : (l1.nth_le n h1, l2.nth_le n h2) ∈ l1.zip l2,
  exact list.nth_le_mem_zip l1 l2 n h1 h2,

  exact function.update_list_mem f (l1.zip l2) (l1.nth_le n h1, l2.nth_le n h2) s1 s2,
end

def list.option_to_option_list {α : Type} [decidable_eq α] (l : list (option α)) : option (list α) :=
  if none ∈ l then none else some l.reduce_option


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/

import data.fun_like.basic

/-!
# Typeclass for a type `F` with an injective map to `A ↪ B`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This typeclass is primarily for use by embeddings such as `rel_embedding`.

## Basic usage of `embedding_like`

A typical type of embedding should be declared as:
```
structure my_embedding (A B : Type*) [my_class A] [my_class B] :=
(to_fun : A → B)
(injective' : function.injective to_fun)
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_embedding

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "Embedding class" design below:
instance : embedding_like (my_embedding A B) A B :=
{ coe := my_embedding.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := my_embedding.injective' }

/-- Helper instance for when there's too many metavariables to directly
apply `fun_like.to_coe_fn`. -/
instance : has_coe_to_fun (my_embedding A B) (λ _, A → B) := ⟨my_embedding.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : my_embedding A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_embedding A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_embedding` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_embedding A B) (f' : A → B) (h : f' = ⇑f) : my_embedding A B :=
{ to_fun := f',
  injective' := h.symm ▸ f.injective',
  map_op' := h.symm ▸ f.map_op' }

end my_embedding
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Embedding classes extending `embedding_like`

The `embedding_like` design provides further benefits if you put in a bit more work.
The first step is to extend `embedding_like` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
section
set_option old_structure_cmd true

/-- `my_embedding_class F A B` states that `F` is a type of `my_class.op`-preserving embeddings.
You should extend this class when you extend `my_embedding`. -/
class my_embedding_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends embedding_like F A B :=
(map_op : ∀ (f : F) (x y : A), f (my_class.op x y) = my_class.op (f x) (f y))

end

@[simp] lemma map_op {F A B : Type*} [my_class A] [my_class B] [my_embedding_class F A B]
  (f : F) (x y : A) : f (my_class.op x y) = my_class.op (f x) (f y) :=
my_embedding_class.map_op

-- You can replace `my_embedding.embedding_like` with the below instance:
instance : my_embedding_class (my_embedding A B) A B :=
{ coe := my_embedding.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := my_embedding.injective',
  map_op := my_embedding.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_embedding_class` for all types extending
`my_embedding`.
Typically, you can just declare a new class analogous to `my_embedding_class`:

```
structure cooler_embedding (A B : Type*) [cool_class A] [cool_class B]
  extends my_embedding A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

section
set_option old_structure_cmd true

class cooler_embedding_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_embedding_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

end

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_embedding_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_embedding_class.map_op

-- You can also replace `my_embedding.embedding_like` with the below instance:
instance : cool_embedding_class (cool_embedding A B) A B :=
{ coe := cool_embedding.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := my_embedding.injective',
  map_op := cool_embedding.map_op',
  map_cool := cool_embedding.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_embedding A B) : sorry := sorry
lemma do_something {F : Type*} [my_embedding_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_embedding`s will automatically work for `cool_embedding_class`es,
and defining `cool_embedding_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_embedding`-related declaration.

-/

set_option old_structure_cmd true

/-- The class `embedding_like F α β` expresses that terms of type `F` have an
injective coercion to injective functions `α ↪ β`.
-/
class embedding_like (F : Sort*) (α β : out_param Sort*)
  extends fun_like F α (λ _, β) :=
(injective' : ∀ (f : F), @function.injective α β (coe f))

namespace embedding_like

variables {F α β γ : Sort*} [i : embedding_like F α β]

include i

protected lemma injective (f : F) : function.injective f := injective' f

@[simp] lemma apply_eq_iff_eq (f : F) {x y : α} : f x = f y ↔ x = y :=
(embedding_like.injective f).eq_iff

omit i

@[simp] lemma comp_injective {F : Sort*} [embedding_like F β γ] (f : α → β) (e : F) :
  function.injective (e ∘ f) ↔ function.injective f :=
(embedding_like.injective e).of_comp_iff f

end embedding_like


import Std

class OMonad (W) extends Monad W where
  le : ∀ {A}, W A → W A → Prop

instance [OMonad w] : LE (w α) where
  le := OMonad.le

class LawfulOMonad (W) [OMonad W] extends LawfulMonad W where
  le_refl : ∀ a : W α, a ≤ a
  le_trans : ∀ a b c : W α, a ≤ b → b ≤ c → a ≤ c
  le_antisymm : ∀ a b : W α, a ≤ b → b ≤ a → a = b
  bind_mono : ∀ {A B} (w1 w2 : W A) (f1 f2 : A → W B),
    w1 ≤ w2 → (∀ a, (f1 a) ≤ (f2 a)) → (bind w1 f1) ≤ (bind w2 f2)

/-! Dijkstra Monad -/
class DijkstraMonad (M W) [Monad M] [OMonad W] [LawfulOMonad W] where
  obs : ∀ {A}, M A → W A
  obsPure : obs (pure a) = pure a
  obsBind : obs (bind m f) = bind (obs m) (fun a => obs (f a))

def Cont (ρ α) := (α → ρ) → ρ
def IDSpec (A) := { w : Cont Prop A // ∀ {p1 p2}, (∀ a, p1 a → p2 a) → w p1 → w p2}

instance : OMonad IDSpec where
  pure a := ⟨(· a), (· a)⟩
  bind
  | ⟨w,hw⟩, f => ⟨fun P => w (fun x => (f x).val P),
    by
      intro p1 p2 mono h; refine hw ?_ h; intro a; generalize f a = w'
      match w' with | ⟨w',hw'⟩ => simp; apply hw'; exact mono⟩
  le w1 w2 := ∀ p, w2.val p → w1.val p

@[ext] theorem Subtype.ext (s1 s2 : Subtype p) (h : s1.val = s2.val) : s1 = s2 := by
  cases s1; cases s2; simp at h ⊢; assumption
@[ext] theorem IDSpec.ext (s1 s2 : IDSpec p) (h : s1.val = s2.val) : s1 = s2 := Subtype.ext _ _ h

instance : LawfulOMonad IDSpec where
  map_const       := by intros; congr
  id_map          := by intros; congr
  seqLeft_eq      := by intros; congr
  seqRight_eq     := by intros; congr
  pure_seq        := by intros; congr
  bind_pure_comp  := by intros; congr
  bind_map        := by intros; congr
  pure_bind       := by intros; congr
  le_refl := by simp [LE.le, OMonad.le]
  le_trans := by simp (config := {contextual := true}) [LE.le, OMonad.le]
  le_antisymm := by simp only [LE.le, OMonad.le]; intros; ext; funext p; simp; constructor <;> (intro; simp [*])
  bind_assoc := by
    intros; simp [bind]
    split
    next h =>
    split at h
    cases h
    congr
  bind_mono
  | _w1, w2, f1, f2, h1, h2, p, h =>
    h1 _ (w2.property (λ a hf2 => h2 a _ hf2) h)

instance : DijkstraMonad Id IDSpec where
  obs a := ⟨(· a), (· a)⟩
  obsPure := rfl
  obsBind := rfl

class MonadTrans (T : (Type _ → Type _) → (Type _ → Type _)) where
  pure : [Monad M] → α → T M α
  bind : [Monad M] → T M α → (α → T M β) → T M β
  lift : [Monad M] → M α → T M α

instance [Monad m] [MonadTrans T] : Monad (T m) where
  pure := MonadTrans.pure
  bind := MonadTrans.bind

class LawfulMonadTrans (T) [MonadTrans T] where
  lift_pure : [Monad M] → [LawfulMonad M] → ∀ {a : α},
    MonadTrans.lift (T := T) (M := M) (pure a) = pure a
  lift_bind : [Monad M] → [LawfulMonad M] → ∀ {m : M α} {k : α → M β},
    MonadTrans.lift (T := T) (M := M) (m >>= k) = (MonadTrans.lift m) >>= (fun x => (MonadTrans.lift <| k x) >>= fun kx => pure kx)

class OrderedMonadTrans (T) extends MonadTrans T where
  le : [OMonad m] → ∀ {α}, T m α → T m α → Prop

instance [OMonad m] [OrderedMonadTrans T] : OMonad (T m) where
  le := OrderedMonadTrans.le

class LawfulOrderedMonadTrans (T) [OrderedMonadTrans T] extends LawfulMonadTrans T where
  lift_mono : [OMonad M] → [LawfulOMonad M] → ∀ {m1 m2 : M α}, m1 ≤ m2 → MonadTrans.lift (T := T) m1 ≤ MonadTrans.lift m2

instance : OrderedMonadTrans (StateT σ) where
  pure := pure
  bind := bind
  lift := liftM
  le m1 m2 := ∀ s, m1 s ≤ m2 s

instance : LawfulOrderedMonadTrans (StateT σ) where
  lift_pure := by intros; simp [MonadTrans.lift, MonadTrans.pure, liftM, pure, monadLift, MonadLift.monadLift, StateT.lift, StateT.pure]
  lift_bind := by intros; simp [MonadTrans.lift, MonadTrans.bind, liftM, bind, monadLift, MonadLift.monadLift, StateT.lift, StateT.bind]; rfl
  lift_mono := by intros; simp [MonadTrans.lift, liftM, monadLift, MonadLift.monadLift, StateT.lift, LE.le, OMonad.le, OrderedMonadTrans.le]
                  intro s; apply LawfulOMonad.bind_mono; assumption; simp [LawfulOMonad.le_refl]

instance : OrderedMonadTrans (ExceptT ε) where
  pure := pure
  bind := bind
  lift := liftM
  le {m _ α} (m1 m2 : m (Except ε α)) := m1 ≤ m2

-- instance : @LawfulOrderedMonadTrans _ (ExceptT ε) where
--   lift_pure := sorry
--   lift_bind := sorry
--   lift_mono := sorry

-- instance {ε : Type} : DijkstraMonad (ExceptT ε Id) (ExceptT ε IDSpec) where
--   obs m := pure (f := IDSpec) m
--   obsPure := by sorry
--   obsBind := by sorry

instance : LawfulOMonad (StateT σ IDSpec) where
  le_refl := by simp [LE.le, OMonad.le, OrderedMonadTrans.le]
  le_trans := by simp (config := {contextual := true}) [LE.le, OMonad.le, OrderedMonadTrans.le]
  le_antisymm := by
    intro _ a b ha hb; funext x; ext; funext p; ext; constructor; apply hb; apply ha
  bind_mono := by
    intro _ _ w1 w2 f1 f2 hw hf s p h
    simp [bind, MonadTrans.bind, StateT.bind] at h ⊢
    have := hw s
    -- variable finagling
    split; split at h
    next a b c d e f g i j k l m =>
    simp at h ⊢
    generalize w1 s = w1' at *
    generalize w2 s = w2' at *
    subst_vars
    clear hw w1 w2 s c d i j
    -- back to meaningful proof
    apply this
    simp
    refine l ?_ h
    rintro ⟨x,y⟩
    simp
    apply hf

instance {σ : Type} : DijkstraMonad (StateT σ Id) (StateT σ IDSpec) where
  obs m := fun s => DijkstraMonad.obs (m s)
  obsPure := rfl
  obsBind := rfl

instance [OrderedMonadTrans T] [LawfulOrderedMonadTrans T] : DijkstraMonad (T Id) (T IDSpec) where
  obs t := sorry
  obsPure := sorry
  obsBind := sorry

variable (σ : Type)

def DijkstraVerify M [Monad M] W [OMonad W] [LawfulOMonad W] [D : DijkstraMonad M W] A (w : W A) (m : M A) : Prop :=
  D.obs m ≤ w

theorem IDSpec.pure_iff_eq : DijkstraVerify Id IDSpec A (pure x) a ↔ x = a
  := by simp [DijkstraVerify, DijkstraMonad.obs, LE.le, OMonad.le, pure]
        constructor
        intro h; apply h; rfl
        intro h; cases h; intro; apply id

def foldSpec (inv : α → Prop) : IDSpec α :=
  ⟨ fun (p : α → Prop) => ∀ a, inv a → p a, by
    intro p1 p2 hp hinv a ha
    apply hp; apply hinv; exact ha ⟩

theorem foldlInv' (L : List τ) (inv : α → Prop) (f : α → τ → α) (init : α)
    (h_init : inv init) (h_f : ∀ {a t}, t ∈ L → inv a → inv (f a t))
  : DijkstraVerify Id IDSpec α (foldSpec inv) (L.foldl f init) := by
  intro post h
  induction L generalizing init with
  | nil =>
    simp; apply h; assumption
  | cons x xs ih =>
    simp; apply ih; apply h_f <;> simp [h_init, h_f];
    intro a t ht inv_a
    specialize @h_f a t
    simp [ht] at h_f
    exact h_f inv_a

theorem foldlInv (L : List τ) (inv : α → Prop) (f : α → τ → α) (init : α)
    (h_init : inv init) (h_f : ∀ {a t}, inv a → inv (f a t))
  : DijkstraVerify Id IDSpec α (foldSpec inv) (L.foldl f init) :=
    foldlInv' L inv f init h_init (@fun _ _ _ inv => h_f inv)

#check List.foldlM

theorem foldlMInv [Monad M] [LawfulMonad M] (L : List τ) (inv : M α → Prop) (f : α → τ → M α) (init : α)
    (h_init : inv (pure init)) (h_f : ∀ {ma t}, inv ma → inv (ma >>= (fun a => f a t)))
    : DijkstraVerify Id IDSpec (M α) (foldSpec inv) (@List.foldlM M _ α τ f init L) := by
    intro post h
    induction L generalizing init with
    | nil => simp; apply h; exact h_init
    | cons x xs ih =>
      simp [DijkstraMonad.obs] at *
      sorry

theorem foldlMInvArr [Monad M] (A : Array τ) (inv : M α → Prop) (f : α → τ → M α) (init : α) (start := 0) (stop := A.size)
    (stop_h : stop ≤ A.size) (h_init : inv (pure init)) (h_f : ∀ {ma t}, inv ma → inv (ma >>= (fun a => f a t))) :
    DijkstraVerify Id IDSpec (M α) (foldSpec inv) (@Array.foldlM τ α M _ f init A start stop) := by
    intro post h
    simp [DijkstraMonad.obs, Array.foldlM]
    split <;> apply h <;> cases A
    case inl L h_stop =>
      induction L generalizing init with
      | nil =>
        simp [Array.size] at h_stop
        rw [Array.foldlM.loop]
        simp [h_stop]
        assumption
      | cons x xs ih =>
        rw [Array.foldlM.loop]
        split
        case inl start_lt_stop =>
          have : ∃ i', stop - start = Nat.succ i' := by sorry
          cases this with
          | _ i h_i =>
            simp [*] at *
            sorry
        case inr _ => exact h_init
    case inr L h_stop => exfalso; exact h_stop stop_h

theorem foldrInv' (L : List τ) (inv : α → Prop) (f : τ → α → α) (init : α)
    (h_init : inv init) (h_f : ∀ {a t}, t ∈ L → inv a → inv (f t a))
  : DijkstraVerify Id IDSpec α (foldSpec inv) (L.foldr f init) := by
  intro post h
  induction L generalizing post with
  | nil =>
    simp; apply h; assumption
  | cons x xs ih =>
    simp [foldSpec] at h
    apply h; apply h_f;
    simp only [List.mem_cons, true_or]; apply ih;
    intro a t txs inva
    apply h_f (by simp only [List.mem_cons, txs, or_true]) inva;
    simp [foldSpec]

theorem foldrInv (L : List τ) (inv : α → Prop) (f : τ → α → α) (init : α)
    (h_init : inv init) (h_f : ∀ {a t}, inv a → inv (f t a))
  : DijkstraVerify Id IDSpec α (foldSpec inv) (L.foldr f init) :=
  foldrInv' L inv f init h_init (@fun _ _ _ inv => h_f inv)