import combinatorics.simple_graph.basic
import combinatorics.simple_graph.subgraph
import data.finset.basic
import data.finset.card
import data.fintype.basic
import data.fintype.card
import data.finset.powerset
import simple_graph_aux
import complete_graph_aux
import coercions_aux
import induced_subgraph

universe u
variables {V : Type u} [fintype V] [decidable_eq V]
variables (G : simple_graph V) [decidable_rel G.adj]
variables {k : ℕ}

variable R : ↥(finset.powerset_len k (finset.univ : finset V))

variable red_edges : (finset ↥G.edge_finset)

variable red_edges_by_R :
finset ↥(G.edge_finset \ ((G.induced_subgraph R).edge_finset)) ×
finset ↥((G.induced_subgraph R).edge_finset)

-- trivial helper lemma
lemma card_R : (R : finset V).card = k :=
begin
  cases R with R R_in,
  change R.card = k,
  rw finset.mem_powerset_len at R_in,
  rw R_in.right,
end

def red_edges_by_R_coe :
( finset ↥(G.edge_finset \ ((G.induced_subgraph R).edge_finset)) ×
  finset ↥((G.induced_subgraph R).edge_finset) ) →
  (finset ↥G.edge_finset) := λ c,
  ↑(⟨finset.map (function.embedding.subtype _) c.fst ∪
    finset.map (function.embedding.subtype _) c.snd,
    begin
      rw finset.union_subset_iff,
      split,
      { rw finset.subset_iff,
        intro x,
        intro x_in,
        have x_in' := finset.property_of_mem_map_subtype c.fst x_in,
        rw finset.mem_sdiff at x_in',
        exact x_in'.left,},
      { rw finset.subset_iff,
        intro x,
        intro x_in,
        have x_in' := finset.property_of_mem_map_subtype c.snd x_in,
        apply finset.mem_of_subset,
        exact (G.induced_subgraph R).edge_finset_subset,
        exact x_in', },
    end⟩ : {s // s ⊆ G.edge_finset})

instance red_edges_by_R_has_coe : has_coe
  ( finset ↥(G.edge_finset \ ((G.induced_subgraph R).edge_finset)) ×
    finset ↥((G.induced_subgraph R).edge_finset))
  (finset ↥G.edge_finset)
:= ⟨red_edges_by_R_coe G R⟩

theorem red_edges_by_R_coe_inj :
function.injective (red_edges_by_R_coe G R) :=
begin
  unfold function.injective,
  unfold red_edges_by_R_coe,
  change (coe : {s // s ⊆ G.edge_finset} → finset ↥(G.edge_finset))
    with subset_subtype.finset_subtype.coe,
  intros c₁ c₂,
  intro h_union,
  rw function.injective.eq_iff subset_subtype.finset_subtype.coe_injective
    at h_union,
  rw subtype.mk_eq_mk at h_union,
  rw prod.ext_iff,
  split,
  { rw finset.ext_iff,
    intro e,
    split,
    { intro e_in₁,
      have e_coe_in₁ := finset.mem_map_of_mem
        (function.embedding.subtype _) e_in₁,
      rw function.embedding.coe_subtype _ at e_coe_in₁,
      have e_coe_in_union :
        ↑e ∈ finset.map (function.embedding.subtype _) c₁.fst ∪
          finset.map (function.embedding.subtype _) c₁.snd,
      { rw finset.mem_union,
        left,
        exact e_coe_in₁, },
      rw h_union at e_coe_in_union,
      have e_coe_in₂ :
        ↑e ∈ finset.map (function.embedding.subtype _) c₂.fst,
      { rw finset.mem_union at e_coe_in_union,
        cases e_coe_in_union with e_coe_in₂ e_coe_in_false,
        { exact e_coe_in₂, },
        { exfalso,
          have e_in_R :=
            finset.property_of_mem_map_subtype _ e_coe_in_false,
          have e_not_in_R := e.property,
          rw finset.mem_sdiff at e_not_in_R,
          exact e_not_in_R.right e_in_R, }, },
      simp only [finset.mem_sdiff, simple_graph.mem_edge_finset,
        simple_graph.complete_graph_eq_top, coe_coe, finset.mem_map,
        function.embedding.coe_subtype, exists_prop, subtype.exists,
        subtype.coe_mk, exists_and_distrib_right, exists_eq_right,
        finset.mk_coe] at e_coe_in₂,
      exact e_coe_in₂.right, },
    { intro e_in₂,
      have e_coe_in₂ := finset.mem_map_of_mem
        (function.embedding.subtype _) e_in₂,
      rw function.embedding.coe_subtype _ at e_coe_in₂,
      have e_coe_in_union :
        ↑e ∈ finset.map (function.embedding.subtype _) c₂.fst ∪
          finset.map (function.embedding.subtype _) c₂.snd,
      { rw finset.mem_union,
        left,
        exact e_coe_in₂, },
      rw ← h_union at e_coe_in_union,
      have e_coe_in₁ :
        ↑e ∈ finset.map (function.embedding.subtype _) c₁.fst,
      { rw finset.mem_union at e_coe_in_union,
        cases e_coe_in_union with e_coe_in₁ e_coe_in_false,
        { exact e_coe_in₁, },
        { exfalso,
          have e_in_R :=
            finset.property_of_mem_map_subtype _ e_coe_in_false,
          have e_not_in_R := e.property,
          rw finset.mem_sdiff at e_not_in_R,
          exact e_not_in_R.right e_in_R,}, },
      simp only [finset.mem_sdiff, simple_graph.mem_edge_finset,
        simple_graph.complete_graph_eq_top, coe_coe, finset.mem_map,
        function.embedding.coe_subtype, exists_prop, subtype.exists,
        subtype.coe_mk, exists_and_distrib_right, exists_eq_right,
        finset.mk_coe] at e_coe_in₁,
      exact e_coe_in₁.right, }, },
  { rw finset.ext_iff,
    intro e,
    split,
    { intro e_in₁,
      have e_coe_in₁ := finset.mem_map_of_mem
        (function.embedding.subtype _) e_in₁,
      rw function.embedding.coe_subtype at e_coe_in₁,
      have e_coe_in_union :
        ↑e ∈ finset.map (function.embedding.subtype _) c₁.fst ∪
          finset.map (function.embedding.subtype _) c₁.snd,
      { rw finset.mem_union,
        right,
        exact e_coe_in₁, },
      rw h_union at e_coe_in_union,
      have e_coe_in₂ :
        ↑e ∈ finset.map (function.embedding.subtype _) c₂.snd,
      { rw finset.mem_union at e_coe_in_union,
        cases e_coe_in_union with e_coe_in_false e_coe_in₂,
        { exfalso,
          have e_not_in_R :=
            finset.property_of_mem_map_subtype _ e_coe_in_false,
          rw finset.mem_sdiff at e_not_in_R,
          have e_in_R := e.property,
          exact e_not_in_R.right e_in_R, },
        { exact e_coe_in₂, }, },
      simp only [coe_coe, finset.mem_map, function.embedding.coe_subtype,
        exists_prop, subtype.exists, subtype.coe_mk,
        exists_and_distrib_right, exists_eq_right, finset.mk_coe]
        at e_coe_in₂,
      exact e_coe_in₂.right, },
    { intro e_in₂,
      have e_coe_in₂ := finset.mem_map_of_mem
        (function.embedding.subtype _) e_in₂,
      rw function.embedding.coe_subtype at e_coe_in₂,
      have e_coe_in_union :
        ↑e ∈ finset.map (function.embedding.subtype _) c₂.fst ∪
          finset.map (function.embedding.subtype _) c₂.snd,
      { rw finset.mem_union,
        right,
        exact e_coe_in₂, },
      rw ← h_union at e_coe_in_union,
      have e_coe_in₁ :
        ↑e ∈ finset.map (function.embedding.subtype _) c₁.snd,
      { rw finset.mem_union at e_coe_in_union,
        cases e_coe_in_union with e_coe_in_false e_coe_in₁,
        { exfalso,
          have e_not_in_R :=
            finset.property_of_mem_map_subtype _ e_coe_in_false,
          rw finset.mem_sdiff at e_not_in_R,
          have e_in_R := e.property,
          exact e_not_in_R.right e_in_R, },
        { exact e_coe_in₁, }, },
      simp only [coe_coe, finset.mem_map, function.embedding.coe_subtype,
        exists_prop, subtype.exists, subtype.coe_mk,
        exists_and_distrib_right, exists_eq_right, finset.mk_coe]
        at e_coe_in₁,
      exact e_coe_in₁.right, }, },
end

def A : Prop :=
∀ (e₁ : ↥((G.induced_subgraph R).edge_finset))
  (e₂ : ↥((G.induced_subgraph R).edge_finset)),
( set.inclusion (G.induced_subgraph R).edge_finset_subset e₁ ∈ red_edges ∧
  set.inclusion (G.induced_subgraph R).edge_finset_subset e₂ ∈ red_edges ) ∨
( set.inclusion (G.induced_subgraph R).edge_finset_subset e₁ ∉ red_edges ∧
  set.inclusion (G.induced_subgraph R).edge_finset_subset e₂ ∉ red_edges )

instance A_decidable : decidable_pred (A G R) :=
begin
  unfold decidable_pred,
  intro red_edges,
  unfold A,
  refine fintype.decidable_forall_fintype,
end

def finset_univ_two_colouring : finset (finset ↥(G.edge_finset)) :=
finset.univ

def two_colourings_sat_A_R : finset (finset ↥(G.edge_finset)) :=
finset.filter (A G R) (finset_univ_two_colouring G)

def empty_univ_col_R :
finset (finset ↥(G.edge_finset \ ((G.induced_subgraph R).edge_finset)) ×
 finset ↥((G.induced_subgraph R).edge_finset)) :=
finset.product finset.univ {∅, finset.univ}

theorem all_red_colourings_sat_A_R :
two_colourings_sat_A_R (complete_graph V) R =
finset.map
  ⟨red_edges_by_R_coe (complete_graph V) R, red_edges_by_R_coe_inj _ _⟩
  (empty_univ_col_R (complete_graph V) R) :=
begin
  unfold two_colourings_sat_A_R,
  unfold finset_univ_two_colouring,
  unfold empty_univ_col_R,
  unfold red_edges_by_R_coe,
  change (coe :
    {s // s ⊆ (complete_graph V).edge_finset} →
      finset ↥((complete_graph V).edge_finset))
    with subset_subtype.finset_subtype.coe,
  rw finset.ext_iff,
  intro c,
  simp only [finset.mem_filter, finset.mem_univ, true_and, finset.mem_map,
    finset.mem_product, finset.mem_insert, finset.mem_singleton,
    function.embedding.coe_fn_mk, exists_prop, prod.exists],
  split,
  { intro hA,
    generalize h_cR :
      simple_graph.induced_subgraph.edge_subtype_finset
        (complete_graph V) R (finset.map (function.embedding.subtype _) c)
      = cR,
    generalize h_cRc :
      simple_graph.induced_subgraph.edge_complement_subtype_finset
        (complete_graph V) R (finset.map (function.embedding.subtype _) c)
      = cRc,
    use cRc,
    use cR,
    rw ← @finset.map_inj _ _
      (function.embedding.subtype (∈ (complete_graph V).edge_finset)) _ _,
    rw subset_subtype.coe_type,
    have h_union :
      finset.map (function.embedding.subtype _) cRc ∪
      finset.map (function.embedding.subtype _) cR =
      finset.map (function.embedding.subtype _) c,
    { rw ← h_cR,
      rw ← h_cRc,
      unfold simple_graph.induced_subgraph.edge_complement_subtype_finset,
      unfold simple_graph.induced_subgraph.edge_subtype_finset,
      rw finset.subtype_map,
      rw finset.subtype_map,
      simp_rw [finset.mem_sdiff],
      rw finset.union_comm,
      rw finset.filter_and,
      rw finset.union_distrib_left,
      rw finset.filter_union_filter_neg_eq
        (∈ ((complete_graph V).induced_subgraph ↑R).edge_finset)
          (finset.map (function.embedding.subtype _) c),
      have h_eq_c :
        finset.filter
          (∈ (complete_graph V).edge_finset)
          (finset.map (function.embedding.subtype _) c) =
        (finset.map (function.embedding.subtype _) c),
      { rw finset.filter_eq_self,
        intro x,
        intro x_in,
        have := finset.property_of_mem_map_subtype _ x_in,
        exact this, },
      rw h_eq_c,
      rw finset.union_comm,
      exact finset.union_inter_cancel_left, },
    cases finset.eq_empty_or_nonempty cR with cR_empty cR_nonempty,
    { clear hA,
      split,
      { left,
        exact cR_empty,},
      { exact h_union, }, },
    { split,
      { clear h_union,
        right,
        unfold finset.nonempty at cR_nonempty,
        cases cR_nonempty with e₁ e₁_in,
        apply finset.ext,
        intro e₂,
        split,
        { revert e₂,
          exact cR.subset_univ, },
        { intro e₂_in,
          specialize hA e₁ e₂,
          cases hA with h_red h_blue,
          { rw ← h_cR,
            unfold simple_graph.induced_subgraph.edge_subtype_finset,
            simp only [simple_graph.mem_edge_finset,
              simple_graph.complete_graph_eq_top, finset.mem_subtype,
                finset.mem_map, function.embedding.coe_subtype,
                exists_prop, subtype.exists, subtype.coe_mk,
                exists_and_distrib_right, exists_eq_right],
            have e₂_in_set : ↑e₂ ∈ (complete_graph V).edge_set,
            { have e₂_in_finset := finset.mem_of_subset
                ((complete_graph V).induced_subgraph R).edge_finset_subset
                e₂.property,
              unfold simple_graph.edge_finset at e₂_in_finset,
              rw set.mem_to_finset at e₂_in_finset,
              exact e₂_in_finset, },
            use e₂_in_set,
          exact h_red.right, },
          { exfalso,
            have e₁_not_in := h_blue.left,
            rw ← h_cR at e₁_in,
            unfold simple_graph.induced_subgraph.edge_subtype_finset
              at e₁_in,
            simp only [simple_graph.mem_edge_finset,
              simple_graph.complete_graph_eq_top, finset.mem_subtype,
              finset.mem_map, function.embedding.coe_subtype, exists_prop,
              subtype.exists, subtype.coe_mk, exists_and_distrib_right,
              exists_eq_right] at e₁_in,
            cases e₁_in with _ e₁_in,
            exact h_blue.left e₁_in, }, }, },
        { exact h_union, }, }, },
  { rintro ⟨cRc, cR, hcR, h_union⟩,
    cases hcR with cR_empty cR_univ,
    { intros e₁ e₂,
      right,
      rw ← h_union,
      clear h_union,
      rw cR_empty,
      clear cR_empty,
      simp only [finset.map_empty, finset.union_empty],
      unfold subset_subtype.finset_subtype.coe,
      split,
      { by_contra,
        simp only [finset.univ_eq_attach, finset.mem_map,
          finset.mem_attach, function.embedding.coe_fn_mk,
          exists_true_left] at h,
        unfold set.inclusion at h,
        rcases h with ⟨⟨a, a_in⟩, h_eq⟩,
        rw subtype.mk_eq_mk at h_eq,
        change a = e₁.val at h_eq,
        rw h_eq at a_in,
        have e_in := finset.property_of_mem_map_subtype cRc a_in,
        rw finset.mem_sdiff at e_in,
        exact e_in.right e₁.property, },
      { by_contra,
        simp only [finset.univ_eq_attach, finset.mem_map,
          finset.mem_attach, function.embedding.coe_fn_mk,
          exists_true_left] at h,
        unfold set.inclusion at h,
        rcases h with ⟨⟨a, a_in⟩, h_eq⟩,
        rw subtype.mk_eq_mk at h_eq,
        change a = e₂.val at h_eq,
        rw h_eq at a_in,
        have e_in := finset.property_of_mem_map_subtype cRc a_in,
        rw finset.mem_sdiff at e_in,
        exact e_in.right e₂.property, }, },
    { intros e₁ e₂,
      left,
      rw ← h_union,
      clear h_union,
      rw cR_univ,
      clear cR_univ,
      unfold subset_subtype.finset_subtype.coe,
      simp only [finset.univ_eq_attach, finset.mem_map, finset.mem_attach,
        function.embedding.coe_fn_mk, exists_true_left],
      split,
      { use e₁,
        { rw set.mem_def,
          rw ← finset.mem_def,
          rw finset.mem_union,
          right,
          change (function.embedding.subtype _) e₁ ∈ finset.map
              (function.embedding.subtype _) finset.univ,
          rw finset.mem_map' (function.embedding.subtype _),
          exact finset.mem_univ e₁, },
        refl, },
      { use e₂,
        { rw set.mem_def,
          rw ← finset.mem_def,
          rw finset.mem_union,
          right,
          change (function.embedding.subtype _) e₂ ∈ finset.map
              (function.embedding.subtype _) finset.univ,
          rw finset.mem_map' (function.embedding.subtype _),
          exact finset.mem_univ e₂, },
        refl, }, }, },
end

theorem card_red_colourings_sat_A_R (hk : k ≥ 2) :
(two_colourings_sat_A_R (complete_graph V) R).card =
  2 ^ ((fintype.card V).choose 2 - k.choose 2 + 1) :=
begin
  rw all_red_colourings_sat_A_R,
  unfold empty_univ_col_R,
  rw finset.card_map,
  rw finset.card_product,
  rw finset.card_univ,
  rw fintype.card_finset,
  rw fintype.card_coe,
  rw finset.card_sdiff
    (((complete_graph V).induced_subgraph R).edge_finset_subset),
  rw complete_graph.induced_subgraph.card_edge_finset,
  change (↑R : set V) with (↑(↑R : finset V) : set V),
  simp_rw finset.coe_sort_coe,
  rw fintype.card_coe,
  rw complete_graph.card_edge_finset,
  rw finset.card_doubleton,
  rw pow_succ',
  rw card_R,
  symmetry,
  apply finset.nonempty.ne_empty,
  rw finset.univ_nonempty_iff,
  rw finset.nonempty_coe_sort,
  unfold simple_graph.subgraph.edge_finset,
  rw ← finset.coe_nonempty,
  exact complete_graph.induced_subgraph_size.edge_finset_nonempty R hk,
end

variable (k)

def finset_univ_prod_R_colouring :
finset (finset.powerset_len k (finset.univ : finset V) ×
  finset ↥G.edge_finset) := finset.univ

theorem finset_univ_prod_R_colouring_eq_prod_univ :
finset_univ_prod_R_colouring G k =
  finset.product finset.univ finset.univ :=
begin
  unfold finset_univ_prod_R_colouring,
  exact finset.univ_product_univ,
end

theorem finset_univ_prod_R_colouring_eq_bUnion :
finset_univ_prod_R_colouring G k = finset.univ.bUnion
  (λ R, finset.map ⟨prod.mk R, prod.mk.inj_left R⟩ finset.univ) :=
begin
  simp_rw [finset.map_eq_image],
  rw finset_univ_prod_R_colouring_eq_prod_univ,
  exact finset.product_eq_bUnion finset.univ finset.univ,
end

def finset_univ_prod_R_colouring_sat_A_R :
finset (finset.powerset_len k (finset.univ : finset V) ×
  finset ↥G.edge_finset) :=
finset.filter (λ Rc, A G Rc.fst Rc.snd) (finset_univ_prod_R_colouring G k)

lemma function.uncurry.comp_prod_mk_eq_self
  {α : Type*} {β : Type*} {γ : Type*} (f : α → β → γ) (a : α) :
(function.uncurry f) ∘ (prod.mk a) = f a := by unfold function.uncurry

theorem finset_univ_prod_R_colouring_sat_A_R_eq_bUnion_filter :
finset_univ_prod_R_colouring_sat_A_R G k =
  finset.univ.bUnion (λ R, finset.map
    ⟨prod.mk R, prod.mk.inj_left R⟩
    (two_colourings_sat_A_R G R)) :=
begin
  unfold finset_univ_prod_R_colouring_sat_A_R,
  rw finset_univ_prod_R_colouring_eq_bUnion,
  rw finset.filter_bUnion,
  apply congr_arg,
  apply funext,
  intro R,
  unfold two_colourings_sat_A_R,
  rw finset.map_filter,
  apply congr_arg,
  rw function.embedding.coe_fn_mk,
  change (λ Rc :
      ↥(finset.powerset_len k finset.univ) × finset ↥(G.edge_finset),
    A G Rc.fst Rc.snd) with function.uncurry (A G),
  simp_rw [function.uncurry.comp_prod_mk_eq_self],
  unfold finset_univ_two_colouring,
end

theorem card_finset_univ_prod_R_colouring_sat_A_R {k} (hk : k ≥ 2) :
(finset_univ_prod_R_colouring_sat_A_R (complete_graph V) k).card =
  (fintype.card V).choose k * 2 ^ ((fintype.card V).choose 2 -
    k.choose 2 + 1) :=
begin
  rw finset_univ_prod_R_colouring_sat_A_R_eq_bUnion_filter,
  rw finset.card_bUnion,
  rw finset.sum_const_nat,
  swap 3,
  { exact 2 ^ ((fintype.card V).choose 2 - k.choose 2 + 1) },
  { rw finset.card_univ,
    rw fintype.card_coe,
    rw finset.card_powerset_len,
    rw finset.card_univ, },
  { intros R R_in,
    rw finset.card_map,
    rw card_red_colourings_sat_A_R,
    exact hk, },
  intros R R_in R' R'_in R_ne_R',
  rw finset.disjoint_iff_ne,
  rintros ⟨R₁, c⟩ Rc_in ⟨R'₁, c'⟩ R'c'_in,
  simp only [finset.mem_map, function.embedding.coe_fn_mk,
    prod.mk.inj_iff, exists_prop, exists_eq_right_right] at Rc_in R'c'_in,
  rw ← Rc_in.right,
  rw ← R'c'_in.right,
  rw ne.def,
  rw prod.mk.inj_iff,
  exact not_and_of_not_left _ R_ne_R',
end

def finset_univ_colouring_sat_A : finset (finset ↥G.edge_finset) :=
finset.image prod.snd (@finset_univ_prod_R_colouring_sat_A_R _ _ _ G _ k)

theorem finset_univ_prod_R_colouring_sat_A_R_ssubset_univ {k}
( h : ((fintype.card V).choose k) * 2 ^
    ((fintype.card V).choose 2 - k.choose 2 + 1) <
    2 ^ (fintype.card V).choose 2) (hk : k ≥ 2) :
finset_univ_colouring_sat_A (complete_graph V) k ⊂
  (finset_univ_two_colouring (complete_graph V)) :=
begin
  unfold finset_univ_two_colouring,
  rw finset.ssubset_iff_subset_ne,
  split,
  { exact finset.subset_univ _, },
  { rw ← finset.card_lt_iff_ne_univ,
    calc (finset_univ_colouring_sat_A (complete_graph V) k).card ≤
      (finset_univ_prod_R_colouring_sat_A_R (complete_graph V) k).card :
        finset.card_image_le
      ... = (fintype.card V).choose k * 2 ^
            ((fintype.card V).choose 2 - k.choose 2 + 1) :
        card_finset_univ_prod_R_colouring_sat_A_R hk
      ... < 2 ^ (fintype.card V).choose 2 : h
      ... = finset.univ.card :
        begin
          rw finset.card_univ,
          rw fintype.card_finset,
          rw fintype.card_coe,
          rw complete_graph.card_edge_finset
        end, },
end

theorem ramsey_lower_bound {k}
( h : ((fintype.card V).choose k) * 2 ^
    ((fintype.card V).choose 2 - k.choose 2 + 1) <
    2 ^ (fintype.card V).choose 2) (hk : k ≥ 2) :
∃ c : finset ↥((complete_graph V).edge_finset),
  ¬∃ R' : ↥(finset.powerset_len k (finset.univ : finset V)),
    A (complete_graph V) R' c :=
begin
  rcases
    finset.exists_of_ssubset
      (finset_univ_prod_R_colouring_sat_A_R_ssubset_univ h hk)
    with ⟨c, c_in, c_not_in⟩,
  use c,
  convert_to ¬∃ R',
    (R', c) ∈ (finset_univ_prod_R_colouring_sat_A_R (complete_graph V) k),
  { unfold finset_univ_prod_R_colouring_sat_A_R,
    simp_rw finset.mem_filter,
    unfold finset_univ_prod_R_colouring,
    simp_rw [eq_true_intro (finset.mem_univ _)],
    simp_rw [true_and], },
  unfold finset_univ_colouring_sat_A at c_not_in,
  rw finset.mem_image at c_not_in,
  rw not_exists at c_not_in,
  rw not_exists,
  intro R,
  specialize c_not_in (R, c),
  rw not_exists at c_not_in,
  rw eq_self_iff_true at c_not_in,
  rw not_true at c_not_in,
  rw imp_false at c_not_in,
  exact c_not_in,
end


section
  variables (x y z : ℕ)
  variables (h₁ : x = y) (h₂ : y = z)

  include h₁ h₂
  theorem foo : x = z :=
  begin
    rw [h₁, h₂]
  end
  omit h₁ h₂

  theorem bar : x = z :=
    eq.trans h₁ h₂

  theorem baz : x = x := rfl

  #check @foo
  #check @bar
  #check baz
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Godel numbering for partial recursive functions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.computability.partrec
import Mathlib.PostPort

universes l u_1 u_2

namespace Mathlib

namespace nat.partrec

theorem rfind' {f : ℕ →. ℕ} (hf : partrec f) : partrec
  (unpaired
    fun (a m : ℕ) =>
      roption.map (fun (_x : ℕ) => _x + m)
        (rfind fun (n : ℕ) => (fun (m : ℕ) => to_bool (m = 0)) <$> f (mkpair a (n + m)))) := sorry

inductive code
where
| zero : code
| succ : code
| left : code
| right : code
| pair : code → code → code
| comp : code → code → code
| prec : code → code → code
| rfind' : code → code

end nat.partrec

namespace nat.partrec.code

protected instance inhabited : Inhabited code :=
  { default := zero }

protected def const : ℕ → code :=
  sorry

theorem const_inj {n₁ : ℕ} {n₂ : ℕ} : code.const n₁ = code.const n₂ → n₁ = n₂ := sorry

protected def id : code :=
  pair left right

def curry (c : code) (n : ℕ) : code :=
  comp c (pair (code.const n) code.id)

def encode_code : code → ℕ :=
  sorry

def of_nat_code : ℕ → code :=
  sorry

protected instance denumerable : denumerable code :=
  denumerable.mk' (equiv.mk encode_code of_nat_code sorry encode_of_nat_code)

theorem encode_code_eq : encodable.encode = encode_code :=
  rfl

theorem of_nat_code_eq : denumerable.of_nat code = of_nat_code :=
  rfl

theorem encode_lt_pair (cf : code) (cg : code) : encodable.encode cf < encodable.encode (pair cf cg) ∧ encodable.encode cg < encodable.encode (pair cf cg) := sorry

theorem encode_lt_comp (cf : code) (cg : code) : encodable.encode cf < encodable.encode (comp cf cg) ∧ encodable.encode cg < encodable.encode (comp cf cg) := sorry

theorem encode_lt_prec (cf : code) (cg : code) : encodable.encode cf < encodable.encode (prec cf cg) ∧ encodable.encode cg < encodable.encode (prec cf cg) := sorry

theorem encode_lt_rfind' (cf : code) : encodable.encode cf < encodable.encode (rfind' cf) := sorry

theorem pair_prim : primrec₂ pair := sorry

theorem comp_prim : primrec₂ comp := sorry

theorem prec_prim : primrec₂ prec := sorry

theorem rfind_prim : primrec rfind' := sorry

theorem rec_prim' {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code} (hc : primrec c) {z : α → σ} (hz : primrec z) {s : α → σ} (hs : primrec s) {l : α → σ} (hl : primrec l) {r : α → σ} (hr : primrec r) {pr : α → code × code × σ × σ → σ} (hpr : primrec₂ pr) {co : α → code × code × σ × σ → σ} (hco : primrec₂ co) {pc : α → code × code × σ × σ → σ} (hpc : primrec₂ pc) {rf : α → code × σ → σ} (hrf : primrec₂ rf) : let PR : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => pr a (cf, cg, hf, hg);
let CO : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => co a (cf, cg, hf, hg);
let PC : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => pc a (cf, cg, hf, hg);
let RF : α → code → σ → σ := fun (a : α) (cf : code) (hf : σ) => rf a (cf, hf);
let F : α → code → σ := fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a);
primrec fun (a : α) => F a (c a) := sorry

theorem rec_prim {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code} (hc : primrec c) {z : α → σ} (hz : primrec z) {s : α → σ} (hs : primrec s) {l : α → σ} (hl : primrec l) {r : α → σ} (hr : primrec r) {pr : α → code → code → σ → σ → σ} (hpr : primrec
  fun (a : α × code × code × σ × σ) =>
    pr (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
      (prod.fst (prod.snd (prod.snd (prod.snd a)))) (prod.snd (prod.snd (prod.snd (prod.snd a))))) {co : α → code → code → σ → σ → σ} (hco : primrec
  fun (a : α × code × code × σ × σ) =>
    co (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
      (prod.fst (prod.snd (prod.snd (prod.snd a)))) (prod.snd (prod.snd (prod.snd (prod.snd a))))) {pc : α → code → code → σ → σ → σ} (hpc : primrec
  fun (a : α × code × code × σ × σ) =>
    pc (prod.fst a) (prod.fst (prod.snd a)) (prod.fst (prod.snd (prod.snd a)))
      (prod.fst (prod.snd (prod.snd (prod.snd a)))) (prod.snd (prod.snd (prod.snd (prod.snd a))))) {rf : α → code → σ → σ} (hrf : primrec fun (a : α × code × σ) => rf (prod.fst a) (prod.fst (prod.snd a)) (prod.snd (prod.snd a))) : let F : α → code → σ := fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (pr a) (co a) (pc a) (rf a);
primrec fun (a : α) => F a (c a) := sorry

/- TODO(Mario): less copy-paste from previous proof -/

theorem rec_computable {α : Type u_1} {σ : Type u_2} [primcodable α] [primcodable σ] {c : α → code} (hc : computable c) {z : α → σ} (hz : computable z) {s : α → σ} (hs : computable s) {l : α → σ} (hl : computable l) {r : α → σ} (hr : computable r) {pr : α → code × code × σ × σ → σ} (hpr : computable₂ pr) {co : α → code × code × σ × σ → σ} (hco : computable₂ co) {pc : α → code × code × σ × σ → σ} (hpc : computable₂ pc) {rf : α → code × σ → σ} (hrf : computable₂ rf) : let PR : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => pr a (cf, cg, hf, hg);
let CO : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => co a (cf, cg, hf, hg);
let PC : α → code → code → σ → σ → σ := fun (a : α) (cf cg : code) (hf hg : σ) => pc a (cf, cg, hf, hg);
let RF : α → code → σ → σ := fun (a : α) (cf : code) (hf : σ) => rf a (cf, hf);
let F : α → code → σ := fun (a : α) (c : code) => code.rec_on c (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a);
computable fun (a : α) => F a (c a) := sorry

def eval : code → ℕ →. ℕ :=
  sorry

protected instance has_mem : has_mem (ℕ →. ℕ) code :=
  has_mem.mk fun (f : ℕ →. ℕ) (c : code) => eval c = f

@[simp] theorem eval_const (n : ℕ) (m : ℕ) : eval (code.const n) m = roption.some n := sorry

@[simp] theorem eval_id (n : ℕ) : eval code.id n = roption.some n := sorry

@[simp] theorem eval_curry (c : code) (n : ℕ) (x : ℕ) : eval (curry c n) x = eval c (mkpair n x) := sorry

theorem const_prim : primrec code.const := sorry

theorem curry_prim : primrec₂ curry :=
  primrec₂.comp comp_prim primrec.fst
    (primrec₂.comp pair_prim (primrec.comp const_prim primrec.snd) (primrec.const code.id))

theorem curry_inj {c₁ : code} {c₂ : code} {n₁ : ℕ} {n₂ : ℕ} (h : curry c₁ n₁ = curry c₂ n₂) : c₁ = c₂ ∧ n₁ = n₂ := sorry

theorem smn : ∃ (f : code → ℕ → code), computable₂ f ∧ ∀ (c : code) (n x : ℕ), eval (f c n) x = eval c (mkpair n x) :=
  Exists.intro curry { left := primrec₂.to_comp curry_prim, right := eval_curry }

theorem exists_code {f : ℕ →. ℕ} : partrec f ↔ ∃ (c : code), eval c = f := sorry

def evaln (k : ℕ) : code → ℕ → Option ℕ :=
  sorry

theorem evaln_bound {k : ℕ} {c : code} {n : ℕ} {x : ℕ} : x ∈ evaln k c n → n < k := sorry

theorem evaln_mono {k₁ : ℕ} {k₂ : ℕ} {c : code} {n : ℕ} {x : ℕ} : k₁ ≤ k₂ → x ∈ evaln k₁ c n → x ∈ evaln k₂ c n := sorry

theorem evaln_sound {k : ℕ} {c : code} {n : ℕ} {x : ℕ} : x ∈ evaln k c n → x ∈ eval c n := sorry

theorem evaln_complete {c : code} {n : ℕ} {x : ℕ} : x ∈ eval c n ↔ ∃ (k : ℕ), x ∈ evaln k c n := sorry

theorem evaln_prim : primrec fun (a : (ℕ × code) × ℕ) => evaln (prod.fst (prod.fst a)) (prod.snd (prod.fst a)) (prod.snd a) := sorry

theorem eval_eq_rfind_opt (c : code) (n : ℕ) : eval c n = rfind_opt fun (k : ℕ) => evaln k c n :=
  roption.ext
    fun (x : ℕ) => iff.trans evaln_complete (iff.symm (rfind_opt_mono fun (a m n_1 : ℕ) (hl : m ≤ n_1) => evaln_mono hl))

theorem eval_part : partrec₂ eval := sorry

theorem fixed_point {f : code → code} (hf : computable f) : ∃ (c : code), eval (f c) = eval c := sorry

theorem fixed_point₂ {f : code → ℕ →. ℕ} (hf : partrec₂ f) : ∃ (c : code), eval c = f c := sorry


import main_induction_step
import for_mathlib.base_change
import for_mathlib.basis
import for_mathlib.duality

.

open_locale tensor_product
open_locale classical

variables (K F : Type*) [field K] [field F]

open module

abbreviation mul_base_change := F ⊗[ℤ] additive Kˣ

variables {K F}

def units.as (x : Kˣ) : mul_base_change K F :=
1 ⊗ₜ additive.of_mul x

namespace units

@[simp]
lemma as_mul (u v : Kˣ) : ((u * v).as : mul_base_change K F) = u.as + v.as :=
tensor_product.tmul_add _ _ _

@[simp]
lemma as_one : ((1 : Kˣ).as : mul_base_change K F) = 0 :=
tensor_product.tmul_zero _ _

@[simp]
lemma as_inv (u : Kˣ) : (u⁻¹.as : mul_base_change K F) = - u.as :=
tensor_product.tmul_neg _ _

lemma as_div (u v : Kˣ) : ((u / v).as : mul_base_change K F) = u.as - v.as :=
tensor_product.tmul_sub _ _ _

end units

namespace submodule

def restrict (T : submodule F (mul_base_change K F)) :
  subgroup Kˣ :=
{ carrier := { u | u.as ∈ T },
  mul_mem' := λ u v hu hv, begin
    dsimp at hu hv ⊢,
    rw units.as_mul,
    apply T.add_mem hu hv,
  end,
  one_mem' := begin
    dsimp, rw units.as_one, exact T.zero_mem,
  end,
  inv_mem' := begin
    intros u hu,
    dsimp at hu ⊢,
    rw units.as_inv,
    apply T.neg_mem hu,
  end }

--instance : topological_space (dual F (mul_base_change K F)) :=
--module.dual.pointwise_convergence_topology

structure acl (H : submodule F (dual F (mul_base_change K F))) : Prop :=
(closed : H.closed)
(alternating :
  ∀ (u v : Kˣ) (h : (u : K) + v = 1) (f g : dual F (mul_base_change K F))
    (hf : f ∈ H) (hg : g ∈ H), f u.as * g v.as = f v.as * g u.as)
(neg_one : ∀ (f : dual F (mul_base_change K F)) (hf : f ∈ H), f ((-1 : Kˣ).as) = 0)

noncomputable theory

lemma neg_one_mem_of_acl (H : submodule F (dual F (mul_base_change K F))) (h : H.acl) :
  (-1 : Kˣ).as ∈ H.dual_annihilator_comap :=
begin
  rw mem_dual_annihilator_comap_iff,
  intros f hf,
  apply h.neg_one _ hf,
end

lemma dependent_of_acl (H : submodule F (dual F (mul_base_change K F))) (h : H.acl)
  (u v : Kˣ) (huv : (u : K) + v = 1) :
  ¬ linear_independent F
    ![H.dual_annihilator_comap.mkq u.as,
      H.dual_annihilator_comap.mkq v.as] :=
begin
  --let T := H.dual_annihilator_comap
  let e := ![(H.dual_annihilator_comap.mkq) u.as,
    (H.dual_annihilator_comap.mkq) v.as],
  let E := equiv_to_dual_mod_of_is_closed H h.1,
  intro c,
  let β := basis.sum_extend c,
  let f : dual F _ := β.coord (sum.inl 0),
  let g : dual F _ := β.coord (sum.inl 1),
  let f' := E.symm f,
  let g' := E.symm g,
  have HH := h.2 u v huv f' g' f'.2 g'.2,
  dsimp only [f',g', E] at HH,
  simp only [equiv_to_dual_mod_of_is_closed_symm_apply_apply H h.1] at HH,
  have he0 : e 0 = (H.dual_annihilator_comap.mkq u.as) := rfl,
  have he1 : e 1 = (H.dual_annihilator_comap.mkq v.as) := rfl,
  simp only [← he0, ← he1] at HH,
  dsimp only [e,f,g,β] at HH,
  simp only [
      ← basis.sum_extend_extends _ c 0,
      ← basis.sum_extend_extends _ c 1] at HH,
  dsimp at HH,
  simp only [basis.repr_self, finsupp.single_apply] at HH,
  simp_rw [if_pos rfl] at HH,
  rw [if_neg, if_neg] at HH,
  { apply (one_ne_zero : (1 : F) ≠ 0),
    simpa using HH },
  all_goals { norm_num }
end

end submodule


import SciLean.Data.Quotient.GradedSetoid

namespace SciLean

def GradedQuotient (α : Type u) {Lvl : Type v} [BoundedLattice Lvl] [GradedSetoid α Lvl] (maxLvl : Lvl := ⊤)
  := Quotient (instSetoidGradedSetoidRepr α maxLvl)

namespace GradedQuotient

  variable {α : Type u} {Lvl : Type v} [BoundedLattice Lvl] [inst : GradedSetoid α Lvl] [∀ l l' : Lvl, Decidable (l ≤ l')]

  notation " ⟦ " lvl " | " x " ⟧ " => ⟦GradedSetoid.reduceToLvl lvl x⟧

  noncomputable
  def repr (a : GradedQuotient α maxLvl) : α := (Quotient.repr a).1

  @[simp high]
  theorem repr_quotient (a : GradedQuotient α maxLvl) [GradedSetoid.Reduce α maxLvl]
    : ⟦maxLvl| a.repr⟧ = a
    := sorry_proof

  def ungraded (a : GradedQuotient α maxLvl) := a.liftOn (λ a => ⟦a.1⟧) sorry_proof

  @[simp high]
  theorem repr_ungraded (a : GradedQuotient α maxLvl)
    : ⟦a.repr⟧ = a.ungraded
    := sorry_proof

  noncomputable
  def grepr (a : GradedQuotient α maxLvl) : GradedSetoid.Repr α maxLvl := Quotient.repr a

  @[simp high]
  theorem grepr_quotient (a : GradedQuotient α maxLvl)
    : ⟦a.grepr⟧ = a
    := sorry_proof

  noncomputable
  def lvl (a : GradedQuotient α maxLvl) : Lvl := (Quotient.repr a).2

  def reduce (lvl : Lvl) [GradedSetoid.Reduce α (lvl ⊓ maxLvl)] (a : GradedQuotient α maxLvl) : GradedQuotient α maxLvl
    := ⟦a.grepr.reduce lvl⟧ rewrite_by simp

  /-- Reduction on quotient does nothing, it only changes the internal representation -/
  theorem reduce_identity (a : GradedQuotient α maxLvl) (lvl : Lvl) [GradedSetoid.Reduce α (lvl ⊓ maxLvl)]
    : a.reduce lvl = a := sorry_proof

  def normalize [inst : GradedSetoid.Reduce α ⊥] (a : GradedQuotient α maxLvl) : GradedQuotient α maxLvl :=
    have h :  ⊥ = (⊥ ⊓ maxLvl : Lvl) := sorry_proof
    have : GradedSetoid.Reduce α (⊥ ⊓ maxLvl) := h ▸ inst
    a.reduce ⊥

  def nrepr [inst : GradedSetoid.Reduce α ⊥] (a : GradedQuotient α maxLvl) : α :=
    a.liftOn (λ a => a.normalize.1) sorry_proof

  @[simp]
  theorem nrepr_quotient_mk [inst : GradedSetoid.Reduce α ⊥] (a : GradedQuotient α maxLvl)
    : ⟦a.nrepr⟧ = a.ungraded
  := sorry_proof

  @[simp]
  theorem nrepr_graded_quotient_mk [GradedSetoid.Reduce α ⊥] [GradedSetoid.Reduce α maxLvl] (a : GradedQuotient α maxLvl)
    : ⟦maxLvl| a.nrepr⟧ = a
  := sorry_proof

  variable {β : Type w} [GradedSetoid β Lvl]

  @[simp high]
  theorem lift_graded_morphism
    {Lvl : Type u'} [BoundedLattice Lvl] {lvl : Lvl}
    {α : Type u} [GradedSetoid α Lvl] [GradedSetoid.Reduce α lvl]
    {β : Type v} [GradedSetoid β Lvl] [GradedSetoid.Reduce β lvl]
    (f : α → β) [GradedSetoid.Morphism f]
    (x : α)
    : ⟦lvl| f x⟧ = Quotient.lift (λ (a : GradedSetoid.Repr α lvl) => ⟦GradedSetoid.Repr.mk (f a.1) a.2 sorry_proof sorry_proof⟧) sorry_proof ⟦lvl| x⟧
    := sorry_proof

  @[simp]
  theorem lift_graded_morphism₂
    {Lvl : Type u'} {lvl : Lvl} [BoundedLattice Lvl]
    {α : Type u} [GradedSetoid α Lvl] [GradedSetoid.Reduce α lvl]
    {β : Type v} [GradedSetoid β Lvl] [GradedSetoid.Reduce β lvl]
    {γ : Type v} [GradedSetoid γ Lvl] [GradedSetoid.Reduce γ lvl]
    (f : α → β → γ) [GradedSetoid.Morphism₂ f]
    (x : α) (y : β)
    : ⟦lvl| f x y⟧ = Quotient.lift₂ (λ (x : GradedSetoid.Repr α lvl) (y : GradedSetoid.Repr β lvl) => ⟦GradedSetoid.Repr.mk (f x.1 y.1) x.2 sorry_proof x.4⟧) sorry_proof ⟦lvl| x⟧ ⟦lvl| y⟧
    := sorry_proof

end GradedQuotient


/-
Copyright (c) 2021 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou, Adam Topaz, Johan Commelin
-/

import algebra.homology.additive
import algebraic_topology.Moore_complex
import data.fintype.card

/-!

# The alternating face map complex of a simplicial object in a preadditive category

We construct the alternating face map complex, as a
functor `alternating_face_map_complex : simplicial_object C ⥤ chain_complex C ℕ`
for any preadditive category `C`. For any simplicial object `X` in `C`,
this is the homological complex `... → X_2 → X_1 → X_0`
where the differentials are alternating sums of faces.

We also construct the natural transformation
`inclusion_of_Moore_complex : normalized_Moore_complex A ⟶ alternating_face_map_complex A`
when `A` is an abelian category.

## References
* https://stacks.math.columbia.edu/tag/0194
* https://ncatlab.org/nlab/show/Moore+complex

-/

open category_theory category_theory.limits category_theory.subobject
open category_theory.preadditive category_theory.category
open opposite

open_locale big_operators
open_locale simplicial

noncomputable theory

namespace algebraic_topology

namespace alternating_face_map_complex

/-!
## Construction of the alternating face map complex
-/

variables {C : Type*} [category C] [preadditive C]
variables (X : simplicial_object C)
variables (Y : simplicial_object C)

/-- The differential on the alternating face map complex is the alternate
sum of the face maps -/
@[simp]
def obj_d (n : ℕ) : X _[n+1] ⟶ X _[n] :=
∑ (i : fin (n+2)), (-1 : ℤ)^(i : ℕ) • X.δ i

/--
## The chain complex relation `d ≫ d`
-/
lemma d_squared (n : ℕ) : obj_d X (n+1) ≫ obj_d X n = 0 :=
begin
  /- we start by expanding d ≫ d as a double sum -/
  dsimp,
  rw comp_sum,
  let d_l := λ (j : fin (n+3)), (-1 : ℤ)^(j : ℕ) • X.δ j,
  let d_r := λ (i : fin (n+2)), (-1 : ℤ)^(i : ℕ) • X.δ i,
  rw [show (λ i , (∑ j : fin (n+3), d_l j) ≫ d_r i) =
    (λ i, ∑ j : fin (n+3), (d_l j ≫ d_r i)), by { ext i, rw sum_comp, }],
  rw ← finset.sum_product',
  /- then, we decompose the index set P into a subet S and its complement Sᶜ -/
  let P := fin (n+2) × fin (n+3),
  let S := finset.univ.filter (λ (ij : P), (ij.2 : ℕ) ≤ (ij.1 : ℕ)),
  let term := λ (ij : P), d_l ij.2 ≫ d_r ij.1,
  erw [show ∑ (ij : P), term ij =
    (∑ ij in S, term ij) + (∑ ij in Sᶜ, term ij), by rw finset.sum_add_sum_compl],
  rw [← eq_neg_iff_add_eq_zero, ← finset.sum_neg_distrib],
  /- we are reduced to showing that two sums are equal, and this is obtained
  by constructing a bijection φ : S -> Sᶜ, which maps (i,j) to (j,i+1),
  and by comparing the terms -/
  let φ : Π (ij : P), ij ∈ S → P := λ ij hij,
    (fin.cast_lt ij.2
      (lt_of_le_of_lt (finset.mem_filter.mp hij).right (fin.is_lt ij.1)), ij.1.succ),
  apply finset.sum_bij φ,
  { -- φ(S) is contained in Sᶜ
    intros ij hij,
    simp only [finset.mem_univ, finset.compl_filter, finset.mem_filter, true_and,
      fin.coe_succ, fin.coe_cast_lt] at hij ⊢,
    linarith, },
  { /- identification of corresponding terms in both sums -/
    rintro ⟨i, j⟩ hij,
    simp only [term, d_l, d_r, φ, comp_zsmul, zsmul_comp, ← neg_smul, ← mul_smul,
      pow_add, neg_mul, mul_one, fin.coe_cast_lt,
      fin.coe_succ, pow_one, mul_neg, neg_neg],
    let jj : fin (n+2) := (φ (i,j) hij).1,
    have ineq : jj ≤ i, { rw ← fin.coe_fin_le, simpa using hij, },
    rw [category_theory.simplicial_object.δ_comp_δ X ineq, fin.cast_succ_cast_lt, mul_comm] },
  { -- φ : S → Sᶜ is injective
    rintro ⟨i, j⟩ ⟨i', j'⟩ hij hij' h,
    rw [prod.mk.inj_iff],
    refine ⟨by simpa using congr_arg prod.snd h, _⟩,
    have h1 := congr_arg fin.cast_succ (congr_arg prod.fst h),
    simpa [fin.cast_succ_cast_lt] using h1 },
  { -- φ : S → Sᶜ is surjective
    rintro ⟨i', j'⟩ hij',
    simp only [true_and, finset.mem_univ, finset.compl_filter, not_le,
      finset.mem_filter] at hij',
    refine ⟨(j'.pred _, fin.cast_succ i'), _, _⟩,
    { intro H,
      simpa only [H, nat.not_lt_zero, fin.coe_zero] using hij' },
    { simpa only [true_and, finset.mem_univ, fin.coe_cast_succ, fin.coe_pred,
        finset.mem_filter] using nat.le_pred_of_lt hij', },
    { simp only [prod.mk.inj_iff, fin.succ_pred, fin.cast_lt_cast_succ],
      split; refl }, },
end

/-!
## Construction of the alternating face map complex functor
-/

/-- The alternating face map complex, on objects -/
def obj : chain_complex C ℕ := chain_complex.of (λ n, X _[n]) (obj_d X) (d_squared X)

variables {X} {Y}

/-- The alternating face map complex, on morphisms -/
@[simp]
def map (f : X ⟶ Y) : obj X ⟶ obj Y :=
chain_complex.of_hom _ _ _ _ _ _
  (λ n, f.app (op [n]))
  (λ n,
    begin
      dsimp,
      rw [comp_sum, sum_comp],
      apply finset.sum_congr rfl (λ x h, _),
      rw [comp_zsmul, zsmul_comp],
      apply congr_arg,
      erw f.naturality,
      refl,
    end)

end alternating_face_map_complex

variables (C : Type*) [category C] [preadditive C]

/-- The alternating face map complex, as a functor -/
@[simps]
def alternating_face_map_complex : simplicial_object C ⥤ chain_complex C ℕ :=
{ obj := alternating_face_map_complex.obj,
  map := λ X Y f, alternating_face_map_complex.map f }

variables {C}

lemma map_alternating_face_map_complex {D : Type*} [category D] [preadditive D]
  (F : C ⥤ D) [F.additive] :
  alternating_face_map_complex C ⋙ F.map_homological_complex _ =
  (simplicial_object.whiskering C D).obj F ⋙ alternating_face_map_complex D :=
begin
  apply category_theory.functor.ext,
  { intros X Y f,
    ext n,
    simp only [functor.comp_map, alternating_face_map_complex.map,
      alternating_face_map_complex_map, functor.map_homological_complex_map_f,
      chain_complex.of_hom_f, simplicial_object.whiskering_obj_map_app,
      homological_complex.comp_f, homological_complex.eq_to_hom_f,
      eq_to_hom_refl, comp_id, id_comp], },
  { intro X,
    erw chain_complex.map_chain_complex_of,
    congr,
    ext n,
    simp only [alternating_face_map_complex.obj_d, functor.map_sum],
    congr,
    ext,
    apply functor.map_zsmul, },
end

/-!
## Construction of the natural inclusion of the normalized Moore complex
-/

variables {A : Type*} [category A] [abelian A]

/-- The inclusion map of the Moore complex in the alternating face map complex -/
def inclusion_of_Moore_complex_map (X : simplicial_object A) :
  (normalized_Moore_complex A).obj X ⟶ (alternating_face_map_complex A).obj X :=
chain_complex.of_hom _ _ _ _ _ _
  (λ n, (normalized_Moore_complex.obj_X X n).arrow)
  (λ n,
    begin
      /- we have to show the compatibility of the differentials on the alternating
         face map complex with those defined on the normalized Moore complex:
         we first get rid of the terms of the alternating sum that are obviously
         zero on the normalized_Moore_complex -/
      simp only [alternating_face_map_complex.obj_d],
      rw comp_sum,
      let t := λ (j : fin (n+2)), (normalized_Moore_complex.obj_X X (n+1)).arrow ≫
        ((-1 : ℤ)^(j : ℕ) • X.δ j),
      have def_t : (∀ j : fin (n+2), t j = (normalized_Moore_complex.obj_X X (n+1)).arrow ≫
        ((-1 : ℤ)^(j : ℕ) • X.δ j)) := by { intro j, refl, },
      rw [fin.sum_univ_succ t],
      have null : ∀ j : fin (n+1), t j.succ = 0,
      { intro j,
        rw [def_t, comp_zsmul, ← zsmul_zero ((-1 : ℤ)^(j.succ : ℕ))],
        apply congr_arg,
        rw normalized_Moore_complex.obj_X,
        rw ← factor_thru_arrow _ _
          (finset_inf_arrow_factors finset.univ _ j (by simp only [finset.mem_univ])),
        slice_lhs 2 3 { erw kernel_subobject_arrow_comp (X.δ j.succ), },
        simp only [comp_zero], },
      rw [fintype.sum_eq_zero _ null],
      simp only [add_zero],
      /- finally, we study the remaining term which is induced by X.δ 0 -/
      let eq := def_t 0,
      rw [show (-1 : ℤ)^((0 : fin (n+2)) : ℕ) = 1, by ring] at eq,
      rw one_smul at eq,
      rw eq,
      cases n; dsimp; simp,
    end)

@[simp]

variables (A)

/-- The inclusion map of the Moore complex in the alternating face map complex,
as a natural transformation -/
@[simps]
def inclusion_of_Moore_complex :
  (normalized_Moore_complex A) ⟶ (alternating_face_map_complex A) :=
{ app := inclusion_of_Moore_complex_map, }

end algebraic_topology


/-
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
-/
import category_theory.subobject.mono_over
import category_theory.skeletal
import category_theory.concrete_category.basic
import tactic.apply_fun
import tactic.elementwise

/-!
# Subobjects

We define `subobject X` as the quotient (by isomorphisms) of
`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 a partial order.

There is a coercion from `subobject X` back to the ambient category `C`
(using choice to pick a representative), and for `P : subobject X`,
`P.arrow : (P : C) ⟶ X` is the inclusion morphism.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : subobject Y ⥤ subobject X`
* `def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : subobject X ⥤ subobject Y`
and prove their basic properties and relationships.
These are all easy consequences of the earlier development
of the corresponding functors for `mono_over`.

The subobjects of `X` form a preorder making them into a category. We have `X ≤ Y` if and only if
`X.arrow` factors through `Y.arrow`: see `of_le`/`of_le_mk`/`of_mk_le`/`of_mk_le_mk` and
`le_of_comm`. Similarly, to show that two subobjects are equal, we can supply an isomorphism between
the underlying objects that commutes with the arrows (`eq_of_comm`).

See also

* `category_theory.subobject.factor_thru` :
  an API describing factorization of morphisms through subobjects.
* `category_theory.subobject.lattice` :
  the lattice structures on subobjects.

## Notes

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

### Implementation note

Currently we describe `pullback`, `map`, etc., as functors.
It may be better to just say that they are monotone functions,
and even avoid using categorical language entirely when describing `subobject X`.
(It's worth keeping this in mind in future use; it should be a relatively easy change here
if it looks preferable.)

### Relation to pseudoelements

There is a separate development of pseudoelements in `category_theory.abelian.pseudoelements`,
as a quotient (but not by isomorphism) of `over X`.

When a morphism `f` has an image, the image represents the same pseudoelement.
In a category with images `pseudoelements X` could be constructed as a quotient of `mono_over X`.
In fact, in an abelian category (I'm not sure in what generality beyond that),
`pseudoelements X` agrees with `subobject X`, but we haven't developed this in mathlib yet.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/-!
We now construct the subobject lattice for `X : C`,
as the quotient by isomorphisms of `mono_over X`.

Since `mono_over X` is a thin category, we use `thin_skeleton` to take the quotient.

Essentially all the structure defined above on `mono_over X` descends to `subobject X`,
with morphisms becoming inequalities, and isomorphisms becoming equations.
-/

/--
The category of subobjects of `X : C`, defined as isomorphism classes of monomorphisms into `X`.
-/
@[derive [partial_order, category]]
def subobject (X : C) := thin_skeleton (mono_over X)

namespace subobject

/-- Convenience constructor for a subobject. -/
abbreviation mk {X A : C} (f : A ⟶ X) [mono f] : subobject X :=
(to_thin_skeleton _).obj (mono_over.mk' f)

section
local attribute [ext] category_theory.comma

protected lemma ind {X : C} (p : subobject X → Prop)
  (h : ∀ ⦃A : C⦄ (f : A ⟶ X) [mono f], by exactI p (subobject.mk f)) (P : subobject X) : p P :=
begin
  apply quotient.induction_on',
  intro a,
  convert h a.arrow,
  ext; refl
end

protected lemma ind₂ {X : C} (p : subobject X → subobject X → Prop)
  (h : ∀ ⦃A B : C⦄ (f : A ⟶ X) (g : B ⟶ X) [mono f] [mono g],
    by exactI p (subobject.mk f) (subobject.mk g)) (P Q : subobject X) : p P Q :=
begin
  apply quotient.induction_on₂',
  intros a b,
  convert h a.arrow b.arrow;
  ext; refl
end

end

/-- Declare a function on subobjects of `X` by specifying a function on monomorphisms with
    codomain `X`. -/
protected def lift {α : Sort*} {X : C} (F : Π ⦃A : C⦄ (f : A ⟶ X) [mono f], α)
  (h : ∀ ⦃A B : C⦄ (f : A ⟶ X) (g : B ⟶ X) [mono f] [mono g] (i : A ≅ B),
    i.hom ≫ g = f → by exactI F f = F g) : subobject X → α :=
λ P, quotient.lift_on' P (λ m, by exactI F m.arrow) $ λ m n ⟨i⟩,
  h m.arrow n.arrow ((mono_over.forget X ⋙ over.forget X).map_iso i) (over.w i.hom)

@[simp]
protected lemma lift_mk {α : Sort*} {X : C} (F : Π ⦃A : C⦄ (f : A ⟶ X) [mono f], α) {h A}
  (f : A ⟶ X) [mono f] : subobject.lift F h (subobject.mk f) = F f :=
rfl

/-- The category of subobjects is equivalent to the `mono_over` category. It is more convenient to
use the former due to the partial order instance, but oftentimes it is easier to define structures
on the latter. -/
noncomputable def equiv_mono_over (X : C) : subobject X ≌ mono_over X :=
thin_skeleton.equivalence _

/--
Use choice to pick a representative `mono_over X` for each `subobject X`.
-/
noncomputable
def representative {X : C} : subobject X ⥤ mono_over X :=
(equiv_mono_over X).functor

/--
Starting with `A : mono_over X`, we can take its equivalence class in `subobject X`
then pick an arbitrary representative using `representative.obj`.
This is isomorphic (in `mono_over X`) to the original `A`.
-/
noncomputable
def representative_iso {X : C} (A : mono_over X) :
  representative.obj ((to_thin_skeleton _).obj A) ≅ A :=
(equiv_mono_over X).counit_iso.app A

/--
Use choice to pick a representative underlying object in `C` for any `subobject X`.

Prefer to use the coercion `P : C` rather than explicitly writing `underlying.obj P`.
-/
noncomputable
def underlying {X : C} : subobject X ⥤ C :=
representative ⋙ mono_over.forget _ ⋙ over.forget _

instance : has_coe (subobject X) C :=
{ coe := λ Y, underlying.obj Y, }

@[simp] lemma underlying_as_coe {X : C} (P : subobject X) : underlying.obj P = P := rfl

/--
If we construct a `subobject Y` from an explicit `f : X ⟶ Y` with `[mono f]`,
then pick an arbitrary choice of underlying object `(subobject.mk f : C)` back in `C`,
it is isomorphic (in `C`) to the original `X`.
-/
noncomputable
def underlying_iso {X Y : C} (f : X ⟶ Y) [mono f] : (subobject.mk f : C) ≅ X :=
(mono_over.forget _ ⋙ over.forget _).map_iso (representative_iso (mono_over.mk' f))

/--
The morphism in `C` from the arbitrarily chosen underlying object to the ambient object.
-/
noncomputable
def arrow {X : C} (Y : subobject X) : (Y : C) ⟶ X :=
(representative.obj Y).obj.hom

instance arrow_mono {X : C} (Y : subobject X) : mono (Y.arrow) :=
(representative.obj Y).property

@[simp]
lemma arrow_congr {A : C} (X Y : subobject A) (h : X = Y) :
  eq_to_hom (congr_arg (λ X : subobject A, (X : C)) h) ≫ Y.arrow = X.arrow :=
by { induction h, simp, }

@[simp]
lemma representative_coe (Y : subobject X) :
  (representative.obj Y : C) = (Y : C) :=
rfl

@[simp]
lemma representative_arrow (Y : subobject X) :
  (representative.obj Y).arrow = Y.arrow :=
rfl

@[simp, reassoc]
lemma underlying_arrow {X : C} {Y Z : subobject X} (f : Y ⟶ Z) :
  underlying.map f ≫ arrow Z = arrow Y :=
over.w (representative.map f)

@[simp, reassoc, elementwise]
lemma underlying_iso_arrow {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).inv ≫ (subobject.mk f).arrow = f :=
over.w _

@[simp, reassoc]
lemma underlying_iso_hom_comp_eq_mk {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).hom ≫ f = (mk f).arrow :=
(iso.eq_inv_comp _).1 (underlying_iso_arrow f).symm

/-- Two morphisms into a subobject are equal exactly if
the morphisms into the ambient object are equal -/
@[ext]
lemma eq_of_comp_arrow_eq {X Y : C} {P : subobject Y}
  {f g : X ⟶ P} (h : f ≫ P.arrow = g ≫ P.arrow) : f = g :=
(cancel_mono P.arrow).mp h

lemma mk_le_mk_of_comm {B A₁ A₂ : C} {f₁ : A₁ ⟶ B} {f₂ : A₂ ⟶ B} [mono f₁] [mono f₂] (g : A₁ ⟶ A₂)
  (w : g ≫ f₂ = f₁) : mk f₁ ≤ mk f₂ :=
⟨mono_over.hom_mk _ w⟩

@[simp] lemma mk_arrow (P : subobject X) : mk P.arrow = P :=
quotient.induction_on' P $ λ Q,
begin
  obtain ⟨e⟩ := @quotient.mk_out' _ (is_isomorphic_setoid _) Q,
  refine quotient.sound' ⟨mono_over.iso_mk _ _ ≪≫ e⟩;
  tidy
end

lemma le_of_comm {B : C} {X Y : subobject B} (f : (X : C) ⟶ (Y : C)) (w : f ≫ Y.arrow = X.arrow) :
  X ≤ Y :=
by convert mk_le_mk_of_comm _ w; simp

lemma le_mk_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : (X : C) ⟶ A)
  (w : g ≫ f = X.arrow) : X ≤ mk f :=
le_of_comm (g ≫ (underlying_iso f).inv) $ by simp [w]

lemma mk_le_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : A ⟶ (X : C))
  (w : g ≫ X.arrow = f) : mk f ≤ X :=
le_of_comm ((underlying_iso f).hom ≫ g) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_of_comm {B : C} {X Y : subobject B} (f : (X : C) ≅ (Y : C))
  (w : f.hom ≫ Y.arrow = X.arrow) : X = Y :=
le_antisymm (le_of_comm f.hom w) $ le_of_comm f.inv $ f.inv_comp_eq.2 w.symm

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_mk_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : (X : C) ≅ A)
  (w : i.hom ≫ f = X.arrow) : X = mk f :=
eq_of_comm (i.trans (underlying_iso f).symm) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : A ≅ (X : C))
  (w : i.hom ≫ X.arrow = f) : mk f = X :=
eq.symm $ eq_mk_of_comm _ i.symm $ by rw [iso.symm_hom, iso.inv_comp_eq, w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_mk_of_comm {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g]
  (i : A₁ ≅ A₂) (w : i.hom ≫ g = f) : mk f = mk g :=
eq_mk_of_comm _ ((underlying_iso f).trans i) $ by simp [w]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
-- We make `X` and `Y` explicit arguments here so that when `of_le` appears in goal statements
-- it is possible to see its source and target
-- (`h` will just display as `_`, because it is in `Prop`).
def of_le {B : C} (X Y : subobject B) (h : X ≤ Y) : (X : C) ⟶ (Y : C) :=
underlying.map $ h.hom

@[simp, reassoc] lemma of_le_arrow {B : C} {X Y : subobject B} (h : X ≤ Y) :
  of_le X Y h ≫ Y.arrow = X.arrow :=
underlying_arrow _

instance {B : C} (X Y : subobject B) (h : X ≤ Y) : mono (of_le X Y h) :=
begin
  fsplit,
  intros Z f g w,
  replace w := w =≫ Y.arrow,
  ext,
  simpa using w,
end

lemma of_le_mk_le_mk_of_comm
  {B A₁ A₂ : C} {f₁ : A₁ ⟶ B} {f₂ : A₂ ⟶ B} [mono f₁] [mono f₂] (g : A₁ ⟶ A₂) (w : g ≫ f₂ = f₁) :
  of_le _ _ (mk_le_mk_of_comm g w) = (underlying_iso _).hom ≫ g ≫ (underlying_iso _).inv :=
by { ext, simp [w], }

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_le_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X ≤ mk f) : (X : C) ⟶ A :=
of_le X (mk f) h ≫ (underlying_iso f).hom

@[simp] lemma of_le_mk_comp {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (h : X ≤ mk f) :
  of_le_mk X f h ≫ f = X.arrow :=
by simp [of_le_mk]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_mk_le {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f ≤ X) : A ⟶ (X : C) :=
(underlying_iso f).inv ≫ of_le (mk f) X h

@[simp] lemma of_mk_le_arrow {B A : C} {f : A ⟶ B} [mono f] {X : subobject B} (h : mk f ≤ X) :
  of_mk_le f X h ≫ X.arrow = f :=
by simp [of_mk_le]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_mk_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f ≤ mk g) :
  A₁ ⟶ A₂ :=
(underlying_iso f).inv ≫ of_le (mk f) (mk g) h ≫ (underlying_iso g).hom

@[simp] lemma of_mk_le_mk_comp {B A₁ A₂ : C} {f : A₁ ⟶ B} {g : A₂ ⟶ B} [mono f] [mono g]
  (h : mk f ≤ mk g) : of_mk_le_mk f g h ≫ g = f :=
by simp [of_mk_le_mk]

@[simp, reassoc] lemma of_le_comp_of_le {B : C} (X Y Z : subobject B) (h₁ : X ≤ Y) (h₂ : Y ≤ Z) :
  of_le X Y h₁ ≫ of_le Y Z h₂ = of_le X Z (h₁.trans h₂) :=
by simp [of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_comp_of_le_mk {B A : C} (X Y : subobject B) (f : A ⟶ B) [mono f]
  (h₁ : X ≤ Y) (h₂ : Y ≤ mk f) : of_le X Y h₁ ≫ of_le_mk Y f h₂ = of_le_mk X f (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le {B A : C} (X : subobject B) (f : A ⟶ B) [mono f]
  (Y : subobject B) (h₁ : X ≤ mk f) (h₂ : mk f ≤ Y) :
  of_le_mk X f h₁ ≫ of_mk_le f Y h₂ = of_le X Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le_mk {B A₁ A₂ : C} (X : subobject B) (f : A₁ ⟶ B)
  [mono f] (g : A₂ ⟶ B) [mono g] (h₁ : X ≤ mk f) (h₂ : mk f ≤ mk g) :
  of_le_mk X f h₁ ≫ of_mk_le_mk f g h₂ = of_le_mk X g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le {B A₁ : C} (f : A₁ ⟶ B) [mono f] (X Y : subobject B)
  (h₁ : mk f ≤ X) (h₂ : X ≤ Y) :
  of_mk_le f X h₁ ≫ of_le X Y h₂ = of_mk_le f Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (X : subobject B)
  (g : A₂ ⟶ B) [mono g] (h₁ : mk f ≤ X) (h₂ : X ≤ mk g) :
  of_mk_le f X h₁ ≫ of_le_mk X g h₂ = of_mk_le_mk f g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (g : A₂ ⟶ B)
  [mono g] (X : subobject B) (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ X) :
  of_mk_le_mk f g h₁ ≫ of_mk_le g X h₂ = of_mk_le f X (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le_mk {B A₁ A₂ A₃ : C} (f : A₁ ⟶ B) [mono f]
  (g : A₂ ⟶ B) [mono g] (h : A₃ ⟶ B) [mono h] (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ mk h) :
  of_mk_le_mk f g h₁ ≫ of_mk_le_mk g h h₂ = of_mk_le_mk f h (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp] lemma of_le_refl {B : C} (X : subobject B) :
  of_le X X le_rfl = 𝟙 _ :=
by { apply (cancel_mono X.arrow).mp, simp }

@[simp] lemma of_mk_le_mk_refl {B A₁ : C} (f : A₁ ⟶ B) [mono f] :
  of_mk_le_mk f f le_rfl = 𝟙 _ :=
by { apply (cancel_mono f).mp, simp }

/-- An equality of subobjects gives an isomorphism of the corresponding objects.
(One could use `underlying.map_iso (eq_to_iso h))` here, but this is more readable.) -/
-- As with `of_le`, we have `X` and `Y` as explicit arguments for readability.
@[simps]
def iso_of_eq {B : C} (X Y : subobject B) (h : X = Y) : (X : C) ≅ (Y : C) :=
{ hom := of_le _ _ h.le,
  inv := of_le _ _ h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_eq_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X = mk f) : (X : C) ≅ A :=
{ hom := of_le_mk X f h.le,
  inv := of_mk_le f X h.ge }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f = X) : A ≅ (X : C) :=
{ hom := of_mk_le f X h.le,
  inv := of_le_mk X f h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f = mk g) :
  A₁ ≅ A₂ :=
{ hom := of_mk_le_mk f g h.le,
  inv := of_mk_le_mk g f h.ge, }

end subobject

open category_theory.limits

namespace subobject

/-- Any functor `mono_over X ⥤ mono_over Y` descends to a functor
`subobject X ⥤ subobject Y`, because `mono_over Y` is thin. -/
def lower {Y : D} (F : mono_over X ⥤ mono_over Y) : subobject X ⥤ subobject Y :=
thin_skeleton.map F

/-- Isomorphic functors become equal when lowered to `subobject`.
(It's not as evil as usual to talk about equality between functors
because the categories are thin and skeletal.) -/
lemma lower_iso (F₁ F₂ : mono_over X ⥤ mono_over Y) (h : F₁ ≅ F₂) :
  lower F₁ = lower F₂ :=
thin_skeleton.map_iso_eq h

/-- A ternary version of `subobject.lower`. -/
def lower₂ (F : mono_over X ⥤ mono_over Y ⥤ mono_over Z) :
  subobject X ⥤ subobject Y ⥤ subobject Z :=
thin_skeleton.map₂ F

@[simp]

/-- An adjunction between `mono_over A` and `mono_over B` gives an adjunction
between `subobject A` and `subobject B`. -/
def lower_adjunction {A : C} {B : D}
  {L : mono_over A ⥤ mono_over B} {R : mono_over B ⥤ mono_over A} (h : L ⊣ R) :
  lower L ⊣ lower R :=
thin_skeleton.lower_adjunction _ _ h

/-- An equivalence between `mono_over A` and `mono_over B` gives an equivalence
between `subobject A` and `subobject B`. -/
@[simps]
def lower_equivalence {A : C} {B : D} (e : mono_over A ≌ mono_over B) : subobject A ≌ subobject B :=
{ functor := lower e.functor,
  inverse := lower e.inverse,
  unit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.unit_iso,
    { exact thin_skeleton.map_id_eq.symm },
    { exact (thin_skeleton.map_comp_eq _ _).symm },
  end,
  counit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.counit_iso,
    { exact (thin_skeleton.map_comp_eq _ _).symm },
    { exact thin_skeleton.map_id_eq.symm },
  end }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `subobject Y ⥤ subobject X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : subobject Y ⥤ subobject X :=
lower (mono_over.pullback f)

lemma pullback_id (x : subobject X) : (pullback (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.pullback_id.app f⟩,
end

lemma pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) (x : subobject Z) :
  (pullback (f ≫ g)).obj x = (pullback f).obj ((pullback g).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.pullback_comp _ _).app t⟩,
end

instance (f : X ⟶ Y) : faithful (pullback f) := {}

end pullback

section map

/--
We can map subobjects of `X` to subobjects of `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y :=
lower (mono_over.map f)

lemma map_id (x : subobject X) : (map (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.map_id.app f⟩,
end

lemma map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] (x : subobject X) :
  (map (f ≫ g)).obj x = (map g).obj ((map f).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.map_comp _ _).app t⟩,
end

/-- Isomorphic objects have equivalent subobject lattices. -/
def map_iso {A B : C} (e : A ≅ B) : subobject A ≌ subobject B :=
lower_equivalence (mono_over.map_iso e)

/-- In fact, there's a type level bijection between the subobjects of isomorphic objects,
which preserves the order. -/
-- @[simps] here generates a lemma `map_iso_to_order_iso_to_equiv_symm_apply`
-- whose left hand side is not in simp normal form.
def map_iso_to_order_iso (e : X ≅ Y) : subobject X ≃o subobject Y :=
{ to_fun := (map e.hom).obj,
  inv_fun := (map e.inv).obj,
  left_inv := λ g, by simp_rw [← map_comp, e.hom_inv_id, map_id],
  right_inv := λ g, by simp_rw [← map_comp, e.inv_hom_id, map_id],
  map_rel_iff' := λ A B, begin
    dsimp, fsplit,
    { intro h,
      apply_fun (map e.inv).obj at h,
      simp_rw [← map_comp, e.hom_inv_id, map_id] at h,
      exact h, },
    { intro h,
      apply_fun (map e.hom).obj at h,
      exact h, },
  end }

@[simp] lemma map_iso_to_order_iso_apply (e : X ≅ Y) (P : subobject X) :
  map_iso_to_order_iso e P = (map e.hom).obj P :=
rfl

@[simp] lemma map_iso_to_order_iso_symm_apply (e : X ≅ Y) (Q : subobject Y) :
  (map_iso_to_order_iso e).symm Q = (map e.inv).obj Q :=
rfl

/-- `map f : subobject X ⥤ subobject Y` is
the left adjoint of `pullback f : subobject Y ⥤ subobject X`. -/
def map_pullback_adj [has_pullbacks C] (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
lower_adjunction (mono_over.map_pullback_adj f)

@[simp]
lemma pullback_map_self [has_pullbacks C] (f : X ⟶ Y) [mono f] (g : subobject X) :
  (pullback f).obj ((map f).obj g) = g :=
begin
  revert g,
  apply quotient.ind,
  intro g',
  apply quotient.sound,
  exact ⟨(mono_over.pullback_map_self f).app _⟩,
end

lemma map_pullback [has_pullbacks C]
  {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} [mono h] [mono g]
  (comm : f ≫ h = g ≫ k) (t : is_limit (pullback_cone.mk f g comm)) (p : subobject Y) :
  (map g).obj ((pullback f).obj p) = (pullback k).obj ((map h).obj p) :=
begin
  revert p,
  apply quotient.ind',
  intro a,
  apply quotient.sound,
  apply thin_skeleton.equiv_of_both_ways,
  { refine mono_over.hom_mk (pullback.lift pullback.fst _ _) (pullback.lift_snd _ _ _),
    change _ ≫ a.arrow ≫ h = (pullback.snd ≫ g) ≫ _,
    rw [assoc, ← comm, pullback.condition_assoc] },
  { refine mono_over.hom_mk (pullback.lift pullback.fst
                        (pullback_cone.is_limit.lift' t (pullback.fst ≫ a.arrow) pullback.snd _).1
                        (pullback_cone.is_limit.lift' _ _ _ _).2.1.symm) _,
    { rw [← pullback.condition, assoc], refl },
    { dsimp, rw [pullback.lift_snd_assoc],
      apply (pullback_cone.is_limit.lift' _ _ _ _).2.2 } }
end

end map

section «exists»
variables [has_images C]

/--
The functor from subobjects of `X` to subobjects of `Y` given by
sending the subobject `S` to its "image" under `f`, usually denoted $\exists_f$.
For instance, when `C` is the category of types,
viewing `subobject X` as `set X` this is just `set.image f`.

This functor is left adjoint to the `pullback f` functor (shown in `exists_pullback_adj`)
provided both are defined, and generalises the `map f` functor, again provided it is defined.
-/
def «exists» (f : X ⟶ Y) : subobject X ⥤ subobject Y :=
lower (mono_over.exists f)

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
lemma exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f = map f :=
lower_iso _ _ (mono_over.exists_iso_map f)

/--
`exists f : subobject X ⥤ subobject Y` is
left adjoint to `pullback f : subobject Y ⥤ subobject X`.
-/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
lower_adjunction (mono_over.exists_pullback_adj f)

end  «exists»

end subobject

end category_theory


import QL.FOL.completeness.skolem QL.FOL.completeness.herbrand

universes u
open_locale logic_symbol aclogic

variables {L : fol.language.{u}}

namespace pl
variables {T : Theory (fol.herbrand_basis L)}

namespace provable

lemma to_fol {p : formula (fol.herbrand_basis L)} (h : equal_axioms L ⊢ p) : ⬝⊢ p.to_fol :=
begin
  simp[axiomatic_classical_logic.empty_axiom],
  apply rec'_on h,
  { intros p q _ _ IHpq IHp, simp at IHpq, refine IHpq ⨀ IHp },
  { intros p hp, rcases hp; simp },
  { simp },
  { simp },
  { simp },
  { simp }
end

end provable

end pl

namespace fol

namespace formula
variables {m : ℕ}

lemma to_snf_univ_closure (p : formula L m) :
  ∃ n (p₀ : subformula (L + L.skolem) m n) (h : p₀.is_open), p.to_snf = ∀'*p₀ :=
pnf.univ_closure_to_formula p.to_pnf.skolemize (pnf.forall_pnf_skolemize _)

end formula

section compactness
open subformula language

def Theory.to_pl (T : Theory L) : pl.Theory (fol.herbrand_basis (L + L.skolem)) :=
⋃ (σ : sentence L) (hσ : σ ∈ T) {n} (p₀ : subformula (L + L.skolem) 0 n) (hp₀ : p₀.is_open)
  (h : σ.to_snf = (∀'*p₀ : subformula _ _ _)),
  set.range (λ x, sentence.to_pl (substs x p₀) (by simpa using hp₀))

lemma Satisfiable_of_to_pl_Satisfiable (T : Theory L) (h : pl.Satisfiable (T.to_pl ∪ pl.equal_axioms (L + L.skolem))) : Satisfiable T :=
begin
  rcases h with ⟨V, hV⟩,
  have hVΓ : V ⊧ T.to_pl, from (logic.semantics.models_union.mp hV).1,
  have hVeq : V ⊧ pl.equal_axioms _, from (logic.semantics.models_union.mp hV).2,
  let S := Structure.Herbrand V hVeq,
  have : ∀ {σ : sentence L} (hσ : σ ∈ T), S ⊧ σ.to_snf,
  { intros σ hσ, rcases formula.to_snf_univ_closure σ with ⟨n, p₀, hp₀, h⟩,
    have : ∀ x, S ⊧ substs x p₀,
    { intros x,
      have : V ⊧ sentence.to_pl (substs (Structure.Herbrand.qu_inv ∘ subterm.val S fin.nil fin.nil ∘ x) p₀) _,
      from hVΓ (by simp[Theory.to_pl]; refine ⟨σ, hσ, n, p₀, h, hp₀, _, rfl⟩),
      simpa[sentence_models_def, Structure.Herbrand.val_iff_subst p₀ hp₀] using this },
    have : S ⊧ ∀'*p₀, by simpa[Structure.Herbrand.models_forall_iff] using this,
    simpa[h] using this },
  refine ⟨S.restrict add_left, by intros σ hσ; exact skolem.restrict_models _ (this hσ)⟩
end

theorem compactness {T : Theory L} : Satisfiable T ↔ (∀ u ⊆ T, u.finite → Satisfiable u) :=
⟨by rintros ⟨S, hS⟩ u hu u_fin; refine ⟨S, logic.semantics.models_of_ss hu hS⟩,
begin
  contrapose, intros h,
  have : ¬pl.Satisfiable (T.to_pl ∪ pl.equal_axioms (L + L.skolem)),
  from mt (Satisfiable_of_to_pl_Satisfiable T) h,
  rcases pl.compactness'.mp this with ⟨u, u_ss, u_fin, hu⟩,
  let g := u \ pl.equal_axioms _,
  have : g ⊆ T.to_pl, by simp[g, set.diff_subset_iff, set.union_comm, u_ss],
  have hg_to_fol : pl.formula.to_fol '' g ⊆
    ⋃ (σ ∈ T) {n} (p₀ : subformula (L + L.skolem) 0 n) (hp₀ : p₀.is_open) (h : to_snf σ = (∀'*p₀ : subformula _ _ _)),
    set.range (λ x, substs x p₀),
  by simpa[Theory.to_pl, set.image_Union, ←set.range_comp, (∘)] using set.image_subset pl.formula.to_fol this,
  have hg_to_fol_fin : (pl.formula.to_fol '' g).finite , from set.finite.image _ (set.finite.diff u_fin _),
  have : ¬pl.Satisfiable (g ∪ pl.equal_axioms _),
  { intros A, suffices : pl.Satisfiable u, by contradiction, refine logic.semantics.Satisfiable_of_ss (by simp) A },
  have : ¬Satisfiable (pl.formula.to_fol '' g), from mt Structure.Satisfies_to_fol_iff.mp this,
  rcases set.finite_subset_Union hg_to_fol_fin hg_to_fol with ⟨s, s_fin, hs⟩,
  simp[-set.image_subset_iff] at hs ⊢,
  refine ⟨s ∩ T, by simp, set.finite.inter_of_left s_fin T, _⟩,
  assume A,
  suffices : Satisfiable (pl.formula.to_fol '' g), by contradiction,
  rcases skolem.Satisfiability.mpr A with ⟨S, hS⟩,
  refine ⟨S, _⟩, intros p hp,
  have : ∃ (σ ∈ s ∩ T) {n} (p₀ : subformula (L + L.skolem) 0 n),
    p₀.is_open ∧ to_snf σ = (∀'*p₀ : subformula _ _ _) ∧ ∃ x, substs x p₀ = p,
  by simpa[and_assoc] using hs hp,
  rcases this with ⟨σ, hσ, n, p₀, hp₀, h, x, rfl⟩,
  have : S ⊧ ∀'*p₀, { rw←h, refine hS (set.mem_image_of_mem _ hσ) },
  simp[sentence_models_def] at this ⊢, exact this _
end⟩

end compactness

open subformula logic logic.Theory
     axiomatic_classical_logic' axiomatic_classical_logic
     Structure
variables {L} {m n : ℕ} [inhabited (L.fn 0)]

lemma provable_of_valid_aux (p : subformula L 0 n) (hp : p.is_open) (H : valid (∃'*p)) : ∅ ⊢ ∃'*p :=
begin
  rcases (valid_iff_pl_consequence p hp).mp H with ⟨v, hv⟩,
  have lmm₁ : ∅ ⊢ (v.map (λ t, substs t p)).disjunction ⟶ ∃'*p, from ldisj_imply_of (by simp),
  have lmm₂ : ∅ ⊢ (v.map (λ t, substs t p)).disjunction,
    by simpa[(∘)] using pl.provable.to_fol (pl.completeness.mpr hv),
  exact lmm₁ ⨀ lmm₂
end

lemma provable_of_valid (σ : sentence L) (H : valid σ) : ∅ ⊢ σ :=
begin
  rcases formula.to_snf_univ_closure (∼σ) with ⟨n, p, hp, h⟩,

end

end fol


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.testing.slim_check.testable
import Mathlib.testing.slim_check.functions
import Mathlib.data.list.sort
import Mathlib.PostPort

namespace Mathlib

/-!
## Finding counterexamples automatically using `slim_check`

A proposition can be tested by writing it out as:

```lean
example (xs : list ℕ) (w : ∃ x ∈ xs, x < 3) : ∀ y ∈ xs, y < 5 := by slim_check
-- ===================

-- ===================
-- Found problems!

-- Found problems!

-- xs := [0, 5]

-- xs := [0, 5]
-- x := 0

-- x := 0
-- y := 5

-- y := 5
-- -------------------

-- -------------------

example (x : ℕ) (h : 2 ∣ x) : x < 100 := by slim_check
-- ===================

-- ===================
-- Found problems!

-- Found problems!

-- x := 258

-- x := 258
-- -------------------

-- -------------------

example (α : Type) (xs ys : list α) : xs ++ ys = ys ++ xs := by slim_check
-- ===================

-- ===================
-- Found problems!

-- Found problems!

-- α := ℤ

-- α := ℤ
-- xs := [-4]

-- xs := [-4]
-- ys := [1]

-- ys := [1]
-- -------------------

-- -------------------

example : ∀ x ∈ [1,2,3], x < 4 := by slim_check
-- Success

-- Success
```

In the first example, `slim_check` is called on the following goal:

```lean
xs : list ℕ,
h : ∃ (x : ℕ) (H : x ∈ xs), x < 3
⊢ ∀ (y : ℕ), y ∈ xs → y < 5
```

The local constants are reverted and an instance is found for
`testable (∀ (xs : list ℕ), (∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))`.
The `testable` instance is supported by instances of `sampleable (list ℕ)`,
`decidable (x < 3)` and `decidable (y < 5)`. `slim_check` builds a
`testable` instance step by step with:

```
- testable (∀ (xs : list ℕ), (∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))
                                     -: sampleable (list xs)
- testable ((∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))
- testable (∀ x ∈ xs, x < 3 → (∀ y ∈ xs, y < 5))
- testable (x < 3 → (∀ y ∈ xs, y < 5))
                                     -: decidable (x < 3)
- testable (∀ y ∈ xs, y < 5)
                                     -: decidable (y < 5)
```

`sampleable (list ℕ)` lets us create random data of type `list ℕ` in a way that
helps find small counter-examples.  Next, the test of the proposition
hinges on `x < 3` and `y < 5` to both be decidable. The
implication between the two could be tested as a whole but it would be
less informative. Indeed, if we generate lists that only contain numbers
greater than `3`, the implication will always trivially hold but we should
conclude that we haven't found meaningful examples. Instead, when `x < 3`
does not hold, we reject the example (i.e.  we do not count it toward
the 100 required positive examples) and we start over. Therefore, when
`slim_check` prints `Success`, it means that a hundred suitable lists
were found and successfully tested.

If no counter-examples are found, `slim_check` behaves like `admit`.

`slim_check` can also be invoked using `#eval`:

```lean
#eval slim_check.testable.check (∀ (α : Type) (xs ys : list α), xs ++ ys = ys ++ xs)
-- ===================

-- ===================
-- Found problems!

-- Found problems!

-- α := ℤ

-- α := ℤ
-- xs := [-4]

-- xs := [-4]
-- ys := [1]

-- ys := [1]
-- -------------------

-- -------------------
```

For more information on writing your own `sampleable` and `testable`
instances, see `testing.slim_check.testable`.
-/

namespace tactic.interactive

/-- Tree structure representing a `testable` instance. -/
end Mathlib


variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
  ∃ t, l₁ ++ t = l₂

instance list_has_le : has_le (list α) := ⟨is_prefix⟩

theorem list.is_prefix_refl (l : list α) : l ≤ l :=
  ⟨[], by simp⟩


import .dual

noncomputable theory
open_locale classical

open set

namespace matroid

variables {E E₀ E₁ E₂ : Type*} [finite E] [finite E₁] [finite E₂]
{M₀ : matroid E₀} {M₁ : matroid E₁} {M₂ : matroid E₂}

section iso

/-- Two matroids are isomorphic if there is a map between ground sets that preserves bases -/
def is_iso (M₁ : matroid E₁) (M₂ : matroid E₂) (e : E₁ ≃ E₂) :=
  ∀ B, M₁.base B ↔ M₂.base (e '' B)

/-- A bundled isomorphism between two matroids -/
structure iso (M₁ : matroid E₁) (M₂ : matroid E₂) :=
(to_fun : E₁ ≃ E₂)
(on_base : ∀ B, M₁.base B ↔ M₂.base (to_fun '' B))

infix ` ≃i ` :75 :=  matroid.iso

instance : has_coe_to_fun (M₁ ≃i M₂) (λ _, E₁ → E₂) :=
  ⟨λ e, e.to_fun⟩

def iso.refl (M : matroid E) : M ≃i M := ⟨equiv.refl E, λ B, by simp⟩
def iso.symm (e : M₁ ≃i M₂) : M₂ ≃i M₁ := ⟨e.to_fun.symm, λ B, by {rw e.on_base, simp, }⟩

/-- An equivalence between types induces a map from a matroid on one type to one on another -/
def congr_equiv (M₁ : matroid E₁) (e : E₁ ≃ E₂)  :
  matroid E₂ :=
{ base := λ B, M₁.base (e ⁻¹' B),
  exists_base' := by
    {obtain ⟨B₁,hB₁⟩ := M₁.exists_base, exact ⟨e '' B₁, by simpa using hB₁⟩} ,
  base_exchange' :=
  begin
    rintro B₁ B₂ hB₁ hB₂ x hx,
    have hx' : e.symm x ∈ e ⁻¹' B₁ \ e⁻¹' B₂, by simpa,
    obtain ⟨y, hy, hBy⟩ := hB₁.exchange hB₂ hx',
    refine ⟨e y, by simpa, _⟩,
    dsimp only,
    simp_rw [←union_singleton, preimage_union, preimage_diff] at ⊢ hBy,
    convert hBy;
    simp [preimage_equiv_eq_image_symm],
  end}

@[simp] lemma congr_equiv_apply_base {e : E₁ ≃ E₂} {M₁ : matroid E₁} {B : set E₂} :
  (M₁.congr_equiv e).base B ↔ M₁.base (e ⁻¹' B) :=
iff.rfl

@[simp] lemma congr_equiv_apply_indep {e : E₁ ≃ E₂} {M₁ : matroid E₁} {I : set E₂} :
  (M₁.congr_equiv e).indep I ↔ M₁.indep (e ⁻¹' I) :=
begin
  simp_rw [indep, congr_equiv_apply_base],
  split,
  { rintro ⟨B₂, hB₂, hIB₂⟩, exact ⟨_, hB₂, preimage_mono hIB₂⟩},
  rintro ⟨B₁, hB₁, hIB₁⟩,
  refine ⟨e '' B₁, by {convert hB₁, simp}, _⟩,
  rwa [←equiv.subset_image, ←preimage_equiv_eq_image_symm],
end

@[simp] lemma congr_equiv_apply_symm_base {e : E₁ ≃ E₂} {M₂ : matroid E₂} {B : set E₁} :
  (M₂.congr_equiv e.symm).base B ↔ M₂.base (e '' B) :=
by simp [←image_equiv_eq_preimage_symm]

@[simp] lemma congr_equiv_apply_symm_indep {e : E₁ ≃ E₂} {M₂ : matroid E₂} {I : set E₁} :
  (M₂.congr_equiv e.symm).indep I ↔ M₂.indep (e '' I) :=
by simp [←image_equiv_eq_preimage_symm]

@[simp] lemma congr_equiv_apply_basis {e : E₁ ≃ E₂} {M₁ : matroid E₁} {I X : set E₂} :
  (M₁.congr_equiv e).basis I X ↔ M₁.basis (e ⁻¹' I) (e ⁻¹' X) :=
begin
  simp only [basis, congr_equiv_apply_indep, equiv.preimage_subset, and.congr_right_iff],
  refine λ hI hIX, ⟨λ h J hJ hIJ hJX, _,λ h J hJ hIJ hJX, _⟩,
  { rw h (e '' J) (by simpa) _ (by simpa),
    { simp, },
    rw ←e.image_preimage I,
    exact image_subset e hIJ},
  have h' := h (e ⁻¹' J) hJ (preimage_mono hIJ) (preimage_mono hJX),
  rwa preimage_eq_preimage e.surjective at h',
end

@[simp] lemma congr_equiv_apply_symm_basis {e : E₁ ≃ E₂} {M₂ : matroid E₂} {I X : set E₁} :
  (M₂.congr_equiv e.symm).basis I X ↔ M₂.basis (e '' I) (e '' X) :=
by simp [←image_equiv_eq_preimage_symm]

@[simp] lemma congr_equiv_apply_r {e : E₁ ≃ E₂} {M₁ : matroid E₁} (X : set E₂) :
  (M₁.congr_equiv e).r X = M₁.r (e ⁻¹' X) :=
begin
  obtain ⟨I, hI⟩ := (M₁.congr_equiv e).exists_basis X,
  rw [←hI.r, hI.indep.r],
  rw [congr_equiv_apply_basis] at hI,
  rw [←hI.r, hI.indep.r, preimage_equiv_eq_image_symm, ncard_image_of_injective _ e.symm.injective],
end

@[simp] lemma congr_equiv_apply_symm_r {e : E₁ ≃ E₂} {M₂ : matroid E₂} (X : set E₁) :
  (M₂.congr_equiv e.symm).r X = M₂.r (e '' X) :=
by simp [←image_equiv_eq_preimage_symm]

@[simp] lemma congr_equiv_apply_circuit {e : E₁ ≃ E₂} {M₁ : matroid E₁} {C : set E₂} :
  (M₁.congr_equiv e).circuit C ↔ M₁.circuit (e ⁻¹' C) :=
begin
  simp_rw [circuit_iff_dep_forall_diff_singleton_indep, congr_equiv_apply_indep, preimage_diff],
  convert iff.rfl,
  rw eq_iff_iff,
  refine ⟨λ h x hxC, _,λ h x (hx : e x ∈ C), _⟩,
  { convert h (e.symm x) (by simpa),
    rw [←image_singleton, preimage_equiv_eq_image_symm]},
  convert h _ hx,
  rw [←image_singleton, preimage_image_eq _ e.injective],
end

@[simp] lemma congr_equiv_apply_symm_circuit {e : E₁ ≃ E₂} {M₂ : matroid E₂} {C : set E₁} :
  (M₂.congr_equiv e.symm).circuit C = M₂.circuit (e '' C) :=
by simp [←image_equiv_eq_preimage_symm]

@[simp] lemma congr_equiv_apply_flat {e : E₁ ≃ E₂} {M₁ : matroid E₁} {F : set E₂} :
  (M₁.congr_equiv e).flat F ↔ M₁.flat (e ⁻¹' F) :=
begin
  simp_rw [flat_def, congr_equiv_apply_basis],
  refine ⟨λ h I X hIF hFX, _,λ h I X hIF hFX, _⟩,
  { rw [←image_subset_iff],
    exact h (e '' I) (e '' X) (by simpa) (by simpa)},
  exact (equiv.preimage_subset e X F).mp (h (⇑e ⁻¹' I) (⇑e ⁻¹' X) hIF hFX),
end

@[simp] lemma congr_equiv_apply_symm_flat {e : E₁ ≃ E₂} {M₂ : matroid E₂} {F : set E₁} :
  (M₂.congr_equiv e.symm).flat F = M₂.flat (e '' F) :=
by simp [←image_equiv_eq_preimage_symm]

end iso

end matroid


namespace hidden
    instance inhabited_sum (α : Type) (β : Type) [inhabited α] : inhabited (α ⊕ β) :=
    ⟨@sum.inl α β (default α)⟩

    instance inhabited_nonempty (α : Type) [inhabited α] : inhabited (list α) :=
    ⟨list.cons (default α) list.nil⟩

    def add_lists (α : Type) [has_add α] : list α → list α → list α
    | [] [] := []
    | l1 [] := l1
    | [] l2 := l2
    | (hd1::tl1) (hd2::tl2) := (hd1 + hd2)::(add_lists tl1 tl2)

    instance list_has_add (α : Type) [has_add α] : has_add (list α) :=
    ⟨add_lists α⟩

    example : [3, 2] + [] = [3, 2] := rfl
    example : [] + [3, 2] = [3, 2] := rfl
    example : (@list.nil ℕ) + [] = [] := rfl
    example : [3, 2] + [10, 20] = [13, 22] := rfl

end hidden


lemma imp_trans (P Q R : Prop) : (P → Q) → ((Q → R) → (P → R)) :=
begin
intros hpq hqr p,
apply hqr,
apply hpq,
exact p,
end


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.category.Mon.basic
import category_theory.endomorphism

/-!
# Category instances for group, add_group, comm_group, and add_comm_group.

We introduce the bundled categories:
* `Group`
* `AddGroup`
* `CommGroup`
* `AddCommGroup`
along with the relevant forgetful functors between them, and to the bundled monoid categories.
-/

universes u v

open category_theory

/-- The category of groups and group morphisms. -/
@[to_additive AddGroup]
def Group : Type (u+1) := bundled group

/-- The category of additive groups and group morphisms -/
add_decl_doc AddGroup

namespace Group

@[to_additive]
instance : bundled_hom.parent_projection group.to_monoid := ⟨⟩

attribute [derive [large_category, concrete_category]] Group
attribute [to_additive] Group.large_category Group.concrete_category

@[to_additive] instance : has_coe_to_sort Group Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Group` from the underlying type and typeclass. -/
@[to_additive] def of (X : Type u) [group X] : Group := bundled.of X

/-- Construct a bundled `AddGroup` from the underlying type and typeclass. -/
add_decl_doc AddGroup.of

/-- Typecheck a `monoid_hom` as a morphism in `Group`. -/
@[to_additive] def of_hom {X Y : Type u} [group X] [group Y] (f : X →* Y) : of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddGroup`. -/
add_decl_doc AddGroup.of_hom

@[to_additive]
instance (G : Group) : group G := G.str

@[simp, to_additive] lemma coe_of (R : Type u) [group R] : (Group.of R : Type u) = R := rfl

@[to_additive]
instance : has_one Group := ⟨Group.of punit⟩

@[to_additive]
instance : inhabited Group := ⟨1⟩

@[to_additive]
instance one.unique : unique (1 : Group) :=
{ default := 1,
  uniq := λ a, begin cases a, refl, end }

@[simp, to_additive]
lemma one_apply (G H : Group) (g : G) : (1 : G ⟶ H) g = 1 := rfl

@[ext, to_additive]

@[to_additive has_forget_to_AddMon]
instance has_forget_to_Mon : has_forget₂ Group Mon := bundled_hom.forget₂ _ _

end Group

/-- The category of commutative groups and group morphisms. -/
@[to_additive AddCommGroup]
def CommGroup : Type (u+1) := bundled comm_group

/-- The category of additive commutative groups and group morphisms. -/
add_decl_doc AddCommGroup

/-- `Ab` is an abbreviation for `AddCommGroup`, for the sake of mathematicians' sanity. -/
abbreviation Ab := AddCommGroup

namespace CommGroup

@[to_additive]
instance : bundled_hom.parent_projection comm_group.to_group := ⟨⟩

attribute [derive [large_category, concrete_category]] CommGroup
attribute [to_additive] CommGroup.large_category CommGroup.concrete_category

@[to_additive] instance : has_coe_to_sort CommGroup Type* := bundled.has_coe_to_sort

/-- Construct a bundled `CommGroup` from the underlying type and typeclass. -/
@[to_additive] def of (G : Type u) [comm_group G] : CommGroup := bundled.of G

/-- Construct a bundled `AddCommGroup` from the underlying type and typeclass. -/
add_decl_doc AddCommGroup.of

/-- Typecheck a `monoid_hom` as a morphism in `CommGroup`. -/
@[to_additive] def of_hom {X Y : Type u} [comm_group X] [comm_group Y] (f : X →* Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddCommGroup`. -/
add_decl_doc AddCommGroup.of_hom

@[to_additive]
instance comm_group_instance (G : CommGroup) : comm_group G := G.str

@[simp, to_additive] lemma coe_of (R : Type u) [comm_group R] : (CommGroup.of R : Type u) = R := rfl

@[to_additive] instance : has_one CommGroup := ⟨CommGroup.of punit⟩

@[to_additive] instance : inhabited CommGroup := ⟨1⟩

@[to_additive]
instance one.unique : unique (1 : CommGroup) :=
{ default := 1,
  uniq := λ a, begin cases a, refl, end }

@[simp, to_additive]
lemma one_apply (G H : CommGroup) (g : G) : (1 : G ⟶ H) g = 1 := rfl

@[ext, to_additive]
lemma ext (G H : CommGroup) (f₁ f₂ : G ⟶ H) (w : ∀ x, f₁ x = f₂ x) : f₁ = f₂ :=
by { ext1, apply w }

@[to_additive has_forget_to_AddGroup]
instance has_forget_to_Group : has_forget₂ CommGroup Group := bundled_hom.forget₂ _ _

@[to_additive has_forget_to_AddCommMon]
instance has_forget_to_CommMon : has_forget₂ CommGroup CommMon :=
induced_category.has_forget₂ (λ G : CommGroup, CommMon.of G)

end CommGroup

-- This example verifies an improvement possible in Lean 3.8.
-- Before that, to have `monoid_hom.map_map` usable by `simp` here,
-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.
-- Now, it just works.
@[to_additive]
example {R S : CommGroup} (i : R ⟶ S) (r : R) (h : r = 1) : i r = 1 :=
by simp [h]

namespace AddCommGroup

/-- Any element of an abelian group gives a unique morphism from `ℤ` sending
`1` to that element. -/
-- Note that because `ℤ : Type 0`, this forces `G : AddCommGroup.{0}`,
-- so we write this explicitly to be clear.
-- TODO generalize this, requiring a `ulift_instances.lean` file
def as_hom {G : AddCommGroup.{0}} (g : G) : (AddCommGroup.of ℤ) ⟶ G :=
zmultiples_hom G g

@[simp]
lemma as_hom_apply {G : AddCommGroup.{0}} (g : G) (i : ℤ) : (as_hom g) i = i • g := rfl

lemma as_hom_injective {G : AddCommGroup.{0}} : function.injective (@as_hom G) :=
λ h k w, by convert congr_arg (λ k : (AddCommGroup.of ℤ) ⟶ G, (k : ℤ → G) (1 : ℤ)) w; simp

@[ext]
lemma int_hom_ext
  {G : AddCommGroup.{0}} (f g : (AddCommGroup.of ℤ) ⟶ G) (w : f (1 : ℤ) = g (1 : ℤ)) : f = g :=
add_monoid_hom.ext_int w

-- TODO: this argument should be generalised to the situation where
-- the forgetful functor is representable.
lemma injective_of_mono {G H : AddCommGroup.{0}} (f : G ⟶ H) [mono f] : function.injective f :=
λ g₁ g₂ h,
begin
  have t0 : as_hom g₁ ≫ f = as_hom g₂ ≫ f :=
  begin
    ext,
    simpa [as_hom_apply] using h,
  end,
  have t1 : as_hom g₁ = as_hom g₂ := (cancel_mono _).1 t0,
  apply as_hom_injective t1,
end

end AddCommGroup

variables {X Y : Type u}

/-- Build an isomorphism in the category `Group` from a `mul_equiv` between `group`s. -/
@[to_additive add_equiv.to_AddGroup_iso, simps]
def mul_equiv.to_Group_iso [group X] [group Y] (e : X ≃* Y) : Group.of X ≅ Group.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

/-- Build an isomorphism in the category `AddGroup` from an `add_equiv` between `add_group`s. -/
add_decl_doc add_equiv.to_AddGroup_iso

/-- Build an isomorphism in the category `CommGroup` from a `mul_equiv` between `comm_group`s. -/
@[to_additive add_equiv.to_AddCommGroup_iso, simps]
def mul_equiv.to_CommGroup_iso [comm_group X] [comm_group Y] (e : X ≃* Y) :
  CommGroup.of X ≅ CommGroup.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

/-- Build an isomorphism in the category `AddCommGroup` from a `add_equiv` between
`add_comm_group`s. -/
add_decl_doc add_equiv.to_AddCommGroup_iso

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Group`. -/
@[to_additive AddGroup_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddGroup`.", simps]
def Group_iso_to_mul_equiv {X Y : Group} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

/-- Build a `mul_equiv` from an isomorphism in the category `CommGroup`. -/
@[to_additive AddCommGroup_iso_to_add_equiv "Build an `add_equiv` from an isomorphism
in the category `AddCommGroup`.", simps]
def CommGroup_iso_to_mul_equiv {X Y : CommGroup} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

end category_theory.iso

/-- multiplicative equivalences between `group`s are the same as (isomorphic to) isomorphisms
in `Group` -/
@[to_additive add_equiv_iso_AddGroup_iso "additive equivalences between `add_group`s are the same
as (isomorphic to) isomorphisms in `AddGroup`"]
def mul_equiv_iso_Group_iso {X Y : Type u} [group X] [group Y] :
  (X ≃* Y) ≅ (Group.of X ≅ Group.of Y) :=
{ hom := λ e, e.to_Group_iso,
  inv := λ i, i.Group_iso_to_mul_equiv, }

/-- multiplicative equivalences between `comm_group`s are the same as (isomorphic to) isomorphisms
in `CommGroup` -/
@[to_additive add_equiv_iso_AddCommGroup_iso "additive equivalences between `add_comm_group`s are
the same as (isomorphic to) isomorphisms in `AddCommGroup`"]
def mul_equiv_iso_CommGroup_iso {X Y : Type u} [comm_group X] [comm_group Y] :
  (X ≃* Y) ≅ (CommGroup.of X ≅ CommGroup.of Y) :=
{ hom := λ e, e.to_CommGroup_iso,
  inv := λ i, i.CommGroup_iso_to_mul_equiv, }

namespace category_theory.Aut

/-- The (bundled) group of automorphisms of a type is isomorphic to the (bundled) group
of permutations. -/
def iso_perm {α : Type u} : Group.of (Aut α) ≅ Group.of (equiv.perm α) :=
{ hom := ⟨λ g, g.to_equiv, (by tidy), (by tidy)⟩,
  inv := ⟨λ g, g.to_iso, (by tidy), (by tidy)⟩ }

/-- The (unbundled) group of automorphisms of a type is `mul_equiv` to the (unbundled) group
of permutations. -/
def mul_equiv_perm {α : Type u} : Aut α ≃* equiv.perm α :=
iso_perm.Group_iso_to_mul_equiv

end category_theory.Aut

@[to_additive]
instance Group.forget_reflects_isos : reflects_isomorphisms (forget Group.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Group).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Group_iso).1⟩,
  end }

@[to_additive]
instance CommGroup.forget_reflects_isos : reflects_isomorphisms (forget CommGroup.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommGroup).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommGroup_iso).1⟩,
  end }


def tst (x : Nat) : Nat :=
  let_mvar% ?m := x + 1;
  ?m + ?m

#print tst

example : tst x = (x + 1) + (x + 1) :=
  rfl


import definitions rotations shrink forall_keys tactic.linarith tactic.induction
set_option pp.generalized_field_notation false

universe u

namespace del_root_lemmas
open btree rotation_lemmas shrink_lemmas forall_keys_lemmas

variables {α : Type u}

lemma del_root_del_root_view (t : btree α) :
  del_root_view t (del_root t) :=
begin
  cases t,
  case empty {
    exact del_root_view.empty,
  },
  case node : l k a r {
    dsimp [del_root],
    cases h : shrink l,
    case none {
      dsimp [del_root._match_1],
      apply del_root_view.nonempty_empty; assumption,
    },
    case some {
      rcases val with ⟨x, a', sh⟩,
      dsimp only [del_root._match_1],
      by_cases h' : height r > height sh + 1,
      { simp only [if_pos h'],
        apply del_root_view.nonempty_nonempty₁; assumption,
      },
      { simp only [if_neg h'],
        apply del_root_view.nonempty_nonempty₂; try { assumption, },
        linarith,
      },
    },
  },
end

/- Auxiliary del_root lemma for forall_delete -/
lemma forall_del_root (t : btree α) (k : nat) (p : nat → nat → Prop) :
  forall_keys p k t → forall_keys p k (del_root t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [del_root],
    exact h₁,
  },
  case node : l x v r {
    cases' del_root_del_root_view (node l x v r),
    case nonempty_empty {
      unfold forall_keys at h₁ ⊢,
      intros k' h₂,
      apply h₁,
      simp [bound],
      tauto,
    },
    case nonempty_nonempty₁ {
      apply forall_rotate_left,
      rw ← forall_keys_char,
      repeat { split },
      { rw ← forall_keys_char at h₁,
        cases_matching* (_ ∧ _),
        apply forall_shrink_aux_1 (and.intro h₁_left h),
      },
      { rw ← forall_keys_char at h₁,
        cases_matching* (_ ∧ _),
        apply forall_shrink_aux_2 (and.intro h₁_left h),
      },
      { unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound],
        tauto,
      },
    },
    case nonempty_nonempty₂ {
      rw ← forall_keys_char,
      repeat { split },
      { rw ← forall_keys_char at h₁,
        cases_matching* (_ ∧ _),
        apply forall_shrink_aux_1 (and.intro h₁_left h),
      },
      { rw ← forall_keys_char at h₁,
        cases_matching* (_ ∧ _),
        apply forall_shrink_aux_2 (and.intro h₁_left h),
      },
      { unfold forall_keys at h₁ ⊢,
        intros k' h₂,
        apply h₁,
        simp [bound],
        tauto,
      },
    },
  },
end

/- Deleting a root of a tree preserves the tree order -/
lemma del_root_ordered (t : btree α) :
  ordered t → ordered (del_root t) :=
begin
  intro h₁,
  cases t,
  case empty {
    simp [del_root, ordered],
  },
  case node : tl tk ta tr {
    simp [ordered] at h₁,
    cases_matching* (_ ∧ _),
    cases' del_root_del_root_view (node tl tk ta tr),
    case nonempty_empty { assumption, },
    case nonempty_nonempty₁ {
      apply rotate_left_ordered,
      rw ordered,
      repeat { split },
      { apply shrink_ordered_aux_1 (and.intro h₁_left h),  },
      { assumption, },
      { apply shrink_ordered_aux_2 (and.intro h₁_left h), },
      { apply forall_keys_trans _ (<) k,
        { apply forall_shrink_aux_2 (and.intro h₁_right_right_left h), },
        { apply trans, },
        { assumption, },
      },
    },
    case nonempty_nonempty₂ {
      rw ordered,
      repeat { split },
      { apply shrink_ordered_aux_1 (and.intro h₁_left h), },
      { assumption, },
      { apply shrink_ordered_aux_2 (and.intro h₁_left h), },
      { apply forall_keys_trans _ (<) k,
        { apply forall_shrink_aux_2 (and.intro h₁_right_right_left h), },
        { apply trans, },
        { assumption, },
      },
    },
  },
end

end del_root_lemmas