/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module data.stream.init
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Std.Tactic.Ext
import Mathlib.Data.Stream.Defs
import Mathlib.Logic.Function.Basic
import Mathlib.Init.Data.List.Basic
import Mathlib.Data.List.Basic

/-!
# Streams a.k.a. infinite lists a.k.a. infinite sequences

Porting note:
This file used to be in the core library. It was moved to `mathlib` and renamed to `init` to avoid
name clashes.  -/

open Nat Function Option

universe u v w

namespace Stream'

variable {α : Type u} {β : Type v} {δ : Type w}

instance {α} [Inhabited α] : Inhabited (Stream' α) :=
  ⟨Stream'.const default⟩

protected theorem eta (s : Stream' α) : (head s::tail s) = s :=
  funext fun i => by cases i <;> rfl
#align stream.eta Stream'.eta

@[simp]
theorem nth_zero_cons (a : α) (s : Stream' α) : nth (a::s) 0 = a :=
  rfl
#align stream.nth_zero_cons Stream'.nth_zero_cons

theorem head_cons (a : α) (s : Stream' α) : head (a::s) = a :=
  rfl
#align stream.head_cons Stream'.head_cons

theorem tail_cons (a : α) (s : Stream' α) : tail (a::s) = s :=
  rfl
#align stream.tail_cons Stream'.tail_cons

theorem tail_drop (n : Nat) (s : Stream' α) : tail (drop n s) = drop n (tail s) :=
  funext fun i => by
    unfold tail drop; simp [nth, Nat.add_comm, Nat.add_left_comm, Nat.add_assoc]
#align stream.tail_drop Stream'.tail_drop

theorem nth_drop (n m : Nat) (s : Stream' α) : nth (drop m s) n = nth s (n + m) :=
  rfl
#align stream.nth_drop Stream'.nth_drop

theorem tail_eq_drop (s : Stream' α) : tail s = drop 1 s :=
  rfl
#align stream.tail_eq_drop Stream'.tail_eq_drop

theorem drop_drop (n m : Nat) (s : Stream' α) : drop n (drop m s) = drop (n + m) s :=
  funext fun i => by unfold drop; rw [Nat.add_assoc]
#align stream.drop_drop Stream'.drop_drop

theorem nth_succ (n : Nat) (s : Stream' α) : nth s (succ n) = nth (tail s) n :=
  rfl
#align stream.nth_succ Stream'.nth_succ

@[simp]
theorem nth_succ_cons (n : Nat) (s : Stream' α) (x : α) : nth (x::s) n.succ = nth s n :=
  rfl
#align stream.nth_succ_cons Stream'.nth_succ_cons

theorem drop_succ (n : Nat) (s : Stream' α) : drop (succ n) s = drop n (tail s) :=
  rfl
#align stream.drop_succ Stream'.drop_succ

@[simp]
theorem head_drop {α} (a : Stream' α) (n : ℕ) : (a.drop n).head = a.nth n := by
  simp only [drop, head, Nat.zero_add, Stream'.nth]
#align stream.head_drop Stream'.head_drop

@[ext]
protected theorem ext {s₁ s₂ : Stream' α} : (∀ n, nth s₁ n = nth s₂ n) → s₁ = s₂ :=
  fun h => funext h
#align stream.ext Stream'.ext

theorem cons_injective2 : Function.Injective2 (cons : α → Stream' α → Stream' α) := fun x y s t h =>
  ⟨by rw [← nth_zero_cons x s, h, nth_zero_cons],
    Stream'.ext fun n => by rw [← nth_succ_cons n _ x, h, nth_succ_cons]⟩
#align stream.cons_injective2 Stream'.cons_injective2

theorem cons_injective_left (s : Stream' α) : Function.Injective fun x => cons x s :=
  cons_injective2.left _
#align stream.cons_injective_left Stream'.cons_injective_left

theorem cons_injective_right (x : α) : Function.Injective (cons x) :=
  cons_injective2.right _
#align stream.cons_injective_right Stream'.cons_injective_right

theorem all_def (p : α → Prop) (s : Stream' α) : All p s = ∀ n, p (nth s n) :=
  rfl
#align stream.all_def Stream'.all_def

theorem any_def (p : α → Prop) (s : Stream' α) : Any p s = ∃ n, p (nth s n) :=
  rfl
#align stream.any_def Stream'.any_def

theorem mem_cons (a : α) (s : Stream' α) : a ∈ a::s :=
  Exists.intro 0 rfl
#align stream.mem_cons Stream'.mem_cons

theorem mem_cons_of_mem {a : α} {s : Stream' α} (b : α) : a ∈ s → a ∈ b::s := fun ⟨n, h⟩ =>
  Exists.intro (succ n) (by rw [nth_succ, tail_cons, h])
#align stream.mem_cons_of_mem Stream'.mem_cons_of_mem

theorem eq_or_mem_of_mem_cons {a b : α} {s : Stream' α} : (a ∈ b::s) → a = b ∨ a ∈ s :=
    fun ⟨n, h⟩ => by
  cases' n with n'
  · left
    exact h
  · right
    rw [nth_succ, tail_cons] at h
    exact ⟨n', h⟩
#align stream.eq_or_mem_of_mem_cons Stream'.eq_or_mem_of_mem_cons

theorem mem_of_nth_eq {n : Nat} {s : Stream' α} {a : α} : a = nth s n → a ∈ s := fun h =>
  Exists.intro n h
#align stream.mem_of_nth_eq Stream'.mem_of_nth_eq

section Map

variable (f : α → β)

theorem drop_map (n : Nat) (s : Stream' α) : drop n (map f s) = map f (drop n s) :=
  Stream'.ext fun _ => rfl
#align stream.drop_map Stream'.drop_map

theorem nth_map (n : Nat) (s : Stream' α) : nth (map f s) n = f (nth s n) :=
  rfl
#align stream.nth_map Stream'.nth_map

theorem tail_map (s : Stream' α) : tail (map f s) = map f (tail s) := by rw [tail_eq_drop]; rfl
#align stream.tail_map Stream'.tail_map

theorem head_map (s : Stream' α) : head (map f s) = f (head s) :=
  rfl
#align stream.head_map Stream'.head_map

theorem map_eq (s : Stream' α) : map f s = f (head s)::map f (tail s) := by
  rw [← Stream'.eta (map f s), tail_map, head_map]
#align stream.map_eq Stream'.map_eq

theorem map_cons (a : α) (s : Stream' α) : map f (a::s) = f a::map f s := by
  rw [← Stream'.eta (map f (a::s)), map_eq]; rfl
#align stream.map_cons Stream'.map_cons

theorem map_id (s : Stream' α) : map id s = s :=
  rfl
#align stream.map_id Stream'.map_id

theorem map_map (g : β → δ) (f : α → β) (s : Stream' α) : map g (map f s) = map (g ∘ f) s :=
  rfl
#align stream.map_map Stream'.map_map

theorem map_tail (s : Stream' α) : map f (tail s) = tail (map f s) :=
  rfl
#align stream.map_tail Stream'.map_tail

theorem mem_map {a : α} {s : Stream' α} : a ∈ s → f a ∈ map f s := fun ⟨n, h⟩ =>
  Exists.intro n (by rw [nth_map, h])
#align stream.mem_map Stream'.mem_map

theorem exists_of_mem_map {f} {b : β} {s : Stream' α} : b ∈ map f s → ∃ a, a ∈ s ∧ f a = b :=
  fun ⟨n, h⟩ => ⟨nth s n, ⟨n, rfl⟩, h.symm⟩
#align stream.exists_of_mem_map Stream'.exists_of_mem_map

end Map

section Zip

variable (f : α → β → δ)

theorem drop_zip (n : Nat) (s₁ : Stream' α) (s₂ : Stream' β) :
    drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
  Stream'.ext fun _ => rfl
#align stream.drop_zip Stream'.drop_zip

theorem nth_zip (n : Nat) (s₁ : Stream' α) (s₂ : Stream' β) :
    nth (zip f s₁ s₂) n = f (nth s₁ n) (nth s₂ n) :=
  rfl
#align stream.nth_zip Stream'.nth_zip

theorem head_zip (s₁ : Stream' α) (s₂ : Stream' β) : head (zip f s₁ s₂) = f (head s₁) (head s₂) :=
  rfl
#align stream.head_zip Stream'.head_zip

theorem tail_zip (s₁ : Stream' α) (s₂ : Stream' β) :
    tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) :=
  rfl
#align stream.tail_zip Stream'.tail_zip

theorem zip_eq (s₁ : Stream' α) (s₂ : Stream' β) :
    zip f s₁ s₂ = f (head s₁) (head s₂)::zip f (tail s₁) (tail s₂) := by
  rw [← Stream'.eta (zip f s₁ s₂)]; rfl
#align stream.zip_eq Stream'.zip_eq

@[simp]
theorem nth_enum (s : Stream' α) (n : ℕ) : nth (enum s) n = (n, s.nth n) :=
  rfl
#align stream.nth_enum Stream'.nth_enum

theorem enum_eq_zip (s : Stream' α) : enum s = zip Prod.mk nats s :=
  rfl
#align stream.enum_eq_zip Stream'.enum_eq_zip

end Zip

theorem mem_const (a : α) : a ∈ const a :=
  Exists.intro 0 rfl
#align stream.mem_const Stream'.mem_const

theorem const_eq (a : α) : const a = a::const a := by
  apply Stream'.ext; intro n
  cases n <;> rfl
#align stream.const_eq Stream'.const_eq

theorem tail_const (a : α) : tail (const a) = const a :=
  suffices tail (a::const a) = const a by rwa [← const_eq] at this
  rfl
#align stream.tail_const Stream'.tail_const

theorem map_const (f : α → β) (a : α) : map f (const a) = const (f a) :=
  rfl
#align stream.map_const Stream'.map_const

theorem nth_const (n : Nat) (a : α) : nth (const a) n = a :=
  rfl
#align stream.nth_const Stream'.nth_const

theorem drop_const (n : Nat) (a : α) : drop n (const a) = const a :=
  Stream'.ext fun _ => rfl
#align stream.drop_const Stream'.drop_const

theorem head_iterate (f : α → α) (a : α) : head (iterate f a) = a :=
  rfl
#align stream.head_iterate Stream'.head_iterate

theorem tail_iterate (f : α → α) (a : α) : tail (iterate f a) = iterate f (f a) := by
  funext n
  induction' n with n' ih
  · rfl
  · unfold tail iterate
    rw [Nat.add, Nat.add_zero (succ n')]
    rw [tail, iterate] at ih
    rw [iterate]
    congr
#align stream.tail_iterate Stream'.tail_iterate

theorem iterate_eq (f : α → α) (a : α) : iterate f a = a::iterate f (f a) := by
  rw [← Stream'.eta (iterate f a)]
  rw [tail_iterate]; rfl
#align stream.iterate_eq Stream'.iterate_eq

theorem nth_zero_iterate (f : α → α) (a : α) : nth (iterate f a) 0 = a :=
  rfl
#align stream.nth_zero_iterate Stream'.nth_zero_iterate

theorem nth_succ_iterate (n : Nat) (f : α → α) (a : α) :
    nth (iterate f a) (succ n) = nth (iterate f (f a)) n := by rw [nth_succ, tail_iterate]
#align stream.nth_succ_iterate Stream'.nth_succ_iterate

section Bisim

variable (R : Stream' α → Stream' α → Prop)

/-- equivalence relation -/
local infixl:50 " ~ " => R

/-- Streams `s₁` and `s₂` are defined to be bisimulations if
their heads are equal and tails are bisimulations. -/
def IsBisimulation :=
  ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ →
      head s₁ = head s₂ ∧ tail s₁ ~ tail s₂
#align stream.is_bisimulation Stream'.IsBisimulation

theorem nth_of_bisim (bisim : IsBisimulation R) :
    ∀ {s₁ s₂} (n), s₁ ~ s₂ → nth s₁ n = nth s₂ n ∧ drop (n + 1) s₁ ~ drop (n + 1) s₂
  | _, _, 0, h => bisim h
  | _, _, n + 1, h =>
    match bisim h with
    | ⟨_, trel⟩ => nth_of_bisim bisim n trel
#align stream.nth_of_bisim Stream'.nth_of_bisim

-- If two streams are bisimilar, then they are equal
theorem eq_of_bisim (bisim : IsBisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ := fun  r =>
  Stream'.ext fun n => And.left (nth_of_bisim R bisim n r)
#align stream.eq_of_bisim Stream'.eq_of_bisim

end Bisim

theorem bisim_simple (s₁ s₂ : Stream' α) :
    head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ := fun hh ht₁ ht₂ =>
  eq_of_bisim (fun s₁ s₂ => head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂)
    (fun s₁ s₂ ⟨h₁, h₂, h₃⟩ => by
      constructor; exact h₁; rw [← h₂, ← h₃];
      (repeat' constructor) <;> assumption)
    (And.intro hh (And.intro ht₁ ht₂))
#align stream.bisim_simple Stream'.bisim_simple

theorem coinduction {s₁ s₂ : Stream' α} :
    head s₁ = head s₂ →
      (∀ (β : Type u) (fr : Stream' α → β),
      fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
  fun hh ht =>
  eq_of_bisim
    (fun s₁ s₂ =>
      head s₁ = head s₂ ∧
        ∀ (β : Type u) (fr : Stream' α → β), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂))
    (fun s₁ s₂ h =>
      have h₁ : head s₁ = head s₂ := And.left h
      have h₂ : head (tail s₁) = head (tail s₂) := And.right h α (@head α) h₁
      have h₃ :
        ∀ (β : Type u) (fr : Stream' α → β),
          fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)) :=
        fun β fr => And.right h β fun s => fr (tail s)
      And.intro h₁ (And.intro h₂ h₃))
    (And.intro hh ht)
#align stream.coinduction Stream'.coinduction

theorem iterate_id (a : α) : iterate id a = const a :=
  coinduction rfl fun β fr ch => by rw [tail_iterate, tail_const]; exact ch
#align stream.iterate_id Stream'.iterate_id

theorem map_iterate (f : α → α) (a : α) : iterate f (f a) = map f (iterate f a) := by
  funext n
  induction' n with n' ih
  · rfl
  · unfold map iterate nth
    dsimp
    rw [map, nth] at ih
    rw [iterate]
    exact congrArg f ih
#align stream.map_iterate Stream'.map_iterate

section Corec

theorem corec_def (f : α → β) (g : α → α) (a : α) : corec f g a = map f (iterate g a) :=
  rfl
#align stream.corec_def Stream'.corec_def

theorem corec_eq (f : α → β) (g : α → α) (a : α) : corec f g a = f a::corec f g (g a) := by
  rw [corec_def, map_eq, head_iterate, tail_iterate]; rfl
#align stream.corec_eq Stream'.corec_eq

theorem corec_id_id_eq_const (a : α) : corec id id a = const a := by
  rw [corec_def, map_id, iterate_id]
#align stream.corec_id_id_eq_const Stream'.corec_id_id_eq_const

theorem corec_id_f_eq_iterate (f : α → α) (a : α) : corec id f a = iterate f a :=
  rfl
#align stream.corec_id_f_eq_iterate Stream'.corec_id_f_eq_iterate

end Corec

section Corec'

theorem corec'_eq (f : α → β × α) (a : α) : corec' f a = (f a).1::corec' f (f a).2 :=
  corec_eq _ _ _
#align stream.corec'_eq Stream'.corec'_eq

end Corec'

theorem unfolds_eq (g : α → β) (f : α → α) (a : α) : unfolds g f a = g a::unfolds g f (f a) := by
  unfold unfolds; rw [corec_eq]
#align stream.unfolds_eq Stream'.unfolds_eq

theorem nth_unfolds_head_tail : ∀ (n : Nat) (s : Stream' α),
    nth (unfolds head tail s) n = nth s n := by
  intro n; induction' n with n' ih
  · intro s
    rfl
  · intro s
    rw [nth_succ, nth_succ, unfolds_eq, tail_cons, ih]
#align stream.nth_unfolds_head_tail Stream'.nth_unfolds_head_tail

theorem unfolds_head_eq : ∀ s : Stream' α, unfolds head tail s = s := fun s =>
  Stream'.ext fun n => nth_unfolds_head_tail n s
#align stream.unfolds_head_eq Stream'.unfolds_head_eq

theorem interleave_eq (s₁ s₂ : Stream' α) : s₁ ⋈ s₂ = head s₁::head s₂::(tail s₁ ⋈ tail s₂) := by
  let t := tail s₁ ⋈ tail s₂
  show s₁ ⋈ s₂ = head s₁::head s₂::t
  unfold interleave; unfold corecOn; rw [corec_eq]; dsimp; rw [corec_eq]; rfl
#align stream.interleave_eq Stream'.interleave_eq

theorem tail_interleave (s₁ s₂ : Stream' α) : tail (s₁ ⋈ s₂) = s₂ ⋈ tail s₁ := by
  unfold interleave corecOn; rw [corec_eq]; rfl
#align stream.tail_interleave Stream'.tail_interleave

theorem interleave_tail_tail (s₁ s₂ : Stream' α) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) := by
  rw [interleave_eq s₁ s₂]; rfl
#align stream.interleave_tail_tail Stream'.interleave_tail_tail

theorem nth_interleave_left : ∀ (n : Nat) (s₁ s₂ : Stream' α),
    nth (s₁ ⋈ s₂) (2 * n) = nth s₁ n
  | 0, s₁, s₂ => rfl
  | n + 1, s₁, s₂ => by
    change nth (s₁ ⋈ s₂) (succ (succ (2 * n))) = nth s₁ (succ n)
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons]
    have : n < succ n := Nat.lt_succ_self n
    rw [nth_interleave_left n (tail s₁) (tail s₂)]
    rfl
#align stream.nth_interleave_left Stream'.nth_interleave_left

theorem nth_interleave_right : ∀ (n : Nat) (s₁ s₂ : Stream' α),
    nth (s₁ ⋈ s₂) (2 * n + 1) = nth s₂ n
  | 0, s₁, s₂ => rfl
  | n + 1, s₁, s₂ => by
    change nth (s₁ ⋈ s₂) (succ (succ (2 * n + 1))) = nth s₂ (succ n)
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons,
      nth_interleave_right n (tail s₁) (tail s₂)]
    rfl
#align stream.nth_interleave_right Stream'.nth_interleave_right

theorem mem_interleave_left {a : α} {s₁ : Stream' α} (s₂ : Stream' α) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ :=
  fun ⟨n, h⟩ => Exists.intro (2 * n) (by rw [h, nth_interleave_left])
#align stream.mem_interleave_left Stream'.mem_interleave_left

theorem mem_interleave_right {a : α} {s₁ : Stream' α} (s₂ : Stream' α) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ :=
  fun ⟨n, h⟩ => Exists.intro (2 * n + 1) (by rw [h, nth_interleave_right])
#align stream.mem_interleave_right Stream'.mem_interleave_right

theorem odd_eq (s : Stream' α) : odd s = even (tail s) :=
  rfl
#align stream.odd_eq Stream'.odd_eq

theorem head_even (s : Stream' α) : head (even s) = head s :=
  rfl
#align stream.head_even Stream'.head_even

theorem tail_even (s : Stream' α) : tail (even s) = even (tail (tail s)) := by
  unfold even;
  rw [corec_eq];
  rfl

#align stream.tail_even Stream'.tail_even

theorem even_cons_cons (a₁ a₂ : α) (s : Stream' α) : even (a₁::a₂::s) = a₁::even s := by
  unfold even;
  rw [corec_eq]; rfl
#align stream.even_cons_cons Stream'.even_cons_cons

theorem even_tail (s : Stream' α) : even (tail s) = odd s :=
  rfl
#align stream.even_tail Stream'.even_tail

theorem even_interleave (s₁ s₂ : Stream' α) : even (s₁ ⋈ s₂) = s₁ :=
  eq_of_bisim (fun s₁' s₁ => ∃ s₂, s₁' = even (s₁ ⋈ s₂))
    (fun s₁' s₁ ⟨s₂, h₁⟩ => by
      rw [h₁]
      constructor
      · rfl
      · exact ⟨tail s₂, by rw [interleave_eq, even_cons_cons, tail_cons]⟩)
    (Exists.intro s₂ rfl)
#align stream.even_interleave Stream'.even_interleave

theorem interleave_even_odd (s₁ : Stream' α) : even s₁ ⋈ odd s₁ = s₁ :=
  eq_of_bisim (fun s' s => s' = even s ⋈ odd s)
    (fun s' s (h : s' = even s ⋈ odd s) => by
      rw [h]; constructor
      · rfl
      · simp [odd_eq, odd_eq, tail_interleave, tail_even])
    rfl
#align stream.interleave_even_odd Stream'.interleave_even_odd

theorem nth_even : ∀ (n : Nat) (s : Stream' α), nth (even s) n = nth s (2 * n)
  | 0, s => rfl
  | succ n, s => by
    change nth (even s) (succ n) = nth s (succ (succ (2 * n)))
    rw [nth_succ, nth_succ, tail_even, nth_even n]; rfl

#align stream.nth_even Stream'.nth_even

theorem nth_odd : ∀ (n : Nat) (s : Stream' α), nth (odd s) n = nth s (2 * n + 1) := fun n s => by
  rw [odd_eq, nth_even]; rfl
#align stream.nth_odd Stream'.nth_odd

theorem mem_of_mem_even (a : α) (s : Stream' α) : a ∈ even s → a ∈ s := fun ⟨n, h⟩ =>
  Exists.intro (2 * n) (by rw [h, nth_even])
#align stream.mem_of_mem_even Stream'.mem_of_mem_even

theorem mem_of_mem_odd (a : α) (s : Stream' α) : a ∈ odd s → a ∈ s := fun ⟨n, h⟩ =>
  Exists.intro (2 * n + 1) (by rw [h, nth_odd])
#align stream.mem_of_mem_odd Stream'.mem_of_mem_odd

theorem nil_append_stream (s : Stream' α) : appendStream' [] s = s :=
  rfl
#align stream.nil_append_stream Stream'.nil_append_stream

theorem cons_append_stream (a : α) (l : List α) (s : Stream' α) :
    appendStream' (a::l) s = a::appendStream' l s :=
  rfl
#align stream.cons_append_stream Stream'.cons_append_stream

theorem append_append_stream : ∀ (l₁ l₂ : List α) (s : Stream' α),
    l₁ ++ l₂ ++ₛ s = l₁ ++ₛ (l₂ ++ₛ s)
  | [], l₂, s => rfl
  | List.cons a l₁, l₂, s => by
    rw [List.cons_append, cons_append_stream, cons_append_stream, append_append_stream l₁]

#align stream.append_append_stream Stream'.append_append_stream

theorem map_append_stream (f : α → β) :
    ∀ (l : List α) (s : Stream' α), map f (l ++ₛ s) = List.map f l ++ₛ map f s
  | [], s => rfl
  | List.cons a l, s => by
    rw [cons_append_stream, List.map_cons, map_cons, cons_append_stream, map_append_stream f l]
#align stream.map_append_stream Stream'.map_append_stream

theorem drop_append_stream : ∀ (l : List α) (s : Stream' α), drop l.length (l ++ₛ s) = s
  | [], s => by rfl
  | List.cons a l, s => by
    rw [List.length_cons, drop_succ, cons_append_stream, tail_cons, drop_append_stream l s]
#align stream.drop_append_stream Stream'.drop_append_stream

theorem append_stream_head_tail (s : Stream' α) : [head s] ++ₛ tail s = s := by
  rw [cons_append_stream, nil_append_stream, Stream'.eta]
#align stream.append_stream_head_tail Stream'.append_stream_head_tail

theorem mem_append_stream_right : ∀ {a : α} (l : List α) {s : Stream' α}, a ∈ s → a ∈ l ++ₛ s
  | _, [], _, h => h
  | a, List.cons _ l, s, h =>
    have ih : a ∈ l ++ₛ s := mem_append_stream_right l h
    mem_cons_of_mem _ ih
#align stream.mem_append_stream_right Stream'.mem_append_stream_right

theorem mem_append_stream_left : ∀ {a : α} {l : List α} (s : Stream' α), a ∈ l → a ∈ l ++ₛ s
  | _, [], _, h => absurd h (List.not_mem_nil _)
  | a, List.cons b l, s, h =>
    Or.elim (List.eq_or_mem_of_mem_cons h) (fun aeqb : a = b => Exists.intro 0 aeqb)
      fun ainl : a ∈ l => mem_cons_of_mem b (mem_append_stream_left s ainl)
#align stream.mem_append_stream_left Stream'.mem_append_stream_left

@[simp]
theorem take_zero (s : Stream' α) : take 0 s = [] :=
  rfl
#align stream.take_zero Stream'.take_zero

@[simp]
theorem take_succ (n : Nat) (s : Stream' α) : take (succ n) s = head s::take n (tail s) :=
  rfl
#align stream.take_succ Stream'.take_succ

@[simp]
theorem length_take (n : ℕ) (s : Stream' α) : (take n s).length = n := by
  induction n generalizing s <;> simp [*]
#align stream.length_take Stream'.length_take

theorem get?_take_succ : ∀ (n : Nat) (s : Stream' α),
    List.get? (take (succ n) s) n = some (nth s n)
  | 0, s => rfl
  | n + 1, s => by
    rw [take_succ, add_one, List.get?, get?_take_succ n]; rfl
#align stream.nth_take_succ Stream'.get?_take_succ

theorem append_take_drop : ∀ (n : Nat) (s : Stream' α),
    appendStream' (take n s) (drop n s) = s := by
  intro n
  induction' n with n' ih
  · intro s
    rfl
  · intro s
    rw [take_succ, drop_succ, cons_append_stream, ih (tail s), Stream'.eta]
#align stream.append_take_drop Stream'.append_take_drop

-- Take theorem reduces a proof of equality of infinite streams to an
-- induction over all their finite approximations.
theorem take_theorem (s₁ s₂ : Stream' α) : (∀ n : Nat, take n s₁ = take n s₂) → s₁ = s₂ := by
  intro h; apply Stream'.ext; intro n
  induction' n with n _
  · have aux := h 1
    simp [take] at aux
    exact aux
  · have h₁ : some (nth s₁ (succ n)) = some (nth s₂ (succ n)) := by
      rw [← get?_take_succ, ← get?_take_succ, h (succ (succ n))]
    injection h₁
#align stream.take_theorem Stream'.take_theorem

protected theorem cycle_g_cons (a : α) (a₁ : α) (l₁ : List α) (a₀ : α) (l₀ : List α) :
    Stream'.cycleG (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) :=
  rfl
#align stream.cycle_g_cons Stream'.cycle_g_cons

theorem cycle_eq : ∀ (l : List α) (h : l ≠ []), cycle l h = l ++ₛ cycle l h
  | [], h => absurd rfl h
  | List.cons a l, _ =>
    have gen :
      ∀ l' a',
        corec Stream'.cycleF Stream'.cycleG (a', l', a, l) =
          (a'::l') ++ₛ corec Stream'.cycleF Stream'.cycleG (a, l, a, l) :=
      by
      intro l'
      induction' l' with a₁ l₁ ih
      · intros
        rw [corec_eq]
        rfl
      · intros
        rw [corec_eq, Stream'.cycle_g_cons, ih a₁]
        rfl
    gen l a
#align stream.cycle_eq Stream'.cycle_eq

theorem mem_cycle {a : α} {l : List α} : ∀ h : l ≠ [], a ∈ l → a ∈ cycle l h := fun h ainl => by
  rw [cycle_eq]; exact mem_append_stream_left _ ainl
#align stream.mem_cycle Stream'.mem_cycle

theorem cycle_singleton (a : α) (h : [a] ≠ []) : cycle [a] h = const a :=
  coinduction rfl fun β fr ch => by rwa [cycle_eq, const_eq]
#align stream.cycle_singleton Stream'.cycle_singleton

theorem tails_eq (s : Stream' α) : tails s = tail s::tails (tail s) := by
  unfold tails ; rw [corec_eq] ; rfl
#align stream.tails_eq Stream'.tails_eq

theorem nth_tails : ∀ (n : Nat) (s : Stream' α), nth (tails s) n = drop n (tail s) := by
  intro n; induction' n with n' ih
  · intros
    rfl
  · intro s
    rw [nth_succ, drop_succ, tails_eq, tail_cons, ih]
#align stream.nth_tails Stream'.nth_tails

theorem tails_eq_iterate (s : Stream' α) : tails s = iterate tail (tail s) :=
  rfl
#align stream.tails_eq_iterate Stream'.tails_eq_iterate

theorem inits_core_eq (l : List α) (s : Stream' α) :
    initsCore l s = l::initsCore (l ++ [head s]) (tail s) := by
    unfold initsCore corecOn;
    rw [corec_eq]
#align stream.inits_core_eq Stream'.inits_core_eq

theorem tail_inits (s : Stream' α) :
    tail (inits s) = initsCore [head s, head (tail s)] (tail (tail s)) := by
    unfold inits;
    rw [inits_core_eq]; rfl
#align stream.tail_inits Stream'.tail_inits

theorem inits_tail (s : Stream' α) : inits (tail s) = initsCore [head (tail s)] (tail (tail s)) :=
  rfl
#align stream.inits_tail Stream'.inits_tail

theorem cons_nth_inits_core :
    ∀ (a : α) (n : Nat) (l : List α) (s : Stream' α),
      (a::nth (initsCore l s) n) = nth (initsCore (a::l) s) n := by
  intro a n
  induction' n with n' ih
  · intros
    rfl
  · intro l s
    rw [nth_succ, inits_core_eq, tail_cons, ih, inits_core_eq (a::l) s]
    rfl
#align stream.cons_nth_inits_core Stream'.cons_nth_inits_core

theorem nth_inits : ∀ (n : Nat) (s : Stream' α), nth (inits s) n = take (succ n) s := by
  intro n; induction' n with n' ih
  · intros
    rfl
  · intros
    rw [nth_succ, take_succ, ← ih, tail_inits, inits_tail, cons_nth_inits_core]
#align stream.nth_inits Stream'.nth_inits

theorem inits_eq (s : Stream' α) :
    inits s = [head s]::map (List.cons (head s)) (inits (tail s)) := by
  apply Stream'.ext; intro n
  cases n
  · rfl
  · rw [nth_inits, nth_succ, tail_cons, nth_map, nth_inits]
    rfl
#align stream.inits_eq Stream'.inits_eq

theorem zip_inits_tails (s : Stream' α) : zip appendStream' (inits s) (tails s) = const s := by
  apply Stream'.ext; intro n
  rw [nth_zip, nth_inits, nth_tails, nth_const, take_succ, cons_append_stream, append_take_drop,
    Stream'.eta]
#align stream.zip_inits_tails Stream'.zip_inits_tails

theorem identity (s : Stream' α) : pure id ⊛ s = s :=
  rfl
#align stream.identity Stream'.identity

theorem composition (g : Stream' (β → δ)) (f : Stream' (α → β)) (s : Stream' α) :
    pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) :=
  rfl
#align stream.composition Stream'.composition

theorem homomorphism (f : α → β) (a : α) : pure f ⊛ pure a = pure (f a) :=
  rfl
#align stream.homomorphism Stream'.homomorphism

theorem interchange (fs : Stream' (α → β)) (a : α) :
    fs ⊛ pure a = (pure fun f : α → β => f a) ⊛ fs :=
  rfl
#align stream.interchange Stream'.interchange

theorem map_eq_apply (f : α → β) (s : Stream' α) : map f s = pure f ⊛ s :=
  rfl
#align stream.map_eq_apply Stream'.map_eq_apply

theorem nth_nats (n : Nat) : nth nats n = n :=
  rfl
#align stream.nth_nats Stream'.nth_nats

theorem nats_eq : nats = cons 0 (map succ nats) := by
  apply Stream'.ext; intro n
  cases n; rfl; rw [nth_succ]; rfl
#align stream.nats_eq Stream'.nats_eq

end Stream'


/-
Copyright (c) 2020 Scott Morrison, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.PostPort

universes u₁ u₂ v

namespace Mathlib

/-!
# Preserving products

Constructions to relate the notions of preserving products and reflecting products
to concrete fans.

In particular, we show that `pi_comparison G f` is an isomorphism iff `G` preserves
the limit of `f`.
-/

namespace category_theory.limits

/--
The map of a fan is a limit iff the fan consisting of the mapped morphisms is a limit. This
essentially lets us commute `fan.mk` with `functor.map_cone`.
-/
def is_limit_map_cone_fan_mk_equiv {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    {J : Type v} (f : J → C) {P : C} (g : (j : J) → P ⟶ f j) :
    is_limit (functor.map_cone G (fan.mk P g)) ≃
        is_limit (fan.mk (functor.obj G P) fun (j : J) => functor.map G (g j)) :=
  equiv.trans
    (equiv.symm
      (is_limit.postcompose_hom_equiv
        (discrete.nat_iso fun (j : discrete J) => iso.refl (functor.obj G (f j)))
        (functor.map_cone G (fan.mk P g))))
    (is_limit.equiv_iso_limit
      (cones.ext
        (iso.refl
          (cone.X
            (functor.obj
              (cones.postcompose
                (iso.hom (discrete.nat_iso fun (j : discrete J) => iso.refl (functor.obj G (f j)))))
              (functor.map_cone G (fan.mk P g)))))
        sorry))

/-- The property of preserving products expressed in terms of fans. -/
def is_limit_fan_mk_obj_of_is_limit {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} (f : J → C) [preserves_limit (discrete.functor f) G] {P : C}
    (g : (j : J) → P ⟶ f j) (t : is_limit (fan.mk P g)) :
    is_limit (fan.mk (functor.obj G P) fun (j : J) => functor.map G (g j)) :=
  coe_fn (is_limit_map_cone_fan_mk_equiv G (fun (j : J) => f j) g) (preserves_limit.preserves t)

/-- The property of reflecting products expressed in terms of fans. -/
def is_limit_of_is_limit_fan_mk_obj {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} (f : J → C) [reflects_limit (discrete.functor f) G] {P : C}
    (g : (j : J) → P ⟶ f j)
    (t : is_limit (fan.mk (functor.obj G P) fun (j : J) => functor.map G (g j))) :
    is_limit (fan.mk P g) :=
  reflects_limit.reflects
    (coe_fn (equiv.symm (is_limit_map_cone_fan_mk_equiv G (fun (j : J) => f j) fun (j : J) => g j))
      t)

/--
If `G` preserves products and `C` has them, then the fan constructed of the mapped projection of a
product is a limit.
-/
def is_limit_of_has_product_of_preserves_limit {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} (f : J → C) [has_product f] [preserves_limit (discrete.functor f) G] :
    is_limit (fan.mk (functor.obj G (∏ f)) fun (j : J) => functor.map G (pi.π f j)) :=
  is_limit_fan_mk_obj_of_is_limit G f (fun (j : J) => pi.π f j)
    (product_is_product fun (j : J) => f j)

/-- If `pi_comparison G f` is an isomorphism, then `G` preserves the limit of `f`. -/
def preserves_product.of_iso_comparison {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} (f : J → C) [has_product f]
    [has_product fun (j : J) => functor.obj G (f j)] [i : is_iso (pi_comparison G f)] :
    preserves_limit (discrete.functor f) G :=
  preserves_limit_of_preserves_limit_cone (product_is_product f)
    (coe_fn (equiv.symm (is_limit_map_cone_fan_mk_equiv G (fun (b : J) => f b) (pi.π f)))
      (is_limit.of_point_iso
        (limit.is_limit (discrete.functor fun (j : J) => functor.obj G (f j)))))

/--
If `G` preserves limits, we have an isomorphism from the image of a product to the product of the
images.
-/
def preserves_product.iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    {J : Type v} (f : J → C) [has_product f] [has_product fun (j : J) => functor.obj G (f j)]
    [preserves_limit (discrete.functor f) G] :
    functor.obj G (∏ f) ≅ ∏ fun (j : J) => functor.obj G (f j) :=
  is_limit.cone_point_unique_up_to_iso (is_limit_of_has_product_of_preserves_limit G f)
    (limit.is_limit (discrete.functor fun (j : J) => functor.obj G (f j)))

@[simp] theorem preserves_product.iso_hom {C : Type u₁} [category C] {D : Type u₂} [category D]
    (G : C ⥤ D) {J : Type v} (f : J → C) [has_product f]
    [has_product fun (j : J) => functor.obj G (f j)] [preserves_limit (discrete.functor f) G] :
    iso.hom (preserves_product.iso G f) = pi_comparison G f :=
  rfl

protected instance pi_comparison.category_theory.is_iso {C : Type u₁} [category C] {D : Type u₂}
    [category D] (G : C ⥤ D) {J : Type v} (f : J → C) [has_product f]
    [has_product fun (j : J) => functor.obj G (f j)] [preserves_limit (discrete.functor f) G] :
    is_iso (pi_comparison G f) :=
  eq.mpr sorry (is_iso.of_iso (preserves_product.iso G f))

end Mathlib


import Lean.Meta
import Lean.Elab
open Lean Meta Elab Tactic
open Lean.Elab.Term

def sigmaTypeExpr? (eType: Expr) : MetaM (Option (Expr × Expr)) :=
  do
    let eType ← whnf eType
    let u ← mkFreshLevelMVar
    let v ← mkFreshLevelMVar
    let α ← mkFreshExprMVar (mkSort (mkLevelSucc u))
    let type ← mkArrow α (mkSort (mkLevelSucc v))
    let β  ← mkFreshExprMVar type
    let m := mkAppN (Lean.mkConst ``Sigma [u, v]) #[α, β]
    if ← isDefEq m eType
      then
        return some (← whnf α , ← whnf β)
      else
        return none

def existsTypeExpr? (eType: Expr) : MetaM (Option (Expr × Expr)) :=
  do
    let eType ← whnf eType
    let u ← mkFreshLevelMVar
    let v := levelZero
    let α ← mkFreshExprMVar (mkSort u)
    let type ← mkArrow α (mkSort v)
    let β  ← mkFreshExprMVar type
    let m := mkAppN (Lean.mkConst ``Exists [u]) #[α, β]
    if ← isDefEq m eType
      then
        return some (← whnf α , ← whnf β)
      else
        return none

syntax (name:= naiveUseTactic) "naiveUse" term : tactic
@[tactic naiveUseTactic] def naiveUseTacticImpl : Tactic :=
  fun stx =>
  match stx with
  | `(tactic|naiveUse $t) =>
    do
    let mvar ← getMainGoal
    let eType ← getMainTarget
    let stOpt ← sigmaTypeExpr? eType
    match stOpt with
    | some (α , β) =>
      let a ← Tactic.elabTerm t α
      let bType ← whnf  (mkApp β a)
      let b ← mkFreshExprMVar bType
      let exp ←  mkAppOptM `Sigma.mk #[α, β, a, b]
      assignExprMVar mvar exp
      replaceMainGoal [b.mvarId!]
      return ()
    | none =>
      let etOpt ← existsTypeExpr? eType
      match etOpt with
      | some (α , β) =>
      let a ← Tactic.elabTerm t α
      let bType ← whnf  (mkApp β a)
      let b ← mkFreshExprMVar bType
      let exp ←  mkAppOptM `Exists.intro #[α, β, a, b]
      assignExprMVar mvar exp
      replaceMainGoal [b.mvarId!]
      return ()
      | none =>
        throwTacticEx `naiveUse mvar "naiveUse only works for Exists and Sigma types"
  | _ => throwIllFormedSyntax

def Tuple : Nat → Type
 | Nat.zero => Unit
 | Nat.succ n => Nat × (Tuple n)

example: Σ n: Nat, Tuple n := by
        naiveUse 2
        exact (2, 3, ())

example : ∃ n: Nat, 3 ≤ n := by
        naiveUse 3
        constructor

syntax (name := sigmaHead) "sigmaHead!" term : term
@[termElab sigmaHead] def sigmaHeadImpl : TermElab := fun stx expectedType =>
  match stx with
  | `(sigmaHead! $t) =>
    do
      let eType ← elabType t
      let ht ← sigmaTypeExpr? eType
      match ht with
      | some (h, t) => return t
      | none => return mkConst `Nat.zero
  | _ => throwIllFormedSyntax

example : Tuple 2 := (2, 3, ())

def Ntuple : Type := Σ n: Nat, Tuple n

set_option pp.all true

#check Ntuple

def chkSgma := sigmaHead! (Σ n: Nat, Tuple n)

#check chkSgma
#check @Sigma.mk

syntax (name := existsHead) "existsHead!" term : term
@[termElab existsHead] def existsHeadImpl : TermElab := fun stx expectedType =>
  match stx with
  | `(existsHead! $t) =>
    do
      let eType ← elabType t
      let ht ← existsTypeExpr? eType
      match ht with
      | some (h, t) => return t
      | none => return mkConst `Nat.zero
  | _ => throwIllFormedSyntax

def chkExists := existsHead! (∃ n: Nat, n = n)


lemma add_right_comm (a b c : mynat) : a + b + c = a + c + b :=
begin
rw add_assoc,
rw add_assoc,
rw add_comm b,
refl,
end


import algebra.direct_limit
import algebra.category.fgModule.basic

import .defs
import .direct_lim

open_locale tensor_product

universes u v
variables {R : Type u} [comm_ring R]
variables (M : Type u) [add_comm_group M] [module R M]

variable (I : ideal R)

@[ext]
structure fg_subideal :=
(to_ideal : ideal R)
(fg : to_ideal.fg)
(le : to_ideal ≤ I)

instance hmmm0 : Π (i : fg_subideal I), add_comm_group $ i.to_ideal ⊗[R] M :=
λ _, infer_instance

instance hmmm1 : Π (i : fg_subideal I), module R (i.to_ideal ⊗[R] M) :=
λ _, tensor_product.left_module

instance  : preorder (fg_subideal I) :=
preorder.lift fg_subideal.to_ideal

instance : is_directed (fg_subideal I) (≤) :=
{ directed := λ J J', ⟨⟨J.to_ideal ⊔ J'.to_ideal, submodule.fg.sup J.fg J'.fg,
    sup_le_iff.mpr ⟨J.le, J'.le⟩⟩,
    ⟨@le_sup_left (ideal R) _ J.to_ideal J'.to_ideal,
      @le_sup_right (ideal R) _ J.to_ideal J'.to_ideal⟩⟩ }

instance : inhabited (fg_subideal I) :=
⟨⟨⊥, submodule.fg_bot, bot_le⟩⟩

variables {I}
@[simps] def principal_fg_subideal (i : I) : fg_subideal I :=
{ to_ideal := ideal.span {i},
  fg := submodule.fg_span_singleton _,
  le := submodule.span_le.mpr $ λ x hx, (set.mem_singleton_iff.mp hx).symm ▸ i.2 }

lemma principal_fg_subideal_smul (r : R) (i : I) :
  principal_fg_subideal (r • i) ≤ principal_fg_subideal i :=
submodule.span_le.mpr $ λ x hx, (set.mem_singleton_iff.mp hx).symm ▸
submodule.mem_span_singleton.mpr ⟨r, rfl⟩

lemma mem_principal_fg_subideal (i : I) : (i : R) ∈ (principal_fg_subideal i).to_ideal :=
submodule.mem_span_singleton_self _

@[simps] def doubleton_fg_subideal (i j : I) : fg_subideal I :=
{ to_ideal := ideal.span {i, j},
  fg := submodule.fg_span $ by simp only [set.finite.insert, set.finite_singleton],
  le := submodule.span_le.mpr $ λ x hx,
  begin
    simp only [set.mem_insert_iff, set.mem_singleton_iff] at hx,
    rcases hx with rfl|rfl,
    { exact i.2 },
    { exact j.2 }
  end }

lemma mem_left_doubleton_fg_subideal (i j : I) :
  (i : R) ∈ (doubleton_fg_subideal i j).to_ideal :=
submodule.subset_span $ by simp

lemma mem_right_doubleton_fg_subideal (i j : I) :
  (j : R) ∈ (doubleton_fg_subideal i j).to_ideal :=
submodule.subset_span $ by simp

lemma left_le_doubleton_fg_subideal (i j : I) :
  principal_fg_subideal i ≤ doubleton_fg_subideal i j :=
submodule.span_le.mpr $ λ x hx, (set.mem_singleton_iff.mpr hx).symm ▸
  submodule.subset_span (by simp)

lemma right_le_doubleton_fg_subideal (i j : I) :
  principal_fg_subideal j ≤ doubleton_fg_subideal i j :=
submodule.span_le.mpr $ λ x hx, (set.mem_singleton_iff.mpr hx).symm ▸
  submodule.subset_span (by simp)

lemma add_le_doubleton_fg_subideal (i j : I) :
  principal_fg_subideal (i + j) ≤ doubleton_fg_subideal i j :=
submodule.span_le.mpr $ λ x hx,
begin
  rw set.mem_singleton_iff at hx,
  rw hx,
  change (i : R) + (j : R) ∈ _,
  refine (doubleton_fg_subideal i j).to_ideal.add_mem _ _,
  { apply mem_left_doubleton_fg_subideal, },
  { apply mem_right_doubleton_fg_subideal, },
end

variable (I)

variable [decidable_eq $ fg_subideal I]

namespace ideal

instance : Π (i : fg_subideal I), add_comm_group $ i.to_ideal :=
λ _, infer_instance

@[reducible]
def as_direct_limit :=
module.direct_limit (λ (i : fg_subideal I), i.to_ideal) $ λ i j hij,
  (submodule.of_le hij : i.to_ideal →ₗ[R] j.to_ideal)

@[reducible]
def from_as_direct_limit :
  I.as_direct_limit →ₗ[R] I :=
module.direct_limit.lift R _ _ _ (λ i, submodule.of_le i.le) $ λ i j hij r, rfl

@[simps]
def to_as_direct_limit :
  I →ₗ[R] I.as_direct_limit :=
{ to_fun := λ r, module.direct_limit.of R (fg_subideal I) (λ i, i.to_ideal)
    (λ _ _ h, submodule.of_le h) (principal_fg_subideal r) ⟨r, mem_principal_fg_subideal r⟩,
  map_add' := λ i i', begin
    set ι : fg_subideal I := doubleton_fg_subideal i i' with ι_eq,
    rw ←@module.direct_limit.of_f R _ (fg_subideal I) _ _ (λ i, i.to_ideal) _ _
        (λ _ _ h, submodule.of_le h) _ _ (add_le_doubleton_fg_subideal i i'),
    simp_rw [submodule.of_le_apply, subtype.coe_mk],
    erw show (⟨i + i', _⟩ : (doubleton_fg_subideal i i').to_ideal) =
      ⟨i, mem_left_doubleton_fg_subideal _ _⟩ + ⟨i', mem_right_doubleton_fg_subideal _ _⟩,
      from rfl,
    rw map_add,
    congr' 1,
    { rw ←@module.direct_limit.of_f R _ (fg_subideal I) _ _ (λ i, i.to_ideal) _ _
        (λ _ _ h, submodule.of_le h) _ _ (left_le_doubleton_fg_subideal i i'),
      refl, },
    { rw ←@module.direct_limit.of_f R _ (fg_subideal I) _ _ (λ i, i.to_ideal) _ _
        (λ _ _ h, submodule.of_le h) _ _ (right_le_doubleton_fg_subideal i i'),
      refl, },
  end,
  map_smul' := λ r i,
  begin
    rw ←@module.direct_limit.of_f R _ (fg_subideal I) _ _ (λ i, i.to_ideal) _ _
        (λ _ _ h, submodule.of_le h) _ _ (principal_fg_subideal_smul r i),
    simpa only [submodule.of_le_apply, ring_hom.id_apply, ←map_smul],
  end }

example : true := trivial

lemma from_to_as_direct_limit :
  function.left_inverse I.from_as_direct_limit I.to_as_direct_limit :=
begin
  intros z,
  rw to_as_direct_limit_apply,
  rw module.direct_limit.lift_of,
  rw submodule.of_le_apply,
  simp_rw subtype.coe_mk,
  ext,
  rw subtype.coe_mk,
end

lemma to_from_as_direct_limit :
  function.right_inverse I.from_as_direct_limit I.to_as_direct_limit :=
begin
  intros z,
  induction z using module.direct_limit.induction_on with i z,
  rw module.direct_limit.lift_of,
  rw submodule.of_le_apply,
  rw to_as_direct_limit_apply,
  simp_rw subtype.coe_mk,
  rw ←module.direct_limit.of_f,
  work_on_goal 2 { show _ ≤ i, begin
    erw submodule.span_le,
    intros r hr,
    rw set.mem_singleton_iff at hr,
    rw subtype.coe_mk at hr,
    rw hr,
    exact z.2,
  end, },
  rw submodule.of_le_apply,
  simp_rw subtype.coe_mk,
  congr' 1,
  ext1,
  refl,
end

@[simps] def iso_as_direct_limit :
  I ≃ₗ[R] I.as_direct_limit :=
{ to_fun := I.to_as_direct_limit,
  map_add' := map_add _,
  map_smul' := map_smul _,
  inv_fun := I.from_as_direct_limit,
  left_inv := I.from_to_as_direct_limit,
  right_inv := I.to_from_as_direct_limit }

-- instance hmmm2 : module R (I.as_direct_limit ⊗[R] M) := tensor_product.left_module

@[simps] def tensor_iso_direct_limit :
  I ⊗[R] M ≃ₗ[R] I.as_direct_limit ⊗[R] M :=
{ inv_fun := (tensor_product.map I.from_as_direct_limit linear_map.id :
    I.as_direct_limit ⊗[R] M →ₗ[R] I ⊗[R] M),
  left_inv := λ z,
  begin
    simp only [linear_map.to_fun_eq_coe],
    rw ←linear_map.comp_apply,
    rw ←tensor_product.map_comp,
    rw linear_map.comp_id,
    convert linear_map.id_apply _,
    convert tensor_product.map_id,
    ext1 z,
    rw linear_map.comp_apply,
    rw I.from_to_as_direct_limit,
    rw linear_map.id_apply,
  end,
  right_inv := λ z,
  begin
    simp only [linear_map.to_fun_eq_coe],
    rw ←linear_map.comp_apply,
    rw ←tensor_product.map_comp,
    rw linear_map.comp_id,
    convert linear_map.id_apply _,
    convert tensor_product.map_id,
    refine linear_map.ext (λ z, _),
    rw linear_map.comp_apply,
    rw I.to_from_as_direct_limit,
    rw linear_map.id_apply,
  end,
  ..(tensor_product.map I.to_as_direct_limit linear_map.id :
    I ⊗[R] M →ₗ[R] I.as_direct_limit ⊗[R] M) }

@[reducible]
def as_direct_limit_tensor :=
module.direct_limit (λ (i : fg_subideal I), i.to_ideal ⊗[R] M)
  (λ i j hij, tensor_product.map (submodule.of_le hij) linear_map.id)

@[reducible]
def iso_as_direct_limit_tensor_aux1 :
  I.as_direct_limit_tensor M ≃ₗ[R] I.as_direct_limit ⊗[R] M :=
@module.direct_limit_of_tensor_product_iso_tensor_product_with_direct_limit R _
    (fg_subideal I) _ _ (λ i, i.to_ideal) _ _ (λ _ _ h, submodule.of_le h) M _ _ _ _

end ideal

@[reducible]
def tensor_embedding' :
  module.direct_limit (λ (i : fg_subideal I), (i.to_ideal ⊗[R] M))
    (λ i j hij, tensor_product.map (submodule.of_le hij) linear_map.id :
      Π (i j : fg_subideal I) (hij : i ≤ j), (i.to_ideal ⊗[R] M) →ₗ[R] (j.to_ideal ⊗[R] M)) →ₗ[R]
  R ⊗[R] M :=
module.direct_limit.lift _ _ _ _
  (λ i, Module.tensor_embedding M i.to_ideal) $ λ i j hij z,
begin
  induction z using tensor_product.induction_on with ii m x y hx hy,
  { simp only [map_zero] },
  { simp only [tensor_product.map_tmul, linear_map.coe_mk, submodule.of_le_apply,
      linear_map.id_apply, subtype.coe_mk], },
  { simp only [map_add, hx, hy] },
end

lemma tensor_embedding_eq :
  (Module.tensor_embedding M I : I ⊗[R] M →ₗ[R] R ⊗[R] M) =
  linear_map.comp (tensor_embedding' M I)
    (linear_map.comp (I.iso_as_direct_limit_tensor_aux1 M).symm.to_linear_map
      ((I.tensor_iso_direct_limit M).to_linear_map)) :=
linear_map.ext $ λ z, begin
  induction z using tensor_product.induction_on with i m x y hx hy,
  { simp only [map_zero] },
  { simp only [tensor_product.map_tmul, linear_map.comp_apply, linear_map.coe_mk, id,
      linear_equiv.coe_to_linear_map, ideal.tensor_iso_direct_limit_apply,
      module.direct_limit_of_tensor_product_iso_tensor_product_with_direct_limit_symm_apply,
      linear_map.to_fun_eq_coe, ideal.to_as_direct_limit_apply, module.direct_limit.lift_of,
      tensor_product.lift.tmul, linear_map.id_apply, subtype.coe_mk], },
  { simp only [map_add, hx, hy] }
end

lemma tensor_embedding_inj_of_fg_inj
  (hinj : ∀ (I : ideal R), I.fg → function.injective (Module.tensor_embedding M I)) :
  function.injective $ Module.tensor_embedding M I :=
begin
  rw tensor_embedding_eq,
  refine function.injective.comp _ (function.injective.comp (function.injective.comp _ _) _),
  { refine module.lift_inj R (fg_subideal I) _ _ _ _ _,
    exact λ i, hinj i.to_ideal i.fg, },
  { exact linear_equiv.injective _, },
  { exact linear_equiv.injective _, },
  { exact function.injective_id, },
end


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import analysis.normed_space.basic
import analysis.normed_space.exponential
import topology.instances.triv_sq_zero_ext

/-!
# Results on `triv_sq_zero_ext R M` related to the norm

For now, this file contains results about `exp` for this type.

## Main results

* `triv_sq_zero_ext.fst_exp`
* `triv_sq_zero_ext.snd_exp`
* `triv_sq_zero_ext.exp_inl`
* `triv_sq_zero_ext.exp_inr`

## TODO
* Actually define a sensible norm on `triv_sq_zero_ext R M`, so that we have access to lemmas
  like `exp_add`.
* Generalize some of these results to non-commutative `R`.

-/

variables (𝕜 : Type*) {R M : Type*}

local notation `tsze` := triv_sq_zero_ext

namespace triv_sq_zero_ext

section topology
variables [topological_space R] [topological_space M]

/-- If `exp R x.fst` converges to `e` then `exp R x` converges to `inl e + inr (e • x.snd)`. -/
lemma has_sum_exp_series [field 𝕜] [char_zero 𝕜] [comm_ring R]
  [add_comm_group M] [algebra 𝕜 R]
  [module R M] [module Rᵐᵒᵖ M] [is_central_scalar R M]
  [module 𝕜 M] [is_scalar_tower 𝕜 R M]
  [topological_ring R] [topological_add_group M]
  [has_continuous_smul R M]
  (x : tsze R M) {e : R} (h : has_sum (λ n, exp_series 𝕜 R n (λ _, x.fst)) e) :
  has_sum (λ n, exp_series 𝕜 (tsze R M) n (λ _, x)) (inl e + inr (e • x.snd)) :=
begin
  simp_rw [exp_series_apply_eq] at *,
  conv
  { congr,
    funext,
    rw [←inl_fst_add_inr_snd_eq (x ^ _), fst_pow, snd_pow, smul_add, ←inr_smul,
      ←inl_smul, nsmul_eq_smul_cast 𝕜 n, smul_smul, inv_mul_eq_div, ←inv_div, ←smul_assoc], },
  refine (has_sum_inl M h).add (has_sum_inr M _),
  apply has_sum.smul_const,
  rw [←has_sum_nat_add_iff' 1], swap, apply_instance,
  rw [finset.range_one, finset.sum_singleton, nat.cast_zero, div_zero, inv_zero, zero_smul,
    sub_zero],
  simp_rw [←nat.succ_eq_add_one, nat.pred_succ, nat.factorial_succ, nat.cast_mul,
    ←nat.succ_eq_add_one,
    mul_div_cancel_left _ ((@nat.cast_ne_zero 𝕜 _ _ _).mpr $ nat.succ_ne_zero _)],
  exact h,
end

end topology

section normed_ring
variables [is_R_or_C 𝕜] [normed_comm_ring R] [add_comm_group M]
variables [normed_algebra 𝕜 R] [module R M] [module Rᵐᵒᵖ M] [is_central_scalar R M]
variables [module 𝕜 M] [is_scalar_tower 𝕜 R M]
variables [topological_space M] [topological_ring R]
variables [topological_add_group M] [has_continuous_smul R M]
variables [complete_space R] [t2_space R] [t2_space M]

lemma exp_def (x : tsze R M) : exp 𝕜 x = inl (exp 𝕜 x.fst) + inr (exp 𝕜 x.fst • x.snd) :=
begin
  simp_rw [exp, formal_multilinear_series.sum],
  refine (has_sum_exp_series 𝕜 x _).tsum_eq,
  exact exp_series_has_sum_exp _,
end

@[simp] lemma fst_exp (x : tsze R M) : fst (exp 𝕜 x) = exp 𝕜 x.fst :=
by rw [exp_def, fst_add, fst_inl, fst_inr, add_zero]

@[simp] lemma snd_exp (x : tsze R M) : snd (exp 𝕜 x) = exp 𝕜 x.fst • x.snd :=
by rw [exp_def, snd_add, snd_inl, snd_inr, zero_add]

@[simp] lemma exp_inl (x : R) : exp 𝕜 (inl x : tsze R M) = inl (exp 𝕜 x) :=
by rw [exp_def, fst_inl, snd_inl, smul_zero, inr_zero, add_zero]

@[simp] lemma exp_inr (m : M) : exp 𝕜 (inr m : tsze R M) = 1 + inr m :=
by rw [exp_def, fst_inr, exp_zero, snd_inr, one_smul, inl_one]

/-- Polar form of trivial-square-zero extension. -/
lemma eq_smul_exp_of_invertible (x : tsze R M) [invertible x.fst] :
  x = x.fst • exp 𝕜 (⅟x.fst • inr x.snd) :=
by rw [←inr_smul, exp_inr, smul_add, ←inl_one, ←inl_smul, ←inr_smul, smul_eq_mul, mul_one,
    smul_smul, mul_inv_of_self, one_smul, inl_fst_add_inr_snd_eq]

end normed_ring

section normed_field
variables [is_R_or_C 𝕜] [normed_field R] [add_comm_group M]
variables [normed_algebra 𝕜 R] [module R M] [module Rᵐᵒᵖ M] [is_central_scalar R M]
variables [module 𝕜 M] [is_scalar_tower 𝕜 R M]
variables [topological_space M] [topological_ring R]
variables [topological_add_group M] [has_continuous_smul R M]
variables [complete_space R] [t2_space R] [t2_space M]

/-- More convenient version of `triv_sq_zero_ext.eq_smul_exp_of_invertible` for when `R` is a
field. -/
lemma eq_smul_exp_of_ne_zero (x : tsze R M) (hx : x.fst ≠ 0) :
  x = x.fst • exp 𝕜 (x.fst⁻¹ • inr x.snd) :=
begin
  letI : invertible x.fst := invertible_of_nonzero hx,
  exact eq_smul_exp_of_invertible _ _
end

end normed_field

end triv_sq_zero_ext


/-
Copyright (c) 2015 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam
-/
prelude
import init.logic

namespace simplifier

namespace empty
end empty

namespace prove
attribute eq_self_iff_true [simp]
end prove

namespace unit_simp
open eq.ops

-- TODO(dhs): prove these lemmas elsewhere and only gather the
-- [simp] attributes here

variables {A B C : Prop}

lemma and_imp [simp] : (A ∧ B → C) ↔ (A → B → C) :=
iff.intro (assume H a b, H (and.intro a b))
          (assume H ab, H (and.left ab) (and.right ab))

lemma or_imp [simp] : (A ∨ B → C) ↔ ((A → C) ∧ (B → C)) :=
iff.intro (assume H, and.intro (assume a, H (or.inl a))
                               (assume b, H (or.inr b)))
          (assume H ab, and.rec_on H
            (assume Hac Hbc, or.rec_on ab Hac Hbc))

lemma imp_and [simp] : (A → B ∧ C) ↔ ((A → B) ∧ (A → C)) :=
iff.intro (assume H, and.intro (assume a, and.left (H a))
                               (assume a, and.right (H a)))
          (assume H a, and.rec_on H
            (assume Hab Hac, and.intro (Hab a) (Hac a)))

-- TODO(dhs, leo): do we want to pre-process away the [iff]s?
/-
lemma iff_and_imp [simp] : ((A ↔ B) → C) ↔ (((A → B) ∧ (B → A)) → C) :=
iff.intro (assume H1 H2, and.rec_on H2 (assume ab ba, H1 (iff.intro ab ba)))
          (assume H1 H2, H1 (and.intro (iff.elim_left H2) (iff.elim_right H2)))
-/

lemma a_of_a [simp] : (A → A) ↔ true :=
iff.intro (assume H, trivial)
          (assume t a, a)

lemma not_true_of_false [simp] : ¬ true ↔ false :=
iff.intro (assume H, H trivial)
          (assume f, false.rec (¬ true) f)

lemma imp_true [simp] : (A → true) ↔ true :=
iff.intro (assume H, trivial)
          (assume t a, trivial)

lemma true_imp [simp] : (true → A) ↔ A :=
iff.intro (assume H, H trivial)
          (assume a t, a)

-- lemma fold_not [simp] : (A → false) ↔ ¬ A :=
-- iff.intro id id

lemma false_imp [simp] : (false → A) ↔ true :=
iff.intro (assume H, trivial)
          (assume t f, false.rec A f)

lemma ite_and [simp] [A_dec : decidable A] : ite A B C ↔ ((A → B) ∧ (¬ A → C)) :=
iff.intro (assume H, and.intro (assume a, implies_of_if_pos H a)
                               (assume a, implies_of_if_neg H a))
          (assume H, and.rec_on H
            (assume Hab Hnac, decidable.rec_on A_dec
              (assume a,
                have rw : @decidable.inl A a = A_dec, from
                  subsingleton.rec_on (subsingleton_decidable A)
                    (assume H, H (@decidable.inl A a) A_dec),
                by rewrite [rw, if_pos a] ; exact Hab a)
              (assume na,
                have rw : @decidable.inr A na = A_dec, from
                  subsingleton.rec_on (subsingleton_decidable A)
                    (assume H, H (@decidable.inr A na) A_dec),
                by rewrite [rw, if_neg na] ; exact Hnac na)))

end unit_simp

end simplifier


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Three-step construction of free group of a type.
Based on https://math.stackexchange.com/a/852661/328173
-/

import data.list.basic algebra.group

universes u v

class inv_type (IT : Type u) extends has_inv IT :=
(inv_inv : ∀ x : IT, x⁻¹⁻¹ = x)

class involution_monoid (M : Type u) extends monoid M, inv_type M :=
(mul_inv : ∀ x y : M, (x*y)⁻¹ = y⁻¹ * x⁻¹)
(one_inv : (1:M)⁻¹ = 1)

instance group.to_involution_monoid (G : Type u) [group G] : involution_monoid G :=
{ mul_inv := mul_inv_rev,
  one_inv := one_inv,
  inv_inv := inv_inv }

class involution_monoid.is_hom {M : Type u} {N : Type v}
  [involution_monoid M] [involution_monoid N] (f : M → N) : Prop :=
(mul : ∀ x y, f (x * y) = f x * f y)
(one : f 1 = 1)
(inv : ∀ x, f x⁻¹ = (f x)⁻¹)

namespace involution_monoid.to_group

variables (M : Type u) [involution_monoid M]

inductive rel : M → M → Prop
| refl : ∀ x, rel x x
| symm : ∀ x y, rel x y → rel y x
| trans : ∀ x y z, rel x y → rel y z → rel x z
| mul : ∀ x y z w, rel x z → rel y w → rel (x * y) (z * w)
| inv : ∀ x y, rel x y → rel x⁻¹ y⁻¹
| mul_left_inv : ∀ x, rel (x⁻¹ * x) 1

instance quotient_rel : setoid M :=
⟨rel M, rel.refl, rel.symm, rel.trans⟩

end involution_monoid.to_group

@[reducible] def involution_monoid.to_group (M : Type u) [involution_monoid M] : Type u :=
quotient (involution_monoid.to_group.quotient_rel M)

namespace involution_monoid.to_group

instance (M : Type u) [involution_monoid M] : group (involution_monoid.to_group M) :=
{ mul := λ x y, quotient.lift_on₂ x y (λ m n, quotient.mk (m * n))
    (λ x y z w hxz hyw, quotient.sound $ rel.mul x y z w hxz hyw),
  mul_assoc := λ x y z, quotient.induction_on₃ x y z $
    λ a b c, quotient.sound $ by rw mul_assoc,
  one := quotient.mk 1,
  mul_one := λ x, quotient.induction_on x $
    λ a, quotient.sound $ by rw mul_one,
  one_mul := λ x, quotient.induction_on x $
    λ a, quotient.sound $ by rw one_mul,
  inv := λ x, quotient.lift_on x (λ m, quotient.mk m⁻¹)
    (λ x y hxy, quotient.sound $ rel.inv x y hxy),
  mul_left_inv := λ x, quotient.induction_on x $
    λ a, quotient.sound $ rel.mul_left_inv a }

def of_involution_monoid {M : Type u} [involution_monoid M] : M → involution_monoid.to_group M :=
quotient.mk

@[simp] lemma of_involution_monoid.mul {M : Type u} [involution_monoid M] {x y : M} :
  of_involution_monoid (x * y) = of_involution_monoid x * of_involution_monoid y := rfl

@[simp] lemma of_involution_monoid.one {M : Type u} [involution_monoid M] :
  of_involution_monoid (1:M) = 1 := rfl

@[simp] lemma of_involution_monoid.inv {M : Type u} [involution_monoid M] {x : M} :
  of_involution_monoid x⁻¹ = (of_involution_monoid x)⁻¹ := rfl

section left_adjoint

parameters (M : Type u) [involution_monoid M]
parameters (G : Type v) [group G]
parameters (f : M → G) -- M → Forgetful(G)
parameters [Hf : involution_monoid.is_hom f]
include Hf

def left_adjoint : involution_monoid.to_group M → G := -- Free(M) → G
λ x, quotient.lift_on x f $ λ a b hab, begin
  induction hab with h c d h ih c d e h1 h2 ih1 ih2
    c d p q h1 h2 ih1 ih2 c d h ih c,
  case involution_monoid.to_group.rel.refl
  { refl },
  case involution_monoid.to_group.rel.symm
  { exact ih.symm },
  case involution_monoid.to_group.rel.trans
  { exact ih1.trans ih2 },
  case involution_monoid.to_group.rel.mul
  { rw [Hf.mul, Hf.mul, ih1, ih2] },
  case involution_monoid.to_group.rel.inv
  { rw [Hf.inv, Hf.inv, ih] },
  case involution_monoid.to_group.rel.mul_left_inv
  { rw [Hf.mul, Hf.inv, mul_left_inv, Hf.one] }
end

theorem left_adjoint.is_group_hom : is_group_hom left_adjoint :=
λ x y, quotient.induction_on₂ x y Hf.mul

theorem left_adjoint.commutes (x) : left_adjoint (of_involution_monoid x) = f x := rfl

parameters (g : involution_monoid.to_group M → G)
parameters (Hg : ∀ x, g (of_involution_monoid x) = f x)

theorem left_adjoint.unique : ∀ x, g x = left_adjoint x :=
λ x, quotient.induction_on x $ λ m, Hg m

end left_adjoint

end involution_monoid.to_group

@[reducible] def inv_type.to_involution_monoid (IT : Type u) [inv_type IT] :=
list IT

namespace inv_type.to_involution_monoid

instance (IT : Type u) [inv_type IT] : involution_monoid (inv_type.to_involution_monoid IT) :=
{ mul := (++),
  one := [],
  inv := λ x, x.reverse.map has_inv.inv,
  mul_assoc := list.append_assoc,
  one_mul := list.nil_append,
  mul_one := list.append_nil,
  mul_inv := λ x y, show (x ++ y).reverse.map has_inv.inv
    = y.reverse.map has_inv.inv ++ x.reverse.map has_inv.inv,
    by rw [list.reverse_append, list.map_append],
  one_inv := rfl,
  inv_inv := λ x, have h1 : (has_inv.inv ∘ has_inv.inv) = @id IT,
    from funext $ inv_type.inv_inv,
    by dsimp; rw [list.map_reverse, list.map_reverse];
    rw [list.map_reverse, list.reverse_reverse];
    rw [list.map_map, h1, list.map_id] }

def of_inv_type {IT : Type u} [inv_type IT] : IT → inv_type.to_involution_monoid IT :=
λ x, [x]

@[simp] lemma of_inv_type.inv {IT : Type u} [inv_type IT] {x : IT} :
  of_inv_type x⁻¹ = (of_inv_type x)⁻¹ := rfl

section left_adjoint

parameters (IT : Type u) [inv_type IT]
parameters (M : Type v) [involution_monoid M]
parameters (f : IT → M) -- IT → Forgetful(M)
parameters (Hinv : ∀ x, f x⁻¹ = (f x)⁻¹)

def left_adjoint : inv_type.to_involution_monoid IT → M := -- Free(IT) → M
λ L, list.prod (L.map f)

theorem left_adjoint.append (x y) : left_adjoint (x ++ y) = left_adjoint x * left_adjoint y :=
by dsimp [left_adjoint]; rw [list.map_append, list.prod_append]

theorem left_adjoint.mul (x y) : left_adjoint (x * y) = left_adjoint x * left_adjoint y :=
left_adjoint.append x y

theorem left_adjoint.one : left_adjoint 1 = 1 := rfl

include Hinv
theorem left_adjoint.inv : ∀ x, left_adjoint x⁻¹ = (left_adjoint x)⁻¹
| []     := eq.symm $ involution_monoid.one_inv M
| (h::IT) := have _ := left_adjoint.inv IT,
  by dsimp [left_adjoint, has_inv.inv] at this ⊢;
  rw [list.map_reverse, list.map_reverse] at this ⊢;
  rw [list.map_cons, list.map_cons, list.prod_cons, involution_monoid.mul_inv, ← this];
  rw [list.reverse_cons', list.prod_append, list.prod_cons, list.prod_nil];
  rw [mul_one, Hinv]
omit Hinv

instance left_adjoint.hom : involution_monoid.is_hom left_adjoint :=
⟨left_adjoint.mul, left_adjoint.one, left_adjoint.inv⟩

theorem left_adjoint.commutes (x) : left_adjoint (of_inv_type x) = f x :=
one_mul _

parameters (g : inv_type.to_involution_monoid IT → M)
parameters (Hg1 : ∀ x y, g (x * y) = g x * g y)
parameters (Hg2 : g 1 = 1)
parameters (Hg3 : ∀ x, g (of_inv_type x) = f x)
include Hg1 Hg3

theorem left_adjoint.unique : ∀ x, g x = left_adjoint x
| []     := Hg2
| (h::t) := eq.trans (Hg1 (of_inv_type h) t) $
  by rw [left_adjoint.unique t]; dsimp [left_adjoint]; rw [Hg3, list.prod_cons]

end left_adjoint

end inv_type.to_involution_monoid

@[reducible] def to_inv_type (T : Type u) :=
sum T T

namespace to_inv_type

def inv (T : Type u) : to_inv_type T → to_inv_type T
| (sum.inl x) := sum.inr x
| (sum.inr x) := sum.inl x

theorem inv.inv (T : Type u) : ∀ x : to_inv_type T, inv T (inv T x) = x
| (sum.inl x) := rfl
| (sum.inr x) := rfl

instance (T : Type u) : inv_type (to_inv_type T) :=
{ inv := inv T,
  inv_inv := inv.inv T }

def of_inv_type {T : Type u} : T → to_inv_type T :=
sum.inl

section left_adjoint

parameters (T : Type u)
parameters (IT : Type v) [inv_type IT]
parameters (f : T → IT) -- T → Forgetful(IT)

def left_adjoint : to_inv_type T → IT -- Free(T) → IT
| (sum.inl x) := f x
| (sum.inr x) := (f x)⁻¹

theorem left_adjoint.inv : ∀ x, left_adjoint x⁻¹ = (left_adjoint x)⁻¹
| (sum.inl x) := rfl
| (sum.inr x) := eq.symm $ inv_type.inv_inv _

theorem left_adjoint.commutes (x) : left_adjoint (of_inv_type x) = f x := rfl

parameters (g : to_inv_type T → IT)
parameters (Hg1 : ∀ x, g x⁻¹ = (g x)⁻¹)
parameters (Hg2 : ∀ x, g (of_inv_type x) = f x)

theorem left_adjoint.unique : ∀ x, g x = left_adjoint x
| (sum.inl x) := Hg2 x
| (sum.inr x) := (Hg1 (sum.inl x)).trans $ congr_arg _ $ Hg2 x

end left_adjoint

end to_inv_type

@[reducible] def free_group.word (S : Type u) : Type u :=
inv_type.to_involution_monoid $ to_inv_type S

@[reducible] def free_group (S : Type u) : Type u :=
involution_monoid.to_group $ free_group.word S

namespace free_group

variables (S : Type u)

instance : group (free_group S) :=
involution_monoid.to_group.group _

def of_type : S → free_group S :=
λ x, ⟦[sum.inl x]⟧

variables (G : Type v) [group G]
variables (f : S → G) -- S → Forgetful(G)

def to_group : free_group S → G := -- Free(S) → G
involution_monoid.to_group.left_adjoint _ G
  (λ y, inv_type.to_involution_monoid.left_adjoint (to_inv_type S) _
    (to_inv_type.left_adjoint S _ f) y)

def to_group.is_group_hom : is_group_hom (to_group S G f) :=
involution_monoid.to_group.left_adjoint.is_group_hom _ _ _ _ _ _

def to_group.commutes (x) : to_group S G f (of_type S x) = f x :=
mul_one _

variables (g : free_group S → G)
variables (Hg1 : is_group_hom g)
variables (Hg2 : ∀ x, g (of_type S x) = f x)
include Hg1 Hg2

def to_group.unique : ∀ x, g x = to_group S G f x :=
λ x, quotient.induction_on x $ λ m, list.rec_on m (is_group_hom.one g) $
λ h t ih, sum.rec_on h
  (λ a, show g (of_type S a * ⟦t⟧) = _ , by rw [Hg1, Hg2, ih]; refl)
  (λ a, show g ((of_type S a)⁻¹ * ⟦t⟧) = _ , by rw [Hg1, is_group_hom.inv g, Hg2, ih]; refl)

omit Hg1 Hg2

variable [decidable_eq S]

def reduce : word S → word S
| ((sum.inl x)::(sum.inr y)::t) := if x = y then reduce t else ((sum.inl x)::(sum.inr y)::reduce t)
| ((sum.inr x)::(sum.inl y)::t) := if x = y then reduce t else ((sum.inr x)::(sum.inl y)::reduce t)
| (h1::h2::t)                   := h1::h2::reduce t
| w                             := w

theorem reduce.sound : ∀ w : word S, ⟦w⟧ = ⟦reduce S w⟧
| []                            := rfl
| ((sum.inl x)::[])             := rfl
| ((sum.inr x)::[])             := rfl
| ((sum.inl x)::(sum.inl y)::t) :=
    show ⟦[sum.inl x, sum.inl y]⟧ * ⟦t⟧ = ⟦[sum.inl x, sum.inl y]⟧ * ⟦reduce S t⟧,
    from congr_arg _ $ reduce.sound t
| ((sum.inr x)::(sum.inr y)::t) :=
    show ⟦[sum.inr x, sum.inr y]⟧ * ⟦t⟧ = ⟦[sum.inr x, sum.inr y]⟧ * ⟦reduce S t⟧,
    from congr_arg _ $ reduce.sound t
| ((sum.inl x)::(sum.inr y)::t) := begin
    dsimp [reduce],
    by_cases x = y; simp [h],
    { change ⟦[sum.inl y]⟧ * ⟦[sum.inr y]⟧ * ⟦t⟧ = ⟦reduce S t⟧,
      have h1 : ⟦[sum.inl y]⟧ * ⟦[sum.inr y]⟧ = 1,
      { exact mul_inv_self _ },
      rw [h1, one_mul, reduce.sound t] },
    { change ⟦[sum.inl x, sum.inr y]⟧ * ⟦t⟧ = ⟦[sum.inl x, sum.inr y]⟧ * ⟦reduce S t⟧,
      rw reduce.sound t }
  end
| ((sum.inr x)::(sum.inl y)::t) := begin
    dsimp [reduce],
    by_cases x = y; simp [h],
    { change ⟦[sum.inr y]⟧ * ⟦[sum.inl y]⟧ * ⟦t⟧ = ⟦reduce S t⟧,
      have h1 : ⟦[sum.inr y]⟧ * ⟦[sum.inl y]⟧ = 1,
      { exact mul_inv_self _ },
      rw [h1, one_mul, reduce.sound t] },
    { change ⟦[sum.inr x, sum.inl y]⟧ * ⟦t⟧ = ⟦[sum.inr x, sum.inl y]⟧ * ⟦reduce S t⟧,
      rw reduce.sound t }
  end

theorem reduce.exact.mul.nil : ∀ p q : word S, [] = reduce S p →
  reduce S q = reduce S (p * q)
| [] q h := rfl
| ((sum.inl x)::(sum.inr y)::t) q h :=
  show reduce S q = reduce S (sum.inl x :: sum.inr y :: t * q),
  begin
    dsimp [reduce] at h ⊢,
    by_cases H : x = y,
    { rw [if_pos H] at h ⊢,
      exact reduce.exact.mul.nil _ _ h },
    { rw [if_neg H] at h ⊢,
      exact list.no_confusion h },
  end
| ((sum.inr x)::(sum.inl y)::t) q h :=
  show reduce S q = reduce S (sum.inr x :: sum.inl y :: t * q),
  begin
    dsimp [reduce] at h ⊢,
    by_cases H : x = y,
    { rw [if_pos H] at h ⊢,
      exact reduce.exact.mul.nil _ _ h },
    { rw [if_neg H] at h ⊢,
      exact list.no_confusion h },
  end

-- TODO
-- theorem reduce.exact : ∀ v w : word S, v ≈ w → reduce S v = reduce S w :=

theorem reduce.min : ∀ w : word S, (reduce S w).length ≤ w.length
| []                            := dec_trivial
| ((sum.inl x)::[])             := dec_trivial
| ((sum.inr x)::[])             := dec_trivial
| ((sum.inl x)::(sum.inl y)::t) :=
    add_le_add_right (add_le_add_right (reduce.min t) 1) 1
| ((sum.inr x)::(sum.inr y)::t) :=
    add_le_add_right (add_le_add_right (reduce.min t) 1) 1
| ((sum.inl x)::(sum.inr y)::t) :=
  match (by apply_instance : decidable (x = y)) with
  | (decidable.is_true  h) := nat.le_succ_of_le $
      nat.le_succ_of_le $ by dsimp [reduce]; rw [if_pos h];
      exact reduce.min t
  | (decidable.is_false h) := by dsimp [reduce]; rw [if_neg h];
      exact add_le_add_right (add_le_add_right (reduce.min t) 1) 1
  end
| ((sum.inr x)::(sum.inl y)::t) :=
  match (by apply_instance : decidable (x = y)) with
  | (decidable.is_true  h) := nat.le_succ_of_le $
      nat.le_succ_of_le $ by dsimp [reduce];
        rw [if_pos h]; exact reduce.min t
  | (decidable.is_false h) := by dsimp [reduce]; rw [if_neg h];
      exact add_le_add_right (add_le_add_right (reduce.min t) 1) 1
  end

theorem reduce.idem : ∀ w : word S, reduce S (reduce S w) = reduce S w
| []                            := rfl
| ((sum.inl x)::[])             := rfl
| ((sum.inr x)::[])             := rfl
| ((sum.inl x)::(sum.inl y)::t) :=
    show sum.inl x :: sum.inl y :: reduce.{u} S (reduce S t)
      = sum.inl x :: sum.inl y :: reduce S t,
    from congr_arg _ $ congr_arg _ $ reduce.idem t
| ((sum.inr x)::(sum.inr y)::t) :=
    show sum.inr x :: sum.inr y :: reduce.{u} S (reduce S t)
      = sum.inr x :: sum.inr y :: reduce S t,
    from congr_arg _ $ congr_arg _ $ reduce.idem t
| ((sum.inl x)::(sum.inr y)::t) :=
  match (by apply_instance : decidable (x = y)) with
  | (decidable.is_true  h) := by dsimp [reduce];
      rw [if_pos h]; exact reduce.idem t
  | (decidable.is_false h) := by dsimp [reduce]; rw [if_neg h];
      dsimp [reduce]; rw [if_neg h];
      from congr_arg _ (congr_arg _ (reduce.idem t))
  end
| ((sum.inr x)::(sum.inl y)::t) :=
  match (by apply_instance : decidable (x = y)) with
  | (decidable.is_true  h) := by dsimp [reduce];
      rw [if_pos h]; exact reduce.idem t
  | (decidable.is_false h) := by dsimp [reduce]; rw [if_neg h];
      dsimp [reduce]; rw [if_neg h];
      from congr_arg _ (congr_arg _ (reduce.idem t))
  end

-- TODO
-- def to_word : free_group S → word S :=

end free_group


/-
Copyright (c) 2022 Antoine Labelle, Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Antoine Labelle, Rémi Bottinelli

! This file was ported from Lean 3 source module combinatorics.quiver.cast
! leanprover-community/mathlib commit fc2ed6f838ce7c9b7c7171e58d78eaf7b438fb0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.Quiver.Basic
import Mathlib.Combinatorics.Quiver.Path

/-!

# Rewriting arrows and paths along vertex equalities

This files defines `Hom.cast` and `Path.cast` (and associated lemmas) in order to allow
rewriting arrows and paths along equalities of their endpoints.

-/

universe v v₁ v₂ u u₁ u₂

variable {U : Type _} [Quiver.{u + 1} U]

namespace Quiver

/-!
### Rewriting arrows along equalities of vertices
-/

/-- Change the endpoints of an arrow using equalities. -/
def Hom.cast {u v u' v' : U} (hu : u = u') (hv : v = v') (e : u ⟶ v) : u' ⟶ v' :=
  Eq.ndrec (motive := λ x => x ⟶ v') (Eq.ndrec e hv) hu
#align quiver.hom.cast Quiver.Hom.cast

theorem Hom.cast_eq_cast {u v u' v' : U} (hu : u = u') (hv : v = v') (e : u ⟶ v) :
    e.cast hu hv = _root_.cast (by {rw [hu, hv]}) e := by
  subst_vars
  rfl
#align quiver.hom.cast_eq_cast Quiver.Hom.cast_eq_cast

@[simp]
theorem Hom.cast_rfl_rfl {u v : U} (e : u ⟶ v) : e.cast rfl rfl = e :=
  rfl
#align quiver.hom.cast_rfl_rfl Quiver.Hom.cast_rfl_rfl

@[simp]
theorem Hom.cast_cast {u v u' v' u'' v'' : U} (e : u ⟶ v) (hu : u = u') (hv : v = v')
    (hu' : u' = u'') (hv' : v' = v'') :
    (e.cast hu hv).cast hu' hv' = e.cast (hu.trans hu') (hv.trans hv') := by
  subst_vars
  rfl
#align quiver.hom.cast_cast Quiver.Hom.cast_cast

theorem Hom.cast_heq {u v u' v' : U} (hu : u = u') (hv : v = v') (e : u ⟶ v) :
    HEq (e.cast hu hv) e := by
  subst_vars
  rfl
#align quiver.hom.cast_heq Quiver.Hom.cast_heq

theorem Hom.cast_eq_iff_heq {u v u' v' : U} (hu : u = u') (hv : v = v') (e : u ⟶ v) (e' : u' ⟶ v') :
    e.cast hu hv = e' ↔ HEq e e' := by
  rw [Hom.cast_eq_cast]
  exact _root_.cast_eq_iff_heq
#align quiver.hom.cast_eq_iff_heq Quiver.Hom.cast_eq_iff_heq

theorem Hom.eq_cast_iff_heq {u v u' v' : U} (hu : u = u') (hv : v = v') (e : u ⟶ v) (e' : u' ⟶ v') :
    e' = e.cast hu hv ↔ HEq e' e := by
  rw [eq_comm, Hom.cast_eq_iff_heq]
  exact ⟨HEq.symm, HEq.symm⟩
#align quiver.hom.eq_cast_iff_heq Quiver.Hom.eq_cast_iff_heq

/-!
### Rewriting paths along equalities of vertices
-/

open Path

/-- Change the endpoints of a path using equalities. -/
def Path.cast {u v u' v' : U} (hu : u = u') (hv : v = v') (p : Path u v) : Path u' v' :=
  Eq.ndrec (motive := λ x => Path x v') (Eq.ndrec p hv) hu
#align quiver.path.cast Quiver.Path.cast

theorem Path.cast_eq_cast {u v u' v' : U} (hu : u = u') (hv : v = v') (p : Path u v) :
    p.cast hu hv = _root_.cast (by rw [hu, hv]) p := by
  subst_vars
  rfl
#align quiver.path.cast_eq_cast Quiver.Path.cast_eq_cast

@[simp]
theorem Path.cast_rfl_rfl {u v : U} (p : Path u v) : p.cast rfl rfl = p :=
  rfl
#align quiver.path.cast_rfl_rfl Quiver.Path.cast_rfl_rfl

@[simp]
theorem Path.cast_cast {u v u' v' u'' v'' : U} (p : Path u v) (hu : u = u') (hv : v = v')
    (hu' : u' = u'') (hv' : v' = v'') :
    (p.cast hu hv).cast hu' hv' = p.cast (hu.trans hu') (hv.trans hv') := by
  subst_vars
  rfl
#align quiver.path.cast_cast Quiver.Path.cast_cast

@[simp]
theorem Path.cast_nil {u u' : U} (hu : u = u') : (Path.nil : Path u u).cast hu hu = Path.nil := by
  subst_vars
  rfl
#align quiver.path.cast_nil Quiver.Path.cast_nil

theorem Path.cast_heq {u v u' v' : U} (hu : u = u') (hv : v = v') (p : Path u v) :
    HEq (p.cast hu hv) p := by
  rw [Path.cast_eq_cast]
  exact _root_.cast_heq _ _
#align quiver.path.cast_heq Quiver.Path.cast_heq

theorem Path.eq_cast_iff_heq {u v u' v' : U} (hu : u = u') (hv : v = v') (p : Path u v)
    (p' : Path u' v') : p' = p.cast hu hv ↔ HEq p' p :=
  ⟨fun h => ((p.cast_eq_iff_heq hu hv p').1 h.symm).symm, fun h =>
    ((p.cast_eq_iff_heq hu hv p').2 h.symm).symm⟩
#align quiver.path.eq_cast_iff_heq Quiver.Path.eq_cast_iff_heq

theorem Path.cast_cons {u v w u' w' : U} (p : Path u v) (e : v ⟶ w) (hu : u = u') (hw : w = w') :
    (p.cons e).cast hu hw = (p.cast hu rfl).cons (e.cast rfl hw) := by
  subst_vars
  rfl
#align quiver.path.cast_cons Quiver.Path.cast_cons

theorem cast_eq_of_cons_eq_cons {u v v' w : U} {p : Path u v} {p' : Path u v'} {e : v ⟶ w}
    {e' : v' ⟶ w} (h : p.cons e = p'.cons e') : p.cast rfl (obj_eq_of_cons_eq_cons h) = p' := by
  rw [Path.cast_eq_iff_heq]
  exact heq_of_cons_eq_cons h
#align quiver.cast_eq_of_cons_eq_cons Quiver.cast_eq_of_cons_eq_cons

theorem hom_cast_eq_of_cons_eq_cons {u v v' w : U} {p : Path u v} {p' : Path u v'} {e : v ⟶ w}
    {e' : v' ⟶ w} (h : p.cons e = p'.cons e') : e.cast (obj_eq_of_cons_eq_cons h) rfl = e' := by
  rw [Hom.cast_eq_iff_heq]
  exact hom_heq_of_cons_eq_cons h
#align quiver.hom_cast_eq_of_cons_eq_cons Quiver.hom_cast_eq_of_cons_eq_cons

theorem eq_nil_of_length_zero {u v : U} (p : Path u v) (hzero : p.length = 0) :
    p.cast (eq_of_length_zero p hzero) rfl = Path.nil := by
  cases p <;> simp only [Nat.succ_ne_zero, length_cons] at hzero
  rfl
#align quiver.eq_nil_of_length_zero Quiver.eq_nil_of_length_zero

end Quiver


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Sébastien Gouëzel, Patrick Massot
-/
import topology.uniform_space.cauchy
import topology.uniform_space.separation
import topology.dense_embedding

/-!
# Uniform embeddings of uniform spaces.

Extension of uniform continuous functions.
-/

open filter topological_space set classical
open_locale classical uniformity topological_space filter

section
variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
universe u

/-- A map `f : α → β` between uniform spaces is called *uniform inducing* if the uniformity filter
on `α` is the pullback of the uniformity filter on `β` under `prod.map f f`. If `α` is a separated
space, then this implies that `f` is injective, hence it is a `uniform_embedding`. -/
structure uniform_inducing (f : α → β) : Prop :=
(comap_uniformity : comap (λx:α×α, (f x.1, f x.2)) (𝓤 β) = 𝓤 α)

lemma uniform_inducing.mk' {f : α → β} (h : ∀ s, s ∈ 𝓤 α ↔
    ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s) : uniform_inducing f :=
⟨by simp [eq_comm, filter.ext_iff, subset_def, h]⟩

lemma uniform_inducing_id : uniform_inducing (@id α) :=
⟨by rw [← prod.map_def, prod.map_id, comap_id]⟩

lemma uniform_inducing.comp {g : β → γ} (hg : uniform_inducing g)
  {f : α → β} (hf : uniform_inducing f) : uniform_inducing (g ∘ f) :=
⟨ by rw [show (λ (x : α × α), ((g ∘ f) x.1, (g ∘ f) x.2)) =
         (λ y : β × β, (g y.1, g y.2)) ∘ (λ x : α × α, (f x.1, f x.2)), by ext ; simp,
        ← filter.comap_comap, hg.1, hf.1]⟩

lemma uniform_inducing.basis_uniformity {f : α → β} (hf : uniform_inducing f)
  {ι : Sort*} {p : ι → Prop} {s : ι → set (β × β)} (H : (𝓤 β).has_basis p s) :
  (𝓤 α).has_basis p (λ i, prod.map f f ⁻¹' s i) :=
hf.1 ▸ H.comap _

lemma uniform_inducing_of_compose {f : α → β} {g : β → γ} (hf : uniform_continuous f)
  (hg : uniform_continuous g) (hgf : uniform_inducing (g ∘ f)) : uniform_inducing f :=
begin
  refine ⟨le_antisymm _ hf.le_comap⟩,
  rw [← hgf.1, ← prod.map_def, ← prod.map_def, ← prod.map_comp_map f f g g,
      ← @comap_comap _ _ _ _ (prod.map f f)],
  exact comap_mono hg.le_comap
end

/-- A map `f : α → β` between uniform spaces is a *uniform embedding* if it is uniform inducing and
injective. If `α` is a separated space, then the latter assumption follows from the former. -/
structure uniform_embedding (f : α → β) extends uniform_inducing f : Prop :=
(inj : function.injective f)

lemma uniform_embedding_subtype_val {p : α → Prop} :
  uniform_embedding (subtype.val : subtype p → α) :=
{ comap_uniformity := rfl,
  inj := subtype.val_injective }

lemma uniform_embedding_subtype_coe {p : α → Prop} :
  uniform_embedding (coe : subtype p → α) :=
uniform_embedding_subtype_val

lemma uniform_embedding_set_inclusion {s t : set α} (hst : s ⊆ t) :
  uniform_embedding (inclusion hst) :=
{ comap_uniformity :=
    by { erw [uniformity_subtype, uniformity_subtype, comap_comap], congr },
  inj := inclusion_injective hst }

lemma uniform_embedding.comp {g : β → γ} (hg : uniform_embedding g)
  {f : α → β} (hf : uniform_embedding f) : uniform_embedding (g ∘ f) :=
{ inj := hg.inj.comp hf.inj,
  ..hg.to_uniform_inducing.comp hf.to_uniform_inducing }

theorem uniform_embedding_def {f : α → β} :
  uniform_embedding f ↔ function.injective f ∧ ∀ s, s ∈ 𝓤 α ↔
    ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s :=
begin
  split,
  { rintro ⟨⟨h⟩, h'⟩,
    rw [eq_comm, filter.ext_iff] at h,
    simp [*, subset_def] },
  { rintro ⟨h, h'⟩,
    refine uniform_embedding.mk ⟨_⟩ h,
    rw [eq_comm, filter.ext_iff],
    simp [*, subset_def] }
end

theorem uniform_embedding_def' {f : α → β} :
  uniform_embedding f ↔ function.injective f ∧ uniform_continuous f ∧
    ∀ s, s ∈ 𝓤 α →
      ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s :=
by simp only [uniform_embedding_def, uniform_continuous_def]; exact
⟨λ ⟨I, H⟩, ⟨I, λ s su, (H _).2 ⟨s, su, λ x y, id⟩, λ s, (H s).1⟩,
 λ ⟨I, H₁, H₂⟩, ⟨I, λ s, ⟨H₂ s,
   λ ⟨t, tu, h⟩, mem_of_superset (H₁ t tu) (λ ⟨a, b⟩, h a b)⟩⟩⟩

lemma equiv.uniform_embedding {α β : Type*} [uniform_space α] [uniform_space β] (f : α ≃ β)
  (h₁ : uniform_continuous f) (h₂ : uniform_continuous f.symm) : uniform_embedding f :=
{ comap_uniformity :=
  begin
    refine le_antisymm _ _,
    { change comap (f.prod_congr f) _ ≤ _,
      rw ← map_equiv_symm (f.prod_congr f),
      exact h₂ },
    { rw ← map_le_iff_le_comap,
      exact h₁ }
  end,
  inj := f.injective }

theorem uniform_embedding_inl : uniform_embedding (sum.inl : α → α ⊕ β) :=
begin
  apply uniform_embedding_def.2 ⟨sum.inl_injective, λ s, ⟨_, _⟩⟩,
  { assume hs,
    refine ⟨(λ p : α × α, (sum.inl p.1, sum.inl p.2)) '' s ∪
      (λ p : β × β, (sum.inr p.1, sum.inr p.2)) '' univ, _, _⟩,
    { exact union_mem_uniformity_sum hs univ_mem },
    { simp } },
  { rintros ⟨t, ht, h't⟩,
    simp only [sum.uniformity, mem_sup, mem_map] at ht,
    apply filter.mem_of_superset ht.1,
    rintros ⟨x, y⟩ hx,
    exact h't _ _ hx }
end

theorem uniform_embedding_inr : uniform_embedding (sum.inr : β → α ⊕ β) :=
begin
  apply uniform_embedding_def.2 ⟨sum.inr_injective, λ s, ⟨_, _⟩⟩,
  { assume hs,
    refine ⟨(λ p : α × α, (sum.inl p.1, sum.inl p.2)) '' univ ∪
      (λ p : β × β, (sum.inr p.1, sum.inr p.2)) '' s, _, _⟩,
    { exact union_mem_uniformity_sum univ_mem hs },
    { simp } },
  { rintros ⟨t, ht, h't⟩,
    simp only [sum.uniformity, mem_sup, mem_map] at ht,
    apply filter.mem_of_superset ht.2,
    rintros ⟨x, y⟩ hx,
    exact h't _ _ hx }
end

/-- If the domain of a `uniform_inducing` map `f` is a `separated_space`, then `f` is injective,
hence it is a `uniform_embedding`. -/
protected theorem uniform_inducing.uniform_embedding [separated_space α] {f : α → β}
  (hf : uniform_inducing f) :
  uniform_embedding f :=
⟨hf, λ x y h, eq_of_uniformity_basis (hf.basis_uniformity (𝓤 β).basis_sets) $
  λ s hs, mem_preimage.2 $ mem_uniformity_of_eq hs h⟩

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is uniform inducing with respect to the discrete uniformity on `α`:
the preimage of `𝓤 β` under `prod.map f f` is the principal filter generated by the diagonal in
`α × α`. -/
lemma comap_uniformity_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  comap (prod.map f f) (𝓤 β) = 𝓟 id_rel :=
begin
  refine le_antisymm _ (@refl_le_uniformity α (uniform_space.comap f ‹_›)),
  calc comap (prod.map f f) (𝓤 β) ≤ comap (prod.map f f) (𝓟 s) : comap_mono (le_principal_iff.2 hs)
  ... = 𝓟 (prod.map f f ⁻¹' s) : comap_principal
  ... ≤ 𝓟 id_rel : principal_mono.2 _,
  rintro ⟨x, y⟩, simpa [not_imp_not] using hf x y
end

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is a uniform embedding with respect to the discrete uniformity on `α`. -/
lemma uniform_embedding_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  @uniform_embedding α β ⊥ ‹_› f :=
begin
  letI : uniform_space α := ⊥, haveI : separated_space α := separated_iff_t2.2 infer_instance,
  exact uniform_inducing.uniform_embedding ⟨comap_uniformity_of_spaced_out hs hf⟩
end

lemma uniform_inducing.uniform_continuous {f : α → β}
  (hf : uniform_inducing f) : uniform_continuous f :=
by simp [uniform_continuous, hf.comap_uniformity.symm, tendsto_comap]

lemma uniform_inducing.uniform_continuous_iff {f : α → β} {g : β → γ} (hg : uniform_inducing g) :
  uniform_continuous f ↔ uniform_continuous (g ∘ f) :=
by { dsimp only [uniform_continuous, tendsto],
  rw [← hg.comap_uniformity, ← map_le_iff_le_comap, filter.map_map] }

lemma uniform_inducing.inducing {f : α → β} (h : uniform_inducing f) : inducing f :=
begin
  refine ⟨eq_of_nhds_eq_nhds $ assume a, _ ⟩,
  rw [nhds_induced, nhds_eq_uniformity, nhds_eq_uniformity, ← h.comap_uniformity,
    comap_lift'_eq, comap_lift'_eq2],
  exacts [rfl, monotone_preimage]
end

lemma uniform_inducing.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_inducing e₁) (h₂ : uniform_inducing e₂) :
  uniform_inducing (λp:α×β, (e₁ p.1, e₂ p.2)) :=
⟨by simp [(∘), uniformity_prod, h₁.comap_uniformity.symm, h₂.comap_uniformity.symm,
           comap_inf, comap_comap]⟩

lemma uniform_inducing.dense_inducing {f : α → β} (h : uniform_inducing f) (hd : dense_range f) :
  dense_inducing f :=
{ dense   := hd,
  induced := h.inducing.induced }

lemma uniform_embedding.embedding {f : α → β} (h : uniform_embedding f) : embedding f :=
{ induced := h.to_uniform_inducing.inducing.induced,
  inj := h.inj }

lemma uniform_embedding.dense_embedding {f : α → β} (h : uniform_embedding f) (hd : dense_range f) :
  dense_embedding f :=
{ dense   := hd,
  inj     := h.inj,
  induced := h.embedding.induced }

lemma closed_embedding_of_spaced_out {α} [topological_space α] [discrete_topology α]
  [separated_space β] {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  closed_embedding f :=
begin
  unfreezingI { rcases (discrete_topology.eq_bot α) with rfl }, letI : uniform_space α := ⊥,
  exact { closed_range := is_closed_range_of_spaced_out hs hf,
          .. (uniform_embedding_of_spaced_out hs hf).embedding }
end

lemma closure_image_mem_nhds_of_uniform_inducing
  {s : set (α×α)} {e : α → β} (b : β)
  (he₁ : uniform_inducing e) (he₂ : dense_inducing e) (hs : s ∈ 𝓤 α) :
  ∃a, closure (e '' {a' | (a, a') ∈ s}) ∈ 𝓝 b :=
have s ∈ comap (λp:α×α, (e p.1, e p.2)) (𝓤 β),
  from he₁.comap_uniformity.symm ▸ hs,
let ⟨t₁, ht₁u, ht₁⟩ := this in
have ht₁ : ∀p:α×α, (e p.1, e p.2) ∈ t₁ → p ∈ s, from ht₁,
let ⟨t₂, ht₂u, ht₂s, ht₂c⟩ := comp_symm_of_uniformity ht₁u in
let ⟨t, htu, hts, htc⟩ := comp_symm_of_uniformity ht₂u in
have preimage e {b' | (b, b') ∈ t₂} ∈ comap e (𝓝 b),
  from preimage_mem_comap $ mem_nhds_left b ht₂u,
let ⟨a, (ha : (b, e a) ∈ t₂)⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
have ∀b' (s' : set (β × β)), (b, b') ∈ t → s' ∈ 𝓤 β →
  ({y : β | (b', y) ∈ s'} ∩ e '' {a' : α | (a, a') ∈ s}).nonempty,
  from assume b' s' hb' hs',
  have preimage e {b'' | (b', b'') ∈ s' ∩ t} ∈ comap e (𝓝 b'),
    from preimage_mem_comap $ mem_nhds_left b' $ inter_mem hs' htu,
  let ⟨a₂, ha₂s', ha₂t⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
  have (e a, e a₂) ∈ t₁,
    from ht₂c $ prod_mk_mem_comp_rel (ht₂s ha) $ htc $ prod_mk_mem_comp_rel hb' ha₂t,
  have e a₂ ∈ {b'':β | (b', b'') ∈ s'} ∩ e '' {a' | (a, a') ∈ s},
    from ⟨ha₂s', mem_image_of_mem _ $ ht₁ (a, a₂) this⟩,
  ⟨_, this⟩,
have ∀b', (b, b') ∈ t → ne_bot (𝓝 b' ⊓ 𝓟 (e '' {a' | (a, a') ∈ s})),
begin
  intros b' hb',
  rw [nhds_eq_uniformity, lift'_inf_principal_eq, lift'_ne_bot_iff],
  exact assume s, this b' s hb',
  exact monotone_preimage.inter monotone_const
end,
have ∀b', (b, b') ∈ t → b' ∈ closure (e '' {a' | (a, a') ∈ s}),
  from assume b' hb', by rw [closure_eq_cluster_pts]; exact this b' hb',
⟨a, (𝓝 b).sets_of_superset (mem_nhds_left b htu) this⟩

lemma uniform_embedding_subtype_emb (p : α → Prop) {e : α → β} (ue : uniform_embedding e)
  (de : dense_embedding e) : uniform_embedding (dense_embedding.subtype_emb p e) :=
{ comap_uniformity := by simp [comap_comap, (∘), dense_embedding.subtype_emb,
           uniformity_subtype, ue.comap_uniformity.symm],
  inj := (de.subtype p).inj }

lemma uniform_embedding.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_embedding e₁) (h₂ : uniform_embedding e₂) :
  uniform_embedding (λp:α×β, (e₁ p.1, e₂ p.2)) :=
{ inj := h₁.inj.prod_map h₂.inj,
  ..h₁.to_uniform_inducing.prod h₂.to_uniform_inducing }

lemma is_complete_of_complete_image {m : α → β} {s : set α} (hm : uniform_inducing m)
  (hs : is_complete (m '' s)) : is_complete s :=
begin
  intros f hf hfs,
  rw le_principal_iff at hfs,
  obtain ⟨_, ⟨x, hx, rfl⟩, hyf⟩ : ∃ y ∈ m '' s, map m f ≤ 𝓝 y,
    from hs (f.map m) (hf.map hm.uniform_continuous)
      (le_principal_iff.2 (image_mem_map hfs)),
  rw [map_le_iff_le_comap, ← nhds_induced, ← hm.inducing.induced] at hyf,
  exact ⟨x, hx, hyf⟩
end

lemma is_complete.complete_space_coe {s : set α} (hs : is_complete s) :
  complete_space s :=
complete_space_iff_is_complete_univ.2 $
  is_complete_of_complete_image uniform_embedding_subtype_coe.to_uniform_inducing $ by simp [hs]

/-- A set is complete iff its image under a uniform inducing map is complete. -/
lemma is_complete_image_iff {m : α → β} {s : set α} (hm : uniform_inducing m) :
  is_complete (m '' s) ↔ is_complete s :=
begin
  refine ⟨is_complete_of_complete_image hm, λ c, _⟩,
  haveI : complete_space s := c.complete_space_coe,
  set m' : s → β := m ∘ coe,
  suffices : is_complete (range m'), by rwa [range_comp, subtype.range_coe] at this,
  have hm' : uniform_inducing m' := hm.comp uniform_embedding_subtype_coe.to_uniform_inducing,
  intros f hf hfm,
  rw filter.le_principal_iff at hfm,
  have cf' : cauchy (comap m' f) :=
    hf.comap' hm'.comap_uniformity.le (ne_bot.comap_of_range_mem hf.1 hfm),
  rcases complete_space.complete cf' with ⟨x, hx⟩,
  rw [hm'.inducing.nhds_eq_comap, comap_le_comap_iff hfm] at hx,
  use [m' x, mem_range_self _, hx]
end

lemma complete_space_iff_is_complete_range {f : α → β} (hf : uniform_inducing f) :
  complete_space α ↔ is_complete (range f) :=
by rw [complete_space_iff_is_complete_univ, ← is_complete_image_iff hf, image_univ]

lemma uniform_inducing.is_complete_range [complete_space α] {f : α → β}
  (hf : uniform_inducing f) :
  is_complete (range f) :=
(complete_space_iff_is_complete_range hf).1 ‹_›

lemma complete_space_congr {e : α ≃ β} (he : uniform_embedding e) :
  complete_space α ↔ complete_space β :=
by rw [complete_space_iff_is_complete_range he.to_uniform_inducing, e.range_eq_univ,
  complete_space_iff_is_complete_univ]

lemma complete_space_coe_iff_is_complete {s : set α} :
  complete_space s ↔ is_complete s :=
(complete_space_iff_is_complete_range uniform_embedding_subtype_coe.to_uniform_inducing).trans $
  by rw [subtype.range_coe]

lemma is_closed.complete_space_coe [complete_space α] {s : set α} (hs : is_closed s) :
  complete_space s :=
hs.is_complete.complete_space_coe

lemma complete_space_extension {m : β → α} (hm : uniform_inducing m) (dense : dense_range m)
  (h : ∀f:filter β, cauchy f → ∃x:α, map m f ≤ 𝓝 x) : complete_space α :=
⟨assume (f : filter α), assume hf : cauchy f,
let
  p : set (α × α) → set α → set α := λs t, {y : α| ∃x:α, x ∈ t ∧ (x, y) ∈ s},
  g := (𝓤 α).lift (λs, f.lift' (p s))
in
have mp₀ : monotone p,
  from assume a b h t s ⟨x, xs, xa⟩, ⟨x, xs, h xa⟩,
have mp₁ : ∀{s}, monotone (p s),
  from assume s a b h x ⟨y, ya, yxs⟩, ⟨y, h ya, yxs⟩,

have f ≤ g, from
  le_infi $ assume s, le_infi $ assume hs, le_infi $ assume t, le_infi $ assume ht,
  le_principal_iff.mpr $
  mem_of_superset ht $ assume x hx, ⟨x, hx, refl_mem_uniformity hs⟩,

have ne_bot g, from hf.left.mono this,

have ne_bot (comap m g), from comap_ne_bot $ assume t ht,
  let ⟨t', ht', ht_mem⟩ := (mem_lift_sets $ monotone_lift' monotone_const mp₀).mp ht in
  let ⟨t'', ht'', ht'_sub⟩ := (mem_lift'_sets mp₁).mp ht_mem in
  let ⟨x, (hx : x ∈ t'')⟩ := hf.left.nonempty_of_mem ht'' in
  have h₀ : ne_bot (𝓝[range m] x),
    from dense.nhds_within_ne_bot x,
  have h₁ : {y | (x, y) ∈ t'} ∈ 𝓝[range m] x,
    from @mem_inf_of_left α (𝓝 x) (𝓟 (range m)) _ $ mem_nhds_left x ht',
  have h₂ : range m ∈ 𝓝[range m] x,
    from @mem_inf_of_right α (𝓝 x) (𝓟 (range m)) _ $ subset.refl _,
  have {y | (x, y) ∈ t'} ∩ range m ∈ 𝓝[range m] x,
    from @inter_mem α (𝓝[range m] x) _ _ h₁ h₂,
  let ⟨y, xyt', b, b_eq⟩ := h₀.nonempty_of_mem this in
  ⟨b, b_eq.symm ▸ ht'_sub ⟨x, hx, xyt'⟩⟩,

have cauchy g, from
  ⟨‹ne_bot g›, assume s hs,
  let
    ⟨s₁, hs₁, (comp_s₁ : comp_rel s₁ s₁ ⊆ s)⟩ := comp_mem_uniformity_sets hs,
    ⟨s₂, hs₂, (comp_s₂ : comp_rel s₂ s₂ ⊆ s₁)⟩ := comp_mem_uniformity_sets hs₁,
    ⟨t, ht, (prod_t : t ×ˢ t ⊆ s₂)⟩ := mem_prod_same_iff.mp (hf.right hs₂)
  in
  have hg₁ : p (preimage prod.swap s₁) t ∈ g,
    from mem_lift (symm_le_uniformity hs₁) $ @mem_lift' α α f _ t ht,
  have hg₂ : p s₂ t ∈ g,
    from mem_lift hs₂ $ @mem_lift' α α f _ t ht,
  have hg : p (prod.swap ⁻¹' s₁) t ×ˢ p s₂ t ∈ g ×ᶠ g,
    from @prod_mem_prod α α _ _ g g hg₁ hg₂,
  (g ×ᶠ g).sets_of_superset hg
    (assume ⟨a, b⟩ ⟨⟨c₁, c₁t, hc₁⟩, ⟨c₂, c₂t, hc₂⟩⟩,
      have (c₁, c₂) ∈ t ×ˢ t, from ⟨c₁t, c₂t⟩,
      comp_s₁ $ prod_mk_mem_comp_rel hc₁ $
      comp_s₂ $ prod_mk_mem_comp_rel (prod_t this) hc₂)⟩,

have cauchy (filter.comap m g),
  from ‹cauchy g›.comap' (le_of_eq hm.comap_uniformity) ‹_›,

let ⟨x, (hx : map m (filter.comap m g) ≤ 𝓝 x)⟩ := h _ this in
have cluster_pt x (map m (filter.comap m g)),
  from (le_nhds_iff_adhp_of_cauchy (this.map hm.uniform_continuous)).mp hx,
have cluster_pt x g,
  from  this.mono map_comap_le,

⟨x, calc f ≤ g : by assumption
  ... ≤ 𝓝 x : le_nhds_of_cauchy_adhp ‹cauchy g› this⟩⟩

lemma totally_bounded_preimage {f : α → β} {s : set β} (hf : uniform_embedding f)
  (hs : totally_bounded s) : totally_bounded (f ⁻¹' s) :=
λ t ht, begin
  rw ← hf.comap_uniformity at ht,
  rcases mem_comap.2 ht with ⟨t', ht', ts⟩,
  rcases totally_bounded_iff_subset.1
    (totally_bounded_subset (image_preimage_subset f s) hs) _ ht' with ⟨c, cs, hfc, hct⟩,
  refine ⟨f ⁻¹' c, hfc.preimage (hf.inj.inj_on _), λ x h, _⟩,
  have := hct (mem_image_of_mem f h), simp at this ⊢,
  rcases this with ⟨z, zc, zt⟩,
  rcases cs zc with ⟨y, yc, rfl⟩,
  exact ⟨y, zc, ts (by exact zt)⟩
end

instance complete_space.sum [complete_space α] [complete_space β] :
  complete_space (α ⊕ β) :=
begin
  rw complete_space_iff_is_complete_univ,
  have A : is_complete (range (sum.inl : α → α ⊕ β)) :=
    uniform_embedding_inl.to_uniform_inducing.is_complete_range,
  have B : is_complete (range (sum.inr : β → α ⊕ β)) :=
    uniform_embedding_inr.to_uniform_inducing.is_complete_range,
  convert A.union B,
  apply (eq_univ_of_forall (λ x, _)).symm,
  cases x,
  { left, exact mem_range_self _ },
  { right, exact mem_range_self _ }
end

end

lemma uniform_embedding_comap {α : Type*} {β : Type*} {f : α → β} [u : uniform_space β]
  (hf : function.injective f) : @uniform_embedding α β (uniform_space.comap f u) u f :=
@uniform_embedding.mk _ _ (uniform_space.comap f u) _ _
  (@uniform_inducing.mk _ _ (uniform_space.comap f u) _ _ rfl) hf

/-- Pull back a uniform space structure by an embedding, adjusting the new uniform structure to
make sure that its topology is defeq to the original one. -/
def embedding.comap_uniform_space {α β} [topological_space α] [u : uniform_space β] (f : α → β)
  (h : embedding f) : uniform_space α :=
(u.comap f).replace_topology h.induced

lemma embedding.to_uniform_embedding {α β} [topological_space α] [u : uniform_space β] (f : α → β)
  (h : embedding f) :
  @uniform_embedding α β (h.comap_uniform_space f) u f :=
{ comap_uniformity := rfl,
  inj := h.inj }

section uniform_extension

variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
          {e : β → α}
          (h_e : uniform_inducing e)
          (h_dense : dense_range e)
          {f : β → γ}
          (h_f : uniform_continuous f)

local notation `ψ` := (h_e.dense_inducing h_dense).extend f

lemma uniformly_extend_exists [complete_space γ] (a : α) :
  ∃c, tendsto f (comap e (𝓝 a)) (𝓝 c) :=
let de := (h_e.dense_inducing h_dense) in
have cauchy (𝓝 a), from cauchy_nhds,
have cauchy (comap e (𝓝 a)), from
  this.comap' (le_of_eq h_e.comap_uniformity) (de.comap_nhds_ne_bot _),
have cauchy (map f (comap e (𝓝 a))), from this.map h_f,
complete_space.complete this

lemma uniform_extend_subtype [complete_space γ]
  {p : α → Prop} {e : α → β} {f : α → γ} {b : β} {s : set α}
  (hf : uniform_continuous (λx:subtype p, f x.val))
  (he : uniform_embedding e) (hd : ∀x:β, x ∈ closure (range e))
  (hb : closure (e '' s) ∈ 𝓝 b) (hs : is_closed s) (hp : ∀x∈s, p x) :
  ∃c, tendsto f (comap e (𝓝 b)) (𝓝 c) :=
have de : dense_embedding e,
  from he.dense_embedding hd,
have de' : dense_embedding (dense_embedding.subtype_emb p e),
  by exact de.subtype p,
have ue' : uniform_embedding (dense_embedding.subtype_emb p e),
  from uniform_embedding_subtype_emb _ he de,
have b ∈ closure (e '' {x | p x}),
  from (closure_mono $ monotone_image $ hp) (mem_of_mem_nhds hb),
let ⟨c, (hc : tendsto (f ∘ subtype.val)
     (comap (dense_embedding.subtype_emb p e) (𝓝 ⟨b, this⟩)) (𝓝 c))⟩ :=
  uniformly_extend_exists ue'.to_uniform_inducing de'.dense hf _ in
begin
  rw [nhds_subtype_eq_comap] at hc,
  simp [comap_comap] at hc,
  change (tendsto (f ∘ @subtype.val α p) (comap (e ∘ @subtype.val α p) (𝓝 b)) (𝓝 c)) at hc,
  rw [←comap_comap, tendsto_comap'_iff] at hc,
  exact ⟨c, hc⟩,
  exact ⟨_, hb, assume x,
    begin
      change e x ∈ (closure (e '' s)) → x ∈ range subtype.val,
      rw [← closure_induced, mem_closure_iff_cluster_pt, cluster_pt, ne_bot_iff,
          nhds_induced, ← de.to_dense_inducing.nhds_eq_comap,
          ← mem_closure_iff_nhds_ne_bot, hs.closure_eq],
      exact assume hxs, ⟨⟨x, hp x hxs⟩, rfl⟩,
    end⟩
end

include h_f

lemma uniformly_extend_spec [complete_space γ] (a : α) :
  tendsto f (comap e (𝓝 a)) (𝓝 (ψ a)) :=
by simpa only [dense_inducing.extend] using tendsto_nhds_lim (uniformly_extend_exists h_e ‹_› h_f _)

lemma uniform_continuous_uniformly_extend [cγ : complete_space γ] : uniform_continuous ψ :=
assume d hd,
let ⟨s, hs, hs_comp⟩ := (mem_lift'_sets $
  monotone_comp_rel monotone_id $ monotone_comp_rel monotone_id monotone_id).mp
    (comp_le_uniformity3 hd) in
have h_pnt : ∀{a m}, m ∈ 𝓝 a → ∃c, c ∈ f '' preimage e m ∧ (c, ψ a) ∈ s ∧ (ψ a, c) ∈ s,
  from assume a m hm,
  have nb : ne_bot (map f (comap e (𝓝 a))),
    from ((h_e.dense_inducing h_dense).comap_nhds_ne_bot _).map _,
  have (f '' preimage e m) ∩ ({c | (c, ψ a) ∈ s } ∩ {c | (ψ a, c) ∈ s }) ∈ map f (comap e (𝓝 a)),
    from inter_mem (image_mem_map $ preimage_mem_comap $ hm)
      (uniformly_extend_spec h_e h_dense h_f _
        (inter_mem (mem_nhds_right _ hs) (mem_nhds_left _ hs))),
  nb.nonempty_of_mem this,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ 𝓤 β,
  from h_f hs,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ comap (λx:β×β, (e x.1, e x.2)) (𝓤 α),
  by rwa [h_e.comap_uniformity.symm] at this,
let ⟨t, ht, ts⟩ := this in
show preimage (λp:(α×α), (ψ p.1, ψ p.2)) d ∈ 𝓤 α,
  from (𝓤 α).sets_of_superset (interior_mem_uniformity ht) $
  assume ⟨x₁, x₂⟩ hx_t,
  have 𝓝 (x₁, x₂) ≤ 𝓟 (interior t),
    from is_open_iff_nhds.mp is_open_interior (x₁, x₂) hx_t,
  have interior t ∈ 𝓝 x₁ ×ᶠ 𝓝 x₂,
    by rwa [nhds_prod_eq, le_principal_iff] at this,
  let ⟨m₁, hm₁, m₂, hm₂, (hm : m₁ ×ˢ m₂ ⊆ interior t)⟩ := mem_prod_iff.mp this in
  let ⟨a, ha₁, _, ha₂⟩ := h_pnt hm₁ in
  let ⟨b, hb₁, hb₂, _⟩ := h_pnt hm₂ in
  have (e ⁻¹' m₁) ×ˢ (e ⁻¹' m₂) ⊆ (λ p : β × β, (f p.1, f p.2)) ⁻¹' s,
    from calc _ ⊆ preimage (λp:(β×β), (e p.1, e p.2)) (interior t) : preimage_mono hm
    ... ⊆ preimage (λp:(β×β), (e p.1, e p.2)) t : preimage_mono interior_subset
    ... ⊆ preimage (λp:(β×β), (f p.1, f p.2)) s : ts,
  have (f '' (e ⁻¹' m₁)) ×ˢ (f '' (e ⁻¹' m₂)) ⊆ s,
    from calc (f '' (e ⁻¹' m₁)) ×ˢ (f '' (e ⁻¹' m₂)) =
      (λp:(β×β), (f p.1, f p.2)) '' ((e ⁻¹' m₁) ×ˢ (e ⁻¹' m₂)) : prod_image_image_eq
    ... ⊆ (λp:(β×β), (f p.1, f p.2)) '' ((λp:(β×β), (f p.1, f p.2)) ⁻¹' s) : monotone_image this
    ... ⊆ s : image_preimage_subset _ _,
  have (a, b) ∈ s, from @this (a, b) ⟨ha₁, hb₁⟩,
  hs_comp $ show (ψ x₁, ψ x₂) ∈ comp_rel s (comp_rel s s),
    from ⟨a, ha₂, ⟨b, this, hb₂⟩⟩

omit h_f

variables [separated_space γ]

lemma uniformly_extend_of_ind (b : β) : ψ (e b) = f b :=
dense_inducing.extend_eq_at _ h_f.continuous.continuous_at

lemma uniformly_extend_unique {g : α → γ} (hg : ∀ b, g (e b) = f b)
  (hc : continuous g) :
  ψ = g :=
dense_inducing.extend_unique _ hg hc

end uniform_extension