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


/-
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


/-
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


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Sean Leather

Functions on lists of sigma types.
-/
import data.list.perm

universes u v

namespace list
variables {α : Type u} {β : α → Type v}

/- keys -/

/-- List of keys from a list of key-value pairs -/
def keys : list (sigma β) → list α :=
map sigma.fst

@[simp] theorem keys_nil : @keys α β [] = [] :=
rfl

@[simp] theorem keys_cons {s} {l : list (sigma β)} : (s :: l).keys = s.1 :: l.keys :=
rfl

theorem mem_keys_of_mem {s : sigma β} {l : list (sigma β)} : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {a} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a} {l : list (sigma β)} : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

theorem not_mem_keys {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ b : β a, sigma.mk a b ∉ l :=
(not_iff_not_of_iff mem_keys).trans not_exists

theorem not_eq_key {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ s : sigma β, s ∈ l → a ≠ s.1 :=
iff.intro
  (λ h₁ s h₂ e, absurd (mem_keys_of_mem h₂) (by rwa e at h₁))
  (λ f h₁, let ⟨b, h₂⟩ := exists_of_mem_keys h₁ in f _ h₂ rfl)

/- nodupkeys -/

def nodupkeys (l : list (sigma β)) : Prop :=
l.keys.nodup

theorem nodupkeys_iff_pairwise {l} : nodupkeys l ↔
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l := pairwise_map _

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] := pairwise.nil

@[simp] theorem nodupkeys_cons {s : sigma β} {l : list (sigma β)} :
  nodupkeys (s::l) ↔ s.1 ∉ l.keys ∧ nodupkeys l :=
by simp [keys, nodupkeys]

theorem nodupkeys.eq_of_fst_eq {l : list (sigma β)}
  (nd : nodupkeys l) {s s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) :
  s.1 = s'.1 → s = s' :=
@forall_of_forall_of_pairwise _
  (λ s s' : sigma β, s.1 = s'.1 → s = s')
  (λ s s' H h, (H h.symm).symm) _ (λ x h _, rfl)
  ((nodupkeys_iff_pairwise.1 nd).imp (λ s s' h h', (h h').elim)) _ h _ h'

theorem nodupkeys.eq_of_mk_mem {a : α} {b b' : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' :=
by cases nd.eq_of_fst_eq h h' rfl; refl

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] := nodup_singleton _

theorem nodupkeys_of_sublist {l₁ l₂ : list (sigma β)} (h : l₁ <+ l₂) : nodupkeys l₂ → nodupkeys l₁ :=
nodup_of_sublist (map_sublist_map _ h)

theorem nodup_of_nodupkeys {l : list (sigma β)} : nodupkeys l → nodup l :=
nodup_of_nodup_map _

theorem perm_nodupkeys {l₁ l₂ : list (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
perm_nodup $ perm_map _ h

theorem nodupkeys_join {L : list (list (sigma β))} :
  nodupkeys (join L) ↔ (∀ l ∈ L, nodupkeys l) ∧ pairwise disjoint (L.map keys) :=
begin
  rw [nodupkeys_iff_pairwise, pairwise_join, pairwise_map],
  refine and_congr (ball_congr $ λ l h, by simp [nodupkeys_iff_pairwise]) _,
  apply iff_of_eq, congr', ext l₁ l₂,
  simp [keys, disjoint_iff_ne]
end

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

variables [decidable_eq α]

/- lookup -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup (a : α) : list (sigma β) → option (β a)
| []             := none
| (⟨a', b⟩ :: l) := if h : a' = a then some (eq.rec_on h b) else lookup l

@[simp] theorem lookup_nil (a : α) : lookup a [] = @none (β a) := rfl

@[simp] theorem lookup_cons_eq (l) (a : α) (b : β a) : lookup a (⟨a, b⟩::l) = some b :=
dif_pos rfl

@[simp] theorem lookup_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup a (s::l) = lookup a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_is_some {a : α} : ∀ {l : list (sigma β)},
  (lookup a l).is_some ↔ a ∈ l.keys
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_is_some] },
end

theorem lookup_eq_none {a : α} {l : list (sigma β)} :
  lookup a l = none ↔ a ∉ l.keys :=
begin
  have := not_congr (@lookup_is_some _ _ _ a l),
  simp at this, refine iff.trans _ this,
  cases lookup a l; exact dec_trivial
end

theorem of_mem_lookup
  {a : α} {b : β a} : ∀ {l : list (sigma β)}, b ∈ lookup a l → sigma.mk a b ∈ l
| (⟨a', b'⟩ :: l) H := begin
  by_cases h : a = a',
  { subst a', simp at H, simp [H] },
  { simp [h] at H, exact or.inr (of_mem_lookup H) }
end

theorem mem_lookup {a} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys)
  (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
begin
  cases option.is_some_iff_exists.mp (lookup_is_some.mpr (mem_keys_of_mem h)) with b' h',
  cases nd.eq_of_mk_mem h (of_mem_lookup h'),
  exact h'
end

theorem map_lookup_eq_find (a : α) : ∀ l : list (sigma β),
  (lookup a l).map (sigma.mk a) = find (λ s, a = s.1) l
| [] := rfl
| (⟨a', b'⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, map_lookup_eq_find] }
end

theorem mem_lookup_iff {a : α} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys) :
  b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
⟨of_mem_lookup, mem_lookup nd⟩

theorem perm_lookup (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ :=
by ext b; simp [mem_lookup_iff, nd₁, nd₂]; exact mem_of_perm p

/- lookup_all -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all (a : α) : list (sigma β) → list (β a)
| []             := []
| (⟨a', b⟩ :: l) := if h : a' = a then eq.rec_on h b :: lookup_all l else lookup_all l

@[simp]

@[simp] theorem lookup_all_cons_eq (l) (a : α) (b : β a) :
  lookup_all a (⟨a, b⟩::l) = b :: lookup_all a l :=
dif_pos rfl

@[simp] theorem lookup_all_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup_all a (s::l) = lookup_all a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_all_eq_nil {a : α} : ∀ {l : list (sigma β)},
  lookup_all a l = [] ↔ ∀ b : β a, sigma.mk a b ∉ l
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp, exact λ H, H b (or.inl rfl) },
  { simp [h, lookup_all_eq_nil] },
end

theorem head_lookup_all (a : α) : ∀ l : list (sigma β),
  head' (lookup_all a l) = lookup a l
| []             := by simp
| (⟨a', b⟩ :: l) := by by_cases h : a = a'; [{subst h, simp}, simp *]

theorem mem_lookup_all {a : α} {b : β a} :
  ∀ {l : list (sigma β)}, b ∈ lookup_all a l ↔ sigma.mk a b ∈ l
| []              := by simp
| (⟨a', b'⟩ :: l) := by by_cases h : a = a'; [{subst h, simp *}, simp *]

theorem lookup_all_sublist (a : α) :
  ∀ l : list (sigma β), (lookup_all a l).map (sigma.mk a) <+ l
| []              := by simp
| (⟨a', b'⟩ :: l) := begin
    by_cases h : a = a',
    { subst h, simp, exact (lookup_all_sublist l).cons2 _ _ _ },
    { simp [h], exact (lookup_all_sublist l).cons _ _ _ }
  end

theorem lookup_all_length_le_one (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  length (lookup_all a l) ≤ 1 :=
by have := nodup_of_sublist (map_sublist_map _ $ lookup_all_sublist a l) h;
   rw map_map at this; rwa [← nodup_repeat, ← map_const _ a]

theorem lookup_all_eq_lookup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  lookup_all a l = (lookup a l).to_list :=
begin
  rw ← head_lookup_all,
  have := lookup_all_length_le_one a h, revert this,
  rcases lookup_all a l with _|⟨b, _|⟨c, l⟩⟩; intro; try {refl},
  exact absurd this dec_trivial
end

theorem lookup_all_nodup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  (lookup_all a l).nodup :=
by rw lookup_all_eq_lookup a h; apply option.to_list_nodup

theorem perm_lookup_all (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ :=
by simp [lookup_all_eq_lookup, nd₁, nd₂, perm_lookup a nd₁ nd₂ p]

/- kreplace -/

def kreplace (a : α) (b : β a) : list (sigma β) → list (sigma β) :=
lookmap $ λ s, if h : a = s.1 then some ⟨a, b⟩ else none

theorem kreplace_of_forall_not (a : α) (b : β a) {l : list (sigma β)}
  (H : ∀ b : β a, sigma.mk a b ∉ l) : kreplace a b l = l :=
lookmap_of_forall_not _ $ begin
  rintro ⟨a', b'⟩ h, dsimp, split_ifs,
  { subst a', exact H _ h }, {refl}
end

theorem kreplace_self {a : α} {b : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
begin
  refine (lookmap_congr _).trans
    (lookmap_id' (option.guard (λ s, a = s.1)) _ _),
  { rintro ⟨a', b'⟩ h', dsimp [option.guard], split_ifs,
    { subst a', exact ⟨rfl, heq_of_eq $ nd.eq_of_mk_mem h h'⟩ },
    { refl } },
  { rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, dsimp [option.guard], split_ifs,
    { subst a₁, rintro ⟨⟩, simp }, { rintro ⟨⟩ } },
end

theorem keys_kreplace (a : α) (b : β a) : ∀ l : list (sigma β),
  (kreplace a b l).keys = l.keys :=
lookmap_map_eq _ _ $ by rintro ⟨a₁, b₂⟩ ⟨a₂, b₂⟩;
  dsimp; split_ifs; simp [h] {contextual := tt}

theorem kreplace_nodupkeys (a : α) (b : β a) {l : list (sigma β)} :
  (kreplace a b l).nodupkeys ↔ l.nodupkeys :=
by simp [nodupkeys, keys_kreplace]

theorem perm_kreplace {a : α} {b : β a} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ →
  kreplace a b l₁ ~ kreplace a b l₂ :=
perm_lookmap _ $ begin
  refine (nodupkeys_iff_pairwise.1 nd).imp _,
  intros x y h z h₁ w h₂,
  split_ifs at h₁ h₂; cases h₁; cases h₂,
  exact (h (h_2.symm.trans h_1)).elim
end

/- kerase -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : list (sigma β) → list (sigma β) :=
erasep $ λ s, a = s.1

@[simp] theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
rfl

@[simp] theorem kerase_cons_eq {a} {s : sigma β} {l : list (sigma β)} (h : a = s.1) :
  kerase a (s :: l) = l :=
by simp [kerase, h]

@[simp] theorem kerase_cons_ne {a} {s : sigma β} {l : list (sigma β)} (h : a ≠ s.1) :
  kerase a (s :: l) = s :: kerase a l :=
by simp [kerase, h]

@[simp] theorem kerase_of_not_mem_keys {a} {l : list (sigma β)} (h : a ∉ l.keys) :
  kerase a l = l :=
by induction l with _ _ ih;
   [refl, { simp [not_or_distrib] at h, simp [h.1, ih h.2] }]

theorem kerase_sublist (a : α) (l : list (sigma β)) : kerase a l <+ l :=
erasep_sublist _

theorem kerase_keys_subset (a) (l : list (sigma β)) :
  (kerase a l).keys ⊆ l.keys :=
subset_of_sublist (map_sublist_map _ (kerase_sublist a l))

theorem mem_keys_of_mem_keys_kerase {a₁ a₂} {l : list (sigma β)} :
  a₁ ∈ (kerase a₂ l).keys → a₁ ∈ l.keys :=
@kerase_keys_subset _ _ _ _ _ _

theorem exists_of_kerase {a : α} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    kerase a l = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih {
    by_cases e : a = hd.1,
    { subst e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h e },
      case or.inr : h {
        rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem e h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

@[simp] theorem mem_keys_kerase_of_ne {a₁ a₂} {l : list (sigma β)} (h : a₁ ≠ a₂) :
  a₁ ∈ (kerase a₂ l).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, kerase a₂ l, exists_of_kerase q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [keys, h] using p
    end
  else
    by simp [q, p]

theorem keys_kerase {a} {l : list (sigma β)} : (kerase a l).keys = l.keys.erase a :=
by rw [keys, kerase, ←erasep_map sigma.fst l, erase_eq_erasep]

theorem kerase_nodupkeys (a : α) {l : list (sigma β)} : nodupkeys l → (kerase a l).nodupkeys :=
nodupkeys_of_sublist $ kerase_sublist _ _

theorem perm_kerase {a : α} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
perm_erasep _ $ (nodupkeys_iff_pairwise.1 nd).imp $
by rintro x y h rfl; exact h

@[simp] theorem not_mem_keys_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  a ∉ (kerase a l).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h : a = hd.1,
    { subst h, simp [nd.1] },
    { simp [h, ih nd.2] } }
end

@[simp] theorem lookup_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  lookup a (kerase a l) = none :=
lookup_eq_none.mpr (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {a a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kerase a' l) = lookup a l :=
begin
  induction l,
  case list.nil { refl },
  case list.cons : hd tl ih {
    cases hd with ah bh,
    by_cases h₁ : a = ah; by_cases h₂ : a' = ah,
    { substs h₁ h₂, cases ne.irrefl h },
    { subst h₁, simp [h₂] },
    { subst h₂, simp [h] },
    { simp [h₁, h₂, ih] }
  }
end

theorem kerase_append_left {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂
| []        _  h  := by cases h
| (s :: l₁) l₂ h₁ :=
  if h₂ : a = s.1 then
    by simp [h₂]
  else
    by simp at h₁;
       cases h₁;
       [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂
| []        _  h := rfl
| (_ :: l₁) l₂ h := by simp [not_or_distrib] at h;
                       simp [h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂) (l : list (sigma β)) :
  kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
if h : a₁ = a₂ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, kerase a₁ l, exists_of_kerase ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

/- kinsert -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert (a : α) (b : β a) (l : list (sigma β)) : list (sigma β) :=
⟨a, b⟩ :: kerase a l

@[simp] theorem kinsert_def {a} {b : β a} {l : list (sigma β)} :
  kinsert a b l = ⟨a, b⟩ :: kerase a l := rfl

@[simp] theorem mem_keys_kinsert {a a'} {b' : β a'} {l : list (sigma β)} :
  a ∈ (kinsert a' b' l).keys ↔ a = a' ∨ a ∈ l.keys :=
by by_cases h : a = a'; simp [h]

theorem kinsert_nodupkeys (a) (b : β a) {l : list (sigma β)} (nd : l.nodupkeys) :
  (kinsert a b l).nodupkeys :=
nodupkeys_cons.mpr ⟨not_mem_keys_kerase a nd, kerase_nodupkeys a nd⟩

theorem perm_kinsert {a} {b : β a} {l₁ l₂ : list (sigma β)} (nd₁ : l₁.nodupkeys)
  (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
perm.skip ⟨a, b⟩ $ perm_kerase nd₁ p

@[simp] theorem lookup_kinsert {a} {b : β a} (l : list (sigma β)) :
  lookup a (kinsert a b l) = some b :=
by simp only [kinsert, lookup_cons_eq]

@[simp] theorem lookup_kinsert_ne {a a'} {b' : β a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kinsert a' b' l) = lookup a l :=
by simp [h, lookup_cons_ne _ ⟨a', b'⟩ h]

/- kextract -/

def kextract (a : α) : list (sigma β) → option (β a) × list (sigma β)
| []     := (none, [])
| (s::l) := if h : s.1 = a then (some (eq.rec_on h s.2), l) else
  let (b', l') := kextract l in (b', s :: l')

@[simp] theorem kextract_eq_lookup_kerase (a : α) :
  ∀ l : list (sigma β), kextract a l = (lookup a l, kerase a l)
| []     := rfl
| (⟨a', b⟩::l) := begin
    simp [kextract], dsimp, split_ifs,
    { subst a', simp [kerase] },
    { simp [kextract, ne.symm h, kextract_eq_lookup_kerase l, kerase] }
  end

/- kunion -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion : list (sigma β) → list (sigma β) → list (sigma β)
| []        l₂ := l₂
| (s :: l₁) l₂ := s :: kunion l₁ (kerase s.1 l₂)

@[simp] theorem nil_kunion {l : list (sigma β)} : kunion [] l = l :=
rfl

@[simp] theorem kunion_nil : ∀ {l : list (sigma β)}, kunion l [] = l
| []       := rfl
| (_ :: l) := by rw [kunion, kerase_nil, kunion_nil]

@[simp] theorem kunion_cons {s} {l₁ l₂ : list (sigma β)} :
  kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase s.1 l₂) :=
rfl

@[simp] theorem mem_keys_kunion {a} {l₁ l₂ : list (sigma β)} :
  a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s l₁ ih { by_cases h : a = s.1; [simp [h], simp [h, ih]] }
end

@[simp] theorem kunion_kerase {a} : ∀ {l₁ l₂ : list (sigma β)},
  kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂)
| []       _ := rfl
| (s :: _) l := by by_cases h : a = s.1;
                   simp [h, kerase_comm a s.1 l, kunion_kerase]

theorem kunion_nodupkeys {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) : (kunion l₁ l₂).nodupkeys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp only [nil_kunion, nd₂] },
  case list.cons : s l₁ ih {
    simp at nd₁,
    simp [not_or_distrib, nd₁.1, nd₂, ih nd₁.2 (kerase_nodupkeys s.1 nd₂)] }
end

theorem perm_kunion_left {l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (l) :
  kunion l₁ l ~ kunion l₂ l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    simp [ih (kerase hd.1 l), perm.skip] },
  case list.perm.swap : s₁ s₂ l {
    simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ {
    exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm_kunion_right : ∀ l {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
| []       _  _  _   p := p
| (s :: l) l₁ l₂ nd₁ p :=
  by simp [perm.skip s
    (perm_kunion_right l (kerase_nodupkeys s.1 nd₁) (perm_kerase nd₁ p))]

theorem perm_kunion {l₁ l₂ l₃ l₄ : list (sigma β)} (nd₃ : l₃.nodupkeys)
  (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
perm.trans (perm_kunion_left p₁₂ l₃) (perm_kunion_right l₂ nd₃ p₃₄)

@[simp] theorem lookup_kunion_left {a} {l₁ l₂ : list (sigma β)} (h : a ∈ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₁ :=
begin
  induction l₁ with s _ ih generalizing l₂; simp at h; cases h; cases s with a',
  { subst h, simp },
  { rw kunion_cons,
    by_cases h' : a = a',
    { subst h', simp },
    { simp [h', ih h] } }
end

@[simp] theorem lookup_kunion_right {a} {l₁ l₂ : list (sigma β)} (h : a ∉ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : _ _ ih { simp [not_or_distrib] at h, simp [h.1, ih h.2] }
end

@[simp] theorem mem_lookup_kunion {a} {b : β a} {l₁ l₂ : list (sigma β)} :
  b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s _ ih {
    cases s with a',
    by_cases h₁ : a = a',
    { subst h₁, simp },
    { let h₂ := @ih (kerase a' l₂), simp [h₁] at h₂, simp [h₁, h₂] } }
end

theorem mem_lookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : list (sigma β)}
  (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
  b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
match mem_lookup_kunion.mp h₁ with
| or.inl h := mem_lookup_kunion.mpr (or.inl (mem_lookup_kunion.mpr (or.inl h)))
| or.inr h := mem_lookup_kunion.mpr $
  or.inr ⟨mt mem_keys_kunion.mp (not_or_distrib.mpr ⟨h.1, h₂⟩), h.2⟩
end

end list