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

! This file was ported from Lean 3 source module data.list.sigma
! leanprover-community/mathlib commit f808feb6c18afddb25e66a71d317643cf7fb5fbb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Range
import Mathlib.Data.List.Perm

/-!
# Utilities for lists of sigmas

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

universe u v

namespace List

variable {α : 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
#align list.keys List.keys

@[simp]
theorem keys_nil : @keys α β [] = [] :=
  rfl
#align list.keys_nil List.keys_nil

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

theorem mem_keys_of_mem {s : Sigma β} {l : List (Sigma β)} : s ∈ l → s.1 ∈ l.keys :=
  mem_map_of_mem Sigma.fst
#align list.mem_keys_of_mem List.mem_keys_of_mem

theorem exists_of_mem_keys {a} {l : List (Sigma β)} (h : a ∈ l.keys) :
    ∃ b : β a, Sigma.mk a b ∈ l :=
  let ⟨⟨_, b'⟩, m, e⟩ := exists_of_mem_map h
  Eq.recOn e (Exists.intro b' m)
#align list.exists_of_mem_keys List.exists_of_mem_keys

theorem mem_keys {a} {l : List (Sigma β)} : a ∈ l.keys ↔ ∃ b : β a, Sigma.mk a b ∈ l :=
  ⟨exists_of_mem_keys, fun ⟨_, h⟩ => mem_keys_of_mem h⟩
#align list.mem_keys List.mem_keys

theorem not_mem_keys {a} {l : List (Sigma β)} : a ∉ l.keys ↔ ∀ b : β a, Sigma.mk a b ∉ l :=
  (not_congr mem_keys).trans not_exists
#align list.not_mem_keys List.not_mem_keys

theorem not_eq_key {a} {l : List (Sigma β)} : a ∉ l.keys ↔ ∀ s : Sigma β, s ∈ l → a ≠ s.1 :=
  Iff.intro (fun h₁ s h₂ e => absurd (mem_keys_of_mem h₂) (by rwa [e] at h₁)) fun f h₁ =>
    let ⟨b, h₂⟩ := exists_of_mem_keys h₁
    f _ h₂ rfl
#align list.not_eq_key List.not_eq_key

/-! ### `NodupKeys` -/

/-- Determines whether the store uses a key several times. -/
def NodupKeys (l : List (Sigma β)) : Prop :=
  l.keys.Nodup
#align list.nodupkeys List.NodupKeys

theorem nodupKeys_iff_pairwise {l} : NodupKeys l ↔ Pairwise (fun s s' : Sigma β => s.1 ≠ s'.1) l :=
  pairwise_map
#align list.nodupkeys_iff_pairwise List.nodupKeys_iff_pairwise

theorem NodupKeys.pairwise_ne {l} (h : NodupKeys l) :
    Pairwise (fun s s' : Sigma β => s.1 ≠ s'.1) l :=
  nodupKeys_iff_pairwise.1 h
#align list.nodupkeys.pairwise_ne List.NodupKeys.pairwise_ne

@[simp]
theorem nodupKeys_nil : @NodupKeys α β [] :=
  Pairwise.nil
#align list.nodupkeys_nil List.nodupKeys_nil

@[simp]
theorem nodupKeys_cons {s : Sigma β} {l : List (Sigma β)} :
    NodupKeys (s :: l) ↔ s.1 ∉ l.keys ∧ NodupKeys l := by simp [keys, NodupKeys]
#align list.nodupkeys_cons List.nodupKeys_cons

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
#align list.not_mem_keys_of_nodupkeys_cons List.not_mem_keys_of_nodupKeys_cons

theorem nodupKeys_of_nodupKeys_cons {s : Sigma β} {l : List (Sigma β)} (h : NodupKeys (s :: l)) :
    NodupKeys l :=
  (nodupKeys_cons.1 h).2
#align list.nodupkeys_of_nodupkeys_cons List.nodupKeys_of_nodupKeys_cons

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 _ (fun s s' : Sigma β => s.1 = s'.1 → s = s') _
    (fun _ _ H h => (H h.symm).symm) (fun _ _ _ => rfl)
    ((nodupKeys_iff_pairwise.1 nd).imp fun h h' => (h h').elim) _ h _ h'
#align list.nodupkeys.eq_of_fst_eq List.NodupKeys.eq_of_fst_eq

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; rfl
#align list.nodupkeys.eq_of_mk_mem List.NodupKeys.eq_of_mk_mem

theorem nodupKeys_singleton (s : Sigma β) : NodupKeys [s] :=
  nodup_singleton _
#align list.nodupkeys_singleton List.nodupKeys_singleton

theorem NodupKeys.sublist {l₁ l₂ : List (Sigma β)} (h : l₁ <+ l₂) : NodupKeys l₂ → NodupKeys l₁ :=
  Nodup.sublist <| h.map _
#align list.nodupkeys.sublist List.NodupKeys.sublist

protected theorem NodupKeys.nodup {l : List (Sigma β)} : NodupKeys l → Nodup l :=
  Nodup.of_map _
#align list.nodupkeys.nodup List.NodupKeys.nodup

theorem perm_nodupKeys {l₁ l₂ : List (Sigma β)} (h : l₁ ~ l₂) : NodupKeys l₁ ↔ NodupKeys l₂ :=
  (h.map _).nodup_iff
#align list.perm_nodupkeys List.perm_nodupKeys

theorem nodupKeys_join {L : List (List (Sigma β))} :
    NodupKeys (join L) ↔ (∀ l ∈ L, NodupKeys l) ∧ Pairwise Disjoint (L.map keys) := by
  rw [nodupKeys_iff_pairwise, pairwise_join, pairwise_map]
  refine' and_congr (ball_congr fun l _ => by simp [nodupKeys_iff_pairwise]) _
  apply iff_of_eq; congr with (l₁ l₂)
  simp [keys, disjoint_iff_ne]
#align list.nodupkeys_join List.nodupKeys_join

theorem nodup_enum_map_fst (l : List α) : (l.enum.map Prod.fst).Nodup := by simp [List.nodup_range]
#align list.nodup_enum_map_fst List.nodup_enum_map_fst

theorem mem_ext {l₀ l₁ : List (Sigma β)} (nd₀ : l₀.Nodup) (nd₁ : l₁.Nodup)
    (h : ∀ x, x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
  (perm_ext nd₀ nd₁).2 h
#align list.mem_ext List.mem_ext

variable [DecidableEq α]

/-! ### `dlookup` -/

--Porting note: renaming to `dlookup` since `lookup` already exists
/-- `dlookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def dlookup (a : α) : List (Sigma β) → Option (β a)
  | [] => none
  | ⟨a', b⟩ :: l => if h : a' = a then some (Eq.recOn h b) else dlookup a l
#align list.lookup List.dlookup

@[simp]
theorem dlookup_nil (a : α) : dlookup a [] = @none (β a) :=
  rfl
#align list.lookup_nil List.dlookup_nil

@[simp]
theorem dlookup_cons_eq (l) (a : α) (b : β a) : dlookup a (⟨a, b⟩ :: l) = some b :=
  dif_pos rfl
#align list.lookup_cons_eq List.dlookup_cons_eq

@[simp]
theorem dlookup_cons_ne (l) {a} : ∀ s : Sigma β, a ≠ s.1 → dlookup a (s :: l) = dlookup a l
  | ⟨_, _⟩, h => dif_neg h.symm
#align list.lookup_cons_ne List.dlookup_cons_ne

theorem dlookup_eq_none {a : α} {l : List (Sigma β)} : dlookup a l = none ↔ a ∉ l.keys := by
  simp [← dlookup_isSome, Option.isNone_iff_eq_none]
#align list.lookup_eq_none List.dlookup_eq_none

theorem of_mem_dlookup {a : α} {b : β a} :
    ∀ {l : List (Sigma β)}, b ∈ dlookup a l → Sigma.mk a b ∈ l
  | ⟨a', b'⟩ :: l, H => by
    by_cases h : a = a'
    · subst a'
      simp at H
      simp [H]
    · simp only [ne_eq, h, not_false_iff, dlookup_cons_ne] at H
      simp [of_mem_dlookup H]
#align list.of_mem_lookup List.of_mem_dlookup

theorem mem_dlookup {a} {b : β a} {l : List (Sigma β)} (nd : l.NodupKeys) (h : Sigma.mk a b ∈ l) :
    b ∈ dlookup a l := by
  cases' Option.isSome_iff_exists.mp (dlookup_isSome.mpr (mem_keys_of_mem h)) with b' h'
  cases nd.eq_of_mk_mem h (of_mem_dlookup h')
  exact h'
#align list.mem_lookup List.mem_dlookup

theorem map_dlookup_eq_find (a : α) :
    ∀ l : List (Sigma β), (dlookup a l).map (Sigma.mk a) = find? (fun s => a = s.1) l
  | [] => rfl
  | ⟨a', b'⟩ :: l => by
    by_cases h : a = a'
    · subst a'
      simp
    · simp [h]
      exact map_dlookup_eq_find a l
#align list.map_lookup_eq_find List.map_dlookup_eq_find

theorem mem_dlookup_iff {a : α} {b : β a} {l : List (Sigma β)} (nd : l.NodupKeys) :
    b ∈ dlookup a l ↔ Sigma.mk a b ∈ l :=
  ⟨of_mem_dlookup, mem_dlookup nd⟩
#align list.mem_lookup_iff List.mem_dlookup_iff

theorem perm_dlookup (a : α) {l₁ l₂ : List (Sigma β)} (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys)
    (p : l₁ ~ l₂) : dlookup a l₁ = dlookup a l₂ := by
  ext b; simp only [mem_dlookup_iff nd₁, mem_dlookup_iff nd₂]; exact p.mem_iff
#align list.perm_lookup List.perm_dlookup

theorem lookup_ext {l₀ l₁ : List (Sigma β)} (nd₀ : l₀.NodupKeys) (nd₁ : l₁.NodupKeys)
    (h : ∀ x y, y ∈ l₀.dlookup x ↔ y ∈ l₁.dlookup x) : l₀ ~ l₁ :=
  mem_ext nd₀.nodup nd₁.nodup fun ⟨a, b⟩ => by
    rw [← mem_dlookup_iff, ← mem_dlookup_iff, h] <;> assumption
#align list.lookup_ext List.lookup_ext

/-! ### `lookup_all` -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookupAll (a : α) : List (Sigma β) → List (β a)
  | [] => []
  | ⟨a', b⟩ :: l => if h : a' = a then Eq.recOn h b :: lookupAll a l else lookupAll a l
#align list.lookup_all List.lookupAll

@[simp]
theorem lookupAll_nil (a : α) : lookupAll a [] = @nil (β a) :=
  rfl
#align list.lookup_all_nil List.lookupAll_nil

@[simp]
theorem lookupAll_cons_eq (l) (a : α) (b : β a) : lookupAll a (⟨a, b⟩ :: l) = b :: lookupAll a l :=
  dif_pos rfl
#align list.lookup_all_cons_eq List.lookupAll_cons_eq

@[simp]
theorem lookupAll_cons_ne (l) {a} : ∀ s : Sigma β, a ≠ s.1 → lookupAll a (s :: l) = lookupAll a l
  | ⟨_, _⟩, h => dif_neg h.symm
#align list.lookup_all_cons_ne List.lookupAll_cons_ne

theorem lookupAll_eq_nil {a : α} :
    ∀ {l : List (Sigma β)}, lookupAll a l = [] ↔ ∀ b : β a, Sigma.mk a b ∉ l
  | [] => by simp
  | ⟨a', b⟩ :: l => by
    by_cases h : a = a'
    · subst a'
      simp
    · simp [h, lookupAll_eq_nil]
#align list.lookup_all_eq_nil List.lookupAll_eq_nil

theorem head?_lookupAll (a : α) : ∀ l : List (Sigma β), head? (lookupAll a l) = dlookup a l
  | [] => by simp
  | ⟨a', b⟩ :: l => by
    by_cases h : a = a'
    . subst h; simp
    . rw [lookupAll_cons_ne, dlookup_cons_ne, head?_lookupAll a l] <;> assumption
#align list.head_lookup_all List.head?_lookupAll

theorem mem_lookupAll {a : α} {b : β a} :
    ∀ {l : List (Sigma β)}, b ∈ lookupAll a l ↔ Sigma.mk a b ∈ l
  | [] => by simp
  | ⟨a', b'⟩ :: l => by
    by_cases h : a = a'
    · subst h
      simp [*, mem_lookupAll]
    . simp [*, mem_lookupAll]
#align list.mem_lookup_all List.mem_lookupAll

theorem lookupAll_sublist (a : α) : ∀ l : List (Sigma β), (lookupAll a l).map (Sigma.mk a) <+ l
  | [] => by simp
  | ⟨a', b'⟩ :: l => by
    by_cases h : a = a'
    · subst h
      simp only [ne_eq, not_true, lookupAll_cons_eq, List.map]
      exact (lookupAll_sublist a l).cons₂ _
    · simp only [ne_eq, h, not_false_iff, lookupAll_cons_ne]
      exact (lookupAll_sublist a l).cons _
#align list.lookup_all_sublist List.lookupAll_sublist

theorem lookupAll_length_le_one (a : α) {l : List (Sigma β)} (h : l.NodupKeys) :
    length (lookupAll a l) ≤ 1 := by
  have := Nodup.sublist ((lookupAll_sublist a l).map _) h
  rw [map_map] at this
  rwa [← nodup_replicate, ← map_const]
#align list.lookup_all_length_le_one List.lookupAll_length_le_one

theorem lookupAll_eq_dlookup (a : α) {l : List (Sigma β)} (h : l.NodupKeys) :
    lookupAll a l = (dlookup a l).toList := by
  rw [← head?_lookupAll]
  have h1 := lookupAll_length_le_one a h; revert h1
  rcases lookupAll a l with (_ | ⟨b, _ | ⟨c, l⟩⟩) <;> intro h1 <;> try rfl
  exact absurd h1 (by simp)
#align list.lookup_all_eq_lookup List.lookupAll_eq_dlookup

theorem lookupAll_nodup (a : α) {l : List (Sigma β)} (h : l.NodupKeys) : (lookupAll a l).Nodup :=
  by (rw [lookupAll_eq_dlookup a h]; apply Option.toList_nodup)
#align list.lookup_all_nodup List.lookupAll_nodup

theorem perm_lookupAll (a : α) {l₁ l₂ : List (Sigma β)} (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys)
    (p : l₁ ~ l₂) : lookupAll a l₁ = lookupAll a l₂ := by
  simp [lookupAll_eq_dlookup, nd₁, nd₂, perm_dlookup a nd₁ nd₂ p]
#align list.perm_lookup_all List.perm_lookupAll

/-! ### `kreplace` -/

/-- Replaces the first value with key `a` by `b`. -/
def kreplace (a : α) (b : β a) : List (Sigma β) → List (Sigma β) :=
  lookmap fun s => if a = s.1 then some ⟨a, b⟩ else none
#align list.kreplace List.kreplace

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 _ <| by
    rintro ⟨a', b'⟩ h; dsimp; split_ifs
    · subst a'
      exact H _ h
    . rfl
#align list.kreplace_of_forall_not List.kreplace_of_forall_not

theorem kreplace_self {a : α} {b : β a} {l : List (Sigma β)} (nd : NodupKeys l)
    (h : Sigma.mk a b ∈ l) : kreplace a b l = l := by
  refine' (lookmap_congr _).trans (lookmap_id' (Option.guard fun (s : Sigma β) => a = s.1) _ _)
  · rintro ⟨a', b'⟩ h'
    dsimp [Option.guard]
    split_ifs
    · subst a'
      simp [nd.eq_of_mk_mem h h']
    · rfl
  · rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩
    dsimp [Option.guard]
    split_ifs
    · simp
    · rintro ⟨⟩
#align list.kreplace_self List.kreplace_self

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 with h <;> simp (config := { contextual := true }) [h]
#align list.keys_kreplace List.keys_kreplace

theorem kreplace_nodupKeys (a : α) (b : β a) {l : List (Sigma β)} :
    (kreplace a b l).NodupKeys ↔ l.NodupKeys := by simp [NodupKeys, keys_kreplace]
#align list.kreplace_nodupkeys List.kreplace_nodupKeys

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 _ <| by
    refine' nd.pairwise_ne.imp _
    intro x y h z h₁ w h₂
    split_ifs  at h₁ h₂ with h_2 h_1 <;> cases h₁ <;> cases h₂
    exact (h (h_2.symm.trans h_1)).elim
#align list.perm.kreplace List.Perm.kreplace

/-! ### `kerase` -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : List (Sigma β) → List (Sigma β) :=
  eraseP fun s => a = s.1
#align list.kerase List.kerase

--Porting note: removing @[simp], `simp` can prove it
theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
  rfl
#align list.kerase_nil List.kerase_nil

@[simp]
theorem kerase_cons_eq {a} {s : Sigma β} {l : List (Sigma β)} (h : a = s.1) :
    kerase a (s :: l) = l := by simp [kerase, h]
#align list.kerase_cons_eq List.kerase_cons_eq

@[simp]
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]
#align list.kerase_cons_ne List.kerase_cons_ne

@[simp]
theorem kerase_of_not_mem_keys {a} {l : List (Sigma β)} (h : a ∉ l.keys) : kerase a l = l := by
  induction' l with _ _ ih <;> [rfl,
    · simp [not_or] at h
      simp [h.1, ih h.2]]
#align list.kerase_of_not_mem_keys List.kerase_of_not_mem_keys

theorem kerase_sublist (a : α) (l : List (Sigma β)) : kerase a l <+ l :=
  eraseP_sublist _
#align list.kerase_sublist List.kerase_sublist

theorem kerase_keys_subset (a) (l : List (Sigma β)) : (kerase a l).keys ⊆ l.keys :=
  ((kerase_sublist a l).map _).subset
#align list.kerase_keys_subset List.kerase_keys_subset

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

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₂ := by
  induction l
  case nil => cases h
  case cons hd tl ih =>
    by_cases e : a = hd.1
    · subst e
      exact ⟨hd.2, [], tl, by simp, by cases hd; rfl, by simp⟩
    · simp at h
      cases' h with h h
      exact absurd h e
      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₂]; rfl), by
            simp [e, h₃]⟩
#align list.exists_of_kerase List.exists_of_kerase

@[simp]
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) fun 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
    else by simp [q, p]
#align list.mem_keys_kerase_of_ne List.mem_keys_kerase_of_ne

theorem keys_kerase {a} {l : List (Sigma β)} : (kerase a l).keys = l.keys.erase a := by
  rw [keys, kerase, erase_eq_eraseP, eraseP_map]; dsimp [Function.comp]
#align list.keys_kerase List.keys_kerase

theorem kerase_kerase {a a'} {l : List (Sigma β)} :
    (kerase a' l).kerase a = (kerase a l).kerase a' := by
  by_cases h : a = a'
  · subst a'; rfl
  induction' l with x xs; · rfl
  · 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, *]
#align list.kerase_kerase List.kerase_kerase

theorem NodupKeys.kerase (a : α) : NodupKeys l → (kerase a l).NodupKeys :=
  NodupKeys.sublist <| kerase_sublist _ _
#align list.nodupkeys.kerase List.NodupKeys.kerase

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
#align list.perm.kerase List.Perm.kerase

@[simp]
theorem not_mem_keys_kerase (a) {l : List (Sigma β)} (nd : l.NodupKeys) :
    a ∉ (kerase a l).keys := by
  induction l
  case nil => simp
  case cons hd tl ih =>
    simp at nd
    by_cases h : a = hd.1
    · subst h
      simp [nd.1]
    · simp [h, ih nd.2]
#align list.not_mem_keys_kerase List.not_mem_keys_kerase

@[simp]
theorem dlookup_kerase (a) {l : List (Sigma β)} (nd : l.NodupKeys) :
    dlookup a (kerase a l) = none :=
  dlookup_eq_none.mpr (not_mem_keys_kerase a nd)
#align list.lookup_kerase List.dlookup_kerase

@[simp]
theorem dlookup_kerase_ne {a a'} {l : List (Sigma β)} (h : a ≠ a') :
    dlookup a (kerase a' l) = dlookup a l := by
  induction l
  case nil => rfl
  case 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]
#align list.lookup_kerase_ne List.dlookup_kerase_ne

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₁ with h₁ h₁ <;>
    [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]
#align list.kerase_append_left List.kerase_append_left

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

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⟩, _ =>
          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)]
      else by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
    else by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]
#align list.kerase_comm List.kerase_comm

theorem sizeOf_kerase {α} {β : α → Type _} [DecidableEq α] [SizeOf (Sigma β)] (x : α)
    (xs : List (Sigma β)) : SizeOf.sizeOf (List.kerase x xs) ≤ SizeOf.sizeOf xs :=by
  simp only [SizeOf.sizeOf, _sizeOf_1]
  induction' xs with y ys
  · simp
  · by_cases x = y.1 <;> simp [*]
#align list.sizeof_kerase List.sizeOf_kerase

/-! ### `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
#align list.kinsert List.kinsert

@[simp]
theorem kinsert_def {a} {b : β a} {l : List (Sigma β)} : kinsert a b l = ⟨a, b⟩ :: kerase a l :=
  rfl
#align list.kinsert_def List.kinsert_def

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]
#align list.mem_keys_kinsert List.mem_keys_kinsert

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⟩
#align list.kinsert_nodupkeys List.kinsert_nodupKeys

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 _
#align list.perm.kinsert List.Perm.kinsert

theorem dlookup_kinsert {a} {b : β a} (l : List (Sigma β)) :
    dlookup a (kinsert a b l) = some b := by
  simp only [kinsert, dlookup_cons_eq]
#align list.lookup_kinsert List.dlookup_kinsert

theorem dlookup_kinsert_ne {a a'} {b' : β a'} {l : List (Sigma β)} (h : a ≠ a') :
    dlookup a (kinsert a' b' l) = dlookup a l := by simp [h]
#align list.lookup_kinsert_ne List.dlookup_kinsert_ne

/-! ### `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.recOn h s.2), l)
    else
      let (b', l') := kextract a l
      (b', s :: l')
#align list.kextract List.kextract

@[simp]
theorem kextract_eq_dlookup_kerase (a : α) :
    ∀ l : List (Sigma β), kextract a l = (dlookup a l, kerase a l)
  | [] => rfl
  | ⟨a', b⟩ :: l => by
    simp [kextract]; dsimp; split_ifs with h
    · subst a'
      simp [kerase]
    · simp [kextract, Ne.symm h, kextract_eq_dlookup_kerase a l, kerase]
#align list.kextract_eq_lookup_kerase List.kextract_eq_dlookup_kerase

/-! ### `dedupKeys` -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def dedupKeys : List (Sigma β) → List (Sigma β) :=
  List.foldr (fun x => kinsert x.1 x.2) []
#align list.dedupkeys List.dedupKeys

theorem dedupKeys_cons {x : Sigma β} (l : List (Sigma β)) :
    dedupKeys (x :: l) = kinsert x.1 x.2 (dedupKeys l) :=
  rfl
#align list.dedupkeys_cons List.dedupKeys_cons

theorem nodupKeys_dedupKeys (l : List (Sigma β)) : NodupKeys (dedupKeys l) := by
  dsimp [dedupKeys]
  generalize hl : nil = l'
  have : NodupKeys l' := by
    rw [← hl]
    apply nodup_nil
  clear hl
  induction' l with x xs l_ih
  · apply this
  · cases x
    simp [dedupKeys]
    constructor
    · simp [keys_kerase]
      apply l_ih.not_mem_erase
    · exact l_ih.kerase _
#align list.nodupkeys_dedupkeys List.nodupKeys_dedupKeys

theorem dlookup_dedupKeys (a : α) (l : List (Sigma β)) : dlookup a (dedupKeys l) = dlookup a l := by
  induction' l with l_hd _ l_ih; rfl
  cases' l_hd with a' b
  by_cases h : a = a'
  · subst a'
    rw [dedupKeys_cons, dlookup_kinsert, dlookup_cons_eq]
  · rw [dedupKeys_cons, dlookup_kinsert_ne h, l_ih, dlookup_cons_ne]
    exact h
#align list.lookup_dedupkeys List.dlookup_dedupKeys

theorem sizeOf_dedupKeys {α} {β : α → Type _} [DecidableEq α] [SizeOf (Sigma β)]
    (xs : List (Sigma β)) : SizeOf.sizeOf (dedupKeys xs) ≤ SizeOf.sizeOf xs := by
  simp only [SizeOf.sizeOf, _sizeOf_1]
  induction' xs with x xs
  · simp [dedupKeys]
  · simp only [dedupKeys_cons, kinsert_def, add_le_add_iff_left, Sigma.eta]
    trans
    apply sizeOf_kerase
    assumption
#align list.sizeof_dedupkeys List.sizeOf_dedupKeys

/-! ### `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₂)
#align list.kunion List.kunion

@[simp]
theorem nil_kunion {l : List (Sigma β)} : kunion [] l = l :=
  rfl
#align list.nil_kunion List.nil_kunion

@[simp]
theorem kunion_nil : ∀ {l : List (Sigma β)}, kunion l [] = l
  | [] => rfl
  | _ :: l => by rw [kunion, kerase_nil, kunion_nil]
#align list.kunion_nil List.kunion_nil

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

@[simp]
theorem mem_keys_kunion {a} {l₁ l₂ : List (Sigma β)} :
    a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys := by
  induction l₁ generalizing l₂
  case nil => simp
  case cons s l₁ ih => by_cases h : a = s.1 <;> [simp [h], simp [h, ih]]
#align list.mem_keys_kunion List.mem_keys_kunion

@[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]
#align list.kunion_kerase List.kunion_kerase

theorem NodupKeys.kunion (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) : (kunion l₁ l₂).NodupKeys := by
  induction l₁ generalizing l₂
  case nil => simp only [nil_kunion, nd₂]
  case cons s l₁ ih =>
    simp at nd₁
    simp [not_or, nd₁.1, nd₂, ih nd₁.2 (nd₂.kerase s.1)]
#align list.nodupkeys.kunion List.NodupKeys.kunion

theorem Perm.kunion_right {l₁ l₂ : List (Sigma β)} (p : l₁ ~ l₂) (l) :
    kunion l₁ l ~ kunion l₂ l := by
  induction p generalizing l
  case nil => rfl
  case cons hd tl₁ tl₂ _ ih =>
    simp [ih (List.kerase _ _), Perm.cons]
  case swap s₁ s₂ l => simp [kerase_comm, Perm.swap]
  case trans l₁ l₂ l₃ _ _ ih₁₂ ih₂₃ => exact Perm.trans (ih₁₂ l) (ih₂₃ l)
#align list.perm.kunion_right List.Perm.kunion_right

theorem Perm.kunion_left :
    ∀ (l) {l₁ l₂ : List (Sigma β)}, l₁.NodupKeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
  | [], _, _, _, p => p
  | s :: l, _, _, nd₁, p => ((p.kerase nd₁).kunion_left l <| nd₁.kerase s.1).cons s
#align list.perm.kunion_left List.Perm.kunion_left

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₃)
#align list.perm.kunion List.Perm.kunion

@[simp]
theorem dlookup_kunion_left {a} {l₁ l₂ : List (Sigma β)} (h : a ∈ l₁.keys) :
    dlookup a (kunion l₁ l₂) = dlookup a l₁ := by
  induction' l₁ with s _ ih generalizing l₂ <;> simp at h; cases' h with h h <;> cases' s with a'
  · subst h
    simp
  · rw [kunion_cons]
    by_cases h' : a = a'
    · subst h'
      simp
    · simp [h', ih h]
#align list.lookup_kunion_left List.dlookup_kunion_left

@[simp]
theorem dlookup_kunion_right {a} {l₁ l₂ : List (Sigma β)} (h : a ∉ l₁.keys) :
    dlookup a (kunion l₁ l₂) = dlookup a l₂ := by
  induction l₁ generalizing l₂
  case nil => simp
  case cons _ _ ih => simp [not_or] at h; simp [h.1, ih h.2]
#align list.lookup_kunion_right List.dlookup_kunion_right

--Porting note: removing simp, LHS not in normal form, added new version
theorem mem_dlookup_kunion {a} {b : β a} {l₁ l₂ : List (Sigma β)} :
    b ∈ dlookup a (kunion l₁ l₂) ↔ b ∈ dlookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ dlookup a l₂ := by
  induction l₁ generalizing l₂
  case nil => simp
  case 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₂]
#align list.mem_lookup_kunion List.mem_dlookup_kunion

--Porting note: New theorem, alternative version of `mem_dlookup_kunion` for simp
@[simp]
theorem dlookup_kunion_eq_some {a} {b : β a} {l₁ l₂ : List (Sigma β)} :
    dlookup a (kunion l₁ l₂) = some b ↔
      dlookup a l₁ = some b ∨ a ∉ l₁.keys ∧ dlookup a l₂ = some b :=
  mem_dlookup_kunion

theorem mem_dlookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : List (Sigma β)}
    (h₁ : b ∈ dlookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
    b ∈ dlookup a (kunion (kunion l₁ l₂) l₃) :=
  match mem_dlookup_kunion.mp h₁ with
  | Or.inl h => mem_dlookup_kunion.mpr (Or.inl (mem_dlookup_kunion.mpr (Or.inl h)))
  | Or.inr h => mem_dlookup_kunion.mpr <| Or.inr ⟨mt mem_keys_kunion.mp (not_or.mpr ⟨h.1, h₂⟩), h.2⟩
#align list.mem_lookup_kunion_middle List.mem_dlookup_kunion_middle

end List


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri

! This file was ported from Lean 3 source module topology.continuous_function.basic
! leanprover-community/mathlib commit 55d771df074d0dd020139ee1cd4b95521422df9f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.UnionLift
import Mathlib.Topology.Homeomorph

/-!
# Continuous bundled maps

In this file we define the type `ContinuousMap` of continuous bundled maps.

We use the `FunLike` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.
-/

open Function

/-- The type of continuous maps from `α` to `β`.

When possible, instead of parametrizing results over `(f : C(α, β))`,
you should parametrize over `{F : Type*} [ContinuousMapClass F α β] (f : F)`.

When you extend this structure, make sure to extend `ContinuousMapClass`. -/
--@[protect_proj] -- Porting note: missing attribute?
structure ContinuousMap (α β : Type _) [TopologicalSpace α] [TopologicalSpace β] where
  /-- The function `α → β` -/
  toFun : α → β
  /-- Proposition that `toFun` is continuous -/
  continuous_toFun : Continuous toFun := by continuity
#align continuous_map ContinuousMap

/-- The type of continuous maps from `α` to `β`. -/
notation "C(" α ", " β ")" => ContinuousMap α β

section

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

You should extend this class when you extend `ContinuousMap`. -/
class ContinuousMapClass (F : Type _) (α β : outParam <| Type _) [TopologicalSpace α]
  [TopologicalSpace β] extends FunLike F α fun _ => β where
  /-- Continuity -/
  map_continuous (f : F) : Continuous f
#align continuous_map_class ContinuousMapClass

end

export ContinuousMapClass (map_continuous)

attribute [continuity] map_continuous

section ContinuousMapClass

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

theorem map_continuousAt (f : F) (a : α) : ContinuousAt f a :=
  (map_continuous f).continuousAt
#align map_continuous_at map_continuousAt

theorem map_continuousWithinAt (f : F) (s : Set α) (a : α) : ContinuousWithinAt f s a :=
  (map_continuous f).continuousWithinAt
#align map_continuous_within_at map_continuousWithinAt

instance : CoeTC F C(α, β) :=
  ⟨fun f =>
    { toFun := f
      continuous_toFun := map_continuous f }⟩

end ContinuousMapClass

/-! ### Continuous maps-/

namespace ContinuousMap

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

instance : ContinuousMapClass C(α, β) α β where
  coe := ContinuousMap.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_continuous := ContinuousMap.continuous_toFun

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

@[simp]
theorem toFun_eq_coe {f : C(α, β)} : f.toFun = (f : α → β) :=
  rfl
#align continuous_map.to_fun_eq_coe ContinuousMap.toFun_eq_coe

/-- See note [custom simps projection]. -/
def Simps.apply (f : C(α, β)) : α → β := f

-- this must come after the coe_to_fun definition
initialize_simps_projections ContinuousMap (toFun → apply)

@[simp] -- Porting note: removed `norm_cast` attribute
protected theorem coe_coe {F : Type _} [ContinuousMapClass F α β] (f : F) : ⇑(f : C(α, β)) = f :=
  rfl
#align continuous_map.coe_coe ContinuousMap.coe_coe

@[ext]
theorem ext {f g : C(α, β)} (h : ∀ a, f a = g a) : f = g :=
  FunLike.ext _ _ h
#align continuous_map.ext ContinuousMap.ext

/-- Copy of a `ContinuousMap` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : C(α, β)) (f' : α → β) (h : f' = f) : C(α, β) where
  toFun := f'
  continuous_toFun := h.symm ▸ f.continuous_toFun
#align continuous_map.copy ContinuousMap.copy

@[simp]
theorem coe_copy (f : C(α, β)) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' :=
  rfl
#align continuous_map.coe_copy ContinuousMap.coe_copy

theorem copy_eq (f : C(α, β)) (f' : α → β) (h : f' = f) : f.copy f' h = f :=
  FunLike.ext' h
#align continuous_map.copy_eq ContinuousMap.copy_eq

variable {f g : C(α, β)}

/-- Deprecated. Use `map_continuous` instead. -/
protected theorem continuous (f : C(α, β)) : Continuous f :=
  f.continuous_toFun
#align continuous_map.continuous ContinuousMap.continuous

@[continuity]
theorem continuous_set_coe (s : Set C(α, β)) (f : s) : Continuous (f : α → β) :=
  f.1.continuous
#align continuous_map.continuous_set_coe ContinuousMap.continuous_set_coe

/-- Deprecated. Use `map_continuousAt` instead. -/
protected theorem continuousAt (f : C(α, β)) (x : α) : ContinuousAt f x :=
  f.continuous.continuousAt
#align continuous_map.continuous_at ContinuousMap.continuousAt

/-- Deprecated. Use `FunLike.congr_fun` instead. -/
protected theorem congr_fun {f g : C(α, β)} (H : f = g) (x : α) : f x = g x :=
  H ▸ rfl
#align continuous_map.congr_fun ContinuousMap.congr_fun

/-- Deprecated. Use `FunLike.congr_arg` instead. -/
protected theorem congr_arg (f : C(α, β)) {x y : α} (h : x = y) : f x = f y :=
  h ▸ rfl
#align continuous_map.congr_arg ContinuousMap.congr_arg

theorem coe_injective : @Function.Injective C(α, β) (α → β) (↑) := fun f g h => by
  cases f; cases g; congr
#align continuous_map.coe_injective ContinuousMap.coe_injective

@[simp]
theorem coe_mk (f : α → β) (h : Continuous f) : ⇑(⟨f, h⟩ : C(α, β)) = f :=
  rfl
#align continuous_map.coe_mk ContinuousMap.coe_mk

theorem map_specializes (f : C(α, β)) {x y : α} (h : x ⤳ y) : f x ⤳ f y :=
  h.map f.2
#align continuous_map.map_specializes ContinuousMap.map_specializes

section

variable (α β)

/--
The continuous functions from `α` to `β` are the same as the plain functions when `α` is discrete.
-/
@[simps]
def equivFnOfDiscrete [DiscreteTopology α] : C(α, β) ≃ (α → β) :=
  ⟨fun f => f,
    fun f => ⟨f, continuous_of_discreteTopology⟩,
    fun _ => by ext; rfl,
    fun _ => by ext; rfl⟩
#align continuous_map.equiv_fn_of_discrete ContinuousMap.equivFnOfDiscrete

end

variable (α)

/-- The identity as a continuous map. -/
protected def id : C(α, α) where
  toFun := id
#align continuous_map.id ContinuousMap.id

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

/-- The constant map as a continuous map. -/
def const (b : β) : C(α, β) where
  toFun := fun _ : α => b
#align continuous_map.const ContinuousMap.const

@[simp]
theorem coe_const (b : β) : ⇑(const α b) = Function.const α b :=
  rfl
#align continuous_map.coe_const ContinuousMap.coe_const

instance [Inhabited β] : Inhabited C(α, β) :=
  ⟨const α default⟩

variable {α}

@[simp]
theorem id_apply (a : α) : ContinuousMap.id α a = a :=
  rfl
#align continuous_map.id_apply ContinuousMap.id_apply

@[simp]
theorem const_apply (b : β) (a : α) : const α b a = b :=
  rfl
#align continuous_map.const_apply ContinuousMap.const_apply

/-- The composition of continuous maps, as a continuous map. -/
def comp (f : C(β, γ)) (g : C(α, β)) : C(α, γ) where
  toFun := f ∘ g
#align continuous_map.comp ContinuousMap.comp

@[simp]
theorem coe_comp (f : C(β, γ)) (g : C(α, β)) : ⇑(comp f g) = f ∘ g :=
  rfl
#align continuous_map.coe_comp ContinuousMap.coe_comp

@[simp]
theorem comp_apply (f : C(β, γ)) (g : C(α, β)) (a : α) : comp f g a = f (g a) :=
  rfl
#align continuous_map.comp_apply ContinuousMap.comp_apply

@[simp]
theorem comp_assoc (f : C(γ, δ)) (g : C(β, γ)) (h : C(α, β)) :
    (f.comp g).comp h = f.comp (g.comp h) :=
  rfl
#align continuous_map.comp_assoc ContinuousMap.comp_assoc

@[simp]
theorem id_comp (f : C(α, β)) : (ContinuousMap.id _).comp f = f :=
  ext fun _ => rfl
#align continuous_map.id_comp ContinuousMap.id_comp

@[simp]
theorem comp_id (f : C(α, β)) : f.comp (ContinuousMap.id _) = f :=
  ext fun _ => rfl
#align continuous_map.comp_id ContinuousMap.comp_id

@[simp]
theorem const_comp (c : γ) (f : C(α, β)) : (const β c).comp f = const α c :=
  ext fun _ => rfl
#align continuous_map.const_comp ContinuousMap.const_comp

@[simp]
theorem comp_const (f : C(β, γ)) (b : β) : f.comp (const α b) = const α (f b) :=
  ext fun _ => rfl
#align continuous_map.comp_const ContinuousMap.comp_const

theorem cancel_right {f₁ f₂ : C(β, γ)} {g : C(α, β)} (hg : Surjective g) :
    f₁.comp g = f₂.comp g ↔ f₁ = f₂ :=
  ⟨fun h => ext <| hg.forall.2 <| FunLike.ext_iff.1 h, congr_arg (ContinuousMap.comp · g)⟩
#align continuous_map.cancel_right ContinuousMap.cancel_right

theorem cancel_left {f : C(β, γ)} {g₁ g₂ : C(α, β)} (hf : Injective f) :
    f.comp g₁ = f.comp g₂ ↔ g₁ = g₂ :=
  ⟨fun h => ext fun a => hf <| by rw [← comp_apply, h, comp_apply], congr_arg _⟩
#align continuous_map.cancel_left ContinuousMap.cancel_left

instance [Nonempty α] [Nontrivial β] : Nontrivial C(α, β) :=
  ⟨let ⟨b₁, b₂, hb⟩ := exists_pair_ne β
  ⟨const _ b₁, const _ b₂, fun h => hb <| FunLike.congr_fun h <| Classical.arbitrary α⟩⟩

section Prod

variable {α₁ α₂ β₁ β₂ : Type _} [TopologicalSpace α₁] [TopologicalSpace α₂] [TopologicalSpace β₁]
  [TopologicalSpace β₂]

/-- Given two continuous maps `f` and `g`, this is the continuous map `x ↦ (f x, g x)`. -/
def prodMk (f : C(α, β₁)) (g : C(α, β₂)) : C(α, β₁ × β₂) where
  toFun x := (f x, g x)
#align continuous_map.prod_mk ContinuousMap.prodMk

/-- Given two continuous maps `f` and `g`, this is the continuous map `(x, y) ↦ (f x, g y)`. -/
@[simps]
def prodMap (f : C(α₁, α₂)) (g : C(β₁, β₂)) : C(α₁ × β₁, α₂ × β₂) where
  toFun := Prod.map f g
  continuous_toFun := f.continuous.prod_map g.continuous
  -- Porting note: proof was `continuity`
#align continuous_map.prod_map ContinuousMap.prodMap

@[simp]
theorem prod_eval (f : C(α, β₁)) (g : C(α, β₂)) (a : α) : (prodMk f g) a = (f a, g a) :=
  rfl
#align continuous_map.prod_eval ContinuousMap.prod_eval

end Prod

section Pi

variable {I A : Type _} {X : I → Type _} [TopologicalSpace A] [∀ i, TopologicalSpace (X i)]

/-- Abbreviation for product of continuous maps, which is continuous -/
def pi (f : ∀ i, C(A, X i)) : C(A, ∀ i, X i) where
  toFun (a : A) (i : I) := f i a
#align continuous_map.pi ContinuousMap.pi

@[simp]
theorem pi_eval (f : ∀ i, C(A, X i)) (a : A) : (pi f) a = fun i : I => (f i) a :=
  rfl
#align continuous_map.pi_eval ContinuousMap.pi_eval

end Pi

section Restrict

variable (s : Set α)

/-- The restriction of a continuous function `α → β` to a subset `s` of `α`. -/
def restrict (f : C(α, β)) : C(s, β) where
  toFun := f ∘ ((↑) : s → α)
#align continuous_map.restrict ContinuousMap.restrict

@[simp]
theorem coe_restrict (f : C(α, β)) : ⇑(f.restrict s) = f ∘ ((↑) : s → α) :=
  rfl
#align continuous_map.coe_restrict ContinuousMap.coe_restrict

@[simp]
theorem restrict_apply (f : C(α, β)) (s : Set α) (x : s) : f.restrict s x = f x :=
  rfl
#align continuous_map.restrict_apply ContinuousMap.restrict_apply

@[simp]
theorem restrict_apply_mk (f : C(α, β)) (s : Set α) (x : α) (hx : x ∈ s) :
    f.restrict s ⟨x, hx⟩ = f x :=
  rfl
#align continuous_map.restrict_apply_mk ContinuousMap.restrict_apply_mk

/-- The restriction of a continuous map to the preimage of a set. -/
@[simps]
def restrictPreimage (f : C(α, β)) (s : Set β) : C(f ⁻¹' s, s) :=
  ⟨s.restrictPreimage f, continuous_iff_continuousAt.mpr fun _ => f.2.continuousAt.restrictPreimage⟩
#align continuous_map.restrict_preimage ContinuousMap.restrictPreimage

end Restrict

section Gluing

variable {ι : Type _} (S : ι → Set α) (φ : ∀ i : ι, C(S i, β))
  (hφ : ∀ (i j) (x : α) (hxi : x ∈ S i) (hxj : x ∈ S j), φ i ⟨x, hxi⟩ = φ j ⟨x, hxj⟩)
  (hS : ∀ x : α, ∃ i, S i ∈ nhds x)

/-- A family `φ i` of continuous maps `C(S i, β)`, where the domains `S i` contain a neighbourhood
of each point in `α` and the functions `φ i` agree pairwise on intersections, can be glued to
construct a continuous map in `C(α, β)`. -/
noncomputable def liftCover : C(α, β) :=
  haveI H : (⋃ i, S i) = Set.univ :=
    Set.unionᵢ_eq_univ_iff.2 fun x ↦ (hS x).imp fun _  ↦ mem_of_mem_nhds
  mk (Set.liftCover S (fun i ↦ φ i) hφ H) <| continuous_of_cover_nhds hS fun i ↦ by
    rw [continuousOn_iff_continuous_restrict]
    simpa only [Set.restrict, Set.liftCover_coe] using (φ i).continuous
#align continuous_map.lift_cover ContinuousMap.liftCover

variable {S φ hφ hS}

@[simp]
theorem liftCover_coe {i : ι} (x : S i) : liftCover S φ hφ hS x = φ i x := by
  rw [liftCover, coe_mk, Set.liftCover_coe _]
#align continuous_map.lift_cover_coe ContinuousMap.liftCover_coe

-- @[simp] -- Porting note: the simpNF linter complained
theorem liftCover_restrict {i : ι} : (liftCover S φ hφ hS).restrict (S i) = φ i := by
  ext
  simp only [coe_restrict, Function.comp_apply, liftCover_coe]
#align continuous_map.lift_cover_restrict ContinuousMap.liftCover_restrict

variable (A : Set (Set α)) (F : ∀ s ∈ A, C(s, β))
  (hF : ∀ (s) (hs : s ∈ A) (t) (ht : t ∈ A) (x : α) (hxi : x ∈ s) (hxj : x ∈ t),
    F s hs ⟨x, hxi⟩ = F t ht ⟨x, hxj⟩)
  (hA : ∀ x : α, ∃ i ∈ A, i ∈ nhds x)

/-- A family `F s` of continuous maps `C(s, β)`, where (1) the domains `s` are taken from a set `A`
of sets in `α` which contain a neighbourhood of each point in `α` and (2) the functions `F s` agree
pairwise on intersections, can be glued to construct a continuous map in `C(α, β)`. -/
noncomputable def liftCover' : C(α, β) := by
  let S : A → Set α := (↑)
  let F : ∀ i : A, C(i, β) := fun i => F i i.prop
  refine' liftCover S F (fun i j => hF i i.prop j j.prop) _
  intro x
  obtain ⟨s, hs, hsx⟩ := hA x
  exact ⟨⟨s, hs⟩, hsx⟩
#align continuous_map.lift_cover' ContinuousMap.liftCover'

variable {A F hF hA}

-- porting note: did not need `by delta liftCover'; exact` in mathlib3; goal was
-- closed by `liftCover_coe x'`
-- Might be something to do with the `let`s in the definition of `liftCover'`?
@[simp]
theorem liftCover_coe' {s : Set α} {hs : s ∈ A} (x : s) : liftCover' A F hF hA x = F s hs x :=
  let x' : ((↑) : A → Set α) ⟨s, hs⟩ := x
  by delta liftCover'; exact liftCover_coe x'
#align continuous_map.lift_cover_coe' ContinuousMap.liftCover_coe'

-- porting note: porting program suggested `ext <| liftCover_coe'`
@[simp]
theorem liftCover_restrict' {s : Set α} {hs : s ∈ A} :
    (liftCover' A F hF hA).restrict s = F s hs := ext <| liftCover_coe' (hF := hF) (hA := hA)
#align continuous_map.lift_cover_restrict' ContinuousMap.liftCover_restrict'

end Gluing

end ContinuousMap

namespace Homeomorph

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

variable (f : α ≃ₜ β) (g : β ≃ₜ γ)

/-- The forward direction of a homeomorphism, as a bundled continuous map. -/
@[simps]
def toContinuousMap (e : α ≃ₜ β) : C(α, β) :=
  ⟨e, e.continuous_toFun⟩
#align homeomorph.to_continuous_map Homeomorph.toContinuousMap

/-- `Homeomorph.toContinuousMap` as a coercion. -/
instance : Coe (α ≃ₜ β) C(α, β) :=
  ⟨Homeomorph.toContinuousMap⟩

-- Porting note: Syntactic tautology
/-theorem toContinuousMap_as_coe : f.toContinuousMap = f :=
  rfl
#align homeomorph.to_continuous_map_as_coe Homeomorph.toContinuousMap_as_coe-/
#noalign homeomorph.to_continuous_map_as_coe

@[simp]
theorem coe_refl : (Homeomorph.refl α : C(α, α)) = ContinuousMap.id α :=
  rfl
#align homeomorph.coe_refl Homeomorph.coe_refl

@[simp]
theorem coe_trans : (f.trans g : C(α, γ)) = (g : C(β, γ)).comp f :=
  rfl
#align homeomorph.coe_trans Homeomorph.coe_trans

/-- Left inverse to a continuous map from a homeomorphism, mirroring `Equiv.symm_comp_self`. -/
@[simp]
theorem symm_comp_toContinuousMap : (f.symm : C(β, α)).comp (f : C(α, β)) = ContinuousMap.id α :=
  by rw [← coe_trans, self_trans_symm, coe_refl]
#align homeomorph.symm_comp_to_continuous_map Homeomorph.symm_comp_toContinuousMap

/-- Right inverse to a continuous map from a homeomorphism, mirroring `Equiv.self_comp_symm`. -/
@[simp]
theorem toContinuousMap_comp_symm : (f : C(α, β)).comp (f.symm : C(β, α)) = ContinuousMap.id β :=
  by rw [← coe_trans, symm_trans_self, coe_refl]
#align homeomorph.to_continuous_map_comp_symm Homeomorph.toContinuousMap_comp_symm

end Homeomorph


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import data.multiset.basic
import combinatorics.simplicial_complex.to_move.list

lemma multiset.exists_min_of_inf_closed {α : Type*} [semilattice_inf α] {s : multiset α}
  (hs₁ : s ≠ 0) (hs₂ : ∀ x y ∈ s, x ⊓ y ∈ s) :
  ∃ z ∈ s, ∀ y ∈ s, z ≤ y :=
begin
  revert hs₁ hs₂,
  apply quotient.induction_on s,
  intros s hs₁ hs₂,
  apply list.exists_min_of_inf_closed _ hs₂,
  intro t,
  rw ←multiset.coe_eq_zero at t,
  apply hs₁ t,
end


import data.zmod.quotient
import group_theory.subgroup.basic
import linear_algebra.general_linear_group

/-!
§1. Groups
§1.2 Subgroups and Lagrange's Theorem
-/

def l1_2_2_ba {G : Type*} [group G] (H : subgroup G) : group H := infer_instance

lemma l1_2_2_ba' {G : Type*} [group G] (H : subgroup G) :
  (∀ a b : H, ((a * b : H) : G) = (a * b : G)) ∧ (((1 : H) : G) = 1) :=
begin
  refine ⟨_, subgroup.coe_one _⟩,
  rintro ⟨a, ha⟩ ⟨b, hb⟩,
  rw [mul_mem_class.mk_mul_mk, subgroup.coe_mk, subgroup.coe_mk, subgroup.coe_mk, mul_left_inj],
end

def l1_2_2_ab {G : Type*} [group G] (H : set G) [group H]
  (hmul : ∀ a b : H, ((a * b : H) : G) = (a * b : G)) (h1 : ((1 : H) : G) = 1) :
  subgroup G := {
  carrier := H,
  mul_mem' := λ a b ha hb, by {
    convert subtype.mem (⟨a, ha⟩ * ⟨b, hb⟩),
    simp [hmul] },
  one_mem' := by {
    convert subtype.mem 1,
    exact h1.symm },
  inv_mem' := λ x hx, by {
    rw ←(subtype.coe_mk x hx),
    convert subtype.mem ⟨x, hx⟩⁻¹,
    rw [inv_eq_iff_mul_eq_one, ←hmul, mul_right_inv, h1] } }

lemma l1_2_2_bc {G : Type*} [group G] (H : subgroup G) :
  (H : set G).nonempty ∧ ∀ h₁ h₂, h₁ ∈ (H : set G) → h₂ ∈ (H : set G) → h₁ * h₂⁻¹ ∈ (H : set G) :=
begin
  refine ⟨⟨1, set_like.mem_coe.mpr (one_mem _)⟩, λ h₁ h₂ h₁mem h₂mem, _⟩,
  rw [set_like.mem_coe] at h₁mem h₂mem ⊢,
  exact subgroup.mul_mem _ h₁mem (subgroup.inv_mem _ h₂mem)
end

def l1_2_2_cb {G : Type*} [group G] (H : set G) (hne : H.nonempty)
  (hmem : ∀ {h₁ h₂}, h₁ ∈ H → h₂ ∈ H → h₁ * h₂⁻¹ ∈ H) :
  subgroup G :=
have h1 : (1 : G) ∈ H,
{ obtain ⟨x, hx⟩ := hne,
  have h1 := hmem hx hx,
  rwa mul_right_inv at h1 },
have hinv : ∀ {h}, h ∈ H → h⁻¹ ∈ H,
{ intros h hh,
  convert hmem h1 hh,
  rw one_mul },
{ carrier := H,
  mul_mem' := λ a b ha hb, by {
    convert hmem ha (hinv hb),
    rw inv_inv },
  one_mem' := h1,
  inv_mem' := λ x, hinv }

def ex_1_2_3_1 {G : Type*} [group G] : subgroup G :=
{ carrier := {1},
  mul_mem' := λ a b ha hb, by {
    rw set.mem_singleton_iff at ha hb ⊢,
    rw [ha, hb, one_mul] },
  one_mem' := set.mem_singleton _,
  inv_mem' := λ a ha, by {
    rw set.mem_singleton_iff at ha ⊢,
    rw [ha, inv_one] } }

def ex_1_2_3_2 (n : ℤ) : add_subgroup ℤ :=
add_subgroup.zmultiples n
lemma l1_2_3_2 (n : ℤ) : (ex_1_2_3_2 n : set ℤ) = { k : ℤ | n ∣ k } :=
begin
  ext,
  simp [ex_1_2_3_2, int.mem_zmultiples_iff],
end

def ex_1_2_3_3 (K : Type*) [field K] (n : ℕ) : subgroup (matrix.general_linear_group (fin n) K) :=
{ carrier := { A | matrix.det A = 1 },
  mul_mem' := λ a b ha hb, by {
    rw [set.mem_set_of, matrix.general_linear_group.coe_fn_eq_coe] at ha hb ⊢,
    rw [matrix.general_linear_group.coe_mul, matrix.det_mul, ha, hb, one_mul] },
  one_mem' := by {
    rw [set.mem_set_of, matrix.general_linear_group.coe_fn_eq_coe,
      matrix.general_linear_group.coe_one, matrix.det_one] },
  inv_mem' := λ a ha, by {
    rw [set.mem_set_of, matrix.general_linear_group.coe_fn_eq_coe] at ha ⊢,
    rw [matrix.coe_units_inv, matrix.det_nonsing_inv, ring.inverse_eq_inv', ha, inv_one] } }

def l1_2_4 {G : Type*} [group G] (S : set $ subgroup G) : subgroup G := Inf S
lemma l1_2_4' {G : Type*} [group G] (S : set $ subgroup G) :
  ((l1_2_4 S) : set G) = ⋂ s ∈ S, (s : set G) := subgroup.coe_Inf _

def d1_2_5 {G : Type*} [group G] (X : set G) : subgroup G := subgroup.closure X
lemma l1_2_5' {G : Type*} [group G] (X : set G) :
  (subgroup.closure X : set G) = ⋂ H' ∈ {H : subgroup G | X ⊆ H}, (H' : set G) := rfl

def n1_2_5_set  {G : Type*} [group G] (X : set G) :
  set (list G) := { m : list G | ∀ x ∈ m, x ∈ X ∪ X⁻¹ }

def n1_2_5 {G : Type*} [group G] (X : set G) : subgroup G :=
{ carrier := { (list.prod x) | x ∈ n1_2_5_set X },
  mul_mem' := begin
    intros a b ha hb,
    simp [set.mem_set_of] at ha hb ⊢,
    obtain ⟨xa, hxa⟩ := ha,
    obtain ⟨xb, hxb⟩ := hb,
    refine ⟨xa ++ xb, _, _⟩,
    { simp only [n1_2_5_set, set.mem_set_of] at hxa hxb ⊢,
      intros x hx,
      obtain hx'|hx' := list.mem_append.mp hx,
      exacts [hxa.1 x hx', hxb.1 x hx'] },
    { rw [list.prod_append, hxa.2, hxb.2] }
  end,
  one_mem' := begin
    simp [set.mem_set_of],
    refine ⟨[], _, list.prod_nil⟩,
    simp [n1_2_5_set, set.mem_set_of]
  end,
  inv_mem' := begin
    intros a ha,
    simp [set.mem_set_of] at ha ⊢,
    obtain ⟨xa, hxa⟩ := ha,
    refine ⟨(xa.map has_inv.inv).reverse, _, _⟩,
    { simpa [n1_2_5_set, set.mem_set_of, or_comm] using hxa.1 },
    { rw [←hxa.2, list.prod_inv_reverse] }
  end }

-- 2019-2020
lemma n1_2_5' {G : Type*} [group G] (X : set G) :
  (subgroup.closure X : set G) = { (list.prod x) | x ∈ n1_2_5_set X } :=
begin
  simp only [subgroup.closure, subgroup.coe_Inf],
  apply subset_antisymm,
  { intros x hx,
    simp only [set.mem_Inter] at hx,
    simp only [set.mem_set_of],
    specialize hx (n1_2_5 X) _,
    { intros y hy,
      simp only [n1_2_5, set.mem_set_of, subgroup.coe_set_mk],
      refine ⟨[y], _, list.prod_singleton⟩,
      simp only [hy, n1_2_5_set, forall_eq, true_or, set.mem_set_of, list.mem_singleton, set.mem_union] },
    simpa [n1_2_5] using hx },
  { intros x hx,
    simp only [set.mem_set_of, n1_2_5_set] at hx,
    simp only [set.mem_Inter, set_like.mem_coe],
    intros i hi,
    obtain ⟨y, h1, rfl⟩ := hx,
    induction y,
    { simp only [list.prod_nil, one_mem], },
    { simp only [list.prod_cons],
      apply mul_mem,
      { specialize h1 y_hd (list.mem_cons_self _ _),
        obtain h1|h1 := (set.mem_union _ _ _).mp h1,
        { exact hi h1 },
        { rw ←inv_inv y_hd, exact subgroup.inv_mem _ (hi h1) } },
      { exact y_ih (λ y hy, h1 _ (list.mem_cons_of_mem _ hy)) } } },
end

def l1_2_8_a {G : Type*} [group G] (H : subgroup G) : setoid G :=
quotient_group.left_rel H
lemma l1_2_8_b {G : Type*} [group G] [fintype G] (H : subgroup G) [fintype H] :
  fintype.card H ∣ fintype.card G :=
subgroup.card_subgroup_dvd_card H

open_locale cardinal
lemma l1_2_9 {G : Type*} [group G] (H : subgroup G) :
  #(quotient (quotient_group.right_rel H)) = #(quotient (quotient_group.left_rel H))  :=
cardinal.mk_congr $ quotient_group.quotient_right_rel_equiv_quotient_left_rel H

def d1_2_10 {G : Type*} [group G] (H : subgroup G) := #(G ⧸ H)
lemma d1_2_10' {G : Type*} [group G] [fintype G] (H : subgroup G) :
  nat.card (G ⧸ H) = nat.card G / nat.card H :=
begin
  haveI : fintype H,
  { classical, apply_instance },
  have : 0 < nat.card H,
  { rw [nat.card_eq_fintype_card, fintype.card_pos_iff],
    exact ⟨⟨1, one_mem _⟩⟩ },
  rw [←subgroup.card_mul_index H, nat.mul_div_cancel_left _ this, subgroup.index],
end

open_locale coset

lemma xmp_1_2_11 (n : ℕ+) : add_subgroup.index (ex_1_2_3_2 n) = n :=
begin
  simp [ex_1_2_3_2, add_subgroup.index,
    nat.card_congr (int.quotient_zmultiples_nat_equiv_zmod n).to_equiv, nat.card_eq_fintype_card,
    zmod.card],
end

lemma n_1_2_13 {G : Type*} [group G] (A B : set G) (g : G) :
  A = { (g * b) | b ∈ B } ↔ { (g⁻¹ * a) | a ∈ A } = B :=
begin
  split; { rintro rfl, ext, simp },
end

def ex_1_2_4' {G : Type*} [group G] (x : G × G) := x.1 * x.2
lemma ex_1_2_4 {G : Type*} [group G] (A B : set G) :
  #({ (ex_1_2_4' x) | x ∈ A ×ˢ B} : set G) ≤ #A * #B :=
begin
  simp only [ex_1_2_4', set.mem_prod, exists_prop, prod.exists],
  calc # ↥{x | ∃ (a b : G), (a ∈ A ∧ b ∈ B) ∧ a * b = x}
      = # ↥⋃ (a ∈ A) (b ∈ B), ({ (a : G) * (b : G) } : set G) : _
  ... = # ↥⋃ (a : A) (b : B), ({ (a : G) * (b : G) } : set G) : _
  ... ≤ cardinal.sum (λ (a : A), cardinal.sum $ λ (b : B), # ({ (a : G) * (b : G) } : set G)) : _
  ... = # ↥A * # ↥B : _,
  { congr' 2,
    ext x,
    simp [set.set_of_exists, set.set_of_and, ←exists_and_distrib_left, and_assoc] },
  { simp only [set.Union_coe_set],
    congr },
  { exact cardinal.mk_Union_le_sum_mk.trans
      (cardinal.sum_le_sum _ _ (λ a, cardinal.mk_Union_le_sum_mk)) },
  { simp_rw [cardinal.mk_singleton, cardinal.sum_const', mul_one] },
end

lemma ex_1_2_5 {G : Type*} [group G] (A B : set G) (g : G) :
  { (g * x) | x ∈ A ∩ B } = { (g * x) | x ∈ A } ∩ { (g * x) | x ∈ B } :=
begin
  ext y, simp only [set.mem_inter_eq, set.mem_set_of_eq, exists_prop],
  split,
  { rintro ⟨x, ⟨ha, hb⟩, hx⟩,
    exact ⟨⟨x, ha, hx⟩, ⟨x, hb, hx⟩⟩ },
  { rintro ⟨⟨x, ha, hx⟩, ⟨x', hb, hx'⟩⟩,
    obtain rfl : x = x',
    { rw [←mul_right_inj g, hx, hx'] },
    exact ⟨x, ⟨ha, hb⟩, hx⟩ }
end

lemma ex_1_2_6 {G : Type*} [fintype G] [group G] (A B : subgroup G) (h : A ≤ B) :
  subgroup.index A = subgroup.relindex A B * subgroup.index B :=
(subgroup.relindex_mul_index h).symm

lemma ex_1_2_7 {G : Type*} [group G] (A B : subgroup G) (h : A ≤ B) :
  subgroup.index A = subgroup.relindex A B * subgroup.index B :=
(subgroup.relindex_mul_index h).symm


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.hom.group
import algebra.hom.equiv.basic
import control.applicative
import control.traversable.basic
import logic.equiv.defs
import data.list.basic

/-!
# Free constructions

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

## Main definitions

* `free_magma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `magma.assoc_quotient α`: quotient of a magma `α` by the associativity equivalence relation.
* `free_semigroup α`: free semigroup over alphabet `α`, defined as a structure with two fields
  `head : α` and `tail : list α` (i.e. nonempty lists), with traversable instance and decidable
  equality.
* `free_magma_assoc_quotient_equiv α`: isomorphism between `magma.assoc_quotient (free_magma α)` and
  `free_semigroup α`.
* `free_magma.lift`: the universal property of the free magma, expressing its adjointness.
-/

universes u v l

/-- Free magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_magma (α : Type u) : Type u
| of : α → free_magma
| mul : free_magma → free_magma → free_magma

/-- Free nonabelian additive magma over a given alphabet. -/
@[derive decidable_eq]
inductive free_add_magma (α : Type u) : Type u
| of : α → free_add_magma
| add : free_add_magma → free_add_magma → free_add_magma

attribute [to_additive] free_magma

namespace free_magma

variables {α : Type u}

@[to_additive]
instance [inhabited α] : inhabited (free_magma α) := ⟨of default⟩

@[to_additive]
instance : has_mul (free_magma α) := ⟨free_magma.mul⟩

attribute [pattern] has_mul.mul

@[simp, to_additive]
theorem mul_eq (x y : free_magma α) : mul x y = x * y := rfl

/-- Recursor for `free_magma` using `x * y` instead of `free_magma.mul x y`. -/
@[elab_as_eliminator, to_additive
  "Recursor for `free_add_magma` using `x + y` instead of `free_add_magma.add x y`."]
def rec_on_mul {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on x ih1 ih2

@[ext, to_additive]

end free_magma

/-- Lifts a function `α → β` to a magma homomorphism `free_magma α → β` given a magma `β`. -/
def free_magma.lift_aux {α : Type u} {β : Type v} [has_mul β] (f : α → β) : free_magma α → β
| (free_magma.of x) := f x
| (x * y)           := x.lift_aux * y.lift_aux

/-- Lifts a function `α → β` to an additive magma homomorphism `free_add_magma α → β` given
an additive magma `β`. -/
def free_add_magma.lift_aux {α : Type u} {β : Type v} [has_add β] (f : α → β) : free_add_magma α → β
| (free_add_magma.of x) := f x
| (x + y)               := x.lift_aux + y.lift_aux

attribute [to_additive free_add_magma.lift_aux] free_magma.lift_aux

namespace free_magma

section lift

variables {α : Type u} {β : Type v} [has_mul β] (f : α → β)

/-- The universal property of the free magma expressing its adjointness. -/
@[to_additive "The universal property of the free additive magma expressing its adjointness.",
  simps symm_apply]
def lift : (α → β) ≃ (free_magma α →ₙ* β) :=
{ to_fun    := λ f,
  { to_fun := lift_aux f,
    map_mul' := λ x y, rfl, },
  inv_fun   := λ F, F ∘ of,
  left_inv  := λ f, by { ext, refl },
  right_inv := λ F, by { ext, refl } }

@[simp, to_additive] lemma lift_of (x) : lift f (of x) = f x := rfl
@[simp, to_additive] lemma lift_comp_of : lift f ∘ of = f := rfl

@[simp, to_additive] lemma lift_comp_of' (f : free_magma α →ₙ* β) : lift (f ∘ of) = f :=
lift.apply_symm_apply f

end lift

section map

variables {α : Type u} {β : Type v} (f : α → β)

/-- The unique magma homomorphism `free_magma α →ₙ* free_magma β` that sends
each `of x` to `of (f x)`. -/
@[to_additive "The unique additive magma homomorphism `free_add_magma α → free_add_magma β` that
sends each `of x` to `of (f x)`."]
def map (f : α → β) : free_magma α →ₙ* free_magma β := lift (of ∘ f)

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl

end map

section category

variables {α β : Type u}

@[to_additive]
instance : monad free_magma :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor on `free_magma` using `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor on `free_add_magma` using `pure` instead of `of`."]
protected def rec_on_pure {C : free_magma α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C x → C y → C (x * y)) :
  C x :=
free_magma.rec_on_mul x ih1 ih2

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_magma β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_magma α) : (f <$> (x * y)) = (f <$> x * f <$> y) := rfl

@[simp, to_additive]
lemma pure_bind (f : α → free_magma β) (x) : (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_magma β) (x y : free_magma α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) := rfl

@[simp, to_additive]
lemma pure_seq {α β : Type u} {f : α → β} {x : free_magma α} : pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {α β : Type u} {f g : free_magma (α → β)} {x : free_magma α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) := rfl

@[to_additive]
instance : is_lawful_monad free_magma.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, free_magma.rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, free_magma.rec_on_pure x (λ _, rfl)
    (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

end category

end free_magma

/-- `free_magma` is traversable. -/
protected def free_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_magma α → m (free_magma β)
| (free_magma.of x) := free_magma.of <$> F x
| (x * y)           := (*) <$> x.traverse <*> y.traverse

/-- `free_add_magma` is traversable. -/
protected def free_add_magma.traverse {m : Type u → Type u} [applicative m] {α β : Type u}
  (F : α → m β) :
  free_add_magma α → m (free_add_magma β)
| (free_add_magma.of x) := free_add_magma.of <$> F x
| (x + y)               := (+) <$> x.traverse <*> y.traverse

attribute [to_additive free_add_magma.traverse] free_magma.traverse

namespace free_magma

variables {α : Type u}

section category

variables {β : Type u}

@[to_additive]
instance : traversable free_magma := ⟨@free_magma.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) : traverse F (pure x : free_magma α) = pure <$> F x := rfl

@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_magma β)) := rfl

@[simp, to_additive]
lemma traverse_mul (x y : free_magma α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_magma α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y := rfl

@[simp, to_additive]
lemma traverse_eq (x) : free_magma.traverse F x = traverse F x := rfl

@[simp, to_additive]
lemma mul_map_seq (x y : free_magma α) :
  ((*) <$> x <*> y : id (free_magma α)) = (x * y : free_magma α) := rfl

@[to_additive]
instance : is_lawful_traversable free_magma.{u} :=
{ id_traverse := λ α x, free_magma.rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, free_magma.rec_on_pure x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, free_magma.rec_on_pure x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_magma.rec_on_pure x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_magma.is_lawful_monad }

end category

end free_magma

/-- Representation of an element of a free magma. -/
protected def free_magma.repr {α : Type u} [has_repr α] : free_magma α → string
| (free_magma.of x) := repr x
| (x * y)           := "( " ++ x.repr ++ " * " ++ y.repr ++ " )"

/-- Representation of an element of a free additive magma. -/
protected def free_add_magma.repr {α : Type u} [has_repr α] : free_add_magma α → string
| (free_add_magma.of x) := repr x
| (x + y)               := "( " ++ x.repr ++ " + " ++ y.repr ++ " )"

attribute [to_additive free_add_magma.repr] free_magma.repr

@[to_additive]
instance {α : Type u} [has_repr α] : has_repr (free_magma α) := ⟨free_magma.repr⟩

/-- Length of an element of a free magma. -/
@[simp] def free_magma.length {α : Type u} : free_magma α → ℕ
| (free_magma.of x) := 1
| (x * y)           := x.length + y.length

/-- Length of an element of a free additive magma. -/
@[simp] def free_add_magma.length {α : Type u} : free_add_magma α → ℕ
| (free_add_magma.of x) := 1
| (x + y)               := x.length + y.length

attribute [to_additive free_add_magma.length] free_magma.length

/-- Associativity relations for an additive magma. -/
inductive add_magma.assoc_rel (α : Type u) [has_add α] : α → α → Prop
| intro : ∀ x y z, add_magma.assoc_rel ((x + y) + z) (x + (y + z))
| left : ∀ w x y z, add_magma.assoc_rel (w + ((x + y) + z)) (w + (x + (y + z)))

/-- Associativity relations for a magma. -/
@[to_additive add_magma.assoc_rel "Associativity relations for an additive magma."]
inductive magma.assoc_rel (α : Type u) [has_mul α] : α → α → Prop
| intro : ∀ x y z, magma.assoc_rel ((x * y) * z) (x * (y * z))
| left : ∀ w x y z, magma.assoc_rel (w * ((x * y) * z)) (w * (x * (y * z)))

namespace magma

/-- Semigroup quotient of a magma. -/
@[to_additive add_magma.free_add_semigroup "Additive semigroup quotient of an additive magma."]
def assoc_quotient (α : Type u) [has_mul α] : Type u := quot $ assoc_rel α

namespace assoc_quotient

variables {α : Type u} [has_mul α]

@[to_additive]
lemma quot_mk_assoc (x y z : α) : quot.mk (assoc_rel α) (x * y * z) = quot.mk _ (x * (y * z)) :=
quot.sound (assoc_rel.intro _ _ _)

@[to_additive]
lemma quot_mk_assoc_left (x y z w : α) :
  quot.mk (assoc_rel α) (x * (y * z * w)) = quot.mk _ (x * (y * (z * w))) :=
quot.sound (assoc_rel.left _ _ _ _)

@[to_additive]
instance : semigroup (assoc_quotient α) :=
{ mul := λ x y,
    begin
      refine quot.lift_on₂ x y (λ x y, quot.mk _ (x * y)) _ _,
      { rintro a b₁ b₂ (⟨c, d, e⟩ | ⟨c, d, e, f⟩); simp only,
        { exact quot_mk_assoc_left _ _ _ _ },
        { rw [← quot_mk_assoc, quot_mk_assoc_left, quot_mk_assoc] } },
      { rintro a₁ a₂ b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); simp only,
        { simp only [quot_mk_assoc, quot_mk_assoc_left] },
        { rw [quot_mk_assoc, quot_mk_assoc, quot_mk_assoc_left, quot_mk_assoc_left,
            quot_mk_assoc_left, ← quot_mk_assoc c d, ← quot_mk_assoc c d, quot_mk_assoc_left] } }
    end,
  mul_assoc := λ x y z, quot.induction_on₃ x y z $ λ p q r, quot_mk_assoc p q r }

/-- Embedding from magma to its free semigroup. -/
@[to_additive "Embedding from additive magma to its free additive semigroup."]
def of : α →ₙ* assoc_quotient α := ⟨quot.mk _, λ x y, rfl⟩

@[to_additive]
instance [inhabited α] : inhabited (assoc_quotient α) := ⟨of default⟩

@[elab_as_eliminator, to_additive]
protected lemma induction_on {C : assoc_quotient α → Prop} (x : assoc_quotient α)
  (ih : ∀ x, C (of x)) : C x :=
quot.induction_on x ih

section lift

variables {β : Type v} [semigroup β] (f : α →ₙ* β)

@[ext, to_additive]
lemma hom_ext {f g : assoc_quotient α →ₙ* β} (h : f.comp of = g.comp of) : f = g :=
fun_like.ext _ _ $ λ x, assoc_quotient.induction_on x $ fun_like.congr_fun h

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `magma.assoc_quotient α → β`
given a semigroup `β`. -/
@[to_additive "Lifts an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.assoc_quotient α → β` given an additive semigroup `β`.", simps symm_apply]
def lift : (α →ₙ* β) ≃ (assoc_quotient α →ₙ* β) :=
{ to_fun := λ f,
    { to_fun := λ x, quot.lift_on x f $
        by rintros a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩); simp only [map_mul, mul_assoc],
      map_mul' := λ x y, quot.induction_on₂ x y (map_mul f) },
  inv_fun := λ f, f.comp of,
  left_inv := λ f, fun_like.ext _ _ $ λ x, rfl,
  right_inv := λ f, hom_ext $ fun_like.ext _ _ $ λ x, rfl }

@[simp, to_additive] lemma lift_of (x : α) : lift f (of x) = f x := rfl

@[simp, to_additive] lemma lift_comp_of : (lift f).comp of = f := lift.symm_apply_apply f

@[simp, to_additive] lemma lift_comp_of' (f : assoc_quotient α →ₙ* β) :
  lift (f.comp of) = f :=
lift.apply_symm_apply f

end lift

variables {β : Type v} [has_mul β] (f : α →ₙ* β)

/-- From a magma homomorphism `α →ₙ* β` to a semigroup homomorphism
`magma.assoc_quotient α →ₙ* magma.assoc_quotient β`. -/
@[to_additive "From an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`add_magma.assoc_quotient α → add_magma.assoc_quotient β`."]
def map : assoc_quotient α →ₙ* assoc_quotient β := lift (of.comp f)

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl

end assoc_quotient

end magma

/-- Free additive semigroup over a given alphabet. -/
@[ext] structure free_add_semigroup (α : Type u) := (head : α) (tail : list α)

/-- Free semigroup over a given alphabet. -/
@[ext, to_additive] structure free_semigroup (α : Type u) := (head : α) (tail : list α)

namespace free_semigroup

variables {α : Type u}

@[to_additive]
instance : semigroup (free_semigroup α) :=
{ mul := λ L1 L2, ⟨L1.1, L1.2 ++ L2.1 :: L2.2⟩,
  mul_assoc := λ L1 L2 L3, ext _ _ rfl $ list.append_assoc _ _ _ }

@[simp, to_additive] lemma head_mul (x y : free_semigroup α) : (x * y).1 = x.1 := rfl

@[simp, to_additive] lemma tail_mul (x y : free_semigroup α) : (x * y).2 = x.2 ++ (y.1 :: y.2) :=
rfl

@[simp, to_additive] lemma mk_mul_mk (x y : α) (L1 L2 : list α) :
  mk x L1 * mk y L2 = mk x (L1 ++ y :: L2) := rfl

/-- The embedding `α → free_semigroup α`. -/
@[to_additive "The embedding `α → free_add_semigroup α`.", simps]
def of (x : α) : free_semigroup α := ⟨x, []⟩

/-- Length of an element of free semigroup. -/
@[to_additive "Length of an element of free additive semigroup"]
def length (x : free_semigroup α) : ℕ := x.tail.length + 1

@[simp, to_additive] lemma length_mul (x y : free_semigroup α) :
  (x * y).length = x.length + y.length :=
by simp [length, ← add_assoc, add_right_comm]

@[simp, to_additive] lemma length_of (x : α) : (of x).length = 1 := rfl

@[to_additive] instance [inhabited α] : inhabited (free_semigroup α) := ⟨of default⟩

/-- Recursor for free semigroup using `of` and `*`. -/
@[elab_as_eliminator, to_additive "Recursor for free additive semigroup using `of` and `+`."]
protected def rec_on_mul {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (of x)) (ih2 : ∀ x y, C (of x) → C y → C (of x * y)) :
  C x :=
free_semigroup.rec_on x $ λ f s, list.rec_on s ih1 (λ hd tl ih f, ih2 f ⟨hd, tl⟩ (ih1 f) (ih hd)) f

@[ext, to_additive]
lemma hom_ext {β : Type v} [has_mul β] {f g : free_semigroup α →ₙ* β} (h : f ∘ of = g ∘ of) :
  f = g :=
fun_like.ext _ _ $ λ x, free_semigroup.rec_on_mul x (congr_fun h) $
  λ x y hx hy, by simp only [map_mul, *]

section lift

variables {β : Type v} [semigroup β] (f : α → β)

/-- Lifts a function `α → β` to a semigroup homomorphism `free_semigroup α → β` given
a semigroup `β`. -/
@[to_additive "Lifts a function `α → β` to an additive semigroup homomorphism
`free_add_semigroup α → β` given an additive semigroup `β`.", simps symm_apply]
def lift : (α → β) ≃ (free_semigroup α →ₙ* β) :=
{ to_fun := λ f,
    { to_fun := λ x, x.2.foldl (λ a b, a * f b) (f x.1),
      map_mul' := λ x y, by simp only [head_mul, tail_mul, ← list.foldl_map f, list.foldl_append,
        list.foldl_cons, list.foldl_assoc] },
  inv_fun := λ f, f ∘ of,
  left_inv := λ f, rfl,
  right_inv := λ f, hom_ext rfl }

@[simp, to_additive] lemma lift_of (x : α) : lift f (of x) = f x := rfl
@[simp, to_additive] lemma lift_comp_of : lift f ∘ of = f := rfl

@[simp, to_additive] lemma lift_comp_of' (f : free_semigroup α →ₙ* β) : lift (f ∘ of) = f :=
hom_ext rfl

@[to_additive] lemma lift_of_mul (x y) : lift f (of x * y) = f x * lift f y :=
by rw [map_mul, lift_of]

end lift

section map

variables {β : Type v} (f : α → β)

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
@[to_additive "The unique additive semigroup homomorphism that sends `of x` to `of (f x)`."]
def map : free_semigroup α →ₙ* free_semigroup β :=
lift $ of ∘ f

@[simp, to_additive] lemma map_of (x) : map f (of x) = of (f x) := rfl

@[simp, to_additive] lemma length_map (x) : (map f x).length = x.length :=
free_semigroup.rec_on_mul x (λ x, rfl) $ λ x y hx hy, by simp only [map_mul, length_mul, *]

end map

section category

variables {β : Type u}

@[to_additive]
instance : monad free_semigroup :=
{ pure := λ _, of,
  bind := λ _ _ x f, lift f x }

/-- Recursor that uses `pure` instead of `of`. -/
@[elab_as_eliminator, to_additive "Recursor that uses `pure` instead of `of`."]
def rec_on_pure {C : free_semigroup α → Sort l} (x)
  (ih1 : ∀ x, C (pure x)) (ih2 : ∀ x y, C (pure x) → C y → C (pure x * y)) :
  C x :=
free_semigroup.rec_on_mul x ih1 ih2

@[simp, to_additive]
lemma map_pure (f : α → β) (x) : (f <$> pure x : free_semigroup β) = pure (f x) := rfl

@[simp, to_additive]
lemma map_mul' (f : α → β) (x y : free_semigroup α) :
  (f <$> (x * y)) = (f <$> x * f <$> y) :=
map_mul (map f) _ _

@[simp, to_additive] lemma pure_bind (f : α → free_semigroup β) (x) :
  (pure x >>= f) = f x := rfl

@[simp, to_additive]
lemma mul_bind (f : α → free_semigroup β) (x y : free_semigroup α) :
  (x * y >>= f) = ((x >>= f) * (y >>= f)) :=
map_mul (lift f) _ _

@[simp, to_additive] lemma pure_seq {f : α → β} {x : free_semigroup α} :
  pure f <*> x = f <$> x := rfl

@[simp, to_additive]
lemma mul_seq {f g : free_semigroup (α → β)} {x : free_semigroup α} :
  (f * g) <*> x = (f <*> x) * (g <*> x) :=
mul_bind _ _ _

@[to_additive]
instance : is_lawful_monad free_semigroup.{u} :=
{ pure_bind := λ _ _ _ _, rfl,
  bind_assoc := λ α β γ x f g, rec_on_pure x (λ x, rfl)
    (λ x y ih1 ih2, by rw [mul_bind, mul_bind, mul_bind, ih1, ih2]),
  id_map := λ α x, rec_on_pure x (λ _, rfl) (λ x y ih1 ih2, by rw [map_mul', ih1, ih2]) }

/-- `free_semigroup` is traversable. -/
@[to_additive "`free_add_semigroup` is traversable."]
protected def traverse {m : Type u → Type u} [applicative m]
  {α β : Type u} (F : α → m β) (x : free_semigroup α) : m (free_semigroup β) :=
rec_on_pure x (λ x, pure <$> F x) (λ x y ihx ihy, (*) <$> ihx <*> ihy)

@[to_additive]
instance : traversable free_semigroup := ⟨@free_semigroup.traverse⟩

variables {m : Type u → Type u} [applicative m] (F : α → m β)

@[simp, to_additive]
lemma traverse_pure (x) :traverse F (pure x : free_semigroup α) = pure <$> F x := rfl
@[simp, to_additive]
lemma traverse_pure' : traverse F ∘ pure = λ x, (pure <$> F x : m (free_semigroup β)) := rfl

section
variables [is_lawful_applicative m]
@[simp, to_additive] lemma traverse_mul (x y : free_semigroup α) :
  traverse F (x * y) = (*) <$> traverse F x <*> traverse F y :=
let ⟨x, L1⟩ := x, ⟨y, L2⟩ := y in
list.rec_on L1 (λ x, rfl) (λ hd tl ih x,
  show (*) <$> pure <$> F x <*> traverse F ((mk hd tl) * (mk y L2)) =
  (*) <$> ((*) <$> pure <$> F x <*> traverse F (mk hd tl)) <*> traverse F (mk y L2),
  by rw ih; simp only [(∘), (mul_assoc _ _ _).symm] with functor_norm) x

@[simp, to_additive] lemma traverse_mul' :
  function.comp (traverse F) ∘ @has_mul.mul (free_semigroup α) _ =
    λ x y, (*) <$> traverse F x <*> traverse F y :=
funext $ λ x, funext $ λ y, traverse_mul F x y
end

@[simp, to_additive] lemma traverse_eq (x) : free_semigroup.traverse F x = traverse F x := rfl

@[simp, to_additive] lemma mul_map_seq (x y : free_semigroup α) :
  ((*) <$> x <*> y : id (free_semigroup α)) = (x * y : free_semigroup α) := rfl

@[to_additive]
instance : is_lawful_traversable free_semigroup.{u} :=
{ id_traverse := λ α x, free_semigroup.rec_on_mul x (λ x, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, mul_map_seq]),
  comp_traverse := λ F G hf1 hg1 hf2 hg2 α β γ f g x, rec_on_pure x
    (λ x, by resetI; simp only [traverse_pure, traverse_pure'] with functor_norm)
    (λ x y ih1 ih2, by resetI; rw [traverse_mul, ih1, ih2, traverse_mul];
      simp only [traverse_mul'] with functor_norm),
  naturality := λ F G hf1 hg1 hf2 hg2 η α β f x, rec_on_pure x
    (λ x, by simp only [traverse_pure] with functor_norm)
    (λ x y ih1 ih2, by resetI; simp only [traverse_mul] with functor_norm; rw [ih1, ih2]),
  traverse_eq_map_id := λ α β f x, free_semigroup.rec_on_mul x (λ _, rfl)
    (λ x y ih1 ih2, by rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; refl),
  .. free_semigroup.is_lawful_monad }

end category

@[to_additive]
instance [decidable_eq α] : decidable_eq (free_semigroup α) :=
λ x y, decidable_of_iff' _ (ext_iff _ _)

end free_semigroup

namespace free_magma

variables {α : Type u} {β : Type v}

/-- The canonical multiplicative morphism from `free_magma α` to `free_semigroup α`. -/
@[to_additive "The canonical additive morphism from `free_add_magma α` to `free_add_semigroup α`."]
def to_free_semigroup : free_magma α →ₙ* free_semigroup α := free_magma.lift free_semigroup.of

@[simp, to_additive] lemma to_free_semigroup_of (x : α) :
  to_free_semigroup (of x) = free_semigroup.of x :=
rfl

@[simp, to_additive] lemma to_free_semigroup_comp_of :
  @to_free_semigroup α ∘ of = free_semigroup.of :=
rfl

@[to_additive] lemma to_free_semigroup_comp_map (f : α → β) :
  to_free_semigroup.comp (map f) = (free_semigroup.map f).comp to_free_semigroup :=
by { ext1, refl }

@[to_additive] lemma to_free_semigroup_map (f : α → β) (x : free_magma α) :
  (map f x).to_free_semigroup = free_semigroup.map f x.to_free_semigroup :=
fun_like.congr_fun (to_free_semigroup_comp_map f) x

@[simp, to_additive] lemma length_to_free_semigroup (x : free_magma α) :
  x.to_free_semigroup.length = x.length :=
free_magma.rec_on_mul x (λ x, rfl) $ λ x y hx hy,
  by rw [map_mul, free_semigroup.length_mul, length, hx, hy]

end free_magma

/-- Isomorphism between `magma.assoc_quotient (free_magma α)` and `free_semigroup α`. -/
@[to_additive "Isomorphism between
`add_magma.assoc_quotient (free_add_magma α)` and `free_add_semigroup α`."]
def free_magma_assoc_quotient_equiv (α : Type u) :
  magma.assoc_quotient (free_magma α) ≃* free_semigroup α :=
(magma.assoc_quotient.lift free_magma.to_free_semigroup).to_mul_equiv
  (free_semigroup.lift (magma.assoc_quotient.of ∘ free_magma.of))
  (by { ext, refl }) (by { ext1, refl })


/-
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 ring_theory.adjoin.basic
import data.polynomial.eval

/-!
# Theory of univariate polynomials

We show that `polynomial A` is an R-algebra when `A` is an R-algebra.
We promote `eval₂` to an algebra hom in `aeval`.
-/

noncomputable theory
open finset
open_locale big_operators polynomial

namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {A' B' : Type*} {a b : R} {n : ℕ}
variables [comm_semiring A'] [semiring B']

section comm_semiring
variables [comm_semiring R] {p q r : R[X]}

variables [semiring A] [algebra R A]

/-- Note that this instance also provides `algebra R R[X]`. -/
instance algebra_of_algebra : algebra R (polynomial A) :=
{ smul_def' := λ r p, to_finsupp_injective $ begin
    dsimp only [ring_hom.to_fun_eq_coe, ring_hom.comp_apply],
    rw [to_finsupp_smul, to_finsupp_mul, to_finsupp_C],
    exact algebra.smul_def' _ _,
  end,
  commutes' := λ r p, to_finsupp_injective $ begin
    dsimp only [ring_hom.to_fun_eq_coe, ring_hom.comp_apply],
    simp_rw [to_finsupp_mul, to_finsupp_C],
    convert algebra.commutes' r p.to_finsupp,
  end,
  to_ring_hom := C.comp (algebra_map R A) }

lemma algebra_map_apply (r : R) :
  algebra_map R (polynomial A) r = C (algebra_map R A r) :=
rfl

@[simp] lemma to_finsupp_algebra_map (r : R) :
  (algebra_map R (polynomial A) r).to_finsupp = algebra_map R _ r :=
show to_finsupp (C (algebra_map _ _ r)) = _, by { rw to_finsupp_C, refl }

lemma of_finsupp_algebra_map (r : R) :
  (⟨algebra_map R _ r⟩ : A[X]) = algebra_map R (polynomial A) r :=
to_finsupp_injective (to_finsupp_algebra_map _).symm

/--
When we have `[comm_semiring R]`, the function `C` is the same as `algebra_map R R[X]`.

(But note that `C` is defined when `R` is not necessarily commutative, in which case
`algebra_map` is not available.)
-/
lemma C_eq_algebra_map (r : R) :
  C r = algebra_map R R[X] r :=
rfl

variables {R}

/--
  Extensionality lemma for algebra maps out of `polynomial A'` over a smaller base ring than `A'`
-/
@[ext] lemma alg_hom_ext' [algebra R A'] [algebra R B']
  {f g : A'[X] →ₐ[R] B'}
  (h₁ : f.comp (is_scalar_tower.to_alg_hom R A' (polynomial A')) =
        g.comp (is_scalar_tower.to_alg_hom R A' (polynomial A')))
  (h₂ : f X = g X) : f = g :=
alg_hom.coe_ring_hom_injective (polynomial.ring_hom_ext'
  (congr_arg alg_hom.to_ring_hom h₁) h₂)

variable (R)

/-- Algebra isomorphism between `polynomial R` and `add_monoid_algebra R ℕ`. This is just an
implementation detail, but it can be useful to transfer results from `finsupp` to polynomials. -/
@[simps]
def to_finsupp_iso_alg : R[X] ≃ₐ[R] add_monoid_algebra R ℕ :=
{ commutes' := λ r,
  begin
    dsimp,
    exact to_finsupp_algebra_map _,
  end,
  ..to_finsupp_iso R }

variable {R}

instance [nontrivial A] : nontrivial (subalgebra R (polynomial A)) :=
⟨⟨⊥, ⊤, begin
  rw [ne.def, set_like.ext_iff, not_forall],
  refine ⟨X, _⟩,
  simp only [algebra.mem_bot, not_exists, set.mem_range, iff_true, algebra.mem_top,
    algebra_map_apply, not_forall],
  intro x,
  rw [ext_iff, not_forall],
  refine ⟨1, _⟩,
  simp [coeff_C],
end⟩⟩

@[simp]
lemma alg_hom_eval₂_algebra_map
  {R A B : Type*} [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]
  (p : R[X]) (f : A →ₐ[R] B) (a : A) :
  f (eval₂ (algebra_map R A) a p) = eval₂ (algebra_map R B) (f a) p :=
begin
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, ring_hom.eq_int_cast, ring_hom.map_int_cast,
    alg_hom.commutes],
end

@[simp]
lemma eval₂_algebra_map_X {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  (p : R[X]) (f : R[X] →ₐ[R] A) :
  eval₂ (algebra_map R A) (f X) p = f p :=
begin
  conv_rhs { rw [←polynomial.sum_C_mul_X_eq p], },
  dsimp [eval₂, sum],
  simp only [f.map_sum, f.map_mul, f.map_pow, ring_hom.eq_int_cast, ring_hom.map_int_cast],
  simp [polynomial.C_eq_algebra_map],
end

-- these used to be about `algebra_map ℤ R`, but now the simp-normal form is `int.cast_ring_hom R`.
@[simp]
lemma ring_hom_eval₂_cast_int_ring_hom {R S : Type*} [ring R] [ring S]
  (p : ℤ[X]) (f : R →+* S) (r : R) :
  f (eval₂ (int.cast_ring_hom R) r p) = eval₂ (int.cast_ring_hom S) (f r) p :=
alg_hom_eval₂_algebra_map p f.to_int_alg_hom r

@[simp]
lemma eval₂_int_cast_ring_hom_X {R : Type*} [ring R] (p : ℤ[X]) (f : ℤ[X] →+* R) :
  eval₂ (int.cast_ring_hom R) (f X) p = f p :=
eval₂_algebra_map_X p f.to_int_alg_hom

end comm_semiring

section aeval
variables [comm_semiring R] {p q : R[X]}

variables [semiring A] [algebra R A]
variables {B : Type*} [semiring B] [algebra R B]
variables (x : A)

/-- Given a valuation `x` of the variable in an `R`-algebra `A`, `aeval R A x` is
the unique `R`-algebra homomorphism from `R[X]` to `A` sending `X` to `x`.

This is a stronger variant of the linear map `polynomial.leval`. -/
def aeval : R[X] →ₐ[R] A :=
{ commutes' := λ r, eval₂_C _ _,
  ..eval₂_ring_hom' (algebra_map R A) x (λ a, algebra.commutes _ _) }

variables {R A}

@[simp] lemma adjoin_X : algebra.adjoin R ({X} : set R[X]) = ⊤ :=
begin
  refine top_unique (λ p hp, _),
  set S := algebra.adjoin R ({X} : set R[X]),
  rw [← sum_monomial_eq p], simp only [monomial_eq_smul_X, sum],
  exact S.sum_mem (λ n hn, S.smul_mem (S.pow_mem (algebra.subset_adjoin rfl) _) _)
end

@[ext] lemma alg_hom_ext {f g : R[X] →ₐ[R] A} (h : f X = g X) : f = g :=
alg_hom.ext_of_adjoin_eq_top adjoin_X $ λ p hp, (set.mem_singleton_iff.1 hp).symm ▸ h

theorem aeval_def (p : R[X]) : aeval x p = eval₂ (algebra_map R A) x p := rfl

@[simp] lemma aeval_zero : aeval x (0 : R[X]) = 0 :=
alg_hom.map_zero (aeval x)

@[simp] lemma aeval_X : aeval x (X : R[X]) = x := eval₂_X _ x

@[simp] lemma aeval_C (r : R) : aeval x (C r) = algebra_map R A r := eval₂_C _ x

@[simp] lemma aeval_monomial {n : ℕ} {r : R} : aeval x (monomial n r) = (algebra_map _ _ r) * x^n :=
eval₂_monomial _ _

@[simp] lemma aeval_X_pow {n : ℕ} : aeval x ((X : R[X])^n) = x^n :=
eval₂_X_pow _ _

@[simp] lemma aeval_add : aeval x (p + q) = aeval x p + aeval x q :=
alg_hom.map_add _ _ _

@[simp] lemma aeval_one : aeval x (1 : R[X]) = 1 :=
alg_hom.map_one _

@[simp] lemma aeval_bit0 : aeval x (bit0 p) = bit0 (aeval x p) :=
alg_hom.map_bit0 _ _

@[simp] lemma aeval_bit1 : aeval x (bit1 p) = bit1 (aeval x p) :=
alg_hom.map_bit1 _ _

@[simp] lemma aeval_nat_cast (n : ℕ) : aeval x (n : R[X]) = n :=
map_nat_cast _ _

lemma aeval_mul : aeval x (p * q) = aeval x p * aeval x q :=
alg_hom.map_mul _ _ _

lemma aeval_comp {A : Type*} [comm_semiring A] [algebra R A] (x : A) :
  aeval x (p.comp q) = (aeval (aeval x q) p) :=
eval₂_comp (algebra_map R A)

@[simp] lemma aeval_map {A : Type*} [comm_semiring A] [algebra R A] [algebra A B]
  [is_scalar_tower R A B] (b : B) (p : R[X]) :
  aeval b (p.map (algebra_map R A)) = aeval b p :=
by rw [aeval_def, eval₂_map, ←is_scalar_tower.algebra_map_eq, ←aeval_def]

theorem aeval_alg_hom (f : A →ₐ[R] B) (x : A) : aeval (f x) = f.comp (aeval x) :=
alg_hom_ext $ by simp only [aeval_X, alg_hom.comp_apply]

@[simp] theorem aeval_X_left : aeval (X : R[X]) = alg_hom.id R R[X] :=
alg_hom_ext $ aeval_X X

theorem eval_unique (φ : R[X] →ₐ[R] A) (p) :
  φ p = eval₂ (algebra_map R A) (φ X) p :=
by rw [← aeval_def, aeval_alg_hom, aeval_X_left, alg_hom.comp_id]

theorem aeval_alg_equiv (f : A ≃ₐ[R] B) (x : A) : aeval (f x) = (f : A →ₐ[R] B).comp (aeval x) :=
aeval_alg_hom (f : A →ₐ[R] B) x

theorem aeval_alg_equiv_apply (f : A ≃ₐ[R] B) (x : A) (p : R[X]) :
  aeval (f x) p = f (aeval x p) :=
aeval_alg_hom_apply (f : A →ₐ[R] B) x p

lemma aeval_algebra_map_apply (x : R) (p : R[X]) :
  aeval (algebra_map R A x) p = algebra_map R A (p.eval x) :=
aeval_alg_hom_apply (algebra.of_id R A) x p

@[simp] lemma coe_aeval_eq_eval (r : R) :
  (aeval r : R[X] → R) = eval r := rfl

@[simp] lemma aeval_fn_apply {X : Type*} (g : R[X]) (f : X → R) (x : X) :
  ((aeval f) g) x = aeval (f x) g :=
(aeval_alg_hom_apply (pi.eval_alg_hom _ _ x) f g).symm

@[norm_cast] lemma aeval_subalgebra_coe
  (g : R[X]) {A : Type*} [semiring A] [algebra R A] (s : subalgebra R A) (f : s) :
  (aeval f g : A) = aeval (f : A) g :=
(aeval_alg_hom_apply s.val f g).symm

lemma coeff_zero_eq_aeval_zero (p : R[X]) : p.coeff 0 = aeval 0 p :=
by simp [coeff_zero_eq_eval_zero]

lemma coeff_zero_eq_aeval_zero' (p : R[X]) :
  algebra_map R A (p.coeff 0) = aeval (0 : A) p :=
by simp [aeval_def]

variable (R)

theorem _root_.algebra.adjoin_singleton_eq_range_aeval (x : A) :
  algebra.adjoin R {x} = (polynomial.aeval x).range :=
by rw [← algebra.map_top, ← adjoin_X, alg_hom.map_adjoin, set.image_singleton, aeval_X]

variable {R}

section comm_semiring

variables [comm_semiring S] {f : R →+* S}

lemma aeval_eq_sum_range [algebra R S] {p : R[X]} (x : S) :
  aeval x p = ∑ i in finset.range (p.nat_degree + 1), p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range (algebra_map R S) x }

lemma aeval_eq_sum_range' [algebra R S] {p : R[X]} {n : ℕ} (hn : p.nat_degree < n) (x : S) :
  aeval x p = ∑ i in finset.range n, p.coeff i • x ^ i :=
by { simp_rw algebra.smul_def, exact eval₂_eq_sum_range' (algebra_map R S) hn x }

lemma is_root_of_eval₂_map_eq_zero
  (hf : function.injective f) {r : R} : eval₂ f (f r) p = 0 → p.is_root r :=
begin
  intro h,
  apply hf,
  rw [←eval₂_hom, h, f.map_zero],
end

lemma is_root_of_aeval_algebra_map_eq_zero [algebra R S] {p : R[X]}
  (inj : function.injective (algebra_map R S))
  {r : R} (hr : aeval (algebra_map R S r) p = 0) : p.is_root r :=
is_root_of_eval₂_map_eq_zero inj hr

section aeval_tower

variables [algebra S R] [algebra S A'] [algebra S B']

/-- Version of `aeval` for defining algebra homs out of `polynomial R` over a smaller base ring
  than `R`. -/
def aeval_tower (f : R →ₐ[S] A') (x : A') : R[X] →ₐ[S] A' :=
{ commutes' := λ r, by simp [algebra_map_apply],
  ..eval₂_ring_hom ↑f x }

variables (g : R →ₐ[S] A') (y : A')

@[simp] lemma aeval_tower_X : aeval_tower g y X = y := eval₂_X _ _

@[simp] lemma aeval_tower_C (x : R) : aeval_tower g y (C x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_C : ((aeval_tower g y : R[X] →+* A').comp C) = g :=
ring_hom.ext $ aeval_tower_C _ _

@[simp] lemma aeval_tower_algebra_map (x : R) :
  aeval_tower g y (algebra_map R R[X] x) = g x := eval₂_C _ _

@[simp] lemma aeval_tower_comp_algebra_map :
  (aeval_tower g y : R[X] →+* A').comp (algebra_map R R[X]) = g :=
aeval_tower_comp_C _ _

lemma aeval_tower_to_alg_hom (x : R) :
  aeval_tower g y (is_scalar_tower.to_alg_hom S R R[X] x) = g x :=
aeval_tower_algebra_map _ _ _

@[simp] lemma aeval_tower_comp_to_alg_hom :
  (aeval_tower g y).comp (is_scalar_tower.to_alg_hom S R R[X]) = g :=
alg_hom.coe_ring_hom_injective $ aeval_tower_comp_algebra_map _ _

@[simp] lemma aeval_tower_id : aeval_tower (alg_hom.id S S) = aeval :=
by { ext, simp only [eval_X, aeval_tower_X, coe_aeval_eq_eval], }

@[simp] lemma aeval_tower_of_id : aeval_tower (algebra.of_id S A') = aeval :=
by { ext, simp only [aeval_X, aeval_tower_X], }

end aeval_tower

end comm_semiring

section comm_ring

variables [comm_ring S] {f : R →+* S}

lemma dvd_term_of_dvd_eval_of_dvd_terms {z p : S} {f : S[X]} (i : ℕ)
  (dvd_eval : p ∣ f.eval z) (dvd_terms : ∀ (j ≠ i), p ∣ f.coeff j * z ^ j) :
  p ∣ f.coeff i * z ^ i :=
begin
  by_cases hi : i ∈ f.support,
  { rw [eval, eval₂, sum] at dvd_eval,
    rw [←finset.insert_erase hi, finset.sum_insert (finset.not_mem_erase _ _)] at dvd_eval,
    refine (dvd_add_left _).mp dvd_eval,
    apply finset.dvd_sum,
    intros j hj,
    exact dvd_terms j (finset.ne_of_mem_erase hj) },
  { convert dvd_zero p,
    rw not_mem_support_iff at hi,
    simp [hi] }
end

lemma dvd_term_of_is_root_of_dvd_terms {r p : S} {f : S[X]} (i : ℕ)
  (hr : f.is_root r) (h : ∀ (j ≠ i), p ∣ f.coeff j * r ^ j) : p ∣ f.coeff i * r ^ i :=
dvd_term_of_dvd_eval_of_dvd_terms i (eq.symm hr ▸ dvd_zero p) h

end comm_ring

end aeval

section ring
variables [ring R]

/--
The evaluation map is not generally multiplicative when the coefficient ring is noncommutative,
but nevertheless any polynomial of the form `p * (X - monomial 0 r)` is sent to zero
when evaluated at `r`.

This is the key step in our proof of the Cayley-Hamilton theorem.
-/
lemma eval_mul_X_sub_C {p : R[X]} (r : R) :
  (p * (X - C r)).eval r = 0 :=
begin
  simp only [eval, eval₂, ring_hom.id_apply],
  have bound := calc
    (p * (X - C r)).nat_degree
         ≤ p.nat_degree + (X - C r).nat_degree : nat_degree_mul_le
     ... ≤ p.nat_degree + 1 : add_le_add_left nat_degree_X_sub_C_le _
     ... < p.nat_degree + 2 : lt_add_one _,
  rw sum_over_range' _ _ (p.nat_degree + 2) bound,
  swap,
  { simp, },
  rw sum_range_succ',
  conv_lhs
  { congr, apply_congr, skip,
    rw [coeff_mul_X_sub_C, sub_mul, mul_assoc, ←pow_succ], },
  simp [sum_range_sub', coeff_monomial],
end

theorem not_is_unit_X_sub_C [nontrivial R] (r : R) : ¬ is_unit (X - C r) :=
λ ⟨⟨_, g, hfg, hgf⟩, rfl⟩, @zero_ne_one R _ _ $ by erw [← eval_mul_X_sub_C, hgf, eval_one]

end ring

lemma aeval_endomorphism {M : Type*}
  [comm_ring R] [add_comm_group M] [module R M]
  (f : M →ₗ[R] M) (v : M) (p : R[X]) :
  aeval f p v = p.sum (λ n b, b • (f ^ n) v) :=
begin
  rw [aeval_def, eval₂],
  exact (linear_map.applyₗ v).map_sum,
end

end polynomial


/-
Copyright (c) 2022 Kevin H. Wilson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin H. Wilson
-/
import measure_theory.integral.interval_integral
import algebra.order.floor
import data.set.function
import analysis.special_functions.integrals

/-!
# Comparing sums and integrals

## Summary

It is often the case that error terms in analysis can be computed by comparing
an infinite sum to the improper integral of an antitone function. This file will eventually enable
that.

At the moment it contains four lemmas in this direction: `antitone_on.integral_le_sum`,
`antitone_on.sum_le_integral` and versions for monotone functions, which can all be paired
with a `filter.tendsto` to estimate some errors.

`TODO`: Add more lemmas to the API to directly address limiting issues

## Main Results

* `antitone_on.integral_le_sum`: The integral of an antitone function is at most the sum of its
  values at integer steps aligning with the left-hand side of the interval
* `antitone_on.sum_le_integral`: The sum of an antitone function along integer steps aligning with
  the right-hand side of the interval is at most the integral of the function along that interval
* `monotone_on.integral_le_sum`: The integral of a monotone function is at most the sum of its
  values at integer steps aligning with the right-hand side of the interval
* `monotone_on.sum_le_integral`: The sum of a monotone function along integer steps aligning with
  the left-hand side of the interval is at most the integral of the function along that interval

## Tags

analysis, comparison, asymptotics
-/

open set measure_theory.measure_space
open_locale big_operators

variables {x₀ : ℝ} {a b : ℕ} {f : ℝ → ℝ}

lemma antitone_on.integral_le_sum (hf : antitone_on f (Icc x₀ (x₀ + a))) :
  ∫ x in x₀..(x₀ + a), f x ≤ ∑ i in finset.range a, f (x₀ + i) :=
begin
  have hint : ∀ (k : ℕ), k < a → interval_integrable f volume (x₀+k) (x₀ + (k + 1 : ℕ)),
  { assume k hk,
    refine (hf.mono _).interval_integrable,
    rw interval_of_le,
    { apply Icc_subset_Icc,
      { simp only [le_add_iff_nonneg_right, nat.cast_nonneg] },
      { simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt hk] } },
    { simp only [add_le_add_iff_left, nat.cast_le, nat.le_succ] } },
  calc
  ∫ x in x₀..(x₀ + a), f x = ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1 : ℕ)), f x :
    begin
      convert (interval_integral.sum_integral_adjacent_intervals hint).symm,
      simp only [nat.cast_zero, add_zero],
    end
  ... ≤ ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1 : ℕ)), f (x₀ + i) :
    begin
      apply finset.sum_le_sum (λ i hi, _),
      have ia : i < a := finset.mem_range.1 hi,
      refine interval_integral.integral_mono_on (by simp) (hint _ ia) (by simp) (λ x hx, _),
      apply hf _ _ hx.1,
      { simp only [ia.le, mem_Icc, le_add_iff_nonneg_right, nat.cast_nonneg, add_le_add_iff_left,
          nat.cast_le, and_self] },
      { refine mem_Icc.2 ⟨le_trans (by simp) hx.1, le_trans hx.2 _⟩,
        simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt ia] },
    end
  ... = ∑ i in finset.range a, f (x₀ + i) : by simp
end

lemma antitone_on.integral_le_sum_Ico (hab : a ≤ b) (hf : antitone_on f (set.Icc a b)) :
  ∫ x in a..b, f x ≤ ∑ x in finset.Ico a b, f x :=
begin
  rw [(nat.sub_add_cancel hab).symm, nat.cast_add],
  conv { congr, congr, skip, skip, rw add_comm, skip, skip, congr, congr, rw ←zero_add a, },
  rw [← finset.sum_Ico_add, nat.Ico_zero_eq_range],
  conv { to_rhs, congr, skip, funext, rw nat.cast_add, },
  apply antitone_on.integral_le_sum,
  simp only [hf, hab, nat.cast_sub, add_sub_cancel'_right],
end

lemma antitone_on.sum_le_integral (hf : antitone_on f (Icc x₀ (x₀ + a))) :
  ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ)) ≤ ∫ x in x₀..(x₀ + a), f x :=
begin
  have hint : ∀ (k : ℕ), k < a → interval_integrable f volume (x₀+k) (x₀ + (k + 1 : ℕ)),
  { assume k hk,
    refine (hf.mono _).interval_integrable,
    rw interval_of_le,
    { apply Icc_subset_Icc,
      { simp only [le_add_iff_nonneg_right, nat.cast_nonneg] },
      { simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt hk] } },
    { simp only [add_le_add_iff_left, nat.cast_le, nat.le_succ] } },
  calc ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ))
      = ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1:ℕ)), f (x₀ + (i + 1 : ℕ)) : by simp
  ... ≤ ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1:ℕ)), f x :
    begin
      apply finset.sum_le_sum (λ i hi, _),
      have ia : i + 1 ≤ a := finset.mem_range.1 hi,
      refine interval_integral.integral_mono_on (by simp) (by simp) (hint _ ia) (λ x hx, _),
      apply hf _ _ hx.2,
      { refine mem_Icc.2 ⟨le_trans ((le_add_iff_nonneg_right _).2 (nat.cast_nonneg _)) hx.1,
          le_trans hx.2 _⟩,
        simp only [nat.cast_le, add_le_add_iff_left, ia] },
      { refine mem_Icc.2 ⟨(le_add_iff_nonneg_right _).2 (nat.cast_nonneg _), _⟩,
        simp only [add_le_add_iff_left, nat.cast_le, ia] },
    end
  ... = ∫ x in x₀..(x₀ + a), f x :
    begin
      convert interval_integral.sum_integral_adjacent_intervals hint,
      simp only [nat.cast_zero, add_zero],
    end
end

lemma antitone_on.sum_le_integral_Ico (hab : a ≤ b) (hf : antitone_on f (set.Icc a b)) :
  ∑ i in finset.Ico a b, f (i + 1 : ℕ) ≤ ∫ x in a..b, f x :=
begin
  rw [(nat.sub_add_cancel hab).symm, nat.cast_add],
  conv { congr, congr, congr, rw ← zero_add a, skip, skip, skip, rw add_comm, },
  rw [← finset.sum_Ico_add, nat.Ico_zero_eq_range],
  conv { to_lhs, congr, congr, skip, funext, rw [add_assoc, nat.cast_add], },
  apply antitone_on.sum_le_integral,
  simp only [hf, hab, nat.cast_sub, add_sub_cancel'_right],
end

lemma monotone_on.sum_le_integral (hf : monotone_on f (Icc x₀ (x₀ + a))) :
  ∑ i in finset.range a, f (x₀ + i) ≤ ∫ x in x₀..(x₀ + a), f x :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.integral_le_sum,
end

lemma monotone_on.sum_le_integral_Ico (hab : a ≤ b) (hf : monotone_on f (set.Icc a b)) :
  ∑ x in finset.Ico a b, f x ≤ ∫ x in a..b, f x :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.integral_le_sum_Ico hab,
end

lemma monotone_on.integral_le_sum (hf : monotone_on f (Icc x₀ (x₀ + a))) :
  ∫ x in x₀..(x₀ + a), f x ≤ ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ)) :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.sum_le_integral,
end

lemma monotone_on.integral_le_sum_Ico (hab : a ≤ b) (hf : monotone_on f (set.Icc a b)) :
  ∫ x in a..b, f x ≤ ∑ i in finset.Ico a b, f (i + 1 : ℕ) :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.sum_le_integral_Ico hab,
end