import order.basic ..nat ..logic .neg_elim
  .reify .rev .sub_elim .dnf ..expr_of_unsat

open tactic

namespace nat

run_cmd mk_simp_attr `sugar_nat
attribute [sugar_nat]
  not_le not_lt
  lt_iff_add_one_le
  succ_eq_add_one
  or_false false_or
  and_true true_and
  ge gt mul_add add_mul
  mul_comm classical.iff_iff
  classical.imp_iff_not_or

meta def desugar := `[try {simp only with sugar_nat}]

lemma uniclo_of_unsat_neg_elim_not (m) (p : form) :
  (neg_elim (¬* p)).unsat → uniclo p (λ _, 0) m :=
begin
  intro h1, apply uniclo_of_valid,
  apply valid_of_unsat_not, intro h2, apply h1,
  apply form.sat_of_implies_of_sat implies_neg_elim h2,
end

meta def preterm.expr_of_sub_free : preterm → tactic expr
| (& m)    := return `(trivial)
| (m ** n) := return `(trivial)
| (t +* s) :=
  do x ← preterm.expr_of_sub_free t,
     y ← preterm.expr_of_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (_ -* _) := failed

meta def expr_of_neg_free : form → tactic expr
| (t =* s) := return `(trivial)
| (t ≤* s) := return `(trivial)
| (p ∨* q) :=
  do x ← expr_of_neg_free p,
     y ← expr_of_neg_free q,
     return `(@and.intro (form.neg_free %%`(p))
       (form.neg_free %%`(q)) %%x %%y)
| (p ∧* q) :=
  do x ← expr_of_neg_free p,
     y ← expr_of_neg_free q,
     return `(@and.intro (form.neg_free %%`(p))
       (form.neg_free %%`(q)) %%x %%y)
| _        := failed

meta def expr_of_sub_free : form → tactic expr
| (t =* s) :=
  do x ← preterm.expr_of_sub_free t,
     y ← preterm.expr_of_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (t ≤* s) :=
  do x ← preterm.expr_of_sub_free t,
     y ← preterm.expr_of_sub_free s,
     return `(@and.intro (preterm.sub_free %%`(t))
       (preterm.sub_free %%`(s)) %%x %%y)
| (¬*p) := expr_of_sub_free p
| (p ∨* q) :=
  do x ← expr_of_sub_free p,
     y ← expr_of_sub_free q,
     return `(@and.intro (form.sub_free %%`(p))
       (form.sub_free %%`(q)) %%x %%y)
| (p ∧* q) :=
  do x ← expr_of_sub_free p,
     y ← expr_of_sub_free q,
     return `(@and.intro (form.sub_free %%`(p))
       (form.sub_free %%`(q)) %%x %%y)

/- Given a p : form, return the expr of a term t : p.unsat,
   where p is subtraction- and negation-free. -/
meta def expr_of_unsat_sf (p : form) : tactic expr :=
do x ← expr_of_neg_free p,
   y ← expr_of_sub_free p,
   z ← expr_of_unsats (dnf p),
   return `(unsat_of_unsat_dnf %%`(p) %%x %%y %%z)

/- Given a p : form, return the expr of a term t : p.unsat,
   where p is negation-free. -/
meta def expr_of_unsat_nf : form → tactic expr | p :=
match p.sub_terms with
| none         := expr_of_unsat_sf p
| (some (t,s)) :=
  do x ← expr_of_unsat_nf (sub_elim t s p),
     return `(unsat_of_unsat_sub_elim %%`(t) %%`(s) %%`(p) %%x)
end

/- Given a (m : nat) and (p : form),
   return the expr of (t : uniclo m p) -/
meta def expr_of_uniclo (m : nat) (p : form) : tactic expr :=
do x ← expr_of_unsat_nf (neg_elim (¬*p)),
   to_expr ``(uniclo_of_unsat_neg_elim_not %%`(m) %%`(p) %%x)

meta def expr_of_lna : tactic expr :=
do (p,m) ← target >>= to_form 0,
   expr_of_uniclo m p

meta def omega : tactic unit :=
rev >> desugar >> expr_of_lna >>= apply >> skip

end nat


example : ∀(x : Nat){h : x = x}, Nat := by
  intro x
  match x with
  | 0 => _
  | n + 1 => _

example (x : Nat) : ∀{h : x = x}, Nat := by
  match x with
  | 0 => _
  | n + 1 => _


section
  variables (x y z : ℕ)
  variables (h₁ : x = y) (h₂ : y = z)

  section
    variables {x y z}
    include h₁ h₂
    theorem foo : x = z :=
    begin
      rw [h₁, h₂]
    end
  end

  theorem bar : x = z :=
    eq.trans h₁ h₂

  variable {x}
  theorem baz : x = x := rfl

  #check @foo
  #check @bar
  #check baz
end


import data.finmap

run_cmd mk_simp_attr `separation_logic

open finmap

namespace memory

variables value : Type

@[reducible]
def ptr := ℕ

@[reducible]
def heap := finmap (λ _ : ptr, value)

variables {value}

def add (x y : option (heap value)) : option (heap value) :=
do x ← x,
   y ← y,
   if disjoint x y then pure $ x ∪ y else none

infixr ` ⊗ `:55 := add

instance {α : Type*} {β : α → Type*} : has_subset (finmap β) :=
⟨ λ x y, ∀ a, a ∈ x → a ∈ y ⟩

lemma disjoint_mono' {ha hb ha' hb' : heap value} (H₀ : ha' ⊆ ha) (H₁ : hb' ⊆ hb) :
  disjoint ha hb → disjoint ha' hb' :=
λ H₂ x H₃ H₄,  H₂ x (H₀ _ H₃) (H₁ _ H₄)

lemma union_eq_add_of_disjoint {h h' : heap value} (H₀ : disjoint h h') :
  some (h ∪ h') = some h ⊗ some h' :=
by simp [add,if_pos H₀]; refl

lemma add_assoc (h₀ h₁ h₂ : option (heap value)) : (h₀ ⊗ h₁) ⊗ h₂ = h₀ ⊗ (h₁ ⊗ h₂) :=
begin
  simp only [add] with monad_norm; congr; ext : 1; congr; ext : 1,
  split_ifs,
  { simp, congr, ext : 1,
    split_ifs; simp [disjoint_union_left] at h_1,
    { simp, rw [if_pos,finmap.union_assoc],
      simp [disjoint_union_right],
      exact ⟨h,h_1.1⟩ },
    { exfalso, apply h_2 h_1.2 },
    simp, split_ifs,
    { exfalso, rw disjoint_union_right at h_3,
      apply h_1 h_3.2 h_2, },
    { refl },
    simp },
  simp, cases h₂,
  { refl },
  change none = pure h₂ >>= _, simp,
  split_ifs,
  { simp, split_ifs,
    exfalso, rw disjoint_union_right at h_2, apply h h_2.1,
    refl },
  refl
end

lemma add_comm (h₀ h₁ : option (heap value)) : h₀ ⊗ h₁ = h₁ ⊗ h₀ :=
begin
  cases h₀; cases h₁; try { refl },
  simp only [add, @disjoint.symm_iff _ _ h₀, option.some_bind]; split_ifs,
  ext : 1, simp only [ext_iff,pure], rw finmap.union_comm_of_disjoint,
  symmetry, assumption, refl
end

instance : is_associative _ (@add value) := ⟨ add_assoc ⟩
instance : is_commutative _ (@add value) := ⟨ add_comm ⟩

@[simp]
lemma empty_add (h : option (heap value)) :
  some ∅ ⊗ h = h :=
by cases h; [ simp [add], { rw [← union_eq_add_of_disjoint,empty_union]; apply disjoint_empty }]

@[simp]
lemma add_empty (h : option (heap value)) :
  h ⊗ some ∅ = h :=
by cases h; [ simp [add], { rw [← union_eq_add_of_disjoint,union_empty]; apply empty_disjoint }]

lemma add_eq_some (x y : option (heap value)) (z : heap value) : some z = x ⊗ y → ∃ x', some x' = x :=
by intro h; cases x; [ { simp [add] at h, cases h }, exact ⟨_,rfl⟩ ]

lemma add_eq_some' (x y : option (heap value)) (z : heap value) : some z = x ⊗ y → ∃ y', some y' = y :=
assume h, add_eq_some y x z (@add_comm _ x y ▸ h)

lemma disjoint_iff {h h' : heap value} : disjoint h h' ↔ ∃ h'', some h'' = some h ⊗ some h' :=
by by_cases disjoint h h'; simp only [add, *, option.some_bind, exists_false, if_false, if_true, true_iff]; exact ⟨_,rfl⟩

lemma disjoint_of_add {h h' : heap value} (h'' : heap value) : some h'' = some h ⊗ some h' → disjoint h h' :=
λ HH, disjoint_iff.mpr ⟨_, HH⟩

lemma eq_union_of_eq_add {h h' h'' : heap value} : some h'' = some h ⊗ some h' → h'' = h ∪ h' :=
λ HH, option.some.inj (eq.trans HH (union_eq_add_of_disjoint (disjoint_of_add _ HH)).symm)

end memory


import analysis.calculus.times_cont_diff
import analysis.calculus.fderiv_symmetric
import analysis.calculus.conformal
import similarity
import data.matrix.notation

noncomputable theory

open conformal_at submodule set continuous_linear_map
open_locale classical real_inner_product_space filter topological_space

lemma quick1 {E : Type*} [inner_product_space ℝ E] (u : E) : ![u] = fin.snoc 0 u :=
begin
  ext y,
  simp only [fin.snoc],
  rw dif_neg (not_lt.mpr $ zero_le y.val),
  simp
end

lemma diff1 {E F G : Type*} [normed_group E] [normed_group F] [normed_group G]
  [normed_space ℝ E] [normed_space ℝ F]
  [normed_space ℝ G] {x v : E} {u : G} {f : E → F} (hf : differentiable_at ℝ f x) :
  (fderiv ℝ (λ y, (f y, u)) x v).2 = 0 :=
begin
  have A : (fderiv ℝ (λ y, (f y, u)) x v).2 =
    (continuous_linear_map.snd ℝ F G).comp (fderiv ℝ (λ y, (f y, u)) x) v := by simp,
  rw A,
  rw ← (continuous_linear_map.snd ℝ F G).fderiv,
  rw [← fderiv.comp, coe_snd'],
  have B : prod.snd ∘ (λ y, (f y, u)) = λ y, u := by ext1; simp,
  rw [B, fderiv_const_apply, zero_apply],
  { exact continuous_linear_map.differentiable_at _ },
  { refine differentiable_at.prod hf _,
    exact differentiable_at_const _ }
end

variables {E F : Type*} [inner_product_space ℝ E] [inner_product_space ℝ F] {f : E → F}
  {s : set E} (hs : is_open s)

lemma A {f' : E →L[ℝ] F} (h : is_conformal_map f') {u v : E} :
  ⟪u, v⟫ = 0 ↔ ⟪f' u, f' v⟫ = 0 :=
begin
  rcases (is_conformal_map_iff _).mp h with ⟨c, p, q⟩,
  split,
  { intros huv,
    convert q u v,
    rw [huv, mul_zero] },
  { intros huv,
    rw q u v at huv,
    exact eq_zero_of_ne_zero_of_mul_left_eq_zero (ne_of_gt p) huv }
end

lemma A' {x : E} {f' : E → (E →L[ℝ] F)} {u v : E} (huv : ⟪u, v⟫ = 0)
  (h : ∀ᶠ x' in 𝓝 x, is_conformal_map $ f' x') :
  (λ x, ⟪f' x u, f' x v⟫) =ᶠ[𝓝 x] λ x, (0 : ℝ) :=
begin
  apply (filter.eventually_of_forall $ λ x, huv).mp,
  simp only [congr_arg],
  rcases filter.eventually_iff_exists_mem.mp h with ⟨s, hs, hys⟩,
  exact filter.eventually_iff_exists_mem.mpr ⟨s, hs, λ y hy p, (A $ hys y hy).mp p⟩
end

include hs

lemma eval_fderiv1 {u v x : E} (hx : x ∈ s) {p : E → formal_multilinear_series ℝ E F}
  (hf : has_ftaylor_series_up_to_on 2 f p s) :
  fderiv ℝ (λ y, p y 1 ![u]) x v = p x 2 ![u, v] :=
begin
  have : (λ y, p y 1 ![u]) = (λ (q : (E →L[ℝ] F) × E), q.1 q.2) ∘
    (λ y, (continuous_multilinear_curry_fin1 ℝ _ _ (p y 1), u)),
  { ext1,
    simp only [function.comp_app, continuous_multilinear_curry_fin1_apply],
    rw quick1 },
  rw [this, fderiv.comp, is_bounded_bilinear_map_apply.fderiv],
  simp only [coe_comp', function.comp_app, is_bounded_bilinear_map_deriv_coe],
  rw @diff1 _ _ _ _ _ _ _ _ _ (λ y, continuous_multilinear_curry_fin1 ℝ _ _ (p y 1)),
end

-- lemma eval_fderiv3 {u x : E} (hx : x ∈ s)
--   {n₀ : ℕ} (hf : times_cont_diff_at ℝ n₀ f x) {n : ℕ} (hn : n < n₀) {m : fin (n + 1) → E} :
--   fderiv ℝ (λ y, iterated_fderiv) x u = p x (n + 2) (fin.snoc m u)

lemma diff_aux {f' : E → (E →L[ℝ] F)} {x u : E}
  (hf : ∀ᶠ (y : E) in 𝓝 x, has_fderiv_at f (f' y) y) (hf' : differentiable_at ℝ f' x) :
  fderiv ℝ (λ y, f' y u) x = fderiv ℝ f' x u :=
begin
  have : (λ y, f' y u) = λ y, ((apply ℝ F u) ∘ f') y :=
    by simp only [function.comp_app, apply_apply],
  simp only [this, congr_arg],
  rw fderiv.comp _ (continuous_linear_map.differentiable_at _) hf',
  ext1 v,
  simp only [continuous_linear_map.fderiv, coe_comp', function.comp_app, apply_apply],
  exact second_derivative_symmetric_of_eventually hf hf'.has_fderiv_at _ _
end

variables {p : E → formal_multilinear_series ℝ E F}

lemma D' (u v w : E) {x : E} (hx : x ∈ s) (hf : has_ftaylor_series_up_to_on 2 f p s) :
  fderiv ℝ (λ y, ⟪fderiv ℝ f y u, fderiv ℝ f y v⟫) x w =
  ⟪p x 2 ![u, w], fderiv ℝ f x v⟫ +
  ⟪fderiv ℝ f x u, iterated_fderiv ℝ 2 f x ![v, w]⟫ :=
begin
  rw fderiv_inner_apply,
  have : ∀ᶠ (y : E) in 𝓝 x, has_fderiv_at f (fderiv ℝ f y) y :=
  begin
    refine filter.eventually_iff_exists_mem.mpr ⟨s, hs.mem_nhds hx, λ y hy, _⟩,
    convert ((hf.differentiable_on $ with_top.coe_le_coe.mpr one_le_two)
      y hy).has_fderiv_within_at.has_fderiv_at (hs.mem_nhds hy),
    rw fderiv_within_of_open hs hy
  end,
  rw diff_aux,
end

lemma D {u v w : E} {x : E} (hx : x ∈ s) (hf : has_ftaylor_series_up_to_on 2 f p s)
  (huv : ⟪u, v⟫ = 0) (hwu : ⟪w, u⟫ = 0) (hvw : ⟪v, w⟫ = 0) :
  ⟪p x 2 ![u, v], p x 1 ![w]⟫ = 0 :=
begin
  have m₁ := D' u v w hx hf,
  have m₂ := D' v w u hx hf,
  have m₃ := D' w u v hx hf,
  rw add_comm at m₁ m₃,
  nth_rewrite 0 real_inner_comm at m₃ m₁,
  nth_rewrite 1 real_inner_comm at m₁,
end


import Smt.Reconstruction.Defs
import Smt.Reconstruction.Term

open Types
open proof
open term
open sort
open Nat

namespace Rules

theorem refl : ∀ {t : term} {Γ : Environment} {Δ : SEnvironment},
  wellTyped t → validWith Γ Δ (eq t t)
  | t, Γ, Δ, wTt =>
    match r: interpTerm t with
    | some ⟨ atom 0 , _ ⟩               => by simp; rewrite [r]; exact rfl
    | some ⟨ atom 1 , _ ⟩               => by simp; rewrite [r]; exact rfl
    | some ⟨ atom (succ (succ _)) , _ ⟩ => by simp; rewrite [r]; simp; exact rfl
    | some ⟨ sort.undef, _ ⟩            => by simp; rewrite [r]; exact rfl
    | some ⟨ sort.array _ _, _ ⟩        => by simp; rewrite [r]; simp; exact rfl
    | some ⟨ sort.bv _, _ ⟩             => by simp; rewrite [r]; simp; exact rfl
    | some ⟨ sort.arrow _ _, _ ⟩        => by simp; rewrite [r]; simp; exact rfl
    | some ⟨ sort.dep, _ ⟩              => by simp; rewrite [r]; exact rfl
    | none                              => by simp at wTt; rewrite [r] at wTt; exact False.elim wTt

end Rules


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

! This file was ported from Lean 3 source module tactic.ring2
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Ring
import Mathbin.Data.Num.Lemmas
import Mathbin.Data.Tree

/-!
# ring2

An experimental variant on the `ring` tactic that uses computational
reflection instead of proof generation. Useful for kernel benchmarking.
-/

namespace Tree

/-- `(reflect' t u α)` quasiquotes a tree `(t: tree expr)` of quoted
values of type `α` at level `u` into an `expr` which reifies to a `tree α`
containing the reifications of the `expr`s from the original `t`. -/
protected unsafe def reflect' (u : level) (α : expr) : Tree expr → expr
  | Tree.nil => (expr.const `` Tree.nil [u] : expr) α
  | Tree.node a t₁ t₂ => (expr.const `` Tree.node [u] : expr) α a t₁.reflect' t₂.reflect'
#align tree.reflect' tree.reflect'

/-- Returns an element indexed by `n`, or zero if `n` isn't a valid index.
See `tree.get`. -/
protected def getOrZero {α} [Zero α] (t : Tree α) (n : PosNum) : α :=
  t.getD n 0
#align tree.get_or_zero Tree.getOrZero

end Tree

namespace Tactic.Ring2

/-- A reflected/meta representation of an expression in a commutative
semiring. This representation is a direct translation of such
expressions - see `horner_expr` for a normal form. -/
inductive CsringExpr/- (atom n) is an opaque element of the csring. For example,
a local variable in the context. n indexes into a storage
of such atoms - a `tree α`. -/

  | atom : PosNum → csring_expr/- (const n) is technically the csring's one, added n times.
Or the zero if n is 0. -/

  | const : Num → csring_expr
  | add : csring_expr → csring_expr → csring_expr
  | mul : csring_expr → csring_expr → csring_expr
  | pow : csring_expr → Num → csring_expr
  deriving has_reflect
#align tactic.ring2.csring_expr Tactic.Ring2.CsringExpr

namespace CsringExpr

instance : Inhabited CsringExpr :=
  ⟨const 0⟩

/-- Evaluates a reflected `csring_expr` into an element of the
original `comm_semiring` type `α`, retrieving opaque elements
(atoms) from the tree `t`. -/
def eval {α} [CommSemiring α] (t : Tree α) : CsringExpr → α
  | atom n => t.getOrZero n
  | const n => n
  | add x y => eval x + eval y
  | mul x y => eval x * eval y
  | pow x n => eval x ^ (n : ℕ)
#align tactic.ring2.csring_expr.eval Tactic.Ring2.CsringExpr.eval

end CsringExpr

/-- An efficient representation of expressions in a commutative
semiring using the sparse Horner normal form. This type admits
non-optimal instantiations (e.g. `P` can be represented as `P+0+0`),
so to get good performance out of it, care must be taken to maintain
an optimal, *canonical* form. -/
inductive HornerExpr/- (const n) is a constant n in the csring, similarly to the same
constructor in `csring_expr`. This one, however, can be negative. -/

  | const : ZNum → horner_expr/- (horner a x n b) is a*xⁿ + b, where x is the x-th atom
in the atom tree. -/

  | horner : horner_expr → PosNum → Num → horner_expr → horner_expr
  deriving DecidableEq
#align tactic.ring2.horner_expr Tactic.Ring2.HornerExpr

namespace HornerExpr

/-- True iff the `horner_expr` argument is a valid `csring_expr`.
For that to be the case, all its constants must be non-negative. -/
def IsCs : HornerExpr → Prop
  | const n => ∃ m : Num, n = m.toZNum
  | horner a x n b => is_cs a ∧ is_cs b
#align tactic.ring2.horner_expr.is_cs Tactic.Ring2.HornerExpr.IsCs

instance : Zero HornerExpr :=
  ⟨const 0⟩

instance : One HornerExpr :=
  ⟨const 1⟩

instance : Inhabited HornerExpr :=
  ⟨0⟩

/-- Represent a `csring_expr.atom` in Horner form. -/
def atom (n : PosNum) : HornerExpr :=
  horner 1 n 1 0
#align tactic.ring2.horner_expr.atom Tactic.Ring2.HornerExpr.atom

def toString : HornerExpr → String
  | const n => repr n
  | horner a x n b => "(" ++ toString a ++ ") * x" ++ repr x ++ "^" ++ repr n ++ " + " ++ toString b
#align tactic.ring2.horner_expr.to_string Tactic.Ring2.HornerExpr.toString

instance : ToString HornerExpr :=
  ⟨toString⟩

/-- Alternative constructor for (horner a x n b) which maintains canonical
form by simplifying special cases of `a`. -/
def horner' (a : HornerExpr) (x : PosNum) (n : Num) (b : HornerExpr) : HornerExpr :=
  match a with
  | const q => if q = 0 then b else horner a x n b
  | horner a₁ x₁ n₁ b₁ => if x₁ = x ∧ b₁ = 0 then horner a₁ x (n₁ + n) b else horner a x n b
#align tactic.ring2.horner_expr.horner' Tactic.Ring2.HornerExpr.horner'

def addConst (k : ZNum) (e : HornerExpr) : HornerExpr :=
  if k = 0 then e
  else by
    induction' e with n a x n b A B
    · exact const (k + n)
    · exact horner a x n B
#align tactic.ring2.horner_expr.add_const Tactic.Ring2.HornerExpr.addConst

def addAux (a₁ : HornerExpr) (A₁ : HornerExpr → HornerExpr) (x₁ : PosNum) :
    HornerExpr → Num → HornerExpr → (HornerExpr → HornerExpr) → HornerExpr
  | const n₂, n₁, b₁, B₁ => addConst n₂ (horner a₁ x₁ n₁ b₁)
  | horner a₂ x₂ n₂ b₂, n₁, b₁, B₁ =>
    let e₂ := horner a₂ x₂ n₂ b₂
    match PosNum.cmp x₁ x₂ with
    | Ordering.lt => horner a₁ x₁ n₁ (B₁ e₂)
    | Ordering.gt => horner a₂ x₂ n₂ (add_aux b₂ n₁ b₁ B₁)
    | Ordering.eq =>
      match Num.sub' n₁ n₂ with
      | ZNum.zero => horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | ZNum.pos k => horner (add_aux a₂ k 0 id) x₁ n₂ (B₁ b₂)
      | ZNum.neg k => horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
#align tactic.ring2.horner_expr.add_aux Tactic.Ring2.HornerExpr.addAux

def add : HornerExpr → HornerExpr → HornerExpr
  | const n₁, e₂ => addConst n₁ e₂
  | horner a₁ x₁ n₁ b₁, e₂ => addAux a₁ (add a₁) x₁ e₂ n₁ b₁ (add b₁)
#align tactic.ring2.horner_expr.add Tactic.Ring2.HornerExpr.add

/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact add_const n₁ e₂ },
  exact match e₂ with e₂ := begin
    induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁;
    let e₁ := horner a₁ x₁ n₁ b₁,
    { exact add_const n₂ e₁ },
    let e₂ := horner a₂ x₂ n₂ b₂,
    exact match pos_num.cmp x₁ x₂ with
    | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
    | ordering.gt := horner a₂ x₂ n₂ (B₂ n₁ b₁)
    | ordering.eq :=
      match num.sub' n₁ n₂ with
      | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | (znum.pos k) := horner (A₂ k 0) x₁ n₂ (B₁ b₂)
      | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
      end
    end
  end end
end-/
def neg (e : HornerExpr) : HornerExpr :=
  by
  induction' e with n a x n b A B
  · exact const (-n)
  · exact horner A x n B
#align tactic.ring2.horner_expr.neg Tactic.Ring2.HornerExpr.neg

def mulConst (k : ZNum) (e : HornerExpr) : HornerExpr :=
  if k = 0 then 0
  else
    if k = 1 then e
    else by
      induction' e with n a x n b A B
      · exact const (n * k)
      · exact horner A x n B
#align tactic.ring2.horner_expr.mul_const Tactic.Ring2.HornerExpr.mulConst

def mulAux (a₁ x₁ n₁ b₁) (A₁ B₁ : HornerExpr → HornerExpr) : HornerExpr → HornerExpr
  | const n₂ => mulConst n₂ (horner a₁ x₁ n₁ b₁)
  | e₂@(horner a₂ x₂ n₂ b₂) =>
    match PosNum.cmp x₁ x₂ with
    | Ordering.lt => horner (A₁ e₂) x₁ n₁ (B₁ e₂)
    | Ordering.gt => horner (mul_aux a₂) x₂ n₂ (mul_aux b₂)
    | Ordering.eq =>
      let haa := horner' (mul_aux a₂) x₁ n₂ 0
      if b₂ = 0 then haa else haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂))
#align tactic.ring2.horner_expr.mul_aux Tactic.Ring2.HornerExpr.mulAux

def mul : HornerExpr → HornerExpr → HornerExpr
  | const n₁ => mulConst n₁
  | horner a₁ x₁ n₁ b₁ => mulAux a₁ x₁ n₁ b₁ (mul a₁) (mul b₁)
#align tactic.ring2.horner_expr.mul Tactic.Ring2.HornerExpr.mul

/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact mul_const n₁ e₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂;
  let e₁ := horner a₁ x₁ n₁ b₁,
  { exact mul_const n₂ e₁ },
  let e₂ := horner a₂ x₂ n₂ b₂,
  cases pos_num.cmp x₁ x₂,
  { exact horner (A₁ e₂) x₁ n₁ (B₁ e₂) },
  { let haa := horner' A₂ x₁ n₂ 0,
    exact if b₂ = 0 then haa else
      haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂)) },
  { exact horner A₂ x₂ n₂ B₂ }
end-/
instance : Add HornerExpr :=
  ⟨add⟩

instance : Neg HornerExpr :=
  ⟨neg⟩

instance : Mul HornerExpr :=
  ⟨mul⟩

def pow (e : HornerExpr) : Num → HornerExpr
  | 0 => 1
  | Num.pos p => by
    induction' p with p ep p ep
    · exact e
    · exact (ep.mul ep).mul e
    · exact ep.mul ep
#align tactic.ring2.horner_expr.pow Tactic.Ring2.HornerExpr.pow

def inv (e : HornerExpr) : HornerExpr :=
  0
#align tactic.ring2.horner_expr.inv Tactic.Ring2.HornerExpr.inv

/-- Brings expressions into Horner normal form. -/
def ofCsexpr : CsringExpr → HornerExpr
  | csring_expr.atom n => atom n
  | csring_expr.const n => const n.toZNum
  | csring_expr.add x y => (of_csexpr x).add (of_csexpr y)
  | csring_expr.mul x y => (of_csexpr x).mul (of_csexpr y)
  | csring_expr.pow x n => (of_csexpr x).pow n
#align tactic.ring2.horner_expr.of_csexpr Tactic.Ring2.HornerExpr.ofCsexpr

/-- Evaluates a reflected `horner_expr` - see `csring_expr.eval`. -/
def cseval {α} [CommSemiring α] (t : Tree α) : HornerExpr → α
  | const n => n.abs
  | horner a x n b => Tactic.Ring.horner (cseval a) (t.getOrZero x) n (cseval b)
#align tactic.ring2.horner_expr.cseval Tactic.Ring2.HornerExpr.cseval

theorem cseval_atom {α} [CommSemiring α] (t : Tree α) (n : PosNum) :
    (atom n).IsCs ∧ cseval t (atom n) = t.getOrZero n :=
  ⟨⟨⟨1, rfl⟩, ⟨0, rfl⟩⟩, (Tactic.Ring.horner_atom _).symm⟩
#align tactic.ring2.horner_expr.cseval_atom Tactic.Ring2.HornerExpr.cseval_atom

theorem cseval_addConst {α} [CommSemiring α] (t : Tree α) (k : Num) {e : HornerExpr} (cs : e.IsCs) :
    (addConst k.toZNum e).IsCs ∧ cseval t (addConst k.toZNum e) = k + cseval t e :=
  by
  simp [add_const]
  cases k <;> simp! [*]
  simp [show ZNum.pos k ≠ 0 by decide]
  induction' e with n a x n b A B <;> simp [*]
  · rcases cs with ⟨n, rfl⟩
    refine' ⟨⟨n + Num.pos k, by simp [add_comm] <;> rfl⟩, _⟩
    cases n <;> simp!
  · rcases B cs.2 with ⟨csb, h⟩
    simp! [*, cs.1]
    rw [← Tactic.Ring.horner_add_const, add_comm]
    rw [add_comm]
#align tactic.ring2.horner_expr.cseval_add_const Tactic.Ring2.HornerExpr.cseval_addConst

theorem cseval_horner' {α} [CommSemiring α] (t : Tree α) (a x n b) (h₁ : IsCs a) (h₂ : IsCs b) :
    (horner' a x n b).IsCs ∧
      cseval t (horner' a x n b) = Tactic.Ring.horner (cseval t a) (t.getOrZero x) n (cseval t b) :=
  by
  cases' a with n₁ a₁ x₁ n₁ b₁ <;> simp [horner'] <;> split_ifs
  · simp! [*, Tactic.Ring.horner]
  · exact ⟨⟨h₁, h₂⟩, rfl⟩
  · refine' ⟨⟨h₁.1, h₂⟩, Eq.symm _⟩
    simp! [*]
    apply Tactic.Ring.horner_horner
    simp
  · exact ⟨⟨h₁, h₂⟩, rfl⟩
#align tactic.ring2.horner_expr.cseval_horner' Tactic.Ring2.HornerExpr.cseval_horner'

theorem cseval_add {α} [CommSemiring α] (t : Tree α) {e₁ e₂ : HornerExpr} (cs₁ : e₁.IsCs)
    (cs₂ : e₂.IsCs) : (add e₁ e₂).IsCs ∧ cseval t (add e₁ e₂) = cseval t e₁ + cseval t e₂ :=
  by
  induction' e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂ <;> simp!
  · rcases cs₁ with ⟨n₁, rfl⟩
    simpa using cseval_add_const t n₁ cs₂
  induction' e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁
  · rcases cs₂ with ⟨n₂, rfl⟩
    simp! [cseval_add_const t n₂ cs₁, add_comm]
  cases' cs₁ with csa₁ csb₁; cases' id cs₂ with csa₂ csb₂
  simp! ; have C := PosNum.cmp_to_nat x₁ x₂
  cases PosNum.cmp x₁ x₂ <;> simp!
  · rcases B₁ csb₁ cs₂ with ⟨csh, h⟩
    refine' ⟨⟨csa₁, csh⟩, Eq.symm _⟩
    apply Tactic.Ring.horner_add_const
    exact h.symm
  · cases C
    have B0 :
      is_cs 0 →
        ∀ {e₂ : horner_expr},
          is_cs e₂ → is_cs (add 0 e₂) ∧ cseval t (add 0 e₂) = cseval t 0 + cseval t e₂ :=
      fun _ e₂ c => ⟨c, (zero_add _).symm⟩
    cases' e : Num.sub' n₁ n₂ with k k <;> simp!
    · have : n₁ = n₂ := by
        have := congr_arg (coe : ZNum → ℤ) e
        simp at this
        have := sub_eq_zero.1 this
        rw [← Num.to_nat_to_int, ← Num.to_nat_to_int] at this
        exact Num.to_nat_inj.1 (Int.ofNat.inj this)
      subst n₂
      rcases cseval_horner' _ _ _ _ _ _ _ with ⟨csh, h⟩
      · refine' ⟨csh, h.trans (Eq.symm _)⟩
        simp [*]
        apply Tactic.Ring.horner_add_horner_eq <;> try rfl
      all_goals simp! [*]
    · simp [B₁ csb₁ csb₂, add_comm]
      rcases A₂ csa₂ _ _ B0 ⟨csa₁, 0, rfl⟩ with ⟨csh, h⟩
      refine' ⟨csh, Eq.symm _⟩
      rw [show id = add 0 from rfl, h]
      apply Tactic.Ring.horner_add_horner_gt
      · change (_ + k : ℕ) = _
        rw [← Int.coe_nat_inj', Int.ofNat_add, eq_comm, ← sub_eq_iff_eq_add']
        simpa using congr_arg (coe : ZNum → ℤ) e
      · rfl
      · apply add_comm
    · have : (horner a₂ x₁ (Num.pos k) 0).IsCs := ⟨csa₂, 0, rfl⟩
      simp [B₁ csb₁ csb₂, A₁ csa₁ this]
      symm
      apply Tactic.Ring.horner_add_horner_lt
      · change (_ + k : ℕ) = _
        rw [← Int.coe_nat_inj', Int.ofNat_add, eq_comm, ← sub_eq_iff_eq_add', ← neg_inj, neg_sub]
        simpa using congr_arg (coe : ZNum → ℤ) e
      all_goals rfl
  · rcases B₂ csb₂ _ _ B₁ ⟨csa₁, csb₁⟩ with ⟨csh, h⟩
    refine' ⟨⟨csa₂, csh⟩, Eq.symm _⟩
    apply Tactic.Ring.const_add_horner
    simp [h]
#align tactic.ring2.horner_expr.cseval_add Tactic.Ring2.HornerExpr.cseval_add

theorem cseval_mulConst {α} [CommSemiring α] (t : Tree α) (k : Num) {e : HornerExpr} (cs : e.IsCs) :
    (mulConst k.toZNum e).IsCs ∧ cseval t (mulConst k.toZNum e) = cseval t e * k :=
  by
  simp [mul_const]
  split_ifs with h h
  · cases (Num.toZNum_inj.1 h : k = 0)
    exact ⟨⟨0, rfl⟩, (MulZeroClass.mul_zero _).symm⟩
  · cases (Num.toZNum_inj.1 h : k = 1)
    exact ⟨cs, (mul_one _).symm⟩
  induction' e with n a x n b A B <;> simp [*]
  · rcases cs with ⟨n, rfl⟩
    suffices
    refine' ⟨⟨n * k, this⟩, _⟩
    swap
    · cases n <;> cases k <;> rfl
    rw [show _ from this]
    simp!
  · cases cs
    simp! [*]
    symm
    apply Tactic.Ring.horner_mul_const <;> rfl
#align tactic.ring2.horner_expr.cseval_mul_const Tactic.Ring2.HornerExpr.cseval_mulConst

theorem cseval_mul {α} [CommSemiring α] (t : Tree α) {e₁ e₂ : HornerExpr} (cs₁ : e₁.IsCs)
    (cs₂ : e₂.IsCs) : (mul e₁ e₂).IsCs ∧ cseval t (mul e₁ e₂) = cseval t e₁ * cseval t e₂ :=
  by
  induction' e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂ <;> simp!
  · rcases cs₁ with ⟨n₁, rfl⟩
    simpa [mul_comm] using cseval_mul_const t n₁ cs₂
  induction' e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂
  · rcases cs₂ with ⟨n₂, rfl⟩
    simpa! using cseval_mul_const t n₂ cs₁
  cases' cs₁ with csa₁ csb₁; cases' id cs₂ with csa₂ csb₂
  simp! ; have C := PosNum.cmp_to_nat x₁ x₂
  cases' A₂ csa₂ with csA₂ hA₂
  cases PosNum.cmp x₁ x₂ <;> simp!
  · simp [A₁ csa₁ cs₂, B₁ csb₁ cs₂]
    symm
    apply Tactic.Ring.horner_mul_const <;> rfl
  · cases' cseval_horner' t _ x₁ n₂ 0 csA₂ ⟨0, rfl⟩ with csh₁ h₁
    cases C
    split_ifs
    · subst b₂
      refine' ⟨csh₁, h₁.trans (Eq.symm _)⟩
      apply Tactic.Ring.horner_mul_horner_zero <;> try rfl
      simp! [hA₂]
    · cases' A₁ csa₁ csb₂ with csA₁ hA₁
      cases' cseval_add t csh₁ _ with csh₂ h₂
      · refine' ⟨csh₂, h₂.trans (Eq.symm _)⟩
        apply Tactic.Ring.horner_mul_horner <;> try rfl
        simp! [*]
      exact ⟨csA₁, (B₁ csb₁ csb₂).1⟩
  · simp [A₂ csa₂, B₂ csb₂]
    rw [mul_comm, eq_comm]
    apply Tactic.Ring.horner_const_mul
    · apply mul_comm
    · rfl
#align tactic.ring2.horner_expr.cseval_mul Tactic.Ring2.HornerExpr.cseval_mul

theorem cseval_pow {α} [CommSemiring α] (t : Tree α) {x : HornerExpr} (cs : x.IsCs) :
    ∀ n : Num, (pow x n).IsCs ∧ cseval t (pow x n) = cseval t x ^ (n : ℕ)
  | 0 => ⟨⟨1, rfl⟩, (pow_zero _).symm⟩
  | Num.pos p => by
    simp [pow]; induction' p with p ep p ep
    · simp [*]
    · simp [pow_bit1]
      cases' cseval_mul t ep.1 ep.1 with cs₀ h₀
      cases' cseval_mul t cs₀ cs with cs₁ h₁
      simp [*]
    · simp [pow_bit0]
      cases' cseval_mul t ep.1 ep.1 with cs₀ h₀
      simp [*]
#align tactic.ring2.horner_expr.cseval_pow Tactic.Ring2.HornerExpr.cseval_pow

/-- For any given tree `t` of atoms and any reflected expression `r`,
the Horner form of `r` is a valid csring expression, and under `t`,
the Horner form evaluates to the same thing as `r`. -/
theorem cseval_ofCsexpr {α} [CommSemiring α] (t : Tree α) :
    ∀ r : CsringExpr, (ofCsexpr r).IsCs ∧ cseval t (ofCsexpr r) = r.eval t
  | csring_expr.atom n => cseval_atom _ _
  | csring_expr.const n => ⟨⟨n, rfl⟩, by cases n <;> rfl⟩
  | csring_expr.add x y =>
    let ⟨cs₁, h₁⟩ := cseval_of_csexpr x
    let ⟨cs₂, h₂⟩ := cseval_of_csexpr y
    let ⟨cs, h⟩ := cseval_add t cs₁ cs₂
    ⟨cs, by simp! [h, *]⟩
  | csring_expr.mul x y =>
    let ⟨cs₁, h₁⟩ := cseval_of_csexpr x
    let ⟨cs₂, h₂⟩ := cseval_of_csexpr y
    let ⟨cs, h⟩ := cseval_mul t cs₁ cs₂
    ⟨cs, by simp! [h, *]⟩
  | csring_expr.pow x n =>
    let ⟨cs, h⟩ := cseval_of_csexpr x
    let ⟨cs, h⟩ := cseval_pow t cs n
    ⟨cs, by simp! [h, *]⟩
#align tactic.ring2.horner_expr.cseval_of_csexpr Tactic.Ring2.HornerExpr.cseval_ofCsexpr

end HornerExpr

/-- The main proof-by-reflection theorem. Given reflected csring expressions
`r₁` and `r₂` plus a storage `t` of atoms, if both expressions go to the
same Horner normal form, then the original non-reflected expressions are
equal. `H` follows from kernel reduction and is therefore `rfl`. -/
theorem correctness {α} [CommSemiring α] (t : Tree α) (r₁ r₂ : CsringExpr)
    (H : HornerExpr.ofCsexpr r₁ = HornerExpr.ofCsexpr r₂) : r₁.eval t = r₂.eval t := by
  repeat' rw [← (horner_expr.cseval_of_csexpr t _).2] <;> rw [H]
#align tactic.ring2.correctness Tactic.Ring2.correctness

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Reflects a csring expression into a `csring_expr`, together
      with a dlist of atoms, i.e. opaque variables over which the
      expression is a polynomial. -/
    unsafe
  def
    reflect_expr
    : expr → CsringExpr × Dlist expr
    |
        q( $ ( e₁ ) + $ ( e₂ ) )
        =>
        let
          ( r₁ , l₁ ) := reflect_expr e₁
          let ( r₂ , l₂ ) := reflect_expr e₂ ( r₁ . add r₂ , l₁ ++ l₂ )
      |
        q( $ ( e₁ ) * $ ( e₂ ) )
        =>
        let
          ( r₁ , l₁ ) := reflect_expr e₁
          let ( r₂ , l₂ ) := reflect_expr e₂ ( r₁ . mul r₂ , l₁ ++ l₂ )
      |
        e @ q( $ ( e₁ ) ^ $ ( e₂ ) )
        =>
        match
          reflect_expr e₁ , expr.to_nat e₂
          with
          | ( r₁ , l₁ ) , some n₂ => ( r₁ . pow ( Num.ofNat' n₂ ) , l₁ )
            | ( r₁ , l₁ ) , none => ( CsringExpr.atom 1 , Dlist.singleton e )
      |
        e
        =>
        match
          expr.to_nat e
          with
          | some n => ( CsringExpr.const ( Num.ofNat' n ) , Dlist.empty )
            | none => ( CsringExpr.atom 1 , Dlist.singleton e )
#align tactic.ring2.reflect_expr tactic.ring2.reflect_expr

/-- In the output of `reflect_expr`, `atom`s are initialized with incorrect indices.
The indices cannot be computed until the whole tree is built, so another pass over
the expressions is needed - this is what `replace` does. The computation (expressed
in the state monad) fixes up `atom`s to match their positions in the atom tree.
The initial state is a list of all atom occurrences in the goal, left-to-right. -/
unsafe def csring_expr.replace (t : Tree expr) : CsringExpr → StateT (List expr) Option CsringExpr
  | csring_expr.atom _ => do
    let e ← get
    let p ← monadLift (t.indexOfₓ (· < ·) e.headI)
    put e
    pure (csring_expr.atom p)
  | csring_expr.const n => pure (CsringExpr.const n)
  | csring_expr.add x y => CsringExpr.add <$> x.replace <*> y.replace
  | csring_expr.mul x y => CsringExpr.mul <$> x.replace <*> y.replace
  | csring_expr.pow x n => (fun x => CsringExpr.pow x n) <$> x.replace
#align tactic.ring2.csring_expr.replace tactic.ring2.csring_expr.replace

--| (csring_expr.neg x)   := csring_expr.neg <$> x.replace
--| (csring_expr.inv x)   := csring_expr.inv <$> x.replace
end Tactic.Ring2

namespace Tactic

namespace Interactive

open Interactive Interactive.Types Lean.Parser

open Tactic.Ring2

-- mathport name: parser.optional
local postfix:1024 "?" => optional

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `ring2` solves equations in the language of rings.

      It supports only the commutative semiring operations, i.e. it does not normalize subtraction or
      division.

        This variant on the `ring` tactic uses kernel computation instead
        of proof generation. In general, you should use `ring` instead of `ring2`. -/
    unsafe
  def
    ring2
    : tactic Unit
    :=
      do
        sorry
          let
            q( $ ( e₁ ) = $ ( e₂ ) )
              ←
              target
              | fail "ring2 tactic failed: the goal is not an equality"
          let α ← infer_type e₁
          let expr.sort ( level.succ u ) ← infer_type α
          let ( r₁ , l₁ ) := reflect_expr e₁
          let ( r₂ , l₂ ) := reflect_expr e₂
          let L := ( l₁ ++ l₂ ) . toList
          let s := Tree.ofRBNode ( rbtreeOf L ) . 1
          let ( r₁ , L ) ← ( StateT.run ( r₁ . replace s ) L : Option _ )
          let ( r₂ , _ ) ← ( StateT.run ( r₂ . replace s ) L : Option _ )
          let se : expr := s . reflect' u α
          let er₁ : expr := reflect r₁
          let er₂ : expr := reflect r₂
          let cs ← mk_app ` ` CommSemiring [ α ] >>= mk_instance
          let
            e
              ←
              to_expr ` `( correctness $ ( se ) $ ( er₁ ) $ ( er₂ ) rfl )
                <|>
                fail
                  (
                    "ring2 tactic failed, cannot show equality:\n"
                          ++
                          toString ( HornerExpr.ofCsexpr r₁ )
                        ++
                        "\n  =?=\n"
                      ++
                      toString ( HornerExpr.ofCsexpr r₂ )
                    )
          tactic.exact e
#align tactic.interactive.ring2 tactic.interactive.ring2

add_tactic_doc
  { Name := "ring2"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.ring2]
    tags := ["arithmetic", "simplification", "decision procedure"] }

end Interactive

end Tactic

namespace Conv.Interactive

open Conv

unsafe def ring2 : conv Unit :=
  discharge_eq_lhs tactic.interactive.ring2
#align conv.interactive.ring2 conv.interactive.ring2

end Conv.Interactive


import data.equiv.basic

namespace random1

variables {α : Type} [partial_order α] [decidable_eq α] (M : α) (M_is_lb : ∀ a, M ≤ a)

open classical
local attribute [instance] prop_decidable

theorem double_not (p : Prop) : ¬¬p ↔ p :=
  begin
  constructor,
  intro h,
  by_cases a : p, exact a, exfalso, exact h a,
  intro h, intro not_p, exact not_p h,
  end

include M_is_lb
lemma not_gt_equiv_eq : iff (¬ ∃ M', M' > M ∧ ∀ a, M' ≤ a) (¬¬∀ M', (∀ a, M' ≤ a) → M' = M) :=
  begin
  have : ∀ M', (M' > M ∧ ∀ a, M' ≤ a) ↔ ¬ ((∀ a, M' ≤ a) → M' = M),
  {
    intro M',
    constructor,
    {
      intro h,
      intro h',
      apply ne_of_gt h.1,
      exact h' h.2,
    }, {
      intro h,
      by_cases meq : M' = M,
      {
        exfalso, apply h, intro, exact meq,
      }, {
        have : M' > M, exact lt_of_le_of_ne (M_is_lb M') (ne.symm meq),
        constructor, exact this,
        by_cases allfor : ∀ (a : α), M' ≤ a, exact allfor, cc,
      }
    }
  },
  simp only [this],
  transitivity,
  constructor,
  exact forall_not_of_not_exists,
  intro allfor, intro exist,
  apply exists.elim exist,
  intro M', intro h,
  apply allfor M',
  exact h,
  constructor,
  intro h, intro not_h, apply not_h,
  intro M', exact (double_not _).1 (h M'),
  intro h, intro M', intro not_concl,
  apply h, intro concl,
  exact not_concl (concl M'),
  end

end random1

#print equiv

universe u

def eqv (t d : Type u) : Prop := nonempty (t ≃ d)
instance Type.setoid : setoid (Type u) :=
  { r := eqv
  , iseqv := begin
    constructor,
    intro t,
    apply nonempty.intro,
    refl,
    constructor,
    intros t d,
    intro e,
    apply nonempty.elim e, intro e',
    apply nonempty.intro,
    exact equiv.symm e',
    intros t d b,
    intros e o,
    apply nonempty.elim e, intro e',
    apply nonempty.elim o, intro o',
    apply nonempty.intro,
    exact equiv.trans e' o',
    end
  }

def up2iso : Type (u+1) := quotient Type.setoid
def up2iso.mk : Type u → up2iso.{u} := @quotient.mk _ Type.setoid

set_option pp.universes true

lemma bool_eq_unit_sum_unit
  : up2iso.mk bool = up2iso.mk (punit.{1} ⊕ punit.{1})
  := quotient.sound $ nonempty.intro equiv.bool_equiv_unit_sum_unit


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.mean_value
import Mathlib.tactic.monotonicity.default
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Extending differentiability to the boundary

We investigate how differentiable functions inside a set extend to differentiable functions
on the boundary. For this, it suffices that the function and its derivative admit limits there.
A general version of this statement is given in `has_fderiv_at_boundary_of_tendsto_fderiv`.

One-dimensional versions, in which one wants to obtain differentiability at the left endpoint or
the right endpoint of an interval, are given in
`has_deriv_at_interval_left_endpoint_of_tendsto_deriv` and
`has_deriv_at_interval_right_endpoint_of_tendsto_deriv`. These versions are formulated in terms
of the one-dimensional derivative `deriv ℝ f`.
-/

/-- If a function `f` is differentiable in a convex open set and continuous on its closure, and its
derivative converges to a limit `f'` at a point on the boundary, then `f` is differentiable there
with derivative `f'`. -/
theorem has_fderiv_at_boundary_of_tendsto_fderiv {E : Type u_1} [normed_group E] [normed_space ℝ E]
    {F : Type u_2} [normed_group F] [normed_space ℝ F] {f : E → F} {s : set E} {x : E}
    {f' : continuous_linear_map ℝ E F} (f_diff : differentiable_on ℝ f s) (s_conv : convex s)
    (s_open : is_open s) (f_cont : ∀ (y : E), y ∈ closure s → continuous_within_at f s y)
    (h : filter.tendsto (fun (y : E) => fderiv ℝ f y) (nhds_within x s) (nhds f')) :
    has_fderiv_within_at f f' (closure s) x :=
  sorry

/-- If a function is differentiable on the right of a point `a : ℝ`, continuous at `a`, and
its derivative also converges at `a`, then `f` is differentiable on the right at `a`. -/
theorem has_deriv_at_interval_left_endpoint_of_tendsto_deriv {E : Type u_1} [normed_group E]
    [normed_space ℝ E] {s : set ℝ} {e : E} {a : ℝ} {f : ℝ → E} (f_diff : differentiable_on ℝ f s)
    (f_lim : continuous_within_at f s a) (hs : s ∈ nhds_within a (set.Ioi a))
    (f_lim' : filter.tendsto (fun (x : ℝ) => deriv f x) (nhds_within a (set.Ioi a)) (nhds e)) :
    has_deriv_within_at f e (set.Ici a) a :=
  sorry

/-- If a function is differentiable on the left of a point `a : ℝ`, continuous at `a`, and
its derivative also converges at `a`, then `f` is differentiable on the left at `a`. -/
theorem has_deriv_at_interval_right_endpoint_of_tendsto_deriv {E : Type u_1} [normed_group E]
    [normed_space ℝ E] {s : set ℝ} {e : E} {a : ℝ} {f : ℝ → E} (f_diff : differentiable_on ℝ f s)
    (f_lim : continuous_within_at f s a) (hs : s ∈ nhds_within a (set.Iio a))
    (f_lim' : filter.tendsto (fun (x : ℝ) => deriv f x) (nhds_within a (set.Iio a)) (nhds e)) :
    has_deriv_within_at f e (set.Iic a) a :=
  sorry

/-- If a real function `f` has a derivative `g` everywhere but at a point, and `f` and `g` are
continuous at this point, then `g` is also the derivative of `f` at this point. -/
theorem has_deriv_at_of_has_deriv_at_of_ne {E : Type u_1} [normed_group E] [normed_space ℝ E]
    {f : ℝ → E} {g : ℝ → E} {x : ℝ} (f_diff : ∀ (y : ℝ), y ≠ x → has_deriv_at f (g y) y)
    (hf : continuous_at f x) (hg : continuous_at g x) : has_deriv_at f (g x) x :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import data.fintype.order
import order.category.LinearOrder

/-!
# Nonempty finite linear orders

This defines `NonemptyFinLinOrd`, the category of nonempty finite linear orders with monotone maps.
This is the index category for simplicial objects.
-/

universes u v

open category_theory

/-- A typeclass for nonempty finite linear orders. -/
class nonempty_fin_lin_ord (α : Type*) extends fintype α, linear_order α :=
(nonempty : nonempty α . tactic.apply_instance)

attribute [instance] nonempty_fin_lin_ord.nonempty

@[priority 100]
instance nonempty_fin_lin_ord.to_bounded_order (α : Type*) [nonempty_fin_lin_ord α] :
  bounded_order α :=
fintype.to_bounded_order α

instance punit.nonempty_fin_lin_ord : nonempty_fin_lin_ord punit :=
{ .. punit.linear_ordered_cancel_add_comm_monoid,
  .. punit.fintype }

instance fin.nonempty_fin_lin_ord (n : ℕ) : nonempty_fin_lin_ord (fin (n+1)) :=
{ .. fin.fintype _,
  .. fin.linear_order }

instance ulift.nonempty_fin_lin_ord (α : Type u) [nonempty_fin_lin_ord α] :
  nonempty_fin_lin_ord (ulift.{v} α) :=
{ nonempty := ⟨ulift.up ⊥⟩,
  .. linear_order.lift equiv.ulift (equiv.injective _),
  .. ulift.fintype _ }

instance (α : Type*) [nonempty_fin_lin_ord α] : nonempty_fin_lin_ord (order_dual α) :=
{ ..order_dual.fintype α }

/-- The category of nonempty finite linear orders. -/
def NonemptyFinLinOrd := bundled nonempty_fin_lin_ord

namespace NonemptyFinLinOrd

instance : bundled_hom.parent_projection @nonempty_fin_lin_ord.to_linear_order := ⟨⟩

attribute [derive [large_category, concrete_category]] NonemptyFinLinOrd

instance : has_coe_to_sort NonemptyFinLinOrd Type* := bundled.has_coe_to_sort

/-- Construct a bundled `NonemptyFinLinOrd` from the underlying type and typeclass. -/
def of (α : Type*) [nonempty_fin_lin_ord α] : NonemptyFinLinOrd := bundled.of α

instance : inhabited NonemptyFinLinOrd := ⟨of punit⟩

instance (α : NonemptyFinLinOrd) : nonempty_fin_lin_ord α := α.str

instance has_forget_to_LinearOrder : has_forget₂ NonemptyFinLinOrd LinearOrder :=
bundled_hom.forget₂ _ _

/-- Constructs an equivalence between nonempty finite linear orders from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : NonemptyFinLinOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def to_dual : NonemptyFinLinOrd ⥤ NonemptyFinLinOrd :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `FinPartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : NonemptyFinLinOrd ≌ NonemptyFinLinOrd :=
equivalence.mk to_dual to_dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end NonemptyFinLinOrd

lemma NonemptyFinLinOrd_dual_equiv_comp_forget_to_LinearOrder :
  NonemptyFinLinOrd.dual_equiv.functor ⋙ forget₂ NonemptyFinLinOrd LinearOrder
  = forget₂ NonemptyFinLinOrd LinearOrder ⋙ LinearOrder.dual_equiv.functor := rfl


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

These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
eliminate existential quantifiers on the left, and look for contradictions. They rely on ematching
and congruence closure to try to finish off a goal at the end.

The procedures *do* split on disjunctions and recreate the smt state for each terminal call, so
they are only meant to be used on small, straightforward problems.

We provide the following tactics:

  finish  -- solves the goal or fails
  clarify -- makes as much progress as possible while not leaving more than one goal
  safe    -- splits freely, finishes off whatever subgoals it can, and leaves the rest

All accept an optional list of simplifier rules, typically definitions that should be expanded.
(The equations and identities should not refer to the local context.)

The variants ifinish, iclarify, and isafe restrict to intuitionistic logic. They do not work
well with the current heuristic instantiation method used by ematch, so they should be revisited
when the API changes.
-/
import logic.basic

declare_trace auto.done
declare_trace auto.finish

-- TODO(Jeremy): move these

namespace tactic

/- call (assert n t) with a fresh name n. -/
meta def assert_fresh (t : expr) : tactic expr :=
do n ← get_unused_name `h none,
   assert n t

/- call (assertv n t v) with a fresh name n. -/
meta def assertv_fresh (t : expr) (v : expr) : tactic expr :=
do h ← get_unused_name `h none,
   assertv h t v

namespace interactive

meta def revert_all := tactic.revert_all

end interactive

end tactic

open tactic expr

namespace auto

/- Utilities -/

meta def whnf_reducible (e : expr) : tactic expr := whnf e reducible

-- stolen from interactive.lean
meta def add_simps : simp_lemmas → list name → tactic simp_lemmas
| s []      := return s
| s (n::ns) := do s' ← s.add_simp n, add_simps s' ns

/-
  Configuration information for the auto tactics.
-/

structure auto_config : Type :=
(use_simp := tt)           -- call the simplifier
(classical := tt)          -- use classical logic
(max_ematch_rounds := 20)  -- for the "done" tactic

/-
  Preprocess goal.

  We want to move everything to the left of the sequent arrow. For intuitionistic logic,
  we replace the goal p with ∀ f, (p → f) → f and introduce.
-/

theorem by_contradiction_trick (p : Prop) (h : ∀ f : Prop, (p → f) → f) : p :=
h p id

meta def preprocess_goal (cfg : auto_config) : tactic unit :=
do repeat (intro1 >> skip),
   tgt ← target >>= whnf_reducible,
   if (¬ (is_false tgt)) then
     if cfg.classical then
       (mk_mapp ``classical.by_contradiction [some tgt]) >>= apply >> intro1 >> skip
     else
       (mk_mapp ``decidable.by_contradiction [some tgt, none] >>= apply >> intro1 >> skip) <|>
       applyc ``by_contradiction_trick >> intro1 >> intro1 >> skip
   else
     skip

/-
  Normalize hypotheses. Bring conjunctions to the outside (for splitting),
  bring universal quantifiers to the outside (for ematching). The classical normalizer
  eliminates a → b in favor of ¬ a ∨ b.

  For efficiency, we push negations inwards from the top down. (For example, consider
  simplifying ¬ ¬ (p ∨ q).)
-/

section

universe u
variable  {α : Type u}
variables (p q : Prop)
variable  (s : α → Prop)

local attribute [instance] classical.prop_decidable
theorem not_not_eq : (¬ ¬ p) = p := propext not_not
theorem not_and_eq : (¬ (p ∧ q)) = (¬ p ∨ ¬ q) := propext not_and_distrib
theorem not_or_eq : (¬ (p ∨ q)) = (¬ p ∧ ¬ q) := propext not_or_distrib
theorem not_forall_eq : (¬ ∀ x, s x) = (∃ x, ¬ s x) := propext not_forall
theorem not_exists_eq : (¬ ∃ x, s x) = (∀ x, ¬ s x) := propext not_exists
theorem not_implies_eq : (¬ (p → q)) = (p ∧ ¬ q) := propext not_imp

theorem classical.implies_iff_not_or : (p → q) ↔ (¬ p ∨ q) := imp_iff_not_or

end

def common_normalize_lemma_names : list name :=
[``bex_def, ``forall_and_distrib, ``exists_imp_distrib, ``or.assoc, ``or.comm, ``or.left_comm,
  ``and.assoc, ``and.comm, ``and.left_comm]

def classical_normalize_lemma_names : list name :=
common_normalize_lemma_names ++ [``classical.implies_iff_not_or]

-- optionally returns an equivalent expression and proof of equivalence
private meta def transform_negation_step (cfg : auto_config) (e : expr) :
  tactic (option (expr × expr)) :=
do e ← whnf_reducible e,
   match e with
   | `(¬ %%ne) :=
      (do ne ← whnf_reducible ne,
      match ne with
      | `(¬ %%a)      := do pr ← mk_app ``not_not_eq [a],
                            return (some (a, pr))
      | `(%%a ∧ %%b)  := do pr ← mk_app ``not_and_eq [a, b],
                            return (some (`(¬ %%a ∨ ¬ %%b), pr))
      | `(%%a ∨ %%b)  := do pr ← mk_app ``not_or_eq [a, b],
                            return (some (`(¬ %%a ∧ ¬ %%b), pr))
      | `(Exists %%p) := do pr ← mk_app ``not_exists_eq [p],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
      | (pi n bi d p) := if ¬ cfg.classical then return none
                         else if p.has_var then do
                            pr ← mk_app ``not_forall_eq [lam n bi d (expr.abstract_local p n)],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
                         else do
                            pr ← mk_app ``not_implies_eq [d, p],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
      | _             := return none
      end)
    | _        := return none
  end

-- given an expr 'e', returns a new expression and a proof of equality
private meta def transform_negation (cfg : auto_config) : expr → tactic (option (expr × expr)) :=
λ e, do
  opr ← transform_negation_step cfg e,
  match opr with
  | (some (e', pr)) := do
    opr' ← transform_negation e',
    match opr' with
    | none              := return (some (e', pr))
    | (some (e'', pr')) := do pr'' ← mk_eq_trans pr pr',
                              return (some (e'', pr''))
    end
  | none            := return none
  end

meta def normalize_negations (cfg : auto_config) (h : expr) : tactic unit :=
do t ← infer_type h,
   (_, e, pr) ← simplify_top_down ()
                   (λ _, λ e, do
                       oepr ← transform_negation cfg e,
                       match oepr with
                       | (some (e', pr)) := return ((), e', pr)
                       | none            := do pr ← mk_eq_refl e, return ((), e, pr)
                       end)
                   t,
   replace_hyp h e pr,
   skip

meta def normalize_hyp (cfg : auto_config) (simps : simp_lemmas) (h : expr) : tactic unit :=
(do h ← simp_hyp simps [] h, try (normalize_negations cfg h)) <|>
try (normalize_negations cfg h)

meta def normalize_hyps (cfg : auto_config) : tactic unit :=
do simps ← if cfg.classical then
             add_simps simp_lemmas.mk classical_normalize_lemma_names
           else
             add_simps simp_lemmas.mk common_normalize_lemma_names,
   local_context >>= monad.mapm' (normalize_hyp cfg simps)

/-
  Eliminate existential quantifiers.
-/

-- eliminate an existential quantifier if there is one
meta def eelim : tactic unit :=
do ctx ← local_context,
   first $ ctx.map $ λ h,
     do t ← infer_type h >>= whnf_reducible,
        guard (is_app_of t ``Exists),
        tgt ← target,
        to_expr ``(@exists.elim _ _ %%tgt %%h) >>= apply,
        intros,
        clear h

-- eliminate all existential quantifiers, fails if there aren't any
meta def eelims : tactic unit := eelim >> repeat eelim

/-
  Substitute if there is a hypothesis x = t or t = x.
-/

-- carries out a subst if there is one, fails otherwise
meta def do_subst : tactic unit :=
do ctx ← local_context,
   first $ ctx.map $ λ h,
     do t ← infer_type h >>= whnf_reducible,
        match t with
        | `(%%a = %%b) := subst h
        | _            := failed
        end

meta def do_substs : tactic unit := do_subst >> repeat do_subst

/-
  Split all conjunctions.
-/

-- Assumes pr is a proof of t. Adds the consequences of t to the context
-- and returns tt if anything nontrivial has been added.
meta def add_conjuncts : expr → expr → tactic bool :=
λ pr t,
let assert_consequences := λ e t, mcond (add_conjuncts e t) skip (assertv_fresh t e >> skip) in
do t' ← whnf_reducible t,
   match t' with
   | `(%%a ∧ %%b) :=
     do e₁ ← mk_app ``and.left [pr],
        assert_consequences e₁ a,
        e₂ ← mk_app ``and.right [pr],
        assert_consequences e₂ b,
        return tt
  | `(true) :=
     do return tt
  | _ := return ff
end

-- return tt if any progress is made
meta def split_hyp (h : expr) : tactic bool :=
do t ← infer_type h,
   mcond (add_conjuncts h t) (clear h >> return tt) (return ff)

-- return tt if any progress is made
meta def split_hyps_aux : list expr → tactic bool
| []        := return ff
| (h :: hs) := do b₁ ← split_hyp h,
                  b₂ ← split_hyps_aux hs,
                  return (b₁ || b₂)

-- fail if no progress is made
meta def split_hyps : tactic unit := local_context >>= split_hyps_aux >>= guardb

/-
  Eagerly apply all the preprocessing rules.
-/

meta def preprocess_hyps (cfg : auto_config) : tactic unit :=
do repeat (intro1 >> skip),
   preprocess_goal cfg,
   normalize_hyps cfg,
   repeat (do_substs <|> split_hyps <|> eelim /-<|> self_simplify_hyps-/)

/-
  The terminal tactic, used to try to finish off goals:
  - Call the contradiction tactic.
  - Open an SMT state, and use ematching and congruence closure, with all the universal
    statements in the context.

  TODO(Jeremy): allow users to specify attribute for ematching lemmas?
-/

meta def mk_hinst_lemmas : list expr → smt_tactic hinst_lemmas
| []        := -- return hinst_lemmas.mk
               do get_hinst_lemmas_for_attr `ematch
| (h :: hs) := do his ← mk_hinst_lemmas hs,
                  t ← infer_type h,
                  match t with
                  | (pi _ _ _ _) :=
                    do t' ← infer_type t,
                       if t' = `(Prop) then
                          (do new_lemma ← hinst_lemma.mk h,
                             return (hinst_lemmas.add his new_lemma)) <|> return his
                       else return his
                  | _ := return his
                  end

meta def done (cfg : auto_config := {}) : tactic unit :=
do when_tracing `auto.done (trace "entering done" >> trace_state),
   contradiction <|>
   (solve1 $
     (do revert_all,
         using_smt
         (do smt_tactic.intros,
             ctx ← local_context,
             hs ← mk_hinst_lemmas ctx,
             smt_tactic.iterate_at_most cfg.max_ematch_rounds
               (smt_tactic.ematch_using hs >> smt_tactic.try smt_tactic.close))))

/-
  Tactics that perform case splits.
-/

inductive case_option
| force        -- fail unless all goals are solved
| at_most_one  -- leave at most one goal
| accept       -- leave as many goals as necessary

private meta def case_cont (s : case_option) (cont : case_option → tactic unit) : tactic unit :=
do match s with
   | case_option.force := cont case_option.force >> cont case_option.force
   | case_option.at_most_one :=
       -- if the first one succeeds, commit to it, and try the second
       (mcond (cont case_option.force >> return tt) (cont case_option.at_most_one) skip) <|>
       -- otherwise, try the second
       (swap >> cont case_option.force >> cont case_option.at_most_one)
   | case_option.accept := focus [cont case_option.accept, cont case_option.accept]
   end

-- three possible outcomes:
--   finds something to case, the continuations succeed ==> returns tt
--   finds something to case, the continutations fail ==> fails
--   doesn't find anything to case ==> returns ff
meta def case_hyp (h : expr) (s : case_option) (cont : case_option → tactic unit) : tactic bool :=
do t ← infer_type h,
   match t with
   | `(%%a ∨ %%b) := cases h >> case_cont s cont >> return tt
   | _            := return ff
   end

meta def case_some_hyp_aux (s : case_option) (cont : case_option → tactic unit) :
  list expr → tactic bool
| []      := return ff
| (h::hs) := mcond (case_hyp h s cont) (return tt) (case_some_hyp_aux hs)

meta def case_some_hyp (s : case_option) (cont : case_option → tactic unit) : tactic bool :=
local_context >>= case_some_hyp_aux s cont

/-
  The main tactics.
-/

meta def safe_core (s : simp_lemmas × list name) (cfg : auto_config) : case_option → tactic unit :=
λ co, focus1 $
do when_tracing `auto.finish (trace "entering safe_core" >> trace_state),
   if cfg.use_simp then do
     when_tracing `auto.finish (trace "simplifying hypotheses"),
     simp_all s.1 s.2 { fail_if_unchanged := ff },
     when_tracing `auto.finish (trace "result:" >> trace_state)
   else skip,
   tactic.done <|>
   do when_tracing `auto.finish (trace "preprocessing hypotheses"),
      preprocess_hyps cfg,
      when_tracing `auto.finish (trace "result:" >> trace_state),
      done cfg <|>
        (mcond (case_some_hyp co safe_core)
          skip
          (match co with
            | case_option.force       := done cfg
            | case_option.at_most_one := try (done cfg)
            | case_option.accept      := try (done cfg)
            end))

meta def clarify (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  safe_core s cfg case_option.at_most_one
meta def safe (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  safe_core s cfg case_option.accept
meta def finish (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  safe_core s cfg case_option.force

meta def iclarify (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  clarify s {classical := ff, ..cfg}
meta def isafe (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  safe s {classical := ff, ..cfg}
meta def ifinish (s : simp_lemmas × list name) (cfg : auto_config := {}) : tactic unit :=
  finish s {classical := ff, ..cfg}

end auto

/- interactive versions -/

open auto

namespace tactic
namespace interactive

open lean lean.parser interactive interactive.types

local postfix `?`:9001 := optional
local postfix *:9001 := many

meta def clarify (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.clarify s cfg

meta def safe (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.safe s cfg

meta def finish (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.finish s cfg

meta def iclarify (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.iclarify s cfg

meta def isafe (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.isafe s cfg

meta def ifinish (hs : parse simp_arg_list) (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.ifinish s cfg

end interactive
end tactic


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

Completion of topological groups:
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.completion
import Mathlib.topology.algebra.uniform_group
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

protected instance uniform_space.completion.has_zero {α : Type u} [uniform_space α] [HasZero α] : HasZero (uniform_space.completion α) :=
  { zero := ↑0 }

protected instance uniform_space.completion.has_neg {α : Type u} [uniform_space α] [Neg α] : Neg (uniform_space.completion α) :=
  { neg := uniform_space.completion.map fun (a : α) => -a }

protected instance uniform_space.completion.has_add {α : Type u} [uniform_space α] [Add α] : Add (uniform_space.completion α) :=
  { add := uniform_space.completion.map₂ Add.add }

protected instance uniform_space.completion.has_sub {α : Type u} [uniform_space α] [Sub α] : Sub (uniform_space.completion α) :=
  { sub := uniform_space.completion.map₂ Sub.sub }

-- TODO: switch sides once #1103 is fixed

theorem uniform_space.completion.coe_zero {α : Type u} [uniform_space α] [HasZero α] : ↑0 = 0 :=
  rfl

namespace uniform_space.completion

theorem coe_neg {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) : ↑(-a) = -↑a :=
  Eq.symm (map_coe uniform_continuous_neg a)

theorem coe_sub {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) (b : α) : ↑(a - b) = ↑a - ↑b :=
  Eq.symm (map₂_coe_coe a b Sub.sub uniform_continuous_sub)

theorem coe_add {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] (a : α) (b : α) : ↑(a + b) = ↑a + ↑b :=
  Eq.symm (map₂_coe_coe a b Add.add uniform_continuous_add)

protected instance sub_neg_monoid {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : sub_neg_monoid (completion α) :=
  sub_neg_monoid.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub

protected instance add_group {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : add_group (completion α) :=
  add_group.mk sub_neg_monoid.add sorry sub_neg_monoid.zero sorry sorry sub_neg_monoid.neg sub_neg_monoid.sub sorry

protected instance uniform_add_group {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : uniform_add_group (completion α) :=
  uniform_add_group.mk (uniform_continuous_map₂ Sub.sub)

protected instance is_add_group_hom_coe {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] : is_add_group_hom coe :=
  is_add_group_hom.mk

theorem is_add_group_hom_extension {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] {β : Type v} [uniform_space β] [add_group β] [uniform_add_group β] [complete_space β] [separated_space β] {f : α → β} [is_add_group_hom f] (hf : continuous f) : is_add_group_hom (completion.extension f) :=
  (fun (hf : uniform_continuous f) => is_add_group_hom.mk) (uniform_continuous_of_continuous hf)

theorem is_add_group_hom_map {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α] {β : Type v} [uniform_space β] [add_group β] [uniform_add_group β] {f : α → β} [is_add_group_hom f] (hf : continuous f) : is_add_group_hom (completion.map f) :=
  is_add_group_hom_extension (continuous.comp (continuous_coe β) hf)

protected instance add_comm_group {α : Type u} [uniform_space α] [add_comm_group α] [uniform_add_group α] : add_comm_group (completion α) :=
  add_comm_group.mk add_group.add sorry add_group.zero sorry sorry add_group.neg add_group.sub sorry sorry


import topology.algebra.infinite_sum
import analysis.normed_space.basic
import topology.instances.ennreal
import analysis.specific_limits.normed

/- These are lemmas that are used in the proof of either auxilliary facts for Theorem 6.9 or
for Theorem 6.9 directly. -/

open function metric finset nnreal normed_field
open_locale nnreal classical big_operators topological_space

namespace aux_thm69

section group_add_neg
variables {G : Type*} [group G]

/--  If `G` is a group and `g ∈ G` is an element, then `equiv.group_mul g` is the self-equivalence
of `G` defined by `h ↦ g * h`. -/
@[to_additive "If `G` is an additive group and `g ∈ G` is an element, then `equiv.add_group_add g`
is the self-equivalence of `G` defined by `h ↦ g + h`."]
def equiv.group_mul (g : G) : G ≃ G :=
  ⟨λ x, g * x, λ x, g⁻¹ * x, by { intro, simp }, by { intro, simp }⟩

@[simp, to_additive]
lemma equiv.group_mul_apply {g h : G} : equiv.group_mul g h = g * h := rfl

@[simp, to_additive]
lemma equiv.group_mul_symm_apply {g h : G} : (equiv.group_mul g).symm h = g⁻¹ * h := rfl

variables [has_le G] [covariant_class G G ((*)) (≤)]

@[to_additive]
lemma aux_ineq_mul {d e x : G} (hx : d ≤ x) : e ≤ e * d⁻¹ * x :=
calc  e ≤ e * (d⁻¹ * x) : le_mul_of_one_le_right' (le_inv_mul_iff_le.mpr hx)
    ... = e * d⁻¹ * x   : (mul_assoc _ _ _).symm

/--  If `G` is a group and `d e : G`. then `mul_inv_fun d e` is the function mapping
`{x // d ≤ x}` to `{x // e ≤ x}` defined by `x ↦ e * d⁻¹ * x`. -/
@[to_additive "If `G` is an additive group and `d e : G`. then `add_neg_fun d e` is the function
mapping `{x // d ≤ x}` to `{x // e ≤ x}` defined by `x ↦ e + (- d) + x`."]
def mul_inv_fun (d e : G) : {x // d ≤ x} → {x // e ≤ x} :=
λ ⟨x, hx⟩, ⟨_, aux_ineq_mul hx⟩

@[to_additive]
lemma mul_inv_fun_def (d e : G) (z : {x // d ≤ x}) :
  mul_inv_fun d e z = ⟨_, aux_ineq_mul z.2⟩ :=
by { cases z, simp [mul_inv_fun] }

@[simp, to_additive]
lemma mul_inv_fun_comp (d e f : G) : mul_inv_fun e f ∘ mul_inv_fun d e = mul_inv_fun d f :=
by { funext, simp [mul_inv_fun_def, mul_assoc] }

@[simp, to_additive]
lemma mul_inv_fun_comp_id (d e : G) : mul_inv_fun e d ∘ mul_inv_fun d e = id :=
by { funext, simp [mul_inv_fun_def] }

@[simp, to_additive]
lemma mul_inv_fun_comp_id_apply (d e : G) (z : {x // d ≤ x}) :
  mul_inv_fun e d (mul_inv_fun d e z) = z :=
by simp [mul_inv_fun_def, mul_assoc]

/--  The function `mul_inv_fun d e` bundled as an equivalence `{x // d ≤ x} ≃ {x // e ≤ x}`. -/
@[to_additive "The function `add_neg_fun d e` bundled as an equivalence
`{x // d ≤ x} ≃ {x // e ≤ x}`."]
def equiv.mul_inv (d e : G) : {x // d ≤ x} ≃ {x // e ≤ x} :=
{ to_fun    := mul_inv_fun d e,
  inv_fun   := mul_inv_fun e d,
  left_inv  := λ z, by simp,
  right_inv := λ z, by simp }

@[simp, to_additive]
lemma equiv.mul_inv_eval (d e : G) (x : {x // d ≤ x}) :
  equiv.mul_inv d e x = ⟨e * d⁻¹ * x, aux_ineq_mul x.2⟩ :=
by { cases x with x hx, simpa }

@[simp, to_additive]
lemma equiv.mul_inv_rev (d e : G) :
  (equiv.mul_inv d e).symm = equiv.mul_inv e d := rfl

end group_add_neg

/--  The subtype of nonnegative integers is equivalent to the natural numbers. -/
def int_subtype_nonneg_equiv : {x : ℤ // 0 ≤ x} ≃ ℕ :=
{ to_fun := begin
    rintro ⟨x | y, hx⟩,
    { exact x },
    { exact ((int.neg_succ_not_nonneg _).mp hx).elim }
  end,
  inv_fun := λ x, ⟨x, int.coe_zero_le x⟩,
  left_inv := begin
    rintro ⟨x | y, hx⟩,
    { simp only [int.of_nat_eq_coe, subtype.coe_mk] },
    { exact ((int.neg_succ_not_nonneg _).mp hx).elim }
  end,
  right_inv := λ x, rfl }

@[simp]
lemma int_subtype_nonneg_equiv_eval {z : {x : ℤ // 0 ≤ x}} :
  int_subtype_nonneg_equiv z = int.to_nat z :=
begin
  rcases z with ⟨x | y, hz⟩,
  { refl },
  { exact ((int.neg_succ_not_nonneg _).mp hz).elim }
end

@[simp]
lemma int.to_nat_subtype_nonneg {z : {x : ℤ // 0 ≤ x}} :
  ((z : ℤ).to_nat : ℤ) = z :=
begin
  cases z with x hz,
  simp [int.to_nat_of_nonneg hz],
end

@[simp]
lemma int_subtype_nonneg_equiv_symm_eval {n : ℕ} : (int_subtype_nonneg_equiv.symm n : ℤ) = n := rfl

/--  The subtype of nonnegative integers is equivalent to the natural number. -/
def int.nonneg_equiv_nat (d : ℤ) : {x : ℤ // d ≤ x} ≃ ℕ :=
(equiv.add_neg d 0).trans int_subtype_nonneg_equiv

/--  The subtype of nonnegative integers is equivalent to the natural number. -/
def nat.le_equiv_nat (d : ℕ) : {x // d ≤ x} ≃ ℕ :=
{ to_fun    := λ x, x.1 - d,
  inv_fun   := λ x, ⟨x + d, le_add_self⟩,
  left_inv  := by { rintro ⟨x, hx⟩, simp only [nat.sub_add_cancel hx] },
  right_inv := λ x, by simp }

/--  The "identity" is an equivalence between the complement of the set of non-negative integers
and the negative integers. -/
def compl_le : ↥(set_of ((≤) (0 : ℤ)))ᶜ ≃ {z : ℤ // z < 0} :=
{ to_fun    := by { rintro ⟨a, ha⟩, exact ⟨a, by simpa using ha⟩ },
  inv_fun   := by { rintro ⟨a, ha⟩, exact ⟨a, by simpa using ha⟩ },
  left_inv  := by { rintro ⟨a, ha⟩, simp },
  right_inv := by { rintro ⟨a, ha⟩, simp } }

@[simp]
lemma compl_le_symm_eval {x : {z : ℤ // z < 0}} :
  (compl_le.symm x : ℤ) = x :=
by { cases x with x hx, refl }

section group
variables (α : Type*)

section one_lt
variables [group α] [has_lt α] [covariant_class α α (*) (<)]

/--  Taking inverses establishes an isomorphism between the elements of a group that are
strictly smaller than `1` with the elements that are strictly larger than `1`. -/
@[to_additive "Taking opposites establishes an isomorphism between the elements of an additive
group that are strictly smaller than `0` with the elements that are strictly larger than `0`."]
def equiv.lt_one_gt_one : {z : α | z < 1} ≃ {z : α | 1 < z} :=
{ to_fun    := by { rintro ⟨z, hz⟩, exact ⟨z⁻¹, by simpa⟩ },
  inv_fun   := by { rintro ⟨z, hz⟩, exact ⟨z⁻¹, by simpa⟩ },
  left_inv  := by { rintro ⟨z, hz⟩, simp },
  right_inv := by { rintro ⟨z, hz⟩, simp } }

variable {α}
@[simp, to_additive]
lemma equiv.lt_one_gt_one_eval {x : {z : α | z < 1}} :
  ((equiv.lt_one_gt_one α) x : α) = x⁻¹ :=
by { cases x with x hx, refl }

@[simp, to_additive]
lemma equiv.lt_one_gt_one_symm_eval {x : {z : α | 1 < z}} :
  ((equiv.lt_one_gt_one α).symm x : α) = x⁻¹ :=
by { cases x with x hx, refl }

end one_lt

section one_le
variables [group α] [has_le α] [covariant_class α α (*) (≤)]

/--  Taking inverses establishes an isomorphism between the elements of a group that are
at most `1` with the elements that are at least `1`. -/
@[to_additive "Taking opposites establishes an isomorphism between the elements of an additive
group that are strictly at most `0` with the elements that are at least `0`."]
def equiv.le_one_ge_one : {z : α | z ≤ 1} ≃ {z : α | 1 ≤ z} :=
{ to_fun    := by { rintro ⟨z, hz⟩, exact ⟨z⁻¹, by simpa⟩ },
  inv_fun   := by { rintro ⟨z, hz⟩, exact ⟨z⁻¹, by simpa⟩ },
  left_inv  := by { rintro ⟨z, hz⟩, simp },
  right_inv := by { rintro ⟨z, hz⟩, simp } }

variable {α}

@[simp, to_additive]
lemma equiv.le_one_ge_one_eval {x : {z : α | z ≤ 1}} :
  ((equiv.le_one_ge_one α) x : α) = x⁻¹ :=
by { cases x with x hx, refl }

@[simp, to_additive]
lemma equiv.le_one_ge_one_symm_eval {x : {z : α | 1 ≤ z}} :
  ((equiv.le_one_ge_one α).symm x : α) = x⁻¹ :=
by { cases x with x hx, refl }

end one_le

end group

/--  An equivalence between the complement of the non-negative integers and the natural numbers. -/
def oppo : ({z : ℤ | 0 ≤ z}ᶜ : set ℤ) ≃ ℕ :=
compl_le.trans $ (equiv.neg_gt_zero ℤ).trans $ (equiv.add_neg 1 0).trans int_subtype_nonneg_equiv

@[simp]
lemma oppo_symm_eval {n : ℕ} : (oppo.symm n : ℤ) = - n - 1 :=
by simp [oppo]

section topological_space
variables {α : Type*} [topological_space α]

section add_comm_monoid
variables [add_comm_monoid α] {f : ℤ → α}

lemma my_summable_shift (f : ℤ → α) (N : ℤ) :
  summable (λ x : ℕ, f (x + N)) ↔ summable (λ x : {x // N ≤ x}, f x) :=
begin
  convert (int_subtype_nonneg_equiv.symm.trans (equiv.add_neg 0 N)).summable_iff,
  ext,
  simp [add_comm],
end

end add_comm_monoid

end topological_space

section uniform
variables {α : Type*} [uniform_space α] [add_comm_group α] [uniform_add_group α] [complete_space α]
variable {f : ℤ → α}

lemma int_summable_iff :
  summable f ↔ summable (λ n : ℕ, f n) ∧ summable (λ n : ℕ, f (- n - 1)) :=
begin
  refine (@summable_subtype_and_compl α _ _ _ _ _ _ {z : ℤ | 0 ≤ z}).symm.trans _,
  rw [← equiv.summable_iff int_subtype_nonneg_equiv, ← equiv.summable_iff oppo.symm],
  refine ⟨_, _⟩;
  rintro ⟨h1, h2⟩;
  refine ⟨_, _⟩;
  refine summable.congr ‹_› (λ b, _);
  simp only [oppo_symm_eval, int_subtype_nonneg_equiv_eval, function.comp_app];
  { apply congr_arg, simp [b.2] }
end

end uniform

lemma _root_.summable.smaller_radius {f : ℕ → ℝ} {ρ σ : ℝ≥0}
  (hf : summable (λ n, f n * ρ ^ n)) (σρ : σ ≤ ρ) (f0 : ∀ n, 0 ≤ f n) :
  summable (λ n, f n * σ ^ n) :=
begin
  refine summable_of_nonneg_of_le (λ b, mul_nonneg (f0 _) (pow_nonneg zero_le_coe _)) _ hf,
  exact λ b, mul_le_mul rfl.le
    (pow_le_pow_of_le_left zero_le_coe σρ b) (pow_nonneg zero_le_coe b) (f0 b)
end

/--  A technical equivalence, useful in the proof of `prod_nat_summable_1`. -/
def equiv_nat_diag : {x : ℕ × ℕ // x.2 ≤ x.1} ≃ ℕ × ℕ :=
{ to_fun    := λ x, (x.1.1 - x.1.2, x.1.2 ),
  inv_fun   := λ x, ⟨(x.1 + x.2, x.2), by simp⟩,
  left_inv  := by { rintros ⟨x, hx⟩, simp only [nat.sub_add_cancel hx, prod.mk.eta] },
  right_inv := by { rintros ⟨x, y⟩, simp only [add_tsub_cancel_right] } }

lemma _root_.summable.prod_nat {f : ℤ → ℝ} {g : ℕ → ℝ} (hf : summable f) (f0 : ∀ n, 0 ≤ f n)
  (hg : summable g) (g0 : ∀ n, 0 ≤ g n) :
  summable (λ lj: ℕ × ℕ, f (lj.fst + lj.snd) * g lj.snd) :=
begin
  apply (equiv.summable_iff equiv_nat_diag).mp,
  suffices : summable (λ (lj : {x : ℕ × ℕ // x.2 ≤ x.1}), f lj.1.fst * g lj.1.snd),
  { convert this,
    ext ⟨⟨x, y⟩, hx⟩,
    suffices : f (↑(x - y) + ↑y) * g y = f ↑x * g y, by simpa [equiv_nat_diag],
    rw_mod_cast nat.sub_add_cancel hx },
  apply summable.subtype (_ : summable (λ (lj : ℕ × ℕ), f lj.fst * g lj.snd)),
  convert summable_mul_of_summable_norm (_ : summable (λ i : ℕ, ∥f i∥)) _,
  { conv { congr, funext, rw [real.norm_of_nonneg (f0 _)] },
    apply ((int_summable_iff).mp hf).1 },
  { conv { congr, funext, rw [real.norm_of_nonneg (g0 _)] },
    exact hg }
end

lemma prod_nat_summable_aux {f : ℤ → ℝ} {s r : ℝ≥0}
  (s1 : s < 1) (hf : summable (λ n : ℤ, ∥ f n ∥ * r ^ n)) :
  summable (λ lj: ℕ × ℕ, ∥(f (lj.fst + 1 + lj.snd)) * r ^ (lj.fst + 1 + lj.snd)∥ * s^ lj.snd) :=
begin
  apply summable_of_summable_norm,
  simp_rw [norm_mul, norm_norm],
  convert (_ : summable (λ n, ∥f (n + 1)∥ * r ^ (n + 1))).prod_nat _ (by simpa) (pow_nonneg s.2),
  { simpa only [norm_pow, norm_eq, val_eq_coe, add_right_comm _ (1 : ℤ), add_right_comm _ 1 _] },
  { let add_one : ℤ ≃ ℤ := ⟨λ x, x - 1, λ x, x + 1, λ x, by simp, λ x, by simp⟩,
    apply add_one.summable_iff.mp,
    convert hf,
    ext,
    simp },
  { exact λ n, mul_nonneg (norm_nonneg _) (zpow_nonneg r.2 _) },
end

end aux_thm69


import Smt

theorem modus_ponens (p q : Bool) : p → (p → q) → q := by
  smt
  simp_all


lemma contrapositive (P Q : Prop) : (P → Q) → (¬ Q → ¬ P) :=
begin
repeat {rw not_iff_imp_false},
intros a b c,
exact b(a(c)),
end


import category_theory.category
import category_theory.colimits
import category_theory.colimit_lemmas
import category_theory.types

import .homeomorphism
import .subspace

open set

open category_theory
local notation f ` ∘ `:80 g:80 := g ≫ f

universe u

namespace homotopy_theory.topological_spaces

namespace Set
local notation `Set` := Type u

def mk_ob (α : Set) : Set := α

def incl' {α : Set} (A B : set α) (h : A ⊆ B) : mk_ob A ⟶ mk_ob B :=
λ p, ⟨p.val, h p.property⟩

section inter_union
variables {X : Set} {A₀ A₁ : set X}

local notation `A₀₁` := A₀ ∩ A₁
local notation `A` := (A₀ ∪ A₁ : set X)

local notation `i₀` := incl' A₀₁ A₀ (set.inter_subset_left A₀ A₁)
local notation `i₁` := incl' A₀₁ A₁ (set.inter_subset_right A₀ A₁)
local notation `j₀` := incl' A₀ A (set.subset_union_left A₀ A₁)
local notation `j₁` := incl' A₁ A (set.subset_union_right A₀ A₁)

section glue
variables ⦃β : Set⦄ (h₀ : mk_ob A₀ ⟶ β) (h₁ : mk_ob A₁ ⟶ β)
variable (e : h₀ ∘ i₀ = h₁ ∘ i₁)
include e

local attribute [instance] classical.prop_decidable

noncomputable def glue : mk_ob A ⟶ β :=
λ a, if h : a.val ∈ A₀ then h₀ ⟨a.val, h⟩ else h₁ ⟨a.val, a.property.resolve_left h⟩

lemma glue_commutes₀ : glue h₀ h₁ e ∘ j₀ = h₀ :=
by funext a; have := a.property; simp [glue, incl', this]

lemma glue_commutes₁ : glue h₀ h₁ e ∘ j₁ = h₁ :=
begin
  funext a, change (if h : _ then _ else _) = h₁ a, cases a with v p,
  split_ifs, { exact congr_fun e ⟨v, h, p⟩ }, { refl }
end

end glue

lemma uniqueness ⦃β : Set⦄ (k k' : mk_ob A ⟶ β)
  (e₀ : k ∘ j₀ = k' ∘ j₀) (e₁ : k ∘ j₁ = k' ∘ j₁) : k = k' :=
begin
  funext a, rcases a with ⟨v, p₀|p₁⟩,
  { exact @@congr_fun _ _ _ e₀ ⟨v, p₀⟩ },
  { exact @@congr_fun _ _ _ e₁ ⟨v, p₁⟩ }
end

variables (A₀ A₁)
include A₀ A₁
noncomputable def Is_pushout_inter_union : Is_pushout i₀ i₁ j₀ j₁ :=
Is_pushout.mk' rfl glue glue_commutes₀ glue_commutes₁ uniqueness

end inter_union

end «Set»

namespace Top
local notation `Top` := Top.{u}

section inter_union
variables {X : Top} {A₀ A₁ : set X} (ha₀ : is_closed A₀) (ha₁ : is_closed A₁)
-- Other assumptions are possible, e.g., A₀, A₁ both open.

local notation `A₀₁` := A₀ ∩ A₁
local notation `A` := (A₀ ∪ A₁ : set X)

local notation `i₀` := incl' A₀₁ A₀ (set.inter_subset_left A₀ A₁)
local notation `i₁` := incl' A₀₁ A₁ (set.inter_subset_right A₀ A₁)
local notation `j₀` := incl' A₀ A (set.subset_union_left A₀ A₁)
local notation `j₁` := incl' A₁ A (set.subset_union_right A₀ A₁)
local notation `i'₀` := Set.incl' A₀₁ A₀ (set.inter_subset_left A₀ A₁)
local notation `i'₁` := Set.incl' A₀₁ A₁ (set.inter_subset_right A₀ A₁)
local notation `j'₀` := Set.incl' A₀ A (set.subset_union_left A₀ A₁)
local notation `j'₁` := Set.incl' A₁ A (set.subset_union_right A₀ A₁)

local notation [parsing_only] a ` ~~ ` b := Bij_on _ a b

instance Set.mk_ob.topological_space (α : Type*) [t : topological_space α] :
  topological_space (Set.mk_ob α) := t

lemma continuous_iff {Z : Top} (k : A → Z) :
  continuous k ↔ continuous (k ∘ j'₀) ∧ continuous (k ∘ j'₁) :=
iff.intro (assume h, ⟨by continuity!, by continuity!⟩)
  (assume ⟨h₀, h₁⟩,
    let c : bool → set A := λ i, bool.rec_on i {a | a.val ∈ A₀} {a | a.val ∈ A₁} in
    have h_lf : locally_finite c :=
      locally_finite_of_finite ⟨fintype.of_equiv _ (equiv.set.univ bool).symm⟩,
    have h_is_closed : ∀ i, is_closed (c i) :=
      assume i, bool.rec_on i
        (continuous_iff_is_closed.mp continuous_subtype_val _ ha₀)
        (continuous_iff_is_closed.mp continuous_subtype_val _ ha₁),
    have h_cover : ∀ a, ∃ i, a ∈ c i :=
      assume a, a.property.elim (λ h, ⟨ff, h⟩) (λ h, ⟨tt, h⟩),
    have f_cont : ∀ i, continuous (λ (x : subtype (c i)), k x.val) :=
      assume i, bool.rec_on i
        (have continuous (function.comp (k ∘ j'₀) (λ (x : subtype (c ff)), ⟨x.val.val, x.property⟩)),
          by continuity, begin convert this, funext x, rcases x with ⟨⟨_, _⟩, _⟩, refl end)
        (have continuous (function.comp (k ∘ j'₁) (λ (x : subtype (c tt)), ⟨x.val.val, x.property⟩)),
          by continuity, begin convert this, funext x, rcases x with ⟨⟨_, _⟩, _⟩, refl end),
    continuous_subtype_is_closed_cover c h_lf h_is_closed h_cover f_cont)

variables (A₀ A₁)
include A₀ A₁
noncomputable def Is_pushout_inter_union : Is_pushout i₀ i₁ j₀ j₁ :=
Is_pushout.mk $ λ Z, calc
  univ ~~ {k : {k : A → Z // continuous k} | true}
       : Bij_on.of_equiv (Top.hom_equiv_subtype (Top.mk_ob A) Z)
   ... ~~ {k : {k : A → Z // continuous (k ∘ j'₀) ∧ continuous (k ∘ j'₁)} | true}
       : Bij_on.congr_subtype (ext (continuous_iff ha₀ ha₁))
   ... ~~ {p : {p : (A₀ → Z) × (A₁ → Z) // continuous p.1 ∧ continuous p.2} | p.val.1 ∘ i'₀ = p.val.2 ∘ i'₁}
       : ((Set.Is_pushout_inter_union A₀ A₁).universal Z).restrict_to_subtype (λ p, continuous p.1 ∧ continuous p.2)
   ... ~~ {p : {f₀ : Top.mk_ob A₀ → Z // continuous f₀} ×
               {f₁ : Top.mk_ob A₁ → Z // continuous f₁} |
           (Top.hom_equiv_subtype _ _).symm p.1 ∘ i₀ = (Top.hom_equiv_subtype _ _).symm p.2 ∘ i₁}
       : by { convert Bij_on.restrict_equiv equiv.subtype_prod_subtype_equiv_subtype.symm _,
              ext, simp only [Top.hom_eq2], refl }
   ... ~~ {p : (Top.mk_ob A₀ ⟶ Z) × (Top.mk_ob A₁ ⟶ Z) | p.1 ∘ i₀ = p.2 ∘ i₁}
       : by {
           convert Bij_on.restrict_equiv
             ((Top.hom_equiv_subtype (Top.mk_ob A₀) Z).prod_congr
              (Top.hom_equiv_subtype (Top.mk_ob A₁) Z)).symm
             _,
           ext ⟨_, _⟩, refl }

local notation `k₀` := incl A₀
local notation `k₁` := incl A₁
variables (h : A₀ ∪ A₁ = univ)

include h
def union_is_X : homeomorphism (Top.mk_ob A) X :=
{ hom := incl _,
  inv := Top.mk_hom (λ x, ⟨x, by rw h; exact trivial⟩) (by continuity),
  hom_inv_id' := by ext p; cases p; refl,
  inv_hom_id' := by ext p; refl }

noncomputable def Is_pushout_inter_of_cover : Is_pushout i₀ i₁ k₀ k₁ :=
Is_pushout_of_isomorphic'
  (Is_pushout_inter_union A₀ A₁ ha₀ ha₁) (union_is_X A₀ A₁ h)

end inter_union

end «Top»

end homotopy_theory.topological_spaces


/- This defines an hmac primitive.
 -/
import galois.word
import galois.tactic.nat
import galois.bitvec.join
import galois.crypto.sha2

namespace crypto

definition hmac {olen : ℕ} -- ^ Output length
                (blen : ℕ) -- ^ Block length
                (hash : list byte → vector byte olen)
                (key : list byte)
                (msg : list byte)
                : vector byte olen :=
  let klen := list.length key in
  let padded_key :=
        if blen ≥ klen then
          key ++ list.repeat 0 (blen - klen)
        else
          key ++ list.repeat 0 (blen - olen) in
  let ki := list.map (bitvec.xor 54) padded_key in
  let ko := list.map (bitvec.xor 92) padded_key in
  hash (ko ++ (hash (ki ++ msg))^.to_list)

end crypto

namespace hmac

/- hash_algorithm -/

inductive hash_algorithm
  | sha1      : hash_algorithm
  | sha2_256  : hash_algorithm
  | ripemd160 : hash_algorithm
  | sha2_224  : hash_algorithm
  | sha2_384  : hash_algorithm
  | sha2_512  : hash_algorithm
  | sha3_224  : hash_algorithm
  | sha3_256  : hash_algorithm
  | sha3_384  : hash_algorithm
  | sha3_512  : hash_algorithm
  | sm3       : hash_algorithm

namespace hash_algorithm

protected def to_string : hash_algorithm → string
| sha1 := "sha1"
| sha2_256 := "sha2_256"
| ripemd160 := "ripemd160"
| sha2_224 := "sha2_224"
| sha2_384 := "sha2_384"
| sha2_512 := "sha2_512"
| sha3_224 := "sha3_224"
| sha3_256 := "sha3_256"
| sha3_384 := "sha3_384"
| sha3_512 := "sha3_512"
| sm3      := "sm3"

instance : has_to_string hash_algorithm := ⟨ hash_algorithm.to_string ⟩

/- hash length in bytes -/
definition hash_length : hash_algorithm → ℕ
  | sha1      := 20
  | sha2_256  := 32
  | ripemd160 := 20
  | sha2_224  := 28
  | sha2_384  := 48
  | sha2_512  := 64
  | sha3_224  := 28
  | sha3_256  := 32
  | sha3_384  := 48
  | sha3_512  := 64
  | sm3       := 32

lemma max_hash_length (algo : hash_algorithm) : algo.hash_length ≤ 64 :=
begin
  cases algo,
  all_goals { dunfold hash_length },
  all_goals { galois.tactic.nat.nat_lit_le },
end

/- block length in bytes -/
definition block_length (algo : hash_algorithm) : ℕ :=
  match algo with
  | sha1      :=  64
  | sha2_256  :=  64
  | ripemd160 :=  64
  | sha2_224  :=  64
  | sha2_384  := 128
  | sha2_512  := 128
  | sha3_224  := 144
  | sha3_256  := 136
  | sha3_384  := 104
  | sha3_512  :=  72
  | sm3       :=  64
  end

definition encode (algo : hash_algorithm) : byte :=
  match algo with
  | sha1      := 0x0
  | sha2_256  := 0x1
  | ripemd160 := 0x2
  | sha2_224  := 0x3
  | sha2_384  := 0x4
  | sha2_512  := 0x5
  | sha3_224  := 0x7
  | sha3_256  := 0x8
  | sha3_384  := 0x9
  | sha3_512  := 0xA
  | sm3       := 0xB
  end

definition decode (w : byte) : option hash_algorithm :=
  if w = 0x0 then
    some sha1
  else if w = 0x1 then
    some sha2_256
  else if w = 0x2 then
    some ripemd160
  else if w = 0x3 then
    some sha2_224
  else if w = 0x4 then
    some sha2_384
  else if w = 0x5 then
    some sha2_512
  else if w = 0x7 then
    some sha3_224
  else if w = 0x8 then
    some sha3_256
  else if w = 0x9 then
    some sha3_384
  else if w = 0xA then
    some sha3_512
  else if w = 0xB then
    some sm3
  else
    none

@[simp]
lemma decode_encode (a : hash_algorithm) : decode (encode a) = some a :=
begin
  cases a,
  simp [encode, decode],
  all_goals {
    simp [encode, decode],
    smt_tactic.execute smt_tactic.solve_goals
  }
end

instance : decidable_eq hash_algorithm := by tactic.mk_dec_eq_instance

------------------------------------------------------------------------
-- hash

-- | Helper function to speed up length proofs below
def to_byte_list (m : ℕ) (v : bitvec (8 * m)) : list byte := cast rfl (@bitvec.split_vector 8 m v)

protected
lemma length_to_byte_list (m : ℕ) (v : bitvec (8 * m)) : (to_byte_list m v).length = m :=
vector.length_split_vector _ _

def nat_224_decompose : bitvec 224 → list byte := @to_byte_list 28
def nat_256_decompose : bitvec 256 → list byte := @to_byte_list 32
def nat_384_decompose : bitvec 384 → list byte := @to_byte_list 48
def nat_512_decompose : bitvec 512 → list byte := @to_byte_list 64

definition hash : hash_algorithm → list byte → list byte
| sha2_256  data := nat_256_decompose (crypto.sha256 data)
| sha2_224  data := nat_224_decompose (crypto.sha224 data)
| sha2_384  data := nat_384_decompose (crypto.sha384 data)
| sha2_512  data := nat_512_decompose (crypto.sha512 data)
| algo data := list.repeat 0 (algo.hash_length)

theorem length_hash_is_hash_length
: ∀ (algo : hash_algorithm) (data : list byte),
    (algo.hash data).length = algo.hash_length
| sha1      data := list.length_repeat _ _
| sha2_256  data := hash_algorithm.length_to_byte_list _ _
| ripemd160 data := list.length_repeat _ _
| sha2_224  data := hash_algorithm.length_to_byte_list _ _
| sha2_384  data := hash_algorithm.length_to_byte_list _ _
| sha2_512  data := hash_algorithm.length_to_byte_list _ _
| sha3_224  data := list.length_repeat _ _
| sha3_256  data := list.length_repeat _ _
| sha3_384  data := list.length_repeat _ _
| sha3_512  data := list.length_repeat _ _
| sm3       data := list.length_repeat _ _

-- Hash the data using the given algorithm.
definition hashv (algo : hash_algorithm) (data : list byte) : vector byte algo.hash_length :=
  ⟨ hash algo data, length_hash_is_hash_length algo data ⟩

end hash_algorithm

end hmac


import Runtime.Network.Graph.Path.Subpaths

namespace Network.Graph.Path

def Succ (path₁ path₂ : Path graph start) :=
  path₁.prefix? = path₂

infix:35 " ≻ " => Succ

theorem Succ.isCons : (path₁ ≻ path₂) → path₁.isCons :=
  fun h => prefix?_isSome_iff_isCons.mp (Option.isSome_iff_exists.mpr ⟨_, h⟩)

theorem Succ.isCons' : (cons c₁ (cons c₂ path₁) ≻ path₂) → path₂.isCons := by
  intro h
  have ⟨subpath, hp⟩ := prefix?_isSome_iff_isCons.mpr (@isCons_of_cons _ _ c₂ path₁) |> Option.isSome_iff_exists.mp
  simp [Succ, prefix?, hp] at h
  simp [isCons_def]
  exists c₁, subpath
  injection h with h
  exact h.symm

theorem Succ.iff_cons_Succ {path₁ path₂} :
  (path₁ ≻ path₂) ↔ (cons child path₁) ≻ (cons child path₂) :=
  prefix?_iff_cons_prefix?

theorem Succ.nil : (cons child nil) ≻ nil := rfl

instance : Decidable (path₁ ≻ path₂) :=
  if h : path₁.prefix? = path₂ then isTrue h else isFalse h

theorem Succ.cons (path₁) : ∃ path₂, (cons child path₁) ≻ path₂ := by
  cases h : (Path.cons child path₁).prefix?
  case none =>
    have h : ¬(Path.cons child path₁).prefix?.isSome := by simp_all [Option.isSome_iff_exists]
    have := mt prefix?_isSome_iff_isCons.mpr h
    contradiction
  case some pre => exists pre

end Network.Graph.Path


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.homology.image_to_kernel_map

/-!
# Exact sequences

In a category with zero morphisms, images, and equalizers we say that `f : A ⟶ B` and `g : B ⟶ C`
are exact if `f ≫ g = 0` and the natural map `image f ⟶ kernel g` is an epimorphism.

This definition is equivalent to the homology at `B` vanishing (at least for preadditive
categories). At this level of generality, this is not necessarily equivalent to other reasonable
definitions of exactness, for example that the inclusion map `image.ι f` is a kernel of `g` or that
the map `image f ⟶ kernel g` is an isomorphism. By adding more assumptions on our category, we get
these equivalences and more. Currently, there is one particular set of assumptions mathlib knows
about: abelian categories. Consequently, many interesting results about exact sequences are found in
`category_theory/abelian/exact.lean`.

# Main results
* Suppose that cokernels exist and that `f` and `g` are exact. If `s` is any kernel fork over `g`
  and `t` is any cokernel cofork over `f`, then `fork.ι s ≫ cofork.π t = 0`.
* Precomposing the first morphism with an epimorphism retains exactness. Postcomposing the second
  morphism with a monomorphism retains exactness.
* If `f` and `g` are exact and `i` is an isomorphism, then `f ≫ i.hom` and `i.inv ≫ g` are also
  exact.

# Future work
* Short exact sequences, split exact sequences, the splitting lemma (maybe only for abelian
  categories?)
* Two adjacent maps in a chain complex are exact iff the homology vanishes

-/

universes v u

open category_theory
open category_theory.limits

variables {V : Type u} [category.{v} V] [has_zero_morphisms V]
variables [has_equalizers V] [has_images V]

namespace category_theory

/-- Two morphisms `f : A ⟶ B`, `g : B ⟶ C` are called exact if `f ≫ g = 0` and the natural map
    `image f ⟶ kernel g` is an epimorphism. -/
class exact {A B C : V} (f : A ⟶ B) (g : B ⟶ C) : Prop :=
(w : f ≫ g = 0)
(epi : epi (image_to_kernel_map f g w))

attribute [instance] exact.epi
attribute [simp, reassoc] exact.w

section
variables {A B C D : V} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}

lemma exact_comp_hom_inv_comp [exact f g] (i : B ≅ D) : exact (f ≫ i.hom) (i.inv ≫ g) :=
begin
  refine ⟨by simp, _⟩,
  rw image_to_kernel_map_comp_hom_inv_comp,
  haveI : epi (image_to_kernel_map f g exact.w ≫ (kernel_is_iso_comp i.inv g).inv) := epi_comp _ _,
  exact epi_comp _ _
end

lemma exact_comp_hom_inv_comp_iff (i : B ≅ D) : exact (f ≫ i.hom) (i.inv ≫ g) ↔ exact f g :=
begin
  refine ⟨_, by { introI, exact exact_comp_hom_inv_comp i }⟩,
  introI,
  have : exact ((f ≫ i.hom) ≫ i.inv) (i.hom ≫ i.inv ≫ g) := exact_comp_hom_inv_comp i.symm,
  simpa using this
end

lemma exact_epi_comp [exact g h] [epi f] : exact (f ≫ g) h :=
begin
  refine ⟨by simp, _⟩,
  rw image_to_kernel_map_comp_left,
  suffices : epi (image.pre_comp f g),
  { exactI epi_comp _ _ },
  apply epi_of_epi_fac (limits.image.factor_thru_image_pre_comp _ _),
  exact epi_comp _ _
end

lemma exact_comp_mono [exact f g] [mono h] : exact f (g ≫ h) :=
begin
  refine ⟨by simp, _⟩,
  letI : is_iso (kernel.lift (g ≫ h) (kernel.ι g) (by simp)) :=
    ⟨⟨kernel.lift g (kernel.ι (g ≫ h)) (by simp [←cancel_mono h]), by tidy⟩⟩,
  rw image_to_kernel_map_comp_right f g h exact.w,
  exact epi_comp _ _
end

lemma exact_kernel : exact (kernel.ι f) f :=
begin
  refine ⟨kernel.condition _, _⟩,
  letI : is_iso (image_to_kernel_map (kernel.ι f) f (kernel.condition f)) :=
    ⟨⟨factor_thru_image (kernel.ι f),
      ⟨by simp [←cancel_mono (image.ι (kernel.ι f))], by tidy⟩⟩⟩,
  apply_instance
end

section
variables (A)

lemma kernel_ι_eq_zero_of_exact_zero_left [exact (0 : A ⟶ B) g] : kernel.ι g = 0 :=
begin
  rw [←cancel_epi (image_to_kernel_map (0 : A ⟶ B) g exact.w),
    ←cancel_epi (factor_thru_image (0 : A ⟶ B))],
  simp
end

lemma exact_zero_left_of_mono [has_zero_object V] [mono g] : exact (0 : A ⟶ B) g :=
⟨by simp, image_to_kernel_map_epi_of_zero_of_mono _⟩

end

end

section has_cokernels
variables [has_cokernels V] {A B C : V} (f : A ⟶ B) (g : B ⟶ C)

@[simp, reassoc] lemma kernel_comp_cokernel [exact f g] : kernel.ι g ≫ cokernel.π f = 0 :=
zero_of_epi_comp (image_to_kernel_map f g exact.w) $ zero_of_epi_comp (factor_thru_image f) $
  by simp

lemma comp_eq_zero_of_exact [exact f g] {X Y : V} {ι : X ⟶ B} (hι : ι ≫ g = 0) {π : B ⟶ Y}
  (hπ : f ≫ π = 0) : ι ≫ π = 0 :=
by rw [←kernel.lift_ι _ _ hι, ←cokernel.π_desc _ _ hπ, category.assoc, kernel_comp_cokernel_assoc,
  zero_comp, comp_zero]

@[simp, reassoc] lemma fork_ι_comp_cofork_π [exact f g] (s : kernel_fork g)
  (t : cokernel_cofork f) : fork.ι s ≫ cofork.π t = 0 :=
comp_eq_zero_of_exact f g (kernel_fork.condition s) (cokernel_cofork.condition t)

end has_cokernels

section
local attribute [instance] has_zero_object.has_zero

lemma exact_of_zero [has_zero_object V] {A C : V} (f : A ⟶ 0) (g : 0 ⟶ C) : exact f g :=
begin
  obtain rfl : f = 0 := by ext,
  obtain rfl : g = 0 := by ext,
  fsplit,
  { simp, },
  { exact image_to_kernel_map_epi_of_zero_of_mono 0, },
end

end

end category_theory