import tactic
import .tokens
import .commun

setup_tactic_parser

namespace tactic

meta def intro_obj (n : name) : tactic expr :=
do t ← target,
   if expr.is_pi t ∨ expr.is_let t then do
     e ← intro_core n,
     t ← infer_type e,
     mwhen (is_prop t) failed,
     pure e
   else do
     whnf_target,
     e ← intro_core n,
     t ← infer_type e,
     mwhen (is_prop t) failed,
     pure e

meta def Soit1 : introduced → tactic unit
| (introduced.typed n t)   := do verifie_nom n,
                                 et ← to_expr t,
                                 e ← intro_obj n <|> fail "Il n'y a pas d'objet à introduire ici.",
                                 change_core et e
| (introduced.bare n)      := do verifie_nom n,
                                 intro_obj n <|> fail "Il n'y a pas d'objet à introduire ici.",
                                 skip
| (introduced.related n rel e) := do verifie_nom n,
                                 ename ← intro_obj n <|> fail "Il n'y a pas d'objet à introduire ici.",
                                 n_type ← infer_type ename,
                                 E ← match rel with
                                 | intro_rel.mem := to_expr e
                                 | _ := to_expr ```(%%e : %%n_type)
                                 end,
                                 rel_expr ← match rel with
                                 | intro_rel.lt := to_expr ``(%%ename < %%E)
                                 | intro_rel.gt := to_expr ``(%%ename > %%E)
                                 | intro_rel.le := to_expr ``(%%ename ≤ %%E)
                                 | intro_rel.ge := to_expr ``(%%ename ≥ %%E)
                                 | intro_rel.mem := to_expr ``(%%ename ∈ %%E)
                                 end,
                                 let hyp_name := if e = ``(0) then
                                    match rel with
                                    | intro_rel.lt  := n.to_string ++ "_neg"
                                    | intro_rel.gt  := n.to_string ++ "_pos"
                                    | intro_rel.le  := n.to_string ++ "_neg"
                                    | intro_rel.ge  := n.to_string ++ "_pos"
                                    | intro_rel.mem := "h_" ++ n.to_string -- ne devrait pas arriver
                                    end
                                 else
                                    match rel with
                                    | intro_rel.lt  := n.to_string ++ "_lt"
                                    | intro_rel.gt  := n.to_string ++ "_gt"
                                    | intro_rel.le  := n.to_string ++ "_le"
                                    | intro_rel.ge  := n.to_string ++ "_ge"
                                    | intro_rel.mem := n.to_string ++ "_mem"
                                    end,
                                 EH ← intro hyp_name,
                                 change_core rel_expr EH,
                                 skip

/-- Introduit un objet ou plusieurs objets pour démontrer un énoncé commençant par un quantificateur universel. -/
@[interactive]
meta def Soit (vs : parse $ with_desc "..." bracketed_intro_parser*) : tactic unit :=
vs.mmap' Soit1

end tactic

example : ∀ n > 0, ∀ k : ℕ, ∀ l ∈ (set.univ : set ℕ), true :=
begin
  Soit (n > 0) k (l ∈ set.univ),
  trivial
end

example : ∀ n > 0, ∀ k : ℕ, ∀ l ∈ (set.univ : set ℕ), true :=
begin
  Soit n,
  success_if_fail { Soit h },
  intro hn,
  Soit k (l ∈ set.univ),
  trivial
end

example : ∀ n > 0, ∀ k : ℕ, true :=
begin
  Soit (n > 0),
  success_if_fail { Soit n },
  Soit k,
  trivial
end

example : ∀ n > 0, ∀ k : ℕ, true :=
begin
  Soit n > 0,
  success_if_fail { Soit n },
  Soit k,
  trivial
end

example (k l : ℕ) : ∀ n ≤ k + l, true :=
begin
  Soit n ≤ k + l,
  trivial,
end

example (A : set ℕ) : ∀ n ∈ A, true :=
begin
  Soit n ∈ A,
  trivial
end


import hmem.stack
import complexity.basic

variables {μ: Type*} [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)]

namespace hmem
namespace encoding

instance: has_equiv (memory μ) := ⟨ eq ⟩

def push_arg (lhs rhs: memory μ): memory μ :=
  (((memory.null μ).setv 1).setm 0 lhs).setm 1 rhs

def build_arg: list (memory μ) → memory μ
| [] := memory.null _
| [m] := m
| (x::xs) := push_arg (build_arg xs) x

def runtime_model (μ: Type*) [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)]: complexity.model (program μ × list (memory μ)) (memory μ) ℕ :=
 ⟨  λ p_a r c, p_a.fst.has_result (build_arg p_a.snd) r ∧ p_a.fst.has_time_cost (build_arg p_a.snd) c,
    λ p_a a', (p_a.fst, a'::p_a.snd),
    λ _ _ _ _ _ hrc₁ hrc₂, program.unique_result hrc₁.left hrc₂.left,
    λ _ _ _ _ hc hrc₀, ⟨hrc₀.left, program.time_cost_mono hrc₀.right hc⟩ ⟩

def encode {δ: Type} [complexity.has_encoding (runtime_model μ) δ]: δ → memory μ := complexity.encode (runtime_model μ)

instance (α β: Type*)  [α_en: complexity.has_encoding (runtime_model μ) α] [β_en: complexity.has_encoding (runtime_model μ) β]:
  complexity.has_encoding (runtime_model μ) (α × β) :=
begin
  fconstructor,
  fconstructor,
  exact λ ab, push_arg (encode ab.fst) (encode ab.snd),
  intros x y,
  cases x,
  cases y,
  simp [push_arg, has_equiv.equiv, encode],
  split,
  { intro h,
    split,
    { rw ← complexity.encoding.encode_inj α_en.value,
      apply memory.getm_congr 0 h,
      { rw [memory.getm_setm_ne _ _ _ _ zero_ne_one, memory.getm_setm],
        refl,
        apply_instance},
      { rw [memory.getm_setm_ne _ _ _ _ zero_ne_one, memory.getm_setm],
        refl,
        apply_instance} },
    { rw ← complexity.encoding.encode_inj β_en.value,
      apply memory.getm_congr 1 h,
      { rw [memory.getm_setm],
        refl },
      { rw [memory.getm_setm],
        refl } } },
  { intro h,
    rw [h.left, h.right] }
end

theorem encode_pair  {α β: Type*}  [α_en: complexity.has_encoding (runtime_model μ) α] [β_en: complexity.has_encoding (runtime_model μ) β] (a: α) (b: β):
  encode (a, b) = (((memory.null μ).setv 1).setm 0 (encode a)).setm 1 (encode b) := rfl

instance (p: Prop):
  complexity.has_encoding (runtime_model μ) (decidable p) :=
begin
  fconstructor,
  fconstructor,
  exact λ d,  (memory.null _).setv (d.cases_on (λ _, 0) (λ _, 1)),
  intros x y,
  cases x;
  cases y;
  simp [has_equiv.equiv, memory.setv_inj_iff],
end

theorem encode_is_false {p: Prop} {hp: ¬ p} (d: decidable p):
  (encode (is_false hp)) = memory.null μ := memory.null_setv_zero

theorem encode_is_true {p: Prop} {hp: p} (d: decidable p):
  (encode (is_true hp)) = (memory.null μ).setv 1 := rfl

end encoding
end hmem


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.eq_to_hom

/-!
# Binary disjoint unions of categories

We define the category instance on `C ⊕ D` when `C` and `D` are categories.

We define:
* `inl_`      : the functor `C ⥤ C ⊕ D`
* `inr_`      : the functor `D ⥤ C ⊕ D`
* `swap`      : the functor `C ⊕ D ⥤ D ⊕ C`
    (and the fact this is an equivalence)

We further define sums of functors and natural transformations, written `F.sum G` and `α.sum β`.
-/

namespace category_theory

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

open sum

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]

/--
`sum C D` gives the direct sum of two categories.
-/
instance sum : category.{v₁} (C ⊕ D) :=
{ hom :=
    λ X Y, match X, Y with
    | inl X, inl Y := X ⟶ Y
    | inl X, inr Y := pempty
    | inr X, inl Y := pempty
    | inr X, inr Y := X ⟶ Y
    end,
  id :=
    λ X, match X with
    | inl X := 𝟙 X
    | inr X := 𝟙 X
    end,
  comp :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := f ≫ g
    | inr X, inr Y, inr Z, f, g := f ≫ g
    end }

@[simp] lemma sum_comp_inl {P Q R : C} (f : (inl P : C ⊕ D) ⟶ inl Q)
  (g : (inl Q : C ⊕ D) ⟶ inl R) :
  @category_struct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
  @category_struct.comp _ _ (inl P) (inl Q) (inl R) (f : P ⟶ Q) (g : Q ⟶ R) := rfl
@[simp] lemma sum_comp_inr {P Q R : D} (f : (inr P : C ⊕ D) ⟶ inr Q)
  (g : (inr Q : C ⊕ D) ⟶ inr R) :
  @category_struct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
  @category_struct.comp _ _ (inr P) (inr Q) (inr R) (f : P ⟶ Q) (g : Q ⟶ R) := rfl
end

namespace sum

variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]

/-- `inl_` is the functor `X ↦ inl X`. -/
-- Unfortunate naming here, suggestions welcome.
@[simps] def inl_ : C ⥤ C ⊕ D :=
{ obj := λ X, inl X,
  map := λ X Y f, f }

/-- `inr_` is the functor `X ↦ inr X`. -/
@[simps] def inr_ : D ⥤ C ⊕ D :=
{ obj := λ X, inr X,
  map := λ X Y f, f }

/-- The functor exchanging two direct summand categories. -/
def swap : C ⊕ D ⥤ D ⊕ C :=
{ obj :=
    λ X, match X with
    | inl X := inr X
    | inr X := inl X
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := f
    | inr X, inr Y, f := f
    end }

@[simp] lemma swap_obj_inl (X : C) : (swap C D).obj (inl X) = inr X := rfl
@[simp] lemma swap_obj_inr (X : D) : (swap C D).obj (inr X) = inl X := rfl
@[simp] lemma swap_map_inl {X Y : C} {f : inl X ⟶ inl Y} : (swap C D).map f = f := rfl
@[simp]

namespace swap

/-- `swap` gives an equivalence between `C ⊕ D` and `D ⊕ C`. -/
def equivalence : C ⊕ D ≌ D ⊕ C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))

instance is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (equivalence C D).functor)

/-- The double swap on `C ⊕ D` is naturally isomorphic to the identity functor. -/
def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C ⊕ D) :=
(equivalence C D).unit_iso.symm

end swap

end sum

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₁} [category.{v₁} B]
          {C : Type u₁} [category.{v₁} C]
          {D : Type u₁} [category.{v₁} D]

namespace functor

/-- The sum of two functors. -/
def sum (F : A ⥤ B) (G : C ⥤ D) : A ⊕ C ⥤ B ⊕ D :=
{ obj :=
    λ X, match X with
    | inl X := inl (F.obj X)
    | inr X := inr (G.obj X)
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := F.map f
    | inr X, inr Y, f := G.map f
    end,
  map_id' := λ X, begin cases X; unfold_aux, erw F.map_id, refl, erw G.map_id, refl end,
  map_comp' :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := by { unfold_aux, erw F.map_comp, refl }
    | inr X, inr Y, inr Z, f, g := by { unfold_aux, erw G.map_comp, refl }
    end }

@[simp] lemma sum_obj_inl (F : A ⥤ B) (G : C ⥤ D) (a : A) :
  (F.sum G).obj (inl a) = inl (F.obj a) := rfl
@[simp] lemma sum_obj_inr (F : A ⥤ B) (G : C ⥤ D) (c : C) :
  (F.sum G).obj (inr c) = inr (G.obj c) := rfl
@[simp] lemma sum_map_inl (F : A ⥤ B) (G : C ⥤ D) {a a' : A} (f : inl a ⟶ inl a') :
  (F.sum G).map f = F.map f := rfl
@[simp] lemma sum_map_inr (F : A ⥤ B) (G : C ⥤ D) {c c' : C} (f : inr c ⟶ inr c') :
  (F.sum G).map f = G.map f := rfl
end functor

namespace nat_trans

/-- The sum of two natural transformations. -/
def sum {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) : F.sum H ⟶ G.sum I :=
{ app         :=
    λ X, match X with
    | inl X := α.app X
    | inr X := β.app X
    end,
  naturality' :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := begin unfold_aux, erw α.naturality, refl, end
    | inr X, inr Y, f := begin unfold_aux, erw β.naturality, refl, end
    end }

@[simp] lemma sum_app_inl {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (a : A) :
  (sum α β).app (inl a) = α.app a := rfl
@[simp] lemma sum_app_inr {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (c : C) :
  (sum α β).app (inr c) = β.app c := rfl
end nat_trans

end category_theory


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.num.bitwise
import Mathlib.data.int.char_zero
import Mathlib.data.nat.gcd
import Mathlib.data.nat.psub
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Properties of the binary representation of integers
-/

namespace pos_num

@[simp] theorem cast_one {α : Type u_1} [HasOne α] [Add α] : ↑1 = 1 := rfl

@[simp] theorem cast_one' {α : Type u_1} [HasOne α] [Add α] : ↑one = 1 := rfl

@[simp] theorem cast_bit0 {α : Type u_1} [HasOne α] [Add α] (n : pos_num) : ↑(bit0 n) = bit0 ↑n :=
  rfl

@[simp] theorem cast_bit1 {α : Type u_1} [HasOne α] [Add α] (n : pos_num) : ↑(bit1 n) = bit1 ↑n :=
  rfl

@[simp] theorem cast_to_nat {α : Type u_1} [add_monoid α] [HasOne α] (n : pos_num) : ↑↑n = ↑n :=
  sorry

@[simp] theorem to_nat_to_int (n : pos_num) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (int.nat_cast_eq_coe_nat ↑n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (cast_to_nat n))) (Eq.refl ↑n))

@[simp] theorem cast_to_int {α : Type u_1} [add_group α] [HasOne α] (n : pos_num) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (to_nat_to_int n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑↑n = ↑n)) (int.cast_coe_nat ↑n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (cast_to_nat n))) (Eq.refl ↑n)))

theorem succ_to_nat (n : pos_num) : ↑(succ n) = ↑n + 1 := sorry

theorem one_add (n : pos_num) : 1 + n = succ n :=
  pos_num.cases_on n (Eq.refl (1 + one)) (fun (n : pos_num) => Eq.refl (1 + bit1 n))
    fun (n : pos_num) => Eq.refl (1 + bit0 n)

theorem add_one (n : pos_num) : n + 1 = succ n :=
  pos_num.cases_on n (Eq.refl (one + 1)) (fun (n : pos_num) => Eq.refl (bit1 n + 1))
    fun (n : pos_num) => Eq.refl (bit0 n + 1)

theorem add_to_nat (m : pos_num) (n : pos_num) : ↑(m + n) = ↑m + ↑n := sorry

theorem add_succ (m : pos_num) (n : pos_num) : m + succ n = succ (m + n) := sorry

theorem bit0_of_bit0 (n : pos_num) : bit0 n = bit0 n := sorry

theorem bit1_of_bit1 (n : pos_num) : bit1 n = bit1 n :=
  (fun (this : bit0 n + 1 = bit1 n) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (bit0 n + 1 = bit1 n)) (add_one (bit0 n))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (succ (bit0 n) = bit1 n)) (bit0_of_bit0 n)))
        (Eq.refl (succ (bit0 n)))))

theorem mul_to_nat (m : pos_num) (n : pos_num) : ↑(m * n) = ↑m * ↑n := sorry

theorem to_nat_pos (n : pos_num) : 0 < ↑n := sorry

theorem cmp_to_nat_lemma {m : pos_num} {n : pos_num} : ↑m < ↑n → ↑(bit1 m) < ↑(bit0 n) := sorry

theorem cmp_swap (m : pos_num) (n : pos_num) : ordering.swap (cmp m n) = cmp n m := sorry

theorem cmp_to_nat (m : pos_num) (n : pos_num) :
    ordering.cases_on (cmp m n) (↑m < ↑n) (m = n) (↑n < ↑m) :=
  sorry

theorem lt_to_nat {m : pos_num} {n : pos_num} : ↑m < ↑n ↔ m < n := sorry

theorem le_to_nat {m : pos_num} {n : pos_num} : ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr lt_to_nat)

end pos_num

namespace num

theorem add_zero (n : num) : n + 0 = n :=
  num.cases_on n (Eq.refl (zero + 0)) fun (n : pos_num) => Eq.refl (pos n + 0)

theorem zero_add (n : num) : 0 + n = n :=
  num.cases_on n (Eq.refl (0 + zero)) fun (n : pos_num) => Eq.refl (0 + pos n)

theorem add_one (n : num) : n + 1 = succ n := sorry

theorem add_succ (m : num) (n : num) : m + succ n = succ (m + n) := sorry

@[simp] theorem add_of_nat (m : ℕ) (n : ℕ) : ↑(m + n) = ↑m + ↑n := sorry

theorem bit0_of_bit0 (n : num) : bit0 n = num.bit0 n :=
  num.cases_on n (idRhs (bit0 0 = bit0 0) rfl)
    fun (n : pos_num) =>
      idRhs (pos (bit0 n) = pos (pos_num.bit0 n)) (congr_arg pos (pos_num.bit0_of_bit0 n))

theorem bit1_of_bit1 (n : num) : bit1 n = num.bit1 n :=
  num.cases_on n (idRhs (bit1 0 = bit1 0) rfl)
    fun (n : pos_num) =>
      idRhs (pos (bit1 n) = pos (pos_num.bit1 n)) (congr_arg pos (pos_num.bit1_of_bit1 n))

@[simp] theorem cast_zero {α : Type u_1} [HasZero α] [HasOne α] [Add α] : ↑0 = 0 := rfl

@[simp] theorem cast_zero' {α : Type u_1} [HasZero α] [HasOne α] [Add α] : ↑zero = 0 := rfl

@[simp] theorem cast_one {α : Type u_1} [HasZero α] [HasOne α] [Add α] : ↑1 = 1 := rfl

@[simp] theorem cast_pos {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : pos_num) :
    ↑(pos n) = ↑n :=
  rfl

theorem succ'_to_nat (n : num) : ↑(succ' n) = ↑n + 1 :=
  num.cases_on n (idRhs (↑(succ' 0) = 0 + ↑(succ' 0)) (Eq.symm (zero_add ↑(succ' 0))))
    fun (n : pos_num) => idRhs (↑(pos_num.succ n) = ↑n + 1) (pos_num.succ_to_nat n)

theorem succ_to_nat (n : num) : ↑(succ n) = ↑n + 1 := succ'_to_nat n

@[simp] theorem cast_to_nat {α : Type u_1} [add_monoid α] [HasOne α] (n : num) : ↑↑n = ↑n :=
  num.cases_on n (idRhs (↑0 = 0) nat.cast_zero)
    fun (n : pos_num) => idRhs (↑↑n = ↑n) (pos_num.cast_to_nat n)

@[simp] theorem to_nat_to_int (n : num) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (int.nat_cast_eq_coe_nat ↑n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (cast_to_nat n))) (Eq.refl ↑n))

@[simp] theorem cast_to_int {α : Type u_1} [add_group α] [HasOne α] (n : num) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (to_nat_to_int n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑↑n = ↑n)) (int.cast_coe_nat ↑n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (cast_to_nat n))) (Eq.refl ↑n)))

theorem to_of_nat (n : ℕ) : ↑↑n = n := sorry

@[simp] theorem of_nat_cast {α : Type u_1} [add_monoid α] [HasOne α] (n : ℕ) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (cast_to_nat ↑n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑↑n = ↑n)) (to_of_nat n))) (Eq.refl ↑n))

theorem of_nat_inj {m : ℕ} {n : ℕ} : ↑m = ↑n ↔ m = n :=
  { mp := fun (h : ↑m = ↑n) => function.left_inverse.injective to_of_nat h,
    mpr := congr_arg fun (x : ℕ) => ↑x }

theorem add_to_nat (m : num) (n : num) : ↑(m + n) = ↑m + ↑n := sorry

theorem mul_to_nat (m : num) (n : num) : ↑(m * n) = ↑m * ↑n := sorry

theorem cmp_to_nat (m : num) (n : num) : ordering.cases_on (cmp m n) (↑m < ↑n) (m = n) (↑n < ↑m) :=
  sorry

theorem lt_to_nat {m : num} {n : num} : ↑m < ↑n ↔ m < n := sorry

theorem le_to_nat {m : num} {n : num} : ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr lt_to_nat)

end num

namespace pos_num

@[simp] theorem of_to_nat (n : pos_num) : ↑↑n = num.pos n := sorry

end pos_num

namespace num

@[simp] theorem of_to_nat (n : num) : ↑↑n = n :=
  num.cases_on n (idRhs (↑↑0 = ↑↑0) rfl)
    fun (n : pos_num) => idRhs (↑↑n = pos n) (pos_num.of_to_nat n)

theorem to_nat_inj {m : num} {n : num} : ↑m = ↑n ↔ m = n :=
  { mp := fun (h : ↑m = ↑n) => function.left_inverse.injective of_to_nat h,
    mpr := congr_arg fun (x : num) => ↑x }

/--
This tactic tries to turn an (in)equality about `num`s to one about `nat`s by rewriting.
```lean
example (n : num) (m : num) : n ≤ n + m :=
begin
  num.transfer_rw,
  exact nat.le_add_right _ _
end
```
-/
/--
This tactic tries to prove (in)equalities about `num`s by transfering them to the `nat` world and
then trying to call `simp`.
```lean
example (n : num) (m : num) : n ≤ n + m := by num.transfer
```
-/
protected instance comm_semiring : comm_semiring num :=
  comm_semiring.mk Add.add sorry 0 zero_add add_zero sorry Mul.mul sorry 1 sorry sorry sorry sorry
    sorry sorry sorry

protected instance ordered_cancel_add_comm_monoid : ordered_cancel_add_comm_monoid num :=
  ordered_cancel_add_comm_monoid.mk comm_semiring.add comm_semiring.add_assoc sorry
    comm_semiring.zero comm_semiring.zero_add comm_semiring.add_zero comm_semiring.add_comm sorry
    LessEq Less sorry sorry sorry sorry sorry

protected instance linear_ordered_semiring : linear_ordered_semiring num :=
  linear_ordered_semiring.mk comm_semiring.add comm_semiring.add_assoc comm_semiring.zero
    comm_semiring.zero_add comm_semiring.add_zero comm_semiring.add_comm comm_semiring.mul
    comm_semiring.mul_assoc comm_semiring.one comm_semiring.one_mul comm_semiring.mul_one
    comm_semiring.zero_mul comm_semiring.mul_zero comm_semiring.left_distrib
    comm_semiring.right_distrib ordered_cancel_add_comm_monoid.add_left_cancel
    ordered_cancel_add_comm_monoid.add_right_cancel ordered_cancel_add_comm_monoid.le
    ordered_cancel_add_comm_monoid.lt ordered_cancel_add_comm_monoid.le_refl
    ordered_cancel_add_comm_monoid.le_trans ordered_cancel_add_comm_monoid.le_antisymm
    ordered_cancel_add_comm_monoid.add_le_add_left
    ordered_cancel_add_comm_monoid.le_of_add_le_add_left sorry sorry sorry sorry num.decidable_le
    num.decidable_eq num.decidable_lt sorry

theorem dvd_to_nat (m : num) (n : num) : ↑m ∣ ↑n ↔ m ∣ n := sorry

end num

namespace pos_num

theorem to_nat_inj {m : pos_num} {n : pos_num} : ↑m = ↑n ↔ m = n := sorry

theorem pred'_to_nat (n : pos_num) : ↑(pred' n) = Nat.pred ↑n := sorry

@[simp] theorem pred'_succ' (n : num) : pred' (num.succ' n) = n := sorry

@[simp] theorem succ'_pred' (n : pos_num) : num.succ' (pred' n) = n := sorry

protected instance has_dvd : has_dvd pos_num :=
  has_dvd.mk fun (m n : pos_num) => num.pos m ∣ num.pos n

theorem dvd_to_nat {m : pos_num} {n : pos_num} : ↑m ∣ ↑n ↔ m ∣ n :=
  num.dvd_to_nat (num.pos m) (num.pos n)

theorem size_to_nat (n : pos_num) : ↑(size n) = nat.size ↑n := sorry

theorem size_eq_nat_size (n : pos_num) : ↑(size n) = nat_size n := sorry

theorem nat_size_to_nat (n : pos_num) : nat_size n = nat.size ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_size n = nat.size ↑n)) (Eq.symm (size_eq_nat_size n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(size n) = nat.size ↑n)) (size_to_nat n)))
      (Eq.refl (nat.size ↑n)))

theorem nat_size_pos (n : pos_num) : 0 < nat_size n :=
  pos_num.cases_on n (nat.succ_pos 0) (fun (n : pos_num) => nat.succ_pos (nat_size n))
    fun (n : pos_num) => nat.succ_pos (nat_size n)

/--
This tactic tries to turn an (in)equality about `pos_num`s to one about `nat`s by rewriting.
```lean
example (n : pos_num) (m : pos_num) : n ≤ n + m :=
begin
  pos_num.transfer_rw,
  exact nat.le_add_right _ _
end
```
-/
/--
This tactic tries to prove (in)equalities about `pos_num`s by transferring them to the `nat` world
and then trying to call `simp`.
```lean
example (n : pos_num) (m : pos_num) : n ≤ n + m := by pos_num.transfer
```
-/
protected instance add_comm_semigroup : add_comm_semigroup pos_num :=
  add_comm_semigroup.mk Add.add sorry sorry

protected instance comm_monoid : comm_monoid pos_num :=
  comm_monoid.mk Mul.mul sorry 1 sorry sorry sorry

protected instance distrib : distrib pos_num := distrib.mk Mul.mul Add.add sorry sorry

protected instance linear_order : linear_order pos_num :=
  linear_order.mk LessEq Less sorry sorry sorry sorry
    (fun (a b : pos_num) => pos_num.decidable_le a b)
    (fun (a b : pos_num) => pos_num.decidable_eq a b)
    fun (a b : pos_num) => pos_num.decidable_lt a b

@[simp] theorem cast_to_num (n : pos_num) : ↑n = num.pos n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = num.pos n)) (Eq.symm (cast_to_nat n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = num.pos n)) (Eq.symm (of_to_nat n)))) (Eq.refl ↑↑n))

@[simp] theorem bit_to_nat (b : Bool) (n : pos_num) : ↑(bit b n) = nat.bit b ↑n :=
  bool.cases_on b (Eq.refl ↑(bit false n)) (Eq.refl ↑(bit tt n))

@[simp] theorem cast_add {α : Type u_1} [add_monoid α] [HasOne α] (m : pos_num) (n : pos_num) :
    ↑(m + n) = ↑m + ↑n :=
  sorry

@[simp] theorem cast_succ {α : Type u_1} [add_monoid α] [HasOne α] (n : pos_num) :
    ↑(succ n) = ↑n + 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(succ n) = ↑n + 1)) (Eq.symm (add_one n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(n + 1) = ↑n + 1)) (cast_add n 1)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑n + ↑1 = ↑n + 1)) cast_one)) (Eq.refl (↑n + 1))))

@[simp] theorem cast_inj {α : Type u_1} [add_monoid α] [HasOne α] [char_zero α] {m : pos_num}
    {n : pos_num} : ↑m = ↑n ↔ m = n :=
  sorry

@[simp] theorem one_le_cast {α : Type u_1} [linear_ordered_semiring α] (n : pos_num) : 1 ≤ ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ ↑n)) (Eq.symm (cast_to_nat n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ ↑↑n)) (Eq.symm nat.cast_one)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑1 ≤ ↑↑n)) (propext nat.cast_le))) (to_nat_pos n)))

@[simp] theorem cast_pos {α : Type u_1} [linear_ordered_semiring α] (n : pos_num) : 0 < ↑n :=
  lt_of_lt_of_le zero_lt_one (one_le_cast n)

@[simp] theorem cast_mul {α : Type u_1} [semiring α] (m : pos_num) (n : pos_num) :
    ↑(m * n) = ↑m * ↑n :=
  sorry

@[simp] theorem cmp_eq (m : pos_num) (n : pos_num) : cmp m n = ordering.eq ↔ m = n := sorry

@[simp] theorem cast_lt {α : Type u_1} [linear_ordered_semiring α] {m : pos_num} {n : pos_num} :
    ↑m < ↑n ↔ m < n :=
  sorry

@[simp] theorem cast_le {α : Type u_1} [linear_ordered_semiring α] {m : pos_num} {n : pos_num} :
    ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr cast_lt)

end pos_num

namespace num

theorem bit_to_nat (b : Bool) (n : num) : ↑(bit b n) = nat.bit b ↑n :=
  bool.cases_on b
    (num.cases_on n (Eq.refl ↑(bit false zero)) fun (n : pos_num) => Eq.refl ↑(bit false (pos n)))
    (num.cases_on n (Eq.refl ↑(bit tt zero)) fun (n : pos_num) => Eq.refl ↑(bit tt (pos n)))

theorem cast_succ' {α : Type u_1} [add_monoid α] [HasOne α] (n : num) : ↑(succ' n) = ↑n + 1 := sorry

theorem cast_succ {α : Type u_1} [add_monoid α] [HasOne α] (n : num) : ↑(succ n) = ↑n + 1 :=
  cast_succ' n

@[simp] theorem cast_add {α : Type u_1} [semiring α] (m : num) (n : num) : ↑(m + n) = ↑m + ↑n :=
  sorry

@[simp] theorem cast_bit0 {α : Type u_1} [semiring α] (n : num) : ↑(num.bit0 n) = bit0 ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(num.bit0 n) = bit0 ↑n)) (Eq.symm (bit0_of_bit0 n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(bit0 n) = bit0 ↑n)) (bit0.equations._eqn_1 n)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑(n + n) = bit0 ↑n)) (cast_add n n))) (Eq.refl (↑n + ↑n))))

@[simp] theorem cast_bit1 {α : Type u_1} [semiring α] (n : num) : ↑(num.bit1 n) = bit1 ↑n := sorry

@[simp] theorem cast_mul {α : Type u_1} [semiring α] (m : num) (n : num) : ↑(m * n) = ↑m * ↑n :=
  sorry

theorem size_to_nat (n : num) : ↑(size n) = nat.size ↑n :=
  num.cases_on n (idRhs (0 = nat.size 0) (Eq.symm nat.size_zero))
    fun (n : pos_num) => idRhs (↑(pos_num.size n) = nat.size ↑n) (pos_num.size_to_nat n)

theorem size_eq_nat_size (n : num) : ↑(size n) = nat_size n :=
  num.cases_on n (idRhs (↑(size 0) = ↑(size 0)) rfl)
    fun (n : pos_num) => idRhs (↑(pos_num.size n) = pos_num.nat_size n) (pos_num.size_eq_nat_size n)

theorem nat_size_to_nat (n : num) : nat_size n = nat.size ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_size n = nat.size ↑n)) (Eq.symm (size_eq_nat_size n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(size n) = nat.size ↑n)) (size_to_nat n)))
      (Eq.refl (nat.size ↑n)))

@[simp] theorem of_nat'_eq (n : ℕ) : of_nat' n = ↑n := sorry

theorem zneg_to_znum (n : num) : -to_znum n = to_znum_neg n :=
  num.cases_on n (Eq.refl (-to_znum zero)) fun (n : pos_num) => Eq.refl (-to_znum (pos n))

theorem zneg_to_znum_neg (n : num) : -to_znum_neg n = to_znum n :=
  num.cases_on n (Eq.refl (-to_znum_neg zero)) fun (n : pos_num) => Eq.refl (-to_znum_neg (pos n))

theorem to_znum_inj {m : num} {n : num} : to_znum m = to_znum n ↔ m = n := sorry

@[simp] theorem cast_to_znum {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : num) :
    ↑(to_znum n) = ↑n :=
  num.cases_on n (idRhs (↑(to_znum 0) = ↑(to_znum 0)) rfl)
    fun (n : pos_num) => idRhs (↑(to_znum (pos n)) = ↑(to_znum (pos n))) rfl

@[simp] theorem cast_to_znum_neg {α : Type u_1} [add_group α] [HasOne α] (n : num) :
    ↑(to_znum_neg n) = -↑n :=
  num.cases_on n (idRhs (0 = -0) (Eq.symm neg_zero))
    fun (n : pos_num) => idRhs (↑(to_znum_neg (pos n)) = ↑(to_znum_neg (pos n))) rfl

@[simp] theorem add_to_znum (m : num) (n : num) : to_znum (m + n) = to_znum m + to_znum n :=
  num.cases_on m
    (num.cases_on n (Eq.refl (to_znum (zero + zero)))
      fun (n : pos_num) => Eq.refl (to_znum (zero + pos n)))
    fun (m : pos_num) =>
      num.cases_on n (Eq.refl (to_znum (pos m + zero)))
        fun (n : pos_num) => Eq.refl (to_znum (pos m + pos n))

end num

namespace pos_num

theorem pred_to_nat {n : pos_num} (h : 1 < n) : ↑(pred n) = Nat.pred ↑n := sorry

theorem sub'_one (a : pos_num) : sub' a 1 = num.to_znum (pred' a) :=
  pos_num.cases_on a (Eq.refl (sub' one 1)) (fun (a : pos_num) => Eq.refl (sub' (bit1 a) 1))
    fun (a : pos_num) => Eq.refl (sub' (bit0 a) 1)

theorem one_sub' (a : pos_num) : sub' 1 a = num.to_znum_neg (pred' a) :=
  pos_num.cases_on a (Eq.refl (sub' 1 one)) (fun (a : pos_num) => Eq.refl (sub' 1 (bit1 a)))
    fun (a : pos_num) => Eq.refl (sub' 1 (bit0 a))

theorem lt_iff_cmp {m : pos_num} {n : pos_num} : m < n ↔ cmp m n = ordering.lt := iff.rfl

theorem le_iff_cmp {m : pos_num} {n : pos_num} : m ≤ n ↔ cmp m n ≠ ordering.gt := sorry

end pos_num

namespace num

theorem pred_to_nat (n : num) : ↑(pred n) = Nat.pred ↑n := sorry

theorem ppred_to_nat (n : num) : coe <$> ppred n = nat.ppred ↑n := sorry

theorem cmp_swap (m : num) (n : num) : ordering.swap (cmp m n) = cmp n m := sorry

theorem cmp_eq (m : num) (n : num) : cmp m n = ordering.eq ↔ m = n := sorry

@[simp] theorem cast_lt {α : Type u_1} [linear_ordered_semiring α] {m : num} {n : num} :
    ↑m < ↑n ↔ m < n :=
  sorry

@[simp] theorem cast_le {α : Type u_1} [linear_ordered_semiring α] {m : num} {n : num} :
    ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr cast_lt)

@[simp] theorem cast_inj {α : Type u_1} [linear_ordered_semiring α] {m : num} {n : num} :
    ↑m = ↑n ↔ m = n :=
  sorry

theorem lt_iff_cmp {m : num} {n : num} : m < n ↔ cmp m n = ordering.lt := iff.rfl

theorem le_iff_cmp {m : num} {n : num} : m ≤ n ↔ cmp m n ≠ ordering.gt := sorry

theorem bitwise_to_nat {f : num → num → num} {g : Bool → Bool → Bool} (p : pos_num → pos_num → num)
    (gff : g false false = false) (f00 : f 0 0 = 0)
    (f0n : ∀ (n : pos_num), f 0 (pos n) = cond (g false tt) (pos n) 0)
    (fn0 : ∀ (n : pos_num), f (pos n) 0 = cond (g tt false) (pos n) 0)
    (fnn : ∀ (m n : pos_num), f (pos m) (pos n) = p m n) (p11 : p 1 1 = cond (g tt tt) 1 0)
    (p1b :
      ∀ (b : Bool) (n : pos_num),
        p 1 (pos_num.bit b n) = bit (g tt b) (cond (g false tt) (pos n) 0))
    (pb1 :
      ∀ (a : Bool) (m : pos_num),
        p (pos_num.bit a m) 1 = bit (g a tt) (cond (g tt false) (pos m) 0))
    (pbb :
      ∀ (a b : Bool) (m n : pos_num), p (pos_num.bit a m) (pos_num.bit b n) = bit (g a b) (p m n))
    (m : num) (n : num) : ↑(f m n) = nat.bitwise g ↑m ↑n :=
  sorry

@[simp] theorem lor_to_nat (m : num) (n : num) : ↑(lor m n) = nat.lor ↑m ↑n := sorry

@[simp] theorem land_to_nat (m : num) (n : num) : ↑(land m n) = nat.land ↑m ↑n := sorry

@[simp] theorem ldiff_to_nat (m : num) (n : num) : ↑(ldiff m n) = nat.ldiff ↑m ↑n := sorry

@[simp] theorem lxor_to_nat (m : num) (n : num) : ↑(lxor m n) = nat.lxor ↑m ↑n := sorry

@[simp] theorem shiftl_to_nat (m : num) (n : ℕ) : ↑(shiftl m n) = nat.shiftl (↑m) n := sorry

@[simp] theorem shiftr_to_nat (m : num) (n : ℕ) : ↑(shiftr m n) = nat.shiftr (↑m) n := sorry

@[simp] theorem test_bit_to_nat (m : num) (n : ℕ) : test_bit m n = nat.test_bit (↑m) n := sorry

end num

namespace znum

@[simp] theorem cast_zero {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : ↑0 = 0 := rfl

@[simp] theorem cast_zero' {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : ↑zero = 0 := rfl

@[simp] theorem cast_one {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] : ↑1 = 1 := rfl

@[simp] theorem cast_pos {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : pos_num) :
    ↑(pos n) = ↑n :=
  rfl

@[simp] theorem cast_neg {α : Type u_1} [HasZero α] [HasOne α] [Add α] [Neg α] (n : pos_num) :
    ↑(neg n) = -↑n :=
  rfl

@[simp] theorem cast_zneg {α : Type u_1} [add_group α] [HasOne α] (n : znum) : ↑(-n) = -↑n :=
  znum.cases_on n (idRhs (0 = -0) (Eq.symm neg_zero))
    (fun (n : pos_num) => idRhs (↑(-pos n) = ↑(-pos n)) rfl)
    fun (n : pos_num) => idRhs (↑(-neg n) = --↑(-neg n)) (Eq.symm (neg_neg ↑(-neg n)))

theorem neg_zero : -0 = 0 := rfl

theorem zneg_pos (n : pos_num) : -pos n = neg n := rfl

theorem zneg_neg (n : pos_num) : -neg n = pos n := rfl

theorem zneg_zneg (n : znum) : --n = n :=
  znum.cases_on n (Eq.refl ( --zero)) (fun (n : pos_num) => Eq.refl ( --pos n))
    fun (n : pos_num) => Eq.refl ( --neg n)

theorem zneg_bit1 (n : znum) : -znum.bit1 n = znum.bitm1 (-n) :=
  znum.cases_on n (Eq.refl (-znum.bit1 zero)) (fun (n : pos_num) => Eq.refl (-znum.bit1 (pos n)))
    fun (n : pos_num) => Eq.refl (-znum.bit1 (neg n))

theorem zneg_bitm1 (n : znum) : -znum.bitm1 n = znum.bit1 (-n) :=
  znum.cases_on n (Eq.refl (-znum.bitm1 zero)) (fun (n : pos_num) => Eq.refl (-znum.bitm1 (pos n)))
    fun (n : pos_num) => Eq.refl (-znum.bitm1 (neg n))

theorem zneg_succ (n : znum) : -succ n = pred (-n) := sorry

theorem zneg_pred (n : znum) : -pred n = succ (-n) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (-pred n = succ (-n))) (Eq.symm (zneg_zneg (succ (-n))))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (-pred n = --succ (-n))) (zneg_succ (-n))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (-pred n = -pred ( --n))) (zneg_zneg n)))
        (Eq.refl (-pred n))))

@[simp] theorem neg_of_int (n : ℤ) : ↑(-n) = -↑n :=
  int.cases_on n
    (fun (n : ℕ) =>
      nat.cases_on n (idRhs (↑(-0) = ↑(-0)) rfl)
        fun (n : ℕ) => idRhs (↑(-↑(n + 1)) = ↑(-↑(n + 1))) rfl)
    fun (n : ℕ) =>
      idRhs (↑(-Int.negSucc n) = --↑(-Int.negSucc n)) (Eq.symm (zneg_zneg ↑(-Int.negSucc n)))

@[simp] theorem abs_to_nat (n : znum) : ↑(abs n) = int.nat_abs ↑n := sorry

@[simp] theorem abs_to_znum (n : num) : abs (num.to_znum n) = n :=
  num.cases_on n (idRhs (abs (num.to_znum 0) = abs (num.to_znum 0)) rfl)
    fun (n : pos_num) => idRhs (abs (num.to_znum (num.pos n)) = abs (num.to_znum (num.pos n))) rfl

@[simp] theorem cast_to_int {α : Type u_1} [add_group α] [HasOne α] (n : znum) : ↑↑n = ↑n := sorry

theorem bit0_of_bit0 (n : znum) : bit0 n = znum.bit0 n :=
  znum.cases_on n (idRhs (bit0 0 = bit0 0) rfl)
    (fun (n : pos_num) =>
      idRhs (pos (bit0 n) = pos (pos_num.bit0 n)) (congr_arg pos (pos_num.bit0_of_bit0 n)))
    fun (n : pos_num) =>
      idRhs (neg (bit0 n) = neg (pos_num.bit0 n)) (congr_arg neg (pos_num.bit0_of_bit0 n))

theorem bit1_of_bit1 (n : znum) : bit1 n = znum.bit1 n := sorry

@[simp] theorem cast_bit0 {α : Type u_1} [add_group α] [HasOne α] (n : znum) :
    ↑(znum.bit0 n) = bit0 ↑n :=
  sorry

@[simp] theorem cast_bit1 {α : Type u_1} [add_group α] [HasOne α] (n : znum) :
    ↑(znum.bit1 n) = bit1 ↑n :=
  sorry

@[simp] theorem cast_bitm1 {α : Type u_1} [add_group α] [HasOne α] (n : znum) :
    ↑(znum.bitm1 n) = bit0 ↑n - 1 :=
  sorry

theorem add_zero (n : znum) : n + 0 = n :=
  znum.cases_on n (Eq.refl (zero + 0)) (fun (n : pos_num) => Eq.refl (pos n + 0))
    fun (n : pos_num) => Eq.refl (neg n + 0)

theorem zero_add (n : znum) : 0 + n = n :=
  znum.cases_on n (Eq.refl (0 + zero)) (fun (n : pos_num) => Eq.refl (0 + pos n))
    fun (n : pos_num) => Eq.refl (0 + neg n)

theorem add_one (n : znum) : n + 1 = succ n := sorry

end znum

namespace pos_num

theorem cast_to_znum (n : pos_num) : ↑n = znum.pos n := sorry

theorem cast_sub' {α : Type u_1} [add_group α] [HasOne α] (m : pos_num) (n : pos_num) :
    ↑(sub' m n) = ↑m - ↑n :=
  sorry

theorem to_nat_eq_succ_pred (n : pos_num) : ↑n = ↑(pred' n) + 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = ↑(pred' n) + 1)) (Eq.symm (num.succ'_to_nat (pred' n)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n = ↑(num.succ' (pred' n)))) (succ'_pred' n))) (Eq.refl ↑n))

theorem to_int_eq_succ_pred (n : pos_num) : ↑n = ↑↑(pred' n) + 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = ↑↑(pred' n) + 1)) (Eq.symm (to_nat_to_int n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑↑(pred' n) + 1)) (to_nat_eq_succ_pred n)))
      (Eq.refl ↑(↑(pred' n) + 1)))

end pos_num

namespace num

@[simp] theorem cast_sub' {α : Type u_1} [add_group α] [HasOne α] (m : num) (n : num) :
    ↑(sub' m n) = ↑m - ↑n :=
  sorry

@[simp] theorem of_nat_to_znum (n : ℕ) : to_znum ↑n = ↑n := sorry

@[simp] theorem of_nat_to_znum_neg (n : ℕ) : to_znum_neg ↑n = -↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (to_znum_neg ↑n = -↑n)) (Eq.symm (of_nat_to_znum n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (to_znum_neg ↑n = -to_znum ↑n)) (zneg_to_znum ↑n)))
      (Eq.refl (to_znum_neg ↑n)))

theorem mem_of_znum' {m : num} {n : znum} : m ∈ of_znum' n ↔ n = to_znum m := sorry

theorem of_znum'_to_nat (n : znum) : coe <$> of_znum' n = int.to_nat' ↑n := sorry

@[simp] theorem of_znum_to_nat (n : znum) : ↑(of_znum n) = int.to_nat ↑n := sorry

@[simp] theorem cast_of_znum {α : Type u_1} [add_group α] [HasOne α] (n : znum) :
    ↑(of_znum n) = ↑(int.to_nat ↑n) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (↑(of_znum n) = ↑(int.to_nat ↑n))) (Eq.symm (cast_to_nat (of_znum n)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑(of_znum n) = ↑(int.to_nat ↑n))) (of_znum_to_nat n)))
      (Eq.refl ↑(int.to_nat ↑n)))

@[simp] theorem sub_to_nat (m : num) (n : num) : ↑(m - n) = ↑m - ↑n := sorry

end num

namespace znum

@[simp] theorem cast_add {α : Type u_1} [add_group α] [HasOne α] (m : znum) (n : znum) :
    ↑(m + n) = ↑m + ↑n :=
  sorry

@[simp] theorem cast_succ {α : Type u_1} [add_group α] [HasOne α] (n : znum) : ↑(succ n) = ↑n + 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(succ n) = ↑n + 1)) (Eq.symm (add_one n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(n + 1) = ↑n + 1)) (cast_add n 1)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑n + ↑1 = ↑n + 1)) cast_one)) (Eq.refl (↑n + 1))))

@[simp] theorem mul_to_int (m : znum) (n : znum) : ↑(m * n) = ↑m * ↑n := sorry

theorem cast_mul {α : Type u_1} [ring α] (m : znum) (n : znum) : ↑(m * n) = ↑m * ↑n := sorry

@[simp] theorem of_to_int (n : znum) : ↑↑n = n := sorry

theorem to_of_int (n : ℤ) : ↑↑n = n := sorry

theorem to_int_inj {m : znum} {n : znum} : ↑m = ↑n ↔ m = n :=
  { mp := fun (h : ↑m = ↑n) => function.left_inverse.injective of_to_int h,
    mpr := congr_arg fun (x : znum) => ↑x }

@[simp] theorem of_int_cast {α : Type u_1} [add_group α] [HasOne α] (n : ℤ) : ↑↑n = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑↑n = ↑n)) (Eq.symm (cast_to_int ↑n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑↑↑n = ↑n)) (to_of_int n))) (Eq.refl ↑n))

@[simp] theorem of_nat_cast {α : Type u_1} [add_group α] [HasOne α] (n : ℕ) : ↑↑n = ↑n :=
  of_int_cast ↑n

@[simp] theorem of_int'_eq (n : ℤ) : of_int' n = ↑n := sorry

theorem cmp_to_int (m : znum) (n : znum) :
    ordering.cases_on (cmp m n) (↑m < ↑n) (m = n) (↑n < ↑m) :=
  sorry

theorem lt_to_int {m : znum} {n : znum} : ↑m < ↑n ↔ m < n := sorry

theorem le_to_int {m : znum} {n : znum} : ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr lt_to_int)

@[simp] theorem cast_lt {α : Type u_1} [linear_ordered_ring α] {m : znum} {n : znum} :
    ↑m < ↑n ↔ m < n :=
  sorry

@[simp] theorem cast_le {α : Type u_1} [linear_ordered_ring α] {m : znum} {n : znum} :
    ↑m ≤ ↑n ↔ m ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑m ≤ ↑n ↔ m ≤ n)) (Eq.symm (propext not_lt))))
    (not_congr cast_lt)

@[simp] theorem cast_inj {α : Type u_1} [linear_ordered_ring α] {m : znum} {n : znum} :
    ↑m = ↑n ↔ m = n :=
  sorry

/--
This tactic tries to turn an (in)equality about `znum`s to one about `int`s by rewriting.
```lean
example (n : znum) (m : znum) : n ≤ n + m * m :=
begin
  znum.transfer_rw,
  exact le_add_of_nonneg_right (mul_self_nonneg _)
end
```
-/
/--
This tactic tries to prove (in)equalities about `znum`s by transfering them to the `int` world and
then trying to call `simp`.
```lean
example (n : znum) (m : znum) : n ≤ n + m * m :=
begin
  znum.transfer,
  exact mul_self_nonneg _
end
```
-/
protected instance linear_order : linear_order znum :=
  linear_order.mk LessEq Less sorry sorry sorry sorry znum.decidable_le znum.decidable_eq
    znum.decidable_lt

protected instance add_comm_group : add_comm_group znum :=
  add_comm_group.mk Add.add sorry 0 zero_add add_zero Neg.neg
    (add_group.sub._default Add.add sorry 0 zero_add add_zero Neg.neg) sorry sorry

protected instance linear_ordered_comm_ring : linear_ordered_comm_ring znum :=
  linear_ordered_comm_ring.mk add_comm_group.add add_comm_group.add_assoc add_comm_group.zero
    add_comm_group.zero_add add_comm_group.add_zero add_comm_group.neg add_comm_group.sub
    add_comm_group.add_left_neg add_comm_group.add_comm Mul.mul sorry 1 sorry sorry sorry sorry
    linear_order.le linear_order.lt linear_order.le_refl linear_order.le_trans
    linear_order.le_antisymm sorry sorry sorry linear_order.le_total linear_order.decidable_le
    linear_order.decidable_eq linear_order.decidable_lt sorry sorry

@[simp] theorem dvd_to_int (m : znum) (n : znum) : ↑m ∣ ↑n ↔ m ∣ n := sorry

end znum

namespace pos_num

theorem divmod_to_nat_aux {n : pos_num} {d : pos_num} {q : num} {r : num}
    (h₁ : ↑r + ↑d * bit0 ↑q = ↑n) (h₂ : ↑r < bit0 1 * ↑d) :
    ↑(prod.snd (divmod_aux d q r)) + ↑d * ↑(prod.fst (divmod_aux d q r)) = ↑n ∧
        ↑(prod.snd (divmod_aux d q r)) < ↑d :=
  sorry

theorem divmod_to_nat (d : pos_num) (n : pos_num) :
    ↑n / ↑d = ↑(prod.fst (divmod d n)) ∧ ↑n % ↑d = ↑(prod.snd (divmod d n)) :=
  sorry

@[simp] theorem div'_to_nat (n : pos_num) (d : pos_num) : ↑(div' n d) = ↑n / ↑d :=
  Eq.symm (and.left (divmod_to_nat d n))

@[simp] theorem mod'_to_nat (n : pos_num) (d : pos_num) : ↑(mod' n d) = ↑n % ↑d :=
  Eq.symm (and.right (divmod_to_nat d n))

end pos_num

namespace num

@[simp] theorem div_to_nat (n : num) (d : num) : ↑(n / d) = ↑n / ↑d := sorry

@[simp] theorem mod_to_nat (n : num) (d : num) : ↑(n % d) = ↑n % ↑d := sorry

theorem gcd_to_nat_aux {n : ℕ} {a : num} {b : num} :
    a ≤ b → nat_size (a * b) ≤ n → ↑(gcd_aux n a b) = nat.gcd ↑a ↑b :=
  sorry

@[simp] theorem gcd_to_nat (a : num) (b : num) : ↑(gcd a b) = nat.gcd ↑a ↑b := sorry

theorem dvd_iff_mod_eq_zero {m : num} {n : num} : m ∣ n ↔ n % m = 0 := sorry

protected instance decidable_dvd : DecidableRel has_dvd.dvd := sorry

end num

protected instance pos_num.decidable_dvd : DecidableRel has_dvd.dvd := sorry

namespace znum

@[simp] theorem div_to_int (n : znum) (d : znum) : ↑(n / d) = ↑n / ↑d := sorry

@[simp] theorem mod_to_int (n : znum) (d : znum) : ↑(n % d) = ↑n % ↑d := sorry

@[simp] theorem gcd_to_nat (a : znum) (b : znum) : ↑(gcd a b) = int.gcd ↑a ↑b := sorry

theorem dvd_iff_mod_eq_zero {m : znum} {n : znum} : m ∣ n ↔ n % m = 0 := sorry

protected instance has_dvd.dvd.decidable_rel : DecidableRel has_dvd.dvd := sorry

end znum

namespace int

/-- Cast a `snum` to the corresponding integer. -/
def of_snum : snum → ℤ :=
  snum.rec' (fun (a : Bool) => cond a (-1) 0)
    fun (a : Bool) (p : snum) (IH : ℤ) => cond a (bit1 IH) (bit0 IH)

end int

protected instance int.snum_coe : has_coe snum ℤ := has_coe.mk int.of_snum

protected instance snum.has_lt : HasLess snum := { Less := fun (a b : snum) => ↑a < ↑b }

protected instance snum.has_le : HasLessEq snum := { LessEq := fun (a b : snum) => ↑a ≤ ↑b }

end Mathlib


import Lean

@[simp] theorem ex1 (x : Nat) : 2 * x = x + x :=
  sorry

@[simp] theorem ex2 (xs : List α) : xs ++ [] = xs :=
  sorry

@[simp] theorem ex3 (xs ys zs : List α) : (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
  sorry

@[simp] theorem ex5 (p : Prop) : p ∨ True :=
  sorry

@[simp] theorem ex4 (xs : List α) : ¬(x :: xs = []) :=
  sorry

@[simp] theorem ex6 (p q : Prop) : p ∨ q ↔ q ∨ p:=
  sorry

@[simp high] theorem ex7 [Add α] (a b : α) : a + b = b + a :=
  sorry

@[simp↓] theorem ex8 [Add α] (p q : Prop) : (¬ (p ∧ q)) = (¬p ∨ ¬q) :=
  sorry

axiom aux {α} (f : List α → List α) (xs ys : List α) : f (xs ++ ys) ++ [] = f (xs ++ ys)

open Lean
open Lean.Meta

def tst1 : MetaM Unit := do
  let thms  ← Meta.getSimpTheorems
  trace[Meta.debug] "{thms.pre}\n-----\n{thms.post}"

set_option trace.Meta.debug true in
#eval tst1

def tst2 : MetaM Unit := do
  let c ← getConstInfo `aux
  forallTelescopeReducing c.type fun xs type => do
    match type.eq? with
    | none => throwError "unexpected"
    | some (_, lhs, _) =>
      trace[Meta.debug] "lhs: {lhs}"
      let s ← Meta.getSimpTheorems
      let m ← s.post.getMatch lhs
      trace[Meta.debug] "result: {m}"
      assert! m.any fun s => s.name? == `ex2

set_option trace.Meta.debug true in
#eval tst2


import category_theory.monoidal.rigid
import category_theory.monoidal.braided

open category_theory

namespace tangle

inductive hom : ℕ → ℕ → Type
| id (a) : hom a a
| associator_hom (a b c : ℕ) : hom ((a + b) + c) (a + (b + c))
| associator_inv (a b c : ℕ) : hom (a + (b + c)) ((a + b) + c)
| left_unitor_hom (a) : hom (0 + a) a
| left_unitor_inv (a) : hom a (0 + a)
| right_unitor_hom (a) : hom (a + 0) a
| right_unitor_inv (a) : hom a (a + 0)
| comp {a b c} (f : hom a b) (g : hom b c) : hom a c
| tensor {a b c d} (f : hom a b) (g : hom c d) : hom (a + c) (b + d)
| coevaluation (a) : hom 0 (a + a)
| evaluation (a) : hom (a + a) 0
| braiding_hom (a b) : hom (a + b) (b + a)
| braiding_inv (a b) : hom (b + a) (a + b)
| twist_hom (a) : hom a a
| twist_inv (a) : hom a a

open hom

local infixr ` ⟶ᵐ `:10 := hom
local infixr ` ≫ `:80 := hom.comp -- type as \gg
local infixr ` ⊗ `:70 := hom.tensor
local notation `𝟙` := hom.id -- type as \b1
local notation `α_` := hom.associator_hom
local notation `α⁻¹_` := hom.associator_inv
local notation `ℓ_` := hom.left_unitor_hom
local notation `ℓ⁻¹_` := hom.left_unitor_inv
local notation `ρ_` := hom.right_unitor_hom
local notation `ρ⁻¹_` := hom.right_unitor_inv
local notation `η_` := hom.coevaluation
local notation `ε_` := hom.evaluation
local notation `β_` := hom.braiding_hom
local notation `β⁻¹_` := hom.braiding_inv
local notation `θ_` := hom.twist_hom
local notation `θ⁻¹_` := hom.twist_inv

inductive hom_equiv : Π {X Y : ℕ}, (X ⟶ᵐ Y) → (X ⟶ᵐ Y) → Prop
| refl {X Y} (f : X ⟶ᵐ Y) : hom_equiv f f
| symm {X Y} (f g : X ⟶ᵐ Y) : hom_equiv f g → hom_equiv g f
| trans {X Y} {f g h : X ⟶ᵐ Y} : hom_equiv f g → hom_equiv g h → hom_equiv f h
| comp {X Y Z} {f f' : X ⟶ᵐ Y} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f ≫ g) (f' ≫ g')
| tensor {W X Y Z} {f f' : W ⟶ᵐ X} {g g' : Y ⟶ᵐ Z} :
    hom_equiv f f' → hom_equiv g g' → hom_equiv (f ⊗ g) (f' ⊗ g')
| comp_id {X Y} (f : X ⟶ᵐ Y) : hom_equiv (f ≫ 𝟙 _) f
| id_comp {X Y} (f : X ⟶ᵐ Y) : hom_equiv (𝟙 _ ≫ f) f
| assoc {X Y U V} (f : X ⟶ᵐ U) (g : U ⟶ᵐ V) (h : V ⟶ᵐ Y) :
    hom_equiv ((f ≫ g) ≫ h) (f ≫ (g ≫ h))
| tensor_id {X Y} : hom_equiv ((𝟙 X) ⊗ (𝟙 Y)) (𝟙 _)
| tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂}
    (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (g₁ : Y₁ ⟶ᵐ Z₁) (g₂ : Y₂ ⟶ᵐ Z₂) :
    hom_equiv ((f₁ ≫ g₁) ⊗ (f₂ ≫ g₂)) ((f₁ ⊗ f₂) ≫ (g₁ ⊗ g₂))
| associator_hom_inv {X Y Z} : hom_equiv (α_ X Y Z ≫ α⁻¹_ X Y Z) (𝟙 _)
| associator_inv_hom {X Y Z} : hom_equiv (α⁻¹_ X Y Z ≫ α_ X Y Z) (𝟙 _)
| associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃} (f₁ : X₁ ⟶ᵐ Y₁) (f₂ : X₂ ⟶ᵐ Y₂) (f₃ : X₃ ⟶ᵐ Y₃) :
    hom_equiv (((f₁ ⊗ f₂) ⊗ f₃) ≫ α_ Y₁ Y₂ Y₃)
      (α_ X₁ X₂ X₃ ≫ (f₁ ⊗ (f₂ ⊗ f₃)))
| right_unitor_hom_inv {X} : hom_equiv (ρ_ X ≫ ρ⁻¹_ X) (𝟙 _)
| right_unitor_inv_hom {X} : hom_equiv (ρ⁻¹_ X ≫ ρ_ X) (𝟙 _)
| right_unitor_naturality {X Y} (f : X ⟶ᵐ Y) : hom_equiv ((f ⊗ 𝟙 0) ≫ ρ_ Y) (ρ_ X ≫ f)
| left_unitor_hom_inv {X} : hom_equiv (ℓ_ X ≫ ℓ⁻¹_ X) (𝟙 _)
| left_unitor_inv_hom {X} : hom_equiv (ℓ⁻¹_ X ≫ ℓ_ X) (𝟙 _)
| left_unitor_naturality {X Y} (f : X ⟶ᵐ Y) : hom_equiv ((𝟙 0 ⊗ f) ≫ ℓ_ Y) (ℓ_ X ≫ f)
| pentagon {W X Y Z} : hom_equiv
    ((α_ W X Y ⊗ 𝟙 Z) ≫ α_ W (X + Y) Z ≫ (𝟙 W ⊗ α_ X Y Z))
    (α_ (W + X) Y Z ≫ α_ W X (Y + Z))
| triangle {X Y} : hom_equiv (α_ X 0 Y ≫ (𝟙 X ⊗ ℓ_ Y)) (ρ_ X ⊗ 𝟙 Y)
| coevaluation_evaluation {Y} : hom_equiv ((𝟙 Y ⊗ η_ Y) ≫ α⁻¹_ Y Y Y ≫ (ε_ Y ⊗ 𝟙 Y))
    (ρ_ Y ≫ ℓ⁻¹_ Y)
| evaluation_coevaluation {X} : hom_equiv ((η_ X ⊗ 𝟙 X) ≫ α_ X X X ≫ (𝟙 X ⊗ ε_ X))
    (ℓ_ X ≫ ρ⁻¹_ X)
| braiding_hom_inv {X Y} : hom_equiv (β_ X Y ≫ β⁻¹_ X Y) (𝟙 _)
| braiding_inv_hom {X Y} : hom_equiv (β⁻¹_ X Y ≫ β_ X Y) (𝟙 _)
| braiding_naturality  {X X' Y Y' : ℕ} (f : X ⟶ᵐ Y) (g : X' ⟶ᵐ Y') : hom_equiv
    ((f ⊗ g) ≫ β_ Y Y') (β_ X X' ≫ (g ⊗ f))
| hexagon_forward {X Y Z} : hom_equiv
    (α_ X Y Z ≫ β_ X (Y + Z) ≫ α_ Y Z X)
    ((β_ X Y ⊗ 𝟙 Z) ≫ α_ Y X Z ≫ (𝟙 Y ⊗ β_ X Z))
| hexagon_reverse {X Y Z} : hom_equiv
    (α⁻¹_ X Y Z ≫ β_ (X + Y) Z ≫ α⁻¹_ Z X Y)
    ((𝟙 X ⊗ β_ Y Z) ≫ α⁻¹_ X Z Y ≫ (β_ X Z ⊗ 𝟙 Y))
| twist_hom_inv {X} : hom_equiv (θ_ X ≫ θ⁻¹_ X) (𝟙 _)
| twist_inv_hom {X} : hom_equiv (θ⁻¹_ X ≫ θ_ X) (𝟙 _)
| twist_naturality {X Y} (f : X ⟶ᵐ Y) : hom_equiv (f ≫ θ_ Y) (θ_ X ≫ f)
| twist_braiding {X Y} : hom_equiv (θ_ (X + Y)) ((θ_ X ⊗ θ_ Y) ≫ β_ X Y ≫ β_ Y X)
| twist_left_dual {X} : hom_equiv (θ_ X)
    (ℓ⁻¹_ X ≫ (η_ X ⊗ 𝟙 _) ≫ ((𝟙 _ ⊗ θ_ X) ⊗ 𝟙 _) ≫ α_ X X X ≫ (𝟙 _ ⊗ ε_ X) ≫ ρ_ X)

def setoid_hom (X Y : ℕ) : setoid (X ⟶ᵐ Y) :=
⟨hom_equiv,
  ⟨λ f, hom_equiv.refl f, λ f g, hom_equiv.symm f g, λ f g h hfg hgh, hom_equiv.trans hfg hgh⟩⟩

attribute [instance] setoid_hom

open hom_equiv

def category : category ℕ :=
{ hom := λ X Y, quotient (setoid_hom X Y),
  id := λ X, ⟦hom.id _⟧,
  comp := λ X Y Z f g, quotient.map₂ comp (by { intros f f' hf g g' hg, exact comp hf hg }) f g,
  id_comp' := by { rintro X Y ⟨f⟩, exact quotient.sound (id_comp f) },
  comp_id' := by { rintro X Y ⟨f⟩, exact quotient.sound (comp_id f) },
  assoc' := by { rintro W X Y Z ⟨f⟩ ⟨g⟩ ⟨h⟩, exact quotient.sound (assoc f g h) } }

local attribute [instance] category

def monoidal_category : monoidal_category ℕ :=
{ tensor_obj := λ X Y, X + Y,
  tensor_hom := λ X₁ Y₁ X₂ Y₂, quotient.map₂ tensor $
    by { intros _ _ h _ _ h', exact hom_equiv.tensor h h'},
  tensor_id' := λ X Y, quotient.sound tensor_id,
  tensor_comp' := λ X₁ Y₁ Z₁ X₂ Y₂ Z₂,
    by { rintros ⟨f₁⟩ ⟨f₂⟩ ⟨g₁⟩ ⟨g₂⟩, exact quotient.sound (tensor_comp _ _ _ _) },
  tensor_unit := 0,
  associator := λ X Y Z,
    ⟨⟦associator_hom X Y Z⟧, ⟦associator_inv X Y Z⟧,
      quotient.sound associator_hom_inv, quotient.sound associator_inv_hom⟩,
  associator_naturality' := λ X₁ X₂ X₃ Y₁ Y₂ Y₃,
    by { rintros ⟨f₁⟩ ⟨f₂⟩ ⟨f₃⟩, exact quotient.sound (associator_naturality _ _ _) },
  left_unitor := λ X,
    ⟨⟦left_unitor_hom X⟧, ⟦left_unitor_inv X⟧,
      quotient.sound left_unitor_hom_inv, quotient.sound left_unitor_inv_hom⟩,
  left_unitor_naturality' := λ X Y, by { rintro ⟨f⟩, exact quotient.sound (left_unitor_naturality _) },
  right_unitor := λ X,
    ⟨⟦right_unitor_hom X⟧, ⟦right_unitor_inv X⟧,
      quotient.sound right_unitor_hom_inv, quotient.sound right_unitor_inv_hom⟩,
  right_unitor_naturality' := λ X Y, by { rintro ⟨f⟩, exact quotient.sound (right_unitor_naturality _) },
  pentagon' := λ W X Y Z, quotient.sound pentagon,
  triangle' := λ X Y, quotient.sound triangle }

local attribute [instance] monoidal_category

def left_rigid_category : left_rigid_category ℕ :=
{ left_dual := λ X,
  { left_dual := X,
    exact :=
    { coevaluation := ⟦coevaluation X⟧,
      evaluation := ⟦evaluation X⟧,
      coevaluation_evaluation' := quotient.sound hom_equiv.coevaluation_evaluation,
      evaluation_coevaluation' := quotient.sound hom_equiv.evaluation_coevaluation }}}

def braided_category : braided_category ℕ :=
{ braiding := λ X Y,
  { hom := ⟦braiding_hom X Y⟧,
    inv := ⟦braiding_inv X Y⟧,
    hom_inv_id' := quotient.sound hom_equiv.braiding_hom_inv,
    inv_hom_id' := quotient.sound hom_equiv.braiding_inv_hom },
  braiding_naturality' := λ W X Y Z,
    by { rintro ⟨f⟩ ⟨g⟩, exact quotient.sound (hom_equiv.braiding_naturality f g)},
  hexagon_forward' := λ X Y Z, quotient.sound (hom_equiv.hexagon_forward),
  hexagon_reverse' := λ X Y Z, quotient.sound (hom_equiv.hexagon_reverse) }

local attribute [instance] left_rigid_category
local attribute [instance] braided_category

/--
Examples of tangles.
-/
abbreviation cap := coevaluation 1
abbreviation cup := evaluation 1
abbreviation vert := hom.id 1
abbreviation over := braiding_hom 1 1
abbreviation under := braiding_inv 1 1

#check cap
#check cup
#check vert
#check over
#check under
#check cap ⊗ under
#check α_ 2 1 3
#check ℓ⁻¹_ (1 + 1)
#check (vert ⊗ vert) ≫ (ℓ⁻¹_ (1 + 1)) ≫ (cap ⊗ under) ≫ (over ⊗ under) ≫ (α⁻¹_ 2 1 1) ≫ (𝟙 4)

example : 2 ⟶ 4 := ⟦(cap ⊗ under) ≫ (over ⊗ under)⟧

end tangle


import o_minimal.examples.simple
import .choice3
import ..tame
import ..ultra

-- TODO: for lean core library: modify binder type of dif_pos etc.:
-- lemma {u} dif_pos' {c : Prop} {h : decidable c} (hc : c) {α : Sort u} {t : c → α} {e : ¬c → α} : dite c t e = t hc := dif_pos hc
-- Avoids the need (unexplained) for `open_locale classical` below.

-- The comments above are obsolete, but this still seems like a good idea.

open o_minimal

variables {R : Type*} [OQM R]
variables {X : set R}

local notation `½` := (1/2 : ℚ)

lemma lt_of_self_add_lt {a b : R} (h : a + a < b + b) : a < b :=
begin
  contrapose! h,
  exact add_le_add h h
end

lemma average_between {a b : R} (hab : a < b) : ½ • (a + b) ∈ set.Ioo a b :=
begin
  split,
  { apply lt_of_self_add_lt,
    rw half_add_half,
    apply add_lt_add_left hab },
  { apply lt_of_self_add_lt,
    rw half_add_half,
    apply add_lt_add_right hab }
end

local attribute [instance] one

lemma one_pos : (0 : R) < 1 :=
classical.some_spec _

lemma chosen_one_mem (nX : X.nonempty) (tX : tame X) :
  (chosen_one X) ∈ X :=
begin
  -- Administrative nonsense; also handle the trivial "has least" case.
  dsimp [chosen_one, roption.map, roption.orelse_pure, function.comp],
  split_ifs with hleast hinf hsup hsup hsup;
    try { dsimp [the_least, the_inf, the_sup] at * },
  { obtain ⟨e, he⟩ := hleast,
    rw get_pfun_of_rel_eq_of_rel he,
    exact he.1 },
  any_goals {
    obtain ⟨a, ha⟩ := hinf,
    simp only [get_pfun_of_rel_eq_of_rel ha] at ⊢ hsup },
  any_goals {
    obtain ⟨b, hb⟩ := hsup,
    rw get_pfun_of_rel_eq_of_rel hb, try { clear hsup } },
  -- Now handle the remaining cases, respectively those yielding
  -- (a+b)/2, b-1, a+1, 0
  -- where a = inf X, b = sup Y, Y = {b | a < b ∧ (a, b) ⊆ X}.
  { have hab : a < b,
    { obtain ⟨b', hb'⟩ := hb.nonempty,
      exact lt_of_lt_of_le hb'.1 (hb.1 hb') },
    have mid : ½ • (a + b) ∈ set.Ioo a b := average_between hab,
    obtain ⟨c, hc, hmc⟩ := (lt_is_lub_iff hb).mp mid.2,
    apply hc.2,
    exact ⟨mid.1, hmc⟩ },
  { let Y := {b | a < b ∧ set.Ioo a b ⊆ X},
    change ¬ ∃ b, is_lub Y b at hsup,
    have nY : Y.nonempty,
    { have := above_inf tX ha (λ H, hleast ⟨a, H, ha.1⟩),
      -- TODO: for_mathlib: ^ is_glb ∧ mem → is_least
      rw mem_above_iff at this,
      obtain ⟨b, hab, hb⟩ := this,
      exact ⟨b, hab, hb⟩ },
    have tY : tame Y,
    { refine tame_of_def simple_struc _,
      apply def_set.and,
      { exact definable_lt def_fun_const def_fun.id },
      { apply def_set.forall,
        apply def_set.imp,
        { apply def_set.and,
          { exact definable_lt def_fun_const def_fun.snd },
          { exact definable_lt def_fun.snd def_fun.fst } },
        { exact def_fun.snd.preimage tX.def_set } } },
    have := mt (exists_tSup tY nY) hsup,
    rw not_bdd_above_iff at this,
    obtain ⟨b, hb₁, hb₂⟩ := this (a + 1),
    apply hb₁.2 ⟨lt_add_of_pos_right _ one_pos, hb₂⟩ },
  { obtain ⟨c, hc₁, hc₂⟩ := (lt_is_lub_iff hb).mp (sub_lt_self b one_pos),
    exact hc₁ hc₂ },
  { let Y := {b | set.Iio b ⊆ X},
    change ¬ ∃ b, is_lub Y b at hsup,
    have nY : Y.nonempty,
    { have := mt (exists_tInf tX nX) hinf,
      exact (contains_Iio_or_bdd_below tX).resolve_right this },
    have tY : tame Y,
    { refine tame_of_def simple_struc _,
      apply def_set.forall,
      apply def_set.imp,
      { exact definable_lt def_fun.snd def_fun.fst },
      { exact def_fun.snd.preimage tX.def_set } },
    have := mt (exists_tSup tY nY) hsup,
    rw not_bdd_above_iff at this,
    obtain ⟨b, hb₁, hb₂⟩ := this 0,
    apply hb₁ hb₂ }
end

lemma chosen_one'_mem (nX : X.nonempty) :
  (chosen_one' X) ∈ X :=
begin
  unfold chosen_one',
  split_ifs with h,
  { exact chosen_one_mem nX h },
  { exact classical.some_spec nX }
end


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison, Bhavik Mehta
-/
import category_theory.monoidal.category
import category_theory.adjunction.basic
import category_theory.products.basic

/-!
# (Lax) monoidal functors

A lax monoidal functor `F` between monoidal categories `C` and `D`
is a functor between the underlying categories equipped with morphisms
* `ε : 𝟙_ D ⟶ F.obj (𝟙_ C)` (called the unit morphism)
* `μ X Y : (F.obj X) ⊗ (F.obj Y) ⟶ F.obj (X ⊗ Y)` (called the tensorator, or strength).
satisfying various axioms.

A monoidal functor is a lax monoidal functor for which `ε` and `μ` are isomorphisms.

We show that the composition of (lax) monoidal functors gives a (lax) monoidal functor.

See also `category_theory.monoidal.functorial` for a typeclass decorating an object-level
function with the additional data of a monoidal functor.
This is useful when stating that a pre-existing functor is monoidal.

See `category_theory.monoidal.natural_transformation` for monoidal natural transformations.

We show in `category_theory.monoidal.Mon_` that lax monoidal functors take monoid objects
to monoid objects.

## Future work
* Oplax monoidal functors.

## References

See <https://stacks.math.columbia.edu/tag/0FFL>.
-/

open category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃

open category_theory.category
open category_theory.functor

namespace category_theory

section

open monoidal_category

variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C]
          (D : Type u₂) [category.{v₂} D] [monoidal_category.{v₂} D]

/-- A lax monoidal functor is a functor `F : C ⥤ D` between monoidal categories,
equipped with morphisms `ε : 𝟙 _D ⟶ F.obj (𝟙_ C)` and `μ X Y : F.obj X ⊗ F.obj Y ⟶ F.obj (X ⊗ Y)`,
satisfying the appropriate coherences. -/
-- The direction of `left_unitality` and `right_unitality` as simp lemmas may look strange:
-- remember the rule of thumb that component indices of natural transformations
-- "weigh more" than structural maps.
-- (However by this argument `associativity` is currently stated backwards!)
structure lax_monoidal_functor extends C ⥤ D :=
-- unit morphism
(ε               : 𝟙_ D ⟶ obj (𝟙_ C))
-- tensorator
(μ                : Π X Y : C, (obj X) ⊗ (obj Y) ⟶ obj (X ⊗ Y))
(μ_natural'       : ∀ {X Y X' Y' : C}
  (f : X ⟶ Y) (g : X' ⟶ Y'),
  ((map f) ⊗ (map g)) ≫ μ Y Y' = μ X X' ≫ map (f ⊗ g)
  . obviously)
-- associativity of the tensorator
(associativity'   : ∀ (X Y Z : C),
    (μ X Y ⊗ 𝟙 (obj Z)) ≫ μ (X ⊗ Y) Z ≫ map (α_ X Y Z).hom
  = (α_ (obj X) (obj Y) (obj Z)).hom ≫ (𝟙 (obj X) ⊗ μ Y Z) ≫ μ X (Y ⊗ Z)
  . obviously)
-- unitality
(left_unitality'  : ∀ X : C,
    (λ_ (obj X)).hom
  = (ε ⊗ 𝟙 (obj X)) ≫ μ (𝟙_ C) X ≫ map (λ_ X).hom
  . obviously)
(right_unitality' : ∀ X : C,
    (ρ_ (obj X)).hom
  = (𝟙 (obj X) ⊗ ε) ≫ μ X (𝟙_ C) ≫ map (ρ_ X).hom
  . obviously)

restate_axiom lax_monoidal_functor.μ_natural'
attribute [simp, reassoc] lax_monoidal_functor.μ_natural
restate_axiom lax_monoidal_functor.left_unitality'
attribute [simp] lax_monoidal_functor.left_unitality
restate_axiom lax_monoidal_functor.right_unitality'
attribute [simp] lax_monoidal_functor.right_unitality
restate_axiom lax_monoidal_functor.associativity'
attribute [simp, reassoc] lax_monoidal_functor.associativity

-- When `rewrite_search` lands, add @[search] attributes to
-- lax_monoidal_functor.μ_natural lax_monoidal_functor.left_unitality
-- lax_monoidal_functor.right_unitality lax_monoidal_functor.associativity

section
variables {C D}

@[simp, reassoc]
lemma lax_monoidal_functor.left_unitality_inv (F : lax_monoidal_functor C D) (X : C) :
  (λ_ (F.obj X)).inv ≫ (F.ε ⊗ 𝟙 (F.obj X)) ≫ F.μ (𝟙_ C) X = F.map (λ_ X).inv :=
begin
  rw [iso.inv_comp_eq, F.left_unitality, category.assoc, category.assoc,
    ←F.to_functor.map_comp, iso.hom_inv_id, F.to_functor.map_id, comp_id],
end

@[simp, reassoc]
lemma lax_monoidal_functor.right_unitality_inv (F : lax_monoidal_functor C D) (X : C) :
  (ρ_ (F.obj X)).inv ≫ (𝟙 (F.obj X) ⊗ F.ε) ≫ F.μ X (𝟙_ C) = F.map (ρ_ X).inv :=
begin
  rw [iso.inv_comp_eq, F.right_unitality, category.assoc, category.assoc,
    ←F.to_functor.map_comp, iso.hom_inv_id, F.to_functor.map_id, comp_id],
end

@[simp, reassoc]
lemma lax_monoidal_functor.associativity_inv (F : lax_monoidal_functor C D) (X Y Z : C) :
  (𝟙 (F.obj X) ⊗ F.μ Y Z) ≫ F.μ X (Y ⊗ Z) ≫ F.map (α_ X Y Z).inv =
    (α_ (F.obj X) (F.obj Y) (F.obj Z)).inv ≫ (F.μ X Y ⊗ 𝟙 (F.obj Z)) ≫ F.μ (X ⊗ Y) Z :=
begin
  rw [iso.eq_inv_comp, ←F.associativity_assoc,
    ←F.to_functor.map_comp, iso.hom_inv_id, F.to_functor.map_id, comp_id],
end

end

/--
A monoidal functor is a lax monoidal functor for which the tensorator and unitor as isomorphisms.

See <https://stacks.math.columbia.edu/tag/0FFL>.
-/
structure monoidal_functor
extends lax_monoidal_functor.{v₁ v₂} C D :=
(ε_is_iso            : is_iso ε . tactic.apply_instance)
(μ_is_iso            : Π X Y : C, is_iso (μ X Y) . tactic.apply_instance)

attribute [instance] monoidal_functor.ε_is_iso monoidal_functor.μ_is_iso

variables {C D}

/--
The unit morphism of a (strong) monoidal functor as an isomorphism.
-/
noncomputable
def monoidal_functor.ε_iso (F : monoidal_functor.{v₁ v₂} C D) :
  tensor_unit D ≅ F.obj (tensor_unit C) :=
as_iso F.ε

/--
The tensorator of a (strong) monoidal functor as an isomorphism.
-/
noncomputable
def monoidal_functor.μ_iso (F : monoidal_functor.{v₁ v₂} C D) (X Y : C) :
  (F.obj X) ⊗ (F.obj Y) ≅ F.obj (X ⊗ Y) :=
as_iso (F.μ X Y)

end

open monoidal_category

namespace lax_monoidal_functor

variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C]

/-- The identity lax monoidal functor. -/
@[simps] def id : lax_monoidal_functor.{v₁ v₁} C C :=
{ ε := 𝟙 _,
  μ := λ X Y, 𝟙 _,
  .. 𝟭 C }

instance : inhabited (lax_monoidal_functor C C) := ⟨id C⟩

end lax_monoidal_functor

namespace monoidal_functor

section
variables {C : Type u₁} [category.{v₁} C] [monoidal_category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]
variable (F : monoidal_functor.{v₁ v₂} C D)

lemma map_tensor {X Y X' Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
  F.map (f ⊗ g) = inv (F.μ X X') ≫ ((F.map f) ⊗ (F.map g)) ≫ F.μ Y Y' :=
by simp

lemma map_left_unitor (X : C) :
  F.map (λ_ X).hom = inv (F.μ (𝟙_ C) X) ≫ (inv F.ε ⊗ 𝟙 (F.obj X)) ≫ (λ_ (F.obj X)).hom :=
begin
  simp only [lax_monoidal_functor.left_unitality],
  slice_rhs 2 3 { rw ←comp_tensor_id, simp, },
  simp,
end

lemma map_right_unitor (X : C) :
  F.map (ρ_ X).hom = inv (F.μ X (𝟙_ C)) ≫ (𝟙 (F.obj X) ⊗ inv F.ε) ≫ (ρ_ (F.obj X)).hom :=
begin
  simp only [lax_monoidal_functor.right_unitality],
  slice_rhs 2 3 { rw ←id_tensor_comp, simp, },
  simp,
end

/-- The tensorator as a natural isomorphism. -/
noncomputable
def μ_nat_iso :
  (functor.prod F.to_functor F.to_functor) ⋙ (tensor D) ≅ (tensor C) ⋙ F.to_functor :=
nat_iso.of_components
  (by { intros, apply F.μ_iso })
  (by { intros, apply F.to_lax_monoidal_functor.μ_natural })

@[simp] lemma μ_iso_hom (X Y : C) : (F.μ_iso X Y).hom = F.μ X Y := rfl
@[simp, reassoc] lemma μ_inv_hom_id (X Y : C) : (F.μ_iso X Y).inv ≫ F.μ X Y = 𝟙 _ :=
(F.μ_iso X Y).inv_hom_id
@[simp] lemma μ_hom_inv_id (X Y : C) : F.μ X Y ≫ (F.μ_iso X Y).inv = 𝟙 _ :=
(F.μ_iso X Y).hom_inv_id

@[simp] lemma ε_iso_hom : F.ε_iso.hom = F.ε := rfl
@[simp, reassoc] lemma ε_inv_hom_id : F.ε_iso.inv ≫ F.ε = 𝟙 _ := F.ε_iso.inv_hom_id
@[simp] lemma ε_hom_inv_id : F.ε ≫ F.ε_iso.inv = 𝟙 _ := F.ε_iso.hom_inv_id

end

section
variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C]

/-- The identity monoidal functor. -/
@[simps] def id : monoidal_functor.{v₁ v₁} C C :=
{ ε := 𝟙 _,
  μ := λ X Y, 𝟙 _,
  .. 𝟭 C }

instance : inhabited (monoidal_functor C C) := ⟨id C⟩

end

end monoidal_functor

variables {C : Type u₁} [category.{v₁} C] [monoidal_category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E] [monoidal_category.{v₃} E]

namespace lax_monoidal_functor
variables (F : lax_monoidal_functor.{v₁ v₂} C D) (G : lax_monoidal_functor.{v₂ v₃} D E)

-- The proofs here are horrendous; rewrite_search helps a lot.
/-- The composition of two lax monoidal functors is again lax monoidal. -/
@[simps] def comp : lax_monoidal_functor.{v₁ v₃} C E :=
{ ε                := G.ε ≫ (G.map F.ε),
  μ                := λ X Y, G.μ (F.obj X) (F.obj Y) ≫ G.map (F.μ X Y),
  μ_natural'       := λ _ _ _ _ f g,
  begin
    simp only [functor.comp_map, assoc],
    rw [←category.assoc, lax_monoidal_functor.μ_natural, category.assoc, ←map_comp, ←map_comp,
        ←lax_monoidal_functor.μ_natural]
  end,
  associativity'   := λ X Y Z,
  begin
    dsimp,
    rw id_tensor_comp,
    slice_rhs 3 4 { rw [← G.to_functor.map_id, G.μ_natural], },
    slice_rhs 1 3 { rw ←G.associativity, },
    rw comp_tensor_id,
    slice_lhs 2 3 { rw [← G.to_functor.map_id, G.μ_natural], },
    rw [category.assoc, category.assoc, category.assoc, category.assoc, category.assoc,
        ←G.to_functor.map_comp, ←G.to_functor.map_comp, ←G.to_functor.map_comp,
        ←G.to_functor.map_comp, F.associativity],
  end,
  left_unitality'  := λ X,
  begin
    dsimp,
    rw [G.left_unitality, comp_tensor_id, category.assoc, category.assoc],
    apply congr_arg,
    rw [F.left_unitality, map_comp, ←nat_trans.id_app, ←category.assoc,
        ←lax_monoidal_functor.μ_natural, nat_trans.id_app, map_id, ←category.assoc, map_comp],
  end,
  right_unitality' := λ X,
  begin
    dsimp,
    rw [G.right_unitality, id_tensor_comp, category.assoc, category.assoc],
    apply congr_arg,
    rw [F.right_unitality, map_comp, ←nat_trans.id_app, ←category.assoc,
        ←lax_monoidal_functor.μ_natural, nat_trans.id_app, map_id, ←category.assoc, map_comp],
  end,
  .. (F.to_functor) ⋙ (G.to_functor) }.

infixr ` ⊗⋙ `:80 := comp

end lax_monoidal_functor

namespace lax_monoidal_functor
universes v₀ u₀
variables {B : Type u₀} [category.{v₀} B] [monoidal_category.{v₀} B]
variables (F : lax_monoidal_functor.{v₀ v₁} B C) (G : lax_monoidal_functor.{v₂ v₃} D E)

local attribute [simp] μ_natural associativity left_unitality right_unitality

/-- The cartesian product of two lax monoidal functors is lax monoidal. -/
@[simps]
def prod : lax_monoidal_functor (B × D) (C × E) :=
{ ε := (ε F, ε G),
  μ := λ X Y, (μ F X.1 Y.1, μ G X.2 Y.2),
  .. (F.to_functor).prod (G.to_functor) }

end lax_monoidal_functor

namespace monoidal_functor
variable (C)

/-- The diagonal functor as a monoidal functor. -/
@[simps]
def diag : monoidal_functor C (C × C) :=
{ ε := 𝟙 _,
  μ := λ X Y, 𝟙 _,
  .. functor.diag C }

end monoidal_functor

namespace lax_monoidal_functor
variables (F : lax_monoidal_functor.{v₁ v₂} C D) (G : lax_monoidal_functor.{v₁ v₃} C E)

/-- The cartesian product of two lax monoidal functors starting from the same monoidal category `C`
    is lax monoidal. -/
def prod' : lax_monoidal_functor C (D × E) :=
(monoidal_functor.diag C).to_lax_monoidal_functor ⊗⋙ (F.prod G)

@[simp] lemma prod'_to_functor :
  (F.prod' G).to_functor = (F.to_functor).prod' (G.to_functor) := rfl

@[simp] lemma prod'_ε : (F.prod' G).ε = (F.ε, G.ε) :=
by { dsimp [prod'], simp }

@[simp] lemma prod'_μ (X Y : C) : (F.prod' G).μ X Y = (F.μ X Y, G.μ X Y) :=
by { dsimp [prod'], simp }

end lax_monoidal_functor

namespace monoidal_functor

variables (F : monoidal_functor.{v₁ v₂} C D) (G : monoidal_functor.{v₂ v₃} D E)

/-- The composition of two monoidal functors is again monoidal. -/
@[simps]
def comp : monoidal_functor.{v₁ v₃} C E :=
{ ε_is_iso := by { dsimp, apply_instance },
  μ_is_iso := by { dsimp, apply_instance },
  .. (F.to_lax_monoidal_functor).comp (G.to_lax_monoidal_functor) }.

infixr ` ⊗⋙ `:80 := comp -- We overload notation; potentially dangerous, but it seems to work.

end monoidal_functor

namespace monoidal_functor
universes v₀ u₀
variables {B : Type u₀} [category.{v₀} B] [monoidal_category.{v₀} B]
variables (F : monoidal_functor.{v₀ v₁} B C) (G : monoidal_functor.{v₂ v₃} D E)

/-- The cartesian product of two monoidal functors is monoidal. -/
@[simps]
def prod : monoidal_functor (B × D) (C × E) :=
{ ε_is_iso := (is_iso_prod_iff C E).mpr ⟨ε_is_iso F, ε_is_iso G⟩,
  μ_is_iso := λ X Y, (is_iso_prod_iff C E).mpr ⟨μ_is_iso F X.1 Y.1, μ_is_iso G X.2 Y.2⟩,
  .. (F.to_lax_monoidal_functor).prod (G.to_lax_monoidal_functor) }

end monoidal_functor

namespace monoidal_functor
variables (F : monoidal_functor.{v₁ v₂} C D) (G : monoidal_functor.{v₁ v₃} C E)

/-- The cartesian product of two monoidal functors starting from the same monoidal category `C`
    is monoidal. -/
def prod' : monoidal_functor C (D × E) := diag C ⊗⋙ (F.prod G)

@[simp] lemma prod'_to_lax_monoidal_functor :
    (F.prod' G).to_lax_monoidal_functor
  = (F.to_lax_monoidal_functor).prod' (G.to_lax_monoidal_functor) := rfl

end monoidal_functor

/--
If we have a right adjoint functor `G` to a monoidal functor `F`, then `G` has a lax monoidal
structure as well.
-/
@[simps]
noncomputable
def monoidal_adjoint (F : monoidal_functor C D) {G : D ⥤ C} (h : F.to_functor ⊣ G) :
  lax_monoidal_functor D C :=
{ to_functor := G,
  ε := h.hom_equiv _ _ (inv F.ε),
  μ := λ X Y,
    h.hom_equiv _ (X ⊗ Y) (inv (F.μ (G.obj X) (G.obj Y)) ≫ (h.counit.app X ⊗ h.counit.app Y)),
  μ_natural' := λ X Y X' Y' f g,
  begin
    rw [←h.hom_equiv_naturality_left, ←h.hom_equiv_naturality_right, equiv.apply_eq_iff_eq, assoc,
      is_iso.eq_inv_comp, ←F.to_lax_monoidal_functor.μ_natural_assoc, is_iso.hom_inv_id_assoc,
      ←tensor_comp, adjunction.counit_naturality, adjunction.counit_naturality, tensor_comp],
  end,
  associativity' := λ X Y Z,
  begin
    rw [←h.hom_equiv_naturality_right, ←h.hom_equiv_naturality_left, ←h.hom_equiv_naturality_left,
      ←h.hom_equiv_naturality_left, equiv.apply_eq_iff_eq,
      ← cancel_epi (F.to_lax_monoidal_functor.μ (G.obj X ⊗ G.obj Y) (G.obj Z)),
      ← cancel_epi (F.to_lax_monoidal_functor.μ (G.obj X) (G.obj Y) ⊗ 𝟙 (F.obj (G.obj Z))),
      F.to_lax_monoidal_functor.associativity_assoc (G.obj X) (G.obj Y) (G.obj Z),
      ←F.to_lax_monoidal_functor.μ_natural_assoc, assoc, is_iso.hom_inv_id_assoc,
      ←F.to_lax_monoidal_functor.μ_natural_assoc, is_iso.hom_inv_id_assoc, ←tensor_comp,
      ←tensor_comp, id_comp, functor.map_id, functor.map_id, id_comp, ←tensor_comp_assoc,
      ←tensor_comp_assoc, id_comp, id_comp, h.hom_equiv_unit, h.hom_equiv_unit, functor.map_comp,
      assoc, assoc, h.counit_naturality, h.left_triangle_components_assoc, is_iso.hom_inv_id_assoc,
      functor.map_comp, assoc, h.counit_naturality, h.left_triangle_components_assoc,
      is_iso.hom_inv_id_assoc],
    exact associator_naturality (h.counit.app X) (h.counit.app Y) (h.counit.app Z),
  end,
  left_unitality' := λ X,
  begin
    rw [←h.hom_equiv_naturality_right, ←h.hom_equiv_naturality_left, ←equiv.symm_apply_eq,
      h.hom_equiv_counit, F.map_left_unitor, h.hom_equiv_unit, assoc, assoc, assoc, F.map_tensor,
      assoc, assoc, is_iso.hom_inv_id_assoc, ←tensor_comp_assoc, functor.map_id, id_comp,
      functor.map_comp, assoc, h.counit_naturality, h.left_triangle_components_assoc,
      ←left_unitor_naturality, ←tensor_comp_assoc, id_comp, comp_id],
  end,
  right_unitality' := λ X,
  begin
    rw [←h.hom_equiv_naturality_right, ←h.hom_equiv_naturality_left, ←equiv.symm_apply_eq,
      h.hom_equiv_counit, F.map_right_unitor, assoc, assoc, ←right_unitor_naturality,
      ←tensor_comp_assoc, comp_id, id_comp, h.hom_equiv_unit, F.map_tensor, assoc, assoc, assoc,
      is_iso.hom_inv_id_assoc, functor.map_comp, functor.map_id, ←tensor_comp_assoc, assoc,
      h.counit_naturality, h.left_triangle_components_assoc, id_comp],
  end }.

/-- If a monoidal functor `F` is an equivalence of categories then its inverse is also monoidal. -/
@[simps]
noncomputable
def monoidal_inverse (F : monoidal_functor C D) [is_equivalence F.to_functor] :
  monoidal_functor D C :=
{ to_lax_monoidal_functor := monoidal_adjoint F (as_equivalence _).to_adjunction,
  ε_is_iso := by { dsimp [equivalence.to_adjunction], apply_instance },
  μ_is_iso := λ X Y, by { dsimp [equivalence.to_adjunction], apply_instance } }

end category_theory


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import logic.basic

/-!
# Nonempty types

This file proves a few extra facts about `nonempty`, which is defined in core Lean.

## Main declarations

* `nonempty.some`: Extracts a witness of nonemptiness using choice. Takes `nonempty α` explicitly.
* `classical.arbitrary`: Extracts a witness of nonemptiness using choice. Takes `nonempty α` as an
  instance.
-/

variables {α β : Type*} {γ : α → Type*}

attribute [simp] nonempty_of_inhabited

@[priority 20]
instance has_zero.nonempty [has_zero α] : nonempty α := ⟨0⟩
@[priority 20]
instance has_one.nonempty [has_one α] : nonempty α := ⟨1⟩

lemma exists_true_iff_nonempty {α : Sort*} : (∃a:α, true) ↔ nonempty α :=
iff.intro (λ⟨a, _⟩, ⟨a⟩) (λ⟨a⟩, ⟨a, trivial⟩)

@[simp] lemma nonempty_Prop {p : Prop} : nonempty p ↔ p :=
iff.intro (assume ⟨h⟩, h) (assume h, ⟨h⟩)

lemma not_nonempty_iff_imp_false {α : Sort*} : ¬ nonempty α ↔ α → false :=
⟨λ h a, h ⟨a⟩, λ h ⟨a⟩, h a⟩

@[simp] lemma nonempty_sigma : nonempty (Σa:α, γ a) ↔ (∃a:α, nonempty (γ a)) :=
iff.intro (assume ⟨⟨a, c⟩⟩, ⟨a, ⟨c⟩⟩) (assume ⟨a, ⟨c⟩⟩, ⟨⟨a, c⟩⟩)

@[simp] lemma nonempty_subtype {α} {p : α → Prop} : nonempty (subtype p) ↔ (∃a:α, p a) :=
iff.intro (assume ⟨⟨a, h⟩⟩, ⟨a, h⟩) (assume ⟨a, h⟩, ⟨⟨a, h⟩⟩)

@[simp] lemma nonempty_prod : nonempty (α × β) ↔ (nonempty α ∧ nonempty β) :=
iff.intro (assume ⟨⟨a, b⟩⟩, ⟨⟨a⟩, ⟨b⟩⟩) (assume ⟨⟨a⟩, ⟨b⟩⟩, ⟨⟨a, b⟩⟩)

@[simp] lemma nonempty_pprod {α β} : nonempty (pprod α β) ↔ (nonempty α ∧ nonempty β) :=
iff.intro (assume ⟨⟨a, b⟩⟩, ⟨⟨a⟩, ⟨b⟩⟩) (assume ⟨⟨a⟩, ⟨b⟩⟩, ⟨⟨a, b⟩⟩)

@[simp] lemma nonempty_sum : nonempty (α ⊕ β) ↔ (nonempty α ∨ nonempty β) :=
iff.intro
  (assume ⟨h⟩, match h with sum.inl a := or.inl ⟨a⟩ | sum.inr b := or.inr ⟨b⟩ end)
  (assume h, match h with or.inl ⟨a⟩ := ⟨sum.inl a⟩ | or.inr ⟨b⟩ := ⟨sum.inr b⟩ end)

@[simp] lemma nonempty_psum {α β} : nonempty (psum α β) ↔ (nonempty α ∨ nonempty β) :=
iff.intro
  (assume ⟨h⟩, match h with psum.inl a := or.inl ⟨a⟩ | psum.inr b := or.inr ⟨b⟩ end)
  (assume h, match h with or.inl ⟨a⟩ := ⟨psum.inl a⟩ | or.inr ⟨b⟩ := ⟨psum.inr b⟩ end)

@[simp] lemma nonempty_psigma {α} {β : α → Sort*} : nonempty (psigma β) ↔ (∃a:α, nonempty (β a)) :=
iff.intro (assume ⟨⟨a, c⟩⟩, ⟨a, ⟨c⟩⟩) (assume ⟨a, ⟨c⟩⟩, ⟨⟨a, c⟩⟩)

@[simp] lemma nonempty_empty : ¬ nonempty empty :=
assume ⟨h⟩, h.elim

@[simp] lemma nonempty_ulift : nonempty (ulift α) ↔ nonempty α :=
iff.intro (assume ⟨⟨a⟩⟩, ⟨a⟩) (assume ⟨a⟩, ⟨⟨a⟩⟩)

@[simp] lemma nonempty_plift {α} : nonempty (plift α) ↔ nonempty α :=
iff.intro (assume ⟨⟨a⟩⟩, ⟨a⟩) (assume ⟨a⟩, ⟨⟨a⟩⟩)

@[simp] lemma nonempty.forall {α} {p : nonempty α → Prop} : (∀h:nonempty α, p h) ↔ (∀a, p ⟨a⟩) :=
iff.intro (assume h a, h _) (assume h ⟨a⟩, h _)

@[simp] lemma nonempty.exists {α} {p : nonempty α → Prop} : (∃h:nonempty α, p h) ↔ (∃a, p ⟨a⟩) :=
iff.intro (assume ⟨⟨a⟩, h⟩, ⟨a, h⟩) (assume ⟨a, h⟩, ⟨⟨a⟩, h⟩)

lemma classical.nonempty_pi {α} {β : α → Sort*} : nonempty (Πa:α, β a) ↔ (∀a:α, nonempty (β a)) :=
iff.intro (assume ⟨f⟩ a, ⟨f a⟩) (assume f, ⟨assume a, classical.choice $ f a⟩)

/-- Using `classical.choice`, lifts a (`Prop`-valued) `nonempty` instance to a (`Type`-valued)
  `inhabited` instance. `classical.inhabited_of_nonempty` already exists, in
  `core/init/classical.lean`, but the assumption is not a type class argument,
  which makes it unsuitable for some applications. -/
noncomputable def classical.inhabited_of_nonempty' {α} [h : nonempty α] : inhabited α :=
⟨classical.choice h⟩

/-- Using `classical.choice`, extracts a term from a `nonempty` type. -/
@[reducible] protected noncomputable def nonempty.some {α} (h : nonempty α) : α :=
classical.choice h

/-- Using `classical.choice`, extracts a term from a `nonempty` type. -/
@[reducible] protected noncomputable def classical.arbitrary (α) [h : nonempty α] : α :=
classical.choice h

/-- Given `f : α → β`, if `α` is nonempty then `β` is also nonempty.
  `nonempty` cannot be a `functor`, because `functor` is restricted to `Type`. -/
lemma nonempty.map {α β} (f : α → β) : nonempty α → nonempty β
| ⟨h⟩ := ⟨f h⟩

protected lemma nonempty.map2 {α β γ : Sort*} (f : α → β → γ) : nonempty α → nonempty β → nonempty γ
| ⟨x⟩ ⟨y⟩ := ⟨f x y⟩

protected lemma nonempty.congr {α β} (f : α → β) (g : β → α) :
  nonempty α ↔ nonempty β :=
⟨nonempty.map f, nonempty.map g⟩

lemma nonempty.elim_to_inhabited {α : Sort*} [h : nonempty α] {p : Prop}
  (f : inhabited α → p) : p :=
h.elim $ f ∘ inhabited.mk

instance {α β} [h : nonempty α] [h2 : nonempty β] : nonempty (α × β) :=
h.elim $ λ g, h2.elim $ λ g2, ⟨⟨g, g2⟩⟩

lemma subsingleton_of_not_nonempty {α : Sort*} (h : ¬ nonempty α) : subsingleton α :=
⟨λ x, false.elim $ not_nonempty_iff_imp_false.mp h x⟩