/-
Copyright (c) 2021 Paula Neeley. All rights reserved.
Author: Paula Neeley
Following the textbook "Dynamic Epistemic Logic" by
Hans van Ditmarsch, Wiebe van der Hoek, and Barteld Kooi
-/

import del.languageDEL del.semantics.semanticsDEL
import data.set.basic data.equiv.basic
local attribute [instance] classical.prop_decidable

variable {agents : Type}

---------------------- Facts about Announcements ----------------------

-- Proposition 4.10, pg. 77
lemma functional_announce (φ ψ : formPA agents) :
  F_validPA ((¬(U φ (¬ψ))) ⊃ (U φ ψ)) equiv_class :=
begin
intros f h v x h1,
rw forces_update_dual at h1,
cases h1 with Ph1 h1, intro h, exact h1
end

-- Proposition 4.11, pg. 77
lemma partial_announce (φ ψ : formPA agents) :
  ¬ (F_validPA ¬(U φ ¬⊥)) equiv_class :=
begin
rw F_validPA,
push_neg,
let f : frame agents :=
{ states := nat,
  h := ⟨0⟩,
  rel := λ a, λ x y : nat, x = y
},
use f, split, intro a,
split, intro x,
exact eq.refl x,
split, intros x y h,
exact eq.symm h,
intros x y z h1 h2,
exact eq.trans h1 h2,
let v : nat → f.states → Prop := λ n x, false,
use v,
let x : f.states := 42,
use x, rw forcesPA, rw not_imp,
split, intro h, intro h1, exact h1,
rw forcesPA, trivial
end

--Proposition 4.22
lemma public_annouce_var (φ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (x : f.states) (n : ℕ) :
  forcesPA f v x (U φ p n) ↔ forcesPA f v x (φ ⊃ (p n)) :=
begin
split, repeat {intros h1 h2, exact h1 h2},
end

lemma public_annouce_conj (φ ψ χ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (x : f.states) :
  forcesPA f v x (U φ (ψ & χ)) ↔ forcesPA f v x ((U φ ψ) & (U φ χ)) :=
begin
split,
intro h1,
split,
intro h2,
exact (h1 h2).left,
intro h2,
exact (h1 h2).right,
intros h1 h2,
split,
exact h1.left h2,
exact h1.right h2,
end

-- Proposition 4.12, pg. 77
lemma public_announce_neg (φ ψ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (x : f.states) :
  forcesPA f v x (U φ (¬ψ)) ↔ forcesPA f v x (φ ⊃ ¬(U φ ψ))  :=
begin
split,
intros h1 h2 h3, specialize h1 h2,
rw ←not_forces_impPA at h1,
exact absurd (h3 h2) h1,
intros h1, rw forcesPA at h1, rw imp_iff_not_or at h1,
cases h1,
intro h2, exact absurd h2 h1,
intros h h2, apply h1, intro h3, exact h2
end

-- Proposition 4.18, pg. 79
lemma public_announce_know (φ ψ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (s : f.states) (a : agents) :
  forcesPA f v s (U φ (K a ψ)) ↔ forcesPA f v s (φ ⊃ (K a (U φ ψ))) :=
begin
split,
intros h1 h2 t hrel h3,
exact h1 h2 ⟨t, h3⟩ hrel,
rintros h1 h2 ⟨t, h3⟩ hrel,
exact h1 h2 t hrel h3,
end

namespace compositionPA

variables A A' : Prop
variable  B    : A → Prop
variable  A''  : A' → Prop
variable  B'   : ∀ h : A', A'' h → Prop

lemma comp_helper1 (h : A ↔ ∃ h : A', A'' h)
  (h' : ∀ (h1 : A) (h2 : A') (h3 : A'' h2), B h1 ↔ B' h2 h3) :
  (∀ h1 : A, B h1) ↔ (∀ h2 h3, B' h2 h3) :=
begin
  split,
  { intros hh h2 h3,
    have h1 : A := h.mpr ⟨h2, h3⟩,
    exact (h' h1 h2 h3).mp (hh h1) },
  intros hh h1,
  cases h.mp h1 with h2 h3,
  exact (h' h1 h2 h3).mpr (hh h2 h3)
end

lemma comp_helper2 (φ ψ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (s : f.states) :
  forcesPA f v s (φ & U φ ψ) ↔
  (∃ h : forcesPA f v s φ, forcesPA (f.restrict
  (λ y, forcesPA f v y φ) s h) (λ n u, v n u.val) ⟨s, h⟩ ψ) :=
begin
split,
intro h1,
cases h1 with h1 h2,
use h1,
apply h2,
intro h1,
cases h1 with h1 h2,
split,
exact h1,
intro h3,
exact h2,
end

def is_frame_iso (f1 f2 : frame agents) (F : f1.states ≃ f2.states) :=
  ∀ x x' : f1.states, ∀ a : agents, (f1.rel a x x' ↔ f2.rel a (F x) (F x'))

def is_model_iso (f1 f2 : frame agents) (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (F : f1.states ≃ f2.states) :=
  is_frame_iso f1 f2 F ∧ ∀ n, ∀ x : f1.states, v1 n x = v2 n (F x)

lemma model_iso_symm {f1 f2 : frame agents} {v1 : nat → f1.states → Prop}
  {v2 : nat → f2.states → Prop} {F : f1.states ≃ f2.states} :
  is_model_iso f1 f2 v1 v2 F → is_model_iso f2 f1 v2 v1 (F.symm) :=
begin
intro h1,
cases h1 with h1 h2,
split,
intros x x' a,
specialize h1 (F.inv_fun x) (F.inv_fun x') a,
simp at h1,
exact h1.symm,
intros n x,
specialize h2 n (F.inv_fun x), simp at *,
exact h2.symm
end

def restrict_F {f1 f2 : frame agents} {v1 : nat → f1.states → Prop}
  {v2 : nat → f2.states → Prop} (F : f1.states ≃ f2.states)
  (φ : formPA agents) (x : f1.states) (h : ∀ y : f1.states,
  (forcesPA f1 v1 y φ ↔ forcesPA f2 v2 (F y) φ)) (h' : forcesPA f1 v1 x φ)
  (h'' : forcesPA f2 v2 (F x) φ) :
  (f1.restrict (λ y, forcesPA f1 v1 y φ) x h').states
  ≃ (f2.restrict (λ y, forcesPA f2 v2 y φ) (F x) h'').states :=
{ to_fun := λ ⟨y, hy⟩, ⟨(F y), (h y).mp hy⟩,
  inv_fun := λ ⟨y, hy⟩, ⟨(F.inv_fun y), (h (F.inv_fun y)).mpr
  begin
    convert hy,
    apply F.right_inv,
  end ⟩,
  left_inv :=
  begin
    intro y,
    cases y with y hy,
    ext,
    apply F.left_inv,
  end,
  right_inv :=
  begin
  intro y,
    cases y with y hy,
    ext,
    apply F.right_inv,
  end }

lemma update_iso {f1 f2 : frame agents} {v1 : nat → f1.states → Prop}
  {v2 : nat → f2.states → Prop} (F : f1.states ≃ f2.states) :
  is_model_iso f1 f2 v1 v2 F → ∀ φ : formPA agents,
  ∀ h : (∀ x : f1.states, forcesPA f1 v1 x φ ↔ forcesPA f2 v2 (F x) φ),
  ∀ x, ∀ h' : forcesPA f1 v1 x φ,
  ∀ h'' : forcesPA f2 v2 (F x) φ,
  is_model_iso (f1.restrict (λ y, forcesPA f1 v1 y φ) x h')
  (f2.restrict (λ y, forcesPA f2 v2 y φ) (F x) h'') (λ n u, v1 n u.val)
  (λ n u, v2 n u.val) (restrict_F F φ x h h' h'') :=
begin
intros h1 φ h2 x h3 h4,
cases h1 with h1 h6,
split,
rintros ⟨x1, hx1⟩ ⟨y1, hy1⟩ a,
apply h1 x1 y1 a,
rintros n ⟨x1, hx1⟩,
apply h6 n x1,
end

lemma comp_helper3 (f1 f2 : frame agents) (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (F : f1.states ≃ f2.states) :
  is_model_iso f1 f2 v1 v2 F → ∀ s1 : f1.states, ∀ φ : formPA agents,
  forcesPA f1 v1 s1 φ ↔ forcesPA f2 v2 (F s1) φ :=
begin
intro h1,
intros x1 φ, induction φ generalizing f1 v1 f2 v2 F h1 x1,
split,
repeat {intro h3, exact h3},
split,
repeat {intro h3,
rename φ n,
cases h1 with h1 h2,
specialize h2 n x1,
rw forcesPA at *,
convert h3},
exact eq.symm h2,
repeat {rename φ_φ φ},
repeat {rename φ_ψ ψ},
repeat {rename φ_ih_φ φ_ih},
repeat {rename φ_ih_ψ ψ_ih},
repeat {rename φ_a a},
split,
repeat {intro h3,
cases h3 with h3 h4,
split},
exact (φ_ih f1 v1 f2 v2 F h1 x1).mp h3,
exact (ψ_ih f1 v1 f2 v2 F h1 x1).mp h4,
exact (φ_ih f1 v1 f2 v2 F h1 x1).mpr h3,
exact (ψ_ih f1 v1 f2 v2 F h1 x1).mpr h4,
split,
repeat {intros h3 h4},
exact (ψ_ih f1 v1 f2 v2 F h1 x1).mp (h3 ((φ_ih f1 v1 f2 v2 F h1 x1).mpr h4)),
exact (ψ_ih f1 v1 f2 v2 F h1 x1).mpr (h3 ((φ_ih f1 v1 f2 v2 F h1 x1).mp h4)),
split,
intros h3 y1 h4,
specialize φ_ih f1 v1 f2 v2 F h1 (F.inv_fun y1),
cases h1 with h1 h5,
specialize h1 x1 (F.inv_fun y1) a,
simp at *,
exact φ_ih.mp (h3 (F.inv_fun y1) (h1.mpr h4)),
intros h3 x2 h4,
specialize φ_ih f1 v1 f2 v2 F h1 x2,
cases h1 with h1 h5,
exact φ_ih.mpr (h3 (F.to_fun x2) ((h1 x1 x2 a).mp h4)),
split,
intro h2,
specialize φ_ih f1 v1 f2 v2 F h1,
intro h3,
have h4 := ((φ_ih x1).mpr h3),
have h5 := update_iso F h1 φ φ_ih x1 h4 h3,
specialize ψ_ih (f1.restrict (λ (y : f1.states), forcesPA f1 v1 y φ) x1 h4)
  (λ (n : ℕ) (u : (f1.restrict (λ (y : f1.states), forcesPA f1 v1 y φ) x1 h4).states), v1 n u.val)
  (f2.restrict (λ (y : f2.states), forcesPA f2 v2 y φ) (F x1) h3)
  (λ (n : ℕ) (u : (f2.restrict (λ (y : f2.states), forcesPA f2 v2 y φ) (F x1) h3).states),
  v2 n u.val) (restrict_F F φ x1 φ_ih h4 h3) h5 ⟨x1, h4⟩,
have h6 := ψ_ih.mp (h2 h4),
convert h6,
intro h2,
specialize φ_ih f1 v1 f2 v2 F h1,
intro h3,
have h4 := (φ_ih x1).mp h3,
have h5 := update_iso F h1 φ φ_ih x1 h3 h4,
specialize ψ_ih (f2.restrict (λ (y : f2.states), forcesPA f2 v2 y φ) (F x1) h4)
  (λ (n : ℕ) (u : (f2.restrict (λ (y : f2.states), forcesPA f2 v2 y φ) (F x1) h4).states), v2 n u.val)
  (f1.restrict (λ (y : f1.states), forcesPA f1 v1 y φ) x1 h3)
  (λ (n : ℕ) (u : (f1.restrict (λ (y : f1.states), forcesPA f1 v1 y φ) x1 h3).states), v1 n u.val)
  (_) (model_iso_symm h5) ⟨F x1, h4⟩,
have h6 := ψ_ih.mp (h2 h4),
convert h6,
{exact (equiv.eq_symm_apply F).mpr rfl},
end

-- Proposition 4.17, pg. 78
lemma public_announce_comp (φ ψ χ : formPA agents) (f : frame agents)
  (v : nat → f.states → Prop) (s : f.states) :
  forcesPA f v s (U (φ & U φ ψ) χ) ↔ forcesPA f v s (U φ (U ψ χ)) :=
begin
apply comp_helper1,
apply comp_helper2,
intros h1 h2 h3,
let F : (f.restrict (λ (y : f.states), forcesPA f v y (φ&φ.update ψ)) s h1).states ≃ ((f.restrict
  (λ (y : f.states), forcesPA f v y φ) s h2).restrict (λ (y : (f.restrict (λ (y : f.states),
  forcesPA f v y φ) s h2).states), forcesPA (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2)
  (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), v n u.val) y ψ)
  ⟨s, h2⟩ h3).states :=
  {to_fun :=
  begin
    rintro ⟨x, h⟩,
    use x,
    apply h.left,
    apply h.right,
  end,
  inv_fun :=
  begin
    rintro ⟨⟨x, h4⟩, h5⟩,
    exact ⟨x, ⟨h4, λ _, h5⟩⟩,
  end,
  left_inv :=
  begin
    rintro ⟨x, h⟩,
    ext,
    refl,
  end,
  right_inv :=
  begin
    rintro ⟨⟨x, h4⟩, h5⟩,
    refl,
  end},
have h4 := comp_helper3 (f.restrict (λ (y : f.states), forcesPA f v y (φ&φ.update ψ)) s h1)
  ((f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).restrict (λ (y : (f.restrict (λ (y : f.states),
  forcesPA f v y φ) s h2).states), forcesPA (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2)
  (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), v n u.val) y ψ) ⟨s, h2⟩ h3)
  (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y (φ&φ.update ψ)) s h1).states), v n u.val)
  (λ (n : ℕ) (u : ((f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).restrict (λ (y : (f.restrict
  (λ (y : f.states), forcesPA f v y φ) s h2).states), forcesPA (f.restrict (λ (y : f.states), forcesPA f v y φ)
  s h2) (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), v n u.val) y ψ)
  ⟨s, h2⟩ h3).states), (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states),
  v n u.val) n u.val),
specialize h4 F,
have h5 : is_model_iso (f.restrict (λ (y : f.states), forcesPA f v y (φ&φ.update ψ)) s h1)
  ((f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).restrict (λ (y : (f.restrict (λ (y : f.states),
  forcesPA f v y φ) s h2).states), forcesPA (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2)
  (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), v n u.val) y ψ)
  ⟨s, h2⟩ h3) (λ (n : ℕ) (u : (f.restrict (λ (y : f.states), forcesPA f v y (φ&φ.update ψ)) s h1).states),
  v n u.val) (λ (n : ℕ) (u : ((f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).restrict
  (λ (y : (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), forcesPA (f.restrict
  (λ (y : f.states), forcesPA f v y φ) s h2) (λ (n : ℕ) (u : (f.restrict (λ (y : f.states),
  forcesPA f v y φ) s h2).states), v n u.val) y ψ) ⟨s, h2⟩ h3).states), (λ (n : ℕ) (u :
  (f.restrict (λ (y : f.states), forcesPA f v y φ) s h2).states), v n u.val) n u.val) F,
{
  split,
  rintros ⟨x1, hx1⟩ ⟨y1, hy1⟩ a,
  refl,
  rintros n ⟨x, hx⟩,
  refl
},
convert h4 h5 ⟨s, h1⟩ χ
end

end compositionPA


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

! This file was ported from Lean 3 source module category_theory.closed.monoidal
! leanprover-community/mathlib commit 0caf3701139ef2e69c215717665361cda205a90b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Monoidal.Functor
import Mathlib.CategoryTheory.Adjunction.Limits
import Mathlib.CategoryTheory.Adjunction.Mates
import Mathlib.CategoryTheory.Functor.InvIsos

/-!
# Closed monoidal categories

Define (right) closed objects and (right) closed monoidal categories.

## TODO
Some of the theorems proved about cartesian closed categories
should be generalised and moved to this file.
-/

universe v u u₂ v₂

namespace CategoryTheory

open Category MonoidalCategory

-- Note that this class carries a particular choice of right adjoint,
-- (which is only unique up to isomorphism),
-- not merely the existence of such, and
-- so definitional properties of instances may be important.
/-- An object `X` is (right) closed if `(X ⊗ -)` is a left adjoint. -/
class Closed {C : Type u} [Category.{v} C] [MonoidalCategory.{v} C] (X : C) where
  /-- a choice of a left adjoint for `tensorLeft X` -/
  isAdj : IsLeftAdjoint (tensorLeft X)
#align category_theory.closed CategoryTheory.Closed

/-- A monoidal category `C` is (right) monoidal closed if every object is (right) closed. -/
class MonoidalClosed (C : Type u) [Category.{v} C] [MonoidalCategory.{v} C] where
  closed : ∀ X : C, Closed X
#align category_theory.monoidal_closed CategoryTheory.MonoidalClosed

attribute [instance] MonoidalClosed.closed

variable {C : Type u} [Category.{v} C] [MonoidalCategory.{v} C]

/-- If `X` and `Y` are closed then `X ⊗ Y` is.
This isn't an instance because it's not usually how we want to construct internal homs,
we'll usually prove all objects are closed uniformly.
-/
def tensorClosed {X Y : C} (hX : Closed X) (hY : Closed Y) : Closed (X ⊗ Y) where
  isAdj := by
    haveI := hX.isAdj
    haveI := hY.isAdj
    exact Adjunction.leftAdjointOfNatIso (MonoidalCategory.tensorLeftTensor _ _).symm
#align category_theory.tensor_closed CategoryTheory.tensorClosed

/-- The unit object is always closed.
This isn't an instance because most of the time we'll prove closedness for all objects at once,
rather than just for this one.
-/
def unitClosed : Closed (𝟙_ C)
    where isAdj :=
    { right := 𝟭 C
      adj :=
        Adjunction.mkOfHomEquiv
          { homEquiv := fun X _ =>
              { toFun := fun a => (leftUnitor X).inv ≫ a
                invFun := fun a => (leftUnitor X).hom ≫ a
                left_inv := by aesop_cat
                right_inv := by aesop_cat }
            homEquiv_naturality_left_symm := fun f g => by
              dsimp
              rw [leftUnitor_naturality_assoc] } }
#align category_theory.unit_closed CategoryTheory.unitClosed

variable (A B : C) {X X' Y Y' Z : C}

variable [Closed A]

/-- This is the internal hom `A ⟶[C] -`.
-/
def ihom : C ⥤ C :=
  (@Closed.isAdj _ _ _ A _).right
#align category_theory.ihom CategoryTheory.ihom

namespace ihom

/-- The adjunction between `A ⊗ -` and `A ⟹ -`. -/
def adjunction : tensorLeft A ⊣ ihom A :=
  Closed.isAdj.adj
#align category_theory.ihom.adjunction CategoryTheory.ihom.adjunction

/-- The evaluation natural transformation. -/
def ev : ihom A ⋙ tensorLeft A ⟶ 𝟭 C :=
  (ihom.adjunction A).counit
#align category_theory.ihom.ev CategoryTheory.ihom.ev

/-- The coevaluation natural transformation. -/
def coev : 𝟭 C ⟶ tensorLeft A ⋙ ihom A :=
  (ihom.adjunction A).unit
#align category_theory.ihom.coev CategoryTheory.ihom.coev

@[simp]
theorem ihom_adjunction_counit : (ihom.adjunction A).counit = ev A :=
  rfl
#align category_theory.ihom.ihom_adjunction_counit CategoryTheory.ihom.ihom_adjunction_counit

@[simp]
theorem ihom_adjunction_unit : (ihom.adjunction A).unit = coev A :=
  rfl
#align category_theory.ihom.ihom_adjunction_unit CategoryTheory.ihom.ihom_adjunction_unit

@[reassoc (attr := simp)]
theorem ev_naturality {X Y : C} (f : X ⟶ Y) :
    (𝟙 A ⊗ (ihom A).map f) ≫ (ev A).app Y = (ev A).app X ≫ f :=
  (ev A).naturality f
#align category_theory.ihom.ev_naturality CategoryTheory.ihom.ev_naturality

@[reassoc (attr := simp)]
theorem coev_naturality {X Y : C} (f : X ⟶ Y) :
    f ≫ (coev A).app Y = (coev A).app X ≫ (ihom A).map (𝟙 A ⊗ f) :=
  (coev A).naturality f
#align category_theory.ihom.coev_naturality CategoryTheory.ihom.coev_naturality

set_option quotPrecheck false in
/-- `A ⟶[C] B` denotes the internal hom from `A` to `B` -/
notation A " ⟶[" C "] " B:10 => (@ihom C _ _ A _).obj B

@[reassoc (attr := simp)]
theorem ev_coev : (𝟙 A ⊗ (coev A).app B) ≫ (ev A).app (A ⊗ B) = 𝟙 (A ⊗ B) :=
  Adjunction.left_triangle_components (ihom.adjunction A)
#align category_theory.ihom.ev_coev CategoryTheory.ihom.ev_coev

@[reassoc (attr := simp)]
theorem coev_ev : (coev A).app (A ⟶[C] B) ≫ (ihom A).map ((ev A).app B) = 𝟙 (A ⟶[C] B) :=
  Adjunction.right_triangle_components (ihom.adjunction A)
#align category_theory.ihom.coev_ev CategoryTheory.ihom.coev_ev

end ihom

open CategoryTheory.Limits

instance : PreservesColimits (tensorLeft A) :=
  (ihom.adjunction A).leftAdjointPreservesColimits

variable {A}

-- Wrap these in a namespace so we don't clash with the core versions.
namespace MonoidalClosed

/-- Currying in a monoidal closed category. -/
def curry : (A ⊗ Y ⟶ X) → (Y ⟶ A ⟶[C] X) :=
  (ihom.adjunction A).homEquiv _ _
#align category_theory.monoidal_closed.curry CategoryTheory.MonoidalClosed.curry

/-- Uncurrying in a monoidal closed category. -/
def uncurry : (Y ⟶ A ⟶[C] X) → (A ⊗ Y ⟶ X) :=
  ((ihom.adjunction A).homEquiv _ _).symm
#align category_theory.monoidal_closed.uncurry CategoryTheory.MonoidalClosed.uncurry

@[simp]
theorem homEquiv_apply_eq (f : A ⊗ Y ⟶ X) : (ihom.adjunction A).homEquiv _ _ f = curry f :=
  rfl
#align category_theory.monoidal_closed.hom_equiv_apply_eq CategoryTheory.MonoidalClosed.homEquiv_apply_eq

@[simp]
theorem homEquiv_symm_apply_eq (f : Y ⟶ A ⟶[C] X) :
    ((ihom.adjunction A).homEquiv _ _).symm f = uncurry f :=
  rfl
#align category_theory.monoidal_closed.hom_equiv_symm_apply_eq CategoryTheory.MonoidalClosed.homEquiv_symm_apply_eq

@[reassoc]
theorem curry_natural_left (f : X ⟶ X') (g : A ⊗ X' ⟶ Y) : curry ((𝟙 _ ⊗ f) ≫ g) = f ≫ curry g :=
  Adjunction.homEquiv_naturality_left _ _ _
#align category_theory.monoidal_closed.curry_natural_left CategoryTheory.MonoidalClosed.curry_natural_left

@[reassoc]
theorem curry_natural_right (f : A ⊗ X ⟶ Y) (g : Y ⟶ Y') :
    curry (f ≫ g) = curry f ≫ (ihom _).map g :=
  Adjunction.homEquiv_naturality_right _ _ _
#align category_theory.monoidal_closed.curry_natural_right CategoryTheory.MonoidalClosed.curry_natural_right

@[reassoc]
theorem uncurry_natural_right (f : X ⟶ A ⟶[C] Y) (g : Y ⟶ Y') :
    uncurry (f ≫ (ihom _).map g) = uncurry f ≫ g :=
  Adjunction.homEquiv_naturality_right_symm _ _ _
#align category_theory.monoidal_closed.uncurry_natural_right CategoryTheory.MonoidalClosed.uncurry_natural_right

@[reassoc]
theorem uncurry_natural_left (f : X ⟶ X') (g : X' ⟶ A ⟶[C] Y) :
    uncurry (f ≫ g) = (𝟙 _ ⊗ f) ≫ uncurry g :=
  Adjunction.homEquiv_naturality_left_symm _ _ _
#align category_theory.monoidal_closed.uncurry_natural_left CategoryTheory.MonoidalClosed.uncurry_natural_left

@[simp]
theorem uncurry_curry (f : A ⊗ X ⟶ Y) : uncurry (curry f) = f :=
  (Closed.isAdj.adj.homEquiv _ _).left_inv f
#align category_theory.monoidal_closed.uncurry_curry CategoryTheory.MonoidalClosed.uncurry_curry

@[simp]
theorem curry_uncurry (f : X ⟶ A ⟶[C] Y) : curry (uncurry f) = f :=
  (Closed.isAdj.adj.homEquiv _ _).right_inv f
#align category_theory.monoidal_closed.curry_uncurry CategoryTheory.MonoidalClosed.curry_uncurry

theorem curry_eq_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ A ⟶[C] X) : curry f = g ↔ f = uncurry g :=
  Adjunction.homEquiv_apply_eq (ihom.adjunction A) f g
#align category_theory.monoidal_closed.curry_eq_iff CategoryTheory.MonoidalClosed.curry_eq_iff

theorem eq_curry_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ A ⟶[C] X) : g = curry f ↔ uncurry g = f :=
  Adjunction.eq_homEquiv_apply (ihom.adjunction A) f g
#align category_theory.monoidal_closed.eq_curry_iff CategoryTheory.MonoidalClosed.eq_curry_iff

-- I don't think these two should be simp.
theorem uncurry_eq (g : Y ⟶ A ⟶[C] X) : uncurry g = (𝟙 A ⊗ g) ≫ (ihom.ev A).app X :=
  Adjunction.homEquiv_counit _
#align category_theory.monoidal_closed.uncurry_eq CategoryTheory.MonoidalClosed.uncurry_eq

theorem curry_eq (g : A ⊗ Y ⟶ X) : curry g = (ihom.coev A).app Y ≫ (ihom A).map g :=
  Adjunction.homEquiv_unit _
#align category_theory.monoidal_closed.curry_eq CategoryTheory.MonoidalClosed.curry_eq

theorem curry_injective : Function.Injective (curry : (A ⊗ Y ⟶ X) → (Y ⟶ A ⟶[C] X)) :=
  (Closed.isAdj.adj.homEquiv _ _).injective
#align category_theory.monoidal_closed.curry_injective CategoryTheory.MonoidalClosed.curry_injective

theorem uncurry_injective : Function.Injective (uncurry : (Y ⟶ A ⟶[C] X) → (A ⊗ Y ⟶ X)) :=
  (Closed.isAdj.adj.homEquiv _ _).symm.injective
#align category_theory.monoidal_closed.uncurry_injective CategoryTheory.MonoidalClosed.uncurry_injective

variable (A X)

theorem uncurry_id_eq_ev : uncurry (𝟙 (A ⟶[C] X)) = (ihom.ev A).app X := by
  rw [uncurry_eq, tensor_id, id_comp]
#align category_theory.monoidal_closed.uncurry_id_eq_ev CategoryTheory.MonoidalClosed.uncurry_id_eq_ev

theorem curry_id_eq_coev : curry (𝟙 _) = (ihom.coev A).app X := by
  rw [curry_eq, (ihom A).map_id (A ⊗ _)]
  apply comp_id
#align category_theory.monoidal_closed.curry_id_eq_coev CategoryTheory.MonoidalClosed.curry_id_eq_coev

section Pre

variable {A B} [Closed B]

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) : ihom A ⟶ ihom B :=
  transferNatTransSelf (ihom.adjunction _) (ihom.adjunction _) ((tensoringLeft C).map f)
#align category_theory.monoidal_closed.pre CategoryTheory.MonoidalClosed.pre

@[reassoc (attr := simp)]
theorem id_tensor_pre_app_comp_ev (f : B ⟶ A) (X : C) :
    (𝟙 B ⊗ (pre f).app X) ≫ (ihom.ev B).app X = (f ⊗ 𝟙 (A ⟶[C] X)) ≫ (ihom.ev A).app X :=
  transferNatTransSelf_counit _ _ ((tensoringLeft C).map f) X
#align category_theory.monoidal_closed.id_tensor_pre_app_comp_ev CategoryTheory.MonoidalClosed.id_tensor_pre_app_comp_ev

@[simp]
theorem uncurry_pre (f : B ⟶ A) (X : C) :
    MonoidalClosed.uncurry ((pre f).app X) = (f ⊗ 𝟙 _) ≫ (ihom.ev A).app X := by
  rw [uncurry_eq, id_tensor_pre_app_comp_ev]
#align category_theory.monoidal_closed.uncurry_pre CategoryTheory.MonoidalClosed.uncurry_pre

@[reassoc (attr := simp)]
theorem coev_app_comp_pre_app (f : B ⟶ A) :
    (ihom.coev A).app X ≫ (pre f).app (A ⊗ X) = (ihom.coev B).app X ≫ (ihom B).map (f ⊗ 𝟙 _) :=
  unit_transferNatTransSelf _ _ ((tensoringLeft C).map f) X
#align category_theory.monoidal_closed.coev_app_comp_pre_app CategoryTheory.MonoidalClosed.coev_app_comp_pre_app

@[simp]
theorem pre_id (A : C) [Closed A] : pre (𝟙 A) = 𝟙 _ := by
  simp only [pre, Functor.map_id]
  dsimp
  simp
#align category_theory.monoidal_closed.pre_id CategoryTheory.MonoidalClosed.pre_id

@[simp]
theorem pre_map {A₁ A₂ A₃ : C} [Closed A₁] [Closed A₂] [Closed A₃] (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
    pre (f ≫ g) = pre g ≫ pre f := by
  rw [pre, pre, pre, transferNatTransSelf_comp, (tensoringLeft C).map_comp]
#align category_theory.monoidal_closed.pre_map CategoryTheory.MonoidalClosed.pre_map

theorem pre_comm_ihom_map {W X Y Z : C} [Closed W] [Closed X] (f : W ⟶ X) (g : Y ⟶ Z) :
    (pre f).app Y ≫ (ihom W).map g = (ihom X).map g ≫ (pre f).app Z := by simp
#align category_theory.monoidal_closed.pre_comm_ihom_map CategoryTheory.MonoidalClosed.pre_comm_ihom_map

end Pre

/-- The internal hom functor given by the monoidal closed structure. -/
@[simps]
def internalHom [MonoidalClosed C] : Cᵒᵖ ⥤ C ⥤ C
    where
  obj X := ihom X.unop
  map f := pre f.unop
#align category_theory.monoidal_closed.internal_hom CategoryTheory.MonoidalClosed.internalHom

section OfEquiv

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

/-- Transport the property of being monoidal closed across a monoidal equivalence of categories -/
noncomputable def ofEquiv (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor]
    [h : MonoidalClosed D] : MonoidalClosed C
    where closed X :=
    { isAdj := by
        haveI q : Closed (F.obj X) := inferInstance
        haveI : IsLeftAdjoint (tensorLeft (F.obj X)) := q.isAdj
        have i := compInvIso (MonoidalFunctor.commTensorLeft F X)
        exact Adjunction.leftAdjointOfNatIso i }
#align category_theory.monoidal_closed.of_equiv CategoryTheory.MonoidalClosed.ofEquiv

/-- Suppose we have a monoidal equivalence `F : C ≌ D`, with `D` monoidal closed. We can pull the
monoidal closed instance back along the equivalence. For `X, Y, Z : C`, this lemma describes the
resulting currying map `Hom(X ⊗ Y, Z) → Hom(Y, (X ⟶[C] Z))`. (`X ⟶[C] Z` is defined to be
`F⁻¹(F(X) ⟶[D] F(Z))`, so currying in `C` is given by essentially conjugating currying in
`D` by `F.`) -/
theorem ofEquiv_curry_def (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor]
    [MonoidalClosed D] {X Y Z : C} (f : X ⊗ Y ⟶ Z) :
    @MonoidalClosed.curry _ _ _ _ _ _ ((MonoidalClosed.ofEquiv F).1 _) f =
      (F.1.1.adjunction.homEquiv Y ((ihom _).obj _))
        (MonoidalClosed.curry
          (F.1.1.inv.adjunction.homEquiv (F.1.1.obj X ⊗ F.1.1.obj Y) Z
            ((compInvIso (F.commTensorLeft X)).hom.app Y ≫ f))) :=
  rfl
#align category_theory.monoidal_closed.of_equiv_curry_def CategoryTheory.MonoidalClosed.ofEquiv_curry_def

/-- Suppose we have a monoidal equivalence `F : C ≌ D`, with `D` monoidal closed. We can pull the
monoidal closed instance back along the equivalence. For `X, Y, Z : C`, this lemma describes the
resulting uncurrying map `Hom(Y, (X ⟶[C] Z)) → Hom(X ⊗ Y ⟶ Z)`. (`X ⟶[C] Z` is
defined to be `F⁻¹(F(X) ⟶[D] F(Z))`, so uncurrying in `C` is given by essentially conjugating
uncurrying in `D` by `F.`) -/
theorem ofEquiv_uncurry_def (F : MonoidalFunctor C D) [IsEquivalence F.toFunctor]
    [MonoidalClosed D] {X Y Z : C}
    (f : Y ⟶ (@ihom _ _ _ X <| (MonoidalClosed.ofEquiv F).1 X).obj Z) :
    @MonoidalClosed.uncurry _ _ _ _ _ _ ((MonoidalClosed.ofEquiv F).1 _) f =
      (compInvIso (F.commTensorLeft X)).inv.app Y ≫
        (F.1.1.inv.adjunction.homEquiv (F.1.1.obj X ⊗ F.1.1.obj Y) Z).symm
          (MonoidalClosed.uncurry
            ((F.1.1.adjunction.homEquiv Y ((ihom (F.1.1.obj X)).obj (F.1.1.obj Z))).symm f)) :=
  rfl
#align category_theory.monoidal_closed.of_equiv_uncurry_def CategoryTheory.MonoidalClosed.ofEquiv_uncurry_def
end OfEquiv

end MonoidalClosed

end CategoryTheory


/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import ring_theory.dedekind_domain.factorization
import topology.algebra.uniform_group

/-!
# Factorization of fractional ideals of Dedekind domains
Every nonzero fractional ideal `I` of a Dedekind domain `R` can be factored as a product
`∏_v v^{n_v}` over the maximal ideals of `R`, where the exponents `n_v` are integers. We define
`fractional_ideal.count K v I` (abbreviated as `val_v(I)` in the documentation) to be `n_v`, and we
prove some of its properties. If `I = 0`, we define `val_v(I) = 0`.

## Main definitions
- `fractional_ideal.count` : If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an ideal of
  `R` such that `I = a⁻¹J`, then we define `val_v(I)` as `(val_v(J) - val_v(a))`. If `I = 0`, we
  set `val_v(I) = 0`.

## Main results
- `ideal.factorization` : The ideal `I` equals the finprod `∏_v v^(val_v(I))`.
- `fractional_ideal.factorization` : If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an
ideal of `R` such that `I = a⁻¹J`, then `I` is equal to the product `∏_v v^(val_v(J) - val_v(a))`.
- `fractional_ideal.factorization_principal` : For a nonzero `k = r/s ∈ K`, the fractional ideal
`(k)` is equal to the product `∏_v v^(val_v(r) - val_v(s))`.
- `fractional_ideal.finite_factors` : If `I ≠ 0`, then `val_v(I) = 0` for all but finitely many
  maximal ideals of `R`.

## Implementation notes
Since we are only interested in nonzero fractional ideals, we chose to define `val_v(I) = 0` so that
every `val_v` is in `ℤ` and we can avoid having to use `with_top ℤ`.

## Tags
dedekind domain, fractional ideal, factorization
-/

noncomputable theory
open_locale big_operators classical

open set function unique_factorization_monoid is_dedekind_domain
  is_dedekind_domain.height_one_spectrum

/-! ### Factorization of fractional ideals of Dedekind domains -/

variables {A : Type*} [comm_ring A] (B : submonoid A) (C : Type*) [comm_ring C] [algebra A C]

/-- If a prime `p` divides a `finprod`, then it must divide one of its factors. -/
lemma prime.exists_mem_finprod_dvd {α : Type*} {N : Type*} [comm_monoid_with_zero N] {f : α → N}
  {p : N} (hp : prime p) (hf : (mul_support f).finite) :
  p ∣  ∏ᶠ i, f i →  ∃ (a : α), p ∣ f a :=
begin
  rw finprod_eq_prod _ hf,
  intro h,
  obtain ⟨a, -, ha_dvd⟩ := prime.exists_mem_finset_dvd hp h,
  exact ⟨a, ha_dvd⟩,
end

variables {R : Type*} {K : Type*} [comm_ring R] [field K] [algebra R K]

/-- The discrete topology on the units of the fractional ideals. -/
instance ufi_ts : topological_space (units (fractional_ideal (non_zero_divisors R) K)) := ⊥

/-- The units of the fractional ideals with the discrete topology are a topological group.  -/
instance ufi_tg : topological_group (units (fractional_ideal (non_zero_divisors R) K)) :=
{ continuous_mul := continuous_of_discrete_topology,
  continuous_inv := continuous_of_discrete_topology, }

instance ufi_us : uniform_space (units (fractional_ideal (non_zero_divisors R) K)) :=
topological_group.to_uniform_space _

instance ufi_ug : uniform_group (units (fractional_ideal (non_zero_divisors R) K)) :=
topological_comm_group_is_uniform

variables [is_fraction_ring R K]

/-- If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an ideal of `R` such that
`I = a⁻¹J`, then `J` is nonzero. -/
lemma fractional_ideal.ideal_factor_ne_zero {I : fractional_ideal (non_zero_divisors R) K}
  (hI : I ≠ 0) {a : R} {J : ideal R}
  (haJ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a)⁻¹ * ↑J) :
  J ≠ 0 :=
begin
  intro h,
  rw [h, ideal.zero_eq_bot, fractional_ideal.coe_to_fractional_ideal_bot, mul_zero] at haJ,
  exact hI haJ,
end

/-- If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an ideal of `R` such that
`I = a⁻¹J`, then `a` is nonzero. -/
lemma fractional_ideal.constant_factor_ne_zero {I : fractional_ideal (non_zero_divisors R) K}
  (hI : I ≠ 0) {a : R} {J : ideal R}
  (haJ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a)⁻¹ * ↑J) :
  (ideal.span{a} : ideal R) ≠ 0 :=
begin
  intro h,
  rw [ideal.zero_eq_bot, ideal.span_singleton_eq_bot] at h,
  rw [h, ring_hom.map_zero, inv_zero, fractional_ideal.span_singleton_zero, zero_mul] at haJ,
  exact hI haJ,
end

open is_dedekind_domain

variables [is_domain R] [is_dedekind_domain R] (v : height_one_spectrum R)

/-- Only finitely many maximal ideals of `R` divide a given nonzero principal ideal. -/
lemma finite_factors (d : R) (hd : (ideal.span{d} : ideal R) ≠ 0) :
  {v : height_one_spectrum R | v.as_ideal ∣ (ideal.span({d}) : ideal R)}.finite :=
ideal.finite_factors hd

/-- If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an ideal of `R` such that
`I = a⁻¹J`, then `I` is equal to the product `∏_v v^(val_v(J) - val_v(a))`. -/
lemma fractional_ideal.factorization (I : fractional_ideal (non_zero_divisors R) K) (hI : I ≠ 0)
  {a : R} {J : ideal R}
  (haJ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a)⁻¹ * ↑J) :
  ∏ᶠ (v : height_one_spectrum R), (v.as_ideal : fractional_ideal (non_zero_divisors R) K)^
    ((associates.mk v.as_ideal).count (associates.mk J).factors -
    (associates.mk v.as_ideal).count (associates.mk (ideal.span{a})).factors : ℤ) = I :=
begin
  have hJ_ne_zero : J ≠ 0 := fractional_ideal.ideal_factor_ne_zero hI haJ,
  have hJ := ideal.finprod_height_one_spectrum_factorization_coe J hJ_ne_zero,
  have ha_ne_zero : ideal.span{a} ≠ 0 := fractional_ideal.constant_factor_ne_zero hI haJ,
  have ha := ideal.finprod_height_one_spectrum_factorization_coe (ideal.span{a} : ideal R)
    ha_ne_zero,
  rw [haJ, ← fractional_ideal.div_span_singleton, fractional_ideal.div_eq_mul_inv,
    ← fractional_ideal.coe_ideal_span_singleton, ← hJ, ← ha, ← finprod_inv_distrib],
  simp_rw ← zpow_neg,
  rw ← finprod_mul_distrib,
  apply finprod_congr,
  intro v,
  rw [← zpow_add₀ ((@fractional_ideal.coe_ideal_ne_zero_iff R _ K _ _ _ _).mpr v.ne_bot),
    sub_eq_add_neg],
  apply ideal.finite_mul_support_coe hJ_ne_zero,
  apply ideal.finite_mul_support_inv ha_ne_zero,
  { apply_instance },
end

/-- For a nonzero `k = r/s ∈ K`, the fractional ideal `(k)` is equal to the product
`∏_v v^(val_v(r) - val_v(s))`. -/
lemma fractional_ideal.factorization_principal (I : fractional_ideal (non_zero_divisors R) K)
  (hI : I ≠ 0) (k : K) (hk : I = fractional_ideal.span_singleton (non_zero_divisors R) k) :
  ∏ᶠ (v : height_one_spectrum R), (v.as_ideal : fractional_ideal (non_zero_divisors R) K)^
    ((associates.mk v.as_ideal).count (associates.mk (ideal.span
    {classical.some (is_localization.mk'_surjective (non_zero_divisors R) k)} : ideal R)).factors -
    (associates.mk v.as_ideal).count (associates.mk (ideal.span { (classical.some
    (classical.some_spec (is_localization.mk'_surjective (non_zero_divisors R) k)) :
    ↥(non_zero_divisors R))} : ideal R)).factors : ℤ) = I :=
begin
  set n : R := classical.some(is_localization.mk'_surjective (non_zero_divisors R) k) with hn,
  set d : ↥(non_zero_divisors R) := (classical.some (classical.some_spec
    (is_localization.mk'_surjective (non_zero_divisors R) k))) with hd,
  have hd_ne_zero : (algebra_map R K) (d : R) ≠ 0 := map_ne_zero_of_mem_non_zero_divisors
    _ (is_fraction_ring.injective R K) d.property,
  have haJ' : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) d)⁻¹ *
    ↑(ideal.span {n} : ideal R),
  { rw [hk, fractional_ideal.coe_ideal_span_singleton,
      fractional_ideal.span_singleton_mul_span_singleton],
    apply congr_arg,
    rw [eq_inv_mul_iff_mul_eq₀ hd_ne_zero, mul_comm,
      ← is_localization.eq_mk'_iff_mul_eq, eq_comm],
    exact classical.some_spec (classical.some_spec (is_localization.mk'_surjective
      (non_zero_divisors R) k)), },
exact fractional_ideal.factorization I hI haJ',
end

variables (K)

/-- If `I` is a nonzero fractional ideal, `a ∈ R`, and `J` is an ideal of `R` such that `I = a⁻¹J`,
then we define `val_v(I)` as `(val_v(J) - val_v(a))`. If `I = 0`, we set `val_v(I) = 0`. -/
def fractional_ideal.count (I : fractional_ideal (non_zero_divisors R) K) : ℤ :=
dite (I = 0) (λ (hI : I = 0), 0) (λ hI : ¬ I = 0,
let a := classical.some (fractional_ideal.exists_eq_span_singleton_mul I) in let
J := classical.some (classical.some_spec (fractional_ideal.exists_eq_span_singleton_mul I))
in ((associates.mk v.as_ideal).count (associates.mk J).factors -
    (associates.mk v.as_ideal).count (associates.mk (ideal.span{a})).factors : ℤ))

/-- `val_v(I)` does not depend on the choice of `a` and `J` used to represent `I`. -/
lemma fractional_ideal.count_well_defined  {I : fractional_ideal (non_zero_divisors R) K}
  (hI : I ≠ 0)  {a : R} {J : ideal R}
  (h_aJ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a)⁻¹ * ↑J) :
  fractional_ideal.count K v I = ((associates.mk v.as_ideal).count (associates.mk J).factors -
    (associates.mk v.as_ideal).count (associates.mk (ideal.span{a})).factors : ℤ) :=
begin
  set a₁ := classical.some (fractional_ideal.exists_eq_span_singleton_mul I) with h_a₁,
  set J₁ := classical.some (classical.some_spec (fractional_ideal.exists_eq_span_singleton_mul I))
    with h_J₁,
  have h_a₁J₁ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a₁)⁻¹ *
    ↑J₁ :=
(classical.some_spec (classical.some_spec (fractional_ideal.exists_eq_span_singleton_mul I))).2,
  have h_a₁_ne_zero : a₁ ≠ 0 :=
  (classical.some_spec (classical.some_spec (fractional_ideal.exists_eq_span_singleton_mul I))).1,
  have h_J₁_ne_zero : J₁ ≠ 0 := fractional_ideal.ideal_factor_ne_zero hI h_a₁J₁,
  have h_a_ne_zero : ideal.span{a} ≠ 0 := fractional_ideal.constant_factor_ne_zero hI h_aJ,
  have h_J_ne_zero : J ≠ 0 := fractional_ideal.ideal_factor_ne_zero hI h_aJ,
  have h_a₁' : fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a₁) ≠ 0,
  { rw [ne.def, fractional_ideal.span_singleton_eq_zero_iff, ← (algebra_map R K).map_zero,
      injective.eq_iff (is_localization.injective K (le_refl (non_zero_divisors R)))],
    exact h_a₁_ne_zero,},
  have h_a' : fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a) ≠ 0,
  { rw [ne.def, fractional_ideal.span_singleton_eq_zero_iff, ← (algebra_map R K).map_zero,
      injective.eq_iff (is_localization.injective K (le_refl (non_zero_divisors R)))],
    rw [ne.def, ideal.zero_eq_bot, ideal.span_singleton_eq_bot] at h_a_ne_zero,
    exact h_a_ne_zero,},
  have hv : irreducible (associates.mk v.as_ideal),
  { rw associates.irreducible_mk,
    exact v.irreducible, },
  rw [h_a₁J₁, ← fractional_ideal.div_span_singleton, ← fractional_ideal.div_span_singleton,
    div_eq_div_iff h_a₁' h_a', ← fractional_ideal.coe_ideal_span_singleton,
    ← fractional_ideal.coe_ideal_span_singleton, ← fractional_ideal.coe_ideal_mul,
    ← fractional_ideal.coe_ideal_mul] at h_aJ,
  rw [fractional_ideal.count, dif_neg hI, sub_eq_sub_iff_add_eq_add, ← int.coe_nat_add,
    ← int.coe_nat_add, int.coe_nat_inj', ← associates.count_mul _ _ hv,
    ← associates.count_mul _ _ hv, associates.mk_mul_mk, associates.mk_mul_mk,
    fractional_ideal.coe_ideal_injective h_aJ],
  { rw [ne.def, associates.mk_eq_zero], exact h_J_ne_zero },
  { rw [ne.def, associates.mk_eq_zero, ideal.zero_eq_bot, ideal.span_singleton_eq_bot],
    exact h_a₁_ne_zero, },
  { rw [ne.def, associates.mk_eq_zero], exact h_J₁_ne_zero },
  { rw [ne.def, associates.mk_eq_zero], exact h_a_ne_zero },
end

/-- For nonzero `I, I'`, `val_v(I*I') = val_v(I) + val_v(I')`. -/
lemma fractional_ideal.count_mul {I I' : fractional_ideal (non_zero_divisors R) K} (hI : I ≠ 0)
  (hI' : I' ≠ 0) : fractional_ideal.count K v (I*I')  = fractional_ideal.count K v (I) +
  fractional_ideal.count K v (I') :=
begin
  have hv : irreducible (associates.mk v.as_ideal),
  { apply v.associates_irreducible },
  obtain ⟨a, J, ha, haJ⟩ := fractional_ideal.exists_eq_span_singleton_mul I,
  have ha_ne_zero : associates.mk (ideal.span {a} : ideal R) ≠ 0,
  { rw [ne.def, associates.mk_eq_zero, ideal.zero_eq_bot, ideal.span_singleton_eq_bot], exact ha },
  have hJ_ne_zero : associates.mk J ≠ 0,
  { rw [ne.def, associates.mk_eq_zero], exact fractional_ideal.ideal_factor_ne_zero hI haJ },
  obtain ⟨a', J', ha', haJ'⟩ := fractional_ideal.exists_eq_span_singleton_mul I',
  have ha'_ne_zero : associates.mk (ideal.span {a'} : ideal R) ≠ 0,
  { rw [ne.def, associates.mk_eq_zero, ideal.zero_eq_bot, ideal.span_singleton_eq_bot], exact ha' },
  have hJ'_ne_zero : associates.mk J' ≠ 0,
  { rw [ne.def, associates.mk_eq_zero], exact fractional_ideal.ideal_factor_ne_zero hI' haJ' },
  have h_prod : I*I' = fractional_ideal.span_singleton (non_zero_divisors R)
    ((algebra_map R K) (a*a'))⁻¹ * ↑(J*J'),
    { rw [haJ, haJ', mul_assoc, mul_comm ↑J, mul_assoc, ← mul_assoc,
      fractional_ideal.span_singleton_mul_span_singleton,
      fractional_ideal.coe_ideal_mul, ring_hom.map_mul, mul_inv, mul_comm ↑J] },
  rw [fractional_ideal.count_well_defined K v hI haJ,
    fractional_ideal.count_well_defined K v hI' haJ',
    fractional_ideal.count_well_defined K v (mul_ne_zero hI hI') h_prod,
    ← associates.mk_mul_mk, associates.count_mul hJ_ne_zero hJ'_ne_zero hv,
    ← ideal.span_singleton_mul_span_singleton, ← associates.mk_mul_mk,
    associates.count_mul ha_ne_zero ha'_ne_zero hv],
  push_cast,
  ring,
end

/-- For nonzero `I, I'`, `val_v(I*I') = val_v(I) + val_v(I')`. If `I` or `I'` is zero, then
`val_v(I*I') = 0`. -/
lemma fractional_ideal.count_mul' (I I' : fractional_ideal (non_zero_divisors R) K) :
  fractional_ideal.count K v (I*I')  = (if I ≠ 0 ∧ I' ≠ 0 then  fractional_ideal.count K v (I) +
    fractional_ideal.count K v (I') else 0) :=
begin
  split_ifs,
  { exact fractional_ideal.count_mul K v h.1 h.2 },
  { push_neg at h,
    by_cases hI : I = 0,
    { rw [hI, zero_mul, fractional_ideal.count, dif_pos (eq.refl _)], },
    { rw [(h hI), mul_zero, fractional_ideal.count, dif_pos (eq.refl _)], }}
end

/-- val_v(0) = 0. -/
lemma fractional_ideal.count_zero :
  fractional_ideal.count K v (0 : fractional_ideal (non_zero_divisors R) K) = 0 :=
by rw [fractional_ideal.count, dif_pos (eq.refl _)]

/-- val_v(1) = 0. -/
lemma fractional_ideal.count_one :
  fractional_ideal.count K v (1 : fractional_ideal (non_zero_divisors R) K) = 0 :=
begin
  have h_one : (1 : fractional_ideal (non_zero_divisors R) K) = fractional_ideal.span_singleton
    (non_zero_divisors R) ((algebra_map R K) (1))⁻¹ * ↑(1 : ideal R),
  { rw [(algebra_map R K).map_one, ideal.one_eq_top, fractional_ideal.coe_ideal_top, mul_one,
      inv_one, fractional_ideal.span_singleton_one], },
  rw [fractional_ideal.count_well_defined K v one_ne_zero h_one, ideal.span_singleton_one,
    ideal.one_eq_top, sub_self],
end

/-- For every `n ∈ ℕ` and every ideal `I`, `val_v(I^n) = n*val_v(I)`. -/
lemma fractional_ideal.count_pow (n : ℕ) (I : fractional_ideal (non_zero_divisors R) K) :
  fractional_ideal.count K v (I^n) = n * fractional_ideal.count K v I :=
begin
  induction n with n h,
  { rw [pow_zero, int.coe_nat_zero, zero_mul, fractional_ideal.count_one] },
  { rw pow_succ, rw fractional_ideal.count_mul',
    by_cases hI : I = 0,
    { have h_neg : ¬ (I ≠ 0 ∧ I ^ n ≠ 0),
      { rw [not_and, not_not, ne.def], intro h, exact absurd hI h, },
      rw [if_neg h_neg, hI, fractional_ideal.count_zero, mul_zero], },
    { rw [if_pos (and.intro hI (pow_ne_zero n hI)), h, nat.succ_eq_add_one], ring, }},
end

/--`val_v(v) = 1`, when `v` is regarded as a fractional ideal. -/
lemma fractional_ideal.count_self :
  fractional_ideal.count K v (v.as_ideal : fractional_ideal (non_zero_divisors R) K)  = 1 :=
begin
  have hv : (v.as_ideal : fractional_ideal (non_zero_divisors R) K) ≠ 0,
  { rw fractional_ideal.coe_ideal_ne_zero_iff,
    exact v.ne_bot  },
  have h_self : (v.as_ideal : fractional_ideal (non_zero_divisors R) K) =
    fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) 1)⁻¹ *
    ↑(v.as_ideal),
  { rw [(algebra_map R K).map_one, inv_one, fractional_ideal.span_singleton_one, one_mul], },
  have hv_irred : irreducible (associates.mk v.as_ideal),
  { apply v.associates_irreducible },
  rw [fractional_ideal.count_well_defined K v hv h_self, associates.count_self hv_irred,
    ideal.span_singleton_one, ← ideal.one_eq_top, associates.mk_one, associates.factors_one,
    associates.count_zero hv_irred, int.coe_nat_zero, sub_zero, int.coe_nat_one],
end

/--`val_v(v) = n` for every `n ∈ ℕ`. -/
lemma fractional_ideal.count_pow_self (n : ℕ) :
  fractional_ideal.count K v ((v.as_ideal : fractional_ideal (non_zero_divisors R) K)^n) = n :=
by rw [fractional_ideal.count_pow, fractional_ideal.count_self, mul_one]

/--`val_v(I⁻ⁿ) = -val_v(Iⁿ)` for every `n ∈ ℤ`. -/
lemma fractional_ideal.count_inv (n : ℤ) (I : fractional_ideal (non_zero_divisors R) K) :
  fractional_ideal.count K v (I^-n) = - fractional_ideal.count K v (I^n) :=
begin
  by_cases hI : I = 0,
  {by_cases hn : n = 0,
    { rw [hn, neg_zero, zpow_zero, fractional_ideal.count_one, neg_zero], },
    { rw [hI, zero_zpow n hn, zero_zpow (-n) (neg_ne_zero.mpr hn), fractional_ideal.count_zero,
        neg_zero], }},
  { rw [eq_neg_iff_add_eq_zero,
    ←  fractional_ideal.count_mul K v (zpow_ne_zero _ hI) (zpow_ne_zero _ hI),
    ← zpow_add₀ hI, neg_add_self, zpow_zero],
    exact fractional_ideal.count_one K v, }
end

/--`val_v(Iⁿ) = n*val_v(I)` for every `n ∈ ℤ`. -/
lemma fractional_ideal.count_zpow (n : ℤ) (I : fractional_ideal (non_zero_divisors R) K) :
  fractional_ideal.count K v (I^n) = n * fractional_ideal.count K v I :=
begin
  cases n,
  { rw [int.of_nat_eq_coe, zpow_coe_nat],
    exact fractional_ideal.count_pow K v n I, },
  { rw [int.neg_succ_of_nat_coe, fractional_ideal.count_inv, zpow_coe_nat,
      fractional_ideal.count_pow], ring, }
end

/--`val_v(v) = n` for every `n ∈ ℤ`. -/
lemma fractional_ideal.count_zpow_self (n : ℤ) :
  fractional_ideal.count K v
  ((v.as_ideal : fractional_ideal (non_zero_divisors R) K)^n) = n :=
by rw [fractional_ideal.count_zpow, fractional_ideal.count_self, mul_one]

/-- If `v ≠ w` are two maximal ideals of `R`, then `val_v(w) = 0`. -/
lemma fractional_ideal.count_maximal_coprime (w : height_one_spectrum R) (hw : w ≠ v) :
  fractional_ideal.count K v (w.as_ideal : fractional_ideal (non_zero_divisors R) K) = 0 :=
begin
  have hw_fact : (w.as_ideal : fractional_ideal (non_zero_divisors R) K) =
   fractional_ideal.span_singleton
    (non_zero_divisors R) ((algebra_map R K) (1))⁻¹ * ↑(w.as_ideal),
  { rw [(algebra_map R K).map_one, inv_one, fractional_ideal.span_singleton_one, one_mul], },
  have hw_ne_zero : (w.as_ideal : fractional_ideal (non_zero_divisors R) K) ≠ 0,
  { rw fractional_ideal.coe_ideal_ne_zero_iff,
    exact w.ne_bot  },
  have hv : irreducible (associates.mk v.as_ideal) :=
  by apply v.associates_irreducible,
  have hw' : irreducible (associates.mk w.as_ideal) :=
  by apply w.associates_irreducible,
  rw [fractional_ideal.count_well_defined K v hw_ne_zero hw_fact, ideal.span_singleton_one,
    ← ideal.one_eq_top, associates.mk_one, associates.factors_one, associates.count_zero hv,
    int.coe_nat_zero, sub_zero, int.coe_nat_eq_zero, ← pow_one (associates.mk w.as_ideal),
    associates.factors_prime_pow hw', associates.count_some hv, multiset.repeat_one,
    multiset.count_eq_zero, multiset.mem_singleton],
  simp only [subtype.val_eq_coe],
  rw [associates.mk_eq_mk_iff_associated, associated_iff_eq, ← height_one_spectrum.ext_iff],
  exact ne.symm hw,
end

/-- `val_v(∏_{w ≠ v} w^{exps w}) = 0`. -/
lemma fractional_ideal.count_finprod_coprime (exps : height_one_spectrum R → ℤ) :
  fractional_ideal.count K v (∏ᶠ (w : height_one_spectrum R) (H : w ≠ v), ↑(w.as_ideal) ^ exps w) = 0 :=
begin
  apply finprod_mem_induction (λ I, fractional_ideal.count K v I = 0),
  { exact fractional_ideal.count_one K v },
  { intros I I' hI hI',
    by_cases h : I ≠ 0 ∧ I' ≠ 0,
    { rw [fractional_ideal.count_mul' K v, if_pos h, hI, hI', add_zero] },
    { rw [fractional_ideal.count_mul' K v, if_neg h], }},
  { intros w hw,
    rw [fractional_ideal.count_zpow, fractional_ideal.count_maximal_coprime K v w hw, mul_zero] }
end

/-- If `exps` is finitely supported, then `val_v(∏_w w^{exps w}) = exps v`. -/
lemma fractional_ideal.count_finprod (exps : height_one_spectrum R → ℤ)
(h_exps : ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, exps v = 0 ) :
fractional_ideal.count K v (∏ᶠ (v : height_one_spectrum R),
  (v.as_ideal : fractional_ideal (non_zero_divisors R) K)^(exps v)) = exps v :=
begin
  have h_supp : (mul_support (λ (i : height_one_spectrum R), ↑(i.as_ideal) ^ exps i)).finite,
  { have h_subset : {v : height_one_spectrum R |
      (v.as_ideal : fractional_ideal (non_zero_divisors R) K) ^ exps v ≠ 1} ⊆
      {v : height_one_spectrum R | exps v ≠ 0},
    { intros v hv,
      by_contradiction h,
      rw [mem_set_of_eq, not_not] at h,
      rw [mem_set_of_eq, h, zpow_zero] at hv,
      exact hv (eq.refl 1),},
    exact finite.subset h_exps h_subset, },
    rw [← mul_finprod_cond_ne v h_supp, fractional_ideal.count_mul,
      fractional_ideal.count_zpow_self, fractional_ideal.count_finprod_coprime, add_zero],
  { apply zpow_ne_zero,
    exact fractional_ideal.coe_ideal_ne_zero_iff.mpr v.ne_bot, },
  { rw [finprod_cond_ne _ _ h_supp, finset.prod_ne_zero_iff],
    intros w hw,
    apply zpow_ne_zero,
    exact fractional_ideal.coe_ideal_ne_zero_iff.mpr w.ne_bot, }
end

variable {K}
/-- If `I ≠ 0`, then `val_v(I) = 0` for all but finitely many maximal ideals of `R`. -/
lemma fractional_ideal.finite_factors {I : fractional_ideal (non_zero_divisors R) K} (hI : I ≠ 0)
  {a : R} {J : ideal R}
  (haJ : I = fractional_ideal.span_singleton (non_zero_divisors R) ((algebra_map R K) a)⁻¹ * ↑J) :
  ∀ᶠ v : height_one_spectrum R in filter.cofinite,
  (((associates.mk v.as_ideal).count (associates.mk J).factors : ℤ) -
    ((associates.mk v.as_ideal).count (associates.mk (ideal.span {a})).factors) = 0) :=
begin
  have ha_ne_zero : ideal.span{a} ≠ 0 := fractional_ideal.constant_factor_ne_zero hI haJ,
  have hJ_ne_zero : J ≠ 0 := fractional_ideal.ideal_factor_ne_zero hI haJ,
  rw filter.eventually_cofinite,
  have h_subset : {v : height_one_spectrum R | ¬((associates.mk v.as_ideal).count
    (associates.mk J).factors : ℤ) -
    ↑((associates.mk v.as_ideal).count (associates.mk (ideal.span {a})).factors) = 0} ⊆
    {v : height_one_spectrum R | v.as_ideal ∣ J} ∪
    {v : height_one_spectrum R | v.as_ideal ∣ (ideal.span {a})},
  { intros v hv,
    have hv_irred : irreducible v.as_ideal := v.irreducible,
    by_contradiction h_nmem,
    rw [mem_union, mem_set_of_eq, mem_set_of_eq] at h_nmem,
    push_neg at h_nmem,
    rw [← associates.count_ne_zero_iff_dvd ha_ne_zero hv_irred, not_not,
    ← associates.count_ne_zero_iff_dvd hJ_ne_zero hv_irred, not_not]
      at h_nmem,
    rw [mem_set_of_eq, h_nmem.1, h_nmem.2, sub_self] at hv,
    exact hv (eq.refl 0), },
  exact finite.subset (finite.union
    (ideal.finite_factors (fractional_ideal.ideal_factor_ne_zero hI haJ))
    (ideal.finite_factors (fractional_ideal.constant_factor_ne_zero hI haJ)))
    h_subset,
end


import counting
open finset nat turanpartition

open_locale big_operators

namespace simple_graph
variables {t n : ℕ}
variables {α : Type*} (G H : simple_graph α)[fintype α][nonempty α]{s : finset α}
[decidable_eq α][decidable_rel G.adj][decidable_rel H.adj]

/-
# Furedi stability result (no counting):

If G is K_{t+2}-free with vertex set α then there is a (t+1)-partition M of α
 such that the e(G)+ ∑ i< t+1, e(G[M_i]) ≤ e(complete_multipartite M)

# Turan's theorem

 Together with an upper bound on the number of edges in any complete multipartite graph
 Furedi's result easily implies Turan with equality iff G is a complete multipartite graph on a
 turan partition (ie. a Turan graph)

  def turan_numb : ℕ → ℕ → ℕ:=
  begin
    intros t n,
    set a:= n/(t+1),--- size of a small part
    set b:= n%(t+1),-- number of large parts
    exact (a^2)*nat.choose(t+1-b)(2)+a*(a+1)*b*(t+1-b)+((a+1)^2)*nat.choose(b)(2)
  end

#eval turan_numb 1 11  -- = 5*6 = 30        K_3-free bipartite
#eval turan_numb 2 12  -- = 3*(4*4) = 48    K_4-free tri-partite
#eval turan_numb 5 23  -- = 5*(4*3) +(5 choose 2)*(4*4) = 60+160 = 220 --  K_7-free 6-partite

# Furedi with counting:
If G is K_{t+2}-free and is close to extremal in size then G is close to (t+1)-partite.

-/

theorem furedi_stability : G.clique_free (t+2) → ∃ M: multi_part α, M.t = t ∧ M.A = univ ∧
G.edge_finset.card + ∑ i in range(t+1), (G.ind (M.P i)).edge_finset.card ≤ (mp M).edge_finset.card:=
begin
  intro h, obtain ⟨M,hA,ht,hs⟩:=G.furedi univ (G.clique_free_graph_imp_set h),
  refine ⟨M,ht,hA,_⟩,apply (mul_le_mul_left (by norm_num:0<2)).mp, rw [mul_add, mul_sum], simp only [deg_res_univ] at hs,
  rw  [← G.sum_degrees_eq_twice_card_edges,← (mp M).sum_degrees_eq_twice_card_edges],
  apply le_trans _ hs, apply add_le_add_left, apply le_of_eq, apply sum_congr, rwa ht,
  intros i hi, rw ← ind_edge_count,
end

-- So we have e(G)+edges internal to the partiton ≤ edges of complete (t+1)-partite M
theorem furedi_stability' : G.clique_free (t+2) → ∃ M: multi_part α, M.t=t ∧ M.A=univ ∧
G.edge_finset.card + (G.disJoin M).edge_finset.card ≤ (mp M).edge_finset.card:=
begin
  intro h, obtain⟨M,ht,hu,hle⟩:=G.furedi_stability h, rw ← ht at hle,rw ← G.disJoin_edge_sum hu at hle,
  exact ⟨M,ht,hu,hle⟩,
end

--Now deduce Turan's theorem without worring about case of equality yet
theorem turan : G.clique_free (t+2) → G.edge_finset.card ≤ turan_numb t (fintype.card α):=
begin
  intro h, obtain ⟨M,ht,hA,hc⟩:=G.furedi_stability h,
  have :=turan_max_edges M hA,rw ht at this,
  apply le_trans (le_of_add_le_left hc) this,
end

-- Uniqueness?
---There are three places where G can fail to achieve equality in Furedi's stability theorem
-- 1) there are "internal" edges, ie edges inside a part of the (t+1)-partition  (counted in the LHS)
-- 2) the partition can fail to be balanced (and hence #edgesof mp M < turan_numb)
-- 3) the multipartite induced graph G ⊓ (mp M) may not be complete
-- Clearly for equality in Furedi-Turan hybrid ie LHS of Furedi with RHS of Turan
-- need M is a balanced partition and G is multipartite (ie no internal edges)
-- can then prove in this case G ≤ (mp M) = T and hence G = T for equality.

--Now deduce case of equality in Turan's theorem
theorem turan_equality :  G.clique_free (t+2) ∧ G.edge_finset.card = turan_numb t (fintype.card α)
 ↔  ∃ M:multi_part α, M.t=t ∧ M.A=univ ∧ turan_partition M ∧ G = mp M:=
begin
  split,{
  intro h,obtain ⟨M,ht,hu,hle⟩:=G.furedi_stability' h.1, rw h.2 at hle,
  refine ⟨M,ht,hu,_⟩, have tm:=turan_max_edges M hu, rw ht at tm,
  have inz:(G.disJoin M).edge_finset.card=0:= by linarith, rw card_eq_zero at inz,
  have inem: (G.disJoin M)=⊥:=empty_iff_edge_empty.mpr inz,
  have dec:=G.self_eq_disJoin_ext_mp hu,rw inem at dec, simp only [bot_sup_eq, left_eq_inf] at dec,
  have ieq:(mp M).edge_finset.card= turan_numb t (fintype.card α):=by linarith, rw ← ht at ieq,
  refine ⟨turan_eq_imp M hu ieq,_⟩, rw ←  h.2 at tm,
  exact edge_eq_sub_imp_eq dec tm},
  { intro h, obtain ⟨M,ht,hu,iM,hG⟩:=h,
    have hc:=mp_clique_free M ht hu,
    have ieq:=turan_imm_imp_eq M hu ht iM,  rw ← hG at hc,
    refine ⟨hc,_⟩,
--    rw ← hG at ieq, ---TO DO: figure out why this rewrite of "G = mp M" doesn't work ... "motive is not type correct"
    rw ← ieq, exact eq_imp_edges_card_eq hG}
end

-- The usual version of Furedi's stability theorem says:
-- if G is (K_t+2)-free and has (turan numb - s) edges
-- then we can make G (t+1)-partite by deleting at most s edges

theorem furedi_stability_count {s : ℕ} : G.clique_free (t+2) → G.edge_finset.card = turan_numb t (fintype.card α) - s →
∃ M: multi_part α, M.t=t ∧ M.A=univ  ∧ G.is_far (mp M) s:=
begin
--
intros h1 h2, obtain ⟨M,ht,hA,hle⟩:=G.furedi_stability' h1,
refine ⟨M,ht,hA,_⟩, rw h2 at hle,
have tm:=turan_max_edges M hA, rw  ht at tm,
by_cases hs: s≤ turan_numb t (fintype.card α),{
have ic:(G.disJoin M).edge_finset.card ≤ s:= by linarith,
have id:=G.self_eq_disJoin_ext_mp hA,
refine ⟨(G.disJoin M).edge_finset,_,ic⟩,
rw G.del_fedges_is_sdiff (G.disJoin M),{ rw G.sdiff_with_int hA,
  by { intro, simp { contextual := tt } },},
  {exact (G.disJoin M).edge_finset},},
  {have :G.edge_finset.card ≤s:=by linarith,
    exact G.is_far_trivial (mp M) s (this)},
end

end simple_graph


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Buzzard, Yury Kudryashov
-/
import algebra.module.submodule
import algebra.punit_instances

/-!
# The lattice structure on `submodule`s

This file defines the lattice structure on submodules, `submodule.complete_lattice`, with `⊥`
defined as `{0}` and `⊓` defined as intersection of the underlying carrier.
If `p` and `q` are submodules of a module, `p ≤ q` means that `p ⊆ q`.

Many results about operations on this lattice structure are defined in `linear_algebra/basic.lean`,
most notably those which use `span`.

## Implementation notes

This structure should match the `add_submonoid.complete_lattice` structure, and we should try
to unify the APIs where possible.

-/

variables {R S M : Type*}

section add_comm_monoid
variables [semiring R] [semiring S] [add_comm_monoid M] [module R M] [module S M]
variables [has_scalar S R] [is_scalar_tower S R M]
variables {p q : submodule R M}

namespace submodule

/-- The set `{0}` is the bottom element of the lattice of submodules. -/
instance : has_bot (submodule R M) :=
⟨{ carrier := {0}, smul_mem' := by simp { contextual := tt }, .. (⊥ : add_submonoid M)}⟩

instance inhabited' : inhabited (submodule R M) := ⟨⊥⟩

@[simp] lemma bot_coe : ((⊥ : submodule R M) : set M) = {0} := rfl
@[simp] lemma bot_to_add_submonoid : (⊥ : submodule R M).to_add_submonoid = ⊥ := rfl

section
variables (R)
@[simp] lemma restrict_scalars_bot : restrict_scalars S (⊥ : submodule R M) = ⊥ := rfl

@[simp] lemma mem_bot {x : M} : x ∈ (⊥ : submodule R M) ↔ x = 0 := set.mem_singleton_iff
end

@[simp] lemma restrict_scalars_eq_bot_iff {p : submodule R M} :
  restrict_scalars S p = ⊥ ↔ p = ⊥ :=
by simp [set_like.ext_iff]

instance unique_bot : unique (⊥ : submodule R M) :=
⟨infer_instance, λ x, subtype.ext $ (mem_bot R).1 x.mem⟩

instance : order_bot (submodule R M) :=
{ bot := ⊥,
  bot_le := λ p x, by simp {contextual := tt} }

protected lemma eq_bot_iff (p : submodule R M) : p = ⊥ ↔ ∀ x ∈ p, x = (0 : M) :=
⟨ λ h, h.symm ▸ λ x hx, (mem_bot R).mp hx,
  λ h, eq_bot_iff.mpr (λ x hx, (mem_bot R).mpr (h x hx)) ⟩

@[ext] protected lemma bot_ext (x y : (⊥ : submodule R M)) : x = y :=
begin
  rcases x with ⟨x, xm⟩, rcases y with ⟨y, ym⟩, congr,
  rw (submodule.eq_bot_iff _).mp rfl x xm,
  rw (submodule.eq_bot_iff _).mp rfl y ym,
end

protected lemma ne_bot_iff (p : submodule R M) : p ≠ ⊥ ↔ ∃ x ∈ p, x ≠ (0 : M) :=
by { haveI := classical.prop_decidable, simp_rw [ne.def, p.eq_bot_iff, not_forall] }

lemma nonzero_mem_of_bot_lt {p : submodule R M} (bot_lt : ⊥ < p) : ∃ a : p, a ≠ 0 :=
let ⟨b, hb₁, hb₂⟩ := p.ne_bot_iff.mp bot_lt.ne' in ⟨⟨b, hb₁⟩, hb₂ ∘ (congr_arg coe)⟩

lemma exists_mem_ne_zero_of_ne_bot {p : submodule R M} (h : p ≠ ⊥) : ∃ b : M, b ∈ p ∧ b ≠ 0 :=
let ⟨b, hb₁, hb₂⟩ := p.ne_bot_iff.mp h in ⟨b, hb₁, hb₂⟩

/-- The bottom submodule is linearly equivalent to punit as an `R`-module. -/
@[simps] def bot_equiv_punit : (⊥ : submodule R M) ≃ₗ[R] punit :=
{ to_fun := λ x, punit.star,
  inv_fun := λ x, 0,
  map_add' := by { intros, ext, },
  map_smul' := by { intros, ext, },
  left_inv := by { intro x, ext, },
  right_inv := by { intro x, ext, }, }

lemma eq_bot_of_subsingleton (p : submodule R M) [subsingleton p] : p = ⊥ :=
begin
  rw eq_bot_iff,
  intros v hv,
  exact congr_arg coe (subsingleton.elim (⟨v, hv⟩ : p) 0)
end

/-- The universal set is the top element of the lattice of submodules. -/
instance : has_top (submodule R M) :=
⟨{ carrier := set.univ, smul_mem' := λ _ _ _, trivial, .. (⊤ : add_submonoid M)}⟩

@[simp] lemma top_coe : ((⊤ : submodule R M) : set M) = set.univ := rfl

@[simp] lemma top_to_add_submonoid : (⊤ : submodule R M).to_add_submonoid = ⊤ := rfl

@[simp] lemma mem_top {x : M} : x ∈ (⊤ : submodule R M) := trivial

section
variables (R)
@[simp] lemma restrict_scalars_top : restrict_scalars S (⊤ : submodule R M) = ⊤ := rfl
end

@[simp] lemma restrict_scalars_eq_top_iff {p : submodule R M} :
  restrict_scalars S p = ⊤ ↔ p = ⊤ :=
by simp [set_like.ext_iff]

instance : order_top (submodule R M) :=
{ top := ⊤,
  le_top := λ p x _, trivial }

lemma eq_top_iff' {p : submodule R M} : p = ⊤ ↔ ∀ x, x ∈ p :=
eq_top_iff.trans ⟨λ h x, h trivial, λ h x _, h x⟩

/-- The top submodule is linearly equivalent to the module.

This is the module version of `add_submonoid.top_equiv`. -/
@[simps] def top_equiv : (⊤ : submodule R M) ≃ₗ[R] M :=
{ to_fun := λ x, x,
  inv_fun := λ x, ⟨x, by simp⟩,
  map_add' := by { intros, refl, },
  map_smul' := by { intros, refl, },
  left_inv := by { intro x, ext, refl, },
  right_inv := by { intro x, refl, }, }

instance : has_Inf (submodule R M) :=
⟨λ S,
{ carrier   := ⋂ s ∈ S, (s : set M),
  zero_mem' := by simp,
  add_mem'  := by simp [add_mem] {contextual := tt},
  smul_mem' := by simp [smul_mem] {contextual := tt} }⟩

private lemma Inf_le' {S : set (submodule R M)} {p} : p ∈ S → Inf S ≤ p :=
set.bInter_subset_of_mem

private lemma le_Inf' {S : set (submodule R M)} {p} : (∀q ∈ S, p ≤ q) → p ≤ Inf S :=
set.subset_Inter₂

instance : has_inf (submodule R M) :=
⟨λ p q,
{ carrier   := p ∩ q,
  zero_mem' := by simp,
  add_mem'  := by simp [add_mem] {contextual := tt},
  smul_mem' := by simp [smul_mem] {contextual := tt} }⟩

instance : complete_lattice (submodule R M) :=
{ sup          := λ a b, Inf {x | a ≤ x ∧ b ≤ x},
  le_sup_left  := λ a b, le_Inf' $ λ x ⟨ha, hb⟩, ha,
  le_sup_right := λ a b, le_Inf' $ λ x ⟨ha, hb⟩, hb,
  sup_le       := λ a b c h₁ h₂, Inf_le' ⟨h₁, h₂⟩,
  inf          := (⊓),
  le_inf       := λ a b c, set.subset_inter,
  inf_le_left  := λ a b, set.inter_subset_left _ _,
  inf_le_right := λ a b, set.inter_subset_right _ _,
  Sup          := λtt, Inf {t | ∀t'∈tt, t' ≤ t},
  le_Sup       := λ s p hs, le_Inf' $ λ q hq, hq _ hs,
  Sup_le       := λ s p hs, Inf_le' hs,
  Inf          := Inf,
  le_Inf       := λ s a, le_Inf',
  Inf_le       := λ s a, Inf_le',
  ..submodule.order_top,
  ..submodule.order_bot,
  ..set_like.partial_order }

@[simp] theorem inf_coe : ↑(p ⊓ q) = (p ∩ q : set M) := rfl

@[simp] theorem mem_inf {p q : submodule R M} {x : M} :
  x ∈ p ⊓ q ↔ x ∈ p ∧ x ∈ q := iff.rfl

@[simp] theorem Inf_coe (P : set (submodule R M)) : (↑(Inf P) : set M) = ⋂ p ∈ P, ↑p := rfl

@[simp] theorem finset_inf_coe {ι} (s : finset ι) (p : ι → submodule R M) :
  (↑(s.inf p) : set M) = ⋂ i ∈ s, ↑(p i) :=
begin
  letI := classical.dec_eq ι,
  refine s.induction_on _ (λ i s hi ih, _),
  { simp },
  { rw [finset.inf_insert, inf_coe, ih],
    simp },
end

@[simp] theorem infi_coe {ι} (p : ι → submodule R M) :
  (↑⨅ i, p i : set M) = ⋂ i, ↑(p i) :=
by rw [infi, Inf_coe]; ext a; simp; exact
⟨λ h i, h _ i rfl, λ h i x e, e ▸ h _⟩

@[simp] lemma mem_Inf {S : set (submodule R M)} {x : M} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p :=
set.mem_Inter₂

@[simp] theorem mem_infi {ι} (p : ι → submodule R M) {x} :
  x ∈ (⨅ i, p i) ↔ ∀ i, x ∈ p i :=
by rw [← set_like.mem_coe, infi_coe, set.mem_Inter]; refl

@[simp] theorem mem_finset_inf {ι} {s : finset ι} {p : ι → submodule R M} {x : M} :
  x ∈ s.inf p ↔ ∀ i ∈ s, x ∈ p i :=
by simp only [← set_like.mem_coe, finset_inf_coe, set.mem_Inter]

lemma mem_sup_left {S T : submodule R M} : ∀ {x : M}, x ∈ S → x ∈ S ⊔ T :=
show S ≤ S ⊔ T, from le_sup_left

lemma mem_sup_right {S T : submodule R M} : ∀ {x : M}, x ∈ T → x ∈ S ⊔ T :=
show T ≤ S ⊔ T, from le_sup_right

lemma add_mem_sup {S T : submodule R M} {s t : M} (hs : s ∈ S) (ht : t ∈ T) : s + t ∈ S ⊔ T :=
add_mem _ (mem_sup_left hs) (mem_sup_right ht)

lemma mem_supr_of_mem {ι : Sort*} {b : M} {p : ι → submodule R M} (i : ι) (h : b ∈ p i) :
  b ∈ (⨆i, p i) :=
have p i ≤ (⨆i, p i) := le_supr p i,
@this b h

open_locale big_operators

lemma sum_mem_supr {ι : Type*} [fintype ι] {f : ι → M} {p : ι → submodule R M}
  (h : ∀ i, f i ∈ p i) :
  ∑ i, f i ∈ ⨆ i, p i :=
sum_mem _ $ λ i hi, mem_supr_of_mem i (h i)

lemma sum_mem_bsupr {ι : Type*} {s : finset ι} {f : ι → M} {p : ι → submodule R M}
  (h : ∀ i ∈ s, f i ∈ p i) :
  ∑ i in s, f i ∈ ⨆ i ∈ s, p i :=
sum_mem _ $ λ i hi, mem_supr_of_mem i $ mem_supr_of_mem hi (h i hi)

/-! Note that `submodule.mem_supr` is provided in `linear_algebra/basic.lean`. -/

lemma mem_Sup_of_mem {S : set (submodule R M)} {s : submodule R M}
  (hs : s ∈ S) : ∀ {x : M}, x ∈ s → x ∈ Sup S :=
show s ≤ Sup S, from le_Sup hs

theorem disjoint_def {p p' : submodule R M} :
  disjoint p p' ↔ ∀ x ∈ p, x ∈ p' → x = (0:M) :=
show (∀ x, x ∈ p ∧ x ∈ p' → x ∈ ({0} : set M)) ↔ _, by simp

theorem disjoint_def' {p p' : submodule R M} :
  disjoint p p' ↔ ∀ (x ∈ p) (y ∈ p'), x = y → x = (0:M) :=
disjoint_def.trans ⟨λ h x hx y hy hxy, h x hx $ hxy.symm ▸ hy,
  λ h x hx hx', h _ hx x hx' rfl⟩

lemma eq_zero_of_coe_mem_of_disjoint (hpq : disjoint p q) {a : p} (ha : (a : M) ∈ q) :
  a = 0 :=
by exact_mod_cast disjoint_def.mp hpq a (coe_mem a) ha

end submodule

section nat_submodule

/-- An additive submonoid is equivalent to a ℕ-submodule. -/
def add_submonoid.to_nat_submodule : add_submonoid M ≃o submodule ℕ M :=
{ to_fun := λ S,
  { smul_mem' := λ r s hs, S.nsmul_mem hs _, ..S },
  inv_fun := submodule.to_add_submonoid,
  left_inv := λ ⟨S, _, _⟩, rfl,
  right_inv := λ ⟨S, _, _, _⟩, rfl,
  map_rel_iff' := λ a b, iff.rfl }

@[simp]
lemma add_submonoid.to_nat_submodule_symm :
  ⇑(add_submonoid.to_nat_submodule.symm : _ ≃o add_submonoid M) = submodule.to_add_submonoid := rfl

@[simp]
lemma add_submonoid.coe_to_nat_submodule (S : add_submonoid M) :
  (S.to_nat_submodule : set M) = S := rfl

@[simp]
lemma add_submonoid.to_nat_submodule_to_add_submonoid (S : add_submonoid M) :
  S.to_nat_submodule.to_add_submonoid = S :=
add_submonoid.to_nat_submodule.symm_apply_apply S

@[simp]
lemma submodule.to_add_submonoid_to_nat_submodule (S : submodule ℕ M) :
  S.to_add_submonoid.to_nat_submodule = S :=
add_submonoid.to_nat_submodule.apply_symm_apply S

end nat_submodule

end add_comm_monoid

section int_submodule

variables [add_comm_group M]

/-- An additive subgroup is equivalent to a ℤ-submodule. -/
def add_subgroup.to_int_submodule : add_subgroup M ≃o submodule ℤ M :=
{ to_fun := λ S,
  { smul_mem' := λ r s hs, S.zsmul_mem hs _, ..S},
  inv_fun := submodule.to_add_subgroup,
  left_inv := λ ⟨S, _, _, _⟩, rfl,
  right_inv := λ ⟨S, _, _, _⟩, rfl,
  map_rel_iff' := λ a b, iff.rfl }

@[simp]
lemma add_subgroup.to_int_submodule_symm :
  ⇑(add_subgroup.to_int_submodule.symm : _ ≃o add_subgroup M) = submodule.to_add_subgroup := rfl

@[simp]
lemma add_subgroup.coe_to_int_submodule (S : add_subgroup M) :
  (S.to_int_submodule : set M) = S := rfl

@[simp]
lemma add_subgroup.to_int_submodule_to_add_subgroup (S : add_subgroup M) :
  S.to_int_submodule.to_add_subgroup = S :=
add_subgroup.to_int_submodule.symm_apply_apply S

@[simp]
lemma submodule.to_add_subgroup_to_int_submodule (S : submodule ℤ M) :
  S.to_add_subgroup.to_int_submodule = S :=
add_subgroup.to_int_submodule.apply_symm_apply S

end int_submodule


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import linear_algebra.affine_space.affine_map
import topology.continuous_function.basic
import topology.algebra.module.basic

/-!
# Continuous affine maps.

This file defines a type of bundled continuous affine maps.

Note that the definition and basic properties established here require minimal assumptions, and do
not even assume compatibility between the topological and algebraic structures. Of course it is
necessary to assume some compatibility in order to obtain a useful theory. Such a theory is
developed elsewhere for affine spaces modelled on _normed_ vector spaces, but not yet for general
topological affine spaces (since we have not defined these yet).

## Main definitions:

 * `continuous_affine_map`

## Notation:

We introduce the notation `P →A[R] Q` for `continuous_affine_map R P Q`. Note that this is parallel
to the notation `E →L[R] F` for `continuous_linear_map R E F`.
-/

/-- A continuous map of affine spaces. -/
structure continuous_affine_map (R : Type*) {V W : Type*} (P Q : Type*) [ring R]
  [add_comm_group V] [module R V] [topological_space P] [add_torsor V P]
  [add_comm_group W] [module R W] [topological_space Q] [add_torsor W Q]
  extends P →ᵃ[R] Q :=
(cont : continuous to_fun)

notation P ` →A[`:25 R `] ` Q := continuous_affine_map R P Q

namespace continuous_affine_map

variables {R V W P Q : Type*} [ring R]
variables [add_comm_group V] [module R V] [topological_space P] [add_torsor V P]
variables [add_comm_group W] [module R W] [topological_space Q] [add_torsor W Q]

include V W

instance : has_coe (P →A[R] Q) (P →ᵃ[R] Q) :=
⟨to_affine_map⟩

lemma to_affine_map_injective {f g : P →A[R] Q} (h : (f : P →ᵃ[R] Q) = (g : P →ᵃ[R] Q)) : f = g :=
by { cases f, cases g, congr' }

instance : continuous_map_class (P →A[R] Q) P Q :=
{ coe := λ f, f.to_affine_map,
  coe_injective' := λ f g h, to_affine_map_injective $ fun_like.coe_injective h,
  map_continuous := cont }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
instance : has_coe_to_fun (P →A[R] Q) (λ _, P → Q) := fun_like.has_coe_to_fun

lemma to_fun_eq_coe (f : P →A[R] Q) : f.to_fun = ⇑f := rfl

lemma coe_injective : @function.injective (P →A[R] Q) (P → Q) coe_fn :=
fun_like.coe_injective

@[ext] lemma ext {f g : P →A[R] Q} (h : ∀ x, f x = g x) : f = g :=
fun_like.ext _ _ h

lemma ext_iff {f g : P →A[R] Q} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

lemma congr_fun {f g : P →A[R] Q} (h : f = g) (x : P) : f x = g x :=
fun_like.congr_fun h _

/-- Forgetting its algebraic properties, a continuous affine map is a continuous map. -/
def to_continuous_map (f : P →A[R] Q) : C(P, Q) :=
⟨f, f.cont⟩

instance : has_coe (P →A[R] Q) (C(P, Q)) :=
⟨to_continuous_map⟩

@[simp] lemma to_affine_map_eq_coe (f : P →A[R] Q) :
  f.to_affine_map = ↑f :=
rfl

@[simp] lemma to_continuous_map_coe (f : P →A[R] Q) : f.to_continuous_map = ↑f :=
rfl

@[simp, norm_cast]

@[simp, norm_cast] lemma coe_to_continuous_map (f : P →A[R] Q) :
  ((f : C(P, Q)) : P → Q) = f :=
rfl

lemma to_continuous_map_injective {f g : P →A[R] Q}
  (h : (f : C(P, Q)) = (g : C(P, Q))) : f = g :=
by { ext a, exact continuous_map.congr_fun h a, }

@[norm_cast] lemma coe_affine_map_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : P →ᵃ[R] Q) = f :=
rfl

@[norm_cast] lemma coe_continuous_map_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : C(P, Q)) = ⟨f, h⟩ :=
rfl

@[simp] lemma coe_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : P → Q) = f :=
rfl

@[simp] lemma mk_coe (f : P →A[R] Q) (h) :
  (⟨(f : P →ᵃ[R] Q), h⟩ : P →A[R] Q) = f :=
by { ext, refl, }

@[continuity]
protected lemma continuous (f : P →A[R] Q) : continuous f := f.2

variables (R P)

/-- The constant map is a continuous affine map. -/
def const (q : Q) : P →A[R] Q :=
{ to_fun := affine_map.const R P q,
  cont   := continuous_const,
  .. affine_map.const R P q, }

@[simp] lemma coe_const (q : Q) : (const R P q : P → Q) = function.const P q := rfl

noncomputable instance : inhabited (P →A[R] Q) :=
⟨const R P $ nonempty.some (by apply_instance : nonempty Q)⟩

variables {R P} {W₂ Q₂ : Type*}
variables [add_comm_group W₂] [module R W₂] [topological_space Q₂] [add_torsor W₂ Q₂]

include W₂

/-- The composition of morphisms is a morphism. -/
def comp (f : Q →A[R] Q₂) (g : P →A[R] Q) : P →A[R] Q₂ :=
{ cont := f.cont.comp g.cont,
  .. (f : Q →ᵃ[R] Q₂).comp (g : P →ᵃ[R] Q), }

@[simp, norm_cast] lemma coe_comp (f : Q →A[R] Q₂) (g : P →A[R] Q) :
  (f.comp g : P → Q₂) = (f : Q → Q₂) ∘ (g : P → Q) :=
rfl

lemma comp_apply (f : Q →A[R] Q₂) (g : P →A[R] Q) (x : P) :
  f.comp g x = f (g x) :=
rfl

omit W₂

section module_valued_maps

variables {S : Type*}
variables [topological_space W]

instance : has_zero (P →A[R] W) := ⟨continuous_affine_map.const R P 0⟩

@[norm_cast, simp] lemma coe_zero : ((0 : P →A[R] W) : P → W) = 0 := rfl

lemma zero_apply (x : P) : (0 : P →A[R] W) x = 0 := rfl

section mul_action
variables [monoid S] [distrib_mul_action S W] [smul_comm_class R S W]
variables [has_continuous_const_smul S W]

instance : has_smul S (P →A[R] W) :=
{ smul := λ t f, { cont := f.continuous.const_smul t, .. (t • (f : P →ᵃ[R] W)) } }

@[norm_cast, simp] lemma coe_smul (t : S) (f : P →A[R] W) : ⇑(t • f) = t • f := rfl

lemma smul_apply (t : S) (f : P →A[R] W) (x : P) : (t • f) x = t • (f x) := rfl

instance [distrib_mul_action Sᵐᵒᵖ W] [is_central_scalar S W] : is_central_scalar S (P →A[R] W) :=
{ op_smul_eq_smul := λ t f, ext $ λ _, op_smul_eq_smul _ _ }

instance : mul_action S (P →A[R] W) :=
function.injective.mul_action _ coe_injective coe_smul

end mul_action

variables [topological_add_group W]

instance : has_add (P →A[R] W) :=
{ add := λ f g, { cont := f.continuous.add g.continuous, .. ((f : P →ᵃ[R] W) + (g : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_add (f g : P →A[R] W) : ⇑(f + g) = f + g := rfl

lemma add_apply (f g : P →A[R] W) (x : P) : (f + g) x = f x + g x := rfl

instance : has_sub (P →A[R] W) :=
{ sub := λ f g, { cont := f.continuous.sub g.continuous, .. ((f : P →ᵃ[R] W) - (g : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_sub (f g : P →A[R] W) : ⇑(f - g) = f - g := rfl

lemma sub_apply (f g : P →A[R] W) (x : P) : (f - g) x = f x - g x := rfl

instance : has_neg (P →A[R] W) :=
{ neg := λ f, { cont := f.continuous.neg, .. (-(f : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_neg (f : P →A[R] W) : ⇑(-f) = -f := rfl

lemma neg_apply (f : P →A[R] W) (x : P) : (-f) x = -(f x) := rfl

instance : add_comm_group (P →A[R] W) :=
coe_injective.add_comm_group _ coe_zero coe_add coe_neg coe_sub
  (λ _ _, coe_smul _ _) (λ _ _, coe_smul _ _)

instance [monoid S] [distrib_mul_action S W] [smul_comm_class R S W]
  [has_continuous_const_smul S W] :
  distrib_mul_action S (P →A[R] W) :=
function.injective.distrib_mul_action ⟨λ f, f.to_affine_map.to_fun, rfl, coe_add⟩
  coe_injective coe_smul

instance [semiring S] [module S W] [smul_comm_class R S W] [has_continuous_const_smul S W] :
  module S (P →A[R] W) :=
function.injective.module S ⟨λ f, f.to_affine_map.to_fun, rfl, coe_add⟩ coe_injective coe_smul

end module_valued_maps

end continuous_affine_map

namespace continuous_linear_map

variables {R V W : Type*} [ring R]
variables [add_comm_group V] [module R V] [topological_space V]
variables [add_comm_group W] [module R W] [topological_space W]

/-- A continuous linear map can be regarded as a continuous affine map. -/
def to_continuous_affine_map (f : V →L[R] W) : V →A[R] W :=
{ to_fun    := f,
  linear    := f,
  map_vadd' := by simp,
  cont      := f.cont, }

@[simp] lemma coe_to_continuous_affine_map (f : V →L[R] W) :
  ⇑f.to_continuous_affine_map = f :=
rfl

@[simp] lemma to_continuous_affine_map_map_zero (f : V →L[R] W) :
  f.to_continuous_affine_map 0 = 0 :=
by simp

end continuous_linear_map


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import topology.bornology.basic

/-!
# Bornology structure on products and subtypes

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

In this file we define `bornology` and `bounded_space` instances on `α × β`, `Π i, π i`, and
`{x // p x}`. We also prove basic lemmas about `bornology.cobounded` and `bornology.is_bounded`
on these types.
-/

open set filter bornology function
open_locale filter

variables {α β ι : Type*} {π : ι → Type*} [fintype ι] [bornology α] [bornology β]
  [Π i, bornology (π i)]

instance : bornology (α × β) :=
{ cobounded := (cobounded α).coprod (cobounded β),
  le_cofinite := @coprod_cofinite α β ▸ coprod_mono ‹bornology α›.le_cofinite
    ‹bornology β›.le_cofinite }

instance : bornology (Π i, π i) :=
{ cobounded := filter.Coprod (λ i, cobounded (π i)),
  le_cofinite := @Coprod_cofinite ι π _ ▸ (filter.Coprod_mono $ λ i, bornology.le_cofinite _) }

/-- Inverse image of a bornology. -/
@[reducible] def bornology.induced {α β : Type*} [bornology β] (f : α → β) : bornology α :=
{ cobounded := comap f (cobounded β),
  le_cofinite := (comap_mono (bornology.le_cofinite β)).trans (comap_cofinite_le _) }

instance {p : α → Prop} : bornology (subtype p) := bornology.induced (coe : subtype p → α)

namespace bornology

/-!
### Bounded sets in `α × β`
-/

lemma cobounded_prod : cobounded (α × β) = (cobounded α).coprod (cobounded β) := rfl

lemma is_bounded_image_fst_and_snd {s : set (α × β)} :
  is_bounded (prod.fst '' s) ∧ is_bounded (prod.snd '' s) ↔ is_bounded s :=
compl_mem_coprod.symm

variables {s : set α} {t : set β} {S : Π i, set (π i)}

lemma is_bounded.fst_of_prod (h : is_bounded (s ×ˢ t)) (ht : t.nonempty) :
  is_bounded s :=
fst_image_prod s ht ▸ (is_bounded_image_fst_and_snd.2 h).1

lemma is_bounded.snd_of_prod (h : is_bounded (s ×ˢ t)) (hs : s.nonempty) :
  is_bounded t :=
snd_image_prod hs t ▸ (is_bounded_image_fst_and_snd.2 h).2

lemma is_bounded.prod (hs : is_bounded s) (ht : is_bounded t) : is_bounded (s ×ˢ t) :=
is_bounded_image_fst_and_snd.1
  ⟨hs.subset $ fst_image_prod_subset _ _, ht.subset $ snd_image_prod_subset _ _⟩

lemma is_bounded_prod_of_nonempty (hne : set.nonempty (s ×ˢ t)) :
  is_bounded (s ×ˢ t) ↔ is_bounded s ∧ is_bounded t :=
⟨λ h, ⟨h.fst_of_prod hne.snd, h.snd_of_prod hne.fst⟩, λ h, h.1.prod h.2⟩

lemma is_bounded_prod : is_bounded (s ×ˢ t) ↔ s = ∅ ∨ t = ∅ ∨ is_bounded s ∧ is_bounded t :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hs, { simp },
  rcases t.eq_empty_or_nonempty with rfl|ht, { simp },
  simp only [hs.ne_empty, ht.ne_empty, is_bounded_prod_of_nonempty (hs.prod ht), false_or]
end

lemma is_bounded_prod_self : is_bounded (s ×ˢ s) ↔ is_bounded s :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hs, { simp },
  exact (is_bounded_prod_of_nonempty (hs.prod hs)).trans (and_self _)
end

/-!
### Bounded sets in `Π i, π i`
-/

lemma cobounded_pi : cobounded (Π i, π i) = filter.Coprod (λ i, cobounded (π i)) := rfl

lemma forall_is_bounded_image_eval_iff {s : set (Π i, π i)} :
  (∀ i, is_bounded (eval i '' s)) ↔ is_bounded s :=
compl_mem_Coprod.symm

lemma is_bounded.pi (h : ∀ i, is_bounded (S i)) : is_bounded (pi univ S) :=
forall_is_bounded_image_eval_iff.1 $ λ i, (h i).subset eval_image_univ_pi_subset

lemma is_bounded_pi_of_nonempty (hne : (pi univ S).nonempty) :
  is_bounded (pi univ S) ↔ ∀ i, is_bounded (S i) :=
⟨λ H i, @eval_image_univ_pi _ _ _ i hne ▸ forall_is_bounded_image_eval_iff.2 H i, is_bounded.pi⟩

lemma is_bounded_pi : is_bounded (pi univ S) ↔ (∃ i, S i = ∅) ∨ ∀ i, is_bounded (S i) :=
begin
  by_cases hne : ∃ i, S i = ∅,
  { simp [hne, univ_pi_eq_empty_iff.2 hne] },
  { simp only [hne, false_or],
    simp only [not_exists, ← ne.def, ←nonempty_iff_ne_empty, ← univ_pi_nonempty_iff] at hne,
    exact is_bounded_pi_of_nonempty hne }
end

/-!
### Bounded sets in `{x // p x}`
-/

lemma is_bounded_induced {α β : Type*} [bornology β] {f : α → β} {s : set α} :
  @is_bounded α (bornology.induced f) s ↔ is_bounded (f '' s) :=
compl_mem_comap

lemma is_bounded_image_subtype_coe {p : α → Prop} {s : set {x // p x}} :
  is_bounded (coe '' s : set α) ↔ is_bounded s :=
is_bounded_induced.symm

end bornology

/-!
### Bounded spaces
-/

open bornology

instance [bounded_space α] [bounded_space β] : bounded_space (α × β) :=
by simp [← cobounded_eq_bot_iff, cobounded_prod]

instance [∀ i, bounded_space (π i)] : bounded_space (Π i, π i) :=
by simp [← cobounded_eq_bot_iff, cobounded_pi]

lemma bounded_space_induced_iff {α β : Type*} [bornology β] {f : α → β} :
  @bounded_space α (bornology.induced f) ↔ is_bounded (range f) :=
by rw [← is_bounded_univ, is_bounded_induced, image_univ]

lemma bounded_space_subtype_iff {p : α → Prop} : bounded_space (subtype p) ↔ is_bounded {x | p x} :=
by rw [bounded_space_induced_iff, subtype.range_coe_subtype]

lemma bounded_space_coe_set_iff {s : set α} : bounded_space s ↔ is_bounded s :=
bounded_space_subtype_iff

alias bounded_space_subtype_iff ↔ _ bornology.is_bounded.bounded_space_subtype
alias bounded_space_coe_set_iff ↔ _ bornology.is_bounded.bounded_space_coe

instance [bounded_space α] {p : α → Prop} : bounded_space (subtype p) :=
(is_bounded.all {x | p x}).bounded_space_subtype

/-!
### `additive`, `multiplicative`

The bornology on those type synonyms is inherited without change.
-/

instance : bornology (additive α) := ‹bornology α›
instance : bornology (multiplicative α) := ‹bornology α›
instance [bounded_space α] : bounded_space (additive α) := ‹bounded_space α›
instance [bounded_space α] : bounded_space (multiplicative α) := ‹bounded_space α›

/-!
### Order dual

The bornology on this type synonym is inherited without change.
-/

instance : bornology αᵒᵈ := ‹bornology α›
instance [bounded_space α] : bounded_space αᵒᵈ := ‹bounded_space α›


import measure_theory.measure.measure_space
  measure_theory.constructions.borel_space
  measure_theory.measure.finite_measure_weak_convergence

open_locale topological_space

section msupport

variables {α : Type}
  [metric_space α] [proper_space α]
  [measurable_space α] [borel_space α]

def msupport
(μ : measure_theory.finite_measure α) : set α :=
{ x : α | ∀ U : set α, x ∈ U → is_open U → μ U > 0 }

/- lemma closed_msupport (μ : measure_theory.finite_measure α) :
is_closed (msupport μ) := sorry -/

-- needs second-countability
lemma integral_eq_of_eq_on_msupport {f g : α → ℝ}
{μ : measure_theory.finite_measure α}
(hf : measure_theory.integrable f μ.val)
(hg : measure_theory.integrable g μ.val)
(h : ∀ G ∈ msupport μ, f G = g G) :
∫ G, f G ∂μ.val = ∫ G, g G ∂μ.val := sorry

lemma msupport_subset_of_tendsto
(μ : ℕ → measure_theory.finite_measure α)
(lμ : measure_theory.finite_measure α)
(h : filter.tendsto μ filter.at_top (𝓝 lμ)) :
msupport lμ ⊆ closure (⋃ (n : ℕ), msupport (μ n)) :=
sorry

instance finite_measure_val {α : Type} [measurable_space α] {μ : measure_theory.finite_measure α} :
measure_theory.is_finite_measure μ.val := μ.property

noncomputable def finite_measure_map {α β : Type}
[measurable_space α] [measurable_space β]
(f : α → β)
(μ : measure_theory.finite_measure α) : measure_theory.finite_measure β :=
begin
  refine ⟨measure_theory.measure.map f μ.val, _⟩,
  exact measure_theory.measure.is_finite_measure_map μ f,
end

/- def measure_theory.finite_measure.discrete (μ : measure_theory.finite_measure α) :=
∃ S : set α, S.countable ∧ μ(Sᶜ) = 0

lemma discrete_measure_ext
{μ ν : measure_theory.finite_measure α}
(hμ : μ.discrete) (hν : ν.discrete)
{U : set α} (hU : measurable_set U) :
μ U = ν U ↔ ∀ x : α, x ∈ U → μ {x} = ν {x} := sorry -/

end msupport


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Devon Tuma
-/
import topology.instances.ennreal
import measure_theory.measure.measure_space

/-!
# Probability mass functions

This file is about probability mass functions or discrete probability measures:
a function `α → ℝ≥0` such that the values have (infinite) sum `1`.

This file features the monadic structure of `pmf`,
other constructions of `pmf`s are found in `probability_mass_function/constructions.lean`

Given `p : pmf α`, `pmf.to_outer_measure` constructs an `outer_measure` on `α`,
by assigning each set the sum of the probabilities of each of its elements.
Under this outer measure, every set is Carathéodory-measurable,
so we can further extend this to a `measure` on `α`, see `pmf.to_measure`.
`pmf.to_measure.is_probability_measure` shows this associated measure is a probability measure.

## Tags

probability mass function, discrete probability measure
-/
noncomputable theory
variables {α : Type*} {β : Type*} {γ : Type*}
open_locale classical big_operators nnreal ennreal

/-- A probability mass function, or discrete probability measures is a function `α → ℝ≥0` such that
  the values have (infinite) sum `1`. -/
def {u} pmf (α : Type u) : Type u := { f : α → ℝ≥0 // has_sum f 1 }

namespace pmf

instance : has_coe_to_fun (pmf α) (λ p, α → ℝ≥0) := ⟨λ p a, p.1 a⟩

@[ext] protected lemma ext : ∀ {p q : pmf α}, (∀ a, p a = q a) → p = q
| ⟨f, hf⟩ ⟨g, hg⟩ eq :=  subtype.eq $ funext eq

lemma has_sum_coe_one (p : pmf α) : has_sum p 1 := p.2

lemma summable_coe (p : pmf α) : summable p := (p.has_sum_coe_one).summable

@[simp] lemma tsum_coe (p : pmf α) : ∑' a, p a = 1 := p.has_sum_coe_one.tsum_eq

/-- The support of a `pmf` is the set where it is nonzero. -/
def support (p : pmf α) : set α := function.support p

@[simp] lemma mem_support_iff (p : pmf α) (a : α) :
  a ∈ p.support ↔ p a ≠ 0 := iff.rfl

lemma apply_eq_zero_iff (p : pmf α) (a : α) :
  p a = 0 ↔ a ∉ p.support :=
by rw [mem_support_iff, not_not]

lemma coe_le_one (p : pmf α) (a : α) : p a ≤ 1 :=
has_sum_le (by { intro b, split_ifs; simp only [h, zero_le'] })
  (has_sum_ite_eq a (p a)) (has_sum_coe_one p)

section pure

/-- The pure `pmf` is the `pmf` where all the mass lies in one point.
  The value of `pure a` is `1` at `a` and `0` elsewhere. -/
def pure (a : α) : pmf α := ⟨λ a', if a' = a then 1 else 0, has_sum_ite_eq _ _⟩

@[simp] lemma pure_apply (a a' : α) : pure a a' = (if a' = a then 1 else 0) := rfl

lemma mem_support_pure_iff (a a' : α) : a' ∈ (pure a).support ↔ a' = a :=
by simp

instance [inhabited α] : inhabited (pmf α) := ⟨pure (default α)⟩

end pure

section bind

protected lemma bind.summable (p : pmf α) (f : α → pmf β) (b : β) :
  summable (λ a : α, p a * f a b) :=
begin
  refine nnreal.summable_of_le (assume a, _) p.summable_coe,
  suffices : p a * f a b ≤ p a * 1, { simpa },
  exact mul_le_mul_of_nonneg_left ((f a).coe_le_one _) (p a).2
end

/-- The monadic bind operation for `pmf`. -/
def bind (p : pmf α) (f : α → pmf β) : pmf β :=
⟨λ b, ∑'a, p a * f a b,
  begin
    apply ennreal.has_sum_coe.1,
    simp only [ennreal.coe_tsum (bind.summable p f _)],
    rw [ennreal.summable.has_sum_iff, ennreal.tsum_comm],
    simp [ennreal.tsum_mul_left, (ennreal.coe_tsum (f _).summable_coe).symm,
      (ennreal.coe_tsum p.summable_coe).symm]
  end⟩

@[simp] lemma bind_apply (p : pmf α) (f : α → pmf β) (b : β) : p.bind f b = ∑'a, p a * f a b :=
rfl

lemma coe_bind_apply (p : pmf α) (f : α → pmf β) (b : β) :
  (p.bind f b : ℝ≥0∞) = ∑'a, p a * f a b :=
eq.trans (ennreal.coe_tsum $ bind.summable p f b) $ by simp

@[simp] lemma pure_bind (a : α) (f : α → pmf β) : (pure a).bind f = f a :=
have ∀ b a', ite (a' = a) 1 0 * f a' b = ite (a' = a) (f a b) 0, from
  assume b a', by split_ifs; simp; subst h; simp,
by ext b; simp [this]

@[simp] lemma bind_pure (p : pmf α) : p.bind pure = p :=
have ∀ a a', (p a * ite (a' = a) 1 0) = ite (a = a') (p a') 0, from
  assume a a', begin split_ifs; try { subst a }; try { subst a' }; simp * at * end,
by ext b; simp [this]

@[simp] lemma bind_bind (p : pmf α) (f : α → pmf β) (g : β → pmf γ) :
  (p.bind f).bind g = p.bind (λ a, (f a).bind g) :=
begin
  ext1 b,
  simp only [ennreal.coe_eq_coe.symm, coe_bind_apply, ennreal.tsum_mul_left.symm,
             ennreal.tsum_mul_right.symm],
  rw [ennreal.tsum_comm],
  simp [mul_assoc, mul_left_comm, mul_comm]
end

lemma bind_comm (p : pmf α) (q : pmf β) (f : α → β → pmf γ) :
  p.bind (λ a, q.bind (f a)) = q.bind (λ b, p.bind (λ a, f a b)) :=
begin
  ext1 b,
  simp only [ennreal.coe_eq_coe.symm, coe_bind_apply, ennreal.tsum_mul_left.symm,
             ennreal.tsum_mul_right.symm],
  rw [ennreal.tsum_comm],
  simp [mul_assoc, mul_left_comm, mul_comm]
end

end bind

instance : monad pmf :=
{ pure := λ A a, pure a,
  bind := λ A B pa pb, pa.bind pb }

section outer_measure

open measure_theory measure_theory.outer_measure

/-- Construct an `outer_measure` from a `pmf`, by assigning measure to each set `s : set α` equal
  to the sum of `p x` for for each `x ∈ α` -/
def to_outer_measure (p : pmf α) : outer_measure α :=
outer_measure.sum (λ (x : α), p x • dirac x)

lemma to_outer_measure_apply (p : pmf α) (s : set α) :
  p.to_outer_measure s = ∑' x, s.indicator (λ x, (p x : ℝ≥0∞)) x :=
tsum_congr (λ x, smul_dirac_apply (p x) x s)

lemma to_outer_measure_apply' (p : pmf α) (s : set α) :
  p.to_outer_measure s = ↑(∑' (x : α), s.indicator p x) :=
by simp only [ennreal.coe_tsum (nnreal.indicator_summable (summable_coe p) s),
  ennreal.coe_indicator, to_outer_measure_apply]

@[simp]
lemma to_outer_measure_apply_finset (p : pmf α) (s : finset α) :
  p.to_outer_measure s = ∑ x in s, (p x : ℝ≥0∞) :=
begin
  refine (to_outer_measure_apply p s).trans ((@tsum_eq_sum _ _ _ _ _ _ s _).trans _),
  { exact λ x hx, set.indicator_of_not_mem hx _ },
  { exact finset.sum_congr rfl (λ x hx, set.indicator_of_mem hx _) }
end

@[simp]
lemma to_outer_measure_apply_fintype [fintype α] (p : pmf α) (s : set α) :
  p.to_outer_measure s = ∑ x, (s.indicator (λ x, (p x : ℝ≥0∞)) x) :=
(p.to_outer_measure_apply s).trans (tsum_eq_sum (λ x h, absurd (finset.mem_univ x) h))

lemma to_outer_measure_apply_eq_zero_iff (p : pmf α) (s : set α) :
  p.to_outer_measure s = 0 ↔ disjoint p.support s :=
begin
  rw [to_outer_measure_apply', ennreal.coe_eq_zero,
    tsum_eq_zero_iff (nnreal.indicator_summable (summable_coe p) s)],
  exact function.funext_iff.symm.trans set.indicator_eq_zero',
end

@[simp]
lemma to_outer_measure_caratheodory (p : pmf α) :
  (to_outer_measure p).caratheodory = ⊤ :=
begin
  refine (eq_top_iff.2 $ le_trans (le_Inf $ λ x hx, _) (le_sum_caratheodory _)),
  obtain ⟨y, hy⟩ := hx,
  exact ((le_of_eq (dirac_caratheodory y).symm).trans
    (le_smul_caratheodory _ _)).trans (le_of_eq hy),
end

end outer_measure

section measure

open measure_theory

/-- Since every set is Carathéodory-measurable under `pmf.to_outer_measure`,
  we can further extend this `outer_measure` to a `measure` on `α` -/
def to_measure [measurable_space α] (p : pmf α) : measure α :=
p.to_outer_measure.to_measure ((to_outer_measure_caratheodory p).symm ▸ le_top)

variables [measurable_space α]

lemma to_measure_apply_eq_to_outer_measure_apply (p : pmf α) (s : set α) (hs : measurable_set s) :
  p.to_measure s = p.to_outer_measure s :=
to_measure_apply p.to_outer_measure _ hs

lemma to_outer_measure_apply_le_to_measure_apply (p : pmf α) (s : set α) :
  p.to_outer_measure s ≤ p.to_measure s :=
le_to_measure_apply p.to_outer_measure _ s

lemma to_measure_apply (p : pmf α) (s : set α) (hs : measurable_set s) :
  p.to_measure s = ∑' x, s.indicator (λ x, (p x : ℝ≥0∞)) x :=
(p.to_measure_apply_eq_to_outer_measure_apply s hs).trans (p.to_outer_measure_apply s)

lemma to_measure_apply' (p : pmf α) (s : set α) (hs : measurable_set s) :
  p.to_measure s = ↑(∑' x, s.indicator p x) :=
(p.to_measure_apply_eq_to_outer_measure_apply s hs).trans (p.to_outer_measure_apply' s)

@[simp]
lemma to_measure_apply_finset [measurable_singleton_class α] (p : pmf α) (s : finset α) :
  p.to_measure s = ∑ x in s, (p x : ℝ≥0∞) :=
(p.to_measure_apply_eq_to_outer_measure_apply s s.measurable_set).trans
  (p.to_outer_measure_apply_finset s)

lemma to_measure_apply_of_finite [measurable_singleton_class α] (p : pmf α) (s : set α)
  (hs : s.finite) : p.to_measure s = ∑' x, s.indicator (λ x, (p x : ℝ≥0∞)) x :=
(p.to_measure_apply_eq_to_outer_measure_apply s hs.measurable_set).trans
  (p.to_outer_measure_apply s)

@[simp]
lemma to_measure_apply_fintype [measurable_singleton_class α] [fintype α] (p : pmf α) (s : set α) :
  p.to_measure s = ∑ x, s.indicator (λ x, (p x : ℝ≥0∞)) x :=
(p.to_measure_apply_eq_to_outer_measure_apply s (set.finite.of_fintype s).measurable_set).trans
  (p.to_outer_measure_apply_fintype s)

/-- The measure associated to a `pmf` by `to_measure` is a probability measure -/
instance to_measure.is_probability_measure (p : pmf α) : is_probability_measure (p.to_measure) :=
⟨by simpa only [measurable_set.univ, to_measure_apply_eq_to_outer_measure_apply, set.indicator_univ,
  to_outer_measure_apply', ennreal.coe_eq_one] using tsum_coe p⟩

end measure

end pmf


structure Graph(V: Type) (E: Type) where
  null : E
  init : E → V
  bar : E → E
  barInv : bar ∘ bar = id
  barNoFP : ∀ e: E, bar e ≠ e

variable {V: Type}{E: Type}[DecidableEq V][DecidableEq E]

@[inline] def term (graph: Graph V E): E → V :=
  fun e => graph.init (graph.bar e)

inductive EdgePath (graph: Graph V E): V → V → Type where
  | single : (x: V) → EdgePath graph v v
  | cons : {x y z : V} → (e : E) → graph.init e = x → term graph e = y →
        EdgePath graph y z → EdgePath graph x z

def EdgePath.length {graph: Graph V E}{x y: V}: EdgePath graph x y → Nat
  | EdgePath.single x => 0
  | EdgePath.cons  _ _ _ path => length path + 1

open EdgePath

-- concatenates two edgepaths
def multiply {G : Graph V E} {x y z : V}: (EdgePath G x y) → (EdgePath G y z) → (EdgePath G x z) := by
intro p q
match p with
| single x => exact q
| cons ex h1 h2 exy => exact (cons ex h1 h2 (multiply exy q))

--proves that the endpoint of the reverse of an edge is the start point of the edge
theorem lemma1 {G : Graph V E} {x : V}{e : E}: G.init e = x → (term G (G.bar e) = x) :=
by
intro h
have h1 : G.bar (G.bar e) = e := congr G.barInv (Eq.refl e)
have h2 : G.init (G.bar (G.bar e)) = G.init e := congrArg G.init h1
apply Eq.trans h2 h

-- proves associativity of path multiplication
theorem mult_assoc {G : Graph V E} (p : EdgePath G w x) (q : EdgePath G x y) (r : EdgePath G y z):
      (multiply (multiply p q) r) = (multiply p (multiply q r)) := by
      induction p with
      | single w => simp[multiply]
      | cons ex h1 h2 exy ih => simp[multiply, ih]

theorem mult_const {G : Graph V E} {p : EdgePath G x y} :
      (multiply p (single y)) = p := by
      induction p with
      | single x => simp [multiply] ; sorry
      | cons ex h1 h2 exy ih => simp[multiply, ih]

-- reverses an edgepath
def inverse {G : Graph V E} {x y : V}: (EdgePath G x y) → (EdgePath G y x)
| single x => single x
| cons ex h1 h2 exy => multiply (inverse exy) (cons (G.bar (ex)) h2 (lemma1 h1) (single x))

open Nat

-- reduces given path such that no two consecutive edges are inverses of each other
def reducePath {G : Graph V E} {x y : V} : (p : EdgePath G x y )→
  {rp : EdgePath G x y // rp.length ≤ p.length}
| single x => ⟨single x, by apply Nat.le_refl⟩
| cons ex h1 h2 (single y) => ⟨cons ex h1 h2 (single y), by apply Nat.le_refl⟩
| cons ex h1 h2 (cons ey h3 h4 (eyz)) =>
    have h5: length eyz < length (cons ex h1 h2 (cons ey h3 h4 eyz)) := by
      simp[EdgePath.length , Nat.lt_trans (Nat.lt_succ_self (length eyz) ) (Nat.lt_succ_self (length eyz +1))]
    let ⟨eyz', ih⟩ := reducePath eyz
    if c : (x = term G ey) ∧ (ey = G.bar (ex)) then
      ⟨Eq.symm (Eq.trans (And.left c) h4) ▸ eyz', by
      have h6 : length (Eq.symm (Eq.trans (And.left c) h4) ▸ eyz') = length (eyz') := by sorry--simp[EdgePath.length]
      rw[h6]
      exact Nat.le_trans ih (Nat.le_of_lt h5)
      ⟩
    else
      have : length (cons ey h3 h4 eyz') < length (cons ex h1 h2 (cons ey h3 h4 eyz)) := by
       simp[EdgePath.length, Nat.lt_succ_of_le (Nat.succ_le_succ ih)]
      let ⟨prev, ih'⟩ := reducePath (cons ey h3 h4 (eyz'))
      if d : prev.length < (cons ey h3 h4 (eyz')).length then
      have h8 :
        length (cons ex h1 h2 prev) <
          length (cons ex h1 h2 (cons ey h3 h4 eyz)) := by
           simp[EdgePath.length]
           have h9 : (cons ey h3 h4 (eyz')).length ≤ length eyz + 1 := by
            simp[EdgePath.length, Nat.succ_le_succ ih]
           exact Nat.succ_lt_succ (Nat.lt_of_lt_of_le d h9 )
      let ⟨rp, pf⟩ := reducePath (cons ex h1 h2 (prev))
      ⟨rp, Nat.le_of_lt (Nat.lt_of_le_of_lt pf h8)⟩
      else
      ⟨cons ex h1 h2 (cons ey h3 h4 (eyz)), by apply Nat.le_refl⟩
termination_by _ _ _ _ p => p.length

--defines homotopy of edgepaths
inductive homotopy {G : Graph V E} : EdgePath G x y → EdgePath G x y → Sort where
| consht : (x : V) → (homotopy (single x) (single x)) -- constant homotopy
| cancel : (ex : E) → {w x y : V} → (p : EdgePath G x y) → -- cancelling consecutive opposite edges from a path
           (h : G.init ex = x) → { h1 : term G ex = w} →
           homotopy p (cons ex h h1 (cons (G.bar (ex)) h1 (lemma1 h) p))
| mult : {x y z : V} → {p q : EdgePath G y z} →   -- adding an edge to homotopic paths
         homotopy p q → (ex : E) →(h1 : G.init ex = x) → ( h : term G ex = y)→
         homotopy (cons ex h1 h p) (cons ex h1 h q)

--proves that homotopy is left multiplicative
theorem homotopy_left_mult {G : Graph V E} {x y z : V} (p1 p2 : EdgePath G y z) (q : EdgePath G x y) (h :homotopy p1 p2):
         (homotopy (multiply q p1) (multiply q p2)) := by
         induction q with
        | single w  =>
          simp [multiply, h]
        | cons ex h1 h2 exy ih =>
         simp[homotopy.mult (ih p1 p2 h) ex h1 h2, multiply]

/-theorem homotopy_reverse {G : Graph V E} {x y : V} (p1 p2 : EdgePath G x y) : homotopy p1 p2 → homotopy (inverse p1) (inverse p2) := by
        intro h
        induction p1 with
        | single x =>
              induction h with
              | consht z => simp[inverse]
              | cancel ex p h h1 =>
              | mult h' h1 h2 =>
        |  cons ex h1 h2 exy =>-/

/-theorem homotopy_right_mult {V : Type} {E : Type} {G : Graph V E} {x y z : V} (p1 p2 : EdgePath G x y) (q : EdgePath G y z) (h :homotopy p1 p2):
        (homotopy (multiply p1 q) (multiply p2 q)) := by
         induction q with
        | single _ => have h1 : multiply p1 (single _) = p1 := by sorry --apply mult_const p1
        | cons ex h1 h2 exy ih =>
         simp[homotopy.mult (ih p1 p2 h) ex h1 h2, multiply]-/

/-theorem homotopy_reducepath {G : Graph V E} {x y : V} (p1 p2 : EdgePath G x y) (ih : p2.length ≤ p1.length)
        (h : reducePath p1 = p2) : homotopy p1 p2 := by
        let c := p1.length
        induction c with
        | zero => have: p2.length = 0 := by
          match p1 with
          | single x => -/