-- Copyright (c) 2014 Floris van Doorn. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Author: Floris van Doorn

-- This file contains basic constructions on categories, including common categories

import .natural_transformation
import data.unit data.sigma data.prod data.empty data.bool

open eq eq.ops prod
namespace category
  namespace opposite
  section
  definition opposite [reducible] {ob : Type} (C : category ob) : category ob :=
  mk (λa b, hom b a)
     (λ a b c f g, g ∘ f)
     (λ a, id)
     (λ a b c d f g h, symm !assoc)
     (λ a b f, !id_right)
     (λ a b f, !id_left)

  definition Opposite [reducible] (C : Category) : Category := Mk (opposite C)
  --direct construction:
  -- MK C
  --    (λa b, hom b a)
  --    (λ a b c f g, g ∘ f)
  --    (λ a, id)
  --    (λ a b c d f g h, symm !assoc)
  --    (λ a b f, !id_right)
  --    (λ a b f, !id_left)

  infixr `∘op`:60 := @comp _ (opposite _) _ _ _

  variables {C : Category} {a b c : C}

  theorem compose_op {f : hom a b} {g : hom b c} : f ∘op g = g ∘ f := rfl

  theorem op_op' {ob : Type} (C : category ob) : opposite (opposite C) = C :=
  category.rec (λ hom comp id assoc idl idr, refl (mk _ _ _ _ _ _)) C

  definition op_op : Opposite (Opposite C) = C :=
  (@congr_arg _ _ (@opposite C (@opposite C C)) _ (Category.mk C) (op_op' C)) ⬝ !Category.equal

  end
  end opposite

  definition type_category [reducible] : category Type :=
  mk (λa b, a → b)
     (λ a b c, function.comp)
     (λ a, _root_.id)
     (λ a b c d h g f, symm (function.comp.assoc h g f))
     (λ a b f, function.comp.left_id f)
     (λ a b f, function.comp.right_id f)

  definition Type_category [reducible] : Category := Mk type_category

  section
  open decidable unit empty
  variables {A : Type} [H : decidable_eq A]
  include H
  definition set_hom [reducible] (a b : A) := decidable.rec_on (H a b) (λh, unit) (λh, empty)
  theorem set_hom_subsingleton [instance] (a b : A) : subsingleton (set_hom a b) := rec_subsingleton
  definition set_compose [reducible] {a b c : A} (g : set_hom b c) (f : set_hom a b) : set_hom a c :=
  decidable.rec_on
    (H b c)
    (λ Hbc g, decidable.rec_on
      (H a b)
      (λ Hab f, rec_on_true (trans Hab Hbc) ⋆)
      (λh f, empty.rec _ f) f)
    (λh (g : empty), empty.rec _ g) g
  omit H
  definition discrete_category (A : Type) [H : decidable_eq A] : category A :=
  mk (λa b, set_hom a b)
     (λ a b c g f, set_compose g f)
     (λ a, decidable.rec_on_true rfl ⋆)
     (λ a b c d h g f, @subsingleton.elim (set_hom a d) _ _ _)
     (λ a b f, @subsingleton.elim (set_hom a b) _ _ _)
     (λ a b f, @subsingleton.elim (set_hom a b) _ _ _)
  local attribute discrete_category [reducible]
  definition Discrete_category (A : Type) [H : decidable_eq A] := Mk (discrete_category A)
    section
    local attribute discrete_category [instance]
    include H
    theorem discrete_category.endomorphism {a b : A} (f : a ⟶ b) : a = b :=
    decidable.rec_on (H a b) (λh f, h) (λh f, empty.rec _ f) f

    theorem discrete_category.discrete {a b : A} (f : a ⟶ b)
      : eq.rec_on (discrete_category.endomorphism f) f = (ID b) :=
    @subsingleton.elim _ !set_hom_subsingleton _ _

    definition discrete_category.rec_on {P : Πa b, a ⟶ b → Type} {a b : A} (f : a ⟶ b)
        (H : ∀a, P a a id) : P a b f :=
    cast (dcongr_arg3 P rfl (discrete_category.endomorphism f)⁻¹
                            (@subsingleton.elim _ !set_hom_subsingleton _ _))⁻¹ (H a)
    end
  end
  section
  open unit bool
  definition category_one := discrete_category unit
  definition Category_one := Mk category_one
  definition category_two := discrete_category bool
  definition Category_two := Mk category_two
  end

  namespace product
    section
    open prod
    definition prod_category [reducible] {obC obD : Type} (C : category obC) (D : category obD)
        : category (obC × obD) :=
    mk (λa b, hom (pr1 a) (pr1 b) × hom (pr2 a) (pr2 b))
       (λ a b c g f, (pr1 g ∘ pr1 f , pr2 g ∘ pr2 f) )
       (λ a, (id,id))
       (λ a b c d h g f, pair_eq !assoc    !assoc   )
       (λ a b f,         prod.eq !id_left  !id_left )
       (λ a b f,         prod.eq !id_right !id_right)

    definition Prod_category [reducible] (C D : Category) : Category := Mk (prod_category C D)
    end
  end product

  namespace ops
    notation `type`:max := Type_category
    postfix `ᵒᵖ`:max := opposite.Opposite
    infixr `×c`:30 := product.Prod_category
    attribute type_category [instance]
    attribute category_one [instance]
    attribute category_two [instance]
    attribute product.prod_category [instance]
  end ops

  open ops
  namespace opposite
  section
  open functor
  definition opposite_functor [reducible] {C D : Category} (F : C ⇒ D) : Cᵒᵖ ⇒ Dᵒᵖ :=
  @functor.mk (Cᵒᵖ) (Dᵒᵖ)
              (λ a, F a)
              (λ a b f, F f)
              (λ a, respect_id F a)
              (λ a b c g f, by apply @respect_comp C D)
  end
  end opposite

  namespace product
  section
  open ops functor
  definition prod_functor [reducible] {C C' D D' : Category} (F : C ⇒ D) (G : C' ⇒ D')
      : C ×c C' ⇒ D ×c D' :=
  functor.mk (λ a, pair (F (pr1 a)) (G (pr2 a)))
             (λ a b f, pair (F (pr1 f)) (G (pr2 f)))
             (λ a, pair_eq !respect_id !respect_id)
             (λ a b c g f, pair_eq !respect_comp !respect_comp)
  end
  end product

  namespace ops
  infixr `×f`:30 := product.prod_functor
  infixr `ᵒᵖᶠ`:max := opposite.opposite_functor
  end ops

  section functor_category
  variables (C D : Category)
  definition functor_category : category (functor C D) :=
  mk (λa b, natural_transformation a b)
     (λ a b c g f, natural_transformation.compose g f)
     (λ a, natural_transformation.id)
     (λ a b c d h g f, !natural_transformation.assoc)
     (λ a b f, !natural_transformation.id_left)
     (λ a b f, !natural_transformation.id_right)
  end functor_category

  namespace slice
  open sigma function
  variables {ob : Type} {C : category ob} {c : ob}
  protected definition slice_obs (C : category ob) (c : ob) := Σ(b : ob), hom b c
  variables {a b : slice.slice_obs C c}
  protected definition to_ob  (a : slice.slice_obs C c) : ob              := sigma.pr1 a
  protected definition to_ob_def (a : slice.slice_obs C c) : slice.to_ob a = sigma.pr1 a := rfl
  protected definition ob_hom (a : slice.slice_obs C c) : hom (slice.to_ob a) c := sigma.pr2 a
  -- protected theorem slice_obs_equal (H₁ : to_ob a = to_ob b)
  --     (H₂ : eq.drec_on H₁ (ob_hom a) = ob_hom b) : a = b :=
  -- sigma.equal H₁ H₂

  protected definition slice_hom (a b : slice.slice_obs C c) : Type :=
  Σ(g : hom (slice.to_ob a) (slice.to_ob b)), slice.ob_hom b ∘ g = slice.ob_hom a

  protected definition hom_hom  (f : slice.slice_hom a b) : hom (slice.to_ob a) (slice.to_ob b)                := sigma.pr1 f
  protected definition commute (f : slice.slice_hom a b) : slice.ob_hom b ∘ (slice.hom_hom f) = slice.ob_hom a := sigma.pr2 f
  -- protected theorem slice_hom_equal (f g : slice_hom a b) (H : hom_hom f = hom_hom g) : f = g :=
  -- sigma.equal H !proof_irrel

  definition slice_category (C : category ob) (c : ob) : category (slice.slice_obs C c) :=
  mk (λa b, slice.slice_hom a b)
     (λ a b c g f, sigma.mk (slice.hom_hom g ∘ slice.hom_hom f)
       (show slice.ob_hom c ∘ (slice.hom_hom g ∘ slice.hom_hom f) = slice.ob_hom a,
         proof
         calc
           slice.ob_hom c ∘ (slice.hom_hom g ∘ slice.hom_hom f) = (slice.ob_hom c ∘ slice.hom_hom g) ∘ slice.hom_hom f : !assoc
             ... = slice.ob_hom b ∘ slice.hom_hom f : {slice.commute g}
             ... = slice.ob_hom a : {slice.commute f}
         qed))
     (λ a, sigma.mk id !id_right)
     (λ a b c d h g f, dpair_eq !assoc    !proof_irrel)
     (λ a b f,         sigma.eq !id_left  !proof_irrel)
     (λ a b f,         sigma.eq !id_right !proof_irrel)
  -- We use !proof_irrel instead of rfl, to give the unifier an easier time

  -- definition slice_category {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom b c)
  -- :=
  -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), dpr2 b ∘ g = dpr2 a)
  --    (λ a b c g f, dpair (dpr1 g ∘ dpr1 f)
  --      (show dpr2 c ∘ (dpr1 g ∘ dpr1 f) = dpr2 a,
  --        proof
  --        calc
  --          dpr2 c ∘ (dpr1 g ∘ dpr1 f) = (dpr2 c ∘ dpr1 g) ∘ dpr1 f : !assoc
  --            ... = dpr2 b ∘ dpr1 f : {dpr2 g}
  --            ... = dpr2 a : {dpr2 f}
  --        qed))
  --    (λ a, dpair id !id_right)
  --    (λ a b c d h g f, dpair_eq    !assoc    !proof_irrel)
  --    (λ a b f,         sigma.equal !id_left  !proof_irrel)
  --    (λ a b f,         sigma.equal !id_right !proof_irrel)
  -- We use !proof_irrel instead of rfl, to give the unifier an easier time

  definition Slice_category [reducible] (C : Category) (c : C) := Mk (slice_category C c)
  open category.ops
  attribute slice_category [instance]
  variables {D : Category}
  definition forgetful (x : D) : (Slice_category D x) ⇒ D :=
  functor.mk (λ a, slice.to_ob a)
             (λ a b f, slice.hom_hom f)
             (λ a, rfl)
             (λ a b c g f, rfl)

  definition postcomposition_functor {x y : D} (h : x ⟶ y)
      : Slice_category D x ⇒ Slice_category D y :=
  functor.mk
       (λ a, sigma.mk (slice.to_ob a) (h ∘ slice.ob_hom a))
       (λ a b f,
         ⟨slice.hom_hom f,
          calc
            (h ∘ slice.ob_hom b) ∘ slice.hom_hom f = h ∘ (slice.ob_hom b ∘ slice.hom_hom f) : by rewrite assoc
                                   ... = h ∘ slice.ob_hom a               : by rewrite slice.commute⟩)
       (λ a, rfl)
       (λ a b c g f, dpair_eq rfl !proof_irrel)

  -- -- in the following comment I tried to have (A = B) in the type of a == b, but that doesn't solve the problems
  -- definition heq2 {A B : Type} (H : A = B) (a : A) (b : B) := a == b
  -- definition heq2.intro {A B : Type} {a : A} {b : B} (H : a == b) : heq2 (heq.type_eq H) a b := H
  -- definition heq2.elim {A B : Type} {a : A} {b : B} (H : A = B) (H2 : heq2 H a b) : a == b := H2
  -- definition heq2.proof_irrel {A B : Prop} (a : A) (b : B) (H : A = B) : heq2 H a b :=
  -- hproof_irrel H a b
  -- theorem functor.mk_eq2 {C D : Category} {obF obG : C → D} {homF homG idF idG compF compG}
  --    (Hob : ∀x, obF x = obG x)
  --    (Hmor : ∀(a b : C) (f : a ⟶ b), heq2 (congr_arg (λ x, x a ⟶ x b) (funext Hob)) (homF a b f) (homG a b f))
  --      : functor.mk obF homF idF compF = functor.mk obG homG idG compG :=
  -- hddcongr_arg4 functor.mk
  --             (funext Hob)
  --             (hfunext (λ a, hfunext (λ b, hfunext (λ f, !Hmor))))
  --             !proof_irrel
  --             !proof_irrel

--  set_option pp.implicit true
--  set_option pp.coercions true

  -- definition slice_functor : D ⇒ Category_of_categories :=
  -- functor.mk (λ a, Category.mk (slice_obs D a) (slice_category D a))
  --            (λ a b f, postcomposition_functor f)
  --            (λ a, functor.mk_heq
  --              (λx, sigma.equal rfl !id_left)
  --              (λb c f, sigma.hequal sorry !heq.refl (hproof_irrel sorry _ _)))
  --            (λ a b c g f, functor.mk_heq
  --                    (λx, sigma.equal (sorry ⬝ refl (dpr1 x)) sorry)
  --                    (λb c f, sorry))

  --the error message generated here is really confusing: the type of the above refl should be
  -- "@dpr1 D (λ (a_1 : D), a_1 ⟶ a) x = @dpr1 D (λ (a_1 : D), a_1 ⟶ c) x", but the second dpr1 is not even well-typed

  end slice

  -- section coslice
  -- open sigma

  -- definition coslice {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom c b) :=
  -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), g ∘ dpr2 a = dpr2 b)
  --    (λ a b c g f, dpair (dpr1 g ∘ dpr1 f)
  --      (show (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr2 c,
  --        proof
  --        calc
  --          (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr1 g ∘ (dpr1 f ∘ dpr2 a): symm !assoc
  --            ... = dpr1 g ∘ dpr2 b : {dpr2 f}
  --            ... = dpr2 c : {dpr2 g}
  --        qed))
  --    (λ a, dpair id !id_left)
  --    (λ a b c d h g f, dpair_eq    !assoc    !proof_irrel)
  --    (λ a b f,         sigma.equal !id_left  !proof_irrel)
  --    (λ a b f,         sigma.equal !id_right !proof_irrel)

  -- -- theorem slice_coslice_opp {ob : Type} (C : category ob) (c : ob) :
  -- --     coslice C c = opposite (slice (opposite C) c) :=
  -- -- sorry
  -- end coslice

  section arrow
  open sigma eq.ops
  -- theorem concat_commutative_squares {ob : Type} {C : category ob} {a1 a2 a3 b1 b2 b3 : ob}
  --     {f1 : a1 => b1} {f2 : a2 => b2} {f3 : a3 => b3} {g2 : a2 => a3} {g1 : a1 => a2}
  --     {h2 : b2 => b3} {h1 : b1 => b2} (H1 : f2 ∘ g1 = h1 ∘ f1) (H2 : f3 ∘ g2 = h2 ∘ f2)
  --       : f3 ∘ (g2 ∘ g1) = (h2 ∘ h1) ∘ f1 :=
  -- calc
  --   f3 ∘ (g2 ∘ g1) = (f3 ∘ g2) ∘ g1 : assoc
  --     ... = (h2 ∘ f2) ∘ g1 : {H2}
  --     ... = h2 ∘ (f2 ∘ g1) : symm assoc
  --     ... = h2 ∘ (h1 ∘ f1) : {H1}
  --     ... = (h2 ∘ h1) ∘ f1 : assoc

  -- definition arrow {ob : Type} (C : category ob) : category (Σ(a b : ob), hom a b) :=
  -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)) (h : hom (dpr2' a) (dpr2' b)),
  --      dpr3 b ∘ g = h ∘ dpr3 a)
  --    (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) (dpair (dpr2' g ∘ dpr2' f) (concat_commutative_squares (dpr3 f) (dpr3 g))))
  --    (λ a, dpair id (dpair id (id_right ⬝ (symm id_left))))
  --    (λ a b c d h g f, dtrip_eq2   assoc    assoc    !proof_irrel)
  --    (λ a b f,         trip.equal2 id_left  id_left  !proof_irrel)
  --    (λ a b f,         trip.equal2 id_right id_right !proof_irrel)

  -- make these definitions private?
  variables {ob : Type} {C : category ob}
  protected definition arrow_obs (ob : Type) (C : category ob) := Σ(a b : ob), hom a b
  variables {a b : category.arrow_obs ob C}
  protected definition src    (a : category.arrow_obs ob C) : ob                  := sigma.pr1 a
  protected definition dst    (a : category.arrow_obs ob C) : ob                  := sigma.pr2' a
  protected definition to_hom (a : category.arrow_obs ob C) : hom (category.src a) (category.dst a) := sigma.pr3 a

  protected definition arrow_hom (a b : category.arrow_obs ob C) : Type :=
  Σ (g : hom (category.src a) (category.src b)) (h : hom (category.dst a) (category.dst b)),
    category.to_hom b ∘ g = h ∘ category.to_hom a

  protected definition hom_src (m : category.arrow_hom a b) : hom (category.src a) (category.src b) := sigma.pr1 m
  protected definition hom_dst (m : category.arrow_hom a b) : hom (category.dst a) (category.dst b) := sigma.pr2' m
  protected definition commute (m : category.arrow_hom a b) :
     category.to_hom b ∘ (category.hom_src m) = (category.hom_dst m) ∘ category.to_hom a
  := sigma.pr3 m

  definition arrow (ob : Type) (C : category ob) : category (category.arrow_obs ob C) :=
  mk (λa b, category.arrow_hom a b)
     (λ a b c g f, sigma.mk (category.hom_src g ∘ category.hom_src f) (sigma.mk (category.hom_dst g ∘ category.hom_dst f)
        (show category.to_hom c ∘ (category.hom_src g ∘ category.hom_src f) = (category.hom_dst g ∘ category.hom_dst f) ∘ category.to_hom a,
         proof
         calc
         category.to_hom c ∘ (category.hom_src g ∘ category.hom_src f) = (category.to_hom c ∘ category.hom_src g) ∘ category.hom_src f : by rewrite assoc
           ... = (category.hom_dst g ∘ category.to_hom b) ∘ category.hom_src f                     : by rewrite category.commute
           ... = category.hom_dst g ∘ (category.to_hom b ∘ category.hom_src f)                     : by rewrite assoc
           ... = category.hom_dst g ∘ (category.hom_dst f ∘ category.to_hom a)                     : by rewrite category.commute
           ... = (category.hom_dst g ∘ category.hom_dst f) ∘ category.to_hom a                     : by rewrite assoc
         qed)
       ))
     (λ a, sigma.mk id (sigma.mk id (!id_right ⬝ (symm !id_left))))
     (λ a b c d h g f, ndtrip_eq    !assoc    !assoc    !proof_irrel)
     (λ a b f,         ndtrip_equal !id_left  !id_left  !proof_irrel)
     (λ a b f,         ndtrip_equal !id_right !id_right !proof_irrel)

  end arrow

end category

  -- definition foo : category (sorry) :=
  -- mk (λa b, sorry)
  --    (λ a b c g f, sorry)
  --    (λ a, sorry)
  --    (λ a b c d h g f, sorry)
  --    (λ a b f, sorry)
  --    (λ a b f, sorry)


inductive bool' : Type
| true' | false'

open bool'

def or' : bool' -> bool' -> bool'
| true' _ := true'
| _ true' := true'
| _ _ := false'

infixr `||` := or'

example : true' || false' = true' := rfl
example : true' || true' = true' := rfl
example : false' || false' = false' := rfl
example : false' || true' = true' := rfl

def and' : bool' -> bool' -> bool'
| false' _ := false'
| true' false' := false'
| _ _ := true'

infixr `&&` := and'

def not' : bool' → bool'
| true' := false'
| _ := true'


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.big_operators.basic
import order.locally_finite
import order.atoms
import order.sup_indep

/-!
# Finite partitions

In this file, we define finite partitions. A finpartition of `a : α` is a finite set of pairwise
disjoint parts `parts : finset α` which does not contain `⊥` and whose supremum is `a`.

## Constructions

We provide many ways to build finpartitions:
* `finpartition.of_erase`: Builds a finpartition by erasing `⊥` for you.
* `finpartition.of_subset`: Builds a finpartition from a subset of the parts of a previous
  finpartition.
* `finpartition.empty`: The empty finpartition of `⊥`.
* `finpartition.indiscrete`: The indiscrete, aka trivial, aka pure, finpartition made of a single
  part.
* `finpartition.discrete`: The discrete finpartition of `s : finset α` made of singletons.
* `finpartition.bind`: Puts together the finpartitions of the parts of a finpartition into a new
  finpartition.
* `finpartition.atomise`: Makes a finpartition of `s : finset α` by breaking `s` along all finsets
  in `F : finset (finset α)`. Two elements of `s` belong to the same part iff they belong to the
  same elements of `F`.

`finpartition.indiscrete` and `finpartition.bind` together form the monadic structure of
`finpartition`.

## Implementation notes

Forbidding `⊥` as a part follows mathematical tradition and is a pragmatic choice concerning
operations on `finpartition`. Not caring about `⊥` being a part or not breaks extensionality (it's
not because the parts of `P` and the parts of `Q` have the same elements that `P = Q`). Enforcing
`⊥` to be a part makes `finpartition.bind` uglier and doesn't rid us of the need of
`finpartition.of_erase`.

## TODO

Link `finpartition` and `setoid.is_partition`.

The order is the wrong way around to make `finpartition a` a graded order. Is it bad to depart from
the literature and turn the order around?
-/

lemma set.pairwise_disjoint.eq_of_le {α ι : Type*} [semilattice_inf α] [order_bot α] {s : set ι}
  {f : ι → α} (hs : s.pairwise_disjoint f) {i j : ι} (hi : i ∈ s) (hj : j ∈ s)
  (h : f i ≠ ⊥) (hf : f i ≤ f j) :
  i = j :=
begin
  classical,
  by_contra hij,
  exact h ((hs hi hj hij).eq_bot_of_le hf),
end

instance {α ι : Type*} [lattice α] [order_bot α] {s t : finset ι} {f : ι → α} {i : ι}
  [decidable_eq ι] [decidable_eq α] : decidable (s.sup_indep f) :=
begin
  apply @finset.decidable_forall_of_decidable_subsets _ _ _ _,
  intros t ht,
  apply @finset.decidable_dforall_finset _ _ _ _,
  exact λ i hi, @implies.decidable _ _ _ (decidable_of_iff' (_ = ⊥) disjoint_iff),
end

open finset function
open_locale big_operators

variables {α : Type*}

/-- A finite partition of `a : α` is a pairwise disjoint finite set of elements whose supremum is
`a`. We forbid `⊥` as a part. -/
@[ext, derive decidable_eq] structure finpartition [lattice α] [order_bot α] (a : α) :=
(parts : finset α)
(sup_indep : parts.sup_indep id)
(sup_parts : parts.sup id = a)
(not_bot_mem : ⊥ ∉ parts)

attribute [protected] finpartition.sup_indep

namespace finpartition
section lattice
variables [lattice α] [order_bot α]

/-- A `finpartition` constructor which does not insist on `⊥` not being a part. -/
@[simps] def of_erase [decidable_eq α] {a : α} (parts : finset α)
  (sup_indep : parts.sup_indep id) (sup_parts : parts.sup id = a) :
  finpartition a :=
{ parts := parts.erase ⊥,
  sup_indep := sup_indep.subset (erase_subset _ _),
  sup_parts := (sup_erase_bot _).trans sup_parts,
  not_bot_mem := not_mem_erase _ _ }

/-- A `finpartition` constructor from a bigger existing finpartition. -/
@[simps] def of_subset {a b : α} (P : finpartition a) {parts : finset α}
  (subset : parts ⊆ P.parts) (sup_parts : parts.sup id = b) :
  finpartition b :=
{ parts := parts,
  sup_indep := P.sup_indep.subset subset,
  sup_parts := sup_parts,
  not_bot_mem := λ h, P.not_bot_mem (subset h) }

/-- Changes the type of a finpartition to an equal one. -/
@[simps] def copy {a b : α} (P : finpartition a) (h : a = b) : finpartition b :=
{ parts := P.parts,
  sup_indep := P.sup_indep,
  sup_parts := h ▸ P.sup_parts,
  not_bot_mem := P.not_bot_mem }

variables (α)

/-- The empty finpartition. -/
@[simps] protected def empty : finpartition (⊥ : α) :=
{ parts := ∅,
  sup_indep := sup_indep_empty _,
  sup_parts := finset.sup_empty,
  not_bot_mem := not_mem_empty ⊥ }

instance : inhabited (finpartition (⊥ : α)) := ⟨finpartition.empty α⟩

@[simp] lemma default_eq_empty : (default : finpartition (⊥ : α)) = finpartition.empty α := rfl

variables {α} {a : α}

/-- The finpartition in one part, aka indiscrete finpartition. -/
@[simps] def indiscrete (ha : a ≠ ⊥) : finpartition a :=
{ parts := {a},
  sup_indep := sup_indep_singleton _ _,
  sup_parts := finset.sup_singleton,
  not_bot_mem := λ h, ha (mem_singleton.1 h).symm }

variables (P : finpartition a)

protected lemma le {b : α} (hb : b ∈ P.parts) : b ≤ a := (le_sup hb).trans P.sup_parts.le

lemma ne_bot {b : α} (hb : b ∈ P.parts) : b ≠ ⊥ := λ h, P.not_bot_mem $ h.subst hb

protected lemma disjoint : (P.parts : set α).pairwise_disjoint id := P.sup_indep.pairwise_disjoint

variables {P}

lemma parts_eq_empty_iff : P.parts = ∅ ↔ a = ⊥ :=
begin
  simp_rw ←P.sup_parts,
  refine ⟨λ h, _, λ h, eq_empty_iff_forall_not_mem.2 (λ b hb, P.not_bot_mem _)⟩,
  { rw h,
    exact finset.sup_empty },
  { rwa ←le_bot_iff.1 ((le_sup hb).trans h.le) }
end

lemma parts_nonempty_iff : P.parts.nonempty ↔ a ≠ ⊥ :=
by rw [nonempty_iff_ne_empty, not_iff_not, parts_eq_empty_iff]

lemma parts_nonempty (P : finpartition a) (ha : a ≠ ⊥) : P.parts.nonempty := parts_nonempty_iff.2 ha

instance : unique (finpartition (⊥ : α)) :=
{ uniq := λ P,
    by { ext a, exact iff_of_false (λ h, P.ne_bot h $ le_bot_iff.1 $ P.le h) (not_mem_empty a) },
  ..finpartition.inhabited α }

/-- There's a unique partition of an atom. -/
@[reducible] -- See note [reducible non instances]
def _root_.is_atom.unique_finpartition (ha : is_atom a) : unique (finpartition a) :=
{ default := indiscrete ha.1,
  uniq := λ P, begin
    have h : ∀ b ∈ P.parts, b = a,
    { exact λ b hb, (eq_bot_or_eq_of_le_atom ha $ P.le hb).resolve_left (P.ne_bot hb) },
    ext b,
    refine iff.trans ⟨h b, _⟩ mem_singleton.symm,
    rintro rfl,
    obtain ⟨c, hc⟩ := P.parts_nonempty ha.1,
    simp_rw ←h c hc,
    exact hc,
  end }

/-! ### Refinement order -/

section order

/-- We say that `P ≤ Q` if `P` refines `Q`: each part of `P` is less than some part of `Q`. -/
instance : has_le (finpartition a) := ⟨λ P Q, ∀ ⦃b⦄, b ∈ P.parts → ∃ c ∈ Q.parts, b ≤ c⟩

instance : partial_order (finpartition a) :=
{ le_refl := λ P b hb, ⟨b, hb, le_rfl⟩,
  le_trans := λ P Q R hPQ hQR b hb, begin
    obtain ⟨c, hc, hbc⟩ := hPQ hb,
    obtain ⟨d, hd, hcd⟩ := hQR hc,
    exact ⟨d, hd, hbc.trans hcd⟩,
  end,
  le_antisymm := λ P Q hPQ hQP, begin
    ext b,
    refine ⟨λ hb, _, λ hb, _⟩,
    { obtain ⟨c, hc, hbc⟩ := hPQ hb,
      obtain ⟨d, hd, hcd⟩ := hQP hc,
      rwa hbc.antisymm,
      rwa P.disjoint.eq_of_le hb hd (P.ne_bot hb) (hbc.trans hcd) },
    { obtain ⟨c, hc, hbc⟩ := hQP hb,
      obtain ⟨d, hd, hcd⟩ := hPQ hc,
      rwa hbc.antisymm,
      rwa Q.disjoint.eq_of_le hb hd (Q.ne_bot hb) (hbc.trans hcd) }
  end,
  ..finpartition.has_le }

instance [decidable (a = ⊥)] : order_top (finpartition a) :=
{ top := if ha : a = ⊥ then (finpartition.empty α).copy ha.symm else indiscrete ha,
  le_top := λ P,
  begin
    split_ifs,
    { intros x hx,
      simpa [h, P.ne_bot hx] using P.le hx },
    { exact λ b hb, ⟨a, mem_singleton_self _, P.le hb⟩ }
  end }

end order

end lattice

section distrib_lattice
variables [distrib_lattice α] [order_bot α] [decidable_eq α] {a b c : α}

instance : has_inf (finpartition a) :=
⟨λ P Q, of_erase ((P.parts.product Q.parts).image $ λ bc, bc.1 ⊓ bc.2)
  begin
    rw sup_indep_iff_disjoint_erase,
    simp only [mem_image, and_imp, exists_prop, forall_exists_index, id.def, prod.exists,
      mem_product, finset.disjoint_sup_right, mem_erase, ne.def],
    rintro _ x₁ y₁ hx₁ hy₁ rfl _ h x₂ y₂ hx₂ hy₂ rfl,
    rcases eq_or_ne x₁ x₂ with rfl | xdiff,
    { refine disjoint.mono inf_le_right inf_le_right (Q.disjoint hy₁ hy₂ _),
      intro t,
      simpa [t] using h },
    exact disjoint.mono inf_le_left inf_le_left (P.disjoint hx₁ hx₂ xdiff),
  end
  begin
    rw [sup_image, comp.left_id, sup_product_left],
    transitivity P.parts.sup id ⊓ Q.parts.sup id,
    { simp_rw [finset.sup_inf_distrib_right, finset.sup_inf_distrib_left],
      refl },
    { rw [P.sup_parts, Q.sup_parts, inf_idem] }
  end⟩

@[simp] lemma parts_inf (P Q : finpartition a) :
  (P ⊓ Q).parts = ((P.parts.product Q.parts).image $ λ bc : α × α, bc.1 ⊓ bc.2).erase ⊥ := rfl

instance : semilattice_inf (finpartition a) :=
{ inf_le_left := λ P Q b hb, begin
    obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb),
    rw mem_product at hc,
    exact ⟨c.1, hc.1, inf_le_left⟩,
  end,
  inf_le_right := λ P Q b hb, begin
    obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb),
    rw mem_product at hc,
    exact ⟨c.2, hc.2, inf_le_right⟩,
  end,
  le_inf := λ P Q R hPQ hPR b hb, begin
    obtain ⟨c, hc, hbc⟩ := hPQ hb,
    obtain ⟨d, hd, hbd⟩ := hPR hb,
    have h := _root_.le_inf hbc hbd,
    refine ⟨c ⊓ d, mem_erase_of_ne_of_mem (ne_bot_of_le_ne_bot (P.ne_bot hb) h)
      (mem_image.2 ⟨(c, d), mem_product.2 ⟨hc, hd⟩, rfl⟩), h⟩,
  end,
  ..finpartition.partial_order, ..finpartition.has_inf }

lemma exists_le_of_le {P Q : finpartition a} (h : P ≤ Q) (hb : b ∈ Q.parts) :
  ∃ c ∈ P.parts, c ≤ b :=
begin
  by_contra' H,
  refine Q.ne_bot hb (disjoint_self.1 $ disjoint.mono_right (Q.le hb) _),
  rw [←P.sup_parts, finset.disjoint_sup_right],
  rintro c hc,
  obtain ⟨d, hd, hcd⟩ := h hc,
  refine (Q.disjoint hb hd _).mono_right hcd,
  rintro rfl,
  exact H _ hc hcd,
end

lemma card_mono {P Q : finpartition a} (h : P ≤ Q) : Q.parts.card ≤ P.parts.card :=
begin
  classical,
  have : ∀ b ∈ Q.parts, ∃ c ∈ P.parts, c ≤ b := λ b, exists_le_of_le h,
  choose f hP hf using this,
  rw ←card_attach,
  refine card_le_card_of_inj_on (λ b, f _ b.2) (λ b _, hP _ b.2) (λ b hb c hc h, _),
  exact subtype.coe_injective (Q.disjoint.elim b.2 c.2 $ λ H, P.ne_bot (hP _ b.2) $
    disjoint_self.1 $ H.mono (hf _ b.2) $ h.le.trans $ hf _ c.2),
end

section bind
variables {a} {P : finpartition a} {Q : Π i ∈ P.parts, finpartition i}

/-- Given a finpartition `P` of `a` and finpartitions of each part of `P`, this yields the
finpartition of `a` obtained by juxtaposing all the subpartitions. -/
@[simps] def bind (P : finpartition a) (Q : Π i ∈ P.parts, finpartition i) : finpartition a :=
{ parts := P.parts.attach.bUnion (λ i, (Q i.1 i.2).parts),
  sup_indep := begin
    rw sup_indep_iff_pairwise_disjoint,
    rintro a ha b hb h,
    rw [finset.mem_coe, finset.mem_bUnion] at ha hb,
    obtain ⟨⟨A, hA⟩, -, ha⟩ := ha,
    obtain ⟨⟨B, hB⟩, -, hb⟩ := hb,
    obtain rfl | hAB := eq_or_ne A B,
    { exact (Q A hA).disjoint ha hb h },
    { exact (P.disjoint hA hB hAB).mono ((Q A hA).le ha) ((Q B hB).le hb) }
  end,
  sup_parts := begin
    simp_rw [sup_bUnion, ←P.sup_parts],
    rw [eq_comm, ←finset.sup_attach],
    exact sup_congr rfl (λ b hb, (Q b.1 b.2).sup_parts.symm),
  end,
  not_bot_mem := λ h, begin
    rw finset.mem_bUnion at h,
    obtain ⟨⟨A, hA⟩, -, h⟩ := h,
    exact (Q A hA).not_bot_mem h,
  end }

lemma mem_bind : b ∈ (P.bind Q).parts ↔ ∃ A hA, b ∈ (Q A hA).parts :=
begin
  rw [bind, mem_bUnion],
  split,
  { rintro ⟨⟨A, hA⟩, -, h⟩,
    exact ⟨A, hA, h⟩ },
  { rintro ⟨A, hA, h⟩,
    exact ⟨⟨A, hA⟩, mem_attach _ ⟨A, hA⟩, h⟩ }
end

lemma card_bind (Q : Π i ∈ P.parts, finpartition i) :
  (P.bind Q).parts.card = ∑ A in P.parts.attach, (Q _ A.2).parts.card :=
begin
  apply card_bUnion,
  rintro ⟨b, hb⟩ - ⟨c, hc⟩ - hbc d,
  rw [inf_eq_inter, mem_inter],
  rintro ⟨hdb, hdc⟩,
  rw [ne.def, subtype.mk_eq_mk] at hbc,
  exact (Q b hb).ne_bot hdb (eq_bot_iff.2 $
    (le_inf ((Q b hb).le hdb) $ (Q c hc).le hdc).trans $ P.disjoint hb hc hbc),
end

end bind

/-- Adds `b` to a finpartition of `a` to make a finpartition of `a ⊔ b`. -/
@[simps] def extend (P : finpartition a) (hb : b ≠ ⊥) (hab : disjoint a b) (hc : a ⊔ b = c) :
  finpartition c :=
{ parts := insert b P.parts,
  sup_indep :=
  begin
    rw [sup_indep_iff_pairwise_disjoint, coe_insert],
    exact P.disjoint.insert (λ d hd hbd, hab.symm.mono_right $ P.le hd),
  end,
  sup_parts := by rwa [sup_insert, P.sup_parts, id, _root_.sup_comm],
  not_bot_mem := λ h, (mem_insert.1 h).elim hb.symm P.not_bot_mem }

lemma card_extend (P : finpartition a) (b c : α) {hb : b ≠ ⊥} {hab : disjoint a b}
  {hc : a ⊔ b = c} :
  (P.extend hb hab hc).parts.card = P.parts.card + 1 :=
card_insert_of_not_mem $ λ h, hb $ hab.symm.eq_bot_of_le $ P.le h

end distrib_lattice

section generalized_boolean_algebra
variables [generalized_boolean_algebra α] [decidable_eq α] {a : α} (P : finpartition a)

/-- Restricts a finpartition to avoid a given element. -/
@[simps] def avoid (b : α) : finpartition (a \ b) :=
of_erase
  (P.parts.image (\ b))
  (P.disjoint.image_finset_of_le $ λ a, sdiff_le).sup_indep
  (begin
    rw [sup_image, comp.left_id, finset.sup_sdiff_right],
    congr,
    exact P.sup_parts,
  end)

end generalized_boolean_algebra
end finpartition

/-! ### Finite partitions of finsets -/

namespace finpartition
variables [decidable_eq α] {s t : finset α} (P : finpartition s)

lemma nonempty_of_mem_parts {a : finset α} (ha : a ∈ P.parts) : a.nonempty :=
nonempty_iff_ne_empty.2 $ P.ne_bot ha

lemma exists_mem {a : α} (ha : a ∈ s) : ∃ t ∈ P.parts, a ∈ t :=
by { simp_rw ←P.sup_parts at ha, exact mem_sup.1 ha }

lemma bUnion_parts : P.parts.bUnion id = s := (sup_eq_bUnion _ _).symm.trans P.sup_parts

lemma sum_card_parts : ∑ i in P.parts, i.card = s.card :=
begin
  convert congr_arg finset.card P.bUnion_parts,
  rw card_bUnion P.sup_indep.pairwise_disjoint,
  refl,
end

/-- `⊥` is the partition in singletons, aka discrete partition. -/
instance (s : finset α) : has_bot (finpartition s) :=
⟨{ parts := s.map ⟨singleton, singleton_injective⟩,
  sup_indep := set.pairwise_disjoint.sup_indep begin
      rw finset.coe_map,
      exact finset.pairwise_disjoint_range_singleton.subset (set.image_subset_range _ _),
    end,
  sup_parts := by rw [sup_map, comp.left_id, embedding.coe_fn_mk, finset.sup_singleton'],
  not_bot_mem := by simp }⟩

@[simp] lemma parts_bot (s : finset α) :
  (⊥ : finpartition s).parts = s.map ⟨singleton, singleton_injective⟩ := rfl

lemma card_bot (s : finset α) : (⊥ : finpartition s).parts.card = s.card := finset.card_map _
lemma mem_bot_iff : t ∈ (⊥ : finpartition s).parts ↔ ∃ a ∈ s, {a} = t := mem_map

instance (s : finset α) : order_bot (finpartition s) :=
{ bot_le := λ P t ht, begin
    rw mem_bot_iff at ht,
    obtain ⟨a, ha, rfl⟩ := ht,
    obtain ⟨t, ht, hat⟩ := P.exists_mem ha,
    exact ⟨t, ht, singleton_subset_iff.2 hat⟩,
  end,
  ..finpartition.has_bot s }

lemma card_parts_le_card (P : finpartition s) : P.parts.card ≤ s.card :=
by { rw ←card_bot s, exact card_mono bot_le }

section atomise

/-- Cuts `s` along the finsets in `F`: Two elements of `s` will be in the same part if they are
in the same finsets of `F`. -/
def atomise (s : finset α) (F : finset (finset α)) : finpartition s :=
of_erase
  (F.powerset.image $ λ Q, s.filter (λ i, ∀ t ∈ F, t ∈ Q ↔ i ∈ t))
  (set.pairwise_disjoint.sup_indep $ λ x hx y hy h z hz, h begin
    rw [mem_coe, mem_image] at hx hy,
    obtain ⟨Q, hQ, rfl⟩ := hx,
    obtain ⟨R, hR, rfl⟩ := hy,
    suffices h : Q = R,
    { subst h },
    rw [id, id, inf_eq_inter, mem_inter, mem_filter, mem_filter] at hz,
    rw mem_powerset at hQ hR,
    ext i,
    refine ⟨λ hi, _, λ hi, _⟩,
    { rwa [hz.2.2 _ (hQ hi), ←hz.1.2 _ (hQ hi)] },
    { rwa [hz.1.2 _ (hR hi), ←hz.2.2 _ (hR hi)] }
  end)
  (begin
    refine (finset.sup_le $ λ t ht, _).antisymm (λ a ha, _),
    { rw mem_image at ht,
      obtain ⟨A, hA, rfl⟩ := ht,
      exact s.filter_subset _ },
    { rw [mem_sup],
      refine ⟨s.filter (λ i, ∀ t, t ∈ F → (t ∈ F.filter (λ u, a ∈ u) ↔ i ∈ t)),
        mem_image_of_mem _ (mem_powerset.2 $ filter_subset _ _), mem_filter.2 ⟨ha, λ t ht, _⟩⟩,
      rw mem_filter,
      exact and_iff_right ht }
  end)

variables {F : finset (finset α)}

lemma mem_atomise {t : finset α} :
  t ∈ (atomise s F).parts ↔ t.nonempty ∧ ∃ (Q ⊆ F), s.filter (λ i, ∀ u ∈ F, u ∈ Q ↔ i ∈ u) = t :=
by simp only [atomise, of_erase, bot_eq_empty, mem_erase, mem_image, nonempty_iff_ne_empty,
  mem_singleton, and_comm, mem_powerset, exists_prop]

lemma atomise_empty (hs : s.nonempty) : (atomise s ∅).parts = {s} :=
begin
  simp only [atomise, powerset_empty, image_singleton, not_mem_empty, forall_false_left,
    implies_true_iff, filter_true],
  exact erase_eq_of_not_mem (not_mem_singleton.2 hs.ne_empty.symm),
end

lemma card_atomise_le : (atomise s F).parts.card ≤ 2^F.card :=
(card_le_of_subset $ erase_subset _ _).trans $ finset.card_image_le.trans (card_powerset _).le

lemma bUnion_filter_atomise (t : finset α) (ht : t ∈ F) (hts : t ⊆ s) :
  ((atomise s F).parts.filter $ λ u, u ⊆ t).bUnion id = t :=
begin
  ext a,
  rw mem_bUnion,
  refine ⟨λ ⟨u, hu, ha⟩, (mem_filter.1 hu).2 ha, λ ha, _⟩,
  obtain ⟨u, hu, hau⟩ := (atomise s F).exists_mem (hts ha),
  refine ⟨u, mem_filter.2 ⟨hu, λ b hb, _⟩, hau⟩,
  obtain ⟨Q, hQ, rfl⟩ := (mem_atomise.1 hu).2,
  rw mem_filter at hau hb,
  rwa [←hb.2 _ ht, hau.2 _ ht]
end

end atomise
end finpartition


/-Heyting algebras display calculus proofs in Lean -- Peter Jipsen -- April 30, 2018-/

set_option default_priority 100
set_option old_structure_cmd true

universe u
variables {α: Type u}

class has_join (α : Type u) := (join : α → α → α)
infix `⊔` : 65 := has_join.join
class has_meet (α : Type u) := (meet : α → α → α)
infix `⊓` : 65 := has_meet.meet

class Lattice (α : Type u) extends partial_order α, has_join α, has_meet α :=
(join_l : ∀ x y z:α, x ≤ z /\ y ≤ z → x⊔y ≤ z)
(join_r1 : ∀ x y z:α, x ≤ y → x ≤ y⊔z)
(join_r2 : ∀ x y z:α, x ≤ z → x ≤ y⊔z)
(meet_l1 : ∀ x y z:α, x ≤ z → x⊓y ≤ z)
(meet_l2 : ∀ x y z:α, y ≤ z → x⊓y ≤ z)
(meet_r : ∀ x y z:α, x ≤ y /\ x ≤ z → x ≤ y⊓z)

class has_impl (α : Type u) := (impl : α → α → α)
infix `→` : 65 := has_impl.impl

class Heyting_algebra α extends Lattice α, has_impl α :=
(meet_res : ∀x y z:α, x ⊓ y ≤ z -> y ≤ x → z)
(res_meet : ∀x y z:α, y ≤ x → z -> x ⊓ y ≤ z)

open Heyting_algebra

lemma HA_distributive [Heyting_algebra α]: ∀x y z:α, x⊓(y ⊔ z) ≤ (x⊓y) ⊔ (x⊓z) :=
assume x y z,
have h1: x⊓y ≤ (x⊓y) ⊔ (x⊓z),         from join_r1 _ _ _ (Lattice.le_refl _),
have h2: y ≤ x → ((x⊓y) ⊔ (x⊓z)),     from meet_res _ _ _ h1,
have h3: x⊓z ≤ (x⊓y) ⊔ (x⊓z),         from join_r2 _ _ _ (Lattice.le_refl _),
have h4: z ≤ x → ((x⊓y) ⊔ (x⊓z)),     from meet_res _ _ _ h3,
have h5: y ⊔ z ≤ x → ((x⊓y) ⊔ (x⊓z)), from join_l _ _ _ (and.intro h2 h4),
show x⊓(y ⊔ z) ≤ (x⊓y) ⊔ (x⊓z),       from res_meet _ _ _ h5

lemma HA_distributive1 [Heyting_algebra α]: ∀x y z:α, x⊓(y ⊔ z) ≤ (x⊓y) ⊔ (x⊓z) :=
assume x y z,
begin
apply res_meet,
apply join_l,
apply and.intro,
apply meet_res,
apply join_r1,
apply Lattice.le_refl,
apply meet_res,
apply join_r2,
apply Lattice.le_refl,
end

lemma HA_distributive2 [Heyting_algebra α]: ∀x y z:α, x⊓(y ⊔ z) ≤ (x⊓y) ⊔ (x⊓z) :=
assume x y z,
by repeat
begin
apply res_meet,
apply join_l,
apply and.intro,
apply meet_res,
apply join_r1,
apply Lattice.le_refl,
--apply meet_res,
apply join_r2,
apply Lattice.le_refl,
end

#print classes

open tactic

variables a b r : Prop

example : a -> b -> a ∧ b :=
by do trace "Hi, Mom!"
    trace_state


/-
Copyright (c) 2018 Guy Leroy. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sangwoo Jo (aka Jason), Guy Leroy, Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.prime
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Extended GCD and divisibility over ℤ

## Main definitions

* Given `x y : ℕ`, `xgcd x y` computes the pair of integers `(a, b)` such that
  `gcd x y = x * a + y * b`. `gcd_a x y` and `gcd_b x y` are defined to be `a` and `b`,
  respectively.

## Main statements

* `gcd_eq_gcd_ab`: Bézout's lemma, given `x y : ℕ`, `gcd x y = x * gcd_a x y + y * gcd_b x y`.

-/

/-! ### Extended Euclidean algorithm -/

namespace nat

/-- Helper function for the extended GCD algorithm (`nat.xgcd`). -/
def xgcd_aux : ℕ → ℤ → ℤ → ℕ → ℤ → ℤ → ℕ × ℤ × ℤ := sorry

@[simp] theorem xgcd_zero_left {s : ℤ} {t : ℤ} {r' : ℕ} {s' : ℤ} {t' : ℤ} :
    xgcd_aux 0 s t r' s' t' = (r', s', t') :=
  sorry

theorem xgcd_aux_rec {r : ℕ} {s : ℤ} {t : ℤ} {r' : ℕ} {s' : ℤ} {t' : ℤ} (h : 0 < r) :
    xgcd_aux r s t r' s' t' = xgcd_aux (r' % r) (s' - ↑r' / ↑r * s) (t' - ↑r' / ↑r * t) r s t :=
  sorry

/-- Use the extended GCD algorithm to generate the `a` and `b` values
  satisfying `gcd x y = x * a + y * b`. -/
def xgcd (x : ℕ) (y : ℕ) : ℤ × ℤ := prod.snd (xgcd_aux x 1 0 y 0 1)

/-- The extended GCD `a` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_a (x : ℕ) (y : ℕ) : ℤ := prod.fst (xgcd x y)

/-- The extended GCD `b` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_b (x : ℕ) (y : ℕ) : ℤ := prod.snd (xgcd x y)

@[simp] theorem gcd_a_zero_left {s : ℕ} : gcd_a 0 s = 0 := sorry

@[simp] theorem gcd_b_zero_left {s : ℕ} : gcd_b 0 s = 1 := sorry

@[simp] theorem gcd_a_zero_right {s : ℕ} (h : s ≠ 0) : gcd_a s 0 = 1 := sorry

@[simp] theorem gcd_b_zero_right {s : ℕ} (h : s ≠ 0) : gcd_b s 0 = 0 := sorry

@[simp] theorem xgcd_aux_fst (x : ℕ) (y : ℕ) (s : ℤ) (t : ℤ) (s' : ℤ) (t' : ℤ) :
    prod.fst (xgcd_aux x s t y s' t') = gcd x y :=
  sorry

theorem xgcd_aux_val (x : ℕ) (y : ℕ) : xgcd_aux x 1 0 y 0 1 = (gcd x y, xgcd x y) := sorry

theorem xgcd_val (x : ℕ) (y : ℕ) : xgcd x y = (gcd_a x y, gcd_b x y) := sorry

theorem xgcd_aux_P (x : ℕ) (y : ℕ) {r : ℕ} {r' : ℕ} {s : ℤ} {t : ℤ} {s' : ℤ} {t' : ℤ} :
    P x y (r, s, t) → P x y (r', s', t') → P x y (xgcd_aux r s t r' s' t') :=
  sorry

/-- Bézout's lemma: given `x y : ℕ`, `gcd x y = x * a + y * b`, where `a = gcd_a x y` and
`b = gcd_b x y` are computed by the extended Euclidean algorithm.
-/
theorem gcd_eq_gcd_ab (x : ℕ) (y : ℕ) : ↑(gcd x y) = ↑x * gcd_a x y + ↑y * gcd_b x y := sorry

end nat

/-! ### Divisibility over ℤ -/

namespace int

theorem nat_abs_div (a : ℤ) (b : ℤ) (H : b ∣ a) : nat_abs (a / b) = nat_abs a / nat_abs b := sorry

theorem nat_abs_dvd_abs_iff {i : ℤ} {j : ℤ} : nat_abs i ∣ nat_abs j ↔ i ∣ j :=
  { mp :=
      fun (H : nat_abs i ∣ nat_abs j) =>
        iff.mp dvd_nat_abs (iff.mp nat_abs_dvd (iff.mpr coe_nat_dvd H)),
    mpr := fun (H : i ∣ j) => iff.mp coe_nat_dvd (iff.mpr dvd_nat_abs (iff.mpr nat_abs_dvd H)) }

theorem succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul {p : ℕ} (p_prime : nat.prime p) {m : ℤ} {n : ℤ}
    {k : ℕ} {l : ℕ} (hpm : ↑(p ^ k) ∣ m) (hpn : ↑(p ^ l) ∣ n) (hpmn : ↑(p ^ (k + l + 1)) ∣ m * n) :
    ↑(p ^ (k + 1)) ∣ m ∨ ↑(p ^ (l + 1)) ∣ n :=
  sorry

theorem dvd_of_mul_dvd_mul_left {i : ℤ} {j : ℤ} {k : ℤ} (k_non_zero : k ≠ 0) (H : k * i ∣ k * j) :
    i ∣ j :=
  dvd.elim H
    fun (l : ℤ) (H1 : k * j = k * i * l) =>
      Exists.intro l
        (mul_left_cancel' k_non_zero
          (eq.mp (Eq._oldrec (Eq.refl (k * j = k * i * l)) (mul_assoc k i l)) H1))

theorem dvd_of_mul_dvd_mul_right {i : ℤ} {j : ℤ} {k : ℤ} (k_non_zero : k ≠ 0) (H : i * k ∣ j * k) :
    i ∣ j :=
  dvd_of_mul_dvd_mul_left k_non_zero
    (eq.mp (Eq._oldrec (Eq.refl (k * i ∣ j * k)) (mul_comm j k))
      (eq.mp (Eq._oldrec (Eq.refl (i * k ∣ j * k)) (mul_comm i k)) H))

theorem prime.dvd_nat_abs_of_coe_dvd_pow_two {p : ℕ} (hp : nat.prime p) (k : ℤ)
    (h : ↑p ∣ k ^ bit0 1) : p ∣ nat_abs k :=
  sorry

/-- ℤ specific version of least common multiple. -/
def lcm (i : ℤ) (j : ℤ) : ℕ := nat.lcm (nat_abs i) (nat_abs j)

theorem lcm_def (i : ℤ) (j : ℤ) : lcm i j = nat.lcm (nat_abs i) (nat_abs j) := rfl

theorem gcd_dvd_left (i : ℤ) (j : ℤ) : ↑(gcd i j) ∣ i :=
  iff.mp dvd_nat_abs (iff.mpr coe_nat_dvd (nat.gcd_dvd_left (nat_abs i) (nat_abs j)))

theorem gcd_dvd_right (i : ℤ) (j : ℤ) : ↑(gcd i j) ∣ j :=
  iff.mp dvd_nat_abs (iff.mpr coe_nat_dvd (nat.gcd_dvd_right (nat_abs i) (nat_abs j)))

theorem dvd_gcd {i : ℤ} {j : ℤ} {k : ℤ} (h1 : k ∣ i) (h2 : k ∣ j) : k ∣ ↑(gcd i j) :=
  iff.mp nat_abs_dvd
    (iff.mpr coe_nat_dvd
      (nat.dvd_gcd (iff.mpr nat_abs_dvd_abs_iff h1) (iff.mpr nat_abs_dvd_abs_iff h2)))

theorem gcd_mul_lcm (i : ℤ) (j : ℤ) : gcd i j * lcm i j = nat_abs (i * j) := sorry

theorem gcd_comm (i : ℤ) (j : ℤ) : gcd i j = gcd j i := nat.gcd_comm (nat_abs i) (nat_abs j)

theorem gcd_assoc (i : ℤ) (j : ℤ) (k : ℤ) : gcd (↑(gcd i j)) k = gcd i ↑(gcd j k) :=
  nat.gcd_assoc (nat_abs i) (nat_abs j) (nat_abs k)

@[simp] theorem gcd_self (i : ℤ) : gcd i i = nat_abs i := sorry

@[simp] theorem gcd_zero_left (i : ℤ) : gcd 0 i = nat_abs i := sorry

@[simp] theorem gcd_zero_right (i : ℤ) : gcd i 0 = nat_abs i := sorry

@[simp] theorem gcd_one_left (i : ℤ) : gcd 1 i = 1 := nat.gcd_one_left (nat_abs i)

@[simp] theorem gcd_one_right (i : ℤ) : gcd i 1 = 1 := nat.gcd_one_right (nat_abs i)

theorem gcd_mul_left (i : ℤ) (j : ℤ) (k : ℤ) : gcd (i * j) (i * k) = nat_abs i * gcd j k := sorry

theorem gcd_mul_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd (i * j) (k * j) = gcd i k * nat_abs j := sorry

theorem gcd_pos_of_non_zero_left {i : ℤ} (j : ℤ) (i_non_zero : i ≠ 0) : 0 < gcd i j :=
  nat.gcd_pos_of_pos_left (nat_abs j) (nat_abs_pos_of_ne_zero i_non_zero)

theorem gcd_pos_of_non_zero_right (i : ℤ) {j : ℤ} (j_non_zero : j ≠ 0) : 0 < gcd i j :=
  nat.gcd_pos_of_pos_right (nat_abs i) (nat_abs_pos_of_ne_zero j_non_zero)

theorem gcd_eq_zero_iff {i : ℤ} {j : ℤ} : gcd i j = 0 ↔ i = 0 ∧ j = 0 := sorry

theorem gcd_div {i : ℤ} {j : ℤ} {k : ℤ} (H1 : k ∣ i) (H2 : k ∣ j) :
    gcd (i / k) (j / k) = gcd i j / nat_abs k :=
  sorry

theorem gcd_div_gcd_div_gcd {i : ℤ} {j : ℤ} (H : 0 < gcd i j) :
    gcd (i / ↑(gcd i j)) (j / ↑(gcd i j)) = 1 :=
  sorry

theorem gcd_dvd_gcd_of_dvd_left {i : ℤ} {k : ℤ} (j : ℤ) (H : i ∣ k) : gcd i j ∣ gcd k j :=
  iff.mp coe_nat_dvd (dvd_gcd (dvd.trans (gcd_dvd_left i j) H) (gcd_dvd_right i j))

theorem gcd_dvd_gcd_of_dvd_right {i : ℤ} {k : ℤ} (j : ℤ) (H : i ∣ k) : gcd j i ∣ gcd j k :=
  iff.mp coe_nat_dvd (dvd_gcd (gcd_dvd_left j i) (dvd.trans (gcd_dvd_right j i) H))

theorem gcd_dvd_gcd_mul_left (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd (k * i) j :=
  gcd_dvd_gcd_of_dvd_left j (dvd_mul_left i k)

theorem gcd_dvd_gcd_mul_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd (i * k) j :=
  gcd_dvd_gcd_of_dvd_left j (dvd_mul_right i k)

theorem gcd_dvd_gcd_mul_left_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd i (k * j) :=
  gcd_dvd_gcd_of_dvd_right i (dvd_mul_left j k)

theorem gcd_dvd_gcd_mul_right_right (i : ℤ) (j : ℤ) (k : ℤ) : gcd i j ∣ gcd i (j * k) :=
  gcd_dvd_gcd_of_dvd_right i (dvd_mul_right j k)

theorem gcd_eq_left {i : ℤ} {j : ℤ} (H : i ∣ j) : gcd i j = nat_abs i := sorry

theorem gcd_eq_right {i : ℤ} {j : ℤ} (H : j ∣ i) : gcd i j = nat_abs j :=
  eq.mpr (id (Eq._oldrec (Eq.refl (gcd i j = nat_abs j)) (gcd_comm i j)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (gcd j i = nat_abs j)) (gcd_eq_left H))) (Eq.refl (nat_abs j)))

theorem ne_zero_of_gcd {x : ℤ} {y : ℤ} (hc : gcd x y ≠ 0) : x ≠ 0 ∨ y ≠ 0 := sorry

theorem exists_gcd_one {m : ℤ} {n : ℤ} (H : 0 < gcd m n) :
    ∃ (m' : ℤ), ∃ (n' : ℤ), gcd m' n' = 1 ∧ m = m' * ↑(gcd m n) ∧ n = n' * ↑(gcd m n) :=
  sorry

theorem exists_gcd_one' {m : ℤ} {n : ℤ} (H : 0 < gcd m n) :
    ∃ (g : ℕ), ∃ (m' : ℤ), ∃ (n' : ℤ), 0 < g ∧ gcd m' n' = 1 ∧ m = m' * ↑g ∧ n = n' * ↑g :=
  sorry

theorem pow_dvd_pow_iff {m : ℤ} {n : ℤ} {k : ℕ} (k0 : 0 < k) : m ^ k ∣ n ^ k ↔ m ∣ n := sorry

/-! ### lcm -/

theorem lcm_comm (i : ℤ) (j : ℤ) : lcm i j = lcm j i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i j = lcm j i)) (lcm.equations._eqn_1 i j)))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (nat.lcm (nat_abs i) (nat_abs j) = lcm j i))
          (lcm.equations._eqn_1 j i)))
      (nat.lcm_comm (nat_abs i) (nat_abs j)))

theorem lcm_assoc (i : ℤ) (j : ℤ) (k : ℤ) : lcm (↑(lcm i j)) k = lcm i ↑(lcm j k) := sorry

@[simp] theorem lcm_zero_left (i : ℤ) : lcm 0 i = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm 0 i = 0)) (lcm.equations._eqn_1 0 i)))
    (nat.lcm_zero_left (nat_abs i))

@[simp] theorem lcm_zero_right (i : ℤ) : lcm i 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i 0 = 0)) (lcm.equations._eqn_1 i 0)))
    (nat.lcm_zero_right (nat_abs i))

@[simp] theorem lcm_one_left (i : ℤ) : lcm 1 i = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm 1 i = nat_abs i)) (lcm.equations._eqn_1 1 i)))
    (nat.lcm_one_left (nat_abs i))

@[simp] theorem lcm_one_right (i : ℤ) : lcm i 1 = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i 1 = nat_abs i)) (lcm.equations._eqn_1 i 1)))
    (nat.lcm_one_right (nat_abs i))

@[simp] theorem lcm_self (i : ℤ) : lcm i i = nat_abs i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm i i = nat_abs i)) (lcm.equations._eqn_1 i i)))
    (nat.lcm_self (nat_abs i))

theorem dvd_lcm_left (i : ℤ) (j : ℤ) : i ∣ ↑(lcm i j) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (i ∣ ↑(lcm i j))) (lcm.equations._eqn_1 i j)))
    (iff.mpr coe_nat_dvd_right (nat.dvd_lcm_left (nat_abs i) (nat_abs j)))

theorem dvd_lcm_right (i : ℤ) (j : ℤ) : j ∣ ↑(lcm i j) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (j ∣ ↑(lcm i j))) (lcm.equations._eqn_1 i j)))
    (iff.mpr coe_nat_dvd_right (nat.dvd_lcm_right (nat_abs i) (nat_abs j)))

theorem lcm_dvd {i : ℤ} {j : ℤ} {k : ℤ} : i ∣ k → j ∣ k → ↑(lcm i j) ∣ k :=
  eq.mpr (id (Eq._oldrec (Eq.refl (i ∣ k → j ∣ k → ↑(lcm i j) ∣ k)) (lcm.equations._eqn_1 i j)))
    fun (hi : i ∣ k) (hj : j ∣ k) =>
      iff.mpr coe_nat_dvd_left
        (nat.lcm_dvd (iff.mpr nat_abs_dvd_abs_iff hi) (iff.mpr nat_abs_dvd_abs_iff hj))

end int

theorem pow_gcd_eq_one {M : Type u_1} [monoid M] (x : M) {m : ℕ} {n : ℕ} (hm : x ^ m = 1)
    (hn : x ^ n = 1) : x ^ nat.gcd m n = 1 :=
  sorry

end Mathlib


import measure_theory.integral.bochner
import measure_theory.function.l2_space
import measure_theory.measure.measure_space
import measure_theory.function.l1_space

open measure_theory measure_theory.measure
open_locale big_operators measure_theory topological_space

variables {α : Type*} [fintype α]

instance sum_is_finite_measure {α ι : Type*} [measurable_space α] [fintype ι] {μ : ι → measure α}
  [∀ i, is_finite_measure (μ i)] : is_finite_measure (sum μ) :=
begin
  refine ⟨_⟩,
  rw [measure.sum_apply _ measurable_set.univ, @tsum_eq_sum _ _ _ _ _ _ finset.univ],
  { simp only [ennreal.sum_lt_top, measure_ne_top, ne.def, not_false_iff, implies_true_iff] },
  { simp only [finset.mem_univ, not_true, forall_false_left, implies_true_iff] },
  { apply_instance },
  { apply_instance }
end

instance [measurable_space α] : is_finite_measure (count : measure α) :=
by apply sum_is_finite_measure

lemma lp (p : ennreal) (f : α → ℝ) :
  mem_ℒp f p (@count α ⊤) :=
begin
  refine mem_ℒp.mem_ℒp_of_exponent_le _ le_top,
  suffices : ∃ b : nnreal, ∀ x : α, ∥f x∥₊ ≤ b,
  { obtain ⟨b, hb⟩ := this,
    exact mem_ℒp_top_of_bound measurable_from_top.ae_strongly_measurable _ (@ae_of_all _ ⊤ _ _ hb) },
  by_cases nonempty α,
  { obtain ⟨x, hx⟩ := by exactI fintype.exists_max (λ x, ∥f x∥₊),
    exact ⟨_, hx⟩ },
  { exact ⟨0, λ x, false.rec _ (h ⟨x⟩)⟩ }
end

lemma integral_count {f : α → ℝ} :
  ∫ a, f a ∂(@count α ⊤) = ∑ a, f a :=
begin
  simp [count],
  rw integral_finset_sum_measure,
  { congr, funext i, apply integral_dirac', exact measurable_from_top.strongly_measurable },
  { refine λ i hi, ⟨measurable_from_top.ae_strongly_measurable, _⟩,
    rw [has_finite_integral, lintegral_dirac' _ measurable_from_top],
    simp only [ennreal.coe_lt_top] }
end

lemma lemma_2 {α : Type u_1} [fintype α] [measurable_space α] {μ : measure α} [is_finite_measure μ]
  (f : (Lp ℝ 2 μ)) :
  ∥f∥ = (∫ (a : α), f a ^ 2 ∂μ) ^ (2⁻¹ : ℝ) :=
begin
  simp only [norm, snorm, snorm', ennreal.bit0_eq_zero_iff, one_ne_zero, ennreal.bit0_eq_top_iff,
    ennreal.one_ne_top, ennreal.to_real_bit0, ennreal.one_to_real, ennreal.rpow_two, one_div,
    if_false],
  have := lintegral_coe_eq_integral (λ x, ∥f x∥₊ ^ 2) _,
  { simp only [ennreal.coe_pow, nnreal.coe_pow, coe_nnnorm] at this,
    rw [this, ennreal.of_real_rpow_of_nonneg, ennreal.to_real_of_real],
    { congr,
      exact funext (λ _, sq_abs _) },
    { apply real.rpow_nonneg_of_nonneg,
      apply integral_nonneg,
      rw pi.le_def,
      exact λ i, pow_two_nonneg _ },
    { apply integral_nonneg,
      rw pi.le_def,
      exact λ i, pow_two_nonneg _ },
    { norm_num } },
  { have := (Lp.mem_ℒp f).integrable_norm_rpow',
    simpa [this] }
end

lemma cauchy_schwarz (f g : α → ℝ) :
  (∑ x, f x * g x) ≤ (∑ x, f x ^ 2) ^ (2⁻¹ : ℝ) * (∑ x, g x ^ 2) ^ (2⁻¹ : ℝ) :=
begin
  simp_rw [← integral_count, pow_two],
  rw ← integral_congr_ae ((lp 2 f).coe_fn_to_Lp.mul (lp 2 g).coe_fn_to_Lp),
  rw ← integral_congr_ae ((lp 2 f).coe_fn_to_Lp.mul (lp 2 f).coe_fn_to_Lp),
  rw ← integral_congr_ae ((lp 2 g).coe_fn_to_Lp.mul (lp 2 g).coe_fn_to_Lp),
  convert ← @real_inner_le_norm _ _ ((lp 2 f).to_Lp f) ((lp 2 g).to_Lp g) using 1,
  simp only [← pow_two, lemma_2],
end


lemma lt_iff_succ_le (a b : mynat) : a < b ↔ succ a ≤ b :=
begin
split,
exact lt_aux_one a b,
exact lt_aux_two a b,
end


import category_theory.single_obj
       category_theory.functor
       category_theory.elements
       category_theory.action
       group_theory.free_group
       quiver
       misc
open category_theory

universes u v

class is_free_group (G) [group.{u} G] :=
(gp_gens : Type u)
(gp_emb : gp_gens → G)
(gp_lift {X} [group.{u} X] (f : gp_gens → X) : ∃! F : G →* X, ∀ a, f a = F (gp_emb a))

class is_free_groupoid (G) [groupoid.{v u} G] :=
(gpd_gens : quiver.{v u} G)
(gpd_emb : Π ⦃a b⦄, gpd_gens a b → (a ⟶ b))
(gpd_lift {X} [group.{v} X] (f : valu gpd_gens X) :
  ∃! F : G ⥤ single_obj X, ∀ {x y : G} (a : gpd_gens x y), f a = F.map (gpd_emb a))
(ind {P : Π {a b : G}, (a ⟶ b) → Prop}
  (base : ∀ a b (e : gpd_gens a b), P (gpd_emb e))
  (id : ∀ a, P (𝟙 a))
  (comp : ∀ a b c (f : a ⟶ b) (g : b ⟶ c), P f → P g → P (f ≫ g))
  (comp : ∀ a b (f : a ⟶ b), P f → P (inv f))
  {a b} (f : a ⟶ b) : P f)

open is_free_group is_free_groupoid

-- this restricted extensionality lemma should be enough for our purposes
lemma is_free_group_ext {G} [group G] [is_free_group G] (f : G →* G) :
  (∀ a : gp_gens G, f (gp_emb a) = gp_emb a) → ∀ g, f g = g :=
begin
  intro hyp,
  suffices : f = monoid_hom.id G,
  { intro g, rw this, refl },
  let F : gp_gens G → G := f ∘ gp_emb,
  rcases gp_lift F with ⟨p, hp, up⟩,
  have : f = p,
  { apply up, intros, refl },
  have : monoid_hom.id G = p,
  { apply up, intros, apply hyp },
  cc,
end

def free_group_is_free_group (A) : is_free_group (free_group A) :=
{ gp_gens := A,
  gp_emb := free_group.of,
  gp_lift := begin
    introsI X _ f,
    apply (free_group.lift.exists_unique_congr _).mp ⟨f, rfl, λ _, eq.symm⟩,
    intro, simp only [function.funext_iff, free_group.lift.of],
  end }

noncomputable def iso_free_group_of_is_free_group {G} [group G] [is_free_group G] :
  G ≃* free_group (gp_gens G) :=
let ⟨F, hF, uF⟩ := classical.indefinite_description _ (gp_lift $ @free_group.of (gp_gens G)) in
{ to_fun := F,
  inv_fun := free_group.lift gp_emb,
  left_inv := by { change ∀ g, ((free_group.lift gp_emb).comp F) g = g,
                   apply is_free_group_ext, simp [←hF] },
  right_inv := begin
    suffices : F.comp (free_group.lift gp_emb) = monoid_hom.id _,
    { rwa monoid_hom.ext_iff at this },
    apply free_group.ext_hom,
    simp [←hF]
  end,
  map_mul' := F.map_mul }

lemma is_free_group_induction {G} [group G] [is_free_group G]
  (P : G → Prop)
  (base : ∀ a, P (gp_emb a))
  (one : P 1)
  (mul : ∀ g h, P g → P h → P (g * h))
  (inv : ∀ g, P g → P (g⁻¹))
  (g : G) : P g :=
let H : subgroup G := {
  carrier  := P,
  one_mem' := one,
  mul_mem' := mul,
  inv_mem' := inv } in
let f : gp_gens G → H := λ a, ⟨gp_emb a, base a⟩ in
begin
  rcases gp_lift f with ⟨F, hF, _⟩,
  have : ∀ g, H.subtype.comp F g = g,
  { apply is_free_group_ext,
    intro a,
    change (F (gp_emb a)).val = _,
    rw ←hF },
  convert (F g).property,
  symmetry, apply this
end

-- being a free group is an isomorphism invariant
def is_free_group_mul_equiv {G H : Type u} [group G] [group H] [is_free_group G] (h : G ≃* H)
  : is_free_group H :=
{ gp_gens := gp_gens G,
  gp_emb := λ a, h (gp_emb a),
  gp_lift := begin
    introsI X _ f,
    refine (equiv.exists_unique_congr (homset_equiv_of_mul_equiv h) _).mp (gp_lift f),
    intros F, apply forall_congr,
    intro, apply eq.congr,
    { refl },
    { change F _ = F _, simp },
  end }


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import ring_theory.local_properties

/-!

# The meta properties of surjective ring homomorphisms.

-/

namespace ring_hom

open_locale tensor_product

open tensor_product algebra.tensor_product

local notation `surjective` := λ {X Y : Type*} [comm_ring X] [comm_ring Y] ,
  by exactI λ (f : X →+* Y), function.surjective f

lemma surjective_stable_under_composition :
  stable_under_composition surjective :=
by { introv R hf hg, exactI hg.comp hf }

lemma surjective_respects_iso :
  respects_iso surjective :=
begin
  apply surjective_stable_under_composition.respects_iso,
  introsI,
  exact e.surjective
end

lemma surjective_stable_under_base_change :
  stable_under_base_change surjective :=
begin
  refine stable_under_base_change.mk _ surjective_respects_iso _,
  classical,
  introv h x,
  resetI,
  induction x using tensor_product.induction_on with x y x y ex ey,
  { exact ⟨0, map_zero _⟩ },
  { obtain ⟨y, rfl⟩ := h y, use y • x, dsimp,
    rw [tensor_product.smul_tmul, algebra.algebra_map_eq_smul_one] },
  { obtain ⟨⟨x, rfl⟩, ⟨y, rfl⟩⟩ := ⟨ex, ey⟩, exact ⟨x + y, map_add _ x y⟩ }
end

open_locale big_operators

lemma surjective_of_localization_span :
  of_localization_span surjective :=
begin
  introv R hs H,
  resetI,
  letI := f.to_algebra,
  show function.surjective (algebra.of_id R S),
  rw [← algebra.range_top_iff_surjective, eq_top_iff],
  rintro x -,
  obtain ⟨l, hl⟩ :=
    (finsupp.mem_span_iff_total R s 1).mp (show _ ∈ ideal.span s, by { rw hs, trivial }),
  fapply subalgebra.mem_of_finset_sum_eq_one_of_pow_smul_mem _
    l.support (λ x : s, f x) (λ x : s, f (l x)),
  { dsimp only, simp_rw [← _root_.map_mul, ← map_sum, ← f.map_one], exact f.congr_arg hl },
  { exact λ _, set.mem_range_self _ },
  { exact λ _, set.mem_range_self _ },
  { intro r,
    obtain ⟨y, hy⟩ := H r (is_localization.mk' _ x (1 : submonoid.powers (f r))),
    obtain ⟨z, ⟨_, n, rfl⟩, rfl⟩ := is_localization.mk'_surjective (submonoid.powers (r : R)) y,
    erw [is_localization.map_mk', is_localization.eq] at hy,
    obtain ⟨⟨_, m, rfl⟩, hm⟩ := hy,
    refine ⟨m + n, _⟩,
    dsimp at hm ⊢,
    simp_rw [_root_.one_mul, ← _root_.mul_assoc, ← map_pow, ← f.map_mul, ← pow_add, map_pow] at hm,
    exact ⟨_, hm⟩ }
end

end ring_hom


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

! This file was ported from Lean 3 source module category_theory.subobject.mono_over
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Over
import Mathbin.CategoryTheory.Limits.Shapes.Images
import Mathbin.CategoryTheory.Adjunction.Reflective

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universe v₁ v₂ u₁ u₂

noncomputable section

namespace CategoryTheory

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

variable {C : Type u₁} [Category.{v₁} C] {X Y Z : C}

variable {D : Type u₂} [Category.{v₂} D]

/-- The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
def MonoOver (X : C) :=
  FullSubcategory fun f : Over X => Mono f.Hom deriving Category
#align category_theory.mono_over CategoryTheory.MonoOver

namespace MonoOver

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : Mono f] : MonoOver X
    where
  obj := Over.mk f
  property := hf
#align category_theory.mono_over.mk' CategoryTheory.MonoOver.mk'

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : MonoOver X ⥤ Over X :=
  fullSubcategoryInclusion _
#align category_theory.mono_over.forget CategoryTheory.MonoOver.forget

instance : Coe (MonoOver X) C where coe Y := Y.obj.left

@[simp]
theorem forget_obj_left {f} : ((forget X).obj f).left = (f : C) :=
  rfl
#align category_theory.mono_over.forget_obj_left CategoryTheory.MonoOver.forget_obj_left

@[simp]
theorem mk'_coe' {X A : C} (f : A ⟶ X) [hf : Mono f] : (mk' f : C) = A :=
  rfl
#align category_theory.mono_over.mk'_coe' CategoryTheory.MonoOver.mk'_coe'

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbrev arrow (f : MonoOver X) : (f : C) ⟶ X :=
  ((forget X).obj f).Hom
#align category_theory.mono_over.arrow CategoryTheory.MonoOver.arrow

@[simp]
theorem mk'_arrow {X A : C} (f : A ⟶ X) [hf : Mono f] : (mk' f).arrow = f :=
  rfl
#align category_theory.mono_over.mk'_arrow CategoryTheory.MonoOver.mk'_arrow

@[simp]
theorem forget_obj_hom {f} : ((forget X).obj f).Hom = f.arrow :=
  rfl
#align category_theory.mono_over.forget_obj_hom CategoryTheory.MonoOver.forget_obj_hom

instance : Full (forget X) :=
  FullSubcategory.full _

instance : Faithful (forget X) :=
  FullSubcategory.faithful _

instance mono (f : MonoOver X) : Mono f.arrow :=
  f.property
#align category_theory.mono_over.mono CategoryTheory.MonoOver.mono

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance isThin {X : C} : Quiver.IsThin (MonoOver X) := fun f g =>
  ⟨by
    intro h₁ h₂
    ext1
    erw [← cancel_mono g.arrow, over.w h₁, over.w h₂]⟩
#align category_theory.mono_over.is_thin CategoryTheory.MonoOver.isThin

@[reassoc.1]
theorem w {f g : MonoOver X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow :=
  Over.w _
#align category_theory.mono_over.w CategoryTheory.MonoOver.w

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbrev homMk {f g : MonoOver X} (h : f.obj.left ⟶ g.obj.left) (w : h ≫ g.arrow = f.arrow) : f ⟶ g :=
  Over.homMk h w
#align category_theory.mono_over.hom_mk CategoryTheory.MonoOver.homMk

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def isoMk {f g : MonoOver X} (h : f.obj.left ≅ g.obj.left) (w : h.Hom ≫ g.arrow = f.arrow) : f ≅ g
    where
  Hom := homMk h.Hom w
  inv := homMk h.inv (by rw [h.inv_comp_eq, w])
#align category_theory.mono_over.iso_mk CategoryTheory.MonoOver.isoMk

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp]
def mk'ArrowIso {X : C} (f : MonoOver X) : mk' f.arrow ≅ f :=
  isoMk (Iso.refl _) (by simp)
#align category_theory.mono_over.mk'_arrow_iso CategoryTheory.MonoOver.mk'ArrowIso

/-- Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : Over Y ⥤ Over X)
    (h : ∀ f : MonoOver Y, Mono (F.obj ((MonoOver.forget Y).obj f)).Hom) : MonoOver Y ⥤ MonoOver X
    where
  obj f := ⟨_, h f⟩
  map _ _ k := (MonoOver.forget X).preimage ((MonoOver.forget Y ⋙ F).map k)
#align category_theory.mono_over.lift CategoryTheory.MonoOver.lift

/-- Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def liftIso {Y : D} {F₁ F₂ : Over Y ⥤ Over X} (h₁ h₂) (i : F₁ ≅ F₂) : lift F₁ h₁ ≅ lift F₂ h₂ :=
  fullyFaithfulCancelRight (MonoOver.forget X) (isoWhiskerLeft (MonoOver.forget Y) i)
#align category_theory.mono_over.lift_iso CategoryTheory.MonoOver.liftIso

/-- `mono_over.lift` commutes with composition of functors. -/
def liftComp {X Z : C} {Y : D} (F : Over X ⥤ Over Y) (G : Over Y ⥤ Over Z) (h₁ h₂) :
    lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) fun f => h₂ ⟨_, h₁ f⟩ :=
  fullyFaithfulCancelRight (MonoOver.forget _) (Iso.refl _)
#align category_theory.mono_over.lift_comp CategoryTheory.MonoOver.liftComp

/-- `mono_over.lift` preserves the identity functor. -/
def liftId : (lift (𝟭 (Over X)) fun f => f.2) ≅ 𝟭 _ :=
  fullyFaithfulCancelRight (MonoOver.forget _) (Iso.refl _)
#align category_theory.mono_over.lift_id CategoryTheory.MonoOver.liftId

@[simp]
theorem lift_comm (F : Over Y ⥤ Over X)
    (h : ∀ f : MonoOver Y, Mono (F.obj ((MonoOver.forget Y).obj f)).Hom) :
    lift F h ⋙ MonoOver.forget X = MonoOver.forget Y ⋙ F :=
  rfl
#align category_theory.mono_over.lift_comm CategoryTheory.MonoOver.lift_comm

@[simp]
theorem lift_obj_arrow {Y : D} (F : Over Y ⥤ Over X)
    (h : ∀ f : MonoOver Y, Mono (F.obj ((MonoOver.forget Y).obj f)).Hom) (f : MonoOver Y) :
    ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).Hom :=
  rfl
#align category_theory.mono_over.lift_obj_arrow CategoryTheory.MonoOver.lift_obj_arrow

/-- Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : Over A} (h₁ h₂) : MonoOver f ≌ MonoOver f.left
    where
  Functor := MonoOver.lift f.iteratedSliceEquiv.Functor h₁
  inverse := MonoOver.lift f.iteratedSliceEquiv.inverse h₂
  unitIso :=
    MonoOver.liftId.symm ≪≫
      MonoOver.liftIso _ _ f.iteratedSliceEquiv.unitIso ≪≫ (MonoOver.liftComp _ _ _ _).symm
  counitIso :=
    MonoOver.liftComp _ _ _ _ ≪≫
      MonoOver.liftIso _ _ f.iteratedSliceEquiv.counitIso ≪≫ MonoOver.liftId
#align category_theory.mono_over.slice CategoryTheory.MonoOver.slice

section Pullback

variable [HasPullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : MonoOver Y ⥤ MonoOver X :=
  MonoOver.lift (Over.pullback f)
    (by
      intro g
      apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _
      change mono g.arrow
      infer_instance)
#align category_theory.mono_over.pullback CategoryTheory.MonoOver.pullback

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullbackComp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
  liftIso _ _ (Over.pullbackComp _ _) ≪≫ (liftComp _ _ _ _).symm
#align category_theory.mono_over.pullback_comp CategoryTheory.MonoOver.pullbackComp

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullbackId : pullback (𝟙 X) ≅ 𝟭 _ :=
  liftIso _ _ Over.pullbackId ≪≫ liftId
#align category_theory.mono_over.pullback_id CategoryTheory.MonoOver.pullbackId

@[simp]
theorem pullback_obj_left (f : X ⟶ Y) (g : MonoOver Y) :
    ((pullback f).obj g : C) = Limits.pullback g.arrow f :=
  rfl
#align category_theory.mono_over.pullback_obj_left CategoryTheory.MonoOver.pullback_obj_left

@[simp]
theorem pullback_obj_arrow (f : X ⟶ Y) (g : MonoOver Y) :
    ((pullback f).obj g).arrow = pullback.snd :=
  rfl
#align category_theory.mono_over.pullback_obj_arrow CategoryTheory.MonoOver.pullback_obj_arrow

end Pullback

section Map

attribute [instance] mono_comp

/-- We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [Mono f] : MonoOver X ⥤ MonoOver Y :=
  lift (Over.map f) fun g => by apply mono_comp g.arrow f
#align category_theory.mono_over.map CategoryTheory.MonoOver.map

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def mapComp (f : X ⟶ Y) (g : Y ⟶ Z) [Mono f] [Mono g] : map (f ≫ g) ≅ map f ⋙ map g :=
  liftIso _ _ (Over.mapComp _ _) ≪≫ (liftComp _ _ _ _).symm
#align category_theory.mono_over.map_comp CategoryTheory.MonoOver.mapComp

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def mapId : map (𝟙 X) ≅ 𝟭 _ :=
  liftIso _ _ Over.mapId ≪≫ liftId
#align category_theory.mono_over.map_id CategoryTheory.MonoOver.mapId

@[simp]
theorem map_obj_left (f : X ⟶ Y) [Mono f] (g : MonoOver X) : ((map f).obj g : C) = g.obj.left :=
  rfl
#align category_theory.mono_over.map_obj_left CategoryTheory.MonoOver.map_obj_left

@[simp]
theorem map_obj_arrow (f : X ⟶ Y) [Mono f] (g : MonoOver X) : ((map f).obj g).arrow = g.arrow ≫ f :=
  rfl
#align category_theory.mono_over.map_obj_arrow CategoryTheory.MonoOver.map_obj_arrow

instance fullMap (f : X ⟶ Y) [Mono f] : Full (map f)
    where preimage g h e := by
    refine' hom_mk e.left _
    rw [← cancel_mono f, assoc]
    apply w e
#align category_theory.mono_over.full_map CategoryTheory.MonoOver.fullMap

instance faithful_map (f : X ⟶ Y) [Mono f] : Faithful (map f) where
#align category_theory.mono_over.faithful_map CategoryTheory.MonoOver.faithful_map

/-- Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps]
def mapIso {A B : C} (e : A ≅ B) : MonoOver A ≌ MonoOver B
    where
  Functor := map e.Hom
  inverse := map e.inv
  unitIso := ((mapComp _ _).symm ≪≫ eqToIso (by simp) ≪≫ mapId).symm
  counitIso := (mapComp _ _).symm ≪≫ eqToIso (by simp) ≪≫ mapId
#align category_theory.mono_over.map_iso CategoryTheory.MonoOver.mapIso

section

variable (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps]
def congr (e : C ≌ D) : MonoOver X ≌ MonoOver (e.Functor.obj X)
    where
  Functor :=
    lift (Over.post e.Functor) fun f => by
      dsimp
      infer_instance
  inverse :=
    (lift (Over.post e.inverse) fun f => by
        dsimp
        infer_instance) ⋙
      (mapIso (e.unitIso.symm.app X)).Functor
  unitIso := NatIso.ofComponents (fun Y => isoMk (e.unitIso.app Y) (by tidy)) (by tidy)
  counitIso := NatIso.ofComponents (fun Y => isoMk (e.counitIso.app Y) (by tidy)) (by tidy)
#align category_theory.mono_over.congr CategoryTheory.MonoOver.congr

end

section

variable [HasPullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def mapPullbackAdj (f : X ⟶ Y) [Mono f] : map f ⊣ pullback f :=
  Adjunction.restrictFullyFaithful (forget X) (forget Y) (Over.mapPullbackAdj f) (Iso.refl _)
    (Iso.refl _)
#align category_theory.mono_over.map_pullback_adj CategoryTheory.MonoOver.mapPullbackAdj

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullbackMapSelf (f : X ⟶ Y) [Mono f] : map f ⋙ pullback f ≅ 𝟭 _ :=
  (asIso (MonoOver.mapPullbackAdj f).Unit).symm
#align category_theory.mono_over.pullback_map_self CategoryTheory.MonoOver.pullbackMapSelf

end

end Map

section Image

variable (f : X ⟶ Y) [HasImage f]

/-- The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def imageMonoOver (f : X ⟶ Y) [HasImage f] : MonoOver Y :=
  MonoOver.mk' (image.ι f)
#align category_theory.mono_over.image_mono_over CategoryTheory.MonoOver.imageMonoOver

@[simp]
theorem imageMonoOver_arrow (f : X ⟶ Y) [HasImage f] : (imageMonoOver f).arrow = image.ι f :=
  rfl
#align category_theory.mono_over.image_mono_over_arrow CategoryTheory.MonoOver.imageMonoOver_arrow

end Image

section Image

variable [HasImages C]

/-- Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : Over X ⥤ MonoOver X where
  obj f := imageMonoOver f.Hom
  map f g k := by
    apply (forget X).preimage _
    apply over.hom_mk _ _
    refine'
      image.lift
        { i := image _
          m := image.ι g.hom
          e := k.left ≫ factor_thru_image g.hom }
    apply image.lift_fac
#align category_theory.mono_over.image CategoryTheory.MonoOver.image

/-- `mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def imageForgetAdj : image ⊣ forget X :=
  Adjunction.mkOfHomEquiv
    {
      homEquiv := fun f g =>
        { toFun := fun k =>
            by
            apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _
            change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom
            rw [assoc, over.w k]
            apply image.fac
          invFun := fun k => by
            refine' over.hom_mk _ _
            refine'
              image.lift
                { i := g.obj.left
                  m := g.arrow
                  e := k.left
                  fac := over.w k }
            apply image.lift_fac
          left_inv := fun k => Subsingleton.elim _ _
          right_inv := fun k => by
            ext1
            change factor_thru_image _ ≫ image.lift _ = _
            rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom]
            exact (over.w k).symm } }
#align category_theory.mono_over.image_forget_adj CategoryTheory.MonoOver.imageForgetAdj

instance : IsRightAdjoint (forget X) where
  left := image
  adj := imageForgetAdj

instance reflective : Reflective (forget X) where
#align category_theory.mono_over.reflective CategoryTheory.MonoOver.reflective

/-- Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forgetImage : forget X ⋙ image ≅ 𝟭 (MonoOver X) :=
  asIso (Adjunction.counit imageForgetAdj)
#align category_theory.mono_over.forget_image CategoryTheory.MonoOver.forgetImage

end Image

section Exists

variable [HasImages C]

/-- In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def exists (f : X ⟶ Y) : MonoOver X ⥤ MonoOver Y :=
  forget _ ⋙ Over.map f ⋙ image
#align category_theory.mono_over.exists CategoryTheory.MonoOver.exists

instance faithful_exists (f : X ⟶ Y) : Faithful (exists f) where
#align category_theory.mono_over.faithful_exists CategoryTheory.MonoOver.faithful_exists

/-- When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def existsIsoMap (f : X ⟶ Y) [Mono f] : exists f ≅ map f :=
  NatIso.ofComponents
    (by
      intro Z
      suffices : (forget _).obj ((exists f).obj Z) ≅ (forget _).obj ((map f).obj Z)
      apply (forget _).preimageIso this
      apply over.iso_mk _ _
      apply image_mono_iso_source (Z.arrow ≫ f)
      apply image_mono_iso_source_hom_self)
    (by
      intro Z₁ Z₂ g
      ext1
      change
        image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).Hom =
          (image_mono_iso_source (Z₁.arrow ≫ f)).Hom ≫ g.left
      rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
        image_mono_iso_source_hom_self]
      apply image.lift_fac)
#align category_theory.mono_over.exists_iso_map CategoryTheory.MonoOver.existsIsoMap

/-- `exists` is adjoint to `pullback` when images exist -/
def existsPullbackAdj (f : X ⟶ Y) [HasPullbacks C] : exists f ⊣ pullback f :=
  Adjunction.restrictFullyFaithful (forget X) (𝟭 _) ((Over.mapPullbackAdj f).comp imageForgetAdj)
    (Iso.refl _) (Iso.refl _)
#align category_theory.mono_over.exists_pullback_adj CategoryTheory.MonoOver.existsPullbackAdj

end Exists

end MonoOver

end CategoryTheory


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/

import data.mv_polynomial.rename
import data.polynomial.algebra_map
import data.mv_polynomial.variables
import data.finsupp.fin
import logic.equiv.fin
import algebra.big_operators.fin

/-!
# Equivalences between polynomial rings

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

This file establishes a number of equivalences between polynomial rings,
based on equivalences between the underlying types.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

## Tags

equivalence, isomorphism, morphism, ring hom, hom

-/

noncomputable theory

open_locale classical big_operators polynomial

open set function finsupp add_monoid_algebra

universes u v w x
variables {R : Type u} {S₁ : Type v} {S₂ : Type w} {S₃ : Type x}

namespace mv_polynomial
variables {σ : Type*} {a a' a₁ a₂ : R} {e : ℕ} {s : σ →₀ ℕ}

section equiv

variables (R) [comm_semiring R]

/--
The ring isomorphism between multivariable polynomials in a single variable and
polynomials over the ground ring.
-/
@[simps]
def punit_alg_equiv : mv_polynomial punit R ≃ₐ[R] R[X] :=
{ to_fun    := eval₂ polynomial.C (λu:punit, polynomial.X),
  inv_fun   := polynomial.eval₂ mv_polynomial.C (X punit.star),
  left_inv  :=
    begin
      let f : R[X] →+* mv_polynomial punit R :=
        (polynomial.eval₂_ring_hom mv_polynomial.C (X punit.star)),
      let g : mv_polynomial punit R →+* R[X] :=
        (eval₂_hom polynomial.C (λu:punit, polynomial.X)),
      show ∀ p, f.comp g p = p,
      apply is_id,
      { ext a, dsimp, rw [eval₂_C, polynomial.eval₂_C] },
      { rintros ⟨⟩, dsimp, rw [eval₂_X, polynomial.eval₂_X] }
    end,
  right_inv := assume p, polynomial.induction_on p
    (assume a, by rw [polynomial.eval₂_C, mv_polynomial.eval₂_C])
    (assume p q hp hq, by rw [polynomial.eval₂_add, mv_polynomial.eval₂_add, hp, hq])
    (assume p n hp,
      by rw [polynomial.eval₂_mul, polynomial.eval₂_pow, polynomial.eval₂_X, polynomial.eval₂_C,
        eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]),
  map_mul'  := λ _ _, eval₂_mul _ _,
  map_add'  := λ _ _, eval₂_add _ _,
  commutes' := λ _, eval₂_C _ _ _}

section map
variables {R} (σ)

/-- If `e : A ≃+* B` is an isomorphism of rings, then so is `map e`. -/
@[simps apply]
def map_equiv [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  mv_polynomial σ S₁ ≃+* mv_polynomial σ S₂ :=
{ to_fun    := map (e : S₁ →+* S₂),
  inv_fun   := map (e.symm : S₂ →+* S₁),
  left_inv  := map_left_inverse e.left_inv,
  right_inv := map_right_inverse e.right_inv,
  ..map (e : S₁ →+* S₂) }

@[simp] lemma map_equiv_refl :
  map_equiv σ (ring_equiv.refl R) = ring_equiv.refl _ :=
ring_equiv.ext map_id

@[simp] lemma map_equiv_symm [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  (map_equiv σ e).symm = map_equiv σ e.symm := rfl

@[simp] lemma map_equiv_trans [comm_semiring S₁] [comm_semiring S₂] [comm_semiring S₃]
  (e : S₁ ≃+* S₂) (f : S₂ ≃+* S₃) :
  (map_equiv σ e).trans (map_equiv σ f) = map_equiv σ (e.trans f) :=
ring_equiv.ext (map_map e f)

variables {A₁ A₂ A₃ : Type*} [comm_semiring A₁] [comm_semiring A₂] [comm_semiring A₃]
variables [algebra R A₁] [algebra R A₂] [algebra R A₃]

/-- If `e : A ≃ₐ[R] B` is an isomorphism of `R`-algebras, then so is `map e`. -/
@[simps apply]
def map_alg_equiv (e : A₁ ≃ₐ[R] A₂) :
  mv_polynomial σ A₁ ≃ₐ[R] mv_polynomial σ A₂ :=
{ to_fun := map (e : A₁ →+* A₂),
  ..map_alg_hom (e : A₁ →ₐ[R] A₂),
  ..map_equiv σ (e : A₁ ≃+* A₂) }

@[simp] lemma map_alg_equiv_refl :
  map_alg_equiv σ (alg_equiv.refl : A₁ ≃ₐ[R] A₁) = alg_equiv.refl :=
alg_equiv.ext map_id

@[simp] lemma map_alg_equiv_symm (e : A₁ ≃ₐ[R] A₂) :
  (map_alg_equiv σ e).symm = map_alg_equiv σ e.symm := rfl

@[simp] lemma map_alg_equiv_trans (e : A₁ ≃ₐ[R] A₂) (f : A₂ ≃ₐ[R] A₃) :
  (map_alg_equiv σ e).trans (map_alg_equiv σ f) = map_alg_equiv σ (e.trans f) :=
alg_equiv.ext (map_map e f)

end map

section
variables (S₁ S₂ S₃)

/--
The function from multivariable polynomials in a sum of two types,
to multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.

See `sum_ring_equiv` for the ring isomorphism.
-/
def sum_to_iter : mv_polynomial (S₁ ⊕ S₂) R →+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
eval₂_hom (C.comp C) (λbc, sum.rec_on bc X (C ∘ X))

@[simp]
lemma sum_to_iter_C (a : R) : sum_to_iter R S₁ S₂ (C a) = C (C a) :=
eval₂_C _ _ a

@[simp]
lemma sum_to_iter_Xl (b : S₁) : sum_to_iter R S₁ S₂ (X (sum.inl b)) = X b :=
eval₂_X _ _ (sum.inl b)

@[simp]
lemma sum_to_iter_Xr (c : S₂) : sum_to_iter R S₁ S₂ (X (sum.inr c)) = C (X c) :=
eval₂_X _ _ (sum.inr c)

/--
The function from multivariable polynomials in one type,
with coefficents in multivariable polynomials in another type,
to multivariable polynomials in the sum of the two types.

See `sum_ring_equiv` for the ring isomorphism.
-/
def iter_to_sum : mv_polynomial S₁ (mv_polynomial S₂ R) →+* mv_polynomial (S₁ ⊕ S₂) R :=
eval₂_hom (eval₂_hom C (X ∘ sum.inr)) (X ∘ sum.inl)

lemma iter_to_sum_C_C (a : R) : iter_to_sum R S₁ S₂ (C (C a)) = C a :=
eq.trans (eval₂_C _ _ (C a)) (eval₂_C _ _ _)

lemma iter_to_sum_X (b : S₁) : iter_to_sum R S₁ S₂ (X b) = X (sum.inl b) :=
eval₂_X _ _ _

lemma iter_to_sum_C_X (c : S₂) : iter_to_sum R S₁ S₂ (C (X c)) = X (sum.inr c) :=
eq.trans (eval₂_C _ _ (X c)) (eval₂_X _ _ _)

variable (σ)

/-- The algebra isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_alg_equiv [he : is_empty σ] : mv_polynomial σ R ≃ₐ[R] R :=
alg_equiv.of_alg_hom
  (aeval (is_empty.elim he))
  (algebra.of_id _ _)
  (by { ext, simp [algebra.of_id_apply, algebra_map_eq] })
  (by { ext i m, exact is_empty.elim' he i })

/-- The ring isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_ring_equiv [he : is_empty σ] : mv_polynomial σ R ≃+* R :=
(is_empty_alg_equiv R σ).to_ring_equiv

variable {σ}

/-- A helper function for `sum_ring_equiv`. -/
@[simps]
def mv_polynomial_equiv_mv_polynomial [comm_semiring S₃]
  (f : mv_polynomial S₁ R →+* mv_polynomial S₂ S₃)
  (g : mv_polynomial S₂ S₃ →+* mv_polynomial S₁ R)
  (hfgC : (f.comp g).comp C = C)
  (hfgX : ∀n, f (g (X n)) = X n)
  (hgfC : (g.comp f).comp C = C)
  (hgfX : ∀n, g (f (X n)) = X n) :
  mv_polynomial S₁ R ≃+* mv_polynomial S₂ S₃ :=
{ to_fun    := f, inv_fun := g,
  left_inv  := is_id (ring_hom.comp _ _) hgfC hgfX,
  right_inv := is_id (ring_hom.comp _ _) hfgC hfgX,
  map_mul'  := f.map_mul,
  map_add'  := f.map_add }

/--
The ring isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_ring_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
begin
  apply @mv_polynomial_equiv_mv_polynomial R (S₁ ⊕ S₂) _ _ _ _
    (sum_to_iter R S₁ S₂) (iter_to_sum R S₁ S₂),
  { refine ring_hom.ext (λ p, _),
    rw [ring_hom.comp_apply],
    convert hom_eq_hom ((sum_to_iter R S₁ S₂).comp ((iter_to_sum R S₁ S₂).comp C)) C _ _ p,
    { ext1 a, dsimp, rw [iter_to_sum_C_C R S₁ S₂, sum_to_iter_C R S₁ S₂] },
    { assume c, dsimp, rw [iter_to_sum_C_X R S₁ S₂, sum_to_iter_Xr R S₁ S₂] } },
  { assume b, rw [iter_to_sum_X R S₁ S₂, sum_to_iter_Xl R S₁ S₂] },
  { ext1 a, rw [ring_hom.comp_apply, ring_hom.comp_apply,
      sum_to_iter_C R S₁ S₂, iter_to_sum_C_C R S₁ S₂] },
  { assume n, cases n with b c,
    { rw [sum_to_iter_Xl, iter_to_sum_X] },
    { rw [sum_to_iter_Xr, iter_to_sum_C_X] } },
end

/--
The algebra isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_alg_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃ₐ[R]
  mv_polynomial S₁ (mv_polynomial S₂ R) :=
{ commutes' := begin
    intro r,
    have A : algebra_map R (mv_polynomial S₁ (mv_polynomial S₂ R)) r = (C (C r) : _), by refl,
    have B : algebra_map R (mv_polynomial (S₁ ⊕ S₂) R) r = C r, by refl,
    simp only [sum_ring_equiv, sum_to_iter_C, mv_polynomial_equiv_mv_polynomial_apply,
      ring_equiv.to_fun_eq_coe, A, B],
  end,
  ..sum_ring_equiv R S₁ S₂ }

section

-- this speeds up typeclass search in the lemma below
local attribute [instance, priority 2000] is_scalar_tower.right

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
polynomials with coefficients in `mv_polynomial S₁ R`.
-/
@[simps] def option_equiv_left :
  mv_polynomial (option S₁) R ≃ₐ[R] polynomial (mv_polynomial S₁ R) :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim polynomial.X (λ s, polynomial.C (X s))))
  (polynomial.aeval_tower (mv_polynomial.rename some) (X none))
  (by ext : 2; simp [← polynomial.C_eq_algebra_map])
  (by ext i : 2; cases i; simp)

end

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
multivariable polynomials with coefficients in polynomials.
-/
def option_equiv_right : mv_polynomial (option S₁) R ≃ₐ[R] mv_polynomial S₁ R[X] :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim (C polynomial.X) X))
  (mv_polynomial.aeval_tower (polynomial.aeval (X none)) (λ i, X (option.some i)))
  begin
    ext : 2;
    simp only [mv_polynomial.algebra_map_eq, option.elim, alg_hom.coe_comp, alg_hom.id_comp,
      is_scalar_tower.coe_to_alg_hom', comp_app, aeval_tower_C, polynomial.aeval_X, aeval_X,
      option.elim, aeval_tower_X, alg_hom.coe_id, id.def, eq_self_iff_true, implies_true_iff],
  end
  begin
    ext ⟨i⟩ : 2;
    simp only [option.elim, alg_hom.coe_comp, comp_app, aeval_X, aeval_tower_C,
      polynomial.aeval_X, alg_hom.coe_id, id.def, aeval_tower_X],
  end

variables (n : ℕ)

/--
The algebra isomorphism between multivariable polynomials in `fin (n + 1)` and
polynomials over multivariable polynomials in `fin n`.
-/
def fin_succ_equiv :
  mv_polynomial (fin (n + 1)) R ≃ₐ[R] polynomial (mv_polynomial (fin n) R) :=
(rename_equiv R (fin_succ_equiv n)).trans
  (option_equiv_left R (fin n))

lemma fin_succ_equiv_eq :
  (fin_succ_equiv R n : mv_polynomial (fin (n + 1)) R →+* polynomial (mv_polynomial (fin n) R)) =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) :=
begin
  ext : 2,
  { simp only [fin_succ_equiv, option_equiv_left_apply, aeval_C, alg_equiv.coe_trans,
      ring_hom.coe_coe, coe_eval₂_hom, comp_app, rename_equiv_apply, eval₂_C, ring_hom.coe_comp,
      rename_C],
    refl },
  { intro i,
    refine fin.cases _ _ i;
    simp [fin_succ_equiv] }
end

@[simp] lemma fin_succ_equiv_apply (p : mv_polynomial (fin (n + 1)) R) :
  fin_succ_equiv R n p =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) p :=
by { rw ← fin_succ_equiv_eq, refl }

lemma fin_succ_equiv_comp_C_eq_C {R : Type u} [comm_semiring R] (n : ℕ) :
  (↑(mv_polynomial.fin_succ_equiv R n).symm : polynomial (mv_polynomial (fin n) R) →+* _).comp
    ((polynomial.C).comp (mv_polynomial.C))
    = (mv_polynomial.C : R →+* mv_polynomial (fin n.succ) R) :=
begin
  refine ring_hom.ext (λ x, _),
  rw ring_hom.comp_apply,
  refine (mv_polynomial.fin_succ_equiv R n).injective
    (trans ((mv_polynomial.fin_succ_equiv R n).apply_symm_apply _) _),
  simp only [mv_polynomial.fin_succ_equiv_apply, mv_polynomial.eval₂_hom_C],
end

variables {n} {R}

lemma fin_succ_equiv_X_zero :
  fin_succ_equiv R n (X 0) = polynomial.X := by simp

lemma fin_succ_equiv_X_succ {j : fin n} :
  fin_succ_equiv R n (X j.succ) = polynomial.C (X j) := by simp

/-- The coefficient of `m` in the `i`-th coefficient of `fin_succ_equiv R n f` equals the
    coefficient of `finsupp.cons i m` in `f`. -/
lemma fin_succ_equiv_coeff_coeff (m : fin n →₀ ℕ)
  (f : mv_polynomial (fin (n + 1)) R) (i : ℕ) :
  coeff m (polynomial.coeff (fin_succ_equiv R n f) i) = coeff (m.cons i) f :=
begin
  induction f using mv_polynomial.induction_on' with j r p q hp hq generalizing i m,
  swap,
  { simp only [(fin_succ_equiv R n).map_add, polynomial.coeff_add, coeff_add, hp, hq] },
  simp only [fin_succ_equiv_apply, coe_eval₂_hom, eval₂_monomial, ring_hom.coe_comp, prod_pow,
    polynomial.coeff_C_mul, coeff_C_mul, coeff_monomial,
    fin.prod_univ_succ, fin.cases_zero, fin.cases_succ, ← ring_hom.map_prod, ← ring_hom.map_pow],
  rw [← mul_boole, mul_comm (polynomial.X ^ j 0), polynomial.coeff_C_mul_X_pow], congr' 1,
  obtain rfl | hjmi := eq_or_ne j (m.cons i),
  { simpa only [cons_zero, cons_succ, if_pos rfl, monomial_eq, C_1, one_mul, prod_pow]
      using coeff_monomial m m (1:R), },
  { simp only [hjmi, if_false],
    obtain hij | rfl := ne_or_eq i (j 0),
    { simp only [hij, if_false, coeff_zero] },
    simp only [eq_self_iff_true, if_true],
    have hmj : m ≠ j.tail, { rintro rfl, rw [cons_tail] at hjmi, contradiction },
    simpa only [monomial_eq, C_1, one_mul, prod_pow, finsupp.tail_apply, if_neg hmj.symm]
      using coeff_monomial m j.tail (1:R), }
end

lemma coeff_eval_eq_eval_coeff (s' : fin n → R) (f : polynomial (mv_polynomial (fin n) R))
  (i : ℕ) : polynomial.coeff (polynomial.map (eval s') f) i = eval s' (polynomial.coeff f i) :=
by simp only [polynomial.coeff_map]

lemma support_coeff_fin_succ_equiv {f : mv_polynomial (fin (n + 1)) R} {i : ℕ}
  {m : fin n →₀ ℕ } : m ∈ (polynomial.coeff ((fin_succ_equiv R n) f) i).support
   ↔ (finsupp.cons i m) ∈ f.support :=
begin
  apply iff.intro,
  { intro h,
    simpa [←fin_succ_equiv_coeff_coeff] using h },
  { intro h,
    simpa [mem_support_iff, ←fin_succ_equiv_coeff_coeff m f i] using h },
end

lemma fin_succ_equiv_support (f : mv_polynomial (fin (n + 1)) R) :
  (fin_succ_equiv R n f).support = finset.image (λ m : fin (n + 1)→₀ ℕ, m 0) f.support :=
begin
  ext i,
  rw [polynomial.mem_support_iff, finset.mem_image, nonzero_iff_exists],
  split,
  { rintro ⟨m, hm⟩,
    refine ⟨cons i m, _, cons_zero _ _⟩,
    rw ← support_coeff_fin_succ_equiv,
    simpa using hm, },
  { rintro ⟨m, h, rfl⟩,
    refine ⟨tail m, _⟩,
    rwa [← coeff, ← mem_support_iff, support_coeff_fin_succ_equiv, cons_tail] },
end

lemma fin_succ_equiv_support' {f : mv_polynomial (fin (n + 1)) R} {i : ℕ} :
  finset.image (finsupp.cons i) (polynomial.coeff ((fin_succ_equiv R n) f) i).support
   = f.support.filter(λ m, m 0 = i) :=
begin
  ext m,
  rw [finset.mem_filter, finset.mem_image, mem_support_iff],
  conv_lhs
  { congr,
    funext,
    rw [mem_support_iff, fin_succ_equiv_coeff_coeff, ne.def] },
  split,
  { rintros ⟨m',⟨h, hm'⟩⟩,
    simp only [←hm'],
    exact ⟨h, by rw cons_zero⟩ },
  { intro h,
    use tail m,
    rw [← h.2, cons_tail],
    simp [h.1] }
end

lemma support_fin_succ_equiv_nonempty {f : mv_polynomial (fin (n + 1)) R} (h : f ≠ 0) :
  (fin_succ_equiv R n f).support.nonempty :=
begin
  by_contradiction c,
  simp only [finset.not_nonempty_iff_eq_empty, polynomial.support_eq_empty] at c,
  have t'' : (fin_succ_equiv R n f) ≠ 0,
  { let ii := (fin_succ_equiv R n).symm,
    have h' : f = 0 :=
      calc f = ii (fin_succ_equiv R n f) : by simpa only [ii, ←alg_equiv.inv_fun_eq_symm]
                                             using ((fin_succ_equiv R n).left_inv f).symm
      ...    = ii 0 : by rw c
      ...    = 0 : by simp,
    simpa [h'] using h },
  simpa [c] using h,
end

lemma degree_fin_succ_equiv {f : mv_polynomial (fin (n + 1)) R} (h : f ≠ 0) :
  (fin_succ_equiv R n f).degree = degree_of 0 f :=
begin
  have h' : (fin_succ_equiv R n f).support.sup (λ x , x)  = degree_of 0 f,
  { rw [degree_of_eq_sup, fin_succ_equiv_support f, finset.sup_image] },
  rw [polynomial.degree, ← h', finset.coe_sup_of_nonempty (support_fin_succ_equiv_nonempty h),
    finset.max_eq_sup_coe],
end

lemma nat_degree_fin_succ_equiv (f : mv_polynomial (fin (n + 1)) R) :
  (fin_succ_equiv R n f).nat_degree = degree_of 0 f :=
begin
  by_cases c : f = 0,
  { rw [c, (fin_succ_equiv R n).map_zero, polynomial.nat_degree_zero, degree_of_zero] },
  { rw [polynomial.nat_degree, degree_fin_succ_equiv (by simpa only [ne.def]) ],
    simp },
end

lemma degree_of_coeff_fin_succ_equiv (p : mv_polynomial (fin (n + 1)) R) (j : fin n)
  (i : ℕ) : degree_of j (polynomial.coeff (fin_succ_equiv R n p) i) ≤ degree_of j.succ p :=
begin
  rw [degree_of_eq_sup, degree_of_eq_sup, finset.sup_le_iff],
  intros m hm,
  rw ← finsupp.cons_succ j i m,
  convert finset.le_sup (support_coeff_fin_succ_equiv.1 hm),
  refl,
end

end

end equiv

end mv_polynomial