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


-- import data.set
import tactic

-- dEAduction imports
import structures2
import utils

-- General principles :
-- Type should be defined as parameters, in order to be implicit everywhere
-- other parameters are implicit in definitions, i.e. defined using '{}' (e.g. {A : set X} )
-- but explicit everywhere else, i.e. defined using '()' (e.g. (A : set X) )
-- each definition must be an iff statement (since it will be called with 'rw' or 'symp_rw')

-- no Magic button ("compute")
/- dEAduction
Title
    Logique propositionnelle (tutoriel)
Author
    Frédéric Le Roux
Institution
    Université du Monde
Description
    Ce fichier, qui peut servir de tutoriel, contient quelques énoncés de logiques propositionnelle.
    Le but n'est pas de les démontrer du point de vue de la logique propositionnelle,
    mais plutôt de voir comment l'interface fonctionne sur ces énoncés.
DefaultAvailableProof
    NONE
DefaultAvailableMagic
    Assumption
-/

-- logic names ['and', 'or', 'not', 'implies', 'iff', 'forall', 'exists']
-- proofs names ['proof_methods', 'new_object', 'apply']
-- magic names ['compute', 'assumption']

local attribute [instance] classical.prop_decidable
---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
variables (P Q R: Prop) -- NOT global
notation [parsing_only] P ` \and ` Q := P ∧ Q
notation [parsing_only]  P ` \or ` Q := P ∨ Q
notation [parsing_only]  ` \not ` P := ¬ P
notation [parsing_only]  P ` \implies ` Q := P → Q
notation [parsing_only]  P ` \iff ` Q := P ↔ Q

------------------
-- COURSE TITLE --
------------------
namespace Logique_propositionnelle

lemma exercise.tautologie :
P → P
:=
/- dEAduction
PrettyName
    La tautologie
Description
    Le bouton "=>" permet de démontrer une implication : pour montrer
    "P => Q", on suppose P, et on montre Q.
AvailableLogic
    implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et :
P ∧ Q → P
:=
/- dEAduction
PrettyName
    P et Q implique P
Description
    Le bouton "ET" permet de découper une hypothèse
AvailableLogic
    and implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_I :
P ∧ Q → Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif (version faible)
Description
    Le bouton "ET" permet aussi de découper le but en deux buts distincts
AvailableLogic
    and implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_II :
P ∧ Q ↔ Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif
Description
    Le bouton "↔" permet de découper le but en deux implications.
    On peut alors appliquer le résultat de l'exercice précédent en le
    sélectionnant dans la liste...
AvailableLogic
    and iff implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_commutatif :
P ∨ Q ↔ Q ∨ P
:=
/- dEAduction
PrettyName
    Le "OU" est commutatif
Description
    Pour utiliser l'hypothèse "P OU Q", on sépare les cas :
    dans le premier cas on suppose P, dans le second cas on suppose Q.
    Pour démontrer "Q OU P", on doit démontrer soit P, soit Q.
AvailableLogic
    and or implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_non :
¬ ¬ P ↔ P
:=
/- dEAduction
PrettyName
    Double négation
Description
    Le bouton "NON" permet d'utiliser les règles logiques du "NON".
    On peut l'utiliser uniquement sur les propriétés qui sont des négations,
    c'est-à-dire de la forme "NON (...)".
AvailableLogic
    and or not implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_ET :
¬ (P ∧ Q) ↔ (¬ P) ∨ (¬ Q)
:=
/- dEAduction
PrettyName
    Négation d'un "ET"
Description
    En général, le bouton "NON" tente de "pousser" la négation le long de la
    propriété.
AvailableLogic
    and or not implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.contradiction :
R ∨ ¬ R
:=
/- dEAduction
PrettyName
    Le tiers exclu : l'une des deux propriétés "R" et "NON R" est vraie
Description
    Le mécanisme de preuve inclus le tiers exclu, de façon un peu cachée...
AvailableLogic
    and or not implies iff
AvailableProof
    proof_methods
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.contraposition :
(P → Q) ↔ (¬ Q → ¬ P)
:=
/- dEAduction
PrettyName
    Contraposition
Description
    Le bouton "=>" permet également d'appliquer une implication "P => Q" à la
    propriété "P" pour obtenir la propriété "Q". Attention, avant de
    l'actionner il faut sélectionner toutes les propriétés requises !
AvailableLogic
    and or not implies iff
AvailableProof
    proof_methods
AvailableMagic
    assumption

-/
begin
    sorry
end

lemma exercise.ou_implication_I :
(P → Q) ↔ (¬ P ∨ Q)
:=
/- dEAduction
PrettyName
    Implication sous forme de "OU"
Description
    Cette propriété permet de transformer une implication en une disjonction
AvailableLogic
    and or not implies iff
AvailableProof
    use_proof_methods
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_implication_II :
(P ∨ Q) ↔ (¬ P → Q)
:=
/- dEAduction
PrettyName
    "OU" sous forme d'implication
Description
    Cette propriété est très proche de la précédente.
    On peut la redémontrer entièrement, mais on peut aussi tenter d'appliquer
    le résultat de l'exercice précédent. Pour cela, il faudra introduire
    un nouvel objet, avant de lui appliquer le résultat précédent...
AvailableLogic
    and or not implies iff
AvailableProof
    use_proof_methods new_object
AvailableMagic
    assumption
-/
begin
    sorry
end

end Logique_propositionnelle

end course


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