import algebra
import data.real.basic
import data.vector
import data.finset
import tactic.explode
import tactic.find
import tactic.induction
import tactic.linarith
import tactic.rcases
import tactic.rewrite
import tactic.ring_exp
import tactic.tidy
import tactic.where

namespace IncLoLang

/-! ## State-/

meta def tactic.dec_trivial := `[exact dec_trivial]

def state: Type := string -> ℕ

def state.update : string -> ℕ -> state -> state
| name val σ := (λ name', if name' = name then val else σ name')

notation s `{` name ` ↦ ` val `}` := state.update name val s

@[simp] lemma state.update_apply (name : string) (val : ℕ) (s : state) :
  s{name ↦ val} name = val :=
begin
  unfold state.update,
  finish,
end

@[simp] lemma state.update_apply_ne (name name' : string) (val : ℕ) (s : state)
    (h : name' ≠ name) :
  s{name ↦ val} name' = s name' :=
begin
  unfold state.update,
  exact if_neg h,
end

@[simp] lemma state.update_override (name : string) (val₁ val₂ : ℕ) (s : state) :
  s{name ↦ val₂}{name ↦ val₁} = s{name ↦ val₁} :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp [h]
end

@[simp] lemma state.update_swap (name₁ name₂ : string) (val₁ val₂ : ℕ) (s : state)
    (h : name₁ ≠ name₂ . tactic.dec_trivial) :
  s{name₂ ↦ val₂}{name₁ ↦ val₁} = s{name₁ ↦ val₁}{name₂ ↦ val₂} :=
begin
  apply funext,
  intro name',
  by_cases name' = name₁;
    by_cases name' = name₂;
    simp * at *
end

@[simp] lemma state.update_id (name : string) (s : state) :
  s{name ↦ s name} = s :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp * at *
end

@[simp] lemma state.update_same_const (name : string) (val : ℕ) :
  (λ_, val){name ↦ val} = (λ_, val) :=
by apply funext; simp

/-! # Propositions -/

def prop: Type := state -> Prop

/-! # Expression -/

def expression: Type := state -> ℕ

/-! ## Language -/

inductive stmt : Type
| skip            : stmt
| assign          : string → expression → stmt
| non_det_assign  : string → stmt
| seq             : stmt → stmt → stmt
| choice          : stmt → stmt → stmt
| star            : stmt → stmt
-- | local_var       : string → stmt → stmt
| error           : stmt
| assumes         : prop → stmt

-- Language notation

infixr ` ;; ` : 90 := stmt.seq

infixr ` <+> ` : 90 := stmt.choice

postfix `**` : 90 := stmt.star

notation `[` x ` ↣ ` e `]` := stmt.assign x e

notation `[loc` x `.` C `]` := stmt.local_var x C

/- This is the definition of P[x'/x] used in the paper -/
def prop.update_val (P: prop) (x': ℕ) (x: string) : IncLoLang.state -> Prop :=
  -- λ σ', ∃ σ, P σ ∧ σ' = σ{x ↦ x'}
  -- This is the definition given int he paper but it is wrong
  λ σ', P (σ'{x ↦ x'})
-- ie, True for σ if P(σ{x ↦ x'})

notation P `{` name ` ↣ ` val `}` := P.update_val val name

/-! # Language semantics -/

inductive LogicType : Type
| er
| ok

def repeat: IncLoLang.stmt → ℕ → IncLoLang.stmt
| C nat.zero := IncLoLang.stmt.skip
| C (nat.succ i) := (repeat C (i)) ;; C

inductive lang_semantics: IncLoLang.stmt → LogicType → IncLoLang.state → IncLoLang.state → Prop
| skip {s} :
  lang_semantics IncLoLang.stmt.skip LogicType.ok s s
| seq_ty {S T s t u ty} (H1: lang_semantics S LogicType.ok s t) (H2: lang_semantics T ty t u) :
  lang_semantics (S ;; T) ty s u
| seq_er_1 {S T s t} (H1: lang_semantics S LogicType.er s t):
  lang_semantics (S ;; T) LogicType.er s t
| error {s}:
  lang_semantics IncLoLang.stmt.error LogicType.er s s
| assign {x s e} :
  lang_semantics [x ↣ e] LogicType.ok s (s{x ↦ (e s)})
| non_det_assign {x s} (v: ℕ) :
  lang_semantics (IncLoLang.stmt.non_det_assign x) LogicType.ok s (s{x ↦ v})
| assumes_ok {s} {B: prop} (h: B s) :
  lang_semantics (IncLoLang.stmt.assumes B) LogicType.ok s s
| choice_left {C₁ C₂ ty s₁ s₂} (h: (lang_semantics C₁ ty s₁ s₂)):
  lang_semantics (C₁ <+> C₂) ty s₁ s₂
| choice_right {C₁ C₂ ty s₁ s₂} (h: (lang_semantics C₂ ty s₁ s₂)):
  lang_semantics (C₁ <+> C₂) ty s₁ s₂
| star {C s₁ s₂ ty} (i: ℕ) (h: lang_semantics (repeat C i) ty s₁ s₂):
  lang_semantics (C**) ty s₁ s₂
-- | local_var {C s₁ s₂ ty} (x: string) (v: ℕ) (h: lang_semantics C ty s₁ s₂):
--   lang_semantics ([loc x . C]) ty (s₁{x ↦ v}) (s₂{x ↦ v})

/-! # Free-/

-- Perhaps invert
def prop.Free (P: prop): set string :=
  λ x, ∃ σ v, (P σ ∧ ¬(P (σ{x ↦ v})))

-- def expression.Free (e: expression): set string :=
--   λ x, ∃ σ v, e σ ≠ e (σ{x ↦ v})

-- Set of variables x such that if ∀ x, σ x = σ' x, then e σ = e σ'
def expression.FreeProp (e: expression): set string → Prop :=
  (λ F, ∀ σ σ': state, (∀ f: F, σ f = σ' f) → e σ = e σ' )

def expression.Free (e: expression): set string :=
  ⋂₀ (λ A, e.FreeProp A)
-- WTS expression.free satisfies expression.FreeProp
-- Freeprop is closed under intersection

-- freeprop {x, y} freeprop {x, z} → freeprop {x}
-- show binary intersections
-- show infinite intersections
-- thus we have what we want

-- infinite intersections in lean?

lemma expression.Free.semantics (e: expression) {x: string}:
  x ∈ expression.Free e ↔ ∃ σ v, e σ ≠ e (σ{x ↦ v}) :=
  -- λ x, ∃ σ v, e σ ≠ e (σ{x ↦ v})
begin
  split,
  {
    intro hx,
    by_contra,
    push_neg at h,
    specialize hx (λ y : string, y ≠ x),
    have H: e.FreeProp (λ (y : string), y ≠ x), {
      intros σ σ' hf,
      have H: ∃ v, σ' = σ{x ↦ v}, {
        use σ' x,
        funext z,
        by_cases z = x,
        { cases h, rw state.update_apply, },
        {
          rw state.update_apply_ne _ _ _ _ h,
          simp at hf,
          specialize hf z h,
          rw hf,
        },
      },
      cases H,
      rw h σ H_w,
      rw H_h,
    },
    specialize hx H,
    apply hx,
    refl,
  },
  {
    intros h F hF,
    rw expression.FreeProp at hF,
    cases h with σ h,
    cases h with v,
    by_contra,
    specialize hF σ (σ{x ↦ v}),
    simp at hF,
    have H: (∀ (y : string), y ∈ F → σ y = σ{x ↦ v} y), {
      intros y hy,
      have H: y ≠ x, {finish,},
      rw state.update_apply_ne _ _ _ _ H,
    },
    specialize hF H,
    apply h_h,
    exact hF,
  }
end

def stmt.Free: stmt → set string
| stmt.skip                 := {}
| ([z ↣ e₂])                := {z} ∪ e₂.Free
| (stmt.non_det_assign z)   := {z}
| (C₁ ;; C₂)                := (stmt.Free C₁) ∪ (stmt.Free C₂)
| (C₁ <+> C₂)               := (stmt.Free C₁) ∪ (stmt.Free C₂)
| (C**)                     := stmt.Free C
-- | [loc z . C]               := (stmt.Free C)
-- | [loc z . C]               := (stmt.Free C) \ {z}
| stmt.error                := {}
| (stmt.assumes P)          := prop.Free P

/-! # Substitute-/

def state.substitute : string → string → state → state
-- | y x := λ σ, σ{y ↦ σ x}
| y x := λ σ, σ{y ↦ σ x}{x ↦ 0}

notation σ `⟨` vto `//` vfrom `⟩` :=  state.substitute vto vfrom σ

def prop.substitute : string → string → prop → prop
| x s P := λ σ, P (σ⟨ x // s⟩)

notation P `[` val `//` name `]` :=  prop.substitute name val P

def expression.substitute : string → string → expression → expression
| x y e := λ σ, e (σ⟨ x // y ⟩)

def stmt.substitute : string → string → stmt → stmt
| x y stmt.skip                 := stmt.skip
| x y ([z ↣ e₂])                := if x = z then [y ↣ λ σ, ((expression.substitute x y e₂) σ)] else [z ↣ λ σ, ((expression.substitute x y e₂) σ)]  -- PUT X BACK!
| x y (stmt.non_det_assign z)   := if x = z then stmt.non_det_assign y else stmt.non_det_assign z
| x y (C₁ ;; C₂)                := (stmt.substitute x y C₁) ;; (stmt.substitute x y C₂)
| x y (C₁ <+> C₂)               := (stmt.substitute x y C₁) <+> (stmt.substitute x y C₂)
| x y (C**)                     := (stmt.substitute x y C)**
-- | x y [loc z . C]               := if x = z then [loc x . C] else [loc z . (stmt.substitute x y C)]
-- | x y [loc z . C]               := if x = z then [loc x . C] else (if y = z then C else [loc z . (stmt.substitute x y C)])
| x y stmt.error                := stmt.error
| x y (stmt.assumes P)          := stmt.assumes (P[y//x])

notation C `{` exp `//` name `}` :=  stmt.substitute name exp C

/-! ## Mod -/

def stmt.Mod: stmt → set string
| (C₁ ;; C₂) := (C₁.Mod) ∪ (C₂.Mod)
| (C₁ <+> C₂) := (C₁.Mod) ∪ (C₂.Mod)
| (C**) := (C.Mod)
| ([x ↣ v]) := {x}
| (IncLoLang.stmt.skip) := {}
| (IncLoLang.stmt.non_det_assign x) := {x}
| (IncLoLang.stmt.assumes _) := {}
| (IncLoLang.stmt.error) := {}
-- | (IncLoLang.stmt.local_var x C) := Mod C \ {x}

lemma mod_elem_left_elem_seq (C₁ C₂: stmt):
   C₁.Mod ⊆ (C₁ ;; C₂).Mod :=
begin
  intro h,
  rw stmt.Mod,
  finish,
end

lemma mod_elem_right_elem_seq (C₁ C₂: stmt):
   C₂.Mod ⊆ (C₁ ;; C₂).Mod :=
begin
  intro h,
  rw stmt.Mod,
  finish,
end

lemma mod_elem_left_elem_choice (C₁ C₂: stmt):
   C₁.Mod ⊆ (C₁ <+> C₂).Mod :=
begin
  intro h,
  rw stmt.Mod,
  finish,
end

lemma mod_elem_right_elem_choice (C₁ C₂: stmt):
   C₂.Mod ⊆ (C₁ <+> C₂).Mod :=
begin
  intro h,
  rw stmt.Mod,
  finish,
end

lemma start_seq {C: stmt} {σ σ': state} {ty: LogicType}:
  IncLoLang.lang_semantics (C** ;; C) ty σ σ' → IncLoLang.lang_semantics (C**) ty σ σ' :=
begin
  intro h,
  cases h,
  {
    have H: ∃ N, lang_semantics (repeat C N) ty σ σ',
    {
      cases h_H1,
      use h_H1_i.succ,
      rw repeat,
      exact lang_semantics.seq_ty h_H1_h h_H2,
    },
    cases H with N,
    exact lang_semantics.star N H_h,
  },
  { exact h_H1, },
end

/-! ## Free lemmas -/

lemma mod_sub_free (C: stmt):
  C.Mod ⊆ C.Free :=
begin
  induction C with v r _ C₁ C₂ hC₁ hC₂ C₁ C₂ hC₁ hC₂ _ h,
  case stmt.skip {
    rw stmt.Mod,
    exact stmt.skip.Free.empty_subset,
  },
  case stmt.assign {
    rw stmt.Mod,
    rw stmt.Free,
    exact ({v}: set string).subset_union_left (expression.Free r),
  },
  case stmt.non_det_assign {
    rw stmt.Mod,
    rw stmt.Free,
  },
  case stmt.seq {
    rw stmt.Mod,
    rw stmt.Free,
    exact set.union_subset_union hC₁ hC₂,
  },
  case stmt.choice {
    rw stmt.Mod,
    rw stmt.Free,
    exact set.union_subset_union hC₁ hC₂,
  },
  case stmt.star {
    rw stmt.Mod,
    rw stmt.Free,
    exact h,
  },
  -- case stmt.local_var {
  --   rw Mod,
  --   rw stmt.Free,
  --   exact set.diff_subset_diff_left C_ih,
  -- },
  case stmt.error {
    rw stmt.Mod,
    rw stmt.Free,
  },
  case stmt.assumes {
    rw stmt.Mod,
    exact (stmt.assumes C).Free.empty_subset,
  },
end

lemma not_free_expression {e: expression} {x}:
  (¬e.Free x) → ∀ σ v, e σ = e (σ{x ↦ v}) :=
begin
  intro hFree,
  by_contra H,
  apply hFree,
  apply (expression.Free.semantics e).2,
  push_neg at H,
  exact H,
end

lemma not_free_prop {e: prop} {x}:
  (¬e.Free x) → ∀ σ v, e σ ↔ e (σ{x ↦ v}) :=
begin
  intro h,
  unfold prop.Free at h,
  push_neg at h,
  intros σ v,
  split,
  { exact h σ v, },
  {
    specialize h (σ{x ↦ v}) (σ x),
    have H: σ{x ↦ v}{x ↦ σ x} = σ, {
      funext,
      by_cases x = name',
      { finish, },
      { finish, }
    },
    rw H at h,
    exact h,
  }
end

lemma free_language_semantics (C: stmt) (x: string):
  (¬C.Free x) → (∀ σ σ' ty v, lang_semantics C ty σ σ' → lang_semantics C ty (σ{x ↦ v}) (σ'{x ↦ v})) :=
begin
  induction C with
    y
    e y
    C₁ C₂ C₁h C₂h
    C₁ C₂ C₁h C₂h
    C Ch
    z C,
  case stmt.skip {
    intros h₁ σ σ' ty v h,
    cases h,
    exact lang_semantics.skip,
  },
  case stmt.assign {
    intros h₁ σ σ' ty v h₂,
    cases h₂,
    by_cases x = y,
    {
      exfalso,
      rw stmt.Free at h₁,
      apply h₁,
      left,
      exact set.mem_singleton_iff.mpr h,
    },
    {
      rw ← state.update,
      rw state.update_swap _ _ _ _ _ (h),
      -- have H: (λ (name' : string), σ name') = σ, {exact rfl}
      rw stmt.Free at h₁,
      have H: e σ = e (σ{x ↦ v}), {
        by_contra,
        have H2: x ∈ e.Free, {
          rw expression.Free.semantics e,
          use σ,
          use v,
        },
        apply h₁,
        right,
        exact H2,
      },
      rw H,
      exact lang_semantics.assign,
    }
  },
  case stmt.non_det_assign {
    intros h₁ σ σ' ty v h₂,
    cases h₂,
    by_cases x = y,
    {
      exfalso,
      rw stmt.Free at h₁,
      apply h₁,
      exact set.mem_singleton_iff.mpr h,
    },
    {
      rw ← state.update,
      rw state.update_swap _ _ _ _ _ h,
      -- have H: (λ (name' : string), σ name') = σ, {exact rfl}
      rw stmt.Free at h₁,

      exact lang_semantics.non_det_assign h₂_v,
    }
  },
  case stmt.seq {
    intros h₁ σ σ' ty v h₂,
    rw stmt.Free at h₁,
    specialize C₁h (by {
      by_contra,
      apply h₁,
      left,
      exact h,
    }),
    specialize C₂h (by {
      by_contra,
      apply h₁,
      right,
      exact h,
    }),
    cases h₂,
    {
      specialize C₁h σ h₂_t LogicType.ok v h₂_H1,
      specialize C₂h h₂_t σ' ty v h₂_H2,
      exact lang_semantics.seq_ty C₁h C₂h,
    },
    {
      specialize C₁h σ σ' LogicType.er v h₂_H1,
      exact lang_semantics.seq_er_1 C₁h,
    },
  },
  case stmt.choice {
    intros h₁ σ σ' ty v h₂,
    rw stmt.Free at h₁,

    cases h₂,
    {
      specialize C₁h (by {
        by_contra,
        apply h₁,
        left,
        exact h,
      }) σ σ' ty v h₂_h,
      exact lang_semantics.choice_left C₁h,
    },
    {
      specialize C₂h (by {
        by_contra,
        apply h₁,
        right,
        exact h,
      }) σ σ' ty v h₂_h,
      exact lang_semantics.choice_right C₂h,
    },
  },
  case stmt.star {
    intros h₁ σ σ' ty v h₂,
    rw stmt.Free at h₁,
    specialize Ch h₁,
    cases h₂,
    use h₂_i,
    revert σ σ' ty,
    induction h₂_i,
    {
      intros σ σ' ty h,
      rw repeat at h,
      cases h,
      rw repeat,
      exact lang_semantics.skip,
    },
    {
      intros σ σ' ty h,
      rw repeat,
      rw repeat at h,
      cases h,
      {
        exact lang_semantics.seq_ty
          (h₂_i_ih σ h_t LogicType.ok h_H1)
          (Ch h_t σ' ty v h_H2),
      },
      { exact lang_semantics.seq_er_1 ( h₂_i_ih σ σ' LogicType.er h_H1 ), }
    }
  },
  -- case stmt.local_var {
  --   intros h₁ σ σ' ty v,
  --   rw stmt.Free at h₁,
  --   by_cases H: x = z,
  --   {
  --     cases H,
  --     intro h,
  --     cases h,
  --     rw ← state.update,
  --     rw ← state.update,
  --     rw assign_order_eq,
  --     rw assign_order_eq,
  --     exact lang_semantics.local_var x v h_h,
  --   },
  --   {
  --     have h₂: x ∉ C.Free, {
  --       by_contra,
  --       apply h₁,
  --       split,
  --       { exact h, },
  --       {
  --         by_contra,
  --         apply H,
  --         exact set.mem_singleton_iff.1 h,
  --       },
  --     },
  --     specialize C_ih h₂,
  --     intro h,
  --     cases h,
  --     rw ← state.update,
  --     rw ← state.update,
  --     rw assign_order (ne.symm H),
  --     rw assign_order (ne.symm H),
  --     exact lang_semantics.local_var _ _ (C_ih h_s₁ h_s₂ ty v h_h)
  --   },
  -- },
  case stmt.error {
    intros h₁ σ σ' ty v h,
    cases h,
    exact lang_semantics.error,
  },
  case stmt.assumes {
    intros h₁ σ σ' ty v h,
    cases h,
    rw stmt.Free at h₁,
    rw prop.Free at h₁,
    push_neg at h₁,
    exact lang_semantics.assumes_ok (h₁ σ v h_h),
  },
end

lemma assign_semantics {x σ σ' ty} {e: expression}:
  lang_semantics ([x ↣ e]) ty σ σ' → σ{x ↦ e σ} = σ' ∧ ty = LogicType.ok:=
begin
  intro h,
  cases h,
  split,
  repeat { refl },
end

lemma non_det_assign_semantics {x σ σ' ty}:
  lang_semantics (stmt.non_det_assign x) ty σ σ' → ∃ v, σ' = σ{x ↦ v} ∧ ty = LogicType.ok :=
begin
  intro h,
  cases h,
  use h_v,
  split,
  repeat { refl },
end

lemma p_thing_free {x: string} {v: ℕ} {P: prop} :
  prop.Free (P{ x ↣ v }) ⊆ prop.Free P \ {x} :=
begin
  intros y hy,
  unfold prop.Free at hy,
  unfold prop.update_val at hy,
  cases hy with σ,
  use σ{x ↦ v},
  have Hxy: x ≠ y,
  {
    by_contra,
    cases h,
    cases hy_h with v,
    rw state.update_override at hy_h_h,
    finish,
  },
  {
    cases hy_h with n hn,
    use n,
    -- rw assign_order Hxy,
    rw state.update_swap _ _ _ _ _ (ne.symm Hxy),
    exact hn,
  },
  {
    intro h,
    finish,
  },
end

lemma free_assign {x e}:  (expression.Free e) ∪ {x} ⊆ (stmt.Free ([x ↣ e])):=
begin
  intros y hy,
  by_cases x = y,
  {
    cases h,
    unfold stmt.Free,
    left,
    exact set.mem_singleton x,
  },
  {
    -- rcases hy with ⟨ x, y ⟩,
    cases hy,
    {
      -- rcases hy with ⟨σ, ⟨v, hσ⟩⟩,
      rw stmt.Free,
      right,
      exact hy,
    },
    {
      exfalso, cases hy, apply h, refl,
    }
  },
end

lemma assign_case {ty y x z e} {σ σ' : state} (Hyx: y ≠ x) (Hfreey: y ∉ ([z ↣ e].Free)):
  lang_semantics ([z ↣ e]) ty (σ) (σ') →
    lang_semantics ([z ↣ e]{y // x}) ty (σ⟨ y // x⟩) (σ'⟨ y // x ⟩) :=
begin
  have H := (set.compl_subset_compl.mpr free_assign) Hfreey,
  have H₁ : y ∉ e.Free, { by_contra, finish, },
  have H₁ := not_free_expression H₁,

  have H₂ : y ≠ z, {
    by_contra,
    finish,
  },

  intro hls,
  cases hls,
  cases hls,
  rw stmt.substitute,

  by_cases hx: x = z,
  {
    rw if_pos hx,
    cases hx,
    rw ← state.update,
    rw expression.substitute,
    simp,

    have H: σ{x ↦ e σ}⟨y//x⟩= σ⟨y//x⟩{y ↦ (λ (σ : state), e (σ⟨x//y⟩)) (σ⟨y//x⟩)},
    {
      ext z,
      simp,

      unfold state.update,
      unfold state.substitute,
      by_cases hx: x = z,
      {finish,},
      {
        by_cases hy: y = z,
        {
          cases hy,
          simp,
          finish,
        },
        {
          simp,
          unfold state.update,
          finish,
        },
      }
    },

    rw H,
    exact lang_semantics.assign,
  },
  {
    rw if_neg hx,
    rw ← state.update,
    rw state.substitute,
    simp,
    rw state.update_swap _ _ _ _ _ H₂,
    rw state.update_swap _ _ _ _ _ hx,
    have H: σ{z ↦ e σ} x = σ x, {
      funext, finish,
    },
    rw H,
    rw expression.substitute,
    have H: e σ = (λ (σ : state), e (σ⟨x//y⟩)) (σ{y ↦ σ x}{x ↦ 0}), {
      simp,
      rw state.substitute,
      simp,
      rw ← state.update_swap _ _ _ _ _ Hyx,
      rw state.update_override,
      have H: σ{x ↦ σ{y ↦ σ x}{x ↦ 0} y} = σ, {
        funext, finish,
      },
      rw H,
      exact H₁ σ 0,
    },
    rw H,
    exact lang_semantics.assign,
  },
end

lemma substitution_rule {ty C y x} {σ σ' : state} (Hyx: y ≠ x) (Hfreey: y ∉ stmt.Free C):
  lang_semantics C ty (σ) (σ') →
    -- If C can take σ to σ'
    lang_semantics (C{y // x}) ty (σ⟨ y // x⟩) (σ'⟨ y // x ⟩) :=
    -- Then C(y/x) can take σ with y set to x's value in σ to σ' with y set to x's value in σ'
begin
  revert ty σ σ',

  induction C with z e z
    C₁ C₂ hC₁ hC₂
    C₁ C₂ hC₁ hC₂
    C hC,
    -- z C hC,
  case stmt.skip {
    -- Skip case is trivial as σ = σ'
    intros _ σ _ h,
    cases h,
    exact lang_semantics.skip,
  },
  case stmt.assign {
    intros ty σ σ' hls,
    exact assign_case Hyx Hfreey hls,
  },
  case stmt.non_det_assign {
    intros ty σ σ' hls,

    by_cases x = z,
    {
      cases h,
      rw stmt.substitute,
      cases hls,
      unfold state.substitute,
      rw if_pos (rfl),
      rw ← state.update,
      rw state.update_swap _ _ _ _ _ Hyx,
      rw if_pos (rfl),
      simp,
      rw ← state.update_swap _ _ _ _ _ Hyx,
      rw ← state.update_swap _ _ _ _ _ Hyx,
      have H: σ{x ↦ 0}{y ↦ hls_v} = σ{x ↦ 0}{y ↦ σ x}{y ↦ hls_v}, { rw state.update_override, },
      rw H,
      exact lang_semantics.non_det_assign hls_v,
    },
    {
      rw stmt.substitute,
      cases hls,
      unfold state.substitute,
      rw if_neg h,
      rw ← state.update,
      rw if_neg h,
      by_cases H₂: z = y,
      {
        cases H₂,
        rw state.update_override,
        rw state.update_swap _ _ _ _ _ h,
        have H: σ{x ↦ 0}{y ↦ σ x} = σ{x ↦ 0}{y ↦ σ x}{y ↦ σ x}, { rw state.update_override, },
        nth_rewrite 1 H,
        exact lang_semantics.non_det_assign (σ x),
      },
      {
        rw state.update_swap _ _ _ _ _ (ne.symm H₂),
        rw state.update_swap _ _ _ _ _ h,
        exact lang_semantics.non_det_assign hls_v,
      }
    },
  },
  case stmt.seq {
    intros ty σ σ' hls,
    cases hls,
    {
      specialize hC₁ (by {
        by_contra,
        apply Hfreey,
        left,
        exact h,
      }) hls_H1,
      specialize hC₂ (by {
        by_contra,
        apply Hfreey,
        right,
        exact h,
      }) hls_H2,
      rw stmt.substitute,
      exact lang_semantics.seq_ty hC₁ hC₂,
    },
    {
      specialize hC₁ (by {
        by_contra,
        apply Hfreey,
        left,
        exact h,
      }) hls_H1,
      rw stmt.substitute,
      exact lang_semantics.seq_er_1 hC₁,
    }
  },
  case stmt.choice {
    intros ty σ σ' hls,
    cases hls,
    {
      specialize hC₁ (by {
        by_contra,
        apply Hfreey,
        left,
        exact h,
      }) hls_h,
      rw stmt.substitute,
      exact lang_semantics.choice_left hC₁,
    },
    {
      specialize hC₂ (by {
        by_contra,
        apply Hfreey,
        right,
        exact h,
      }) hls_h,
      rw stmt.substitute,
      exact lang_semantics.choice_right hC₂,
    }
  },
  case stmt.star {
    intros ty σ σ' hls,
    cases hls,
    rw stmt.substitute,
    use hls_i,
    revert ty σ σ' ,
    induction hls_i,
    {
      intros ty σ σ' hls_h,
      rw repeat at hls_h,
      cases hls_h,
      rw repeat,
      exact lang_semantics.skip,
    },
    {
      intros ty σ σ' hls_h,
      rw repeat at hls_h,
      cases hls_h,
      {
        specialize hls_i_ih hls_h_H1,
        rw stmt.Free at Hfreey,
        specialize hC Hfreey hls_h_H2,
        rw repeat,
        exact lang_semantics.seq_ty hls_i_ih hC,
      },
      {
        specialize hls_i_ih hls_h_H1,
        rw repeat,
        exact lang_semantics.seq_er_1 hls_i_ih,
      },
    },
  },
  -- case stmt.local_var {
  --   intros ty σ σ' hls,
  --   cases hls,
  --   rw stmt.substitute,
  --   by_cases x = z,
  --   {
  --     cases h,
  --     rw if_pos h,
  --     rw stmt.Free at Hfreey,
  --     have H : y ∉ C.Free, { finish, },
  --     rw ← state.update,
  --     rw ← state.update,
  --     rw state.substitute,
  --     simp,
  --     have H₂ := free_language_semantics C y H,
  --     rw ← assign_order Hyx,
  --     rw ← assign_order Hyx,
  --     rw assign_order_eq,
  --     rw assign_order_eq,
  --     specialize H₂ hls_s₁ hls_s₂ ty hls_v hls_h,
  --     exact lang_semantics.local_var _ _ H₂,
  --   },
  --   {
  --     rw if_neg h,
  --     rw stmt.Free at Hfreey,
  --     by_cases y = z,
  --     {
  --       cases h,
  --       rw ← state.update,
  --       rw state.substitute,
  --       rw ← state.update,
  --       simp,
  --       have H1: hls_s₁{y ↦ hls_v} x = hls_s₁ x, { unfold state.update, finish, },
  --       have H2: hls_s₂{y ↦ hls_v} x = hls_s₂ x, { unfold state.update, finish, },
  --       rw H1, rw H2,
  --       sorry,
  --        -- [loc z. z = 5]
  --        -- [loc z. x = 5](z//x)
  --        -- [loc z. z = 5](z//x) !! Need to move to fresh
  --       -- exact lang_semantic.local_var y hls_v (hC Hfreey hls_h),
  --       -- rw stmt.substitute,
  --       -- x ≠ b (σ1, σ2) ∈ ⟦local x . C⟧ and y ∉ Free C ⇒ (σ1(y/b), σ2(y/b)) ∈ ⟦local x . C(y/b)⟧
  --       -- ({b = 1}, {b = 2}) ∈ ⟦local y . b = 2⟧ ⇒ ({y = 1}, {y = 2}) ∈ ⟦local y . y = 2⟧
  --     },
  --     {
  --       have H: y ∉ C.Free, { by_contra, finish, },
  --       specialize hC H hls_h,
  --       rw ← state.update,
  --       rw ← state.update,
  --       simp,
  --       have H1: ∀ σ, ((σ{z ↦ hls_v})⟨y//x⟩) = ((σ⟨y//x⟩){z ↦ hls_v}), {
  --         intro σ,
  --         rw state.substitute,
  --         funext,
  --         simp,
  --         unfold state.update,
  --         by_cases name' = x, { cases h, finish, },
  --         by_cases name' = y, { cases h, finish, },
  --         by_cases name' = z, { cases h, finish, },
  --         finish,
  --       },
  --       rw (H1 hls_s₁),
  --       rw (H1 hls_s₂),
  --       exact lang_semantics.local_var _ _ hC,
  --     },
  --   },
  -- },
  {
    intros ty σ σ' hls,
    cases hls,
    rw stmt.substitute,
    exact lang_semantics.error,
  },
  {
    intros ty σ σ' hls,
    cases hls,
    rw stmt.substitute,
    have H: (C[y//x]) (σ⟨y//x⟩), {
      unfold prop.substitute,
      unfold state.substitute,
      rw state.update_override,
      have H: σ{y ↦ σ x}{x ↦ σ{y ↦ σ x}{x ↦ 0} y} = σ{y ↦ σ x}, {
        unfold state.update,
        funext,
        finish,
      },
      rw H,
      rw stmt.Free at Hfreey,
      simp,
      apply (not_free_prop Hfreey σ (0)).1,
      exact hls_h,
    },
    exact lang_semantics.assumes_ok H,
  },
end

lemma stmt_free_unchanged {x: string} {C: stmt} {σ σ': state} {ty: LogicType}:
  (lang_semantics C ty σ σ') ∧ (x ∉ C.Free) → σ x = σ' x :=
begin
  revert σ σ' ty,
  induction C with
    y e
    y
    C₁ C₂ hC₁ hC₂
    C₁ C₂ hC₁ hC₂
    C Ch,
  case stmt.skip {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    refl,
  },
  case stmt.assign {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    unfold stmt.Free at hxFree,
    have H: x ≠ y, { finish, },
    simp,
    rw if_neg H,
  },
  case stmt.non_det_assign {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    unfold stmt.Free at hxFree,
    have H: x ≠ y, { finish, },
    simp,
    rw if_neg H,
  },
  case stmt.seq {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    have H₁: x ∉ C₁.Free, {by_contra, apply hxFree, left, exact h,},
    have H₂: x ∉ C₂.Free, {by_contra, apply hxFree, right, exact h,},
    cases hls,
    {
      specialize hC₁ (⟨hls_H1, H₁⟩),
      specialize hC₂ (⟨hls_H2, H₂⟩),
      rw hC₁,
      exact hC₂,
    },
    { exact hC₁ (⟨hls_H1, H₁⟩), },
  },
  case stmt.choice {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    have H₁: x ∉ C₁.Free, {by_contra, apply hxFree, left, exact h,},
    have H₂: x ∉ C₂.Free, {by_contra, apply hxFree, right, exact h,},
    cases hls,
    {
      specialize hC₁ (⟨hls_h, H₁⟩),
      exact hC₁,
    },
    {
      specialize hC₂ (⟨hls_h, H₂⟩),
      exact hC₂,
    },
  },
  case stmt.star {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    revert ty σ σ',
    induction hls_i with n hC' hC',
    {
      intros _ _ _ hls_h,
      rw repeat at hls_h,
      cases hls_h,
      refl,
    },
    {
      intros ty σ σ' hls,
      rw repeat at hls,
      rw stmt.Free at hxFree,
      cases hls,
      {
        specialize Ch (⟨hls_H2, hxFree⟩),
        specialize hC' hls_H1,
        rw hC',
        exact Ch,
      },
      {
        specialize hC' hls_H1,
        exact hC',
      },
    }
  },
  case stmt.error {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    refl,
  },
  case stmt.assumes {
    rintros σ σ' ty ⟨ hls, hxFree ⟩,
    cases hls,
    refl,
  },
end

lemma expression.substitute.x_free {x y} (e: expression) (H: x ≠ y) :
  x ∉ (expression.substitute x y e).Free :=
begin
  -- unfold expression.Free,
  by_contra,
  have H := (expression.Free.semantics (expression.substitute x y e)).1 h,
  cases H with σ h,
  rcases h with ⟨v, h⟩,
  unfold expression.substitute at h,
  unfold state.substitute at h,
  simp[H, (ne.symm H)] at h,
  exact h,
end

lemma prop.substitute.x_free {x y} (P: prop) (H: x ≠ y) :
  x ∉ (prop.substitute x y P).Free :=
begin
  unfold prop.Free,
  by_contra,
  cases h with σ h,
  rcases h with ⟨v, ⟨hp, hnp⟩⟩,
  unfold prop.substitute at hp,
  unfold prop.substitute at hnp,
  unfold state.substitute at hp,
  unfold state.substitute at hnp,
  simp[ne.symm H] at hnp,
  simp[ne.symm H] at hp,
  exact H (false.rec (x = y) (hnp hp)),
end

lemma stmt.substitution.x_free {x y C} (H: x ≠ y): x ∉ (C{y // x}).Free :=
begin
  -- sorry,
  induction C with
    z e
    z
    C₁ C₂ hC₁ hC₂
    C₁ C₂ hC₁ hC₂
    C hC
    ,
  case stmt.skip {
    rw stmt.substitute,
    rw stmt.Free,
    exact set.not_mem_empty x,
  },
  case stmt.assign {
    rw stmt.substitute,
    by_cases hxz: x = z,
    {
      cases hxz,
      simp,
      rw stmt.Free,
      by_contra,
      simp[H] at h,

      exact expression.substitute.x_free e H h,
    },
    {
      simp[hxz],
      rw stmt.Free,
      by_contra,
      simp[hxz] at h,

      exact expression.substitute.x_free e H h,
    },
  },
  case stmt.non_det_assign {
    rw stmt.substitute,
    by_cases hxz: x = z,
    {
      cases hxz,
      simp,
      rw stmt.Free,
      exact H,
    },
    {
      simp [hxz],
      rw stmt.Free,
      exact hxz,
    },
  },
  case stmt.seq {
    rw stmt.substitute,
    rw stmt.Free,
    by_contra,
    cases h,
    { exact hC₁ h, },
    { exact hC₂ h, },
  },
  case stmt.choice {
    rw stmt.substitute,
    rw stmt.Free,
    by_contra,
    cases h,
    { exact hC₁ h, },
    { exact hC₂ h, },
  },
  case stmt.star {
    rw stmt.substitute,
    rw stmt.Free,
    exact hC,
  },
  case stmt.error {
    rw stmt.substitute,
    rw stmt.Free,
    exact set.not_mem_empty x,
  },
  case stmt.assumes {
    rw stmt.substitute,
    rw stmt.Free,
    exact prop.substitute.x_free C H,
  },
end

lemma expression.FreeProp.intersection
  {e: expression} {A B: set string}:
  e.FreeProp A ∧ e.FreeProp B → e.FreeProp (A ∩ B) :=
begin
  rintro ⟨ hA, hB ⟩,
  unfold expression.FreeProp,
  intros σ₁ σ₃ h,
  classical,
  let σ₂: state := λ s, if s ∈ A then σ₁ s else σ₃ s,
  have H₁₂: e σ₁ = e σ₂, {
    specialize hA σ₁ σ₂,
    apply hA,
    intro a,
    simp[σ₂],
    simp,
  },
  have H₂₃: e σ₂ = e σ₃, {
    specialize hB σ₂ σ₃,
    apply hB,
    intro b,
    simp,
    intro hb,
    have H: ↑b ∈ A ∩ B, { finish, },
    simp at h,
    exact h b (hb) (subtype.mem b),
  },
  rw H₁₂,
  exact H₂₃,
end

-- lemma finite_powerset (B: set string) : B.finite → (𝒫 B).finite :=
-- begin
--   intro h,

--   have hA := set.finite.exists_finset_coe h,
--   cases hA,

--   have hB := finset.coe_powerset (hA_w),
--   rw hA_h at hB,

--   let X : finset (set string) := ((hA_h.powerset).map (⟨coe, finset.coe_injective⟩)),

--   exact set.finite.of_finset (hA_w.powerset) hB,
-- end

-- From https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/Arguments.20with.20infinite.20sets.20and.20decidability
lemma finite_powerset {α} {s : set α} (h : s.finite) : (𝒫 s).finite :=
begin
  obtain ⟨s', hs'⟩ := set.finite.exists_finset_coe h,
  refine set.finite.of_finset (s'.powerset.map (⟨_, finset.coe_injective⟩)) _,
  simp_rw [←finset.mem_coe, ←set.ext_iff, finset.coe_map, finset.coe_powerset,
    function.embedding.coe_fn_mk, ←hs', set.image_preimage_eq_iff],
  intros x hx,
  rw set.mem_powerset_iff at hx,
  classical,
  refine ⟨s'.filter (∈ x), _⟩,
  rwa [finset.coe_filter, set.sep_mem_eq, set.inter_eq_right_iff_subset],
end

lemma expression.FreeProp.infIntersection
  (e: expression):
  (∃ B: set string,(e.FreeProp B) ∧ B.finite) → (e.FreeProp e.Free) :=
begin
  -- Argument:
  -- B ∈ A so ⋂₀ A ⊆ B
  intros h₁,
  cases h₁ with B h₁,

  -- so ⋂₀ A = ⋂₀ (a ⋂ B, a ∈ A)
  let AB : set (set string) := (λ (x: set string), (∃ (a: set string), (e.FreeProp a) ∧ x = B ∩ a)),
  have AB_finite: AB.finite,
  {
    let Bp : set (set string) := B.powerset,

    have H1: AB ⊆ Bp, {
      intros x hx,
      rcases hx with ⟨ a, ⟨ b, c ⟩ ⟩,
      rw c,
      simp,
    },
    have H2 := finite_powerset h₁.2,
    exact set.finite.subset H2 H1,
  },

  -- but B finite, so this becomes a finite set
  have H: e.Free = ⋂₀ AB, {
    have H₁: e.Free ⊆ ⋂₀ AB, {
      intros a ha t ht,
      apply ha,
      rcases ht with ⟨ s, ⟨ hs, ht⟩⟩,
      rw ht,
      exact expression.FreeProp.intersection (⟨ h₁.1, hs ⟩),
    },
    have H₂: ⋂₀ AB ⊆ e.Free, {
      intros a ha t ht,
      have H: t ∩ B ∈ AB, {
        use t,
        split,
        { exact ht, },
        { exact set.inter_comm t B, },
      },
      exact set.mem_of_mem_inter_left (ha (t ∩ B) H),
    },
    exact subset_antisymm H₁ H₂,
  },
  rw H,

  let prop : set (set string) → Prop := λ A, e.FreeProp (⋂₀ A),
  have H₀: prop ∅, {
    intros σ σ' h,
    simp at h,
    have H: σ = σ', { exact funext h, },
    rw H,
  },
  -- So get result by applying above theorem inductively
  exact set.finite.induction_on' AB_finite (H₀) (by {
    intros s A hs hA hs' hAi,
    have H: ⋂₀ insert s A = ⋂₀ A ∩ s, {
      ext,
      split,
      { finish, },
      { finish, }
    },
    rw H,
    rcases hs with ⟨ t, ⟨ ht, hs ⟩ ⟩,
    exact expression.FreeProp.intersection (⟨ hAi,
      (by { rw hs, exact expression.FreeProp.intersection (⟨h₁.1, ht⟩) })
    ⟩),
  }),
end

lemma for_all_free_expression {e: expression} {σ σ': state }
  (H: ∀ x ∈ e.Free, σ x = σ' x) (H₂: ∃ A, e.FreeProp A ∧ A.finite): e σ = e σ' :=
begin
  -- if e σ ≠ e σ'
  -- then must show ∃ x ∈ e.Free st σ x ≠ σ' x
  -- ?

  -- freeprop {x, y} freeprop {x, z} → freeprop {x}
  -- show binary intersections
  -- show infinite intersections
  -- thus we have what we want
  -- infinite intersections in lean?

  have H₂: e.FreeProp e.Free, {
    unfold expression.Free,
    exact expression.FreeProp.infIntersection e H₂,
  },

  unfold expression.FreeProp at H₂,
  specialize H₂ σ σ',
  simp at H₂,
  exact H₂ H,
end

end IncLoLang


-- Chapter 9.3 From "Articol metateoreme"

import ProofMining.Proof
import ProofMining.Formula
import ProofMining.IntuitionisticRules

open Formula (falsum WellFormed)
namespace Proof

set_option maxHeartbeats 1000000

theorem t19 (A B : Formula)
  (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ (A ⋀ B ⟹ B) :=
  let p₁ : e ;; Γ ⊢ (A ⋀ B ⟹ B ⋀ A) := permConj
  let p₂ : e ;; Γ ⊢ (B ⋀ A ⟹ B) := weakConj
  syllogism p₁ p₂

theorem t20 (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) : e ;; Γ ⊢ (B ⟹ A ⋁ B) :=
  let p₁ : e ;; Γ ⊢ (B ⟹ B ⋁ A) := weakDisj
  let p₂ : e ;; Γ ⊢ (B ⋁ A ⟹ A ⋁ B) := permDisj
  syllogism p₁ p₂

theorem t21 (A : Formula) (_ : WellFormed e A := by autowf) : e ;; Γ ⊢ A ⟹ A :=
  let p₁ : e ;; Γ ⊢ A ⟹ A ⋀ A := contrConj
  let p₂ : e ;; Γ ⊢ A ⋀ A ⟹ A := weakConj
  syllogism p₁ p₂

theorem t18 (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) : e ;; Γ ⊢ (∼A ⋀ A ⟹ B) :=
  let p₁ : e ;; Γ ⊢ (falsum ⟹ B) := exFalso
  let p₂ : e ;; Γ ⊢ ∼(∼A ⋀ A) := importation (t21 ∼A)
  syllogism p₂ p₁

theorem t22 (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ A ⟹ (B ⟹ (A ⋀ B)) :=
  let p₁ : e ;; Γ ⊢ (A ⋀ B) ⟹ (A ⋀ B) := t21 _
  exportation p₁

theorem t23 (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ A ⟹ (B ⟹ A) :=
  let p₁ : e ;; Γ ⊢ (A ⋀ B) ⟹ A := weakConj
  exportation p₁

theorem t24 (A : Formula) (_ : WellFormed e A := by autowf) :
  e ;; Γ ⊢ (A ⟹ ∼∼A) :=
  let p₁ : e ;; Γ ⊢ (A ⋀ ∼A ⟹ ∼A ⋀ A) := permConj
  let p₂ : e ;; Γ ⊢ ∼(A ⋀ ∼A) := syllogism p₁ (t18 A falsum)
  exportation p₂

theorem t26a (A : Formula) (_ : WellFormed e A := by autowf) :
  e ;; Γ ⊢ ∼A ⟹ ∼∼∼A :=
  t24 ∼A

theorem t26b (A : Formula) (_ : WellFormed e A := by autowf) :
  e ;; Γ ⊢ ∼∼∼A ⟹ ∼A :=
  let p₁ : e ;; Γ ⊢ A ⟹ ∼∼∼∼A := syllogism (t24 _) (t24 _)
  let p₂ : e ;; Γ ⊢ ∼∼∼A ⋀ A ⟹ falsum := syllogism (permConj) (importation p₁)
  exportation p₂

theorem t28a (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ ∼∼(A ⟹ B) ⟹ (∼∼A ⟹ ∼∼B) :=
  sorry

theorem t28b (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ (∼∼A ⟹ ∼∼B) ⟹ ∼∼(A ⟹ B) :=
  let p₁ : e ;; Γ ⊢ (A ⟹ B) ⟹ ∼∼A ⟹ (A ⟹ B) := t23 _ _
  let p₂ : e ;; Γ ⊢ (A ⟹ B) ⋀ ∼∼A ⋀ A ⟹ ∼∼B := syllogism (importation (importation p₁)) (t24 B)
  let p₃ : e ;; Γ ⊢ (A ⟹ B) ⋀ ∼∼A ⟹ (A ⟹ B) ⋀ ∼∼A ⋀ A := sorry
  let p₄ : e ;; Γ ⊢ (A ⟹ B) ⋀ ∼∼A ⟹ ∼∼B := syllogism p₃ p₂
  -- let p₅ (h₁: Γ ⊢ A ⟹ B) : Γ ⊢ ∼A ⟹ ∼B := sorry
  let p₆ : e ;; Γ ⊢ (A ⟹ B) ⟹ (∼∼A ⟹ ∼∼B) := exportation p₄
  let p₇ : e ;; Γ ⊢ ∼(A ⟹ B) ⟹ ∼(∼∼A ⟹ ∼∼B) := sorry
  sorry

theorem t27a (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ ∼∼(A ⟹ B) ⟹ (A ⟹ ∼∼B) :=
  let p₀ : e ;; Γ ⊢ (∼∼(A ⟹ B)) ⋀ ∼∼A ⟹ ∼∼B := importation (t28a _ _)
  let p₁ : e ;; Γ ⊢ ∼∼A ⋀ (∼∼(A ⟹ B)) ⟹ (∼∼(A ⟹ B)) ⋀ ∼∼A := permConj
  let p₂ : e ;; Γ ⊢ ∼∼A ⋀ (∼∼(A ⟹ B)) ⟹ ∼∼B := syllogism p₁ p₀
  let p₃ : e ;; Γ ⊢ ∼∼A ⟹ ∼∼(A ⟹ B) ⟹ ∼∼B := exportation p₂
  let p₄ : e ;; Γ ⊢ A ⟹ ∼∼(A ⟹ B) ⟹ ∼∼B := syllogism (t24 _) p₃
  exportation (syllogism (permConj) (importation p₄))

-- theorem t27b (A B : Formula) : Γ ⊢ (A ⟹ ∼∼B) ⟹ ∼∼(A ⟹ B) :=
--   sorry

theorem t29a (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ (A ⟹ ∼B) ⟹ (∼∼A ⟹ ∼B) :=
  let p₁ : e ;; Γ ⊢ (A ⟹ ∼B) ⟹ (∼∼A ⟹ ∼∼∼B) := syllogism (t24 _) (t28a _ _)
  let p₂ : e ;; Γ ⊢ (∼∼A ⟹ ∼∼∼B) ⟹ (∼∼A ⟹ ∼B) := exportation (syllogism (importation (t21 _)) (t26b _))
  syllogism p₁ p₂

-- theorem t29b (A B : Formula) : Γ ⊢ (∼∼A ⟹ ∼B) ⟹ (A ⟹ ∼B) :=
--   sorry

-- theorem t30a (A B : Formula) : Γ ⊢ ∼∼(A ⋀ B) ⟹ (∼∼A ⋀ ∼∼B) :=
--   sorry

-- theorem t30b (A B : Formula) : Γ ⊢ (∼∼A ⋀ ∼∼B) ⟹ ∼∼(A ⋀ B) :=
--   sorry

-- theorem t31 (A B : Formula) : Γ ⊢ ∼∼(A ⋁ B) ⟹ ∼∼A ⟹ ∼∼B :=
--   sorry

-- theorem t32a (A B : Formula) : Γ ⊢ ∼∼(A ⋁ B) ⟹ ∼∼(∼A ⋀ ∼B) :=
--   sorry

theorem t32b (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ ∼(∼A ⋀ ∼B) ⟹ ∼∼(A ⋁ B) :=
  sorry

theorem t25 (A : Formula) (_ : WellFormed e A := by autowf) :
  e ;; Γ ⊢ ∼∼(A ⋁ ∼A) :=
  let p₁ : e ;; Γ ⊢ ∼(∼A ⋀ ∼∼A) := syllogism (permConj) (t18 _ _)
  mpon p₁ (t32b _ _)

theorem t33a (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ ∼(A ⋀ B) ⟹ A ⟹ ∼B :=
  let p₁ : e ;; Γ ⊢ ∼(A ⋀ B) ⋀ (A ⋀ B) ⟹ falsum := t18 _ _
  let p₂ : e ;; Γ ⊢ (B ⟹ ∼∼(A ⋀ B)) ⟹ ∼(A ⋀ B) ⟹ ∼B := sorry
  sorry

theorem t33b (A B : Formula) : e ;; Γ ⊢ (A ⟹ ∼B) ⟹ ∼(A ⋀ B) :=
  sorry

theorem t35 (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ A ⋁ B ⟹ ∼A ⟹ B :=
  let p₁ : e ;; Γ ⊢ ∼A ⋀ A ⟹ B := t18 _ _
  let p₂ : e ;; Γ ⊢ A ⟹ ∼A ⟹ B := exportation (syllogism (permConj) p₁)
  let p₃ : e ;; Γ ⊢ B ⟹ ∼A ⟹ B := t23 _ _
  r49 p₂ p₃

theorem t40a (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ ∼(A ⋁ B) ⟹ (∼A ⋀ ∼B) :=
  let p₃ : e ;; Γ ⊢ A ⟹ ∼∼ (A ⋁ B) := syllogism (weakDisj) (t24 (A ⋁ B))
  let p₄ : e ;; Γ ⊢ ∼(A ⋁ B) ⋀ A ⟹ falsum := syllogism (permConj) (importation p₃)
  let p₁ : e ;; Γ ⊢ ∼(A ⋁ B) ⟹ ∼A := exportation p₄
  let p₅ : e ;; Γ ⊢ B ⟹ ∼∼ (A ⋁ B) := syllogism (t20 A B) (t24 (A ⋁ B))
  let p₆ : e ;; Γ ⊢ ∼(A ⋁ B) ⋀ B ⟹ falsum := syllogism (permConj) (importation p₅)
  let p₂ : e ;; Γ ⊢ ∼(A ⋁ B) ⟹ ∼B := exportation p₆
  r45 p₁ p₂

theorem t40b (A B : Formula) (_ : WellFormed e A := by autowf) (_ : WellFormed e B := by autowf) :
  e ;; Γ ⊢ (∼A ⋀ ∼B) ⟹ ∼(A ⋁ B) :=
  let p₁ : e ;; Γ ⊢ A ⟹ ∼A ⟹ ∼∼B := exportation (syllogism (permConj) (t18 _ _))
  let p₂ : e ;; Γ ⊢ B ⟹ ∼A ⟹ ∼∼B := exportation (syllogism (permConj) (importation (r44 (t24 _))))
  let p₃ : e ;; Γ ⊢ A ⋁ B ⟹ ∼A ⟹ ∼∼B := r49 p₁ p₂
  let p₄ : e ;; Γ ⊢ (∼A ⟹ ∼∼B) ⟹ ∼(∼A ⋀ ∼B) := t33b _ _
  let p₅ : e ;; Γ ⊢ A ⋁ B ⟹ ∼(∼A ⋀ ∼B) := syllogism p₃ p₄
  exportation (syllogism (permConj) (importation p₅))


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.finite_limits
import category_theory.limits.shapes.products
import category_theory.limits.shapes.terminal

/-!
# Categories with finite (co)products

Typeclasses representing categories with (co)products over finite indexing types.
-/

universes w v u

open category_theory
open_locale classical

namespace category_theory.limits

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

/--
A category has finite products if there is a chosen limit for every diagram
with shape `discrete J`, where we have `[fintype J]`.
-/
-- We can't simply make this an abbreviation, as we do with other `has_Xs` limits typeclasses,
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_products : Prop :=
(out (J : Type) [fintype J] : has_limits_of_shape (discrete J) C)

instance has_limits_of_shape_discrete
  (J : Type) [fintype J] [has_finite_products C] :
  has_limits_of_shape (discrete J) C :=
by { haveI := @has_finite_products.out C _ _ J, apply_instance }

/-- If `C` has finite limits then it has finite products. -/
@[priority 10]
instance has_finite_products_of_has_finite_limits [has_finite_limits C] :
  has_finite_products C :=
⟨λ J 𝒥, by { resetI, apply_instance }⟩

instance has_fintype_products [has_finite_products C] (ι : Type w) [fintype ι] :
  has_limits_of_shape (discrete ι) C :=
has_limits_of_shape_of_equivalence
  (discrete.equivalence
    ((show ulift.{0} (fin (fintype.card ι)) ≃ fin (fintype.card ι), by tidy).trans
      (fintype.equiv_fin ι).symm))

/-- We can now write this for powers. -/
noncomputable example [has_finite_products C] (X : C) : C := ∏ (λ (i : fin 5), X)

/--
If a category has all products then in particular it has finite products.
-/
lemma has_finite_products_of_has_products [has_products.{w} C] : has_finite_products C :=
⟨λ J _, has_limits_of_shape_of_equivalence (discrete.equivalence (equiv.ulift.{w}))⟩

/--
A category has finite coproducts if there is a chosen colimit for every diagram
with shape `discrete J`, where we have `[fintype J]`.
-/
class has_finite_coproducts : Prop :=
(out (J : Type) [fintype J] : has_colimits_of_shape (discrete J) C)

attribute [class] has_finite_coproducts

instance has_colimits_of_shape_discrete
  (J : Type) [fintype J] [has_finite_coproducts C] :
  has_colimits_of_shape (discrete J) C :=
by { haveI := @has_finite_coproducts.out C _ _ J, apply_instance }

/-- If `C` has finite colimits then it has finite coproducts. -/
@[priority 10]
instance has_finite_coproducts_of_has_finite_colimits [has_finite_colimits C] :
  has_finite_coproducts C :=
⟨λ J 𝒥, by { resetI, apply_instance }⟩

instance has_fintype_coproducts [has_finite_coproducts C] (ι : Type w) [fintype ι] :
  has_colimits_of_shape (discrete ι) C :=
has_colimits_of_shape_of_equivalence
  (discrete.equivalence
    ((show ulift.{0} (fin (fintype.card ι)) ≃ fin (fintype.card ι), by tidy).trans
      (fintype.equiv_fin ι).symm))

/--
If a category has all coproducts then in particular it has finite coproducts.
-/
lemma has_finite_coproducts_of_has_coproducts [has_coproducts.{w} C] : has_finite_coproducts C :=
⟨λ J _, has_colimits_of_shape_of_equivalence (discrete.equivalence (equiv.ulift.{w}))⟩

end category_theory.limits


example (P Q R S T U: Type)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=
begin
have q := h(p),
have t := j(q),
exact l(t),
end


import data.fintype.basic

namespace finset
variables {α β : Type*} [decidable_eq β]

lemma image_subtype_ne_univ_eq_image_erase [fintype α] (k : β) (b : α → β) :
  image (λ i : {a // b a ≠ k}, b ↑i) univ = (image b univ).erase k :=
begin
  apply subset_antisymm,
  { rw image_subset_iff,
    intros i _,
    apply mem_erase_of_ne_of_mem i.2 (mem_image_of_mem _ (mem_univ _)) },
  { intros i hi,
    rw mem_image,
    rcases mem_image.1 (erase_subset _ _ hi) with ⟨a, _, ha⟩,
    subst ha,
    exact ⟨⟨a, ne_of_mem_erase hi⟩, mem_univ _, rfl⟩ }
end

lemma image_subtype_univ_ssubset_image_univ [fintype α] (k : β) (b : α → β)
  (hk : k ∈ image b univ) (p : β → Prop) [decidable_pred p] (hp : ¬ p k) :
  image (λ i : {a // p (b a)}, b ↑i) univ ⊂ image b univ :=
begin
  split,
  { intros x hx,
    rcases mem_image.1 hx with ⟨y, _, hy⟩,
    exact hy ▸ mem_image_of_mem b (mem_univ y) },
  { intros h,
    rw mem_image at hk,
    rcases hk with ⟨k', _, hk'⟩, subst hk',
    have := h (mem_image_of_mem b (mem_univ k')),
    rw mem_image at this,
    rcases this with ⟨j, hj, hj'⟩,
    exact hp (hj' ▸ j.2) }
end

end finset


import algebra.module.basic
import algebra.module.linear_map
import linear_algebra.basic
import linear_algebra.prod
import linear_algebra.projection
import order.bounded_lattice

theorem cpge_reduction_1 (R : Type*) (M : Type*)
[semiring R] [add_comm_monoid M] [module R M] (u : linear_map R M M) (E : submodule R M) :
u '' u.ker = u.ker ∧ (u '' E) = E := sorry


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import geometry.manifold.algebra.structures
import geometry.manifold.bump_function
import topology.paracompact
import topology.partition_of_unity
import topology.shrinking_lemma

/-!
# Smooth partition of unity

In this file we define two structures, `smooth_bump_covering` and `smooth_partition_of_unity`. Both
structures describe coverings of a set by a locally finite family of supports of smooth functions
with some additional properties. The former structure is mostly useful as an intermediate step in
the construction of a smooth partition of unity but some proofs that traditionally deal with a
partition of unity can use a `smooth_bump_covering` as well.

Given a real manifold `M` and its subset `s`, a `smooth_bump_covering ι I M s` is a collection of
`smooth_bump_function`s `f i` indexed by `i : ι` such that

* the center of each `f i` belongs to `s`;
* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, there exists `i : ι` such that `f i =ᶠ[𝓝 x] 1`.
In the same settings, a `smooth_partition_of_unity ι I M s` is a collection of smooth nonnegative
functions `f i : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯`, `i : ι`, such that

* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, the sum `∑ᶠ i, f i x` equals one;
* for each `x`, the sum `∑ᶠ i, f i x` is less than or equal to one.

We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `closure (support (f i)) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.

We prove that on a smooth finitely dimensional real manifold with `σ`-compact Hausdorff topology,
for any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a similar statement about smooth partitions of
unity.

## Implementation notes

## TODO

* Build a framework for to transfer local definitions to global using partition of unity and use it
  to define, e.g., the integral of a differential form over a manifold.

## Tags

smooth bump function, partition of unity
-/

universes uι uE uH uM

open function filter finite_dimensional set
open_locale topological_space manifold classical filter big_operators

noncomputable theory

variables {ι : Type uι}
{E : Type uE} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type uH} [topological_space H] (I : model_with_corners ℝ E H)
{M : Type uM} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-!
### Covering by supports of smooth bump functions

In this section we define `smooth_bump_covering ι I M s` to be a collection of
`smooth_bump_function`s such that their supports is a locally finite family of sets and for each `x
∈ s` some function `f i` from the collection is equal to `1` in a neighborhood of `x`. A covering of
this type is useful to construct a smooth partition of unity and can be used instead of a partition
of unity in some proofs.

We prove that on a smooth finite dimensional real manifold with `σ`-compact Hausdorff topology, for
any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a version of the Whitney embedding theorem: any
compact real manifold can be embedded into `ℝ^n` for large enough `n`.  -/

variables (ι M)

/-- We say that a collection of `smooth_bump_function`s is a `smooth_bump_covering` of a set `s` if

* `(f i).c ∈ s` for all `i`;
* the family `λ i, support (f i)` is locally finite;
* for each point `x ∈ s` there exists `i` such that `f i =ᶠ[𝓝 x] 1`;
  in other words, `x` belongs to the interior of `{y | f i y = 1}`;

If `M` is a finite dimensional real manifold which is a sigma-compact Hausdorff topological space,
then for every covering `U : M → set M`, `∀ x, U x ∈ 𝓝 x`, there exists a `smooth_bump_covering`
subordinate to `U`, see `smooth_bump_covering.exists_is_subordinate`.

This covering can be used, e.g., to construct a partition of unity and to prove the weak
Whitney embedding theorem. -/
@[nolint has_inhabited_instance]
structure smooth_bump_covering (s : set M := univ) :=
(c : ι → M)
(to_fun : Π i, smooth_bump_function I (c i))
(c_mem' : ∀ i, c i ∈ s)
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(eventually_eq_one' : ∀ x ∈ s, ∃ i, to_fun i =ᶠ[𝓝 x] 1)

/-- We say that that a collection of functions form a smooth partition of unity on a set `s` if

* all functions are infinitely smooth and nonnegative;
* the family `λ i, support (f i)` is locally finite;
* for all `x ∈ s` the sum `∑ᶠ i, f i x` equals one;
* for all `x`, the sum `∑ᶠ i, f i x` is less than or equal to one. -/
structure smooth_partition_of_unity (s : set M := univ) :=
(to_fun : ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯)
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(nonneg' : ∀ i x, 0 ≤ to_fun i x)
(sum_eq_one' : ∀ x ∈ s, ∑ᶠ i, to_fun i x = 1)
(sum_le_one' : ∀ x, ∑ᶠ i, to_fun i x ≤ 1)

variables {ι I M}

namespace smooth_partition_of_unity

variables {s : set M} (f : smooth_partition_of_unity ι I M s)

instance {s : set M} : has_coe_to_fun (smooth_partition_of_unity ι I M s)
  (λ _, ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯) :=
⟨smooth_partition_of_unity.to_fun⟩

protected lemma locally_finite : locally_finite (λ i, support (f i)) :=
f.locally_finite'

lemma nonneg (i : ι) (x : M) : 0 ≤ f i x := f.nonneg' i x

lemma sum_eq_one {x} (hx : x ∈ s) : ∑ᶠ i, f i x = 1 := f.sum_eq_one' x hx

lemma sum_le_one (x : M) : ∑ᶠ i, f i x ≤ 1 := f.sum_le_one' x

/-- Reinterpret a smooth partition of unity as a continuous partition of unity. -/
def to_partition_of_unity : partition_of_unity ι M s :=
{ to_fun := λ i, f i, .. f }

lemma smooth_sum : smooth I 𝓘(ℝ) (λ x, ∑ᶠ i, f i x) :=
smooth_finsum (λ i, (f i).smooth) f.locally_finite

lemma le_one (i : ι) (x : M) : f i x ≤ 1 := f.to_partition_of_unity.le_one i x

lemma sum_nonneg (x : M) : 0 ≤ ∑ᶠ i, f i x := f.to_partition_of_unity.sum_nonneg x

/-- A smooth partition of unity `f i` is subordinate to a family of sets `U i` indexed by the same
type if for each `i` the closure of the support of `f i` is a subset of `U i`. -/
def is_subordinate (f : smooth_partition_of_unity ι I M s) (U : ι → set M) :=
∀ i, closure (support (f i)) ⊆ U i

@[simp] lemma is_subordinate_to_partition_of_unity {f : smooth_partition_of_unity ι I M s}
  {U : ι → set M} :
  f.to_partition_of_unity.is_subordinate U ↔ f.is_subordinate U :=
iff.rfl

alias is_subordinate_to_partition_of_unity ↔
  _ smooth_partition_of_unity.is_subordinate.to_partition_of_unity

end smooth_partition_of_unity

namespace bump_covering

-- Repeat variables to drop [finite_dimensional ℝ E] and [smooth_manifold_with_corners I M]
lemma smooth_to_partition_of_unity {E : Type uE} [normed_group E] [normed_space ℝ E]
  {H : Type uH} [topological_space H] {I : model_with_corners ℝ E H}
  {M : Type uM} [topological_space M] [charted_space H M] {s : set M}
  (f : bump_covering ι M s) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) (i : ι) :
  smooth I 𝓘(ℝ) (f.to_partition_of_unity i) :=
(hf i).mul $ smooth_finprod_cond (λ j _, smooth_const.sub (hf j)) $
  by { simp only [mul_support_one_sub], exact f.locally_finite }

variables {s : set M}

/-- A `bump_covering` such that all functions in this covering are smooth generates a smooth
partition of unity.

In our formalization, not every `f : bump_covering ι M s` with smooth functions `f i` is a
`smooth_bump_covering`; instead, a `smooth_bump_covering` is a covering by supports of
`smooth_bump_function`s. So, we define `bump_covering.to_smooth_partition_of_unity`, then reuse it
in `smooth_bump_covering.to_smooth_partition_of_unity`. -/
def to_smooth_partition_of_unity (f : bump_covering ι M s) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  smooth_partition_of_unity ι I M s :=
{ to_fun := λ i, ⟨f.to_partition_of_unity i, f.smooth_to_partition_of_unity hf i⟩,
  .. f.to_partition_of_unity }

@[simp] lemma to_smooth_partition_of_unity_to_partition_of_unity (f : bump_covering ι M s)
  (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  (f.to_smooth_partition_of_unity hf).to_partition_of_unity = f.to_partition_of_unity :=
rfl

@[simp] lemma coe_to_smooth_partition_of_unity (f : bump_covering ι M s)
  (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) (i : ι) :
  ⇑(f.to_smooth_partition_of_unity hf i) = f.to_partition_of_unity i :=
rfl

lemma is_subordinate.to_smooth_partition_of_unity {f : bump_covering ι M s}
  {U : ι → set M} (h : f.is_subordinate U) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  (f.to_smooth_partition_of_unity hf).is_subordinate U :=
h.to_partition_of_unity

end bump_covering

namespace smooth_bump_covering

variables {s : set M} {U : M → set M} (fs : smooth_bump_covering ι I M s) {I}

instance : has_coe_to_fun (smooth_bump_covering ι I M s)
  (λ x, Π (i : ι), smooth_bump_function I (x.c i)) :=
⟨to_fun⟩

@[simp] lemma coe_mk (c : ι → M) (to_fun : Π i, smooth_bump_function I (c i))
  (h₁ h₂ h₃) : ⇑(mk c to_fun h₁ h₂ h₃ : smooth_bump_covering ι I M s) = to_fun :=
rfl

/--
We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `closure (support (f i)) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.
-/
def is_subordinate {s : set M} (f : smooth_bump_covering ι I M s) (U : M → set M) :=
∀ i, closure (support $ f i) ⊆ U (f.c i)

lemma is_subordinate.support_subset {fs : smooth_bump_covering ι I M s} {U : M → set M}
  (h : fs.is_subordinate U) (i : ι) :
  support (fs i) ⊆ U (fs.c i) :=
subset.trans subset_closure (h i)

variable (I)

/-- Let `M` be a smooth manifold with corners modelled on a finite dimensional real vector space.
Suppose also that `M` is a Hausdorff `σ`-compact topological space. Let `s` be a closed set
in `M` and `U : M → set M` be a collection of sets such that `U x ∈ 𝓝 x` for every `x ∈ s`.
Then there exists a smooth bump covering of `s` that is subordinate to `U`. -/
lemma exists_is_subordinate [t2_space M] [sigma_compact_space M] (hs : is_closed s)
  (hU : ∀ x ∈ s, U x ∈ 𝓝 x) :
  ∃ (ι : Type uM) (f : smooth_bump_covering ι I M s), f.is_subordinate U :=
begin
  -- First we deduce some missing instances
  haveI : locally_compact_space H := I.locally_compact,
  haveI : locally_compact_space M := charted_space.locally_compact H,
  haveI : normal_space M := normal_of_paracompact_t2,
  -- Next we choose a covering by supports of smooth bump functions
  have hB := λ x hx, smooth_bump_function.nhds_basis_support I (hU x hx),
  rcases refinement_of_locally_compact_sigma_compact_of_nhds_basis_set hs hB
    with ⟨ι, c, f, hf, hsub', hfin⟩, choose hcs hfU using hf,
  /- Then we use the shrinking lemma to get a covering by smaller open -/
  rcases exists_subset_Union_closed_subset hs (λ i, (f i).open_support)
    (λ x hx, hfin.point_finite x) hsub' with ⟨V, hsV, hVc, hVf⟩,
  choose r hrR hr using λ i, (f i).exists_r_pos_lt_subset_ball (hVc i) (hVf i),
  refine ⟨ι, ⟨c, λ i, (f i).update_r (r i) (hrR i), hcs, _, λ x hx, _⟩, λ i, _⟩,
  { simpa only [smooth_bump_function.support_update_r] },
  { refine (mem_Union.1 $ hsV hx).imp (λ i hi, _),
    exact ((f i).update_r _ _).eventually_eq_one_of_dist_lt
      ((f i).support_subset_source $ hVf _ hi) (hr i hi).2 },
  { simpa only [coe_mk, smooth_bump_function.support_update_r] using hfU i }
end

variables {I M}

protected lemma locally_finite : locally_finite (λ i, support (fs i)) := fs.locally_finite'

protected lemma point_finite (x : M) : {i | fs i x ≠ 0}.finite :=
fs.locally_finite.point_finite x

lemma mem_chart_at_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
  x ∈ (chart_at H (fs.c i)).source :=
(fs i).support_subset_source $ by simp [h]

lemma mem_ext_chart_at_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
  x ∈ (ext_chart_at I (fs.c i)).source :=
by { rw ext_chart_at_source, exact fs.mem_chart_at_source_of_eq_one h }

/-- Index of a bump function such that `fs i =ᶠ[𝓝 x] 1`. -/
def ind (x : M) (hx : x ∈ s) : ι := (fs.eventually_eq_one' x hx).some

lemma eventually_eq_one (x : M) (hx : x ∈ s) : fs (fs.ind x hx) =ᶠ[𝓝 x] 1 :=
(fs.eventually_eq_one' x hx).some_spec

lemma apply_ind (x : M) (hx : x ∈ s) : fs (fs.ind x hx) x = 1 :=
(fs.eventually_eq_one x hx).eq_of_nhds

lemma mem_support_ind (x : M) (hx : x ∈ s) : x ∈ support (fs $ fs.ind x hx) :=
by simp [fs.apply_ind x hx]

lemma mem_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (chart_at H (fs.c (fs.ind x hx))).source :=
fs.mem_chart_at_source_of_eq_one (fs.apply_ind x hx)

lemma mem_ext_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (ext_chart_at I (fs.c (fs.ind x hx))).source :=
fs.mem_ext_chart_at_source_of_eq_one (fs.apply_ind x hx)

/-- The index type of a `smooth_bump_covering` of a compact manifold is finite. -/
protected def fintype [compact_space M] : fintype ι :=
fs.locally_finite.fintype_of_compact $ λ i, (fs i).nonempty_support

variable [t2_space M]

/-- Reinterpret a `smooth_bump_covering` as a continuous `bump_covering`. Note that not every
`f : bump_covering ι M s` with smooth functions `f i` is a `smooth_bump_covering`. -/
def to_bump_covering : bump_covering ι M s :=
{ to_fun := λ i, ⟨fs i, (fs i).continuous⟩,
  locally_finite' := fs.locally_finite,
  nonneg' := λ i x, (fs i).nonneg,
  le_one' := λ i x, (fs i).le_one,
  eventually_eq_one' := fs.eventually_eq_one' }

@[simp] lemma is_subordinate_to_bump_covering {f : smooth_bump_covering ι I M s} {U : M → set M} :
  f.to_bump_covering.is_subordinate (λ i, U (f.c i)) ↔ f.is_subordinate U :=
iff.rfl

alias is_subordinate_to_bump_covering ↔
  _ smooth_bump_covering.is_subordinate.to_bump_covering

/-- Every `smooth_bump_covering` defines a smooth partition of unity. -/
def to_smooth_partition_of_unity : smooth_partition_of_unity ι I M s :=
fs.to_bump_covering.to_smooth_partition_of_unity (λ i, (fs i).smooth)

lemma to_smooth_partition_of_unity_apply (i : ι) (x : M) :
  fs.to_smooth_partition_of_unity i x = fs i x * ∏ᶠ j (hj : well_ordering_rel j i), (1 - fs j x) :=
rfl

lemma to_smooth_partition_of_unity_eq_mul_prod (i : ι) (x : M) (t : finset ι)
  (ht : ∀ j, well_ordering_rel j i → fs j x ≠ 0 → j ∈ t) :
  fs.to_smooth_partition_of_unity i x =
    fs i x * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - fs j x) :=
fs.to_bump_covering.to_partition_of_unity_eq_mul_prod i x t ht

lemma exists_finset_to_smooth_partition_of_unity_eventually_eq (i : ι) (x : M) :
  ∃ t : finset ι, fs.to_smooth_partition_of_unity i =ᶠ[𝓝 x]
    fs i * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - fs j) :=
fs.to_bump_covering.exists_finset_to_partition_of_unity_eventually_eq i x

lemma to_smooth_partition_of_unity_zero_of_zero {i : ι} {x : M} (h : fs i x = 0) :
  fs.to_smooth_partition_of_unity i x = 0 :=
fs.to_bump_covering.to_partition_of_unity_zero_of_zero h

lemma support_to_smooth_partition_of_unity_subset (i : ι) :
  support (fs.to_smooth_partition_of_unity i) ⊆ support (fs i) :=
fs.to_bump_covering.support_to_partition_of_unity_subset i

lemma is_subordinate.to_smooth_partition_of_unity {f : smooth_bump_covering ι I M s} {U : M → set M}
  (h : f.is_subordinate U) :
  f.to_smooth_partition_of_unity.is_subordinate (λ i, U (f.c i)) :=
h.to_bump_covering.to_partition_of_unity

lemma sum_to_smooth_partition_of_unity_eq (x : M) :
  ∑ᶠ i, fs.to_smooth_partition_of_unity i x = 1 - ∏ᶠ i, (1 - fs i x) :=
fs.to_bump_covering.sum_to_partition_of_unity_eq x

end smooth_bump_covering

variable (I)

/-- Given two disjoint closed sets in a Hausdorff σ-compact finite dimensional manifold, there
exists an infinitely smooth function that is equal to `0` on one of them and is equal to one on the
other. -/
lemma exists_smooth_zero_one_of_closed [t2_space M] [sigma_compact_space M] {s t : set M}
  (hs : is_closed s) (ht : is_closed t) (hd : disjoint s t) :
  ∃ f : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯, eq_on f 0 s ∧ eq_on f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1 :=
begin
  have : ∀ x ∈ t, sᶜ ∈ 𝓝 x, from λ x hx, hs.is_open_compl.mem_nhds (disjoint_right.1 hd hx),
  rcases smooth_bump_covering.exists_is_subordinate I ht this with ⟨ι, f, hf⟩,
  set g := f.to_smooth_partition_of_unity,
  refine ⟨⟨_, g.smooth_sum⟩, λ x hx, _, λ x, g.sum_eq_one, λ x, ⟨g.sum_nonneg x, g.sum_le_one x⟩⟩,
  suffices : ∀ i, g i x = 0,
    by simp only [this, times_cont_mdiff_map.coe_fn_mk, finsum_zero, pi.zero_apply],
  refine λ i, f.to_smooth_partition_of_unity_zero_of_zero _,
  exact nmem_support.1 (subset_compl_comm.1 (hf.support_subset i) hx)
end

variable {I}

namespace smooth_partition_of_unity

/-- A `smooth_partition_of_unity` that consists of a single function, uniformly equal to one,
defined as an example for `inhabited` instance. -/
def single (i : ι) (s : set M) : smooth_partition_of_unity ι I M s :=
(bump_covering.single i s).to_smooth_partition_of_unity $ λ j,
  begin
    rcases eq_or_ne j i with rfl|h,
    { simp only [smooth_one, continuous_map.coe_one, bump_covering.coe_single, pi.single_eq_same] },
    { simp only [smooth_zero, bump_covering.coe_single, pi.single_eq_of_ne h,
        continuous_map.coe_zero] }
  end

instance [inhabited ι] (s : set M) : inhabited (smooth_partition_of_unity ι I M s) :=
⟨single (default ι) s⟩

variables [t2_space M] [sigma_compact_space M]

/-- If `X` is a paracompact normal topological space and `U` is an open covering of a closed set
`s`, then there exists a `bump_covering ι X s` that is subordinate to `U`. -/
lemma exists_is_subordinate {s : set M} (hs : is_closed s) (U : ι → set M) (ho : ∀ i, is_open (U i))
  (hU : s ⊆ ⋃ i, U i) :
  ∃ f : smooth_partition_of_unity ι I M s, f.is_subordinate U :=
begin
  haveI : locally_compact_space H := I.locally_compact,
  haveI : locally_compact_space M := charted_space.locally_compact H,
  haveI : normal_space M := normal_of_paracompact_t2,
  rcases bump_covering.exists_is_subordinate_of_prop (smooth I 𝓘(ℝ)) _ hs U ho hU
    with ⟨f, hf, hfU⟩,
  { exact ⟨f.to_smooth_partition_of_unity hf, hfU.to_smooth_partition_of_unity hf⟩ },
  { intros s t hs ht hd,
    rcases exists_smooth_zero_one_of_closed I hs ht hd with ⟨f, hf⟩,
    exact ⟨f, f.smooth, hf⟩ }
end

end smooth_partition_of_unity


import Mt.Utils.Nat

namespace Mt

/-- Class to represent 'reservations'

  Reservations are the main method for reasoning about inter-thread behaviour.

  Basic idea: Only threads with a certain reservation are allowed to do certain
  things. In many cases, some operation cannot be done atomically. Instead,
  a thread needs to do several steps. Using reservations, the thread can keep
  track about how many of those steps it has already accomplished. Other
  threads have no way to manipulate each other's reservation, only their own.

  For reasoning, the reservations of all threads have to be taken into account.
  However, we want:
  * The order of the other threads should not matter
  * It should not matter if there are 10 other threads, or only one which
    achieved those reservations

  As a consequence, we require an addition operator for reservations. Invariants
  used for reasoning may use both the shared state and the sum of all
  reservations, but not individual reservations. Each thread has to guarantee the
  invariant, but it only knows about its own reservation, i.e. it has a lower
  bound on the reservation, but nothing more. Therefore, it's actions are limited
  by the reservation it has already achieved on its own.

  ### Example:
  * There is one shared `Nat` variable `x`
  * Each thread performs the following three steps:
    - generate a random variable `n : Nat`
    - increase `x` by `n + 1` atomically
    - decrease `x` by `n` atomically
  * We want to reason that - in the end - `x` is never zero.

    Solution: We introduce a `reservation : Nat` reservation which keeps track of how much
    we have increased `x`. Therefore, the have the invariant ∑reservation = x.
    Now, we can easily reason about the thread:
  * Step 1: Generating the random number has no effect on the shared variable
  * Step 2: We increase `x` by `n + 1` and assign `reservation :=n + 1`. Since the
    reservations of the other threads have not changed, the invariant still holds
  * Step 3: Since no other thread can affect our reservation, we still know that
    `reservation = n + 1`. Because of our invariant, we also know
    `x = ∑reservation ≥ reservation = n + 1`. Therefore, we can safely decrease both `x`
    and `reservation` by `n` and we still have `x > 0`
-/
class IsReservation (T : Type)
  extends
    Add T,
    Lean.IsAssociative (@HAdd.hAdd T T T _),
    Lean.IsCommutative (@HAdd.hAdd T T T _)
  where
    empty : T
    empty_add : ∀ t : T, empty + t = t

/-- Specification for a multithreading system

  This specification specifies the context for threads but not the
  threads itself. Threads encode a specification in their type. Only
  threads with the same specification can be executed in parallel
-/
structure Spec where
  State : Type
  Reservation : Type
  [is_reservation : IsReservation Reservation]
  validate : Reservation -> State -> Prop

end Mt

namespace Mt
instance : IsReservation Nat where
  assoc     := Nat.add_assoc
  comm      := Nat.add_comm
  empty     := 0
  empty_add := Nat.zero_add

def LowerBound :=Nat

instance : Add LowerBound :=⟨Nat.max⟩

instance LowerBound.instance : IsReservation LowerBound where
  assoc :=Utils.Nat.max_assoc
  comm :=Utils.Nat.max_comm
  empty :=(0 : Nat)
  empty_add :=Utils.Nat.zero_max

structure UnitReservation

instance : IsReservation UnitReservation where
  add := λ _ _ => ⟨⟩
  assoc :=by intros ; rfl
  comm :=by intros ; rfl
  empty :=⟨⟩
  empty_add :=by intros ; rfl

inductive Lock (T : Type) where
| Unlocked
| Locked : T -> Lock T
| Invalid

def Lock.is_locked {T : Type} : Lock T -> Bool
| Locked _ => true
| _ => false

def Lock.is_locked_and_valid {T : Type} (valid : T -> Prop) : Lock T -> Prop
| Locked s => valid s
| _ => False

def Lock.is_unlocked {T : Type} : Lock T -> Bool
| Unlocked => true
| _ => false

def Lock.add {T : Type} : Lock T -> Lock T -> Lock T
| Unlocked, a => a
| a, Unlocked => a
| _, _ => Invalid

theorem Lock.eq_of_is_unlocked {T : Type} {r : Lock T} :
  r.is_unlocked → r = Lock.Unlocked :=by
  cases r
  . intros ; rfl
  . intros ; contradiction
  . intros ; contradiction

instance {T : Type} : Add (Lock T) :=⟨Lock.add⟩

theorem Lock.unlocked_add {T : Type} : ∀ a : Lock T, Unlocked + a = a :=by
  intro a ; cases a <;> rfl

theorem Lock.add_unlocked {T : Type} : ∀ a : Lock T, a + Unlocked = a :=by
  intro a ; cases a <;> rfl

theorem Lock.invalid_add {T : Type} : ∀ a : Lock T, Invalid + a = Invalid :=by
  intro a ; cases a <;> rfl

theorem Lock.add_comm {T : Type} : ∀ a b : Lock T, a + b = b + a :=by
  intro a b
  cases a <;> cases b <;> rfl

theorem Lock.add_assoc {T : Type} : ∀ a b c : Lock T,
  a + b + c = a + (b + c) :=by
  intro a b c
  cases a <;> cases b <;> cases c <;> rfl

instance {T : Type} : IsReservation (Lock T) where
  assoc :=Lock.add_assoc
  comm :=Lock.add_comm
  empty :=Lock.Unlocked
  empty_add :=Lock.unlocked_add

end Mt


import tactic.suggest
import analysis.special_functions.exp_log

open real

/- Turn off trace messages so they don't pollute the test build: -/
set_option trace.silence_library_search true

example {a b : ℝ} (h: a ≤ b) : exp a ≤ exp b := by library_search


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.ring_theory.witt_vector.is_poly
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-! ## The Verschiebung operator -/

namespace witt_vector

-- unfortunately, without this attribute, some of the code breaks for reasons I don't understand

/--
`verschiebung_fun x` shifts the coefficients of `x` up by one,
by inserting 0 as the 0th coefficient.
`x.coeff i` then becomes `(verchiebung_fun x).coeff (i + 1)`.

`verschiebung_fun` is the underlying function of the additive monoid hom `witt_vector.verschiebung`.
-/
def verschiebung_fun {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) : witt_vector p R :=
  mk p fun (n : ℕ) => ite (n = 0) 0 (coeff x (n - 1))

theorem verschiebung_fun_coeff {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) :
    coeff (verschiebung_fun x) n = ite (n = 0) 0 (coeff x (n - 1)) :=
  sorry

theorem verschiebung_fun_coeff_zero {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) :
    coeff (verschiebung_fun x) 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coeff (verschiebung_fun x) 0 = 0)) (verschiebung_fun_coeff x 0)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (ite (0 = 0) 0 (coeff x (0 - 1)) = 0)) (if_pos rfl)))
      (Eq.refl 0))

@[simp] theorem verschiebung_fun_coeff_succ {p : ℕ} {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : coeff (verschiebung_fun x) (Nat.succ n) = coeff x n :=
  rfl

theorem ghost_component_zero_verschiebung_fun {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (x : witt_vector p R) : coe_fn (ghost_component 0) (verschiebung_fun x) = 0 :=
  sorry

theorem ghost_component_verschiebung_fun {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (x : witt_vector p R) (n : ℕ) :
    coe_fn (ghost_component (n + 1)) (verschiebung_fun x) = ↑p * coe_fn (ghost_component n) x :=
  sorry

/--
The 0th Verschiebung polynomial is 0. For `n > 0`, the `n`th Verschiebung polynomial is the
variable `X (n-1)`.
-/
def verschiebung_poly (n : ℕ) : mv_polynomial ℕ ℤ := ite (n = 0) 0 (mv_polynomial.X (n - 1))

@[simp] theorem verschiebung_poly_zero : verschiebung_poly 0 = 0 := rfl

theorem aeval_verschiebung_poly' {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R)
    (n : ℕ) :
    coe_fn (mv_polynomial.aeval (coeff x)) (verschiebung_poly n) = coeff (verschiebung_fun x) n :=
  sorry

/--
`witt_vector.verschiebung` has polynomial structure given by `witt_vector.verschiebung_poly`.
-/
theorem verschiebung_fun_is_poly (p : ℕ) :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => verschiebung_fun :=
  sorry

/--
`verschiebung x` shifts the coefficients of `x` up by one, by inserting 0 as the 0th coefficient.
`x.coeff i` then becomes `(verchiebung x).coeff (i + 1)`.

This is a additive monoid hom with underlying function `verschiebung_fun`.
-/
def verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] :
    witt_vector p R →+ witt_vector p R :=
  add_monoid_hom.mk verschiebung_fun sorry sorry

/-- `witt_vector.verschiebung` is a polynomial function. -/
theorem verschiebung_is_poly {p : ℕ} [hp : fact (nat.prime p)] :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => ⇑verschiebung :=
  verschiebung_fun_is_poly p

/-- verschiebung is a natural transformation -/
@[simp] theorem map_verschiebung {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)]
    [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) :
    coe_fn (map f) (coe_fn verschiebung x) = coe_fn verschiebung (coe_fn (map f) x) :=
  sorry

theorem ghost_component_zero_verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (x : witt_vector p R) : coe_fn (ghost_component 0) (coe_fn verschiebung x) = 0 :=
  ghost_component_zero_verschiebung_fun x

theorem ghost_component_verschiebung {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R]
    (x : witt_vector p R) (n : ℕ) :
    coe_fn (ghost_component (n + 1)) (coe_fn verschiebung x) = ↑p * coe_fn (ghost_component n) x :=
  ghost_component_verschiebung_fun x n

@[simp] theorem verschiebung_coeff_zero {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (x : witt_vector p R) : coeff (coe_fn verschiebung x) 0 = 0 :=
  rfl

-- simp_nf complains if this is simp

theorem verschiebung_coeff_add_one {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : coeff (coe_fn verschiebung x) (n + 1) = coeff x n :=
  rfl

@[simp] theorem verschiebung_coeff_succ {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (x : witt_vector p R) (n : ℕ) :
    coeff (coe_fn verschiebung x) (Nat.succ n) = coeff x n :=
  rfl

theorem aeval_verschiebung_poly {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R]
    (x : witt_vector p R) (n : ℕ) :
    coe_fn (mv_polynomial.aeval (coeff x)) (verschiebung_poly n) =
        coeff (coe_fn verschiebung x) n :=
  aeval_verschiebung_poly' x n

@[simp] theorem bind₁_verschiebung_poly_witt_polynomial {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) :
    coe_fn (mv_polynomial.bind₁ verschiebung_poly) (witt_polynomial p ℤ n) =
        ite (n = 0) 0 (↑p * witt_polynomial p ℤ (n - 1)) :=
  sorry

end Mathlib


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebra.homology.additive
import category_theory.limits.shapes.biproducts

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables {ι : Type*} {V : Type*} [category V] [preadditive V]
variable {c : complex_shape ι}

namespace homological_complex

variables (X Y : homological_complex V c) [∀ i, has_binary_biproduct (X.X i) (Y.X i)]
variables {Z Z': homological_complex V c} (f₁ : X ⟶ Z) (f₂ : Y ⟶ Z) (g₁ : Z' ⟶ X) (g₂ : Z' ⟶ Y)

@[simps]
def biprod : homological_complex V c :=
{ X := λ i, X.X i ⊞ Y.X i,
  d := λ i j, biprod.desc (biprod.lift (X.d i j) 0) (biprod.lift 0 (Y.d i j)),
  shape' := λ i j hij, begin
    ext,
    { simp only [biprod.inl_desc, biprod.lift_fst, comp_zero, zero_comp, X.shape i j hij], },
    { simp only [biprod.inl_desc, biprod.lift_snd, comp_zero, zero_comp], },
    { simp only [biprod.inr_desc, biprod.lift_fst, comp_zero, zero_comp], },
    { simp only [Y.shape i j hij, biprod.inr_desc, biprod.lift_snd, comp_zero, zero_comp], },
  end, }

namespace biprod

variables {X Y}

@[simps] def inl : X ⟶ biprod X Y := { f := λ i, biprod.inl, }
@[simps] def inr : Y ⟶ biprod X Y := { f := λ i, biprod.inr, }
@[simps] def fst : biprod X Y ⟶ X := { f := λ i, biprod.fst, }
@[simps] def snd : biprod X Y ⟶ Y := { f := λ i, biprod.snd, }

@[simp, reassoc] def inl_fst : (inl : X ⟶ biprod X Y) ≫ fst = 𝟙 _ := by tidy
@[simp, reassoc] def inl_snd : (inl : X ⟶ biprod X Y) ≫ snd = 0   := by tidy
@[simp, reassoc] def inr_fst : (inr : Y ⟶ biprod X Y) ≫ fst = 0   := by tidy
@[simp, reassoc] def inr_snd : (inr : Y ⟶ biprod X Y) ≫ snd = 𝟙 _ := by tidy

@[simps] def desc : biprod X Y ⟶ Z := { f := λ i, biprod.desc (f₁.f i) (f₂.f i), }
@[simp, reassoc] lemma inl_desc : inl ≫ desc f₁ f₂ = f₁ := by tidy
@[simp, reassoc] lemma inr_desc : inr ≫ desc f₁ f₂ = f₂ := by tidy

@[simps] def lift : Z' ⟶ biprod X Y := { f := λ i, biprod.lift (g₁.f i) (g₂.f i), }
@[simp, reassoc] lemma lift_fst : lift g₁ g₂ ≫ fst = g₁ := by tidy
@[simp, reassoc] lemma lift_snd : lift g₁ g₂ ≫ snd = g₂ := by tidy

@[ext]
lemma hom_ext (f₁ f₂ : Z' ⟶ biprod X Y) (h₁ : f₁ ≫ biprod.fst = f₂ ≫ biprod.fst)
  (h₂ : f₁ ≫ biprod.snd = f₂ ≫ biprod.snd ) : f₁ = f₂ :=
by { ext i, exacts [congr_hom h₁ i, congr_hom h₂ i], }

@[ext]
lemma hom_ext' (f₁ f₂ : biprod X Y ⟶ Z) (h₁ : biprod.inl ≫ f₁= biprod.inl ≫ f₂)
  (h₂ : biprod.inr ≫ f₁ = biprod.inr ≫ f₂) : f₁ = f₂ :=
by { ext i, exacts [congr_hom h₁ i, congr_hom h₂ i], }

@[simp, reassoc]
lemma lift_desc : lift g₁ g₂ ≫ desc f₁ f₂ = g₁ ≫ f₁ + g₂ ≫ f₂ := by tidy

lemma total : fst ≫ inl + snd ≫ inr = 𝟙 (biprod X Y) :=
begin
  ext1; ext1; simp only [preadditive.comp_add, inl_fst_assoc, inl_snd_assoc,
    inr_fst_assoc, inr_snd_assoc, zero_comp, zero_add, add_zero, comp_id, biprod.total],
end

end biprod

end homological_complex


/- various properties about pfun and roption -/

import basic data.pfun

open set

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w} {n : ℕ}

namespace roption

def compatible (o₁ o₂ : roption α) : Prop := ∀{{x y}}, x ∈ o₁ → y ∈ o₂ → x = y

namespace compatible
  variables {o₁ o₂ o₃ : roption α}
  infix ` =. `:50 := roption.compatible
  protected lemma compatible_of_eq {x y : α} (h : x = y) :
    compatible (roption.some x) (roption.some y) :=
  omitted
  protected lemma symm (h : o₁ =. o₂) : o₂ =. o₁ := λx y hx hy, (h hy hx).symm
  -- note: it is not transitive, probably good to use different notation
end compatible

end roption

namespace pfun

protected def empty (α β : Type*) : α →. β := λx, roption.none
protected def id : α →. α := pfun.lift id
protected def comp (g : β →. γ) (f : α →. β) : α →. γ := λx, roption.bind (f x) g
infix ` ∘. `:90 := pfun.comp

def to_subtype (p : α → Prop) : α →. subtype p := λx, ⟨p x, λ h, ⟨x, h⟩⟩

def compatible (f g : α →. β) : Prop := ∀x, f x =. g x

namespace compatible
  variables {f g h : α →. β}
  infix ` ~. `:50 := pfun.compatible
  protected lemma symm (h : f ~. g) : g ~. f := λx, (h x).symm
  -- note: it is not transitive, probably good to use different notation
end compatible

def restrict' (f : α →. β) (p : set α) : α →. β :=
pfun.restrict f (inter_subset_right p (dom f))

end pfun

/- a partial equivalence -/
open pfun
structure pequiv (α : Type*) (β : Type*) :=
(to_fun    : α →. β)
(inv_fun   : β →. α)
(dom_inv_fun : ∀{{x}} (hx : x ∈ dom to_fun), to_fun.fn x hx ∈ dom inv_fun)
(dom_to_fun : ∀{{y}} (hy : y ∈ dom inv_fun), inv_fun.fn y hy ∈ dom to_fun)
(left_inv  : inv_fun ∘. to_fun ~. pfun.id)
(right_inv : to_fun ∘. inv_fun ~. pfun.id)

infixr ` ≃. `:25 := pequiv

namespace equiv
def to_pequiv (e : α ≃ β) : α ≃. β :=
⟨e.to_fun, e.inv_fun, λx hx, trivial, λy hy, trivial, omitted, omitted⟩

def rfl : α ≃ α := equiv.refl α
end equiv

namespace pequiv

instance : has_coe (α ≃. β) (α →. β) := ⟨pequiv.to_fun⟩
protected def rfl : α ≃. α := equiv.rfl.to_pequiv
protected def refl (α) : α ≃. α := pequiv.rfl
protected def symm (e : α ≃. β) : β ≃. α :=
⟨e.inv_fun, e.to_fun, e.dom_to_fun, e.dom_inv_fun, e.right_inv, e.left_inv⟩
protected def trans (e₁ : α ≃. β) (e₂ : β ≃. γ) : α ≃. γ :=
⟨e₂.to_fun ∘. e₁.to_fun, e₁.inv_fun ∘. e₂.inv_fun, omitted, omitted, omitted, omitted⟩

def restrict' (e : α ≃. β) (p : set α) : α ≃. β :=
⟨e.to_fun.restrict' p, e.inv_fun.restrict' (e.to_fun.image p), omitted, omitted, omitted, omitted⟩

def subtype_pequiv (p : α → Prop) : subtype p ≃. α :=
⟨pfun.lift subtype.val, to_subtype p, omitted, omitted, omitted, omitted⟩

end pequiv


import logic.funrel

open function

namespace function

--- Dependent analogue of `curry`
definition dcurry {α : Sort _} {β : α → Sort _} {γ : Π a (b : β a), Sort _} (f : Π a (b : β a), γ a b) : Π (x : sigma β), γ x.fst x.snd :=
  λ x, f x.fst x.snd

--- Dependent analogue of `uncurry`
definition duncurry {α : Sort _} {β : α → Sort _} {γ : Π (x : sigma β), Sort _} (f : Π (x : sigma β), γ x) : Π a (b : β a), γ ⟨a,b⟩ :=
  λ a b, f ⟨a,b⟩

--- Composition of retractions is again a retraction.
lemma left_inverse_comp {α β γ : Sort _} {gr : γ → β} {g : β → γ} {fr : β → α} {f : α → β} : left_inverse gr g → left_inverse fr f → left_inverse (fr∘ gr) (g∘f) :=
  begin
    intros hg hf a,
    dsimp [function.comp],
    rw [hg, hf]
  end

--- Composition of sections is again a section.
lemma right_inverse_comp {α β γ : Sort _} {gr : γ → β} {g : β → γ} {fr : β → α} {f : α → β} : right_inverse gr g → right_inverse fr f → right_inverse (fr∘ gr) (g∘f) :=
  λ hg hf, left_inverse_comp hf hg

definition has_inverse {α β : Sort _} (f : α → β) : Prop :=
  ∃ (g : β → α), left_inverse g f ∧ right_inverse g f

theorem has_inverse_of_twosided_invertible {α β : Sort _} {f : α → β} : has_left_inverse f → has_right_inverse f → has_inverse f :=
  begin
    intros hlinv hrinv,
    cases hlinv with gl hgl,
    cases hrinv with gr hgr,
    existsi gl,
    split,
    show ∀ a, gl (f a) = a, { exact hgl },
    show ∀ b, f (gl b) = b, {
      intros b,
      by calc
        f (gl b)
            = f (gl (f (gr b))) : by rw [hgr]
        ... = f (gr b) : by rw [hgl]
        ... = b : hgr b
    }
  end

namespace has_inverse

lemma has_left_inverse {α β : Sort _} {f : α → β} : has_inverse f → function.has_left_inverse f :=
  begin
    intros hinv; cases hinv with g hg,
    exact ⟨g,hg.left⟩
  end

lemma has_right_inverse {α β : Sort _} {f : α → β} : has_inverse f → function.has_right_inverse f :=
  begin
    intros hinv; cases hinv with g hg,
    exact ⟨g,hg.right⟩
  end

lemma bijective {α β : Sort _} {f : α → β} : has_inverse f → bijective f
| ⟨g, h⟩ := ⟨has_left_inverse.injective ⟨g, h.left⟩, has_right_inverse.surjective ⟨g, h.right⟩⟩

end has_inverse

--- Analogue of `congr` for functions with dependent domain.
definition dcongr {α : Sort _} {C : α → Sort _} {β : Sort _} : ∀ {a b : α} {f : C a → β} {g : C b → β} {x : C a} {y : C b}, a = b → f == g → x == y → f x = g y :=
  begin
    intros a b f g x y hab hfg hxy,
    cases hab,
    cases hfg,
    cases hxy,
    refl
  end

--- Analogue of `congr_arg` for functions with dependent codomain.
definition hcongr_arg {α : Sort _} {C : α → Sort _} (f : Π a, C a) : ∀ {x y : α}, x=y → f x == f y
| _ _ rfl := heq.rfl

end function