import Lib.Tactic

def Injective (f : α → β) :=
∀ x y, f x = f y → x = y

def Surjective (f : α → β) :=
∀ y, ∃ x, f x = y

abbrev LeftInv (f : α → β) (g : β → α) :=
g ∘ f = id

theorem LeftInv.apply {f : α → β} {g} (H : LeftInv f g) x :
  g (f x) = x := congrFun H x

abbrev RightInv (f : α → β) (g : β → α) :=
f ∘ g = id

theorem RightInv.apply {f : α → β} {g} (H : RightInv f g) x :
  f (g x) = x := congrFun H x

def HasLeftInv (f : α → β) :=
∃ g, LeftInv f g

@[auto]
theorem HasLeftInv.intro (f : α → β) {g}
  (H : LeftInv f g) : HasLeftInv f :=
⟨ g, H ⟩

abbrev LeftInv.toHasLeftInv := @HasLeftInv.intro

def HasRightInv (f : α → β) :=
∃ g, RightInv f g

@[auto]
theorem HasRightInv.intro (f : α → β) {g}
  (H : RightInv f g) : HasRightInv f :=
⟨ g, H ⟩

abbrev RightInv.toHasRightInv := @HasRightInv.intro

noncomputable def inv [Nonempty α] (f : α → β) (b : β) :=
Classical.epsilon λ a => f a = b

theorem inv_comp_of_injective [Nonempty α] {f : α → β}
        (h : Injective f) :
  inv f ∘ f = id := by
apply funext; intros x; simp [inv]
apply h
apply Classical.epsilon_spec (p := λ y => f y = f x)
exists x

theorem comp_inv_of_surjective [Nonempty α] {f : α → β}
        (h : Surjective f) :
  f ∘ inv f = id := by
apply funext; intros x; simp [inv]
apply Classical.epsilon_spec (p := λ y => f y = x)
apply h

@[auto]
theorem HasLeftInv_of_Injective [Nonempty α] {f : α → β}
        (h : Injective f) :
  HasLeftInv f := by
exists inv f; apply inv_comp_of_injective h

@[auto]
theorem Injective_of_LeftInv {f : α → β} {g}
        (hg : LeftInv f g) :
  Injective f := by
intros x y Hxy
rw [← hg.apply x, Hxy, hg.apply]

@[auto]
theorem Injective_of_HasLeftInv  {f : α → β}
        (h : HasLeftInv f) :
  Injective f := by
obtain ⟨g,hg⟩ from h;
apply Injective_of_LeftInv; assumption

theorem HasLeftInv_iff_Injective [Nonempty α] {f : α → β} :
  HasLeftInv f ↔ Injective f := by auto

@[auto]
theorem HasRightInv_of_Surjective [Nonempty α] {f : α → β}
        (h : Surjective f) :
  HasRightInv f := by
exists inv f; apply comp_inv_of_surjective h

@[auto]
theorem Surjective_of_RightInv {f : α → β} {g}
        (hg : RightInv f g) :
  Surjective f := by
intros x
exists g x; rw [hg.apply]

@[auto]
theorem Surjective_of_HasRightInv {f : α → β}
        (h : HasRightInv f) :
  Surjective f := by
obtain ⟨g, hg⟩ from h;
apply Surjective_of_RightInv; assumption

theorem HasRightInv_iff_Surjective [Nonempty α] {f : α → β} :
  HasRightInv f ↔ Surjective f := by auto

@[simp]
theorem flip_eq {α β γ} (f : α → β → γ) x y :
  flip f x y = f y x := rfl

@[simp]
theorem flip_flip {α β γ} (f : α → β → γ) :
  flip (flip f) = f := rfl

theorem comp_lam {α β γ} (f : α → β) (g : β → γ) :
  (g ∘ λ a => f a) = λ a => g (f a) := rfl

@[simp]
def curry (f : α × β → γ) (x : α) (y : β) := f (x, y)

@[simp]
def uncurry (f : α → β → γ) : α × β → γ
| (x, y) => f x y


import tuto_lib

set_option pp.beta true
set_option pp.coercions false

/-
This is the final file in the series. Here we use everything covered
in previous files to prove a couple of famous theorems from
elementary real analysis. Of course they all have more general versions
in mathlib.

As usual, keep in mind the following:

  abs_le {x y : ℝ} : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

  ge_max_iff (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

  le_max_left p q : p ≤ max p q

  le_max_right p q : q ≤ max p q

as well as a lemma from the previous file:

  le_of_le_add_all : (∀ ε > 0, y ≤ x + ε) →  y ≤ x

Let's start with a variation on a known exercise.
-/

-- 0071
lemma le_lim {x y : ℝ} {u : ℕ → ℝ} (hu : seq_limit u x)
  (ineg : ∃ N, ∀ n ≥ N, y ≤ u n) : y ≤ x :=
begin
  apply le_of_le_add_all, intros ε ε_pos,
  cases ineg with N hN, cases hu ε ε_pos with N' hN',
  specialize hN  (max N N') (le_max_left _ _),
  specialize hN' (max N N') (le_max_right _ _), rw abs_le at hN', linarith,
end

/-
Let's now return to the result proved in the `00_` file of this series,
and prove again the sequential characterization of upper bounds (with a slighly
different proof).

For this, and other exercises below, we'll need many things that we proved in previous files,
and a couple of extras.

From the 5th file:

  limit_const (x : ℝ) : seq_limit (λ n, x) x

  squeeze (lim_u : seq_limit u l) (lim_w : seq_limit w l)
    (hu : ∀ n, u n ≤ v n) (hw : ∀ n, v n ≤ w n)  : seq_limit v l

From the 8th:

  def upper_bound (A : set ℝ) (x : ℝ) := ∀ a ∈ A, a ≤ x

  def is_sup (A : set ℝ) (x : ℝ) := upper_bound A x ∧ ∀ y, upper_bound A y → x ≤ y

  lt_sup (hx : is_sup A x) : ∀ y, y < x → ∃ a ∈ A, y < a :=

You can also use:

  nat.one_div_pos_of_nat {n : ℕ} : 0 < 1 / (n + 1 : ℝ)

  inv_succ_le_all :  ∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, 1/(n + 1 : ℝ) ≤ ε

and their easy consequences:

  limit_of_sub_le_inv_succ (h : ∀ n, |u n - x| ≤ 1/(n+1)) : seq_limit u x

  limit_const_add_inv_succ (x : ℝ) : seq_limit (λ n, x + 1/(n+1)) x

  limit_const_sub_inv_succ (x : ℝ) : seq_limit (λ n, x - 1/(n+1)) x

The structure of the proof is offered. It features a new tactic:
`choose` which invokes the axiom of choice (observing the tactic state before and
after using it should be enough to understand everything).
-/

-- 0072
lemma is_sup_iff (A : set ℝ) (x : ℝ) :
(is_sup A x) ↔ (upper_bound A x ∧ ∃ u : ℕ → ℝ, seq_limit u x ∧ ∀ n, u n ∈ A ) :=
begin
  split,
  { intro h,
    split,
    {
      exact h.1,
    },
    { have : ∀ n : ℕ, ∃ a ∈ A, x - 1/(n+1) < a,
      { intros n,
        have : 1/(n+1 : ℝ) > 0,
          exact nat.one_div_pos_of_nat,
        apply lt_sup h, linarith,
      },
      choose u hu using this,
      use u, split, apply limit_of_sub_le_inv_succ, intro n, rw abs_le,
      split; linarith[(hu n).2, h.1 (u n) (hu n).1],
      intro n, exact (hu n).1,
  } },
  { rintro ⟨maj, u, limu, u_in⟩,
    split, exact maj, intros y hy, apply lim_le limu, intro n, exact hy (u n) (u_in n),
  },
end

/-- Continuity of a function at a point  -/
def continuous_at_pt (f : ℝ → ℝ) (x₀ : ℝ) : Prop :=
∀ ε > 0, ∃ δ > 0, ∀ x, |x - x₀| ≤ δ → |f x - f x₀| ≤ ε

variables {f : ℝ → ℝ} {x₀ : ℝ} {u : ℕ → ℝ}

-- 0073
lemma seq_continuous_of_continuous (hf : continuous_at_pt f x₀)
  (hu : seq_limit u x₀) : seq_limit (f ∘ u) (f x₀) :=
begin
  intros ε ε_pos, rcases hf ε ε_pos with ⟨δ, δ_pos, hδ⟩,
  rcases hu δ δ_pos with ⟨N,hN⟩, use N, intros n hn,
  exact hδ (u n) (hN n hn),
end

-- 0074
example :
  (∀ u : ℕ → ℝ, seq_limit u x₀ → seq_limit (f ∘ u) (f x₀)) →
  continuous_at_pt f x₀ :=
begin
  intro h, by_contradiction hyp, unfold continuous_at_pt at hyp, push_neg at hyp,
  rcases hyp with ⟨ε,ε_pos,hyp⟩,
  have j : ∀ (n : ℕ), ∃ (x : ℝ), |x - x₀| ≤ (1/(n+1)) ∧ ε < |f x - f x₀|,
  intros n, exact hyp (1/(n+1)) (nat.one_div_pos_of_nat), clear hyp,
  choose u hu using j, have k := h u,
  have lim : seq_limit u x₀, {apply limit_of_sub_le_inv_succ, intro n, exact (hu n).left},
  have limf := k lim, rcases limf ε ε_pos with ⟨N,hN⟩,
  specialize hN N (by linarith), specialize hu N, linarith,
end

/-
Recall from the 6th file:

  def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m

  def cluster_point (u : ℕ → ℝ) (a : ℝ) :=
    ∃ φ, extraction φ ∧ seq_limit (u ∘ φ) a

  id_le_extraction : extraction φ → ∀ n, n ≤ φ n

and from the 8th file:

  def tendsto_infinity (u : ℕ → ℝ) := ∀ A, ∃ N, ∀ n ≥ N, u n ≥ A

  not_seq_limit_of_tendstoinfinity : tendsto_infinity u → ∀ l, ¬ seq_limit u l
-/

variables {φ : ℕ → ℕ}

-- 0075
lemma subseq_tendstoinfinity
  (h : tendsto_infinity u) (hφ : extraction φ) :
tendsto_infinity (u ∘ φ) :=
begin
  intro A, cases h A with N hN, use N, intros n hn, apply hN,
  by_cases j : (n = N), rw j, exact id_le_extraction hφ N, unfold extraction at hφ,
  change n≠N at j, have k : n > N, exact (ne.symm j).lt_of_le hn,
  have l := hφ N n (by linarith),
  linarith [id_le_extraction hφ N],
end

-- 0076
lemma squeeze_infinity {u v : ℕ → ℝ} (hu : tendsto_infinity u)
(huv : ∀ n, u n ≤ v n) : tendsto_infinity v :=
begin
  intro A, rcases hu A with ⟨N, hN⟩, use N, intros n hn,
  specialize hN n hn, specialize huv n, linarith,
end

/-
We will use segments: Icc a b := { x | a ≤ x ∧ x ≤ b }
The notation stands for Interval-closed-closed. Variations exist with
o or i instead of c, where o stands for open and i for infinity.

We will use the following version of Bolzano-Weierstrass

  bolzano_weierstrass (h : ∀ n, u n ∈ [a, b]) :
    ∃ c ∈ [a, b], cluster_point u c

as well as the obvious

  seq_limit_id : tendsto_infinity (λ n, n)
-/
open set

-- 0077
lemma bdd_above_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ M, ∀ x ∈ Icc a b, f x ≤ M :=
begin
  by_contradiction hyp, push_neg at hyp,
  have j : ∀ (n : ℕ), ∃ (x : ℝ), x ∈ Icc a b ∧ ↑n < f x,
  intro n, exact hyp n, clear hyp,
  choose u hu using j,
  have h : ∀ n, u n ∈ Icc a b, intro n, exact (hu n).left,
  have k : ∀ n, ↑n ≤ f(u n), intro n, linarith[(hu n).right], clear hu,
  have j := bolzano_weierstrass h, clear h,
  rcases j with ⟨c, cin, hc⟩,
  rcases hc with ⟨φ, hφ, hlim⟩,
  change seq_limit (u ∘ φ) c at hlim,
  have j : seq_limit (f ∘ u ∘ φ) (f c),
  from seq_continuous_of_continuous (hf c cin) (hlim),
  clear hlim cin hf,
  have jj := squeeze_infinity seq_limit_id k,
  have l := subseq_tendstoinfinity jj hφ,
  exact not_seq_limit_of_tendstoinfinity l (f c) j,
end

/-
In the next exercise, we can use:

  abs_neg x : |-x| = |x|
-/

-- 0078
lemma continuous_opposite {f : ℝ → ℝ} {x₀ : ℝ} (h : continuous_at_pt f x₀) :
  continuous_at_pt (λ x, -f x) x₀ :=
begin
  intros ε ε_pos,
  rcases h ε ε_pos with ⟨δ, δ_pos, hδ⟩,
  use [δ, δ_pos], intros x hx, specialize hδ x hx,
  rw ← abs_neg, ring_nf, exact hδ,
end

/-
Now let's combine the two exercises above
-/

-- 0079
lemma bdd_below_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ m, ∀ x ∈ Icc a b, m ≤ f x :=
begin
  have j : ∀ x ∈ Icc a b, continuous_at_pt (-f) x,
  {intros x H, exact continuous_opposite (hf x H)},
  clear hf,
  have k := bdd_above_segment j, clear j,
  rcases k with ⟨M,h⟩,
  use (-M), intros x H, specialize h x H, change - (f x) ≤ M at h,  linarith,
end

/-
Remember from the 5th file:

 unique_limit : seq_limit u l → seq_limit u l' → l = l'

and from the 6th one:

  subseq_tendsto_of_tendsto (h : seq_limit u l) (hφ : extraction φ) :
    seq_limit (u ∘ φ) l

We now admit the following version of the least upper bound theorem
(that cannot be proved without discussing the construction of real numbers
or admitting another strong theorem).

sup_segment {a b : ℝ} {A : set ℝ} (hnonvide : ∃ x, x ∈ A) (h : A ⊆ Icc a b) :
  ∃ x ∈ Icc a b, is_sup A x

In the next exercise, it can be useful to prove inclusions of sets of real number.
By definition, A ⊆ B means : ∀ x, x ∈ A → x ∈ B.
Hence one can start a proof of A ⊆ B by `intros x x_in`,
which brings `x : ℝ` and `x_in : x ∈ A` in the local context,
and then prove `x ∈ B`.

Note also the use of
  {x | P x}
which denotes the set of x satisfying predicate P.

Hence `x' ∈ { x | P x} ↔ P x'`, by definition.
-/

-- 0080
example {a b : ℝ} (hab : a ≤ b) (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ x₀ ∈ Icc a b, ∀ x ∈ Icc a b, f x ≤ f x₀ :=
begin
  cases bdd_above_segment hf with M hM,
  cases bdd_below_segment hf with m hm,
  let A := { (f x) | x ∈ Icc a b},
  have hnonvide : ∃ x, x ∈ A, use (f a), use a, split,
  split; linarith, linarith,
  have h : A ⊆ Icc m M, intros y y_in, rcases y_in with ⟨x, hx, hxx⟩, split,
  rw ← hxx, apply (hm x hx), rw ← hxx, apply (hM x hx),
  have j := sup_segment hnonvide h,
  rcases j with ⟨y,yin,hy⟩,
  have k := (is_sup_iff A y).1 hy, clear hM hm h yin hy hnonvide,
  cases k with up seq, rcases seq with ⟨u,ulim,hu⟩,
  choose v hv using hu,
  have vin : ∀ n, v n ∈ Icc a b, intro n, exact (hv n).1,
  have fv  : ∀ n, f (v n) = u n, intro n, exact (hv n).2,
  clear hv,
  have vlim := bolzano_weierstrass vin,
  rcases vlim with ⟨c, cin, hc⟩,
  use [c,cin], intro x, rcases hc with ⟨φ, φ_ext, φlim⟩,
  have j : ∀ n, f(v (φ n)) = u (φ n), intro n, exact fv (φ n),
  have limit : seq_limit (u ∘ φ) (f c),
  clear M m,
  have kk := seq_continuous_of_continuous (hf c cin) φlim,
  have leq : ∀ n, f(v(φ n)) ≤ u(φ n), intro n, linarith[j n],
  have geq : ∀ n, f(v(φ n)) ≥ u(φ n), intro n, linarith[j n],
  have kkk := squeeze kk kk leq geq, exact kkk,
  have kkkk := subseq_tendsto_of_tendsto ulim φ_ext,
  have kkkkk := unique_limit kkkk limit,
  rw ← kkkkk,
  intro hh,
  apply up, use x, split, exact hh, refl,
end

lemma stupid {a b x : ℝ} (h : x ∈ Icc a b) (h' : x ≠ b) : x < b :=
lt_of_le_of_ne h.right h'

/-
And now the final boss...
-/

def I := (Icc 0 1 : set ℝ) -- the type ascription makes sure 0 and 1 are real numbers here

-- 0081
example (f : ℝ → ℝ) (hf : ∀ x, continuous_at_pt f x) (h₀ : f 0 < 0) (h₁ : f 1 > 0) :
∃ x₀ ∈ I, f x₀ = 0 :=
begin
  let A := { x | x ∈ I ∧ f x < 0},
  have ex_x₀ : ∃ x₀ ∈ I, is_sup A x₀,
  {
    have h : ∀ x ∈ I, continuous_at_pt f x, intros x xi, exact hf x,
    cases bdd_above_segment h with M jM, cases bdd_below_segment h with m jm,
    apply sup_segment,
    use 0, split, split; linarith, from h₀, intros x hx,cases hx with h1 h2, exact h1,

  },
  rcases ex_x₀ with ⟨x₀, x₀_in, x₀_sup⟩,
  use [x₀, x₀_in],
  have : f x₀ ≤ 0,
  {
    rw is_sup_iff at x₀_sup,
    cases x₀_sup with up lim,
    rcases lim with ⟨u, limu, inc⟩,
    have j : ∀ n, f (u n) < 0, intro n, exact (inc n).2,
    by_contradiction hyp, push_neg at hyp,
    have limf : seq_limit (f ∘ u) (f x₀), exact seq_continuous_of_continuous (hf x₀) limu,
    specialize limf (f x₀) hyp, cases limf with N hN, specialize hN N (by linarith),
    rw abs_le at hN, linarith[j N],
  },
  have x₀_1: x₀ < 1,
  {
    have j : x₀ ≠ 1, intro j, rw ← j at h₁, linarith, exact stupid x₀_in j,
  },
  have : f x₀ ≥ 0,
  { have in_I : ∃ N : ℕ, ∀ n ≥ N, x₀ + 1/(n+1) ∈ I,
    { have : ∃ N : ℕ, ∀ n≥ N, 1/(n+1 : ℝ) ≤ 1-x₀,
      {
        have j := limit_const_add_inv_succ x₀, specialize j ((1-x₀)) (by linarith),
        cases j with N hN, use N, intros n hn, specialize hN n hn, rw abs_le at hN,
        cases hN with h1 h2, simp at h2, simp, exact h2,
      },
      cases this with N hN, use N, intros n hn, specialize hN n hn, split,
      cases x₀_in with above below,
      have k : 0 < 1 / ((n + 1):ℝ), from nat.one_div_pos_of_nat,
      linarith, linarith,
    },
    have not_in : ∀ n : ℕ, x₀ + 1/(n+1) ∉ A,
    -- By definition, x ∉ A means ¬ (x ∈ A).
    {
      intro n, by_contradiction hyp,
      have k : 0 < 1 / ((n + 1):ℝ), from nat.one_div_pos_of_nat,
      have ineq : x₀ < x₀ + 1/(n+1), linarith, linarith[x₀_sup.1 (x₀ + 1 / (n + 1)) hyp],
    },
    dsimp [A] at not_in,
    have j : ∃ N : ℕ, ∀ n ≥ N, f (x₀ + 1 / (n + 1)) ≥ 0,
    {
      cases in_I with N hN, use N,
      intros n hn, specialize hN n hn, specialize not_in n,
      push_neg at not_in, linarith[not_in hN],
    },
    have k := seq_continuous_of_continuous (hf x₀) (limit_const_add_inv_succ x₀),
    apply le_lim k, exact j,
  },
  linarith,
end


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import topology.subset_properties
import topology.connected
import topology.algebra.monoid
import topology.continuous_function.basic
import tactic.tfae
import tactic.fin_cases

/-!
# Locally constant functions

This file sets up the theory of locally constant function from a topological space to a type.

## Main definitions and constructions

* `is_locally_constant f` : a map `f : X → Y` where `X` is a topological space is locally
                            constant if every set in `Y` has an open preimage.
* `locally_constant X Y` : the type of locally constant maps from `X` to `Y`
* `locally_constant.map` : push-forward of locally constant maps
* `locally_constant.comap` : pull-back of locally constant maps

-/

variables {X Y Z α : Type*} [topological_space X]

open set filter
open_locale topological_space

/-- A function between topological spaces is locally constant if the preimage of any set is open. -/
def is_locally_constant (f : X → Y) : Prop := ∀ s : set Y, is_open (f ⁻¹' s)

namespace is_locally_constant

protected lemma tfae (f : X → Y) :
  tfae [is_locally_constant f,
    ∀ x, ∀ᶠ x' in 𝓝 x, f x' = f x,
    ∀ x, is_open {x' | f x' = f x},
    ∀ y, is_open (f ⁻¹' {y}),
    ∀ x, ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x] :=
begin
  tfae_have : 1 → 4, from λ h y, h {y},
  tfae_have : 4 → 3, from λ h x, h (f x),
  tfae_have : 3 → 2, from λ h x, is_open.mem_nhds (h x) rfl,
  tfae_have : 2 → 5,
  { intros h x,
    rcases mem_nhds_iff.1 (h x) with ⟨U, eq, hU, hx⟩,
    exact ⟨U, hU, hx, eq⟩ },
  tfae_have : 5 → 1,
  { intros h s,
    refine is_open_iff_forall_mem_open.2 (λ x hx, _),
    rcases h x with ⟨U, hU, hxU, eq⟩,
    exact ⟨U, λ x' hx', mem_preimage.2 $ (eq x' hx').symm ▸ hx, hU, hxU⟩ },
  tfae_finish
end

@[nontriviality] lemma of_discrete [discrete_topology X] (f : X → Y) :
  is_locally_constant f :=
λ s, is_open_discrete _

lemma is_open_fiber {f : X → Y} (hf : is_locally_constant f) (y : Y) :
  is_open {x | f x = y} :=
hf {y}

lemma is_closed_fiber {f : X → Y} (hf : is_locally_constant f) (y : Y) :
  is_closed {x | f x = y} :=
⟨hf {y}ᶜ⟩

lemma is_clopen_fiber {f : X → Y} (hf : is_locally_constant f) (y : Y) :
  is_clopen {x | f x = y} :=
⟨is_open_fiber hf _, is_closed_fiber hf _⟩

lemma iff_exists_open (f : X → Y) :
  is_locally_constant f ↔ ∀ x, ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x :=
(is_locally_constant.tfae f).out 0 4

lemma iff_eventually_eq (f : X → Y) :
  is_locally_constant f ↔ ∀ x, ∀ᶠ y in 𝓝 x, f y = f x :=
(is_locally_constant.tfae f).out 0 1

lemma exists_open {f : X → Y} (hf : is_locally_constant f) (x : X) :
  ∃ (U : set X) (hU : is_open U) (hx : x ∈ U), ∀ x' ∈ U, f x' = f x :=
(iff_exists_open f).1 hf x

protected lemma eventually_eq {f : X → Y} (hf : is_locally_constant f) (x : X) :
  ∀ᶠ y in 𝓝 x, f y = f x :=
(iff_eventually_eq f).1 hf x

protected lemma continuous [topological_space Y] {f : X → Y} (hf : is_locally_constant f) :
  continuous f :=
⟨λ U hU, hf _⟩

lemma iff_continuous {_ : topological_space Y} [discrete_topology Y] (f : X → Y) :
  is_locally_constant f ↔ continuous f :=
⟨is_locally_constant.continuous, λ h s, h.is_open_preimage s (is_open_discrete _)⟩

lemma iff_continuous_bot (f : X → Y) :
  is_locally_constant f ↔ @continuous X Y _ ⊥ f :=
iff_continuous f

lemma of_constant (f : X → Y) (h : ∀ x y, f x = f y) :
  is_locally_constant f :=
(iff_eventually_eq f).2 $ λ x, eventually_of_forall $ λ x', h _ _

lemma const (y : Y) : is_locally_constant (function.const X y) :=
of_constant _ $ λ _ _, rfl

lemma comp {f : X → Y} (hf : is_locally_constant f) (g : Y → Z) :
  is_locally_constant (g ∘ f) :=
λ s, by { rw set.preimage_comp, exact hf _ }

lemma prod_mk {Y'} {f : X → Y} {f' : X → Y'} (hf : is_locally_constant f)
  (hf' : is_locally_constant f') :
  is_locally_constant (λ x, (f x, f' x)) :=
(iff_eventually_eq _).2 $ λ x, (hf.eventually_eq x).mp $ (hf'.eventually_eq x).mono $
  λ x' hf' hf, prod.ext hf hf'

lemma comp₂ {Y₁ Y₂ Z : Type*} {f : X → Y₁} {g : X → Y₂}
  (hf : is_locally_constant f) (hg : is_locally_constant g) (h : Y₁ → Y₂ → Z) :
  is_locally_constant (λ x, h (f x) (g x)) :=
(hf.prod_mk hg).comp (λ x : Y₁ × Y₂, h x.1 x.2)

lemma comp_continuous [topological_space Y] {g : Y → Z} {f : X → Y}
  (hg : is_locally_constant g) (hf : continuous f) :
  is_locally_constant (g ∘ f) :=
λ s, by { rw set.preimage_comp, exact hf.is_open_preimage _ (hg _) }

/-- A locally constant function is constant on any preconnected set. -/
lemma apply_eq_of_is_preconnected {f : X → Y} (hf : is_locally_constant f)
  {s : set X} (hs : is_preconnected s) {x y : X} (hx : x ∈ s) (hy : y ∈ s) :
  f x = f y :=
begin
  let U := f ⁻¹' {f y},
  suffices : x ∉ Uᶜ, from not_not.1 this,
  intro hxV,
  specialize hs U Uᶜ (hf {f y}) (hf {f y}ᶜ) _ ⟨y, ⟨hy, rfl⟩⟩ ⟨x, ⟨hx, hxV⟩⟩,
  { simp only [union_compl_self, subset_univ] },
  { simpa only [inter_empty, not_nonempty_empty, inter_compl_self] using hs }
end

lemma iff_is_const [preconnected_space X] {f : X → Y} :
  is_locally_constant f ↔ ∀ x y, f x = f y :=
⟨λ h x y, h.apply_eq_of_is_preconnected is_preconnected_univ trivial trivial, of_constant _⟩

lemma range_finite [compact_space X] {f : X → Y} (hf : is_locally_constant f) :
  (set.range f).finite :=
begin
  letI : topological_space Y := ⊥,
  haveI : discrete_topology Y := ⟨rfl⟩,
  rw @iff_continuous X Y ‹_› ‹_› at hf,
  exact finite_of_is_compact_of_discrete _ (is_compact_range hf)
end

@[to_additive] lemma one [has_one Y] : is_locally_constant (1 : X → Y) := const 1

@[to_additive] lemma inv [has_inv Y] ⦃f : X → Y⦄ (hf : is_locally_constant f) :
  is_locally_constant f⁻¹ :=
hf.comp (λ x, x⁻¹)

@[to_additive]
lemma mul [has_mul Y] ⦃f g : X → Y⦄ (hf : is_locally_constant f) (hg : is_locally_constant g) :
  is_locally_constant (f * g) :=
hf.comp₂ hg (*)

@[to_additive]
lemma div [has_div Y] ⦃f g : X → Y⦄ (hf : is_locally_constant f) (hg : is_locally_constant g) :
  is_locally_constant (f / g) :=
hf.comp₂ hg (/)

/-- If a composition of a function `f` followed by an injection `g` is locally
constant, then the locally constant property descends to `f`. -/
lemma desc {α β : Type*} (f : X → α) (g : α → β)
  (h : is_locally_constant (g ∘ f)) (inj : function.injective g) : is_locally_constant f :=
begin
  rw (is_locally_constant.tfae f).out 0 3,
  intros a,
  have : f ⁻¹' {a} = (g ∘ f) ⁻¹' { g a },
  { ext x,
    simp only [mem_singleton_iff, function.comp_app, mem_preimage],
    exact ⟨λ h, by rw h, λ h, inj h⟩ },
  rw this,
  apply h,
end

end is_locally_constant

/-- A (bundled) locally constant function from a topological space `X` to a type `Y`. -/
structure locally_constant (X Y : Type*) [topological_space X] :=
(to_fun : X → Y)
(is_locally_constant : is_locally_constant to_fun)

namespace locally_constant

instance [inhabited Y] : inhabited (locally_constant X Y) :=
⟨⟨_, is_locally_constant.const (default Y)⟩⟩

instance : has_coe_to_fun (locally_constant X Y) (λ _, X → Y) := ⟨locally_constant.to_fun⟩

initialize_simps_projections locally_constant (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : locally_constant X Y) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : X → Y) (h) : ⇑(⟨f, h⟩ : locally_constant X Y) = f := rfl

theorem congr_fun {f g : locally_constant X Y} (h : f = g) (x : X) : f x = g x :=
congr_arg (λ h : locally_constant X Y, h x) h

theorem congr_arg (f : locally_constant X Y) {x y : X} (h : x = y) : f x = f y :=
congr_arg (λ x : X, f x) h

theorem coe_injective : @function.injective (locally_constant X Y) (X → Y) coe_fn
| ⟨f, hf⟩ ⟨g, hg⟩ h := have f = g, from h, by subst f

@[simp, norm_cast] theorem coe_inj {f g : locally_constant X Y} : (f : X → Y) = g ↔ f = g :=
coe_injective.eq_iff

@[ext] theorem ext ⦃f g : locally_constant X Y⦄ (h : ∀ x, f x = g x) : f = g :=
coe_injective (funext h)

theorem ext_iff {f g : locally_constant X Y} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

section codomain_topological_space

variables [topological_space Y] (f : locally_constant X Y)

protected lemma continuous : continuous f := f.is_locally_constant.continuous

/-- We can turn a locally-constant function into a bundled `continuous_map`. -/
def to_continuous_map : C(X, Y) := ⟨f, f.continuous⟩

/-- As a shorthand, `locally_constant.to_continuous_map` is available as a coercion -/
instance : has_coe (locally_constant X Y) C(X, Y) := ⟨to_continuous_map⟩

@[simp] lemma to_continuous_map_eq_coe : f.to_continuous_map = f := rfl

@[simp] lemma coe_continuous_map : ((f : C(X, Y)) : X → Y) = (f : X → Y) := rfl

lemma to_continuous_map_injective :
  function.injective (to_continuous_map : locally_constant X Y → C(X, Y)) :=
λ _ _ h, ext (continuous_map.congr_fun h)

end codomain_topological_space

/-- The constant locally constant function on `X` with value `y : Y`. -/
def const (X : Type*) {Y : Type*} [topological_space X] (y : Y) :
  locally_constant X Y :=
⟨function.const X y, is_locally_constant.const _⟩

@[simp] lemma coe_const (y : Y) : (const X y : X → Y) = function.const X y := rfl

/-- The locally constant function to `fin 2` associated to a clopen set. -/
def of_clopen {X : Type*} [topological_space X] {U : set X} [∀ x, decidable (x ∈ U)]
  (hU : is_clopen U) : locally_constant X (fin 2) :=
{ to_fun := λ x, if x ∈ U then 0 else 1,
  is_locally_constant := begin
    rw (is_locally_constant.tfae (λ x, if x ∈ U then (0 : fin 2) else 1)).out 0 3,
    intros e,
    fin_cases e,
    { convert hU.1 using 1,
      ext,
      simp only [nat.one_ne_zero, mem_singleton_iff, fin.one_eq_zero_iff,
        mem_preimage, ite_eq_left_iff],
      tauto },
    { rw ← is_closed_compl_iff,
      convert hU.2,
      ext,
      simp }
  end }

@[simp] lemma of_clopen_fiber_zero {X : Type*} [topological_space X] {U : set X}
  [∀ x, decidable (x ∈ U)] (hU : is_clopen U) : of_clopen hU ⁻¹' ({0} : set (fin 2)) = U :=
begin
  ext,
  simp only [of_clopen, nat.one_ne_zero, mem_singleton_iff,
    fin.one_eq_zero_iff, coe_mk, mem_preimage, ite_eq_left_iff],
  tauto,
end

@[simp] lemma of_clopen_fiber_one {X : Type*} [topological_space X] {U : set X}
  [∀ x, decidable (x ∈ U)] (hU : is_clopen U) : of_clopen hU ⁻¹' ({1} : set (fin 2)) = Uᶜ :=
begin
  ext,
  simp only [of_clopen, nat.one_ne_zero, mem_singleton_iff, coe_mk,
    fin.zero_eq_one_iff, mem_preimage, ite_eq_right_iff,
    mem_compl_eq],
  tauto,
end

lemma locally_constant_eq_of_fiber_zero_eq {X : Type*} [topological_space X]
  (f g : locally_constant X (fin 2)) (h : f ⁻¹' ({0} : set (fin 2)) = g ⁻¹' {0}) : f = g :=
begin
  simp only [set.ext_iff, mem_singleton_iff, mem_preimage] at h,
  ext1 x,
  have := h x,
  set a := f x,
  set b := g x,
  fin_cases a; fin_cases b; finish
end

lemma range_finite [compact_space X] (f : locally_constant X Y) :
  (set.range f).finite :=
f.is_locally_constant.range_finite

lemma apply_eq_of_is_preconnected (f : locally_constant X Y) {s : set X} (hs : is_preconnected s)
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) :
  f x = f y :=
f.is_locally_constant.apply_eq_of_is_preconnected hs hx hy

lemma apply_eq_of_preconnected_space [preconnected_space X] (f : locally_constant X Y) (x y : X) :
  f x = f y :=
f.is_locally_constant.apply_eq_of_is_preconnected is_preconnected_univ trivial trivial

lemma eq_const [preconnected_space X] (f : locally_constant X Y) (x : X) :
  f = const X (f x) :=
ext $ λ y, apply_eq_of_preconnected_space f _ _

lemma exists_eq_const [preconnected_space X] [nonempty Y] (f : locally_constant X Y) :
  ∃ y, f = const X y :=
begin
  rcases classical.em (nonempty X) with ⟨⟨x⟩⟩|hX,
  { exact ⟨f x, f.eq_const x⟩ },
  { exact ⟨classical.arbitrary Y, ext $ λ x, (hX ⟨x⟩).elim⟩ }
end

/-- Push forward of locally constant maps under any map, by post-composition. -/
def map (f : Y → Z) : locally_constant X Y → locally_constant X Z :=
λ g, ⟨f ∘ g, λ s, by { rw set.preimage_comp, apply g.is_locally_constant }⟩

@[simp] lemma map_apply (f : Y → Z) (g : locally_constant X Y) : ⇑(map f g) = f ∘ g := rfl

@[simp] lemma map_id : @map X Y Y _ id = id := by { ext, refl }

@[simp] lemma map_comp {Y₁ Y₂ Y₃ : Type*} (g : Y₂ → Y₃) (f : Y₁ → Y₂) :
  @map X _ _ _ g ∘ map f = map (g ∘ f) := by { ext, refl }

/-- Given a locally constant function to `α → β`, construct a family of locally constant
functions with values in β indexed by α. -/
def flip {X α β : Type*} [topological_space X] (f : locally_constant X (α → β)) (a : α) :
  locally_constant X β := f.map (λ f, f a)

/-- If α is finite, this constructs a locally constant function to `α → β` given a
family of locally constant functions with values in β indexed by α. -/
def unflip {X α β : Type*} [fintype α] [topological_space X] (f : α → locally_constant X β) :
  locally_constant X (α → β) :=
{ to_fun := λ x a, f a x,
  is_locally_constant := begin
    rw (is_locally_constant.tfae (λ x a, f a x)).out 0 3,
    intros g,
    have : (λ (x : X) (a : α), f a x) ⁻¹' {g} = ⋂ (a : α), (f a) ⁻¹' {g a}, by tidy,
    rw this,
    apply is_open_Inter,
    intros a,
    apply (f a).is_locally_constant,
  end }

@[simp]
lemma unflip_flip {X α β : Type*} [fintype α] [topological_space X]
  (f : locally_constant X (α → β)) : unflip f.flip = f := by { ext, refl }

@[simp]
lemma flip_unflip {X α β : Type*} [fintype α] [topological_space X]
  (f : α → locally_constant X β) : (unflip f).flip = f := by { ext, refl }

section comap

open_locale classical

variables [topological_space Y]

/-- Pull back of locally constant maps under any map, by pre-composition.

This definition only makes sense if `f` is continuous,
in which case it sends locally constant functions to their precomposition with `f`.
See also `locally_constant.coe_comap`. -/
noncomputable
def comap (f : X → Y) :
  locally_constant Y Z → locally_constant X Z :=
if hf : continuous f
then λ g, ⟨g ∘ f, g.is_locally_constant.comp_continuous hf⟩
else
begin
  by_cases H : nonempty X,
  { introsI g, exact const X (g $ f $ classical.arbitrary X) },
  { intro g, refine ⟨λ x, (H ⟨x⟩).elim, _⟩,
    intro s, rw is_open_iff_nhds, intro x, exact (H ⟨x⟩).elim }
end

@[simp] lemma coe_comap (f : X → Y) (g : locally_constant Y Z) (hf : continuous f) :
  ⇑(comap f g) = g ∘ f :=
by { rw [comap, dif_pos hf], refl }

@[simp] lemma comap_id : @comap X X Z _ _ id = id :=
by { ext, simp only [continuous_id, id.def, function.comp.right_id, coe_comap] }

lemma comap_comp [topological_space Z]
  (f : X → Y) (g : Y → Z) (hf : continuous f) (hg : continuous g) :
  @comap _ _ α _ _ f ∘ comap g = comap (g ∘ f) :=
by { ext, simp only [hf, hg, hg.comp hf, coe_comap] }

lemma comap_const (f : X → Y) (y : Y) (h : ∀ x, f x = y) :
  (comap f : locally_constant Y Z → locally_constant X Z) =
  λ g, ⟨λ x, g y, is_locally_constant.const _⟩ :=
begin
  ext, rw coe_comap,
  { simp only [h, coe_mk, function.comp_app] },
  { rw show f = λ x, y, by ext; apply h,
    exact continuous_const }
end

end comap

section desc

/-- If a locally constant function factors through an injection, then it factors through a locally
constant function. -/
def desc {X α β : Type*} [topological_space X] {g : α → β} (f : X → α) (h : locally_constant X β)
  (cond : g ∘ f = h) (inj : function.injective g) : locally_constant X α :=
{ to_fun := f,
  is_locally_constant := is_locally_constant.desc _ g (by { rw cond, exact h.2 }) inj }

@[simp]
lemma coe_desc {X α β : Type*} [topological_space X] (f : X → α) (g : α → β)
  (h : locally_constant X β) (cond : g ∘ f = h) (inj : function.injective g) :
  ⇑(desc f h cond inj) = f := rfl

end desc

end locally_constant


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

! This file was ported from Lean 3 source module algebra.order.euclidean_absolute_value
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.AbsoluteValue
import Mathbin.Algebra.EuclideanDomain.Instances

/-!
# Euclidean absolute values

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

This file defines a predicate `absolute_value.is_euclidean abv` stating the
absolute value is compatible with the Euclidean domain structure on its domain.

## Main definitions

 * `absolute_value.is_euclidean abv` is a predicate on absolute values on `R` mapping to `S`
    that preserve the order on `R` arising from the Euclidean domain structure.
 * `absolute_value.abs_is_euclidean` shows the "standard" absolute value on `ℤ`,
   mapping negative `x` to `-x`, is euclidean.
-/

-- mathport name: «expr ≺ »
local infixl:50 " ≺ " => EuclideanDomain.r

namespace AbsoluteValue

section OrderedSemiring

variable {R S : Type _} [EuclideanDomain R] [OrderedSemiring S]

variable (abv : AbsoluteValue R S)

#print AbsoluteValue.IsEuclidean /-
/-- An absolute value `abv : R → S` is Euclidean if it is compatible with the
`euclidean_domain` structure on `R`, namely `abv` is strictly monotone with respect to the well
founded relation `≺` on `R`. -/
structure IsEuclidean : Prop where
  map_lt_map_iff' : ∀ {x y}, abv x < abv y ↔ x ≺ y
#align absolute_value.is_euclidean AbsoluteValue.IsEuclidean
-/

namespace IsEuclidean

variable {abv}

/- warning: absolute_value.is_euclidean.map_lt_map_iff -> AbsoluteValue.IsEuclidean.map_lt_map_iff is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {S : Type.{u2}} [_inst_1 : EuclideanDomain.{u1} R] [_inst_2 : OrderedSemiring.{u2} S] {abv : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2} {x : R} {y : R}, (AbsoluteValue.IsEuclidean.{u1, u2} R S _inst_1 _inst_2 abv) -> (Iff (LT.lt.{u2} S (Preorder.toLT.{u2} S (PartialOrder.toPreorder.{u2} S (OrderedAddCommMonoid.toPartialOrder.{u2} S (OrderedSemiring.toOrderedAddCommMonoid.{u2} S _inst_2)))) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) (fun (f : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) => R -> S) (AbsoluteValue.hasCoeToFun.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) abv x) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) (fun (f : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) => R -> S) (AbsoluteValue.hasCoeToFun.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) abv y)) (EuclideanDomain.r.{u1} R _inst_1 x y))
but is expected to have type
  forall {R : Type.{u2}} {S : Type.{u1}} [_inst_1 : EuclideanDomain.{u2} R] [_inst_2 : OrderedSemiring.{u1} S] {abv : AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2} {x : R} {y : R}, (AbsoluteValue.IsEuclidean.{u2, u1} R S _inst_1 _inst_2 abv) -> (Iff (LT.lt.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) x) (Preorder.toLT.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) x) (PartialOrder.toPreorder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) x) (OrderedSemiring.toPartialOrder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) x) _inst_2))) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R (fun (f : R) => (fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) f) (SubadditiveHomClass.toFunLike.{max u2 u1, u2, u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R S (Distrib.toAdd.{u2} R (NonUnitalNonAssocSemiring.toDistrib.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))))))) (Distrib.toAdd.{u1} S (NonUnitalNonAssocSemiring.toDistrib.{u1} S (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} S (Semiring.toNonAssocSemiring.{u1} S (OrderedSemiring.toSemiring.{u1} S _inst_2))))) (Preorder.toLE.{u1} S (PartialOrder.toPreorder.{u1} S (OrderedSemiring.toPartialOrder.{u1} S _inst_2))) (AbsoluteValue.subadditiveHomClass.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2)) abv x) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R (fun (f : R) => (fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) f) (SubadditiveHomClass.toFunLike.{max u2 u1, u2, u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R S (Distrib.toAdd.{u2} R (NonUnitalNonAssocSemiring.toDistrib.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))))))) (Distrib.toAdd.{u1} S (NonUnitalNonAssocSemiring.toDistrib.{u1} S (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} S (Semiring.toNonAssocSemiring.{u1} S (OrderedSemiring.toSemiring.{u1} S _inst_2))))) (Preorder.toLE.{u1} S (PartialOrder.toPreorder.{u1} S (OrderedSemiring.toPartialOrder.{u1} S _inst_2))) (AbsoluteValue.subadditiveHomClass.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2)) abv y)) (EuclideanDomain.r.{u2} R _inst_1 x y))
Case conversion may be inaccurate. Consider using '#align absolute_value.is_euclidean.map_lt_map_iff AbsoluteValue.IsEuclidean.map_lt_map_iffₓ'. -/
-- Rearrange the parameters to `map_lt_map_iff'` so it elaborates better.
theorem map_lt_map_iff {x y : R} (h : abv.IsEuclidean) : abv x < abv y ↔ x ≺ y :=
  map_lt_map_iff' h
#align absolute_value.is_euclidean.map_lt_map_iff AbsoluteValue.IsEuclidean.map_lt_map_iff

attribute [simp] map_lt_map_iff

/- warning: absolute_value.is_euclidean.sub_mod_lt -> AbsoluteValue.IsEuclidean.sub_mod_lt is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {S : Type.{u2}} [_inst_1 : EuclideanDomain.{u1} R] [_inst_2 : OrderedSemiring.{u2} S] {abv : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2}, (AbsoluteValue.IsEuclidean.{u1, u2} R S _inst_1 _inst_2 abv) -> (forall (a : R) {b : R}, (Ne.{succ u1} R b (OfNat.ofNat.{u1} R 0 (OfNat.mk.{u1} R 0 (Zero.zero.{u1} R (MulZeroClass.toHasZero.{u1} R (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} R (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} R (NonAssocRing.toNonUnitalNonAssocRing.{u1} R (Ring.toNonAssocRing.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))))))))))) -> (LT.lt.{u2} S (Preorder.toLT.{u2} S (PartialOrder.toPreorder.{u2} S (OrderedAddCommMonoid.toPartialOrder.{u2} S (OrderedSemiring.toOrderedAddCommMonoid.{u2} S _inst_2)))) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) (fun (f : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) => R -> S) (AbsoluteValue.hasCoeToFun.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) abv (HMod.hMod.{u1, u1, u1} R R R (instHMod.{u1} R (EuclideanDomain.hasMod.{u1} R _inst_1)) a b)) (coeFn.{max (succ u1) (succ u2), max (succ u1) (succ u2)} (AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) (fun (f : AbsoluteValue.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) => R -> S) (AbsoluteValue.hasCoeToFun.{u1, u2} R S (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R (EuclideanDomain.toCommRing.{u1} R _inst_1))) _inst_2) abv b)))
but is expected to have type
  forall {R : Type.{u2}} {S : Type.{u1}} [_inst_1 : EuclideanDomain.{u2} R] [_inst_2 : OrderedSemiring.{u1} S] {abv : AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2}, (AbsoluteValue.IsEuclidean.{u2, u1} R S _inst_1 _inst_2 abv) -> (forall (a : R) {b : R}, (Ne.{succ u2} R b (OfNat.ofNat.{u2} R 0 (Zero.toOfNat0.{u2} R (CommMonoidWithZero.toZero.{u2} R (CommSemiring.toCommMonoidWithZero.{u2} R (CommRing.toCommSemiring.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))))))) -> (LT.lt.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) (HMod.hMod.{u2, u2, u2} R R R (instHMod.{u2} R (EuclideanDomain.instMod.{u2} R _inst_1)) a b)) (Preorder.toLT.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) (HMod.hMod.{u2, u2, u2} R R R (instHMod.{u2} R (EuclideanDomain.instMod.{u2} R _inst_1)) a b)) (PartialOrder.toPreorder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) (HMod.hMod.{u2, u2, u2} R R R (instHMod.{u2} R (EuclideanDomain.instMod.{u2} R _inst_1)) a b)) (OrderedSemiring.toPartialOrder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) (HMod.hMod.{u2, u2, u2} R R R (instHMod.{u2} R (EuclideanDomain.instMod.{u2} R _inst_1)) a b)) _inst_2))) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R (fun (f : R) => (fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) f) (SubadditiveHomClass.toFunLike.{max u2 u1, u2, u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R S (Distrib.toAdd.{u2} R (NonUnitalNonAssocSemiring.toDistrib.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))))))) (Distrib.toAdd.{u1} S (NonUnitalNonAssocSemiring.toDistrib.{u1} S (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} S (Semiring.toNonAssocSemiring.{u1} S (OrderedSemiring.toSemiring.{u1} S _inst_2))))) (Preorder.toLE.{u1} S (PartialOrder.toPreorder.{u1} S (OrderedSemiring.toPartialOrder.{u1} S _inst_2))) (AbsoluteValue.subadditiveHomClass.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2)) abv (HMod.hMod.{u2, u2, u2} R R R (instHMod.{u2} R (EuclideanDomain.instMod.{u2} R _inst_1)) a b)) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R (fun (f : R) => (fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => S) f) (SubadditiveHomClass.toFunLike.{max u2 u1, u2, u1} (AbsoluteValue.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2) R S (Distrib.toAdd.{u2} R (NonUnitalNonAssocSemiring.toDistrib.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))))))) (Distrib.toAdd.{u1} S (NonUnitalNonAssocSemiring.toDistrib.{u1} S (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} S (Semiring.toNonAssocSemiring.{u1} S (OrderedSemiring.toSemiring.{u1} S _inst_2))))) (Preorder.toLE.{u1} S (PartialOrder.toPreorder.{u1} S (OrderedSemiring.toPartialOrder.{u1} S _inst_2))) (AbsoluteValue.subadditiveHomClass.{u2, u1} R S (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R (EuclideanDomain.toCommRing.{u2} R _inst_1))) _inst_2)) abv b)))
Case conversion may be inaccurate. Consider using '#align absolute_value.is_euclidean.sub_mod_lt AbsoluteValue.IsEuclidean.sub_mod_ltₓ'. -/
theorem sub_mod_lt (h : abv.IsEuclidean) (a : R) {b : R} (hb : b ≠ 0) : abv (a % b) < abv b :=
  h.map_lt_map_iff.mpr (EuclideanDomain.mod_lt a hb)
#align absolute_value.is_euclidean.sub_mod_lt AbsoluteValue.IsEuclidean.sub_mod_lt

end IsEuclidean

end OrderedSemiring

section Int

open Int

#print AbsoluteValue.abs_isEuclidean /-
-- TODO: generalize to `linear_ordered_euclidean_domain`s if we ever get a definition of those
/-- `abs : ℤ → ℤ` is a Euclidean absolute value -/
protected theorem abs_isEuclidean : IsEuclidean (AbsoluteValue.abs : AbsoluteValue ℤ ℤ) :=
  {
    map_lt_map_iff' := fun x y =>
      show abs x < abs y ↔ natAbs x < natAbs y by rw [abs_eq_nat_abs, abs_eq_nat_abs, coe_nat_lt] }
#align absolute_value.abs_is_euclidean AbsoluteValue.abs_isEuclidean
-/

end Int

end AbsoluteValue


/-
CS 2102 F19, Homework #8, Predicate Logic & Proofs.
-/

/-
Is this stuff useful?

-- Functional programming is *hot*. Much of
Facebook's Messenger app is written in Reason,
for example, which is just a Java-script like
syntactic sugar on top of OCaml, which you
can now program in.

-- Boolean satisfiability, which is all
about finding "models" of formulae in
propositional logic is hugely useful in
computer science.
    * find Hamiltonian circuits in graphs
    * solve Sudoko programs automatically
    * generate test cases to "cover" all
      statements in a program
    * annual SAT solver competitions

- Predicate logic
    * the language of mathematics
    * the language of specification

- Design and implementation of
provably correct programming languages
and compilers

- Proofs: the language of verification
    * provable security
    * provable safety
    * provable privcy
-/

namespace hw8

/-
#1. Equality and proofs of equality.
-/

/-
A. [10 points] Fill in the blank.

When we say that the binary equality relation,
=, on objects of any type, α, is reflexive, we
mean that for any value, a, of type, α, _______.

ANSWER: a = a
-/

/-
B. [10 points]
Complete the following definition in Lean
to formalize the proposition that 1 equals
1.
-/

def one_eq_one : Prop :=
    -- ANSWER
    1 = 1

/-
C. [10 points]
Give an English language proof of the
proposition that 1 = 1 by completing the
following incomplete proof.

To obtain a proof of 1 = 1 we apply the ________
property of the ________ relation to the specific
value, _________.

∀ a : α, (a, a) ∈ =; applying this to 1 gives us
a proof of 1 = 1, in particular.

ANSWER: reflexive, equality, 1.

We apply the reflexive property of equality,
that ∀ (n : ℕ), n = n, to the value, 1, to
obtain a proof (value) of (type) 1 = 1.
-/

/-
D. [10 points]
Give a formal proof of this proposition
by completing the following definition.
-/

def proof_that_one_eq_one : one_eq_one :=
    -- ANSWER
    (eq.refl 1)

/- [10 points]
E. Complete the following test case to produce
an example that suggests (correctly) that Lean
will accept a proof that two *different terms* are
equal as long as they reduce to the same value.
-/

-- ANSWER: Give a proposition and proof in Lean

def two_plus_two_eq_four : 2 + 2 = 4 := eq.refl 4

-- ANSWER Does eq.refl work as suggested? Yes

/-
#2. Predicates and Properties

A predicate is a "parameterized proposition". By
applying a predicate to different arguments, we get
different propositions. Such a propopsition can
be said to be "about" the argument to which it was
applied.

We interpret such a proposition as asserting that
its argument has a *property* of interest. If the
proposition has a proof (is true), the object does
have the asserted property, and if the proposition
is not true, the object doesn't have that property.

In the  following set of problems, we will take the
property of a natural number "being even" as a case
in point.

In natural language, we will say that a natural
number, n, is even if and only if (1) it is zero,
or, (2) it is two more than another even number.

Think about this inductive definition. Why does it
cover all possible cases -- an infinitude of cases?
(No need for an answer here.)
-/

/-

A. [10 points]

We have accepted as *axioms* in our definition
of evennness that zero is even and that any number
that is two more than another even number is even.
These are the only axioms you may use in giving a
proof that four is even. Give a natural language
proof now. Hint, start by saying the following:

Proof: To prove that four is even, *it will suffice*
to show that 2 is even, because if two is even then,
given that 4 is two more than two, if two is even
then so is four, by rule (2). Now all that remains
to be proved is that _______________.

ANSWER: Two is even.

Give the rest of your natural language proof here,
and be sure to indicate which of the two rules you
are applying at each step in your reasoning.

ANSWER: To prove that two is even it will suffice
to prove that 0 is even, because 2 is two more than
0, so if 0 is even, then so is 2.

Now all that remains to be proven is that 0 is even.
But is is even by the first axiom, that zero is
even.

[In summary, 0 is even, so 2 is even, and because 2
is even, 4 is even. Thus 4 is even.]

QED.

-/

/-
B. [10 points]

We formalize a predicate, such as is_even, as a
family of "inductive propositions" given by a
function from argument values to propositions.
Such an inductive definition thus has the type,
α → Prop, where α is the type of argument to
which the predicate is applied.

Please see the first line of the definition of
is_even that follows for an example.

Having specified the *type* of a predicate, in
this case from ℕ → Prop, we then define the set
of constructors to define the logical rules that
can be used to construct proofs of any such
proposition.

These rules are the (formal) axioms that can be
used to construct proofs. The first one (below)
states that the term, pf_zero_is_even, is to be
accepted as a proof of is_even 0 (which is how
we write the application of a predicate to a value
to obtain a proposition, here that "0 is even").

The second constructor/axiom/rule provides a way
to build a proof of (is_even 2+n) by applying the
constructor to any n along with a proof that that
particular n is even. (Yes: the ∀ specifies the
first argument to pf_even_plus_two_is_even. This
is necessary to give the argument a name, here n,
so that that name can be used in defining the rest
of the constructor's type).
-/

inductive is_even : ℕ → Prop
| pf_zero_is_even : (is_even 0)
| pf_even_plus_two_is_even :
    ∀ (n : ℕ), is_even n → is_even (nat.succ (nat.succ n))

/-
Give formal proofs for each of the following
propositions. (Notice how we obtain different
propositions by applying the predicate, is_even,
to different argument values. This is what we
mean when we say that a predicate defines a
family of propositions.)
-/

open is_even

theorem zero_even : is_even 0 :=
    -- ANSWER
    pf_zero_is_even

/-
In this case, give a proof term without using
a begin/end proof script.
-/
theorem two_even    : is_even 2 :=
    -- ANSWER
    pf_even_plus_two_is_even 0 pf_zero_is_even

/-
In this case, give a proof using a begin/end
proof script.
-/
theorem eight_even  : is_even 8 :=
begin
    apply pf_even_plus_two_is_even _ _,
    /-
    Lean infers value of first argument,
    leaving the proof that that value is
    even to be constructed.
    -/
    apply pf_even_plus_two_is_even,
    apply pf_even_plus_two_is_even,
    apply pf_even_plus_two_is_even,
    exact pf_zero_is_even
end

/-
C. [10 points]

Formally specify a predicate, is_odd, on the
natural numbers.  You can reason about any
natural number being odd using two rules, just
as for being even. Once you've defined your
predicate (an inductive family of proposition,
just like is_even), formally state and prove
the following propositions (however you wish).

- 1 is odd
- 7 is odd

-/

-- ANSWER

inductive is_odd : ℕ → Prop
| one_is_odd : is_odd 1
| two_plus_odd_is_odd :
    ∀ (n : ℕ), is_odd n → is_odd (nat.succ(nat.succ n))

open is_odd

-- ANSWER

example : is_odd 1 := one_is_odd

-- ANSWER

example : is_odd 7 :=
two_plus_odd_is_odd
    5
    (
    two_plus_odd_is_odd
        3
        (
            two_plus_odd_is_odd
            1
            one_is_odd
        )
    )

example : is_odd 7 :=
begin
    apply two_plus_odd_is_odd,
    apply two_plus_odd_is_odd,
    apply two_plus_odd_is_odd,
    apply one_is_odd,   -- exact works here, too
end

/-
Introducing an important concept. In the preceding
problems, we've seen that we can think of a predicate
with one argument as defining a property objects, such
as the property of being even. Now we shift perspective
from the concept of a property, per se, to the concept
of "the set of objects that have a given property." The
set of objects that have the is_even property, for
example, could be written as

    evens = {0, 2, 4, 6, 8, 10, ...}

or more formally as

    evens = { n : ℕ | is_even n}

The elements of these sets are all, and only,
the values that "satisfy" the is_even predicate.
A value satisfies its predicate if, when plugged
in, the resulting proposition has a proof (and so
is true). The key conclusion is that a predicate
with a single argument defines a *set*, namely
the set of all and only those objects that have
that property.
-/

/-
#4. Predicates and binary relations

Mathematicians define *binary relations* as sets
of ordered pairs. For example, the equality relation
on natural numbers comprises the set of of all pairs
of natural numbers such that the first and second
elements are the same. We could write this set like
this:

    equals = { (0,0), (1,1), (2,2), ...},

or like this:

    equals = { (m : ℕ, n : ℕ) | m = n }

We formalize binary relations as predicates with
*two* arguments. The type of such a predicate in
Lean is thus α → β → Prop, where α and β are the
types of the arguments.

In our example, we have a two-place predicate that
defines the set of ordered pairs of natural numbers
where the two elements of each pair are co-equal.

Study and understand the following specification
of this binary relation. Look at the construtor,
mk, in particular: it says that you can construct
a proof that a pair of values, n and m, is in our
id_nat_relation if you have a proof of n = m. (In
other words, it suffices to show that n = m using
Lean's built in equality relation to construct a
proof that (n, m) is in our id_nat_relation.)
-/

inductive id_nat_relation : ℕ → ℕ → Prop
| mk : ∀ (n m : ℕ), n = m → id_nat_relation n m

/-
A. [10 points]

Give a formal proof that id_nat_relation contains
the pair, (3, 3). Do it by completing the following
proof. Think carefully about the third argument: you
need a *value* of what type here? What do we call a
value of a logical type?
-/

theorem three_three_in_id : id_nat_relation 3 3 :=
    -- ANSWER (apply a constructor, of course)
    id_nat_relation.mk 3 3 (eq.refl 3)

/-
B. [10 points]

Explain in just a few words why it is not
possible to prove that (3,5) is in this relation.
-/

-- ANSWER: It's not possible to prove that (3,5)
-- is in the relation because it's not possible
-- to construct a proof of 3=5, and so it's not
-- possible to apply the mk constructor, and there
-- is no other way to obtain a proof that a pair
-- is in the id_nat_relation

/-
EXTRA CREDIT.
-/

/-
Here's a definition of what it means for a
relation to be reflexive.
-/

def reflexive {α : Type} (r : α → α → Prop) :=
    ∀ (a : α), r a a

/-
A. Formally state and prove that id_nat_relation
is reflexive. Hint: use a script and start it
with "assume (a : ℕ)". Remember that to prove a ∀
proposition, we *assume* that we're given some
arbitrary but specific value of the given type,
then we prove the rest of the proposition about
it. But because we didn't say anything about
the element we picked, we can conclude that the
statement must be true of any element of the type.
-/

-- ANSWER

theorem id_nat_refl : reflexive id_nat_relation :=
begin
unfold reflexive,
assume (a : ℕ),
--sorry               -- replace this
apply id_nat_relation.mk a a (eq.refl a)
end

example : reflexive id_nat_relation :=
    λ (a : ℕ),
        id_nat_relation.mk a a (eq.refl a)

/-
B. [Double extra credit.]

Formally define what we mean by a relation being
symmetric and transitive, in the style of the above
definition of reflexive, and formally state and show
that our id_nat_reflexive relation is also symmetric
and transitive.
-/

def symmetric {α : Type} (r : α → α → Prop) :=
    ∀ (a b : α), r a b → r b a

def transitive {α : Type} (r : α → α → Prop) :=
    ∀ (a b c: α), r a b → r b c → r a c

example :
    symmetric id_nat_relation ∧
    transitive id_nat_relation :=
and.intro
-- symmetric
(
    λ (a b : ℕ),
    λ h,
    match h with
        -- only constructor for h is mk
        -- pattern matching destructures
        -- by cases
        (id_nat_relation.mk a b e) :=
            id_nat_relation.mk _ _
                (eq.symm e)
    end
)
-- transitive
(
    λ (a b c : ℕ),
    λ h k,
   match h with
        (id_nat_relation.mk a b e) :=
            id_nat_relation.mk _ _
                (
                    match k with
                        id_nat_relation.mk a b f :=
                            (eq.trans e f)
                    end
                )
    end
)

example :
    symmetric id_nat_relation ∧
    transitive id_nat_relation :=
begin
    apply and.intro _ _,

    -- symmetric
    assume (a b : ℕ),
    assume (h : id_nat_relation a b),
    cases h with a b e, -- new tactic
    apply id_nat_relation.mk
        b a (eq.symm e),  -- property of =

    -- transitive
    assume a b c,
    assume h k,
    cases h with a b e,
    cases k with b c f,
    apply id_nat_relation.mk,
    exact eq.trans e f,
end

/-
We now show how we can use our
understanding of the formal proof
to render a precise English proof.
-/
example :
    symmetric id_nat_relation ∧
    transitive id_nat_relation :=
begin
/-
To prove the conjunction, we will apply
the rule of "and introduction" to proofs
of the individual conjuncts. All that then
remains to be proved are the individual
conjuncts.
-/
    apply and.intro _ _,

/-
We first prove symmetric id_nat_relation:
that ∀ (a b : α), r a b → r b a. To prove
this universal generalization, we assume
that a and b are arbitrary but specific
natural numbers and then we prove that
r a b → r b a.
-/
    assume (a b : ℕ),
/-
To prove r a b → r b a, we apply the
rule for → introduction: we assume that
we have a proof of the premise, r a b,
and we then show that we can obtain a
proof of the conclusion, r b a.
-/
    assume (h : id_nat_relation a b),

/-
What now remains to be proved is r b a.
To construct a proof of (r b a) our only
choice is to apply id_nat_relation.mk to
b, a, and to a proof that b = a. The only
missing element is a proof of b = a, which
we will build in the next step.
-/
    apply id_nat_relation.mk b a _,
/-
To prove that b = a, we observe that
inherent in h is a proof that a = b.
There is no other way that the proof
of h could have been obtained.
-/
    cases h with a b e,
/-
Finally, we apply the principle of
the *symmetry* of = to (a = b) to
show that (b = a), and that is the
last proof we need to complete the
application of "mk".
-/
    apply eq.symm e,

/-
QED first conjunct.
-/

/-
To complete the proof we now prove that
id_nat_relation is transitive: namely,
that ∀ (a b c: α), r a b → r b c → r a c.
-/

/- [∀ introduction]

This conjecture is in the form of a
universal generalization. We thus
start by assuming that a, b, and c
are arbitrary but specific natural
numbers. Then what will remain to be
proved is that r a b → r b c → r a c.
-/
    assume a b c,

/- [→ introduction]

To prove the remaining implication,
we assume that the premise is true
(and that we have a proof of it that
we will call h).
-/
    assume h,

/- [→ introduction again]

What remains to be proved is the
rest of the implication, so we once
again assume that we have a proof of
the premise. We'll call it k.
-/

    assume k,

/-
What remains to be proved is that
(a, c) is in the id_nat_relation.
To prove it, we will apply the
axiom that if (a = c) then (a, c)
is provably in this relation. All
that will remain to be proved is
that a = c.
-/
    apply id_nat_relation.mk,

/-
To prove that a = c, we will
first deduce from the existence
of h that a = b, and from the
existence of k that b = c, and
we will then apply the axiom of
the transitive of equality to
deduce that a = c. This will
complete the proof that our
relation is transitive; and
that in turn will complete the
proof that it is both symmetric
and transitive.
-/

/-
The only way that it can be
true that r a b is if a = b,
and we've assumed that r a b,
so we can deduce that (under
this assumption), a = b.
-/
    cases h with a b e,

/-
The only way that it can be
true that r b c is if b = c,
and we've assumed that r b c,
so we can deduce that (under
this assumption), b = c.
-/
    cases k with b c f,

/-
From these two equalities,
by the axiom of the transitivity
of equality we deduce that (under
the given assumptions) a = c.
-/
    exact eq.trans e f,

/-
And that compeletes both the
proof of transitivity and the
proof of both symmetry and of
transitivity of our relation.

QED.
-/
end

/-
An unambiguos, consistent, complete,
and formally precise natural-language
proof.

To prove the conjunction, we will apply
the rule of "and introduction" to proofs
of the individual conjuncts. All that then
remains to be proved are the individual
conjuncts.

We first prove symmetric id_nat_relation:
that ∀ (a b : α), r a b → r b a. To prove
this universal generalization, we assume
that a and b are arbitrary but specific
natural numbers and then we prove that
r a b → r b a.

To prove r a b → r b a, we apply the
rule for → introduction: we assume that
we have a proof of the premise, r a b,
and we then show that we can obtain a
proof of the conclusion, r b a.

What now remains to be proved is r b a.
To construct a proof of (r b a) our only
choice is to apply id_nat_relation.mk to
b, a, and to a proof that b = a. The only
missing element is a proof of b = a, which
we will build in the next step.

To prove that b = a, we observe that
inherent in h is a proof that a = b.
There is no other way that the proof
of h could have been obtained.

Finally, we apply the principle of
the *symmetry* of = to (a = b) to
show that (b = a), and that is the
last proof we need to complete the
application of "mk".

QED first conjunct.

To complete the proof we now prove that
id_nat_relation is transitive: namely,
that ∀ (a b c: α), r a b → r b c → r a c.

This conjecture is in the form of a
universal generalization. We thus
start by assuming that a, b, and c
are arbitrary but specific natural
numbers. Then what will remain to be
proved is that r a b → r b c → r a c.

To prove the remaining implication,
we assume that the premise is true
(and that we have a proof of it that
we will call h).

What remains to be proved is the
rest of the implication, so we once
again assume that we have a proof of
the premise. We'll call it k.

What now remains to be proved is that
(a, c) is in the id_nat_relation.
To prove it, we will apply the
axiom that if (a = c) then (a, c)
is provably in this relation. All
that will remain to be proved is
that a = c.

To prove that a = c, we will
first deduce from the existence
of h that a = b, and from the
existence of k that b = c, and
we will then apply the axiom of
the transitive of equality to
deduce that a = c. This will
complete the proof that our
relation is transitive; and
that in turn will complete the
proof that it is both symmetric
and transitive.

The only way that it can be
true that r a b is if a = b,
and we've assumed that r a b,
so we can deduce that (under
this assumption), a = b.

The only way that it can be
true that r b c is if b = c,
and we've assumed that r b c,
so we can deduce that (under
this assumption), b = c.

From these two equalities,
by the axiom of the transitivity
of equality we deduce that (under
the given assumptions) a = c.

And that compeletes both the
proof of transitivity and the
proof of both symmetry and of
transitivity of our relation.

QED.
-/

end hw8


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module analysis.normed_space.enorm
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Basic

/-!
# Extended norm

In this file we define a structure `enorm 𝕜 V` representing an extended norm (i.e., a norm that can
take the value `∞`) on a vector space `V` over a normed field `𝕜`. We do not use `class` for
an `enorm` because the same space can have more than one extended norm. For example, the space of
measurable functions `f : α → ℝ` has a family of `L_p` extended norms.

We prove some basic inequalities, then define

* `emetric_space` structure on `V` corresponding to `e : enorm 𝕜 V`;
* the subspace of vectors with finite norm, called `e.finite_subspace`;
* a `normed_space` structure on this space.

The last definition is an instance because the type involves `e`.

## Implementation notes

We do not define extended normed groups. They can be added to the chain once someone will need them.

## Tags

normed space, extended norm
-/

noncomputable section

attribute [local instance] Classical.propDecidable

open ENNReal

/-- Extended norm on a vector space. As in the case of normed spaces, we require only
`‖c • x‖ ≤ ‖c‖ * ‖x‖` in the definition, then prove an equality in `map_smul`. -/
structure Enorm (𝕜 : Type _) (V : Type _) [NormedField 𝕜] [AddCommGroup V] [Module 𝕜 V] where
  toFun : V → ℝ≥0∞
  eq_zero' : ∀ x, to_fun x = 0 → x = 0
  map_add_le' : ∀ x y : V, to_fun (x + y) ≤ to_fun x + to_fun y
  map_smul_le' : ∀ (c : 𝕜) (x : V), to_fun (c • x) ≤ ‖c‖₊ * to_fun x
#align enorm Enorm

namespace Enorm

variable {𝕜 : Type _} {V : Type _} [NormedField 𝕜] [AddCommGroup V] [Module 𝕜 V] (e : Enorm 𝕜 V)

instance : CoeFun (Enorm 𝕜 V) fun _ => V → ℝ≥0∞ :=
  ⟨Enorm.toFun⟩

theorem coeFn_injective : Function.Injective (coeFn : Enorm 𝕜 V → V → ℝ≥0∞) := fun e₁ e₂ h => by
  cases e₁ <;> cases e₂ <;> congr <;> exact h
#align enorm.coe_fn_injective Enorm.coeFn_injective

@[ext]
theorem ext {e₁ e₂ : Enorm 𝕜 V} (h : ∀ x, e₁ x = e₂ x) : e₁ = e₂ :=
  coeFn_injective <| funext h
#align enorm.ext Enorm.ext

theorem ext_iff {e₁ e₂ : Enorm 𝕜 V} : e₁ = e₂ ↔ ∀ x, e₁ x = e₂ x :=
  ⟨fun h x => h ▸ rfl, ext⟩
#align enorm.ext_iff Enorm.ext_iff

@[simp, norm_cast]
theorem coe_inj {e₁ e₂ : Enorm 𝕜 V} : (e₁ : V → ℝ≥0∞) = e₂ ↔ e₁ = e₂ :=
  coeFn_injective.eq_iff
#align enorm.coe_inj Enorm.coe_inj

@[simp]
theorem map_smul (c : 𝕜) (x : V) : e (c • x) = ‖c‖₊ * e x :=
  le_antisymm (e.map_smul_le' c x) <| by
    by_cases hc : c = 0; · simp [hc]
    calc
      (‖c‖₊ : ℝ≥0∞) * e x = ‖c‖₊ * e (c⁻¹ • c • x) := by rw [inv_smul_smul₀ hc]
      _ ≤ ‖c‖₊ * (‖c⁻¹‖₊ * e (c • x)) := _
      _ = e (c • x) := _

    · exact mul_le_mul_left' (e.map_smul_le' _ _) _
    ·
      rw [← mul_assoc, nnnorm_inv, ENNReal.coe_inv, ENNReal.mul_inv_cancel _ ENNReal.coe_ne_top,
          one_mul] <;>
        simp [hc]
#align enorm.map_smul Enorm.map_smul

@[simp]
theorem map_zero : e 0 = 0 := by
  rw [← zero_smul 𝕜 (0 : V), e.map_smul]
  norm_num
#align enorm.map_zero Enorm.map_zero

@[simp]
theorem eq_zero_iff {x : V} : e x = 0 ↔ x = 0 :=
  ⟨e.eq_zero' x, fun h => h.symm ▸ e.map_zero⟩
#align enorm.eq_zero_iff Enorm.eq_zero_iff

@[simp]
theorem map_neg (x : V) : e (-x) = e x :=
  calc
    e (-x) = ‖(-1 : 𝕜)‖₊ * e x := by rw [← map_smul, neg_one_smul]
    _ = e x := by simp

#align enorm.map_neg Enorm.map_neg

theorem map_sub_rev (x y : V) : e (x - y) = e (y - x) := by rw [← neg_sub, e.map_neg]
#align enorm.map_sub_rev Enorm.map_sub_rev

theorem map_add_le (x y : V) : e (x + y) ≤ e x + e y :=
  e.map_add_le' x y
#align enorm.map_add_le Enorm.map_add_le

theorem map_sub_le (x y : V) : e (x - y) ≤ e x + e y :=
  calc
    e (x - y) = e (x + -y) := by rw [sub_eq_add_neg]
    _ ≤ e x + e (-y) := (e.map_add_le x (-y))
    _ = e x + e y := by rw [e.map_neg]

#align enorm.map_sub_le Enorm.map_sub_le

instance : PartialOrder (Enorm 𝕜 V)
    where
  le e₁ e₂ := ∀ x, e₁ x ≤ e₂ x
  le_refl e x := le_rfl
  le_trans e₁ e₂ e₃ h₁₂ h₂₃ x := le_trans (h₁₂ x) (h₂₃ x)
  le_antisymm e₁ e₂ h₁₂ h₂₁ := ext fun x => le_antisymm (h₁₂ x) (h₂₁ x)

/-- The `enorm` sending each non-zero vector to infinity. -/
noncomputable instance : Top (Enorm 𝕜 V) :=
  ⟨{  toFun := fun x => if x = 0 then 0 else ⊤
      eq_zero' := fun x => by split_ifs <;> simp [*]
      map_add_le' := fun x y =>
        by
        split_ifs with hxy hx hy hy hx hy hy <;> try simp [*]
        simpa [hx, hy] using hxy
      map_smul_le' := fun c x =>
        by
        split_ifs with hcx hx hx <;> simp only [smul_eq_zero, not_or] at hcx
        · simp only [MulZeroClass.mul_zero, le_refl]
        · have : c = 0 := by tauto
          simp [this]
        · tauto
        · simp [hcx.1] }⟩

noncomputable instance : Inhabited (Enorm 𝕜 V) :=
  ⟨⊤⟩

theorem top_map {x : V} (hx : x ≠ 0) : (⊤ : Enorm 𝕜 V) x = ⊤ :=
  if_neg hx
#align enorm.top_map Enorm.top_map

noncomputable instance : OrderTop (Enorm 𝕜 V)
    where
  top := ⊤
  le_top e x := if h : x = 0 then by simp [h] else by simp [top_map h]

noncomputable instance : SemilatticeSup (Enorm 𝕜 V) :=
  { Enorm.partialOrder with
    le := (· ≤ ·)
    lt := (· < ·)
    sup := fun e₁ e₂ =>
      { toFun := fun x => max (e₁ x) (e₂ x)
        eq_zero' := fun x h => e₁.eq_zero_iff.1 (ENNReal.max_eq_zero_iff.1 h).1
        map_add_le' := fun x y =>
          max_le (le_trans (e₁.map_add_le _ _) <| add_le_add (le_max_left _ _) (le_max_left _ _))
            (le_trans (e₂.map_add_le _ _) <| add_le_add (le_max_right _ _) (le_max_right _ _))
        map_smul_le' := fun c x => le_of_eq <| by simp only [map_smul, ENNReal.mul_max] }
    le_sup_left := fun e₁ e₂ x => le_max_left _ _
    le_sup_right := fun e₁ e₂ x => le_max_right _ _
    sup_le := fun e₁ e₂ e₃ h₁ h₂ x => max_le (h₁ x) (h₂ x) }

@[simp, norm_cast]
theorem coe_max (e₁ e₂ : Enorm 𝕜 V) : ⇑(e₁ ⊔ e₂) = fun x => max (e₁ x) (e₂ x) :=
  rfl
#align enorm.coe_max Enorm.coe_max

@[norm_cast]
theorem max_map (e₁ e₂ : Enorm 𝕜 V) (x : V) : (e₁ ⊔ e₂) x = max (e₁ x) (e₂ x) :=
  rfl
#align enorm.max_map Enorm.max_map

/-- Structure of an `emetric_space` defined by an extended norm. -/
@[reducible]
def emetricSpace : EMetricSpace V where
  edist x y := e (x - y)
  edist_self x := by simp
  eq_of_edist_eq_zero x y := by simp [sub_eq_zero]
  edist_comm := e.map_sub_rev
  edist_triangle x y z :=
    calc
      e (x - z) = e (x - y + (y - z)) := by rw [sub_add_sub_cancel]
      _ ≤ e (x - y) + e (y - z) := e.map_add_le (x - y) (y - z)

#align enorm.emetric_space Enorm.emetricSpace

/-- The subspace of vectors with finite enorm. -/
def finiteSubspace : Subspace 𝕜 V
    where
  carrier := { x | e x < ⊤ }
  zero_mem' := by simp
  add_mem' x y hx hy := lt_of_le_of_lt (e.map_add_le x y) (ENNReal.add_lt_top.2 ⟨hx, hy⟩)
  smul_mem' c x (hx : _ < _) :=
    calc
      e (c • x) = ‖c‖₊ * e x := e.map_smul c x
      _ < ⊤ := ENNReal.mul_lt_top ENNReal.coe_ne_top hx.Ne

#align enorm.finite_subspace Enorm.finiteSubspace

/-- Metric space structure on `e.finite_subspace`. We use `emetric_space.to_metric_space`
to ensure that this definition agrees with `e.emetric_space`. -/
instance : MetricSpace e.finiteSubspace :=
  by
  letI := e.emetric_space
  refine' EMetricSpace.toMetricSpace fun x y => _
  change e (x - y) ≠ ⊤
  exact ne_top_of_le_ne_top (ENNReal.add_lt_top.2 ⟨x.2, y.2⟩).Ne (e.map_sub_le x y)

theorem finite_dist_eq (x y : e.finiteSubspace) : dist x y = (e (x - y)).toReal :=
  rfl
#align enorm.finite_dist_eq Enorm.finite_dist_eq

theorem finite_edist_eq (x y : e.finiteSubspace) : edist x y = e (x - y) :=
  rfl
#align enorm.finite_edist_eq Enorm.finite_edist_eq

/-- Normed group instance on `e.finite_subspace`. -/
instance : NormedAddCommGroup e.finiteSubspace :=
  { finiteSubspace.metricSpace e,
    Submodule.addCommGroup _ with
    norm := fun x => (e x).toReal
    dist_eq := fun x y => rfl }

theorem finite_norm_eq (x : e.finiteSubspace) : ‖x‖ = (e x).toReal :=
  rfl
#align enorm.finite_norm_eq Enorm.finite_norm_eq

/-- Normed space instance on `e.finite_subspace`. -/
instance : NormedSpace 𝕜 e.finiteSubspace
    where norm_smul_le c x := le_of_eq <| by simp [finite_norm_eq, ENNReal.toReal_mul]

end Enorm


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

Evaluate expressions in the language of commutative monoids and groups.
-/
import algebra.group_power tactic.norm_num

namespace tactic
namespace abel

meta structure cache :=
(α : expr)
(univ : level)
(α0 : expr)
(is_group : bool)
(inst : expr)

meta def mk_cache (e : expr) : tactic cache :=
do α ← infer_type e,
   c ← mk_app ``add_comm_monoid [α] >>= mk_instance,
   cg ← try_core (mk_app ``add_comm_group [α] >>= mk_instance),
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   α0 ← expr.of_nat α 0,
   match cg with
   | (some cg) := return ⟨α, u, α0, tt, cg⟩
   | _ := return ⟨α, u, α0, ff, c⟩
   end

meta def cache.app (c : cache) (n : name) (inst : expr) : list expr → expr :=
(@expr.const tt n [c.univ] c.α inst).mk_app

meta def cache.mk_app (c : cache) (n inst : name) (l : list expr) : tactic expr :=
do m ← mk_instance ((expr.const inst [c.univ] : expr) c.α), return $ c.app n m l

meta def add_g : name → name
| (name.mk_string s p) := name.mk_string (s ++ "g") p
| n := n

meta def cache.iapp (c : cache) (n : name) : list expr → expr :=
c.app (if c.is_group then add_g n else n) c.inst

def term {α} [add_comm_monoid α] (n : ℕ) (x a : α) : α := add_monoid.smul n x + a
def termg {α} [add_comm_group α] (n : ℤ) (x a : α) : α := gsmul n x + a

meta def cache.mk_term (c : cache) (n x a : expr) : expr := c.iapp ``term [n, x, a]

meta def cache.int_to_expr (c : cache) (n : ℤ) : tactic expr :=
expr.of_int (if c.is_group then `(ℤ) else `(ℕ)) n

meta inductive normal_expr : Type
| zero (e : expr) : normal_expr
| nterm (e : expr) (n : expr × ℤ) (x : expr) (a : normal_expr) : normal_expr

meta def normal_expr.e : normal_expr → expr
| (normal_expr.zero e) := e
| (normal_expr.nterm e _ _ _) := e

meta instance : has_coe normal_expr expr := ⟨normal_expr.e⟩

meta def normal_expr.term' (c : cache) (n : expr × ℤ) (x : expr) (a : normal_expr) : normal_expr :=
normal_expr.nterm (c.mk_term n.1 x a) n x a

meta def normal_expr.zero' (c : cache) : normal_expr := normal_expr.zero c.α0

meta def normal_expr.to_list : normal_expr → list (ℤ × expr)
| (normal_expr.zero _) := []
| (normal_expr.nterm _ (_, n) x a) := (n, x) :: a.to_list

open normal_expr

meta def normal_expr.to_string (e : normal_expr) : string :=
" + ".intercalate $ (to_list e).map $
λ ⟨n, e⟩, to_string n ++ " • (" ++ to_string e ++ ")"

meta def normal_expr.pp (e : normal_expr) : tactic format :=
do l ← (to_list e).mmap (λ ⟨n, e⟩, do
  pe ← pp e, return (to_fmt n ++ " • (" ++ pe ++ ")")),
  return $ format.join $ l.intersperse ↑" + "

meta instance : has_to_tactic_format normal_expr := ⟨normal_expr.pp⟩

meta def normal_expr.refl_conv (e : normal_expr) : tactic (normal_expr × expr) :=
do p ← mk_eq_refl e, return (e, p)

theorem const_add_term {α} [add_comm_monoid α] (k n x a a') (h : k + a = a') :
  k + @term α _ n x a = term n x a' := by simp [h.symm, term]

theorem const_add_termg {α} [add_comm_group α] (k n x a a') (h : k + a = a') :
  k + @termg α _ n x a = termg n x a' := by simp [h.symm, termg]

theorem term_add_const {α} [add_comm_monoid α] (n x a k a') (h : a + k = a') :
  @term α _ n x a + k = term n x a' := by simp [h.symm, term]

theorem term_add_constg {α} [add_comm_group α] (n x a k a') (h : a + k = a') :
  @termg α _ n x a + k = termg n x a' := by simp [h.symm, termg]

theorem term_add_term {α} [add_comm_monoid α] (n₁ x a₁ n₂ a₂ n' a')
  (h₁ : n₁ + n₂ = n') (h₂ : a₁ + a₂ = a') :
  @term α _ n₁ x a₁ + @term α _ n₂ x a₂ = term n' x a' :=
by simp [h₁.symm, h₂.symm, term, add_monoid.add_smul]

theorem term_add_termg {α} [add_comm_group α] (n₁ x a₁ n₂ a₂ n' a')
  (h₁ : n₁ + n₂ = n') (h₂ : a₁ + a₂ = a') :
  @termg α _ n₁ x a₁ + @termg α _ n₂ x a₂ = termg n' x a' :=
by simp [h₁.symm, h₂.symm, termg, add_gsmul]

theorem zero_term {α} [add_comm_monoid α] (x a) : @term α _ 0 x a = a :=
by simp [term]

theorem zero_termg {α} [add_comm_group α] (x a) : @termg α _ 0 x a = a :=
by simp [termg]

meta def eval_add (c : cache) : normal_expr → normal_expr → tactic (normal_expr × expr)
| (zero _) e₂ := do
  p ← mk_app ``zero_add [e₂],
  return (e₂, p)
| e₁ (zero _) := do
  p ← mk_app ``add_zero [e₁],
  return (e₁, p)
| he₁@(nterm e₁ n₁ x₁ a₁) he₂@(nterm e₂ n₂ x₂ a₂) :=
  if expr.lex_lt x₁ x₂ then do
    (a', h) ← eval_add a₁ he₂,
    return (term' c n₁ x₁ a', c.iapp ``term_add_const [n₁.1, x₁, a₁, e₂, a', h])
  else if x₁ ≠ x₂ then do
    (a', h) ← eval_add he₁ a₂,
    return (term' c n₂ x₂ a', c.iapp ``const_add_term [e₁, n₂.1, x₂, a₂, a', h])
  else do
    (n', h₁) ← mk_app ``has_add.add [n₁.1, n₂.1] >>= norm_num,
    (a', h₂) ← eval_add a₁ a₂,
    let k := n₁.2 + n₂.2,
    let p₁ := c.iapp ``term_add_term [n₁.1, x₁, a₁, n₂.1, a₂, n', a', h₁, h₂],
    if k = 0 then do
      p ← mk_eq_trans p₁ (c.iapp ``zero_term [x₁, a']),
      return (a', p)
    else return (term' c (n', k) x₁ a', p₁)

theorem term_neg {α} [add_comm_group α] (n x a n' a')
  (h₁ : -n = n') (h₂ : -a = a') :
  -@termg α _ n x a = termg n' x a' :=
by simp [h₂.symm, h₁.symm, termg]

meta def eval_neg (c : cache) : normal_expr → tactic (normal_expr × expr)
| (zero e) := do
  p ← c.mk_app ``neg_zero ``add_group [],
  return (zero' c, p)
| (nterm e n x a) := do
  (n', h₁) ← mk_app ``has_neg.neg [n.1] >>= norm_num,
  (a', h₂) ← eval_neg a,
  return (term' c (n', -n.2) x a',
    c.app ``term_neg c.inst [n.1, x, a, n', a', h₁, h₂])

def smul {α} [add_comm_monoid α] (n : ℕ) (x : α) : α := add_monoid.smul n x
def smulg {α} [add_comm_group α] (n : ℤ) (x : α) : α := gsmul n x

theorem zero_smul {α} [add_comm_monoid α] (c) : smul c (0 : α) = 0 :=
by simp [smul]

theorem zero_smulg {α} [add_comm_group α] (c) : smulg c (0 : α) = 0 :=
by simp [smulg]

theorem term_smul {α} [add_comm_monoid α] (c n x a n' a')
  (h₁ : c * n = n') (h₂ : smul c a = a') :
  smul c (@term α _ n x a) = term n' x a' :=
by simp [h₂.symm, h₁.symm, term, smul, add_monoid.smul_add, add_monoid.mul_smul]

theorem term_smulg {α} [add_comm_group α] (c n x a n' a')
  (h₁ : c * n = n') (h₂ : smulg c a = a') :
  smulg c (@termg α _ n x a) = termg n' x a' :=
by simp [h₂.symm, h₁.symm, termg, smulg, gsmul_add, gsmul_mul]

meta def eval_smul (c : cache) (k : expr × ℤ) :
  normal_expr → tactic (normal_expr × expr)
| (zero _) := return (zero' c, c.iapp ``zero_smul [k.1])
| (nterm e n x a) := do
  (n', h₁) ← mk_app ``has_mul.mul [k.1, n.1] >>= norm_num,
  (a', h₂) ← eval_smul a,
  return (term' c (n', k.2 * n.2) x a',
    c.iapp ``term_smul [k.1, n.1, x, a, n', a', h₁, h₂])

theorem term_atom {α} [add_comm_monoid α] (x : α) : x = term 1 x 0 :=
by simp [term]

theorem term_atomg {α} [add_comm_group α] (x : α) : x = termg 1 x 0 :=
by simp [termg]

meta def eval_atom (c : cache) (e : expr) : tactic (normal_expr × expr) :=
do n1 ← c.int_to_expr 1,
   return (term' c (n1, 1) e (zero' c), c.iapp ``term_atom [e])

lemma unfold_sub {α} [add_group α] (a b c : α)
  (h : a + -b = c) : a - b = c := h

theorem unfold_smul {α} [add_comm_monoid α] (n) (x y : α)
  (h : smul n x = y) : add_monoid.smul n x = y := h

theorem unfold_smulg {α} [add_comm_group α] (n : ℕ) (x y : α)
  (h : smulg (int.of_nat n) x = y) : add_monoid.smul n x = y := h

theorem unfold_gsmul {α} [add_comm_group α] (n : ℤ) (x y : α)
  (h : smulg n x = y) : gsmul n x = y := h

lemma subst_into_smul {α} [add_comm_monoid α]
  (l r tl tr t) (prl : l = tl) (prr : r = tr)
  (prt : @smul α _ tl tr = t) : smul l r = t :=
by simp [prl, prr, prt]

lemma subst_into_smulg {α} [add_comm_group α]
  (l r tl tr t) (prl : l = tl) (prr : r = tr)
  (prt : @smulg α _ tl tr = t) : smulg l r = t :=
by simp [prl, prr, prt]

meta def eval (c : cache) : expr → tactic (normal_expr × expr)
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_sum ``has_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| `(%%e₁ - %%e₂) := do
  e₂' ← mk_app ``has_neg.neg [e₂],
  e ← mk_app ``has_add.add [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_sub ``add_group [e₁, e₂, e', p],
  return (e', p')
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg c e₁,
  p ← c.mk_app ``norm_num.subst_into_neg ``has_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(add_monoid.smul %%e₁ %%e₂) := do
  n ← if c.is_group then mk_app ``int.of_nat [e₁] else return e₁,
  (e', p) ← eval $ c.iapp ``smul [n, e₂],
  return (e', c.iapp ``unfold_smul [e₁, e₂, e', p])
| `(gsmul %%e₁ %%e₂) := do
  guardb c.is_group,
  (e', p) ← eval $ c.iapp ``smul [e₁, e₂],
  return (e', c.app ``unfold_gsmul c.inst [e₁, e₂, e', p])
| `(smul %%e₁ %%e₂) := do
  guard (¬ c.is_group),
  (e₁', p₁) ← norm_num.derive e₁ <|> refl_conv e₁, n ← e₁'.to_nat,
  (e₂', p₂) ← eval e₂,
  (e', p) ← eval_smul c (e₁', n) e₂',
  return (e', c.iapp ``subst_into_smul [e₁, e₂, e₁', e₂', e', p₁, p₂, p])
| `(smulg %%e₁ %%e₂) := do
  guardb c.is_group,
  (e₁', p₁) ← norm_num.derive e₁ <|> refl_conv e₁, n ← e₁'.to_int,
  (e₂', p₂) ← eval e₂,
  (e', p) ← eval_smul c (e₁', n) e₂',
  return (e', c.iapp ``subst_into_smul [e₁, e₂, e₁', e₂', e', p₁, p₂, p])
| e := eval_atom c e

meta def eval' (c : cache) (e : expr) : tactic (expr × expr) :=
do (e', p) ← eval c e, return (e', p)

@[derive has_reflect]
inductive normalize_mode | raw | term

meta def normalize (mode := normalize_mode.term) (e : expr) : tactic (expr × expr) := do
pow_lemma ← simp_lemmas.mk.add_simp ``pow_one,
let lemmas := match mode with
| normalize_mode.term :=
  [``term.equations._eqn_1, ``termg.equations._eqn_1,
   ``add_zero, ``add_monoid.one_smul, ``one_gsmul]
| _ := []
end,
lemmas ← lemmas.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
(_, e', pr) ← ext_simplify_core () {}
  simp_lemmas.mk (λ _, failed) (λ _ _ _ _ e, do
    c ← mk_cache e,
    (new_e, pr) ← match mode with
    | normalize_mode.raw := eval' c
    | normalize_mode.term := trans_conv (eval' c) (simplify lemmas [])
    end e,
    guard (¬ new_e =ₐ e),
    return ((), new_e, some pr, ff))
   (λ _ _ _ _ _, failed) `eq e,
return (e', pr)

end abel

namespace interactive
open interactive interactive.types lean.parser
open tactic.abel

local postfix `?`:9001 := optional

/-- Tactic for solving equations in the language of
  commutative monoids and groups.
  This version of `abel` fails if the target is not an equality
  that is provable by the axioms of commutative monoids/groups. -/
meta def abel1 : tactic unit :=
do `(%%e₁ = %%e₂) ← target,
  c ← mk_cache e₁,
  (e₁', p₁) ← eval c e₁,
  (e₂', p₂) ← eval c e₂,
  is_def_eq e₁' e₂',
  p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
  tactic.exact p

meta def abel.mode : lean.parser abel.normalize_mode :=
with_desc "(raw|term)?" $
do mode ← ident?, match mode with
| none       := return abel.normalize_mode.term
| some `term := return abel.normalize_mode.term
| some `raw  := return abel.normalize_mode.raw
| _          := failed
end

/-- Tactic for solving equations in the language of
  commutative monoids and groups.
  Attempts to prove the goal outright if there is no `at`
  specifier and the target is an equality, but if this
  fails it falls back to rewriting all monoid expressions
  into a normal form. -/
meta def abel (SOP : parse abel.mode) (loc : parse location) : tactic unit :=
match loc with
| interactive.loc.ns [none] := abel1
| _ := failed
end <|>
do ns ← loc.get_locals,
   tt ← tactic.replace_at (normalize SOP) ns loc.include_goal
      | fail "abel failed to simplify",
   when loc.include_goal $ try tactic.reflexivity

end interactive
end tactic


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.whiskering
import category_theory.functor.fully_faithful
import category_theory.natural_isomorphism
import data.sigma.basic

/-!
# Disjoint union of categories

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace category_theory
namespace sigma

universes w₁ w₂ w₃ v₁ v₂ u₁ u₂

variables {I : Type w₁} {C : I → Type u₁} [Π i, category.{v₁} (C i)]

/--
The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive sigma_hom : (Σ i, C i) → (Σ i, C i) → Type (max w₁ v₁ u₁)
| mk : Π {i : I} {X Y : C i}, (X ⟶ Y) → sigma_hom ⟨i, X⟩ ⟨i, Y⟩

namespace sigma_hom

/-- The identity morphism on an object. -/
def id : Π (X : Σ i, C i), sigma_hom X X
| ⟨i, X⟩ := mk (𝟙 _)

instance (X : Σ i, C i) : inhabited (sigma_hom X X) := ⟨id X⟩

/-- Composition of sigma homomorphisms. -/
def comp : Π {X Y Z : Σ i, C i}, sigma_hom X Y → sigma_hom Y Z → sigma_hom X Z
| _ _ _ (mk f) (mk g) := mk (f ≫ g)

instance : category_struct (Σ i, C i) :=
{ hom := sigma_hom,
  id := id,
  comp := λ X Y Z f g, comp f g }

@[simp]
lemma comp_def (i : I) (X Y Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) :
  comp (mk f) (mk g) = mk (f ≫ g) :=
rfl

lemma assoc : ∀ (X Y Z W : Σ i, C i) (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W), (f ≫ g) ≫ h = f ≫ g ≫ h
| _ _ _ _ (mk f) (mk g) (mk h) := congr_arg mk (category.assoc _ _ _)

lemma id_comp : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), 𝟙 X ≫ f = f
| _ _ (mk f) := congr_arg mk (category.id_comp _)

lemma comp_id : ∀ (X Y : Σ i, C i) (f : X ⟶ Y), f ≫ 𝟙 Y = f
| _ _ (mk f) := congr_arg mk (category.comp_id _)

end sigma_hom

instance sigma : category (Σ i, C i) :=
{ id_comp' := sigma_hom.id_comp,
  comp_id' := sigma_hom.comp_id,
  assoc' := sigma_hom.assoc }

/-- The inclusion functor into the disjoint union of categories. -/
@[simps map]
def incl (i : I) : C i ⥤ Σ i, C i :=
{ obj := λ X, ⟨i, X⟩,
  map := λ X Y, sigma_hom.mk }

@[simp] lemma incl_obj {i : I} (X : C i) : (incl i).obj X = ⟨i, X⟩ := rfl

instance (i : I) : full (incl i : C i ⥤ Σ i, C i) :=
{ preimage := λ X Y ⟨f⟩, f,
  witness' := λ X Y ⟨f⟩, rfl }.

instance (i : I) : faithful (incl i : C i ⥤ Σ i, C i) := {}.

section
variables {D : Type u₂} [category.{v₂} D] (F : Π i, C i ⥤ D)

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def nat_trans {F G : (Σ i, C i) ⥤ D} (h : Π (i : I), incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G :=
{ app := λ ⟨j, X⟩, (h j).app X,
  naturality' := by { rintro ⟨j, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩, apply (h j).naturality } }

@[simp]

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def desc_map : ∀ (X Y : Σ i, C i), (X ⟶ Y) → ((F X.1).obj X.2 ⟶ (F Y.1).obj Y.2)
| _ _ (sigma_hom.mk g) := (F _).map g

/--
Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simps obj]
def desc : (Σ i, C i) ⥤ D :=
{ obj := λ X, (F X.1).obj X.2,
  map := λ X Y g, desc_map F X Y g,
  map_id' := by { rintro ⟨i, X⟩, apply (F i).map_id },
  map_comp' := by { rintro ⟨i, X⟩ ⟨_, Y⟩ ⟨_, Z⟩ ⟨i, _, Y, f⟩ ⟨_, _, Z, g⟩, apply (F i).map_comp } }

@[simp]
lemma desc_map_mk {i : I} (X Y : C i) (f : X ⟶ Y) :
  (desc F).map (sigma_hom.mk f) = (F i).map f :=
rfl

/--
This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
-- We hand-generate the simp lemmas about this since they come out cleaner.
def incl_desc (i : I) : incl i ⋙ desc F ≅ F i :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma incl_desc_hom_app (i : I) (X : C i) :
  (incl_desc F i).hom.app X = 𝟙 ((F i).obj X) :=
rfl

@[simp]
lemma incl_desc_inv_app (i : I) (X : C i) :
  (incl_desc F i).inv.app X = 𝟙 ((F i).obj X) :=
rfl

/--
If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def desc_uniq (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) : q ≅ desc F :=
nat_iso.of_components (λ ⟨i, X⟩, (h i).app X) $
  by { rintro ⟨i, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩, apply (h i).hom.naturality f }

@[simp]
lemma desc_uniq_hom_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).hom.app ⟨i, X⟩ = (h i).hom.app X :=
rfl

@[simp]
lemma desc_uniq_inv_app (q : (Σ i, C i) ⥤ D) (h : Π i, incl i ⋙ q ≅ F i) (i : I) (X : C i) :
  (desc_uniq F q h).inv.app ⟨i, X⟩ = (h i).inv.app X :=
rfl

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simps]
def nat_iso {q₁ q₂ : (Σ i, C i) ⥤ D} (h : Π i, incl i ⋙ q₁ ≅ incl i ⋙ q₂) :
  q₁ ≅ q₂ :=
{ hom := nat_trans (λ i, (h i).hom),
  inv := nat_trans (λ i, (h i).inv) }

end

section

variables (C) {J : Type w₂} (g : J → I)

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map : (Σ (j : J), C (g j)) ⥤ (Σ (i : I), C i) :=
desc (λ j, incl (g j))

@[simp] lemma map_obj (j : J) (X : C (g j)) : (sigma.map C g).obj ⟨j, X⟩ = ⟨g j, X⟩ := rfl
@[simp] lemma map_map {j : J} {X Y : C (g j)} (f : X ⟶ Y) :
  (sigma.map C g).map (sigma_hom.mk f) = sigma_hom.mk f :=
rfl

/--
The functor `sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simps]
def incl_comp_map (j : J) : incl j ⋙ map C g ≅ incl (g j) := iso.refl _

variable (I)

/-- The functor `sigma.map` applied to the identity function is just the identity functor. -/
@[simps]
def map_id : map C (id : I → I) ≅ 𝟭 (Σ i, C i) :=
nat_iso (λ i, nat_iso.of_components (λ X, iso.refl _) (by tidy))

variables {I} {K : Type w₃}

/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simps]
def map_comp (f : K → J) (g : J → I) : map (C ∘ g) f ⋙ (map C g : _) ≅ map C (g ∘ f) :=
desc_uniq _ _ $ λ k,
  (iso_whisker_right (incl_comp_map (C ∘ g) f k) (map C g : _) : _) ≪≫ incl_comp_map _ _ _

end

namespace functor

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]

/--
Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma (F : Π i, C i ⥤ D i) : (Σ i, C i) ⥤ (Σ i, D i) :=
desc (λ i, F i ⋙ incl i)

end functor

namespace nat_trans

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]
variables {F G : Π i, C i ⥤ D i}

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma (α : Π i, F i ⟶ G i) : functor.sigma F ⟶ functor.sigma G :=
{ app := λ f, sigma_hom.mk ((α f.1).app _),
  naturality' :=
  begin
    rintro ⟨i, X⟩ ⟨_, _⟩ ⟨_, _, Y, f⟩,
    change sigma_hom.mk _ = sigma_hom.mk _,
    rw (α i).naturality,
  end }

end nat_trans

end sigma
end category_theory


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

/-!
# Probabilities for Computations Over Prod Type

General lemmas about probability computations involving `prod`
-/

namespace oracle_comp

open oracle_spec
open_locale big_operators ennreal

variables {α β γ δ : Type} {spec spec' : oracle_spec}
  (oa : oracle_comp spec (α × β)) (oc : α × β → oracle_comp spec γ)

section eval_dist

/-- Binding on a computation of a `prod` type can be written as a double sum,
instead of a sum of the product type. -/
lemma eval_dist_prod_bind (c : γ) :
  ⁅oa >>= oc⁆ c = ∑' (a : α) (b : β), ⁅oa⁆ (a, b) * ⁅oc (a, b)⁆ c :=
by rw [eval_dist_bind_apply_eq_tsum, ennreal.tsum_prod']

/-- Version of `eval_dist_prod_bind` with summation arguments swapped. -/
lemma eval_dist_prod_bind' (c : γ) :
  ⁅oa >>= oc⁆ c = ∑' (b : β) (a : α), ⁅oa⁆ (a, b) * ⁅oc (a, b)⁆ c :=
by rw [eval_dist_bind_apply_eq_tsum, ennreal.tsum_prod', ennreal.tsum_comm]

/-- The first output of a computation of a `prod` type is a sum over possible second outputs. -/
lemma eval_dist_map_fst (a : α) : ⁅prod.fst <$> oa⁆ a = ∑' (b : β), ⁅oa⁆ (a, b) :=
by rw [eval_dist_map, pmf.map_fst_apply]

/-- The second output of a computation of a `prod` type is a sum over possible first outputs -/
lemma eval_dist_map_snd (b : β) : ⁅prod.snd <$> oa⁆ b = ∑' (a : α), ⁅oa⁆ (a, b) :=
by rw [eval_dist_map, pmf.map_snd_apply]

/-- If only the left output is changed in mapping the result of a computation,
then the resulting distribution sums only over the left type in the product type. -/
lemma eval_dist_map_prod_map_id_right_apply [decidable_eq β] [decidable_eq γ] (f : α → γ)
  (z : γ × β) : ⁅prod.map f id <$> oa⁆ z = ∑' (x : α), ite (z.1 = f x) (⁅oa⁆ (x, z.2)) 0 :=
begin
  rw [eval_dist_map_apply_eq_tsum, ennreal.tsum_prod'],
  refine tsum_congr (λ x, (tsum_eq_single z.2 _).trans _),
  { exact λ y hy, if_neg $ by simp only [prod.eq_iff_fst_eq_snd_eq, hy.symm,
      prod.map_mk, id.def, and_false, not_false_iff] },
  { simp only [prod.eq_iff_fst_eq_snd_eq, prod.map_mk, id.def, eq_self_iff_true, and_true] },
end

/-- If only the right output is changed in mapping the result of a computation,
then the resulting distribution sums only over the right type in the product type. -/
lemma eval_dist_map_prod_map_id_left_apply [decidable_eq α] [decidable_eq γ] (f : β → γ)
  (z : α × γ) : ⁅prod.map id f <$> oa⁆ z = ∑' (y : β), ite (z.2 = f y) (⁅oa⁆ (z.1, y)) 0 :=
begin
  rw [eval_dist_map_apply_eq_tsum, ennreal.tsum_prod', ennreal.tsum_comm],
  refine tsum_congr (λ x, (tsum_eq_single z.1 _).trans _),
  { exact λ y hy, if_neg $ by simp only [prod.eq_iff_fst_eq_snd_eq, hy.symm,
      prod.map_mk, id.def, false_and, not_false_iff]},
  { simp only [prod.eq_iff_fst_eq_snd_eq, prod.map_mk, id.def, eq_self_iff_true, true_and] },
end

end eval_dist

section prob_event

lemma prob_event_diagonal [decidable_eq α] (oa : oracle_comp spec (α × α)) :
  ⁅set.diagonal α | oa⁆ = ∑' (a : α), ⁅oa⁆ (a, a) :=
calc ⁅set.diagonal α | oa⁆ = ∑' (x : α × α), ite (x ∈ set.diagonal α) (⁅oa⁆ x) 0 :
    prob_event_eq_tsum_ite oa (set.diagonal α)
  ... = ∑' (a a' : α), ite (a = a') (⁅oa⁆ (a, a')) 0 :
    tsum_prod' ennreal.summable (λ _, ennreal.summable)
  ... = ∑' (a a' : α), ite (a = a') (⁅oa⁆ (a, a)) 0 :
    tsum_congr (λ a, tsum_congr (λ a', by by_cases h : a = a'; simp only [h, if_false]))
  ... = ∑' (a a' : α), ite (a' = a) (⁅oa⁆ (a, a)) 0 : by simp_rw [@eq_comm]
  ... = ∑' (a : α), ⁅oa⁆ (a, a) : tsum_congr (λ a, tsum_ite_eq _ _)

end prob_event

end oracle_comp