/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Sean Leather
-/
import data.list.range
import data.list.perm

/-!
# Utilities for lists of sigmas

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

This file includes several ways of interacting with `list (sigma β)`, treated as a key-value store.

If `α : Type*` and `β : α → Type*`, then we regard `s : sigma β` as having key `s.1 : α` and value
`s.2 : β s.1`. Hence, `list (sigma β)` behaves like a key-value store.

## Main Definitions

- `list.keys` extracts the list of keys.
- `list.nodupkeys` determines if the store has duplicate keys.
- `list.lookup`/`lookup_all` accesses the value(s) of a particular key.
- `list.kreplace` replaces the first value with a given key by a given value.
- `list.kerase` removes a value.
- `list.kinsert` inserts a value.
- `list.kunion` computes the union of two stores.
- `list.kextract` returns a value with a given key and the rest of the values.
-/

universes u v

namespace list
variables {α : Type u} {β : α → Type v} {l l₁ l₂ : list (sigma β)}

/-! ### `keys` -/

/-- List of keys from a list of key-value pairs -/
def keys : list (sigma β) → list α := map sigma.fst

@[simp] theorem keys_nil : @keys α β [] = [] := rfl

@[simp] theorem keys_cons {s} {l : list (sigma β)} : (s :: l).keys = s.1 :: l.keys := rfl

theorem mem_keys_of_mem {s : sigma β} {l : list (sigma β)} : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {a} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a} {l : list (sigma β)} : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

theorem not_mem_keys {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ b : β a, sigma.mk a b ∉ l :=
(not_iff_not_of_iff mem_keys).trans not_exists

theorem not_eq_key {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ s : sigma β, s ∈ l → a ≠ s.1 :=
iff.intro
  (λ h₁ s h₂ e, absurd (mem_keys_of_mem h₂) (by rwa e at h₁))
  (λ f h₁, let ⟨b, h₂⟩ := exists_of_mem_keys h₁ in f _ h₂ rfl)

/-! ### `nodupkeys` -/

/-- Determines whether the store uses a key several times. -/
def nodupkeys (l : list (sigma β)) : Prop := l.keys.nodup

theorem nodupkeys_iff_pairwise {l} : nodupkeys l ↔
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l := pairwise_map _

theorem nodupkeys.pairwise_ne {l} (h : nodupkeys l) :
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l :=
nodupkeys_iff_pairwise.1 h

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] := pairwise.nil

@[simp] theorem nodupkeys_cons {s : sigma β} {l : list (sigma β)} :
  nodupkeys (s::l) ↔ s.1 ∉ l.keys ∧ nodupkeys l :=
by simp [keys, nodupkeys]

theorem not_mem_keys_of_nodupkeys_cons {s : sigma β} {l : list (sigma β)} (h : nodupkeys (s :: l)) :
  s.1 ∉ l.keys := (nodupkeys_cons.1 h).1

theorem nodupkeys_of_nodupkeys_cons {s : sigma β} {l : list (sigma β)} (h : nodupkeys (s :: l)) :
  nodupkeys l := (nodupkeys_cons.1 h).2

theorem nodupkeys.eq_of_fst_eq {l : list (sigma β)}
  (nd : nodupkeys l) {s s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) :
  s.1 = s'.1 → s = s' :=
@pairwise.forall_of_forall _
  (λ s s' : sigma β, s.1 = s'.1 → s = s') _
  (λ s s' H h, (H h.symm).symm) (λ x h _, rfl)
  ((nodupkeys_iff_pairwise.1 nd).imp (λ s s' h h', (h h').elim)) _ h _ h'

theorem nodupkeys.eq_of_mk_mem {a : α} {b b' : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' :=
by cases nd.eq_of_fst_eq h h' rfl; refl

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] := nodup_singleton _

theorem nodupkeys.sublist {l₁ l₂ : list (sigma β)} (h : l₁ <+ l₂) :
  nodupkeys l₂ → nodupkeys l₁ :=
nodup.sublist $ h.map _

protected lemma nodupkeys.nodup {l : list (sigma β)} : nodupkeys l → nodup l := nodup.of_map _

theorem perm_nodupkeys {l₁ l₂ : list (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
(h.map _).nodup_iff

theorem nodupkeys_join {L : list (list (sigma β))} :
  nodupkeys (join L) ↔ (∀ l ∈ L, nodupkeys l) ∧ pairwise disjoint (L.map keys) :=
begin
  rw [nodupkeys_iff_pairwise, pairwise_join, pairwise_map],
  refine and_congr (ball_congr $ λ l h, by simp [nodupkeys_iff_pairwise]) _,
  apply iff_of_eq, congr' with l₁ l₂,
  simp [keys, disjoint_iff_ne]
end

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

lemma mem_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodup) (nd₁ : l₁.nodup)
  (h : ∀ x, x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
begin
  induction l₀ with x xs generalizing l₁; cases l₁ with y ys,
  { constructor },
  iterate 2
  { specialize h x <|> specialize h y, simp at h,
    cases h },
  simp at nd₀ nd₁, classical,
  obtain rfl | h' := eq_or_ne x y,
  { constructor,
    refine l₀_ih nd₀.2 nd₁.2 (λ a, _),
    specialize h a, simp at h,
    obtain rfl | h' := eq_or_ne a x,
    { exact iff_of_false nd₀.1 nd₁.1 },
    { simpa [h'] using h } },
  { transitivity x :: y :: ys.erase x,
    { constructor,
      refine l₀_ih nd₀.2 ((nd₁.2.erase _).cons $ λ h, nd₁.1 $ mem_of_mem_erase h) (λ a, _),
      { specialize h a, simp at h,
        obtain rfl | h' := eq_or_ne a x,
        { exact iff_of_false nd₀.1 (λ h, h.elim h' nd₁.2.not_mem_erase) },
        { rw or_iff_right h' at h,
          rw [h, mem_cons_iff],
          exact or_congr_right' (mem_erase_of_ne h').symm } } },
    transitivity y :: x :: ys.erase x,
    { constructor },
    { constructor, symmetry, apply perm_cons_erase,
      specialize h x, simp [h'] at h, exact h } }
end

variables [decidable_eq α]

/-! ### `lookup` -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup (a : α) : list (sigma β) → option (β a)
| []             := none
| (⟨a', b⟩ :: l) := if h : a' = a then some (eq.rec_on h b) else lookup l

@[simp] theorem lookup_nil (a : α) : lookup a [] = @none (β a) := rfl

@[simp] theorem lookup_cons_eq (l) (a : α) (b : β a) : lookup a (⟨a, b⟩::l) = some b :=
dif_pos rfl

@[simp] theorem lookup_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup a (s::l) = lookup a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_is_some {a : α} : ∀ {l : list (sigma β)},
  (lookup a l).is_some ↔ a ∈ l.keys
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_is_some] },
end

theorem lookup_eq_none {a : α} {l : list (sigma β)} :
  lookup a l = none ↔ a ∉ l.keys :=
by simp [← lookup_is_some, option.is_none_iff_eq_none]

theorem of_mem_lookup
  {a : α} {b : β a} : ∀ {l : list (sigma β)}, b ∈ lookup a l → sigma.mk a b ∈ l
| (⟨a', b'⟩ :: l) H := begin
  by_cases h : a = a',
  { subst a', simp at H, simp [H] },
  { simp [h] at H, exact or.inr (of_mem_lookup H) }
end

theorem mem_lookup {a} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys)
  (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
begin
  cases option.is_some_iff_exists.mp (lookup_is_some.mpr (mem_keys_of_mem h)) with b' h',
  cases nd.eq_of_mk_mem h (of_mem_lookup h'),
  exact h'
end

theorem map_lookup_eq_find (a : α) : ∀ l : list (sigma β),
  (lookup a l).map (sigma.mk a) = find (λ s, a = s.1) l
| [] := rfl
| (⟨a', b'⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, map_lookup_eq_find] }
end

theorem mem_lookup_iff {a : α} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys) :
  b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
⟨of_mem_lookup, mem_lookup nd⟩

theorem perm_lookup (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ :=
by ext b; simp [mem_lookup_iff, nd₁, nd₂]; exact p.mem_iff

lemma lookup_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodupkeys) (nd₁ : l₁.nodupkeys)
  (h : ∀ x y, y ∈ l₀.lookup x ↔ y ∈ l₁.lookup x) : l₀ ~ l₁ :=
mem_ext nd₀.nodup nd₁.nodup (λ ⟨a,b⟩, by rw [← mem_lookup_iff, ← mem_lookup_iff, h]; assumption)

/-! ### `lookup_all` -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all (a : α) : list (sigma β) → list (β a)
| []             := []
| (⟨a', b⟩ :: l) := if h : a' = a then eq.rec_on h b :: lookup_all l else lookup_all l

@[simp]

@[simp] theorem lookup_all_cons_eq (l) (a : α) (b : β a) :
  lookup_all a (⟨a, b⟩::l) = b :: lookup_all a l :=
dif_pos rfl

@[simp] theorem lookup_all_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup_all a (s::l) = lookup_all a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_all_eq_nil {a : α} : ∀ {l : list (sigma β)},
  lookup_all a l = [] ↔ ∀ b : β a, sigma.mk a b ∉ l
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_all_eq_nil] },
end

theorem head_lookup_all (a : α) : ∀ l : list (sigma β),
  head' (lookup_all a l) = lookup a l
| []             := by simp
| (⟨a', b⟩ :: l) := by by_cases h : a = a'; [{subst h, simp}, simp *]

theorem mem_lookup_all {a : α} {b : β a} :
  ∀ {l : list (sigma β)}, b ∈ lookup_all a l ↔ sigma.mk a b ∈ l
| []              := by simp
| (⟨a', b'⟩ :: l) := by by_cases h : a = a'; [{subst h, simp *}, simp *]

theorem lookup_all_sublist (a : α) :
  ∀ l : list (sigma β), (lookup_all a l).map (sigma.mk a) <+ l
| []              := by simp
| (⟨a', b'⟩ :: l) := begin
    by_cases h : a = a',
    { subst h, simp, exact (lookup_all_sublist l).cons2 _ _ _ },
    { simp [h], exact (lookup_all_sublist l).cons _ _ _ }
  end

theorem lookup_all_length_le_one (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  length (lookup_all a l) ≤ 1 :=
by have := nodup.sublist ((lookup_all_sublist a l).map _) h;
   rw map_map at this; rwa [← nodup_replicate, ← map_const _ a]

theorem lookup_all_eq_lookup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  lookup_all a l = (lookup a l).to_list :=
begin
  rw ← head_lookup_all,
  have := lookup_all_length_le_one a h, revert this,
  rcases lookup_all a l with _|⟨b, _|⟨c, l⟩⟩; intro; try {refl},
  exact absurd this dec_trivial
end

theorem lookup_all_nodup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  (lookup_all a l).nodup :=
by rw lookup_all_eq_lookup a h; apply option.to_list_nodup

theorem perm_lookup_all (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ :=
by simp [lookup_all_eq_lookup, nd₁, nd₂, perm_lookup a nd₁ nd₂ p]

/-! ### `kreplace` -/

/-- Replaces the first value with key `a` by `b`. -/
def kreplace (a : α) (b : β a) : list (sigma β) → list (sigma β) :=
lookmap $ λ s, if a = s.1 then some ⟨a, b⟩ else none

theorem kreplace_of_forall_not (a : α) (b : β a) {l : list (sigma β)}
  (H : ∀ b : β a, sigma.mk a b ∉ l) : kreplace a b l = l :=
lookmap_of_forall_not _ $ begin
  rintro ⟨a', b'⟩ h, dsimp, split_ifs,
  { subst a', exact H _ h }, {refl}
end

theorem kreplace_self {a : α} {b : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
begin
  refine (lookmap_congr _).trans
    (lookmap_id' (option.guard (λ s, a = s.1)) _ _),
  { rintro ⟨a', b'⟩ h', dsimp [option.guard], split_ifs,
    { subst a', exact ⟨rfl, heq_of_eq $ nd.eq_of_mk_mem h h'⟩ },
    { refl } },
  { rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, dsimp [option.guard], split_ifs,
    { exact id }, { rintro ⟨⟩ } },
end

theorem keys_kreplace (a : α) (b : β a) : ∀ l : list (sigma β),
  (kreplace a b l).keys = l.keys :=
lookmap_map_eq _ _ $ by rintro ⟨a₁, b₂⟩ ⟨a₂, b₂⟩;
  dsimp; split_ifs; simp [h] {contextual := tt}

theorem kreplace_nodupkeys (a : α) (b : β a) {l : list (sigma β)} :
  (kreplace a b l).nodupkeys ↔ l.nodupkeys :=
by simp [nodupkeys, keys_kreplace]

theorem perm.kreplace {a : α} {b : β a} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ →
  kreplace a b l₁ ~ kreplace a b l₂ :=
perm_lookmap _ $ begin
  refine nd.pairwise_ne.imp _,
  intros x y h z h₁ w h₂,
  split_ifs at h₁ h₂; cases h₁; cases h₂,
  exact (h (h_2.symm.trans h_1)).elim
end

/-! ### `kerase` -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : list (sigma β) → list (sigma β) :=
erasep $ λ s, a = s.1

@[simp] theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
rfl

@[simp, priority 990]
theorem kerase_cons_eq {a} {s : sigma β} {l : list (sigma β)} (h : a = s.1) :
  kerase a (s :: l) = l :=
by simp [kerase, h]

@[simp, priority 990]
theorem kerase_cons_ne {a} {s : sigma β} {l : list (sigma β)} (h : a ≠ s.1) :
  kerase a (s :: l) = s :: kerase a l :=
by simp [kerase, h]

@[simp, priority 980]
theorem kerase_of_not_mem_keys {a} {l : list (sigma β)} (h : a ∉ l.keys) :
  kerase a l = l :=
by induction l with _ _ ih;
   [refl, { simp [not_or_distrib] at h, simp [h.1, ih h.2] }]

theorem kerase_sublist (a : α) (l : list (sigma β)) : kerase a l <+ l :=
erasep_sublist _

theorem kerase_keys_subset (a) (l : list (sigma β)) :
  (kerase a l).keys ⊆ l.keys :=
((kerase_sublist a l).map _).subset

theorem mem_keys_of_mem_keys_kerase {a₁ a₂} {l : list (sigma β)} :
  a₁ ∈ (kerase a₂ l).keys → a₁ ∈ l.keys :=
@kerase_keys_subset _ _ _ _ _ _

theorem exists_of_kerase {a : α} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    kerase a l = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih
  { by_cases e : a = hd.1,
    { subst e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h e },
      case or.inr : h
      { rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem e h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

@[simp, priority 990]
theorem mem_keys_kerase_of_ne {a₁ a₂} {l : list (sigma β)} (h : a₁ ≠ a₂) :
  a₁ ∈ (kerase a₂ l).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, kerase a₂ l, exists_of_kerase q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [keys, h] using p
    end
  else
    by simp [q, p]

theorem keys_kerase {a} {l : list (sigma β)} : (kerase a l).keys = l.keys.erase a :=
by rw [keys, kerase, ←erasep_map sigma.fst l, erase_eq_erasep]

theorem kerase_kerase {a a'} {l : list (sigma β)} :
  (kerase a' l).kerase a = (kerase a l).kerase a' :=
begin
  by_cases a = a',
  { subst a' },
  induction l with x xs, { refl },
  { by_cases a' = x.1,
    { subst a', simp [kerase_cons_ne h,kerase_cons_eq rfl] },
    by_cases h' : a = x.1,
    { subst a, simp [kerase_cons_eq rfl,kerase_cons_ne (ne.symm h)] },
    { simp [kerase_cons_ne,*] } }
end

lemma nodupkeys.kerase (a : α) : nodupkeys l → (kerase a l).nodupkeys :=
nodupkeys.sublist $ kerase_sublist _ _

theorem perm.kerase {a : α} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
perm.erasep _ $ (nodupkeys_iff_pairwise.1 nd).imp $
by rintro x y h rfl; exact h

@[simp] theorem not_mem_keys_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  a ∉ (kerase a l).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih
  { simp at nd,
    by_cases h : a = hd.1,
    { subst h, simp [nd.1] },
    { simp [h, ih nd.2] } }
end

@[simp] theorem lookup_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  lookup a (kerase a l) = none :=
lookup_eq_none.mpr (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {a a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kerase a' l) = lookup a l :=
begin
  induction l,
  case list.nil { refl },
  case list.cons : hd tl ih
  { cases hd with ah bh,
    by_cases h₁ : a = ah; by_cases h₂ : a' = ah,
    { substs h₁ h₂, cases ne.irrefl h },
    { subst h₁, simp [h₂] },
    { subst h₂, simp [h] },
    { simp [h₁, h₂, ih] } }
end

theorem kerase_append_left {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂
| []        _  h  := by cases h
| (s :: l₁) l₂ h₁ :=
  if h₂ : a = s.1 then
    by simp [h₂]
  else
    by simp at h₁;
       cases h₁;
       [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂
| []        _  h := rfl
| (_ :: l₁) l₂ h := by simp [not_or_distrib] at h;
                       simp [h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂) (l : list (sigma β)) :
  kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
if h : a₁ = a₂ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, kerase a₁ l, exists_of_kerase ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

lemma sizeof_kerase {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)] (x : α)
  (xs : list (sigma β)) :
  sizeof (list.kerase x xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with y ys,
  { simp },
  { by_cases x = y.1; simp [*, list.sizeof] },
end

/-! ### `kinsert` -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert (a : α) (b : β a) (l : list (sigma β)) : list (sigma β) :=
⟨a, b⟩ :: kerase a l

@[simp] theorem kinsert_def {a} {b : β a} {l : list (sigma β)} :
  kinsert a b l = ⟨a, b⟩ :: kerase a l := rfl

theorem mem_keys_kinsert {a a'} {b' : β a'} {l : list (sigma β)} :
  a ∈ (kinsert a' b' l).keys ↔ a = a' ∨ a ∈ l.keys :=
by by_cases h : a = a'; simp [h]

theorem kinsert_nodupkeys (a) (b : β a) {l : list (sigma β)} (nd : l.nodupkeys) :
  (kinsert a b l).nodupkeys :=
nodupkeys_cons.mpr ⟨not_mem_keys_kerase a nd, nd.kerase a⟩

theorem perm.kinsert {a} {b : β a} {l₁ l₂ : list (sigma β)} (nd₁ : l₁.nodupkeys)
  (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
(p.kerase nd₁).cons _

theorem lookup_kinsert {a} {b : β a} (l : list (sigma β)) :
  lookup a (kinsert a b l) = some b :=
by simp only [kinsert, lookup_cons_eq]

theorem lookup_kinsert_ne {a a'} {b' : β a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kinsert a' b' l) = lookup a l :=
by simp [h]

/-! ### `kextract` -/

/-- Finds the first entry with a given key `a` and returns its value (as an `option` because there
might be no entry with key `a`) alongside with the rest of the entries. -/
def kextract (a : α) : list (sigma β) → option (β a) × list (sigma β)
| []     := (none, [])
| (s::l) := if h : s.1 = a then (some (eq.rec_on h s.2), l) else
  let (b', l') := kextract l in (b', s :: l')

@[simp] theorem kextract_eq_lookup_kerase (a : α) :
  ∀ l : list (sigma β), kextract a l = (lookup a l, kerase a l)
| []     := rfl
| (⟨a', b⟩::l) := begin
    simp [kextract], dsimp, split_ifs,
    { subst a', simp [kerase] },
    { simp [kextract, ne.symm h, kextract_eq_lookup_kerase l, kerase] }
  end

/-! ### `dedupkeys` -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def dedupkeys : list (sigma β) → list (sigma β) :=
list.foldr (λ x, kinsert x.1 x.2) []

lemma dedupkeys_cons {x : sigma β} (l : list (sigma β)) :
  dedupkeys (x :: l) = kinsert x.1 x.2 (dedupkeys l) := rfl

lemma nodupkeys_dedupkeys (l : list (sigma β)) : nodupkeys (dedupkeys l) :=
begin
  dsimp [dedupkeys], generalize hl : nil = l',
  have : nodupkeys l', { rw ← hl, apply nodup_nil },
  clear hl,
  induction l with x xs,
  { apply this },
  { cases x, simp [dedupkeys], split,
    { simp [keys_kerase], apply l_ih.not_mem_erase },
    { exact l_ih.kerase _ } }
end

lemma lookup_dedupkeys (a : α) (l : list (sigma β)) : lookup a (dedupkeys l) = lookup a l :=
begin
  induction l, refl,
  cases l_hd with a' b,
  by_cases a = a',
  { subst a', rw [dedupkeys_cons,lookup_kinsert,lookup_cons_eq] },
  { rw [dedupkeys_cons,lookup_kinsert_ne h,l_ih,lookup_cons_ne], exact h },
end

lemma sizeof_dedupkeys {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)]
  (xs : list (sigma β)) :
  sizeof (list.dedupkeys xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with x xs,
  { simp [list.dedupkeys] },
  { simp only [dedupkeys_cons, list.sizeof, kinsert_def, add_le_add_iff_left, sigma.eta],
    transitivity, apply sizeof_kerase,
    assumption }
end

/-! ### `kunion` -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion : list (sigma β) → list (sigma β) → list (sigma β)
| []        l₂ := l₂
| (s :: l₁) l₂ := s :: kunion l₁ (kerase s.1 l₂)

@[simp] theorem nil_kunion {l : list (sigma β)} : kunion [] l = l :=
rfl

@[simp] theorem kunion_nil : ∀ {l : list (sigma β)}, kunion l [] = l
| []       := rfl
| (_ :: l) := by rw [kunion, kerase_nil, kunion_nil]

@[simp] theorem kunion_cons {s} {l₁ l₂ : list (sigma β)} :
  kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase s.1 l₂) :=
rfl

@[simp] theorem mem_keys_kunion {a} {l₁ l₂ : list (sigma β)} :
  a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s l₁ ih { by_cases h : a = s.1; [simp [h], simp [h, ih]] }
end

@[simp] theorem kunion_kerase {a} : ∀ {l₁ l₂ : list (sigma β)},
  kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂)
| []       _ := rfl
| (s :: _) l := by by_cases h : a = s.1;
                   simp [h, kerase_comm a s.1 l, kunion_kerase]

lemma nodupkeys.kunion
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) : (kunion l₁ l₂).nodupkeys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp only [nil_kunion, nd₂] },
  case list.cons : s l₁ ih
  { simp at nd₁,
    simp [not_or_distrib, nd₁.1, nd₂, ih nd₁.2 (nd₂.kerase s.1)] }
end

theorem perm.kunion_right {l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (l) :
  kunion l₁ l ~ kunion l₂ l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.cons : hd tl₁ tl₂ p ih
  { simp [ih (kerase hd.1 l), perm.cons] },
  case list.perm.swap : s₁ s₂ l
  { simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃
  { exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm.kunion_left : ∀ l {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
| []       _  _  _   p := p
| (s :: l) l₁ l₂ nd₁ p :=
  by simp [((p.kerase nd₁).kunion_left l $ nd₁.kerase s.1).cons s]

theorem perm.kunion {l₁ l₂ l₃ l₄ : list (sigma β)} (nd₃ : l₃.nodupkeys)
  (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
(p₁₂.kunion_right l₃).trans (p₃₄.kunion_left l₂ nd₃)

@[simp] theorem lookup_kunion_left {a} {l₁ l₂ : list (sigma β)} (h : a ∈ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₁ :=
begin
  induction l₁ with s _ ih generalizing l₂; simp at h; cases h; cases s with a',
  { subst h, simp },
  { rw kunion_cons,
    by_cases h' : a = a',
    { subst h', simp },
    { simp [h', ih h] } }
end

@[simp] theorem lookup_kunion_right {a} {l₁ l₂ : list (sigma β)} (h : a ∉ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : _ _ ih { simp [not_or_distrib] at h, simp [h.1, ih h.2] }
end

@[simp] theorem mem_lookup_kunion {a} {b : β a} {l₁ l₂ : list (sigma β)} :
  b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s _ ih
  { cases s with a',
    by_cases h₁ : a = a',
    { subst h₁, simp },
    { let h₂ := @ih (kerase a' l₂), simp [h₁] at h₂, simp [h₁, h₂] } }
end

theorem mem_lookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : list (sigma β)}
  (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
  b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
match mem_lookup_kunion.mp h₁ with
| or.inl h := mem_lookup_kunion.mpr (or.inl (mem_lookup_kunion.mpr (or.inl h)))
| or.inr h := mem_lookup_kunion.mpr $
  or.inr ⟨mt mem_keys_kunion.mp (not_or_distrib.mpr ⟨h.1, h₂⟩), h.2⟩
end

end list


/-
Copyright (c) 2023 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.distribution_semantics.defs.equiv

/-!
# Distribution Semantics of Queries

This file gives various lemmas for probabilities outcomes of the computation `query i t`.
-/

namespace oracle_comp

open oracle_spec
open_locale big_operators ennreal

variables {α β γ : Type} {spec spec': oracle_spec} (i : spec.ι) (i' : spec'.ι)

section query_eq_iff

/-- A computation is distributionally equivalent to query iff all outcomes are equally likely. -/
lemma query_dist_equiv_iff (t : spec.domain i) (oa : oracle_comp spec' (spec.range i)) :
  query i t ≃ₚ oa ↔ ∀ u u', ⁅= u | oa⁆ = ⁅= u' | oa⁆ :=
begin
  sorry,
end

-- lemma eval_dist_query_eq_iff (t : spec.domain i) (p : pmf (spec.range i)) :
--   ⁅query i t⁆ = p ↔ ∀ x x', p x = p x' :=
-- begin
--   rw [eval_dist_query],
--   simp [pmf.ext_iff],
-- end

lemma eval_dist_query_apply_eq_iff (t : spec.domain i) (u : spec.range i) (r : ℝ≥0∞) :
  ⁅= u | query i t⁆ = r ↔ ↑(fintype.card $ spec.range i) = r⁻¹ :=
by rw [eval_dist_query_apply_eq_inv, inv_eq_iff_eq_inv]

lemma eval_dist_query_apply_eq_iff_mul_eq_one (t : spec.domain i) (u : spec.range i) (r : ℝ≥0∞) :
  ⁅= u | query i t⁆ = r ↔ r * (fintype.card $ spec.range i) = 1 :=
begin
  rw [eval_dist_query_apply_eq_iff],
  sorry,
end

end query_eq_iff

lemma prob_event_coe_finset (t : spec.domain i) (e : finset (spec.range i)) :
  ⁅↑e | query i t⁆ = e.card / (fintype.card (spec.range i)) :=
by simp_rw [prob_event_query, finset.coe_sort_coe, fintype.card_coe]

lemma eval_dist_query_apply_ne_zero (t : spec.domain i) (u : spec.range i) :
  ⁅= u | query i t⁆ ≠ 0 :=
by simp only [eval_dist_query_apply, one_div, ne.def, ennreal.inv_eq_zero,
  ennreal.nat_ne_top, not_false_iff]

lemma prob_event_query_eq_zero_iff (t : spec.domain i) (e : set (spec.range i)) :
  ⁅e | query i t⁆ = 0 ↔ e = ∅ :=
by rw [prob_event_eq_zero_iff_disjoint_support, support_query, set.top_eq_univ, set.univ_disjoint]

lemma eval_dist_query_apply_eq_one_iff (t : spec.domain i) (u : spec.range i) :
  ⁅= u | query i t⁆ = 1 ↔ fintype.card (spec.range i) = 1 :=
begin
  simp only [eval_dist_query, pmf.uniform_of_fintype_apply, ← one_div],
  exact trans (ennreal.div_eq_one_iff (nat.cast_ne_zero.2 fintype.card_ne_zero) $
    ennreal.nat_ne_top _) (eq_comm.trans nat.cast_eq_one),
end

lemma prob_event_query_eq_one_iff (t : spec.domain i) (e : set (spec.range i)) :
  ⁅e | query i t⁆ = 1 ↔ e = set.univ :=
by simp only [set.univ_subset_iff, prob_event_eq_one_iff_support_subset,
  support_query, set.top_eq_univ]

lemma eval_dist_query_apply_pos (t : spec.domain i) (u : spec.range i) : 0 < ⁅= u | query i t⁆ :=
pos_iff_ne_zero.2 (eval_dist_query_apply_ne_zero i t u)

lemma prob_event_query_pos_iff (t : spec.domain i) (e : set (spec.range i)) :
  0 < ⁅e | query i t⁆ ↔ e ≠ ∅ :=
pos_iff_ne_zero.trans (by simp only [ne.def, prob_event_query_eq_zero_iff])

@[simp] lemma query_dist_equiv_query (t t' : spec.domain i) :
  query i t ≃ₚ query i t' := dist_equiv.def.2 rfl

lemma eval_dist_query_eq_eval_dist_query (t t' : spec.domain i) : ⁅query i t⁆ = ⁅query i t'⁆ := rfl

lemma eval_dist_query_apply_eq_eval_dist_query_apply_iff (t : spec.domain i) (t' : spec'.domain i')
  (u : spec.range i) (u' : spec'.range i') : ⁅= u | query i t⁆ = ⁅= u' | query i' t'⁆ ↔
    fintype.card (spec.range i) = fintype.card (spec'.range i') :=
by simp only [eval_dist_query_apply, one_div, inv_inj, nat.cast_inj]

-- lemma prob_event_query_eq_prob_event_query_iff (t : spec.domain i) (t' : spec'.domain i')
--   (e : set (spec.range i)) (e' : set (spec'.range i')) : ⁅e | query i t⁆ = ⁅e' | query i' t'⁆ ↔

end oracle_comp


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.monic
import Mathlib.ring_theory.euclidean_domain
import Mathlib.ring_theory.multiplicity
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Division of univariate polynomials

The main defs are `div_by_monic` and `mod_by_monic`.
The compatibility between these is given by `mod_by_monic_add_div`.
We also define `root_multiplicity`.
-/

namespace polynomial

/--
The coercion turning a `polynomial` into the function which reports the coefficient of a given
monomial `X^n`
-/
-- TODO we would like to completely remove this, but this requires fixing some proofs

def coeff_coe_to_fun {R : Type u} [semiring R] : has_coe_to_fun (polynomial R) :=
  finsupp.has_coe_to_fun

theorem apply_eq_coeff {R : Type u} {n : ℕ} [semiring R] {p : polynomial R} :
    coe_fn p n = coeff p n :=
  rfl

/-- `div_X p` return a polynomial `q` such that `q * X + C (p.coeff 0) = p`.
  It can be used in a semiring where the usual division algorithm is not possible -/
def div_X {R : Type u} [semiring R] (p : polynomial R) : polynomial R :=
  finsupp.mk
    (finset.mk
      (multiset.map (fun (n : ℕ) => n - 1)
        (finset.val (finset.filter (fun (_x : ℕ) => _x > 0) (finsupp.support p))))
      sorry)
    (fun (n : ℕ) => coeff p (n + 1)) sorry

theorem div_X_mul_X_add {R : Type u} [semiring R] (p : polynomial R) :
    div_X p * X + coe_fn C (coeff p 0) = p :=
  sorry

@[simp] theorem div_X_C {R : Type u} [semiring R] (a : R) : div_X (coe_fn C a) = 0 := sorry

theorem div_X_eq_zero_iff {R : Type u} [semiring R] {p : polynomial R} :
    div_X p = 0 ↔ p = coe_fn C (coeff p 0) :=
  sorry

theorem div_X_add {R : Type u} [semiring R] {p : polynomial R} {q : polynomial R} :
    div_X (p + q) = div_X p + div_X q :=
  sorry

theorem degree_div_X_lt {R : Type u} [semiring R] {p : polynomial R} (hp0 : p ≠ 0) :
    degree (div_X p) < degree p :=
  sorry

/-- An induction principle for polynomials, valued in Sort* instead of Prop. -/
def rec_on_horner {R : Type u} [semiring R] {M : polynomial R → Sort u_1} (p : polynomial R) :
    M 0 →
        ((p : polynomial R) → (a : R) → coeff p 0 = 0 → a ≠ 0 → M p → M (p + coe_fn C a)) →
          ((p : polynomial R) → p ≠ 0 → M p → M (p * X)) → M p :=
  sorry

theorem degree_pos_induction_on {R : Type u} [semiring R] {P : polynomial R → Prop}
    (p : polynomial R) (h0 : 0 < degree p) (hC : ∀ {a : R}, a ≠ 0 → P (coe_fn C a * X))
    (hX : ∀ {p : polynomial R}, 0 < degree p → P p → P (p * X))
    (hadd : ∀ {p : polynomial R} {a : R}, 0 < degree p → P p → P (p + coe_fn C a)) : P p :=
  sorry

theorem X_dvd_iff {α : Type u} [comm_semiring α] {f : polynomial α} : X ∣ f ↔ coeff f 0 = 0 := sorry

theorem multiplicity_finite_of_degree_pos_of_monic {R : Type u} [comm_semiring R] {p : polynomial R}
    {q : polynomial R} (hp : 0 < degree p) (hmp : monic p) (hq : q ≠ 0) : multiplicity.finite p q :=
  sorry

theorem div_wf_lemma {R : Type u} [ring R] {p : polynomial R} {q : polynomial R}
    (h : degree q ≤ degree p ∧ p ≠ 0) (hq : monic q) :
    degree (p - coe_fn C (leading_coeff p) * X ^ (nat_degree p - nat_degree q) * q) < degree p :=
  sorry

/-- See `div_by_monic`. -/
def div_mod_by_monic_aux {R : Type u} [ring R] (p : polynomial R) {q : polynomial R} :
    monic q → polynomial R × polynomial R :=
  sorry

/-- `div_by_monic` gives the quotient of `p` by a monic polynomial `q`. -/
def div_by_monic {R : Type u} [ring R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  dite (monic q) (fun (hq : monic q) => prod.fst (div_mod_by_monic_aux p hq))
    fun (hq : ¬monic q) => 0

/-- `mod_by_monic` gives the remainder of `p` by a monic polynomial `q`. -/
def mod_by_monic {R : Type u} [ring R] (p : polynomial R) (q : polynomial R) : polynomial R :=
  dite (monic q) (fun (hq : monic q) => prod.snd (div_mod_by_monic_aux p hq))
    fun (hq : ¬monic q) => p

infixl:70 " /ₘ " => Mathlib.polynomial.div_by_monic

infixl:70 " %ₘ " => Mathlib.polynomial.mod_by_monic

theorem degree_mod_by_monic_lt {R : Type u} [ring R] (p : polynomial R) {q : polynomial R}
    (hq : monic q) (hq0 : q ≠ 0) : degree (p %ₘ q) < degree q :=
  sorry

@[simp] theorem zero_mod_by_monic {R : Type u} [ring R] (p : polynomial R) : 0 %ₘ p = 0 := sorry

@[simp] theorem zero_div_by_monic {R : Type u} [ring R] (p : polynomial R) : 0 /ₘ p = 0 := sorry

@[simp] theorem mod_by_monic_zero {R : Type u} [ring R] (p : polynomial R) : p %ₘ 0 = p := sorry

@[simp] theorem div_by_monic_zero {R : Type u} [ring R] (p : polynomial R) : p /ₘ 0 = 0 := sorry

theorem div_by_monic_eq_of_not_monic {R : Type u} [ring R] {q : polynomial R} (p : polynomial R)
    (hq : ¬monic q) : p /ₘ q = 0 :=
  dif_neg hq

theorem mod_by_monic_eq_of_not_monic {R : Type u} [ring R] {q : polynomial R} (p : polynomial R)
    (hq : ¬monic q) : p %ₘ q = p :=
  dif_neg hq

theorem mod_by_monic_eq_self_iff {R : Type u} [ring R] {p : polynomial R} {q : polynomial R}
    (hq : monic q) (hq0 : q ≠ 0) : p %ₘ q = p ↔ degree p < degree q :=
  sorry

theorem degree_mod_by_monic_le {R : Type u} [ring R] (p : polynomial R) {q : polynomial R}
    (hq : monic q) : degree (p %ₘ q) ≤ degree q :=
  sorry

theorem mod_by_monic_eq_sub_mul_div {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R}
    (hq : monic q) : p %ₘ q = p - q * (p /ₘ q) :=
  sorry

theorem mod_by_monic_add_div {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R}
    (hq : monic q) : p %ₘ q + q * (p /ₘ q) = p :=
  iff.mp eq_sub_iff_add_eq (mod_by_monic_eq_sub_mul_div p hq)

theorem div_by_monic_eq_zero_iff {R : Type u} [comm_ring R] {p : polynomial R} {q : polynomial R}
    (hq : monic q) (hq0 : q ≠ 0) : p /ₘ q = 0 ↔ degree p < degree q :=
  sorry

theorem degree_add_div_by_monic {R : Type u} [comm_ring R] {p : polynomial R} {q : polynomial R}
    (hq : monic q) (h : degree q ≤ degree p) : degree q + degree (p /ₘ q) = degree p :=
  sorry

theorem degree_div_by_monic_le {R : Type u} [comm_ring R] (p : polynomial R) (q : polynomial R) :
    degree (p /ₘ q) ≤ degree p :=
  sorry

theorem degree_div_by_monic_lt {R : Type u} [comm_ring R] (p : polynomial R) {q : polynomial R}
    (hq : monic q) (hp0 : p ≠ 0) (h0q : 0 < degree q) : degree (p /ₘ q) < degree p :=
  sorry

theorem nat_degree_div_by_monic {R : Type u} [comm_ring R] (f : polynomial R) {g : polynomial R}
    (hg : monic g) : nat_degree (f /ₘ g) = nat_degree f - nat_degree g :=
  sorry

theorem div_mod_by_monic_unique {R : Type u} [comm_ring R] {f : polynomial R} {g : polynomial R}
    (q : polynomial R) (r : polynomial R) (hg : monic g) (h : r + g * q = f ∧ degree r < degree g) :
    f /ₘ g = q ∧ f %ₘ g = r :=
  sorry

theorem map_mod_div_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R}
    {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) :
    map f (p /ₘ q) = map f p /ₘ map f q ∧ map f (p %ₘ q) = map f p %ₘ map f q :=
  sorry

theorem map_div_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R}
    {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) :
    map f (p /ₘ q) = map f p /ₘ map f q :=
  and.left (map_mod_div_by_monic f hq)

theorem map_mod_by_monic {R : Type u} {S : Type v} [comm_ring R] {p : polynomial R}
    {q : polynomial R} [comm_ring S] (f : R →+* S) (hq : monic q) :
    map f (p %ₘ q) = map f p %ₘ map f q :=
  and.right (map_mod_div_by_monic f hq)

theorem dvd_iff_mod_by_monic_eq_zero {R : Type u} [comm_ring R] {p : polynomial R}
    {q : polynomial R} (hq : monic q) : p %ₘ q = 0 ↔ q ∣ p :=
  sorry

theorem map_dvd_map {R : Type u} {S : Type v} [comm_ring R] [comm_ring S] (f : R →+* S)
    (hf : function.injective ⇑f) {x : polynomial R} {y : polynomial R} (hx : monic x) :
    map f x ∣ map f y ↔ x ∣ y :=
  sorry

@[simp] theorem mod_by_monic_one {R : Type u} [comm_ring R] (p : polynomial R) : p %ₘ 1 = 0 := sorry

@[simp] theorem div_by_monic_one {R : Type u} [comm_ring R] (p : polynomial R) : p /ₘ 1 = p := sorry

@[simp] theorem mod_by_monic_X_sub_C_eq_C_eval {R : Type u} [comm_ring R] (p : polynomial R)
    (a : R) : p %ₘ (X - coe_fn C a) = coe_fn C (eval a p) :=
  sorry

theorem mul_div_by_monic_eq_iff_is_root {R : Type u} {a : R} [comm_ring R] {p : polynomial R} :
    (X - coe_fn C a) * (p /ₘ (X - coe_fn C a)) = p ↔ is_root p a :=
  sorry

theorem dvd_iff_is_root {R : Type u} {a : R} [comm_ring R] {p : polynomial R} :
    X - coe_fn C a ∣ p ↔ is_root p a :=
  sorry

theorem mod_by_monic_X {R : Type u} [comm_ring R] (p : polynomial R) :
    p %ₘ X = coe_fn C (eval 0 p) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (p %ₘ X = coe_fn C (eval 0 p)))
        (Eq.symm (mod_by_monic_X_sub_C_eq_C_eval p 0))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (p %ₘ X = p %ₘ (X - coe_fn C 0))) C_0))
      (eq.mpr (id (Eq._oldrec (Eq.refl (p %ₘ X = p %ₘ (X - 0))) (sub_zero X))) (Eq.refl (p %ₘ X))))

theorem eval₂_mod_by_monic_eq_self_of_root {R : Type u} {S : Type v} [comm_ring R] [comm_ring S]
    {f : R →+* S} {p : polynomial R} {q : polynomial R} (hq : monic q) {x : S}
    (hx : eval₂ f x q = 0) : eval₂ f x (p %ₘ q) = eval₂ f x p :=
  sorry

/-- An algorithm for deciding polynomial divisibility.
The algorithm is "compute `p %ₘ q` and compare to `0`". `
See `polynomial.mod_by_monic` for the algorithm that computes `%ₘ`.
 -/
def decidable_dvd_monic {R : Type u} [comm_ring R] {q : polynomial R} (p : polynomial R)
    (hq : monic q) : Decidable (q ∣ p) :=
  decidable_of_iff (p %ₘ q = 0) (dvd_iff_mod_by_monic_eq_zero hq)

theorem multiplicity_X_sub_C_finite {R : Type u} [comm_ring R] {p : polynomial R} (a : R)
    (h0 : p ≠ 0) : multiplicity.finite (X - coe_fn C a) p :=
  sorry

/-- The largest power of `X - C a` which divides `p`.
This is computable via the divisibility algorithm `decidable_dvd_monic`. -/
def root_multiplicity {R : Type u} [comm_ring R] (a : R) (p : polynomial R) : ℕ :=
  dite (p = 0) (fun (h0 : p = 0) => 0)
    fun (h0 : ¬p = 0) =>
      let I : decidable_pred fun (n : ℕ) => ¬(X - coe_fn C a) ^ (n + 1) ∣ p :=
        fun (n : ℕ) => not.decidable;
      nat.find (multiplicity_X_sub_C_finite a h0)

theorem root_multiplicity_eq_multiplicity {R : Type u} [comm_ring R] (p : polynomial R) (a : R) :
    root_multiplicity a p =
        dite (p = 0) (fun (h0 : p = 0) => 0)
          fun (h0 : ¬p = 0) =>
            roption.get (multiplicity (X - coe_fn C a) p) (multiplicity_X_sub_C_finite a h0) :=
  sorry

theorem pow_root_multiplicity_dvd {R : Type u} [comm_ring R] (p : polynomial R) (a : R) :
    (X - coe_fn C a) ^ root_multiplicity a p ∣ p :=
  sorry

theorem div_by_monic_mul_pow_root_multiplicity_eq {R : Type u} [comm_ring R] (p : polynomial R)
    (a : R) :
    p /ₘ (X - coe_fn C a) ^ root_multiplicity a p * (X - coe_fn C a) ^ root_multiplicity a p = p :=
  sorry

theorem eval_div_by_monic_pow_root_multiplicity_ne_zero {R : Type u} [comm_ring R]
    {p : polynomial R} (a : R) (hp : p ≠ 0) :
    eval a (p /ₘ (X - coe_fn C a) ^ root_multiplicity a p) ≠ 0 :=
  sorry

end Mathlib


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

! This file was ported from Lean 3 source module algebraic_topology.extra_degeneracy
! leanprover-community/mathlib commit 324a7502510e835cdbd3de1519b6c66b51fb2467
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicTopology.AlternatingFaceMapComplex
import Mathbin.AlgebraicTopology.SimplicialSet
import Mathbin.AlgebraicTopology.CechNerve
import Mathbin.Algebra.Homology.Homotopy
import Mathbin.Tactic.FinCases

/-!

# Augmented simplicial objects with an extra degeneracy

In simplicial homotopy theory, in order to prove that the connected components
of a simplicial set `X` are contractible, it suffices to construct an extra
degeneracy as it is defined in *Simplicial Homotopy Theory* by Goerss-Jardine p. 190.
It consists of a series of maps `π₀ X → X _[0]` and `X _[n] → X _[n+1]` which
behave formally like an extra degeneracy `σ (-1)`. It can be thought as a datum
associated to the augmented simplicial set `X → π₀ X`.

In this file, we adapt this definition to the case of augmented
simplicial objects in any category.

## Main definitions

- the structure `extra_degeneracy X` for any `X : simplicial_object.augmented C`
- `extra_degeneracy.map`: extra degeneracies are preserved by the application of any
functor `C ⥤ D`
- `sSet.augmented.standard_simplex.extra_degeneracy`: the standard `n`-simplex has
an extra degeneracy
- `arrow.augmented_cech_nerve.extra_degeneracy`: the Čech nerve of a split
epimorphism has an extra degeneracy
- `extra_degeneracy.homotopy_equiv`: in the case the category `C` is preadditive,
if we have an extra degeneracy on `X : simplicial_object.augmented C`, then
the augmentation on the alternating face map complex of `X` is a homotopy
equivalence.

## References
* [Paul G. Goerss, John F. Jardine, *Simplical Homotopy Theory*][goerss-jardine-2009]

-/

open CategoryTheory CategoryTheory.Category

open CategoryTheory.SimplicialObject.Augmented

open Opposite

open Simplicial

namespace SimplicialObject

namespace Augmented

variable {C : Type _} [Category C]

/-- The datum of an extra degeneracy is a technical condition on
augmented simplicial objects. The morphisms `s'` and `s n` of the
structure formally behave like extra degeneracies `σ (-1)`. -/
@[ext]
structure ExtraDegeneracy (X : SimplicialObject.Augmented C) where
  s' : point.obj X ⟶ drop.obj X _[0]
  s : ∀ n : ℕ, drop.obj X _[n] ⟶ drop.obj X _[n + 1]
  s'_comp_ε' : s' ≫ X.Hom.app (op [0]) = 𝟙 _
  s₀_comp_δ₁' : s 0 ≫ (drop.obj X).δ 1 = X.Hom.app (op [0]) ≫ s'
  s_comp_δ₀' : ∀ n : ℕ, s n ≫ (drop.obj X).δ 0 = 𝟙 _
  s_comp_δ' :
    ∀ (n : ℕ) (i : Fin (n + 2)), s (n + 1) ≫ (drop.obj X).δ i.succ = (drop.obj X).δ i ≫ s n
  s_comp_σ' :
    ∀ (n : ℕ) (i : Fin (n + 1)), s n ≫ (drop.obj X).σ i.succ = (drop.obj X).σ i ≫ s (n + 1)
#align simplicial_object.augmented.extra_degeneracy SimplicialObject.Augmented.ExtraDegeneracy

namespace ExtraDegeneracy

restate_axiom s'_comp_ε'

restate_axiom s₀_comp_δ₁'

restate_axiom s_comp_δ₀'

restate_axiom s_comp_δ'

restate_axiom s_comp_σ'

attribute [reassoc.1] s'_comp_ε s₀_comp_δ₁ s_comp_δ₀ s_comp_δ s_comp_σ

attribute [simp] s'_comp_ε s_comp_δ₀

/-- If `ed` is an extra degeneracy for `X : simplicial_object.augmented C` and
`F : C ⥤ D` is a functor, then `ed.map F` is an extra degeneracy for the
augmented simplical object in `D` obtained by applying `F` to `X`. -/
def map {D : Type _} [Category D] {X : SimplicialObject.Augmented C} (ed : ExtraDegeneracy X)
    (F : C ⥤ D) : ExtraDegeneracy (((whiskering _ _).obj F).obj X)
    where
  s' := F.map ed.s'
  s n := F.map (ed.s n)
  s'_comp_ε' := by
    dsimp
    erw [comp_id, ← F.map_comp, ed.s'_comp_ε, F.map_id]
  s₀_comp_δ₁' := by
    dsimp
    erw [comp_id, ← F.map_comp, ← F.map_comp, ed.s₀_comp_δ₁]
  s_comp_δ₀' n := by
    dsimp
    erw [← F.map_comp, ed.s_comp_δ₀, F.map_id]
  s_comp_δ' n i := by
    dsimp
    erw [← F.map_comp, ← F.map_comp, ed.s_comp_δ]
    rfl
  s_comp_σ' n i := by
    dsimp
    erw [← F.map_comp, ← F.map_comp, ed.s_comp_σ]
    rfl
#align simplicial_object.augmented.extra_degeneracy.map SimplicialObject.Augmented.ExtraDegeneracy.map

/-- If `X` and `Y` are isomorphic augmented simplicial objects, then an extra
degeneracy for `X` gives also an extra degeneracy for `Y` -/
def ofIso {X Y : SimplicialObject.Augmented C} (e : X ≅ Y) (ed : ExtraDegeneracy X) :
    ExtraDegeneracy Y
    where
  s' := (point.mapIso e).inv ≫ ed.s' ≫ (drop.mapIso e).Hom.app (op [0])
  s n := (drop.mapIso e).inv.app (op [n]) ≫ ed.s n ≫ (drop.mapIso e).Hom.app (op [n + 1])
  s'_comp_ε' := by
    simpa only [functor.map_iso, assoc, w₀, ed.s'_comp_ε_assoc] using (point.map_iso e).inv_hom_id
  s₀_comp_δ₁' := by
    have h := w₀ e.inv
    dsimp at h⊢
    simp only [assoc, ← simplicial_object.δ_naturality, ed.s₀_comp_δ₁_assoc, reassoc_of h]
  s_comp_δ₀' n := by
    have h := ed.s_comp_δ₀'
    dsimp at h⊢
    simpa only [assoc, ← simplicial_object.δ_naturality, reassoc_of h] using
      congr_app (drop.map_iso e).inv_hom_id (op [n])
  s_comp_δ' n i := by
    have h := ed.s_comp_δ' n i
    dsimp at h⊢
    simp only [assoc, ← simplicial_object.δ_naturality, reassoc_of h, ←
      simplicial_object.δ_naturality_assoc]
  s_comp_σ' n i := by
    have h := ed.s_comp_σ' n i
    dsimp at h⊢
    simp only [assoc, ← simplicial_object.σ_naturality, reassoc_of h, ←
      simplicial_object.σ_naturality_assoc]
#align simplicial_object.augmented.extra_degeneracy.of_iso SimplicialObject.Augmented.ExtraDegeneracy.ofIso

end ExtraDegeneracy

end Augmented

end SimplicialObject

namespace SSet

namespace Augmented

namespace StandardSimplex

/-- When `[has_zero X]`, the shift of a map `f : fin n → X`
is a map `fin (n+1) → X` which sends `0` to `0` and `i.succ` to `f i`. -/
def shiftFun {n : ℕ} {X : Type _} [Zero X] (f : Fin n → X) (i : Fin (n + 1)) : X :=
  dite (i = 0) (fun h => 0) fun h => f (i.pred h)
#align sSet.augmented.standard_simplex.shift_fun SSet.Augmented.standardSimplex.shiftFun

@[simp]
theorem shiftFun_0 {n : ℕ} {X : Type _} [Zero X] (f : Fin n → X) : shiftFun f 0 = 0 :=
  rfl
#align sSet.augmented.standard_simplex.shift_fun_0 SSet.Augmented.standardSimplex.shiftFun_0

@[simp]
theorem shiftFun_succ {n : ℕ} {X : Type _} [Zero X] (f : Fin n → X) (i : Fin n) :
    shiftFun f i.succ = f i := by
  dsimp [shift_fun]
  split_ifs
  · exfalso
    simpa only [Fin.ext_iff, Fin.val_succ] using h
  · simp only [Fin.pred_succ]
#align sSet.augmented.standard_simplex.shift_fun_succ SSet.Augmented.standardSimplex.shiftFun_succ

/-- The shift of a morphism `f : [n] → Δ` in `simplex_category` corresponds to
the monotone map which sends `0` to `0` and `i.succ` to `f.to_order_hom i`. -/
@[simp]
def shift {n : ℕ} {Δ : SimplexCategory} (f : [n] ⟶ Δ) : [n + 1] ⟶ Δ :=
  SimplexCategory.Hom.mk
    { toFun := shiftFun f.toOrderHom
      monotone' := fun i₁ i₂ hi => by
        by_cases h₁ : i₁ = 0
        · subst h₁
          simp only [shift_fun_0, Fin.zero_le]
        · have h₂ : i₂ ≠ 0 := by
            intro h₂
            subst h₂
            exact h₁ (le_antisymm hi (Fin.zero_le _))
          cases' Fin.eq_succ_of_ne_zero h₁ with j₁ hj₁
          cases' Fin.eq_succ_of_ne_zero h₂ with j₂ hj₂
          substs hj₁ hj₂
          simpa only [shift_fun_succ] using f.to_order_hom.monotone (fin.succ_le_succ_iff.mp hi) }
#align sSet.augmented.standard_simplex.shift SSet.Augmented.standardSimplex.shift

/-- The obvious extra degeneracy on the standard simplex. -/
@[protected]
def extraDegeneracy (Δ : SimplexCategory) :
    SimplicialObject.Augmented.ExtraDegeneracy (standardSimplex.obj Δ)
    where
  s' x := SimplexCategory.Hom.mk (OrderHom.const _ 0)
  s n f := shift f
  s'_comp_ε' := by
    ext1 j
    fin_cases j
  s₀_comp_δ₁' := by
    ext (x j)
    fin_cases j
    rfl
  s_comp_δ₀' n := by
    ext (φ i) : 4
    dsimp [simplicial_object.δ, SimplexCategory.δ, SSet.standardSimplex]
    simp only [shift_fun_succ]
  s_comp_δ' n i := by
    ext (φ j) : 4
    dsimp [simplicial_object.δ, SimplexCategory.δ, SSet.standardSimplex]
    by_cases j = 0
    · subst h
      simp only [Fin.succ_succAbove_zero, shift_fun_0]
    · cases' Fin.eq_succ_of_ne_zero h with k hk
      subst hk
      simp only [Fin.succ_succAbove_succ, shift_fun_succ]
  s_comp_σ' n i := by
    ext (φ j) : 4
    dsimp [simplicial_object.σ, SimplexCategory.σ, SSet.standardSimplex]
    by_cases j = 0
    · subst h
      simpa only [shift_fun_0] using shift_fun_0 φ.to_order_hom
    · cases' Fin.eq_succ_of_ne_zero h with k hk
      subst hk
      simp only [Fin.succ_predAbove_succ, shift_fun_succ]
#align sSet.augmented.standard_simplex.extra_degeneracy SSet.Augmented.standardSimplex.extraDegeneracy

instance nonempty_extraDegeneracy_standardSimplex (Δ : SimplexCategory) :
    Nonempty (SimplicialObject.Augmented.ExtraDegeneracy (standardSimplex.obj Δ)) :=
  ⟨standardSimplex.extraDegeneracy Δ⟩
#align sSet.augmented.standard_simplex.nonempty_extra_degeneracy_standard_simplex SSet.Augmented.standardSimplex.nonempty_extraDegeneracy_standardSimplex

end StandardSimplex

end Augmented

end SSet

namespace CategoryTheory

open Limits

namespace Arrow

namespace AugmentedCechNerve

variable {C : Type _} [Category C] (f : Arrow C)
  [∀ n : ℕ, HasWidePullback f.right (fun i : Fin (n + 1) => f.left) fun i => f.Hom]
  (S : SplitEpi f.Hom)

include S

/-- The extra degeneracy map on the Čech nerve of a split epi. It is
given on the `0`-projection by the given section of the split epi,
and by shifting the indices on the other projections. -/
noncomputable def ExtraDegeneracy.s (n : ℕ) :
    f.cechNerve.obj (op [n]) ⟶ f.cechNerve.obj (op [n + 1]) :=
  WidePullback.lift (WidePullback.base _)
    (fun i =>
      dite (i = 0) (fun h => WidePullback.base _ ≫ S.section_) fun h => WidePullback.π _ (i.pred h))
    fun i => by
    split_ifs
    · subst h
      simp only [assoc, split_epi.id, comp_id]
    · simp only [wide_pullback.π_arrow]
#align category_theory.arrow.augmented_cech_nerve.extra_degeneracy.s CategoryTheory.Arrow.augmentedCechNerve.ExtraDegeneracy.s

@[simp]
theorem ExtraDegeneracy.s_comp_π_0 (n : ℕ) :
    ExtraDegeneracy.s f S n ≫ WidePullback.π _ 0 = WidePullback.base _ ≫ S.section_ :=
  by
  dsimp [extra_degeneracy.s]
  simpa only [wide_pullback.lift_π]
#align category_theory.arrow.augmented_cech_nerve.extra_degeneracy.s_comp_π_0 CategoryTheory.Arrow.augmentedCechNerve.ExtraDegeneracy.s_comp_π_0

@[simp]
theorem ExtraDegeneracy.s_comp_π_succ (n : ℕ) (i : Fin (n + 1)) :
    ExtraDegeneracy.s f S n ≫ WidePullback.π _ i.succ = WidePullback.π _ i :=
  by
  dsimp [extra_degeneracy.s]
  simp only [wide_pullback.lift_π]
  split_ifs
  · exfalso
    simpa only [Fin.ext_iff, Fin.val_succ, Fin.val_zero, Nat.succ_ne_zero] using h
  · congr
    apply Fin.pred_succ
#align category_theory.arrow.augmented_cech_nerve.extra_degeneracy.s_comp_π_succ CategoryTheory.Arrow.augmentedCechNerve.ExtraDegeneracy.s_comp_π_succ

@[simp]
theorem ExtraDegeneracy.s_comp_base (n : ℕ) :
    ExtraDegeneracy.s f S n ≫ WidePullback.base _ = WidePullback.base _ := by
  apply wide_pullback.lift_base
#align category_theory.arrow.augmented_cech_nerve.extra_degeneracy.s_comp_base CategoryTheory.Arrow.augmentedCechNerve.ExtraDegeneracy.s_comp_base

/-- The augmented Čech nerve associated to a split epimorphism has an extra degeneracy. -/
noncomputable def extraDegeneracy : SimplicialObject.Augmented.ExtraDegeneracy f.augmentedCechNerve
    where
  s' := S.section_ ≫ WidePullback.lift f.Hom (fun i => 𝟙 _) fun i => by rw [id_comp]
  s n := ExtraDegeneracy.s f S n
  s'_comp_ε' := by
    simp only [augmented_cech_nerve_hom_app, assoc, wide_pullback.lift_base, split_epi.id]
  s₀_comp_δ₁' := by
    dsimp [cech_nerve, simplicial_object.δ, SimplexCategory.δ]
    ext j
    · fin_cases j
      simpa only [assoc, wide_pullback.lift_π, comp_id] using extra_degeneracy.s_comp_π_0 f S 0
    ·
      simpa only [assoc, wide_pullback.lift_base, split_epi.id, comp_id] using
        extra_degeneracy.s_comp_base f S 0
  s_comp_δ₀' n := by
    dsimp [cech_nerve, simplicial_object.δ, SimplexCategory.δ]
    ext j
    · simpa only [assoc, wide_pullback.lift_π, id_comp] using extra_degeneracy.s_comp_π_succ f S n j
    · simpa only [assoc, wide_pullback.lift_base, id_comp] using extra_degeneracy.s_comp_base f S n
  s_comp_δ' n i := by
    dsimp [cech_nerve, simplicial_object.δ, SimplexCategory.δ]
    ext j
    · simp only [assoc, wide_pullback.lift_π]
      by_cases j = 0
      · subst h
        erw [Fin.succ_succAbove_zero, extra_degeneracy.s_comp_π_0, extra_degeneracy.s_comp_π_0]
        dsimp
        simp only [wide_pullback.lift_base_assoc]
      · cases' Fin.eq_succ_of_ne_zero h with k hk
        subst hk
        erw [Fin.succ_succAbove_succ, extra_degeneracy.s_comp_π_succ,
          extra_degeneracy.s_comp_π_succ]
        dsimp
        simp only [wide_pullback.lift_π]
    · simp only [assoc, wide_pullback.lift_base]
      erw [extra_degeneracy.s_comp_base, extra_degeneracy.s_comp_base]
      dsimp
      simp only [wide_pullback.lift_base]
  s_comp_σ' n i := by
    dsimp [cech_nerve, simplicial_object.σ, SimplexCategory.σ]
    ext j
    · simp only [assoc, wide_pullback.lift_π]
      by_cases j = 0
      · subst h
        erw [extra_degeneracy.s_comp_π_0, extra_degeneracy.s_comp_π_0]
        dsimp
        simp only [wide_pullback.lift_base_assoc]
      · cases' Fin.eq_succ_of_ne_zero h with k hk
        subst hk
        erw [Fin.succ_predAbove_succ, extra_degeneracy.s_comp_π_succ,
          extra_degeneracy.s_comp_π_succ]
        dsimp
        simp only [wide_pullback.lift_π]
    · simp only [assoc, wide_pullback.lift_base]
      erw [extra_degeneracy.s_comp_base, extra_degeneracy.s_comp_base]
      dsimp
      simp only [wide_pullback.lift_base]
#align category_theory.arrow.augmented_cech_nerve.extra_degeneracy CategoryTheory.Arrow.augmentedCechNerve.extraDegeneracy

end AugmentedCechNerve

end Arrow

end CategoryTheory

namespace SimplicialObject

namespace Augmented

namespace ExtraDegeneracy

open AlgebraicTopology CategoryTheory CategoryTheory.Limits

/-- If `C` is a preadditive category and `X` is an augmented simplicial object
in `C` that has an extra degeneracy, then the augmentation on the alternating
face map complex of `X` is an homotopy equivalence. -/
noncomputable def homotopyEquiv {C : Type _} [Category C] [Preadditive C] [HasZeroObject C]
    {X : SimplicialObject.Augmented C} (ed : ExtraDegeneracy X) :
    HomotopyEquiv (AlgebraicTopology.AlternatingFaceMapComplex.obj (drop.obj X))
      ((ChainComplex.single₀ C).obj (point.obj X))
    where
  Hom := alternatingFaceMapComplex.ε.app X
  inv := (ChainComplex.fromSingle₀Equiv _ _).invFun ed.s'
  homotopyInvHomId :=
    Homotopy.ofEq
      (by
        ext
        exact ed.s'_comp_ε)
  homotopyHomInvId :=
    { Hom := fun i j => by
        by_cases i + 1 = j
        · exact (-ed.s i) ≫ eq_to_hom (by congr )
        · exact 0
      zero' := fun i j hij => by
        split_ifs
        · exfalso
          exact hij h
        · simp only [eq_self_iff_true]
      comm := fun i => by
        cases i
        · rw [Homotopy.prevD_chainComplex, Homotopy.dNext_zero_chainComplex, zero_add]
          dsimp [ChainComplex.fromSingle₀Equiv, ChainComplex.toSingle₀Equiv]
          simp only [zero_add, eq_self_iff_true, preadditive.neg_comp, comp_id, if_true,
            alternating_face_map_complex.obj_d_eq, Fin.sum_univ_two, Fin.val_zero, pow_zero,
            one_zsmul, Fin.val_one, pow_one, neg_smul, preadditive.comp_add, ← s₀_comp_δ₁,
            s_comp_δ₀, preadditive.comp_neg, neg_add_rev, neg_neg, neg_add_cancel_right,
            neg_add_cancel_comm]
        · rw [Homotopy.prevD_chainComplex, Homotopy.dNext_succ_chainComplex]
          dsimp [ChainComplex.toSingle₀Equiv, ChainComplex.fromSingle₀Equiv]
          simp only [zero_comp, alternating_face_map_complex.obj_d_eq, eq_self_iff_true,
            preadditive.neg_comp, comp_id, if_true, preadditive.comp_neg,
            @Fin.sum_univ_succ _ _ (i + 2), preadditive.comp_add, Fin.val_zero, pow_zero, one_zsmul,
            s_comp_δ₀, Fin.val_succ, pow_add, pow_one, mul_neg, neg_zsmul, preadditive.comp_sum,
            preadditive.sum_comp, neg_neg, mul_one, preadditive.comp_zsmul, preadditive.zsmul_comp,
            s_comp_δ, zsmul_neg]
          rw [add_comm (-𝟙 _), add_assoc, add_assoc, add_left_neg, add_zero, Finset.sum_neg_distrib,
            add_left_neg] }
#align simplicial_object.augmented.extra_degeneracy.homotopy_equiv SimplicialObject.Augmented.ExtraDegeneracy.homotopyEquiv

end ExtraDegeneracy

end Augmented

end SimplicialObject


import tactic.tauto
local attribute [instance, priority 10] classical.prop_decidable

lemma contrapositive2 (P Q : Prop) : (¬ Q → ¬ P) → (P → Q) :=
begin
by_cases p : P; by_cases q : Q,
repeat {cc},
end


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

! This file was ported from Lean 3 source module group_theory.group_action.sum
! leanprover-community/mathlib commit f1a2caaf51ef593799107fe9a8d5e411599f3996
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.GroupAction.Defs

/-!
# Sum instances for additive and multiplicative actions

This file defines instances for additive and multiplicative actions on the binary `Sum` type.

## See also

* `GroupTheory.GroupAction.Option`
* `GroupTheory.GroupAction.Pi`
* `GroupTheory.GroupAction.Prod`
* `GroupTheory.GroupAction.Sigma`
-/

variable {M N P α β γ : Type _}

namespace Sum

section SMul

variable [SMul M α] [SMul M β] [SMul N α] [SMul N β] (a : M) (b : α) (c : β)
  (x : Sum α β)

@[to_additive Sum.hasVAdd]
instance : SMul M (Sum α β) :=
  ⟨fun a => Sum.map ((· • ·) a) ((· • ·) a)⟩

@[to_additive]
theorem smul_def : a • x = x.map ((· • ·) a) ((· • ·) a) :=
  rfl
#align sum.smul_def Sum.smul_def
#align sum.vadd_def Sum.vadd_def

@[to_additive (attr := simp)]
theorem smul_inl : a • (inl b : Sum α β) = inl (a • b) :=
  rfl
#align sum.smul_inl Sum.smul_inl
#align sum.vadd_inl Sum.vadd_inl

@[to_additive (attr := simp)]
theorem smul_inr : a • (inr c : Sum α β) = inr (a • c) :=
  rfl
#align sum.smul_inr Sum.smul_inr
#align sum.vadd_inr Sum.vadd_inr

@[to_additive (attr := simp)]
theorem smul_swap : (a • x).swap = a • x.swap := by cases x <;> rfl
#align sum.smul_swap Sum.smul_swap
#align sum.vadd_swap Sum.vadd_swap

instance [SMul M N] [IsScalarTower M N α] [IsScalarTower M N β] : IsScalarTower M N (Sum α β) :=
  ⟨fun a b x => by
    cases x
    exacts[congr_arg inl (smul_assoc _ _ _), congr_arg inr (smul_assoc _ _ _)]⟩

@[to_additive]
instance [SMulCommClass M N α] [SMulCommClass M N β] : SMulCommClass M N (Sum α β) :=
  ⟨fun a b x => by
    cases x
    exacts[congr_arg inl (smul_comm _ _ _), congr_arg inr (smul_comm _ _ _)]⟩

@[to_additive]
instance [SMul Mᵐᵒᵖ α] [SMul Mᵐᵒᵖ β] [IsCentralScalar M α] [IsCentralScalar M β] :
    IsCentralScalar M (Sum α β) :=
  ⟨fun a x => by
    cases x
    exacts[congr_arg inl (op_smul_eq_smul _ _), congr_arg inr (op_smul_eq_smul _ _)]⟩

@[to_additive]
instance FaithfulSMulLeft [FaithfulSMul M α] : FaithfulSMul M (Sum α β) :=
  ⟨fun h => eq_of_smul_eq_smul fun a : α => by injection h (inl a)⟩
#align sum.has_faithful_smul_left Sum.FaithfulSMulLeft
#align sum.has_faithful_vadd_left Sum.FaithfulVAddLeft

@[to_additive]
instance FaithfulSMulRight [FaithfulSMul M β] : FaithfulSMul M (Sum α β) :=
  ⟨fun h => eq_of_smul_eq_smul fun b : β => by injection h (inr b)⟩
#align sum.has_faithful_smul_right Sum.FaithfulSMulRight
#align sum.has_faithful_vadd_right Sum.FaithfulVAddRight

end SMul

@[to_additive]
instance {m : Monoid M} [MulAction M α] [MulAction M β] :
    MulAction M
      (Sum α
        β) where
  mul_smul a b x := by
    cases x
    exacts[congr_arg inl (mul_smul _ _ _), congr_arg inr (mul_smul _ _ _)]
  one_smul x := by
    cases x
    exacts[congr_arg inl (one_smul _ _), congr_arg inr (one_smul _ _)]

end Sum


/-
Copyright (c) 2021 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

import tactic.core
import tactic.push_neg

/-!
# by_contra'

`by_contra'` is a tactic for proving propositions by contradiction.
It is similar to `by_contra` except that it also uses `push_neg` to normalize negations.
-/

namespace tactic
namespace interactive
setup_tactic_parser

/--
If the target of the main goal is a proposition `p`,
`by_contra'` reduces the goal to proving `false` using the additional hypothesis `h : ¬ p`.
`by_contra' h` can be used to name the hypothesis `h : ¬ p`.
The hypothesis `¬ p` will be negation normalized using `push_neg`.
For instance, `¬ a < b` will be changed to `b ≤ a`.
`by_contra' h : q` will normalize negations in `¬ p`, normalize negations in `q`,
and then check that the two normalized forms are equal.
The resulting hypothesis is the pre-normalized form, `q`.

If the name `h` is not explicitly provided, then `this` will be used as name.

This tactic uses classical reasoning.
It is a variant on the tactic `by_contra` (`tactic.interactive.by_contra`).

Examples:

```lean
example : 1 < 2 :=
begin
  by_contra' h,
  -- h : 2 ≤ 1 ⊢ false
end

example : 1 < 2 :=
begin
  by_contra' h : ¬ 1 < 2,
  -- h : ¬ 1 < 2 ⊢ false
end
```
-/
meta def by_contra' (h : parse ident?) (t : parse (tk ":" *> texpr)?) : tactic unit := do
  let h := h.get_or_else `this,
  tgt ← target,
  mk_mapp `classical.by_contradiction [some tgt] >>= tactic.eapply,
  h₁ ← tactic.intro h,
  t' ← infer_type h₁,
  -- negation-normalize `t'` to the expression `e'` and get a proof `pr'` of `t' = e'`
  (e', pr') ← push_neg.normalize_negations t' <|> refl_conv t',
  match t with
  | none := () <$ replace_hyp h₁ e' pr'
  | some t := do
    t ← to_expr ``(%%t : Prop),
    -- negation-normalize `t` to the expression `e` and get a proof `pr` of `t = e`
    (e, pr) ← push_neg.normalize_negations t <|> refl_conv t,
    unify e e',
    () <$ (mk_eq_symm pr >>= mk_eq_trans pr' >>= replace_hyp h₁ t)
  end

add_tactic_doc
{ name       := "by_contra'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.by_contra'],
  tags       := ["logic"] }

end interactive
end tactic


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

! This file was ported from Lean 3 source module topology.continuous_function.cocompact_map
! leanprover-community/mathlib commit 0a0ec35061ed9960bf0e7ffb0335f44447b58977
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.ContinuousFunction.Basic

/-!
# Cocompact continuous maps

The type of *cocompact continuous maps* are those which tend to the cocompact filter on the
codomain along the cocompact filter on the domain. When the domain and codomain are Hausdorff, this
is equivalent to many other conditions, including that preimages of compact sets are compact. -/

universe u v w

open Filter Set

/-! ### Cocompact continuous maps -/

/-- A *cocompact continuous map* is a continuous function between topological spaces which
tends to the cocompact filter along the cocompact filter. Functions for which preimages of compact
sets are compact always satisfy this property, and the converse holds for cocompact continuous maps
when the codomain is Hausdorff (see `CocompactMap.tendsto_of_forall_preimage` and
`CocompactMap.isCompact_preimage`).

Cocompact maps thus generalise proper maps, with which they correspond when the codomain is
Hausdorff. -/
structure CocompactMap (α : Type u) (β : Type v) [TopologicalSpace α] [TopologicalSpace β] extends
  ContinuousMap α β : Type max u v where
  /-- The cocompact filter on `α` tends to the cocompact filter on `β` under the function -/
  cocompact_tendsto' : Tendsto toFun (cocompact α) (cocompact β)
#align cocompact_map CocompactMap

section

/-- `CocompactMapClass F α β` states that `F` is a type of cocompact continuous maps.

You should also extend this typeclass when you extend `CocompactMap`. -/
class CocompactMapClass (F : Type _) (α β : outParam <| Type _) [TopologicalSpace α]
  [TopologicalSpace β] extends ContinuousMapClass F α β where
  /-- The cocompact filter on `α` tends to the cocompact filter on `β` under the function -/
  cocompact_tendsto (f : F) : Tendsto f (cocompact α) (cocompact β)
#align cocompact_map_class CocompactMapClass

end

namespace CocompactMapClass

variable {F α β : Type _} [TopologicalSpace α] [TopologicalSpace β] [CocompactMapClass F α β]

instance : CoeTC F (CocompactMap α β) :=
  ⟨fun f => ⟨f, cocompact_tendsto f⟩⟩

end CocompactMapClass

export CocompactMapClass (cocompact_tendsto)

namespace CocompactMap

section Basics

variable {α β γ δ : Type _} [TopologicalSpace α] [TopologicalSpace β] [TopologicalSpace γ]
  [TopologicalSpace δ]

instance : CocompactMapClass (CocompactMap α β) α β where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨_, _⟩, _⟩ := f
    obtain ⟨⟨_, _⟩, _⟩ := g
    congr
  map_continuous f := f.continuous_toFun
  cocompact_tendsto f := f.cocompact_tendsto'

/- Porting note: not needed anymore
/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : CoeFun (CocompactMap α β) fun _ => α → β :=
  FunLike.hasCoeToFun-/

@[simp]
theorem coe_toContinuousMap {f : CocompactMap α β} : (f.toContinuousMap : α → β) = f :=
  rfl
#align cocompact_map.coe_to_continuous_fun CocompactMap.coe_toContinuousMap

@[ext]
theorem ext {f g : CocompactMap α β} (h : ∀ x, f x = g x) : f = g :=
  FunLike.ext _ _ h
#align cocompact_map.ext CocompactMap.ext

/-- Copy of a `CocompactMap` with a new `toFun` equal to the old one. Useful
to fix definitional equalities. -/
protected def copy (f : CocompactMap α β) (f' : α → β) (h : f' = f) : CocompactMap α β where
  toFun := f'
  continuous_toFun := by
    rw [h]
    exact f.continuous_toFun
  cocompact_tendsto' := by
    simp_rw [h]
    exact f.cocompact_tendsto'
#align cocompact_map.copy CocompactMap.copy

@[simp]
theorem coe_copy (f : CocompactMap α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align cocompact_map.coe_copy CocompactMap.coe_copy

@[simp]
theorem coe_mk (f : C(α, β)) (h : Tendsto f (cocompact α) (cocompact β)) :
    ⇑(⟨f, h⟩ : CocompactMap α β) = f :=
  rfl
#align cocompact_map.coe_mk CocompactMap.coe_mk

section

variable (α)

/-- The identity as a cocompact continuous map. -/
protected def id : CocompactMap α α :=
  ⟨ContinuousMap.id _, tendsto_id⟩
#align cocompact_map.id CocompactMap.id

@[simp]
theorem coe_id : ⇑(CocompactMap.id α) = id :=
  rfl
#align cocompact_map.coe_id CocompactMap.coe_id

end

instance : Inhabited (CocompactMap α α) :=
  ⟨CocompactMap.id α⟩

/-- The composition of cocompact continuous maps, as a cocompact continuous map. -/
def comp (f : CocompactMap β γ) (g : CocompactMap α β) : CocompactMap α γ :=
  ⟨f.toContinuousMap.comp g, (cocompact_tendsto f).comp (cocompact_tendsto g)⟩
#align cocompact_map.comp CocompactMap.comp

@[simp]
theorem coe_comp (f : CocompactMap β γ) (g : CocompactMap α β) : ⇑(comp f g) = f ∘ g :=
  rfl
#align cocompact_map.coe_comp CocompactMap.coe_comp

@[simp]
theorem comp_apply (f : CocompactMap β γ) (g : CocompactMap α β) (a : α) : comp f g a = f (g a) :=
  rfl
#align cocompact_map.comp_apply CocompactMap.comp_apply

@[simp]
theorem comp_assoc (f : CocompactMap γ δ) (g : CocompactMap β γ) (h : CocompactMap α β) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align cocompact_map.comp_assoc CocompactMap.comp_assoc

@[simp]
theorem id_comp (f : CocompactMap α β) : (CocompactMap.id _).comp f = f :=
  ext fun _ => rfl
#align cocompact_map.id_comp CocompactMap.id_comp

@[simp]
theorem comp_id (f : CocompactMap α β) : f.comp (CocompactMap.id _) = f :=
  ext fun _ => rfl
#align cocompact_map.comp_id CocompactMap.comp_id

theorem tendsto_of_forall_preimage {f : α → β} (h : ∀ s, IsCompact s → IsCompact (f ⁻¹' s)) :
    Tendsto f (cocompact α) (cocompact β) := fun s hs =>
  match mem_cocompact.mp hs with
  | ⟨t, ht, hts⟩ =>
    mem_map.mpr (mem_cocompact.mpr ⟨f ⁻¹' t, h t ht, by simpa using preimage_mono hts⟩)
#align cocompact_map.tendsto_of_forall_preimage CocompactMap.tendsto_of_forall_preimage

/-- If the codomain is Hausdorff, preimages of compact sets are compact under a cocompact
continuous map. -/
theorem isCompact_preimage [T2Space β] (f : CocompactMap α β) ⦃s : Set β⦄ (hs : IsCompact s) :
    IsCompact (f ⁻¹' s) := by
  obtain ⟨t, ht, hts⟩ :=
    mem_cocompact'.mp
      (by
        simpa only [preimage_image_preimage, preimage_compl] using
          mem_map.mp
            (cocompact_tendsto f <|
              mem_cocompact.mpr ⟨s, hs, compl_subset_compl.mpr (image_preimage_subset f _)⟩))
  exact
    isCompact_of_isClosed_subset ht (hs.isClosed.preimage <| map_continuous f) (by simpa using hts)
#align cocompact_map.is_compact_preimage CocompactMap.isCompact_preimage

end Basics

end CocompactMap

/-- A homemomorphism is a cocompact map. -/
@[simps]
def Homeomorph.toCocompactMap {α β : Type _} [TopologicalSpace α] [TopologicalSpace β]
    (f : α ≃ₜ β) : CocompactMap α β where
  toFun := f
  continuous_toFun := f.continuous
  cocompact_tendsto' :=
    by
    refine' CocompactMap.tendsto_of_forall_preimage fun K hK => _
    erw [K.preimage_equiv_eq_image_symm]
    exact hK.image f.symm.continuous
#align homeomorph.to_cocompact_map Homeomorph.toCocompactMap


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Defines the inf/sup (semi)-lattice with optionally top/bot type class hierarchy.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.rel_classes
import Mathlib.PostPort

universes u l u_1 v

namespace Mathlib

-- TODO: move this eventually, if we decide to use them

-- TODO: this seems crazy, but it also seems to work reasonably well

theorem le_antisymm' {α : Type u} [partial_order α] {a : α} {b : α} : a ≤ b → b ≤ a → a = b :=
  le_antisymm

/- TODO: automatic construction of dual definitions / theorems -/

/-- Typeclass for the `⊔` (`\lub`) notation -/
/-- Typeclass for the `⊓` (`\glb`) notation -/
class has_sup (α : Type u) where
  sup : α → α → α

class has_inf (α : Type u) where
  inf : α → α → α

infixl:65 " ⊔ " => Mathlib.has_sup.sup

infixl:70 " ⊓ " => Mathlib.has_inf.inf

/-- A `semilattice_sup` is a join-semilattice, that is, a partial order
  with a join (a.k.a. lub / least upper bound, sup / supremum) operation
  `⊔` which is the least element larger than both factors. -/
class semilattice_sup (α : Type u) extends has_sup α, partial_order α where
  le_sup_left : ∀ (a b : α), a ≤ a ⊔ b
  le_sup_right : ∀ (a b : α), b ≤ a ⊔ b
  sup_le : ∀ (a b c : α), a ≤ c → b ≤ c → a ⊔ b ≤ c

protected instance order_dual.has_sup (α : Type u_1) [has_inf α] : has_sup (order_dual α) :=
  has_sup.mk has_inf.inf

protected instance order_dual.has_inf (α : Type u_1) [has_sup α] : has_inf (order_dual α) :=
  has_inf.mk has_sup.sup

@[simp] theorem le_sup_left {α : Type u} [semilattice_sup α] {a : α} {b : α} : a ≤ a ⊔ b :=
  semilattice_sup.le_sup_left a b

theorem le_sup_left' {α : Type u} [semilattice_sup α] {a : α} {b : α} : a ≤ a ⊔ b := le_sup_left

@[simp] theorem le_sup_right {α : Type u} [semilattice_sup α] {a : α} {b : α} : b ≤ a ⊔ b :=
  semilattice_sup.le_sup_right a b

theorem le_sup_right' {α : Type u} [semilattice_sup α] {a : α} {b : α} : b ≤ a ⊔ b := le_sup_right

theorem le_sup_left_of_le {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} (h : c ≤ a) :
    c ≤ a ⊔ b :=
  le_trans h le_sup_left

theorem le_sup_right_of_le {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} (h : c ≤ b) :
    c ≤ a ⊔ b :=
  le_trans h le_sup_right

theorem sup_le {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} :
    a ≤ c → b ≤ c → a ⊔ b ≤ c :=
  semilattice_sup.sup_le a b c

@[simp] theorem sup_le_iff {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} :
    a ⊔ b ≤ c ↔ a ≤ c ∧ b ≤ c :=
  sorry

@[simp] theorem sup_eq_left {α : Type u} [semilattice_sup α] {a : α} {b : α} : a ⊔ b = a ↔ b ≤ a :=
  sorry

theorem sup_of_le_left {α : Type u} [semilattice_sup α] {a : α} {b : α} (h : b ≤ a) : a ⊔ b = a :=
  iff.mpr sup_eq_left h

@[simp] theorem left_eq_sup {α : Type u} [semilattice_sup α] {a : α} {b : α} : a = a ⊔ b ↔ b ≤ a :=
  iff.trans eq_comm sup_eq_left

@[simp] theorem sup_eq_right {α : Type u} [semilattice_sup α] {a : α} {b : α} : a ⊔ b = b ↔ a ≤ b :=
  sorry

theorem sup_of_le_right {α : Type u} [semilattice_sup α] {a : α} {b : α} (h : a ≤ b) : a ⊔ b = b :=
  iff.mpr sup_eq_right h

@[simp] theorem right_eq_sup {α : Type u} [semilattice_sup α] {a : α} {b : α} : b = a ⊔ b ↔ a ≤ b :=
  iff.trans eq_comm sup_eq_right

theorem sup_le_sup {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} {d : α} (h₁ : a ≤ b)
    (h₂ : c ≤ d) : a ⊔ c ≤ b ⊔ d :=
  sup_le (le_sup_left_of_le h₁) (le_sup_right_of_le h₂)

theorem sup_le_sup_left {α : Type u} [semilattice_sup α] {a : α} {b : α} (h₁ : a ≤ b) (c : α) :
    c ⊔ a ≤ c ⊔ b :=
  sup_le_sup (le_refl c) h₁

theorem sup_le_sup_right {α : Type u} [semilattice_sup α] {a : α} {b : α} (h₁ : a ≤ b) (c : α) :
    a ⊔ c ≤ b ⊔ c :=
  sup_le_sup h₁ (le_refl c)

theorem le_of_sup_eq {α : Type u} [semilattice_sup α] {a : α} {b : α} (h : a ⊔ b = b) : a ≤ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ≤ b)) (Eq.symm h)))
    (eq.mpr (id (propext (iff_true_intro le_sup_left))) trivial)

theorem sup_ind {α : Type u} [semilattice_sup α] [is_total α LessEq] (a : α) (b : α) {p : α → Prop}
    (ha : p a) (hb : p b) : p (a ⊔ b) :=
  or.elim (is_total.total a b)
    (fun (h : a ≤ b) => eq.mpr (id (Eq._oldrec (Eq.refl (p (a ⊔ b))) (iff.mpr sup_eq_right h))) hb)
    fun (h : b ≤ a) => eq.mpr (id (Eq._oldrec (Eq.refl (p (a ⊔ b))) (iff.mpr sup_eq_left h))) ha

@[simp] theorem sup_lt_iff {α : Type u} [semilattice_sup α] [is_total α LessEq] {a : α} {b : α}
    {c : α} : b ⊔ c < a ↔ b < a ∧ c < a :=
  { mp :=
      fun (h : b ⊔ c < a) =>
        { left := has_le.le.trans_lt le_sup_left h, right := has_le.le.trans_lt le_sup_right h },
    mpr := fun (h : b < a ∧ c < a) => sup_ind b c (and.left h) (and.right h) }

@[simp] theorem le_sup_iff {α : Type u} [semilattice_sup α] [is_total α LessEq] {a : α} {b : α}
    {c : α} : a ≤ b ⊔ c ↔ a ≤ b ∨ a ≤ c :=
  sorry

@[simp] theorem lt_sup_iff {α : Type u} [semilattice_sup α] [is_total α LessEq] {a : α} {b : α}
    {c : α} : a < b ⊔ c ↔ a < b ∨ a < c :=
  sorry

@[simp] theorem sup_idem {α : Type u} [semilattice_sup α] {a : α} : a ⊔ a = a :=
  le_antisymm (eq.mpr (id (Eq.trans (propext sup_le_iff) (propext (and_self (a ≤ a))))) (le_refl a))
    (eq.mpr (id (propext (iff_true_intro le_sup_right))) trivial)

protected instance sup_is_idempotent {α : Type u} [semilattice_sup α] :
    is_idempotent α has_sup.sup :=
  is_idempotent.mk sup_idem

theorem sup_comm {α : Type u} [semilattice_sup α] {a : α} {b : α} : a ⊔ b = b ⊔ a := sorry

protected instance sup_is_commutative {α : Type u} [semilattice_sup α] :
    is_commutative α has_sup.sup :=
  is_commutative.mk sup_comm

theorem sup_assoc {α : Type u} [semilattice_sup α] {a : α} {b : α} {c : α} :
    a ⊔ b ⊔ c = a ⊔ (b ⊔ c) :=
  le_antisymm
    (sup_le (sup_le le_sup_left (le_sup_right_of_le le_sup_left)) (le_sup_right_of_le le_sup_right))
    (sup_le (le_sup_left_of_le le_sup_left) (sup_le (le_sup_left_of_le le_sup_right) le_sup_right))

protected instance sup_is_associative {α : Type u} [semilattice_sup α] :
    is_associative α has_sup.sup :=
  is_associative.mk sup_assoc

@[simp] theorem sup_left_idem {α : Type u} [semilattice_sup α] {a : α} {b : α} :
    a ⊔ (a ⊔ b) = a ⊔ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ (a ⊔ b) = a ⊔ b)) (Eq.symm sup_assoc)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ a ⊔ b = a ⊔ b)) sup_idem)) (Eq.refl (a ⊔ b)))

@[simp] theorem sup_right_idem {α : Type u} [semilattice_sup α] {a : α} {b : α} :
    a ⊔ b ⊔ b = a ⊔ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ b ⊔ b = a ⊔ b)) sup_assoc))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ (b ⊔ b) = a ⊔ b)) sup_idem)) (Eq.refl (a ⊔ b)))

theorem sup_left_comm {α : Type u} [semilattice_sup α] (a : α) (b : α) (c : α) :
    a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c))) (Eq.symm sup_assoc)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ b ⊔ c = b ⊔ (a ⊔ c))) (Eq.symm sup_assoc)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a ⊔ b ⊔ c = b ⊔ a ⊔ c)) sup_comm)) (Eq.refl (b ⊔ a ⊔ c))))

theorem forall_le_or_exists_lt_sup {α : Type u} [semilattice_sup α] (a : α) :
    (∀ (b : α), b ≤ a) ∨ ∃ (b : α), a < b :=
  sorry

/-- If `f` is a monotonically increasing sequence, `g` is a monotonically decreasing
sequence, and `f n ≤ g n` for all `n`, then for all `m`, `n` we have `f m ≤ g n`. -/
theorem forall_le_of_monotone_of_mono_decr {α : Type u} [semilattice_sup α] {β : Type u_1}
    [preorder β] {f : α → β} {g : α → β} (hf : monotone f) (hg : ∀ {m n : α}, m ≤ n → g n ≤ g m)
    (h : ∀ (n : α), f n ≤ g n) (m : α) (n : α) : f m ≤ g n :=
  le_trans (le_trans (hf le_sup_left) (h (m ⊔ n))) (hg le_sup_right)

theorem semilattice_sup.ext_sup {α : Type u_1} {A : semilattice_sup α} {B : semilattice_sup α}
    (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) (x : α) (y : α) : x ⊔ y = x ⊔ y :=
  sorry

theorem semilattice_sup.ext {α : Type u_1} {A : semilattice_sup α} {B : semilattice_sup α}
    (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B :=
  sorry

/-- A `semilattice_inf` is a meet-semilattice, that is, a partial order
  with a meet (a.k.a. glb / greatest lower bound, inf / infimum) operation
  `⊓` which is the greatest element smaller than both factors. -/
class semilattice_inf (α : Type u) extends partial_order α, has_inf α where
  inf_le_left : ∀ (a b : α), a ⊓ b ≤ a
  inf_le_right : ∀ (a b : α), a ⊓ b ≤ b
  le_inf : ∀ (a b c : α), a ≤ b → a ≤ c → a ≤ b ⊓ c

protected instance order_dual.semilattice_sup (α : Type u_1) [semilattice_inf α] :
    semilattice_sup (order_dual α) :=
  semilattice_sup.mk has_sup.sup partial_order.le partial_order.lt sorry sorry sorry sorry sorry
    sorry

protected instance order_dual.semilattice_inf (α : Type u_1) [semilattice_sup α] :
    semilattice_inf (order_dual α) :=
  semilattice_inf.mk has_inf.inf partial_order.le partial_order.lt sorry sorry sorry le_sup_left
    le_sup_right sorry

@[simp] theorem inf_le_left {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b ≤ a :=
  semilattice_inf.inf_le_left a b

theorem inf_le_left' {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b ≤ a :=
  semilattice_inf.inf_le_left a b

@[simp] theorem inf_le_right {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b ≤ b :=
  semilattice_inf.inf_le_right a b

theorem inf_le_right' {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b ≤ b :=
  semilattice_inf.inf_le_right a b

theorem le_inf {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} :
    a ≤ b → a ≤ c → a ≤ b ⊓ c :=
  semilattice_inf.le_inf a b c

theorem inf_le_left_of_le {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} (h : a ≤ c) :
    a ⊓ b ≤ c :=
  le_trans inf_le_left h

theorem inf_le_right_of_le {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} (h : b ≤ c) :
    a ⊓ b ≤ c :=
  le_trans inf_le_right h

@[simp] theorem le_inf_iff {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} :
    a ≤ b ⊓ c ↔ a ≤ b ∧ a ≤ c :=
  sup_le_iff

@[simp] theorem inf_eq_left {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b = a ↔ a ≤ b :=
  sorry

theorem inf_of_le_left {α : Type u} [semilattice_inf α] {a : α} {b : α} (h : a ≤ b) : a ⊓ b = a :=
  iff.mpr inf_eq_left h

@[simp] theorem left_eq_inf {α : Type u} [semilattice_inf α] {a : α} {b : α} : a = a ⊓ b ↔ a ≤ b :=
  iff.trans eq_comm inf_eq_left

@[simp] theorem inf_eq_right {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b = b ↔ b ≤ a :=
  sorry

theorem inf_of_le_right {α : Type u} [semilattice_inf α] {a : α} {b : α} (h : b ≤ a) : a ⊓ b = b :=
  iff.mpr inf_eq_right h

@[simp] theorem right_eq_inf {α : Type u} [semilattice_inf α] {a : α} {b : α} : b = a ⊓ b ↔ b ≤ a :=
  iff.trans eq_comm inf_eq_right

theorem inf_le_inf {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} {d : α} (h₁ : a ≤ b)
    (h₂ : c ≤ d) : a ⊓ c ≤ b ⊓ d :=
  le_inf (inf_le_left_of_le h₁) (inf_le_right_of_le h₂)

theorem inf_le_inf_right {α : Type u} [semilattice_inf α] (a : α) {b : α} {c : α} (h : b ≤ c) :
    b ⊓ a ≤ c ⊓ a :=
  inf_le_inf h (le_refl a)

theorem inf_le_inf_left {α : Type u} [semilattice_inf α] (a : α) {b : α} {c : α} (h : b ≤ c) :
    a ⊓ b ≤ a ⊓ c :=
  inf_le_inf (le_refl a) h

theorem le_of_inf_eq {α : Type u} [semilattice_inf α] {a : α} {b : α} (h : a ⊓ b = a) : a ≤ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ≤ b)) (Eq.symm h)))
    (eq.mpr (id (propext (iff_true_intro inf_le_right))) trivial)

theorem inf_ind {α : Type u} [semilattice_inf α] [is_total α LessEq] (a : α) (b : α) {p : α → Prop}
    (ha : p a) (hb : p b) : p (a ⊓ b) :=
  sup_ind a b ha hb

@[simp] theorem lt_inf_iff {α : Type u} [semilattice_inf α] [is_total α LessEq] {a : α} {b : α}
    {c : α} : a < b ⊓ c ↔ a < b ∧ a < c :=
  sup_lt_iff

@[simp] theorem inf_le_iff {α : Type u} [semilattice_inf α] [is_total α LessEq] {a : α} {b : α}
    {c : α} : b ⊓ c ≤ a ↔ b ≤ a ∨ c ≤ a :=
  le_sup_iff

@[simp] theorem inf_idem {α : Type u} [semilattice_inf α] {a : α} : a ⊓ a = a := sup_idem

protected instance inf_is_idempotent {α : Type u} [semilattice_inf α] :
    is_idempotent α has_inf.inf :=
  is_idempotent.mk inf_idem

theorem inf_comm {α : Type u} [semilattice_inf α] {a : α} {b : α} : a ⊓ b = b ⊓ a := sup_comm

protected instance inf_is_commutative {α : Type u} [semilattice_inf α] :
    is_commutative α has_inf.inf :=
  is_commutative.mk inf_comm

theorem inf_assoc {α : Type u} [semilattice_inf α] {a : α} {b : α} {c : α} :
    a ⊓ b ⊓ c = a ⊓ (b ⊓ c) :=
  sup_assoc

protected instance inf_is_associative {α : Type u} [semilattice_inf α] :
    is_associative α has_inf.inf :=
  is_associative.mk inf_assoc

@[simp] theorem inf_left_idem {α : Type u} [semilattice_inf α] {a : α} {b : α} :
    a ⊓ (a ⊓ b) = a ⊓ b :=
  sup_left_idem

@[simp] theorem inf_right_idem {α : Type u} [semilattice_inf α] {a : α} {b : α} :
    a ⊓ b ⊓ b = a ⊓ b :=
  sup_right_idem

theorem inf_left_comm {α : Type u} [semilattice_inf α] (a : α) (b : α) (c : α) :
    a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) :=
  sup_left_comm a b c

theorem forall_le_or_exists_lt_inf {α : Type u} [semilattice_inf α] (a : α) :
    (∀ (b : α), a ≤ b) ∨ ∃ (b : α), b < a :=
  forall_le_or_exists_lt_sup a

theorem semilattice_inf.ext_inf {α : Type u_1} {A : semilattice_inf α} {B : semilattice_inf α}
    (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) (x : α) (y : α) : x ⊓ y = x ⊓ y :=
  sorry

theorem semilattice_inf.ext {α : Type u_1} {A : semilattice_inf α} {B : semilattice_inf α}
    (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B :=
  sorry

/-! ### Lattices -/

/-- A lattice is a join-semilattice which is also a meet-semilattice. -/
class lattice (α : Type u) extends semilattice_sup α, semilattice_inf α where

protected instance order_dual.lattice (α : Type u_1) [lattice α] : lattice (order_dual α) :=
  lattice.mk semilattice_sup.sup semilattice_sup.le semilattice_sup.lt sorry sorry sorry sorry sorry
    sorry semilattice_inf.inf sorry sorry sorry

/- Distributivity laws -/

/- TODO: better names? -/

theorem sup_inf_le {α : Type u} [lattice α] {a : α} {b : α} {c : α} :
    a ⊔ b ⊓ c ≤ (a ⊔ b) ⊓ (a ⊔ c) :=
  le_inf (sup_le_sup_left inf_le_left a) (sup_le_sup_left inf_le_right a)

theorem le_inf_sup {α : Type u} [lattice α] {a : α} {b : α} {c : α} : a ⊓ b ⊔ a ⊓ c ≤ a ⊓ (b ⊔ c) :=
  sup_le (inf_le_inf_left a le_sup_left) (inf_le_inf_left a le_sup_right)

theorem inf_sup_self {α : Type u} [lattice α] {a : α} {b : α} : a ⊓ (a ⊔ b) = a :=
  eq.mpr (id (Eq.trans (propext inf_eq_left) (propext (iff_true_intro le_sup_left)))) trivial

theorem sup_inf_self {α : Type u} [lattice α] {a : α} {b : α} : a ⊔ a ⊓ b = a :=
  eq.mpr (id (Eq.trans (propext sup_eq_left) (propext (iff_true_intro inf_le_left)))) trivial

theorem lattice.ext {α : Type u_1} {A : lattice α} {B : lattice α}
    (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B :=
  sorry

/-- A distributive lattice is a lattice that satisfies any of four
  equivalent distribution properties (of sup over inf or inf over sup,
  on the left or right). A classic example of a distributive lattice
  is the lattice of subsets of a set, and in fact this example is
  generic in the sense that every distributive lattice is realizable
  as a sublattice of a powerset lattice. -/
class distrib_lattice (α : Type u_1) extends lattice α where
  le_sup_inf : ∀ (x y z : α), (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z

theorem le_sup_inf {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α} :
    (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z :=
  distrib_lattice.le_sup_inf

theorem sup_inf_left {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α} :
    x ⊔ y ⊓ z = (x ⊔ y) ⊓ (x ⊔ z) :=
  le_antisymm sup_inf_le le_sup_inf

theorem sup_inf_right {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α} :
    y ⊓ z ⊔ x = (y ⊔ x) ⊓ (z ⊔ x) :=
  sorry

theorem inf_sup_left {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α} :
    x ⊓ (y ⊔ z) = x ⊓ y ⊔ x ⊓ z :=
  sorry

protected instance order_dual.distrib_lattice (α : Type u_1) [distrib_lattice α] :
    distrib_lattice (order_dual α) :=
  distrib_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry sorry

theorem inf_sup_right {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α} :
    (y ⊔ z) ⊓ x = y ⊓ x ⊔ z ⊓ x :=
  sorry

theorem le_of_inf_le_sup_le {α : Type u} [distrib_lattice α] {x : α} {y : α} {z : α}
    (h₁ : x ⊓ z ≤ y ⊓ z) (h₂ : x ⊔ z ≤ y ⊔ z) : x ≤ y :=
  sorry

theorem eq_of_inf_eq_sup_eq {α : Type u} [distrib_lattice α] {a : α} {b : α} {c : α}
    (h₁ : b ⊓ a = c ⊓ a) (h₂ : b ⊔ a = c ⊔ a) : b = c :=
  le_antisymm (le_of_inf_le_sup_le (le_of_eq h₁) (le_of_eq h₂))
    (le_of_inf_le_sup_le (le_of_eq (Eq.symm h₁)) (le_of_eq (Eq.symm h₂)))

/-!
### Lattices derived from linear orders
-/

protected instance lattice_of_linear_order {α : Type u} [o : linear_order α] : lattice α :=
  lattice.mk max linear_order.le linear_order.lt linear_order.le_refl linear_order.le_trans
    linear_order.le_antisymm le_max_left le_max_right sorry min min_le_left min_le_right sorry

theorem sup_eq_max {α : Type u} [linear_order α] {x : α} {y : α} : x ⊔ y = max x y := rfl

theorem inf_eq_min {α : Type u} [linear_order α] {x : α} {y : α} : x ⊓ y = min x y := rfl

protected instance distrib_lattice_of_linear_order {α : Type u} [o : linear_order α] :
    distrib_lattice α :=
  distrib_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry sorry

protected instance nat.distrib_lattice : distrib_lattice ℕ :=
  Mathlib.distrib_lattice_of_linear_order

namespace monotone

theorem le_map_sup {α : Type u} {β : Type v} [semilattice_sup α] [semilattice_sup β] {f : α → β}
    (h : monotone f) (x : α) (y : α) : f x ⊔ f y ≤ f (x ⊔ y) :=
  sup_le (h le_sup_left) (h le_sup_right)

theorem map_sup {α : Type u} {β : Type v} [semilattice_sup α] [is_total α LessEq]
    [semilattice_sup β] {f : α → β} (hf : monotone f) (x : α) (y : α) : f (x ⊔ y) = f x ⊔ f y :=
  sorry

theorem map_inf_le {α : Type u} {β : Type v} [semilattice_inf α] [semilattice_inf β] {f : α → β}
    (h : monotone f) (x : α) (y : α) : f (x ⊓ y) ≤ f x ⊓ f y :=
  le_inf (h inf_le_left) (h inf_le_right)

theorem map_inf {α : Type u} {β : Type v} [semilattice_inf α] [is_total α LessEq]
    [semilattice_inf β] {f : α → β} (hf : monotone f) (x : α) (y : α) : f (x ⊓ y) = f x ⊓ f y :=
  map_sup (monotone.order_dual hf) x y

end monotone

namespace prod

protected instance has_sup (α : Type u) (β : Type v) [has_sup α] [has_sup β] : has_sup (α × β) :=
  has_sup.mk fun (p q : α × β) => (fst p ⊔ fst q, snd p ⊔ snd q)

protected instance has_inf (α : Type u) (β : Type v) [has_inf α] [has_inf β] : has_inf (α × β) :=
  has_inf.mk fun (p q : α × β) => (fst p ⊓ fst q, snd p ⊓ snd q)

protected instance semilattice_sup (α : Type u) (β : Type v) [semilattice_sup α]
    [semilattice_sup β] : semilattice_sup (α × β) :=
  semilattice_sup.mk has_sup.sup partial_order.le partial_order.lt sorry sorry sorry sorry sorry
    sorry

protected instance semilattice_inf (α : Type u) (β : Type v) [semilattice_inf α]
    [semilattice_inf β] : semilattice_inf (α × β) :=
  semilattice_inf.mk has_inf.inf partial_order.le partial_order.lt sorry sorry sorry sorry sorry
    sorry

protected instance lattice (α : Type u) (β : Type v) [lattice α] [lattice β] : lattice (α × β) :=
  lattice.mk semilattice_sup.sup semilattice_inf.le semilattice_inf.lt sorry sorry sorry sorry sorry
    sorry semilattice_inf.inf sorry sorry sorry

protected instance distrib_lattice (α : Type u) (β : Type v) [distrib_lattice α]
    [distrib_lattice β] : distrib_lattice (α × β) :=
  distrib_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry sorry

end prod

namespace subtype

/-- A subtype forms a `⊔`-semilattice if `⊔` preserves the property. -/
protected def semilattice_sup {α : Type u} [semilattice_sup α] {P : α → Prop}
    (Psup : ∀ {x y : α}, P x → P y → P (x ⊔ y)) : semilattice_sup (Subtype fun (x : α) => P x) :=
  semilattice_sup.mk
    (fun (x y : Subtype fun (x : α) => P x) => { val := val x ⊔ val y, property := sorry })
    partial_order.le partial_order.lt sorry sorry sorry sorry sorry sorry

/-- A subtype forms a `⊓`-semilattice if `⊓` preserves the property. -/
protected def semilattice_inf {α : Type u} [semilattice_inf α] {P : α → Prop}
    (Pinf : ∀ {x y : α}, P x → P y → P (x ⊓ y)) : semilattice_inf (Subtype fun (x : α) => P x) :=
  semilattice_inf.mk
    (fun (x y : Subtype fun (x : α) => P x) => { val := val x ⊓ val y, property := sorry })
    partial_order.le partial_order.lt sorry sorry sorry sorry sorry sorry

/-- A subtype forms a lattice if `⊔` and `⊓` preserve the property. -/
protected def lattice {α : Type u} [lattice α] {P : α → Prop}
    (Psup : ∀ {x y : α}, P x → P y → P (x ⊔ y)) (Pinf : ∀ {x y : α}, P x → P y → P (x ⊓ y)) :
    lattice (Subtype fun (x : α) => P x) :=
  lattice.mk semilattice_sup.sup semilattice_inf.le semilattice_inf.lt sorry sorry sorry sorry sorry
    sorry semilattice_inf.inf sorry sorry sorry

end Mathlib


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.deriv
import analysis.analytic.basic
import analysis.calculus.cont_diff

/-!
# Frechet derivatives of analytic functions.

A function expressible as a power series at a point has a Frechet derivative there.
Also the special case in terms of `deriv` when the domain is 1-dimensional.
-/

open filter asymptotics
open_locale ennreal

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F]

section fderiv

variables {p : formal_multilinear_series 𝕜 E F} {r : ℝ≥0∞}
variables {f : E → F} {x : E} {s : set E}

lemma has_fpower_series_at.has_strict_fderiv_at (h : has_fpower_series_at f p x) :
  has_strict_fderiv_at f (continuous_multilinear_curry_fin1 𝕜 E F (p 1)) x :=
begin
  refine h.is_O_image_sub_norm_mul_norm_sub.trans_is_o (is_o.of_norm_right _),
  refine is_o_iff_exists_eq_mul.2 ⟨λ y, ∥y - (x, x)∥, _, eventually_eq.rfl⟩,
  refine (continuous_id.sub continuous_const).norm.tendsto' _ _ _,
  rw [_root_.id, sub_self, norm_zero]
end

lemma has_fpower_series_at.has_fderiv_at (h : has_fpower_series_at f p x) :
  has_fderiv_at f (continuous_multilinear_curry_fin1 𝕜 E F (p 1)) x :=
h.has_strict_fderiv_at.has_fderiv_at

lemma has_fpower_series_at.differentiable_at (h : has_fpower_series_at f p x) :
  differentiable_at 𝕜 f x :=
h.has_fderiv_at.differentiable_at

lemma analytic_at.differentiable_at : analytic_at 𝕜 f x → differentiable_at 𝕜 f x
| ⟨p, hp⟩ := hp.differentiable_at

lemma analytic_at.differentiable_within_at (h : analytic_at 𝕜 f x) :
  differentiable_within_at 𝕜 f s x :=
h.differentiable_at.differentiable_within_at

lemma has_fpower_series_at.fderiv_eq (h : has_fpower_series_at f p x) :
  fderiv 𝕜 f x = continuous_multilinear_curry_fin1 𝕜 E F (p 1) :=
h.has_fderiv_at.fderiv

lemma has_fpower_series_on_ball.differentiable_on [complete_space F]
  (h : has_fpower_series_on_ball f p x r) :
  differentiable_on 𝕜 f (emetric.ball x r) :=
λ y hy, (h.analytic_at_of_mem hy).differentiable_within_at

lemma analytic_on.differentiable_on (h : analytic_on 𝕜 f s) :
  differentiable_on 𝕜 f s :=
λ y hy, (h y hy).differentiable_within_at

lemma has_fpower_series_on_ball.has_fderiv_at [complete_space F]
  (h : has_fpower_series_on_ball f p x r) {y : E} (hy : (∥y∥₊ : ℝ≥0∞) < r) :
  has_fderiv_at f (continuous_multilinear_curry_fin1 𝕜 E F (p.change_origin y 1)) (x + y) :=
(h.change_origin hy).has_fpower_series_at.has_fderiv_at

lemma has_fpower_series_on_ball.fderiv_eq [complete_space F]
  (h : has_fpower_series_on_ball f p x r) {y : E} (hy : (∥y∥₊ : ℝ≥0∞) < r) :
  fderiv 𝕜 f (x + y) = continuous_multilinear_curry_fin1 𝕜 E F (p.change_origin y 1) :=
(h.has_fderiv_at hy).fderiv

/-- If a function has a power series on a ball, then so does its derivative. -/
lemma has_fpower_series_on_ball.fderiv [complete_space F]
  (h : has_fpower_series_on_ball f p x r) :
  has_fpower_series_on_ball (fderiv 𝕜 f)
    ((continuous_multilinear_curry_fin1 𝕜 E F : (E [×1]→L[𝕜] F) →L[𝕜] (E →L[𝕜] F))
      .comp_formal_multilinear_series (p.change_origin_series 1)) x r :=
begin
  suffices A : has_fpower_series_on_ball
    (λ z, continuous_multilinear_curry_fin1 𝕜 E F (p.change_origin (z - x) 1))
      ((continuous_multilinear_curry_fin1 𝕜 E F : (E [×1]→L[𝕜] F) →L[𝕜] (E →L[𝕜] F))
        .comp_formal_multilinear_series (p.change_origin_series 1)) x r,
  { apply A.congr,
    assume z hz,
    dsimp,
    rw [← h.fderiv_eq, add_sub_cancel'_right],
    simpa only [edist_eq_coe_nnnorm_sub, emetric.mem_ball] using hz},
  suffices B : has_fpower_series_on_ball (λ z, p.change_origin (z - x) 1)
    (p.change_origin_series 1) x r,
      from (continuous_multilinear_curry_fin1 𝕜 E F).to_continuous_linear_equiv
        .to_continuous_linear_map.comp_has_fpower_series_on_ball B,
  simpa using ((p.has_fpower_series_on_ball_change_origin 1 (h.r_pos.trans_le h.r_le)).mono
    h.r_pos h.r_le).comp_sub x,
end

/-- If a function is analytic on a set `s`, so is its Fréchet derivative. -/
lemma analytic_on.fderiv [complete_space F] (h : analytic_on 𝕜 f s) :
  analytic_on 𝕜 (fderiv 𝕜 f) s :=
begin
  assume y hy,
  rcases h y hy with ⟨p, r, hp⟩,
  exact hp.fderiv.analytic_at,
end

/-- If a function is analytic on a set `s`, so are its successive Fréchet derivative. -/
lemma analytic_on.iterated_fderiv [complete_space F] (h : analytic_on 𝕜 f s) (n : ℕ) :
  analytic_on 𝕜 (iterated_fderiv 𝕜 n f) s :=
begin
  induction n with n IH,
  { rw iterated_fderiv_zero_eq_comp,
    exact ((continuous_multilinear_curry_fin0 𝕜 E F).symm : F →L[𝕜] (E [×0]→L[𝕜] F))
      .comp_analytic_on h },
  { rw iterated_fderiv_succ_eq_comp_left,
    apply (continuous_multilinear_curry_left_equiv 𝕜 (λ (i : fin (n + 1)), E) F)
      .to_continuous_linear_equiv.to_continuous_linear_map.comp_analytic_on,
    exact IH.fderiv }
end

/-- An analytic function is infinitely differentiable. -/
lemma analytic_on.cont_diff_on [complete_space F] (h : analytic_on 𝕜 f s) {n : with_top ℕ} :
  cont_diff_on 𝕜 n f s :=
begin
  let t := {x | analytic_at 𝕜 f x},
  suffices : cont_diff_on 𝕜 n f t, from this.mono h,
  have H : analytic_on 𝕜 f t := λ x hx, hx,
  have t_open : is_open t := is_open_analytic_at 𝕜 f,
  apply cont_diff_on_of_continuous_on_differentiable_on,
  { assume m hm,
    apply (H.iterated_fderiv m).continuous_on.congr,
    assume x hx,
    exact iterated_fderiv_within_of_is_open _ t_open hx },
  { assume m hm,
    apply (H.iterated_fderiv m).differentiable_on.congr,
    assume x hx,
    exact iterated_fderiv_within_of_is_open _ t_open hx }
end

end fderiv

section deriv

variables {p : formal_multilinear_series 𝕜 𝕜 F} {r : ℝ≥0∞}
variables {f : 𝕜 → F} {x : 𝕜} {s : set 𝕜}

protected lemma has_fpower_series_at.has_strict_deriv_at (h : has_fpower_series_at f p x) :
  has_strict_deriv_at f (p 1 (λ _, 1)) x :=
h.has_strict_fderiv_at.has_strict_deriv_at

protected lemma has_fpower_series_at.has_deriv_at (h : has_fpower_series_at f p x) :
  has_deriv_at f (p 1 (λ _, 1)) x :=
h.has_strict_deriv_at.has_deriv_at

protected lemma has_fpower_series_at.deriv (h : has_fpower_series_at f p x) :
  deriv f x = p 1 (λ _, 1) :=
h.has_deriv_at.deriv

/-- If a function is analytic on a set `s`, so is its derivative. -/
lemma analytic_on.deriv [complete_space F] (h : analytic_on 𝕜 f s) :
  analytic_on 𝕜 (deriv f) s :=
(continuous_linear_map.apply 𝕜 F (1 : 𝕜)).comp_analytic_on h.fderiv

/-- If a function is analytic on a set `s`, so are its successive derivatives. -/
lemma analytic_on.iterated_deriv [complete_space F] (h : analytic_on 𝕜 f s) (n : ℕ) :
  analytic_on 𝕜 (deriv^[n] f) s :=
begin
  induction n with n IH,
  { exact h },
  { simpa only [function.iterate_succ', function.comp_app] using IH.deriv }
end

end deriv