-- weirdly this is named List.List.append_eq ??
theorem List.append_eq : {α : Type} → (as bs : List α) → List.append as bs = as ++ bs := List.List.append_eq

inductive Brick : Type
  | Vert : Brick
  | Cap : Brick
  | Cup : Brick
  | Over : Brick
  | Under : Brick
  deriving BEq, DecidableEq
open Brick

-- stolen from Bool LawfulBEq impl
instance instLawfulEqBrick : LawfulBEq Brick where
  eq_of_beq {a b} h := by cases a <;> cases b <;> first | rfl | contradiction
  rfl {a} := by cases a <;> decide

/-- input threads -/
def Brick.domain : Brick → Nat
  | Vert => 1
  | Cap => 0
  | Cup => 2
  | Over => 2
  | Under => 2

/-- output threads -/
def Brick.codomain : Brick → Nat
  | Vert => 1
  | Cap => 2
  | Cup => 0
  | Over => 2
  | Under => 2

/-- 180° rotation -/
def Brick.vflip : Brick → Brick
  | Vert => Vert
  | Cap => Cup
  | Cup => Cap
  | Over => Over
  | Under => Under

def Brick.hflip : Brick → Brick := id

theorem Brick.vflip_boundary (b : Brick) : b.vflip.domain = b.codomain ∧ b.vflip.codomain = b.domain := by
  cases b <;> simp

def Bricks := List Brick

instance : Append Bricks := List.instAppendList
-- want this for simp in proofs, allows us to translate first to List.append
-- then List.append_eq simps to (Append List _).append a b
-- otherwise stuff like [] ++ b won't simp because the ++ is the wrong type ((Append Bricks).append)
@[simp] theorem Bricks.append_eq : {a b : Bricks} → a ++ b = List.append a b := rfl

/-- input threads -/
def Bricks.domain (bs : Bricks) : Nat := List.foldr Nat.add 0 (bs.map Brick.domain)
/-- output threads -/
def Bricks.codomain (bs : Bricks) : Nat := List.foldr Nat.add 0 (bs.map Brick.codomain)

@[simp] theorem Bricks.domain_cons : Bricks.domain (b::bs) = b.domain + Bricks.domain bs := by
  rewrite [domain, List.map, List.foldr, ←domain]
  apply Nat.add_eq
@[simp] theorem Bricks.codomain_cons : Bricks.codomain (b::bs) = b.codomain + Bricks.codomain bs := by
  rewrite [codomain, List.map, List.foldr, ←codomain]
  apply Nat.add_eq

@[simp] theorem Bricks.domain_append : {a b : Bricks} → Bricks.domain (a ++ b) = Bricks.domain a + Bricks.domain b := by
  intro a b
  induction a with
  | nil => simp [domain, List.foldr]
  | cons hd tl h => simp; rewrite [h]; exact Eq.symm (Nat.add_assoc _ _ _)
@[simp] theorem Bricks.codomain_append : {a b : Bricks} → Bricks.codomain (a ++ b) = Bricks.codomain a + Bricks.codomain b := by
  intro a b
  induction a with
  | nil => simp [codomain, List.foldr]
  | cons hd tl h => simp; rewrite [h]; exact Eq.symm (Nat.add_assoc _ _ _)

def Bricks.vflip (bs : Bricks) : Bricks := List.map Brick.vflip bs
def Bricks.hflip (bs : Bricks) : Bricks := (List.map Brick.hflip bs).reverse

def Wall : Type := List Bricks

instance : Append Wall := List.instAppendList
@[simp] theorem Wall.append_eq : {a b : Wall} → a ++ b = List.append a b := rfl

def Wall.happend : (a b : Wall) → (a.length = b.length) →  Wall
  | [], [], _ => []
  | a::as, bs, h => match bs with
      | b::bs => (a.append b)::(Wall.happend as bs (by simp [List.length] at h; exact h))
      | [] => by simp at h

def Wall.vflip (w : Wall) : Wall := (List.map Bricks.vflip w).reverse
def Wall.hflip (w : Wall) : Wall := (List.map Bricks.hflip w)

namespace Equivalence
def vert_bricks (n : Nat) : Bricks := List.replicate n Vert

theorem verts_dom_eq_codom (n : Nat) : (vert_bricks n).domain = (vert_bricks n).codomain := by
  induction n with
  | zero => simp
  | succ _ h =>
    simp [vert_bricks, List.replicate, Brick.domain, Brick.codomain]
    rewrite [←vert_bricks, h]
    rfl

/--
Planar isotopic mappings

     vertcl    vertcc    crosscl       crosscc
     |  .". |  |  | .".  | |  .". | |  | |  | | .".
     |  | '.'  |  '.' |  '/.  | .\' |  '/.  | .\' |
                         | |  | | '.'  | |  '.' | |

     slide
     . . .    . . .
     #######  | | |
     | | | |  #######
     ' ' ' '  ' ' ' '
-/
inductive PlanarIsotopic : Wall → Wall → Prop
  | vertcl : PlanarIsotopic [[Vert],[Vert]] [[Cap,Vert],[Vert,Cup]]
  | vertcc : PlanarIsotopic [[Vert],[Vert]] [[Vert,Cap],[Cup,Vert]]
  | crosscl : PlanarIsotopic [[Vert,Vert],[Under],[Vert,Vert]] [[Cap,Vert,Vert],[Vert,Over,Vert],[Vert,Vert,Cup]]
  | crosscc : PlanarIsotopic [[Vert,Vert],[Under],[Vert,Vert]] [[Vert,Vert,Cap],[Vert,Over,Vert],[Cup,Vert,Vert]]
  | slide : PlanarIsotopic [a, vert_bricks (Bricks.codomain a)] [vert_bricks (Bricks.domain a), a]

/--
Reidemeister moves

    1a .".  .".  2a | |  .\'  3a .\' |  | '/.
       | |  .\'     | |  '/.     | .\'  .\' |
                                 '/. |  | .\'
    1b .".  .".  2b | |  '/.
       | |  '/.     | |  .\'  3b '/. |  | '/.
                                 | '/.  '/. |
    1c | |  .\'                  '/. |  | '/.
       '.'  '.'
                              3c .\' |  | '/.
    1d | |  '/.                  | .\'  .\' |
       '.'  '.'                  '/. |  | .\'

                              3d '/. |  | .\'
                                 | '/.  '/. |
                                 .\' |  | '/.
-/
inductive ReidemeisterMove : Wall → Wall → Prop
  | type1a : ReidemeisterMove [[Cap], [Vert, Vert]]  [[Cap], [Over]]
  | type1b : ReidemeisterMove [[Cap], [Vert, Vert]]  [[Cap], [Under]]
  | type1c : ReidemeisterMove [[Vert, Vert], [Cup]]  [[Over], [Cup]]
  | type1d : ReidemeisterMove [[Vert, Vert], [Cup]]  [[Under], [Cup]]
  | type2a : ReidemeisterMove [[Vert, Vert], [Vert, Vert]]  [[Over], [Under]]
  | type2b : ReidemeisterMove [[Vert, Vert], [Vert, Vert]]  [[Under], [Over]]
  | type3a : ReidemeisterMove [[Over, Vert], [Vert, Over], [Under, Vert]]
                  [[Vert, Under], [Over, Vert], [Vert, Over]]
  | type3b : ReidemeisterMove [[Under, Vert], [Vert, Under], [Under, Vert]]
                  [[Vert, Under], [Under, Vert], [Vert, Under]]
  | type3c : ReidemeisterMove [[Over, Vert], [Vert, Over], [Over, Vert]]
                  [[Vert, Over], [Over, Vert], [Vert, Over]]
  | type3d : ReidemeisterMove [[Under, Vert], [Vert, Under], [Over, Vert]]
                  [[Vert, Over], [Under, Vert], [Vert, Under]]

end Equivalence


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

Extra definitions on option.
-/

namespace option
variables {α : Type*} {β : Type*}

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

theorem is_none_iff_eq_none {o : option α} : o.is_none = tt ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

instance decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_decidable_of_iff (bool.decidable_eq _ _) is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp)
| (some a) := if h : p a
  then is_true $ λ o e, some_inj.1 e ▸ h
  else is_false $ mt (λ H, H _ rfl) h

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (λ ⟨a, ⟨h, _⟩⟩, by cases h)
| (some a) := if h : p a
  then is_true $ ⟨_, rfl, h⟩
  else is_false $ λ ⟨_, ⟨rfl, hn⟩⟩, h hn

/-- inhabited `get` function. Returns `a` if the input is `some a`,
  otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default α

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a`
  and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

inductive rel (r : α → β → Prop) : option α → option β → Prop
| some {a b} : r a b → rel (some a) (some b)
| none {}    : rel none none

end option


import topology.algebra.infinite_sum
import topology.instances.ennreal

open_locale ennreal

open_locale nnreal

-- don't need it but maybe useful?
lemma ennreal.summable_of_coe_sum_eq {X : Type*} (f g : X → ℝ≥0)
  (h : ∑' x, (f x : ℝ≥0∞) = ∑' x, (g x : ℝ≥0∞)) :
  summable f ↔ summable g :=
by rw [← ennreal.tsum_coe_ne_top_iff_summable, h, ennreal.tsum_coe_ne_top_iff_summable]

lemma ennreal.has_sum_comm {α β: Type*} (F : α → β → ℝ≥0∞) (s : ℝ≥0∞)
  : has_sum (λ n, ∑' k, F n k) s ↔ has_sum (λ k, ∑' n, F n k) s :=
by rw [ summable.has_sum_iff ennreal.summable, summable.has_sum_iff ennreal.summable,
    ennreal.tsum_comm ]

-- do we need the `real` version?
-- /-- sum of row sums equals sum of column sums -/
-- lemma real.summable_snd_of_summable_fst {α β: Type*} (F : α → β → ℝ) (h_nonneg : ∀ n k, 0 ≤ F n k)
--   (h_rows : ∀ n, summable (λ k, F n k)) (h_cols : ∀ k, summable (λ n, F n k))
--   (h_col_row : summable (λ k, ∑' n, F n k)) : summable (λ n, ∑' k, F n k) :=
-- begin

--   -- wrong idea have := summable (λ ab : α × β, F ab.1 ab.2),
--   admit,
-- end

-- could go in ennreal line 684 or so
lemma ennreal.mul_le_mul_of_right {a b c : ℝ≥0∞} (hab : a ≤ b) : a * c ≤ b * c :=
begin
  rcases eq_or_ne c 0 with (rfl | hc0),
  { simp },
  { rcases eq_or_ne c ⊤ with (rfl | hctop),
    { rw [@ennreal.mul_top b],
      split_ifs with hb,
      { subst hb,
        change a ≤ ⊥ at hab,
        rw le_bot_iff at hab,
        simp [hab], },
      { exact le_top, } },
    { rwa ennreal.mul_le_mul_right hc0 hctop }, },
end

-- could go in ennreal line 684 or so
lemma ennreal.mul_le_mul_of_left {a b c : ℝ≥0∞} (hab : a ≤ b) : c * a ≤ c * b :=
begin
  rw [mul_comm, mul_comm c],
  exact ennreal.mul_le_mul_of_right hab,
end

-- might not need this
lemma nnreal.inv_mul_le_iff {a b c : ℝ≥0} (hb0 : b ≠ 0) : b⁻¹ * a ≤ c ↔ a ≤ b * c :=
begin
  rw ← nnreal.coe_le_coe,
  rw ← nnreal.coe_le_coe,
  push_cast,
  apply inv_mul_le_iff,
  obtain (hb | (hb : 0 < b)) := eq_zero_or_pos,
  { subst hb, exfalso, apply hb0, refl, },
  { assumption_mod_cast, }
end

lemma ennreal.inv_mul_le_iff {a b c : ℝ≥0∞} (hb0 : b ≠ 0) (hb : b ≠ ∞) :
  b⁻¹ * a ≤ c ↔ a ≤ b * c :=
begin
  rw [mul_comm, mul_comm b],
  apply ennreal.div_le_iff_le_mul;
  cc,
end

lemma ennreal.zero_le (a : ℝ≥0∞) : 0 ≤ a := bot_le
lemma ennreal.zero_le' {a : ℝ≥0∞} : 0 ≤ a := bot_le

lemma ennreal.inv_eq_of_mul_eq_one {a b : ℝ≥0∞} (h : a * b = 1) : a⁻¹ = b :=
begin
  induction b using with_top.rec_top_coe,
  { exfalso,
    rw ennreal.mul_top at h,
    split_ifs at h with ha;
    { revert h, norm_num, }, },
  induction a using with_top.rec_top_coe,
  { exfalso,
    rw ennreal.top_mul at h,
    split_ifs at h with ha;
    { revert h, norm_num, }, },
  norm_cast at h,
  have ha : a ≠ 0,
  { rintro rfl, rw zero_mul at h, revert h, norm_num, },
  rw ← ennreal.coe_inv ha,
  norm_cast,
  rwa [← inv_mul_eq_one₀, inv_inv],
  exact inv_ne_zero ha,
end

lemma ennreal.mul_inv_eq_of_eq_mul {a b c : ℝ≥0∞} (hb0 : b ≠ 0) (hbtop : b ≠ ⊤) (h : a = c * b) :
  a * b⁻¹ = c :=
by rw [h, mul_assoc, ennreal.mul_inv_cancel hb0 hbtop, mul_one]

lemma ennreal.eq_mul_of_mul_inv_eq {a b c : ℝ≥0∞} (hb0 : b ≠ 0) (hbtop : b ≠ ⊤) (h : a * b⁻¹ = c) :
  a = c * b :=
by rw [← h, mul_assoc, ennreal.inv_mul_cancel hb0 hbtop, mul_one]

lemma ennreal.mul_eq_of_mul_inv_eq {a b c : ℝ≥0∞} (hb0 : b ≠ 0) (hbtop : b ≠ ⊤) (h : a * b⁻¹ = c) :
  c * b = a :=
(ennreal.eq_mul_of_mul_inv_eq hb0 hbtop h).symm

lemma ennreal.mul_inv_eq_iff_eq_mul {a b c : ℝ≥0∞} (hb0 : b ≠ 0) (hbtop : b ≠ ⊤) :
  (a * b⁻¹ = c ↔ a = c * b) :=
⟨ennreal.eq_mul_of_mul_inv_eq hb0 hbtop, ennreal.mul_inv_eq_of_eq_mul hb0 hbtop⟩

lemma ennreal.le_zero_iff {a : ℝ≥0∞} : a ≤ 0 ↔ a = 0 := le_bot_iff

lemma ennreal.sub_pos {a b : ℝ≥0∞} : 0 < a - b ↔ b < a :=
begin
  rw ← not_iff_not,
  push_neg,
  rw ennreal.le_zero_iff,
  apply tsub_eq_zero_iff_le,
end

lemma ennreal.top_zpow_of_pos {n : ℤ} (hn : 0 < n) : (⊤ : ℝ≥0∞) ^ n = ⊤ :=
begin
  let m := n.nat_abs,
  have hm : n = m,
  { rw int.nat_abs_of_nonneg hn.le },
  rw hm at hn ⊢,
  apply ennreal.top_pow,
  exact_mod_cast hn,
end

-- can't do!
--lemma ennreal.zpow_neg (a : ℝ≥0∞) : ∀ (n : ℤ), a ^ -n = (a ^ n)⁻¹ := by admit

-- lemma ennreal.top_zpow_of_neg {n : ℤ} (hn : n < 0) : (⊤ : ℝ≥0∞) ^ n = 0 :=
-- begin
--   let m := n.nat_abs,
--   have hm : n = -m,
--   { rw [int.of_nat_nat_abs_of_nonpos hn.le, neg_neg] },
--   rw hm at hn ⊢,
--   rw neg_lt_zero at hn,
--   have hm' : 0 < m, by exact_mod_cast hn,
--   rw [ennreal.zpow_neg, zpow_coe_nat, ennreal.inv_eq_zero, ennreal.top_pow hm'],
-- end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.algebra.basic
import algebra.algebra.subalgebra
import algebra.free_algebra
import algebra.category.CommRing.basic
import algebra.category.Module.basic

/-!
# Category instance for algebras over a commutative ring

We introduce the bundled category `Algebra` of algebras over a fixed commutative ring `R ` along
with the forgetful functors to `Ring` and `Module`. We furthermore show that the functor associating
to a type the free `R`-algebra on that type is left adjoint to the forgetful functor.
-/

open category_theory
open category_theory.limits

universes v u

variables (R : Type u) [comm_ring R]

/-- The category of R-algebras and their morphisms. -/
structure Algebra :=
(carrier : Type v)
[is_ring : ring carrier]
[is_algebra : algebra R carrier]

attribute [instance] Algebra.is_ring Algebra.is_algebra

namespace Algebra

instance : has_coe_to_sort (Algebra R) (Type v) := ⟨Algebra.carrier⟩

instance : category (Algebra.{v} R) :=
{ hom   := λ A B, A →ₐ[R] B,
  id    := λ A, alg_hom.id R A,
  comp  := λ A B C f g, g.comp f }

instance : concrete_category.{v} (Algebra.{v} R) :=
{ forget := { obj := λ R, R, map := λ R S f, (f : R → S) },
  forget_faithful := { } }

instance has_forget_to_Ring : has_forget₂ (Algebra.{v} R) Ring.{v} :=
{ forget₂ :=
  { obj := λ A, Ring.of A,
    map := λ A₁ A₂ f, alg_hom.to_ring_hom f, } }

instance has_forget_to_Module : has_forget₂ (Algebra.{v} R) (Module.{v} R) :=
{ forget₂ :=
  { obj := λ M, Module.of R M,
    map := λ M₁ M₂ f, alg_hom.to_linear_map f, } }

/-- The object in the category of R-algebras associated to a type equipped with the appropriate
typeclasses. -/
def of (X : Type v) [ring X] [algebra R X] : Algebra.{v} R := ⟨X⟩

/-- Typecheck a `alg_hom` as a morphism in `Algebra R`. -/
def of_hom {R : Type u} [comm_ring R] {X Y : Type v} [ring X] [algebra R X] [ring Y] [algebra R Y]
  (f : X →ₐ[R] Y) : of R X ⟶ of R Y := f

instance : inhabited (Algebra R) := ⟨of R R⟩

@[simp]
lemma coe_of (X : Type u) [ring X] [algebra R X] : (of R X : Type u) = X := rfl

variables {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
algebra. -/
@[simps]
def of_self_iso (M : Algebra.{v} R) : Algebra.of R M ≅ M :=
{ hom := 𝟙 M, inv := 𝟙 M }

variables {R} {M N U : Module.{v} R}

@[simp]

@[simp] lemma coe_comp (f : M ⟶ N) (g : N ⟶ U) :
  ((f ≫ g) : M → U) = g ∘ f := rfl

variables (R)
/-- The "free algebra" functor, sending a type `S` to the free algebra on `S`. -/
@[simps]
def free : Type u ⥤ Algebra.{u} R :=
{ obj := λ S,
  { carrier := free_algebra R S,
    is_ring := algebra.semiring_to_ring R },
  map := λ S T f, free_algebra.lift _ $ (free_algebra.ι _) ∘ f,
  -- obviously can fill the next two goals, but it is slow
  map_id' := by { intros X, ext1, simp only [free_algebra.ι_comp_lift], refl },
  map_comp' := by { intros, ext1, simp only [free_algebra.ι_comp_lift], ext1,
    simp only [free_algebra.lift_ι_apply, category_theory.coe_comp, function.comp_app,
      types_comp_apply] } }

/-- The free/forget adjunction for `R`-algebras. -/
def adj : free.{u} R ⊣ forget (Algebra.{u} R) :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X A, (free_algebra.lift _).symm,
  -- Relying on `obviously` to fill out these proofs is very slow :(
  hom_equiv_naturality_left_symm' := by { intros, ext,
    simp only [free_map, equiv.symm_symm, free_algebra.lift_ι_apply, category_theory.coe_comp,
      function.comp_app, types_comp_apply] },
  hom_equiv_naturality_right' := by { intros, ext,
    simp only [forget_map_eq_coe, category_theory.coe_comp, function.comp_app,
      free_algebra.lift_symm_apply, types_comp_apply] } }

instance : is_right_adjoint (forget (Algebra.{u} R)) := ⟨_, adj R⟩

end Algebra

variables {R}
variables {X₁ X₂ : Type u}

/-- Build an isomorphism in the category `Algebra R` from a `alg_equiv` between `algebra`s. -/
@[simps]
def alg_equiv.to_Algebra_iso
  {g₁ : ring X₁} {g₂ : ring X₂} {m₁ : algebra R X₁} {m₂ : algebra R X₂} (e : X₁ ≃ₐ[R] X₂) :
  Algebra.of R X₁ ≅ Algebra.of R X₂ :=
{ hom := (e : X₁ →ₐ[R] X₂),
  inv := (e.symm : X₂ →ₐ[R] X₁),
  hom_inv_id' := begin ext, exact e.left_inv x, end,
  inv_hom_id' := begin ext, exact e.right_inv x, end, }

namespace category_theory.iso

/-- Build a `alg_equiv` from an isomorphism in the category `Algebra R`. -/
@[simps]
def to_alg_equiv {X Y : Algebra R} (i : X ≅ Y) : X ≃ₐ[R] Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_mul'  := by tidy,
  commutes' := by tidy, }.

end category_theory.iso

/-- Algebra equivalences between `algebras`s are the same as (isomorphic to) isomorphisms in
`Algebra`. -/
@[simps]
def alg_equiv_iso_Algebra_iso {X Y : Type u}
  [ring X] [ring Y] [algebra R X] [algebra R Y] :
  (X ≃ₐ[R] Y) ≅ (Algebra.of R X ≅ Algebra.of R Y) :=
{ hom := λ e, e.to_Algebra_iso,
  inv := λ i, i.to_alg_equiv, }

instance (X : Type u) [ring X] [algebra R X] : has_coe (subalgebra R X) (Algebra R) :=
⟨ λ N, Algebra.of R N ⟩

instance Algebra.forget_reflects_isos : reflects_isomorphisms (forget (Algebra.{u} R)) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget (Algebra.{u} R)).map f),
    let e : X ≃ₐ[R] Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Algebra_iso).1⟩,
  end }


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.traversable.equiv
import control.traversable.instances
import data.lazy_list

/-!
## Definitions on lazy lists

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

This file contains various definitions and proofs on lazy lists.

TODO: move the `lazy_list.lean` file from core to mathlib.
-/

universes u

namespace thunk

/-- Creates a thunk with a (non-lazy) constant value. -/
def mk {α} (x : α) : thunk α := λ _, x

instance {α : Type u} [decidable_eq α] : decidable_eq (thunk α) | a b :=
have a = b ↔ a () = b (), from ⟨by cc, by intro; ext x; cases x; assumption⟩,
by rw this; apply_instance

end thunk

namespace lazy_list

open function

/-- Isomorphism between strict and lazy lists. -/
def list_equiv_lazy_list (α : Type*) : list α ≃ lazy_list α :=
{ to_fun := lazy_list.of_list,
  inv_fun := lazy_list.to_list,
  right_inv := by { intro, induction x, refl, simp! [*],
                    ext, cases x, refl },
  left_inv := by { intro, induction x, refl, simp! [*] } }

instance {α : Type u} [decidable_eq α] : decidable_eq (lazy_list α)
| nil nil := is_true rfl
| (cons x xs) (cons y ys) :=
  if h : x = y then
    match decidable_eq (xs ()) (ys ()) with
    | is_false h2 := is_false (by intro; cc)
    | is_true h2 :=
      have xs = ys, by ext u; cases u; assumption,
      is_true (by cc)
    end
  else
    is_false (by intro; cc)
| nil (cons _ _) := is_false (by cc)
| (cons _ _) nil := is_false (by cc)

/-- Traversal of lazy lists using an applicative effect. -/
protected def traverse {m : Type u → Type u} [applicative m] {α β : Type u}
    (f : α → m β) : lazy_list α → m (lazy_list β)
| lazy_list.nil := pure lazy_list.nil
| (lazy_list.cons x xs) := lazy_list.cons <$> f x <*> (thunk.mk <$> traverse (xs ()))

instance : traversable lazy_list :=
{ map := @lazy_list.traverse id _,
  traverse := @lazy_list.traverse }

instance : is_lawful_traversable lazy_list :=
begin
  apply equiv.is_lawful_traversable' list_equiv_lazy_list;
  intros ; resetI; ext,
  { induction x, refl,
    simp! [equiv.map,functor.map] at *,
    simp [*], refl, },
  { induction x, refl,
    simp! [equiv.map,functor.map_const] at *,
    simp [*], refl, },
  { induction x,
    { simp! [traversable.traverse,equiv.traverse] with functor_norm, refl },
    simp! [equiv.map,functor.map_const,traversable.traverse] at *, rw x_ih,
    dsimp [list_equiv_lazy_list,equiv.traverse,to_list,traversable.traverse,list.traverse],
    simp! with functor_norm, refl },
end

/-- `init xs`, if `xs` non-empty, drops the last element of the list.
Otherwise, return the empty list. -/
def init {α} : lazy_list α → lazy_list α
| lazy_list.nil := lazy_list.nil
| (lazy_list.cons x xs) :=
  let xs' := xs () in
  match xs' with
  | lazy_list.nil := lazy_list.nil
  | (lazy_list.cons _ _) := lazy_list.cons x (init xs')
  end

/-- Return the first object contained in the list that satisfies
predicate `p` -/
def find {α} (p : α → Prop) [decidable_pred p] : lazy_list α → option α
| nil        := none
| (cons h t) := if p h then some h else find (t ())

/-- `interleave xs ys` creates a list where elements of `xs` and `ys` alternate. -/
def interleave {α} : lazy_list α → lazy_list α → lazy_list α
| lazy_list.nil xs := xs
| a@(lazy_list.cons x xs) lazy_list.nil := a
| (lazy_list.cons x xs) (lazy_list.cons y ys) :=
  lazy_list.cons x (lazy_list.cons y (interleave (xs ()) (ys ())))

/-- `interleave_all (xs::ys::zs::xss)` creates a list where elements of `xs`, `ys`
and `zs` and the rest alternate. Every other element of the resulting list is taken from
`xs`, every fourth is taken from `ys`, every eighth is taken from `zs` and so on. -/
def interleave_all {α} : list (lazy_list α) → lazy_list α
| [] := lazy_list.nil
| (x :: xs) := interleave x (interleave_all xs)

/-- Monadic bind operation for `lazy_list`. -/
protected def bind {α β} : lazy_list α → (α → lazy_list β) → lazy_list β
| lazy_list.nil _ := lazy_list.nil
| (lazy_list.cons x xs) f := lazy_list.append (f x) (bind (xs ()) f)

/-- Reverse the order of a `lazy_list`.
It is done by converting to a `list` first because reversal involves evaluating all
the list and if the list is all evaluated, `list` is a better representation for
it than a series of thunks. -/
def reverse {α} (xs : lazy_list α) : lazy_list α :=
of_list xs.to_list.reverse

instance : monad lazy_list :=
{ pure := @lazy_list.singleton,
  bind := @lazy_list.bind }

lemma append_assoc {α} (xs ys zs : lazy_list α) :
  (xs.append ys).append zs = xs.append (ys.append zs) :=
by induction xs; simp [append, *]

lemma append_bind {α β} (xs : lazy_list α) (ys : thunk (lazy_list α)) (f : α → lazy_list β) :
  (@lazy_list.append _ xs ys).bind f = (xs.bind f).append ((ys ()).bind f) :=
by induction xs; simp [lazy_list.bind, append, *, append_assoc, append, lazy_list.bind]

instance : is_lawful_monad lazy_list :=
{ pure_bind := by { intros, apply append_nil },
  bind_assoc := by { intros, dsimp [(>>=)], induction x; simp [lazy_list.bind, append_bind, *], },
  id_map :=
  begin
    intros,
    simp [(<$>)],
    induction x; simp [lazy_list.bind, *, singleton, append],
    ext ⟨ ⟩, refl,
  end }

/-- Try applying function `f` to every element of a `lazy_list` and
return the result of the first attempt that succeeds. -/
def mfirst {m} [alternative m] {α β} (f : α → m β) : lazy_list α → m β
| nil := failure
| (cons x xs) :=
  f x <|> mfirst (xs ())

/-- Membership in lazy lists -/
protected def mem {α} (x : α) : lazy_list α → Prop
| lazy_list.nil := false
| (lazy_list.cons y ys) := x = y ∨ mem (ys ())

instance {α} : has_mem α (lazy_list α) :=
⟨ lazy_list.mem ⟩

instance mem.decidable {α} [decidable_eq α] (x : α) : Π xs : lazy_list α, decidable (x ∈ xs)
| lazy_list.nil := decidable.false
| (lazy_list.cons y ys) :=
  if h : x = y
    then decidable.is_true (or.inl h)
    else decidable_of_decidable_of_iff (mem.decidable (ys ())) (by simp [*, (∈), lazy_list.mem])

@[simp]
lemma mem_nil {α} (x : α) : x ∈ @lazy_list.nil α ↔ false := iff.rfl

@[simp]
lemma mem_cons {α} (x y : α) (ys : thunk (lazy_list α)) :
  x ∈ @lazy_list.cons α y ys ↔ x = y ∨ x ∈ ys () := iff.rfl

theorem forall_mem_cons {α} {p : α → Prop} {a : α} {l : thunk (lazy_list α)} :
  (∀ x ∈ @lazy_list.cons _ a l, p x) ↔ p a ∧ ∀ x ∈ l (), p x :=
by simp only [has_mem.mem, lazy_list.mem, or_imp_distrib, forall_and_distrib, forall_eq]

/-! ### map for partial functions -/

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f l h` is essentially the same as `map f l`
  but is defined only when all members of `l` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α β} {p : α → Prop} (f : Π a, p a → β) :
  Π l : lazy_list α, (∀ a ∈ l, p a) → lazy_list β
| lazy_list.nil         H := lazy_list.nil
| (lazy_list.cons x xs) H := lazy_list.cons (f x (forall_mem_cons.1 H).1)
                               (pmap (xs ()) (forall_mem_cons.1 H).2)

/-- "Attach" the proof that the elements of `l` are in `l` to produce a new `lazy_list`
  with the same elements but in the type `{x // x ∈ l}`. -/
def attach {α} (l : lazy_list α) : lazy_list {x // x ∈ l} := pmap subtype.mk l (λ a, id)

instance {α} [has_repr α] : has_repr (lazy_list α) :=
⟨ λ xs, repr xs.to_list ⟩

end lazy_list


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot

! This file was ported from Lean 3 source module topology.uniform_space.pi
! leanprover-community/mathlib commit 0a0ec35061ed9960bf0e7ffb0335f44447b58977
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.UniformSpace.Cauchy
import Mathbin.Topology.UniformSpace.Separation

/-!
# Indexed product of uniform spaces

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

noncomputable section

open uniformity Topology

section

open Filter UniformSpace

universe u

variable {ι : Type _} (α : ι → Type u) [U : ∀ i, UniformSpace (α i)]

include U

#print Pi.uniformSpace /-
instance Pi.uniformSpace : UniformSpace (∀ i, α i) :=
  UniformSpace.ofCoreEq (⨅ i, UniformSpace.comap (fun a : ∀ i, α i => a i) (U i)).toCore
      Pi.topologicalSpace <|
    Eq.symm toTopologicalSpace_infᵢ
#align Pi.uniform_space Pi.uniformSpace
-/

/- warning: Pi.uniformity -> Pi.uniformity is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u2}} (α : ι -> Type.{u1}) [U : forall (i : ι), UniformSpace.{u1} (α i)], Eq.{succ (max u2 u1)} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (uniformity.{max u2 u1} (forall (i : ι), α i) (Pi.uniformSpace.{u1, u2} ι (fun (i : ι) => α i) (fun (i : ι) => U i))) (infᵢ.{max u2 u1, succ u2} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (ConditionallyCompleteLattice.toHasInf.{max u2 u1} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (CompleteLattice.toConditionallyCompleteLattice.{max u2 u1} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (Filter.completeLattice.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))))) ι (fun (i : ι) => Filter.comap.{max u2 u1, u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i)) (Prod.{u1, u1} (α i) (α i)) (fun (a : Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i)) => Prod.mk.{u1, u1} (α i) (α i) (Prod.fst.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i) a i) (Prod.snd.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i) a i)) (uniformity.{u1} (α i) (U i))))
but is expected to have type
  forall {ι : Type.{u1}} (α : ι -> Type.{u2}) [U : forall (i : ι), UniformSpace.{u2} (α i)], Eq.{max (succ u2) (succ u1)} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (uniformity.{max u2 u1} (forall (i : ι), α i) (Pi.uniformSpace.{u2, u1} ι (fun (i : ι) => α i) (fun (i : ι) => U i))) (infᵢ.{max u2 u1, succ u1} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (ConditionallyCompleteLattice.toInfSet.{max u2 u1} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (CompleteLattice.toConditionallyCompleteLattice.{max u2 u1} (Filter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))) (Filter.instCompleteLatticeFilter.{max u2 u1} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i))))) ι (fun (i : ι) => Filter.comap.{max u2 u1, u2} (Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i)) (Prod.{u2, u2} (α i) (α i)) (fun (a : Prod.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i)) => Prod.mk.{u2, u2} (α i) (α i) (Prod.fst.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i) a i) (Prod.snd.{max u2 u1, max u2 u1} (forall (i : ι), α i) (forall (i : ι), α i) a i)) (uniformity.{u2} (α i) (U i))))
Case conversion may be inaccurate. Consider using '#align Pi.uniformity Pi.uniformityₓ'. -/
theorem Pi.uniformity : 𝓤 (∀ i, α i) = ⨅ i : ι, (Filter.comap fun a => (a.1 i, a.2 i)) <| 𝓤 (α i) :=
  infᵢ_uniformity
#align Pi.uniformity Pi.uniformity

variable {α}

/- warning: uniform_continuous_pi -> uniformContinuous_pi is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u2}} {α : ι -> Type.{u1}} [U : forall (i : ι), UniformSpace.{u1} (α i)] {β : Type.{u3}} [_inst_1 : UniformSpace.{u3} β] {f : β -> (forall (i : ι), α i)}, Iff (UniformContinuous.{u3, max u2 u1} β (forall (i : ι), α i) _inst_1 (Pi.uniformSpace.{u1, u2} ι (fun (i : ι) => α i) (fun (i : ι) => U i)) f) (forall (i : ι), UniformContinuous.{u3, u1} β (α i) _inst_1 (U i) (fun (x : β) => f x i))
but is expected to have type
  forall {ι : Type.{u1}} {α : ι -> Type.{u3}} [U : forall (i : ι), UniformSpace.{u3} (α i)] {β : Type.{u2}} [_inst_1 : UniformSpace.{u2} β] {f : β -> (forall (i : ι), α i)}, Iff (UniformContinuous.{u2, max u3 u1} β (forall (i : ι), α i) _inst_1 (Pi.uniformSpace.{u3, u1} ι (fun (i : ι) => α i) (fun (i : ι) => U i)) f) (forall (i : ι), UniformContinuous.{u2, u3} β (α i) _inst_1 (U i) (fun (x : β) => f x i))
Case conversion may be inaccurate. Consider using '#align uniform_continuous_pi uniformContinuous_piₓ'. -/
theorem uniformContinuous_pi {β : Type _} [UniformSpace β] {f : β → ∀ i, α i} :
    UniformContinuous f ↔ ∀ i, UniformContinuous fun x => f x i := by
  simp only [UniformContinuous, Pi.uniformity, tendsto_infi, tendsto_comap_iff]
#align uniform_continuous_pi uniformContinuous_pi

variable (α)

/- warning: Pi.uniform_continuous_proj -> Pi.uniformContinuous_proj is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u2}} (α : ι -> Type.{u1}) [U : forall (i : ι), UniformSpace.{u1} (α i)] (i : ι), UniformContinuous.{max u2 u1, u1} (forall (i : ι), α i) (α i) (Pi.uniformSpace.{u1, u2} ι (fun (i : ι) => α i) (fun (i : ι) => U i)) (U i) (fun (a : forall (i : ι), α i) => a i)
but is expected to have type
  forall {ι : Type.{u1}} (α : ι -> Type.{u2}) [U : forall (i : ι), UniformSpace.{u2} (α i)] (i : ι), UniformContinuous.{max u2 u1, u2} (forall (i : ι), α i) (α i) (Pi.uniformSpace.{u2, u1} ι (fun (i : ι) => α i) (fun (i : ι) => U i)) (U i) (fun (a : forall (i : ι), α i) => a i)
Case conversion may be inaccurate. Consider using '#align Pi.uniform_continuous_proj Pi.uniformContinuous_projₓ'. -/
theorem Pi.uniformContinuous_proj (i : ι) : UniformContinuous fun a : ∀ i : ι, α i => a i :=
  uniformContinuous_pi.1 uniformContinuous_id i
#align Pi.uniform_continuous_proj Pi.uniformContinuous_proj

#print Pi.complete /-
instance Pi.complete [∀ i, CompleteSpace (α i)] : CompleteSpace (∀ i, α i) :=
  ⟨by
    intro f hf
    haveI := hf.1
    have : ∀ i, ∃ x : α i, Filter.map (fun a : ∀ i, α i => a i) f ≤ 𝓝 x :=
      by
      intro i
      have key : Cauchy (map (fun a : ∀ i : ι, α i => a i) f) :=
        hf.map (Pi.uniformContinuous_proj α i)
      exact cauchy_iff_exists_le_nhds.1 key
    choose x hx using this
    use x
    rwa [nhds_pi, le_pi]⟩
#align Pi.complete Pi.complete
-/

#print Pi.separated /-
instance Pi.separated [∀ i, SeparatedSpace (α i)] : SeparatedSpace (∀ i, α i) :=
  separated_def.2 fun x y H => by
    ext i
    apply eq_of_separated_of_uniform_continuous (Pi.uniformContinuous_proj α i)
    apply H
#align Pi.separated Pi.separated
-/

end


import complements.filter_product
import tactic
import tactic.interactive
import data.real.hyperreal

open tactic expr

namespace tactic

section lift_lhs

private meta def forall_rule (l : expr) (α : expr) : tactic unit :=
do  `(filter %%ι) ← infer_type l,
    e ← to_expr ``(filter.germ.forall_iff_forall_lift_pred %%l),
    rewrite_target e

private meta def exists_rule (l : expr) (α : expr) : tactic unit :=
do  `(filter %%ι) ← infer_type l,
    e ← to_expr ``(filter.germ.exists_iff_exists_lift_pred %%l),
    rewrite_target e

meta def transfer_lift_lhs (tgt : expr) : tactic unit :=
do  `(%%lhs ↔ %%rhs) ← (return tgt) | fail "Goal is not an equivalence (step 1)",
    match rhs with
    | `(∀ _ : (filter.germ %%l %%α), _) := forall_rule l α
    | `(∀ _ : ℝ*, _) := forall_rule `(filter.hyperfilter ℕ : filter ℕ) `(ℝ)
    | `(∃ _ : (filter.germ %%l %%α), _) := exists_rule l α
    | `(∃ _ : ℝ*, _) := exists_rule `(filter.hyperfilter ℕ : filter ℕ) `(ℝ)
    | _ := fail "No known pattern applicable (step 1)"
    end

end lift_lhs

section congr

meta def transfer_congr (tgt : expr) : tactic unit :=
do  `(%%lhs ↔ %%rhs) ← (return tgt) | fail "Goal is not an equivalence (step 2)",
    match lhs with
    | `(∀ _ : %%t, _) :=
      (do t' ← infer_type t,
          unify t' `(Prop),
          refine ``(imp_congr _ _)) <|>
      (do some (name, _, _) ← get_binder none tt lhs,
          name ← get_unused_name name,
          refine ``(forall_congr _),
          intro name,
          skip)
    | `(∃ _ : %%t, _) :=
      do  --some (name, _, _) ← get_binder none tt lhs, TODO
          name ← get_unused_name,
          refine ``(exists_congr _),
          intro name,
          skip
    | `(_ ∧ _) :=
      do  name ← get_unused_name,
          refine ``(and_congr _ _)
    | `(_ ∨ _) :=
      do  name ← get_unused_name,
          refine ``(or_congr _ _)
    | `(¬ _) :=
      do  name ← get_unused_name,
          refine ``(not_congr _)
    | `(_ = _) :=
      do  name ← get_unused_name,
          refine ``(iff_of_eq (_root_.congr (=) _))
    | _ := fail "No known pattern applicable (step 2)"
    end

end congr

section push_lift

meta def transfer_push_lift (tgt : expr) : tactic unit :=
do  `(filter.germ.lift_pred %%p %%x ↔ %%rhs) ← (return tgt) | fail "Goal is not an equivalence (step 3)",
    match p with
    | `(λ _, ∀ y, %%q) :=
      (do e ← to_expr ``(filter.germ.lift_pred_forall_iff_forall_lift_pred'),
          rewrite_target e) <|>
      (do e ← to_expr ``(filter.germ.lift_pred_imp_iff_imp_lift_pred),
          rewrite_target e)
    | `(λ _, ¬ %%q) :=
      do  e ← to_expr ``(filter.germ.lift_pred_not_iff_not_lift_pred),
          rewrite_target e
    | `(λ _, ∃ y, %%q) :=
      (do e ← to_expr ``(filter.germ.lift_pred_exists_iff_exists_lift_pred'),
          rewrite_target e) <|>
      (do e ← to_expr ``(filter.germ.lift_pred_exists_prop_iff_and_lift_pred),
          e' ← to_expr ``(exists_prop),
          rewrite_target e,
          rewrite_target e')
    | `(λ _, _ < _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_lt_iff_lt_map),
          rewrite_target e
    | `(λ _, _ > _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_lt_iff_lt_map),
          rewrite_target e
    | `(λ _, _ = _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_eq_iff_eq_map),
          rewrite_target e
    | `(λ _, _ ≠ _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_ne_iff_ne_map),
          rewrite_target e
    | `(λ _, _ ∧ _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_and_iff_and_lift_pred),
          rewrite_target e
    | `(λ _, _ ∨ _) :=
      do  e ← to_expr ``(filter.germ.lift_pred_or_iff_or_lift_pred),
          rewrite_target e
    | _ := fail "No known pattern applicable (step 3)"
    end

end push_lift

section induction

meta def transfer_induction (tgt : expr) : tactic unit :=
local_context >>= list.mmap' (λ x, try $
  do  t ← infer_type x,
      match t with
      | `(filter.germ _ _) := skip
      | `(ℝ*) := skip
      | _ := fail ()
      end,
      refine ``((%%x).induction_on _),
      name ← get_unused_name,
      intro name )

meta def transfer_close (tgt : expr) : tactic unit :=
transfer_induction tgt >> reflexivity

end induction

namespace interactive

setup_tactic_parser

meta def transfer_lift_lhs : tactic unit :=
target >>= tactic.transfer_lift_lhs

meta def transfer_congr : tactic unit :=
target >>= tactic.transfer_congr

meta def transfer_push_lift : tactic unit :=
target >>= tactic.transfer_push_lift

meta def transfer_induction : tactic unit :=
target >>= tactic.transfer_induction

meta def transfer_close : tactic unit :=
target >>= tactic.transfer_close

meta def transfer_step : tactic unit :=
transfer_close <|>
transfer_congr <|>
(transfer_push_lift >> try transfer_congr) <|>
(transfer_lift_lhs >> try transfer_congr)

meta def transfer : tactic unit :=
focus (repeat transfer_step)

end interactive

example (α ι : Type*) [preorder α] (l : ultrafilter ι) (a : α) :
  (∀ x, a ≤ x) ↔ (∀ x : (l : filter ι).germ α, ↑a ≤ x) :=
by transfer

example (α ι : Type*) [preorder α] (l : ultrafilter ι) (a : α) :
  (∀ x y : α, x = y) ↔ (∀ x y : (l : filter ι).germ α, x = y) :=
by transfer

open filter

example (l : ℝ) (u : ℕ → ℝ) :
  (∀ ε > 0, ∃ N ≥ (1 : ℕ), ∀ n ≥ N, abs (u n - l) < ε) ↔
  (∀ ε > 0, ∃ N ≥ (1 : (hyperfilter ℕ : filter ℕ).germ ℕ), ∀ n ≥ N, germ.map abs (germ.map u n - ↑l) < ε) :=
by transfer

end tactic


import Mathbin.Data.MvPolynomial.Basic

noncomputable section

open Classical BigOperators

open Set Function Finsupp AddMonoidAlgebra MvPolynomial

universe u v
variable {R : Type u}

namespace MvPolynomial
variable {σ : Type _} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section CommSemiringₓ

variable [CommSemiringₓ R] {p q : MvPolynomial σ R}

section DecidableEq

variable [DecidableEq σ] (a : σ)

/-
lemma coeff_X_mul' (m) (s : σ) (p : MvPolynomial σ R) :
   coeff m (X s * p) = if s ∈ m.support then coeff (m - Finsupp.single s 1) p else 0 :=
   by
  rw [mul_comm]
  rw [MvPolynomial.coeff_mul_X']
-/

end DecidableEq

lemma coeff_mul_X_pow (m : σ →₀ ℕ) (n : ℕ) (s : σ) (p : MvPolynomial σ R) :
  coeff (m + single s n : σ →₀ ℕ) (p * (x s : MvPolynomial σ R) ^ n : MvPolynomial σ R) = coeff m p := by
  have : HasMem.Mem (m, single s n) (m + single s n).antidiagonal := sorry -- mem_antidiagonal.2 _,
  rw [coeff_mul, ← Finset.insert_erase this, Finset.sum_insert (Finset.not_mem_erase _ _),
      Finset.sum_eq_zero, add_zeroₓ, coeff_X_pow, if_pos, mul_oneₓ]
  simp only [eq_self_iff_true]
  intro ⟨i,j⟩ hij
  rw [Finset.mem_erase, mem_antidiagonal] at hij
  by_cases H : single s n = j
  · subst j
    sorry
  · rw [coeff_X_pow, if_neg H, _root_.mul_zero]

-- # TODO
-- lemma support_X_pow [nontrivial R] : (X n ^ e : MvPolynomial σ R).support = {single n e} :=
-- by rw [X_pow_eq_single, support_monomial, if_neg]; exact one_ne_zero

lemma coeff_mul_X_pow' (m : σ →₀ ℕ) (n : ℕ) (s : σ) (p : MvPolynomial σ R) :
  coeff m (p * (x s : MvPolynomial σ R) ^ n : MvPolynomial σ R) = if n ≤ m s then coeff (m - single s n : σ →₀ ℕ) p else 0 :=
by sorry
  -- # TODO: what to do with `nontriviality` and `split_ifs`?
  -- nontriviality R,
  -- split_ifs with h h,
  -- { conv_rhs {rw ← coeff_mul_X_pow _ n s},
  --   congr' with  t,
  --   by_cases hj : s = t,
  --   { subst t, simp only [nat_sub_apply, add_apply, single_eq_same], exact (nat.sub_eq_iff_eq_add h).mp rfl,
  --     },
  --   { simp [single_eq_of_ne hj] } },
  -- { rw ← not_mem_support_iff, intro hm, apply h,
  --   have H := support_mul _ _ hm, simp only [Finset.mem_bUnion] at H,
  --   rcases H with ⟨j, hj, i', hi', H⟩,
  --   rw [support_X_pow, Finset.mem_singleton] at hi', subst i',
  --   rw Finset.mem_singleton at H, subst m,
  --   rw [add_apply, single_apply, if_pos rfl],
  --   finish, }

lemma coeff_X_pow_mul' (m) (n : ℕ) (s : σ) (p : MvPolynomial σ R) :
  coeff m (((x s : MvPolynomial σ R) ^ n) * p : MvPolynomial σ R) = if n ≤ m s then coeff (m - Finsupp.single s n : σ →₀ ℕ) p else 0 := by sorry
-- begin
--   rw mul_comm,
--   rw coeff_mul_X_pow',
-- end

-- # TODO:
-- Bolton mentions this below;
-- "For some reason, this lemma is actually useless
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Extracting.20constant.20from.20sum"
-- unification is smart enough to figure out that `Finset.mul_sum` works
-- without the need to specialize lemmas like this

lemma sum_X_mul {α : Type u} (r : Finset α) (f : α -> MvPolynomial σ R) (s : σ) :
  (∑ x in r, (MvPolynomial.x s : MvPolynomial σ R) * f x) = (x s : MvPolynomial σ R) * (∑ x in r, f x) :=
by rw [Finset.mul_sum]

lemma sum_C_mul {α : Type u} {r : Finset α} {f : α -> MvPolynomial σ R} (e : R) :
  (∑ x in r, (c e : MvPolynomial σ R) * f x) = (c e : MvPolynomial σ R) * (∑ x in r, f x) :=
by rw [Finset.mul_sum]

lemma sum_C_hom {α : Type u} {r : Finset α} {f : α -> R} :
  ((∑ x in r, c (f x)) : MvPolynomial σ R) = (c (∑ x in r, f x) : MvPolynomial σ R) :=
by sorry -- exact Finset.sum_hom r c

-- -- TODO add to mathlib
-- instance (s : σ →₀ ℕ) : is_add_monoid_hom (@monomial R σ _ s) :=
-- {
--   map_add := begin
--     intros x y,
--     exact monomial_add.symm,
--   end,
--   map_zero := monomial_zero,
-- }

lemma sum_monomial_hom {α : Type u} {r : Finset α} {f : α -> R}  (s : σ →₀ ℕ) :
   ((∑ x in r, monomial s (f x)) : MvPolynomial σ R) = monomial s (∑ x in r, f x)
 := by sorry -- Finset.mul_sum r (monomial s)

lemma extract_mul_from_sum {α : Type u} {r : Finset α} {f : α -> MvPolynomial σ R} (p : MvPolynomial σ R) :
   (∑ x in r, p * f x) = p * (∑ x in r, f x) :=
by rw [Finset.mul_sum]

-- lemma C_mul_C (a a' : R) : (c a) * (c a') = (c (a * a') : MvPolynomial σ R) := by simp

-- lemma C_mul_monomial' (a a' : R) (s : σ →₀ ℕ) : (Monomial s a') * c a  = Monomial s (a' * a) :=
--  by sorry
-- simp [C_apply, monomial, single_mul_single]

-- lemma C_to_monomial (a : R) : @C _ σ _ a = monomial 0 (a) := by exact C_apply

-- -- For some reason, this lemma is actually useless https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Extracting.20constant.20from.20sum
-- -- I expect many other lemmas in theis file may be useless as well
-- -- TODO investigate and clean up
-- lemma Finset_sum_C {α : Type u} {r : Finset α} {f : α -> R} (e : R) :
--   (∑ x in r, (C (f x) : MvPolynomial σ R)) = C (∑ x in r, f x)
-- :=
-- begin
--   rw Finset.sum_hom,
-- end

lemma rearrange1 (n : ℕ) (v1 v2 : σ) (p : MvPolynomial σ R) :
  ((MvPolynomial.x v1) ^ n) * ((MvPolynomial.x v2) * p) = (MvPolynomial.x v2) * ((MvPolynomial.x v1 ^ n) * p) :=
  by sorry
  --by ring

lemma rearrange2 (n : ℕ) (f : R) (v1 : σ) (p : MvPolynomial σ R) :
  let f₁ := (MvPolynomial.x v1 : MvPolynomial σ R)
  let f₂ := (MvPolynomial.c f : MvPolynomial σ R)
  (f₁ ^ n) * (f₂ * p) = f₂ * ((f₁ ^ n) * p) :=
  by sorry

-- -- move constants right of X
lemma rearrange_constants_right (f : R) (v1 : σ) :
  let f₁ := (MvPolynomial.x v1 : MvPolynomial σ R)
  let f₂ := (MvPolynomial.c f : MvPolynomial σ R)
  f₂ * f₁ = f₁ * f₂
:= by sorry
-- by ring

lemma rearrange_constants_right_with_extra (f : R) (v1 : σ) (p : MvPolynomial σ R) :
  let f₁ := (MvPolynomial.x v1 : MvPolynomial σ R)
  let f₂ := (MvPolynomial.c f : MvPolynomial σ R)
  f₂ * (f₁ * p) = f₁ * (f₂ * p)
:= by sorry

lemma rearrange_sums_right_with_extra {α : Type u} {r : Finset α} {f : α → MvPolynomial σ R} (s : σ) (p : MvPolynomial σ R) :
   let f₁ := (MvPolynomial.x s : MvPolynomial σ R)
   (∑ x in r, f x) * (f₁ * p) = (f₁ * (∑ x in r, f x)) * p
:= by sorry

lemma rearrange_sums_right {α : Type u} {r : Finset α} {f : α → MvPolynomial σ R} (s : σ) :
   let f₁ := (MvPolynomial.x s : MvPolynomial σ R)
   (∑ x in r, f x) * f₁ = f₁ * (∑ x in r, f x)
:= by sorry

-- -- move constants right of X
lemma rearrange_smul_right (n : ℕ) (a : R) (v1 : σ) (p : MvPolynomial σ R) :
  let f₁ := (MvPolynomial.x v1 : MvPolynomial σ R)
  a • (f₁ * p) = f₁ * (a • p)
:= by sorry -- rw [mul_smul_comm]

/-
lemma rearrange_constants_right_hard (f : R) (p : R[X]) :
   Polynomial.c f * p = (p) * (Polynomial.c f)
:= by sorry

lemma rearrange_001 (f : R) (p1 p2 p3 : Polynomial R) :
  (Polynomial.c f) * p1 = p2 + p3 ↔ p2 + p3 = (Polynomial.c f) * p1 := by
   split
    { intro h, rw h }
    { intro h, rw h }

lemma rearrange_002 (f : R) (p1 p2 p3 : Polynomial R) :
  p1 * (c f) = p2 + p3 ↔ p2 + p3 = p1 * (c f) := by
   split
    { intro h, rw h }
    { intro h, rw h }
-/

lemma add_mul_distrib (a b c d : R) : a + b * c + b * d = a + b * (c + d) :=
by sorry

lemma add_mul_distrib' (a b c d : R) : a + c * b + d * b = a + b * (c + d) :=
by sorry

end CommSemiringₓ

end MvPolynomial


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

/-!
# A type for VM-erased data

This file defines a type `erased α` which is classically isomorphic to `α`,
but erased in the VM. That is, at runtime every value of `erased α` is
represented as `0`, just like types and proofs.
-/

universes u

/-- `erased α` is the same as `α`, except that the elements
  of `erased α` are erased in the VM in the same way as types
  and proofs. This can be used to track data without storing it
  literally. -/
def erased (α : Sort u) : Sort (max 1 u) :=
Σ' s : α → Prop, ∃ a, (λ b, a = b) = s

namespace erased

/-- Erase a value. -/
@[inline] def mk {α} (a : α) : erased α := ⟨λ b, a = b, a, rfl⟩

/-- Extracts the erased value, noncomputably. -/
noncomputable def out {α} : erased α → α
| ⟨s, h⟩ := classical.some h

/--
Extracts the erased value, if it is a type.

Note: `(mk a).out_type` is not definitionally equal to `a`.
-/
@[reducible] def out_type (a : erased (Sort u)) : Sort u := out a

/-- Extracts the erased value, if it is a proof. -/
theorem out_proof {p : Prop} (a : erased p) : p := out a

@[simp] theorem out_mk {α} (a : α) : (mk a).out = a :=
begin
  let h, show classical.some h = a,
  have := classical.some_spec h,
  exact cast (congr_fun this a).symm rfl
end

@[simp] theorem mk_out {α} : ∀ (a : erased α), mk (out a) = a
| ⟨s, h⟩ := by simp [mk]; congr; exact classical.some_spec h

@[ext] lemma out_inj {α} (a b : erased α) (h : a.out = b.out) : a = b :=
by simpa using congr_arg mk h

/-- Equivalence between `erased α` and `α`. -/
noncomputable def equiv (α) : erased α ≃ α :=
⟨out, mk, mk_out, out_mk⟩

instance (α : Type u) : has_repr (erased α) := ⟨λ _, "erased"⟩
instance (α : Type u) : has_to_string (erased α) := ⟨λ _, "erased"⟩
meta instance (α : Type u) : has_to_format (erased α) := ⟨λ _, ("erased" : format)⟩

/-- Computably produce an erased value from a proof of nonemptiness. -/
def choice {α} (h : nonempty α) : erased α := mk (classical.choice h)

@[simp] theorem nonempty_iff {α} : nonempty (erased α) ↔ nonempty α :=
⟨λ ⟨a⟩, ⟨a.out⟩, λ ⟨a⟩, ⟨mk a⟩⟩

instance {α} [h : nonempty α] : inhabited (erased α) :=
⟨choice h⟩

/--
`(>>=)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `monad`).
-/
def bind {α β} (a : erased α) (f : α → erased β) : erased β :=
⟨λ b, (f a.out).1 b, (f a.out).2⟩

@[simp] theorem bind_eq_out {α β} (a f) : @bind α β a f = f a.out :=
by delta bind bind._proof_1; cases f a.out; refl

/--
Collapses two levels of erasure.
-/
def join {α} (a : erased (erased α)) : erased α := bind a id

@[simp] theorem join_eq_out {α} (a) : @join α a = a.out := bind_eq_out _ _

/--
`(<$>)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `functor`).
-/
def map {α β} (f : α → β) (a : erased α) : erased β :=
bind a (mk ∘ f)

@[simp] theorem map_out {α β} {f : α → β} (a : erased α) : (a.map f).out = f a.out :=
by simp [map]

instance : monad erased := { pure := @mk, bind := @bind, map := @map }

@[simp] lemma pure_def {α} : (pure : α → erased α) = @mk _ := rfl
@[simp] lemma bind_def {α β} : ((>>=) : erased α → (α → erased β) → erased β) = @bind _ _ := rfl
@[simp] lemma map_def {α β} : ((<$>) : (α → β) → erased α → erased β) = @map _ _ := rfl

instance : is_lawful_monad erased := by refine {..}; intros; ext; simp

end erased


/-
Copyright (c) 2017 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Jesse Michael Han
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.hint
import Mathlib.PostPort

universes l u

namespace Mathlib

/-!
# The `finish` family of tactics

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.

## Main definitions

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

-/

namespace tactic

namespace interactive

end interactive

end tactic

namespace auto

/-! ### Utilities -/

-- stolen from interactive.lean

/--
Configuration information for the auto tactics.
* `(use_simp := tt)`: call the simplifier
* `(max_ematch_rounds := 20)`: for the "done" tactic
-/
structure auto_config where
  use_simp : Bool
  max_ematch_rounds : ℕ

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

/-!
### 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)`.)
-/

theorem not_not_eq (p : Prop) : (¬¬p) = p := propext not_not

theorem not_and_eq (p : Prop) (q : Prop) : (¬(p ∧ q)) = (¬p ∨ ¬q) := propext not_and_distrib

theorem not_or_eq (p : Prop) (q : Prop) : (¬(p ∨ q)) = (¬p ∧ ¬q) := propext not_or_distrib

theorem not_forall_eq {α : Type u} (s : α → Prop) : (¬∀ (x : α), s x) = ∃ (x : α), ¬s x :=
  propext not_forall

theorem not_exists_eq {α : Type u} (s : α → Prop) : (¬∃ (x : α), s x) = ∀ (x : α), ¬s x :=
  propext not_exists

theorem not_implies_eq (p : Prop) (q : Prop) : (¬(p → q)) = (p ∧ ¬q) := propext not_imp

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

def common_normalize_lemma_names : List name := sorry

def classical_normalize_lemma_names : List name := sorry

/-- optionally returns an equivalent expression and proof of equivalence -/
/-- given an expr `e`, returns a new expression and a proof of equality -/
/-!
### Eliminate existential quantifiers
-/

/-- eliminate an existential quantifier if there is one -/
/-- eliminate all existential quantifiers, fails if there aren't any -/
/-!
### Substitute if there is a hypothesis `x = t` or `t = x`
-/

/-- carries out a subst if there is one, fails otherwise -/
/-!
### 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. -/
/-- return `tt` if any progress is made -/
/-- return `tt` if any progress is made -/
/-- fail if no progress is made -/
/-!
### Eagerly apply all the preprocessing rules
-/

/-- Eagerly apply all the preprocessing rules -/
/-!
### Terminal tactic
-/

/--
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?
-/
/--
`done` first attempts to close the goal using `contradiction`. If this fails, it creates an
SMT state and will repeatedly use `ematch` (using `ematch` lemmas in the environment,
universally quantified assumptions, and the supplied lemmas `ps`) and congruence closure.
-/
/-!
### Tactics that perform case splits
-/

inductive case_option where
| force : case_option
| at_most_one : case_option
| accept : case_option

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

/-!
### The main tactics
-/

/--
`safe_core s ps cfg opt` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `s`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `ps`) and congruence closure.

`safe_core` is complete for propositional logic. Depending on the form of `opt`
it will:

- (if `opt` is `case_option.force`) fail if it does not close the goal,
- (if `opt` is `case_option.at_most_one`) fail if it produces more than one goal, and
- (if `opt` is `case_option.accept`) ignore the number of goals it produces.
-/
/--
`clarify` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.at_most_one`.
-/
/--
`safe` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.accept`.
-/
/--
`finish` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.force`.
-/
end auto

/-! ### interactive versions -/

namespace tactic

namespace interactive

/--
`clarify [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`clarify` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`clarify` will fail if it produces more than one goal.
-/
/--
`safe [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`safe` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`safe` ignores the number of goals it produces, and should never fail.
-/
/--
`finish [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`finish` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`finish` will fail if it does not close the goal.
-/
/--
These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
end Mathlib


example (x : Int) (h : x = 2) : Int.div 2 1 = x := by
  simp [Int.div]
  trace_state
  simp [h]

example (n : Nat) : Int.div (Int.ofNat n) (Int.ofNat 0) = Int.ofNat (n / 0) := by
  simp [Int.div]

example (n : Nat) : Int.div (Int.ofNat n) 0 = Int.ofNat (n / 0) := by
  simp [Int.div]

example (n : Nat) : Int.mul (Int.ofNat n) (Int.ofNat 0) = Int.ofNat (n * 0) := by
  simp [Int.mul]

example (n : Nat) : Int.mul (Int.ofNat n) 0 = Int.ofNat (n * 0) := by
  simp [Int.mul]


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

import algebra.module.pi
import data.polynomial.basic
import group_theory.group_action.prod
import group_theory.group_action.units
import data.complex.module
import ring_theory.algebraic
import data.zmod.basic
import ring_theory.tensor_product

/-! # Tests that instances do not form diamonds -/

/-! ## Scalar action instances -/
section has_smul
open_locale polynomial

example :
  (sub_neg_monoid.has_smul_int : has_smul ℤ ℂ) = (complex.has_smul : has_smul ℤ ℂ) :=
rfl

example : restrict_scalars.module ℝ ℂ ℂ = complex.module := rfl
example : restrict_scalars.algebra ℝ ℂ ℂ = complex.algebra := rfl

example (α β : Type*) [add_monoid α] [add_monoid β] :
  (prod.has_smul : has_smul ℕ (α × β)) = add_monoid.has_smul_nat := rfl

example (α β : Type*) [sub_neg_monoid α] [sub_neg_monoid β] :
  (prod.has_smul : has_smul ℤ (α × β)) = sub_neg_monoid.has_smul_int := rfl

example (α : Type*) (β : α → Type*) [Π a, add_monoid (β a)] :
  (pi.has_smul : has_smul ℕ (Π a, β a)) = add_monoid.has_smul_nat := rfl

example (α : Type*) (β : α → Type*) [Π a, sub_neg_monoid (β a)] :
  (pi.has_smul : has_smul ℤ (Π a, β a)) = sub_neg_monoid.has_smul_int := rfl

namespace tensor_product

open_locale tensor_product
open complex

/-! The `example` below times out. TODO Fix it!

/- `tensor_product.algebra.module` forms a diamond with `has_mul.to_has_smul` and
`algebra.tensor_product.tensor_product.semiring`. Given a commutative semiring `A` over a
commutative semiring `R`, we get two mathematically different scalar actions of `A ⊗[R] A` on
itself. -/
def f : ℂ ⊗[ℝ] ℂ →ₗ[ℝ] ℝ :=
tensor_product.lift
{ to_fun    := λ z, z.re • re_lm,
  map_add'  := λ z w, by simp [add_smul],
  map_smul' := λ r z, by simp [mul_smul], }

@[simp] lemma f_apply (z w : ℂ) : f (z ⊗ₜ[ℝ] w) = z.re * w.re := by simp [f]

/- `tensor_product.algebra.module` forms a diamond with `has_mul.to_has_smul` and
`algebra.tensor_product.tensor_product.semiring`. Given a commutative semiring `A` over a
commutative semiring `R`, we get two mathematically different scalar actions of `A ⊗[R] A` on
itself. -/
example :
  has_mul.to_has_smul (ℂ ⊗[ℝ] ℂ) ≠
  (@tensor_product.algebra.module ℝ ℂ ℂ (ℂ ⊗[ℝ] ℂ) _ _ _ _ _ _ _ _ _ _ _ _).to_has_smul :=
begin
  have contra : I ⊗ₜ[ℝ] I ≠ (-1) ⊗ₜ[ℝ] 1 := λ c, by simpa using congr_arg f c,
  contrapose! contra,
  rw has_smul.ext_iff at contra,
  replace contra := congr_fun (congr_fun contra (1 ⊗ₜ I)) (I ⊗ₜ 1),
  rw @tensor_product.algebra.smul_def ℝ ℂ ℂ (ℂ ⊗[ℝ] ℂ) _ _ _ _ _ _ _ _ _ _ _ _
    (1 : ℂ) I (I ⊗ₜ[ℝ] (1 : ℂ)) at contra,
  simpa only [algebra.id.smul_eq_mul, algebra.tensor_product.tmul_mul_tmul, one_mul, mul_one,
    one_smul, tensor_product.smul_tmul', I_mul_I] using contra,
end

-/

end tensor_product

section units

example (α : Type*) [monoid α] :
  (units.mul_action : mul_action αˣ (α × α)) = prod.mul_action := rfl

example (R α : Type*) (β : α → Type*) [monoid R] [Π i, mul_action R (β i)] :
  (units.mul_action : mul_action Rˣ (Π i, β i)) = pi.mul_action _ := rfl

example (R α : Type*) (β : α → Type*) [monoid R] [semiring α] [distrib_mul_action R α] :
  (units.distrib_mul_action : distrib_mul_action Rˣ α[X]) =
    polynomial.distrib_mul_action :=
rfl

/-!
TODO: https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/units.2Emul_action'.20diamond/near/246402813
```lean
example {α : Type*} [comm_monoid α] :
  (units.mul_action' : mul_action αˣ αˣ) = monoid.to_mul_action _ :=
rfl -- fails
```
-/

end units

end has_smul

/-! ## `with_top` (Type with point at infinity) instances -/
section with_top

example (R : Type*) [h : strict_ordered_semiring R] :
  (@with_top.add_comm_monoid R
    (@non_unital_non_assoc_semiring.to_add_comm_monoid R
      (@non_assoc_semiring.to_non_unital_non_assoc_semiring R
        (@semiring.to_non_assoc_semiring R
          (@strict_ordered_semiring.to_semiring R h)))))
        =
  (@ordered_add_comm_monoid.to_add_comm_monoid (with_top R)
    (@with_top.ordered_add_comm_monoid R
      (@ordered_cancel_add_comm_monoid.to_ordered_add_comm_monoid R
        (@strict_ordered_semiring.to_ordered_cancel_add_comm_monoid R h)))) :=
rfl

end with_top

/-! ## `multiplicative` instances -/
section multiplicative

example :
  @monoid.to_mul_one_class (multiplicative ℕ) (comm_monoid.to_monoid _) =
    multiplicative.mul_one_class :=
rfl

-- `dunfold` can still break unification, but it's better to have `dunfold` break it than have the
-- above example fail.
example :
  @monoid.to_mul_one_class (multiplicative ℕ) (comm_monoid.to_monoid _) =
    multiplicative.mul_one_class :=
begin
  dunfold has_one.one multiplicative.mul_one_class,
  success_if_fail { refl, },
  ext,
  refl
end

end multiplicative

/-! ## `finsupp` instances-/

section finsupp
open finsupp

/-- `finsupp.comap_has_smul` can form a non-equal diamond with `finsupp.smul_zero_class` -/
example {k : Type*} [semiring k] [nontrivial k] :
  (finsupp.comap_has_smul : has_smul k (k →₀ k)) ≠ finsupp.smul_zero_class.to_has_smul :=
begin
  obtain ⟨u : k, hu⟩ := exists_ne (1 : k),
  intro h,
  simp only [has_smul.ext_iff, function.funext_iff, finsupp.ext_iff] at h,
  replace h := h u (finsupp.single 1 1) u,
  classical,
  rw [comap_smul_single, smul_apply, smul_eq_mul, mul_one, single_eq_same,
    smul_eq_mul, single_eq_of_ne hu.symm, mul_zero] at h,
  exact one_ne_zero h,
end

/-- `finsupp.comap_has_smul` can form a non-equal diamond with `finsupp.smul_zero_class` even when
the domain is a group. -/
example {k : Type*} [semiring k] [nontrivial kˣ] :
  (finsupp.comap_has_smul : has_smul kˣ (kˣ →₀ k)) ≠ finsupp.smul_zero_class.to_has_smul :=
begin
  obtain ⟨u : kˣ, hu⟩ := exists_ne (1 : kˣ),
  haveI : nontrivial k := ⟨⟨u, 1, units.ext.ne hu⟩⟩,
  intro h,
  simp only [has_smul.ext_iff, function.funext_iff, finsupp.ext_iff] at h,
  replace h := h u (finsupp.single 1 1) u,
  classical,
  rw [comap_smul_single, smul_apply, units.smul_def, smul_eq_mul, mul_one, single_eq_same,
    smul_eq_mul, single_eq_of_ne hu.symm, mul_zero] at h,
  exact one_ne_zero h,
end

end finsupp

/-! ## `polynomial` instances -/
section polynomial

variables (R A : Type*)
open_locale polynomial
open polynomial

/-- `polynomial.has_smul_pi` forms a diamond with `pi.has_smul`. -/
example [semiring R] [nontrivial R] :
  polynomial.has_smul_pi _ _ ≠ (pi.has_smul : has_smul R[X] (R → R[X])) :=
begin
  intro h,
  simp_rw [has_smul.ext_iff, function.funext_iff, polynomial.ext_iff] at h,
  simpa using h X 1 1 0,
end

/-- `polynomial.has_smul_pi'` forms a diamond with `pi.has_smul`. -/
example [comm_semiring R] [nontrivial R] :
  polynomial.has_smul_pi' _ _ _ ≠ (pi.has_smul : has_smul R[X] (R → R[X])) :=
begin
  intro h,
  simp_rw [has_smul.ext_iff, function.funext_iff, polynomial.ext_iff] at h,
  simpa using h X 1 1 0,
end

/-- `polynomial.has_smul_pi'` is consistent with `polynomial.has_smul_pi`. -/
example [comm_semiring R] [nontrivial R] :
  polynomial.has_smul_pi' _ _ _ = (polynomial.has_smul_pi _ _ : has_smul R[X] (R → R[X])) :=
rfl

/-- `polynomial.algebra_of_algebra` is consistent with `algebra_nat`. -/
example [semiring R] : (polynomial.algebra_of_algebra : algebra ℕ R[X]) = algebra_nat := rfl

/-- `polynomial.algebra_of_algebra` is consistent with `algebra_int`. -/
example [ring R] : (polynomial.algebra_of_algebra : algebra ℤ R[X]) = algebra_int _ := rfl

end polynomial

/-! ## `subtype` instances -/
section subtype

-- this diamond is the reason that `fintype.to_locally_finite_order` is not an instance
example {α} [preorder α] [locally_finite_order α] [fintype α] [@decidable_rel α (<)]
  [@decidable_rel α (≤)] (p : α → Prop) [decidable_pred p] :
  subtype.locally_finite_order p = fintype.to_locally_finite_order :=
begin
  success_if_fail { refl, },
  exact subsingleton.elim _ _
end

end subtype

/-! ## `zmod` instances -/
section zmod

variables {p : ℕ} [fact p.prime]

example : @euclidean_domain.to_comm_ring _ (@field.to_euclidean_domain _ (zmod.field p)) =
  zmod.comm_ring p :=
rfl

example (n : ℕ) : zmod.comm_ring (n + 1) = fin.comm_ring (n + 1) := rfl
example : zmod.comm_ring 0 = int.comm_ring := rfl

end zmod


import .logic

class atom_type (α β : Type) :=
(val : list β → α → Prop)
(neg : α → fm α)
(neg_nqfree : ∀ (a : α), nqfree (neg a))
(neg_prsv : ∀ (a : α) (xs : list β), (interp val xs (neg a)) ↔ (interp val xs (¬' A' a)))
(dep0 : α → Prop)
(dec_dep0 : decidable_pred dep0)
(decr : α → α)
(decr_prsv : ∀ {a : α} {hd : ¬ (dep0 a)} {b : β} {bs : list β}, (val bs (decr a) ↔ val (b::bs) a))
(inh : β)
(dec_eq : decidable_eq α)
(normal : α → Prop)
(dec_normal : decidable_pred normal)
(neg_prsv_normal : ∀ a, (normal a → ∀ a' ∈ (atoms (neg a)), normal a'))
(decr_prsv_normal : ∀ a, normal a → ¬ dep0 a → normal (decr a))

class atom_eq_type (α β : Type) extends atom_type α β :=
(solv0 : α → Prop)
(dec_solv0 : decidable_pred solv0)
(dest_solv0 : ∀ a, solv0 a → nat)
(solv0_eq : ∀ {e : α} (He : solv0 e) {b} {bs}, val (b::bs) e
  → list.nth_dft (atom_type.inh α β) (b::bs) (dest_solv0 e He) = b)
(trivial : α → Prop)
(dec_triv : decidable_pred trivial)
(true_triv : ∀ a, trivial a → ∀ xs, val xs a)
(subst0 : α → α → α)
(true_subst : ∀ e, solv0 e → ∀ bs, val bs (subst0 e e))
(subst_prsv : ∀ {e : α} (He : solv0 e), ∀ {a : α} {bs : list β},
  val bs (subst0 e a) ↔ val ((list.nth_dft (atom_type.inh α β) bs (dest_solv0 e He - 1))::bs) a)
(dest_pos : ∀ {a} {Ha : solv0 a}, ¬ trivial a → dest_solv0 a Ha > 0)

-- subst_eqn i j k returns the result of taking an
-- identity atom of form (i = j) and using it to
-- substitute a de Brujin variable k.
-- Requires : j = 0 ↔ ¬(i = 0)
def subst_eqn : nat → nat → nat → nat
| 0 j 0 := j - 1
| (i+1) _ 0 := i
| _ _ k := k - 1

def isubst (k) : nat → nat
| 0 := k
| (i + 1) := i

-- Qstn : Why do I need this? (Why doesn't unfold work?)
lemma exp_subst_eqn_i0 (i) : subst_eqn (i+1) 0 0 = i :=
begin refl end

variables {α β : Type}

def I [atom_type α β] (p : fm α) (xs : list β) := interp (atom_type.val) xs p

lemma exp_I [atom_type α β] {p : fm α} {xs : list β} :
  I p xs = interp (atom_type.val) xs p := refl _

lemma exp_I_and [atom_type α β] (p q : fm α) (xs : list β) :
  I (p ∧' q) xs = ((I p xs) ∧ (I q xs)) := eq.refl _

lemma exp_I_and_o [atom_type α β] (p q : fm α) (xs : list β) :
  I (and_o p q) xs = ((I p xs) ∧ (I q xs)) :=
begin
  apply (cases_and_o' (λ p q pq, ((I pq xs) = ((I p xs) ∧ (I q xs)))) p q),
  repeat {unfold I, unfold interp, simp},
  unfold I, unfold interp
end

lemma exp_I_or [atom_type α β] (p q : fm α) (xs : list β) :
  I (p ∨' q) xs = ((I p xs) ∨ (I q xs)) := eq.refl _

lemma exp_I_or_o [atom_type α β] (p q : fm α) (xs : list β) :
  I (or_o p q) xs ↔ ((I p xs) ∨ (I q xs)) :=
begin
  apply (cases_or_o' (λ p q pq, ((I pq xs) ↔ ((I p xs) ∨ (I q xs)))) p q),
  repeat {unfold I, unfold interp, simp},
  unfold I, unfold interp
end

lemma exp_I_not [atom_type α β] (p : fm α) (xs : list β) :
  I (¬' p) xs = ¬ (I p xs) := eq.refl _

lemma exp_I_not_o [atom_type α β] (p : fm α) :
  ∀ (xs : list β), I (not_o p) xs ↔ ¬ (I p xs) :=
by cases p; {unfold not_o, unfold I, unfold interp, try {simp}}

lemma exp_I_ex [atom_type α β] (p : fm α) (xs) : @I α β _ (∃' p) xs = ∃ x, (I p (x::xs)) :=
by unfold I; unfold interp

lemma exp_I_top [atom_type α β] (xs) : @I α β _ ⊤' xs = true :=
by unfold I; unfold interp

lemma exp_I_bot [atom_type α β] (xs) : @I α β _ ⊥' xs = false :=
by unfold I; unfold interp

lemma I_not_dep0 [atom_type α β] (a : α) (b : β) (bs : list β) :
  ¬ atom_type.dep0 β a
  → (I (A' a) (b::bs) ↔ I (A' (atom_type.decr β a)) bs) :=
begin
  intro h, unfold I, unfold interp,
  rewrite atom_type.decr_prsv, apply h
end

def fnormal_alt (β) [atom_type α β] (p : fm α) :=
  ∀ a ∈ (@atoms _ (atom_type.dec_eq _ β) p), atom_type.normal β a

def fnormal (β) [atom_type α β] : fm α → Prop
| ⊤' := true
| ⊥' := true
| (A' a) := atom_type.normal β a
| (p ∧' q) := fnormal p ∧ fnormal q
| (p ∨' q) := fnormal p ∧ fnormal q
| (¬' p) := fnormal p
| (∃' p) := fnormal p

instance dec_fnormal (β) [atom_type α β] : decidable_pred (@fnormal α β _)
| ⊤' := decidable.is_true trivial
| ⊥' := decidable.is_true trivial
| (A' a) :=
  begin
    unfold fnormal,
    apply atom_type.dec_normal α β
  end
| (p ∧' q) :=
  begin
    unfold fnormal,
    apply @and.decidable _ _ _ _;
    apply dec_fnormal
  end
| (p ∨' q) :=
  begin
    unfold fnormal,
    apply @and.decidable _ _ _ _;
    apply dec_fnormal
  end
| (¬' p) :=
  begin
    unfold fnormal,
    apply dec_fnormal
  end
| (∃' p) :=
  begin
    unfold fnormal,
    apply dec_fnormal
  end

lemma fnormal_iff_fnormal_alt [atom_type α β] :
  ∀ {p : fm α}, fnormal β p ↔ fnormal_alt β p
| ⊤' := true_iff_true trivial (λ a ha, by cases ha)
| ⊥' := true_iff_true trivial (λ a ha, by cases ha)
| (A' a) :=
  begin
    unfold fnormal,
    unfold fnormal_alt, unfold atoms,
    apply iff.intro; intro h,
    intros a' ha', cases ha' with he he,
    subst he, apply h, cases he,
    apply h, apply or.inl rfl
  end
| (p ∧' q) :=
  begin
    unfold fnormal,
    repeat {rewrite fnormal_iff_fnormal_alt},
    apply iff.symm, apply list.forall_mem_union
  end
| (p ∨' q) :=
  begin
    unfold fnormal,
    repeat {rewrite fnormal_iff_fnormal_alt},
    apply iff.symm, apply list.forall_mem_union
  end
| (¬' p) :=
  begin
    unfold fnormal,
    rewrite fnormal_iff_fnormal_alt, refl
  end
| (∃' p) :=
  begin
    unfold fnormal,
    rewrite fnormal_iff_fnormal_alt, refl
  end

def disj_to_prop (β) [atom_type α β] (as : list α) (bs : list β) : Prop :=
  ∀ a ∈ as, atom_type.val bs a

instance atoms_dec_eq [atom_type α β] : decidable_eq α :=
atom_type.dec_eq α β

instance atoms_dec_dep0 [atom_type α β] : decidable_pred (atom_type.dep0 β) :=
atom_type.dec_dep0 α β

def atoms_dep0 (β) [atom_type α β] (p : fm α) :=
list.filter (atom_type.dep0 β) (atoms p)


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Jesse Michael Han
-/
import tactic.rcases
import logic.function.basic

universes u₁ u₂

open interactive interactive.types
section ext
open lean.parser nat tactic

declare_trace ext

/--
`derive_struct_ext_lemma n` generates two extensionality lemmas based on
the equality of all non-propositional projections.

On the following:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

`derive_struct_lemma` generates:

```lean
lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
  x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
  x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
meta def derive_struct_ext_lemma (n : name) : tactic name :=
do e ← get_env,
   fs ← e.structure_fields n,
   d ← get_decl n,
   n ← resolve_constant n,
   let r := @expr.const tt n $ d.univ_params.map level.param,
   (args,_) ← infer_type r >>= open_pis,
   let args := args.map expr.to_implicit_local_const,
   let t := r.mk_app args,
   x ← mk_local_def `x t,
   y ← mk_local_def `y t,
   let args_x := args ++ [x],
   let args_y := args ++ [y],
   bs ← fs.mmap $ λ f,
     do { d ← get_decl (n ++ f),
          let a := @expr.const tt (n ++ f) $ d.univ_params.map level.param,
          t ← infer_type a,
          s ← infer_type t,

          if s ≠ `(Prop)
            then do
              let x := a.mk_app args_x,
              let y := a.mk_app args_y,
              t ← infer_type x,
              t' ← infer_type y,
              some <$> if t = t'
                then mk_app `eq [x,y] >>= mk_local_def `h
                else mk_mapp `heq [none,x,none,y] >>= mk_local_def `h
            else pure none },
   let bs := bs.filter_map id,
   eq_t ← mk_app `eq [x,y],
   t ← pis (args ++ [x,y] ++ bs) eq_t,
   pr ← run_async $
     do { (_,pr) ← solve_aux t (do
          { args ← intron args.length,
            x ← intro1, y ← intro1,
            cases x, cases y,
            bs.mmap' (λ _,
              do e ← intro1,
                 cases e),
            reflexivity }),
          instantiate_mvars pr },
   let decl_n := n <.> "ext",
   add_decl (declaration.thm decl_n d.univ_params t pr),
   bs ← bs.mmap infer_type,
   let rhs := expr.mk_and_lst bs,
   iff_t ← mk_app `iff [eq_t,rhs],
   t ← pis (args ++ [x,y]) iff_t,
   pr ← run_async $
     do { (_,pr) ← solve_aux t $ do
          { args ← intron args.length,
            x ← intro1, y ← intro1,
            cases x, cases y,
            split,
            solve1 $ do
            { h ← intro1, hs ← injection h, subst_vars,
              repeat (refine ``( and.intro _ _ ) >> reflexivity ),
              done <|> reflexivity },
            solve1 $ do
            { repeat (do refine ``(and_imp.mpr _),
                         h ← intro1, cases h, skip ),
              h ← intro1, cases h,
              reflexivity } },
          instantiate_mvars pr },
   add_decl (declaration.thm (n <.> "ext_iff") d.univ_params t pr),
   pure decl_n

meta def get_ext_subject : expr → tactic name
| (expr.pi n bi d b) :=
  do v  ← mk_local' n bi d,
     b' ← whnf $ b.instantiate_var v,
     get_ext_subject b'
| (expr.app _ e) :=
  do t ← infer_type e >>= instantiate_mvars >>= head_beta,
     if t.get_app_fn.is_constant then
       pure $ t.get_app_fn.const_name
     else if t.is_pi then
       pure $ name.mk_numeral 0 name.anonymous
     else if t.is_sort then
       pure $ name.mk_numeral 1 name.anonymous
     else do
       t ← pp t,
       fail format!"only constants and Pi types are supported: {t}"
| e := fail format!"Only expressions of the form `_ → _ → ... → R ... e are supported: {e}"

open native

meta def saturate_fun : name → tactic expr
| (name.mk_numeral 0 name.anonymous) :=
do v₀ ← mk_mvar,
   v₁ ← mk_mvar,
   return $ v₀.imp v₁
| (name.mk_numeral 1 name.anonymous) :=
do u ← mk_meta_univ,
   pure $ expr.sort u
| n :=
do e ← resolve_constant n >>= mk_const,
   a ← get_arity e,
   e.mk_app <$> (list.iota a).mmap (λ _, mk_mvar)

meta def equiv_type_constr (n n' : name) : tactic unit :=
do e  ← saturate_fun n,
   e' ← saturate_fun n',
   unify e e' <|> fail format!"{n} and {n'} are not definitionally equal types"

section performance_hack
/--
For performance reasons, it is inadvisable to use `user_attribute.get_param`.
The parameter is stored as a reflected expression.  When calling `get_param`,
the stored parameter is evaluated using `eval_expr`, which first compiles the
expression into VM bytecode. The unevaluated expression is available using
`user_attribute.get_param_untyped`.

In particular, `user_attribute.get_param` MUST NEVER BE USED in the
implementation of an attribute cache. This is because calling `eval_expr`
disables the attribute cache.

There are several possible workarounds:
 1. Set a different attribute depending on the parameter.
 2. Use your own evaluation function instead of `eval_expr`, such as e.g. `expr.to_nat`.
 3. Write your own `has_reflect Param` instance (using a more efficient serialization format).
   The `user_attribute` code unfortunately checks whether the expression has the correct type,
   but you can use `` `(id %%e : Param) `` to pretend that your expression `e` has type `Param`.
-/
library_note "user attribute parameters"

/-!
For performance reasons, the parameters of the `@[ext]` attribute are stored
in two auxiliary attributes:
```lean
attribute [ext thunk] funext

-- is turned into
attribute [_ext_core (@id name @funext)] thunk
attribute [_ext_lemma_core] funext
```

see Note [user attribute parameters]
-/

local attribute [semireducible] reflected

local attribute [instance, priority 9000]
private meta def hacky_name_reflect : has_reflect name :=
λ n, `(id %%(expr.const n []) : name)

@[user_attribute]
private meta def ext_attr_core : user_attribute (name_map name) name :=
{ name := `_ext_core,
  descr := "(internal attribute used by ext)",
  cache_cfg :=
  { dependencies := [],
    mk_cache := λ ns, ns.mfoldl (λ m n, do
      ext_l ← ext_attr_core.get_param_untyped n,
      pure (m.insert n ext_l.app_arg.const_name)) mk_name_map },
  parser := failure }

end performance_hack

/-- Private attribute used to tag extensionality lemmas. -/
@[user_attribute]
private meta def ext_lemma_attr_core : user_attribute :=
{ name := `_ext_lemma_core,
  descr := "(internal attribute used by ext)",
  parser := failure }

/--
Returns the extensionality lemmas in the environment, as a map from structure
name to lemma name.
-/
meta def get_ext_lemmas : tactic (name_map name) :=
ext_attr_core.get_cache

/--
Returns the extensionality lemmas in the environment, as a list of lemma names.
-/
meta def get_ext_lemma_names : tactic (list name) :=
attribute.get_instances ext_lemma_attr_core.name

/-- Marks `lem` as an extensionality lemma corresponding to type constructor `constr`;
if `persistent` is true then this is a global attribute, else local. -/
meta def add_ext_lemma (constr lem : name) (persistent : bool) : tactic unit :=
ext_attr_core.set constr lem persistent >> ext_lemma_attr_core.set lem () persistent

/--
Tag lemmas of the form:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The attribute indexes extensionality lemma using the type of the
objects (i.e. `my_collection`) which it gets from the statement of
the lemma.  In some cases, the same lemma can be used to state the
extensionality of multiple types that are definitionally equivalent.

```lean
attribute [ext thunk, ext stream] funext
```

Also, the following:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

is equivalent to

```lean
@[ext my_collection]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

This allows us specify type synonyms along with the type
that is referred to in the lemma statement.

```lean
@[ext, ext my_type_synonym]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The `ext` attribute can be applied to a structure to generate its extensionality lemmas:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

will generate:

```lean
@[ext] lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
@[user_attribute]
meta def extensional_attribute : user_attribute unit (option name) :=
{ name := `ext,
  descr := "lemmas usable by `ext` tactic",
  parser := optional ident,
  after_set := some $ λ n _ b, do
    add ← extensional_attribute.get_param n,
    e ← get_env,
    n ← if (e.structure_fields n).is_some
      then derive_struct_ext_lemma n
      else pure n,
    s ← mk_const n >>= infer_type >>= get_ext_subject,
    match add with
    | none := add_ext_lemma s n b
    | some add := equiv_type_constr s add >> add_ext_lemma add n b
    end }

add_tactic_doc
{ name                     := "ext",
  category                 := doc_category.attr,
  decl_names               := [`extensional_attribute],
  tags                     := ["rewrite", "logic"] }

/--
When possible, `ext` lemmas are stated without a full set of arguments. As an example, for bundled
homs `f`, `g`, and `of`, `f.comp of = g.comp of → f = g` is a better `ext` lemma than
`(∀ x, f (of x) = g (of x)) → f = g`, as the former allows a second type-specific extensionality
lemmas to be applied to `f.comp of = g.comp of`.
If the domain of `of` is `ℕ` or `ℤ` and `of` is a `ring_hom`, such a lemma could then make the goal
`f (of 1) = g (of 1)`.

For bundled morphisms, there is a `ext` lemma that always applies of the form
`(∀ x, ⇑f x = ⇑g x) → f = g`. When adding type-specific `ext` lemmas like the one above, we want
these to be tried first. This happens automatically since the type-specific lemmas are inevitably
defined later.
-/
library_note "partially-applied ext lemmas"

-- We mark some existing extensionality lemmas.
attribute [ext] array.ext propext function.hfunext
attribute [ext thunk] _root_.funext

-- This line is equivalent to:
--   attribute [ext (→)] _root_.funext
-- but (→) is not actually a binary relation with a constant at the head,
-- so we use the special name [anon].0 to represent (→).
run_cmd add_ext_lemma (name.mk_numeral 0 name.anonymous) ``_root_.funext tt

-- We create some extensionality lemmas for existing structures.
attribute [ext] ulift

namespace plift
-- This is stronger than the one generated automatically.
@[ext] lemma ext {P : Prop} (a b : plift P) : a = b :=
begin
  cases a, cases b, refl
end
end plift

-- Conservatively, we'll only add extensionality lemmas for `has_*` structures
-- as they become useful.
attribute [ext] has_zero

@[ext] lemma unit.ext {x y : unit} : x = y := by { cases x, cases y, refl, }
@[ext] lemma punit.ext {x y : punit} : x = y := by { cases x, cases y, refl, }

namespace tactic

/-- Helper structure for `ext` and `ext1`. `lemmas` keeps track of extensionality lemmas
  applied so far. -/
meta structure ext_state : Type :=
(patts : list rcases_patt := [])
(trace_msg : list string := [])
(fuel : option ℕ := none)

/-- Helper function for `try_intros`. Additionally populates the `trace_msg` field
  of `ext_state`. -/
private meta def try_intros_core : state_t ext_state tactic unit :=
do ⟨patts, trace_msg, fuel⟩ ← get,
   match patts with
   | [] := do { es ← state_t.lift intros, when (es.length > 0) $ do
                let msg := "intros " ++ (" ".intercalate (es.map (λ e, e.local_pp_name.to_string))),
                modify (λ ⟨patts, trace_msg, fuel⟩, ⟨patts, trace_msg ++ [msg], fuel⟩) }
             <|> pure ()
   | (x::xs) :=
     do tgt ← state_t.lift (target >>= whnf),
        when tgt.is_pi $
          do state_t.lift (rintro [x]),
             msg ← state_t.lift (((++) "rintro ") <$> format.to_string <$> x.format ff),
             modify (λ ⟨_, trace_msg, fuel⟩, ⟨xs, trace_msg ++ [msg], fuel⟩),
             try_intros_core
   end

/-- Try to introduce as many arguments as possible, using the given patterns to destruct the
  introduced variables. Returns the unused patterns. -/
meta def try_intros (patts : list rcases_patt) : tactic (list rcases_patt) :=
let σ := ext_state.mk patts [] none in
  (ext_state.patts ∘ prod.snd) <$> state_t.run try_intros_core σ

/-- Apply one extensionality lemma, and destruct the arguments using the patterns
  in the ext_state. -/
meta def ext1_core (cfg : apply_cfg := {}) : state_t ext_state tactic unit :=
do ⟨patts, trace_msg, _⟩ ← get,
   (new_msgs) ← state_t.lift $ focus1 $
   do { m ← get_ext_lemmas,
         tgt ← target,
         when_tracing `ext $ trace!"[ext] goal: {tgt}",
         subject ← get_ext_subject tgt,
         new_trace_msg ←
           do { rule ← (m.find subject),
                if is_trace_enabled_for `ext then
                  trace!"[ext] matched goal to rule: {rule}" >>
                  timetac "[ext] application attempt time" (applyc rule cfg)
                else applyc rule cfg,
                pure (["apply " ++ rule.to_string]) } <|>
             do { ls ← get_ext_lemma_names,
                  let nms := ls.map name.to_string,
                  rule ← (ls.any_of (λ n,
                    (if is_trace_enabled_for `ext then
                      trace!"[ext] trying to apply ext lemma: {n}" >>
                      timetac "[ext] application attempt time" (applyc n cfg)
                    else applyc n cfg) *> pure n)),
                  pure (["apply " ++ rule.to_string]) } <|>
               (fail format!"no applicable extensionality rule found for {subject}"),
         pure new_trace_msg },
    modify (λ ⟨patts, trace_msg, fuel⟩, ⟨patts, trace_msg ++ new_msgs, fuel⟩),
    try_intros_core

/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns. -/
meta def ext_core (cfg : apply_cfg := {}) : state_t ext_state tactic unit :=
do acc@⟨_, _, fuel⟩ ← get,
   match fuel with
   | (some 0) := pure ()
   | n        := do { ext1_core cfg,
                      modify (λ ⟨patts, lemmas, _⟩, ⟨patts, lemmas, nat.pred <$> n⟩),
                      ext_core <|> pure () }
   end

/-- Apply one extensionality lemma, and destruct the arguments using the given patterns.
  Returns the unused patterns. -/
meta def ext1 (xs : list rcases_patt) (cfg : apply_cfg := {})
  (trace : bool := ff) : tactic (list rcases_patt) :=
do ⟨_, σ⟩ ← state_t.run (ext1_core cfg) {patts := xs},
   when trace $ tactic.trace $ "Try this: " ++  ", ".intercalate σ.trace_msg,
   pure σ.patts

/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns.
  `ext ps (some n)` applies at most `n` extensionality lemmas. Returns the unused patterns. -/
meta def ext (xs : list rcases_patt) (fuel : option ℕ) (cfg : apply_cfg := {})
  (trace : bool := ff) : tactic (list rcases_patt) :=
do ⟨_, σ⟩ ← state_t.run (ext_core cfg) {patts := xs, fuel := fuel},
   when trace $ tactic.trace $ "Try this: " ++  ", ".intercalate σ.trace_msg,
   pure σ.patts

local postfix (name := parser.optional) `?`:9001 := optional
local postfix (name := parser.many) *:9001 := many

/--
`ext1 id` selects and apply one extensionality lemma (with attribute
`ext`), using `id`, if provided, to name a local constant
introduced by the lemma. If `id` is omitted, the local constant is
named automatically, as per `intro`. Placing a `?` after `ext1`
 (e.g. `ext1? i ⟨a,b⟩ : 3`) will display a sequence of tactic
applications that can replace the call to `ext1`.
-/
meta def interactive.ext1 (trace : parse (tk "?")?)
  (xs : parse rcases_patt_parse_hi*) : tactic unit :=
ext1 xs {} trace.is_some $> ()

/--
- `ext` applies as many extensionality lemmas as possible;
- `ext ids`, with `ids` a list of identifiers, finds extentionality and applies them
  until it runs out of identifiers in `ids` to name the local constants.
- `ext` can also be given an `rcases` pattern in place of an identifier.
  This will destruct the introduced local constant.
- Placing a `?` after `ext` (e.g. `ext? i ⟨a,b⟩ : 3`) will display
  a sequence of tactic applications that can replace the call to `ext`.
- `set_option trace.ext true` will trace every attempted lemma application,
  along with the time it takes for the application to succeed or fail.
  This is useful for debugging slow `ext` calls.

When trying to prove:

```lean
α β : Type,
f g : α → set β
⊢ f = g
```

applying `ext x y` yields:

```lean
α β : Type,
f g : α → set β,
x : α,
y : β
⊢ y ∈ f x ↔ y ∈ f x
```

by applying functional extensionality and set extensionality.

When trying to prove:

```lean
α β γ : Type
f g : α × β → γ
⊢ f = g
```

applying `ext ⟨a, b⟩` yields:

```lean
α β γ : Type,
f g : α × β → γ,
a : α,
b : β
⊢ f (a, b) = g (a, b)
```

by applying functional extensionality and destructing the introduced pair.

In the previous example, applying `ext? ⟨a,b⟩` will produce the trace message:

```lean
Try this: apply funext, rintro ⟨a, b⟩
```

A maximum depth can be provided with `ext x y z : 3`.
-/
meta def interactive.ext :
  (parse $ (tk "?")?) → parse rintro_patt_parse_hi* → parse (tk ":" *> small_nat)? → tactic unit
 | trace [] (some n)  := iterate_range 1 n (ext1 [] {} trace.is_some $> ())
 | trace [] none      := repeat1 (ext1 [] {} trace.is_some $> ())
 | trace xs n         := ext xs.join n {} trace.is_some $> ()

/--
* `ext1 id` selects and apply one extensionality lemma (with
  attribute `ext`), using `id`, if provided, to name a
  local constant introduced by the lemma. If `id` is omitted, the
  local constant is named automatically, as per `intro`.

* `ext` applies as many extensionality lemmas as possible;
* `ext ids`, with `ids` a list of identifiers, finds extensionality lemmas
  and applies them until it runs out of identifiers in `ids` to name
  the local constants.
* `ext` can also be given an `rcases` pattern in place of an identifier.
  This will destruct the introduced local constant.
- Placing a `?` after `ext`/`ext1` (e.g. `ext? i ⟨a,b⟩ : 3`) will display
  a sequence of tactic applications that can replace the call to `ext`/`ext1`.
- `set_option trace.ext true` will trace every attempted lemma application,
  along with the time it takes for the application to succeed or fail.
  This is useful for debugging slow `ext` calls.

When trying to prove:

```lean
α β : Type,
f g : α → set β
⊢ f = g
```

applying `ext x y` yields:

```lean
α β : Type,
f g : α → set β,
x : α,
y : β
⊢ y ∈ f x ↔ y ∈ g x
```
by applying functional extensionality and set extensionality.

When trying to prove:

```lean
α β γ : Type
f g : α × β → γ
⊢ f = g
```

applying `ext ⟨a, b⟩` yields:

```lean
α β γ : Type,
f g : α × β → γ,
a : α,
b : β
⊢ f (a, b) = g (a, b)
```

by applying functional extensionality and destructing the introduced pair.

In the previous example, applying `ext? ⟨a,b⟩` will produce the trace message:

```lean
Try this: apply funext, rintro ⟨a, b⟩
```

A maximum depth can be provided with `ext x y z : 3`.
-/
add_tactic_doc
{ name        := "ext1 / ext",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.ext1, `tactic.interactive.ext],
  tags        := ["rewriting", "logic"] }

end tactic
end ext


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.nodup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The cartesian product of multisets
-/

namespace multiset

/-- Given `δ : α → Type*`, `pi.empty δ` is the trivial dependent function out of the empty
multiset. -/
def pi.empty {α : Type u_1} (δ : α → Type u_2) (a : α) (H : a ∈ 0) : δ a := sorry

/-- Given `δ : α → Type*`, a multiset `m` and a term `a`, as well as a term `b : δ a` and a
function `f` such that `f a' : δ a'` for all `a'` in `m`, `pi.cons m a b f` is a function `g` such
that `g a'' : δ a''` for all `a''` in `a ::ₘ m`. -/
def pi.cons {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} (m : multiset α) (a : α) (b : δ a)
    (f : (a : α) → a ∈ m → δ a) (a' : α) (H : a' ∈ a ::ₘ m) : δ a' :=
  dite (a' = a) (fun (h : a' = a) => Eq._oldrec b (Eq.symm h)) fun (h : ¬a' = a) => f a' sorry

theorem pi.cons_same {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} {m : multiset α} {a : α}
    {b : δ a} {f : (a : α) → a ∈ m → δ a} (h : a ∈ a ::ₘ m) : pi.cons m a b f a h = b :=
  dif_pos rfl

theorem pi.cons_ne {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} {m : multiset α} {a : α}
    {a' : α} {b : δ a} {f : (a : α) → a ∈ m → δ a} (h' : a' ∈ a ::ₘ m) (h : a' ≠ a) :
    pi.cons m a b f a' h' = f a' (or.resolve_left (iff.mp mem_cons h') h) :=
  dif_neg h

theorem pi.cons_swap {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} {a : α} {a' : α} {b : δ a}
    {b' : δ a'} {m : multiset α} {f : (a : α) → a ∈ m → δ a} (h : a ≠ a') :
    pi.cons (a' ::ₘ m) a b (pi.cons m a' b' f) == pi.cons (a ::ₘ m) a' b' (pi.cons m a b f) :=
  sorry

/-- `pi m t` constructs the Cartesian product over `t` indexed by `m`. -/
def pi {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} (m : multiset α)
    (t : (a : α) → multiset (δ a)) : multiset ((a : α) → a ∈ m → δ a) :=
  multiset.rec_on m (singleton sorry)
    (fun (a : α) (m : multiset α) (p : multiset ((a : α) → a ∈ m → δ a)) =>
      bind (t a) fun (b : δ a) => map sorry p)
    sorry

@[simp] theorem pi_zero {α : Type u_1} [DecidableEq α] {δ : α → Type u_2}
    (t : (a : α) → multiset (δ a)) : pi 0 t = pi.empty δ ::ₘ 0 :=
  rfl

@[simp] theorem pi_cons {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} (m : multiset α)
    (t : (a : α) → multiset (δ a)) (a : α) :
    pi (a ::ₘ m) t = bind (t a) fun (b : δ a) => map (pi.cons m a b) (pi m t) :=
  rec_on_cons a m

theorem pi_cons_injective {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} {a : α} {b : δ a}
    {s : multiset α} (hs : ¬a ∈ s) : function.injective (pi.cons s a b) :=
  sorry

theorem card_pi {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} (m : multiset α)
    (t : (a : α) → multiset (δ a)) :
    coe_fn card (pi m t) = prod (map (fun (a : α) => coe_fn card (t a)) m) :=
  sorry

theorem nodup_pi {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} {s : multiset α}
    {t : (a : α) → multiset (δ a)} : nodup s → (∀ (a : α), a ∈ s → nodup (t a)) → nodup (pi s t) :=
  sorry

theorem mem_pi {α : Type u_1} [DecidableEq α] {δ : α → Type u_2} (m : multiset α)
    (t : (a : α) → multiset (δ a)) (f : (a : α) → a ∈ m → δ a) :
    f ∈ pi m t ↔ ∀ (a : α) (h : a ∈ m), f a h ∈ t a :=
  sorry

end Mathlib


example (P Q R S T U: Type) (p: P) (h: P → Q) (i: Q → R) (j: Q → T) (k: S → T) (l: T → U) : U :=
begin
    apply l,
    apply j,
    apply h,
    exact p,
end