/-
Copyright (c) 2022 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Anatole Dedecker
-/
import analysis.locally_convex.balanced_core_hull
import topology.algebra.module.simple
import topology.algebra.module.determinant

/-!
# Finite dimensional topological vector spaces over complete fields

Let `𝕜` be a complete nontrivially normed field, and `E` a topological vector space (TVS) over
`𝕜` (i.e we have `[add_comm_group E] [module 𝕜 E] [topological_space E] [topological_add_group E]`
and `[has_continuous_smul 𝕜 E]`).

If `E` is finite dimensional and Hausdorff, then all linear maps from `E` to any other TVS are
continuous.

When `E` is a normed space, this gets us the equivalence of norms in finite dimension.

## Main results :

* `linear_map.continuous_iff_is_closed_ker` : a linear form is continuous if and only if its kernel
  is closed.
* `linear_map.continuous_of_finite_dimensional` : a linear map on a finite-dimensional Hausdorff
  space over a complete field is continuous.

## TODO

Generalize more of `analysis/normed_space/finite_dimension` to general TVSs.

## Implementation detail

The main result from which everything follows is the fact that, if `ξ : ι → E` is a finite basis,
then `ξ.equiv_fun : E →ₗ (ι → 𝕜)` is continuous. However, for technical reasons, it is easier to
prove this when `ι` and `E` live ine the same universe. So we start by doing that as a private
lemma, then we deduce `linear_map.continuous_of_finite_dimensional` from it, and then the general
result follows as `continuous_equiv_fun_basis`.

-/

universes u v w x

noncomputable theory

open set finite_dimensional topological_space filter
open_locale big_operators

section field

variables {𝕜 E F : Type*} [field 𝕜] [topological_space 𝕜] [add_comm_group E] [module 𝕜 E]
  [topological_space E] [add_comm_group F] [module 𝕜 F] [topological_space F]
  [topological_add_group F] [has_continuous_smul 𝕜 F]

/-- The space of continuous linear maps between finite-dimensional spaces is finite-dimensional. -/
instance [finite_dimensional 𝕜 E] [finite_dimensional 𝕜 F] :
  finite_dimensional 𝕜 (E →L[𝕜] F) :=
finite_dimensional.of_injective
  (continuous_linear_map.coe_lm 𝕜 : (E →L[𝕜] F) →ₗ[𝕜] (E →ₗ[𝕜] F))
  continuous_linear_map.coe_injective

end field

section normed_field

variables {𝕜 : Type u} [hnorm : nontrivially_normed_field 𝕜]
  {E : Type v} [add_comm_group E] [module 𝕜 E] [topological_space E]
  [topological_add_group E] [has_continuous_smul 𝕜 E]
  {F : Type w} [add_comm_group F] [module 𝕜 F] [topological_space F]
  [topological_add_group F] [has_continuous_smul 𝕜 F]
  {F' : Type x} [add_comm_group F'] [module 𝕜 F'] [topological_space F']
  [topological_add_group F'] [has_continuous_smul 𝕜 F']

include hnorm

/-- If `𝕜` is a nontrivially normed field, any T2 topology on `𝕜` which makes it a topological
vector space over itself (with the norm topology) is *equal* to the norm topology. -/
lemma unique_topology_of_t2 {t : topological_space 𝕜}
  (h₁ : @topological_add_group 𝕜 t _)
  (h₂ : @has_continuous_smul 𝕜 𝕜 _ hnorm.to_uniform_space.to_topological_space t)
  (h₃ : @t2_space 𝕜 t) :
  t = hnorm.to_uniform_space.to_topological_space :=
begin
  -- Let `𝓣₀` denote the topology on `𝕜` induced by the norm, and `𝓣` be any T2 vector
  -- topology on `𝕜`. To show that `𝓣₀ = 𝓣`, it suffices to show that they have the same
  -- neighborhoods of 0.
  refine topological_add_group.ext h₁ infer_instance (le_antisymm _ _),
  { -- To show `𝓣 ≤ 𝓣₀`, we have to show that closed balls are `𝓣`-neighborhoods of 0.
    rw metric.nhds_basis_closed_ball.ge_iff,
    -- Let `ε > 0`. Since `𝕜` is nontrivially normed, we have `0 < ‖ξ₀‖ < ε` for some `ξ₀ : 𝕜`.
    intros ε hε,
    rcases normed_field.exists_norm_lt 𝕜 hε with ⟨ξ₀, hξ₀, hξ₀ε⟩,
    -- Since `ξ₀ ≠ 0` and `𝓣` is T2, we know that `{ξ₀}ᶜ` is a `𝓣`-neighborhood of 0.
    have : {ξ₀}ᶜ ∈ @nhds 𝕜 t 0 :=
      is_open.mem_nhds is_open_compl_singleton (ne.symm $ norm_ne_zero_iff.mp hξ₀.ne.symm),
    -- Thus, its balanced core `𝓑` is too. Let's show that the closed ball of radius `ε` contains
    -- `𝓑`, which will imply that the closed ball is indeed a `𝓣`-neighborhood of 0.
    have : balanced_core 𝕜 {ξ₀}ᶜ ∈ @nhds 𝕜 t 0 := balanced_core_mem_nhds_zero this,
    refine mem_of_superset this (λ ξ hξ, _),
    -- Let `ξ ∈ 𝓑`. We want to show `‖ξ‖ < ε`. If `ξ = 0`, this is trivial.
    by_cases hξ0 : ξ = 0,
    { rw hξ0,
      exact metric.mem_closed_ball_self hε.le },
    { rw [mem_closed_ball_zero_iff],
      -- Now suppose `ξ ≠ 0`. By contradiction, let's assume `ε < ‖ξ‖`, and show that
      -- `ξ₀ ∈ 𝓑 ⊆ {ξ₀}ᶜ`, which is a contradiction.
      by_contra' h,
      suffices : (ξ₀ * ξ⁻¹) • ξ ∈ balanced_core 𝕜 {ξ₀}ᶜ,
      { rw [smul_eq_mul 𝕜, mul_assoc, inv_mul_cancel hξ0, mul_one] at this,
        exact not_mem_compl_iff.mpr (mem_singleton ξ₀) ((balanced_core_subset _) this) },
      -- For that, we use that `𝓑` is balanced : since `‖ξ₀‖ < ε < ‖ξ‖`, we have `‖ξ₀ / ξ‖ ≤ 1`,
      -- hence `ξ₀ = (ξ₀ / ξ) • ξ ∈ 𝓑` because `ξ ∈ 𝓑`.
      refine (balanced_core_balanced _).smul_mem _ hξ,
      rw [norm_mul, norm_inv, mul_inv_le_iff (norm_pos_iff.mpr hξ0), mul_one],
      exact (hξ₀ε.trans h).le } },
  { -- Finally, to show `𝓣₀ ≤ 𝓣`, we simply argue that `id = (λ x, x • 1)` is continuous from
    -- `(𝕜, 𝓣₀)` to `(𝕜, 𝓣)` because `(•) : (𝕜, 𝓣₀) × (𝕜, 𝓣) → (𝕜, 𝓣)` is continuous.
    calc (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0)
        = map id (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0) : map_id.symm
    ... = map (λ x, id x • 1) (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0) :
        by conv_rhs {congr, funext, rw [smul_eq_mul, mul_one]}; refl
    ... ≤ (@nhds 𝕜 t ((0 : 𝕜) • 1)) :
        @tendsto.smul_const _ _ _ hnorm.to_uniform_space.to_topological_space t _ _ _ _ _
          tendsto_id (1 : 𝕜)
    ... = (@nhds 𝕜 t 0) : by rw zero_smul }
end

/-- Any linear form on a topological vector space over a nontrivially normed field is continuous if
    its kernel is closed. -/
lemma linear_map.continuous_of_is_closed_ker (l : E →ₗ[𝕜] 𝕜) (hl : is_closed (l.ker : set E)) :
  continuous l :=
begin
  -- `l` is either constant or surjective. If it is constant, the result is trivial.
  by_cases H : finrank 𝕜 l.range = 0,
  { rw [finrank_eq_zero, linear_map.range_eq_bot] at H,
    rw H,
    exact continuous_zero },
  { -- In the case where `l` is surjective, we factor it as `φ : (E ⧸ l.ker) ≃ₗ[𝕜] 𝕜`. Note that
    -- `E ⧸ l.ker` is T2 since `l.ker` is closed.
    have : finrank 𝕜 l.range = 1,
      from le_antisymm (finrank_self 𝕜 ▸ l.range.finrank_le) (zero_lt_iff.mpr H),
    have hi : function.injective (l.ker.liftq l (le_refl _)),
    { rw [← linear_map.ker_eq_bot],
      exact submodule.ker_liftq_eq_bot _ _ _ (le_refl _) },
    have hs : function.surjective (l.ker.liftq l (le_refl _)),
    { rw [← linear_map.range_eq_top, submodule.range_liftq],
      exact eq_top_of_finrank_eq ((finrank_self 𝕜).symm ▸ this) },
    let φ : (E ⧸ l.ker) ≃ₗ[𝕜] 𝕜 := linear_equiv.of_bijective (l.ker.liftq l (le_refl _)) ⟨hi, hs⟩,
    have hlφ : (l : E → 𝕜) = φ ∘ l.ker.mkq,
      by ext; refl,
    -- Since the quotient map `E →ₗ[𝕜] (E ⧸ l.ker)` is continuous, the continuity of `l` will follow
    -- form the continuity of `φ`.
    suffices : continuous φ.to_equiv,
    { rw hlφ,
      exact this.comp continuous_quot_mk },
    -- The pullback by `φ.symm` of the quotient topology is a T2 topology on `𝕜`, because `φ.symm`
    -- is injective. Since `φ.symm` is linear, it is also a vector space topology.
    -- Hence, we know that it is equal to the topology induced by the norm.
    have : induced φ.to_equiv.symm infer_instance = hnorm.to_uniform_space.to_topological_space,
    { refine unique_topology_of_t2 (topological_add_group_induced φ.symm.to_linear_map)
        (has_continuous_smul_induced φ.symm.to_linear_map) _,
      rw t2_space_iff,
      exact λ x y hxy, @separated_by_continuous _ _ (induced _ _) _ _ _
        continuous_induced_dom _ _ (φ.to_equiv.symm.injective.ne hxy) },
    -- Finally, the pullback by `φ.symm` is exactly the pushforward by `φ`, so we have to prove
    -- that `φ` is continuous when `𝕜` is endowed with the pushforward by `φ` of the quotient
    -- topology, which is trivial by definition of the pushforward.
    rw [this.symm, equiv.induced_symm],
    exact continuous_coinduced_rng }
end

/-- Any linear form on a topological vector space over a nontrivially normed field is continuous if
    and only if its kernel is closed. -/
lemma linear_map.continuous_iff_is_closed_ker (l : E →ₗ[𝕜] 𝕜) :
  continuous l ↔ is_closed (l.ker : set E) :=
⟨λ h, is_closed_singleton.preimage h, l.continuous_of_is_closed_ker⟩

/-- Over a nontrivially normed field, any linear form which is nonzero on a nonempty open set is
    automatically continuous. -/
lemma linear_map.continuous_of_nonzero_on_open (l : E →ₗ[𝕜] 𝕜) (s : set E) (hs₁ : is_open s)
  (hs₂ : s.nonempty) (hs₃ : ∀ x ∈ s, l x ≠ 0) : continuous l :=
begin
  refine l.continuous_of_is_closed_ker (l.is_closed_or_dense_ker.resolve_right $ λ hl, _),
  rcases hs₂ with ⟨x, hx⟩,
  have : x ∈ interior (l.ker : set E)ᶜ,
  { rw mem_interior_iff_mem_nhds,
    exact mem_of_superset (hs₁.mem_nhds hx) hs₃ },
  rwa hl.interior_compl at this
end

variables [complete_space 𝕜]

/-- This version imposes `ι` and `E` to live in the same universe, so you should instead use
`continuous_equiv_fun_basis` which gives the same result without universe restrictions. -/
private lemma continuous_equiv_fun_basis_aux [ht2 : t2_space E] {ι : Type v} [fintype ι]
  (ξ : basis ι 𝕜 E) : continuous ξ.equiv_fun :=
begin
  letI : uniform_space E := topological_add_group.to_uniform_space E,
  letI : uniform_add_group E := topological_add_comm_group_is_uniform,
  letI : separated_space E := separated_iff_t2.mpr ht2,
  unfreezingI { induction hn : fintype.card ι with n IH generalizing ι E },
  { rw fintype.card_eq_zero_iff at hn,
    exact continuous_of_const (λ x y, funext hn.elim) },
  { haveI : finite_dimensional 𝕜 E := of_fintype_basis ξ,
    -- first step: thanks to the induction hypothesis, any n-dimensional subspace is equivalent
    -- to a standard space of dimension n, hence it is complete and therefore closed.
    have H₁ : ∀s : submodule 𝕜 E, finrank 𝕜 s = n → is_closed (s : set E),
    { assume s s_dim,
      letI : uniform_add_group s := s.to_add_subgroup.uniform_add_group,
      let b := basis.of_vector_space 𝕜 s,
      have U : uniform_embedding b.equiv_fun.symm.to_equiv,
      { have : fintype.card (basis.of_vector_space_index 𝕜 s) = n,
          by { rw ← s_dim, exact (finrank_eq_card_basis b).symm },
        have : continuous b.equiv_fun := IH b this,
        exact b.equiv_fun.symm.uniform_embedding b.equiv_fun.symm.to_linear_map.continuous_on_pi
          this },
      have : is_complete (s : set E),
        from complete_space_coe_iff_is_complete.1 ((complete_space_congr U).1 (by apply_instance)),
      exact this.is_closed },
    -- second step: any linear form is continuous, as its kernel is closed by the first step
    have H₂ : ∀f : E →ₗ[𝕜] 𝕜, continuous f,
    { assume f,
      by_cases H : finrank 𝕜 f.range = 0,
      { rw [finrank_eq_zero, linear_map.range_eq_bot] at H,
        rw H,
        exact continuous_zero },
      { have : finrank 𝕜 f.ker = n,
        { have Z := f.finrank_range_add_finrank_ker,
          rw [finrank_eq_card_basis ξ, hn] at Z,
          have : finrank 𝕜 f.range = 1,
            from le_antisymm (finrank_self 𝕜 ▸ f.range.finrank_le) (zero_lt_iff.mpr H),
          rw [this, add_comm, nat.add_one] at Z,
          exact nat.succ.inj Z },
        have : is_closed (f.ker : set E),
          from H₁ _ this,
        exact linear_map.continuous_of_is_closed_ker f this } },
    rw continuous_pi_iff,
    intros i,
    change continuous (ξ.coord i),
    exact H₂ (ξ.coord i) },
end

/-- Any linear map on a finite dimensional space over a complete field is continuous. -/
theorem linear_map.continuous_of_finite_dimensional [t2_space E] [finite_dimensional 𝕜 E]
  (f : E →ₗ[𝕜] F') :
  continuous f :=
begin
  -- for the proof, go to a model vector space `b → 𝕜` thanks to `continuous_equiv_fun_basis`, and
  -- argue that all linear maps there are continuous.
  let b := basis.of_vector_space 𝕜 E,
  have A : continuous b.equiv_fun :=
    continuous_equiv_fun_basis_aux b,
  have B : continuous (f.comp (b.equiv_fun.symm : (basis.of_vector_space_index 𝕜 E → 𝕜) →ₗ[𝕜] E)) :=
    linear_map.continuous_on_pi _,
  have : continuous ((f.comp (b.equiv_fun.symm : (basis.of_vector_space_index 𝕜 E → 𝕜) →ₗ[𝕜] E))
                      ∘ b.equiv_fun) := B.comp A,
  convert this,
  ext x,
  dsimp,
  rw [basis.equiv_fun_symm_apply, basis.sum_repr]
end

instance linear_map.continuous_linear_map_class_of_finite_dimensional
  [t2_space E] [finite_dimensional 𝕜 E] :
  continuous_linear_map_class (E →ₗ[𝕜] F') 𝕜 E F' :=
{ map_continuous := λ f, f.continuous_of_finite_dimensional,
  ..linear_map.semilinear_map_class }

/-- In finite dimensions over a non-discrete complete normed field, the canonical identification
(in terms of a basis) with `𝕜^n` (endowed with the product topology) is continuous.
This is the key fact wich makes all linear maps from a T2 finite dimensional TVS over such a field
continuous (see `linear_map.continuous_of_finite_dimensional`), which in turn implies that all
norms are equivalent in finite dimensions. -/
theorem continuous_equiv_fun_basis [t2_space E] {ι : Type*} [fintype ι] (ξ : basis ι 𝕜 E) :
  continuous ξ.equiv_fun :=
begin
  haveI : finite_dimensional 𝕜 E := of_fintype_basis ξ,
  exact ξ.equiv_fun.to_linear_map.continuous_of_finite_dimensional
end

namespace linear_map

variables [t2_space E] [finite_dimensional 𝕜 E]

/-- The continuous linear map induced by a linear map on a finite dimensional space -/
def to_continuous_linear_map : (E →ₗ[𝕜] F') ≃ₗ[𝕜] E →L[𝕜] F' :=
{ to_fun := λ f, ⟨f, f.continuous_of_finite_dimensional⟩,
  inv_fun := coe,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl,
  left_inv := λ f, rfl,
  right_inv := λ f, continuous_linear_map.coe_injective rfl }

@[simp] lemma coe_to_continuous_linear_map' (f : E →ₗ[𝕜] F') :
  ⇑f.to_continuous_linear_map = f := rfl

@[simp] lemma coe_to_continuous_linear_map (f : E →ₗ[𝕜] F') :
  (f.to_continuous_linear_map : E →ₗ[𝕜] F') = f := rfl

@[simp] lemma coe_to_continuous_linear_map_symm :
  ⇑(to_continuous_linear_map : (E →ₗ[𝕜] F') ≃ₗ[𝕜] E →L[𝕜] F').symm = coe := rfl

@[simp] lemma det_to_continuous_linear_map (f : E →ₗ[𝕜] E) :
  f.to_continuous_linear_map.det = f.det :=
rfl

@[simp] lemma ker_to_continuous_linear_map (f : E →ₗ[𝕜] F') :
  ker f.to_continuous_linear_map = ker f :=
rfl

@[simp] lemma range_to_continuous_linear_map (f : E →ₗ[𝕜] F') :
  range f.to_continuous_linear_map = range f :=
rfl

/-- A surjective linear map `f` with finite dimensional codomain is an open map. -/
lemma is_open_map_of_finite_dimensional (f : F →ₗ[𝕜] E) (hf : function.surjective f) :
  is_open_map f :=
begin
  rcases f.exists_right_inverse_of_surjective (linear_map.range_eq_top.2 hf) with ⟨g, hg⟩,
  refine is_open_map.of_sections (λ x, ⟨λ y, g (y - f x) + x, _, _, λ y, _⟩),
  { exact ((g.continuous_of_finite_dimensional.comp $ continuous_id.sub continuous_const).add
      continuous_const).continuous_at },
  { rw [sub_self, map_zero, zero_add] },
  { simp only [map_sub, map_add, ← comp_apply f g, hg, id_apply, sub_add_cancel] }
end

instance can_lift_continuous_linear_map : can_lift (E →ₗ[𝕜] F) (E →L[𝕜] F) coe (λ _, true) :=
⟨λ f _, ⟨f.to_continuous_linear_map, rfl⟩⟩

end linear_map

namespace linear_equiv

variables [t2_space E] [t2_space F] [finite_dimensional 𝕜 E]

/-- The continuous linear equivalence induced by a linear equivalence on a finite dimensional
space. -/
def to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) : E ≃L[𝕜] F :=
{ continuous_to_fun := e.to_linear_map.continuous_of_finite_dimensional,
  continuous_inv_fun := begin
    haveI : finite_dimensional 𝕜 F := e.finite_dimensional,
    exact e.symm.to_linear_map.continuous_of_finite_dimensional
  end,
  ..e }

@[simp] lemma coe_to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv : E →ₗ[𝕜] F) = e := rfl

@[simp] lemma coe_to_continuous_linear_equiv' (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv : E → F) = e := rfl

@[simp] lemma coe_to_continuous_linear_equiv_symm (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv.symm : F →ₗ[𝕜] E) = e.symm := rfl

@[simp] lemma coe_to_continuous_linear_equiv_symm' (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv.symm : F → E) = e.symm := rfl

@[simp] lemma to_linear_equiv_to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) :
  e.to_continuous_linear_equiv.to_linear_equiv = e :=
by { ext x, refl }

@[simp] lemma to_linear_equiv_to_continuous_linear_equiv_symm (e : E ≃ₗ[𝕜] F) :
  e.to_continuous_linear_equiv.symm.to_linear_equiv = e.symm :=
by { ext x, refl }

instance can_lift_continuous_linear_equiv :
  can_lift (E ≃ₗ[𝕜] F) (E ≃L[𝕜] F) continuous_linear_equiv.to_linear_equiv (λ _, true) :=
⟨λ f _, ⟨_, f.to_linear_equiv_to_continuous_linear_equiv⟩⟩

end linear_equiv

namespace continuous_linear_map

variables [t2_space E] [finite_dimensional 𝕜 E]

/-- Builds a continuous linear equivalence from a continuous linear map on a finite-dimensional
vector space whose determinant is nonzero. -/
def to_continuous_linear_equiv_of_det_ne_zero
  (f : E →L[𝕜] E) (hf : f.det ≠ 0) : E ≃L[𝕜] E :=
((f : E →ₗ[𝕜] E).equiv_of_det_ne_zero hf).to_continuous_linear_equiv

@[simp] lemma coe_to_continuous_linear_equiv_of_det_ne_zero (f : E →L[𝕜] E) (hf : f.det ≠ 0) :
  (f.to_continuous_linear_equiv_of_det_ne_zero hf : E →L[𝕜] E) = f :=
by { ext x, refl }

@[simp] lemma to_continuous_linear_equiv_of_det_ne_zero_apply
  (f : E →L[𝕜] E) (hf : f.det ≠ 0) (x : E) :
  f.to_continuous_linear_equiv_of_det_ne_zero hf x = f x :=
rfl

lemma _root_.matrix.to_lin_fin_two_prod_to_continuous_linear_map (a b c d : 𝕜) :
  (matrix.to_lin (basis.fin_two_prod 𝕜) (basis.fin_two_prod 𝕜)
      !![a, b; c, d]).to_continuous_linear_map =
  (a • continuous_linear_map.fst 𝕜 𝕜 𝕜 + b • continuous_linear_map.snd 𝕜 𝕜 𝕜).prod
  (c • continuous_linear_map.fst 𝕜 𝕜 𝕜 + d • continuous_linear_map.snd 𝕜 𝕜 𝕜) :=
continuous_linear_map.ext $ matrix.to_lin_fin_two_prod_apply _ _ _ _

end continuous_linear_map

end normed_field


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

Extended non-negative reals
-/
import data.real.nnreal order.bounds
noncomputable theory
open classical set lattice

local attribute [instance] prop_decidable
variables {α : Type*} {β : Type*}

/-- The extended nonnegative real numbers. This is usually denoted [0, ∞],
  and is relevant as the codomain of a measure. -/
def ennreal := with_top nnreal

local notation `∞` := (⊤ : ennreal)

namespace ennreal
variables {a b c d : ennreal} {r p q : nnreal}

instance : canonically_ordered_comm_semiring ennreal := by unfold ennreal; apply_instance
instance : decidable_linear_order ennreal := by unfold ennreal; apply_instance
instance : complete_linear_order ennreal := by unfold ennreal; apply_instance
instance : inhabited ennreal := ⟨0⟩

instance : densely_ordered ennreal := with_top.densely_ordered

instance : has_coe nnreal ennreal := ⟨ option.some ⟩

lemma none_eq_top : (none : ennreal) = (⊤ : ennreal) := rfl
lemma some_eq_coe (a : nnreal) : (some a : ennreal) = (↑a : ennreal) := rfl

/-- `to_nnreal x` returns `x` if it is real, otherwise 0. -/
protected def to_nnreal : ennreal → nnreal
| (some r) := r
| none := 0

@[simp] lemma to_nnreal_coe : (r : ennreal).to_nnreal = r := rfl

@[simp] lemma coe_to_nnreal : ∀{a:ennreal}, a ≠ ∞ → ↑(a.to_nnreal) = a
| (some r) h := rfl
| none     h := (h rfl).elim

@[simp] lemma top_to_nnreal : ∞.to_nnreal = 0 := rfl

lemma forall_ennreal {p : ennreal → Prop} : (∀a, p a) ↔ (∀r:nnreal, p r) ∧ p ∞ :=
⟨assume h, ⟨assume r, h _, h _⟩,
  assume ⟨h₁, h₂⟩ a, match a with some r := h₁ _ | none := h₂ end⟩

@[simp] lemma coe_zero : ↑(0 : nnreal) = (0 : ennreal) := rfl
@[simp] lemma coe_one : ↑(1 : nnreal) = (1 : ennreal) := rfl

@[simp] lemma coe_ne_top : (r : ennreal) ≠ ∞ := with_top.coe_ne_top
@[simp] lemma top_ne_coe : ∞ ≠ (r : ennreal) := with_top.top_ne_coe

@[simp] lemma zero_ne_top : 0 ≠ ∞ := coe_ne_top
@[simp] lemma top_ne_zero : ∞ ≠ 0 := top_ne_coe

@[simp] lemma one_ne_top : 1 ≠ ∞ := coe_ne_top
@[simp] lemma top_ne_one : ∞ ≠ 1 := top_ne_coe

@[simp] lemma coe_eq_coe : (↑r : ennreal) = ↑q ↔ r = q := with_top.coe_eq_coe
@[simp] lemma coe_le_coe : (↑r : ennreal) ≤ ↑q ↔ r ≤ q := with_top.coe_le_coe
@[simp] lemma coe_lt_coe : (↑r : ennreal) < ↑q ↔ r < q := with_top.coe_lt_coe

@[simp] lemma coe_eq_zero : (↑r : ennreal) = 0 ↔ r = 0 := coe_eq_coe
@[simp] lemma zero_eq_coe : 0 = (↑r : ennreal) ↔ 0 = r := coe_eq_coe
@[simp] lemma coe_eq_one : (↑r : ennreal) = 1 ↔ r = 1 := coe_eq_coe
@[simp] lemma one_eq_coe : 1 = (↑r : ennreal) ↔ 1 = r := coe_eq_coe

@[simp] lemma coe_add : ↑(r + p) = (r + p : ennreal) := with_top.coe_add
@[simp] lemma coe_mul : ↑(r * p) = (r * p : ennreal) := with_top.coe_mul

@[simp] lemma add_top : a + ∞ = ∞ := with_top.add_top
@[simp] lemma top_add : ∞ + a = ∞ := with_top.top_add

lemma add_eq_top : a + b = ∞ ↔ a = ∞ ∨ b = ∞ := with_top.add_eq_top _ _

lemma mul_top : a * ∞ = (if a = 0 then 0 else ∞) :=
begin split_ifs, { simp [h] }, { exact with_top.mul_top h } end

lemma top_mul : ∞ * a = (if a = 0 then 0 else ∞) :=
begin split_ifs, { simp [h] }, { exact with_top.top_mul h } end

@[simp] lemma top_mul_top : ∞ * ∞ = ∞ := with_top.top_mul_top

@[simp] lemma coe_finset_sum {s : finset α} {f : α → nnreal} : ↑(s.sum f) = (s.sum (λa, f a) : ennreal) :=
(finset.sum_hom coe coe_zero @coe_add).symm

@[simp] lemma coe_finset_prod {s : finset α} {f : α → nnreal} : ↑(s.prod f) = (s.prod (λa, f a) : ennreal) :=
(finset.prod_hom coe coe_one @coe_mul).symm

@[simp] lemma bot_eq_zero : (⊥ : ennreal) = 0 := rfl
section order

@[simp] lemma coe_lt_top : coe r < ∞ := with_top.coe_lt_top r
@[simp] lemma not_top_le_coe : ¬ (⊤:ennreal) ≤ ↑r := with_top.not_top_le_coe r
@[simp] lemma zero_lt_coe_iff : 0 < (↑p : ennreal) ↔ 0 < p := coe_lt_coe
@[simp] lemma one_le_coe_iff : (1:ennreal) ≤ ↑r ↔ 1 ≤ r := coe_le_coe
@[simp] lemma coe_le_one_iff : ↑r ≤ (1:ennreal) ↔ r ≤ 1 := coe_le_coe
@[simp] lemma coe_lt_one_iff : (↑p : ennreal) < 1 ↔ p < 1 := coe_lt_coe
@[simp] lemma one_lt_zero_iff : 1 < (↑p : ennreal) ↔ 1 < p := coe_lt_coe

lemma le_coe_iff : a ≤ ↑r ↔ (∃p:nnreal, a = p ∧ p ≤ r) := with_top.le_coe_iff r a
lemma coe_le_iff : ↑r ≤ a ↔ (∀p:nnreal, a = p → r ≤ p) := with_top.coe_le_iff r a

lemma lt_iff_exists_coe : a < b ↔ (∃p:nnreal, a = p ∧ ↑p < b) := with_top.lt_iff_exists_coe a b

-- TODO: move to canonically ordered semiring ...
protected lemma zero_lt_one : 0 < (1 : ennreal) := zero_lt_coe_iff.mpr zero_lt_one

@[simp] lemma not_lt_zero : ¬ a < 0 := by simp

lemma add_lt_add_iff_left : a < ⊤ → (a + c < a + b ↔ c < b) :=
with_top.add_lt_add_iff_left

lemma lt_add_right (ha : a < ⊤) (hb : 0 < b) : a < a + b :=
by rwa [← add_lt_add_iff_left ha, add_zero] at hb

lemma le_of_forall_epsilon_le : ∀{a b : ennreal}, (∀ε:nnreal, ε > 0 → b < ∞ → a ≤ b + ε) → a ≤ b
| a    none     h := le_top
| none (some a) h :=
  have (⊤:ennreal) ≤ ↑a + ↑(1:nnreal), from h 1 zero_lt_one coe_lt_top,
  by rw [← coe_add] at this; exact (not_top_le_coe this).elim
| (some a) (some b) h :=
    by simp only [none_eq_top, some_eq_coe, coe_add.symm, coe_le_coe, coe_lt_top, true_implies_iff] at *;
      exact nnreal.le_of_forall_epsilon_le h

protected lemma lt_iff_exists_rat_btwn :
  a < b ↔ (∃q:ℚ, 0 ≤ q ∧ a < nnreal.of_real q ∧ (nnreal.of_real q:ennreal) < b) :=
⟨λ h,
  begin
    rcases lt_iff_exists_coe.1 h with ⟨p, rfl, _⟩,
    rcases dense h with ⟨c, pc, cb⟩,
    rcases lt_iff_exists_coe.1 cb with ⟨r, rfl, _⟩,
    rcases (nnreal.lt_iff_exists_rat_btwn _ _).1 (coe_lt_coe.1 pc) with ⟨q, hq0, pq, qr⟩,
    exact ⟨q, hq0, coe_lt_coe.2 pq, lt_trans (coe_lt_coe.2 qr) cb⟩
  end,
λ ⟨q, q0, qa, qb⟩, lt_trans qa qb⟩

end order

section complete_lattice

lemma coe_Sup {s : set nnreal} : bdd_above s → (↑(Sup s) : ennreal) = (⨆a∈s, ↑a) := with_top.coe_Sup
lemma coe_Inf {s : set nnreal} : s ≠ ∅ → (↑(Inf s) : ennreal) = (⨅a∈s, ↑a) := with_top.coe_Inf

@[simp] lemma top_mem_upper_bounds {s : set ennreal} : ∞ ∈ upper_bounds s :=
assume x hx, le_top

lemma coe_mem_upper_bounds {s : set nnreal} :
  ↑r ∈ upper_bounds ((coe : nnreal → ennreal) '' s) ↔ r ∈ upper_bounds s :=
by simp [upper_bounds, ball_image_iff, -mem_image, *] {contextual := tt}

end complete_lattice

section mul

lemma mul_eq_mul_left : a ≠ 0 → a ≠ ⊤ → (a * b = a * c ↔ b = c) :=
begin
  cases a; cases b; cases c;
    simp [none_eq_top, some_eq_coe, mul_top, top_mul, -coe_mul, coe_mul.symm,
      nnreal.mul_eq_mul_left] {contextual := tt},
end

lemma mul_le_mul_left : a ≠ 0 → a ≠ ⊤ → (a * b ≤ a * c ↔ b ≤ c) :=
begin
  cases a; cases b; cases c;
    simp [none_eq_top, some_eq_coe, mul_top, top_mul, -coe_mul, coe_mul.symm] {contextual := tt},
  assume h, exact mul_le_mul_left (zero_lt_iff_ne_zero.2 h)
end

end mul

section sub
instance : has_sub ennreal := ⟨λa b, Inf {d | a ≤ d + b}⟩

lemma coe_sub : ↑(p - r) = (↑p:ennreal) - r :=
le_antisymm
  (le_Inf $ assume b (hb : ↑p ≤ b + r), coe_le_iff.2 $
    by rintros d rfl; rwa [← coe_add, coe_le_coe, ← nnreal.sub_le_iff_le_add] at hb)
  (Inf_le $ show (↑p : ennreal) ≤ ↑(p - r) + ↑r,
    by rw [← coe_add, coe_le_coe, ← nnreal.sub_le_iff_le_add])

@[simp] lemma top_sub_coe : ∞ - ↑r = ∞ :=
top_unique $ le_Inf $ by simp [add_eq_top]

@[simp] lemma sub_eq_zero_of_le (h : a ≤ b) : a - b = 0 :=
le_antisymm (Inf_le $ le_add_left h) (zero_le _)

@[simp] lemma zero_sub : 0 - a = 0 :=
le_antisymm (Inf_le $ zero_le _) (zero_le _)

@[simp] lemma sub_infty : a - ∞ = 0 :=
le_antisymm (Inf_le $ by simp) (zero_le _)

lemma sub_le_sub (h₁ : a ≤ b) (h₂ : d ≤ c) : a - c ≤ b - d :=
Inf_le_Inf $ assume e (h : b ≤ e + d),
  calc a ≤ b : h₁
    ... ≤ e + d : h
    ... ≤ e + c : add_le_add' (le_refl _) h₂

@[simp] lemma add_sub_self : ∀{a b : ennreal}, b < ∞ → (a + b) - b = a
| a        none     := by simp [none_eq_top]
| none     (some b) := by simp [none_eq_top, some_eq_coe]
| (some a) (some b) :=
  by simp [some_eq_coe]; rw [← coe_add, ← coe_sub, coe_eq_coe, nnreal.add_sub_cancel]

@[simp] lemma add_sub_self' (h : a < ∞) : (a + b) - a = b :=
by rw [add_comm, add_sub_self h]

lemma add_left_inj (h : a < ∞) : a + b = a + c ↔ b = c :=
⟨λ e, by simpa [h] using congr_arg (λ x, x - a) e, congr_arg _⟩

lemma add_right_inj (h : a < ∞) : b + a = c + a ↔ b = c :=
by rw [add_comm, add_comm c, add_left_inj h]

@[simp] lemma sub_add_cancel_of_le : ∀{a b : ennreal}, b ≤ a → (a - b) + b = a :=
begin
  simp [forall_ennreal, le_coe_iff, -add_comm] {contextual := tt},
  rintros r p x rfl h,
  rw [← coe_sub, ← coe_add, nnreal.sub_add_cancel_of_le h]
end

@[simp] lemma add_sub_cancel_of_le (h : b ≤ a) : b + (a - b) = a :=
by rwa [add_comm, sub_add_cancel_of_le]

lemma sub_add_self_eq_max : (a - b) + b = max a b :=
match le_total a b with
| or.inl h := by simp [h, max_eq_right]
| or.inr h := by simp [h, max_eq_left]
end

@[simp] protected lemma sub_le_iff_le_add : a - b ≤ c ↔ a ≤ c + b :=
iff.intro
  (assume h : a - b ≤ c,
    calc a ≤ (a - b) + b : by rw [sub_add_self_eq_max]; exact le_max_left _ _
      ... ≤ c + b : add_le_add' h (le_refl _))
  (assume h : a ≤ c + b,
    calc a - b ≤ (c + b) - b : sub_le_sub h (le_refl _)
      ... ≤ c : Inf_le (le_refl (c + b)))

lemma sub_le_self (a b : ennreal) : a - b ≤ a :=
ennreal.sub_le_iff_le_add.2 $ le_add_of_nonneg_right' $ zero_le _

@[simp] lemma sub_zero : a - 0 = a :=
eq.trans (add_zero (a - 0)).symm $ by simp

lemma sub_sub_cancel (h : a < ∞) (h2 : b ≤ a) : a - (a - b) = b :=
by rw [← add_right_inj (lt_of_le_of_lt (sub_le_self _ _) h),
  sub_add_cancel_of_le (sub_le_self _ _), add_sub_cancel_of_le h2]

end sub

section inv
instance : has_inv ennreal := ⟨λa, Inf {b | 1 ≤ a * b}⟩
instance : has_div ennreal := ⟨λa b, a * b⁻¹⟩

lemma div_def : a / b = a * b⁻¹ := rfl

@[simp] lemma inv_zero : (0 : ennreal)⁻¹ = ∞ :=
show Inf {b : ennreal | 1 ≤ 0 * b} = ∞, by simp; refl

@[simp] lemma inv_top : (∞ : ennreal)⁻¹ = 0 :=
bot_unique $ le_of_forall_le_of_dense $ λ a (h : a > 0), Inf_le $ by simp [*, ne_of_gt h, top_mul]

@[simp] lemma inv_coe (hr : r ≠ 0) : (r : ennreal)⁻¹ = ↑(r⁻¹ : nnreal) :=
le_antisymm
  (Inf_le $ by simp; rw [← coe_mul, nnreal.mul_inv_cancel hr]; exact le_refl 1)
  (le_Inf $ assume b (hb : 1 ≤ ↑r * b), coe_le_iff.2 $
    by rintros b rfl; rwa [← coe_mul, ← coe_one, coe_le_coe, ← nnreal.inv_le hr] at hb)

@[simp] lemma inv_eq_top : (a)⁻¹ = ∞ ↔ a = 0 :=
by by_cases a = 0; cases a; simp [*, none_eq_top, some_eq_coe] at *

lemma inv_ne_top : (a)⁻¹ ≠ ∞ ↔ a ≠ 0 := by simp

@[simp] lemma inv_eq_zero : (a)⁻¹ = 0 ↔ a = ∞ :=
by by_cases a = 0; cases a; simp [*, none_eq_top, some_eq_coe] at *

lemma inv_ne_zero : (a)⁻¹ ≠ 0 ↔ a ≠ ∞ := by simp

@[simp] lemma inv_inv : ∀{a:ennreal}, (a⁻¹)⁻¹ = a :=
forall_ennreal.mpr $ and.intro (assume r, by by_cases r = 0; simp [*, inv_pos]) (by simp)

lemma le_div_iff_mul_le : ∀{b}, b ≠ 0 → b ≠ ⊤ → (a ≤ c / b ↔ a * b ≤ c)
| none     h0 ht := (ht rfl).elim
| (some r) h0 ht :=
  begin
    have hr : r ≠ 0, from mt coe_eq_coe.2 h0,
    rw [← ennreal.mul_le_mul_left h0 ht],
    suffices : ↑r * a ≤ (↑r  * ↑r⁻¹) * c ↔ a * ↑r ≤ c,
    { simpa [some_eq_coe, div_def, hr, mul_left_comm, mul_comm, mul_assoc] },
    rw [← coe_mul, nnreal.mul_inv_cancel hr, coe_one, one_mul, mul_comm]
  end

lemma div_le_iff_le_mul (hb0 : b ≠ 0) (hbt : b ≠ ⊤) : (a / b ≤ c ↔ a ≤ c * b) :=
suffices a * b⁻¹ ≤ c ↔ a ≤ c / b⁻¹, by simpa [div_def],
(le_div_iff_mul_le (inv_ne_zero.2 hbt) (inv_ne_top.2 hb0)).symm

lemma inv_le_iff_le_mul : (b = ⊤ → a ≠ 0) → (a = ⊤ → b ≠ 0) → (a⁻¹ ≤ b ↔ 1 ≤ a * b) :=
begin
  cases a; cases b; simp [none_eq_top, some_eq_coe, mul_top, top_mul] {contextual := tt},
  by_cases a = 0; simp [*, -coe_mul, coe_mul.symm, nnreal.inv_le]
end

@[simp] lemma le_inv_iff_mul_le : a ≤ b⁻¹ ↔ a * b ≤ 1 :=
begin
  cases b, { by_cases a = 0; simp [*, none_eq_top, mul_top] },
  by_cases b = 0; simp [*, some_eq_coe, le_div_iff_mul_le],
  suffices : a ≤ 1 / b ↔ a * b ≤ 1, { simpa [div_def, h] },
  exact le_div_iff_mul_le (mt coe_eq_coe.1 h) coe_ne_top
end

end inv

section infi
variables {ι : Sort*} {f g : ι → ennreal}

lemma infi_add : infi f + a = ⨅i, f i + a :=
le_antisymm
  (le_infi $ assume i, add_le_add' (infi_le _ _) $ le_refl _)
  (ennreal.sub_le_iff_le_add.1 $ le_infi $ assume i, ennreal.sub_le_iff_le_add.2 $ infi_le _ _)

lemma supr_sub : (⨆i, f i) - a = (⨆i, f i - a) :=
le_antisymm
  (ennreal.sub_le_iff_le_add.2 $ supr_le $ assume i, ennreal.sub_le_iff_le_add.1 $ le_supr _ i)
  (supr_le $ assume i, ennreal.sub_le_sub (le_supr _ _) (le_refl a))

lemma sub_infi : a - (⨅i, f i) = (⨆i, a - f i) :=
begin
  refine (eq_of_forall_ge_iff $ λ c, _),
  rw [ennreal.sub_le_iff_le_add, add_comm, infi_add],
  simp [ennreal.sub_le_iff_le_add]
end

lemma Inf_add {s : set ennreal} : Inf s + a = ⨅b∈s, b + a :=
by simp [Inf_eq_infi, infi_add]

lemma add_infi {a : ennreal} : a + infi f = ⨅b, a + f b :=
by rw [add_comm, infi_add]; simp

lemma infi_add_infi (h : ∀i j, ∃k, f k + g k ≤ f i + g j) : infi f + infi g = (⨅a, f a + g a) :=
suffices (⨅a, f a + g a) ≤ infi f + infi g,
  from le_antisymm (le_infi $ assume a, add_le_add' (infi_le _ _) (infi_le _ _)) this,
calc (⨅a, f a + g a) ≤ (⨅ a a', f a + g a') :
    le_infi $ assume a, le_infi $ assume a',
      let ⟨k, h⟩ := h a a' in infi_le_of_le k h
  ... ≤ infi f + infi g :
    by simp [add_infi, infi_add, -add_comm, -le_infi_iff]; exact le_refl _

lemma infi_sum {f : ι → α → ennreal} {s : finset α} [nonempty ι]
  (h : ∀(t : finset α) (i j : ι), ∃k, ∀a∈t, f k a ≤ f i a ∧ f k a ≤ f j a) :
  (⨅i, s.sum (f i)) = s.sum (λa, ⨅i, f i a) :=
finset.induction_on s (by simp) $ assume a s ha ih,
  have ∀ (i j : ι), ∃ (k : ι), f k a + s.sum (f k) ≤ f i a + s.sum (f j),
    from assume i j,
    let ⟨k, hk⟩ := h (insert a s) i j in
    ⟨k, add_le_add' (hk a (finset.mem_insert_self _ _)).left $ finset.sum_le_sum' $
      assume a ha, (hk _ $ finset.mem_insert_of_mem ha).right⟩,
  by simp [ha, ih.symm, infi_add_infi this]

end infi

end ennreal


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

! This file was ported from Lean 3 source module logic.embedding.set
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Embedding.Basic
import Mathbin.Data.Set.Image

/-!
# Interactions between embeddings and sets.

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

-/

universe u v w x

section Equiv

variable {α : Sort u} {β : Sort v} (f : α ≃ β)

/- warning: equiv.as_embedding_range -> Equiv.asEmbedding_range is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Type.{u2}} {p : β -> Prop} (e : Equiv.{u1, succ u2} α (Subtype.{succ u2} β p)), Eq.{succ u2} (Set.{u2} β) (Set.range.{u2, u1} β α (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) (Equiv.asEmbedding.{u1, succ u2} α β p e))) (setOf.{u2} β p)
but is expected to have type
  forall {α : Sort.{u2}} {β : Type.{u1}} {p : β -> Prop} (e : Equiv.{u2, succ u1} α (Subtype.{succ u1} β p)), Eq.{succ u1} (Set.{u1} β) (Set.range.{u1, u2} β α (FunLike.coe.{max (max 1 u2) (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (max 1 u2) (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) (Equiv.asEmbedding.{succ u1, u2} β α p e))) (setOf.{u1} β p)
Case conversion may be inaccurate. Consider using '#align equiv.as_embedding_range Equiv.asEmbedding_rangeₓ'. -/
@[simp]
theorem Equiv.asEmbedding_range {α β : Sort _} {p : β → Prop} (e : α ≃ Subtype p) :
    Set.range e.asEmbedding = setOf p :=
  Set.ext fun x => ⟨fun ⟨y, h⟩ => h ▸ Subtype.coe_prop (e y), fun hs => ⟨e.symm ⟨x, hs⟩, by simp⟩⟩
#align equiv.as_embedding_range Equiv.asEmbedding_range

end Equiv

namespace Function

namespace Embedding

#print Function.Embedding.coeWithTop /-
/-- Embedding into `with_top α`. -/
@[simps]
def coeWithTop {α} : α ↪ WithTop α :=
  { Embedding.some with toFun := coe }
#align function.embedding.coe_with_top Function.Embedding.coeWithTop
-/

#print Function.Embedding.optionElim /-
/-- Given an embedding `f : α ↪ β` and a point outside of `set.range f`, construct an embedding
`option α ↪ β`. -/
@[simps]
def optionElim {α β} (f : α ↪ β) (x : β) (h : x ∉ Set.range f) : Option α ↪ β :=
  ⟨Option.elim' x f, Option.injective_iff.2 ⟨f.2, h⟩⟩
#align function.embedding.option_elim Function.Embedding.optionElim
-/

/- warning: function.embedding.option_embedding_equiv -> Function.Embedding.optionEmbeddingEquiv is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) (β : Type.{u2}), Equiv.{max 1 (succ u1) (succ u2), max (succ (max u1 u2)) (succ u2)} (Function.Embedding.{succ u1, succ u2} (Option.{u1} α) β) (Sigma.{max u1 u2, u2} (Function.Embedding.{succ u1, succ u2} α β) (fun (f : Function.Embedding.{succ u1, succ u2} α β) => coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) (HasCompl.compl.{u2} (Set.{u2} β) (BooleanAlgebra.toHasCompl.{u2} (Set.{u2} β) (Set.booleanAlgebra.{u2} β)) (Set.range.{u2, succ u1} β α (coeFn.{max 1 (succ u1) (succ u2), max (succ u1) (succ u2)} (Function.Embedding.{succ u1, succ u2} α β) (fun (_x : Function.Embedding.{succ u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{succ u1, succ u2} α β) f)))))
but is expected to have type
  forall (α : Type.{u1}) (β : Type.{u2}), Equiv.{max (succ u2) (succ u1), max (succ u2) (succ (max u1 u2))} (Function.Embedding.{succ u1, succ u2} (Option.{u1} α) β) (Sigma.{max u1 u2, u2} (Function.Embedding.{succ u1, succ u2} α β) (fun (f : Function.Embedding.{succ u1, succ u2} α β) => Set.Elem.{u2} β (HasCompl.compl.{u2} (Set.{u2} β) (BooleanAlgebra.toHasCompl.{u2} (Set.{u2} β) (Set.instBooleanAlgebraSet.{u2} β)) (Set.range.{u2, succ u1} β α (FunLike.coe.{max (succ u2) (succ u1), succ u1, succ u2} (Function.Embedding.{succ u1, succ u2} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (succ u2) (succ u1), succ u1, succ u2} (Function.Embedding.{succ u1, succ u2} α β) α β (Function.instEmbeddingLikeEmbedding.{succ u1, succ u2} α β)) f)))))
Case conversion may be inaccurate. Consider using '#align function.embedding.option_embedding_equiv Function.Embedding.optionEmbeddingEquivₓ'. -/
/-- Equivalence between embeddings of `option α` and a sigma type over the embeddings of `α`. -/
@[simps]
def optionEmbeddingEquiv (α β) : (Option α ↪ β) ≃ Σf : α ↪ β, ↥(Set.range fᶜ)
    where
  toFun f := ⟨some.trans f, f none, fun ⟨x, hx⟩ => Option.some_ne_none x <| f.Injective hx⟩
  invFun f := f.1.optionElim f.2 f.2.2
  left_inv f := ext <| by rintro (_ | _) <;> simp [Option.coe_def]
  right_inv := fun ⟨f, y, hy⟩ => by ext <;> simp [Option.coe_def]
#align function.embedding.option_embedding_equiv Function.Embedding.optionEmbeddingEquiv

#print Function.Embedding.codRestrict /-
/-- Restrict the codomain of an embedding. -/
def codRestrict {α β} (p : Set β) (f : α ↪ β) (H : ∀ a, f a ∈ p) : α ↪ p :=
  ⟨fun a => ⟨f a, H a⟩, fun a b h => f.Injective (@congr_arg _ _ _ _ Subtype.val h)⟩
#align function.embedding.cod_restrict Function.Embedding.codRestrict
-/

/- warning: function.embedding.cod_restrict_apply -> Function.Embedding.codRestrict_apply is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Type.{u2}} (p : Set.{u2} β) (f : Function.Embedding.{u1, succ u2} α β) (H : forall (a : α), Membership.Mem.{u2, u2} β (Set.{u2} β) (Set.hasMem.{u2} β) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) f a) p) (a : α), Eq.{succ u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (fun (_x : Function.Embedding.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) => α -> (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (Function.Embedding.hasCoeToFun.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (Function.Embedding.codRestrict.{u1, u2} α β p f H) a) (Subtype.mk.{succ u2} β (fun (x : β) => Membership.Mem.{u2, u2} β (Set.{u2} β) (Set.hasMem.{u2} β) x p) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) f a) (H a))
but is expected to have type
  forall {α : Sort.{u2}} {β : Type.{u1}} (p : Set.{u1} β) (f : Function.Embedding.{u2, succ u1} α β) (H : forall (a : α), Membership.mem.{u1, u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) a) (Set.{u1} β) (Set.instMembershipSet.{u1} β) (FunLike.coe.{max (succ u1) u2, u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (succ u1) u2, u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) f a) p) (a : α), Eq.{succ u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => Set.Elem.{u1} β p) a) (FunLike.coe.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α (Set.Elem.{u1} β p)) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => Set.Elem.{u1} β p) _x) (EmbeddingLike.toFunLike.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α (Set.Elem.{u1} β p)) α (Set.Elem.{u1} β p) (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α (Set.Elem.{u1} β p))) (Function.Embedding.codRestrict.{u2, u1} α β p f H) a) (Subtype.mk.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Set.{u1} β) (Set.instMembershipSet.{u1} β) x p) (FunLike.coe.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) f a) (H a))
Case conversion may be inaccurate. Consider using '#align function.embedding.cod_restrict_apply Function.Embedding.codRestrict_applyₓ'. -/
@[simp]
theorem codRestrict_apply {α β} (p) (f : α ↪ β) (H a) : codRestrict p f H a = ⟨f a, H a⟩ :=
  rfl
#align function.embedding.cod_restrict_apply Function.Embedding.codRestrict_apply

open Set

#print Function.Embedding.image /-
/-- `set.image` as an embedding `set α ↪ set β`. -/
@[simps apply]
protected def image {α β} (f : α ↪ β) : Set α ↪ Set β :=
  ⟨image f, f.2.image_injective⟩
#align function.embedding.image Function.Embedding.image
-/

end Embedding

end Function

namespace Set

#print Set.embeddingOfSubset /-
/-- The injection map is an embedding between subsets. -/
@[simps apply]
def embeddingOfSubset {α} (s t : Set α) (h : s ⊆ t) : s ↪ t :=
  ⟨fun x => ⟨x.1, h x.2⟩, fun ⟨x, hx⟩ ⟨y, hy⟩ h =>
    by
    congr
    injection h⟩
#align set.embedding_of_subset Set.embeddingOfSubset
-/

end Set

section Subtype

variable {α : Type _}

#print subtypeOrEquiv /-
/-- A subtype `{x // p x ∨ q x}` over a disjunction of `p q : α → Prop` is equivalent to a sum of
subtypes `{x // p x} ⊕ {x // q x}` such that `¬ p x` is sent to the right, when
`disjoint p q`.

See also `equiv.sum_compl`, for when `is_compl p q`.  -/
@[simps apply]
def subtypeOrEquiv (p q : α → Prop) [DecidablePred p] (h : Disjoint p q) :
    { x // p x ∨ q x } ≃ Sum { x // p x } { x // q x }
    where
  toFun := subtypeOrLeftEmbedding p q
  invFun :=
    Sum.elim (Subtype.impEmbedding _ _ fun x hx => (Or.inl hx : p x ∨ q x))
      (Subtype.impEmbedding _ _ fun x hx => (Or.inr hx : p x ∨ q x))
  left_inv x := by
    by_cases hx : p x
    · rw [subtypeOrLeftEmbedding_apply_left _ hx]
      simp [Subtype.ext_iff]
    · rw [subtypeOrLeftEmbedding_apply_right _ hx]
      simp [Subtype.ext_iff]
  right_inv x := by
    cases x
    · simp only [Sum.elim_inl]
      rw [subtypeOrLeftEmbedding_apply_left]
      · simp
      · simpa using x.prop
    · simp only [Sum.elim_inr]
      rw [subtypeOrLeftEmbedding_apply_right]
      · simp
      · suffices ¬p x by simpa
        intro hp
        simpa using h.le_bot x ⟨hp, x.prop⟩
#align subtype_or_equiv subtypeOrEquiv
-/

#print subtypeOrEquiv_symm_inl /-
@[simp]
theorem subtypeOrEquiv_symm_inl (p q : α → Prop) [DecidablePred p] (h : Disjoint p q)
    (x : { x // p x }) : (subtypeOrEquiv p q h).symm (Sum.inl x) = ⟨x, Or.inl x.Prop⟩ :=
  rfl
#align subtype_or_equiv_symm_inl subtypeOrEquiv_symm_inl
-/

#print subtypeOrEquiv_symm_inr /-
@[simp]
theorem subtypeOrEquiv_symm_inr (p q : α → Prop) [DecidablePred p] (h : Disjoint p q)
    (x : { x // q x }) : (subtypeOrEquiv p q h).symm (Sum.inr x) = ⟨x, Or.inr x.Prop⟩ :=
  rfl
#align subtype_or_equiv_symm_inr subtypeOrEquiv_symm_inr
-/

end Subtype


namespace deduction_basic
  class has_Hyp (Form : Type) :=
    (Hyp : Type)
    [emptyHyp : has_emptyc Hyp]
    [insertHyp : has_insert Form Hyp]
  instance singleHyp {Form : Type} [hasHyp : has_Hyp Form] : has_singleton Form hasHyp.Hyp :=
    {singleton := λ φ, hasHyp.insertHyp.insert φ hasHyp.emptyHyp.emptyc}

  instance lawfulSingleHyp {Form : Type} [hasHyp : has_Hyp Form] :
  @is_lawful_singleton Form (has_Hyp.Hyp Form) hasHyp.emptyHyp hasHyp.insertHyp deduction_basic.singleHyp :=
  { insert_emptyc_eq := begin assume φ, refl end }

  class has_derives (Form : Type) extends has_Hyp Form :=
    (derives : Hyp → Form → Prop)
    (derive_Trans : ∀ {Φ : Hyp} (ψ) {θ : Form}, derives Φ ψ → derives {ψ} θ → derives Φ θ)

  def der {Form : Type} [Der : has_derives Form] : Form → Form → Prop :=
    λ φ ψ, has_derives.derives {φ} ψ

  infix `⊢`:60 := der

  lemma derive_trans {Form : Type} [Der : has_derives Form] :
    ∀ {φ : Form} (ψ) {θ}, (φ ⊢ ψ) → (ψ ⊢ θ) → (φ ⊢ θ) :=
  begin
    assume φ,
    apply Der.derive_Trans,
  end

  class has_struct_derives (Form : Type) extends has_derives Form :=
    [memHyp : has_mem Form Hyp]
    (inInsert : ∀ {φ : Form} {Φ : Hyp}, φ ∈ insert φ Φ)
    (hyp : ∀ {Φ} {φ}, (φ ∈ Φ) → derives Φ φ)
    (weak1 : ∀ {Φ} {φ} (ψ), derives Φ φ → derives (insert ψ Φ) φ)

  lemma derive_refl {Form : Type} [Der : has_struct_derives Form] :
    ∀ φ : Form, φ ⊢ φ :=
  begin
    assume φ,
    apply Der.hyp,
    apply Der.inInsert,
  end

end deduction_basic


import data.stream

import unitb.scheduling
import unitb.logic

import util.data.bijection
import util.data.finite
import util.data.countable

namespace det

open predicate

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

@[reducible]
def pred (α : Sort*) := pred' α

variables {lbl α : Type}

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

def program.take_step (s : program lbl α) : option lbl → α → α
  | none := id
  | (some e) := s^.step e

def program.action_of (s : program lbl α) (e : option lbl) (σ σ' : α) : Prop :=
σ' = s^.take_step e σ

def is_step (s : program lbl α) (σ σ' : α) : Prop :=
∃ ev, s.action_of ev σ σ'

def program.falsify (s : program lbl α) (ev : option lbl) (p q : pred α) : Prop :=
∀ σ, σ ⊨ q → (s^.take_step ev σ) ⊨ - q

def program.transient (s : program lbl α) (p q : pred α) : Prop :=
∃ ev, s.falsify ev p q

def program.falsify_action (s : program lbl α) (p q : pred α) (ev : option lbl)
  (h : s.falsify ev p q)
: •q ⟹ ( ⟦ s.action_of ev ⟧ ⟶ ⊙ - •q ) :=
begin [temporal]
  action {
    intros Hq H₁,
    unfold program.action_of at H₁,
    rw H₁,
    apply (h _ Hq) },
end

lemma program.falsify.negate
   {s : program lbl α} {act : option lbl} {p q : pred' α}
   (H : s.falsify act p q)
:  •q ⋀ ⟦ s^.action_of act ⟧ ⟹ ◇-•q :=
begin [temporal]
  intros H',
  strengthen_to ⊙-• _ ,
  exact program.falsify_action s p q act H Γ H'.left H'.right,
end

lemma program.transient_impl (s : program lbl α) (p : pred' α)
: s.transient p False :=
begin
  unfold program.transient False,
  existsi @none lbl,
  intros σ h,
  cases h
end

lemma program.transient_antimono (s : program lbl α) {p q p' q' : pred α}
  (hp : p' ⟹ p)
  (hq : q' ⟹ q)
  (T₀ : s.transient p q)
: s.transient p' q' :=
begin
  unfold program.transient,
  cases T₀ with ev T₁,
  existsi ev,
  intros σ,
  imp_transitivity [σ ⊨ q,program.take_step s ev σ ⊨ -q], simp,
  intros_mono, apply ew_str hq,
  apply T₁, apply ew_str hq,
end

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

open temporal

structure ex (p : program lbl α) (τ : stream α) : Prop :=
    (init : τ 0 = p^.first)
    (safety : τ ⊨ unitb.saf_ex p)
    (liveness : ∀ e, τ ⊨ ◻ ◇ ⟦ p.action_of e ⟧)

open unitb
open nat

section soundness

variables (s : program lbl α)
variables (Γ : cpred α)
variables {p q : pred' α}
variables h : Γ ⊢ ex s

lemma safety : Γ ⊢ ex s ⟶ unitb.saf_ex s :=
by { apply p_imp_ext,
     introv _, apply ex.safety, }
lemma liveness : Γ ⊢ ex s ⟶ ∀∀ e, ◻ ◇ ⟦ s.action_of e ⟧ :=
by { apply p_imp_ext,
     introv _, apply ex.liveness, }

variables {s}
include h

lemma init_sem
  (I₀ : init s p)
: Γ ⊢ •p :=
begin [temporal]
  explicit τ {
    rw h.init,
    apply I₀ }
end

lemma transient.semantics
  (T₀ : s.transient p q)
: Γ ⊢ ◻◇•p ⟶ ◻◇-•q :=
begin [temporal]
  intro,
  simp [program.transient] at T₀,
  cases T₀ with ev T₀,
  assume_negation with hq ,
  simp [p_not_p_not_iff_self] at hq,
  have occ := coincidence hq (liveness s Γ h ev),
  clear h,
  henceforth at occ ⊢,
  eventually occ,
  apply T₀.negate Γ occ
end

end soundness

open scheduling scheduling.unitb

def object (p : program lbl α) : target_mch (option lbl) :=
{ σ := α
, s₀ := p.first
, next := λ l s P, p.take_step l s
, req := ↑λ _ : α, @set.univ (option lbl)
, req_nemp := by { intros _, rw [set.ne_empty_iff_exists_mem], existsi none, trivial, } }

lemma program.witness [sched lbl] (s : program lbl α)
: ∃ (τ : stream (state (program lbl α))), ex s τ :=
begin
  apply exists_imp_exists _ (sched.sched_str (object s)),
  intros τ h,
  have H : ∀ e, •(↑e ∊ (object s).req) ⋀ ⟦target_mch.action (object s) e⟧
              ⟹ ⟦s.action_of e⟧,
  { simp [init_eq_action,action_and_action],
    intro e,
    apply action_entails_action,
    intros σ σ',
    unfold target_mch.action,
    rw [exists_and,exists_imp_iff_forall_imp],
    intro, apply and.left },
  apply ex.mk,
  { rw h.init, refl },
  replace h := h.valid,
  begin [temporal]
    simp [saf_ex],
    henceforth at h ⊢,
    cases h with l h,
    have := (H l Γ h),
    revert this,
    action {
      simp [unitb.step,has_safety.step,is_step],
      intro h, exact ⟨_,h⟩ },
  end,
  intro e, have H' := h.fair e,
  begin [temporal]
    note H'' : •(↑e ∊ (object s).req) = True,
    { simp [temporal.init], congr, },
    simp [H''] at H',
    revert H', monotonicity,
    intros H', apply H e Γ _,
    simp [H''], apply H',
  end
end

instance {α} [sched lbl] : system_sem (program lbl α) :=
  { (_ : system (program lbl α)) with
    ex := λ p, (↑(ex p) : cpred _)
  , safety := safety
  , inhabited := program.witness
  , init_sem := @init_sem _ _
  , transient_sem := @transient.semantics _ _  }

end det


-- http://leanprover.github.io/ijcar16/examples/

/-
This is a file from the Lean standard library.
We use it to demonstrate/test the congruence closure procedure
described in the paper:
  "Congruence Closure for Intensional Type Theory"
   Daniel Selsam and Leonardo de Moura

The lemmas proved using `by inst_simp` are using the congruence closure
procedure described in the paper above.

The lemmas proved using `by rec_inst_simp` are also using the congruence closure
procedure described in the paper above. They first apply induction, and then use
`inst_simp`.

The tactic inst_simp uses E-matching to heuristically instantiate
lemmas tagged as simplification rules (i.e., `[simp]` tag in Lean).

There are 15 instances `by inst_simp` and `by rec_inst_simp` in this file.
-/
import EggTactic

macro mods:declModifiers "lemma" n:declId sig:declSig val:declVal : command => `($mods:declModifiers theorem $n $sig $val)

theorem cons_eq {α : Type} (a : α) (t : List α) : List.cons a t = List.cons a t :=
  by rfl

lemma nil_eq {α : Type} : (List.nil : List α) = (List.nil : List α) :=
  by rfl

#print nil_eq

lemma head_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : List A} :
      (h₁::t₁) = (h₂::t₂) → h₁ = h₂ :=
--by inst_simp
  by
  intros
  rawEgg [cons_eq, nil_eq]

#print head_eq_of_cons_eq

lemma tail_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : List A} :
      (h₁::t₁) = (h₂::t₂) → t₁ = t₂ :=
by inst_simp

/- append -/

definition append : List T → List T → List T
| []       l := l
| (h :: s) t := h :: (append s t)

notation l₁ ++ l₂ := append l₁ l₂

theorem append_nil_left [simp] (t : List T) : [] ++ t = t :=
rfl

theorem append_cons [simp] (x : T) (s t : List T) : (x::s) ++ t = x::(s ++ t) :=
rfl

theorem append_nil_right [simp] : ∀ (t : List T), t ++ [] = t :=
by rec_inst_simp

theorem append.assoc [simp] : ∀ (s t u : List T), s ++ t ++ u = s ++ (t ++ u) :=
by rec_inst_simp

/- length -/
definition length : List T → nat
| []       := 0
| (a :: l) := length l + 1

theorem length_nil [simp] : length (@nil T) = 0 :=
rfl

theorem length_cons [simp] (x : T) (t : List T) : length (x::t) = length t + 1 :=
rfl

theorem length_append [simp] : ∀ (s t : List T), length (s ++ t) = length s + length t :=
by rec_inst_simp

theorem eq_nil_of_length_eq_zero : ∀ {l : List T}, length l = 0 → l = []
| []     H := rfl
| (a::s) H := by contradiction

theorem ne_nil_of_length_eq_succ : ∀ {l : List T} {n : nat}, length l = succ n → l ≠ []
| []     n h := by contradiction
| (a::l) n h := by contradiction

/- concat -/

definition concat : Π (x : T), List T → List T
| a []       := [a]
| a (b :: l) := b :: concat a l

theorem concat_nil [simp] (x : T) : concat x [] = [x] :=
rfl

theorem concat_cons [simp] (x y : T) (l : List T) : concat x (y::l)  = y::(concat x l) :=
rfl

theorem concat_eq_append [simp] (a : T) : ∀ (l : List T), concat a l = l ++ [a] :=
by rec_inst_simp

theorem concat_ne_nil [simp] (a : T) : ∀ (l : List T), concat a l ≠ [] :=
by intro l; induction l; repeat contradiction

theorem length_concat [simp] (a : T) : ∀ (l : List T), length (concat a l) = length l + 1 :=
by rec_inst_simp

theorem concat_append [simp] (a : T) : ∀ (l₁ l₂ : List T), concat a l₁ ++ l₂ = l₁ ++ a :: l₂ :=
by rec_inst_simp

theorem append_concat (a : T)  : ∀(l₁ l₂ : List T), l₁ ++ concat a l₂ = concat a (l₁ ++ l₂) :=
by rec_inst_simp

/- last -/

definition last : Π l : List T, l ≠ [] → T
| []          h := absurd rfl h
| [a]         h := a
| (a₁::a₂::l) h := last (a₂::l) !cons_ne_nil

lemma last_singleton [simp] (a : T) (h : [a] ≠ []) : last [a] h = a :=
rfl

lemma last_cons_cons [simp] (a₁ a₂ : T) (l : List T) (h : a₁::a₂::l ≠ []) : last (a₁::a₂::l) h = last (a₂::l) !cons_ne_nil :=
rfl

theorem last_congr {l₁ l₂ : List T} (h₁ : l₁ ≠ []) (h₂ : l₂ ≠ []) (h₃ : l₁ = l₂) : last l₁ h₁ = last l₂ h₂ :=
by subst l₁

theorem last_concat [simp] {x : T} : ∀ {l : List T} (h : concat x l ≠ []), last (concat x l) h = x :=
by rec_simp

-- add_rewrite append_nil append_cons

/- reverse -/

definition reverse : List T → List T
| []       := []
| (a :: l) := concat a (reverse l)

theorem reverse_nil [simp] : reverse (@nil T) = [] :=
rfl

theorem reverse_cons [simp] (x : T) (l : List T) : reverse (x::l) = concat x (reverse l) :=
rfl

theorem reverse_singleton [simp] (x : T) : reverse [x] = [x] :=
rfl

theorem reverse_append [simp] : ∀ (s t : List T), reverse (s ++ t) = (reverse t) ++ (reverse s) :=
by rec_inst_simp

theorem reverse_reverse [simp] : ∀ (l : List T), reverse (reverse l) = l :=
by rec_inst_simp

theorem concat_eq_reverse_cons (x : T) (l : List T) : concat x l = reverse (x :: reverse l) :=
by inst_simp

theorem length_reverse : ∀ (l : List T), length (reverse l) = length l :=
by rec_inst_simp

/- head and tail -/

definition head [h : inhabited T] : List T → T
| []       := arbitrary T
| (a :: l) := a

theorem head_cons [simp] [h : inhabited T] (a : T) (l : List T) : head (a::l) = a :=
rfl

theorem head_append [simp] [h : inhabited T] (t : List T) : ∀ {s : List T}, s ≠ [] → head (s ++ t) = head s :=
by rec_inst_simp

definition tail : List T → List T
| []       := []
| (a :: l) := l

theorem tail_nil [simp] : tail (@nil T) = [] :=
rfl

theorem tail_cons [simp] (a : T) (l : List T) : tail (a::l) = l :=
rfl

theorem cons_head_tail [h : inhabited T] {l : List T} : l ≠ [] → (head l)::(tail l) = l :=
by rec_inst_simp

/-
This is a file from the Lean standard library.
We use it to demonstrate/test the congruence closure procedure
described in the paper:
  "Congruence Closure for Intensional Type Theory"
   Daniel Selsam and Leonardo de Moura

The lemmas proved using `by inst_simp` are using the congruence closure
procedure described in the paper above.

The tactic inst_simp uses E-matching to heuristically instantiate
lemmas tagged as simplification rules (i.e., `[simp]` tag in Lean).

There are more than 100 instances of `by inst_simp` in this file.
-/
import algebra.binary algebra.priority

variable {A : Type}

/- semigroup -/

attribute inv [light 3]
attribute neg [light 3]

structure semigroup [class] (A : Type) extends has_mul A :=
(mul_assoc : ∀a b c, mul (mul a b) c = mul a (mul b c))

-- We add pattern hints to the following lemma because we want it to be used in both directions
-- at inst_simp strategy.
theorem mul.assoc [simp] [semigroup A] (a b c : A) : (: a * b * c :) = (: a * (b * c) :) :=
!semigroup.mul_assoc

structure comm_semigroup [class] (A : Type) extends semigroup A :=
(mul_comm : ∀a b, mul a b = mul b a)

theorem mul.comm [simp] [comm_semigroup A] (a b : A) : a * b = b * a :=
!comm_semigroup.mul_comm

theorem mul.left_comm [simp] [comm_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) :=
binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c

theorem mul.right_comm [comm_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b :=
by inst_simp

structure left_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_left_cancel : ∀a b c, mul a b = mul a c → b = c)

theorem mul.left_cancel [left_cancel_semigroup A] {a b c : A} : a * b = a * c → b = c :=
!left_cancel_semigroup.mul_left_cancel

abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel

structure right_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_right_cancel : ∀a b c, mul a b = mul c b → a = c)

theorem mul.right_cancel [right_cancel_semigroup A] {a b c : A} : a * b = c * b → a = c :=
!right_cancel_semigroup.mul_right_cancel

abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel

/- additive semigroup -/

structure add_semigroup [class] (A : Type) extends has_add A :=
(add_assoc : ∀a b c, add (add a b) c = add a (add b c))

theorem add.assoc [simp] [add_semigroup A] (a b c : A) : (: a + b + c :) = (: a + (b + c) :) :=
!add_semigroup.add_assoc

structure add_comm_semigroup [class] (A : Type) extends add_semigroup A :=
(add_comm : ∀a b, add a b = add b a)

theorem add.comm [simp] [add_comm_semigroup A] (a b : A) : a + b = b + a :=
!add_comm_semigroup.add_comm

theorem add.left_comm [simp] [add_comm_semigroup A] (a b c : A) : a + (b + c) = b + (a + c) :=
binary.left_comm (@add.comm A _) (@add.assoc A _) a b c

theorem add.right_comm [add_comm_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
by inst_simp

structure add_left_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_left_cancel : ∀a b c, add a b = add a c → b = c)

theorem add.left_cancel [add_left_cancel_semigroup A] {a b c : A} : a + b = a + c → b = c :=
!add_left_cancel_semigroup.add_left_cancel

abbreviation eq_of_add_eq_add_left := @add.left_cancel

structure add_right_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_right_cancel : ∀a b c, add a b = add c b → a = c)

theorem add.right_cancel [add_right_cancel_semigroup A] {a b c : A} : a + b = c + b → a = c :=
!add_right_cancel_semigroup.add_right_cancel

abbreviation eq_of_add_eq_add_right := @add.right_cancel

/- monoid -/

structure monoid [class] (A : Type) extends semigroup A, has_one A :=
(one_mul : ∀a, mul one a = a) (mul_one : ∀a, mul a one = a)

theorem one_mul [simp] [monoid A] (a : A) : 1 * a = a := !monoid.one_mul

theorem mul_one [simp] [monoid A] (a : A) : a * 1 = a := !monoid.mul_one

structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A

/- additive monoid -/

structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A :=
(zero_add : ∀a, add zero a = a) (add_zero : ∀a, add a zero = a)

theorem zero_add [simp] [add_monoid A] (a : A) : 0 + a = a := !add_monoid.zero_add

theorem add_zero [simp] [add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_zero

structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A

definition add_monoid.to_monoid {A : Type} [add_monoid A] : monoid A :=
⦃ monoid,
  mul         := add_monoid.add,
  mul_assoc   := add_monoid.add_assoc,
  one         := add_monoid.zero A,
  mul_one     := add_monoid.add_zero,
  one_mul     := add_monoid.zero_add
⦄

definition add_comm_monoid.to_comm_monoid {A : Type} [add_comm_monoid A] : comm_monoid A :=
⦃ comm_monoid,
  add_monoid.to_monoid,
  mul_comm    := add_comm_monoid.add_comm
⦄

section add_comm_monoid
  variables [add_comm_monoid A]

  theorem add_comm_three  (a b c : A) : a + b + c = c + b + a :=
  by inst_simp

  theorem add.comm4 : ∀ (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
  by inst_simp
end add_comm_monoid

/- group -/

structure group [class] (A : Type) extends monoid A, has_inv A :=
(mul_left_inv : ∀a, mul (inv a) a = one)

-- Note: with more work, we could derive the axiom one_mul

section group
  variable [group A]

  theorem mul.left_inv [simp] (a : A) : a⁻¹ * a = 1 := !group.mul_left_inv

  theorem inv_mul_cancel_left [simp] (a b : A) : a⁻¹ * (a * b) = b :=
  by inst_simp

  theorem inv_mul_cancel_right [simp] (a b : A) : a * b⁻¹ * b = a :=
  by inst_simp

  theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b :=
  assert a⁻¹ * 1 = b, by inst_simp,
  by inst_simp

  theorem one_inv [simp] : 1⁻¹ = (1 : A) :=
  inv_eq_of_mul_eq_one (one_mul 1)

  theorem inv_inv [simp] (a : A) : (a⁻¹)⁻¹ = a :=
  inv_eq_of_mul_eq_one (mul.left_inv a)

  theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b :=
  assert a = a⁻¹⁻¹, by simp_nohyps,
  by inst_simp

  theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b :=
  iff.intro (assume H, inv.inj H) (by simp)

  theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 :=
  assert a⁻¹ = 1⁻¹ ↔ a = 1, from inv_eq_inv_iff_eq a 1,
  by inst_simp

  theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 :=
  iff.mp !inv_eq_one_iff_eq_one

  theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ :=
  by inst_simp

  theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ :=
  iff.intro !eq_inv_of_eq_inv !eq_inv_of_eq_inv

  theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ :=
  assert a⁻¹ = b, from inv_eq_of_mul_eq_one H,
  by inst_simp

  theorem mul.right_inv [simp] (a : A) : a * a⁻¹ = 1 :=
  assert a = a⁻¹⁻¹, by simp,
  by inst_simp

  theorem mul_inv_cancel_left [simp] (a b : A) : a * (a⁻¹ * b) = b :=
  by inst_simp

  theorem mul_inv_cancel_right [simp] (a b : A) : a * b * b⁻¹ = a :=
  by inst_simp

  theorem mul_inv [simp] (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
  inv_eq_of_mul_eq_one (by inst_simp)

  theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b :=
  assert a⁻¹ * 1 = a⁻¹, by inst_simp,
  by inst_simp

  theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ :=
  by inst_simp

  theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c :=
  by inst_simp

  theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c :=
  by inst_simp

  theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c :=
  by inst_simp

  theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c :=
  by inst_simp

  theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c :=
  by inst_simp

  theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c :=
  by inst_simp

  theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c :=
  by inst_simp

  theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c :=
  iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul

  theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ :=
  iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv

  theorem mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c :=
  assert a⁻¹ * (a * b) = b, by inst_simp,
  by inst_simp

  theorem mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c :=
  assert a * b * b⁻¹ = a, by inst_simp,
  by inst_simp

  theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 :=
  by rewrite [-inv_eq_of_mul_eq_one H, mul.left_inv]

  theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 :=
  iff.intro !mul_eq_one_of_mul_eq_one !mul_eq_one_of_mul_eq_one

  definition conj_by (g a : A) := g * a * g⁻¹
  definition is_conjugate (a b : A) := ∃ x, conj_by x b = a

  local infixl ` ~ ` := is_conjugate
  local infixr ` ∘c `:55 := conj_by

  local attribute conj_by [reducible]

  lemma conj_compose [simp] (f g a : A) : f ∘c g ∘c a = f*g ∘c a :=
  by inst_simp

  lemma conj_id [simp] (a : A) : 1 ∘c a = a :=
  by inst_simp

  lemma conj_one [simp] (g : A) : g ∘c 1 = 1 :=
  by inst_simp

  lemma conj_inv_cancel [simp] (g : A) : ∀ a, g⁻¹ ∘c g ∘c a = a :=
  by inst_simp

  lemma conj_inv [simp] (g : A) : ∀ a, (g ∘c a)⁻¹ = g ∘c a⁻¹ :=
  by inst_simp

  lemma is_conj.refl (a : A) : a ~ a := exists.intro 1 (conj_id a)

  lemma is_conj.symm (a b : A) : a ~ b → b ~ a :=
  assume Pab, obtain x (Pconj : x ∘c b = a), from Pab,
  assert Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a,   by simp,
  exists.intro x⁻¹ (by inst_simp)

  lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c :=
  assume Pab, assume Pbc,
  obtain x (Px : x ∘c b = a), from Pab,
  obtain y (Py : y ∘c c = b), from Pbc,
  exists.intro (x*y) (by inst_simp)

end group

definition group.to_left_cancel_semigroup [trans_instance] [reducible] [s : group A] :
    left_cancel_semigroup A :=
⦃ left_cancel_semigroup, s,
  mul_left_cancel := @mul_left_cancel A s ⦄

definition group.to_right_cancel_semigroup [trans_instance] [reducible] [s : group A] :
    right_cancel_semigroup A :=
⦃ right_cancel_semigroup, s,
  mul_right_cancel := @mul_right_cancel A s ⦄

structure comm_group [class] (A : Type) extends group A, comm_monoid A

/- additive group -/

structure add_group [class] (A : Type) extends add_monoid A, has_neg A :=
(add_left_inv : ∀a, add (neg a) a = zero)

definition add_group.to_group {A : Type} [add_group A] : group A :=
⦃ group, add_monoid.to_monoid,
  mul_left_inv := add_group.add_left_inv ⦄

section add_group
  variables [s : add_group A]
  include s

  theorem add.left_inv [simp] (a : A) : -a + a = 0 := !add_group.add_left_inv

  theorem neg_add_cancel_left [simp] (a b : A) : -a + (a + b) = b :=
  calc -a + (a + b) = (-a + a) + b : by rewrite add.assoc
               ...  = b            : by simp

  theorem neg_add_cancel_right [simp] (a b : A) : a + -b + b = a :=
  by inst_simp

  theorem neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b :=
  assert -a + 0 = b, by inst_simp,
  by inst_simp

  theorem neg_zero [simp] : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0)

  theorem neg_neg [simp] (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a)

  theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b :=
  assert -a = b, from neg_eq_of_add_eq_zero H,
  by inst_simp

  theorem neg.inj {a b : A} (H : -a = -b) : a = b :=
  assert a = -(-a), by simp_nohyps,
  by inst_simp

  theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b :=
  iff.intro (assume H, neg.inj H) (by simp)

  theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b :=
  iff.mp !neg_eq_neg_iff_eq

  theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 :=
  assert -a = -0 ↔ a = 0, from neg_eq_neg_iff_eq a 0,
  by inst_simp

  theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 :=
  iff.mp !neg_eq_zero_iff_eq_zero

  theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a :=
  by inst_simp

  theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a :=
  iff.intro !eq_neg_of_eq_neg !eq_neg_of_eq_neg

  theorem add.right_inv [simp] (a : A) : a + -a = 0 :=
  assert a = -(-a), by simp,
  by inst_simp

  theorem add_neg_cancel_left [simp] (a b : A) : a + (-a + b) = b :=
  by inst_simp

  theorem add_neg_cancel_right [simp] (a b : A) : a + b + -b = a :=
  by inst_simp

  theorem neg_add_rev [simp] (a b : A) : -(a + b) = -b + -a :=
  neg_eq_of_add_eq_zero (by inst_simp)

  -- TODO: delete these in favor of sub rules?
  theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c :=
  by inst_simp

  theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c :=
  by inst_simp

  theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c :=
  by inst_simp

  theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c :=
  by inst_simp

  theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c :=
  by inst_simp

  theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c :=
  by inst_simp

  theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c :=
  by inst_simp

  theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c :=
  iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add

  theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b :=
  iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg

  theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c :=
  assert -a + (a + b) = b, by inst_simp,
  by inst_simp

  theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c :=
  assert a + b + -b = a, by inst_simp,
  by inst_simp

  definition add_group.to_left_cancel_semigroup [trans_instance] [reducible] :
    add_left_cancel_semigroup A :=
  ⦃ add_left_cancel_semigroup, s,
    add_left_cancel := @add_left_cancel A s ⦄

  definition add_group.to_add_right_cancel_semigroup [trans_instance] [reducible] :
    add_right_cancel_semigroup A :=
  ⦃ add_right_cancel_semigroup, s,
    add_right_cancel := @add_right_cancel A s ⦄

  theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) :=
  by inst_simp

  theorem ne_add_of_ne_zero_right (a : A) {b : A} (H : b ≠ 0) : a ≠ b + a :=
    begin
      intro Heq,
      apply H,
      rewrite [-zero_add a at Heq{1}],
      let Heq' := eq_of_add_eq_add_right Heq,
      apply eq.symm Heq'
    end

  theorem ne_add_of_ne_zero_left (a : A) {b : A} (H : b ≠ 0) : a ≠ a + b :=
    begin
      intro Heq,
      apply H,
      rewrite [-add_zero a at Heq{1}],
      let Heq' := eq_of_add_eq_add_left Heq,
      apply eq.symm Heq'
    end

  /- sub -/

  -- TODO: derive corresponding facts for div in a field
  protected definition algebra.sub [reducible] (a b : A) : A := a + -b

  definition add_group_has_sub [reducible] [instance] : has_sub A :=
  has_sub.mk algebra.sub

  theorem sub_eq_add_neg [simp] (a b : A) : a - b = a + -b := rfl

  theorem sub_self (a : A) : a - a = 0 := !add.right_inv

  theorem sub_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right

  theorem add_sub_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right

  theorem add_sub_assoc (a b c : A) : a + b - c = a + (b - c) :=
    by rewrite [sub_eq_add_neg, add.assoc, -sub_eq_add_neg]

  theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b :=
  assert -a + 0 = -a, by inst_simp,
  by inst_simp

  theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 :=
  iff.intro (assume H, eq.subst H !sub_self) (assume H, eq_of_sub_eq_zero H)

  theorem zero_sub (a : A) : 0 - a = -a := !zero_add

  theorem sub_zero (a : A) : a - 0 = a :=
  by inst_simp

  theorem sub_ne_zero_of_ne {a b : A} (H : a ≠ b) : a - b ≠ 0 :=
    begin
      intro Hab,
      apply H,
      apply eq_of_sub_eq_zero Hab
    end

  theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b :=
  by inst_simp

  theorem neg_sub (a b : A) : -(a - b) = b - a :=
  neg_eq_of_add_eq_zero (by inst_simp)

  theorem add_sub (a b c : A) : a + (b - c) = a + b - c :=
  by inst_simp

  theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b :=
  by inst_simp

  theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b :=
  iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H)

  theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b :=
  iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H)

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d :=
  calc
    a = b ↔ a - b = 0   : eq_iff_sub_eq_zero
      ... = (c - d = 0) : H
      ... ↔ c = d       : iff.symm (eq_iff_sub_eq_zero c d)

  theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c :=
  by inst_simp

  theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c :=
  by inst_simp

  theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
  by inst_simp

end add_group

structure add_comm_group [class] (A : Type) extends add_group A, add_comm_monoid A

section add_comm_group
  variable [s : add_comm_group A]
  include s

  theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c :=
  by inst_simp

  theorem neg_add_eq_sub (a b : A) : -a + b = b - a :=
  by inst_simp

  theorem neg_add (a b : A) : -(a + b) = -a + -b :=
  by inst_simp

  theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b :=
  by inst_simp

  theorem sub_sub (a b c : A) : a - b - c = a - (b + c) :=
  by inst_simp

  theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b :=
  by inst_simp

  theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c :=
  by inst_simp

  theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c :=
  by inst_simp

  theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c :=
  by inst_simp

  theorem sub_sub_self (a b : A) : a - (a - b) = b :=
  by inst_simp

  theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) :=
  by inst_simp

  theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) :=
  by inst_simp

  theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
  by inst_simp

end add_comm_group

definition group_of_add_group (A : Type) [G : add_group A] : group A :=
⦃group,
  mul             := has_add.add,
  mul_assoc       := add.assoc,
  one             := !has_zero.zero,
  one_mul         := zero_add,
  mul_one         := add_zero,
  inv             := has_neg.neg,
  mul_left_inv    := add.left_inv⦄

namespace norm_num
reveal add.assoc

definition add1 [has_add A] [has_one A] (a : A) : A := add a one

local attribute add1 bit0 bit1 [reducible]

theorem add_comm_four [add_comm_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) :=
by inst_simp

theorem add_comm_middle [add_comm_semigroup A] (a b c : A) : a + b + c = a + c + b :=
by inst_simp

theorem bit0_add_bit0 [add_comm_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
by inst_simp

theorem bit0_add_bit0_helper [add_comm_semigroup A] (a b t : A) (H : a + b = t) :
        bit0 a + bit0 b = bit0 t :=
by rewrite -H; simp

theorem bit1_add_bit0 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit0 b = bit1 (a + b) :=
by inst_simp

theorem bit1_add_bit0_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit1 a + bit0 b = bit1 t :=
by rewrite -H; simp

theorem bit0_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit0 a + bit1 b = bit1 (a + b) :=
by inst_simp

theorem bit0_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit0 a + bit1 b = bit1 t :=
by rewrite -H; simp

theorem bit1_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit1 b = bit0 (add1 (a + b)) :=
by inst_simp

theorem bit1_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t s: A)
        (H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s :=
by inst_simp

theorem bin_add_zero [add_monoid A] (a : A) : a + zero = a :=
by inst_simp

theorem bin_zero_add [add_monoid A] (a : A) : zero + a = a :=
by inst_simp

theorem one_add_bit0 [add_comm_semigroup A] [has_one A] (a : A) : one + bit0 a = bit1 a :=
by inst_simp

theorem bit0_add_one [has_add A] [has_one A] (a : A) : bit0 a + one = bit1 a :=
rfl

theorem bit1_add_one [has_add A] [has_one A] (a : A) : bit1 a + one = add1 (bit1 a) :=
rfl

theorem bit1_add_one_helper [has_add A] [has_one A] (a t : A) (H : add1 (bit1 a) = t) :
        bit1 a + one = t :=
by inst_simp

theorem one_add_bit1 [add_comm_semigroup A] [has_one A] (a : A) : one + bit1 a = add1 (bit1 a) :=
by inst_simp

theorem one_add_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A)
        (H : add1 (bit1 a) = t) : one + bit1 a = t :=
by inst_simp

theorem add1_bit0 [has_add A] [has_one A] (a : A) : add1 (bit0 a) = bit1 a :=
rfl

theorem add1_bit1 [add_comm_semigroup A] [has_one A] (a : A) :
        add1 (bit1 a) = bit0 (add1 a) :=
by inst_simp

theorem add1_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A) (H : add1 a = t) :
        add1 (bit1 a) = bit0 t :=
by inst_simp

theorem add1_one [has_add A] [has_one A] : add1 (one : A) = bit0 one :=
rfl

theorem add1_zero [add_monoid A] [has_one A] : add1 (zero : A) = one :=
by inst_simp

theorem one_add_one [has_add A] [has_one A] : (one : A) + one = bit0 one :=
rfl

theorem subst_into_sum [has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
        (prt : tl + tr = t) : l + r = t :=
by inst_simp

theorem neg_zero_helper [add_group A] (a : A) (H : a = 0) : - a = 0 :=
by inst_simp

end norm_num

attribute [simp]
  zero_add add_zero one_mul mul_one
  at simplifier.unit

attribute [simp]
  neg_neg sub_eq_add_neg
  at simplifier.neg

attribute [simp]
  add.assoc add.comm add.left_comm
  mul.left_comm mul.comm mul.assoc
  at simplifier.ac

import data.real
open real

namespace example2

/- Assume we have an exp (exponential) function, and state basic properties using axioms. -/
constant exp : ℝ → ℝ
/- The annotation (: t :) is used to indicate that `t` is a pattern for the E-matching procedure. -/
axiom exp_add : ∀ x y : ℝ, (: exp (x + y) :) = exp x * exp y
/- The [forward] attribute instructs lean to use the following axioms for E-matching. -/
attribute [forward] exp_add

/- Define t² as notation for t*t -/
definition sq (x : ℝ) := x * x
notation a `²` := sq a
/- (sq x) and (x * x) are equal by definition, and we can prove it using reflexivity. -/
lemma sq_def [forward] : ∀ x : ℝ, sq x = x * x :=
  take x, rfl
lemma sq_add [forward] : ∀ x y : ℝ, sq (x + y) = (: sq x + 2 * x * y + sq y :) :=
  take x y, by unfold sq; rewrite add_mul_self_eq

/- Define predicate pos and state basic properties using axioms. -/
definition pos (x : ℝ) := x > 0
axiom pos_1    : pos (1:ℝ)
axiom pos_bit1 : ∀ x : ℝ,   pos x → pos (bit1 x)
axiom pos_bit0 : ∀ x : ℝ,   pos x → pos (bit0 x)
axiom pos_sq   : ∀ x : ℝ,   pos x → pos (sq x)
axiom pos_add  : ∀ x y : ℝ, pos x → pos y → (: pos (x + y) :)
axiom pos_mul  : ∀ x y : ℝ, pos x → pos y → (: pos (x * y) :)
axiom pos_exp  : ∀ x : ℝ,   pos (exp x)

/- The [intro!] attribute instructs lean to use the following axioms for backward chaining. -/
attribute [intro!]  pos_bit1 pos_bit0 pos_1 pos_add pos_mul pos_sq pos_exp
attribute [forward] pos_add pos_mul

/- Define predicate nzero and state basic properties using axioms. -/
definition nzero (x : ℝ) := x ≠ 0
axiom nzero_of_pos : ∀ x : ℝ, pos x → nzero x
axiom nzero_of_neg : ∀ x : ℝ, pos x → nzero (- x)

attribute [intro!] nzero_of_pos nzero_of_neg

/- Assume we have safe_log and safe_inv functions. -/
constant safe_log : Π (x : ℝ), pos x → ℝ
constant safe_inv : Π (x : ℝ), nzero x → ℝ

/-
Define notation (log x), (x ⁻¹) and (x / y) for safe_log and safe_inv.
We discharge the preconditions pos and nzero using tactics.
The grind tactic is based on backward chaining, and uses all axioms/lemmas
marked with the `[intro!]` attribute.
-/
notation `log`:max x:max := (@safe_log x (by grind))
/-
  We use priority greater than the default to avoid a conflict with existing
  notation defined in Lean.
-/
notation [priority std.priority.default+1] x ⁻¹ := (@safe_inv x (by grind))
notation [priority std.priority.default+1] x `/` y := (@safe_inv y (by grind) * x)

/- Assume basic properties about safe_inf and safe_log as axioms -/

axiom inv_pos         : ∀ x : ℝ,   pos x → pos (x⁻¹)
axiom inv_mul         : ∀ x y : ℝ, pos x → pos y →  (x * y)⁻¹ = (x⁻¹) * (y⁻¹)
axiom inv_cancel_left : ∀ x y : ℝ, pos x →  x⁻¹ * (x * y) = y
axiom inv_neg         : ∀ x : ℝ,   pos x →  (- x)⁻¹ = - (x⁻¹)

attribute [intro!] inv_pos
attribute [forward] inv_pos inv_mul inv_cancel_left inv_neg

axiom log_mul : ∀ x y : ℝ, pos x → pos y → log (x * y) = log x + log y
axiom log_sq  : ∀ x : ℝ,   pos x → log (sq x) = 2 * log x
axiom log_inv : ∀ x : ℝ,   pos x → log (x⁻¹)  = - log x

attribute [forward] log_mul log_sq log_inv

/- To prove the main lemma, we also need the following basic properties from the standard library. -/
lemma rdistrib [forward]    : ∀ x y z : ℝ, (x + y) * z = x * z + y * z   :=
  right_distrib
lemma addcomm [forward]     : ∀ x y : ℝ, x + y = y + x                   :=
  add.comm
lemma sub_def [forward]     : ∀ x y : ℝ, x - y = x + -y                  :=
  take x y, rfl
lemma mul_two_sum [forward] : ∀ x : ℝ, (: 2 * x :) = x + x               :=
  take x, show (1 + 1) * x = x + x,
  by rewrite [rdistrib, one_mul]
lemma neg_mul [forward]     : ∀ x y : ℝ, (: (- x) * y :) = - (x * y)     :=
  take x y, by rewrite neg_mul_eq_neg_mul

set_option blast.strategy "ematch"

example : ∀ x y z w : ℝ, pos x → pos y → pos z → pos w → x * y = exp z + w →
          log (2 * w * exp z + w² + exp (2*z)) / -2 = log (y⁻¹) - log x :=
begin
  have pos 2, by grind, /- Discharge auxiliary fact using backward chaining. -/
  blast                 /- Use congruence closure and ematching to prove main goal. -/
end

end example2


import topology.maps topology.subset_properties

example : ℕ := 691

open_locale classical

-- x ∈ closure S if and only if x ∈ C for all closed sets containing S.
lemma mem_closure_iff' {X : Type*} [topological_space X] {S : set X} {x : X} :
  x ∈ closure S ↔ ∀ C : set X, is_closed C → S ⊆ C → x ∈ C :=
begin
  rw mem_closure_iff,
  split,
  { intros h C hC hSC,
    replace h := h C.compl hC,
    by_contra hx,
    apply set.ne_empty_iff_nonempty.2 (h hx), clear h hx,
    rw set.eq_empty_iff_forall_not_mem,
    rintros x ⟨hxC, hxS⟩,
    apply hxC,
    apply hSC,
    assumption},
  { intros h U hU hxU,
    replace h := h (-U : set X) (is_closed_compl_iff.2 hU),
    rw ←set.ne_empty_iff_nonempty,
    intro hUS,
    apply h _ hxU,
    intros x hx hU,
    apply set.not_mem_empty x,
    rw ←hUS,
    split; assumption},
end

open set

/-- If X is compact then pr₂ : X × Y → Y is a closed map -/
theorem closed_pr2_of_compact
  {X : Type*} [topological_space X] [compact_space X]
  {Y : Type*} [topological_space Y] :
  is_closed_map (prod.snd : X × Y → Y) :=
-- Let C be a closed set in X × Y
λ C hC, begin
  -- It suffices to prove that every y in the complement of pr₂(C)
  -- is contained in an open neighbourhood which misses pr₂(C)
  rw [←is_open_compl_iff, is_open_iff_forall_mem_open],
  -- so take y in the complement
  intros y hy,
  -- and apply the generalised tube lemma to X × {y}
  -- which tells us that there exists a basic open U × V containing X × {y}
  -- which is disjoint from C (this is where we use compactness of X)
  rcases generalized_tube_lemma compact_univ
    (compact_singleton : compact {y}) (is_open_compl_iff.2 hC) _ with
    ⟨U, V, hU, hV, hXU, hyV, hUV⟩,
  { -- The set V is the neighbourhood of y we seek.
    use V,
    split,
    { rintros v hvV ⟨uv, huv, rfl⟩,
      exact hUV ⟨hXU (set.mem_univ _), hvV⟩ huv,
    },
    exact ⟨hV, hyV (set.mem_singleton _)⟩,
  },
  { -- and the proof is complete once we note that y ∉ pr₂(C) implies
    -- X × {y} is disjoint from C
    rintros xy ⟨hx, hyC⟩ hxyC,
    apply hy,
    existsi xy,
    exact ⟨hxyC, mem_singleton_iff.1 hyC⟩,
  }
end

def filter_topology {X : Type*} (F : filter X) : topological_space (option X) :=
{ is_open := λ U, if none ∈ U then some ⁻¹' U ∈ F else true,
  is_open_univ := begin
    rw [if_pos, preimage_univ],
      exact filter.univ_mem_sets,
    exact mem_univ (none : option X),
  end,
  is_open_inter := λ U V hU hV,
    begin
    split_ifs, swap, trivial,
    cases h with h0U h0V,
    rw if_pos at hU, swap, exact h0U,
    rw if_pos at hV, swap, exact h0V,
    show some ⁻¹' (U ∩ V) ∈ F,
    rw preimage_inter,
    exact F.inter_sets hU hV,
  end,
  is_open_sUnion := λ I hI, begin
    split_ifs, swap, trivial,
    rcases h with ⟨U, hU, h0U⟩,
    replace hI := hI U hU,
    rw preimage_sUnion,
    rw if_pos at hI,
      exact filter.mem_sets_of_superset hI (subset_bUnion_of_mem hU),
    exact h0U,
  end
}

/-- If F is not ⊥ then the closure of X in option X is all of option X -/
lemma closure_range_sum_eq_univ {X : Type*} {F : filter X} (hF : F ≠ ⊥) :
  @closure (option X) (filter_topology F) (range some) = univ :=
begin
  letI := filter_topology F,
  apply eq_univ_of_forall,
  rintro (_| x),
  -- Clearly X is a subset of the closure of X
  -- so it suffices to prove that the extra point is in the closure
    swap, exact subset_closure ⟨x, rfl⟩,
  -- Assume for a contradiction that it is not.
  by_contra hnone,
  -- Then the complement of the closure is open and contains the extra point
  set U := -(closure (range some) : set (option X)) with hUc,
  have HUO : is_open U := is_open_compl_iff.2 is_closed_closure,
  change if none ∈ U then some ⁻¹' U ∈ F else true at HUO,
  -- so the intersection of this complement with X must be in F
  rw if_pos at HUO, swap, rwa hUc,
  apply hF,
  rw ←filter.empty_in_sets_eq_bot,
  -- If this intersection is empty this contradicts the fact that F ≠ ⊥
  convert HUO, symmetry, rw eq_empty_iff_forall_not_mem,
  -- but the intersection is empty because X is a subset of its closure
  intros x hx,
  rw hUc at hx,
  refine hx (subset_closure _),
  use x,
end

universe u

theorem compact_space_of_closed_pr2 {X : Type u} [topological_space X]
  (hclosed : ∀ (Y : Type u) [topological_space Y], is_closed_map (prod.snd : X × Y → Y)) :
  compact_space X :=
  -- we will show that every proper filter has an adherent point
⟨λ F hF h0, begin
  -- Let Y be the topological space defined above (X + extra point with nhds F)
  -- (we'll just call it `option X` here)
  letI := filter_topology F,
  -- Let D be the closure of {(x,x)} in X × Y.
  set D := closure (set.range (λ x : X, (⟨x, some x⟩ : X × option X))) with hD,
  -- Its image in Y is closed.
  replace hclosed := hclosed (option X) D (is_closed_closure),
  -- Now clearly the projection contains X
  have hX : range some ⊆ prod.snd '' D,
  { rintros _ ⟨x, rfl⟩,
    use ⟨x, some x⟩,
    split, swap, refl,
    refine subset_closure _,
    exact ⟨x, rfl⟩,
  },
  -- and it's closed, so by `closure_range_sum_eq_univ` the projection is everything
  -- and in particular contains the extra point
  have hnone : none ∈ prod.snd '' D,
    apply (closure_subset_iff_subset_of_is_closed hclosed).2 hX,
    rw closure_range_sum_eq_univ hF,
    exact mem_univ _,
  -- Hence (x, extra point) is in the closure of the diagonal
  rcases hnone with ⟨xy, hxy, hy⟩,
  -- and we claim this x works
  use xy.fst,
  split, exact mem_univ _,
  -- We have to show that every element of F meets every neighbourhood of X
  intro hbot,
  rw [←filter.empty_in_sets_eq_bot, filter.mem_inf_sets] at hbot,
  -- so let A be an element of the filter, and let U be a neighbourhood of x (=xy.fst)
  rcases hbot with ⟨A, hA, U, hU, hAU⟩,
  rw subset_empty_iff at hAU,
  revert hAU,
  -- and let's show A ∩ U is non-empty.
  change A ∩ U ≠ ∅,
  rw set.ne_empty_iff_nonempty,
  rw mem_nhds_sets_iff at hU,
  -- U is a neighbourhood of x so it contains an open neighbourhood U' of x
  rcases hU with ⟨U', hU'U, hU', hxyU'⟩,
  -- Let V be the basic open set U' x (point union A)
  set V : set (X × option X) := set.prod U' (insert none (some '' A)),
  have hV : is_open V,
  { apply is_open_prod hU',
    change if none ∈ (insert none (some '' A)) then some ⁻¹' (insert none (some '' A)) ∈ F else true,
    rw if_pos (mem_insert none _),
    convert hA using 1,
    ext a,
    simp,
  },
  -- Clearly (x,extra point) is in V
  have hxyV : xy ∈ V,
  { split, exact hxyU',
    rw hy,
    apply mem_insert
  },
  -- so V meets D and hence (because V is open) meets the diagonal
  rw [hD, mem_closure_iff] at hxy,
  replace hxy := hxy V hV hxyV,
  -- so say it meets the diagonal at (p,p)
  rcases hxy with ⟨_, hp, p, rfl⟩,
  -- then p is easily checked to be in the intersection and we're done
  use p,
  cases hp with hpU hpA,
  split,
    change some p ∈ _ at hpA,
    rw mem_insert_iff at hpA,
    cases hpA, cases hpA,
    rcases hpA with ⟨p', hp', hpp'⟩,
    convert hp',
    exact option.some_inj.1 hpp'.symm,
  exact hU'U hpU,
end⟩