import convex convex_body brunn_minkowski microid
  measure set_pi
  init.data.fin.ops

open_locale pointwise
open_locale topological_space
open_locale nat

-- needed to get decidable_eq for sets!
open classical
local attribute [instance] prop_decidable

variables {V : Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

def lfe --locally face equivalent
(U : set (metric.sphere (0 : V) 1))
(P Q : polytope V) :=
∃ (x : V) (c : ℝ), c > 0 ∧
bm.τ (convex_body_of_polytope P) U =
{x} + c • (bm.τ (convex_body_of_polytope Q) U)

lemma lfe_refl (P : polytope V) : lfe ⊤ P P :=
begin
  refine ⟨0, 1, zero_lt_one, _⟩,
  simp only [one_smul, set.singleton_add, zero_add, set.image_id'],
end

lemma lfe_symm
{U : set (metric.sphere (0 : V) 1)}
{P Q : polytope V}
(h : lfe U P Q) : lfe U Q P :=
begin
  obtain ⟨x, c, cpos, hxc⟩ := h,
  refine ⟨-c⁻¹ • x, c⁻¹, inv_pos_of_pos cpos, _⟩,
  rw [hxc, smul_add, ←add_assoc],
  simp only [neg_smul, set.smul_set_singleton,
  set.singleton_add_singleton, add_left_neg,
  set.singleton_add],
  simp only [subtype.val_eq_coe, set.image_add_left, neg_neg, set.preimage_add_left_singleton, add_left_neg, set.singleton_add,
  zero_add, set.image_id'],
  rw [inv_smul_smul₀ (ne_of_gt cpos)],
end

lemma lfe_mono
{U₁ U₂ : set (metric.sphere (0 : V) 1)}
{P Q : polytope V}
(hPQ : lfe U₂ P Q)
(hU : U₁ ⊆ U₂) :
lfe U₁ P Q :=
begin
  obtain ⟨x, c, cpos, hxc⟩ := hPQ,
  refine ⟨x, c, cpos, _⟩,
  simp only [bm.τ_mono hU, hxc],
  rw [add_comm],
  simp only [face_translate, face_smul cpos],
  rw [add_comm],
  rw [set.smul_set_Union₂, set.Union₂_add],
end

lemma lfe_trans
{U₁ U₂ : set (metric.sphere (0 : V) 1)}
{P Q R : polytope V}
(h₁ : lfe U₁ P Q)
(h₂ : lfe U₂ Q R) : lfe (U₁ ∩ U₂) P R :=
begin
  obtain ⟨x₁, c₁, c₁pos, hxc₁⟩ := lfe_mono h₁ (set.inter_subset_left _ _),
  obtain ⟨x₂, c₂, c₂pos, hxc₂⟩ := lfe_mono h₂ (set.inter_subset_right _ _),
  refine ⟨x₁ + c₁ • x₂, c₁ * c₂, _, _⟩,
  {
    exact mul_pos c₁pos c₂pos,
  },
  {
    rw [hxc₁, hxc₂],
    simp only [smul_add, smul_smul, ←add_assoc],
    simp only [set.smul_set_singleton, set.singleton_add_singleton],
  },
end

def in_combinatorial_closure
(u : metric.sphere (0 : V) 1)
(S : set (convex_body V))
(K : convex_body V) :=
∀ Ps : multiset (convex_body V), dim V = Ps.card + 2 →
u ∈ msupport (bm.area (K ::ₘ Ps)) →
u ∈ closure (⋃ L ∈ S, msupport (bm.area (L ::ₘ Ps)))

/- lemma mem_closure_of_mem_closure_nhd
{A U : set V} {x : V} (hU : U ∈ 𝓝 x) :
x ∈ closure A ↔ x ∈ closure (A ∩ U) := sorry

lemma mem_closure_of_mem_closure_nhd'
{A B U : set V} {x : V} (hU : U ∈ 𝓝 x) (hAB : A ∩ U = B ∩ U) :
x ∈ closure A ↔ x ∈ closure B := sorry -/

lemma mem_closure_of_subset_within_of_mem_closure
{α : Type} [topological_space α]
{A B U : set α} {x : α} (hU : U ∈ 𝓝 x) (hAB : A ∩ U ⊆ B ∩ U) :
x ∈ closure A → x ∈ closure B :=
begin
  simp only [mem_closure_iff_cluster_pt, cluster_pt_iff],
  intros h X hX W hW,
  let W' := W ∪ A,
  have W'p : W' ∈ filter.principal A,
  {
    apply set.subset_union_right,
  },
  obtain ⟨x, ⟨xX, xU⟩, xW'⟩ := h (filter.inter_mem hX hU) W'p,
  refine ⟨x, xX, _⟩,
  cases xW' with xW xA,
  {
    exact xW,
  },
  {
    apply hW,
    apply set.inter_subset_left,
    refine hAB ⟨xA, xU⟩,
  },
end

/- lemma polytope_area_eq_face_area
{C : multiset (convex_body V)}
{P : polytope V}
(hPC : bm.is_area_coll (convex_body_of_polytope P ::ₘ C) ⊤)
{U : set (metric.sphere (0 : V) 1)} {u : metric.sphere (0 : V) 1}
(hU₁ : measurable_set U)
(hU₂ : ∀ v : metric.sphere (0 : V) 1, v ∈ U → normal_face P.val v.val = normal_face P.val u.val) :
bm.area (convex_body_of_polytope P ::ₘ C) U =
bm.area ((convex_body_of_polytope P).normal_face u.val ::ₘ C) U :=
begin
  refine bm.area_determined_by_τ hPC _ hU₁ _,
  {
    refine bm.is_area_coll_cons_of_head_subset _ hPC,
    apply normal_face_subset,
  },
  {
    intro M,
    simp only [bm.τ],
    congr,
    funext v,
    congr,
    funext hv,
    simp only [subtype.val_eq_coe, normal_face_add'],
    congr' 1,
    simp only [convex_body.normal_face, convex_body_of_polytope, subtype.val_eq_coe, subtype.coe_mk],
    simp only [subtype.val_eq_coe, subtype.coe_mk] at hU₂,
    rw [←hU₂ v hv],
    simp only [normal_face_idem_poly],
  },
end -/

-- MOVETO brunn_minkowski.lean
lemma area_determined_by_τ
{C : multiset (convex_body V)}
{K L : convex_body V}
(hC : bm.is_area_coll (K ::ₘ C))
(hD : bm.is_area_coll (L ::ₘ C))
{U : set (metric.sphere (0 : V) 1)}
(hU : measurable_set U)
(h : bm.τ K U = bm.τ L U) :
bm.area (K ::ₘ C) U = bm.area (L ::ₘ C) U :=
begin
  apply bm.area_determined_by_τ_add hC hD hU,
  intro M,
  exact bm.τ_add_right_eq h,
end

-- MOVETO multiset.lean
@[simp]
lemma multiset.all_cons {α : Type}
(p : α → Prop) (a : α) (C : multiset α) :
multiset_all p (a ::ₘ C) ↔ p a ∧ multiset_all p C :=
begin
  simp only [multiset_all, multiset.mem_cons, forall_eq_or_imp],
end

-- MOVETO brunn_minkowski.lean
lemma is_area_coll_smul_cons
{K : convex_body V}
{C : multiset (convex_body V)}
(h : bm.is_area_coll (K ::ₘ C))
(c : nnreal) :
bm.is_area_coll (c • K ::ₘ C) :=
begin
  simp only [bm.is_area_coll, multiset.card_cons] at h ⊢,
  exact h,
end

lemma is_area_coll_add_singleton_cons
{K : convex_body V} {x : V}
{C : multiset (convex_body V)}
(h : bm.is_area_coll (K ::ₘ C)) :
bm.is_area_coll ((K + {x}) ::ₘ C) :=
begin
  simp only [bm.is_area_coll, multiset.card_cons] at h ⊢,
  exact h,
end

lemma area_pos_iff_of_lfe_aux
{P Q : polytope V} {U : set (metric.sphere (0 : V) 1)}
{Ks : multiset (convex_body V)}
(hPQ : lfe U P Q)
(ac₁ : bm.is_area_coll (convex_body_of_polytope P ::ₘ Ks))
(ac₂ : bm.is_area_coll (convex_body_of_polytope Q ::ₘ Ks))
(hU₁ : measurable_set U) :
∃ c : nnreal, 0 < c ∧
bm.area (convex_body_of_polytope Q ::ₘ Ks) U =
c • bm.area (convex_body_of_polytope P ::ₘ Ks) U :=
begin
  obtain ⟨x, c, cpos, hcx⟩ := lfe_symm hPQ,
  let c' := c.to_nnreal,
  have c'pos := real.to_nnreal_pos.mpr cpos,
  refine ⟨c', c'pos, _⟩,
  let P' := (c' • convex_body_of_polytope P) + {x},
  have : bm.area (convex_body_of_polytope Q ::ₘ Ks) U = bm.area (P' ::ₘ Ks) U,
  {
    simp only [P'],
    apply area_determined_by_τ,
    {exact ac₂},
    {
      apply is_area_coll_add_singleton_cons,
      apply is_area_coll_smul_cons,
      exact ac₁,
    },
    exact hU₁,
    {
      rw [bm.τ_translate, bm.τ_smul, add_comm],
      rw [hcx],
      simp only [c', nnreal.smul_def, real.coe_to_nnreal _ (le_of_lt cpos)],
    },
  },
  convert this using 1,
  simp only [P'],
  rw [bm.area_cons_translate,
      bm.area_cons_smul],
  {
    simp only [measure_theory.finite_measure.coe_fn_smul_apply],
  },
  {
    exact ac₁,
  },
  {
    apply is_area_coll_smul_cons,
    exact ac₁,
  },
end

-- MOVETO brunn_minkowski.lean
@[simp]
lemma is_area_coll_top
(C : multiset (convex_body V)) :
bm.is_area_coll C ↔ dim V = C.card + 1 :=
begin
  simp only [bm.is_area_coll],
end

lemma area_pos_iff_of_lfe
{P Q : polytope V} {U : set (metric.sphere (0 : V) 1)}
{Ks : multiset (convex_body V)}
(hPQ : lfe U P Q)
(hKs : dim V = Ks.card + 2)
(hU : measurable_set U) :
bm.area (convex_body_of_polytope P ::ₘ Ks) U > 0 ↔
bm.area (convex_body_of_polytope Q ::ₘ Ks) U > 0 :=
begin
  --have ac₁ : bm.is_area_coll (convex_body_of_polytope P ::ₘ Ks) ⊤,
  obtain ⟨c, cpos, hc⟩ := area_pos_iff_of_lfe_aux hPQ _ _ hU, rotate, rotate,
  any_goals {simp only [is_area_coll_top, multiset.card_cons, add_assoc, hKs]},
  simp only [hc, cpos, gt_iff_lt, algebra.id.smul_eq_mul, canonically_ordered_comm_semiring.mul_pos, true_and],
end

-- MOVETO measure.lean
lemma finite_measure_mono
{μ : measure_theory.finite_measure (metric.sphere (0 : V) 1)}
{U₁ U₂ : set (metric.sphere (0 : V) 1)}
(h : U₁ ⊆ U₂) :
μ U₁ ≤ μ U₂ :=
begin
  simp only [measure_theory.finite_measure.coe_fn_eq_to_nnreal_coe_fn_to_measure],
  apply ennreal.to_nnreal_mono,
  {
    apply measure_theory.measure_ne_top,
  },
  {
    exact measure_theory.measure_mono h,
  },
end

lemma msupport_eq_of_lfe
{P Q : polytope V} {U : set (metric.sphere (0 : V) 1)}
{Ks : multiset (convex_body V)}
(hPQ : lfe U P Q)
(hKs : dim V = Ks.card + 2) :
msupport (bm.area (convex_body_of_polytope P ::ₘ Ks)) ∩ (interior U) =
msupport (bm.area (convex_body_of_polytope Q ::ₘ Ks)) ∩ (interior U) :=
begin
  ext,
  simp only [msupport, set.mem_inter_iff, set.mem_set_of],
  split,
  all_goals {
    rintro ⟨h₁, h₂⟩,
    refine ⟨_, h₂⟩,
    intros W hW₁ hW₂,
    refine lt_of_lt_of_le _
      (finite_measure_mono (set.inter_subset_left W (interior U))),
    have : x ∈ W ∩ interior U := ⟨hW₁, h₂⟩,
    replace h₁ := h₁ _ this (is_open.inter hW₂ is_open_interior),
    rw [area_pos_iff_of_lfe _ hKs] at h₁, exact h₁,
    {exact (hW₂.inter is_open_interior).measurable_set},
    {
      exact lfe_mono (by exact hPQ <|> exact (lfe_symm hPQ)) (subset_trans (set.inter_subset_right W (interior U)) interior_subset : W ∩ interior U ⊆ U),
      -- refine lfe_mono (lfe_symm hPQ) _,
      -- refine subset_trans (set.inter_subset_right _ _) _,
      -- exact interior_subset, strange errors ????????
      -- -> all_goals!!!!
    },
  },
end

lemma comb_cl_of_lfe
{U : set (metric.sphere (0 : V) 1)}
{u : metric.sphere (0 : V) 1}
{t : ℕ → polytope V}
{S : set (polytope V)}
{tl : convex_body V}
(hU : U ∈ nhds u)
(tt : filter.tendsto (λ n, convex_body_of_polytope (t n))
  filter.at_top (𝓝 tl))
(hl : ∀ n : ℕ, ∃ P ∈ S, lfe U (t n) P) :
in_combinatorial_closure u (convex_body_of_polytope '' S)
tl :=
begin
  intros Ps hdim hu,
  have := bm.area_continuous Ps _ _ _ tt,
  {
    have hiU : interior U ∈ nhds u := interior_mem_nhds.mpr hU,
    replace := msupport_subset_of_tendsto _ _ this hu,
    simp only at this,
    refine mem_closure_of_subset_within_of_mem_closure
      hiU _ this,
    rw [set.Union₂_inter, set.Union_inter, set.Union_subset_iff],
    intro n,
    rcases hl n with ⟨P, hS, hlfe⟩,
    rw [msupport_eq_of_lfe hlfe hdim],
    refine subset_trans _ (set.subset_Union₂ (convex_body_of_polytope P) _),
    {
      exact subset_refl _, -- why do I have to use subset_trans?
    },
    {
      exact set.mem_image_of_mem _ hS,
    },
  },
  {
    intro n,
    simp only [bm.is_area_coll],
    simp only [dim_finrank, finrank_top, multiset.card_cons, add_assoc] at hdim ⊢,
    exact hdim,
  },
end


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

! This file was ported from Lean 3 source module algebra.group.type_tags
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Hom.Group
import Mathbin.Logic.Equiv.Defs
import Mathbin.Data.Finite.Defs

/-!
# Type tags that turn additive structures into multiplicative, and vice versa

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

We define two type tags:

* `additive α`: turns any multiplicative structure on `α` into the corresponding
  additive structure on `additive α`;
* `multiplicative α`: turns any additive structure on `α` into the corresponding
  multiplicative structure on `multiplicative α`.

We also define instances `additive.*` and `multiplicative.*` that actually transfer the structures.

## See also

This file is similar to `order.synonym`.
-/

universe u v

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

#print Additive /-
/-- If `α` carries some multiplicative structure, then `additive α` carries the corresponding
additive structure. -/
def Additive (α : Type _) :=
  α
#align additive Additive
-/

#print Multiplicative /-
/-- If `α` carries some additive structure, then `multiplicative α` carries the corresponding
multiplicative structure. -/
def Multiplicative (α : Type _) :=
  α
#align multiplicative Multiplicative
-/

namespace Additive

#print Additive.ofMul /-
/-- Reinterpret `x : α` as an element of `additive α`. -/
def ofMul : α ≃ Additive α :=
  ⟨fun x => x, fun x => x, fun x => rfl, fun x => rfl⟩
#align additive.of_mul Additive.ofMul
-/

#print Additive.toMul /-
/-- Reinterpret `x : additive α` as an element of `α`. -/
def toMul : Additive α ≃ α :=
  ofMul.symm
#align additive.to_mul Additive.toMul
-/

#print Additive.ofMul_symm_eq /-
@[simp]
theorem ofMul_symm_eq : (@ofMul α).symm = toMul :=
  rfl
#align additive.of_mul_symm_eq Additive.ofMul_symm_eq
-/

#print Additive.toMul_symm_eq /-
@[simp]
theorem toMul_symm_eq : (@toMul α).symm = ofMul :=
  rfl
#align additive.to_mul_symm_eq Additive.toMul_symm_eq
-/

end Additive

namespace Multiplicative

#print Multiplicative.ofAdd /-
/-- Reinterpret `x : α` as an element of `multiplicative α`. -/
def ofAdd : α ≃ Multiplicative α :=
  ⟨fun x => x, fun x => x, fun x => rfl, fun x => rfl⟩
#align multiplicative.of_add Multiplicative.ofAdd
-/

#print Multiplicative.toAdd /-
/-- Reinterpret `x : multiplicative α` as an element of `α`. -/
def toAdd : Multiplicative α ≃ α :=
  ofAdd.symm
#align multiplicative.to_add Multiplicative.toAdd
-/

#print Multiplicative.ofAdd_symm_eq /-
@[simp]
theorem ofAdd_symm_eq : (@ofAdd α).symm = toAdd :=
  rfl
#align multiplicative.of_add_symm_eq Multiplicative.ofAdd_symm_eq
-/

#print Multiplicative.toAdd_symm_eq /-
@[simp]
theorem toAdd_symm_eq : (@toAdd α).symm = ofAdd :=
  rfl
#align multiplicative.to_add_symm_eq Multiplicative.toAdd_symm_eq
-/

end Multiplicative

#print toAdd_ofAdd /-
@[simp]
theorem toAdd_ofAdd (x : α) : (Multiplicative.ofAdd x).toAdd = x :=
  rfl
#align to_add_of_add toAdd_ofAdd
-/

#print ofAdd_toAdd /-
@[simp]
theorem ofAdd_toAdd (x : Multiplicative α) : Multiplicative.ofAdd x.toAdd = x :=
  rfl
#align of_add_to_add ofAdd_toAdd
-/

#print toMul_ofMul /-
@[simp]
theorem toMul_ofMul (x : α) : (Additive.ofMul x).toMul = x :=
  rfl
#align to_mul_of_mul toMul_ofMul
-/

#print ofMul_toMul /-
@[simp]
theorem ofMul_toMul (x : Additive α) : Additive.ofMul x.toMul = x :=
  rfl
#align of_mul_to_mul ofMul_toMul
-/

instance [Inhabited α] : Inhabited (Additive α) :=
  ⟨Additive.ofMul default⟩

instance [Inhabited α] : Inhabited (Multiplicative α) :=
  ⟨Multiplicative.ofAdd default⟩

instance [Finite α] : Finite (Additive α) :=
  Finite.of_equiv α (by rfl)

instance [Finite α] : Finite (Multiplicative α) :=
  Finite.of_equiv α (by rfl)

instance [Infinite α] : Infinite (Additive α) := by tauto

instance [Infinite α] : Infinite (Multiplicative α) := by tauto

instance [Nontrivial α] : Nontrivial (Additive α) :=
  Additive.ofMul.Injective.Nontrivial

instance [Nontrivial α] : Nontrivial (Multiplicative α) :=
  Multiplicative.ofAdd.Injective.Nontrivial

instance Additive.hasAdd [Mul α] : Add (Additive α)
    where add x y := Additive.ofMul (x.toMul * y.toMul)
#align additive.has_add Additive.hasAdd

instance [Add α] : Mul (Multiplicative α) where mul x y := Multiplicative.ofAdd (x.toAdd + y.toAdd)

#print ofAdd_add /-
@[simp]
theorem ofAdd_add [Add α] (x y : α) :
    Multiplicative.ofAdd (x + y) = Multiplicative.ofAdd x * Multiplicative.ofAdd y :=
  rfl
#align of_add_add ofAdd_add
-/

#print toAdd_mul /-
@[simp]
theorem toAdd_mul [Add α] (x y : Multiplicative α) : (x * y).toAdd = x.toAdd + y.toAdd :=
  rfl
#align to_add_mul toAdd_mul
-/

#print ofMul_mul /-
@[simp]
theorem ofMul_mul [Mul α] (x y : α) :
    Additive.ofMul (x * y) = Additive.ofMul x + Additive.ofMul y :=
  rfl
#align of_mul_mul ofMul_mul
-/

#print toMul_add /-
@[simp]
theorem toMul_add [Mul α] (x y : Additive α) : (x + y).toMul = x.toMul * y.toMul :=
  rfl
#align to_mul_add toMul_add
-/

instance [Semigroup α] : AddSemigroup (Additive α) :=
  { Additive.hasAdd with add_assoc := @mul_assoc α _ }

instance [AddSemigroup α] : Semigroup (Multiplicative α) :=
  { Multiplicative.hasMul with mul_assoc := @add_assoc α _ }

instance [CommSemigroup α] : AddCommSemigroup (Additive α) :=
  { Additive.addSemigroup with add_comm := @mul_comm _ _ }

instance [AddCommSemigroup α] : CommSemigroup (Multiplicative α) :=
  { Multiplicative.semigroup with mul_comm := @add_comm _ _ }

instance [Mul α] [IsLeftCancelMul α] : IsLeftCancelAdd (Additive α)
    where add_left_cancel := @mul_left_cancel α _ _

instance [Add α] [IsLeftCancelAdd α] : IsLeftCancelMul (Multiplicative α)
    where mul_left_cancel := @add_left_cancel α _ _

instance [Mul α] [IsRightCancelMul α] : IsRightCancelAdd (Additive α)
    where add_right_cancel := @mul_right_cancel α _ _

instance [Add α] [IsRightCancelAdd α] : IsRightCancelMul (Multiplicative α)
    where mul_right_cancel := @add_right_cancel α _ _

instance [Mul α] [IsCancelMul α] : IsCancelAdd (Additive α) :=
  { Additive.isLeftCancelAdd, Additive.isRightCancelAdd with }

instance [Add α] [IsCancelAdd α] : IsCancelMul (Multiplicative α) :=
  { Multiplicative.isLeftCancelMul, Multiplicative.isRightCancelMul with }

instance [LeftCancelSemigroup α] : AddLeftCancelSemigroup (Additive α) :=
  { Additive.addSemigroup, Additive.isLeftCancelAdd with }

instance [AddLeftCancelSemigroup α] : LeftCancelSemigroup (Multiplicative α) :=
  { Multiplicative.semigroup, Multiplicative.isLeftCancelMul with }

instance [RightCancelSemigroup α] : AddRightCancelSemigroup (Additive α) :=
  { Additive.addSemigroup, Additive.isRightCancelAdd with }

instance [AddRightCancelSemigroup α] : RightCancelSemigroup (Multiplicative α) :=
  { Multiplicative.semigroup, Multiplicative.isRightCancelMul with }

instance [One α] : Zero (Additive α) :=
  ⟨Additive.ofMul 1⟩

#print ofMul_one /-
@[simp]
theorem ofMul_one [One α] : @Additive.ofMul α 1 = 0 :=
  rfl
#align of_mul_one ofMul_one
-/

#print ofMul_eq_zero /-
@[simp]
theorem ofMul_eq_zero {A : Type _} [One A] {x : A} : Additive.ofMul x = 0 ↔ x = 1 :=
  Iff.rfl
#align of_mul_eq_zero ofMul_eq_zero
-/

#print toMul_zero /-
@[simp]
theorem toMul_zero [One α] : (0 : Additive α).toMul = 1 :=
  rfl
#align to_mul_zero toMul_zero
-/

instance [Zero α] : One (Multiplicative α) :=
  ⟨Multiplicative.ofAdd 0⟩

#print ofAdd_zero /-
@[simp]
theorem ofAdd_zero [Zero α] : @Multiplicative.ofAdd α 0 = 1 :=
  rfl
#align of_add_zero ofAdd_zero
-/

#print ofAdd_eq_one /-
@[simp]
theorem ofAdd_eq_one {A : Type _} [Zero A] {x : A} : Multiplicative.ofAdd x = 1 ↔ x = 0 :=
  Iff.rfl
#align of_add_eq_one ofAdd_eq_one
-/

#print toAdd_one /-
@[simp]
theorem toAdd_one [Zero α] : (1 : Multiplicative α).toAdd = 0 :=
  rfl
#align to_add_one toAdd_one
-/

instance [MulOneClass α] : AddZeroClass (Additive α)
    where
  zero := 0
  add := (· + ·)
  zero_add := one_mul
  add_zero := mul_one

instance [AddZeroClass α] : MulOneClass (Multiplicative α)
    where
  one := 1
  mul := (· * ·)
  one_mul := zero_add
  mul_one := add_zero

instance [h : Monoid α] : AddMonoid (Additive α) :=
  { Additive.addZeroClass,
    Additive.addSemigroup with
    zero := 0
    add := (· + ·)
    nsmul := @Monoid.npow α h
    nsmul_zero := Monoid.npow_zero
    nsmul_succ := Monoid.npow_succ }

instance [h : AddMonoid α] : Monoid (Multiplicative α) :=
  { Multiplicative.mulOneClass,
    Multiplicative.semigroup with
    one := 1
    mul := (· * ·)
    npow := @AddMonoid.nsmul α h
    npow_zero := AddMonoid.nsmul_zero
    npow_succ := AddMonoid.nsmul_succ }

instance [LeftCancelMonoid α] : AddLeftCancelMonoid (Additive α) :=
  { Additive.addMonoid,
    Additive.addLeftCancelSemigroup with
    zero := 0
    add := (· + ·) }

instance [AddLeftCancelMonoid α] : LeftCancelMonoid (Multiplicative α) :=
  { Multiplicative.monoid,
    Multiplicative.leftCancelSemigroup with
    one := 1
    mul := (· * ·) }

instance [RightCancelMonoid α] : AddRightCancelMonoid (Additive α) :=
  { Additive.addMonoid,
    Additive.addRightCancelSemigroup with
    zero := 0
    add := (· + ·) }

instance [AddRightCancelMonoid α] : RightCancelMonoid (Multiplicative α) :=
  { Multiplicative.monoid,
    Multiplicative.rightCancelSemigroup with
    one := 1
    mul := (· * ·) }

instance [CommMonoid α] : AddCommMonoid (Additive α) :=
  { Additive.addMonoid,
    Additive.addCommSemigroup with
    zero := 0
    add := (· + ·) }

instance [AddCommMonoid α] : CommMonoid (Multiplicative α) :=
  { Multiplicative.monoid,
    Multiplicative.commSemigroup with
    one := 1
    mul := (· * ·) }

instance [Inv α] : Neg (Additive α) :=
  ⟨fun x => Multiplicative.ofAdd x.toMul⁻¹⟩

#print ofMul_inv /-
@[simp]
theorem ofMul_inv [Inv α] (x : α) : Additive.ofMul x⁻¹ = -Additive.ofMul x :=
  rfl
#align of_mul_inv ofMul_inv
-/

#print toMul_neg /-
@[simp]
theorem toMul_neg [Inv α] (x : Additive α) : (-x).toMul = x.toMul⁻¹ :=
  rfl
#align to_mul_neg toMul_neg
-/

instance [Neg α] : Inv (Multiplicative α) :=
  ⟨fun x => Additive.ofMul (-x.toAdd)⟩

#print ofAdd_neg /-
@[simp]
theorem ofAdd_neg [Neg α] (x : α) : Multiplicative.ofAdd (-x) = (Multiplicative.ofAdd x)⁻¹ :=
  rfl
#align of_add_neg ofAdd_neg
-/

#print toAdd_inv /-
@[simp]
theorem toAdd_inv [Neg α] (x : Multiplicative α) : x⁻¹.toAdd = -x.toAdd :=
  rfl
#align to_add_inv toAdd_inv
-/

#print Additive.sub /-
instance Additive.sub [Div α] : Sub (Additive α) where sub x y := Additive.ofMul (x.toMul / y.toMul)
#align additive.has_sub Additive.sub
-/

#print Multiplicative.div /-
instance Multiplicative.div [Sub α] : Div (Multiplicative α)
    where div x y := Multiplicative.ofAdd (x.toAdd - y.toAdd)
#align multiplicative.has_div Multiplicative.div
-/

#print ofAdd_sub /-
@[simp]
theorem ofAdd_sub [Sub α] (x y : α) :
    Multiplicative.ofAdd (x - y) = Multiplicative.ofAdd x / Multiplicative.ofAdd y :=
  rfl
#align of_add_sub ofAdd_sub
-/

#print toAdd_div /-
@[simp]
theorem toAdd_div [Sub α] (x y : Multiplicative α) : (x / y).toAdd = x.toAdd - y.toAdd :=
  rfl
#align to_add_div toAdd_div
-/

#print ofMul_div /-
@[simp]
theorem ofMul_div [Div α] (x y : α) :
    Additive.ofMul (x / y) = Additive.ofMul x - Additive.ofMul y :=
  rfl
#align of_mul_div ofMul_div
-/

#print toMul_sub /-
@[simp]
theorem toMul_sub [Div α] (x y : Additive α) : (x - y).toMul = x.toMul / y.toMul :=
  rfl
#align to_mul_sub toMul_sub
-/

instance [InvolutiveInv α] : InvolutiveNeg (Additive α) :=
  { Additive.hasNeg with neg_neg := @inv_inv _ _ }

instance [InvolutiveNeg α] : InvolutiveInv (Multiplicative α) :=
  { Multiplicative.hasInv with inv_inv := @neg_neg _ _ }

instance [DivInvMonoid α] : SubNegMonoid (Additive α) :=
  { Additive.hasNeg, Additive.sub,
    Additive.addMonoid with
    sub_eq_add_neg := @div_eq_mul_inv α _
    zsmul := @DivInvMonoid.zpow α _
    zsmul_zero' := DivInvMonoid.zpow_zero'
    zsmul_succ' := DivInvMonoid.zpow_succ'
    zsmul_neg' := DivInvMonoid.zpow_neg' }

instance [SubNegMonoid α] : DivInvMonoid (Multiplicative α) :=
  { Multiplicative.hasInv, Multiplicative.div,
    Multiplicative.monoid with
    div_eq_mul_inv := @sub_eq_add_neg α _
    zpow := @SubNegMonoid.zsmul α _
    zpow_zero' := SubNegMonoid.zsmul_zero'
    zpow_succ' := SubNegMonoid.zsmul_succ'
    zpow_neg' := SubNegMonoid.zsmul_neg' }

instance [DivisionMonoid α] : SubtractionMonoid (Additive α) :=
  { Additive.subNegMonoid,
    Additive.hasInvolutiveNeg with
    neg_add_rev := @mul_inv_rev _ _
    neg_eq_of_add := @inv_eq_of_mul_eq_one_right _ _ }

instance [SubtractionMonoid α] : DivisionMonoid (Multiplicative α) :=
  { Multiplicative.divInvMonoid,
    Multiplicative.hasInvolutiveInv with
    mul_inv_rev := @neg_add_rev _ _
    inv_eq_of_mul := @neg_eq_of_add_eq_zero_right _ _ }

instance [DivisionCommMonoid α] : SubtractionCommMonoid (Additive α) :=
  { Additive.subtractionMonoid, Additive.addCommSemigroup with }

instance [SubtractionCommMonoid α] : DivisionCommMonoid (Multiplicative α) :=
  { Multiplicative.divisionMonoid, Multiplicative.commSemigroup with }

instance [Group α] : AddGroup (Additive α) :=
  { Additive.subNegMonoid with add_left_neg := @mul_left_inv α _ }

instance [AddGroup α] : Group (Multiplicative α) :=
  { Multiplicative.divInvMonoid with mul_left_inv := @add_left_neg α _ }

instance [CommGroup α] : AddCommGroup (Additive α) :=
  { Additive.addGroup, Additive.addCommMonoid with }

instance [AddCommGroup α] : CommGroup (Multiplicative α) :=
  { Multiplicative.group, Multiplicative.commMonoid with }

open Multiplicative (ofAdd)

open Additive (ofMul)

#print AddMonoidHom.toMultiplicative /-
/-- Reinterpret `α →+ β` as `multiplicative α →* multiplicative β`. -/
@[simps]
def AddMonoidHom.toMultiplicative [AddZeroClass α] [AddZeroClass β] :
    (α →+ β) ≃ (Multiplicative α →* Multiplicative β)
    where
  toFun f := ⟨fun a => ofAdd (f a.toAdd), f.2, f.3⟩
  invFun f := ⟨fun a => (f (ofAdd a)).toAdd, f.2, f.3⟩
  left_inv x := by
    ext
    rfl
  right_inv x := by
    ext
    rfl
#align add_monoid_hom.to_multiplicative AddMonoidHom.toMultiplicative
-/

#print MonoidHom.toAdditive /-
/-- Reinterpret `α →* β` as `additive α →+ additive β`. -/
@[simps]
def MonoidHom.toAdditive [MulOneClass α] [MulOneClass β] : (α →* β) ≃ (Additive α →+ Additive β)
    where
  toFun f := ⟨fun a => ofMul (f a.toMul), f.2, f.3⟩
  invFun f := ⟨fun a => (f (ofMul a)).toMul, f.2, f.3⟩
  left_inv x := by
    ext
    rfl
  right_inv x := by
    ext
    rfl
#align monoid_hom.to_additive MonoidHom.toAdditive
-/

#print AddMonoidHom.toMultiplicative' /-
/-- Reinterpret `additive α →+ β` as `α →* multiplicative β`. -/
@[simps]
def AddMonoidHom.toMultiplicative' [MulOneClass α] [AddZeroClass β] :
    (Additive α →+ β) ≃ (α →* Multiplicative β)
    where
  toFun f := ⟨fun a => ofAdd (f (ofMul a)), f.2, f.3⟩
  invFun f := ⟨fun a => (f a.toMul).toAdd, f.2, f.3⟩
  left_inv x := by
    ext
    rfl
  right_inv x := by
    ext
    rfl
#align add_monoid_hom.to_multiplicative' AddMonoidHom.toMultiplicative'
-/

#print MonoidHom.toAdditive' /-
/-- Reinterpret `α →* multiplicative β` as `additive α →+ β`. -/
@[simps]
def MonoidHom.toAdditive' [MulOneClass α] [AddZeroClass β] :
    (α →* Multiplicative β) ≃ (Additive α →+ β) :=
  AddMonoidHom.toMultiplicative'.symm
#align monoid_hom.to_additive' MonoidHom.toAdditive'
-/

#print AddMonoidHom.toMultiplicative'' /-
/-- Reinterpret `α →+ additive β` as `multiplicative α →* β`. -/
@[simps]
def AddMonoidHom.toMultiplicative'' [AddZeroClass α] [MulOneClass β] :
    (α →+ Additive β) ≃ (Multiplicative α →* β)
    where
  toFun f := ⟨fun a => (f a.toAdd).toMul, f.2, f.3⟩
  invFun f := ⟨fun a => ofMul (f (ofAdd a)), f.2, f.3⟩
  left_inv x := by
    ext
    rfl
  right_inv x := by
    ext
    rfl
#align add_monoid_hom.to_multiplicative'' AddMonoidHom.toMultiplicative''
-/

#print MonoidHom.toAdditive'' /-
/-- Reinterpret `multiplicative α →* β` as `α →+ additive β`. -/
@[simps]
def MonoidHom.toAdditive'' [AddZeroClass α] [MulOneClass β] :
    (Multiplicative α →* β) ≃ (α →+ Additive β) :=
  AddMonoidHom.toMultiplicative''.symm
#align monoid_hom.to_additive'' MonoidHom.toAdditive''
-/

#print Additive.coeToFun /-
/-- If `α` has some multiplicative structure and coerces to a function,
then `additive α` should also coerce to the same function.

This allows `additive` to be used on bundled function types with a multiplicative structure, which
is often used for composition, without affecting the behavior of the function itself.
-/
instance Additive.coeToFun {α : Type _} {β : α → Sort _} [CoeFun α β] :
    CoeFun (Additive α) fun a => β a.toMul :=
  ⟨fun a => coeFn a.toMul⟩
#align additive.has_coe_to_fun Additive.coeToFun
-/

#print Multiplicative.coeToFun /-
/-- If `α` has some additive structure and coerces to a function,
then `multiplicative α` should also coerce to the same function.

This allows `multiplicative` to be used on bundled function types with an additive structure, which
is often used for composition, without affecting the behavior of the function itself.
-/
instance Multiplicative.coeToFun {α : Type _} {β : α → Sort _} [CoeFun α β] :
    CoeFun (Multiplicative α) fun a => β a.toAdd :=
  ⟨fun a => coeFn a.toAdd⟩
#align multiplicative.has_coe_to_fun Multiplicative.coeToFun
-/


import .logic_util .nat_util

lemma fin.pos_of_elem {n} : fin n → 0 < n :=
by { intro k, by_cases n = 0, rw [h] at k,
     exact k.elim0, exact nat.pos_of_ne_zero h, }

lemma fin1.all_zero : ∀ x : fin 1, x.val = 0 :=
begin
  intros, cases x, simp, apply nat.eq_zero_of_le_zero,
  apply nat.le_of_succ_le_succ, exact x_is_lt
end

lemma fin1.singleton (x y : fin 1) : x = y :=
fin.eq_of_veq (eq.trans (fin1.all_zero x) $ eq.symm $ fin1.all_zero y)

def fin.glue {A} {n m} (f : fin n → A) (g : fin m → A) : fin (n + m) → A :=
λ k, if h : k.val < n
     then f ⟨k.val, h⟩
     else g ⟨k.val - n, sub_lt_if_ge n m k.val (ge_if_not_lt h) k.is_lt⟩

lemma both_inj_and_im_disj_implies_glue_inj {A} {n m}
  : ∀ (f : fin n → A) (g : fin m → A),
    function.injective f
    → function.injective g
    → disjoint (fun.im f) (fun.im g)
    → function.injective (fin.glue f g) :=
begin
  intros f g f_i g_i h_disj,
  intros x y hxy,
  simp [fin.glue] at hxy,
  by_cases hx : x.val < n,
  { by_cases hy : y.val < n,
    { apply fin.eq_of_veq, rw [dif_pos hx, dif_pos hy] at hxy,
      refine (_ : (fin.mk x.val hx).val = (fin.mk y.val hy).val),
      apply fin.veq_of_eq, apply f_i, assumption },
    { exfalso, rw [dif_pos hx, dif_neg hy] at hxy,
      refine (_ : (∅ : set A) (f ⟨x.val, hx⟩)),
      dsimp [disjoint] at h_disj, rw ← h_disj,
      constructor,
      existsi _, refl,
      rw hxy, existsi _, refl } },
  { by_cases hy : y.val < n,
    { exfalso, rw [dif_neg hx, dif_pos hy] at hxy,
      refine (_ : (∅ : set A) (f ⟨y.val, hy⟩)),
      dsimp [disjoint] at h_disj, rw ← h_disj,
      constructor,
      existsi _, refl,
      rw ← hxy, existsi _, refl },
    { apply fin.eq_of_veq, rw [dif_neg hx, dif_neg hy] at hxy,
      have := fin.veq_of_eq (g_i hxy), simp at this,
      have hx : n ≤ x.val := ge_if_not_lt hx,
      have hy : n ≤ y.val := ge_if_not_lt hy,
      rw [← nat.add_sub_of_le hx, ← nat.add_sub_of_le hy, this] } }
end

lemma im_glue_eq_union_ims {A} {n m}
  : ∀ (f : fin n → A) (g : fin m → A),
    fun.im (fin.glue f g) = fun.im f ∪ fun.im g :=
begin
  intros f g, funext, apply propext,
  constructor; intro h; cases h,
  { by_cases h_w.val < n,
    { apply or.inl, existsi fin.mk h_w.val h,
      simp [fin.glue] at h_h, rw [← h_h, dif_pos h] },
    { apply or.inr,
      existsi fin.mk (h_w.val - n) (sub_lt_if_ge n m h_w.val (ge_if_not_lt h) h_w.is_lt),
      simp [fin.glue] at h_h, rw [dif_neg] at h_h, assumption } },
  { cases h, existsi fin.mk h_w.val (nat.lt_of_lt_of_le h_w.is_lt (nat.le_add_right _ _)),
    simp [fin.glue], rw [dif_pos h_w.is_lt],
    rw ← h_h, congr, apply fin.eq_of_veq, refl },
  { cases h, existsi fin.mk (n + h_w.val) (nat.add_lt_add_left h_w.is_lt n),
    have h1 : ¬ (n + h_w.val < n),
    { have := nat.le_add_right n h_w.val,
      intro, apply nat.lt_irrefl (n + h_w.val),
      apply nat.lt_of_lt_of_le; assumption },
    simp [fin.glue], rw [dif_neg h1],
    rw ← h_h, congr, apply fin.eq_of_veq, simp,
    apply nat.add_sub_cancel_left }
end

def fin.restrict {A} {n} (f : fin (nat.succ n) → A) : fin n → A :=
λ k, f ⟨k.val, nat.lt_trans k.is_lt $ nat.lt_succ_self n⟩

lemma fin.restrict_glue_comm {A} {n m : ℕ}
  : ∀ (f : fin n → A) (g  : fin (nat.succ m) → A),
    fin.restrict (fin.glue f g) = fin.glue f (fin.restrict g) :=
  by intros; refl

def fin.restrict_many {A} (n m) (f : fin (n + m) → A) : fin n → A :=
λ k, f ⟨k.val, nat.lt_of_lt_of_le k.is_lt (nat.le_add_right n m)⟩

def fin.tail {A} (n m) (f : fin (n + m) → A) : fin m → A :=
λ k, f ⟨n + k.val, nat.add_lt_add_left k.is_lt n⟩

def fin.fun_omit {A : Type _} {n} (k : nat) (f : fin (nat.succ n) → A) : fin n → A :=
λ m, if hmk : m.val < k
     then f ⟨m.val, nat.lt_trans m.is_lt $ nat.lt_succ_self n⟩
     else f ⟨m.val+1, nat.add_lt_add_right m.is_lt 1⟩

lemma restrict_is_omit_n {T n}
  : ∀ (f : fin (nat.succ n) → T), fin.restrict f = fin.fun_omit n f :=
begin
  intros, funext,
  simp [fin.restrict, fin.fun_omit],
  rw dif_pos, exact k.is_lt
end

lemma omit_inj_if_fun_inj {A : Type _} {n} (k : nat) (f : fin (nat.succ n) → A)
  : function.injective f → function.injective (fin.fun_omit k f) :=
begin
  intros f_inj x y hxy,
  by_cases h : x.val < k; by_cases h' : y.val < k,
  { dsimp [fin.fun_omit] at hxy,
    rw [dif_pos h, dif_pos h'] at hxy,
    apply fin.eq_of_veq,
    have := f_inj hxy,
    apply fin.veq_of_eq this },
  { exfalso, dsimp [fin.fun_omit] at hxy,
    rw [dif_pos h, dif_neg h'] at hxy,
    have : x.val = y.val + 1,
    { have := f_inj hxy, apply fin.veq_of_eq this },
    rw this at h, apply h',
    apply nat.lt_trans _ h,
    apply nat.lt_succ_self },
  { exfalso, dsimp [fin.fun_omit] at hxy,
    rw [dif_neg h, dif_pos h'] at hxy,
    have : x.val + 1 = y.val,
    { have := f_inj hxy, apply fin.veq_of_eq this },
    rw ← this at h', apply h,
    apply nat.lt_trans _ h',
    apply nat.lt_succ_self },
  { dsimp [fin.fun_omit] at hxy,
    rw [dif_neg h, dif_neg h'] at hxy,
    apply fin.eq_of_veq,
    apply nat.succ_inj,
    exact fin.veq_of_eq (f_inj hxy) }
end

lemma restrict_inj_if_fun_inj {A : Type _} {n} (f : fin (nat.succ n) → A)
  : function.injective f → function.injective (fin.restrict f) :=
  eq.substr (restrict_is_omit_n f) (omit_inj_if_fun_inj n f)

lemma im_omit {T : Type _}
  : ∀ n (f : fin (nat.succ n) → T) (k : fin (nat.succ n)),
    function.injective f →
    fun.im (fin.fun_omit k.val f) = fun.im f ∖ {f k} :=
begin
  intros n f k f_i,
  funext, apply propext, constructor; intro h,
  { cases h with m h,
    have : (f ⟨m.val, nat.lt_trans m.is_lt (nat.lt_succ_self n)⟩ = b)
         ∨ (f ⟨m.val + 1, nat.succ_lt_succ m.is_lt⟩ = b),
    { dsimp [fin.fun_omit] at h,
      by_cases h' : m.val < k.val,
      { rw dif_pos h' at h, apply or.inl, assumption },
      { rw dif_neg h' at h, apply or.inr, assumption } },
    cases this,
    { constructor,
      { existsi _, exact this },
      { rw elem_singleton, intro h', cases h',
        rw eq.symm (fin.veq_of_eq (f_i this)) at h, simp at h,
        rw ← this at h,
        dsimp [fin.fun_omit] at h,
        rw dif_neg (nat.lt_irrefl m.val) at h,
        apply nat.succ_ne_self m.val,
        exact fin.veq_of_eq (f_i h) } },
    { constructor,
      { existsi _, exact this },
      { rw elem_singleton, intro h', cases h',
        rw eq.symm (fin.veq_of_eq (f_i this)) at h, simp at h,
        rw ← this at h,
        dsimp [fin.fun_omit] at h,
        rw dif_pos (nat.lt_succ_self m.val) at h,
        apply nat.succ_ne_self m.val, symmetry,
        exact fin.veq_of_eq (f_i h) } } },
  { cases h, cases h_left with m hm,
    cases (nat.lt_trichotomy m.val k.val),
    { existsi fin.mk m.val (nat.lt_of_lt_of_le h $ nat.le_of_lt_succ k.is_lt),
      dsimp [fin.fun_omit], rw dif_pos h,
      rw ← hm, congr, apply fin.eq_of_veq, refl },
    { have := or.resolve_left h _,
      { destruct m.val,
        { intro h, rw h at this, cases this },
        { intros m' hm',
          have m'_is_lt : m' < n,
          { apply nat.lt_of_lt_of_le,
            apply nat.lt_succ_self,
            rw ← hm', apply nat.le_of_lt_succ,
            exact m.is_lt },
          existsi fin.mk m' m'_is_lt,
          { dsimp [fin.fun_omit],
            rw dif_neg _, rw ← hm,
            congr, apply fin.eq_of_veq,
            exact eq.symm hm',
            intro h, apply nat.not_self_lt_lt_succ_self,
            exact h, rw nat.add_one, rw ← hm', exact this },  } },
      { intro hmk, apply h_right,
        rw elem_singleton,
        rw [fin.eq_of_veq (eq.symm hmk), hm],
        constructor } } }
end

lemma im_restrict {T : Type _}
  : ∀ n (f : fin (nat.succ n) → T),
    function.injective f →
    fun.im (fin.restrict f) = fun.im f ∖ {f ⟨n,nat.lt_succ_self n⟩} :=
  by { intros, rw restrict_is_omit_n,
       rw (_ : fin.fun_omit n f = fin.fun_omit (fin.mk n (nat.lt_succ_self n)).val f),
       apply im_omit, assumption, refl }

def has_size (T : Type _) (n) := ∃ (f : fin n → T), function.bijective f
def finite (T : Type _) := ∃ n, has_size T n
def set.has_size {T : Type _} (S n) := ∃ (f : fin n → T), function.injective f ∧ (S = fun.im f)
def set.finite {T : Type _} (S : set T) := ∃ n, set.has_size S n

lemma has_size_zero_iff_empty {T : Type _} :
  ∀ (S : set T), set.has_size S 0 → S = ∅ :=
begin
  intros S h, rw ← subset_of_empty_iff_empty,
  intros x hx, cases h, cases h_h,
  rw h_h_right at hx, cases hx, apply hx_w.elim0
end

theorem subtype_finite_iff_subset_finite {T : Type _} (S : set T)
  : set.finite S ↔ finite (subtype S) :=
begin
  constructor,
  { intros,
    cases a with n a, cases a with f a, cases a with h h',
    have : ∀ k, S (f k),
    { intros, rw h', existsi k, refl },
    let f' : fin n → subtype S
        := λ k, subtype.mk (f k) (this k),
    existsi n, existsi f',
    constructor,
    { simp [function.injective, f'], exact h },
    { simp [f'], intros y, cases y,
      rewrite h' at y_property,
      cases y_property, existsi y_property_w,
      apply subtype.eq, exact y_property_h } },
  { intros,
    cases a with n a, cases a with f h,
    existsi n,
    let f' : fin n → T := λ k, (f k).val,
    existsi f',
    constructor,
    { dsimp [function.injective, f'],
      intros x y hxy,
      have : f x = f y := subtype.eq hxy,
      apply h.left this },
    { funext, apply propext,
      constructor,
      { intro hx,
        cases (h.right ⟨x, hx⟩),
        existsi w, dsimp [f'], rw h_1 },
      { intros hx, cases hx, rw ← hx_h,
        rw (_ : f' hx_w = (f hx_w).val),
        exact (f hx_w).property,
        refl } } }
end

theorem classical.subsets_of_finite_sets_are_finite {T}
  : ∀ {S S' : set T}, S ⊆ S' → set.finite S' → set.finite S :=
begin
  suffices : ∀ n S S', S ⊆ S' →
             ∀ (f : fin n → T), function.injective f
                              → (S' = { t : T | ∃ k, f k = t })
                              → set.finite S,
  { intros, cases a_1, cases a_1_h, cases a_1_h_h,
    apply this; assumption },
  intro n, induction n; intros S S' hsub f f_i f_s,
  case nat.zero {
    have : {t : T | ∃ (k : fin 0), f k = t} = ∅,
    { rw ← subset_of_empty_iff_empty, intros x hx,
      cases hx, cases hx_w, cases hx_w_is_lt },
    rw this at f_s,
    { rw f_s at hsub, rw subset_of_empty_iff_empty.mp hsub,
      existsi 0, existsi f, constructor, assumption, symmetry, assumption } },
  case nat.succ : n ih {
    cases (classical.prop_decidable $ S = S'),
    { have : ∃ x, x ∉ S ∧ x ∈ S',
      { apply classical.by_contradiction,
        intro h',
        apply h,
        funext, apply propext, constructor,
        { apply hsub },
        { intro hx,
            have : ∀ y, ¬(y ∉ S ∧ y ∈ S') := forall_not_of_not_exists h',
            specialize this x,
            apply classical.by_contradiction,
            intro h'', apply this, constructor; assumption } },
      cases this with x hx,
      cases hx with hnxS hxS',
      specialize ih S (S' ∖ {x}) _,
      { rw f_s at hxS', cases hxS' with k hkx,
        let f' := fin.fun_omit k.val f,
        specialize ih f' (omit_inj_if_fun_inj _ _ f_i),
        apply ih, rw f_s,
        funext, apply propext, constructor,
        { intro h, cases h, rw elem_singleton at h_right,
          rw (_ : a ∉ {y : T | y = x} ↔ a ≠ x) at h_right,
          cases h_left with m hm,
          cases nat.lt_trichotomy m.val k.val,
          { existsi fin.mk m.val (nat.lt_of_lt_of_le h_1 $ nat.le_of_lt_succ k.is_lt),
            dsimp [f', fin.fun_omit], rw dif_pos h_1,
            rw ← hm, congr, apply fin.eq_of_veq, refl },
          cases h_1,
          { exfalso, rw (_ : f m = f k) at hm,
            apply h_right, rw ← hm, rw ← hkx,
            congr, apply fin.eq_of_veq, assumption },
          { destruct m.val,
            { intro hm_eq, rw hm_eq at h_1, cases h_1 },
            { intros m' hm_eq,
              have : m' < n,
              { apply nat.lt_of_succ_lt_succ, rw ← hm_eq, exact m.is_lt },
              existsi fin.mk m' this,
              dsimp [f', fin.fun_omit],
              rw dif_neg, rw ← hm, congr,
              apply fin.eq_of_veq, simp, symmetry, assumption,
              { rw hm_eq at h_1, intro,
                exact nat.not_self_lt_lt_succ_self a_1 h_1, } } },
          refl },
        { intro h, cases h with m hm, constructor,
          { dsimp [f', fin.fun_omit] at hm,
            by_cases m.val < k.val,
            { rw dif_pos h at hm,
              existsi fin.mk m.val (nat.lt_trans h k.is_lt), assumption },
            { rw dif_neg h at hm,
              existsi fin.mk (m.val +  1) (nat.succ_lt_succ m.is_lt),
              rw ← hm } },
          { rw elem_singleton,
            rw (_ : a ∈ {y : T | y = x} ↔ a = x),
            intro hax, rw hax at hm,
            { rw ← hkx at hm,
              dsimp [f', fin.fun_omit] at hm,
              by_cases m.val < k.val,
              { apply nat.lt_irrefl k.val,
                rw dif_pos h at hm,
                have : m.val = k.val := fin.veq_of_eq (f_i hm),
                rw this at h, exact h },
              { apply h, rw dif_neg h at hm,
                rw ← (fin.veq_of_eq (f_i hm) : m.val + 1 = k.val),
                apply nat.lt_succ_self } },
            refl } } },
      { intro x', cases (classical.prop_decidable $ x = x'),
        { intro hx', have : x' ∈ S' := hsub hx',
          dsimp [(∖), (∈), set.mem],
          rw elem_singleton,
          constructor, assumption,
          apply ne.symm, assumption },
        { intro hx', exfalso, apply hnxS, rw h_1, assumption } } },
    { subst h, existsi (nat.succ n), existsi f, constructor; assumption } }
end

theorem classical.sets_of_finite_types_are_finite
  : ∀ T, finite T → (∀ S : set T, set.finite S) :=
begin
  intros T hT S,
  apply @classical.subsets_of_finite_sets_are_finite T S set.univ (λ x _, true.intro),
  cases hT with n hT, cases hT with f h,
  cases h with f_i f_s,
  existsi n, existsi f,
  constructor, assumption,
  funext, apply propext, rw (_ : set.univ a = true),
  { rw true_iff, exact f_s a },
  refl
end

theorem classical.subtypes_of_finite_types_are_finite
  : ∀ T, finite T → (∀ P : T → Prop, finite (subtype P)) :=
by { intros, rw ← subtype_finite_iff_subset_finite, apply classical.sets_of_finite_types_are_finite, assumption }

lemma surj_zero_implies_eq_zero {T}
  : ∀ (S : set T) n (f : fin n → T) (f' : fin 0 → T),
    (S = fun.im f)
    → (S = fun.im f')
    → n = 0 :=
begin
  intros, by_contradiction,
  let z : fin n := ⟨0, nat.pos_of_ne_zero a_2⟩,
  have : f z ∈ S,
  { rw a, existsi z, refl },
  rw a_1 at this, cases this,
  cases this_w, cases this_w_is_lt
end

theorem one_way_to_be_finite {T}
  : ∀ (S : set T) n (f : fin n → T) n' (f' : fin n' → T),
    function.injective f → (S = fun.im f)
    → function.injective f' → (S = fun.im f')
    → n = n' :=
begin
  intros S n, revert S,
  induction n;
  intros S f n' f' f_i f_s f'_i f'_s,
  { by_contradiction,
    { apply a, symmetry,
      apply surj_zero_implies_eq_zero S n' f' f f'_s f_s } },
  case nat.succ : n ih {
    cases n',
    { exfalso, apply nat.succ_ne_zero n,
      apply surj_zero_implies_eq_zero S _ f f' f_s f'_s },
    let fin_n : fin (nat.succ n) := ⟨n, nat.lt_succ_self n⟩,
    have : f fin_n ∈ S,
    { rw f_s, existsi fin_n, refl },
    rw f'_s at this, cases this with m,
    specialize ih (S ∖ {f fin_n}) (fin.restrict f) n' (fin.fun_omit m.val f'),
    congr, apply ih,
    { rw restrict_is_omit_n, apply omit_inj_if_fun_inj, assumption },
    { rw restrict_is_omit_n,
      suffices : S∖{f fin_n} = fun.im (fin.fun_omit fin_n.val f), { exact this },
      rw im_omit, rw f_s, assumption },
    { apply omit_inj_if_fun_inj, assumption },
    { suffices : S∖{f' m} = fun.im (fin.fun_omit m.val f'), { rw ← this_h, assumption },
      rw im_omit, rw f'_s, assumption } }
end

lemma union_size' {T : Type _} {A B : set T}
  : disjoint A B
  → ∀ {n m} (f : fin n → T) (g : fin m → T),
    function.injective f → A = fun.im f
    → function.injective g → B = fun.im g
    → function.injective (fin.glue f g)
      ∧ (A ∪ B) = fun.im (fin.glue f g) :=
begin
  intros h n m f g f_i f_s g_i g_s,
  constructor,
  { apply both_inj_and_im_disj_implies_glue_inj f g f_i g_i,
    rw ← f_s, rw ← g_s, assumption },
  { rw [im_glue_eq_union_ims, f_s, g_s] }
end

lemma union_size {T : Type _} {A B : set T}
  : disjoint A B
  → ∀ {n m}, set.has_size A n
           → set.has_size B m
           → set.has_size (A ∪ B) (n + m) :=
begin
  intros hAB n m hA hB,
  cases hA with f hA, cases hA with f_i f_s,
  cases hB with g hB, cases hB with g_i g_s,
  existsi (fin.glue f g), apply union_size'; assumption
end

def fin.square_to_line {n m} : fin n × fin m → fin (n * m) :=
λ p, fin.mk (p.fst.val + n * p.snd.val) $
     have h1 : 0 < m - p.snd.val,
     from nat.sub_pos_of_lt p.snd.is_lt,
     have p.fst.val < n * (m - p.snd.val),
     by { apply nat.lt_of_lt_of_le p.fst.is_lt,
          transitivity n * 1, rw mul_one,
          apply nat.mul_le_mul_left, exact h1 },
     have p.fst.val < n*m - n*p.snd.val,
     from nat.mul_sub_left_distrib n m p.snd.val ▸ this,
     have p.fst.val + n*p.snd.val < n*m - n*p.snd.val + n*p.snd.val,
     from nat.add_lt_add_right this _,
     by { rw nat.sub_add_cancel at this, assumption,
          apply nat.mul_le_mul_left, apply le_of_lt, exact p.snd.is_lt }

def fin.line_to_square {n m} : fin (n * m) → fin n × fin m :=
λ k, prod.mk (fin.mk (k.val % n) $ nat.mod_lt k.val (pos_of_prod_pos_l $ fin.pos_of_elem k))
             $ fin.mk (k.val / n)
             $ iff.mpr (nat.div_lt_iff_lt_mul k.val m
                       $ pos_of_prod_pos_l $ fin.pos_of_elem k)
             $ mul_comm n m ▸ k.is_lt

lemma line_to_square.iso {n m}
  : ∀ (x : fin n) (y : fin m),
    fin.line_to_square
    (fin.square_to_line (x, y))
    = (x, y) :=
begin
  intros, dsimp [fin.square_to_line, fin.line_to_square],
  congr; apply fin.eq_of_veq; simp,
  { apply nat.mod_eq_of_lt x.is_lt },
  { induction y.val,
    { apply nat.div_eq_of_lt x.is_lt },
    { rw [nat.mul_succ, ← add_assoc],
      rw nat.div_eq_sub_div (fin.pos_of_elem x),
      rw [nat.add_sub_cancel, nat.add_one], congr,
      assumption, apply nat.le_add_left } }
end

lemma square_to_line.iso {n m}
  : ∀ (p : fin (n * m)),
    fin.square_to_line
    (fin.line_to_square p)
    = p :=
begin
  intros, dsimp [fin.square_to_line, fin.line_to_square],
  apply fin.eq_of_veq, simp,
  apply nat.mod_add_div
end

lemma square_line_iso {n m}
  : function.left_inverse (@fin.line_to_square n m) fin.square_to_line
  ∧ function.left_inverse (@fin.square_to_line n m) fin.line_to_square :=
begin
  constructor,
  { intros p, cases p, apply line_to_square.iso },
  { intros p, apply square_to_line.iso }
end


import Smt

theorem exists' : ∃ x : Nat, x = 1 := by
  smt
  exact ⟨1, rfl⟩


import init.data.nat
import init.data.set

/- Types -/
/- Inductive Types: Formula -/
inductive formula
| atom (SYMBOL : ℕ) : formula
| implication (ANTECEDENT CONSEQUENT : formula) : formula
export formula (atom implication)
notation #SYMBOL := formula.atom SYMBOL
notation ANTECEDENT >> CONSEQUENT := formula.implication ANTECEDENT CONSEQUENT
/- Instances of Decidability: Equality -/
instance formula.decidable_eq :
  ∀(f1 f2 : formula),
  ---------------------------------
  decidable (f1 = f2)
-- ATOM:
| (atom SBL1) (atom SBL2) := begin simp [eq.decidable], from @nat.decidable_eq SBL1 SBL2 end
| (atom _) (implication _ _) := begin simp [eq.decidable], from is_false not_false end
-- IMPLICATION:
| (implication _ _) (atom _) := begin simp [eq.decidable], from is_false not_false end
| (implication ANT1 CON1) (implication ANT2 CON2) := begin
  simp [eq.decidable],
  from @and.decidable (ANT1 = ANT2) (CON1 = CON2) (@formula.decidable_eq ANT1 ANT2) (@formula.decidable_eq CON1 CON2)
end

/- Inductive Types: Dag-Like Derivability Structure -/
/- DLDS: Node -/
inductive node
| vertex (LEVEL : ℕ)
         (NUMBER : ℕ)
         (FORMULA : formula)
export node (vertex)
notation LEVEL && NUMBER && FORMULA := node.vertex LEVEL NUMBER FORMULA
/- Instances of Decidability: Equality -/
instance node.decidable_eq :
  ∀(n1 n2 : node),
  ---------------------------------
  decidable (n1 = n2)
-- VERTEX:
| (vertex LVL_1 NBR_1 FML_1) (vertex LVL_2 NBR_2 FML_2) := begin
  simp [eq.decidable],
  have decidable_and, from @and.decidable (NBR_1 = NBR_2)
                                          (FML_1 = FML_2)
                                          (@nat.decidable_eq NBR_1 NBR_2)
                                          (@formula.decidable_eq FML_1 FML_2),
  from @and.decidable (LVL_1 = LVL_2)
                      (NBR_1 = NBR_2 ∧ FML_1 = FML_2)
                      (@nat.decidable_eq LVL_1 LVL_2)
                      (decidable_and)
end

/- Inductive Types: Dag-Like Derivability Structure -/
/- DLDS: Deduction Edges -/
inductive deduction
| edge (START : node)
       (END : node)
       (COLOUR : list ℕ)
       (DEPENDENT : set formula)
export deduction (edge)
/- DLDS: Ancestral Edges -/
inductive ancestral
| path (START : node)
       (END : node)
       (PATH : list ℕ)
export ancestral (path)
/- DLDS: Neighborhoods -/
inductive neighborhood
| dag (CENTER : node)
      (IN : list deduction)
      (OUT : list deduction)
      (ANCESTRAL : list ancestral)
export neighborhood (dag)

/- Methods -/
/- Auxiliary Definitions: -/
/- Rewrite: Nodes -/
def node_rewrite : node → node → node → node
| NODE OLD NEW := if NODE = OLD then NEW else NODE
def list_node_rewrite : list node → node → node → list node
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (node_rewrite HEAD OLD NEW)::(list_node_rewrite TAIL OLD NEW)
/- Rewrite: Deduction Edges -/
def deduction_rewrite : deduction → node → node → deduction
| (edge STR END CLR DEP) OLD NEW := edge (node_rewrite STR OLD NEW)
                                         (node_rewrite END OLD NEW)
                                         CLR
                                         DEP
def list_deduction_rewrite : list deduction → node → node → list deduction
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (deduction_rewrite HEAD OLD NEW)::(list_deduction_rewrite TAIL OLD NEW)
/- Rewrite: Ancestral Edges -/
def ancestral_rewrite : ancestral → node → node → ancestral
| (path STR END PTH) OLD NEW := path (node_rewrite STR OLD NEW)
                                     (node_rewrite END OLD NEW)
                                     PTH
def list_ancestral_rewrite : list ancestral → node → node → list ancestral
| [] OLD NEW := []
| (HEAD::TAIL) OLD NEW := (ancestral_rewrite HEAD OLD NEW)::(list_ancestral_rewrite TAIL OLD NEW)
/- Rewrite: Neighborhoods -/
def neighborhood_rewrite : neighborhood → node → node → neighborhood
| (dag CTR IN OUT ANC) OLD NEW := dag (node_rewrite CTR OLD NEW)
                                      (list_deduction_rewrite IN OLD NEW)
                                      (list_deduction_rewrite OUT OLD NEW)
                                      (list_ancestral_rewrite ANC OLD NEW)
/- Paint: Deduction Edges -/
def colour_paint : list ℕ → ℕ → list ℕ
| COLOUR PAINT := if COLOUR = [] then [PAINT] else COLOUR
def deduction_paint : deduction → ℕ → deduction
| (edge STR END CLR DEP) PAINT := edge STR
                                       END
                                       (colour_paint CLR PAINT)
                                       DEP
def list_deduction_paint : list deduction → ℕ → list deduction
| [] PAINT := []
| (HEAD::TAIL) PAINT := (deduction_paint HEAD PAINT)::(list_deduction_paint TAIL PAINT)

/- Neighborhoods of Non-Collapsed Nodes (Without Incoming Ancestral Edges): -/
/- Neighborhood: Type 0 ⊇-Elimination -/
def elimination_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(antecedent out_frm : formula),
                                             ∃(minor out_nbr : ℕ),
                                             ∃(minor_dep major_dep : set formula),
                                             ------------------------------------------------------
                                             IN = [ edge (vertex (LVL+1) minor antecedent)
                                                         (vertex LVL NBR FML)
                                                         []
                                                         minor_dep,
                                                    edge (vertex (LVL+1) (minor+1) (antecedent>>FML))
                                                         (vertex LVL NBR FML)
                                                         []
                                                         major_dep ]
                                           ∧ OUT = [ edge (vertex LVL NBR FML)
                                                          (vertex (LVL-1) out_nbr out_frm)
                                                          []
                                                          (minor_dep ∪ major_dep) ]
                                           ∧ ANC = [] )
/- Neighborhood: Type 0 ⊇-Introduction -/
def introduction_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(antecedent consequent out_frm : formula),
                                             ∃(intro out_nbr : ℕ),
                                             ∃(dep : set formula),
                                           ------------------------------------------------------
                                             FML = antecedent>>consequent
                                           ∧ IN = [ edge (vertex (LVL+1) intro antecedent)
                                                          (vertex LVL NBR FML)
                                                          []
                                                          {x | x = antecedent ∨ x ∈ dep} ]
                                           ∧ OUT = [edge (vertex LVL NBR FML)
                                                         (vertex (LVL-1) out_nbr out_frm)
                                                         []
                                                         {x | x ≠ antecedent ∧ x ∈ dep} ]
                                           ∧ ANC = [] )
/- Neighborhood: Type 0 Hypothesis -/
def hypothesis_neighborhood : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( ∃(out_frm : formula),
                                             ∃(out_nbr : ℕ),
                                           ------------------------------------------------------
                                             IN = []
                                           ∧ OUT = [edge (vertex LVL NBR FML)
                                                         (vertex (LVL-1) out_nbr out_frm)
                                                         []
                                                         {FML} ]
                                           ∧ ANC = [] )

/- Colapse: -/
/- Conditions for Collapse -/
def check_nodes : neighborhood → neighborhood → Prop
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := (LVL_U = LVL_V)
                                                     ∧ (LVL_U > 0)
                                                     ∧ (LVL_V > 0)
                                                     ∧ (NBR_U ≠ NBR_V)
                                                     ∧ (FML_U = FML_V)
/- Colapse: Ancestral Edges-/
def loop_ancestral : ℕ → deduction → deduction → ancestral
| COLOUR
  (edge IN_STR IN_END IN_CLR IN_DEP)
  (edge OUT_STR OUT_END OUT_CLR OUT_DEP) := path OUT_END
                                                 IN_STR
                                                 [COLOUR]
def create_ancestral : ℕ → list deduction → list deduction → list ancestral
| COLOUR (HEAD::TAIL) [OUT] := (loop_ancestral COLOUR HEAD OUT)::(create_ancestral COLOUR TAIL [OUT])
| COLOUR IN OUT := []
/- Collapse: Neighborhoods -/
def pre_collapse : neighborhood → neighborhood
| (dag (vertex LVL NBR FML) IN OUT ANC) := dag (vertex LVL NBR FML)
                                               IN
                                               (list_deduction_paint OUT NBR)
                                               (create_ancestral NBR IN OUT)
def horizontal_collapse : neighborhood → neighborhood → neighborhood
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := dag (vertex LVL_U NBR_U FML_U)
                                                           (   IN_U
                                                            ++ list_deduction_rewrite IN_V
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )
                                                           (   (list_deduction_paint OUT_U NBR_U)
                                                            ++ list_deduction_rewrite (list_deduction_paint OUT_V NBR_V)
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )
                                                           (   (create_ancestral NBR_U IN_U OUT_U)
                                                            ++ list_ancestral_rewrite (create_ancestral NBR_V IN_V OUT_V)
                                                                                (vertex LVL_V NBR_V FML_V)
                                                                                (vertex LVL_U NBR_U FML_U)   )

/- Neighborhoods of Collapsed Nodes Without Incoming Ancestral Edges: -/
/- Neighborhood: Type 1 Ancestral Edges -/
def loop_loop_ancestral_set : deduction → deduction → ancestral
| (edge IN_STR IN_END IN_CLR IN_DEP)
  (edge OUT_STR OUT_END OUT_CLR OUT_DEP) := path OUT_END
                                                 IN_STR
                                                 OUT_CLR
def loop_ancestral_set : deduction → list deduction → list ancestral
| IN [] := []
| IN (HEAD::TAIL) := (loop_loop_ancestral_set IN HEAD)::(loop_ancestral_set IN TAIL)
def ancestral_set : list deduction → list deduction → list ancestral
| [] OUT := []
| (HEAD::TAIL) OUT := (loop_ancestral_set HEAD OUT) ++ (ancestral_set TAIL OUT)
/- Neighborhood: Type 1 Collapsed Node -/
def neighborhood_type_01 : neighborhood → Prop
| (dag (vertex LVL NBR FML) IN OUT ANC) := ( IN = IN
                                           ∧ OUT = OUT
                                           ∧ list.length ANC = list.length IN
                                           ∧ ∀(a : ancestral), a ∈ ANC → a ∈ ancestral_set IN OUT )

/- Proofs -/
lemma Add_Lemma :
  ∀{n : ℕ},
  ---------------------------
  ¬( n+1 = n )
| 0 := begin
  rewrite[nat.add_one 0],
  from nat.one_ne_zero,
end
| (n+1) := begin
  rewrite[←nat.succ_eq_add_one (n+1)],
  rewrite[←nat.succ_eq_add_one n],
  simp at ⊢,
  from Add_Lemma,
end
lemma Sub_Lemma :
  ∀{n : ℕ},
  ( n > 0 ) →
  ---------------------------
  ¬( n-1 = n )
| 0 := begin
  assume n_gt_zero,
  have not_n_gt_zero, from gt_irrefl 0,
  from false.elim (not_n_gt_zero n_gt_zero)
end
| (n+1) := begin
  assume n_gt_zero,
  rewrite[←nat.succ_eq_add_one n],
  simp at ⊢,
  have n_lt_succ, from nat.lt_succ_of_le (le_refl n),
  from ne_of_lt n_lt_succ
end

/- Proof Steps: -/
/- Rule 1: ⊇-Introduction = ⊇-Elimination -/
theorem Main_Theorem_Rule_01 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_cases,
  case or.inl { simp [a_case_01] },
  cases a_cases with a_case_02 a_case_03,
  case or.inl { simp [a_case_02] },
  case or.inr { simp [a_case_03] },
end
/- Rule 2: Hypothesis = ⊇-Elimination -/
theorem Main_Theorem_Rule_02 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( hypothesis_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [hypothesis_neighborhood] at prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_case_02,
  case or.inl { simp [a_case_01] },
  case or.inr { simp [a_case_02] },
end
/- Rule 3: ⊇-Introduction = Hypothesis -/
theorem Main_Theorem_Rule_03 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( hypothesis_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [hypothesis_neighborhood] at prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  simp [a_cases],
end
/- Rule 4: Hypothesis = Hypothesis -/
theorem Main_Theorem_Rule_04 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( hypothesis_neighborhood u ) →
  ( hypothesis_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [hypothesis_neighborhood] at prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],

  simp [hypothesis_neighborhood] at prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
end
/- New Rule 1: ⊇-Elimination = ⊇-Elimination -/
theorem Main_Theorem_New_Rule_01 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( elimination_neighborhood u ) →
  ( elimination_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [elimination_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with minor_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with minor_dep_v prop_v,
  cases prop_v with major_dep_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [elimination_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with minor_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with minor_dep_u prop_u,
  cases prop_u with major_dep_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_cases,
  case or.inl { simp [a_case_01] },
  cases a_cases with a_case_02 a_cases,
  case or.inl { simp [a_case_02] },
  cases a_cases with a_case_03 a_case_04,
  case or.inl { simp [a_case_03] },
  case or.inr { simp [a_case_04] },
end
/- New Rule 2: ⊇-Introduction = ⊇-Introduction -/
theorem Main_Theorem_New_Rule_02 :
  ∀(u v : neighborhood),
  ( check_nodes u v ) →
  ( introduction_neighborhood u ) →
  ( introduction_neighborhood v ) →
  ---------------------------
  ( neighborhood_type_01 (horizontal_collapse u v) )
| (dag (vertex LVL_U NBR_U FML_U) IN_U OUT_U ANC_U)
  (dag (vertex LVL_V NBR_V FML_V) IN_V OUT_V ANC_V) := begin
  assume prop_nodes prop_u prop_v,

  simp [check_nodes] at prop_nodes,
  cases prop_nodes with prop_eq_lvl prop_nodes,
  cases prop_nodes with prop_lvl_u prop_nodes,
  cases prop_nodes with prop_lvl_v prop_nodes,
  cases prop_nodes with prop_ne_nbr prop_eq_fml,

  simp [horizontal_collapse],

  simp [introduction_neighborhood] at prop_v,
  cases prop_v with antecedent_v prop_v,
  cases prop_v with consequent_v prop_v,
  cases prop_v with out_frm_v prop_v,
  cases prop_v with intro_v prop_v,
  cases prop_v with out_nbr_v prop_v,
  cases prop_v with dep_v prop_v,
  cases prop_v with prop_fml_v prop_v,
  cases prop_v with prop_in_v prop_v,
  cases prop_v with prop_out_v prop_anc_v,

  rewrite [prop_in_v],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Add_Lemma],

  rewrite [prop_out_v],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [list_deduction_rewrite, deduction_rewrite],
  simp [node_rewrite, Sub_Lemma prop_lvl_v],

  simp [create_ancestral, loop_ancestral],
  simp [list_ancestral_rewrite, ancestral_rewrite],
  simp [node_rewrite, Add_Lemma, Sub_Lemma prop_lvl_v],

  simp [introduction_neighborhood] at prop_u,
  cases prop_u with antecedent_u prop_u,
  cases prop_u with consequent_u prop_u,
  cases prop_u with out_frm_u prop_u,
  cases prop_u with intro_u prop_u,
  cases prop_u with out_nbr_u prop_u,
  cases prop_u with dep_u prop_u,
  cases prop_u with prop_fml_u prop_u,
  cases prop_u with prop_in_u prop_u,
  cases prop_u with prop_out_u prop_anc_u,

  rewrite [prop_in_u, prop_out_u],
  simp [list_deduction_paint, deduction_paint, colour_paint],
  simp [create_ancestral, loop_ancestral],

  simp [neighborhood_type_01],
  simp [ancestral_set],
  simp [loop_ancestral_set],
  simp [loop_loop_ancestral_set],

  assume a a_cases,
  cases a_cases with a_case_01 a_case_02,
  case or.inl { simp [a_case_01] },
  case or.inr { simp [a_case_02] },
end

/- Tests -/
constants LVL_U LVL_V : ℕ
--def LVL_U : ℕ := 10
--def LVL_V : ℕ := 10
constants NBR_U NBR_V : ℕ
--def NBR_U : ℕ := 1
--def NBR_V : ℕ := 2
constants FML_U FML_V : formula
--def FML_U : formula := #1
--def FML_V : formula := #2
constants minor_u out_nbr_u : ℕ
--def minor_u : ℕ := 11
--def out_nbr_u : ℕ := 13
constants antecedent_u out_frm_u : formula
--def antecedent_u : formula := #11
--def out_frm_u : formula := #13
constants minor_dep_u major_dep_u : set formula
--def minor_dep_u : set formula := ∅
--def major_dep_u : set formula := ∅
constants minor_v out_nbr_v : ℕ
--def minor_v : ℕ := 21
--def out_nbr_v : ℕ := 23
constants antecedent_v out_frm_v : formula
--def antecedent_v : formula := #21
--def out_frm_v : formula := #23
constants minor_dep_v major_dep_v : set formula
--def minor_dep_v : set formula := ∅
--def major_dep_v : set formula := ∅

--ancestral_set
--  [ edge ((LVL_U + 1)&&minor_u&&antecedent_u) (LVL_U&&NBR_U&&FML_U) [] minor_dep_u,
--    edge ((LVL_U + 1)&&(minor_u + 1)&&antecedent_u>>FML_U) (LVL_U&&NBR_U&&FML_U) [] major_dep_u,
--    edge ((LVL_V + 1)&&minor_v&&antecedent_v) (LVL_U&&NBR_U&&FML_U) [] minor_dep_v,
--	edge ((LVL_V + 1)&&(minor_v + 1)&&antecedent_v>>FML_V) (LVL_U&&NBR_U&&FML_U) [] major_dep_v ]
--  [ edge (LVL_U&&NBR_U&&FML_U) ((LVL_U - 1)&&out_nbr_u&&out_frm_u) [NBR_U] (minor_dep_u ∪ major_dep_u),
--    edge (LVL_U&&NBR_U&&FML_U) ((LVL_V - 1)&&out_nbr_v&&out_frm_v) [NBR_V] (minor_dep_v ∪ major_dep_v) ]
--=
--[ path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_U&&minor_u&&antecedent_u) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_U&&minor_u&&antecedent_u) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_U&&nat.succ minor_u&&antecedent_u>>FML_U) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_U&&nat.succ minor_u&&antecedent_u>>FML_U) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_V&&minor_v&&antecedent_v) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_V&&minor_v&&antecedent_v) [NBR_V],
--  path (nat.pred LVL_U&&out_nbr_u&&out_frm_u) (nat.succ LVL_V&&nat.succ minor_v&&antecedent_v>>FML_V) [NBR_U],
--  path (nat.pred LVL_V&&out_nbr_v&&out_frm_v) (nat.succ LVL_V&&nat.succ minor_v&&antecedent_v>>FML_V) [NBR_V] ]

def ANC := ancestral_set  [ edge ((LVL_U + 1)&&minor_u&&antecedent_u) (LVL_U&&NBR_U&&FML_U) [] minor_dep_u, edge ((LVL_U + 1)&&(minor_u + 1)&&antecedent_u>>FML_U) (LVL_U&&NBR_U&&FML_U) [] major_dep_u, edge ((LVL_V + 1)&&minor_v&&antecedent_v) (LVL_U&&NBR_U&&FML_U) [] minor_dep_v, edge ((LVL_V + 1)&&(minor_v + 1)&&antecedent_v>>FML_V) (LVL_U&&NBR_U&&FML_U) [] major_dep_v ]  [ edge (LVL_U&&NBR_U&&FML_U) ((LVL_U - 1)&&out_nbr_u&&out_frm_u) [NBR_U] (minor_dep_u ∪ major_dep_u), edge (LVL_U&&NBR_U&&FML_U) ((LVL_V - 1)&&out_nbr_v&&out_frm_v) [NBR_V] (minor_dep_v ∪ major_dep_v) ]

#check ANC
#print ANC
#reduce ANC


import Myint.Sub

namespace myint

def mymul (m n : myint) : myint :=
  myint.mk (m.x * n.x + m.y * n.y) (m.x * n.y + m.y * n.x)

instance : Mul myint where
  mul := mymul

theorem mul_eq_mymul (a b : myint) : a * b = mymul a b := rfl
theorem mul_zero (a : myint) : a * 0 ≈ 0 := rfl

theorem zero_mul (m : myint) : 0 * m ≈ 0 := by
  rw [mul_eq_mymul]
  rw [mymul]
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [destruct_x]
    rw [zerox, zeroy]
    rw [mynat.zero_mul, mynat.zero_mul]
    rfl
  . rw [destruct_y]
    rw [zerox, zeroy]
    rw [mynat.zero_mul, mynat.zero_mul]
    rfl

theorem mul_one (a : myint) : a * 1 ≈ a := by
  rw [mul_eq_mymul]
  rw [mymul]
  rw [default_nat_has_same_x 1]
  rw [default_nat_has_no_y]
  rw [mynat.mul_zero, mynat.mul_zero]
  rw [mynat.add_zero, mynat.zero_add]
  rw [mynat.myofnat, mynat.myofnat]
  rw [mynat.mynat_zero_eq_zero]
  rw [← mynat.one_eq_succ_zero]
  rw [mynat.mul_one, mynat.mul_one]
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [destruct_x]
  . rw [destruct_y]

theorem mul_negone (a : myint) : a * -1 ≈ -a := by
  have hnegonex : (-1 : myint).x = 0 := by
    rw [neg_eq_myneg]
    rw [myneg]
    rw [destruct_x]
    rw [default_nat_has_no_y]
  have hnegoney : (-1 : myint).y = 1 := by
    rw [neg_eq_myneg]
    rw [myneg]
    rw [destruct_y]
    rw [default_nat_has_same_x]
    rw [mynat.myofnat, mynat.myofnat]
    rw [mynat.mynat_zero_eq_zero]
    rfl
  rw [mul_eq_mymul]
  rw [mymul]
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [destruct_x]
    rw [hnegonex, hnegoney]
    rw [mynat.mul_zero]
    rw [mynat.zero_add]
    rw [mynat.mul_one]
    rw [neg_eq_myneg]
    rw [myneg]
  . rw [destruct_y]
    rw [hnegonex, hnegoney]
    rw [mynat.mul_zero]
    rw [mynat.add_zero]
    rw [mynat.mul_one]
    rw [neg_eq_myneg]
    rw [myneg]

theorem one_mul (m : myint) : 1 * m ≈ m := by
  rw [mul_eq_mymul, mymul]
  rw [default_nat_has_same_x]
  rw [mynat.myofnat, mynat.myofnat, mynat.mynat_zero_eq_zero, ← mynat.one_eq_succ_zero]
  rw [default_nat_has_no_y]
  rw [mynat.zero_mul, mynat.zero_mul]
  rw [mynat.one_mul, mynat.one_mul]
  rw [mynat.add_zero, mynat.add_zero]
  rw [equiv_is_myequal, myequal]
  rw [destruct_x, destruct_y]
  rw [mynat.add_comm]

theorem mul_add (t a b : myint) : t * (a + b) ≈ t * a + t * b := by
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [mul_eq_mymul, mymul]
    rw [destruct_x]
    rw [add_x, add_y, add_x]
    rw [mul_eq_mymul, mymul]
    rw [destruct_x (t.x * a.x + t.y * a.y) _]
    rw [mul_eq_mymul, mymul]
    rw [destruct_x (t.x * b.x + t.y * b.y) _]
    rw [← mynat.add_assoc]
    rw [mynat.add_assoc (t.x * a.x) _]
    rw [mynat.add_comm (t.y * a.y) _]
    rw [← mynat.add_assoc]
    rw [mynat.mul_add, mynat.mul_add]
    rw [← mynat.add_assoc]
  . rw [mul_eq_mymul, mymul]
    rw [destruct_y]
    rw [add_x, add_y, add_y]
    rw [mul_eq_mymul, mymul]
    rw [destruct_y _ (t.x * a.y + t.y * a.x)]
    rw [mul_eq_mymul, mymul]
    rw [destruct_y _ (t.x * b.y + t.y * b.x)]
    rw [← mynat.add_assoc]
    rw [mynat.add_assoc (t.x * a.y) _]
    rw [mynat.add_comm (t.y * a.x) _]
    rw [← mynat.add_assoc]
    rw [mynat.mul_add, mynat.mul_add]
    rw [← mynat.add_assoc]

theorem mul_assoc (a b c : myint) : (a * b) * c ≈ a * (b * c) := by
  rw [mul_eq_mymul, mul_eq_mymul, mul_eq_mymul, mul_eq_mymul]
  rw [mymul, mymul, mymul, mymul]
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [destruct_x, destruct_x]
    conv =>
      rhs
      rw [destruct_x]
      congr
      . arg 2
        rw [destruct_x]
      . arg 2
        rw [destruct_y]
    conv =>
      lhs
      arg 2
      arg 1
      rw [destruct_y]
    rw [mynat.add_mul, mynat.add_mul, mynat.mul_add, mynat.mul_add]
    rw [← mynat.mul_assoc, ← mynat.mul_assoc, ← mynat.mul_assoc, ← mynat.mul_assoc]
    conv =>
      rhs
      rw [mynat.add_comm (a.y * b.x * c.y) _]
      rw [← mynat.add_assoc]
      rw [mynat.add_assoc (a.x * b.x * c.x) _ _]
      rw [mynat.add_comm (a.x * b.y * c.y)]
      rw [← mynat.add_assoc]
    rw [← mynat.add_assoc]
  . rw [destruct_x, destruct_y]
    conv =>
      rhs
      rw [destruct_y]
      congr
      . arg 2
        rw [destruct_y]
      . arg 2
        rw [destruct_x]
    conv =>
      lhs
      arg 2
      arg 1
      rw [destruct_y]
    rw [mynat.add_mul, mynat.add_mul, mynat.mul_add, mynat.mul_add]
    rw [← mynat.mul_assoc, ← mynat.mul_assoc, ← mynat.mul_assoc, ← mynat.mul_assoc]
    conv =>
      rhs
      rw [mynat.add_comm (a.y * b.x * c.x) _]
      rw [← mynat.add_assoc]
      rw [mynat.add_assoc (a.x * b.x * c.y) _ _]
      rw [mynat.add_comm (a.x * b.y * c.x)]
      rw [← mynat.add_assoc]
    rw [← mynat.add_assoc]

theorem mul_comm (a b : myint) : a * b ≈ b * a := by
  rw [mul_eq_mymul, mymul, mul_eq_mymul, mymul]
  apply if_x_and_y_equal_then_equiv
  apply And.intro
  . rw [destruct_x, destruct_x (b.x * a.x + b.y * a.y)]
    rw [mynat.mul_comm, mynat.mul_comm a.y _]
  . rw [destruct_y, destruct_y _ (b.x * a.y + b.y * a.x)]
    rw [mynat.mul_comm, mynat.mul_comm a.y _]
    rw [mynat.add_comm]

theorem add_mul (a b t : myint) : (a + b) * t ≈ a * t + b * t := by
  have h1 : (a + b) * t ≈ t * (a + b) := mul_comm (a + b) t
  have h2 : t * (a + b) ≈ t * a + t * b := mul_add t a b
  have h3 : t * a ≈ a * t := mul_comm t a
  have h4 : t * b ≈ b * t := mul_comm t b
  have h5 := add_equiv (t * a) (a * t) (t * b) (b * t) ⟨ h3, h4 ⟩
  exact trans (trans h1 h2) h5

theorem mul_right (a b t : myint) : a ≈ b → a * t ≈ b * t := by
  intro h
  rw [mul_eq_mymul, mul_eq_mymul]
  rw [mymul, mymul]
  rw [equiv_is_myequal, myequal]
  rw [destruct_x]
  rw [destruct_y _ (b.x * t.y + b.y * t.x)]
  rw [destruct_x (b.x * t.x + b.y * t.y) _]
  rw [destruct_y _ (a.x * t.y + a.y * t.x)]
  rw [equiv_is_myequal, myequal] at h
  have htx : (a.x + b.y) * t.x = (a.y + b.x) * t.x := by rw[h]
  have hty : (a.x + b.y) * t.y = (a.y + b.x) * t.y := by rw[h]
  rw [mynat.add_comm (b.x * t.y) _]
  rw [mynat.add_comm (a.x * t.y) _]
  rw [← mynat.add_assoc, ← mynat.add_assoc]
  rw [mynat.add_assoc (a.x * t.x) _]
  rw [mynat.add_comm (a.y * t.y) _]
  rw [← mynat.add_assoc]
  rw [mynat.add_assoc (a.y * t.x) _]
  rw [mynat.add_comm (a.x * t.y) _]
  rw [← mynat.add_assoc]
  rw [← mynat.add_mul, ← mynat.add_mul]
  rw [mynat.add_assoc, ← mynat.add_mul]
  rw [mynat.add_assoc, ← mynat.add_mul]
  rw [htx, hty]

theorem mul_left (t a b : myint) : a ≈ b → t * a ≈ t * b := by
  intro h
  have := mul_right a b t h
  exact trans (trans (mul_comm t a) this) (mul_comm b t)

theorem mul_left_comm (a b c : myint) : a * (b * c) ≈ b * (a * c) := by
  have h1 : a * (b * c) ≈ a * b * c := symm (mul_assoc a b c)
  have h2 : a * b * c ≈ b * a * c := mul_right (a * b) (b * a) c (mul_comm a b)
  have h3 : b * a * c ≈ b * (a * c) := mul_assoc b a c
  exact trans (trans h1 h2) h3

attribute [simp] mul_assoc mul_comm mul_left_comm

theorem eq_zero_or_eq_zero_of_mul_eq_zero (a b : myint) (h : a * b ≈ 0) :
  a ≈ 0 ∨ b ≈ 0 := by
  rw [mul_eq_mymul, mymul] at h
  rw [equiv_is_myequal, myequal] at h
  rw [destruct_x, destruct_y _ (a.x * b.y + a.y * b.x)] at h
  rw [zerox, zeroy] at h
  repeat rw [mynat.add_zero] at h
  rw [equiv_is_myequal, myequal, zerox, zeroy, mynat.add_zero, mynat.add_zero]
  rw [equiv_is_myequal, myequal, zerox, zeroy, mynat.add_zero, mynat.add_zero]
  apply Or.elim (Classical.em (a.x = a.y))
  . intro h'
    apply Or.intro_left
    exact h'
  . intro h'
    apply Or.intro_right
    have h'' : a.x ≠ a.y := h'
    have hfull : a.x * b.x + a.y * b.y + a.x * b.y + a.y * b.x = a.x * b.y + a.y * b.x + a.x * b.y + a.y * b.x := by rw [h]
    cases mynat.le_total a.x a.y
    case right.h.inl hh =>
      rw [mynat.le_iff_exists_add] at hh
      cases hh with
      | intro c hc =>
        rw [hc] at hfull
        repeat rw [mynat.add_mul] at hfull
        simp at hfull
        have := mynat.add_left_cancel (c * b.x) _ _ hfull
        have := mynat.add_left_cancel _ _ _ this
        have := mynat.add_left_cancel _ _ _ this
        repeat rw [← mynat.add_assoc] at this
        rw [mynat.add_comm (c * b.x) _] at this
        have := mynat.add_right_cancel _ _ _ this
        have hlast := mynat.add_left_cancel _ _ _ this
        rename_i h_ h__ h___ -- this is so dirty ...
        cases c
        case zero =>
          apply False.elim
          rw [mynat.mynat_zero_eq_zero] at hc
          rw [mynat.add_zero] at hc
          exact h'' (Eq.symm hc)
        case succ d =>
          have hsnez := mynat.succ_ne_zero d
          exact Eq.symm (mynat.mul_left_cancel (mynat.succ d) b.y b.x hsnez hlast)
    case right.h.inr hh =>
      rw [mynat.le_iff_exists_add] at hh
      cases hh with
      | intro c hc =>
        rw [hc] at hfull
        repeat rw [mynat.add_mul] at hfull
        simp at hfull
        have := mynat.add_left_cancel _ _ _ hfull
        rw [← mynat.add_assoc (b.x * a.y) _ _] at this
        rw [mynat.add_comm (b.x * a.y) _] at this
        rw [mynat.add_assoc (a.y * b.y) _ _] at this
        have := mynat.add_right_cancel (c * b.x) (a.y * b.y + (b.x * a.y + (c * b.y + a.y * b.y))) (c * b.y) this
        rename_i h_ -- this is so dirty ...
        cases c
        case zero =>
          apply False.elim
          rw [mynat.mynat_zero_eq_zero] at hc
          rw [mynat.add_zero] at hc
          exact h'' hc
        case succ d =>
          have hsnez := mynat.succ_ne_zero d
          exact mynat.mul_left_cancel (mynat.succ d) b.x b.y hsnez this

theorem mul_eq_zero_iff (a b : myint): a * b ≈ 0 ↔ a ≈ 0 ∨ b ≈ 0 := by
  apply Iff.intro
  . intro h
    exact eq_zero_or_eq_zero_of_mul_eq_zero a b h
  . intro h
    cases h
    . rename_i hh
      have := mul_right a 0 b hh
      exact trans this (zero_mul b)
    . rename_i hh
      have := mul_right b 0 a hh
      have := trans this (zero_mul a)
      have := trans (mul_comm a b) this
      exact this

theorem mul_left_cancel (a b c : myint) (ha : a ≉ 0) : a * b ≈ a * c → b ≈ c := by
  intro h
  have := (sub_right (a * b) (a * c) (a * c)) h
  repeat rw [sub_eq_plusneg] at this
  have hez : a * b + -(a * c) ≈ 0 := trans this (neg_is_inv _)
  have : -(a * c) ≈ a * c * -1 := (symm (mul_negone (a * c)))
  have : a * b + -(a * c) ≈ a * b + a * c * -1 := add_left (a * b) _ _ this
  have : a * b + a * c * -1 ≈ 0 := trans (symm this) hez
  have hma : a * c * -1 ≈ a * (c * -1) := mul_assoc _ _ _
  have hz : a * b + a * (c * -1) ≈ 0 := trans (symm (add_left (a * b) _ _ hma)) this
  have := mul_add a b (c * -1)
  have : a * (b + c * -1) ≈ 0 := trans this hz
  have heitherzero := eq_zero_or_eq_zero_of_mul_eq_zero a (b + c * -1) this
  cases heitherzero
  case inl haz =>
    apply False.elim
    exact ha haz
  case inr hs =>
    have : c + (b + c * -1) ≈ c + 0 := add_left c (b + c * -1) 0 hs
    have hbc : c + b + c * -1 ≈ c + 0 := trans (add_assoc _ _ _) this
    have : c * -1 ≈ -c := mul_negone c
    have : c + b + c * -1 ≈ c + b + -c := add_left _ _ _ this
    have : c + b + -c ≈ c + 0 := trans (symm this) hbc
    have hlast : c + b + -c ≈ c := trans this (add_zero c)
    have hcomm := add_comm b c
    have := add_right (b + c) (c + b) (-c) hcomm
    have : b + c + -c ≈ c := trans this hlast
    have hg : b + (c + -c) ≈ c := trans (symm (add_assoc _ _ _)) this
    have : b + (c + -c) ≈ b + 0 := (add_left b _ _) (neg_is_inv c)
    exact trans (symm this) hg

end myint