/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad
-/

/-!
# booleans

This file proves various trivial lemmas about booleans and their
relation to decidable propositions.

## Notations

This file introduces the notation `!b` for `bnot b`, the boolean "not".

## Tags
bool, boolean, De Morgan
-/

prefix `!`:90 := bnot

namespace bool

-- TODO: duplicate of a lemma in core
theorem coe_sort_tt : coe_sort.{1 1} tt = true := coe_sort_tt

-- TODO: duplicate of a lemma in core
theorem coe_sort_ff : coe_sort.{1 1} ff = false := coe_sort_ff

-- TODO: duplicate of a lemma in core
theorem to_bool_true {h} : @to_bool true h = tt :=
to_bool_true_eq_tt h

-- TODO: duplicate of a lemma in core
theorem to_bool_false {h} : @to_bool false h = ff :=
to_bool_false_eq_ff h

@[simp] theorem to_bool_coe (b:bool) {h} : @to_bool b h = b :=
(show _ = to_bool b, by congr).trans (by cases b; refl)

theorem coe_to_bool (p : Prop) [decidable p] : to_bool p ↔ p := to_bool_iff _

@[simp] lemma of_to_bool_iff {p : Prop} [decidable p] : to_bool p ↔ p :=
⟨of_to_bool_true, _root_.to_bool_true⟩

@[simp] lemma tt_eq_to_bool_iff {p : Prop} [decidable p] : tt = to_bool p ↔ p :=
eq_comm.trans of_to_bool_iff

@[simp] lemma ff_eq_to_bool_iff {p : Prop} [decidable p] : ff = to_bool p ↔ ¬ p :=
eq_comm.trans (to_bool_ff_iff _)

@[simp] theorem to_bool_not (p : Prop) [decidable p] : to_bool (¬ p) = bnot (to_bool p) :=
by by_cases p; simp *

@[simp] theorem to_bool_and (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∧ q) = p && q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_or (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∨ q) = p || q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_eq {p q : Prop} [decidable p] [decidable q] :
  to_bool p = to_bool q ↔ (p ↔ q) :=
⟨λ h, (coe_to_bool p).symm.trans $ by simp [h], to_bool_congr⟩

lemma not_ff : ¬ ff := ff_ne_tt

@[simp] theorem default_bool : default = ff := rfl

theorem dichotomy (b : bool) : b = ff ∨ b = tt :=
by cases b; simp

@[simp] theorem forall_bool {p : bool → Prop} : (∀ b, p b) ↔ p ff ∧ p tt :=
⟨λ h, by simp [h], λ ⟨h₁, h₂⟩ b, by cases b; assumption⟩

@[simp] theorem exists_bool {p : bool → Prop} : (∃ b, p b) ↔ p ff ∨ p tt :=
⟨λ ⟨b, h⟩, by cases b; [exact or.inl h, exact or.inr h],
 λ h, by cases h; exact ⟨_, h⟩⟩

/-- If `p b` is decidable for all `b : bool`, then `∀ b, p b` is decidable -/
instance decidable_forall_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∀ b, p b) :=
decidable_of_decidable_of_iff and.decidable forall_bool.symm

/-- If `p b` is decidable for all `b : bool`, then `∃ b, p b` is decidable -/
instance decidable_exists_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∃ b, p b) :=
decidable_of_decidable_of_iff or.decidable exists_bool.symm

@[simp] theorem cond_ff {α} (t e : α) : cond ff t e = e := rfl

@[simp] theorem cond_tt {α} (t e : α) : cond tt t e = t := rfl

@[simp] theorem cond_to_bool {α} (p : Prop) [decidable p] (t e : α) :
  cond (to_bool p) t e = if p then t else e :=
by by_cases p; simp *

@[simp] theorem cond_bnot {α} (b : bool) (t e : α) : cond (!b) t e = cond b e t :=
by cases b; refl

theorem coe_bool_iff : ∀ {a b : bool}, (a ↔ b) ↔ a = b := dec_trivial

theorem eq_tt_of_ne_ff : ∀ {a : bool}, a ≠ ff → a = tt := dec_trivial

theorem eq_ff_of_ne_tt : ∀ {a : bool}, a ≠ tt → a = ff := dec_trivial

theorem bor_comm : ∀ a b, a || b = b || a := dec_trivial

@[simp] theorem bor_assoc : ∀ a b c, (a || b) || c = a || (b || c) := dec_trivial

theorem bor_left_comm : ∀ a b c, a || (b || c) = b || (a || c) := dec_trivial

theorem bor_inl {a b : bool} (H : a) : a || b :=
by simp [H]

theorem bor_inr {a b : bool} (H : b) : a || b :=
by simp [H]

theorem band_comm : ∀ a b, a && b = b && a := dec_trivial

@[simp] theorem band_assoc : ∀ a b c, (a && b) && c = a && (b && c) := dec_trivial

theorem band_left_comm : ∀ a b c, a && (b && c) = b && (a && c) := dec_trivial

theorem band_elim_left : ∀ {a b : bool}, a && b → a := dec_trivial

theorem band_intro : ∀ {a b : bool}, a → b → a && b := dec_trivial

theorem band_elim_right : ∀ {a b : bool}, a && b → b := dec_trivial

lemma band_bor_distrib_left (a b c : bool) : a && (b || c) = a && b || a && c := by cases a; simp
lemma band_bor_distrib_right (a b c : bool) : (a || b) && c = a && c || b && c := by cases c; simp
lemma bor_band_distrib_left (a b c : bool) : a || b && c = (a || b) && (a || c) := by cases a; simp
lemma bor_band_distrib_right (a b c : bool) : a && b || c = (a || c) && (b || c) := by cases c; simp

@[simp] theorem bnot_false : bnot ff = tt := rfl

@[simp] theorem bnot_true : bnot tt = ff := rfl

@[simp] lemma not_eq_bnot : ∀ {a b : bool}, ¬a = !b ↔ a = b := dec_trivial
@[simp] lemma bnot_not_eq : ∀ {a b : bool}, ¬!a = b ↔ a = b := dec_trivial

lemma ne_bnot {a b : bool} : a ≠ !b ↔ a = b := not_eq_bnot
lemma bnot_ne {a b : bool} : !a ≠ b ↔ a = b := bnot_not_eq

@[simp] theorem bnot_iff_not : ∀ {b : bool}, !b ↔ ¬b := dec_trivial

theorem eq_tt_of_bnot_eq_ff : ∀ {a : bool}, bnot a = ff → a = tt := dec_trivial

theorem eq_ff_of_bnot_eq_tt : ∀ {a : bool}, bnot a = tt → a = ff := dec_trivial

@[simp] lemma band_bnot_self : ∀ x, x && !x = ff := dec_trivial
@[simp] lemma bnot_band_self : ∀ x, !x && x = ff := dec_trivial
@[simp] lemma bor_bnot_self : ∀ x, x || !x = tt := dec_trivial
@[simp] lemma bnot_bor_self : ∀ x, !x || x = tt := dec_trivial

theorem bxor_comm : ∀ a b, bxor a b = bxor b a := dec_trivial
@[simp] theorem bxor_assoc : ∀ a b c, bxor (bxor a b) c = bxor a (bxor b c) := dec_trivial
theorem bxor_left_comm : ∀ a b c, bxor a (bxor b c) = bxor b (bxor a c) := dec_trivial
@[simp] theorem bxor_bnot_left : ∀ a, bxor (!a) a = tt := dec_trivial
@[simp] theorem bxor_bnot_right : ∀ a, bxor a (!a) = tt := dec_trivial
@[simp] theorem bxor_bnot_bnot : ∀ a b, bxor (!a) (!b) = bxor a b := dec_trivial
@[simp] theorem bxor_ff_left : ∀ a, bxor ff a = a := dec_trivial
@[simp] theorem bxor_ff_right : ∀ a, bxor a ff = a := dec_trivial

lemma band_bxor_distrib_left (a b c : bool) : a && (bxor b c) = bxor (a && b) (a && c) :=
by cases a; simp
lemma band_bxor_distrib_right (a b c : bool) : (bxor a b) && c = bxor (a && c) (b && c) :=
by cases c; simp

lemma bxor_iff_ne : ∀ {x y : bool}, bxor x y = tt ↔ x ≠ y := dec_trivial

/-! ### De Morgan's laws for booleans-/
@[simp] lemma bnot_band : ∀ (a b : bool), !(a && b) = !a || !b := dec_trivial
@[simp] lemma bnot_bor : ∀ (a b : bool), !(a || b) = !a && !b := dec_trivial

lemma bnot_inj : ∀ {a b : bool}, !a = !b → a = b := dec_trivial

instance : linear_order bool :=
{ le := λ a b, a = ff ∨ b = tt,
  le_refl := dec_trivial,
  le_trans := dec_trivial,
  le_antisymm := dec_trivial,
  le_total := dec_trivial,
  decidable_le := infer_instance,
  decidable_eq := infer_instance,
  max := bor,
  max_def := by { funext x y, revert x y, exact dec_trivial },
  min := band,
  min_def := by { funext x y, revert x y, exact dec_trivial } }

@[simp] lemma ff_le {x : bool} : ff ≤ x := or.intro_left _ rfl

@[simp] lemma le_tt {x : bool} : x ≤ tt := or.intro_right _ rfl

lemma lt_iff : ∀ {x y : bool}, x < y ↔ x = ff ∧ y = tt := dec_trivial

@[simp] lemma ff_lt_tt : ff < tt := lt_iff.2 ⟨rfl, rfl⟩

lemma le_iff_imp : ∀ {x y : bool}, x ≤ y ↔ (x → y) := dec_trivial

lemma band_le_left : ∀ x y : bool, x && y ≤ x := dec_trivial

lemma band_le_right : ∀ x y : bool, x && y ≤ y := dec_trivial

lemma le_band : ∀ {x y z : bool}, x ≤ y → x ≤ z → x ≤ y && z := dec_trivial

lemma left_le_bor : ∀ x y : bool, x ≤ x || y := dec_trivial

lemma right_le_bor : ∀ x y : bool, y ≤ x || y := dec_trivial

lemma bor_le : ∀ {x y z}, x ≤ z → y ≤ z → x || y ≤ z := dec_trivial

/-- convert a `bool` to a `ℕ`, `false -> 0`, `true -> 1` -/
def to_nat (b : bool) : ℕ :=
cond b 1 0

/-- convert a `ℕ` to a `bool`, `0 -> false`, everything else -> `true` -/
def of_nat (n : ℕ) : bool :=
to_bool (n ≠ 0)

lemma of_nat_le_of_nat {n m : ℕ} (h : n ≤ m) : of_nat n ≤ of_nat m :=
begin
  simp [of_nat];
    cases nat.decidable_eq n 0;
    cases nat.decidable_eq m 0;
    simp only [to_bool],
  { subst m, have h := le_antisymm h (nat.zero_le _),
    contradiction },
  { left, refl }
end

lemma to_nat_le_to_nat {b₀ b₁ : bool} (h : b₀ ≤ b₁) : to_nat b₀ ≤ to_nat b₁ :=
by cases h; subst h; [cases b₁, cases b₀]; simp [to_nat,nat.zero_le]

lemma of_nat_to_nat (b : bool) : of_nat (to_nat b) = b :=
by cases b; simp only [of_nat,to_nat]; exact dec_trivial

@[simp] lemma injective_iff {α : Sort*} {f : bool → α} : function.injective f ↔ f ff ≠ f tt :=
⟨λ Hinj Heq, ff_ne_tt (Hinj Heq),
  λ H x y hxy, by { cases x; cases y, exacts [rfl, (H hxy).elim, (H hxy.symm).elim, rfl] }⟩

/-- **Kaminski's Equation** -/
theorem apply_apply_apply (f : bool → bool) (x : bool) : f (f (f x)) = f x :=
by cases x; cases h₁ : f tt; cases h₂ : f ff; simp only [h₁, h₂]

end bool


/-
Chapter 4: Facts about Proofs and Provability
Author: Billy Price
-/
import definitions
import tactic.induction

namespace nat_deduction

-- The intuitionistic provability relation on sets of Formulas and Formulas
-- The sole constructor takes a deduction of the appropriate type
inductive provable (X : set Form) (A : Form) : Prop
| mk : X ≻ A → provable

infix ` ⊢I `:60 := provable

variables {A B C : Form}
variables {X Y : set Form}

-- Constructs a non-normalised deduction mimicking the cut rule
def cut_deduction (A : Form) : (X ∪ {A} ≻ B) → (Y ≻ A) → (X ∪ Y ≻ B) :=
begin
  intros XAdB YdA,
  apply ⟹E A,
  apply ⟹I,
    rw [set.union_assoc,
        set.union_comm,
        set.union_assoc,
        set.union_comm _ X],
    exact weaken_union_left XAdB,
  exact weaken_union_left YdA
end

/- The following theorems lift the deduction rules to provability equivalences -/

theorem provable.and_iff : X ⊢I (A ⋀ B) ↔ (X ⊢I A) ∧ (X ⊢I B) :=
begin
  split,
    { rintro ⟨XdAB⟩,
      exact ⟨⟨⋀E₁ _ _ XdAB⟩,⟨⋀E₂ _ _ XdAB⟩⟩ },
    { rintro ⟨⟨XdA⟩,⟨XdB⟩⟩, exact ⟨⋀I XdA XdB⟩ }
end

theorem provable.imp_iff : X ⊢I (A ⟹ B) ↔ X ∪ {A} ⊢I B :=
begin
  split,
    { rintro ⟨XdAB⟩, exact ⟨⟹E A (weaken_union_right XdAB) (by assump)⟩ },
    { rintro ⟨XAdB⟩, exact ⟨⟹I XAdB⟩ }
end

theorem provable.neg_iff : X ⊢I (¬ A) ↔ X ∪ {A} ⊢I ⊥ := provable.imp_iff

theorem provable.explosion : X ⊢I ⊥ → X ⊢I A :=
  λ ⟨XdF⟩, ⟨⊥E XdF⟩

theorem provable.cut {X Y} (A : Form) {B} : X ∪ {A} ⊢I B → Y ⊢I A → X ∪ Y ⊢I B :=
  λ ⟨XAdB⟩ ⟨YdA⟩, by constructor; apply cut_deduction; assumption

theorem proof_from_or_iff : X ∪ {A ⋁ B} ⊢I C ↔ X ∪ {A} ⊢I C ∧ X ∪ {B} ⊢I C :=
begin
  split,
    { rintro ⟨XdAB⟩,
      split; apply provable.cut (A ⋁ B) ⟨XdAB⟩; constructor,
      apply ⋁I₁, assump, apply ⋁I₂, assump },
    { rintro ⟨⟨XdA⟩,⟨XdB⟩⟩, constructor, apply ⋁E A B, assump,
      all_goals {rw [set.union_comm, ←set.union_assoc, set.union_comm _ X], apply weaken_union_right, assumption } }
end

theorem provable.refl {A : Form} : {A} ⊢I A := ⟨by assump⟩

/-- Cuts out the minimal finite set of assumptions needed in any deduction
and produces the compactified proof -/
def compactify {X A} : X ≻ A → { d : Σ X' : finset Form, ↑X' ≻ A // ↑d.1 ⊆ X } :=
begin
  intro dXA,
  induction' dXA,
  case assumption : { use {A}, tidy, assump },
  case and_intro : X A B dXA dXB ih₁ ih₂
    { rcases ih₁ with ⟨⟨X₁, X₁dA⟩⟩,
      rcases ih₂ with ⟨⟨X₂, X₂dB⟩⟩,
      use (X₁ ∪ X₂),
      rw finset.coe_union,
      apply ⋀I,
        { exact weaken_union_right X₁dA }, { rw set.union_comm, exact weaken_union_right X₂dB },
      tidy
    },
  case and_left : { rcases ih with ⟨⟨X', X'dAB⟩⟩, use X', exact ⋀E₁ _ _ X'dAB, tidy },
  case and_right : { rcases ih with ⟨⟨X', X'dAB⟩⟩, use X', exact ⋀E₂ _ _ X'dAB, tidy },
  case imp_intro : X A B
    { rcases ih with ⟨⟨X', X'dB⟩⟩, use X' \ {A};
      simp only [finset.coe_sdiff, finset.coe_singleton] at *,
      apply ⟹I,
      rw set.diff_union_self,
      exact weaken_union_right X'dB,
      rwa [set.diff_subset_iff, set.union_comm] },
  case imp_elim : X A B dXAB dA ihAB ihA
    { rcases ihAB with ⟨⟨X₁, X₁dAB⟩⟩,
      rcases ihA with ⟨⟨X₂, X₂dA⟩⟩,
      use X₁ ∪ X₂; simp [finset.coe_union] at *,
      exact ⟹E A (weaken_union_right X₁dAB) (weaken_union_left X₂dA),
      tidy },
  case or_left : X A B { rcases ih with ⟨⟨X', X'dA⟩⟩, use X', exact ⋁I₁ X'dA, tidy },
  case or_right : X A B { rcases ih with ⟨⟨X', X'dA⟩⟩, use X', exact ⋁I₂ X'dA, tidy },
  case or_elim : X A B C _ _ _ ih₁ ih₂ ih₃
  {
    rcases ih₁ with ⟨⟨X₁, dX₁AB⟩, sub₁X⟩,
    rcases ih₂ with ⟨⟨X₂, dX₂C⟩, sub₂X⟩,
    rcases ih₃ with ⟨⟨X₃, dX₃C⟩, sub₃X⟩,
    use X₁ ∪ (X₂ \ {A}) ∪ (X₃ \ {B}); simp [finset.coe_union, finset.coe_sdiff, finset.coe_singleton],
    apply ⋁E A B (weaken_union_right dX₁AB),
      { have : ↑X₁ ∪ (↑X₂ \ {A} ∪ ↑X₃ \ {B}) ∪ {A} = ↑X₂ ∪ ({A} ∪ (↑X₃ \ {B} ∪ ↑X₁)),
          { rw [@set.union_assoc Form,
                set.union_assoc _ _ {A},
                set.union_comm _ {A},
                ←set.union_assoc _ {A},
                set.diff_union_self,
                set.union_comm,
                set.union_assoc,
                set.union_assoc] },
        rw this,
        exact weaken_union_right dX₂C },
      { have : ↑X₁ ∪ (↑X₂ \ {A} ∪ ↑X₃ \ {B}) ∪ {B} = ↑X₃ ∪ ({B} ∪ (↑X₁ ∪ ↑X₂ \ {A})),
          { rw [ @set.union_assoc Form,
                  set.union_assoc,
                  set.diff_union_self,
                  ←set.union_assoc,
                  set.union_comm,
                  set.union_assoc ] },
        rw this,
        exact weaken_union_right dX₃C },
    tidy,
  },
  case falsum : { rcases ih with ⟨⟨X',X'dF⟩⟩, use X', apply ⊥E X'dF, tidy },
end

/--Theorem 2 of Chapter 4-/
theorem compactness {X : set Form} {A : Form} : X ⊢I A → ∃ X' : finset Form, ↑X' ⊆ X ∧ ↑X' ⊢I A :=
  λ ⟨XdA⟩, by { rcases compactify XdA with ⟨⟨X', X'dA⟩, X'subX⟩, use X', split, assumption, exact ⟨X'dA⟩ }

/--Definition 11 of Chapter 4-/
def inconsistent (X : set Form) : Prop := X ⊢I ⊥

/- TODO: Formalise detour formulas and detour sequences  - How??? -/

def subformulas : Form → set Form
| ⊥ := {⊥}
| (n : ℕ) := {n}
| (A ⋀ B) := subformulas A ∪ subformulas B ∪ {A ⋀ B}
| (A ⋁ B) := subformulas A ∪ subformulas B ∪ {A ⋁ B}
| (A ⟹ B) := subformulas A ∪ subformulas B ∪ {A ⟹ B}

def subformula (A : Form) := {B : Form // B ∈ subformulas A}

section
open deduction

/--The formulas which *appear* in a written out proof d : X ≻ A
Recursively define as the formulas above the last rule with the conclusion
inserted-/
def deduction.formulas : Π {X A}, X ≻ A → set Form
| X A (assumption mA) := {A}
| X _ (@and_intro _ A B XdA XdB) := deduction.formulas XdA ∪ deduction.formulas XdB ∪ {A ⋀ B}
| X _ (@and_left _ A B XdAB) := deduction.formulas XdAB ∪ {A}
| X _ (@and_right _ A B XdAB) := deduction.formulas XdAB ∪ {B}
| X _ (@imp_intro _ A B XAdB) := deduction.formulas XAdB ∪ {A ⟹ B}
| X B (@imp_elim _ A _ XdAB XdA) := deduction.formulas XdAB ∪ deduction.formulas XdA ∪ {B}
| X _ (@or_left _ A B XdA) := deduction.formulas XdA ∪ {A ⋁ B}
| X _ (@or_right _ A B XdB) := deduction.formulas XdB ∪ {A ⋁ B}
| X C (@or_elim _ A B _ XdAB XAdC XBdC) := deduction.formulas XdAB ∪ deduction.formulas XAdC ∪ deduction.formulas XBdC ∪ {C}
| X A (@falsum _ _ XdF) := deduction.formulas XdF ∪ {A}

end

/--Definition 20-/
def subformula_property {X A} : X ≻ A → Prop := λ XdA, XdA.formulas ⊆ X ∪ {A}

/-- Lemma used in preorder proof-/
lemma provable.premise_contraction {X A B} : X ∪ (X ∪ {A}) ⊢I B → X ∪ {A} ⊢I B := by obviously

/--Any set of formulas induces a preorder on Formulas,-/
instance provable.preorder (X : set Form): preorder Form :=
{ le := λ A B, X ∪ {A} ⊢I B,
  lt := λ A B, X ∪ {A} ⊢I B ∧ ¬ (X ∪ {B} ⊢I A),
  le_refl := λ A, ⟨by assump⟩,
  le_trans := λ A B C ApB BpC, provable.premise_contraction $ provable.cut B BpC ApB,
  lt_iff_le_not_le := λ A B, by refl }

/- Chapter 6 Exercises -/
section exercises

variables {p q r : ℕ}

/-Question 1-/

example : inconsistent {p,q,¬(p ⋀ q)} :=
  ⟨¬E (p ⋀ q) (by assump) (by apply ⋀I; assump)⟩

-- TODO: finish chapter 4 exercises

end exercises

end nat_deduction


lemma succ_le_succ (a b : mynat) (h : a ≤ b) : succ a ≤ succ b :=
begin
cases h with d hd,
use d,
rw hd,
rwa succ_add,
end


variables {α : Type _} {β : Type _} {γ : Type _}

def fun.im (f : α → β) (A : set α) := { b : β | ∃ a, a ∈ A ∧ b = f a }
def fun.pre_im (f : α → β) (B : set β) := { a : α | f a ∈ B }

def fun.pre_im_of_inv_eq_im (f : α → β) (g : β → α) (B : set β)
  (hfg : ∀ b, f (g b) = b) (hgf : ∀ a, g (f a) = a)
  : fun.pre_im f B = fun.im g B :=
begin
  dsimp [fun.pre_im, fun.im], funext, apply propext,
  suffices : B (f a) ↔ ∃ b : β, b ∈ B ∧ a = g b, exact this,
  constructor; intro h,
  { existsi f a, constructor, assumption, symmetry, apply hgf },
  { cases h with b h, cases h with hB h, rw h, rw hfg, assumption }
end

def im_of_comp : ∀ (f : α → β) (g : β → γ) (A : set α),
  fun.im (g ∘ f) A = fun.im g (fun.im f A) :=
begin
  intros, funext, apply propext, constructor; intro h,
  { cases h with a h, existsi f a, constructor,
    existsi a, constructor, exact h.left, refl, exact h.right },
  { cases h with fa h, cases h with hfa hb,
    cases hfa with a ha, cases ha with ha hfa,
    existsi a, constructor, assumption,
    dsimp [(∘)], rw ← hfa, assumption }
end

def eq_symm_iff (a b : α) : a = b ↔ b = a :=
⟨eq.symm, eq.symm⟩

lemma classical.dne : ∀ P, ¬ ¬ P ↔ P :=
begin
  intro P, constructor; intro h,
  { cases (classical.em P), assumption, trivial },
  exact (λ nh, absurd h nh),
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Johan Commelin
-/
import Mathlib.Tactic.WLOG
import Mathlib.Data.Nat.Basic

example {x y : ℕ} : True := by
  wlog h : x ≤ y
  { guard_hyp h : ¬x ≤ y
    guard_hyp «this» : ∀ {x y : ℕ}, x ≤ y → True -- `wlog` generalizes by default
    guard_target =ₛ True
    trivial }
  { guard_hyp h : x ≤ y
    guard_target =ₛ True
    trivial }

example {x y : ℕ} : True := by
  wlog h : x ≤ y generalizing x with H
  { guard_hyp h : ¬x ≤ y
    guard_hyp H : ∀ {x : ℕ}, x ≤ y → True -- only `x` was generalized
    guard_target =ₛ True
    trivial }
  { guard_hyp h : x ≤ y
    guard_target =ₛ True
    trivial }

example {x y z : ℕ} : True := by
  wlog h : x ≤ y + z with H
  { guard_hyp h : ¬ x ≤ y + z
    guard_hyp H : ∀ {x y z : ℕ}, x ≤ y + z → True -- wlog-claim is named `H` instead of `this`
    guard_target =ₛ True
    trivial }
  { guard_hyp h : x ≤ y + z
    guard_target =ₛ True
    trivial }

example : ∀ _ _ : ℕ, True := by
  intro x y
  wlog h : x ≤ y -- `wlog` finds new variables
  { trivial }
  { trivial }

example {x y : ℕ} : True := by
  wlog h : x ≤ y generalizing y x with H
  { guard_hyp h : ¬ x ≤ y
    guard_hyp H : ∀ {x y : ℕ}, x ≤ y → True -- order of ids in `generalizing` is ignored
    trivial }
  { trivial }

-- metadata doesn't cause a problem
example (α : Type := ℕ) (x : Option α := none) (y : Option α := by exact 0) : True := by
  wlog h : x = y with H
  { guard_hyp h : ¬ x = y
    guard_hyp H : ∀ α, ∀ {x y : Option α}, x = y → True
    trivial }
  { guard_hyp h : x = y
    guard_target =ₛ True
    trivial }

-- inaccessible names work
example {x y : ℕ} : True := by
  wlog _ : x ≤ y
  case _ h => -- if these hypotheses weren't inaccessible, they wouldn't be renamed by `case`
  { guard_hyp h : ¬x ≤ y
    guard_hyp «this» : ∀ {x y : ℕ}, x ≤ y → True
    guard_target =ₛ True
    trivial }
  case _ h =>
  { guard_hyp h : x ≤ y
    guard_target =ₛ True
    trivial }


import tactic.find tactic.tidy data.set.basic
universes u v

namespace metalogic

open tactic set

inductive HProp : Type
| intro (p : Prop) : HProp

def is_true : HProp → Prop
| (HProp.intro p) := p

-- inductive andH : HProp → HProp
-- | intro (p : HProp) : andH p

inductive provable.prop.classical : set (Sort u) → (Sort u) → (Sort (max (u+1) v))
| reflexive {Γ : set (Sort u)} {φ : (Sort u)} (h : φ ∈ Γ) : provable.prop.classical Γ φ
| transitivity {Γ Δ : set (Sort u)} {φ : (Sort u)}
               (h₁ : ∀ ψ ∈ Δ, provable.prop.classical Γ ψ)
               (h₂ : provable.prop.classical Δ φ)
               : provable.prop.classical Γ φ
| modus_ponens
            (φ ψ : (Sort u)) (Γ : set (Sort u))
            (h₁ : provable.prop.classical Γ (φ → ψ))
            (h₂ : provable.prop.classical Γ φ)
            : provable.prop.classical Γ ψ
| intro
            {φ ψ : (Sort u)} {Γ : set (Sort u)}
            (h : provable.prop.classical (Γ ∪ {φ}) ψ)
            : provable.prop.classical Γ (φ → ψ)
-- | exfalso
--           (φ : (Sort u)) (Γ : set (Sort u))
--           (h : provable.prop.classical Γ )
--           : provable.prop.classical Γ φ
-- | by_contradiction (φ : (Sort u)) (Γ : set (Sort u))
--                    (h : provable.prop.classical Γ ¬¬φ)
--                    : provable.prop.classical Γ φ

variables {Γ : set Prop} {φ : Prop}
#check provable.prop.classical.{0}

example : φ → provable.prop.classical.{0} Γ φ :=
begin
    intro h,
    have c₁ : φ = true, simp [h],
    have c₂ : (φ → φ) = true, simp,
    rw [c₁,←c₂],
    apply provable.prop.classical.intro,
    apply provable.prop.classical.reflexive,
    simp,
end

-- example : φ → provable.prop.classical.{1} ∅ (provable.prop.classical.{0} Γ φ) :=
-- begin

-- end

-- We wanted to define what a tautology is in order
-- to define a necessitation rule for normal modal logics
-- in terms of this notion of tautology.
-- However our approach did not work.
-- For this approach to work the defined proof system
-- would have to be incomplete relative to provability
-- or "truth" in LEAN. However we were able to prove
-- that given a proof of proposition φ we can build
-- a proof of proposition provable.minimal Γ φ
-- for any set Γ of propositions.

inductive provable.minimal : set Prop → Prop → Prop
| reflexive (Γ : set Prop) (φ : Prop) (h : set.mem φ Γ) : provable.minimal Γ φ
| transitivity (Γ Δ : set Prop) (φ : Prop)
               (h₁ : ∀ ψ ∈ Δ, provable.minimal Γ ψ)
               (h₂ : provable.minimal Δ φ)
                : provable.minimal Γ φ
| and_intro (φ ψ : Prop) (Γ : set Prop)
            (h₁ : provable.minimal Γ φ)
            (h₂ : provable.minimal Γ ψ)
             : provable.minimal Γ (φ ∧ ψ)
| and_elim_left (φ ψ : Prop) (Γ : set Prop)
            (h : provable.minimal Γ (φ ∧ ψ))
             : provable.minimal Γ φ
| and_elim_right (φ ψ : Prop) (Γ : set Prop)
            (h : provable.minimal Γ (φ ∧ ψ))
             : provable.minimal Γ ψ
| or_intro_left
            (φ ψ : Prop) (Γ : set Prop)
            (h : provable.minimal Γ φ)
             : provable.minimal Γ (φ ∨ ψ)
| or_intro_right
            (φ ψ : Prop) (Γ : set Prop)
            (h : provable.minimal Γ ψ)
             : provable.minimal Γ (φ ∨ ψ)
| or_elim
            (φ ψ δ : Prop) (Γ : set Prop)
            (h₁ : provable.minimal Γ (φ ∨ ψ))
            (h₂ : provable.minimal Γ (φ → δ))
            (h₃ : provable.minimal Γ (ψ → δ))
             : provable.minimal Γ δ
| modus_ponens
            (φ ψ : Prop) (Γ : set Prop)
            (h₁ : provable.minimal Γ (φ → ψ))
            (h₂ : provable.minimal Γ φ)
             : provable.minimal Γ ψ
| intro
            (φ ψ : Prop) (Γ : set Prop)
            (h : provable.minimal (Γ ∪ {φ}) ψ)
             : provable.minimal Γ (φ → ψ)
| true_intro
            (Γ : set Prop)
             : provable.minimal Γ true
| for_all_intro
            {α : Type u}
            (Γ : set Prop) (p : α → Prop)
            (h : ∀ x : α, provable.minimal Γ (p x))
             : provable.minimal Γ (∀ x:α, p x)
| for_all_elim
            {α : Type u}
            (Γ : set Prop) (p : α → Prop)
            (c : α)
            (h : provable.minimal Γ (∀ x : α, p x))
             : provable.minimal Γ (p c)
| exists_intro
            {α : Type u}
            (Γ : set Prop) (p : α → Prop)
            (c : α)
            (h : provable.minimal Γ (p c))
             : provable.minimal Γ (∃x:α, p x)
| exists_elim
            {α : Type u}
            (Γ : set Prop) (p : α → Prop)
            (ψ : Prop)
            (h₁ : provable.minimal Γ (∃x:α, p x))
            (h₂ : ∀ x:α, provable.minimal Γ (p x → ψ))
             : provable.minimal Γ ψ
| identity_intro
            {α : Type u}
            (Γ : set Prop) (c : α)
             : provable.minimal Γ (c = c)
| identity_elim
            {α : Type u}
            (Γ : set Prop) (p : α → Prop)
            (c₁ c₂: α)
            (h : provable.minimal Γ (p c₁))
            (eq : provable.minimal Γ (c₁ = c₂))
             : provable.minimal Γ (p c₂)

-- variables {Γ : set Prop} {φ : Prop}

example : provable.minimal.{u} Γ (φ → φ) :=
begin
    apply provable.minimal.intro,
    apply provable.minimal.reflexive (Γ∪{φ} : set Prop) φ,
    right,
    -- this would be needed if we forgot the .{u}
    -- apply singleton_subset_iff.mp,
    simp,
end

-- here is the proof why this approach doesn't quite work:
theorem completeness.minimal : φ → minimal Γ φ :=
begin
    intro h₁,
    have c₁ := classical.eq_true_or_eq_false φ,
    cases c₁,
        rw c₁,
        apply provable.minimal.true_intro Γ,
    simp at c₁,
    contradiction,
end

-- it doesn't help to remove the true_intro rule
-- because it can be proven using the same logic:
-- (1) prove that Γ proves false → false,
-- (2) simplify false → false to true,
-- (3) conclude that Γ proves true

-- and it gets worse than that:

def complete.minimal (Γ : set Prop) := ∀ φ : Prop, provable.minimal.{u} Γ φ ∨ provable.minimal.{u} Γ (¬φ)

theorem universal_decidibility.minimal : complete.minimal Γ :=
begin
    intro φ,
    classical,
    by_cases φ,
        left,
        apply completeness.minimal,
        assumption,
    right,
    apply completeness.minimal,
    assumption,
end

-- It might have worked out if we refrained
-- from using classical logic, but there isn't a
-- clear requirement that we refrain from it.
-- Even if we do another user of this module might use it,
-- and he might prove the same result we did above.
-- There is no way to keep tabs on where classical
-- reasoning is being used.

-- It would be more useful if whenever we used
-- classical logic, we had to add a tag
-- to the theorem or definition name, like "meta"
-- or "noncomputable" are already in use.

-- Which is pretty sad because I made all these nice
-- other proofs:

theorem provable.minimal.monotonicity : ∀ (Δ ⊆ Γ) (ψ : Prop), provable.minimal.{u} Δ ψ → provable.minimal.{u} Γ ψ :=
begin
    intros Δ H ψ h,
    -- induction on the possible ways in which
    -- Δ could prove ψ
    induction h,
    -- case it was proven by reflection
        apply provable.minimal.reflexive Γ h_φ,
        exact H h_h,
    -- case it was proven by transitivity
        apply provable.minimal.transitivity Γ h_Δ h_φ,
        intros ψ₂ elem,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by and_intro
        apply provable.minimal.and_intro,-- h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by and_elim_left
        apply provable.minimal.and_elim_left h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by and_elim_right
        apply provable.minimal.and_elim_right h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by or_intro_left
        apply provable.minimal.or_intro_left h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by or_intro_right
        apply provable.minimal.or_intro_right h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by or_elim
        apply provable.minimal.or_elim,-- h_φ h_ψ h_δ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by modus ponens
        apply provable.minimal.modus_ponens h_φ h_ψ Γ,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by intro
        have c : provable.minimal h_Γ (h_φ → h_ψ),
            apply provable.minimal.intro h_φ h_ψ h_Γ,
            assumption,
        apply provable.minimal.transitivity Γ h_Γ (h_φ → h_ψ),
            intros ψ₂ elem,
            have c₂ := H elem,
            exact provable.minimal.reflexive Γ ψ₂ c₂,
        assumption,
    -- case it was proven by true_intro
        exact provable.minimal.true_intro Γ,
    -- case it was proven by for_all_intro
        apply provable.minimal.for_all_intro,
        intro x,
        have c := h_ih x,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by for_all_elim
        apply provable.minimal.for_all_elim,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by exists_intro
        apply provable.minimal.exists_intro,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by exists_elim
        have c : minimal h_Γ h_ψ,
            apply provable.minimal.exists_elim h_Γ h_p h_ψ,
            repeat {assumption <|> apply_assumption},
        apply provable.minimal.exists_elim Γ h_p h_ψ,
        repeat {assumption <|> apply_assumption},
        intro x,
        repeat {assumption <|> apply_assumption},
    -- case it was proven by identity_intro
        apply provable.minimal.identity_intro,
    -- case it was proven by identity_elim
        apply provable.minimal.identity_elim,
        repeat {assumption <|> apply_assumption},
end

-- prove that minimal logic is sound relative to LEAN
-- semantics.
theorem provable.minimal.sound : provable.minimal Γ φ →
                                (∀ ψ ∈ Γ, ψ) →
                                 φ :=
begin
    intros h₀ h₁,
    induction h₀,
    -- case it was proven by reflection
    apply_assumption, assumption,
    -- case it was proven by transitivity
        apply h₀_ih_h₂,
        intros ψ elem,
        have c := h₀_ih_h₁ ψ elem,
        exact c h₁,
    -- case it was proven by and_intro
        constructor;
        apply_assumption; assumption,
    -- case it was proven by and_elim_left
        exact (h₀_ih h₁).1,
    -- case it was proven by and_elim_right
        exact (h₀_ih h₁).2,
    -- case it was proven by or_intro_left
        left,
        apply_assumption, assumption,
    -- case it was proven by or_intro_right
        right,
        apply_assumption, assumption,
    -- case it was proven by or_elim
        cases h₀_ih_h₁ h₁ with h,
            exact h₀_ih_h₂ h₁ h,
        exact h₀_ih_h₃ h₁ h,
    -- case it was proven by modus ponens
        apply h₀_ih_h₁ h₁,
        apply_assumption, assumption,
    -- case it was proven by intro
        have c : (∀ (ψ : Prop), ψ ∈ h₀_Γ ∪ {h₀_φ} → ψ),
            intros ψ elem,
            cases elem,
                exact h₀_h₁ ψ elem,
            simp at elem,
            exact elem.2 a,
        apply_assumption, assumption,
    -- case it was proven by true_intro
        exact true.intro,
    -- case it was proven by for_all_intro
        have c := h₀_ih x,
        apply_assumption, assumption,
    -- case it was proven by for_all_elim
        exact h₀_ih h₁ h₀_c,
    -- case it was proven by exists_intro
        existsi h₀_c,
        apply_assumption, assumption,
    -- case it was proven by exists_elim
        obtain ⟨x, p⟩ := h₀_ih_h₁ h₁,
        have c := h₀_ih_h₂ x,
        exact c h₁ p,
    -- case it was proven by identity_intro
        refl,
    -- case it was proven by identity_elim
        have c := h₀_ih_h h₁,
        rwa h₀_ih_eq h₁ at c,
end

lemma provable.minimal.cond : provable.minimal.{u} Γ φ → ∀ ψ : Prop, provable.minimal.{u} Γ (ψ → φ) :=
begin
    intros h ψ,
    apply provable.minimal.intro,
    apply provable.minimal.monotonicity Γ,
        simp,
    assumption,
end

def tautology.minimal (φ : Prop) : Prop := provable.minimal ∅ φ

def consistent.minimal (Γ : set Prop) := ¬ ∀ φ : Prop, provable.minimal.{u} Γ φ

inductive provable.constructive : set Prop → Prop → Prop
| minimal (Γ : set Prop) (φ : Prop)
          (h : provable.minimal Γ φ)
           : provable.constructive Γ φ
| quodlibet (Γ : set Prop) (φ : Prop)
           : provable.constructive Γ (false → φ)

theorem provable.constructive.sound : provable.constructive Γ φ →
                                (∀ ψ ∈ Γ, ψ) →
                                 φ :=
begin
    intros h₀ h₁,
    induction h₀,
        exact provable.minimal.sound h₀_h h₁,
    contradiction,
end

-- lemma provable.constructive.cond : provable.constructive.{u} Γ φ → ∀ ψ : Prop, provable.constructive.{u} Γ (ψ → φ) :=
-- begin
--     intros h ψ,
--     cases h,
-- end

-- lemma provable.constructive.intro : ∀ φ ψ : Prop,
--                                 (provable.constructive.{u} (Γ ∪ {φ}) ψ)
--                                 → provable.constructive.{u} Γ (φ → ψ) :=
-- begin
--     intros φ ψ h,
--     rcases h with h₁| h₂,
--         apply provable.constructive.minimal,
--         apply provable.minimal.intro,
--         have c : ((Γ ∪ {φ}) : set Prop) = λ (a : Prop), a ∈ Γ ∨ a ∈ ({φ}:set Prop),
--             trivial,
--         rwa c,
--     simp,

-- end

def tautology.constructive (φ : Prop) : Prop := provable.constructive ∅ φ

inductive provable.classical : set Prop → Prop → Prop
| constructive (Γ : set Prop) (φ : Prop)
               (h : provable.constructive Γ φ)
                : provable.classical Γ φ
| by_contradiction (Γ : set Prop) (φ : Prop)
                    (h : provable.classical Γ (¬φ → false))
                    : provable.classical Γ φ

theorem provable.classical.sound : provable.classical Γ φ →
                                (∀ ψ ∈ Γ, ψ) →
                                 φ :=
begin
    intros h₀ h₁,
    induction h₀,
        exact provable.constructive.sound h₀_h h₁,
    have c := h₀_ih h₁,
    classical,
    by_contradiction h,
    exact c h,
end

def tautology.classical (φ : Prop) : Prop := provable.classical ∅ φ

-- lemma provable.classical.intro : ∀ φ ψ : Prop,
--                                 (provable.classical (Γ ∪ {φ}) ψ)
--                                 → provable.classical Γ (φ → ψ)
-- :=
-- begin
--     intros φ ψ h,
--     cases h,
--         apply provable.classical.constructive,
--     -- apply provable.constructive.minimal,
-- end

-- example : tautology.classical (φ ∨ ¬ φ) :=
-- begin
--     unfold tautology.classical,
--     apply provable.classical.by_contradiction ∅ (φ ∨ ¬ φ),
--     apply provable.classical.constructive ∅ (¬(φ ∨ ¬φ) → false),
--     apply provable.constructive.minimal ∅ (¬(φ ∨ ¬φ) → false),
--     apply provable.minimal.intro (¬(φ ∨ ¬φ)) false ∅, simp,
--     have c₀ : minimal ∅ (φ → φ ∨ ¬φ),
--         -- apply provable.classical.constructive ∅ (φ → φ ∨ ¬φ),
--         -- apply provable.constructive.minimal ∅ (φ → φ ∨ ¬φ),
--         apply provable.minimal.intro φ (φ ∨ ¬φ) ∅,
--         simp,
--         apply provable.minimal.or_intro_left φ (¬φ) {φ},
--         apply provable.minimal.reflexive {φ} φ,
--         -- again, what the hell???
--         apply singleton_subset_iff.mp,
--         simp,
--     have c₁ : minimal

-- end

end metalogic


import phase1.A_map

/-!
# Equivalence of codes

Several codes will be identified to make one TTT object. A TTT object has extensions for all type
indices (except possibly `⊥`), so our equivalence classes must too.

One way to do this is to make an equivalence class out of a code and its image under each A-map.
Thus we want to partition the big tree given by `A_map_rel` into trees of height `1` that each
contains all descendents of its root (this is a slight lie for empty codes as the one equivalence
class they form won't be a tree but rather a complete graph).

This is where code parity kicks in. We recursively pick out the small trees by noticing that codes
whose preimages under A-maps are all in a small tree already (in particular, those that have no
preimage under an A-map) must be the root of their own small tree, and that codes that are a
image of some root of a small tree must belong to that same tree. This motivates the following
definitions:
* A code is even if all its preimages under A-maps are odd.
* A code is odd if one of its preimages under A-maps are even.

If we replace "even" and "odd" by "winning" and "losing", we precisely get the rules for determining
whether a game position is winning or losing.

Note that for nonempty codes there is at most one preimage under A-maps.

## Main declarations

* `con_nf.is_even`, `con_nf.is_odd`: Code parity.
* `con_nf.code.equiv`: Equivalence of codes.
-/

open set with_bot

universe u

namespace con_nf
variables [params.{u}] [position_data.{}] {α : Λ} {β : Iio_index α} {γ : Iio α}
  [core_tangle_cumul α] [almost_tangle_cumul α] [positioned_tangle_cumul α]

open Iio_index

namespace code
variables {c d : code α}

/-! ### Parity of a code -/

/-- Parity of codes. We define them mutually inductively (`even_odd ff` is evenness, `even_odd tt`
is oddity). If we consider codes as states of a game and `A_map_rel` as the "leads to"
relation, then even codes are precisely losing codes and odd codes are precisely winning codes.
Parity of a nonempty code corresponds to the parity of its number of iterated preimages under
A-maps. The only even empty code is `⊥` one, all others are odd. -/
@[mk_iff] inductive even_odd : bool → code α → Prop
| intro_even : ∀ c, (∀ d, d ↝ c → even_odd tt d) → even_odd ff c
| intro_odd : ∀ c d, d ↝ c → even_odd ff d → even_odd tt c

/-- A code is even iff it only leads to odd codes. -/
def is_even : code α → Prop := even_odd false

/-- A code is odd iff it leads to some even code. -/
def is_odd : code α → Prop := even_odd true

lemma is_even_iff : c.is_even ↔ ∀ d, d ↝ c → d.is_odd := (even_odd_iff _ _).trans $ by simp [is_odd]
lemma is_odd_iff : c.is_odd ↔ ∃ d, d ↝ c ∧ d.is_even := (even_odd_iff _ _).trans $ by simp [is_even]

lemma is_even_of_forall_not (h : ∀ d, ¬ d ↝ c) : is_even c := is_even_iff.2 $ λ d hd, (h _ hd).elim

@[simp] lemma is_even_of_eq_bot (c : code α) (hc : c.1.1 = ⊥) : c.is_even :=
is_even_of_forall_not $ by { rintro d ⟨β, -⟩, exact coe_ne_bot hc }

@[simp] lemma is_even_bot (s : set atom) : is_even (mk ⊥ s : code α) := is_even_of_eq_bot _ rfl

lemma not_is_odd_bot (s : set atom) : ¬ is_odd (mk ⊥ s : code α) :=
begin
  simp_rw [is_odd_iff, A_map_rel_iff],
  rintro ⟨d, ⟨γ, hdγ, h⟩, hd⟩,
  exact bot_ne_mk_coe (congr_arg sigma.fst h),
end

@[simp] lemma is_empty.is_even_iff (hc : c.is_empty) : is_even c ↔ (c.1 : type_index) = ⊥ :=
begin
  refine ⟨λ h, _, is_even_of_eq_bot _⟩,
  obtain ⟨⟨_ | β, hβ⟩, s⟩ := c,
  { refl },
  cases not_is_odd_bot _ (is_even_iff.1 h ⟨⟨⊥, _⟩, ∅⟩ _),
  convert A_map_rel.intro ⟨β, coe_lt_coe.1 hβ⟩ _; simp,
  assumption,
end

@[simp] lemma is_empty.is_odd_iff (hc : c.is_empty) : is_odd c ↔ (c.1 : type_index) ≠ ⊥ :=
begin
  obtain ⟨⟨β, hβ⟩, s⟩ := c,
  refine ⟨_, λ h, is_odd_iff.2 ⟨mk ⊥ ∅, _, is_even_bot _⟩⟩,
  { rintro h (rfl : β = _),
    exact not_is_odd_bot _ h },
  { lift β to Λ using h,
    rw (show s = _, from hc.eq),
    exact (A_map_rel_iff _ _).2 ⟨⟨β, coe_lt_coe.1 hβ⟩, bot_ne_mk_coe, by simpa using hc.eq⟩ }
end

@[simp] lemma is_even_empty_iff : is_even (mk β ∅) ↔ (β : type_index) = ⊥ :=
is_empty.is_even_iff rfl

@[simp] lemma is_odd_empty_iff : is_odd (mk β ∅) ↔ (β : type_index) ≠ ⊥ := is_empty.is_odd_iff rfl

private lemma not_is_odd_nonempty : ∀ c : nonempty_code α, ¬ c.1.is_odd ↔ c.1.is_even
| c := begin
  rw [is_odd_iff, is_even_iff],
  push_neg,
  apply forall_congr (λ d, _),
  apply imp_congr_right (λ h, _),
  rw [iff.comm, ←not_iff_not, not_not],
  obtain hd | hd := d.2.eq_empty_or_nonempty,
  { rw [is_empty.is_odd_iff hd, is_empty.is_even_iff hd, not_not] },
  { let : A_map_rel' ⟨d, hd⟩ c := A_map_rel_coe_coe.1 h,
    exact @not_is_odd_nonempty ⟨d, hd⟩ }
end
using_well_founded { dec_tac := `[assumption] }

@[simp] lemma not_is_odd : ¬ c.is_odd ↔ c.is_even :=
begin
  obtain hc | hc := c.2.eq_empty_or_nonempty,
  { rw [is_empty.is_odd_iff hc, is_empty.is_even_iff hc, not_not] },
  { exact not_is_odd_nonempty ⟨c, hc⟩ }
end

@[simp] lemma not_is_even : ¬ c.is_even ↔ c.is_odd := not_is_odd.symm.not_left

alias not_is_odd ↔ _ is_even.not_is_odd
alias not_is_even ↔ _ is_odd.not_is_even

lemma is_even_or_is_odd (c : code α) : c.is_even ∨ c.is_odd := by { rw ←not_is_even, exact em _ }

protected lemma _root_.con_nf.A_map_rel.is_odd (hc : c.is_even) (h : c ↝ d) : d.is_odd :=
is_odd_iff.2 ⟨_, h, hc⟩

protected lemma is_even.A_map_code (hc : c.is_even) (hcγ : c.1 ≠ γ) : (A_map_code γ c).is_odd :=
(A_map_rel.intro _ hcγ).is_odd hc

protected lemma is_odd.A_map_code (hc : c.is_odd) (hc' : c.2.nonempty) (hcγ : c.1 ≠ γ) :
  (A_map_code γ c).is_even :=
is_even_iff.2 $ λ d hd, by rwa (A_map_rel_A_map_code _ hc' hcγ).1 hd

protected lemma is_even.A_map_code_ne (hc : c.is_even) (hd : d.is_even) (hcγ : c.1 ≠ γ) :
  A_map_code γ c ≠ d :=
by { rintro rfl, exact hd.not_is_odd (hc.A_map_code hcγ) }

lemma A_map_code_ne_bot {s} : A_map_code γ c ≠ mk ⊥ s :=
ne_of_apply_ne (subtype.val ∘ sigma.fst) coe_ne_bot

lemma A_map_code_ne_singleton {t} (hcβ : c.1 ≠ β) : A_map_code γ c ≠ mk β {t} :=
begin
  simp only [A_map_code, ne.def, eq_self_iff_true, heq_iff_eq, true_and, sigma.ext_iff, fst_mk,
    snd_mk],
  rintro ⟨rfl, h⟩,
  refine (cardinal.one_lt_aleph_0.trans_le $ κ_regular.aleph_0_le.trans κ_le_μ).not_le _,
  rw [←cardinal.mk_singleton t, ←h.eq],
  refine μ_le_mk_A_map_code c hcβ (A_map_code_nonempty.1 _),
  exact γ,
  rw [A_map_code, eq_of_heq h],
  simp only [snd_mk, singleton_nonempty],
end

@[simp] lemma is_even_singleton (t) : (mk β {t}).is_even :=
begin
  refine is_even_of_forall_not (λ c hc, _),
  obtain ⟨γ, hc', h⟩ := (A_map_rel_iff _ _).1 hc,
  have := congr_arg sigma.fst h,
  cases this,
  exact A_map_code_ne_singleton hc' h.symm,
end

/-! ### Equivalence of codes -/

/-- Equivalence of codes. -/
@[mk_iff] inductive equiv : code α → code α → Prop
| refl (c) : equiv c c
| A_map_left (c : code α) (hc : c.is_even) (β : Iio α) (hcβ : c.1 ≠ β) :
  equiv (A_map_code β c) c
| A_map_right (c : code α) (hc : c.is_even) (β : Iio α) (hcβ : c.1 ≠ β) :
  equiv c (A_map_code β c)
| A_map_A_map (c : code α) (hc : c.is_even) (β : Iio α) (hcβ : c.1 ≠ β) (γ : Iio α)
  (hcγ : c.1 ≠ γ) :
    equiv (A_map_code β c) (A_map_code γ c)

/-! We declare new notation for code equivalence. -/
infix ` ≡ `:50 := equiv

namespace equiv

attribute [refl] refl

protected lemma rfl : c ≡ c := refl _

lemma of_eq : c = d → c ≡ d := by { rintro rfl, refl }

lemma symm : symmetric ((≡) : code α → code α → Prop)
| _ _ (refl _) := refl _
| _ _ (A_map_left c β hc hcβ) := A_map_right c β hc hcβ
| _ _ (A_map_right c β hc hcβ) := A_map_left c β hc hcβ
| _ _ (A_map_A_map c hc β hcβ γ hcγ) := A_map_A_map c hc γ hcγ β hcβ

lemma comm : c ≡ d ↔ d ≡ c := symm.iff _ _

lemma empty_empty : ∀ (β γ), (⟨β, ∅⟩ : code α) ≡ ⟨γ, ∅⟩
| ⟨⊥, _⟩ ⟨⊥, _⟩ := equiv.rfl
| ⟨⊥, _⟩ ⟨(γ : Λ), hγ⟩ := by { convert A_map_right _ (is_even_bot _) ⟨_, coe_lt_coe.1 hγ⟩
      bot_ne_mk_coe,
    rw [extension_ne _ _ bot_ne_coe, snd_mk, A_map_empty], }
| ⟨(β : Λ), hβ⟩  ⟨⊥, _⟩ := by { convert A_map_left _ (is_even_bot _) ⟨_, coe_lt_coe.1 hβ⟩
      bot_ne_mk_coe,
    rw [extension_ne _ _ bot_ne_coe, snd_mk, A_map_empty], }
| ⟨(β : Λ), hβ⟩ ⟨(γ : Λ), hγ⟩ := by
  { convert A_map_A_map _ (is_even_bot ∅) ⟨_, coe_lt_coe.1 hβ⟩ bot_ne_mk_coe ⟨_, coe_lt_coe.1 hγ⟩
      bot_ne_mk_coe;
    rw [extension_ne _ _ bot_ne_coe, snd_mk, A_map_empty], }

protected lemma _root_.con_nf.code.is_empty.equiv (hc : c.is_empty) (hd : d.is_empty) : c ≡ d :=
by { cases c, cases d, change c_snd = ∅ at hc, change d_snd = ∅ at hd, subst hc, subst hd,
  exact equiv.empty_empty _ _ }

lemma trans {c d e : code α} : c ≡ d → d ≡ e → c ≡ e :=
begin
  rw [equiv_iff, equiv_iff],
  rintro (rfl | ⟨hc, β, hcβ, rfl⟩ | ⟨hc, β, hcβ, rfl⟩ | ⟨d, hd, γ, hdγ, ε, hdε, rfl, rfl⟩),
  { exact (equiv_iff _ _).2 },
  { rintro (rfl | ⟨hc', γ, hcγ, rfl⟩ | ⟨-, γ, hcγ, rfl⟩ | ⟨_, hc', γ, hcγ, ε, hcε, rfl, rfl⟩),
    { exact A_map_left _ hc β hcβ },
    { cases (hc'.A_map_code hcγ).not_is_even hc },
    { exact A_map_A_map _ hc _ hcβ _ hcγ },
    { cases (hc'.A_map_code hcγ).not_is_even hc } },
  { rintro (rfl | ⟨hc', γ, hcγ, hce⟩ | ⟨hc', γ, hcγ, rfl⟩ |
      ⟨e, he, γ, hcγ, ε, heε, hce, rfl⟩),
    { exact A_map_right _ hc β hcβ },
    { obtain h | h := c.2.eq_empty_or_nonempty,
      { refine is_empty.equiv h _,
        rwa [←A_map_code_is_empty, ←hce, A_map_code_is_empty, code.is_empty] },
      { exact of_eq (eq_of_A_map_code h hcβ hcγ hce) } },
    { cases (hc.A_map_code hcβ).not_is_even hc' },
    { obtain h | h := c.2.eq_empty_or_nonempty,
      { refine is_empty.equiv h _,
        rwa [A_map_code_is_empty, ←A_map_code_is_empty, ←hce, A_map_code_is_empty, code.is_empty] },
      { rw eq_of_A_map_code h hcβ hcγ hce,
        exact A_map_right _ he _ heε } } },
  { rintro (rfl | ⟨he, γ, heγ, hde⟩ | ⟨hd', γ, -, rfl⟩ | ⟨e, he, ι, heι, κ, heκ, hde, rfl⟩),
    { exact A_map_A_map _ hd _ hdγ _ hdε },
    { obtain h | h := e.2.eq_empty_or_nonempty,
      { refine is_empty.equiv _ h,
        rwa [A_map_code_is_empty, ←A_map_code_is_empty, hde, A_map_code_is_empty, code.is_empty] },
      { rw eq_of_A_map_code h heγ hdε hde.symm,
        exact A_map_left _ hd _ hdγ } },
    { cases (hd.A_map_code hdε).not_is_even hd' },
    { obtain h | h := d.2.eq_empty_or_nonempty,
      { refine (is_empty.A_map_code h).equiv _,
        rwa [A_map_code_is_empty, ←A_map_code_is_empty, ←hde, A_map_code_is_empty, code.is_empty] },
      { have := eq_of_A_map_code h hdε heι hde,
        subst this,
        exact A_map_A_map _ hd _ hdγ _ heκ } } }
end

lemma equiv_equivalence : equivalence ((≡) : code α → code α → Prop) :=
⟨refl, symm, λ _ _ _, trans⟩

lemma nonempty_iff : ∀ {c d : code α}, c ≡ d → (c.2.nonempty ↔ d.2.nonempty)
| _ _ (refl _) := iff.rfl
| _ _ (A_map_left c hc β h) := A_map_code_nonempty
| _ _ (A_map_right c hc β h) := A_map_code_nonempty.symm
| _ _ (A_map_A_map c hc β hcβ γ hcγ) := A_map_code_nonempty.trans A_map_code_nonempty.symm

lemma ext : ∀ {c d : code α}, c ≡ d → c.1 = d.1 → c = d
| _ _ (refl _) _ := rfl
| _ _ (A_map_left c hc β h) H := (h H.symm).elim
| _ _ (A_map_right c hc β h) H := (h H).elim
| _ _ (A_map_A_map c hc β hcβ γ hcγ) H :=
  by { simp only [fst_A_map_code, Iio.coe_inj] at H, subst H }

@[simp] lemma bot_left_iff {s} : mk ⊥ s ≡ c ↔ mk ⊥ s = c ∨
  ∃ β : Iio α, c = mk β (A_map Iio_index.bot_ne_coe s) :=
by simp [equiv_iff, A_map_code_ne_bot.symm, eq_comm]

@[simp] lemma bot_right_iff {s} : c ≡ mk ⊥ s ↔ c = mk ⊥ s ∨
  ∃ β : Iio α, c = mk β (A_map Iio_index.bot_ne_coe s) :=
by simp [equiv_iff, A_map_code_ne_bot.symm, eq_comm]

@[simp] lemma bot_bot_iff {s t} : (mk ⊥ s : code α) ≡ mk ⊥ t ↔ s = t :=
by simp [equiv_iff, A_map_code_ne_bot.symm, eq_comm, sigma.ext_iff]

lemma singleton (hβγ : β ≠ γ) (g : tangle β) :
  mk β {g} ≡ mk γ (typed_near_litter '' local_cardinal (f_map (coe_ne hβγ) g)) :=
begin
  convert equiv.A_map_right (mk β {g}) (is_even_singleton _) _ hβγ,
  rw [extension, dif_neg],
  simp only [snd_mk, A_map_singleton],
end

lemma singleton_iff {g} :
  c ≡ mk β {g} ↔ c = mk β {g} ∨ ∃ γ : Iio α, (c.1 : type_index) = some γ ∧ β ≠ γ ∧
    c = A_map_code γ (mk β {g}) :=
begin
  classical,
  refine ⟨λ h, _, _⟩,
  { rw equiv_iff at h,
    simp only [mem_Iio, is_even_singleton, fst_mk, ne.def, set_coe.exists,
      Iio.coe_mk, true_and] at h,
    obtain rfl | ⟨γ, hβγ, hcβ, rfl⟩ |
      ⟨hc, γ, hγ, γne, h⟩ | ⟨d, hd, γ, hγ, γne, δ, hδ, δne, -, h⟩ := h,
    { exact or.inl rfl },
    { simp only [subtype.coe_mk, set_coe.exists, exists_and_distrib_left],
      exact or.inr ⟨_, rfl, hβγ, hcβ, rfl⟩ },
    { cases congr_arg sigma.fst h,
      cases A_map_code_ne_singleton γne h.symm },
    { cases congr_arg sigma.fst h,
      cases A_map_code_ne_singleton δne h.symm } },
  { rintro (rfl | ⟨γ, hc, hβγ, rfl⟩),
    { refl },
    { convert (singleton hβγ g).symm,
      simp only [snd_mk, A_map_code, extension_ne _ _ hβγ, A_map_singleton], } }
end

end equiv

lemma extension_eq_of_singleton_equiv_singleton {γ : Iio ↑α} {a b}
  (h : (⟨β, {a}⟩ : code α) ≡ ⟨γ, {b}⟩) : β = γ :=
begin
  obtain h | ⟨ε, hc, hβε, hA⟩ := equiv.singleton_iff.1 h,
  { exact (sigma.ext_iff.1 h).1 },
  { cases A_map_code_ne_singleton _ hA.symm,
    cases congr_arg sigma.fst hA,
    exact hβε }
end

lemma is_even.unique : ∀ {c d : code α}, c.is_even → d.is_even → c ≡ d → c = d
| c _ _ _ (equiv.refl _) := rfl
| c _ hc hd (equiv.A_map_left d _ β hdβ) := by cases (hd.A_map_code hdβ).not_is_even hc
| c _ hc hd (equiv.A_map_right d _ β hcβ) := by cases (hc.A_map_code hcβ).not_is_even hd
| c _ hc hd (equiv.A_map_A_map e he β hcβ γ _) := by cases (he.A_map_code hcβ).not_is_even hc

lemma exists_even_equiv : ∀ c : code α, ∃ d ≡ c, d.is_even :=
begin
  rintro ⟨β, s⟩,
   obtain rfl | hs := s.eq_empty_or_nonempty,
  { exact ⟨_, equiv.empty_empty _ _, is_even_bot _⟩ },
  obtain heven | hodd := is_even_or_is_odd ⟨β, s⟩,
  { exact ⟨_, equiv.rfl, heven⟩ },
  simp_rw [is_odd_iff, A_map_rel_iff] at hodd,
  obtain ⟨d, ⟨γ, hdγ, hc⟩, hd⟩ := id hodd,
  exact ⟨d, (equiv.A_map_right _ hd _ hdγ).trans (equiv.of_eq hc.symm), hd⟩,
end

protected lemma is_even.exists_equiv_extension_eq (heven : c.is_even) : ∃ d ≡ c, d.1 = γ :=
begin
  by_cases c.1 = γ,
  { exact ⟨c, equiv.rfl, h⟩ },
  { exact ⟨A_map_code γ c, equiv.A_map_left _ heven _ h, rfl⟩ }
end

lemma exists_equiv_extension_eq : ∀ c : code α, ∃ d ≡ c, d.1 = γ :=
begin
  rintro ⟨β, s⟩,
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { exact ⟨_, equiv.empty_empty _ _, rfl⟩ },
  obtain heven | hodd := is_even_or_is_odd ⟨β, s⟩,
  { exact heven.exists_equiv_extension_eq },
  simp_rw [is_odd_iff, A_map_rel_iff] at hodd,
  obtain ⟨d, ⟨ε, hdε, hc⟩, hd⟩ := hodd,
  obtain ⟨e, he, heγ⟩ := hd.exists_equiv_extension_eq,
  exact ⟨e, he.trans $ (equiv.A_map_right _ hd _ hdε).trans $ equiv.of_eq hc.symm, heγ⟩,
end

lemma equiv.unique : ∀ {c d : code α}, c ≡ d → c.1 = d.1 → c = d
| c _ (equiv.refl _) _ := rfl
| c _ (equiv.A_map_left d _ β hdβ) h := by cases hdβ h.symm
| c _ (equiv.A_map_right d _ β hcβ) h := by cases hcβ h
| c _ (equiv.A_map_A_map e he β _ γ _) h := by { have : β = γ := Iio.coe_injective h, subst this }

lemma equiv_bot_subsingleton : ∀ d ≡ c, ∀ e ≡ c, d.1 = ⊥ → e.1 = ⊥ → d = e :=
λ d hdc e hec hd he, (hdc.trans hec.symm).unique (hd.trans he.symm)

end code
end con_nf


variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
  ∃ t, l₁ ++ t = l₂

infix ` <+: `:50 := is_prefix

theorem list.is_prefix_refl (l : list α) : l <+: l :=
  ⟨[], by simp⟩

attribute [simp] list.is_prefix_refl


/-
Copyright (c) 2015 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import data.list.big_operators

/-!
# Lists in product and sigma types

This file proves basic properties of `list.product` and `list.sigma`, which are list constructions
living in `prod` and `sigma` types respectively. Their definitions can be found in
[`data.list.defs`](./data/list/defs). Beware, this is not about `list.prod`, the multiplicative
product.
-/

variables {α β : Type*}

namespace list

/-! ### product -/

@[simp] lemma nil_product (l : list β) : product (@nil α) l = [] := rfl

@[simp] lemma product_cons (a : α) (l₁ : list α) (l₂ : list β)
        : product (a::l₁) l₂ = map (λ b, (a, b)) l₂ ++ product l₁ l₂ := rfl

@[simp] lemma product_nil : ∀ (l : list α), product l (@nil β) = []
| []     := rfl
| (a::l) := by rw [product_cons, product_nil]; refl

@[simp] lemma mem_product {l₁ : list α} {l₂ : list β} {a : α} {b : β} :
  (a, b) ∈ product l₁ l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ :=
by simp only [product, mem_bind, mem_map, prod.ext_iff, exists_prop,
  and.left_comm, exists_and_distrib_left, exists_eq_left, exists_eq_right]

lemma length_product (l₁ : list α) (l₂ : list β) :
  length (product l₁ l₂) = length l₁ * length l₂ :=
by induction l₁ with x l₁ IH; [exact (zero_mul _).symm,
  simp only [length, product_cons, length_append, IH,
    right_distrib, one_mul, length_map, add_comm]]

/-! ### sigma -/

variable {σ : α → Type*}

@[simp] lemma nil_sigma (l : Π a, list (σ a)) : (@nil α).sigma l = [] := rfl

@[simp] lemma sigma_cons (a : α) (l₁ : list α) (l₂ : Π a, list (σ a))
        : (a::l₁).sigma l₂ = map (sigma.mk a) (l₂ a) ++ l₁.sigma l₂ := rfl

@[simp] lemma sigma_nil : ∀ (l : list α), l.sigma (λ a, @nil (σ a)) = []
| []     := rfl
| (a::l) := by rw [sigma_cons, sigma_nil]; refl

@[simp] lemma mem_sigma {l₁ : list α} {l₂ : Π a, list (σ a)} {a : α} {b : σ a} :
  sigma.mk a b ∈ l₁.sigma l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ a :=
by simp only [list.sigma, mem_bind, mem_map, exists_prop, exists_and_distrib_left,
  and.left_comm, exists_eq_left, heq_iff_eq, exists_eq_right]

lemma length_sigma (l₁ : list α) (l₂ : Π a, list (σ a)) :
  length (l₁.sigma l₂) = (l₁.map (λ a, length (l₂ a))).sum :=
by induction l₁ with x l₁ IH; [refl,
simp only [map, sigma_cons, length_append, length_map, IH, sum_cons]]

end list


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Chris Hughes, Mario Carneiro, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.prod
import Mathlib.algebra.ring.basic
import Mathlib.data.equiv.ring
import Mathlib.PostPort

universes u_1 u_3 u_5 u_2 u_4

namespace Mathlib

/-!
# Semiring, ring etc structures on `R × S`

In this file we define two-binop (`semiring`, `ring` etc) structures on `R × S`. We also prove
trivial `simp` lemmas, and define the following operations on `ring_hom`s:

* `fst R S : R × S →+* R`, `snd R S : R × S →+* R`: projections `prod.fst` and `prod.snd`
  as `ring_hom`s;
* `f.prod g : `R →+* S × T`: sends `x` to `(f x, g x)`;
* `f.prod_map g : `R × S → R' × S'`: `prod.map f g` as a `ring_hom`,
  sends `(x, y)` to `(f x, g y)`.
-/

namespace prod

/-- Product of two semirings is a semiring. -/
protected instance semiring {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : semiring (R × S) :=
  semiring.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry sorry monoid.mul sorry monoid.one sorry sorry
    sorry sorry sorry sorry

/-- Product of two commutative semirings is a commutative semiring. -/
protected instance comm_semiring {R : Type u_1} {S : Type u_3} [comm_semiring R] [comm_semiring S] : comm_semiring (R × S) :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry semiring.mul sorry semiring.one sorry sorry sorry
    sorry sorry sorry sorry

/-- Product of two rings is a ring. -/
protected instance ring {R : Type u_1} {S : Type u_3} [ring R] [ring S] : ring (R × S) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg add_comm_group.sub sorry sorry
    semiring.mul sorry semiring.one sorry sorry sorry sorry

/-- Product of two commutative rings is a commutative ring. -/
protected instance comm_ring {R : Type u_1} {S : Type u_3} [comm_ring R] [comm_ring S] : comm_ring (R × S) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry

end prod

namespace ring_hom

/-- Given semirings `R`, `S`, the natural projection homomorphism from `R × S` to `R`.-/
def fst (R : Type u_1) (S : Type u_3) [semiring R] [semiring S] : R × S →+* R :=
  mk prod.fst sorry sorry sorry sorry

/-- Given semirings `R`, `S`, the natural projection homomorphism from `R × S` to `S`.-/
def snd (R : Type u_1) (S : Type u_3) [semiring R] [semiring S] : R × S →+* S :=
  mk prod.snd sorry sorry sorry sorry

@[simp] theorem coe_fst {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ⇑(fst R S) = prod.fst :=
  rfl

@[simp] theorem coe_snd {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ⇑(snd R S) = prod.snd :=
  rfl

/-- Combine two ring homomorphisms `f : R →+* S`, `g : R →+* T` into `f.prod g : R →+* S × T`
given by `(f.prod g) x = (f x, g x)` -/
protected def prod {R : Type u_1} {S : Type u_3} {T : Type u_5} [semiring R] [semiring S] [semiring T] (f : R →+* S) (g : R →+* T) : R →+* S × T :=
  mk (fun (x : R) => (coe_fn f x, coe_fn g x)) sorry sorry sorry sorry

@[simp] theorem prod_apply {R : Type u_1} {S : Type u_3} {T : Type u_5} [semiring R] [semiring S] [semiring T] (f : R →+* S) (g : R →+* T) (x : R) : coe_fn (ring_hom.prod f g) x = (coe_fn f x, coe_fn g x) :=
  rfl

@[simp] theorem fst_comp_prod {R : Type u_1} {S : Type u_3} {T : Type u_5} [semiring R] [semiring S] [semiring T] (f : R →+* S) (g : R →+* T) : comp (fst S T) (ring_hom.prod f g) = f :=
  ext fun (x : R) => rfl

@[simp] theorem snd_comp_prod {R : Type u_1} {S : Type u_3} {T : Type u_5} [semiring R] [semiring S] [semiring T] (f : R →+* S) (g : R →+* T) : comp (snd S T) (ring_hom.prod f g) = g :=
  ext fun (x : R) => rfl

theorem prod_unique {R : Type u_1} {S : Type u_3} {T : Type u_5} [semiring R] [semiring S] [semiring T] (f : R →+* S × T) : ring_hom.prod (comp (fst S T) f) (comp (snd S T) f) = f := sorry

/-- `prod.map` as a `ring_hom`. -/
def prod_map {R : Type u_1} {R' : Type u_2} {S : Type u_3} {S' : Type u_4} [semiring R] [semiring S] [semiring R'] [semiring S'] (f : R →+* R') (g : S →+* S') : R × S →* R' × S' :=
  ↑(ring_hom.prod (comp f (fst R S)) (comp g (snd R S)))

theorem prod_map_def {R : Type u_1} {R' : Type u_2} {S : Type u_3} {S' : Type u_4} [semiring R] [semiring S] [semiring R'] [semiring S'] (f : R →+* R') (g : S →+* S') : prod_map f g = ↑(ring_hom.prod (comp f (fst R S)) (comp g (snd R S))) :=
  rfl

@[simp] theorem coe_prod_map {R : Type u_1} {R' : Type u_2} {S : Type u_3} {S' : Type u_4} [semiring R] [semiring S] [semiring R'] [semiring S'] (f : R →+* R') (g : S →+* S') : ⇑(prod_map f g) = prod.map ⇑f ⇑g :=
  rfl

theorem prod_comp_prod_map {R : Type u_1} {R' : Type u_2} {S : Type u_3} {S' : Type u_4} {T : Type u_5} [semiring R] [semiring S] [semiring R'] [semiring S'] [semiring T] (f : T →* R) (g : T →* S) (f' : R →* R') (g' : S →* S') : monoid_hom.comp (monoid_hom.prod_map f' g') (monoid_hom.prod f g) =
  monoid_hom.prod (monoid_hom.comp f' f) (monoid_hom.comp g' g) :=
  rfl

end ring_hom

namespace ring_equiv

/-- Swapping components as an equivalence of (semi)rings. -/
def prod_comm {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : R × S ≃+* S × R :=
  mk (add_equiv.to_fun add_equiv.prod_comm) (add_equiv.inv_fun add_equiv.prod_comm) sorry sorry sorry sorry

@[simp] theorem coe_prod_comm {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ⇑prod_comm = prod.swap :=
  rfl

@[simp] theorem coe_prod_comm_symm {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ⇑(ring_equiv.symm prod_comm) = prod.swap :=
  rfl

@[simp] theorem fst_comp_coe_prod_comm {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ring_hom.comp (ring_hom.fst S R) ↑prod_comm = ring_hom.snd R S :=
  ring_hom.ext fun (_x : R × S) => rfl

@[simp] theorem snd_comp_coe_prod_comm {R : Type u_1} {S : Type u_3} [semiring R] [semiring S] : ring_hom.comp (ring_hom.snd S R) ↑prod_comm = ring_hom.fst R S :=
  ring_hom.ext fun (_x : R × S) => rfl


import GroundZero.Algebra.Basic
import GroundZero.HITs.Trunc
open GroundZero GroundZero.Types

namespace GroundZero.Algebra

universe u v

hott def Monoid := Σ (M : Magma), M.isAssociative × M.isUnital

namespace Monoid
  variable (M : Monoid)

  hott def carrier := M.1.carrier
  hott def subset  := M.1.subset
  hott def hset    := M.1.hset
  hott def magma   := M.1

  hott def φ := M.1.φ
  hott def e := M.2.2.1

  hott def mulAssoc : Π a b c, M.φ (M.φ a b) c = M.φ a (M.φ b c) := M.2.1

  hott def oneMul (a : M.carrier) : M.φ M.e a = a := (M.2.2.2 a).1
  hott def mulOne (a : M.carrier) : M.φ a M.e = a := (M.2.2.2 a).2

  hott def isCommutative := M.1.isCommutative

  hott def Hom (G H : Monoid) := Algebra.Hom G.1 H.1

  hott def intro {A : Type u} (H : Structures.hset A)
    (φ : A → A → A) (ι : A → A) (e : A)
    (α : Π a b c, φ (φ a b) c = φ a (φ b c))
    (β₁ : Π a, φ e a = a) (β₂ : Π a, φ a e = a) : Monoid :=
  ⟨Magma.intro H φ, (α, ⟨e, λ a, (β₁ a, β₂ a)⟩)⟩
end Monoid

inductive Term (A : Type u)
| φ : Term A → Term A → Term A
| ι : A → Term A
| e : Term A

hott def Term.toList {A : Type u} : Term A → List A
| Term.φ x y => toList x ++ toList y
| Term.ι x   => [x]
| Term.e     => []

hott def Term.ofList {A : Type u} : List A → Term A
| []      => Term.e
| x :: xs => Term.φ (Term.ι x) (ofList xs)

hott def Term.toMonoid (M : Monoid) : Term M.carrier → M.carrier
| Term.φ x y => M.φ (toMonoid M x) (toMonoid M y)
| Term.ι x   => x
| Term.e     => M.e

hott def Term.ofAppend (M : Monoid) : Π (xs ys : List M.carrier),
    Term.toMonoid M (Term.ofList (xs ++ ys))
  = M.φ (Term.toMonoid M (Term.ofList xs)) (Term.toMonoid M (Term.ofList ys))
| [],      ys => (M.oneMul _)⁻¹
| x :: xs, ys => Id.map (M.φ x) (ofAppend M xs ys) ⬝ (M.mulAssoc _ _ _)⁻¹

hott def Term.sec (M : Monoid) : Term.toMonoid M ∘ Term.ofList ∘ Term.toList ~ Term.toMonoid M
| Term.e     => Id.refl
| Term.ι x   => M.mulOne x
| Term.φ x y => Term.ofAppend M _ _ ⬝ Equiv.bimap M.φ (sec M x) (sec M y)

hott def Term.solve (M : Monoid) (τ₁ τ₂ : Term M.carrier)
  (ρ : τ₁.toList = τ₂.toList) : τ₁.toMonoid M = τ₂.toMonoid M :=
(Term.sec M τ₁)⁻¹ ⬝ Id.map (Term.toMonoid M ∘ Term.ofList) ρ ⬝ Term.sec M τ₂

hott def Term.example (M : Monoid) (x y z : M.carrier) :
  M.φ (M.φ (M.φ x (M.φ y M.e)) M.e) (M.φ z M.e) = M.φ x (M.φ y z) :=
Term.solve M (Term.φ (Term.φ (Term.φ (Term.ι x) (Term.φ (Term.ι y) Term.e)) Term.e) (Term.φ (Term.ι z) Term.e))
  (Term.φ (Term.ι x) (Term.φ (Term.ι y) (Term.ι z))) Id.refl

hott def Term.ret {A : Type u} : Term.toList ∘ @Term.ofList A ~ id
| []      => Id.refl
| x :: xs => Id.map (List.cons x) (ret xs)

end GroundZero.Algebra


import SciLean.Core.Attributes
import SciLean.Mathlib.Convenient.Basic
import SciLean.Data.Prod

namespace SciLean

  class IsSmoothT {X Y : Type} [Vec X] [Vec Y] (f : X → Y) : Prop where
    is_smooth : Mathlib.Convenient.is_smooth f

  class IsSmooth {X Y} [Vec X] [Vec Y] (f : X → Y) extends IsSmoothT f : Prop

  class IsSmoothN {X Y : Type} {Xs Y' : Type} [Vec Xs] [Vec Y']
   (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
   is_smooth : IsSmoothT (uncurryN n f)

  structure SmoothMap (X Y : Type) [Vec X] [Vec Y] where
    val : X → Y
    [property : IsSmoothT val]

  /-- `X ~~> Y` is the space of all smooth maps between `X` and `Y`.

  The notation `X ⟿ Y` is prefered, but this fixes pure ASCII equivalent. -/
  infixr:25 " ~~> " => SmoothMap

  /-- `X ⟿ Y` is the space of all smooth maps between `X` and `Y`.

  Can be also written as `X ~~> Y` -/
  infixr:25 " ⟿ " => SmoothMap

  -- Lambda notation
  open Lean.TSyntax.Compat in
  macro "λ"   xs:Lean.explicitBinders " ⟿ " b:term : term =>
    Lean.expandExplicitBinders `SciLean.SmoothMap.mk xs b

  instance {X Y} [Vec X] [Vec Y] : CoeFun (X⟿Y) (λ _ => X→Y) := ⟨λ f => f.1⟩

  instance SmoothMap.val.arg_x.isSmooth {X Y} [Vec X] [Vec Y] (f : X ⟿ Y)
    : IsSmoothT f.1 := f.2

  abbrev SmoothMap.mk' {X Y} [Vec X] [Vec Y] (f : X → Y) (_ : IsSmoothT f) : X⟿Y := λ x ⟿ f x

  @[ext]
  theorem SmoothMap.ext {X Y} [Vec X] [Vec Y] (f g : X ⟿ Y) : (∀ x, f x = g x) → f = g := by sorry

  @[simp, diff_simp]
  theorem SmoothMap.eta_reduction {X Y} [Vec X] [Vec Y] (f : X ⟿ Y)
      : (λ (x : X) ⟿ f x) = f := by rfl; done

  theorem show_smoothness_via {X Y} [Vec X] [Vec Y] {f : X → Y} (g : X ⟿ Y) : (f = g) → IsSmoothT f :=
  by
    intro p
    have q : f = g := by apply p
    rw[q]; infer_instance

  variable {X Y Z} [Vec X] [Vec Y] [Vec Z] {α : Type}

  def Smooth.comp' : (Y ⟿ Z) → (X ⟿ Y) → (X⟿Z) := λ f g =>
    SmoothMap.mk' (λ x => f (g x)) sorry

  def Smooth.prodMap' : (X⟿Y) → (X⟿Z) → (X ⟿ Y×Z) := λ f g =>
    SmoothMap.mk' (λ x => (f x, g x)) sorry

  def Smooth.prodMap'' : (α→X) × (α→Y) ⟿ (α → X×Y) :=
    SmoothMap.mk' (λ (x,y) a => (x a, y a)) sorry

  def Smooth.const' : X→Y⟿X := λ x =>
    SmoothMap.mk' (λ y => x) sorry

  @[simp] theorem Smooth.comp'_eval (f : Y ⟿ Z) (g : X⟿Y) (x : X) : Smooth.comp' f g x = f (g x) := by simp[Smooth.comp']
  @[simp] theorem Smooth.prodMap'_eval (f : X ⟿ Y) (g : X⟿Z) (x : X) : Smooth.prodMap' f g x = (f x, g x) := by simp[Smooth.prodMap']
  @[simp] theorem Smooth.prodMap''_eval (xy : (α→X) × (α→Y)) : Smooth.prodMap'' xy = λ a => (xy.1 a , xy.2 a) := by simp[Smooth.prodMap'']
  @[simp] theorem Smooth.const'_eval (x : X) (y : Y) : Smooth.const' x y = x := by simp[Smooth.const']

  def Smooth.neg : X ⟿ X := SmoothMap.mk' (λ x => -x) sorry
  def Smooth.add' : X×X ⟿ X := SmoothMap.mk' (λ (x,y) => x+y) sorry
  def Smooth.sub' : X×X ⟿ X := SmoothMap.mk' (λ (x,y) => x-y) sorry
  def Smooth.smul' : ℝ×X ⟿ X := SmoothMap.mk' (λ (r,x) => r•x) sorry
  def Smooth.mul' : ℝ×ℝ ⟿ ℝ := SmoothMap.mk' (λ (x,y) => x*y) sorry

  open Smooth

  instance : Neg (X⟿Y) := ⟨λ f => SmoothMap.mk' (λ x => -f x)
    (show_smoothness_via (comp' neg f) (by ext; simp[neg]))⟩

  instance : Add (X⟿Y) := ⟨λ f g => SmoothMap.mk' (λ x => f x + g x)
    (show_smoothness_via (comp' add' (prodMap' f g)) (by ext; simp[add']))⟩

  instance : Sub (X⟿Y) := ⟨λ f g => SmoothMap.mk' (λ x => f x - g x)
    (show_smoothness_via (comp' sub' (prodMap' f g)) (by ext; simp[sub']))⟩

  instance : Mul (X⟿ℝ) := ⟨λ f g => SmoothMap.mk' (λ x => f x * g x)
    (show_smoothness_via (comp' mul' (prodMap' f g)) (by ext; simp[mul']))⟩

  instance : SMul ℝ (X⟿Y) := ⟨λ r f => SmoothMap.mk' (λ x => r • f x)
    (show_smoothness_via (comp' smul' (prodMap' (const' r) f)) (by ext; simp[smul']))⟩

  instance : HMul (X⟿ℝ) (X⟿Y) (X⟿Y) := ⟨λ f g => SmoothMap.mk' (λ x => f x • g x)
    (show_smoothness_via (comp' smul' (prodMap' f g)) (by ext; simp[smul']))⟩

  instance : Zero (X ⟿ Y) := ⟨const' 0⟩
  instance [One Y] : One (X ⟿ Y) := ⟨const' 1⟩

  -- !!!THIS USES SORRY!!!
  instance : Vec (X ⟿ Y) := Vec.mkSorryProofs

  --------------------------------------------------------------------

  namespace Smooth

  variable {X Y Z W : Type} [Vec X] [Vec Y] [Vec Z] [Vec W]

  def curry' (f : X×Y ⟿ Z) : (X ⟿ Y ⟿ Z) :=
    SmoothMap.mk' (λ x =>
      SmoothMap.mk' (λ y => f (x,y))
      sorry)
    sorry

  def uncurry' (f : X ⟿ Y ⟿ Z) : (X×Y ⟿ Z) :=
    SmoothMap.mk' (λ (x,y) => f x y) sorry

  def forallMap'  (f : α → X⟿Y) : (α → X) ⟿ (α → Y) :=
    SmoothMap.mk' (λ x a => f a (x a)) sorry

  @[simp] theorem curry'_eval (f : X×Y ⟿ Z) (x y) : curry' f x y = f (x,y) := by simp[curry']
  @[simp] theorem uncurry'_eval (f : X⟿ Y ⟿ Z) (xy : X×Y) : uncurry' f xy = f xy.1 xy.2:= by simp[uncurry']
  @[simp] theorem forallMap'_eval (f : α→X⟿Y) (g : α→X) (a : α) : forallMap' f g a = f a (g a) := by simp[forallMap']

  def id : X ⟿ X := SmoothMap.mk' (λ x => x) sorry
  def fst : X×Y ⟿ X := SmoothMap.mk' (λ (x,y) => x) sorry
  def snd : X×Y ⟿ Y := SmoothMap.mk' (λ (x,y) => y) sorry
  def forget : (X⟿Y)⟿(X→Y) := SmoothMap.mk' (λ f x => f x) sorry
  def proj : α → (α → X) ⟿ X := λ a => SmoothMap.mk' (λ f => f a) sorry
  def const (α : Type) : X⟿(α→X) := SmoothMap.mk' (λ x a => x) sorry

  @[simp] theorem id_eval (x : X) : id x = x := by simp[id]
  @[simp] theorem fst_eval (xy : X×Y) : fst xy = xy.1 := by simp[fst]
  @[simp] theorem snd_eval (xy : X×Y) : snd xy = xy.2 := by simp[snd]
  @[simp] theorem forget_eval (f : X⟿Y) : forget f = f.1 := by simp[forget]
  @[simp] theorem proj_eval (a : α) (f : α → X) : proj a f = f a := by simp[proj]
  @[simp] theorem const_eval (x : X) : const α x = λ _ => x := by simp[const]

  def pair : X⟿Y⟿X×Y :=
    SmoothMap.mk' (λ x =>
      SmoothMap.mk' (λ y => (x,y))
      (show_smoothness_via (curry' id x) (by funext x; simp)))
    (show_smoothness_via (curry' id) (by funext y; simp[curry']))

  def swap : X×Y⟿Y×X :=
    SmoothMap.mk' (λ (x,y) => (y,x))
      (show_smoothness_via (prodMap' snd fst) (by funext; simp))

  @[simp] theorem pair_eval (x : X) (y : Y) : pair x y = (x,y) := by simp[pair]
  @[simp] theorem swap_eval (xy : X×Y) : swap xy = (xy.2,xy.1) := by simp[swap]

  def eval : X⟿(X⟿Y)⟿Y :=
    SmoothMap.mk' (λ x : X =>
      SmoothMap.mk' (λ f : X⟿Y => f x)
      (show_smoothness_via (curry' (comp' (uncurry' id) swap) x) (by ext; simp)))
    (show_smoothness_via (curry' (comp' (uncurry' id) swap)) (by ext; simp))

  def assocl : X×(Y×Z) ⟿ (X×Y)×Z :=
    SmoothMap.mk' (λ (x,y,z) => ((x,y),z))
      (show_smoothness_via (prodMap' (prodMap' fst (comp' fst snd))  (comp' snd snd)) (by funext; simp))

  def assocr : (X×Y)×Z ⟿ X×(Y×Z) :=
    SmoothMap.mk' (λ ((x,y),z) => (x,y,z))
      (show_smoothness_via (prodMap' (comp' fst fst) (prodMap' (comp' snd fst) snd)) (by funext; simp))

  @[simp] theorem eval_eval (x : X) (f : X⟿Y) : eval x f = f x := by simp[eval]
  @[simp] theorem assocl_eval (xyz : X×(Y×Z)) : assocl xyz = ((xyz.1, xyz.2.1),xyz.2.2) := by simp[assocl]
  @[simp] theorem assocr_eval (xyz : (X×Y)×Z) : assocr xyz = (xyz.1.1, (xyz.1.2,xyz.2)) := by simp[assocr]

  def comp : (Y⟿Z)⟿(X⟿Y)⟿X⟿Z :=
    SmoothMap.mk' (λ f : Y⟿Z =>
      SmoothMap.mk' (λ g : X⟿Y =>
        SmoothMap.mk' (λ x : X => f (g x))
        (show_smoothness_via (comp' (f) (g)) (by ext; simp)))
      (show_smoothness_via (curry' (comp' (f) (uncurry' (id (X:=X⟿Y))))) (by ext; simp)))
    (show_smoothness_via (
      let F : (Y⟿Z)×(X⟿Y)×X⟿Z := comp' (uncurry' id) (prodMap' (fst) (comp' (uncurry' (id (X:=X⟿Y))) (snd)))
      curry' (curry' (comp' F (assocr))))
      (by ext; simp))

  def prodMap : (X⟿Y)⟿(X⟿Z)⟿X⟿Y×Z :=
    SmoothMap.mk' (λ f =>
      SmoothMap.mk' (λ g =>
        SmoothMap.mk' (λ x => (f x, g x))
        (show_smoothness_via (prodMap' f g) (by funext; simp)))
      (show_smoothness_via (curry' (comp' swap (prodMap' (uncurry' id) (comp' f snd)))) (by funext g; simp[comp',curry'])))
    (show_smoothness_via (
      let F : (X⟿Y)×(X⟿Z)×X ⟿ Y×Z := comp'
        (prodMap' (comp' (uncurry' id) fst) (comp' (uncurry' id) snd))
        (prodMap' (prodMap' fst (comp' snd snd)) (prodMap' (comp' fst snd) (comp' snd snd)))
      curry' (curry' (comp' F (assocr))))
      (by funext; simp[curry',comp']))

  @[simp] theorem comp_eval (f : Y⟿Z) (g : X⟿Y) : comp f g = comp' f g := by simp[comp,comp']
  @[simp] theorem prodMap_eval (f : Y⟿Z) (g : X⟿Y) (x : X) : comp f g x = f (g x) := by simp[comp]

  def curry : (X×Y⟿Z)⟿X⟿Y⟿Z :=
    SmoothMap.mk' (λ f =>
      SmoothMap.mk' (λ x =>
        SmoothMap.mk' (λ y => f (x,y))
        (show_smoothness_via (curry' f x) (by ext; simp)))
      (show_smoothness_via (curry' f) (by ext; simp)))
    (show_smoothness_via (
      let F : ((X×Y⟿Z)×X)×Y⟿Z := comp' (uncurry' id) assocr
      curry' (curry' F)
      ) (by ext; simp))

  def uncurry : (X⟿Y⟿Z)⟿X×Y⟿Z :=
    SmoothMap.mk' (λ f =>
      SmoothMap.mk' (λ xy => f xy.1 xy.2)
      (show_smoothness_via (uncurry' f) (by ext; simp)))
    (show_smoothness_via (
      let F : ((X⟿Y⟿Z)×X)×Y⟿Z := comp' (uncurry' id) (prodMap' (comp' (uncurry' id) fst) snd)
      (curry' (comp' F assocl))
      ) (by ext; simp))

  def forallMap : (α → X⟿Y) ⟿ (α → X) ⟿ (α → Y) :=
    SmoothMap.mk' (λ f =>
      SmoothMap.mk' (λ x a => f a (x a))
      (show_smoothness_via (forallMap' f) (by ext; simp)))
    (show_smoothness_via (
      let F : (α → (X⟿Y))×(α → X) ⟿ _ := prodMap'' |> comp' (forallMap' (λ _ => uncurry' id))
      curry' F
    ) (by ext f g a; simp[curry']))

  @[simp] theorem curry_eval (f : X×Y⟿Z) : curry f = curry' f := by simp[curry,curry']
  @[simp] theorem uncurry_eval (f : X⟿Y⟿Z) : uncurry f = uncurry' f := by simp[uncurry,uncurry']
  @[simp] theorem forallMap_eval (f : α→X⟿Y) : forallMap f = forallMap' f := by simp[forallMap, forallMap']

  -- variable {ι κ : Type} {E F G : ι → Type} {E' : κ → Type} [∀ i, Vec (E i)] [∀ i, Vec (F i)] [∀ i, Vec (G i)] [∀ j, Vec (E' j)]

  -- def pmapDep : ((i : ι)→(E i)) ⟿ ((i : ι)→(F i)) ⟿ ((i : ι)→(E i)×(F i)) := ⟨λ f => ⟨λ g => λ x => (f x, g x), sorry⟩, sorry⟩
  -- def fmapDep : ((i : ι)→(E i)) ⟿ ((j : κ)→(E' j)) ⟿ ((ij : (ι×κ))→(E ij.1)×(E' ij.2)) := ⟨λ f => ⟨λ g => λ (i,j) => (f i, g j), sorry⟩, sorry⟩
  -- def prodDep : ((i : ι) → E i ⟿ F i) ⟿ ((i : ι) → E i) ⟿ ((i : ι) → F i) := sorry

  end Smooth


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.equiv_rw
import Mathlib.PostPort

namespace Mathlib

/-!
## The `transport` tactic

`transport` attempts to move an `s : S α` expression across an equivalence `e : α ≃ β` to solve
a goal of the form `S β`, by building the new object field by field, taking each field of `s`
and rewriting it along `e` using the `equiv_rw` tactic.

We try to ensure good definitional properties, so that, for example, when we transport a `monoid α`
to a `monoid β`, the new multiplication is definitionally `λ x y, e (e.symm a * e.symm b)`.
-/

namespace tactic

/--
Given `s : S α` for some structure `S` depending on a type `α`,
and an equivalence `e : α ≃ β`,
try to produce an `S β`,
by transporting data and axioms across `e` using `equiv_rw`.
-/
namespace interactive

/--
Given a goal `⊢ S β` for some type class `S`, and an equivalence `e : α ≃ β`.
`transport using e` will look for a hypothesis `s : S α`,
and attempt to close the goal by transporting `s` across the equivalence `e`.

```lean
example {α : Type} [ring α] {β : Type} (e : α ≃ β) : ring β :=
by transport using e.
```

You can specify the object to transport using `transport s using e`.

`transport` works by attempting to copy each of the operations and axiom fields of `s`,
rewriting them using `equiv_rw e` and defining a new structure using these rewritten fields.

If it fails to fill in all the new fields, `transport` will produce new subgoals.
It's probably best to think about which missing `simp` lemmas would have allowed `transport`
to finish, rather than solving these goals by hand.
(This may require looking at the implementation of `tranport` to understand its algorithm;
there are several examples of "transport-by-hand" at the end of `test/equiv_rw.lean`,
which `transport` is an abstraction of.)
-/


import Lib.Logic.Relation
import Lib.Order.Basic

-- class abbrev Zero (α : Type u) := OfNat α (nat_lit 0)
-- class abbrev One (α : Type u) := OfNat α (nat_lit 1)

class Zero (α : Type u) where
  zero : α

instance [Zero α] : OfNat α (nat_lit 0) where
  ofNat := Zero.zero

class One (α : Type u) where
  one : α

instance [One α] : OfNat α (nat_lit 1) where
  ofNat := One.one

open One

class Monoid (α : Type u) extends One α, Mul α where
  one_mul {x : α} : 1 * x = x
  mul_one {x : α} : x * 1 = x
  mul_assoc {x y z : α} : (x * y) * z = x * (y * z)

attribute [simp] Monoid.one_mul Monoid.mul_one Monoid.mul_assoc

def Additive (α : Type u) := α

abbrev AddMonoid (α) := Monoid (Additive α)

instance [AddMonoid α] : Add α where
  add := Mul.mul (α := Additive α)

instance [AddMonoid α] : Zero α where
  zero := One.one (α := Additive α)

namespace AddMonoid
open Monoid Zero

variable {α} [AddMonoid α]

@[simp]
theorem add_zero (x : α) : x + 0 = x :=
have := mul_one (α := Additive α) (x := x)
this

@[simp]
theorem zero_add (x : α) : 0 + x = x :=
have := one_mul (α := Additive α) (x := x)
this

@[simp]
theorem add_assoc (x y z : α) : (x + y) + z = x + (y + z) :=
mul_assoc (α := Additive α)

end AddMonoid

class CommMonoid (α : Type u)
extends Monoid α where
  mul_comm {x y : α} : x * y = y * x

abbrev AddCommMonoid (α : Type u) :=
CommMonoid (Additive α)

namespace AddCommMonoid
variable [AddCommMonoid α]

theorem add_comm {x y : α} : x + y = y + x :=
CommMonoid.mul_comm (α := Additive α)

end AddCommMonoid

instance [LE α] : LE (Additive α) where
  le := LE.le (α := α)

class OrderedMonoid (α : Type u) [LE α]
extends Monoid α where
  mul_le_mul {x x' y y' : α} :
    x ≤ x' →
    y ≤ y' →
    x * y ≤ x' * y'

namespace OrderedMonoid
open Reflexive
variable [LE α] [Preorder α] [OrderedMonoid α]

theorem mul_le_mul_l {x x' y : α}
        (h : x ≤ x') :
  x * y ≤ x' * y :=
mul_le_mul h <| refl _

theorem mul_le_mul_r {x y y' : α}
        (h : y ≤ y') :
  x * y ≤ x * y' :=
mul_le_mul (refl _) h

end OrderedMonoid

-- @[class]
abbrev AddOrderedMonoid (α : Type u) [LE α] :=
OrderedMonoid (Additive α)

namespace AddOrderedMonoid
open Reflexive
variable [LE α] [AddOrderedMonoid α]

theorem add_le_add {x x' y y' : α} :
    x ≤ x' →
    y ≤ y' →
    x + y ≤ x' + y' :=
OrderedMonoid.mul_le_mul (α := Additive α)

variable [Preorder α]

theorem add_le_add_l {x x' y : α}
        (h : x ≤ x') :
  x + y ≤ x' + y :=
add_le_add h <| refl _

theorem add_le_add_r {x y y' : α}
        (h : y ≤ y') :
  x + y ≤ x + y' :=
add_le_add (refl _) h

end AddOrderedMonoid

structure MonoidHom (α β) [Monoid α] [Monoid β] where
  fn : α → β
  fn_id : fn 1 = 1
  fn_mul {x y : α} : fn (x * y) = fn x * fn y

instance [Monoid α] [Monoid β] : CoeFun (MonoidHom α β) (λ _ => α → β) where
  coe f := f.fn

attribute [simp] MonoidHom.fn_id MonoidHom.fn_mul

instance : CommMonoid Nat where
  one := 1
  mul := _
  mul_one := @Nat.mul_one
  one_mul := @Nat.one_mul
  mul_assoc := @Nat.mul_assoc
  mul_comm := @Nat.mul_comm

instance : AddCommMonoid Nat where
  one := (0 : Nat)
  mul := Nat.add
  mul_one := @Nat.add_zero
  one_mul := @Nat.zero_add
  mul_assoc := @Nat.add_assoc
  mul_comm := @Nat.add_comm

def Endo (α : Sort u) := α → α
def Endo.mk (f : α → α) : Endo α := f
def Endo.run (f : Endo α) : α → α := f

instance : Monoid (Endo α) where
  one := id
  mul := (.∘.)
  mul_one := rfl
  one_mul := rfl
  mul_assoc := rfl

namespace Endo

@[simp]
theorem run_one :
  @Endo.run α (1 : Endo α) x = x := rfl

@[simp]
theorem run_one' :
  @Endo.run α one x = x := rfl

@[simp]
theorem run_mk {α} x a :
  @Endo.run α (Endo.mk x) a = x a := rfl

@[simp]
theorem run_mul_mk {α} (x : α → α) y a :
  @Endo.run α (Endo.mk x * y) a = x (Endo.run y a) := rfl

@[simp]
theorem run_mul_mk' {α} x y a :
  @Endo.run α (x * Endo.mk y) a = Endo.run x (y a) := rfl

end Endo

def Op (α : Sort u) := α
def Op.mk (f : α) : Op α := f
def Op.run (f : Op α) : α := f

instance [Monoid α] : Monoid (Op α) where
  one := (1 : α)
  mul (x y : α) := y * x
  mul_one := @Monoid.one_mul α _
  one_mul := @Monoid.mul_one α _
  mul_assoc {x y z} := @Monoid.mul_assoc α _ z y x |>.symm

namespace Op

@[simp]
theorem run_mk [Monoid α] (x : α) :
  Op.run (Op.mk x) = x := rfl

@[simp]
theorem run_one' [Monoid α] :
  Op.run one = one (α := α) := rfl

@[simp]
theorem run_one [Monoid α] :
  Op.run (1 : α) = 1 := rfl

@[simp]
theorem run_mul [Monoid α] (x y : Op α) :
  Op.run (x * y) = y.run * x.run := rfl

end Op

namespace Monoid

structure Max (α : Type u) where
  get : Option α
structure Min (α : Type u) where
  get : Option α
structure Sum (α : Type u) where
  get : α

-- instance [LT α] [DecidableRel LT.lt (α := α)] : Monoid (Max α) where
--   one := ⟨ none ⟩
--   mul
--     | ⟨ some x ⟩, ⟨ some y ⟩ => ⟨ some (max x y) ⟩
--     | ⟨ none ⟩, x => x
--     | x, ⟨ none ⟩ => x

end Monoid


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

Miscellaneous function constructions and lemmas.
-/
import logic.basic data.option.defs

universes u v w

namespace function

section
variables {α : Sort u} {β : Sort v} {f : α → β}

lemma hfunext {α α': Sort u} {β : α → Sort v} {β' : α' → Sort v} {f : Πa, β a} {f' : Πa, β' a}
  (hα : α = α') (h : ∀a a', a == a' → f a == f' a') : f == f' :=
begin
  subst hα,
  have : ∀a, f a == f' a,
  { intro a, exact h a a (heq.refl a) },
  have : β = β',
  { funext a, exact type_eq_of_heq (this a) },
  subst this,
  apply heq_of_eq,
  funext a,
  exact eq_of_heq (this a)
end

lemma funext_iff {β : α → Sort*} {f₁ f₂ : Π (x : α), β x} : f₁ = f₂ ↔ (∀a, f₁ a = f₂ a) :=
iff.intro (assume h a, h ▸ rfl) funext

lemma comp_apply {α : Sort u} {β : Sort v} {φ : Sort w} (f : β → φ) (g : α → β) (a : α) :
  (f ∘ g) a = f (g a) := rfl

@[simp] theorem injective.eq_iff (I : injective f) {a b : α} :
  f a = f b ↔ a = b :=
⟨@I _ _, congr_arg f⟩

lemma injective.ne (hf : function.injective f) {a₁ a₂ : α} : a₁ ≠ a₂ → f a₁ ≠ f a₂ :=
mt (assume h, hf h)

def injective.decidable_eq [decidable_eq β] (I : injective f) : decidable_eq α
| a b := decidable_of_iff _ I.eq_iff

instance decidable_eq_pfun (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, decidable_eq (α hp)] : decidable_eq (Π hp, α hp)
| f g := decidable_of_iff (∀ hp, f hp = g hp) funext_iff.symm

theorem cantor_surjective {α} (f : α → α → Prop) : ¬ function.surjective f | h :=
let ⟨D, e⟩ := h (λ a, ¬ f a a) in
(iff_not_self (f D D)).1 $ iff_of_eq (congr_fun e D)

theorem cantor_injective {α : Type*} (f : (α → Prop) → α) :
  ¬ function.injective f | i :=
cantor_surjective (λ a b, ∀ U, a = f U → U b) $
surjective_of_has_right_inverse ⟨f, λ U, funext $
  λ a, propext ⟨λ h, h U rfl, λ h' U' e, i e ▸ h'⟩⟩

/-- `g` is a partial inverse to `f` (an injective but not necessarily
  surjective function) if `g y = some x` implies `f x = y`, and `g y = none`
  implies that `y` is not in the range of `f`. -/
def is_partial_inv {α β} (f : α → β) (g : β → option α) : Prop :=
∀ x y, g y = some x ↔ f x = y

theorem is_partial_inv_left {α β} {f : α → β} {g} (H : is_partial_inv f g) (x) : g (f x) = some x :=
(H _ _).2 rfl

theorem injective_of_partial_inv {α β} {f : α → β} {g} (H : is_partial_inv f g) : injective f :=
λ a b h, option.some.inj $ ((H _ _).2 h).symm.trans ((H _ _).2 rfl)

theorem injective_of_partial_inv_right {α β} {f : α → β} {g} (H : is_partial_inv f g)
 (x y b) (h₁ : b ∈ g x) (h₂ : b ∈ g y) : x = y :=
((H _ _).1 h₁).symm.trans ((H _ _).1 h₂)

theorem left_inverse.comp_eq_id {f : α → β} {g : β → α} (h : left_inverse f g) : f ∘ g = id :=
funext h

theorem right_inverse.comp_eq_id {f : α → β} {g : β → α} (h : right_inverse f g) : g ∘ f = id :=
funext h

theorem left_inverse.comp {γ} {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : left_inverse f g) (hh : left_inverse h i) : left_inverse (h ∘ f) (g ∘ i) :=
assume a, show h (f (g (i a))) = a, by rw [hf (i a), hh a]

theorem right_inverse.comp {γ} {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : right_inverse f g) (hh : right_inverse h i) : right_inverse (h ∘ f) (g ∘ i) :=
left_inverse.comp hh hf

local attribute [instance] classical.prop_decidable

/-- We can use choice to construct explicitly a partial inverse for
  a given injective function `f`. -/
noncomputable def partial_inv {α β} (f : α → β) (b : β) : option α :=
if h : ∃ a, f a = b then some (classical.some h) else none

theorem partial_inv_of_injective {α β} {f : α → β} (I : injective f) :
  is_partial_inv f (partial_inv f) | a b :=
⟨λ h, if h' : ∃ a, f a = b then begin
    rw [partial_inv, dif_pos h'] at h,
    injection h with h, subst h,
    apply classical.some_spec h'
  end else by rw [partial_inv, dif_neg h'] at h; contradiction,
 λ e, e ▸ have h : ∃ a', f a' = f a, from ⟨_, rfl⟩,
   (dif_pos h).trans (congr_arg _ (I $ classical.some_spec h))⟩

theorem partial_inv_left {α β} {f : α → β} (I : injective f) : ∀ x, partial_inv f (f x) = some x :=
is_partial_inv_left (partial_inv_of_injective I)

end

section inv_fun
variables {α : Type u} [inhabited α] {β : Sort v} {f : α → β} {s : set α} {a : α} {b : β}

local attribute [instance] classical.prop_decidable

/-- Construct the inverse for a function `f` on domain `s`. -/
noncomputable def inv_fun_on (f : α → β) (s : set α) (b : β) : α :=
if h : ∃a, a ∈ s ∧ f a = b then classical.some h else default α

theorem inv_fun_on_pos (h : ∃a∈s, f a = b) : inv_fun_on f s b ∈ s ∧ f (inv_fun_on f s b) = b :=
by rw [bex_def] at h; rw [inv_fun_on, dif_pos h]; exact classical.some_spec h

theorem inv_fun_on_mem (h : ∃a∈s, f a = b) : inv_fun_on f s b ∈ s := (inv_fun_on_pos h).left

theorem inv_fun_on_eq (h : ∃a∈s, f a = b) : f (inv_fun_on f s b) = b := (inv_fun_on_pos h).right

theorem inv_fun_on_eq' (h : ∀ x y ∈ s, f x = f y → x = y) (ha : a ∈ s) :
  inv_fun_on f s (f a) = a :=
have ∃a'∈s, f a' = f a, from ⟨a, ha, rfl⟩,
h _ _ (inv_fun_on_mem this) ha (inv_fun_on_eq this)

theorem inv_fun_on_neg (h : ¬ ∃a∈s, f a = b) : inv_fun_on f s b = default α :=
by rw [bex_def] at h; rw [inv_fun_on, dif_neg h]

/-- The inverse of a function (which is a left inverse if `f` is injective
  and a right inverse if `f` is surjective). -/
noncomputable def inv_fun (f : α → β) : β → α := inv_fun_on f set.univ

theorem inv_fun_eq (h : ∃a, f a = b) : f (inv_fun f b) = b :=
inv_fun_on_eq $ let ⟨a, ha⟩ := h in ⟨a, trivial, ha⟩

lemma inv_fun_neg (h : ¬ ∃ a, f a = b) : inv_fun f b = default α :=
by refine inv_fun_on_neg (mt _ h); exact assume ⟨a, _, ha⟩, ⟨a, ha⟩

theorem inv_fun_eq_of_injective_of_right_inverse {g : β → α}
  (hf : injective f) (hg : right_inverse g f) : inv_fun f = g :=
funext $ assume b,
hf begin rw [hg b], exact inv_fun_eq ⟨g b, hg b⟩ end

lemma right_inverse_inv_fun (hf : surjective f) : right_inverse (inv_fun f) f :=
assume b, inv_fun_eq $ hf b

lemma left_inverse_inv_fun (hf : injective f) : left_inverse (inv_fun f) f :=
assume b,
have f (inv_fun f (f b)) = f b,
  from inv_fun_eq ⟨b, rfl⟩,
hf this

lemma inv_fun_surjective (hf : injective f) : surjective (inv_fun f) :=
surjective_of_has_right_inverse ⟨_, left_inverse_inv_fun hf⟩

lemma inv_fun_comp (hf : injective f) : inv_fun f ∘ f = id := funext $ left_inverse_inv_fun hf

lemma injective.has_left_inverse (hf : injective f) : has_left_inverse f :=
⟨inv_fun f, left_inverse_inv_fun hf⟩

lemma injective_iff_has_left_inverse : injective f ↔ has_left_inverse f :=
⟨injective.has_left_inverse, injective_of_has_left_inverse⟩

end inv_fun

section surj_inv
variables {α : Sort u} {β : Sort v} {f : α → β}

/-- The inverse of a surjective function. (Unlike `inv_fun`, this does not require
  `α` to be inhabited.) -/
noncomputable def surj_inv {f : α → β} (h : surjective f) (b : β) : α := classical.some (h b)

lemma surj_inv_eq (h : surjective f) (b) : f (surj_inv h b) = b := classical.some_spec (h b)

lemma right_inverse_surj_inv (hf : surjective f) : right_inverse (surj_inv hf) f :=
surj_inv_eq hf

lemma left_inverse_surj_inv (hf : bijective f) : left_inverse (surj_inv hf.2) f :=
right_inverse_of_injective_of_left_inverse hf.1 (right_inverse_surj_inv hf.2)

lemma surjective.has_right_inverse (hf : surjective f) : has_right_inverse f :=
⟨_, right_inverse_surj_inv hf⟩

lemma surjective_iff_has_right_inverse : surjective f ↔ has_right_inverse f :=
⟨surjective.has_right_inverse, surjective_of_has_right_inverse⟩

lemma bijective_iff_has_inverse : bijective f ↔ ∃ g, left_inverse g f ∧ right_inverse g f :=
⟨λ hf, ⟨_, left_inverse_surj_inv hf, right_inverse_surj_inv hf.2⟩,
 λ ⟨g, gl, gr⟩, ⟨injective_of_left_inverse gl, surjective_of_has_right_inverse ⟨_, gr⟩⟩⟩

lemma injective_surj_inv (h : surjective f) : injective (surj_inv h) :=
injective_of_has_left_inverse ⟨f, right_inverse_surj_inv h⟩

end surj_inv

section update
variables {α : Sort u} {β : α → Sort v} [decidable_eq α]

def update (f : Πa, β a) (a' : α) (v : β a') (a : α) : β a :=
if h : a = a' then eq.rec v h.symm else f a

@[simp] lemma update_same {a : α} {v : β a} {f : Πa, β a} : update f a v a = v :=
dif_pos rfl

@[simp] lemma update_noteq {a a' : α} {v : β a'} {f : Πa, β a} (h : a ≠ a') : update f a' v a = f a :=
dif_neg h

end update

lemma uncurry_def {α β γ} (f : α → β → γ) : uncurry f = (λp, f p.1 p.2) :=
funext $ assume ⟨a, b⟩, rfl

def restrict {α β} (f : α → β) (s : set α) : subtype s → β := λ x, f x.val

theorem restrict_eq {α β} (f : α → β) (s : set α): function.restrict f s = f ∘ (@subtype.val _ s) := rfl

end function


-- author: Ben Sherman
import .lptree
       galois.list
       galois.list.filter_some

namespace binary_tree

universes u v

/-- Binary trees *with* internal nodes
    (which differs from both `ptree` and `lptree`)

    In this formulation, every binary tree has at least
    one item of type A in it.
-/
inductive tree (A : Type) : Type
| leaf (item : A) : tree
| node (item : A) (l r : tree) : tree

namespace tree
def height {A : Type} : tree A → ℕ
| (leaf x) := 0
| (node x l r) := max (height l) (height r) + 1
end tree

/-- Pick the item at the root of the tree -/
def root {A} : tree A -> A
| (tree.node x _ _) := x
| (tree.leaf x) := x

/-- Combine a left and right subtree into a single tree
    with some function that determines the root of the
    new tree from the roots of the subtrees
-/
def combine {A} (f : A -> A -> A) (l r : tree A)
  : tree A := tree.node (f (root l) (root r)) l r

lemma combine_height {A} (f : A → A → A) (l r : tree A)
  : (combine f l r).height = max l.height r.height + 1
:= rfl

namespace tree
/-- Enumerate the leaves of a binary tree from right to left
-/
def leaves {A} : tree A -> list A
| (node x l r) := leaves r ++ leaves l
| (leaf x) := [x]

lemma leaves_combine {A} (f)
  (x y : tree A)
  : (combine f x y).leaves
  = y.leaves ++ x.leaves :=
begin
induction x,
  { simp [combine, leaves] },
  { reflexivity }
end
end tree

def tree_leaves_option {A} : option (tree A) -> list A
| none := []
| (some t) := t.leaves

/-- Given a tree specified by a list of its left subtrees and
    its rightmost subtree, enumerate its leaves from right to left
-/
def left_subtrees_leaves {A}
  (f : A -> A -> A)
  : list (tree A) -> tree A -> list A
| [] x := x.leaves
| (y :: ys) x := left_subtrees_leaves ys (combine f y x)

/-- Enumerate the leaves of a tree specified by a list of
    left subtrees (with an empty rightmost subtree)
    in reverse order
-/
def left_subtrees_leaves' {A}
  : list (tree A) -> list A
| [] := []
| (t :: ts) := t.leaves ++ left_subtrees_leaves' ts

lemma left_subtrees_leaves_same {A}
  (f : A -> A -> A) (ts : list (tree A))
  : ∀ t : tree A,
    left_subtrees_leaves f ts t = t.leaves ++ left_subtrees_leaves' ts
  :=
begin
induction ts; intros,
  { simp [left_subtrees_leaves],
    simp [left_subtrees_leaves']
  },
  { simp [left_subtrees_leaves'],
    simp [left_subtrees_leaves],
    rw ih_1,
    rw tree.leaves_combine,
    rw list.append_assoc
   }
end

def tree_mem {A} (t : tree A) : tree A -> Prop
| (tree.node i l r) := t = tree.node i l r ∨ tree_mem l ∨ tree_mem r
| (tree.leaf i) := t = tree.leaf i

/-- This inductive predicate holds of a binary tree
    if all of its internal nodes can be compute by applying
    `f` to the roots of its left and right subtrees
-/
inductive internal_nodes_ok {A} (f : A -> A -> A) : tree A -> Prop
| leaf : forall  x : A, internal_nodes_ok (tree.leaf x)
| node : forall x l r, internal_nodes_ok l -> internal_nodes_ok r
      -> x = f (root l) (root r) -> internal_nodes_ok (tree.node x l r)

lemma internal_nodes_ok_combine {A} (f : A -> A -> A)
  (x y : tree A)
  (Hx : internal_nodes_ok f x)
  (Hy : internal_nodes_ok f y)
  : internal_nodes_ok f (combine f x y) :=
begin
unfold combine,
constructor, assumption, assumption, reflexivity
end

end binary_tree


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

universes u
variables {α : Type u}

namespace list

/- erase duplicates function -/

variable [decidable_eq α]

@[simp] theorem erase_dup_nil : erase_dup [] = ([] : list α) := rfl

theorem erase_dup_cons_of_mem' {a : α} {l : list α} (h : a ∈ erase_dup l) :
  erase_dup (a::l) = erase_dup l :=
pw_filter_cons_of_neg $ by simpa only [forall_mem_ne] using h

theorem erase_dup_cons_of_not_mem' {a : α} {l : list α} (h : a ∉ erase_dup l) :
  erase_dup (a::l) = a :: erase_dup l :=
pw_filter_cons_of_pos $ by simpa only [forall_mem_ne] using h

@[simp] theorem mem_erase_dup {a : α} {l : list α} : a ∈ erase_dup l ↔ a ∈ l :=
by simpa only [erase_dup, forall_mem_ne, not_not] using not_congr (@forall_mem_pw_filter α (≠) _
  (λ x y z xz, not_and_distrib.1 $ mt (and.rec eq.trans) xz) a l)

@[simp] theorem erase_dup_cons_of_mem {a : α} {l : list α} (h : a ∈ l) :
  erase_dup (a::l) = erase_dup l :=
erase_dup_cons_of_mem' $ mem_erase_dup.2 h

@[simp] theorem erase_dup_cons_of_not_mem {a : α} {l : list α} (h : a ∉ l) :
  erase_dup (a::l) = a :: erase_dup l :=
erase_dup_cons_of_not_mem' $ mt mem_erase_dup.1 h

theorem erase_dup_sublist : ∀ (l : list α), erase_dup l <+ l := pw_filter_sublist

theorem erase_dup_subset : ∀ (l : list α), erase_dup l ⊆ l := pw_filter_subset

theorem subset_erase_dup (l : list α) : l ⊆ erase_dup l :=
λ a, mem_erase_dup.2

theorem nodup_erase_dup : ∀ l : list α, nodup (erase_dup l) := pairwise_pw_filter

theorem erase_dup_eq_self {l : list α} : erase_dup l = l ↔ nodup l := pw_filter_eq_self

@[simp] theorem erase_dup_idempotent {l : list α} : erase_dup (erase_dup l) = erase_dup l :=
pw_filter_idempotent

theorem erase_dup_append (l₁ l₂ : list α) : erase_dup (l₁ ++ l₂) = l₁ ∪ erase_dup l₂ :=
begin
  induction l₁ with a l₁ IH, {refl}, rw [cons_union, ← IH],
  show erase_dup (a :: (l₁ ++ l₂)) = insert a (erase_dup (l₁ ++ l₂)),
  by_cases a ∈ erase_dup (l₁ ++ l₂);
  [ rw [erase_dup_cons_of_mem' h, insert_of_mem h],
    rw [erase_dup_cons_of_not_mem' h, insert_of_not_mem h]]
end

end list


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import algebra.order.nonneg.ring
import algebra.order.archimedean

/-!
# Nonnegative elements are archimedean

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

This file defines instances and prove some properties about the nonnegative elements
`{x : α // 0 ≤ x}` of an arbitrary type `α`.

This is used to derive algebraic structures on `ℝ≥0` and `ℚ≥0` automatically.

## Main declarations

* `{x : α // 0 ≤ x}` is a `floor_semiring` if `α` is.
-/

namespace nonneg
variables {α : Type*}

instance archimedean [ordered_add_comm_monoid α] [archimedean α] : archimedean {x : α // 0 ≤ x} :=
⟨λ x y hy,
  let ⟨n, hr⟩ := archimedean.arch (x : α) (hy : (0 : α) < y) in
  ⟨n, show (x : α) ≤ (n • y : {x : α // 0 ≤ x}), by simp [*, -nsmul_eq_mul, nsmul_coe]⟩⟩

instance floor_semiring [ordered_semiring α] [floor_semiring α] : floor_semiring {r : α // 0 ≤ r} :=
{ floor := λ a, ⌊(a : α)⌋₊,
  ceil := λ a, ⌈(a : α)⌉₊,
  floor_of_neg := λ a ha, floor_semiring.floor_of_neg ha,
  gc_floor := λ a n ha, begin
    refine (floor_semiring.gc_floor (show 0 ≤ (a : α), from ha)).trans _,
    rw [←subtype.coe_le_coe, nonneg.coe_nat_cast]
  end,
  gc_ceil := λ a n, begin
    refine (floor_semiring.gc_ceil (a : α) n).trans _,
    rw [←subtype.coe_le_coe, nonneg.coe_nat_cast]
  end}

@[norm_cast] lemma nat_floor_coe [ordered_semiring α] [floor_semiring α] (a : {r : α // 0 ≤ r}) :
  ⌊(a : α)⌋₊ = ⌊a⌋₊ := rfl

@[norm_cast] lemma nat_ceil_coe [ordered_semiring α] [floor_semiring α] (a : {r : α // 0 ≤ r}) :
  ⌈(a : α)⌉₊ = ⌈a⌉₊  := rfl

end nonneg