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']


import ConNF.Background.Rel
import ConNF.Base.Small

/-!
# Enumerations

In this file, we define enumerations of a type.

## Main declarations

* `ConNF.Enumeration`: The type family of enumerations.
-/

universe u

open Cardinal

namespace ConNF

variable [Params.{u}] {X Y : Type u}

@[ext]
structure Enumeration (X : Type u) where
  bound : κ
  rel : Rel κ X
  lt_bound : ∀ i ∈ rel.dom, i < bound
  rel_coinjective : rel.Coinjective

variable {E F G : Enumeration X}

namespace Enumeration

instance : CoeTC (Enumeration X) (Set X) where
  coe E := E.rel.codom

instance : Membership X (Enumeration X) where
  mem E x := x ∈ E.rel.codom

theorem mem_iff (x : X) (E : Enumeration X) :
    x ∈ E ↔ x ∈ E.rel.codom :=
  Iff.rfl

theorem mem_congr {E F : Enumeration X} (h : E = F) :
    ∀ x, x ∈ E ↔ x ∈ F := by
  intro x
  rw [h]

theorem dom_small (E : Enumeration X) :
    Small E.rel.dom :=
  (iio_small E.bound).mono E.lt_bound

theorem coe_small (E : Enumeration X) :
    Small (E : Set X) :=
  small_codom_of_small_dom E.rel_coinjective E.dom_small

theorem graph'_small (E : Enumeration X) :
    Small E.rel.graph' :=
  small_graph' E.dom_small E.coe_small

noncomputable def empty : Enumeration X where
  bound := 0
  rel _ _ := False
  lt_bound _ h := by cases h; contradiction
  rel_coinjective := by constructor; intros; contradiction

@[simp]
theorem not_mem_empty (x : X) : x ∉ Enumeration.empty


import ConNF.Levels.Path

/-!
# Trees

In this file, we define the notion of a tree on a type.

## Main declarations

* `ConNF.Tree`: The type family of trees parametrised by a given type.
-/

universe u

open Cardinal

namespace ConNF

variable [Params.{u}] {X Y : Type _} {α β γ : TypeIndex}

/-- An `α`-tree of `X` associates an object of type `X` to each path `α ↝ ⊥`. -/
def Tree (X : Type _) (α : TypeIndex) :=
  (α ↝ ⊥) → X

namespace Tree

instance : Derivative (Tree X α) (Tree X β) α β where
  deriv T A B := T (A ⇘ B)

@[simp]
theorem deriv_apply (T : Tree X α) (A : α ↝ β) (B : β ↝ ⊥) :
    (T ⇘ A) B = T (A ⇘ B) :=
  rfl

@[simp]
theorem deriv_nil (T : Tree X α) :
    T ⇘ .nil = T := by
  funext A
  rw [deriv_apply, Path.nil_deriv]

theorem deriv_deriv (T : Tree X α) (A : α ↝ β) (B : β ↝ γ) :
    T ⇘ A ⇘ B = T ⇘ (A ⇘ B) := by
  funext C
  simp only [deriv_apply, Path.deriv_assoc]

theorem deriv_sderiv (T : Tree X α) (A : α ↝ β) (h : γ < β) :
    T ⇘ A ↘ h = T ⇘ (A ↘ h) := by
  rw [← Derivative.deriv_single, ← Derivative.deriv_single, deriv_deriv]

@[simp]
theorem sderiv_apply (T : Tree X α) (h : β < α) (B : β ↝ ⊥) :
    (T ↘ h) B = T (B ↗ h) :=
  rfl

instance : BotDerivative (Tree X α) X α where
  botDeriv T A := T A
  botSderiv T := T <| Path.nil ↘.
  botDeriv_single T h := by
    cases α using WithBot.recBotCoe with
      | bot => cases lt_irrefl ⊥ h
      | coe => rfl

@[simp]
theorem botDeriv_eq (T : Tree X α) (A : α ↝ ⊥) :
    T ⇘. A = T A :=
  rfl

theorem botSderiv_eq (T : Tree X α) :
    T ↘. = T (Path.nil ↘.) :=
  rfl

/-- The group structure on the type of `α`-trees of `X` is given by "branchwise" multiplication,
given by `Pi.group`. -/
instance group [Group X] : Group (Tree X α) :=
  Pi.group

@[simp]
theorem one_apply [Group X] (A : α ↝ ⊥) :
    (1 : Tree X α) A = 1 :=
  rfl

@[simp]
theorem one_deriv [Group X] (A : α ↝ β) :
    (1 : Tree X α) ⇘ A = 1 :=
  rfl

@[simp]
theorem one_sderiv [Group X] (h : β < α) :
    (1 : Tree X α) ↘ h = 1 :=
  rfl

@[simp]
theorem one_sderivBot [Group X] :
    (1 : Tree X α) ↘. = 1 :=
  rfl

@[simp]
theorem mul_apply [Group X] (T₁ T₂ : Tree X α) (A : α ↝ ⊥) :
    (T₁ * T₂) A = T₁ A * T₂ A :=
  rfl

@[simp]
theorem mul_deriv [Group X] (T₁ T₂ : Tree X α) (A : α ↝ β) :
    (T₁ * T₂) ⇘ A = T₁ ⇘ A * T₂ ⇘ A


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


import ConNF.Model.Externalise

/-!
# 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) < β}

namespace Support

theorem not_mem_scoderiv_botDeriv (S : Support γ) (N : NearLitter) :
    N ∉ (S ↗ hγ ⇘. (Path.nil ↘.))ᴺ := by
  rintro ⟨i, ⟨A, N'⟩, h₁, h₂⟩
  simp only [Prod.mk.injEq] at h₂
  cases A
  case sderiv δ A hδ _ =>
    simp only [Path.deriv_sderiv] at h₂
    cases A
    case nil => cases h₂.1
    case sderiv ζ A hζ _ =>
      simp only [Path.deriv_sderiv] at h₂
      cases h₂.1

variable [Level] [LtLevel β]

theorem not_mem_strong_botDeriv (S : Support γ) (N : NearLitter) :
    N ∉ ((S ↗ hγ).strong ⇘. (Path.nil ↘.))ᴺ := by
  rintro h
  rw [strong, close_nearLitters, preStrong_nearLitters, Enumeration.mem_add_iff] at h
  obtain h | h := h
  · exact not_mem_scoderiv_botDeriv S N h
  · rw [mem_constrainsNearLitters_nearLitters] at h
    obtain ⟨B, N', hN', h⟩ := h
    cases h using Relation.ReflTransGen.head_induction_on
    case refl => exact not_mem_scoderiv_botDeriv S N hN'
    case head x hx₁ hx₂ _ =>
      obtain ⟨⟨γ, δ, ε, hδ, hε, hδε, A⟩, t, B, hB, hN, ht⟩ := hx₂
      simp only at hB
      cases B
      case nil =>
        cases hB
        obtain ⟨C, N''⟩ := x
        simp only at ht
        cases ht.1
        change _ ∈ t.supportᴺ at hN
        rw [t.support_supports.2 rfl] at hN
        obtain ⟨i, hN⟩ := hN
        cases hN
      case sderiv δ B hδ _ _ =>
        cases B
        case nil => cases hB
        case sderiv ζ B hζ _ _ => cases hB

theorem raise_preStrong' (S : Support α) (hS : S.Strong) (T : Support γ) (ρ : AllPerm β)
    (hγ : (γ : TypeIndex) < β) :
    (S + (ρᵁ • ((T ↗ hγ).strong +
      (S ↘ LtLevel.elim + (T ↗ hγ).strong).interferenceSupport)) ↗ LtLevel.elim).PreStrong := by
  apply hS.toPreStrong.add
  constructor
  intro A N hN P t hA ht
  obtain ⟨A, rfl⟩ := eq_of_nearLitter_mem_scoderiv_botDeriv hN
  simp only [scoderiv_botDeriv_eq, add_derivBot, smul_derivBot,
    BaseSupport.add_nearLitters, BaseSupport.smul_nearLitters, interferenceSupport_nearLitters,
    Enumeration.mem_add_iff, Enumeration.mem_smul, Enumeration.not_mem_empty, or_false] at hN
  obtain ⟨δ, ε, ζ, hε, hζ, hεζ, B⟩ := P
  dsimp only at *
  cases A
  case sderiv ζ' A hζ' _ =>
    rw [← Path.coderiv_deriv] at hA
    cases Path.sderiv_index_injective hA
    apply Path.sderiv_left_inj.mp at hA
    cases A
    case nil =>
      cases hA
      cases not_mem_strong_botDeriv T _ hN
    case sderiv ι A hι _ _ =>
      rw [← Path.coderiv_deriv] at hA
      cases Path.sderiv_index_injective hA
      cases hA
      haveI : LtLevel δ := ⟨A.le.trans_lt LtLevel.elim⟩
      haveI : LtLevel ε := ⟨hε.trans LtLevel.elim⟩
      haveI : LtLevel ζ := ⟨hζ.trans LtLevel.elim⟩
      have := (T ↗ hγ).strong_strong.support_le hN ⟨δ, ε, ζ, hε, hζ, hεζ, A⟩
          (ρ⁻¹ ⇘ A ↘ hε • t) rfl ?_
      · simp only [Tangle.smul_support, allPermSderiv_forget, allPermDeriv_forget,
          allPermForget_inv, Tree.inv_deriv, Tree.inv_sderiv] at this
        have := smul_le_smul this (ρᵁ ⇘ A ↘ hε)
        simp only [smul_inv_smul] at this
        apply le_trans this
        intro B
        constructor
        · intro a ha
          simp only [smul_derivBot, Tree.sderiv_apply, Tree.deriv_apply, Path.deriv_scoderiv,
            deriv_derivBot, Enumeration.mem_smul] at ha
          rw [deriv_derivBot, ← Path.deriv_scoderiv, Path.coderiv_deriv', scoderiv_botDeriv_eq,]
          simp only [Path.deriv_scoderiv, add_derivBot, smul_derivBot,
            BaseSupport.add_atoms, BaseSupport.smul_atoms, Enumeration.mem_add_iff,
            Enumeration.mem_smul]
          exact Or.inl ha
        · intro N hN
          simp only [smul_derivBot, Tree.sderiv_apply, Tree.deriv_apply, Path.deriv_scoderiv,
            deriv_derivBot, Enumeration.mem_smul] at hN
          rw [deriv_derivBot, ← Path.deriv_scoderiv, Path.coderiv_deriv', scoderiv_botDeriv_eq,]
          simp only [Path.deriv_scoderiv, add_derivBot, smul_derivBot,
            BaseSupport.add_nearLitters, BaseSupport.smul_nearLitters, Enumeration.mem_add_iff,
            Enumeration.mem_smul]
          exact Or.inl hN
      · rw [← smul_fuzz hε hζ hεζ, ← ht]
        simp only [Path.botSderiv_coe_eq, BasePerm.smul_nearLitter_litter, allPermDeriv_forget,
          allPermForget_inv, Tree.inv_deriv, Tree.inv_sderiv, Tree.inv_sderivBot]
        rfl

theorem raise_closed' (S : Support α) (hS : S.Strong) (T : Support γ) (ρ : AllPerm β)
    (hγ : (γ : TypeIndex) < β)
    (hρ : ρᵁ • (S ↘ LtLevel.elim : Support β) = S ↘ LtLevel.elim) :
    (S + (ρᵁ • ((T ↗ hγ).strong +
      (S ↘ LtLevel.elim + (T ↗ hγ).strong).interferenceSupport)) ↗ LtLevel.elim).Closed := by
  constructor
  intro A
  constructor
  intro N₁ N₂ hN₁ hN₂ a ha
  simp only [add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff,
    BaseSupport.add_atoms] at hN₁ hN₂ ⊢
  obtain hN₁ | hN₁ := hN₁
  · obtain hN₂ | hN₂ := hN₂
    · exact Or.inl ((hS.closed A).interference_subset hN₁ hN₂ a ha)
    · obtain ⟨B, rfl⟩ := eq_of_nearLitter_mem_scoderiv_botDeriv hN₂
      simp only [smul_add, scoderiv_botDeriv_eq, add_derivBot, smul_derivBot,
        BaseSupport.add_nearLitters, BaseSupport.smul_nearLitters, Enumeration.mem_add_iff,
        Enumeration.mem_smul, BaseSupport.add_atoms, BaseSupport.smul_atoms] at hN₁ hN₂ ⊢
      refine Or.inr (Or.inr ?_)
      rw [mem_interferenceSupport_atoms]
      refine ⟨(ρᵁ B)⁻¹ • N₁, ?_, (ρᵁ B)⁻¹ • N₂, ?_, ?_⟩
      · simp only [add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
        rw [← Enumeration.mem_smul, ← BaseSupport.smul_nearLitters, ← smul_derivBot, hρ]
        exact Or.inl hN₁
      · simp only [add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
        simp only [interferenceSupport_nearLitters, Enumeration.not_mem_empty, or_false] at hN₂
        exact Or.inr hN₂
      · rw [← BasePerm.smul_interference]
        exact Set.smul_mem_smul_set ha
  · obtain ⟨B, rfl⟩ := eq_of_nearLitter_mem_scoderiv_botDeriv hN₁
    simp only [smul_add, scoderiv_botDeriv_eq, add_derivBot, smul_derivBot,
      BaseSupport.add_nearLitters, BaseSupport.smul_nearLitters, Enumeration.mem_add_iff,
      Enumeration.mem_smul, BaseSupport.add_atoms, BaseSupport.smul_atoms] at hN₁ hN₂ ⊢
    refine Or.inr (Or.inr ?_)
    rw [mem_interferenceSupport_atoms]
    refine ⟨(ρᵁ B)⁻¹ • N₁, ?_, (ρᵁ B)⁻¹ • N₂, ?_, ?_⟩
    · simp only [add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
      simp only [interferenceSupport_nearLitters, Enumeration.not_mem_empty, or_false] at hN₁
      exact Or.inr hN₁
    · simp only [add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
      simp only [interferenceSupport_nearLitters, Enumeration.not_mem_empty, or_false] at hN₂
      obtain hN₂ | hN₂ := hN₂
      · rw [← Enumeration.mem_smul, ← BaseSupport.smul_nearLitters, ← smul_derivBot, hρ]
        exact Or.inl hN₂
      · exact Or.inr hN₂
    · rw [← BasePerm.smul_interference]
      exact Set.smul_mem_smul_set ha

theorem raise_strong' (S : Support α) (hS : S.Strong) (T : Support γ) (ρ : AllPerm β)
    (hγ : (γ : TypeIndex) < β)
    (hρ : ρᵁ • (S ↘ LtLevel.elim : Support β) = S ↘ LtLevel.elim) :
    (S + (ρᵁ • ((T ↗ hγ).strong +
      (S ↘ LtLevel.elim + (T ↗ hγ).strong).interferenceSupport)) ↗ LtLevel.elim).Strong :=
  ⟨raise_preStrong' S hS T ρ hγ, raise_closed' S hS T ρ hγ hρ⟩

theorem convAtoms_injective_of_fixes {S : Support α} {T : Support γ}
    {ρ₁ ρ₂ : AllPerm β} {hγ : (γ : TypeIndex) < β}
    (hρ₁ : ρ₁ᵁ • (S ↘ LtLevel.elim : Support β) = S ↘ LtLevel.elim)
    (hρ₂ : ρ₂ᵁ • (S ↘ LtLevel.elim : Support β) = S ↘ LtLevel.elim)
    (A : ↑α ↝ ⊥) :
    (convAtoms
      (S + (ρ₁ᵁ • ((T ↗ hγ).strong + (S ↘ LtLevel.elim + (T ↗ hγ).strong).interferenceSupport)) ↗
        LtLevel.elim)
      (S + (ρ₂ᵁ • ((T ↗ hγ).strong + (S ↘ LtLevel.elim + (T ↗ hγ).strong).interferenceSupport)) ↗
        LtLevel.elim) A).Injective

:= by
  rw [Support.smul_eq_iff] at hρ₁ hρ₂
  constructor
  rintro a₁ a₂ a₃ ⟨i, hi₁, hi₂⟩ ⟨j, hj₁, hj₂⟩
  simp only [add_derivBot, BaseSupport.add_atoms, Rel.inv_apply,
    Enumeration.rel_add_iff] at hi₁ hi₂ hj₁ hj₂
  obtain hi₁ | ⟨i, rfl, hi₁⟩ := hi₁
  · obtain hi₂ | ⟨i', rfl, _⟩ := hi₂
    swap
    · have := Enumeration.lt_bound _ _ ⟨_, hi₁⟩
      simp only [add_lt_iff_neg_left] at this
      cases (κ_zero_le i').not_lt this
    cases (Enumeration.rel_coinjective _).coinjective hi₁ hi₂
    obtain hj₁ | ⟨j, rfl, hj₁⟩ := hj₁
    · obtain hj₂ | ⟨j', rfl, _⟩ := hj₂
      · exact (Enumeration.rel_coinjective _).coinjective hj₂ hj₁
      · have := Enumeration.lt_bound _ _ ⟨_, hj₁⟩
        simp only [add_lt_iff_neg_left] at this
        cases (κ_zero_le j').not_lt this
    · obtain hj₂ | hj₂ := hj₂
      · have := Enumeration.lt_bound _ _ ⟨_, hj₂⟩
        simp only [add_lt_iff_neg_left] at this
        cases (κ_zero_le j).not_lt this
      · simp only [add_right_inj, exists_eq_left] at hj₂
        obtain ⟨B, rfl⟩ := eq_of_atom_mem_scoderiv_botDeriv ⟨j, hj₁⟩
        simp only [scoderiv_botDeriv_eq, smul_derivBot, add_derivBot, BaseSupport.smul_atoms,
          BaseSupport.add_atoms, Enumeration.smul_rel, add_right_inj, exists_eq_left] at hj₁ hj₂
        have := (Enumeration.rel_coinjective _).coinjective hj₁ hj₂
        rw [← (hρ₂ B).1 a₁ ⟨_, hi₁⟩, inv_smul_smul, inv_smul_eq_iff, (hρ₁ B).1 a₁ ⟨_, hi₁⟩] at this
        exact this.symm
  · obtain ⟨B, rfl⟩ := eq_of_atom_mem_scoderiv_botDeriv ⟨i, hi₁⟩
    simp only [scoderiv_botDeriv_eq, smul_derivBot, add_derivBot, BaseSupport.smul_atoms,
      BaseSupport.add_atoms, Enumeration.smul_rel, add_right_inj, exists_eq_left] at hi₁ hi₂ hj₁ hj₂
    obtain hi₂ | hi₂ := hi₂
    · have := Enumeration.lt_bound _ _ ⟨_, hi₂⟩
      simp only [add_lt_iff_neg_left] at this
      cases (κ_zero_le i).not_lt this
    have hi := (Enumeration.rel_coinjective _).coinjective hi₁ hi₂
    suffices hj : (ρ₁ᵁ B)⁻¹ • a₂ = (ρ₂ᵁ B)⁻¹ • a₃ by
      rwa [← hj, smul_left_cancel_iff] at hi
    obtain hj₁ | ⟨j, rfl, hj₁⟩ := hj₁
    · obtain hj₂ | ⟨j', rfl, _⟩ := hj₂
      · rw [← (hρ₁ B).1 a₂ ⟨_, hj₁⟩, ← (hρ₂ B).1 a₃ ⟨_, hj₂⟩, inv_smul_smul, inv_smul_smul]
        exact (Enumeration.rel_coinjective _).coinjective hj₁ hj₂
      · have := Enumeration.lt_bound _ _ ⟨_, hj₁⟩
        simp only [add_lt_iff_neg_left] at this
        cases (κ_zero_le j').not_lt this
    · obtain hj₂ | hj₂ := hj₂
      · have := Enumeration.lt_bound _ _ ⟨_, hj₂⟩
        simp only [add_lt_iff_neg_left] at this
        cases (κ_zero_le j).not_lt this
      · simp only [add_right_inj, exists_eq_left] at hj₂
        exact (Enumeration.rel_coinjective _).coinjective hj₁ hj₂


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)ᴬ :=
  rfl

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

theorem ext' {S T : Support α} (h₁ : Sᴬ = Tᴬ) (h₂ : Sᴺ = Tᴺ) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  cases h₁
  cases h₂
  rfl

@[ext]
theorem ext {S T : Support α} (h : ∀ A, S ⇘. A = T ⇘. A) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  rw [mk.injEq]
  constructor
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.atoms_congr (h A)
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.nearLitters_congr (h A)

@[simp]
theorem deriv_derivBot {α : TypeIndex} (S : Support α)
    (A : α ↝ β) (B : β ↝ ⊥) :
    S ⇘ A ⇘. B = S ⇘. (A ⇘ B) :=
  rfl

@[simp]
theorem coderiv_deriv_eq {α β : TypeIndex} (S : Support β) (A : α ↝ β) :
    S ⇗ A ⇘ A = S :=
  ext' (Sᴬ.coderiv_deriv_eq A) (Sᴺ.coderiv_deriv_eq A)

theorem eq_of_atom_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {a : Atom} (ha : a ∈ (S ↗ h ⇘. A)ᴬ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv ha

theorem eq_of_nearLitter_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {N : NearLitter} (hN : N ∈ (S ↗ h ⇘. A)ᴺ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv hN

@[simp]
theorem scoderiv_botDeriv_eq {α β : TypeIndex} (S : Support β) (A : β ↝ ⊥) (h : β < α) :
    S ↗ h ⇘. (A ↗ h) = S ⇘. A :=
  BaseSupport.ext (Enumeration.scoderiv_botDeriv_eq _ _ _) (Enumeration.scoderiv_botDeriv_eq _ _ _)

@[simp]
theorem scoderiv_deriv_eq {α β γ : TypeIndex} (S : Support β) (A : β ↝ γ) (h : β < α) :
    S ↗ h ⇘ (A ↗ h) = S ⇘ A := by
  apply ext
  intro B
  simp only [deriv_derivBot, ← scoderiv_botDeriv_eq S (A ⇘ B) h, Path.coderiv_deriv']

@[simp]
theorem coderiv_inj {α β : TypeIndex} (S T : Support β) (A : α ↝ β) :
    S ⇗ A = T ⇗ A ↔ S = T := by
  constructor
  swap
  · rintro rfl
    rfl
  intro h
  ext B : 1
  have : S ⇗ A ⇘ A ⇘. B = T ⇗ A ⇘ A ⇘. B := by rw [h]
  rwa [coderiv_deriv_eq, coderiv_deriv_eq] at this

@[simp]
theorem scoderiv_inj {α β : TypeIndex} (S T : Support β) (h : β < α) :
    S ↗ h = T ↗ h ↔ S = T :=
  coderiv_inj S T (.single h)

instance {α : TypeIndex} : SMul (StrPerm α) (Support α) where
  smul π S := ⟨π • Sᴬ, π • Sᴺ⟩

@[simp]
theorem smul_atoms {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴬ = π • Sᴬ :=
  rfl

@[simp]
theorem smul_nearLitters {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴺ = π • Sᴺ :=
  rfl

theorem smul_atoms_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴬ = Sᴬ := by
  rw [← smul_atoms, h]

theorem smul_nearLitters_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴺ = Sᴺ := by
  rw [← smul_nearLitters, h]

instance {α : TypeIndex} : MulAction (StrPerm α) (Support α) 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]

@[simp]
theorem smul_derivBot {α : TypeIndex} (π : StrPerm α) (S : Support α) (A : α ↝ ⊥) :
    (π • S) ⇘. A = π A • (S ⇘. A) :=
  rfl

theorem smul_coderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (A : α ↝ β) :
    π • S ⇗ A = (π ⇘ A • S) ⇗ A := by
  ext B i x
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, a⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩

theorem smul_scoderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (h : β < α) :
    π • S ↗ h = (π ↘ h • S) ↗ h :=
  smul_coderiv π S (Path.single h)

theorem smul_eq_smul_iff (π₁ π₂ : StrPerm β) (S : Support β) :
    π₁ • S = π₂ • S ↔
      ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π₁ A • a = π₂ A • a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π₁ A • N = π₂ A • N) := by
  constructor
  · intro h A
    have := congr_arg (· ⇘. A) h
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff] at this
    exact this
  · intro h
    apply ext
    intro A
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff]
    exact h A

theorem smul_eq_iff (π : StrPerm β) (S : Support β) :
    π • S = S ↔ ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π A • a = a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π A • N = N) := by
  have := smul_eq_smul_iff π 1 S
  simp only [one_smul, Tree.one_apply] at this
  exact this

noncomputable instance : Add (Support α) where
  add S T := ⟨Sᴬ + Tᴬ, Sᴺ + Tᴺ⟩

@[simp]
theorem add_derivBot (S T : Support α) (A : α ↝ ⊥) :
    (S + T) ⇘. A = (S ⇘. A) + (T ⇘. A) :=
  rfl

theorem smul_add (S T : Support α) (π : StrPerm α) :
    π • (S + T) = π • S + π • T :=
  rfl

theorem add_inj_of_bound_eq_bound {S T U V : Support α}
    (ha : Sᴬ.bound = Tᴬ.bound) (hN : Sᴺ.bound = Tᴺ.bound)
    (h' : S + U = T + V) : S = T ∧ U = V := by
  have ha' := Enumeration.add_inj_of_bound_eq_bound ha (congr_arg (·ᴬ) h')
  have hN' := Enumeration.add_inj_of_bound_eq_bound hN (congr_arg (·ᴺ) h')
  constructor
  · exact Support.ext' ha'.1 hN'.1
  · exact Support.ext' ha'.2 hN'.2

end Support

def supportEquiv {α : TypeIndex} : Support α ≃
    Enumeration (α ↝ ⊥ × Atom) × Enumeration (α ↝ ⊥ × NearLitter) where
  toFun S := (Sᴬ, Sᴺ)
  invFun S := ⟨S.1, S.2⟩
  left_inv _ := rfl
  right_inv _ := rfl

theorem card_support {α : TypeIndex} : #(Support α) = #μ := by
  rw [Cardinal.eq.mpr ⟨supportEquiv⟩, mk_prod, lift_id, lift_id,
    card_enumeration_eq, card_enumeration_eq, mul_eq_self aleph0_lt_μ.le]
  · rw [mk_prod, lift_id, lift_id, card_nearLitter,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]
  · rw [mk_prod, lift_id, lift_id, card_atom,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]

/-!
## Orders on supports
-/

-- TODO: Is this order used?
instance : LE BaseSupport where
  le S T := (∀ a ∈ Sᴬ, a ∈ Tᴬ) ∧ (∀ N ∈ Sᴺ, N ∈ Tᴺ)

instance : Preorder BaseSupport where
  le_refl S := ⟨λ _ ↦ id, λ _ ↦ id⟩
  le_trans S T U h₁ h₂ := ⟨λ a h ↦ h₂.1 _ (h₁.1 a h), λ N h ↦ h₂.2 _ (h₁.2 N h)⟩

theorem BaseSupport.smul_le_smul {S T : BaseSupport} (h : S ≤ T) (π : BasePerm) :
    π • S ≤ π • T := by
  constructor
  · intro a
    exact h.1 (π⁻¹ • a)
  · intro N
    exact h.2 (π⁻¹ • N)

theorem BaseSupport.le_add_right {S T : BaseSupport} :
    S ≤ S + T := by
  constructor
  · intro a ha
    simp only [Support.add_derivBot, BaseSupport.add_atoms, Enumeration.mem_add_iff]
    exact Or.inl ha
  · intro N hN
    simp only [Support.add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
    exact Or.inl hN

theorem BaseSupport.le_add_left {S T : BaseSupport} :
    S ≤ T + S

:= by
  constructor
  · intro a ha
    simp only [add_atoms, Enumeration.mem_add_iff]
    exact Or.inr ha
  · intro N hN
    simp only [add_nearLitters, Enumeration.mem_add_iff]
    exact Or.inr hN


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)ᴬ :=
  rfl

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

theorem ext' {S T : Support α} (h₁ : Sᴬ = Tᴬ) (h₂ : Sᴺ = Tᴺ) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  cases h₁
  cases h₂
  rfl

@[ext]
theorem ext {S T : Support α} (h : ∀ A, S ⇘. A = T ⇘. A) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  rw [mk.injEq]
  constructor
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.atoms_congr (h A)
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.nearLitters_congr (h A)

@[simp]
theorem deriv_derivBot {α : TypeIndex} (S : Support α)
    (A : α ↝ β) (B : β ↝ ⊥) :
    S ⇘ A ⇘. B = S ⇘. (A ⇘ B) :=
  rfl

@[simp]
theorem coderiv_deriv_eq {α β : TypeIndex} (S : Support β) (A : α ↝ β) :
    S ⇗ A ⇘ A = S :=
  ext' (Sᴬ.coderiv_deriv_eq A) (Sᴺ.coderiv_deriv_eq A)

theorem eq_of_atom_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {a : Atom} (ha : a ∈ (S ↗ h ⇘. A)ᴬ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv ha

theorem eq_of_nearLitter_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {N : NearLitter} (hN : N ∈ (S ↗ h ⇘. A)ᴺ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv hN

@[simp]
theorem scoderiv_botDeriv_eq {α β : TypeIndex} (S : Support β) (A : β ↝ ⊥) (h : β < α) :
    S ↗ h ⇘. (A ↗ h) = S ⇘. A :=
  BaseSupport.ext (Enumeration.scoderiv_botDeriv_eq _ _ _) (Enumeration.scoderiv_botDeriv_eq _ _ _)

@[simp]
theorem scoderiv_deriv_eq {α β γ : TypeIndex} (S : Support β) (A : β ↝ γ) (h : β < α) :
    S ↗ h ⇘ (A ↗ h) = S ⇘ A := by
  apply ext
  intro B
  simp only [deriv_derivBot, ← scoderiv_botDeriv_eq S (A ⇘ B) h, Path.coderiv_deriv']

@[simp]
theorem coderiv_inj {α β : TypeIndex} (S T : Support β) (A : α ↝ β) :
    S ⇗ A = T ⇗ A ↔ S = T := by
  constructor
  swap
  · rintro rfl
    rfl
  intro h
  ext B : 1
  have : S ⇗ A ⇘ A ⇘. B = T ⇗ A ⇘ A ⇘. B := by rw [h]
  rwa [coderiv_deriv_eq, coderiv_deriv_eq] at this

@[simp]
theorem scoderiv_inj {α β : TypeIndex} (S T : Support β) (h : β < α) :
    S ↗ h = T ↗ h ↔ S = T :=
  coderiv_inj S T (.single h)

instance {α : TypeIndex} : SMul (StrPerm α) (Support α) where
  smul π S := ⟨π • Sᴬ, π • Sᴺ⟩

@[simp]
theorem smul_atoms {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴬ = π • Sᴬ :=
  rfl

@[simp]
theorem smul_nearLitters {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴺ = π • Sᴺ :=
  rfl

theorem smul_atoms_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴬ = Sᴬ := by
  rw [← smul_atoms, h]

theorem smul_nearLitters_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴺ = Sᴺ := by
  rw [← smul_nearLitters, h]

instance {α : TypeIndex} : MulAction (StrPerm α) (Support α) 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]

@[simp]
theorem smul_derivBot {α : TypeIndex} (π : StrPerm α) (S : Support α) (A : α ↝ ⊥) :
    (π • S) ⇘. A = π A • (S ⇘. A) :=
  rfl

theorem smul_coderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (A : α ↝ β) :
    π • S ⇗ A = (π ⇘ A • S) ⇗ A := by
  ext B i x
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, a⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩

theorem smul_scoderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (h : β < α) :
    π • S ↗ h = (π ↘ h • S) ↗ h :=
  smul_coderiv π S (Path.single h)

theorem smul_eq_smul_iff (π₁ π₂ : StrPerm β) (S : Support β) :
    π₁ • S = π₂ • S ↔
      ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π₁ A • a = π₂ A • a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π₁ A • N = π₂ A • N) := by
  constructor
  · intro h A
    have := congr_arg (· ⇘. A) h
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff] at this
    exact this
  · intro h
    apply ext
    intro A
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff]
    exact h A

theorem smul_eq_iff (π : StrPerm β) (S : Support β) :
    π • S = S ↔ ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π A • a = a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π A • N = N) := by
  have := smul_eq_smul_iff π 1 S
  simp only [one_smul, Tree.one_apply] at this
  exact this

noncomputable instance : Add (Support α) where
  add S T := ⟨Sᴬ + Tᴬ, Sᴺ + Tᴺ⟩

@[simp]
theorem add_derivBot (S T : Support α) (A : α ↝ ⊥) :
    (S + T) ⇘. A = (S ⇘. A) + (T ⇘. A) :=
  rfl

theorem smul_add (S T : Support α) (π : StrPerm α) :
    π • (S + T) = π • S + π • T :=
  rfl

theorem add_inj_of_bound_eq_bound {S T U V : Support α}
    (ha : Sᴬ.bound = Tᴬ.bound) (hN : Sᴺ.bound = Tᴺ.bound)
    (h' : S + U = T + V) : S = T ∧ U = V := by
  have ha' := Enumeration.add_inj_of_bound_eq_bound ha (congr_arg (·ᴬ) h')
  have hN' := Enumeration.add_inj_of_bound_eq_bound hN (congr_arg (·ᴺ) h')
  constructor
  · exact Support.ext' ha'.1 hN'.1
  · exact Support.ext' ha'.2 hN'.2

end Support

def supportEquiv {α : TypeIndex} : Support α ≃
    Enumeration (α ↝ ⊥ × Atom) × Enumeration (α ↝ ⊥ × NearLitter) where
  toFun S := (Sᴬ, Sᴺ)
  invFun S := ⟨S.1, S.2⟩
  left_inv _ := rfl
  right_inv _ := rfl

theorem card_support {α : TypeIndex} : #(Support α) = #μ := by
  rw [Cardinal.eq.mpr ⟨supportEquiv⟩, mk_prod, lift_id, lift_id,
    card_enumeration_eq, card_enumeration_eq, mul_eq_self aleph0_lt_μ.le]
  · rw [mk_prod, lift_id, lift_id, card_nearLitter,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]
  · rw [mk_prod, lift_id, lift_id, card_atom,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]

/-!
## Orders on supports
-/

-- TODO: Is this order used?
instance : LE BaseSupport where
  le S T := (∀ a ∈ Sᴬ, a ∈ Tᴬ) ∧ (∀ N ∈ Sᴺ, N ∈ Tᴺ)

instance : Preorder BaseSupport where
  le_refl S := ⟨λ _ ↦ id, λ _ ↦ id⟩
  le_trans S T U h₁ h₂ := ⟨λ a h ↦ h₂.1 _ (h₁.1 a h), λ N h ↦ h₂.2 _ (h₁.2 N h)⟩

theorem BaseSupport.smul_le_smul {S T : BaseSupport} (h : S ≤ T) (π : BasePerm) :
    π • S ≤ π • T := by
  constructor
  · intro a
    exact h.1 (π⁻¹ • a)
  · intro N
    exact h.2 (π⁻¹ • N)

theorem BaseSupport.le_add_right {S T : BaseSupport} :
    S ≤ S + T

:= by
  constructor
  · intro a ha
    simp only [Support.add_derivBot, BaseSupport.add_atoms, Enumeration.mem_add_iff]
    exact Or.inl ha
  · intro N hN
    simp only [Support.add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
    exact Or.inl hN


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']


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)ᴬ :=
  rfl

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

theorem ext' {S T : Support α} (h₁ : Sᴬ = Tᴬ) (h₂ : Sᴺ = Tᴺ) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  cases h₁
  cases h₂
  rfl

@[ext]
theorem ext {S T : Support α} (h : ∀ A, S ⇘. A = T ⇘. A) : S = T := by
  obtain ⟨SA, SN⟩ := S
  obtain ⟨TA, TN⟩ := T
  rw [mk.injEq]
  constructor
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.atoms_congr (h A)
  · apply Enumeration.ext_path
    intro A
    exact BaseSupport.nearLitters_congr (h A)

@[simp]
theorem deriv_derivBot {α : TypeIndex} (S : Support α)
    (A : α ↝ β) (B : β ↝ ⊥) :
    S ⇘ A ⇘. B = S ⇘. (A ⇘ B) :=
  rfl

@[simp]
theorem coderiv_deriv_eq {α β : TypeIndex} (S : Support β) (A : α ↝ β) :
    S ⇗ A ⇘ A = S :=
  ext' (Sᴬ.coderiv_deriv_eq A) (Sᴺ.coderiv_deriv_eq A)

theorem eq_of_atom_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {a : Atom} (ha : a ∈ (S ↗ h ⇘. A)ᴬ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv ha

theorem eq_of_nearLitter_mem_scoderiv_botDeriv {α β : TypeIndex} {S : Support β} {A : α ↝ ⊥}
    {h : β < α} {N : NearLitter} (hN : N ∈ (S ↗ h ⇘. A)ᴺ) :
    ∃ B : β ↝ ⊥, A = B ↗ h :=
  Enumeration.eq_of_mem_scoderiv_botDeriv hN

@[simp]
theorem scoderiv_botDeriv_eq {α β : TypeIndex} (S : Support β) (A : β ↝ ⊥) (h : β < α) :
    S ↗ h ⇘. (A ↗ h) = S ⇘. A :=
  BaseSupport.ext (Enumeration.scoderiv_botDeriv_eq _ _ _) (Enumeration.scoderiv_botDeriv_eq _ _ _)

@[simp]
theorem scoderiv_deriv_eq {α β γ : TypeIndex} (S : Support β) (A : β ↝ γ) (h : β < α) :
    S ↗ h ⇘ (A ↗ h) = S ⇘ A := by
  apply ext
  intro B
  simp only [deriv_derivBot, ← scoderiv_botDeriv_eq S (A ⇘ B) h, Path.coderiv_deriv']

@[simp]
theorem coderiv_inj {α β : TypeIndex} (S T : Support β) (A : α ↝ β) :
    S ⇗ A = T ⇗ A ↔ S = T := by
  constructor
  swap
  · rintro rfl
    rfl
  intro h
  ext B : 1
  have : S ⇗ A ⇘ A ⇘. B = T ⇗ A ⇘ A ⇘. B := by rw [h]
  rwa [coderiv_deriv_eq, coderiv_deriv_eq] at this

@[simp]
theorem scoderiv_inj {α β : TypeIndex} (S T : Support β) (h : β < α) :
    S ↗ h = T ↗ h ↔ S = T :=
  coderiv_inj S T (.single h)

instance {α : TypeIndex} : SMul (StrPerm α) (Support α) where
  smul π S := ⟨π • Sᴬ, π • Sᴺ⟩

@[simp]
theorem smul_atoms {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴬ = π • Sᴬ :=
  rfl

@[simp]
theorem smul_nearLitters {α : TypeIndex} (π : StrPerm α) (S : Support α) :
    (π • S)ᴺ = π • Sᴺ :=
  rfl

theorem smul_atoms_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴬ = Sᴬ := by
  rw [← smul_atoms, h]

theorem smul_nearLitters_eq_of_smul_eq {α : TypeIndex} {π : StrPerm α} {S : Support α}
    (h : π • S = S) :
    π • Sᴺ = Sᴺ := by
  rw [← smul_nearLitters, h]

instance {α : TypeIndex} : MulAction (StrPerm α) (Support α) 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]

@[simp]
theorem smul_derivBot {α : TypeIndex} (π : StrPerm α) (S : Support α) (A : α ↝ ⊥) :
    (π • S) ⇘. A = π A • (S ⇘. A) :=
  rfl

theorem smul_coderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (A : α ↝ β) :
    π • S ⇗ A = (π ⇘ A • S) ⇗ A := by
  ext B i x
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩
  · rfl
  · constructor
    · rintro ⟨⟨C, x⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, x⟩, hS, rfl⟩
    · rintro ⟨⟨C, a⟩, hS, hx⟩
      simp only [Prod.mk.injEq] at hx
      obtain ⟨rfl, rfl⟩ := hx
      exact ⟨⟨C, _⟩, hS, rfl⟩

theorem smul_scoderiv {α : TypeIndex} (π : StrPerm α) (S : Support β) (h : β < α) :
    π • S ↗ h = (π ↘ h • S) ↗ h :=
  smul_coderiv π S (Path.single h)

theorem smul_eq_smul_iff (π₁ π₂ : StrPerm β) (S : Support β) :
    π₁ • S = π₂ • S ↔
      ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π₁ A • a = π₂ A • a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π₁ A • N = π₂ A • N) := by
  constructor
  · intro h A
    have := congr_arg (· ⇘. A) h
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff] at this
    exact this
  · intro h
    apply ext
    intro A
    simp only [smul_derivBot, BaseSupport.smul_eq_smul_iff]
    exact h A

theorem smul_eq_iff (π : StrPerm β) (S : Support β) :
    π • S = S ↔ ∀ A, (∀ a ∈ (S ⇘. A)ᴬ, π A • a = a) ∧ (∀ N ∈ (S ⇘. A)ᴺ, π A • N = N) := by
  have := smul_eq_smul_iff π 1 S
  simp only [one_smul, Tree.one_apply] at this
  exact this

noncomputable instance : Add (Support α) where
  add S T := ⟨Sᴬ + Tᴬ, Sᴺ + Tᴺ⟩

@[simp]
theorem add_derivBot (S T : Support α) (A : α ↝ ⊥) :
    (S + T) ⇘. A = (S ⇘. A) + (T ⇘. A) :=
  rfl

theorem smul_add (S T : Support α) (π : StrPerm α) :
    π • (S + T) = π • S + π • T :=
  rfl

theorem add_inj_of_bound_eq_bound {S T U V : Support α}
    (ha : Sᴬ.bound = Tᴬ.bound) (hN : Sᴺ.bound = Tᴺ.bound)
    (h' : S + U = T + V) : S = T ∧ U = V := by
  have ha' := Enumeration.add_inj_of_bound_eq_bound ha (congr_arg (·ᴬ) h')
  have hN' := Enumeration.add_inj_of_bound_eq_bound hN (congr_arg (·ᴺ) h')
  constructor
  · exact Support.ext' ha'.1 hN'.1
  · exact Support.ext' ha'.2 hN'.2

end Support

def supportEquiv {α : TypeIndex} : Support α ≃
    Enumeration (α ↝ ⊥ × Atom) × Enumeration (α ↝ ⊥ × NearLitter) where
  toFun S := (Sᴬ, Sᴺ)
  invFun S := ⟨S.1, S.2⟩
  left_inv _ := rfl
  right_inv _ := rfl

theorem card_support {α : TypeIndex} : #(Support α) = #μ := by
  rw [Cardinal.eq.mpr ⟨supportEquiv⟩, mk_prod, lift_id, lift_id,
    card_enumeration_eq, card_enumeration_eq, mul_eq_self aleph0_lt_μ.le]
  · rw [mk_prod, lift_id, lift_id, card_nearLitter,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]
  · rw [mk_prod, lift_id, lift_id, card_atom,
      mul_eq_right aleph0_lt_μ.le (card_path_lt' α ⊥).le (card_path_ne_zero α)]

/-!
## Orders on supports
-/

-- TODO: Is this order used?
instance : LE BaseSupport where
  le S T := (∀ a ∈ Sᴬ, a ∈ Tᴬ) ∧ (∀ N ∈ Sᴺ, N ∈ Tᴺ)

instance : Preorder BaseSupport where
  le_refl S := ⟨λ _ ↦ id, λ _ ↦ id⟩
  le_trans S T U h₁ h₂ := ⟨λ a h ↦ h₂.1 _ (h₁.1 a h), λ N h ↦ h₂.2 _ (h₁.2 N h)⟩

theorem BaseSupport.smul_le_smul {S T : BaseSupport} (h : S ≤ T) (π : BasePerm) :
    π • S ≤ π • T := by
  constructor
  · intro a
    exact h.1 (π⁻¹ • a)
  · intro N
    exact h.2 (π⁻¹ • N)

theorem BaseSupport.le_add_right {S T : BaseSupport} :
    S ≤ S + T := by
  constructor
  · intro a ha
    simp only [Support.add_derivBot, BaseSupport.add_atoms, Enumeration.mem_add_iff]
    exact Or.inl ha
  · intro N hN
    simp only [Support.add_derivBot, BaseSupport.add_nearLitters, Enumeration.mem_add_iff]
    exact Or.inl hN

theorem BaseSupport.le_add_left {S T : BaseSupport} :
    S ≤ T + S := by
  constructor
  · intro a ha
    simp only [add_atoms, Enumeration.mem_add_iff]
    exact Or.inr ha
  · intro N hN
    simp only [add_nearLitters, Enumeration.mem_add_iff]
    exact Or.inr hN

def BaseSupport.Subsupport (S T : BaseSupport) : Prop :=
  Sᴬ.rel ≤ Tᴬ.rel ∧ Sᴺ.rel ≤ Tᴺ.rel

theorem BaseSupport.Subsupport.le {S T : BaseSupport}
    (h : S.Subsupport T) : S ≤ T := by
  constructor
  · rintro a ⟨i, hi⟩
    exact ⟨i, h.1 i a hi⟩
  · rintro N ⟨i, hi⟩
    exact ⟨i, h.2 i N hi⟩

theorem BaseSupport.Subsupport.trans {S T U : BaseSupport}
    (h₁ : S.Subsupport T) (h₂ : T.Subsupport U) :
    S.Subsupport U :=
  ⟨h₁.1.trans h₂.1, h₁.2.trans h₂.2⟩

theorem BaseSupport.smul_subsupport_smul {S T : BaseSupport} (h : S.Subsupport T) (π : BasePerm) :
    (π • S).Subsupport (π • T) := by
  constructor
  · intro i a ha
    exact h.1 i _ ha
  · intro i N hN
    exact h.2 i _ hN

instance {α : TypeIndex} : LE (Support α) where
  le S T := ∀ A, S ⇘. A ≤ T ⇘. A

instance {α : TypeIndex} : Preorder (Support α) where
  le_refl S := λ A ↦ le_rfl
  le_trans S T U h₁ h₂ := λ A ↦ (h₁ A).trans (h₂ A)

theorem Support.smul_le_smul {α : TypeIndex} {S T : Support α} (h : S ≤ T) (π : StrPerm α) :
    π • S ≤ π • T :=
  λ A ↦ BaseSupport.smul_le_smul (h A) (π A)

theorem Support.le_add_right {α : TypeIndex} {S T : Support α} :
    S ≤ S + T

:= by
  intro A
  rw [add_derivBot]
  exact BaseSupport.le_add_right


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]


import ConNF.Model.RunInduction

/-!
# Externalisation

In this file, we convert many of our *internal* results (i.e. inside the induction) to *external*
ones (i.e. defined using the global `TSet`/`AllPerm` definitions).

## Main declarations

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

noncomputable section
universe u

open Cardinal Ordinal WithBot

namespace ConNF

variable [Params.{u}]

instance globalModelData : {α : TypeIndex} → ModelData α
  | (α : Λ) => (motive α).data
  | ⊥ => botModelData

instance globalPosition : {α : TypeIndex} → Position (Tangle α)
  | (α : Λ) => (motive α).pos
  | ⊥ => botPosition

instance globalTypedNearLitters {α : Λ} : TypedNearLitters α :=
  (motive α).typed

instance globalLtData [Level] : LtData where

instance globalLeData [Level] : LeData where

omit [Params] in
theorem heq_funext {α : Sort _} {β γ : α → Sort _} {f : (x : α) → β x} {g : (x : α) → γ x}
    (h : ∀ x, HEq (f x) (g x)) : HEq f g := by
  cases funext λ x ↦ type_eq_of_heq (h x)
  simp only [heq_eq_eq] at h ⊢
  exact funext h

theorem globalLtData_eq [Level] :
    globalLtData = ltData (λ β _ ↦ motive β) := by
  apply LtData.ext
  · ext β hβ
    induction β using recBotCoe
    case bot => rfl
    case coe β => rfl
  · apply heq_funext
    intro β
    induction β using recBotCoe
    case bot => rfl
    case coe β => rfl
  · rfl

theorem globalLeData_eq [Level] :
    globalLeData = leData (λ β _ ↦ motive β) := by
  apply LeData.ext
  · ext β hβ
    induction β using recBotCoe
    case bot => rfl
    case coe β =>
      by_cases h : (β : TypeIndex) = α
      · cases coe_injective h
        rw [leData_data_eq]
        unfold globalLeData globalModelData
        dsimp only
        rw [motive_eq]
        rfl
      · rw [leData_data_lt _ (hβ.elim.lt_of_ne h)]
        rfl
  · apply heq_funext
    intro β
    apply heq_funext
    intro hβ
    induction β using recBotCoe
    case bot => rfl
    case coe β =>
      rw [leData]
      simp only [coe_inj, id_eq, eq_mpr_eq_cast, recBotCoe_bot, recBotCoe_coe, LtLevel.elim.ne]
      exact HEq.symm (cast_heq _ _)

instance globalPreCoherentData [Level] : PreCoherentData where
  allPermSderiv h := cast (by rw [globalLeData_eq])
    ((preCoherentData (λ β _ ↦ motive β) (λ β _ ↦ hypothesis β)).allPermSderiv h)
  singleton h := cast (by rw [globalLeData_eq])
    ((preCoherentData (λ β _ ↦ motive β) (λ β _ ↦ hypothesis β)).singleton h)

omit [Params] in
@[simp]
theorem heq_cast_eq_iff {α β γ : Type _} {x : α} {y : β} {h : α = γ} :
    HEq (cast h x) y ↔ HEq x y := by
  cases h
  rw [cast_eq]

theorem globalPreCoherentData_eq [Level] :
    globalPreCoherentData = preCoherentData (λ β _ ↦ motive β) (λ β _ ↦ hypothesis β)

:= by
  have := globalLeData_eq
  rw [LeData.ext_iff] at this
  apply PreCoherentData.ext
  · exact this.1
  · exact this.2
  · unfold globalPreCoherentData
    apply heq_funext; intro β
    apply heq_funext; intro γ
    apply heq_funext; intro hβ
    apply heq_funext; intro hγ
    apply heq_funext; intro hβγ
    simp only [heq_cast_eq_iff]
    rfl
  · unfold globalPreCoherentData
    apply heq_funext; intro β
    apply heq_funext; intro γ
    apply heq_funext; intro hβ
    apply heq_funext; intro hγ
    apply heq_funext; intro hβγ
    simp only [heq_cast_eq_iff]
    rfl


import ConNF.Model.Externalise

/-!
# 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) < β}

namespace Support

theorem not_mem_scoderiv_botDeriv (S : Support γ) (N : NearLitter) :
    N ∉ (S ↗ hγ ⇘. (Path.nil ↘.))ᴺ

:= by
  rintro ⟨i, ⟨A, N'⟩, h₁, h₂⟩
  simp only [Prod.mk.injEq] at h₂
  cases A
  case sderiv δ A hδ _ =>
    simp only [Path.deriv_sderiv] at h₂
    cases A
    case nil => cases h₂.1
    case sderiv ζ A hζ _ =>
      simp only [Path.deriv_sderiv] at h₂
      cases h₂.1


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 ρ  -- For some reason, using `exact` instead of term mode speeds this up!

def singleton {α β : Λ} (hβ : (β : TypeIndex) < α) (x : TSet β) : TSet α :=
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  PreCoherentData.singleton hβ x

@[simp]
theorem typedMem_singleton_iff' {α β : Λ} (hβ : (β : TypeIndex) < α) (x y : TSet β) :
    y ∈[hβ] singleton hβ x ↔ y = x :=
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  typedMem_singleton_iff hβ x y

@[simp]
theorem smul_singleton {α β : Λ} (hβ : (β : TypeIndex) < α) (x : TSet β) (ρ : AllPerm α) :
    ρ • singleton hβ x = singleton hβ (ρ ↘ hβ • x) := by
  apply tSet_ext' hβ
  intro z
  rw [TSet.mem_smul_iff', allPerm_inv_sderiv', typedMem_singleton_iff', typedMem_singleton_iff',
    inv_smul_eq_iff]

theorem singleton_injective {α β : Λ} (hβ : (β : TypeIndex) < α) :
    Function.Injective (singleton hβ) := by
  intro x y hxy
  have := typedMem_singleton_iff' hβ x y
  rw [hxy, typedMem_singleton_iff'] at this
  exact (this.mp rfl).symm

@[simp]
theorem singleton_inj {α β : Λ} {hβ : (β : TypeIndex) < α} {x y : TSet β} :
    singleton hβ x = singleton hβ y ↔ x = y :=
  (singleton_injective hβ).eq_iff

theorem sUnion_singleton_symmetric_aux' {α β γ : Λ}
    (hγ : (γ : TypeIndex) < β) (hβ : (β : TypeIndex) < α) (s : Set (TSet γ)) (S : Support α)
    (hS : ∀ ρ : AllPerm α, ρᵁ • S = S → ρ ↘ hβ • singleton hγ '' s = singleton hγ '' s) :
    letI : Level := ⟨α⟩
    letI : LeLevel α := ⟨le_rfl⟩
    ∀ (ρ : AllPerm β), ρᵁ • S.strong ↘ hβ = S.strong ↘ hβ → ρ ↘ hγ • s ⊆ s

:= by
  letI : Level := ⟨α⟩
  letI : LeLevel α := ⟨le_rfl⟩
  letI : LtLevel β := ⟨hβ⟩
  rintro ρ hρ _ ⟨x, hx, rfl⟩
  obtain ⟨T, hT⟩ := exists_support x
  obtain ⟨ρ', hρ'₁, hρ'₂⟩ := Support.exists_allowable_of_fixes S.strong S.strong_strong T ρ hγ hρ
  have hρ's := hS ρ' (smul_eq_of_le (S.subsupport_strong.le) hρ'₁)
  have hρ'x : ρ' ↘ hβ ↘ hγ • x = ρ ↘ hγ • x := by
    apply hT.smul_eq_smul
    simp only [allPermSderiv_forget', allPermSderiv_forget, WithBot.recBotCoe_coe, id_eq, hρ'₂]
  dsimp only
  rw [← hρ'x]
  have := (Set.ext_iff.mp hρ's (ρ' ↘ hβ • singleton hγ x)).mp ⟨_, Set.mem_image_of_mem _ hx, rfl⟩
  rw [smul_singleton] at this
  rwa [(singleton_injective hγ).mem_set_image] at this


import ConNF.Background.Rel
import ConNF.Base.Small

/-!
# Enumerations

In this file, we define enumerations of a type.

## Main declarations

* `ConNF.Enumeration`: The type family of enumerations.
-/

universe u

open Cardinal

namespace ConNF

variable [Params.{u}] {X Y : Type u}

@[ext]
structure Enumeration (X : Type u) where
  bound : κ
  rel : Rel κ X
  lt_bound : ∀ i ∈ rel.dom, i < bound
  rel_coinjective : rel.Coinjective

variable {E F G : Enumeration X}

namespace Enumeration

instance : CoeTC (Enumeration X) (Set X) where
  coe E := E.rel.codom

instance : Membership X (Enumeration X) where
  mem E x := x ∈ E.rel.codom

theorem mem_iff (x : X) (E : Enumeration X) :
    x ∈ E ↔ x ∈ E.rel.codom :=
  Iff.rfl

theorem mem_congr {E F : Enumeration X} (h : E = F) :
    ∀ x, x ∈ E ↔ x ∈ F := by
  intro x
  rw [h]

theorem dom_small (E : Enumeration X) :
    Small E.rel.dom :=
  (iio_small E.bound).mono E.lt_bound

theorem coe_small (E : Enumeration X) :
    Small (E : Set X) :=
  small_codom_of_small_dom E.rel_coinjective E.dom_small

theorem graph'_small (E : Enumeration X) :
    Small E.rel.graph' :=
  small_graph' E.dom_small E.coe_small

noncomputable def empty : Enumeration X where
  bound := 0
  rel _ _ := False
  lt_bound _ h := by cases h; contradiction
  rel_coinjective := by constructor; intros; contradiction

@[simp]
theorem not_mem_empty (x : X) : x ∉ Enumeration.empty := by
  rintro ⟨i, h⟩
  cases h

noncomputable def singleton (x : X) : Enumeration X where
  bound := 1
  rel i y := i = 0 ∧ y = x
  lt_bound i h := by
    have : i = 0 := by simpa only [Rel.dom, exists_eq_right, Set.setOf_eq_eq_singleton,
      Set.mem_singleton_iff] using h
    rw [this, κEquiv_lt, ← Subtype.coe_lt_coe, κEquiv_ofNat, κEquiv_ofNat, Nat.cast_zero,
      Nat.cast_one]
    exact zero_lt_one
  rel_coinjective := by
    constructor
    cc

@[simp]
theorem mem_singleton_iff (x y : X) :
    y ∈ singleton x ↔ y = x := by
  constructor
  · rintro ⟨_, _, h⟩
    exact h
  · intro h
    exact ⟨0, rfl, h⟩

theorem singleton_injective : Function.Injective (singleton : X → Enumeration X) := by
  intro x y h
  have := mem_singleton_iff y x
  rw [← h, mem_singleton_iff] at this
  exact this.mp rfl

/-!
## Cardinality bounds on enumerations
-/

end Enumeration

theorem card_enumeration_ge (X : Type u) : #X ≤ #(Enumeration X) :=
  mk_le_of_injective Enumeration.singleton_injective

def enumerationEmbedding (X : Type u) : Enumeration X ↪ κ × {s : Set (κ × X) | Small s} where
  toFun E := (E.bound, ⟨E.rel.graph', E.graph'_small⟩)
  inj' := by
    intro E F h
    rw [Prod.mk.injEq, Subtype.mk.injEq] at h
    exact Enumeration.ext h.1 (Rel.graph'_injective h.2)

theorem card_enumeration_le (h : #X ≤ #μ) : #(Enumeration X) ≤ #μ := by
  apply (mk_le_of_injective (enumerationEmbedding X).injective).trans
  rw [mk_prod, lift_id, lift_id]
  apply mul_le_of_le aleph0_lt_μ.le κ_le_μ
  apply card_small_le
  rw [mk_prod, lift_id, lift_id]
  exact mul_le_of_le aleph0_lt_μ.le κ_le_μ h

theorem card_enumeration_lt (h : #X < #μ) : #(Enumeration X) < #μ := by
  apply (mk_le_of_injective (enumerationEmbedding X).injective).trans_lt
  rw [mk_prod, lift_id, lift_id]
  apply mul_lt_of_lt aleph0_lt_μ.le κ_lt_μ
  apply (mk_subtype_le _).trans_lt
  rw [mk_set]
  apply μ_isStrongLimit.2
  rw [mk_prod, lift_id, lift_id]
  exact mul_lt_of_lt aleph0_lt_μ.le κ_lt_μ h

theorem card_enumeration_eq (h : #X = #μ) : #(Enumeration X) = #μ :=
  le_antisymm (card_enumeration_le h.le) (h.symm.le.trans (card_enumeration_ge X))

namespace Enumeration

/-!
## Enumerations from sets
-/

theorem exists_equiv (s : Set X) (hs : Small s) :
    Nonempty ((i : κ) × (s ≃ Set.Iio i)) := by
  rw [Small] at hs
  refine ⟨κEquiv.symm ⟨(#s).ord, ?_⟩, Nonempty.some ?_⟩
  · rwa [Set.mem_Iio, ord_lt_ord]
  · rw [← Cardinal.eq, Set.Iio, κ_card_Iio_eq, Equiv.apply_symm_apply, card_ord]

noncomputable def ofSet (s : Set X) (hs : Small s) : Enumeration X where
  bound := (exists_equiv s hs).some.1
  rel i x := ∃ h, i = (exists_equiv s hs).some.2 ⟨x, h⟩
  lt_bound := by
    rintro _ ⟨x, h, rfl⟩
    exact ((exists_equiv s hs).some.2 ⟨x, h⟩).prop
  rel_coinjective := by
    constructor
    rintro x y i ⟨hx, hix⟩ ⟨hy, hiy⟩
    rw [hix] at hiy
    cases (exists_equiv s hs).some.2.injective (Subtype.coe_injective hiy)
    rfl

@[simp]
theorem mem_ofSet_iff (s : Set X) (hs : Small s) (x : X) :
    x ∈ ofSet s hs ↔ x ∈ s := by
  constructor
  · rintro ⟨i, hx, _⟩
    exact hx
  · intro h
    exact ⟨(exists_equiv s hs).some.2 ⟨x, h⟩, h, rfl⟩

@[simp]
theorem ofSet_coe (s : Set X) (hs : Small s) :
    (ofSet s hs : Set X) = s := by
  ext x
  rw [← mem_ofSet_iff s hs]
  rfl

/-!
## Operations on enumerations
-/

def image (E : Enumeration X) (f : X → Y) : Enumeration Y where
  bound := E.bound
  rel i y := ∃ x, E.rel i x ∧ f x = y
  lt_bound := by
    rintro i ⟨_, x, hi, rfl⟩
    exact E.lt_bound i ⟨x, hi⟩
  rel_coinjective := by
    constructor
    rintro i _ _ ⟨x₁, hx₁, rfl⟩ ⟨x₂, hx₂, rfl⟩
    rw [E.rel_coinjective.coinjective hx₁ hx₂]

@[simp]
theorem image_bound {f : X → Y} :
    (E.image f).bound = E.bound :=
  rfl

theorem image_rel {f : X → Y} (i : κ) (y : Y) :
    (E.image f).rel i y ↔ ∃ x, E.rel i x ∧ f x = y :=
  Iff.rfl

@[simp]
theorem mem_image {f : X → Y} (y : Y) :
    y ∈ E.image f ↔ y ∈ f '' E := by
  constructor
  · rintro ⟨i, x, hx, rfl⟩
    exact ⟨x, ⟨i, hx⟩, rfl⟩
  · rintro ⟨x, ⟨i, hx⟩, rfl⟩
    exact ⟨i, x, hx, rfl⟩

def invImage (E : Enumeration X) (f : Y → X) (hf : f.Injective) : Enumeration Y where
  bound := E.bound
  rel i y := E.rel i (f y)
  lt_bound := by
    rintro i ⟨y, hy⟩
    exact E.lt_bound i ⟨f y, hy⟩
  rel_coinjective := by
    constructor
    intro i y₁ y₂ h₁ h₂
    exact hf <| E.rel_coinjective.coinjective h₁ h₂

theorem invImage_rel {f : Y → X} {hf : f.Injective} (i : κ) (y : Y) :
    (E.invImage f hf).rel i y ↔ E.rel i (f y) :=
  Iff.rfl

@[simp]
theorem mem_invImage {f : Y → X} {hf : f.Injective} (y : Y) :
    y ∈ E.invImage f hf ↔ f y ∈ E :=
  Iff.rfl

def comp (E : Enumeration X) (r : Rel X Y) (hr : r.Coinjective) : Enumeration Y where
  bound := E.bound
  rel := E.rel.comp r
  lt_bound := by
    rintro i ⟨y, x, hy⟩
    exact E.lt_bound i ⟨x, hy.1⟩
  rel_coinjective := E.rel_coinjective.comp hr

instance {G X : Type _} [Group G] [MulAction G X] :
    SMul G (Enumeration X) where
  smul π E := E.invImage (λ x ↦ π⁻¹ • x) (MulAction.injective π⁻¹)

@[simp]
theorem smul_rel {G X : Type _} [Group G] [MulAction G X]
    (π : G) (E : Enumeration X) (i : κ) (x : X) :
    (π • E).rel i x ↔ E.rel i (π⁻¹ • x) :=
  Iff.rfl

@[simp]
theorem mem_smul {G X : Type _} [Group G] [MulAction G X]
    (π : G) (E : Enumeration X) (x : X) :
    x ∈ π • E ↔ π⁻¹ • x ∈ E :=
  Iff.rfl

@[simp]
theorem smul_rel_dom {G X : Type _} [Group G] [MulAction G X]
    (π : G) (E : Enumeration X) :
    (π • E).rel.dom = E.rel.dom := by
  ext i
  constructor
  · rintro ⟨x, h⟩
    exact ⟨π⁻¹ • x, h⟩
  · rintro ⟨x, h⟩
    use π • x
    rwa [smul_rel, inv_smul_smul]

open scoped Pointwise in
@[simp]
theorem smul_rel_codom {G X : Type _} [Group G] [MulAction G X]
    (π : G) (E : Enumeration X) :
    (π • E).rel.codom = π • E.rel.codom := by
  ext x
  constructor
  · rintro ⟨i, h⟩
    exact ⟨π⁻¹ • x, ⟨i, h⟩, smul_inv_smul π x⟩
  · rintro ⟨x, ⟨i, h⟩, rfl⟩
    use i
    rwa [smul_rel, inv_smul_smul]

open scoped Pointwise in
@[simp]
theorem smul_coe {G X : Type _} [Group G] [MulAction G X]
    (π : G) (E : Enumeration X) :
    ((π • E : Enumeration X) : Set X) = π • (E : Set X) :=
  smul_rel_codom π E

instance {G X : Type _} [Group G] [MulAction G X] :
    MulAction G (Enumeration X) where
  one_smul E := by
    ext i x
    · rfl
    · rw [smul_rel, inv_one, one_smul]
  mul_smul π₁ π₂ E := by
    ext i x
    · rfl
    · rw [smul_rel, smul_rel, smul_rel, mul_inv_rev, mul_smul]

theorem mem_smul_iff {G X : Type _} [Group G] [MulAction G X] (x : X) (g : G) (E : Enumeration X) :
    x ∈ g • E ↔ g⁻¹ • x ∈ E :=
  Iff.rfl

theorem eq_of_smul_eq_smul {G X : Type _} [Group G] [MulAction G X] {g₁ g₂ : G} {E : Enumeration X}
    (h : g₁ • E = g₂ • E) (x : X) (hx : x ∈ E) : g₁ • x = g₂ • x := by
  obtain ⟨i, hi⟩ := hx
  have : (g₁ • E).rel i (g₁ • x) := by rwa [smul_rel, inv_smul_smul]
  rw [h] at this
  have := E.rel_coinjective.coinjective hi this
  exact (eq_inv_smul_iff.mp this).symm

theorem eq_of_smul_eq {G X : Type _} [Group G] [MulAction G X] {g : G} {E : Enumeration X}
    (h : g • E = E) (x : X) (hx : x ∈ E) : g • x = x := by
  have := eq_of_smul_eq_smul (g₁ := g) (g₂ := 1) ?_ x hx
  · rwa [one_smul] at this
  · rwa [one_smul]

@[simp]
theorem smul_singleton {G X : Type _} [Group G] [MulAction G X] {g : G} {x : X} :
    g • singleton x = singleton (g • x) := by
  apply Enumeration.ext
  · rfl
  · ext i y
    rw [smul_rel]
    simp only [singleton, and_congr_right_iff, inv_smul_eq_iff]

/-!
## Concatenation of enumerations
-/

noncomputable instance : Add (Enumeration X) where
  add E F := {
    bound := E.bound + F.bound
    rel := E.rel ⊔ Rel.comp (E.bound + ·).graph.inv F.rel
    lt_bound := by
      rintro i ⟨x, hi | ⟨j, rfl, hjx⟩⟩
      · exact (E.lt_bound i ⟨x, hi⟩).trans_le (κ_le_add E.bound F.bound)
      · rw [add_lt_add_iff_left]
        exact F.lt_bound j ⟨x, hjx⟩
    rel_coinjective := by
      constructor
      rintro x y i (hix | ⟨j, hj, hjx⟩) (hiy | ⟨k, hk, hky⟩)
      · exact E.rel_coinjective.coinjective hix hiy
      · cases hk
        have := E.lt_bound _ ⟨x, hix⟩
        rw [add_lt_iff_neg_left] at this
        cases (κ_zero_le k).not_lt this
      · cases hj
        have := E.lt_bound _ ⟨y, hiy⟩
        rw [add_lt_iff_neg_left] at this
        cases (κ_zero_le j).not_lt this
      · cases hj
        simp only [Rel.inv, flip, Function.graph_def, add_right_inj] at hk
        cases hk
        exact F.rel_coinjective.coinjective hjx hky
  }

@[simp]
theorem add_bound (E F : Enumeration X) :
    (E + F).bound = E.bound + F.bound :=
  rfl

theorem rel_add_iff {E F : Enumeration X} (i : κ) (x : X) :
    (E + F).rel i x ↔ E.rel i x ∨ ∃ j, E.bound + j = i ∧ F.rel j x :=
  Iff.rfl

theorem add_rel_dom {X : Type _} (E F : Enumeration X) :
    (E + F).rel.dom = E.rel.dom ∪ (E.bound + ·) '' F.rel.dom

:= by
  ext i
  simp only [Rel.dom, rel_add_iff, Set.mem_setOf_eq, Set.mem_union, Set.mem_image]
  aesop