/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl
-/
import category_theory.fully_faithful
import data.equiv.basic

/-!
# The category `Type`.

In this section we set up the theory so that Lean's types and functions between them
can be viewed as a `large_category` in our framework.

Lean can not transparently view a function as a morphism in this category, and needs a hint in
order to be able to type check. We provide the abbreviation `as_hom f` to guide type checking,
as well as a corresponding notation `↾ f`. (Entered as `\upr `.) The notation is enabled using
`open_locale category_theory.Type`.

We provide various simplification lemmas for functors and natural transformations valued in `Type`.

We define `ulift_functor`, from `Type u` to `Type (max u v)`, and show that it is fully faithful
(but not, of course, essentially surjective).

We prove some basic facts about the category `Type`:
*  epimorphisms are surjections and monomorphisms are injections,
* `iso` is both `iso` and `equiv` to `equiv` (at least within a fixed universe),
* every type level `is_lawful_functor` gives a categorical functor `Type ⥤ Type`
  (the corresponding fact about monads is in `src/category_theory/monad/types.lean`).
-/

namespace category_theory

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

/- The `@[to_additive]` attribute is just a hint that expressions involving this instance can
  still be additivized. -/
@[to_additive category_theory.types]
instance types : large_category (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

lemma types_hom {α β : Type u} : (α ⟶ β) = (α → β) := rfl
lemma types_id (X : Type u) : 𝟙 X = id := rfl
lemma types_comp {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f := rfl

@[simp]
lemma types_id_apply (X : Type u) (x : X) : ((𝟙 X) : X → X) x = x := rfl
@[simp]
lemma types_comp_apply {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) := rfl

@[simp]
lemma hom_inv_id_apply {X Y : Type u} (f : X ≅ Y) (x : X) : f.inv (f.hom x) = x :=
congr_fun f.hom_inv_id x
@[simp]
lemma inv_hom_id_apply {X Y : Type u} (f : X ≅ Y) (y : Y) : f.hom (f.inv y) = y :=
congr_fun f.inv_hom_id y

/-- `as_hom f` helps Lean type check a function as a morphism in the category `Type`. -/
-- Unfortunately without this wrapper we can't use `category_theory` idioms, such as `is_iso f`.
abbreviation as_hom {α β : Type u} (f : α → β) : α ⟶ β := f
-- If you don't mind some notation you can use fewer keystrokes:
localized "notation  `↾` f : 200 := as_hom f" in category_theory.Type -- type as \upr in VScode

section -- We verify the expected type checking behaviour of `as_hom`.
variables (α β γ : Type u) (f : α → β) (g : β → γ)

example : α → γ := ↾f ≫ ↾g
example [is_iso ↾f] : mono ↾f := by apply_instance
example [is_iso ↾f] : ↾f ≫ inv ↾f = 𝟙 α := by simp
end

namespace functor
variables {J : Type u} [category.{v} J]

/--
The sections of a functor `J ⥤ Type` are
the choices of a point `u j : F.obj j` for each `j`,
such that `F.map f (u j) = u j` for every morphism `f : j ⟶ j'`.

We later use these to define limits in `Type` and in many concrete categories.
-/
def sections (F : J ⥤ Type w) : set (Π j, F.obj j) :=
{ u | ∀ {j j'} (f : j ⟶ j'), F.map f (u j) = u j'}
end functor

namespace functor_to_types
variables {C : Type u} [category.{v} C] (F G H : C ⥤ Type w) {X Y Z : C}
variables (σ : F ⟶ G) (τ : G ⟶ H)

@[simp] lemma map_comp_apply (f : X ⟶ Y) (g : Y ⟶ Z) (a : F.obj X) :
  (F.map (f ≫ g)) a = (F.map g) ((F.map f) a) :=
by simp [types_comp]

@[simp] lemma map_id_apply (a : F.obj X) : (F.map (𝟙 X)) a = a :=
by simp [types_id]

lemma naturality (f : X ⟶ Y) (x : F.obj X) : σ.app Y ((F.map f) x) = (G.map f) (σ.app X x) :=
congr_fun (σ.naturality f) x

@[simp] lemma comp (x : F.obj X) : (σ ≫ τ).app X x = τ.app X (σ.app X x) := rfl

variables {D : Type u'} [𝒟 : category.{u'} D] (I J : D ⥤ C) (ρ : I ⟶ J) {W : D}

@[simp] lemma hcomp (x : (I ⋙ F).obj W) :
  (ρ ◫ σ).app W x = (G.map (ρ.app W)) (σ.app (I.obj W) x) :=
rfl

@[simp]

@[simp] lemma hom_inv_id_app_apply (α : F ≅ G) (X) (x) : α.inv.app X (α.hom.app X x) = x :=
congr_fun (α.hom_inv_id_app X) x
@[simp] lemma inv_hom_id_app_apply (α : F ≅ G) (X) (x) : α.hom.app X (α.inv.app X x) = x :=
congr_fun (α.inv_hom_id_app X) x

end functor_to_types

/--
The isomorphism between a `Type` which has been `ulift`ed to the same universe,
and the original type.
-/
def ulift_trivial (V : Type u) : ulift.{u} V ≅ V := by tidy

/--
The functor embedding `Type u` into `Type (max u v)`.
Write this as `ulift_functor.{5 2}` to get `Type 2 ⥤ Type 5`.
-/
def ulift_functor : Type u ⥤ Type (max u v) :=
{ obj := λ X, ulift.{v} X,
  map := λ X Y f, λ x : ulift.{v} X, ulift.up (f x.down) }

@[simp] lemma ulift_functor_map {X Y : Type u} (f : X ⟶ Y) (x : ulift.{v} X) :
  ulift_functor.map f x = ulift.up (f x.down) := rfl

instance ulift_functor_full : full.{u} ulift_functor :=
{ preimage := λ X Y f x, (f (ulift.up x)).down }
instance ulift_functor_faithful : faithful ulift_functor :=
{ map_injective' := λ X Y f g p, funext $ λ x,
    congr_arg ulift.down ((congr_fun p (ulift.up x)) : ((ulift.up (f x)) = (ulift.up (g x)))) }

/--
The functor embedding `Type u` into `Type u` via `ulift` is isomorphic to the identity functor.
 -/
def ulift_functor_trivial : ulift_functor.{u u} ≅ 𝟭 _ :=
nat_iso.of_components ulift_trivial (by tidy)

/-- Any term `x` of a type `X` corresponds to a morphism `punit ⟶ X`. -/
-- TODO We should connect this to a general story about concrete categories
-- whose forgetful functor is representable.
def hom_of_element {X : Type u} (x : X) : punit ⟶ X := λ _, x

lemma hom_of_element_eq_iff {X : Type u} (x y : X) :
  hom_of_element x = hom_of_element y ↔ x = y :=
⟨λ H, congr_fun H punit.star, by cc⟩

/--
A morphism in `Type` is a monomorphism if and only if it is injective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma mono_iff_injective {X Y : Type u} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { intros H x x' h,
    resetI,
    rw ←hom_of_element_eq_iff at ⊢ h,
    exact (cancel_mono f).mp h },
  { refine λ H, ⟨λ Z g h H₂, _⟩,
    ext z,
    replace H₂ := congr_fun H₂ z,
    exact H H₂ }
end

/--
A morphism in `Type` is an epimorphism if and only if it is surjective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma epi_iff_surjective {X Y : Type u} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { intros H,
    let g : Y ⟶ ulift Prop := λ y, ⟨true⟩,
    let h : Y ⟶ ulift Prop := λ y, ⟨∃ x, f x = y⟩,
    suffices : f ≫ g = f ≫ h,
    { resetI,
      rw cancel_epi at this,
      intro y,
      replace this := congr_fun this y,
      replace this : true = ∃ x, f x = y := congr_arg ulift.down this,
      rw ←this,
      trivial },
    ext x,
    change true ↔ ∃ x', f x' = f x,
    rw true_iff,
    exact ⟨x, rfl⟩ },
  { intro H,
    constructor,
    intros Z g h H₂,
    apply funext,
    rw ←forall_iff_forall_surj H,
    intro x,
    exact (congr_fun H₂ x : _) }
end

section

/-- `of_type_functor m` converts from Lean's `Type`-based `category` to `category_theory`. This
allows us to use these functors in category theory. -/
def of_type_functor (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m] :
  Type u ⥤ Type v :=
{ obj       := m,
  map       := λα β, _root_.functor.map,
  map_id'   := assume α, _root_.functor.map_id,
  map_comp' := assume α β γ f g, funext $ assume a, is_lawful_functor.comp_map f g _ }

variables (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m]

@[simp]
lemma of_type_functor_obj : (of_type_functor m).obj = m := rfl

@[simp]
lemma of_type_functor_map {α β} (f : α → β) :
  (of_type_functor m).map f = (_root_.functor.map f : m α → m β) := rfl

end

end category_theory

-- Isomorphisms in Type and equivalences.

namespace equiv

universe u

variables {X Y : Type u}

/--
Any equivalence between types in the same universe gives
a categorical isomorphism between those types.
-/
def to_iso (e : X ≃ Y) : X ≅ Y :=
{ hom := e.to_fun,
  inv := e.inv_fun,
  hom_inv_id' := funext e.left_inv,
  inv_hom_id' := funext e.right_inv }

@[simp] lemma to_iso_hom {e : X ≃ Y} : e.to_iso.hom = e := rfl
@[simp] lemma to_iso_inv {e : X ≃ Y} : e.to_iso.inv = e.symm := rfl

end equiv

universe u

namespace category_theory.iso
open category_theory

variables {X Y : Type u}

/--
Any isomorphism between types gives an equivalence.
-/
def to_equiv (i : X ≅ Y) : X ≃ Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := λ x, congr_fun i.hom_inv_id x,
  right_inv := λ y, congr_fun i.inv_hom_id y }

@[simp] lemma to_equiv_fun (i : X ≅ Y) : (i.to_equiv : X → Y) = i.hom := rfl
@[simp] lemma to_equiv_symm_fun (i : X ≅ Y) : (i.to_equiv.symm : Y → X) = i.inv := rfl

@[simp] lemma to_equiv_id (X : Type u) : (iso.refl X).to_equiv = equiv.refl X := rfl
@[simp] lemma to_equiv_comp {X Y Z : Type u} (f : X ≅ Y) (g : Y ≅ Z) :
  (f ≪≫ g).to_equiv = f.to_equiv.trans (g.to_equiv) := rfl

end category_theory.iso

namespace category_theory

/-- A morphism in `Type u` is an isomorphism if and only if it is bijective. -/
lemma is_iso_iff_bijective {X Y : Type u} (f : X ⟶ Y) : is_iso f ↔ function.bijective f :=
iff.intro
  (λ i, (by exactI as_iso f : X ≅ Y).to_equiv.bijective)
  (λ b, is_iso.of_iso (equiv.of_bijective f b).to_iso)

end category_theory

-- We prove `equiv_iso_iso` and then use that to sneakily construct `equiv_equiv_iso`.
-- (In this order the proofs are handled by `obviously`.)

/-- Equivalences (between types in the same universe) are the same as (isomorphic to) isomorphisms
of types. -/
@[simps] def equiv_iso_iso {X Y : Type u} : (X ≃ Y) ≅ (X ≅ Y) :=
{ hom := λ e, e.to_iso,
  inv := λ i, i.to_equiv, }

/-- Equivalences (between types in the same universe) are the same as (equivalent to) isomorphisms
of types. -/
def equiv_equiv_iso {X Y : Type u} : (X ≃ Y) ≃ (X ≅ Y) :=
(equiv_iso_iso).to_equiv

@[simp] lemma equiv_equiv_iso_hom {X Y : Type u} (e : X ≃ Y) :
  equiv_equiv_iso e = e.to_iso := rfl

@[simp] lemma equiv_equiv_iso_inv {X Y : Type u} (e : X ≅ Y) :
  equiv_equiv_iso.symm e = e.to_equiv := rfl


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn.

A lecture on mathlib.
-/
import data.rat.basic tactic.norm_num

/-
  You can find mathlib at https://github.com/leanprover-community/mathlib/

  It was started in July 2017 to separate the mathematics library from the core library.
  The core library is part on Lean: https://github.com/leanprover/lean/tree/master/library

  Initially the main developer of mathlib was Mario Carneiro

  Currently, has 9 maintainers: Jeremy Avigad, Reid Barton, Mario Carneiro, Johan Commelin,
  Sébastien Gouëzel, Simon Hudon, Chris Hughes, Robert Y. Lewis and Patrick Massot.
-/

/-
  Contents
  * Data -- number systems, sets, equiv (bijections), lists, polynomials and much more
  * Algebra -- mostly equations and basic lemmas, some instances
    * Group Theory
    * Ring Theory
    * Field Theory
    * Linear Algebra
    * Order
  * Analysis -- still lacking, has Frechet derivative, Lebesque integral (mostly), but not much theorems about either, and also not specialized to special cases
    * Topology
    * Measure Theory
  * Number Theory -- very little content
  * Logic -- basic logic, much of it is also in core
    * Category Theory
    * Set Theory -- cardinal and ordinal numbers
  * Meta(programming)
    * Tactics -- many useful tactics are defined here
    * Category -- do not confuse with category theory.
-/

/-
  Navigating mathlib
  * "Go to definition" and "peek definition"
  * Browse through files
  * Search in VSCode
  * Search on Github
  * Potentially: `#print prefix` and `#print instances`
-/
-- useful: alt+left (option+cmd+left on Mac) to jump to previous location
-- or use ctrl+tab (option+cmd+tab on Mac) to navigate between VSCode tabs.
#print is_group_hom
#check tactic.assumption
#print prefix nat
#print instances group

/-
  Use the command `update-mathlib` to download compiled version of mathlib.

  To get this command,
  * make sure you have Python installed
  * Now in a terminal (on Windows use `git bash`), type:
  ```
    curl https://raw.githubusercontent.com/leanprover-community/mathlib-tools/master/scripts/remote-install-update-mathlib.sh -sSf | bash
  ```
  * For more information, see
    https://github.com/leanprover-community/mathlib/tree/master/docs/install
-/

/-
  If you want to make a new project depending on mathlib, you can execute (in a command line)
  ```
    mkdir my_project
    cd my_project
    leanpkg init my_project
    leanpkg add leanprover-community/mathlib
    update-mathlib
  ```
  If you clone a repository (assuming it already has a leanpkg.toml file):
  ```
    git clone https://www.github.com/<username>/<project>
    cd <project>
    leanpkg configure
    update-mathlib
  ```
  To update mathlib, run
  ```
    leanpkg upgrade
    update-mathlib
  ```
-/

/-
  Contributing to mathlib:
  https://github.com/leanprover-community/mathlib/blob/master/docs/contribute/index.md
  * Use Zulip to discuss your contribution before and while you are working on it.
    https://leanprover.zulipchat.com/
  * If you are done, make a pull request on Github. After that it will be reviewed.
-/

/- If `e : t` then `e.foo` is the same as `t.foo e`-/
example (n m : ℕ) : nat.gcd n m = n.gcd m :=
by reflexivity

lemma mul_eq_mul_left {α} [integral_domain α] {a b c : α} (ha : a ≠ 0) :
  a * b = a * c ↔ b = c :=
⟨eq_of_mul_eq_mul_left ha, λ h, by rw h⟩

open rat
local infix ` /. `:70 := mk
lemma rat.coe_num_eq_iff (r : ℚ) :
  (r.num : ℚ) = r ↔ r.denom = 1 :=
begin
  rw [coe_int_eq_mk],
  conv { to_lhs, to_rhs, rw [num_denom r] },
  rw [mk_eq],
  { by_cases h : r.num = 0,
    { simpa [h] using r.cop },
    { rw [mul_eq_mul_left h], norm_cast }
   },
   norm_num,
   simpa using r.denom_ne_zero
end


/- This file defines all the iff-lemmas. These are used to lift transitions into Lean's logic.-/
import tactic
import tactic.induction
import data.option.basic
import .transition

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

lemma transition.atom_iff (a b : α) (z) : transition (atom a) b z ↔ z = none ∧ (a ≠ 0) ∧ b = a :=
begin
  split,
  { intro h,
    cases h,
    exact ⟨rfl, h_h, rfl⟩ },
  { rintro ⟨rfl, h, rfl⟩,
    exact transition.atom h}
end

lemma transition.alt_iff (x y : mcrl2 α) (a z) : transition (x + y) a z ↔ transition x a z ∨ transition y a z :=
begin
  split,
  { rintro (h | h),
    { left, assumption },
    { right, assumption } },
  { rintro (h | h),
    { exact transition.altl h },
    { exact transition.altr h } }
end

lemma transition.seq_iff (x y : mcrl2 α) (a : α) (z) : transition (x ⬝ y) a z ↔ (∃ x', z = seq' x' y ∧ transition x a x') :=
begin
  split,
  { rintro (h | _),
    exact ⟨_, rfl, by assumption⟩ },
  { rintro ⟨x', rfl, h⟩,
    exact transition.seq h }
end

lemma transition.parl_iff (x y : mcrl2 α) (a z) : transition (x |_ y) a z ↔ (∃ x', z = par' x' y ∧ transition x a x') :=
begin
  split,
  { rintro (h | _),
    exact ⟨_, rfl, by assumption⟩ },
  { rintro (⟨x', rfl, h⟩),
    exact transition.parl h  }
end

/- This states that x || y has a transition if you can execute from x, from y, or a communication between x and y.-/
lemma transition.par_iff (x y : mcrl2 α) (a z) : transition (x || y) a z ↔
  (∃ x', z = par' x' y ∧ transition x a x') ∨
  (∃ y', z = par' x y' ∧ transition y a y') ∨
  (∃ x' y', z = par' x' y' ∧ ∃ a' b', a ≠ 0 ∧ a = a' * b' ∧ transition x a' x' ∧ transition y b' y') :=
begin
  split,
  { intro h, cases h,
    { exact or.inl ⟨h_x', rfl, (by assumption)⟩ },
    { exact or.inr (or.inl ⟨h_y', rfl, (by assumption)⟩) },
    { exact or.inr (or.inr ⟨h_x', h_y', rfl, h_a, h_b, h_h₃, rfl, h_h₁, h_h₂⟩)}},
  { rintro (⟨x', rfl, h⟩ | ⟨y', rfl, h⟩ | ⟨x', y', rfl, a', b', ha, rfl, hx, hy⟩),
    { exact transition.par_l h },
    { exact transition.par_r h },
    { exact transition.par_comm hx hy ha } }
end

lemma transition.comm_iff (x y : mcrl2 α) (a z) : transition (x ∣ y) a z ↔
  (∃ x' y', z = par' x' y' ∧ ∃ a' b', a = a' * b' ∧ a ≠ 0 ∧ transition x a' x' ∧ transition y b' y') :=
begin
  split,
  { intro h,
    cases h,
    exact ⟨h_x', h_y', rfl, h_a, h_b, rfl, (by assumption), (by assumption), (by assumption)⟩ },
  { rintro ⟨x', y', rfl, a', b', rfl, ha, hx, hy⟩,
    { exact transition.comm hx hy ha} }
end

lemma transition.no_zero {x : mcrl2 α} {z: option (mcrl2 α)} : ¬transition x 0 z :=
begin
  intro h,
  induction' h ; try { assumption },
  repeat {contradiction}
end

lemma transition.encap_iff (x : mcrl2 α) (a : α) (y A) : transition (encap A x) a y ↔
(∃ y', y = encap A <$> y' ∧ (transition x a y')) ∧ a ∉ A :=
begin
  apply iff.intro,
  { intro h,
    cases h,
    cases h_y,
    { apply and.intro,
      apply exists.intro none,
      simp,
      repeat {assumption}},
    { apply and.intro,
      apply exists.intro (some h_y),
      simp,
      repeat {assumption}}},
  { intro h,
    cases h with l r,
    rcases l with ⟨w, h_w₁, h_w₂⟩,
    rw h_w₁,
    apply transition.encap_pass; assumption}
end

lemma transition.deadlock_iff (a z) :
transition (δ : mcrl2 α) a z ↔ false :=
begin
  simp,
  intro h,
  cases h
end

lemma transition.sum_iff (β : Type) (A : set β) (f : β → mcrl2 α) ( a z) :
transition (sum A f) a z ↔ (∃a': β, a' ∈ A ∧ transition (f a') a z) :=
begin
  split,
  { intro h,
    cases h,
    exact ⟨h_a', h_ha', h_h⟩},
  { intro h,
    rcases h with ⟨a', ha', h⟩,
    apply transition.sum; assumption}
end


import data.finset.basic

theorem AIME_2021_I_5 (a b:ℕ)(h:(a-b)^2+a^2+(a+b)^2=a*b^2):
(a=5∧ b=5)∨ (a=14∧b=7)
:=
begin
  sorry
end


import hilbert.wr.ka

namespace clfrags
    namespace hilbert
        namespace wr
            namespace ka

                theorem ka₀ {a b c : Prop} (h₁ : ka a b c) : a :=
                    have h₃ : ka (ka a b c) (ka a b c) a, from ka₁ h₁ h₁,
                    have h₄ : ka (ka a b c) a (ka a b c), from ka₃ h₃,
                    have h₅ : ka (ka a b c) a a, from ka₆ h₄,
                    show a, from ka₂ h₅

                theorem ka₄' {a b c d : Prop} (h₁ : ka a (ka a b c) d) : ka a b (ka a c d) :=
                    have h₂ : ka a d (ka a b c), from ka₃ h₁,
                    have h₃ : ka a (ka a d b) c, from ka₄ h₂,
                    have h₄ : ka a c (ka a d b), from ka₃ h₃,
                    have h₅ : ka a (ka a c d) b, from ka₄ h₄,
                    show ka a b (ka a c d), from ka₃ h₅

                theorem ka₈ {a b c : Prop} (h₁ : ka a b (ka a c c)) : ka a b c :=
                    have h₂ : ka a (ka a b c) c, from ka₄ h₁,
                    have h₃ : ka a c (ka a b c), from ka₃ h₂,
                    have h₄ : a, from ka₀ h₂,
                    have h₅ : ka a (ka a c (ka a b c)) b, from ka₁ h₄ h₃,
                    have h₆ : ka a b (ka a c (ka a b c)), from ka₃ h₅,
                    have h₇ : ka a (ka a b c) (ka a b c), from ka₄ h₆,
                    show ka a b c, from ka₂ h₇

                theorem ka₁_ka {a b c d e : Prop} (h₁ : ka e d a) (h₂ : ka e d b) : ka e d (ka a b c) :=
                    have h₃ : e, from ka₀ h₂,
                    have h₄ : ka e (ka e d b) c, from ka₁ h₃ h₂,
                    have h₅ : ka e d (ka e b c), from ka₄' h₄,
                    show ka e d (ka a b c), from ka₅ h₁ h₅

                theorem ka₂_ka {a b c d : Prop} (h₁ : ka d c (ka a b b)) : ka d c b :=
                    have h₂ : ka d c (ka d b b), from ka₇ h₁,
                    show ka d c b, from ka₈ h₂

                theorem ka₃_ka {a b c d e : Prop} (h₁ : ka e d (ka a b c)) : ka e d (ka a c b) :=
                    have h₂ : e, from ka₀ h₁,
                    have h₃ : ka e d a, from ka₆ h₁,
                    have h₄ : ka e d (ka e b c), from ka₇ h₁,
                    have h₅ : ka e (ka e d b) c, from ka₄ h₄,
                    have h₆ : ka e (ka e (ka e d b) c) b, from ka₁ h₂ h₅,
                    have h₇ : ka e (ka e d b) (ka e c b), from ka₄' h₆,
                    have h₈ : ka e d (ka e b (ka e c b)), from ka₄' h₇,
                    have h₉ : ka e (ka e b (ka e c b)) d, from ka₃ h₈,
                    have h₁₀ : ka e b (ka e (ka e c b) d), from ka₄' h₉,
                    have h₁₁ : ka e (ka e b (ka e (ka e c b) d)) c, from ka₁ h₂ h₁₀,
                    have h₁₂ : ka e c (ka e b (ka e (ka e c b) d)), from ka₃ h₁₁,
                    have h₁₃ : ka e (ka e c b) (ka e (ka e c b) d), from ka₄ h₁₂,
                    have h₁₄ : ka e (ka e (ka e c b) (ka e c b)) d, from ka₄ h₁₃,
                    have h₁₅ : ka e d (ka e (ka e c b) (ka e c b)), from ka₃ h₁₄,
                    have h₁₆ : ka e d (ka e c b), from ka₂_ka h₁₅,
                    show ka e d (ka a c b), from ka₅ h₃ h₁₆

                theorem ka₄_ka {a b c d e f : Prop} (h₁ : ka f e (ka a b (ka a c d))) :
                    ka f e (ka a (ka a b c) d):=
                    have h₂ : ka f e (ka f b (ka a c d)), from ka₇ h₁,
                    have h₃ : ka f (ka f e b) (ka a c d), from ka₄ h₂,
                    have h₄ : ka f (ka f e b) (ka f c d), from ka₇ h₃,
                    have h₅ : ka f (ka f e b) (ka f d c), from ka₃_ka h₄,
                    have h₆ : ka f (ka f (ka f e b) d) c, from ka₄ h₅,
                    have h₇ : f, from ka₀ h₁,
                    have h₈ : ka f (ka f (ka f (ka f e b) d) c) b, from ka₁ h₇ h₆,
                    have h₉ : ka f (ka f (ka f e b) d) (ka f c b), from ka₄' h₈,
                    have h₁₀ : ka f (ka f (ka f e b) d) (ka f b c), from ka₃_ka h₉,
                    have h₁₁ : ka f (ka f e b) (ka f d (ka f b c)), from ka₄' h₁₀,
                    have h₁₂ : ka f (ka f e b) (ka f (ka f b c) d), from ka₃_ka h₁₁,
                    let g := ka f (ka f b c) d in
                        have h₁₃ : ka f (ka f e b) g, from h₁₂,
                        have h₁₄ : ka f e (ka f b g), from ka₄' h₁₃,
                        have h₁₅ : ka f e (ka f g b), from ka₃_ka h₁₄,
                        have h₁₆ : ka f (ka f e g) b, from ka₄ h₁₅,
                        have h₁₇ : ka f (ka f (ka f e g) b) c, from ka₁ h₇ h₁₆,
                        have h₁₈ : ka f (ka f e g) (ka f b c), from ka₄' h₁₇,
                        have h₁₉ : ka f (ka f (ka f e g) (ka f b c)) d, from ka₁ h₇ h₁₈,
                        have h₂₀ : ka f (ka f e g) (ka f (ka f b c) d), from ka₄' h₁₉,
                        have h₂₁ : ka f (ka f e g) g, from h₂₀,
                        have h₂₂ : ka f e (ka f g g), from ka₄' h₂₁,
                        have h₂₃ : ka f e g, from ka₂_ka h₂₂,
                        have h₂₄ : ka f e (ka f (ka f b c) d), from h₂₃,
                        have h₂₅ : ka f e a, from ka₆ h₁,
                        have h₂₆ : ka f (ka f e a) d, from ka₁ h₇ h₂₅,
                        have h₂₇ : ka f e (ka f a d), from ka₄' h₂₆,
                        have h₂₈ : ka f e (ka f d a), from ka₃_ka h₂₇,
                        have h₂₉ : ka f (ka f e d) a, from ka₄ h₂₈,
                        have h₃₀ : ka f e (ka f d (ka f b c)), from ka₃_ka h₂₄,
                        have h₃₁ : ka f (ka f e d) (ka f b c), from ka₄ h₃₀,
                        have h₃₂ : ka f (ka f e d) (ka a b c), from ka₅ h₂₉ h₃₁,
                        have h₃₃ : ka f e (ka f d (ka a b c)), from ka₄' h₃₂,
                        have h₃₄ : ka f e (ka a d (ka a b c)), from ka₅ h₂₅ h₃₃,
                        show ka f e (ka a (ka a b c) d), from ka₃_ka h₃₄

                theorem ka₅_ka {a b c d e f g : Prop}
                    (h₁ : ka g f (ka a b c))
                    (h₂ : ka g f (ka a b (ka a d e))) :
                    ka g f (ka a b (ka c d e)) :=
                    have h₃ : ka g f (ka g b c), from ka₇ h₁,
                    have h₄ : ka g (ka g f b) c, from ka₄ h₃,
                    have h₅ : ka g f (ka g b (ka a d e)), from ka₇ h₂,
                    have h₆ : ka g (ka g f b) (ka a d e), from ka₄ h₅,
                    have h₇ : ka g (ka g f b) (ka g d e), from ka₇ h₆,
                    have h₈ : ka g (ka g f b) (ka c d e), from ka₅ h₄ h₇,
                    have h₉ : ka g f (ka g b (ka c d e)), from ka₄' h₈,
                    have h₁₀ : ka g f a, from ka₆ h₁,
                    show ka g f (ka a b (ka c d e)), from ka₅ h₁₀ h₉

                theorem ka₆_ka {a b c d e f g : Prop} (h₁ : ka g f (ka a c (ka b d e))) :
                    ka g f (ka a c b) :=
                    have h₂ : ka g f (ka g c (ka b d e)), from ka₇ h₁,
                    have h₃ : ka g (ka g f c) (ka b d e), from ka₄ h₂,
                    have h₄ : ka g (ka g f c) b, from ka₆ h₃,
                    have h₅ : ka g f (ka g c b), from ka₄' h₄,
                    have h₆ : ka g f a, from ka₆ h₁,
                    show ka g f (ka a c b), from ka₅ h₆ h₅

                theorem ka₇_ka {a b c d e f g : Prop} (h₁ : ka g f (ka a c (ka b d e))) :
                    ka g f (ka a c (ka a d e)) :=
                    have h₂ : ka g f a, from ka₆ h₁,
                    have h₃ : g, from ka₀ h₁,
                    have h₄ : ka g (ka g f a) c, from ka₁ h₃ h₂,
                    have h₅ : ka g f (ka g a c), from ka₄' h₄,
                    have h₆ : ka g f (ka g c a), from ka₃_ka h₅,
                    have h₇ : ka g (ka g f c) a, from ka₄ h₆,
                    have h₈ : ka g f (ka g c (ka b d e)), from ka₇ h₁,
                    have h₉ : ka g (ka g f c) (ka b d e), from ka₄ h₈,
                    have h₁₀ : ka g (ka g f c) (ka g d e), from ka₇ h₉,
                    have h₁₁ : ka g (ka g f c) (ka a d e), from ka₅ h₇ h₁₀,
                    have h₁₂ : ka g f (ka g c (ka a d e)), from ka₄' h₁₁,
                    show ka g f (ka a c (ka a d e)), from ka₅ h₂ h₁₂

            end ka
        end wr
    end hilbert
end clfrags


theorem ex1 (x : Nat) : 0 + x = x := by
  cases x with
  | zero   => skip -- Error: unsolved goals
  | succ y => skip -- Error: unsolved goals

theorem ex2 (x : Nat) : 0 + x = x := by
  induction x with
  | zero      => skip -- Error: unsolved goals
  | succ y ih => skip -- Error: unsolved goals

theorem ex3 (x : Nat) : 0 + x = x := by
  cases x with
  | zero   => rfl
  | succ y => skip -- Error: unsolved goals

theorem ex4 (x : Nat) {y : Nat} (h : y > 0) : x % y < y := by
  induction x, y using Nat.mod.inductionOn with
  | ind x y h₁ ih => skip -- Error: unsolved goals
  | base x y h₁   => skip -- Error: unsolved goals

theorem ex5 (x : Nat) {y : Nat} (h : y > 0) : x % y < y := by
  cases x, y using Nat.mod.inductionOn with
  | ind x y h₁ ih => skip -- Error: unsolved goals
  | base x y h₁   => skip -- Error: unsolved goals


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.shapes.binary_products
import Mathlib.category_theory.limits.preserves.shapes.terminal
import Mathlib.category_theory.adjunction.fully_faithful
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

namespace category_theory

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective {C : Type u₁} {D : Type u₂} [category C] [category D] (R : D ⥤ C)
    extends full R, faithful R, is_right_adjoint R where

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.

theorem unit_obj_eq_map_unit {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C}
    [reflective i] (X : C) :
    nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i))
          (functor.obj i (functor.obj (left_adjoint i) X)) =
        functor.map i
          (functor.map (left_adjoint i)
            (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) X)) :=
  sorry

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
protected instance functor.ess_image.unit_iso_restrict {C : Type u₁} {D : Type u₂} [category C]
    [category D] {i : D ⥤ C} [reflective i] {B : D} :
    is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) (functor.obj i B)) :=
  eq.mpr sorry is_iso.inv_is_iso

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
def functor.ess_image.unit_is_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C}
    [reflective i] {A : C} (h : A ∈ functor.ess_image i) :
    is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A) :=
  eq.mpr sorry is_iso.comp_is_iso

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
theorem mem_ess_image_of_unit_is_iso {C : Type u₁} {D : Type u₂} [category C] [category D]
    {i : D ⥤ C} [is_right_adjoint i] (A : C)
    [is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A)] :
    A ∈ functor.ess_image i :=
  Exists.intro (functor.obj (left_adjoint i) A)
    (Nonempty.intro
      (iso.symm (as_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A))))

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
theorem mem_ess_image_of_unit_split_mono {C : Type u₁} {D : Type u₂} [category C] [category D]
    {i : D ⥤ C} [reflective i] {A : C}
    [split_mono (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A)] :
    A ∈ functor.ess_image i :=
  let η : 𝟭 ⟶ left_adjoint i ⋙ i := adjunction.unit (adjunction.of_right_adjoint i);
  mem_ess_image_of_unit_is_iso A

end Mathlib


def one (α : Type u) [OfNat α (nat_lit 1)] : α := 1

abbrev HasOne (α : Type u) := OfNat α (nat_lit 1)

def one' (α : Type u) [HasOne α] : α := 1

example : HasOne Nat := inferInstance


import category_theory.opposites
import category_theory.limits.shapes.products
import category_theory.limits.shapes.pullbacks
import sieve

namespace category_theory
namespace category_theory.limits

section topologies
universes v u

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

-- SGA 4 II Def 1.1.
structure grothendieck_topology :=
(coverings : Π (X : C), set (sieve.{v} X))
(base_change : ∀ (X Y : C) (S : sieve.{v} X) (f : Y ⟶ X),
    S ∈ coverings X → (pullback_sieve f S) ∈ coverings Y)
(local_character : ∀ (X : C) (S T : sieve.{v} X) (_ : S ∈ coverings X),
    (∀ (Y : C) (f : Y ⟶ X) (_ : f ∈ S.map Y),
         (pullback_sieve f T) ∈ coverings Y) → T ∈ coverings X)
(id : ∀ (X : C), id_sieve X ∈ coverings X)

--TODO coverings is 'cofiltrant' [SGA 4 II 1.1.1.]

-- how to generate this? @[ext] didn't work for because of the explicit universe parameters
lemma grothendieck_topology_ext {J K : grothendieck_topology C}:
    J.coverings = K.coverings → J = K := by {cases K, intro H, cases J, tidy}

-- SGA 4 II 1.1.2. topologies plus ou moins fine
instance grothendieck_topology_partial_order:
    partial_order (grothendieck_topology C) :=
    {   le := (λ J, λ K, J.coverings ≤ K.coverings),
        le_refl := by {intros J X, exact le_refl (J.coverings X), },
        le_trans := by {intros J K L hJK hKL X, exact le_trans (hJK X) (hKL X),},
        le_antisymm := by {
            intros J K hJK hKJ,
            apply grothendieck_topology_ext, ext X S,
            split,
            intro hS,
            exact hJK X hS,
            intro hS,
            exact hKJ X hS, }
    }

-- SGA 4 II 1.1.3. intersection topology
instance grothendieck_topology_has_Inf:
    lattice.has_Inf (grothendieck_topology C) :=
    { Inf := λ T : set (grothendieck_topology C), ⟨ λ U : C,
            ⋂ (J : grothendieck_topology C) (H : J ∈ T), J.coverings U,
        by { tidy, apply H_w.base_change, exact a H_w H_w_1, },
        by {
            tidy,
            apply H_w.local_character X S T_1,
            exact _x H_w H_w_1,
            intros Y f hf,
            exact a Y f hf H_w H_w_1, },
        by {tidy, exact H_w.id X, } ⟩ }

-- SGA 4 II 1.1.4. discrete (top) and chaotic (bot) topologies
instance grothendieck_topology_order_top:
    lattice.order_top (grothendieck_topology C) :=
    { top := ⟨λ U, {a | true}, by tidy, by tidy, by tidy⟩,
      le_top := by tidy,
      ..grothendieck_topology_partial_order C}

instance grothendieck_topology_order_bot:
    lattice.order_bot (grothendieck_topology C) :=
    { bot := ⟨ λ U, {id_sieve U},
        by {
            tidy,
            rw a,
            rw pullback_id_sieve,
        }, by {
            tidy,
            have H1 : (𝟙 X) ∈ S.map X,
                rw h,
                tidy,
            have H := a X (𝟙 X) H1,
            rw <- H,
            apply sieve_ext, ext,
            have H : x_1 = x_1 ≫ 𝟙 X := by tidy,
            split, {
                intro hx,
                rw H at hx,
                exact hx,
            }, {
                intro hx,
                have : (x_1 ≫ 𝟙 X) ∈ T.map x := hx,
                rw <- H at this,
                exact this,
            },
        }, by tidy⟩,
    bot_le := by {
        intros J U S hS,
        have H : S = id_sieve U := by tidy,
        rw H,
        exact J.id U,
      },
      ..grothendieck_topology_partial_order C}
end topologies

section topologies
universes v u

--SGA 4 II 1.1.6. topology generated by family of morphisms
def topology_gen_by {C : Type u} [iC : category.{v} C] (fa : Π X Y : C, set (Y ⟶ X)):
    @grothendieck_topology C iC := lattice.Inf {J | ∀ X Y : C, sieve_gen_by (fa X) ∈ J.coverings X}

def is_fibreproduct {C : Type u} [iC : category.{v} C]
    {A X Y Z : C} (pX : A ⟶ X) (pY : A ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z) :=
    ∀ B : C, ∀ fx : B ⟶ X, ∀ fy : B ⟶ Y, fx ≫ f = fy ≫ g →
        (∃ h : B ⟶ A, h ≫ pX = fx ∧ h ≫ pY = fy ∧
        (∀ h1 : B ⟶ A, (h1 ≫ pX = fx ∧ h1 ≫ pY = fy) → h1 = h))

def is_squareable {C : Type u} [iC : category.{v} C] {X Y :C} (f : Y ⟶ X) :=
    ∀ Z : C, ∀ g : Z ⟶ X, ∃ A : C, ∃ pX : A ⟶ Z, ∃ pY : A ⟶ Y,
        is_fibreproduct pX pY g f

--SGA 4 II def 1.3. pretopology
structure pretopology (C : Type u) [iC : category.{v} C] :=
(coverings : Π X : C, set (Π Y : C, set (Y ⟶ X)))
(squareable : ∀ X : C, ∀ fa : (Π Y : C, set (Y ⟶ X)),
    fa ∈ coverings X → ∀ {Y : C} (f : Y ⟶ X), f ∈ fa Y → is_squareable f)
(basechange : ∀ X : C, ∀ fa : (Π Z : C, set (Z ⟶ X)), ∀ {Y : C} (f : Y ⟶ X),
    fa ∈ coverings X → (λ Z : C, {g : Z ⟶ Y | ∃ Xa : C, ∃ h : Xa ⟶ X,
        h ∈ fa Xa ∧ ∃ p : Z ⟶ Xa, is_fibreproduct p g h f}) ∈ coverings Y)
(local_character : sorry)
(identity : ∀ X : C, sorry)

--TODO prove Prop 1.4

end topologies

section sites
universes v u

variables (cat : Type u) [icat : category.{v} cat]
include icat

-- SGA 4 II 1.1.5
structure site :=
(top : @grothendieck_topology cat icat)

variable C : site cat

def covering_morphisms (X : cat) (fa : Π Y : cat, set (Y ⟶ X)) :=
    sieve_gen_by fa ∈ C.top.coverings X
end sites

section sites
universe v
open topological_space

-- this is quite bad, especially base_change
-- I find it annoying to switch between set theory
-- and the category of open sets... there's some of ulift, plift magic
-- there should definitely be an easy way of doing this
-- (tidy doesn't work / produces something with I don't understand)

-- maybe it can be simplified by defining it as the topology generated by open covers.
def grothendieck_topology_of_topology (M : Top.{v}):
    @grothendieck_topology (opens M) opens.opens_category :=
    ⟨λ X : opens M, {s | ∀ x : M, x ∈ X → ∃ Y : opens M, s.map Y ≠ ∅ ∧ x ∈ Y },
    by {
        intros X Y s f hs,
        intros x hx,
        have hx' : x ∈ X,
            have H : Y ⊆ X := f.down.down,
            exact H hx,
        have h := hs x hx',
        cases h with Z hZ,
        refine ⟨Z ∩ Y, _, _⟩,
        {   rw set.ne_empty_iff_nonempty,
            rw set.ne_empty_iff_nonempty at hZ,
            cases hZ.1 with i hi,
            have h1 : Z ∩ Y ≤ Y,
            {   intros w hw,
                have h3 : (Z ∩ Y).val = Z.val ∩ Y.val := by tidy,
                rw h3 at hw,
                rw set.mem_inter_iff at hw,
                exact hw.2, },
            let g : Z ∩ Y ⟶ Y := ulift.up (plift.up h1),
            have h2 : Z ∩ Y ≤ Z,
            {   intros w hw,
                have h3 : (Z ∩ Y).val = Z.val ∩ Y.val := by tidy,
                rw h3 at hw,
                rw set.mem_inter_iff at hw,
                exact hw.1, },
            let t : Z ∩ Y ⟶ Z := ulift.up (plift.up h2),
            have H : t ≫ i ∈ s.map (Z ∩ Y),
                apply s.comp, exact hi,
            have H1 : t ≫ i = g ≫ f := by tidy,
            rw H1 at H,
            have H2 : g ∈ (pullback_sieve f s).map (Z ∩ Y) := H,
            existsi g, exact H,
        }, {
            split,
            exact hZ.2,
            exact hx,
        },
    }, by {
        intros X S T hS H x hx,
        cases hS x hx with Y hY,
        rw set.ne_empty_iff_nonempty at hY,
        cases hY.1 with i hi,
        cases H Y i hi x hY.2 with Z hZ,
        rw set.ne_empty_iff_nonempty at hZ,
        cases hZ.1 with j hj,

        refine ⟨Z, _, hZ.2⟩,
        rw set.ne_empty_iff_nonempty,
        existsi j ≫ i,
        exact hj,
    },
    by {
        intros X x hx,
        refine ⟨X, _, hx⟩,
        intro h,
        set s : sieve.{v} X := id_sieve X with sdef,
        have h1 : 𝟙 X ∈ s.map X := by tidy,
        rw h at h1,
        rw set.mem_empty_eq at h1,
        exact h1,
    }⟩

end sites

open opposite

universes v u

variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

structure covering (U : C) :=
(ι : Type v)
(obj : ι → C)
(hom : Π i, obj i ⟶ U)

set_option pp.universes true

/- redefined this as category + grothendieck topology
structure site :=
(index : C → Type v)
(coverings : Π (U : C), index U → covering.{v} U)
(pullback : ∀ {U V: C} (k : index U) (g : V ⟶ U), ∃ (l : index V), ∀ (j : (coverings V l).ι),
∃ (i : (coverings U k).ι) (h : ((coverings V l).obj j) ⟶ ((coverings U k).obj i)),
(coverings V l).hom j ≫ g = h ≫ ((coverings U k).hom i))
-/

variables {D : Type u} [Dc : category.{v} D]
variables [products : limits.has_products.{v} D] [pullbacks : limits.has_pullbacks.{v} C]
variables {F : Cᵒᵖ ⥤ D}
include Dc products pullbacks

def asdf (U : C) (CU : covering.{v} U) (i j : CU.ι) := limits.pullback (CU.hom i) (CU.hom j)

/-def obj1 (U : C) (CU : covering U) := (limits.pullback (CU.hom i) (CU.hom j)) -/

def fan1 (U : C) (CU : covering.{v} U) := λ (k : CU.ι × CU.ι), F.obj (op ( limits.pullback (CU.hom k.1) (CU.hom k.2)))

def intersection_prod (U : C) (CU : covering.{v u} U) := limits.pi_obj.{v u} (@fan1 _ _ _ _ _ _ F U CU)

/- TODO:
Get maps from product of pullbacks to product of U_i
-/

end category_theory.limits
end category_theory


import
  tactic
  computability.primrec
  computability.partrec
  computability.partrec_code
  computability.halting
  data.pfun
  order
  init.data.list
  init.data.subtype
  data.list.dedup
  data.W.basic

import lib.notation

universes u v

attribute [instance, priority 0] classical.prop_decidable

namespace nat

lemma mkpair_eq_iff {n m l : ℕ} : n.mkpair m = l ↔ n = l.unpair.1 ∧ m = l.unpair.2 :=
by { split,
  { intros e, rw ←e, simp },
  { intros h, simp[h], } }

@[simp] lemma unpair0 : (1 : ℕ).unpair = (0, 1) :=
by { have h : nat.mkpair 0 1 = 1, { simpa },
     suffices : nat.unpair (nat.mkpair 0 1) = (0, 1), simp[h] at this, exact this,
     simp }

lemma pos_succ {n : ℕ} (h : 0 < n) : n = (n - 1) + 1 :=
(succ_pred_eq_of_pos h).symm

lemma pos_pred_add {n m : ℕ} (h : m ≤ n) (l) : n - m + l = n + l - m :=
by { omega }

@[simp] lemma lt_max_add_one_left (m n : ℕ) : m < max m n + 1 := lt_succ_iff.mpr (le_max_left m n)

@[simp] lemma lt_max_add_one_right (m n : ℕ) : n < max m n + 1 := lt_succ_iff.mpr (le_max_right m n)

section cases
variables {C : Sort*} {a b : C} {s : ℕ → C}

@[elab_as_eliminator] def left_concat {C : Sort*} (hzero : C) (hsucc : ℕ → C) :
  ℕ → C := cases hzero hsucc

infixr (name:= nat.left_concat) ` .> `:70 := left_concat

@[simp] lemma left_concat_zero : (a .> s) 0 = a := by simp[left_concat]

@[simp] lemma left_concat_succ (i : ℕ) : (a .> s) i.succ = s i := by simp[left_concat]

@[simp] lemma left_concat_comp_succ : (a .> s) ∘ nat.succ = s := funext(by simp)

lemma comp_left_concat {α : Sort*} (f : C → α) (a : C) (s : ℕ → C) : f ∘ (a .> s) = f a .> f ∘ s :=
funext (λ i, nat.cases_on i (by simp) (by simp))

lemma left_concat_eq {α} (f : ℕ → α) : f 0 .> f ∘ nat.succ = f :=
funext (λ i, by cases i; simp)

end cases

end nat

namespace function
variables {α : Type*}

def fun_pow (f : α → α) : ℕ → α → α
| 0     a := a
| (n+1) a := f (fun_pow n a)
infix ` ^ᶠ `:60 := fun_pow

end function

namespace vector
variables {α : Type*} {n : ℕ}

lemma tail_nth : ∀ (v : vector α (n + 1)) (i : fin n), v.tail.nth i = v.nth ⟨i + 1, by simp; exact i.property⟩
| ⟨ [], h ⟩ i := by simp[tail, nth]
| ⟨ (a :: v), h ⟩ p := by { simp[tail, nth], refl }

@[simp] lemma succ_nth (v : vector α n) (a : α) (i : ℕ) (h : i + 1 < n + 1) :
  (a ::ᵥ v).nth ⟨i + 1, h⟩ = v.nth ⟨i, nat.succ_lt_succ_iff.mp h⟩ :=
by { have := vector.nth_tail (a ::ᵥ v) ⟨i, nat.succ_lt_succ_iff.mp h⟩, simp at this, simp[this] }

@[simp] lemma succ_nth' (v : vector α n) (a : α) (i : fin n)  :
  (a ::ᵥ v).nth i.succ = v.nth i := by simp[show i.succ = ⟨i + 1, nat.succ_lt_succ i.property⟩, from fin.ext (by simp)]

@[simp] lemma succ_nth_1 (v : vector α (n + 1)) (a : α) :
  (a ::ᵥ v).nth 1 = v.nth 0 := succ_nth' v a 0

@[simp] lemma cons_inj (a₁ a₂ : α) (v₁ v₂ : vector α n) :
  (a₁ ::ᵥ v₁) = (a₂ ::ᵥ v₂) ↔ a₁ = a₂ ∧ v₁ = v₂ :=
⟨by intros h; refine ⟨by simpa using congr_arg head h, by simpa using congr_arg tail h⟩,
 by rintros ⟨rfl, rfl⟩; refl⟩

end vector

def finitary (α : Type*) (n : ℕ) := fin n → α

namespace fin

def add' {n} (i : fin n) : fin (n + 1) := ⟨i, nat.lt.step i.property⟩

lemma cases_inv {n} (i : fin (n + 1)) : (∃ i' : fin n, i = add' i') ∨ i = ⟨n, lt_add_one n⟩ :=
by { have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property, cases this,
     { left, refine ⟨⟨i, this⟩, fin.eq_of_veq _⟩, simp[add'] },
     { right, apply fin.eq_of_veq, simp[this] } }

@[simp] lemma fin_le {n} (i : fin n) : ↑i < n := i.property

@[simp] lemma fin_le_succ {n} (i : fin n) : ↑i < n + 1 := nat.lt.step i.property

def psucc {n} (m : ℕ) : fin n → fin (n + 1) :=
λ i, if ↑i < m then i.cast_succ else i.succ

section psucc
variables {n : ℕ}

@[simp] lemma psucc_zero : (psucc 0 : fin n → fin (n + 1)) = fin.succ :=
funext (λ j, by simp[psucc])

lemma succ_fix_zero_of_lt {i : fin n} {m : ℕ} (h : ↑i < m) : psucc m i = i.cast_succ := by simp[psucc, h]

lemma succ_fix_zero_of_ge {i : fin n} {m : ℕ} (h : ↑i ≥ m) : psucc m i = i.succ := by simp[psucc, not_lt.mpr h]

end psucc

lemma eq_last_or_eq_cast_succ {n : ℕ} : ∀ (i : fin (n + 1)),
i = last n ∨ ∃ (j : fin n), i = j.cast_succ :=
@last_cases n (λ i, i = last n ∨ ∃ (j : fin n), i = j.cast_succ) (by simp) (by simp)

lemma eq_zero_or_eq_last_or_interval {n : ℕ} (i : fin (n + 1 + 1)) :
i = 0 ∨ i = last (n + 1) ∨ ∃ (j: fin n), i = j.cast_succ.succ :=
begin
  rcases fin.eq_zero_or_eq_succ i with (eqn | ⟨j₁, h₁⟩),
  { exact or.inl eqn },
  { rcases eq_last_or_eq_cast_succ i with (eqn | ⟨j₂, h₂⟩),
    { refine (or.inr $ or.inl eqn) },
    { refine (or.inr $ or.inr _),
      rcases eq_last_or_eq_cast_succ j₁ with (rfl | ⟨j, rfl⟩),
      { exfalso,
        have : j₂.cast_succ = last n.succ, by simpa[←h₂] using h₁,
        have e : j₂.val = n.succ, simpa using congr_arg fin.val this,
        have : j₂.val < n + 1, from j₂.property,
        simp[e] at this, contradiction },
      { exact ⟨j, h₁⟩ } } }
end

section cases
variables {n : ℕ} {C : Sort*} {a b : C} {s : fin n → C}

-- finitary.cons の書き換え
@[elab_as_eliminator] def left_concat {C : Sort*} (hzero : C) (hsucc : fin n → C) : fin (n + 1) → C := @cases n (λ _, C) hzero hsucc

infixr (name:= left_concat) ` *> `:70 := left_concat

@[simp] lemma left_concat_zero : (a *> s) 0 = a := by simp[left_concat]

@[simp] lemma left_concat_succ (i : fin n) : (a *> s) i.succ = s i := by simp[left_concat]

@[simp] lemma left_concat_comp_succ : (a *> s) ∘ fin.succ = s := funext(by simp)

lemma comp_left_concat {α : Sort*} (f : C → α) (a : C) (s : fin n → C) : f ∘ (a *> s) = f a *> f ∘ s :=
funext (λ i, cases (by simp) (by simp) i)

@[simp] lemma cases_one
  {a : C} {s : fin 0 → C} (x : fin 1) : (a *> s) x = a :=
by rw [show x = 0, by simp]; simp

@[elab_as_eliminator, elab_strategy]
def right_concat (hcast : fin n → C) (hlast : C) : fin (n + 1) → C := @last_cases n (λ _, C) hlast hcast

infixl (name:= right_concat) ` <* `:70 := right_concat

@[simp] lemma right_concat_last : (s <* a) (last n) = a := by simp[right_concat]

@[simp] lemma right_concat_cast_succ (i : fin n) : (s <* a) i.cast_succ = s i := by simp[right_concat]

@[simp] lemma left_concat_comp_cast : (s <* a) ∘ fin.cast_succ = s := funext(by simp)

lemma comp_right_concat {α : Sort*} (f : C → α) (a : C) (s : fin n → C) : f ∘ (s <* a) = f ∘ s <* f a :=
funext (λ i, by refine last_cases _ _ i; simp)

@[simp] lemma last_cases_one
  {a : C} {s : fin 0 → C} (x : fin 1) : (s <* a) x = a :=
by rw [show x = last 0, by simp]; simp

lemma left_right_concat_assoc :
  a *> (s <* b) = (a *> s) <* b :=
funext (by { intros x, rcases eq_zero_or_eq_last_or_interval x with (rfl | h | ⟨x', rfl⟩),
  { show (a *> (s <* b)) 0 = ((a *> s) <* b) (cast_succ 0),
    simp only [left_concat_zero, right_concat_cast_succ] },
  { suffices : (a *> (s <* b)) (last n).succ = ((a *> s) <* b) (last $ n + 1),
    by simpa only [←h, succ_last] using this,
    simp only [left_concat_succ, right_concat_last] },
  { suffices : (a *> (s <* b)) x'.cast_succ.succ = ((a *> s) <* b) x'.succ.cast_succ,
    by simpa only [succ_cast_succ] using this,
    simp } })

lemma left_concat_eq {α} {n} (f : fin (n + 1) → α) : f 0 *> f ∘ fin.succ = f :=
funext (λ i, by refine cases _ _ i; simp)

lemma right_concat_eq {α} {n} (f : fin (n + 1) → α) : f ∘ fin.cast_succ <* f (last n) = f :=
funext (λ i, by refine last_cases _ _ i; simp)

protected def nil : fin 0 → C := fin_zero_elim

lemma eq_nil {α : fin 0 → Sort*} (f : Π x : fin 0, α x) : f = fin_zero_elim :=
by ext x; exact x.nil

lemma concat_zero {α} {x : α} : x *> fin.nil = fin.nil <* x :=
by funext; simp

@[simp] lemma left_concat_inj {a₁ a₂ : C} {s₁ s₂ : fin n → C} :
  a₁ *> s₁ = a₂ *> s₂ ↔ a₁ = a₂ ∧ s₁ = s₂ :=
⟨by { intros h, refine ⟨by simpa using congr_fun h 0, _⟩,
      simpa using congr_arg2 (∘) h (@rfl _ fin.succ) },
 by { rintros ⟨rfl, rfl⟩, refl }⟩

@[simp] lemma right_concat_inj {a₁ a₂ : C} {s₁ s₂ : fin n → C} :
  s₁ <* a₁ = s₂ <* a₂ ↔ a₁ = a₂ ∧ s₁ = s₂ :=
⟨by { intros h, refine ⟨by simpa using congr_fun h (last n), _⟩,
      simpa using congr_arg (λ s, s ∘ fin.cast_succ) h },
 by { rintros ⟨rfl, rfl⟩, refl }⟩

@[simp] lemma zero_concat_succ : (0 *> fin.succ : fin (n + 1) → fin (n + 1)) = id :=
by simpa using left_concat_eq id

@[simp] lemma cast_concat_last : (fin.cast_succ <* fin.last n) = id :=
by simpa using right_concat_eq id

end cases

end fin

namespace finitary
variables {α : Type*} {β : Type*}
open vector

def of_vec_of_fn : Π {n}, (fin n → α) → vector α n
| 0 f := nil
| (n+1) f := cons (f 0) (of_fn (λi, f i.succ))

def Max [linear_order α] (d : α) : ∀ {n}, finitary α n → α
| 0     _ := d
| (n+1) f := max (f ⟨n, lt_add_one n⟩) (@Max n (λ i, f i.add'))

@[elab_as_eliminator]
lemma finitary_induction (p : Π {n}, finitary α n → Prop)
  (nil : ∀ f : finitary α 0, p f)
  (cons : ∀ {n} (a : α) (f : finitary α n), p f → @p (n + 1) (λ i, if h : ↑i < n then f ⟨↑i, h⟩ else a)) :
  ∀ {n} (f : finitary α n), p f :=
by { intros n, induction n with n IH, refine nil, intros f,
      let f' : finitary α n := λ i, f ⟨↑i, nat.lt.step i.property⟩,
      have : f = (λ i, if h : ↑i < n then f' ⟨↑i, h⟩ else f n),
      { funext i,
        have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property,
        cases this; simp [this], { simp[f'], unfold_coes, simp },
        { simp[←this] } },
      rw [this], refine cons _ _ (IH _) }

def Max_le [linear_order α] (d : α) {n} (v : finitary α n) (i) : v i ≤ Max d v :=
begin
  induction n with n IH; rcases i with ⟨i, i_p⟩,
  { exfalso, exact nat.not_lt_zero i i_p },
  simp[Max],
  have : i < n ∨ i = n, exact nat.lt_succ_iff_lt_or_eq.mp i_p,
  cases this,
  { right, have := IH (λ i, v ↑i) ⟨i, this⟩, simp at this, exact this },
  { left, simp[this] }
end

@[simp] def Max_0 [linear_order α] (d : α) (v : finitary α 0) : Max d v = d :=
by simp[Max]

protected def mem : ∀ {n}, α → finitary α n → Prop
| 0     a _ := false
| (n+1) a f := a = f ⟨n, lt_add_one n⟩ ∨ @mem n a (λ i, f ⟨i.val, nat.lt.step i.property⟩)

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

@[simp] lemma index_mem {n} (f : finitary α n) (i) :  f i ∈ f :=
by { induction n with n IH; simp[has_mem.mem, finitary.mem],
     { exact i.val.not_lt_zero i.property },
     have := nat.lt_succ_iff_lt_or_eq.mp i.property, cases this,
     {right, have := IH (λ (i : fin n), f ⟨i.val, nat.lt.step i.property⟩) ⟨i, this⟩, simp at*, refine this },
     simp[←this] }

protected def subset {n₁ n₂} (f₁ : finitary α n₁) (f₂ : finitary α n₂) := ∀ ⦃a : α⦄, a ∈ f₁ → a ∈ f₂

def cons_inv {n} (f : finitary α n) (a : α) : finitary α (n + 1) := λ i, if h : ↑i < n then f ⟨i, h⟩ else a

@[simp] def cons {n} (a : α) (f : finitary α n) : finitary α n.succ
| ⟨0, h⟩ := a
| ⟨i + 1, h⟩ := f ⟨i, nat.succ_lt_succ_iff.mp h⟩

infixl ` ᶠ:: `:60  := finitary.cons_inv

infixr ` ::ᶠ `:60  := finitary.cons

@[simp] lemma cons_inv_app0 {n} (f : finitary α n) (a : α) : (f ᶠ:: a) ⟨n, lt_add_one n⟩ = a := by simp[finitary.cons_inv]

@[simp] lemma cons_inv_app1 {n} (f : finitary α n) (a : α) (i : fin n) : (f ᶠ:: a) i.add' = f i :=
by { simp[finitary.cons_inv, fin.add'] }

@[simp] lemma cons_app_0 {n} (f : finitary α n) (a : α) : (a ::ᶠ f) 0 = a := rfl

@[simp] lemma cons_app_succ {n} (f : finitary α n) (a : α) (i : fin n) {h} : (a ::ᶠ f) ⟨i + 1, h⟩ = f i :=
by simp

@[simp] lemma cons_app_eq_succ (a : α) {n} (f : finitary α n) (i : fin n) :
  (a ::ᶠ f) i.succ = f i := by simp[show i.succ = ⟨i + 1, nat.succ_lt_succ i.property⟩, from fin.ext (by simp)]

@[simp] lemma cons_app_eq_1 (a : α) {n} (f : finitary α (n + 1)) :
  (a ::ᶠ f) 1 = f 0 := cons_app_eq_succ a f 0

def nil : finitary α 0 := λ i, by { exfalso, exact i.val.not_lt_zero i.property }

instance : has_emptyc (finitary α 0) := ⟨nil⟩

notation `‹` l:(foldr `, ` (t h, finitary.cons t h) finitary.nil `›`) := l

def tail_inv {n} (f : finitary α (n + 1)) : finitary α n := λ i, f ⟨i, nat.lt.step i.property⟩

def head_inv {n} (f : finitary α (n + 1)) : α := f ⟨n, lt_add_one n⟩

def tail {n} (f : finitary α (n + 1)) : finitary α n := λ i, f i.succ

lemma tail_inv_cons_inv_head {n} (f : finitary α (n + 1)) : f.tail_inv ᶠ:: f.head_inv = f :=
funext (λ i, by { simp[cons_inv, tail_inv, head_inv],
  intros h,
  congr, apply fin.eq_of_veq, simp,
  have : ↑i ≤ n, from fin.is_le i,
  exact le_antisymm h this })

@[simp] lemma zero_eq (f : finitary α 0) : f = ∅ :=
funext (λ i, by { have := i.property, exfalso, exact i.val.not_lt_zero this })

@[simp] lemma zero_eq' (f : fin 0 → α) : f = (∅ : finitary α 0) := zero_eq f

/-
lemma fin_2_eq (f : finitary α 1) : fin[f 0] = f :=
funext (λ i, by { rcases i with ⟨i, i_p⟩, cases i; simp[cons_inv], exfalso, simp[←nat.add_one] at*, exact i_p })

lemma fin1_eq (f : finitary α 1) : fin[f 0] = f :=
funext (λ i, by { rcases i with ⟨i, i_p⟩, cases i; simp[cons_inv], exfalso, simp[←nat.add_one] at*, exact i_p })

lemma fin2_eq (f : finitary α 2) : fin[f 0, f 1] = f :=
funext (λ i, by { rcases i with ⟨i, i_p⟩, cases i; simp[cons_inv], cases i, { simp },
  exfalso, simp[←nat.add_one] at i_p, exact i_p })
-/

@[ext] lemma fin_0_ext (f g : finitary α 0) : f = g :=
funext (λ i, by { rcases i with ⟨i, h⟩, exfalso, exact nat.not_lt_zero i h })

@[ext] lemma fin_1_ext {f g : finitary α 1} (h : f 0 = g 0) : f = g :=
funext (λ i, by { rcases i with ⟨i, hi⟩, rcases nat.lt_one_iff.mp hi with rfl, simp[h] })

@[ext] lemma fin_2_ext {f g : finitary α 2} (h0 : f 0 = g 0) (h1 : f 1 = g 1) : f = g :=
funext (λ i, by { rcases i with ⟨i, hi⟩,
  cases i, { simp[h0] }, cases i, { simp[h1] },
  { exfalso, simp[←nat.add_one, add_assoc] at hi, contradiction  } })

@[simp] lemma fin_1_app_eq (a : α) (i : fin 1) : ‹a› i = a :=
by { rcases i with ⟨i, h⟩, rcases nat.lt_one_iff.mp h with rfl, simp }

@[simp] lemma cons_inv_app_eq_0 (a : α) {n} (f : finitary α n) :
  (a ::ᶠ f) 0 = a := rfl

@[simp] lemma app_cons (a : α) {n} (f : finitary α n) (F : α → β) :
  (λ i : fin (n + 1), F $ (a ::ᶠ f) i) = (F a ::ᶠ λ i, F (f i)) :=
by { funext i, rcases i with ⟨i, h⟩, cases i; simp }

@[simp] lemma cons_tail (a : α) {n} (f : finitary α n) :
  (a ::ᶠ f).tail = f :=
by simp[tail]

lemma app_0_cons_tail_refl {n} (f : finitary α (n + 1)) : (f 0) ::ᶠ f.tail = f :=
funext (λ ⟨i, h⟩, by { rcases i; simp, refl })

@[simp] lemma of_fn_nil (f : finitary α 0) :
  of_fn f = vector.nil :=
by { ext i, exfalso, exact i.val.not_lt_zero i.property }

@[simp] lemma of_fn_cons (a : α) {n} (f : finitary α n) :
  of_fn (a ::ᶠ f) = a ::ᵥ (of_fn f) :=
by { ext i, rcases i with ⟨i, i_lt⟩, cases i; simp }

@[simp] lemma nth_cons (a : α) {n} (v : vector α n) :
  (a ::ᵥ v).nth = a ::ᶠ v.nth :=
by { ext i, rcases i with ⟨i, i_lt⟩, cases i; simp }

@[simp] lemma of_fn_nth_refl {n} (v : vector α n) :
  of_fn v.nth = v := by ext i; simp

@[simp] lemma nth_of_fn_refl {n} (f : finitary α n) :
  (of_fn f).nth = f := by ext i; simp

lemma app_0_nth_eq_head {n} (v : vector α (n + 1)) :
  v.nth 0 = v.head := by simp

@[simp] lemma head_eq_head {n} (f : finitary α (n + 1)) :
  (of_fn f).head = f 0 := by simp

lemma pi_fin0_eq_empty (f : fin 0 → α) : f = (∅ : finitary α 0) :=
zero_eq f

instance [primcodable α] (n : ℕ) : primcodable (finitary α n) :=
primcodable.fin_arrow

instance [has_to_string α] (n) : has_to_string (finitary α n) :=
⟨λ f, by { exact "(" ++ list.to_string_aux tt (of_fn f).val ++ ")" }⟩

@[simp, reducible] def to_total [inhabited α] {n} (f : finitary α n) : ℕ → α :=
λ x, if h : x < n then f ⟨x, h⟩ else default

@[simp, reducible] def of_total {n} (f : ℕ → α) : finitary α n := λ i, f i

@[simp] def of_option : Π {n}, finitary (option α) n → option (finitary α n)
| 0       f := some finitary.nil
| (n + 1) f := (f 0).bind (λ a, (@of_option n f.tail).map (λ v, a ::ᶠ v))

@[simp] lemma of_option_some : ∀ {n} (v : finitary α n), of_option (λ i, some (v i)) = some v
| 0       v := by { simp, ext }
| (n + 1) v := by { simp[@of_option_some n, tail], refine app_0_cons_tail_refl _ }

lemma of_option_eq_some_iff : ∀ {n} {v : finitary (option α) n} {v'},
  of_option v = some v' ↔ ∀ i, v i = some (v' i)
| 0       v v' := by simp[show v' = nil, by ext]
| (n + 1) v v' := by { simp[@of_option_eq_some_iff _ v.tail], split,
    { rintros ⟨a, v0_eq, v', h, rfl⟩ ⟨i, i_lt⟩, rw ←app_0_cons_tail_refl v,
      cases i; simp* },
    { intros h, refine ⟨v' 0, by simp[h], v'.tail, by simp[tail, h], by simp[app_0_cons_tail_refl]⟩ } }

lemma of_option_eq_none_iff : ∀ {n} (v : finitary (option α) n),
  of_option v = none ↔ ∃ i, v i = none
| 0       v := by simp
| (n + 1) v := by {
    have IH := of_option_eq_none_iff v.tail,
    simp, intros,
    split,
    { intros h,
      cases C₁ : (v 0) with a, { refine ⟨0, C₁⟩ },
      cases C₂ : v.tail.of_option with v', { rcases IH.mp C₂ with ⟨i, h⟩, refine ⟨i.succ, h⟩ },
      have := h (a ::ᶠ v') a C₁ v' C₂ rfl, contradiction },
    { rintros ⟨⟨i, i_lt⟩, eqn⟩ w a eqn_a w' eqn_w' rfl,
      cases i,
      { simp[eqn_a] at eqn, contradiction },
      { have :v.tail ⟨i, _⟩ = some (w' ⟨i, _⟩),
        from of_option_eq_some_iff.mp eqn_w' ⟨i, (by { simp[←nat.add_one] at i_lt, exact i_lt })⟩,
        simp[tail, eqn] at this, contradiction } } }

end finitary

namespace encodable
variables {α : Type u} [encodable α] [inhabited α]

def idecode (α : Type u) [encodable α] [inhabited α] : ℕ → α := λ n, (decode α n).iget

lemma idecode_surj : function.surjective (idecode α) := surjective_decode_iget _

@[simp] lemma idecode_encodek : ∀ (a : α), idecode α (encode a) = a :=
by simp[idecode, encodek]

end encodable

namespace quotient
variables {α : Type u}

protected def lift_on_finitary {s : setoid α} {φ} : ∀ {n : ℕ} (v : finitary (quotient s) n) (f : finitary α n → φ)
  (h : ∀ v₁ v₂ : finitary α n, (∀ n, setoid.r (v₁ n) (v₂ n)) → f v₁ = f v₂), φ
| 0       v f h := f finitary.nil
| (n + 1) v f h :=
    let f' : α → finitary α n → φ := λ t v, f (λ i, if h : ↑i < n then (v ⟨i, h⟩) else t) in
    have h_0 : ∀ (a₁ a₂ : α) (eq : setoid.r a₁ a₂), f' a₁ = f' a₂,
    { intros t₁ t₂ eq, funext v, simp[f'], refine h _ _ (λ i, _),
      have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property, cases this; simp[this],
      { exact quotient.eq'.mp rfl }, refine eq },
    have h_v : ∀ (a : α) (v₁ v₂ : finitary α n) (eqs : ∀ (n : fin n), setoid.r (v₁ n) (v₂ n)), f' a v₁ = f' a v₂,
    { intros t v₁ v₂ hyp, refine h _ _ (λ i, _),
      have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property, cases this; simp[this],
      refine hyp _, exact quotient.eq'.mp rfl },
    let f'_p : α → φ := λ t, lift_on_finitary (λ i, v ⟨i, nat.lt.step i.property⟩) (f' t) (h_v t) in
    quotient.lift_on (v ⟨n, lt_add_one n⟩) f'_p (λ a₁ a₂ h, by { simp[f'_p], funext _, simp[h_0 a₁ a₂ h] })

@[simp]
protected lemma lift_on_finitary_eq {s : setoid α} {φ} {n} (v : finitary α n) (f : finitary α n → φ)
  (h : ∀ v₁ v₂ : finitary α n, (∀ n, setoid.r (v₁ n) (v₂ n)) → f v₁ = f v₂) :
  quotient.lift_on_finitary (λ x, ⟦v x⟧) f h = f v :=
by { induction n with n IH; simp[quotient.lift_on_finitary],
     { simp [finitary.zero_eq v, show (finitary.nil : finitary α 0) = ∅, by refl] },
     simp[IH], congr, funext i,
     have : ↑i < n ∨ ↑i = n, exact nat.lt_succ_iff_lt_or_eq.mp i.property, cases this; simp[this], simp[←this] }

@[simp]
protected lemma lift_on_finitary_0_eq {s : setoid α} {φ} (f : finitary α 0 → φ)
  (h : ∀ v₁ v₂ : finitary α 0, (∀ n, setoid.r (v₁ n) (v₂ n)) → f v₁ = f v₂) (n : finitary (quotient s) 0) :
  quotient.lift_on_finitary n f h = f finitary.nil :=
by simp[quotient.lift_on_finitary]

@[simp]
protected lemma lift_on_finitary_1_eq {s : setoid α} {φ} (a : α) (f : finitary α 1 → φ)
  (h : ∀ v₁ v₂ : finitary α 1, (∀ n, setoid.r (v₁ n) (v₂ n)) → f v₁ = f v₂) :
  quotient.lift_on_finitary ‹⟦a⟧› f h = f ‹a› :=
by { rw[show ‹⟦a⟧› = (λ x : fin 1, ⟦a⟧), by { refine finitary.fin_1_ext _; simp }],
     refine quotient.lift_on_finitary_eq ‹a› f h}

@[simp]
protected lemma lift_on_finitary_2_eq {s : setoid α} {φ} (a b : α) (f : finitary α 2 → φ)
  (h : ∀ v₁ v₂ : finitary α 2, (∀ n, setoid.r (v₁ n) (v₂ n)) → f v₁ = f v₂) :
  quotient.lift_on_finitary ‹⟦a⟧, ⟦b⟧› f h = f ‹a, b› :=
by { rw[show ‹⟦a⟧, ⟦b⟧› = (λ x : fin 2, ⟦‹a, b› x⟧), by { refine finitary.fin_2_ext _ _; simp }],
     refine quotient.lift_on_finitary_eq ‹a, b› f h }

end quotient

#check is_empty_sigma
-- @[simp] lemma is_empty_sigma {α} {s : α → Sort*} : is_empty (Σ a, s a) ↔ ∀ a, is_empty (s a) :=
-- by simp only [← not_nonempty_iff, nonempty_sigma, not_exists]

notation T` +{ ` :max p ` }` := insert p T

@[simp] lemma set.insert_mem {α : Sort*} (T : set α) (a : α) : a ∈ T +{ a } :=
by simp[insert]

@[simp] lemma set.insert_mem_of_mem {α : Sort*} {T : set α} {b : α} (h : b ∈ T) (a : α) :
  b ∈ T +{ a } := by simp[insert, h]

@[simp] lemma set.insert_mem_iff {α : Sort*} {T : set α} {a b : α} :
  b ∈ T +{ a } ↔ b = a ∨ b ∈ T := by simp[insert]

@[simp] def finitary.conjunction {α : Type*} [has_top α] [has_inf α] : ∀ n, (fin n → α) → α
| 0 _        := ⊤
| (n + 1) f  := f (fin.last n) ⊓ finitary.conjunction n (f ∘ fin.cast_succ)

notation `⋀` binders `, ` r:(scoped p, finitary.conjunction _ p) := r

@[simp] def finitary.disjunction {α : Type*} [has_bot α] [has_sup α] : ∀ n, (fin n → α) → α
| 0 _        := ⊥
| (n + 1) f  := finitary.disjunction n (f ∘ fin.cast_succ) ⊔ f (fin.last n)

notation `⋁` binders `, ` r:(scoped p, finitary.disjunction _ p) := r

@[simp] def list.conjunction {α : Type*} [has_top α] [has_inf α] : list α → α
| []        := ⊤
| (a :: as) := a ⊓ as.conjunction

@[simp] def list.disjunction {α : Type*} [has_bot α] [has_sup α] : list α → α
| []        := ⊥
| (a :: as) := as.disjunction ⊔ a

namespace finset
variables {α : Type*}

noncomputable def disjunction {α : Type*} [has_bot α] [has_sup α] (s : finset α) : α := s.to_list.disjunction

noncomputable def conjunction {α : Type*} [has_top α] [has_inf α] (s : finset α) : α := s.to_list.conjunction

@[simp] lemma disjunction_empty [has_bot α] [has_sup α] : (∅ : finset α).disjunction = ⊥ := by simp[finset.disjunction]

@[simp] lemma conjunction_empty [has_top α] [has_inf α] : (∅ : finset α).conjunction = ⊤ := by simp[finset.conjunction]

end finset

def fintype_sup {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α] [order_bot α] (f : ι → α) : α :=
  (finset.univ : finset ι).sup f

notation `⨆ᶠ ` binders `, ` r:(scoped f, fintype_sup f) := r

@[simp] lemma le_fintype_sup {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α] [order_bot α]
  (f : ι → α) (i : ι) :
  f i ≤ ⨆ᶠ i, f i := finset.le_sup (by simp)

@[simp] lemma le_fintype_sup' {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α] [order_bot α]
  {a : α} {f : ι → α} (i : ι) (le : a ≤ f i) :
  a ≤ ⨆ᶠ i, f i := le_trans le (le_fintype_sup _ _)

lemma fintype_sup_le {ι : Type*} [fintype ι] {α : Type*} [semilattice_sup α] [order_bot α]
  {f : ι → α} {a : α} (h : ∀ i, f i ≤ a) : (⨆ᶠ i, f i) ≤ a :=
finset.sup_le (λ i _, h i)

namespace fintype_sup
variables {ι : Type*} [fintype ι] {α : Type*}

section semilattice
variables [semilattice_sup α] [order_bot α]

@[simp] lemma fintype_sup_le_iff {f : ι → α} {a : α} :
  (⨆ᶠ i, f i) ≤ a ↔ (∀ i, f i ≤ a):=
by simp[fintype_sup]

@[simp] lemma finsup_eq_0_of_empty [is_empty ι] (f : ι → α) :
  (⨆ᶠ i, f i) = (⊥ : α) := by simp[fintype_sup]

@[simp] lemma finsup_eq_of_subsingleton [subsingleton ι] [inhabited ι] (f : ι → α) :
  (⨆ᶠ i, f i) = f default :=
begin
  suffices : (⨆ᶠ i, f i) ≤ f default ∧ f default ≤ (⨆ᶠ i, f i), from le_antisymm_iff.mpr this,
  split,
  { refine fintype_sup_le (λ i, by simp[subsingleton.elim i default]) },
  { refine le_fintype_sup _ _ }
end

@[simp] lemma finsup_eq_of_fin2 {α : Type*} [linear_order α] [order_bot α] (f : fin 2 → α) :
  (⨆ᶠ i, f i) = max (f 0) (f 1) :=
begin
  suffices : (⨆ᶠ i, f i) ≤ max (f 0) (f 1) ∧ max (f 0) (f 1) ≤ (⨆ᶠ i, f i), from le_antisymm_iff.mpr this,
  split,
  { refine fintype_sup_le (λ ⟨i, hi⟩, by { rcases i; simp; rcases i; simp[← nat.add_one, add_assoc] at hi ⊢, contradiction }) },
  { simp }
end

end semilattice

section linear_order
variables [linear_order α] [order_bot α]

@[simp] lemma fintype_sup_lt [inhabited ι] {f : ι → α} {a : α} :
  (⨆ᶠ i, f i) < a ↔ (∀ i, f i < a) :=
begin
  simp[fintype_sup],
  by_cases C : a ≤ ⊥,
  { have : a = ⊥, from eq_bot_iff.mpr C, rcases this with rfl,
    simp, },
  { have : ⊥ < a, exact not_le.mp C,
    simp[this] }
end

private lemma exists_sup {ι} (f : ι → α) (s : finset ι) : s ≠ ∅ → ∃ i, f i = s.sup f :=
begin
  refine finset.induction_on s (by simp) _,
  intros i s hi IH hs, simp,
  by_cases C : s = ∅,
  { rcases C with rfl, refine ⟨i, by simp⟩ },
  { rcases IH C with ⟨j, hj⟩, simp[←hj],
    have : f i ≤ f j ∨ f j ≤ f i, from le_total _ _,
    rcases this with (le | le),
    { refine ⟨j, by simp[le]⟩ },
    { refine ⟨i, by simp[le]⟩ } }
end

lemma exists_sup_index [inhabited ι] (f : ι → α) :
  ∃ i, f i = (⨆ᶠ i, f i) :=
exists_sup f _ (by simp[finset.univ_eq_empty_iff])

end linear_order

end fintype_sup

class wf_lt (α : Type*) :=
(prelt : α → α → Prop)
(wt : α → ℕ)
(mono' : ∀ {a b}, prelt a b → wt a < wt b)

namespace wf_lt
variables {α : Type*} [wf_lt α]

inductive le : α → α → Prop
| refl     : ∀ a, le a a
| of_prelt : ∀ {a b}, prelt a b → le a b
| trans    : ∀ a b c, le a b → le b c → le a c

instance : preorder α :=
{ le := le,
  le_refl := le.refl,
  le_trans := le.trans }

lemma mono {a b : α} (h : a ≤ b) : wt a ≤ wt b :=
by { induction h,
  case refl { simp },
  case of_prelt : a b prelt { exact le_of_lt (mono' prelt) },
  case trans : a b c _ _ le_ab le_bc { exact le_trans le_ab le_bc } }

instance : partial_order α :=
  { le_antisymm := λ p q h, by {
      induction h; try { simp },
      case of_prelt : a b prelt { intros le, exfalso, exact nat.lt_le_antisymm (mono' prelt) (mono le) },
      case trans : a b c le_ab le_bc IH_ab IH_bc
      { intros le, rcases IH_bc (le_trans le le_ab) with rfl, exact IH_ab le } },
    ..wf_lt.preorder }

lemma lt_of_prelt {a b : α} (h : wf_lt.prelt a b) : a < b :=
by { have le : a ≤ b, from le.of_prelt h,
     have ne : a ≠ b, { rintros rfl, exact nat.lt_asymm (mono' h) (mono' h) },
     refine lt_iff_le_and_ne.mpr ⟨le, ne⟩ }

lemma lt_iff {a b : α} : a < b ↔ ∃ b', prelt b' b ∧ a ≤ b' :=
⟨by { suffices : ∀ {a b : α} (le : a ≤ b) (ne : a ≠ b), (∃ b', prelt b' b ∧ a ≤ b'),
  { intros lt, exact this (le_of_lt lt) (ne_of_lt lt) },
  intros a b h, induction h,
  case refl { simp },
  case of_prelt : a b prelt { intros nle, refine ⟨a, prelt, by refl⟩ },
  case trans : a b c le_ab le_bc IH_ab IH_bc
  { intros ne,
    by_cases C : b = c, rcases C with (rfl | C),
    { exact IH_ab ne },
    { rcases IH_bc C with ⟨b', prelt, le⟩,
      refine ⟨b', prelt, le_trans (show a ≤ b, from le_ab) le⟩ } } },
 by { rintros ⟨b', prelt, le⟩, exact gt_of_gt_of_ge (lt_of_prelt prelt) le }⟩

lemma lt_mono {a b : α} (h : a < b) : wt a < wt b :=
by { rcases lt_iff.mp h with ⟨b', prelt, le⟩, exact gt_of_gt_of_ge (mono' prelt) (mono le) }

def wf : well_founded ((<) : α → α → Prop) :=
subrelation.wf (λ x y h, @lt_mono _ _ _ _ h) (inv_image.wf wt nat.lt_wf)

lemma lt_finite (h : ∀ a : α, set.finite {b | prelt b a}) (a : α) : set.finite {b | b < a} :=
begin
  refine @well_founded.induction _ _ wf (λ a, set.finite {b | b < a}) a _,
  simp, intros a IH,
  let P := {b | prelt b a},
  let B := P ∪ ⋃ b ∈ P, {c | c < b},
  have : B = {b : α | b < a},
  { ext b, simp[B], split,
    { rintros (prelt | ⟨c, prelt, lt⟩),
      { exact lt_of_prelt prelt },
      { have : c < a, from lt_of_prelt prelt, exact lt_trans lt this } },
    { intros lt, rcases lt_iff.mp lt with ⟨c, prelt, le⟩,
      have : b = c ∨ b < c, from eq_or_lt_of_le le,
      rcases this with (rfl | lt_bc),
      { exact or.inl prelt },
      { refine or.inr ⟨c, prelt, lt_bc⟩ } } },
  rw ←this,
  show B.finite,
  have : (⋃ b ∈ P, {c | c < b}).finite, from set.finite.bUnion (h _) (λ c prelt, IH c (lt_of_prelt prelt)),
  exact set.finite.union (show P.finite, from h _) this
end

lemma le_finite (h : ∀ a : α, set.finite {b | prelt b a}) (a : α) : set.finite {b | b ≤ a} :=
by { have : {b : α | b ≤ a} = insert a {b | b < a}, { ext b, simp, exact le_iff_eq_or_lt },
     simp[this], exact set.finite.insert a (lt_finite h a) }

end wf_lt

namespace list
variables {α : Type*} {ι : Type*} [fintype ι]

def Sup {n} (f : fin n → list α) : list α := (list.of_fn f).join

@[simp] lemma ss_Sup {n} (f : fin n → list α) (i : fin n) : f i ⊆ Sup f := λ x h,
by simp[Sup]; refine ⟨f i, _, h⟩; simp[list.mem_of_fn]

@[simp] lemma mem_Sup_iff {n} {f : fin n → list α} {a : α} :
  a ∈ Sup f ↔ ∃ i, a ∈ f i :=
⟨by { simp[Sup], intros i h, refine ⟨i, h⟩ },
 by { rintros ⟨i, h⟩, simp[Sup, list.mem_of_fn], refine ⟨i, h⟩ }⟩

section inf
variables [has_inf α] [has_top α]

@[simp] def inf : list α → α
| []        := ⊤
| (a :: as) := a ⊓ as.inf

end inf

lemma map_to_list_option {β} (f : α → β) (o : option α) : list.map f o.to_list = (o.map f).to_list := by cases o; simp; refl

lemma prefix_nth_le (l₁ l₂ : list α) (i : ℕ) (hi : i < l₁.length) (h : l₁ <+: l₂) :
  l₁.nth_le i hi = l₂.nth_le i (gt_of_ge_of_gt (is_prefix.length_le h) hi) :=
by { rcases h with ⟨l, rfl⟩, exact (list.nth_le_append _ _).symm }

end list

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

lemma image_finite_inversion_aux (s : set β) (h : s.finite) (f : α → β) : ∀ (z : set α), s ⊆ f '' z → ∃ u ⊆ z, u.finite ∧ f '' u = s :=
begin
  apply set.finite.induction_on h,
  { intros, refine ⟨∅, by simp⟩ },
  { rintros b s hb sfin IH z ss,
    have : (∃ a, a ∈ z ∧ f a = b) ∧ s ⊆ f '' z, by simpa[set.insert_subset] using ss,
    rcases this with ⟨⟨a, ha, rfl⟩, hs⟩,
    have : ∃ u ⊆ z, u.finite ∧ f '' u = s, from IH z hs,
    rcases this with ⟨u, hu, u_fin, rfl⟩,
    refine ⟨insert a u, by simp[set.insert_subset, ha, hu], finite.insert a u_fin, image_insert_eq⟩ }
end

lemma image_finite_inversion {f : α → β} {s : set α} (h : (f '' s).finite) : ∃ u ⊆ s, u.finite ∧ f '' u = f '' s :=
image_finite_inversion_aux (f '' s) h f s (by refl)

lemma subset_union_iff_exists {s t u : set α} : s ⊆ t ∪ u ↔ ∃ (t' ⊆ t) (u' ⊆ u), s = t' ∪ u' :=
⟨by { intros h,
  refine ⟨s ∩ t, by simp, s ∩ u, by simp, by symmetry; simp[←set.inter_union_distrib_left, h]⟩,
   },
 by { rintros ⟨t', ht', u', hu', rfl⟩,
      simp[set.subset_union_of_subset_left ht', set.subset_union_of_subset_right hu'] }⟩

end set

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

@[simp] lemma to_list_to_finset_eq {α} (a : option α) : a.to_list.to_finset = a.to_finset :=
by { rcases a; simp[], ext x, simp, exact comm }

end option

namespace finset
variables {α : Type*} {β : Type*} {γ : Type*}

theorem image_to_finset_list (l : list α) (f : α → β) :
  l.to_finset.image f = (l.map f).to_finset := ext (by simp)

theorem image_to_finset_option (o : option α) (f : α → β) :
  o.to_finset.image f = (o.map f).to_finset := ext (by simp)

noncomputable def bind := @sup (finset α) β _ _

lemma mem_bind (x : β) (s : finset α) (f : α → finset β) : x ∈ s.bind f ↔ ∃ y ∈ s, x ∈ f y :=
by simp[bind, finset.mem_sup]

lemma image_bind (s : finset α) (f : α → finset β) (g : β → γ) : (s.bind f).image g = s.bind (λ x, (f x).image g) :=
by { ext x, simp[mem_bind], split,
  { rintros ⟨y, ⟨a, ha, hy⟩, rfl⟩, refine ⟨a, ha, y, hy, rfl⟩ },
  { rintros ⟨x, hx, a, ha, rfl⟩, refine ⟨a, ⟨x, hx, ha⟩, rfl⟩ } }

end finset

section heyting_algebra
variables {α : Type u} {x : α} [heyting_algebra  α]

@[simp] lemma compl_finset_sup {ι : Type*} {s : finset ι} {f : ι → α} : (s.sup f)ᶜ = s.inf (compl ∘ f) :=
by induction s using finset.induction with i s hs IH; simp*

end heyting_algebra

section boolean_algebra
variables {α : Type u} {x : α} [boolean_algebra  α]

@[simp] lemma compl_finset_inf {ι : Type*} {s : finset ι} {f : ι → α} : (s.inf f)ᶜ = s.sup (compl ∘ f) :=
by induction s using finset.induction with i s hs IH; simp[*, compl_inf]

end boolean_algebra

section classical
attribute [instance, priority 0] classical.prop_decidable

end classical