inductive person : Type
| dan, tina
open person

@[reducible] def timestep := ℕ

constant is_marked : person → Prop

constant knows (t : timestep) (n : person) (p : Prop) : Prop

@[reducible] def mk_prec (p : timestep → person → Prop) : ℕ → timestep → person → Prop
| 0     t  n  := p t n
| (d+1) t₁ n₁ := ∀ {t₂ : timestep} {n₂ : person}, knows t₁ n₁ (mk_prec d t₂ n₂)

@[reducible] def pcommon_knowledge (pr : timestep → person → Prop) : Prop :=
  ∀ (d : ℕ) {t : timestep} {n : person}, mk_prec pr d t n

axiom knows_persists {p : Prop}   : pcommon_knowledge (λ t n, knows t n p → knows (t+1) n p)
axiom knows_lam      {p q : Prop} : pcommon_knowledge (λ t n, (knows t n p → knows t n q) → knows t n (p → q))
axiom knows_mp       {p q : Prop} : pcommon_knowledge (λ t n, knows t n (p → q) → knows t n p → knows t n q)
axiom knows_and      {p q : Prop} : pcommon_knowledge (λ t n, knows t n p → knows t n q → knows t n (p ∧ q))
axiom knows_sound    {p : Prop}   : pcommon_knowledge (λ t n, knows t n p → p)
axiom knows_cancel   {p q : Prop} : pcommon_knowledge (λ t n, knows t n (¬ p) → knows t n (p ∨ q) → knows t n q)
axiom knows_id       {p : Prop}   : pcommon_knowledge (λ t n, knows t n (p → p))
axiom knows_em       {p q : Prop} : pcommon_knowledge (λ t n, knows t n (p → q) → knows t n (¬ p → q) → knows t n q)

axiom oracle : pcommon_knowledge (λ t n, knows t n (is_marked dan ∨ is_marked tina))

@[reducible] def mk_rec (p : timestep → person → Prop) (t₁ t₂ : timestep) : person → ℕ → Prop
| n  0     := p t₂ n
| n₁ (d+1) := ∀ {n₂ : person}, knows t₁ n₁ (mk_rec n₂ d)

@[reducible] def common_knowledge (pr : timestep → person → Prop) (t₁ t₂ : timestep) : Prop :=
  ∀ (d : ℕ) {n : person}, mk_rec pr t₁ t₂ n d

axiom nobody_leaves : ∀ (t₁ t₂ : timestep), t₁ < 2 → t₁ < t₂ → common_knowledge (λ t n, ¬ knows t₁ n (is_marked n)) t₂ t₁

theorem T1 : knows 0 dan ((¬ is_marked dan) → knows 1 tina (is_marked tina)) :=
suffices H_suffices : knows 0 dan (¬ is_marked dan) → knows 0 dan (knows 1 tina (is_marked tina)), from knows_lam 0 H_suffices,
assume H1 : knows 0 dan (¬ is_marked dan),
show knows 0 dan (knows 1 tina (is_marked tina)), from

have H3a : knows 0 dan (knows 1 tina (is_marked dan → is_marked tina)), from
  suffices H_suffices : knows 0 dan (knows 1 tina (is_marked dan) → knows 1 tina (is_marked tina)),
    from knows_mp 0 (knows_lam 1) H_suffices,
  suffices H_suffices : knows 0 dan (knows 1 tina (is_marked dan)) → knows 0 dan (knows 1 tina (is_marked tina)),
    from knows_lam 0 H_suffices,
  assume h1 : knows 0 dan (knows 1 tina (is_marked dan)),
  absurd (knows_sound 0 (knows_sound 0 h1)) (knows_sound 0 H1),

have H3b : knows 0 dan (knows 1 tina (¬ is_marked dan → is_marked tina)), from
  suffices H_suffices : knows 0 dan (knows 1 tina (¬ is_marked dan) → knows 1 tina (is_marked tina)),
    from knows_mp 0 (knows_lam 1) H_suffices,
  suffices H_suffices : knows 0 dan (knows 1 tina (¬ is_marked dan)) → knows 0 dan (knows 1 tina (is_marked tina)),
    from knows_lam 0 H_suffices,
  assume h1 : knows 0 dan (knows 1 tina (¬ is_marked dan)),
  have   h2 : knows 0 dan (knows 1 tina (is_marked dan ∨ is_marked tina)), from knows_mp 0 (knows_persists 1) (oracle 1),
  have   h3 : knows 0 dan (knows 1 tina (¬ is_marked dan))
              → knows 0 dan (knows 1 tina (is_marked dan ∨ is_marked tina) → knows 1 tina (is_marked tina)), from knows_mp 0 (knows_cancel 1),
  have   h4 : knows 0 dan (knows 1 tina (¬ is_marked dan))
              → knows 0 dan (knows 1 tina (is_marked dan ∨ is_marked tina))
              → knows 0 dan (knows 1 tina (is_marked tina)), from assume z1 z2, knows_mp 0 (h3 z1) z2,
  h4 h1 (knows_mp 0 (knows_persists 1) (oracle 1)),

have Hem : ∀ {p q : Prop}, knows 0 dan (knows 1 tina (p → q)) → knows 0 dan (knows 1 tina ((¬ p) → q)) → knows 0 dan (knows 1 tina q), from
  begin intros p q z1, apply knows_mp 0, revert z1, apply knows_mp 0, exact knows_em 1 end,

Hem H3a H3b

theorem T2 : knows 0 dan (¬ knows 1 tina (is_marked tina) → is_marked dan) :=
suffices H_suffices : knows 0 dan (¬ knows 1 tina (is_marked tina)) → knows 0 dan (is_marked dan), from knows_lam 0 H_suffices,
assume H1 : knows 0 dan (¬ knows 1 tina (is_marked tina)),
have   H2 : knows 0 dan ((¬ is_marked dan) → knows 1 tina (is_marked tina)), from T1,
have   H3a : knows 0 dan (is_marked dan → is_marked dan), from knows_id 0,
have   H3b : knows 0 dan (¬ is_marked dan → is_marked dan), from
  suffices H_suffices : knows 0 dan (¬ is_marked dan) → knows 0 dan (is_marked dan), from knows_lam 0 H_suffices,
  assume h1 : knows 0 dan (¬ is_marked dan),
  show        knows 0 dan (is_marked dan), from
  have   h2 : knows 0 dan (knows 1 tina (is_marked tina)), from knows_mp 0 H2 h1,
  absurd (knows_sound 0 h2) (knows_sound 0 H1),
knows_em 0 H3a H3b

theorem T3 : knows 2 dan (is_marked dan) :=
have H1 : knows 2 dan (¬ knows 1 tina (is_marked tina) → is_marked dan), from knows_persists 0 (knows_persists 0 T2),
have H2 : knows 2 dan (¬ knows 1 tina (is_marked tina)), from nobody_leaves 1 2 (nat.lt_succ_self _) (nat.lt_succ_self _) 1,
show      knows 2 dan (is_marked dan), from
knows_mp 0 H1 H2


import algebra.group -- for is_add_group_hom
import group_theory.subgroup -- for kernels
import algebra.module
import tactic.linarith
import tactic.omega
import tactic.fin_cases
import add_group_hom.basic
import algebra.pi_instances
import G_module.basic

def cochain(n:ℕ)(G : Type*) [group G] (M : Type*) [add_comm_group M] [G_module G M] :=
(fin n → G) → M

def F{n:ℕ}(j:ℕ) {G : Type*}[group G](g:fin (n+1)→ G):fin n→ G
:= λ k,  if k.val < j then g ⟨k.val, lt_trans k.2 $ lt_add_one _⟩ else
         if k.val=j then g ⟨k.val, lt_trans k.2 $ lt_add_one _⟩ *g ⟨k.val+1, add_lt_add_right k.2 1⟩
         else g  ⟨k.val+1, add_lt_add_right k.2 1⟩

def XYZ (n : ℕ): fin n → fin (n + 1) := coe
example : XYZ 3 ⟨2,by linarith⟩ = ⟨2, by linarith⟩ := rfl

--set_option pp.all true
theorem degenerate{n:ℕ}{j:ℕ}{k:ℕ}{G : Type*}[group G](h:j≤ k)(g:fin (n+2)→ G):
F j (F (k+1) g) = F k (F j g):=
begin
unfold F,
funext t,
cases t with t ht,
-- I got this line by typing "dsimp"
show ite (t < j) (ite (t < k + 1) (g ⟨t, _⟩) (ite (t = k + 1) (g ⟨t, _⟩ * g ⟨t + 1, _⟩) (g ⟨t + 1, _⟩)))
      (ite (t = j)
         (ite (t < k + 1) (g ⟨t, _⟩) (ite (t = k + 1) (g ⟨t, _⟩ * g ⟨t + 1, _⟩) (g ⟨t + 1, _⟩)) *
            ite (t + 1 < k + 1) (g ⟨t + 1, _⟩)
              (ite (t + 1 = k + 1) (g ⟨t + 1, _⟩ * g ⟨t + 1 + 1, _⟩) (g ⟨t + 1 + 1, _⟩)))
         (ite (t + 1 < k + 1) (g ⟨t + 1, _⟩)
            (ite (t + 1 = k + 1) (g ⟨t + 1, _⟩ * g ⟨t + 1 + 1, _⟩) (g ⟨t + 1 + 1, _⟩)))) =
    ite (t < k) (ite (t < j) (g ⟨t, _⟩) (ite (t = j) (g ⟨t, _⟩ * g ⟨t + 1, _⟩) (g ⟨t + 1, _⟩)))
      (ite (t = k)
         (ite (t < j) (g ⟨t, _⟩) (ite (t = j) (g ⟨t, _⟩ * g ⟨t + 1, _⟩) (g ⟨t + 1, _⟩)) *
            ite (t + 1 < j) (g ⟨t + 1, _⟩)
              (ite (t + 1 = j) (g ⟨t + 1, _⟩ * g ⟨t + 1 + 1, _⟩) (g ⟨t + 1 + 1, _⟩)))
         (ite (t + 1 < j) (g ⟨t + 1, _⟩)
            (ite (t + 1 = j) (g ⟨t + 1, _⟩ * g ⟨t + 1 + 1, _⟩) (g ⟨t + 1 + 1, _⟩)))),
by_cases h1 : t < j,
{ rw if_pos h1,
  rw if_pos (lt_trans h1 (nat.lt_succ_of_le h)),
  --rw if_pos (show t < k, from lt_of_lt_of_le h1 h),
  rw if_pos (lt_of_lt_of_le h1 h),
  rw if_pos h1
},
rw if_neg h1,
by_cases h2:t=j,
{ rw if_pos (h2),
  cases h2,
  rw if_pos (nat.lt_succ_of_le h),
  rw le_iff_eq_or_lt at h,
  cases h,
  {cases h,
  rw if_neg (lt_irrefl (j+1)),
  rw if_pos (rfl),
  rw if_neg (lt_irrefl j),
  rw if_pos (rfl),
  rw if_neg (lt_irrefl j),
  rw if_pos (rfl),
  rw if_neg (show ¬ (j+1<j), from mt (le_of_lt) (nat.not_succ_le_self j) ),
  rw if_neg (show ¬ (j+1=j), from mt (le_of_eq) (nat.not_succ_le_self j) ),
  rw mul_assoc,
    },
  {rw if_pos (nat.succ_lt_succ h),
  rw if_pos h,
  rw if_neg (lt_irrefl j),
  rw if_pos rfl,
  },
},
rw if_neg h2,
by_cases h3 : t < k,
{  rw if_pos (nat.lt_succ_iff.2 h3),
   rw if_pos h3,
   rw if_neg h1,
   rw if_neg h2,

},
rw if_neg (mt nat.lt_succ_iff.1 h3),
by_cases h4 : t = k,
{  cases h4,
   rw if_pos rfl,
   rw if_neg (lt_irrefl k),
   rw if_pos rfl,
   rw if_neg h1,
   rw if_neg h2,
   rw if_neg (not_lt_of_le (le_trans h (nat.le_succ k))),
   rw if_neg (ne_of_gt (nat.succ_le_succ h) : ¬ (k + 1 = j)),
},
rw if_neg (mt (nat.succ_inj) h4),
rw if_neg h3,
rw if_neg h4,
have h5: ¬ t+1<j, by linarith,
rw if_neg h5,
have h6: ¬ t+1=j, by linarith,
rw if_neg h6,
-- no goal!
end

--example (j : ℕ) : ¬ (j+1<j) := mt (le_of_lt) (nat.not_succ_le_self j)

theorem neg_one_power(n:ℕ )(G : Type*) [group G] (M : Type*) [add_comm_group M] [G_module G M]
: ∀ m : M, ((-1:ℤ)^n  + (-1:ℤ)^(n+1)) • m = 0 :=
begin
intro m,
induction n with h hd,
norm_num,
rw nat.succ_eq_add_one,
rw pow_add (-1:ℤ ) h 1,
rw pow_add (-1:ℤ ) h (1+1),
norm_num,

end

--open_locale add_group

theorem neg_degenerate (n:ℕ)(j:ℕ)(k:ℕ)(G : Type*)[group G](g:fin (n+2)→ G)(h:j≤ k) (M : Type*) [add_comm_group M] [G_module G M](v:cochain n G M)
: (-1:ℤ)^(j+k+1) • (v (F j (F (k+1) g))) + (-1:ℤ)^(j+k)• (v (F k (F j g)))=0:=
begin
rw degenerate h,
--show gsmul ((-1) ^ n) (v (F k (F j g))) + gsmul ((-1) ^ (n + 1)) (v (F k (F j g))) = 0,
rw <-add_smul,
--show ((-1 : ℤ) ^ n + (-1) ^ (n + 1)) • (v (F k (F j g))) = 0,
rw add_comm,
rw neg_one_power (j+k) G M,
end

open finset

def finset.sum_smul2 {α : Type*} {R : Type*} [semiring R] {M : Type*} [add_comm_monoid M]
  [semimodule R M] (s : finset α) (r : R) (f : α → M) :
    finset.sum s (λ (x : α), (r • (f x))) = r • (finset.sum s f) :=
by haveI := classical.dec_eq α; exact
finset.induction_on s (by simp) (by simp [_root_.smul_add] {contextual := tt})

theorem pow_add'(a : ℤ ) (m n : ℕ): a ^ m * a ^ n=a ^ (m + n) :=
begin
rw pow_add,
end

--theorem double_sum_zero (n':ℕ)(G : Type*)[group G](g:fin (n'+3)→ G)(M : Type*) [add_comm_group M] [G_module G M](v:cochain (n'+1) G M):
--(range (n'+1)).sum(λ i, (-1:ℤ)^(i+1)• (range i).sum(λ j, (-1:ℤ )^(j+1)• (v (F j (F i g))))) =0:=
--begin

--simp only [(finset.sum_smul' _ _ _).symm, smul_smul, pow_add],
--norm_num,
--simp only [pow_add'],
----simp only [degenerate2],
--sorry
--end

theorem degenerate2{n:ℕ}{j:ℕ}{k:ℕ}{G : Type*}[group G](h:j≤ k)(g:fin (n+2)→ G):
 F k (F j g)=F j (F (k+1) g) :=
 begin
 rw degenerate,
 exact h,
 end

def F2{n:ℕ}{G : Type*}[group G](g:fin (n+2)→ G){M : Type*} [add_comm_group M] [G_module G M](v:cochain n G M): ℕ × ℕ → M:=
λ j, (-1:ℤ)^(j.1+j.2)• v (F (j.2) (F (j.1) g))

theorem F2_degenerate {n:ℕ}{j:ℕ}{k:ℕ}(h:j≤ k){G : Type*}[group G](g:fin (n+2)→ G){M : Type*} [add_comm_group M] [G_module G M](v:cochain n G M):
F2 g v (k+1, j)+F2 g v (j, k)=0:=
begin
unfold F2,
norm_num,
rw degenerate,
rw <-add_smul,
rw <-add_assoc,
rw neg_one_power (j+k) G M,
exact h,
end

def invo : ℕ × ℕ → ℕ × ℕ :=
λ jk, if jk.1 ≤ jk.2 then ⟨jk.2 + 1, jk.1⟩ else ⟨jk.2, jk.1 - 1⟩

lemma invo_def1 {jk : ℕ × ℕ} (h : jk.1 ≤ jk.2) :
  invo jk = ⟨jk.2 + 1, jk.1⟩ := if_pos h

lemma invo_ineq1 {jk : ℕ × ℕ}
  (h : jk.1 ≤ jk.2) :
  ¬(invo jk).1 ≤ (invo jk).2 :=
begin
  unfold invo,
  rw if_pos h,
  exact not_le.2 (nat.lt_succ_of_le h),
end

lemma invo_ineq2 {jk : ℕ × ℕ}
  (h : ¬jk.1 ≤ jk.2) :
  (invo jk).1 ≤ (invo jk).2 :=
begin
  unfold invo,
  rw if_neg h,
  rw not_le at h,
  exact nat.pred_le_pred h,
end

lemma invo_aux {j k : ℕ} (h : ¬j ≤ k) : j - 1 + 1 = j :=
nat.succ_pred_eq_of_pos $ lt_of_le_of_lt (zero_le _) (lt_of_not_ge h)

lemma invo_invo (jk : ℕ × ℕ) : invo (invo jk) = jk :=
begin
  unfold invo,
  split_ifs,
  { exfalso, linarith},
  { ext, refl, simp},
  { ext, dsimp, exact invo_aux h, refl},
  { exfalso,
    rw not_le at h_1,
    rw nat.lt_iff_add_one_le at h_1,
    rw invo_aux h at h_1,
    linarith,}
end

--example (n:ℕ )(x:ℕ){G : Type*}[group G](g:fin (n+2)→ G)(M : Type*) [add_comm_group M] [G_module G M](v:cochain n G M):F2 g v(x,x)=v (F (x) (F (x) g)):=rfl
--#print prod
--#check finset.product
--#check finset.range
theorem double_sum_zero1 (n':ℕ)(G : Type*)[group G](g:fin (n'+3)→ G)(M : Type*) [add_comm_group M] [G_module G M](v:cochain (n'+1) G M):
(range (n'+3)).sum(λ i, (range (n'+2)).sum(λ j, (F2 g v (i,j)))) =0:=
begin
  rw <-sum_product,
  apply sum_involution (λ jk h, invo jk),
  { intros jk hjk,
    let j := jk.1,
    let k := jk.2,
    -- do we need these next three lines?
    --cases mem_product.1 hjk with hj hk,
    --replace hj : j < n' + 1 := mem_range.1 hj,
    --replace hk : k < n' := mem_range.1 hk,
    by_cases hin : j ≤ k,
    { rw add_comm,
      convert F2_degenerate hin g v,
      exact invo_def1 hin},
    { convert F2_degenerate (invo_ineq2 hin) g v,
      unfold invo,
      rw if_neg hin,
      ext,
        exact (invo_aux hin).symm,
      refl,
    }
  },
  { intros jk hjk _ h,
    dsimp at h,
    by_cases hin : jk.1 ≤ jk.2,
    { apply invo_ineq1 hin,
      rwa h},
    { have h2 := invo_ineq2 hin,
      apply hin,
      rwa h at h2}},
  { intros jk hjk,
    dsimp,
    exact invo_invo jk, },
  { intros jk hjk,

    dsimp,
    unfold invo,
    let j := jk.1,
    let k := jk.2,
    -- do we need these next three lines?
    cases mem_product.1 hjk with hj hk,
    replace hj : j < n' + 3 := mem_range.1 hj,
    replace hk : k < n'+ 2 := mem_range.1 hk,
    rw finset.mem_product,
    split_ifs,
    split,
    show k+1∈ range(n'+3),
    rw mem_range,
    linarith,
    show j∈ range(n'+2),
    rw mem_range,
    exact lt_of_le_of_lt h hk,
    split,
    show k∈ range(n'+3),
    rw mem_range,
    linarith,
    show j-1∈ range(n'+2),
    rw mem_range,
    rw nat.sub_lt_left_iff_lt_add,
    linarith,
    rw not_le at h,
    exact nat.one_le_of_lt h,}
end

--#check @finset.product
--#check @finset.sum_bij
--#check @finset.sum_bind
--#check @finset.sum
--#check finset.bind

--example (a b:ℤ )(M : Type*) [add_comm_group M](c:M):(a+b) • c=a• c+b• c :=begin library_search end
--example (a b:ℕ) :(-a:ℤ ) + (-b:ℤ )=-(a+b) := begin library_search end
--#example (n:ℕ ): (-1:ℤ)^n  + (-1:ℤ)^(n+1)=0 := begin library_search end

--funext t,
--conv begin
--  to_lhs,
 -- simp only [F],
--end,
--split_ifs;try {refl}; try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith};
--rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *,
--change t.val < k + 1 at h_2,
--unfold F,
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--swap,
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},

--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},

--split_ifs; try {refl}; try {rw (show (t : fin(n + 1)).val = t.val, by refl) at *},
--{split_ifs;try {rw (show (↑t : fin(n + 1)).val = t.val, by refl) at *}; try {exfalso;linarith}; try {refl}; try {simp only [mul_assoc]}; try {finish}},
--end

def F_first{n:ℕ} {G : Type*}[group G](g:fin (n+1)→ G):fin n→ G
:= λ k,   g  ⟨k.val+1, add_lt_add_right k.2 1⟩

def d.to_fun {n:ℕ}{G : Type*} [group G] {M : Type*} [add_comm_group M] [G_module G M]
(φ: cochain n G M): (cochain (n+1) G M):= λ(gi: fin (n+1) → G),
gi ⟨0, (by simp)⟩ • φ (λ i, gi ⟨i.val + 1, add_lt_add_right i.2 1⟩)
+(range (n+1)).sum(λ j,(-1:ℤ  )^(j+1)• φ (F j gi))

example (G : Type*) [group G] (M : Type*) [add_comm_group M] [G_module G M]
(φ : cochain 1 G M) (hφ : d.to_fun φ = (λ i, 0)) (g h : G) : φ (λ _, g * h) = φ (λ _, g) + g • φ (λ _, h) :=
begin
  unfold d.to_fun at hφ,
  let glist : fin 2 → G := λ i, if i.val = 0 then g else if i.val = 1 then h else 1,
  have h2 : (λ (gi : fin (1 + 1) → G),
       gi ⟨0, _⟩ • φ (λ (i : fin 1), gi ⟨i.val + 1, _⟩) +
         finset.sum (finset.range (1 + 1)) (λ (j : ℕ), (-1: ℤ) ^ (j + 1) • φ (F j gi))) glist = 0,
    rw hφ,
  dsimp at h2,
  change g • φ (λ (i : fin 1), glist ⟨i.val + 1, _⟩) +
      finset.sum (finset.range (1 + 1)) (λ (j : ℕ), (-1 : ℤ) ^ (j + 1) • φ (F j glist)) =
    0 at h2,
  rw finset.sum_range_succ at h2,
  rw finset.sum_range_succ at h2,
  rw finset.sum_range_zero at h2,
  have H : (-1 : ℤ) ^ (1 + 1) = 1,
    norm_num,
  rw H at h2,
  rw one_smul at h2,
  rw ←add_assoc at h2,
  rw add_zero at h2,
  clear H,
  have H : (-1 : ℤ) ^ (0 + 1) = -1,
    norm_num,
  rw H at h2,
  rw neg_one_smul at h2,
  clear H,
  rw add_neg_eq_zero at h2,
  rw eq_comm at h2,
  rw add_comm at h2,
  convert h2,
  {
    ext,
    cases x with x hx,
    cases (nat.sub_eq_zero_of_le hx),
    refl,
  },
  { ext,
    cases x with x hx,
    cases (nat.sub_eq_zero_of_le hx),
    refl,
  },
  { ext,
    cases x with x hx,
    cases (nat.sub_eq_zero_of_le hx),
    refl,
  }
end
--theorem lt_succ_self{n j:ℕ }{H:j=nat.succ n}:n<j:=begin rw H, exact nat.lt_succ_self n,end
theorem add_one_finset{n:ℕ }{n'=nat.succ n}{j:fin n }:j.1+1<n'+1:=begin
have h2: n<n',
rw H,
exact nat.lt_succ_self n,
--rw H, exact lt_add_one n,
--have h3: j.val<n',
--exact lt.trans j.is_lt h2,
norm_num,
exact lt.trans j.is_lt h2,
end

--example {a b c d:ℕ }{h1:a<c}{h2:b<d} : (a+b) < (c+b) := begin library_search end
theorem F_0_0(n':ℕ){G : Type*}[group G](g:fin (n'+1+1+1)→ G):F 0 g ⟨0, nat.succ_pos (n'+1)⟩ = g⟨ 0, nat.succ_pos (n'+1+1) ⟩ *g⟨ 1,nat.lt_of_sub_eq_succ rfl⟩ :=
begin
refl,
end

theorem F_0_j{n':ℕ}{j:fin (n'+1)}{G : Type*}[group G](g:fin (n'+1+1+1)→ G):F 0 g⟨ j.val+1,nat.lt_succ_iff.mpr j.is_lt

--norm_num,
--have h3:1<2,
--exact nat.lt_succ_self 1,
--exact add_lt_add (lt.trans j.is_lt h2) h3,
--end
⟩ =g⟨ j.val+2, add_lt_add_right j.is_lt 2⟩:=
begin
refl,
end

theorem F_x_0(n' x:ℕ)(h:x>0){G : Type*}[group G](g:fin (n'+1+1+1)→ G):F x g ⟨0, nat.succ_pos (n'+1)⟩ = g⟨ 0, nat.succ_pos (n'+1+1) ⟩:=
begin
unfold F,
rw if_pos h,
end

theorem F_x_j(n' x:ℕ){G : Type*}[group G](g:fin (n'+1+1+1)→ G):F x (λ (j:fin (n'+1+1)), g ⟨j.val+1, nat.lt_succ_iff.mpr j.is_lt,⟩ )
= λ (j:fin (n'+1)), F (x+1) g⟨j.1+1, nat.lt_succ_iff.mpr j.is_lt,⟩:=
begin
unfold F,
funext,
split_ifs,
{refl},
{exfalso,linarith},
{exfalso,linarith},
{exfalso,linarith},
{refl},
{have h5: k.val+1=x+1,
rw h_1,
contradiction,
},
{exfalso,linarith},
{have h5: k.val=x,
exact nat.succ_inj h_3,
contradiction},
{refl},
end
--example {n m:ℕ }(h:n+1=m+1):n=m:=by library_search

theorem sum_range_first{β : Type*} [_inst_1 : add_comm_monoid β] (f : ℕ → β) (n': ℕ):
sum (range (n'+1)) f = f 0 + sum (range n') (λ i, f (i+1)):=
begin
--induction n' with d hd,
--{refl},
--rw sum_range_suc
rw sum_range_succ',
rw add_comm,
end

theorem sum_add_eq_add_sum {β : Type*} [_inst_1 : add_comm_monoid β] (f g: ℕ → β) (n: ℕ): sum (range n) (λ x, f x+g x)=sum (range n) f+sum(range n) g:=
begin
exact sum_add_distrib,
end

--#check @finset.sum_range_succ'
theorem d_square_zero{n:ℕ}{G : Type*} [group G] {M : Type*} [add_comm_group M] [G_module G M]
(φ: cochain n G M):d.to_fun (d.to_fun φ )=λ(gi: fin (n+2) → G), 0:=
begin
  unfold d.to_fun,
  funext,
  dsimp,
  norm_num,
  cases n with n',
  { norm_num,
    rw sum_range_succ,
    rw sum_range_succ,
    rw sum_range_zero,
    norm_num,
    unfold F,
    split_ifs,
      cases h_1,
      { clear h h_1,
        let f : fin 0 → G := λ ⟨i, hi⟩, false.elim (by cases hi),
        have hf0 : ∀ f' : fin 0 → G, f' = f,
          intro f',
          ext i,
          cases i.2,
        have hf1 : ∀ f' : fin 0 → G, φ f' = φ f,
          intro f', rw hf0 f',
        conv begin
          to_lhs,
          congr,
            rw hf1,
            skip,
          congr,
            rw hf1,
            skip,
          congr,
            rw hf1,
            skip,
          congr,
            rw hf1,
            skip,
          congr,
            rw hf1,
            skip,
          congr,
            skip,
          rw hf1,
        end,
        simp,
      },
      cases h_1,
      cases h_1,
      cases h_2,
      dsimp at h, exfalso, apply h, norm_num,
  },

--  cases n with 0 n',
rw ←double_sum_zero1 n' G gi _ φ,
unfold F2,
dsimp,
simp only [smul_add],
rw sum_add_eq_add_sum,
rw sum_range_succ' _ (n'+2),
rw F_0_0,
simp only [F_0_j],
rw [zero_add, pow_one, neg_one_smul],
rw <-sub_eq_add_neg,
rw sub_add_eq_add_sub,
apply add_eq_of_eq_sub',
convert sub_add_cancel _ _,
  show _ = sum (range (n' + 2))
        ((λ (x : ℕ),
              (-(1 : ℤ )) ^ (x + 1 + 1) • F (x + 1) gi ⟨0, _⟩ • φ (λ (i : fin (nat.succ n')), F (x + 1) gi ⟨i.val + 1, _⟩)))+_,
simp only [F_x_0 _ _ (nat.succ_pos _)],
simp only [(F_x_j n' _ gi).symm],
rw sub_eq_add_neg,
convert add_comm _ _,
{
  simp only [(pow_add' _ _ _).symm, nat.succ_eq_add_one],
  simp only [(G_module.G_sum_smul _ _ _).symm],
  norm_num,
  simp only [G_module.neg_one_pow_mul_comm],
},
{
  simp only [(finset.sum_smul2 _ _ _).symm],
  simp only [nat.succ_eq_add_one, smul_smul,pow_add'],
  simp only [(add_assoc _ _ _).symm,(pow_add' _ _ _).symm],
  norm_num,
},

end
--#check neg_one_pow_eq_pow_mod_two

variables (n : ℕ) (G : Type*) [group G] (M : Type*) [add_comm_group M] [G_module G M]

instance: add_comm_group (cochain n G M):=
by unfold cochain; apply_instance

lemma sum_cochain {x y :cochain n G M}{F: fin n → G}: (x+y)(F)=x(F)+y(F):=
begin
refl,
end

lemma zero_cochain {v :cochain n G M}: v=0 → ∀ {F: fin n → G}, v(F)=(0:M):=
begin
intros,
exact congr_fun a F,
end

lemma G_module.zero{G : Type*} [group G] {M : Type*} [add_comm_group M]
  [G_module G M]
  :∀ g : G, g• (0:M) = 0:= begin
  intros,
  have h: g• (0:M)+g• (0:M)=g• ((0:M)+(0:M)),
  rw G_module.linear,
  rw add_zero at h,
  exact add_left_eq_self.mp h,
  end

lemma G_module.neg_one_linear (G : Type*) [group G] {M : Type*} [add_comm_group M]
[G_module G M] (n:ℕ )(m l: M):(-1:ℤ )^(n+1) • (m+l) = (-1:ℤ )^(n+1) • m + (-1:ℤ )^(n+1) • l:=
begin

induction n with d hd,
norm_num,
rw nat.succ_eq_add_one,
rw pow_add,
norm_num,
rw hd,
norm_num,
end

lemma G_module.neg_one_linear_applied {G : Type*}[group G] {M : Type*} [add_comm_group M]
[G_module G M] (i:ℕ )(gi:fin(n+1)→ G)(x y: cochain n G M): (-1:ℤ )^(i+1) • (x(F i gi)+y(F i gi)) = (-1:ℤ )^(i+1) • x(F i gi) + (-1:ℤ )^(i+1) • y(F i gi):=
begin
--have h:(-1:ℤ )^(n+1) • (m+l) = (-1:ℤ )^(n+1) • m + (-1:ℤ )^(n+1) • l,
--exact G_module.neg_one_linear G n m l,
simp only [G_module.neg_one_linear G _ (x(F i gi)) _],
end

def d : add_group_hom (cochain n G M) (cochain (n + 1) G M) :=
{ to_fun := d.to_fun,
  map_zero' := begin
    unfold d.to_fun,
    funext,
    have h1: (0:cochain n G M)=0, refl,
    have h2: (0:cochain (n+1) G M)=0, refl,
    simp only [zero_cochain n G M h1],
    rw zero_cochain (n+1) G M h2,
    norm_num,
    rw G_module.zero,
  end,

  map_add' := begin
    unfold d.to_fun,
    intros,
    funext,
    simp only [sum_cochain, G_module.linear, G_module.neg_one_linear_applied, sum_add_distrib],
    rw [add_left_comm, <-add_assoc, add_left_comm, <-add_assoc,add_assoc],

  end }

theorem d_square_zero2 :d (n + 1) G M ∘ d n G M = 0 :=
begin
funext,
--dsimp,
show d.to_fun (d.to_fun x) gi=0,
rw d_square_zero x,
end

theorem range_d_sub_ker_d : add_group_hom.range (d n G M) ⊆ add_group_hom.ker (d (n + 1) G M) :=
begin
  rintros _ ⟨a, ha, rfl⟩,
  show d n G M a ∈ add_group_hom.ker (d (n + 1) G M),
  rw add_group_hom.mem_ker,
  exact d_square_zero a,
end

example {β : Type*} [_inst_1 : add_comm_monoid β] (f g: ℕ → β)(i:ℕ ) :  f i+ g i=((λ (j:ℕ), f j) + λ (j:ℕ ), g j ) i:=rfl
example {β : Type*} [_inst_1 : add_comm_monoid β]{a b c d:β  }:a+b+(c+d)=a+c+(b+d):=
begin
rw add_left_comm,
rw <-add_assoc,
rw add_left_comm,
rw <-add_assoc,
rw add_assoc,
end


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.complex.circle
import analysis.inner_product_space.calculus
import analysis.inner_product_space.pi_L2
import geometry.manifold.algebra.lie_group
import geometry.manifold.instances.real

/-!
# Manifold structure on the sphere

This file defines stereographic projection from the sphere in an inner product space `E`, and uses
it to put a smooth manifold structure on the sphere.

## Main results

For a unit vector `v` in `E`, the definition `stereographic` gives the stereographic projection
centred at `v`, a local homeomorphism from the sphere to `(ℝ ∙ v)ᗮ` (the orthogonal complement of
`v`).

For finite-dimensional `E`, we then construct a smooth manifold instance on the sphere; the charts
here are obtained by composing the local homeomorphisms `stereographic` with arbitrary isometries
from `(ℝ ∙ v)ᗮ` to Euclidean space.

We prove two lemmas about smooth maps:
* `cont_mdiff_coe_sphere` states that the coercion map from the sphere into `E` is smooth;
  this is a useful tool for constructing smooth maps *from* the sphere.
* `cont_mdiff.cod_restrict_sphere` states that a map from a manifold into the sphere is
  smooth if its lift to a map to `E` is smooth; this is a useful tool for constructing smooth maps
  *to* the sphere.

As an application we prove `cont_mdiff_neg_sphere`, that the antipodal map is smooth.

Finally, we equip the `circle` (defined in `analysis.complex.circle` to be the sphere in `ℂ`
centred at `0` of radius `1`) with the following structure:
* a charted space with model space `euclidean_space ℝ (fin 1)` (inherited from `metric.sphere`)
* a Lie group with model with corners `𝓡 1`

We furthermore show that `exp_map_circle` (defined in `analysis.complex.circle` to be the natural
map `λ t, exp (t * I)` from `ℝ` to `circle`) is smooth.

## Implementation notes

The model space for the charted space instance is `euclidean_space ℝ (fin n)`, where `n` is a
natural number satisfying the typeclass assumption `[fact (finrank ℝ E = n + 1)]`.  This may seem a
little awkward, but it is designed to circumvent the problem that the literal expression for the
dimension of the model space (up to definitional equality) determines the type.  If one used the
naive expression `euclidean_space ℝ (fin (finrank ℝ E - 1))` for the model space, then the sphere in
`ℂ` would be a manifold with model space `euclidean_space ℝ (fin (2 - 1))` but not with model space
`euclidean_space ℝ (fin 1)`.
-/

variables {E : Type*} [inner_product_space ℝ E]

noncomputable theory

open metric finite_dimensional
open_locale manifold

local attribute [instance] fact_finite_dimensional_of_finrank_eq_succ

section stereographic_projection
variables (v : E)

/-! ### Construction of the stereographic projection -/

/-- Stereographic projection, forward direction. This is a map from an inner product space `E` to
the orthogonal complement of an element `v` of `E`. It is smooth away from the affine hyperplane
through `v` parallel to the orthogonal complement.  It restricts on the sphere to the stereographic
projection. -/
def stereo_to_fun [complete_space E] (x : E) : (ℝ ∙ v)ᗮ :=
(2 / ((1:ℝ) - innerSL v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x

variables {v}

@[simp] lemma stereo_to_fun_apply [complete_space E] (x : E) :
  stereo_to_fun v x = (2 / ((1:ℝ) - innerSL v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x :=
rfl

lemma cont_diff_on_stereo_to_fun [complete_space E] :
  cont_diff_on ℝ ⊤ (stereo_to_fun v) {x : E | innerSL v x ≠ (1:ℝ)} :=
begin
  refine cont_diff_on.smul _
    (orthogonal_projection ((ℝ ∙ v)ᗮ)).cont_diff.cont_diff_on,
  refine cont_diff_const.cont_diff_on.div _ _,
  { exact (cont_diff_const.sub (innerSL v).cont_diff).cont_diff_on },
  { intros x h h',
    exact h (sub_eq_zero.mp h').symm }
end

lemma continuous_on_stereo_to_fun [complete_space E] :
  continuous_on (stereo_to_fun v) {x : E | innerSL v x ≠ (1:ℝ)} :=
cont_diff_on_stereo_to_fun.continuous_on

variables (v)

/-- Auxiliary function for the construction of the reverse direction of the stereographic
projection.  This is a map from the orthogonal complement of a unit vector `v` in an inner product
space `E` to `E`; we will later prove that it takes values in the unit sphere.

For most purposes, use `stereo_inv_fun`, not `stereo_inv_fun_aux`. -/
def stereo_inv_fun_aux (w : E) : E := (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v)

variables {v}

@[simp] lemma stereo_inv_fun_aux_apply (w : E) :
  stereo_inv_fun_aux v w = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_aux_mem (hv : ∥v∥ = 1) {w : E} (hw : w ∈ (ℝ ∙ v)ᗮ) :
  stereo_inv_fun_aux v w ∈ (sphere (0:E) 1) :=
begin
  have h₁ : 0 ≤ ∥w∥ ^ 2 + 4 := by nlinarith,
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ = ∥w∥ ^ 2 + 4,
  { have h₂ : ∥w∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    simp only [mem_sphere_zero_iff_norm, norm_smul, real.norm_eq_abs, abs_inv, this,
      abs_of_nonneg h₁, stereo_inv_fun_aux_apply],
    field_simp },
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ ^ 2 = (∥w∥ ^ 2 + 4) ^ 2,
  { have h₃ : 0 ≤ ∥stereo_inv_fun_aux v w∥ := norm_nonneg _,
    simpa [h₁, h₃, -one_pow] using this },
  simp [norm_add_sq_real, norm_smul, inner_smul_left, inner_smul_right,
    inner_left_of_mem_orthogonal_singleton _ hw, mul_pow, real.norm_eq_abs, hv],
  ring
end

lemma cont_diff_stereo_inv_fun_aux : cont_diff ℝ ⊤ (stereo_inv_fun_aux v) :=
begin
  have h₀ : cont_diff ℝ ⊤ (λ w : E, ∥w∥ ^ 2) := cont_diff_norm_sq,
  have h₁ : cont_diff ℝ ⊤ (λ w : E, (∥w∥ ^ 2 + 4)⁻¹),
  { refine (h₀.add cont_diff_const).inv _,
    intros x,
    nlinarith },
  have h₂ : cont_diff ℝ ⊤ (λ w, (4:ℝ) • w + (∥w∥ ^ 2 - 4) • v),
  { refine (cont_diff_const.smul cont_diff_id).add _,
    refine (h₀.sub cont_diff_const).smul cont_diff_const },
  exact h₁.smul h₂
end

/-- Stereographic projection, reverse direction.  This is a map from the orthogonal complement of a
unit vector `v` in an inner product space `E` to the unit sphere in `E`. -/
def stereo_inv_fun (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) : sphere (0:E) 1 :=
⟨stereo_inv_fun_aux v (w:E), stereo_inv_fun_aux_mem hv w.2⟩

@[simp] lemma stereo_inv_fun_apply (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  (stereo_inv_fun hv w : E) = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_ne_north_pole (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_inv_fun hv w ≠ (⟨v, by simp [hv]⟩ : sphere (0:E) 1) :=
begin
  refine subtype.ne_of_val_ne _,
  rw ← inner_lt_one_iff_real_of_norm_one _ hv,
  { have hw : ⟪v, w⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v w.2,
    have hw' : (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4) < 1,
    { refine (inv_mul_lt_iff' _).mpr _,
      { nlinarith },
      linarith },
    simpa [real_inner_comm, inner_add_right, inner_smul_right, real_inner_self_eq_norm_mul_norm, hw,
      hv] using hw' },
  { simpa using stereo_inv_fun_aux_mem hv w.2 }
end

lemma continuous_stereo_inv_fun (hv : ∥v∥ = 1) : continuous (stereo_inv_fun hv) :=
continuous_induced_rng (cont_diff_stereo_inv_fun_aux.continuous.comp continuous_subtype_coe)

variables [complete_space E]

lemma stereo_left_inv (hv : ∥v∥ = 1) {x : sphere (0:E) 1} (hx : (x:E) ≠ v) :
  stereo_inv_fun hv (stereo_to_fun v x) = x :=
begin
  ext,
  simp only [stereo_to_fun_apply, stereo_inv_fun_apply, smul_add],
  -- name two frequently-occuring quantities and write down their basic properties
  set a : ℝ := innerSL v x,
  set y := orthogonal_projection (ℝ ∙ v)ᗮ x,
  have split : ↑x = a • v + ↑y,
  { convert eq_sum_orthogonal_projection_self_orthogonal_complement (ℝ ∙ v) x,
    exact (orthogonal_projection_unit_singleton ℝ hv x).symm },
  have hvy : ⟪v, y⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v y.2,
  have pythag : 1 = a ^ 2 + ∥y∥ ^ 2,
  { have hvy' : ⟪a • v, y⟫_ℝ = 0 := by simp [inner_smul_left, hvy],
    convert norm_add_sq_eq_norm_sq_add_norm_sq_of_inner_eq_zero _ _ hvy' using 2,
    { simp [← split] },
    { simp [norm_smul, hv, real.norm_eq_abs, ← sq, sq_abs] },
    { exact sq _ } },
  -- two facts which will be helpful for clearing denominators in the main calculation
  have ha : 1 - a ≠ 0,
  { have : a < 1 := (inner_lt_one_iff_real_of_norm_one hv (by simp)).mpr hx.symm,
    linarith },
  have : 2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2 ≠ 0,
  { refine ne_of_gt _,
    have := norm_nonneg (y:E),
    have : 0 < (1 - a) ^ 2 := sq_pos_of_ne_zero (1 - a) ha,
    nlinarith },
  -- the core of the problem is these two algebraic identities:
  have h₁ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * 4 * (2 / (1 - a)) = 1,
  { field_simp,
    simp only [submodule.coe_norm] at *,
    nlinarith },
  have h₂ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 - 4) = a,
  { field_simp,
    transitivity (1 - a) ^ 2 * (a * (2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2)),
    { congr,
      simp only [submodule.coe_norm] at *,
      nlinarith },
    ring },
  -- deduce the result
  convert congr_arg2 has_add.add (congr_arg (λ t, t • (y:E)) h₁) (congr_arg (λ t, t • v) h₂)
    using 1,
  { simp [inner_add_right, inner_smul_right, hvy, real_inner_self_eq_norm_mul_norm, hv, mul_smul,
      mul_pow, real.norm_eq_abs, sq_abs, norm_smul] },
  { simp [split, add_comm] }
end

lemma stereo_right_inv (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_to_fun v (stereo_inv_fun hv w) = w :=
begin
  have : 2 / (1 - (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4)) * (∥(w:E)∥ ^ 2 + 4)⁻¹ * 4 = 1,
  { have : ∥(w:E)∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    have : (4:ℝ) + 4 ≠ 0 := by nlinarith,
    field_simp,
    ring },
  convert congr_arg (λ c, c • w) this,
  { have h₁ : orthogonal_projection (ℝ ∙ v)ᗮ v = 0 :=
      orthogonal_projection_orthogonal_complement_singleton_eq_zero v,
    have h₂ : orthogonal_projection (ℝ ∙ v)ᗮ w = w :=
      orthogonal_projection_mem_subspace_eq_self w,
    have h₃ : innerSL v w = (0:ℝ) := inner_right_of_mem_orthogonal_singleton v w.2,
    have h₄ : innerSL v v = (1:ℝ) := by simp [real_inner_self_eq_norm_mul_norm, hv],
    simp [h₁, h₂, h₃, h₄, continuous_linear_map.map_add, continuous_linear_map.map_smul,
      mul_smul] },
  { simp }
end

/-- Stereographic projection from the unit sphere in `E`, centred at a unit vector `v` in `E`; this
is the version as a local homeomorphism. -/
def stereographic (hv : ∥v∥ = 1) : local_homeomorph (sphere (0:E) 1) (ℝ ∙ v)ᗮ :=
{ to_fun := (stereo_to_fun v) ∘ coe,
  inv_fun := stereo_inv_fun hv,
  source := {⟨v, by simp [hv]⟩}ᶜ,
  target := set.univ,
  map_source' := by simp,
  map_target' := λ w _, stereo_inv_fun_ne_north_pole hv w,
  left_inv' := λ _ hx, stereo_left_inv hv (λ h, hx (subtype.ext h)),
  right_inv' := λ w _, stereo_right_inv hv w,
  open_source := is_open_compl_singleton,
  open_target := is_open_univ,
  continuous_to_fun := continuous_on_stereo_to_fun.comp continuous_subtype_coe.continuous_on
    (λ w h, h ∘ subtype.ext ∘ eq.symm ∘ (inner_eq_norm_mul_iff_of_norm_one hv (by simp)).mp),
  continuous_inv_fun := (continuous_stereo_inv_fun hv).continuous_on }

@[simp] lemma stereographic_source (hv : ∥v∥ = 1) :
  (stereographic hv).source = {⟨v, by simp [hv]⟩}ᶜ :=
rfl

@[simp] lemma stereographic_target (hv : ∥v∥ = 1) : (stereographic hv).target = set.univ := rfl

end stereographic_projection

section charted_space

/-!
### Charted space structure on the sphere

In this section we construct a charted space structure on the unit sphere in a finite-dimensional
real inner product space `E`; that is, we show that it is locally homeomorphic to the Euclidean
space of dimension one less than `E`.

The restriction to finite dimension is for convenience.  The most natural `charted_space`
structure for the sphere uses the stereographic projection from the antipodes of a point as the
canonical chart at this point.  However, the codomain of the stereographic projection constructed
in the previous section is `(ℝ ∙ v)ᗮ`, the orthogonal complement of the vector `v` in `E` which is
the "north pole" of the projection, so a priori these charts all have different codomains.

So it is necessary to prove that these codomains are all continuously linearly equivalent to a
fixed normed space.  This could be proved in general by a simple case of Gram-Schmidt
orthogonalization, but in the finite-dimensional case it follows more easily by dimension-counting.
-/

/-- Variant of the stereographic projection, for the sphere in an `n + 1`-dimensional inner product
space `E`.  This version has codomain the Euclidean space of dimension `n`, and is obtained by
composing the original sterographic projection (`stereographic`) with an arbitrary linear isometry
from `(ℝ ∙ v)ᗮ` to the Euclidean space. -/
def stereographic' (n : ℕ) [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  local_homeomorph (sphere (0:E) 1) (euclidean_space ℝ (fin n)) :=
(stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
(linear_isometry_equiv.from_orthogonal_span_singleton n
  (ne_zero_of_mem_unit_sphere v)).to_homeomorph.to_local_homeomorph

@[simp] lemma stereographic'_source {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).source = {v}ᶜ :=
by simp [stereographic']

@[simp] lemma stereographic'_target {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).target = set.univ :=
by simp [stereographic']

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a charted space
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  charted_space (euclidean_space ℝ (fin n)) (sphere (0:E) 1) :=
{ atlas            := {f | ∃ v : (sphere (0:E) 1), f = stereographic' n v},
  chart_at         := λ v, stereographic' n (-v),
  mem_chart_source := λ v, by simpa using ne_neg_of_mem_unit_sphere ℝ v,
  chart_mem_atlas  := λ v, ⟨-v, rfl⟩ }

end charted_space

section smooth_manifold

/-! ### Smooth manifold structure on the sphere -/

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a smooth manifold,
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  smooth_manifold_with_corners (𝓡 n) (sphere (0:E) 1) :=
smooth_manifold_with_corners_of_cont_diff_on (𝓡 n) (sphere (0:E) 1)
begin
  rintros _ _ ⟨v, rfl⟩ ⟨v', rfl⟩,
  let U : (ℝ ∙ (v:E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (ne_zero_of_mem_unit_sphere v),
  let U' : (ℝ ∙ (v':E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (ne_zero_of_mem_unit_sphere v'),
  have hUv : stereographic' n v = (stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
    U.to_homeomorph.to_local_homeomorph := rfl,
  have hU'v' : stereographic' n v' = (stereographic (norm_eq_of_mem_sphere v')).trans
    U'.to_homeomorph.to_local_homeomorph := rfl,
  have H₁ := U'.cont_diff.comp_cont_diff_on cont_diff_on_stereo_to_fun,
  have H₂ := (cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ (v:E))ᗮ.subtypeL.cont_diff).comp U.symm.cont_diff,
  convert H₁.comp' (H₂.cont_diff_on : cont_diff_on ℝ ⊤ _ set.univ) using 1,
  have h_set : ∀ p : sphere (0:E) 1, p = v' ↔ ⟪(p:E), v'⟫_ℝ = 1,
  { simp [subtype.ext_iff, inner_eq_norm_mul_iff_of_norm_one] },
  ext,
  simp [h_set, hUv, hU'v', stereographic, real_inner_comm, ← submodule.coe_norm]
end

/-- The inclusion map (i.e., `coe`) from the sphere in `E` to `E` is smooth.  -/
lemma cont_mdiff_coe_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  cont_mdiff (𝓡 n) 𝓘(ℝ, E) ∞ (coe : (sphere (0:E) 1) → E) :=
begin
  rw cont_mdiff_iff,
  split,
  { exact continuous_subtype_coe },
  { intros v _,
    let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
      linear_isometry_equiv.from_orthogonal_span_singleton n (ne_zero_of_mem_unit_sphere (-v)),
    exact ((cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ ((-v):E))ᗮ.subtypeL.cont_diff).comp U.symm.cont_diff).cont_diff_on }
end

variables {F : Type*} [normed_group F] [normed_space ℝ F]
variables {H : Type*} [topological_space H] {I : model_with_corners ℝ F H}
variables {M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-- If a `cont_mdiff` function `f : M → E`, where `M` is some manifold, takes values in the
sphere, then it restricts to a `cont_mdiff` function from `M` to the sphere. -/
lemma cont_mdiff.cod_restrict_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)]
  {m : with_top ℕ} {f : M → E} (hf : cont_mdiff I 𝓘(ℝ, E) m f)
  (hf' : ∀ x, f x ∈ sphere (0:E) 1) :
  cont_mdiff I (𝓡 n) m (set.cod_restrict _ _ hf' : M → (sphere (0:E) 1)) :=
begin
  rw cont_mdiff_iff_target,
  refine ⟨continuous_induced_rng hf.continuous, _⟩,
  intros v,
  let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    (linear_isometry_equiv.from_orthogonal_span_singleton n (ne_zero_of_mem_unit_sphere (-v))),
  have h : cont_diff_on ℝ ⊤ U set.univ :=
    U.cont_diff.cont_diff_on,
  have H₁ := (h.comp' cont_diff_on_stereo_to_fun).cont_mdiff_on,
  have H₂ : cont_mdiff_on _ _ _ _ set.univ := hf.cont_mdiff_on,
  convert (H₁.of_le le_top).comp' H₂ using 1,
  ext x,
  have hfxv : f x = -↑v ↔ ⟪f x, -↑v⟫_ℝ = 1,
  { have hfx : ∥f x∥ = 1 := by simpa using hf' x,
    rw inner_eq_norm_mul_iff_of_norm_one hfx,
    exact norm_eq_of_mem_sphere (-v) },
  dsimp [chart_at],
  simp [not_iff_not, subtype.ext_iff, hfxv, real_inner_comm]
end

/-- The antipodal map is smooth. -/
lemma cont_mdiff_neg_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  cont_mdiff (𝓡 n) (𝓡 n) ∞ (λ x : sphere (0:E) 1, -x) :=
begin
  -- this doesn't elaborate well in term mode
  apply cont_mdiff.cod_restrict_sphere,
  apply cont_diff_neg.cont_mdiff.comp _,
  exact cont_mdiff_coe_sphere,
end

end smooth_manifold

section circle

open complex

local attribute [instance] finrank_real_complex_fact

/-- The unit circle in `ℂ` is a charted space modelled on `euclidean_space ℝ (fin 1)`.  This
follows by definition from the corresponding result for `metric.sphere`. -/
instance : charted_space (euclidean_space ℝ (fin 1)) circle := metric.sphere.charted_space

instance : smooth_manifold_with_corners (𝓡 1) circle :=
metric.sphere.smooth_manifold_with_corners

/-- The unit circle in `ℂ` is a Lie group. -/
instance : lie_group (𝓡 1) circle :=
{ smooth_mul := begin
    apply cont_mdiff.cod_restrict_sphere,
    let c : circle → ℂ := coe,
    have h₂ : cont_mdiff (𝓘(ℝ, ℂ).prod 𝓘(ℝ, ℂ)) 𝓘(ℝ, ℂ) ∞ (λ (z : ℂ × ℂ), z.fst * z.snd),
    { rw cont_mdiff_iff,
      exact ⟨continuous_mul, λ x y, (cont_diff_mul.restrict_scalars ℝ).cont_diff_on⟩ },
    suffices h₁ : cont_mdiff _ _ _ (prod.map c c),
    { apply h₂.comp h₁ },
    -- this elaborates much faster with `apply`
    apply cont_mdiff.prod_map; exact cont_mdiff_coe_sphere,
  end,
  smooth_inv := begin
    apply cont_mdiff.cod_restrict_sphere,
    exact complex.conj_cle.cont_diff.cont_mdiff.comp cont_mdiff_coe_sphere
  end }

/-- The map `λ t, exp (t * I)` from `ℝ` to the unit circle in `ℂ` is smooth. -/
lemma cont_mdiff_exp_map_circle : cont_mdiff 𝓘(ℝ, ℝ) (𝓡 1) ∞ exp_map_circle :=
(((cont_diff_exp.restrict_scalars ℝ).comp
  (cont_diff_id.smul cont_diff_const)).cont_mdiff).cod_restrict_sphere _

end circle


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import analysis.normed_space.add_torsor
import linear_algebra.affine_space.ordered

/-!
# Urysohn's lemma

In this file we prove Urysohn's lemma `exists_continuous_zero_one_of_closed`: for any two disjoint
closed sets `s` and `t` in a normal topological space `X` there exists a continuous function
`f : X → ℝ` such that

* `f` equals zero on `s`;
* `f` equals one on `t`;
* `0 ≤ f x ≤ 1` for all `x`.

## Implementation notes

Most paper sources prove Urysohn's lemma using a family of open sets indexed by dyadic rational
numbers on `[0, 1]`. There are many technical difficulties with formalizing this proof (e.g., one
needs to formalize the "dyadic induction", then prove that the resulting family of open sets is
monotone). So, we formalize a slightly different proof.

Let `urysohns.CU` the the type of pairs `(C, U)` of a closed set `C`and an open set `U` such that
`C ⊆ U`. Since `X` is a normal topological space, for each `c : CU X` there exists an open set `u`
such that `c.C ⊆ u ∧ closure u ⊆ c.U`. We define `c.left` and `c.right` to be `(c.C, u)` and
`(closure u, c.U)`, respectively. Then we define a family of functions
`urysohns.CU.approx (c : urysohns.CU X) (n : ℕ) : X → ℝ` by recursion on `n`:

* `c.approx 0` is the indicator of `c.Uᶜ`;
* `c.approx (n + 1) x = (c.left.approx n x + c.right.approx n x) / 2`.

For each `x` this is a monotone family of functions that are equal to zero on `c.C` and are equal to
one outside of `c.U`. We also have `c.approx n x ∈ [0, 1]` for all `c`, `n`, and `x`.

Let `urysohns.CU.lim c` be the supremum (or equivalently, the limit) of `c.approx n`. Then
properties of `urysohns.CU.approx` immediately imply that

* `c.lim x ∈ [0, 1]` for all `x`;
* `c.lim` equals zero on `c.C` and equals one outside of `c.U`;
* `c.lim x = (c.left.lim x + c.right.lim x) / 2`.

In order to prove that `c.lim` is continuous at `x`, we prove by induction on `n : ℕ` that for `y`
in a small neighborhood of `x` we have `|c.lim y - c.lim x| ≤ (3 / 4) ^ n`. Induction base follows
from `c.lim x ∈ [0, 1]`, `c.lim y ∈ [0, 1]`. For the induction step, consider two cases:

* `x ∈ c.left.U`; then for `y` in a small neighborhood of `x` we have `y ∈ c.left.U ⊆ c.right.C`
  (hence `c.right.lim x = c.right.lim y = 0`) and `|c.left.lim y - c.left.lim x| ≤ (3 / 4) ^ n`.
  Then
  `|c.lim y - c.lim x| = |c.left.lim y - c.left.lim x| / 2 ≤ (3 / 4) ^ n / 2 < (3 / 4) ^ (n + 1)`.

* otherwise, `x ∉ c.left.right.C`; then for `y` in a small neighborhood of `x` we have
  `y ∉ c.left.right.C ⊇ c.left.left.U` (hence `c.left.left.lim x = c.left.left.lim y = 1`),
  `|c.left.right.lim y - c.left.right.lim x| ≤ (3 / 4) ^ n`, and
  `|c.right.lim y - c.right.lim x| ≤ (3 / 4) ^ n`. Combining these inequalities, the triangle
  inequality, and the recurrence formula for `c.lim`, we get
  `|c.lim x - c.lim y| ≤ (3 / 4) ^ (n + 1)`.

The actual formalization uses `midpoint ℝ x y` instead of `(x + y) / 2` because we have more API
lemmas about `midpoint`.

## Tags

Urysohn's lemma, normal topological space
-/

variables {X : Type*} [topological_space X]

open set filter topological_space
open_locale topological_space filter

namespace urysohns

/-- An auxiliary type for the proof of Urysohn's lemma: a pair of a closed set `C` and its
open neighborhood `U`. -/
@[protect_proj] structure CU (X : Type*) [topological_space X] :=
(C U : set X)
(closed_C : is_closed C)
(open_U : is_open U)
(subset : C ⊆ U)

instance : inhabited (CU X) := ⟨⟨∅, univ, is_closed_empty, is_open_univ, empty_subset _⟩⟩

variable [normal_space X]

namespace CU

/-- Due to `normal_exists_closure_subset`, for each `c : CU X` there exists an open set `u`
such chat `c.C ⊆ u` and `closure u ⊆ c.U`. `c.left` is the pair `(c.C, u)`. -/
@[simps C] def left (c : CU X) : CU X :=
{ C := c.C,
  U := (normal_exists_closure_subset c.closed_C c.open_U c.subset).some,
  closed_C := c.closed_C,
  open_U := (normal_exists_closure_subset c.closed_C c.open_U c.subset).some_spec.1,
  subset := (normal_exists_closure_subset c.closed_C c.open_U c.subset).some_spec.2.1 }

/-- Due to `normal_exists_closure_subset`, for each `c : CU X` there exists an open set `u`
such chat `c.C ⊆ u` and `closure u ⊆ c.U`. `c.right` is the pair `(closure u, c.U)`. -/
@[simps U] def right (c : CU X) : CU X :=
{ C := closure (normal_exists_closure_subset c.closed_C c.open_U c.subset).some,
  U := c.U,
  closed_C := is_closed_closure,
  open_U := c.open_U,
  subset := (normal_exists_closure_subset c.closed_C c.open_U c.subset).some_spec.2.2 }

lemma left_U_subset_right_C (c : CU X) : c.left.U ⊆ c.right.C :=
subset_closure

lemma left_U_subset (c : CU X) : c.left.U ⊆ c.U :=
subset.trans c.left_U_subset_right_C c.right.subset

lemma subset_right_C (c : CU X) : c.C ⊆ c.right.C :=
subset.trans c.left.subset c.left_U_subset_right_C

/-- `n`-th approximation to a continuous function `f : X → ℝ` such that `f = 0` on `c.C` and `f = 1`
outside of `c.U`. -/
noncomputable def approx : ℕ → CU X → X → ℝ
| 0 c x := indicator c.Uᶜ 1 x
| (n + 1) c x := midpoint ℝ (approx n c.left x) (approx n c.right x)

lemma approx_of_mem_C (c : CU X) (n : ℕ) {x : X} (hx : x ∈ c.C) :
  c.approx n x = 0 :=
begin
  induction n with n ihn generalizing c,
  { exact indicator_of_not_mem (λ hU, hU $ c.subset hx) _ },
  { simp only [approx],
    rw [ihn, ihn, midpoint_self],
    exacts [c.subset_right_C hx, hx] }
end

lemma approx_of_nmem_U (c : CU X) (n : ℕ) {x : X} (hx : x ∉ c.U) :
  c.approx n x = 1 :=
begin
  induction n with n ihn generalizing c,
  { exact indicator_of_mem hx _ },
  { simp only [approx],
    rw [ihn, ihn, midpoint_self],
    exacts [hx, λ hU, hx $ c.left_U_subset hU] }
end

lemma approx_nonneg (c : CU X) (n : ℕ) (x : X) :
  0 ≤ c.approx n x :=
begin
  induction n with n ihn generalizing c,
  { exact indicator_nonneg (λ _ _, zero_le_one) _ },
  { simp only [approx, midpoint_eq_smul_add, inv_of_eq_inv],
    refine mul_nonneg (inv_nonneg.2 zero_le_two) (add_nonneg _ _); apply ihn }
end

lemma approx_le_one (c : CU X) (n : ℕ) (x : X) :
  c.approx n x ≤ 1 :=
begin
  induction n with n ihn generalizing c,
  { exact indicator_apply_le' (λ _, le_rfl) (λ _, zero_le_one) },
  { simp only [approx, midpoint_eq_smul_add, inv_of_eq_inv, smul_eq_mul, ← div_eq_inv_mul],
    refine iff.mpr (div_le_one zero_lt_two) (add_le_add _ _); apply ihn }
end

lemma bdd_above_range_approx (c : CU X) (x : X) : bdd_above (range $ λ n, c.approx n x) :=
⟨1, λ y ⟨n, hn⟩, hn ▸ c.approx_le_one n x⟩

lemma approx_le_approx_of_U_sub_C {c₁ c₂ : CU X} (h : c₁.U ⊆ c₂.C) (n₁ n₂ : ℕ) (x : X) :
  c₂.approx n₂ x ≤ c₁.approx n₁ x :=
begin
  by_cases hx : x ∈ c₁.U,
  { calc approx n₂ c₂ x = 0              : approx_of_mem_C _ _ (h hx)
                    ... ≤ approx n₁ c₁ x : approx_nonneg _ _ _ },
  { calc approx n₂ c₂ x ≤ 1              : approx_le_one _ _ _
                    ... = approx n₁ c₁ x : (approx_of_nmem_U _ _ hx).symm }
end

lemma approx_mem_Icc_right_left (c : CU X) (n : ℕ) (x : X) :
  c.approx n x ∈ Icc (c.right.approx n x) (c.left.approx n x) :=
begin
  induction n with n ihn generalizing c,
  { exact ⟨le_rfl, indicator_le_indicator_of_subset (compl_subset_compl.2 c.left_U_subset)
      (λ _, zero_le_one) _⟩ },
  { simp only [approx, mem_Icc],
    refine ⟨midpoint_le_midpoint _ (ihn _).1, midpoint_le_midpoint (ihn _).2 _⟩;
      apply approx_le_approx_of_U_sub_C,
    exacts [subset_closure, subset_closure] }
end

lemma approx_le_succ (c : CU X) (n : ℕ) (x : X) :
  c.approx n x ≤ c.approx (n + 1) x :=
begin
  induction n with n ihn generalizing c,
  { simp only [approx, right_U, right_le_midpoint],
    exact (approx_mem_Icc_right_left c 0 x).2 },
  { rw [approx, approx],
    exact midpoint_le_midpoint (ihn _) (ihn _) }
end

lemma approx_mono (c : CU X) (x : X) : monotone (λ n, c.approx n x) :=
monotone_of_monotone_nat $ λ n, c.approx_le_succ n x

/-- A continuous function `f : X → ℝ` such that

* `0 ≤ f x ≤ 1` for all `x`;
* `f` equals zero on `c.C` and equals one outside of `c.U`;
-/
protected noncomputable def lim (c : CU X) (x : X) : ℝ := ⨆ n, c.approx n x

lemma tendsto_approx_at_top (c : CU X) (x : X) :
  tendsto (λ n, c.approx n x) at_top (𝓝 $ c.lim x) :=
tendsto_at_top_csupr (c.approx_mono x) ⟨1, λ x ⟨n, hn⟩, hn ▸ c.approx_le_one _ _⟩

lemma lim_of_mem_C (c : CU X) (x : X) (h : x ∈ c.C) : c.lim x = 0 :=
by simp only [CU.lim, approx_of_mem_C, h, csupr_const]

lemma lim_of_nmem_U (c : CU X) (x : X) (h : x ∉ c.U) : c.lim x = 1 :=
by simp only [CU.lim, approx_of_nmem_U c _ h, csupr_const]

lemma lim_eq_midpoint (c : CU X) (x : X) :
  c.lim x = midpoint ℝ (c.left.lim x) (c.right.lim x) :=
begin
  refine tendsto_nhds_unique (c.tendsto_approx_at_top x) ((tendsto_add_at_top_iff_nat 1).1 _),
  simp only [approx],
  exact (c.left.tendsto_approx_at_top x).midpoint (c.right.tendsto_approx_at_top x)
end

lemma approx_le_lim (c : CU X) (x : X) (n : ℕ) : c.approx n x ≤ c.lim x :=
le_csupr (c.bdd_above_range_approx x) _

lemma lim_nonneg (c : CU X) (x : X) : 0 ≤ c.lim x :=
(c.approx_nonneg 0 x).trans (c.approx_le_lim x 0)

lemma lim_le_one (c : CU X) (x : X) : c.lim x ≤ 1 :=
csupr_le $ λ n, c.approx_le_one _ _

lemma lim_mem_Icc (c : CU X) (x : X) : c.lim x ∈ Icc (0 : ℝ) 1 :=
⟨c.lim_nonneg x, c.lim_le_one x⟩

/-- Continuity of `urysohns.CU.lim`. See module docstring for a sketch of the proofs. -/

end urysohns

variable [normal_space X]

/-- Urysohns lemma: if `s` and `t` are two disjoint closed sets in a normal topological space `X`,
then there exists a continuous function `f : X → ℝ` such that

* `f` equals zero on `s`;
* `f` equals one on `t`;
* `0 ≤ f x ≤ 1` for all `x`.
-/
lemma exists_continuous_zero_one_of_closed {s t : set X} (hs : is_closed s) (ht : is_closed t)
  (hd : disjoint s t) :
  ∃ f : X → ℝ, continuous f ∧ eq_on f 0 s ∧ eq_on f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1 :=
begin
  -- The actual proof is in the code above. Here we just repack it into the expected format.
  set c : urysohns.CU X := ⟨s, tᶜ, hs, ht.is_open_compl, λ _, disjoint_left.1 hd⟩,
  exact ⟨c.lim, c.continuous_lim, c.lim_of_mem_C,
    λ x hx, c.lim_of_nmem_U _ (λ h, h hx), c.lim_mem_Icc⟩
end


import data.stream

import unitb.logic

import util.logic

namespace simple

open unitb
open predicate

section

parameter (α : Type)

structure program : Type :=
  (first : α)
  (step : α → α)

def pred := pred' α

parameter {α}

def program.init (s : program) (p : pred) : Prop :=
s.first ⊨ p

def is_step (s : program) (σ σ' : α) : Prop := σ' = s.step σ

def program.transient (s : program) (p q : pred) : Prop :=
⊩ ⟦is_step s⟧ ⟶ •p ⟶ •q ⟶ ⊙-•q

def program.unless (s : program) (p q : pred) : Prop :=
∀ σ, σ ⊨ p ∧ ¬σ ⊨ p → s.step σ ⊨ p ∨ s.step σ ⊨ q

open temporal

lemma program.transient_impl (s : program) {p q : pred}
  (H : p ⟹ -q)
: s.transient p q :=
begin [temporal]
  intros STEP hp hq,
  exfalso,
  revert hq hp,
  simp, rw [not_init],
  clear STEP,
  show _,
  { revert Γ, change _ ⟹ _, monotonicity H, },
end

lemma program.transient_antimono (s : program) (p q p' q' : pred)
  (hp : p' ⟹ p)
  (hq : q' ⟹ q)
  (T₀ : s.transient p q)
: s.transient p' q' :=
begin [temporal]
  replace hp := init_entails_init hp,
  replace hq := init_entails_init hq,
  intros STEP hp' hq',
  replace T₀ := T₀ Γ STEP (hp Γ hp') (hq Γ hq'),
  revert T₀,
  persistent,
  monotonicity,
  apply hq,
end

instance prog_is_system : system program :=
  { σ := α
  , step := is_step
  , init := program.init
  , transient := program.transient
  , transient_false := λ s p, program.transient_impl s (by simp)
  , transient_antimono := program.transient_antimono
  }

lemma unless_step
  {init : α}
  {step : α → α}
  {p q : pred}
  (h : ∀ σ, σ ⊨ p → ¬ σ ⊨ q → step σ ⊨ p ∨ step σ ⊨ q)
: unless (program.mk init step) p q :=
begin
  unfold unless,
  intros σ σ' S,
  have h' := h σ, clear h,
  simp [unitb.step,has_safety.step,is_step] at S,
  rw S,
  intros h,
  cases h,
  apply h' ; assumption,
end

open classical

lemma leads_to_step
  (init : α)
  (step : α → α)
  (p q : pred)
  (h : ∀ σ, σ ⊨ p → ¬ σ ⊨ q → step σ ⊨ q)
: p ↦ q in program.mk init step :=
begin
  apply leads_to.basis,
  { lifted_pred [is_step,temporal.init,not_not_iff_self],
    intros, specialize h _ a_1 a_2,
    simp [a,h], },
  { apply unless_step,
    intros σ hp hnq,
    right, apply h _ hp hnq, }
end

open nat

open temporal

def ex (s : program) : cpred α :=
•eq s.first ⋀ ◻ ⟦ is_step s ⟧

lemma ex.safety (s : program)
: ex s ⟹ ◻ ⟦ is_step s ⟧ :=
begin [temporal]
  intros h, apply h.right
end

def ex.witness (s : program) : stream α
  | 0 := s.first
  | (succ i) := s.step (ex.witness i)

lemma ex.witness_correct (s : program)
: ex.witness s ⊨ ex s :=
begin
  unfold ex, simp,
  split,
  { intro i,
    simp [action,is_step,stream.drop],
    refl },
  { simp [temporal.init],
    exact rfl }
end

section semantics

variable {s : program}
variable Γ : cpred α
variables {p q : pred}
variables H : Γ ⊢ ex s
open temporal
include H

lemma init_sem
  (I₀ : init s p)
: Γ ⊢ •p :=
begin [temporal]
  have H' := H.left,
  revert H',
  lifted_pred,
  show _ ,
  { intros,
    simp [temporal.init] at a ⊢,
    rw ← a,
    assumption },
end

lemma transient.semantics
  (T₀ : transient' s p q)
: Γ ⊢ ◻◇•p ⟶ ◻◇-•q :=
begin [temporal]
  intros Hp,
  replace H := coincidence' (ex.safety s Γ H) Hp,
  rw ← eventually_eventually,
  revert H,
  monotonicity,
  { rw p_and_p_imp,
    intros Hs Hp,
    cases predicate.em (•q) with Hq Hnq,
    { apply T₀ Γ Hs Hp Hnq, },
    { apply Hq } },
end

end semantics

instance : system_sem program :=
  { (_ : system program) with
    ex := ex
  , safety := @ex.safety
  , inhabited := λ p, ⟨ex.witness p, ex.witness_correct p⟩
  , init_sem := @init_sem
  , transient_sem := @transient.semantics }

end

end simple


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Frédéric Dupuis
-/
import algebra.star.self_adjoint
import algebra.module.equiv
import linear_algebra.prod

/-!
# The star operation, bundled as a star-linear equiv

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

We define `star_linear_equiv`, which is the star operation bundled as a star-linear map.
It is defined on a star algebra `A` over the base ring `R`.

This file also provides some lemmas that need `algebra.module.basic` imported to prove.

## TODO

- Define `star_linear_equiv` for noncommutative `R`. We only the commutative case for now since,
  in the noncommutative case, the ring hom needs to reverse the order of multiplication. This
  requires a ring hom of type `R →+* Rᵐᵒᵖ`, which is very undesirable in the commutative case.
  One way out would be to define a new typeclass `is_op R S` and have an instance `is_op R R`
  for commutative `R`.
- Also note that such a definition involving `Rᵐᵒᵖ` or `is_op R S` would require adding
  the appropriate `ring_hom_inv_pair` instances to be able to define the semilinear
  equivalence.
-/

section smul_lemmas
variables {R M : Type*}

@[simp] lemma star_nat_cast_smul [semiring R] [add_comm_monoid M] [module R M] [star_add_monoid M]
  (n : ℕ) (x : M) : star ((n : R) • x) = (n : R) • star x :=
map_nat_cast_smul (star_add_equiv : M ≃+ M) R R n x

@[simp] lemma star_int_cast_smul [ring R] [add_comm_group M] [module R M] [star_add_monoid M]
  (n : ℤ) (x : M) : star ((n : R) • x) = (n : R) • star x :=
map_int_cast_smul (star_add_equiv : M ≃+ M) R R n x

@[simp] lemma star_inv_nat_cast_smul [division_semiring R] [add_comm_monoid M] [module R M]
  [star_add_monoid M] (n : ℕ) (x : M) : star ((n⁻¹ : R) • x) = (n⁻¹ : R) • star x :=
map_inv_nat_cast_smul (star_add_equiv : M ≃+ M) R R n x

@[simp] lemma star_inv_int_cast_smul [division_ring R] [add_comm_group M] [module R M]
  [star_add_monoid M] (n : ℤ) (x : M) : star ((n⁻¹ : R) • x) = (n⁻¹ : R) • star x :=
map_inv_int_cast_smul (star_add_equiv : M ≃+ M) R R n x

@[simp] lemma star_rat_cast_smul [division_ring R] [add_comm_group M] [module R M]
  [star_add_monoid M] (n : ℚ) (x : M) : star ((n : R) • x) = (n : R) • star x :=
map_rat_cast_smul (star_add_equiv : M ≃+ M) _ _ _ x

@[simp] lemma star_rat_smul {R : Type*} [add_comm_group R] [star_add_monoid R] [module ℚ R]
  (x : R) (n : ℚ) : star (n • x) = n • star x :=
map_rat_smul (star_add_equiv : R ≃+ R) _ _

end smul_lemmas

/-- If `A` is a module over a commutative `R` with compatible actions,
then `star` is a semilinear equivalence. -/
@[simps]
def star_linear_equiv (R : Type*) {A : Type*}
  [comm_ring R] [star_ring R] [semiring A] [star_ring A] [module R A] [star_module R A]  :
    A ≃ₗ⋆[R] A :=
{ to_fun := star,
  map_smul' := star_smul,
  .. star_add_equiv }

variables (R : Type*) (A : Type*)
  [semiring R] [star_semigroup R] [has_trivial_star R]
  [add_comm_group A] [module R A] [star_add_monoid A] [star_module R A]

/-- The self-adjoint elements of a star module, as a submodule. -/
def self_adjoint.submodule : submodule R A :=
{ smul_mem' := λ r x, (is_self_adjoint.all _).smul,
  ..self_adjoint A }

/-- The skew-adjoint elements of a star module, as a submodule. -/
def skew_adjoint.submodule : submodule R A :=
{ smul_mem' := skew_adjoint.smul_mem,
  ..skew_adjoint A }

variables {A} [invertible (2 : R)]

/-- The self-adjoint part of an element of a star module, as a linear map. -/
@[simps] def self_adjoint_part : A →ₗ[R] self_adjoint A :=
{ to_fun := λ x, ⟨(⅟2 : R) • (x + star x),
  by simp only [self_adjoint.mem_iff, star_smul, add_comm,
                  star_add_monoid.star_add, star_inv', star_bit0,
                  star_one, star_star, star_inv_of (2 : R), star_trivial]⟩,
  map_add' := λ x y, by { ext, simp [add_add_add_comm] },
  map_smul' := λ r x, by { ext, simp [←mul_smul,
          show ⅟ 2 * r = r * ⅟ 2, from commute.inv_of_left (commute.one_left r).bit0_left] } }

/-- The skew-adjoint part of an element of a star module, as a linear map. -/
@[simps] def skew_adjoint_part : A →ₗ[R] skew_adjoint A :=
{ to_fun := λ x, ⟨(⅟2 : R) • (x - star x),
    by simp only [skew_adjoint.mem_iff, star_smul, star_sub, star_star, star_trivial, ←smul_neg,
                  neg_sub]⟩,
  map_add' := λ x y, by { ext, simp only [sub_add, ←smul_add, sub_sub_eq_add_sub, star_add,
                                          add_subgroup.coe_mk, add_subgroup.coe_add] },
  map_smul' := λ r x, by { ext, simp [←mul_smul, ←smul_sub,
            show r * ⅟ 2 = ⅟ 2 * r, from commute.inv_of_right (commute.one_right r).bit0_right] } }

lemma star_module.self_adjoint_part_add_skew_adjoint_part (x : A) :
  (self_adjoint_part R x : A) + skew_adjoint_part R x = x :=
by simp only [smul_sub, self_adjoint_part_apply_coe, smul_add, skew_adjoint_part_apply_coe,
              add_add_sub_cancel, inv_of_two_smul_add_inv_of_two_smul]

variables (A)

/-- The decomposition of elements of a star module into their self- and skew-adjoint parts,
as a linear equivalence. -/
@[simps] def star_module.decompose_prod_adjoint : A ≃ₗ[R] self_adjoint A × skew_adjoint A :=
linear_equiv.of_linear
  ((self_adjoint_part R).prod (skew_adjoint_part R))
  ((self_adjoint.submodule R A).subtype.coprod (skew_adjoint.submodule R A).subtype)
  (by ext; simp)
  (linear_map.ext $ star_module.self_adjoint_part_add_skew_adjoint_part R)

@[simp]
lemma algebra_map_star_comm {R A : Type*} [comm_semiring R] [star_ring R] [semiring A]
  [star_semigroup A] [algebra R A] [star_module R A] (r : R) :
  algebra_map R A (star r) = star (algebra_map R A r) :=
by simp only [algebra.algebra_map_eq_smul_one, star_smul, star_one]


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.convex.topology
import tactic.by_contra

/-!
# Simplicial complexes

In this file, we define simplicial complexes in `𝕜`-modules. A simplicial complex is a collection
of simplices closed by inclusion (of vertices) and intersection (of underlying sets).

We model them by a downward-closed set of affine independent finite sets whose convex hulls "glue
nicely", each finite set and its convex hull corresponding respectively to the vertices and the
underlying set of a simplex.

## Main declarations

* `simplicial_complex 𝕜 E`: A simplicial complex in the `𝕜`-module `E`.
* `simplicial_complex.vertices`: The zero dimensional faces of a simplicial complex.
* `simplicial_complex.facets`: The maximal faces of a simplicial complex.

## Notation

`s ∈ K` means that `s` is a face of `K`.

`K ≤ L` means that the faces of `K` are faces of `L`.

## Implementation notes

"glue nicely" usually means that the intersection of two faces (as sets in the ambient space) is a
face. Given that we store the vertices, not the faces, this would be a bit awkward to spell.
Instead, `simplicial_complex.inter_subset_convex_hull` is an equivalent condition which works on the
vertices.

## TODO

Simplicial complexes can be generalized to affine spaces once `convex_hull` has been ported.
-/

open finset set

variables (𝕜 E : Type*) {ι : Type*} [ordered_ring 𝕜] [add_comm_group E] [module 𝕜 E]

namespace geometry

/-- A simplicial complex in a `𝕜`-module is a collection of simplices which glue nicely together.
Note that the textbook meaning of "glue nicely" is given in
`geometry.simplicial_complex.disjoint_or_exists_inter_eq_convex_hull`. It is mostly useless, as
`geometry.simplicial_complex.convex_hull_inter_convex_hull` is enough for all purposes. -/
-- TODO: update to new binder order? not sure what binder order is correct for `down_closed`.
@[ext] structure simplicial_complex :=
(faces : set (finset E))
(not_empty_mem : ∅ ∉ faces)
(indep : ∀ {s}, s ∈ faces → affine_independent 𝕜 (coe : (s : set E) → E))
(down_closed : ∀ {s t}, s ∈ faces → t ⊆ s → t ≠ ∅ → t ∈ faces)
(inter_subset_convex_hull : ∀ {s t}, s ∈ faces → t ∈ faces →
  convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t ⊆ convex_hull 𝕜 (s ∩ t : set E))

namespace simplicial_complex
variables {𝕜 E} {K : simplicial_complex 𝕜 E} {s t : finset E} {x : E}

/-- A `finset` belongs to a `simplicial_complex` if it's a face of it. -/
instance : has_mem (finset E) (simplicial_complex 𝕜 E) := ⟨λ s K, s ∈ K.faces⟩

/-- The underlying space of a simplicial complex is the union of its faces. -/
def space (K : simplicial_complex 𝕜 E) : set E := ⋃ s ∈ K.faces, convex_hull 𝕜 (s : set E)

lemma mem_space_iff : x ∈ K.space ↔ ∃ s ∈ K.faces, x ∈ convex_hull 𝕜 (s : set E) := mem_Union₂

lemma convex_hull_subset_space (hs : s ∈ K.faces) : convex_hull 𝕜 ↑s ⊆ K.space :=
subset_bUnion_of_mem hs

protected lemma subset_space (hs : s ∈ K.faces) : (s : set E) ⊆ K.space :=
(subset_convex_hull 𝕜 _).trans $ convex_hull_subset_space hs

lemma convex_hull_inter_convex_hull (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t = convex_hull 𝕜 (s ∩ t : set E) :=
(K.inter_subset_convex_hull hs ht).antisymm $ subset_inter
  (convex_hull_mono $ set.inter_subset_left _ _) $ convex_hull_mono $ set.inter_subset_right _ _

/-- The conclusion is the usual meaning of "glue nicely" in textbooks. It turns out to be quite
unusable, as it's about faces as sets in space rather than simplices. Further,  additional structure
on `𝕜` means the only choice of `u` is `s ∩ t` (but it's hard to prove). -/
lemma disjoint_or_exists_inter_eq_convex_hull (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  disjoint (convex_hull 𝕜 (s : set E)) (convex_hull 𝕜 ↑t) ∨
  ∃ u ∈ K.faces, convex_hull 𝕜 (s : set E) ∩ convex_hull 𝕜 ↑t = convex_hull 𝕜 ↑u :=
begin
  classical,
  by_contra' h,
  refine h.2 (s ∩ t) (K.down_closed hs (inter_subset_left _ _) $ λ hst, h.1 $
    (K.inter_subset_convex_hull hs ht).trans _) _,
  { rw [←coe_inter, hst, coe_empty, convex_hull_empty],
    refl },
  { rw [coe_inter, convex_hull_inter_convex_hull hs ht] }
end

/-- Construct a simplicial complex by removing the empty face for you. -/
@[simps] def of_erase
  (faces : set (finset E))
  (indep : ∀ s ∈ faces, affine_independent 𝕜 (coe : (s : set E) → E))
  (down_closed : ∀ s ∈ faces, ∀ t ⊆ s, t ∈ faces)
  (inter_subset_convex_hull : ∀ s t ∈ faces,
    convex_hull 𝕜 ↑s ∩ convex_hull 𝕜 ↑t ⊆ convex_hull 𝕜 (s ∩ t : set E)) :
  simplicial_complex 𝕜 E :=
{ faces := faces \ {∅},
  not_empty_mem := λ h, h.2 (mem_singleton _),
  indep := λ s hs, indep _ hs.1,
  down_closed := λ s t hs hts ht, ⟨down_closed _ hs.1 _ hts, ht⟩,
  inter_subset_convex_hull := λ s t hs ht, inter_subset_convex_hull _ hs.1 _ ht.1 }

/-- Construct a simplicial complex as a subset of a given simplicial complex. -/
@[simps] def of_subcomplex (K : simplicial_complex 𝕜 E)
  (faces : set (finset E))
  (subset : faces ⊆ K.faces)
  (down_closed : ∀ {s t}, s ∈ faces → t ⊆ s → t ∈ faces) :
  simplicial_complex 𝕜 E :=
{ faces := faces,
  not_empty_mem := λ h, K.not_empty_mem (subset h),
  indep := λ s hs, K.indep (subset hs),
  down_closed := λ s t hs hts _, down_closed hs hts,
  inter_subset_convex_hull := λ s t hs ht, K.inter_subset_convex_hull (subset hs) (subset ht) }

/-! ### Vertices -/

/-- The vertices of a simplicial complex are its zero dimensional faces. -/
def vertices (K : simplicial_complex 𝕜 E) : set E := {x | {x} ∈ K.faces}

lemma mem_vertices : x ∈ K.vertices ↔ {x} ∈ K.faces := iff.rfl

lemma vertices_eq : K.vertices = ⋃ k ∈ K.faces, (k : set E) :=
begin
  ext x,
  refine ⟨λ h, mem_bUnion h $ mem_coe.2 $ mem_singleton_self x, λ h, _⟩,
  obtain ⟨s, hs, hx⟩ := mem_Union₂.1 h,
  exact K.down_closed hs (finset.singleton_subset_iff.2 $ mem_coe.1 hx) (singleton_ne_empty _),
end

lemma vertices_subset_space : K.vertices ⊆ K.space :=
vertices_eq.subset.trans $ Union₂_mono $ λ x hx, subset_convex_hull 𝕜 x

lemma vertex_mem_convex_hull_iff (hx : x ∈ K.vertices) (hs : s ∈ K.faces) :
  x ∈ convex_hull 𝕜 (s : set E) ↔ x ∈ s :=
begin
  refine ⟨λ h, _, λ h, subset_convex_hull _ _ h⟩,
  classical,
  have h := K.inter_subset_convex_hull hx hs ⟨by simp, h⟩,
  by_contra H,
  rwa [←coe_inter, finset.disjoint_iff_inter_eq_empty.1
    (finset.disjoint_singleton_right.2 H).symm, coe_empty, convex_hull_empty] at h,
end

/-- A face is a subset of another one iff its vertices are.  -/
lemma face_subset_face_iff (hs : s ∈ K.faces) (ht : t ∈ K.faces) :
  convex_hull 𝕜 (s : set E) ⊆ convex_hull 𝕜 ↑t ↔ s ⊆ t :=
⟨λ h x hxs, (vertex_mem_convex_hull_iff (K.down_closed hs (finset.singleton_subset_iff.2 hxs) $
  singleton_ne_empty _) ht).1 (h (subset_convex_hull 𝕜 ↑s hxs)), convex_hull_mono⟩

/-! ### Facets -/

/-- A facet of a simplicial complex is a maximal face. -/
def facets (K : simplicial_complex 𝕜 E) : set (finset E) :=
{s ∈ K.faces | ∀ ⦃t⦄, t ∈ K.faces → s ⊆ t → s = t}

lemma mem_facets : s ∈ K.facets ↔ s ∈ K.faces ∧ ∀ t ∈ K.faces, s ⊆ t → s = t := mem_sep_iff

lemma facets_subset : K.facets ⊆ K.faces := λ s hs, hs.1

lemma not_facet_iff_subface (hs : s ∈ K.faces) : (s ∉ K.facets ↔ ∃ t, t ∈ K.faces ∧ s ⊂ t) :=
begin
  refine ⟨λ (hs' : ¬ (_ ∧ _)), _, _⟩,
  { push_neg at hs',
    obtain ⟨t, ht⟩ := hs' hs,
    exact ⟨t, ht.1, ⟨ht.2.1, (λ hts, ht.2.2 (subset.antisymm ht.2.1 hts))⟩⟩ },
  { rintro ⟨t, ht⟩ ⟨hs, hs'⟩,
    have := hs' ht.1 ht.2.1,
    rw this at ht,
    exact ht.2.2 (subset.refl t) } -- `has_ssubset.ssubset.ne` would be handy here
end

/-!
### The semilattice of simplicial complexes

`K ≤ L` means that `K.faces ⊆ L.faces`.
-/

variables (𝕜 E)

/-- The complex consisting of only the faces present in both of its arguments. -/
instance : has_inf (simplicial_complex 𝕜 E) :=
⟨λ K L, { faces := K.faces ∩ L.faces,
  not_empty_mem := λ h, K.not_empty_mem (set.inter_subset_left _ _ h),
  indep := λ s hs, K.indep hs.1,
  down_closed := λ s t hs hst ht, ⟨K.down_closed hs.1 hst ht, L.down_closed hs.2 hst ht⟩,
  inter_subset_convex_hull := λ s t hs ht, K.inter_subset_convex_hull hs.1 ht.1 }⟩

instance : semilattice_inf (simplicial_complex 𝕜 E) :=
{ inf := (⊓),
  inf_le_left := λ K L s hs, hs.1,
  inf_le_right := λ K L s hs, hs.2,
  le_inf := λ K L M hKL hKM s hs, ⟨hKL hs, hKM hs⟩,
  .. (partial_order.lift faces $ λ x y, ext _ _) }

instance : has_bot (simplicial_complex 𝕜 E) :=
⟨{ faces := ∅,
  not_empty_mem := set.not_mem_empty ∅,
  indep := λ s hs, (set.not_mem_empty _ hs).elim,
  down_closed := λ s _ hs, (set.not_mem_empty _ hs).elim,
  inter_subset_convex_hull := λ s _ hs, (set.not_mem_empty _ hs).elim }⟩

instance : order_bot (simplicial_complex 𝕜 E) :=
{ bot_le := λ K, set.empty_subset _, .. simplicial_complex.has_bot 𝕜 E }

instance : inhabited (simplicial_complex 𝕜 E) := ⟨⊥⟩

variables {𝕜 E}

lemma faces_bot : (⊥ : simplicial_complex 𝕜 E).faces = ∅ := rfl

lemma space_bot : (⊥ : simplicial_complex 𝕜 E).space = ∅ := set.bUnion_empty _

lemma facets_bot : (⊥ : simplicial_complex 𝕜 E).facets = ∅ := eq_empty_of_subset_empty facets_subset

end simplicial_complex
end geometry


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

import algebra.homology.homological_complex
import algebraic_topology.simplicial_object
import algebraic_topology.Moore_complex
import category_theory.abelian.basic
import algebra.big_operators.basic
import tactic.ring_exp
import data.fintype.card

/-!

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

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

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

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

-/

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

open_locale big_operators
open_locale simplicial

noncomputable theory

namespace algebraic_topology

namespace alternating_face_map_complex

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

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

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

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

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

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

variables {X} {Y}

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

end alternating_face_map_complex

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

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

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

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

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

@[simp]

variables (A)

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

end algebraic_topology


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import data.padics.padic_integers
import topology.metric_space.cau_seq_filter
import analysis.specific_limits
import data.polynomial.identities
import topology.algebra.polynomial

/-!
# Hensel's lemma on ℤ_p

This file proves Hensel's lemma on ℤ_p, roughly following Keith Conrad's writeup:
<http://www.math.uconn.edu/~kconrad/blurbs/gradnumthy/hensel.pdf>

Hensel's lemma gives a simple condition for the existence of a root of a polynomial.

The proof and motivation are described in the paper
[R. Y. Lewis, *A formal proof of Hensel's lemma over the p-adic integers*][lewis2019].

## References

* <http://www.math.uconn.edu/~kconrad/blurbs/gradnumthy/hensel.pdf>
* [R. Y. Lewis, *A formal proof of Hensel's lemma over the p-adic integers*][lewis2019]
* <https://en.wikipedia.org/wiki/Hensel%27s_lemma>

## Tags

p-adic, p adic, padic, p-adic integer
-/

noncomputable theory

open_locale classical topological_space

-- We begin with some general lemmas that are used below in the computation.

lemma padic_polynomial_dist {p : ℕ} [fact p.prime] (F : polynomial ℤ_[p]) (x y : ℤ_[p]) :
  ∥F.eval x - F.eval y∥ ≤ ∥x - y∥ :=
let ⟨z, hz⟩ := F.eval_sub_factor x y in calc
  ∥F.eval x - F.eval y∥ = ∥z∥ * ∥x - y∥ : by simp [hz]
    ... ≤ 1 * ∥x - y∥ : mul_le_mul_of_nonneg_right (padic_int.norm_le_one _) (norm_nonneg _)
    ... = ∥x - y∥ : by simp

open filter metric

private lemma comp_tendsto_lim {p : ℕ} [fact p.prime] {F : polynomial ℤ_[p]}
  (ncs : cau_seq ℤ_[p] norm) :
  tendsto (λ i, F.eval (ncs i)) at_top (𝓝 (F.eval ncs.lim)) :=
F.continuous_at.tendsto.comp ncs.tendsto_limit

section
parameters {p : ℕ} [fact p.prime] {ncs : cau_seq ℤ_[p] norm} {F : polynomial ℤ_[p]} {a : ℤ_[p]}
           (ncs_der_val : ∀ n, ∥F.derivative.eval (ncs n)∥ = ∥F.derivative.eval a∥)
include ncs_der_val

private lemma ncs_tendsto_const :
  tendsto (λ i, ∥F.derivative.eval (ncs i)∥) at_top (𝓝 ∥F.derivative.eval a∥) :=
by convert tendsto_const_nhds; ext; rw ncs_der_val

private lemma ncs_tendsto_lim :
  tendsto (λ i, ∥F.derivative.eval (ncs i)∥) at_top (𝓝 (∥F.derivative.eval ncs.lim∥)) :=
tendsto.comp (continuous_iff_continuous_at.1 continuous_norm _) (comp_tendsto_lim _)

private lemma norm_deriv_eq : ∥F.derivative.eval ncs.lim∥ = ∥F.derivative.eval a∥ :=
tendsto_nhds_unique ncs_tendsto_lim ncs_tendsto_const

end

section
parameters {p : ℕ} [fact p.prime] {ncs : cau_seq ℤ_[p] norm} {F : polynomial ℤ_[p]}
           (hnorm : tendsto (λ i, ∥F.eval (ncs i)∥) at_top (𝓝 0))
include hnorm

private lemma tendsto_zero_of_norm_tendsto_zero : tendsto (λ i, F.eval (ncs i)) at_top (𝓝 0) :=
tendsto_iff_norm_tendsto_zero.2 (by simpa using hnorm)

lemma limit_zero_of_norm_tendsto_zero : F.eval ncs.lim = 0 :=
tendsto_nhds_unique (comp_tendsto_lim _) tendsto_zero_of_norm_tendsto_zero

end

section hensel
open nat

parameters {p : ℕ} [fact p.prime] {F : polynomial ℤ_[p]} {a : ℤ_[p]}
           (hnorm : ∥F.eval a∥ < ∥F.derivative.eval a∥^2) (hnsol : F.eval a ≠ 0)
include hnorm

/-- `T` is an auxiliary value that is used to control the behavior of the polynomial `F`. -/
private def T : ℝ := ∥(F.eval a / (F.derivative.eval a)^2 : ℚ_[p])∥

private lemma deriv_sq_norm_pos : 0 < ∥F.derivative.eval a∥ ^ 2 :=
lt_of_le_of_lt (norm_nonneg _) hnorm

private lemma deriv_sq_norm_ne_zero : ∥F.derivative.eval a∥^2 ≠ 0 := ne_of_gt deriv_sq_norm_pos

private lemma deriv_norm_ne_zero : ∥F.derivative.eval a∥ ≠ 0 :=
λ h, deriv_sq_norm_ne_zero (by simp [*, sq])

private lemma deriv_norm_pos : 0 < ∥F.derivative.eval a∥ :=
lt_of_le_of_ne (norm_nonneg _) (ne.symm deriv_norm_ne_zero)

private lemma deriv_ne_zero : F.derivative.eval a ≠ 0 := mt norm_eq_zero.2 deriv_norm_ne_zero

private lemma T_def : T = ∥F.eval a∥ / ∥F.derivative.eval a∥^2 :=
calc T = ∥F.eval a∥ / ∥((F.derivative.eval a)^2 : ℚ_[p])∥ : normed_field.norm_div _ _
   ... = ∥F.eval a∥ / ∥(F.derivative.eval a)^2∥ : by simp [norm, padic_int.norm_def]
   ... = ∥F.eval a∥ / ∥(F.derivative.eval a)∥^2 : by simp

private lemma T_lt_one : T < 1 :=
let h := (div_lt_one deriv_sq_norm_pos).2 hnorm in
by rw T_def; apply h

private lemma T_pow {n : ℕ} (hn : n > 0) : T ^ n < 1 :=
have T ^ n ≤ T ^ 1,
from pow_le_pow_of_le_one (norm_nonneg _) (le_of_lt T_lt_one) (succ_le_of_lt hn),
lt_of_le_of_lt (by simpa) T_lt_one

private lemma T_pow' (n : ℕ) : T ^ (2 ^ n) < 1 := (T_pow (pow_pos (by norm_num) _))

private lemma T_pow_nonneg (n : ℕ) : 0 ≤ T ^ n := pow_nonneg (norm_nonneg _) _

/-- We will construct a sequence of elements of ℤ_p satisfying successive values of `ih`. -/
private def ih (n : ℕ) (z : ℤ_[p]) : Prop :=
∥F.derivative.eval z∥ = ∥F.derivative.eval a∥ ∧ ∥F.eval z∥ ≤ ∥F.derivative.eval a∥^2 * T ^ (2^n)

private lemma ih_0 : ih 0 a :=
⟨ rfl, by simp [T_def, mul_div_cancel' _ (ne_of_gt (deriv_sq_norm_pos hnorm))] ⟩

private lemma calc_norm_le_one {n : ℕ} {z : ℤ_[p]} (hz : ih n z) :
         ∥(↑(F.eval z) : ℚ_[p]) / ↑(F.derivative.eval z)∥ ≤ 1 :=
calc ∥(↑(F.eval z) : ℚ_[p]) / ↑(F.derivative.eval z)∥
    = ∥(↑(F.eval z) : ℚ_[p])∥ / ∥(↑(F.derivative.eval z) : ℚ_[p])∥ : normed_field.norm_div _ _
... = ∥F.eval z∥ / ∥F.derivative.eval a∥ : by simp [hz.1]
... ≤ ∥F.derivative.eval a∥^2 * T^(2^n) / ∥F.derivative.eval a∥ :
  (div_le_div_right deriv_norm_pos).2 hz.2
... = ∥F.derivative.eval a∥ * T^(2^n) : div_sq_cancel (ne_of_gt deriv_norm_pos) _
... ≤ 1 : mul_le_one (padic_int.norm_le_one _) (T_pow_nonneg _) (le_of_lt (T_pow' _))

private lemma calc_deriv_dist {z z' z1 : ℤ_[p]} (hz' : z' = z - z1)
  (hz1 : ∥z1∥ = ∥F.eval z∥ / ∥F.derivative.eval a∥) {n} (hz : ih n z) :
  ∥F.derivative.eval z' - F.derivative.eval z∥ < ∥F.derivative.eval a∥ :=
calc
  ∥F.derivative.eval z' - F.derivative.eval z∥
    ≤ ∥z' - z∥ : padic_polynomial_dist _ _ _
... = ∥z1∥ : by simp only [sub_eq_add_neg, add_assoc, hz', add_add_neg_cancel'_right, norm_neg]
... = ∥F.eval z∥ / ∥F.derivative.eval a∥ : hz1
... ≤ ∥F.derivative.eval a∥^2 * T^(2^n) / ∥F.derivative.eval a∥ :
  (div_le_div_right deriv_norm_pos).2 hz.2
... = ∥F.derivative.eval a∥ * T^(2^n) : div_sq_cancel deriv_norm_ne_zero _
... < ∥F.derivative.eval a∥ :
  (mul_lt_iff_lt_one_right deriv_norm_pos).2 (T_pow (pow_pos (by norm_num) _))

private def calc_eval_z'  {z z' z1 : ℤ_[p]} (hz' : z' = z - z1) {n} (hz : ih n z)
  (h1 : ∥(↑(F.eval z) : ℚ_[p]) / ↑(F.derivative.eval z)∥ ≤ 1) (hzeq : z1 = ⟨_, h1⟩) :
  {q : ℤ_[p] // F.eval z' = q * z1^2} :=
have hdzne' : (↑(F.derivative.eval z) : ℚ_[p]) ≠ 0, from
  have hdzne : F.derivative.eval z ≠ 0,
    from mt norm_eq_zero.2 (by rw hz.1; apply deriv_norm_ne_zero; assumption),
  λ h, hdzne $ subtype.ext_iff_val.2 h,
let ⟨q, hq⟩ := F.binom_expansion z (-z1) in
have ∥(↑(F.derivative.eval z) * (↑(F.eval z) / ↑(F.derivative.eval z)) : ℚ_[p])∥ ≤ 1,
  by { rw padic_norm_e.mul, exact mul_le_one (padic_int.norm_le_one _) (norm_nonneg _) h1 },
have F.derivative.eval z * (-z1) = -F.eval z, from calc
  F.derivative.eval z * (-z1)
    = (F.derivative.eval z) * -⟨↑(F.eval z) / ↑(F.derivative.eval z), h1⟩ : by rw [hzeq]
... = -((F.derivative.eval z) * ⟨↑(F.eval z) / ↑(F.derivative.eval z), h1⟩) :
  by simp [subtype.ext_iff_val]
... = -(⟨↑(F.derivative.eval z) * (↑(F.eval z) / ↑(F.derivative.eval z)), this⟩) :
  subtype.ext $ by simp
... = -(F.eval z) : by simp [mul_div_cancel' _ hdzne'],
have heq : F.eval z' = q * z1^2, by simpa [sub_eq_add_neg, this, hz'] using hq,
⟨q, heq⟩

private def calc_eval_z'_norm {z z' z1 : ℤ_[p]} {n} (hz : ih n z) {q}
  (heq : F.eval z' = q * z1^2) (h1 : ∥(↑(F.eval z) : ℚ_[p]) / ↑(F.derivative.eval z)∥ ≤ 1)
  (hzeq : z1 = ⟨_, h1⟩) : ∥F.eval z'∥ ≤ ∥F.derivative.eval a∥^2 * T^(2^(n+1)) :=
calc ∥F.eval z'∥
    = ∥q∥ * ∥z1∥^2 : by simp [heq]
... ≤ 1 * ∥z1∥^2 :
  mul_le_mul_of_nonneg_right (padic_int.norm_le_one _) (pow_nonneg (norm_nonneg _) _)
... = ∥F.eval z∥^2 / ∥F.derivative.eval a∥^2 :
  by simp [hzeq, hz.1, div_pow]
... ≤ (∥F.derivative.eval a∥^2 * T^(2^n))^2 / ∥F.derivative.eval a∥^2 :
  (div_le_div_right deriv_sq_norm_pos).2 (pow_le_pow_of_le_left (norm_nonneg _) hz.2 _)
... = (∥F.derivative.eval a∥^2)^2 * (T^(2^n))^2 / ∥F.derivative.eval a∥^2 : by simp only [mul_pow]
... = ∥F.derivative.eval a∥^2 * (T^(2^n))^2 : div_sq_cancel deriv_sq_norm_ne_zero _
... = ∥F.derivative.eval a∥^2 * T^(2^(n + 1)) : by rw [←pow_mul, pow_succ' 2]

set_option eqn_compiler.zeta true

/-- Given `z : ℤ_[p]` satisfying `ih n z`, construct `z' : ℤ_[p]` satisfying `ih (n+1) z'`. We need
the hypothesis `ih n z`, since otherwise `z'` is not necessarily an integer. -/
private def ih_n {n : ℕ} {z : ℤ_[p]} (hz : ih n z) : {z' : ℤ_[p] // ih (n+1) z'} :=
have h1 : ∥(↑(F.eval z) : ℚ_[p]) / ↑(F.derivative.eval z)∥ ≤ 1, from calc_norm_le_one hz,
let z1 : ℤ_[p] := ⟨_, h1⟩,
    z' : ℤ_[p] := z - z1 in
⟨ z',
  have hdist : ∥F.derivative.eval z' - F.derivative.eval z∥ < ∥F.derivative.eval a∥,
    from calc_deriv_dist rfl (by simp [z1, hz.1]) hz,
  have hfeq : ∥F.derivative.eval z'∥ = ∥F.derivative.eval a∥,
    begin
      rw [sub_eq_add_neg, ← hz.1, ←norm_neg (F.derivative.eval z)] at hdist,
      have := padic_int.norm_eq_of_norm_add_lt_right hdist,
      rwa [norm_neg, hz.1] at this
    end,
  let ⟨q, heq⟩ := calc_eval_z' rfl hz h1 rfl in
  have hnle : ∥F.eval z'∥ ≤ ∥F.derivative.eval a∥^2 * T^(2^(n+1)),
    from calc_eval_z'_norm hz heq h1 rfl,
  ⟨hfeq, hnle⟩⟩

set_option eqn_compiler.zeta false

-- why doesn't "noncomputable theory" stick here?
private noncomputable def newton_seq_aux : Π n : ℕ, {z : ℤ_[p] // ih n z}
| 0 := ⟨a, ih_0⟩
| (k+1) := ih_n (newton_seq_aux k).2

private def newton_seq (n : ℕ) : ℤ_[p] := (newton_seq_aux n).1

private lemma newton_seq_deriv_norm (n : ℕ) :
  ∥F.derivative.eval (newton_seq n)∥ = ∥F.derivative.eval a∥ :=
(newton_seq_aux n).2.1

private lemma newton_seq_norm_le (n : ℕ) :
  ∥F.eval (newton_seq n)∥ ≤ ∥F.derivative.eval a∥^2 * T ^ (2^n) :=
(newton_seq_aux n).2.2

private lemma newton_seq_norm_eq (n : ℕ) :
  ∥newton_seq (n+1) - newton_seq n∥ =
    ∥F.eval (newton_seq n)∥ / ∥F.derivative.eval (newton_seq n)∥ :=
by simp [newton_seq, newton_seq_aux, ih_n, sub_eq_add_neg, add_comm]

private lemma newton_seq_succ_dist (n : ℕ) :
  ∥newton_seq (n+1) - newton_seq n∥ ≤ ∥F.derivative.eval a∥ * T^(2^n) :=
calc ∥newton_seq (n+1) - newton_seq n∥
    = ∥F.eval (newton_seq n)∥ / ∥F.derivative.eval (newton_seq n)∥ : newton_seq_norm_eq _
... = ∥F.eval (newton_seq n)∥ / ∥F.derivative.eval a∥ : by rw newton_seq_deriv_norm
... ≤ ∥F.derivative.eval a∥^2 * T ^ (2^n) / ∥F.derivative.eval a∥ :
  (div_le_div_right deriv_norm_pos).2 (newton_seq_norm_le _)
... = ∥F.derivative.eval a∥ * T^(2^n) : div_sq_cancel (ne_of_gt deriv_norm_pos) _

include hnsol
private lemma T_pos : T > 0 :=
begin
  rw T_def,
  exact div_pos (norm_pos_iff.2 hnsol) (deriv_sq_norm_pos hnorm)
end

private lemma newton_seq_succ_dist_weak (n : ℕ) :
  ∥newton_seq (n+2) - newton_seq (n+1)∥ < ∥F.eval a∥ / ∥F.derivative.eval a∥ :=
have 2 ≤ 2^(n+1),
  from have _, from pow_le_pow (by norm_num : 1 ≤ 2) (nat.le_add_left _ _ : 1 ≤ n + 1),
    by simpa using this,
calc ∥newton_seq (n+2) - newton_seq (n+1)∥
    ≤ ∥F.derivative.eval a∥ * T^(2^(n+1)) : newton_seq_succ_dist _
... ≤ ∥F.derivative.eval a∥ * T^2 :
  mul_le_mul_of_nonneg_left (pow_le_pow_of_le_one (norm_nonneg _) (le_of_lt T_lt_one) this)
    (norm_nonneg _)
... < ∥F.derivative.eval a∥ * T^1 :
  mul_lt_mul_of_pos_left (pow_lt_pow_of_lt_one T_pos T_lt_one (by norm_num)) deriv_norm_pos
... = ∥F.eval a∥ / ∥F.derivative.eval a∥ :
  begin
    rw [T, sq, pow_one, normed_field.norm_div, ←mul_div_assoc, padic_norm_e.mul],
    apply mul_div_mul_left,
    apply deriv_norm_ne_zero; assumption
  end

private lemma newton_seq_dist_aux (n : ℕ) :
  ∀ k : ℕ, ∥newton_seq (n + k) - newton_seq n∥ ≤ ∥F.derivative.eval a∥ * T^(2^n)
| 0 := by simp [T_pow_nonneg hnorm, mul_nonneg]
| (k+1) :=
  have 2^n ≤ 2^(n+k),
    by {apply pow_le_pow, norm_num, apply nat.le_add_right},
  calc
  ∥newton_seq (n + (k + 1)) - newton_seq n∥
    = ∥newton_seq ((n + k) + 1) - newton_seq n∥ : by rw add_assoc
... = ∥(newton_seq ((n + k) + 1) - newton_seq (n+k)) + (newton_seq (n+k) - newton_seq n)∥ :
  by rw ←sub_add_sub_cancel
... ≤ max (∥newton_seq ((n + k) + 1) - newton_seq (n+k)∥) (∥newton_seq (n+k) - newton_seq n∥) :
  padic_int.nonarchimedean _ _
... ≤ max (∥F.derivative.eval a∥ * T^(2^((n + k)))) (∥F.derivative.eval a∥ * T^(2^n)) :
  max_le_max (newton_seq_succ_dist _) (newton_seq_dist_aux _)
... = ∥F.derivative.eval a∥ * T^(2^n) :
  max_eq_right $ mul_le_mul_of_nonneg_left
    (pow_le_pow_of_le_one (norm_nonneg _) (le_of_lt T_lt_one) this) (norm_nonneg _)

private lemma newton_seq_dist {n k : ℕ} (hnk : n ≤ k) :
  ∥newton_seq k - newton_seq n∥ ≤ ∥F.derivative.eval a∥ * T^(2^n) :=
have hex : ∃ m, k = n + m, from exists_eq_add_of_le hnk,
let ⟨_, hex'⟩ := hex in
by rw hex'; apply newton_seq_dist_aux; assumption

private lemma newton_seq_dist_to_a :
  ∀ n : ℕ, 0 < n → ∥newton_seq n - a∥ = ∥F.eval a∥ / ∥F.derivative.eval a∥
| 1 h := by simp [sub_eq_add_neg, add_assoc, newton_seq, newton_seq_aux, ih_n]
| (k+2) h :=
  have hlt : ∥newton_seq (k+2) - newton_seq (k+1)∥ < ∥newton_seq (k+1) - a∥,
    by rw newton_seq_dist_to_a (k+1) (succ_pos _); apply newton_seq_succ_dist_weak; assumption,
  have hne' : ∥newton_seq (k + 2) - newton_seq (k+1)∥ ≠ ∥newton_seq (k+1) - a∥, from ne_of_lt hlt,
  calc  ∥newton_seq (k + 2) - a∥
    = ∥(newton_seq (k + 2) - newton_seq (k+1)) + (newton_seq (k+1) - a)∥ : by rw ←sub_add_sub_cancel
... = max (∥newton_seq (k + 2) - newton_seq (k+1)∥) (∥newton_seq (k+1) - a∥) :
  padic_int.norm_add_eq_max_of_ne hne'
... = ∥newton_seq (k+1) - a∥ : max_eq_right_of_lt hlt
... = ∥polynomial.eval a F∥ / ∥polynomial.eval a (polynomial.derivative F)∥ :
  newton_seq_dist_to_a (k+1) (succ_pos _)

private lemma bound' : tendsto (λ n : ℕ, ∥F.derivative.eval a∥ * T^(2^n)) at_top (𝓝 0) :=
begin
  rw ←mul_zero (∥F.derivative.eval a∥),
  exact tendsto_const_nhds.mul
                    (tendsto.comp
                      (tendsto_pow_at_top_nhds_0_of_lt_1 (norm_nonneg _) (T_lt_one hnorm))
                      (nat.tendsto_pow_at_top_at_top_of_one_lt (by norm_num)))
end

private lemma bound : ∀ {ε}, ε > 0 → ∃ N : ℕ, ∀ {n}, n ≥ N → ∥F.derivative.eval a∥ * T^(2^n) < ε :=
have mtn : ∀ n : ℕ, ∥polynomial.eval a (polynomial.derivative F)∥ * T ^ (2 ^ n) ≥ 0,
  from λ n, mul_nonneg (norm_nonneg _) (T_pow_nonneg _),
begin
  have := bound' hnorm hnsol,
  simp [tendsto, nhds] at this,
  intros ε hε,
  cases this (ball 0 ε) (mem_ball_self hε) (is_open_ball) with N hN,
  existsi N, intros n hn,
  simpa [normed_field.norm_mul, real.norm_eq_abs, abs_of_nonneg (mtn n)] using hN _ hn
end

private lemma bound'_sq : tendsto (λ n : ℕ, ∥F.derivative.eval a∥^2 * T^(2^n)) at_top (𝓝 0) :=
begin
  rw [←mul_zero (∥F.derivative.eval a∥), sq],
  simp only [mul_assoc],
  apply tendsto.mul,
  { apply tendsto_const_nhds },
  { apply bound', assumption }
end

private theorem newton_seq_is_cauchy : is_cau_seq norm newton_seq :=
begin
  intros ε hε,
  cases bound hnorm hnsol hε with N hN,
  existsi N,
  intros j hj,
  apply lt_of_le_of_lt,
  { apply newton_seq_dist _ _ hj, assumption },
  { apply hN, apply le_refl }
end

private def newton_cau_seq : cau_seq ℤ_[p] norm := ⟨_, newton_seq_is_cauchy⟩

private def soln : ℤ_[p] := newton_cau_seq.lim

private lemma soln_spec {ε : ℝ} (hε : ε > 0) :
  ∃ (N : ℕ), ∀ {i : ℕ}, i ≥ N → ∥soln - newton_cau_seq i∥ < ε :=
setoid.symm (cau_seq.equiv_lim newton_cau_seq) _ hε

private lemma soln_deriv_norm : ∥F.derivative.eval soln∥ = ∥F.derivative.eval a∥ :=
norm_deriv_eq newton_seq_deriv_norm

private lemma newton_seq_norm_tendsto_zero :
  tendsto (λ i, ∥F.eval (newton_cau_seq i)∥) at_top (𝓝 0) :=
squeeze_zero (λ _, norm_nonneg _) newton_seq_norm_le bound'_sq

private lemma newton_seq_dist_tendsto :
  tendsto (λ n, ∥newton_cau_seq n - a∥) at_top (𝓝 (∥F.eval a∥ / ∥F.derivative.eval a∥)) :=
tendsto_const_nhds.congr' $ eventually_at_top.2 ⟨1, λ _ hx, (newton_seq_dist_to_a _ hx).symm⟩

private lemma newton_seq_dist_tendsto' :
  tendsto (λ n, ∥newton_cau_seq n - a∥) at_top (𝓝 ∥soln - a∥) :=
(continuous_norm.tendsto _).comp (newton_cau_seq.tendsto_limit.sub tendsto_const_nhds)

private lemma soln_dist_to_a : ∥soln - a∥ = ∥F.eval a∥ / ∥F.derivative.eval a∥ :=
tendsto_nhds_unique newton_seq_dist_tendsto' newton_seq_dist_tendsto

private lemma soln_dist_to_a_lt_deriv : ∥soln - a∥ < ∥F.derivative.eval a∥ :=
begin
  rw [soln_dist_to_a, div_lt_iff],
  { rwa sq at hnorm },
  { apply deriv_norm_pos, assumption }
end

private lemma eval_soln : F.eval soln = 0 :=
limit_zero_of_norm_tendsto_zero newton_seq_norm_tendsto_zero

private lemma soln_unique (z : ℤ_[p]) (hev : F.eval z = 0)
  (hnlt : ∥z - a∥ < ∥F.derivative.eval a∥) :
  z = soln :=
have soln_dist : ∥z - soln∥ < ∥F.derivative.eval a∥, from calc
  ∥z - soln∥ = ∥(z - a) + (a - soln)∥ : by rw sub_add_sub_cancel
        ... ≤ max (∥z - a∥) (∥a - soln∥) : padic_int.nonarchimedean _ _
        ... < ∥F.derivative.eval a∥ : max_lt hnlt (norm_sub_rev soln a ▸ soln_dist_to_a_lt_deriv),
let h := z - soln,
    ⟨q, hq⟩ := F.binom_expansion soln h in
have (F.derivative.eval soln + q * h) * h = 0, from eq.symm (calc
  0 = F.eval (soln + h) : by simp [hev, h]
... = F.derivative.eval soln * h + q * h^2 : by rw [hq, eval_soln, zero_add]
... = (F.derivative.eval soln + q * h) * h : by rw [sq, right_distrib, mul_assoc]),
have h = 0, from by_contradiction $ λ hne,
  have F.derivative.eval soln + q * h = 0,
    from (eq_zero_or_eq_zero_of_mul_eq_zero this).resolve_right hne,
  have F.derivative.eval soln = (-q) * h, by simpa using eq_neg_of_add_eq_zero this,
  lt_irrefl ∥F.derivative.eval soln∥ (calc
  ∥F.derivative.eval soln∥ = ∥(-q) * h∥ : by rw this
... ≤ 1 * ∥h∥ :
  by { rw padic_int.norm_mul,
       exact mul_le_mul_of_nonneg_right (padic_int.norm_le_one _) (norm_nonneg _) }
... = ∥z - soln∥ : by simp [h]
... < ∥F.derivative.eval soln∥ : by rw soln_deriv_norm; apply soln_dist),
eq_of_sub_eq_zero (by rw ←this; refl)

end hensel

variables {p : ℕ} [fact p.prime] {F : polynomial ℤ_[p]} {a : ℤ_[p]}

private lemma a_soln_is_unique (ha : F.eval a = 0) (z' : ℤ_[p]) (hz' : F.eval z' = 0)
  (hnormz' : ∥z' - a∥ < ∥F.derivative.eval a∥) : z' = a :=
let h := z' - a,
    ⟨q, hq⟩ := F.binom_expansion a h in
have (F.derivative.eval a + q * h) * h = 0, from eq.symm (calc
  0 = F.eval (a + h) : show 0 = F.eval (a + (z' - a)), by rw add_comm; simp [hz']
... = F.derivative.eval a * h + q * h^2 : by rw [hq, ha, zero_add]
... = (F.derivative.eval a + q * h) * h : by rw [sq, right_distrib, mul_assoc]),
have h = 0, from by_contradiction $ λ hne,
  have F.derivative.eval a + q * h = 0,
    from (eq_zero_or_eq_zero_of_mul_eq_zero this).resolve_right hne,
  have F.derivative.eval a = (-q) * h, by simpa using eq_neg_of_add_eq_zero this,
  lt_irrefl ∥F.derivative.eval a∥ (calc
    ∥F.derivative.eval a∥ = ∥q∥*∥h∥ : by simp [this]
    ... ≤ 1*∥h∥ : mul_le_mul_of_nonneg_right (padic_int.norm_le_one _) (norm_nonneg _)
    ... < ∥F.derivative.eval a∥ : by simpa [h]),
eq_of_sub_eq_zero (by rw ←this; refl)

variable (hnorm : ∥F.eval a∥ < ∥F.derivative.eval a∥^2)
include hnorm

private lemma a_is_soln (ha : F.eval a = 0) :
  F.eval a = 0 ∧ ∥a - a∥ < ∥F.derivative.eval a∥ ∧ ∥F.derivative.eval a∥ = ∥F.derivative.eval a∥ ∧
  ∀ z', F.eval z' = 0 → ∥z' - a∥ < ∥F.derivative.eval a∥ → z' = a :=
⟨ha, by simp [deriv_ne_zero hnorm], rfl, a_soln_is_unique ha⟩

lemma hensels_lemma : ∃ z : ℤ_[p], F.eval z = 0 ∧ ∥z - a∥ < ∥F.derivative.eval a∥ ∧
  ∥F.derivative.eval z∥ = ∥F.derivative.eval a∥ ∧
  ∀ z', F.eval z' = 0 → ∥z' - a∥ < ∥F.derivative.eval a∥ → z' = z :=
if ha : F.eval a = 0 then ⟨a, a_is_soln hnorm ha⟩ else
by refine ⟨soln _ _, eval_soln _ _, soln_dist_to_a_lt_deriv _ _, soln_deriv_norm _ _,
  soln_unique _ _⟩; assumption