/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import control.functor.multivariate
import data.pfunctor.univariate.basic

/-!
# Multivariate polynomial functors.

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

universes u v
open_locale mvfunctor

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ) :=
(A : Type.{u}) (B : A → typevec.{u} n)

namespace mvpfunctor
open mvfunctor (liftp liftr)

variables {n m : ℕ} (P : mvpfunctor.{u} n)

/-- Applying `P` to an object of `Type` -/
def obj (α : typevec.{u} n) : Type u := Σ a : P.A, P.B a ⟹ α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : typevec n} (f : α ⟹ β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, typevec.comp f g⟩

instance : inhabited (mvpfunctor n) :=
⟨ ⟨default _, λ _, default _⟩ ⟩

instance obj.inhabited {α : typevec n} [inhabited P.A] [Π i, inhabited (α i)] :
  inhabited (P.obj α) :=
⟨ ⟨default _, λ _ _, default _⟩ ⟩

instance : mvfunctor P.obj :=
⟨@mvpfunctor.map n P⟩

theorem map_eq {α β : typevec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
  @mvfunctor.map _ P.obj _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
rfl

theorem id_map {α : typevec n} : ∀ x : P.obj α, typevec.id <$$> x = x
| ⟨a, g⟩ := rfl

theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) :
  ∀ x : P.obj α, (g ⊚ f) <$$> x = g <$$> (f <$$> x)
| ⟨a, h⟩ := rfl

instance : is_lawful_mvfunctor P.obj :=
{ id_map := @id_map _ P,
  comp_map := @comp_map _ P }

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n :=
{ A := A, B := λ a i, pempty }

section const
variables (n) {A : Type u}  {α β : typevec.{u} n}

/-- Constructor for the constant functor -/
def const.mk (x : A) {α} : (const n A).obj α :=
⟨ x, λ i a, pempty.elim a ⟩

variables {n A}

/-- Destructor for the constant functor -/
def const.get (x : (const n A).obj α) : A :=
x.1

@[simp]
lemma const.get_map (f : α ⟹ β) (x : (const n A).obj α) :
  const.get (f <$$> x) = const.get x :=
by { cases x, refl }

@[simp]
lemma const.get_mk (x : A) : const.get (const.mk n x : (const n A).obj α) = x :=
by refl

@[simp]
lemma const.mk_get (x : (const n A).obj α) : const.mk n (const.get x) = x :=
by { cases x, dsimp [const.get,const.mk], congr' with _ ⟨ ⟩ }

end const

/-- Functor composition on polynomial functors -/
def comp (P : mvpfunctor.{u} n) (Q : fin2 n → mvpfunctor.{u} m) : mvpfunctor m :=
{ A := Σ a₂ : P.1, Π i, P.2 a₂ i → (Q i).1,
  B := λ a, λ i, Σ j (b : P.2 a.1 j), (Q j).2 (a.snd j b) i }

variables {P} {Q : fin2 n → mvpfunctor.{u} m} {α β : typevec.{u} m}

/-- Constructor for functor composition -/
def comp.mk (x : P.obj (λ i, (Q i).obj α)) : (comp P Q).obj α :=
⟨ ⟨ x.1, λ i a, (x.2 _ a).1  ⟩, λ i a, (x.snd a.fst (a.snd).fst).snd i (a.snd).snd ⟩

/-- Destructor for functor composition -/
def comp.get (x : (comp P Q).obj α) : P.obj (λ i, (Q i).obj α) :=
⟨ x.1.1, λ i a, ⟨x.fst.snd i a, λ (j : fin2 m) (b : (Q i).B _ j), x.snd j ⟨i, ⟨a, b⟩⟩⟩ ⟩

lemma comp.get_map (f : α ⟹ β) (x : (comp P Q).obj α) :
  comp.get (f <$$> x) = (λ i (x : (Q i).obj α), f <$$> x) <$$> comp.get x :=
by { cases x, refl }

@[simp]
lemma comp.get_mk (x : P.obj (λ i, (Q i).obj α)) : comp.get (comp.mk x) = x :=
begin
  cases x,
  simp! [comp.get,comp.mk],
end

@[simp]
lemma comp.mk_get (x : (comp P Q).obj α) : comp.mk (comp.get x) = x :=
begin
  cases x,
  dsimp [comp.get,comp.mk],
  ext : 2; intros, refl, refl,
  congr, ext1; intros; refl,
  ext : 2, congr, rcases x_1 with ⟨a,b,c⟩; refl
end

/-
lifting predicates and relations
-/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i j, (f i j).val, _, λ i j, (f i j).property⟩,
    rw [←hy, h, map_eq], refl },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i j, ⟨f i j, pf i j⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (a : P.A) (f : P.B a ⟹ α) :
  @liftp.{u} _ P.obj _ α p ⟨a,f⟩ ↔ ∀ i x, p (f i x) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set mvfunctor

theorem supp_eq {α : typevec n} (a : P.A) (f : P.B a ⟹ α) (i) :
  @supp.{u} _ P.obj _ α  (⟨a,f⟩ : P.obj α) i = f i '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ i x, ∃ (y : P.B a i), f i y = x),
    rw liftp_iff', intros, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor
open typevec
variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop : mvpfunctor n :=
{ A := P.A, B := λ a, (P.B a).drop }

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last : pfunctor :=
{ A := P.A, B := λ a, (P.B a).last }

/-- append arrows of a polynomial functor application -/
@[reducible] def append_contents {α : typevec n} {β : Type*}
    {a : P.A} (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.B a ⟹ α ::: β :=
split_fun f' f

end mvpfunctor


/-|
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad, Haitao Zhang
|-/
-- a port of core Lean `init/function.lean`

/-!
# General operations on functions
-/

namespace Function

variable {α : Sort u₁} {β : Sort u₂} {φ : Sort u₃} {δ : Sort u₄} {ζ : Sort u₁}

@[reducible] def comp_right (f : β → β → β) (g : α → β) : β → α → β :=
λ b a => f b (g a)

@[reducible] def comp_left (f : β → β → β) (g : α → β) : α → β → β :=
λ a b => f (g a) b

/-- Given functions `f : β → β → φ` and `g : α → β`, produce a function `α → α → φ` that evaluates
`g` on each argument, then applies `f` to the results. Can be used, e.g., to transfer a relation
from `β` to `α`. -/
@[reducible] def on_fun (f : β → β → φ) (g : α → β) : α → α → φ :=
λ x y => f (g x) (g y)

@[reducible] def combine (f : α → β → φ) (op : φ → δ → ζ) (g : α → β → δ)
  : α → β → ζ :=
λ x y => op (f x y) (g x y)

@[reducible] def swap {φ : α → β → Sort u₃} (f : ∀ x y, φ x y) : ∀ y x, φ x y :=
λ y x => f x y

@[reducible] def app {β : α → Sort u₂} (f : ∀ x, β x) (x : α) : β x :=
f x

theorem left_id (f : α → β) : id ∘ f = f := rfl

theorem right_id (f : α → β) : f ∘ id = f := rfl

@[simp] theorem comp_app (f : β → φ) (g : α → β) (a : α) : (f ∘ g) a = f (g a) := rfl

theorem comp.assoc (f : φ → δ) (g : β → φ) (h : α → β) : (f ∘ g) ∘ h = f ∘ (g ∘ h) := rfl

@[simp] theorem comp.left_id (f : α → β) : id ∘ f = f := rfl

@[simp] theorem comp.right_id (f : α → β) : f ∘ id = f := rfl

theorem comp_const_right (f : β → φ) (b : β) : f ∘ (const α b) = const α (f b) := rfl

/-- A function `f : α → β` is called injective if `f x = f y` implies `x = y`. -/
@[reducible] def injective (f : α → β) : Prop := ∀ {a₁ a₂}, f a₁ = f a₂ → a₁ = a₂

theorem injective.comp {g : β → φ} {f : α → β} (hg : injective g) (hf : injective f) :
  injective (g ∘ f) :=
λ h => hf (hg h)

/-- A function `f : α → β` is calles surjective if every `b : β` is equal to `f a`
for some `a : α`. -/
@[reducible] def surjective (f : α → β) : Prop := ∀ b, ∃ a, f a = b

theorem surjective.comp {g : β → φ} {f : α → β} (hg : surjective g) (hf : surjective f) :
  surjective (g ∘ f) :=
λ (c : φ) => Exists.elim (hg c) (λ b hb => Exists.elim (hf b) (λ a ha =>
  Exists.intro a (show g (f a) = c from (Eq.trans (congrArg g ha) hb))))

/-- A function is called bijective if it is both injective and surjective. -/
def bijective (f : α → β) := injective f ∧ surjective f

theorem bijective.comp {g : β → φ} {f : α → β} : bijective g → bijective f → bijective (g ∘ f)
| ⟨h_ginj, h_gsurj⟩, ⟨h_finj, h_fsurj⟩ => ⟨h_ginj.comp h_finj, h_gsurj.comp h_fsurj⟩

/-- `left_inverse g f` means that g is a left inverse to f. That is, `g ∘ f = id`. -/
def left_inverse (g : β → α) (f : α → β) : Prop := ∀ x, g (f x) = x

/-- `has_left_inverse f` means that `f` has an unspecified left inverse. -/
def has_left_inverse (f : α → β) : Prop := ∃ finv : β → α, left_inverse finv f

/-- `right_inverse g f` means that g is a right inverse to f. That is, `f ∘ g = id`. -/
def right_inverse (g : β → α) (f : α → β) : Prop := left_inverse f g

/-- `has_right_inverse f` means that `f` has an unspecified right inverse. -/
def has_right_inverse (f : α → β) : Prop := ∃ finv : β → α, right_inverse finv f

theorem left_inverse.injective {g : β → α} {f : α → β} : left_inverse g f → injective f :=
λ h a b hf => h a ▸ h b ▸ hf ▸ rfl

theorem has_left_inverse.injective {f : α → β} : has_left_inverse f → injective f :=
λ h => Exists.elim h (λ finv inv => inv.injective)

theorem right_inverse_of_injective_of_left_inverse {f : α → β} {g : β → α}
    (injf : injective f) (lfg : left_inverse f g) :
  right_inverse f g :=
λ x => injf $ lfg $ f x

theorem right_inverse.surjective {f : α → β} {g : β → α} (h : right_inverse g f) : surjective f :=
λ y => ⟨g y, h y⟩

theorem has_right_inverse.surjective {f : α → β} : has_right_inverse f → surjective f
| ⟨finv, inv⟩ => inv.surjective

theorem left_inverse_of_surjective_of_right_inverse {f : α → β} {g : β → α} (surjf : surjective f)
  (rfg : right_inverse f g) : left_inverse f g :=
λ y =>
  let ⟨x, hx⟩ := surjf y
  by rw [← hx, rfg]

theorem injective_id : injective (@id α) := id

theorem surjective_id : surjective (@id α) := λ a => ⟨a, rfl⟩

theorem bijective_id : bijective (@id α) := ⟨injective_id, surjective_id⟩

end Function

namespace Function

variable {α : Type u₁} {β : Type u₂} {φ : Type u₃}

/-- Interpret a function on `α × β` as a function with two arguments. -/
@[inline] def curry : (α × β → φ) → α → β → φ :=
λ f a b => f (a, b)

/-- Interpret a function with two arguments as a function on `α × β` -/
@[inline] def uncurry : (α → β → φ) → α × β → φ :=
λ f a => f a.1 a.2

@[simp] theorem curry_uncurry (f : α → β → φ) : curry (uncurry f) = f :=
rfl

@[simp] theorem uncurry_curry (f : α × β → φ) : uncurry (curry f) = f :=
funext (λ ⟨a, b⟩ => rfl)

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

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

end Function


import tactic -- imports all the Lean tactics
import topology.continuous_function.compact -- continuous functions, compact sets
import topology.constructions
import topology.continuous_on
import topology.category.Top.epi_mono
import topology.path_connected
import data.set.lattice
import data.nat.basic
import topology.subset_properties
import topology.bases
import data.set.basic
import topology.constructions
import topology.separation
import topology.basic
import topology.sequences

-- Winter 2022

variables (X Y : Type) [topological_space X] [topological_space Y]

-- let S be a subset of X
variable (S : set X)

-- Let `f : X → Y` be a function
variables (f : X → Y)

lemma singleton_fun {X: Type} {Y: Type} (f: X → Y) (x: X):
  f '' {x} = {f x}:=
begin
  ext y,
  split,
  intro hy,
  simp,
  rw set.mem_image_iff_bex at hy,
  cases hy with x1 hy,
  cases hy with h hy,
  simp at h,
  exact (eq.symm hy).trans (congr_arg f h),
  intro hy,
  simp at hy,
  rw set.mem_image_iff_bex,
  use x,
  split,
  simp,
  rw hy,
end

-- Thm: Let f: X → Y be a quotient map, if each set f⁻¹({y}) is connected and if Y is connected, then X is connected.
example (h1: quotient_map f) (h2: is_connected (set.univ: set Y)) (h3: ∀ y : Y, is_connected (f⁻¹' {y})):
  is_connected (set.univ: set X) :=
begin
  unfold is_connected at h2 ⊢ h3,
  split,
  {
    cases h2 with h2_nonempty h2,
    have y: Y,
    exact set.nonempty.some h2_nonempty,
    specialize h3 y,
    cases h3 with h3_nonempty h3,
    have h4: f⁻¹' {y} ⊆ (set.univ: set X),
    exact (f ⁻¹' {y}).subset_univ,
    exact set.nonempty.mono h4 h3_nonempty,

  },
  {
    unfold is_preconnected,
    intro u,
    intro v,
    intro openu,
    intro openv,
    intro hypo,
    intro nonemptyu,
    intro nonemptyv,
    by_contra,
    rw set.not_nonempty_iff_eq_empty at h,
    simp at nonemptyu nonemptyv h,
    cases h2 with nonemptyy h2,
    have splitX: u ∪ v = (set.univ: set X),
    exact set.univ_subset_iff.mp hypo,
    have preim_subset: ∀ y: Y, f⁻¹'{y} ⊆ u ∪ v,
    intro y,
    rw splitX,
    exact (f ⁻¹' {y}).subset_univ,
    have disj: disjoint u v,
    exact set.disjoint_iff_inter_eq_empty.mpr h,
    have h4: ∀ y: Y, f⁻¹' {y} ⊆ u ∨ f⁻¹' {y} ⊆ v,
    intro y,
    specialize preim_subset y,
    specialize h3 y,
    cases h3 with h3nonempty h3,
    exact is_preconnected.subset_or_subset openu openv disj preim_subset h3,

    -- build Yu an Yv
    let Yu := {y : Y | f⁻¹' {y} ⊆ u},
    let Yv := {y : Y | f⁻¹' {y} ⊆ v},
    have h5: (set.univ: set Y) ⊆ Yu ∪ Yv,
    intro y,
    intro y_elem,
    specialize h4 y,
    cases h4 with h4u h4v,
    left,
    simp,
    exact h4u,
    right,
    simp,
    exact h4v,
    have yuy: Yu ⊆ (set.univ: set Y),
    exact set.subset_univ Yu,
    have yvy: Yv ⊆ (set.univ: set Y),
    exact set.subset_univ Yv,
    have yuyvy: Yu ∪ Yv ⊆ (set.univ: set Y),
    exact (Yu ∪ Yv).subset_univ,
    have splitY: Yu ∪ Yv = (set.univ: set Y),
    ext,
    split,
    intro x1,
    triv,
    intro x1,
    exact h5 x1,
    have disjointyuyv: Yu ∩ Yv = ∅,
    ext,
    split,
    intro xy,
    simp at xy,
    cases xy with xyu xyv,
    have xyuv: f ⁻¹' {x} ⊆ u ∩ v,
    exact set.subset_inter xyu xyv,
    rw h at xyuv,
    have surf: function.surjective f,
    exact quotient_map.surjective h1,
    unfold function.surjective at surf,
    specialize surf x,
    cases surf with a surf,
    rw set.subset_empty_iff at xyuv,
    have fa: a ∈ f ⁻¹' {x},
    exact surf,

    rw xyuv at fa,
    exact fa,
    intro h6,
    exfalso,
    exact h6,

    -- f⁻¹ yu = u
    have hypo_yu: f ⁻¹' Yu = u,
    ext,

    have hx: {x} ⊆ f ⁻¹' (f '' {x}),
    exact set.subset_preimage_image f {x},
    have eqset: f '' {x} = {f x},
    exact singleton_fun f x,

    split,

    intro xyu,
    simp at xyu,

    rw eqset at hx,
    rw ← set.singleton_subset_iff,
    exact set.subset.trans hx xyu,
    intro xu,
    have hxu: f x ∈ Yu ∪ Yv,
    rw splitY,
    simp,
    have hyv: f x ∈ Yu,
    cases hxu,
    exact hxu,
    simp at hxu,
    rw ← eqset at hxu,
    have hx2: {x} ⊆ v,
    exact set.subset.trans hx hxu,
    simp at hx2,
    have huv: x ∈ u ∩ v,
    exact set.mem_inter xu hx2,
    rw h at huv,
    exfalso,
    exact huv,

    rw eqset at hx,
    rw set.singleton_subset_iff at hx,
    rw ← set.singleton_subset_iff at hyv,
    have fyu: f ⁻¹' {f x} ⊆ f ⁻¹' Yu,
    rw set.subset_def,
    intro x1,
    intro hx1,
    have hx1_1: f x1 ∈ {f x},
    exact set.mem_preimage.mp hx1,
    simp at hx1_1,
    rw ← hx1_1 at hyv,
    rw set.singleton_subset_iff at hyv,

    have hx1_2: f x1 ∈ f '' (f ⁻¹' Yu),
    have surf: function.surjective f,
    exact quotient_map.surjective h1,
    rw set.image_preimage_eq,
    exact hyv,
    exact surf,
    have hypox: f '' {x1} = {f x1},
    exact singleton_fun f x1,
    rw set.mem_preimage,
    exact hyv,
    exact fyu hx,

    -- f ⁻¹' Yv = v
    have hypo_yv: f ⁻¹' Yv = v,
    ext,

    have eqset: f '' {x} = {f x},
    exact singleton_fun f x,
    have hx1: {x} ⊆ f ⁻¹' (f '' {x}),
    exact set.subset_preimage_image f {x},
    rw set.singleton_subset_iff at hx1,
    split,
    intro xyv,
    have hx: x ∈ u ∪ v,
    rw splitX,
    simp,
    cases hx,
    rw ← hypo_yu at hx,
    simp at xyv hx,
    have xuv: f ⁻¹' {f x} ⊆ u ∩ v,
    exact set.subset_inter hx xyv,
    rw h at xuv,
    exfalso,
    rw ← eqset at xuv,

    have hx2: x ∈ ∅,
    exact xuv hx1,
    exact hx2,
    exact hx,

    intro xv,
    rw set.mem_preimage,
    have hfx: (f x) ∈ Yu ∪ Yv,
    rw splitY,
    simp,
    cases hfx,
    simp at hfx,
    rw ← eqset at hfx,
    have hx: x ∈ u,
    exact hfx hx1,
    have xuv: x ∈ u ∩ v,
    exact set.mem_inter (hfx hx1) xv,
    rw h at xuv,
    exfalso,
    exact xuv,
    exact hfx,

    -- Yu Yv open
    rw quotient_map_iff at h1,
    cases h1 with h1 hopen,
    have hopen2: ∀ (s : set Y), is_open s ↔ is_open (f ⁻¹' s),
    exact hopen,
    specialize hopen Yu,
    rw hypo_yu at hopen,
    rw ← hopen at openu,
    specialize hopen2 Yv,
    rw hypo_yv at hopen2,
    rw ← hopen2 at openv,

    -- nonempty yu yv
    have noneyu: Yu.nonempty,
    by_contra yuem,
    rw set.not_nonempty_iff_eq_empty at yuem,
    rw yuem at splitY,
    simp at splitY,
    rw yuem at hypo_yu,
    simp at hypo_yu,
    have h6: ¬u ⊆ ∅,
    exact set.nonempty.not_subset_empty nonemptyu,
    apply h6,
    exact (eq.symm hypo_yu).subset,

    have noneyv: Yv.nonempty,
    by_contra yvem,
    rw set.not_nonempty_iff_eq_empty at yvem,
    rw yvem at splitY,
    simp at splitY,
    rw yvem at hypo_yv,
    simp at hypo_yv,
    have h6: ¬v ⊆ ∅,
    exact set.nonempty.not_subset_empty nonemptyv,
    apply h6,
    exact (eq.symm hypo_yv).subset,

    unfold is_preconnected at h2,
    specialize h2 Yu Yv,
    specialize h2 openu,
    specialize h2 openv,
    specialize h2 h5,
    simp at h2,
    specialize h2 noneyu,
    specialize h2 noneyv,
    have h6: ¬ (Yu ∩ Yv ⊆ ∅),
    exact set.nonempty.not_subset_empty h2,
    apply h6,
    exact eq.subset disjointyuyv,
  },
end

-- If S is open set and intersects closure of U, S intersects U.
lemma closure_inter {X: Type} [topological_space X] (U: set X) (S: set X) (h1: (closure U ∩ S).nonempty) (h2: is_open S):
(U ∩ S).nonempty :=
begin
  rw set.nonempty_def at h1,
  cases h1 with x h1,
  cases h1 with hu hs,
  rw mem_closure_iff at hu,
  specialize hu S,
  specialize hu h2,
  specialize hu hs,
  rw set.nonempty_def at hu ⊢,
  cases hu with y hu,
  use y,
  cases hu with hu1 hu2,
  split,
  exact hu2,
  exact hu1,
end

-- Thm: If a set is connected, then its closure is connected
example (A: set X) (h1: is_connected A) : (is_connected (closure A)) :=
begin
  have sub: A ⊆ closure A,
  {
     exact subset_closure,
  },
  unfold is_connected at h1 ⊢,
  cases h1 with h1 h2,
  split,
  {
    exact set.nonempty.mono sub h1,
  },
  {
    unfold is_preconnected at h2 ⊢,
    intro u,
    intro v,
    intro openu,
    intro openv,
    intro contain,
    intro nonem_u,
    intro nonem_v,
    specialize h2 u,
    specialize h2 v,
    specialize h2 openu,
    specialize h2 openv,
    have h3: A ⊆ u ∪ v,
    {
      exact has_subset.subset.trans sub contain,
    },
    specialize h2 h3,
    have nonem_Au: (A ∩ u).nonempty,
    {
      exact closure_inter A u nonem_u openu,
    },
    have nonem_Av: (A ∩ v).nonempty,
    {
      exact closure_inter A v nonem_v openv,
    },
    specialize h2 nonem_Au,
    specialize h2 nonem_Av,
    rw set.nonempty_def at h2 ⊢,
    cases h2 with x h2,
    use x,
    cases h2 with h21 h22,
    split,
    apply sub,
    exact h21,
    exact h22,

  },
end

-- big theorem

def accu [metric_space X] (A: set X) := {x : X | ∀ ε > (0: ℝ), (((metric.ball x ε) ∩ A) \ {x}) ≠ ∅}

def accu_compl [metric_space X] (A: set X) := {x: X | ∃ ε > (0: ℝ), ((metric.ball x ε) ∩ A) ⊆ {x}}

def small_rad [metric_space X] (A: set X) (x: X) := {ε : ℝ | (ε >= 0) ∧ ((metric.ball x ε) ∩ A) ⊆ {x} ∧ (ε < 1)}

noncomputable theory
def one_rad [metric_space X] (A: set X): X → ℝ := λ x, (has_Sup.Sup (small_rad X A x)) / 2

def x_ball_rad [metric_space X] (A: set X): X → set X := λ x, metric.ball x (one_rad X A x)

lemma zero_in_rad {X: Type} [metric_space X] (A: set X) (x: X): (0: ℝ) ∈ (small_rad X A x) :=
begin
  unfold small_rad,
  simp,
  intro y,
  intro dist,
  intro h2,
  have h3: has_dist.dist y x ≥ 0,
  exact dist_nonneg,
  have h4: ¬has_dist.dist y x < 0,
  exact not_lt.mpr h3,
  exfalso,
  apply h4,
  exact dist,
end

-- small_rad X A x nonempty and bdd above
lemma has_sup_rad {X: Type} [metric_space X] (A: set X) (x: X):  (small_rad X A x).nonempty ∧ bdd_above (small_rad X A x):=
begin
  have h: (small_rad X A x).nonempty,
  have h1: (0: ℝ) ∈ (small_rad X A x),
  exact zero_in_rad A x,
  exact set.nonempty_of_mem h1,

  have h1: bdd_above (small_rad X A x),
  unfold bdd_above,
  have h2: (1: ℝ) ∈ upper_bounds (small_rad X A x),
  unfold small_rad,
  unfold upper_bounds,
  simp,
  intro a,
  intro ha,
  intro h3,
  intro h4,
  exact le_of_lt h4,
  exact set.nonempty_of_mem h2,

  exact ⟨h, h1⟩,

end

-- if b in small_rad X A x and 0 ≤ a < b, then a also in.
lemma set_contain_less_dist {X: Type} [metric_space X] (A: set X) (x: X) (a: ℝ) (b: ℝ) :
  (a ≥ 0 ∧ b ∈ small_rad X A x ∧ a < b) → a ∈ small_rad X A x :=
begin
  intro h,
  cases h with h1 h2,
  cases h2 with h2 h3,
  unfold small_rad at h2,
  simp at h2,
  cases h2 with h21 h22,
  cases h22 with h22 h23,
  unfold small_rad,
  simp,
  split,
  exact h1,
  split,
  intro y,

  specialize h22 y,
  intro h4,
  have h5: dist y x < b,
  linarith,
  specialize h22 h5,
  exact h22,
  linarith,

end

lemma larger_than_or_equal_split (a: ℝ) (b: ℝ): a ≥ b ↔ (a > b) ∨ (a = b) :=
begin

  have h3: a = b ↔ b = a,
  exact eq_comm,
  have h2: a > b ↔ b < a,
  exact iff.rfl,
  split,
  intro h,
  have h1: b ≤ a,
  exact h,

  rw h2,
  rw h3,
  exact lt_or_eq_of_le h,

  rw h2,
  rw h3,
  intro h,
  have claim: b ≤ a,
  exact le_of_lt_or_eq h,
  exact claim,
end

-- Sup (small_rad X A x) >= 0
lemma sup_small_rad_nonneg {X: Type} [metric_space X] (A: set X) (x: X): Sup (small_rad X A x) ≥ 0 :=
begin
  have h5: ∀ (a : ℝ), a ∈ (small_rad X A x) → 0 ≤ a,
  intro a,
  intro ha,
  unfold small_rad at ha,
  simp at ha,
  cases ha with ha ha1,
  exact ha,
  exact real.Sup_nonneg (small_rad X A x) h5,
end

-- one_rad X A x ≥ 0
lemma one_rad_nonneg {X: Type} [metric_space X] (A: set X) (x: X): one_rad X A x ≥ 0 :=
begin
  unfold one_rad,
  have h: Sup (small_rad X A x) ≥ 0,
  exact sup_small_rad_nonneg A x,
  linarith,
end

-- one_rad X A x ∈ small_rad X A x
lemma one_rad_in_small_rad {X: Type} [metric_space X] (A: set X) (x: X): one_rad X A x ∈ small_rad X A x :=
begin
  have h: (small_rad X A x).nonempty ∧ bdd_above (small_rad X A x),
  exact has_sup_rad A x,
  cases h with h1 h2,
  have claim: ∀ ε < 0, ∃ (a: ℝ) (H: a ∈ small_rad X A x), has_Sup.Sup (small_rad X A x) + ε < a,
  intro ε,
  intro ε0,
  exact real.add_neg_lt_Sup h1 ε0,
  have h4: Sup (small_rad X A x) ≥  0,
  exact sup_small_rad_nonneg A x,
  rw larger_than_or_equal_split (Sup (small_rad X A x)) 0 at h4,
  cases h4,
  have h3: -Sup (small_rad X A x) / 2 < 0,
  linarith,
  unfold one_rad,
  specialize claim (-Sup (small_rad X A x) / 2),
  specialize claim h3,
  cases claim with a claim,
  cases claim with H claim,
  have claim2: Sup (small_rad X A x) / 2 < a,
  linarith,
  have claim3: Sup (small_rad X A x) / 2 ≥ 0 ∧ a ∈ small_rad X A x ∧ Sup (small_rad X A x) / 2 < a,
  split,
  linarith,
  exact ⟨H, claim2⟩,
  exact set_contain_less_dist A x (Sup (small_rad X A x) / 2) a claim3,
  unfold one_rad,
  rw h4,
  simp,
  exact zero_in_rad A x,

end

-- If a positive number is in small_rad X A x, then one_rad X A x > 0
lemma positive_sup_positive {X: Type} [metric_space X] (A: set X) (x: X) (h: ∃ a : ℝ, a > 0 ∧ a ∈ small_rad X A x):
  one_rad X A x > 0 :=
begin
  cases h with a h,
  cases h with h1 h2,
  have claim: one_rad X A x ≥ 0,
  exact one_rad_nonneg A x,
  rw larger_than_or_equal_split at claim,
  cases claim,
  exact claim,
  unfold one_rad at claim,
  simp at claim,
  have h: (small_rad X A x).nonempty ∧ bdd_above (small_rad X A x),
  exact has_sup_rad A x,
  cases h with nonem bdd,
  have h3: ∀ (ε : ℝ), ε < 0 → (∃ (y : ℝ) (H : y ∈ (small_rad X A x)), a + ε < y),
  intro ε,
  intro neg,
  use a,
  split,
  exact h2,
  linarith,
  rw ← real.le_Sup_iff bdd nonem at h3,
  rw claim at h3,
  exfalso,
  have h4: a < a,
  exact gt_of_gt_of_ge h1 h3,
  simp at h4,
  exact h4,
end

-- if x ∈ accu_compl X A, then x ∈ (metric.ball x (one_rad X A x))
lemma accu_compl_x_in_small_rad {X: Type} [metric_space X] (A: set X) (x: X) (h: x ∈ accu_compl X A):
  x ∈ (metric.ball x (one_rad X A x)) :=
begin
  unfold accu_compl at h,
  simp at h,
  cases h with a h,
  cases h with pos h,
  have H: a < 1 ∨ a ≥ 1,
  exact lt_or_ge a 1,
  cases H,
  have h1: ∃ a : ℝ, a > 0 ∧ a ∈ small_rad X A x,
  use a,
  split,
  exact pos,
  unfold small_rad,
  simp,
  split,
  exact le_of_lt pos,
  split,
  exact h,
  exact H,
  simp,
  exact positive_sup_positive A x h1,

  have h1: (0.5: ℝ) ∈ small_rad X A x,
  unfold small_rad,
  simp,
  split,
  intro y,
  specialize h y,
  intro dist,
  have h2: (0.5: ℝ) < a,
  linarith,
  simp at h2,
  have h3: has_dist.dist y x < a,
  linarith,
  specialize h h3,
  exact h,
  have h4: (1 / 2 : ℝ) = (2⁻¹: ℝ),
  exact one_div 2,
  rw ← h4,
  exact one_half_lt_one,
  --unfold one_rad,
  simp,
  have h5: ∃ a : ℝ, a > 0 ∧ a ∈ small_rad X A x,
  use (1 / 2: ℝ),
  split,
  exact one_half_pos,
  exact h1,
  exact positive_sup_positive A x h5,

end

-- x ∈ accu_compl X A → x ∈ x_ball_rad X A x
lemma accu_compl_x_in_ball_rad {X: Type} [metric_space X] (A: set X) (x: X) (h: x ∈ accu_compl X A):
  x ∈ x_ball_rad X A x :=
begin
  unfold x_ball_rad,
  exact accu_compl_x_in_small_rad A x h,
end

-- if accu is empty, all elements are in accu_compl
lemma accu_empty_accu_compl {X: Type} [metric_space X] (A: set X) (h: accu X A = ∅): ∀ x: X, x ∈ accu_compl X A :=
begin
  intro x,
  have h1: x ∉ accu X A,
  exact set.eq_empty_iff_forall_not_mem.mp h x,
  unfold accu_compl,
  unfold accu at h1,
  simp,
  simp at h1,
  cases h1 with e h1,
  use e,
  cases h1 with h1 h2,

  split,
  exact h1,
  intro y,
  intro h3,
  intro hy,
  have claim: y ∈ metric.ball x e ∩ A,
  split,
  exact metric.mem_ball.mpr h3,
  exact hy,
  have claim2: metric.ball x e ∩ A ⊆ {x},
  exact set.diff_eq_empty.mp h2,
  have claim3: y ∈ {x},
  exact claim2 claim,
  simp at claim3,
  exact claim3,
end

lemma inter_bUnion {X: Type} (A: set X) (S: set X) (B: set X →  X → set X) :
  (A ∩ ⋃ (i : X) (H : i ∈ S), B A i) = ⋃ (i : X) (H : i ∈ S), A ∩ B A i :=
begin
  ext y,
  split,
  {
    intro h,
    cases h with h1 h2,
    rw set.mem_bUnion_iff at h2 ⊢,
    cases h2 with z h2,
    use z,
    cases h2 with hz h2,
    split,

    exact hz,
    split,
    exact h1,
    exact h2,

  },
  {
    intro h,
    rw set.mem_bUnion_iff at h,
    cases h with z h,
    cases h with hz h,
    cases h with ha hb,
    split,
    exact ha,
    rw set.mem_bUnion_iff,
    use z,
    exact ⟨hz, hb⟩,

  },
end

-- A ∩ x_ball_rad X A x ⊆ {x}
lemma x_ball_rad_inter_A {X: Type} [metric_space X] (A: set X): ∀ x: X, A ∩ x_ball_rad X A x ⊆ {x} :=
begin
  intro x,
  have h2: one_rad X A x ∈ small_rad X A x,
  exact one_rad_in_small_rad A x,
  unfold small_rad at h2,
  simp at h2,
  cases h2 with h2 h3,
  cases h3 with h3 h4,
  simp,
  intro hy,
  specialize h3 hy,
  intro hya,
  intro h4,
  specialize h3 h4,
  apply h3,
  exact hya,

end

-- y ∈ A ∩ x_ball_rad X A x → y = x
lemma mem_x_ball_rad_inter_A {X: Type} [metric_space X] (A: set X) (x: X) (y: X) (h: y ∈ A ∩ x_ball_rad X A x):
  y = x:=
begin
  have h1: ∀ x: X, A ∩ x_ball_rad X A x ⊆ {x},
  exact x_ball_rad_inter_A A,
  specialize h1 x,
  have h2: y ∈ {x},
  exact h1 h,
  exact set.mem_singleton_iff.mp h2,
end

-- X is compact → Every infinite subset of X has a cluster point
example {X: Type} [metric_space X] (h: is_compact (set.univ: set X)) (A: set X) (h1: infinite A) : ((accu X A).nonempty) :=
begin
  by_contra hypo,
  rw set.not_nonempty_iff_eq_empty at hypo,
  rw is_compact_iff_finite_subcover at h,
  specialize h (x_ball_rad X A: X → set X),
  have metric_open: ∀ (i : X), is_open (x_ball_rad X A i),
  intro x,
  unfold x_ball_rad,
  exact metric.is_open_ball,
  specialize h metric_open,

  have claim: ∀ x: X, x ∈ accu_compl X A,
  exact accu_empty_accu_compl A hypo,
  have cover: set.univ ⊆ ⋃ (i : X), x_ball_rad X A i,
  rw set.subset_def,
  intro x,
  intro hx,
  have h2: x ∈ x_ball_rad X A x,
  specialize claim x,
  exact accu_compl_x_in_ball_rad A x claim,
  have ball_subset: x_ball_rad X A x ⊆ ⋃ (i : X), x_ball_rad X A i,
  exact set.subset_Union (x_ball_rad X A) x,
  exact ball_subset h2,
  specialize h cover,
  cases h with S h,
  have inter_A: A ∩ set.univ ⊆ A ∩ ⋃ (i : X) (H : i ∈ S), x_ball_rad X A i,
  exact set.inter_subset_inter_right A h,
  rw set.inter_univ A at inter_A,
  --rw inter_bUnion A S (x_ball_rad X A) at h,
  have h2: (A ∩ ⋃ (i : X) (H : i ∈ S), (x_ball_rad X A) i) = ⋃ (i : X) (H : i ∈ S), A ∩ (x_ball_rad X A) i,
  exact inter_bUnion A S (x_ball_rad X),
  rw h2 at inter_A,
  have h3: ∀ i: X, A ∩ x_ball_rad X A i ⊆ {i},
  exact x_ball_rad_inter_A A,

  have h4: (⋃ (i : X) (H : i ∈ S), A ∩ x_ball_rad X A i) ⊆ ⋃ (i : X) (H : i ∈ S), {i},
  rw set.subset_def,
  intro x,
  intro hx,
  simp,
  simp at hx,
  cases hx with i hx,
  cases hx with hx1 hx2,

  have hx3: x ∈ A ∩ x_ball_rad X A i,
  exact (set.mem_inter_iff x A (x_ball_rad X A i)).mpr hx2,
  have hx4: x = i,
  exact mem_x_ball_rad_inter_A A i x hx3,
  rw hx4,
  exact hx1,
  have hA: A ⊆ ⋃ (i : X) (H : i ∈ S), {i},
  exact set.subset.trans inter_A h4,
  have h5:  (⋃ (i : X) (H : i ∈ S), {i} ).infinite,
  apply set.infinite.mono hA,
  exact set.infinite_coe_iff.mp h1,
  apply h5,
  let t: X → (set X) := λ t, {t},
  have h6: ∀ (i : X), i ∈ S → (t i).finite,
  intro i,
  intro hi,
  exact set.finite_singleton i,
  have h7: (⋃ (i : X) (H : i ∈ S), {i})= ⋃ (i : X) (H : i ∈ S), t i,
  exact rfl,
  rw h7,

  have h8: ∀ (x : X), (x ∈ ⋃ (i : X) (H : i ∈ S), t i) ↔ x ∈ S,
  intro x,
  simp,
  have h9: (coe S: set X).finite,
  exact finset.finite_to_set S,
  exact set.finite.bUnion h9 h6,
end


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

! This file was ported from Lean 3 source module set_theory.game.state
! leanprover-community/mathlib commit b134b2f5cf6dd25d4bbfd3c498b6e36c11a17225
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.SetTheory.Game.Short

/-!
# Games described via "the state of the board".

We provide a simple mechanism for constructing combinatorial (pre-)games, by describing
"the state of the board", and providing an upper bound on the number of turns remaining.

## Implementation notes

We're very careful to produce a computable definition, so small games can be evaluated
using `dec_trivial`. To achieve this, I've had to rely solely on induction on natural numbers:
relying on general well-foundedness seems to be poisonous to computation?

See `set_theory/game/domineering` for an example using this construction.
-/

universe u

namespace Pgame

/-- `pgame_state S` describes how to interpret `s : S` as a state of a combinatorial game.
Use `pgame.of_state s` or `game.of_state s` to construct the game.

`pgame_state.L : S → finset S` and `pgame_state.R : S → finset S` describe the states reachable
by a move by Left or Right. `pgame_state.turn_bound : S → ℕ` gives an upper bound on the number of
possible turns remaining from this state.
-/
class State (S : Type u) where
  turnBound : S → ℕ
  l : S → Finset S
  r : S → Finset S
  left_bound : ∀ {s t : S} (m : t ∈ L s), turn_bound t < turn_bound s
  right_bound : ∀ {s t : S} (m : t ∈ R s), turn_bound t < turn_bound s
#align pgame.state Pgame.State

open StateM

variable {S : Type u} [State S]

theorem turnBound_ne_zero_of_left_move {s t : S} (m : t ∈ l s) : turnBound s ≠ 0 :=
  by
  intro h
  have t := state.left_bound m
  rw [h] at t
  exact Nat.not_succ_le_zero _ t
#align pgame.turn_bound_ne_zero_of_left_move Pgame.turnBound_ne_zero_of_left_move

theorem turnBound_ne_zero_of_right_move {s t : S} (m : t ∈ r s) : turnBound s ≠ 0 :=
  by
  intro h
  have t := state.right_bound m
  rw [h] at t
  exact Nat.not_succ_le_zero _ t
#align pgame.turn_bound_ne_zero_of_right_move Pgame.turnBound_ne_zero_of_right_move

theorem turnBound_of_left {s t : S} (m : t ∈ l s) (n : ℕ) (h : turnBound s ≤ n + 1) :
    turnBound t ≤ n :=
  Nat.le_of_lt_succ (Nat.lt_of_lt_of_le (left_bound m) h)
#align pgame.turn_bound_of_left Pgame.turnBound_of_left

theorem turnBound_of_right {s t : S} (m : t ∈ r s) (n : ℕ) (h : turnBound s ≤ n + 1) :
    turnBound t ≤ n :=
  Nat.le_of_lt_succ (Nat.lt_of_lt_of_le (right_bound m) h)
#align pgame.turn_bound_of_right Pgame.turnBound_of_right

/-- Construct a `pgame` from a state and a (not necessarily optimal) bound on the number of
turns remaining.
-/
def ofStateAux : ∀ (n : ℕ) (s : S) (h : turnBound s ≤ n), Pgame
  | 0, s, h =>
    Pgame.mk { t // t ∈ l s } { t // t ∈ r s }
      (fun t => by exfalso; exact turn_bound_ne_zero_of_left_move t.2 (nonpos_iff_eq_zero.mp h))
      fun t => by exfalso; exact turn_bound_ne_zero_of_right_move t.2 (nonpos_iff_eq_zero.mp h)
  | n + 1, s, h =>
    Pgame.mk { t // t ∈ l s } { t // t ∈ r s }
      (fun t => of_state_aux n t (turnBound_of_left t.2 n h)) fun t =>
      of_state_aux n t (turnBound_of_right t.2 n h)
#align pgame.of_state_aux Pgame.ofStateAux

/-- Two different (valid) turn bounds give equivalent games. -/
def ofStateAuxRelabelling :
    ∀ (s : S) (n m : ℕ) (hn : turnBound s ≤ n) (hm : turnBound s ≤ m),
      Relabelling (ofStateAux n s hn) (ofStateAux m s hm)
  | s, 0, 0, hn, hm => by
    dsimp [Pgame.ofStateAux]
    fconstructor; rfl; rfl
    · intro i
      dsimp at i
      exfalso
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hn)
    · intro j
      dsimp at j
      exfalso
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hm)
  | s, 0, m + 1, hn, hm => by
    dsimp [Pgame.ofStateAux]
    fconstructor; rfl; rfl
    · intro i
      dsimp at i
      exfalso
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hn)
    · intro j
      dsimp at j
      exfalso
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hn)
  | s, n + 1, 0, hn, hm => by
    dsimp [Pgame.ofStateAux]
    fconstructor; rfl; rfl
    · intro i
      dsimp at i
      exfalso
      exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp hm)
    · intro j
      dsimp at j
      exfalso
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp hm)
  | s, n + 1, m + 1, hn, hm => by
    dsimp [Pgame.ofStateAux]
    fconstructor; rfl; rfl
    · intro i
      apply of_state_aux_relabelling
    · intro j
      apply of_state_aux_relabelling
#align pgame.of_state_aux_relabelling Pgame.ofStateAuxRelabelling

/-- Construct a combinatorial `pgame` from a state. -/
def ofState (s : S) : Pgame :=
  ofStateAux (turnBound s) s (refl _)
#align pgame.of_state Pgame.ofState

/-- The equivalence between `left_moves` for a `pgame` constructed using `of_state_aux _ s _`, and
`L s`. -/
def leftMovesOfStateAux (n : ℕ) {s : S} (h : turnBound s ≤ n) :
    LeftMoves (ofStateAux n s h) ≃ { t // t ∈ l s } := by induction n <;> rfl
#align pgame.left_moves_of_state_aux Pgame.leftMovesOfStateAux

/-- The equivalence between `left_moves` for a `pgame` constructed using `of_state s`, and `L s`. -/
def leftMovesOfState (s : S) : LeftMoves (ofState s) ≃ { t // t ∈ l s } :=
  leftMovesOfStateAux _ _
#align pgame.left_moves_of_state Pgame.leftMovesOfState

/-- The equivalence between `right_moves` for a `pgame` constructed using `of_state_aux _ s _`, and
`R s`. -/
def rightMovesOfStateAux (n : ℕ) {s : S} (h : turnBound s ≤ n) :
    RightMoves (ofStateAux n s h) ≃ { t // t ∈ r s } := by induction n <;> rfl
#align pgame.right_moves_of_state_aux Pgame.rightMovesOfStateAux

/-- The equivalence between `right_moves` for a `pgame` constructed using `of_state s`, and
`R s`. -/
def rightMovesOfState (s : S) : RightMoves (ofState s) ≃ { t // t ∈ r s } :=
  rightMovesOfStateAux _ _
#align pgame.right_moves_of_state Pgame.rightMovesOfState

/-- The relabelling showing `move_left` applied to a game constructed using `of_state_aux`
has itself been constructed using `of_state_aux`.
-/
def relabellingMoveLeftAux (n : ℕ) {s : S} (h : turnBound s ≤ n)
    (t : LeftMoves (ofStateAux n s h)) :
    Relabelling (moveLeft (ofStateAux n s h) t)
      (ofStateAux (n - 1) ((leftMovesOfStateAux n h) t : S)
        (turnBound_of_left ((leftMovesOfStateAux n h) t).2 (n - 1) (Nat.le_trans h le_tsub_add))) :=
  by
  induction n
  · have t' := (left_moves_of_state_aux 0 h) t
    exfalso
    exact turn_bound_ne_zero_of_left_move t'.2 (nonpos_iff_eq_zero.mp h)
  · rfl
#align pgame.relabelling_move_left_aux Pgame.relabellingMoveLeftAux

/-- The relabelling showing `move_left` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabellingMoveLeft (s : S) (t : LeftMoves (ofState s)) :
    Relabelling (moveLeft (ofState s) t) (ofState ((leftMovesOfState s).toFun t : S)) :=
  by
  trans
  apply relabelling_move_left_aux
  apply of_state_aux_relabelling
#align pgame.relabelling_move_left Pgame.relabellingMoveLeft

/-- The relabelling showing `move_right` applied to a game constructed using `of_state_aux`
has itself been constructed using `of_state_aux`.
-/
def relabellingMoveRightAux (n : ℕ) {s : S} (h : turnBound s ≤ n)
    (t : RightMoves (ofStateAux n s h)) :
    Relabelling (moveRight (ofStateAux n s h) t)
      (ofStateAux (n - 1) ((rightMovesOfStateAux n h) t : S)
        (turnBound_of_right ((rightMovesOfStateAux n h) t).2 (n - 1)
          (Nat.le_trans h le_tsub_add))) :=
  by
  induction n
  · have t' := (right_moves_of_state_aux 0 h) t
    exfalso
    exact turn_bound_ne_zero_of_right_move t'.2 (nonpos_iff_eq_zero.mp h)
  · rfl
#align pgame.relabelling_move_right_aux Pgame.relabellingMoveRightAux

/-- The relabelling showing `move_right` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabellingMoveRight (s : S) (t : RightMoves (ofState s)) :
    Relabelling (moveRight (ofState s) t) (ofState ((rightMovesOfState s).toFun t : S)) :=
  by
  trans
  apply relabelling_move_right_aux
  apply of_state_aux_relabelling
#align pgame.relabelling_move_right Pgame.relabellingMoveRight

instance fintypeLeftMovesOfStateAux (n : ℕ) (s : S) (h : turnBound s ≤ n) :
    Fintype (LeftMoves (ofStateAux n s h)) :=
  by
  apply Fintype.ofEquiv _ (left_moves_of_state_aux _ _).symm
  infer_instance
#align pgame.fintype_left_moves_of_state_aux Pgame.fintypeLeftMovesOfStateAux

instance fintypeRightMovesOfStateAux (n : ℕ) (s : S) (h : turnBound s ≤ n) :
    Fintype (RightMoves (ofStateAux n s h)) :=
  by
  apply Fintype.ofEquiv _ (right_moves_of_state_aux _ _).symm
  infer_instance
#align pgame.fintype_right_moves_of_state_aux Pgame.fintypeRightMovesOfStateAux

instance shortOfStateAux : ∀ (n : ℕ) {s : S} (h : turnBound s ≤ n), Short (ofStateAux n s h)
  | 0, s, h =>
    Short.mk'
      (fun i => by
        have i := (left_moves_of_state_aux _ _).toFun i
        exfalso
        exact turn_bound_ne_zero_of_left_move i.2 (nonpos_iff_eq_zero.mp h))
      fun j => by
      have j := (right_moves_of_state_aux _ _).toFun j
      exfalso
      exact turn_bound_ne_zero_of_right_move j.2 (nonpos_iff_eq_zero.mp h)
  | n + 1, s, h =>
    Short.mk'
      (fun i =>
        shortOfRelabelling (relabellingMoveLeftAux (n + 1) h i).symm (short_of_state_aux n _))
      fun j =>
      shortOfRelabelling (relabellingMoveRightAux (n + 1) h j).symm (short_of_state_aux n _)
#align pgame.short_of_state_aux Pgame.shortOfStateAux

instance shortOfState (s : S) : Short (ofState s) :=
  by
  dsimp [Pgame.ofState]
  infer_instance
#align pgame.short_of_state Pgame.shortOfState

end Pgame

namespace Game

/-- Construct a combinatorial `game` from a state. -/
def ofState {S : Type u} [Pgame.State S] (s : S) : Game :=
  ⟦Pgame.ofState s⟧
#align game.of_state Game.ofState

end Game


import data.complex.basic tactic.ring
open is_absolute_value

lemma finset.exists_max {α : Type*} [decidable_linear_order α] [inhabited α] (s : finset α) : ∃ a : α, ∀ b : α, b ∈ s → b ≤ a := begin
  apply finset.induction_on s,
  existsi default α,simp,
  assume a s as hi,
  cases hi with m hm,
  existsi max a m,
  assume b,simp,assume h,
  cases h with h h,
  rw h, exact le_max_left _ _,
  exact le_trans (hm b h) (le_max_right _ _),
end

lemma seq_bounded_above_of_cau {α : Type*} {β : Type*} [discrete_linear_ordered_field α]
  [ring β] {f : ℕ → β} {abv : β → α} [is_absolute_value abv] : is_cau_seq abv f →
  ∃ a : α, ∀ i : ℕ, abv (f i) < a := begin
  assume h,unfold is_cau_seq at h,
  have iα : inhabited α := ⟨0⟩,
  cases h 1 (by norm_num) with i hi,
  have : ∀ j : ℕ, j ≥ i → abv (f j) - abv (f i) < 1,assume j ji,
  have := hi j ji,
  exact lt_of_le_of_lt (sub_abv_le_abv_sub _ _ _) this,
  generalize hs : finset.image (λ k, abv (f k)) (finset.range i) = s,
  cases finset.exists_max s with ms hms,
  existsi max (1 + abv (f i)) (ms + 1),assume i₁,
  cases lt_or_ge i₁ i,
  have := finset.mem_image_of_mem (λ (k : ℕ), abv (f k)) (finset.mem_range.mpr h_1),rw hs at this,
  have := hms _ this,simp at this,
  exact lt_of_le_of_lt this (lt_of_lt_of_le (lt_add_one _) (le_max_right _ _)),
  have := this i₁ h_1,
  rw sub_lt_iff_lt_add at this,
  exact lt_of_lt_of_le this (le_max_left _ _),
end
section real
open real
lemma real.lim_const {f : ℕ → ℝ} (hf : is_cau_seq abs f) (x : ℝ) : x = real.lim f ↔
cau_seq.const abs x ≈ ⟨f, hf⟩ := begin
  have := real.equiv_lim ⟨f, hf⟩,split,assume h,rw h,simp at this,exact setoid.symm this,
  assume h,have := setoid.trans h this,rw cau_seq.const_equiv at this,simp at this, exact this,
end

lemma real.lim_eq_lim_iff_equiv {f g : ℕ → ℝ} (hf : is_cau_seq abs f)
    (hg : is_cau_seq abs g) : real.lim f = real.lim g ↔ @has_equiv.equiv
    (cau_seq ℝ abs) _ ⟨f, hf⟩ ⟨g, hg⟩ := begin
  have h₁:= real.lim_const hg (real.lim f),
  have h₂:= real.lim_const hf (real.lim g),
  split,assume h, simp * at *,
  exact setoid.trans (setoid.symm h₂) h₁,
  assume h,rw h₁,have := real.equiv_lim ⟨f, hf⟩,simp at this,
  exact setoid.trans (setoid.symm this) h,
end

-- would be useful to have is_cau_seq abs f → is_cau_seq abs g → is_cau_seq abs (λ i, f i + g i)
-- in the library, similarly for mul
lemma real.lim_add {f g : ℕ → ℝ} (hf : is_cau_seq abs f)
    (hg : is_cau_seq abs g) : real.lim f + real.lim g =
    real.lim (λ x, f x + g x) := begin
  have : ∀ (ε : ℝ),
    ε > 0 → (∃ (i : ℕ), ∀ (j : ℕ), j ≥ i → abs (f j + (g j + (-real.lim f + -real.lim g))) < ε),
    {assume ε ε0,
    cases real.equiv_lim ⟨f, hf⟩ (ε / 2) (div_pos ε0 (by norm_num)) with fi hfi,simp at hfi,
    cases real.equiv_lim ⟨g, hg⟩ (ε / 2) (div_pos ε0 (by norm_num)) with gi hgi,simp at hgi,
    existsi max fi gi,
    assume j hj,rw [add_left_comm (g j),←add_assoc (f j)],
    refine lt_of_le_of_lt (abs_add _ _) _,rw ←add_halves ε,
    exact add_lt_add (hfi j (le_trans (le_max_left _ _) hj)) (hgi j (le_trans (le_max_right _ _) hj))},
  have cau : is_cau_seq abs (λ (x : ℕ), f x + g x), refine cau_seq.of_near _ (cau_seq.const abs (real.lim f + real.lim g)) _,simpa,
  rw real.lim_const,refine setoid.symm _,exact cau,assume ε ε0,simp,exact this ε ε0,
end

lemma real.lim_mul {f g : ℕ → ℝ} (hf : is_cau_seq abs f)
    (hg : is_cau_seq abs g) : real.lim f * real.lim g =
    real.lim (λ x, f x * g x) := begin
  have : ∀ (ε : ℝ),
    ε > 0 → (∃ (i : ℕ), ∀ (j : ℕ), j ≥ i → abs (f j * g j - (real.lim f * real.lim g)) < ε),
  { assume ε ε0,
    cases seq_bounded_above_of_cau hg with G hG,
    have G0 : 0 < G := lt_of_le_of_lt (abs_nonneg _) (hG 0),
    have Gf : 0 < G + abs (lim f) := add_pos_of_pos_of_nonneg G0 (abs_nonneg _),
    have Gε : 0 < ε / (G + abs (lim f)) := div_pos ε0 Gf,
    cases real.equiv_lim ⟨f, hf⟩ _ Gε with fi hfi, simp at hfi,
    cases real.equiv_lim ⟨g, hg⟩ _ Gε with gi hgi, simp at hgi,
    existsi max fi gi,assume j ji,
    rw (by simp[mul_add,add_mul];ring : f j * g j -lim f * lim g = (f j - lim f) * g j + lim f * (g j - lim g)),
    refine lt_of_le_of_lt (abs_add _ _) _,
    rw [abs_mul],
    suffices : abs (f j - lim f) * G + abs (lim f * (g j - lim g)) < ε,
      exact lt_of_le_of_lt (add_le_add (mul_le_mul_of_nonneg_left (le_of_lt (hG j)) (abs_nonneg _)) (le_refl _)) this,
    rw abs_mul,
    have : ε = ε * G / (G + abs (lim f)) + ε * abs (lim f) / (G + abs (lim f)),
      {rw [←add_div,←mul_add,mul_div_cancel _ (ne_of_lt Gf).symm]},
    rw this,
    refine add_lt_add_of_lt_of_le _ _,
    {rw [mul_comm,mul_comm ε,mul_div_assoc],
    exact mul_lt_mul_of_pos_left (hfi j (le_trans (le_max_left _ _) ji)) G0},
    rw [mul_comm ε,mul_div_assoc],
    refine mul_le_mul_of_nonneg_left (le_of_lt (hgi j (le_trans (le_max_right _ _) ji))) (abs_nonneg _)},
  have cau : is_cau_seq abs (λ (x : ℕ), f x * g x), refine cau_seq.of_near _ (cau_seq.const abs (real.lim f * real.lim g)) _,simpa,
  rw real.lim_const, refine setoid.symm _,exact cau,assume ε ε0,simp, exact this ε ε0,
end
end real

lemma complex.re_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) :
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ → cau_seq.const abs z.re ≈  ⟨(λ (n : ℕ), (f n).re),
    complex.is_cau_seq_re ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_re,←complex.add_re],
  exact lt_of_le_of_lt (complex.abs_re_le_abs _) hi,
end

lemma complex.im_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) :
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ → cau_seq.const abs z.im ≈ ⟨(λ (n : ℕ), (f n).im),
    complex.is_cau_seq_im ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_im,←complex.add_im],
  exact lt_of_le_of_lt (complex.abs_im_le_abs _) hi,
end

lemma complex.lim_const {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) : z = complex.lim f ↔
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ := begin
  split,have := complex.equiv_lim ⟨f, hf⟩,simp at this,
  assume h,rw h, exact setoid.symm this,assume h,
  unfold complex.lim,cases z with zre zim,simp,
  split, have := real.equiv_lim ⟨(λ (n : ℕ), (f n).re), complex.is_cau_seq_re ⟨f,hf⟩⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.re_const_equiv_of_const_equiv hf {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
  have := real.equiv_lim ⟨(λ (n : ℕ), (f n).im), complex.is_cau_seq_im ⟨f,hf⟩⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.im_const_equiv_of_const_equiv hf {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
end

lemma complex.lim_eq_lim_iff_equiv {f g : ℕ → ℂ} (hf : is_cau_seq complex.abs f)
    (hg : is_cau_seq complex.abs g) : complex.lim f = complex.lim g ↔ @has_equiv.equiv
    (cau_seq ℂ complex.abs) _ ⟨f, hf⟩ ⟨g, hg⟩ := begin
  have h₁:= complex.lim_const hg (complex.lim f),
  have h₂:= complex.lim_const hf (complex.lim g),
  split,assume h, simp * at *,
  exact setoid.trans (setoid.symm h₂) h₁,
  assume h,rw h₁,have := complex.equiv_lim ⟨f, hf⟩,simp at this,
  exact setoid.trans (setoid.symm this) h,
end
open complex
lemma complex.lim_add {f g : ℕ → ℂ} (hf : is_cau_seq complex.abs f)
    (hg : is_cau_seq complex.abs g) : complex.lim f + complex.lim g =
    complex.lim (λ x, f x + g x) := begin
  have : ∀ (ε : ℝ),
    ε > 0 → (∃ (i : ℕ), ∀ (j : ℕ), j ≥ i → complex.abs (f j + (g j + (-complex.lim f + -complex.lim g))) < ε),
    {assume ε ε0,
    cases complex.equiv_lim ⟨f, hf⟩ (ε / 2) (div_pos ε0 (by norm_num)) with fi hfi,simp at hfi,
    cases complex.equiv_lim ⟨g, hg⟩ (ε / 2) (div_pos ε0 (by norm_num)) with gi hgi,simp at hgi,
    existsi max fi gi,
    assume j hj,rw [add_left_comm (g j),←add_assoc (f j)],
    refine lt_of_le_of_lt (complex.abs_add _ _) _,rw ←add_halves ε,
    exact add_lt_add (hfi j (le_trans (le_max_left _ _) hj)) (hgi j (le_trans (le_max_right _ _) hj))},
  have cau : is_cau_seq complex.abs (λ (x : ℕ), f x + g x), refine cau_seq.of_near _ (cau_seq.const complex.abs (lim f + lim g)) _,simpa,
  rw lim_const,refine setoid.symm _,exact cau,assume ε ε0,simp,exact this ε ε0,
end

lemma complex.lim_mul {f g : ℕ → ℂ} (hf : is_cau_seq complex.abs f)
    (hg : is_cau_seq complex.abs g) : complex.lim f * complex.lim g =
    complex.lim (λ x, f x * g x) := begin
  have : ∀ (ε : ℝ),
    ε > 0 → (∃ (i : ℕ), ∀ (j : ℕ), j ≥ i → complex.abs (f j * g j - (complex.lim f * complex.lim g)) < ε),
  { assume ε ε0,
    cases seq_bounded_above_of_cau hg with G hG,
    have G0 : 0 < G := lt_of_le_of_lt (complex.abs_nonneg _) (hG 0),
    have Gf : 0 < G + complex.abs (complex.lim f) := add_pos_of_pos_of_nonneg G0 (complex.abs_nonneg _),
    have Gε : 0 < ε / (G + complex.abs (complex.lim f)) := div_pos ε0 Gf,
    cases complex.equiv_lim ⟨f, hf⟩ _ Gε with fi hfi, simp at hfi,
    cases complex.equiv_lim ⟨g, hg⟩ _ Gε with gi hgi, simp at hgi,
    existsi max fi gi,assume j ji,
    rw (by simp[mul_add,add_mul];ring : f j * g j -complex.lim f * complex.lim g = (f j - complex.lim f) * g j + complex.lim f * (g j - complex.lim g)),
    refine lt_of_le_of_lt (complex.abs_add _ _) _,
    rw [complex.abs_mul],
    suffices : complex.abs (f j - lim f) * G + complex.abs (lim f * (g j - lim g)) < ε,
      exact lt_of_le_of_lt (add_le_add (mul_le_mul_of_nonneg_left (le_of_lt (hG j)) (abs_nonneg _)) (le_refl _)) this,
    rw complex.abs_mul,
    have : ε = ε * G / (G + abs (lim f)) + ε * abs (lim f) / (G + abs (lim f)),
      {rw [←add_div,←mul_add,mul_div_cancel _ (ne_of_lt Gf).symm]},
    rw this,
    refine add_lt_add_of_lt_of_le _ _,
    {rw [mul_comm,mul_comm ε,mul_div_assoc],
    exact mul_lt_mul_of_pos_left (hfi j (le_trans (le_max_left _ _) ji)) G0},
    rw [mul_comm ε,mul_div_assoc],
    refine mul_le_mul_of_nonneg_left (le_of_lt (hgi j (le_trans (le_max_right _ _) ji))) (abs_nonneg _)},
  have cau : is_cau_seq complex.abs (λ (x : ℕ), f x * g x), refine cau_seq.of_near _ (cau_seq.const abs (lim f * lim g)) _,simpa,
  rw lim_const, refine setoid.symm _,exact cau,assume ε ε0,simp, exact this ε ε0,
end


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.solvable

/-!
# Semisimple Lie algebras

The famous Cartan-Dynkin-Killing classification of semisimple Lie algebras renders them one of the
most important classes of Lie algebras. In this file we define simple and semisimple Lie algebras
and prove some basic related results.

## Main definitions

  * `lie_module.is_irreducible`
  * `lie_algebra.is_simple`
  * `lie_algebra.is_semisimple`
  * `lie_algebra.is_semisimple_iff_no_solvable_ideals`
  * `lie_algebra.is_semisimple_iff_no_abelian_ideals`
  * `lie_algebra.abelian_radical_iff_solvable_is_abelian`

## Tags

lie algebra, radical, simple, semisimple
-/

universes u v w w₁ w₂

/-- A Lie module is irreducible if it is zero or its only non-trivial Lie submodule is itself. -/
class lie_module.is_irreducible (R : Type u) (L : Type v) (M : Type w)
  [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
  [lie_ring_module L M] [lie_module R L M] : Prop :=
(irreducible : ∀ (N : lie_submodule R L M), N ≠ ⊥ → N = ⊤)

namespace lie_algebra

variables (R : Type u) (L : Type v)
variables [comm_ring R] [lie_ring L] [lie_algebra R L]

set_option old_structure_cmd true
/-- A Lie algebra is simple if it is irreducible as a Lie module over itself via the adjoint
action, and it is non-Abelian. -/
class is_simple extends lie_module.is_irreducible R L L : Prop :=
(non_abelian : ¬is_lie_abelian L)

/-- A semisimple Lie algebra is one with trivial radical.

Note that the label 'semisimple' is apparently not universally agreed
[upon](https://mathoverflow.net/questions/149391/on-radicals-of-a-lie-algebra#comment383669_149391)
for general coefficients. We are following [Seligman, page 15](seligman1967) and using the label
for the weakest of the various properties which are all equivalent over a field of characteristic
zero. -/
class is_semisimple : Prop :=
(semisimple : radical R L = ⊥)

lemma is_semisimple_iff_no_solvable_ideals :
  is_semisimple R L ↔ ∀ (I : lie_ideal R L), is_solvable R I → I = ⊥ :=
⟨λ h, Sup_eq_bot.mp h.semisimple, λ h, ⟨Sup_eq_bot.mpr h⟩⟩

lemma is_semisimple_iff_no_abelian_ideals :
  is_semisimple R L ↔ ∀ (I : lie_ideal R L), is_lie_abelian I → I = ⊥ :=
begin
  rw is_semisimple_iff_no_solvable_ideals,
  split; intros h₁ I h₂,
  { haveI : is_lie_abelian I := h₂, apply h₁, exact lie_algebra.of_abelian_is_solvable R I, },
  { haveI : is_solvable R I := h₂, rw ← abelian_of_solvable_ideal_eq_bot_iff, apply h₁,
    exact abelian_derived_abelian_of_ideal I, },
end

@[simp] lemma center_eq_bot_of_semisimple [h : is_semisimple R L] : center R L = ⊥ :=
by { rw is_semisimple_iff_no_abelian_ideals at h, apply h, apply_instance, }

/-- A simple Lie algebra is semisimple. -/
@[priority 100]
instance is_semisimple_of_is_simple [h : is_simple R L] : is_semisimple R L :=
begin
  rw is_semisimple_iff_no_abelian_ideals,
  intros I hI,
  tactic.unfreeze_local_instances, obtain ⟨h₁, h₂⟩ := h,
  by_contradiction contra,
  rw [h₁ I contra, lie_abelian_iff_equiv_lie_abelian lie_ideal.top_equiv_self] at hI,
  exact h₂ hI,
end

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_semisimple_lie_abelian [is_semisimple R L] [h : is_lie_abelian L] :
  subsingleton (lie_ideal R L) :=
begin
  apply subsingleton_of_bot_eq_top,
  rwa [is_lie_abelian_iff_center_eq_top R L, center_eq_bot_of_semisimple] at h,
end

lemma abelian_radical_of_semisimple [is_semisimple R L] : is_lie_abelian (radical R L) :=
by { rw is_semisimple.semisimple, exact is_lie_abelian_bot R L, }

/-- The two properties shown to be equivalent here are possible definitions for a Lie algebra
to be reductive.

Note that there is absolutely [no agreement](https://mathoverflow.net/questions/284713/) on what
the label 'reductive' should mean when the coefficients are not a field of characteristic zero. -/
lemma abelian_radical_iff_solvable_is_abelian [is_noetherian R L] :
  is_lie_abelian (radical R L) ↔ ∀ (I : lie_ideal R L), is_solvable R I → is_lie_abelian I :=
begin
  split,
  { rintros h₁ I h₂,
    rw lie_ideal.solvable_iff_le_radical at h₂,
    exact (lie_ideal.hom_of_le_injective h₂).is_lie_abelian h₁, },
  { intros h, apply h, apply_instance, },
end

end lie_algebra


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

! This file was ported from Lean 3 source module algebra.punit_instances
! leanprover-community/mathlib commit be24ec5de6701447e5df5ca75400ffee19d65659
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Module.Basic
import Mathbin.Algebra.GcdMonoid.Basic
import Mathbin.Algebra.GroupRingAction.Basic
import Mathbin.GroupTheory.GroupAction.Defs
import Mathbin.Order.CompleteBooleanAlgebra

/-!
# Instances on punit

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

This file collects facts about algebraic structures on the one-element type, e.g. that it is a
commutative ring.
-/

universe u

namespace PUnit

variable {R S : Type _} (x y : PUnit.{u + 1}) (s : Set PUnit.{u + 1})

@[to_additive]
instance : CommGroup PUnit := by
  refine_struct
        { mul := fun _ _ => star
          one := star
          inv := fun _ => star
          div := fun _ _ => star
          npow := fun _ _ => star
          zpow := fun _ _ => star.. } <;>
      intros <;>
    exact Subsingleton.elim _ _

#print PUnit.one_eq /-
@[simp, to_additive]
theorem one_eq : (1 : PUnit) = unit :=
  rfl
#align punit.one_eq PUnit.one_eq
#align punit.zero_eq PUnit.zero_eq
-/

#print PUnit.mul_eq /-
@[simp, to_additive]
theorem mul_eq : x * y = unit :=
  rfl
#align punit.mul_eq PUnit.mul_eq
#align punit.add_eq PUnit.add_eq
-/

#print PUnit.div_eq /-
-- `sub_eq` simplifies `punit.sub_eq`, but the latter is eligible for `dsimp`
@[simp, nolint simp_nf, to_additive]
theorem div_eq : x / y = unit :=
  rfl
#align punit.div_eq PUnit.div_eq
#align punit.sub_eq PUnit.sub_eq
-/

#print PUnit.inv_eq /-
-- `neg_eq` simplifies `punit.neg_eq`, but the latter is eligible for `dsimp`
@[simp, nolint simp_nf, to_additive]
theorem inv_eq : x⁻¹ = unit :=
  rfl
#align punit.inv_eq PUnit.inv_eq
#align punit.neg_eq PUnit.neg_eq
-/

instance : CommRing PUnit := by
  refine' { PUnit.commGroup, PUnit.addCommGroup with natCast := fun _ => PUnit.unit.. } <;>
      intros <;>
    exact Subsingleton.elim _ _

instance : CancelCommMonoidWithZero PUnit := by
  refine' { PUnit.commRing with .. } <;> intros <;> exact Subsingleton.elim _ _

instance : NormalizedGCDMonoid PUnit := by
  refine' {
          gcd := fun _ _ => star
          lcm := fun _ _ => star
          normUnit := fun x => 1
          gcd_dvd_left := fun _ _ => ⟨star, Subsingleton.elim _ _⟩
          gcd_dvd_right := fun _ _ => ⟨star, Subsingleton.elim _ _⟩
          dvd_gcd := fun _ _ _ _ _ => ⟨star, Subsingleton.elim _ _⟩
          gcd_mul_lcm := fun _ _ => ⟨1, Subsingleton.elim _ _⟩.. } <;>
      intros <;>
    exact Subsingleton.elim _ _

#print PUnit.gcd_eq /-
@[simp]
theorem gcd_eq : gcd x y = unit :=
  rfl
#align punit.gcd_eq PUnit.gcd_eq
-/

#print PUnit.lcm_eq /-
@[simp]
theorem lcm_eq : lcm x y = unit :=
  rfl
#align punit.lcm_eq PUnit.lcm_eq
-/

#print PUnit.norm_unit_eq /-
@[simp]
theorem norm_unit_eq : normUnit x = 1 :=
  rfl
#align punit.norm_unit_eq PUnit.norm_unit_eq
-/

instance : CanonicallyOrderedAddMonoid PUnit := by
  refine'
        { PUnit.commRing, PUnit.completeBooleanAlgebra with
          exists_add_of_le := fun _ _ _ => ⟨star, Subsingleton.elim _ _⟩.. } <;>
      intros <;>
    trivial

instance : LinearOrderedCancelAddCommMonoid PUnit :=
  { PUnit.canonicallyOrderedAddMonoid, PUnit.linearOrder with
    le_of_add_le_add_left := fun _ _ _ _ => trivial }

instance : LinearOrderedAddCommMonoidWithTop PUnit :=
  { PUnit.completeBooleanAlgebra, PUnit.linearOrderedCancelAddCommMonoid with
    top_add' := fun _ => rfl }

@[to_additive]
instance : SMul R PUnit :=
  ⟨fun _ _ => unit⟩

#print PUnit.smul_eq /-
@[simp, to_additive]
theorem smul_eq (r : R) : r • y = unit :=
  rfl
#align punit.smul_eq PUnit.smul_eq
#align punit.vadd_eq PUnit.vadd_eq
-/

@[to_additive]
instance : IsCentralScalar R PUnit :=
  ⟨fun _ _ => rfl⟩

@[to_additive]
instance : SMulCommClass R S PUnit :=
  ⟨fun _ _ _ => rfl⟩

@[to_additive]
instance [SMul R S] : IsScalarTower R S PUnit :=
  ⟨fun _ _ _ => rfl⟩

instance [Zero R] : SMulWithZero R PUnit := by
  refine' { PUnit.hasSmul with .. } <;> intros <;> exact Subsingleton.elim _ _

instance [Monoid R] : MulAction R PUnit := by
  refine' { PUnit.hasSmul with .. } <;> intros <;> exact Subsingleton.elim _ _

instance [Monoid R] : DistribMulAction R PUnit := by
  refine' { PUnit.mulAction with .. } <;> intros <;> exact Subsingleton.elim _ _

instance [Monoid R] : MulDistribMulAction R PUnit := by
  refine' { PUnit.mulAction with .. } <;> intros <;> exact Subsingleton.elim _ _

instance [Semiring R] : MulSemiringAction R PUnit :=
  { PUnit.distribMulAction, PUnit.mulDistribMulAction with }

instance [MonoidWithZero R] : MulActionWithZero R PUnit :=
  { PUnit.mulAction, PUnit.smulWithZero with }

instance [Semiring R] : Module R PUnit := by
  refine' { PUnit.distribMulAction with .. } <;> intros <;> exact Subsingleton.elim _ _

end PUnit


/-
The Sinz at-most-one encoding.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import cnf.literal
import cnf.clause
import cnf.cnf
import cnf.encoding
import cnf.gensym

import cardinality.distinct
import cardinality.amk
import cardinality.alk

import data.list.basic
import data.nat.basic

variables {V : Type*} [inhabited V] [decidable_eq V]

namespace sinz_amo

open nat
open list
open literal
open clause
open cnf
open assignment
open encoding
open distinct
open gensym
open amk
open alk

variables {l : list (literal V)} {g : gensym V}
          {τ : assignment V} (hdis : disjoint g.stock (clause.vars l))

@[inline] def xi_to_si (g : gensym V) (n i : nat) (lit : literal V) : cnf V :=
  if (i < n - 1) then [[lit.flip, Pos (g.nth i)]] else []

@[inline] def si_to_next_si (g : gensym V) (n i : nat) : cnf V :=
  if (i < n - 2) then [[Neg (g.nth i), Pos (g.nth (i + 1))]] else []

@[inline] def si_to_next_xi (g : gensym V) (i : nat) (lit : literal V) : cnf V :=
  if (0 < i) then [[Neg (g.nth (i - 1)), lit.flip]] else []

-- TODO: no need to case on length 0 and 1, because the length checks handle things?
def sinz_amo : enc_fn V
| []     g := ⟨[], g⟩
| [lit₁] g := ⟨[], g⟩
| l      g :=
  ⟨join (map_with_index (λ (idx : nat) (lit : literal V),
    xi_to_si g (length l) idx lit ++
    si_to_next_si g (length l) idx ++
    si_to_next_xi g idx lit) l),
  (g.nfresh (length l - 1)).2⟩

def var_idx (g : gensym V) (v : V) : nat → nat
| 0       := 0
| (i + 1) := if v = g.nth (i + 1) then i + 1 else var_idx i

theorem var_idx_eq_nth_of_le (g : gensym V) {i n : nat} (Hi : i ≤ n) :
  var_idx g (g.nth i) n = i :=
begin
  induction n with n ih generalizing i,
  { cases i,
    { refl },
    { rw nonpos_iff_eq_zero at Hi,
      exact absurd Hi (succ_ne_zero _) } },
  { by_cases hn : i = n.succ,
    { subst hn,
      simp [var_idx] },
    { simp [var_idx, nth_ne_of_ne hn],
      exact ih (le_of_lt_succ (lt_of_le_of_ne Hi hn)) } }
end

theorem xi_to_si_mem_sinz_amo (g : gensym V) {i : nat} (Hi : i < length l - 1) (Hi' : i < length l) :
  [(l.nth_le i Hi').flip, Pos (g.nth i)] ∈ (sinz_amo l g).1 :=
begin
  cases l with lit₁ ls, { simp at Hi, contradiction },
  cases ls with lit₂ ls, { simp at Hi, contradiction },
  rw sinz_amo,
  simp at Hi Hi',
  simp [-map_with_index_cons],
  use [((xi_to_si g (ls.length + 2) i ((lit₁ :: lit₂ :: ls).nth_le i Hi')) ++
      (si_to_next_si g (ls.length + 2) i) ++
      si_to_next_xi g i ((lit₁ :: lit₂ :: ls).nth_le i Hi')),
      ((lit₁ :: lit₂ :: ls).nth_le i Hi'), i, Hi'],
  { refl },
  { rw append_assoc },
  { simp [xi_to_si, Hi], left, refl }
end

theorem si_to_next_si_mem (g : gensym V) {i : nat} (Hi : i < length l - 2) :
  [Neg (g.nth i), Pos (g.nth (i + 1))] ∈ (sinz_amo l g).1 :=
begin
  cases l with lit₁ ls, { simp at Hi, contradiction },
  cases ls with lit₂ ls, { simp at Hi, contradiction },
  rw sinz_amo,
  simp at Hi,
  have Hi' : i < length (lit₁ :: lit₂ :: ls),
  { simp, exact lt_succ_of_lt (lt_succ_of_lt Hi) },
  simp [-map_with_index_cons],
  use [(xi_to_si g (ls.length + 2) i ((lit₁ :: lit₂ :: ls).nth_le i Hi') ++
       si_to_next_si g (ls.length + 2) i ++
      si_to_next_xi g i ((lit₁ :: lit₂ :: ls).nth_le i Hi')),
      ((lit₁ :: lit₂ :: ls).nth_le i Hi'), i, Hi'],
  { rw append_assoc },
  { simp [si_to_next_si, Hi] }
end

theorem si_to_next_xi_mem (g : gensym V) {i : nat} (Hi : i + 1 < length l) :
  [Neg (g.nth i), (l.nth_le (i + 1) Hi).flip] ∈ (sinz_amo l g).1 :=
begin
  cases l with lit₁ ls, { simp at Hi, contradiction },
  cases ls with lit₂ ls, { simp at Hi, contradiction },
  rw sinz_amo,
  have Hi' : i < length (lit₁ :: lit₂ :: ls),
  { simp at Hi, simp only [length], exact lt_succ_of_lt Hi },
  simp [-map_with_index_cons],
  use [(xi_to_si g (ls.length + 2) (i + 1) ((lit₁ :: lit₂ :: ls).nth_le (i + 1) Hi) ++
       si_to_next_si g (ls.length + 2) (i + 1) ++
      si_to_next_xi g (i + 1) ((lit₁ :: lit₂ :: ls).nth_le (i + 1) Hi)),
      ((lit₁ :: lit₂ :: ls).nth_le (i + 1) Hi), i + 1, Hi],
  { rw append_assoc },
  { simp [si_to_next_xi] }
end

-- If the var is in l, then use τ.
-- Otherwise, the signal variable is true if at least 1 variable before is true
def sinz_amo_tau (l : list (literal V)) (g : gensym V) (τ : assignment V) : assignment V :=
  aite (clause.vars l) τ (λ v, (alk 1).eval τ (l.take ((var_idx g v (length l - 1)) + 1)))

theorem sinz_amo_eval_tt_under_sinz_amo_tau (hdis : disj l g) : ∀ (τ : assignment V),
  (amk 1).eval τ l = tt → (sinz_amo l g).1.eval (sinz_amo_tau l g τ) = tt :=
begin
  intros τ heval,
  cases l with lit₁ ls,
  { simp [sinz_amo] },
  cases ls with lit₂ ls,
  { simp [sinz_amo] },
  { rw eval_tt_iff_forall_clause_eval_tt,
    intros c hc,
    rw sinz_amo at hc,
    unfold prod.fst at hc,
    simp [-map_with_index_cons] at hc,
    rcases hc with ⟨f, ⟨lit, i, ⟨hi, rfl⟩, rfl⟩, hmemc⟩,
    simp only [mem_append] at hmemc,
    rcases hmemc with (hc | hc | hc),
    { unfold xi_to_si at hc,
      rcases eq_or_lt_of_le (le_of_lt_succ hi) with (rfl | hlt),
      { simp at hc, contradiction },
      { simp [hlt] at hc, subst hc,
        rw eval_tt_iff_exists_literal_eval_tt,
        cases halk : (alk 1).eval τ ((lit₁ :: lit₂ :: ls).take (i + 1)),
        { use [((lit₁ :: lit₂ :: ls).nth_le i hi).flip, mem_cons_self _ _],
          simp [eval_flip],
          rw [sinz_amo_tau, aite_pos_lit (mem_vars_of_mem (nth_le_mem (lit₁ :: lit₂ :: ls) i hi))],
          have hamk : !((alk 1).eval τ ((lit₁ :: lit₂ :: ls).take (i + 1))) = !ff, exact congr_arg bnot halk,
          rw [← amk_eval_eq_alk_succ_eval, bool.bnot_ff, amz_eval_tt_iff_forall_eval_ff] at hamk,
          exact hamk (nth_le_mem_take_of_lt hi (lt_succ_self i)) },
        { use [Pos (g.nth i), mem_cons_of_mem _ (mem_singleton_self _)],
          rw [literal.eval, sinz_amo_tau, aite_neg (disj_right.mp hdis (nth_mem_stock g i)), var_idx_eq_nth_of_le],
          { exact halk },
          { simp only [length, succ_add_sub_one], exact le_of_lt_succ hi } } } },
    { unfold si_to_next_si at hc,
      by_cases hi' : i < ls.length,
      { simp [hi'] at hc, subst hc,
        rw eval_tt_iff_exists_literal_eval_tt,
        cases halk : (alk 1).eval τ ((lit₁ :: lit₂ :: ls).take (i + 1)),
        { use [Neg (g.nth i), mem_cons_self _ _],
          rw [literal.eval, sinz_amo_tau, aite_neg (disj_right.mp hdis (nth_mem_stock g i)), var_idx_eq_nth_of_le],
          { have hamk : !((alk 1).eval τ ((lit₁ :: lit₂ :: ls).take (i + 1))) = !ff, exact congr_arg bnot halk,
            rw [← amk_eval_eq_alk_succ_eval, bool.bnot_ff] at hamk,
            rw ← amk_eval_eq_alk_succ_eval, exact hamk },
          { simp only [length, succ_add_sub_one], exact le_of_lt_succ hi } },
        { use [Pos (g.nth (i + 1)), mem_cons_of_mem _ (mem_singleton_self _)],
          rw [literal.eval, sinz_amo_tau, aite_neg (disj_right.mp hdis (nth_mem_stock g (i + 1))), var_idx_eq_nth_of_le],
          { rw alk.eval_tt_of_sublist_of_eval_tt (take_sublist_of_le (le_succ (i + 1)) _),
            { exact halk },
            { exact _inst_1 } },
          { simp only [length, succ_add_sub_one, add_le_add_iff_right], exact le_of_lt hi' } } },
      { simp [hi'] at hc, contradiction } },
    { unfold si_to_next_xi at hc,
      cases i,
      { simp only [not_lt_zero', if_false, not_mem_nil] at hc, contradiction },
      { simp [-nth_le] at hc, subst hc,
        rw eval_tt_iff_exists_literal_eval_tt,
        cases halk : (alk 1).eval τ ((lit₁ :: lit₂ :: ls).take (i + 1)),
        { use [Neg (g.nth i), mem_cons_self _ _],
          rw [literal.eval, sinz_amo_tau],
          rw [aite_neg (disj_right.mp hdis (nth_mem_stock g i)), var_idx_eq_nth_of_le],
          { rw bnot_eq_true_eq_eq_ff, exact halk },
          { simp only [length, succ_add_sub_one], exact le_of_lt_succ (lt_of_succ_lt hi) } },
        { use [((lit₁ :: lit₂ :: ls).nth_le i.succ hi).flip, mem_cons_of_mem _ (mem_singleton_self _)],
          simp [-nth_le, eval_flip],
          rw [sinz_amo_tau, aite_pos_lit (mem_vars_of_mem (nth_le_mem (lit₁ :: lit₂ :: ls) _ hi))],
          have hi' : i.succ < (lit₁ :: lit₂ :: ls).length, exact hi,
          rw amo_eval_tt_iff_distinct_eval_ff_of_eval_tt at heval,
          rcases alo_eval_tt_iff_exists_eval_tt.mp halk with ⟨z, hmem, hevalz⟩,
          have := nth_le_mem_drop_of_ge hi' (le_refl i.succ),
          have := distinct_of_mem_take_of_mem_drop hmem this,
          exact heval this hevalz } } } }
end

theorem sinz_amo_mem_vars {l : list (literal V)} {g : gensym V} :
  ∀ ⦃v⦄, v ∈ (sinz_amo l g).1.vars → v ∈ (clause.vars l) ∨ (v ∈ (g.nfresh (length l - 1)).1) :=
begin
  -- redo proof with si_to_si_mem theorems?
  cases l with lit₁ ls,
  { simp [sinz_amo] },
  { cases ls with lit₂ ls,
    { simp [sinz_amo] },
    { intros v hv,
      rw sinz_amo at hv,
      unfold prod.fst at hv,
      simp [-map_with_index_cons] at hv,
      rcases hv with ⟨F, ⟨lit, idx, ⟨hlen, rfl⟩, rfl⟩, hf⟩,
      simp at hf,
      rcases hf with (hf | hf | hf),
      { unfold xi_to_si at hf,
        by_cases hidx : idx = ls.length + 1,
        { simp [hidx] at hf, contradiction },
        { have hlen' := lt_of_le_of_ne (le_of_lt_succ hlen) hidx,
          simp [hlen', flip_var_eq, var] at hf,
          rcases hf with (rfl | rfl),
          { exact or.inl (mem_vars_of_mem (nth_le_mem _ _ _)) },
          { exact or.inr (nth_mem_nfresh_of_lt _ hlen') } } },
      { unfold si_to_next_si at hf,
        by_cases hidx : idx ≥ ls.length,
        { simp [not_lt_of_ge hidx] at hf, contradiction },
        { have hlen' := lt_of_not_ge hidx,
          simp [hlen', var] at hf,
          right, simp only [length, succ_add_sub_one],
          rcases hf with (rfl | rfl),
          { exact nth_mem_nfresh_of_lt _ (lt_succ_of_lt hlen') },
          { exact nth_mem_nfresh_of_lt _ (succ_lt_succ_iff.mpr hlen') } } },
      { unfold si_to_next_xi at hf,
        cases idx,
        { simp at hf, contradiction },
        { simp [flip_var_eq, var] at hf,
          rcases hf with (rfl | rfl),
          { right, simp only [length, succ_add_sub_one],
            exact nth_mem_nfresh_of_lt _ (succ_lt_succ_iff.mp hlen) },
          { exact or.inl (mem_vars_of_mem (mem_cons_of_mem _ (nth_le_mem _ _ _))) } } } } }
end

theorem sinz_amo_is_wb : is_wb (sinz_amo : enc_fn V) :=
begin
  intros l g hdis,
  cases l with lit₁ ls,
  { simp [sinz_amo] },
  cases ls with lit₂ ls,
  { simp [sinz_amo] },
  { split,
    { rw sinz_amo,
      intros v hv,
      simp only [prod.snd] at hv,
      exact (nfresh_stock_subset _ _) hv },
    { intros v hv,
      apply (set.mem_union _ _ _).mpr,
      rcases sinz_amo_mem_vars hv with (hv | hv),
      { exact or.inl hv },
      { exact or.inr ⟨nfresh_mem_stock hv, nth_not_mem_nfresh_stock hv⟩ } } }
end

theorem signal_eval_tt_if_xi_eval_tt {i : nat} {hi : i < length l}
  (hi' : i < length l - 1) :
  (sinz_amo l g).1.eval τ = tt → (l.nth_le i hi).eval τ = tt → τ (g.nth i) = tt :=
begin
  cases l with lit₁ ls, { simp only [length, not_lt_zero'] at hi, contradiction },
  cases ls with lit₂ ls, { simp only [length_singleton, not_lt_zero'] at hi', contradiction },
  intros heval hlit,
  rw eval_tt_iff_forall_clause_eval_tt at heval,
  have := heval _ (xi_to_si_mem_sinz_amo g hi' hi),
  simp [eval_tt_iff_exists_literal_eval_tt, eval_flip, literal.eval, hlit] at this,
  exact this
end

theorem signal_eval_tt_of_prev_signal_eval_tt {i : nat} (hi : i < length l - 2) :
  (sinz_amo l g).1.eval τ = tt →
  τ (g.nth i) = tt → ∀ ⦃j : nat⦄, (j > i ∧ j < length l - 1) → τ (g.nth j) = tt :=
begin
  cases l with lit₁ ls, { simp only [length, not_lt_zero'] at hi, contradiction },
  cases ls with lit₂ ls, { simp only [length_singleton, not_lt_zero'] at hi, contradiction },
  rintros heval hgnth j ⟨hij, hj⟩,
  rw eval_tt_iff_forall_clause_eval_tt at heval,
  induction j with j ih,
  { simp only [gt_iff_lt, not_lt_zero'] at hij, contradiction },
  { rcases (eq_or_lt_of_le (le_of_lt_succ hij)) with (rfl | hij'),
    { have := heval _ (si_to_next_si_mem g hi),
      simp [eval_tt_iff_exists_literal_eval_tt, literal.eval, hgnth] at this,
      exact this },
    { have ihred := ih hij' (lt_of_succ_lt hj),
      have hj' : j < (lit₁ :: lit₂ :: ls).length - 2,
      { simp at hj |-, exact succ_lt_succ_iff.mp hj },
      have := heval _ (si_to_next_si_mem g hj'),
      simp [eval_tt_iff_exists_literal_eval_tt, literal.eval, ihred] at this,
      exact this } }
end

theorem nth_eval_ff_of_signal_eval_tt {i : nat} (hi : i < length l - 1) :
  (sinz_amo l g).1.eval τ = tt → τ (g.nth i) = tt →
  ∀ {j : nat} (hj : (j > i) ∧ (j < length l)), (l.nth_le j hj.2).eval τ = ff :=
begin
  cases l with lit₁ ls, { simp only [length, not_lt_zero'] at hi, contradiction },
  cases ls with lit₂ ls, { simp only [length_singleton, not_lt_zero'] at hi, contradiction },
  rintros heval hgnth j ⟨hij, hj⟩,
  cases j,
  { simp only [gt_iff_lt, not_lt_zero'] at hij, contradiction },
  { have hc := eval_tt_iff_forall_clause_eval_tt.mp heval _ (si_to_next_xi_mem g hj),
    rcases eq_or_lt_of_le (le_of_lt_succ hij) with (rfl | h),
    { simp [eval_flip, literal.eval, hgnth, -nth_le] at hc,
      exact hc },
    { simp [succ_lt_succ_iff ] at hj,
      have h' : i < (lit₁ :: lit₂ :: ls).length - 2,
      { exact lt_of_lt_of_le h (le_of_lt_succ hj) },
      have := signal_eval_tt_of_prev_signal_eval_tt h' heval hgnth,
      simp at this,
      simp [eval_flip, literal.eval, this h hj, -nth_le] at hc,
      exact hc } }
end

theorem sinz_amo_formula_encodes : is_correct (amk 1) (sinz_amo : enc_fn V) :=
begin
  intros l g hdis τ,
  cases l with lit₁ ls,
  { simp [sinz_amo] },
  { cases ls with lit₂ ls,
    { simp [sinz_amo], use τ },
    { split,
      { intro hamk,
        use [(sinz_amo_tau (lit₁ :: lit₂ :: ls) g τ), sinz_amo_eval_tt_under_sinz_amo_tau hdis τ hamk],
        intros v hv, rw [sinz_amo_tau, aite_pos hv] },
      { rintros ⟨σ, hs, hagree_on⟩,
        rw amo_eval_tt_iff_distinct_eval_ff_of_eval_tt,
        rintros lit₁ lit₂ ⟨i, j, hi, hj, hij, rfl, rfl⟩ hl₁,
        rw nth_eval_eq_of_agree_on hj hagree_on,
        have hi' := lt_of_lt_of_le hij (le_pred_of_lt hj),
        have hl₁' := nth_eval_eq_of_agree_on hi hagree_on,
        rw hl₁ at hl₁',
        have := signal_eval_tt_if_xi_eval_tt hi' hs hl₁'.symm,
        exact nth_eval_ff_of_signal_eval_tt hi' hs this ⟨hij, hj⟩ } } }
end

-- Alernative proof of reverse direction using the amk semantics directly
/-

theorem signal_semantics₁ : (sinz_amo l g).1.eval τ = tt →
  ∀ ⦃i : nat⦄, i < length l - 1 → τ (g.nth i) = ff → (amk 0).eval τ (l.take (i + 1)) = tt :=
begin
  cases l with lit₁ ls, { simp },
  cases ls with lit₂ ls, { simp },
  intros heval i hi htau,
  rw eval_tt_iff_forall_clause_eval_tt at heval,
  induction i with i ih,
  { have : 0 < (lit₁ :: lit₂ :: ls).length, { simp },
    have := heval _ (xi_to_si_mem_sinz_amo g hi this),
    simp [literal.eval, eval_flip, htau] at this,
    simp [this] },
  { cases htau' : τ (g.nth i),
    { have hi' : i + 1 < (lit₁ :: lit₂ :: ls).length,
      { simp at hi |-, exact lt_of_succ_lt hi },
      cases hlit : ((lit₁ :: lit₂ :: ls).nth_le _ hi').eval τ,
      { rw [amk.eval_take_tail_neg hlit, take],
        simp at ih hi,
        exact ih (lt_of_succ_lt hi) htau' },
      { have := heval _ (xi_to_si_mem_sinz_amo g hi hi'),
        rw nth_le at hlit,
        simp [literal.eval, eval_flip, htau, hlit] at this,
        contradiction } },
    { have : i < (lit₁ :: lit₂ :: ls).length - 2,
      { simp at hi |-, exact succ_lt_succ_iff.mp hi },
      have := heval _ (si_to_next_si_mem g this),
      simp [literal.eval, htau, htau'] at this,
      contradiction } }
end

theorem signal_semantics₂ : (sinz_amo l g).1.eval τ = tt →
  ∀ ⦃i : nat⦄, i < length l - 1 → τ (g.nth i) = tt → (amk 1).eval τ (l.take (i + 1)) = tt :=
begin
  cases l with lit₁ ls, { simp },
  cases ls with lit₂ ls, { simp },
  intros heval i hi htau,
  have heval_copy := heval,
  rw eval_tt_iff_forall_clause_eval_tt at heval,
  induction i with i ih,
  { simp },
  { have hi' : i < (lit₁ :: lit₂ :: ls).length - 1,
    { simp at hi |-, exact lt_of_succ_lt hi },
    have hi'' : (i + 1) < (lit₁ :: lit₂ :: ls).length,
    { simp at hi |-, exact lt_of_succ_lt hi },
    cases htau' : τ (g.nth i),
    { have := signal_semantics₁ heval_copy hi' htau',
      cases hlit : ((lit₁ :: lit₂ :: ls).nth_le _ hi'').eval τ,
      { rw amk.eval_take_tail_neg hlit,
        exact amk.eval_tt_of_le_of_eval_tt (zero_le 1) this },
      { rw amk.eval_take_tail_pos hlit,
        exact this } },
    { have := heval _ (si_to_next_xi_mem g hi''),
      simp [literal.eval, eval_flip, htau', -nth_le] at this,
      rw amk.eval_take_tail_neg this,
      exact ih hi' htau' } }
end

...
{ rintro ⟨σ, hs, hagree_on⟩,
  rw amk.eval_eq_of_agree_on 1 hagree_on,
  have hlen : length (lit₁ :: lit₂ :: ls) - 2 < length (lit₁ :: lit₂ :: ls) - 1, { simp },
  have hlen' : length (lit₁ :: lit₂ :: ls) - 1 < length (lit₁ :: lit₂ :: ls), { simp },
  have htake : (lit₁ :: lit₂ :: ls).take (length (lit₁ :: lit₂ :: ls)) = (lit₁ :: lit₂ :: ls),
  { simp only [take, take_length, eq_self_iff_true, and_self] },
  have hadd_sub : (lit₁ :: lit₂ :: ls).length = (lit₁ :: lit₂ :: ls).length - 1 + 1, { simp },
  cases hsig : σ (g.nth (length (lit₁ :: lit₂ :: ls) - 2)),
  { rw [← htake, hadd_sub],
    have hsigsem := signal_semantics₁ hs hlen hsig,
    cases hlit : ((lit₁ :: lit₂ :: ls).nth_le _ hlen').eval σ,
    { rw amk.eval_take_tail_neg hlit,
      exact amk.eval_tt_of_le_of_eval_tt (zero_le 1) hsigsem },
    { rw amk.eval_take_tail_pos hlit,
      exact hsigsem } },
  { rw [← htake, hadd_sub],
    have hsigsem := signal_semantics₂ hs hlen hsig,
    cases hlit : ((lit₁ :: lit₂ :: ls).nth_le _ hlen').eval σ,
    { rw amk.eval_take_tail_neg hlit,
      exact hsigsem },
    { have := eval_tt_iff_forall_clause_eval_tt.mp hs _ (si_to_next_xi_mem g hlen'),
      simp at hsig hlit,
      simp [literal.eval, eval_flip, hsig, hlit] at this,
      contradiction } }
-/

theorem sinz_amo_encodes_amo : encodes (amk 1) (sinz_amo : enc_fn V) :=
⟨sinz_amo_formula_encodes, sinz_amo_is_wb⟩

-- The version easier for theorem proving
def sinz_amo_rec : enc_fn V
| []                   g := ⟨[], g⟩
| [lit₁]               g := ⟨[], g⟩
| [lit₁, lit₂]         g := ⟨[[lit₁.flip, Pos g.fresh.1], [Neg g.fresh.1, lit₂.flip]], g.fresh.2⟩
| (lit₁ :: lit₂ :: ls) g :=
  ⟨[[lit₁.flip, Pos g.fresh.1], [Neg g.fresh.1, Pos g.fresh.2.fresh.1], [Neg g.fresh.1, lit₂.flip]] ++
   (sinz_amo_rec (lit₂ :: ls) g.fresh.2).1,
   (sinz_amo_rec (lit₂ :: ls) g.fresh.2).2⟩

-- A nicer looking and more efficient presentation of the Sinz encoding
def sinz_amo_rec' : enc_fn V
| []                   g := ⟨[], g⟩
| [lit₁]               g := ⟨[], g⟩
| [lit₁, lit₂]         g :=
    let ⟨y, g₁⟩ := g.fresh in
    ⟨[[lit₁.flip, Pos y], [Neg y, lit₂.flip]], g₁⟩
| (lit₁ :: lit₂ :: ls) g :=
    let ⟨y, g₁⟩ := g.fresh in
    let ⟨z, _⟩ := g₁.fresh in
    let ⟨F_rec, g₂⟩ := sinz_amo_rec' (lit₂ :: ls) g₁ in
    ⟨[[lit₁.flip, Pos y], [Neg y, Pos z], [Neg y, lit₂.flip]] ++ F_rec, g₂⟩

-- The two definitions of the Sinz encoding are equivalent on all inputs
theorem sinz_amo_rec_eq_sinz_amo_rec' : ∀ (l : list (literal V)) (g : gensym V),
  sinz_amo_rec l g = sinz_amo_rec' l g :=
begin
  intros l g,
  induction l with lit₁ ls ih generalizing g,
  { refl },
  { cases ls with lit₂ ls,
    { refl },
    { cases ls with lit₃ ls,
      { simp [sinz_amo_rec, sinz_amo_rec'], unfold fresh, refl },
      { rw [sinz_amo_rec, sinz_amo_rec'],
        rw [prod.ext_self g.fresh, sinz_amo_rec'._match_4,
            prod.ext_self g.fresh.2.fresh, sinz_amo_rec'._match_3,
            ← ih, prod.ext_self (sinz_amo_rec _ _)],
        rw sinz_amo_rec'._match_2 } } }
end

theorem sinz_amo_rec_is_wb : is_wb (sinz_amo_rec : enc_fn V) :=
begin
  intros l g hdis,
  induction l with lit₁ ls ih generalizing g,
  { simp [sinz_amo_rec] },
  { cases ls with lit₂ ls,
    { simp [sinz_amo_rec] },
    { cases ls with lit₃ ls,
      { simp [sinz_amo_rec, cnf.vars, var, flip_var_eq],
        split,
        { exact fresh_stock_subset g },
        { intros v hv,
          simp only [set.mem_insert_iff, set.mem_singleton_iff] at hv,
          rcases hv with (rfl | rfl | rfl),
          { apply set.mem_union_left, simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
          { apply set.mem_union_left, simp only [set.mem_insert_iff, eq_self_iff_true, true_or] },
          { apply set.mem_union_right,
            exact ⟨fresh_mem_stock g, fresh_not_mem_fresh_stock g⟩ } } },
      { rw sinz_amo_rec,
        simp [cnf.vars, var, flip_var_eq],
        have ihred := ih (disj_fresh_cons hdis),
        split,
        { exact subset_trans ihred.1 (fresh_stock_subset g) },
        { intros v hv,
          simp only [set.mem_insert_iff, finset.mem_coe] at hv,
          rcases hv with (rfl | rfl | rfl | rfl | hv),
          { apply set.mem_union_left, simp only [set.mem_insert_iff, eq_self_iff_true, true_or] },
          { apply set.mem_union_right, split,
            { exact fresh_fresh_mem_stock g },
            { intro hcon,
              have : g.fresh.2.fresh.1 ∈ (sinz_amo_rec (lit₂ :: lit₃ :: ls) g.fresh.2).1.vars,
              { cases ls with lit₄ ls; { rw sinz_amo_rec, simp [cnf.vars, var] } },
              rcases (set.mem_union _ _ _).mp (ihred.2 this) with (hv | hv),
              { exact (disj_left.mp (disj_of_disj_cons hdis) hv) (fresh_fresh_mem_stock g) },
              { exact hv.2 hcon } } },
          { apply set.mem_union_right,
            exact ⟨fresh_mem_stock g, not_mem_subset (fresh_not_mem_fresh_stock g) ihred.1⟩ },
          { apply set.mem_union_left,
            simp only [set.mem_insert_iff, eq_self_iff_true, true_or, or_true] },
          { rcases (set.mem_union _ _ _).mp (ihred.2 hv) with (hv | hv),
            { apply set.mem_union_left,
              simp at hv,
              rcases hv with (rfl | rfl | hv),
              { simp only [set.mem_insert_iff, eq_self_iff_true, true_or, or_true] },
              { simp only [set.mem_insert_iff, eq_self_iff_true, true_or, or_true] },
              { simp only [hv, set.mem_insert_iff, finset.mem_coe, or_true] } },
            { apply set.mem_union_right,
              exact ⟨(fresh_stock_subset g) hv.1, hv.2⟩ } } } } } }
end

theorem sinz_amo_rec_amz {l} {g} (hdis : disj l g) : (amk 0).eval τ l = tt →
  (sinz_amo_rec l g).1.eval (aite (clause.vars l) τ all_tt) = tt :=
begin
  induction l with lit₁ ls ih generalizing g,
  { simp [sinz_amo_rec] },
  { cases ls with lit₂ ls,
    { simp [sinz_amo_rec] },
    { intro hamk,
      have h₁ : lit₁ ∈ lit₁ :: lit₂ :: ls, { exact mem_cons_self _ _ },
      have h₂ : lit₂ ∈ lit₁ :: lit₂ :: ls, { exact mem_cons_of_mem _ (mem_cons_self _ _) },
      cases ls with lit₃ ls,
      { simp [sinz_amo_rec, eval_flip, literal.eval, -clause.vars_cons,
          aite_pos_lit (mem_vars_of_mem h₁),
          aite_pos_lit (mem_vars_of_mem h₂),
          (amz_eval_tt_iff_forall_eval_ff.mp hamk) h₁,
          (amz_eval_tt_iff_forall_eval_ff.mp hamk) h₂] },
      { rw sinz_amo_rec,
        simp [eval_flip, literal.eval, -clause.vars_cons,
          aite_pos_lit (mem_vars_of_mem h₁),
          aite_pos_lit (mem_vars_of_mem h₂),
          aite_neg (disj_right.mp hdis (fresh_mem_stock g)),
          aite_neg (disj_right.mp hdis (fresh_fresh_mem_stock g)),
          (amz_eval_tt_iff_forall_eval_ff.mp hamk) h₁,
          (amz_eval_tt_iff_forall_eval_ff.mp hamk) h₂,
          all_tt_eval_tt],
        have ihred := ih (disj_fresh_cons hdis) (amz_of_amz_cons hamk),
        by_cases hlit₁ : lit₁.var ∈ clause.vars (lit₂ :: lit₃ :: ls),
        { rw vars_cons_of_mem hlit₁, exact ihred },
        { rw ← ihred,
          apply cnf.eval_eq_of_agree_on,
          intros v hv,
          rcases (set.mem_union _ _ _).mp
            ((sinz_amo_rec_is_wb (disj_fresh_cons hdis)).2 hv) with (hv | hv),
          { rw [aite_pos hv, aite_pos (clause.mem_vars_cons_of_mem_vars _ hv)] },
          { rw [aite_neg (disj_right.mp (disj_fresh_cons hdis) hv.1),
                aite_neg (disj_right.mp (disj_fresh_of_disj hdis) hv.1)] } } } } }
end

theorem sinz_amo_rec_amo {l} {g} (hdis : disj l g) :
  (sinz_amo_rec l g).1.eval τ = tt ∧ τ g.fresh.1 = tt → (amk 0).eval τ l.tail = tt :=
begin
  induction l with lit₁ ls ih generalizing g,
  { simp [sinz_amo_rec], },
  { cases ls with lit₂ ls,
    { simp [sinz_amo_rec] },
    { rintro ⟨heval, hfresh⟩,
      cases ls with lit₃ ls,
      { simp [sinz_amo_rec, hfresh, eval_flip, literal.eval] at heval,
        rw [tail, amk.eval_cons_neg heval, amk.eval_nil] },
      { rw sinz_amo_rec at heval,
        simp [hfresh, eval_flip, literal.eval] at heval,
        rcases heval with ⟨h₁, h₂, h₃⟩,
        rw [tail, amk.eval_cons_neg h₂],
        exact ih (disj_fresh_of_disj (disj_of_disj_cons hdis)) ⟨h₃, h₁⟩ } } }
end

theorem sinz_amo_rec_encodes : encodes (amk 1) (sinz_amo_rec : enc_fn V) :=
begin
  split,
  { intros l g hdis τ,
    induction l with lit₁ ls ih generalizing g,
    { simp [sinz_amo_rec] },
    { cases ls with lit₂ ls,
      { simp [sinz_amo_rec], use τ },
      { split,
        { intro hamk,
          have h₁ : lit₁ ∈ lit₁ :: lit₂ :: ls, { exact mem_cons_self _ _ },
          have h₂ : lit₂ ∈ lit₁ :: lit₂ :: ls, { exact mem_cons_of_mem _ (mem_cons_self _ _) },
          cases hlit₁ : lit₁.eval τ,
          { rw amk.eval_cons_neg hlit₁ at hamk,
            rcases (ih (disj_fresh_cons hdis)).mp hamk with ⟨σ, heval, hs⟩,
            have hnmem : g.fresh.1 ∉ (sinz_amo_rec (lit₂ :: ls) g.fresh.2).1.vars,
            { apply not_mem_form_of_is_wb sinz_amo_rec_is_wb (disj_fresh_cons hdis),
              intro hcon, rcases (set.mem_union _ _ _).mp hcon with (hv | hv),
              { exact (disj_right.mp (disj_of_disj_cons hdis) (fresh_mem_stock g)) hv },
              { exact (fresh_not_mem_fresh_stock g) hv } },
            rcases exists_agree_on_and_eq_of_not_mem σ ff hnmem with ⟨σ₂, hs₂, hfresh⟩,
            use aite (clause.vars (lit₁ :: lit₂ :: ls)) τ σ₂,
            split,
            { cases ls with lit₃ ls;
              simp [sinz_amo_rec, eval_flip, literal.eval, -clause.vars_cons,
                aite_pos_lit (mem_vars_of_mem h₁), hlit₁,
                aite_neg (disj_right.mp hdis (fresh_mem_stock g)), hfresh],
              have : agree_on (aite (clause.vars (lit₁ :: lit₂ :: lit₃ :: ls)) τ σ₂) σ₂ (sinz_amo_rec (lit₂ :: lit₃ :: ls) g.fresh.2).1.vars,
              { intros v hv,
                rcases mem_vars_or_stock_of_is_wb_of_mem sinz_amo_rec_is_wb (disj_fresh_cons hdis) hv with (h | h),
                { rw aite_pos (clause.mem_vars_cons_of_mem_vars _ h),
                  exact (hs _ h).symm ▸ (hs₂ _ hv) },
                { rw aite_neg (disj_right.mp (disj_fresh_of_disj hdis) h) } },
              rw [eval_eq_of_agree_on this, ← eval_eq_of_agree_on hs₂], exact heval },
            { intros v hv, rw aite_pos hv } },
          { rw amk.eval_cons_pos hlit₁ at hamk,
            use [aite (clause.vars (lit₁ :: lit₂ :: ls)) τ all_tt],
            split,
            { cases ls with lit₃ ls;
              simp [sinz_amo_rec, eval_flip, literal.eval, -clause.vars_cons,
                aite_pos_lit (mem_vars_of_mem h₁), hlit₁,
                aite_pos_lit (mem_vars_of_mem h₂),
                aite_neg (disj_right.mp hdis (fresh_mem_stock g)),
                aite_neg (disj_right.mp hdis (fresh_fresh_mem_stock g)), all_tt_eval_tt],
              { exact (amz_eval_tt_iff_forall_eval_ff.mp hamk) (mem_cons_self _ _) },
              { split,
                { exact (amz_eval_tt_iff_forall_eval_ff.mp hamk) (mem_cons_self _ _) },
                { rw [← sinz_amo_rec_amz (disj_fresh_of_disj (disj_of_disj_cons hdis)) hamk, cnf.eval_eq_of_agree_on],
                  intros v hv,
                  rcases mem_vars_or_stock_of_is_wb_of_mem sinz_amo_rec_is_wb (disj_fresh_cons hdis) hv with (h | h),
                  { rw [aite_pos h, aite_pos (clause.mem_vars_cons_of_mem_vars _ h)] },
                  { rw [aite_neg (disj_right.mp (disj_fresh_of_disj hdis) h),
                        aite_neg (disj_right.mp (disj_fresh_cons hdis) h)] } } } },
            { intros v hv, rw aite_pos hv } } },
        { rintros ⟨σ, heval, hs⟩,
          have hlit₁' := eval_eq_of_agree_on_of_var_mem hs (mem_vars_of_mem (mem_cons_self _ _)),
          cases hlit₁ : lit₁.eval σ,
          { rw hlit₁ at hlit₁',
            rw amk.eval_cons_neg hlit₁',
            cases ls with lit₃ ls,
            { simp [sinz_amo_rec, literal.eval, eval_flip, hlit₁] at heval,
              exact eval_singleton_pos 0 τ lit₂ },
            { rw sinz_amo_rec at heval,
              simp [literal.eval, eval_flip, hlit₁] at heval,
              exact (ih (disj_fresh_cons hdis)).mpr ⟨σ, heval.2.2, (agree_on_of_agree_on_vars_cons hs)⟩ } },
          { rw hlit₁ at hlit₁',
            rw amk.eval_cons_pos hlit₁',
            cases ls with lit₃ ls,
            { simp [sinz_amo_rec, literal.eval, eval_flip, hlit₁] at heval,
              rcases heval with ⟨he₁, (he₂ | he₂)⟩,
              { rw he₁ at he₂, contradiction },
              { rw ← (eval_eq_of_agree_on_of_var_mem hs
                  (mem_vars_cons_of_mem_vars _ (mem_vars_of_mem (mem_cons_self _ _)))) at he₂,
                rw [amk.eval_cons_neg he₂ 0 [], amk.eval_nil 0 τ] } },
            { have heval_copy := heval,
              rw sinz_amo_rec at heval,
              simp [literal.eval, eval_flip, hlit₁] at heval,
              rw amk.eval_eq_of_agree_on 0 (agree_on_of_agree_on_vars_cons hs),
              exact sinz_amo_rec_amo hdis ⟨heval_copy, heval.1⟩ } } } } } },
  { exact sinz_amo_rec_is_wb }
end

end sinz_amo


import formula

variable {vars : Type}

/- The soundness and completeness theorems are always proven with respect to a
particular proof system. In this file we define the natural deduction proof
system as an inductive type and prove the syntactic compactness theorem.
-/

/-- Gentzen-style (Proof Tree) Natural Deduction -/
inductive Deriv : set (Form vars) → Form vars → Prop
| Bottom_E  : ∀ {Γ : set (Form vars)} {A : Form vars},
              Deriv Γ ⊥ → Deriv Γ A
| Ax        : ∀ {Γ : set (Form vars)} {A : Form vars},
              A ∈ Γ → Deriv Γ A
| Not_I     : ∀ {Γ : set (Form vars)} {A : Form vars},
              Deriv (insert A Γ) ⊥ → Deriv Γ (~ A)
| Not_E     : ∀ {Γ : set (Form vars)} {A : Form vars},
              Deriv Γ (~ A) → Deriv Γ A → Deriv Γ ⊥
| And_I     : ∀ {Γ : set (Form vars)} {A B : Form vars},
              Deriv Γ A → Deriv Γ B → Deriv Γ (A ⋀ B)
| And_E_1   : ∀ {Γ : set (Form vars)} {A B : Form vars},
              Deriv Γ (A ⋀ B) → Deriv Γ A
| And_E_2   : ∀ {Γ : set (Form vars)} {A B : Form vars},
              Deriv Γ (A ⋀ B) → Deriv Γ B
| Or_I_1    : ∀ {Γ : set (Form vars)} {A B : Form vars},
              Deriv Γ A → Deriv Γ (A ⋁ B)
| Or_I_2    : ∀ {Γ : set (Form vars)} {A B : Form vars},
              Deriv Γ B → Deriv Γ (A ⋁ B)
| Or_E      : ∀ {Γ : set (Form vars)} {A B C : Form vars},
              Deriv Γ (A ⋁ B) → Deriv (insert A Γ) C → Deriv (insert B Γ) C
              → Deriv Γ C
| Contra    : ∀ {Γ : set (Form vars)} {A : Form vars},
              Deriv (insert (~ A) Γ) ⊥ → Deriv Γ A
-- This is an admissible rule (we can prove it from the others), but its easier
-- to just add it as most of the inductive cases are easy to prove for this rule
-- and its helpful in many situations.
| Weakening : ∀ {Γ Δ : set (Form vars)} {A : Form vars},
              (Γ ⊆ Δ) → (Deriv Γ A) → (Deriv Δ A)

open Deriv

notation Γ ` ⊩ ` A := Deriv Γ A
notation Γ ` ⊮ ` A := ¬ Deriv Γ A

/-- Γ is consistent if it cannnot derive ⊥.-/
def consistent   (Γ : set (Form vars)) : Prop := Γ ⊮ ⊥
/-- Γ is inconsistent if it can derive ⊥.-/
def inconsistent (Γ : set (Form vars)) : Prop := Γ ⊩ ⊥

/-- An example derivation:
(Ax) ---------  --------- (Ax)
     A, B ⊩ A   A, B ⊩ B
    --------------------- (⋀I)
         A, B ⊩ A ⋀ B
-/
example {A B : Form vars} : {A, B} ⊩ (A ⋀ B) :=
begin
  apply Deriv.And_I,
  {
    apply Deriv.Ax,
    simp,
  },
  {
    apply Deriv.Ax,
    simp
  }
end

/-- The following syntactic compactness theorem states that if Γ ⊩ A,
then A can be derived from a finite subset of Γ. This is intuitively obvious
because a derivation is a finite structure so it must only use finitely many
assumptions from Γ because there can only be finite occurences of the Ax rule.
Regardless we have to construct such a finite subset explicitly for a formal
proof. -/
theorem deriv_compactness
{Γ : set (Form vars)} {A} (h : Γ ⊩ A)
  : ∃ Δ, Δ ⊆ Γ ∧ Δ.finite ∧ (Δ ⊩ A) :=
begin
  induction h,
  -- the proof inductively constructs a Δ containing only the assumptions that
  -- are actually used in the derivation. Most cases are trivial because we can
  -- just use the same set given by the IH. The exception are rules Not_I, Or_E
  -- and Contra where the premise(s) add new assumptions. For these rules, we
  -- have to remove the added assumptions from the set given in the ih and
  -- prove that this new set satisfies the requirements.
  case Deriv.Bottom_E : Γ A _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hbot⟩,
    use Δ, use hsub, use hfin,
    use Deriv.Bottom_E hbot,
  },
  case Deriv.Ax : Γ A h {
    refine ⟨{A}, _, _, _⟩,
    { simp, use h },
    { simp },
    { apply Deriv.Ax, simp }
  },
  case Deriv.Not_I : Γ A _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hbot⟩,
    use Δ \ {A}, -- remove the assumption added by the Not_I rule
    refine ⟨_, _, _⟩,
    { simp, exact hsub },
    { exact set.finite.subset hfin (set.diff_subset Δ {A}) },
    { apply Deriv.Not_I, simp, exact Deriv.Weakening (by simp : Δ ⊆ insert A Δ) hbot }
  },
  case Deriv.Not_E : Γ A _ _ ihnA ihA {
    rcases ihnA with ⟨ΓnA, hnAsub, hnAfin, hnA⟩,
    rcases ihA with ⟨ΓA, hAsub, hAfin, hA⟩,
    refine ⟨ΓnA ∪ ΓA, _, _, _⟩,
    { simp [hnAsub, hAsub] },
    { simp [hnAfin, hAfin] },
    { apply Deriv.Not_E,
      exact Deriv.Weakening (by simp) hnA,
      exact Deriv.Weakening (by simp) hA },
  },
  case Deriv.And_I : Γ A B _ _ ihA ihB {
    rcases ihA with ⟨ΓA, hAsub, hAfin, hA⟩,
    rcases ihB with ⟨ΓB, hBsub, hBfin, hB⟩,
    refine ⟨ΓA ∪ ΓB, _, _, _⟩,
    { simp [hAsub, hBsub] },
    { simp [hAfin, hBfin] },
    { apply Deriv.And_I,
      exact Deriv.Weakening (by simp) hA,
      exact Deriv.Weakening (by simp) hB },
  },
  case Deriv.And_E_1 : Γ A B _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hA⟩,
    exact ⟨Δ, hsub, hfin, Deriv.And_E_1 hA⟩
  },
  case Deriv.And_E_2 : Γ A B _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hB⟩,
    exact ⟨Δ, hsub, hfin, Deriv.And_E_2 hB⟩
  },
  case Deriv.Or_I_1 : Γ A B _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hA⟩,
    exact ⟨Δ, hsub, hfin, Deriv.Or_I_1 hA⟩
  },
  case Deriv.Or_I_2 : Γ A B _ ih {
    rcases ih with ⟨Δ, hsub, hfin, hB⟩,
    exact ⟨Δ, hsub, hfin, Deriv.Or_I_2 hB⟩
  },
  case Deriv.Or_E : Γ A B C _ _ _ ihAB ihAC ihBC {
    rcases ihAB with ⟨ΓAB, hABsub, hABfin, hAB⟩,
    rcases ihAC with ⟨ΓAC, hACsub, hACfin, hAC⟩,
    rcases ihBC with ⟨ΓBC, hBCsub, hBCfin, hBC⟩,
    -- all the assumptions used except for the ones added by the Or_E rule.
    use ΓAB ∪ ((ΓAC \ {A}) ∪ (ΓBC \ {B})),
    refine ⟨_, _, _⟩,
    { simp, exact ⟨hABsub, hACsub, hBCsub⟩ },
    { simp,
      exact ⟨hABfin,
             set.finite.subset hACfin (set.diff_subset ΓAC {A}),
             set.finite.subset hBCfin (set.diff_subset ΓBC {B})⟩ },
    { apply Deriv.Or_E,
      { exact Deriv.Weakening (set.subset_union_left _ _) hAB },
      { rw [←set.union_insert, ←set.insert_union, set.insert_diff_singleton],
        refine Deriv.Weakening _ hAC,
        apply set.subset_union_of_subset_right,
        apply set.subset_union_of_subset_left,
        exact set.subset_insert A ΓAC },
      { rw [←set.union_insert, ←set.union_insert, set.insert_diff_singleton],
        refine Deriv.Weakening _ hBC,
        apply set.subset_union_of_subset_right,
        apply set.subset_union_of_subset_right,
        exact set.subset_insert B ΓBC }
    }
  },
  case Deriv.Contra : Γ A _ ih {
    -- this case is similar to Not_I
    rcases ih with ⟨Δ, hsub, hfin, hbot⟩,
    use Δ \ {~ A},
    refine ⟨_, _, _⟩,
    { simp, exact hsub },
    { exact set.finite.subset hfin (set.diff_subset Δ {~ A}) },
    { apply Deriv.Contra,
      simp,
      exact Deriv.Weakening (by simp : Δ ⊆ insert (~ A) Δ) hbot }
  },
  case Deriv.Weakening : Γ SΓ A hsub _ ih {
    rcases ih with ⟨Δ, hsub', hfin, hA⟩,
    exact ⟨Δ, trans hsub' hsub, hfin, hA⟩
  }
end

/-- An alternative statement of the compactness theorem. -/
theorem deriv_compactness' {Γ : set (Form vars)}
  (hfincon : ∀ (Δ : set (Form vars)), Δ ⊆ Γ → Δ.finite → consistent Δ)
  : consistent Γ :=
begin
  -- this is just contrapositive of deriv_compactness
  have := mt deriv_compactness,
  simp at this,
  exact this hfincon,
end

#lint