/-

Zariski's Lemma: if k is a field and K is a field finitely generated
as a k-algebra, then K is also finitely-generated as a k-module

-/

import ring_theory.integral_closure field_theory.subfield

import linear_algebra.finite_dimensional

import for_mathlib.finset -- Chris' lemma about S - {s}

import field_theory.minimal_polynomial -- I need a poly for an algebraic element
-- and this will do

example : 2 + 2 = 4 := rfl

open_locale classical

lemma subalgebra.mem_coe_submodule (R : Type*) [comm_ring R] (A : Type*)
  [comm_ring A] [algebra R A]
  (M : subalgebra R A) (x : A) : x ∈ (M : submodule R A) ↔ x ∈ M := iff.rfl

lemma subalgebra.coe_submodule_top (R : Type*) [comm_ring R]
  (A : Type*) [comm_ring A] [algebra R A] :
  ((⊤ : subalgebra R A) : submodule R A) = ⊤ :=
begin
  ext,
  convert iff.refl true,
  rw [eq_true, subalgebra.mem_coe_submodule],
  exact algebra.mem_top,
end

lemma field.closure.clear_denominators
  {K : Type*} [discrete_field K]
  {S : finset K} {T : set K}
  (hST : ↑S ⊆ field.closure T) :
  ∃ D : K, D ≠ 0 ∧ D ∈ ring.closure T ∧ ∀ s ∈ S, D * s ∈ ring.closure T :=
begin
  revert hST,
  apply finset.induction_on S, -- no good because I lose hST
  { intro, use 1,
    split, symmetry, exact zero_ne_one,
    split, exact is_submonoid.one_mem _,
    intros s hs, cases hs,
  },
  rintros a s has H hasT,
  replace H := H (set.subset.trans (finset.subset_insert a s) hasT),
  rcases H with ⟨D0, hD00, hD0T, hD0⟩,
  rcases hasT (finset.mem_insert_self a s) with ⟨n, hn, d, hd, hd0, hnd⟩,
  use D0 * d,
  split, exact mul_ne_zero hD00 hd0,
  split, exact is_submonoid.mul_mem hD0T hd,
  intros k hk,
  rw finset.mem_insert at hk,
  cases hk,
  { rw hk,
    rw mul_assoc,
    apply is_submonoid.mul_mem hD0T,
    convert hn,
    rw ←hnd,
    exact mul_div_cancel' n hd0,
  },
  rw [mul_assoc, mul_left_comm],
  exact is_submonoid.mul_mem hd (hD0 k hk),
end

universes u

open set algebra

lemma algebra.adjoin_eq_closure (R : Type*) [comm_ring R] {A : Type*} [ring A]
  [algebra R A] (s : set A) :
  (↑(adjoin R s) : set A) = ring.closure (set.range (algebra_map A : R → A) ∪ s) := rfl

/-
We formalise the proof in "A note on Zariski's Lemma" by John McCabe,
AMM Vol 83 No 7.
-/

-- needed to get [algebra R K] from (R : subalgebra k K) in next proof
set_option class.instance_max_depth 38

-- We start with the following lemma.
lemma not_fin_dim_of_fin_gen_alg_of_nonintegral
  -- Let k be a field
  (k : Type*) [discrete_field k] (K : Type*) [discrete_field K]
  -- and let K be a field which is generated as a k-algebra
  -- by the finite set S ⊆ K
  [algebra k K] (S : finset K) (hSgen : adjoin k (↑S : set K) = ⊤)
  -- Say s ∈ S is transcendental over k
  (s : K) (hs : s ∈ S) (hsnonint : ¬ is_integral k s)
  -- Then
  :
  --  K/k(s) can't be finite-dimensional
  ¬ (finite_dimensional (field.closure (range (algebra_map K : k → K) ∪ {s})) K)
  :=
begin
  /-
  The argument to prove this in Atiyah--Macdonald uses the Artin-Tate lemma.
  I won't formalise this but I'll leave it here for reference.
  Assume K is finite-dimensional over L := k(s).
  Choose a basis y₁, y₂, … yₘ.
  We can write each sᵢ∈S as sᵢ=∑ⱼ aᵢⱼyⱼ
  and we can write each yᵢyⱼ as Σₖ bᵢⱼₖ yₖ with the a's and b's in L.
  If R is the k-algebra generated by the aᵢⱼ and the bᵢⱼₖ then
  any polynomial in the sᵢ with coefficients in k is easily checked to
  be an R-linear combination of the yₖ, and in particular K is a finite R-module.
  Because R is Noetherian we have that K is a Noetherian R-module, and hence
  its submodule L is a Noetherian R-module. Because R is a finitely-generated
  k-algebra this means that L is also a finitely-generated k-algebra.
  But L=k(s) is not finitely-generated, because consider 1/(d₁d₂…dₙ+1)
  where the dᵢ are the denominators of a finite set of generators

  A shorter to formalise argument is found in "A note on Zariski's Lemma"
  by John McCabe, AMM Vol 83 No 7. I'll formalise this instead.
  -/

  -- Assume K/L is finite-dimensional
  set L := (field.closure (range (algebra_map K : k → K) ∪ {s})) with hL,
  intro hKL,
  -- Each sᵢ ∈ S is thus algebraic over L,
  have hLKi : ∀ (t : K), is_integral ↥L t,
    intro t,
    exact is_integral_of_noetherian' hKL t,
  -- so if we let X be the (finite) set of the coefficients
  -- of all the min polys of the sᵢ over L=k(s)
  set X := finset.image subtype.val (finset.bind S
    (λ t, let p := minimal_polynomial (hLKi t) in
    finset.image p.coeff (@finsupp.support ℕ _ _ p))) with hX,
  -- and if we choose D ∈ k[s] non-zero such that D*X ⊆ k[s]
  have hXfc : ↑X ⊆ field.closure (range (algebra_map K) ∪ {s}),
  { rintro x hx,
    rw finset.mem_coe at hx,
    rw [hX, finset.mem_image] at hx,
    rcases hx with ⟨⟨yv, yp⟩, hy, hyx⟩,
    rw [←hL, ←hyx],
    exact yp },
  rcases field.closure.clear_denominators hXfc
    with ⟨D, hD0, hDL, hDden⟩,
  -- then X ⊆ R := k[s][1/D]
  set R := adjoin k ({s, D⁻¹} : set K) with hR,
  have hXR : (↑X : set K) ⊆ ↑R,
  { intros x hx,
    replace hDden := hDden x hx,
    rw hR,
    rw algebra.adjoin_eq_closure,
    have htemp : x = D⁻¹ * (D * x),
      field_simp [hD0], ring,
    rw htemp,
    apply is_submonoid.mul_mem,
    { apply ring.mem_closure,
      right, left, refl,
    },
    refine ring.closure_mono _ hDden,
    simp,
  },
  -- so each sᵢ is integral over R := k[s][1/D].
  have hSint : ∀ t ∈ S, is_integral R t,
  { intros t ht,
    set f := minimal_polynomial (hLKi t) with hf,
    have Hf : finset.image subtype.val (finset.image (polynomial.coeff f) f.support) ⊆ X,
    { rw hX,
      apply finset.image_mono,
      intros x hx,
      rw finset.mem_bind,
      use t, use ht,
      rw hf at hx, exact hx},

    sorry
  },

  -- TODO
  -- Hence K=k[S] is integral over k[s][1/D].
  -- This means k[s][1/D] is a field (a standard trick; a non-zero element of k[s][1/D]
  -- has an inverse in K, which is integral over k[s][1/D] and now multiply up
  -- and expand out), which can't happen (it implies
  -- that D is in every maximal ideal of k[s] and hence 1+D is in
  -- none of them, thus 1+D is in k, so D is too, contradiction)

  sorry
end

#check finsupp
#check polynomial
#check ring.closure
#check is_subring
#exit
def XXX (A : Type*) [comm_ring A] (C : Type*) [comm_ring C] [algebra A C]
  (B : subalgebra A C) : algebra B C := by apply_instance

#print XXX
#check @subalgebra.to_algebra
/-
subalgebra.to_algebra :
  Π (R : Type u_1) (A : Type u_2) [_inst_4 : comm_ring R] [_inst_5 : comm_ring A] [_inst_6 : algebra R A]
  (S : subalgebra R A), algebra ↥S A
  -/
  /-

1 goal
L : set K := field.closure (range (algebra_map K) ∪ {s}),
hL : L = field.closure (range (algebra_map K) ∪ {s}),
hKL : finite_dimensional ↥L K
⊢ false
-/

instance Zariski's_lemma
  -- let k be a field
  (k : Type u) [discrete_field k]
  -- and let k ⊆ K be another field (note: I seem to need that it's in the same universe)
  (K : Type u) [discrete_field K] [algebra k K]
  -- Assume that there's a finite subset S of K
  (S : finset K)
  -- which generates K as a k-algebra
  -- (note: `⊤` is "the largest k-subalgebra of K", i.e., K)
  (hsgen : adjoin k (↑S : set K) = ⊤)
  -- Then
  :
  -- K is finite-dimensional as a k-vector space
  finite_dimensional k K
:=
begin
  -- I will show that if K is a field and S is a finite subset,
  -- then for all subfields k of K, if K=k(S) then K is finite-dimensional
  -- as a k-vector space.
  unfreezeI, revert S k,
  -- We'll do it by induction on the size of S,
  intro S, apply finset.strong_induction_on S, clear S, intros S IH,
  intros k hk hka, letI := hk, letI := hka,
  intro hSgen,
  -- Let's deal first with the case where all the elements of S are algebraic
  -- over k
  by_cases h_int : ∀ s ∈ S, is_integral k s,
  -- In this case, the result is standard, because K is finitely-generated
  -- and algebraic over k, so it's module-finite (use the
  -- tower law and induction)
  { convert fg_adjoin_of_finite (finset.finite_to_set S) h_int,
    rw hSgen,
    rw finite_dimensional.iff_fg,
    apply congr_arg,
    convert (subalgebra.coe_submodule_top k K).symm,
  },
  -- The remaining case is where S contains an element transcendental over k.
  push_neg at h_int,
  rcases h_int with ⟨s, hs, hsnonint⟩,
  -- We prove that this cannot happen.
  exfalso,
  -- Let L:=k(s) be the subfield of K generated by k and s.
  set L := field.closure ((set.range (algebra_map K : k → K)) ∪ {s}) with hL,
  -- then K = L(S - {s})
  -- and |S - {s}| < |S|, so by induction, K is finite-dimensional over L,
  have hKL : finite_dimensional L K,
  { refine IH (S.erase s) (finset.erase_ssubset hs) ↥L _,
    -- NB this is a proof that k(S)=L(S - {s})
    rw algebra.eq_top_iff at ⊢ hSgen,
    intro x, replace hSgen := hSgen x,
    rw ←subalgebra.mem_coe at ⊢ hSgen,
    revert hSgen x,
    show ring.closure (range (algebra_map K) ∪ ↑S) ≤
    ring.closure (range (algebra_map K) ∪ ↑(S.erase s)),
    apply ring.closure_subset,
    apply union_subset,
    { refine subset.trans _ ring.subset_closure,
      refine subset.trans _ (subset_union_left _ _),
      rintro x ⟨x0, hx0⟩,
      suffices hx : x ∈ L,
      { use ⟨x, hx⟩,
        refl,
      },
      rw hL,
      apply field.subset_closure,
      apply subset_union_left _ _,
      use x0,
      exact hx0
    },
    { refine subset.trans _ ring.subset_closure,
      intros t ht,
      by_cases hst : t = s,
      { apply subset_union_left,
        cases hst, clear hst,
        suffices hsL : s ∈ L,
          use ⟨s, hsL⟩,
          refl,
        rw hL,
        apply field.subset_closure,
        apply subset_union_right _ _,
        apply mem_singleton
      },
      { apply subset_union_right _ _,
        exact finset.mem_erase_of_ne_of_mem hst ht,
      }
    }
  },

  convert not_fin_dim_of_fin_gen_alg_of_nonintegral k K S hSgen s hs hsnonint hKL, refl,

end


import syntax.syntax data.set.basic
local attribute [instance] classical.prop_decidable

open  Kproof

---------------------- Helper Lemmas ----------------------

-- A → A
lemma iden {Γ : ctx} {A : form} :
   Kproof Γ (A ⊃ A) :=
begin
exact mp (mp (@pl2 _ A (A ⊃ A) A) pl1) pl1
end

-- ⊤ is always provable
lemma prtrue {Γ : ctx} :  Kproof Γ ⊤ := iden

lemma weak {Γ : ctx} {A B : form} :
   Kproof Γ A →  Kproof (Γ ∪ B) A :=
begin
intro h,
induction h,
{apply ax, exact (set.mem_insert_of_mem _ h_h)},
{exact pl1},
{exact pl2},
{exact pl3},
{exact pl4},
{exact pl5},
{exact pl6},
{exact pl7},
{exact kdist},
{apply mp,
  {exact h_ih_hpq},
  {exact h_ih_hp}},
{exact nec h_ih }
end

-- We are able to prove axioms
lemma pr {Γ : ctx} {A : form} :
   Kproof (Γ ∪ A) A :=
begin
apply ax;
apply or.intro_left;
simp
end

-- The cut rule,
lemma cut {Γ : ctx} {A B C : form} :
   Kproof Γ (A ⊃ B) →  Kproof Γ (B ⊃ C) →  Kproof Γ (A ⊃ C) :=
begin
intros h1 h2,
exact mp (mp pl2 (mp pl1 h2)) h1
end

lemma conv_deduction {Γ : ctx} {A B : form} :
   Kproof Γ (A ⊃ B) →  Kproof (Γ ∪ A) B :=
begin
intro h,
exact mp (weak h) pr
end

-- The following build up to double negation

lemma hs1 {Γ : ctx} {A B C : form} :
   Kproof Γ ((B ⊃ C) ⊃ ((A ⊃ B) ⊃ (A ⊃ C))) :=
begin
exact (mp (mp pl2 (mp pl1 pl2)) pl1)
end

lemma likemp {Γ : ctx} {A B : form} :
   Kproof Γ (A ⊃ ((A ⊃ B) ⊃ B)) :=
begin
exact (mp (mp hs1 (mp pl2 iden)) pl1)
end

lemma dne {Γ : ctx} {A : form} :
 Kproof Γ ((¬¬A) ⊃ A) :=
begin
have h1 :  Kproof Γ (A ⊃ (A ⊃ A)), from pl1,
exact (cut (cut pl1 (cut pl7 pl7)) (mp likemp h1))
end

lemma dni {Γ : ctx} {A : form} :  Kproof Γ (A ⊃ ¬¬A) :=
begin
exact mp pl7 dne
end

lemma imp_if_imp_imp {Γ : ctx} {A B C : form} :  Kproof Γ (A ⊃ C) →  Kproof Γ (A ⊃ (B ⊃ C)) :=
begin
intro h1,
exact mp (mp pl2 (mp pl1 pl1)) h1
end

lemma cut1 {Γ : ctx} {A B C θ : form} :
   Kproof Γ (θ ⊃ (A ⊃ B)) →  Kproof Γ (B ⊃ C) →  Kproof Γ (θ ⊃ (A ⊃ C)) :=
begin
intros h1 h2,
exact cut h1 (mp pl2 (mp pl1 h2))
end

lemma imp_switch {Γ : ctx} {A B C : form} :  Kproof Γ (A ⊃ (B ⊃ C)) →  Kproof Γ (B ⊃ (A ⊃ C)) :=
begin
intro h1,
exact mp (mp pl2 (mp pl1 (mp pl2 h1))) pl1
end

lemma l2 {Γ : ctx} {A B C : form} :  Kproof Γ ((A ⊃ (B ⊃ C)) ⊃ (B ⊃ (A ⊃ C))) :=
begin
exact (mp (mp pl2 (cut pl2 hs1)) (mp pl1 pl1))
end

lemma hs2 {Γ : ctx} {A B C : form} :
   Kproof Γ ((A ⊃ B) ⊃ ((B ⊃ C) ⊃ (A ⊃ C))) :=
begin
exact (mp l2 hs1)
end

lemma cut2 {Γ : ctx} {A B C θ : form} :
   Kproof Γ (A ⊃ B) →  Kproof Γ (θ ⊃ (B ⊃ C)) →  Kproof Γ (θ ⊃ (A ⊃ C)) :=
begin
intros h1 h2,
exact imp_switch (cut h1 (imp_switch h2))
end

lemma double_imp {Γ : ctx} {A B : form} :
   Kproof Γ ((A ⊃ (A ⊃ B)) ⊃ (A ⊃ B)) :=
begin
exact mp pl2 (imp_switch iden)
end

lemma imp_imp_iff_imp {Γ : ctx} {θ A B : form} :
   Kproof Γ (θ ⊃ (A ⊃ (A ⊃ B))) ↔  Kproof Γ (θ ⊃ (A ⊃ B)) :=
begin
split,
{intro h1,
exact cut h1 double_imp},
{intro h1,
exact cut h1 pl1}
end

lemma imp_shift {Γ : ctx} {θ A B C : form} :
   Kproof Γ (θ ⊃ (A ⊃ (B ⊃ C))) ↔  Kproof Γ (θ ⊃ (B ⊃ (A ⊃ C))) :=
begin
split,
repeat {intro h1, exact cut h1 (cut2 pl1 pl2)}
end

lemma left_and_imp {Γ : ctx} {A B C : form} :
   Kproof Γ (B ⊃ ((A & B) ⊃ C)) →  Kproof Γ ((A & B) ⊃ C) :=
begin
intro h1,
exact mp double_imp (cut pl6 h1)
end

lemma and_right_imp {Γ : ctx} {A B C : form} :
   Kproof Γ ((A & B) ⊃ C) ↔  Kproof Γ (B ⊃ (A ⊃ C)) :=
begin
split,
{intro h1,
exact mp (cut2 pl1 pl2) (cut1 pl4 h1)},
intro h1,
exact left_and_imp (cut2 pl5 h1)
end

lemma not_and_subst {A B C : form} {Γ : ctx} :
   Kproof Γ (A ↔ B) → ( Kproof Γ ¬(C & A) ↔  Kproof Γ ¬(C & B)) :=
begin
intro h1, split,
{intro h2,
exact mp (mp pl3 (mp pl1 h2)) (cut dne (mp double_imp (cut2 (cut pl6 (mp pl6 h1))
  (cut pl5 pl4))))},
{intro h2,
exact mp (mp pl3 (mp pl1 h2)) (cut dne (mp double_imp (cut2 (cut pl6 (mp pl5 h1))
  (cut pl5 pl4))))},
end

lemma not_contra {Γ : ctx} {A : form} :
   Kproof Γ ¬(A & ¬A) :=
begin
exact mp (mp pl3 (cut dne pl6)) (cut dne pl5)
end

lemma phi_and_true {Γ : ctx} {A : form} :  Kproof Γ ((A&¬⊥) ↔ A) :=
begin
exact (mp (mp pl4 pl5) (mp (imp_switch pl4) prtrue))
end

lemma imp_and_and_imp {Γ : ctx} {A B C θ : form} :
   Kproof Γ (((A ⊃ B) & (C ⊃ θ))) →  Kproof Γ (((A & C) ⊃ (B & θ))) :=
begin
intro h,
exact (mp double_imp (cut (cut pl5 (mp pl5 h)) (cut2 (cut pl6 (mp pl6 h)) pl4)))
end

lemma not_contra_equiv_true {Γ : ctx} {A : form} :
   Kproof Γ (¬(A & ¬A) ↔ ⊤) :=
begin
exact (mp (mp pl4 (mp pl1 prtrue)) (mp pl1 not_contra))
end

lemma contrapos {Γ : ctx} {A B : form} :
   Kproof Γ ((¬B) ⊃ (¬A)) ↔  Kproof Γ (A ⊃ B) :=
begin
split,
intro h1,
exact mp pl7 h1,
intro h1,
exact mp (cut (cut (mp hs1 dni) (mp hs2 dne)) pl7) h1,
end

lemma iff_not {Γ : ctx} {A B : form} :
   Kproof Γ (A ↔ B) →  Kproof Γ (¬B ↔ ¬A) :=
begin
intro h1,
have h2 :  Kproof Γ (A ⊃ B), from mp pl5 h1,
have h3 :  Kproof Γ (B ⊃ A), from mp pl6 h1,
rw ←contrapos at h2,
rw ←contrapos at h3,
exact (mp (mp pl4 h2) h3)
end

lemma contra_equiv_false {Γ : ctx} {A : form} :
   Kproof Γ ((A & ¬A) ↔ ⊥) :=
begin
have h1 := iff_not not_contra_equiv_true,
exact (mp (mp pl4 (cut dni (cut (mp pl6 h1) dne))) (cut dni (cut (mp pl5 h1) dne)))
end

lemma and_switch {Γ : ctx} {A B : form} :  Kproof Γ ((A & B) ↔ (B & A)) :=
begin
exact (mp (mp pl4 (mp double_imp (cut pl5 (imp_switch (cut pl6 pl4)))))
(mp double_imp (cut pl5 (imp_switch (cut pl6 pl4)))))
end

lemma and_commute {Γ : ctx} {A B C : form} :  Kproof Γ (((A & B) & C) ↔ (A & (B & C))) :=
begin
exact mp (mp pl4 (mp double_imp (imp_imp_iff_imp.mp
  (cut (cut pl5 pl6) (cut2 pl6 (cut1 pl4 (imp_switch (cut (cut pl5 pl5) pl4))))))))
  (mp double_imp (imp_imp_iff_imp.mp (cut (cut pl6 pl5)
  (imp_switch (cut pl5 (cut1 pl4 (cut2 (cut pl6 pl6) pl4)))))))
end

lemma imp_and_imp {Γ : ctx} {A B C : form} :
   Kproof Γ (A ⊃ B) →  Kproof Γ ((C & A) ⊃ (C & B)) :=
begin
intros h1,
exact imp_and_and_imp (mp (mp pl4 iden) h1)
end

lemma demorgans {Γ : ctx} {A B : form} :  Kproof Γ (¬(A & B)) ↔  Kproof Γ (A ⊃ ¬B) :=
begin
split,
intro h1,
exact (and_right_imp.mp (mp (contrapos.mpr (mp pl5 and_switch)) h1)),
intro h1,
exact (mp (contrapos.mpr (mp pl5 and_switch)) (and_right_imp.mpr h1))
end

lemma explosion {Γ : ctx} {B : form} :  Kproof Γ (⊥ ⊃ B) :=
begin
apply contrapos.mp, exact (mp pl1 iden)
end

lemma exfalso {Γ : ctx} {A B : form} :  Kproof Γ ((A & ¬A) ⊃ B) :=
begin
exact cut not_contra explosion
end

lemma box_dn {Γ : ctx} {A : form} :  Kproof Γ ((¬□A) ↔ ¬(□(¬¬A))) :=
begin
exact mp (mp pl4 (contrapos.mpr (mp kdist (nec dne)))) (contrapos.mpr (mp kdist (nec dni)))
end

-- The following are known as dual formulas encode how □ ≃ ¬◇¬ and ◇ ≃ ¬□¬

lemma dual_equiv1 {Γ : ctx} {A : form} :  Kproof Γ ((□A) ↔ (¬(◇(¬A)))) :=
begin
exact mp (mp pl4 (cut (contrapos.mp (mp pl6 box_dn)) dni))
  (cut dne (contrapos.mp (mp pl5 box_dn)))
end

lemma dual_equiv2 {Γ : ctx} {A : form} :  Kproof Γ ((¬(□¬A)) ↔ (◇A)) :=
begin
exact mp (mp pl4 iden) iden,
end


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/
import data.nat.basic

/-!
# Lists as Functions

Definitions for using lists as finite representations of finitely-supported functions with domain
ℕ.

These include pointwise operations on lists, as well as get and set operations.

## Notations

An index notation is introduced in this file for setting a particular element of a list. With `as`
as a list `m` as an index, and `a` as a new element, the notation is `as {m ↦ a}`.

So, for example
`[1, 3, 5] {1 ↦ 9}` would result in `[1, 9, 5]`

This notation is in the locale `list.func`.
-/

open list

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

namespace list
namespace func

variables {a : α}
variables {as as1 as2 as3 : list α}

/-- Elementwise negation of a list -/
def neg [has_neg α] (as : list α) := as.map (λ a, -a)

variables [inhabited α] [inhabited β]

/--
Update element of a list by index. If the index is out of range, extend the list with default
elements
-/
@[simp] def set (a : α) : list α → ℕ → list α
| (_::as) 0     := a::as
| []      0     := [a]
| (h::as) (k+1) := h::(set as k)
| []      (k+1) := default::(set ([] : list α) k)

localized "notation as ` {` m ` ↦ ` a `}` := list.func.set a as m" in list.func

/-- Get element of a list by index. If the index is out of range, return the default element -/
@[simp] def get : ℕ → list α → α
| _ []          := default
| 0 (a::as)     := a
| (n+1) (a::as) := get n as

/--
Pointwise equality of lists. If lists are different lengths, compare with the default
element.
-/
def equiv (as1 as2 : list α) : Prop :=
∀ (m : nat), get m as1 = get m as2

/-- Pointwise operations on lists. If lists are different lengths, use the default element. -/
@[simp] def pointwise (f : α → β → γ) : list α → list β → list γ
| []      []      := []
| []      (b::bs) := map (f default) (b::bs)
| (a::as) []      := map (λ x, f x default) (a::as)
| (a::as) (b::bs) := (f a b)::(pointwise as bs)

/-- Pointwise addition on lists. If lists are different lengths, use zero. -/
def add {α : Type u} [has_zero α] [has_add α] : list α → list α → list α :=
@pointwise α α α ⟨0⟩ ⟨0⟩ (+)

/-- Pointwise subtraction on lists. If lists are different lengths, use zero. -/
def sub {α : Type u} [has_zero α] [has_sub α] : list α → list α → list α :=
@pointwise α α α ⟨0⟩ ⟨0⟩ (@has_sub.sub α _)

/- set -/

lemma length_set : ∀ {m : ℕ} {as : list α},
  (as {m ↦ a}).length = max as.length (m+1)
| 0 []          := rfl
| 0 (a::as)     := by {rw max_eq_left, refl, simp [nat.le_add_right]}
| (m+1) []      := by simp only [set, nat.zero_max, length, @length_set m]
| (m+1) (a::as) := by simp only [set, nat.max_succ_succ, length, @length_set m]

@[simp] lemma get_nil {k : ℕ} : (get k [] : α) = default :=
by {cases k; refl}

lemma get_eq_default_of_le :
  ∀ (k : ℕ) {as : list α}, as.length ≤ k → get k as = default
| 0     []      h1 := rfl
| 0     (a::as) h1 := by cases h1
| (k+1) []      h1 := rfl
| (k+1) (a::as) h1 :=
  begin
    apply get_eq_default_of_le k,
    rw ← nat.succ_le_succ_iff, apply h1,
  end

@[simp] lemma get_set {a : α} :
  ∀ {k : ℕ} {as : list α}, get k (as {k ↦ a}) = a
| 0 as     := by {cases as; refl, }
| (k+1) as := by {cases as; simp [get_set]}

lemma eq_get_of_mem {a : α} :
  ∀ {as : list α}, a ∈ as → ∃ n : nat, ∀ d : α, a = (get n as)
| [] h := by cases h
| (b::as) h :=
  begin
    rw mem_cons_iff at h, cases h,
    { existsi 0, intro d, apply h },
    { cases eq_get_of_mem h with n h2,
      existsi (n+1), apply h2 }
  end

lemma mem_get_of_le :
  ∀ {n : ℕ} {as : list α}, n < as.length → get n as ∈ as
| _ [] h1 := by cases h1
| 0 (a::as) _ := or.inl rfl
| (n+1) (a::as) h1 :=
  begin
    apply or.inr, unfold get,
    apply mem_get_of_le,
    apply nat.lt_of_succ_lt_succ h1,
  end

lemma mem_get_of_ne_zero :
  ∀ {n : ℕ} {as : list α},
  get n as ≠ default → get n as ∈ as
| _ [] h1 := begin exfalso, apply h1, rw get_nil end
| 0 (a::as) h1 := or.inl rfl
| (n+1) (a::as) h1 :=
  begin
    unfold get,
    apply (or.inr (mem_get_of_ne_zero _)),
    apply h1
  end

lemma get_set_eq_of_ne {a : α} :
  ∀ {as : list α} (k : ℕ) (m : ℕ),
  m ≠ k → get m (as {k ↦ a}) = get m as
| as 0 m h1 :=
  by { cases m, contradiction, cases as;
       simp only [set, get, get_nil] }
| as (k+1) m h1 :=
  begin
    cases as; cases m,
    simp only [set, get],
    { have h3 : get m (nil {k ↦ a}) = default,
      { rw [get_set_eq_of_ne k m, get_nil],
        intro hc, apply h1, simp [hc] },
      apply h3 },
    simp only [set, get],
    { apply get_set_eq_of_ne k m,
      intro hc, apply h1, simp [hc], }
  end

lemma get_map {f : α → β} : ∀ {n : ℕ} {as : list α}, n < as.length →
  get n (as.map f) = f (get n as)
| _ [] h := by cases h
| 0 (a::as) h := rfl
| (n+1) (a::as) h1 :=
  begin
    have h2 : n < length as,
    { rw [← nat.succ_le_iff, ← nat.lt_succ_iff],
      apply h1 },
    apply get_map h2,
  end

lemma get_map' {f : α → β} {n : ℕ} {as : list α} :
  f default = default →
  get n (as.map f) = f (get n as) :=
begin
  intro h1, by_cases h2 : n < as.length,
  { apply get_map h2, },
  { rw not_lt at h2,
    rw [get_eq_default_of_le _ h2, get_eq_default_of_le, h1],
    rw [length_map], apply h2 }
end

lemma forall_val_of_forall_mem {as : list α} {p : α → Prop} :
  p default → (∀ x ∈ as, p x) → (∀ n, p (get n as)) :=
begin
  intros h1 h2 n,
  by_cases h3 : n < as.length,
  { apply h2 _ (mem_get_of_le h3) },
  { rw not_lt at h3,
    rw get_eq_default_of_le _ h3, apply h1 }
end

/- equiv -/

lemma equiv_refl : equiv as as := λ k, rfl

lemma equiv_symm : equiv as1 as2 → equiv as2 as1 :=
λ h1 k, (h1 k).symm

lemma equiv_trans :
  equiv as1 as2 → equiv as2 as3 → equiv as1 as3 :=
λ h1 h2 k, eq.trans (h1 k) (h2 k)

lemma equiv_of_eq : as1 = as2 → equiv as1 as2 :=
begin intro h1, rw h1, apply equiv_refl end

lemma eq_of_equiv : ∀ {as1 as2 : list α}, as1.length = as2.length →
  equiv as1 as2 → as1 = as2
| []     [] h1 h2 := rfl
| (_::_) [] h1 h2 := by cases h1
| [] (_::_) h1 h2 := by cases h1
| (a1::as1) (a2::as2) h1 h2 :=
  begin
    congr,
    { apply h2 0 },
    have h3 : as1.length = as2.length,
    { simpa [add_left_inj, add_comm, length] using h1 },
    apply eq_of_equiv h3,
    intro m, apply h2 (m+1)
  end

end func
-- We want to drop the `inhabited` instances for a moment,
-- so we close and open the namespace

namespace func

/- neg -/

@[simp] lemma get_neg [add_group α] {k : ℕ} {as : list α} :
  @get α ⟨0⟩ k (neg as) = -(@get α ⟨0⟩ k as) :=
by {unfold neg, rw (@get_map' α α ⟨0⟩), apply neg_zero}

@[simp] lemma length_neg [has_neg α] (as : list α) : (neg as).length = as.length :=
by simp only [neg, length_map]

variables [inhabited α] [inhabited β]

/- pointwise -/

lemma nil_pointwise {f : α → β → γ} : ∀ bs : list β, pointwise f [] bs = bs.map (f default)
| []      := rfl
| (b::bs) :=
  by simp only [nil_pointwise bs, pointwise,
     eq_self_iff_true, and_self, map]

lemma pointwise_nil {f : α → β → γ} :
  ∀ as : list α, pointwise f as [] = as.map (λ a, f a default)
| []      := rfl
| (a::as) :=
  by simp only [pointwise_nil as, pointwise,
     eq_self_iff_true, and_self, list.map]

lemma get_pointwise [inhabited γ] {f : α → β → γ} (h1 : f default default = default) :
  ∀ (k : nat) (as : list α) (bs : list β),
  get k (pointwise f as bs) = f (get k as) (get k bs)
| k [] [] := by simp only [h1, get_nil, pointwise, get]
| 0 [] (b::bs) :=
  by simp only [get_pointwise, get_nil,
      pointwise, get, nat.nat_zero_eq_zero, map]
| (k+1) [] (b::bs) :=
  by { have : get k (map (f default) bs) = f default (get k bs),
       { simpa [nil_pointwise, get_nil] using (get_pointwise k [] bs) },
       simpa [get, get_nil, pointwise, map] }
| 0 (a::as) [] :=
  by simp only [get_pointwise, get_nil,
     pointwise, get, nat.nat_zero_eq_zero, map]
| (k+1) (a::as) [] :=
  by simpa [get, get_nil, pointwise, map, pointwise_nil, get_nil]
     using get_pointwise k as []
| 0 (a::as) (b::bs) := by simp only [pointwise, get]
| (k+1) (a::as) (b::bs) :=
  by simp only [pointwise, get, get_pointwise k]

lemma length_pointwise {f : α → β → γ} :
  ∀ {as : list α} {bs : list β},
  (pointwise f as bs).length = max as.length bs.length
| []      []      := rfl
| []      (b::bs) :=
  by simp only [pointwise, length, length_map,
     max_eq_right (nat.zero_le (length bs + 1))]
| (a::as) []      :=
  by simp only [pointwise, length, length_map,
     max_eq_left (nat.zero_le (length as + 1))]
| (a::as) (b::bs) :=
  by simp only [pointwise, length,
     nat.max_succ_succ, @length_pointwise as bs]

end func

namespace func
/- add -/

@[simp] lemma get_add {α : Type u} [add_monoid α] {k : ℕ} {xs ys : list α} :
  @get α ⟨0⟩ k (add xs ys) = ( @get α ⟨0⟩ k xs + @get α ⟨0⟩ k ys) :=
by {apply get_pointwise, apply zero_add}

@[simp] lemma length_add {α : Type u}
  [has_zero α] [has_add α] {xs ys : list α} :
  (add xs ys).length = max xs.length ys.length :=
@length_pointwise α α α ⟨0⟩ ⟨0⟩ _ _ _

@[simp]

@[simp] lemma add_nil {α : Type u} [add_monoid α]
  (as : list α) : add as [] = as :=
begin
  rw [add, @pointwise_nil α α α ⟨0⟩ ⟨0⟩],
  apply eq.trans _ (map_id as),
  congr' with x,
  rw [add_zero, id]
end

lemma map_add_map {α : Type u} [add_monoid α] (f g : α → α) {as : list α} :
  add (as.map f) (as.map g) = as.map (λ x, f x + g x) :=
begin
  apply @eq_of_equiv _ (⟨0⟩ : inhabited α),
  { rw [length_map, length_add, max_eq_left, length_map],
    apply le_of_eq,
    rw [length_map, length_map] },
  intros m,
  rw [get_add],
  by_cases h : m < length as,
  { repeat {rw [@get_map α α ⟨0⟩ ⟨0⟩ _ _ _ h]} },
  rw not_lt at h,
  repeat {rw [get_eq_default_of_le m]};
  try {rw length_map, apply h},
  apply zero_add
end

/- sub -/

@[simp] lemma get_sub {α : Type u}
  [add_group α] {k : ℕ} {xs ys : list α} :
  @get α ⟨0⟩ k (sub xs ys) = (@get α ⟨0⟩ k xs - @get α ⟨0⟩ k ys) :=
by {apply get_pointwise, apply sub_zero}

@[simp] lemma length_sub [has_zero α] [has_sub α] {xs ys : list α} :
  (sub xs ys).length = max xs.length ys.length :=
@length_pointwise α α α ⟨0⟩ ⟨0⟩ _ _ _

@[simp] lemma nil_sub {α : Type} [add_group α]
  (as : list α) : sub [] as = neg as :=
begin
  rw [sub, nil_pointwise],
  congr' with x,
  rw [zero_sub]
end

@[simp] lemma sub_nil {α : Type} [add_group α]
  (as : list α) : sub as [] = as :=
begin
  rw [sub, pointwise_nil],
  apply eq.trans _ (map_id as),
  congr' with x,
  rw [sub_zero, id]
end

end func
end list


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

! This file was ported from Lean 3 source module topology.sets.closeds
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Sets.Opens

/-!
# Closed sets

We define a few types of closed sets in a topological space.

## Main Definitions

For a topological space `α`,
* `TopologicalSpace.Closeds α`: The type of closed sets.
* `TopologicalSpace.Clopens α`: The type of clopen sets.
-/

open Order OrderDual Set

variable {ι α β : Type _} [TopologicalSpace α] [TopologicalSpace β]

namespace TopologicalSpace

/-! ### Closed sets -/

/-- The type of closed subsets of a topological space. -/
structure Closeds (α : Type _) [TopologicalSpace α] where
  carrier : Set α
  closed' : IsClosed carrier
#align topological_space.closeds TopologicalSpace.Closeds

namespace Closeds

instance : SetLike (Closeds α) α where
  coe := Closeds.carrier
  coe_injective' s t h := by cases s; cases t; congr

instance : CanLift (Set α) (Closeds α) (↑) IsClosed where
  prf s hs := ⟨⟨s, hs⟩, rfl⟩

theorem closed (s : Closeds α) : IsClosed (s : Set α) :=
  s.closed'
#align topological_space.closeds.closed TopologicalSpace.Closeds.closed

/-- See Note [custom simps projection]. -/
def Simps.coe (s : Closeds α) : Set α := s

initialize_simps_projections Closeds (carrier → coe)

@[ext]
protected theorem ext {s t : Closeds α} (h : (s : Set α) = t) : s = t :=
  SetLike.ext' h
#align topological_space.closeds.ext TopologicalSpace.Closeds.ext

@[simp]
theorem coe_mk (s : Set α) (h) : (mk s h : Set α) = s :=
  rfl
#align topological_space.closeds.coe_mk TopologicalSpace.Closeds.coe_mk

/-- The closure of a set, as an element of `TopologicalSpace.Closeds`. -/
protected def closure (s : Set α) : Closeds α :=
  ⟨closure s, isClosed_closure⟩
#align topological_space.closeds.closure TopologicalSpace.Closeds.closure

theorem gc : GaloisConnection Closeds.closure ((↑) : Closeds α → Set α) := fun _ U =>
  ⟨subset_closure.trans, fun h => closure_minimal h U.closed⟩
#align topological_space.closeds.gc TopologicalSpace.Closeds.gc

/-- The galois coinsertion between sets and opens. -/
def gi : GaloisInsertion (@Closeds.closure α _) (↑) where
  choice s hs := ⟨s, closure_eq_iff_isClosed.1 <| hs.antisymm subset_closure⟩
  gc := gc
  le_l_u _ := subset_closure
  choice_eq _s hs := SetLike.coe_injective <| subset_closure.antisymm hs
#align topological_space.closeds.gi TopologicalSpace.Closeds.gi

instance : CompleteLattice (Closeds α) :=
  CompleteLattice.copy
    (GaloisInsertion.liftCompleteLattice gi)
    -- le
    _ rfl
    -- top
    ⟨univ, isClosed_univ⟩ rfl
    -- bot
    ⟨∅, isClosed_empty⟩ (SetLike.coe_injective closure_empty.symm)
    -- sup
    (fun s t => ⟨s ∪ t, s.2.union t.2⟩)
    (funext fun s => funext fun t => SetLike.coe_injective (s.2.union t.2).closure_eq.symm)
    -- inf
    (fun s t => ⟨s ∩ t, s.2.inter t.2⟩) rfl
    -- supₛ
    _ rfl
    -- infₛ
    (fun S => ⟨⋂ s ∈ S, ↑s, isClosed_binterᵢ fun s _ => s.2⟩)
    (funext fun _ => SetLike.coe_injective infₛ_image.symm)

/-- The type of closed sets is inhabited, with default element the empty set. -/
instance : Inhabited (Closeds α) :=
  ⟨⊥⟩

@[simp, norm_cast]
theorem coe_sup (s t : Closeds α) : (↑(s ⊔ t) : Set α) = ↑s ∪ ↑t :=
  rfl
#align topological_space.closeds.coe_sup TopologicalSpace.Closeds.coe_sup

@[simp, norm_cast]
theorem coe_inf (s t : Closeds α) : (↑(s ⊓ t) : Set α) = ↑s ∩ ↑t :=
  rfl
#align topological_space.closeds.coe_inf TopologicalSpace.Closeds.coe_inf

@[simp, norm_cast]
theorem coe_top : (↑(⊤ : Closeds α) : Set α) = univ :=
  rfl
#align topological_space.closeds.coe_top TopologicalSpace.Closeds.coe_top

@[simp, norm_cast] -- porting note: new
theorem coe_eq_univ {s : Closeds α} : (s : Set α) = univ ↔ s = ⊤ :=
  SetLike.coe_injective.eq_iff' rfl

@[simp, norm_cast]
theorem coe_bot : (↑(⊥ : Closeds α) : Set α) = ∅ :=
  rfl
#align topological_space.closeds.coe_bot TopologicalSpace.Closeds.coe_bot

@[simp, norm_cast] -- porting note: new
theorem coe_eq_empty {s : Closeds α} : (s : Set α) = ∅ ↔ s = ⊥ :=
  SetLike.coe_injective.eq_iff' rfl

theorem coe_nonempty {s : Closeds α} : (s : Set α).Nonempty ↔ s ≠ ⊥ :=
  nonempty_iff_ne_empty.trans coe_eq_empty.not

@[simp, norm_cast]
theorem coe_infₛ {S : Set (Closeds α)} : (↑(infₛ S) : Set α) = ⋂ i ∈ S, ↑i :=
  rfl
#align topological_space.closeds.coe_Inf TopologicalSpace.Closeds.coe_infₛ

@[simp, norm_cast]
theorem coe_finset_sup (f : ι → Closeds α) (s : Finset ι) :
    (↑(s.sup f) : Set α) = s.sup ((↑) ∘ f) :=
  map_finset_sup (⟨⟨(↑), coe_sup⟩, coe_bot⟩ : SupBotHom (Closeds α) (Set α)) _ _
#align topological_space.closeds.coe_finset_sup TopologicalSpace.Closeds.coe_finset_sup

@[simp, norm_cast]

-- porting note: Lean 3 proofs didn't work as expected, so I reordered lemmas to fix&golf the proofs

@[simp]
theorem mem_infₛ {S : Set (Closeds α)} {x : α} : x ∈ infₛ S ↔ ∀ s ∈ S, x ∈ s := mem_interᵢ₂
#align topological_space.closeds.mem_Inf TopologicalSpace.Closeds.mem_infₛ

@[simp]
theorem mem_infᵢ {ι} {x : α} {s : ι → Closeds α} : x ∈ infᵢ s ↔ ∀ i, x ∈ s i := by simp [infᵢ]
#align topological_space.closeds.mem_infi TopologicalSpace.Closeds.mem_infᵢ

@[simp, norm_cast]
theorem coe_infᵢ {ι} (s : ι → Closeds α) : ((⨅ i, s i : Closeds α) : Set α) = ⋂ i, s i := by
  ext; simp
#align topological_space.closeds.coe_infi TopologicalSpace.Closeds.coe_infᵢ

theorem infᵢ_def {ι} (s : ι → Closeds α) :
    (⨅ i, s i) = ⟨⋂ i, s i, isClosed_interᵢ fun i => (s i).2⟩ := by ext1; simp
#align topological_space.closeds.infi_def TopologicalSpace.Closeds.infᵢ_def

@[simp]
theorem infᵢ_mk {ι} (s : ι → Set α) (h : ∀ i, IsClosed (s i)) :
    (⨅ i, ⟨s i, h i⟩ : Closeds α) = ⟨⋂ i, s i, isClosed_interᵢ h⟩ :=
  infᵢ_def _
#align topological_space.closeds.infi_mk TopologicalSpace.Closeds.infᵢ_mk

instance : Coframe (Closeds α) :=
  { inferInstanceAs (CompleteLattice (Closeds α)) with
    infₛ := infₛ
    infᵢ_sup_le_sup_infₛ := fun a s =>
      (SetLike.coe_injective <| by simp only [coe_sup, coe_infᵢ, coe_infₛ, Set.union_interᵢ₂]).le }

/-- The term of `TopologicalSpace.Closeds α` corresponding to a singleton. -/
@[simps]
def singleton [T1Space α] (x : α) : Closeds α :=
  ⟨{x}, isClosed_singleton⟩
#align topological_space.closeds.singleton TopologicalSpace.Closeds.singleton

end Closeds

/-- The complement of a closed set as an open set. -/
@[simps]
def Closeds.compl (s : Closeds α) : Opens α :=
  ⟨sᶜ, s.2.isOpen_compl⟩
#align topological_space.closeds.compl TopologicalSpace.Closeds.compl

/-- The complement of an open set as a closed set. -/
@[simps]
def Opens.compl (s : Opens α) : Closeds α :=
  ⟨sᶜ, s.2.isClosed_compl⟩
#align topological_space.opens.compl TopologicalSpace.Opens.compl

nonrec theorem Closeds.compl_compl (s : Closeds α) : s.compl.compl = s :=
  Closeds.ext (compl_compl (s : Set α))
#align topological_space.closeds.compl_compl TopologicalSpace.Closeds.compl_compl

nonrec theorem Opens.compl_compl (s : Opens α) : s.compl.compl = s :=
  Opens.ext (compl_compl (s : Set α))
#align topological_space.opens.compl_compl TopologicalSpace.Opens.compl_compl

theorem Closeds.compl_bijective : Function.Bijective (@Closeds.compl α _) :=
  Function.bijective_iff_has_inverse.mpr ⟨Opens.compl, Closeds.compl_compl, Opens.compl_compl⟩
#align topological_space.closeds.compl_bijective TopologicalSpace.Closeds.compl_bijective

theorem Opens.compl_bijective : Function.Bijective (@Opens.compl α _) :=
  Function.bijective_iff_has_inverse.mpr ⟨Closeds.compl, Opens.compl_compl, Closeds.compl_compl⟩
#align topological_space.opens.compl_bijective TopologicalSpace.Opens.compl_bijective

variable (α)

/-- `TopologicalSpace.Closeds.compl` as an `OrderIso` to the order dual of
`TopologicalSpace.Opens α`. -/
@[simps]
def Closeds.complOrderIso : Closeds α ≃o (Opens α)ᵒᵈ where
  toFun := OrderDual.toDual ∘ Closeds.compl
  invFun := Opens.compl ∘ OrderDual.ofDual
  left_inv s := by simp [Closeds.compl_compl]
  right_inv s := by simp [Opens.compl_compl]
  map_rel_iff' := (@OrderDual.toDual_le_toDual (Opens α)).trans compl_subset_compl
#align topological_space.closeds.compl_order_iso TopologicalSpace.Closeds.complOrderIso

/-- `TopologicalSpace.Opens.compl` as an `OrderIso` to the order dual of
`TopologicalSpace.Closeds α`. -/
@[simps]
def Opens.complOrderIso : Opens α ≃o (Closeds α)ᵒᵈ where
  toFun := OrderDual.toDual ∘ Opens.compl
  invFun := Closeds.compl ∘ OrderDual.ofDual
  left_inv s := by simp [Opens.compl_compl]
  right_inv s := by simp [Closeds.compl_compl]
  map_rel_iff' := (@OrderDual.toDual_le_toDual (Closeds α)).trans compl_subset_compl
#align topological_space.opens.compl_order_iso TopologicalSpace.Opens.complOrderIso

variable {α}

/-- in a `T1Space`, atoms of `TopologicalSpace.Closeds α` are precisely the
`TopologicalSpace.Closeds.singleton`s.

TODO: use `minimal_nonempty_closed_eq_singleton` to show that an atom in `TopologicalSpace.Closeds`
in a T₀ space is a singleton. -/
theorem Closeds.isAtom_iff [T1Space α] {s : Closeds α} :
    IsAtom s ↔ ∃ x, s = Closeds.singleton x := by
  have : IsAtom (s : Set α) ↔ IsAtom s := by
    refine' Closeds.gi.isAtom_iff' rfl (fun t ht => _) s
    obtain ⟨x, rfl⟩ := t.isAtom_iff.mp ht
    exact closure_singleton
  simp only [← this, (s : Set α).isAtom_iff, SetLike.ext'_iff, Closeds.singleton_coe]
#align topological_space.closeds.is_atom_iff TopologicalSpace.Closeds.isAtom_iff

/-- in a `T1Space`, coatoms of `TopologicalSpace.Opens α` are precisely complements of singletons:
`(TopologicalSpace.Closeds.singleton x).compl`. -/
theorem Opens.isCoatom_iff [T1Space α] {s : Opens α} :
    IsCoatom s ↔ ∃ x, s = (Closeds.singleton x).compl := by
  rw [← s.compl_compl, ← isAtom_dual_iff_isCoatom]
  change IsAtom (Closeds.complOrderIso α s.compl) ↔ _
  simp only [(Closeds.complOrderIso α).isAtom_iff, Closeds.isAtom_iff,
    Closeds.compl_bijective.injective.eq_iff]
#align topological_space.opens.is_coatom_iff TopologicalSpace.Opens.isCoatom_iff

/-! ### Clopen sets -/

/-- The type of clopen sets of a topological space. -/
structure Clopens (α : Type _) [TopologicalSpace α] where
  carrier : Set α
  clopen' : IsClopen carrier
#align topological_space.clopens TopologicalSpace.Clopens

namespace Clopens

instance : SetLike (Clopens α) α where
  coe s := s.carrier
  coe_injective' s t h := by cases s; cases t; congr

theorem clopen (s : Clopens α) : IsClopen (s : Set α) :=
  s.clopen'
#align topological_space.clopens.clopen TopologicalSpace.Clopens.clopen

/-- See Note [custom simps projection]. -/
def Simps.coe (s : Clopens α) : Set α := s

initialize_simps_projections Clopens (carrier → coe)

/-- Reinterpret a clopen as an open. -/
@[simps]
def toOpens (s : Clopens α) : Opens α :=
  ⟨s, s.clopen.isOpen⟩
#align topological_space.clopens.to_opens TopologicalSpace.Clopens.toOpens

@[ext]
protected theorem ext {s t : Clopens α} (h : (s : Set α) = t) : s = t :=
  SetLike.ext' h
#align topological_space.clopens.ext TopologicalSpace.Clopens.ext

@[simp]
theorem coe_mk (s : Set α) (h) : (mk s h : Set α) = s :=
  rfl
#align topological_space.clopens.coe_mk TopologicalSpace.Clopens.coe_mk

instance : Sup (Clopens α) := ⟨fun s t => ⟨s ∪ t, s.clopen.union t.clopen⟩⟩
instance : Inf (Clopens α) := ⟨fun s t => ⟨s ∩ t, s.clopen.inter t.clopen⟩⟩
instance : Top (Clopens α) := ⟨⟨⊤, isClopen_univ⟩⟩
instance : Bot (Clopens α) := ⟨⟨⊥, isClopen_empty⟩⟩
instance : SDiff (Clopens α) := ⟨fun s t => ⟨s \ t, s.clopen.diff t.clopen⟩⟩
instance : HasCompl (Clopens α) := ⟨fun s => ⟨sᶜ, s.clopen.compl⟩⟩

instance : BooleanAlgebra (Clopens α) :=
  SetLike.coe_injective.booleanAlgebra _ (fun _ _ => rfl) (fun _ _ => rfl) rfl rfl (fun _ => rfl)
    fun _ _ => rfl

@[simp] theorem coe_sup (s t : Clopens α) : (↑(s ⊔ t) : Set α) = ↑s ∪ ↑t := rfl
#align topological_space.clopens.coe_sup TopologicalSpace.Clopens.coe_sup

@[simp] theorem coe_inf (s t : Clopens α) : (↑(s ⊓ t) : Set α) = ↑s ∩ ↑t := rfl
#align topological_space.clopens.coe_inf TopologicalSpace.Clopens.coe_inf

@[simp] theorem coe_top : (↑(⊤ : Clopens α) : Set α) = univ := rfl
#align topological_space.clopens.coe_top TopologicalSpace.Clopens.coe_top

@[simp] theorem coe_bot : (↑(⊥ : Clopens α) : Set α) = ∅ := rfl
#align topological_space.clopens.coe_bot TopologicalSpace.Clopens.coe_bot

@[simp] theorem coe_sdiff (s t : Clopens α) : (↑(s \ t) : Set α) = ↑s \ ↑t := rfl
#align topological_space.clopens.coe_sdiff TopologicalSpace.Clopens.coe_sdiff

@[simp] theorem coe_compl (s : Clopens α) : (↑(sᶜ) : Set α) = ↑sᶜ := rfl
#align topological_space.clopens.coe_compl TopologicalSpace.Clopens.coe_compl

instance : Inhabited (Clopens α) := ⟨⊥⟩

end Clopens

end TopologicalSpace


open String (length)
open List (reverse tail! head!)

/-- Split a list by a delimiter where the delimiter is a member of the list -/
def split {α : Type} [DecidableEq α] (cs: List α) (delim: α) : List (List α) :=
  loop [] [] cs
  where
    loop : List (List α) -> List α -> List α -> List (List α)
      | acc, cur, [] => acc ++ [cur]
      | acc, cur, (x::xs) =>
        if x = delim
        then loop (acc ++ [cur]) [] xs
        else loop acc (cur ++ [x]) xs

/-- Splits a list by a sequence of elements of the list.
    * `splitOn` [1,2,0,0,3,0,0,4,5,6] [0,0] = [[1,2],[3],[4,5,6]]
-/
def splitOn {α : Type} [BEq α] (lst : List α) (delim : List α) : List (List α) :=
  let rec splitAux : List α → List α → List α → List (List α)
      | [], [], acc => [acc.reverse]
      | [], _, acc => [acc.reverse]
      | (h::t), [], acc => splitAux t delim (h::acc)
      | (h::t), (dh::dt), acc =>
        if h == dh then
          let rest := splitAux t dt []
          (acc.reverse :: rest)
        else splitAux t delim (h::acc)
  (splitAux lst delim []).filter (λ l => ¬ l.isEmpty)

/-- splits a string into a list of lines where the delimiter is
    the newline character -/
def lines : String -> List String
  | "" => []
  | s =>
    split s.data '\n'
    |> List.map String.mk

/-- convert a list of chars to a natural. Does not check that the chars are
    digits, it simply performs the conversion without possibility of error. -/
def strToNat (cs : String) : Nat :=
  loop (List.reverse cs.data)
  where
    loop : List Char -> Nat
    | [] => 0
    | c::cs => ((Char.toNat c) - 48) + 10 * loop cs

/-- Gets the contents of an Advent of Code data file given the year and day,
    and whether or not the file being sought is the example file or the
    puzzle file. It does not check that the file exists; if it doesn't,
    you'll experience the wrath of `IO.FS.readFile`! -/
def getData (y: Nat) (d: Nat) (ex: Bool) : IO String :=
  let y₁  := if y < 2000 then 2000 + y else y
  let ds  := toString d
  let d₁  := if length ds < 2 then "0" ++ ds else ds
  let ex₁ := if ex then "ex" else ""
  s!"./data/y{y₁}/d{d₁}{ex₁}.txt"
  |> IO.FS.readFile

/-- Gets puzzle data from the data directory
* `getPuz 2022 1` puzzle from year 2022 day 1
* `getPuz 22 1`  puzzle from year 2022 day 1
-/
def getPuz : Nat -> Nat -> IO String
  | y, d => getData y d False

def getEx : Nat -> Nat -> IO String
  | y, d => getData y d True

/-- finds the intersection between multiple lists -/
def intersect {α : Type} [BEq α] (xs : List (List α)) : List α :=
  match xs with
  | [] => []
  | h :: t => loop h t
  where
    /-- find the intersection between two lists -/
    intr : List α -> List α -> List α
      | [] => λ _ => List.nil
      | xs => List.filter (List.elem · xs)

    /-- Finds the intersection between multiple lists by
        recursively calling `intr` on the accumulated
        intersection and the next list -/
    loop : List α -> List (List α) -> List α
      | acc, [] => acc
      | acc, h' :: t => loop (intr acc h') t


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.range
import Mathlib.data.list.bag_inter
import Mathlib.PostPort

namespace Mathlib

namespace list

/--
`Ico n m` is the list of natural numbers `n ≤ x < m`.
(Ico stands for "interval, closed-open".)

See also `data/set/intervals.lean` for `set.Ico`, modelling intervals in general preorders, and
`multiset.Ico` and `finset.Ico` for `n ≤ x < m` as a multiset or as a finset.

@TODO (anyone): Define `Ioo` and `Icc`, state basic lemmas about them.
@TODO (anyone): Also do the versions for integers?
@TODO (anyone): One could generalise even further, defining
'locally finite partial orders', for which `set.Ico a b` is `[finite]`, and
'locally finite total orders', for which there is a list model.
 -/
def Ico (n : ℕ) (m : ℕ) : List ℕ :=
  range' n (m - n)

namespace Ico

theorem zero_bot (n : ℕ) : Ico 0 n = range n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Ico 0 n = range n)) (equations._eqn_1 0 n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (range' 0 (n - 0) = range n)) (nat.sub_zero n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (range' 0 n = range n)) (range_eq_range' n))) (Eq.refl (range' 0 n))))

@[simp] theorem length (n : ℕ) (m : ℕ) : length (Ico n m) = m - n := sorry

theorem pairwise_lt (n : ℕ) (m : ℕ) : pairwise Less (Ico n m) :=
  id (eq.mpr (id (propext ((fun (s n : ℕ) => iff_true_intro (pairwise_lt_range' s n)) n (m - n)))) trivial)

theorem nodup (n : ℕ) (m : ℕ) : nodup (Ico n m) :=
  id (eq.mpr (id (propext ((fun (s n : ℕ) => iff_true_intro (nodup_range' s n)) n (m - n)))) trivial)

@[simp] theorem mem {n : ℕ} {m : ℕ} {l : ℕ} : l ∈ Ico n m ↔ n ≤ l ∧ l < m := sorry

theorem eq_nil_of_le {n : ℕ} {m : ℕ} (h : m ≤ n) : Ico n m = [] := sorry

theorem map_add (n : ℕ) (m : ℕ) (k : ℕ) : map (Add.add k) (Ico n m) = Ico (n + k) (m + k) := sorry

theorem map_sub (n : ℕ) (m : ℕ) (k : ℕ) (h₁ : k ≤ n) : map (fun (x : ℕ) => x - k) (Ico n m) = Ico (n - k) (m - k) := sorry

@[simp] theorem self_empty {n : ℕ} : Ico n n = [] :=
  eq_nil_of_le (le_refl n)

@[simp] theorem eq_empty_iff {n : ℕ} {m : ℕ} : Ico n m = [] ↔ m ≤ n := sorry

theorem append_consecutive {n : ℕ} {m : ℕ} {l : ℕ} (hnm : n ≤ m) (hml : m ≤ l) : Ico n m ++ Ico m l = Ico n l := sorry

@[simp] theorem inter_consecutive (n : ℕ) (m : ℕ) (l : ℕ) : Ico n m ∩ Ico m l = [] := sorry

@[simp] theorem bag_inter_consecutive (n : ℕ) (m : ℕ) (l : ℕ) : list.bag_inter (Ico n m) (Ico m l) = [] :=
  iff.mpr (bag_inter_nil_iff_inter_nil (Ico n m) (Ico m l)) (inter_consecutive n m l)

@[simp] theorem succ_singleton {n : ℕ} : Ico n (n + 1) = [n] := sorry

theorem succ_top {n : ℕ} {m : ℕ} (h : n ≤ m) : Ico n (m + 1) = Ico n m ++ [m] :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Ico n (m + 1) = Ico n m ++ [m])) (Eq.symm succ_singleton)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Ico n (m + 1) = Ico n m ++ Ico m (m + 1))) (append_consecutive h (nat.le_succ m))))
      (Eq.refl (Ico n (m + 1))))

theorem eq_cons {n : ℕ} {m : ℕ} (h : n < m) : Ico n m = n :: Ico (n + 1) m :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Ico n m = n :: Ico (n + 1) m)) (Eq.symm (append_consecutive (nat.le_succ n) h))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Ico n (Nat.succ n) ++ Ico (Nat.succ n) m = n :: Ico (n + 1) m)) succ_singleton))
      (Eq.refl ([n] ++ Ico (Nat.succ n) m)))

@[simp] theorem pred_singleton {m : ℕ} (h : 0 < m) : Ico (m - 1) m = [m - 1] := sorry

theorem chain'_succ (n : ℕ) (m : ℕ) : chain' (fun (a b : ℕ) => b = Nat.succ a) (Ico n m) := sorry

@[simp] theorem not_mem_top {n : ℕ} {m : ℕ} : ¬m ∈ Ico n m := sorry

theorem filter_lt_of_top_le {n : ℕ} {m : ℕ} {l : ℕ} (hml : m ≤ l) : filter (fun (x : ℕ) => x < l) (Ico n m) = Ico n m :=
  iff.mpr filter_eq_self fun (k : ℕ) (hk : k ∈ Ico n m) => lt_of_lt_of_le (and.right (iff.mp mem hk)) hml

theorem filter_lt_of_le_bot {n : ℕ} {m : ℕ} {l : ℕ} (hln : l ≤ n) : filter (fun (x : ℕ) => x < l) (Ico n m) = [] :=
  iff.mpr filter_eq_nil fun (k : ℕ) (hk : k ∈ Ico n m) => not_lt_of_le (le_trans hln (and.left (iff.mp mem hk)))

theorem filter_lt_of_ge {n : ℕ} {m : ℕ} {l : ℕ} (hlm : l ≤ m) : filter (fun (x : ℕ) => x < l) (Ico n m) = Ico n l := sorry

@[simp] theorem filter_lt (n : ℕ) (m : ℕ) (l : ℕ) : filter (fun (x : ℕ) => x < l) (Ico n m) = Ico n (min m l) := sorry

theorem filter_le_of_le_bot {n : ℕ} {m : ℕ} {l : ℕ} (hln : l ≤ n) : filter (fun (x : ℕ) => l ≤ x) (Ico n m) = Ico n m :=
  iff.mpr filter_eq_self fun (k : ℕ) (hk : k ∈ Ico n m) => le_trans hln (and.left (iff.mp mem hk))

theorem filter_le_of_top_le {n : ℕ} {m : ℕ} {l : ℕ} (hml : m ≤ l) : filter (fun (x : ℕ) => l ≤ x) (Ico n m) = [] :=
  iff.mpr filter_eq_nil fun (k : ℕ) (hk : k ∈ Ico n m) => not_le_of_gt (lt_of_lt_of_le (and.right (iff.mp mem hk)) hml)

theorem filter_le_of_le {n : ℕ} {m : ℕ} {l : ℕ} (hnl : n ≤ l) : filter (fun (x : ℕ) => l ≤ x) (Ico n m) = Ico l m := sorry

@[simp] theorem filter_le (n : ℕ) (m : ℕ) (l : ℕ) : filter (fun (x : ℕ) => l ≤ x) (Ico n m) = Ico (max n l) m := sorry

theorem filter_lt_of_succ_bot {n : ℕ} {m : ℕ} (hnm : n < m) : filter (fun (x : ℕ) => x < n + 1) (Ico n m) = [n] := sorry

@[simp] theorem filter_le_of_bot {n : ℕ} {m : ℕ} (hnm : n < m) : filter (fun (x : ℕ) => x ≤ n) (Ico n m) = [n] :=
  eq.mpr (id (Eq._oldrec (Eq.refl (filter (fun (x : ℕ) => x ≤ n) (Ico n m) = [n])) (Eq.symm (filter_lt_of_succ_bot hnm))))
    (filter_congr fun (_x : ℕ) (_x_1 : _x ∈ Ico n m) => iff.symm nat.lt_succ_iff)

/--
For any natural numbers n, a, and b, one of the following holds:
1. n < a
2. n ≥ b
3. n ∈ Ico a b
-/
theorem trichotomy (n : ℕ) (a : ℕ) (b : ℕ) : n < a ∨ b ≤ n ∨ n ∈ Ico a b := sorry


/-
Copyright (c) 2017 Simon Hudon All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.pfunctor.univariate.basic

/-!
# M-types

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.
-/

universes u v w

open nat function list (hiding head')

variables (F : pfunctor.{u})

local prefix `♯`:0 := cast (by simp [*] <|> cc <|> solve_by_elim)

namespace pfunctor
namespace approx

/-- `cofix_a F n` is an `n` level approximation of a M-type -/
inductive cofix_a : ℕ → Type u
| continue : cofix_a 0
| intro {n} : ∀ a, (F.B a → cofix_a n) → cofix_a (succ n)

/-- default inhabitant of `cofix_a` -/
protected def cofix_a.default [inhabited F.A] : Π n, cofix_a F n
| 0 := cofix_a.continue
| (succ n) := cofix_a.intro default $ λ _, cofix_a.default n

instance [inhabited F.A] {n} : inhabited (cofix_a F n) := ⟨ cofix_a.default F n ⟩

lemma cofix_a_eq_zero : ∀ x y : cofix_a F 0, x = y
| cofix_a.continue cofix_a.continue := rfl

variables {F}

/--
The label of the root of the tree for a non-trivial
approximation of the cofix of a pfunctor.
-/
def head' : Π {n}, cofix_a F (succ n) → F.A
| n (cofix_a.intro i _) := i

/-- for a non-trivial approximation, return all the subtrees of the root -/
def children' : Π {n} (x : cofix_a F (succ n)), F.B (head' x) → cofix_a F n
| n (cofix_a.intro a f) := f

lemma approx_eta  {n : ℕ} (x : cofix_a F (n+1)) :
  x = cofix_a.intro (head' x) (children' x) :=
by cases x; refl

/-- Relation between two approximations of the cofix of a pfunctor
that state they both contain the same data until one of them is truncated -/
inductive agree : ∀ {n : ℕ}, cofix_a F n → cofix_a F (n+1) → Prop
 | continue (x : cofix_a F 0) (y : cofix_a F 1) : agree x y
 | intro {n} {a} (x : F.B a → cofix_a F n) (x' : F.B a → cofix_a F (n+1)) :
   (∀ i : F.B a, agree (x i) (x' i)) →
   agree (cofix_a.intro a x) (cofix_a.intro a x')

/--
Given an infinite series of approximations `approx`,
`all_agree approx` states that they are all consistent with each other.
-/
def all_agree (x : Π n, cofix_a F n) :=
∀ n, agree (x n) (x (succ n))

@[simp]
lemma agree_trival {x : cofix_a F 0} {y : cofix_a F 1} :
  agree x y :=
by { constructor }

lemma agree_children {n : ℕ} (x : cofix_a F (succ n)) (y : cofix_a F (succ n+1))
    {i j} (h₀ : i == j) (h₁ : agree x y) :
  agree (children' x i) (children' y j) :=
begin
  cases h₁ with _ _ _ _ _ _ hagree, cases h₀,
  apply hagree,
end

/-- `truncate a` turns `a` into a more limited approximation -/
def truncate : ∀ {n : ℕ}, cofix_a F (n+1) → cofix_a F n
| 0 (cofix_a.intro _ _) := cofix_a.continue
| (succ n) (cofix_a.intro i f) := cofix_a.intro i $ truncate ∘ f

lemma truncate_eq_of_agree {n : ℕ} (x : cofix_a F n) (y : cofix_a F (succ n)) (h : agree x y) :
  truncate y = x :=
begin
  induction n generalizing x y; cases x; cases y,
  { refl },
  { cases h with _ _ _ _ _ h₀ h₁,
    cases h,
    simp only [truncate, function.comp, true_and, eq_self_iff_true, heq_iff_eq],
    ext y, apply n_ih,
    apply h₁ }
end

variables {X : Type w}
variables (f : X → F.obj X)

/-- `s_corec f i n` creates an approximation of height `n`
of the final coalgebra of `f` -/
def s_corec : Π (i : X) n, cofix_a F n
| _ 0 := cofix_a.continue
| j (succ n) := cofix_a.intro (f j).1 (λ i, s_corec ((f j).2 i) _)

lemma P_corec (i : X) (n : ℕ) : agree (s_corec f i n) (s_corec f i (succ n)) :=
begin
  induction n with n generalizing i,
  constructor,
  cases h : f i with y g,
  constructor,
  introv,
  apply n_ih,
end

/-- `path F` provides indices to access internal nodes in `corec F` -/
def path (F : pfunctor.{u}) := list F.Idx

instance path.inhabited : inhabited (path F) := ⟨ [] ⟩

open list nat

instance : subsingleton (cofix_a F 0) :=
⟨ by { intros, casesm* cofix_a F 0, refl } ⟩

lemma head_succ' (n m : ℕ) (x : Π n, cofix_a F n) (Hconsistent : all_agree x) :
  head' (x (succ n)) = head' (x (succ m)) :=
begin
  suffices : ∀ n, head' (x (succ n)) = head' (x 1),
  { simp [this] },
  clear m n, intro,
  cases h₀ : x (succ n) with _ i₀ f₀,
  cases h₁ : x 1 with _ i₁ f₁,
  dsimp only [head'],
  induction n with n,
  { rw h₁ at h₀, cases h₀, trivial },
  { have H := Hconsistent (succ n),
    cases h₂ : x (succ n) with _ i₂ f₂,
    rw [h₀,h₂] at H,
    apply n_ih (truncate ∘ f₀),
    rw h₂,
    cases H with _ _ _ _ _ _ hagree,
    congr, funext j, dsimp only [comp_app],
    rw truncate_eq_of_agree,
    apply hagree }
end

end approx
open approx

/-- Internal definition for `M`. It is needed to avoid name clashes
between `M.mk` and `M.cases_on` and the declarations generated for
the structure -/
structure M_intl :=
(approx : ∀ n, cofix_a F n)
(consistent : all_agree approx)

/-- For polynomial functor `F`, `M F` is its final coalgebra -/
def M := M_intl F

lemma M.default_consistent [inhabited F.A] :
  Π n, agree (default : cofix_a F n) default
| 0 := agree.continue _ _
| (succ n) := agree.intro _ _ $ λ _, M.default_consistent n

instance M.inhabited [inhabited F.A] : inhabited (M F) :=
⟨ { approx := λ n, default,
    consistent := M.default_consistent _ } ⟩

instance M_intl.inhabited [inhabited F.A] : inhabited (M_intl F) :=
show inhabited (M F), by apply_instance

namespace M

lemma ext' (x y : M F) (H : ∀ i : ℕ, x.approx i = y.approx i) : x = y :=
by { cases x, cases y, congr' with n, apply H }

variables {X : Type*}
variables (f : X → F.obj X)
variables {F}

/-- Corecursor for the M-type defined by `F`. -/
protected def corec (i : X) : M F :=
{ approx := s_corec f i,
  consistent := P_corec _ _ }

variables {F}

/-- given a tree generated by `F`, `head` gives us the first piece of data
it contains -/
def head (x : M F) :=
head' (x.1 1)

/-- return all the subtrees of the root of a tree `x : M F` -/
def children (x : M F) (i : F.B (head x)) : M F :=
   let H := λ n : ℕ, @head_succ' _ n 0 x.1 x.2 in
   { approx := λ n, children' (x.1 _) (cast (congr_arg _ $ by simp only [head,H]; refl) i),
     consistent :=
     begin
       intro,
       have P' := x.2 (succ n),
       apply agree_children _ _ _ P',
       transitivity i,
       apply cast_heq,
       symmetry,
       apply cast_heq,
     end }

/-- select a subtree using a `i : F.Idx` or return an arbitrary tree if
`i` designates no subtree of `x` -/
def ichildren [inhabited (M F)] [decidable_eq F.A] (i : F.Idx) (x : M F) : M F :=
if H' : i.1 = head x
  then children x (cast (congr_arg _ $ by simp only [head,H']; refl) i.2)
  else default

lemma head_succ (n m : ℕ) (x : M F) :
  head' (x.approx (succ n)) = head' (x.approx (succ m)) :=
head_succ' n m _ x.consistent

lemma head_eq_head' : Π (x : M F) (n : ℕ),
  head x = head' (x.approx $ n+1)
| ⟨x,h⟩ n := head_succ' _ _ _ h

lemma head'_eq_head : Π (x : M F) (n : ℕ),
  head' (x.approx $ n+1) = head x
| ⟨x,h⟩ n := head_succ' _ _ _ h

lemma truncate_approx (x : M F) (n : ℕ) :
  truncate (x.approx $ n+1) = x.approx n :=
truncate_eq_of_agree _ _ (x.consistent _)

/-- unfold an M-type -/
def dest : M F → F.obj (M F)
| x := ⟨head x,λ i, children x i ⟩

namespace approx

/-- generates the approximations needed for `M.mk` -/
protected def s_mk (x : F.obj $ M F) : Π n, cofix_a F n
 | 0 :=  cofix_a.continue
 | (succ n) := cofix_a.intro x.1 (λ i, (x.2 i).approx n)

protected lemma P_mk  (x : F.obj $ M F)
: all_agree (approx.s_mk x)
 | 0 := by { constructor }
 | (succ n) := by { constructor, introv,
                    apply (x.2 i).consistent }

end approx

/-- constructor for M-types -/
protected def mk (x : F.obj $ M F) : M F :=
{ approx := approx.s_mk x,
  consistent := approx.P_mk x }

/-- `agree' n` relates two trees of type `M F` that
are the same up to dept `n` -/
inductive agree' : ℕ → M F → M F → Prop
| trivial (x y : M F) : agree' 0 x y
| step {n : ℕ} {a} (x y : F.B a → M F) {x' y'} :
  x' = M.mk ⟨a,x⟩ →
  y' = M.mk ⟨a,y⟩ →
  (∀ i, agree' n (x i) (y i)) →
  agree' (succ n) x' y'

@[simp]
lemma dest_mk (x : F.obj $ M F) :
  dest (M.mk x) = x :=
begin
  funext i,
  dsimp only [M.mk,dest],
  cases x with x ch, congr' with i,
  cases h : ch i,
  simp only [children,M.approx.s_mk,children',cast_eq],
  dsimp only [M.approx.s_mk,children'],
  congr, rw h,
end

@[simp] lemma mk_dest (x : M F) :
  M.mk (dest x) = x :=
begin
  apply ext', intro n,
  dsimp only [M.mk],
  induction n with n,
  { apply subsingleton.elim },
  dsimp only [approx.s_mk,dest,head],
  cases h : x.approx (succ n) with _ hd ch,
  have h' : hd = head' (x.approx 1),
  { rw [← head_succ' n,h,head'], apply x.consistent },
  revert ch, rw h', intros, congr,
  { ext a, dsimp only [children],
    h_generalize! hh : a == a'',
    rw h, intros, cases hh, refl },
end

lemma mk_inj {x y : F.obj $ M F}
  (h : M.mk x = M.mk y) : x = y :=
by rw [← dest_mk x,h,dest_mk]

/-- destructor for M-types -/
protected def cases {r : M F → Sort w}
  (f : ∀ (x : F.obj $ M F), r (M.mk x)) (x : M F) : r x :=
suffices r (M.mk (dest x)),
  by { haveI := classical.prop_decidable,
       haveI := inhabited.mk x,
       rw [← mk_dest x], exact this },
f _

/-- destructor for M-types -/
protected def cases_on {r : M F → Sort w}
  (x : M F) (f : ∀ (x : F.obj $ M F), r (M.mk x)) : r x :=
M.cases f x

/-- destructor for M-types, similar to `cases_on` but also
gives access directly to the root and subtrees on an M-type -/
protected def cases_on' {r : M F → Sort w}
  (x : M F) (f : ∀ a f, r (M.mk ⟨a,f⟩)) : r x :=
M.cases_on x (λ ⟨a,g⟩, f a _)

lemma approx_mk (a : F.A) (f : F.B a → M F) (i : ℕ) :
  (M.mk ⟨a, f⟩).approx (succ i) = cofix_a.intro a (λ j, (f j).approx i) :=
rfl

@[simp] lemma agree'_refl {n : ℕ} (x : M F) :
  agree' n x x :=
by { induction n generalizing x; induction x using pfunctor.M.cases_on';
     constructor; try { refl }, intros, apply n_ih }

lemma agree_iff_agree' {n : ℕ} (x y : M F) :
  agree (x.approx n) (y.approx $ n+1) ↔ agree' n x y :=
begin
  split; intros h,
  { induction n generalizing x y, constructor,
    { induction x using pfunctor.M.cases_on',
      induction y using pfunctor.M.cases_on',
      simp only [approx_mk] at h, cases h with _ _ _ _ _ _ hagree,
      constructor; try { refl },
      intro i, apply n_ih, apply hagree } },
  { induction n generalizing x y, constructor,
    { cases h,
      induction x using pfunctor.M.cases_on',
      induction y using pfunctor.M.cases_on',
      simp only [approx_mk],
      have h_a_1 := mk_inj ‹M.mk ⟨x_a, x_f⟩ = M.mk ⟨h_a, h_x⟩›, cases h_a_1,
      replace h_a_2 := mk_inj ‹M.mk ⟨y_a, y_f⟩ = M.mk ⟨h_a, h_y⟩›, cases h_a_2,
      constructor, intro i, apply n_ih, simp * } },
end

@[simp]
lemma cases_mk {r : M F → Sort*} (x : F.obj $ M F) (f : Π (x : F.obj $ M F), r (M.mk x)) :
  pfunctor.M.cases f (M.mk x) = f x :=
begin
  dsimp only [M.mk,pfunctor.M.cases,dest,head,approx.s_mk,head'],
  cases x, dsimp only [approx.s_mk],
  apply eq_of_heq,
  apply rec_heq_of_heq, congr' with x,
  dsimp only [children,approx.s_mk,children'],
  cases h : x_snd x, dsimp only [head],
  congr' with n, change (x_snd (x)).approx n = _, rw h
end

@[simp]
lemma cases_on_mk {r : M F → Sort*} (x : F.obj $ M F) (f : Π x : F.obj $ M F, r (M.mk x)) :
  pfunctor.M.cases_on (M.mk x) f = f x :=
cases_mk x f

@[simp]
lemma cases_on_mk'
  {r : M F → Sort*} {a} (x : F.B a → M F) (f : Π a (f : F.B a → M F), r (M.mk ⟨a,f⟩)) :
  pfunctor.M.cases_on' (M.mk ⟨a,x⟩) f = f a x :=
cases_mk ⟨_,x⟩ _

/-- `is_path p x` tells us if `p` is a valid path through `x` -/
inductive is_path : path F → M F → Prop
| nil (x : M F) : is_path [] x
| cons (xs : path F) {a} (x : M F) (f : F.B a → M F) (i : F.B a) :
  x = M.mk ⟨a,f⟩ →
  is_path xs (f i) →
  is_path (⟨a,i⟩ :: xs) x

lemma is_path_cons {xs : path F} {a a'} {f : F.B a → M F} {i : F.B a'}
  (h : is_path (⟨a',i⟩ :: xs) (M.mk ⟨a,f⟩)) :
  a = a' :=
begin
  revert h, generalize h : (M.mk ⟨a,f⟩) = x,
  intros h', cases h', subst x,
  cases mk_inj ‹_›, refl,
end

lemma is_path_cons' {xs : path F} {a} {f : F.B a → M F} {i : F.B a}
  (h : is_path (⟨a,i⟩ :: xs) (M.mk ⟨a,f⟩)) :
  is_path xs (f i) :=
begin
  revert h, generalize h : (M.mk ⟨a,f⟩) = x,
  intros h', cases h', subst x,
  have := mk_inj ‹_›, cases this, cases this,
  assumption,
end

/-- follow a path through a value of `M F` and return the subtree
found at the end of the path if it is a valid path for that value and
return a default tree -/
def isubtree [decidable_eq F.A] [inhabited (M F)] : path F → M F → M F
| [] x := x
| (⟨a, i⟩ :: ps) x :=
pfunctor.M.cases_on' x (λ a' f,
(if h : a = a' then isubtree ps (f $ cast (by rw h) i)
 else default : (λ x, M F) (M.mk ⟨a',f⟩)))

/-- similar to `isubtree` but returns the data at the end of the path instead
of the whole subtree -/
def iselect [decidable_eq F.A] [inhabited (M F)] (ps : path F) : M F → F.A :=
λ (x : M F), head $ isubtree ps x

lemma iselect_eq_default [decidable_eq F.A] [inhabited (M F)] (ps : path F) (x : M F)
  (h : ¬ is_path ps x) :
  iselect ps x = head default :=
begin
  induction ps generalizing x,
  { exfalso, apply h, constructor },
  { cases ps_hd with a i,
    induction x using pfunctor.M.cases_on',
    simp only [iselect,isubtree] at ps_ih ⊢,
    by_cases h'' : a = x_a, subst x_a,
    { simp only [dif_pos, eq_self_iff_true, cases_on_mk'],
      rw ps_ih, intro h', apply h,
      constructor; try { refl }, apply h' },
    { simp * } }
end

@[simp] lemma head_mk (x : F.obj (M F)) :
  head (M.mk x) = x.1 :=
eq.symm $
calc  x.1
    = (dest (M.mk x)).1 : by rw dest_mk
... = head (M.mk x)           : by refl

lemma children_mk {a} (x : F.B a → (M F)) (i : F.B (head (M.mk ⟨a,x⟩))) :
  children (M.mk ⟨a,x⟩) i = x (cast (by rw head_mk) i) :=
by apply ext'; intro n; refl

@[simp]
lemma ichildren_mk [decidable_eq F.A] [inhabited (M F)] (x : F.obj (M F)) (i : F.Idx) :
  ichildren i (M.mk x) = x.iget i :=
by { dsimp only [ichildren,pfunctor.obj.iget],
     congr' with h, apply ext',
     dsimp only [children',M.mk,approx.s_mk],
     intros, refl }

@[simp]
lemma isubtree_cons
  [decidable_eq F.A] [inhabited (M F)] (ps : path F) {a} (f : F.B a → M F) {i : F.B a} :
  isubtree (⟨_,i⟩ :: ps) (M.mk ⟨a,f⟩) = isubtree ps (f i) :=
by simp only [isubtree,ichildren_mk,pfunctor.obj.iget,dif_pos,isubtree,M.cases_on_mk']; refl

@[simp]
lemma iselect_nil [decidable_eq F.A] [inhabited (M F)] {a} (f : F.B a → M F) :
  iselect nil (M.mk ⟨a,f⟩) = a :=
by refl

@[simp]
lemma iselect_cons [decidable_eq F.A] [inhabited (M F)] (ps : path F) {a} (f : F.B a → M F) {i} :
  iselect (⟨a,i⟩ :: ps) (M.mk ⟨a,f⟩) = iselect ps (f i) :=
by simp only [iselect,isubtree_cons]

lemma corec_def {X} (f : X → F.obj X) (x₀ : X) :
  M.corec f x₀ = M.mk (M.corec f <$> f x₀)  :=
begin
  dsimp only [M.corec,M.mk],
  congr' with n,
  cases n with n,
  { dsimp only [s_corec,approx.s_mk], refl, },
  { dsimp only [s_corec,approx.s_mk], cases h : (f x₀),
    dsimp only [(<$>),pfunctor.map],
    congr, }
end

lemma ext_aux [inhabited (M F)] [decidable_eq F.A] {n : ℕ} (x y z : M F)
  (hx : agree' n z x)
  (hy : agree' n z y)
  (hrec : ∀ (ps : path F),
             n = ps.length →
            iselect ps x = iselect ps y) :
  x.approx (n+1) = y.approx (n+1) :=
begin
  induction n with n generalizing x y z,
  { specialize hrec [] rfl,
    induction x using pfunctor.M.cases_on', induction y using pfunctor.M.cases_on',
    simp only [iselect_nil] at hrec, subst hrec,
    simp only [approx_mk, true_and, eq_self_iff_true, heq_iff_eq],
    apply subsingleton.elim },
  { cases hx, cases hy,
    induction x using pfunctor.M.cases_on', induction y using pfunctor.M.cases_on',
    subst z,
    iterate 3 { have := mk_inj ‹_›, repeat { cases this } },
    simp only [approx_mk, true_and, eq_self_iff_true, heq_iff_eq],
    ext i, apply n_ih,
    { solve_by_elim },
    { solve_by_elim },
    introv h, specialize hrec (⟨_,i⟩ :: ps) (congr_arg _ h),
    simp only [iselect_cons] at hrec, exact hrec }
end

open pfunctor.approx

variables {F}

local attribute [instance, priority 0] classical.prop_decidable

lemma ext [inhabited (M F)]
  (x y : M F)
  (H : ∀ (ps : path F), iselect ps x = iselect ps y) :
  x = y :=
begin
  apply ext', intro i,
  induction i with i,
  { cases x.approx 0, cases y.approx 0, constructor },
  { apply ext_aux x y x,
    { rw ← agree_iff_agree', apply x.consistent },
    { rw [← agree_iff_agree',i_ih], apply y.consistent },
    introv H',
    dsimp only [iselect] at H,
    cases H',
    apply H ps }
end

section bisim

variable (R : M F → M F → Prop)
local infix ` ~ `:50 := R

/-- Bisimulation is the standard proof technique for equality between
infinite tree-like structures -/
structure is_bisimulation : Prop :=
(head : ∀ {a a'} {f f'}, M.mk ⟨a,f⟩ ~ M.mk ⟨a',f'⟩ → a = a')
(tail : ∀ {a} {f f' : F.B a → M F},
  M.mk ⟨a,f⟩ ~ M.mk ⟨a,f'⟩ →
  (∀ (i : F.B a), f i ~ f' i) )

theorem nth_of_bisim [inhabited (M F)] (bisim : is_bisimulation R) (s₁ s₂) (ps : path F) :
     s₁ ~ s₂ →
       is_path ps s₁ ∨ is_path ps s₂ →
       iselect ps s₁ = iselect ps s₂ ∧
       ∃ a (f f' : F.B a → M F),
         isubtree ps s₁ = M.mk ⟨a,f⟩ ∧
         isubtree ps s₂ = M.mk ⟨a,f'⟩ ∧
       ∀ (i : F.B a), f i ~ f' i :=
begin
  intros h₀ hh,
  induction s₁ using pfunctor.M.cases_on' with a f,
  induction s₂ using pfunctor.M.cases_on' with a' f',
  have : a = a' := bisim.head h₀, subst a',
  induction ps with i ps generalizing a f f',
  { existsi [rfl,a,f,f',rfl,rfl],
    apply bisim.tail h₀ },
  cases i with a' i,
  have : a = a',
  { cases hh; cases is_path_cons hh; refl },
  subst a', dsimp only [iselect] at ps_ih ⊢,
  have h₁ := bisim.tail h₀ i,
  induction h : (f i) using pfunctor.M.cases_on' with a₀ f₀,
  induction h' : (f' i) using pfunctor.M.cases_on' with a₁ f₁,
  simp only [h,h',isubtree_cons] at ps_ih ⊢,
  rw [h,h'] at h₁,
  have : a₀ = a₁ := bisim.head h₁, subst a₁,
  apply (ps_ih _ _ _ h₁),
  rw [← h,← h'], apply or_of_or_of_imp_of_imp hh is_path_cons' is_path_cons'
end

theorem eq_of_bisim [nonempty (M F)] (bisim : is_bisimulation R) : ∀ s₁ s₂, s₁ ~ s₂ → s₁ = s₂ :=
begin
  inhabit (M F),
  introv Hr, apply ext,
  introv,
  by_cases h : is_path ps s₁ ∨ is_path ps s₂,
  { have H := nth_of_bisim R bisim _ _ ps Hr h,
    exact H.left },
  { rw not_or_distrib at h, cases h with h₀ h₁,
    simp only [iselect_eq_default,*,not_false_iff] }
end

end bisim

universes u' v'

/-- corecursor for `M F` with swapped arguments -/
def corec_on {X : Type*} (x₀ : X) (f : X → F.obj X) : M F :=
M.corec f x₀

variables {P : pfunctor.{u}} {α : Type u}

lemma dest_corec (g : α → P.obj α) (x : α) :
  M.dest (M.corec g x) = M.corec g <$> g x :=
by rw [corec_def,dest_mk]

theorem bisim' {α : Type*} (Q : α → Prop) (u v : α → M P)
    (h : ∀ x, Q x → ∃ a f f',
      M.dest (u x) = ⟨a, f⟩ ∧
      M.dest (v x) = ⟨a, f'⟩ ∧
      ∀ i, ∃ x', Q x' ∧ f i = u x' ∧ f' i = v x') :
  ∀ x, Q x → u x = v x :=
λ x Qx,
let R := λ w z : M P, ∃ x', Q x' ∧ w = u x' ∧ z = v x' in
@M.bisim P R
  (λ x y ⟨x', Qx', xeq, yeq⟩,
    let ⟨a, f, f', ux'eq, vx'eq, h'⟩ := h x' Qx' in
      ⟨a, f, f', xeq.symm ▸ ux'eq, yeq.symm ▸ vx'eq, h'⟩)
  _ _ ⟨x, Qx, rfl, rfl⟩

-- for the record, show M_bisim follows from _bisim'
theorem bisim_equiv (R : M P → M P → Prop)
    (h : ∀ x y, R x y → ∃ a f f',
      M.dest x = ⟨a, f⟩ ∧
      M.dest y = ⟨a, f'⟩ ∧
      ∀ i, R (f i) (f' i)) :
  ∀ x y, R x y → x = y :=
λ x y Rxy,
let Q : M P × M P → Prop := λ p, R p.fst p.snd in
bisim' Q prod.fst prod.snd
  (λ p Qp,
    let ⟨a, f, f', hx, hy, h'⟩ := h p.fst p.snd Qp in
    ⟨a, f, f', hx, hy, λ i, ⟨⟨f i, f' i⟩, h' i, rfl, rfl⟩⟩)
  ⟨x, y⟩ Rxy

theorem corec_unique (g : α → P.obj α) (f : α → M P)
    (hyp : ∀ x, M.dest (f x) = f <$> (g x)) :
  f = M.corec g :=
begin
  ext x,
  apply bisim' (λ x, true) _ _ _ _ trivial,
  clear x,
  intros x _,
  cases gxeq : g x with a f',
  have h₀ : M.dest (f x) = ⟨a, f ∘ f'⟩,
  { rw [hyp, gxeq, pfunctor.map_eq] },
  have h₁ : M.dest (M.corec g x) = ⟨a, M.corec g ∘ f'⟩,
  { rw [dest_corec, gxeq, pfunctor.map_eq], },
  refine ⟨_, _, _, h₀, h₁, _⟩,
  intro i,
  exact ⟨f' i, trivial, rfl, rfl⟩
end

/-- corecursor where the state of the computation can be sent downstream
in the form of a recursive call -/
def corec₁ {α : Type u} (F : Π X, (α → X) → α → P.obj X) : α → M P :=
M.corec (F _ id)

/-- corecursor where it is possible to return a fully formed value at any point
of the computation -/
def corec' {α : Type u} (F : Π {X : Type u}, (α → X) → α → M P ⊕ P.obj X) (x : α) : M P :=
corec₁
(λ X rec (a : M P ⊕ α),
     let y := a >>= F (rec ∘ sum.inr) in
     match y with
     | sum.inr y := y
     | sum.inl y := (rec ∘ sum.inl) <$> M.dest y
     end )
(@sum.inr (M P) _ x)

end M

end pfunctor


/-
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

! This file was ported from Lean 3 source module analysis.complex.liouville
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Complex.CauchyIntegral
import Mathbin.Analysis.Calculus.FderivAnalytic
import Mathbin.Analysis.NormedSpace.Completion

/-!
# Liouville's theorem

In this file we prove Liouville's theorem: if `f : E → F` is complex differentiable on the whole
space and its range is bounded, then the function is a constant. Various versions of this theorem
are formalized in `differentiable.apply_eq_apply_of_bounded`,
`differentiable.exists_const_forall_eq_of_bounded`, and
`differentiable.exists_eq_const_of_bounded`.

The proof is based on the Cauchy integral formula for the derivative of an analytic function, see
`complex.deriv_eq_smul_circle_integral`.
-/

open TopologicalSpace Metric Set Filter Asymptotics Function MeasureTheory

open Topology Filter NNReal Real

universe u v

variable {E : Type u} [NormedAddCommGroup E] [NormedSpace ℂ E] {F : Type v} [NormedAddCommGroup F]
  [NormedSpace ℂ F]

-- mathport name: «expr ̂»
local postfix:100 "̂" => UniformSpace.Completion

namespace Complex

/-- If `f` is complex differentiable on an open disc with center `c` and radius `R > 0` and is
continuous on its closure, then `f' c` can be represented as an integral over the corresponding
circle.

TODO: add a version for `w ∈ metric.ball c R`.

TODO: add a version for higher derivatives. -/
theorem deriv_eq_smul_circleIntegral [CompleteSpace F] {R : ℝ} {c : ℂ} {f : ℂ → F} (hR : 0 < R)
    (hf : DiffContOnCl ℂ f (ball c R)) :
    deriv f c = (2 * π * I : ℂ)⁻¹ • ∮ z in C(c, R), (z - c) ^ (-2 : ℤ) • f z :=
  by
  lift R to ℝ≥0 using hR.le
  refine' (hf.has_fpower_series_on_ball hR).HasFpowerSeriesAt.deriv.trans _
  simp only [cauchyPowerSeries_apply, one_div, zpow_neg, pow_one, smul_smul, zpow_two, mul_inv]
#align complex.deriv_eq_smul_circle_integral Complex.deriv_eq_smul_circleIntegral

theorem norm_deriv_le_aux [CompleteSpace F] {c : ℂ} {R C : ℝ} {f : ℂ → F} (hR : 0 < R)
    (hf : DiffContOnCl ℂ f (ball c R)) (hC : ∀ z ∈ sphere c R, ‖f z‖ ≤ C) : ‖deriv f c‖ ≤ C / R :=
  by
  have : ∀ z ∈ sphere c R, ‖(z - c) ^ (-2 : ℤ) • f z‖ ≤ C / (R * R) :=
    fun z (hz : abs (z - c) = R) => by
    simpa [-mul_inv_rev, norm_smul, hz, zpow_two, ← div_eq_inv_mul] using
      (div_le_div_right (mul_pos hR hR)).2 (hC z hz)
  calc
    ‖deriv f c‖ = ‖(2 * π * I : ℂ)⁻¹ • ∮ z in C(c, R), (z - c) ^ (-2 : ℤ) • f z‖ :=
      congr_arg norm (deriv_eq_smul_circle_integral hR hf)
    _ ≤ R * (C / (R * R)) :=
      (circleIntegral.norm_two_pi_i_inv_smul_integral_le_of_norm_le_const hR.le this)
    _ = C / R := by rw [mul_div_left_comm, div_self_mul_self', div_eq_mul_inv]

#align complex.norm_deriv_le_aux Complex.norm_deriv_le_aux

/-- If `f` is complex differentiable on an open disc of radius `R > 0`, is continuous on its
closure, and its values on the boundary circle of this disc are bounded from above by `C`, then the
norm of its derivative at the center is at most `C / R`. -/
theorem norm_deriv_le_of_forall_mem_sphere_norm_le {c : ℂ} {R C : ℝ} {f : ℂ → F} (hR : 0 < R)
    (hd : DiffContOnCl ℂ f (ball c R)) (hC : ∀ z ∈ sphere c R, ‖f z‖ ≤ C) : ‖deriv f c‖ ≤ C / R :=
  by
  set e : F →L[ℂ] F̂ := UniformSpace.Completion.toComplL
  have : HasDerivAt (e ∘ f) (e (deriv f c)) c :=
    e.has_fderiv_at.comp_has_deriv_at c
      (hd.differentiable_at is_open_ball <| mem_ball_self hR).HasDerivAt
  calc
    ‖deriv f c‖ = ‖deriv (e ∘ f) c‖ := by
      rw [this.deriv]
      exact (UniformSpace.Completion.norm_coe _).symm
    _ ≤ C / R :=
      norm_deriv_le_aux hR (e.differentiable.comp_diff_cont_on_cl hd) fun z hz =>
        (UniformSpace.Completion.norm_coe _).trans_le (hC z hz)

#align complex.norm_deriv_le_of_forall_mem_sphere_norm_le Complex.norm_deriv_le_of_forall_mem_sphere_norm_le

/-- An auxiliary lemma for Liouville's theorem `differentiable.apply_eq_apply_of_bounded`. -/
theorem liouville_theorem_aux {f : ℂ → F} (hf : Differentiable ℂ f) (hb : Bounded (range f))
    (z w : ℂ) : f z = f w := by
  suffices : ∀ c, deriv f c = 0
  exact is_const_of_deriv_eq_zero hf this z w
  clear z w
  intro c
  obtain ⟨C, C₀, hC⟩ : ∃ C > (0 : ℝ), ∀ z, ‖f z‖ ≤ C :=
    by
    rcases bounded_iff_forall_norm_le.1 hb with ⟨C, hC⟩
    exact
      ⟨max C 1, lt_max_iff.2 (Or.inr zero_lt_one), fun z =>
        (hC (f z) (mem_range_self _)).trans (le_max_left _ _)⟩
  refine' norm_le_zero_iff.1 (le_of_forall_le_of_dense fun ε ε₀ => _)
  calc
    ‖deriv f c‖ ≤ C / (C / ε) :=
      norm_deriv_le_of_forall_mem_sphere_norm_le (div_pos C₀ ε₀) hf.diff_cont_on_cl fun z _ => hC z
    _ = ε := div_div_cancel' C₀.lt.ne'

#align complex.liouville_theorem_aux Complex.liouville_theorem_aux

end Complex

namespace Differentiable

open Complex

/-- **Liouville's theorem**: a complex differentiable bounded function `f : E → F` is a constant. -/
theorem apply_eq_apply_of_bounded {f : E → F} (hf : Differentiable ℂ f) (hb : Bounded (range f))
    (z w : E) : f z = f w :=
  by
  set g : ℂ → F := f ∘ fun t : ℂ => t • (w - z) + z
  suffices g 0 = g 1 by simpa [g]
  apply liouville_theorem_aux
  exacts[hf.comp ((differentiable_id.smul_const (w - z)).AddConst z),
    hb.mono (range_comp_subset_range _ _)]
#align differentiable.apply_eq_apply_of_bounded Differentiable.apply_eq_apply_of_bounded

/-- **Liouville's theorem**: a complex differentiable bounded function is a constant. -/
theorem exists_const_forall_eq_of_bounded {f : E → F} (hf : Differentiable ℂ f)
    (hb : Bounded (range f)) : ∃ c, ∀ z, f z = c :=
  ⟨f 0, fun z => hf.apply_eq_apply_of_bounded hb _ _⟩
#align differentiable.exists_const_forall_eq_of_bounded Differentiable.exists_const_forall_eq_of_bounded

/-- **Liouville's theorem**: a complex differentiable bounded function is a constant. -/
theorem exists_eq_const_of_bounded {f : E → F} (hf : Differentiable ℂ f) (hb : Bounded (range f)) :
    ∃ c, f = const E c :=
  (hf.exists_const_forall_eq_of_bounded hb).imp fun c => funext
#align differentiable.exists_eq_const_of_bounded Differentiable.exists_eq_const_of_bounded

end Differentiable


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

! This file was ported from Lean 3 source module analysis.normed_space.M_structure
! leanprover-community/mathlib commit d11893b411025250c8e61ff2f12ccbd7ee35ab15
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Ring.Idempotents
import Mathlib.Analysis.Normed.Group.Basic

/-!
# M-structure

A projection P on a normed space X is said to be an L-projection (`IsLprojection`) if, for all `x`
in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

A projection P on a normed space X is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

The L-projections on `X` form a Boolean algebra (`IsLprojection.Subtype.BooleanAlgebra`).

## TODO (Motivational background)

The M-projections on a normed space form a Boolean algebra.

The range of an L-projection on a normed space `X` is said to be an L-summand of `X`. The range of
an M-projection is said to be an M-summand of `X`.

When `X` is a Banach space, the Boolean algebra of L-projections is complete. Let `X` be a normed
space with dual `X^*`. A closed subspace `M` of `X` is said to be an M-ideal if the topological
annihilator `M^∘` is an L-summand of `X^*`.

M-ideal, M-summands and L-summands were introduced by Alfsen and Effros in [alfseneffros1972] to
study the structure of general Banach spaces. When `A` is a JB*-triple, the M-ideals of `A` are
exactly the norm-closed ideals of `A`. When `A` is a JBW*-triple with predual `X`, the M-summands of
`A` are exactly the weak*-closed ideals, and their pre-duals can be identified with the L-summands
of `X`. In the special case when `A` is a C*-algebra, the M-ideals are exactly the norm-closed
two-sided ideals of `A`, when `A` is also a W*-algebra the M-summands are exactly the weak*-closed
two-sided ideals of `A`.

## Implementation notes

The approach to showing that the L-projections form a Boolean algebra is inspired by
`MeasureTheory.MeasurableSpace`.

Instead of using `P : X →L[𝕜] X` to represent projections, we use an arbitrary ring `M` with a
faithful action on `X`. `ContinuousLinearMap.apply_module` can be used to recover the `X →L[𝕜] X`
special case.

## References

* [Behrends, M-structure and the Banach-Stone Theorem][behrends1979]
* [Harmand, Werner, Werner, M-ideals in Banach spaces and Banach algebras][harmandwernerwerner1993]

## Tags

M-summand, M-projection, L-summand, L-projection, M-ideal, M-structure

-/

variable (X : Type _) [NormedAddCommGroup X]

variable {M : Type _} [Ring M] [Module M X]

--porting note: Mathlib3 uses names with uppercase 'L' for L-projections
set_option linter.uppercaseLean3 false

/-- A projection on a normed space `X` is said to be an L-projection if, for all `x` in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure IsLprojection (P : M) : Prop where
  proj : IsIdempotentElem P
  Lnorm : ∀ x : X, ‖x‖ = ‖P • x‖ + ‖(1 - P) • x‖
#align is_Lprojection IsLprojection

/-- A projection on a normed space `X` is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure IsMprojection (P : M) : Prop where
  proj : IsIdempotentElem P
  Mnorm : ∀ x : X, ‖x‖ = max ‖P • x‖ ‖(1 - P) • x‖
#align is_Mprojection IsMprojection

variable {X}

namespace IsLprojection

--porting note: The liturature always uses uppercase 'L' for L-projections
theorem Lcomplement {P : M} (h : IsLprojection X P) : IsLprojection X (1 - P) :=
  ⟨h.proj.one_sub, fun x => by
    rw [add_comm, sub_sub_cancel]
    exact h.Lnorm x⟩
#align is_Lprojection.Lcomplement IsLprojection.Lcomplement

theorem Lcomplement_iff (P : M) : IsLprojection X P ↔ IsLprojection X (1 - P) :=
  ⟨Lcomplement, fun h => sub_sub_cancel 1 P ▸ h.Lcomplement⟩
#align is_Lprojection.Lcomplement_iff IsLprojection.Lcomplement_iff

      rw [GE.ge] at e1
      --porting note: Bump index in nth_rewrite
      nth_rewrite 2 [← add_zero ‖R • x‖]  at e1
      rw [add_le_add_iff_left, two_smul, ← two_mul] at e1
      rw [le_antisymm_iff]
      refine' ⟨_, norm_nonneg _⟩
      rwa [← MulZeroClass.mul_zero (2 : ℝ), mul_le_mul_left (show (0 : ℝ) < 2 by norm_num)] at e1
  have QP_eq_QPQ : Q * P = Q * P * Q :=
    by
    have e1 : P * (1 - Q) = P * (1 - Q) - (Q * P - Q * P * Q) :=
      calc
        P * (1 - Q) = (1 - Q) * P * (1 - Q) := by rw [PR_eq_RPR (1 - Q) h₂.Lcomplement]

        --porting note: noncomm_ring tactic not yet ported, so complete proof with rewrites for now
        _ = 1 * (P * (1 - Q)) - Q * (P * (1 - Q)) := by rw [mul_assoc, sub_mul]
        _ = P * (1 - Q) - Q * (P * (1 - Q)) := by rw [one_mul]
        _ = P * (1 - Q) - Q * (P - P * Q) := by rw [mul_sub, mul_one]
        _ = P * (1 - Q) - (Q * P - Q * P * Q) := by rw [mul_sub Q, mul_assoc]
    rwa [eq_sub_iff_add_eq, add_right_eq_self, sub_eq_zero] at e1
  show P * Q = Q * P
  · rw [QP_eq_QPQ, PR_eq_RPR Q h₂]
#align is_Lprojection.commute IsLprojection.commute

theorem mul [FaithfulSMul M X] {P Q : M} (h₁ : IsLprojection X P) (h₂ : IsLprojection X Q) :
    IsLprojection X (P * Q) := by
  refine' ⟨IsIdempotentElem.mul_of_commute (h₁.commute h₂) h₁.proj h₂.proj, _⟩
  intro x
  refine' le_antisymm _ _
  · calc
      ‖x‖ = ‖(P * Q) • x + (x - (P * Q) • x)‖ := by rw [add_sub_cancel'_right ((P * Q) • x) x]
      _ ≤ ‖(P * Q) • x‖ + ‖x - (P * Q) • x‖ := by apply norm_add_le
      _ = ‖(P * Q) • x‖ + ‖(1 - P * Q) • x‖ := by rw [sub_smul, one_smul]

  · calc
      ‖x‖ = ‖P • Q • x‖ + (‖Q • x - P • Q • x‖ + ‖x - Q • x‖) := by
        rw [h₂.Lnorm x, h₁.Lnorm (Q • x), sub_smul, one_smul, sub_smul, one_smul, add_assoc]
      _ ≥ ‖P • Q • x‖ + ‖Q • x - P • Q • x + (x - Q • x)‖ :=
        ((add_le_add_iff_left ‖P • Q • x‖).mpr (norm_add_le (Q • x - P • Q • x) (x - Q • x)))
      _ = ‖(P * Q) • x‖ + ‖(1 - P * Q) • x‖ := by
        rw [sub_add_sub_cancel', sub_smul, one_smul, mul_smul]

#align is_Lprojection.mul IsLprojection.mul

theorem join [FaithfulSMul M X] {P Q : M} (h₁ : IsLprojection X P) (h₂ : IsLprojection X Q) :
    IsLprojection X (P + Q - P * Q) := by
  convert (Lcomplement_iff _).mp (h₁.Lcomplement.mul h₂.Lcomplement) using 1
  --porting note: noncomm_ring tactic not yet ported, so complete proof with rewrites for now
  rw [sub_mul, one_mul, sub_sub, sub_sub_self, mul_sub, mul_one, add_sub, add_comm]
#align is_Lprojection.join IsLprojection.join

--porting note: Advice is to explicitly name instances
-- https://github.com/leanprover-community/mathlib4/wiki/Porting-wiki#some-common-fixes
instance Subtype.hasCompl : HasCompl { f : M // IsLprojection X f } :=
  ⟨fun P => ⟨1 - P, P.prop.Lcomplement⟩⟩

@[simp]
theorem coe_compl (P : { P : M // IsLprojection X P }) : ↑(Pᶜ) = (1 : M) - ↑P :=
  rfl
#align is_Lprojection.coe_compl IsLprojection.coe_compl

instance Subtype.inf [FaithfulSMul M X] : Inf { P : M // IsLprojection X P } :=
  ⟨fun P Q => ⟨P * Q, P.prop.mul Q.prop⟩⟩

@[simp]
theorem coe_inf [FaithfulSMul M X] (P Q : { P : M // IsLprojection X P }) :
    ↑(P ⊓ Q) = (↑P : M) * ↑Q :=
  rfl
#align is_Lprojection.coe_inf IsLprojection.coe_inf

instance Subtype.sup [FaithfulSMul M X] : Sup { P : M // IsLprojection X P } :=
  ⟨fun P Q => ⟨P + Q - P * Q, P.prop.join Q.prop⟩⟩

@[simp]
theorem coe_sup [FaithfulSMul M X] (P Q : { P : M // IsLprojection X P }) :
    ↑(P ⊔ Q) = (↑P : M) + ↑Q - ↑P * ↑Q :=
  rfl
#align is_Lprojection.coe_sup IsLprojection.coe_sup

instance Subtype.sdiff [FaithfulSMul M X] : SDiff { P : M // IsLprojection X P } :=
  ⟨fun P Q => ⟨P * (1 - Q), P.prop.mul Q.prop.Lcomplement⟩⟩

@[simp]
theorem coe_sdiff [FaithfulSMul M X] (P Q : { P : M // IsLprojection X P }) :
    ↑(P \ Q) = (↑P : M) * (1 - ↑Q) :=
  rfl
#align is_Lprojection.coe_sdiff IsLprojection.coe_sdiff

instance Subtype.partialOrder [FaithfulSMul M X] :
    PartialOrder { P : M // IsLprojection X P } where
  le P Q := (↑P : M) = ↑(P ⊓ Q)
  le_refl P := by simpa only [coe_inf, ← sq] using P.prop.proj.eq.symm
  le_trans P Q R h₁ h₂ := by
    simp only [coe_inf] at h₁ h₂⊢
    rw [h₁, mul_assoc, ← h₂]
  le_antisymm P Q h₁ h₂ := Subtype.eq (by convert (P.prop.commute Q.prop).eq)

theorem le_def [FaithfulSMul M X] (P Q : { P : M // IsLprojection X P }) :
    P ≤ Q ↔ (P : M) = ↑(P ⊓ Q) :=
  Iff.rfl
#align is_Lprojection.le_def IsLprojection.le_def

instance Subtype.zero : Zero { P : M // IsLprojection X P } :=
  ⟨⟨0, ⟨by rw [IsIdempotentElem, MulZeroClass.zero_mul], fun x => by
        simp only [zero_smul, norm_zero, sub_zero, one_smul, zero_add]⟩⟩⟩

@[simp]
theorem coe_zero : ↑(0 : { P : M // IsLprojection X P }) = (0 : M) :=
  rfl
#align is_Lprojection.coe_zero IsLprojection.coe_zero

instance Subtype.one : One { P : M // IsLprojection X P } :=
  ⟨⟨1, sub_zero (1 : M) ▸ (0 : { P : M // IsLprojection X P }).prop.Lcomplement⟩⟩

@[simp]
theorem coe_one : ↑(1 : { P : M // IsLprojection X P }) = (1 : M) :=
  rfl
#align is_Lprojection.coe_one IsLprojection.coe_one

instance Subtype.boundedOrder [FaithfulSMul M X] :
    BoundedOrder { P : M // IsLprojection X P } where
  top := 1
  le_top P := (mul_one (P : M)).symm
  bot := 0
  bot_le P := (MulZeroClass.zero_mul (P : M)).symm

@[simp]
theorem coe_bot [FaithfulSMul M X] :
  --porting note: Manual correction of name required here
    ↑(BoundedOrder.toOrderBot.toBot.bot : { P : M // IsLprojection X P }) = (0 : M) :=
  rfl
#align is_Lprojection.coe_bot IsLprojection.coe_bot

@[simp]
theorem coe_top [FaithfulSMul M X] :
  --porting note: Manual correction of name required here
    ↑(BoundedOrder.toOrderTop.toTop.top : { P : M // IsLprojection X P }) = (1 : M) :=
  rfl
#align is_Lprojection.coe_top IsLprojection.coe_top

theorem compl_mul {P : { P : M // IsLprojection X P }} {Q : M} : ↑(Pᶜ) * Q = Q - ↑P * Q := by
  rw [coe_compl, sub_mul, one_mul]
#align is_Lprojection.compl_mul IsLprojection.compl_mul

theorem mul_compl_self {P : { P : M // IsLprojection X P }} : (↑P : M) * ↑(Pᶜ) = 0 := by
  rw [coe_compl, mul_sub, mul_one, P.prop.proj.eq, sub_self]
#align is_Lprojection.mul_compl_self IsLprojection.mul_compl_self

theorem distrib_lattice_lemma [FaithfulSMul M X] {P Q R : { P : M // IsLprojection X P }} :
    ((↑P : M) + ↑(Pᶜ) * R) * (↑P + ↑Q * ↑R * ↑(Pᶜ)) = ↑P + ↑Q * ↑R * ↑(Pᶜ) := by
  rw [add_mul, mul_add, mul_add, (mul_assoc _ (R : M) (↑Q * ↑R * ↑(Pᶜ))),
    ← mul_assoc (R : M) (↑Q * ↑R) _, ← coe_inf Q, (Pᶜ.prop.commute R.prop).eq,
    ((Q ⊓ R).prop.commute (Pᶜ).prop).eq, (R.prop.commute (Q ⊓ R).prop).eq, coe_inf Q,
    mul_assoc (Q : M), ←mul_assoc, mul_assoc (R : M), (Pᶜ.prop.commute P.prop).eq, mul_compl_self,
    MulZeroClass.zero_mul, MulZeroClass.mul_zero, zero_add, add_zero, ← mul_assoc, P.prop.proj.eq,
    R.prop.proj.eq, ←coe_inf Q, mul_assoc, ((Q ⊓ R).prop.commute (Pᶜ).prop).eq, ← mul_assoc,
    Pᶜ.prop.proj.eq]
#align is_Lprojection.distrib_lattice_lemma IsLprojection.distrib_lattice_lemma

--porting note: In mathlib3 we were able to directly show that `{ P : M // IsLprojection X P }` was
--  an instance of a `DistribLattice`. Trying to do that in mathlib4 fails with "error:
-- (deterministic) timeout at 'whnf', maximum number of heartbeats (800000) has been reached"
-- My workaround is to show instance Lattice first
instance [FaithfulSMul M X] : Lattice { P : M // IsLprojection X P } where
  le_sup_left P Q := by
    rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, ← mul_assoc, P.prop.proj.eq,
      sub_self, add_zero]
  le_sup_right P Q := by
    rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, (P.prop.commute Q.prop).eq,
      ← mul_assoc, Q.prop.proj.eq, add_sub_cancel'_right]
  sup_le P Q R := by
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_sup, coe_inf, coe_sup, ← add_sub, add_mul,
      sub_mul, mul_assoc]
    intro h₁ h₂
    rw [← h₂, ← h₁]
  inf_le_left P Q := by
    rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc, (Q.prop.commute P.prop).eq, ← mul_assoc,
      P.prop.proj.eq]
  inf_le_right P Q := by rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc, Q.prop.proj.eq]
  le_inf P Q R := by
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_inf, coe_inf, ← mul_assoc]
    intro h₁ h₂
    rw [← h₁, ← h₂]

instance Subtype.distribLattice [FaithfulSMul M X] :
    DistribLattice { P : M // IsLprojection X P } where
  le_sup_inf P Q R := by
    have e₁ : ↑((P ⊔ Q) ⊓ (P ⊔ R)) = ↑P + ↑Q * (R : M) * ↑(Pᶜ) := by
      rw [coe_inf, coe_sup, coe_sup, ← add_sub, ← add_sub, ← compl_mul, ← compl_mul, add_mul,
        mul_add, ((Pᶜ).prop.commute Q.prop).eq, mul_add, ← mul_assoc, mul_assoc (Q: M),
        ((Pᶜ).prop.commute P.prop).eq, mul_compl_self, MulZeroClass.zero_mul, MulZeroClass.mul_zero,
        zero_add, add_zero, ← mul_assoc, mul_assoc (Q : M), P.prop.proj.eq, (Pᶜ).prop.proj.eq,
        mul_assoc, ((Pᶜ).prop.commute R.prop).eq, ← mul_assoc]
    have e₂ : ↑((P ⊔ Q) ⊓ (P ⊔ R)) * ↑(P ⊔ Q ⊓ R) = (P : M) + ↑Q * ↑R * ↑(Pᶜ) := by
      rw [coe_inf, coe_sup, coe_sup, coe_sup, ← add_sub, ← add_sub, ← add_sub, ← compl_mul, ←
        compl_mul, ← compl_mul, ((Pᶜ).prop.commute (Q ⊓ R).prop).eq, coe_inf, mul_assoc,
        distrib_lattice_lemma, (Q.prop.commute R.prop).eq, distrib_lattice_lemma]
    rw [le_def, e₁, coe_inf, e₂]

instance Subtype.BooleanAlgebra [FaithfulSMul M X] :
    BooleanAlgebra { P : M // IsLprojection X P } :=
--porting note: use explicitly specified instance names
  { IsLprojection.Subtype.hasCompl,
    IsLprojection.Subtype.sdiff,
    IsLprojection.Subtype.boundedOrder with
    inf_compl_le_bot := fun P =>
      (Subtype.ext (by rw [coe_inf, coe_compl, coe_bot, ← coe_compl, mul_compl_self])).le
    top_le_sup_compl := fun P =>
      (Subtype.ext
        (by
          rw [coe_top, coe_sup, coe_compl, add_sub_cancel'_right, ← coe_compl, mul_compl_self,
            sub_zero])).le
    sdiff_eq := fun P Q => Subtype.ext <| by rw [coe_sdiff, ← coe_compl, coe_inf] }

end IsLprojection


import Basic
import Tangle

def isBraid : Wall → Prop
| [] => true
| bs::w => !bs.elem Brick.Cap ∧ !bs.elem Brick.Cup ∧
  match w with
  | [] => true
  | bs'::w => bs.codomain = bs'.domain ∧ isBraid (bs'::w)
def Braid := { w : Wall // isBraid w }

namespace Braid

theorem is_tangle : isBraid w → isTangle w := by
  intro hb
  induction w with
  | nil => simp [isTangle]
  | cons bs w hi =>
      cases w with
      | nil => simp [isTangle]
      | cons bs' w =>
          rewrite [isBraid] at hb
          rewrite [isTangle]
          exact And.intro hb.right.right.left (hi hb.right.right.right)

def tangle (b : Braid) : Tangle := ⟨b.val, is_tangle b.property⟩

-- TODO
def permute (b : Braid ) (as : List α) (hdom : b.tangle.domain = as.length) : List α :=
  sorry

end Braid


theorem ex1 (p : Prop) (h1 : p) (h2 : p → False) : α := by
  contradiction

theorem ex2 (p : Prop) (h1 : p) (h2 : ¬ p) : α := by
  contradiction

theorem ex3 (p : Prop) (h1 : id p) (h2 : ¬ p) : α := by
  contradiction

theorem ex4 (p : Prop) (h1 : id p) (h2 : id (Not p)) : α := by
  contradiction

theorem ex5 (h : x+1 = 0) : α := by
  contradiction

theorem ex6 (h : 0+0 ≠ 0) : α := by
  contradiction

theorem ex7 (x : α) (h : Not (x = x)) : α := by
  contradiction

theorem ex8 (h : 0+0 = 0 → False) : α := by
  contradiction

theorem ex9 (h : 10 = 20) : α := by
  contradiction

theorem ex10 (h : [] = [1, 2, 3]) : α := by
  contradiction

theorem ex11 (h : id [] = [1, 2, 3]) : α := by
  contradiction

theorem ex12 (h : False) : α := by
  contradiction

theorem ex13 (h : id False) : α := by
  contradiction

theorem ex14 (h : 100000000 ≤ 20) : α := by
  contradiction

theorem ex15 (x : α) (h : x = x → False) : α := by
  contradiction

theorem ex16 (xs : List α) (h : xs = [] → False) : Nonempty α := by
  cases xs using List.rec with
  | nil      => contradiction
  | cons x _ => apply Nonempty.intro; assumption