/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/

import category_theory.monad.types
import category_theory.monad.limits
import category_theory.equivalence
import topology.category.CompHaus
import data.set.constructions

/-!

# Compacta and Compact Hausdorff Spaces

Recall that, given a monad `M` on `Type*`, an *algebra* for `M` consists of the following data:
- A type `X : Type*`
- A "structure" map `M X → X`.
This data must also satisfy a distributivity and unit axiom, and algebras for `M` form a category
in an evident way.

See the file `category_theory.monad.algebra` for a general version, as well as the following link.
https://ncatlab.org/nlab/show/monad

This file proves the equivalence between the category of *compact Hausdorff topological spaces*
and the category of algebras for the *ultrafilter monad*.

## Notation:

Here are the main objects introduced in this file.
- `Compactum` is the type of compacta, which we define as algebras for the ultrafilter monad.
- `Compactum_to_CompHaus` is the functor `Compactum ⥤ CompHaus`. Here `CompHaus` is the usual
  category of compact Hausdorff spaces.
- `Compactum_to_CompHaus.is_equivalence` is a term of type `is_equivalence Compactum_to_CompHaus`.

The proof of this equivalence is a bit technical. But the idea is quite simply that the structure
map `ultrafilter X → X` for an algebra `X` of the ultrafilter monad should be considered as the map
sending an ultrafilter to its limit in `X`. The topology on `X` is then defined by mimicking the
characterization of open sets in terms of ultrafilters.

Any `X : Compactum` is endowed with a coercion to `Type*`, as well as the following instances:
- `topological_space X`.
- `compact_space X`.
- `t2_space X`.

Any morphism `f : X ⟶ Y` of is endowed with a coercion to a function `X → Y`, which is shown to
be continuous in `continuous_of_hom`.

The function `Compactum.of_topological_space` can be used to construct a `Compactum` from a
topological space which satisfies `compact_space` and `t2_space`.

We also add wrappers around structures which already exist. Here are the main ones, all in the
`Compactum` namespace:

- `forget : Compactum ⥤ Type*` is the forgetful functor, which induces a `concrete_category`
  instance for `Compactum`.
- `free : Type* ⥤ Compactum` is the left adjoint to `forget`, and the adjunction is in `adj`.
- `str : ultrafilter X → X` is the structure map for `X : Compactum`.
  The notation `X.str` is preferred.
- `join : ultrafilter (ultrafilter X) → ultrafilter X` is the monadic join for `X : Compactum`.
  Again, the notation `X.join` is preferred.
- `incl : X → ultrafilter X` is the unit for `X : Compactum`. The notation `X.incl` is preferred.

## References

- E. Manes, Algebraic Theories, Graduate Texts in Mathematics 26, Springer-Verlag, 1976.
- https://ncatlab.org/nlab/show/ultrafilter

-/

open category_theory filter ultrafilter topological_space category_theory.limits has_finite_inter
open_locale classical topological_space

local notation `β` := of_type_monad ultrafilter

/-- The type `Compactum` of Compacta, defined as algebras for the ultrafilter monad. -/
@[derive [category, inhabited]]
def Compactum := monad.algebra β

namespace Compactum

/-- The forgetful functor to Type* -/
@[derive [creates_limits,faithful]]
def forget : Compactum ⥤ Type* := monad.forget _

/-- The "free" Compactum functor. -/
def free : Type* ⥤ Compactum := monad.free _

/-- The adjunction between `free` and `forget`. -/
def adj : free ⊣ forget := monad.adj _

-- Basic instances
instance : concrete_category Compactum := { forget := forget }
instance : has_coe_to_sort Compactum := ⟨Type*,forget.obj⟩
instance {X Y : Compactum} : has_coe_to_fun (X ⟶ Y) := ⟨λ f, X → Y, λ f, f.f⟩
instance : has_limits Compactum := has_limits_of_has_limits_creates_limits forget

/-- The structure map for a compactum, essentially sending an ultrafilter to its limit. -/
def str (X : Compactum) : ultrafilter X → X := X.a

/-- The monadic join. -/
def join (X : Compactum) : ultrafilter (ultrafilter X) → ultrafilter X := β .μ.app _

/-- The inclusion of `X` into `ultrafilter X`. -/
def incl (X : Compactum) : X → ultrafilter X := β .η.app _

@[simp] lemma str_incl (X : Compactum) (x : X) : X.str (X.incl x) = x :=
begin
  change (β .η.app _ ≫ X.a) _ = _,
  rw monad.algebra.unit,
  refl,
end

@[simp] lemma str_hom_commute (X Y : Compactum) (f : X ⟶ Y) (xs : ultrafilter X) :
  f (X.str xs) = Y.str (map f xs) :=
begin
  change (X.a ≫ f.f) _ = _,
  rw ←f.h,
  refl,
end

@[simp] lemma join_distrib (X : Compactum) (uux : ultrafilter (ultrafilter X)) :
  X.str (X.join uux) = X.str (map X.str uux) :=
begin
  change (β .μ.app _ ≫ X.a) _ = _,
  rw monad.algebra.assoc,
  refl,
end

instance {X : Compactum} : topological_space X :=
{ is_open := λ U, ∀ (F : ultrafilter X), X.str F ∈ U → U ∈ F,
  is_open_univ := λ _ _, filter.univ_sets _,
  is_open_inter := λ S T h3 h4 h5 h6,
    filter.inter_sets _ (h3 _ h6.1) (h4 _ h6.2),
  is_open_sUnion := λ S h1 F ⟨T,hT,h2⟩,
    mem_sets_of_superset (h1 T hT _ h2) (set.subset_sUnion_of_mem hT) }

theorem is_closed_iff {X : Compactum} (S : set X) : is_closed S ↔
  (∀ F : ultrafilter X, S ∈ F → X.str F ∈ S) :=
begin
  rw ← is_open_compl_iff,
  split,
  { intros cond F h,
    by_contradiction c,
    specialize cond F c,
    rw compl_mem_iff_not_mem at cond,
    contradiction },
  { intros h1 F h2,
    specialize h1 F,
    cases F.mem_or_compl_mem S;
    finish }
end

instance {X : Compactum} : compact_space X :=
begin
  constructor,
  rw compact_iff_ultrafilter_le_nhds,
  intros F h,
  refine ⟨X.str F, by tauto, _⟩,
  rw le_nhds_iff,
  intros S h1 h2,
  exact h2 F h1
end

/-- A local definition used only in the proofs. -/
private def basic {X : Compactum} (A : set X) : set (ultrafilter X) := {F | A ∈ F}
/-- A local definition used only in the proofs. -/
private def cl {X : Compactum} (A : set X) : set X := X.str '' (basic A)

private lemma basic_inter {X : Compactum} (A B : set X) : basic (A ∩ B) = basic A ∩ basic B :=
begin
  ext G,
  split,
  { intro hG,
    split; filter_upwards [hG]; intro x,
    exacts [and.left, and.right] },
  { rintros ⟨h1, h2⟩,
    exact inter_mem_sets h1 h2 }
end

private lemma subset_cl {X : Compactum} (A : set X) : A ⊆ cl A := λ a ha, ⟨X.incl a, ha,by simp⟩

private theorem cl_cl {X : Compactum} (A : set X) : cl (cl A) ⊆ cl A :=
begin
  rintros _ ⟨F,hF,rfl⟩,
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let C0 : ssu := {Z | ∃ B ∈ F, X.str ⁻¹' B = Z},
  let AA := {G : ultrafilter X | A ∈ G},
  let C1 := insert AA C0,
  let C2 := finite_inter_closure C1,
  -- C0 is closed under intersections.
  have claim1 : ∀ B C ∈ C0, B ∩ C ∈ C0,
  { rintros B C ⟨Q,hQ,rfl⟩ ⟨R,hR,rfl⟩,
    use Q ∩ R,
    simp only [and_true, eq_self_iff_true, set.preimage_inter, subtype.val_eq_coe],
    exact inter_sets _ hQ hR },
  -- All sets in C0 are nonempty.
  have claim2 : ∀ B ∈ C0, set.nonempty B,
  { rintros B ⟨Q,hQ,rfl⟩,
    obtain ⟨q⟩ := nonempty_of_mem hQ,
    use X.incl q,
    simpa, },
  -- The intersection of AA with every set in C0 is nonempty.
  have claim3 : ∀ B ∈ C0, (AA ∩ B).nonempty,
  { rintros B ⟨Q,hQ,rfl⟩,
    have : (Q ∩ cl A).nonempty :=
      nonempty_of_mem_sets (inter_mem_sets hQ hF),
    rcases this with ⟨q,hq1,P,hq2,hq3⟩,
    refine ⟨P,hq2,_⟩,
    rw ←hq3 at hq1,
    simpa },
  -- Suffices to show that the intersection of any finite subcollection of C1 is nonempty.
  suffices : ∀ (T : fsu), ι T ⊆ C1 → (⋂₀ ι T).nonempty,
  { obtain ⟨G, h1⟩ := exists_ultrafilter_of_finite_inter_nonempty _ this,
    use X.join G,
    have : G.map X.str = F :=
      ultrafilter.coe_le_coe.1 (λ S hS, h1 (or.inr ⟨S, hS, rfl⟩)),
    rw [join_distrib, this],
    exact ⟨h1 (or.inl rfl), rfl⟩ },
  -- C2 is closed under finite intersections (by construction!).
  have claim4 := finite_inter_closure_has_finite_inter C1,
  -- C0 is closed under finite intersections by claim1.
  have claim5 : has_finite_inter C0 := ⟨⟨_, univ_mem_sets, set.preimage_univ⟩, claim1⟩,
  -- Every element of C2 is nonempty.
  have claim6 : ∀ P ∈ C2, (P : set (ultrafilter X)).nonempty,
  { suffices : ∀ P ∈ C2, P ∈ C0 ∨ ∃ Q ∈ C0, P = AA ∩ Q,
    { intros P hP,
      cases this P hP,
      { exact claim2 _ h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim3 _ hQ } },
    intros P hP,
    exact claim5.finite_inter_closure_insert _ hP },
  intros T hT,
  -- Suffices to show that the intersection of the T's is contained in C2.
  suffices : ⋂₀ ι T ∈ C2, by exact claim6 _ this,
  -- Finish
  apply claim4.finite_inter_mem,
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht),
end

lemma is_closed_cl {X : Compactum} (A : set X) : is_closed (cl A) :=
begin
  rw is_closed_iff,
  intros F hF,
  exact cl_cl _ ⟨F, hF, rfl⟩,
end

lemma str_eq_of_le_nhds {X : Compactum} (F : ultrafilter X) (x : X) :
  ↑F ≤ 𝓝 x → X.str F = x :=
begin
  -- Notation to be used in this proof.
  let fsu := finset (set (ultrafilter X)),
  let ssu := set (set (ultrafilter X)),
  let ι : fsu → ssu := coe,
  let T0 : ssu := { S | ∃ A ∈ F, S = basic A },
  let AA := (X.str ⁻¹' {x}),
  let T1 := insert AA T0,
  let T2 := finite_inter_closure T1,
  intro cond,
  -- If F contains a closed set A, then x is contained in A.
  have claim1 : ∀ (A : set X), is_closed A → A ∈ F → x ∈ A,
  { intros A hA h,
    by_contradiction H,
    rw le_nhds_iff at cond,
    specialize cond Aᶜ H hA.is_open_compl,
    rw [ultrafilter.mem_coe, ultrafilter.compl_mem_iff_not_mem] at cond,
    contradiction },
  -- If A ∈ F, then x ∈ cl A.
  have claim2 : ∀ (A : set X), A ∈ F → x ∈ cl A,
  { intros A hA,
    exact claim1 (cl A) (is_closed_cl A) (mem_sets_of_superset hA (subset_cl A)) },
  -- T0 is closed under intersections.
  have claim3 : ∀ (S1 S2 ∈ T0), S1 ∩ S2 ∈ T0,
  { rintros S1 S2 ⟨S1, hS1, rfl⟩ ⟨S2, hS2, rfl⟩,
    exact ⟨S1 ∩ S2, inter_mem_sets hS1 hS2, by simp [basic_inter]⟩ },
  -- For every S ∈ T0, the intersection AA ∩ S is nonempty.
  have claim4 : ∀ (S ∈ T0), (AA ∩ S).nonempty,
  { rintros S ⟨S, hS, rfl⟩,
    rcases claim2 _ hS with ⟨G, hG, hG2⟩,
    exact ⟨G, hG2, hG⟩ },
  -- Every element of T0 is nonempty.
  have claim5 : ∀ (S ∈ T0), set.nonempty S,
  { rintros S ⟨S, hS, rfl⟩,
    exact ⟨F, hS⟩ },
  -- Every element of T2 is nonempty.
  have claim6 : ∀ (S ∈ T2), set.nonempty S,
  { suffices : ∀ S ∈ T2, S ∈ T0 ∨ ∃ Q ∈ T0, S = AA ∩ Q,
    { intros S hS,
      cases this _ hS with h h,
      { exact claim5 S h },
      { rcases h with ⟨Q, hQ, rfl⟩,
        exact claim4 Q hQ } },
    intros S hS,
    apply finite_inter_closure_insert,
    { split,
      { use set.univ,
        refine ⟨filter.univ_sets _, _⟩,
        ext,
        refine ⟨_, by tauto⟩,
        { intro,
          apply filter.univ_sets, } },
      { exact claim3} },
    { exact hS} },
  -- It suffices to show that the intersection of any finite subset of T1 is nonempty.
  suffices : ∀ (F : fsu), ↑F ⊆ T1 → (⋂₀ ι F).nonempty,
  { obtain ⟨G,h1⟩ := ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ this,
    have c1 : X.join G = F := ultrafilter.coe_le_coe.1 (λ P hP, h1 (or.inr ⟨P, hP, rfl⟩)),
    have c2 : G.map X.str = X.incl x,
    { refine ultrafilter.coe_le_coe.1 (λ P hP, _),
      apply mem_sets_of_superset (h1 (or.inl rfl)),
      rintros x ⟨rfl⟩,
      exact hP },
    simp [←c1, c2] },
  -- Finish...
  intros T hT,
  refine claim6 _ (finite_inter_mem (finite_inter_closure_has_finite_inter _) _ _),
  intros t ht,
  exact finite_inter_closure.basic (@hT t ht)
end

lemma le_nhds_of_str_eq {X : Compactum} (F : ultrafilter X) (x : X) :
  X.str F = x → ↑F ≤ 𝓝 x := λ h, le_nhds_iff.mpr (λ s hx hs, hs _ $ by rwa h)

-- All the hard work above boils down to this t2_space instance.
instance {X : Compactum} : t2_space X :=
begin
  rw t2_iff_ultrafilter,
  intros _ _ F hx hy,
  rw [← str_eq_of_le_nhds _ _ hx, ← str_eq_of_le_nhds _ _ hy]
end

/-- The structure map of a compactum actually computes limits. -/
lemma Lim_eq_str {X : Compactum} (F : ultrafilter X) : F.Lim = X.str F :=
begin
  rw [ultrafilter.Lim_eq_iff_le_nhds, le_nhds_iff],
  tauto,
end

lemma cl_eq_closure {X : Compactum} (A : set X) : cl A = closure A :=
begin
  ext,
  rw mem_closure_iff_ultrafilter,
  split,
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, le_nhds_of_str_eq _ _ h2⟩ },
  { rintro ⟨F, h1, h2⟩,
    exact ⟨F, h1, str_eq_of_le_nhds _ _ h2⟩ }
end

/-- Any morphism of compacta is continuous. -/
lemma continuous_of_hom {X Y : Compactum} (f : X ⟶ Y) : continuous f :=
begin
  rw continuous_iff_ultrafilter,
  intros x _ h,
  rw [tendsto, ← coe_map],
  apply le_nhds_of_str_eq,
  rw [← str_hom_commute, str_eq_of_le_nhds _ x h]
end

/-- Given any compact Hausdorff space, we construct a Compactum. -/
noncomputable def of_topological_space (X : Type*) [topological_space X]
  [compact_space X] [t2_space X] : Compactum :=
{ A := X,
  a := ultrafilter.Lim,
  unit' := by {ext x, exact Lim_eq (by finish [le_nhds_iff]) },
  assoc' := begin
    ext FF,
    change ultrafilter (ultrafilter X) at FF,
    set x := (ultrafilter.map ultrafilter.Lim FF).Lim with c1,
    have c2 : ∀ (U : set X) (F : ultrafilter X), F.Lim ∈ U → is_open U → U ∈ F,
    { intros U F h1 hU,
      exact c1 ▸ is_open_iff_ultrafilter.mp hU _ h1 _ (ultrafilter.le_nhds_Lim _) },
    have c3 : ↑(ultrafilter.map ultrafilter.Lim FF) ≤ 𝓝 x,
    { rw le_nhds_iff,
      intros U hx hU,
      exact mem_coe.2 (c2 _ _ (by rwa ← c1) hU) },
    have c4 : ∀ (U : set X), x ∈ U → is_open U → { G : ultrafilter X | U ∈ G } ∈ FF,
    { intros U hx hU,
      suffices : ultrafilter.Lim ⁻¹' U ∈ FF,
      { apply mem_sets_of_superset this,
        intros P hP,
        exact c2 U P hP hU },
      exact @c3 U (mem_nhds_sets hU hx) },
    apply Lim_eq,
    rw le_nhds_iff,
    exact c4,
  end }

/-- Any continuous map between Compacta is a morphism of compacta. -/
def hom_of_continuous {X Y : Compactum} (f : X → Y) (cont : continuous f) : X ⟶ Y :=
{ f := f,
  h' := begin
    rw continuous_iff_ultrafilter at cont,
    ext (F : ultrafilter X),
    specialize cont (X.str F) F (le_nhds_of_str_eq F (X.str F) rfl),
    have := str_eq_of_le_nhds (ultrafilter.map f F) _ cont,
    simpa only [←this, types_comp_apply, of_type_functor_map],
  end }

end Compactum

/-- The functor functor from Compactum to CompHaus. -/
def Compactum_to_CompHaus : Compactum ⥤ CompHaus :=
{ obj := λ X, { to_Top := { α := X } },
  map := λ X Y f,
  { to_fun := f,
    continuous_to_fun := Compactum.continuous_of_hom _ }}

namespace Compactum_to_CompHaus

/-- The functor Compactum_to_CompHaus is full. -/
def full : full Compactum_to_CompHaus :=
{ preimage := λ X Y f, Compactum.hom_of_continuous f.1 f.2 }

/-- The functor Compactum_to_CompHaus is faithful. -/
lemma faithful : faithful Compactum_to_CompHaus := {}

/-- This definition is used to prove essential surjectivity of Compactum_to_CompHaus. -/
noncomputable def iso_of_topological_space {D : CompHaus} :
  Compactum_to_CompHaus.obj (Compactum.of_topological_space D) ≅ D :=
{ hom :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $ λ _ h, by {rw is_open_iff_ultrafilter' at h, exact h} },
  inv :=
  { to_fun := id,
    continuous_to_fun := continuous_def.2 $
      λ _ h1, by {rw is_open_iff_ultrafilter', intros _ h2, exact h1 _ h2} } }

/-- The functor Compactum_to_CompHaus is essentially surjective. -/
lemma ess_surj : ess_surj Compactum_to_CompHaus :=
{ mem_ess_image := λ X, ⟨Compactum.of_topological_space X, ⟨iso_of_topological_space⟩⟩ }

/-- The functor Compactum_to_CompHaus is an equivalence of categories. -/
noncomputable def is_equivalence : is_equivalence Compactum_to_CompHaus :=
begin
  apply equivalence.equivalence_of_fully_faithfully_ess_surj _,
  exact Compactum_to_CompHaus.full,
  exact Compactum_to_CompHaus.faithful,
  exact Compactum_to_CompHaus.ess_surj,
end

end Compactum_to_CompHaus


-- This is an example illustrating a problem with unification when using Category based on Sort, rather than Type.

-- We set up some tactics:
open tactic
open smt_tactic
meta def smt_eblast : tactic unit := using_smt $ try eblast
meta def smt_ematch : tactic unit := using_smt $ intros >> add_lemmas_from_facts >> try ematch
meta def blast  : tactic unit := intros >> try dsimp >> try simp >> try smt_eblast
notation `♮` := by abstract { blast }

attribute [reducible] cast

@[reducible] def {u} auto_cast {α β : Type u} {h : α = β} (a : α) := cast h a
@[simp] lemma {u} auto_cast_identity {α : Type u} (a : α) : @auto_cast α α (by smt_ematch) a = a := ♮
notation `⟦` p `⟧` := @auto_cast _ _ (by smt_ematch) p

-- And now a minimal example:
universe variables u v

structure Category :=
  (Obj : Sort u)
  (Hom : Obj → Obj → Sort v)
  (identity : Π X : Obj, Hom X X)
  (compose  : Π { X Y Z : Obj }, Hom X Y → Hom Y Z → Hom X Z)

  (left_identity  : ∀ { X Y : Obj } (f : Hom X Y), compose (identity X) f = f)

attribute [simp] Category.left_identity

universe variables u1 v1 u2 v2

structure Functor (C : Category.{ u1 v1 }) (D : Category.{ u2 v2 }) :=
  (onObjects   : C^.Obj → D^.Obj)
  (onMorphisms : Π { X Y : C^.Obj },
                C^.Hom X Y → D^.Hom (onObjects X) (onObjects Y))

set_option pp.all true

def rewriteMorphism   { C : Category.{u1 v1} }
  { D : Category.{u2 v2} }
  { F G : Functor C D }
  { X Y : C^.Obj }
  ( objectWitness : ∀ X : C^.Obj, F^.onObjects X = G^.onObjects X )
  ( f : D^.Hom (F^.onObjects X) (F^.onObjects Y) ) : D^.Hom (G^.onObjects X) (G^.onObjects Y) :=
  begin
    rewrite (objectWitness X) at f,
    rewrite (objectWitness Y) at f,
    exact f
  end

lemma Functors_pointwise_equal
  { C : Category.{u1 v1} }
  { D : Category.{u2 v2} }
  { F G : Functor C D }
  ( objectWitness : ∀ X : C^.Obj, F^.onObjects X = G^.onObjects X )
  ( morphismWitness : ∀ X Y : C^.Obj, ∀ f : C^.Hom X Y, rewriteMorphism objectWitness (F^.onMorphisms f)  = G^.onMorphisms f ) : F = G :=
begin
  induction F with F_onObjects F_onMorphisms,
  induction G with G_onObjects G_onMorphisms,
  assert h_objects : F_onObjects = G_onObjects, exact funext objectWitness,
  subst h_objects,
  assert h_morphisms : @F_onMorphisms = @G_onMorphisms,
  apply funext, intro X, apply funext, intro Y, apply funext, intro f,
  exact morphismWitness X Y f,
  subst h_morphisms
end

@[reducible] definition IdentityFunctor ( C: Category ) : Functor C C :=
{
  onObjects     := id,
  onMorphisms   := λ _ _ f, f
}

@[reducible] definition FunctorComposition { C D E : Category } ( F : Functor C D ) ( G : Functor D E ) : Functor C E :=
{
  onObjects     := λ X, G^.onObjects (F^.onObjects X),
  onMorphisms   := λ _ _ f, G^.onMorphisms (F^.onMorphisms f)
}

definition CategoryOfCategoriesAndFunctors : Category := {
  Obj := Category,
  Hom := λ C D, Functor C D,
  identity := λ C, IdentityFunctor C,
  compose  := λ _ _ _ F G, FunctorComposition F G,
  left_identity  := begin
                      intros,
                      fapply Functors_pointwise_equal,
                      intros,
                      dsimp,
                      refl,
                      intros,
                      dsimp,
                      refl
                    end
}


import Mathlib.Tactic.Basic
import Std.Tactic.GuardExpr

example : n + 2 = m := by
  change n + 1 + 1 = _
  guard_target =ₛ n + 1 + 1 = m
  sorry

example (h : n + 2 = m) : False := by
  change _ + 1 = _ at h
  guard_hyp h :ₛ n + 1 + 1 = m
  sorry

example : n + 2 = m := by
  fail_if_success change true
  fail_if_success change _ + 3 = _
  fail_if_success change _ * _ = _
  change (_ : Nat) + _ = _
  sorry

-- `change ... at ...` allows placeholders to mean different things at different hypotheses
example (h : n + 3 = m) (h' : n + 2 = m) : False := by
  change _ + 1 = _ at h h'
  guard_hyp h :ₛ n + 2 + 1 = m
  guard_hyp h' :ₛ n + 1 + 1 = m
  sorry

-- `change ... at ...` preserves dependencies
example (p : n + 2 = m → Type) (h : n + 2 = m) (x : p h) : false := by
  change _ + 1 = _ at h
  guard_hyp x :ₛ p h
  sorry

example : Nat := by
  fail_if_success change Type 1
  sorry

def foo (a b c : Nat) := if a < b then c else 0

example : foo 1 2 3 = 3 := by
  change (if _ then _ else _) = _
  change ite _ _ _ = _
  change (if _ < _ then _ else _) = _
  change _ = (if true then 3 else 4)
  rfl

example (h : foo 1 2 3 = 4) : True := by
  change ite _ _ _ = _ at h
  guard_hyp h :ₛ ite (1 < 2) 3 0 = 4
  trivial

example (h : foo 1 2 3 = 4) : True := by
  change (if _ then _ else _) = _ at h
  guard_hyp h : (if 1 < 2 then 3 else 0) = 4
  trivial

example (α : Type) [LT α] (x : α) (h : x < x) : x < id x := by
  change _ < _ -- can defer LT typeclass lookup, just like `show`
  change _ < _ at h -- can defer LT typeclass lookup at h too
  guard_target =ₛ x < id x
  change _ < x
  guard_target =ₛ x < x
  exact h

example (x y : Nat) (h : x = y) : True := by
  change (if 1 < 2 then x else ?_) = y at h
  rotate_left
  · exact 4
  guard_hyp h : (if 1 < 2 then x else 4) = y
  · trivial

example : let x := 22; let y : Nat := x; let z : Fin (y + 1) := 0; z.1 < y + 1 := by
  intro x y z -- `z` was erroneously marked as unused
  change _ at y
  exact z.2


/-
Copyright (c) 2020 Bjørn Kjos-Hanssen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Bjørn Kjos-Hanssen.
Zulip chat help from:
  Alex J. Best, Johan Commelin, Kyle Miller, Pedro Minicz, Reid Barton, Scott Morrison, Heather Macbeth.
Code contribution and definition of D improvement from:
  Jason Greuling
-/
import data.finset  -- finite set
import data.set -- to make backslash work as set difference
import data.finset.basic
import topology.metric_space.basic

import data.real.basic

import delta

import data.set.basic

--set_option profiler true

set_option pp.all true

/-!
# A theorem on metrics based on min and max
In this file we give a formal proof that in terms of
d(X,Y)= m min(|X\Y|, |Y\X|) + M max(|X\Y|, |Y\X|)
the function
D(X,Y) = d(X,Y)/(|X ∩ Y|+d(X,Y))
is a metric if and only if m ≤ M and 1 ≤ M.
In particular, taking m=M=1, the Jaccard distance is a metric on finset ℕ.
## Main results
- `noncomputable instance jaccard_nid.metric_space`: the proof of the main result described above.
- `noncomputable instance jaccard.metric_space`: the special case of the Jaccard distance.
## Notation
 - `|_|` : Notation for cardinality.
## References
See [KNYHLM20] for the original proof (https://math.hawaii.edu/~bjoern/nid-walcom.pdf).
-/

open finset

local notation |X| := X.card

variables {m M : ℝ} -- in delta.lean but can't import variables

section jaccard_nid

variables {α : Type*} [decidable_eq α]
--#check δ
noncomputable def D : ℝ → ℝ → finset α → (finset α → ℝ) :=
  λ m M x y, (δ m M x y) / (|x ∩ y| + δ m M x y)
  -- using Lean's "group with zero" to hand the case 0/0=0

lemma cap_sdiff (X Y Z : finset α): X ∩ Z  ⊆  X ∩ Y ∪ Z \ Y := by{tidy, by_cases h: a ∈ Y, cc,cc}
lemma sdiff_cap (X Y Z : finset α): X ∩ Z \ Y ⊆ Z \ Y := -- by show_term{tidy} -- by tidy?
by {intros a a_1, dsimp at *, simp at *, cases a_1, cases a_1_left, fsplit, work_on_goal 0 { assumption }, assumption}

--#print sdiff_cap

theorem twelve_end (X Y Z : finset α) : |X ∩ Z| ≤ |X ∩ Y| + max (|Z \ Y|) (|Y \ Z|) :=
let z_y := |Z \ Y|, y_z := |Y \ Z|, y := |Y|, z := |Z| in
(em (y ≤ z)).elim(
  λ h: y ≤ z, calc |X ∩ Z| ≤ |X ∩ Y  ∪  Z \ Y|     : card_le_of_subset (cap_sdiff X Y Z)
                       ... ≤ |X ∩ Y| + |Z \ Y|     : card_union_le (X ∩ Y) (Z \ Y)
                       ... = |X ∩ Y| + max z_y y_z : by rw[max_eq_left (sdiff_card Z Y h)]
)(
  λ h: ¬ y ≤ z,
  have h1: z ≤ y, from le_of_lt ((iff.elim_right lt_iff_not_ge') h),
  have h_diff: z_y ≤ y_z, from sdiff_card Y Z h1, let
    x110 := |X ∩ Y \ Z|, x111 := |X ∩ Y ∩ Z|, x010 := |Y \ X \ Z|,
    x111 := |X ∩ Y ∩ Z|, x101 := |X ∩ Z \ Y|, xz := |X ∩ Z|,
    xy := |X ∩ Y|, xz_y := |X ∩ Z \ Y| in
  have r: xz_y ≤ z_y, from card_le_of_subset (sdiff_cap X Y Z),
  have uni_xz:  X ∩ Z = (X ∩ Z \ Y) ∪ (X ∩ Y ∩ Z), by { tidy, by_cases h: a ∈ Y, cc, cc},
  have uni_xy:  (X ∩ Y \ Z) ∪ (X ∩ Y ∩ Z) = X ∩ Y, by { tidy, by_cases h: a ∈ Z, cc, cc},
  have uni_y_z: (X ∩ Y \ Z) ∪ (Y \ X \ Z) = Y \ Z, by { tidy, by_cases h: a ∈ X, cc, cc},
  have dis_xz:  disjoint (X ∩ Z \ Y) (X ∩ Y ∩ Z), by { rw disjoint_iff, tidy},
  have dis_xy:  disjoint (X ∩ Y \ Z) (X ∩ Y ∩ Z), by { rw disjoint_iff, tidy},
  have dis_y_z: disjoint (X ∩ Y \ Z) (Y \ X \ Z), by { rw disjoint_iff, tidy},
  have sum_xz: xz = x101 + x111, from calc
               xz = ((X ∩ Z \ Y) ∪ (X ∩ Y ∩ Z)).card : congr_arg card uni_xz
              ... = x101 + x111: card_disjoint_union dis_xz,
  have sum_xy:  x110 + x111 = xy, from calc
                x110 + x111 = ((X ∩ Y \ Z) ∪ (X ∩ Y ∩ Z)).card: (card_disjoint_union dis_xy).symm
                        ... = xy: (congr_arg card uni_xy),
  have sum_y_z: x110 + x010 = y_z, from calc
                x110 + x010 = ((X ∩ Y \ Z) ∪ (Y \ X \ Z)).card: (card_disjoint_union dis_y_z).symm
                        ... = y_z: congr_arg card uni_y_z,
  have prelim: x101 ≤ x110 + x110 + x010, from calc
               x101 ≤ y_z                 : le_trans r h_diff
                ... = x110 + x010          : by rw[sum_y_z]
                ... = 0 + (x110 + x010)    : by ring
                ... ≤ x110 + (x110 + x010) : add_le_add_right (nat.zero_le x110) (x110 + x010)
                ... = x110 + x110 + x010   : by ring,
  calc xz = x101 + x111                   : sum_xz
      ... ≤ x110 + x110 + x010 + x111     : add_le_add_right prelim x111
      ... = (x110 + x111) + (x110 + x010) : by ring
      ... = xy            + max z_y y_z   : by rw[sum_xy,sum_y_z,max_eq_right h_diff]
)

theorem twelve_middle (hm: 0 ≤ m) (hM: 0 < M) (X Y Z : finset α) :
let y_z := |Y\Z|, z_y := |Z\Y|, xy := |X ∩ Y|, xz := |X ∩ Z| in
(|X ∩ Z|:ℝ) ≤ (xy:ℝ) + (max z_y y_z:ℝ) + (m/M) * (min z_y y_z:ℝ) :=
let y_z := |Y\Z|, z_y := |Z\Y|, xy := |X ∩ Y|, xz := |X ∩ Z| in
    have b: 0 ≤ m/M ↔ 0*M ≤ m, from le_div_iff hM,
    have a: 0*M ≤ m, from calc
            0*M = 0 : by ring
            ... ≤ m : hm,
    have g:0 ≤ m/M, from (iff.elim_right b) a,
    have e:0 ≤ min z_y y_z, from le_min (nat.zero_le z_y) (nat.zero_le y_z),
    have f:0 ≤ (min z_y y_z:ℝ), begin norm_cast,exact e, end,
    let maxzy := (max z_y y_z:ℝ) in
    calc
    (xz:ℝ) ≤ (xy:ℝ) + (max z_y y_z:ℝ): by {norm_cast,exact (twelve_end X Y Z)}
       ... = (xy:ℝ) + maxzy + 0                       : by ring
       ... ≤ (xy:ℝ) + maxzy + (m/M) * (min z_y y_z:ℝ) :
              add_le_add_left (mul_nonneg g f) ((xy:ℝ) + maxzy)

theorem jn_self  (X : finset α): D m M X X = 0 :=
    show (δ m M X X) / (|X ∩ X| + δ m M X X) = 0, by rw[delta_self,zero_div]

theorem delta_nonneg {x y : finset α} (hm: 0 ≤ m) (hM: m ≤ M): 0 ≤ δ m M x y :=
  have alpha: δ m M x x ≤ δ m M x y + δ m M y x, from seventeen_right hm hM,
  have 0 ≤ 2 * δ m M x y, from calc
       0 = δ m M x x: by rw[delta_self]
     ... ≤ δ m M x y + δ m M y x: seventeen_right hm hM
     ... = 2 * δ m M x y: by rw [delta_comm, two_mul],
  nonneg_of_mul_nonneg_left this zero_lt_two

theorem jn_comm (X Y : finset α): D m M X Y = D m M Y X :=
    show (δ m M X Y) / (|X ∩ Y| + δ m M X Y)  = (δ m M Y X) / (|Y ∩ X| + δ m M Y X), from
    by rw[delta_comm,delta_comm,inter_comm]

lemma card_inter_nonneg (X Y : finset α):
  0 ≤ (|X ∩ Y|:ℝ) := by { norm_cast, exact (nat.zero_le (|X ∩ Y|))}

lemma D_denom_nonneg (X Y : finset α) (hm: 0 ≤ m) (hM: m ≤ M):
  0 ≤ (|X ∩ Y|:ℝ) + δ m M X Y := add_nonneg (card_inter_nonneg X Y) (delta_nonneg hm hM)

theorem eq_of_jn_eq_zero (hm: 0 < m) (hM: m ≤ M) (X Y : finset α) (h: D m M X Y = 0) : X = Y :=
    have h1: (δ m M X Y) = 0 ∨ ((|X ∩ Y|:ℝ) + δ m M X Y) = 0, from
      (iff.elim_left (div_eq_zero_iff)) h,
    h1.elim(
        assume g: δ m M X Y = 0,
        eq_of_delta_eq_zero hm hM X Y g
    )(
        assume g: (|X ∩ Y|:ℝ) + δ m M X Y = 0,
        have denom:  0 = δ m M X Y + |X ∩ Y| , begin rw[add_comm] at g, exact g.symm, end,
        have nonneg: 0 ≤ δ m M X Y, from delta_nonneg (le_of_lt hm) hM,
        have zero:   0 = δ m M X Y, from
            eq_zero_of_nonneg_of_nonneg_of_add_zero nonneg (card_inter_nonneg X Y) denom,
        eq_of_delta_eq_zero hm hM X Y (eq.symm zero)
    )

theorem D_nonneg (X Y : finset α) (hm: 0 ≤ m) (hM: m ≤ M): 0 ≤ D m M X Y :=
have hc: 0 ≤ δ m M X Y, from delta_nonneg hm hM,
(em (0 < (|X ∩ Y|:ℝ) + δ m M X Y)).elim(
  λ hd: 0 < (|X ∩ Y|:ℝ) + δ m M X Y,
  calc
    0 = 0         / ((|X ∩ Y|:ℝ) + δ m M X Y) : by rw[zero_div]
  ... ≤ δ m M X Y / ((|X ∩ Y|:ℝ) + δ m M X Y) : div_le_div hc hc hd (by apply_rules le_refl)
)(
  λ hd: ¬ 0 < (|X ∩ Y|:ℝ) + δ m M X Y,  -- in this case, X = Y = ∅
  have hd2: 0 ≤ (|X ∩ Y|:ℝ) + δ m M X Y, from D_denom_nonneg X Y hm hM,
  have hdd: 0 = (|X ∩ Y|:ℝ) + δ m M X Y, from
    by_contra (
      λ hh: ¬ 0 = (|X ∩ Y|:ℝ) + δ m M X Y,
      hd ((iff.elim_right lt_iff_le_and_ne) (and.intro hd2 hh))
    ),
  calc 0 ≤ 0: le_refl 0
  ... = δ m M X Y / 0: by rw[div_zero]
  ... = δ m M X Y / ((|X ∩ Y|:ℝ) + δ m M X Y): by rw[hdd]
)

theorem D_empty_1 (m M : ℝ) {X Y : finset α} (hm: 0 < m) (hM: m ≤ M):
  X = ∅ → Y ≠ ∅ → D m M X Y = 1 :=
λ hx: X = ∅, λ hy: Y ≠ ∅,
have hhh: X ∩ Y = ∅, from calc
          X ∩ Y = ∅ ∩ Y : by rw hx
            ... = ∅ :empty_inter Y,
have h: |X ∩ Y| = 0, from calc |X∩ Y|=|(∅:finset α)|: by rw hhh
... = 0: card_empty,
have h1: X ≠ Y, from
  assume h2: X = Y,
  have h3: Y = ∅, from eq.trans h2.symm hx,
  hy h3,
have h0: δ m M X Y ≠ 0, from
  assume h2: δ m M X Y = 0,
  have h3: X = Y, from eq_of_delta_eq_zero (hm) hM X Y h2,
  h1 h3,
have hh: (|X ∩ Y|:ℝ) = 0, begin norm_cast,exact h, end,
calc
(δ m M X Y)/(|X ∩ Y| + δ m M X Y) = (δ m M X Y)/(0 + δ m M X Y) : by rw[hh]
                              ... = (δ m M X Y)/(δ m M X Y)     : by rw[zero_add]
                              ... = 1                           : div_self h0

theorem D_empty_2  (m M : ℝ) {X Y : finset α} (hm: 0 < m) (hM: m ≤ M):
  X ≠ ∅ → Y = ∅ → D m M X Y = 1
:= λ hx: X ≠ ∅, λ hy: Y = ∅, let dxy := δ m M X Y, dyx := δ m M Y X in calc
dxy / (|X ∩ Y| + dxy) = (δ m M Y X)/(|Y ∩ X| + δ m M Y X) : by rw[delta_comm,inter_comm]
                  ... = 1                                 : D_empty_1 m M hm hM hy hx

lemma div_self_le_one (a:ℝ): a/a ≤ 1 :=
(em (a=0)).elim(
  λ h: a = 0, calc
    a/a = a/0: by rw[h]
    ... = 0  : div_zero a
    ... ≤ 1  : zero_le_one
)(
  λ h: a ≠ 0,
  calc a/a = 1: div_self h
  ... ≤ 1: le_refl 1
)

theorem D_bounded (m M : ℝ) (X Y : finset α) (hm: 0 ≤ m) (hM: m ≤ M): D m M X Y ≤ 1
  :=
  (em (0 = (|X ∩ Y|:ℝ) + δ m M X Y)).elim(
    λ h0: 0 = (|X ∩ Y|:ℝ) + δ m M X Y,
    calc
    (δ m M X Y)/(|X ∩ Y| + δ m M X Y) = (δ m M X Y)/0: by rw[h0]
                                  ... = 0: div_zero (δ m M X Y)
                                  ... ≤ 1: zero_le_one
  )(
    λ h0: 0 ≠ (|X ∩ Y|:ℝ) + δ m M X Y,
    let dxy := δ m M X Y in
    have hd2: 0 ≤ (|X ∩ Y|:ℝ) + dxy, from D_denom_nonneg X Y hm hM,

    have pos: 0 < (|X ∩ Y|:ℝ) + dxy, from (iff.elim_right lt_iff_le_and_ne) (and.intro hd2 h0),
    have h: dxy ≤ |X ∩ Y| + dxy, from
       calc dxy =    0    + dxy: by rw[zero_add]
            ... ≤ |X ∩ Y| + dxy: add_le_add_right (card_inter_nonneg X Y) (dxy),
    calc         dxy /(|X ∩ Y| + dxy)
    ≤ (|X ∩ Y| + dxy)/(|X ∩ Y| + dxy): div_le_div hd2 h pos (le_refl (|X ∩ Y| + dxy)) ...
    ≤ 1: div_self_le_one (|X ∩ Y| + dxy)
  )

theorem intersect_cases (m M : ℝ) (Y Z : finset α) (hm: 0<m) (hM: m≤ M) (hy: Y ≠ ∅) (hz: Z ≠ ∅):
    let ayz := (|Z ∩ Y|:ℝ), dyz :=  (δ m M Z Y) in 0 < (ayz + dyz) :=

    let ayz := (|Z ∩ Y|:ℝ), dyz :=  (δ m M Z Y) in

    (em (Y ∩ Z = ∅)).elim(
        λ hxy : Y ∩ Z = ∅,
        have decompose: Y = Y ∩ Z ∪ Y \ Z, begin tidy,by_cases (a ∈ Z),cc,cc, end,
        have non_empty: ∅ ≠ Y \ Z, from
          assume h: ∅ = Y \ Z,
          have h1:Y = ∅, from
            calc Y = Y ∩ Z ∪ Y \ Z : decompose
               ... =   ∅   ∪   ∅   : by rw[hxy,h]
               ... =       ∅       : by rw union_empty,
          hy h1,
        have ne_prelim: Z ≠ Y, from
          assume h: Z = Y,
          have h0: Y \ Z = ∅, from calc
                   Y \ Z = Z \ Z: by rw[h]
                     ... = ∅: sdiff_self Z,
          have h1: ∅ = Y \ Z, from h0.symm,
          non_empty h1,
        have ne: 0 ≠ dyz, from
          λ zero_eq_delta: 0 = dyz,
          have eq: Z = Y, from eq_of_delta_eq_zero hm hM Z Y zero_eq_delta.symm,
          ne_prelim eq,
        have le: 0 ≤ dyz, from delta_nonneg (le_of_lt hm) hM,
        calc 0 <       dyz: (iff.elim_right lt_iff_le_and_ne) (and.intro le ne)
           ... =  0  + dyz: by rw[zero_add]
           ... ≤ ayz + dyz: add_le_add_right (card_inter_nonneg Z Y) dyz
    )(
        λ hxy : Y ∩ Z ≠ ∅,
          have card_zero: |Y ∩ Z| = 0 ↔ Y ∩ Z = ∅, from card_eq_zero,
          have ne_nat: |Y ∩ Z| ≠ 0, from
            λ h: |Y ∩ Z| = 0,
            hxy ((iff.elim_left card_zero) h),
          have le: 0 ≤ (|Y ∩ Z|:ℝ), from card_inter_nonneg Y Z,
          have ne: 0 ≠ (|Y ∩ Z|:ℝ), begin norm_cast,exact ne_nat.symm, end,
          calc 0 < (|Y ∩ Z|:ℝ): (iff.elim_right lt_iff_le_and_ne) (and.intro le ne)
            ... = ayz      : by rw[inter_comm]
            ... = ayz +  0 : by rw[add_zero]
            ... ≤ ayz + dyz: add_le_add_left (delta_nonneg (le_of_lt hm) hM) ayz
    )

lemma four_immediate_from (m M : ℝ) (X Y Z : finset α)
  (hm: 0 < m) (hM: m ≤ M) (h1M: 1 ≤ M)
  (hx: X ≠ ∅) (hy: Y ≠ ∅) (hz: Z ≠ ∅):
  let axy := (|X ∩ Y|:ℝ), dxz := δ m M X Z, dyz := δ m M Z Y,
      axz := (|X ∩ Z|:ℝ), denom := axy+dxz+dyz in

  dxz/denom ≤ dxz/(axz + dxz) :=

  let dxy := (δ m M X Y), axy := (|X ∩ Y|:ℝ), dxz := δ m M X Z,
    dyz :=  (δ m M Z Y), ayz := (|Z ∩ Y|:ℝ), axz := (|X ∩ Z|:ℝ),
    y_z : ℕ := (Y \ Z).card, z_y : ℕ := (Z \ Y).card,x_z : ℕ := (X \ Z).card,
    z_x : ℕ := (Z \ X).card, xy : ℕ := (X ∩ Y).card,
    xz : ℕ := (X ∩ Z).card,  yz : ℕ := (Y ∩ Z).card,
    mini := (min (|Z \ Y|) (|Y \ Z|) : ℝ), maxi := (max (|Z \ Y|) (|Y \ Z|) : ℝ),
    denom := (axy+dxz+dyz)
  in
  have twelve_end_real: (xz:ℝ) ≤ (xy:ℝ) + max (|Z \ Y| : ℝ) (|Y \ Z| : ℝ), from
    have ddd: xz ≤ xy + max ((Z \ Y).card) ((Y \ Z).card), from twelve_end X Y Z,
    begin norm_cast,exact ddd, end,
  have max_nonneg_real: 0 ≤ (max (|Z \ Y|) (|Y \ Z|) : ℝ), from
    have 0 ≤ max z_y y_z, from nat.zero_le (max z_y y_z),
    begin norm_cast, exact this,end,
  have min_nonneg_real: 0 ≤ (min (|Z \ Y|) (|Y \ Z|) : ℝ), from
    have 0 ≤ min z_y y_z, from nat.zero_le (min z_y y_z),
    begin norm_cast, exact this,end,
  have mmin_nonneg : 0 ≤ m * mini, from mul_nonneg (le_of_lt hm) min_nonneg_real,
  have use_h1M: 1 * maxi ≤ M * maxi, from mul_le_mul_of_nonneg_right h1M max_nonneg_real,
  have four_would_follow_from : axz ≤ axy + dyz, from calc
      axz ≤ (xy:ℝ) +     maxi             : twelve_end_real
      ... = (xy:ℝ) + 1 * maxi             : by ring
      ... ≤ (xy:ℝ) + M * maxi             : add_le_add_left use_h1M (xy:ℝ)
      ... = (xy:ℝ) + M * maxi + 0         : by rw[add_zero]
      ... ≤ (xy:ℝ) + M * maxi + m * mini  : add_le_add_left mmin_nonneg ((xy:ℝ) + M * maxi)
      ... = (xy:ℝ) + (M * (max (|Z \ Y|) (|Y \ Z|) : ℝ) + m * (min (|Z \ Y|) (|Y \ Z|) : ℝ)):
        by rw[add_assoc]
      ... = (|X ∩ Y|:ℝ)    + (δ m M Z Y): begin norm_cast, end,
  have le_denom:(axz + dxz) ≤ denom, from
      calc axz + dxz ≤ axy + dyz + dxz : add_le_add_right four_would_follow_from dxz
                  ... = axy + dxz + dyz : by ring,
  have denom_pos : 0 < (axz + dxz), from intersect_cases m M Z X hm hM hz hx,
  have d_nonneg: 0 ≤ dxz, from delta_nonneg (le_of_lt hm) hM,
  div_le_div_of_le_left d_nonneg denom_pos le_denom

 lemma four_immediate_from_and  (m M : ℝ) (X Y Z : finset α)
  (hm: 0 < m) (hM: m ≤ M) (h1M: 1 ≤ M)
  (hx: X ≠ ∅) (hy: Y ≠ ∅) (hz: Z ≠ ∅):
  (δ m M Z Y)/((|X ∩ Y|:ℝ) + δ m M X Z + δ m M Z Y) ≤ (δ m M Z Y)/((|Z ∩ Y|:ℝ) + δ m M Z Y) :=

  let dzy := δ m M Z Y, dyz := δ m M Y Z, dxz := δ m M X Z, dzx := δ m M Z X in
  have S: (dyz) / ((|Y ∩ X|:ℝ) + (dyz) + (dzx)) ≤ (dyz) / ((|Y ∩ Z|:ℝ) + dyz), from
    four_immediate_from m M Y X Z hm hM h1M hy hx hz,
  have dzy_comm: dzy = dyz, from delta_comm,
  have dxz_comm: dxz = dzx, from delta_comm,
  have ring_in_denom: (|Y ∩ X|:ℝ) + dzx + dyz = (|Y ∩ X|:ℝ) + dyz + dzx, by ring,
  calc   dzy / ((|X ∩ Y|:ℝ) + dxz + dzy)
       = dyz / ((|Y ∩ X|:ℝ) + dyz + dzx) : by rw[inter_comm,dxz_comm,dzy_comm,ring_in_denom]
   ... ≤ dyz / ((|Y ∩ Z|:ℝ) + dyz)       : S
   ... = dzy / ((|Z ∩ Y|:ℝ) + dzy)       : by rw[inter_comm,dzy_comm]

lemma mul_le_mul_rt {a b c : ℝ} (h : 0 ≤ c) : a ≤ b → a * c ≤ b * c :=
(em (0 = c)).elim(
  λ h0: 0 = c,
  λ hab: a ≤ b,
  calc a* c = a * 0: by rw h0
  ... = 0: mul_zero a
  ... ≤ 0: le_refl 0
  ... = b * 0: by rw[mul_zero b]
  ... = b * c: by rw h0
)(
  λ h0: 0 ≠ c,
  λ hab: a ≤ b,
  have h1: 0 < c, from (iff.elim_right lt_iff_le_and_ne) (and.intro h h0),
  (iff.elim_right (mul_le_mul_right h1)) hab
)

lemma abc_lemma {a b c : ℝ} (h : 0 ≤ a) (hb : a ≤ b) (hc : 0 ≤ c) : (a/(a+c)) ≤ (b/(b+c)) :=

(em (0 = a)).elim(
  λ ha: 0 = a,
  (em (0 = b)).elim(
    λ hhb: 0 = b, -- a=b=0
        calc  a/(a+c)
            = 0/(0+c): by rw ha
        ... ≤ 0/(0+c): le_refl (0/(0+c))
        ... = b/(b+c): by rw hhb
  )(
    λ hhb: 0 ≠ b, -- a=0, b ≠ 0
      have g0: 0 ≤ b, from (le_trans h hb),
      have g: 0 ≤ b + c, from add_nonneg g0 hc,
        calc  a/(a+c)
            = 0/(a+c): by rw ha
        ... = 0: by rw zero_div
        ... ≤ b/(b+c): div_nonneg g0 g
  )
)(
  λ hh: 0 ≠ a, -- then, since a ≤ b, b ≠ 0 as well
        have ha: 0 < a, from (iff.elim_right lt_iff_le_and_ne) (and.intro h hh),
        have numer : a*(b+c) ≤ b*(a+c), from calc
          a*(b+c) = a*b + a*c : by rw left_distrib
              ... ≤ a*b + b*c : add_le_add_left (mul_le_mul_rt hc hb) (a*b)
              ... = b * (a+c) : by ring,
        have h6 : 0 < a+c, from lt_add_of_pos_of_le ha hc,
        have h7 : 0 < b+c, from lt_add_of_pos_of_le (has_lt.lt.trans_le ha hb) hc,
        (iff.elim_right (div_le_div_iff h6 h7)) numer
  )

theorem three (X Y Z : finset α) (hm: 0 < m) (hM: m ≤ M):
let axy := (|X ∩ Y| : ℝ), dxy := δ m M X Y, dxz := δ m M X Z,
    dyz := δ m M Z Y, denom := (axy+dxz+dyz) in

dxy/(axy + dxy) ≤ (dxz+dyz)/denom :=

let axy := (|X ∩ Y| : ℝ), dxy := δ m M X Y, dxz := δ m M X Z, dzy := δ m M Y Z, dyz := δ m M Z Y,
    axy := (|X ∩ Y| : ℝ), denom := (axy+dxz+dyz) in

  have hd : 0 ≤ δ m M X Y, from delta_nonneg (le_of_lt hm) hM,
  have h0 : δ m M Z Y = δ m M Y Z , by rw delta_comm,
  have h1 : dxy ≤ dxz + dzy, from calc
    dxy ≤ dxz + δ m M Z Y: delta_triangle X Z Y hm hM
    ... = dxz + δ m M Y Z: by rw h0,
  have h2: dxz + dyz + axy = axy + dxz + dyz, by ring,
    calc  dxy / (axy + dxy)
        = dxy / (dxy + axy)                           : by rw add_comm axy dxy
    ... ≤ (dxz + δ m M Y Z) / (dxz + dzy + axy)       : abc_lemma hd h1 (card_inter_nonneg X Y)
    ... = (dxz + δ m M Z Y) / (dxz + δ m M Z Y + axy) : by rw h0
    ... = (dxz + δ m M Z Y) / (axy + dxz + δ m M Z Y) : by rw h2

 theorem jn_triangle_nonempty
  (m M : ℝ) (X Y Z : finset α) (hm: 0 < m) (hM: m ≤ M) (h1M: 1 ≤ M)
  (hx: X ≠ ∅) (hy: Y ≠ ∅) (hz: Z ≠ ∅): D m M X Y ≤ D m M X Z + D m M Z Y :=
  let dxy := (δ m M X Y), axy := (|X ∩ Y|:ℝ), dxz := δ m M X Z,
    dyz :=  (δ m M Z Y), ayz := (|Z ∩ Y|:ℝ), axz := (|X ∩ Z|:ℝ),
    denom := (axy+dxz+dyz)
  in
    have hzM: 0 < M, from calc
             0 < m: hm
           ... ≤ M: hM,
    have three: dxy/(axy + dxy) ≤ (dxz+dyz)/denom, from three X Y Z hm hM,
    have four: (dxz+dyz)/denom ≤ dxz/(axz + dxz) + dyz/(ayz + dyz), from calc
    (dxz+dyz)/denom = dxz/denom + dyz/denom: add_div dxz dyz denom
                ... ≤ dxz/(axz + dxz)   + dyz/denom:
                add_le_add_right
                (four_immediate_from m M X Y Z hm hM h1M hx hy hz)
                ((dyz)/denom)
                ... ≤ dxz/(axz + dxz)   + dyz/(ayz + dyz)  :
                add_le_add_left
                (four_immediate_from_and m M X Y Z hm hM h1M hx hy hz)
                (dxz/(axz + dxz)),
    le_trans three four

theorem jn_triangle (m M : ℝ) (X Y Z : finset α)
(hm: 0 < m) (hM: m ≤ M) (h1M: 1 ≤ M): D m M X Y ≤ D m M X Z + D m M Z Y :=
let dxz := D m M X Z in
    (em (X=∅)).elim(
        λ hx: X = ∅,
        (em (Y=∅)).elim(
            λ hy: Y = ∅,
            have h1: X = Y, from eq.trans hx hy.symm, calc
            D m M X Y = D m M X X          : by rw[h1]
                  ... = 0                     : jn_self X
                  ... ≤             D m M Z Y : D_nonneg Z Y (le_of_lt hm) hM
                  ... = 0         + D m M Z Y : eq.symm (zero_add (D m M Z Y))
                  ... ≤ D m M X Z + D m M Z Y :
                  add_le_add_right (D_nonneg X Z (le_of_lt hm) hM) (D m M Z Y)
        )(
            λ hy: Y ≠ ∅,
            (em (Z = ∅)).elim(
                λ hz: Z = ∅, -- 010 non Y nonempty
                have h3: D m M Z Y = 1, from D_empty_1 m M hm hM hz hy,
                calc D m M X Y =             1: D_empty_1 m M hm hM hx hy
                        ... = 0         + 1: by rw[zero_add]
                        ... ≤ D m M X Z + 1: add_le_add_right (D_nonneg X Z (le_of_lt hm) hM) 1
                        ... = D m M X Z + D m M Z Y: by rw[h3]
            )(
                λ hz: Z ≠ ∅, -- 011 only X empty
                have h1: D m M X Y = 1, from D_empty_1 m M hm hM hx hy,
                have h2: D m M X Z = 1, from D_empty_1 m M hm hM hx hz,
                calc D m M X Y = 1: h1
                        ... = 1 + 0: by rw[add_zero]
                        ... ≤ 1 + D m M Z Y: add_le_add_left (D_nonneg Z Y (le_of_lt hm) hM) 1
                        ... = D m M X Z + D m M Z Y: by rw[h2]
            )
        )
    )(
      λ hx: X ≠ ∅,
      (em (Y=∅)).elim(
        λ hy: Y = ∅,
        (em (Z = ∅)).elim(
          λ hz: Z = ∅, -- 100 only X nonempty
          calc D m M X Y =     1                  : D_empty_2 m M hm hM hx hy
                     ... =     1     +      0     : by rw[add_zero]
                     ... ≤     1     +  D m M Z Y : add_le_add_left (D_nonneg Z Y (le_of_lt hm) hM) 1
                     ... = D m M X Z +  D m M Z Y : by rw[D_empty_2 m M hm hM hx hz]
        )(
          λ hz: Z ≠ ∅, -- 101 only Y empty
          calc D m M X Y =                 1    : D_empty_2 m M hm hM hx hy
                     ... =     0     +     1    : by rw[zero_add]
                     ... ≤ D m M X Z +     1    : add_le_add_right (D_nonneg X Z (le_of_lt hm) hM) 1
                     ... = D m M X Z + D m M Z Y : by rw[D_empty_2 m M hm hM hz hy]
        )
      )(
        λ hy: Y ≠ ∅,
        (em (Z = ∅)).elim(
          λ hz: Z = ∅, -- 110 only Z is empty
          have h2: D m M X Z = 1, from D_empty_2 m M hm hM hx hz,
          have h3: D m M Z Y = 1, from D_empty_1 m M hm hM hz hy,
          calc D m M X Y ≤             1: D_bounded m M X Y (le_of_lt hm) hM
                     ... =         0 + 1: by rw[zero_add]
                     ... ≤         1 + 1: add_le_add_right zero_le_one 1
                     ... = D m M X Z + D m M Z Y: by rw[h2,h3]
        )(
            λ hz: Z ≠ ∅, -- 111
            jn_triangle_nonempty m M X Y Z hm hM h1M hx hy hz
        )
      )
    )

noncomputable instance jaccard_nid.metric_space
(hm : 0 < m) (hM : m ≤ M) (h1M: 1 ≤ M): metric_space (finset α) := {
        dist               := λx y, D m M x y,
        dist_self          := jn_self,
        eq_of_dist_eq_zero := eq_of_jn_eq_zero hm hM,
        dist_comm          := λ x y, jn_comm x y,
        dist_triangle      := λ x z y, jn_triangle m M x y z hm hM h1M
    }

noncomputable def J : finset α → (finset α → ℝ) :=
  λ x y, (δ 1 1 x y) / ((|x ∩ y|:ℝ) + δ 1 1 x y)

--Easy but not done yet:
--theorem J_characterization (X Y : finset α):
--J X Y = ((|X \ Y|) + (|Y \ X|)) / (|X ∪ Y|) :=
--let dxy := (1:ℝ) * (max (|X \ Y|) (|Y \ X|):ℝ) + (1:ℝ) * (min (|X \ Y|) (|Y \ X|):ℝ) in
--calc dxy / ((|X ∩ Y|:ℝ) + dxy) = ((|X \ Y|) + (|Y \ X|)) / (|X ∪ Y|): sorry

noncomputable instance jaccard.metric_space
(hm : (0:ℝ) < (1:ℝ)) (hM : (1:ℝ) ≤ (1:ℝ)) (h1M: (1:ℝ) ≤ (1:ℝ)): metric_space (finset ℕ) := {
        dist               := λx y, D 1 1 x y,
        dist_self          := jn_self,
        eq_of_dist_eq_zero := eq_of_jn_eq_zero hm hM,
        dist_comm          := λ x y, jn_comm x y,
        dist_triangle      := λ x z y, jn_triangle 1 1 x y z hm hM h1M
    }

end jaccard_nid


import tactic
import data.set.finite

import topological_spaces
import neighbourhoods
import topological_spaces2

open set

open_locale classical

open topological_space

-- Convergence simple :
def pointwise_lim {X Y : Type} [topological_space Y] (f : ℕ → (X → Y)) (F : X → Y) : Prop :=
∀ (x : X), seq_lim (λ n, f n x) (F x)

-- Topologie produit sur X → Y :
instance fnct.topological_space (X Y : Type) [topological_space Y] : topological_space (X → Y) :=
topological_space.generate_from (X → Y) {U | ∃ (x : X) (Ux : set Y) (hUx : is_open Ux), U = {f : X → Y | f x ∈ Ux}}

-- Base de la topologie produit (intersections finies de générateurs) :
lemma is_open_fnct_iff {X Y : Type} [topological_space Y] {s : set (X → Y)} :
is_open s ↔ ∀ f ∈ s, ∃ (D : set X) (φ : X → set Y) (hD : finite D) (hφ : ∀ x ∉ D, φ x = univ), (∀ x, is_open (φ x)) ∧ (∀ x, f x ∈ φ x) ∧ ({f' : X → Y | ∀ x, f' x ∈ φ x} ⊆ s) :=
begin
  split,
  { intros hyp f hf,
    induction hyp with U hU A B hA1 hB1 hA2 hB2 C hC1 hC2,
    { rcases hU with ⟨ x, Ux, hUx, hU ⟩,
      use [{x}, (λ x', ite (x' = x) Ux univ)], split,
      exact finite_singleton x, repeat {split},
      intros x' hx', simp, intro H, exfalso, exact hx' H,
      intro x', split_ifs, exact hUx, exact univ_mem,
      intro x', split_ifs, rw h, rw hU at hf, exact hf, simp,
      intros f' hf', rw hU, specialize hf' x, simp at hf', exact hf', },
    { rcases hA2 hf.1 with ⟨ D1, φ1, hD1, hφ1, hoφ1, hfφ1, hA ⟩,
      rcases hB2 hf.2 with ⟨ D2, φ2, hD2, hφ2, hoφ2, hfφ2, hB ⟩,
      use [(D1 ∪ D2), (λ x, (φ1 x) ∩ (φ2 x))], split,
      exact finite.union hD1 hD2, repeat {split},
      intros x hx, rw union_def at hx, simp at hx, push_neg at hx, simp [hφ1 x hx.1, hφ2 x hx.2],
      intro x, exact inter (hoφ1 x) (hoφ2 x),
      intro x, split, exact hfφ1 x, exact hfφ2 x,
      intros f' hf', split, apply hA, intro x, exact (hf' x).1, apply hB, intro x, exact (hf' x).2, },
    { rcases hf with ⟨c, hcC, hfc⟩,
      rcases hC2 c hcC hfc with ⟨ D, φ, hD, hφ, hoφ, hfφ, hc ⟩,
      use [D, φ], split,
      exact hD, repeat {split},
      exact hφ, exact hoφ, exact hfφ,
      intros f' hf', use [c, hcC, hc hf'], },
    { use [∅, (λ x, univ)], split,
      exact finite_empty, repeat {split},
      simp,
      intro x, exact univ_mem,
      repeat {simp}, }, },
  { intro hyp,
    choose D_ φ_ H1 H2 H3 H4 H5 using hyp,
    have clef : s = ⋃₀ { ({f' : X → Y | ∀ x, f' x ∈ φ_ f H x}) | (f : X → Y) (H : f ∈ s)},
    { apply le_antisymm,
      { intros f hf,
        use {f' : X → Y | ∀ x, f' x ∈ φ_ f hf x},
        use [f, hf, H4 f hf], },
      { rintros f ⟨ V, ⟨f', hf', hV⟩, hfV⟩,
        rw ← hV at hfV,
        exact H5 f' hf' hfV, }, },
    rw clef,
    apply union,
    rintros V ⟨ f, hf, hV ⟩,
    have clef2 : V = ⋂₀ { ({f' : X → Y | f' x ∈ φ_ f hf x }) | x ∈ D_ f hf },
    { apply le_antisymm,
      { intros f' hf',
        rintros Vx ⟨ x, hx, hVx ⟩,
        rw ← hVx,
        rw ← hV at hf',
        exact hf' x, },
      { intros f' hf',
        rw ← hV,
        intro x,
        cases em (x ∈ D_ f hf) with hx1 hx2,
        apply hf' {f' : X → Y | f' x ∈ φ_ f hf x },
        use [x, hx1],
        rw H2 f hf x hx2, simp, }, },
    rw clef2,
    apply finite_inter,
    { let ψ := λ x, {f' : X → Y | f' x ∈ φ_ f hf x},
      have : {_x : set (X → Y) | ∃ (x : X) (H : x ∈ D_ f hf), {f' : X → Y | f' x ∈ φ_ f hf x} = _x} = ψ '' (D_ f hf),
      { apply le_antisymm,
        { rintros V ⟨x, hx, hV⟩, rw ← hV, clear hV V,
          use x, split, exact hx, refl, },
        { rintros V ⟨x, hx, hV⟩, rw ← hV, clear hV V,
          use x, split, exact hx, refl, }, },
      rw this,
      exact finite.image ψ (H1 f hf), },
    rintros Vx ⟨ x, hx, hVx ⟩,
    rw ← hVx,
    apply generated_open.generator,
    use [x, φ_ f hf x], split,
    exact H3 f hf x,
    refl, },
end

-- Cette topologie est la topologie de la convergence simple :
example {X Y : Type} [topological_space Y] (f : ℕ → (X → Y)) (F : X → Y) :
pointwise_lim f F ↔ seq_lim f F :=
begin
  split,
  { intro hyp,
    intros V hV,
    rcases (is_neighbourhood_iff F).1 hV with ⟨U, hU, hFU, hUV⟩,
    rw is_open_fnct_iff at hU,
    rcases hU F hFU with ⟨D, φ, hD, hφ, h1, h2, h3⟩,
    cases em (D.nonempty) with hD1 hD2,
    { have clef : ∀ x, ∃ (N : ℕ), ∀ n ≥ N, f n x ∈ φ x,
      { intros x,
        have hφx : (φ x) ∈ neighbourhoods (F x),
        { rw is_neighbourhood_iff,
          use [φ x, h1 x, h2 x], },
        exact hyp x (φ x) hφx, },
      choose ψ hψ using clef,
      cases finite.exists_maximal_wrt ψ D hD hD1 with x₀ hx₀, rw exists_prop at hx₀,
      let N := ψ x₀,
      have hN : ∀ x ∈ D, N ≥ ψ x,
      { intros x hx,
        cases le_total N (ψ x) with H1 H2,
        exact ge_of_eq (hx₀.2 x hx H1),
        exact H2, },
      use N,
      intros n hn,
      apply hUV, apply h3,
      intro x,
      cases em (x ∈ D) with hx1 hx2,
      exact hψ x n (ge_trans hn (hN x hx1)),
      rw hφ x hx2, simp, },
    { rw nonempty_def at hD2, push_neg at hD2,
      use 0,
      intros n hn,
      apply hUV, apply h3,
      intro x, rw hφ x (hD2 x), simp, }, },
  { intro hyp,
    intros x Vx hVx,
    rcases (is_neighbourhood_iff (F x)).1 hVx with ⟨Ux, hUx, hxUx, hUxVx⟩,
    let V := {g : X → Y | g x ∈ Vx},
    have hV: V ∈ neighbourhoods F,
    { rw is_neighbourhood_iff,
      use {g : X → Y | g x ∈ Ux}, repeat {split},
      apply generated_open.generator,
      use [x, Ux, hUx],
      exact hxUx,
      intros g hg,
      exact hUxVx hg, },
    cases hyp V hV with N hN,
    use N,
    intros n hn,
    exact hN n hn, },
end


/-
Copyright (c) 2018-2019 Minchao Wu. All rights reserved.
Released under MIT license as described in the file LICENSE.
Author: Minchao Wu
-/
import data.list

open nat tactic subtype

inductive nnf : Type
| var (n : nat)
| neg (n : nat)
| and (φ ψ : nnf)
| or (φ ψ : nnf)
| box (φ : nnf)
| dia (φ : nnf)

open nnf
instance : inhabited nnf := ⟨nnf.var 0⟩

class no_literals (Γ : list nnf) :=
(no_var : ∀ {n}, var n ∉ Γ)
(no_neg : ∀ {n}, neg n ∉ Γ)

class saturated (Γ : list nnf) :=
(no_and : ∀ {φ ψ}, nnf.and φ ψ ∉ Γ)
(no_or : ∀ {φ ψ}, nnf.or φ ψ ∉ Γ)

class box_only (Γ : list nnf) extends no_literals Γ, saturated Γ :=
(no_dia : ∀ {φ}, nnf.dia φ ∉ Γ)

def box_only_nil : box_only [] :=
{no_var := λ n hn, absurd hn $ list.not_mem_nil _,
no_neg := λ n hn, absurd hn $ list.not_mem_nil _,
no_and := λ φ ψ hn, absurd hn $ list.not_mem_nil _,
no_or := λ φ ψ hn, absurd hn $ list.not_mem_nil _,
no_dia := λ n hn, absurd hn $ list.not_mem_nil _}

def cons_box_only {φ Γ} (h : box_only Γ) : box_only (box φ :: Γ) :=
{no_var := begin intros n hn, cases hn, contradiction, apply h.no_var, exact hn end,
no_neg := begin intros n hn, cases hn, contradiction, apply h.no_neg, exact hn end,
no_and := begin intros ψ₁ ψ₂ hψ, cases hψ, contradiction, apply h.no_and, exact hψ end,
no_or := begin intros ψ₁ ψ₂ hψ, cases hψ, contradiction, apply h.no_or, exact hψ end,
no_dia := begin intros n hn, cases hn, contradiction, apply h.no_dia, exact hn end}

def box_only_ex : Π {φ Γ} (h₁ : box_only Γ) (h₂ : φ ∈ Γ), ∃ ψ, φ = box ψ
| (var n) Γ h₁ h₂   := begin exfalso, apply h₁.no_var, exact h₂ end
| (neg n) Γ h₁ h₂   := begin exfalso, apply h₁.no_neg, exact h₂ end
| (and φ ψ) Γ h₁ h₂ := begin exfalso, apply h₁.no_and, exact h₂ end
| (or φ ψ) Γ h₁ h₂  := begin exfalso, apply h₁.no_or, exact h₂ end
| (box φ) Γ h₁ h₂   := ⟨φ, rfl⟩
| (dia φ) Γ h₁ h₂   := begin exfalso, apply h₁.no_dia, exact h₂ end

def nnf.to_string : nnf → string
| (var n)    := "P" ++ n.repr
| (neg n)    := "¬P" ++ n.repr
| (and φ ψ)  := nnf.to_string φ ++ "∧" ++ nnf.to_string ψ
| (or φ ψ)   := nnf.to_string φ ++ "∨" ++ nnf.to_string ψ
| (box φ)    := "□" ++ "(" ++ nnf.to_string φ ++ ")"
| (dia φ)    := "◇" ++ "(" ++ nnf.to_string φ ++ ")"

instance nnf_repr : has_repr nnf := ⟨nnf.to_string⟩

instance dec_eq_nnf : decidable_eq nnf := by mk_dec_eq_instance

structure kripke (states : Type) :=
(val : ℕ → states → Prop)
(rel : states → states → Prop)

instance inhabited_kripke : inhabited (kripke ℕ) :=
⟨{ val := λ a b, tt, rel := λ a b, tt }⟩

open nnf

/- Do not use map -/
@[simp] def node_size : list nnf → ℕ
| []          := 0
| (hd :: tl)  := sizeof hd + node_size tl

inductive close_instance (Γ : list nnf)
| cons : Π {n}, var n ∈ Γ → neg n ∈ Γ → close_instance

inductive and_instance (Γ : list nnf) : list nnf → Type
| cons : Π {φ ψ}, nnf.and φ ψ ∈ Γ →
         and_instance (φ :: ψ :: Γ.erase (nnf.and φ ψ))

inductive or_instance (Γ : list nnf) : list nnf → list nnf → Type
| cons : Π {φ ψ}, nnf.or φ ψ ∈ Γ →
         or_instance (φ :: Γ.erase (nnf.or φ ψ))
                     (ψ :: Γ.erase (nnf.or φ ψ))

def left_prcp : Π {Γ₁ Γ₂ Δ : list nnf} (i : or_instance Δ Γ₁ Γ₂), nnf
| Γ₁ Γ₂ Δ (@or_instance.cons _ φ ψ _) := φ

@[simp] def sub_nnf : nnf → list nnf
| (var n)    := [var n]
| (neg n)    := [neg n]
| (and φ ψ)  := and φ ψ :: (sub_nnf φ ++ sub_nnf ψ)
| (or φ ψ)   := or φ ψ :: (sub_nnf φ ++ sub_nnf ψ)
| (box φ)    := box φ :: sub_nnf φ
| (dia φ)    := dia φ :: sub_nnf φ

theorem mem_sub_nnf_self : Π φ : nnf, φ ∈ sub_nnf φ :=
begin intro φ, cases φ,  all_goals {simp} end

theorem mem_sub_nnf_and {φ ψ : nnf} : Π γ : nnf, and φ ψ ∈ sub_nnf γ → φ ∈ sub_nnf γ ∧ ψ ∈ sub_nnf γ
| (var n) h   := begin simp at h, contradiction end
| (neg n) h   := begin simp at h, contradiction end
| (and φ₁ ψ₁) h :=
begin
simp only [sub_nnf] at h,
cases h,
{injection h with eq₁ eq₂,
 rw eq₁, rw eq₂,
 simp only [sub_nnf],
 split,
 {simp, right, left, apply mem_sub_nnf_self},
 {simp, right, right, apply mem_sub_nnf_self}},
{have := (@list.mem_append _ _ _ _).1 h,
 cases this,
 {split,
  {simp, right, left, apply (mem_sub_nnf_and _ _).1, exact this},
  {simp, right, left, apply (mem_sub_nnf_and _ _).2, exact this}},
 {split,
  {simp, right, right, apply (mem_sub_nnf_and _ _).1, exact this},
  {simp, right, right, apply (mem_sub_nnf_and _ _).2, exact this}}}
end
| (or φ₁ ψ₁) h  :=
begin
simp at h,
cases h,
 {split,
  {simp, right, left, apply (mem_sub_nnf_and _ _).1, exact h},
  {simp, right, left, apply (mem_sub_nnf_and _ _).2, exact h}},
 {split,
  {simp, right, right, apply (mem_sub_nnf_and _ _).1, exact h},
  {simp, right, right, apply (mem_sub_nnf_and _ _).2, exact h}}
end
| (box φ₁) h   :=
begin
simp at h,
{split,
 {simp, right, apply (mem_sub_nnf_and _ _).1, exact h},
 {simp, right, apply (mem_sub_nnf_and _ _).2, exact h}}
end
| (dia φ₁) h   :=
begin
simp at h,
{split,
 {simp, right, apply (mem_sub_nnf_and _ _).1, exact h},
 {simp, right, apply (mem_sub_nnf_and _ _).2, exact h}}
end

theorem mem_sub_nnf_or {φ ψ : nnf} : Π γ : nnf, or φ ψ ∈ sub_nnf γ → φ ∈ sub_nnf γ ∧ ψ ∈ sub_nnf γ
| (var n) h   := begin simp at h, contradiction end
| (neg n) h   := begin simp at h, contradiction end
| (and φ₁ ψ₁) h :=
begin
simp at h,
cases h,
 {split,
  {simp, right, left, apply (mem_sub_nnf_or _ _).1, exact h},
  {simp, right, left, apply (mem_sub_nnf_or _ _).2, exact h}},
 {split,
  {simp, right, right, apply (mem_sub_nnf_or _ _).1, exact h},
  {simp, right, right, apply (mem_sub_nnf_or _ _).2, exact h}}
end
| (or φ₁ ψ₁) h  :=
begin
simp only [sub_nnf] at h,
cases h,
{injection h with eq₁ eq₂,
 rw eq₁, rw eq₂,
 simp only [sub_nnf],
 split,
 {simp, right, left, apply mem_sub_nnf_self},
 {simp, right, right, apply mem_sub_nnf_self}},
{have := (@list.mem_append _ _ _ _).1 h,
 cases this,
 {split,
  {simp, right, left, apply (mem_sub_nnf_or _ _).1, exact this},
  {simp, right, left, apply (mem_sub_nnf_or _ _).2, exact this}},
 {split,
  {simp, right, right, apply (mem_sub_nnf_or _ _).1, exact this},
  {simp, right, right, apply (mem_sub_nnf_or _ _).2, exact this}}}
end
| (box φ₁) h   :=
begin
simp at h,
{split,
 {simp, right, apply (mem_sub_nnf_or _ _).1, exact h},
 {simp, right, apply (mem_sub_nnf_or _ _).2, exact h}}
end
| (dia φ₁) h   :=
begin
simp at h,
{split,
 {simp, right, apply (mem_sub_nnf_or _ _).1, exact h},
 {simp, right, apply (mem_sub_nnf_or _ _).2, exact h}}
end

theorem mem_sub_nnf_box {φ : nnf} : Π γ : nnf, box φ ∈ sub_nnf γ → φ ∈ sub_nnf γ
| (var n) h   := begin simp at h, contradiction end
| (neg n) h   := begin simp at h, contradiction end
| (and φ₁ ψ₁) h :=
begin
simp at h,
cases h,
{simp, right, left, apply mem_sub_nnf_box, exact h},
{simp, right, right, apply mem_sub_nnf_box, exact h}
end
| (or φ₁ ψ₁) h  :=
begin
simp at h,
cases h,
{simp, right, left, apply mem_sub_nnf_box, exact h},
{simp, right, right, apply mem_sub_nnf_box, exact h}
end
| (box φ₁) h   :=
begin
simp at h,
cases h,
{rw h, simp, right, apply mem_sub_nnf_self},
{simp, right, apply mem_sub_nnf_box, exact h}
end
| (dia φ₁) h   :=
begin
simp at h,
simp, right, apply mem_sub_nnf_box, exact h
end

theorem mem_sub_nnf_dia {φ : nnf} : Π γ : nnf, dia φ ∈ sub_nnf γ → φ ∈ sub_nnf γ
| (var n) h   := begin simp at h, contradiction end
| (neg n) h   := begin simp at h, contradiction end
| (and φ₁ ψ₁) h :=
begin
simp at h,
cases h,
{simp, right, left, apply mem_sub_nnf_dia, exact h},
{simp, right, right, apply mem_sub_nnf_dia, exact h}
end
| (or φ₁ ψ₁) h  :=
begin
simp at h,
cases h,
{simp, right, left, apply mem_sub_nnf_dia, exact h},
{simp, right, right, apply mem_sub_nnf_dia, exact h}
end
| (box φ₁) h   :=
begin
simp at h,
simp, right, apply mem_sub_nnf_dia, exact h
end
| (dia φ₁) h   :=
begin
simp at h,
cases h,
{rw h, simp, right, apply mem_sub_nnf_self},
{simp, right, apply mem_sub_nnf_dia, exact h}
end

@[simp] def nnf.closure : list nnf → list nnf
| [] := []
| (hd::tl) := sub_nnf hd ++ nnf.closure tl

theorem mem_closure_self : Π Γ : list nnf, Γ ⊆ nnf.closure Γ
| [] := λ x h, absurd h $ list.not_mem_nil _
| (hd::tl) :=
begin
  intros x hx, cases hx,
  {rw hx, simp, left, apply mem_sub_nnf_self},
  {simp, right, apply mem_closure_self, exact hx}
end

theorem mem_closure_and {φ ψ : nnf} : Π Γ : list nnf, and φ ψ ∈ nnf.closure Γ → φ ∈ nnf.closure Γ ∧ ψ ∈ nnf.closure Γ
| [] h := absurd h $ list.not_mem_nil _
| (hd::tl) h :=
begin
simp at h,
cases h,
{split,
 {simp, left, apply (mem_sub_nnf_and hd _).1, swap, exact h},
 {simp, left, apply (mem_sub_nnf_and hd _).2, swap, exact h}},
{split,
 {simp, right, apply (mem_closure_and _ _).1, exact h},
 {simp, right, apply (mem_closure_and _ _).2, exact h} }
end

theorem mem_closure_or {φ ψ : nnf} : Π Γ : list nnf, or φ ψ ∈ nnf.closure Γ → φ ∈ nnf.closure Γ ∧ ψ ∈ nnf.closure Γ
| [] h := absurd h $ list.not_mem_nil _
| (hd::tl) h :=
begin
simp at h,
cases h,
{split,
 {simp, left, apply (mem_sub_nnf_or hd _).1, swap, exact h},
 {simp, left, apply (mem_sub_nnf_or hd _).2, swap, exact h}},
{split,
 {simp, right, apply (mem_closure_or _ _).1, exact h},
 {simp, right, apply (mem_closure_or _ _).2, exact h} }
end

theorem mem_closure_box {φ : nnf} : Π Γ : list nnf, box φ ∈ nnf.closure Γ → φ ∈ nnf.closure Γ
| [] h := absurd h $ list.not_mem_nil _
| (hd::tl) h :=
begin
simp at h,
cases h,
{simp, left, apply mem_sub_nnf_box _ h},
{simp, right, apply mem_closure_box _ h}
end

theorem mem_closure_dia {φ : nnf} : Π Γ : list nnf, dia φ ∈ nnf.closure Γ → φ ∈ nnf.closure Γ
| [] h := absurd h $ list.not_mem_nil _
| (hd::tl) h :=
begin
simp at h,
cases h,
{simp, left, apply mem_sub_nnf_dia _ h},
{simp, right, apply mem_closure_dia _ h}
end

@[simp] def filter_undia (l : list nnf) : list nnf → list nnf
| [] := []
| (dia φ::tl) := if φ ∈ l then filter_undia tl else φ :: filter_undia tl
| (e::tl) := filter_undia tl

theorem mem_filter_undia_left : Π l Γ φ (h₁ : dia φ ∈ Γ) (h₂ : φ ∉ l),
φ ∈ filter_undia l Γ
| l [] φ h₁ h₂ := absurd h₁ $ list.not_mem_nil _
| l (hd :: tl) φ h₁ h₂ :=
begin
  cases h : hd,
  case nnf.dia : ψ
  {rw h at h₁, simp,
   by_cases hc : ψ ∈ l,
   {rw if_pos, apply mem_filter_undia_left, cases h₁, {injection h₁ with h₁', rw ←h₁' at hc, contradiction}, {exact h₁}, repeat {assumption}},
   {rw if_neg, cases h₁, {injection h₁ with h₁', rw h₁', simp}, {right, apply mem_filter_undia_left, exact h₁, exact h₂}, exact hc}},
  all_goals
  {simp, rw h at h₁, cases h₁, contradiction, apply mem_filter_undia_left, repeat {assumption}}
end

theorem mem_filter_dia_right_aux : Π l Γ φ, φ ∈ filter_undia l Γ → dia φ ∈ Γ
| l [] φ h := absurd h $ list.not_mem_nil _
| l (hd :: tl) φ h :=
begin
cases h₁ : hd,
case nnf.dia : ψ
{rw h₁ at h, dsimp at h,
 by_cases hc : ψ ∈ l,
 {rw if_pos at h, have := mem_filter_dia_right_aux l tl φ h, right, exact this, exact hc},
 {rw if_neg at h, cases h, {rw h, simp}, {have := mem_filter_dia_right_aux l tl φ h, right, exact this}, exact hc}},
all_goals
{rw h₁ at h, simp at h, right, apply mem_filter_dia_right_aux, exact h}
end

theorem mem_filter_dia_right : Π l Γ φ (h₂ : φ ∈ filter_undia l Γ), φ ∉ l
| l [] φ h := absurd h $ list.not_mem_nil _
| l (hd :: tl) φ h :=
begin
cases h₁ : hd,
case nnf.dia : ψ
{rw h₁ at h, dsimp at h,
 by_cases hc : ψ ∈ l,
 {rw if_pos at h, have := mem_filter_dia_right l tl φ h, exact this, exact hc},
 {rw if_neg at h, cases h, {rw h, exact hc}, {have := mem_filter_dia_right l tl φ h, exact this}, exact hc}},
all_goals
{rw h₁ at h, simp at h, apply mem_filter_dia_right, exact h}
end

structure hintikka (Γ : list nnf) : Prop :=
(hno_contra : ∀ {n}, var n ∈ Γ → neg n ∉ Γ)
(hand_left : ∀ {φ ψ}, nnf.and φ ψ ∈ Γ → φ ∈ Γ)
(hand_right : ∀ {φ ψ}, nnf.and φ ψ ∈ Γ → ψ ∈ Γ)
(hor : ∀ {φ ψ}, nnf.or φ ψ ∈ Γ → φ ∈ Γ ∨ ψ ∈ Γ)
(hbox : ∀ {φ}, nnf.box φ ∈ Γ → φ ∈ Γ)


import
  computability.primrec
  computability.partrec
  computability.partrec_code
  computability.halting
  data.pfun
  deduction semantics lindenbaum arithmetic
  proof
  coding

open encodable denumerable part classical_logic axiomatic_classical_logic axiomatic_classical_logic'

open vector

namespace fopl

namespace arithmetic

namespace LC

inductive pcode : ℕ → Type
| zero : pcode 0
| succ : pcode 1
| nth {n} (i : fin n) : pcode n
| comp {m n} : pcode n → (fin n → pcode m) → pcode m
| prec {n} : pcode n → pcode (n + 2) → pcode (n + 1)

namespace pcode

--lemma finitary_vec_head {α : Type*} {n} (v :vector α n)

def eval : ∀ {n}, pcode n → vector ℕ n → ℕ
| _ zero            := λ _, 0
| _ succ            := λ v, nat.succ v.head
| _ (nth i)         := λ v, v.nth i
| _ (comp cf cg)    := λ a, eval cf (of_fn (λ i, eval (cg i) a))
| _ (@prec n cf cg) := λ v : vector ℕ (n+1),
    v.head.elim (eval cf v.tail) (λ y IH, eval cg (y ::ᵥ IH ::ᵥ v.tail))

theorem exists_pcode {n : ℕ} {f : vector ℕ n → ℕ} :
  nat.primrec' f ↔ ∃ c : pcode n, eval c = f := ⟨λ h,
begin
  induction h,
  case zero { exact ⟨zero, rfl⟩ },
  case succ { exact ⟨succ, rfl⟩ },
  case nth  : n i { exact ⟨nth i, rfl⟩ },
  case comp : ar_gs ar_f f gs pf pgs IH_f IH_gs {
    rcases IH_f with ⟨cf, rfl⟩,
    rcases classical.skolem.mp IH_gs with ⟨cgs, cgs_eqn⟩,
    refine ⟨comp cf cgs, _⟩, simp[eval, cgs_eqn] },
  case prec : n f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨prec cf cg, rfl⟩ }
end, λ h,
begin
  rcases h with ⟨c, rfl⟩, induction c,
  case pcode.zero { exact nat.primrec'.zero },
  case pcode.succ { exact nat.primrec'.succ },
  case pcode.nth : n i { exact nat.primrec'.nth _ },
  case pcode.comp : _ _ cf cgs pf pgs { refine nat.primrec'.comp _ pf pgs },
  case pcode.prec : _ cf cg pf pg { exact nat.primrec'.prec pf pg },
end⟩

def eval_fin {n} (c : pcode n) (f : finitary ℕ n) : ℕ := eval c (of_fn f)

@[simp] lemma eval_fin_zero : eval_fin pcode.zero = (λ _, 0) := rfl

@[simp] lemma eval_fin_succ : eval_fin pcode.succ = (λ n, n 0 + 1) := rfl

@[simp] lemma eval_fin_nth {n} (i : fin n) : eval_fin (pcode.nth i) = (λ f, f i) :=
by funext f; simp[eval_fin, eval]

@[simp] lemma eval_fin_comp {n m} (cf : pcode n) (cF : finitary (pcode m) n) :
  eval_fin (pcode.comp cf cF) = (λ f, eval_fin cf (λ i, eval_fin (cF i) f)) :=
by funext f; simp[eval_fin, eval]

@[simp] lemma eval_fin_prec {n} (cf : pcode n) (cg : pcode (n + 2)) :
  eval_fin (pcode.prec cf cg) =
  (λ f, (f 0).elim (eval_fin cf f.tail) (λ y IH, eval_fin cg (y ::ᶠ IH ::ᶠ f.tail))) :=
by {funext f; simp[eval_fin, eval], congr }

end pcode

inductive langp : ℕ → Type

end LC

def LC : language := ⟨LC.pcode, LC.langp⟩

local infix ` ≃₁ `:50 := ((≃) : term (LA + LC) → term (LA + LC) → formula (LA + LC))
local prefix `∏₁ `:64 := (has_univ_quantifier.univ : formula (LA + LC) → formula (LA + LC))
local prefix `∐₁ `:64 := (has_exists_quantifier.ex : formula (LA + LC) → formula (LA + LC))

namespace prim
open LC vector

 def symbol.fn₁ {n} (c : pcode n) : finitary (term (LA + LC)) n → term (LA + LC) :=
λ x, term.app (sum.inr (c)) x

prefix `Ḟ `:max := symbol.fn₁

@[simp] lemma fn_rew {n} (c : pcode n) (v : finitary (term (LA + LC)) n) (s : ℕ → term (LA + LC)) :
  term.rew s (Ḟ c v) = Ḟ c (λ i, term.rew s (v i)) :=
by simp[symbol.fn₁]

inductive Prim : theory (LA + LC)
| zero                : Prim (Ḟ pcode.zero ∅ ≃ 0)
| succ                : Prim ∏₁ (Ḟ pcode.succ ‹#0› ≃₁ Succ #0)
| nth {n} (i : fin n) : Prim ∏[n] (Ḟ (pcode.nth i) (λ j, #j) ≃ #i)
| comp {m n}          : ∀ (c : pcode n) (cs : fin n → pcode m),
    Prim ∏[m] (Ḟ (pcode.comp c cs) (λ j, #j) ≃ Ḟ c (λ i, Ḟ (cs i) (λ j, #j)))
| prec_z {n}          : ∀ (c₀ : pcode n) (c₁ : pcode (n + 2)),
    Prim ∏[n] (Ḟ (pcode.prec c₀ c₁) (0 ::ᶠ (λ j, #j)) ≃ Ḟ c₀ (λ j, #j))
| prec_s {n}          : ∀ (c₀ : pcode n) (c₁ : pcode (n + 2)),
    Prim ∏[n+1] (Ḟ (pcode.prec c₀ c₁) (Succ #0 ::ᶠ (λ i, #(i + 1))) ≃
      Ḟ c₁ (#0 ::ᶠ Ḟ (pcode.prec c₀ c₁) (λ j, #j) ::ᶠ (λ j, #(j+1))))

theorem Prim_complete {i} (c : pcode i) :
  ∀ n : finitary ℕ i, Prim ⊢ Ḟ c (λ i, (n i)˙) ≃ (c.eval_fin n)˙ := λ v,
begin
  induction c generalizing v,
  case zero { simp[pcode.eval],
    simp[show (λ (i : fin 0), (v i)˙) = (∅ : finitary (term (LA + LC)) 0), by simp],
    refine by_axiom Prim.zero },
  case succ {
    simp[pcode.eval],
    have : Prim ⊢ formula.rew ı[0 ⇝ (v 0)˙] (Ḟ pcode.succ ‹#0› ≃ Succ #0),
      from (by_axiom Prim.succ) ⊚ (v 0)˙, simp at this,
    simp[show ∀ i, v i = v 0, by intros i; { simp[show i = 0, by simp] }], exact this },
  case nth : m i { simp[pcode.eval],
    have := provable.nfal_subst'_finitary (by_axiom (Prim.nth i)) (λ i, (v i)˙),
     simp at this, exact this },
  case comp : m n cf cF IHf IHF {
    simp at*,
    calc Ḟ (cf.comp cF) (λ i, (v i)˙) ≃[Prim] Ḟ cf (λ i, Ḟ (cF i) (λ i, (v i)˙))
    : by { have := provable.nfal_subst'_finitary (by_axiom (Prim.comp cf cF)) (λ i, (v i)˙), simp at this, exact this }
                                  ... ≃[Prim] Ḟ cf (λ i, ((cF i).eval_fin v)˙)
    : (provable.function_ext' _ _ _) ⨀ (provable.conjunction' (λ i, IHF i v))
                                  ... ≃[Prim] (cf.eval_fin (λ i, (cF i).eval_fin v))˙
    : IHf _ },
  case prec : n cf cg IHf IHg {
    simp at*,
    induction C : (v 0) with s IH generalizing v; simp[C],
    { have := provable.nfal_subst'_finitary (by_axiom (Prim.prec_z cf cg))  (λ i, numeral (v.tail i)),
      simp at this,
      calc
        Ḟ (cf.prec cg) (λ i, (v i)˙) ≃[Prim] Ḟ cf (λ i, (v.tail i)˙)
      : by { refine cast _ this, congr, { funext i, rcases i with ⟨i, h⟩, cases i; simp[C, finitary.tail, numeral], } }

                                 ... ≃[Prim] (cf.eval_fin v.tail)˙
      : IHf v.tail },
    { let I : ℕ := nat.elim (cf.eval_fin v.tail) (λ (y IH : ℕ), cg.eval_fin (y ::ᶠ IH ::ᶠ v.tail)) s,
      have IH' : Prim ⊢ Ḟ (cf.prec cg) (s˙ ::ᶠ λ i, (v.tail i)˙) ≃ I˙,
      { have := IH (s ::ᶠ v.tail) (by simp), simp at this, exact this },

      calc          Ḟ (cf.prec cg) (λ i, (v i)˙)
                  = Ḟ (cf.prec cg) (Succ s˙ ::ᶠ λ i, (v.tail i)˙)
      : by { congr, rw [←finitary.app_0_cons_tail_refl (λ i, (v i)˙)], simp[C, finitary.tail, numeral] }

        ... ≃[Prim] Ḟ cg (s˙ ::ᶠ Ḟ (cf.prec cg) (s˙ ::ᶠ λ i, (v.tail i)˙) ::ᶠ λ i, (v.tail i)˙)
      : by { have := provable.nfal_subst'_finitary (by_axiom (Prim.prec_s cf cg))
             (s˙ ::ᶠ (λ i, (v.tail i)˙)), simp at this, exact this }

        ... ≃[Prim] Ḟ cg (s˙ ::ᶠ I˙ ::ᶠ λ i, (v.tail i)˙)
      : by { refine (provable.function_ext' _ _ _) ⨀ (provable.conjunction' _), intros i,
             rcases i with ⟨i, lt_i⟩, cases i with i; cases i with i; simp, exact IH' }

        ... ≃[Prim] (cg.eval_fin (s ::ᶠ I ::ᶠ v.tail))˙
      : by { refine cast _ (IHg (s ::ᶠ I ::ᶠ v.tail)), congr, funext i, rcases i with ⟨i, h⟩,
             cases i with i; cases i with i; simp } } }
end

@[simp] def prim_fn : ∀ {n}, (LA + LC).fn n → finitary ℕ n → ℕ
| _ (sum.inl langf.zero) v := 0
| _ (sum.inl langf.succ) v := v 0 + 1
| _ (sum.inl langf.add)  v := v 0 + v 1
| _ (sum.inl langf.mul)  v := v 0 * v 1
| _ (sum.inr c)          v := pcode.eval_fin c v

def prim_standard : model (LA + LC) := {
  dom := ℕ,
  inhabited := nat.inhabited,
  fn := @prim_fn,
  pr := λ n l v,
    match n, l, v with
    | 2, (sum.inl langp.le), v := v 0 ≤ v 1
    end }

notation `ℙ` := prim_standard

namespace prim_standard

@[simp] lemma dom_eq : |ℙ| = ℕ := rfl

@[simp] lemma zero_eq (v : finitary ℕ 0) : prim_standard.fn has_zero_symbol.zero v = (0 : ℕ) := rfl

@[simp] lemma succ_eq (v : finitary ℕ 1) : prim_standard.fn has_succ_symbol.succ v = (v 0 + 1 : ℕ) := rfl

@[simp] lemma add_eq (v : finitary ℕ 2) : prim_standard.fn has_add_symbol.add v = (v 0 + v 1 : ℕ) := rfl

@[simp] lemma mul_eq (v : finitary ℕ 2) : prim_standard.fn has_mul_symbol.mul v = (v 0 * v 1 : ℕ) := rfl

@[simp] lemma le_eq (v : finitary ℕ 2) : prim_standard.pr has_le_symbol.le v ↔ (v 0 : ℕ) ≤ v 1 := by refl

lemma prim_standard.fn_eq : prim_standard.fn = @prim_fn := rfl

@[simp] lemma fun_eq {n} (c : pcode n) (v : finitary ℕ n) :
  prim_standard.fn (sum.inr c) v = pcode.eval_fin c v := by { cases c; simp[*, prim_standard.fn_eq] }

theorem models_Prim : ℙ ⊧ₜₕ Prim := λ p h e,
by {cases h; simp[symbol.fn₁, models_univs],
     { intros, congr; simp[finitary.tail] } }

@[simp] lemma numeral_eval (n : ℕ) (e : ℕ → |ℙ|) : term.val e (n˙) = n :=
by { induction n with n IH; simp[numeral, *] }

end prim_standard

theorem Prim_consistent : theory.consistent Prim := model_consistent prim_standard.models_Prim

variables {L : language.{0}} [primcodable (formula L)] [primcodable (proof L)]

@[reducible] def goedel_number (p : formula L) : ℕ := encode p

notation `⌜` p `⌝` := goedel_number p

variables {P : theory (LA + LC)} [extend Prim P] [theory_of_model ℙ P]
  {T : theory L} [primrec_theory T]

variables (T)

lemma proof_of_n_index : ∃ c : pcode 2, c.eval_fin = (λ v : finitary ℕ 2, proof.of_n T (v 0) (v 1)) :=
begin
  let pr : vector ℕ 2 → ℕ := λ v, proof.of_n T (v.nth 0) (v.nth 1),
  have : primrec pr,
    from primrec_theory.prim.comp (primrec.vector_nth.comp primrec.id (primrec.const 0))
      (primrec.vector_nth.comp primrec.id (primrec.const 1)),
  rcases pcode.exists_pcode.mp (nat.primrec'.of_prim this) with ⟨c, c_eval_eq_pr⟩,
  refine ⟨c, _⟩, ext v, simp[pcode.eval_fin, c_eval_eq_pr, pr], refl
end

noncomputable def is_proof_index : pcode 2 := classical.some (proof_of_n_index T)

lemma is_proof_index_spec : (is_proof_index T).eval_fin = (λ v : finitary ℕ 2, proof.of_n T (v 0) (v 1)) :=
classical.some_spec (proof_of_n_index T)

variables {T}

theorem Prim_complete_provability (p) :
  T ⊢ p ↔ P ⊢ ∐ (Ḟ (is_proof_index T) ‹⌜p⌝˙, #0› ≃₁ 2˙) :=
begin
  have pr_iff : T ⊢ p ↔ ∃ s, proof.of_n T ⌜p⌝ s = 2,
  { simp [proof.of_n_complete] },
  split,
  { intros h,
    suffices : Prim ⊢ ∐ (Ḟ (is_proof_index T) ‹⌜p⌝˙, #0› ≃ 2˙), { exact provable.extend this },
    rcases pr_iff.mp h with ⟨s, pr_eq⟩,
    have : Prim ⊢ Ḟ (is_proof_index T) ‹⌜p⌝˙, s˙› ≃ 2˙,
    { have := Prim_complete (is_proof_index T) ‹⌜p⌝, s›,
      simp[is_proof_index_spec, pr_eq] at this,
      exact cast (by { congr,  refine finitary.fin_1_ext (by refl) }) this },
    refine provable.use (s˙) _, simp,
    refine cast (by { congr; ext; simp }) this },
  { intros h,
    have : ℙ ⊧ ∐ (Ḟ (is_proof_index T) ‹⌜p⌝˙, #0› ≃ 2˙), from soundness h theory_of_model.models,
    have : ∃ s : ℕ, (is_proof_index T).eval_fin ‹⌜p⌝, s› = 2,
    { have := this (default _),
      simp[symbol.fn₁, show 1 + 1 = 2, by simp] at this,
      refine cast _ this, congr },
    rcases this with ⟨s, hs⟩,
    refine pr_iff.mpr ⟨s, _⟩, simp[is_proof_index_spec] at hs ⊢, exact hs }
end

variables (T)

noncomputable def Prov (t : term (LA + LC)) : formula (LA + LC) := ∐ (Ḟ (is_proof_index T) ‹t, #0› ≃₁ 2˙)

variables {T}

lemma Prov_spec (p : formula L) :
  T ⊢ p ↔ P ⊢ Prov T (⌜p⌝˙) :=
Prim_complete_provability p

lemma provable_K (p q : formula L) : P ⊢ Prov T (⌜p ⟶ q⌝˙) ⟶ Prov T (⌜p⌝˙) ⟶ Prov T (⌜q⌝˙) :=
begin
  simp[Prov],

end

end prim

namespace prim_incompleteness
variables {L : language.{0}} [primcodable (formula L)] [primcodable (proof L)]

def Γ (p : formula L) (t : term L) : formula L := p.rew ı[0 ⇝ t]

end prim_incompleteness

end arithmetic

end fopl


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.card
import Mathlib.data.polynomial.ring_division
import Mathlib.group_theory.order_of_element
import Mathlib.algebra.geom_sum
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Integral domains

Assorted theorems about integral domains.

## Main theorems

* `is_cyclic_of_subgroup_integral_domain` : A finite subgroup of the units of an integral domain
                                            is cyclic.
* `field_of_integral_domain`              : A finite integral domain is a field.

## Tags

integral domain, finite integral domain, finite field
-/

theorem card_nth_roots_subgroup_units {R : Type u_1} {G : Type u_2} [integral_domain R] [group G]
    [fintype G] (f : G →* R) (hf : function.injective ⇑f) {n : ℕ} (hn : 0 < n) (g₀ : G) :
    finset.card (has_sep.sep (fun (g : G) => g ^ n = g₀) finset.univ) ≤
        coe_fn multiset.card (polynomial.nth_roots n (coe_fn f g₀)) :=
  sorry

/-- A finite subgroup of the unit group of an integral domain is cyclic. -/
theorem is_cyclic_of_subgroup_integral_domain {R : Type u_1} {G : Type u_2} [integral_domain R]
    [group G] [fintype G] (f : G →* R) (hf : function.injective ⇑f) : is_cyclic G :=
  sorry

/-- The unit group of a finite integral domain is cyclic. -/
protected instance units.is_cyclic {R : Type u_1} [integral_domain R] [fintype R] :
    is_cyclic (units R) :=
  is_cyclic_of_subgroup_integral_domain (units.coe_hom R) units.ext

/-- Every finite integral domain is a field. -/
def field_of_integral_domain {R : Type u_1} [integral_domain R] [DecidableEq R] [fintype R] :
    field R :=
  field.mk integral_domain.add sorry integral_domain.zero sorry sorry integral_domain.neg
    integral_domain.sub sorry sorry integral_domain.mul sorry integral_domain.one sorry sorry sorry
    sorry sorry
    (fun (a : R) => dite (a = 0) (fun (h : a = 0) => 0) fun (h : ¬a = 0) => fintype.bij_inv sorry 1)
    sorry sorry sorry

/-- A finite subgroup of the units of an integral domain is cyclic. -/
protected instance subgroup_units_cyclic {R : Type u_1} [integral_domain R] (S : set (units R))
    [is_subgroup S] [fintype ↥S] : is_cyclic ↥S :=
  sorry

theorem card_fiber_eq_of_mem_range {G : Type u_2} [group G] [fintype G] {H : Type u_1} [group H]
    [DecidableEq H] (f : G →* H) {x : H} {y : H} (hx : x ∈ set.range ⇑f) (hy : y ∈ set.range ⇑f) :
    finset.card (finset.filter (fun (g : G) => coe_fn f g = x) finset.univ) =
        finset.card (finset.filter (fun (g : G) => coe_fn f g = y) finset.univ) :=
  sorry

/-- In an integral domain, a sum indexed by a nontrivial homomorphism from a finite group is zero. -/
theorem sum_hom_units_eq_zero {R : Type u_1} {G : Type u_2} [integral_domain R] [group G]
    [fintype G] (f : G →* R) (hf : f ≠ 1) :
    (finset.sum finset.univ fun (g : G) => coe_fn f g) = 0 :=
  sorry

/-- In an integral domain, a sum indexed by a homomorphism from a finite group is zero,
unless the homomorphism is trivial, in which case the sum is equal to the cardinality of the group. -/
theorem sum_hom_units {R : Type u_1} {G : Type u_2} [integral_domain R] [group G] [fintype G]
    (f : G →* R) [Decidable (f = 1)] :
    (finset.sum finset.univ fun (g : G) => coe_fn f g) = ite (f = 1) (↑(fintype.card G)) 0 :=
  sorry

end Mathlib