import tactic
import analysis.complex.basic
import analysis.calculus.deriv
import measure_theory.measure.haar_lebesgue
import measure_theory.integral.interval_integral
import data.set.intervals.unordered_interval
import measure_theory.integral.circle_integral
import tomathlib

open num

noncomputable theory

variables {E : Type}
[normed_add_comm_group E] [normed_space ℂ E] [complete_space E]

/-! Part O. Convert types

- # Type Convertion
-/

@[simp] lemma smul_type_convert (a:ℝ)(b:E):
  (a:ℂ)• b = a • b :=
begin
  simp,
end

lemma smul_integral_convert {α:ℂ}{a:ℝ}{b:ℝ}{g:ℝ→ E}:
  α • ∫ (t: ℝ) in a..b, g t = ∫ (t: ℝ) in a..b, α • g t :=
begin
  simp,
end

lemma smul_assoc_convert {α:ℂ}{a:ℂ}{b:E}:
  (α * a) • b = α • a • b :=
begin
  have p1: (α * a) • b = (α • a) • b := by simp,
  have p2: (α • a) • b = α • (a • b) := by apply smul_assoc,
  rw p1,
  rw p2,
end

/-! Part O'. About 2⁻¹

- # A Half
-/

@[simp] lemma zero_leq_frac_1_2: 0≤ (2⁻¹ : ℝ) := by simp

@[simp] lemma frac_1_2 : (2⁻¹ : ℝ) ≤ 1 :=
  begin
    have h0 : (1 : ℕ) ≤ (2 : ℕ) := by simp,
    have h1 : (1 : ℝ) ≤ (2 : ℝ) :=
    calc
    (1 : ℝ) = (1 : ℕ) : by simp
    ... ≤ (2 : ℕ) : nat.cast_le.elim_right h0
    ... = (2 : ℝ) : by simp,
    have h2 : 0 ≤ (2⁻¹ : ℝ) := by simp,
    have h3 : (1 : ℝ)*(2⁻¹ : ℝ) ≤ (2 : ℝ)*(2⁻¹ : ℝ) := mul_le_mul_of_nonneg_right h1 h2,
    have h4 : (2⁻¹ : ℝ) ≤ 1 :=
    calc
    (2⁻¹ : ℝ) = (1 : ℝ)*(2⁻¹ : ℝ) : by ring_nf
    ... ≤ (2 : ℝ)*(2⁻¹ : ℝ) : h3
    ... = (1 : ℝ) : by ring,
    exact h4,
  end

@[simp] lemma frac_1_2' : (min 2⁻¹ 1 : ℝ) = (2⁻¹ : ℝ) :=
  min_eq_left frac_1_2

@[simp] lemma frac_1_2'': (max 2⁻¹ 1 : ℝ) = (1 : ℝ) :=
  max_eq_right frac_1_2

@[simp] lemma Iiohalf:{a : ℝ | a < 2⁻¹}=set.Iio 2⁻¹ :=
  by rw set.Iio

@[simp] lemma Icchalfone: set.interval (2⁻¹:ℝ) 1 = set.Icc (2⁻¹:ℝ) 1 :=
  by {rw set.interval, rw frac_1_2', rw frac_1_2'',}

lemma frac_1_2_inclusion_left :
  (set.interval 0 (2⁻¹:ℝ))⊆ (set.interval 0 (1:ℝ)) :=
  by {simp, repeat {rw set.Icc,},simp,
      intros x p q, split, exact p,
      exact le_trans q frac_1_2,}

lemma frac_1_2_inclusion_right :
  (set.interval (2⁻¹:ℝ) 1)⊆ (set.interval 0 (1:ℝ)) :=
  by {simp, repeat {rw set.Icc,}, simp,
      intros a p q, split,
      exact le_trans zero_leq_frac_1_2 p, exact q,}

/-! Part O''. Aaffine function

- # Affine Function
-/

/- The affine function is a ℝ → ℝ function with the form of t ↦ b + k * t for some k, b ∈ ℝ. -/
def affine_function(k:ℝ)(b:ℝ):ℝ → ℝ := λ t:ℝ , b+k*t

def constant_real_function(k:ℝ):ℝ→ ℝ :=λ t:ℝ , k

lemma affine_function_def(k:ℝ)(b:ℝ):
affine_function k b=λ t:ℝ , b+k*t := by unfold affine_function

lemma inverse_of_affine{k:ℝ}(hk: k≠ 0)(b:ℝ)(x:ℝ):
(affine_function k b) ((affine_function k⁻¹ (-b/k)) x) = x :=
begin
  repeat {rw affine_function,},
  simp,
  rw mul_add,
  rw ← mul_assoc,
  have kkinv: k * k⁻¹=1 :=mul_inv_cancel hk,
  rw kkinv,
  have kbk: k*(-b/k)=-b :=
    by {ring_nf,rw mul_comm, rw ← mul_assoc, rw kkinv, ring_nf,},
  rw kbk,
  ring_nf,
end

lemma inverse_of_affine'{k:ℝ}(hk: k≠ 0)(b:ℝ)(x:ℝ):
(affine_function k⁻¹ (-b/k)) ((affine_function k b) x) = x  :=
begin
  repeat {rw affine_function,},
  simp,
  rw mul_add,
  rw ← mul_assoc,
  have kkinv: k⁻¹ * k =1 :=inv_mul_cancel hk,
  rw kkinv,
  simp, rw ← add_assoc,
  ring_nf,
end

/- The following lemmas prove that the affine function is continuously differentiable. -/
/- In other words, it lies in the C1 space. -/
lemma affine_is_differentiable(k:ℝ)(b:ℝ):
∀ x:ℝ, differentiable_at ℝ (affine_function k b) x :=
begin
  intro,
  unfold affine_function,
  simp,
end

lemma affine_is_differentiable'(k:ℝ)(b:ℝ):
differentiable ℝ (affine_function k b):=
begin
  rw differentiable,
  exact affine_is_differentiable k b,
end

lemma affine_is_continuous(k:ℝ)(b:ℝ):
continuous (affine_function k b):=
  by {exact differentiable.continuous (affine_is_differentiable' k b),}

lemma affine_is_continuous_on(k:ℝ)(b:ℝ)(lef:ℝ)(ref:ℝ):
continuous_on (affine_function k b) (set.interval lef ref) :=
  (affine_is_continuous k b).continuous_on

lemma deriv_of_affine(k:ℝ)(b:ℝ):
deriv (affine_function k b) = constant_real_function k :=
begin
  unfold affine_function,
  unfold constant_real_function,
  ext1,
  simp,
end

lemma affine_has_deriv_on_interval(k:ℝ)(b:ℝ)(lep:ℝ)(rep:ℝ):
∀ x:ℝ , (x ∈ (set.interval lep rep)) →
(has_deriv_at (affine_function k b)
((constant_real_function k) x) x) :=
begin
  intro,
  intro q,
  rw ← deriv_of_affine k b,
  apply differentiable_at.has_deriv_at
    ((affine_is_differentiable k b) x),
end

lemma affine_in_C1_on_interval(k:ℝ)(lep:ℝ)(rep:ℝ):
continuous_on (constant_real_function k)
(set.interval lep rep) :=
begin
  unfold constant_real_function,
  exact continuous_on_const,
end

/- The derivative of a path composed by an affine function -/
lemma deriv_of_path_affine_comp_pre
(k:ℝ)(b:ℝ)(L:ℝ → ℂ):
deriv (L ∘ (affine_function k b))
= (deriv (affine_function k b))
• (deriv L ∘ (affine_function k b)):=
begin
  have hk: k = 0 ∨ k ≠ 0 := em (k = 0),
  cases hk, rw hk, ext1,
  rw affine_function, simp,
  ext1,
  have q:differentiable_at ℝ (affine_function k b) x
    :=affine_is_differentiable k b x,
  have dcond:
  differentiable_at ℝ L ((affine_function k b) x)
  ∨ ¬ differentiable_at ℝ L ((affine_function k b) x) :=
    em (differentiable_at ℝ L ((affine_function k b) x) ),
  cases dcond,
  exact deriv.scomp x dcond q,
  simp,
  have dlhx: deriv L ((affine_function k b) x) = 0 :=
    deriv_zero_of_not_differentiable_at dcond,
  rw dlhx,
  simp,
  apply deriv_zero_of_not_differentiable_at,
  intro drlhx,
  have Lhh: L= (L∘ (affine_function k b)) ∘
    (affine_function k⁻¹ (-b/k)) :=
    by {ext1,simp,rw inverse_of_affine hk b _,},
  rw Lhh at dcond,
  apply dcond, apply differentiable_at.comp,
  rw inverse_of_affine' hk b _,
  exact drlhx,
  exact affine_is_differentiable' _ _ _,
end

lemma deriv_of_path_affine_comp
(k:ℝ)(b:ℝ)(L:ℝ → ℂ):
deriv (L ∘ (affine_function k b))
= k • (deriv L ∘ (affine_function k b)):=
begin
  have p:=deriv_of_path_affine_comp_pre k b L,
  rw deriv_of_affine k b at p,
  exact p,
end

/-! Part I. Path: definition and basic properties

- # Path
A path is any function L defined as ℝ → ℂ
-/

def constant_path (z:ℂ):ℝ → ℂ :=λ (t:ℝ ), z

/-- The path concatenation of two path means compressing their domain [0,1] to [0, 1/2] (and [1/2, 1]) then concate them back to [0,1].-/
def path_concatenation {L1:ℝ → ℂ}{L2:ℝ →ℂ}
(hw: L1 1=L2 0):ℝ → ℂ :=
λ (t:ℝ), if t<2⁻¹ then L1 (2*t) else L2 (-1+2*t)

/-- The inverse of a path is to reverse the direction of a path. -/
def path_inverse(L:ℝ → ℂ):ℝ → ℂ := λ (t:ℝ ), L(1-t)

lemma path_concatenation_endpoint {L1:ℝ → ℂ}{L2:ℝ→ℂ}
(hw: L1 1=L2 0): path_concatenation hw 1=L2 1:=
begin
  rw path_concatenation,
  have m:¬ (1<(2⁻¹ : ℝ)):=by simp,
  ring_nf,
  simp,
  intro f,
  exfalso,
  finish,
end

lemma path_concatenation_left{L1:ℝ → ℂ}{L2:ℝ→ℂ}
(hw: L1 1=L2 0){t:ℝ}(ht: t<=2⁻¹):
path_concatenation hw t = L1 (2*t):=
begin
  rw path_concatenation,
  by_cases t<2⁻¹,
  simp,
  intro p,
  exfalso,
  have hn:¬ t<2⁻¹:=by {simp,exact p},
  exact hn h,
  simp at *,
  have hh: t=2⁻¹:=by {exact ge_antisymm h ht},
  rw hh,
  simp,
  rwa hw,
end

lemma path_concatenation_right{L1:ℝ → ℂ}{L2:ℝ→ℂ}
(hw: L1 1=L2 0){t:ℝ}(ht: t>=2⁻¹):
path_concatenation hw t = L2 (-1+2*t):=
begin
  rw path_concatenation,
  simp,
  intro p,
  exfalso,
  have pn:¬ t<2⁻¹:=by {simp at *,exact ht},
  exact pn p,
end

lemma path_concatenation_left'{L1:ℝ → ℂ}{L2:ℝ→ℂ}
(hw: L1 1=L2 0):set.eq_on ((λ t:ℝ, L1 (2*t)):ℝ → ℂ)
((λ t:ℝ, path_concatenation hw t):ℝ → ℂ)
(set.interval (0:ℝ) 2⁻¹):=
begin
  rw set.eq_on,
  intro x,
  intro in_condition,
  simp at in_condition, symmetry,
  exact path_concatenation_left hw in_condition.2,
end

lemma path_concatenation_right'{L1:ℝ → ℂ}{L2:ℝ→ℂ}
(hw: L1 1=L2 0):set.eq_on ((λ t:ℝ, L2 (-1+2*t)):ℝ → ℂ)
((λ t:ℝ, path_concatenation hw t):ℝ → ℂ)
(set.interval 2⁻¹ (1:ℝ)):=
begin
  rw set.eq_on,
  intro x,
  intro in_condition, symmetry,
  apply path_concatenation_right,
  rw[ge],
  rw set.interval at in_condition,
  have h0 : (min 2⁻¹ 1 : ℝ) ≤ x := and.elim_left ((iff.elim_left set.mem_Icc) in_condition),
  have h4 : 2⁻¹ ≤ x :=
    calc 2⁻¹ = (min 2⁻¹ 1 : ℝ) : by simp
    ... ≤ x : h0,
  exact h4,
end

lemma path_concatenation_image{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0):
set.image (path_concatenation hw) (set.interval 0 1)
=(set.image L1 (set.interval 0 1))∪
(set.image L2 (set.interval 0 1)) :=
begin
  ext1, split,
  have md: (0:ℝ)<(2:ℝ):= by simp,
  have mn: (0:ℝ)≤(2:ℝ):= le_of_lt md,
  intro x_in,
  rw path_concatenation at *,
  simp, simp at x_in,
  cases x_in with x',
  by_cases x'<(2⁻¹:ℝ),
  rw if_pos h at x_in_h,
  left, use 2*x',
  split, split,
  simp, exact x_in_h.1.1,
  apply le_of_lt,
  have t:=mul_lt_mul_of_pos_left h md,
  simp at t, exact t, exact x_in_h.2,
  rw if_neg h at x_in_h,
  right, use (-1+2*x'),
  simp at h, split, split,
  simp, have t:=mul_le_mul_of_nonneg_left h mn,
  simp at t, exact t,
  simp, ring_nf, simp, exact x_in_h.1.2,
  exact x_in_h.2,
  intro x_in,
  rw path_concatenation at *,
  simp, simp at x_in,
  cases x_in, cases x_in with x',
  use (2⁻¹:ℝ)*x',
  simp, split, split,
  exact x_in_h.1.1,
  have t:=mul_le_mul_of_nonneg_left x_in_h.1.2 zero_leq_frac_1_2,
  apply le_trans t, simp,
  by_cases x'<1,
  rw if_pos h, exact x_in_h.2,
  rw if_neg h, simp at h,
  have t:x'=1 :=
    by {apply ge_antisymm, exact h, exact x_in_h.1.2,},
  rw t, rw t at x_in_h, simp,
  rw ← hw, exact x_in_h.2,
  cases x_in with x',
  use (2⁻¹:ℝ)*(1+x'),
  simp, split, split,
  apply le_trans x_in_h.1.1,
  simp,
  have t:=add_le_add_left x_in_h.1.2 1,
  have tt:=mul_le_mul_of_nonneg_left t zero_leq_frac_1_2,
  apply le_trans tt, ring_nf,
  have xneg:¬ x'<0:= by {simp, exact x_in_h.1.1,},
  rw if_neg xneg, exact x_in_h.2,
end

lemma path_concatenation_image_left_subset
{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0):
set.image L1 (set.interval 0 1) ⊆
set.image (path_concatenation hw) (set.interval 0 1):=
by { rw path_concatenation_image hw,
     exact (L1 '' set.interval 0 1).subset_union_left
       (L2 '' set.interval 0 1), }

lemma path_concatenation_image_right_subset
{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0):
set.image L2 (set.interval 0 1) ⊆
set.image (path_concatenation hw) (set.interval 0 1):=
by { rw path_concatenation_image hw,
     exact (L1 '' set.interval 0 1).subset_union_right
       (L2 '' set.interval 0 1), }

lemma continuity_of_constant_path (z:ℂ): continuous (constant_path z):=
begin
  rw constant_path,
  exact continuous_const,
end

lemma general_piece_continuous_on(L:ℝ→ ℂ)
{k:ℝ}(hk:0 ≤ k)(b:ℝ)(lef:ℝ)(ref:ℝ)
(hlc:continuous_on L (set.interval (b+k*lef) (b+k*ref))):
continuous_on (λt:ℝ, L(b+k*t)) (set.interval lef ref) :=
begin
  have p:(λt:ℝ, L(b+k*t))=L∘(affine_function k b) :=
    by {ext1, rw affine_function, },
  rw p,
  apply continuous_on.comp,
  exact hlc,
  exact affine_is_continuous_on k b _ _,
  rw set.maps_to,
  intros x hx,
  rw set.interval at *, rw affine_function,
  simp at *, split,
  cases hx.1 with hx1,
  left, exact mul_le_mul_of_nonneg_left hx1 hk,
  right, exact mul_le_mul_of_nonneg_left h hk,
  cases hx.2 with hx2,
  left, exact mul_le_mul_of_nonneg_left hx2 hk,
  right, exact mul_le_mul_of_nonneg_left h hk,
end

lemma path_concatenation_continuous_on{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0)
(hl1c:continuous_on L1 (set.interval 0 1))
(hl2c:continuous_on L2 (set.interval 0 1)):
continuous_on (path_concatenation hw) (set.interval 0 1):=
begin
  have twogeqzero:(2:ℝ)≥ (0:ℝ):=by simp,
  apply continuous_on.if,
  {
    intros a ha,
    rw Iiohalf at ha,
    rw frontier_Iio at ha,
    simp at ha,
    rw ha.2, simp, exact hw,
  },
  {
    rw Iiohalf, rw closure_Iio,
    simp,
    have fr:=frac_1_2,
    have mp: (set.Icc (0:ℝ) 1 ∩ set.Iic (2⁻¹:ℝ))=set.interval 0 (2⁻¹:ℝ):=
      begin
        repeat {rw set.Icc,}, rw set.Iic, ext1,
        simp, intros p q, exact le_trans p fr,
      end,
    rw mp,
    have gc:=general_piece_continuous_on L1 twogeqzero 0 0 2⁻¹,
    ring_nf at gc, ring_nf,
    apply gc, exact hl1c,
  },
  {
    have Icihalf:{a : ℝ | ¬a < 2⁻¹}=set.Ici 2⁻¹:=
      by {rw set.Ici,ext1,simp,},
    rw Icihalf, rw closure_Ici, simp,
    have mp: (set.Icc 0 1 ∩ set.Ici 2⁻¹)=set.interval (2⁻¹:ℝ) 1:=
      begin
        rw Icchalfone, repeat {rw set.Icc,}, rw set.Ici,
        ext1, simp, split, intro fc, split, exact fc.2,
        exact fc.1.2, intro fc, split, split,
        exact le_trans zero_leq_frac_1_2 fc.1,
        exact fc.2, exact fc.1
      end,
    rw mp,
    have gc:=general_piece_continuous_on L2 twogeqzero (-1) 2⁻¹ 1,
    ring_nf at gc, ring_nf,
    apply gc, exact hl2c,
  },
end

lemma path_concatenation_continuous{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0)
(hl1c:continuous L1)(hl2c:continuous L2):
continuous (path_concatenation hw):=
begin
  apply continuous.if,
  {
    intros a af,
    rw Iiohalf at af, rw frontier_Iio at af,
    simp at af, rw af, simp, exact hw,
  },
  {
    have p:(λt:ℝ, L1(2*t))=L1∘(affine_function 2 0) :=
      by {ext1, rw affine_function, simp,},
    rw p,
    exact continuous.comp hl1c (affine_is_continuous _ _),
  },
  {
    have p:(λt:ℝ, L2(-1+2*t))=L2∘(affine_function 2 (-1)) :=
      by {ext1, rw affine_function, },
    rw p,
    exact continuous.comp hl2c (affine_is_continuous _ _),
  },
end

lemma has_eq_deriv_on_Ioo{f:ℝ→ ℂ}{g:ℝ→ ℂ}{a b x:ℝ}{d:ℂ}
(hab:a≤ b)(hde: set.eq_on f g (set.Ioo a b))
(hx: x ∈ set.Ioo a b)(hfx: has_deriv_at f d x):
has_deriv_at g d x:=
begin
  apply has_deriv_at.congr_of_eventually_eq hfx,
  symmetry,
  unfold filter.eventually_eq,
  apply iff.elim_right eventually_nhds_eq_iff,
  existsi (set.Ioo a b),
  apply and.intro,
  exact hde,
  split,
  exact is_open_Ioo,
  exact hx,
end

lemma deriv_eq_on_Ioo{f:ℝ→ ℂ}{g:ℝ→ ℂ}{a b:ℝ}(hab:a≤ b)
(hde: set.eq_on f g (set.Ioo a b)):
set.eq_on (deriv f) (deriv g) (set.Ioo a b):=
begin
  rw set.eq_on,
  intros x hx,
  apply filter.eventually_eq.deriv_eq,
  unfold filter.eventually_eq,
  apply iff.elim_right eventually_nhds_eq_iff,
  existsi (set.Ioo a b),
  apply and.intro,
  exact hde,
  split,
  exact is_open_Ioo,
  exact hx,
end

lemma deriv_eq_on{f:ℝ→ ℂ}{g:ℝ→ ℂ}{a b:ℝ}(hab:a≤ b)
(hde: set.eq_on f g (set.interval a b)):
set.eq_on (deriv f) (deriv g) (set.Ioo a b):=
deriv_eq_on_Ioo hab
(set.eq_on.mono Ioo_subset_interval hde)

@[protected] lemma deriv_L1_eq_on{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0):
set.eq_on (deriv (λ t:ℝ, L1 (2*t)))
(deriv (path_concatenation hw)) (set.Ioo (0:ℝ) 2⁻¹):=
begin
  apply deriv_eq_on,
  simp,
  exact path_concatenation_left' hw,
end

@[protected] lemma deriv_L2_eq_on{L1:ℝ→ ℂ}{L2:ℝ → ℂ}(hw: L1 1=L2 0):
set.eq_on (deriv (λ t:ℝ, L2 (-1+2*t)))
(deriv (path_concatenation hw)) (set.Ioo 2⁻¹ (1:ℝ)):=
begin
  apply deriv_eq_on,
  simp,
  exact path_concatenation_right' hw,
end

lemma interval_integrable_iff_integrable_Ioo_volume
(f : ℝ → E) {a b : ℝ} (hab : a ≤ b):
  interval_integrable f measure_theory.measure_space.volume a b ↔
  measure_theory.integrable_on f (set.Ioo a b) measure_theory.measure_space.volume :=
begin
  apply interval_integrable_iff_integrable_Ioo_of_le hab,
  exact _inst_2,
  exact _inst_3,
  exact real.has_no_atoms_volume,
end

lemma path_comp_affine_deriv_integrable(L:ℝ→ ℂ)
{k:ℝ}(hk:k≠ 0)(b:ℝ)
(hli:interval_integrable (deriv L) measure_theory.measure_space.volume 0 1):
interval_integrable (deriv (λ t:ℝ, L (b+k*t)))
  measure_theory.measure_space.volume (-b/k) ((1-b)/k) :=
begin
  have m:(λ t:ℝ, L (b+k*t))=L∘ (affine_function k b):=
    by {ext1,rw affine_function,},
  rw m,
  rw deriv_of_path_affine_comp k b L,
  apply interval_integrable.smul,
  let f:=λ(t:ℝ), deriv L (b+t),
  let g:=λ(t:ℝ), deriv L t,
  have rf: (deriv L ∘ affine_function k b) = (λ(t:ℝ), f(k*t)):=
    by {ext1, rw affine_function, },
  have rg: f = (λ(t:ℝ), g(b+t)) :=
    by {ext1, simp,},
  rw rf,
  apply interval_integrable.comp_mul_left,
  rw rg,
  have minusb: -b=0-b:= by ring_nf, rw minusb,
  apply integrable_comp_add_left,
  exact hli,
end

lemma path_concatenation_deriv_integrable{L1:ℝ→ ℂ}{L2:ℝ → ℂ}
(hw: L1 1=L2 0)
(hl1i:interval_integrable (deriv L1) measure_theory.measure_space.volume 0 1)
(hl2i:interval_integrable (deriv L2) measure_theory.measure_space.volume 0 1):
interval_integrable (deriv (path_concatenation hw))
measure_theory.measure_space.volume 0 1 :=
begin
  have ze_leq_one:(0:ℝ)≤ (1:ℝ):= by simp,
  have two_ne_zero: (2:ℝ)≠ (0:ℝ):= by simp,
  have hl1i':=path_comp_affine_deriv_integrable L1 two_ne_zero 0 hl1i,
  have hl2i':=path_comp_affine_deriv_integrable L2 two_ne_zero (-1) hl2i,
  simp at hl1i', simp at hl2i',
  apply interval_integrable.trans,
  {
    rw interval_integrable_iff_integrable_Ioo_volume
      (deriv (path_concatenation hw)) zero_leq_frac_1_2,
    apply measure_theory.integrable_on.congr_fun,
    {
      rw ← interval_integrable_iff_integrable_Ioo_volume _ zero_leq_frac_1_2,
      exact hl1i',
      exact normed_field.to_normed_space,
      exact complete_of_proper,
    },
    {
      exact deriv_L1_eq_on hw,
    },
    {
      exact measurable_set_Ioo,
    },
  },
  {
    rw interval_integrable_iff_integrable_Ioo_volume
      (deriv (path_concatenation hw)) frac_1_2,
    apply measure_theory.integrable_on.congr_fun,
    {
      rw ← interval_integrable_iff_integrable_Ioo_volume _ frac_1_2,
      exact hl2i',
      exact normed_field.to_normed_space,
      exact complete_of_proper,
    },
    {
      exact deriv_L2_eq_on hw,
    },
    {
      exact measurable_set_Ioo,
    },
  },
end

/-! Part II. Integrability along a contour

- # Contour Integrability
-/

def contour_integrable (f : ℂ → E) (L: ℝ → ℂ): Prop :=
interval_integrable (λ (x : ℝ), deriv L x • f (L x))
  measure_theory.measure_space.volume 0 1

lemma contour_integrable_smul_continuous_on{f:ℂ → E}{L:ℝ → ℂ}
(hf: continuous_on f (set.image L (set.interval 0 1)))
(hl: continuous_on L (set.interval 0 1))
(hli: interval_integrable (deriv L) measure_theory.measure_space.volume 0 1):
  contour_integrable f L :=
begin
  apply interval_integrable.smul_continuous_on,
  {
    exact hli,
  },
  {
    simp at *,
    apply continuous_on.comp,
    {
      exact hf,
    },
    {
      exact hl,
    },
    {
      simp,
      rw set.maps_to,
      intros x x_in,
      simp,
      use x, split,
      simp at x_in, exact x_in,
      exact rfl,
    },
  },
end

lemma contour_integrable_zero (L:ℝ → ℂ):
contour_integrable (λt:ℂ, (0:E)) L :=
  by {unfold contour_integrable, simp, }

lemma contour_integrable_neg {f:ℂ → E}{L:ℝ → ℂ}
(h: contour_integrable f L):
contour_integrable (-f) L :=
  by {unfold contour_integrable at *, simp,
  exact interval_integrable.neg h,}

lemma contour_integrable_smul {f:ℂ → E}{L:ℝ → ℂ}
(h: contour_integrable f L)(α:ℂ):
contour_integrable (α • f) L :=
begin
  unfold contour_integrable at *,
  have mid:(λt:ℝ, deriv L t • (α • f) (L t))
      =(λt:ℝ, α • deriv L t • f (L t)):=
    by {ext1, simp, rw smul_comm,},
  rw mid,
  exact interval_integrable.smul h _,
end

/-! Part III. Contour Integral: definition and basic properties

- # Contour Integral
-/

def contour_integral (f : ℂ → E) (L: ℝ → ℂ): E :=
∫ (t: ℝ ) in 0..1, (deriv L t) • f(L t)

@[simp] lemma contour_integral_zero (L:ℝ → ℂ):
contour_integral (λt:ℂ, (0:E)) L = 0 :=
  by {unfold contour_integral, simp, }

lemma contour_integral_neg (f:ℂ → E)(L:ℝ → ℂ):
contour_integral (-f) L = - contour_integral f L :=
  by {unfold contour_integral, simp,}

lemma contour_integral_smul (f:ℂ → E)(L:ℝ → ℂ)(α:ℂ):
contour_integral (α • f) L = α • contour_integral f L :=
begin
  unfold contour_integral,
  have mid:(λt:ℝ, deriv L t • (α • f) (L t))
      =(λt:ℝ, α • deriv L t • f (L t)):=
    by {ext1, simp, rw smul_comm,},
  rw mid,
  rw smul_integral_convert,
end

lemma contour_integral_smul_right(f:ℂ → ℂ)(L:ℝ → ℂ)(c:E):
contour_integral (λz:ℂ, f(z) • c) L =
(contour_integral f L) • c :=
begin
  unfold contour_integral,
  have func_rw: (λ t:ℝ,deriv L t • f (L t) • c) =
  (λ t:ℝ,(deriv L t • f (L t)) • c) :=
    by {ext1, rw smul_assoc,},
  rw func_rw,
  simp,
end

lemma contour_integral_add{f:ℂ → E}{g:ℂ → E}{L:ℝ → ℂ}
(hfL: contour_integrable f L)(hgL: contour_integrable g L):
contour_integral (f + g) L =
contour_integral f L + contour_integral g L :=
begin
  unfold contour_integral, simp,
  apply interval_integral.integral_add,
  exact hfL, exact hgL,
end

lemma contour_integral_add' {f:ℂ → E}{g:ℂ → E}{L:ℝ → ℂ}
(hf: continuous_on f (set.image L (set.interval 0 1)))
(hg: continuous_on g (set.image L (set.interval 0 1)))
(hl: continuous_on L (set.interval 0 1))
(hli: interval_integrable (deriv L) measure_theory.measure_space.volume 0 1):
contour_integral (f + g) L =
contour_integral f L + contour_integral g L :=
begin
  apply contour_integral_add,
  exact contour_integrable_smul_continuous_on hf hl hli,
  exact contour_integrable_smul_continuous_on hg hl hli,
end

lemma contour_integral_sub{f:ℂ → E}{g:ℂ → E}{L:ℝ → ℂ}
(hfL: contour_integrable f L)(hgL: contour_integrable g L):
contour_integral (f - g) L =
contour_integral f L - contour_integral g L :=
begin
  unfold contour_integral, simp,
  have p:(λt:ℝ,deriv L t • (f (L t) - g (L t)))=
  (λt:ℝ, deriv L t • f (L t) - deriv L t • g (L t)) :=
    by {ext1, exact smul_sub _ (f(L x)) (g(L x)),},
  rw p,
  apply interval_integral.integral_sub,
  exact hfL, exact hgL,
end

lemma contour_integral_sub' {f:ℂ → E}{g:ℂ → E}{L:ℝ → ℂ}
(hf: continuous_on f (set.image L (set.interval 0 1)))
(hg: continuous_on g (set.image L (set.interval 0 1)))
(hl: continuous_on L (set.interval 0 1))
(hli: interval_integrable (deriv L) measure_theory.measure_space.volume 0 1):
contour_integral (f - g) L =
contour_integral f L - contour_integral g L :=
begin
  apply contour_integral_sub,
  exact contour_integrable_smul_continuous_on hf hl hli,
  exact contour_integrable_smul_continuous_on hg hl hli,
end

lemma contour_integral_ML_inequality{f:ℂ → E}{L:ℝ → ℂ}
{C D:ℝ}
(hc: ∀ z:ℂ, z ∈ set.image L (set.interval_oc 0 1) →
∥f z∥≤ C)
(hd: ∀ x:ℝ, (x ∈ (set.interval_oc (0:ℝ) 1)) →
complex.abs(deriv L x)≤ D):
∥contour_integral f L∥≤ C*D :=
begin
  unfold contour_integral,
  have cdrw:C*D =(C*D)*|1-0|:= by simp,
  rw cdrw,
  apply interval_integral.norm_integral_le_of_norm_le_const,
  intros x x_in,
  have Lx_in: L x∈ set.image L (set.interval_oc 0 1) :=
    by {unfold set.image, simp, use x, split,
        exact x_in, exact rfl,},
  rw norm_smul, rw mul_comm,
  have fL0: 0≤ ∥ f (L x) ∥ := norm_nonneg (f (L x)),
  have fL1: ∥ f (L x) ∥≤ C := hc (L x) Lx_in,
  have dL0: 0≤ ∥deriv L x∥ := norm_nonneg (deriv L x),
  have dL1: ∥deriv L x∥≤ D:= hd x x_in,
  have md1:=mul_mono_nonneg dL0 fL1,
  have md2:=mul_mono_nonneg (le_trans fL0 fL1) dL1,
  rw mul_comm at md2, rw mul_comm D _ at md2,
  exact le_trans md1 md2,
end

/-! Part IV. Integral is an addictive function of the path

- # Addictivity
-/

lemma contour_integral_congr {f g: ℂ → E}{L:ℝ→ ℂ}
(hfg: set.eq_on f g (set.image L (set.interval 0 1))):
contour_integral f L = contour_integral g L :=
begin
  unfold contour_integral,
  apply interval_integral.integral_congr,
  intros x x_in, simp,
  have Lx_in: L x∈ (set.image L (set.interval 0 1)):=
    set.mem_image_of_mem L x_in,
  have hfg':=hfg Lx_in,
  rwa hfg',
end

@[simp] lemma contour_integral_along_constant_path
(f : ℂ → E) (z:ℂ) :
contour_integral f (constant_path z) = 0 :=
begin
  unfold contour_integral,
  have p:deriv  (constant_path z) =0 :=
    begin
      ext1,
      unfold constant_path,
      simp,
    end,
  rw p,
  simp,
end

@[protected] lemma genearl_term_of_sum' (f : ℂ → E)(L:ℝ → ℂ)
(k:ℝ)(b:ℝ)(lep:ℝ)(rep:ℝ):
∫ (t : ℝ) in b+k*lep..b+k*rep, deriv L t • f (L t)
= ∫ (t : ℝ) in lep..rep,
deriv (L ∘ (affine_function k b)) t • f (L (b+k*t)):=
begin
  rw deriv_of_path_affine_comp,
  rw ← interval_integral.smul_integral_comp_add_mul _ k b,
  rw affine_function,
  simp,
  simp [smul_assoc_convert],
end

@[protected] lemma genearl_term_of_sum (f : ℂ → E)(L:ℝ → ℂ)
(k:ℝ)(b:ℝ)(lep:ℝ)(rep:ℝ):
∫ (t : ℝ) in b+k*lep..b+k*rep, deriv L t • f (L t)
= ∫ (t : ℝ) in lep..rep,
deriv (λ(t:ℝ), L(b+k*t)) t • f (L (b+k*t)) :=
begin
  have p:deriv (λ(t:ℝ), L(b+k*t))
    = deriv (L ∘ (affine_function k b)) :=
    by {ext1,rw affine_function,},
  rw p,
  exact genearl_term_of_sum' _ _ _ _ _ _,
end

@[protected] lemma first_term_of_sum(f : ℂ → E)(L1:ℝ → ℂ):
∫ (t : ℝ) in 0..1, deriv L1 t • f (L1 t)
= ∫ (t : ℝ) in 0..2⁻¹,
deriv (λ(t:ℝ),L1 (2*t)) t • f (L1 (2*t)) :=
begin
  have p:(λ t:ℝ,deriv (λ(x:ℝ),L1 (2*x)) t • f (L1 (2*t)))
  =(λ t:ℝ,deriv (λ(x:ℝ),L1 (0+2*x)) t • f (L1 (0+2*t))) :=
    by simp,
  rw p,
  rw ← genearl_term_of_sum f L1 2 0 0 2⁻¹,
  simp,
end

@[protected] lemma second_term_of_sum(f : ℂ → E)(L2:ℝ → ℂ):
∫ (t : ℝ) in 0..1, deriv L2 t • f (L2 t)
= ∫ (t : ℝ) in 2⁻¹..1,
deriv (λ(t:ℝ),L2 (-1+2*t)) t • f (L2 (-1+2*t)) :=
begin
  rw ← genearl_term_of_sum f L2 2 (-1) 2⁻¹ 1,
  simp,
  have q: (-1)+2 = (1:ℝ) :=by ring,
  rw q,
end

@[protected] lemma first_func_in_term(f : ℂ → E)
{L1:ℝ → ℂ}{L2:ℝ → ℂ} (hw: L1 1=L2 0):
set.eq_on (λ t:ℝ, deriv (λ(x:ℝ),L1 (2*x)) t • f (L1 (2*t)))
(λ t:ℝ, deriv (path_concatenation hw) t • f (path_concatenation hw t))
(set.Ioo (0:ℝ) 2⁻¹) :=
begin
  rw set.eq_on,
  intros x x_in,
  rw deriv_L1_eq_on hw x_in,
  have ip: (set.Ioo (0:ℝ) 2⁻¹)⊆ (set.interval (0:ℝ) 2⁻¹) :=
    by {simp,exact set.Ioo_subset_Icc_self},
  have x_in':x∈ (set.interval (0:ℝ) 2⁻¹) := ip x_in,
  have t:=path_concatenation_left' hw x_in', simp at t, rw t,
end

@[protected] lemma second_func_in_term(f : ℂ → E)
{L1:ℝ → ℂ}{L2:ℝ → ℂ} (hw: L1 1=L2 0):
set.eq_on (λt:ℝ,deriv (λ(x:ℝ),L2 (-1+2*x)) t • f (L2 (-1+2*t)))
(λ t:ℝ, deriv (path_concatenation hw) t • f (path_concatenation hw t))
(set.Ioo (2⁻¹:ℝ) 1) :=
begin
  rw set.eq_on,
  intros x x_in,
  rw deriv_L2_eq_on hw x_in,
  have ip: (set.Ioo (2⁻¹:ℝ) 1)⊆ (set.interval (2⁻¹:ℝ) 1) :=
    by {simp,exact set.Ioo_subset_Icc_self},
  have x_in':x∈ (set.interval (2⁻¹:ℝ) 1) := ip x_in,
  have t:=path_concatenation_right' hw x_in', simp at t, rw t,
end

@[protected] lemma contour_integral_first_piece (f : ℂ → E)
{L1:ℝ → ℂ}{L2:ℝ → ℂ} (hw: L1 1=L2 0):
contour_integral f L1 =
(∫ (t : ℝ) in 0..2⁻¹, deriv (path_concatenation hw) t • f (path_concatenation hw t) ) :=
begin
  unfold contour_integral, rw first_term_of_sum,
  rw integral_congr''' zero_leq_frac_1_2 (first_func_in_term f hw),
  exact real.has_no_atoms_volume,
end

@[protected] lemma contour_integral_second_piece (f : ℂ → E)
{L1:ℝ → ℂ}{L2:ℝ → ℂ} (hw: L1 1=L2 0):
contour_integral f L2 =
(∫ (t : ℝ) in 2⁻¹..1, deriv (path_concatenation hw) t • f (path_concatenation hw t) ) :=
begin
  unfold contour_integral, rw second_term_of_sum,
  rw integral_congr''' frac_1_2 (second_func_in_term f hw),
  exact real.has_no_atoms_volume,
end

/- The integral along the path L1∪L2 is equal to the sum of integrals along L1 and L2. -/
theorem contour_integral_along_piecewise_path{f : ℂ → E}
{L1:ℝ → ℂ}{L2:ℝ → ℂ} {hw: L1 1=L2 0}
(hi: contour_integrable f (path_concatenation hw)):
contour_integral f (path_concatenation hw) =
contour_integral f L1 + contour_integral f L2 :=
begin
  unfold contour_integrable at hi,
  rw [contour_integral_first_piece f hw,
      contour_integral_second_piece f hw,
      contour_integral], symmetry,
  apply interval_integral.integral_add_adjacent_intervals,
  exact interval_integrable.mono_set hi frac_1_2_inclusion_left,
  exact interval_integrable.mono_set hi frac_1_2_inclusion_right,
end

/- A useful version of the previous theorem -/
theorem contour_integral_along_piecewise_path'{f : ℂ → E}
{L1:ℝ → ℂ}{L2:ℝ → ℂ} {hw: L1 1=L2 0}
(hf: continuous_on f (set.image (path_concatenation hw) (set.interval 0 1)))
(hlc: continuous_on (path_concatenation hw) (set.interval 0 1))
(hli: interval_integrable (deriv ((path_concatenation hw)))
       measure_theory.measure_space.volume 0 1):
contour_integral f (path_concatenation hw) =
contour_integral f L1 + contour_integral f L2 :=
contour_integral_along_piecewise_path
(contour_integrable_smul_continuous_on hf hlc hli)

/- Even more useful -/
theorem contour_integral_along_piecewise_path''{f : ℂ → E}
{L1:ℝ → ℂ}{L2:ℝ → ℂ} {hw: L1 1=L2 0}
(hf: continuous_on f ((set.image L1 (set.interval 0 1))∪
     (set.image L2 (set.interval 0 1))))
(hl1c: continuous_on L1 (set.interval 0 1))
(hl2c: continuous_on L2 (set.interval 0 1))
(hl1i: interval_integrable (deriv L1) measure_theory.measure_space.volume 0 1)
(hl2i: interval_integrable (deriv L2) measure_theory.measure_space.volume 0 1):
contour_integral f (path_concatenation hw) =
contour_integral f L1 + contour_integral f L2 :=
begin
  apply contour_integral_along_piecewise_path',
  rw ← path_concatenation_image hw at hf, exact hf,
  exact path_concatenation_continuous_on hw hl1c hl2c,
  exact path_concatenation_deriv_integrable hw hl1i hl2i,
end

/- The integral along the inverse of a path is equal to the negative number of that along the original path. -/
theorem contour_integral_along_inverse_path
(f : ℂ → E) (L:ℝ → ℂ) :
contour_integral f (path_inverse L) = - contour_integral f L :=
begin
  unfold contour_integral,
  unfold path_inverse,
  let h:ℝ → ℝ := λ(t:ℝ ), 1-t,
  let h':ℝ → ℝ :=λ(t:ℝ ), -1,
  have h_def: h = λ(t:ℝ ), 1-t := rfl,
  have h'_def: ∀ x:ℝ , h' x = -1:=congr_fun rfl,
  have h_diff: ∀ x:ℝ, differentiable_at ℝ h x:=
    begin
    intro x,
    simp,
    end,
  have deriv_h_eq_h':  deriv h = h':=
    begin
      ext1,
      rw h'_def x,
      simp,
    end,
  have p: ∀ x:ℝ , (x ∈ (set.interval (0:ℝ) 1)) →
    (has_deriv_at h (h' x) x):=
    begin
      intro x,
      intro q,
      rw ← deriv_h_eq_h',
      apply differentiable_at.has_deriv_at (h_diff x),
    end,
  have q: continuous_on h' (set.interval (0:ℝ) 1):=
    by exact continuous_on_const,
  have Lh:(λ (t:ℝ), L(1-t))=L∘ h:= by simp,
  have L1_minus_t_der': ∀ x:ℝ,
    deriv ((λ (t:ℝ), L(1-t))) x = (- (deriv L) ∘ h) x:=
    begin
      intro x,
      rw Lh,
      have dcond: (differentiable_at ℝ L (h x)) ∨
        ¬ (differentiable_at ℝ L (h x)) := em (differentiable_at ℝ L (h x)),
      cases dcond,
      rw deriv.scomp x (dcond) (h_diff x),
      simp,
      have dlhx: deriv L (h x) = 0 :=deriv_zero_of_not_differentiable_at dcond,
      have dlhx': (-deriv L∘ h)x = 0 :=by {simp,exact dlhx,},
      rw dlhx',
      apply deriv_zero_of_not_differentiable_at,
      intro drlhx,
      have Lhh : L = (L∘ h)∘ h:= by {ext1, rw h_def, simp,},
      have hhx: h (h x) = x:= by {rw h_def,simp,},
      rw Lhh at dcond,
      apply dcond,
      apply differentiable_at.comp,
      rw hhx,
      exact drlhx,
      exact h_diff (h x),
    end,
  have L1_minus_t_der:
    deriv ((λ (t:ℝ), L(1-t))) = - (deriv L) ∘ h :=
    begin
      ext1,
      exact L1_minus_t_der' x,
    end,
  rw L1_minus_t_der,
  simp,
  rw h_def,
  simp,
  let func_lhs: ℝ → E:= λ (x:ℝ), deriv L (1-x) • f(L(1-x)),
  let func_rhs: ℝ → E:=λ (t:ℝ), deriv L t • f (L t),
  have func_lhs_def: func_lhs
    = λ (t:ℝ), deriv L (1-t) • f(L(1-t)) :=rfl,
  have func_rhs_def: func_rhs
    = λ (t:ℝ), deriv L t • f (L t) := rfl,
  have relation_lr: func_lhs = - h' • (func_rhs ∘ h):=
    begin
      rw func_lhs_def,
      ext1,
      simp,
    end,
  have lhs: ∫ (x : ℝ) in 0..1, deriv L (1 - x) • f (L (1 - x))
    = ∫ (t : ℝ) in 0..1, func_lhs t := by rw func_lhs_def,
  have rhs: ∫ (t : ℝ) in 0..1, deriv L t • f (L t)
    = ∫ (t : ℝ) in 0..1, func_rhs t := by rw func_rhs_def,
  rw lhs,
  rw rhs,
  rw relation_lr,
  simp,
end


/-
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
-/
import linear_algebra.basic
import linear_algebra.basis
import linear_algebra.pi

/-!
# The standard basis

This file defines the standard basis `std_basis R φ i b j`, which is `b` where `i = j` and `0`
elsewhere.

To give a concrete example, `std_basis R (λ (i : fin 3), R) i 1` gives the `i`th unit basis vector
in `R³`, and `pi.is_basis_fun` proves this is a basis over `fin 3 → R`.

## Main definitions

 - `linear_map.std_basis R ϕ i b`: the `i`'th standard `R`-basis vector on `Π i, ϕ i`,
   scaled by `b`.

## Main results

 - `pi.is_basis_std_basis`: `std_basis` turns a component-wise basis into a basis on the product
   type.
 - `pi.is_basis_fun`: `std_basis R (λ _, R) i 1` is a basis for `n → R`.

-/

open function submodule
open_locale big_operators
open_locale big_operators

namespace linear_map

variables (R : Type*) {ι : Type*} [semiring R] (φ : ι → Type*)
  [Π i, add_comm_monoid (φ i)] [Π i, module R (φ i)] [decidable_eq ι]

/-- The standard basis of the product of `φ`. -/
def std_basis : Π (i : ι), φ i →ₗ[R] (Πi, φ i) := single

lemma std_basis_apply (i : ι) (b : φ i) : std_basis R φ i b = update 0 i b :=
rfl

lemma coe_std_basis (i : ι) : ⇑(std_basis R φ i) = pi.single i :=
funext $ std_basis_apply R φ i

@[simp] lemma std_basis_same (i : ι) (b : φ i) : std_basis R φ i b i = b :=
by rw [std_basis_apply, update_same]

lemma std_basis_ne (i j : ι) (h : j ≠ i) (b : φ i) : std_basis R φ i b j = 0 :=
by rw [std_basis_apply, update_noteq h]; refl

lemma std_basis_eq_pi_diag (i : ι) : std_basis R φ i = pi (diag i) :=
begin
  ext x j,
  convert (update_apply 0 x i j _).symm,
  refl,
end

lemma ker_std_basis (i : ι) : ker (std_basis R φ i) = ⊥ :=
ker_eq_bot_of_injective $ assume f g hfg,
  have std_basis R φ i f i = std_basis R φ i g i := hfg ▸ rfl,
  by simpa only [std_basis_same]

lemma proj_comp_std_basis (i j : ι) : (proj i).comp (std_basis R φ j) = diag j i :=
by rw [std_basis_eq_pi_diag, proj_pi]

lemma proj_std_basis_same (i : ι) : (proj i).comp (std_basis R φ i) = id :=
by ext b; simp

lemma proj_std_basis_ne (i j : ι) (h : i ≠ j) : (proj i).comp (std_basis R φ j) = 0 :=
by ext b; simp [std_basis_ne R φ _ _ h]

lemma supr_range_std_basis_le_infi_ker_proj (I J : set ι) (h : disjoint I J) :
  (⨆i∈I, range (std_basis R φ i)) ≤ (⨅i∈J, ker (proj i)) :=
begin
  refine (supr_le $ assume i, supr_le $ assume hi, range_le_iff_comap.2 _),
  simp only [(ker_comp _ _).symm, eq_top_iff, set_like.le_def, mem_ker, comap_infi, mem_infi],
  assume b hb j hj,
  have : i ≠ j := assume eq, h ⟨hi, eq.symm ▸ hj⟩,
  rw [proj_std_basis_ne R φ j i this.symm, zero_apply]
end

lemma infi_ker_proj_le_supr_range_std_basis {I : finset ι} {J : set ι} (hu : set.univ ⊆ ↑I ∪ J) :
  (⨅ i∈J, ker (proj i)) ≤ (⨆i∈I, range (std_basis R φ i)) :=
set_like.le_def.2
begin
  assume b hb,
  simp only [mem_infi, mem_ker, proj_apply] at hb,
  rw ← show ∑ i in I, std_basis R φ i (b i) = b,
  { ext i,
    rw [finset.sum_apply, ← std_basis_same R φ i (b i)],
    refine finset.sum_eq_single i (assume j hjI ne, std_basis_ne _ _ _ _ ne.symm _) _,
    assume hiI,
    rw [std_basis_same],
    exact hb _ ((hu trivial).resolve_left hiI) },
  exact sum_mem _ (assume i hiI, mem_supr_of_mem i $ mem_supr_of_mem hiI $
    (std_basis R φ i).mem_range_self (b i))
end

lemma supr_range_std_basis_eq_infi_ker_proj {I J : set ι}
  (hd : disjoint I J) (hu : set.univ ⊆ I ∪ J) (hI : set.finite I) :
  (⨆i∈I, range (std_basis R φ i)) = (⨅i∈J, ker (proj i)) :=
begin
  refine le_antisymm (supr_range_std_basis_le_infi_ker_proj _ _ _ _ hd) _,
  have : set.univ ⊆ ↑hI.to_finset ∪ J, { rwa [hI.coe_to_finset] },
  refine le_trans (infi_ker_proj_le_supr_range_std_basis R φ this) (supr_le_supr $ assume i, _),
  rw [set.finite.mem_to_finset],
  exact le_refl _
end

lemma supr_range_std_basis [fintype ι] : (⨆i:ι, range (std_basis R φ i)) = ⊤ :=
have (set.univ : set ι) ⊆ ↑(finset.univ : finset ι) ∪ ∅ := by rw [finset.coe_univ, set.union_empty],
begin
  apply top_unique,
  convert (infi_ker_proj_le_supr_range_std_basis R φ this),
  exact infi_emptyset.symm,
  exact (funext $ λi, (@supr_pos _ _ _ (λh, range (std_basis R φ i)) $ finset.mem_univ i).symm)
end

lemma disjoint_std_basis_std_basis (I J : set ι) (h : disjoint I J) :
  disjoint (⨆i∈I, range (std_basis R φ i)) (⨆i∈J, range (std_basis R φ i)) :=
begin
  refine disjoint.mono
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right)
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right) _,
  simp only [disjoint, set_like.le_def, mem_infi, mem_inf, mem_ker, mem_bot, proj_apply,
    funext_iff],
  rintros b ⟨hI, hJ⟩ i,
  classical,
  by_cases hiI : i ∈ I,
  { by_cases hiJ : i ∈ J,
    { exact (h ⟨hiI, hiJ⟩).elim },
    { exact hJ i hiJ } },
  { exact hI i hiI }
end

lemma std_basis_eq_single {a : R} :
  (λ (i : ι), (std_basis R (λ _ : ι, R) i) a) = λ (i : ι), (finsupp.single i a) :=
begin
  ext i j,
  rw [std_basis_apply, finsupp.single_apply],
  split_ifs,
  { rw [h, function.update_same] },
  { rw [function.update_noteq (ne.symm h)], refl },
end

end linear_map

namespace pi
open linear_map
open set

variables {R : Type*}

section module
variables {η : Type*} {ιs : η → Type*} {Ms : η → Type*}
variables [ring R] [∀i, add_comm_group (Ms i)] [∀i, module R (Ms i)]

lemma linear_independent_std_basis [decidable_eq η]
  (v : Πj, ιs j → (Ms j)) (hs : ∀i, linear_independent R (v i)) :
  linear_independent R (λ (ji : Σ j, ιs j), std_basis R Ms ji.1 (v ji.1 ji.2)) :=
begin
  have hs' : ∀j : η, linear_independent R (λ i : ιs j, std_basis R Ms j (v j i)),
  { intro j,
    exact (hs j).map' _ (ker_std_basis _ _ _) },
  apply linear_independent_Union_finite hs',
  { assume j J _ hiJ,
    simp [(set.Union.equations._eqn_1 _).symm, submodule.span_image, submodule.span_Union],
    have h₀ : ∀ j, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ range (std_basis R Ms j),
    { intro j,
      rw [span_le, linear_map.range_coe],
      apply range_comp_subset_range },
    have h₁ : span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ ⨆ i ∈ {j}, range (std_basis R Ms i),
    { rw @supr_singleton _ _ _ (λ i, linear_map.range (std_basis R (λ (j : η), Ms j) i)),
      apply h₀ },
    have h₂ : (⨆ j ∈ J, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))) ≤
               ⨆ j ∈ J, range (std_basis R (λ (j : η), Ms j) j) :=
      supr_le_supr (λ i, supr_le_supr (λ H, h₀ i)),
    have h₃ : disjoint (λ (i : η), i ∈ {j}) J,
    { convert set.disjoint_singleton_left.2 hiJ using 0 },
    exact (disjoint_std_basis_std_basis _ _ _ _ h₃).mono h₁ h₂ }
end

variable [fintype η]

lemma is_basis_std_basis [decidable_eq η] (s : Πj, ιs j → (Ms j)) (hs : ∀j, is_basis R (s j)) :
  is_basis R (λ (ji : Σ j, ιs j), std_basis R Ms ji.1 (s ji.1 ji.2)) :=
begin
  split,
  { apply linear_independent_std_basis _ (assume i, (hs i).1) },
  have h₁ : Union (λ j, set.range (std_basis R Ms j ∘ s j))
    ⊆ range (λ (ji : Σ (j : η), ιs j), (std_basis R Ms (ji.fst)) (s (ji.fst) (ji.snd))),
  { apply Union_subset, intro i,
    apply range_comp_subset_range (λ x : ιs i, (⟨i, x⟩ : Σ (j : η), ιs j))
        (λ (ji : Σ (j : η), ιs j), std_basis R Ms (ji.fst) (s (ji.fst) (ji.snd))) },
  have h₂ : ∀ i, span R (range (std_basis R Ms i ∘ s i)) = range (std_basis R Ms i),
  { intro i,
    rw [set.range_comp, submodule.span_image, (assume i, (hs i).2), submodule.map_top] },
  apply eq_top_mono,
  apply span_mono h₁,
  rw span_Union,
  simp only [h₂],
  apply supr_range_std_basis
end

section
variables (R η)

lemma is_basis_fun₀ [decidable_eq η] : is_basis R
    (λ (ji : Σ (j : η), unit),
       (std_basis R (λ (i : η), R) (ji.fst)) 1) :=
@is_basis_std_basis R η (λi:η, unit) (λi:η, R) _ _ _ _ _ (λ _ _, (1 : R))
  (assume i, @is_basis_singleton_one _ _ _ _)

lemma is_basis_fun [decidable_eq η] : is_basis R (λ i, std_basis R (λi:η, R) i 1) :=
begin
  apply (is_basis_fun₀ R η).comp (λ i, ⟨i, punit.star⟩),
  apply bijective_iff_has_inverse.2,
  use sigma.fst,
  simp [function.left_inverse, function.right_inverse]
end

@[simp] lemma is_basis_fun_repr [decidable_eq η] (x : η → R) (i : η) :
  (pi.is_basis_fun R η).repr x i = x i :=
begin
  conv_rhs { rw ← (pi.is_basis_fun R η).total_repr x },
  rw [finsupp.total_apply, finsupp.sum_fintype],
  show (pi.is_basis_fun R η).repr x i =
    (∑ j, λ i, (pi.is_basis_fun R η).repr x j • std_basis R (λ _, R) j 1 i) i,
  rw [finset.sum_apply, finset.sum_eq_single i],
  { simp only [pi.smul_apply, smul_eq_mul, std_basis_same, mul_one] },
  { rintros b - hb, simp only [std_basis_ne _ _ _ _ hb.symm, smul_zero] },
  { intro,
    have := finset.mem_univ i,
    contradiction },
  { intros, apply zero_smul },
end

end

end module

end pi


/-
Copyright (c) 2022 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa, Junyan Xu

! This file was ported from Lean 3 source module data.dfinsupp.ne_locus
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Dfinsupp.Basic

/-!
# Locus of unequal values of finitely supported dependent functions

Let `N : α → Type*` be a type family, assume that `N a` has a `0` for all `a : α` and let
`f g : Π₀ a, N a` be finitely supported dependent functions.

## Main definition

* `Dfinsupp.neLocus f g : finset α`, the finite subset of `α` where `f` and `g` differ.
In the case in which `N a` is an additive group for all `a`, `Dfinsupp.neLocus f g` coincides with
`Dfinsupp.support (f - g)`.
-/

variable {α : Type _} {N : α → Type _}

namespace Dfinsupp

variable [DecidableEq α]

section NHasZero

variable [∀ a, DecidableEq (N a)] [∀ a, Zero (N a)] (f g : Π₀ a, N a)

/-- Given two finitely supported functions `f g : α →₀ N`, `Finsupp.neLocus f g` is the `Finset`
where `f` and `g` differ. This generalizes `(f - g).support` to situations without subtraction. -/
def neLocus (f g : Π₀ a, N a) : Finset α :=
  (f.support ∪ g.support).filter fun x ↦ f x ≠ g x
#align dfinsupp.ne_locus Dfinsupp.neLocus

@[simp]
theorem mem_neLocus {f g : Π₀ a, N a} {a : α} : a ∈ f.neLocus g ↔ f a ≠ g a := by
  simpa only [neLocus, Finset.mem_filter, Finset.mem_union, mem_support_iff,
    and_iff_right_iff_imp] using Ne.ne_or_ne _
#align dfinsupp.mem_ne_locus Dfinsupp.mem_neLocus

theorem not_mem_neLocus {f g : Π₀ a, N a} {a : α} : a ∉ f.neLocus g ↔ f a = g a :=
  mem_neLocus.not.trans not_ne_iff
#align dfinsupp.not_mem_ne_locus Dfinsupp.not_mem_neLocus

@[simp]
theorem coe_neLocus : ↑(f.neLocus g) = { x | f x ≠ g x } :=
  Set.ext fun _x ↦ mem_neLocus
#align dfinsupp.coe_ne_locus Dfinsupp.coe_neLocus

@[simp]
theorem neLocus_eq_empty {f g : Π₀ a, N a} : f.neLocus g = ∅ ↔ f = g :=
  ⟨fun h ↦
    ext fun a ↦ not_not.mp (mem_neLocus.not.mp (Finset.eq_empty_iff_forall_not_mem.mp h a)),
    fun h ↦ h ▸ by simp only [neLocus, Ne.def, eq_self_iff_true, not_true, Finset.filter_False]⟩
#align dfinsupp.ne_locus_eq_empty Dfinsupp.neLocus_eq_empty

@[simp]
theorem nonempty_neLocus_iff {f g : Π₀ a, N a} : (f.neLocus g).Nonempty ↔ f ≠ g :=
  Finset.nonempty_iff_ne_empty.trans neLocus_eq_empty.not
#align dfinsupp.nonempty_ne_locus_iff Dfinsupp.nonempty_neLocus_iff

theorem neLocus_comm : f.neLocus g = g.neLocus f := by
  simp_rw [neLocus, Finset.union_comm, ne_comm]
#align dfinsupp.ne_locus_comm Dfinsupp.neLocus_comm

@[simp]
theorem neLocus_zero_right : f.neLocus 0 = f.support := by
  ext
  rw [mem_neLocus, mem_support_iff, coe_zero, Pi.zero_apply]
#align dfinsupp.ne_locus_zero_right Dfinsupp.neLocus_zero_right

@[simp]
theorem neLocus_zero_left : (0 : Π₀ a, N a).neLocus f = f.support :=
  (neLocus_comm _ _).trans (neLocus_zero_right _)
#align dfinsupp.ne_locus_zero_left Dfinsupp.neLocus_zero_left

end NHasZero

section NeLocusAndMaps

variable {M P : α → Type _} [∀ a, Zero (N a)] [∀ a, Zero (M a)] [∀ a, Zero (P a)]

theorem subset_mapRange_neLocus [∀ a, DecidableEq (N a)] [∀ a, DecidableEq (M a)] (f g : Π₀ a, N a)
    {F : ∀ a, N a → M a} (F0 : ∀ a, F a 0 = 0) :
    (f.mapRange F F0).neLocus (g.mapRange F F0) ⊆ f.neLocus g := fun a ↦ by
  simpa only [mem_neLocus, mapRange_apply, not_imp_not] using congr_arg (F a)
#align dfinsupp.subset_map_range_ne_locus Dfinsupp.subset_mapRange_neLocus

theorem zipWith_neLocus_eq_left [∀ a, DecidableEq (N a)] [∀ a, DecidableEq (P a)]
    {F : ∀ a, M a → N a → P a} (F0 : ∀ a, F a 0 0 = 0) (f : Π₀ a, M a) (g₁ g₂ : Π₀ a, N a)
    (hF : ∀ a f, Function.Injective fun g ↦ F a f g) :
    (zipWith F F0 f g₁).neLocus (zipWith F F0 f g₂) = g₁.neLocus g₂ := by
  ext a
  simpa only [mem_neLocus] using (hF a _).ne_iff
#align dfinsupp.zip_with_ne_locus_eq_left Dfinsupp.zipWith_neLocus_eq_left

theorem zipWith_neLocus_eq_right [∀ a, DecidableEq (M a)] [∀ a, DecidableEq (P a)]
    {F : ∀ a, M a → N a → P a} (F0 : ∀ a, F a 0 0 = 0) (f₁ f₂ : Π₀ a, M a) (g : Π₀ a, N a)
    (hF : ∀ a g, Function.Injective fun f ↦ F a f g) :
    (zipWith F F0 f₁ g).neLocus (zipWith F F0 f₂ g) = f₁.neLocus f₂ := by
  ext a
  simpa only [mem_neLocus] using (hF a _).ne_iff
#align dfinsupp.zip_with_ne_locus_eq_right Dfinsupp.zipWith_neLocus_eq_right

theorem mapRange_neLocus_eq [∀ a, DecidableEq (N a)] [∀ a, DecidableEq (M a)] (f g : Π₀ a, N a)
    {F : ∀ a, N a → M a} (F0 : ∀ a, F a 0 = 0) (hF : ∀ a, Function.Injective (F a)) :
    (f.mapRange F F0).neLocus (g.mapRange F F0) = f.neLocus g := by
  ext a
  simpa only [mem_neLocus] using (hF a).ne_iff
#align dfinsupp.map_range_ne_locus_eq Dfinsupp.mapRange_neLocus_eq

end NeLocusAndMaps

variable [∀ a, DecidableEq (N a)]

@[simp]
theorem neLocus_add_left [∀ a, AddLeftCancelMonoid (N a)] (f g h : Π₀ a, N a) :
    (f + g).neLocus (f + h) = g.neLocus h :=
  zipWith_neLocus_eq_left _ _ _ _ fun _a ↦ add_right_injective
#align dfinsupp.ne_locus_add_left Dfinsupp.neLocus_add_left

@[simp]
theorem neLocus_add_right [∀ a, AddRightCancelMonoid (N a)] (f g h : Π₀ a, N a) :
    (f + h).neLocus (g + h) = f.neLocus g :=
  zipWith_neLocus_eq_right _ _ _ _ fun _a ↦ add_left_injective
#align dfinsupp.ne_locus_add_right Dfinsupp.neLocus_add_right

section AddGroup

variable [∀ a, AddGroup (N a)] (f f₁ f₂ g g₁ g₂ : Π₀ a, N a)

@[simp]
theorem neLocus_neg_neg : neLocus (-f) (-g) = f.neLocus g :=
  mapRange_neLocus_eq _ _ (fun _a ↦ neg_zero) fun _a ↦ neg_injective
#align dfinsupp.ne_locus_neg_neg Dfinsupp.neLocus_neg_neg

theorem neLocus_neg : neLocus (-f) g = f.neLocus (-g) := by rw [← neLocus_neg_neg, neg_neg]
#align dfinsupp.ne_locus_neg Dfinsupp.neLocus_neg

theorem neLocus_eq_support_sub : f.neLocus g = (f - g).support := by
  rw [← @neLocus_add_right α N _ _ _ _ _ (-g), add_right_neg, neLocus_zero_right, sub_eq_add_neg]
#align dfinsupp.ne_locus_eq_support_sub Dfinsupp.neLocus_eq_support_sub

@[simp]
theorem neLocus_sub_left : neLocus (f - g₁) (f - g₂) = neLocus g₁ g₂ := by
  simp only [sub_eq_add_neg, @neLocus_add_left α N _ _ _, neLocus_neg_neg]
#align dfinsupp.ne_locus_sub_left Dfinsupp.neLocus_sub_left

@[simp]
theorem neLocus_sub_right : neLocus (f₁ - g) (f₂ - g) = neLocus f₁ f₂ := by
  simpa only [sub_eq_add_neg] using @neLocus_add_right α N _ _ _ _ _ _
#align dfinsupp.ne_locus_sub_right Dfinsupp.neLocus_sub_right

@[simp]
theorem neLocus_self_add_right : neLocus f (f + g) = g.support := by
  rw [← neLocus_zero_left, ← @neLocus_add_left α N _ _ _ f 0 g, add_zero]
#align dfinsupp.ne_locus_self_add_right Dfinsupp.neLocus_self_add_right

@[simp]
theorem neLocus_self_add_left : neLocus (f + g) f = g.support := by
  rw [neLocus_comm, neLocus_self_add_right]
#align dfinsupp.ne_locus_self_add_left Dfinsupp.neLocus_self_add_left

@[simp]
theorem neLocus_self_sub_right : neLocus f (f - g) = g.support := by
  rw [sub_eq_add_neg, neLocus_self_add_right, support_neg]
#align dfinsupp.ne_locus_self_sub_right Dfinsupp.neLocus_self_sub_right

@[simp]

end AddGroup

end Dfinsupp


namespace prop_11

variables A B : Prop

theorem prop_11 (h : ¬ A) : ¬ (A ∨ B) ∨ (¬ A ∧ B) :=
show ¬(A ∨ B) ∨ ¬A ∧ B,
from or.elim (classical.em ¬ B)
   (assume h1: ¬B,
    have h2: ¬ (A ∨ B), from
      (assume h3: A ∨ B,
       show false, from or.elim h3
         (assume h4: A, h h4)
         (assume h4: B, h1 h4)),
    show ¬(A ∨ B) ∨ ¬A ∧ B, from or.inl h2)
      (assume h5: ¬¬B,
       have h6: B, from classical.by_contradiction h5,
       have h7: ¬A ∧ B, from and.intro h h6,
       show ¬(A ∨ B) ∨ ¬A ∧ B, from or.inr h7)

-- end namespace
end prop_11


import algebra.group.basic data.buffer

universe u

@[derive decidable_eq, derive has_reflect] inductive group_term : Type
| of : ℕ → group_term
| one : group_term
| mul : group_term → group_term → group_term
| inv : group_term → group_term

namespace group_term

instance : has_one group_term := ⟨group_term.one⟩
instance : has_mul group_term := ⟨group_term.mul⟩
instance : has_inv group_term := ⟨group_term.inv⟩
instance : has_repr group_term :=
⟨λ t, group_term.rec_on t (λ n, "X" ++ repr n) "1"
   (λ _ _ s₁ s₂, "(" ++ s₁ ++ " * " ++ s₂ ++ ")")
   (λ _ s, "(" ++ s ++ ")⁻¹")⟩

local attribute [pattern] has_mul.mul has_inv.inv

def eval {G : Type*} [group G] (f : ℕ → G) : group_term → G
| (of i) := f i
| 1 := 1
| (a * b) := eval a * eval b
| (a⁻¹) := (eval a)⁻¹

/-- `rel a b` is inhabited when group terms are equal as elements of a group. -/
inductive rel : group_term → group_term → Type
| assoc : ∀ a b c : group_term, rel (a * b * c) (a * (b * c))
| mul_one : ∀ a : group_term, rel (a * 1) a
| one_mul : ∀ a : group_term, rel (1 * a) a
| mul_inv_self : ∀ a : group_term, rel (a * a⁻¹) 1
| inv_mul_self : ∀ a : group_term, rel (a⁻¹ * a) 1
| mul_inv_left_cancel : ∀ a b : group_term, rel (a⁻¹ * (a * b)) b
| mul_inv_right_cancel : ∀ a b : group_term, rel (a * (a⁻¹ * b)) b
| mul_inv_rev : ∀ a b, rel ((a * b)⁻¹) (b⁻¹ * a⁻¹)
| inv_inv : ∀ a, rel (a⁻¹⁻¹) a
| one_inv : rel (1⁻¹) 1
| mul : ∀ {a b c d : group_term}, rel a c → rel b d → rel (a * b) (c * d)
| refl : ∀ a : group_term, rel a a
| symm : ∀ {a b}, rel a b → rel b a
| trans : ∀ {a b c : group_term}, rel a b → rel b c → rel a c

lemma eval_eq_of_rel {G : Type*} [group G] (f : ℕ → G) (e₁ e₂ : group_term)
  (h : rel e₁ e₂) : e₁.eval f = e₂.eval f :=
by induction h; simp [eval, mul_assoc, *]

open expr

@[inline] meta def rel.reflect : Π {a b : group_term}, rel a b → expr
| _ _ (rel.assoc a b c) := (app (app (app (const ``rel.assoc [])
  (reflect a)) (reflect b)) (reflect c))
| _ _ (rel.mul_one a) := app (const ``rel.mul_one []) (reflect a)
| _ _ (rel.one_mul a) := app (const ``rel.one_mul []) (reflect a)
| _ _ (rel.mul_inv_self a) := app (const ``rel.mul_inv_self []) (reflect a)
| _ _ (rel.inv_mul_self a) := app (const ``rel.inv_mul_self []) (reflect a)
| _ _ (rel.mul_inv_left_cancel a b) :=
  app (app (const ``rel.mul_inv_left_cancel []) (reflect a)) (reflect b)
| _ _ (rel.mul_inv_right_cancel a b) :=
  app (app (const ``rel.mul_inv_right_cancel []) (reflect a)) (reflect b)
| _ _ (@rel.mul a b c d h₁ h₂) := app (app (app (app (app (app
  (const ``rel.mul [])
  (reflect a)) (reflect b)) (reflect c))
  (reflect d)) (rel.reflect h₁)) (rel.reflect h₂)
| _ _ (rel.mul_inv_rev a b) := app (app (const ``rel.mul_inv_rev []) (reflect a)) (reflect b)
| _ _ (rel.inv_inv a) := app (const ``rel.inv_inv []) (reflect a)
| _ _ (rel.one_inv) := const ``rel.one_inv []
| _ _ (rel.refl a) := app (const ``rel.refl []) (reflect a)
| _ _ (@rel.symm a b h) := app (app (app (const ``rel.symm []) (reflect a))
  (reflect b)) (rel.reflect h)
| _ _ (@rel.trans a b c hab hbc) := app (app (app (app (app
  (const ``rel.trans []) (reflect a))
  (reflect b)) (reflect c)) (rel.reflect hab)) (rel.reflect hbc)

-- meta def rel.reflect : Π {a b : group_term}, rel a b → expr
-- | _ _ (rel.assoc a b c) := `(rel.assoc %%(reflect a) %%(reflect b) %%(reflect c))
-- | _ _ (rel.mul_one a) := `(rel.mul_one %%(reflect a))
-- | _ _ (rel.one_mul a) := `(rel.one_mul %%(reflect a))
-- | _ _ (rel.mul_inv_self a) := `(rel.mul_inv_self %%(reflect a))
-- | _ _ (rel.inv_mul_self a) := `(rel.inv_mul_self %%(reflect a))
-- | _ _ (rel.mul_inv_left_cancel a b) := `(rel.mul_inv_left_cancel %%(reflect a) %%(reflect b))
-- | _ _ (rel.mul_inv_right_cancel a b) := `(rel.mul_inv_right_cancel %%(reflect a) %%(reflect b))
-- | _ _ (@rel.mul a b c d h₁ h₂) :=
--   `(@rel.mul %%(reflect a) %%(reflect b) %%(reflect c) %%(reflect d)
--      %%(rel.reflect h₁) %%(rel.reflect h₂))
-- | _ _ (rel.mul_inv_rev a b) := `(rel.mul_inv_rev %%(reflect a) %%(reflect b))
-- | _ _ (rel.inv_inv a) := `(rel.inv_inv a)
-- | _ _ (rel.one_inv) := `(rel.one_inv)
-- | _ _ (rel.refl a) := `(rel.refl a)
-- | _ _ (@rel.symm a b h) := `(@rel.symm %%(reflect a) %%(reflect b) %%(rel.reflect h))
-- | _ _ (@rel.trans a b c hab hbc) :=
--   `(@rel.trans %%(reflect a) %%(reflect b) %%(reflect c) %%(rel.reflect hab) %%(rel.reflect hbc))

attribute [trans] rel.trans

meta def snormalize : Π (x : group_term), Σ y : group_term, rel x y
| (a * b * c) := let ⟨y, h⟩ := snormalize (a * (b * c)) in
  ⟨y, rel.trans (rel.assoc _ _ _) h⟩
| (1⁻¹) := ⟨1, rel.one_inv⟩
| (a * 1) := let ⟨y, h⟩ := snormalize a in ⟨y, rel.trans (rel.mul_one _) h⟩
| (of i) := ⟨(of i), rel.refl _⟩
| (1 * a) := let ⟨y, h⟩ := snormalize a in ⟨y, rel.trans (rel.one_mul _) h⟩
| (of i * (of j)⁻¹) := if hij : i = j
  then ⟨1, eq.rec_on hij $ rel.mul_inv_self _⟩
  else ⟨of i * (of j)⁻¹, rel.refl _⟩
| ((of i)⁻¹ * of j) := if hij : i = j
  then ⟨1, eq.rec_on hij $ rel.inv_mul_self _⟩
  else ⟨(of i)⁻¹ * of j, rel.refl _⟩
| ((of i) * ((of j)⁻¹ * a)) :=
  if hij : i = j
  then let ⟨y, h⟩ := snormalize a in
    ⟨y, rel.trans (show rel ((of i) * ((of j)⁻¹ * a)) a,
      from eq.rec_on hij (rel.mul_inv_right_cancel (of i) a)) h⟩
  else let ⟨y, h⟩ := snormalize ((of j)⁻¹ * a) in
    ⟨(of i) * y, rel.mul (rel.refl _) h⟩
| ((of i)⁻¹ * ((of j) * a)) :=
  if hij : i = j
  then let ⟨y, h⟩ := snormalize a in
    ⟨y, rel.trans (show rel ((of i)⁻¹ * ((of j) * a)) a,
      from eq.rec_on hij (rel.mul_inv_left_cancel (of i) a)) h⟩
  else let ⟨y, h⟩ := snormalize ((of j) * a) in
    ⟨(of i)⁻¹ * y, rel.mul (rel.refl _) h⟩
| ((a * b)⁻¹) := let ⟨y, h⟩ := snormalize (b⁻¹ * a⁻¹) in
  ⟨y, rel.trans (rel.mul_inv_rev _ _) h⟩
| (a⁻¹⁻¹) := let ⟨y, h⟩ := snormalize a in
  ⟨y, rel.trans (rel.inv_inv _) h⟩
| (of i)⁻¹ := ⟨(of i)⁻¹, rel.refl _⟩
| 1 := ⟨1, rel.refl _⟩
| (a * b) := let ⟨x, hx⟩ := snormalize a in let ⟨y, hy⟩ := snormalize b in
  ⟨x * y, rel.mul hx hy⟩

meta def normalize : Π (x : group_term), Σ y : group_term, rel x y
| x := let sn := snormalize x in
if x = sn.1 then ⟨x, rel.refl x⟩
else let n := normalize sn.1 in
⟨n.1, sn.2.trans n.2⟩

open tactic

meta def prove_rel (x y : group_term) : option (rel x y) :=
let nx := normalize x, ny := normalize y in
if h : nx.1 = ny.1
then some (rel.trans nx.2 (eq.rec_on h.symm ny.2.symm))
else none

-- meta def prove_rel_aux : expr → tactic unit
-- | `(rel %%xe %%ye) :=
-- do x ← eval_expr group_term xe,
--    y ← eval_expr group_term ye,
--    match prove_rel' x y with
--    | none := failure
--    | some e := tactic.exact (rel.reflect e)
--    end
-- | _ := failure

-- meta def prove_rel : tactic unit :=
-- target >>= prove_rel_aux

@[derive [monad, alternative]]
meta def group_m (α : Type) : Type :=
reader_t (ref (buffer expr)) tactic α

meta def read : group_m (ref (buffer expr)) := reader_t.read

meta def add_atom (e : expr) : group_m ℕ :=
⟨λ l, do es ← read_ref l,
  es.iterate failed (λ n e' t, t <|> (is_def_eq e e' $> n.1)) <|>
    (es.size <$ write_ref l (es.push_back e))⟩

meta def to_group_term : expr → group_m group_term
| `(%%a * %%b) :=
  do a' ← to_group_term a,
     b' ← to_group_term b,
     return (a' * b')
| `((%%a)⁻¹) :=
  do a' ← to_group_term a, return (a'⁻¹)
| `(@has_one.one _ _) := return 1
| e := do l ← read, n ← add_atom e, return (of n)

meta def to_group_rel : expr → group_m (expr × group_term × group_term )
| `(@eq %%G %%a %%b) :=
  do a' ← to_group_term a,
     b' ← to_group_term b,
     return (G, a', b')
| _ := failure

/-- Given an `l : buffer expr` return an `expr` representing a list containing
  whose elements are the elements represented by the `expr`s in `l`  -/
meta def to_list_expr (α : expr) (l : buffer expr) : tactic expr :=
l.reverse.foldl (mk_mapp `list.nil [α])
  (λ a l, do l ← l, mk_mapp `list.cons [α, a, l])

lemma eval_eq_of_rel' (G : Type*) [group G] (l : list G) (t₁ t₂ : group_term)
  (h : rel t₁ t₂) : t₁.eval (λ i, (l.nth i).get_or_else 1) =
  t₂.eval (λ i, (l.nth i).get_or_else 1) :=
eval_eq_of_rel _ _ _ h

meta def suffices_rel : tactic unit :=
using_new_ref mk_buffer $ λ l : ref (buffer expr),
  do t ← target,
  (G, t₁, t₂) ← reader_t.run (to_group_rel t) l,
  l ← read_ref l,
  l ← to_list_expr G l,
  p' ← tactic.mk_mapp `group_term.eval_eq_of_rel'
        [G, none, l, reflect t₁, reflect t₂],
  apply p', skip

meta def group_tac : tactic unit :=
using_new_ref mk_buffer $ λ l : ref (buffer expr),
  do t ← target,
  (G, t₁, t₂) ← reader_t.run (to_group_rel t) l,
  l ← read_ref l,
  l ← to_list_expr G l,
  match prove_rel t₁ t₂ with
  | none := do trace "t₁ = ",
      trace (repr t₁),
      trace "t₂ = ",
      trace (repr t₂), fail "terms aren't equal"
  | some p :=
      do p' ← tactic.mk_mapp `group_term.eval_eq_of_rel'
          [G, none, l, reflect t₁, reflect t₂, rel.reflect p],
      tactic.exact p'
  end

set_option profiler true

example {G : Type*} [group G] (a b c d e f g h i : G) :
  (d * a * b * b⁻¹ * c * c * c⁻¹ * (c⁻¹ * a * f * g * g)⁻¹ *
  g * (g⁻¹ * a * a⁻¹)⁻¹ * 1 * 1⁻¹ * a⁻¹ * (1 * a)) =
  d * a * c * g⁻¹ * g⁻¹ * f⁻¹ * a⁻¹ * c * g * g  :=
begin
  group_tac,
end

example {G : Type } [group G] (a b c d e f g h i : G) :
  (a * a⁻¹) = 1 :=
begin
  group_tac,
end

end group_term


namespace prop_17

variables A B : Prop

theorem prop_17 : ¬ (¬ A ∧ ¬ B) → (A ∨ B) :=
assume h1: ¬ (¬ A ∧ ¬ B),
show A ∨ B, from or.elim (classical.em A)
    (assume h2: A, or.inl h2)
    (assume h3: ¬ A,
     show A ∨ B, from or.inr
        (show B, from (classical.by_contradiction
            (assume h4: ¬ B,
             have h5: ¬ A ∧ ¬ B, from and.intro h3 h4,
             h1 h5))))

-- end namespace
end prop_17


import YatimaStdLib.Algebra
import YatimaStdLib.Nat
import YatimaStdLib.Int

namespace Fin

def ofInt {n : Nat} (a : Int) : Fin n.succ :=
  ⟨a.modToNat n.succ, Int.modToNat_le⟩

/- This is copied from core since it is private -/
theorem mlt {b : Nat} : {a : Nat} → a < n → b % n < n
  | 0  , h => Nat.mod_lt _ h
  | _+1, h => Nat.mod_lt _ (Nat.lt_trans (Nat.zero_lt_succ _) h)

def inv : Fin n → Fin n
  | ⟨a, h⟩ => ⟨(Int.modToNat (Nat.GCD.gcdA a n) n) % n, mlt h⟩

instance : YatimaStdLib.Inv (Fin n) where
  inv a := Fin.inv a

end Fin


import tactic
import order.galois_connection

def hProp := { T : Type // ∀ x y : T, x = y }

structure powerset_adjunction (X Y : Type) :=
( preim : (set Y) → (set X) )
( im : (set X) → (set Y) )
( adj : galois_connection im preim )

example {X Y : Type} (f : X → Y) (s t : set Y) :
  f ⁻¹' (s ∩ t) = (f ⁻¹' s) ∩ (f ⁻¹' t) := rfl

example : powerset_adjunction ℕ ℕ :=
{ preim := λ _, set.univ,
  im := λ _, ∅,
  adj := λ _, by simp }

structure powerset_adjunction2 (X Y : Type) :=
( preim₁ : set (Y × Y) → set (X × Y) )
( im₁    : set (X × Y) → set (Y × Y) )
( preim₂ : set (X × Y) → set (X × X) )
( im₂    : set (X × X) → set (X × Y) )
( adj₁   : galois_connection im₁ preim₁ )
( adj₂   : galois_connection im₂ preim₂ )
( swap   : ∀ s, (im₂ ∘ preim₂) s ⊆ (preim₁ ∘ im₁) s )

example {X Y : Type} (f : X → Y) (s : set (X × Y)) :
  prod.map (id : X → X) f '' (prod.map id f ⁻¹' s) ≤
  prod.map f (id : Y → Y) ⁻¹' (prod.map f id '' s) :=
begin
  intro x,
  cases x with x y,
  { simp,
    rintros x₁ x₂ h rfl rfl,
    use x₁,
    simp * }
end

example {X Y : Type} (h : powerset_adjunction2 X Y) (x : X) : Y :=
begin
  have := h.im₂ {y : X × X | y.1 = y.2},

end

structure powerset_adjunction (X Y : Type) :=
( preim : (Y → hProp) → (X → hProp) )
( im : (X → hProp) → (Y → hProp) )
( adj : ∀ (s : X → hProp) (t : Y → hProp),
    (∀ x, (s x).1 → (preim t x).1) ≃ (∀ x, (im s x).1 → (t x).1) )

example {X Y : Type} (h : powerset_adjunction X Y) (x : X) : Y :=
begin
  cases h with preim im adj,
  have := adj (λ y : X, ⟨plift (x = y), by simp⟩)
    (λ y, nonempty ),

end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module combinatorics.simple_graph.hasse
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Combinatorics.SimpleGraph.Prod
import Mathbin.Data.Fin.SuccPred
import Mathbin.Order.SuccPred.Relation

/-!
# The Hasse diagram as a graph

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

This file defines the Hasse diagram of an order (graph of `covby`, the covering relation) and the
path graph on `n` vertices.

## Main declarations

* `simple_graph.hasse`: Hasse diagram of an order.
* `simple_graph.path_graph`: Path graph on `n` vertices.
-/

open Order OrderDual Relation

namespace SimpleGraph

variable (α β : Type _)

section Preorder

variable [Preorder α] [Preorder β]

#print SimpleGraph.hasse /-
/-- The Hasse diagram of an order as a simple graph. The graph of the covering relation. -/
def hasse : SimpleGraph α where
  Adj a b := a ⋖ b ∨ b ⋖ a
  symm a b := Or.symm
  loopless a h := h.elim (irrefl _) (irrefl _)
#align simple_graph.hasse SimpleGraph.hasse
-/

variable {α β} {a b : α}

#print SimpleGraph.hasse_adj /-
@[simp]
theorem hasse_adj : (hasse α).Adj a b ↔ a ⋖ b ∨ b ⋖ a :=
  Iff.rfl
#align simple_graph.hasse_adj SimpleGraph.hasse_adj
-/

#print SimpleGraph.hasseDualIso /-
/-- `αᵒᵈ` and `α` have the same Hasse diagram. -/
def hasseDualIso : hasse αᵒᵈ ≃g hasse α :=
  { ofDual with map_rel_iff' := fun a b => by simp [or_comm'] }
#align simple_graph.hasse_dual_iso SimpleGraph.hasseDualIso
-/

/- warning: simple_graph.hasse_dual_iso_apply -> SimpleGraph.hasseDualIso_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (a : OrderDual.{u1} α), Eq.{succ u1} α (coeFn.{succ u1, succ u1} (SimpleGraph.Iso.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1)) (SimpleGraph.hasse.{u1} α _inst_1)) (fun (_x : RelIso.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1))) => (OrderDual.{u1} α) -> α) (RelIso.hasCoeToFun.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1))) (SimpleGraph.hasseDualIso.{u1} α _inst_1) a) (coeFn.{succ u1, succ u1} (Equiv.{succ u1, succ u1} (OrderDual.{u1} α) α) (fun (_x : Equiv.{succ u1, succ u1} (OrderDual.{u1} α) α) => (OrderDual.{u1} α) -> α) (Equiv.hasCoeToFun.{succ u1, succ u1} (OrderDual.{u1} α) α) (OrderDual.ofDual.{u1} α) a)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (a : OrderDual.{u1} α), Eq.{succ u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : OrderDual.{u1} α) => α) a) (FunLike.coe.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} (OrderDual.{u1} α) α) (OrderDual.{u1} α) (fun (_x : OrderDual.{u1} α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : OrderDual.{u1} α) => α) _x) (EmbeddingLike.toFunLike.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} (OrderDual.{u1} α) α) (OrderDual.{u1} α) α (Function.instEmbeddingLikeEmbedding.{succ u1, succ u1} (OrderDual.{u1} α) α)) (RelEmbedding.toEmbedding.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (RelIso.toRelEmbedding.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (SimpleGraph.hasseDualIso.{u1} α _inst_1))) a) (FunLike.coe.{succ u1, succ u1, succ u1} (Equiv.{succ u1, succ u1} (OrderDual.{u1} α) α) (OrderDual.{u1} α) (fun (_x : OrderDual.{u1} α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : OrderDual.{u1} α) => α) _x) (Equiv.instFunLikeEquiv.{succ u1, succ u1} (OrderDual.{u1} α) α) (OrderDual.ofDual.{u1} α) a)
Case conversion may be inaccurate. Consider using '#align simple_graph.hasse_dual_iso_apply SimpleGraph.hasseDualIso_applyₓ'. -/
@[simp]
theorem hasseDualIso_apply (a : αᵒᵈ) : hasseDualIso a = ofDual a :=
  rfl
#align simple_graph.hasse_dual_iso_apply SimpleGraph.hasseDualIso_apply

/- warning: simple_graph.hasse_dual_iso_symm_apply -> SimpleGraph.hasseDualIso_symm_apply is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (a : α), Eq.{succ u1} (OrderDual.{u1} α) (coeFn.{succ u1, succ u1} (SimpleGraph.Iso.{u1, u1} α (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} α _inst_1) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (fun (_x : RelIso.{u1, u1} α (OrderDual.{u1} α) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1)))) => α -> (OrderDual.{u1} α)) (RelIso.hasCoeToFun.{u1, u1} α (OrderDual.{u1} α) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1)))) (SimpleGraph.Iso.symm.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1)) (SimpleGraph.hasse.{u1} α _inst_1) (SimpleGraph.hasseDualIso.{u1} α _inst_1)) a) (coeFn.{succ u1, succ u1} (Equiv.{succ u1, succ u1} α (OrderDual.{u1} α)) (fun (_x : Equiv.{succ u1, succ u1} α (OrderDual.{u1} α)) => α -> (OrderDual.{u1} α)) (Equiv.hasCoeToFun.{succ u1, succ u1} α (OrderDual.{u1} α)) (OrderDual.toDual.{u1} α) a)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Preorder.{u1} α] (a : α), Eq.{succ u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => OrderDual.{u1} α) a) (FunLike.coe.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} α (OrderDual.{u1} α)) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => OrderDual.{u1} α) _x) (EmbeddingLike.toFunLike.{succ u1, succ u1, succ u1} (Function.Embedding.{succ u1, succ u1} α (OrderDual.{u1} α)) α (OrderDual.{u1} α) (Function.instEmbeddingLikeEmbedding.{succ u1, succ u1} α (OrderDual.{u1} α))) (RelEmbedding.toEmbedding.{u1, u1} α (OrderDual.{u1} α) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (RelIso.toRelEmbedding.{u1, u1} α (OrderDual.{u1} α) (SimpleGraph.Adj.{u1} α (SimpleGraph.hasse.{u1} α _inst_1)) (SimpleGraph.Adj.{u1} (OrderDual.{u1} α) (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1))) (SimpleGraph.Iso.symm.{u1, u1} (OrderDual.{u1} α) α (SimpleGraph.hasse.{u1} (OrderDual.{u1} α) (OrderDual.preorder.{u1} α _inst_1)) (SimpleGraph.hasse.{u1} α _inst_1) (SimpleGraph.hasseDualIso.{u1} α _inst_1)))) a) (FunLike.coe.{succ u1, succ u1, succ u1} (Equiv.{succ u1, succ u1} α (OrderDual.{u1} α)) α (fun (_x : α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : α) => OrderDual.{u1} α) _x) (Equiv.instFunLikeEquiv.{succ u1, succ u1} α (OrderDual.{u1} α)) (OrderDual.toDual.{u1} α) a)
Case conversion may be inaccurate. Consider using '#align simple_graph.hasse_dual_iso_symm_apply SimpleGraph.hasseDualIso_symm_applyₓ'. -/
@[simp]
theorem hasseDualIso_symm_apply (a : α) : hasseDualIso.symm a = toDual a :=
  rfl
#align simple_graph.hasse_dual_iso_symm_apply SimpleGraph.hasseDualIso_symm_apply

end Preorder

section PartialOrder

variable [PartialOrder α] [PartialOrder β]

/- warning: simple_graph.hasse_prod -> SimpleGraph.hasse_prod is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) (β : Type.{u2}) [_inst_1 : PartialOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β], Eq.{succ (max u1 u2)} (SimpleGraph.{max u1 u2} (Prod.{u1, u2} α β)) (SimpleGraph.hasse.{max u1 u2} (Prod.{u1, u2} α β) (Prod.preorder.{u1, u2} α β (PartialOrder.toPreorder.{u1} α _inst_1) (PartialOrder.toPreorder.{u2} β _inst_2))) (SimpleGraph.boxProd.{u1, u2} α β (SimpleGraph.hasse.{u1} α (PartialOrder.toPreorder.{u1} α _inst_1)) (SimpleGraph.hasse.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2)))
but is expected to have type
  forall (α : Type.{u2}) (β : Type.{u1}) [_inst_1 : PartialOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β], Eq.{max (succ u2) (succ u1)} (SimpleGraph.{max u1 u2} (Prod.{u2, u1} α β)) (SimpleGraph.hasse.{max u1 u2} (Prod.{u2, u1} α β) (Prod.instPreorderProd.{u2, u1} α β (PartialOrder.toPreorder.{u2} α _inst_1) (PartialOrder.toPreorder.{u1} β _inst_2))) (SimpleGraph.boxProd.{u2, u1} α β (SimpleGraph.hasse.{u2} α (PartialOrder.toPreorder.{u2} α _inst_1)) (SimpleGraph.hasse.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2)))
Case conversion may be inaccurate. Consider using '#align simple_graph.hasse_prod SimpleGraph.hasse_prodₓ'. -/
@[simp]
theorem hasse_prod : hasse (α × β) = hasse α □ hasse β :=
  by
  ext (x y)
  simp_rw [box_prod_adj, hasse_adj, Prod.covby_iff, or_and_right, @eq_comm _ y.1, @eq_comm _ y.2,
    or_or_or_comm]
#align simple_graph.hasse_prod SimpleGraph.hasse_prod

end PartialOrder

section LinearOrder

variable [LinearOrder α]

#print SimpleGraph.hasse_preconnected_of_succ /-
theorem hasse_preconnected_of_succ [SuccOrder α] [IsSuccArchimedean α] : (hasse α).Preconnected :=
  fun a b => by
  rw [reachable_iff_refl_trans_gen]
  exact
    reflTransGen_of_succ _ (fun c hc => Or.inl <| covby_succ_of_not_is_max hc.2.not_isMax)
      fun c hc => Or.inr <| covby_succ_of_not_is_max hc.2.not_isMax
#align simple_graph.hasse_preconnected_of_succ SimpleGraph.hasse_preconnected_of_succ
-/

#print SimpleGraph.hasse_preconnected_of_pred /-
theorem hasse_preconnected_of_pred [PredOrder α] [IsPredArchimedean α] : (hasse α).Preconnected :=
  fun a b => by
  rw [reachable_iff_refl_trans_gen, ← refl_trans_gen_swap]
  exact
    reflTransGen_of_pred _ (fun c hc => Or.inl <| pred_covby_of_not_is_min hc.1.not_isMin)
      fun c hc => Or.inr <| pred_covby_of_not_is_min hc.1.not_isMin
#align simple_graph.hasse_preconnected_of_pred SimpleGraph.hasse_preconnected_of_pred
-/

end LinearOrder

#print SimpleGraph.pathGraph /-
/-- The path graph on `n` vertices. -/
def pathGraph (n : ℕ) : SimpleGraph (Fin n) :=
  hasse _
#align simple_graph.path_graph SimpleGraph.pathGraph
-/

#print SimpleGraph.pathGraph_preconnected /-
theorem pathGraph_preconnected (n : ℕ) : (pathGraph n).Preconnected :=
  hasse_preconnected_of_succ _
#align simple_graph.path_graph_preconnected SimpleGraph.pathGraph_preconnected
-/

#print SimpleGraph.pathGraph_connected /-
theorem pathGraph_connected (n : ℕ) : (pathGraph (n + 1)).Connected :=
  ⟨pathGraph_preconnected _⟩
#align simple_graph.path_graph_connected SimpleGraph.pathGraph_connected
-/

end SimpleGraph


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang

! This file was ported from Lean 3 source module algebra.module.injective
! leanprover-community/mathlib commit f8d8465c3c392a93b9ed226956e26dee00975946
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Preadditive.Injective
import Mathbin.Algebra.Category.Module.EpiMono
import Mathbin.RingTheory.Ideal.Basic
import Mathbin.LinearAlgebra.LinearPmap

/-!
# Injective modules

## Main definitions

* `module.injective`: an `R`-module `Q` is injective if and only if every injective `R`-linear
  map descends to a linear map to `Q`, i.e. in the following diagram, if `f` is injective then there
  is an `R`-linear map `h : Y ⟶ Q` such that `g = h ∘ f`
  ```
  X --- f ---> Y
  |
  | g
  v
  Q
  ```
* `module.Baer`: an `R`-module `Q` satisfies Baer's criterion if any `R`-linear map from an
  `ideal R` extends to an `R`-linear map `R ⟶ Q`

## Main statements

* `module.Baer.criterion`: an `R`-module is injective if it is Baer.

-/

noncomputable section

universe u v

variable (R : Type u) [Ring R] (Q : Type max u v) [AddCommGroup Q] [Module R Q]

/--
An `R`-module `Q` is injective if and only if every injective `R`-linear map descends to a linear
map to `Q`, i.e. in the following diagram, if `f` is injective then there is an `R`-linear map
`h : Y ⟶ Q` such that `g = h ∘ f`
  ```
  X --- f ---> Y
  |
  | g
  v
  Q
  ```
-/
class Module.Injective : Prop where
  out :
    ∀ (X Y : Type max u v) [AddCommGroup X] [AddCommGroup Y] [Module R X] [Module R Y]
      (f : X →ₗ[R] Y) (hf : Function.Injective f) (g : X →ₗ[R] Q),
      ∃ h : Y →ₗ[R] Q, ∀ x, h (f x) = g x
#align module.injective Module.Injective

theorem Module.injective_object_of_injective_module [Module.Injective.{u, v} R Q] :
    CategoryTheory.Injective.{max u v} (⟨Q⟩ : ModuleCat.{max u v} R) :=
  {
    Factors := fun X Y g f mn =>
      by
      rcases Module.Injective.out X Y f ((ModuleCat.mono_iff_injective f).mp mn) g with ⟨h, eq1⟩
      exact ⟨h, LinearMap.ext eq1⟩ }
#align module.injective_object_of_injective_module Module.injective_object_of_injective_module

theorem Module.injective_module_of_injective_object
    [CategoryTheory.Injective.{max u v} (⟨Q⟩ : ModuleCat.{max u v} R)] :
    Module.Injective.{u, v} R Q :=
  {
    out := fun X Y ins1 ins2 ins3 ins4 f hf g => by
      skip
      rcases@CategoryTheory.Injective.factors (ModuleCat R) _ ⟨Q⟩ _ ⟨X⟩ ⟨Y⟩ g f
          ((ModuleCat.mono_iff_injective _).mpr hf) with
        ⟨h, rfl⟩
      exact ⟨h, fun x => rfl⟩ }
#align module.injective_module_of_injective_object Module.injective_module_of_injective_object

theorem Module.injective_iff_injective_object :
    Module.Injective.{u, v} R Q ↔
      CategoryTheory.Injective.{max u v} (⟨Q⟩ : ModuleCat.{max u v} R) :=
  ⟨fun h => @Module.injective_object_of_injective_module R _ Q _ _ h, fun h =>
    @Module.injective_module_of_injective_object R _ Q _ _ h⟩
#align module.injective_iff_injective_object Module.injective_iff_injective_object

/-- An `R`-module `Q` satisfies Baer's criterion if any `R`-linear map from an `ideal R` extends to
an `R`-linear map `R ⟶ Q`-/
def Module.Baer : Prop :=
  ∀ (I : Ideal R) (g : I →ₗ[R] Q), ∃ g' : R →ₗ[R] Q, ∀ (x : R) (mem : x ∈ I), g' x = g ⟨x, mem⟩
#align module.Baer Module.Baer

namespace Module.Baer

variable {R Q} {M N : Type max u v} [AddCommGroup M] [AddCommGroup N]

variable [Module R M] [Module R N] (i : M →ₗ[R] N) (f : M →ₗ[R] Q)

/-- If we view `M` as a submodule of `N` via the injective linear map `i : M ↪ N`, then a submodule
between `M` and `N` is a submodule `N'` of `N`. To prove Baer's criterion, we need to consider
pairs of `(N', f')` such that `M ≤ N' ≤ N` and `f'` extends `f`. -/
structure ExtensionOf extends LinearPMap R N Q where
  le : i.range ≤ domain
  is_extension : ∀ m : M, f m = to_linear_pmap ⟨i m, le ⟨m, rfl⟩⟩
#align module.Baer.extension_of Module.Baer.ExtensionOf

section Ext

variable {i f}

@[ext]
theorem ExtensionOf.ext {a b : ExtensionOf i f} (domain_eq : a.domain = b.domain)
    (to_fun_eq :
      ∀ ⦃x : a.domain⦄ ⦃y : b.domain⦄, (x : N) = y → a.toLinearPMap x = b.toLinearPMap y) :
    a = b := by
  rcases a with ⟨a, a_le, e1⟩
  rcases b with ⟨b, b_le, e2⟩
  congr
  exact LinearPMap.ext domain_eq to_fun_eq
#align module.Baer.extension_of.ext Module.Baer.ExtensionOf.ext

theorem ExtensionOf.ext_iff {a b : ExtensionOf i f} :
    a = b ↔
      ∃ domain_eq : a.domain = b.domain,
        ∀ ⦃x : a.domain⦄ ⦃y : b.domain⦄, (x : N) = y → a.toLinearPMap x = b.toLinearPMap y :=
  ⟨fun r => r ▸ ⟨rfl, fun x y h => congr_arg a.toFun <| by exact_mod_cast h⟩, fun ⟨h1, h2⟩ =>
    ExtensionOf.ext h1 h2⟩
#align module.Baer.extension_of.ext_iff Module.Baer.ExtensionOf.ext_iff

end Ext

instance : Inf (ExtensionOf i f)
    where inf X1 X2 :=
    {
      X1.toLinearPMap ⊓
        X2.toLinearPMap with
      le := fun x hx =>
        (by
          rcases hx with ⟨x, rfl⟩
          refine' ⟨X1.le (Set.mem_range_self _), X2.le (Set.mem_range_self _), _⟩
          rw [← X1.is_extension x, ← X2.is_extension x] :
          x ∈ X1.toLinearPMap.eqLocus X2.toLinearPMap)
      is_extension := fun m => X1.is_extension _ }

instance : SemilatticeInf (ExtensionOf i f) :=
  Function.Injective.semilatticeInf ExtensionOf.toLinearPmap
    (fun X Y h =>
      ExtensionOf.ext (by rw [h]) fun x y h' =>
        by
        induction h
        congr
        exact_mod_cast h')
    fun X Y =>
    LinearPMap.ext rfl fun x y h => by
      congr
      exact_mod_cast h

variable {R i f}

theorem chain_linearPMap_of_chain_extensionOf {c : Set (ExtensionOf i f)}
    (hchain : IsChain (· ≤ ·) c) :
    IsChain (· ≤ ·) <| (fun x : ExtensionOf i f => x.toLinearPMap) '' c :=
  by
  rintro _ ⟨a, a_mem, rfl⟩ _ ⟨b, b_mem, rfl⟩ neq
  exact hchain a_mem b_mem (ne_of_apply_ne _ neq)
#align module.Baer.chain_linear_pmap_of_chain_extension_of Module.Baer.chain_linearPMap_of_chain_extensionOf

/-- The maximal element of every nonempty chain of `extension_of i f`. -/
def ExtensionOf.max {c : Set (ExtensionOf i f)} (hchain : IsChain (· ≤ ·) c)
    (hnonempty : c.Nonempty) : ExtensionOf i f :=
  {
    LinearPMap.supₛ _
      (IsChain.directedOn <|
        chain_linearPMap_of_chain_extensionOf
          hchain) with
    le :=
      le_trans hnonempty.some.le <|
        (LinearPMap.le_supₛ _ <|
            (Set.mem_image _ _ _).mpr ⟨hnonempty.some, hnonempty.choose_spec, rfl⟩).1
    is_extension := fun m =>
      by
      refine' Eq.trans (hnonempty.some.is_extension m) _
      symm
      generalize_proofs _ h0 h1
      exact
        LinearPMap.supₛ_apply (IsChain.directedOn <| chain_linear_pmap_of_chain_extension_of hchain)
          ((Set.mem_image _ _ _).mpr ⟨hnonempty.some, hnonempty.some_spec, rfl⟩) ⟨i m, h1⟩ }
#align module.Baer.extension_of.max Module.Baer.ExtensionOf.max

theorem ExtensionOf.le_max {c : Set (ExtensionOf i f)} (hchain : IsChain (· ≤ ·) c)
    (hnonempty : c.Nonempty) (a : ExtensionOf i f) (ha : a ∈ c) :
    a ≤ ExtensionOf.max hchain hnonempty :=
  LinearPMap.le_supₛ (IsChain.directedOn <| chain_linearPMap_of_chain_extensionOf hchain) <|
    (Set.mem_image _ _ _).mpr ⟨a, ha, rfl⟩
#align module.Baer.extension_of.le_max Module.Baer.ExtensionOf.le_max

variable (i f) [Fact <| Function.Injective i]

instance ExtensionOf.inhabited : Inhabited (ExtensionOf i f)
    where default :=
    { domain := i.range
      toFun :=
        { toFun := fun x => f x.2.some
          map_add' := fun x y =>
            by
            have eq1 : _ + _ = (x + y).1 := congr_arg₂ (· + ·) x.2.choose_spec y.2.choose_spec
            rw [← map_add, ← (x + y).2.choose_spec] at eq1
            rw [← Fact.out (Function.Injective i) eq1, map_add]
          map_smul' := fun r x =>
            by
            have eq1 : r • _ = (r • x).1 := congr_arg ((· • ·) r) x.2.choose_spec
            rw [← LinearMap.map_smul, ← (r • x).2.choose_spec] at eq1
            rw [RingHom.id_apply, ← Fact.out (Function.Injective i) eq1, LinearMap.map_smul] }
      le := le_refl _
      is_extension := fun m =>
        by
        simp only [LinearPMap.mk_apply, LinearMap.coe_mk]
        congr
        exact Fact.out (Function.Injective i) (⟨i m, ⟨_, rfl⟩⟩ : i.range).2.choose_spec.symm }
#align module.Baer.extension_of.inhabited Module.Baer.ExtensionOf.inhabited

/-- Since every nonempty chain has a maximal element, by Zorn's lemma, there is a maximal
`extension_of i f`. -/
def extensionOfMax : ExtensionOf i f :=
  (@zorn_nonempty_partialOrder (ExtensionOf i f) _ ⟨Inhabited.default⟩ fun c hchain hnonempty =>
      ⟨ExtensionOf.max hchain hnonempty, ExtensionOf.le_max hchain hnonempty⟩).some
#align module.Baer.extension_of_max Module.Baer.extensionOfMax

theorem extensionOfMax_is_max :
    ∀ a : ExtensionOf i f, extensionOfMax i f ≤ a → a = extensionOfMax i f :=
  (@zorn_nonempty_partialOrder (ExtensionOf i f) _ ⟨Inhabited.default⟩ fun c hchain hnonempty =>
      ⟨ExtensionOf.max hchain hnonempty, ExtensionOf.le_max hchain hnonempty⟩).choose_spec
#align module.Baer.extension_of_max_is_max Module.Baer.extensionOfMax_is_max

variable {f}

private theorem extension_of_max_adjoin.aux1 {y : N}
    (x : (extensionOfMax i f).domain ⊔ Submodule.span R {y}) :
    ∃ (a : (extensionOfMax i f).domain)(b : R), x.1 = a.1 + b • y :=
  by
  have mem1 : x.1 ∈ (_ : Set _) := x.2
  rw [Submodule.coe_sup] at mem1
  rcases mem1 with ⟨a, b, a_mem, b_mem : b ∈ (Submodule.span R _ : Submodule R N), eq1⟩
  rw [Submodule.mem_span_singleton] at b_mem
  rcases b_mem with ⟨z, eq2⟩
  exact ⟨⟨a, a_mem⟩, z, by rw [← eq1, ← eq2]⟩
#align module.Baer.extension_of_max_adjoin.aux1 module.Baer.extension_of_max_adjoin.aux1

/-- If `x ∈ M ⊔ ⟨y⟩`, then `x = m + r • y`, `fst` pick an arbitrary such `m`.-/
def ExtensionOfMaxAdjoin.fst {y : N} (x : (extensionOfMax i f).domain ⊔ Submodule.span R {y}) :
    (extensionOfMax i f).domain :=
  (ExtensionOfMaxAdjoin.aux1 i x).some
#align module.Baer.extension_of_max_adjoin.fst Module.Baer.ExtensionOfMaxAdjoin.fst

/-- If `x ∈ M ⊔ ⟨y⟩`, then `x = m + r • y`, `snd` pick an arbitrary such `r`.-/
def ExtensionOfMaxAdjoin.snd {y : N} (x : (extensionOfMax i f).domain ⊔ Submodule.span R {y}) : R :=
  (ExtensionOfMaxAdjoin.aux1 i x).choose_spec.some
#align module.Baer.extension_of_max_adjoin.snd Module.Baer.ExtensionOfMaxAdjoin.snd

theorem ExtensionOfMaxAdjoin.eqn {y : N} (x : (extensionOfMax i f).domain ⊔ Submodule.span R {y}) :
    ↑x = ↑(ExtensionOfMaxAdjoin.fst i x) + ExtensionOfMaxAdjoin.snd i x • y :=
  (ExtensionOfMaxAdjoin.aux1 i x).choose_spec.choose_spec
#align module.Baer.extension_of_max_adjoin.eqn Module.Baer.ExtensionOfMaxAdjoin.eqn

variable (f)

/-- the ideal `I = {r | r • y ∈ N}`-/
def ExtensionOfMaxAdjoin.ideal (y : N) : Ideal R :=
  (extensionOfMax i f).domain.comap ((LinearMap.id : R →ₗ[R] R).smul_right y)
#align module.Baer.extension_of_max_adjoin.ideal Module.Baer.ExtensionOfMaxAdjoin.ideal

/-- A linear map `I ⟶ Q` by `x ↦ f' (x • y)` where `f'` is the maximal extension-/
def ExtensionOfMaxAdjoin.idealTo (y : N) : ExtensionOfMaxAdjoin.ideal i f y →ₗ[R] Q
    where
  toFun z := (extensionOfMax i f).toLinearPMap ⟨(↑z : R) • y, z.Prop⟩
  map_add' z1 z2 := by simp [← (extension_of_max i f).toLinearPMap.map_add, add_smul]
  map_smul' z1 z2 := by simp [← (extension_of_max i f).toLinearPMap.map_smul, mul_smul] <;> rfl
#align module.Baer.extension_of_max_adjoin.ideal_to Module.Baer.ExtensionOfMaxAdjoin.idealTo

/-- Since we assumed `Q` being Baer, the linear map `x ↦ f' (x • y) : I ⟶ Q` extends to `R ⟶ Q`,
call this extended map `φ`-/
def ExtensionOfMaxAdjoin.extendIdealTo (h : Module.Baer R Q) (y : N) : R →ₗ[R] Q :=
  (h (ExtensionOfMaxAdjoin.ideal i f y) (ExtensionOfMaxAdjoin.idealTo i f y)).some
#align module.Baer.extension_of_max_adjoin.extend_ideal_to Module.Baer.ExtensionOfMaxAdjoin.extendIdealTo

theorem ExtensionOfMaxAdjoin.extendIdealTo_is_extension (h : Module.Baer R Q) (y : N) :
    ∀ (x : R) (mem : x ∈ ExtensionOfMaxAdjoin.ideal i f y),
      ExtensionOfMaxAdjoin.extendIdealTo i f h y x = ExtensionOfMaxAdjoin.idealTo i f y ⟨x, mem⟩ :=
  (h (ExtensionOfMaxAdjoin.ideal i f y) (ExtensionOfMaxAdjoin.idealTo i f y)).choose_spec
#align module.Baer.extension_of_max_adjoin.extend_ideal_to_is_extension Module.Baer.ExtensionOfMaxAdjoin.extendIdealTo_is_extension

theorem ExtensionOfMaxAdjoin.extendIdealTo_wd' (h : Module.Baer R Q) {y : N} (r : R)
    (eq1 : r • y = 0) : ExtensionOfMaxAdjoin.extendIdealTo i f h y r = 0 :=
  by
  rw [extension_of_max_adjoin.extend_ideal_to_is_extension i f h y r
      (by rw [eq1] <;> exact Submodule.zero_mem _ : r • y ∈ _)]
  simp only [extension_of_max_adjoin.ideal_to, LinearMap.coe_mk, eq1, Subtype.coe_mk, ←
    ZeroMemClass.zero_def, (extension_of_max i f).toLinearPMap.map_zero]
#align module.Baer.extension_of_max_adjoin.extend_ideal_to_wd' Module.Baer.ExtensionOfMaxAdjoin.extendIdealTo_wd'

theorem ExtensionOfMaxAdjoin.extendIdealTo_wd (h : Module.Baer R Q) {y : N} (r r' : R)
    (eq1 : r • y = r' • y) :
    ExtensionOfMaxAdjoin.extendIdealTo i f h y r = ExtensionOfMaxAdjoin.extendIdealTo i f h y r' :=
  by
  rw [← sub_eq_zero, ← map_sub]
  convert extension_of_max_adjoin.extend_ideal_to_wd' i f h (r - r') _
  rw [sub_smul, sub_eq_zero, eq1]
#align module.Baer.extension_of_max_adjoin.extend_ideal_to_wd Module.Baer.ExtensionOfMaxAdjoin.extendIdealTo_wd

theorem ExtensionOfMaxAdjoin.extendIdealTo_eq (h : Module.Baer R Q) {y : N} (r : R)
    (hr : r • y ∈ (extensionOfMax i f).domain) :
    ExtensionOfMaxAdjoin.extendIdealTo i f h y r = (extensionOfMax i f).toLinearPMap ⟨r • y, hr⟩ :=
  by
  simp only [extension_of_max_adjoin.extend_ideal_to_is_extension i f h _ _ hr,
    extension_of_max_adjoin.ideal_to, LinearMap.coe_mk, Subtype.coe_mk]
#align module.Baer.extension_of_max_adjoin.extend_ideal_to_eq Module.Baer.ExtensionOfMaxAdjoin.extendIdealTo_eq

/-- We can finally define a linear map `M ⊔ ⟨y⟩ ⟶ Q` by `x + r • y ↦ f x + φ r`
-/
def ExtensionOfMaxAdjoin.extensionToFun (h : Module.Baer R Q) {y : N} :
    (extensionOfMax i f).domain ⊔ Submodule.span R {y} → Q := fun x =>
  (extensionOfMax i f).toLinearPMap (ExtensionOfMaxAdjoin.fst i x) +
    ExtensionOfMaxAdjoin.extendIdealTo i f h y (ExtensionOfMaxAdjoin.snd i x)
#align module.Baer.extension_of_max_adjoin.extension_to_fun Module.Baer.ExtensionOfMaxAdjoin.extensionToFun

theorem ExtensionOfMaxAdjoin.extensionToFun_wd (h : Module.Baer R Q) {y : N}
    (x : (extensionOfMax i f).domain ⊔ Submodule.span R {y}) (a : (extensionOfMax i f).domain)
    (r : R) (eq1 : ↑x = ↑a + r • y) :
    ExtensionOfMaxAdjoin.extensionToFun i f h x =
      (extensionOfMax i f).toLinearPMap a + ExtensionOfMaxAdjoin.extendIdealTo i f h y r :=
  by
  cases' a with a ha
  rw [Subtype.coe_mk] at eq1
  have eq2 :
    (extension_of_max_adjoin.fst i x - a : N) = (r - extension_of_max_adjoin.snd i x) • y := by
    rwa [extension_of_max_adjoin.eqn, ← sub_eq_zero, ← sub_sub_sub_eq, sub_eq_zero, ← sub_smul] at
      eq1
  have eq3 :=
    extension_of_max_adjoin.extend_ideal_to_eq i f h (r - extension_of_max_adjoin.snd i x)
      (by rw [← eq2] <;> exact Submodule.sub_mem _ (extension_of_max_adjoin.fst i x).2 ha)
  simp only [map_sub, sub_smul, sub_eq_iff_eq_add] at eq3
  unfold extension_of_max_adjoin.extension_to_fun
  rw [eq3, ← add_assoc, ← (extension_of_max i f).toLinearPMap.map_add, AddMemClass.mk_add_mk]
  congr
  ext
  rw [Subtype.coe_mk, add_sub, ← eq1]
  exact eq_sub_of_add_eq (extension_of_max_adjoin.eqn _ _).symm
#align module.Baer.extension_of_max_adjoin.extension_to_fun_wd Module.Baer.ExtensionOfMaxAdjoin.extensionToFun_wd

/-- The linear map `M ⊔ ⟨y⟩ ⟶ Q` by `x + r • y ↦ f x + φ r` is an extension of `f`-/
def extensionOfMaxAdjoin (h : Module.Baer R Q) (y : N) : ExtensionOf i f
    where
  domain := (extensionOfMax i f).domain ⊔ Submodule.span R {y}
  le := le_trans (extensionOfMax i f).le le_sup_left
  toFun :=
    { toFun := ExtensionOfMaxAdjoin.extensionToFun i f h
      map_add' := fun a b =>
        by
        have eq1 :
          ↑a + ↑b =
            ↑(extension_of_max_adjoin.fst i a + extension_of_max_adjoin.fst i b) +
              (extension_of_max_adjoin.snd i a + extension_of_max_adjoin.snd i b) • y :=
          by
          rw [extension_of_max_adjoin.eqn, extension_of_max_adjoin.eqn, add_smul]
          abel
        rw [extension_of_max_adjoin.extension_to_fun_wd i f h (a + b) _ _ eq1, LinearPMap.map_add,
          map_add]
        unfold extension_of_max_adjoin.extension_to_fun
        abel
      map_smul' := fun r a => by
        rw [RingHom.id_apply]
        have eq1 :
          r • ↑a =
            ↑(r • extension_of_max_adjoin.fst i a) + (r • extension_of_max_adjoin.snd i a) • y :=
          by
          rw [extension_of_max_adjoin.eqn, smul_add, smul_eq_mul, mul_smul]
          rfl
        rw [extension_of_max_adjoin.extension_to_fun_wd i f h (r • a) _ _ eq1, LinearMap.map_smul,
          LinearPMap.map_smul, ← smul_add]
        congr }
  is_extension m := by
    simp only [LinearPMap.mk_apply, LinearMap.coe_mk]
    rw [(extension_of_max i f).is_extension,
      extension_of_max_adjoin.extension_to_fun_wd i f h _ ⟨i m, _⟩ 0 _, map_zero, add_zero]
    simp
#align module.Baer.extension_of_max_adjoin Module.Baer.extensionOfMaxAdjoin

theorem extensionOfMax_le (h : Module.Baer R Q) {y : N} :
    extensionOfMax i f ≤ extensionOfMaxAdjoin i f h y :=
  ⟨le_sup_left, fun x x' EQ => by
    symm
    change extension_of_max_adjoin.extension_to_fun i f h _ = _
    rw [extension_of_max_adjoin.extension_to_fun_wd i f h x' x 0 (by simp [EQ]), map_zero,
      add_zero]⟩
#align module.Baer.extension_of_max_le Module.Baer.extensionOfMax_le

theorem extensionOfMax_to_submodule_eq_top (h : Module.Baer R Q) :
    (extensionOfMax i f).domain = ⊤ :=
  by
  refine' submodule.eq_top_iff'.mpr fun y => _
  rw [← extension_of_max_is_max i f _ (extension_of_max_le i f h), extension_of_max_adjoin,
    Submodule.mem_sup]
  exact ⟨0, Submodule.zero_mem _, y, Submodule.mem_span_singleton_self _, zero_add _⟩
#align module.Baer.extension_of_max_to_submodule_eq_top Module.Baer.extensionOfMax_to_submodule_eq_top

/-- **Baer's criterion** for injective module : a Baer module is an injective module, i.e. if every
linear map from an ideal can be extended, then the module is injective.-/
protected theorem injective (h : Module.Baer R Q) : Module.Injective R Q :=
  {
    out := fun X Y ins1 ins2 ins3 ins4 i hi f =>
      haveI : Fact (Function.Injective i) := ⟨hi⟩
      ⟨{  toFun := fun y =>
            (extension_of_max i f).toLinearPMap
              ⟨y, (extension_of_max_to_submodule_eq_top i f h).symm ▸ trivial⟩
          map_add' := fun x y => by
            rw [← LinearPMap.map_add]
            congr
          map_smul' := fun r x => by
            rw [← LinearPMap.map_smul]
            congr },
        fun x => ((extension_of_max i f).is_extension x).symm⟩ }
#align module.Baer.injective Module.Baer.injective

end Module.Baer