import ..list .sqe .dnf

variable {α : Type}
-- import .axms_eq ..dnf.basic ..has_dec_aval

-- namespace dnf
--
-- open list has_atom_dlo axms axms_eq dnf

-- class has_sqe_eq (α : Type) extends axms_eq α  :=
--
-- -- Requires : all args are normal
-- -- Requires : all args are unified
-- -- Requires : all args are nontrivial
-- -- Requires : all args are nonsolutions
-- (sqe : list atom_dlo → list atom_dlo)
-- -- (qfree_sqe : ∀ {as : list atom_dlo}, --(∀ a ∈ as, dep_0 a) → qfree (sqe as))
-- (forall_mem_sqe_normal : ∀ {as : list atom_dlo}, (∀ a ∈ as, normal a) → (∀ a ∈ (sqe as), normal a))
-- (eval_sqe_iff : ∀ {as : list atom_dlo},
--   (∀ a ∈ as, normal a) →
--   (∀ a ∈ as, dep_0 a) →
--   (∀ a ∈ as, ¬ trv a) →
--   (∀ a ∈ as, ¬ solv_0 a) →
--   ∀ {bs : list α}, (avals bs (sqe as) ↔ ∃ (x : α), avals (x::bs) as))
--
open list

def sqe_eq (as : list atom_dlo) : list (atom_dlo) :=
  match find (solv_0) as with
  | none := sqe as
  | some eq := map (atom_dlo.subst_0 eq) as
  end

-- lemma forall_mem_sqe_eq_normal {as : list (atom_dlo)} :
-- (∀ a ∈ as, normal a) → -- (∀ a ∈ as, dep_0 a) →
--   ∀ a ∈ (sqe_eq as), normal a :=
-- begin
--   intros h1 a ha, simp [sqe_eq] at ha,
--   cases (find (solv_0) as); simp [sqe_eq] at ha,
--   { apply forall_mem_sqe_normal h1 _ ha },
--   { cases ha with x hx, cases hx, subst hx_right,
--     apply normal_subst, apply h1 _ hx_left }
-- end

lemma option.dest :
 ∀ (x : option α), x = none ∨ ∃ a, x = (some a)
| none := or.inl rfl
| (some a) := or.inr (begin existsi a, refl end)

lemma forall_mem_filter_nontrv_eval {as : list (atom_dlo)} {bs : list rat} :
  (∀ a ∈ (as.filter (λ x, ¬ trv x)), a.eval bs) ↔ (∀ a ∈ as, atom_dlo.eval bs a) :=
begin
  constructor; intros h a ha,
  { by_cases ht : (trv a), apply of_trv ht,
    apply h a _, rw mem_filter, constructor; assumption },
  { apply h _ (mem_of_mem_filter ha) }
end

lemma eval_sqe_eq_iff :
∀ {as : list (atom_dlo)},
  -- (∀ a ∈ as, normal a) →
  (∀ a ∈ as, dep_0 a) → (∀ a ∈ as, ¬ trv a)
  → ∀ {bs : list rat}, ((avals bs (sqe_eq as)) ↔ (∃ x, avals (x::bs) as)) :=
begin
  intros as has2 has3 bs, simp [sqe_eq],
  cases
    (option.dest (list.find (solv_0) as)) with heq heq,
    { rw heq, simp [sqe_eq],
      apply eval_sqe has2,
      rw list.find_eq_none at heq, apply heq },
    {
      cases heq with eq heq, rw heq, simp [sqe_eq],
      have heq1 : solv_0 eq := list.find_some heq,
      have heq2 : eq ∈ as := list.find_mem heq,
      have heq3 : ¬ trv eq := has3 _ heq2,
      constructor; intro h,
      { cases (of_solv_0 heq1) with b hb,
        existsi b, intros a ha,
        apply (eval_subst_0_iff heq1 heq3 hb).elim_left,
        apply h, apply mem_map_of_mem _ ha },
      { cases h with b hb, intros a ha, rw mem_map at ha,
        cases ha with a' ha', cases ha' with ha1' ha2', subst ha2',
        rw (eval_subst_0_iff heq1 heq3 (hb _ heq2)), apply hb _ ha1' }
    }
end

def sqe_opt (as : list (atom_dlo)) : list (atom_dlo) :=
let as1 := as.filter (λ a, dep_0 a ∧ ¬ trv a) in
let as2 := as.filter (λ a, ¬ dep_0 a ∧ ¬ trv a) in
(sqe_eq as1) ++ (map atom_dlo.decr_idx as2)

lemma avals_append {bs} {as1 as2 : list atom_dlo} :
avals bs (as1 ++ as2) ↔ (avals bs as1 ∧ avals bs as2) :=
begin
  simp [avals, forall_mem_append], constructor; intros h,
  { constructor; intros a ha; apply h, apply or.inl ha,
    apply or.inr ha },
  { intros a ha, cases ha, apply h.left, assumption,
    apply h.right, assumption }
end

lemma eval_sqe_opt_iff {as : list atom_dlo} {bs : list rat} :
  (avals bs (sqe_opt as)) ↔ (∃ b, avals (b::bs) as) :=
begin
  simp [sqe_opt, avals_append],
  rw ( @eval_sqe_eq_iff (filter (λ a, dep_0 a ∧ ¬trv a) as)
       -- (forall_mem_filter_of_forall_mem hr)
       (begin intros a ha, rw mem_filter at ha, apply ha.right.left end)
       (begin intros a ha, rw mem_filter at ha, apply ha.right.right end) bs),
  apply iff.trans
    exists_and_distrib_right.symm
    (exists_iff_exists _),
  intro b, constructor; intro h,
  { cases h with h1 h2, intros a ha,
    by_cases htrv : trv a,
    { apply of_trv htrv },
    { by_cases (dep_0 a),
      { apply h1, apply mem_filter_of_mem ha,
        constructor; assumption },
      { rw (atom_dlo.eval_decr_idx_iff h).symm,
        apply h2, rw mem_map, existsi a,
        apply and.intro _ rfl,
        apply mem_filter_of_mem ha,
        constructor; assumption, } } },
  { constructor,
    { intros a ha, apply h _ (mem_of_mem_filter ha) },
    { apply forall_mem_map, intros a ha, rw mem_filter at ha,
      rw atom_dlo.eval_decr_idx_iff ha.right.left, apply h _ ha.left } }
end

-- lemma qfree_sqe_eq :
--   ∀ {as : list (atom_dlo)}, (∀ a ∈ as, dep_0 a) → qfree (sqe_eq as) :=
-- begin
--   intros as has, simp [sqe_eq], --simp,
--   cases (list.find (solv_0) as) with pr,
--   { apply qfree_sqe  },
--   { simp [sqe_eq], apply qfree_conj,
--     apply forall_mem_map, intros a ha, trivial }
-- end

--lemma qfree_sqe_opt (as : list (atom_dlo)) :
--  qfree (sqe_opt as) :=
--begin
--  simp [sqe_opt], apply qfree_and_o,
--  { apply qfree_sqe_eq, simp [of_mem_filter],
--    intros, assumption },
--  { apply qfree_conj, intros p hp,
--    rw mem_map at hp, cases hp with a ha,
--    cases ha with ha1 ha2, subst ha2, trivial }
--end

def qe : formula_dlo → formula_dlo
| (formula_dlo.true) := ⊤'
| (formula_dlo.false) := ⊥'
| (formula_dlo.atom a) := A' a
| (formula_dlo.and p q) := (qe p) ∧' (qe q)
| (formula_dlo.or p q) := (qe p) ∨' (qe q)
| (formula_dlo.not p) := ¬'(qe p)
| (formula_dlo.ex p) := to_frm $ map sqe_opt $ dnf $ qe p

lemma qfree_qe : ∀ {p : formula_dlo}, qfree (qe p)
| ⊤' := trivial
| ⊥' := trivial
| (A' _) := trivial
| (¬' p) := begin apply (@qfree_qe p) end
| (p ∧' q) := begin constructor; apply qfree_qe end
| (p ∨' q) := begin constructor; apply qfree_qe end
| (∃' p) :=
  begin
    simp [qe], apply qfree_disj,
    intros q hq, rw mem_map at hq, cases hq with as has,
    cases has with has1 has2, subst has2, apply qfree_conj_atom
  end

-- lemma forall_mem_sqe_opt_normal :
--   ∀ {as : list (atom_dlo)}, (∀ a ∈ as, normal a) → (∀ a ∈ (sqe_opt as), normal a) :=
-- begin
--   intros as has a ha1,
--
--   simp [sqe_opt] at ha1, cases ha1,
--   { apply forall_mem_sqe_eq_normal _ _ ha1,
--     intros a ha2, apply has,
--     apply mem_of_mem_filter ha2 },
--   { cases ha1 with x hx, cases hx, subst hx_right,
--     apply normal_decr_idx, apply has _ hx_left.left }
-- end
--
-- lemma fnormal_qe : ∀ {p : formula_dlo}, fnormal p → fnormal (qe p)
-- | (frm.true α) hnm := trivial
-- | (frm.false α) hnm := trivial
-- | (frm.atom_dlo a) hnm := hnm
-- | (frm.and p q) hnm :=
--   begin cases hnm, constructor; apply fnormal_qe; assumption end
-- | (frm.or p q) hnm :=
--   begin cases hnm, constructor; apply fnormal_qe; assumption end
-- | (frm.not p) hnm :=
--   begin apply @fnormal_qe p, assumption end
-- | (frm.ex p) hnm :=
--   begin
--    simp [fnormal, to_frm, qe],
--    apply fnormal_disj, apply forall_mem_map,
--    intros as has, apply fnormal_conj_atom_dlo,
--    apply forall_mem_sqe_opt_normal,
--    apply forall_mem_dnf_core_forall_mem_normal _ has,
--    apply nnf.fnormal_dnf _ (fnormal_qe _),
--    apply qfree_qe, apply hnm,
--  end

lemma eval_qe :
  ∀ {p : formula_dlo} {bs : list rat}, (qe p).eval bs ↔ p.eval bs
| ⊤' bs := iff.refl _
| ⊥' bs := iff.refl _
| (A' a) bs := iff.refl _
| (p ∧' q) bs :=
  begin
    simp [qe, eval_and],
    repeat {rw eval_qe}; assumption,
  end
| (p ∨' q) bs :=
  begin
    simp [qe, eval_or],
    repeat {rw eval_qe}; assumption,
  end
| (¬' p) bs :=
  begin simp [qe, eval_not], repeat {rw eval_qe} end
| (∃' p) bs :=
  begin
    simp [qe, eval_to_frm, eval_ex],
    apply calc
      (∃ (l : list (atom_dlo)), (∃ (a : list (atom_dlo)), a ∈ dnf (qe p) ∧ sqe_opt a = l) ∧ avals bs l)
    ↔ (∃ (as : list (atom_dlo)), as ∈ dnf (qe p) ∧ avals bs (sqe_opt as)) :
      begin
        constructor; intro h,
        { cases h with as1 h2, cases h2 with h2 h3,
          cases h2 with as2 h2, cases h2, subst h2_right,
          existsi as2, constructor; assumption },
        { cases h with as has, existsi (sqe_opt as), constructor,
          { existsi as, constructor, apply has.left, refl },
          { apply has.right} }
      end
... ↔ (∃ (x : rat) (as : list (atom_dlo)), as ∈ dnf (qe p) ∧ ∀ a ∈ as, atom_dlo.eval (x::bs) a) :
      begin
        constructor; intro h;
        [
          {
            cases h with as has, cases has with has1 has2,
            rw [eval_sqe_opt_iff] at has2;
            [
              { cases has2 with b hb, existsi b, existsi as, constructor; assumption }
              --{ apply forall_mem_dnf_forall_mem_normal _ _ has1,
              --  apply qfree_qe, apply fnormal_qe, apply hp }
            ]
          },
          {
            cases h with b hb, cases hb with as has,
            cases has with has1 has2, existsi as, apply and.intro has1,
            apply (eval_sqe_opt_iff).elim_right,
              { existsi b, apply has2 },
              -- { apply forall_mem_dnf_forall_mem_normal _ _ has1,
              --   apply qfree_qe, apply fnormal_qe, apply hp }
          }
        ]
      end
... ↔ ∃ (x : rat), (qe p).eval (x :: bs) :
      begin
        apply exists_iff_exists, intro b,
        apply some_disjunct_true_iff,
        apply qfree_qe
      end
... ↔ ∃ (x : rat), p.eval (x :: bs) :
      begin
        apply exists_iff_exists, intro b,
        apply eval_qe,
      end
end

def dec_eval_of_qfree :
  ∀ {φ : formula_dlo}, qfree φ → ∀ {ds}, decidable (φ.eval ds)
| ⊤' h _ := decidable.true
| ⊥' h _ := decidable.false
| (A' a) h _ := begin simp [formula_dlo.eval], apply_instance end
| (¬' p) h _ :=
  begin apply @not.decidable _ (dec_eval_of_qfree _), apply h end
| (p ∧' q) h _ :=
  @and.decidable _ _
  (dec_eval_of_qfree h.left)
  (dec_eval_of_qfree h.right)
| (p ∨' q) h _ :=
  @or.decidable _ _
  (dec_eval_of_qfree h.left)
  (dec_eval_of_qfree h.right)
| (∃' p) h _ := by cases h

instance dec_eval_qe
  {φ : formula_dlo} : decidable ((qe φ).eval []) :=
begin apply dec_eval_of_qfree, apply qfree_qe end


import data.rat data.nat.gcd tactic.finish algebra.group_power

--meta instance : has_to_format ℤ := ⟨λ z, int.rec_on z (λ k, ↑k) (λ k, "-"++↑(k+1)++"")⟩

meta instance int.reflect : has_reflect int
| (int.of_nat n) :=
       if n = 0 then unchecked_cast `(0 : int)
       else if n = 1 then unchecked_cast `(1 : int)
       else if n % 2 = 0 then unchecked_cast $ `(λ n : int, bit0 n).subst (int.reflect ↑(n / 2))
       else unchecked_cast $ `(λ n : int, bit1 n).subst (int.reflect ↑(n / 2))
| (int.neg_succ_of_nat n) := let rv := int.reflect (int.of_nat (n+1)) in unchecked_cast `(-%%rv : ℤ)

/-meta def f (z : ℤ) : expr := `(z)
set_option pp.all true
run_cmd tactic.trace $ f (-10)-/

--def rat_of_int (i : ℤ) : ℚ := --⟦⟨i, 1, zero_lt_one⟩⟧
--{ num := i, denom := 1,

/-meta def num_denum.to_expr : rat.num_denum → expr
| (num, ⟨denum, _⟩) := `((rat.of_int %%(int.reflect num)) / (rat.of_int (%%(int.reflect denum)) : ℚ))

meta def num_denum_to_expr_wf : Π a b : rat.num_denum, rat.rel a b → num_denum.to_expr a = num_denum.to_expr b := sorry

meta def rat.to_expr  :=
quot.lift num_denum.to_expr num_denum_to_expr_wf

meta instance rat.reflect : has_reflect rat :=
λ q, unchecked_cast $ q.to_expr
-/

private meta def nat_to_rat_expr : nat → expr | n :=
if n = 0 then `(0 : ℚ)
else if n = 1 then `(1 : ℚ)
else if n % 2 = 0 then `(@bit0 ℚ _ %%(nat_to_rat_expr (n/2)))
else `(@bit1 ℚ _ _ %%(nat_to_rat_expr (n/2)))

private meta def int_to_rat_expr : int → expr | n :=
if n = 0 then `(0 : ℚ)
else if n < 0 then `(-%%(int_to_rat_expr (-n)) : ℚ)
else if n = 1 then `(1 : ℚ)
else if n % 2 = 0 then `(@bit0 ℚ _ %%(int_to_rat_expr (n/2)))
else `(@bit1 ℚ _ _ %%(int_to_rat_expr (n/2)))

meta def rat.to_expr (q : ℚ) : expr :=
if q.denom = 1 then
  `(%%(int_to_rat_expr q.num) : ℚ)
else
  `(%%(int_to_rat_expr q.num) / %%(nat_to_rat_expr q.denom) : ℚ)
--`(rat.mk_nat %%(int.reflect q.num) %%(nat.reflect q.denom))

meta instance rat.reflect : has_reflect rat :=
λ q, unchecked_cast $ q.to_expr

section
open nat

theorem gcd_ne_zero_right (a : ℕ) {b : ℕ} (hb : b ≠ 0) : gcd a b ≠ 0 :=
assume : gcd a b = 0,
have gcd a b ∣ b, from gcd_dvd_right _ _,
have 0 ∣ b, by cc,
have b = 0, from eq_zero_of_zero_dvd this,
by contradiction

end

def sign {α} [decidable_linear_ordered_comm_ring α] (a : α) : α :=
if a < 0 then (-1) else if a = 0 then 0 else 1
/-
section
open int
def int.gcd : ℤ → ℤ → ℤ
| (of_nat k1) (of_nat k2) := of_nat (nat.gcd k1 k2)
| (of_nat k1) (neg_succ_of_nat k2) := of_nat (nat.gcd k1 (k2+1))
| (neg_succ_of_nat k1) (of_nat k2) := of_nat (nat.gcd (k1+1) k2)
| (neg_succ_of_nat k1) (neg_succ_of_nat k2) := of_nat (nat.gcd (k1+1) (k2+1))

/-def int.sign : ℤ → ℤ
--| (of_nat 0) := 0
| (of_nat k) := if k = 0 then 0 else 1
| (neg_succ_of_nat _) := -1-/

/-def int.div : ℤ → ℤ → ℤ
| (of_nat k1) (of_nat k2) := of_nat (k1 / k2)
| (of_nat k1) (neg_succ_of_nat k2) := neg_succ_of_nat (k1 / (k2+1))
| (neg_succ_of_nat k1) (of_nat k2) := neg_succ_of_nat ((k1) / k2)
| (neg_succ_of_nat k1) (neg_succ_of_nat k2) := of_nat ((k1+1) / (k2+1))-/

def int.div (a b : ℤ) : ℤ :=
sign b *
  (match a with
    | of_nat m := of_nat (m / (nat_abs b))
    | -[1+m]   := -[1+ ((m:nat) / (nat_abs b))]
  end)

instance : has_div int := ⟨int.div⟩

theorem int.of_nat_ne_zero_of_ne_zero {n : ℕ} (h : n ≠ 0) : of_nat n ≠ 0 :=
suppose of_nat n = of_nat 0,
by cc

@[ematch]
theorem int_gcd_ne_zero_right : Π (a : ℤ) {b : ℤ} (h : b ≠ 0), int.gcd a b ≠ 0 :=
begin
intros,
induction a,
all_goals {induction b; apply int.of_nat_ne_zero_of_ne_zero; apply gcd_ne_zero_right; finish}
end

theorem int.gcd_pos_of_ne_right (a : ℤ) {b : ℤ} (h : b ≠ 0) : int.gcd a b > 0 :=
begin
induction a,
all_goals {induction b; unfold int.gcd; apply of_nat_p},

end
/-

variable P : ℕ → Prop
theorem f : Π (h : P 0) (h2 : ∀ n, P n → P (n+1)), Π (n : ℕ), P n
| h h2 0 := sorry --begin try {do n ← decl_name, interactive.clear [n]}; finish end
| h h2 (k+1) := begin apply h2, apply f, apply h, apply h2 end

theorem int_gcd_ne_zero_right' : Π (a : ℤ) {b : ℤ} (h : b ≠ 0), int.gcd a b ≠ 0 :=
begin
intros,
cases a; cases b,
safe [int_gcd_ne_zero_right],
-/

/-| (of_nat k1) (of_nat k2) h := begin safe end
| (of_nat k1) (neg_succ_of_nat k2) h := sorry
| (neg_succ_of_nat k1) (of_nat k2) h := sorry
| (neg_succ_of_nat k1) (neg_succ_of_nat k2) h := sorry
 -/

def num_denum.reduce : rat.num_denum → rat.num_denum | (num, ⟨denum, _⟩) :=
let g := int.gcd num denum in
(num/g, ⟨denum/g, begin end⟩)-/

/-set_option pp.all true
run_cmd  tactic.trace $ (↑`(-5 : ℤ) : expr)
meta example (z : ℤ) : reflected z := by apply_instance
-/

/-
| n := if n = 0 then unchecked_cast `(0 : nat)
       else if n % 2 = 0 then unchecked_cast $ `(λ n : nat, bit0 n).subst (nat.reflect (n / 2))
       else unchecked_cast $ `(λ n : nat, bit1 n).subst (nat.reflect (n / 2))
-/
-- make this more efficient. Why did it disappear?
--meta instance : has_to_pexpr ℕ := ⟨λ n, nat.rec_on n ``(0) (λ _ k, ``(%%k + 1))⟩

--meta instance : has_to_pexpr ℤ :=
--⟨λ z, int.rec_on z (λ k, ``(%%k)) (λ k, ``(-(%%(k)+1)))⟩

/-meta def num_denum_format : rat.num_denum → format
| (num, ⟨denum, _⟩) :=
if num = 0 then "0"
--else if denum = 1 then to_fmt num
else to_fmt num ++ "/" ++ to_fmt denum
-/

/-meta def num_denum_quote : rat.num_denum → pexpr
| (num, ⟨denum, _⟩) := ``(%%(to_pexpr num)/%%(to_pexpr denum))-/

--meta def num_denum_format_wf : Π a b : rat.num_denum, rat.rel a b → num_denum_format a = num_denum_format b := sorry

--meta def num_denum_quote_wf : Π a b : rat.num_denum, rat.rel a b → num_denum_quote a = num_denum_quote b := sorry

meta def rat.to_string (q : ℚ) : string :=
if q.denom = 1 then
  to_string q.num
else
  to_string q.num ++ " / " ++ to_string q.denom

meta def rat.to_format (q : ℚ) : format :=
/-if q.denom = 1 then
  to_fmt q.num
else
  to_fmt q.num ++ " / " ++ to_fmt q.denom-/
rat.to_string q

/-meta instance : has_to_pexpr ℚ :=
⟨quot.lift num_denum_quote num_denum_quote_wf⟩
-/

def rat.pow (q : ℚ) : ℤ → ℚ
| (int.of_nat n) := q^n
| -[1+n] := 1/(q^(n+1))

--def rat.pow (q : ℚ) (z : ℤ) : ℚ :=
--if q = 1 then q else if z = 1 then q else rat.pow_aux q z

lemma rat.mul_pow_neg_one {q : ℚ} (h : q ≠ 0) : q * (rat.pow q (-1)) = 1 :=
begin
change (-1 : ℤ) with -[1+0],
simp [rat.pow, mul_inv_cancel h]
end

lemma rat.pow_neg_one {q : ℚ} : rat.pow q (-1) = 1 / q :=
begin
change (-1 : ℤ) with -[1+0],
simp [rat.pow]
end

lemma rat.pow_one {q : ℚ} : rat.pow q 1 = q :=
begin
change (1 : ℤ) with int.of_nat 1,
simp [rat.pow]
end

lemma rat.pow_pow (a : ℚ) (z1 z2 : ℤ) : rat.pow (rat.pow a z1) z2 = rat.pow a (z1*z2) := sorry

lemma rat.one_div_pow (q : ℚ) (z : ℤ) : rat.pow (1/q) z = rat.pow q (-z) := sorry

namespace int
open nat
/-protected def div : ℤ → ℤ → ℤ
| (m : ℕ) (n : ℕ) := of_nat (m / n)
| (m : ℕ) -[1+ n] := -of_nat (m / succ n)
| -[1+ m] 0       := 0
| -[1+ m] (n+1:ℕ) := -[1+ m / succ n]
| -[1+ m] -[1+ n] := of_nat (succ (m / succ n))

instance : has_div int := ⟨int.div⟩

-/
theorem exists_eq_of_nat {z : ℤ} (h : z ≥ 0) : ∃ n : ℕ, z = n :=
match int.le.dest h with
| ⟨n, pr⟩ := ⟨n, by clear _match; finish⟩
end

end int

theorem nat.one_lt_pow_of_one_lt {x n : ℕ} (h : 1 < x) (hn : n > 0) : 1 < nat.pow x n :=
have h : nat.pow 1 n = 1, from nat.one_pow _,
begin
rw ←h, apply nat.pow_lt_pow_of_lt_left,
repeat {assumption}
end

theorem rat.one_pow : Π (n : ℤ), rat.pow 1 n = 1
| (int.of_nat n) := by simp [rat.pow]
| -[1+n] := by simp [rat.pow, one_inv_eq]

theorem rat.mul_pow (q r : ℚ) : Π (z : ℤ), rat.pow (q*r) z = rat.pow q z * rat.pow r z
| (int.of_nat n) := mul_pow _ _ _
| -[1+n] := begin unfold rat.pow, rw [mul_pow, div_mul_eq_div_mul_one_div] end

theorem rat.mul_pow_rev (q r : ℚ) (z : ℤ) : rat.pow q z * rat.pow r z = rat.pow (q*r) z := by simp [rat.mul_pow]

def rat.order : ℚ → ℚ → ordering :=
λ a b, if a < b then ordering.lt else if a = b then ordering.eq else ordering.gt

def int.order : ℤ → ℤ → ordering :=
λ a b, if a < b then ordering.lt else if a = b then ordering.eq else ordering.gt


#exit

-- so every polynomial has a GCD? Shouldn't there be some restriction on α
--axiom gcd_ax : ∀ a b : polynomial α,( ∃( d : polynomial α ), (is_gcd a b d))

--@[instance] constant polynomial.has_gcd : has_gcd (polynomial α)

--def monic (p : polynomial α) : Prop := leading_coeff p = 1
--Assume has_gcd on polynomials
 --∈ set.range (units.val : _ → polynomial α)

--We need to define the radical and the number of distinct roots of a polynomial
--First define roots

structure roots_of (a : polynomial α):= --Can this be made as a set directly?
(val : α)(h1 : root_of a val)

def roots_of_as_set (a : polynomial α) := set_of (root_of a)
--Can we proof this set is finite?

--Can I define the radical?

--Proof linear factor iff root, makes use of the division algorithm. Hence that polynomials are a euclidian ring.

section field

variable β : Type u

variable [field β] --Again an anoying diamond porblem with field to UFD

open finsupp

def lin_fac {β : Type u} [field β] (q : β) : polynomial β := X - C q

lemma deg_ln_fac {q : β} : degree (X + (- C q)) = 1 :=
have one_le_deg : 1 ≤ degree (X + (- C q)), from
    have h1: ((X : polynomial β) + (- C q)) 1 = (1:β),  -- Type annotation is needed here, otherwise + will fail.
    begin
      show (X : polynomial β) 1 + - (C q : polynomial β) 1 = (1:β),
      rw [X, single_eq_same, C, single_eq_of_ne]; simp
    end,
    have ((X : polynomial β) + (- C q)) 1 ≠ 0, from calc
        ((X : polynomial β) + (- C q)) 1 = 1 : h1
        ... ≠ 0 : one_ne_zero,
    le_degree this,
have ((0 : β ) ≠ (1 : β)), from zero_ne_one,
have h_deg_X : degree X = 1, from  degree_X this,
have degree (C q) = 0, from degree_C,
have h_deg_neg_C :degree (- C q) = 0, by rw [degree_neg, this],
have ha: degree (X + (- C q)) ≤ 1, from
  calc
    degree (X + (- C q)) ≤ max (degree (X)) (degree (- C q)) : degree_add
    ... ≤ max 1 0 : by rw [h_deg_X, h_deg_neg_C ]
    ... = 1 : max_eq_left zero_le_one,
have 1 ≤ degree (X + (- C q)), from (one_le_deg),
show degree (X + (- C q)) = 1, from le_antisymm ha this

open euclidean_domain

lemma degree_ne_zero_ne_zero2 {f : polynomial β } : degree f ≠ 0 → f ≠ 0 :=--I want to apply normal by_cpntradiction here, but I don't know how to apply that, due to ambiguous overload.
begin intro, apply (@classical.by_contradiction (f ≠ 0) _), intro,
have h3: (f = 0), from iff.elim_left (@not_not _ (classical.prop_decidable _)) a_1,
have h4: degree f = 0, calc degree f = degree 0 : by rw [h3] ... = 0 : degree_zero,
apply a h4
 end

/- NOT USED:

--Why is there no instance for has subtract?
lemma root_iff_lin_fac : ∀p : polynomial β, ∀k:β, (root_of p k) ↔ (X - C k ∣ p) :=
begin intros, apply iff.intro,
{intro, --apply (exists.elim a), intros,
  -- have h1 : 1 ≠ 0, from dec_trivial,
  have h2 :  degree (X + (- (C k ))) ≠ 0,
  from calc degree (X + (- (C k))) = 1 : @deg_ln_fac _ _ k
  ... ≠ 0 : one_ne_zero,
  have h3 : (X + (- (C k))) ≠ 0,
    from degree_ne_zero_ne_zero2 _ h2,
  --Mogelijk gaat deze fout omdat het lemma niet was gedefinieerd voor een integral domain.
  --Lemma is gedefinieerd voor semiring, maar mogelijk is het niet zo dat de integral domain kan worden omgezet in een semiring?
  -- Ik zie dat er wel een instance is met naar comm_semi_ring vanaf comm_ring. En een comm_semiring is een ring.
  have h4 : (∃ q : polynomial β, ∃ r : polynomial β ,( (p = q *  (X + (- (C k))) + r) ∧ ((r = 0) ∨
     ( (norm r ) < (norm (X + (- (C k))))) )  ) ),
  apply @h_norm (polynomial β) _ p (X + (- (C k))) (degree_ne_zero_ne_zero2 β  h2) , --dom.h p (X + (- (C α))) h3
  --Er gaat gebeurt iets geks met de type universes, want degree h2, zit in type universe max 1 (u+1), en de andere zir in (u+1).
  --Of mogelijk heeft het te maken met field, integral_domain enzovoort. Maar snapt ie zelf dan niet dat max 1 (1+u) = 1 + u?
  --Mogelijk gaat het fout door het gebruik van de classical axioms, en dat je dat dan overal moet doen?? Zie maar degree_ne_zero2
admit
} , {admit} end

-/

lemma finite_roots {a : polynomial β} : set.finite (roots_of_as_set a):= sorry --How do we do an induction on the degree?

end field


import condensed.ab
import rescale.pseudo_normed_group
import hacks_and_tricks.asyncI
import for_mathlib.Profinite.extend
import facts.nnreal

.

noncomputable theory

universe u

open_locale nnreal
open category_theory

namespace comphaus_filtered_pseudo_normed_group

def of_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale 1 M) M :=
{ continuous' := λ c, comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * 1⁻¹) c,
  .. rescale.of_rescale_one_strict_pseudo_normed_group_hom M
}

def to_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom M (rescale 1 M) :=
{ continuous' := λ c, begin
    haveI : fact (c ≤ c * 1⁻¹) := ⟨le_of_eq (by rw [inv_one, mul_one])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le c (c * 1⁻¹),
  end,
  .. rescale.to_rescale_one_strict_pseudo_normed_group_hom M
}

def of_rescale_eq_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M]
  (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] (hrr' : r = r') :
strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M) (rescale r' M) :=
{ continuous' := λ c, begin
  haveI : fact (c * r⁻¹ ≤ c * r'⁻¹) := ⟨le_of_eq (by rw hrr')⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹) (c * r'⁻¹),
  end,
  .. rescale.of_rescale_eq_strict_pseudo_normed_group_hom  r r' M hrr',
}

def of_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale r (rescale r' M)) (rescale (r' * r) M) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * r⁻¹ * r'⁻¹ ≤ c * (r' * r)⁻¹) :=
      ⟨le_of_eq (by rw [nnreal.mul_inv, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹ * r'⁻¹) _,
  end,
  ..rescale.of_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

def to_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale (r' * r) M) (rescale r (rescale r' M)) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * (r' * r)⁻¹ ≤ c * r⁻¹ * r'⁻¹) :=
      ⟨le_of_eq (by rw [nnreal.mul_inv, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * (r' * r)⁻¹) _,
  end,
  ..rescale.to_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

end comphaus_filtered_pseudo_normed_group

namespace CompHausFiltPseuNormGrp

@[simps]
def rescale (r : ℝ≥0) : CompHausFiltPseuNormGrp ⥤ CompHausFiltPseuNormGrp :=
{ obj := λ M, of (rescale r M),
  map := λ M₁ M₂ f, rescale.map_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

def rescale_iso_component (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp) :
  (rescale r).obj M ≅ M :=
{ hom :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    refine ⟨r⁻¹, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw mul_comm },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw mul_comm, apply_instance }
  end,
  inv :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    have hr : r ≠ 0 := ne_of_gt (fact.out _),
    refine ⟨r, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      dsimp, erw rescale.mem_filtration,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw [mul_comm, inv_mul_cancel_left₀ hr], },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw [mul_comm, inv_mul_cancel_left₀ hr], apply_instance }
  end,
  hom_inv_id' := by { intros, ext, refl },
  inv_hom_id' := by { intros, ext, refl } }

def rescale_iso (r : ℝ≥0) [fact (0 < r)] : rescale r ≅ 𝟭 _ :=
nat_iso.of_components (rescale_iso_component r) $ λ _ _ _, rfl

-- instance (X : Profinite) (c : ℝ≥0) [fact (0 < c)] :
--   limits.preserves_limits (rescale c) :=
-- limits.preserves_limits_of_nat_iso (rescale_iso c).symm

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
limits.preserves_limits_of_shape_of_nat_iso (rescale_iso c).symm

def rescale₁ (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp)
  (exh : ∀ m : M, ∃ c, m ∈ pseudo_normed_group.filtration M c) :
  CompHausFiltPseuNormGrp₁ :=
{ M := _root_.rescale r M,
  exhaustive' := λ m, begin
    obtain ⟨c, hc⟩ := exh (rescale.of.symm m),
    simp only [rescale.mem_filtration],
    refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
    rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
  end }

end CompHausFiltPseuNormGrp

namespace CompHausFiltPseuNormGrp₁

@[simps]
def rescale (r : ℝ≥0) [fact (0 < r)] : CompHausFiltPseuNormGrp₁ ⥤ CompHausFiltPseuNormGrp₁ :=
{ obj := λ M,
  { M := rescale r M,
    exhaustive' := λ m, begin
      obtain ⟨c, hc⟩ := M.exhaustive (rescale.of.symm m),
      simp only [rescale.mem_filtration],
      refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
      rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
    end },
  map := λ M₁ M₂ f, rescale.map_strict_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

instance rescale.equivalence (r : ℝ≥0) [fact (0 < r)] :
  is_equivalence (rescale r) :=
by haveI : fact (0 < r⁻¹) := ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩;
   haveI : fact (0 < r * r⁻¹) := ⟨mul_pos (fact.elim infer_instance) (fact.elim infer_instance)⟩;
exactI
is_equivalence.mk (@rescale r⁻¹ ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩)
{ hom :=
  { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r * r⁻¹) M ⟶ rescale r⁻¹ (rescale r M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r⁻¹ r M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r * r⁻¹)
      (eq.symm (mul_inv_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
    naturality' := λ M N f, rfl,
  },
  inv :=
  { app := λ M,
    -- rescale r⁻¹ (rescale r M) ⟶ rescale (r * r⁻¹) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r * r⁻¹) 1
      ((mul_inv_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r⁻¹ r M)),
    naturality' := λ M N f, rfl },
  hom_inv_id' := rfl,
  inv_hom_id' := rfl }
  { hom :=
    { app := λ M,
    -- rescale r (rescale r⁻¹ M) ⟶ rescale (r⁻¹ * r) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r⁻¹ * r) 1
      ((inv_mul_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r r⁻¹ M)),
      naturality' := λ M N f, rfl },
    inv :=
    { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r⁻¹ * r) M ⟶ rescale r (rescale r⁻¹ M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r r⁻¹ M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r⁻¹ * r)
      (eq.symm (inv_mul_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
      naturality' := λ M N f, rfl },
    hom_inv_id' := rfl,
    inv_hom_id' := rfl }

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
begin
  let foo := (category_theory.adjunction.is_equivalence_preserves_limits
    (rescale c)).preserves_limits_of_shape,
  exact foo, -- not 100% sure why I need to define foo first
end

@[simps]
def rescale_enlarging_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ CHFPNG₁_to_CHFPNGₑₗ ≅ CHFPNG₁_to_CHFPNGₑₗ :=
begin
  refine _ ≪≫ (iso_whisker_left _ (CompHausFiltPseuNormGrp.rescale_iso r))
    ≪≫ functor.right_unitor _,
  exact nat_iso.of_components (λ M, iso.refl _) (λ _ _ _, rfl),
end

@[simps]
def rescale_to_Condensed_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ to_Condensed ≅
  CHFPNG₁_to_CHFPNGₑₗ ⋙ CompHausFiltPseuNormGrp.rescale r ⋙ CompHausFiltPseuNormGrp.to_Condensed :=
nat_iso.of_components (λ M, iso.refl _) $ λ _ _ _, rfl

-- @[simps]
-- def strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⟶ 𝟭 _ :=
-- { app := λ M, comphaus_filtered_pseudo_normed_group.strict_unscale M r,
--   naturality' := by { intros, ext, refl, } }

-- def Condensed_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⋙ to_Condensed ⟶ to_Condensed :=
-- whisker_right (strict_unscale r) to_Condensed ≫ (functor.left_unitor _).hom

-- instance is_iso_strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] (M) :
--   is_iso ((Condensed_unscale r).app M) :=
-- begin
--   admit
-- end

end CompHausFiltPseuNormGrp₁

namespace comphaus_filtered_pseudo_normed_group_hom

def strictify (M₁ M₂ : Type*)
  [comphaus_filtered_pseudo_normed_group M₁] [comphaus_filtered_pseudo_normed_group M₂]
  (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂)
  (r : ℝ≥0) [fact (0 < r)]
  (hf : f.bound_by r) :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M₁) M₂ :=
strict_comphaus_filtered_pseudo_normed_group_hom.mk' (f.to_add_monoid_hom)
begin
  intro c,
  refine ⟨λ x hx, pseudo_normed_group.filtration_mono _ (hf hx), f.continuous _ (λ _, rfl)⟩,
  have hr : r ≠ 0 := ne_of_gt (fact.out _),
  rw [mul_left_comm, mul_inv_cancel hr, mul_one],
end

end comphaus_filtered_pseudo_normed_group_hom

open CompHausFiltPseuNormGrp₁

def strictify_nat_trans {C : Type*} [category C] {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  F ⋙ CompHausFiltPseuNormGrp₁.rescale.{u u} c ⟶ G :=
{ app := λ X, comphaus_filtered_pseudo_normed_group_hom.strictify _ _ (α.app X) c (h X),
  naturality' := λ X Y f, begin
    ext x, have := α.naturality f, apply_fun (λ φ, φ.to_fun x) at this, exact this
  end }

lemma strictify_nat_trans_enlarging {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ =
  (functor.associator _ _ _).hom ≫ whisker_left F (rescale_enlarging_iso c).hom ≫ α :=
begin
  ext, refl,
end

@[simp]
lemma strictify_nat_trans_enlarging' {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_left F (rescale_enlarging_iso.{u u} c).inv ≫ (functor.associator _ _ _).inv ≫
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ = α :=
begin
  ext, refl,
end

-- move me
instance preadditive_CompHausFiltPseuNormGrp : preadditive CompHausFiltPseuNormGrp.{u} :=
{ hom_group := λ M N, by apply_instance,
  add_comp' := by { intros X Y Z f₁ f₂ g, ext, exact g.map_add _ _ },
  comp_add' := by { intros, ext, refl } }

section

variables {F G H : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (α β : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
variables (c cα cβ cαβ : ℝ≥0) [fact (0 < c)] [fact (0 < cα)] [fact (0 < cβ)] [fact (0 < cαβ)]

def nonstrict_extend (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (h : ∀ X, (α.app X).bound_by c) :
  Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend.{u} G ⋙ CHFPNG₁_to_CHFPNGₑₗ :=
whisker_left (Profinite.extend F) (rescale_enlarging_iso.{u u} c).inv ≫
whisker_right ((Profinite.extend_commutes _ _).hom ≫
  Profinite.extend_nat_trans.{u} (strictify_nat_trans α c h)) CHFPNG₁_to_CHFPNGₑₗ

-- move me
attribute [reassoc] whisker_left_comp whisker_right_comp

lemma nonstrict_extend_whisker_left (h : ∀ X, (α.app X).bound_by c) :
  whisker_left Fintype.to_Profinite (nonstrict_extend.{u} α c h) =
  (functor.associator _ _ _).inv ≫
  whisker_right (Profinite.extend_extends.{u} F).hom CHFPNG₁_to_CHFPNGₑₗ.{u} ≫ α ≫
  whisker_right (Profinite.extend_extends.{u} G).inv CHFPNG₁_to_CHFPNGₑₗ.{u} ≫
  (functor.associator _ _ _).hom :=
begin
  rw [nonstrict_extend, whisker_right_comp, whisker_left_comp, whisker_left_comp,
    ← whisker_right_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left,
    whisker_right_comp, whisker_right_comp, strictify_nat_trans_enlarging,
    ← category_theory.whisker_right_comp_assoc, Profinite.extend_commutes_comp_extend_extends],
  refl,
end
.

lemma nonstrict_extend_bound_by (h : ∀ X, (α.app X).bound_by c) (X : Profinite.{u}) :
  ((nonstrict_extend α c h).app X).bound_by c :=
begin
  conv begin congr, skip, rw ← one_mul c, end, -- can't get nth_rewrite to work
  refine comphaus_filtered_pseudo_normed_group_hom.bound_by.comp (λ r m hm, _) _,
  { rw mul_comm,
    rwa (show r = r * c * c⁻¹, begin
      rw [mul_assoc, mul_inv_cancel (ne_of_gt (fact.elim infer_instance)), mul_one];
      apply_instance,
    end) at hm },
  { rw [← one_mul (1 : ℝ≥0), whisker_right_comp],
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one },
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one } },
end

lemma nonstrict_extend_ext'
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (hα : ∀ X, (α.app X).bound_by c) (hβ : ∀ X, (β.app X).bound_by c)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  suffices : strictify_nat_trans α c hα = strictify_nat_trans β c hβ,
  { rw [← strictify_nat_trans_enlarging' α c hα, ← strictify_nat_trans_enlarging' β c hβ, this] },
  rw ← cancel_epi (Profinite.extend_commutes F (CompHausFiltPseuNormGrp₁.rescale.{u u} c)).inv,
  apply Profinite.extend_nat_trans_ext,
  simp only [whisker_left_comp, cancel_epi],
  refine ((whiskering_right _ _ _).obj CHFPNG₁_to_CHFPNGₑₗ.{u}).map_injective _,
  simp only [whiskering_right_obj_map, whisker_right_left,
    strictify_nat_trans_enlarging, whisker_left_comp, h],
end

-- move me
instance fact_max_pos : fact (0 < max cα cβ) := ⟨lt_max_iff.mpr (or.inl $ fact.out _)⟩

lemma nonstrict_extend_mono (c₁ c₂ : ℝ≥0) [fact (0 < c₁)] [fact (0 < c₂)]
  (h₁ : ∀ X, (α.app X).bound_by c₁) (h₂ : ∀ X, (α.app X).bound_by c₂) :
  nonstrict_extend α c₁ h₁ = nonstrict_extend α c₂ h₂ :=
begin
  refine nonstrict_extend_ext' _ _ (max c₁ c₂) _ _ _,
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_left _ _), },
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_right _ _), },
  { simp only [nonstrict_extend_whisker_left], }
end

lemma nonstrict_extend_ext
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (cα : ℝ≥0) [fact (0 < cα)] (cβ : ℝ≥0) [fact (0 < cβ)]
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  refine nonstrict_extend_ext' _ _ (max cα cβ) _ _ h,
  { intro X, refine (hα X).mono _ (le_max_left _ _), },
  { intro X, refine (hβ X).mono _ (le_max_right _ _), },
end

-- move me
instance fact_add_pos (c₁ c₂ : ℝ≥0) [h₁ : fact (0 < c₁)] [h₂ : fact (0 < c₂)] :
  fact (0 < c₁ + c₂) :=
⟨add_pos h₁.1 h₂.1⟩

lemma nonstrict_extend_map_add (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α + β).app X).bound_by cαβ) :
  nonstrict_extend (α + β) cαβ hαβ = nonstrict_extend α cα hα + nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_add],
    exact (nonstrict_extend_bound_by _ _ _ X).add (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_add],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.add_comp, preadditive.comp_add,
      nat_trans.app_add, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_neg
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((-α).app X).bound_by cβ) :
  nonstrict_extend (-α) cβ hβ = -nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ cα _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X, apply (nonstrict_extend_bound_by _ _ _ _).neg, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_neg],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.neg_comp, preadditive.comp_neg,
      nat_trans.app_neg, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_sub (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α - β).app X).bound_by cαβ) :
  nonstrict_extend (α - β) cαβ hαβ = nonstrict_extend α cα hα - nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_sub],
    exact (nonstrict_extend_bound_by _ _ _ X).sub (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_sub],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.sub_comp, preadditive.comp_sub,
      nat_trans.app_sub, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], },
end

lemma nonstrict_extend_map_nsmul (n : ℕ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((n • α).app X).bound_by cβ) :
  nonstrict_extend (n • α) cβ hβ = n • nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ (1 + n * cα) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_nsmul],
    exact ((nonstrict_extend_bound_by _ _ _ _).nsmul _).mono _ le_add_self, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_nsmul],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.nsmul_comp, preadditive.comp_nsmul,
      nat_trans.app_nsmul, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_comp
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (β : G ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ H ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α ≫ β).app X).bound_by cαβ) :
  nonstrict_extend (α ≫ β) cαβ hαβ = nonstrict_extend α cα hα ≫ nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα * cβ) (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X,
    rw mul_comm,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { exact nonstrict_extend_bound_by α cα hα X },
    { exact nonstrict_extend_bound_by β cβ hβ X } },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc], }
end

lemma nonstrict_extend_id
  (hα : ∀ X, (nat_trans.app (𝟙 (F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u})) X).bound_by cα) :
  nonstrict_extend (𝟙 _) cα hα = 𝟙 _ :=
begin
  refine nonstrict_extend_ext _ _ cα 1 (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X, exact comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _ },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv, category.id_comp,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc, whisker_left_id'],
    refl, }
end

lemma nonstrict_extend_whisker_right_enlarging (α : F ⟶ G) :
  nonstrict_extend (whisker_right α CHFPNG₁_to_CHFPNGₑₗ) 1
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) =
  whisker_right (Profinite.extend_nat_trans α) _ :=
begin
  refine nonstrict_extend_ext _ _ 1 1 (nonstrict_extend_bound_by _ _ _)
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) _,
  rw [nonstrict_extend_whisker_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left],
  refl
end

end


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

/-!
A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
whose forgetful functors both reflect isomorphisms, itself reflects isomorphisms.
-/

universes u

namespace category_theory

instance : reflects_isomorphisms (forget (Type u)) :=
{ reflects := λ X Y f i, i }

variables (C : Type (u+1)) [category C] [concrete_category.{u} C]
variables (D : Type (u+1)) [category D] [concrete_category.{u} D]

/--
A `forget₂ C D` forgetful functor between concrete categories `C` and `D`
where `forget C` reflects isomorphisms, itself reflects isomorphisms.
-/
-- This should not be an instance, as it causes a typeclass loop
-- with `category_theory.has_forget_to_Type`
lemma reflects_isomorphisms_forget₂ [has_forget₂ C D] [reflects_isomorphisms (forget C)] :
  reflects_isomorphisms (forget₂ C D) :=
{ reflects := λ X Y f i,
  begin
    resetI,
    haveI i' : is_iso ((forget D).map ((forget₂ C D).map f)) := functor.map_is_iso (forget D) _,
    haveI : is_iso ((forget C).map f) :=
    begin
      have := has_forget₂.forget_comp,
      dsimp at this,
      rw ←this,
      exact i',
    end,
    apply is_iso_of_reflects_iso f (forget C),
  end }

end category_theory


/- -----------------------------------------------------------------------
Dependent products in LeanCat.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits
import ..c3_wtypes

import .s1_basic

namespace qp

open stdaux

universe variables ℓ ℓobjx ℓhomx

/- -----------------------------------------------------------------------
The dependent product functor.
----------------------------------------------------------------------- -/

/-! #brief The dependent product functor on objects.
-/
definition LeanCat.DepProdFun.obj {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S : OverObj LeanCat.{ℓ} B)
    : OverObj LeanCat.{ℓ} A
:= { obj := @coproduct LeanCat A
              (λ a, @product LeanCat {b : B // disp b = a}
                      (λ b, { x : S^.obj // S^.hom x = b^.val})
                      (LeanCat.HasProduct.{ℓ ℓ} _))
              (LeanCat.HasCoProduct.{ℓ ℓ} _)
   , hom := sigma.fst
   }

-- /-! #brief Function induced toward the dependent product of a monic.
-- -/
-- definition LeanCat.DepProdFun.obj.monic_to {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     [disp_Monic : @Monic LeanCat.{ℓ} B A disp]
--     (S : OverObj LeanCat.{ℓ} B)
--     (s : S^.obj)
--     : (LeanCat.DepProdFun.obj disp S)^.obj
-- := { fst := disp (S^.hom s)
--    , snd := λ b
--             , { val := s
--               , property := eq.symm (LeanCat.Monic.inj disp_Monic b^.property)
--               }
--    }

-- /-! #brief Function induced from the dependent product of a (strong) epic.
-- -/
-- definition LeanCat.DepProdFun.obj.epic_from.upon {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     {ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A}
--     (S : OverObj LeanCat.{ℓ} B)
--     (af : (LeanCat.DepProdFun.obj disp S)^.obj)
--     : {b // disp b = af^.fst}
-- := { val := undisp af^.fst
--    , property := congr_fun ωdisp_undisp af^.fst
--    }

-- /-! #brief Function induced from the dependent product of a (strong) epic.
-- -/
-- definition LeanCat.DepProdFun.obj.epic_from {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     (ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A)
--     (S : OverObj LeanCat.{ℓ} B)
--     (af : (LeanCat.DepProdFun.obj disp S)^.obj)
--     : S^.obj
-- := (af^.snd (@LeanCat.DepProdFun.obj.epic_from.upon B A disp undisp ωdisp_undisp S af))^.val

-- /-! #brief The dependent product functor is trivial on isos.
-- -/
-- definition LeanCat.DepProdFun.obj.Iso {B A : LeanCat.{ℓ}^.obj}
--     (disp : LeanCat.{ℓ}^.hom B A)
--     [disp_Monic : @Monic LeanCat.{ℓ} B A disp]
--     (undisp : LeanCat.{ℓ}^.hom A B)
--     (ωdisp_undisp : LeanCat.{ℓ}^.circ disp undisp = LeanCat.{ℓ}^.id A)
--     (S : OverObj LeanCat.{ℓ} B)
--     : @Iso LeanCat.{ℓ} _ _
--         (LeanCat.DepProdFun.obj.monic_to disp S)
--         (LeanCat.DepProdFun.obj.epic_from disp undisp ωdisp_undisp S)
-- := { id₁ := rfl
--    , id₂ := begin
--               apply funext,
--               intro a,
--               cases a with a f,
--               unfold LeanCat SortCat,
--               dsimp,
--               unfold LeanCat.DepProdFun.obj.monic_to,
--               unfold LeanCat.DepProdFun.obj.epic_from,
--               exact sorry
--             end
--    }

/-! #brief The dependent product functor on functions.
-/
definition LeanCat.DepProdFun.hom {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    {S₀ S₁ : OverObj LeanCat.{ℓ} B}
    (f : OverHom LeanCat.{ℓ} B S₀ S₁)
    : OverHom LeanCat.{ℓ} A
       (@LeanCat.DepProdFun.obj B A disp S₀)
       (@LeanCat.DepProdFun.obj B A disp S₁)
:= let a : (LeanCat.DepProdFun.obj disp S₀)^.obj → A
        := λ σ
           , σ^.fst
in let s₁ : ∀ (σ : (LeanCat.DepProdFun.obj disp S₀)^.obj)
              (b : {b // disp b = a σ})
            , S₁^.obj
         := λ σ b
            , f^.hom (σ^.snd b)^.val
in let ωs₁ : ∀ (σ : (LeanCat.DepProdFun.obj disp S₀)^.obj)
               (b : {b // disp b = a σ})
             , S₁^.hom (s₁ σ b) = b^.val
          := λ σ b
             , begin
                 apply eq.trans (congr_fun (eq.symm f^.triangle) (σ^.snd b)),
                 apply (σ^.snd b)^.property
               end
in { hom
      := λ σ, { fst := a σ
              , snd := λ b, { val := s₁ σ b, property := ωs₁ σ b }
              }
   , triangle := rfl
   }

/-! #brief The dependent product functor preserves identity functions.
-/
definition LeanCat.DepProdFun.hom_id {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S : OverObj LeanCat.{ℓ} B)
    : LeanCat.DepProdFun.hom disp (OverHom.id LeanCat.{ℓ} B S)
       = OverHom.id LeanCat.{ℓ} A (LeanCat.DepProdFun.obj disp S)
:= begin
     apply OverHom.eq,
     apply funext, intro σ,
     cases σ with a f,
     apply congr_arg (sigma.mk a),
     apply funext, intro b,
     apply subtype.eq,
     trivial
   end

/-! #brief The dependent product functor distributes over composition.
-/
definition LeanCat.DepProdFun.hom_comp {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    (S₁ S₂ S₃ : OverObj LeanCat.{ℓ} B)
    (g : OverHom LeanCat.{ℓ} B S₂ S₃)
    (f : OverHom LeanCat.{ℓ} B S₁ S₂)
    : LeanCat.DepProdFun.hom disp (OverHom.comp LeanCat.{ℓ} B _ _ _ g f)
       = OverHom.comp LeanCat.{ℓ} A _ _ _ (LeanCat.DepProdFun.hom disp g) (LeanCat.DepProdFun.hom disp f)
:= begin
     apply OverHom.eq,
     apply funext, intro σ,
     cases σ with a h,
     apply congr_arg (sigma.mk a),
     apply funext, intro b,
     apply subtype.eq,
     trivial
   end

/-! #brief The dependent product functor.
-/
definition LeanCat.DepProdFun {B A : LeanCat.{ℓ}^.obj}
    (disp : LeanCat.{ℓ}^.hom B A)
    : Fun (OverCat LeanCat.{ℓ} B) (OverCat LeanCat.{ℓ} A)
:= { obj := LeanCat.DepProdFun.obj disp
   , hom := @LeanCat.DepProdFun.hom B A disp
   , hom_id := LeanCat.DepProdFun.hom_id disp
   , hom_circ := LeanCat.DepProdFun.hom_comp disp
   }

-- /- -----------------------------------------------------------------------
-- The dependent product functor is right adjoint to base change.
-- ----------------------------------------------------------------------- -/

/-! #brief Component of the counit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.counit_com
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (X : OverObj LeanCat.{ℓ} x)
    : OverHom LeanCat.{ℓ} x
        (BaseChangeFun.obj f (LeanCat.DepProdFun.obj f X))
        X
:= { hom := λ Z
            , let pb₀ := pullback.π LeanCat.{ℓ} (f ↗→ (LeanCat.DepProdFun.obj f X)^.hom ↗→↗) (@fin_of 1 0) Z
           in let pb₁ := (pullback.π LeanCat.{ℓ} (f ↗→ (LeanCat.DepProdFun.obj f X)^.hom ↗→↗) (@fin_of 0 1) Z)^.snd
              in (pb₁ { val := pb₀, property := sorry })^.val
   , triangle := sorry
   }

/-! #brief Counit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.counit
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : NatTrans (@BaseChangeFun LeanCat.{ℓ} x y f (HasAllPullbacks.HasPullbacksAlong LeanCat _) □□ LeanCat.DepProdFun f)
               (Fun.id (OverCat LeanCat.{ℓ} x))
:= { com := LeanCat.BaseChange_DepProd.Adj.counit_com f
   , natural := sorry
   }

/-! #brief Cone used to define the component of the unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit_com.cone
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    (Yy : OverObj.dom Y)
    (Xx : {b // f b = Y^.hom Yy})
    : PullbackCone LeanCat.{ℓ} (f ↗→ Y^.hom ↗→↗)
:= @PullbackCone.mk LeanCat.{ℓ} _ _
    (f ↗→ Y^.hom ↗→↗) {b // f b = Y^.hom Yy}
    (λ Xx, f Xx^.val) (subtype.val ↗← (λ Xx, Yy) ↗←↗)
    begin
      apply dlist.eq,
      { trivial },
      apply dlist.eq,
      { apply funext, intro Xx, cases Xx with Xx ωXx,
        exact sorry
      }
      , trivial
    end

/-! #brief Component of the unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit_com
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    : OverHom LeanCat.{ℓ} y
        Y
        (LeanCat.DepProdFun.obj f (BaseChangeFun.obj f Y))
:= { hom := λ Yy, { fst := Y^.hom Yy
                  , snd := λ Xx
                           , { val := pullback.univ LeanCat.{ℓ}
                                       (f ↗→ Y^.hom ↗→↗)
                                       (LeanCat.BaseChange_DepProd.Adj.unit_com.cone f Y Yy Xx) Xx
                             , property := sorry
                             }
                  }
   , triangle := sorry
   }

/-! #brief Unit of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
definition LeanCat.BaseChange_DepProd.Adj.unit
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : NatTrans (Fun.id (OverCat LeanCat.{ℓ} y))
               (LeanCat.DepProdFun f □□ @BaseChangeFun LeanCat.{ℓ} x y f (HasAllPullbacks.HasPullbacksAlong _ _))
:= { com := LeanCat.BaseChange_DepProd.Adj.unit_com f
   , natural := sorry
   }

/-! #brief Left-identity of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
theorem LeanCat.BaseChange_DepProd.Adj.id_left
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (Y : OverObj LeanCat.{ℓ} y)
    : OverHom.comp LeanCat x _ _ _
        (LeanCat.BaseChange_DepProd.Adj.counit_com f (BaseChangeFun.obj f Y))
        (BaseChangeFun.hom f _ _ (LeanCat.BaseChange_DepProd.Adj.unit_com f Y))
       = OverHom.id LeanCat x (BaseChangeFun.obj f Y)
:= sorry

/-! #brief Right-identity of the BaseChangeFun/LeanCat.DepProdFun adjunction.
-/
theorem LeanCat.BaseChange_DepProd.Adj.id_right
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    (X : OverObj LeanCat.{ℓ} x)
    : OverHom.comp LeanCat y _ _ _
        (LeanCat.DepProdFun.hom f (LeanCat.BaseChange_DepProd.Adj.counit_com f X))
        (LeanCat.BaseChange_DepProd.Adj.unit_com f (LeanCat.DepProdFun.obj f X))
       = OverHom.id LeanCat y (LeanCat.DepProdFun.obj f X)
:= sorry

/-! #brief BaseChangeFun and LeanCat.DepProdFun are adjoint.
-/
definition LeanCat.BaseChange_DepProd.Adj
    {x y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom x y)
    : Adj (LeanCat.BaseChangeFun f)
          (LeanCat.DepProdFun f)
:= { counit := LeanCat.BaseChange_DepProd.Adj.counit f
   , unit := LeanCat.BaseChange_DepProd.Adj.unit f
   , id_left := LeanCat.BaseChange_DepProd.Adj.id_left f
   , id_right := LeanCat.BaseChange_DepProd.Adj.id_right f
   }

/-! #brief LeanCat has dependent product.
-/
instance LeanCat.HasDepProd {X Y : LeanCat.{ℓ}^.obj}
    (f : LeanCat.{ℓ}^.hom X Y)
    : HasDepProd LeanCat.{ℓ} f
:= { depprod := LeanCat.DepProdFun f
   , adj := LeanCat.BaseChange_DepProd.Adj f
   }

/-! #brief LeanCat has all dependent products.
-/
instance LeanCat.HasAllDepProd
    : HasAllDepProd LeanCat.{ℓ}
:= { has_depprod := λ x y f, LeanCat.HasDepProd f
   }

/- -----------------------------------------------------------------------
Existence of W-types in LeanCat.
----------------------------------------------------------------------- -/

definition LeanCat.DepProdFun.PresCoLimit.hom
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    (L : Fun NatCat (OverCat LeanCat P^.dom))
     : OverHom LeanCat P^.codom
        ((LeanCat.DepProdFun P^.hom)^.obj (colimit L))
        (colimit (LeanCat.DepProdFun P^.hom □□ L))
:= sorry

definition LeanCat.DepProdFun.PresCoLimit
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    (L : Fun NatCat (OverCat LeanCat P^.dom))
    : PresCoLimit L (LeanCat.DepProdFun P^.hom)
:= PresCoLimit.show
    (λ L_HasCoLimit C hom ωhom
     , let ccone : CoCone (LeanCat.DepProdFun P^.hom □□ L)
                := CoCone.mk C hom @ωhom
       in (OverCat LeanCat P^.codom)^.circ
           ((OverCat LeanCat P^.codom)^.circ
              (@colimit.univ _ _ _ (LeanCat.Over.HasCoLimit _ _) ccone)
              (LeanCat.DepProdFun.PresCoLimit.hom P ωP L))
           ((LeanCat.DepProdFun P^.hom)^.hom (colimit.iso L_HasCoLimit (LeanCat.Over.HasCoLimit P^.dom L))))
    sorry
    sorry

definition LeanCat.HasWType
    (P : PolyEndoFun LeanCat.{ℓ})
    (ωP : ∀ (a : P^.codom), FinType { b : P^.dom // P^.hom b = a })
    : HasWType LeanCat P
:= HasWType.Adamek LeanCat P
    { pres_colimit := LeanCat.DepProdFun.PresCoLimit P ωP }

end qp


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin, Bhavik Mehta
-/
import category_theory.isomorphism
import category_theory.functor.category
import category_theory.eq_to_hom

/-!
# Comma categories

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

A comma category is a construction in category theory, which builds a category out of two functors
with a common codomain. Specifically, for functors `L : A ⥤ T` and `R : B ⥤ T`, an object in
`comma L R` is a morphism `hom : L.obj left ⟶ R.obj right` for some objects `left : A` and
`right : B`, and a morphism in `comma L R` between `hom : L.obj left ⟶ R.obj right` and
`hom' : L.obj left' ⟶ R.obj right'` is a commutative square

```
L.obj left   ⟶   L.obj left'
      |               |
  hom |               | hom'
      ↓               ↓
R.obj right  ⟶   R.obj right',
```

where the top and bottom morphism come from morphisms `left ⟶ left'` and `right ⟶ right'`,
respectively.

## Main definitions

* `comma L R`: the comma category of the functors `L` and `R`.
* `over X`: the over category of the object `X` (developed in `over.lean`).
* `under X`: the under category of the object `X` (also developed in `over.lean`).
* `arrow T`: the arrow category of the category `T` (developed in `arrow.lean`).

## References

* <https://ncatlab.org/nlab/show/comma+category>

## Tags

comma, slice, coslice, over, under, arrow
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ v₅ u₁ u₂ u₃ u₄ u₅
variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]
variables {T : Type u₃} [category.{v₃} T]

/-- The objects of the comma category are triples of an object `left : A`, an object
   `right : B` and a morphism `hom : L.obj left ⟶ R.obj right`.  -/
structure comma (L : A ⥤ T) (R : B ⥤ T) : Type (max u₁ u₂ v₃) :=
(left : A)
(right : B)
(hom : L.obj left ⟶ R.obj right)

-- Satisfying the inhabited linter
instance comma.inhabited [inhabited T] : inhabited (comma (𝟭 T) (𝟭 T)) :=
{ default :=
  { left := default,
    right := default,
    hom := 𝟙 default } }

variables {L : A ⥤ T} {R : B ⥤ T}

/-- A morphism between two objects in the comma category is a commutative square connecting the
    morphisms coming from the two objects using morphisms in the image of the functors `L` and `R`.
-/
@[ext] structure comma_morphism (X Y : comma L R) :=
(left : X.left ⟶ Y.left)
(right : X.right ⟶ Y.right)
(w' : L.map left ≫ Y.hom = X.hom ≫ R.map right . obviously)

-- Satisfying the inhabited linter
instance comma_morphism.inhabited [inhabited (comma L R)] :
  inhabited (comma_morphism (default : comma L R) default) :=
⟨⟨𝟙 _, 𝟙 _⟩⟩

restate_axiom comma_morphism.w'
attribute [simp, reassoc] comma_morphism.w

instance comma_category : category (comma L R) :=
{ hom := comma_morphism,
  id := λ X,
  { left := 𝟙 X.left,
    right := 𝟙 X.right },
  comp := λ X Y Z f g,
  { left := f.left ≫ g.left,
    right := f.right ≫ g.right } }

namespace comma

section
variables {X Y Z : comma L R} {f : X ⟶ Y} {g : Y ⟶ Z}

@[simp] lemma id_left  : ((𝟙 X) : comma_morphism X X).left = 𝟙 X.left := rfl
@[simp] lemma id_right : ((𝟙 X) : comma_morphism X X).right = 𝟙 X.right := rfl
@[simp] lemma comp_left  : (f ≫ g).left  = f.left ≫ g.left   := rfl
@[simp] lemma comp_right : (f ≫ g).right = f.right ≫ g.right := rfl

end

variables (L) (R)

/-- The functor sending an object `X` in the comma category to `X.left`. -/
@[simps]
def fst : comma L R ⥤ A :=
{ obj := λ X, X.left,
  map := λ _ _ f, f.left }

/-- The functor sending an object `X` in the comma category to `X.right`. -/
@[simps]
def snd : comma L R ⥤ B :=
{ obj := λ X, X.right,
  map := λ _ _ f, f.right }

/-- We can interpret the commutative square constituting a morphism in the comma category as a
    natural transformation between the functors `fst ⋙ L` and `snd ⋙ R` from the comma category
    to `T`, where the components are given by the morphism that constitutes an object of the comma
    category. -/
@[simps]
def nat_trans : fst L R ⋙ L ⟶ snd L R ⋙ R :=
{ app := λ X, X.hom }

@[simp] lemma eq_to_hom_left (X Y : comma L R) (H : X = Y) :
  comma_morphism.left (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

@[simp] lemma eq_to_hom_right (X Y : comma L R) (H : X = Y) :
  comma_morphism.right (eq_to_hom H) = eq_to_hom (by { cases H, refl }) := by { cases H, refl }

section
variables {L₁ L₂ L₃ : A ⥤ T} {R₁ R₂ R₃ : B ⥤ T}

/--
Construct an isomorphism in the comma category given isomorphisms of the objects whose forward
directions give a commutative square.
-/
@[simps]
def iso_mk {X Y : comma L₁ R₁} (l : X.left ≅ Y.left) (r : X.right ≅ Y.right)
  (h : L₁.map l.hom ≫ Y.hom = X.hom ≫ R₁.map r.hom) : X ≅ Y :=
{ hom := { left := l.hom, right := r.hom },
  inv :=
  { left := l.inv,
    right := r.inv,
    w' := begin
      rw [←L₁.map_iso_inv l, iso.inv_comp_eq, L₁.map_iso_hom, reassoc_of h, ← R₁.map_comp],
      simp
    end, } }

/-- A natural transformation `L₁ ⟶ L₂` induces a functor `comma L₂ R ⥤ comma L₁ R`. -/
@[simps]
def map_left (l : L₁ ⟶ L₂) : comma L₂ R ⥤ comma L₁ R :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := l.app X.left ≫ X.hom },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `L` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_left_id : map_left R (𝟙 L) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L₁ R ⥤ comma L₃ R` induced by the composition of two natural transformations
    `l : L₁ ⟶ L₂` and `l' : L₂ ⟶ L₃` is naturally isomorphic to the composition of the two functors
    induced by these natural transformations. -/
@[simps]
def map_left_comp (l : L₁ ⟶ L₂) (l' : L₂ ⟶ L₃) :
  (map_left R (l ≫ l')) ≅ (map_left R l') ⋙ (map_left R l) :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- A natural transformation `R₁ ⟶ R₂` induces a functor `comma L R₁ ⥤ comma L R₂`. -/
@[simps]
def map_right (r : R₁ ⟶ R₂) : comma L R₁ ⥤ comma L R₂ :=
{ obj := λ X,
  { left  := X.left,
    right := X.right,
    hom   := X.hom ≫ r.app X.right },
  map := λ X Y f,
  { left  := f.left,
    right := f.right } }

/-- The functor `comma L R ⥤ comma L R` induced by the identity natural transformation on `R` is
    naturally isomorphic to the identity functor. -/
@[simps]
def map_right_id : map_right L (𝟙 R) ≅ 𝟭 _ :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

/-- The functor `comma L R₁ ⥤ comma L R₃` induced by the composition of the natural transformations
    `r : R₁ ⟶ R₂` and `r' : R₂ ⟶ R₃` is naturally isomorphic to the composition of the functors
    induced by these natural transformations. -/
@[simps]
def map_right_comp (r : R₁ ⟶ R₂) (r' : R₂ ⟶ R₃) :
  (map_right L (r ≫ r')) ≅ (map_right L r) ⋙ (map_right L r') :=
{ hom :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } },
  inv :=
  { app := λ X, { left := 𝟙 _, right := 𝟙 _ } } }

end

section
variables {C : Type u₄} [category.{v₄} C] {D : Type u₅} [category.{v₅} D]

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_left (F: C ⥤ A) (L : A ⥤ T) (R : B ⥤ T) : comma (F ⋙ L) R ⥤ comma L R :=
{ obj := λ X, { left := F.obj X.left, right := X.right, hom := X.hom },
  map := λ X Y f, { left := F.map f.left, right := f.right, w' := by simpa using f.w } }

/-- The functor `(F ⋙ L, R) ⥤ (L, R)` -/
@[simps] def pre_right (L : A ⥤ T) (F: C ⥤ B) (R : B ⥤ T) : comma L (F ⋙ R) ⥤ comma L R :=
{ obj := λ X, { left := X.left, right := F.obj X.right, hom := X.hom },
  map := λ X Y f, { left := f.left, right := F.map f.right, w' := by simp } }

/-- The functor `(L, R) ⥤ (L ⋙ F, R ⋙ F)` -/
@[simps] def post (L : A ⥤ T) (R : B ⥤ T) (F: T ⥤ C) : comma L R ⥤ comma (L ⋙ F) (R ⋙ F) :=
{ obj := λ X, { left := X.left, right := X.right, hom := F.map X.hom },
  map := λ X Y f, { left := f.left, right := f.right, w' :=
    by { simp only [functor.comp_map, ←F.map_comp, f.w] } } }

end
end comma

end category_theory


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

import lib.tactic
import lib.pretty_print

open tactic

meta def forward_attribute : user_attribute := {
  name := `forward,
  descr := "A lemma whose conclusion should be deduced whenever all arguments are satisfiable from hypotheses; use `forwards_reasoning` to automatically try all lemmas tagged `@[forward]`."
}

run_cmd attribute.register `forward_attribute

/- Improvements:

* Store the local_context, and its types, rather than recomputing.
* Give up earlier if our current expression is obviously still just a hypothesis.
* Don't use dsimplify; does it still work?
  * If not, try using whnf
* In mk_apps, `to_expr` is probably too expensive. Can we get away with just the second option?
* In the second option, `mk_app_aux`, either delete the instance implicit branch, and hope unify
  handles typeclass inference for us later, or make do typeclass inference by hand, using `apply_instance`

For testing, we better be able to run against lean-category-theory...
-/

meta def guard_no_duplicate_hypothesis (t : expr) : tactic unit :=
do hyps ← local_context,
   types ← hyps.mmap (λ h, infer_type h),
   success_if_fail (types.mfirst (λ s, is_def_eq s t))

meta def guard_prop (e : expr) : tactic unit :=
do t ← infer_type e,
   guard (t = `(Prop))

meta def attempt_forwards_reasoning (only_props : bool) (s : simp_lemmas) : list (expr × list string) → tactic string
| [] := fail "forwards_reasoning failed"
| (e :: es) := do
    t ← infer_type e.1,
    t' ← try_core (s.dsimplify [] t), -- FIXME too expensive
    let changed := t'.is_some,
    let t := t'.get_or_else t,
    if t.is_pi then
      do hyps ← local_context,
         apps ← mk_apps e.1 hyps,
         apps ← apps.mmap (λ p, do h_pp ← pretty_print p.2, return (p.1, list.cons h_pp e.2)),
         attempt_forwards_reasoning (apps ++ es)
    else (do if only_props then guard_prop t else skip,
             guard_no_duplicate_hypothesis t,
             let n := "_".intercalate e.2.reverse,
             assertv n t e.1,
             term ← pretty_print e.1,
             -- TODO sometimes this reported tactic won't work, and we need to write instead
             -- `have n : t := by convert term`
             return ("have " ++ n ++ " := " ++ term)
             ) <|> attempt_forwards_reasoning es

/-- Attempt to `have` a lemma marked with the attribute @[forward], whose conclusion is not yet known and whose arguments can be filled in by hypotheses. -/
meta def forwards_library_reasoning : tactic string :=
do cs ← attribute.get_instances `forward,
   es ← cs.mmap (λ n, (do e ← mk_const n, let s := n.components.ilast.to_string, return (e, [s]))),
   s ← mk_simp_set ff [] [],
   attempt_forwards_reasoning ff s.1 es

/-- Attempt to `have` a result obtained by applying one hypothesis to others, as long as the conclusion is propositional, is not yet known, and has no further arguments. -/
meta def forwards_reasoning : tactic string :=
do hyps ← local_context,
   es ← hyps.mmap (λ e, (do s ← pretty_print e, return (e, [s]))),
   s ← mk_simp_set ff [] [],
   attempt_forwards_reasoning tt s.1 es

attribute [forward] congr_fun


import data.matrix.block

namespace matrix
open_locale matrix
variables {l m α R : Type*}
variables [decidable_eq l] [decidable_eq m]

section has_zero
variables [has_zero α]

lemma to_block_diagonal_self (d : m → α) (p : m → Prop) :
  matrix.to_block (diagonal d) p p = diagonal (λ i : subtype p, d ↑i) :=
begin
  ext i j,
  by_cases i = j,
  { simp [h] },
  { simp [has_one.one, h, λ h', h $ subtype.ext h'], }
end

lemma to_block_diagonal_disjoint (d : m → α) {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (diagonal d) p q = 0 :=
begin
  ext ⟨i, hi⟩ ⟨j, hj⟩,
  have : i ≠ j, from λ heq, hpq i ⟨hi, heq.symm ▸ hj⟩,
  simp [diagonal_apply_ne d this]
end

end has_zero

section has_zero_has_one
variables [has_zero α] [has_one α]

lemma to_block_one_self (p : m → Prop) : matrix.to_block (1 : matrix m m α) p p = 1 :=
to_block_diagonal_self _ p

lemma to_block_one_disjoint {p q : m → Prop} (hpq : disjoint p q) :
  matrix.to_block (1 : matrix m m α) p q = 0 :=
to_block_diagonal_disjoint _ hpq

end has_zero_has_one

section
variables [comm_ring R]

lemma to_block_mul_eq_mul {m n k : Type*} [fintype n] (p : m → Prop) (q : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p q = A.to_block p ⊤ ⬝ B.to_block ⊤ q :=
begin
  ext i k,
  simp only [to_block_apply, mul_apply],
  rw finset.sum_subtype,
  simp [has_top.top, complete_lattice.top, bounded_order.top],
end

lemma to_block_mul_eq_add
  {m n k : Type*} [fintype n] (p : m → Prop) (q : n → Prop) [decidable_pred q] (r : k → Prop)
  (A : matrix m n R) (B : matrix n k R) :
  (A ⬝ B).to_block p r =
    A.to_block p q ⬝ B.to_block q r + A.to_block p (λ i, ¬ q i) ⬝ B.to_block (λ i, ¬ q i) r :=
begin
  classical,
  ext i k,
  simp only [to_block_apply, mul_apply, pi.add_apply],
  convert (fintype.sum_subtype_add_sum_subtype q (λ x, A ↑i x * B x ↑k)).symm
end

end

end matrix


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.group.ext
import category_theory.simple
import category_theory.linear.basic
import category_theory.endomorphism
import algebra.algebra.spectrum

/-!
# Schur's lemma
We first prove the part of Schur's Lemma that holds in any preadditive category with kernels,
that any nonzero morphism between simple objects
is an isomorphism.

Second, we prove Schur's lemma for `𝕜`-linear categories with finite dimensional hom spaces,
over an algebraically closed field `𝕜`:
the hom space `X ⟶ Y` between simple objects `X` and `Y` is at most one dimensional,
and is 1-dimensional iff `X` and `Y` are isomorphic.
-/

namespace category_theory

open category_theory.limits

variables {C : Type*} [category C]
variables [preadditive C]

-- See also `epi_of_nonzero_to_simple`, which does not require `preadditive C`.
lemma mono_of_nonzero_from_simple [has_kernels C] {X Y : C} [simple X] {f : X ⟶ Y} (w : f ≠ 0) :
  mono f :=
preadditive.mono_of_kernel_zero (kernel_zero_of_nonzero_from_simple w)

/--
The part of **Schur's lemma** that holds in any preadditive category with kernels:
that a nonzero morphism between simple objects is an isomorphism.
-/
lemma is_iso_of_hom_simple [has_kernels C] {X Y : C} [simple X] [simple Y] {f : X ⟶ Y} (w : f ≠ 0) :
  is_iso f :=
begin
  haveI := mono_of_nonzero_from_simple w,
  exact is_iso_of_mono_of_nonzero w
end

/--
As a corollary of Schur's lemma for preadditive categories,
any morphism between simple objects is (exclusively) either an isomorphism or zero.
-/
lemma is_iso_iff_nonzero [has_kernels C] {X Y : C} [simple X] [simple Y] (f : X ⟶ Y) :
  is_iso f ↔ f ≠ 0 :=
⟨λ I,
  begin
    introI h,
    apply id_nonzero X,
    simp only [←is_iso.hom_inv_id f, h, zero_comp],
  end,
  λ w, is_iso_of_hom_simple w⟩

/--
In any preadditive category with kernels,
the endomorphisms of a simple object form a division ring.
-/
noncomputable
instance [has_kernels C] {X : C} [simple X] : division_ring (End X) :=
by classical; exact
{ inv := λ f, if h : f = 0 then 0 else by { haveI := is_iso_of_hom_simple h, exact inv f, },
  exists_pair_ne := ⟨𝟙 X, 0, id_nonzero _⟩,
  inv_zero := dif_pos rfl,
  mul_inv_cancel := λ f h, begin
    haveI := is_iso_of_hom_simple h,
    convert is_iso.inv_hom_id f,
    exact dif_neg h,
  end,
  ..(infer_instance : ring (End X)) }

open finite_dimensional

section
variables (𝕜 : Type*) [division_ring 𝕜]

/--
Part of **Schur's lemma** for `𝕜`-linear categories:
the hom space between two non-isomorphic simple objects is 0-dimensional.
-/
lemma finrank_hom_simple_simple_eq_zero_of_not_iso
  [has_kernels C] [linear 𝕜 C] {X Y : C} [simple X] [simple Y]
  (h : (X ≅ Y) → false):
  finrank 𝕜 (X ⟶ Y) = 0 :=
begin
  haveI := subsingleton_of_forall_eq (0 : X ⟶ Y) (λ f, begin
    have p := not_congr (is_iso_iff_nonzero f),
    simp only [not_not, ne.def] at p,
    refine p.mp (λ _, by exactI h (as_iso f)),
  end),
  exact finrank_zero_of_subsingleton,
end

end

variables (𝕜 : Type*) [field 𝕜]
variables [is_alg_closed 𝕜] [linear 𝕜 C]

-- In the proof below we have some difficulty using `I : finite_dimensional 𝕜 (X ⟶ X)`
-- where we need a `finite_dimensional 𝕜 (End X)`.
-- These are definitionally equal, but without eta reduction Lean can't see this.
-- To get around this, we use `convert I`,
-- then check the various instances agree field-by-field,

/--
An auxiliary lemma for Schur's lemma.

If `X ⟶ X` is finite dimensional, and every nonzero endomorphism is invertible,
then `X ⟶ X` is 1-dimensional.
-/
-- We prove this with the explicit `is_iso_iff_nonzero` assumption,
-- rather than just `[simple X]`, as this form is useful for
-- Müger's formulation of semisimplicity.
lemma finrank_endomorphism_eq_one
  {X : C} (is_iso_iff_nonzero : ∀ f : X ⟶ X, is_iso f ↔ f ≠ 0)
  [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
begin
  have id_nonzero := (is_iso_iff_nonzero (𝟙 X)).mp (by apply_instance),
  apply finrank_eq_one (𝟙 X),
  { exact id_nonzero, },
  { intro f,
    haveI : nontrivial (End X) := nontrivial_of_ne _ _ id_nonzero,
    obtain ⟨c, nu⟩ := @spectrum.nonempty_of_is_alg_closed_of_finite_dimensional 𝕜 (End X) _ _ _ _ _
      (by { convert I, ext, refl, ext, refl, }) (End.of f),
    use c,
    rw [spectrum.mem_iff, is_unit.sub_iff, is_unit_iff_is_iso, is_iso_iff_nonzero, ne.def,
      not_not, sub_eq_zero, algebra.algebra_map_eq_smul_one] at nu,
    exact nu.symm, },
end

variables [has_kernels C]

/--
**Schur's lemma** for endomorphisms in `𝕜`-linear categories.
-/
lemma finrank_endomorphism_simple_eq_one
  (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  finrank 𝕜 (X ⟶ X) = 1 :=
finrank_endomorphism_eq_one 𝕜 is_iso_iff_nonzero

lemma endomorphism_simple_eq_smul_id
  {X : C} [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] (f : X ⟶ X) :
  ∃ c : 𝕜, c • 𝟙 X = f :=
(finrank_eq_one_iff_of_nonzero' (𝟙 X) (id_nonzero X)).mp (finrank_endomorphism_simple_eq_one 𝕜 X) f

/--
Endomorphisms of a simple object form a field if they are finite dimensional.
This can't be an instance as `𝕜` would be undetermined.
-/
noncomputable
def field_End_of_finite_dimensional (X : C) [simple X] [I : finite_dimensional 𝕜 (X ⟶ X)] :
  field (End X) :=
by classical; exact
{ mul_comm := λ f g, begin
    obtain ⟨c, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 f,
    obtain ⟨d, rfl⟩ := endomorphism_simple_eq_smul_id 𝕜 g,
    simp [←mul_smul, mul_comm c d],
  end,
  ..(infer_instance : division_ring (End X)) }

/--
**Schur's lemma** for `𝕜`-linear categories:
if hom spaces are finite dimensional, then the hom space between simples is at most 1-dimensional.

See `finrank_hom_simple_simple_eq_one_iff` and `finrank_hom_simple_simple_eq_zero_iff` below
for the refinements when we know whether or not the simples are isomorphic.
-/
-- There is a symmetric argument that uses `[finite_dimensional 𝕜 (Y ⟶ Y)]` instead,
-- but we don't bother proving that here.
lemma finrank_hom_simple_simple_le_one
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) ≤ 1 :=
begin
  cases subsingleton_or_nontrivial (X ⟶ Y) with h,
  { resetI,
    rw finrank_zero_of_subsingleton,
    exact zero_le_one },
  { obtain ⟨f, nz⟩ := (nontrivial_iff_exists_ne 0).mp h,
    haveI fi := (is_iso_iff_nonzero f).mpr nz,
    apply finrank_le_one f,
    intro g,
    obtain ⟨c, w⟩ := endomorphism_simple_eq_smul_id 𝕜 (g ≫ inv f),
    exact ⟨c, by simpa using w =≫ f⟩, },
end

lemma finrank_hom_simple_simple_eq_one_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 1 ↔ nonempty (X ≅ Y) :=
begin
  fsplit,
  { intro h,
    rw finrank_eq_one_iff' at h,
    obtain ⟨f, nz, -⟩ := h,
    rw ←is_iso_iff_nonzero at nz,
    exactI ⟨as_iso f⟩, },
  { rintro ⟨f⟩,
    have le_one := finrank_hom_simple_simple_le_one 𝕜 X Y,
    have zero_lt : 0 < finrank 𝕜 (X ⟶ Y) :=
      finrank_pos_iff_exists_ne_zero.mpr ⟨f.hom, (is_iso_iff_nonzero f.hom).mp infer_instance⟩,
    linarith, }
end

lemma finrank_hom_simple_simple_eq_zero_iff
  (X Y : C) [finite_dimensional 𝕜 (X ⟶ X)] [finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = 0 ↔ is_empty (X ≅ Y) :=
begin
  rw [← not_nonempty_iff, ← not_congr (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y)],
  refine ⟨λ h, by { rw h, simp, }, λ h, _⟩,
  have := finrank_hom_simple_simple_le_one 𝕜 X Y,
  interval_cases finrank 𝕜 (X ⟶ Y) with h',
  { exact h', },
  { exact false.elim (h h'), },
end

open_locale classical

lemma finrank_hom_simple_simple
  (X Y : C) [∀ X Y : C, finite_dimensional 𝕜 (X ⟶ Y)] [simple X] [simple Y] :
  finrank 𝕜 (X ⟶ Y) = if nonempty (X ≅ Y) then 1 else 0 :=
begin
  split_ifs,
  exact (finrank_hom_simple_simple_eq_one_iff 𝕜 X Y).2 h,
  exact (finrank_hom_simple_simple_eq_zero_iff 𝕜 X Y).2 (not_nonempty_iff.mp h),
end

end category_theory