import data.real.basic
import .affnK
import tactic.linarith
/-
Amanda:

Go to line 730ish and find the proof I just copied and pasted in. It is an example basis proof.
Dig into the details and you'll be able to adapt this, or at least some of it.
-/
import linear_algebra.basis
-- Testing vec_n_basis

/-
protected noncomputable def span : basis ι R (span R (range v)) :=
basis.mk (linear_independent_span hli) $
begin
  rw eq_top_iff,
  intros x _,
  have h₁ : subtype.val '' set.range (λ i, subtype.mk (v i) _) = range v,
  { rw ← set.range_comp },
  have h₂ : map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _)))
    = span R (range v),
  { rw [← span_image, submodule.subtype_eq_val, h₁] },
  have h₃ : (x : M) ∈ map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _))),
  { rw h₂, apply subtype.mem x },
  rcases mem_map.1 h₃ with ⟨y, hy₁, hy₂⟩,
  have h_x_eq_y : x = y,
  { rw [subtype.ext_iff, ← hy₂], simp },
  rwa h_x_eq_y
end
-/

open submodule
/-

protected theorem lt_asymm {n m : ℕ} (h₁ : n < m) : ¬ m < n :=
le_lt_antisymm (nat.le_of_lt h₁)

-/
@[simp]
lemma eznat :  ∀ (a b : ℕ), a + b < a → false :=
begin
  intros a b c,
  cases b,
  suffices : ¬a < a, from by contradiction, exact irrefl _,
  let h1 : 0 < b.succ := by simp *,
  let h2 : a + 0 < a + b.succ := by simp *,
  let h3 : a + 0 < a := by exact lt_trans h2 c,
  suffices : ¬a < a, from by contradiction, exact irrefl _,

end

@[simp]
lemma eznat2 :  ∀ (a b : ℕ), b + a < a → false :=
begin
  intros a b c,
  rw ←(nat.add_comm a b) at c,
  exact eznat _ _ c,
end

#check nat.add_comm

#check nat.succ_ne_zero
#check nat.add_lt_add_left
#check lt_trans

def vec_1_basis :=
let v := (λ a : fin 1, (λ b : fin 1, vec.mk (1 : ℚ)))  in
  vec_n_basis.mk v
begin
  ext,
  split,
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    suffices h' : x = {support := ∅, to_fun := λ (_x : fin 1), semiring.zero, mem_support_to_fun := _},
    exact h',
    dsimp only [linear_map.ker, submodule.comap, set.preimage] at h,
    have h₀ : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x ∈ ↑⊥ := by exact h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h₀,
    dsimp only [vec_zero] at h₀,
    have h₁ : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x = λ (_x : fin 1), mk_vec ℚ 0 := by exact h₀,
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe] at h₁,
    dsimp [finsupp.sum] at h₁,
    simp only [linear_map.id_coe, id.def] at h₁,
    sorry,
  },
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h,
    have h₀ : x = {support := ∅, to_fun := λ (_x : fin 1), semiring.zero, mem_support_to_fun := _} := by exact h,
    dsimp only [linear_map.ker, submodule.comap, set.preimage],
    suffices h' : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x ∈ ↑⊥,
    exact h',
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    dsimp only [vec_zero],
    suffices h' : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x = λ (_x : fin 1), mk_vec ℚ 0,
    exact h',
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe],
    rw h₀,
    dsimp [finsupp.sum],
    refl,
  }
end begin
  dsimp only [submodule.span, Inf],
  dsimp only [has_top.top, set.univ],
  dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
  dsimp only [set.range, set.Inter],
  simp only [nonempty_of_inhabited, set.mem_set_of_eq, exists_const],
  ext,
  split,
  {
    intro,
    exact true.intro,
  },
  {
    intro,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp *,
    dsimp [set_of],
    intros f g,
    simp [has_subset.subset, set.subset] at g,
    /-
    (λ (a : vec_n ℚ 2),
      (∀ ⦃a : vec_n ℚ 2⦄,
        (a ∈ λ (x : vec_n ℚ 2),
          ∃ (y : fin 2), (λ (j : fin 2), ite (y = j) {coord := 1} {coord := 0}) = x)
            → a ∈ c.carrier) → a ∈ c)
        = t
    -/
    let h3 := x ⟨0, by linarith⟩,
    destruct h3,

    intros,
    let one_ : vec_n ℚ 1 := (λ i, {coord := 1}),

    let h4 : one_ ∈ f := by apply @g one_ rfl,
    let onex := coord•one_,
    let onexmem : onex ∈ f :=
      by exact @submodule.smul_mem ℚ (vec_n ℚ 1) _ _ _ f one_ coord h4,
    haveI := onex,
    let h6 : coord • (λ (i : fin 1), {coord := 1} : vec_n ℚ 1) = onex := rfl,
    let onexeq : (∀ (i : fin 1), x i = onex i) := begin
        intros,
        cases i,
        cases i_val,
        { rw ←h6,
          let h7 : (coord • (λ (i : fin 1), {coord := 1}) : vec_n ℚ 1) ⟨0, i_property⟩
            = (coord • {coord := 1}) := begin
              refl
            end,
          simp [h7],
          dsimp [has_scalar.smul],
          simp *,
          let h16 : x 0 = h3 := by refl,
          rw h16,
          exact a,
         },
        {
          cases i_val,
          let h10 : (1 )= (1) := rfl,
          let h11 := lt_irrefl 1,
          contradiction,

          let h12 : 1 < i_val.succ.succ := by exact nat.one_lt_succ_succ i_val,
          let h13 : 1 < 1 := by exact lt_trans h12 i_property,
          let h14 : ¬1<1 := by exact lt_irrefl _,
          contradiction,
        },
    end,
    let h20 : x = onex := by exact funext onexeq,
    rw h20,
    exact onexmem,

  },
end

def vec_2_basis :=
let v := (λ i : fin 2, (λ j : fin 2,
  if i = j then mk_vec ℚ 1 else mk_vec ℚ 0
))  in
  vec_n_basis.mk v
begin
  ext,
  split,
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    suffices h' : x = {support := ∅, to_fun := λ (_x : fin 2), semiring.zero, mem_support_to_fun := _},
    exact h',
    dsimp only [linear_map.ker, submodule.comap, set.preimage] at h,
    have h₀ : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x ∈ ↑⊥ := by exact h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h₀,
    dsimp only [vec_zero] at h₀,
    have h₁ : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x = λ (_x : fin 2), mk_vec ℚ 0 := by exact h₀,
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe] at h₁,
    dsimp [finsupp.sum] at h₁,
    simp only [linear_map.id_coe, id.def] at h₁,
    sorry,
  },
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h,
    have h₀ : x = {support := ∅, to_fun := λ (_x : fin 2), semiring.zero, mem_support_to_fun := _} := by exact h,
    dsimp only [linear_map.ker, submodule.comap, set.preimage],
    suffices h' : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x ∈ ↑⊥,
    exact h',
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    dsimp only [vec_zero],
    suffices h' : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x = λ (_x : fin 2), mk_vec ℚ 0,
    exact h',
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe],
    rw h₀,
    dsimp [finsupp.sum],
    refl,
  }
end
begin
  dsimp only [submodule.span, Inf],
  dsimp only [has_top.top, set.univ],
  dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
  dsimp only [set.range, set.Inter],
  simp only [nonempty_of_inhabited, set.mem_set_of_eq, exists_const],
  ext,
  split,
  {
    intros,
    exact true.intro,
  },
  {
    intros,
    intro,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp *,
    dsimp [set_of],
    intros c d,
    dsimp [has_subset.subset, set.subset] at d,--, has_mem.mem, set.mem] at d,
    --rw ←d at t,
    --rw d.symm,
    let smdef : set (vec_n ℚ 2) :=
      (λ (a : vec_n ℚ 2),
      (∀ ⦃a : vec_n ℚ 2⦄, (∃ (y : fin 2),
        (λ (j : fin 2), ite (y = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)
        ) = a) → c.carrier a)
          → (↑c : set _) a),
    let tt : t = smdef := by exact d.symm,
    simp *,
    dsimp [has_mem.mem, set.mem],
    assume cmem : _,
    let v0 := v ⟨0, by linarith⟩,
    let v1 := v ⟨1, by linarith⟩,
    let v0mem : v0 ∈ c := begin
      --let h0 :
      let c0 : vec_n ℚ 2 :=
        (λ (j : fin 2), ite (0 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
      let h0 : c.carrier c0 := cmem 0,
      let h1 : c0 = v0 :=
        begin
          suffices sh : ∀ i, c0 i = v0 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          refl,
          cases i_val,
          refl,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,
        end,
      rw ←h1,
      exact (mem_carrier c).mp h0,
    end,
    let v1mem : v1 ∈ c := begin
      --let h0 :
      let c1 : vec_n ℚ 2 :=
        (λ (j : fin 2), ite (1 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
      let h0 : c.carrier c1 := cmem ⟨1, by linarith⟩,
      let h1 : c1 = v1 :=
        begin
          suffices sh : ∀ i, c1 i = v1 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          refl,
          cases i_val,
          refl,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,
        end,
      rw ←h1,
      exact (mem_carrier c).mp h0,
    end,

    --let x0 := x ⟨0, by linarith⟩,
    --let x1 := x ⟨1, by linarith⟩,
    destruct x ⟨0, by linarith⟩,
    intros c0 e0,
    destruct x ⟨1, by linarith⟩,
    intros c1 e1,
    let v00 := v0 ⟨0, by linarith⟩,
    let v10 := v1 ⟨0, by linarith⟩,
    let c0smulv0 := λ (j : fin 2), ite (0 = j) ({coord := c0}: vec ℚ) ({coord := 0}: vec ℚ),
    let c0smulv0_eq :
      (c0 • v0 = c0smulv0)
        := begin
         -- simp *,
          suffices sh : ∀ i, (c0 • v0) i = c0smulv0 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          simp *,
          let h0 : ite (0 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c0} : vec ℚ) := rfl,
          simp *,
          dsimp [has_scalar.smul],
          simp *,
          cases i_val,
          simp *,
          let h0 : ite (1 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
          simp *,
          dsimp [has_scalar.smul],
          simp *,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,

        end,
    let c0smulv0mem : c0smulv0 ∈ c :=
      begin
        rw ←c0smulv0_eq,
        exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v0 c0 v0mem
      end,

    let c1smulv1 := λ (j : fin 2), ite (1 = j) ({coord := c1}: vec ℚ) ({coord := 0}: vec ℚ),

    let c1smulv1_eq :
      (c1 • v1 = c1smulv1)
        := begin
         -- simp *,
          suffices sh : ∀ i, (c1 • v1) i = c1smulv1 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          simp *,
          --let h0 : ite (1 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c1} : vec ℚ) := rfl,
          --simp *,
          dsimp [has_scalar.smul],
          simp *,
          cases i_val,
          simp *,
          --let h0 : ite (0 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
          --simp *,
          dsimp [has_scalar.smul],
          simp *,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,

        end,
    let c1smulv1mem : c1smulv1 ∈ c :=
      begin
        rw ←c1smulv1_eq,
        exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v1 c1 v1mem
      end,

    let comb_mem : c0smulv0 + c1smulv1 ∈ c :=
      by exact @submodule.add_mem ℚ (vec_n ℚ 2) _ _ _ c  _ _ c0smulv0mem c1smulv1mem,

    let x_combeq : x = c0smulv0 + c1smulv1 := begin
      suffices sh : ∀ i, x i = (c0smulv0 + c1smulv1) i, from funext sh,
      intros,
      cases i,
      cases i_val,
      /-
      x ⟨0, i_property⟩ = (c0smulv0 + c1smulv1) ⟨0, i_property⟩
      -/
      rw e0,
      simp *, refl,
      cases i_val,
      rw e1,
      simp *, refl,
      let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
      rw ←ht at i_property,
      let : false := by exact eznat2 _ _ i_property,
      contradiction,
    end,

    rw x_combeq,
    exact comb_mem,
  }
end

def vec_2_basis_hard :=
let v := (λ i : fin 2,
  if i = 0 then mk_vec_n ℚ 2 ⟨[4, 3],rfl⟩ else mk_vec_n ℚ 2 ⟨[-1, 1],rfl⟩)
  in
  vec_n_basis.mk v
  begin
    ext,
  split,
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    suffices h' : x = {support := ∅, to_fun := λ (_x : fin 2), semiring.zero, mem_support_to_fun := _},
    exact h',
    dsimp only [linear_map.ker, submodule.comap, set.preimage] at h,
    have h₀ : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x ∈ ↑⊥ := by exact h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h₀,
    dsimp only [vec_zero] at h₀,
    have h₁ : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x = λ (_x : fin 2), mk_vec ℚ 0 := by exact h₀,
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe] at h₁,
    dsimp [finsupp.sum] at h₁,
    simp only [linear_map.id_coe, id.def] at h₁,
    sorry,
  },
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h,
    have h₀ : x = {support := ∅, to_fun := λ (_x : fin 2), semiring.zero, mem_support_to_fun := _} := by exact h,
    dsimp only [linear_map.ker, submodule.comap, set.preimage],
    suffices h' : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x ∈ ↑⊥,
    exact h',
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    dsimp only [vec_zero],
    suffices h' : (finsupp.total (fin 2) (vec_n ℚ 2) ℚ v) x = λ (_x : fin 2), mk_vec ℚ 0,
    exact h',
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe],
    rw h₀,
    dsimp [finsupp.sum],
    refl,
  }
  end
  begin
    /-rw eq_top_iff,
    intros x _,
    dsimp only [submodule.span, Inf, set.range, set.Inter],
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp only [forall_apply_eq_imp_iff', and_imp, set_like.mem_coe, submodule.mem_carrier, set.mem_set_of_eq, exists_imp_distrib, exists_const],
    suffices h : ∀ (a_1 : submodule ℚ (vec_n ℚ 2)), {x : vec_n ℚ 2 | ∃ (y : fin 2), v y = x} ⊆ ↑a_1 → x ∈ a_1,
    exact h,
    intros a_1 h,
    dsimp only [has_subset.subset, set.subset] at h,
    suffices h' : x ∈ {x : vec_n ℚ 2 | ∃ (y : fin 2), v y = x},
    {
      have h₀ := h h',
      exact h₀,
    },
    suffices h' : ∃ (y : fin 2), v y = x,
    exact h',
    dsimp only [v, ite],
    sorry,-/
    dsimp only [submodule.span, Inf],
    dsimp only [has_top.top, set.univ],
    dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
    dsimp only [set.range, set.Inter],
    simp only [nonempty_of_inhabited, set.mem_set_of_eq, exists_const],
    ext,
    split,
    {
      intros,
      exact true.intro,
    },
    {
      intros,
      intro,
      dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
      simp *,
      dsimp [set_of],
      intros c d,
      dsimp [has_subset.subset, set.subset] at d,--, has_mem.mem, set.mem] at d,
      --rw ←d at t,
      --rw d.symm,
      let smdef : set (vec_n ℚ 2) :=
        (λ (a : vec_n ℚ 2),
        (∀ ⦃a : vec_n ℚ 2⦄, (∃ (y : fin 2),
          (λ (j : fin 2), ite (y = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)
          ) = a) → c.carrier a)
            → (↑c : set _) a),
      let tt : t = smdef := by exact d.symm,
      simp *,
      dsimp [has_mem.mem, set.mem],
      assume cmem : _,
      let v0 := v ⟨0, by linarith⟩,
      let v1 := v ⟨1, by linarith⟩,
      let v0mem : v0 ∈ c := begin
        --let h0 :
        let c0 : vec_n ℚ 2 :=
          (λ (j : fin 2), ite (0 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
        let h0 : c.carrier c0 := cmem 0,
        let h1 : c0 = v0 :=
          begin
            suffices sh : ∀ i, c0 i = v0 i, from funext sh,
            intros,
            cases i,
            cases i_val,
            refl,
            cases i_val,
            refl,
            let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
            rw ←ht at i_property,
            let : false := by exact eznat2 _ _ i_property,
            contradiction,
          end,
        rw ←h1,
        exact (mem_carrier c).mp h0,
      end,
      let v1mem : v1 ∈ c := begin
        --let h0 :
        let c1 : vec_n ℚ 2 :=
          (λ (j : fin 2), ite (1 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
        let h0 : c.carrier c1 := cmem ⟨1, by linarith⟩,
        let h1 : c1 = v1 :=
          begin
            suffices sh : ∀ i, c1 i = v1 i, from funext sh,
            intros,
            cases i,
            cases i_val,
            refl,
            cases i_val,
            refl,
            let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
            rw ←ht at i_property,
            let : false := by exact eznat2 _ _ i_property,
            contradiction,
          end,
        rw ←h1,
        exact (mem_carrier c).mp h0,
      end,

      --let x0 := x ⟨0, by linarith⟩,
      --let x1 := x ⟨1, by linarith⟩,
      destruct x ⟨0, by linarith⟩,
      intros c0 e0,
      destruct x ⟨1, by linarith⟩,
      intros c1 e1,
      let v00 := v0 ⟨0, by linarith⟩,
      let v10 := v1 ⟨0, by linarith⟩,
      let c0smulv0 := λ (j : fin 2), ite (0 = j) ({coord := c0}: vec ℚ) ({coord := 0}: vec ℚ),
      let c0smulv0_eq :
        (c0 • v0 = c0smulv0)
          := begin
          -- simp *,
            suffices sh : ∀ i, (c0 • v0) i = c0smulv0 i, from funext sh,
            intros,
            cases i,
            cases i_val,
            simp *,
            let h0 : ite (0 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c0} : vec ℚ) := rfl,
            simp *,
            dsimp [has_scalar.smul],
            simp *,
            cases i_val,
            simp *,
            let h0 : ite (1 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
            simp *,
            dsimp [has_scalar.smul],
            simp *,
            let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
            rw ←ht at i_property,
            let : false := by exact eznat2 _ _ i_property,
            contradiction,

          end,
      let c0smulv0mem : c0smulv0 ∈ c :=
        begin
          rw ←c0smulv0_eq,
          exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v0 c0 v0mem
        end,

      let c1smulv1 := λ (j : fin 2), ite (1 = j) ({coord := c1}: vec ℚ) ({coord := 0}: vec ℚ),
      let c1smulv1_eq :
        (c1 • v1 = c1smulv1)
          := begin
          -- simp *,
            suffices sh : ∀ i, (c1 • v1) i = c1smulv1 i, from funext sh,
            intros,
            cases i,
            cases i_val,
            simp *,
            --let h0 : ite (1 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c1} : vec ℚ) := rfl,
            --simp *,
            dsimp [has_scalar.smul],
            simp *,
            cases i_val,
            simp *,
            --let h0 : ite (0 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
            --simp *,
            dsimp [has_scalar.smul],
            simp *,
            let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
            rw ←ht at i_property,
            let : false := by exact eznat2 _ _ i_property,
            contradiction,
          end,
      let c1smulv1mem : c1smulv1 ∈ c :=
        begin
          rw ←c1smulv1_eq,
          exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v1 c1 v1mem
        end,

      let comb_mem : c0smulv0 + c1smulv1 ∈ c :=
        by exact @submodule.add_mem ℚ (vec_n ℚ 2) _ _ _ c  _ _ c0smulv0mem c1smulv1mem,

      let x_combeq : x = c0smulv0 + c1smulv1 := begin
        suffices sh : ∀ i, x i = (c0smulv0 + c1smulv1) i, from funext sh,
        intros,
        cases i,
        cases i_val,
        /-
        x ⟨0, i_property⟩ = (c0smulv0 + c1smulv1) ⟨0, i_property⟩
        -/
        rw e0,
        simp *, refl,
        cases i_val,
        rw e1,
        simp *, refl,
        let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
        rw ←ht at i_property,
        let : false := by exact eznat2 _ _ i_property,
        contradiction,
      end,

      rw x_combeq,
      exact comb_mem,
    },
  end

variables (sm : submodule ℚ (vec_n ℚ 1)) (v : (vec_n ℚ 1))

let h15 := funext one

#check nat.add_succ_sub_one

#check funext
#check (1:ℚ) • v

#check nat.add_succ_lt_add
#check nat.succ_succ_ne_one

#check smul_prod

#check lt_tra

#check lt_one_add
#check nat.lt_add_left

#check nat.succ_succ

#check iff.mpr

#check lt_add_one

#check nat.succ

#check submodule
/-
(
  λ (a : vec_n ℚ 2),
  (∀ ⦃a : vec_n ℚ 2⦄,
    set.mem a
    (
      λ (x : vec_n ℚ 2),
      ∃ (y : fin 2),
      (
        λ (j : fin 2),
        ite (y = j) {coord := 1} {coord := 0}
      )
      = x
    )
    →
    set.mem a c.carrier
  )
  →
  set.mem a ↑c
)
= t

-/

#check nat.lt_add_of_zero_lt_left

#check @submodule.smul_mem

#check smul_add

#check finset

#check v ∈ sm

#check (↑sm:set (vec_n ℚ 1)) v

def dajks : fin 2 → ℕ
| ⟨0, _⟩ := 1
| ⟨1, _⟩ := 2
| ⟨n, _⟩ := 0

def dasjsj : ∀i ∈ finset.range 2, ℕ
:= λi : _, λ j, begin
  cases i,
  exact 0,
  cases i,
  exact 0,

end

#check nat.lt

#check nat_ceil_lt_add_one
#check nat_mul_inj

#check lt_irrefl

#check lt_add_one
#check submodule

#check module

#check {[1]} ⊆  {[1], [2]}

#check ⦃a : vec_n ℚ 1⦄

#check eq_bot_iff

#check eq

#check set.set_of_mem_eq

def n := 1
def K := ℚ

def myfinset : finset ℕ := finset.range 4
@[reducible]
abbreviation pt_nf := ∀i ∈{i|i∈myfinset}, pt ℚ
@[reducible]
abbreviation vec_nf := fin (n) → vec ℚ

#check set.range

#eval 0 ∈ myfinset
#eval myfinset

def mk_pt_nf (vals : vector ℚ n) : pt_nf :=
  λj : _, λmf:_, begin

  end

def mk_vec_nf (vals : vector ℚ n) : vec_nf ℚ n :=
  λi, mk_vec ℚ (vals.nth i)

def pt_nf.coords
 (ptn : pt_nf ) : fin n → ℚ :=
  λi : fin n, (ptn i).coord

def vec_nf.coords (vecn : vec_nf ) : fin n → K :=
  λi, (vecn i).coord

structure vec_nf_basis :=
  (basis_vecs:fin n → vec_nf )
  (basis_independent : linear_independent ℚ basis_vecs)
  (basis_spans : submodule.span ℚ (set.range basis_vecs) = ⊤)

instance : has_lift_t (vec_nf_basis K n) (fin n → vec_n K n) := ⟨λvb, vb.basis_vecs⟩

open_locale affine
--done
instance : add_comm_group (vec_nf) := by apply_instance
instance : affine_space (vec_nf) (pt_nf) := by apply_instance

/-
Frame built from primitive (fin n)-indexed maps pts and vecs.
Constructors are Base (standard) frame or a derived frame.
-/
inductive fm : Π (dim : ℕ) , Type
| base : Π (dim : ℕ), fm dim

@[simp]
def fm.basis
{dim : ℕ} :
fm  dim → (vec_n_basis ℚ dim)
| (fm.base dim ) := ⟨(λ i j, if j = i then mk_vec K 1 else mk_vec K 0), sorry, sorry⟩


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.hom.group_action
import ring_theory.subring.pointwise

/-! # Subrings invariant under an action

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

variables (M R : Type*) [monoid M] [ring R] [mul_semiring_action M R]
variables (S : subring R)
open mul_action
variables {R}

/-- A typeclass for subrings invariant under a `mul_semiring_action`. -/
class is_invariant_subring : Prop :=
(smul_mem : ∀ (m : M) {x : R}, x ∈ S → m • x ∈ S)

instance is_invariant_subring.to_mul_semiring_action [is_invariant_subring M S] :
  mul_semiring_action M S :=
{ smul := λ m x, ⟨m • x, is_invariant_subring.smul_mem m x.2⟩,
  one_smul := λ s, subtype.eq $ one_smul M s,
  mul_smul := λ m₁ m₂ s, subtype.eq $ mul_smul m₁ m₂ s,
  smul_add := λ m s₁ s₂, subtype.eq $ smul_add m s₁ s₂,
  smul_zero := λ m, subtype.eq $ smul_zero m,
  smul_one := λ m, subtype.eq $ smul_one m,
  smul_mul := λ m s₁ s₂, subtype.eq $ smul_mul' m s₁ s₂ }

end ring

section
variables (M : Type*) [monoid M]
variables {R' : Type*} [ring R'] [mul_semiring_action M R']
variables (U : subring R') [is_invariant_subring M U]

/-- The canonical inclusion from an invariant subring. -/
def is_invariant_subring.subtype_hom : U →+*[M] R' :=
{ map_smul' := λ m s, rfl, ..U.subtype }

@[simp] theorem is_invariant_subring.coe_subtype_hom :
  (is_invariant_subring.subtype_hom M U : U → R') = coe := rfl

@[simp] theorem is_invariant_subring.coe_subtype_hom' :
  (is_invariant_subring.subtype_hom M U : U →+* R') = U.subtype := rfl

end


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_209
  (σ : equiv ℝ ℝ)
  (h₀ : σ.2 2 = 10)
  (h₁ : σ.2 10 = 1)
  (h₂ : σ.2 1 = 2) :
  σ.1 (σ.1 10) = 1 :=
begin
  rw [← h₀, ← h₂],
  simp,
end


/-
Copyright (c) 2023 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/

import probability.kernel.basic

/-!
# Product and composition of kernels

We define
* the composition-product `κ ⊗ₖ η` of two s-finite kernels `κ : kernel α β` and
  `η : kernel (α × β) γ`, a kernel from `α` to `β × γ`.
* the map and comap of a kernel along a measurable function.
* the composition `η ∘ₖ κ` of s-finite kernels `κ : kernel α β` and `η : kernel β γ`,
  a kernel from `α` to `γ`.
* the product `prod κ η` of s-finite kernels `κ : kernel α β` and `η : kernel α γ`,
  a kernel from `α` to `β × γ`.

A note on names:
The composition-product `kernel α β → kernel (α × β) γ → kernel α (β × γ)` is named composition in
[kallenberg2021] and product on the wikipedia article on transition kernels.
Most papers studying categories of kernels call composition the map we call composition. We adopt
that convention because it fits better with the use of the name `comp` elsewhere in mathlib.

## Main definitions

Kernels built from other kernels:
* `comp_prod (κ : kernel α β) (η : kernel (α × β) γ) : kernel α (β × γ)`: composition-product of 2
  s-finite kernels. We define a notation `κ ⊗ₖ η = comp_prod κ η`.
  `∫⁻ bc, f bc ∂((κ ⊗ₖ η) a) = ∫⁻ b, ∫⁻ c, f (b, c) ∂(η (a, b)) ∂(κ a)`
* `map (κ : kernel α β) (f : β → γ) (hf : measurable f) : kernel α γ`
  `∫⁻ c, g c ∂(map κ f hf a) = ∫⁻ b, g (f b) ∂(κ a)`
* `comap (κ : kernel α β) (f : γ → α) (hf : measurable f) : kernel γ β`
  `∫⁻ b, g b ∂(comap κ f hf c) = ∫⁻ b, g b ∂(κ (f c))`
* `comp (η : kernel β γ) (κ : kernel α β) : kernel α γ`: composition of 2 s-finite kernels.
  We define a notation `η ∘ₖ κ = comp η κ`.
  `∫⁻ c, g c ∂((η ∘ₖ κ) a) = ∫⁻ b, ∫⁻ c, g c ∂(η b) ∂(κ a)`
* `prod (κ : kernel α β) (η : kernel α γ) : kernel α (β × γ)`: product of 2 s-finite kernels.
  `∫⁻ bc, f bc ∂(prod κ η a) = ∫⁻ b, ∫⁻ c, f (b, c) ∂(η a) ∂(κ a)`

## Main statements

* `lintegral_comp_prod`, `lintegral_map`, `lintegral_comap`, `lintegral_comp`, `lintegral_prod`:
  Lebesgue integral of a function against a composition-product/map/comap/composition/product of
  kernels.
* Instances of the form `<class>.<operation>` where class is one of `is_markov_kernel`,
  `is_finite_kernel`, `is_s_finite_kernel` and operation is one of `comp_prod`, `map`, `comap`,
  `comp`, `prod`. These instances state that the three classes are stable by the various operations.

## Notations

* `κ ⊗ₖ η = probability_theory.kernel.comp_prod κ η`
* `η ∘ₖ κ = probability_theory.kernel.comp η κ`

-/

open measure_theory

open_locale ennreal

namespace probability_theory

namespace kernel

variables {α β ι : Type*} {mα : measurable_space α} {mβ : measurable_space β}

include mα mβ

section composition_product

/-!
### Composition-Product of kernels

We define a kernel composition-product
`comp_prod : kernel α β → kernel (α × β) γ → kernel α (β × γ)`.
-/

variables {γ : Type*} {mγ : measurable_space γ} {s : set (β × γ)}

include mγ

/-- Auxiliary function for the definition of the composition-product of two kernels.
For all `a : α`, `comp_prod_fun κ η a` is a countably additive function with value zero on the empty
set, and the composition-product of kernels is defined in `kernel.comp_prod` through
`measure.of_measurable`. -/
noncomputable
def comp_prod_fun (κ : kernel α β) (η : kernel (α × β) γ) (a : α) (s : set (β × γ)) : ℝ≥0∞ :=
∫⁻ b, η (a, b) {c | (b, c) ∈ s} ∂(κ a)

lemma comp_prod_fun_empty (κ : kernel α β) (η : kernel (α × β) γ) (a : α) :
  comp_prod_fun κ η a ∅ = 0 :=
by simp only [comp_prod_fun, set.mem_empty_iff_false, set.set_of_false, measure_empty,
  lintegral_const, zero_mul]

lemma comp_prod_fun_Union (κ : kernel α β) (η : kernel (α × β) γ) [is_s_finite_kernel η] (a : α)
  (f : ℕ → set (β × γ)) (hf_meas : ∀ i, measurable_set (f i)) (hf_disj : pairwise (disjoint on f)) :
  comp_prod_fun κ η a (⋃ i, f i) = ∑' i, comp_prod_fun κ η a (f i) :=
begin
  have h_Union : (λ b, η (a, b) {c : γ | (b, c) ∈ ⋃ i, f i})
    = λ b, η (a,b) (⋃ i, {c : γ | (b, c) ∈ f i}),
  { ext1 b,
    congr' with c,
    simp only [set.mem_Union, set.supr_eq_Union, set.mem_set_of_eq],
    refl, },
  rw [comp_prod_fun, h_Union],
  have h_tsum : (λ b, η (a, b) (⋃ i, {c : γ | (b, c) ∈ f i}))
    = λ b, ∑' i, η (a, b) {c : γ | (b, c) ∈ f i},
  { ext1 b,
    rw measure_Union,
    { intros i j hij s hsi hsj c hcs,
      have hbci : {(b, c)} ⊆ f i, by { rw set.singleton_subset_iff, exact hsi hcs, },
      have hbcj : {(b, c)} ⊆ f j, by { rw set.singleton_subset_iff, exact hsj hcs, },
      simpa only [set.bot_eq_empty, set.le_eq_subset, set.singleton_subset_iff,
        set.mem_empty_iff_false] using hf_disj hij hbci hbcj, },
    { exact λ i, (@measurable_prod_mk_left β γ _ _ b) _ (hf_meas i), }, },
  rw [h_tsum, lintegral_tsum],
  { refl, },
  { intros i,
    have hm : measurable_set {p : (α × β) × γ | (p.1.2, p.2) ∈ f i},
      from measurable_fst.snd.prod_mk measurable_snd (hf_meas i),
    exact ((measurable_prod_mk_mem η hm).comp measurable_prod_mk_left).ae_measurable, },
end

lemma comp_prod_fun_tsum_right (κ : kernel α β) (η : kernel (α × β) γ) [is_s_finite_kernel η]
  (a : α) (hs : measurable_set s) :
  comp_prod_fun κ η a s = ∑' n, comp_prod_fun κ (seq η n) a s :=
begin
  simp_rw [comp_prod_fun, (measure_sum_seq η _).symm],
  have : ∫⁻ b, measure.sum (λ n, seq η n (a, b)) {c : γ | (b, c) ∈ s} ∂(κ a)
    = ∫⁻ b, ∑' n, seq η n (a, b) {c : γ | (b, c) ∈ s} ∂(κ a),
  { congr',
    ext1 b,
    rw measure.sum_apply,
    exact measurable_prod_mk_left hs, },
  rw [this, lintegral_tsum (λ n : ℕ, _)],
  exact ((measurable_prod_mk_mem (seq η n) ((measurable_fst.snd.prod_mk measurable_snd) hs)).comp
    measurable_prod_mk_left).ae_measurable,
end

lemma comp_prod_fun_tsum_left (κ : kernel α β) (η : kernel (α × β) γ) [is_s_finite_kernel κ]
  (a : α) (s : set (β × γ)) :
  comp_prod_fun κ η a s = ∑' n, comp_prod_fun (seq κ n) η a s :=
by simp_rw [comp_prod_fun, (measure_sum_seq κ _).symm, lintegral_sum_measure]

lemma comp_prod_fun_eq_tsum (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] (a : α) (hs : measurable_set s) :
  comp_prod_fun κ η a s = ∑' n m, comp_prod_fun (seq κ n) (seq η m) a s :=
by simp_rw [comp_prod_fun_tsum_left κ η a s, comp_prod_fun_tsum_right _ η a hs]

/-- Auxiliary lemma for `measurable_comp_prod_fun`. -/
lemma measurable_comp_prod_fun_of_finite (κ : kernel α β) [is_finite_kernel κ]
  (η : kernel (α × β) γ) [is_finite_kernel η] (hs : measurable_set s) :
  measurable (λ a, comp_prod_fun κ η a s) :=
begin
  simp only [comp_prod_fun],
  have h_meas : measurable (function.uncurry (λ a b, η (a, b) {c : γ | (b, c) ∈ s})),
  { have : function.uncurry (λ a b, η (a, b) {c : γ | (b, c) ∈ s})
      = λ p, η p {c : γ | (p.2, c) ∈ s},
    { ext1 p,
      have hp_eq_mk : p = (p.fst, p.snd) := prod.mk.eta.symm,
      rw [hp_eq_mk, function.uncurry_apply_pair], },
    rw this,
    exact measurable_prod_mk_mem η (measurable_fst.snd.prod_mk measurable_snd hs), },
  exact measurable_lintegral κ h_meas,
end

lemma measurable_comp_prod_fun (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] (hs : measurable_set s) :
  measurable (λ a, comp_prod_fun κ η a s) :=
begin
  simp_rw comp_prod_fun_tsum_right κ η _ hs,
  refine measurable.ennreal_tsum (λ n, _),
  simp only [comp_prod_fun],
  have h_meas : measurable (function.uncurry (λ a b, seq η n (a, b) {c : γ | (b, c) ∈ s})),
  { have : function.uncurry (λ a b, seq η n (a, b) {c : γ | (b, c) ∈ s})
      = λ p, seq η n p {c : γ | (p.2, c) ∈ s},
    { ext1 p,
      have hp_eq_mk : p = (p.fst, p.snd) := prod.mk.eta.symm,
      rw [hp_eq_mk, function.uncurry_apply_pair], },
    rw this,
    exact measurable_prod_mk_mem (seq η n) (measurable_fst.snd.prod_mk measurable_snd hs), },
  exact measurable_lintegral κ h_meas,
end

/-- Composition-Product of kernels. It verifies
`∫⁻ bc, f bc ∂(comp_prod κ η a) = ∫⁻ b, ∫⁻ c, f (b, c) ∂(η (a, b)) ∂(κ a)`
(see `lintegral_comp_prod`). -/
noncomputable
def comp_prod (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] :
  kernel α (β × γ) :=
{ val := λ a, measure.of_measurable (λ s hs, comp_prod_fun κ η a s) (comp_prod_fun_empty κ η a)
    (comp_prod_fun_Union κ η a),
  property :=
  begin
    refine measure.measurable_of_measurable_coe _ (λ s hs, _),
    have : (λ a, measure.of_measurable (λ s hs, comp_prod_fun κ η a s) (comp_prod_fun_empty κ η a)
        (comp_prod_fun_Union κ η a) s) = λ a, comp_prod_fun κ η a s,
    { ext1 a, rwa measure.of_measurable_apply, },
    rw this,
    exact measurable_comp_prod_fun κ η hs,
  end, }

localized "infix (name := kernel.comp_prod) ` ⊗ₖ `:100 := probability_theory.kernel.comp_prod" in
  probability_theory

lemma comp_prod_apply_eq_comp_prod_fun (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] (a : α) (hs : measurable_set s) :
  (κ ⊗ₖ η) a s = comp_prod_fun κ η a s :=
begin
  rw [comp_prod],
  change measure.of_measurable (λ s hs, comp_prod_fun κ η a s) (comp_prod_fun_empty κ η a)
    (comp_prod_fun_Union κ η a) s = ∫⁻ b, η (a, b) {c | (b, c) ∈ s} ∂(κ a),
  rw measure.of_measurable_apply _ hs,
  refl,
end

lemma comp_prod_apply (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel (α × β) γ)
  [is_s_finite_kernel η] (a : α) (hs : measurable_set s) :
  (κ ⊗ₖ η) a s = ∫⁻ b, η (a, b) {c | (b, c) ∈ s} ∂(κ a) :=
comp_prod_apply_eq_comp_prod_fun κ η a hs

/-- Lebesgue integral against the composition-product of two kernels. -/
theorem lintegral_comp_prod' (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel (α × β) γ)
  [is_s_finite_kernel η] (a : α) {f : β → γ → ℝ≥0∞} (hf : measurable (function.uncurry f)) :
  ∫⁻ bc, f bc.1 bc.2 ∂((κ ⊗ₖ η) a) = ∫⁻ b, ∫⁻ c, f b c ∂(η (a, b)) ∂(κ a) :=
begin
  let F : ℕ → simple_func (β × γ) ℝ≥0∞ := simple_func.eapprox (function.uncurry f),
  have h : ∀ a, (⨆ n, F n a) = function.uncurry f a,
    from simple_func.supr_eapprox_apply (function.uncurry f) hf,
  simp only [prod.forall, function.uncurry_apply_pair] at h,
  simp_rw [← h, prod.mk.eta],
  have h_mono : monotone F := λ i j hij b, simple_func.monotone_eapprox (function.uncurry f) hij _,
  rw lintegral_supr (λ n, (F n).measurable) h_mono,
  have : ∀ b, ∫⁻ c, (⨆ n, F n (b, c)) ∂(η (a, b)) = ⨆ n, ∫⁻ c, F n (b, c) ∂(η (a, b)),
  { intro a,
    rw lintegral_supr,
    { exact λ n, (F n).measurable.comp measurable_prod_mk_left, },
    { exact λ i j hij b, h_mono hij _, }, },
  simp_rw this,
  have h_some_meas_integral : ∀ f' : simple_func (β × γ) ℝ≥0∞,
    measurable (λ b, ∫⁻ c, f' (b, c) ∂(η (a, b))),
  { intros f',
    have : (λ b, ∫⁻ c, f' (b, c) ∂(η (a, b)))
        = (λ ab, ∫⁻ c, f' (ab.2, c) ∂(η (ab))) ∘ (λ b, (a, b)),
      { ext1 ab, refl, },
      rw this,
      refine measurable.comp _ measurable_prod_mk_left,
      exact (measurable_lintegral η
        ((simple_func.measurable _).comp (measurable_fst.snd.prod_mk measurable_snd))), },
  rw lintegral_supr,
  rotate,
  { exact λ n, h_some_meas_integral (F n), },
  { exact λ i j hij b, lintegral_mono (λ c, h_mono hij _), },
  congr,
  ext1 n,
  refine simple_func.induction _ _ (F n),
  { intros c s hs,
    simp only [simple_func.const_zero, simple_func.coe_piecewise, simple_func.coe_const,
      simple_func.coe_zero, set.piecewise_eq_indicator, lintegral_indicator_const hs],
    rw [comp_prod_apply κ η _ hs, ← lintegral_const_mul c _],
    swap, { exact (measurable_prod_mk_mem η ((measurable_fst.snd.prod_mk measurable_snd) hs)).comp
      measurable_prod_mk_left, },
    congr,
    ext1 b,
    rw lintegral_indicator_const_comp measurable_prod_mk_left hs,
    refl, },
  { intros f f' h_disj hf_eq hf'_eq,
    simp_rw [simple_func.coe_add, pi.add_apply],
    change ∫⁻ x, ((f : (β × γ) → ℝ≥0∞) x + f' x) ∂((κ ⊗ₖ η) a)
      = ∫⁻ b, ∫⁻ (c : γ), f (b, c) + f' (b, c) ∂(η (a, b)) ∂(κ a),
    rw [lintegral_add_left (simple_func.measurable _), hf_eq, hf'_eq, ← lintegral_add_left],
    swap, { exact h_some_meas_integral f, },
    congr' with b,
    rw ← lintegral_add_left ((simple_func.measurable _).comp measurable_prod_mk_left), },
end

/-- Lebesgue integral against the composition-product of two kernels. -/
theorem lintegral_comp_prod (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel (α × β) γ)
  [is_s_finite_kernel η] (a : α) {f : β × γ → ℝ≥0∞} (hf : measurable f) :
  ∫⁻ bc, f bc ∂((κ ⊗ₖ η) a) = ∫⁻ b, ∫⁻ c, f (b, c) ∂(η (a, b)) ∂(κ a) :=
begin
  let g := function.curry f,
  change ∫⁻ bc, f bc ∂((κ ⊗ₖ η) a) = ∫⁻ b, ∫⁻ c, g b c ∂(η (a, b)) ∂(κ a),
  rw ← lintegral_comp_prod',
  { simp_rw [g, function.curry_apply, prod.mk.eta], },
  { simp_rw [g, function.uncurry_curry], exact hf, },
end

lemma comp_prod_eq_tsum_comp_prod (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel (α × β) γ)
  [is_s_finite_kernel η] (a : α) (hs : measurable_set s) :
  (κ ⊗ₖ η) a s = ∑' (n m : ℕ), (seq κ n ⊗ₖ seq η m) a s :=
by { simp_rw comp_prod_apply_eq_comp_prod_fun _ _ _ hs, exact comp_prod_fun_eq_tsum κ η a hs, }

lemma comp_prod_eq_sum_comp_prod (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] :
  κ ⊗ₖ η = kernel.sum (λ n, kernel.sum (λ m, seq κ n ⊗ₖ seq η m)) :=
by { ext a s hs : 2, simp_rw [kernel.sum_apply' _ a hs], rw comp_prod_eq_tsum_comp_prod κ η a hs, }

lemma comp_prod_eq_sum_comp_prod_left (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] :
  κ ⊗ₖ η = kernel.sum (λ n, seq κ n ⊗ₖ η) :=
begin
  rw comp_prod_eq_sum_comp_prod,
  congr' with n a s hs,
  simp_rw [kernel.sum_apply' _ _ hs, comp_prod_apply_eq_comp_prod_fun _ _ _ hs,
    comp_prod_fun_tsum_right _ η a hs],
end

lemma comp_prod_eq_sum_comp_prod_right (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] :
  κ ⊗ₖ η = kernel.sum (λ n, κ ⊗ₖ seq η n) :=
begin
  rw comp_prod_eq_sum_comp_prod,
  simp_rw comp_prod_eq_sum_comp_prod_left κ _,
  rw kernel.sum_comm,
end

instance is_markov_kernel.comp_prod (κ : kernel α β) [is_markov_kernel κ]
  (η : kernel (α × β) γ) [is_markov_kernel η] :
  is_markov_kernel (κ ⊗ₖ η) :=
⟨λ a, ⟨begin
  rw comp_prod_apply κ η a measurable_set.univ,
  simp only [set.mem_univ, set.set_of_true, measure_univ, lintegral_one],
end⟩⟩

lemma comp_prod_apply_univ_le (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_finite_kernel η] (a : α) :
  (κ ⊗ₖ η) a set.univ ≤ (κ a set.univ) * (is_finite_kernel.bound η) :=
begin
  rw comp_prod_apply κ η a measurable_set.univ,
  simp only [set.mem_univ, set.set_of_true],
  let Cη := is_finite_kernel.bound η,
  calc ∫⁻ b, η (a, b) set.univ ∂(κ a)
      ≤ ∫⁻ b, Cη ∂(κ a) : lintegral_mono (λ b, measure_le_bound η (a, b) set.univ)
  ... = Cη * κ a set.univ : lintegral_const Cη
  ... = κ a set.univ * Cη : mul_comm _ _,
end

instance is_finite_kernel.comp_prod (κ : kernel α β) [is_finite_kernel κ]
  (η : kernel (α × β) γ) [is_finite_kernel η] :
  is_finite_kernel (κ ⊗ₖ η) :=
⟨⟨is_finite_kernel.bound κ * is_finite_kernel.bound η,
  ennreal.mul_lt_top (is_finite_kernel.bound_ne_top κ) (is_finite_kernel.bound_ne_top η),
  λ a, calc (κ ⊗ₖ η) a set.univ
    ≤ (κ a set.univ) * is_finite_kernel.bound η : comp_prod_apply_univ_le κ η a
... ≤ is_finite_kernel.bound κ * is_finite_kernel.bound η :
        mul_le_mul (measure_le_bound κ a set.univ) le_rfl (zero_le _) (zero_le _), ⟩⟩

instance is_s_finite_kernel.comp_prod (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel (α × β) γ) [is_s_finite_kernel η] :
  is_s_finite_kernel (κ ⊗ₖ η) :=
begin
  rw comp_prod_eq_sum_comp_prod,
  exact kernel.is_s_finite_kernel_sum (λ n, kernel.is_s_finite_kernel_sum infer_instance),
end

end composition_product

section map_comap
/-! ### map, comap -/

variables {γ : Type*} {mγ : measurable_space γ} {f : β → γ} {g : γ → α}

include mγ

/-- The pushforward of a kernel along a measurable function.
We include measurability in the assumptions instead of using junk values
to make sure that typeclass inference can infer that the `map` of a Markov kernel
is again a Markov kernel. -/
noncomputable
def map (κ : kernel α β) (f : β → γ) (hf : measurable f) : kernel α γ :=
{ val := λ a, (κ a).map f,
  property := (measure.measurable_map _ hf).comp (kernel.measurable κ) }

lemma map_apply (κ : kernel α β) (hf : measurable f) (a : α) :
  map κ f hf a = (κ a).map f := rfl

lemma map_apply' (κ : kernel α β) (hf : measurable f) (a : α) {s : set γ} (hs : measurable_set s) :
  map κ f hf a s = κ a (f ⁻¹' s) :=
by rw [map_apply, measure.map_apply hf hs]

lemma lintegral_map (κ : kernel α β) (hf : measurable f) (a : α)
  {g' : γ → ℝ≥0∞} (hg : measurable g') :
  ∫⁻ b, g' b ∂(map κ f hf a) = ∫⁻ a, g' (f a) ∂(κ a) :=
by rw [map_apply _ hf, lintegral_map hg hf]

lemma sum_map_seq (κ : kernel α β) [is_s_finite_kernel κ] (hf : measurable f) :
  kernel.sum (λ n, map (seq κ n) f hf) = map κ f hf :=
begin
  ext a s hs : 2,
  rw [kernel.sum_apply, map_apply' κ hf a hs, measure.sum_apply _ hs, ← measure_sum_seq κ,
    measure.sum_apply _ (hf hs)],
  simp_rw map_apply' _ hf _ hs,
end

instance is_markov_kernel.map (κ : kernel α β) [is_markov_kernel κ] (hf : measurable f) :
  is_markov_kernel (map κ f hf) :=
 ⟨λ a, ⟨by rw [map_apply' κ hf a measurable_set.univ, set.preimage_univ, measure_univ]⟩⟩

instance is_finite_kernel.map (κ : kernel α β) [is_finite_kernel κ] (hf : measurable f) :
  is_finite_kernel (map κ f hf) :=
begin
  refine ⟨⟨is_finite_kernel.bound κ, is_finite_kernel.bound_lt_top κ, λ a, _⟩⟩,
  rw map_apply' κ hf a measurable_set.univ,
  exact measure_le_bound κ a _,
end

instance is_s_finite_kernel.map (κ : kernel α β) [is_s_finite_kernel κ] (hf : measurable f) :
  is_s_finite_kernel (map κ f hf) :=
⟨⟨λ n, map (seq κ n) f hf, infer_instance, (sum_map_seq κ hf).symm⟩⟩

/-- Pullback of a kernel, such that for each set s `comap κ g hg c s = κ (g c) s`.
We include measurability in the assumptions instead of using junk values
to make sure that typeclass inference can infer that the `comap` of a Markov kernel
is again a Markov kernel. -/
def comap (κ : kernel α β) (g : γ → α) (hg : measurable g) : kernel γ β :=
{ val := λ a, κ (g a),
  property := (kernel.measurable κ).comp hg }

lemma comap_apply (κ : kernel α β) (hg : measurable g) (c : γ) :
  comap κ g hg c = κ (g c) := rfl

lemma comap_apply' (κ : kernel α β) (hg : measurable g) (c : γ) (s : set β) :
  comap κ g hg c s = κ (g c) s := rfl

lemma lintegral_comap (κ : kernel α β) (hg : measurable g) (c : γ) (g' : β → ℝ≥0∞) :
  ∫⁻ b, g' b ∂(comap κ g hg c) = ∫⁻ b, g' b ∂(κ (g c)) := rfl

lemma sum_comap_seq (κ : kernel α β) [is_s_finite_kernel κ] (hg : measurable g) :
  kernel.sum (λ n, comap (seq κ n) g hg) = comap κ g hg :=
begin
  ext a s hs : 2,
  rw [kernel.sum_apply, comap_apply' κ hg a s, measure.sum_apply _ hs, ← measure_sum_seq κ,
    measure.sum_apply _ hs],
  simp_rw comap_apply' _ hg _ s,
end

instance is_markov_kernel.comap (κ : kernel α β) [is_markov_kernel κ] (hg : measurable g) :
  is_markov_kernel (comap κ g hg) :=
⟨λ a, ⟨by rw [comap_apply' κ hg a set.univ, measure_univ]⟩⟩

instance is_finite_kernel.comap (κ : kernel α β) [is_finite_kernel κ] (hg : measurable g) :
  is_finite_kernel (comap κ g hg) :=
begin
  refine ⟨⟨is_finite_kernel.bound κ, is_finite_kernel.bound_lt_top κ, λ a, _⟩⟩,
  rw comap_apply' κ hg a set.univ,
  exact measure_le_bound κ _ _,
end

instance is_s_finite_kernel.comap (κ : kernel α β) [is_s_finite_kernel κ] (hg : measurable g) :
  is_s_finite_kernel (comap κ g hg) :=
⟨⟨λ n, comap (seq κ n) g hg, infer_instance, (sum_comap_seq κ hg).symm⟩⟩

end map_comap

open_locale probability_theory

section fst_snd

/-- Define a `kernel (γ × α) β` from a `kernel α β` by taking the comap of the projection. -/
def prod_mk_left (κ : kernel α β) (γ : Type*) [measurable_space γ] : kernel (γ × α) β :=
comap κ prod.snd measurable_snd

variables {γ : Type*} {mγ : measurable_space γ} {f : β → γ} {g : γ → α}

include mγ

lemma prod_mk_left_apply (κ : kernel α β) (ca : γ × α) :
  prod_mk_left κ γ ca = κ ca.snd := rfl

lemma prod_mk_left_apply' (κ : kernel α β) (ca : γ × α) (s : set β) :
  prod_mk_left κ γ ca s = κ ca.snd s := rfl

lemma lintegral_prod_mk_left (κ : kernel α β) (ca : γ × α) (g : β → ℝ≥0∞) :
  ∫⁻ b, g b ∂(prod_mk_left κ γ ca) = ∫⁻ b, g b ∂(κ ca.snd) := rfl

instance is_markov_kernel.prod_mk_left (κ : kernel α β) [is_markov_kernel κ] :
  is_markov_kernel (prod_mk_left κ γ) :=
by { rw prod_mk_left, apply_instance, }

instance is_finite_kernel.prod_mk_left (κ : kernel α β) [is_finite_kernel κ] :
  is_finite_kernel (prod_mk_left κ γ) :=
by { rw prod_mk_left, apply_instance, }

instance is_s_finite_kernel.prod_mk_left (κ : kernel α β) [is_s_finite_kernel κ] :
  is_s_finite_kernel (prod_mk_left κ γ) :=
by { rw prod_mk_left, apply_instance, }

/-- Define a `kernel (β × α) γ` from a `kernel (α × β) γ` by taking the comap of `prod.swap`. -/
def swap_left (κ : kernel (α × β) γ) : kernel (β × α) γ :=
comap κ prod.swap measurable_swap

lemma swap_left_apply (κ : kernel (α × β) γ) (a : β × α) :
  swap_left κ a = (κ a.swap) := rfl

lemma swap_left_apply' (κ : kernel (α × β) γ) (a : β × α) (s : set γ) :
  swap_left κ a s = κ a.swap s := rfl

lemma lintegral_swap_left (κ : kernel (α × β) γ) (a : β × α) (g : γ → ℝ≥0∞) :
  ∫⁻ c, g c ∂(swap_left κ a) = ∫⁻ c, g c ∂(κ a.swap) :=
by { rw [swap_left, lintegral_comap _ measurable_swap a], }

instance is_markov_kernel.swap_left (κ : kernel (α × β) γ) [is_markov_kernel κ] :
  is_markov_kernel (swap_left κ) :=
by { rw swap_left, apply_instance, }

instance is_finite_kernel.swap_left (κ : kernel (α × β) γ) [is_finite_kernel κ] :
  is_finite_kernel (swap_left κ) :=
by { rw swap_left, apply_instance, }

instance is_s_finite_kernel.swap_left (κ : kernel (α × β) γ) [is_s_finite_kernel κ] :
  is_s_finite_kernel (swap_left κ) :=
by { rw swap_left, apply_instance, }

/-- Define a `kernel α (γ × β)` from a `kernel α (β × γ)` by taking the map of `prod.swap`. -/
noncomputable
def swap_right (κ : kernel α (β × γ)) : kernel α (γ × β) :=
map κ prod.swap measurable_swap

lemma swap_right_apply (κ : kernel α (β × γ)) (a : α) :
  swap_right κ a = (κ a).map prod.swap := rfl

lemma swap_right_apply' (κ : kernel α (β × γ)) (a : α) {s : set (γ × β)} (hs : measurable_set s) :
  swap_right κ a s = κ a {p | p.swap ∈ s} :=
by { rw [swap_right_apply, measure.map_apply measurable_swap hs], refl, }

lemma lintegral_swap_right (κ : kernel α (β × γ)) (a : α) {g : γ × β → ℝ≥0∞} (hg : measurable g) :
  ∫⁻ c, g c ∂(swap_right κ a) = ∫⁻ (bc : β × γ), g bc.swap ∂(κ a) :=
by rw [swap_right, lintegral_map _ measurable_swap a hg]

instance is_markov_kernel.swap_right (κ : kernel α (β × γ)) [is_markov_kernel κ] :
  is_markov_kernel (swap_right κ) :=
by { rw swap_right, apply_instance, }

instance is_finite_kernel.swap_right (κ : kernel α (β × γ)) [is_finite_kernel κ] :
  is_finite_kernel (swap_right κ) :=
by { rw swap_right, apply_instance, }

instance is_s_finite_kernel.swap_right (κ : kernel α (β × γ)) [is_s_finite_kernel κ] :
  is_s_finite_kernel (swap_right κ) :=
by { rw swap_right, apply_instance, }

/-- Define a `kernel α β` from a `kernel α (β × γ)` by taking the map of the first projection. -/
noncomputable
def fst (κ : kernel α (β × γ)) : kernel α β :=
map κ prod.fst measurable_fst

lemma fst_apply (κ : kernel α (β × γ)) (a : α) :
  fst κ a = (κ a).map prod.fst := rfl

lemma fst_apply' (κ : kernel α (β × γ)) (a : α) {s : set β} (hs : measurable_set s) :
  fst κ a s = κ a {p | p.1 ∈ s} :=
by { rw [fst_apply, measure.map_apply measurable_fst hs], refl, }

lemma lintegral_fst (κ : kernel α (β × γ)) (a : α) {g : β → ℝ≥0∞} (hg : measurable g) :
  ∫⁻ c, g c ∂(fst κ a) = ∫⁻ (bc : β × γ), g bc.fst ∂(κ a) :=
by rw [fst, lintegral_map _ measurable_fst a hg]

instance is_markov_kernel.fst (κ : kernel α (β × γ)) [is_markov_kernel κ] :
  is_markov_kernel (fst κ) :=
by { rw fst, apply_instance, }

instance is_finite_kernel.fst (κ : kernel α (β × γ)) [is_finite_kernel κ] :
  is_finite_kernel (fst κ) :=
by { rw fst, apply_instance, }

instance is_s_finite_kernel.fst (κ : kernel α (β × γ)) [is_s_finite_kernel κ] :
  is_s_finite_kernel (fst κ) :=
by { rw fst, apply_instance, }

/-- Define a `kernel α γ` from a `kernel α (β × γ)` by taking the map of the second projection. -/
noncomputable
def snd (κ : kernel α (β × γ)) : kernel α γ :=
map κ prod.snd measurable_snd

lemma snd_apply (κ : kernel α (β × γ)) (a : α) :
  snd κ a = (κ a).map prod.snd := rfl

lemma snd_apply' (κ : kernel α (β × γ)) (a : α) {s : set γ} (hs : measurable_set s) :
  snd κ a s = κ a {p | p.2 ∈ s} :=
by { rw [snd_apply, measure.map_apply measurable_snd hs], refl, }

lemma lintegral_snd (κ : kernel α (β × γ)) (a : α) {g : γ → ℝ≥0∞} (hg : measurable g) :
  ∫⁻ c, g c ∂(snd κ a) = ∫⁻ (bc : β × γ), g bc.snd ∂(κ a) :=
by rw [snd, lintegral_map _ measurable_snd a hg]

instance is_markov_kernel.snd (κ : kernel α (β × γ)) [is_markov_kernel κ] :
  is_markov_kernel (snd κ) :=
by { rw snd, apply_instance, }

instance is_finite_kernel.snd (κ : kernel α (β × γ)) [is_finite_kernel κ] :
  is_finite_kernel (snd κ) :=
by { rw snd, apply_instance, }

instance is_s_finite_kernel.snd (κ : kernel α (β × γ)) [is_s_finite_kernel κ] :
  is_s_finite_kernel (snd κ) :=
by { rw snd, apply_instance, }

end fst_snd

section comp
/-! ### Composition of two kernels -/

variables {γ : Type*} {mγ : measurable_space γ} {f : β → γ} {g : γ → α}

include mγ

/-- Composition of two s-finite kernels. -/
noncomputable
def comp (η : kernel β γ) [is_s_finite_kernel η] (κ : kernel α β) [is_s_finite_kernel κ] :
  kernel α γ :=
snd (κ ⊗ₖ prod_mk_left η α)

localized "infix (name := kernel.comp) ` ∘ₖ `:100 := probability_theory.kernel.comp" in
  probability_theory

lemma comp_apply (η : kernel β γ) [is_s_finite_kernel η] (κ : kernel α β) [is_s_finite_kernel κ]
  (a : α) {s : set γ} (hs : measurable_set s) :
  (η ∘ₖ κ) a s = ∫⁻ b, η b s ∂(κ a) :=
begin
  rw [comp, snd_apply' _ _ hs, comp_prod_apply],
  swap, { exact measurable_snd hs, },
  simp only [set.mem_set_of_eq, set.set_of_mem_eq, prod_mk_left_apply' _ _ s],
end

lemma lintegral_comp (η : kernel β γ) [is_s_finite_kernel η] (κ : kernel α β) [is_s_finite_kernel κ]
  (a : α) {g : γ → ℝ≥0∞} (hg : measurable g) :
  ∫⁻ c, g c ∂((η ∘ₖ κ) a) = ∫⁻ b, ∫⁻ c, g c ∂(η b) ∂(κ a) :=
begin
  rw [comp, lintegral_snd _ _ hg],
  change ∫⁻ bc, (λ a b, g b) bc.fst bc.snd ∂((κ ⊗ₖ prod_mk_left η α) a)
    = ∫⁻ b, ∫⁻ c, g c ∂(η b) ∂(κ a),
  exact lintegral_comp_prod _ _ _ (hg.comp measurable_snd),
end

instance is_markov_kernel.comp (η : kernel β γ) [is_markov_kernel η]
  (κ : kernel α β) [is_markov_kernel κ] :
  is_markov_kernel (η ∘ₖ κ) :=
by { rw comp, apply_instance, }

instance is_finite_kernel.comp (η : kernel β γ) [is_finite_kernel η]
  (κ : kernel α β) [is_finite_kernel κ] :
  is_finite_kernel (η ∘ₖ κ) :=
by { rw comp, apply_instance, }

instance is_s_finite_kernel.comp (η : kernel β γ) [is_s_finite_kernel η]
  (κ : kernel α β) [is_s_finite_kernel κ] :
  is_s_finite_kernel (η ∘ₖ κ) :=
by { rw comp, apply_instance, }

/-- Composition of kernels is associative. -/
lemma comp_assoc {δ : Type*} {mδ : measurable_space δ} (ξ : kernel γ δ) [is_s_finite_kernel ξ]
  (η : kernel β γ) [is_s_finite_kernel η] (κ : kernel α β) [is_s_finite_kernel κ] :
  (ξ ∘ₖ η ∘ₖ κ) = ξ ∘ₖ (η ∘ₖ κ) :=
begin
  refine ext_fun (λ a f hf, _),
  simp_rw [lintegral_comp _ _ _ hf, lintegral_comp _ _ _ (measurable_lintegral' ξ hf)],
end

lemma deterministic_comp_eq_map (hf : measurable f) (κ : kernel α β) [is_s_finite_kernel κ] :
  (deterministic hf ∘ₖ κ) = map κ f hf :=
begin
  ext a s hs : 2,
  simp_rw [map_apply' _ _ _ hs, comp_apply _ _ _ hs, deterministic_apply' hf _ hs,
    lintegral_indicator_const_comp hf hs, one_mul],
end

lemma comp_deterministic_eq_comap (κ : kernel α β) [is_s_finite_kernel κ] (hg : measurable g) :
  (κ ∘ₖ deterministic hg) = comap κ g hg :=
begin
  ext a s hs : 2,
  simp_rw [comap_apply' _ _ _ s, comp_apply _ _ _ hs, deterministic_apply hg a,
    lintegral_dirac' _ (kernel.measurable_coe κ hs)],
end

end comp

section prod

/-! ### Product of two kernels -/

variables {γ : Type*} {mγ : measurable_space γ}

include mγ

/-- Product of two s-finite kernels. -/
noncomputable
def prod (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel α γ) [is_s_finite_kernel η] :
  kernel α (β × γ) :=
κ ⊗ₖ (swap_left (prod_mk_left η β))

lemma prod_apply (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel α γ) [is_s_finite_kernel η]
  (a : α) {s : set (β × γ)} (hs : measurable_set s) :
  (prod κ η) a s = ∫⁻ (b : β), (η a) {c : γ | (b, c) ∈ s} ∂(κ a) :=
by simp_rw [prod, comp_prod_apply _ _ _ hs, swap_left_apply _ _, prod_mk_left_apply,
  prod.swap_prod_mk]

lemma lintegral_prod (κ : kernel α β) [is_s_finite_kernel κ] (η : kernel α γ) [is_s_finite_kernel η]
  (a : α) {g : (β × γ) → ℝ≥0∞} (hg : measurable g) :
  ∫⁻ c, g c ∂((prod κ η) a) = ∫⁻ b, ∫⁻ c, g (b, c) ∂(η a) ∂(κ a) :=
by simp_rw [prod, lintegral_comp_prod _ _ _ hg, swap_left_apply, prod_mk_left_apply,
  prod.swap_prod_mk]

instance is_markov_kernel.prod (κ : kernel α β) [is_markov_kernel κ]
  (η : kernel α γ) [is_markov_kernel η] :
  is_markov_kernel (prod κ η) :=
by { rw prod, apply_instance, }

instance is_finite_kernel.prod (κ : kernel α β) [is_finite_kernel κ]
  (η : kernel α γ) [is_finite_kernel η] :
  is_finite_kernel (prod κ η) :=
by { rw prod, apply_instance, }

instance is_s_finite_kernel.prod (κ : kernel α β) [is_s_finite_kernel κ]
  (η : kernel α γ) [is_s_finite_kernel η] :
  is_s_finite_kernel (prod κ η) :=
by { rw prod, apply_instance, }

end prod

end kernel

end probability_theory


-- Exercise 1
--
-- Go back to the exercises in Chapter 3 and Chapter 4 and redo as many as you
-- can now with tactic proofs, using also rw and simp as appropriate.

-- NOTE: I had alreadty been doing this, so I don't think I need to go back and
--       do them again... oops.

-- Exercise 2
--
-- Use tactic combinators to obtain a one line proof of the following:
example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by {
  repeat {split},
  repeat {
    {
      left,
      assumption
    } <|>
    right <|>
    assumption
  }
}


import field_theory.krull_topology
import topology.category.CompHaus.default
import topology.category.Profinite.default

open set

lemma ultrafilter.eq_principal_of_fintype (X : Type*) [fintype X]
  (f : ultrafilter X) : ∃ x : X, (f : filter X) = pure x :=
let ⟨x, hx1, (hx2 : (f : filter X) = pure x)⟩ :=
  ultrafilter.eq_principal_of_finite_mem (finite_univ : (univ : set X).finite)
  (filter.univ_mem) in
⟨x, hx2⟩

universe u

/-- Let `E` be an intermediate field of `L/K` with `E/K` finite, and let `f` be an ultrafilter
  on `L ≃ₐ[K] L`. Then the restriction map `(L ≃ₐ[K] L) → (E →ₐ[K] L)` gives pushes `f` forward
  to an ultrafilter on `E →ₐ[K] L`. Since `E →ₐ[K] L` is a finite set, this ultrafilter is
  principal. The element of `E →ₐ[K] L` generating this principal ultrafilter is
  `alg_hom_of_finite_dimensional_of_ultrafilter h_findim f`, where `h_findim : finite_dimensional K E`. -/
noncomputable def alg_hom_of_finite_dimensional_of_ultrafilter
  {K : Type*} {L : Type u} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) : E →ₐ[K] L :=
classical.some
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) _
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

/-- Let `f` be an ultrafilter on `L ≃ₐ[K] L`. For an intermediate field `E` of `L/K`, there is a
  natural restriction map `res : (L ≃ₐ[K] L) → (E →ₐ[K] L)`. Moreover, this restriction map gives
  a pushforward of `f` to an ultrafilter on `E →ₐ[K] L`. If `E/K` is finite, then this pushforward
  is generated by `alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f`.  -/
lemma alg_hom_of_finite_dimensional_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) : (f.map (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) : filter (E →ₐ[K] L)) =
  pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) := classical.some_spec
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) _
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

lemma ultrafilter.map_map {X Y Z: Type*} (m : X → Y) (n : Y → Z) (f : ultrafilter X) :
(f.map m).map n = f.map(n ∘ m) :=
begin
  ext,
  split,
  { intro hs,
    rw [ultrafilter.mem_map, set.preimage_comp, ← ultrafilter.mem_map, ← ultrafilter.mem_map],
    exact hs },
  { intro hs,
    rw [ultrafilter.mem_map, ultrafilter.mem_map, ← set.preimage_comp, ← ultrafilter.mem_map],
    exact hs },
end

lemma ultrafilter.map_pure {X Y : Type*} (x : X) (m : X → Y):
(pure x : ultrafilter X).map m = pure (m x) := rfl

lemma alg_hom_of_finite_dimensional_of_ultrafilter_functor {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (hE : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) {F : intermediate_field K L} (hF : finite_dimensional K F) (hEF : E ≤ F)
  :
  alg_hom_of_finite_dimensional_of_ultrafilter hE f =
  (alg_hom_of_finite_dimensional_of_ultrafilter hF f).comp (subalgebra.inclusion hEF) :=
  begin
    set p_E :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) with p_E_def,
    set p_F :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val F)) with p_F_def,
    set σ_E := alg_hom_of_finite_dimensional_of_ultrafilter hE f with σ_E_def,
    set σ_F := alg_hom_of_finite_dimensional_of_ultrafilter hF f with σ_F_def,
    have hσ_E := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← p_E_def, ← σ_E_def] at hσ_E,
    have hσ_F := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← p_F_def, ← σ_F_def] at hσ_F,
    set res : (F →ₐ[K] L) → (E →ₐ[K] L) := (λ ϕ, ϕ.comp (subalgebra.inclusion hEF))
    with res_def,
    have h_pF_pE_res : res ∘ p_F = p_E := rfl,
    have h_maps_commute : ((f.map p_F).map res : filter (E →ₐ[K] L)) = f.map p_E,
    { rw [ultrafilter.map_map, h_pF_pE_res] },
    have hEf  := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← σ_E_def, ← p_E_def] at hEf,
    have hFf := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← σ_F_def, ← p_F_def] at hFf,
    have hFf' : (ultrafilter.map p_F f) = (pure σ_F : ultrafilter (F →ₐ[K] L)),
    { exact ultrafilter.coe_inj.mp hFf },
    rw [hEf, hFf', ultrafilter.map_pure] at h_maps_commute,
    have h := filter.pure_injective h_maps_commute,
    rw res_def at h,
    dsimp at h,
    exact h.symm,
  end

/-- For each `x : L`, the intermediate field `K(x)` is finite dimensional over `K`, so
  `alg_hom_of_finite_dimensional_of_ultrafilter` gives a map `ϕₓ : K(x) → L`. We define
  `function_of_ultrafilter h_int f` to be the function taking `x` to `ϕₓ(x)` for all `x : L`. -/
noncomputable def function_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L → L) :=
λ x, (alg_hom_of_finite_dimensional_of_ultrafilter
(intermediate_field.adjoin.finite_dimensional (h_int x)) f)
(⟨x, intermediate_field.mem_adjoin_simple_self K x⟩)

lemma function_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(hE : finite_dimensional K E) (x : E) :
(function_of_ultrafilter h_int f) x = (alg_hom_of_finite_dimensional_of_ultrafilter hE f) x :=
begin
   have h_le : intermediate_field.adjoin K {(x : L)} ≤ E,
   {
     apply intermediate_field.gc.l_le,
     simp only [set_like.coe_mem, set_like.mem_coe, set.singleton_subset_iff, set.le_eq_subset],
   },
   have h_Kx : finite_dimensional K (intermediate_field.adjoin K {(x : L)}) :=
   intermediate_field.adjoin.finite_dimensional (h_int x),
   let h_functor := alg_hom_of_finite_dimensional_of_ultrafilter_functor h_Kx f hE h_le,
   have h : (function_of_ultrafilter h_int f) x =
   (alg_hom_of_finite_dimensional_of_ultrafilter h_Kx f) ⟨x,
   intermediate_field.mem_adjoin_simple_self K x⟩ := rfl,
   rw [h, h_functor],
   let x_in_Kx : intermediate_field.adjoin K {(x : L)} := ⟨(x : L),
   intermediate_field.mem_adjoin_simple_self K (x : L)⟩,
   have h_inclusion_mk : (subalgebra.inclusion h_le) ⟨x, intermediate_field.mem_adjoin_simple_self K (x : L)⟩ =
   ⟨x, h_le (intermediate_field.mem_adjoin_simple_self K (x : L))⟩ := rfl,
   simp [h_inclusion_mk],
end

lemma adj_finset_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
(S : finset L)
(h_int : ∀ (x : L), x ∈ S → is_integral K x) :
finite_dimensional K (intermediate_field.adjoin K (coe S : set L)) :=
begin
  refine intermediate_field.induction_on_adjoin_finset (S) (λ (E : intermediate_field K L),
  finite_dimensional K E) _ _,
  { have temp : (⊥ : intermediate_field K L) = (⊥ : intermediate_field K L) := rfl,
    rw ← intermediate_field.finrank_eq_one_iff at temp,
    refine finite_dimensional.finite_dimensional_of_finrank _,
    rw temp,
    exact zero_lt_one },
  { intros E x hx,
    specialize h_int x hx,
    introI h,
    haveI h2 : finite_dimensional ↥E (↥E)⟮x⟯,
    { apply intermediate_field.adjoin.finite_dimensional,
      exact is_integral_of_is_scalar_tower x h_int },
    change finite_dimensional K ↥(↥E)⟮x⟯,
    exact finite_dimensional.trans K ↥E ↥(↥E)⟮x⟯ },
end

/-- The function `function_of_ultrafilter h_int f` is actually a `K`-algebra homomorphism,
  and here we define the corresponding term of `L →ₐ[K] L`.-/
noncomputable def alg_hom_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L →ₐ[K] L) :=
{ to_fun := function_of_ultrafilter h_int f,
  map_one' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_one_bot : (1 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).one_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (1 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_mul' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    { apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
    have hxyE : x * y ∈ E := E.mul_mem' hxE hyE,
    haveI : decidable_eq L := classical.dec_eq L,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x * y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) *
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x * y, hxyE⟩],
    have h2 : (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ *
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨y, hyE⟩ =
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) (⟨x, hxE⟩ * ⟨y, hyE⟩),
    { simp only [mul_eq_mul_left_iff, true_or, eq_self_iff_true, map_mul] },
    rw h2,
    refl,
  end,
  map_zero' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_zero_bot : (0 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).zero_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (0 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_add' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    { apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
    have hxyE : x + y ∈ E := E.add_mem' hxE hyE,
    haveI : decidable_eq L := classical.dec_eq L,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x + y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) +
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x + y, hxyE⟩],
    rw eq.symm (map_add (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ ⟨y, hyE⟩),
    refl,
  end,
  commutes' :=
  begin
    intro r,
    let r' := (algebra_map K L) r,
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h : r' ∈ (⊥ : intermediate_field K L) := (⊥ : intermediate_field K L).algebra_map_mem r,
    change function_of_ultrafilter h_int f (⟨r', h⟩ : (⊥ : intermediate_field K L)) =
    (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    rw function_of_ultrafilter_spec h_int f h_findim_bot (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    have h2 : (⟨r', h⟩ : (⊥ : intermediate_field K L)) = (algebra_map K (⊥ : intermediate_field K L)
    r) := rfl,
    rw h2,
    simp,
    refl,
  end }

lemma alg_hom_of_ultrafilter_injective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
function.injective (alg_hom_of_ultrafilter h_int f) :=
begin
  intros x y hxy,
  haveI : decidable_eq L := classical.dec_eq L,
  let E := intermediate_field.adjoin K ({x, y} : set L),
  let S := ({x, y} : finset L),
  have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
  λ a ha, h_int a,
  have hE := adj_finset_finite_dimensional S h_S_int,
  have h_S_coes : (S : set L) = {x, y},
  { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
  rw h_S_coes at hE,
  change finite_dimensional K E at hE,
  have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
  have hxE : x ∈ E := h_sub (mem_insert x {y}),
  have hyE : y ∈ E,
  { apply h_sub,
    simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
  change (alg_hom_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (alg_hom_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  change (function_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (function_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  rw [function_of_ultrafilter_spec h_int f hE (⟨x, hxE⟩ : E),
  function_of_ultrafilter_spec h_int f hE (⟨y, hyE⟩ : E)] at hxy,
  have h : (⟨x, hxE⟩ : E) = (⟨y, hyE⟩ : E),
  { exact ring_hom.injective (alg_hom_of_finite_dimensional_of_ultrafilter hE f).to_ring_hom hxy },
  simp at h,
  exact h,
end

lemma eq_of_map_le {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
{f : L →ₐ[K] L} (h_findim : finite_dimensional K E) (h_map_le : E.map f ≤ E) :
E.map f = E :=
begin
  have hf_inj : function.injective f := ring_hom.injective f.to_ring_hom,
  haveI hE_submod_fin : finite_dimensional K E.to_subalgebra.to_submodule,
  { exact h_findim },
  have h_finrank_eq : finite_dimensional.finrank K (E.map f) =
  finite_dimensional.finrank K E,
  { exact (linear_equiv.finrank_eq (submodule.equiv_map_of_injective (f.to_linear_map)
    hf_inj E.to_subalgebra.to_submodule)).symm },
  have h_submod_le : (E.map f).to_subalgebra.to_submodule ≤ E.to_subalgebra.to_submodule := h_map_le,
  exact intermediate_field.to_subalgebra_eq_iff.mp (subalgebra.to_submodule_injective
  (finite_dimensional.eq_of_le_of_finrank_eq h_map_le h_finrank_eq)),
end

lemma alg_hom_of_ultrafilter_surjective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.surjective (alg_hom_of_ultrafilter h_int f) :=
begin
  intro y,
  specialize h_splits y,
  let p := minpoly K y,
  haveI : decidable_eq L := classical.dec_eq L,
  let S := (p.map (algebra_map K L)).roots.to_finset,
  let E := intermediate_field.adjoin K (S : set L),
  have hE_findim : finite_dimensional K E := adj_finset_finite_dimensional S (λ x hx, h_int x),
  let σ := alg_hom_of_ultrafilter h_int f,
  have hσSS : σ '' S ⊆ S,
  { rintros x ⟨a, ha, hax⟩,
    rw ← hax,
    simp,
    rw polynomial.mem_roots,
    { rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map, ← polynomial.alg_hom_eval₂_algebra_map],
      have hσ0 : σ 0 = 0 := by simp,
      rw ← hσ0,
      apply congr_arg σ,
      simp at ha,
      rw polynomial.mem_roots at ha,
      { rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map] at ha,
        exact ha },
      { exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) } },
    exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) },
  have hSE : (S : set L) ⊆ E := intermediate_field.gc.le_u_l (S : set L),
  have hσSE : σ '' S ⊆ E := set.subset.trans hσSS hSE,
  have h1 : E.map σ = intermediate_field.adjoin K (σ '' S) := intermediate_field.adjoin_map K S σ,
  have h2 : intermediate_field.adjoin K (σ '' S) ≤ E,
  { apply intermediate_field.gc.l_le,
    exact hσSE },
  change ∃ (a : L), σ a = y,
  rw ← h1 at h2,
  have h3 := eq_of_map_le hE_findim h2,
  have hyE : y ∈ E,
  { have hyS : y ∈ S,
    { simp,
      rw polynomial.mem_roots,
      { rw [polynomial.is_root.def,
         ← polynomial.eval₂_eq_eval_map,
         ← polynomial.aeval_def],
        exact minpoly.aeval K y },
      { exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) } },
    exact hSE hyS },
  rw ← h3 at hyE,
  rcases hyE with ⟨a, ha, hay⟩,
  exact ⟨a, hay⟩,
end

lemma alg_hom_of_ultrafilter_bijection {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.bijective (alg_hom_of_ultrafilter h_int f) :=
begin
  exact ⟨alg_hom_of_ultrafilter_injective h_int f,
  alg_hom_of_ultrafilter_surjective h_int h_splits f⟩,
end

/-- Since `alg_hom_of_ultrafilter h_int f` is a bijective `K`-algebra homomorphism `L →ₐ[K] L`,
  it is a `K`-algebra equivalence. Here we define the corresponding term of `L ≃ₐ[K] L`. -/
noncomputable def equiv_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(L ≃ₐ[K] L) :=
alg_equiv.of_bijective (alg_hom_of_ultrafilter h_int f) (alg_hom_of_ultrafilter_bijection h_int h_splits f)

lemma equiv_of_ultrafilter_to_fun {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_fun = function_of_ultrafilter h_int f :=
rfl

lemma equiv_of_ultrafilter_to_alg_hom {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_alg_hom = alg_hom_of_ultrafilter h_int f :=
rfl

/-- Let `L/K` be a normal algebraic field extension, let `f` be an ultrafilter on
  `L ≃ₐ[K] L`, and let `E/K` be a finite subextension. Then `equiv_of_ultrafilter h_int h_splits f`
  is a term of `L ≃ₐ[K] L`, and `alg_hom_of_finite_dimensional_of_ultrafilter h_findim f` is a term
  `E →ₐ[K] L`. This Lemma tells us that the underlying maps of these two terms agree on `E`.
    -/
lemma equiv_restricts_to_alg_hom_of_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(h_findim : finite_dimensional K E) :
((equiv_of_ultrafilter h_int h_splits f).to_alg_hom.comp E.val) =
alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
begin
  ext,
  exact function_of_ultrafilter_spec h_int f h_findim x,
end

/-- The restriction map `L ≃ₐ[K] L → E →ₐ[K] L`. -/
def res {K L : Type*} [field K] [field L] [algebra K L] (E : intermediate_field K L):
(L ≃ₐ[K] L) → (E →ₐ[K] L) :=
λ f, f.to_alg_hom.comp E.val

lemma res_eq_map {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
(σ : L ≃ₐ[K] L) (x : E) :
σ x = (res E σ) x :=
begin
  unfold res,
  simp,
end

lemma inv_mul_alg_equiv_of_elem {K L : Type*} [field K] [field L] [algebra K L]
(x : L) (f g : L ≃ₐ[K] L)  :
(f⁻¹ * g) x = x ↔ g x = f x :=
begin
   rw alg_equiv.mul_apply,
   split,
   { intro h,
    have h' := congr_arg f h,
    rw [← alg_equiv.mul_apply, mul_right_inv] at h',
    exact h' },
   { intro h,
    have h' := congr_arg f.symm h,
    rw alg_equiv.symm_apply_apply at h',
    exact h' },
end

lemma top_group_map_nhds_eq {G : Type*} [group G] [topological_space G]
[topological_group G] (g x : G) :
filter.map (λ y, g * y) (nhds x) = nhds (g * x) :=
begin
  ext,
  split,
  { intro h,
    rw [filter.mem_map, mem_nhds_iff] at h,
    rcases h with ⟨U, h_subset, h_open, hxU⟩,
    rw mem_nhds_iff,
    use left_coset g U,
    split,
    { rw ← set.image_subset_iff at h_subset,
      exact h_subset },
    refine ⟨_, ⟨x, ⟨hxU, rfl⟩⟩⟩,
    apply is_open_map_mul_left g,
    exact h_open },
  { intro h,
    rw mem_nhds_iff at h,
    rcases h with ⟨U, h_subset, h_open, hgxU⟩,
    rw [filter.mem_map, mem_nhds_iff],
    use left_coset g⁻¹ U,
    split,
    { rw ← set.image_subset_iff,
      have h : (λ (y : G), g * y) '' left_coset g⁻¹ U = U,
      { ext a,
        refine ⟨_, λ ha, ⟨g⁻¹ * a, ⟨a, ha, rfl⟩, by simp⟩⟩,
        rintro ⟨b, ⟨c, hcU, hcb⟩, hba⟩,
        change g⁻¹ * c = b at hcb,
        change g * b = a at hba,
        rw [← hcb, ← mul_assoc, mul_right_inv, one_mul] at hba,
        rw ← hba,
        exact hcU },
      rw h,
      exact h_subset },
    refine ⟨_, ⟨g * x, hgxU, by simp⟩⟩,
    apply is_open_map_mul_left g⁻¹,
    exact h_open },
end

lemma sigma_is_limit {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))
(f : ultrafilter (L ≃ₐ[K] L))
(h_le_princ : ↑f ≤ filter.principal
 (set.univ : set (L ≃ₐ[K] L))) :
(f : filter (L ≃ₐ[K] L)) ≤ nhds (equiv_of_ultrafilter h_int h_splits f) :=
begin
  let σ := equiv_of_ultrafilter h_int h_splits f,
  intros A hA,
  have hA_coset : left_coset σ⁻¹ A ∈ nhds (1 : L ≃ₐ[K] L),
  { have h_sigma_1 : σ = σ * 1 := by simp,
    change A ∈ nhds σ at hA,
    rw [h_sigma_1, ← top_group_map_nhds_eq σ 1, filter.mem_map] at hA,
    have h : left_coset σ⁻¹ A = (λ y, σ * y)⁻¹' A,
    { ext,
      split,
      { rintro ⟨a, ha, hax⟩,
        simp [hax.symm, ha] },
      { intro hx,
        rw set.mem_preimage at hx,
        rw [mem_left_coset_iff, inv_inv],
        exact hx } },
    rw h,
    exact hA },
  have hA_coset_cont_H : ∃ (E : intermediate_field K L), finite_dimensional K E
  ∧ E.fixing_subgroup.carrier ⊆ left_coset σ⁻¹ A,
  { rw [group_filter_basis.nhds_one_eq, filter_basis.mem_filter_iff] at hA_coset,
    rcases hA_coset with ⟨H_set, hH, hA_coset⟩,
    change H_set ∈ gal_basis K L at hH,
    rw mem_gal_basis_iff at hH,
    rcases hH with ⟨H, ⟨E, hE, hHE⟩, hHH_set⟩,
    refine ⟨E, hE, _⟩,
    rw [hHE, hHH_set],
    exact hA_coset },
  rcases hA_coset_cont_H with ⟨E, h_findim, hEA⟩,
  have hEA' : left_coset σ E.fixing_subgroup ⊆ A,
  { rintros x ⟨y, hy, hyx⟩,
    change σ * y = x at hyx,
    specialize hEA hy,
    rcases hEA with ⟨a, ha, hay⟩,
    change σ⁻¹ * a = y at hay,
    rw inv_mul_eq_iff_eq_mul at hay,
    rw [← hyx, ← hay],
    exact ha },
  let p : (L ≃ₐ[K] L) → (E →ₐ[K] L) := λ σ, (σ.to_alg_hom.comp E.val),
  have h_principal : f.map p = pure (p σ),
  { have h : p σ = alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
    equiv_restricts_to_alg_hom_of_finite_dimensional h_int h_splits f h_findim,
    rw h,
    have h2 : ↑(ultrafilter.map p f) = pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) :=
    alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f,
    ext,
    split,
    { intro hs,
      rw [← ultrafilter.mem_coe, h2] at hs,
      exact hs },
    { intro hs,
      rw ultrafilter.mem_pure at hs,
      have h3 : s ∈ (pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) : filter (↥E →ₐ[K] L)),
      { rw filter.mem_pure,
        exact hs },
      rw ← h2 at h3,
      rw ultrafilter.mem_coe at h3,
      exact h3 } },
  have h_small_set : left_coset σ E.fixing_subgroup ∈ f,
  { have h : {p σ} ∈ (pure (p σ) : ultrafilter (E →ₐ[K] L)) := set.mem_singleton (p σ),
    rw [← h_principal, ultrafilter.mem_map] at h,
    have h_preim : p⁻¹' {p σ} = left_coset σ E.fixing_subgroup,
    { ext g,
      split,
      { intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff] at hg,
        rw mem_left_coset_iff,
        intro x,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        change (σ⁻¹ * g) x = x,
        rw [inv_mul_alg_equiv_of_elem, h_g_on_x, h_σ_on_x, hg] },
      { intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff],
        ext,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        rw [← h_g_on_x, ← h_σ_on_x, ← inv_mul_alg_equiv_of_elem],
        exact (mem_left_coset_iff σ).1 hg x } },
    rw h_preim at h,
    exact h },
  exact f.to_filter.sets_of_superset h_small_set hEA',
end

lemma krull_topology_compact {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))  :
is_compact (set.univ : set (L ≃ₐ[K] L)) := is_compact_iff_ultrafilter_le_nhds.2
  (λ f hf,  ⟨equiv_of_ultrafilter h_int h_splits f,
  set.mem_univ (equiv_of_ultrafilter h_int h_splits f),
  sigma_is_limit h_int h_splits f hf⟩)

/-- -/
def krull_topology_comphaus {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)):
CompHaus :=
{ to_Top := Top.of (L ≃ₐ[K] L),
  is_compact := {
    compact_univ := krull_topology_compact h_int h_splits},
  is_hausdorff := krull_topology_t2 h_int,
}

def krull_topology_totally_disconnected_space {K L : Type*} [field K] [field L] [algebra K L]
(h_int : ∀ (x : L), is_integral K x) :
totally_disconnected_space (L ≃ₐ[K] L) :=
{ is_totally_disconnected_univ := krull_topology_totally_disconnected h_int}

def krull_topology_profinite {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) :
Profinite :=
{ to_CompHaus := krull_topology_comphaus h_int h_splits,
  is_totally_disconnected := krull_topology_totally_disconnected_space h_int}


import predicate_logic tactic.find
open logic
universe u

namespace syllogistic
section syllogism
parameters {sort : Type u} [decidable_eq sort]
parameter {σ : @signature sort _}

-- Aristotelian syllogistic calculus with individuals and conversions (including singular conversion).
-- "singular conversion" means we support the conception of treating individual/singular assertions
-- as categorical ones.
-- We had been told this is a port royal idea, but maybe it is due to Aristotle as well.
-- must check.

-- individuals
-- Notice that "term" for Aristotle is, in the context of a categorical syllogism,
-- almost the opposite of what "term" in mathematical logic means.
def atomo := @uterm sort _ σ

-- Aristotelian terms.
-- Those will be monadic predicates in the signature,
-- and also the terms generated from equality

-- universals (καθόλου)
def katholou := @nrary sort _ σ 1

inductive horos
| universal : katholou → horos
-- In predicate logic this constructor would be equivalent to the language having equality.
| singular : atomo → horos

instance : has_lift katholou horos := ⟨horos.universal⟩

-- Apophansis (ἀπόφανσις)
-- i.e.  the type of assertions
inductive apophansis
-- universal affirmative individual/singular (καθόλου κατάφασις άτομο)
-- Socrates is human.
| AI : atomo → katholou → apophansis
-- universal negative individual/singular
-- Socrates is not human.
| EI : atomo → katholou → apophansis
-- undefined/indefinite affirmative.
-- Supposed to stand either for vague quantification, or the predication of a proper accident.
-- Rougly, a proper accident is a property that is not part of the definition of the term,
-- but is either deducible from the definition or present almost universally in the instance of the universal term.
-- humans are mortal.
| UA : katholou → katholou → apophansis
-- undefined/indefinite negative.
-- humans are not mortal.
| UE : katholou → katholou → apophansis
-- universal affirmative
-- All men are mortal.
| A : horos → katholou → apophansis
-- universal negative
-- No man is mortal.
| E : horos → katholou → apophansis
-- particular affirmative
-- Some men are mortal.
| I : katholou → katholou → apophansis
-- particular negative
-- Some men are not mortal.
| O : katholou → katholou → apophansis
-- Existence claims, used for introducing existential import in Aristotelian logic.
-- e.g. "Some human exists".
| EXI : katholou → apophansis
-- e.g. "No human exists".
| EXE : katholou → apophansis
-- trivially true
-- Used as a default value in some functions
-- e.g. "All humans exist".
| EXA : katholou → apophansis
-- Always false.
-- Used as a default value in some functions
-- e.g. "Some humans do not exist".
| EXO : katholou → apophansis

def AI := apophansis.AI
def EI := apophansis.EI
def UA := apophansis.UA
def UE := apophansis.UE
def A := apophansis.A
def E := apophansis.E
def I := apophansis.I
def O := apophansis.O
def EXA := apophansis.EXA
def EXE := apophansis.EXE
def EXI := apophansis.EXI
def EXO := apophansis.EXO

--square of opposition (up to singular conversion).
def contradictory : apophansis → apophansis
| (apophansis.AI socrates mortal) := EI socrates mortal
| (apophansis.EI socrates mortal) := AI socrates mortal
| (apophansis.UA human mortal) := UE human mortal
| (apophansis.UE human mortal) := UA human mortal
| (apophansis.A (horos.universal human) mortal) := O human mortal
| (apophansis.A (horos.singular socrates) mortal) := EI socrates mortal
| (apophansis.E (horos.universal human) mortal) := I human mortal
| (apophansis.E (horos.singular socrates) mortal) := EI socrates mortal
| (apophansis.I human mortal) := E ↑human mortal
| (apophansis.O human mortal) := A ↑human mortal
| (apophansis.EXA human) := EXO human
| (apophansis.EXE human) := EXI human
| (apophansis.EXI human) := EXE human
| (apophansis.EXO human) := EXA human

-- EXO can be interpreted as "undefined".
-- But it is also logically true that it is contrary to everything.
def contrary : apophansis → apophansis
| (apophansis.AI socrates mortal) := EI socrates mortal
| (apophansis.EI socrates mortal) := AI socrates mortal
| (apophansis.UA human mortal) := EXO human
| (apophansis.UE human mortal) := EXO human
| (apophansis.A human mortal) := E human mortal
| (apophansis.E human mortal) := A human mortal
| (apophansis.I human mortal) := EXO human
| (apophansis.O human mortal) := EXO human
| (apophansis.EXA human) := EXO human
| (apophansis.EXE human) := EXO human
| (apophansis.EXI human) := EXO human
| (apophansis.EXO human) := EXO human

-- EXA is the "undefined".
-- It is logically true that it is compatible with everthing (except EXO).
-- def subalternate : apophansis → apophansis
-- | (apophansis.AI socrates mortal) := EI socrates mortal
-- | (apophansis.EI socrates mortal) := AI socrates mortal
-- | (apophansis.UA human mortal) := EXA human
-- | (apophansis.UE human mortal) := EXA human
-- | (apophansis.A (horos.universal human) mortal) := I human mortal
-- | (apophansis.A (horos.singular socrates) mortal) := I human mortal
-- | (apophansis.E human mortal) := A human mortal
-- | (apophansis.I human mortal) := EXO human
-- | (apophansis.O human mortal) := EXO human
-- | (apophansis.EXA human) := EXO human
-- | (apophansis.EXE human) := EXO human
-- | (apophansis.EXI human) := EXO human
-- | (apophansis.EXO human) := EXO human

-- convert singular assertions to categorical ones.
-- e.g. convert from "Socrates is human" to "All Socrates are human"
-- (meaning all entities equal to Socrates are human).
-- e.g. convert from "Socrates is not human" to "No Socrates is human".
def singular_conversion : apophansis → apophansis
| (apophansis.AI socrates human) := A (horos.singular socrates) human
| (apophansis.EI socrates human) := E (horos.singular socrates) human
| φ := φ

-- inverse function.
-- converts from "All Socrates are human" to "Socrates is human".
-- converts from "No Socrates is human" to "Socrates is not human".
def singular_reversion : apophansis → apophansis
| (apophansis.A (horos.singular socrates) human) := AI socrates human
| (apophansis.E (horos.singular socrates) human) := EI socrates human
| φ := φ

def categorical : apophansis → Prop
| (apophansis.AI _ _) := false
| (apophansis.EI _ _) := false
| _ := true

lemma singular_conversion_gives_categorical : ∀ φ : apophansis, categorical (singular_conversion φ) :=
    begin
    intros φ,
    cases φ;
    simp [singular_conversion]
    end

-- Eba→Eab
-- if no human is a donkey, no donkey is a human.
def disjoint_conversion : apophansis → apophansis
| (apophansis.E (horos.universal human) donkey) := E ↑donkey human
| φ := φ

-- Iba→Iab
-- If some humans are idiots, some idiots are human.
def conjoint_conversion : apophansis → apophansis
| (apophansis.I human idiot) := I idiot human
| φ := φ

-- Aba → Iab
-- If all men are mortal, some mortals are men.
-- requires existential import.
def existential_conversion : apophansis → apophansis
| (apophansis.A (horos.universal human) mortal) := I mortal human
| φ := φ

-- All moods can be reduced to Barbara and Celarent,
-- although Darii and Ferio are also considered perfect.
inductive perfect_syllogism : apophansis → apophansis → apophansis → Prop
| Barbara (middle major : katholou) (minor : horos) : perfect_syllogism (A ↑middle major) (A minor middle) (A minor major)
| Celarent (major middle minor : katholou) : perfect_syllogism (E ↑middle major) (A ↑minor middle) (E ↑minor major)

inductive syllogism : apophansis → apophansis → apophansis → Prop
-- teleios syllogism
| perfect {p₁ p₂ c₁ : apophansis} (h : perfect_syllogism p₁ p₂ c₁) : syllogism p₁ p₂ c₁
-- singular_conversion
| SC {p₁ p₂ c₁ : apophansis} (h : syllogism p₁ p₂ c₁)
    : syllogism (singular_conversion p₁) (singular_conversion p₂) (singular_conversion c₁)
-- singular_reversion
| SR {p₁ p₂ c₁ : apophansis} (h : syllogism p₁ p₂ c₁)
    : syllogism (singular_reversion p₁) (singular_reversion p₂) (singular_reversion c₁)
-- disjoint_conversion
| DC {p₁ p₂ c₁ : apophansis} (h : syllogism p₁ p₂ c₁)
    : syllogism (disjoint_conversion p₁) (disjoint_conversion p₂) (disjoint_conversion c₁)
-- conjoint_conversion
| CC {p₁ p₂ c₁ : apophansis} (h : syllogism p₁ p₂ c₁)
    : syllogism (conjoint_conversion p₁) (conjoint_conversion p₂) (conjoint_conversion c₁)
-- existential_conversion
| EC {p₁ p₂ c₁ : apophansis} (h : syllogism p₁ p₂ c₁)
    : syllogism (existential_conversion p₁) (existential_conversion p₂) (existential_conversion c₁)

-- parameters {p₁ p₂ c : apophansis}

lemma BarbaraI (middle major : katholou) (minor : atomo)
        : syllogism (singular_conversion (A ↑middle major)) (singular_conversion (A (horos.singular minor) middle))
(singular_conversion (A (horos.singular minor) major)) :=
syllogism.SC (syllogism.perfect
(perfect_syllogism.Barbara middle major (horos.singular minor)))

-- | CelarentI (major middle : katholou) (minor : atomo) : syllogism (E ↑middle major) (AI minor middle) (EI minor major)

inductive deduction : apophansis → Type u
| immediate  (p₁ p₂ c : apophansis) (h : syllogism p₁ p₂ c) : deduction c
| first_recursive (p₂ c₀ c : apophansis) (proof : deduction c₀)
                  (h : syllogism c₀ p₂ c)
                  : deduction c
| second_recursive (p₁ c₀ c : apophansis) (proof : deduction c₀)
                  (h : syllogism p₁ c₀ c)
                  : deduction c
| birecursive (p₁ c₁ c₂ c : apophansis) (proof₁ : deduction c₁)
                  (proof₂ : deduction c₂) (h : syllogism c₁ c₂ c)
                  : deduction c

-- | second_recursive (p₁ p₂ c₁ p₃ c₂ : apophansis) (h₀ : syllogism p₁ p₂ c₁)
--                   (h₀ : syllogism p₃ c₁ c₂)
--                   : deduction [p₁, p₂, c₁, p₃, c₂]
end syllogism
end syllogistic