import tactic

open classical
local attribute [instance] prop_decidable

universe u

inductive Formula : Type u
| absurd  : Formula
| var     : nat → Formula
| impl    : Formula → Formula → Formula
| conj    : Formula → Formula → Formula
| disj    : Formula → Formula → Formula
| nec     : Formula → Formula

axiom formulas_countable : encodable Formula
local attribute [instance] formulas_countable

notation  `⊥`     : 85 := Formula.absurd
prefix    `#`     : 65 := Formula.var
infixr    `→'`    : 55 := Formula.impl
notation  `¬'` x  : 60 := x →' ⊥
infixl    `∧'`    : 50 := Formula.conj
infixl    `∨'`    : 50 := Formula.disj
prefix    `□`     : 60 := Formula.nec
notation  `◇` x   : 60 := ¬' (□ (¬'x))

inductive proof (Ax: set Formula) : set Formula → set Formula
| ax  : ∀ A   : Formula, ∀ Γ : set Formula, A ∈ Ax → proof Γ A
| ctx : ∀ A   : Formula, ∀ Γ : set Formula, A ∈ Γ → proof Γ A
| mp  : ∀ A B : Formula, ∀ Γ : set Formula, proof Γ A → proof Γ (A →' B) → proof Γ B
| rn  : ∀ A   : Formula, ∀ Γ : set Formula, proof ∅ A → proof Γ □A

notation Γ `⊢[` A `]` f : 25 := proof A Γ f

structure Model : Type (u + 1) :=
mk :: (W : Type u) (r : W → W → Prop) (v : W → nat → Prop)

def loc_true (M : Model.{u}) : M.W → Formula → Prop
| w ⊥           := false
| w (#v)        := M.v w v
| w (f₁ →' f₂)  := loc_true w f₁ → loc_true w f₂
| w (f₁ ∧' f₂)  := loc_true w f₁ ∧ loc_true w f₂
| w (f₁ ∨' f₂)  := loc_true w f₁ ∨ loc_true w f₂
| w (□f)        := ∀ w' : M.W, M.r w w' → loc_true w' f

def loc_true_ctx (M : Model.{u}) (Γ : set Formula.{u}) (w : M.W) : Prop
  := ∀ f : Formula, f ∈ Γ → loc_true M w f

def models (M : set Model.{u}) (Γ : set Formula.{u}) (f : Formula.{u}) : Prop
  := ∀ m : Model, m ∈ M →
     ∀ w : m.W, loc_true_ctx m Γ w → loc_true m w f

notation Γ `⊨[` M `]` f : 25 := models M Γ f

def sound (A : set Formula.{u}) (M : set Model.{u}) : Prop
  :=  ∀ Γ : set Formula.{u}, ∀ f : Formula.{u},
      (Γ ⊢[A] f) → (Γ ⊨[M] f)

def complete (A : set Formula.{u}) (M : set Model.{u}) : Prop
  :=  ∀ Γ : set Formula.{u}, ∀ f : Formula.{u},
      (Γ ⊨[M] f) → (Γ ⊢[A] f)

inductive AxiomPC : set Formula
| implIntro   : ∀ A B   : Formula, AxiomPC $ A →' B →' A
| implChain   : ∀ A B C : Formula, AxiomPC $ (A →' B →' C) →' (A →' B) →' A →' C
| andIntro    : ∀ A B   : Formula, AxiomPC $ A →' B →' (A ∧' B)
| andElimL    : ∀ A B   : Formula, AxiomPC $ (A ∧' B) →' A
| andElimR    : ∀ A B   : Formula, AxiomPC $ (A ∧' B) →' B
| orIntroL    : ∀ A B   : Formula, AxiomPC $ A →' (A ∨' B)
| orIntroR    : ∀ A B   : Formula, AxiomPC $ B →' (A ∨' B)
| orElim      : ∀ A B C : Formula, AxiomPC $ (A →' C) →' (B →' C) →' (A ∨' B) →' C
| absurdElim  : ∀ A     : Formula, AxiomPC $ ⊥ →' A
| lem         : ∀ A     : Formula, AxiomPC $ A ∨' ¬' A

notation Γ `⊢ₚ` f : 25 := Γ ⊢[AxiomPC] f

inductive AxiomS5 : set Formula
| prop  : ∀ A   : Formula, A ∈ AxiomPC → AxiomS5 A
| axK   : ∀ A B : Formula, AxiomS5 $ □(A →' B) →' □A →' □B
| ref   : ∀ A   : Formula, AxiomS5 $ □A →' A
| sym   : ∀ A   : Formula, AxiomS5 $ A →' □◇A
| tran  : ∀ A   : Formula, AxiomS5 $ □A →' □□A

notation Γ `⊢₅` f : 25 := Γ ⊢[AxiomS5] f

def ModelS5 : set Model.{u} := λ M, equivalence M.r

notation Γ `⊨₅` f : 25 := Γ ⊨[ModelS5] f

theorem S5_sound : sound AxiomS5 ModelS5 :=
begin
  intros  context
          formula
          prf
          model
          rel_equiv
          world
          loc_ctx_truth,

  induction prf with
    _ _ in_ax generalizing world,

  -- automatically solve prop, axK, mp cases
  cases in_ax with _ prf',
  cases prf',
  repeat { finish [loc_true] },

  case ref : {
    intros boxA,
    exact boxA world (rel_equiv.1 world),
  },

  case sym : {
    intros A w' rw' h,
    exact h world (rel_equiv.2.1 rw') A,
  },

  case tran : {
    intros boxA w' rw' w'' rw'',
    exact boxA w'' (rel_equiv.2.2 rw' rw''),
  },

  case ctx : _ _ in_ctx {
    exact loc_ctx_truth _ in_ctx,
  },

  case rn : _ _ _ ih {
    intros w' _,
    apply ih,
    intros _ f,
    cases f,
  },
end

lemma proof_mp_ctx (A : set Formula) (Γ : set Formula) (f₁ f₂ : Formula)
  : f₁ ∈ Γ → (f₁ →' f₂) ∈ Γ → (Γ ⊢[A] f₂) :=
begin
  intros h₁ h₂,
  have h₃ : (Γ ⊢[A] f₁) := proof.ctx _ _ h₁,
  have h₄ : (Γ ⊢[A] (f₁ →' f₂)) := proof.ctx _ _ h₂,
  have h₅ := proof.mp _ _ _ h₃ h₄,
  assumption,
end

lemma proof_subset (A : set Formula) (Γ Γ' : set Formula) (f : Formula)
  : Γ ⊆ Γ' → (Γ ⊢[A] f) → (Γ' ⊢[A] f) :=
begin
  intros h₁ h₂,
  induction h₂,

  case ax : {
    apply proof.ax,
    assumption,
  },

  case ctx : {
    apply proof.ctx,
    tauto,
  },

  case mp : _ _ _ _ _ ih₁ ih₂ {
    have h₂ := ih₁ h₁,
    have h₃ := ih₂ h₁,
    exact proof.mp _ _ _ h₂ h₃,
  },

  case rn : {
    apply proof.rn,
    assumption,
  },
end

lemma lift_subset (A₁ A₂ : set Formula) (as : A₁ ⊆ A₂) (Γ : set Formula)
  (f : Formula) : (Γ ⊢[A₁] f) → (Γ ⊢[A₂] f) :=
begin
  intro prf,
  induction prf,

  case proof.ax {
    apply proof.ax,
    apply as,
    assumption,
  },

  case proof.ctx {
    apply proof.ctx,
    assumption,
  },

  case proof.mp {
    apply proof.mp,
    assumption,
    assumption,
  },

  case proof.rn {
    apply proof.rn,
    assumption,
  },
end

lemma lift_S5 (Γ : set Formula) (f : Formula)
  : (Γ ⊢ₚ f) → (Γ ⊢₅ f) := lift_subset AxiomPC AxiomS5 (AxiomS5.prop) Γ f

lemma append_PC' (A : set Formula) (pc : AxiomPC ⊆ A) (Γ : set Formula)
  (f : Formula) (g : Formula) (h : Γ ⊢[A] g) : Γ ⊢[A] (f →' g) :=
begin
  have h₁ : (Γ ⊢[A] (g →' f →' g)),
  apply proof.ax,
  apply pc,
  apply AxiomPC.implIntro,

  exact proof.mp _ _ _ h h₁,
end

lemma append_PC (Γ : set Formula) (f : Formula) (g : Formula) (h : Γ ⊢ₚ g)
  : Γ ⊢ₚ (f →' g) := append_PC' AxiomPC (by refl) _ _ _ h

lemma append_S5 (Γ : set Formula) (f : Formula) (g : Formula) (h : Γ ⊢₅ g)
  : Γ ⊢₅ (f →' g) := append_PC' AxiomS5 (AxiomS5.prop) _ _ _ h

lemma refl_PC (Γ : set Formula) (f : Formula) : Γ ⊢ₚ (f →' f) :=
begin
  have h₁ : (Γ ⊢ₚ ((f →' (f →' f) →' f) →' (f →' f →' f) →' (f →' f))),
  apply proof.ax,
  apply AxiomPC.implChain,

  have h₂ : (Γ ⊢ₚ (f →' (f →' f) →' f)),
  apply proof.ax,
  apply AxiomPC.implIntro,

  have h₃ : (Γ ⊢ₚ (f →' f →' f)),
  apply proof.ax,
  apply AxiomPC.implIntro,

  have h₄ := proof.mp _ _ _ h₂ h₁,
  have h₅ := proof.mp _ _ _ h₃ h₄,
  exact h₅,
end

lemma refl_S5 (Γ : set Formula) (f : Formula) : Γ ⊢₅ (f →' f)
  := lift_S5 _ _ $ refl_PC _ _

theorem deduction_PC' (A : set Formula) (pc : AxiomPC ⊆ A)
  (Γ : set Formula) (f : Formula) (g : Formula)
  : (insert f Γ ⊢[A] g) ↔ (Γ ⊢[A] (f →' g)) :=
begin
  split,

  generalize eq : insert f Γ = Γ',

  intro prf,
  induction prf,

  case proof.ax : A' _ ax {
    apply append_PC',
    assumption,

    apply proof.ax,
    assumption,
  },

  case proof.ctx : A' _ ctx {
    rw [←eq] at ctx,
    cases ctx,

    case or.inl : {
      rw ctx,
      apply lift_subset AxiomPC A pc,
      apply refl_PC,
    },

    case or.inr : {
      apply append_PC',
      assumption,

      apply proof.ctx,
      assumption,
    },
  },

  case proof.mp : A' B' _ _ _ ih₁ ih₂ {
    have h₁ : (Γ ⊢[A] ((f →' A' →' B') →' (f →' A') →' f →' B')),
    apply proof.ax,
    apply pc,
    apply AxiomPC.implChain,

    have h₂ := proof.mp _ _ _ (ih₂ eq) h₁,
    have h₃ := proof.mp _ _ _ (ih₁ eq) h₂,
    assumption,
  },

  case proof.rn : A _ h₁ _ {
    apply append_PC',
    assumption,

    apply proof.rn,
    assumption,
  },

  intro h₁,
  have h₂ : (insert f Γ ⊢[A] f) := proof.ctx _ _ (by finish),
  have h₃ : (insert f Γ ⊢[A] (f →' g)) :=
    proof_subset _ _ _ _ (by finish) h₁,
  have h₄ := proof.mp _ _ _ h₂ h₃,
  assumption,
end

theorem deduction_PC (Γ : set Formula) (f: Formula) (g: Formula)
  : (insert f Γ ⊢ₚ g) ↔ (Γ ⊢ₚ (f →' g))
  := deduction_PC' AxiomPC (by refl) _ _ _

theorem deduction_S5 (Γ : set Formula) (f: Formula) (g: Formula)
  : (insert f Γ ⊢₅ g) ↔ (Γ ⊢₅ (f →' g))
  := deduction_PC' AxiomS5 AxiomS5.prop _ _ _

lemma dneg_intro_PC (Γ : set Formula) (f : Formula)
  : (Γ ⊢ₚ (f →' ¬' ¬'f)) :=
begin
  rw [←deduction_PC],
  rw [←deduction_PC],
  set Γ' := insert (f→'⊥) (insert f Γ),

  have h₁ : (Γ' ⊢ₚ f) := proof.ctx _ _ (by finish),
  have h₂ : (Γ' ⊢ₚ (f →' ⊥)) := proof.ctx _ _ (by finish),
  exact proof.mp _ _ _ h₁ h₂,
end

lemma dneg_elim_PC (Γ : set Formula) (f : Formula)
  : (Γ ⊢ₚ (¬' ¬' f →' f)) :=
begin
  rw [←deduction_PC],
  set Γ' := insert ((f→'⊥)→'⊥) Γ,

  have h₁ : (Γ' ⊢ₚ (f ∨' ¬' f)),
  apply proof.ax,
  apply AxiomPC.lem,

  have h₂ : (Γ' ⊢ₚ (⊥ →' f)),
  apply proof.ax,
  apply AxiomPC.absurdElim,

  have h₃ : (Γ' ⊢ₚ (¬'f →' ⊥ →' f) →' (¬' ¬' f) →' (¬' f) →' f),
  apply proof.ax,
  apply AxiomPC.implChain,

  have h₄ : (Γ' ⊢ₚ (¬'f →' ⊥ →' f)) := append_PC _ _ _ h₂,

  have h₅ : (Γ' ⊢ₚ (¬' ¬' f) →' (¬'f) →' f) := proof.mp _ _ _ h₄ h₃,

  have h₆ : (Γ' ⊢ₚ (¬' ¬' f)) := proof.ctx _ _ (by finish),

  have h₇ : (Γ' ⊢ₚ (¬' f →' f)) := proof.mp _ _ _ h₆ h₅,

  have h₈ : (Γ' ⊢ₚ (f →' f) →' (¬' f →' f) →' (f ∨' ¬' f) →' f),
  apply proof.ax,
  apply AxiomPC.orElim,

  have h₉ : (Γ' ⊢ₚ (f →' f)) := refl_PC _ _,

  have h₁₀ : (Γ' ⊢ₚ (¬' f →' f) →' (f ∨' ¬' f) →' f) := proof.mp _ _ _ h₉ h₈,

  have h₁₁ : (Γ' ⊢ₚ ((f ∨' ¬' f) →' f)) := proof.mp _ _ _ h₇ h₁₀,

  have h₁₂ : (Γ' ⊢ₚ f) := proof.mp _ _ _ h₁ h₁₁,

  assumption,
end

lemma contrapose_PC' (Γ : set Formula) (f g : Formula)
  : Γ ⊢ₚ ((f →' g) →' (¬'g →' ¬' f)) :=
begin
  rw [←deduction_PC],
  rw [←deduction_PC],
  rw [←deduction_PC],
  set Γ' := insert f (insert (g→'⊥) (insert (f→' g) Γ)),

  have h₁ : (Γ' ⊢ₚ f) := proof.ctx _ _ (by finish),
  have h₂ : (Γ' ⊢ₚ (f →' g)) := proof.ctx _ _ (by finish),
  have h₃ : (Γ' ⊢ₚ g) := proof.mp _ _ _ h₁ h₂,
  have h₄ : (Γ' ⊢ₚ (g →' ⊥)) := proof.ctx _ _ (by finish),
  have h₅ : (Γ' ⊢ₚ ⊥) := proof.mp _ _ _ h₃ h₄,

  assumption,
end

lemma contrapose_PC (Γ : set Formula) (f g : Formula)
  : (Γ ⊢ₚ (f →' g)) → (Γ ⊢ₚ (¬' g →' ¬' f)) :=
begin
  intro h₁,
  have h₂ := contrapose_PC' Γ f g,
  exact proof.mp _ _ _ h₁ h₂,
end

lemma contrapose_S5 (Γ : set Formula) (f g : Formula)
  : (Γ ⊢₅ (f →' g)) → (Γ ⊢₅ (¬' g →' ¬' f)) :=
begin
  intro h₁,
  have h₂ := lift_S5 _ _ (contrapose_PC' Γ f g),
  exact proof.mp _ _ _ h₁ h₂,
end

lemma nec_k (f g : Formula) : (∅ ⊢₅ (f →' g)) → (∅ ⊢₅ (□f →' □g)) :=
begin
  intro h₁,

  have h₂ : (∅ ⊢₅ □(f →' g)),
  apply proof.rn,
  assumption,

  have h₃ : (∅ ⊢₅ (□(f →' g) →' □f →' □g)),
  apply proof.ax,
  apply AxiomS5.axK,

  have h₄ : (∅ ⊢₅ (□f →' □g)) := proof.mp _ _ _ h₂ h₃,
  assumption,
end

lemma S5_sym_alt (Γ : set Formula) (f : Formula) : Γ ⊢₅ (◇ □ f →' f) :=
begin
  rw [←deduction_S5],
  set Γ' := insert (□(□f→'⊥)→'⊥) Γ,

  have h₁ : (Γ' ⊢₅ (¬' f →' □ ◇ ¬' f)),
  apply proof.ax,
  apply AxiomS5.sym,

  have h₂ := contrapose_S5 _ _ _ h₁,

  have h₃ : (∅ ⊢₅ (f →' ¬' ¬' f)),
  apply lift_S5,
  apply dneg_intro_PC,

  have h₄ := nec_k _ _ h₃,
  have h₅ := contrapose_S5 _ _ _ h₄,
  have h₆ := nec_k _ _ h₅,
  have h₇ := contrapose_S5 _ _ _ h₆,
  have h₈ := proof_subset AxiomS5 ∅ Γ' _ (by finish) h₇,

  have h₉ : (Γ' ⊢₅ (□(□f→'⊥)→'⊥)) := proof.ctx _ _ (by finish),
  have h₁₀ := proof.mp _ _ _ h₉ h₈,
  have h₁₁ := proof.mp _ _ _ h₁₀ h₂,

  have h₁₂ : (Γ' ⊢₅ (¬' ¬'f →' f)),
  apply lift_S5,
  apply dneg_elim_PC,

  have h₁₃ := proof.mp _ _ _ h₁₁ h₁₂,
  assumption,
end

def consistent (A : set Formula) (Γ : set Formula) : Prop
  := ¬(Γ ⊢[A] ⊥)

def cons_ext (A : set Formula) (Γ : set Formula) (f : Formula) : set Formula
  := if consistent A (Γ ∪ {f}) then Γ ∪ {f} else Γ ∪ {¬'f}

def cons_ext_nth (A : set Formula) (Γ : set Formula) (n : nat) : set Formula
  :=
     match encodable.decode Formula n with
     | none := Γ
     | some f := cons_ext A Γ f
     end

def cons_ext_chain (A : set Formula) (Γ : set Formula) : nat → set Formula
| 0 := Γ
| (n + 1) := cons_ext_nth A (cons_ext_chain n) n

def cons_ext_max (A : set Formula) (Γ : set Formula) : set Formula
  := ⋃ n : nat, cons_ext_chain A Γ n

lemma cons_ext_sub (A: set Formula) (Γ : set Formula) (f : Formula)
  : Γ ⊆ cons_ext A Γ f :=
begin
  simp [cons_ext],
  split_ifs,
  finish,
  finish,
end

lemma cons_ext_nth_sub (A: set Formula) (Γ : set Formula) (n : nat)
  : Γ ⊆ cons_ext_nth A Γ n :=
begin
  simp [cons_ext_nth],
  cases encodable.decode Formula n,
  finish,
  finish [cons_ext_nth, cons_ext_sub],
end

lemma cons_ext_chain_sub₁ (A : set Formula) (Γ : set Formula) (n : nat)
  : cons_ext_chain A Γ n ⊆ cons_ext_chain A Γ (n + 1) :=
  by finish [cons_ext_chain, cons_ext_nth_sub]

lemma cons_ext_chain_sub₂ (A : set Formula) (Γ : set Formula) (m n : nat)
  : m ≤ n → cons_ext_chain A Γ m ⊆ cons_ext_chain A Γ n :=
begin
  intro h₁,
  cases nat.le.dest h₁ with n' h₂,
  rw [←h₂] at *,
  clear h₂ h₁ n,

  induction n',
  refl,
  exact set.subset.trans n'_ih (cons_ext_chain_sub₁ _ _ _),
end

lemma cons_ext_max_sub (A : set Formula) (Γ : set Formula)
  : Γ ⊆ cons_ext_max A Γ := set.subset_Union (cons_ext_chain A Γ) 0

lemma cons_ext_cons (Γ : set Formula) (f : Formula)
  (h : consistent AxiomS5 Γ) : consistent AxiomS5 (cons_ext AxiomS5 Γ f) :=
begin
  by_cases h₁ : consistent AxiomS5 (Γ ∪ {f}),
  finish [cons_ext],

  simp [cons_ext, consistent] at *,
  split_ifs,
  by_contradiction h₂,

  have h₃ : ¬consistent AxiomS5 Γ,
  simp [consistent],

  have h₄ : (Γ ⊢[AxiomS5] (f ∨' ¬'f)),
  apply proof.ax,
  apply AxiomS5.prop,
  apply AxiomPC.lem,

  have h₅ : (Γ ⊢[AxiomS5] ((f →' ⊥) →' (¬' f →' ⊥) →' (f ∨' ¬' f) →' ⊥)),
  apply proof.ax,
  apply AxiomS5.prop,
  apply AxiomPC.orElim,

  have h₆ := (deduction_S5 Γ f ⊥).mp h₁,
  have h₇ := (deduction_S5 Γ (¬'f) ⊥).mp h₂,

  have h₈ := proof.mp _ _ Γ h₆ h₅,
  have h₉ := proof.mp _ _ Γ h₇ h₈,
  have h₁₀ := proof.mp _ _ Γ h₄ h₉,
  exact h₁₀,

  contradiction,
end

lemma cons_ext_nth_cons (Γ : set Formula) (n : nat)
  (h : consistent AxiomS5 Γ) : consistent AxiomS5 (cons_ext_nth AxiomS5 Γ n) :=
begin
  simp [cons_ext_nth],
  cases encodable.decode Formula n,
  finish,
  finish [cons_ext_nth, cons_ext_cons],
end

lemma cons_ext_chain_cons (Γ : set Formula) (n : nat)
  (h : consistent AxiomS5 Γ) : consistent AxiomS5 (cons_ext_chain AxiomS5 Γ n) :=
begin
  induction n,
  finish,
  finish [cons_ext_chain, cons_ext_nth_cons],
end

theorem finite_derivation (A : set Formula) (Γ : set Formula) (f : Formula)
  : ((cons_ext_max A Γ) ⊢[A] f) → ∃ n : ℕ, ((cons_ext_chain A Γ n) ⊢[A] f) :=
begin
  generalize eq : cons_ext_max A Γ = Γ',
  intro h,
  induction h,

  case ax : {
    use 0,
    apply proof.ax,
    assumption,
  },

  case ctx : _ _ ctx {
    subst eq,
    simp [cons_ext_max] at ctx,
    cases ctx with n d,
    use n,
    apply proof.ctx,
    assumption,
  },

  case mp : A' B' _ _ _ ih₁ ih₂ {
    subst eq,
    cases ih₁ (by refl) with n₁ d₁,
    cases ih₂ (by refl) with n₂ d₂,

    use max n₁ n₂,
    apply proof.mp A' B',

    apply proof_subset _ (cons_ext_chain A Γ n₁),
    apply cons_ext_chain_sub₂,
    finish,
    assumption,

    apply proof_subset _ (cons_ext_chain A Γ n₂),
    apply cons_ext_chain_sub₂,
    finish,
    assumption,
  },

  case rn : {
    use 0,
    apply proof.rn,
    assumption,
  },
end

lemma cons_ext_max_cons (Γ : set Formula) (h₁ : consistent AxiomS5 Γ)
  : consistent AxiomS5 (cons_ext_max AxiomS5 Γ) :=
begin
  by_contradiction h₂,
  simp [consistent] at *,
  cases finite_derivation _ _ _ h₂ with n h₃,
  have h₄ := cons_ext_chain_cons _ n h₁,
  contradiction,
end

lemma cons_ext_max_equicons (Γ : set Formula)
  : consistent AxiomS5 Γ ↔ consistent AxiomS5 (cons_ext_max AxiomS5 Γ) :=
begin
  split,
  apply cons_ext_max_cons,

  contrapose,
  simp [consistent],
  apply proof_subset,
  apply cons_ext_max_sub,
end

lemma cons_ext_max_em (A : set Formula) (Γ : set Formula) (f : Formula)
  : f ∈ cons_ext_max A Γ ∨ (¬'f) ∈ cons_ext_max A Γ :=
begin
  set n := encodable.encode f,
  have h₁ : cons_ext_chain A Γ (n + 1) ⊆ cons_ext_max A Γ :=
    by simp [cons_ext_max, set.subset_Union],

  simp [cons_ext_chain, cons_ext_nth, cons_ext] at *,
  split_ifs at *,

  left,
  apply h₁,
  finish,

  right,
  apply h₁,
  finish,
end

theorem cons_ext_max_closed (Γ : set Formula) (f : Formula)
  (h₁ : consistent AxiomS5 Γ) (h₂ : (cons_ext_max AxiomS5 Γ) ⊢[AxiomS5] f)
  : f ∈ (cons_ext_max AxiomS5 Γ) :=
begin
  cases cons_ext_max_em AxiomS5 Γ f with _ h₃,
  assumption,

  have h₄ := proof.ctx _ _ h₃,
  have h₅ := proof.mp _ _ _ h₂ h₄,
  have h₆ := cons_ext_max_cons _ h₁,
  contradiction,
end

lemma cons_ext_max_der_equiv (Γ : set Formula) (f : Formula) (h : consistent AxiomS5 Γ)
  : (cons_ext_max AxiomS5 Γ ⊢₅ f) ↔ f ∈ cons_ext_max AxiomS5 Γ :=
begin
  split,
  exact cons_ext_max_closed _ _ h,
  exact proof.ctx _ _,
end

inductive CanonS5_W : set (set Formula.{u})
| mk : ∀ Γ : set Formula, consistent AxiomS5 Γ → CanonS5_W (cons_ext_max AxiomS5 Γ)

def v_mem (w : CanonS5_W.{u}) (f : Formula.{u}) : Prop := f ∈ (↑w : set Formula.{u})

def unbox (w : set Formula.{u}) : set Formula.{u} := { f | □f ∈ w }

def CanonS5_R (w₁ w₂ : CanonS5_W.{u}) : Prop :=
  unbox (w₁ : set Formula.{u}) ⊆ (w₂ : set Formula.{u})

def CanonS5_v (w : CanonS5_W.{u}) (n : nat) : Prop := v_mem w #n

lemma v_mem_der_equiv (w : CanonS5_W.{u}) (f : Formula.{u})
  : (v_mem w f) ↔ ((w : set Formula.{u}) ⊢₅ f) :=
begin
  cases w, induction w_property,
  simp [v_mem],
  rw [cons_ext_max_der_equiv],
  assumption,
end

lemma v_mem_em (w : CanonS5_W.{u}) (f : Formula.{u})
  : v_mem w f ∨ v_mem w ¬'f :=
begin
  cases w, induction w_property,
  apply cons_ext_max_em,
end

lemma CanonS5_R_refl : reflexive CanonS5_R :=
begin
  intros w₁ f h₁,

  cases w₁,
  simp [unbox] at *,
  induction w₁_property,

  apply cons_ext_max_closed,
  tauto,

  rw cons_ext_max_equicons at *,
  have h₂ : (_ ⊢₅ _) := proof.ctx _ _ h₁,
  have h₃ := proof.ax _ (cons_ext_max AxiomS5 w₁_property_Γ) (AxiomS5.ref f),

  exact proof.mp _ _ _ h₂ h₃,
end

lemma CanonS5_R_sym : symmetric CanonS5_R :=
begin
  intros w₁ w₂ h₁ f h₂,

  cases w₁,
  cases w₂,
  simp [CanonS5_R] at *,
  simp [unbox] at *,
  induction w₁_property,
  induction w₂_property,

  cases cons_ext_max_em AxiomS5 w₁_property_Γ □¬'□ f with h₃ h₃;
  rw [←cons_ext_max_der_equiv] at *;
  set Γ₁ := cons_ext_max AxiomS5 w₁_property_Γ,
  set Γ₂ := cons_ext_max AxiomS5 w₂_property_Γ,

  have h₄ := h₁ ((cons_ext_max_der_equiv _ _ _).mp h₃),
  rw [←cons_ext_max_der_equiv] at *,
  repeat { tauto },

  have h₅ := proof.mp _ _ _ h₂ h₄,
  exfalso,

  have h₇ := cons_ext_max_cons _ w₂_property_ᾰ,
  contradiction,

  have h₄ := S5_sym_alt Γ₁ f,
  have h₅ := proof.mp _ _ _ h₃ h₄,

  assumption,
end

lemma CanonS5_R_trans : transitive CanonS5_R :=
begin
  intros w₁ w₂ w₃ h₁ h₂ f h₃,

  cases w₁,
  cases w₂,
  cases w₃,
  induction w₁_property,
  induction w₂_property,
  induction w₃_property,
  simp [CanonS5_R, v_mem, unbox] at *,
  rw [←cons_ext_max_der_equiv] at h₃,

  have h₄ : (cons_ext_max AxiomS5 w₁_property_Γ ⊢₅ (□f →' □□f)),
  apply proof.ax,
  apply AxiomS5.tran,

  have h₅ := proof.mp _ _ _ h₃ h₄,
  rw [cons_ext_max_der_equiv] at h₅,
  apply h₂,
  apply h₁,

  repeat {tauto},
end

def CanonS5 : Model.{u} := { W := CanonS5_W.{u}, r := CanonS5_R.{u}, v := CanonS5_v.{u}}

lemma CanonS5_models : ModelS5 CanonS5 :=
  ⟨CanonS5_R_refl, ⟨CanonS5_R_sym, CanonS5_R_trans⟩⟩

lemma unbox_deriv (w : CanonS5_W.{u}) (f : Formula.{u})
  : (unbox (↑w : set Formula.{u}) ⊢₅ f) → v_mem w (□f) :=
begin
  generalize eq : unbox (↑w : set Formula.{u}) = Γ',
  intro prf,
  induction prf,

  case ax {
    rw [v_mem_der_equiv],
    apply proof.rn,
    apply proof.ax,
    assumption,
  },

  case ctx : A _ prf_A {
    rw [v_mem_der_equiv],
    apply proof.ctx,
    subst eq,
    simp [unbox] at *,
    rw [←v_mem] at *,
    rw [v_mem_der_equiv] at *,
    assumption,
 },

  case mp : A B _ _ _ ihA ihB {
    subst eq,
    simp at *,
    rw [v_mem_der_equiv] at *,

    have h₁ : ((w : set Formula.{u}) ⊢₅ (□(A →' B) →' □A →' □B)),
    apply proof.ax,
    apply AxiomS5.axK,

    have h₂ := proof.mp _ _ _ ihB h₁,
    have h₃ := proof.mp _ _ _ ihA h₂,
    assumption,
  },

  case rn {
    rw [v_mem_der_equiv],
    apply proof.rn,
    apply proof.rn,
    assumption,
  },
end

lemma CanonS5_v_equiv (w : CanonS5_W.{u}) (f : Formula.{u}) :
  v_mem w f ↔ loc_true CanonS5 w f :=
begin
  induction f generalizing w,

  case absurd {
    simp [v_mem_der_equiv, loc_true],
    cases w, induction w_property,
    apply cons_ext_max_cons,
    assumption,
  },

  case var {
    tauto,
  },

  case impl : A B ih₁ ih₂ {
    specialize ih₁ w,
    specialize ih₂ w,

    simp [loc_true] at *,
    rw [←ih₁, ←ih₂] at *,
    simp [v_mem_der_equiv] at *,

    split,

    intros h₁ h₂,
    exact proof.mp _ _ _ h₂ h₁,

    intro h₁,

    cases v_mem_em w A with h₂ h₂;
    simp [v_mem_der_equiv] at *,
    apply append_S5,
    tauto,

    rw [←deduction_S5] at h₂,
    rw [←deduction_S5],

    have h₃ : (insert A (w : set Formula.{u}) ⊢₅ (⊥ →' B)),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.absurdElim,

    exact proof.mp _ _ _ h₂ h₃,
  },

  case conj : A B ih₁ ih₂ {
    specialize ih₁ w,
    specialize ih₂ w,

    simp [v_mem_der_equiv, loc_true] at *,
    split,

    intro h₁,

    have h₂ : ((w : set Formula.{u}) ⊢₅ ((A ∧' B) →' A)),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.andElimL,

    have h₃ : ((w : set Formula.{u}) ⊢₅ ((A ∧' B) →' B)),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.andElimR,

    split,

    rw ←ih₁,
    exact proof.mp _ _ _ h₁ h₂,

    rw ←ih₂,
    exact proof.mp _ _ _ h₁ h₃,

    rw [←ih₁, ←ih₂],
    intro h₁,

    have h₂ : ((w : set Formula.{u}) ⊢₅ (A →' B →' (A ∧' B))),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.andIntro,

    have h₃ := proof.mp _ _ _ h₁.1 h₂,
    have h₄ := proof.mp _ _ _ h₁.2 h₃,
    assumption,
  },

  case disj : A B ih₁ ih₂ {
    specialize ih₁ w,
    specialize ih₂ w,

    simp [loc_true] at *,
    rw [←ih₁, ←ih₂] at *,
    simp [v_mem_der_equiv] at *,
    split,

    intro h₁,

    cases v_mem_em w A with h₂ h₂,
    left,
    simp [v_mem_der_equiv] at *,
    assumption,

    cases v_mem_em w B with h₃ h₃,
    right,
    simp [v_mem_der_equiv] at *,
    assumption,

    simp [v_mem_der_equiv] at *,
    exfalso,

    have h₄ : ((w : set Formula.{u}) ⊢₅ (¬' A →' ¬' B →' ¬'(A ∨' B))),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.orElim,

    have h₅ := proof.mp _ _ _ h₂ h₄,
    have h₆ := proof.mp _ _ _ h₃ h₅,
    have h₇ := proof.mp _ _ _ h₁ h₆,

    cases w, induction w_property,
    have h₈ := cons_ext_max_cons _ w_property_ᾰ,
    contradiction,

    intro h₁,
    cases h₁,

    have h₂ : ((w : set Formula.{u}) ⊢₅ (A →' (A ∨' B))),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.orIntroL,
    exact proof.mp _ _ _ h₁ h₂,

    have h₂ : ((w : set Formula.{u}) ⊢₅ (B →' (A ∨' B))),
    apply proof.ax,
    apply AxiomS5.prop,
    apply AxiomPC.orIntroR,
    exact proof.mp _ _ _ h₁ h₂,
  },

  case nec : A ih {
    split,

    intros h₁ w' acc,
    rw [←ih],
    apply acc,
    simp [*, v_mem, unbox] at *,

    intro h₁,
    cases v_mem_em w □A with h₂ h₂,
    assumption,

    exfalso,
    set Γ' : set Formula.{u} :=
      insert (¬'A) (unbox (w : set Formula.{u})) with eq,

    have h₃ : consistent AxiomS5 Γ' :=
      begin
        intro h₃,
        simp [eq] at h₃,
        simp [deduction_S5] at h₃,

        have h₄ := unbox_deriv _ _ h₃,
        rw [v_mem_der_equiv] at h₂,
        rw [v_mem_der_equiv] at h₄,

        have h₅ : ((w : set Formula.{u}) ⊢₅ □(¬' ¬' A →' A)),
        apply proof.rn,
        apply lift_S5,
        apply dneg_elim_PC,

        have h₆ : ((w : set Formula.{u}) ⊢₅ (□(¬' ¬' A →' A)) →' □ ¬' ¬' A →' □ A),
        apply proof.ax,
        apply AxiomS5.axK,

        have h₇ := proof.mp _ _ _ h₅ h₆,
        have h₈ := proof.mp _ _ _ h₄ h₇,
        have h₉ := proof.mp _ _ _ h₈ h₂,

        cases w, induction w_property,
        apply cons_ext_max_cons,
        assumption,
        assumption,
      end,

    set w_mem := CanonS5_W.mk.{u} Γ' h₃,

    simp [loc_true] at h₁,
    specialize h₁ ⟨cons_ext_max AxiomS5 Γ', w_mem⟩,

    have h₄ : CanonS5.r w ⟨cons_ext_max AxiomS5 Γ', w_mem⟩,
    intros f h₅,
    apply cons_ext_max_sub,
    finish,

    specialize h₁ h₄,
    rw [←ih] at h₁,

    simp [v_mem_der_equiv] at *,

    have h₅ : (cons_ext_max AxiomS5 Γ' ⊢₅ ¬' A),
    apply proof.ctx,
    apply cons_ext_max_sub,
    finish,

    have h₆ := proof.mp _ _ _ h₁ h₅,
    have h₇ := cons_ext_max_cons _ h₃,
    contradiction,
  },
end

theorem S5_complete : complete AxiomS5.{u} ModelS5.{u} :=
begin
  simp [complete],
  intros Γ f,

  set Γ' := cons_ext_max AxiomS5 (Γ ∪ {¬' f}),

  by_cases h₁ : consistent AxiomS5 (Γ ∪ {¬' f}),
  contrapose,

  intros prf mdl,

  have h₂ : CanonS5_W Γ',
  fconstructor,
  assumption,

  specialize mdl CanonS5 CanonS5_models ⟨Γ', h₂⟩ _,
  rw [←CanonS5_v_equiv] at mdl,
  simp [v_mem] at mdl,
  rw [←cons_ext_max_der_equiv] at mdl,

  have h₃ : (Γ' ⊢₅ (f →' ⊥)),
  apply proof.ctx,
  apply cons_ext_max_sub,
  finish,

  have h₄ : (Γ' ⊢₅ ⊥) := proof.mp _ _ _ mdl h₃,
  have h₅ := cons_ext_max_cons _ h₁,
  contradiction,

  assumption,
  intros f' h₃,
  rw [←CanonS5_v_equiv],
  simp [v_mem],
  apply cons_ext_max_sub,
  finish,

  intro _,
  simp [consistent] at h₁,
  rw deduction_S5 at h₁,

  have h₂ := lift_S5 _ _ (dneg_elim_PC Γ f),
  have h₃ := proof.mp _ _ _ h₁ h₂,
  assumption,
end


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

! This file was ported from Lean 3 source module tactic.norm_fin
! leanprover-community/mathlib commit 0bd2ea37bcba5769e14866170f251c9bc64e35d7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fin.Basic
import Mathbin.Tactic.NormNum

/-!
# `norm_fin`

This file defines functions for dealing with `fin n` numbers as expressions.

## Main definitions

* `tactic.norm_fin.eval_ineq` is a `norm_num` plugin for normalizing equalities and inequalities of
  type `fin n`.

* `tactic.interactive.norm_fin` is a standalone tactic like `norm_num` for normalizing `fin n`
  expressions anywhere in the goal.

-/

namespace Tactic

namespace NormFin

open NormNum

/-- `normalize_fin n a b` means that `a : fin n` is equivalent to `b : ℕ` in the modular sense -
that is, `↑a ≡ b (mod n)`. This is used for translating the algebraic operations: addition,
multiplication, zero and one, which use modulo for reduction. -/
def NormalizeFin (n : ℕ) (a : Fin n) (b : ℕ) :=
  a.1 = b % n
#align tactic.norm_fin.normalize_fin Tactic.NormFin.NormalizeFin

/-- `normalize_fin_lt n a b` means that `a : fin n` is equivalent to `b : ℕ` in the embedding
sense - that is, `↑a = b`. This is used for operations that treat `fin n` as the subset
`{0, ..., n-1}` of `ℕ`. For example, `fin.succ : fin n → fin (n+1)` is thought of as the successor
function, but it does not lift to a map `zmod n → zmod (n+1)`; this addition only makes sense if
the input is strictly less than `n`.

`normalize_fin_lt n a b` is equivalent to `normalize_fin n a b ∧ b < n`. -/
def NormalizeFinLt (n : ℕ) (a : Fin n) (b : ℕ) :=
  a.1 = b
#align tactic.norm_fin.normalize_fin_lt Tactic.NormFin.NormalizeFinLt

theorem NormalizeFinLt.coe {n} {a : Fin n} {b : ℕ} (h : NormalizeFinLt n a b) : ↑a = b :=
  h
#align tactic.norm_fin.normalize_fin_lt.coe Tactic.NormFin.NormalizeFinLt.coe

theorem normalizeFin_iff {n : ℕ} [NeZero n] {a b} : NormalizeFin n a b ↔ a = Fin.ofNat'' b :=
  Iff.symm (Fin.eq_iff_veq _ _)
#align tactic.norm_fin.normalize_fin_iff Tactic.NormFin.normalizeFin_iff

theorem NormalizeFinLt.mk {n a b n'} (hn : n = n') (h : NormalizeFin n a b) (h2 : b < n') :
    NormalizeFinLt n a b :=
  h.trans <| Nat.mod_eq_of_lt <| by rw [hn] <;> exact h2
#align tactic.norm_fin.normalize_fin_lt.mk Tactic.NormFin.NormalizeFinLt.mk

theorem NormalizeFinLt.lt {n a b} (h : NormalizeFinLt n a b) : b < n := by
  rw [← h.coe] <;> exact a.2
#align tactic.norm_fin.normalize_fin_lt.lt Tactic.NormFin.NormalizeFinLt.lt

theorem NormalizeFinLt.of {n a b} (h : NormalizeFinLt n a b) : NormalizeFin n a b :=
  h.trans <| Eq.symm <| Nat.mod_eq_of_lt h.lt
#align tactic.norm_fin.normalize_fin_lt.of Tactic.NormFin.NormalizeFinLt.of

theorem NormalizeFin.zero (n : ℕ) [NeZero n] : NormalizeFin n 0 0 :=
  by
  rw [normalize_fin]
  norm_num
#align tactic.norm_fin.normalize_fin.zero Tactic.NormFin.NormalizeFin.zero

theorem NormalizeFinLt.zero (n : ℕ) [NeZero n] : NormalizeFinLt n 0 0 :=
  refl _
#align tactic.norm_fin.normalize_fin_lt.zero Tactic.NormFin.NormalizeFinLt.zero

theorem NormalizeFin.one (n : ℕ) [NeZero n] : NormalizeFin n 1 1 :=
  refl _
#align tactic.norm_fin.normalize_fin.one Tactic.NormFin.NormalizeFin.one

theorem NormalizeFin.add {n} {a b : Fin n} {a' b' c' : ℕ} (ha : NormalizeFin n a a')
    (hb : NormalizeFin n b b') (h : a' + b' = c') : NormalizeFin n (a + b) c' := by
  simp only [normalize_fin, ← h] at * <;> rw [Nat.add_mod, ← ha, ← hb, Fin.add_def]
#align tactic.norm_fin.normalize_fin.add Tactic.NormFin.NormalizeFin.add

theorem NormalizeFin.mul {n} {a b : Fin n} {a' b' c' : ℕ} (ha : NormalizeFin n a a')
    (hb : NormalizeFin n b b') (h : a' * b' = c') : NormalizeFin n (a * b) c' := by
  simp only [normalize_fin, ← h] at * <;> rw [Nat.mul_mod, ← ha, ← hb, Fin.mul_def]
#align tactic.norm_fin.normalize_fin.mul Tactic.NormFin.NormalizeFin.mul

theorem NormalizeFin.bit0 {n} {a : Fin n} {a' : ℕ} (h : NormalizeFin n a a') :
    NormalizeFin n (bit0 a) (bit0 a') :=
  h.add h rfl
#align tactic.norm_fin.normalize_fin.bit0 Tactic.NormFin.NormalizeFin.bit0

theorem NormalizeFin.bit1 {n : ℕ} [NeZero n] {a : Fin n} {a' : ℕ} (h : NormalizeFin n a a') :
    NormalizeFin n (bit1 a) (bit1 a') :=
  h.bit0.add (NormalizeFin.one _) rfl
#align tactic.norm_fin.normalize_fin.bit1 Tactic.NormFin.NormalizeFin.bit1

theorem NormalizeFinLt.succ {n} {a : Fin n} {a' b : ℕ} (h : NormalizeFinLt n a a')
    (e : a' + 1 = b) : NormalizeFinLt n.succ (Fin.succ a) b := by
  simpa [normalize_fin_lt, ← e] using h
#align tactic.norm_fin.normalize_fin_lt.succ Tactic.NormFin.NormalizeFinLt.succ

theorem NormalizeFinLt.castLt {n m} {a : Fin m} {ha} {a' : ℕ} (h : NormalizeFinLt m a a') :
    NormalizeFinLt n (Fin.castLt a ha) a' := by simpa [normalize_fin_lt] using h
#align tactic.norm_fin.normalize_fin_lt.cast_lt Tactic.NormFin.NormalizeFinLt.castLt

theorem NormalizeFinLt.castLe {n m} {nm} {a : Fin m} {a' : ℕ} (h : NormalizeFinLt m a a') :
    NormalizeFinLt n (Fin.castLe nm a) a' := by simpa [normalize_fin_lt] using h
#align tactic.norm_fin.normalize_fin_lt.cast_le Tactic.NormFin.NormalizeFinLt.castLe

theorem NormalizeFinLt.cast {n m} {nm} {a : Fin m} {a' : ℕ} (h : NormalizeFinLt m a a') :
    NormalizeFinLt n (Fin.cast nm a) a' := by simpa [normalize_fin_lt] using h
#align tactic.norm_fin.normalize_fin_lt.cast Tactic.NormFin.NormalizeFinLt.cast

theorem NormalizeFin.cast {n m} {nm} {a : Fin m} {a' : ℕ} (h : NormalizeFin m a a') :
    NormalizeFin n (Fin.cast nm a) a' := by convert← normalize_fin_lt.cast h
#align tactic.norm_fin.normalize_fin.cast Tactic.NormFin.NormalizeFin.cast

theorem NormalizeFinLt.castAdd {n m} {a : Fin n} {a' : ℕ} (h : NormalizeFinLt n a a') :
    NormalizeFinLt (n + m) (Fin.castAdd m a) a' := by simpa [normalize_fin_lt] using h
#align tactic.norm_fin.normalize_fin_lt.cast_add Tactic.NormFin.NormalizeFinLt.castAdd

theorem NormalizeFinLt.castSucc {n} {a : Fin n} {a' : ℕ} (h : NormalizeFinLt n a a') :
    NormalizeFinLt (n + 1) (Fin.castSucc a) a' :=
  NormalizeFinLt.castAdd h
#align tactic.norm_fin.normalize_fin_lt.cast_succ Tactic.NormFin.NormalizeFinLt.castSucc

theorem NormalizeFinLt.addNat {n m m'} (hm : m = m') {a : Fin n} {a' b : ℕ}
    (h : NormalizeFinLt n a a') (e : a' + m' = b) : NormalizeFinLt (n + m) (@Fin.addNat n m a) b :=
  by simpa [normalize_fin_lt, ← e, ← hm] using h
#align tactic.norm_fin.normalize_fin_lt.add_nat Tactic.NormFin.NormalizeFinLt.addNat

theorem NormalizeFinLt.natAdd {n m n'} (hn : n = n') {a : Fin m} {a' b : ℕ}
    (h : NormalizeFinLt m a a') (e : n' + a' = b) : NormalizeFinLt (n + m) (@Fin.natAdd n m a) b :=
  by simpa [normalize_fin_lt, ← e, ← hn] using h
#align tactic.norm_fin.normalize_fin_lt.nat_add Tactic.NormFin.NormalizeFinLt.natAdd

theorem NormalizeFin.reduce {n} {a : Fin n} {n' a' b k nk : ℕ} (hn : n = n')
    (h : NormalizeFin n a a') (e1 : n' * k = nk) (e2 : nk + b = a') : NormalizeFin n a b := by
  rwa [← e2, ← e1, ← hn, normalize_fin, add_comm, Nat.add_mul_mod_self_left] at h
#align tactic.norm_fin.normalize_fin.reduce Tactic.NormFin.NormalizeFin.reduce

theorem NormalizeFinLt.reduce {n} {a : Fin n} {n' a' b k nk : ℕ} (hn : n = n')
    (h : NormalizeFin n a a') (e1 : n' * k = nk) (e2 : nk + b = a') (hl : b < n') :
    NormalizeFinLt n a b :=
  NormalizeFinLt.mk hn (h.reduce hn e1 e2) hl
#align tactic.norm_fin.normalize_fin_lt.reduce Tactic.NormFin.NormalizeFinLt.reduce

theorem NormalizeFin.eq {n} {a b : Fin n} {c : ℕ} (ha : NormalizeFin n a c)
    (hb : NormalizeFin n b c) : a = b :=
  Fin.eq_of_veq <| ha.trans hb.symm
#align tactic.norm_fin.normalize_fin.eq Tactic.NormFin.NormalizeFin.eq

theorem NormalizeFin.lt {n} {a b : Fin n} {a' b' : ℕ} (ha : NormalizeFin n a a')
    (hb : NormalizeFinLt n b b') (h : a' < b') : a < b := by
  have ha' := normalize_fin_lt.mk rfl ha (h.trans hb.lt) <;> rwa [← hb.coe, ← ha'.coe] at h
#align tactic.norm_fin.normalize_fin.lt Tactic.NormFin.NormalizeFin.lt

theorem NormalizeFin.le {n} {a b : Fin n} {a' b' : ℕ} (ha : NormalizeFin n a a')
    (hb : NormalizeFinLt n b b') (h : a' ≤ b') : a ≤ b := by
  have ha' := normalize_fin_lt.mk rfl ha (h.trans_lt hb.lt) <;> rwa [← hb.coe, ← ha'.coe] at h
#align tactic.norm_fin.normalize_fin.le Tactic.NormFin.NormalizeFin.le

/-- The monad for the `norm_fin` internal tactics. The state consists of an instance cache for `ℕ`,
and a tuple `(nn, n', p)` where `p` is a proof of `n = n'` and `nn` is `n` evaluated to a natural
number. (`n` itself is implicit.)  It is in an `option` because it is lazily initialized - for many
`n` we will never need this information, and indeed eagerly computing it would make some reductions
fail spuriously if `n` is not a numeral. -/
unsafe def eval_fin_m (α : Type) : Type :=
  StateT (instance_cache × Option (ℕ × expr × expr)) tactic α deriving Monad, Alternative
#align tactic.norm_fin.eval_fin_m tactic.norm_fin.eval_fin_m

/-- Lifts a tactic into the `eval_fin_m` monad. -/
@[inline]
unsafe def eval_fin_m.lift {α} (m : tactic α) : eval_fin_m α :=
  ⟨fun ⟨ic, r⟩ => do
    let a ← m
    pure (a, ic, r)⟩
#align tactic.norm_fin.eval_fin_m.lift tactic.norm_fin.eval_fin_m.lift

unsafe instance {α} : Coe (tactic α) (eval_fin_m α) :=
  ⟨eval_fin_m.lift⟩

/-- Lifts an `instance_cache` tactic into the `eval_fin_m` monad. -/
@[inline]
unsafe def eval_fin_m.lift_ic {α} (m : instance_cache → tactic (instance_cache × α)) :
    eval_fin_m α :=
  ⟨fun ⟨ic, r⟩ => do
    let (ic, a) ← m ic
    pure (a, ic, r)⟩
#align tactic.norm_fin.eval_fin_m.lift_ic tactic.norm_fin.eval_fin_m.lift_ic

/-- Evaluates a monadic action with a fresh `n` cache, and restore the old cache on completion of
the action. This is used when evaluating a tactic in the context of a different `n` than the parent
context. For example if we are evaluating `fin.succ a`, then `a : fin n` and
`fin.succ a : fin (n+1)`, so the parent cache will be about `n+1` and we need a separate cache for
`n`. -/
@[inline]
unsafe def eval_fin_m.reset {α} (m : eval_fin_m α) : eval_fin_m α :=
  ⟨fun ⟨ic, r⟩ => do
    let (a, ic, _) ← m.run ⟨ic, none⟩
    pure (a, ic, r)⟩
#align tactic.norm_fin.eval_fin_m.reset tactic.norm_fin.eval_fin_m.reset

/-- Given `n`, returns a tuple `(nn, n', p)` where `p` is a proof of `n = n'` and `nn` is `n`
evaluated to a natural number. The result of the evaluation is cached for future references.
Future calls to this function must use the same value of `n`, unless it is in a sub-context
created by `eval_fin_m.reset`. -/
unsafe def eval_fin_m.eval_n (n : expr) : eval_fin_m (ℕ × expr × expr) :=
  ⟨fun ⟨ic, r⟩ =>
    match r with
    | none => do
      let (n', p) ← or_refl_conv norm_num.derive n
      let nn ← n'.toNat
      let np := (nn, n', p)
      pure (np, ic, some np)
    | some np => pure (np, ic, some np)⟩
#align tactic.norm_fin.eval_fin_m.eval_n tactic.norm_fin.eval_fin_m.eval_n

/-- Run an `eval_fin_m` action with a new cache and discard the cache after evaluation. -/
@[inline]
unsafe def eval_fin_m.run {α} (m : eval_fin_m α) : tactic α := do
  let ic ← mk_instance_cache q(ℕ)
  let (a, _) ← StateT.run m (ic, none)
  pure a
#align tactic.norm_fin.eval_fin_m.run tactic.norm_fin.eval_fin_m.run

/-- The expression constructors recognized by the `eval_fin` evaluator. This is used instead of a
direct expr pattern match because expr pattern matches generate very large terms under the
hood so going via an intermediate inductive type like this is more efficient. -/
unsafe inductive match_fin_result
  | zero (n : expr) (n0 : expr)-- `(0 : fin n)`

  | one (n : expr) (n0 : expr)-- `(1 : fin n)`

  | add (n a b : expr)-- `(a + b : fin n)`

  | mul (n a b : expr)-- `(a * b : fin n)`

  | bit0 (n a : expr)-- `(bit0 a : fin n)`

  | bit1 (n a : expr) (n0 : expr)-- `(bit1 a : fin n)`

  | succ (n a : expr)-- `(fin.succ a : fin n.succ)`

  | cast_lt (n m i h : expr)-- `(fin.cast_lt (i : fin m) (h : i.val < n) : fin n)`

  | cast_le (n m h a : expr)-- `(fin.cast_le (h : n ≤ m) (a : fin n) : fin m)`

  | cast (n m h a : expr)-- `(fin.cast_le (h : n = m) (a : fin n) : fin m)`

  | cast_add (n m a : expr)-- `(fin.cast_add m (a : fin n) : fin (n + m))`

  | cast_succ (n a : expr)-- `(fin.cast_succ (a : fin n) : fin (n + 1))`

  | add_nat (n m a : expr)-- `(fin.add_nat m (a : fin n) : fin (n + m))`

  | nat_add (n m a : expr)
#align tactic.norm_fin.match_fin_result tactic.norm_fin.match_fin_result

-- `(fin.nat_add n (a : fin m) : fin (n + m))`
section

open MatchFinResult

/-- Match a fin expression of the form `(coe_fn f a)` where `f` is some fin function. Several fin
functions are written this way: for example `cast_le : n ≤ m → fin n ↪o fin m` is not actually a
function but rather an order embedding with a coercion to a function. -/
unsafe def match_fin_coe_fn (a : expr) : expr → Option match_fin_result
  | q(@Fin.castLe $(n) $(m) $(h)) => some (cast_le n m h a)
  | q(@Fin.cast $(m) $(n) $(h)) => some (cast n m h a)
  | q(@Fin.castAdd $(n) $(m)) => some (cast_add n m a)
  | q(@Fin.castSucc $(n)) => some (cast_succ n a)
  | q(@Fin.addNat $(n) $(m)) => some (add_nat n m a)
  | q(@Fin.natAdd $(n) $(m)) => some (nat_add n m a)
  | _ => none
#align tactic.norm_fin.match_fin_coe_fn tactic.norm_fin.match_fin_coe_fn

/-- Match a fin expression to a `match_fin_result`, for easier pattern matching in the
evaluator. -/
unsafe def match_fin : expr → Option match_fin_result
  | q(@Zero.zero _ (@Fin.hasZeroOfNeZero $(n) $(n0))) => some (zero n n0)
  | q(@One.one _ (@Fin.hasOneOfNeZero $(n) $(n0))) => some (one n n0)
  | q(@Add.add (Fin $(n)) _ $(a) $(b)) => some (add n a b)
  | q(@Mul.mul (Fin $(n)) _ $(a) $(b)) => some (mul n a b)
  | q(@bit0 (Fin $(n)) _ $(a)) => some (bit0 n a)
  | q(@bit1 _ (@Fin.hasOneOfNeZero $(n) $(n0)) _ $(a)) => some (bit1 n a n0)
  | q(@Fin.succ $(n) $(a)) => some (succ n a)
  | q(@Fin.castLt $(n) $(m) $(a) $(h)) => some (cast_lt n m a h)
  | expr.app q(@coeFn _ _ _ $(f)) a => match_fin_coe_fn a f
  | _ => none
#align tactic.norm_fin.match_fin tactic.norm_fin.match_fin

end

/-- `reduce_fin lt n a (a', pa)` expects that `pa : normalize_fin n a a'` where `a'`
is a natural numeral, and produces `(b, pb)` where `pb : normalize_fin n a b` if `lt` is false, or
`pb : normalize_fin_lt n a b` if `lt` is true. In either case, `b` will be chosen to be less than
`n`, but if `lt` is true then we also prove it. This requires that `n` can be evaluated to a
numeral. -/
unsafe def reduce_fin' : Bool → expr → expr → expr × expr → eval_fin_m (expr × expr)
  | lt, n, a, (a', pa) => do
    let (nn, n', pn) ← eval_fin_m.eval_n n
    let na ← expr.to_nat a'
    if na < nn then
        if lt then do
          let p ← eval_fin_m.lift_ic fun ic => prove_lt_nat ic a' n'
          pure (a', q(@NormalizeFinLt.mk).mk_app [n, a, a', n', pn, pa, p])
        else pure (a', pa)
      else
        let nb := na % nn
        let nk := (na - nb) / nn
        eval_fin_m.lift_ic fun ic => do
          let (ic, k) ← ic nk
          let (ic, b) ← ic nb
          let (ic, nk, pe1) ← prove_mul_nat ic n' k
          let (ic, pe2) ← prove_add_nat ic nk b a'
          if lt then do
              let (ic, p) ← prove_lt_nat ic b n'
              pure
                  (ic, b,
                    q(@NormalizeFinLt.reduce).mk_app [n, a, n', a', b, k, nk, pn, pa, pe1, pe2, p])
            else
              pure
                (ic, b, q(@NormalizeFin.reduce).mk_app [n, a, n', a', b, k, nk, pn, pa, pe1, pe2])
#align tactic.norm_fin.reduce_fin' tactic.norm_fin.reduce_fin'

/-- `eval_fin_lt' eval_fin n a` expects that `a : fin n`, and produces `(b, p)` where
`p : normalize_fin_lt n a b`. (It is mutually recursive with `eval_fin` which is why it takes the
function as an argument.) -/
unsafe def eval_fin_lt' (eval_fin : expr → eval_fin_m (expr × expr)) :
    expr → expr → eval_fin_m (expr × expr)
  | n, a => do
    let e ← match_fin a
    match e with
      | match_fin_result.succ n a => do
        let (a', pa) ← (eval_fin_lt' n a).reset
        let (b, pb) ← eval_fin_m.lift_ic fun ic => prove_succ' ic a'
        pure (b, q(@NormalizeFinLt.succ).mk_app [n, a, a', b, pa, pb])
      | match_fin_result.cast_lt _ m a h => do
        let (a', pa) ← (eval_fin_lt' m a).reset
        pure (a', q(@NormalizeFinLt.castLt).mk_app [n, m, a, h, a', pa])
      | match_fin_result.cast_le _ m nm a => do
        let (a', pa) ← (eval_fin_lt' m a).reset
        pure (a', q(@NormalizeFinLt.castLe).mk_app [n, m, nm, a, a', pa])
      | match_fin_result.cast m _ nm a => do
        let (a', pa) ← (eval_fin_lt' m a).reset
        pure (a', q(@NormalizeFinLt.cast).mk_app [n, m, nm, a, a', pa])
      | match_fin_result.cast_add n m a => do
        let (a', pa) ← (eval_fin_lt' m a).reset
        pure (a', q(@NormalizeFinLt.castAdd).mk_app [n, m, a, a', pa])
      | match_fin_result.cast_succ n a => do
        let (a', pa) ← (eval_fin_lt' n a).reset
        pure (a', q(@NormalizeFinLt.castSucc).mk_app [n, a, a', pa])
      | match_fin_result.add_nat n m a => do
        let (a', pa) ← (eval_fin_lt' n a).reset
        let (m', pm) ← or_refl_conv norm_num.derive m
        let (b, pb) ← eval_fin_m.lift_ic fun ic => prove_add_nat' ic a' m'
        pure (b, q(@NormalizeFinLt.addNat).mk_app [n, m, m', pm, a, a', b, pa, pb])
      | match_fin_result.nat_add n m a => do
        let (a', pa) ← (eval_fin_lt' m a).reset
        let (n', pn) ← or_refl_conv norm_num.derive n
        let (b, pb) ← eval_fin_m.lift_ic fun ic => prove_add_nat' ic n' a'
        pure (b, q(@NormalizeFinLt.natAdd).mk_app [n, m, n', pn, a, a', b, pa, pb])
      | _ => do
        let (_, n', pn) ← eval_fin_m.eval_n n
        let (a', pa) ← eval_fin a >>= reduce_fin' tt n a
        let p ← eval_fin_m.lift_ic fun ic => prove_lt_nat ic a' n'
        pure (a', q(@NormalizeFinLt.mk).mk_app [n, a, a', n', pn, pa, p])
#align tactic.norm_fin.eval_fin_lt' tactic.norm_fin.eval_fin_lt'

/-- Get `n` such that `a : fin n`. -/
unsafe def get_fin_type (a : expr) : tactic expr := do
  let q(Fin $(n)) ← infer_type a
  pure n
#align tactic.norm_fin.get_fin_type tactic.norm_fin.get_fin_type

/-- Given `a : fin n`, `eval_fin a` returns `(b, p)` where `p : normalize_fin n a b`. This function
does no reduction of the numeral `b`; for example `eval_fin (5 + 5 : fin 6)` returns `10`. It works
even if `n` is a variable, for example `eval_fin (5 + 5 : fin (n+1))` also returns `10`. -/
unsafe def eval_fin : expr → eval_fin_m (expr × expr)
  | a => do
    let m ← match_fin a
    match m with
      | match_fin_result.zero n n0 => pure (q((0 : ℕ)), q(NormalizeFin.zero).mk_app [n, n0])
      | match_fin_result.one n n0 => pure (q((1 : ℕ)), q(NormalizeFin.one).mk_app [n, n0])
      | match_fin_result.add n a b => do
        let (a', pa) ← eval_fin a
        let (b', pb) ← eval_fin b
        let (c, pc) ← eval_fin_m.lift_ic fun ic => prove_add_nat' ic a' b'
        pure (c, q(@NormalizeFin.add).mk_app [n, a, b, a', b', c, pa, pb, pc])
      | match_fin_result.mul n a b => do
        let (a', pa) ← eval_fin a
        let (b', pb) ← eval_fin b
        let (c, pc) ← eval_fin_m.lift_ic fun ic => prove_mul_nat ic a' b'
        pure (c, q(@NormalizeFin.mul).mk_app [n, a, b, a', b', c, pa, pb, pc])
      | match_fin_result.bit0 n a => do
        let (a', pa) ← eval_fin a
        pure (q(@bit0 ℕ _).mk_app [a'], q(@NormalizeFin.bit0).mk_app [n, a, a', pa])
      | match_fin_result.bit1 n a n0 => do
        let (a', pa) ← eval_fin a
        pure (q(@bit1 ℕ _ _).mk_app [a'], q(@NormalizeFin.bit1).mk_app [n, n0, a, a', pa])
      | match_fin_result.cast m n nm a => do
        let (a', pa) ← (eval_fin a).reset
        pure (a', q(@NormalizeFin.cast).mk_app [n, m, nm, a, a', pa])
      | _ => do
        let n ← get_fin_type a
        let (a', pa) ← eval_fin_lt' eval_fin n a
        pure (a', q(@NormalizeFinLt.of).mk_app [n, a, a', pa])
#align tactic.norm_fin.eval_fin tactic.norm_fin.eval_fin

/-- `eval_fin_lt n a` expects that `a : fin n`, and produces `(b, p)` where
`p : normalize_fin_lt n a b`. -/
unsafe def eval_fin_lt : expr → expr → eval_fin_m (expr × expr) :=
  eval_fin_lt' eval_fin
#align tactic.norm_fin.eval_fin_lt tactic.norm_fin.eval_fin_lt

/-- Given `a : fin n`, `eval_fin ff n a` returns `(b, p)` where `p : normalize_fin n a b`, and
`eval_fin tt n a` returns `p : normalize_fin_lt n a b`. Unlike `eval_fin`, this also does reduction
of the numeral `b`; for example `reduce_fin ff 6 (5 + 5 : fin 6)` returns `4`. As a result, it
fails if `n` is a variable, for example `reduce_fin ff (n+1) (5 + 5 : fin (n+1))` fails. -/
unsafe def reduce_fin (lt : Bool) (n a : expr) : eval_fin_m (expr × expr) :=
  eval_fin a >>= reduce_fin' lt n a
#align tactic.norm_fin.reduce_fin tactic.norm_fin.reduce_fin

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_lt_fin' n a b a' b'` proves `a < b`. -/
unsafe def prove_lt_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
  | n, a, b, a', b' => do
    let (a', pa) ← reduce_fin' false n a a'
    let (b', pb) ← reduce_fin' true n b b'
    let p ← eval_fin_m.lift_ic fun ic => prove_lt_nat ic a' b'
    pure (q(@NormalizeFin.lt).mk_app [n, a, b, a', b', pa, pb, p])
#align tactic.norm_fin.prove_lt_fin' tactic.norm_fin.prove_lt_fin'

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_le_fin' n a b a' b'` proves `a ≤ b`. -/
unsafe def prove_le_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
  | n, a, b, a', b' => do
    let (a', pa) ← reduce_fin' false n a a'
    let (b', pb) ← reduce_fin' true n b b'
    let p ← eval_fin_m.lift_ic fun ic => prove_le_nat ic a' b'
    pure (q(@NormalizeFin.le).mk_app [n, a, b, a', b', pa, pb, p])
#align tactic.norm_fin.prove_le_fin' tactic.norm_fin.prove_le_fin'

/-- If `a b : fin n` and `a'` and `b'` are as returned by `eval_fin`,
then `prove_eq_fin' n a b a' b'` proves `a = b`. -/
unsafe def prove_eq_fin' : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr
  | n, a, b, (a', pa), (b', pb) =>
    if a' == b' then do
      pure (q(@NormalizeFin.eq).mk_app [n, a, b, a', pa, pb])
    else do
      let (a', pa) ← reduce_fin' false n a (a', pa)
      let (b', pb) ← reduce_fin' false n b (b', pb)
      guard (a' == b')
      pure (q(@NormalizeFin.eq).mk_app [n, a, b, a', pa, pb])
#align tactic.norm_fin.prove_eq_fin' tactic.norm_fin.prove_eq_fin'

/-- Given a function with the type of `prove_eq_fin'`, evaluates it with the given `a` and `b`. -/
unsafe def eval_prove_fin (f : expr → expr → expr → expr × expr → expr × expr → eval_fin_m expr)
    (a b : expr) : tactic expr := do
  let n ← get_fin_type a
  eval_fin_m.run <| eval_fin a >>= fun a' => eval_fin b >>= f n a b a'
#align tactic.norm_fin.eval_prove_fin tactic.norm_fin.eval_prove_fin

/-- If `a b : fin n`, then `prove_eq_fin a b` proves `a = b`. -/
unsafe def prove_eq_fin : expr → expr → tactic expr :=
  eval_prove_fin prove_eq_fin'
#align tactic.norm_fin.prove_eq_fin tactic.norm_fin.prove_eq_fin

/-- If `a b : fin n`, then `prove_lt_fin a b` proves `a < b`. -/
unsafe def prove_lt_fin : expr → expr → tactic expr :=
  eval_prove_fin prove_lt_fin'
#align tactic.norm_fin.prove_lt_fin tactic.norm_fin.prove_lt_fin

/-- If `a b : fin n`, then `prove_le_fin a b` proves `a ≤ b`. -/
unsafe def prove_le_fin : expr → expr → tactic expr :=
  eval_prove_fin prove_le_fin'
#align tactic.norm_fin.prove_le_fin tactic.norm_fin.prove_le_fin

section

open NormNum.MatchNumeralResult

/-- Given expressions `n` and `m` such that `n` is definitionally equal to `m.succ`, and
a natural numeral `a`, proves `(b, ⊢ normalize_fin n b a)`, where `n` and `m` are both used
in the construction of the numeral `b : fin n`. -/
unsafe def mk_fin_numeral (n m : expr) : expr → Option (expr × expr)
  | a =>
    match match_numeral a with
    | zero =>
      some
        (expr.app q(@Zero.zero (Fin $(n))) q(@Fin.hasZero $(m)),
          q(NormalizeFin.zero).mk_app [n, q(@NeZero.succ $(m))])
    | one =>
      some
        (expr.app q(@One.one (Fin $(n))) q(@Fin.hasOne $(m)),
          q(NormalizeFin.one).mk_app [n, q(@NeZero.succ $(m))])
    | bit0 a => do
      let (a', p) ← mk_fin_numeral a
      some (q((bit0 $(a') : Fin $(n))), q(@NormalizeFin.bit0).mk_app [n, a', a, p])
    | bit1 a => do
      let (a', p) ← mk_fin_numeral a
      some
          (q(@bit1 (Fin $(n))).mk_app [q(@Fin.hasOne $(m)), q(@Fin.hasAdd $(n)), a'],
            q(@NormalizeFin.bit1).mk_app [n, q(@NeZero.succ $(m)), a', a, p])
    | _ => none
#align tactic.norm_fin.mk_fin_numeral tactic.norm_fin.mk_fin_numeral

end

/-- The common prep work for the cases in `eval_ineq`. Given inputs `a b : fin n`, it calls
`f n a' b' na nb` where `a'` and `b'` are the result of `eval_fin` and `na` and `nb` are
`a' % n` and `b' % n` as natural numbers. -/
unsafe def eval_rel {α} (a b : expr) (f : expr → expr × expr → expr × expr → ℕ → ℕ → eval_fin_m α) :
    tactic α := do
  let n ← get_fin_type a
  eval_fin_m.run do
      let (nn, n', pn) ← eval_fin_m.eval_n n
      let (a', pa) ← eval_fin a
      let (b', pb) ← eval_fin b
      let na ← eval_fin_m.lift a'
      let nb ← eval_fin_m.lift b'
      f n (a', pa) (b', pb) (na % nn) (nb % nn)
#align tactic.norm_fin.eval_rel tactic.norm_fin.eval_rel

/-- Given `a b : fin n`, proves either `(n, tt, p)` where `p : a < b` or
`(n, ff, p)` where `p : b ≤ a`. -/
unsafe def prove_lt_ge_fin : expr → expr → tactic (expr × Bool × expr)
  | a, b =>
    eval_rel a b fun n a' b' na nb =>
      if na < nb then Prod.mk n <$> Prod.mk true <$> prove_lt_fin' n a b a' b'
      else Prod.mk n <$> Prod.mk false <$> prove_le_fin' n b a b' a'
#align tactic.norm_fin.prove_lt_ge_fin tactic.norm_fin.prove_lt_ge_fin

/-- Given `a b : fin n`, proves either `(n, tt, p)` where `p : a = b` or
`(n, ff, p)` where `p : a ≠ b`. -/
unsafe def prove_eq_ne_fin : expr → expr → tactic (expr × Bool × expr)
  | a, b =>
    eval_rel a b fun n a' b' na nb =>
      if na = nb then Prod.mk n <$> Prod.mk true <$> prove_eq_fin' n a b a' b'
      else
        if na < nb then do
          let p ← prove_lt_fin' n a b a' b'
          pure (n, ff, q(@ne_of_lt (Fin $(n)) _).mk_app [a, b, p])
        else do
          let p ← prove_lt_fin' n b a b' a'
          pure (n, ff, q(@ne_of_gt (Fin $(n)) _).mk_app [a, b, p])
#align tactic.norm_fin.prove_eq_ne_fin tactic.norm_fin.prove_eq_ne_fin

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      A `norm_num` extension that evaluates equalities and inequalities on the type `fin n`.

      ```
      example : (5 : fin 7) = fin.succ (fin.succ 3) := by norm_num
      ```
      -/
    @[ norm_num ]
    unsafe
  def
    eval_ineq
    : expr → tactic ( expr × expr )
    |
        q( $ ( a ) < $ ( b ) )
        =>
        do
          let ( n , lt , p ) ← prove_lt_ge_fin a b
            if
              lt
              then
              true_intro p
              else
              false_intro ( q( @ not_lt_of_ge ( Fin $ ( n ) ) _ ) . mk_app [ a , b , p ] )
      |
        q( $ ( a ) ≤ $ ( b ) )
        =>
        do
          let ( n , lt , p ) ← prove_lt_ge_fin b a
            if
              lt
              then
              false_intro ( q( @ not_le_of_gt ( Fin $ ( n ) ) _ ) . mk_app [ a , b , p ] )
              else
              true_intro p
      |
        q( $ ( a ) = $ ( b ) )
        =>
        do let ( n , Eq , p ) ← prove_eq_ne_fin a b if Eq then true_intro p else false_intro p
      | q( $ ( a ) > $ ( b ) ) => mk_app ` ` LT.lt [ b , a ] >>= eval_ineq
      | q( $ ( a ) ≥ $ ( b ) ) => mk_app ` ` LE.le [ b , a ] >>= eval_ineq
      |
        q( $ ( a ) ≠ $ ( b ) )
        =>
        do
          let ( n , Eq , p ) ← prove_eq_ne_fin a b
            if
              Eq
              then
              false_intro q( not_not_intro ( $ ( p ) : ( $ ( a ) : Fin $ ( n ) ) = $ ( b ) ) )
              else
              true_intro p
      | _ => failed
#align tactic.norm_fin.eval_ineq tactic.norm_fin.eval_ineq

/-- Evaluates `e : fin n` to a natural number less than `n`. Returns `none` if it is not a natural
number or greater than `n`. -/
unsafe def as_numeral (n e : expr) : eval_fin_m (Option ℕ) :=
  match e.toNat with
  | none => pure none
  | some Ne => do
    let (nn, _) ← eval_fin_m.eval_n n
    pure <| if Ne < nn then some Ne else none
#align tactic.norm_fin.as_numeral tactic.norm_fin.as_numeral

/-- Given `a : fin n`, returns `(b, ⊢ a = b)` where `b` is a normalized fin numeral. Fails if `a`
is already normalized. -/
unsafe def eval_fin_num (a : expr) : tactic (expr × expr) := do
  let n ← get_fin_type a
  eval_fin_m.run do
      as_numeral n a >>= fun o => guardb o
      let (a', pa) ← eval_fin a
      let (a', pa) ← reduce_fin' ff n a (a', pa) <|> pure (a', pa)
      let (nm + 1, _) ← eval_fin_m.eval_n n |
        failure
      let m' ← eval_fin_m.lift_ic fun ic => ic nm
      let n' ← eval_fin_m.lift_ic fun ic => ic (nm + 1)
      let (b, pb) ← mk_fin_numeral n' m' a'
      pure (b, q(@NormalizeFin.eq).mk_app [n, a, b, a', pa, pb])
#align tactic.norm_fin.eval_fin_num tactic.norm_fin.eval_fin_num

end NormFin

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Rewrites occurrences of fin expressions to normal form anywhere in the goal.
The `norm_num` extension will only rewrite fin expressions if they appear in equalities and
inequalities. For example if the goal is `P (2 + 2 : fin 3)` then `norm_num` will not do anything
but `norm_fin` will reduce the goal to `P 1`.

(The reason this is not part of `norm_num` is because evaluation of fin numerals uses a top down
evaluation strategy while `norm_num` works bottom up; also determining whether a normalization
will work is expensive, meaning that unrelated uses of `norm_num` would be slowed down with this
as a plugin.) -/
unsafe def norm_fin (hs : parse simp_arg_list) : tactic Unit :=
  try (simp_top_down tactic.norm_fin.eval_fin_num) >> try (norm_num hs (Loc.ns [none]))
#align tactic.interactive.norm_fin tactic.interactive.norm_fin

/-- Rewrites occurrences of fin expressions to normal form anywhere in the goal.
The `norm_num` extension will only rewrite fin expressions if they appear in equalities and
inequalities. For example if the goal is `P (2 + 2 : fin 3)` then `norm_num` will not do anything
but `norm_fin` will reduce the goal to `P 1`.

```lean
example : (5 : fin 7) = fin.succ (fin.succ 3) := by norm_num
example (P : fin 7 → Prop) (h : P 5) : P (fin.succ (fin.succ 3)) := by norm_fin; exact h
```
-/
add_tactic_doc
  { Name := "norm_fin"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.norm_fin]
    tags := ["arithmetic", "decision procedure"] }

end Interactive

end Tactic


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.subalgebra
import ring_theory.noetherian

/-!
# Lie submodules of a Lie algebra

In this file we define Lie submodules and Lie ideals, we construct the lattice structure on Lie
submodules and we use it to define various important operations, notably the Lie span of a subset
of a Lie module.

## Main definitions

  * `lie_submodule`
  * `lie_submodule.well_founded_of_noetherian`
  * `lie_submodule.lie_span`
  * `lie_submodule.map`
  * `lie_submodule.comap`
  * `lie_ideal`
  * `lie_ideal.map`
  * `lie_ideal.comap`

## Tags

lie algebra, lie submodule, lie ideal, lattice structure
-/

universes u v w w₁ w₂

section lie_submodule

variables (R : Type u) (L : Type v) (M : Type w)
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]

set_option old_structure_cmd true
/-- A Lie submodule of a Lie module is a submodule that is closed under the Lie bracket.
This is a sufficient condition for the subset itself to form a Lie module. -/
structure lie_submodule extends submodule R M :=
(lie_mem : ∀ {x : L} {m : M}, m ∈ carrier → ⁅x, m⁆ ∈ carrier)

attribute [nolint doc_blame] lie_submodule.to_submodule

namespace lie_submodule

variables {R L M} (N N' : lie_submodule R L M)

/-- The zero module is a Lie submodule of any Lie module. -/
instance : has_zero (lie_submodule R L M) :=
⟨{ lie_mem := λ x m h, by { rw ((submodule.mem_bot R).1 h), apply lie_zero, },
   ..(0 : submodule R M)}⟩

instance : inhabited (lie_submodule R L M) := ⟨0⟩

instance coe_submodule : has_coe (lie_submodule R L M) (submodule R M) := ⟨to_submodule⟩

@[norm_cast]
lemma coe_to_submodule : ((N : submodule R M) : set M) = N := rfl

instance has_mem : has_mem M (lie_submodule R L M) := ⟨λ x N, x ∈ (N : set M)⟩

@[simp] lemma mem_carrier {x : M} : x ∈ N.carrier ↔ x ∈ (N : set M) :=
iff.rfl

@[simp] lemma mem_coe_submodule {x : M} : x ∈ (N : submodule R M) ↔ x ∈ N := iff.rfl

lemma mem_coe {x : M} : x ∈ (N : set M) ↔ x ∈ N := iff.rfl

@[simp] lemma zero_mem : (0 : M) ∈ N := (N : submodule R M).zero_mem

@[simp] lemma coe_to_set_mk (S : set M) (h₁ h₂ h₃ h₄) :
  ((⟨S, h₁, h₂, h₃, h₄⟩ : lie_submodule R L M) : set M) = S := rfl

@[simp] lemma coe_to_submodule_mk (p : submodule R M) (h) :
  (({lie_mem := h, ..p} : lie_submodule R L M) : submodule R M) = p :=
by { cases p, refl, }

@[ext] lemma ext (h : ∀ m, m ∈ N ↔ m ∈ N') : N = N' :=
by { cases N, cases N', simp only [], ext m, exact h m, }

@[simp] lemma coe_to_submodule_eq_iff : (N : submodule R M) = (N' : submodule R M) ↔ N = N' :=
begin
  split; intros h,
  { ext, rw [← mem_coe_submodule, h], simp, },
  { rw h, },
end

/-- Copy of a lie_submodule with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (s : set M) (hs : s = ↑N) : lie_submodule R L M :=
{ carrier := s,
  zero_mem' := hs.symm ▸ N.zero_mem',
  add_mem'  := hs.symm ▸ N.add_mem',
  smul_mem' := hs.symm ▸ N.smul_mem',
  lie_mem   := hs.symm ▸ N.lie_mem, }

instance : lie_ring_module L N :=
{ bracket     := λ (x : L) (m : N), ⟨⁅x, m.val⁆, N.lie_mem m.property⟩,
  add_lie     := by { intros x y m, apply set_coe.ext, apply add_lie, },
  lie_add     := by { intros x m n, apply set_coe.ext, apply lie_add, },
  leibniz_lie := by { intros x y m, apply set_coe.ext, apply leibniz_lie, }, }

instance : lie_module R L N :=
{ lie_smul := by { intros t x y, apply set_coe.ext, apply lie_smul, },
  smul_lie := by { intros t x y, apply set_coe.ext, apply smul_lie, }, }

end lie_submodule

section lie_ideal

variables (L)

/-- An ideal of a Lie algebra is a Lie submodule of the Lie algebra as a Lie module over itself. -/
abbreviation lie_ideal := lie_submodule R L L

lemma lie_mem_right (I : lie_ideal R L) (x y : L) (h : y ∈ I) : ⁅x, y⁆ ∈ I := I.lie_mem h

lemma lie_mem_left (I : lie_ideal R L) (x y : L) (h : x ∈ I) : ⁅x, y⁆ ∈ I :=
 by { rw [←lie_skew, ←neg_lie], apply lie_mem_right, assumption, }

/-- An ideal of a Lie algebra is a Lie subalgebra. -/
def lie_ideal_subalgebra (I : lie_ideal R L) : lie_subalgebra R L :=
{ lie_mem' := by { intros x y hx hy, apply lie_mem_right, exact hy, },
  ..I.to_submodule, }

instance : has_coe (lie_ideal R L) (lie_subalgebra R L) := ⟨λ I, lie_ideal_subalgebra R L I⟩

@[norm_cast] lemma lie_ideal.coe_to_subalgebra (I : lie_ideal R L) :
  ((I : lie_subalgebra R L) : set L) = I := rfl

@[norm_cast] lemma lie_ideal.coe_to_lie_subalgebra_to_submodule (I : lie_ideal R L) :
  ((I : lie_subalgebra R L) : submodule R L) = I := rfl

end lie_ideal

variables {R M}

lemma submodule.exists_lie_submodule_coe_eq_iff (p : submodule R M) :
  (∃ (N : lie_submodule R L M), ↑N = p) ↔ ∀ (x : L) (m : M), m ∈ p → ⁅x, m⁆ ∈ p :=
begin
  split,
  { rintros ⟨N, rfl⟩, exact N.lie_mem, },
  { intros h, use { lie_mem := h, ..p }, exact lie_submodule.coe_to_submodule_mk p _, },
end

namespace lie_subalgebra

variables {L}

lemma exists_lie_ideal_coe_eq_iff (K : lie_subalgebra R L):
  (∃ (I : lie_ideal R L), ↑I = K) ↔ ∀ (x y : L), y ∈ K → ⁅x, y⁆ ∈ K :=
begin
  simp only [← coe_to_submodule_eq_iff, lie_ideal.coe_to_lie_subalgebra_to_submodule,
    submodule.exists_lie_submodule_coe_eq_iff L],
  exact iff.rfl,
end

lemma exists_nested_lie_ideal_coe_eq_iff {K K' : lie_subalgebra R L} (h : K ≤ K') :
  (∃ (I : lie_ideal R K'), ↑I = of_le h) ↔ ∀ (x y : L), x ∈ K' → y ∈ K → ⁅x, y⁆ ∈ K :=
begin
  simp only [exists_lie_ideal_coe_eq_iff, coe_bracket, mem_of_le],
  split,
  { intros h' x y hx hy, exact h' ⟨x, hx⟩ ⟨y, h hy⟩ hy, },
  { rintros h' ⟨x, hx⟩ ⟨y, hy⟩ hy', exact h' x y hx hy', },
end

end lie_subalgebra

end lie_submodule

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L)

section lattice_structure

open set

lemma coe_injective : function.injective (coe : lie_submodule R L M → set M) :=
λ N N' h, by { cases N, cases N', simp only, exact h, }

lemma coe_submodule_injective : function.injective (coe : lie_submodule R L M → submodule R M) :=
λ N N' h, by { ext, rw [← mem_coe_submodule, h], refl, }

instance : partial_order (lie_submodule R L M) :=
{ le := λ N N', ∀ ⦃x⦄, x ∈ N → x ∈ N', -- Overriding `le` like this gives a better defeq.
  ..partial_order.lift (coe : lie_submodule R L M → set M) coe_injective }

lemma le_def : N ≤ N' ↔ (N : set M) ⊆ N' := iff.rfl

@[simp, norm_cast] lemma coe_submodule_le_coe_submodule : (N : submodule R M) ≤ N' ↔ N ≤ N' :=
iff.rfl

instance : has_bot (lie_submodule R L M) := ⟨0⟩

@[simp] lemma bot_coe : ((⊥ : lie_submodule R L M) : set M) = {0} := rfl

@[simp] lemma bot_coe_submodule : ((⊥ : lie_submodule R L M) : submodule R M) = ⊥ := rfl

@[simp] lemma mem_bot (x : M) : x ∈ (⊥ : lie_submodule R L M) ↔ x = 0 := mem_singleton_iff

instance : has_top (lie_submodule R L M) :=
⟨{ lie_mem := λ x m h, mem_univ ⁅x, m⁆,
   ..(⊤ : submodule R M) }⟩

@[simp] lemma top_coe : ((⊤ : lie_submodule R L M) : set M) = univ := rfl

@[simp] lemma top_coe_submodule : ((⊤ : lie_submodule R L M) : submodule R M) = ⊤ := rfl

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : lie_submodule R L M) := mem_univ x

instance : has_inf (lie_submodule R L M) :=
⟨λ N N', { lie_mem := λ x m h, mem_inter (N.lie_mem h.1) (N'.lie_mem h.2),
            ..(N ⊓ N' : submodule R M) }⟩

instance : has_Inf (lie_submodule R L M) :=
⟨λ S, { lie_mem := λ x m h, by
        { simp only [submodule.mem_carrier, mem_Inter, submodule.Inf_coe, mem_set_of_eq,
            forall_apply_eq_imp_iff₂, exists_imp_distrib] at *,
          intros N hN, apply N.lie_mem (h N hN), },
        ..Inf {(s : submodule R M) | s ∈ S} }⟩

@[simp] theorem inf_coe : (↑(N ⊓ N') : set M) = N ∩ N' := rfl

@[simp] lemma Inf_coe_to_submodule (S : set (lie_submodule R L M)) :
  (↑(Inf S) : submodule R M) = Inf {(s : submodule R M) | s ∈ S} := rfl

@[simp] lemma Inf_coe (S : set (lie_submodule R L M)) : (↑(Inf S) : set M) = ⋂ s ∈ S, (s : set M) :=
begin
  rw [← lie_submodule.coe_to_submodule, Inf_coe_to_submodule, submodule.Inf_coe],
  ext m,
  simpa only [mem_Inter, mem_set_of_eq, forall_apply_eq_imp_iff₂, exists_imp_distrib],
end

lemma Inf_glb (S : set (lie_submodule R L M)) : is_glb S (Inf S) :=
begin
  have h : ∀ (N N' : lie_submodule R L M), (N : set M) ≤ N' ↔ N ≤ N', { intros, apply iff.rfl, },
  simp only [is_glb.of_image h, Inf_coe, is_glb_binfi],
end

/-- The set of Lie submodules of a Lie module form a complete lattice.

We provide explicit values for the fields `bot`, `top`, `inf` to get more convenient definitions
than we would otherwise obtain from `complete_lattice_of_Inf`.  -/
instance : complete_lattice (lie_submodule R L M) :=
{ bot          := ⊥,
  bot_le       := λ N _ h, by { rw mem_bot at h, rw h, exact N.zero_mem', },
  top          := ⊤,
  le_top       := λ _ _ _, trivial,
  inf          := (⊓),
  le_inf       := λ N₁ N₂ N₃ h₁₂ h₁₃ m hm, ⟨h₁₂ hm, h₁₃ hm⟩,
  inf_le_left  := λ _ _ _, and.left,
  inf_le_right := λ _ _ _, and.right,
  ..complete_lattice_of_Inf _ Inf_glb }

instance : add_comm_monoid (lie_submodule R L M) :=
{ add       := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero      := ⊥,
  zero_add  := λ _, bot_sup_eq,
  add_zero  := λ _, sup_bot_eq,
  add_comm  := λ _ _, sup_comm, }

@[simp] lemma add_eq_sup : N + N' = N ⊔ N' := rfl

@[norm_cast, simp] lemma sup_coe_to_submodule :
  (↑(N ⊔ N') : submodule R M) = (N : submodule R M) ⊔ (N' : submodule R M) :=
begin
  have aux : ∀ (x : L) m, m ∈ (N ⊔ N' : submodule R M) → ⁅x,m⁆ ∈ (N ⊔ N' : submodule R M),
  { simp only [submodule.mem_sup],
    rintro x m ⟨y, hy, z, hz, rfl⟩,
    refine ⟨⁅x, y⁆, N.lie_mem hy, ⁅x, z⁆, N'.lie_mem hz, (lie_add _ _ _).symm⟩ },
  refine le_antisymm (Inf_le ⟨{ lie_mem := aux, ..(N ⊔ N' : submodule R M) }, _⟩) _,
  { simp only [exists_prop, and_true, mem_set_of_eq, eq_self_iff_true, coe_to_submodule_mk,
      ← coe_submodule_le_coe_submodule, and_self, le_sup_left, le_sup_right] },
  { simp, },
end

@[norm_cast, simp] lemma inf_coe_to_submodule :
  (↑(N ⊓ N') : submodule R M) = (N : submodule R M) ⊓ (N' : submodule R M) := rfl

@[simp] lemma mem_inf (x : M) : x ∈ N ⊓ N' ↔ x ∈ N ∧ x ∈ N' :=
by rw [← mem_coe_submodule, ← mem_coe_submodule, ← mem_coe_submodule, inf_coe_to_submodule,
  submodule.mem_inf]

lemma mem_sup (x : M) : x ∈ N ⊔ N' ↔ ∃ (y ∈ N) (z ∈ N'), y + z = x :=
by { rw [← mem_coe_submodule, sup_coe_to_submodule, submodule.mem_sup], exact iff.rfl, }

lemma eq_bot_iff : N = ⊥ ↔ ∀ (m : M), m ∈ N → m = 0 :=
by { rw eq_bot_iff, exact iff.rfl, }

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_submodule R L ↥(⊥ : lie_submodule R L M)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, lie_submodule.mem_bot],
end

instance : is_modular_lattice (lie_submodule R L M) :=
{ sup_inf_le_assoc_of_le := λ N₁ N₂ N₃,
    by { simp only [← coe_submodule_le_coe_submodule, sup_coe_to_submodule, inf_coe_to_submodule],
         exact is_modular_lattice.sup_inf_le_assoc_of_le ↑N₂, }, }

variables (R L M)

lemma well_founded_of_noetherian [is_noetherian R M] :
  well_founded ((>) : lie_submodule R L M → lie_submodule R L M → Prop) :=
begin
  let f : ((>) : lie_submodule R L M → lie_submodule R L M → Prop) →r
          ((>) : submodule R M → submodule R M → Prop) :=
  { to_fun       := coe,
    map_rel' := λ N N' h, h, },
  apply f.well_founded, rw ← is_noetherian_iff_well_founded, apply_instance,
end

variables {R L M}

section inclusion_maps

/-- The inclusion of a Lie submodule into its ambient space is a morphism of Lie modules. -/
def incl : N →ₗ⁅R,L⁆ M :=
{ map_lie' := λ x m, rfl,
  ..submodule.subtype (N : submodule R M) }

@[simp] lemma incl_apply (m : N) : N.incl m = m := rfl

lemma incl_eq_val : (N.incl : N → M) = subtype.val := rfl

variables {N N'} (h : N ≤ N')

/-- Given two nested Lie submodules `N ⊆ N'`, the inclusion `N ↪ N'` is a morphism of Lie modules.-/
def hom_of_le : N →ₗ⁅R,L⁆ N' :=
{ map_lie' := λ x m, rfl,
  ..submodule.of_le h }

@[simp] lemma coe_hom_of_le (m : N) : (hom_of_le h m : M) = m := rfl

lemma hom_of_le_apply (m : N) : hom_of_le h m = ⟨m.1, h m.2⟩ := rfl

lemma hom_of_le_injective : function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

end inclusion_maps

section lie_span

variables (R L) (s : set M)
/-- The `lie_span` of a set `s ⊆ M` is the smallest Lie submodule of `M` that contains `s`. -/
def lie_span : lie_submodule R L M := Inf {N | s ⊆ N}

variables {R L s}

lemma mem_lie_span {x : M} : x ∈ lie_span R L s ↔ ∀ N : lie_submodule R L M, s ⊆ N → x ∈ N :=
by { change x ∈ (lie_span R L s : set M) ↔ _, erw Inf_coe, exact mem_bInter_iff, }

lemma subset_lie_span : s ⊆ lie_span R L s :=
by { intros m hm, erw mem_lie_span, intros N hN, exact hN hm, }

lemma submodule_span_le_lie_span : submodule.span R s ≤ lie_span R L s :=
by { rw submodule.span_le, apply subset_lie_span, }

lemma lie_span_le {N} : lie_span R L s ≤ N ↔ s ⊆ N :=
begin
  split,
  { exact subset.trans subset_lie_span, },
  { intros hs m hm, rw mem_lie_span at hm, exact hm _ hs, },
end

lemma lie_span_mono {t : set M} (h : s ⊆ t) : lie_span R L s ≤ lie_span R L t :=
by { rw lie_span_le, exact subset.trans h subset_lie_span, }

lemma lie_span_eq : lie_span R L (N : set M) = N :=
le_antisymm (lie_span_le.mpr rfl.subset) subset_lie_span

lemma coe_lie_span_submodule_eq_iff {p : submodule R M} :
  (lie_span R L (p : set M) : submodule R M) = p ↔ ∃ (N : lie_submodule R L M), ↑N = p :=
begin
  rw p.exists_lie_submodule_coe_eq_iff L, split; intros h,
  { intros x m hm, rw [← h, mem_coe_submodule], exact lie_mem _ (subset_lie_span hm), },
  { rw [← coe_to_submodule_mk p h, coe_to_submodule, coe_to_submodule_eq_iff, lie_span_eq], },
end

end lie_span

end lattice_structure

end lie_submodule

section lie_submodule_map_and_comap

variables {R : Type u} {L : Type v} {L' : Type w₂} {M : Type w} {M' : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group M'] [module R M'] [lie_ring_module L M'] [lie_module R L M']

namespace lie_submodule

variables (f : M →ₗ⁅R,L⁆ M') (N N₂ : lie_submodule R L M) (N' : lie_submodule R L M')

/-- A morphism of Lie modules `f : M → M'` pushes forward Lie submodules of `M` to Lie submodules
of `M'`. -/
def map : lie_submodule R L M' :=
{ lie_mem := λ x m' h, by
  { rcases h with ⟨m, hm, hfm⟩, use ⁅x, m⁆, split,
    { apply N.lie_mem hm, },
    { norm_cast at hfm, simp [hfm], }, },
  ..(N : submodule R M).map (f : M →ₗ[R] M') }

/-- A morphism of Lie modules `f : M → M'` pulls back Lie submodules of `M'` to Lie submodules of
`M`. -/
def comap : lie_submodule R L M :=
{ lie_mem := λ x m h, by { suffices : ⁅x, f m⁆ ∈ N', { simp [this], }, apply N'.lie_mem h, },
  ..(N' : submodule R M').comap (f : M →ₗ[R] M') }

variables {f N N₂ N'}

lemma map_le_iff_le_comap : map f N ≤ N' ↔ N ≤ comap f N' :=
set.image_subset_iff

variables (f)

lemma gc_map_comap : galois_connection (map f) (comap f) :=
λ N N', map_le_iff_le_comap

variables {f}

@[simp] lemma map_sup : (N ⊔ N₂).map f = N.map f ⊔ N₂.map f :=
(gc_map_comap f).l_sup

lemma mem_map (m' : M') : m' ∈ N.map f ↔ ∃ m, m ∈ N ∧ f m = m' :=
submodule.mem_map

end lie_submodule

namespace lie_ideal

variables (f : L →ₗ⁅R⁆ L') (I I₂ : lie_ideal R L) (J : lie_ideal R L')

@[simp] lemma top_coe_lie_subalgebra : ((⊤ : lie_ideal R L) : lie_subalgebra R L) = ⊤ := rfl

/-- A morphism of Lie algebras `f : L → L'` pushes forward Lie ideals of `L` to Lie ideals of `L'`.

Note that unlike `lie_submodule.map`, we must take the `lie_span` of the image. Mathematically
this is because although `f` makes `L'` into a Lie module over `L`, in general the `L` submodules of
`L'` are not the same as the ideals of `L'`. -/
def map : lie_ideal R L' := lie_submodule.lie_span R L' $ (I : submodule R L).map (f : L →ₗ[R] L')

/-- A morphism of Lie algebras `f : L → L'` pulls back Lie ideals of `L'` to Lie ideals of `L`.

Note that `f` makes `L'` into a Lie module over `L` (turning `f` into a morphism of Lie modules)
and so this is a special case of `lie_submodule.comap` but we do not exploit this fact. -/
def comap : lie_ideal R L :=
{ lie_mem := λ x y h, by { suffices : ⁅f x, f y⁆ ∈ J, { simp [this], }, apply J.lie_mem h, },
  ..(J : submodule R L').comap (f : L →ₗ[R] L') }

@[simp] lemma map_coe_submodule (h : ↑(map f I) = f '' I) :
  (map f I : submodule R L') = (I : submodule R L).map f :=
by { rw [set_like.ext'_iff, lie_submodule.coe_to_submodule, h, submodule.map_coe], refl, }

@[simp] lemma comap_coe_submodule : (comap f J : submodule R L) = (J : submodule R L').comap f :=
rfl

lemma map_le : map f I ≤ J ↔ f '' I ⊆ J := lie_submodule.lie_span_le

variables {f I I₂ J}

lemma mem_map {x : L} (hx : x ∈ I) : f x ∈ map f I :=
by { apply lie_submodule.subset_lie_span, use x, exact ⟨hx, rfl⟩, }

@[simp] lemma mem_comap {x : L} : x ∈ comap f J ↔ f x ∈ J := iff.rfl

lemma map_le_iff_le_comap : map f I ≤ J ↔ I ≤ comap f J :=
by { rw map_le, exact set.image_subset_iff, }

variables (f)

lemma gc_map_comap : galois_connection (map f) (comap f) :=
λ I I', map_le_iff_le_comap

variables {f}

@[simp] lemma map_sup : (I ⊔ I₂).map f = I.map f ⊔ I₂.map f :=
(gc_map_comap f).l_sup

lemma map_comap_le : map f (comap f J) ≤ J :=
by { rw map_le_iff_le_comap, apply le_refl _, }

/-- See also `lie_ideal.map_comap_eq`. -/
lemma comap_map_le : I ≤ comap f (map f I) :=
by { rw ← map_le_iff_le_comap, apply le_refl _, }

@[mono] lemma map_mono : monotone (map f) :=
λ I₁ I₂ h,
by { rw lie_submodule.le_def at h, apply lie_submodule.lie_span_mono (set.image_subset ⇑f h), }

@[mono] lemma comap_mono : monotone (comap f) :=
λ J₁ J₂ h, by { rw lie_submodule.le_def at h ⊢, exact set.preimage_mono h, }

lemma map_of_image (h : f '' I = J) : I.map f = J :=
begin
  apply le_antisymm,
  { erw [lie_submodule.lie_span_le, submodule.map_coe, h], },
  { rw [lie_submodule.le_def, ← h], exact lie_submodule.subset_lie_span, },
end

/-- Note that this is not a special case of `lie_submodule.subsingleton_of_bot`. Indeed, given
`I : lie_ideal R L`, in general the two lattices `lie_ideal R I` and `lie_submodule R L I` are
different (though the latter does naturally inject into the former).

In other words, in general, ideals of `I`, regarded as a Lie algebra in its own right, are not the
same as ideals of `L` contained in `I`. -/
-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_ideal R ↥(⊥ : lie_ideal R L)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, lie_submodule.mem_bot],
end

end lie_ideal

namespace lie_hom

variables (f : L →ₗ⁅R⁆ L') (I : lie_ideal R L) (J : lie_ideal R L')

/-- The kernel of a morphism of Lie algebras, as an ideal in the domain. -/
def ker : lie_ideal R L := lie_ideal.comap f ⊥

/-- The range of a morphism of Lie algebras as an ideal in the codomain. -/
def ideal_range : lie_ideal R L' := lie_submodule.lie_span R L' f.range

lemma ideal_range_eq_lie_span_range :
  f.ideal_range = lie_submodule.lie_span R L' f.range := rfl

lemma ideal_range_eq_map :
  f.ideal_range = lie_ideal.map f ⊤ :=
by { ext, simp only [ideal_range, range_eq_map], refl }

/-- The condition that the image of a morphism of Lie algebras is an ideal. -/
def is_ideal_morphism : Prop := (f.ideal_range : lie_subalgebra R L') = f.range

@[simp] lemma is_ideal_morphism_def :
  f.is_ideal_morphism ↔ (f.ideal_range : lie_subalgebra R L') = f.range := iff.rfl

lemma is_ideal_morphism_iff :
  f.is_ideal_morphism ↔ ∀ (x : L') (y : L), ∃ (z : L), ⁅x, f y⁆ = f z :=
begin
  simp only [is_ideal_morphism_def, ideal_range_eq_lie_span_range,
    ← lie_subalgebra.coe_to_submodule_eq_iff, ← f.range.coe_to_submodule,
    lie_ideal.coe_to_lie_subalgebra_to_submodule, lie_submodule.coe_lie_span_submodule_eq_iff,
    lie_subalgebra.mem_coe_submodule, mem_range, exists_imp_distrib,
    submodule.exists_lie_submodule_coe_eq_iff],
  split,
  { intros h x y, obtain ⟨z, hz⟩ := h x (f y) y rfl, use z, exact hz.symm, },
  { intros h x y z hz, obtain ⟨w, hw⟩ := h x z, use w, rw [← hw, hz], },
end

lemma range_subset_ideal_range : (f.range : set L') ⊆ f.ideal_range := lie_submodule.subset_lie_span

lemma map_le_ideal_range : I.map f ≤ f.ideal_range :=
begin
  rw f.ideal_range_eq_map,
  exact lie_ideal.map_mono le_top,
end

lemma ker_le_comap : f.ker ≤ J.comap f := lie_ideal.comap_mono bot_le

@[simp] lemma ker_coe_submodule : (ker f : submodule R L) = (f : L →ₗ[R] L').ker := rfl

@[simp] lemma mem_ker {x : L} : x ∈ ker f ↔ f x = 0 :=
show x ∈ (f.ker : submodule R L) ↔ _,
by simp only [ker_coe_submodule, linear_map.mem_ker, coe_to_linear_map]

lemma mem_ideal_range {x : L} : f x ∈ ideal_range f :=
begin
  rw ideal_range_eq_map,
  exact lie_ideal.mem_map (lie_submodule.mem_top x)
end

@[simp]

lemma le_ker_iff : I ≤ f.ker ↔ ∀ x, x ∈ I → f x = 0 :=
begin
  split; intros h x hx,
  { specialize h hx, rw mem_ker at h, exact h, },
  { rw mem_ker, apply h x hx, },
end

lemma ker_eq_bot : f.ker = ⊥ ↔ function.injective f :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, ker_coe_submodule, lie_submodule.bot_coe_submodule,
  linear_map.ker_eq_bot, coe_to_linear_map]

@[simp] lemma range_coe_submodule : (f.range : submodule R L') = (f : L →ₗ[R] L').range := rfl

lemma range_eq_top : f.range = ⊤ ↔ function.surjective f :=
begin
  rw [← lie_subalgebra.coe_to_submodule_eq_iff, range_coe_submodule,
    lie_subalgebra.top_coe_submodule],
  exact linear_map.range_eq_top,
end

@[simp] lemma ideal_range_eq_top_of_surjective (h : function.surjective f) : f.ideal_range = ⊤ :=
begin
  rw ← f.range_eq_top at h,
  rw [ideal_range_eq_lie_span_range, h, ← lie_subalgebra.coe_to_submodule,
    ← lie_submodule.coe_to_submodule_eq_iff, lie_submodule.top_coe_submodule,
      lie_subalgebra.top_coe_submodule, lie_submodule.coe_lie_span_submodule_eq_iff],
  use ⊤,
  exact lie_submodule.top_coe_submodule,
end

lemma is_ideal_morphism_of_surjective (h : function.surjective f) : f.is_ideal_morphism :=
by rw [is_ideal_morphism_def, f.ideal_range_eq_top_of_surjective h, f.range_eq_top.mpr h,
    lie_ideal.top_coe_lie_subalgebra]

end lie_hom

namespace lie_ideal

variables {f : L →ₗ⁅R⁆ L'} {I : lie_ideal R L} {J : lie_ideal R L'}

@[simp] lemma map_eq_bot_iff : I.map f = ⊥ ↔ I ≤ f.ker :=
by { rw ← le_bot_iff, exact lie_ideal.map_le_iff_le_comap }

lemma coe_map_of_surjective (h : function.surjective f) :
  (I.map f : submodule R L') = (I : submodule R L).map f :=
begin
  let J : lie_ideal R L' :=
  { lie_mem := λ x y hy,
    begin
      have hy' : ∃ (x : L), x ∈ I ∧ f x = y, { simpa [hy], },
      obtain ⟨z₂, hz₂, rfl⟩ := hy',
      obtain ⟨z₁, rfl⟩ := h x,
      simp only [lie_hom.coe_to_linear_map, set_like.mem_coe, set.mem_image,
        lie_submodule.mem_coe_submodule, submodule.mem_carrier, submodule.map_coe],
      use ⁅z₁, z₂⁆,
      exact ⟨I.lie_mem hz₂, f.map_lie z₁ z₂⟩,
    end,
    ..(I : submodule R L).map (f : L →ₗ[R] L'), },
  erw lie_submodule.coe_lie_span_submodule_eq_iff,
  use J,
  apply lie_submodule.coe_to_submodule_mk,
end

lemma mem_map_of_surjective {y : L'} (h₁ : function.surjective f) (h₂ : y ∈ I.map f) :
  ∃ (x : I), f x = y :=
begin
  rw [← lie_submodule.mem_coe_submodule, coe_map_of_surjective h₁, submodule.mem_map] at h₂,
  obtain ⟨x, hx, rfl⟩ := h₂,
  use ⟨x, hx⟩,
  refl,
end

lemma bot_of_map_eq_bot {I : lie_ideal R L} (h₁ : function.injective f) (h₂ : I.map f = ⊥) :
  I = ⊥ :=
begin
  rw ← f.ker_eq_bot at h₁, change comap f ⊥ = ⊥ at h₁,
  rw [eq_bot_iff, map_le_iff_le_comap, h₁] at h₂,
  rw eq_bot_iff, exact h₂,
end

/-- Given two nested Lie ideals `I₁ ⊆ I₂`, the inclusion `I₁ ↪ I₂` is a morphism of Lie algebras. -/
def hom_of_le {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) : I₁ →ₗ⁅R⁆ I₂ :=
{ map_lie' := λ x y, rfl,
  ..submodule.of_le h, }

@[simp] lemma coe_hom_of_le {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) (x : I₁) :
  (hom_of_le h x : L) = x := rfl

lemma hom_of_le_apply {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) (x : I₁) :
  hom_of_le h x = ⟨x.1, h x.2⟩ := rfl

lemma hom_of_le_injective {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) :
  function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

@[simp] lemma map_sup_ker_eq_map : lie_ideal.map f (I ⊔ f.ker) = lie_ideal.map f I :=
begin
  suffices : lie_ideal.map f (I ⊔ f.ker) ≤ lie_ideal.map f I,
  { exact le_antisymm this (lie_ideal.map_mono le_sup_left), },
  apply lie_submodule.lie_span_mono,
  rintros x ⟨y, hy₁, hy₂⟩, rw ← hy₂,
  erw lie_submodule.mem_sup at hy₁, obtain ⟨z₁, hz₁, z₂, hz₂, hy⟩ := hy₁, rw ← hy,
  rw [f.coe_to_linear_map, f.map_add, f.mem_ker.mp hz₂, add_zero], exact ⟨z₁, hz₁, rfl⟩,
end

@[simp] lemma map_comap_eq (h : f.is_ideal_morphism) : map f (comap f J) = f.ideal_range ⊓ J :=
begin
  apply le_antisymm,
  { rw le_inf_iff, exact ⟨f.map_le_ideal_range _, map_comap_le⟩, },
  { rw f.is_ideal_morphism_def at h,
    rw [lie_submodule.le_def, lie_submodule.inf_coe, ← coe_to_subalgebra, h],
    rintros y ⟨⟨x, h₁⟩, h₂⟩, rw ← h₁ at h₂ ⊢, exact mem_map h₂, },
end

@[simp] lemma comap_map_eq (h : ↑(map f I) = f '' I) : comap f (map f I) = I ⊔ f.ker :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, comap_coe_submodule, I.map_coe_submodule f h,
  lie_submodule.sup_coe_to_submodule, f.ker_coe_submodule, linear_map.comap_map_eq]

variables (f I J)

/-- Regarding an ideal `I` as a subalgebra, the inclusion map into its ambient space is a morphism
of Lie algebras. -/
def incl : I →ₗ⁅R⁆ L := (I : lie_subalgebra R L).incl

@[simp] lemma incl_range : I.incl.range = I := (I : lie_subalgebra R L).incl_range

@[simp] lemma incl_apply (x : I) : I.incl x = x := rfl

@[simp] lemma incl_coe : (I.incl : I →ₗ[R] L) = (I : submodule R L).subtype := rfl

@[simp] lemma comap_incl_self : comap I.incl I = ⊤ :=
by { rw ← lie_submodule.coe_to_submodule_eq_iff, exact submodule.comap_subtype_self _, }

@[simp] lemma ker_incl : I.incl.ker = ⊥ :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, I.incl.ker_coe_submodule,
  lie_submodule.bot_coe_submodule, incl_coe, submodule.ker_subtype]

@[simp] lemma incl_ideal_range : I.incl.ideal_range = I :=
begin
  rw [lie_hom.ideal_range_eq_lie_span_range, ← lie_subalgebra.coe_to_submodule,
    ← lie_submodule.coe_to_submodule_eq_iff, incl_range, coe_to_lie_subalgebra_to_submodule,
    lie_submodule.coe_lie_span_submodule_eq_iff],
  use I,
end

lemma incl_is_ideal_morphism : I.incl.is_ideal_morphism :=
begin
  rw [I.incl.is_ideal_morphism_def, incl_ideal_range],
  exact (I : lie_subalgebra R L).incl_range.symm,
end

end lie_ideal

end lie_submodule_map_and_comap

namespace lie_module_hom

variables {R : Type u} {L : Type v} {M : Type w} {N : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group N] [module R N] [lie_ring_module L N] [lie_module R L N]
variables (f : M →ₗ⁅R,L⁆ N)

/-- The range of a morphism of Lie modules `f : M → N` is a Lie submodule of `N`.
See Note [range copy pattern]. -/
def range : lie_submodule R L N :=
(lie_submodule.map f ⊤).copy (set.range f) set.image_univ.symm

@[simp] lemma coe_range : (f.range : set N) = set.range f := rfl

@[simp] lemma coe_submodule_range : (f.range : submodule R N) = (f : M →ₗ[R] N).range := rfl

@[simp] lemma mem_range (n : N) : n ∈ f.range ↔ ∃ m, f m = n :=
iff.rfl

lemma map_top : lie_submodule.map f ⊤ = f.range :=
by { ext, simp [lie_submodule.mem_map], }

end lie_module_hom

section top_equiv_self

variables {R : Type u} {L : Type v}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]

/-- The natural equivalence between the 'top' Lie subalgebra and the enclosing Lie algebra. -/
def lie_subalgebra.top_equiv_self : (⊤ : lie_subalgebra R L) ≃ₗ⁅R⁆ L :=
{ inv_fun   := λ x, ⟨x, set.mem_univ x⟩,
  left_inv  := λ x, by { ext, refl, },
  right_inv := λ x, rfl,
  ..(⊤ : lie_subalgebra R L).incl, }

@[simp] lemma lie_subalgebra.top_equiv_self_apply (x : (⊤ : lie_subalgebra R L)) :
  lie_subalgebra.top_equiv_self x = x := rfl

/-- The natural equivalence between the 'top' Lie ideal and the enclosing Lie algebra. -/
def lie_ideal.top_equiv_self : (⊤ : lie_ideal R L) ≃ₗ⁅R⁆ L :=
lie_subalgebra.top_equiv_self

@[simp] lemma lie_ideal.top_equiv_self_apply (x : (⊤ : lie_ideal R L)) :
  lie_ideal.top_equiv_self x = x := rfl

end top_equiv_self


import data.rat.basic
import data.rat.floor

namespace summation -- this file contains all the necessary definitions and theorems about summations required for the proof of the WZ theorem

-- an inductive definition of summation over a subset of ℤ
def summation (f : ℤ → ℚ) : ℕ → ℚ
  | 0 := f 0
  | (m+1) := f (-(m+1)) + summation m + f (m+1)

-- finite summations split
theorem summation_split {f g : ℤ → ℚ} {m : ℕ} : summation (λ (n : ℤ), f n + g n) m = summation f m + summation g m :=
begin
  induction m with d hd,
  refl,
  rw [summation, hd, summation, summation],
  ring,
end

-- finite differences split
theorem difference_split {f g : ℤ → ℚ} {m : ℕ} : summation (λ (n : ℤ), f n - g n) m = summation f m - summation g m :=
begin
  induction m with d hd,
  refl,
  rw [summation, hd, summation, summation],
  ring,
end

-- scaling the summands scales the sum by the same amount
theorem summation_scaling {f : ℤ → ℚ} {c : ℚ} {m : ℕ} : summation (λ n, c * f n) m = c * (summation f m) :=
begin
  induction m with d hd,
  refl,
  rw [summation, hd, summation],
  ring,
end

-- this is true when ∑_{n ∈ ℤ} f n = c
-- the summation is defined as a limit of finite sums
def equals_indefinite_sum (f : ℤ → ℚ) (c : ℚ) := ∀ (ε : ℚ), ε > (0 : ℚ) → ∃ (M : ℕ), ∀ (m : ℕ), m > M → (summation f m > c - ε) ∧ (summation f m < c + ε)

-- indefinite summations split
theorem indefinite_summation_split {f g : ℤ → ℚ} {c d : ℚ} (sf : equals_indefinite_sum f c) (sg : equals_indefinite_sum g d) : equals_indefinite_sum (λ (k : ℤ), f k + g k) (c + d) :=
begin
  rw equals_indefinite_sum at *,
  intro ε, intro hε_pos,

  have hεbytwo_pos : (ε / 2) > 0 := half_pos hε_pos,

  cases sf (ε / 2) hεbytwo_pos with Mf hsf,
  cases sg (ε / 2) hεbytwo_pos with Mg hsg,

  use Mf + Mg,

  intro m,
  intro hmlarge,

  rw summation_split at *,

  have hm_gt_Mf : m > Mf := by linarith,
  have hm_gt_Mg: m > Mg := by linarith,

  cases hsf m hm_gt_Mf with fbound_low fbound_high,
  cases hsg m hm_gt_Mg with gbound_low gbound_high,

  split,
  {
    linarith,
  },
  {
    linarith,
  }
end

-- indefinite differences split
theorem indefinite_difference_split {f g : ℤ → ℚ} {c d : ℚ} (sf : equals_indefinite_sum f c) (sg : equals_indefinite_sum g d) : equals_indefinite_sum (λ (k : ℤ), f k - g k) (c - d) :=
begin
  unfold equals_indefinite_sum,
  intro ε, intro hε_pos,

  have hεbytwo_pos : (ε / 2) > 0 := half_pos hε_pos,

  cases sf (ε / 2) hεbytwo_pos with Mf hsf,
  cases sg (ε / 2) hεbytwo_pos with Mg hsg,

  use Mf + Mg,

  intro m,
  intro hmlarge,

  rw difference_split at *,

  have hm_gt_Mf : m > Mf := by linarith,
  have hm_gt_Mg: m > Mg := by linarith,

  cases hsf m hm_gt_Mf with fbound_low fbound_high,
  cases hsg m hm_gt_Mg with gbound_low gbound_high,

  split,
  {
    linarith,
  },
  {
    linarith,
  }
end

-- scaling the summands scales the indefinite sum by the same amount
theorem indefinite_summation_scaling {f : ℤ → ℚ} {κ c : ℚ} : equals_indefinite_sum f c → equals_indefinite_sum (λ n, κ * (f n)) (κ * c) :=
begin
  unfold equals_indefinite_sum at *,
  intro hsumf,
  intro ε, intro hεpos,

  have h_trichotomy : κ < 0 ∨ κ = 0 ∨ κ > 0 := trichotomous κ 0,

  cases h_trichotomy,
  {
    let ε' := (-ε) / κ,
    have ε'pos : ε' > 0 := div_pos_of_neg_of_neg (neg_lt_zero.mpr hεpos) h_trichotomy,

    cases hsumf ε' ε'pos with M hM,

    use M,

    intro m, intro hmgtM,

    have h : ε = -κ * ε' := by {
      have g : ε' * κ = (-ε) := (eq_div_iff (ne_of_lt h_trichotomy)).mp rfl,
      linarith,
    },

    rw h at *,
    rw summation_scaling at *,
    split,
    {
      have hs : _ := (hM m hmgtM).2,
      have hm : _ := mul_lt_mul_of_neg_left hs h_trichotomy,
      ring_nf,
      rw mul_add at hm,
      linarith,
    },
    {
      have hs : _ := (hM m hmgtM).1,
      have hm : _ := mul_lt_mul_of_neg_left hs h_trichotomy,
      ring_nf,
      rw mul_sub at hm,
      linarith,
    }
  },
  cases h_trichotomy,
  {
    use 1,
    intro m, intro hmgt1,
    rw h_trichotomy at *,
    rw summation_scaling at *,
    simp,
    assumption,
  },
  {
    let ε' := ε / κ,
    have ε'pos : ε' > 0 := div_pos hεpos h_trichotomy,

    cases hsumf ε' ε'pos with M hM,

    use M,

    intro m, intro hmgtM,

    have h : ε = κ * ε' := by {
      rw mul_comm,
      apply eq.symm,
      exact (eq_div_iff (ne_of_gt h_trichotomy)).mp rfl,
    },

    rw h at *,
    rw summation_scaling at *,
    split,
    {
      have hs : _ := (hM m hmgtM).1,
      have hm : _ := (mul_lt_mul_left h_trichotomy).2 hs,
      rw mul_sub at hm,
      linarith,
    },
    {
      have hs : _ := (hM m hmgtM).2,
      have hm : _ := (mul_lt_mul_left h_trichotomy).2 hs,
      rw mul_add at hm,
      linarith,
    }
  }
end

-- If ∑ₖ (F (n+1) k - F n k) = 0, then ∑ₖ F n k = c  ↔  ∑ₖ F (n+1) k = c
lemma zero_diff_iff_equal (F : ℤ → ℤ → ℚ) (consecutive_difference_vanishes : ∀ (n : ℤ), equals_indefinite_sum (λ (k : ℤ), F (n+1) k - F n k) 0) (c : ℚ) : ∀ (n : ℤ), equals_indefinite_sum (F n) c ↔ equals_indefinite_sum (F (n+1)) c :=
begin
  intro n,
  split,
  {
    intro sumn,
    have h : _ := indefinite_summation_split sumn (consecutive_difference_vanishes n),
    rw add_zero at h,

    have func_equiv : (λ (k : ℤ), F n k + (F (n + 1) k - F n k)) = F (n+1) :=
    begin
      refine funext _,
      ring_nf,
      intro x,
      refl,
    end,

    rw func_equiv at h,
    exact h,
  },
  {
    intro sumns,
    have h : _ := indefinite_difference_split sumns (consecutive_difference_vanishes n),
    rw sub_zero at h,

    have func_equiv : (λ (k : ℤ), F (n+1) k - (F (n + 1) k - F n k)) = F n :=
    begin
      refine funext _,
      ring_nf,
      intro x,
      refl,
    end,

    rw func_equiv at h,
    exact h,
  }
end

end summation


/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import analysis.normed.group.hom
import analysis.normed_space.basic
import analysis.normed_space.linear_isometry
import algebra.star.unitary

/-!
# Normed star rings and algebras

A normed star monoid is a `star_add_monoid` endowed with a norm such that the star operation is
isometric.

A C⋆-ring is a normed star monoid that is also a ring and that verifies the stronger
condition `∥x⋆ * x∥ = ∥x∥^2` for all `x`.  If a C⋆-ring is also a star algebra, then it is a
C⋆-algebra.

To get a C⋆-algebra `E` over field `𝕜`, use
`[normed_field 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [cstar_ring E]
 [normed_algebra 𝕜 E] [star_module 𝕜 E]`.

## TODO

- Show that `∥x⋆ * x∥ = ∥x∥^2` is equivalent to `∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥`, which is used as the
  definition of C*-algebras in some sources (e.g. Wikipedia).

-/

open_locale topological_space

local postfix `⋆`:std.prec.max_plus := star

/-- A normed star ring is a star ring endowed with a norm such that `star` is isometric. -/
class normed_star_monoid (E : Type*) [normed_group E] [star_add_monoid E] :=
(norm_star : ∀ {x : E}, ∥x⋆∥ = ∥x∥)

export normed_star_monoid (norm_star)
attribute [simp] norm_star

/-- A C*-ring is a normed star ring that satifies the stronger condition `∥x⋆ * x∥ = ∥x∥^2`
for every `x`. -/
class cstar_ring (E : Type*) [normed_ring E] [star_ring E] :=
(norm_star_mul_self : ∀ {x : E}, ∥x⋆ * x∥ = ∥x∥ * ∥x∥)

noncomputable instance : cstar_ring ℝ :=
{ norm_star_mul_self := λ x, by simp only [star, id.def, normed_field.norm_mul] }

variables {𝕜 E α : Type*}

section normed_star_monoid
variables [normed_group E] [star_add_monoid E] [normed_star_monoid E]

/-- The `star` map in a normed star group is a normed group homomorphism. -/
def star_normed_group_hom : normed_group_hom E E :=
{ bound' := ⟨1, λ v, le_trans (norm_star.le) (one_mul _).symm.le⟩,
  .. star_add_equiv }

/-- The `star` map in a normed star group is an isometry -/
lemma star_isometry : isometry (star : E → E) :=
star_add_equiv.to_add_monoid_hom.isometry_of_norm (λ _, norm_star)

lemma continuous_star : continuous (star : E → E) := star_isometry.continuous

lemma continuous_on_star {s : set E} : continuous_on star s := continuous_star.continuous_on

lemma continuous_at_star {x : E} : continuous_at star x := continuous_star.continuous_at

lemma continuous_within_at_star {s : set E} {x : E} : continuous_within_at star s x :=
continuous_star.continuous_within_at

lemma tendsto_star (x : E) : filter.tendsto star (𝓝 x) (𝓝 x⋆) := continuous_star.tendsto x

lemma filter.tendsto.star {f : α → E} {l : filter α} {y : E} (h : filter.tendsto f l (𝓝 y)) :
  filter.tendsto (λ x, (f x)⋆) l (𝓝 y⋆) :=
(continuous_star.tendsto y).comp h

variables [topological_space α]

lemma continuous.star {f : α → E} (hf : continuous f) : continuous (λ y, star (f y)) :=
continuous_star.comp hf

lemma continuous_at.star {f : α → E} {x : α} (hf : continuous_at f x) :
  continuous_at (λ x, (f x)⋆) x :=
continuous_at_star.comp hf

lemma continuous_on.star {f : α → E} {s : set α} (hf : continuous_on f s) :
  continuous_on (λ x, (f x)⋆) s :=
continuous_star.comp_continuous_on hf

lemma continuous_within_at.star {f : α → E} {s : set α} {x : α}
  (hf : continuous_within_at f s x) : continuous_within_at (λ x, (f x)⋆) s x := hf.star

end normed_star_monoid

instance ring_hom_isometric.star_ring_end [normed_comm_ring E] [star_ring E]
   [normed_star_monoid E] : ring_hom_isometric (star_ring_end E) :=
⟨λ _, norm_star⟩

namespace cstar_ring
variables [normed_ring E] [star_ring E] [cstar_ring E]

/-- In a C*-ring, star preserves the norm. -/
@[priority 100] -- see Note [lower instance priority]
instance to_normed_star_monoid : normed_star_monoid E :=
⟨begin
  intro x,
  by_cases htriv : x = 0,
  { simp only [htriv, star_zero] },
  { have hnt : 0 < ∥x∥ := norm_pos_iff.mpr htriv,
    have hnt_star : 0 < ∥x⋆∥ :=
      norm_pos_iff.mpr ((add_equiv.map_ne_zero_iff star_add_equiv).mpr htriv),
    have h₁ := calc
      ∥x∥ * ∥x∥ = ∥x⋆ * x∥        : norm_star_mul_self.symm
            ... ≤ ∥x⋆∥ * ∥x∥      : norm_mul_le _ _,
    have h₂ := calc
      ∥x⋆∥ * ∥x⋆∥ = ∥x * x⋆∥      : by rw [←norm_star_mul_self, star_star]
             ... ≤ ∥x∥ * ∥x⋆∥     : norm_mul_le _ _,
    exact le_antisymm (le_of_mul_le_mul_right h₂ hnt_star) (le_of_mul_le_mul_right h₁ hnt) },
end⟩

lemma norm_self_mul_star {x : E} : ∥x * x⋆∥ = ∥x∥ * ∥x∥ :=
by { nth_rewrite 0 [←star_star x], simp only [norm_star_mul_self, norm_star] }

lemma norm_star_mul_self' {x : E} : ∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥ :=
by rw [norm_star_mul_self, norm_star]

@[simp] lemma norm_one [nontrivial E] : ∥(1 : E)∥ = 1 :=
begin
  have : 0 < ∥(1 : E)∥ := norm_pos_iff.mpr one_ne_zero,
  rw [←mul_left_inj' this.ne', ←norm_star_mul_self, mul_one, star_one, one_mul],
end

@[priority 100] -- see Note [lower instance priority]
instance [nontrivial E] : norm_one_class E := ⟨norm_one⟩

lemma norm_coe_unitary [nontrivial E] (U : unitary E) : ∥(U : E)∥ = 1 :=
begin
  rw [←sq_eq_sq (norm_nonneg _) zero_le_one, one_pow 2, sq, ←cstar_ring.norm_star_mul_self,
    unitary.coe_star_mul_self, cstar_ring.norm_one],
end

@[simp] lemma norm_of_mem_unitary [nontrivial E] {U : E} (hU : U ∈ unitary E) : ∥U∥ = 1 :=
norm_coe_unitary ⟨U, hU⟩

@[simp] lemma norm_coe_unitary_mul (U : unitary E) (A : E) : ∥(U : E) * A∥ = ∥A∥ :=
begin
  nontriviality E,
  refine le_antisymm _ _,
  { calc _  ≤ ∥(U : E)∥ * ∥A∥     : norm_mul_le _ _
        ... = ∥A∥                 : by rw [norm_coe_unitary, one_mul] },
  { calc _ = ∥(U : E)⋆ * U * A∥         : by rw [unitary.coe_star_mul_self U, one_mul]
       ... ≤ ∥(U : E)⋆∥ * ∥(U : E) * A∥ : by { rw [mul_assoc], exact norm_mul_le _ _ }
       ... = ∥(U : E) * A∥              : by rw [norm_star, norm_coe_unitary, one_mul] },
end

@[simp] lemma norm_unitary_smul (U : unitary E) (A : E) : ∥U • A∥ = ∥A∥ :=
norm_coe_unitary_mul U A

lemma norm_mem_unitary_mul {U : E} (A : E) (hU : U ∈ unitary E) : ∥U * A∥ = ∥A∥ :=
norm_coe_unitary_mul ⟨U, hU⟩ A

@[simp] lemma norm_mul_coe_unitary (A : E) (U : unitary E) : ∥A * U∥ = ∥A∥ :=
calc _ = ∥((U : E)⋆ * A⋆)⋆∥ : by simp only [star_star, star_mul]
  ...  = ∥(U : E)⋆ * A⋆∥    : by rw [norm_star]
  ...  = ∥A⋆∥               : norm_mem_unitary_mul (star A) (unitary.star_mem U.prop)
  ...  = ∥A∥                : norm_star

lemma norm_mul_mem_unitary (A : E) {U : E} (hU : U ∈ unitary E) : ∥A * U∥ = ∥A∥ :=
norm_mul_coe_unitary A ⟨U, hU⟩

end cstar_ring

section starₗᵢ

variables [comm_semiring 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [normed_star_monoid E]
variables [module 𝕜 E] [star_module 𝕜 E]

variables (𝕜)
/-- `star` bundled as a linear isometric equivalence -/
def starₗᵢ : E ≃ₗᵢ⋆[𝕜] E :=
{ map_smul' := star_smul,
  norm_map' := λ x, norm_star,
  .. star_add_equiv }

variables {𝕜}

@[simp] lemma coe_starₗᵢ : (starₗᵢ 𝕜 : E → E) = star := rfl

lemma starₗᵢ_apply {x : E} : starₗᵢ 𝕜 x = star x := rfl

end starₗᵢ