import formal_system data.set.finite init.data.list tactic.find
universe u

-- We introduce predicate logic.

namespace logic

open logic list tactic set

section basic
parameters {sort : Type u} [decidable_eq sort]

structure functional_symbol :=
    (name : string)
    (domain   : list sort)
    (codomain : sort)

instance deq_functional_symbol : decidable_eq functional_symbol :=
    begin
    intros f g,
    cases f with nf df cdf,
    cases g with ng dg cdg,
    simp,
    apply_instance
    end

def arity (f : functional_symbol) := length f.domain

def is_constant (f : functional_symbol) := arity f = 0

def tail_symbol (f : functional_symbol) : functional_symbol :=
{ name := f.name ++ "tail_",
  domain := tail f.domain,
  codomain := f.codomain}

structure relational_symbol :=
    (name : string)
    (sig : list sort)
    (sig_not_empty : sig ≠ [])

instance deq_relational_symbol : decidable_eq relational_symbol :=
    begin
    intros f g,
    cases f with nf df cdf,
    cases g with ng dg cdg,
    simp,
    apply_instance
    end

def rarity (r : relational_symbol) := length r.sig

structure signature :=
    (sf : set functional_symbol)
    (sr : set relational_symbol)
    (unique_name₁ : ∀ f₁ f₂ : functional_symbol, f₁ ∈ sf → f₂ ∈ sf → f₁.name ≠ f₂.name)
    (unique_name₂ : ∀ r₁ r₂ : relational_symbol, r₁ ∈ sr → r₂ ∈ sr → r₁.name ≠ r₂.name)
    (unique_name₃ : ∀ (r₁ : relational_symbol) (f₂ : functional_symbol), r₁ ∈ sr → f₂ ∈ sf → r₁.name ≠ f₂.name)
    -- support for partial application.
    -- (head_project : ∀ f ∈ sf, tail_symbol f ∈ sf)

section terms
parameter {σ : signature}

def in_use  (s : sort) :=
    (∃ f : functional_symbol, f ∈ σ.sf ∧ (s ∈ f.domain ∨ s = f.codomain))
    ∨ (∃ r : relational_symbol, r ∈ σ.sr ∧ s ∈ r.sig)

def nary (n : ℕ) := subtype {f : functional_symbol | f ∈ σ.sf ∧ arity f = n}

@[reducible]
def const := nary 0

def nrary (n : ℕ) := subtype {r : relational_symbol | r ∈ σ.sr ∧ rarity r = n}

instance deq_nary (n : ℕ) : decidable_eq (nary n) :=
begin
    intros f g,
    rcases f with ⟨f, fleft, fright⟩,
    rcases g with ⟨g, gleft, gright⟩,
    simp, apply_instance
end

instance deq_nrary (n : ℕ) : decidable_eq (nrary n) :=
begin
    intros f g,
    rcases f with ⟨f, fleft, fright⟩,
    rcases g with ⟨g, gleft, gright⟩,
    simp,
    apply_instance
end

inductive tvariable
| mk :  ∀ s : sort, in_use s → ℕ → tvariable

instance deq_tvariable : decidable_eq tvariable :=
begin
    intros x y,
    cases x; cases y; simp * at *,
    exact and.decidable
end

-- Note: for lack of support for nested inductive types,
-- you can't switch (fin n → uterm) for (vector uterm n) in the definition.
-- See: https://leanprover-community.github.io/archive/113488general/48465nestedinductivetype.html
-- This is the type of untyped terms of the signature, which is to say that they are terms but we don't
-- pay attention to their type, only the arity of the signature functions matters.
-- We can later introduce typed terms by type checking the untyped ones.
inductive uterm
| var : tvariable → uterm
| app  {n : ℕ} (f : nary n) (v : fin n → uterm) :  uterm

-- constant terms.
def const.uterm : const → uterm
| c := uterm.app c fin_zero_elim

def uterm.app_vector {n : ℕ} (f : nary n) (v : vector uterm n) : uterm :=
    uterm.app f (λ m, v.nth m)

-- syntatic equality between untyped terms.
instance deq_uterm : decidable_eq uterm :=
begin
    intros x y,
    -- ⟨f_y, fy_in_σ, fy_arity⟩
    rcases x with x_var | ⟨n_x, f_x, x_v⟩;
    rcases y with y_var | ⟨n_y, f_y, y_v⟩;
    simp * at *;
    try{apply_instance},
    suffices h : decidable (f_x == f_y ∧ x_v == y_v),
        from @and.decidable _ _ _ h,
    -- rcases f_x with ⟨f_x, _, _⟩,
    -- rcases f_y with ⟨f_y, _, _⟩,
    -- suffices h : decidable (x_v == y_v),
    --     from @and.decidable _ _ _ h,
    have h : decidable(f_x == f_y) := (
        if z : n_x = n_y
        then by {
            have teq : nary n_x = nary n_y,
                rw z,
            let f := cast teq f_x,
            have h : f == f_x := cast_heq teq f_x,
            have deq : decidable (f == f_y),
                cases logic.deq_nary n_y f f_y with c₁ c₂,
                    left, intro hyp,
                    have c := eq_of_heq hyp,
                    contradiction,
                right,
                exact heq_of_eq c₂,
            cases deq,
                left, intro hyp,
                have c := heq.trans h hyp,
                contradiction,
            right,
            replace h := heq.symm h,
            exact heq.trans h deq
        }
            -- exact @and.decidable _ _ deq h}
        else by {
            left, intro h,
            let f := λ (n : ℕ) (x : nary n), (@arity sort _)(subtype.val x) = n_x,
                work_on_goal 1 {exact σ},
            -- have c := type_eq_of_heq h,

            have c₁ : (f n_x f_x) := f_x.property.right,
            -- have c := heq.subst h c₁,
                -- @heq.elim (nary n_x) f_x f f_y h c₁,
            -- let f := cast c f_x,
            -- have z : f == f_x := cast_heq c f_x,
            -- apply heq.rec_on h,

            have c₂ := f_y.property.right,
            admit
        }
    ),

    -- have h : decidable(f_x == f_y),
        -- tidy,
        -- suffices h : decidable (x_v == y_v),
    admit,
    -- have c
    --     := (@subtype.decidable_eq functional_symbol
    --     (λ f, f ∈ σ.sf ∧ arity f = n_x) _),
    -- suffices h : decidable (x_v == y_v),
    --     from @and.decidable _ _ c h,

    -- have c : decidable (⟨f_x_val, _⟩ == ⟨f_y_val, _⟩),
    -- obtain c₁ | c₂ := nat.decidable_eq n_x n_y,
    --     -- left, rintro ⟨h₁, h₂⟩,
    --     suffices h : decidable (x_v == y_v),
    --         from @and.decidable _ _ _ h,
    --     have c : f_x.property.right == f_y.property.right
    --         := h₁,

            -- simp [h.left, eq.substr],
    --     refine @and.decidable _ _ _ _,
    -- have c₀ : decidable (f_x == f_y),
    --     cases h₀ : f_x with val prop,
    --     cases prop with p₁ p₂,
    --     cases nat.decidable_eq n_x n_y,
    --         work_on_goal 1 {rw h at p₂, apply_instance}

        -- exact (
        --     if hyp : n_x = n_y
        --     then by {
        --         rw hyp at p₂,
        --         replace f_x : nary n_y
        --         exact logic.deq_nary n_x
        --     }
        --     else admit
        -- ),
    -- have c : decidable (f_x == f_y ∧ x_v == y_v),
    --     admit,
    -- assumption
end

-- My original inclination was to write:
-- | (uterm.app f v) := uterm.app f (uterm.rewrite ∘ v)
-- But apparently lean doesn't reduce the ∘ that easily.

def uterm.rewrite : uterm → tvariable → uterm → uterm
| (uterm.var a) x t := if x = a then t else uterm.var a
| (uterm.app f v) x t :=
    let v₂ := λ m, uterm.rewrite (v m) x t in
    uterm.app f v₂

def uterm.variables : uterm → set tvariable
| (uterm.var a) := {a}
| (uterm.app f v) :=
    let v₂ := λ m, uterm.variables (v m) in
    ⋃ m, v₂ m

lemma uterm.nvar_rw (τ : uterm) (x : tvariable) (t : uterm) : x ∉ τ.variables → τ.rewrite x t = τ :=
begin
    intros h,
    induction τ;
    dunfold uterm.rewrite,
        have c : x ∉ {τ} := h,
        simp at c,
        simp [c],
    simp,
    ext m,
    apply τ_ih m,
    have c : x ∉ ⋃ m, (τ_v m).variables := h,
    simp at c,
    exact c m
 end

lemma uterm.nvar_rw₂ (τ : uterm) (x y : tvariable) (t : uterm) (h : y ∈ τ.variables) : x ≠ y → y ∈ (τ.rewrite x t).variables :=
begin
    intro hyp,
    induction τ;
    dunfold uterm.rewrite,
        replace h : y ∈ {τ} := h,
        simp at h,
        by_cases c : x = τ,
            rw ←h at c,
            contradiction,
        simp [c],
        dunfold uterm.variables,
        simp [h],
    dunfold uterm.variables,
    simp,
    have c : y ∈ ⋃ m, (τ_v m).variables := h,
    simp at c,
    cases c with i c,
    existsi i,
    apply τ_ih i,
    exact c
end

def list_variables : list uterm → set tvariable
| [] := ∅
| (hd :: tl) := hd.variables  ∪ list_variables tl

def list_rewrite : list uterm → tvariable → uterm → list uterm
| [] _ _:= ∅
| (hd :: tl) x t := (hd.rewrite x t) :: list_rewrite tl x t

def fn_rewrite {n : ℕ} (v : fin n → uterm) : tvariable → uterm → list uterm :=
    list_rewrite (of_fn v)

def vector_rewrite {n : ℕ} : vector uterm n → tvariable → uterm → vector uterm n
| v x t := ⟨list_rewrite v.val x t, by admit⟩

lemma list_variables_nvar_rw₂ (xs : list uterm) (x y : tvariable) (t : uterm) (h : y ∈ list_variables xs) : x ≠ y → y ∈ list_variables (list_rewrite xs x t) :=
begin
    intro hyp,
    induction xs with hd tl ih,
        replace h : false := h,
        contradiction,
    dunfold list_rewrite list_variables,
    cases h,
        left,
        exact hd.nvar_rw₂ x y t h hyp,
    right,
    exact ih h
end

def uterm.denotes (t : uterm) :=
    uterm.variables t = ∅

-- untyped atomic formulas.
inductive uatomic_formula
| relational {n : ℕ} (r : nrary n) (v : fin n → uterm) : uatomic_formula
| equation (t₁ t₂ : uterm) : uatomic_formula
| true : uatomic_formula
| false : uatomic_formula

def uatomic_formula.variables : uatomic_formula → set tvariable
| (uatomic_formula.relational r v) := list_variables (of_fn v)
| (uatomic_formula.equation t₁ t₂) := t₁.variables  ∪ t₂.variables
| _ := ∅

def uatomic_formula.rewrite : uatomic_formula → tvariable → uterm → uatomic_formula
| (uatomic_formula.relational r v) x t :=
    let v₂ := λ m, (v m).rewrite x t in
    uatomic_formula.relational r v₂
| (uatomic_formula.equation t₁ t₂) x t :=
    let t₃ := t₁.rewrite x t,
        t₄ := t₂.rewrite x t
    in uatomic_formula.equation t₃ t₄
| φ _ _ := φ

lemma uatomic_formula.nvar_rw₂ (φ : uatomic_formula) (x y : tvariable) (t : uterm) (h : y ∈ φ.variables) : x ≠ y → y ∈ (φ.rewrite x t).variables :=
begin
    intro hyp,
    induction φ;
    -- any_goals {
    --     replace h : y ∈ list_variables (of_fn φ_v) := h,
    --     have c := list_variables_nvar_rw₂ (of_fn φ_v) x y t h hyp,
    -- };
    dunfold uatomic_formula.rewrite;
    simp * at *,
        dunfold uatomic_formula.variables,
        replace h : y ∈ list_variables (of_fn φ_v) := h,
        have c := list_variables_nvar_rw₂ (of_fn φ_v) x y t h hyp,
        cases c₀ : (of_fn φ_v),
            rw c₀ at h,
            simp [list_variables] at h,
            contradiction,
    -- rw c₀ at c,
    -- revert c,
    -- dunfold list_rewrite list_variables,
    -- rintro (c₁ | c₂),
    convert c,
    ext m, constructor; intro h₂,

end

-- untyped formulas.
-- Not requiring quantified variables to be free.
inductive uformula
| atomic : uatomic_formula → uformula
| for_all :  tvariable → uformula → uformula
| exist   : tvariable → uformula → uformula
| and : uformula → uformula → uformula
| or : uformula → uformula → uformula
| if_then : uformula → uformula → uformula

def uformula.is_atomic : uformula → Prop
| (uformula.atomic _) := true
| _ := false

instance uformula.lift : has_lift uatomic_formula uformula := ⟨uformula.atomic⟩

def uformula.is_molecular : uformula → Prop
| (uformula.atomic _)    :=  true
| (uformula.and φ ψ)     :=  φ.is_molecular ∧ ψ.is_molecular
| (uformula.or φ ψ)      :=  φ.is_molecular ∧ ψ.is_molecular
| (uformula.if_then φ ψ) :=  φ.is_molecular ∧ ψ.is_molecular
| _ := false

-- free variables
def uformula.free : uformula → set tvariable
| (uformula.atomic φ)    := φ.variables
| (uformula.for_all x φ) := φ.free - {x}
| (uformula.exist x φ)   := φ.free - {x}
| (uformula.and φ ψ)     := φ.free ∪ ψ.free
| (uformula.or φ ψ)      := φ.free ∪ ψ.free
| (uformula.if_then φ ψ) := φ.free ∪ ψ.free

-- open and closed formulas.
def uformula.closed : uformula → Prop
| φ := φ.free = ∅

def uformula.open : uformula → Prop
| φ := ¬ φ.closed

-- instance dec_free (φ : uformula) : decidable_pred φ.free :=
-- begin
--     intros x,
--     cases φ,

--     -- try{apply_instance},
-- end

def uformula.variables : uformula → set tvariable
| (uformula.atomic φ)    := φ.variables
| (uformula.for_all x φ) := φ.free ∪ {x}
| (uformula.exist x φ)   := φ.free ∪ {x}
| (uformula.and φ ψ)     := φ.variables ∪ ψ.variables
| (uformula.or φ ψ)      := φ.variables ∪ ψ.variables
| (uformula.if_then φ ψ) := φ.variables ∪ ψ.variables

-- def uformula.bound_variables : uformula → set tvariable
-- | (logic.uformula.atomic φ) := ∅
-- | (logic.uformula.for_all x φ) := uformula.bound_variables φ ∪ {x}
-- | (logic.uformula.exist x φ) := uformula.bound_variables φ ∪ {x}
-- | (logic.uformula.and φ ψ) :=
--     uformula.bound_variables φ
--     ∩ uformula.bound_variables ψ
-- | (logic.uformula.or φ ψ) :=
--     uformula.bound_variables φ
--     ∩ uformula.bound_variables ψ
-- | (logic.uformula.if_then φ ψ) :=
--     uformula.bound_variables φ
--     ∩ uformula.bound_variables ψ

def uformula.rewrite : uformula → tvariable → uterm → uformula
| (uformula.atomic φ) x t    := ↑(φ.rewrite x t)
| (uformula.for_all y φ) x t :=
    let ψ := if y = x then φ else φ.rewrite x t in
    uformula.for_all y ψ
| (uformula.exist y φ) x t :=
    let ψ := if y = x then φ else φ.rewrite x t in
    uformula.exist y ψ
| (uformula.and φ ψ) x t     := uformula.and (φ.rewrite x t) (ψ.rewrite x t)
| (uformula.or φ ψ)  x t     := uformula.or (φ.rewrite x t) (ψ.rewrite x t)
| (uformula.if_then φ ψ) x t := uformula.if_then (φ.rewrite x t) (ψ.rewrite x t)

-- lemma uformula.rw_free : ∀ (φ : uformula) (x : tvariable) (t : uterm), φ.free - {x} ⊆ (φ.rewrite x t).free :=
-- begin
--  intros φ x t y h,
--  cases h with h₁ h₂,
--  simp at *,
--  cases φ;
--  dunfold uformula.rewrite,
--  replace h₁ : y ∈ (uatomic_formula.relational φ_r φ_v).variables := h₁,

-- --  dunfold uformula.free at h₁,
-- --  dunfold uterm.rewrite,

-- --  dunfold ,
-- end

-- -- rewriting a bound variable is the same as keeping the formula as it is.
-- lemma uformula.rw_bnd (x : tvariable) (t : uterm) (φ : uformula) : x ∉ φ.free → φ.rewrite x t = φ :=
-- begin
--     intros h,
--     induction φ,
--     replace h : x ∉ φ.variables := h,
-- end

lemma uformula.rw_bnd (x y : tvariable) (t : uterm) (φ : uformula) (h : y ∈ φ.free) : x ≠ y → y ∈ (φ.rewrite x t).free :=
begin
    intro hyp,
    induction φ;
    dunfold uformula.rewrite;
    simp * at *,
        focus {
            -- exact list_variables_nvar_rw₂,
            -- dunfold uformula.lift,
            -- admit
            -- dunfold uformula.free,
        },
    all_goals {cases h with h₁ h₂},
    any_goals {
        by_cases c : φ_a = x;
        simp [c];
        dunfold uformula.free,
        rw c at h₂,
        exact ⟨h₁, h₂⟩,
    simp [h₂],
    apply φ_ih,
    exact h₁,
    },
    all_goals {
        dunfold uformula.free,
        {left, apply φ_ih_a, assumption} <|>
        {right, apply φ_ih_a_1, assumption},
    }
end

-- checks whether variables bound by a quantifier are free in the rest of the expression.
def uformula.well_formed : uformula → Prop
| (uformula.atomic φ)    := true
| (uformula.for_all x φ) := x ∈ φ.free ∧ φ.well_formed
| (uformula.exist x φ)   := x ∈ φ.free ∧ φ.well_formed
| (uformula.and φ ψ)     := φ.well_formed ∧ ψ.well_formed
| (uformula.or φ ψ)      := φ.well_formed ∧ ψ.well_formed
| (uformula.if_then φ ψ) := φ.well_formed ∧ ψ.well_formed

-- The type of untyped well formed formulas.
def uwff := subtype uformula.well_formed

-- utilities
def uwff.and : uwff → uwff → uwff
| ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨uformula.and φ ψ,
                      by constructor; assumption⟩

def uwff.or : uwff → uwff → uwff
| ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨uformula.or φ ψ,
                      by constructor; assumption⟩

def uwff.if_then : uwff → uwff → uwff
| ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨uformula.if_then φ ψ,
                      by constructor; assumption⟩

instance uwff.has_exp : has_exp uwff := ⟨uwff.if_then⟩

instance uwff.lift : has_lift uatomic_formula uwff := ⟨λ φ, ⟨↑φ, true.intro⟩⟩

def uwff.true : uwff := ↑uatomic_formula.true
def uwff.false : uwff := ↑uatomic_formula.false

def uwff.free (φ : uwff) := φ.val.free

def uwff.for_all (x : tvariable) (φ : uwff) (h : x ∈ φ.free) : uwff :=
    ⟨uformula.for_all x φ.val, ⟨h, φ.property⟩⟩

def uwff.exist (x : tvariable) (φ : uwff) (h : x ∈ φ.free) : uwff :=
    ⟨uformula.exist x φ.val, ⟨h, φ.property⟩⟩

def uwff.rewrite (x : tvariable) (t : uterm) : uwff → uwff
| ⟨φ, h⟩ :=
⟨φ.rewrite x t,
begin
    -- induction φ.rewrite x t,
    -- exact true.intro,
    induction φ,
    exact true.intro,
    all_goals {dunfold uformula.rewrite},
        by_cases c : φ_a = x;
        simp [c],
        rw ←c,
        exact h,
        refine and.intro _ (φ_ih h.2),
        cases φ_a_1,
        try{dunfold uformula.rewrite},

    -- cases h with h₁ h₂,
    -- have c := φ_ih h₂,
    -- obtain c₁ | c₂ : decidable (φ_a = x),
    --     by apply_instance,
    -- dunfold uformula.rewrite,
    -- -- constructor,
    -- simp [c₁],
    -- constructor,
    -- dunfold uformula.free,
    -- cases
      --  logic.deq_tvariable,
    -- constructor;

    -- cases h₂ : ψ;
    -- constructor;

    -- any_goals {assumption},

end⟩

-- deductive consequence of uwffs: Γ ⊢ φ
inductive uwff.entails : set uwff → uwff → Prop
| reflexive (Γ : set uwff) (φ : uwff)(h : φ ∈ Γ) : uwff.entails Γ φ
| transitivity (Γ Δ : set uwff) (φ : uwff)
               (h₁ : ∀ ψ ∈ Δ, uwff.entails Γ ψ)
               (h₂ : uwff.entails Δ φ) :  uwff.entails Γ φ
| and_intro (φ ψ : uwff) (Γ : set uwff)
            (h₁ : uwff.entails Γ φ)
            (h₂ : uwff.entails Γ ψ)
             : uwff.entails Γ (uwff.and φ ψ)
| and_elim_left (φ ψ : uwff) (Γ : set uwff)
            (h : uwff.entails Γ (uwff.and φ ψ))
             : uwff.entails Γ φ
| and_elim_right (φ ψ : uwff) (Γ : set uwff)
            (h : uwff.entails Γ (uwff.and φ ψ))
             : uwff.entails Γ ψ
| or_intro_left
            (φ ψ : uwff) (Γ : set uwff)
            (h : uwff.entails Γ φ)
             : uwff.entails Γ (uwff.or φ ψ)
| or_intro_right
            (φ ψ : uwff) (Γ : set uwff)
            (h : uwff.entails Γ ψ)
             : uwff.entails Γ (uwff.or φ ψ)
| or_elim
            (φ ψ δ : uwff) (Γ : set uwff)
            (h₁ : uwff.entails Γ (uwff.or φ ψ))
            (h₂ : uwff.entails (Γ ∪ {φ}) δ)
            (h₃ : uwff.entails (Γ ∪ {ψ}) δ)
             : uwff.entails Γ δ
| modus_ponens
            (φ ψ : uwff) (Γ : set uwff)
            (h₁ : uwff.entails Γ (φ ⇒ ψ))
            (h₂ : uwff.entails Γ φ)
             : uwff.entails Γ ψ
| intro
            (φ ψ : uwff) (Γ : set uwff)
            (h : uwff.entails (Γ ∪ {φ}) ψ)
             : uwff.entails Γ (φ ⇒ ψ)
| true_intro
            (Γ : set uwff)
             : uwff.entails Γ uwff.true
| for_all_elim
            (Γ : set uwff) (φ : uwff)
            (x : tvariable)
            (free : x ∈ φ.free)
            (h : uwff.entails Γ (uwff.for_all x φ free))
            (t : uterm)
             : uwff.entails Γ uwff.true

end terms
end basic
end logic


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .identity
import .congruence

namespace universal
universe u
variables {τ : Type} {σ : Type u} {sig : signature τ σ}

definition valid {ι : Type} (ax : ι → identity sig) {dom : list τ} {{cod}} : term sig dom cod → term sig dom cod → Prop :=
λ t₁ t₂, ∀ (alg : algebra.{u u} sig), (∀ i, alg.satisfies (ax i)) → (∀ (val : Π (i : index dom), alg.sort i.val), alg.eval t₁ val = alg.eval t₂ val)

namespace valid
variables {ι : Type} {ax : ι → identity sig} {dom : list τ}

theorem refl {{cod}} (t : term sig dom cod) : valid ax t t := λ _ _ _, rfl

theorem rfl {cod} {t : term sig dom cod} : valid ax t t := refl t

theorem ax (i) (sub : substitution sig (ax i).dom dom) :
valid ax (sub.apply (ax i).lhs) (sub.apply (ax i).rhs) :=
begin
intros alg h val,
rw sub.eval,
rw sub.eval,
apply h,
end

theorem app (f : σ) {ts us : Π (i : sig.index f), term sig dom i.val} :
(∀ (i : sig.index f), valid ax (ts i) (us i)) → valid ax (term.func f ts) (term.func f us) :=
begin
intros hs alg h val,
rw alg.eval_func,
rw alg.eval_func,
congr,
funext i,
apply hs i alg,
exact h,
end

theorem symm {{cod}} {{x y : term sig dom cod}} : valid ax x y → valid ax y x :=
λ hxy alg h val, eq.symm $ hxy alg h val

theorem trans {{cod}} {{x y z : term sig dom cod}} : valid ax x y → valid ax y z → valid ax x z :=
λ hxy hyz alg h val, eq.trans (hxy alg h val) (hyz alg h val)

theorem eucl {{cod}} {{x y z : term sig dom cod}} : valid ax x y → valid ax x z → valid ax y z :=
λ hxy hxz, trans hxy.symm hxz

variables (sig dom ax)

definition to_congruence : congruence (term_algebra sig dom) :=
{ r := valid ax
, refl := valid.refl
, eucl := valid.eucl
, func := valid.app
}

end valid

definition models {ι : Type} (ax : ι → identity sig) (e : identity sig) : Prop := valid ax e.lhs e.rhs

theorem models.elim {ι : Type} {ax : ι → identity sig} {e : identity sig} :
models ax e → ∀ (alg : algebra sig), (∀ i, alg.satisfies (ax i)) → alg.satisfies e :=
λ Hm alg Ha val,
let h := alg.eval_hom val in
let img := homomorphism.image h in
let ival : Π (i : index e.dom), img.sort i.val := λ i, quotient.mk h.kernel (term.proj i) in
have hival : h.image_map = img.eval_hom ival,
begin
apply homomorphism.ext,
introv,
induction x with _ f ts IH,
reflexivity,
have : term.func f ts = (term_algebra sig e.dom).func f ts, from rfl,
rw this,
rw ← homomorphism.func,
rw ← homomorphism.func,
congr,
funext,
exact IH i,
end,
have Ia : ∀ i, img.satisfies (ax i),
begin
intro i,
apply algebra.satisfies_of_injective_hom (homomorphism.image_inc (alg.eval_hom val)),
exact Ha i,
end,
calc h.map e.cod e.lhs
= (homomorphism.comp h.image_inc h.image_map).map e.cod e.lhs : by rw h.image_factorization ...
= h.image_inc.map e.cod (h.image_map.map e.cod e.lhs) : rfl ...
= h.image_inc.map e.cod ((img.eval_hom ival).map e.cod e.lhs) : by rw hival ...
= h.image_inc.map e.cod (algebra.eval _ e.lhs ival) : rfl ...
= h.image_inc.map e.cod (algebra.eval _ e.rhs ival) : by rw Hm img Ia ival ...
= h.image_inc.map e.cod ((img.eval_hom ival).map e.cod e.rhs) : rfl ...
= h.image_inc.map e.cod (h.image_map.map e.cod e.rhs) : by rw hival ...
= (homomorphism.comp h.image_inc h.image_map).map e.cod e.rhs : rfl ...
= h.map e.cod e.rhs : by rw h.image_factorization

end universal


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Kalle Kytölä
-/

import analysis.normed.field.basic
import linear_algebra.sesquilinear_form
import topology.algebra.module.weak_dual

/-!
# Polar set

In this file we define the polar set. There are different notions of the polar, we will define the
*absolute polar*. The advantage over the real polar is that we can define the absolute polar for
any bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`, where `𝕜` is a normed commutative ring and
`E` and `F` are modules over `𝕜`.

## Main definitions

* `linear_map.polar`: The polar of a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`.

## Main statements

* `linear_map.polar_eq_Inter`: The polar as an intersection.
* `linear_map.subset_bipolar`: The polar is a subset of the bipolar.
* `linear_map.polar_weak_closed`: The polar is closed in the weak topology induced by `B.flip`.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

polar
-/

variables {𝕜 E F : Type*}
open_locale topology

namespace linear_map

section normed_ring

variables [normed_comm_ring 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

/-- The (absolute) polar of `s : set E` is given by the set of all `y : F` such that `‖B x y‖ ≤ 1`
for all `x ∈ s`.-/
def polar (s : set E) : set F :=
  {y : F | ∀ x ∈ s, ‖B x y‖ ≤ 1 }

lemma polar_mem_iff (s : set E) (y : F) :
  y ∈ B.polar s ↔ ∀ x ∈ s, ‖B x y‖ ≤ 1 := iff.rfl

lemma polar_mem (s : set E) (y : F) (hy : y ∈ B.polar s) :
  ∀ x ∈ s, ‖B x y‖ ≤ 1 := hy

@[simp] lemma zero_mem_polar (s : set E) :
  (0 : F) ∈ B.polar s :=
λ _ _, by simp only [map_zero, norm_zero, zero_le_one]

lemma polar_eq_Inter {s : set E} :
  B.polar s = ⋂ x ∈ s, {y : F | ‖B x y‖ ≤ 1} :=
by { ext, simp only [polar_mem_iff, set.mem_Inter, set.mem_set_of_eq] }

/-- The map `B.polar : set E → set F` forms an order-reversing Galois connection with
`B.flip.polar : set F → set E`. We use `order_dual.to_dual` and `order_dual.of_dual` to express
that `polar` is order-reversing. -/
lemma polar_gc : galois_connection (order_dual.to_dual ∘ B.polar)
  (B.flip.polar ∘ order_dual.of_dual) :=
λ s t, ⟨λ h _ hx _ hy, h hy _ hx, λ h _ hx _ hy, h hy _ hx⟩

@[simp] lemma polar_Union {ι} {s : ι → set E} : B.polar (⋃ i, s i) = ⋂ i, B.polar (s i) :=
B.polar_gc.l_supr

@[simp] lemma polar_union {s t : set E} : B.polar (s ∪ t) = B.polar s ∩ B.polar t :=
B.polar_gc.l_sup

lemma polar_antitone : antitone (B.polar : set E → set F) := B.polar_gc.monotone_l

@[simp] lemma polar_empty : B.polar ∅ = set.univ := B.polar_gc.l_bot

@[simp]

lemma subset_bipolar (s : set E) : s ⊆ B.flip.polar (B.polar s) :=
λ x hx y hy, by { rw B.flip_apply, exact hy x hx }

@[simp] lemma tripolar_eq_polar (s : set E) : B.polar (B.flip.polar (B.polar s)) = B.polar s :=
begin
  refine (B.polar_antitone (B.subset_bipolar s)).antisymm _,
  convert subset_bipolar B.flip (B.polar s),
  exact B.flip_flip.symm,
end

/-- The polar set is closed in the weak topology induced by `B.flip`. -/
lemma polar_weak_closed (s : set E) :
  is_closed[weak_bilin.topological_space B.flip] (B.polar s) :=
begin
  rw polar_eq_Inter,
  refine is_closed_Inter (λ x, is_closed_Inter (λ _, _)),
  exact is_closed_le (weak_bilin.eval_continuous B.flip x).norm continuous_const,
end

end normed_ring

section nontrivially_normed_field

variables [nontrivially_normed_field 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

lemma polar_univ (h : separating_right B) :
  B.polar set.univ = {(0 : F)} :=
begin
  rw set.eq_singleton_iff_unique_mem,
  refine ⟨by simp only [zero_mem_polar], λ y hy, h _ (λ x, _)⟩,
  refine norm_le_zero_iff.mp (le_of_forall_le_of_dense $ λ ε hε, _),
  rcases normed_field.exists_norm_lt 𝕜 hε with ⟨c, hc, hcε⟩,
  calc ‖B x y‖ = ‖c‖ * ‖B (c⁻¹ • x) y‖ :
    by rw [B.map_smul, linear_map.smul_apply, algebra.id.smul_eq_mul, norm_mul, norm_inv,
      mul_inv_cancel_left₀ hc.ne']
  ... ≤ ε * 1 : mul_le_mul hcε.le (hy _ trivial) (norm_nonneg _) hε.le
  ... = ε : mul_one _
end

end nontrivially_normed_field

end linear_map


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

! This file was ported from Lean 3 source module ring_theory.chain_of_divisors
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.IsPrimePow
import Mathbin.Algebra.Squarefree
import Mathbin.Order.Hom.Bounded
import Mathbin.Algebra.GcdMonoid.Basic

/-!

# Chains of divisors

The results in this file show that in the monoid `associates M` of a `unique_factorization_monoid`
`M`, an element `a` is an n-th prime power iff its set of divisors is a strictly increasing chain
of length `n + 1`, meaning that we can find a strictly increasing bijection between `fin (n + 1)`
and the set of factors of `a`.

## Main results
- `divisor_chain.exists_chain_of_prime_pow` : existence of a chain for prime powers.
- `divisor_chain.is_prime_pow_of_has_chain` : elements that have a chain are prime powers.
- `multiplicity_prime_eq_multiplicity_image_by_factor_order_iso` : if there is a
  monotone bijection `d` between the set of factors of `a : associates M` and the set of factors of
  `b : associates N` then for any prime `p ∣ a`, `multiplicity p a = multiplicity (d p) b`.
- `multiplicity_eq_multiplicity_factor_dvd_iso_of_mem_normalized_factor` : if there is a bijection
  between the set of factors of `a : M` and `b : N` then for any prime `p ∣ a`,
  `multiplicity p a = multiplicity (d p) b`

## Todo
- Create a structure for chains of divisors.
- Simplify proof of `mem_normalized_factors_factor_dvd_iso_of_mem_normalized_factors` using
  `mem_normalized_factors_factor_order_iso_of_mem_normalized_factors` or vice versa.

-/

variable {M : Type _} [CancelCommMonoidWithZero M]

theorem Associates.isAtom_iff {p : Associates M} (h₁ : p ≠ 0) : IsAtom p ↔ Irreducible p :=
  ⟨fun hp =>
    ⟨by simpa only [Associates.isUnit_iff_eq_one] using hp.1, fun a b h =>
      (hp.le_iff.mp ⟨_, h⟩).casesOn (fun ha => Or.inl (a.isUnit_iff_eq_one.mpr ha)) fun ha =>
        Or.inr
          (show IsUnit b by
            rw [ha] at h
            apply isUnit_of_associated_mul (show Associated (p * b) p by conv_rhs => rw [h]) h₁)⟩,
    fun hp =>
    ⟨by simpa only [Associates.isUnit_iff_eq_one, Associates.bot_eq_one] using hp.1,
      fun b ⟨⟨a, hab⟩, hb⟩ =>
      (hp.isUnit_or_isUnit hab).casesOn
        (fun hb => show b = ⊥ by rwa [Associates.isUnit_iff_eq_one, ← Associates.bot_eq_one] at hb)
        fun ha =>
        absurd
          (show p ∣ b from
            ⟨(ha.Unit⁻¹ : Units _), by
              simp [hab] <;> rw [mul_assoc] <;> rw [IsUnit.mul_val_inv ha] <;> rw [mul_one]⟩)
          hb⟩⟩
#align associates.is_atom_iff Associates.isAtom_iff

open UniqueFactorizationMonoid multiplicity Irreducible Associates

namespace DivisorChain

theorem exists_chain_of_prime_pow {p : Associates M} {n : ℕ} (hn : n ≠ 0) (hp : Prime p) :
    ∃ c : Fin (n + 1) → Associates M,
      c 1 = p ∧ StrictMono c ∧ ∀ {r : Associates M}, r ≤ p ^ n ↔ ∃ i, r = c i :=
  by
  refine' ⟨fun i => p ^ (i : ℕ), _, fun n m h => _, fun y => ⟨fun h => _, _⟩⟩
  · rw [Fin.val_one', Nat.mod_eq_of_lt, pow_one]
    exact Nat.lt_succ_of_le (nat.one_le_iff_ne_zero.mpr hn)
  ·
    exact
      associates.dvd_not_unit_iff_lt.mp
        ⟨pow_ne_zero n hp.ne_zero, p ^ (m - n : ℕ),
          not_isUnit_of_not_isUnit_dvd hp.not_unit (dvd_pow dvd_rfl (Nat.sub_pos_of_lt h).ne'),
          (pow_mul_pow_sub p h.le).symm⟩
  · obtain ⟨i, i_le, hi⟩ := (dvd_prime_pow hp n).1 h
    rw [associated_iff_eq] at hi
    exact ⟨⟨i, Nat.lt_succ_of_le i_le⟩, hi⟩
  · rintro ⟨i, rfl⟩
    exact ⟨p ^ (n - i : ℕ), (pow_mul_pow_sub p (nat.succ_le_succ_iff.mp i.2)).symm⟩
#align divisor_chain.exists_chain_of_prime_pow DivisorChain.exists_chain_of_prime_pow

theorem element_of_chain_not_isUnit_of_index_ne_zero {n : ℕ} {i : Fin (n + 1)} (i_pos : i ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c) : ¬IsUnit (c i) :=
  DvdNotUnit.not_unit
    (Associates.dvdNotUnit_iff_lt.2
      (h₁ <| show (0 : Fin (n + 1)) < i from i.pos_iff_ne_zero.mpr i_pos))
#align divisor_chain.element_of_chain_not_is_unit_of_index_ne_zero DivisorChain.element_of_chain_not_isUnit_of_index_ne_zero

theorem first_of_chain_isUnit {q : Associates M} {n : ℕ} {c : Fin (n + 1) → Associates M}
    (h₁ : StrictMono c) (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i) : IsUnit (c 0) :=
  by
  obtain ⟨i, hr⟩ := h₂.mp Associates.one_le
  rw [Associates.isUnit_iff_eq_one, ← Associates.le_one_iff, hr]
  exact h₁.monotone (Fin.zero_le i)
#align divisor_chain.first_of_chain_is_unit DivisorChain.first_of_chain_isUnit

/-- The second element of a chain is irreducible. -/
theorem second_of_chain_is_irreducible {q : Associates M} {n : ℕ} (hn : n ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c) (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i)
    (hq : q ≠ 0) : Irreducible (c 1) := by
  cases n; · contradiction
  refine' (Associates.isAtom_iff (ne_zero_of_dvd_ne_zero hq (h₂.2 ⟨1, rfl⟩))).mp ⟨_, fun b hb => _⟩
  · exact ne_bot_of_gt (h₁ (show (0 : Fin (n + 2)) < 1 from Fin.one_pos))
  obtain ⟨⟨i, hi⟩, rfl⟩ := h₂.1 (hb.le.trans (h₂.2 ⟨1, rfl⟩))
  cases i
  · exact (Associates.isUnit_iff_eq_one _).mp (first_of_chain_is_unit h₁ @h₂)
  · simpa [Fin.lt_iff_val_lt_val] using h₁.lt_iff_lt.mp hb
#align divisor_chain.second_of_chain_is_irreducible DivisorChain.second_of_chain_is_irreducible

theorem eq_second_of_chain_of_prime_dvd {p q r : Associates M} {n : ℕ} (hn : n ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c)
    (h₂ : ∀ {r : Associates M}, r ≤ q ↔ ∃ i, r = c i) (hp : Prime p) (hr : r ∣ q) (hp' : p ∣ r) :
    p = c 1 := by
  cases n
  · contradiction
  obtain ⟨i, rfl⟩ := h₂.1 (dvd_trans hp' hr)
  refine' congr_arg c (eq_of_ge_of_not_gt _ fun hi => _)
  · rw [Fin.le_iff_val_le_val, Fin.val_one, Nat.succ_le_iff, ← Fin.val_zero (n.succ + 1), ←
      Fin.lt_iff_val_lt_val, Fin.pos_iff_ne_zero]
    rintro rfl
    exact hp.not_unit (first_of_chain_is_unit h₁ @h₂)
  obtain rfl | ⟨j, rfl⟩ := i.eq_zero_or_eq_succ
  · cases hi
  refine'
    not_irreducible_of_not_unit_dvdNotUnit
      (DvdNotUnit.not_unit
        (Associates.dvdNotUnit_iff_lt.2 (h₁ (show (0 : Fin (n + 2)) < j from _))))
      _ hp.irreducible
  · simpa [Fin.succ_lt_succ_iff, Fin.lt_iff_val_lt_val] using hi
  · refine' Associates.dvdNotUnit_iff_lt.2 (h₁ _)
    simpa only [Fin.coe_eq_castSucc] using Fin.lt_succ
#align divisor_chain.eq_second_of_chain_of_prime_dvd DivisorChain.eq_second_of_chain_of_prime_dvd

theorem card_subset_divisors_le_length_of_chain {q : Associates M} {n : ℕ}
    {c : Fin (n + 1) → Associates M} (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i) {m : Finset (Associates M)}
    (hm : ∀ r, r ∈ m → r ≤ q) : m.card ≤ n + 1 := by
  classical
    have mem_image : ∀ r : Associates M, r ≤ q → r ∈ finset.univ.image c :=
      by
      intro r hr
      obtain ⟨i, hi⟩ := h₂.1 hr
      exact Finset.mem_image.2 ⟨i, Finset.mem_univ _, hi.symm⟩
    rw [← Finset.card_fin (n + 1)]
    exact (Finset.card_le_of_subset fun x hx => mem_image x <| hm x hx).trans Finset.card_image_le
#align divisor_chain.card_subset_divisors_le_length_of_chain DivisorChain.card_subset_divisors_le_length_of_chain

variable [UniqueFactorizationMonoid M]

theorem element_of_chain_eq_pow_second_of_chain {q r : Associates M} {n : ℕ} (hn : n ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c) (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i)
    (hr : r ∣ q) (hq : q ≠ 0) : ∃ i : Fin (n + 1), r = c 1 ^ (i : ℕ) := by
  classical
    let i := (normalized_factors r).card
    have hi : normalized_factors r = Multiset.replicate i (c 1) :=
      by
      apply Multiset.eq_replicate_of_mem
      intro b hb
      refine'
        eq_second_of_chain_of_prime_dvd hn h₁ (fun r' => h₂) (prime_of_normalized_factor b hb) hr
          (dvd_of_mem_normalized_factors hb)
    have H : r = c 1 ^ i :=
      by
      have := UniqueFactorizationMonoid.normalizedFactors_prod (ne_zero_of_dvd_ne_zero hq hr)
      rw [associated_iff_eq, hi, Multiset.prod_replicate] at this
      rw [this]
    refine' ⟨⟨i, _⟩, H⟩
    have : (finset.univ.image fun m : Fin (i + 1) => c 1 ^ (m : ℕ)).card = i + 1 :=
      by
      conv_rhs => rw [← Finset.card_fin (i + 1)]
      cases n
      · contradiction
      rw [Finset.card_image_iff]
      refine' Set.injOn_of_injective (fun m m' h => Fin.ext _) _
      refine'
        pow_injective_of_not_unit (element_of_chain_not_is_unit_of_index_ne_zero (by simp) h₁) _ h
      exact Irreducible.ne_zero (second_of_chain_is_irreducible hn h₁ (@h₂) hq)
    suffices H' : ∀ r ∈ finset.univ.image fun m : Fin (i + 1) => c 1 ^ (m : ℕ), r ≤ q
    · simp only [← Nat.succ_le_iff, Nat.succ_eq_add_one, ← this]
      apply card_subset_divisors_le_length_of_chain (@h₂) H'
    simp only [Finset.mem_image]
    rintro r ⟨a, ha, rfl⟩
    refine' dvd_trans _ hr
    use c 1 ^ (i - a)
    rw [pow_mul_pow_sub (c 1)]
    · exact H
    · exact nat.succ_le_succ_iff.mp a.2
#align divisor_chain.element_of_chain_eq_pow_second_of_chain DivisorChain.element_of_chain_eq_pow_second_of_chain

theorem eq_pow_second_of_chain_of_has_chain {q : Associates M} {n : ℕ} (hn : n ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c)
    (h₂ : ∀ {r : Associates M}, r ≤ q ↔ ∃ i, r = c i) (hq : q ≠ 0) : q = c 1 ^ n := by
  classical
    obtain ⟨i, hi'⟩ := element_of_chain_eq_pow_second_of_chain hn h₁ (fun r => h₂) (dvd_refl q) hq
    convert hi'
    refine' (Nat.lt_succ_iff.1 i.prop).antisymm' (Nat.le_of_succ_le_succ _)
    calc
      n + 1 = (Finset.univ : Finset (Fin (n + 1))).card := (Finset.card_fin _).symm
      _ = (finset.univ.image c).card := (finset.card_image_iff.mpr (h₁.injective.inj_on _)).symm
      _ ≤ (finset.univ.image fun m : Fin (i + 1) => c 1 ^ (m : ℕ)).card :=
        (Finset.card_le_of_subset _)
      _ ≤ (Finset.univ : Finset (Fin (i + 1))).card := Finset.card_image_le
      _ = i + 1 := Finset.card_fin _

    intro r hr
    obtain ⟨j, -, rfl⟩ := Finset.mem_image.1 hr
    have := h₂.2 ⟨j, rfl⟩
    rw [hi'] at this
    obtain ⟨u, hu, hu'⟩ := (dvd_prime_pow (show Prime (c 1) from _) i).1 this
    refine' finset.mem_image.mpr ⟨u, Finset.mem_univ _, _⟩
    · rw [associated_iff_eq] at hu'
      rw [Fin.val_cast_of_lt (Nat.lt_succ_of_le hu), hu']
    · rw [← irreducible_iff_prime]
      exact second_of_chain_is_irreducible hn h₁ (@h₂) hq
#align divisor_chain.eq_pow_second_of_chain_of_has_chain DivisorChain.eq_pow_second_of_chain_of_has_chain

theorem isPrimePow_of_has_chain {q : Associates M} {n : ℕ} (hn : n ≠ 0)
    {c : Fin (n + 1) → Associates M} (h₁ : StrictMono c)
    (h₂ : ∀ {r : Associates M}, r ≤ q ↔ ∃ i, r = c i) (hq : q ≠ 0) : IsPrimePow q :=
  ⟨c 1, n, irreducible_iff_prime.mp (second_of_chain_is_irreducible hn h₁ (@h₂) hq),
    zero_lt_iff.mpr hn, (eq_pow_second_of_chain_of_has_chain hn h₁ (@h₂) hq).symm⟩
#align divisor_chain.is_prime_pow_of_has_chain DivisorChain.isPrimePow_of_has_chain

end DivisorChain

variable {N : Type _} [CancelCommMonoidWithZero N]

theorem factor_orderIso_map_one_eq_bot {m : Associates M} {n : Associates N}
    (d : { l : Associates M // l ≤ m } ≃o { l : Associates N // l ≤ n }) :
    (d ⟨1, one_dvd m⟩ : Associates N) = 1 :=
  by
  letI : OrderBot { l : Associates M // l ≤ m } := Subtype.orderBot bot_le
  letI : OrderBot { l : Associates N // l ≤ n } := Subtype.orderBot bot_le
  simp [← Associates.bot_eq_one]
#align factor_order_iso_map_one_eq_bot factor_orderIso_map_one_eq_bot

theorem coe_factor_orderIso_map_eq_one_iff {m u : Associates M} {n : Associates N} (hu' : u ≤ m)
    (d : Set.Iic m ≃o Set.Iic n) : (d ⟨u, hu'⟩ : Associates N) = 1 ↔ u = 1 :=
  ⟨fun hu =>
    by
    rw [show u = ↑(d.symm ⟨↑(d ⟨u, hu'⟩), (d ⟨u, hu'⟩).Prop⟩) by
        simp only [Subtype.coe_eta, OrderIso.symm_apply_apply, Subtype.coe_mk]]
    convert factor_orderIso_map_one_eq_bot d.symm, fun hu =>
    by
    simp_rw [hu]
    convert factor_orderIso_map_one_eq_bot d⟩
#align coe_factor_order_iso_map_eq_one_iff coe_factor_orderIso_map_eq_one_iff

section

variable [UniqueFactorizationMonoid N] [UniqueFactorizationMonoid M]

open DivisorChain

theorem pow_image_of_prime_by_factor_orderIso_dvd [DecidableEq (Associates M)] {m p : Associates M}
    {n : Associates N} (hn : n ≠ 0) (hp : p ∈ normalizedFactors m) (d : Set.Iic m ≃o Set.Iic n)
    {s : ℕ} (hs' : p ^ s ≤ m) : (d ⟨p, dvd_of_mem_normalizedFactors hp⟩ : Associates N) ^ s ≤ n :=
  by
  by_cases hs : s = 0
  · simp [hs]
  suffices (d ⟨p, dvd_of_mem_normalized_factors hp⟩ : Associates N) ^ s = ↑(d ⟨p ^ s, hs'⟩)
    by
    rw [this]
    apply Subtype.prop (d ⟨p ^ s, hs'⟩)
  obtain ⟨c₁, rfl, hc₁', hc₁''⟩ := exists_chain_of_prime_pow hs (prime_of_normalized_factor p hp)
  set c₂ : Fin (s + 1) → Associates N := fun t => d ⟨c₁ t, le_trans (hc₁''.2 ⟨t, by simp⟩) hs'⟩
  have c₂.def : ∀ t, c₂ t = d ⟨c₁ t, _⟩ := fun t => rfl
  refine' (congr_arg (· ^ s) (c₂.def 1).symm).trans _
  refine'
    (eq_pow_second_of_chain_of_has_chain hs (fun t u h => _) (fun r => ⟨fun hr => _, _⟩) _).symm
  · rw [c₂.def, c₂.def, Subtype.coe_lt_coe, d.lt_iff_lt, Subtype.mk_lt_mk, hc₁'.lt_iff_lt]
    exact h
  · have : r ≤ n := hr.trans (d ⟨c₁ 1 ^ s, _⟩).2
    suffices d.symm ⟨r, this⟩ ≤ ⟨c₁ 1 ^ s, hs'⟩
      by
      obtain ⟨i, hi⟩ := hc₁''.1 this
      use i
      simp only [c₂.def, ← hi, d.apply_symm_apply, Subtype.coe_eta, Subtype.coe_mk]
    conv_rhs => rw [← d.symm_apply_apply ⟨c₁ 1 ^ s, hs'⟩]
    rw [d.symm.le_iff_le]
    simpa only [← Subtype.coe_le_coe, Subtype.coe_mk] using hr
  · rintro ⟨i, hr⟩
    rw [hr, c₂.def, Subtype.coe_le_coe, d.le_iff_le]
    simpa [Subtype.mk_le_mk] using hc₁''.2 ⟨i, rfl⟩
  exact ne_zero_of_dvd_ne_zero hn (Subtype.prop (d ⟨c₁ 1 ^ s, _⟩))
#align pow_image_of_prime_by_factor_order_iso_dvd pow_image_of_prime_by_factor_orderIso_dvd

theorem map_prime_of_factor_orderIso [DecidableEq (Associates M)] {m p : Associates M}
    {n : Associates N} (hn : n ≠ 0) (hp : p ∈ normalizedFactors m) (d : Set.Iic m ≃o Set.Iic n) :
    Prime (d ⟨p, dvd_of_mem_normalizedFactors hp⟩ : Associates N) :=
  by
  rw [← irreducible_iff_prime]
  refine' (Associates.isAtom_iff <| ne_zero_of_dvd_ne_zero hn (d ⟨p, _⟩).Prop).mp ⟨_, fun b hb => _⟩
  · rw [Ne.def, ← Associates.isUnit_iff_eq_bot, Associates.isUnit_iff_eq_one,
      coe_factor_orderIso_map_eq_one_iff _ d]
    rintro rfl
    exact (prime_of_normalized_factor 1 hp).not_unit isUnit_one
  · obtain ⟨x, hx⟩ :=
      d.surjective ⟨b, le_trans (le_of_lt hb) (d ⟨p, dvd_of_mem_normalized_factors hp⟩).Prop⟩
    rw [← Subtype.coe_mk b _, Subtype.coe_lt_coe, ← hx] at hb
    letI : OrderBot { l : Associates M // l ≤ m } := Subtype.orderBot bot_le
    letI : OrderBot { l : Associates N // l ≤ n } := Subtype.orderBot bot_le
    suffices x = ⊥ by
      rw [this, OrderIso.map_bot d] at hx
      refine' (Subtype.mk_eq_bot_iff _ _).mp hx.symm
      exact bot_le
    obtain ⟨a, ha⟩ := x
    rw [Subtype.mk_eq_bot_iff]
    ·
      exact
        ((Associates.isAtom_iff <| Prime.ne_zero <| prime_of_normalized_factor p hp).mpr <|
              irreducible_of_normalized_factor p hp).right
          a (subtype.mk_lt_mk.mp <| d.lt_iff_lt.mp hb)
    exact bot_le
#align map_prime_of_factor_order_iso map_prime_of_factor_orderIso

theorem mem_normalizedFactors_factor_orderIso_of_mem_normalizedFactors [DecidableEq (Associates M)]
    [DecidableEq (Associates N)] {m p : Associates M} {n : Associates N} (hn : n ≠ 0)
    (hp : p ∈ normalizedFactors m) (d : Set.Iic m ≃o Set.Iic n) :
    ↑(d ⟨p, dvd_of_mem_normalizedFactors hp⟩) ∈ normalizedFactors n :=
  by
  obtain ⟨q, hq, hq'⟩ :=
    exists_mem_normalized_factors_of_dvd hn (map_prime_of_factor_orderIso hn hp d).Irreducible
      (d ⟨p, dvd_of_mem_normalized_factors hp⟩).Prop
  rw [associated_iff_eq] at hq'
  rwa [hq']
#align mem_normalized_factors_factor_order_iso_of_mem_normalized_factors mem_normalizedFactors_factor_orderIso_of_mem_normalizedFactors

variable [DecidableRel ((· ∣ ·) : M → M → Prop)] [DecidableRel ((· ∣ ·) : N → N → Prop)]

theorem multiplicity_prime_le_multiplicity_image_by_factor_orderIso [DecidableEq (Associates M)]
    {m p : Associates M} {n : Associates N} (hp : p ∈ normalizedFactors m)
    (d : Set.Iic m ≃o Set.Iic n) :
    multiplicity p m ≤ multiplicity (↑(d ⟨p, dvd_of_mem_normalizedFactors hp⟩)) n :=
  by
  by_cases hn : n = 0
  · simp [hn]
  by_cases hm : m = 0
  · simpa [hm] using hp
  rw [←
    PartENat.natCast_get
      (finite_iff_dom.1 <| finite_prime_left (prime_of_normalized_factor p hp) hm),
    ← pow_dvd_iff_le_multiplicity]
  exact pow_image_of_prime_by_factor_orderIso_dvd hn hp d (pow_multiplicity_dvd _)
#align multiplicity_prime_le_multiplicity_image_by_factor_order_iso multiplicity_prime_le_multiplicity_image_by_factor_orderIso

theorem multiplicity_prime_eq_multiplicity_image_by_factor_orderIso [DecidableEq (Associates M)]
    {m p : Associates M} {n : Associates N} (hn : n ≠ 0) (hp : p ∈ normalizedFactors m)
    (d : Set.Iic m ≃o Set.Iic n) :
    multiplicity p m = multiplicity (↑(d ⟨p, dvd_of_mem_normalizedFactors hp⟩)) n :=
  by
  refine' le_antisymm (multiplicity_prime_le_multiplicity_image_by_factor_orderIso hp d) _
  suffices
    multiplicity (↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩)) n ≤
      multiplicity (↑(d.symm (d ⟨p, dvd_of_mem_normalized_factors hp⟩))) m
    by
    rw [d.symm_apply_apply ⟨p, dvd_of_mem_normalized_factors hp⟩, Subtype.coe_mk] at this
    exact this
  letI := Classical.decEq (Associates N)
  simpa only [Subtype.coe_eta] using
    multiplicity_prime_le_multiplicity_image_by_factor_orderIso
      (mem_normalizedFactors_factor_orderIso_of_mem_normalizedFactors hn hp d) d.symm
#align multiplicity_prime_eq_multiplicity_image_by_factor_order_iso multiplicity_prime_eq_multiplicity_image_by_factor_orderIso

end

variable [Unique Mˣ] [Unique Nˣ]

/-- The order isomorphism between the factors of `mk m` and the factors of `mk n` induced by a
  bijection between the factors of `m` and the factors of `n` that preserves `∣`. -/
@[simps]
def mkFactorOrderIsoOfFactorDvdEquiv {m : M} {n : N} {d : { l : M // l ∣ m } ≃ { l : N // l ∣ n }}
    (hd : ∀ l l', (d l : N) ∣ d l' ↔ (l : M) ∣ (l' : M)) :
    Set.Iic (Associates.mk m) ≃o Set.Iic (Associates.mk n)
    where
  toFun l :=
    ⟨Associates.mk
        (d
          ⟨associatesEquivOfUniqueUnits ↑l, by
            obtain ⟨x, hx⟩ := l
            rw [Subtype.coe_mk, associatesEquivOfUniqueUnits_apply, out_dvd_iff]
            exact hx⟩),
      mk_le_mk_iff_dvd_iff.mpr (Subtype.prop (d ⟨associatesEquivOfUniqueUnits ↑l, _⟩))⟩
  invFun l :=
    ⟨Associates.mk
        (d.symm
          ⟨associatesEquivOfUniqueUnits ↑l, by
            obtain ⟨x, hx⟩ := l <;>
                rw [Subtype.coe_mk, associatesEquivOfUniqueUnits_apply, out_dvd_iff] <;>
              exact hx⟩),
      mk_le_mk_iff_dvd_iff.mpr (Subtype.prop (d.symm ⟨associatesEquivOfUniqueUnits ↑l, _⟩))⟩
  left_inv := fun ⟨l, hl⟩ => by
    simp only [Subtype.coe_eta, Equiv.symm_apply_apply, Subtype.coe_mk,
      associatesEquivOfUniqueUnits_apply, mk_out, out_mk, normalize_eq]
  right_inv := fun ⟨l, hl⟩ => by
    simp only [Subtype.coe_eta, Equiv.apply_symm_apply, Subtype.coe_mk,
      associatesEquivOfUniqueUnits_apply, out_mk, normalize_eq, mk_out]
  map_rel_iff' := by
    rintro ⟨a, ha⟩ ⟨b, hb⟩ <;>
      simp only [Equiv.coe_fn_mk, Subtype.mk_le_mk, Associates.mk_le_mk_iff_dvd_iff, hd,
        Subtype.coe_mk, associatesEquivOfUniqueUnits_apply, out_dvd_iff, mk_out]
#align mk_factor_order_iso_of_factor_dvd_equiv mkFactorOrderIsoOfFactorDvdEquiv

variable [UniqueFactorizationMonoid M] [UniqueFactorizationMonoid N] [DecidableEq M]

theorem mem_normalizedFactors_factor_dvd_iso_of_mem_normalizedFactors [DecidableEq N] {m p : M}
    {n : N} (hm : m ≠ 0) (hn : n ≠ 0) (hp : p ∈ normalizedFactors m)
    {d : { l : M // l ∣ m } ≃ { l : N // l ∣ n }}
    (hd : ∀ l l', (d l : N) ∣ d l' ↔ (l : M) ∣ (l' : M)) :
    ↑(d ⟨p, dvd_of_mem_normalizedFactors hp⟩) ∈ normalizedFactors n :=
  by
  suffices
    Prime
      ↑(d
          ⟨associatesEquivOfUniqueUnits (associates_equiv_of_unique_units.symm p), by
            simp [dvd_of_mem_normalized_factors hp]⟩)
    by
    simp only [associatesEquivOfUniqueUnits_apply, out_mk, normalize_eq,
      associatesEquivOfUniqueUnits_symm_apply] at this
    obtain ⟨q, hq, hq'⟩ :=
      exists_mem_normalized_factors_of_dvd hn this.irreducible
        (d ⟨p, by apply dvd_of_mem_normalized_factors <;> convert hp⟩).Prop
    rwa [associated_iff_eq.mp hq']
  have :
    Associates.mk
        ↑(d
            ⟨associatesEquivOfUniqueUnits (associates_equiv_of_unique_units.symm p), by
              simp only [dvd_of_mem_normalized_factors hp, associatesEquivOfUniqueUnits_apply,
                out_mk, normalize_eq, associatesEquivOfUniqueUnits_symm_apply]⟩) =
      ↑(mkFactorOrderIsoOfFactorDvdEquiv hd
          ⟨associates_equiv_of_unique_units.symm p, by
            simp only [associatesEquivOfUniqueUnits_symm_apply] <;>
              exact mk_dvd_mk.mpr (dvd_of_mem_normalized_factors hp)⟩) :=
    by
    rw [mkFactorOrderIsoOfFactorDvdEquiv_apply_coe]
    simp only [Subtype.coe_mk]
  rw [← Associates.prime_mk, this]
  letI := Classical.decEq (Associates M)
  refine' map_prime_of_factor_orderIso (mk_ne_zero.mpr hn) _ _
  obtain ⟨q, hq, hq'⟩ :=
    exists_mem_normalized_factors_of_dvd (mk_ne_zero.mpr hm)
      ((prime_mk p).mpr (prime_of_normalized_factor p (by convert hp))).Irreducible
      (mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp))
  simpa only [associated_iff_eq.mp hq', associatesEquivOfUniqueUnits_symm_apply] using hq
#align mem_normalized_factors_factor_dvd_iso_of_mem_normalized_factors mem_normalizedFactors_factor_dvd_iso_of_mem_normalizedFactors

variable [DecidableRel ((· ∣ ·) : M → M → Prop)] [DecidableRel ((· ∣ ·) : N → N → Prop)]

theorem multiplicity_factor_dvd_iso_eq_multiplicity_of_mem_normalized_factor {m p : M} {n : N}
    (hm : m ≠ 0) (hn : n ≠ 0) (hp : p ∈ normalizedFactors m)
    {d : { l : M // l ∣ m } ≃ { l : N // l ∣ n }} (hd : ∀ l l', (d l : N) ∣ d l' ↔ (l : M) ∣ l') :
    multiplicity (d ⟨p, dvd_of_mem_normalizedFactors hp⟩ : N) n = multiplicity p m :=
  by
  apply Eq.symm
  suffices
    multiplicity (Associates.mk p) (Associates.mk m) =
      multiplicity
        (Associates.mk
          ↑(d
              ⟨associatesEquivOfUniqueUnits (associates_equiv_of_unique_units.symm p), by
                simp [dvd_of_mem_normalized_factors hp]⟩))
        (Associates.mk n)
    by
    simpa only [multiplicity_mk_eq_multiplicity, associatesEquivOfUniqueUnits_symm_apply,
      associatesEquivOfUniqueUnits_apply, out_mk, normalize_eq] using this
  have :
    Associates.mk
        ↑(d
            ⟨associatesEquivOfUniqueUnits (associates_equiv_of_unique_units.symm p), by
              simp only [dvd_of_mem_normalized_factors hp, associatesEquivOfUniqueUnits_symm_apply,
                associatesEquivOfUniqueUnits_apply, out_mk, normalize_eq]⟩) =
      ↑(mkFactorOrderIsoOfFactorDvdEquiv hd
          ⟨associates_equiv_of_unique_units.symm p, by
            rw [associatesEquivOfUniqueUnits_symm_apply] <;>
              exact mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp)⟩) :=
    by
    rw [mkFactorOrderIsoOfFactorDvdEquiv_apply_coe]
    rfl
  rw [this]
  letI := Classical.decEq (Associates M)
  refine'
    multiplicity_prime_eq_multiplicity_image_by_factor_orderIso (mk_ne_zero.mpr hn) _
      (mkFactorOrderIsoOfFactorDvdEquiv hd)
  obtain ⟨q, hq, hq'⟩ :=
    exists_mem_normalized_factors_of_dvd (mk_ne_zero.mpr hm)
      ((prime_mk p).mpr (prime_of_normalized_factor p hp)).Irreducible
      (mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp))
  rwa [associated_iff_eq.mp hq']
#align multiplicity_factor_dvd_iso_eq_multiplicity_of_mem_normalized_factor multiplicity_factor_dvd_iso_eq_multiplicity_of_mem_normalized_factor


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.big_operators.basic
import Mathlib.data.nat.enat
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Big operators in `enat`

A simple lemma about sums in `enat`.
-/

namespace finset

theorem sum_nat_coe_enat {α : Type u_1} (s : finset α) (f : α → ℕ) : (finset.sum s fun (x : α) => ↑(f x)) = ↑(finset.sum s fun (x : α) => f x) :=
  Eq.symm (add_monoid_hom.map_sum enat.coe_hom (fun (x : α) => f x) s)


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

! This file was ported from Lean 3 source module category_theory.category.Cat.limit
! leanprover-community/mathlib commit 1995c7bbdbb0adb1b6d5acdc654f6cf46ed96cfa
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Cat
import Mathlib.CategoryTheory.Limits.Types
import Mathlib.CategoryTheory.Limits.Preserves.Basic

/-!
# The category of small categories has all small limits.

An object in the limit consists of a family of objects,
which are carried to one another by the functors in the diagram.
A morphism between two such objects is a family of morphisms between the corresponding objects,
which are carried to one another by the action on morphisms of the functors in the diagram.

## Future work
Can the indexing category live in a lower universe?
-/

noncomputable section

universe v u

open CategoryTheory.Limits

namespace CategoryTheory

variable {J : Type v} [SmallCategory J]

namespace Cat

namespace HasLimits

instance categoryObjects {F : J ⥤ Cat.{u, u}} {j} :
    SmallCategory ((F ⋙ Cat.objects.{u, u}).obj j) :=
  (F.obj j).str
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.category_objects CategoryTheory.Cat.HasLimits.categoryObjects

/-- Auxiliary definition:
the diagram whose limit gives the morphism space between two objects of the limit category. -/
@[simps]
def homDiagram {F : J ⥤ Cat.{v, v}} (X Y : limit (F ⋙ Cat.objects.{v, v})) : J ⥤ Type v where
  obj j := limit.π (F ⋙ Cat.objects) j X ⟶ limit.π (F ⋙ Cat.objects) j Y
  map f g := by
    refine' eqToHom _ ≫ (F.map f).map g ≫ eqToHom _
    exact (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm
    exact congr_fun (limit.w (F ⋙ Cat.objects) f) Y
  map_id X := by
    funext f
    letI : Category (objects.obj (F.obj X)) := (inferInstance : Category (F.obj X))
    simp [Functor.congr_hom (F.map_id X) f]
  map_comp {_ _ Z} f g := by
    funext h
    letI : Category (objects.obj (F.obj Z)) := (inferInstance : Category (F.obj Z))
    simp [Functor.congr_hom (F.map_comp f g) h, eqToHom_map]
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.hom_diagram CategoryTheory.Cat.HasLimits.homDiagram

@[simps]
instance (F : J ⥤ Cat.{v, v}) : Category (limit (F ⋙ Cat.objects))
    where
  Hom X Y := limit (homDiagram X Y)
  id X := Types.Limit.mk.{v, v} (homDiagram X X) (fun j => 𝟙 _) fun j j' f => by simp
  comp {X Y Z} f g :=
    Types.Limit.mk.{v, v} (homDiagram X Z)
      (fun j => limit.π (homDiagram X Y) j f ≫ limit.π (homDiagram Y Z) j g) fun j j' h => by
      simp [← congr_fun (limit.w (homDiagram X Y) h) f,
        ← congr_fun (limit.w (homDiagram Y Z) h) g]
  id_comp _ := by
    apply Types.limit_ext.{v, v}
    aesop_cat
  comp_id _ := by
    apply Types.limit_ext.{v, v}
    aesop_cat

/-- Auxiliary definition: the limit category. -/
@[simps]
def limitConeX (F : J ⥤ Cat.{v, v}) : Cat.{v, v} where α := limit (F ⋙ Cat.objects)
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.limit_cone_X CategoryTheory.Cat.HasLimits.limitConeX

/-- Auxiliary definition: the cone over the limit category. -/
@[simps]
def limitCone (F : J ⥤ Cat.{v, v}) : Cone F
    where
  pt := limitConeX F
  π :=
    { app := fun j =>
        { obj := limit.π (F ⋙ Cat.objects) j
          map := fun f => limit.π (homDiagram _ _) j f }
      naturality := fun j j' f =>
        CategoryTheory.Functor.ext (fun X => (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm)
          fun X Y h => (congr_fun (limit.w (homDiagram X Y) f) h).symm }
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.limit_cone CategoryTheory.Cat.HasLimits.limitCone

/-- Auxiliary definition: the universal morphism to the proposed limit cone. -/
@[simps]
def limitConeLift (F : J ⥤ Cat.{v, v}) (s : Cone F) : s.pt ⟶ limitConeX F
    where
  obj :=
    limit.lift (F ⋙ Cat.objects)
      { pt := s.pt
        π :=
          { app := fun j => (s.π.app j).obj
            naturality := fun _ _ f => Functor.congr_map objects (s.π.naturality f) } }
  map f := by
    fapply Types.Limit.mk.{v, v}
    · intro j
      refine' eqToHom _ ≫ (s.π.app j).map f ≫ eqToHom _ <;> simp
    · intro j j' h
      dsimp
      simp only [Category.assoc, Functor.map_comp, eqToHom_map, eqToHom_trans,
        eqToHom_trans_assoc, ← Functor.comp_map]
      have := (s.π.naturality h).symm
      dsimp at this
      rw [Category.id_comp] at this
      erw [Functor.congr_hom this f]
      simp
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.limit_cone_lift CategoryTheory.Cat.HasLimits.limitConeLift

@[simp]
theorem limit_π_homDiagram_eqToHom {F : J ⥤ Cat.{v, v}} (X Y : limit (F ⋙ Cat.objects.{v, v}))
    (j : J) (h : X = Y) :
    limit.π (homDiagram X Y) j (eqToHom h) =
      eqToHom (congr_arg (limit.π (F ⋙ Cat.objects.{v, v}) j) h) := by
  subst h
  simp
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.limit_π_hom_diagram_eq_to_hom CategoryTheory.Cat.HasLimits.limit_π_homDiagram_eqToHom

/-- Auxiliary definition: the proposed cone is a limit cone. -/
def limitConeIsLimit (F : J ⥤ Cat.{v, v}) : IsLimit (limitCone F) where
  lift := limitConeLift F
  fac s j := CategoryTheory.Functor.ext (by simp) fun X Y f => by
    dsimp [limitConeLift]
    exact Types.Limit.π_mk.{v, v} _ _ _ _
  uniq s m w := by
    symm
    refine' CategoryTheory.Functor.ext _ _
    . intro X
      apply Types.limit_ext.{v, v}
      intro j
      simp [Types.Limit.lift_π_apply', ← w j]
    . intro X Y f
      dsimp
      simp [fun j => Functor.congr_hom (w j).symm f]
set_option linter.uppercaseLean3 false in
#align category_theory.Cat.has_limits.limit_cone_is_limit CategoryTheory.Cat.HasLimits.limitConeIsLimit

end HasLimits

/-- The category of small categories has all small limits. -/
instance : HasLimits Cat.{v, v} where
  has_limits_of_shape _ :=
    { has_limit := fun F => ⟨⟨⟨HasLimits.limitCone F, HasLimits.limitConeIsLimit F⟩⟩⟩ }

instance : PreservesLimits Cat.objects.{v, v} where
  preservesLimitsOfShape :=
    { preservesLimit := fun {F} =>
        preservesLimitOfPreservesLimitCone (HasLimits.limitConeIsLimit F)
          (Limits.IsLimit.ofIsoLimit (limit.isLimit (F ⋙ Cat.objects))
            (Cones.ext (by rfl) (by aesop_cat))) }

end Cat

end CategoryTheory


/-
Copyright (c) 2021 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez
-/
import algebra.algebra.basic
import algebra.char_p.basic

/-!
# `ne_zero` typeclass

We create a typeclass `ne_zero n` which carries around the fact that `(n : R) ≠ 0`.

## Main declarations

* `ne_zero`: `n ≠ 0` as a typeclass.

-/

/-- A type-class version of `n ≠ 0`.  -/
class ne_zero {R} [has_zero R] (n : R) : Prop := (out : n ≠ 0)

lemma ne_zero.ne {R} [has_zero R] (n : R) [h : ne_zero n] : n ≠ 0 := h.out

lemma ne_zero.ne' (n : ℕ) (R) [has_zero R] [has_one R] [has_add R] [h : ne_zero (n : R)] :
  (n : R) ≠ 0 := h.out

lemma ne_zero_iff {R : Type*} [has_zero R] {n : R} : ne_zero n ↔ n ≠ 0 :=
⟨λ h, h.out, ne_zero.mk⟩

lemma not_ne_zero {R : Type*} [has_zero R] {n : R} : ¬ ne_zero n ↔ n = 0 :=
by simp [ne_zero_iff]

namespace ne_zero

variables {R S M F : Type*} {r : R} {x y : M} {n p : ℕ} {a : ℕ+}

instance pnat : ne_zero (a : ℕ) := ⟨a.ne_zero⟩
instance succ : ne_zero (n + 1) := ⟨n.succ_ne_zero⟩

instance char_zero [ne_zero n] [add_monoid M] [has_one M] [char_zero M] : ne_zero (n : M) :=
⟨nat.cast_ne_zero.mpr $ ne_zero.ne n⟩

@[priority 100] instance invertible [monoid_with_zero M] [nontrivial M] [invertible x] :
  ne_zero x := ⟨nonzero_of_invertible x⟩

instance coe_trans {r : R} [has_zero M] [has_coe R S] [has_coe_t S M] [h : ne_zero (r : M)] :
  ne_zero ((r : S) : M) := ⟨h.out⟩

lemma trans {r : R} [has_zero M] [has_coe R S] [has_coe_t S M] (h : ne_zero ((r : S) : M)) :
  ne_zero (r : M) := ⟨h.out⟩

lemma of_map [has_zero R] [has_zero M] [zero_hom_class F R M] (f : F) [ne_zero (f r)] :
  ne_zero r := ⟨λ h, ne (f r) $ by convert map_zero f⟩

lemma of_injective {r : R} [has_zero R] [h : ne_zero r] [has_zero M] [zero_hom_class F R M]
  {f : F} (hf : function.injective f) : ne_zero (f r) :=
⟨by { rw ←map_zero f, exact hf.ne (ne r) }⟩

lemma nat_of_injective [non_assoc_semiring M] [non_assoc_semiring R] [h : ne_zero (n : R)]
  [ring_hom_class F R M] {f : F} (hf : function.injective f) : ne_zero (n : M) :=
 ⟨λ h, (ne_zero.ne' n R) $ hf $ by simpa⟩

variables (R M)

lemma of_not_dvd [add_monoid M] [has_one M] [char_p M p] (h : ¬ p ∣ n) : ne_zero (n : M) :=
⟨(not_iff_not.mpr $ char_p.cast_eq_zero_iff M p n).mpr h⟩

lemma of_no_zero_smul_divisors (n : ℕ) [comm_ring R] [ne_zero (n : R)] [ring M] [nontrivial M]
  [algebra R M] [no_zero_smul_divisors R M] : ne_zero (n : M) :=
nat_of_injective $ no_zero_smul_divisors.algebra_map_injective R M

lemma of_ne_zero_coe [has_zero R] [has_one R] [has_add R] [h : ne_zero (n : R)] : ne_zero n :=
⟨by {casesI h, rintro rfl, contradiction}⟩

lemma not_char_dvd [add_monoid R] [has_one R] (p : ℕ) [char_p R p] (k : ℕ) [h : ne_zero (k : R)] :
  ¬ p ∣ k :=
by rwa [←not_iff_not.mpr $ char_p.cast_eq_zero_iff R p k, ←ne.def, ←ne_zero_iff]

lemma pos_of_ne_zero_coe [has_zero R] [has_one R] [has_add R] [ne_zero (n : R)] : 0 < n :=
(ne_zero.of_ne_zero_coe R).out.bot_lt

end ne_zero


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.Init.Data.Nat.Notation

/-!
# Theorems about equality in `Fin`.
-/

namespace Fin

theorem eq_of_veq : ∀ {i j : Fin n}, i.val = j.val → i = j
  | ⟨iv, ilt₁⟩, ⟨jv, jlt₁⟩, h => by cases h; rfl

theorem veq_of_eq : ∀ {i j : Fin n}, i = j → i.val = j.val
  | ⟨_, _⟩, _, rfl => rfl

theorem vne_of_ne {i j : Fin n} (h : i ≠ j) : i.val ≠ j.val := fun h' ↦ absurd (eq_of_veq h') h

end Fin


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Partial predecessor and partial subtraction on the natural numbers

The usual definition of natural number subtraction (`nat.sub`) returns 0 as a "garbage value" for
`a - b` when `a < b`. Similarly, `nat.pred 0` is defined to be `0`. The functions in this file
wrap the result in an `option` type instead:

## Main definitions

- `nat.ppred`: a partial predecessor operation
- `nat.psub`: a partial subtraction operation

-/

namespace nat

/-- Partial predecessor operation. Returns `ppred n = some m`
  if `n = m + 1`, otherwise `none`. -/
@[simp] def ppred : ℕ → Option ℕ := sorry

/-- Partial subtraction operation. Returns `psub m n = some k`
  if `m = n + k`, otherwise `none`. -/
@[simp] def psub (m : ℕ) : ℕ → Option ℕ := sorry

theorem pred_eq_ppred (n : ℕ) : Nat.pred n = option.get_or_else (ppred n) 0 :=
  nat.cases_on n (Eq.refl (Nat.pred 0)) fun (n : ℕ) => Eq.refl (Nat.pred (Nat.succ n))

theorem sub_eq_psub (m : ℕ) (n : ℕ) : m - n = option.get_or_else (psub m n) 0 := sorry

@[simp] theorem ppred_eq_some {m : ℕ} {n : ℕ} : ppred n = some m ↔ Nat.succ m = n := sorry

@[simp] theorem ppred_eq_none {n : ℕ} : ppred n = none ↔ n = 0 := sorry

theorem psub_eq_some {m : ℕ} {n : ℕ} {k : ℕ} : psub m n = some k ↔ k + n = m := sorry

theorem psub_eq_none {m : ℕ} {n : ℕ} : psub m n = none ↔ m < n := sorry

theorem ppred_eq_pred {n : ℕ} (h : 0 < n) : ppred n = some (Nat.pred n) :=
  iff.mpr ppred_eq_some (succ_pred_eq_of_pos h)

theorem psub_eq_sub {m : ℕ} {n : ℕ} (h : n ≤ m) : psub m n = some (m - n) :=
  iff.mpr psub_eq_some (nat.sub_add_cancel h)

theorem psub_add (m : ℕ) (n : ℕ) (k : ℕ) :
    psub m (n + k) =
        do
          let x ← psub m n
          psub x k :=
  sorry

/-- Same as `psub`, but with a more efficient implementation. -/
def psub' (m : ℕ) (n : ℕ) : Option ℕ := ite (n ≤ m) (some (m - n)) none

theorem psub'_eq_psub (m : ℕ) (n : ℕ) : psub' m n = psub m n := sorry

end Mathlib


import ring_theory.polynomial.homogeneous
import data.list.basic
import .finset

namespace mv_polynomial
variables {σ : Type*} {τ : Type*} {R : Type*} {S : Type*}

namespace is_homogeneous
variables [comm_semiring R] {φ ψ : mv_polynomial σ R} {m n : ℕ}

lemma pow (hφ : is_homogeneous φ n) (k : ℕ) :
	is_homogeneous (φ ^ k) (n * k) :=
begin
	rw [finset.pow_eq_prod_const],
	convert prod (finset.range k) (λ _, φ) (λ _, n) (λ _ _, hφ),
	simp [nat.mul_comm],
end

lemma multiset_sum (s : multiset (mv_polynomial σ R)) (n : ℕ) :
	(∀ φ ∈ s, is_homogeneous φ n) → is_homogeneous s.sum n :=
begin
	apply multiset.induction_on s, { simp [is_homogeneous_zero] },
	intros ψ s ih h, rw multiset.sum_cons,
	apply (h ψ (multiset.mem_cons_self _ _)).add (ih _),
	intros φ hφ, apply h φ (multiset.mem_cons_of_mem hφ),
end

lemma list_sum (l : list (mv_polynomial σ R)) (n : ℕ)	(h : ∀ φ ∈ l, is_homogeneous φ n) :
	is_homogeneous l.sum n :=
begin
	revert h,
	induction l with hd tl ih,
	{	intro, simp only [is_homogeneous_zero, list.sum_nil] },
	intro h, rw list.sum_cons,
	apply (h hd (list.mem_cons_self _ _)).add (ih _),
	intros φ hφ, apply h φ (list.mem_cons_of_mem _ hφ),
end

lemma zip_with_mul_sum_homogeneous (l₁ l₂ : list (mv_polynomial σ R)) (n₁ n₂ : ℕ)
	(h₁ : ∀ φ ∈ l₁, is_homogeneous φ n₁) (h₂ : ∀ φ ∈ l₂, is_homogeneous φ n₂) :
	is_homogeneous (list.zip_with (*) l₁ l₂).sum (n₁ + n₂) :=
begin
	apply list_sum, intros φ hφ,
	cases list.mem_iff_nth.mp hφ with i hi,
	rw list.nth_zip_with_eq_some at hi,
	rcases hi with ⟨φ₁, φ₂, hs₁, hs₂, rfl⟩,
	apply mul (h₁ _ _) (h₂ _ _);
	{ apply list.mem_iff_nth.mpr, use i, assumption }
end

#check list.nth_zip_with_eq_some

end is_homogeneous

end mv_polynomial


/-
Copyright (c) 2020 Kyle Miller All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller
-/
import data.sym.basic
import tactic.linarith

/-!
# The symmetric square

This file defines the symmetric square, which is `α × α` modulo
swapping.  This is also known as the type of unordered pairs.

More generally, the symmetric square is the second symmetric power
(see `data.sym.basic`). The equivalence is `sym2.equiv_sym`.

From the point of view that an unordered pair is equivalent to a
multiset of cardinality two (see `sym2.equiv_multiset`), there is a
`has_mem` instance `sym2.mem`, which is a `Prop`-valued membership
test.  Given `h : a ∈ z` for `z : sym2 α`, then `h.other` is the other
element of the pair, defined using `classical.choice`.  If `α` has
decidable equality, then `h.other'` computably gives the other element.

The universal property of `sym2` is provided as `sym2.lift`, which
states that functions from `sym2 α` are equivalent to symmetric
two-argument functions from `α`.

Recall that an undirected graph (allowing self loops, but no multiple
edges) is equivalent to a symmetric relation on the vertex type `α`.
Given a symmetric relation on `α`, the corresponding edge set is
constructed by `sym2.from_rel` which is a special case of `sym2.lift`.

## Notation

The symmetric square has a setoid instance, so `⟦(a, b)⟧` denotes a
term of the symmetric square.

## Tags

symmetric square, unordered pairs, symmetric powers
-/

open finset fintype function sym

universe u
variables {α : Type u}
namespace sym2

/--
This is the relation capturing the notion of pairs equivalent up to permutations.
-/
inductive rel (α : Type u) : (α × α) → (α × α) → Prop
| refl (x y : α) : rel (x, y) (x, y)
| swap (x y : α) : rel (x, y) (y, x)

attribute [refl] rel.refl

@[symm] lemma rel.symm {x y : α × α} : rel α x y → rel α y x :=
by rintro ⟨_, _⟩; constructor

@[trans] lemma rel.trans {x y z : α × α} : rel α x y → rel α y z → rel α x z :=
by { intros a b, cases_matching* rel _ _ _; apply rel.refl <|> apply rel.swap }

lemma rel.is_equivalence : equivalence (rel α) := by tidy; apply rel.trans; assumption

instance rel.setoid (α : Type u) : setoid (α × α) := ⟨rel α, rel.is_equivalence⟩

end sym2

/--
`sym2 α` is the symmetric square of `α`, which, in other words, is the
type of unordered pairs.

It is equivalent in a natural way to multisets of cardinality 2 (see
`sym2.equiv_multiset`).
-/
@[reducible]
def sym2 (α : Type u) := quotient (sym2.rel.setoid α)

namespace sym2

@[elab_as_eliminator]
protected lemma ind {f : sym2 α → Prop} (h : ∀ x y, f ⟦(x, y)⟧) : ∀ i, f i :=
quotient.ind $ prod.rec $ by exact h

@[elab_as_eliminator]
protected lemma induction_on {f : sym2 α → Prop} (i : sym2 α) (hf : ∀ x y, f ⟦(x,y)⟧) : f i :=
i.ind hf

protected lemma «exists» {α : Sort*} {f : sym2 α → Prop} :
  (∃ (x : sym2 α), f x) ↔ ∃ x y, f ⟦(x, y)⟧ :=
(surjective_quotient_mk _).exists.trans prod.exists

protected lemma «forall» {α : Sort*} {f : sym2 α → Prop} :
  (∀ (x : sym2 α), f x) ↔ ∀ x y, f ⟦(x, y)⟧ :=
(surjective_quotient_mk _).forall.trans prod.forall

lemma eq_swap {a b : α} : ⟦(a, b)⟧ = ⟦(b, a)⟧ :=
by { rw quotient.eq, apply rel.swap }

lemma congr_right {a b c : α} : ⟦(a, b)⟧ = ⟦(a, c)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

lemma congr_left {a b c : α} : ⟦(b, a)⟧ = ⟦(c, a)⟧ ↔ b = c :=
by { split; intro h, { rw quotient.eq at h, cases h; refl }, rw h }

lemma eq_iff {x y z w : α} :
  ⟦(x, y)⟧ = ⟦(z, w)⟧ ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) :=
begin
  split; intro h,
  { rw quotient.eq at h, cases h; tidy },
  { cases h; rw [h.1, h.2], rw eq_swap }
end

/-- The universal property of `sym2`; symmetric functions of two arguments are equivalent to
functions from `sym2`. Note that when `β` is `Prop`, it can sometimes be more convenient to use
`sym2.from_rel` instead. -/
def lift {β : Type*} : {f : α → α → β // ∀ a₁ a₂, f a₁ a₂ = f a₂ a₁} ≃ (sym2 α → β) :=
{ to_fun := λ f, quotient.lift (uncurry ↑f) $ by { rintro _ _ ⟨⟩, exacts [rfl, f.prop _ _] },
  inv_fun := λ F, ⟨curry (F ∘ quotient.mk), λ a₁ a₂, congr_arg F eq_swap⟩,
  left_inv := λ f, subtype.ext rfl,
  right_inv := λ F, funext $ sym2.ind $ by exact λ x y, rfl }

@[simp]
lemma lift_mk {β : Type*} (f : {f : α → α → β // ∀ a₁ a₂, f a₁ a₂ = f a₂ a₁}) (a₁ a₂ : α) :
  lift f ⟦(a₁, a₂)⟧ = (f : α → α → β) a₁ a₂ := rfl

@[simp]
lemma coe_lift_symm_apply {β : Type*} (F : sym2 α → β) (a₁ a₂ : α) :
  (lift.symm F : α → α → β) a₁ a₂ = F ⟦(a₁, a₂)⟧ := rfl

/--
The functor `sym2` is functorial, and this function constructs the induced maps.
-/
def map {α β : Type*} (f : α → β) : sym2 α → sym2 β :=
quotient.map (prod.map f f)
  (by { rintros _ _ h, cases h, { refl }, apply rel.swap })

@[simp]
lemma map_id : sym2.map (@id α) = id := by tidy

lemma map_comp {α β γ : Type*} {g : β → γ} {f : α → β} :
  sym2.map (g ∘ f) = sym2.map g ∘ sym2.map f := by tidy

lemma map_map {α β γ : Type*} {g : β → γ} {f : α → β} (x : sym2 α) :
  map g (map f x) = map (g ∘ f) x := by tidy

@[simp]
lemma map_pair_eq {α β : Type*} (f : α → β) (x y : α) : map f ⟦(x, y)⟧ = ⟦(f x, f y)⟧ := rfl

lemma map.injective {α β : Type*} {f : α → β} (hinj : injective f) : injective (map f) :=
begin
  intros z z',
  refine quotient.ind₂ (λ z z', _) z z',
  cases z with x y,
  cases z' with x' y',
  repeat { rw [map_pair_eq, eq_iff] },
  rintro (h|h); simp [hinj h.1, hinj h.2],
end

section membership

/-! ### Declarations about membership -/

/--
This is a predicate that determines whether a given term is a member of a term of the
symmetric square.  From this point of view, the symmetric square is the subtype of
cardinality-two multisets on `α`.
-/
def mem (x : α) (z : sym2 α) : Prop :=
∃ (y : α), z = ⟦(x, y)⟧

instance : has_mem α (sym2 α) := ⟨mem⟩

lemma mk_has_mem (x y : α) : x ∈ ⟦(x, y)⟧ := ⟨y, rfl⟩

lemma mk_has_mem_right (x y : α) : y ∈ ⟦(x, y)⟧ := by { rw eq_swap, apply mk_has_mem }

/--
Given an element of the unordered pair, give the other element using `classical.some`.
See also `mem.other'` for the computable version.
-/
noncomputable def mem.other {a : α} {z : sym2 α} (h : a ∈ z) : α :=
classical.some h

@[simp]
lemma mem_other_spec {a : α} {z : sym2 α} (h : a ∈ z) : ⟦(a, h.other)⟧ = z :=
by erw ← classical.some_spec h

@[simp]

lemma mem_other_mem {a : α} {z : sym2 α} (h : a ∈ z) :
  h.other ∈ z :=
by { convert mk_has_mem_right a h.other, rw mem_other_spec h }

lemma elems_iff_eq {x y : α} {z : sym2 α} (hne : x ≠ y) :
  x ∈ z ∧ y ∈ z ↔ z = ⟦(x, y)⟧ :=
begin
  split,
  { refine quotient.rec_on_subsingleton z _,
    rintros ⟨z₁, z₂⟩ ⟨hx, hy⟩,
    rw eq_iff,
    cases mem_iff.mp hx with hx hx; cases mem_iff.mp hy with hy hy; subst x; subst y;
    try { exact (hne rfl).elim };
    simp only [true_or, eq_self_iff_true, and_self, or_true] },
  { rintro rfl, simp },
end

@[ext]
lemma sym2_ext (z z' : sym2 α) (h : ∀ x, x ∈ z ↔ x ∈ z') : z = z' :=
begin
  refine quotient.rec_on_subsingleton z (λ w, _) h,
  refine quotient.rec_on_subsingleton z' (λ w', _),
  intro h,
  cases w with x y, cases w' with x' y',
  simp only [mem_iff] at h,
  apply eq_iff.mpr,
  have hx := h x, have hy := h y, have hx' := h x', have hy' := h y',
  simp only [true_iff, true_or, eq_self_iff_true, iff_true, or_true] at hx hy hx' hy',
  cases hx; subst x; cases hy; subst y; cases hx'; try { subst x' }; cases hy'; try { subst y' };
  simp only [eq_self_iff_true, and_self, or_self, true_or, or_true],
end

instance mem.decidable [decidable_eq α] (x : α) (z : sym2 α) : decidable (x ∈ z) :=
quotient.rec_on_subsingleton z (λ ⟨y₁, y₂⟩, decidable_of_iff' _ mem_iff)

end membership

/--
A type `α` is naturally included in the diagonal of `α × α`, and this function gives the image
of this diagonal in `sym2 α`.
-/
def diag (x : α) : sym2 α := ⟦(x, x)⟧

lemma diag_injective : function.injective (sym2.diag : α → sym2 α) :=
λ x y h, by cases quotient.exact h; refl

/--
A predicate for testing whether an element of `sym2 α` is on the diagonal.
-/
def is_diag : sym2 α → Prop :=
lift ⟨eq, λ _ _, propext eq_comm⟩

lemma is_diag_iff_eq {x y : α} : is_diag ⟦(x, y)⟧ ↔ x = y :=
iff.rfl

@[simp]
lemma is_diag_iff_proj_eq (z : α × α) : is_diag ⟦z⟧ ↔ z.1 = z.2 :=
prod.rec_on z $ λ _ _, is_diag_iff_eq

@[simp]
lemma diag_is_diag (a : α) : is_diag (diag a) :=
eq.refl a

lemma is_diag.mem_range_diag {z : sym2 α} : is_diag z → z ∈ set.range (@diag α) :=
begin
  induction z using quotient.induction_on,
  cases z,
  rintro (rfl : z_fst = z_snd),
  exact ⟨z_fst, rfl⟩,
end

lemma is_diag_iff_mem_range_diag (z : sym2 α) : is_diag z ↔ z ∈ set.range (@diag α) :=
⟨is_diag.mem_range_diag, λ ⟨i, hi⟩, hi ▸ diag_is_diag i⟩

instance is_diag.decidable_pred (α : Type u) [decidable_eq α] : decidable_pred (@is_diag α) :=
by { refine λ z, quotient.rec_on_subsingleton z (λ a, _), erw is_diag_iff_proj_eq, apply_instance }

lemma mem_other_ne {a : α} {z : sym2 α} (hd : ¬is_diag z) (h : a ∈ z) : h.other ≠ a :=
begin
  intro hn, apply hd,
  have h' := sym2.mem_other_spec h,
  rw hn at h',
  rw ←h',
  simp,
end

section relations

/-! ### Declarations about symmetric relations -/

variables {r : α → α → Prop}

/--
Symmetric relations define a set on `sym2 α` by taking all those pairs
of elements that are related.
-/
def from_rel (sym : symmetric r) : set (sym2 α) :=
set_of (lift ⟨r, λ x y, propext ⟨λ h, sym h, λ h, sym h⟩⟩)

@[simp]
lemma from_rel_proj_prop {sym : symmetric r} {z : α × α} :
  ⟦z⟧ ∈ from_rel sym ↔ r z.1 z.2 := iff.rfl

@[simp]
lemma from_rel_prop {sym : symmetric r} {a b : α} :
  ⟦(a, b)⟧ ∈ from_rel sym ↔ r a b := iff.rfl

lemma from_rel_irreflexive {sym : symmetric r} :
  irreflexive r ↔ ∀ {z}, z ∈ from_rel sym → ¬is_diag z :=
{ mp  := λ h, sym2.ind $ by { rintros a b hr (rfl : a = b), exact h _ hr },
  mpr := λ h x hr, h (from_rel_prop.mpr hr) rfl }

lemma mem_from_rel_irrefl_other_ne {sym : symmetric r} (irrefl : irreflexive r)
  {a : α} {z : sym2 α} (hz : z ∈ from_rel sym) (h : a ∈ z) : h.other ≠ a :=
mem_other_ne (from_rel_irreflexive.mp irrefl hz) h

instance from_rel.decidable_pred (sym : symmetric r) [h : decidable_rel r] :
  decidable_pred (∈ sym2.from_rel sym) :=
λ z, quotient.rec_on_subsingleton z (λ x, h _ _)

end relations

section sym_equiv

/-! ### Equivalence to the second symmetric power -/

local attribute [instance] vector.perm.is_setoid

private def from_vector {α : Type*} : vector α 2 → α × α
| ⟨[a, b], h⟩ := (a, b)

private lemma perm_card_two_iff {α : Type*} {a₁ b₁ a₂ b₂ : α} :
  [a₁, b₁].perm [a₂, b₂] ↔ (a₁ = a₂ ∧ b₁ = b₂) ∨ (a₁ = b₂ ∧ b₁ = a₂) :=
{ mp  := by { simp [← multiset.coe_eq_coe, ← multiset.cons_coe, multiset.cons_eq_cons]; tidy },
  mpr := by { intro h, cases h; rw [h.1, h.2], apply list.perm.swap', refl } }

/--
The symmetric square is equivalent to length-2 vectors up to permutations.
-/
def sym2_equiv_sym' {α : Type*} : equiv (sym2 α) (sym' α 2) :=
{ to_fun := quotient.map
    (λ (x : α × α), ⟨[x.1, x.2], rfl⟩)
    (by { rintros _ _ ⟨_⟩, { refl }, apply list.perm.swap', refl }),
  inv_fun := quotient.map from_vector (begin
    rintros ⟨x, hx⟩ ⟨y, hy⟩ h,
    cases x with _ x, { simpa using hx, },
    cases x with _ x, { simpa using hx, },
    cases x with _ x, swap, { exfalso, simp at hx, linarith [hx] },
    cases y with _ y, { simpa using hy, },
    cases y with _ y, { simpa using hy, },
    cases y with _ y, swap, { exfalso, simp at hy, linarith [hy] },
    rcases perm_card_two_iff.mp h with ⟨rfl,rfl⟩|⟨rfl,rfl⟩, { refl },
    apply sym2.rel.swap,
  end),
  left_inv := by tidy,
  right_inv := λ x, begin
    refine quotient.rec_on_subsingleton x (λ x, _),
    { cases x with x hx,
      cases x with _ x, { simpa using hx, },
      cases x with _ x, { simpa using hx, },
      cases x with _ x, swap, { exfalso, simp at hx, linarith [hx] },
      refl },
  end }

/--
The symmetric square is equivalent to the second symmetric power.
-/
def equiv_sym (α : Type*) : sym2 α ≃ sym α 2 :=
equiv.trans sym2_equiv_sym' sym_equiv_sym'.symm

/--
The symmetric square is equivalent to multisets of cardinality
two. (This is currently a synonym for `equiv_sym`, but it's provided
in case the definition for `sym` changes.)
-/
def equiv_multiset (α : Type*) : sym2 α ≃ {s : multiset α // s.card = 2} :=
equiv_sym α

end sym_equiv

section decidable

/--
An algorithm for computing `sym2.rel`.
-/
def rel_bool [decidable_eq α] (x y : α × α) : bool :=
if x.1 = y.1 then x.2 = y.2 else
  if x.1 = y.2 then x.2 = y.1 else ff

lemma rel_bool_spec [decidable_eq α] (x y : α × α) :
  ↥(rel_bool x y) ↔ rel α x y :=
begin
  cases x with x₁ x₂, cases y with y₁ y₂,
  dsimp [rel_bool], split_ifs;
  simp only [false_iff, bool.coe_sort_ff, bool.of_to_bool_iff],
  rotate 2, { contrapose! h, cases h; cc },
  all_goals { subst x₁, split; intro h1,
    { subst h1; apply sym2.rel.swap },
    { cases h1; cc } }
end

/--
Given `[decidable_eq α]` and `[fintype α]`, the following instance gives `fintype (sym2 α)`.
-/
instance (α : Type*) [decidable_eq α] : decidable_rel (sym2.rel α) :=
λ x y, decidable_of_bool (rel_bool x y) (rel_bool_spec x y)

/--
A function that gives the other element of a pair given one of the elements.  Used in `mem.other'`.
-/
private def pair_other [decidable_eq α] (a : α) (z : α × α) : α := if a = z.1 then z.2 else z.1

/--
Get the other element of the unordered pair using the decidable equality.
This is the computable version of `mem.other`.
-/
def mem.other' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : α :=
quot.rec (λ x h', pair_other a x) (begin
  clear h z,
  intros x y h,
  ext hy,
  convert_to pair_other a x = _,
  { have h' : ∀ {c e h}, @eq.rec _ ⟦x⟧ (λ s, a ∈ s → α)
      (λ _, pair_other a x) c e h = pair_other a x,
    { intros _ e _, subst e },
    apply h', },
  have h' := (rel_bool_spec x y).mpr h,
  cases x with x₁ x₂, cases y with y₁ y₂,
  cases mem_iff.mp hy with hy'; subst a; dsimp [rel_bool] at h';
    split_ifs at h'; try { rw bool.of_to_bool_iff at h', subst x₁, subst x₂ }; dsimp [pair_other],
  simp only [ne.symm h_1, if_true, eq_self_iff_true, if_false],
  exfalso, exact bool.not_ff h',
  simp only [h_1, if_true, eq_self_iff_true, if_false],
  exfalso, exact bool.not_ff h',
end) z h

@[simp]
lemma mem_other_spec' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) :
  ⟦(a, h.other')⟧ = z :=
begin
  induction z, cases z with x y,
  have h' := mem_iff.mp h,
  dsimp [mem.other', quot.rec, pair_other],
  cases h'; subst a,
  { simp only [if_true, eq_self_iff_true], refl, },
  { split_ifs, subst h_1, refl, rw eq_swap, refl, },
  refl,
end

@[simp]
lemma other_eq_other' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) : h.other = h.other' :=
by rw [←congr_right, mem_other_spec' h, mem_other_spec]

lemma mem_other_mem' [decidable_eq α] {a : α} {z : sym2 α} (h : a ∈ z) :
  h.other' ∈ z :=
by { rw ←other_eq_other', exact mem_other_mem h }

lemma other_invol' [decidable_eq α] {a : α} {z : sym2 α} (ha : a ∈ z) (hb : ha.other' ∈ z):
  hb.other' = a :=
begin
  induction z, cases z with x y,
  dsimp [mem.other', quot.rec, pair_other] at hb,
  split_ifs at hb; dsimp [mem.other', quot.rec, pair_other],
  simp only [h, if_true, eq_self_iff_true],
  split_ifs, assumption, refl,
  simp only [h, if_false, if_true, eq_self_iff_true],
  exact ((mem_iff.mp ha).resolve_left h).symm,
  refl,
end

lemma other_invol {a : α} {z : sym2 α} (ha : a ∈ z) (hb : ha.other ∈ z):
  hb.other = a :=
begin
  classical,
  rw other_eq_other' at hb ⊢,
  convert other_invol' ha hb,
  rw other_eq_other',
end

lemma filter_image_quotient_mk_is_diag [decidable_eq α] (s : finset α) :
  ((s.product s).image quotient.mk).filter is_diag =
    s.diag.image quotient.mk :=
begin
  ext z,
  induction z using quotient.induction_on,
  rcases z with ⟨x, y⟩,
  simp only [mem_image, mem_diag, exists_prop, mem_filter, prod.exists, mem_product],
  split,
  { rintro ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩,
    rw [←h, sym2.is_diag_iff_eq] at hab,
    exact ⟨a, b, ⟨ha, hab⟩, h⟩ },
  { rintro ⟨a, b, ⟨ha, rfl⟩, h⟩,
    rw ←h,
    exact ⟨⟨a, a, ⟨ha, ha⟩, rfl⟩, rfl⟩ }
end

lemma filter_image_quotient_mk_not_is_diag [decidable_eq α] (s : finset α) :
  ((s.product s).image quotient.mk).filter (λ a : sym2 α, ¬a.is_diag) =
    s.off_diag.image quotient.mk :=
begin
  ext z,
  induction z using quotient.induction_on,
  rcases z with ⟨x, y⟩,
  simp only [mem_image, mem_off_diag, exists_prop, mem_filter, prod.exists, mem_product],
  split,
  { rintro ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩,
    rw [←h, sym2.is_diag_iff_eq] at hab,
    exact ⟨a, b, ⟨ha, hb, hab⟩, h⟩ },
  { rintro ⟨a, b, ⟨ha, hb, hab⟩, h⟩,
    rw [ne.def, ←sym2.is_diag_iff_eq, h] at hab,
    exact ⟨⟨a, b, ⟨ha, hb⟩, h⟩, hab⟩ }
end

end decidable

end sym2


import Playground.Category.Basic
import Playground.Category.Opposite
import Playground.Category.Isomorphism
import Playground.Category.Functor.Basic

namespace Category

section
  structure Natural_Transformation {C D} [Category C] [Category D] (F G : C ⥤ D) where
    component (X : C) : F X ⟶ G X
    naturality {X Y : C} : ∀ f : X ⟶ Y, F.hom_map f ≫ component Y = component X ≫ G.hom_map f
  scoped infixr:26 " ⟹ " => Natural_Transformation
end

namespace Natural_Transformation
section
  instance {C D} [Category C] [Category D] {F G : C ⥤ D}
    : CoeFun (F ⟹ G) (λ _ => (X : C) → (F X ⟶ G X)) where
    coe α := α.component

  theorem eq_of_component_eq {C D} [Category C] [Category D]
    {F G : C ⥤ D} {α β : F ⟹ G}
    (h : α.component = β.component) : α = β := by
    cases α; cases β; simp; exact h

end
end Natural_Transformation
end Category