/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Yury Kudryashov

! This file was ported from Lean 3 source module topology.uniform_space.compact
! leanprover-community/mathlib commit ee05e9ce1322178f0c12004eb93c00d2c8c00ed2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.UniformSpace.UniformConvergence
import Mathbin.Topology.UniformSpace.Equicontinuity
import Mathbin.Topology.Separation
import Mathbin.Topology.Support

/-!
# Compact separated uniform spaces

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

## Main statements

* `compact_space_uniformity`: On a compact uniform space, the topology determines the
  uniform structure, entourages are exactly the neighborhoods of the diagonal.

* `uniform_space_of_compact_t2`: every compact T2 topological structure is induced by a uniform
  structure. This uniform structure is described in the previous item.

* **Heine-Cantor** theorem: continuous functions on compact uniform spaces with values in uniform
  spaces are automatically uniformly continuous. There are several variations, the main one is
  `compact_space.uniform_continuous_of_continuous`.

## Implementation notes

The construction `uniform_space_of_compact_t2` is not declared as an instance, as it would badly
loop.

## tags

uniform space, uniform continuity, compact space
-/

open Classical uniformity Topology Filter

open Filter UniformSpace Set

variable {α β γ : Type _} [UniformSpace α] [UniformSpace β]

/-!
### Uniformity on compact spaces
-/

/- warning: nhds_set_diagonal_eq_uniformity -> nhdsSet_diagonal_eq_uniformity is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : UniformSpace.{u1} α] [_inst_3 : CompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)], Eq.{succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (nhdsSet.{u1} (Prod.{u1, u1} α α) (Prod.topologicalSpace.{u1, u1} α α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} α _inst_1)) (Set.diagonal.{u1} α)) (uniformity.{u1} α _inst_1)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : UniformSpace.{u1} α] [_inst_3 : CompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)], Eq.{succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (nhdsSet.{u1} (Prod.{u1, u1} α α) (instTopologicalSpaceProd.{u1, u1} α α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} α _inst_1)) (Set.diagonal.{u1} α)) (uniformity.{u1} α _inst_1)
Case conversion may be inaccurate. Consider using '#align nhds_set_diagonal_eq_uniformity nhdsSet_diagonal_eq_uniformityₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- On a compact uniform space, the topology determines the uniform structure, entourages are
exactly the neighborhoods of the diagonal. -/
theorem nhdsSet_diagonal_eq_uniformity [CompactSpace α] : 𝓝ˢ (diagonal α) = 𝓤 α :=
  by
  refine' nhds_set_diagonal_le_uniformity.antisymm _
  have :
    (𝓤 (α × α)).HasBasis (fun U => U ∈ 𝓤 α) fun U =>
      (fun p : (α × α) × α × α => ((p.1.1, p.2.1), p.1.2, p.2.2)) ⁻¹' U ×ˢ U :=
    by
    rw [uniformity_prod_eq_comap_prod]
    exact (𝓤 α).basis_sets.prod_self.comap _
  refine' (is_compact_diagonal.nhds_set_basis_uniformity this).ge_iff.2 fun U hU => _
  exact mem_of_superset hU fun ⟨x, y⟩ hxy => mem_Union₂.2 ⟨(x, x), rfl, refl_mem_uniformity hU, hxy⟩
#align nhds_set_diagonal_eq_uniformity nhdsSet_diagonal_eq_uniformity

/- warning: compact_space_uniformity -> compactSpace_uniformity is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : UniformSpace.{u1} α] [_inst_3 : CompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)], Eq.{succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (uniformity.{u1} α _inst_1) (supᵢ.{u1, succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (ConditionallyCompleteLattice.toHasSup.{u1} (Filter.{u1} (Prod.{u1, u1} α α)) (CompleteLattice.toConditionallyCompleteLattice.{u1} (Filter.{u1} (Prod.{u1, u1} α α)) (Filter.completeLattice.{u1} (Prod.{u1, u1} α α)))) α (fun (x : α) => nhds.{u1} (Prod.{u1, u1} α α) (Prod.topologicalSpace.{u1, u1} α α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} α _inst_1)) (Prod.mk.{u1, u1} α α x x)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : UniformSpace.{u1} α] [_inst_3 : CompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)], Eq.{succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (uniformity.{u1} α _inst_1) (supᵢ.{u1, succ u1} (Filter.{u1} (Prod.{u1, u1} α α)) (ConditionallyCompleteLattice.toSupSet.{u1} (Filter.{u1} (Prod.{u1, u1} α α)) (CompleteLattice.toConditionallyCompleteLattice.{u1} (Filter.{u1} (Prod.{u1, u1} α α)) (Filter.instCompleteLatticeFilter.{u1} (Prod.{u1, u1} α α)))) α (fun (x : α) => nhds.{u1} (Prod.{u1, u1} α α) (instTopologicalSpaceProd.{u1, u1} α α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} α _inst_1)) (Prod.mk.{u1, u1} α α x x)))
Case conversion may be inaccurate. Consider using '#align compact_space_uniformity compactSpace_uniformityₓ'. -/
/-- On a compact uniform space, the topology determines the uniform structure, entourages are
exactly the neighborhoods of the diagonal. -/
theorem compactSpace_uniformity [CompactSpace α] : 𝓤 α = ⨆ x, 𝓝 (x, x) :=
  nhdsSet_diagonal_eq_uniformity.symm.trans (nhdsSet_diagonal _)
#align compact_space_uniformity compactSpace_uniformity

#print unique_uniformity_of_compact /-
theorem unique_uniformity_of_compact [t : TopologicalSpace γ] [CompactSpace γ]
    {u u' : UniformSpace γ} (h : u.toTopologicalSpace = t) (h' : u'.toTopologicalSpace = t) :
    u = u' := by
  apply uniformSpace_eq
  change uniformity _ = uniformity _
  have : @CompactSpace γ u.to_topological_space := by rwa [h]
  have : @CompactSpace γ u'.to_topological_space := by rwa [h']
  rw [compactSpace_uniformity, compactSpace_uniformity, h, h']
#align unique_uniformity_of_compact unique_uniformity_of_compact
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (y «expr ≠ » x) -/
#print uniformSpaceOfCompactT2 /-
/-- The unique uniform structure inducing a given compact topological structure. -/
def uniformSpaceOfCompactT2 [TopologicalSpace γ] [CompactSpace γ] [T2Space γ] : UniformSpace γ
    where
  uniformity := 𝓝ˢ (diagonal γ)
  refl := principal_le_nhdsSet
  symm := continuous_swap.tendsto_nhdsSet fun x => Eq.symm
  comp :=
    by
    /-
        This is the difficult part of the proof. We need to prove that, for each neighborhood `W`
        of the diagonal `Δ`, there exists a smaller neighborhood `V` such that `V ○ V ⊆ W`.
        -/
    set 𝓝Δ := 𝓝ˢ (diagonal γ)
    -- The filter of neighborhoods of Δ
    set F := 𝓝Δ.lift' fun s : Set (γ × γ) => s ○ s
    -- Compositions of neighborhoods of Δ
    -- If this weren't true, then there would be V ∈ 𝓝Δ such that F ⊓ 𝓟 Vᶜ ≠ ⊥
    rw [le_iff_forall_inf_principal_compl]
    intro V V_in
    by_contra H
    haveI : ne_bot (F ⊓ 𝓟 (Vᶜ)) := ⟨H⟩
    -- Hence compactness would give us a cluster point (x, y) for F ⊓ 𝓟 Vᶜ
    obtain ⟨⟨x, y⟩, hxy⟩ : ∃ p : γ × γ, ClusterPt p (F ⊓ 𝓟 (Vᶜ)) := cluster_point_of_compact _
    -- In particular (x, y) is a cluster point of 𝓟 Vᶜ, hence is not in the interior of V,
    -- and a fortiori not in Δ, so x ≠ y
    have clV : ClusterPt (x, y) (𝓟 <| Vᶜ) := hxy.of_inf_right
    have : (x, y) ∉ interior V :=
      by
      have : (x, y) ∈ closure (Vᶜ) := by rwa [mem_closure_iff_clusterPt]
      rwa [closure_compl] at this
    have diag_subset : diagonal γ ⊆ interior V := subset_interior_iff_mem_nhdsSet.2 V_in
    have x_ne_y : x ≠ y := mt (@diag_subset (x, y)) this
    -- Since γ is compact and Hausdorff, it is normal, hence T₃.
    haveI : NormalSpace γ := normalOfCompactT2
    -- So there are closed neighboords V₁ and V₂ of x and y contained in disjoint open neighborhoods
    -- U₁ and U₂.
    obtain
      ⟨U₁, U₁_in, V₁, V₁_in, U₂, U₂_in₂, V₂, V₂_in, V₁_cl, V₂_cl, U₁_op, U₂_op, VU₁, VU₂, hU₁₂⟩ :=
      disjoint_nested_nhds x_ne_y
    -- We set U₃ := (V₁ ∪ V₂)ᶜ so that W := U₁ ×ˢ U₁ ∪ U₂ ×ˢ U₂ ∪ U₃ ×ˢ U₃ is an open
    -- neighborhood of Δ.
    let U₃ := (V₁ ∪ V₂)ᶜ
    have U₃_op : IsOpen U₃ := (V₁_cl.union V₂_cl).isOpen_compl
    let W := U₁ ×ˢ U₁ ∪ U₂ ×ˢ U₂ ∪ U₃ ×ˢ U₃
    have W_in : W ∈ 𝓝Δ := by
      rw [mem_nhdsSet_iff_forall]
      rintro ⟨z, z'⟩ (rfl : z = z')
      refine' IsOpen.mem_nhds _ _
      · apply_rules [IsOpen.union, IsOpen.prod]
      · simp only [mem_union, mem_prod, and_self_iff]
        exact (em _).imp_left fun h => union_subset_union VU₁ VU₂ h
    -- So W ○ W ∈ F by definition of F
    have : W ○ W ∈ F := by simpa only using mem_lift' W_in
    -- And V₁ ×ˢ V₂ ∈ 𝓝 (x, y)
    have hV₁₂ : V₁ ×ˢ V₂ ∈ 𝓝 (x, y) := prod_mem_nhds V₁_in V₂_in
    -- But (x, y) is also a cluster point of F so (V₁ ×ˢ V₂) ∩ (W ○ W) ≠ ∅
    -- However the construction of W implies (V₁ ×ˢ V₂) ∩ (W ○ W) = ∅.
    -- Indeed assume for contradiction there is some (u, v) in the intersection.
    obtain ⟨⟨u, v⟩, ⟨u_in, v_in⟩, w, huw, hwv⟩ := cluster_pt_iff.mp hxy.of_inf_left hV₁₂ this
    -- So u ∈ V₁, v ∈ V₂, and there exists some w such that (u, w) ∈ W and (w ,v) ∈ W.
    -- Because u is in V₁ which is disjoint from U₂ and U₃, (u, w) ∈ W forces (u, w) ∈ U₁ ×ˢ U₁.
    have uw_in : (u, w) ∈ U₁ ×ˢ U₁ :=
      (huw.resolve_right fun h => h.1 <| Or.inl u_in).resolve_right fun h =>
        hU₁₂.le_bot ⟨VU₁ u_in, h.1⟩
    -- Similarly, because v ∈ V₂, (w ,v) ∈ W forces (w, v) ∈ U₂ ×ˢ U₂.
    have wv_in : (w, v) ∈ U₂ ×ˢ U₂ :=
      (hwv.resolve_right fun h => h.2 <| Or.inr v_in).resolve_left fun h =>
        hU₁₂.le_bot ⟨h.2, VU₂ v_in⟩
    -- Hence w ∈ U₁ ∩ U₂ which is empty.
    -- So we have a contradiction
    exact hU₁₂.le_bot ⟨uw_in.2, wv_in.1⟩
  isOpen_uniformity :=
    by
    -- Here we need to prove the topology induced by the constructed uniformity is the
    -- topology we started with.
    suffices ∀ x : γ, Filter.comap (Prod.mk x) (𝓝ˢ (diagonal γ)) = 𝓝 x
      by
      intro s
      simp_rw [isOpen_fold, isOpen_iff_mem_nhds, ← mem_comap_prod_mk, this]
    intro x
    simp_rw [nhdsSet_diagonal, comap_supr, nhds_prod_eq, comap_prod, (· ∘ ·), comap_id']
    rw [supᵢ_split_single _ x, comap_const_of_mem fun V => mem_of_mem_nhds]
    suffices ∀ (y) (_ : y ≠ x), comap (fun y : γ => x) (𝓝 y) ⊓ 𝓝 y ≤ 𝓝 x by simpa
    intro y hxy
    simp [comap_const_of_not_mem (compl_singleton_mem_nhds hxy) (Classical.not_not.2 rfl)]
#align uniform_space_of_compact_t2 uniformSpaceOfCompactT2
-/

/-!
### Heine-Cantor theorem
-/

/- warning: compact_space.uniform_continuous_of_continuous -> CompactSpace.uniformContinuous_of_continuous is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : UniformSpace.{u1} α] [_inst_2 : UniformSpace.{u2} β] [_inst_3 : CompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)] {f : α -> β}, (Continuous.{u1, u2} α β (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2) f) -> (UniformContinuous.{u1, u2} α β _inst_1 _inst_2 f)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : UniformSpace.{u2} α] [_inst_2 : UniformSpace.{u1} β] [_inst_3 : CompactSpace.{u2} α (UniformSpace.toTopologicalSpace.{u2} α _inst_1)] {f : α -> β}, (Continuous.{u2, u1} α β (UniformSpace.toTopologicalSpace.{u2} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} β _inst_2) f) -> (UniformContinuous.{u2, u1} α β _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align compact_space.uniform_continuous_of_continuous CompactSpace.uniformContinuous_of_continuousₓ'. -/
/-- Heine-Cantor: a continuous function on a compact uniform space is uniformly
continuous. -/
theorem CompactSpace.uniformContinuous_of_continuous [CompactSpace α] {f : α → β}
    (h : Continuous f) : UniformContinuous f :=
  have : Tendsto (Prod.map f f) (𝓝ˢ (diagonal α)) (𝓝ˢ (diagonal β)) :=
    (h.Prod_map h).tendsto_nhdsSet mapsTo_prod_map_diagonal
  (this.mono_left nhdsSet_diagonal_eq_uniformity.ge).mono_right nhdsSet_diagonal_le_uniformity
#align compact_space.uniform_continuous_of_continuous CompactSpace.uniformContinuous_of_continuous

/- warning: is_compact.uniform_continuous_on_of_continuous -> IsCompact.uniformContinuousOn_of_continuous is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : UniformSpace.{u1} α] [_inst_2 : UniformSpace.{u2} β] {s : Set.{u1} α} {f : α -> β}, (IsCompact.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) s) -> (ContinuousOn.{u1, u2} α β (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2) f s) -> (UniformContinuousOn.{u1, u2} α β _inst_1 _inst_2 f s)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : UniformSpace.{u2} α] [_inst_2 : UniformSpace.{u1} β] {s : Set.{u2} α} {f : α -> β}, (IsCompact.{u2} α (UniformSpace.toTopologicalSpace.{u2} α _inst_1) s) -> (ContinuousOn.{u2, u1} α β (UniformSpace.toTopologicalSpace.{u2} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} β _inst_2) f s) -> (UniformContinuousOn.{u2, u1} α β _inst_1 _inst_2 f s)
Case conversion may be inaccurate. Consider using '#align is_compact.uniform_continuous_on_of_continuous IsCompact.uniformContinuousOn_of_continuousₓ'. -/
/-- Heine-Cantor: a continuous function on a compact set of a uniform space is uniformly
continuous. -/
theorem IsCompact.uniformContinuousOn_of_continuous {s : Set α} {f : α → β} (hs : IsCompact s)
    (hf : ContinuousOn f s) : UniformContinuousOn f s :=
  by
  rw [uniformContinuousOn_iff_restrict]
  rw [isCompact_iff_compactSpace] at hs
  rw [continuousOn_iff_continuous_restrict] at hf
  skip
  exact CompactSpace.uniformContinuous_of_continuous hf
#align is_compact.uniform_continuous_on_of_continuous IsCompact.uniformContinuousOn_of_continuous

#print IsCompact.uniformContinuousAt_of_continuousAt /-
/-- If `s` is compact and `f` is continuous at all points of `s`, then `f` is
"uniformly continuous at the set `s`", i.e. `f x` is close to `f y` whenever `x ∈ s` and `y` is
close to `x` (even if `y` is not itself in `s`, so this is a stronger assertion than
`uniform_continuous_on s`). -/
theorem IsCompact.uniformContinuousAt_of_continuousAt {r : Set (β × β)} {s : Set α}
    (hs : IsCompact s) (f : α → β) (hf : ∀ a ∈ s, ContinuousAt f a) (hr : r ∈ 𝓤 β) :
    { x : α × α | x.1 ∈ s → (f x.1, f x.2) ∈ r } ∈ 𝓤 α :=
  by
  obtain ⟨t, ht, htsymm, htr⟩ := comp_symm_mem_uniformity_sets hr
  choose U hU T hT hb using fun a ha =>
    exists_mem_nhds_ball_subset_of_mem_nhds ((hf a ha).preimage_mem_nhds <| mem_nhds_left _ ht)
  obtain ⟨fs, hsU⟩ := hs.elim_nhds_subcover' U hU
  apply mem_of_superset ((bInter_finset_mem fs).2 fun a _ => hT a a.2)
  rintro ⟨a₁, a₂⟩ h h₁
  obtain ⟨a, ha, haU⟩ := Set.mem_unionᵢ₂.1 (hsU h₁)
  apply htr
  refine' ⟨f a, htsymm.mk_mem_comm.1 (hb _ _ _ haU _), hb _ _ _ haU _⟩
  exacts[mem_ball_self _ (hT a a.2), mem_Inter₂.1 h a ha]
#align is_compact.uniform_continuous_at_of_continuous_at IsCompact.uniformContinuousAt_of_continuousAt
-/

/- warning: continuous.uniform_continuous_of_tendsto_cocompact -> Continuous.uniformContinuous_of_tendsto_cocompact is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : UniformSpace.{u1} α] [_inst_2 : UniformSpace.{u2} β] {f : α -> β} {x : β}, (Continuous.{u1, u2} α β (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2) f) -> (Filter.Tendsto.{u1, u2} α β f (Filter.cocompact.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)) (nhds.{u2} β (UniformSpace.toTopologicalSpace.{u2} β _inst_2) x)) -> (UniformContinuous.{u1, u2} α β _inst_1 _inst_2 f)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : UniformSpace.{u2} α] [_inst_2 : UniformSpace.{u1} β] {f : α -> β} {x : β}, (Continuous.{u2, u1} α β (UniformSpace.toTopologicalSpace.{u2} α _inst_1) (UniformSpace.toTopologicalSpace.{u1} β _inst_2) f) -> (Filter.Tendsto.{u2, u1} α β f (Filter.cocompact.{u2} α (UniformSpace.toTopologicalSpace.{u2} α _inst_1)) (nhds.{u1} β (UniformSpace.toTopologicalSpace.{u1} β _inst_2) x)) -> (UniformContinuous.{u2, u1} α β _inst_1 _inst_2 f)
Case conversion may be inaccurate. Consider using '#align continuous.uniform_continuous_of_tendsto_cocompact Continuous.uniformContinuous_of_tendsto_cocompactₓ'. -/
theorem Continuous.uniformContinuous_of_tendsto_cocompact {f : α → β} {x : β}
    (h_cont : Continuous f) (hx : Tendsto f (cocompact α) (𝓝 x)) : UniformContinuous f :=
  uniformContinuous_def.2 fun r hr =>
    by
    obtain ⟨t, ht, htsymm, htr⟩ := comp_symm_mem_uniformity_sets hr
    obtain ⟨s, hs, hst⟩ := mem_cocompact.1 (hx <| mem_nhds_left _ ht)
    apply
      mem_of_superset
        (symmetrize_mem_uniformity <|
          (hs.uniform_continuous_at_of_continuous_at f fun _ _ => h_cont.continuous_at) <|
            symmetrize_mem_uniformity hr)
    rintro ⟨b₁, b₂⟩ h
    by_cases h₁ : b₁ ∈ s; · exact (h.1 h₁).1
    by_cases h₂ : b₂ ∈ s; · exact (h.2 h₂).2
    apply htr
    exact ⟨x, htsymm.mk_mem_comm.1 (hst h₁), hst h₂⟩
#align continuous.uniform_continuous_of_tendsto_cocompact Continuous.uniformContinuous_of_tendsto_cocompact

#print HasCompactMulSupport.is_one_at_infty /-
/-- If `f` has compact multiplicative support, then `f` tends to 1 at infinity. -/
@[to_additive "If `f` has compact support, then `f` tends to zero at infinity."]
theorem HasCompactMulSupport.is_one_at_infty {f : α → γ} [TopologicalSpace γ] [One γ]
    (h : HasCompactMulSupport f) : Tendsto f (cocompact α) (𝓝 1) :=
  by
  -- porting note: move to src/topology/support.lean once the port is over
  intro N hN
  rw [mem_map, mem_cocompact']
  refine' ⟨mulTSupport f, h.is_compact, _⟩
  rw [compl_subset_comm]
  intro v hv
  rw [mem_preimage, image_eq_one_of_nmem_mulTSupport hv]
  exact mem_of_mem_nhds hN
#align has_compact_mul_support.is_one_at_infty HasCompactMulSupport.is_one_at_infty
#align has_compact_support.is_zero_at_infty HasCompactSupport.is_zero_at_infty
-/

#print HasCompactMulSupport.uniformContinuous_of_continuous /-
@[to_additive]
theorem HasCompactMulSupport.uniformContinuous_of_continuous {f : α → β} [One β]
    (h1 : HasCompactMulSupport f) (h2 : Continuous f) : UniformContinuous f :=
  h2.uniformContinuous_of_tendsto_cocompact h1.is_one_at_infty
#align has_compact_mul_support.uniform_continuous_of_continuous HasCompactMulSupport.uniformContinuous_of_continuous
#align has_compact_support.uniform_continuous_of_continuous HasCompactSupport.uniformContinuous_of_continuous
-/

/- warning: continuous_on.tendsto_uniformly -> ContinuousOn.tendstoUniformly is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {γ : Type.{u3}} [_inst_1 : UniformSpace.{u1} α] [_inst_2 : UniformSpace.{u2} β] [_inst_3 : LocallyCompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)] [_inst_4 : CompactSpace.{u2} β (UniformSpace.toTopologicalSpace.{u2} β _inst_2)] [_inst_5 : UniformSpace.{u3} γ] {f : α -> β -> γ} {x : α} {U : Set.{u1} α}, (Membership.Mem.{u1, u1} (Set.{u1} α) (Filter.{u1} α) (Filter.hasMem.{u1} α) U (nhds.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) x)) -> (ContinuousOn.{max u1 u2, u3} (Prod.{u1, u2} α β) γ (Prod.topologicalSpace.{u1, u2} α β (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2)) (UniformSpace.toTopologicalSpace.{u3} γ _inst_5) (Function.HasUncurry.uncurry.{max u1 u2 u3, max u1 u2, u3} (α -> β -> γ) (Prod.{u1, u2} α β) γ (Function.hasUncurryInduction.{u1, max u2 u3, u2, u3} α (β -> γ) β γ (Function.hasUncurryBase.{u2, u3} β γ)) f) (Set.prod.{u1, u2} α β U (Set.univ.{u2} β))) -> (TendstoUniformly.{u2, u3, u1} β γ α _inst_5 f (f x) (nhds.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) x))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} [_inst_1 : UniformSpace.{u3} α] [_inst_2 : UniformSpace.{u2} β] [_inst_3 : LocallyCompactSpace.{u3} α (UniformSpace.toTopologicalSpace.{u3} α _inst_1)] [_inst_4 : CompactSpace.{u2} β (UniformSpace.toTopologicalSpace.{u2} β _inst_2)] [_inst_5 : UniformSpace.{u1} γ] {f : α -> β -> γ} {x : α} {U : Set.{u3} α}, (Membership.mem.{u3, u3} (Set.{u3} α) (Filter.{u3} α) (instMembershipSetFilter.{u3} α) U (nhds.{u3} α (UniformSpace.toTopologicalSpace.{u3} α _inst_1) x)) -> (ContinuousOn.{max u3 u2, u1} (Prod.{u3, u2} α β) γ (instTopologicalSpaceProd.{u3, u2} α β (UniformSpace.toTopologicalSpace.{u3} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2)) (UniformSpace.toTopologicalSpace.{u1} γ _inst_5) (Function.HasUncurry.uncurry.{max (max u3 u2) u1, max u3 u2, u1} (α -> β -> γ) (Prod.{u3, u2} α β) γ (Function.hasUncurryInduction.{u3, max u2 u1, u2, u1} α (β -> γ) β γ (Function.hasUncurryBase.{u2, u1} β γ)) f) (Set.prod.{u3, u2} α β U (Set.univ.{u2} β))) -> (TendstoUniformly.{u2, u1, u3} β γ α _inst_5 f (f x) (nhds.{u3} α (UniformSpace.toTopologicalSpace.{u3} α _inst_1) x))
Case conversion may be inaccurate. Consider using '#align continuous_on.tendsto_uniformly ContinuousOn.tendstoUniformlyₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A family of functions `α → β → γ` tends uniformly to its value at `x` if `α` is locally compact,
`β` is compact and `f` is continuous on `U × (univ : set β)` for some neighborhood `U` of `x`. -/
theorem ContinuousOn.tendstoUniformly [LocallyCompactSpace α] [CompactSpace β] [UniformSpace γ]
    {f : α → β → γ} {x : α} {U : Set α} (hxU : U ∈ 𝓝 x) (h : ContinuousOn (↿f) (U ×ˢ univ)) :
    TendstoUniformly f (f x) (𝓝 x) :=
  by
  rcases LocallyCompactSpace.local_compact_nhds _ _ hxU with ⟨K, hxK, hKU, hK⟩
  have : UniformContinuousOn (↿f) (K ×ˢ univ) :=
    IsCompact.uniformContinuousOn_of_continuous (hK.prod isCompact_univ)
      (h.mono <| prod_mono hKU subset.rfl)
  exact this.tendsto_uniformly hxK
#align continuous_on.tendsto_uniformly ContinuousOn.tendstoUniformly

/- warning: continuous.tendsto_uniformly -> Continuous.tendstoUniformly is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {γ : Type.{u3}} [_inst_1 : UniformSpace.{u1} α] [_inst_2 : UniformSpace.{u2} β] [_inst_3 : LocallyCompactSpace.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1)] [_inst_4 : CompactSpace.{u2} β (UniformSpace.toTopologicalSpace.{u2} β _inst_2)] [_inst_5 : UniformSpace.{u3} γ] (f : α -> β -> γ), (Continuous.{max u1 u2, u3} (Prod.{u1, u2} α β) γ (Prod.topologicalSpace.{u1, u2} α β (UniformSpace.toTopologicalSpace.{u1} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2)) (UniformSpace.toTopologicalSpace.{u3} γ _inst_5) (Function.HasUncurry.uncurry.{max u1 u2 u3, max u1 u2, u3} (α -> β -> γ) (Prod.{u1, u2} α β) γ (Function.hasUncurryInduction.{u1, max u2 u3, u2, u3} α (β -> γ) β γ (Function.hasUncurryBase.{u2, u3} β γ)) f)) -> (forall (x : α), TendstoUniformly.{u2, u3, u1} β γ α _inst_5 f (f x) (nhds.{u1} α (UniformSpace.toTopologicalSpace.{u1} α _inst_1) x))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} [_inst_1 : UniformSpace.{u3} α] [_inst_2 : UniformSpace.{u2} β] [_inst_3 : LocallyCompactSpace.{u3} α (UniformSpace.toTopologicalSpace.{u3} α _inst_1)] [_inst_4 : CompactSpace.{u2} β (UniformSpace.toTopologicalSpace.{u2} β _inst_2)] [_inst_5 : UniformSpace.{u1} γ] (f : α -> β -> γ), (Continuous.{max u3 u2, u1} (Prod.{u3, u2} α β) γ (instTopologicalSpaceProd.{u3, u2} α β (UniformSpace.toTopologicalSpace.{u3} α _inst_1) (UniformSpace.toTopologicalSpace.{u2} β _inst_2)) (UniformSpace.toTopologicalSpace.{u1} γ _inst_5) (Function.HasUncurry.uncurry.{max (max u3 u2) u1, max u3 u2, u1} (α -> β -> γ) (Prod.{u3, u2} α β) γ (Function.hasUncurryInduction.{u3, max u2 u1, u2, u1} α (β -> γ) β γ (Function.hasUncurryBase.{u2, u1} β γ)) f)) -> (forall (x : α), TendstoUniformly.{u2, u1, u3} β γ α _inst_5 f (f x) (nhds.{u3} α (UniformSpace.toTopologicalSpace.{u3} α _inst_1) x))
Case conversion may be inaccurate. Consider using '#align continuous.tendsto_uniformly Continuous.tendstoUniformlyₓ'. -/
/-- A continuous family of functions `α → β → γ` tends uniformly to its value at `x` if `α` is
locally compact and `β` is compact. -/
theorem Continuous.tendstoUniformly [LocallyCompactSpace α] [CompactSpace β] [UniformSpace γ]
    (f : α → β → γ) (h : Continuous ↿f) (x : α) : TendstoUniformly f (f x) (𝓝 x) :=
  h.ContinuousOn.TendstoUniformly univ_mem
#align continuous.tendsto_uniformly Continuous.tendstoUniformly

section UniformConvergence

#print CompactSpace.uniformEquicontinuous_of_equicontinuous /-
/-- An equicontinuous family of functions defined on a compact uniform space is automatically
uniformly equicontinuous. -/
theorem CompactSpace.uniformEquicontinuous_of_equicontinuous {ι : Type _} {F : ι → β → α}
    [CompactSpace β] (h : Equicontinuous F) : UniformEquicontinuous F :=
  by
  rw [equicontinuous_iff_continuous] at h
  rw [uniformEquicontinuous_iff_uniformContinuous]
  exact CompactSpace.uniformContinuous_of_continuous h
#align compact_space.uniform_equicontinuous_of_equicontinuous CompactSpace.uniformEquicontinuous_of_equicontinuous
-/

end UniformConvergence


/- This file includes the proofs for the axioms for the summation operator.-/
import .iff_lemmas

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

variable {β : Type}

/- Note the presence of the hypothesis h here. -/
lemma transition.sum_idem (A : set β) (h : ∃a, a ∈ A) (x : mcrl2 α) (z a) :
transition (sum A (λa, x)) a z ↔ transition x a z :=
begin
  simp only [transition.sum_iff],
  split,
  { intro h',
    rcases h' with ⟨_, _, h'⟩,
    assumption},
  { intro h',
    cases h,
    exact ⟨h_w, h_h, h'⟩}
end

lemma transition.sum_elem (A : set β)  (f : β → mcrl2 α) (d) (h : d ∈ A) (z a) :
transition (sum A f) a z ↔ transition (sum A f + f d) a z :=
begin
  simp [transition.sum_iff, transition.alt_iff],
  split,
  { intro h,
    apply or.inl,
    assumption},
  { intro h',
    rcases h' with ⟨a', ha', haz⟩ | ⟨haz⟩,
    { exact ⟨a', ha', haz⟩},
    { exact ⟨d, h, haz⟩}}
end

lemma transition.sum_pure (A : set β) (f : β → mcrl2 α) (z a) :
transition (sum A (λa, f a)) a z ↔ transition (sum A f) a z :=
begin
  simp [transition.sum_iff]
end

lemma transition.sum_alt (A : set β) (f g : β → mcrl2 α) (z a) :
transition (sum A (λa, f a + g a)) a z ↔ transition (sum A f + sum A g) a z :=
by simp [transition.sum_iff, transition.alt_iff, and_or_distrib_left, ←exists_or_distrib]

lemma transition.sum_seq (A : set β) (f : β → mcrl2 α) (x z a) :
transition (sum A f ⬝ x) a z ↔ transition (sum A (λa, f a ⬝ x)) a z :=
begin simp [transition.sum_iff, transition.seq_iff, ←exists_and_distrib_left], tauto
end

lemma transition.sum_parl (A : set β) (f : β → mcrl2 α) (x z a) :
transition (sum A f |_ x) a z ↔ transition (sum A (λa, f a |_ x)) a z :=
by simp [transition.sum_iff, transition.parl_iff, ←exists_and_distrib_left, ←and_assoc, and_comm, exists_comm]

lemma transition.sum_comm (A : set β) (f : β → mcrl2 α) (x z a) :
transition (sum A f ∣ x) a z ↔ transition (sum A (λa, f a ∣ x)) a z :=
begin
  simp [transition.sum_iff, transition.comm_iff, ←exists_and_distrib_left, ←and_assoc, ←exists_and_distrib_right],
  tauto
end

lemma transition.comm_sum (A : set β) (f : β → mcrl2 α) (x z a) :
transition (x ∣ (sum A f)) a z ↔ transition (sum A (λa, x ∣ f a)) a z :=
begin
  simp [transition.sum_iff, transition.comm_iff, ←exists_and_distrib_left, ←and_assoc, ←exists_and_distrib_right],
  tauto
end

lemma transition.encap_sum (H : set α) (D : set β) (f z a) :
transition (encap H (sum D f)) a z ↔ transition (sum D (λa, encap H (f a))) a z :=
begin
  simp [transition.encap_iff, transition.sum_iff],
  tauto
end

lemma transition.sum_ext (D : set β) (f g : β → mcrl2 α )
  (h : ∀a' : β, a' ∈ D → ∀z a, (transition (f a') a z ↔ transition (g a') a z)) (z a) :
transition (sum D f) a z ↔ transition (sum D g) a z :=
begin
  simp [transition.sum_iff],
  split,
  { intro h',
    rcases h' with ⟨a', ha', haz⟩,
    apply exists.intro a',
    apply and.intro ha',
    apply iff.elim_left (h a' ha' z a),
    assumption},
  { intro h',
    rcases h' with ⟨a', ha', haz⟩,
    apply exists.intro a',
    apply and.intro ha',
    apply iff.elim_right (h a' ha' z a),
    assumption}
end


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .fol data.zmod.basic

open fol

-- local attribute [instance, priority 0] classical.prop_decidable
--local attribute [instance] classical.prop_decidable

local notation h :: t  := dvector.cons h t
local notation `[]` := dvector.nil
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l

namespace realization

/- Note: maybe some of the _irrel lemmas should be called something_elim instead -/

-- section fin_lemmas

-- open fin
-- variable n : ℕ
-- @[simp]lemma of_nat_zero : @of_nat n 0 = 0 := rfl

-- @[simp]lemma add_def (a b : fin n) : (a + b).val = (a.val + b.val) % n :=
-- show (fin.add a b).val = (a.val + b.val) % n, from
-- by cases a; cases b; simp [fin.add]

-- @[simp]lemma mul_def (a b : fin n) : (a * b).val = (a.val * b.val) % n :=
-- show (fin.mul a b).val = (a.val * b.val) % n, from
-- by cases a; cases b; simp [fin.mul]

-- @[simp]lemma sub_def (a b : fin n) : (a - b).val = a.val - b.val :=
-- show (fin.sub a b).val = a.val - b.val, from
-- by cases a; cases b; simp [fin.sub]

-- @[simp]lemma mod_def (a b : fin n) : (a % b).val = a.val % b.val :=
-- show (fin.mod a b).val = a.val % b.val, from
-- by cases a; cases b; simp [fin.mod]

-- @[simp]lemma div_def (a b : fin n) : (a / b).val = a.val / b.val :=
-- show (fin.div a b).val = a.val / b.val, from
-- by cases a; cases b; simp [fin.div]

-- @[simp]lemma lt_def (a b : fin n) : (a < b) = (a.val < b.val) :=
-- show (fin.lt a b) = (a.val < b.val), from
-- by cases a; cases b; simp [fin.lt]

-- @[simp]lemma le_def (a b : fin n) : (a ≤ b) = (a.val ≤ b.val) :=
-- show (fin.le a b) = (a.val ≤ b.val), from
-- by cases a; cases b; simp [fin.le]

-- @[simp]lemma val_zero : (0 : fin (nat.succ n)).val = 0 := rfl

-- end fin_lemmas

-- set_option pp.notation true
-- set_option pp.all false

/- To finish this, we need to port some of the zmod lemmas
   should write an elimination principle which reduces to the 0 case and the pos case, which then hands it off to zmod...
-/

lemma succ_of_fin_val_succ_and_lt : ∀ {m k : ℕ} {h : k < (m + 1 + 1)}, ((k : fin (m+1+1)) + 1).val = k + 1
| 0 0 h := rfl
| 0 (k + 1) h := by {induction k, simp, rw[fin.add_def], change _ % (2) = 2, repeat{sorry}}
| (m+1) 0 h := rfl
| (m+1) (k+1) h := sorry

lemma var_subst_cast_irrel {L : Language} {n n' m} {h : m = n+ n' + 1} {k : fin m} {t : bounded_term L n'} :
  subst_bounded_term ((&k : bounded_term L m).cast_eq h) t = subst_bounded_term (&k : bounded_term L (n + n' + 1)) t :=
begin
  ext, simp, rcases k with ⟨k_val, k_H⟩, induction m generalizing n' k_val, cases k_H,
  cases k_val,
    {refl},
    {tidy, congr, subst h_1, change _ = fin.val ((nat.cast k_val) + 1 : fin (n + n' + 1)), sorry},
-- to apply the above lemma, need to case on n to access the constructor.
--induction k_val, unfold coe lift_t has_lift_t.lift coe_t has_coe_t.coe coe_b has_coe.coe nat.cast, conv {to_rhs, congr,
end

@[simp]lemma func_subst_cast_irrel {L : Language} {n n' l m} {h : m = n + n' + 1} {f : L.functions l} {t : bounded_term L n'} :
  subst_bounded_term ((bd_func f : bounded_preterm L m l).cast_eq h) t = subst_bounded_term (bd_func f) t := by refl

@[simp]lemma func_subst_irrel {L : Language} {n n' l} {f : L.functions l} {t : bounded_term L n'} :
  subst_bounded_term (bd_func f : bounded_preterm L (n + n' + 1) l) t = (bd_func f) := by refl

@[simp]lemma func_subst0_irrel {L : Language} {n l} {f : L.functions l} {t : bounded_term L n} : (bd_func f)[t /0] = (bd_func f) := by refl
-- i wonder why this is by refl while rel_subst0_irrel isn't...

@[simp]lemma subst_bounded_term_bd_apps {L} {n n' l} (f : bounded_preterm L (n + n' + 1) l) {t : bounded_term L n'} {ts : dvector (bounded_term L (n + n' + 1)) l} :
  (bd_apps f ts)[t /// _] = bd_apps (f[t /// _]) (ts.map $ λ t', subst_bounded_term (t') t) := by {induction ts generalizing f, refl, simp[bd_apps, ts_ih (bd_app f ts_x)]}

@[simp]lemma subst0_bounded_term_bd_apps {L} {n l} (f : bounded_preterm L (n+1) l) {t : closed_term L} {ts : dvector (bounded_term L (n+1)) l} :
  (bd_apps f ts)[(t.cast0 n) /0] = bd_apps (f[(t.cast0 n) /0]) (ts.map $ λ t', t'[(t.cast0 n) /0]) := by {induction ts generalizing f, refl, simp[bd_apps, ts_ih (bd_app f ts_x)], refl}

lemma realize_func_irrel {L} {S : Structure L} {n n' l : ℕ} {t : bounded_term L n'} {f : L.functions l} {xs : dvector ↥S l} {v : dvector ↥S (n + n' + 1)} : realize_bounded_term v (bd_func f) xs = S.fun_map f xs := by refl

@[simp]lemma subst_falsum {L} {n n' n''} {h : n + n' + 1 = n''} {t : bounded_term L n'} : bd_falsum[t // n // h] = bd_falsum :=
  by ext; simp

@[simp]lemma subst0_falsum {L} {n} {t : bounded_term L n} : bd_falsum[t /0] = bd_falsum :=
  by ext; simp

@[simp]lemma subst_eq {L} {n n' n''} {h : n + n' + 1 = n''} {t₁ t₂ : bounded_term L n''} {t : bounded_term L n'} : (t₁ ≃ t₂)[t // n // h] = subst_bounded_term (t₁.cast_eq h.symm) t ≃ subst_bounded_term (t₂.cast_eq h.symm) t := by ext; simp

@[simp]lemma subst0_eq {L} {n} {t : bounded_term L n} {t₁ t₂ : bounded_term L (n+1)} : (t₁ ≃ t₂)[t /0] = (t₁[t /0] ≃ t₂[t /0]) :=
  by {unfold subst0_bounded_formula, simpa only [subst_eq]}

@[simp]lemma subst_imp {L} {n n' n''} {h : n + n' + 1 = n''} {t : bounded_term L n'} {f₁ f₂ : bounded_formula L (n'')} : (f₁ ⟹ f₂)[t // n // h] = (f₁[t // n // h] ⟹ f₂[t // n // h]) := by {ext1, induction h, refl}

@[simp]lemma subst0_imp {L} {n} {t : bounded_term L n} {f₁ f₂ : bounded_formula L (n+1)} : (f₁ ⟹ f₂)[t /0] = f₁[t /0] ⟹ f₂[t /0] :=
  by {unfold subst0_bounded_formula, simpa only [subst_imp]}

@[simp]lemma subst_all' {L} {n n' n''} {h : n + n' + 1 = n''} {t : bounded_term L n'} {f : bounded_formula L (n'' + 1)} :
  (∀'f)[t  // n // (by {simp[h]})]
  = ∀'(f[(t : bounded_term L n') // (n+1) // (by {subst h; simp})]).cast_eq (by simp) := by ext; simp

@[simp]lemma subst_all {L} {n n' n''} {h : n + n' + 1 = n''} {t : closed_term L} {f : bounded_formula L (n'' + 1)} :
  (∀'f)[t.cast0 n' // n // (by {simp[h]})]
  = ∀'(f[(t.cast0 n' : bounded_term L n') // (n+1) // (by subst h; simp)]).cast_eq (by simp) :=
  by {apply subst_all'}

@[simp]lemma subst0_all {L} {n} {t : closed_term L} {f : bounded_formula L (n+2)} :
  ((∀'f)[t.cast (by simp) /0] : bounded_formula L n) = ∀'((f[t.cast0 n // 1 // (by {simp} : 1 + n + 1 = n + 2)]).cast_eq (by simp)) :=
  by ext; simp

@[simp]lemma subst0_all_base {L} {t : closed_term L} {f : bounded_formula L 2} : (∀' f)[t /0] = ∀'(f[t // 1 // (by simp)]) :=
  by ext; simp

@[simp]lemma rel_subst_irrel {L : Language} {n n' l} {R : L.relations l} {t : bounded_term L n'} : (bd_rel R)[t // n // (by refl)] = (bd_rel R) := by ext; simp

@[simp]lemma rel_subst_irrel1 {L : Language} {n n' n'' l} {h : n + n' + 1 = n''} {R : L.relations l} {t : bounded_term L n'} : (@bd_rel L (n + n' + 1 + 1) _ R)[t // (n+1) // (by subst h; simp)] = (bd_rel R) := by ext; simp

@[simp]lemma rel_subst_irrel' {L : Language} {n n' n'' l} {h : n + n' + 1 = n''} {R : L.relations l} {t : bounded_term L n'} : (bd_rel R)[t // n // h] = (bd_rel R) := by subst h; apply rel_subst_irrel

@[simp]lemma rel_subst0_irrel {L : Language} {n l} {R : L.relations l} {t : bounded_term L n} : (bd_rel R)[t /0] = (bd_rel R) := by ext; simp

lemma realize_rel_irrel {L} {S : Structure L} {n n' l : ℕ} {t : bounded_term L n'} {R : L.relations l} {xs : dvector ↥S l} {v : dvector ↥S (n + n' + 1)} : realize_bounded_formula v (bounded_preformula.cast_eq (by refl) (bd_rel R)) xs = S.rel_map R xs := by refl

@[simp]lemma subst_bounded_formula_bd_apprel {L} {n n' n'' l} {h : n + n' + 1 = n''} (f : bounded_preformula L (n'') (l + 1))
  {t : bounded_term L n'} {s : bounded_term L (n'')} :
(bd_apprel f s)[t // n //  h] = (bd_apprel (f[t // n // h]) (subst_bounded_term (s.cast_eq h.symm) t))
:= by ext; simp

@[simp]lemma subst_bounded_formula_bd_apps_rel {L} {n n' n'' l} {h : n + n' + 1 = n''} (f : bounded_preformula L (n''+1) l)
  {t : bounded_term L n'} {ts : dvector (bounded_term L (n'' + 1)) l } :
    (bd_apps_rel f ts)[t // (n+1) // (by {subst h, simp})] = bd_apps_rel (f[t // (n+1) // by {subst h, simp}]) (ts.map $ λ t', subst_bounded_term (t'.cast_eq (by subst h; simp)) t) :=
  by {induction ts generalizing f, refl, simp[bd_apps_rel, ts_ih (bd_apprel f ts_x)]}

@[simp]lemma subst0_bounded_formula_bd_apps_rel {L} {n l} (f : bounded_preformula L (n+1) l)
  (t : closed_term L) (ts : dvector (bounded_term L (n+1)) l) :
  subst0_bounded_formula (bd_apps_rel f ts) (t.cast (by simp)) =
  bd_apps_rel (subst0_bounded_formula f (t.cast (by simp))) (ts.map $ λt', subst0_bounded_term t' (t.cast (by simp))) :=
by {induction ts generalizing f, refl, simp[bd_apps_rel, ts_ih (bd_apprel f ts_x)], congr, ext, simp}

lemma zero_of_lt_one (n : nat) (h : n < 1) : n = 0 :=
  by {cases h, refl, cases nat.lt_of_succ_le h_a}

-- lemma asjh'_term {L} {S : Structure L} {n n'} {s : bounded_term L (n + n' + 1 + 1)} {t : bounded_term L n'} {v : dvector S (n + n' + 1)} :
-- S[(@subst_bounded_term _ (n+1) n' 0 (s.cast_eq (by simp)) t).cast_eq (by simp) ;;; v] = S[s ;;; (v.insert (S[t.cast (by linarith) ;;; v]) (n+1))]
--  :=
-- begin
--   revert s, refine bounded_term.rec1 _ _; intros,
--   {sorry},
--   {sorry}
-- end

-- set_option pp.implicit false

-- lemma asjh' {L} {S : Structure L} {n n' n''} {h : n + n' + 1 = n''} {t : bounded_term L (n')} {f : bounded_formula L (n''+1)} (v : dvector S n'') : (S[(f[t  // (n+1) // (by {induction h, simp})]).cast_eq (by induction h; simp) ;; v])
-- = (S[f ;; (v.insert (S[t.cast (by {induction h, linarith}) ;;; v]) (n+1))]) :=
-- begin
--   revert n'' f v, refine bounded_formula.rec1 _ _ _ _ _; intros,
--   {ext, subst h, simp[subst_falsum], intros a, exact a},
--   {ext, -- simp[realize_subst_preterm, asjh'_term],
--     conv {to_lhs, rw[realize_bounded_formula_cast_eq_irrel]},
--     simp[realize_subst_preterm], induction v, simp,
--     sorry, simp*, repeat{sorry}

--   --  tidy,
--   --       sorry
--   -- -- conv {to_lhs, congr, skip, congr, congr, rw[asjh'_term],},
--     },
--   {sorry},
--   {sorry},
--   {have : n + 1 + n' + 1 = n_1 + 1, by subst h; simp, conv {to_lhs, congr, skip, congr, rw[subst_all'], skip, rw[this]}, rw[bounded_preformula.cast_eq_all], dsimp, ext, apply forall_congr, intro x, repeat{rw[realize_bounded_formula_cast_eq_irrel]}, rw[dvector.cast_trans], have := ih (x::v), simp at *,
--   },
-- end

set_option pp.implicit false

lemma dvector_cast_push_in {α : Type*} {n : ℕ} {m} {h : n = m} {h' : n+1 = m+1} {x : α} {v : dvector α n} :
(x::v).cast h' = x::(v.cast h) := by subst h; refl

lemma dvector_cast_pull_out {α : Type*} {n : ℕ} {m} {h : n = m} {h' : n+1 = m+1} {x : α} {v : dvector α n} : (x :: (v.cast h)) = (x::v).cast (h') := by subst h; refl

set_option pp.implicit false

lemma gen_realize_bounded_term {L : Language} {S : Structure L} : ∀ {n n' n'' : ℕ} {l f_n : ℕ} (s : bounded_term L f_n) (t : closed_term L) (v : dvector ↥S n'') {h : n + n' + 1 = n''} {h' : n'' + 1 = f_n}  (xs : dvector ↥S 0), realize_bounded_term (dvector.cast (by substs h h'; simp : n'' = n + 1 + n') v)
      (subst_bounded_term (bounded_preterm.cast_eq (by {subst h; rw[<-h'],simp}) s) (bounded_preterm.cast (zero_le n') t))
      xs =
    realize_bounded_term (dvector.cast (h') (dvector.insert (realize_closed_term S t) (n + 1) v)) s xs :=
begin
  intros, revert s, refine bounded_term.rec _ _; intros,
  {rcases k with ⟨k_val, k_H⟩,
    -- unfold realize_bounded_term realize_closed_term, simp,
    induction n generalizing k_val; subst h', swap,
    by_cases k_val = n'',
          {subst h, simp, tidy, sorry}, -- looks like here we need to case on k_val's relation to n_n + 1...

          -- {have : k_val < n'',
          --       by {apply nat.lt_of_le_and_ne, exact nat.le_of_lt_succ k_H, exact h},
          -- have := @n_ih (v.trunc _ (rfl)) k_val this,
          -- rw[dvector.nth_irrel1] at this, swap, dedup, apply nat.lt_of_lt_of_le, exact this,
          -- exact nat.le_succ (n_n + 1),
          -- rw[<-this], apply realize_bounded_term_irrel', swap, simp,
          -- intros, simp only [dvector.trunc_nth]
          repeat{sorry}},
  {rw[dvector.zero_eq xs], substs h h',simp[subst_bounded_term_bd_apps,
  realize_bounded_term_bd_apps, func_subst_irrel], congr' 1,
  apply dvector.map_congr_pmem, intros x Hx, have := ih_ts x Hx, rwa[dvector.zero_eq xs] at this}
end

set_option pp.implicit false

lemma gen_realize_bounded_formula {L} {S : Structure L}  : ∀ {n n' n'' : ℕ} {n'''} {l} {h : n + n' + 1 = n''} {h' : n'' + 1 = n'''} (f : bounded_preformula L (n''') l) (t : closed_term L) (v : dvector S n'') (xs : dvector S l), (S[(f[t.cast0 n' // (n+1) // (by {substs h h', simp})]).cast_eq (by {subst h, simp}) ;; v ;; xs]) ↔ (S[f.cast_eq (by substs h h'; simp) ;; (v.insert (S[t.cast (by {substs h h', linarith}) ;;; v]) (n+1)) ;; xs])
:=
begin
  intros,
  induction f generalizing n n' n'' v,
    {intros, simp},
    {simp, apply iff_of_eq, congr' 1; apply gen_realize_bounded_term _ t v xs, all_goals{try{exact 0}, try{exact h}}},
    {simp},
    {rw[realize_bounded_formula_cast_eq_irrel,subst_bounded_formula_bd_apprel],
    conv {to_rhs, rw[realize_bounded_formula_cast_eq_irrel]},
    have := @f_ih (realize_bounded_term (dvector.cast h' (dvector.insert (realize_closed_term S t) (n + 1) v)) f_t [] :: xs) n n' n'' v h h',
    simp only [fol.realize_bounded_formula_cast_eq_irrel, add_zero, dvector.insert, neg_nonpos, int.coe_nat_zero, fol.subst_bounded_formula,
    int.coe_nat_add, add_comm, int.coe_nat_one, fol.bounded_preterm.cast, eq_self_iff_true, zero_le, fol.realize_bounded_formula,
    fol.bounded_preterm.cast_irrel, fol.realize_closed_term_v_irrel, zero_add, add_right_inj, fol.realize_bounded_term, add_left_comm,
    fol.closed_preterm.cast_of_cast0] at *,
    erw[gen_realize_bounded_term], tactic.rotate 1, exact f_l, exact h, exact h',
    apply this},

    {have this_f := f_ih_f₁ xs v, have this_g := f_ih_f₂ xs v, simp, simp at this_f this_g, rw[<-this_f,<-this_g]},

    {substs h h', conv{to_lhs, congr, skip, congr,
    rw[@subst_all' L (n+1) n' (n + n' + 1 + 1) (by {simp}) (t.cast0 n') f_f]}, rw[cast_eq_all], dsimp, apply forall_congr, intro x,
    have := @f_ih xs (n+1) n' ((n+1) + n' + 1) (x::(v.cast (by simp))) (by simp) (by simp),
    rw[<-dvector_cast_push_in] at this, swap, {simp},
    repeat{rw[realize_bounded_formula_cast_eq_irrel]},
    rw[realize_bounded_formula_cast_eq_irrel] at this, rw[dvector.cast_trans] at *,
    rw[this], clear this, clear f_ih, rw[dvector.insert_cons], apply iff_of_eq,
    congr' 1, {simp}, simp [realize_bounded_term_irrel, -dvector.cast],
      {rw[dvector.insert_cons], congr' 1, simp, apply dvector.cast_hrfl},
      {simp[bounded_preformula.cast_eq_rfl], apply bounded_preformula.cast_eq_hrfl}}
end

-- /- The statement of this isn't quite right -/
-- lemma asjh'' {L} {S : Structure L}  : ∀ {n n' n'' : ℕ} {n'''} {l} {h : n + n' + 1 = n''} {h' : n'' + 1 = n'''} (f : bounded_preformula L (n''') l) (t : bounded_term L n') (v : dvector S n'') (xs : dvector S l), (S[(f[t  // (n+1) // (by {substs h h', simp})]).cast_eq (by {subst h, simp}) ;; v ;; xs]) = (S[f.cast_eq (by substs h h'; simp) ;; (v.insert (S[t.cast (by {substs h h', linarith}) ;;; v]) (n+1)) ;; xs])
-- :=
-- begin
--   intros,
--   induction f generalizing n n' n'' v,
--     {intros, simp},
--     {sorry},
--     {simp},
--     {sorry},
--     {have this_f := f_ih_f₁ xs v t, have this_g := f_ih_f₂ xs v t, simp, simp at this_f this_g, rw[<-this_f,<-this_g]},
--     {substs h h', have := @subst_all' L (n+1) n' (n + n' + 1 + 1) (by {simp}) t (f_f), ext, simp[this], let k, swap, change realize_bounded_formula v (bounded_preformula.cast_eq k _) _ ↔ _,
-- let j, swap, change realize_bounded_formula v (bounded_preformula.cast_eq k (∀' j)) _ ↔ _,
-- rw[cast_eq_all], dsimp[k,j], clear k j, apply forall_congr, intro x,
--      have := @f_ih xs (n+1) n' ((n+1) + n' + 1) (x::(v.cast (by simp))) (by simp) (by simp) t,
--      rw[cast_eq_trans], rw[<-dvector_cast_push_in] at this, swap, simp, swap, simp, simp,
--      rw[realize_bounded_formula_cast_eq_irrel], rw[realize_bounded_formula_cast_eq_irrel] at this, rw[dvector.cast_trans] at this, rw[this], clear this, clear this f_ih,
--      rw[dvector.insert_cons], apply iff_of_eq, congr' 1, simp, swap, {apply cast_eq_hrfl},
--      {swap, simp, rw[dvector.insert_cons], simp, rw[dvector.insert_cons],--  let p, swap,
--      -- let q, swap, change p == q,
--      -- apply (@heq_iff_eq _ p (q.cast (by simp))).mpr, }}
--      congr' 1, simp, sorry, sorry}}
-- end
-- AHA! so we can see here that the term itself actually needs to be lifted... by 1.
-- note: doing just t ↦ t ↑ 1 doesn't work. need to lift the formula instead

-- #check (((&0 ≃ &1) : bounded_formula L_empty 2) ⟹ (∀'((&0 ≃ &1 : bounded_formula L_empty 3) ⊓ (&0 ≃ &2 : bounded_formula L_empty 3)) : bounded_formula L_empty 2))

-- TODO : figure out the correct statement of this lemma
-- lemma asjh'' {L} {S : Structure L}  : ∀ {n n' n'' : ℕ} {l} {h : n + n' + 1 = n''} (f : bounded_preformula L n'' l) (t : bounded_term L n') (v : dvector S n'') (xs : dvector S l), (S[((f ↑' 1 # (n+1))[t  // (n+1) // (by {subst h, simp})]).cast_eq (by {subst h, simp}) ;; v ;; xs]) ↔ (S[f.cast (by {subst h, repeat{constructor} }) ;; (v.insert (S[t.cast (by {subst h, linarith}) ;;; v]) (n+1)) ;; xs])
-- :=
-- begin
--   intros,
--   induction f generalizing n n' v,
--     {intros, simp},
--     {sorry},
--     {simp},
--     {sorry},
--     {-- have this_f := f_ih_f₁ xs v t, have this_g := f_ih_f₂ xs v t, simp, simp at this_f this_g, simp*
--     sorry
--     },
--     {rw[subst_all'],
--       }

-- substs h h', have := @subst_all' L (n+1) n' (n + n' + 1 + 1) (by {simp}) t (f_f), simp[this], let k, swap, change realize_bounded_formula v (bounded_preformula.cast_eq k _) _ ↔ _,
-- let j, swap, change realize_bounded_formula v (bounded_preformula.cast_eq k (∀' j)) _ ↔ _,
-- rw[cast_eq_all], dsimp[k,j], clear k j, apply forall_congr, intro x,
--      have := @f_ih xs (n+1) n' ((n+1) + n' + 1) (x::(v.cast (by simp))) (by simp) (by simp) t,
--      rw[cast_eq_trans], rw[dvector_cast_pull_out] at this, swap, simp, swap, simp, simp,
--      rw[realize_bounded_formula_cast_eq_irrel], rw[realize_bounded_formula_cast_eq_irrel] at this, rw[dvector.cast_trans] at this, rw[this], clear this, clear this f_ih,
--      rw[dvector.insert_cons], apply iff_of_eq, congr' 2; simp,

--  -- congr' 1, simp, swap, {apply cast_eq_hrfl},
--      -- {swap, simp, rw[dvector.insert_cons], simp, rw[dvector.insert_cons], let p, swap,
--      -- let q, swap, change p == q, apply (@heq_iff_eq _ p (q.cast (by simp))).mpr, }
-- }

-- -- congr' 2, simp, simp, {apply realize_bounded_term_irrel', swap, simp, tidy,  },
--      -- {apply dvector.cast_hrfl}, {apply cast_eq_hrfl},

-- have := @subst_all' L (n+1) n' (n'' + 1) (by {subst h, simp}) t (f_f.cast_eq (by simp[h'])),ext, simp[-subst_all'] at this,

-- @[simp]lemma subst_all' {L} {n n' n''} {h : n + n' + 1 = n''} {t : bounded_term L n'} {f : bounded_formula L (n'' + 1)} :
  -- (∀'f)[t  // n // (by {simp[h]})]
  -- = ∀'(f[(t : bounded_term L n') // (n+1) // (by {subst h; simp})]).cast_eq (by simp) := by ext; simp

-- | _ _ _ _ _ _ _ bd_falsum t v xs := by {intros; simp}
-- | _ _ _ _ _ _ _ (t₁ ≃ t₂) t v xs := by {sorry} -- follows from term version
-- | _ _ _ _ _ _ _ (bd_rel R) t v xs := by simp
-- | _ _ _  _ _ _ _ (bd_apprel f s) t v xs := by sorry
-- | _ _ _ n'' l h h' (f ⟹ g) t v xs := by {have this_f := asjh'' f t v xs, have this_g := asjh'' g t v xs, simp[*, -asjh''], simp at this_f this_g, rw[<-this_f,<-this_g]}
-- | n n' n'' n''' l h h' (∀' f) t v xs := begin
-- -- clear asjh'',
-- substs h h',
-- simp,
--         let k, swap, change _ = k, let j, tactic.rotate 1, change realize_bounded_formula v (bounded_preformula.cast_eq _ ∀'j) _ = k, swap, by simp,
--         conv {to_lhs, congr, skip, rw[bounded_preformula.cast_eq_all],}, dsimp[k,j], clear k j,
--         ext, apply forall_congr, intro x, repeat{rw[realize_bounded_formula_cast_eq_irrel]},
--         rw[dvector.cast_trans], rw[<-dvector.insert],
--         swap,
--         have := @asjh'' (n+1) n' (n + n' + 1 + 1) (n + n' + 1 + 1 + 1) 0 (by {simp}) (by refl) f t (x::v) xs, simp at this,
--       sorry --- might need to lift, actually

@[simp]lemma realize_bounded_term_subst0 {L} {S : Structure L} {n} (s : bounded_term L (n+1)) {v : dvector S n} (t : closed_term L) : realize_bounded_term v (s[(t.cast (by simp)) /0]) [] = realize_bounded_term ((realize_closed_term S t)::v) s [] :=
begin
revert s, refine bounded_term.rec1 _ _,
  {intro k, rcases k with ⟨k_val, k_H⟩, simp,
    induction n generalizing k_val, swap,
    by_cases k_val = n_n + 1,
          {subst h, refl},
          {have : k_val < n_n + 1,
                by {apply nat.lt_of_le_and_ne, exact nat.le_of_lt_succ k_H, exact h},
          have := @n_ih (v.trunc _ (nat.le_succ n_n)) k_val this,
          rw[dvector.nth_irrel1] at this, swap, dedup, apply nat.lt_of_lt_of_le, exact this,
          exact nat.le_succ (n_n + 1),
          rw[<-this], apply realize_bounded_term_irrel', swap, simp,
          intros, simp only [dvector.trunc_nth]},
    have := zero_of_lt_one k_val (by exact k_H), subst this,
    congr, {apply dvector.zero_eq}, {ext, simp}},
  {intros, simp[subst0_bounded_term_bd_apps,realize_bounded_term_bd_apps, func_subst0_irrel],
  congr' 1, apply dvector.map_congr_pmem, intros x Hx, exact ih_ts x Hx}
end

-- /-- realization of a subst0 is the realization with the substituted term prepended to the realizing vector --/
lemma realize_bounded_formula_subst0 {L} {S : Structure L} {n} (f : bounded_formula L (n+1)) {v : dvector S n} (t : closed_term L) : realize_bounded_formula v (f[(t.cast0 n) /0]) [] ↔ realize_bounded_formula ((realize_closed_term S t)::v) f [] :=
begin
  revert n f v, refine bounded_formula.rec1 _ _ _ _ _; intros,
  {simp},
  {simp},
  {rw[subst0_bounded_formula_bd_apps_rel], simp[realize_bounded_formula_bd_apps_rel, rel_subst0_irrel]},
  {simp*},
  {simp[-realize_bounded_formula_cast_eq_irrel], apply forall_congr, clear ih, intro x, have := @gen_realize_bounded_formula L S 0 n (n+1) (n+2) 0 (by simp) (by simp) f t (x::v) [], simpa using this}
end

lemma realize_bounded_formula_subst0' {L} {S : Structure L} {n} (f : bounded_formula L (n+1)) {v : dvector S n} (t : bounded_term L 1) (x : S) : realize_bounded_formula (x :: v) ((f ↑' 1 # 1)[(t.cast (by simp)) /0]) [] ↔ realize_bounded_formula ((realize_bounded_term ([x] : dvector S 1) t []) :: v) f [] :=
begin
revert f n v, refine bounded_formula.rec1 _ _ _ _ _; intros,
  {simp},
  {sorry}, -- this requires a version of this lemma for terms
  {sorry}, -- same issue as the corresponding case above
  {sorry}, -- this one should be easy, just need a lemma about commutation with bd_imp
  {sorry}, -- same issues as the corresponding case above
end

end realization

export fol realization


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import algebraic_geometry.pullbacks
import category_theory.morphism_property

/-!
# Properties of morphisms between Schemes

We provide the basic framework for talking about properties of morphisms between Schemes.

A `morphism_property Scheme` is a predicate on morphisms between schemes, and an
`affine_target_morphism_property` is a predicate on morphisms into affine schemes. Given a
`P : affine_target_morphism_property`, we may construct a `morphism_property` called
`target_affine_locally P` that holds for `f : X ⟶ Y` whenever `P` holds for the
restriction of `f` on every affine open subset of `Y`.

## Main definitions

- `algebraic_geometry.affine_target_morphism_property.is_local`: We say that `P.is_local` if `P`
satisfies the assumptions of the affine communication lemma
(`algebraic_geometry.of_affine_open_cover`). That is,
1. `P` respects isomorphisms.
2. If `P` holds for `f : X ⟶ Y`, then `P` holds for `f ∣_ Y.basic_open r` for any
  global section `r`.
3. If `P` holds for `f ∣_ Y.basic_open r` for all `r` in a spanning set of the global sections,
  then `P` holds for `f`.

- `algebraic_geometry.property_is_local_at_target`: We say that `property_is_local_at_target P` for
`P : morphism_property Scheme` if
1. `P` respects isomorphisms.
2. If `P` holds for `f : X ⟶ Y`, then `P` holds for `f ∣_ U` for any `U`.
3. If `P` holds for `f ∣_ U` for an open cover `U` of `Y`, then `P` holds for `f`.

## Main results

- `algebraic_geometry.affine_target_morphism_property.is_local.affine_open_cover_tfae`:
  If `P.is_local`, then `target_affine_locally P f` iff there exists an affine cover `{ Uᵢ }` of `Y`
  such that `P` holds for `f ∣_ Uᵢ`.
- `algebraic_geometry.affine_target_morphism_property.is_local_of_open_cover_imply`:
  If the existance of an affine cover `{ Uᵢ }` of `Y` such that `P` holds for `f ∣_ Uᵢ` implies
  `target_affine_locally P f`, then `P.is_local`.
- `algebraic_geometry.affine_target_morphism_property.is_local.affine_target_iff`:
  If `Y` is affine and `f : X ⟶ Y`, then `target_affine_locally P f ↔ P f` provided `P.is_local`.
- `algebraic_geometry.affine_target_morphism_property.is_local.target_affine_locally_is_local` :
  If `P.is_local`, then `property_is_local_at_target (target_affine_locally P)`.
- `algebraic_geometry.property_is_local_at_target.open_cover_tfae`:
  If `property_is_local_at_target P`, then `P f` iff there exists an open cover `{ Uᵢ }` of `Y`
  such that `P` holds for `f ∣_ Uᵢ`.

These results should not be used directly, and should be ported to each property that is local.

-/

universe u

open topological_space category_theory category_theory.limits opposite

noncomputable theory

namespace algebraic_geometry

/-- An `affine_target_morphism_property` is a class of morphisms from an arbitrary scheme into an
affine scheme. -/
def affine_target_morphism_property := ∀ ⦃X Y : Scheme⦄ (f : X ⟶ Y) [is_affine Y], Prop

/-- `is_iso` as a `morphism_property`. -/
protected def Scheme.is_iso : morphism_property Scheme := @is_iso Scheme _

/-- `is_iso` as an `affine_morphism_property`. -/
protected def Scheme.affine_target_is_iso : affine_target_morphism_property :=
λ X Y f H, is_iso f

instance : inhabited affine_target_morphism_property := ⟨Scheme.affine_target_is_iso⟩

/-- A `affine_target_morphism_property` can be extended to a `morphism_property` such that it
*never* holds when the target is not affine -/
def affine_target_morphism_property.to_property (P : affine_target_morphism_property) :
  morphism_property Scheme :=
λ X Y f, ∃ h, @@P f h

lemma affine_target_morphism_property.to_property_apply (P : affine_target_morphism_property)
  {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  P.to_property f ↔ P f := by { delta affine_target_morphism_property.to_property, simp [*] }

lemma affine_cancel_left_is_iso {P : affine_target_morphism_property}
  (hP : P.to_property.respects_iso) {X Y Z : Scheme} (f : X ⟶ Y)
    (g : Y ⟶ Z) [is_iso f] [is_affine Z] : P (f ≫ g) ↔ P g :=
by rw [← P.to_property_apply, ← P.to_property_apply, hP.cancel_left_is_iso]

lemma affine_cancel_right_is_iso
  {P : affine_target_morphism_property} (hP : P.to_property.respects_iso) {X Y Z : Scheme}
    (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] [is_affine Z] [is_affine Y] : P (f ≫ g) ↔ P f :=
by rw [← P.to_property_apply, ← P.to_property_apply, hP.cancel_right_is_iso]

lemma affine_target_morphism_property.respects_iso_mk {P : affine_target_morphism_property}
  (h₁ : ∀ {X Y Z} (e : X ≅ Y) (f : Y ⟶ Z) [is_affine Z], by exactI P f → P (e.hom ≫ f))
  (h₂ : ∀ {X Y Z} (e : Y ≅ Z) (f : X ⟶ Y) [h : is_affine Y],
     by exactI P f → @@P (f ≫ e.hom) (is_affine_of_iso e.inv)) : P.to_property.respects_iso :=
begin
  split,
  { rintros X Y Z e f ⟨a, h⟩, exactI ⟨a, h₁ e f h⟩ },
  { rintros X Y Z e f ⟨a, h⟩, exactI ⟨is_affine_of_iso e.inv, h₂ e f h⟩ },
end

/-- For a `P : affine_target_morphism_property`, `target_affine_locally P` holds for
`f : X ⟶ Y` whenever `P` holds for the restriction of `f` on every affine open subset of `Y`. -/
def target_affine_locally (P : affine_target_morphism_property) : morphism_property Scheme :=
  λ {X Y : Scheme} (f : X ⟶ Y), ∀ (U : Y.affine_opens), @@P (f ∣_ U) U.prop

lemma is_affine_open.map_is_iso {X Y : Scheme} {U : opens Y.carrier} (hU : is_affine_open U)
  (f : X ⟶ Y) [is_iso f] : is_affine_open ((opens.map f.1.base).obj U) :=
begin
  haveI : is_affine _ := hU,
  exact is_affine_of_iso (f ∣_ U),
end

lemma target_affine_locally_respects_iso {P : affine_target_morphism_property}
  (hP : P.to_property.respects_iso) : (target_affine_locally P).respects_iso :=
begin
  split,
  { introv H U,
    rw [morphism_restrict_comp, affine_cancel_left_is_iso hP],
    exact H U },
  { introv H,
    rintro ⟨U, hU : is_affine_open U⟩, dsimp,
    haveI : is_affine _ := hU,
    haveI : is_affine _ := hU.map_is_iso e.hom,
    rw [morphism_restrict_comp, affine_cancel_right_is_iso hP],
    exact H ⟨(opens.map e.hom.val.base).obj U, hU.map_is_iso e.hom⟩ }
end

/--
We say that `P : affine_target_morphism_property` is a local property if
1. `P` respects isomorphisms.
2. If `P` holds for `f : X ⟶ Y`, then `P` holds for `f ∣_ Y.basic_open r` for any
  global section `r`.
3. If `P` holds for `f ∣_ Y.basic_open r` for all `r` in a spanning set of the global sections,
  then `P` holds for `f`.
-/
structure affine_target_morphism_property.is_local (P : affine_target_morphism_property) : Prop :=
(respects_iso : P.to_property.respects_iso)
(to_basic_open : ∀ {X Y : Scheme} [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj $ op ⊤),
  by exactI P f →
    @@P (f ∣_ (Y.basic_open r)) ((top_is_affine_open Y).basic_open_is_affine _))
(of_basic_open_cover : ∀ {X Y : Scheme} [is_affine Y] (f : X ⟶ Y)
  (s : finset (Y.presheaf.obj $ op ⊤)) (hs : ideal.span (s : set (Y.presheaf.obj $ op ⊤)) = ⊤),
  by exactI (∀ (r : s), @@P (f ∣_ (Y.basic_open r.1))
    ((top_is_affine_open Y).basic_open_is_affine _)) → P f)

lemma target_affine_locally_of_open_cover {P : affine_target_morphism_property}
  (hP : P.is_local)
  {X Y : Scheme} (f : X ⟶ Y) (𝒰 : Y.open_cover) [∀ i, is_affine (𝒰.obj i)]
  (h𝒰 : ∀ i, P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i)) :
    target_affine_locally P f :=
begin
  classical,
  let S := λ i, (⟨⟨set.range (𝒰.map i).1.base, (𝒰.is_open i).base_open.open_range⟩,
    range_is_affine_open_of_open_immersion (𝒰.map i)⟩ : Y.affine_opens),
  intro U,
  apply of_affine_open_cover U (set.range S),
  { intros U r h,
    haveI : is_affine _ := U.2,
    have := hP.2 (f ∣_ U.1),
    replace this := this (Y.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op r) h,
    rw ← P.to_property_apply at this ⊢,
    exact (hP.1.arrow_mk_iso_iff (morphism_restrict_restrict_basic_open f _ r)).mp this },
  { intros U s hs H,
    haveI : is_affine _ := U.2,
    apply hP.3 (f ∣_ U.1) (s.image (Y.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op)),
    { apply_fun ideal.comap (Y.presheaf.map (eq_to_hom U.1.open_embedding_obj_top.symm).op) at hs,
      rw ideal.comap_top at hs,
      rw ← hs,
      simp only [eq_to_hom_op, eq_to_hom_map, finset.coe_image],
      have : ∀ {R S : CommRing} (e : S = R) (s : set S),
        (by exactI ideal.span (eq_to_hom e '' s) = ideal.comap (eq_to_hom e.symm) (ideal.span s)),
      { intros, subst e, simpa },
      apply this },
    { rintro ⟨r, hr⟩,
      obtain ⟨r, hr', rfl⟩ := finset.mem_image.mp hr,
      simp_rw ← P.to_property_apply at ⊢ H,
      exact
        (hP.1.arrow_mk_iso_iff (morphism_restrict_restrict_basic_open f _ r)).mpr (H ⟨r, hr'⟩) } },
  { rw set.eq_univ_iff_forall,
    simp only [set.mem_Union],
    intro x,
    exact ⟨⟨_, ⟨𝒰.f x, rfl⟩⟩, 𝒰.covers x⟩ },
  { rintro ⟨_, i, rfl⟩,
    simp_rw ← P.to_property_apply at ⊢ h𝒰,
    exact (hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _)).mpr (h𝒰 i) },
end

lemma affine_target_morphism_property.is_local.affine_open_cover_tfae
  {P : affine_target_morphism_property}
  (hP : P.is_local) {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [target_affine_locally P f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)], ∀ (i : 𝒰.J),
      by exactI P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      by exactI P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      by exactI P (pullback.snd : pullback f g ⟶ U),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤) (hU' : ∀ i, is_affine_open (U i)),
      ∀ i, @@P (f ∣_ (U i)) (hU' i)] :=
begin
  tfae_have : 1 → 4,
  { intros H U g h₁ h₂,
    resetI,
    replace H := H ⟨⟨_, h₂.base_open.open_range⟩,
      range_is_affine_open_of_open_immersion g⟩,
    rw ← P.to_property_apply at H ⊢,
    rwa ← hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _) },
  tfae_have : 4 → 3,
  { intros H 𝒰 h𝒰 i,
    resetI,
    apply H },
  tfae_have : 3 → 2,
  { exact λ H, ⟨Y.affine_cover, infer_instance, H Y.affine_cover⟩ },
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, h𝒰, H⟩, exactI target_affine_locally_of_open_cover hP f 𝒰 H },
  tfae_have : 5 → 2,
  { rintro ⟨ι, U, hU, hU', H⟩,
    refine ⟨Y.open_cover_of_supr_eq_top U hU, hU', _⟩,
    intro i,
    specialize H i,
    rw [← P.to_property_apply, ← hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _)],
    rw ← P.to_property_apply at H,
    convert H,
    all_goals { ext1, exact subtype.range_coe } },
  tfae_have : 1 → 5,
  { intro H,
    refine ⟨Y.carrier, λ x, (Y.affine_cover.map x).opens_range, _,
      λ i, range_is_affine_open_of_open_immersion _, _⟩,
    { rw eq_top_iff, intros x _, erw opens.mem_supr, exact⟨x, Y.affine_cover.covers x⟩ },
    { intro i, exact H ⟨_, range_is_affine_open_of_open_immersion _⟩ } },
  tfae_finish
end

lemma affine_target_morphism_property.is_local_of_open_cover_imply
  (P : affine_target_morphism_property) (hP : P.to_property.respects_iso)
  (H : ∀ {X Y : Scheme.{u}} (f : X ⟶ Y),
    (∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)], ∀ (i : 𝒰.J),
      by exactI P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i)) →
    (∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      by exactI P (pullback.snd : pullback f g ⟶ U))) : P.is_local :=
begin
  refine ⟨hP, _, _⟩,
  { introv h,
    resetI,
    haveI : is_affine _ := (top_is_affine_open Y).basic_open_is_affine r,
    delta morphism_restrict,
    rw affine_cancel_left_is_iso hP,
    refine @@H f ⟨Scheme.open_cover_of_is_iso (𝟙 Y), _, _⟩ (Y.of_restrict _) _inst _,
    { intro i, dsimp, apply_instance },
    { intro i, dsimp,
      rwa [← category.comp_id pullback.snd, ← pullback.condition, affine_cancel_left_is_iso hP] } },
  { introv hs hs',
    resetI,
    replace hs := ((top_is_affine_open Y).basic_open_union_eq_self_iff _).mpr hs,
    have := H f ⟨Y.open_cover_of_supr_eq_top _ hs, _, _⟩ (𝟙 _),
    rwa [← category.comp_id pullback.snd, ← pullback.condition,
      affine_cancel_left_is_iso hP] at this,
    { intro i, exact (top_is_affine_open Y).basic_open_is_affine _ },
    { rintro (i : s),
      specialize hs' i,
      haveI : is_affine _ := (top_is_affine_open Y).basic_open_is_affine i.1,
      delta morphism_restrict at hs',
      rwa affine_cancel_left_is_iso hP at hs' } }
end

lemma affine_target_morphism_property.is_local.affine_open_cover_iff
  {P : affine_target_morphism_property} (hP : P.is_local)
  {X Y : Scheme.{u}} (f : X ⟶ Y) (𝒰 : Scheme.open_cover.{u} Y) [h𝒰 : ∀ i, is_affine (𝒰.obj i)] :
  target_affine_locally P f ↔ ∀ i, @@P (pullback.snd : pullback f (𝒰.map i) ⟶ _) (h𝒰 i) :=
⟨λ H, let h := ((hP.affine_open_cover_tfae f).out 0 2).mp H in h 𝒰,
  λ H, let h := ((hP.affine_open_cover_tfae f).out 1 0).mp in h ⟨𝒰, infer_instance, H⟩⟩

lemma affine_target_morphism_property.is_local.affine_target_iff
  {P : affine_target_morphism_property} (hP : P.is_local)
  {X Y : Scheme.{u}} (f : X ⟶ Y) [is_affine Y] :
  target_affine_locally P f ↔ P f :=
begin
  rw hP.affine_open_cover_iff f _,
  swap, { exact Scheme.open_cover_of_is_iso (𝟙 Y) },
  swap, { intro _, dsimp, apply_instance },
  transitivity (P (pullback.snd : pullback f (𝟙 _) ⟶ _)),
  { exact ⟨λ H, H punit.star, λ H _, H⟩ },
  rw [← category.comp_id pullback.snd, ← pullback.condition, affine_cancel_left_is_iso hP.1],
end

/--
We say that `P : morphism_property Scheme` is local at the target if
1. `P` respects isomorphisms.
2. If `P` holds for `f : X ⟶ Y`, then `P` holds for `f ∣_ U` for any `U`.
3. If `P` holds for `f ∣_ U` for an open cover `U` of `Y`, then `P` holds for `f`.
-/
structure property_is_local_at_target (P : morphism_property Scheme) : Prop :=
(respects_iso : P.respects_iso)
(restrict : ∀ {X Y : Scheme} (f : X ⟶ Y) (U : opens Y.carrier), P f → P (f ∣_ U))
(of_open_cover : ∀ {X Y : Scheme.{u}} (f : X ⟶ Y) (𝒰 : Scheme.open_cover.{u} Y),
    (∀ (i : 𝒰.J), P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i)) → P f)

lemma affine_target_morphism_property.is_local.target_affine_locally_is_local
  {P : affine_target_morphism_property} (hP : P.is_local) :
    property_is_local_at_target (target_affine_locally P) :=
begin
  constructor,
  { exact target_affine_locally_respects_iso hP.1 },
  { intros X Y f U H V,
    rw [← P.to_property_apply, hP.1.arrow_mk_iso_iff (morphism_restrict_restrict f _ _)],
    convert H ⟨_, is_affine_open.image_is_open_immersion V.2 (Y.of_restrict _)⟩,
    rw ← P.to_property_apply,
    refl },
  { rintros X Y f 𝒰 h𝒰,
    rw (hP.affine_open_cover_tfae f).out 0 1,
    refine ⟨𝒰.bind (λ _, Scheme.affine_cover _), _, _⟩,
    { intro i, dsimp [Scheme.open_cover.bind], apply_instance },
    { intro i,
      specialize h𝒰 i.1,
      rw (hP.affine_open_cover_tfae (pullback.snd : pullback f (𝒰.map i.fst) ⟶ _)).out 0 2
        at h𝒰,
      specialize h𝒰 (Scheme.affine_cover _) i.2,
      let e : pullback f ((𝒰.obj i.fst).affine_cover.map i.snd ≫ 𝒰.map i.fst) ⟶
        pullback (pullback.snd : pullback f (𝒰.map i.fst) ⟶ _)
          ((𝒰.obj i.fst).affine_cover.map i.snd),
      { refine (pullback_symmetry _ _).hom ≫ _,
        refine (pullback_right_pullback_fst_iso _ _ _).inv ≫ _,
        refine (pullback_symmetry _ _).hom ≫ _,
        refine pullback.map _ _ _ _ (pullback_symmetry _ _).hom (𝟙 _) (𝟙 _) _ _;
          simp only [category.comp_id, category.id_comp, pullback_symmetry_hom_comp_snd] },
      rw ← affine_cancel_left_is_iso hP.1 e at h𝒰,
      convert h𝒰,
      simp } },
end

lemma property_is_local_at_target.open_cover_tfae
  {P : morphism_property Scheme}
  (hP : property_is_local_at_target P)
  {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [P f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      P (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), P (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      P (pullback.snd : pullback f g ⟶ U),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), (∀ i, P (f ∣_ (U i)))] :=
begin
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, H⟩, exact hP.3 f 𝒰 H },
  tfae_have : 1 → 4,
  { intros H U, exact hP.2 f U H },
  tfae_have : 4 → 3,
  { intros H 𝒰 i,
    rw ← hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _),
    exact H (𝒰.map i).opens_range },
  tfae_have : 3 → 2,
  { exact λ H, ⟨Y.affine_cover, H Y.affine_cover⟩ },
  tfae_have : 4 → 5,
  { intros H U g hg,
    resetI,
    rw ← hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _),
    apply H },
  tfae_have : 5 → 4,
  { intros H U,
    erw hP.1.cancel_left_is_iso,
    apply H },
  tfae_have : 4 → 6,
  { intro H, exact ⟨punit, λ _, ⊤, csupr_const, λ _, H _⟩ },
  tfae_have : 6 → 2,
  { rintro ⟨ι, U, hU, H⟩,
    refine ⟨Y.open_cover_of_supr_eq_top U hU, _⟩,
    intro i,
    rw ← hP.1.arrow_mk_iso_iff (morphism_restrict_opens_range f _),
    convert H i,
    all_goals { ext1, exact subtype.range_coe } },
  tfae_finish
end

lemma property_is_local_at_target.open_cover_iff
  {P : morphism_property Scheme} (hP : property_is_local_at_target P)
  {X Y : Scheme.{u}} (f : X ⟶ Y) (𝒰 : Scheme.open_cover.{u} Y) :
  P f ↔ ∀ i, P (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
⟨λ H, let h := ((hP.open_cover_tfae f).out 0 2).mp H in h 𝒰,
  λ H, let h := ((hP.open_cover_tfae f).out 1 0).mp in h ⟨𝒰, H⟩⟩

namespace affine_target_morphism_property

/-- A `P : affine_target_morphism_property` is stable under base change if `P` holds for `Y ⟶ S`
implies that `P` holds for `X ×ₛ Y ⟶ X` with `X` and `S` affine schemes. -/
def stable_under_base_change
  (P : affine_target_morphism_property) : Prop :=
∀ ⦃X Y S : Scheme⦄ [is_affine S] [is_affine X] (f : X ⟶ S) (g : Y ⟶ S),
  by exactI P g → P (pullback.fst : pullback f g ⟶ X)

lemma is_local.target_affine_locally_pullback_fst_of_right_of_stable_under_base_change
  {P : affine_target_morphism_property} (hP : P.is_local) (hP' : P.stable_under_base_change)
  {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_affine S] (H : P g) :
  target_affine_locally P (pullback.fst : pullback f g ⟶ X) :=
begin
  rw (hP.affine_open_cover_tfae (pullback.fst : pullback f g ⟶ X)).out 0 1,
  use [X.affine_cover, infer_instance],
  intro i,
  let e := pullback_symmetry _ _ ≪≫ pullback_right_pullback_fst_iso f g (X.affine_cover.map i),
  have : e.hom ≫ pullback.fst = pullback.snd := by simp,
  rw [← this, affine_cancel_left_is_iso hP.1],
  apply hP'; assumption,
end

lemma is_local.stable_under_base_change
  {P : affine_target_morphism_property} (hP : P.is_local) (hP' : P.stable_under_base_change) :
  (target_affine_locally P).stable_under_base_change :=
morphism_property.stable_under_base_change.mk (target_affine_locally_respects_iso hP.respects_iso)
begin
  intros X Y S f g H,
  rw (hP.target_affine_locally_is_local.open_cover_tfae (pullback.fst : pullback f g ⟶ X)).out 0 1,
  use S.affine_cover.pullback_cover f,
  intro i,
  rw (hP.affine_open_cover_tfae g).out 0 3 at H,
  let e : pullback (pullback.fst : pullback f g ⟶ _) ((S.affine_cover.pullback_cover f).map i) ≅ _,
  { refine pullback_symmetry _ _ ≪≫ pullback_right_pullback_fst_iso f g _ ≪≫ _ ≪≫
      (pullback_right_pullback_fst_iso (S.affine_cover.map i) g
        (pullback.snd : pullback f (S.affine_cover.map i) ⟶ _)).symm,
    exact as_iso (pullback.map _ _ _ _ (𝟙 _) (𝟙 _) (𝟙 _)
      (by simpa using pullback.condition) (by simp)) },
  have : e.hom ≫ pullback.fst = pullback.snd := by simp,
  rw [← this, (target_affine_locally_respects_iso hP.1).cancel_left_is_iso],
  apply hP.target_affine_locally_pullback_fst_of_right_of_stable_under_base_change hP',
  rw [← pullback_symmetry_hom_comp_snd, affine_cancel_left_is_iso hP.1],
  apply H
end

end affine_target_morphism_property

/--
The `affine_target_morphism_property` associated to `(target_affine_locally P).diagonal`.
See `diagonal_target_affine_locally_eq_target_affine_locally`.
-/
def affine_target_morphism_property.diagonal (P : affine_target_morphism_property) :
  affine_target_morphism_property :=
λ X Y f hf, ∀ {U₁ U₂ : Scheme} (f₁ : U₁ ⟶ X) (f₂ : U₂ ⟶ X) [is_affine U₁] [is_affine U₂]
  [is_open_immersion f₁] [is_open_immersion f₂],
  by exactI P (pullback.map_desc f₁ f₂ f)

lemma affine_target_morphism_property.diagonal_respects_iso (P : affine_target_morphism_property)
  (hP : P.to_property.respects_iso) :
  P.diagonal.to_property.respects_iso :=
begin
  delta affine_target_morphism_property.diagonal,
  apply affine_target_morphism_property.respects_iso_mk,
  { introv H _ _,
    resetI,
    rw [pullback.map_desc_comp, affine_cancel_left_is_iso hP, affine_cancel_right_is_iso hP],
    apply H },
  { introv H _ _,
    resetI,
    rw [pullback.map_desc_comp, affine_cancel_right_is_iso hP],
    apply H }
end

lemma diagonal_target_affine_locally_of_open_cover (P : affine_target_morphism_property)
  (hP : P.is_local)
  {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (𝒰' : Π i, Scheme.open_cover.{u} (pullback f (𝒰.map i)))
  [∀ i j, is_affine ((𝒰' i).obj j)]
  (h𝒰' : ∀ i j k, P (pullback.map_desc ((𝒰' i).map j) ((𝒰' i).map k) pullback.snd)) :
    (target_affine_locally P).diagonal f :=
begin
  refine (hP.affine_open_cover_iff _ _).mpr _,
  { exact ((Scheme.pullback.open_cover_of_base 𝒰 f f).bind (λ i,
      Scheme.pullback.open_cover_of_left_right.{u u} (𝒰' i) (𝒰' i) pullback.snd pullback.snd)) },
  { intro i,
    dsimp at *,
    apply_instance },
  { rintro ⟨i, j, k⟩,
    dsimp,
    convert (affine_cancel_left_is_iso hP.1
    (pullback_diagonal_map_iso _ _ ((𝒰' i).map j) ((𝒰' i).map k)).inv pullback.snd).mp _,
    swap 3,
    { convert h𝒰' i j k, apply pullback.hom_ext; simp, },
    all_goals
    { apply pullback.hom_ext; simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
      pullback.lift_fst_assoc, pullback.lift_snd_assoc] } }
end

lemma affine_target_morphism_property.diagonal_of_target_affine_locally
  (P : affine_target_morphism_property)
  (hP : P.is_local) {X Y U : Scheme.{u}} (f : X ⟶ Y) (g : U ⟶ Y)
  [is_affine U] [is_open_immersion g] (H : (target_affine_locally P).diagonal f) :
    P.diagonal (pullback.snd : pullback f g ⟶ _) :=
begin
  rintros U V f₁ f₂ _ _ _ _,
  resetI,
  replace H := ((hP.affine_open_cover_tfae (pullback.diagonal f)).out 0 3).mp H,
  let g₁ := pullback.map (f₁ ≫ pullback.snd)
    (f₂ ≫ pullback.snd) f f
    (f₁ ≫ pullback.fst)
    (f₂ ≫ pullback.fst) g
    (by rw [category.assoc, category.assoc, pullback.condition])
    (by rw [category.assoc, category.assoc, pullback.condition]),
  let g₂ : pullback f₁ f₂ ⟶ pullback f g := pullback.fst ≫ f₁,
  specialize H g₁,
  rw ← affine_cancel_left_is_iso hP.1 (pullback_diagonal_map_iso f _ f₁ f₂).hom,
  convert H,
  { apply pullback.hom_ext; simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
    pullback.lift_fst_assoc, pullback.lift_snd_assoc, category.comp_id,
    pullback_diagonal_map_iso_hom_fst, pullback_diagonal_map_iso_hom_snd], }
end

lemma affine_target_morphism_property.is_local.diagonal_affine_open_cover_tfae
  {P : affine_target_morphism_property}
  (hP : P.is_local) {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [(target_affine_locally P).diagonal f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)], by exactI
      ∀ (i : 𝒰.J), P.diagonal (pullback.snd : pullback f (𝒰.map i) ⟶ _),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J), by exactI
      P.diagonal (pullback.snd : pullback f (𝒰.map i) ⟶ _),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g], by exactI
      P.diagonal (pullback.snd : pullback f g ⟶ _),
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)]
      (𝒰' : Π i, Scheme.open_cover.{u} (pullback f (𝒰.map i))) [∀ i j, is_affine ((𝒰' i).obj j)],
    by exactI ∀ i j k, P (pullback.map_desc ((𝒰' i).map j) ((𝒰' i).map k) pullback.snd)] :=
begin
  tfae_have : 1 → 4,
  { introv H hU hg _ _, resetI, apply P.diagonal_of_target_affine_locally; assumption },
  tfae_have : 4 → 3,
  { introv H h𝒰, resetI, apply H },
  tfae_have : 3 → 2,
  { exact λ H, ⟨Y.affine_cover, infer_instance, H Y.affine_cover⟩ },
  tfae_have : 2 → 5,
  { rintro ⟨𝒰, h𝒰, H⟩,
    resetI,
    refine ⟨𝒰, infer_instance, λ _, Scheme.affine_cover _, infer_instance, _⟩,
    intros i j k,
    apply H },
  tfae_have : 5 → 1,
  { rintro ⟨𝒰, _, 𝒰', _, H⟩,
    exactI diagonal_target_affine_locally_of_open_cover P hP f 𝒰 𝒰' H, },
  tfae_finish
end

lemma affine_target_morphism_property.is_local.diagonal {P : affine_target_morphism_property}
  (hP : P.is_local) : P.diagonal.is_local :=
affine_target_morphism_property.is_local_of_open_cover_imply
  P.diagonal
  (P.diagonal_respects_iso hP.1)
  (λ _ _ f, ((hP.diagonal_affine_open_cover_tfae f).out 1 3).mp)

lemma diagonal_target_affine_locally_eq_target_affine_locally (P : affine_target_morphism_property)
  (hP : P.is_local) :
  (target_affine_locally P).diagonal = target_affine_locally P.diagonal :=
begin
  ext _ _ f,
  exact ((hP.diagonal_affine_open_cover_tfae f).out 0 1).trans
    ((hP.diagonal.affine_open_cover_tfae f).out 1 0),
end

lemma universally_is_local_at_target_of_morphism_restrict (P : morphism_property Scheme)
  (hP₁ : P.respects_iso)
  (hP₂ : ∀ {X Y : Scheme.{u}} (f : X ⟶ Y) {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤),
    (∀ i, P (f ∣_ (U i))) → P f) :
  property_is_local_at_target P.universally :=
universally_is_local_at_target P
begin
  intros X Y f 𝒰 h𝒰,
  apply hP₂ f (λ (i : 𝒰.J), (𝒰.map i).opens_range) 𝒰.supr_opens_range,
  simp_rw hP₁.arrow_mk_iso_iff (morphism_restrict_opens_range f _),
  exact h𝒰
end

/-- `topologically P` holds for a morphism if the underlying topological map satisfies `P`. -/
def morphism_property.topologically
  (P : ∀ {α β : Type u} [topological_space α] [topological_space β] (f : α → β), Prop) :
  morphism_property Scheme.{u} :=
λ X Y f, P f.1.base

end algebraic_geometry


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Supplementary theorems about the `string` type.
-/
import data.list.basic data.char

namespace string

def ltb : iterator → iterator → bool
| s₁ s₂ := begin
  cases s₂.has_next, {exact ff},
  cases h₁ : s₁.has_next, {exact tt},
  exact if s₁.curr = s₂.curr then
    have s₁.next.2.length < s₁.2.length, from
    match s₁, h₁ with ⟨_, a::l⟩, h := nat.lt_succ_self _ end,
    ltb s₁.next s₂.next
  else s₁.curr < s₂.curr,
end
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ s, s.1.2.length)⟩]}

instance has_lt' : has_lt string :=
⟨λ s₁ s₂, ltb s₁.mk_iterator s₂.mk_iterator⟩

instance decidable_lt : @decidable_rel string (<) := by apply_instance

@[simp] theorem lt_iff_to_list_lt :
  ∀ {s₁ s₂ : string}, s₁ < s₂ ↔ s₁.to_list < s₂.to_list
| ⟨i₁⟩ ⟨i₂⟩ :=
  suffices ∀ {p₁ p₂ s₁ s₂}, ltb ⟨p₁, s₁⟩ ⟨p₂, s₂⟩ ↔ s₁ < s₂, from this,
  begin
    intros,
    induction s₁ with a s₁ IH generalizing p₁ p₂ s₂;
      cases s₂ with b s₂; rw ltb; simp [iterator.has_next],
    { exact iff_of_false bool.ff_ne_tt (lt_irrefl _) },
    { exact iff_of_true rfl list.lex.nil },
    { exact iff_of_false bool.ff_ne_tt (not_lt_of_lt list.lex.nil) },
    { dsimp [iterator.has_next,
        iterator.curr, iterator.next],
      split_ifs,
      { subst b, exact IH.trans list.lex.cons_iff.symm },
      { simp, refine ⟨list.lex.rel, λ e, _⟩,
        cases e, {cases h rfl}, assumption } }
  end

instance has_le : has_le string := ⟨λ s₁ s₂, ¬ s₂ < s₁⟩

instance decidable_le : @decidable_rel string (≤) := by apply_instance

@[simp] theorem le_iff_to_list_le
  {s₁ s₂ : string} : s₁ ≤ s₂ ↔ s₁.to_list ≤ s₂.to_list :=
(not_congr lt_iff_to_list_lt).trans not_lt

theorem to_list_inj : ∀ {s₁ s₂}, to_list s₁ = to_list s₂ ↔ s₁ = s₂
| ⟨s₁⟩ ⟨s₂⟩ := ⟨congr_arg _, congr_arg _⟩

instance : decidable_linear_order string :=
by refine_struct {
    lt := (<), le := (≤),
    le_antisymm := by simp; exact
      λ a b h₁ h₂, to_list_inj.1 (le_antisymm h₁ h₂),
    decidable_lt := by apply_instance,
    decidable_le := string.decidable_le,
    decidable_eq := by apply_instance, .. };
  { simp [-not_le], introv, apply_field }

def map_tokens (c : char) (f : list string → list string) : string → string :=
intercalate (singleton c) ∘ f ∘ split (= c)

end string


import .lemmas
import .spec

import data.set.basic

import util.data.minimum
import util.data.ordering
import util.data.order
import util.function
import util.logic
import tactic.norm_num

open temporal function predicate nat set

local infix ` ≃ `:75 := v_eq
local prefix `♯ `:0 := cast (by simp)
universes u v

namespace temporal
namespace scheduling
section scheduling

local attribute [instance, priority 0] classical.prop_decidable
local attribute [-simp] add_comm

parameter {evt : Type u}
parameter Γ : cpred
parameter r : tvar (set evt)
parameter Hr : Γ ⊢ ◻-(r ≃ (∅ : set evt))
-- parameter [nonempty evt]

abbreviation SCHED  (s : tvar evt) :=
◻(s ∊ r) ⋀
∀∀ (e : evt),
  ◻◇(↑e ∊ r) ⟶
  ◻◇(s ≃ ↑e ⋀ ↑e ∊ r)

section implementation

parameters (f : ℕ → evt) (Hinj : surjective f)
parameter p : tvar (ℕ → evt)
parameter cur : tvar ℕ
/- consider making select into a state variable instead of a definition -/
variable select : tvar evt

infixl ` |+| `:80 := lifted₂ has_add.add
infixl ` |-| `:80 := lifted₂ has_sub.sub

noncomputable def next_p (p : ℕ → evt) (r' : set evt) (i : ℕ) : ordering → evt
 | ordering.gt := p i
 | ordering.eq := p (↓ i : ℕ, p i ∈ r')
 | ordering.lt :=
   if (↓ i : ℕ, p i ∈ r') ≤ i
          then p (i + 1)
          else p i

noncomputable def next' (r' : set evt) : ℕ × (ℕ → evt) → ℕ × (ℕ → evt)
 | (cur,p) :=
let min := ↓ i : ℕ, p i ∈ r',
    cur' := max min $ cur+1,
    p' : ℕ → evt := λ i : ℕ,
          next_p p r' i (cmp i cur')
in
(cur',p')

section

noncomputable def next : tvar $ ℕ × (ℕ → evt) → ℕ × (ℕ → evt) :=
⟪ ℕ, next' ⟫ (⊙r)
end

@[simp]
lemma next_def (cur cur' : ℕ) (p p' : ℕ → evt) (σ : ℕ)
: (cur', p') = (σ ⊨ next) (cur, p) ↔
   cur' = max (↓ (i : ℕ), p i ∈ succ σ ⊨ r) (cur + 1) ∧
∀ i, p' i =
          next_p p
            (succ σ ⊨ r) i
            (cmp i cur') :=
by { repeat { simp [next,next'] <|> unfold_coes },
     apply and_congr_right,
     intro,
     split, { introv h, subst cur', simp [h], },
     { intro, apply funext,
       intro, subst cur', solve_by_elim } }

section
parameter f

@[predicate]
noncomputable def cur₀ : tvar ℕ :=
[| r , ↓ i : ℕ, f i ∈ r |]

-- noncomputable abbreviation select₀ : tvar evt :=
-- [| r , f (↓ i : ℕ, f i ∈ r) |]

-- noncomputable def nxt_select : tvar (evt → evt) :=
-- [| p , λ (p' : ℕ → ℕ) (r' : set evt) (e : evt),
--   inv q $ ↓ i : ℕ, inv q i ∈ r' |] (⊙q) (⊙r)

end

noncomputable def Spec :=
⦃cur,p⦄ ≃ ⦃cur₀,f⦄ ⋀ ◻(⊙⦃cur,p⦄ ≃ next ⦃cur,p⦄)

parameter Hq : Γ ⊢ Spec

@[predicate]
def select : tvar evt :=
p cur

-- noncomputable def select_Spec :=
-- select ≃ select₀ ⋀ ◻(⊙select ≃ nxt_select select)

-- variables Hs : Γ ⊢ select_Spec select

section q_injective

lemma next_rec (P : ℕ → Prop) (cur cur') (p p' : ℕ → evt) (r' : set evt)
  {i : ℕ} {e : evt}
  (h : p i = e)
  (Hcur' : cur' = max (↓ (i : ℕ), p i ∈ r') (cur + 1))
  (Hq' : ∀ (i : ℕ), p' i =
       next_p p r' i (cmp i cur'))
  (Hcase_lt : (i < ↓ (i : ℕ), p i ∈ r') ∨ (↓ (i : ℕ), p i ∈ r') < i ∧ ¬i ≤ cur' →
               next_p p r' i (cmp i cur') = e →
               P i)
  (Hcase_eq : (i = ↓ (i : ℕ), p i ∈ r') →
               next_p p r' cur' (cmp cur' cur') = e →
               P cur')
  (Hcase_gt : (↓ (i : ℕ), p i ∈ r') < i →
               next_p p r' (i - 1) (cmp (i - 1) cur') = e →
               P (i - 1))
: (∃ j, p' j = e ∧ P j) :=
begin
  ordering_cases cmp i (↓ i, p i ∈ r'),
  { existsi i, rw Hq',
    suffices : cmp i cur' = ordering.lt,
    { rw [this,next_p,if_neg,h] at *,
      { existsi [rfl], apply_assumption,
        left, solve_by_elim, refl, },
      all_goals { apply not_le_of_gt h_1 }, },
    rw [cmp,cmp_using_eq_lt,Hcur'],
    apply lt_max_of_lt_left _ h_1, },
  { existsi cur', rw Hq',
    have : cmp cur' cur' = ordering.eq,
    { rw [cmp_eq_eq], },
    rw and_iff_imp, intro, solve_by_elim,
    rw [this,next_p], cc },
  by_cases h_cur : i ≤ cur',
  { existsi i - 1, rw Hq',
    have h_i_gt_0 : 0 < i,
    { apply lt_of_le_of_lt,
      apply nat.zero_le, assumption, },
    have : cmp (i - 1) cur' = ordering.lt,
    { rw [cmp,cmp_using_eq_lt],
      apply lt_of_lt_of_le _ h_cur,
      show i - 1 < i,
      { apply nat.sub_lt, assumption, norm_num }, },
    rw and_iff_imp, intro, solve_by_elim,
    rw [this,next_p,if_pos,nat.sub_add_cancel,h],
    assumption,
    rw ← add_le_to_le_sub,
    repeat { assumption }, },
  { existsi i, rw Hq',
    have : cmp i cur' = ordering.gt,
    { rw [cmp,cmp_using_eq_gt],
      apply lt_of_not_ge h_cur },
    rw and_iff_imp, intro, apply_assumption,
    right, tauto, solve_by_elim,
    rw [this,next_p,h] at *, }
end

include Hq Hinj

/- TODO: split into lemmas -/
lemma q_injective
: Γ ⊢ ◻(⟨ surjective ⟩ ! p) :=
begin [temporal]
  cases Hq with Hq Hq',
  t_induction!,
  { explicit' with Hq
    { cases_matching* _ ∧ _, subst p, solve_by_elim, } },
  { henceforth at Hq',
    explicit' with ih Hq'
    { simp_intros e, cases ih e with i h,
      cases Hq' with Hcur' Hq',
      ordering_cases cmp i (↓ i, p i ∈ r'),
      { existsi i, rw Hq',
        suffices : cmp i cur' = ordering.lt,
        { rw [this,next_p,if_neg,h],
          apply not_le_of_gt h_1, },
        rw [cmp,cmp_using_eq_lt,Hcur'],
        apply lt_max_of_lt_left _ h_1, },
      { existsi cur', rw Hq',
        have : cmp cur' cur' = ordering.eq,
        { rw [cmp_eq_eq], },
        rw [this,next_p], cc },
      by_cases h_cur : i ≤ cur',
      { existsi i - 1, rw Hq',
        have h_i_gt_0 : 0 < i,
        { apply lt_of_le_of_lt,
          apply nat.zero_le, assumption, },
        have : cmp (i - 1) cur' = ordering.lt,
        { rw [cmp,cmp_using_eq_lt],
          apply lt_of_lt_of_le _ h_cur,
          show i - 1 < i,
          { apply nat.sub_lt, assumption, norm_num }, },
        rw [this,next_p,if_pos,nat.sub_add_cancel,h],
        assumption,
        rw ← add_le_to_le_sub,
        repeat { assumption }, },
      { existsi i, rw Hq',
        have : cmp i cur' = ordering.gt,
        { rw [cmp,cmp_using_eq_gt],
          apply lt_of_not_ge h_cur },
        rw [this,next_p,h], } } },
end

end q_injective

section

-- include Hq
-- lemma select_eq_inv_q_cur'
-- : Γ ⊢ select_Spec select' :=
-- begin [temporal]
--   cases Hq with Hq₀ Hq,
--   split,
--   explicit' { cc },
--   henceforth! at ⊢ Hq,
--   explicit' [nxt_select]
--   { cases Hq with Hcur Hq,
--     rw [inv_eq _ _ _],
--     rw [Hq,← Hcur],
--     ordering_cases cmp (↓ (i : ℕ), inv q i ∈ r') (q (inv q (↓ (i : ℕ), inv q i ∈ r')))
--     ; simp [next_p],
--     ite_cases,
--     { exfalso, apply h_1, clear h_1,
--       rw Hcur, rw le_max_iff_le_or_le, left,
--        } }
--   { verbose := tt }
-- end

-- include Hs Hinj

-- lemma select_eq_inv_q_cur
-- : Γ ⊢ ◻[| q cur select, select = inv q cur |] :=
-- begin [temporal]
--   have Hinj_q := temporal.scheduling.q_injective,
--   have Hinj_q' := henceforth_next _ _ Hinj_q,
--   cases Hq with Hq₀ Hq,
--   cases Hs with Hs₀ Hs,
--   t_induction! using Hq Hs Hinj_q' Hinj_q,
--   explicit' { cc },
--   explicit' [nxt_select]
--   { cases Hq,
--     rw inv_eq _ _ Hinj_q',
--     rw [Hq_right],
--     ordering_cases (cmp (↓ (i : ℕ), inv q i ∈ r') (q select'))
--     ; simp [next_p],
--     ite_cases,
--     { exfalso, apply h_1, clear h_1,
--       rw le_max_iff_le_or_le, left,
--       apply le_of_eq, clear_except Hs, },
--     {  },
--     {  },
--     {  } }
-- end
-- end

open set

-- invariant
--           inv q' cur' = (↓ i, inv q' i ∈ r)
--           inv q' cur' ≤ (↓ i, inv q' i ∈ r)
--           inv q' cur' ≥ (↓ i, inv q' i ∈ r)

section
include Hr Hq Hinj
lemma valid_indices_ne_empty
: Γ ⊢ ◻([| p, λ r : set evt, { i : ℕ | p i ∈ r } ≠ ∅ |] (⊙r)) :=
begin [temporal]
  have Hsur := temporal.scheduling.q_injective,
  replace Hr := henceforth_next _ _ Hr,
  henceforth! at Hr Hsur ⊢,
  explicit' with Hr Hsur
  { rw not_eq_empty_iff_exists at *,
    cases Hr with i Hr,
    existsi inv p i,
    change _ ∈ r',
    rw [inv_is_right_inverse_of_surjective Hsur],
    assumption, }
end
end

noncomputable def rank (e : evt) : tvar ℕ :=
[| p, ↓ i, p i = e |]

include Hr Hq Hinj
lemma sched_inv
: Γ ⊢ ◻(select ∊ r) :=
begin [temporal]
  have Hq_inj := temporal.scheduling.q_injective,
  have hJ := temporal.scheduling.valid_indices_ne_empty,
  cases Hq with Hq₀ Hq,
  have Hq_inj' := henceforth_next _ _ Hq_inj,
  t_induction!,
  henceforth! at Hr Hq_inj,
  { explicit' [select,cur₀] with Hq₀ Hr Hq_inj
    { change cur ∈ { i | p i ∈ r },
      rw [Hq₀.left,Hq₀.right],
      apply minimum_mem,
      intro, apply Hr,
      rw eq_empty_iff_forall_not_mem at *,
      intro x, specialize a (inv p x),
      -- apply Hr,
      intro, apply a,
      show f (inv p x) ∈ r,
      cases Hq₀, subst p,
      rw [inv_is_right_inverse_of_surjective Hq_inj],
      assumption } },
  henceforth! at Hr Hq_inj' Hq_inj Hq hJ,
  explicit' with Hq hJ
  { cases Hq with Hq Hq',
    rw Hq',
    have : cmp cur' cur' = ordering.eq,
    { rw cmp_eq_eq },
    rw [this,next_p],
    change (↓ (i : ℕ), p i ∈ r') ∈ { i | p i ∈ r' },
    apply minimum_mem,
    assumption },
end

lemma cur_lt_cur'
: Γ ⊢ ◻(cur ≺ ⊙cur) :=
begin [temporal]
  cases Hq with Hq₀ Hq,
  henceforth! at Hq ⊢,
  explicit' with Hq
  { simp [Hq],
    apply lt_max_of_lt_right,
    apply lt_add_one, }
end

section sched_queue_safety
variables
  (q₀ : ℕ)
  (e : evt)
  (Hprev : Γ ⊢ rank e |+| (rank e |-| cur) ≃ ↑q₀)
  (H₂ : Γ ⊢ ⊙(-(⟨λ (i : ℕ), (i ⊨ rank e) + ((i ⊨ rank e) - (i ⊨ cur))⟩ ≺≺ q₀) ⋀
                   -(select ≃ e)))
  (Hdec : Γ ⊢ cur ≺ ⊙cur)
  (Hsurj : Γ ⊢ ⊙( ⟨ surjective ⟩ ! p ))
  (this : Γ ⊢ ⊙rank e ≼ rank e ⋁ ⊙(cur ≃ rank e))

omit Hq
include Hdec Hprev Hsurj H₂ this
lemma non_dec_po
: Γ ⊢ ⊙(rank e |+| (rank e |-| cur) ≃ ↑q₀) :=
begin [temporal]
  explicit' [next,next',select,rank]
    with Hprev this H₂ Hdec Hsurj
  { subst q₀,
    cases this with this this,
    cases lt_or_eq_of_le this,
    { exfalso, apply H₂.left,
      change _ + _ < _ + _,
      apply lt_of_lt_of_le,
      { apply add_lt_add_right h, },
      apply add_le_add_left,
      transitivity,
      { apply nat.sub_le_sub_left,
      apply le_of_lt Hdec, },
      { apply nat.sub_le_sub_right this, } },
    { simp [h],
      let rank := (↓ (i : ℕ), p i = e),
      have : rank - cur' ≤ rank - cur,
      { apply nat.sub_le_sub_left, apply le_of_lt Hdec },
      cases lt_or_eq_of_le this,
      { exfalso, apply H₂.left,
        change _ + _ < _ + _, simp [h,h_1], },
      assumption },
    replace H₂ := H₂.right, rw this at H₂,
    have H₀ : { i : ℕ | p' i = e } ≠ ∅,
    { apply ne_empty_of_mem _,
      exact (inv p' e),
      change p' (inv p' e) = e,
      apply inv_is_right_inverse_of_surjective Hsurj, },
    have H₃ := minimum_mem H₀,
    cases H₂ H₃, },
end

end sched_queue_safety

lemma subsumes_requested (e : evt)
: Γ ⊢ ◻( select ≃ ↑e ⋀ ↑e ∊ r
             ≡ select ≃ ↑e ) :=
begin [temporal]
  have Hr' := temporal.scheduling.sched_inv,
  henceforth! at ⊢ Hr',
  explicit' [select] with Hr'
  { split,
    { simp, intros, assumption },
    { intros, cc, } },
end

-- include Hinj
/-- TODO: Pull out lemmas -/
lemma sched_queue_safety (q₀ : ℕ) (e : evt)
: Γ ⊢ ◻(rank e |+| (rank e |-| cur) ≃ ↑q₀ ⟶
    ◻(rank e |+| (rank e |-| cur) ≃ ↑q₀) ⋁
    ◇(rank e |+| (rank e |-| cur) ≺≺ ↑q₀ ⋁ select ≃ ↑e)) :=
begin [temporal]
  have hJ := temporal.scheduling.q_injective,
  have Hinc := temporal.scheduling.cur_lt_cur',
  have p_not_empty := temporal.scheduling.valid_indices_ne_empty,
  have p'_not_empty := henceforth_next _ _ p_not_empty,
  cases Hq with Hq Hq',
  henceforth!, intro H,
  rw [p_or_comm,← p_not_p_imp],
  intros H₁, simp [p_not_p_or,p_not_p_and] at H₁,
  t_induction,
  { assumption },
  { henceforth!, intro Hprev,
    have H₂ := henceforth_next _ _ H₁,
    have hJ' := henceforth_next _ _ hJ,
    henceforth at Hinc Hq' H₁ H₂ hJ hJ' p_not_empty p'_not_empty,
    apply temporal.scheduling.non_dec_po _ _ Hprev H₂ Hinc hJ',
    explicit' [next,next',select,rank] with Hq' hJ hJ' H₂
    { cases Hq' with Hcur Hq,
      replace Hq := congr_fun Hq, simp only at Hq,
      rw [or_comm,or_iff_not_imp], intro Hncur,
      have p_not_empty : { i : ℕ | p i = e } ≠ ∅,
      { rw ne_empty_iff_exists_mem, apply hJ e, },
      have p'_not_empty : { i : ℕ | p' i = e } ≠ ∅,
      { rw ne_empty_iff_exists_mem, apply hJ' e, },
      apply (le_minimum_iff_forall_le p_not_empty (↓ (i : ℕ), p' i = e)).2,
      assume j (Hj : p j = e),
      apply (minimum_le_iff_exists_le p'_not_empty j).2,
      rw ← Hcur at Hq,
      apply next_rec _ cur cur' p p' r' Hj Hcur Hq,
      { intros, refl },
      { intros h h',
        rw ← Hq at h', cases H₂.right h', },
      { intros, apply nat.sub_le, } }, },
end

/- TODO: split into lemmas -/
lemma sched_queue_liveness (q₀ : ℕ) (e : evt)
: Γ ⊢ ⊙(↑e ∊ r) ⋀ rank e |+| (rank e |-| cur) ≃ ↑q₀ ~>
  rank e |+| (rank e |-| cur) ≺≺ ↑q₀ ⋁ select ≃ ↑e ⋀ ↑e ∊ r :=
begin [temporal]
  { have Hq_inj := temporal.scheduling.q_injective,
    have Hinc := temporal.scheduling.cur_lt_cur',
    cases Hq with Hq₀ Hq,
    henceforth! at ⊢ Hq Hq_inj Hinc,
    have Hq_inj' : ⊙(⟨surjective⟩ ! p) := holds_next _ _ Hq_inj,
    simp, intros hreq hq₀,
    apply next_entails_eventually,
    explicit' [select,next,next',rank]
      with Hq hreq hq₀ Hinc  Hq_inj
    { cases Hq with Hq Hq' Hq_inj,
      replace Hq' := congr_fun Hq', simp at Hq',
      rw ← Hq at Hq',
      let rank := ↓ i, p i = e,
      have Hrank : p rank = e := _,
      let P := λ k, k + (k - cur') < q₀ ∨ k = cur',
      have rec := temporal.scheduling.next_rec P cur cur' p p' r' Hrank Hq Hq' _ _ _,
      { cases rec with k Hk, cases Hk with Hpk Hk,
        cases Hk with Hk Hk,
        { left, change _ + _ < _,
          apply @lt_of_le_of_lt _ _ _ (k + (k - cur')),
          have h : (↓ (i : ℕ), p' i = e) ≤ k, apply minimum_le, exact Hpk,
          apply add_le_add, assumption,
          apply nat.sub_le_sub_right,
          assumption, assumption, },
        { right, cc }, },
      { simp [P,rank], intros h₀ h₁,
        rw ← Hq' (↓ (i : ℕ), p i = e) at h₁,
        clear P,
        cases h₀,
        { right, clear hq₀ Hq',
          have : cur + 1 ≤ (↓ (i : ℕ), p i ∈ r'), admit,
          rw max_eq_left this at Hq, clear this,
          admit },
        { left, rw ← hq₀,
          have : ((↓ (i : ℕ), p i = e) ≥ cur'),
          { apply le_of_lt h₀.right },
          monotonicity Hinc }, },
      { intros, rw ← Hq' at a_1,
        right, refl, },
      { intros, rw ← Hq' at a_1,
        left, rw ← hq₀,
        apply lt_of_lt_of_le,
        apply add_lt_add_right,
        apply nat.sub_lt, apply lt_of_le_of_lt (nat.zero_le _) a,
        norm_num, apply nat.sub_le_sub,
        apply nat.sub_le, apply le_of_lt Hinc, },
      { have h : { i | p i = e } ≠ ∅,
        { rw ne_empty_iff_exists_mem, apply Hq_inj, },
        apply minimum_mem h, } } },
end

lemma sched_fairness (e : evt)
: Γ ⊢ ◻◇(↑e ∊ r) ⟶ ◻◇(select ≃ ↑e ⋀ ↑e ∊ r) :=
begin [temporal]
  suffices : ◻◇⊙(↑e ∊ r) ⟶ ◻◇(temporal.scheduling.select ≃ ↑e ⋀ ↑e ∊ r),
  { intro h, apply this,
    rw [← next_eventually_comm], apply henceforth_next _ _ h, },
  apply inf_often_induction' (temporal.scheduling.rank e |+| (temporal.scheduling.rank e |-| cur)) ; intro q₀,
  { rw temporal.scheduling.subsumes_requested e,
    apply temporal.scheduling.sched_queue_safety q₀ e, },
  { apply temporal.scheduling.sched_queue_liveness }
end

def correct_sched
: Γ ⊢ SCHED select :=
begin [temporal]
  split,
  { apply temporal.scheduling.sched_inv, },
  { intro, apply temporal.scheduling.sched_fairness },
end
end
end implementation

-- class schedulable (α : Sort u) :=
--   (f : α → ℕ)
--   (inj : injective f)
open encodable

example (w σ₀ : tvar ℕ)
: ⇑(to_fun_var (λ (w : tvar ℕ), w ≃ σ₀)) w = w ≃ σ₀ :=
begin
  -- rw [v_eq,to_fun_var_lift₂],
  -- dsimp,
  -- dsimp,
  -- unfold_coes,
  -- dsimp with lifted_fn,
  -- unfold_coes,
  simp! only with lifted_fn predicate,
end

lemma scheduler [encodable evt]
  (Hr : Γ ⊢ ◻-(r ≃ (∅ : set evt)))
: Γ ⊢ (∃∃ s, SCHED s) :=
begin [temporal]
  let f' : (evt → ℕ) := @encode evt _,
  let f : tvar (evt → ℕ) := f',
  have Hnemp : ∃∃ x : evt, True,
  { admit },
  nonempty evt,
  let g' : (ℕ → evt) := inv (@encode evt _),
  let g  : tvar (ℕ → evt) := g',
  let σ₀ := ⦃cur₀ r g',g⦄,
  select_witness w : w ≃ σ₀ ⋀ ◻(⊙w ≃ temporal.scheduling.next w),
  have := fwd_witness σ₀ (next r) Γ,
  cases this with cur Hcur,
  cases cur with cur q,
  existsi select p cur,
  note Hsur : surjective (inv f'),
  { apply surjective_of_has_right_inverse,
    existsi f',
    apply inv_is_left_inverse_of_injective,
    apply schedulable.inj },
  type_check @temporal.scheduling.correct_sched,
  apply temporal.scheduling.correct_sched (inv f') Hsur _,
  simp [Spec,σ₀] at ⊢ Hcur,
  exact Hcur,
end

end scheduling

section spec

variables Γ : cpred
variables {α : Type v} (m : mch α)
local notation `evt` := m.evt
variable [encodable evt]
local notation `cs` := m.cs
local notation `fs` := m.fs
local notation `p` := m.init
local notation `A` := m.A

lemma sch_intro (v : tvar α)
: Γ ⊢ m.spec v ⟶ (∃∃ sch, m.spec_sch v sch) :=
begin [temporal]
  intro h,
  let r : tvar (set (option evt)) := ⟪ ℕ, λ s s', { e | m.effect e s s' } ⟫ v ⊙v,
  have hr : ◻-(r ≃ (∅ : set (option evt))),
  { simp [mch.spec] at h,
    casesm* _ ⋀ _,
    select Hact : ◻(p_exists _),
    henceforth! at Hact ⊢,
    explicit' [r] with Hact
    { erw [← not_eq_empty_iff_exists] at Hact, exact Hact }, },
  have h' := temporal.scheduling.scheduler Γ r hr,
  cases h' with sch h',
  existsi sch,
  simp  at ⊢ h,
  casesm* _ ⋀ _,
  split!* ; try { solve_by_elim },
  { select h' : ◻(p_exists _),
    select hJ : ◻(_ ∊ _),
    henceforth! at hJ h' ⊢,
    existsi sch with hh,
    { explicit' [r] with hh hJ h'
      { subst sch, tauto } } },
  { introv, intros h₀ h₁,
    rename a_3 h₂,
    replace h₂ := h₂ x h₀ h₁,
    replace a_1 := a_1 x,
    persistent,
    have H₀ : ↑x ∊ r ≡ cs x ! v ⋀ fs x ! v ⋀ ⟦ v | A x ⟧,
    { explicit' [r]
      { simp [mch.effect,and_assoc] }, },
    have H₁ : sch ≃ ↑x ⋀ ↑x ∊ r ≡ cs x ! v ⋀ fs x ! v ⋀ (sch ≃ ↑x ⋀ ⟦ v | A x ⟧),
    { explicit' [r,mch.effect,and_assoc]
      { apply eq.to_iff, ac_refl }, },
    rw [H₁,H₀] at a_1,
    solve_by_elim, }
end

end spec
end scheduling
export scheduling (schedulable sch_intro)
end temporal