import ConNF.Model.Hailperin

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

theorem ext (x y : TSet α) :
    (∀ z : TSet β, z ∈' x ↔ z ∈' y) → x = y :=
  tSet_ext' hβ x y

def inter (x y : TSet α) : TSet α :=
  (TSet.exists_inter hβ x y).choose

notation:69 x:69 " ⊓[" h "] " y:69 => _root_.ConNF.inter h x y
notation:69 x:69 " ⊓' " y:69 => x ⊓[by assumption] y

@[simp]
theorem mem_inter_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊓' y ↔ z ∈' x ∧ z ∈' y :=
  (TSet.exists_inter hβ x y).choose_spec

def compl (x : TSet α) : TSet α :=
  (TSet.exists_compl hβ x).choose

notation:1024 x:1024 " ᶜ[" h "]" => _root_.ConNF.compl h x
notation:1024 x:1024 " ᶜ'" => xᶜ[by assumption]

@[simp]
theorem mem_compl_iff (x : TSet α) :
    ∀ z : TSet β, z ∈' xᶜ' ↔ ¬z ∈' x :=
  (TSet.exists_compl hβ x).choose_spec

notation:1024 "{" x "}[" h "]" => _root_.ConNF.singleton h x
notation:1024 "{" x "}'" => {x}[by assumption]

@[simp]
theorem mem_singleton_iff (x y : TSet β) :
    y ∈' {x}' ↔ y = x :=
  typedMem_singleton_iff' hβ x y

notation:1024 "{" x ", " y "}[" h "]" => _root_.ConNF.TSet.up h x y
notation:1024 "{" x ", " y "}'" => {x, y}[by assumption]

@[simp]
theorem mem_up_iff (x y z : TSet β) :
    z ∈' {x, y}' ↔ z = x ∨ z = y :=
  TSet.mem_up_iff hβ x y z

notation:1024 "⟨" x ", " y "⟩[" h ", " h' "]" => _root_.ConNF.TSet.op h h' x y
notation:1024 "⟨" x ", " y "⟩'" => ⟨x, y⟩[by assumption, by assumption]

theorem op_def (x y : TSet γ) :
    (⟨x, y⟩' : TSet α) = { {x}', {x, y}' }' :=
  rfl

def singletonImage' (x : TSet β) : TSet α :=
  (TSet.exists_singletonImage hβ hγ hδ hε x).choose

@[simp]
theorem singletonImage'_spec (x : TSet β) :
    ∀ z w,
    ⟨ {z}', {w}' ⟩' ∈' singletonImage' hβ hγ hδ hε x ↔ ⟨z, w⟩' ∈' x

:=
  (TSet.exists_singletonImage hβ hγ hδ hε x).choose_spec


import ConNF.Model.Result

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

def union (x y : TSet α) : TSet α :=
  (xᶜ' ⊓' yᶜ')ᶜ'

notation:68 x:68 " ⊔[" h "] " y:68 => _root_.ConNF.union h x y
notation:68 x:68 " ⊔' " y:68 => x ⊔[by assumption] y

@[simp]
theorem mem_union_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊔' y ↔ z ∈' x ∨ z ∈' y := by
  rw [union]
  intro z
  rw [mem_compl_iff, mem_inter_iff, mem_compl_iff, mem_compl_iff, or_iff_not_and_not]

def higherIndex (α : Λ) : Λ :=
  (exists_gt α).choose

theorem lt_higherIndex {α : Λ} :
    (α : TypeIndex) < higherIndex α :=
  WithBot.coe_lt_coe.mpr (exists_gt α).choose_spec

theorem tSet_nonempty (h : ∃ β : Λ, (β : TypeIndex) < α) : Nonempty (TSet α) := by
  obtain ⟨α', hα⟩ := h
  constructor
  apply typeLower lt_higherIndex lt_higherIndex lt_higherIndex hα
  apply cardinalOne lt_higherIndex lt_higherIndex

def empty : TSet α :=
  (tSet_nonempty ⟨β, hβ⟩).some ⊓' (tSet_nonempty ⟨β, hβ⟩).someᶜ'

@[simp]
theorem mem_empty_iff :
    ∀ x : TSet β, ¬x ∈' empty hβ := by
  intro x
  rw [empty, mem_inter_iff, mem_compl_iff]
  exact and_not_self

def univ : TSet α :=
  (empty hβ)ᶜ'

@[simp]
theorem mem_univ_iff :
    ∀ x : TSet β, x ∈' univ hβ := by
  intro x
  simp only [univ, mem_compl_iff, mem_empty_iff, not_false_eq_true]

/-- The set of all ordered pairs. -/
def orderedPairs : TSet α :=
  vCross hβ hγ hδ (univ hδ)

@[simp]
theorem mem_orderedPairs_iff (x : TSet β) :
    x ∈' orderedPairs hβ hγ hδ ↔ ∃ a b, x = ⟨a, b⟩' := by
  simp only [orderedPairs, vCross_spec, mem_univ_iff, and_true]

def converse (x : TSet α) : TSet α :=
  converse' hβ hγ hδ x ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem op_mem_converse_iff (x : TSet α) :
    ∀ a b, ⟨a, b⟩' ∈' converse hβ hγ hδ x ↔ ⟨b, a⟩' ∈' x := by
  intro a b
  simp only [converse, mem_inter_iff, converse'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def cross (x y : TSet γ) : TSet α :=
  converse hβ hγ hδ (vCross hβ hγ hδ x) ⊓' vCross hβ hγ hδ y

@[simp]
theorem mem_cross_iff (x y : TSet γ) :
    ∀ a, a ∈' cross hβ hγ hδ x y ↔ ∃ b c, a = ⟨b, c⟩' ∧ b ∈' x ∧ c ∈' y := by
  intro a
  rw [cross, mem_inter_iff, vCross_spec]
  constructor
  · rintro ⟨h₁, b, c, rfl, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj] at h₁
    obtain ⟨b', c', ⟨rfl, rfl⟩, h₁⟩ := h₁
    exact ⟨b, c, rfl, h₁, h₂⟩
  · rintro ⟨b, c, rfl, h₁, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj]
    exact ⟨⟨c, b, ⟨rfl, rfl⟩, h₁⟩, ⟨b, c, ⟨rfl, rfl⟩, h₂⟩⟩

def singletonImage (x : TSet β) : TSet α :=
  singletonImage' hβ hγ hδ hε x ⊓' (cross hβ hγ hδ (cardinalOne hδ hε) (cardinalOne hδ hε))

@[simp]
theorem singletonImage_spec (x : TSet β) :
    ∀ z w,
    ⟨ {z}', {w}' ⟩' ∈' singletonImage hβ hγ hδ hε x ↔ ⟨z, w⟩' ∈' x := by
  intro z w
  rw [singletonImage, mem_inter_iff, singletonImage'_spec, and_iff_left_iff_imp]
  intro hzw
  rw [mem_cross_iff]
  refine ⟨{z}', {w}', rfl, ?_⟩
  simp only [mem_cardinalOne_iff, singleton_inj, exists_eq', and_self]

theorem exists_of_mem_singletonImage {x : TSet β} {z w : TSet δ}
    (h : ⟨z, w⟩' ∈' singletonImage hβ hγ hδ hε x) :
    ∃ a b, z = {a}' ∧ w = {b}' := by
  simp only [singletonImage, mem_inter_iff, mem_cross_iff, op_inj, mem_cardinalOne_iff] at h
  obtain ⟨-, _, _, ⟨rfl, rfl⟩, ⟨a, rfl⟩, ⟨b, rfl⟩⟩ := h
  exact ⟨a, b, rfl, rfl⟩

/-- Turn a model element encoding a relation into an actual relation. -/
def ExternalRel (r : TSet α) : Rel (TSet δ) (TSet δ) :=
  λ x y ↦ ⟨x, y⟩' ∈' r

@[simp]
theorem externalRel_converse (r : TSet α) :
    ExternalRel hβ hγ hδ (converse hβ hγ hδ r) = (ExternalRel hβ hγ hδ r).inv := by
  ext
  simp only [ExternalRel, op_mem_converse_iff, Rel.inv_apply]

/-- The codomain of a relation. -/
def codom (r : TSet α) : TSet γ :=
  (typeLower lt_higherIndex hβ hγ hδ (singletonImage lt_higherIndex hβ hγ hδ r)ᶜ[lt_higherIndex])ᶜ'

@[simp]
theorem mem_codom_iff (r : TSet α) (x : TSet δ) :
    x ∈' codom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).codom := by
  simp only [codom, mem_compl_iff, mem_typeLower_iff, not_forall, not_not]
  constructor
  · rintro ⟨y, hy⟩
    obtain ⟨a, b, rfl, hb⟩ := exists_of_mem_singletonImage lt_higherIndex hβ hγ hδ hy
    rw [singleton_inj] at hb
    subst hb
    rw [singletonImage_spec] at hy
    exact ⟨a, hy⟩
  · rintro ⟨a, ha⟩
    use {a}'
    rw [singletonImage_spec]
    exact ha

/-- The domain of a relation. -/
def dom (r : TSet α) : TSet γ :=
  codom hβ hγ hδ (converse hβ hγ hδ r)

@[simp]
theorem mem_dom_iff (r : TSet α) (x : TSet δ) :
    x ∈' dom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).dom := by
  rw [dom, mem_codom_iff, externalRel_converse, Rel.inv_codom]

/-- The field of a relation. -/
def field (r : TSet α) : TSet γ :=
  dom hβ hγ hδ r ⊔' codom hβ hγ hδ r

@[simp]
theorem mem_field_iff (r : TSet α) (x : TSet δ) :
    x ∈' field hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).field := by
  rw [field, mem_union_iff, mem_dom_iff, mem_codom_iff, Rel.field, Set.mem_union]

def subset : TSet α :=
  subset' hβ hγ hδ hε ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem subset_spec :
    ∀ a b, ⟨a, b⟩' ∈' subset hβ hγ hδ hε ↔ a ⊆[TSet ε] b := by
  intro a b
  simp only [subset, mem_inter_iff, subset'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def membership : TSet α :=
  subset hβ hγ hδ hε ⊓' cross hβ hγ hδ (cardinalOne hδ hε) (univ hδ)

@[simp]
theorem membership_spec :
    ∀ a b, ⟨{a}', b⟩' ∈' membership hβ hγ hδ hε ↔ a ∈' b := by
  intro a b
  rw [membership, mem_inter_iff, subset_spec]
  simp only [mem_cross_iff, op_inj, mem_cardinalOne_iff, mem_univ_iff, and_true, exists_and_right,
    exists_and_left, exists_eq', exists_eq_left', singleton_inj]
  constructor
  · intro h
    exact h a ((typedMem_singleton_iff' hε a a).mpr rfl)
  · intro h c hc
    simp only [typedMem_singleton_iff'] at hc
    cases hc
    exact h

def powerset (x : TSet β) : TSet α :=
  dom lt_higherIndex lt_higherIndex hβ
    (subset lt_higherIndex lt_higherIndex hβ hγ ⊓[lt_higherIndex]
      vCross lt_higherIndex lt_higherIndex hβ {x}')

@[simp]
theorem mem_powerset_iff (x y : TSet β) :
    x ∈' powerset hβ hγ y ↔ x ⊆[TSet γ] y

:= by
  rw [powerset, mem_dom_iff]
  constructor
  · rintro ⟨z, h⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, exists_and_right, exists_eq', true_and] at h
    cases h.2
    exact h.1
  · intro h
    refine ⟨y, ?_⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, h, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, and_true, exists_eq', and_self]


import ConNF.Model.TTT

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

namespace TSet

theorem exists_inter (x y : TSet α) :
    ∃ w : TSet α, ∀ z : TSet β, z ∈[hβ] w ↔ z ∈[hβ] x ∧ z ∈[hβ] y := by
  refine exists_of_symmetric {z | z ∈[hβ] x ∧ z ∈[hβ] y} hβ ?_
  obtain ⟨S, hS⟩ := symmetric x hβ
  obtain ⟨T, hT⟩ := symmetric y hβ
  use S + T
  intro ρ hρ
  specialize hS ρ (smul_eq_of_le Support.le_add_right hρ)
  specialize hT ρ (smul_eq_of_le Support.le_add_left hρ)
  simp [Set.ext_iff, Set.mem_smul_set_iff_inv_smul_mem] at hS hT ⊢
  aesop

theorem exists_compl (x : TSet α) :
    ∃ y : TSet α, ∀ z : TSet β, z ∈[hβ] y ↔ ¬z ∈[hβ] x := by
  refine exists_of_symmetric {z | ¬z ∈[hβ] x} hβ ?_
  obtain ⟨S, hS⟩ := symmetric x hβ
  use S
  intro ρ hρ
  specialize hS ρ hρ
  simp [Set.ext_iff, Set.mem_smul_set_iff_inv_smul_mem] at hS ⊢
  aesop

theorem exists_up (x y : TSet β) :
    ∃ w : TSet α, ∀ z : TSet β, z ∈[hβ] w ↔ z = x ∨ z = y

:= by
  refine exists_of_symmetric {x, y} hβ ?_
  obtain ⟨S, hS⟩ := exists_support x
  obtain ⟨T, hT⟩ := exists_support y
  use (S + T) ↗ hβ
  intro ρ hρ
  rw [Support.smul_scoderiv, Support.scoderiv_inj, ← allPermSderiv_forget'] at hρ
  specialize hS (ρ ↘ hβ) (smul_eq_of_le Support.le_add_right hρ)
  specialize hT (ρ ↘ hβ) (smul_eq_of_le Support.le_add_left hρ)
  simp only [Set.smul_set_def, Set.image, Set.mem_insert_iff, Set.mem_singleton_iff,
    exists_eq_or_imp, hS, exists_eq_left, hT]
  ext z
  rw [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_setOf_eq]
  aesop


import ConNF.Model.Result

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

def union (x y : TSet α) : TSet α :=
  (xᶜ' ⊓' yᶜ')ᶜ'

notation:68 x:68 " ⊔[" h "] " y:68 => _root_.ConNF.union h x y
notation:68 x:68 " ⊔' " y:68 => x ⊔[by assumption] y

@[simp]
theorem mem_union_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊔' y ↔ z ∈' x ∨ z ∈' y := by
  rw [union]
  intro z
  rw [mem_compl_iff, mem_inter_iff, mem_compl_iff, mem_compl_iff, or_iff_not_and_not]

def higherIndex (α : Λ) : Λ :=
  (exists_gt α).choose

theorem lt_higherIndex {α : Λ} :
    (α : TypeIndex) < higherIndex α :=
  WithBot.coe_lt_coe.mpr (exists_gt α).choose_spec

theorem tSet_nonempty (h : ∃ β : Λ, (β : TypeIndex) < α) : Nonempty (TSet α) := by
  obtain ⟨α', hα⟩ := h
  constructor
  apply typeLower lt_higherIndex lt_higherIndex lt_higherIndex hα
  apply cardinalOne lt_higherIndex lt_higherIndex

def empty : TSet α :=
  (tSet_nonempty ⟨β, hβ⟩).some ⊓' (tSet_nonempty ⟨β, hβ⟩).someᶜ'

@[simp]
theorem mem_empty_iff :
    ∀ x : TSet β, ¬x ∈' empty hβ := by
  intro x
  rw [empty, mem_inter_iff, mem_compl_iff]
  exact and_not_self

def univ : TSet α :=
  (empty hβ)ᶜ'

@[simp]
theorem mem_univ_iff :
    ∀ x : TSet β, x ∈' univ hβ := by
  intro x
  simp only [univ, mem_compl_iff, mem_empty_iff, not_false_eq_true]

/-- The set of all ordered pairs. -/
def orderedPairs : TSet α :=
  vCross hβ hγ hδ (univ hδ)

@[simp]
theorem mem_orderedPairs_iff (x : TSet β) :
    x ∈' orderedPairs hβ hγ hδ ↔ ∃ a b, x = ⟨a, b⟩' := by
  simp only [orderedPairs, vCross_spec, mem_univ_iff, and_true]

def converse (x : TSet α) : TSet α :=
  converse' hβ hγ hδ x ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem op_mem_converse_iff (x : TSet α) :
    ∀ a b, ⟨a, b⟩' ∈' converse hβ hγ hδ x ↔ ⟨b, a⟩' ∈' x := by
  intro a b
  simp only [converse, mem_inter_iff, converse'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def cross (x y : TSet γ) : TSet α :=
  converse hβ hγ hδ (vCross hβ hγ hδ x) ⊓' vCross hβ hγ hδ y

@[simp]
theorem mem_cross_iff (x y : TSet γ) :
    ∀ a, a ∈' cross hβ hγ hδ x y ↔ ∃ b c, a = ⟨b, c⟩' ∧ b ∈' x ∧ c ∈' y := by
  intro a
  rw [cross, mem_inter_iff, vCross_spec]
  constructor
  · rintro ⟨h₁, b, c, rfl, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj] at h₁
    obtain ⟨b', c', ⟨rfl, rfl⟩, h₁⟩ := h₁
    exact ⟨b, c, rfl, h₁, h₂⟩
  · rintro ⟨b, c, rfl, h₁, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj]
    exact ⟨⟨c, b, ⟨rfl, rfl⟩, h₁⟩, ⟨b, c, ⟨rfl, rfl⟩, h₂⟩⟩

def singletonImage (x : TSet β) : TSet α :=
  singletonImage' hβ hγ hδ hε x ⊓' (cross hβ hγ hδ (cardinalOne hδ hε) (cardinalOne hδ hε))

@[simp]
theorem singletonImage_spec (x : TSet β) :
    ∀ z w,
    ⟨ {z}', {w}' ⟩' ∈' singletonImage hβ hγ hδ hε x ↔ ⟨z, w⟩' ∈' x := by
  intro z w
  rw [singletonImage, mem_inter_iff, singletonImage'_spec, and_iff_left_iff_imp]
  intro hzw
  rw [mem_cross_iff]
  refine ⟨{z}', {w}', rfl, ?_⟩
  simp only [mem_cardinalOne_iff, singleton_inj, exists_eq', and_self]

theorem exists_of_mem_singletonImage {x : TSet β} {z w : TSet δ}
    (h : ⟨z, w⟩' ∈' singletonImage hβ hγ hδ hε x) :
    ∃ a b, z = {a}' ∧ w = {b}' := by
  simp only [singletonImage, mem_inter_iff, mem_cross_iff, op_inj, mem_cardinalOne_iff] at h
  obtain ⟨-, _, _, ⟨rfl, rfl⟩, ⟨a, rfl⟩, ⟨b, rfl⟩⟩ := h
  exact ⟨a, b, rfl, rfl⟩

/-- Turn a model element encoding a relation into an actual relation. -/
def ExternalRel (r : TSet α) : Rel (TSet δ) (TSet δ) :=
  λ x y ↦ ⟨x, y⟩' ∈' r

@[simp]
theorem externalRel_converse (r : TSet α) :
    ExternalRel hβ hγ hδ (converse hβ hγ hδ r) = (ExternalRel hβ hγ hδ r).inv := by
  ext
  simp only [ExternalRel, op_mem_converse_iff, Rel.inv_apply]

/-- The codomain of a relation. -/
def codom (r : TSet α) : TSet γ :=
  (typeLower lt_higherIndex hβ hγ hδ (singletonImage lt_higherIndex hβ hγ hδ r)ᶜ[lt_higherIndex])ᶜ'

@[simp]
theorem mem_codom_iff (r : TSet α) (x : TSet δ) :
    x ∈' codom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).codom := by
  simp only [codom, mem_compl_iff, mem_typeLower_iff, not_forall, not_not]
  constructor
  · rintro ⟨y, hy⟩
    obtain ⟨a, b, rfl, hb⟩ := exists_of_mem_singletonImage lt_higherIndex hβ hγ hδ hy
    rw [singleton_inj] at hb
    subst hb
    rw [singletonImage_spec] at hy
    exact ⟨a, hy⟩
  · rintro ⟨a, ha⟩
    use {a}'
    rw [singletonImage_spec]
    exact ha

/-- The domain of a relation. -/
def dom (r : TSet α) : TSet γ :=
  codom hβ hγ hδ (converse hβ hγ hδ r)

@[simp]
theorem mem_dom_iff (r : TSet α) (x : TSet δ) :
    x ∈' dom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).dom := by
  rw [dom, mem_codom_iff, externalRel_converse, Rel.inv_codom]

/-- The field of a relation. -/
def field (r : TSet α) : TSet γ :=
  dom hβ hγ hδ r ⊔' codom hβ hγ hδ r

@[simp]
theorem mem_field_iff (r : TSet α) (x : TSet δ) :
    x ∈' field hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).field := by
  rw [field, mem_union_iff, mem_dom_iff, mem_codom_iff, Rel.field, Set.mem_union]

def subset : TSet α :=
  subset' hβ hγ hδ hε ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem subset_spec :
    ∀ a b, ⟨a, b⟩' ∈' subset hβ hγ hδ hε ↔ a ⊆[TSet ε] b := by
  intro a b
  simp only [subset, mem_inter_iff, subset'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def membership : TSet α :=
  subset hβ hγ hδ hε ⊓' cross hβ hγ hδ (cardinalOne hδ hε) (univ hδ)

@[simp]
theorem membership_spec :
    ∀ a b, ⟨{a}', b⟩' ∈' membership hβ hγ hδ hε ↔ a ∈' b := by
  intro a b
  rw [membership, mem_inter_iff, subset_spec]
  simp only [mem_cross_iff, op_inj, mem_cardinalOne_iff, mem_univ_iff, and_true, exists_and_right,
    exists_and_left, exists_eq', exists_eq_left', singleton_inj]
  constructor
  · intro h
    exact h a ((typedMem_singleton_iff' hε a a).mpr rfl)
  · intro h c hc
    simp only [typedMem_singleton_iff'] at hc
    cases hc
    exact h

def powerset (x : TSet β) : TSet α :=
  dom lt_higherIndex lt_higherIndex hβ
    (subset lt_higherIndex lt_higherIndex hβ hγ ⊓[lt_higherIndex]
      vCross lt_higherIndex lt_higherIndex hβ {x}')

@[simp]
theorem mem_powerset_iff (x y : TSet β) :
    x ∈' powerset hβ hγ y ↔ x ⊆[TSet γ] y := by
  rw [powerset, mem_dom_iff]
  constructor
  · rintro ⟨z, h⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, exists_and_right, exists_eq', true_and] at h
    cases h.2
    exact h.1
  · intro h
    refine ⟨y, ?_⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, h, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, and_true, exists_eq', and_self]

/-- The set `ι²''x = {{{a}} | a ∈ x}`. -/
def doubleSingleton (x : TSet γ) : TSet α :=
  cross hβ hγ hδ x x ⊓' cardinalOne hβ hγ

@[simp]
theorem mem_doubleSingleton_iff (x : TSet γ) :
    ∀ y : TSet β, y ∈' doubleSingleton hβ hγ hδ x ↔
    ∃ z : TSet δ, z ∈' x ∧ y = { {z}' }' := by
  intro y
  rw [doubleSingleton, mem_inter_iff, mem_cross_iff, mem_cardinalOne_iff]
  constructor
  · rintro ⟨⟨b, c, h₁, h₂, h₃⟩, ⟨a, rfl⟩⟩
    obtain ⟨hbc, rfl⟩ := (op_eq_singleton_iff _ _ _ _ _).mp h₁.symm
    exact ⟨c, h₃, rfl⟩
  · rintro ⟨z, h, rfl⟩
    constructor
    · refine ⟨z, z, ?_⟩
      rw [eq_comm, op_eq_singleton_iff]
      tauto
    · exact ⟨_, rfl⟩

/-- The union of a set of *singletons*: `ι⁻¹''x = {a | {a} ∈ x}`. -/
def singletonUnion (x : TSet α) : TSet β :=
  typeLower lt_higherIndex lt_higherIndex hβ hγ
    (vCross lt_higherIndex lt_higherIndex hβ x)

@[simp]
theorem mem_singletonUnion_iff (x : TSet α) :
    ∀ y : TSet γ, y ∈' singletonUnion hβ hγ x ↔ {y}' ∈' x := by
  intro y
  simp only [singletonUnion, mem_typeLower_iff, vCross_spec, op_inj]
  constructor
  · intro h
    obtain ⟨a, b, ⟨rfl, rfl⟩, hy⟩ := h {y}'
    exact hy
  · intro h b
    exact ⟨b, _, ⟨rfl, rfl⟩, h⟩

/--
The union of a set of sets.

```
singletonUnion dom {⟨{a}, b⟩ | a ∈ b} ∩ (1 × x) =
singletonUnion dom {⟨{a}, b⟩ | a ∈ b ∧ b ∈ x} =
singletonUnion {{a} | a ∈ b ∧ b ∈ x} =
{a | a ∈ b ∧ b ∈ x} =
⋃ x
```
-/
def sUnion (x : TSet α) : TSet β :=
  singletonUnion hβ hγ
    (dom lt_higherIndex lt_higherIndex hβ
      (membership lt_higherIndex lt_higherIndex hβ hγ ⊓[lt_higherIndex]
        cross lt_higherIndex lt_higherIndex hβ (cardinalOne hβ hγ) x))

@[simp]
theorem mem_sUnion_iff (x : TSet α) :
    ∀ y : TSet γ, y ∈' sUnion hβ hγ x ↔ ∃ t : TSet β, t ∈' x ∧ y ∈' t := by
  intro y
  simp only [sUnion, mem_singletonUnion_iff, mem_dom_iff, Rel.dom, ExternalRel, mem_inter_iff,
    mem_cross_iff, op_inj, mem_cardinalOne_iff, Set.mem_setOf_eq, membership_spec]
  constructor
  · rintro ⟨z, h₁, a, b, ⟨rfl, rfl⟩, ⟨c, h₂⟩, h₃⟩
    rw [singleton_inj] at h₂
    cases h₂
    exact ⟨z, h₃, h₁⟩
  · rintro ⟨z, h₂, h₃⟩
    exact ⟨z, h₃, _, _, ⟨rfl, rfl⟩, ⟨y, rfl⟩, h₂⟩

theorem exists_smallUnion (s : Set (TSet α)) (hs : Small s) :
    ∃ x : TSet α, ∀ y : TSet β, y ∈' x ↔ ∃ t ∈ s, y ∈' t

:= by
  apply exists_of_symmetric
  have := exists_support (α := α)
  choose S hS using this
  refine ⟨⟨Enumeration.ofSet (⋃ t ∈ s, (S t)ᴬ) ?_, Enumeration.ofSet (⋃ t ∈ s, (S t)ᴺ) ?_⟩, ?_⟩
  · apply small_biUnion hs
    intros
    exact (S _)ᴬ.coe_small
  · apply small_biUnion hs
    intros
    exact (S _)ᴺ.coe_small
  intro ρ hρ
  suffices ∀ t ∈ s, ρ • t = t by
    ext y
    rw [Set.mem_smul_set_iff_inv_smul_mem]
    constructor
    · rintro ⟨t, h₁, h₂⟩
      refine ⟨t, h₁, ?_⟩
      rw [← this t h₁]
      rwa [mem_smul_iff', allPerm_inv_sderiv']
    · rintro ⟨t, h₁, h₂⟩
      refine ⟨t, h₁, ?_⟩
      have := this t h₁
      rw [smul_eq_iff_eq_inv_smul] at this
      rwa [this, mem_smul_iff', inv_inv, smul_inv_smul]
  intro t ht
  apply (hS t).supports ρ
  refine smul_eq_of_le ?_ hρ
  intro A
  constructor
  · intro a ha
    rw [← Support.derivBot_atoms, Support.mk_atoms, ← Enumeration.mem_path_iff,
      Enumeration.mem_ofSet_iff, Set.mem_iUnion]
    use t
    rw [Set.mem_iUnion]
    use ht
    exact ha
  · intro a ha
    rw [← Support.derivBot_nearLitters, Support.mk_nearLitters, ← Enumeration.mem_path_iff,
      Enumeration.mem_ofSet_iff, Set.mem_iUnion]
    use t
    rw [Set.mem_iUnion]
    use ht
    exact ha


import ConNF.External.Basic

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

/-- A set in our model that is a well-order. Internal well-orders are exactly external well-orders,
so we externalise the definition for convenience. -/
def InternalWellOrder (r : TSet α) : Prop :=
  IsWellOrder (ExternalRel hβ hγ hδ r).field
    (InvImage (ExternalRel hβ hγ hδ r) Subtype.val)

def InternallyWellOrdered (x : TSet γ) : Prop :=
  {y : TSet δ | y ∈' x}.Subsingleton ∨ (∃ r, InternalWellOrder hβ hγ hδ r ∧ x = field hβ hγ hδ r)

@[simp]
theorem externalRel_smul (r : TSet α) (ρ : AllPerm α) :
    ExternalRel hβ hγ hδ (ρ • r) =
      InvImage (ExternalRel hβ hγ hδ r) ((ρ ↘ hβ ↘ hγ ↘ hδ)⁻¹ • ·) := by
  ext a b
  simp only [ExternalRel, mem_smul_iff', allPerm_inv_sderiv', smul_op, InvImage]

omit [Params] in
/-- Well-orders are rigid. -/
theorem apply_eq_of_isWellOrder {X : Type _} {r : Rel X X} {f : X → X}
    (hr : IsWellOrder X r) (hf : Function.Bijective f) (hf' : ∀ x y, r x y ↔ r (f x) (f y)) :
    ∀ x, f x = x := by
  let emb : r ≼i r := ⟨⟨⟨f, hf.injective⟩, λ {a b} ↦ (hf' a b).symm⟩, ?_⟩
  · have : emb = InitialSeg.refl r := Subsingleton.elim _ _
    intro x
    exact congr_arg (λ f ↦ f x) this
  · intro a b h
    exact hf.surjective _

omit [Params] in
theorem apply_eq_of_isWellOrder' {X : Type _} {r : Rel X X} {f : X → X}
    (hr : IsWellOrder r.field (InvImage r Subtype.val)) (hf : Function.Bijective f)
    (hf' : ∀ x y, r x y ↔ r (f x) (f y)) :
    ∀ x ∈ r.field, f x = x := by
  have : ∀ x ∈ r.field, f x ∈ r.field := by
    rintro x (⟨y, h⟩ | ⟨y, h⟩)
    · exact Or.inl ⟨f y, (hf' x y).mp h⟩
    · exact Or.inr ⟨f y, (hf' y x).mp h⟩
  have := apply_eq_of_isWellOrder (f := λ x ↦ ⟨f x.val, this x.val x.prop⟩) hr ⟨?_, ?_⟩ ?_
  · intro x hx
    exact congr_arg Subtype.val (this ⟨x, hx⟩)
  · intro x y h
    rw [Subtype.mk.injEq] at h
    exact Subtype.val_injective (hf.injective h)
  · intro x
    obtain ⟨y, hy⟩ := hf.surjective x.val
    refine ⟨⟨y, ?_⟩, ?_⟩
    · obtain (⟨z, h⟩ | ⟨z, h⟩) := x.prop <;>
          rw [← hy] at h <;>
          obtain ⟨z, rfl⟩ := hf.surjective z
      · exact Or.inl ⟨z, (hf' y z).mpr h⟩
      · exact Or.inr ⟨z, (hf' z y).mpr h⟩
    · simp only [hy]
  · intros
    apply hf'

theorem exists_common_support_of_internallyWellOrdered' {x : TSet δ}
    (h : InternallyWellOrdered hγ hδ hε x) :
    ∃ S : Support β, ∀ y, y ∈' x → S.Supports { { {y}' }' }[hγ] := by
  obtain (h | ⟨r, h, rfl⟩) := h
  · obtain (h | ⟨y, hy⟩) := h.eq_empty_or_singleton
    · use ⟨Enumeration.empty, Enumeration.empty⟩
      intro y hy
      rw [Set.eq_empty_iff_forall_not_mem] at h
      cases h y hy
    · obtain ⟨S, hS⟩ := TSet.exists_support y
      use S ↗ hε ↗ hδ ↗ hγ
      intro z hz
      rw [Set.eq_singleton_iff_unique_mem] at hy
      cases hy.2 z hz
      refine ⟨?_, λ h ↦ by cases h⟩
      intro ρ hρ
      simp only [Support.smul_scoderiv, ← allPermSderiv_forget', Support.scoderiv_inj] at hρ
      simp only [smul_singleton, singleton_inj]
      exact hS _ hρ
  obtain ⟨S, hS⟩ := TSet.exists_support r
  use S
  intro a ha
  refine ⟨?_, λ h ↦ by cases h⟩
  intro ρ hρ
  have := hS ρ hρ
  simp only [smul_singleton, singleton_inj]
  apply apply_eq_of_isWellOrder' (r := ExternalRel hγ hδ hε r)
  · exact h
  · exact MulAction.bijective (ρ ↘ hγ ↘ hδ ↘ hε)
  · intro x y
    conv_rhs => rw [← this]
    simp only [externalRel_smul, InvImage, inv_smul_smul]
  · rwa [mem_field_iff] at ha

include hγ in
theorem Support.Supports.ofSingleton {S : Support α} {x : TSet β}
    (h : S.Supports {x}') :
    letI : Level := ⟨α⟩
    letI : LeLevel α := ⟨le_rfl⟩
    (S.strong ↘ hβ).Supports x := by
  refine ⟨?_, λ h ↦ by cases h⟩
  intro ρ hρ
  open scoped Pointwise in
  have := sUnion_singleton_symmetric_aux hγ hβ {y | y ∈' x} S ?_ ρ hρ
  · apply ConNF.ext hγ
    intro z
    simp only [Set.ext_iff, Set.mem_setOf_eq, Set.mem_smul_set_iff_inv_smul_mem] at this
    rw [mem_smul_iff', allPerm_inv_sderiv', this]
  · intro ρ hρ
    ext z
    simp only [Set.mem_smul_set_iff_inv_smul_mem, Set.mem_image, Set.mem_setOf_eq]
    have := h.supports ρ hρ
    simp only [smul_singleton, singleton_inj] at this
    constructor
    · rintro ⟨y, h₁, h₂⟩
      rw [← smul_eq_iff_eq_inv_smul, smul_singleton] at h₂
      refine ⟨_, ?_, h₂⟩
      rw [← this]
      simp only [mem_smul_iff', allPerm_inv_sderiv', inv_smul_smul]
      exact h₁
    · rintro ⟨y, h, rfl⟩
      refine ⟨(ρ ↘ hβ ↘ hγ)⁻¹ • y, ?_, ?_⟩
      · rwa [← allPerm_inv_sderiv', ← mem_smul_iff', this]
      · simp only [smul_singleton, allPerm_inv_sderiv']

include hγ in

theorem supports_of_supports_singletons {S : Support α} {s : Set (TSet β)}
    (h : ∀ x ∈ s, S.Supports {x}') :
    ∃ S : Support β, ∀ x ∈ s, S.Supports x

:=
  ⟨_, λ x hx ↦ (h x hx).ofSingleton hβ hγ⟩


import ConNF.Base.TypeIndex

/-!
# Paths of type indices

In this file, we define the notion of a *path*, and the derivative and coderivative operations.

## Main declarations

* `ConNF.Path`: A path of type indices.
* `ConNF.Path.recSderiv`, `ConNF.Path.recSderivLe`, `ConNF.Path.recSderivGlobal`:
    Downwards induction principles for paths.
* `ConNF.Path.recScoderiv`: An upwards induction principle for paths.
-/

universe u

open Cardinal WithBot

namespace ConNF

variable [Params.{u}] {α β γ δ : TypeIndex}

/-- A path of type indices starting at `α` and ending at `β` is a finite sequence of type indices
`α > ... > β`. -/
inductive Path (α : TypeIndex) : TypeIndex → Type u
  | nil : Path α α
  | cons {β γ : TypeIndex} : Path α β → γ < β → Path α γ

@[inherit_doc] infix:70 " ↝ "  => Path

def Path.single {α β : TypeIndex} (h : β < α) : α ↝ β :=
  .cons .nil h

/-- Typeclass for the `↘` notation. -/
class SingleDerivative (X : Type _) (Y : outParam <| Type _)
    (β : outParam TypeIndex) (γ : TypeIndex) where
  sderiv : X → γ < β → Y

/-- Typeclass for the `⇘` notation. -/
class Derivative (X : Type _) (Y : outParam <| Type _)
    (β : outParam TypeIndex) (γ : TypeIndex) extends SingleDerivative X Y β γ where
  deriv : X → β ↝ γ → Y
  sderiv x h := deriv x (.single h)
  deriv_single : ∀ x : X, ∀ h : γ < β, deriv x (.single h) = sderiv x h := by intros; rfl

/-- Typeclass for the `↘.` notation. -/
class BotSingleDerivative (X : Type _) (Y : outParam <| Type _) where
  botSderiv : X → Y

/-- Typeclass for the `⇘.` notation. -/
class BotDerivative (X : Type _) (Y : outParam <| Type _) (β : outParam TypeIndex)
    extends BotSingleDerivative X Y where
  botDeriv : X → β ↝ ⊥ → Y
  /-- We often need to do case analysis on `β` to show that it's a proper type index here.
  This case check doesn't need to be done in most actual use cases of the notation. -/
  botDeriv_single : ∀ x : X, ∀ h : ⊥ < β, botDeriv x (.single h) = botSderiv x

/-- Typeclass for the `↗` notation. -/
class SingleCoderivative (X : Type _) (Y : outParam <| Type _)
    (β : TypeIndex) (γ : outParam TypeIndex) where
  scoderiv : X → γ < β → Y

/-- Typeclass for the `⇗` notation. -/
class Coderivative (X : Type _) (Y : outParam <| Type _)
    (β : TypeIndex) (γ : outParam TypeIndex) extends SingleCoderivative X Y β γ where
  coderiv : X → β ↝ γ → Y
  scoderiv x h := coderiv x (.single h)
  coderiv_single : ∀ x : X, ∀ h : γ < β, coderiv x (.single h) = scoderiv x h := by intros; rfl

infixl:75 " ↘ " => SingleDerivative.sderiv
infixl:75 " ⇘ " => Derivative.deriv
postfix:75 " ↘." => BotSingleDerivative.botSderiv
infixl:75 " ⇘. " => BotDerivative.botDeriv
infixl:75 " ↗ " => SingleCoderivative.scoderiv
infixl:75 " ⇗ " => Coderivative.coderiv

@[simp]
theorem deriv_single {X Y : Type _} [Derivative X Y β γ] (x : X) (h : γ < β) :
    x ⇘ .single h = x ↘ h :=
  Derivative.deriv_single x h

@[simp]
theorem coderiv_single {X Y : Type _} [Coderivative X Y β γ] (x : X) (h : γ < β) :
    x ⇗ .single h = x ↗ h :=
  Coderivative.coderiv_single x h

@[simp]
theorem botDeriv_single {X Y : Type _} [BotDerivative X Y β] (x : X) (h : ⊥ < β) :
    x ⇘. .single h = x ↘. :=
  BotDerivative.botDeriv_single x h

/-!
## Downwards recursion along paths
-/

instance : SingleDerivative (α ↝ β) (α ↝ γ) β γ where
  sderiv := .cons

/-- The downwards recursion principle for paths. -/
@[elab_as_elim, induction_eliminator, cases_eliminator]
def Path.recSderiv {motive : ∀ β, α ↝ β → Sort _}
    (nil : motive α .nil)
    (sderiv : ∀ β γ (A : α ↝ β) (h : γ < β), motive β A → motive γ (A ↘ h)) :
    {β : TypeIndex} → (A : α ↝ β) → motive β A
  | _, .nil => nil
  | _, .cons A h => sderiv _ _ A h (recSderiv nil sderiv A)

@[simp]
theorem Path.recSderiv_nil {motive : ∀ β, α ↝ β → Sort _}
    (nil : motive α .nil)
    (sderiv : ∀ β γ (A : α ↝ β) (h : γ < β), motive β A → motive γ (A ↘ h)) :
    recSderiv (motive := motive) nil sderiv .nil = nil :=
  rfl

@[simp]
theorem Path.recSderiv_sderiv {motive : ∀ β, α ↝ β → Sort _}
    (nil : motive α .nil)
    (sderiv : ∀ β γ (A : α ↝ β) (h : γ < β), motive β A → motive γ (A ↘ h))
    {β γ : TypeIndex} (A : α ↝ β) (h : γ < β) :
    recSderiv (motive := motive) nil sderiv (A ↘ h) = sderiv β γ A h (recSderiv nil sderiv A) :=
  rfl

theorem Path.le (A : α ↝ β) : β ≤ α := by
  induction A with
  | nil => exact le_rfl
  | sderiv β γ _A h h' => exact h.le.trans h'

/-- The downwards recursion principle for paths, specialised to the case where the motive at `β`
only depends on the fact that `β ≤ α`. -/
def Path.recSderivLe {motive : ∀ β ≤ α, Sort _}
    (nil : motive α le_rfl)
    (sderiv : ∀ β γ, ∀ (A : α ↝ β) (h : γ < β), motive β A.le → motive γ (h.le.trans A.le)) :
    {β : TypeIndex} → (A : α ↝ β) → motive β A.le :=
  Path.recSderiv (motive := λ β A ↦ motive β A.le) nil sderiv

@[simp]
theorem Path.recSderivLe_nil {motive : ∀ β ≤ α, Sort _}
    (nil : motive α le_rfl)
    (sderiv : ∀ β γ (A : α ↝ β) (h : γ < β), motive β A.le → motive γ (h.le.trans A.le)) :
    recSderivLe (motive := motive) nil sderiv .nil = nil :=
  rfl

@[simp]
theorem Path.recSderivLe_sderiv {motive : ∀ β ≤ α, Sort _}
    (nil : motive α le_rfl)
    (sderiv : ∀ β γ (A : α ↝ β) (h : γ < β), motive β A.le → motive γ (h.le.trans A.le))
    {β γ : TypeIndex} (A : α ↝ β) (h : γ < β) :
    recSderivLe (motive := motive) nil sderiv (A ↘ h) = sderiv β γ A h (recSderiv nil sderiv A) :=
  rfl

/-- The downwards recursion principle for paths, specialised to the case where the motive is not
dependent on the relation of `β` to `α`. -/
@[elab_as_elim]
def Path.recSderivGlobal {motive : TypeIndex → Sort _}
    (nil : motive α)
    (sderiv : ∀ β γ, α ↝ β → γ < β → motive β → motive γ) :
    {β : TypeIndex} → α ↝ β → motive β :=
  Path.recSderiv (motive := λ β _ ↦ motive β) nil sderiv

@[simp]
theorem Path.recSderivGlobal_nil {motive : TypeIndex → Sort _}
    (nil : motive α)
    (sderiv : ∀ β γ, α ↝ β → γ < β → motive β → motive γ) :
    recSderivGlobal (motive := motive) nil sderiv .nil = nil :=
  rfl

@[simp]
theorem Path.recSderivGlobal_sderiv {motive : TypeIndex → Sort _}
    (nil : motive α)
    (sderiv : ∀ β γ, α ↝ β → γ < β → motive β → motive γ)
    {β γ : TypeIndex} (A : α ↝ β) (h : γ < β) :
    recSderivGlobal (motive := motive) nil sderiv (A ↘ h) =
      sderiv β γ A h (recSderiv nil sderiv A) :=
  rfl

/-!
## Derivatives of paths
-/

instance : Derivative (α ↝ β) (α ↝ γ) β γ where
  deriv A := Path.recSderivGlobal A (λ _ _ _ h B ↦ B ↘ h)

instance : BotDerivative (α ↝ β) (α ↝ ⊥) β where
  botDeriv A B := A ⇘ B
  botSderiv A :=
    match β with
      | ⊥ => A
      | (β : Λ) => A ↘ bot_lt_coe β
  botDeriv_single A h := by
    cases β using WithBot.recBotCoe with
    | bot => cases lt_irrefl ⊥ h
    | coe => rfl

instance : Coderivative (β ↝ γ) (α ↝ γ) α β where
  coderiv A B := B ⇘ A

@[simp]
theorem Path.deriv_nil (A : α ↝ β) :
    A ⇘ .nil = A :=
  rfl

@[simp]
theorem Path.deriv_sderiv (A : α ↝ β) (B : β ↝ γ) (h : δ < γ) :
    A ⇘ (B ↘ h) = A ⇘ B ↘ h :=
  rfl

@[simp]
theorem Path.nil_deriv (A : α ↝ β) :
    (.nil : α ↝ α) ⇘ A = A := by
  induction A with
  | nil => rfl
  | sderiv γ δ A h ih => rw [deriv_sderiv, ih]

@[simp]
theorem Path.deriv_sderivBot (A : α ↝ β) (B : β ↝ γ) :
    A ⇘ (B ↘.) = A ⇘ B ↘. := by
  cases γ using WithBot.recBotCoe with
  | bot => rfl
  | coe => rfl

@[simp]
theorem Path.botSderiv_bot_eq (A : α ↝ ⊥) :
    A ↘. = A :=
  rfl

@[simp]
theorem Path.botSderiv_coe_eq {β : Λ} (A : α ↝ β) :
    A ↘ bot_lt_coe β = A ↘. :=
  rfl

@[simp]
theorem Path.deriv_assoc (A : α ↝ β) (B : β ↝ γ) (C : γ ↝ δ) :
    A ⇘ (B ⇘ C) = A ⇘ B ⇘ C := by
  induction C with
  | nil => rfl
  | sderiv ε ζ C h ih => simp only [deriv_sderiv, ih]

@[simp]
theorem Path.deriv_sderiv_assoc (A : α ↝ β) (B : β ↝ γ) (h : δ < γ) :
    A ⇘ (B ↘ h) = A ⇘ B ↘ h :=
  rfl

@[simp]
theorem Path.deriv_scoderiv (A : α ↝ β) (B : γ ↝ δ) (h : γ < β) :
    A ⇘ (B ↗ h) = A ↘ h ⇘ B := by
  induction B with
  | nil => rfl
  | sderiv ε ζ B h' ih =>
    rw [deriv_sderiv, ← ih]
    rfl

@[simp]
theorem Path.botDeriv_scoderiv (A : α ↝ β) (B : γ ↝ ⊥) (h : γ < β) :
    A ⇘. (B ↗ h) = A ↘ h ⇘. B :=
  deriv_scoderiv A B h

theorem Path.coderiv_eq_deriv (A : α ↝ β) (B : β ↝ γ) :
    B ⇗ A = A ⇘ B :=
  rfl

theorem Path.coderiv_deriv (A : β ↝ γ) (h₁ : β < α) (h₂ : δ < γ) :
    A ↗ h₁ ↘ h₂ = A ↘ h₂ ↗ h₁ :=
  rfl

theorem Path.coderiv_deriv' (A : β ↝ γ) (h : β < α) (B : γ ↝ δ) :
    A ↗ h ⇘ B = A ⇘ B ↗ h

:= by
  induction B with
  | nil => rfl
  | sderiv ε ζ B h' ih =>
    rw [deriv_sderiv, ih]
    rfl


import ConNF.Model.RaiseStrong

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal

open scoped Pointwise

namespace ConNF

variable [Params.{u}]

/-- A redefinition of the derivative of allowable permutations that is invariant of level,
but still has nice definitional properties. -/
@[default_instance 200]
instance {β γ : TypeIndex} : Derivative (AllPerm β) (AllPerm γ) β γ where
  deriv ρ A :=
    A.recSderiv
    (motive := λ (δ : TypeIndex) (A : β ↝ δ) ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      AllPerm δ)
    ρ (λ δ ε A h ρ ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      letI : LeLevel ε := ⟨h.le.trans LeLevel.elim⟩
      PreCoherentData.allPermSderiv h ρ)

@[simp]
theorem allPerm_deriv_nil' {β : TypeIndex}
    (ρ : AllPerm β) :
    ρ ⇘ (.nil : β ↝ β) = ρ :=
  rfl

@[simp]
theorem allPerm_deriv_sderiv' {β γ δ : TypeIndex}
    (ρ : AllPerm β) (A : β ↝ γ) (h : δ < γ) :
    ρ ⇘ (A ↘ h) = ρ ⇘ A ↘ h :=
  rfl

@[simp]
theorem allPermSderiv_forget' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    (ρ ↘ h)ᵁ = ρᵁ ↘ h :=
  letI : Level := ⟨β.recBotCoe (Nonempty.some inferInstance) id⟩
  letI : LeLevel β := ⟨β.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
    (show β.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
  letI : LeLevel γ := ⟨h.le.trans LeLevel.elim⟩
  allPermSderiv_forget h ρ

@[simp]
theorem allPerm_inv_sderiv' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    ρ⁻¹ ↘ h = (ρ ↘ h)⁻¹ := by
  apply allPermForget_injective
  rw [allPermSderiv_forget', allPermForget_inv, Tree.inv_sderiv, allPermForget_inv,
    allPermSderiv_forget']

def Symmetric {α β : Λ} (s : Set (TSet β)) (hβ : (β : TypeIndex) < α) : Prop :=
  ∃ S : Support α, ∀ ρ : AllPerm α, ρᵁ • S = S → ρ ↘ hβ • s = s

def newSetEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    @TSet _ α newModelData.toPreModelData ≃ TSet α :=
  letI : Level := ⟨α⟩
  castTSet (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem newSetEquiv_forget {α : Λ}
    (x : letI : Level := ⟨α⟩; @TSet _ α newModelData.toPreModelData) :
    (newSetEquiv x)ᵁ = xᵁ :=
  letI : Level := ⟨α⟩
  castTSet_forget (D₁ := newModelData) (D₂ := globalModelData) _ x

def allPermEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    NewPerm ≃ AllPerm α :=
  letI : Level := ⟨α⟩
  castAllPerm (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem allPermEquiv_forget {α : Λ} (ρ : letI : Level := ⟨α⟩; NewPerm) :
    (allPermEquiv ρ)ᵁ = ρᵁ :=
  letI : Level := ⟨α⟩
  castAllPerm_forget (D₁ := newModelData) (D₂ := globalModelData) _ ρ

theorem allPermEquiv_sderiv {α β : Λ}
    (ρ : letI : Level := ⟨α⟩; NewPerm) (hβ : (β : TypeIndex) < α) :
    letI : Level := ⟨α⟩
    letI : LtLevel β := ⟨hβ⟩
    allPermEquiv ρ ↘ hβ = ρ.sderiv β := by
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  apply allPermForget_injective
  rw [allPermSderiv_forget, allPermEquiv_forget, NewPerm.forget_sderiv]

theorem TSet.exists_of_symmetric {α β : Λ} (s : Set (TSet β)) (hβ : (β : TypeIndex) < α)
    (hs : Symmetric s hβ) :
    ∃ x : TSet α, ∀ y : TSet β, y ∈[hβ] x ↔ y ∈ s := by
  letI : Level := ⟨α⟩
  letI : LtLevel β := ⟨hβ⟩
  suffices ∃ x : (@TSet _ α newModelData.toPreModelData), ∀ y : TSet β, yᵁ ∈[hβ] xᵁ ↔ y ∈ s by
    obtain ⟨x, hx⟩ := this
    use newSetEquiv x
    intro y
    rw [← hx, ← TSet.forget_mem_forget, newSetEquiv_forget]
  obtain rfl | hs' := s.eq_empty_or_nonempty
  · use none
    intro y
    simp only [Set.mem_empty_iff_false, iff_false]
    exact not_mem_none y
  · use some (Code.toSet ⟨β, s, hs'⟩ ?_)
    · intro y
      erw [mem_some_iff]
      exact Code.mem_toSet _
    · obtain ⟨S, hS⟩ := hs
      use S
      intro ρ hρS
      have := hS (allPermEquiv ρ) ?_
      · simp only [NewPerm.smul_mk, Code.mk.injEq, heq_eq_eq, true_and]
        rwa [allPermEquiv_sderiv] at this
      · rwa [allPermEquiv_forget]

theorem TSet.exists_support {α : Λ} (x : TSet α) :
    ∃ S : Support α, ∀ ρ : AllPerm α, ρᵁ • S = S → ρ • x = x := by
  letI : Level := ⟨α⟩
  obtain ⟨S, hS⟩ := NewSet.exists_support (newSetEquiv.symm x)
  use S
  intro ρ hρ
  have := @Support.Supports.supports _ _ _ newPreModelData _ _ _ hS (allPermEquiv.symm ρ) ?_
  · apply tSetForget_injective
    have := congr_arg (·ᵁ) this
    simp only at this
    erw [@smul_forget _ _ newModelData (allPermEquiv.symm ρ) (newSetEquiv.symm x),
      ← allPermEquiv_forget, ← newSetEquiv_forget, Equiv.apply_symm_apply,
      Equiv.apply_symm_apply] at this
    rwa [smul_forget]
  · rwa [← allPermEquiv_forget, Equiv.apply_symm_apply]

theorem TSet.symmetric {α β : Λ} (x : TSet α) (hβ : (β : TypeIndex) < α) :
    Symmetric {y : TSet β | y ∈[hβ] x} hβ := by
  obtain ⟨S, hS⟩ := exists_support x
  use S
  intro ρ hρ
  conv_rhs => rw [← hS ρ hρ]
  simp only [← forget_mem_forget, smul_forget, StrSet.mem_smul_iff]
  ext y
  rw [Set.mem_smul_set_iff_inv_smul_mem, Set.mem_setOf_eq, Set.mem_setOf_eq,
    smul_forget, allPermForget_inv, allPermSderiv_forget']

theorem tSet_ext' {α β : Λ} (hβ : (β : TypeIndex) < α) (x y : TSet α)
    (h : ∀ z : TSet β, z ∈[hβ] x ↔ z ∈[hβ] y) : x = y :=
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  tSet_ext hβ x y h

@[simp]
theorem TSet.mem_smul_iff' {α β : TypeIndex}
    {x : TSet β} {y : TSet α} (h : β < α) (ρ : AllPerm α) :
    x ∈[h] ρ • y ↔ ρ⁻¹ ↘ h • x ∈[h] y

:= by
  letI : Level := ⟨α.recBotCoe (Nonempty.some inferInstance) id⟩
  letI : LeLevel α := ⟨α.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
    (show α.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
  letI : LtLevel β := ⟨h.trans_le LeLevel.elim⟩
  exact mem_smul_iff h ρ


import ConNF.Model.RaiseStrong

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal

open scoped Pointwise

namespace ConNF

variable [Params.{u}]

/-- A redefinition of the derivative of allowable permutations that is invariant of level,
but still has nice definitional properties. -/
@[default_instance 200]
instance {β γ : TypeIndex} : Derivative (AllPerm β) (AllPerm γ) β γ where
  deriv ρ A :=
    A.recSderiv
    (motive := λ (δ : TypeIndex) (A : β ↝ δ) ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      AllPerm δ)
    ρ (λ δ ε A h ρ ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      letI : LeLevel ε := ⟨h.le.trans LeLevel.elim⟩
      PreCoherentData.allPermSderiv h ρ)

@[simp]
theorem allPerm_deriv_nil' {β : TypeIndex}
    (ρ : AllPerm β) :
    ρ ⇘ (.nil : β ↝ β) = ρ :=
  rfl

@[simp]
theorem allPerm_deriv_sderiv' {β γ δ : TypeIndex}
    (ρ : AllPerm β) (A : β ↝ γ) (h : δ < γ) :
    ρ ⇘ (A ↘ h) = ρ ⇘ A ↘ h :=
  rfl

@[simp]
theorem allPermSderiv_forget' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    (ρ ↘ h)ᵁ = ρᵁ ↘ h :=
  letI : Level := ⟨β.recBotCoe (Nonempty.some inferInstance) id⟩
  letI : LeLevel β := ⟨β.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
    (show β.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
  letI : LeLevel γ := ⟨h.le.trans LeLevel.elim⟩
  allPermSderiv_forget h ρ

@[simp]
theorem allPerm_inv_sderiv' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    ρ⁻¹ ↘ h = (ρ ↘ h)⁻¹ := by
  apply allPermForget_injective
  rw [allPermSderiv_forget', allPermForget_inv, Tree.inv_sderiv, allPermForget_inv,
    allPermSderiv_forget']

def Symmetric {α β : Λ} (s : Set (TSet β)) (hβ : (β : TypeIndex) < α) : Prop :=
  ∃ S : Support α, ∀ ρ : AllPerm α, ρᵁ • S = S → ρ ↘ hβ • s = s

def newSetEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    @TSet _ α newModelData.toPreModelData ≃ TSet α :=
  letI : Level := ⟨α⟩
  castTSet (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem newSetEquiv_forget {α : Λ}
    (x : letI : Level := ⟨α⟩; @TSet _ α newModelData.toPreModelData) :
    (newSetEquiv x)ᵁ = xᵁ :=
  letI : Level := ⟨α⟩
  castTSet_forget (D₁ := newModelData) (D₂ := globalModelData) _ x

def allPermEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    NewPerm ≃ AllPerm α :=
  letI : Level := ⟨α⟩
  castAllPerm (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem allPermEquiv_forget {α : Λ} (ρ : letI : Level := ⟨α⟩; NewPerm) :
    (allPermEquiv ρ)ᵁ = ρᵁ :=
  letI : Level := ⟨α⟩
  castAllPerm_forget (D₁ := newModelData) (D₂ := globalModelData) _ ρ

theorem allPermEquiv_sderiv {α β : Λ}
    (ρ : letI : Level := ⟨α⟩; NewPerm) (hβ : (β : TypeIndex) < α) :
    letI : Level := ⟨α⟩
    letI : LtLevel β := ⟨hβ⟩
    allPermEquiv ρ ↘ hβ = ρ.sderiv β := by
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  apply allPermForget_injective
  rw [allPermSderiv_forget, allPermEquiv_forget, NewPerm.forget_sderiv]

theorem TSet.exists_of_symmetric {α β : Λ} (s : Set (TSet β)) (hβ : (β : TypeIndex) < α)
    (hs : Symmetric s hβ) :
    ∃ x : TSet α, ∀ y : TSet β, y ∈[hβ] x ↔ y ∈ s

:= by
  letI : Level := ⟨α⟩
  letI : LtLevel β := ⟨hβ⟩
  suffices ∃ x : (@TSet _ α newModelData.toPreModelData), ∀ y : TSet β, yᵁ ∈[hβ] xᵁ ↔ y ∈ s by
    obtain ⟨x, hx⟩ := this
    use newSetEquiv x
    intro y
    rw [← hx, ← TSet.forget_mem_forget, newSetEquiv_forget]
  obtain rfl | hs' := s.eq_empty_or_nonempty
  · use none
    intro y
    simp only [Set.mem_empty_iff_false, iff_false]
    exact not_mem_none y
  · use some (Code.toSet ⟨β, s, hs'⟩ ?_)
    · intro y
      erw [mem_some_iff]
      exact Code.mem_toSet _
    · obtain ⟨S, hS⟩ := hs
      use S
      intro ρ hρS
      have := hS (allPermEquiv ρ) ?_
      · simp only [NewPerm.smul_mk, Code.mk.injEq, heq_eq_eq, true_and]
        rwa [allPermEquiv_sderiv] at this
      · rwa [allPermEquiv_forget]


import ConNF.Model.Result

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

def union (x y : TSet α) : TSet α :=
  (xᶜ' ⊓' yᶜ')ᶜ'

notation:68 x:68 " ⊔[" h "] " y:68 => _root_.ConNF.union h x y
notation:68 x:68 " ⊔' " y:68 => x ⊔[by assumption] y

@[simp]
theorem mem_union_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊔' y ↔ z ∈' x ∨ z ∈' y := by
  rw [union]
  intro z
  rw [mem_compl_iff, mem_inter_iff, mem_compl_iff, mem_compl_iff, or_iff_not_and_not]

def higherIndex (α : Λ) : Λ :=
  (exists_gt α).choose

theorem lt_higherIndex {α : Λ} :
    (α : TypeIndex) < higherIndex α :=
  WithBot.coe_lt_coe.mpr (exists_gt α).choose_spec

theorem tSet_nonempty (h : ∃ β : Λ, (β : TypeIndex) < α) : Nonempty (TSet α) := by
  obtain ⟨α', hα⟩ := h
  constructor
  apply typeLower lt_higherIndex lt_higherIndex lt_higherIndex hα
  apply cardinalOne lt_higherIndex lt_higherIndex

def empty : TSet α :=
  (tSet_nonempty ⟨β, hβ⟩).some ⊓' (tSet_nonempty ⟨β, hβ⟩).someᶜ'

@[simp]
theorem mem_empty_iff :
    ∀ x : TSet β, ¬x ∈' empty hβ := by
  intro x
  rw [empty, mem_inter_iff, mem_compl_iff]
  exact and_not_self

def univ : TSet α :=
  (empty hβ)ᶜ'

@[simp]
theorem mem_univ_iff :
    ∀ x : TSet β, x ∈' univ hβ := by
  intro x
  simp only [univ, mem_compl_iff, mem_empty_iff, not_false_eq_true]

/-- The set of all ordered pairs. -/
def orderedPairs : TSet α :=
  vCross hβ hγ hδ (univ hδ)

@[simp]
theorem mem_orderedPairs_iff (x : TSet β) :
    x ∈' orderedPairs hβ hγ hδ ↔ ∃ a b, x = ⟨a, b⟩' := by
  simp only [orderedPairs, vCross_spec, mem_univ_iff, and_true]

def converse (x : TSet α) : TSet α :=
  converse' hβ hγ hδ x ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem op_mem_converse_iff (x : TSet α) :
    ∀ a b, ⟨a, b⟩' ∈' converse hβ hγ hδ x ↔ ⟨b, a⟩' ∈' x := by
  intro a b
  simp only [converse, mem_inter_iff, converse'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def cross (x y : TSet γ) : TSet α :=
  converse hβ hγ hδ (vCross hβ hγ hδ x) ⊓' vCross hβ hγ hδ y

@[simp]
theorem mem_cross_iff (x y : TSet γ) :
    ∀ a, a ∈' cross hβ hγ hδ x y ↔ ∃ b c, a = ⟨b, c⟩' ∧ b ∈' x ∧ c ∈' y := by
  intro a
  rw [cross, mem_inter_iff, vCross_spec]
  constructor
  · rintro ⟨h₁, b, c, rfl, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj] at h₁
    obtain ⟨b', c', ⟨rfl, rfl⟩, h₁⟩ := h₁
    exact ⟨b, c, rfl, h₁, h₂⟩
  · rintro ⟨b, c, rfl, h₁, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj]
    exact ⟨⟨c, b, ⟨rfl, rfl⟩, h₁⟩, ⟨b, c, ⟨rfl, rfl⟩, h₂⟩⟩

def singletonImage (x : TSet β) : TSet α :=
  singletonImage' hβ hγ hδ hε x ⊓' (cross hβ hγ hδ (cardinalOne hδ hε) (cardinalOne hδ hε))

@[simp]
theorem singletonImage_spec (x : TSet β) :
    ∀ z w,
    ⟨ {z}', {w}' ⟩' ∈' singletonImage hβ hγ hδ hε x ↔ ⟨z, w⟩' ∈' x := by
  intro z w
  rw [singletonImage, mem_inter_iff, singletonImage'_spec, and_iff_left_iff_imp]
  intro hzw
  rw [mem_cross_iff]
  refine ⟨{z}', {w}', rfl, ?_⟩
  simp only [mem_cardinalOne_iff, singleton_inj, exists_eq', and_self]

theorem exists_of_mem_singletonImage {x : TSet β} {z w : TSet δ}
    (h : ⟨z, w⟩' ∈' singletonImage hβ hγ hδ hε x) :
    ∃ a b, z = {a}' ∧ w = {b}' := by
  simp only [singletonImage, mem_inter_iff, mem_cross_iff, op_inj, mem_cardinalOne_iff] at h
  obtain ⟨-, _, _, ⟨rfl, rfl⟩, ⟨a, rfl⟩, ⟨b, rfl⟩⟩ := h
  exact ⟨a, b, rfl, rfl⟩

/-- Turn a model element encoding a relation into an actual relation. -/
def ExternalRel (r : TSet α) : Rel (TSet δ) (TSet δ) :=
  λ x y ↦ ⟨x, y⟩' ∈' r

@[simp]
theorem externalRel_converse (r : TSet α) :
    ExternalRel hβ hγ hδ (converse hβ hγ hδ r) = (ExternalRel hβ hγ hδ r).inv := by
  ext
  simp only [ExternalRel, op_mem_converse_iff, Rel.inv_apply]

/-- The codomain of a relation. -/
def codom (r : TSet α) : TSet γ :=
  (typeLower lt_higherIndex hβ hγ hδ (singletonImage lt_higherIndex hβ hγ hδ r)ᶜ[lt_higherIndex])ᶜ'

@[simp]
theorem mem_codom_iff (r : TSet α) (x : TSet δ) :
    x ∈' codom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).codom := by
  simp only [codom, mem_compl_iff, mem_typeLower_iff, not_forall, not_not]
  constructor
  · rintro ⟨y, hy⟩
    obtain ⟨a, b, rfl, hb⟩ := exists_of_mem_singletonImage lt_higherIndex hβ hγ hδ hy
    rw [singleton_inj] at hb
    subst hb
    rw [singletonImage_spec] at hy
    exact ⟨a, hy⟩
  · rintro ⟨a, ha⟩
    use {a}'
    rw [singletonImage_spec]
    exact ha

/-- The domain of a relation. -/
def dom (r : TSet α) : TSet γ :=
  codom hβ hγ hδ (converse hβ hγ hδ r)

@[simp]
theorem mem_dom_iff (r : TSet α) (x : TSet δ) :
    x ∈' dom hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).dom := by
  rw [dom, mem_codom_iff, externalRel_converse, Rel.inv_codom]

/-- The field of a relation. -/
def field (r : TSet α) : TSet γ :=
  dom hβ hγ hδ r ⊔' codom hβ hγ hδ r

@[simp]
theorem mem_field_iff (r : TSet α) (x : TSet δ) :
    x ∈' field hβ hγ hδ r ↔ x ∈ (ExternalRel hβ hγ hδ r).field := by
  rw [field, mem_union_iff, mem_dom_iff, mem_codom_iff, Rel.field, Set.mem_union]

def subset : TSet α :=
  subset' hβ hγ hδ hε ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem subset_spec :
    ∀ a b, ⟨a, b⟩' ∈' subset hβ hγ hδ hε ↔ a ⊆[TSet ε] b := by
  intro a b
  simp only [subset, mem_inter_iff, subset'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def membership : TSet α :=
  subset hβ hγ hδ hε ⊓' cross hβ hγ hδ (cardinalOne hδ hε) (univ hδ)

@[simp]
theorem membership_spec :
    ∀ a b, ⟨{a}', b⟩' ∈' membership hβ hγ hδ hε ↔ a ∈' b := by
  intro a b
  rw [membership, mem_inter_iff, subset_spec]
  simp only [mem_cross_iff, op_inj, mem_cardinalOne_iff, mem_univ_iff, and_true, exists_and_right,
    exists_and_left, exists_eq', exists_eq_left', singleton_inj]
  constructor
  · intro h
    exact h a ((typedMem_singleton_iff' hε a a).mpr rfl)
  · intro h c hc
    simp only [typedMem_singleton_iff'] at hc
    cases hc
    exact h

def powerset (x : TSet β) : TSet α :=
  dom lt_higherIndex lt_higherIndex hβ
    (subset lt_higherIndex lt_higherIndex hβ hγ ⊓[lt_higherIndex]
      vCross lt_higherIndex lt_higherIndex hβ {x}')

@[simp]
theorem mem_powerset_iff (x y : TSet β) :
    x ∈' powerset hβ hγ y ↔ x ⊆[TSet γ] y := by
  rw [powerset, mem_dom_iff]
  constructor
  · rintro ⟨z, h⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, exists_and_right, exists_eq', true_and] at h
    cases h.2
    exact h.1
  · intro h
    refine ⟨y, ?_⟩
    simp only [ExternalRel, mem_inter_iff, subset_spec, h, vCross_spec, op_inj,
      typedMem_singleton_iff', exists_eq_right, and_true, exists_eq', and_self]

/-- The set `ι²''x = {{{a}} | a ∈ x}`. -/
def doubleSingleton (x : TSet γ) : TSet α :=
  cross hβ hγ hδ x x ⊓' cardinalOne hβ hγ

@[simp]
theorem mem_doubleSingleton_iff (x : TSet γ) :
    ∀ y : TSet β, y ∈' doubleSingleton hβ hγ hδ x ↔
    ∃ z : TSet δ, z ∈' x ∧ y = { {z}' }' := by
  intro y
  rw [doubleSingleton, mem_inter_iff, mem_cross_iff, mem_cardinalOne_iff]
  constructor
  · rintro ⟨⟨b, c, h₁, h₂, h₃⟩, ⟨a, rfl⟩⟩
    obtain ⟨hbc, rfl⟩ := (op_eq_singleton_iff _ _ _ _ _).mp h₁.symm
    exact ⟨c, h₃, rfl⟩
  · rintro ⟨z, h, rfl⟩
    constructor
    · refine ⟨z, z, ?_⟩
      rw [eq_comm, op_eq_singleton_iff]
      tauto
    · exact ⟨_, rfl⟩

/-- The union of a set of *singletons*: `ι⁻¹''x = {a | {a} ∈ x}`. -/
def singletonUnion (x : TSet α) : TSet β :=
  typeLower lt_higherIndex lt_higherIndex hβ hγ
    (vCross lt_higherIndex lt_higherIndex hβ x)

@[simp]
theorem mem_singletonUnion_iff (x : TSet α) :
    ∀ y : TSet γ, y ∈' singletonUnion hβ hγ x ↔ {y}' ∈' x

:= by
  intro y
  simp only [singletonUnion, mem_typeLower_iff, vCross_spec, op_inj]
  constructor
  · intro h
    obtain ⟨a, b, ⟨rfl, rfl⟩, hy⟩ := h {y}'
    exact hy
  · intro h b
    exact ⟨b, _, ⟨rfl, rfl⟩, h⟩


import ConNF.Model.TTT

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

namespace TSet

theorem exists_inter (x y : TSet α) :
    ∃ w : TSet α, ∀ z : TSet β, z ∈[hβ] w ↔ z ∈[hβ] x ∧ z ∈[hβ] y := by
  refine exists_of_symmetric {z | z ∈[hβ] x ∧ z ∈[hβ] y} hβ ?_
  obtain ⟨S, hS⟩ := symmetric x hβ
  obtain ⟨T, hT⟩ := symmetric y hβ
  use S + T
  intro ρ hρ
  specialize hS ρ (smul_eq_of_le Support.le_add_right hρ)
  specialize hT ρ (smul_eq_of_le Support.le_add_left hρ)
  simp [Set.ext_iff, Set.mem_smul_set_iff_inv_smul_mem] at hS hT ⊢
  aesop

theorem exists_compl (x : TSet α) :
    ∃ y : TSet α, ∀ z : TSet β, z ∈[hβ] y ↔ ¬z ∈[hβ] x := by
  refine exists_of_symmetric {z | ¬z ∈[hβ] x} hβ ?_
  obtain ⟨S, hS⟩ := symmetric x hβ
  use S
  intro ρ hρ
  specialize hS ρ hρ
  simp [Set.ext_iff, Set.mem_smul_set_iff_inv_smul_mem] at hS ⊢
  aesop

theorem exists_up (x y : TSet β) :
    ∃ w : TSet α, ∀ z : TSet β, z ∈[hβ] w ↔ z = x ∨ z = y := by
  refine exists_of_symmetric {x, y} hβ ?_
  obtain ⟨S, hS⟩ := exists_support x
  obtain ⟨T, hT⟩ := exists_support y
  use (S + T) ↗ hβ
  intro ρ hρ
  rw [Support.smul_scoderiv, Support.scoderiv_inj, ← allPermSderiv_forget'] at hρ
  specialize hS (ρ ↘ hβ) (smul_eq_of_le Support.le_add_right hρ)
  specialize hT (ρ ↘ hβ) (smul_eq_of_le Support.le_add_left hρ)
  simp only [Set.smul_set_def, Set.image, Set.mem_insert_iff, Set.mem_singleton_iff,
    exists_eq_or_imp, hS, exists_eq_left, hT]
  ext z
  rw [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_setOf_eq]
  aesop

/-- The unordered pair. -/
def up (x y : TSet β) : TSet α :=
  (exists_up hβ x y).choose

@[simp]
theorem mem_up_iff (x y z : TSet β) :
    z ∈[hβ] up hβ x y ↔ z = x ∨ z = y :=
  (exists_up hβ x y).choose_spec z

/-- The Kuratowski ordered pair. -/
def op (x y : TSet γ) : TSet α :=
  up hβ (singleton hγ x) (up hγ x y)

theorem up_injective {x y z w : TSet β} (h : up hβ x y = up hβ z w) :
    (x = z ∧ y = w) ∨ (x = w ∧ y = z) := by
  have h₁ := mem_up_iff hβ x y z
  have h₂ := mem_up_iff hβ x y w
  have h₃ := mem_up_iff hβ z w x
  have h₄ := mem_up_iff hβ z w y
  rw [h, mem_up_iff] at h₁ h₂
  rw [← h, mem_up_iff] at h₃ h₄
  aesop

@[simp]
theorem up_inj (x y z w : TSet β) :
    up hβ x y = up hβ z w ↔ (x = z ∧ y = w) ∨ (x = w ∧ y = z) := by
  constructor
  · exact up_injective hβ
  · rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩)
    · rfl
    · apply tSet_ext' hβ
      aesop

@[simp]
theorem up_self {x : TSet β} :
    up hβ x x = singleton hβ x := by
  apply tSet_ext' hβ
  aesop

@[simp]
theorem up_eq_singleton_iff (x y z : TSet β) :
    up hβ x y = singleton hβ z ↔ x = z ∧ y = z := by
  constructor
  · intro h
    have h₁ := typedMem_singleton_iff' hβ z x
    have h₂ := typedMem_singleton_iff' hβ z y
    rw [← h, mem_up_iff] at h₁ h₂
    aesop
  · rintro ⟨rfl, rfl⟩
    rw [up_self]

@[simp]
theorem singleton_eq_up_iff (x y z : TSet β) :
    singleton hβ z = up hβ x y ↔ x = z ∧ y = z := by
  rw [← up_eq_singleton_iff hβ x y z, eq_comm]

theorem op_injective {x y z w : TSet γ} (h : op hβ hγ x y = op hβ hγ z w) :
    x = z ∧ y = w := by
  rw [op, op] at h
  simp only [up_inj, singleton_inj, singleton_eq_up_iff, up_eq_singleton_iff] at h
  obtain (⟨rfl, ⟨h, rfl⟩ | ⟨rfl, rfl⟩⟩ | ⟨⟨rfl, rfl⟩, ⟨h, rfl⟩⟩) := h <;> simp only [and_self]

@[simp]
theorem op_inj (x y z w : TSet γ) :
    op hβ hγ x y = op hβ hγ z w ↔ x = z ∧ y = w := by
  constructor
  · exact op_injective hβ hγ
  · rintro ⟨rfl, rfl⟩
    rfl

@[simp]
theorem op_eq_singleton_iff (x y : TSet γ) (z : TSet β) :
    op hβ hγ x y = singleton hβ z ↔ singleton hγ x = z ∧ singleton hγ y = z := by
  rw [op, up_eq_singleton_iff, and_congr_right_iff]
  rintro rfl
  simp only [up_eq_singleton_iff, true_and, singleton_inj]

@[simp]
theorem smul_up (x y : TSet β) (ρ : AllPerm α) :
    ρ • up hβ x y = up hβ (ρ ↘ hβ • x) (ρ ↘ hβ • y) := by
  apply tSet_ext' hβ
  aesop

@[simp]
theorem smul_op (x y : TSet γ) (ρ : AllPerm α) :
    ρ • op hβ hγ x y = op hβ hγ (ρ ↘ hβ ↘ hγ • x) (ρ ↘ hβ ↘ hγ • y) := by
  apply tSet_ext' hβ
  simp only [op, smul_up, smul_singleton, mem_up_iff, implies_true]

theorem exists_singletonImage (x : TSet β) :
    ∃ y : TSet α, ∀ z w,
    op hγ hδ (singleton hε z) (singleton hε w) ∈[hβ] y ↔ op hδ hε z w ∈[hγ] x

:= by
  have := exists_of_symmetric {u | ∃ z w : TSet ε, op hδ hε z w ∈[hγ] x ∧
      u = op hγ hδ (singleton hε z) (singleton hε w)} hβ ?_
  · obtain ⟨y, hy⟩ := this
    use y
    intro z w
    rw [hy]
    simp only [Set.mem_setOf_eq, op_inj, singleton_inj, exists_eq_right_right', exists_eq_right']
  · obtain ⟨S, hS⟩ := exists_support x
    use S ↗ hβ
    intro ρ hρ
    rw [Support.smul_scoderiv, Support.scoderiv_inj, ← allPermSderiv_forget'] at hρ
    specialize hS (ρ ↘ hβ) hρ
    ext z
    constructor
    · rintro ⟨_, ⟨z, w, hab, rfl⟩, rfl⟩
      refine ⟨ρ ↘ hβ ↘ hγ ↘ hδ ↘ hε • z, ρ ↘ hβ ↘ hγ ↘ hδ ↘ hε • w, ?_, ?_⟩
      · rwa [← hS, mem_smul_iff', smul_op, allPerm_inv_sderiv', allPerm_inv_sderiv',
          allPerm_inv_sderiv', inv_smul_smul, inv_smul_smul]
      · simp only [smul_op, smul_singleton]
    · rintro ⟨z, w, hab, rfl⟩
      refine ⟨ρ⁻¹ ↘ hβ • op hγ hδ (singleton hε z) (singleton hε w), ?_, ?_⟩
      · simp only [allPerm_inv_sderiv', smul_op, smul_singleton, Set.mem_setOf_eq, op_inj,
          singleton_inj, exists_eq_right_right', exists_eq_right']
        rw [smul_eq_iff_eq_inv_smul] at hS
        rw [hS]
        simp only [mem_smul_iff', inv_inv, smul_op, smul_inv_smul]
        exact hab
      · simp only [allPerm_inv_sderiv', smul_inv_smul]


import ConNF.Model.Result

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

def union (x y : TSet α) : TSet α :=
  (xᶜ' ⊓' yᶜ')ᶜ'

notation:68 x:68 " ⊔[" h "] " y:68 => _root_.ConNF.union h x y
notation:68 x:68 " ⊔' " y:68 => x ⊔[by assumption] y

@[simp]
theorem mem_union_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊔' y ↔ z ∈' x ∨ z ∈' y := by
  rw [union]
  intro z
  rw [mem_compl_iff, mem_inter_iff, mem_compl_iff, mem_compl_iff, or_iff_not_and_not]

def higherIndex (α : Λ) : Λ :=
  (exists_gt α).choose

theorem lt_higherIndex {α : Λ} :
    (α : TypeIndex) < higherIndex α :=
  WithBot.coe_lt_coe.mpr (exists_gt α).choose_spec

theorem tSet_nonempty (h : ∃ β : Λ, (β : TypeIndex) < α) : Nonempty (TSet α)

:= by
  obtain ⟨α', hα⟩ := h
  constructor
  apply typeLower lt_higherIndex lt_higherIndex lt_higherIndex hα
  apply cardinalOne lt_higherIndex lt_higherIndex


import ConNF.Model.RaiseStrong

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal

open scoped Pointwise

namespace ConNF

variable [Params.{u}]

/-- A redefinition of the derivative of allowable permutations that is invariant of level,
but still has nice definitional properties. -/
@[default_instance 200]
instance {β γ : TypeIndex} : Derivative (AllPerm β) (AllPerm γ) β γ where
  deriv ρ A :=
    A.recSderiv
    (motive := λ (δ : TypeIndex) (A : β ↝ δ) ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      AllPerm δ)
    ρ (λ δ ε A h ρ ↦
      letI : Level := ⟨δ.recBotCoe (Nonempty.some inferInstance) id⟩
      letI : LeLevel δ := ⟨δ.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
        (show δ.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
      letI : LeLevel ε := ⟨h.le.trans LeLevel.elim⟩
      PreCoherentData.allPermSderiv h ρ)

@[simp]
theorem allPerm_deriv_nil' {β : TypeIndex}
    (ρ : AllPerm β) :
    ρ ⇘ (.nil : β ↝ β) = ρ :=
  rfl

@[simp]
theorem allPerm_deriv_sderiv' {β γ δ : TypeIndex}
    (ρ : AllPerm β) (A : β ↝ γ) (h : δ < γ) :
    ρ ⇘ (A ↘ h) = ρ ⇘ A ↘ h :=
  rfl

@[simp]
theorem allPermSderiv_forget' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    (ρ ↘ h)ᵁ = ρᵁ ↘ h :=
  letI : Level := ⟨β.recBotCoe (Nonempty.some inferInstance) id⟩
  letI : LeLevel β := ⟨β.recBotCoe (λ _ ↦ bot_le) (λ _ h ↦ WithBot.coe_le_coe.mpr h.le)
    (show β.recBotCoe (Nonempty.some inferInstance) id = Level.α from rfl)⟩
  letI : LeLevel γ := ⟨h.le.trans LeLevel.elim⟩
  allPermSderiv_forget h ρ

@[simp]
theorem allPerm_inv_sderiv' {β γ : TypeIndex} (h : γ < β) (ρ : AllPerm β) :
    ρ⁻¹ ↘ h = (ρ ↘ h)⁻¹ := by
  apply allPermForget_injective
  rw [allPermSderiv_forget', allPermForget_inv, Tree.inv_sderiv, allPermForget_inv,
    allPermSderiv_forget']

def Symmetric {α β : Λ} (s : Set (TSet β)) (hβ : (β : TypeIndex) < α) : Prop :=
  ∃ S : Support α, ∀ ρ : AllPerm α, ρᵁ • S = S → ρ ↘ hβ • s = s

def newSetEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    @TSet _ α newModelData.toPreModelData ≃ TSet α :=
  letI : Level := ⟨α⟩
  castTSet (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem newSetEquiv_forget {α : Λ}
    (x : letI : Level := ⟨α⟩; @TSet _ α newModelData.toPreModelData) :
    (newSetEquiv x)ᵁ = xᵁ :=
  letI : Level := ⟨α⟩
  castTSet_forget (D₁ := newModelData) (D₂ := globalModelData) _ x

def allPermEquiv {α : Λ} :
    letI : Level := ⟨α⟩
    NewPerm ≃ AllPerm α :=
  letI : Level := ⟨α⟩
  castAllPerm (D₁ := newModelData) (D₂ := globalModelData) rfl
    (by rw [globalModelData, motive_eq, constructMotive, globalLtData_eq])

@[simp]
theorem allPermEquiv_forget {α : Λ} (ρ : letI : Level := ⟨α⟩; NewPerm) :
    (allPermEquiv ρ)ᵁ = ρᵁ :=
  letI : Level := ⟨α⟩
  castAllPerm_forget (D₁ := newModelData) (D₂ := globalModelData) _ ρ

theorem allPermEquiv_sderiv {α β : Λ}
    (ρ : letI : Level := ⟨α⟩; NewPerm) (hβ : (β : TypeIndex) < α) :
    letI : Level := ⟨α⟩
    letI : LtLevel β := ⟨hβ⟩
    allPermEquiv ρ ↘ hβ = ρ.sderiv β

:= by
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  apply allPermForget_injective
  rw [allPermSderiv_forget, allPermEquiv_forget, NewPerm.forget_sderiv]


import ConNF.Model.Result

/-!
# New file

In this file...

## Main declarations

* `ConNF.foo`: Something new.
-/

noncomputable section
universe u

open Cardinal Ordinal ConNF.TSet

namespace ConNF

variable [Params.{u}] {α β γ δ ε ζ : Λ} (hβ : (β : TypeIndex) < α) (hγ : (γ : TypeIndex) < β)
  (hδ : (δ : TypeIndex) < γ) (hε : (ε : TypeIndex) < δ) (hζ : (ζ : TypeIndex) < ε)

def union (x y : TSet α) : TSet α :=
  (xᶜ' ⊓' yᶜ')ᶜ'

notation:68 x:68 " ⊔[" h "] " y:68 => _root_.ConNF.union h x y
notation:68 x:68 " ⊔' " y:68 => x ⊔[by assumption] y

@[simp]
theorem mem_union_iff (x y : TSet α) :
    ∀ z : TSet β, z ∈' x ⊔' y ↔ z ∈' x ∨ z ∈' y := by
  rw [union]
  intro z
  rw [mem_compl_iff, mem_inter_iff, mem_compl_iff, mem_compl_iff, or_iff_not_and_not]

def higherIndex (α : Λ) : Λ :=
  (exists_gt α).choose

theorem lt_higherIndex {α : Λ} :
    (α : TypeIndex) < higherIndex α :=
  WithBot.coe_lt_coe.mpr (exists_gt α).choose_spec

theorem tSet_nonempty (h : ∃ β : Λ, (β : TypeIndex) < α) : Nonempty (TSet α) := by
  obtain ⟨α', hα⟩ := h
  constructor
  apply typeLower lt_higherIndex lt_higherIndex lt_higherIndex hα
  apply cardinalOne lt_higherIndex lt_higherIndex

def empty : TSet α :=
  (tSet_nonempty ⟨β, hβ⟩).some ⊓' (tSet_nonempty ⟨β, hβ⟩).someᶜ'

@[simp]
theorem mem_empty_iff :
    ∀ x : TSet β, ¬x ∈' empty hβ := by
  intro x
  rw [empty, mem_inter_iff, mem_compl_iff]
  exact and_not_self

def univ : TSet α :=
  (empty hβ)ᶜ'

@[simp]
theorem mem_univ_iff :
    ∀ x : TSet β, x ∈' univ hβ := by
  intro x
  simp only [univ, mem_compl_iff, mem_empty_iff, not_false_eq_true]

/-- The set of all ordered pairs. -/
def orderedPairs : TSet α :=
  vCross hβ hγ hδ (univ hδ)

@[simp]
theorem mem_orderedPairs_iff (x : TSet β) :
    x ∈' orderedPairs hβ hγ hδ ↔ ∃ a b, x = ⟨a, b⟩' := by
  simp only [orderedPairs, vCross_spec, mem_univ_iff, and_true]

def converse (x : TSet α) : TSet α :=
  converse' hβ hγ hδ x ⊓' orderedPairs hβ hγ hδ

@[simp]
theorem op_mem_converse_iff (x : TSet α) :
    ∀ a b, ⟨a, b⟩' ∈' converse hβ hγ hδ x ↔ ⟨b, a⟩' ∈' x := by
  intro a b
  simp only [converse, mem_inter_iff, converse'_spec, mem_orderedPairs_iff, op_inj, exists_and_left,
    exists_eq', and_true]

def cross (x y : TSet γ) : TSet α :=
  converse hβ hγ hδ (vCross hβ hγ hδ x) ⊓' vCross hβ hγ hδ y

@[simp]
theorem mem_cross_iff (x y : TSet γ) :
    ∀ a, a ∈' cross hβ hγ hδ x y ↔ ∃ b c, a = ⟨b, c⟩' ∧ b ∈' x ∧ c ∈' y := by
  intro a
  rw [cross, mem_inter_iff, vCross_spec]
  constructor
  · rintro ⟨h₁, b, c, rfl, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj] at h₁
    obtain ⟨b', c', ⟨rfl, rfl⟩, h₁⟩ := h₁
    exact ⟨b, c, rfl, h₁, h₂⟩
  · rintro ⟨b, c, rfl, h₁, h₂⟩
    simp only [op_mem_converse_iff, vCross_spec, op_inj]
    exact ⟨⟨c, b, ⟨rfl, rfl⟩, h₁⟩, ⟨b, c, ⟨rfl, rfl⟩, h₂⟩⟩

def singletonImage (x : TSet β) : TSet α :=
  singletonImage' hβ hγ hδ hε x ⊓' (cross hβ hγ hδ (cardinalOne hδ hε) (cardinalOne hδ hε))

@[simp]
theorem singletonImage_spec (x : TSet β) :
    ∀ z w,
    ⟨ {z}', {w}' ⟩' ∈' singletonImage hβ hγ hδ hε x ↔ ⟨z, w⟩' ∈' x := by
  intro z w
  rw [singletonImage, mem_inter_iff, singletonImage'_spec, and_iff_left_iff_imp]
  intro hzw
  rw [mem_cross_iff]
  refine ⟨{z}', {w}', rfl, ?_⟩
  simp only [mem_cardinalOne_iff, singleton_inj, exists_eq', and_self]

theorem exists_of_mem_singletonImage {x : TSet β} {z w : TSet δ}
    (h : ⟨z, w⟩' ∈' singletonImage hβ hγ hδ hε x) :
    ∃ a b, z = {a}' ∧ w = {b}' := by
  simp only [singletonImage, mem_inter_iff, mem_cross_iff, op_inj, mem_cardinalOne_iff] at h
  obtain ⟨-, _, _, ⟨rfl, rfl⟩, ⟨a, rfl⟩, ⟨b, rfl⟩⟩ := h
  exact ⟨a, b, rfl, rfl⟩

/-- Turn a model element encoding a relation into an actual relation. -/
def ExternalRel (r : TSet α) : Rel (TSet δ) (TSet δ) :=
  λ x y ↦ ⟨x, y⟩' ∈' r

@[simp]
theorem externalRel_converse (r : TSet α) :
    ExternalRel hβ hγ hδ (converse hβ hγ hδ r) = (ExternalRel hβ hγ hδ r).inv

:= by
  ext
  simp only [ExternalRel, op_mem_converse_iff, Rel.inv_apply]


import ConNF.ModelData.PathEnumeration

/-!
# Supports

In this file, we define the notion of a support.

## Main declarations

* `ConNF.BaseSupport`: The type of supports of atoms.
* `ConNF.Support`: The type of supports of objects of arbitrary type indices.
-/

universe u

open Cardinal

namespace ConNF

variable [Params.{u}]

/-!
## Base supports
-/

structure BaseSupport where
  atoms : Enumeration Atom
  nearLitters : Enumeration NearLitter

namespace BaseSupport

instance : SuperA BaseSupport (Enumeration Atom) where
  superA := atoms

instance : SuperN BaseSupport (Enumeration NearLitter) where
  superN := nearLitters

@[simp]
theorem mk_atoms {a : Enumeration Atom} {N : Enumeration NearLitter} :
    (BaseSupport.mk a N)ᴬ = a :=
  rfl

@[simp]
theorem mk_nearLitters {a : Enumeration Atom} {N : Enumeration NearLitter} :
    (BaseSupport.mk a N)ᴺ = N :=
  rfl

theorem atoms_congr {S T : BaseSupport} (h : S = T) :
    Sᴬ = Tᴬ :=
  h ▸ rfl

theorem nearLitters_congr {S T : BaseSupport} (h : S = T) :
    Sᴺ = Tᴺ :=
  h ▸ rfl

@[ext]
theorem ext {S T : BaseSupport} (h₁ : Sᴬ = Tᴬ) (h₂ : Sᴺ = Tᴺ) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  cases h₁
  cases h₂
  rfl

instance : SMul BasePerm BaseSupport where
  smul π S := ⟨π • Sᴬ, π • Sᴺ⟩

@[simp]
theorem smul_atoms (π : BasePerm) (S : BaseSupport) :
    (π • S)ᴬ = π • Sᴬ :=
  rfl

@[simp]
theorem smul_nearLitters (π : BasePerm) (S : BaseSupport) :
    (π • S)ᴺ = π • Sᴺ :=
  rfl

@[simp]
theorem smul_atoms_eq_of_smul_eq {π : BasePerm} {S : BaseSupport}
    (h : π • S = S) :
    π • Sᴬ = Sᴬ := by
  rw [← smul_atoms, h]

@[simp]
theorem smul_nearLitters_eq_of_smul_eq {π : BasePerm} {S : BaseSupport}
    (h : π • S = S) :
    π • Sᴺ = Sᴺ := by
  rw [← smul_nearLitters, h]

instance : MulAction BasePerm BaseSupport where
  one_smul S := by
    apply ext
    · rw [smul_atoms, one_smul]
    · rw [smul_nearLitters, one_smul]
  mul_smul π₁ π₂ S := by
    apply ext
    · rw [smul_atoms, smul_atoms, smul_atoms, mul_smul]
    · rw [smul_nearLitters, smul_nearLitters, smul_nearLitters, mul_smul]

theorem smul_eq_smul_iff (π₁ π₂ : BasePerm) (S : BaseSupport) :
    π₁ • S = π₂ • S ↔ (∀ a ∈ Sᴬ, π₁ • a = π₂ • a) ∧ (∀ N ∈ Sᴺ, π₁ • N = π₂ • N) := by
  constructor
  · intro h
    constructor
    · rintro a ⟨i, ha⟩
      have := congr_arg (·ᴬ.rel i (π₁ • a)) h
      simp only [smul_atoms, Enumeration.smul_rel, inv_smul_smul, eq_iff_iff] at this
      have := Sᴬ.rel_coinjective.coinjective ha (this.mp ha)
      rw [eq_inv_smul_iff] at this
      rw [this]
    · rintro N ⟨i, hN⟩
      have := congr_arg (·ᴺ.rel i (π₁ • N)) h
      simp only [smul_nearLitters, Enumeration.smul_rel, inv_smul_smul, eq_iff_iff] at this
      have := Sᴺ.rel_coinjective.coinjective hN (this.mp hN)
      rw [eq_inv_smul_iff] at this
      rw [this]
  · intro h
    ext : 2
    · rfl
    · ext i a : 3
      rw [smul_atoms, smul_atoms, Enumeration.smul_rel, Enumeration.smul_rel]
      constructor
      · intro ha
        have := h.1 _ ⟨i, ha⟩
        rw [smul_inv_smul, ← inv_smul_eq_iff] at this
        rwa [this]
      · intro ha
        have := h.1 _ ⟨i, ha⟩
        rw [smul_inv_smul, smul_eq_iff_eq_inv_smul] at this
        rwa [← this]
    · rfl
    · ext i a : 3
      rw [smul_nearLitters, smul_nearLitters, Enumeration.smul_rel, Enumeration.smul_rel]
      constructor
      · intro hN
        have := h.2 _ ⟨i, hN⟩
        rw [smul_inv_smul, ← inv_smul_eq_iff] at this
        rwa [this]
      · intro hN
        have := h.2 _ ⟨i, hN⟩
        rw [smul_inv_smul, smul_eq_iff_eq_inv_smul] at this
        rwa [← this]

theorem smul_eq_iff (π : BasePerm) (S : BaseSupport) :
    π • S = S ↔ (∀ a ∈ Sᴬ, π • a = a) ∧ (∀ N ∈ Sᴺ, π • N = N) := by
  have := smul_eq_smul_iff π 1 S
  simp only [one_smul] at this
  exact this

noncomputable instance : Add BaseSupport where
  add S T := ⟨Sᴬ + Tᴬ, Sᴺ + Tᴺ⟩

@[simp]
theorem add_atoms (S T : BaseSupport) :
    (S + T)ᴬ = Sᴬ + Tᴬ :=
  rfl

@[simp]
theorem add_nearLitters (S T : BaseSupport) :
    (S + T)ᴺ = Sᴺ + Tᴺ :=
  rfl

end BaseSupport

def baseSupportEquiv : BaseSupport ≃ Enumeration Atom × Enumeration NearLitter where
  toFun S := (Sᴬ, Sᴺ)
  invFun S := ⟨S.1, S.2⟩
  left_inv _ := rfl
  right_inv _ := rfl

theorem card_baseSupport : #BaseSupport = #μ := by
  rw [Cardinal.eq.mpr ⟨baseSupportEquiv⟩, mk_prod, lift_id, lift_id,
    card_enumeration_eq card_atom, card_enumeration_eq card_nearLitter, mul_eq_self aleph0_lt_μ.le]

/-!
## Structural supports
-/

structure Support (α : TypeIndex) where
  atoms : Enumeration (α ↝ ⊥ × Atom)
  nearLitters : Enumeration (α ↝ ⊥ × NearLitter)

namespace Support

variable {α β : TypeIndex}

instance : SuperA (Support α) (Enumeration (α ↝ ⊥ × Atom)) where
  superA := atoms

instance : SuperN (Support α) (Enumeration (α ↝ ⊥ × NearLitter)) where
  superN := nearLitters

@[simp]
theorem mk_atoms (E : Enumeration (α ↝ ⊥ × Atom)) (F : Enumeration (α ↝ ⊥ × NearLitter)) :
    (⟨E, F⟩ : Support α)ᴬ = E :=
  rfl

@[simp]
theorem mk_nearLitters (E : Enumeration (α ↝ ⊥ × Atom)) (F : Enumeration (α ↝ ⊥ × NearLitter)) :
    (⟨E, F⟩ : Support α)ᴺ = F :=
  rfl

instance : Derivative (Support α) (Support β) α β where
  deriv S A := ⟨Sᴬ ⇘ A, Sᴺ ⇘ A⟩

instance : Coderivative (Support β) (Support α) α β where
  coderiv S A := ⟨Sᴬ ⇗ A, Sᴺ ⇗ A⟩

instance : BotDerivative (Support α) BaseSupport α where
  botDeriv S A := ⟨Sᴬ ⇘. A, Sᴺ ⇘. A⟩
  botSderiv S := ⟨Sᴬ ↘., Sᴺ ↘.⟩
  botDeriv_single S h := by dsimp only; rw [botDeriv_single, botDeriv_single]

@[simp]
theorem deriv_atoms {α β : TypeIndex} (S : Support α) (A : α ↝ β) :
    Sᴬ ⇘ A = (S ⇘ A)ᴬ :=
  rfl

@[simp]
theorem deriv_nearLitters {α β : TypeIndex} (S : Support α) (A : α ↝ β) :
    Sᴺ ⇘ A = (S ⇘ A)ᴺ :=
  rfl

@[simp]
theorem sderiv_atoms {α β : TypeIndex} (S : Support α) (h : β < α) :
    Sᴬ ↘ h = (S ↘ h)ᴬ :=
  rfl

@[simp]
theorem sderiv_nearLitters {α β : TypeIndex} (S : Support α) (h : β < α) :
    Sᴺ ↘ h = (S ↘ h)ᴺ :=
  rfl

@[simp]
theorem coderiv_atoms {α β : TypeIndex} (S : Support β) (A : α ↝ β) :
    Sᴬ ⇗ A = (S ⇗ A)ᴬ :=
  rfl

@[simp]
theorem coderiv_nearLitters {α β : TypeIndex} (S : Support β) (A : α ↝ β) :
    Sᴺ ⇗ A = (S ⇗ A)ᴺ :=
  rfl

@[simp]
theorem scoderiv_atoms {α β : TypeIndex} (S : Support β) (h : β < α) :
    Sᴬ ↗ h = (S ↗ h)ᴬ :=
  rfl

@[simp]
theorem scoderiv_nearLitters {α β : TypeIndex} (S : Support β) (h : β < α) :
    Sᴺ ↗ h = (S ↗ h)ᴺ :=
  rfl

@[simp]
theorem derivBot_atoms {α : TypeIndex} (S : Support α) (A : α ↝ ⊥) :
    Sᴬ ⇘. A = (S ⇘. A)ᴬ