/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.topological_fiber_bundle
import geometry.manifold.smooth_manifold_with_corners

/-!
# Basic smooth bundles

In general, a smooth bundle is a bundle over a smooth manifold, whose fiber is a manifold, and
for which the coordinate changes are smooth. In this definition, there are charts involved at
several places: in the manifold structure of the base, in the manifold structure of the fibers, and
in the local trivializations. This makes it a complicated object in general. There is however a
specific situation where things are much simpler: when the fiber is a vector space (no need for
charts for the fibers), and when the local trivializations of the bundle and the charts of the base
coincide. Then everything is expressed in terms of the charts of the base, making for a much
simpler overall structure, which is easier to manipulate formally.

Most vector bundles that naturally occur in differential geometry are of this form:
the tangent bundle, the cotangent bundle, differential forms (used to define de Rham cohomology)
and the bundle of Riemannian metrics. Therefore, it is worth defining a specific constructor for
this kind of bundle, that we call basic smooth bundles.

A basic smooth bundle is thus a smooth bundle over a smooth manifold whose fiber is a vector space,
and which is trivial in the coordinate charts of the base. (We recall that in our notion of manifold
there is a distinguished atlas, which does not need to be maximal: we require the triviality above
this specific atlas). It can be constructed from a basic smooth bundled core, defined below,
specifying the changes in the fiber when one goes from one coordinate chart to another one. We do
not require that this changes in fiber are linear, but only diffeomorphisms.

## Main definitions

* `basic_smooth_bundle_core I M F`: assuming that `M` is a smooth manifold over the model with
  corners `I` on `(𝕜, E, H)`, and `F` is a normed vector space over `𝕜`, this structure registers,
  for each pair of charts of `M`, a smooth change of coordinates on `F`. This is the core structure
  from which one will build a smooth bundle with fiber `F` over `M`.

Let `Z` be a basic smooth bundle core over `M` with fiber `F`. We define
`Z.to_topological_fiber_bundle_core`, the (topological) fiber bundle core associated to `Z`. From
it, we get a space `Z.to_topological_fiber_bundle_core.total_space` (which as a Type is just `Σ (x :
M), F`), with the fiber bundle topology. It inherits a manifold structure (where the charts are in
bijection with the charts of the basis). We show that this manifold is smooth.

Then we use this machinery to construct the tangent bundle of a smooth manifold.

* `tangent_bundle_core I M`: the basic smooth bundle core associated to a smooth manifold `M` over a
  model with corners `I`.
* `tangent_bundle I M`     : the total space of `tangent_bundle_core I M`. It is itself a
  smooth manifold over the model with corners `I.tangent`, the product of `I` and the trivial model
  with corners on `E`.
* `tangent_space I x`      : the tangent space to `M` at `x`
* `tangent_bundle.proj I M`: the projection from the tangent bundle to the base manifold

## Implementation notes

In the definition of a basic smooth bundle core, we do not require that the coordinate changes of
the fibers are linear map, only that they are diffeomorphisms. Therefore, the fibers of the
resulting fiber bundle do not inherit a vector space structure (as an algebraic object) in general.
As the fiber, as a type, is just `F`, one can still always register the vector space structure, but
it does not make sense to do so (i.e., it will not lead to any useful theorem) unless this structure
is canonical, i.e., the coordinate changes are linear maps.

For instance, we register the vector space structure on the fibers of the tangent bundle. However,
we do not register the normed space structure coming from that of `F` (as it is not canonical, and
we also want to keep the possibility to add a Riemannian structure on the manifold later on without
having two competing normed space instances on the tangent spaces).

We require `F` to be a normed space, and not just a topological vector space, as we want to talk
about smooth functions on `F`. The notion of derivative requires a norm to be defined.

## TODO
construct the cotangent bundle, and the bundles of differential forms. They should follow
functorially from the description of the tangent bundle as a basic smooth bundle.

## Tags
Smooth fiber bundle, vector bundle, tangent space, tangent bundle
-/

noncomputable theory

universe u

open topological_space set
open_locale manifold topological_space

/-- Core structure used to create a smooth bundle above `M` (a manifold over the model with
corner `I`) with fiber the normed vector space `F` over `𝕜`, which is trivial in the chart domains
of `M`. This structure registers the changes in the fibers when one changes coordinate charts in the
base. We do not require the change of coordinates of the fibers to be linear, only smooth.
Therefore, the fibers of the resulting bundle will not inherit a canonical vector space structure
in general. -/
structure basic_smooth_bundle_core {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(F : Type*) [normed_group F] [normed_space 𝕜 F] :=
(coord_change      : atlas H M → atlas H M → H → F → F)
(coord_change_self :
  ∀ i : atlas H M, ∀ x ∈ i.1.target, ∀ v, coord_change i i x v = v)
(coord_change_comp : ∀ i j k : atlas H M,
  ∀ x ∈ ((i.1.symm.trans j.1).trans (j.1.symm.trans k.1)).source, ∀ v,
  (coord_change j k ((i.1.symm.trans j.1) x)) (coord_change i j x v) = coord_change i k x v)
(coord_change_smooth : ∀ i j : atlas H M,
  times_cont_diff_on 𝕜 ∞ (λp : E × F, coord_change i j (I.symm p.1) p.2)
  ((I '' (i.1.symm.trans j.1).source).prod (univ : set F)))

/-- The trivial basic smooth bundle core, in which all the changes of coordinates are the
identity. -/
def trivial_basic_smooth_bundle_core {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(F : Type*) [normed_group F] [normed_space 𝕜 F] : basic_smooth_bundle_core I M F :=
{ coord_change := λ i j x v, v,
  coord_change_self := λ i x hx v, rfl,
  coord_change_comp := λ i j k x hx v, rfl,
  coord_change_smooth := λ i j, times_cont_diff_snd.times_cont_diff_on }

namespace basic_smooth_bundle_core

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] {I : model_with_corners 𝕜 E H}
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
(Z : basic_smooth_bundle_core I M F)

instance : inhabited (basic_smooth_bundle_core I M F) :=
⟨trivial_basic_smooth_bundle_core I M F⟩

/-- Fiber bundle core associated to a basic smooth bundle core -/
def to_topological_fiber_bundle_core : topological_fiber_bundle_core (atlas H M) M F :=
{ base_set := λi, i.1.source,
  is_open_base_set := λi, i.1.open_source,
  index_at := λx, ⟨chart_at H x, chart_mem_atlas H x⟩,
  mem_base_set_at := λx, mem_chart_source H x,
  coord_change := λi j x v, Z.coord_change i j (i.1 x) v,
  coord_change_self := λi x hx v, Z.coord_change_self i (i.1 x) (i.1.map_source hx) v,
  coord_change_comp := λi j k x ⟨⟨hx1, hx2⟩, hx3⟩ v, begin
    have := Z.coord_change_comp i j k (i.1 x) _ v,
    convert this using 2,
    { simp only [hx1] with mfld_simps },
    { simp only [hx1, hx2, hx3] with mfld_simps }
  end,
  coord_change_continuous := λi j, begin
    have A : continuous_on (λp : E × F, Z.coord_change i j (I.symm p.1) p.2)
      ((I '' (i.1.symm.trans j.1).source).prod (univ : set F)) :=
      (Z.coord_change_smooth i j).continuous_on,
    have B : continuous_on (λx : M, I (i.1 x)) i.1.source :=
      I.continuous.comp_continuous_on i.1.continuous_on,
    have C : continuous_on (λp : M × F, (⟨I (i.1 p.1), p.2⟩ : E × F))
             (i.1.source.prod univ),
    { apply continuous_on.prod _ continuous_snd.continuous_on,
      exact B.comp continuous_fst.continuous_on (prod_subset_preimage_fst _ _) },
    have C' : continuous_on (λp : M × F, (⟨I (i.1 p.1), p.2⟩ : E × F))
              ((i.1.source ∩ j.1.source).prod univ) :=
      continuous_on.mono C (prod_mono (inter_subset_left _ _) (subset.refl _)),
    have D : (i.1.source ∩ j.1.source).prod univ ⊆ (λ (p : M × F),
      (I (i.1 p.1), p.2)) ⁻¹' ((I '' (i.1.symm.trans j.1).source).prod univ),
    { rintros ⟨x, v⟩ hx,
      simp only with mfld_simps at hx,
      simp only [hx] with mfld_simps },
    convert continuous_on.comp A C' D,
    ext p,
    simp only with mfld_simps
  end }

@[simp, mfld_simps] lemma base_set (i : atlas H M) :
  Z.to_topological_fiber_bundle_core.base_set i = i.1.source := rfl

/-- Local chart for the total space of a basic smooth bundle -/
def chart {e : local_homeomorph M H} (he : e ∈ atlas H M) :
  local_homeomorph (Z.to_topological_fiber_bundle_core.total_space) (model_prod H F) :=
(Z.to_topological_fiber_bundle_core.local_triv ⟨e, he⟩).trans
  (local_homeomorph.prod e (local_homeomorph.refl F))

@[simp, mfld_simps] lemma chart_source (e : local_homeomorph M H) (he : e ∈ atlas H M) :
  (Z.chart he).source = Z.to_topological_fiber_bundle_core.proj ⁻¹' e.source :=
by { simp only [chart, mem_prod], mfld_set_tac }

@[simp, mfld_simps] lemma chart_target (e : local_homeomorph M H) (he : e ∈ atlas H M) :
  (Z.chart he).target = e.target.prod univ :=
by { simp only [chart], mfld_set_tac }

/-- The total space of a basic smooth bundle is endowed with a charted space structure, where the
charts are in bijection with the charts of the basis. -/
instance to_charted_space :
  charted_space (model_prod H F) Z.to_topological_fiber_bundle_core.total_space :=
{ atlas := ⋃(e : local_homeomorph M H) (he : e ∈ atlas H M), {Z.chart he},
  chart_at := λp, Z.chart (chart_mem_atlas H p.1),
  mem_chart_source := λp, by simp [mem_chart_source],
  chart_mem_atlas := λp, begin
    simp only [mem_Union, mem_singleton_iff, chart_mem_atlas],
    exact ⟨chart_at H p.1, chart_mem_atlas H p.1, rfl⟩
  end }

lemma mem_atlas_iff
  (f : local_homeomorph Z.to_topological_fiber_bundle_core.total_space (model_prod H F)) :
  f ∈ atlas (model_prod H F) Z.to_topological_fiber_bundle_core.total_space ↔
  ∃(e : local_homeomorph M H) (he : e ∈ atlas H M), f = Z.chart he :=
by simp only [atlas, mem_Union, mem_singleton_iff]

@[simp, mfld_simps] lemma mem_chart_source_iff
  (p q : Z.to_topological_fiber_bundle_core.total_space) :
  p ∈ (chart_at (model_prod H F) q).source ↔ p.1 ∈ (chart_at H q.1).source :=
by simp only [chart_at] with mfld_simps

@[simp, mfld_simps] lemma mem_chart_target_iff
  (p : H × F) (q : Z.to_topological_fiber_bundle_core.total_space) :
  p ∈ (chart_at (model_prod H F) q).target ↔ p.1 ∈ (chart_at H q.1).target :=
by simp only [chart_at] with mfld_simps

@[simp, mfld_simps] lemma coe_chart_at_fst (p q : Z.to_topological_fiber_bundle_core.total_space) :
  ((chart_at (model_prod H F) q) p).1 = chart_at H q.1 p.1 := rfl

@[simp, mfld_simps] lemma coe_chart_at_symm_fst
  (p : H × F) (q : Z.to_topological_fiber_bundle_core.total_space) :
  ((chart_at (model_prod H F) q).symm p).1 = ((chart_at H q.1).symm : H → M) p.1 := rfl

/-- Smooth manifold structure on the total space of a basic smooth bundle -/
instance to_smooth_manifold :
  smooth_manifold_with_corners (I.prod (𝓘(𝕜, F))) Z.to_topological_fiber_bundle_core.total_space :=
begin
  /- We have to check that the charts belong to the smooth groupoid, i.e., they are smooth on their
  source, and their inverses are smooth on the target. Since both objects are of the same kind, it
  suffices to prove the first statement in A below, and then glue back the pieces at the end. -/
  let J := model_with_corners.to_local_equiv (I.prod (𝓘(𝕜, F))),
  have A : ∀ (e e' : local_homeomorph M H) (he : e ∈ atlas H M) (he' : e' ∈ atlas H M),
    times_cont_diff_on 𝕜 ∞
    (J ∘ ((Z.chart he).symm.trans (Z.chart he')) ∘ J.symm)
    (J.symm ⁻¹' ((Z.chart he).symm.trans (Z.chart he')).source ∩ range J),
  { assume e e' he he',
    have : J.symm ⁻¹' ((chart Z he).symm.trans (chart Z he')).source ∩ range J =
      (I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod univ,
      by { simp only [J, chart, model_with_corners.prod], mfld_set_tac },
    rw this,
    -- check separately that the two components of the coordinate change are smooth
    apply times_cont_diff_on.prod,
    show times_cont_diff_on 𝕜 ∞ (λ (p : E × F), (I ∘ e' ∘ e.symm ∘ I.symm) p.1)
         ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod (univ : set F)),
    { -- the coordinate change on the base is just a coordinate change for `M`, smooth since
      -- `M` is smooth
      have A : times_cont_diff_on 𝕜 ∞ (I ∘ (e.symm.trans e') ∘ I.symm)
        (I.symm ⁻¹' (e.symm.trans e').source ∩ range I) :=
      (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) he he').1,
      have B : times_cont_diff_on 𝕜 ∞ (λp : E × F, p.1)
        ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod univ) :=
      times_cont_diff_fst.times_cont_diff_on,
      exact times_cont_diff_on.comp A B (prod_subset_preimage_fst _ _) },
    show times_cont_diff_on 𝕜 ∞ (λ (p : E × F),
      Z.coord_change ⟨chart_at H (e.symm (I.symm p.1)), _⟩ ⟨e', he'⟩
         ((chart_at H (e.symm (I.symm p.1)) : M → H) (e.symm (I.symm p.1)))
      (Z.coord_change ⟨e, he⟩ ⟨chart_at H (e.symm (I.symm p.1)), _⟩
        (e (e.symm (I.symm p.1))) p.2))
      ((I.symm ⁻¹' (e.symm.trans e').source ∩ range I).prod (univ : set F)),
    { /- The coordinate change in the fiber is more complicated as its definition involves the
      reference chart chosen at each point. However, it appears with its inverse, so using the
      cocycle property one can get rid of it, and then conclude using the smoothness of the
      cocycle as given in the definition of basic smooth bundles. -/
      have := Z.coord_change_smooth ⟨e, he⟩ ⟨e', he'⟩,
      rw I.image_eq at this,
      apply times_cont_diff_on.congr this,
      rintros ⟨x, v⟩ hx,
      simp only with mfld_simps at hx,
      let f := chart_at H (e.symm (I.symm x)),
      have A : I.symm x ∈ ((e.symm.trans f).trans (f.symm.trans e')).source,
        by simp only [hx.1.1, hx.1.2] with mfld_simps,
      rw e.right_inv hx.1.1,
      have := Z.coord_change_comp ⟨e, he⟩ ⟨f, chart_mem_atlas _ _⟩ ⟨e', he'⟩ (I.symm x) A v,
      simpa only [] using this } },
  constructor,
  assume e₀ e₀' he₀ he₀',
  rcases (Z.mem_atlas_iff _).1 he₀ with ⟨e, he, rfl⟩,
  rcases (Z.mem_atlas_iff _).1 he₀' with ⟨e', he', rfl⟩,
  rw [times_cont_diff_groupoid, mem_groupoid_of_pregroupoid],
  exact ⟨A e e' he he', A e' e he' he⟩
end

end basic_smooth_bundle_core

section tangent_bundle

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-- Basic smooth bundle core version of the tangent bundle of a smooth manifold `M` modelled over a
model with corners `I` on `(E, H)`. The fibers are equal to `E`, and the coordinate change in the
fiber corresponds to the derivative of the coordinate change in `M`. -/
def tangent_bundle_core : basic_smooth_bundle_core I M E :=
{ coord_change := λi j x v, (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
                            (range I) (I x) : E → E) v,
  coord_change_smooth := λi j, begin
    /- To check that the coordinate change of the bundle is smooth, one should just use the
    smoothness of the charts, and thus the smoothness of their derivatives. -/
    rw I.image_eq,
    have A : times_cont_diff_on 𝕜 ∞
      (I ∘ (i.1.symm.trans j.1) ∘ I.symm)
      (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
      (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) i.2 j.2).1,
    have B : unique_diff_on 𝕜 (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
      I.unique_diff_preimage_source,
    have C : times_cont_diff_on 𝕜 ∞
      (λ (p : E × E), (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) p.1 : E → E) p.2)
      ((I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I).prod univ) :=
      times_cont_diff_on_fderiv_within_apply A B le_top,
    have D : ∀ x ∈ (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I),
      fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (range I) x =
      fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
            (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) x,
    { assume x hx,
      have N : I.symm ⁻¹' (i.1.symm.trans j.1).source ∈ nhds x :=
        I.continuous_symm.continuous_at.preimage_mem_nhds
          (mem_nhds_sets (local_homeomorph.open_source _) hx.1),
      symmetry,
      rw inter_comm,
      exact fderiv_within_inter N (I.unique_diff _ hx.2) },
    apply times_cont_diff_on.congr C,
    rintros ⟨x, v⟩ hx,
    have E : x ∈ I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I,
      by simpa only [prod_mk_mem_set_prod_eq, and_true, mem_univ] using hx,
    have : I (I.symm x) = x, by simp [E.2],
    dsimp [-subtype.val_eq_coe],
    rw [this, D x E],
    refl
  end,
  coord_change_self := λi x hx v, begin
    /- Locally, a self-change of coordinate is just the identity, thus its derivative is the
    identity. One just needs to write this carefully, paying attention to the sets where the
    functions are defined. -/
    have A : I.symm ⁻¹' (i.1.symm.trans i.1).source ∩ range I ∈
      𝓝[range I] (I x),
    { rw inter_comm,
      apply inter_mem_nhds_within,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (mem_nhds_sets (local_homeomorph.open_source _) _),
      simp only [hx, i.1.map_target] with mfld_simps },
    have B : ∀ᶠ y in 𝓝[range I] (I x),
      (I ∘ i.1 ∘ i.1.symm ∘ I.symm) y = (id : E → E) y,
    { filter_upwards [A],
      assume y hy,
      rw ← I.image_eq at hy,
      rcases hy with ⟨z, hz⟩,
      simp only with mfld_simps at hz,
      simp only [hz.2.symm, hz.1] with mfld_simps },
    have C : fderiv_within 𝕜 (I ∘ i.1 ∘ i.1.symm ∘ I.symm) (range I) (I x) =
             fderiv_within 𝕜 (id : E → E) (range I) (I x) :=
      filter.eventually_eq.fderiv_within_eq I.unique_diff_at_image B
      (by simp only [hx] with mfld_simps),
    rw fderiv_within_id I.unique_diff_at_image at C,
    rw C,
    refl
  end,
  coord_change_comp := λi j u x hx, begin
    /- The cocycle property is just the fact that the derivative of a composition is the product of
    the derivatives. One needs however to check that all the functions one considers are smooth, and
    to pay attention to the domains where these functions are defined, making this proof a little
    bit cumbersome although there is nothing complicated here. -/
    have M : I x ∈
      (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I) :=
    ⟨by simpa only [mem_preimage, model_with_corners.left_inv] using hx, mem_range_self _⟩,
    have U : unique_diff_within_at 𝕜
      (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I) (I x) :=
      I.unique_diff_preimage_source _ M,
    have A : fderiv_within 𝕜 ((I ∘ u.1 ∘ j.1.symm ∘ I.symm) ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm))
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)
      = (fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
             (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I)
             ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x))).comp
        (fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)),
    { apply fderiv_within.comp _ _ _ _ U,
      show differentiable_within_at 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
        (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
        (I x),
      { have A : times_cont_diff_on 𝕜 ∞
          (I ∘ (i.1.symm.trans j.1) ∘ I.symm)
          (I.symm ⁻¹' (i.1.symm.trans j.1).source ∩ range I) :=
        (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) i.2 j.2).1,
        have B : differentiable_on 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
          (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I),
        { apply (A.differentiable_on le_top).mono,
          have : ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ⊆
            (i.1.symm.trans j.1).source := inter_subset_left _ _,
          exact inter_subset_inter (preimage_mono this) (subset.refl (range I)) },
        apply B,
        simpa only [] with mfld_simps using hx },
      show differentiable_within_at 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
        (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I)
        ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)),
      { have A : times_cont_diff_on 𝕜 ∞
          (I ∘ (j.1.symm.trans u.1) ∘ I.symm)
          (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I) :=
        (has_groupoid.compatible (times_cont_diff_groupoid ∞ I) j.2 u.2).1,
        apply A.differentiable_on le_top,
        rw [local_homeomorph.trans_source] at hx,
        simp only with mfld_simps,
        exact hx.2 },
      show (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
        ⊆ (I ∘ j.1 ∘ i.1.symm ∘ I.symm) ⁻¹' (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I),
      { assume y hy,
        simp only with mfld_simps at hy,
        rw [local_homeomorph.left_inv] at hy,
        { simp only [hy] with mfld_simps },
        { exact hy.1.1.2 } } },
    have B : fderiv_within 𝕜 ((I ∘ u.1 ∘ j.1.symm ∘ I.symm)
                          ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm))
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x)
             = fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x),
    { have E :
        ∀ y ∈ (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I),
          ((I ∘ u.1 ∘ j.1.symm ∘ I.symm) ∘ (I ∘ j.1 ∘ i.1.symm ∘ I.symm)) y =
            (I ∘ u.1 ∘ i.1.symm ∘ I.symm) y,
      { assume y hy,
        simp only [function.comp_app, model_with_corners.left_inv],
        rw [j.1.left_inv],
        exact hy.1.1.2 },
      exact fderiv_within_congr U E (E _ M) },
    have C : fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
             (I x) =
             fderiv_within 𝕜 (I ∘ u.1 ∘ i.1.symm ∘ I.symm)
             (range I) (I x),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (mem_nhds_sets (local_homeomorph.open_source _) _),
      simpa only [model_with_corners.left_inv] using hx },
    have D : fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm)
      (I.symm ⁻¹' (j.1.symm.trans u.1).source ∩ range I) ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)) =
      fderiv_within 𝕜 (I ∘ u.1 ∘ j.1.symm ∘ I.symm) (range I) ((I ∘ j.1 ∘ i.1.symm ∘ I.symm) (I x)),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (mem_nhds_sets (local_homeomorph.open_source _) _),
      rw [local_homeomorph.trans_source] at hx,
      simp only with mfld_simps,
      exact hx.2 },
    have E : fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm)
               (I.symm ⁻¹' ((i.1.symm.trans j.1).trans (j.1.symm.trans u.1)).source ∩ range I)
               (I x) =
             fderiv_within 𝕜 (I ∘ j.1 ∘ i.1.symm ∘ I.symm) (range I) (I x),
    { rw inter_comm,
      apply fderiv_within_inter _ I.unique_diff_at_image,
      apply I.continuous_symm.continuous_at.preimage_mem_nhds
        (mem_nhds_sets (local_homeomorph.open_source _) _),
      simpa only [model_with_corners.left_inv] using hx },
    rw [B, C, D, E] at A,
    simp only [A, continuous_linear_map.coe_comp'] with mfld_simps
  end }

variable {M}
include I

/-- The tangent space at a point of the manifold `M`. It is just `E`. We could use instead
`(tangent_bundle_core I M).to_topological_fiber_bundle_core.fiber x`, but we use `E` to help the
kernel.
-/
@[nolint unused_arguments]
def tangent_space (x : M) : Type* := E

omit I
variable (M)

/-- The tangent bundle to a smooth manifold, as a plain type. We could use
`(tangent_bundle_core I M).to_topological_fiber_bundle_core.total_space`, but instead we use the
(definitionally equal) `Σ (x : M), tangent_space I x`, to make sure that rcasing an element of the
tangent bundle gives a second component in the tangent space. -/
@[nolint has_inhabited_instance, reducible] -- is empty if the base manifold is empty
def tangent_bundle := Σ (x : M), tangent_space I x

/-- The projection from the tangent bundle of a smooth manifold to the manifold. As the tangent
bundle is represented internally as a product type, the notation `p.1` also works for the projection
of the point `p`. -/
def tangent_bundle.proj : tangent_bundle I M → M :=
λ p, p.1

variable {M}

@[simp, mfld_simps] lemma tangent_bundle.proj_apply (x : M) (v : tangent_space I x) :
  tangent_bundle.proj I M ⟨x, v⟩ = x :=
rfl

section tangent_bundle_instances

/- In general, the definition of tangent_bundle and tangent_space are not reducible, so that type
class inference does not pick wrong instances. In this section, we record the right instances for
them, noting in particular that the tangent bundle is a smooth manifold. -/
variable (M)

instance : topological_space (tangent_bundle I M) :=
(tangent_bundle_core I M).to_topological_fiber_bundle_core.to_topological_space

instance : charted_space (model_prod H E) (tangent_bundle I M) :=
(tangent_bundle_core I M).to_charted_space

instance : smooth_manifold_with_corners I.tangent (tangent_bundle I M) :=
(tangent_bundle_core I M).to_smooth_manifold

local attribute [reducible] tangent_space
variables {M} (x : M)

instance : has_continuous_smul 𝕜 (tangent_space I x) := by apply_instance
instance : topological_space (tangent_space I x) := by apply_instance
instance : add_comm_group (tangent_space I x) := by apply_instance
instance : topological_add_group (tangent_space I x) := by apply_instance
instance : module 𝕜 (tangent_space I x) := by apply_instance
instance : inhabited (tangent_space I x) := ⟨0⟩

end tangent_bundle_instances

variable (M)

/-- The tangent bundle projection on the basis is a continuous map. -/
lemma tangent_bundle_proj_continuous : continuous (tangent_bundle.proj I M) :=
topological_fiber_bundle_core.continuous_proj _

/-- The tangent bundle projection on the basis is an open map. -/
lemma tangent_bundle_proj_open : is_open_map (tangent_bundle.proj I M) :=
topological_fiber_bundle_core.is_open_map_proj _

/-- In the tangent bundle to the model space, the charts are just the canonical identification
between a product type and a sigma type, a.k.a. `equiv.sigma_equiv_prod`. -/
@[simp, mfld_simps] lemma tangent_bundle_model_space_chart_at (p : tangent_bundle I H) :
  (chart_at (model_prod H E) p).to_local_equiv = (equiv.sigma_equiv_prod H E).to_local_equiv :=
begin
  have A : ∀ x_fst, fderiv_within 𝕜 (I ∘ I.symm) (range I) (I x_fst) = continuous_linear_map.id 𝕜 E,
  { assume x_fst,
    have : fderiv_within 𝕜 (I ∘ I.symm) (range I) (I x_fst)
         = fderiv_within 𝕜 id (range I) (I x_fst),
    { refine fderiv_within_congr I.unique_diff_at_image (λy hy, _) (by simp),
      exact model_with_corners.right_inv _ hy },
    rwa fderiv_within_id I.unique_diff_at_image at this },
  ext x : 1,
  show (chart_at (model_prod H E) p : tangent_bundle I H → model_prod H E) x =
    (equiv.sigma_equiv_prod H E) x,
  { cases x,
    simp only [chart_at, basic_smooth_bundle_core.chart, tangent_bundle_core,
      basic_smooth_bundle_core.to_topological_fiber_bundle_core, A, prod.mk.inj_iff,
      continuous_linear_map.coe_id'] with mfld_simps, },
  show ∀ x, ((chart_at (model_prod H E) p).to_local_equiv).symm x =
    (equiv.sigma_equiv_prod H E).symm x,
  { rintros ⟨x_fst, x_snd⟩,
    simp only [chart_at, basic_smooth_bundle_core.chart, tangent_bundle_core,
      continuous_linear_map.coe_id', basic_smooth_bundle_core.to_topological_fiber_bundle_core, A]
      with mfld_simps},
  show ((chart_at (model_prod H E) p).to_local_equiv).source = univ,
    by simp only [chart_at] with mfld_simps,
end

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at (p : tangent_bundle I H) :
  ⇑(chart_at (model_prod H E) p) = equiv.sigma_equiv_prod H E :=
by { unfold_coes, simp only with mfld_simps }

@[simp, mfld_simps] lemma tangent_bundle_model_space_coe_chart_at_symm (p : tangent_bundle I H) :
  ((chart_at (model_prod H E) p).symm : model_prod H E → tangent_bundle I H) =
  (equiv.sigma_equiv_prod H E).symm :=
by { unfold_coes, simp only with mfld_simps }

variable (H)
/-- The canonical identification between the tangent bundle to the model space and the product,
as a homeomorphism -/
def tangent_bundle_model_space_homeomorph : tangent_bundle I H ≃ₜ model_prod H E :=
{ continuous_to_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p),
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  continuous_inv_fun :=
  begin
    let p : tangent_bundle I H := ⟨I.symm (0 : E), (0 : E)⟩,
    have : continuous (chart_at (model_prod H E) p).symm,
    { rw continuous_iff_continuous_on_univ,
      convert local_homeomorph.continuous_on _,
      simp only with mfld_simps },
    simpa only with mfld_simps using this,
  end,
  .. equiv.sigma_equiv_prod H E }

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe :
  (tangent_bundle_model_space_homeomorph H I : tangent_bundle I H → model_prod H E)
  = equiv.sigma_equiv_prod H E :=
rfl

@[simp, mfld_simps] lemma tangent_bundle_model_space_homeomorph_coe_symm :
  ((tangent_bundle_model_space_homeomorph H I).symm : model_prod H E → tangent_bundle I H)
  = (equiv.sigma_equiv_prod H E).symm :=
rfl

end tangent_bundle


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann
-/
import algebra.floor
import tactic.field_simp

/-!
# Floor Function for Rational Numbers

## Summary

We define the `floor` function and the `floor_ring` instance on `ℚ`. Some technical lemmas relating
`floor` to integer division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

namespace rat

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
protected def floor : ℚ → ℤ
| ⟨n, d, h, c⟩ := n / d

protected theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ rat.floor r ↔ (z : ℚ) ≤ r
| ⟨n, d, h, c⟩ := begin
  simp [rat.floor],
  rw [num_denom'],
  have h' := int.coe_nat_lt.2 h,
  conv { to_rhs,
    rw [coe_int_eq_mk, rat.le_def zero_lt_one h', mul_one] },
  exact int.le_div_iff_mul_le h'
end

instance : floor_ring ℚ :=
{ floor := rat.floor, le_floor := @rat.le_floor }

protected lemma floor_def {q : ℚ} : ⌊q⌋ = q.num / q.denom := by { cases q, refl }

lemma floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : ⌊(↑n : ℚ) / (↑d : ℚ)⌋ = n / (↑d : ℤ) :=
begin
  rw [rat.floor_def],
  cases decidable.em (d = 0) with d_eq_zero d_ne_zero,
  { simp [d_eq_zero] },
  { cases decidable.em (n = 0) with n_eq_zero n_ne_zero,
    { simp [n_eq_zero] },
    { set q := (n : ℚ) / d with q_eq,
      obtain ⟨c, n_eq_c_mul_num, d_eq_c_mul_denom⟩ : ∃ c, n = c * q.num ∧ (d : ℤ) = c * q.denom, by
      { rw q_eq,
        exact_mod_cast (@rat.exists_eq_mul_div_num_and_eq_mul_div_denom n d n_ne_zero
          (by exact_mod_cast d_ne_zero)) },
      suffices : q.num / q.denom = c * q.num / (c * q.denom),
        by rwa [n_eq_c_mul_num, d_eq_c_mul_denom],
      suffices : c > 0, by solve_by_elim [int.mul_div_mul_of_pos],
      have q_denom_mul_c_pos : (0 : ℤ) < q.denom * c, by
      { have : (d : ℤ) > 0, by exact_mod_cast (pos_iff_ne_zero.elim_right d_ne_zero),
        rwa [d_eq_c_mul_denom, mul_comm] at this },
      suffices : (0 : ℤ) ≤ q.denom, from pos_of_mul_pos_left q_denom_mul_c_pos this,
      exact_mod_cast (le_of_lt q.pos) } }
end

end rat

lemma int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % d = n - d * ⌊(n : ℚ) / d⌋ :=
by rw [(eq_sub_of_add_eq $ int.mod_add_div n d), rat.floor_int_div_nat_eq_div]

lemma nat.coprime_sub_mul_floor_rat_div_of_coprime {n d : ℕ} (n_coprime_d : n.coprime d) :
  ((n : ℤ) - d * ⌊(n : ℚ)/ d⌋).nat_abs.coprime d :=
begin
  have : (n : ℤ) % d = n - d * ⌊(n : ℚ)/ d⌋, from int.mod_nat_eq_sub_mul_floor_rat_div,
  rw ←this,
  have : d.coprime n, from n_coprime_d.symm,
  rwa [nat.coprime, nat.gcd_rec] at this
end

namespace rat

lemma num_lt_succ_floor_mul_denom (q : ℚ) : q.num < (⌊q⌋ + 1) * q.denom :=
begin
  suffices : (q.num : ℚ) < (⌊q⌋ + 1) * q.denom, by exact_mod_cast this,
  suffices : (q.num : ℚ) < (q - fract q + 1) * q.denom, by
  { have : (⌊q⌋ : ℚ) = q - fract q, from (eq_sub_of_add_eq $ floor_add_fract q),
    rwa this },
  suffices : (q.num : ℚ) < q.num + (1 - fract q) * q.denom, by
  { have : (q - fract q + 1) * q.denom = q.num + (1 - fract q) * q.denom, calc
      (q - fract q + 1) * q.denom = (q + (1 - fract q)) * q.denom            : by ring
                              ... = q * q.denom + (1 - fract q) * q.denom    : by rw add_mul
                              ... = q.num + (1 - fract q) * q.denom : by simp,
    rwa this },
  suffices : 0 < (1 - fract q) * q.denom, by { rw ←sub_lt_iff_lt_add', simpa },
  have : 0 < 1 - fract q, by
  { have : fract q < 1, from fract_lt_one q,
    have : 0 + fract q < 1, by simp [this],
    rwa lt_sub_iff_add_lt },
  exact mul_pos this (by exact_mod_cast q.pos)
end

lemma fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q): (fract q⁻¹).num < q.num :=
begin
  -- we know that the numerator must be positive
  have q_num_pos : 0 < q.num, from rat.num_pos_iff_pos.elim_right q_pos,
  -- we will work with the absolute value of the numerator, which is equal to the numerator
  have q_num_abs_eq_q_num : (q.num.nat_abs : ℤ) = q.num, from
    (int.nat_abs_of_nonneg $ le_of_lt q_num_pos),
  set q_inv := (q.denom : ℚ) / q.num with q_inv_def,
  have q_inv_eq : q⁻¹ = q_inv, from rat.inv_def',
  suffices : (q_inv - ⌊q_inv⌋).num < q.num, by rwa q_inv_eq,
  suffices : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num < q.num, by
    field_simp [this, (ne_of_gt q_num_pos)],
  suffices : (q.denom : ℤ) - q.num * ⌊q_inv⌋ < q.num, by
  { -- use that `q.num` and `q.denom` are coprime to show that the numerator stays unreduced
    have : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num = q.denom - q.num * ⌊q_inv⌋, by
    { suffices : ((q.denom : ℤ) - q.num * ⌊q_inv⌋).nat_abs.coprime q.num.nat_abs, by
        exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos this),
      have : (q.num.nat_abs : ℚ) = (q.num : ℚ), by exact_mod_cast q_num_abs_eq_q_num,
      have tmp := nat.coprime_sub_mul_floor_rat_div_of_coprime q.cop.symm,
      simpa only [this, q_num_abs_eq_q_num] using tmp },
    rwa this },
  -- to show the claim, start with the following inequality
  have q_inv_num_denom_ineq : q⁻¹.num - ⌊q⁻¹⌋ * q⁻¹.denom < q⁻¹.denom, by
  { have : q⁻¹.num < (⌊q⁻¹⌋ + 1) * q⁻¹.denom, from rat.num_lt_succ_floor_mul_denom q⁻¹,
    have : q⁻¹.num < ⌊q⁻¹⌋ * q⁻¹.denom + q⁻¹.denom, by rwa [right_distrib, one_mul] at this,
    rwa [←sub_lt_iff_lt_add'] at this },
  -- use that `q.num` and `q.denom` are coprime to show that q_inv is the unreduced reciprocal
  -- of `q`
  have : q_inv.num = q.denom ∧ q_inv.denom = q.num.nat_abs, by
  { have coprime_q_denom_q_num : q.denom.coprime q.num.nat_abs, from q.cop.symm,
    have : int.nat_abs q.denom = q.denom, by simp,
    rw ←this at coprime_q_denom_q_num,
    rw q_inv_def,
    split,
    { exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) },
    { suffices : (((q.denom : ℚ) / q.num).denom : ℤ) = q.num.nat_abs, by exact_mod_cast this,
      rw q_num_abs_eq_q_num,
      exact_mod_cast (rat.denom_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) } },
  rwa [q_inv_eq, this.left, this.right, q_num_abs_eq_q_num, mul_comm] at q_inv_num_denom_ineq
end

end rat


import group_theory.subgroup
import group_theory.quotient_group
import group_theory.category
open category_theory

local attribute [instance] classical.prop_decidable

lemma fintype.card_of_removed {α} [fintype α] (a : α)
  : fintype.card { x : α // x ≠ a } = nat.pred (fintype.card α) :=
begin
  transitivity finset.card (finset.erase finset.univ a),
  apply fintype.card_of_subtype, intros,
  rw [finset.mem_erase, eq_true_intro (finset.mem_univ x), and_true],
  apply finset.card_erase_of_mem, apply finset.mem_univ
end

noncomputable
def quotient.out_avoid {α} (s : setoid α) (a b : α)
  (hdist : a ≠ b) : quotient s → { x : α // x ≠ b } :=
  λ x, if h : quotient.out x = b
       then ⟨a, hdist⟩
       else ⟨quotient.out x, h⟩

lemma quotient.out_avoid_inj {α : Type*} (s : setoid α) (a b : α)
  (hdist : a ≠ b) (hrel : setoid.r a b)
  : function.injective (quotient.out_avoid s a b hdist) :=
  λ x y hxy,
  if hx : quotient.out x = b
  then if hy : quotient.out y = b
       then calc x   = quotient.mk b : by { rw ← hx, rw quotient.out_eq }
                 ... = y : by { symmetry, rw ← hy, rw quotient.out_eq }
       else by { simp [quotient.out_avoid] at hxy,
                 rw [dif_pos hx, dif_neg hy] at hxy,
                 transitivity quotient.mk b,
                 rw ← hx, rw quotient.out_eq,
                 transitivity quotient.mk a,
                 exact quot.eqv_gen_sound (eqv_gen.symm _ _ (eqv_gen.rel _ _ hrel)),
                 rw subtype.ext at hxy, simp at hxy,
                 rw hxy, rw quotient.out_eq }
  else if hy : quotient.out y = b
       then by { simp [quotient.out_avoid] at hxy,
                 rw [dif_neg hx, dif_pos hy] at hxy,
                 transitivity quotient.mk a,
                 rw subtype.ext at hxy, simp at hxy,
                 rw ← hxy, rw quotient.out_eq,
                 transitivity quotient.mk b,
                 exact quot.eqv_gen_sound (eqv_gen.rel _ _ hrel),
                 rw ← hy, rw quotient.out_eq }
        else by { simp [quotient.out_avoid] at hxy,
                  rw [dif_neg hx, dif_neg hy] at hxy,
                  rw subtype.ext at hxy, simp at hxy,
                  rw [← quotient.out_eq x, ← quotient.out_eq y, hxy] }

lemma quotient.card_lt {α : Type*} [fintype α] (s : setoid α)
  (a b : α) (hdist : a ≠ b) (hrel : setoid.r a b)
  : fintype.card (quotient s) < fintype.card α :=
  by { apply @nat.lt_of_le_of_lt _ (fintype.card { x : α // x ≠ b }) _,
       apply fintype.card_le_of_injective (quotient.out_avoid s a b hdist),
       apply quotient.out_avoid_inj, assumption,
       rw fintype.card_of_removed, apply nat.pred_lt,
       intro h, rw fintype.card_eq_zero_iff at h, exact h a }

lemma finite_group.induction_ord (P : Π (G : Group), fintype G → Sort _)
  : (∀ (G : Group) (h : fintype G),
      (∀ (H : Group) (h' : fintype H),
       @fintype.card H h' < @fintype.card G h → P H h')
    → P G h)
  → ∀ (G : Group) (h : fintype G), P G h :=
begin
  intro inductive_step,
  suffices : ∀ n (G : Group) (h : fintype G), @fintype.card G h = n → P G h,
  { intros, apply this (@fintype.card G h), refl },
  intro n, apply @nat.strong_rec_on (λ n, ∀ (G : Group) (h : fintype G), @fintype.card G h = n → P G h) n,
  clear n, intros n ih G h card_eq,
  apply inductive_step,
  intros H h' hlt,
  apply ih (@fintype.card H h') (card_eq ▸ hlt),
  refl
end

noncomputable
lemma finite_group.induction_subquot (P : Π (G : Group), fintype G → Sort _)
  : (∀ (G : Group) (h : fintype G),
      (∀ (H : set G) [inst : is_subgroup H], H ≠ set.univ →
       P (@Group.of H (@subtype.group _ _ _ inst))
                      (@subtype.fintype _ h _ _))
      → (∀ (N : set G) [inst : normal_subgroup N], N ≠ is_subgroup.trivial G →
          P (@Group.of (@quotient_group.quotient _ _ N inst.to_is_subgroup)
                       (@quotient_group.group _ _ N inst))
            (@quotient.fintype _ h _ _))
      → P G h)
  → ∀ (G : Group) (h : fintype G), P G h :=
begin
  intro inductive_step,
  apply finite_group.induction_ord,
  intros G h ih,
  apply inductive_step,
  { intros H inst h', apply ih,
    apply @nat.lt_of_le_of_lt _ (@fintype.card (subtype H) (@subtype.fintype _ h _ _)),
    refl,
    rw fintype.card_of_subtype (@set.to_finset _ H (@subtype.fintype _ h _ _)),
    dsimp [fintype.card], apply finset.card_lt_card,
    refine (_ : @set.to_finset _ H (@subtype.fintype _ h _ _) < @finset.univ _ h),
    apply lt_of_le_of_ne,
    apply finset.subset_univ,
    intro h'', apply h', ext,
    transitivity true, rw iff_true,
    have : x ∈ @set.to_finset _ H (@subtype.fintype _ h _ _), rw h'', apply finset.mem_univ,
    rw set.mem_to_finset at this, assumption,
    rw true_iff, apply set.mem_univ,
    intro, rw set.mem_to_finset, refl },
  { intros N inst hproper,
    apply ih,
    apply @nat.lt_of_le_of_lt _ (@fintype.card (@quotient_group.quotient _ _ N inst.to_is_subgroup) (@quotient.fintype _ h _ _)),
    refl, dsimp [quotient_group.quotient],
    have : ∃ x : G, x ∈ N ∧ x ≠ 1,
    { by_contra h, apply hproper,
      rw @is_subgroup.eq_trivial_iff _ _ _ inst.to_is_subgroup,
      intros, by_contra, apply h,
      existsi x, constructor; assumption },
    cases this with x hx, cases hx with hN hdist,
    apply quotient.card_lt _, exact hdist.symm,
    refine (_ : 1⁻¹ * x ∈ N),
    rw [one_inv, one_mul], assumption }
end


import data.set.basic data.nat.parity

open set nat

def evens : set ℕ := {n | even n}
def odds :  set ℕ := {n | ¬ even n}

example : evens ∪ odds = univ :=
begin
  rw [evens, odds],
  ext n,
  simp,
  apply classical.em,
end


import data.nat.prime
import tactic.norm_num
import data.list.basic
import analysis.real
open nat

definition is_prime : nat → Prop
| zero := false
| (succ zero) := false
| (succ(succ x)) := ¬∃b c:nat,2≤b ∧ 2≤c ∧ b*c=succ(succ x)
definition product : list nat → nat
| list.nil := 1
| (n::L) :=  n * product L

theorem product_append: ∀L M:list nat,product L*product M=product (L ++ M):=begin
    assume L,
    induction L with h L1 HiL,
        unfold product append list.append,
        assume M, rw one_mul,

        assume M1,
        have H2:=HiL (h::M1),
        clear HiL,revert H2,
        unfold product append list.append,
        rw[←mul_assoc, mul_comm (product L1) h],
        assume H,rw H,clear H,
        induction L1 with h1 L2 HiL1,
            unfold list.append product,

            unfold list.append product,
            rw [HiL1,←mul_assoc,←mul_assoc, mul_comm h h1],
end

theorem prime_eq :∀ p, is_prime p ↔ prime p := begin

    intro, cases p with p,
    unfold is_prime prime,norm_num,
    cases p with p,
    unfold is_prime prime,norm_num,exact dec_trivial,
    unfold prime is_prime,
    apply iff.intro,
    assume H,apply and.intro,
    exact dec_trivial,
    assume p1 H3,
    have H4:=exists_eq_mul_right_of_dvd H3,
    cases H4 with c Hc,
    cases c with c,
    exfalso,revert Hc,exact dec_trivial,
    cases c with c,
    revert Hc,norm_num,rw eq_comm,cc,
    cases classical.em(p1=1),left,assumption,
    have H5:∃ (b c : ℕ), 2 ≤ b ∧ 2 ≤ c ∧ b * c = succ (succ p):=begin
        existsi (succ(succ c)),existsi p1,
        have H6:2 ≤ succ (succ c)↔true:=dec_trivial,
        rw H6,simp,rw Hc,simp,
        cases p1 with p1,
        revert Hc,norm_num,exact succ_ne_zero (succ p),
        cases p1 with p1,
        revert a,norm_num,exact dec_trivial,
    end,exfalso,exact H H5,
    assume Hp Hexists,
    cases Hexists with b Hb,
    cases Hb with c Hbc,
    cases Hbc with Hb Hc1,
    cases Hc1 with Hc Hbc,
    cases Hp with H1 Hp,
    have H5:= (Hp c) (dvd_of_mul_left_eq b Hbc),
    have H6:c=1↔false:=begin
        apply iff.intro,
        assume Ht,revert Hc,rw Ht,norm_num,
    end,revert H5,rw H6,simp,
    assume Hc,rw Hc at Hbc,
    cases b with b,revert Hb,exact dec_trivial,
    cases b with b,revert Hb,exact dec_trivial,
    revert Hbc,simp,rw mul_succ,norm_num,rw[mul_comm,mul_succ],assume Hbc,
    have H7:succ (succ p) + (succ (succ p) * b + succ (succ p)) = succ (succ p)+0:=begin rw Hbc, end,
    have H8:(succ (succ p) * b + succ (succ p))=0:=add_left_cancel H7,
    revert H8,rw[add_comm,succ_add],apply succ_ne_zero,
end

theorem prime_product: ∀x:ℕ,1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧product L=x:=begin
    have Hstrong:∀ x y:ℕ,x≤y→1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧product L=x:=begin
        assume x y, revert x,
        induction y with y Hiy,
            assume x Hxy Hx1,
            have Hx:=eq_zero_of_le_zero Hxy,revert Hx1,rw Hx,norm_num,
            assume x Hxy H1x,
            cases x with x,revert H1x,norm_num,
            cases x with x,
            existsi list.nil,
            unfold list.mem product,simp,
            cases classical.em(prime (succ(succ x))) with Hx Hx1,
                existsi ([succ(succ x)]),
                unfold list.mem product,simp,assumption,

                rw ←prime_eq at Hx1,unfold is_prime at Hx1,
                have A:∃ (b c : ℕ), 2 ≤ b ∧ 2 ≤ c ∧ b * c = succ (succ x):=by{revert Hx1,cc},clear Hx1,
                cases A with b Hb,
                cases Hb with c Hbc1,
                cases Hbc1 with Hb Hc,
                cases Hc with Hc Hbc,
                have Hbx:b<succ(succ x),{rw[←Hbc,mul_comm,lt_mul_iff_one_lt_left],exact lt_of_succ_le Hc,cases b,revert Hb,norm_num,exact dec_trivial},
                have Hcx:c<succ(succ x),{rw[←Hbc,lt_mul_iff_one_lt_left],exact lt_of_succ_le Hb,cases c,revert Hc,norm_num,exact dec_trivial},
                have Hxy1:succ x≤y:=by rwa ←succ_le_succ_iff,clear Hxy,
                have Hbx1:b≤succ x:=begin rw ←succ_le_succ_iff,apply succ_le_of_lt,assumption end,
                have Hcx1:c≤succ x:=begin rw ←succ_le_succ_iff,apply succ_le_of_lt,assumption end,
                have Hby:=le_trans Hbx1 Hxy1,
                have Hcy:=le_trans Hcx1 Hxy1,
                have H12:1≤2:=dec_trivial,
                have H1b:=le_trans H12 Hb,
                have H1c:=le_trans H12 Hc,
                clear H12 Hcx1 Hbx1 Hxy1 Hcx Hbx Hb Hc H1x,
                cases (Hiy b Hby H1b) with Lb HLb,
                cases (Hiy c Hcy H1c) with Lc HLc,clear Hiy H1b H1c Hby Hcy,
                cases HLb with HLb1 HLb2,
                cases HLc with HLc1 HLc2,
                existsi(Lb ++ Lc),
                apply and.intro,rw[←Hbc,←HLb2,←HLc2,eq_comm],
                exact product_append Lb Lc,
                norm_num,
                assume p H,
                cases H with A A,
                exact HLb1 p A,
                exact HLc1 p A,
    end,
    assume x,
    exact Hstrong x x (le_refl x),
end

def euclid_r: nat→nat→nat→nat
| b c 0     := c
| b c 1     := b%c
| b c (n+2) := euclid_r b c n % euclid_r b c (succ n)
def euclid_q: nat→nat→nat→nat
| b c 0     := 0
| b c 1     := b/c
| b c (n+2) := euclid_r b c n / euclid_r b c (succ n)
def euclid_x: nat→nat→nat→int
| b c 0     := 0
| b c 1     := 1
| b c (n+2) := euclid_x b c n - euclid_q b c (succ (succ n)) * euclid_x b c (succ n)
def euclid_y: nat→nat→nat→int
| b c 0     := 1
| b c 1     := -euclid_q b c 1
| b c (n+2) := euclid_y b c n - euclid_q b c (succ (succ n)) * euclid_y b c (succ n)
theorem sub_succ2: ∀ n k1 :nat,succ k1≤ n→ succ (n - succ k1)=n-k1:=begin
    intros,
    rw[← add_one,←add_one],
    suffices:n - (k1 + 1) + 1 +k1= n - k1+k1,
        revert this,simp,
    rw [add_comm k1 1, add_assoc,one_add],
    have H:=le_trans (le_succ k1) a,
    rw nat.sub_add_cancel a,
    rw nat.sub_add_cancel H,
end
theorem decreasing_r: ∀ (b c n:ℕ),euclid_r b c (n+1)<euclid_r b c n ∨ ∃m,m≤n+1∧euclid_r b c m = 0 :=begin
    assume b c n,
    induction n with n1 Hin,
        unfold euclid_r,
        cases classical.em(c=0) with A A,
        right,existsi 0,unfold euclid_r,
        rw A,simp,exact dec_trivial,left,
        cases c with c,exfalso,revert A,simp,
        exact mod_lt b (succ_pos c),

        unfold euclid_r,rw ←add_one,
        cases classical.em (∃ (m : ℕ), m ≤ n1 + 1 ∧ euclid_r b c m = 0) with A A,
        right,cases A with m Hm,existsi m,
        exact  and.intro (le_trans (and.left Hm) (le_add_right (n1+1) 1)) (and.right Hm),
        cases classical.em(euclid_r b c (n1 + 1)=0) with A A,
        right, existsi n1+1,apply and.intro,norm_num,
        assumption,left,
        cases (euclid_r b c (n1 + 1)) with r,
        exfalso, revert A_1,simp,
        exact mod_lt (euclid_r b c n1) (succ_pos r)
end

theorem gcd_exists: ∀ b c :nat, ∃ n:nat, euclid_r b c (succ n) = 0:=begin
    assume b c ,
    have H:∀ n:nat,n≤c→(∀ m:nat,m≤n→¬euclid_r b c m = 0)→euclid_r b c n≤c-n:=begin
        assume n Hnc Hn,
        induction n with n1 Hin,
        unfold euclid_r,norm_num,
        have Hn1:∀ (m : ℕ), m ≤ n1 → ¬euclid_r b c m = 0:=begin
            assume m Hm,
            have H:=le_trans Hm (le_succ n1),
            exact Hn m H,
        end,
        have Hin1:=Hin (le_trans (le_succ n1) Hnc) Hn1,clear Hin,
        have H1:=decreasing_r b c n1,
        have H3:∀ (m : ℕ),¬( m ≤succ n1 ∧ euclid_r b c m = 0):=begin
            assume m,rw not_and,exact Hn m,
        end,
        have H2:¬∃ (m : ℕ), m ≤ succ n1 ∧ euclid_r b c m = 0:=not_exists_of_forall_not H3,
        have H4:(∃ (m : ℕ), m ≤ succ n1 ∧ euclid_r b c m = 0)↔false:=begin
            apply iff.intro,exact H2,trivial,
        end,rw H4 at H1,simp at H1,clear H4 H2 H3,
        have H2:= lt_of_lt_of_le H1 Hin1,
        have H3:= succ_le_of_lt H2,
        apply le_of_succ_le_succ,
        rwa sub_succ2 c n1 Hnc,
    end,
    cases classical.em (∃m:nat,m≤ c ∧ euclid_r b c m = 0) with A A,
    apply exists.elim A,assume m Hm,
    cases m with m,unfold euclid_r at Hm,
    existsi 1,unfold  euclid_r,rw and.right Hm,simp,
    existsi m,exact and.right Hm,
    have H1:∀ (m : ℕ),¬( m ≤ c ∧ euclid_r b c m = 0):=forall_not_of_not_exists A,
    clear A,
    have H2: ∀ (m : ℕ), m ≤ c →¬ euclid_r b c m = 0:=begin
        assume m,rw ←not_and,exact H1 m,
    end,
    clear H1,have H3:=H c (le_refl c) (H2),exfalso,revert H3,
    rw nat.sub_self c,
    assume H1,have H3:=eq_zero_of_le_zero H1,revert H3,
    exact H2 c (le_refl c),
end

theorem quotients :∀(b c n:nat), euclid_r b c n - euclid_q b c (succ(succ n)) * euclid_r b c (succ n) = euclid_r b c (succ (succ n)):=begin
    assume b c n,
    unfold euclid_q euclid_r,
    have H1:(euclid_r b c n - euclid_r b c n / euclid_r b c (succ n) * euclid_r b c (succ n))+euclid_r b c n / euclid_r b c (succ n) * euclid_r b c (succ n)= euclid_r b c n % euclid_r b c (succ n)+euclid_r b c n / euclid_r b c (succ n) * euclid_r b c (succ n):=begin
        rw [nat.sub_add_cancel,mul_comm,mod_add_div],
        exact div_mul_le_self (euclid_r b c n) (euclid_r b c (succ n)),
    end,
    apply add_right_cancel H1,
end

theorem almost_bezout: ∀ (c b n:nat), euclid_x c b n * c + euclid_y c b n * b = euclid_r c b n:=begin
    -- semi strong induction, need previous two cases
    have Hi:∀(c b n:nat),euclid_x c b n * c + euclid_y c b n * b = euclid_r c b n ∧ euclid_x c b (succ n) * c + euclid_y c b (succ n) * b = euclid_r c b (succ n):=begin
        assume  c b n,
        induction n with n1 Hin2,
        apply and.intro,
        unfold euclid_x euclid_y euclid_r,simp,
        unfold euclid_x euclid_y euclid_r euclid_q,simp,
        have H1:↑c + -(↑b * ↑(c / b)) + (↑b * ↑(c / b)) = ↑(c % b) +(↑b * ↑(c / b)):=begin
            rw [←int.coe_nat_mul,←int.coe_nat_add,mod_add_div],rw [add_assoc,add_comm (-↑(b * (c / b))) (↑(b * (c / b))),← add_assoc],rw add_neg_cancel_right,
        end,
        revert H1,norm_num,assume H1,rw H1,simp,

        have Hin:=and.left Hin2,
        have Hin1:=and.right Hin2,clear Hin2,
        apply and.intro,assumption,

        unfold euclid_x euclid_y,

        rw ←quotients c b n1,
        have H1:(euclid_x c b n1 - euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1)) * c=euclid_x c b n1 *c - euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1)*c:=begin norm_num,rw mul_add,norm_num,end,
        have H2:(euclid_y c b n1 - euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1)) * b=euclid_y c b n1 *b - euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1)*b:=begin norm_num,rw mul_add,norm_num,end,
        rw [H1,H2],clear H1 H2,
        have H1:=calc euclid_x c b n1 * c - euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1) * c +
      (euclid_y c b n1 * b - euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1) * b)=euclid_x c b n1 * c - euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1) * c +
      euclid_y c b n1 * b - euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1) * b:by norm_num
      ...=euclid_x c b n1 * c + euclid_y c b n1 * b - euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1) * b-euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1)*c:by norm_num
      ...=euclid_r c b n1 -euclid_q c b (succ (succ n1)) * euclid_y c b (succ n1) * b-euclid_q c b (succ (succ n1)) * euclid_x c b (succ n1)*c:by rw ←Hin
      ...=euclid_r c b n1 + (-euclid_q c b (succ (succ n1)) * (euclid_y c b (succ n1) * b) + -euclid_q c b (succ (succ n1)) * (euclid_x c b (succ n1)*c)):by norm_num,
      rw H1,
      have H2:=mul_add (-↑(euclid_q c b (succ (succ n1)))) (euclid_y c b (succ n1) * ↑b) (euclid_x c b (succ n1)*↑c),rw  ←H2,rw add_comm at Hin1,
      rw Hin1,rw [int.coe_nat_sub,int.coe_nat_mul],simp,
      unfold euclid_q,apply div_mul_le_self,
    end,
    assume c b n,
    exact and.left (Hi c b n),
end
theorem cd_dvd_r:∀ (b c x:nat), x ∣ b → x∣c→∀ n:nat, x∣euclid_r b c n:=begin
    assume b c x Hb Hc n,
    have Hi:x ∣ euclid_r b c n∧x ∣ euclid_r b c (succ n):=begin
        induction n with n1 Hin,
        unfold euclid_r,
        exact and.intro Hc (iff.elim_right (dvd_mod_iff Hc) Hb),

        unfold euclid_r,
        exact and.intro (and.right Hin) (iff.elim_right (dvd_mod_iff  (and.right Hin)) (and.left Hin)),
    end,
    exact and.left Hi,
end
def is_gcd: nat→nat→nat→Prop
| b c n := n∣b ∧ n ∣ c ∧ (∀ e:nat,e∣b→ e∣c → e∣n)

theorem gcd_euclid: ∀ b c n:nat, euclid_r b c (n+1)=0→is_gcd b c (euclid_r b c n):=begin
    have quotients_mod: ∀ (b c n:nat),(euclid_r b c n)= (euclid_q b c (succ (succ n)))* (euclid_r b c(succ n)) +(euclid_r b c (succ (succ n))):=begin
        assume b c n,
        unfold euclid_q euclid_r,rw [mul_comm,add_comm,mod_add_div],
    end,
    have Hi:∀ (b c n:nat), euclid_r b c (succ(succ n))=0→(∀ k:nat,k≤n→euclid_r b c (succ n) ∣ euclid_r b c (n-k)∧euclid_r b c (succ n) ∣ euclid_r b c (succ(n-k))):=begin
        assume b c n H,
        unfold euclid_r at H,
        have H2:=dvd_of_mod_eq_zero H,
        assume k Hkn,
        induction k with k1 Hik,
        simp,assumption,
        have Hik3:=Hik ( le_trans (le_succ k1) Hkn),clear Hik,
        have Hik1:= and.left Hik3,
        have Hik2:=and.right Hik3,clear Hik3,
        have Hsucc:(succ (n - succ k1))=n-k1:=sub_succ2 n k1 Hkn,
        apply and.intro,
        have Hup:↑(euclid_r b c (succ n)) ∣ ↑(euclid_r b c (n - succ k1)):=begin
            rw quotients_mod b c (n- succ k1),rw Hsucc,
            rw ←int.coe_nat_dvd at Hik2,
            rw← int.coe_nat_dvd at Hik1,
            exact dvd_add (dvd_mul_of_dvd_right Hik1 (euclid_q b c (succ (n - k1)))) Hik2,
        end,
        rwa ←int.coe_nat_dvd,
        rwa Hsucc,
    end,
    assume b c n Hn,
    have H1:euclid_r b c n ∣ c:=begin
        cases n with n1,
        unfold euclid_r,exact dvd_refl c,rw add_one at Hn,
        have Hi1:= Hi b c n1 Hn n1 (le_refl n1),
        have H1:=nat.sub_self n1,
        rw H1 at Hi1,
        unfold euclid_r at Hi1,
        exact and.left Hi1,
    end,
    have H2:euclid_r b c n ∣ (b%c):=begin
        cases n with n1,
        unfold euclid_r,unfold euclid_r at Hn,rw Hn,
        exact dvd_zero c,
        cases n1 with n2,
        unfold euclid_r,exact dvd_refl (b%c),
        have Hi1:= Hi b c (succ n2) Hn n2,
        have H1:succ n2-n2=1:=begin rw ←zero_add 1,have H2:=nat.sub_self n2,rw[←H2,add_one],exact succ_sub (le_refl n2), end,
        rw H1 at Hi1,
        have H3: euclid_r b c 1 =b%c:=by unfold euclid_r,
        rw ←H3,exact and.left (Hi1 (le_succ n2)),
    end,
    unfold is_gcd,rw ←dvd_mod_iff H1,
    exact and.intro H2 (and.intro H1 (λ e Heb Hec,cd_dvd_r b c e Heb Hec n)),
end
theorem bezout: ∀ b c:nat,  ∃ (x y:ℤ) (d:nat), x *↑b + y*↑c = ↑d∧is_gcd b c d:=
    λ b c,exists.elim (gcd_exists b c) (λ n Hn,exists.intro (euclid_x b c n)
    (exists.intro (euclid_y b c n) (exists.intro (euclid_r b c n)
    ⟨almost_bezout b c n,gcd_euclid b c n Hn⟩)))

theorem gcdprime:∀ p x:nat, prime p → ∀ d, is_gcd x p d → d=1 ∨ d=p:=begin
    unfold prime is_gcd,
    assume p x Hp d Hd, exact (and.right Hp) d (and.left(and.right Hd)),
end

theorem euclids_lemma: ∀b c p:nat, prime p → p ∣ (b*c) → p ∣ b ∨ p ∣ c:=begin
    assume b c p Hp Hpbc,
    have Hgcdb:=gcdprime p b Hp,
    have H1:= bezout b p,
    cases H1 with x H,
    cases H with y H1,
    cases H1 with d Hxyd,
    cases Hxyd with Hbz Hd,
    cases (Hgcdb d Hd) with A A,
    rw A at Hbz,
    have Hbz2:↑ c*(x * ↑b) + ↑ c*(y * ↑p) = ↑ c*↑1:=by rw[←mul_add,Hbz],
    rw [mul_comm x ↑b,←mul_assoc,←mul_assoc,mul_comm ↑c ↑b] at Hbz2,right,
    rw [←int.coe_nat_dvd,int.coe_nat_mul ]at Hpbc,
    have H2:=dvd_add (dvd_mul_of_dvd_left Hpbc x)(dvd_mul_of_dvd_right (dvd_refl ↑p) (↑c*y)),
    rw Hbz2 at H2,simp at H2,
    rwa ←int.coe_nat_dvd,

    unfold is_gcd at Hd,rw A at Hd,left,
    exact and.left Hd,
end

theorem product_dvd: ∀ (p:nat) (L:list nat),p∈L→ p ∣ product L:=begin
    assume p L,revert p,
    induction L with p1 L1 HiL,
        norm_num,
        unfold product,norm_num,
        assume p2 Hp,
        have H:= HiL p2 Hp,
        exact dvd_mul_of_dvd_right H p1,
end
theorem listcount1:∀ B:list nat,∀ x y1 y2:nat, list.count x (y1::y2::B) = list.count x (y2::y1::B):=begin
    assume B x y1 y2,
    cases classical.em (x=y1) with H H,
    cases classical.em (x=y2) with H1 H1,
    rw [←H,← H1],rw ← H,
    rw list.count_cons_self,
    rw list.count_cons_of_ne H1,
    rw list.count_cons_of_ne H1,
    rw list.count_cons_self,
    cases classical.em(x=y2) with H1 H1,
    rw← H1,
    rw list.count_cons_of_ne H,
    rw list.count_cons_self,
    rw list.count_cons_self,
    rw list.count_cons_of_ne H,
    rw list.count_cons_of_ne H,
    rw list.count_cons_of_ne H1,
    rw list.count_cons_of_ne H1,
    rw list.count_cons_of_ne H,
end
theorem anti_cons_list:∀ (B1:list nat) (p:nat),p∈ B1→ (∀x:nat,x∈B1→prime x)→ ∃ B2:list nat,(product B1=product (p::B2)∧(∀x:nat,x∈ B2→ prime x)∧(∀ x:nat,list.count x B1 = list.count x (p::B2))):=begin
    assume B1,
    induction B1 with p1 B3 Hi,
    simp,
    assume p2 Hp,
    have H:p2 = p1 ∨ p2 ∈ B3:=by{revert Hp,norm_num},
    cases H with A A,
    assume H2,
    existsi B3,rw A,
    apply and.intro,trivial,
    revert H2,norm_num,

    assume H6 H7,
    have H1:=Hi p2 A H7,
    cases H1 with C HC,
    existsi p1::C,
    unfold product,unfold product at HC,
    rw and.left HC,
    apply and.intro,
    simp,

    apply and.intro,exact H6,
    exact and.left (and.right HC),
    apply and.intro,simp,
    norm_num,
    assume x,
    rw listcount1 C x p2 p1,
    cases classical.em (x=p1) with A A,
    rw A,
    rw list.count_cons_self,
    rw list.count_cons_self,
    rw and.right (and.right HC) p1,
    rw list.count_cons_of_ne A,
    rw list.count_cons_of_ne A,
    rw and.right (and.right HC) x,
end

theorem prime_product_dvd:∀ (B:list nat)(p:nat),prime p→(∀pB, pB ∈ B → prime pB)→p ∣ product B → p ∈ B:=begin
    assume B,
    induction B with p1 B1 Hi,
    unfold product,assume p Hp H H2,exfalso,revert H2,
    exact prime.not_dvd_one Hp,
    assume p2 Hp2 H H1,
    norm_num,
    unfold product at H1,
    have H2:=euclids_lemma p1 (product B1) p2 Hp2 H1,
    cases H2 with A A,
    left,
    have H3:=H p1,
    revert H3,norm_num,assume H4,
    unfold prime at H4,
    have H5:=and.right H4 p2 A,
    have H6:p2=1↔ false:=begin apply iff.intro,unfold prime at Hp2,intro,rw a at Hp2,simp at Hp2,revert Hp2,norm_num, end,
    rw H6 at H5, simp at H5,assumption,
    right,
    have H3:(∀ (pB : ℕ), pB ∈ B1 → prime pB):=begin revert H, norm_num,end,have H2:= Hi p2 Hp2 H3 A,assumption,
end
theorem eq_one_of_mul_eq_one:∀ x y :nat, x*y=1→x=1∧ y=1:=begin
    assume x y,
    cases x with x,
    norm_num,
    cases y with y,norm_num,
    rw [mul_succ,mul_comm,mul_succ,add_comm,succ_add],
    assume Hxy,
    have H:=succ_inj Hxy,
    have H2:=eq_zero_of_add_eq_zero H,apply and.intro,
    rw and.left H2,
    have H3:=eq_zero_of_add_eq_zero (and.right H2),
    rw and.right H3,
end
theorem  unique_prime_factorization: ∀ A B:list nat,product A=product B→(∀p:nat, p∈A→prime p)→(∀ p:nat,p∈ B→ prime p)→∀ p:nat,list.count p A=list.count p B:=begin
assume A,
    induction A with pA A1 Hi,
    unfold product,norm_num,
    assume B HP HA p,
    have H:p∈ B→ ¬p∈ B:=begin
        intro HpB,
        have H:= HA p HpB,
        have H1:=product_dvd p B HpB,
        rw ←HP at H1,
        exfalso,
        exact prime.not_dvd_one H H1,
    end,
    cases classical.em(list.count p B>0) with A A,
    have H1:=H (list.mem_of_count_pos A) (list.mem_of_count_pos A),exfalso,assumption,
    cases (eq_zero_or_pos (list.count p B)),rwa eq_comm, exfalso, exact A a,

    assume B,
    cases B with pB B1,clear Hi,norm_num,
    assume HP Hp Hb,
    exfalso,
    unfold product at HP,
    have H:=and.left (eq_one_of_mul_eq_one pA (product A1) HP),
    unfold prime at Hp, rw H at Hp,revert Hp,simp,norm_num,

    assume HP HppA H6 HppB H7,

    cases classical.em(pA ∣ pB) with A B,
    unfold prime at HppA HppB,
    have H:=and.right HppB pA A,
    have H1:pA=1↔ false:=begin apply iff.intro, assume H2,rw H2 at HppA,revert HppA,norm_num,end,
    rw H1 at H,clear H1,simp at H,
    unfold product at HP, rw H at HP,
    have HpB0: pB>0:=gt_of_ge_of_gt (and.left HppB) (begin norm_num,end),
    have H2:product A1=product B1:=iff.elim_left (nat.mul_left_inj HpB0) HP,

    have Hi2:=Hi B1 H2 H6 H7,assume p,rw H,
    rw ←H,
    cases classical.em(p=pA) with C C,
    rw [C,list.count_cons_self,list.count_cons_self],rw (Hi2 pA),
    rw[list.count_cons_of_ne C,list.count_cons_of_ne C],exact Hi2 p,

    unfold product at HP,
    have HA:(∀ (p : ℕ), p ∈pA:: A1 → prime p):=begin norm_num,exact and.intro HppA H6 end,
    have HB:(∀ (p : ℕ), p ∈ pB::B1 → prime p):=begin norm_num,exact and.intro HppB H7 end,
    have H8:pA ∣ product B1:=begin
        have H:=dvd_mul_right pA (product A1),rw HP at H,
        have H2:=euclids_lemma pB (product B1) pA HppA H,
        have H3:pA ∣ pB↔ false:=by{apply iff.intro, exact B,trivial},rw H3 at H2,simp at H2,assumption
    end,
    have H9:=prime_product_dvd B1 pA HppA H7 H8,
    have H11:pA ∈ pB :: B1:=by{revert H9,intro,right,assumption},
    have H10:=anti_cons_list (pB::B1) pA H11 HB,
    intros,
    cases H10 with B2 HB2,
    unfold product at HB2,rw ←HP at HB2,
    have HpA0:pA>0:=gt_of_ge_of_gt (and.left HppA) (by norm_num),
    have H2:=iff.elim_left (nat.mul_left_inj HpA0) (and.left HB2),
    have H3:=λ p Hp,and.left (and.right HB2) p Hp,
    have H4:=λ p,and.right (and.right HB2) p,
    have Hi2:= Hi B2 H2 H6 H3,
    rw H4,
    cases classical.em (p=pA) with D D,rw D,
    rw[list.count_cons_self,list.count_cons_self, Hi2 pA],
    rw[list.count_cons_of_ne D,list.count_cons_of_ne D, Hi2 p],

end
theorem fundamental_theorem_of_arithmetic: ∀ n:ℕ,1≤n→∃ L:list ℕ, (∀ p:ℕ, p ∈ L → prime p) ∧ product L = n ∧ ∀ M:list ℕ, ((∀ p:ℕ, p ∈ M → prime p) → product M = n → (∀ p:ℕ, list.count p L = list.count p M)):=begin
    assume n Hn,
    cases (prime_product n Hn) with L HL,
    existsi L,
    apply and.intro (and.left HL),
    apply and.intro (and.right HL),
    assume M H1 H2 p,
    rw[eq_comm,←and.right HL] at H2,
    exact (unique_prime_factorization L) M H2 (and.left HL) H1 p,
end


import data.matrix data.rat.basic linear_algebra.determinant
variable {n : ℕ}

open matrix

local infix ` ⬝ `:70 := matrix.mul
local postfix `ᵀ` : 1500 := matrix.transpose

def comatrix (M : matrix (fin n) (fin n) ℚ) : matrix (fin n) (fin n) ℚ :=
begin
  cases n,
  { exact fin.elim0 },
  { exact λ i j, (-1) ^ (i + j : ℕ) * det (minor M
      (λ i' : fin n, if i'.1 < i.1 then i'.cast_succ else i'.succ)
      (λ j' : fin n, if j'.1 < j.1 then j'.cast_succ else j'.succ)) }
end

def list.to_matrix (m :ℕ) (n : ℕ) (l : list (list ℚ)) : matrix (fin m) (fin n) ℚ :=
λ i j, (l.nth_le i sorry).nth_le j sorry

instance has_repr_fin_fun {n : ℕ} {α : Type*} [has_repr α] : has_repr (fin n → α) :=
⟨λ f, repr (vector.of_fn f).to_list⟩

instance {m n} : has_repr (matrix (fin m) (fin n) ℚ) := has_repr_fin_fun

def inverse (M : matrix (fin n) (fin n) ℚ) : matrix (fin n) (fin n) ℚ :=
(det M)⁻¹ • (comatrix M)ᵀ

lemma mul_inverse : Π n, (M : matrix (fin n) (fin n) ℚ) : M ⬝ inverse M = 1 :=
begin

end

def M := list.to_matrix 3 3 [[1,2,3],[1,2,0],[0,1,0]]

#eval M ⬝ inverse M


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.pfunctor.univariate

/-!

# Quotients of Polynomial Functors

We assume the following:

`P`   : a polynomial functor
`W`   : its W-type
`M`   : its M-type
`F`   : a functor

We define:

`q`   : `qpf` data, representing `F` as a quotient of `P`

The main goal is to construct:

`fix`   : the initial algebra with structure map `F fix → fix`.
`cofix` : the final coalgebra with structure map `cofix → F cofix`

We also show that the composition of qpfs is a qpf, and that the quotient of a qpf
is a qpf.

The present theory focuses on the univariate case for qpfs

## References

* [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]

-/

universe u

/--
Quotients of polynomial functors.

Roughly speaking, saying that `F` is a quotient of a polynomial functor means that for each `α`,
elements of `F α` are represented by pairs `⟨a, f⟩`, where `a` is the shape of the object and
`f` indexes the relevant elements of `α`, in a suitably natural manner.
-/

class qpf (F : Type u → Type u) [functor F] :=
(P         : pfunctor.{u})
(abs       : Π {α}, P.obj α → F α)
(repr      : Π {α}, F α → P.obj α)
(abs_repr  : ∀ {α} (x : F α), abs (repr x) = x)
(abs_map   : ∀ {α β} (f : α → β) (p : P.obj α), abs (f <$> p) = f <$> abs p)

namespace qpf
variables {F : Type u → Type u} [functor F] [q : qpf F]
include q
open functor (liftp liftr)

/-
Show that every qpf is a lawful functor.

Note: every functor has a field, `map_const`, and is_lawful_functor has the defining
characterization. We can only propagate the assumption.
-/

theorem id_map {α : Type*} (x : F α) : id <$> x = x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map], reflexivity }

theorem comp_map {α β γ : Type*} (f : α → β) (g : β → γ) (x : F α) :
  (g ∘ f) <$> x = g <$> f <$> x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map, ←abs_map, ←abs_map], reflexivity }

theorem is_lawful_functor
    (h : ∀ α β : Type u, @functor.map_const F _ α _ = functor.map ∘ function.const β) :
  is_lawful_functor F :=
{ map_const_eq := h,
  id_map := @id_map F _ _,
  comp_map := @comp_map F _ _ }

/-
Lifting predicates and relations
-/

section
open functor

theorem liftp_iff {α : Type u} (p : α → Prop) (x : F α) :
  liftp p x ↔ ∃ a f, x = abs ⟨a, f⟩ ∧ ∀ i, p (f i) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : repr y with a f,
    use [a, λ i, (f i).val], split,
    { rw [←hy, ←abs_repr y, h, ←abs_map], reflexivity },
    intro i, apply (f i).property },
  rintros ⟨a, f, h₀, h₁⟩, dsimp at *,
  use abs (⟨a, λ i, ⟨f i, h₁ i⟩⟩),
  rw [←abs_map, h₀], reflexivity
end

theorem liftp_iff' {α : Type u} (p : α → Prop) (x : F α) :
  liftp p x ↔ ∃ u : q.P.obj α, abs u = x ∧ ∀ i, p (u.snd i) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : repr y with a f,
    use ⟨a, λ i, (f i).val⟩, dsimp, split,
    { rw [←hy, ←abs_repr y, h, ←abs_map], reflexivity },
    intro i, apply (f i).property },
  rintros ⟨⟨a, f⟩, h₀, h₁⟩, dsimp at *,
  use abs (⟨a, λ i, ⟨f i, h₁ i⟩⟩),
  rw [←abs_map, ←h₀], reflexivity
end

theorem liftr_iff {α : Type u} (r : α → α → Prop) (x y : F α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = abs ⟨a, f₀⟩ ∧ y = abs ⟨a, f₁⟩ ∧ ∀ i, r (f₀ i) (f₁ i) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : repr u with a f,
    use [a, λ i, (f i).val.fst, λ i, (f i).val.snd],
    split, { rw [←xeq, ←abs_repr u, h, ←abs_map], refl },
    split, { rw [←yeq, ←abs_repr u, h, ←abs_map], refl },
    intro i, exact (f i).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use abs ⟨a, λ i, ⟨(f₀ i, f₁ i), h i⟩⟩,
  dsimp, split,
  { rw [xeq, ←abs_map], refl },
  rw [yeq, ←abs_map], refl
end

end

/-
Think of trees in the `W` type corresponding to `P` as representatives of elements of the
least fixed point of `F`, and assign a canonical representative to each equivalence class
of trees.
-/

/-- does recursion on `q.P.W` using `g : F α → α` rather than `g : P α → α` -/
def recF {α : Type*} (g : F α → α) : q.P.W → α
| ⟨a, f⟩ := g (abs ⟨a, λ x, recF (f x)⟩)

theorem recF_eq {α : Type*} (g : F α → α) (x : q.P.W) :
  recF g x = g (abs (recF g <$> x.dest)) :=
by cases x; reflexivity

theorem recF_eq' {α : Type*} (g : F α → α) (a : q.P.A) (f : q.P.B a → q.P.W) :
  recF g ⟨a, f⟩ = g (abs (recF g <$> ⟨a, f⟩)) :=
rfl

/-- two trees are equivalent if their F-abstractions are -/
inductive Wequiv : q.P.W → q.P.W → Prop
| ind (a : q.P.A) (f f' : q.P.B a → q.P.W) :
    (∀ x, Wequiv (f x) (f' x)) → Wequiv ⟨a, f⟩ ⟨a, f'⟩
| abs (a : q.P.A) (f : q.P.B a → q.P.W) (a' : q.P.A) (f' : q.P.B a' → q.P.W) :
    abs ⟨a, f⟩ = abs ⟨a', f'⟩ → Wequiv ⟨a, f⟩ ⟨a', f'⟩
| trans (u v w : q.P.W) : Wequiv u v → Wequiv v w → Wequiv u w

/-- recF is insensitive to the representation -/
theorem recF_eq_of_Wequiv {α : Type u} (u : F α → α) (x y : q.P.W) :
  Wequiv x y → recF u x = recF u y :=
begin
  cases x with a f, cases y with b g,
  intro h, induction h,
  case qpf.Wequiv.ind : a f f' h ih
    { simp only [recF_eq', pfunctor.map_eq, function.comp, ih] },
  case qpf.Wequiv.abs : a f a' f' h
    { simp only [recF_eq', abs_map, h] },
  case qpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact eq.trans ih₁ ih₂ }
end

theorem Wequiv.abs' (x y : q.P.W) (h : abs x.dest = abs y.dest) :
  Wequiv x y :=
by { cases x, cases y, apply Wequiv.abs, apply h }

theorem Wequiv.refl (x : q.P.W) : Wequiv x x :=
by cases x with a f; exact Wequiv.abs a f a f rfl

theorem Wequiv.symm (x y : q.P.W) : Wequiv x y → Wequiv y x :=
begin
  cases x with a f, cases y with b g,
  intro h, induction h,
  case qpf.Wequiv.ind : a f f' h ih
    { exact Wequiv.ind _ _ _ ih },
  case qpf.Wequiv.abs : a f a' f' h
    { exact Wequiv.abs _ _ _ _ h.symm },
  case qpf.Wequiv.trans : x y z e₁ e₂ ih₁ ih₂
    { exact qpf.Wequiv.trans _ _ _ ih₂ ih₁}
end

/-- maps every element of the W type to a canonical representative -/
def Wrepr : q.P.W → q.P.W := recF (pfunctor.W.mk ∘ repr)

theorem Wrepr_equiv (x : q.P.W) : Wequiv (Wrepr x) x :=
begin
  induction x with a f ih,
  apply Wequiv.trans,
  { change Wequiv (Wrepr ⟨a, f⟩) (pfunctor.W.mk (Wrepr <$> ⟨a, f⟩)),
    apply Wequiv.abs',
    have : Wrepr ⟨a, f⟩ = pfunctor.W.mk (repr (abs (Wrepr <$> ⟨a, f⟩))) := rfl,
    rw [this, pfunctor.W.dest_mk, abs_repr],
    reflexivity },
  apply Wequiv.ind, exact ih
end

/--
Define the fixed point as the quotient of trees under the equivalence relation `Wequiv`.
-/
def W_setoid : setoid q.P.W :=
⟨Wequiv, @Wequiv.refl _ _ _, @Wequiv.symm _ _ _, @Wequiv.trans _ _ _⟩

local attribute [instance] W_setoid

/-- inductive type defined as initial algebra of a Quotient of Polynomial Functor -/
@[nolint has_inhabited_instance]
def fix (F : Type u → Type u) [functor F] [q : qpf F] := quotient (W_setoid : setoid q.P.W)

/-- recursor of a type defined by a qpf -/
def fix.rec {α : Type*} (g : F α → α) : fix F → α :=
quot.lift (recF g) (recF_eq_of_Wequiv g)

/-- access the underlying W-type of a fixpoint data type -/
def fix_to_W : fix F → q.P.W :=
quotient.lift Wrepr (recF_eq_of_Wequiv (λ x, @pfunctor.W.mk q.P (repr x)))

/-- constructor of a type defined by a qpf -/
def fix.mk (x : F (fix F)) : fix F := quot.mk _ (pfunctor.W.mk (fix_to_W <$> repr x))

/-- destructor of a type defined by a qpf -/
def fix.dest : fix F → F (fix F) := fix.rec (functor.map fix.mk)

theorem fix.rec_eq {α : Type*} (g : F α → α) (x : F (fix F)) :
  fix.rec g (fix.mk x) = g (fix.rec g <$> x) :=
have recF g ∘ fix_to_W = fix.rec g,
  by { apply funext, apply quotient.ind, intro x, apply recF_eq_of_Wequiv,
       rw fix_to_W, apply Wrepr_equiv },
begin
  conv { to_lhs, rw [fix.rec, fix.mk], dsimp },
  cases h : repr x with a f,
  rw [pfunctor.map_eq, recF_eq, ←pfunctor.map_eq, pfunctor.W.dest_mk, ←pfunctor.comp_map,
      abs_map, ←h, abs_repr, this]
end

theorem fix.ind_aux (a : q.P.A) (f : q.P.B a → q.P.W) :
  fix.mk (abs ⟨a, λ x, ⟦f x⟧⟩) = ⟦⟨a, f⟩⟧ :=
have fix.mk (abs ⟨a, λ x, ⟦f x⟧⟩) = ⟦Wrepr ⟨a, f⟩⟧,
  begin
    apply quot.sound, apply Wequiv.abs',
    rw [pfunctor.W.dest_mk, abs_map, abs_repr, ←abs_map, pfunctor.map_eq],
    conv { to_rhs, simp only [Wrepr, recF_eq, pfunctor.W.dest_mk, abs_repr] },
    reflexivity
  end,
by { rw this, apply quot.sound, apply Wrepr_equiv }

theorem fix.ind_rec {α : Type u} (g₁ g₂ : fix F → α)
    (h : ∀ x : F (fix F), g₁ <$> x = g₂ <$> x → g₁ (fix.mk x) = g₂ (fix.mk x)) :
  ∀ x, g₁ x = g₂ x :=
begin
  apply quot.ind,
  intro x,
  induction x with a f ih,
  change g₁ ⟦⟨a, f⟩⟧ = g₂ ⟦⟨a, f⟩⟧,
  rw [←fix.ind_aux a f], apply h,
  rw [←abs_map, ←abs_map, pfunctor.map_eq, pfunctor.map_eq],
  dsimp [function.comp],
  congr' with x, apply ih
end

theorem fix.rec_unique {α : Type u} (g : F α → α) (h : fix F → α)
    (hyp : ∀ x, h (fix.mk x) = g (h <$> x)) :
  fix.rec g = h :=
begin
  ext x,
  apply fix.ind_rec,
  intros x hyp',
  rw [hyp, ←hyp', fix.rec_eq]
end

theorem fix.mk_dest (x : fix F) : fix.mk (fix.dest x) = x :=
begin
  change (fix.mk ∘ fix.dest) x = id x,
  apply fix.ind_rec,
  intro x, dsimp,
  rw [fix.dest, fix.rec_eq, id_map, comp_map],
  intro h, rw h
end

theorem fix.dest_mk (x : F (fix F)) : fix.dest (fix.mk x) = x :=
begin
  unfold fix.dest, rw [fix.rec_eq, ←fix.dest, ←comp_map],
  conv { to_rhs, rw ←(id_map x) },
  congr' with x, apply fix.mk_dest
end

theorem fix.ind (p : fix F → Prop)
    (h : ∀ x : F (fix F), liftp p x → p (fix.mk x)) :
  ∀ x, p x :=
begin
  apply quot.ind,
  intro x,
  induction x with a f ih,
  change p ⟦⟨a, f⟩⟧,
  rw [←fix.ind_aux a f],
  apply h,
  rw liftp_iff,
  refine ⟨_, _, rfl, _⟩,
  apply ih
end

end qpf

/-
Construct the final coalgebra to a qpf.
-/

namespace qpf
variables {F : Type u → Type u} [functor F] [q : qpf F]
include q
open functor (liftp liftr)

/-- does recursion on `q.P.M` using `g : α → F α` rather than `g : α → P α` -/
def corecF {α : Type*} (g : α → F α) : α → q.P.M :=
pfunctor.M.corec (λ x, repr (g x))

theorem corecF_eq {α : Type*} (g : α → F α) (x : α) :
  pfunctor.M.dest (corecF g x) = corecF g <$> repr (g x) :=
by rw [corecF, pfunctor.M.dest_corec]

/- Equivalence -/

/-- A pre-congruence on q.P.M *viewed as an F-coalgebra*. Not necessarily symmetric. -/
def is_precongr (r : q.P.M → q.P.M → Prop) : Prop :=
  ∀ ⦃x y⦄, r x y →
    abs (quot.mk r <$> pfunctor.M.dest x) = abs (quot.mk r <$> pfunctor.M.dest y)

/-- The maximal congruence on q.P.M -/
def Mcongr : q.P.M → q.P.M → Prop :=
λ x y, ∃ r, is_precongr r ∧ r x y

/-- coinductive type defined as the final coalgebra of a qpf -/
def cofix (F : Type u → Type u) [functor F] [q : qpf F]:= quot (@Mcongr F _ q)

instance [inhabited q.P.A] : inhabited (cofix F) := ⟨ quot.mk _ (default _) ⟩

/-- corecursor for type defined by `cofix` -/
def cofix.corec {α : Type*} (g : α → F α) (x : α) : cofix F :=
quot.mk  _ (corecF g x)

/-- destructor for type defined by `cofix` -/
def cofix.dest : cofix F → F (cofix F) :=
quot.lift
  (λ x, quot.mk Mcongr <$> (abs (pfunctor.M.dest x)))
  begin
    rintros x y ⟨r, pr, rxy⟩, dsimp,
    have : ∀ x y, r x y → Mcongr x y,
    { intros x y h, exact ⟨r, pr, h⟩ },
    rw [←quot.factor_mk_eq _ _ this], dsimp,
    conv { to_lhs, rw [comp_map, ←abs_map, pr rxy, abs_map, ←comp_map] }
  end

theorem cofix.dest_corec {α : Type u} (g : α → F α) (x : α) :
  cofix.dest (cofix.corec g x) = cofix.corec g <$> g x :=
begin
  conv { to_lhs, rw [cofix.dest, cofix.corec] }, dsimp,
  rw [corecF_eq, abs_map, abs_repr, ←comp_map], reflexivity
end

private theorem cofix.bisim_aux
    (r : cofix F → cofix F → Prop)
    (h' : ∀ x, r x x)
    (h : ∀ x y, r x y → quot.mk r <$> cofix.dest x = quot.mk r <$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
begin
  intro x, apply quot.induction_on x, clear x,
  intros x y, apply quot.induction_on y, clear y,
  intros y rxy,
  apply quot.sound,
  let r' := λ x y, r (quot.mk _ x) (quot.mk _ y),
  have : is_precongr r',
  { intros a b r'ab,
    have  h₀: quot.mk r <$> quot.mk Mcongr <$> abs (pfunctor.M.dest a) =
              quot.mk r <$> quot.mk Mcongr <$> abs (pfunctor.M.dest b) := h _ _ r'ab,
    have h₁ : ∀ u v : q.P.M, Mcongr u v → quot.mk r' u = quot.mk r' v,
    { intros u v cuv, apply quot.sound, dsimp [r'], rw quot.sound cuv, apply h' },
    let f : quot r → quot r' := quot.lift (quot.lift (quot.mk r') h₁)
      begin
        intro c, apply quot.induction_on c, clear c,
        intros c d, apply quot.induction_on d, clear d,
        intros d rcd, apply quot.sound, apply rcd
      end,
    have : f ∘ quot.mk r ∘ quot.mk Mcongr = quot.mk r' := rfl,
    rw [←this, pfunctor.comp_map _ _ f, pfunctor.comp_map _ _ (quot.mk r),
          abs_map, abs_map, abs_map, h₀],
    rw [pfunctor.comp_map _ _ f, pfunctor.comp_map _ _ (quot.mk r),
          abs_map, abs_map, abs_map] },
  refine ⟨r', this, rxy⟩
end

theorem cofix.bisim_rel
    (r : cofix F → cofix F → Prop)
    (h : ∀ x y, r x y → quot.mk r <$> cofix.dest x = quot.mk r <$> cofix.dest y) :
  ∀ x y, r x y → x = y :=
let r' x y := x = y ∨ r x y in
begin
  intros x y rxy,
  apply cofix.bisim_aux r',
  { intro x, left, reflexivity },
  { intros x y r'xy,
    cases r'xy, { rw r'xy },
    have : ∀ x y, r x y → r' x y := λ x y h, or.inr h,
    rw ←quot.factor_mk_eq _ _ this, dsimp,
    rw [@comp_map _ _ q _ _ _ (quot.mk r), @comp_map _ _ q _ _ _ (quot.mk r)],
    rw h _ _ r'xy },
  right, exact rxy
end

theorem cofix.bisim
    (r : cofix F → cofix F → Prop)
    (h : ∀ x y, r x y → liftr r (cofix.dest x) (cofix.dest y)) :
  ∀ x y, r x y → x = y :=
begin
  apply cofix.bisim_rel,
  intros x y rxy,
  rcases (liftr_iff r _ _).mp (h x y rxy) with ⟨a, f₀, f₁, dxeq, dyeq, h'⟩,
  rw [dxeq, dyeq, ←abs_map, ←abs_map, pfunctor.map_eq, pfunctor.map_eq],
  congr' 2 with i,
  apply quot.sound,
  apply h'
end

theorem cofix.bisim' {α : Type*} (Q : α → Prop) (u v : α → cofix F)
    (h : ∀ x, Q x → ∃ a f f',
      cofix.dest (u x) = abs ⟨a, f⟩ ∧
      cofix.dest (v x) = abs ⟨a, f'⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f i = u x' ∧ f' i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : cofix F, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
cofix.bisim R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    begin
      rcases h x' Qx' with ⟨a, f, f', ux'eq, vx'eq, h'⟩,
      rw liftr_iff,
      refine ⟨a, f, f', xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, h'⟩,
    end)
  _ _ ⟨x, Qx, rfl, rfl⟩

end qpf

/-
Composition of qpfs.
-/

namespace qpf

variables {F₂ : Type u → Type u} [functor F₂] [q₂ : qpf F₂]
variables {F₁ : Type u → Type u} [functor F₁] [q₁ : qpf F₁]
include q₂ q₁

/-- composition of qpfs gives another qpf  -/
def comp : qpf (functor.comp F₂ F₁) :=
{ P := pfunctor.comp (q₂.P) (q₁.P),
  abs := λ α,
    begin
      dsimp [functor.comp],
      intro p,
      exact abs ⟨p.1.1, λ x, abs ⟨p.1.2 x, λ y, p.2 ⟨x, y⟩⟩⟩
    end,
  repr := λ α,
    begin
      dsimp [functor.comp],
      intro y,
      refine ⟨⟨(repr y).1, λ u, (repr ((repr y).2 u)).1⟩, _⟩,
      dsimp [pfunctor.comp],
      intro x,
      exact (repr ((repr y).2 x.1)).snd x.2
    end,
  abs_repr := λ α,
    begin
      abstract {
      dsimp [functor.comp],
      intro x,
      conv { to_rhs, rw ←abs_repr x},
      cases h : repr x with a f,
      dsimp,
      congr' with x,
      cases h' : repr (f x) with b g,
      dsimp, rw [←h', abs_repr] }
    end,
  abs_map := λ α β f,
    begin
      abstract {
      dsimp [functor.comp, pfunctor.comp],
      intro p,
      cases p with a g, dsimp,
      cases a with b h, dsimp,
      symmetry,
      transitivity,
      symmetry,
      apply abs_map,
      congr,
      rw pfunctor.map_eq,
      dsimp [function.comp],
      simp [abs_map],
      split,
      reflexivity,
      ext x,
      rw ←abs_map,
      reflexivity }
    end
}

end qpf

/-
Quotients.

We show that if `F` is a qpf and `G` is a suitable quotient of `F`, then `G` is a qpf.
-/

namespace qpf
variables {F : Type u → Type u} [functor F] [q : qpf F]
variables {G : Type u → Type u} [functor G]
variable  {FG_abs  : Π {α}, F α → G α}
variable  {FG_repr : Π {α}, G α → F α}

/-- Given a qpf `F` and a well-behaved surjection `FG_abs` from F α to
functor G α, `G` is a qpf. We can consider `G` a quotient on `F` where
elements `x y : F α` are in the same equivalence class if
`FG_abs x = FG_abs y`  -/
def quotient_qpf
    (FG_abs_repr : Π {α} (x : G α), FG_abs (FG_repr x) = x)
    (FG_abs_map  : ∀ {α β} (f : α → β) (x : F α), FG_abs (f <$> x) = f <$> FG_abs x) :
  qpf G :=
{ P        := q.P,
  abs      := λ {α} p, FG_abs (abs p),
  repr     := λ {α} x, repr (FG_repr x),
  abs_repr := λ {α} x, by rw [abs_repr, FG_abs_repr],
  abs_map  := λ {α β} f x, by { rw [abs_map, FG_abs_map] } }

end qpf

/-
Support.
-/

namespace qpf
variables {F : Type u → Type u} [functor F] [q : qpf F]
include q
open functor (liftp liftr supp)
open set

theorem mem_supp {α : Type u} (x : F α) (u : α) :
  u ∈ supp x ↔ ∀ a f, abs ⟨a, f⟩ = x → u ∈ f '' univ :=
begin
  rw [supp], dsimp, split,
  { intros h a f haf,
    have : liftp (λ u, u ∈ f '' univ) x,
    { rw liftp_iff, refine ⟨a, f, haf.symm, λ i, mem_image_of_mem _ (mem_univ _)⟩ },
    exact h this },
  intros h p, rw liftp_iff,
  rintros ⟨a, f, xeq, h'⟩,
  rcases h a f xeq.symm with ⟨i, _, hi⟩,
  rw ←hi, apply h'
end

theorem supp_eq {α : Type u} (x : F α) : supp x = { u | ∀ a f, abs ⟨a, f⟩ = x → u ∈ f '' univ } :=
by ext; apply mem_supp

theorem has_good_supp_iff {α : Type u} (x : F α) :
  (∀ p, liftp p x ↔ ∀ u ∈ supp x, p u) ↔
    ∃ a f, abs ⟨a, f⟩ = x ∧ ∀ a' f', abs ⟨a', f'⟩ = x → f '' univ ⊆ f' '' univ :=
begin
  split,
  { intro h,
    have : liftp (supp x) x, by rw h; intro u; exact id,
    rw liftp_iff at this, rcases this with ⟨a, f, xeq, h'⟩,
    refine ⟨a, f, xeq.symm, _⟩,
    intros a' f' h'',
    rintros u ⟨i, _, hfi⟩,
    have : u ∈ supp x, by rw ←hfi; apply h',
    exact (mem_supp x u).mp this _ _ h'' },
  rintros ⟨a, f, xeq, h⟩ p, rw liftp_iff, split,
  { rintros ⟨a', f', xeq', h'⟩ u usuppx,
    rcases (mem_supp x u).mp usuppx a' f' xeq'.symm with ⟨i, _, f'ieq⟩,
    rw ←f'ieq, apply h' },
  intro h',
  refine ⟨a, f, xeq.symm, _⟩, intro i,
  apply h', rw mem_supp,
  intros a' f' xeq',
  apply h a' f' xeq',
  apply mem_image_of_mem _ (mem_univ _)
end

variable (q)

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def is_uniform : Prop := ∀ ⦃α : Type u⦄ (a a' : q.P.A)
    (f : q.P.B a → α) (f' : q.P.B a' → α),
  abs ⟨a, f⟩ = abs ⟨a', f'⟩ → f '' univ = f' '' univ

/-- does `abs` preserve `liftp`? -/
def liftp_preservation : Prop :=
∀ ⦃α⦄ (p : α → Prop) (x : q.P.obj α), liftp p (abs x) ↔ liftp p x

/-- does `abs` preserve `supp`? -/
def supp_preservation : Prop :=
∀ ⦃α⦄ (x : q.P.obj α), supp (abs x) = supp x

variable [q]

theorem supp_eq_of_is_uniform (h : q.is_uniform) {α : Type u} (a : q.P.A) (f : q.P.B a → α) :
  supp (abs ⟨a, f⟩) = f '' univ :=
begin
  ext u, rw [mem_supp], split,
  { intro h', apply h' _ _ rfl },
  intros h' a' f' e,
  rw [←h _ _ _ _ e.symm], apply h'
end

theorem liftp_iff_of_is_uniform (h : q.is_uniform) {α : Type u} (x : F α) (p : α → Prop) :
  liftp p x ↔ ∀ u ∈ supp x, p u :=
begin
  rw [liftp_iff, ←abs_repr x],
  cases repr x with a f,  split,
  { rintros ⟨a', f', abseq, hf⟩ u,
    rw [supp_eq_of_is_uniform h, h _ _ _ _ abseq],
    rintros ⟨i, _, hi⟩, rw ←hi, apply hf },
  intro h',
  refine ⟨a, f, rfl, λ i, h' _ _⟩,
  rw supp_eq_of_is_uniform h,
  exact ⟨i, mem_univ i, rfl⟩
end

theorem supp_map (h : q.is_uniform) {α β : Type u} (g : α → β) (x : F α) :
  supp (g <$> x) = g '' supp x :=
begin
  rw ←abs_repr x, cases repr x with a f, rw [←abs_map, pfunctor.map_eq],
  rw [supp_eq_of_is_uniform h, supp_eq_of_is_uniform h, image_comp]
end

theorem supp_preservation_iff_uniform :
  q.supp_preservation ↔ q.is_uniform :=
begin
  split,
  { intros h α a a' f f' h',
    rw [← pfunctor.supp_eq,← pfunctor.supp_eq,← h,h',h] },
  { rintros h α ⟨a,f⟩, rwa [supp_eq_of_is_uniform,pfunctor.supp_eq], }
end

theorem supp_preservation_iff_liftp_preservation :
  q.supp_preservation ↔ q.liftp_preservation :=
begin
  split; intro h,
  { rintros α p ⟨a,f⟩,
    have h' := h, rw supp_preservation_iff_uniform at h',
    dsimp only [supp_preservation,supp] at h,
    rwa [liftp_iff_of_is_uniform,supp_eq_of_is_uniform,pfunctor.liftp_iff'];
      try { assumption },
    { simp only [image_univ, mem_range, exists_imp_distrib],
      split; intros; subst_vars; solve_by_elim } },
  { rintros α ⟨a,f⟩,
    simp only [liftp_preservation] at h,
    simp only [supp,h] }
end

theorem liftp_preservation_iff_uniform :
  q.liftp_preservation ↔ q.is_uniform :=
by rw [← supp_preservation_iff_liftp_preservation, supp_preservation_iff_uniform]

end qpf