/-
Copyright (c) 2022 Hanting Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Hanting Zhang
-/
import Mathlib.Tactic.Core
import Mathlib.Lean.Expr.Basic
import Mathlib.Data.Fintype.Basic

/-!
# The `fin_cases` tactic.

Given a hypothesis of the form `h : x ∈ (A : List α)`, `x ∈ (A : Finset α)`,
or `x ∈ (A : Multiset α)`,
or a hypothesis of the form `h : A`, where `[Fintype A]` is available,
`fin_cases h` will repeatedly call `cases` to split the goal into
separate cases for each possible value.
-/

open Lean.Meta

namespace Lean.Elab.Tactic

/-- If `e` is of the form `x ∈ (A : List α)`, `x ∈ (A : Finset α)`, or `x ∈ (A : Multiset α)`,
return `some α`, otherwise `none`. -/
def getMemType {m : Type → Type} [Monad m] [MonadError m] (e : Expr) : m (Option Expr) := do
  match e.getAppFnArgs with
  | (``Membership.mem, #[_, type, _, _, _]) =>
    match type.getAppFnArgs with
    | (``List, #[α])     => return α
    | (``Multiset, #[α]) => return α
    | (``Finset, #[α])   => return α
    | _ => throwError ("Hypothesis must be of type `x ∈ (A : List α)`, `x ∈ (A : Finset α)`,"
        ++ " or `x ∈ (A : Multiset α)`")
  | _ => return none

/--
Recursively runs the `cases` tactic on a hypothesis `h`.
As long as two goals are produced, `cases` is called recursively on the second goal,
and we return a list of the first goals which appeared.

This is useful for hypotheses of the form `h : a ∈ [l₁, l₂, ...]`,
which will be transformed into a sequence of goals with hypotheses `h : a = l₁`, `h : a = l₂`,
and so on.
-/
partial def unfoldCases (g : MVarId) (h : FVarId) : MetaM (List MVarId) := do
  let gs ← g.cases h
  try
    let #[g₁, g₂] := gs | throwError "unexpected number of cases"
    let gs ← unfoldCases g₂.mvarId g₂.fields[2]!.fvarId!
    return g₁.mvarId :: gs
  catch _ => return []

/-- Implementation of the `fin_cases` tactic. -/
partial def finCasesAt (g : MVarId) (hyp : FVarId) : MetaM (List MVarId) := g.withContext do
  let lDecl ←
    match (← getLCtx).find? hyp with
    | none => throwError m!"hypothesis not found"
    | some lDecl => pure lDecl
  match ← getMemType lDecl.type with
  | some _ => unfoldCases g hyp
  | none =>
    -- Deal with `x : A`, where `[Fintype A]` is available:
    let inst ← synthInstance (← mkAppM ``Fintype #[lDecl.type])
    let elems ← mkAppOptM ``Fintype.elems #[lDecl.type, inst]
    let t ← mkAppM ``Membership.mem #[lDecl.toExpr, elems]
    let v ← mkAppOptM ``Fintype.complete #[lDecl.type, inst, lDecl.toExpr]
    let (fvar, g) ← (← g.assert `this t v).intro1P
    finCasesAt g fvar

/--
`fin_cases h` performs case analysis on a hypothesis of the form
`h : A`, where `[Fintype A]` is available, or
`h : a ∈ A`, where `A : Finset X`, `A : Multiset X` or `A : List X`.

As an example, in
```
example (f : ℕ → Prop) (p : Fin 3) (h0 : f 0) (h1 : f 1) (h2 : f 2) : f p.val := by
  fin_cases *; simp
  all_goals assumption
```
after `fin_cases p; simp`, there are three goals, `f 0`, `f 1`, and `f 2`.
-/
syntax (name := finCases) "fin_cases " ("*" <|> term,+) (" with " term,+)? : tactic

/-!
`fin_cases` used to also have two modifiers, `fin_cases ... with ...` and `fin_cases ... using ...`.
With neither actually used in mathlib, they haven't been re-implemented here.

In case someone finds a need for them, and wants to re-implement, the relevant sections of
the doc-string are preserved here:

---

`fin_cases h with l` takes a list of descriptions for the cases of `h`.
These should be definitionally equal to and in the same order as the
default enumeration of the cases.

For example,
```
example (x y : ℕ) (h : x ∈ [1, 2]) : x = y := by
  fin_cases h with 1, 1+1
```
produces two cases: `1 = y` and `1 + 1 = y`.

When using `fin_cases a` on data `a` defined with `let`,
the tactic will not be able to clear the variable `a`,
and will instead produce hypotheses `this : a = ...`.
These hypotheses can be given a name using `fin_cases a using ha`.

For example,
```
example (f : ℕ → fin 3) : true := by
  let a := f 3
  fin_cases a using ha
```
produces three goals with hypotheses
`ha : a = 0`, `ha : a = 1`, and `ha : a = 2`.
-/

/- TODO: In mathlib3 we ran `norm_num` when there is no `with` clause. Is this still useful? -/
/- TODO: can we name the cases generated according to their values,
   rather than `tail.tail.tail.head`? -/

@[tactic finCases] elab_rules : tactic
  | `(tactic| fin_cases $[$hyps:ident],*) => withMainContext <| focus do
    for h in hyps do
      allGoals <| liftMetaTactic (finCasesAt · (← getFVarId h))


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.const
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u u_1

namespace Mathlib

namespace category_theory

namespace functor

/-- The constant functor sending everything to `punit.star`. -/
def star (C : Type u) [category C] : C ⥤ discrete PUnit := obj (const C) PUnit.unit

/-- Any two functors to `discrete punit` are isomorphic. -/
def punit_ext {C : Type u} [category C] (F : C ⥤ discrete PUnit) (G : C ⥤ discrete PUnit) : F ≅ G :=
  nat_iso.of_components (fun (_x : C) => eq_to_iso sorry) sorry

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
theorem punit_ext' {C : Type u} [category C] (F : C ⥤ discrete PUnit) (G : C ⥤ discrete PUnit) :
    F = G :=
  ext (fun (_x : C) => of_as_true trivial)
    fun (_x _x_1 : C) (_x_2 : _x ⟶ _x_1) => of_as_true trivial

/-- The functor from `discrete punit` sending everything to the given object. -/
def from_punit {C : Type u} [category C] (X : C) : discrete PUnit ⥤ C :=
  obj (const (discrete PUnit)) X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simp] theorem equiv_functor_obj {C : Type u} [category C] (F : discrete PUnit ⥤ C) :
    obj (equivalence.functor equiv) F = obj F PUnit.unit :=
  Eq.refl (obj (equivalence.functor equiv) F)

end Mathlib


universes u v

namespace Experiment1
inductive ArrayLitMatch (α : Type u)
| sz0 {}             : ArrayLitMatch
| sz1 (a₁ : α)       : ArrayLitMatch
| sz2 (a₁ a₂ : α)    : ArrayLitMatch
| sz3 (a₁ a₂ a₃ : α) : ArrayLitMatch
| other {}           : ArrayLitMatch

def matchArrayLit {α : Type u} (a : Array α) : ArrayLitMatch α :=
if a.size = 0 then
  ArrayLitMatch.sz0
else if h : a.size = 1 then
  ArrayLitMatch.sz1 (a.getLit 0 h (ofDecideEqTrue rfl))
else if h : a.size = 2 then
  ArrayLitMatch.sz2 (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl))
else if h : a.size = 3 then
  ArrayLitMatch.sz3 (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl))
else
  ArrayLitMatch.other

def matchArrayLit.eq0 {α : Type u} : matchArrayLit (#[] : Array α) = ArrayLitMatch.sz0 :=
rfl

def matchArrayLit.eq1 {α : Type u} (a₁ : α) : matchArrayLit #[a₁] = ArrayLitMatch.sz1 a₁ :=
rfl

def matchArrayLit.eq2 {α : Type u} (a₁ a₂ : α) : matchArrayLit #[a₁, a₂] = ArrayLitMatch.sz2 a₁ a₂ :=
rfl

def matchArrayLit.eq3 {α : Type u} (a₁ a₂ a₃ : α) : matchArrayLit #[a₁, a₂, a₃] = ArrayLitMatch.sz3 a₁ a₂ a₃ :=
rfl

def matchArrayLit.eq4 {α : Type u} (a₁ a₂ a₃ a₄ : α) : matchArrayLit #[a₁, a₂, a₃, a₄] = ArrayLitMatch.other :=
rfl
end Experiment1

def toListLitAux {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : ∀ (i : Nat), i ≤ a.size → List α → List α
| 0,     hi, acc => acc
| (i+1), hi, acc => toListLitAux i (Nat.leOfSuccLe hi) (a.getLit i hsz (Nat.ltOfLtOfEq (Nat.ltOfLtOfLe (Nat.ltSuccSelf i) hi) hsz) :: acc)

def toArrayLit {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : Array α :=
List.toArray $ toListLitAux a n hsz n (hsz ▸ Nat.leRefl _) []

theorem toArrayLitEq {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : a = toArrayLit a n hsz :=
-- TODO: this is painful to prove without proper automation
sorry
/-
First, we need to prove
∀ i j acc, i ≤ a.size → (toListLitAux a n hsz (i+1) hi acc).index j = if j < i then a.getLit j hsz _ else acc.index (j - i)
by induction

Base case is trivial
(j : Nat) (acc : List α) (hi : 0 ≤ a.size)
     |- (toListLitAux a n hsz 0 hi acc).index j = if j < 0 then a.getLit j hsz _ else acc.index (j - 0)
...  |- acc.index j = acc.index j

Induction

(j : Nat) (acc : List α) (hi : i+1 ≤ a.size)
      |- (toListLitAux a n hsz (i+1) hi acc).index j = if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1))
  ... |- (toListLitAux a n hsz i hi' (a.getLit i hsz _ :: acc)).index j = if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1))  * by def
  ... |- if j < i     then a.getLit j hsz _ else (a.getLit i hsz _ :: acc).index (j-i)    * by induction hypothesis
         =
         if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1))
If j < i, then both are a.getLit j hsz _
If j = i, then lhs reduces else-branch to (a.getLit i hsz _) and rhs is then-brachn (a.getLit i hsz _)
If j >= i + 1, we use
   - j - i >= 1 > 0
   - (a::as).index k = as.index (k-1) If k > 0
   - j - (i + 1) = (j - i) - 1
   Then lhs = (a.getLit i hsz _ :: acc).index (j-i) = acc.index (j-i-1) = acc.index (j-(i+1)) = rhs

With this proof, we have

∀ j, j < n → (toListLitAux a n hsz n _ []).index j = a.getLit j hsz _

We also need

- (toListLitAux a n hsz n _ []).length = n
- j < n -> (List.toArray as).getLit j _ _ = as.index j

Then using Array.extLit, we have that a = List.toArray $ toListLitAux a n hsz n _ []
-/

theorem Array.eqLitOfSize0 {α : Type u} (a : Array α) (hsz : a.size = 0) : a = #[] :=
toArrayLitEq a 0 hsz
/-
Array.ext a #[] h (fun i h₁ h₂ => absurd h₂ (Nat.notLtZero _))
-/

theorem Array.eqLitOfSize1 {α : Type u} (a : Array α) (hsz : a.size = 1) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl)] :=
toArrayLitEq a 1 hsz
/-
Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i =>
  match i with
  | 0     => fun hi => rfl
  | (n+1) => fun hi =>
    have n < 0 from hi;
    absurd this (Nat.notLtZero _)
-/

theorem Array.eqLitOfSize2 {α : Type u} (a : Array α) (hsz : a.size = 2) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] :=
toArrayLitEq a 2 hsz
/-
Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i =>
  match i with
  | 0     => fun hi => rfl
  | 1     => fun hi => rfl
  | (n+2) => fun hi =>
    have n < 0 from hi;
    absurd this (Nat.notLtZero _)
-/

theorem Array.eqLitOfSize3 {α : Type u} (a : Array α) (hsz : a.size = 3) :
  a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] :=
toArrayLitEq a 3 hsz
/-
Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i =>
  match i with
  | 0     => fun hi => rfl
  | 1     => fun hi => rfl
  | 2     => fun hi => rfl
  | (n+3) => fun hi =>
    have n < 0 from hi;
    absurd this (Nat.notLtZero _)
-/

/-
Matcher for the following patterns
```
| #[]           => _
| #[a₁]         => _
| #[a₁, a₂, a₃] => _
| a             => _
``` -/
def matchArrayLit {α : Type u} (C : Array α → Sort v) (a : Array α)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : C a :=
if h : a.size = 0 then
  @Eq.rec _ _ (fun x _ => C x) (h₁ ()) _ (toArrayLitEq a 0 h).symm
else if h : a.size = 1 then
  @Eq.rec _ _ (fun x _ => C x) (h₂ (a.getLit 0 h (ofDecideEqTrue rfl))) _ (toArrayLitEq a 1 h).symm
else if h : a.size = 3 then
  @Eq.rec _ _ (fun x _ => C x) (h₃ (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl))) _ (toArrayLitEq a 3 h).symm
else
  h₄ a

/- Equational lemmas that should be generated automatically. -/
theorem matchArrayLit.eq1 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    : matchArrayLit C #[] h₁ h₂ h₃ h₄ = h₁ () :=
rfl

theorem matchArrayLit.eq2 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ : α)
    : matchArrayLit C #[a₁] h₁ h₂ h₃ h₄ = h₂ a₁ :=
rfl

theorem matchArrayLit.eq3 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a₁ a₂ a₃ : α)
    : matchArrayLit C #[a₁, a₂, a₃] h₁ h₂ h₃ h₄ = h₃ a₁ a₂ a₃ :=
rfl

theorem matchArrayLit.eq4 {α : Type u} (C : Array α → Sort v)
    (h₁ : Unit →      C #[])
    (h₂ : ∀ a₁,       C #[a₁])
    (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃])
    (h₄ : ∀ a,        C a)
    (a : Array α)
    (n₁ : a.size ≠ 0) (n₂ : a.size ≠ 1) (n₃ : a.size ≠ 3)
    : matchArrayLit C a h₁ h₂ h₃ h₄ = h₄ a :=
match a, n₁, n₂, n₃ with
| ⟨0, _⟩,   n₁, _, _  => absurd rfl n₁
| ⟨1, _⟩,   _,  n₂, _ => absurd rfl n₂
| ⟨2, _⟩,   _, _, _   => rfl
| ⟨3, _⟩,   _, _, n₃  => absurd rfl n₃
| ⟨n+4, _⟩, _, _, _   => rfl


theorem ex {c d : Char} : c = d → c.val = d.val
  | rfl => rfl


import to_mathlib.data.set.prod
import to_mathlib.data.nat.basic
import to_mathlib.geometry.manifold.metrizable
import to_mathlib.topology.constructions
import global.parametricity_for_free
import global.inductive_htpy_construction
import global.localized_construction
import global.localisation_data
/-!
# Gromov's theorem

We prove the h-principle for open and ample first order differential relations.
-/

noncomputable theory

open set filter model_with_corners metric
open_locale topology manifold

variables
{EM : Type*} [normed_add_comm_group EM] [normed_space ℝ EM] [finite_dimensional ℝ EM]
{HM : Type*} [topological_space HM] {IM : model_with_corners ℝ EM HM} [boundaryless IM]
{M : Type*} [topological_space M] [charted_space HM M] [smooth_manifold_with_corners IM M]
[t2_space M] [sigma_compact_space M]

{EX : Type*} [normed_add_comm_group EX] [normed_space ℝ EX] [finite_dimensional ℝ EX]
{HX : Type*} [topological_space HX] {IX : model_with_corners ℝ EX HX} [model_with_corners.boundaryless IX]
-- note: X is a metric space
{X : Type*} [metric_space X] [charted_space HX X] [smooth_manifold_with_corners IX X]
[sigma_compact_space X]

{R : rel_mfld IM M IX X}
{A : set M} {δ : M → ℝ}

set_option trace.filter_inst_type true
local notation `J¹` := one_jet_bundle IM M IX X

lemma rel_mfld.ample.satisfies_h_principle (hRample : R.ample) (hRopen : is_open R)
  (hA : is_closed A)
  (hδ_pos : ∀ x, 0 < δ x) (hδ_cont : continuous δ) :
  R.satisfies_h_principle A δ :=
begin
  borelize EX,
  haveI := locally_compact_manifold IM M,
  haveI := locally_compact_manifold IX X,
  refine rel_mfld.satisfies_h_principle_of_weak hA _,
  unfreezingI { clear_dependent A },
  intros A hA 𝓕₀ h𝓕₀,

  casesI is_empty_or_nonempty M with hM hM,
  { refine  ⟨empty_htpy_formal_sol R, _, _, _, _⟩,
    all_goals { try { apply eventually_of_forall _ } },
    all_goals { try { intro } },
    all_goals { try { intro } },
    all_goals { apply empty_htpy_formal_sol_eq <|> apply (is_empty.false ‹M›).elim } },
  casesI is_empty_or_nonempty X with hX hX,
  { exfalso,
    inhabit M,
    exact (is_empty.false $ 𝓕₀.bs default).elim },
  /- We now start the main proof under the assumption that `M` and `X` are nonempty. -/
  have cont : continuous 𝓕₀.bs, from 𝓕₀.smooth_bs.continuous,
  let L : localisation_data IM IX 𝓕₀.bs := std_localisation_data EM IM EX IX cont,
  let K : index_type L.N → set M := λ i, (L.φ i) '' (closed_ball (0:EM) 1),
  let U : index_type L.N → set M := λ i, range (L.φ i),
  have K_cover : (⋃ i, K i) = univ,
    from eq_univ_of_subset (Union_mono (λ i, image_subset _ ball_subset_closed_ball)) L.h₁,
  let τ := λ x : M, min (δ x) (L.ε x),
  have τ_pos : ∀ x, 0 < τ x, from λ x, lt_min (hδ_pos x) (L.ε_pos x),
  have τ_cont : continuous τ, from hδ_cont.min L.ε_cont,
  have := (λ (x : M) (F' : germ (𝓝 x) J¹), F'.value = 𝓕₀ x),
  let P₀ : Π x : M, germ (𝓝 x) J¹ → Prop := λ x F,
    F.value.1.1 = x ∧
    F.value ∈ R ∧
    F.cont_mdiff_at' IM ((IM.prod IX).prod 𝓘(ℝ, EM →L[ℝ] EX)) ∞ ∧
    restrict_germ_predicate (λ x F', F'.value = 𝓕₀ x) A x F ∧
    dist (F.value.1.2) (𝓕₀.bs x) < τ x,

  let P₁ : Π x : M, germ (𝓝 x) J¹ → Prop := λ x F, is_holonomic_germ F,
  let P₂ : Π p : ℝ × M, germ (𝓝 p) J¹ → Prop := λ p F,
    F.cont_mdiff_at' (𝓘(ℝ).prod IM) ((IM.prod IX).prod 𝓘(ℝ, EM →L[ℝ] EX)) ∞,
  have hP₂ : ∀ (a b : ℝ) (p : ℝ × M) (f : ℝ × M → one_jet_bundle IM M IX X),
    P₂ (a*p.1+b, p.2) f → P₂ p (λ p : ℝ × M, f (a*p.1+b, p.2)),
  { rintros a b ⟨t, x⟩ f h,
    change cont_mdiff_at _ _ _ (f ∘ λ (p : ℝ × M), (a * p.1 + b, p.2)) (t, x),
    change cont_mdiff_at _ _ _ f ((λ (p : ℝ × M), (a * p.1 + b, p.2)) (t, x)) at h,
    have : cont_mdiff_at (𝓘(ℝ, ℝ).prod IM) (𝓘(ℝ, ℝ).prod IM) ∞ (λ (p : ℝ × M), (a * p.1 + b, p.2)) (t, x),
    { have h₁ : cont_mdiff_at 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ (λ t, a * t + b) t,
      from cont_mdiff_at_iff_cont_diff_at.mpr
        (((cont_diff_at_id : cont_diff_at ℝ ∞ id t).const_smul a).add cont_diff_at_const),
      exact h₁.prod_map cont_mdiff_at_id },
    exact h.comp (t, x) this },
  have init : ∀ x : M, P₀ x (𝓕₀ : M → J¹),
  { refine λ x, ⟨rfl, 𝓕₀.is_sol x, 𝓕₀.smooth x, _, _⟩,
    { revert x,
      exact forall_restrict_germ_predicate_of_forall (λ x, rfl) },
    { erw dist_self,
      exact τ_pos x } },
  have ind : ∀ (i : index_type L.N) (f : M → J¹), (∀ x, P₀ x f) → (∀ᶠ x near ⋃ j < i, K j, P₁ x f) →
    ∃ F : ℝ → M → J¹, (∀ t, ∀ x, P₀ x $ F t) ∧ (∀ᶠ x near ⋃ j ≤ i, K j, P₁ x $ F 1) ∧
                     (∀ p, P₂ p ↿F) ∧ (∀ t, ∀ x ∉ U i, F t x = f x) ∧
                     (∀ᶠ t near Iic 0, F t = f) ∧ (∀ᶠ t near Ici 1, F t = F 1),
  { intros i f hf₀ hf₁,
    let K₀ : set EM := closed_ball 0 1,
    have hK₀ : is_compact K₀, from is_compact_closed_ball 0 1,
    let K₁ : set EM := closed_ball 0 2,
    have hK₁ : is_compact K₁, from is_compact_closed_ball 0 2,
    have hK₀K₁ : K₀ ⊆ interior K₁,
    { dsimp [K₀, K₁],
      rw interior_closed_ball (0 : EM) (by norm_num : (2 : ℝ) ≠ 0),
      exact closed_ball_subset_ball (by norm_num) },
    let C := ⋃ j < i, (L.φ j) '' closed_ball 0 1,
    have hC : is_closed C,
    { -- TODO: rewrite localization_data.is_closed_Union to match this.
      exact is_closed_bUnion (finite_Iio _) (λ j hj, (hK₀.image $ (L.φ j).continuous).is_closed) },
    simp only [P₀, forall_and_distrib] at hf₀,
    rcases hf₀ with ⟨hf_sec, hf_sol, hf_smooth, hf_A, hf_dist⟩,
    rw forall_restrict_germ_predicate_iff at hf_A,
    let F : formal_sol R := mk_formal_sol f hf_sec hf_sol hf_smooth,
    have hFAC : ∀ᶠ x near A ∪ C, F.is_holonomic_at x,
    { rw eventually_nhds_set_union,
      refine ⟨_, hf₁⟩,
      apply (hf_A.and h𝓕₀).eventually_nhds_set.mono (λ x hx, _),
      rw eventually_and at hx,
      apply hx.2.self_of_nhds.congr,
      apply hx.1.mono (λ x' hx', _),
      simp [F],
      exact hx'.symm },
    have hFφψ : F.bs '' (range $ L.φ i) ⊆ range (L.ψj i),
    { rw ← range_comp,
      apply L.ε_spec,
      intro x,
      calc dist (F.bs x) (𝓕₀.bs x) = dist (f x).1.2 (𝓕₀.bs x) : by simp only [F, mk_formal_sol_bs_apply]
      ... < τ x : hf_dist x
      ... ≤ L.ε x : min_le_right _ _ },
    let η : M → ℝ := λ x, τ x - dist (f x).1.2 (𝓕₀.bs x),
    have η_pos : ∀ x, 0 < η x,
    { exact λ x, sub_pos.mpr (hf_dist x) },
    have η_cont : continuous η,
    { have : cont_mdiff IM ((IM.prod IX).prod 𝓘(ℝ, EM →L[ℝ] EX)) ∞ f, from λ x, hf_smooth x,
      apply τ_cont.sub,
      exact (one_jet_bundle_proj_continuous.comp this.continuous).snd.dist
        𝓕₀.smooth_bs.continuous },
    rcases (L.φ i).improve_formal_sol (L.ψj i) hRample hRopen (hA.union hC) η_pos η_cont hFφψ hFAC
      hK₀ hK₁ hK₀K₁ with ⟨F', hF'₀, hF'₁, hF'AC, hF'K₁, hF'η, hF'hol⟩,
    refine ⟨λ t x, F' t x, _, _, _, _, _, _⟩,
    { refine λ t x, ⟨rfl, F'.is_sol, (F' t).smooth x, _, _⟩,
      { revert x,
        rw forall_restrict_germ_predicate_iff,
        rw [eventually_nhds_set_union] at hF'AC,
        apply (hF'AC.1.and hf_A).mono,
        rintros x ⟨hx, hx'⟩,
        change F' t x = _,
        rw [hx t, ← hx', mk_formal_sol_apply],
        refl },
      { calc dist (F' t x).1.2 (𝓕₀.bs x) ≤ dist (F' t x).1.2 (F.bs x) + dist (F.bs x) (𝓕₀.bs x) : dist_triangle _ _ _
        ... < η x + dist (F.bs x) (𝓕₀.bs x) : add_lt_add_right (hF'η t x) _
        ... = τ x : by simp [η] } },
    { rw [union_assoc, eventually_nhds_set_union] at hF'hol,
      replace hF'hol := hF'hol.2,
      simp_rw [← L.Union_succ'] at hF'hol,
      exact hF'hol },
    { exact F'.smooth },
    { intros t x hx,
      rw hF'K₁ t x ((mem_range_of_mem_image _ _).mt hx),
      simp [F] },
    { apply hF'₀.mono (λ x hx, _),
      erw hx,
      ext1 y,
      simp [F] },
    { apply hF'₁.mono (λ x hx, _),
      rw hx } },
  rcases inductive_htpy_construction P₀ P₁ P₂ hP₂ L.lf_φ K_cover init ind with ⟨F, hF₀, hFP₀, hFP₁, hFP₂⟩,
  simp only [P₀, forall₂_and_distrib] at hFP₀,
  rcases hFP₀ with ⟨hF_sec, hF_sol, hF_smooth, hF_A, hF_dist⟩,
  refine ⟨mk_htpy_formal_sol F hF_sec hF_sol hFP₂, _, _, _, _⟩,
  { intros x,
    rw [mk_htpy_formal_sol_apply, hF₀] },
  { exact hFP₁ },
  { intros x hx t,
    rw mk_htpy_formal_sol_apply,
    exact (forall_restrict_germ_predicate_iff.mp $ hF_A t).on_set x hx },
  { intros t x,
    change dist (mk_htpy_formal_sol F hF_sec hF_sol hFP₂ t x).1.2 (𝓕₀.bs x) ≤ δ x,
    rw mk_htpy_formal_sol_apply,
    exact (hF_dist t x).le.trans (min_le_left _ _) }
end

variables
{EP : Type*} [normed_add_comm_group EP] [normed_space ℝ EP]  [finite_dimensional ℝ EP]
{HP : Type*} [topological_space HP] {IP : model_with_corners ℝ EP HP} [boundaryless IP]
{P : Type*} [topological_space P] [charted_space HP P] [smooth_manifold_with_corners IP P]
[sigma_compact_space P]
[t2_space P]
{C : set (P × M)}

/-
We now deduce the parametric case from the unparametric one using
`rel_mfld.satisfies_h_principle.satisfies_h_principle_with` which reduces the parametric
`h`-principle to the non-parametric one for a different relation and `rel_mafld.ample.relativize`
which ensures the ampleness assumption survives this reduction.
-/

/-- **Gromov's Theorem** -/
theorem rel_mfld.ample.satisfies_h_principle_with (hRample : R.ample) (hRopen : is_open R)
  (hC : is_closed C)
  (hδ_pos : ∀ x, 0 < δ x) (hδ_cont : continuous δ) :
  R.satisfies_h_principle_with IP C δ :=
begin
  have hδ_pos' : ∀ (x : P × M), 0 < δ x.2 := λ (x : P × M), hδ_pos x.snd,
  have hδ_cont' : continuous (λ (x : P × M), δ x.2) := hδ_cont.comp continuous_snd,
  have is_op : is_open (rel_mfld.relativize IP P R) := R.is_open_relativize hRopen,
  apply rel_mfld.satisfies_h_principle.satisfies_h_principle_with,
  exact (hRample.relativize IP P).satisfies_h_principle is_op hC hδ_pos' hδ_cont',
end

variables
{E' : Type*} [normed_add_comm_group E'] [normed_space ℝ E'] [finite_dimensional ℝ E']
{H' : Type*} [topological_space H'] {I' : model_with_corners ℝ E' H'} [model_with_corners.boundaryless I']
{M' : Type*} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
[sigma_compact_space M'] [t2_space M']

include IP

/-
Since every (sigma-compact) manifold is metrizable, the metric space assumption can be removed.
-/

/-- Gromov's Theorem without metric space assumption -/
theorem rel_mfld.ample.satisfies_h_principle_with' {R : rel_mfld IM M I' M'}
  (hRample : R.ample) (hRopen : is_open R) (hC : is_closed C)
  (hδ_pos : ∀ x, 0 < δ x) (hδ_cont : continuous δ) :
  by letI := manifold_metric I' M' ; exact
  R.satisfies_h_principle_with IP C δ :=
by apply rel_mfld.ample.satisfies_h_principle_with; assumption


import IIT.PropInversion
import IIT.ClarifyIndices

/-
mututal
inductive Con : Type
| nil : Con
| ext : (Γ : Con) → Ty Γ → Con

inductive Ty : Con → Types
| base : (Γ : Con) → Ty Γ
| wk  : (Γ : Con) → (A B : Ty Γ) → Ty (ext Γ A)
end
-/

mutual
inductive Conₑ : Type
| nilₑ : Conₑ
| extₑ : Conₑ → Tyₑ → Conₑ

inductive Tyₑ : Type
| baseₑ : Conₑ → Tyₑ
| wkₑ   : Conₑ → Tyₑ → Tyₑ → Tyₑ
end

open Conₑ Tyₑ

mutual
inductive Con_w : Conₑ → Prop
| nil_w : Con_w nilₑ
| ext_w : ∀ {Γ}, Con_w Γ → ∀ {A}, Ty_w Γ A → Con_w (extₑ Γ A)

inductive Ty_w : Conₑ → Tyₑ → Prop
| base_w : ∀ {Γ}, Con_w Γ → Ty_w Γ (baseₑ Γ)
| wk_w : ∀ {Γ}, Con_w Γ → ∀ {A}, Ty_w Γ A → ∀ {B}, Ty_w Γ B → Ty_w (extₑ Γ A) (wkₑ Γ A B)
end

open Con_w Ty_w

def Con := PSigma Con_w
def Ty := fun (Γ : Con) => PSigma (Ty_w Γ.1)

def nil : Con                                         := ⟨nilₑ,            nil_w⟩
def ext (Γ : Con) (A : Ty Γ) : Con                    := ⟨extₑ Γ.1 A.1,    ext_w Γ.2 A.2⟩
def base (Γ : Con) : Ty Γ                             := ⟨baseₑ Γ.1,       base_w Γ.2⟩
def wk (Γ : Con) (A B : Ty Γ) : Ty (ext Γ A)          := ⟨wkₑ Γ.1 A.1 B.1, wk_w Γ.2 A.2 B.2⟩

section
variable
  (Conₘ  : Con → Type)
  (Tyₘ   : ∀ {Γ}, Conₘ Γ → Ty Γ → Type)
  (nilₘ  : Conₘ nil)
  (extₘ  : ∀ {Γ} (Γₘ : Conₘ Γ) {A}, Tyₘ Γₘ A → Conₘ (ext Γ A))
  (baseₘ : ∀ {Γ} (Γₘ : Conₘ Γ), Tyₘ Γₘ (base Γ))
  (wkₘ   : ∀ {Γ} (Γₘ : Conₘ Γ) {A} (Aₘ : Tyₘ Γₘ A) {B} (Bₘ : Tyₘ Γₘ B), Tyₘ (extₘ Γₘ Aₘ) (wk Γ A B))

mutual
inductive Conᵣ : (Γ : Con) → Conₘ Γ → Type
| nilᵣ : Conᵣ nil nilₘ
| extᵣ : ∀ {Γ} {Γₘ : Conₘ Γ}, Conᵣ Γ Γₘ →
           ∀ {A} {Aₘ : Tyₘ Γₘ A}, Tyᵣ Γₘ A Aₘ → Conᵣ (ext Γ A) (extₘ Γₘ Aₘ)

inductive Tyᵣ : {Γ : Con} → (Γₘ : Conₘ Γ) → (A : Ty Γ) → Tyₘ Γₘ A → Type
| baseᵣ: ∀ {Γ} {Γₘ : Conₘ Γ}, Conᵣ Γ Γₘ → Tyᵣ Γₘ (base Γ) (baseₘ Γₘ)
| wkᵣ: ∀ {Γ} {Γₘ : Conₘ Γ}, Conᵣ Γ Γₘ →
         ∀ {A} {Aₘ : Tyₘ Γₘ A}, Tyᵣ Γₘ A Aₘ →
           ∀ {B} {Bₘ : Tyₘ Γₘ B}, Tyᵣ Γₘ B Bₘ →
             Tyᵣ (extₘ Γₘ Aₘ) (wk Γ A B) (wkₘ Γₘ Aₘ Bₘ)
end

open Conᵣ Tyᵣ

noncomputable def Con_tot (Γ : Con) : PSigma (Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ) := by
  cases Γ with | mk Γₑ Γ_w => ?_
  apply Conₑ.recOn Γₑ
    (motive_1 := fun Γₑ => ∀ Γ_w, PSigma (Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ ⟨Γₑ, Γ_w⟩))
    (motive_2 := fun Aₑ => ∀ {Γ Γₘ} (Γᵣ : Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ Γₘ)
                   A_w, PSigma (Tyᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γₘ ⟨Aₑ, A_w⟩))
  · intro Γ_w
    exact PSigma.mk nilₘ nilᵣ
  · intro Δₑ Aₑ Δ_ih A_ih ctor_w
    inversion ctor_w with Δ_w A_w
    cases Δ_ih Δ_w with | mk Δₘ Δᵣ => ?_
    cases A_ih Δᵣ A_w with | mk Aₘ Aᵣ => ?_
    exact PSigma.mk (extₘ Δₘ Aₘ) (extᵣ Δᵣ Aᵣ)
  · intro Γₑ Γ_ih Δ Δₘ Δᵣ ctor_w
    cases Δ with | mk Δₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    exact PSigma.mk (baseₘ Δₘ) (baseᵣ Δᵣ)
  · intro Δₑ Aₑ Bₑ Δ_ih A_ih B_ih Δ' Δ'ₘ Δ'ᵣ ctor_w
    cases Δ' with | mk Δ'ₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    inversion ctor_w with Δ_w A_w B_w
    cases Δ'ᵣ with | @extᵣ Γ' Γ'ₘ Γ'ᵣ A' A'ₘ A'ᵣ => ?_
    cases B_ih Γ'ᵣ B_w with | mk Bₘ Bᵣ => ?_
    exact PSigma.mk (wkₘ Γ'ₘ A'ₘ Bₘ) (wkᵣ Γ'ᵣ A'ᵣ Bᵣ)

noncomputable def Ty_tot (Γ : Con) (A : Ty Γ) :
  PSigma (Tyᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ (Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ).1 A) := by
  cases Γ with | mk Γₑ Γ_w => ?_
  cases A with | mk Aₑ A_w => ?_
  apply Tyₑ.recOn Aₑ
    (motive_1 := fun Γₑ => ∀ Γ_w, PSigma (Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ ⟨Γₑ, Γ_w⟩))
    (motive_2 := fun Aₑ => ∀ {Γ Γₘ} (Γᵣ : Conᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ Γₘ)
                   A_w, PSigma (Tyᵣ Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γₘ ⟨Aₑ, A_w⟩))
  · intro Γ_w
    exact PSigma.mk nilₘ nilᵣ
  · intro Δₑ Aₑ Δ_ih A_ih ctor_w
    inversion ctor_w with Δ_w A_w
    cases Δ_ih Δ_w with | mk Δₘ Δᵣ => ?_
    cases A_ih Δᵣ A_w with | mk Aₘ Aᵣ => ?_
    exact PSigma.mk (extₘ Δₘ Aₘ) (extᵣ Δᵣ Aᵣ)
  · intro Γₑ Γ_ih Δ Δₘ Δᵣ ctor_w
    cases Δ with | mk Δₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    exact PSigma.mk (baseₘ Δₘ) (baseᵣ Δᵣ)
  · intro Δₑ Aₑ Bₑ Δ_ih A_ih B_ih Δ' Δ'ₘ Δ'ᵣ ctor_w
    cases Δ' with | mk Δ'ₑ Δ_w => ?_
    simp only at ctor_w
    clarifyIndices ctor_w
    inversion ctor_w with Δ_w A_w B_w
    cases Δ'ᵣ with | @extᵣ Γ' Γ'ₘ Γ'ᵣ A' A'ₘ A'ᵣ => ?_
    cases B_ih Γ'ᵣ B_w with | mk Bₘ Bᵣ => ?_
    exact PSigma.mk (wkₘ Γ'ₘ A'ₘ Bₘ) (wkᵣ Γ'ᵣ A'ᵣ Bᵣ)
  · exact (Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ ⟨Γₑ, Γ_w⟩).2

noncomputable def Con.rec (Γ : Con) : Conₘ Γ :=
(Con_tot Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ).1

noncomputable def Ty.rec (Γ : Con) (A : Ty Γ) : Tyₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ) A :=
(Ty_tot Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ A).1

theorem nil_beta : Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ nil = nilₘ :=
rfl

theorem ext_beta (Γ : Con) (A : Ty Γ) :
  Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ (ext Γ A)
  = extₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ)
    (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ A) :=
rfl

theorem base_beta (Γ : Con) :
  Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ (base Γ)
  = baseₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ) :=
rfl

theorem wk_beta (Γ : Con) (A : Ty Γ) (B : Ty Γ) :
  Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ (ext Γ A) (wk Γ A B)
  = wkₘ (Con.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ)
      (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ A)
      (Ty.rec Conₘ Tyₘ nilₘ extₘ baseₘ wkₘ Γ B) :=
rfl

end


import data.real.basic
import algebra.category.Group.basic
import category_theory.functor category_theory.yoneda
import analysis.normed.group.SemiNormedGroup

notation `Ab` := AddCommGroup

universes u

noncomputable theory
open category_theory

instance : concrete_category Ab := by apply_instance

@[protect_proj, ancestor semi_normed_group]
class homogeneous_semi_normed_group (E : Type*) extends semi_normed_group E :=
(is_homogeneous : ∀ (n : ℤ) (a : E), norm ( n • a ) = (abs n) * (norm a))

@[reducible]
def homogeneous_semi_normed_group.induced
 {F} [homogeneous_semi_normed_group F] {E} [add_comm_group E]
  (f : E →+ F) : homogeneous_semi_normed_group E :=
{ is_homogeneous := λ n a, by {
    change ∥ f (n • a) ∥ = _ * ∥ f a ∥,
    rw[add_monoid_hom.map_zsmul, homogeneous_semi_normed_group.is_homogeneous]
  },
  .. semi_normed_group.induced f
}

instance : bundled_hom.parent_projection
  @homogeneous_semi_normed_group.to_semi_normed_group := ⟨⟩

def homogeneous_normed_group_hom (V W : Type*)
  [homogeneous_semi_normed_group V] [homogeneous_semi_normed_group W] :=
    normed_group_hom V W

def HSNAb : Type (u + 1) := bundled homogeneous_semi_normed_group

namespace HSNAb

attribute [derive [large_category, concrete_category]] HSNAb

instance : has_coe_to_sort HSNAb (Type u) := bundled.has_coe_to_sort

def of (M : Type u) [homogeneous_semi_normed_group M] : HSNAb := bundled.of M

instance (M : HSNAb) : homogeneous_semi_normed_group M := M.str

end HSNAb

def HSNAb₁ : Type (u+1) := bundled homogeneous_semi_normed_group

namespace HSNAb₁

instance : has_coe_to_sort HSNAb₁ (Type u) := bundled.has_coe_to_sort

instance : large_category.{u} HSNAb₁ :=
{ hom := λ X Y, { f : normed_group_hom X Y // f.norm_noninc },
  id := λ X, ⟨normed_group_hom.id X, normed_group_hom.norm_noninc.id⟩,
  comp := λ X Y Z f g, ⟨(g : normed_group_hom Y Z).comp (f : normed_group_hom X Y), g.2.comp f.2⟩, }

@[ext] lemma hom_ext {M N : HSNAb₁} (f g : M ⟶ N) (w : (f : M → N) = (g : M → N)) :
  f = g :=
subtype.eq (normed_group_hom.ext (congr_fun w))

instance : concrete_category.{u} HSNAb₁ :=
{ forget :=
  { obj := λ X, X,
    map := λ X Y f, f, },
  forget_faithful := {} }

instance has_forget_Ab : category_theory.has_forget₂ HSNAb₁ Ab := {
  forget₂ := {
    obj := λ A, AddCommGroup.of A,
    map := λ A B f, AddCommGroup.of_hom (normed_group_hom.to_add_monoid_hom f)
  }
}

notation `U` := HSNAb₁.has_forget_Ab.forget₂

instance (A : HSNAb₁) : homogeneous_semi_normed_group (AddCommGroup.of A) := A.str

end HSNAb₁

def transfer {A : Ab} {A' : HSNAb₁} (f : A ≅ AddCommGroup.of A') :
  homogeneous_semi_normed_group A :=
  homogeneous_semi_normed_group.induced f.hom

variables {C : Type*} [category C]

def is_wf_pair {F : C ⥤ Ab} {X Y : C} (α : F.obj X) (β : F.obj Y) :=
  ∀ (n : ℕ), ∃ (m : ℤ) (f : X ⟶ Y), m.nat_abs ≥ n ∧ (F.map f) α = m • β

def is_weakly_flexible {F : C ⥤ Ab} {Y : C} (β : F.obj Y) :=
  ∃ (X : C) (α : F.obj X), is_wf_pair α β

structure functorial_semi_norm (F : C ⥤ Ab) :=
(lift : C ⥤ HSNAb₁)
(lift_iso : F ≅ (lift ⋙ U))

example (n : ℕ) (x : ℝ) : n • x = (n : ℝ) * x := by library_search

example (n m : ℕ) (h : n ≤ m) : (n : ℝ) ≤ (m : ℝ) := nat.cast_le.mpr h

example (x y z : ℝ) (h : 0 ≤ x) (h' : y ≤ z) : x * y ≤ x * z := mul_le_mul_of_nonneg_left h' h

lemma is_zero_of_bounds {c d : ℝ} (hc : c ≥ 0) (hd : d ≥ 0)
 (h : ∀ n : ℕ, ∃ m : ℕ, n ≤ m ∧ (m : ℝ) * c ≤ d ) : c = 0 :=
begin
  by_contra h', change c ≠ 0 at h',
  replace h' := lt_of_le_of_ne hc h'.symm,
  rcases (archimedean.arch (d + 1) h') with ⟨n, hn⟩,
  rw[nsmul_eq_mul] at hn,
  rcases (h n) with ⟨m, hnm, hm⟩,
  exact not_le_of_gt (lt_add_one d)
   (le_trans hn (le_trans (mul_le_mul_of_nonneg_right (nat.cast_le.mpr hnm) hc) hm))
end

lemma zero_norm_of_fsn {F : C ⥤ Ab} (F' : functorial_semi_norm F)
  {Y : C} {β : F.obj Y} (h : is_weakly_flexible β) :
    (norm : F'.lift.obj Y → ℝ) ((F'.lift_iso.app Y).hom β) = 0 :=
begin
  rcases h with ⟨X,α,hα⟩,
  let fX : F.obj X ≅ AddCommGroup.of (F'.lift.obj X) := F'.lift_iso.app X,
  let fY : F.obj Y ≅ AddCommGroup.of (F'.lift.obj Y) := F'.lift_iso.app Y,
  let α' := fX.hom α,
  let β' := fY.hom β,
  change ∥ β' ∥ = 0,
  apply is_zero_of_bounds (norm_nonneg β') (norm_nonneg α'),
  intro n,
  rcases (hα n) with ⟨m, g, hnm, hg⟩,
  use m.nat_abs, split, exact hnm,
  rw[int.cast_nat_abs, ← homogeneous_semi_normed_group.is_homogeneous],
  let g' : F'.lift.obj X ⟶ F'.lift.obj Y := F'.lift.map g,
  have : g' α' = m • β' := by {
    have := congr_hom (F'.lift_iso.hom.naturality g) α,
    change fY.hom ((F.map g) α) = g' (fX.hom α) at this,
    rw[hg, fY.hom.map_zsmul] at this,
    symmetry, exact this
  },
  rw[← this],
  exact g'.property α'
end

def is_indiscrete (A : HSNAb₁) := ∀ (a : A), ∥ a ∥ = 0

def UAb : Ab ⥤ Type u := AddCommGroup.concrete_category.forget

lemma corep_is_wf {F : C ⥤ Ab} [functor.corepresentable (F ⋙ UAb)]
 {Y : C} (β : F.obj Y) : is_weakly_flexible β :=
begin
  have c : functor.corepresentable (F ⋙ UAb) := by apply_instance,
  rcases c with ⟨T, p, hp⟩,
  let T' : C := opposite.unop T,
  haveI := hp,
  let p' : (T' ⟶ Y) → (F.obj Y) := p.app Y,
  let p'' : (F.obj Y) → (T' ⟶ Y) := ((as_iso p).app Y).inv,
  let u : (F.obj T') := p.app T' (𝟙 T'),
  let v : ∀ (n : ℤ), T' ⟶ Y := λ n, p'' (n • β),
  have hv : ∀ (n : ℤ), (F.map (v n)) u = n • β := λ n,
  begin
    have h : p' (v n) = (p' ∘ p'') (n • β) := rfl,
    have : p' ∘ p'' = id := ((as_iso p).app Y).inv_hom_id, rw[this, id.def] at h,
    rw[← h],
    have : p' (v n) = p' ((coyoneda.obj T).map (v n) (𝟙 T')) := by simp,
    rw[this],
    change (F.map (v n)) (p.app T' (𝟙 T')) = (p.app Y) _,
    have := (congr_hom (p.naturality (v n)) (𝟙 T')).symm,
    exact this,
  end,
  use T', use u, intro n, use n, use (v n),
  split, exact le_refl _, exact hv n
end

lemma corep_fsn_indiscrete {F : C ⥤ Ab} [functor.corepresentable (F ⋙ UAb)]
  (F' : functorial_semi_norm F) : ∀ (X : C), is_indiscrete (F'.lift.obj X) :=
begin
  intros Y β',
  let β : F.obj Y := (F'.lift_iso.app Y).inv β',
  have : β' = (F'.lift_iso.app Y).hom β := (congr_hom (F'.lift_iso.app Y).inv_hom_id β').symm,
  rw[this],
  exact zero_norm_of_fsn F' (corep_is_wf β),
end


import data.nat.basic
import .ch01_basics

open basics (evenb oddb sub_two leb)
open nat (add mul)

namespace poly

/-
Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).
-/

inductive boollist : Type
| bool_nil
| bool_cons (b : bool) (l : boollist)

/-
Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).
-/

/- needing to already move to gadt syntax is annoying -/
inductive list (α : Type) : Type
| nil : list
| cons (a : α) (l : list) : list

open poly.list

/-
Check list.
(* ===> list : Type -> Type *)
-/

#check list

/-
Check (nil nat).
(* ===> nil nat : list nat *)
-/

#check @nil ℕ

/-
Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)
-/

#check (cons 3 nil)

/-
Check nil.
(* ===> nil : forall X : Type, list X *)
-/

#check nil

/-
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)
-/

#check cons

/-
Check (cons nat 2 (cons nat 1 (nil nat))).
-/

#check (cons 2 (cons 1 nil))

/-
Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 ⇒ nil X
  | S count' ⇒ cons X x (repeat X x count')
  end.
-/

def repeat (α : Type) (a : α) : ℕ → list α
| 0 := nil
| (n + 1) := cons a (repeat n)

/-
Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.
-/

example : repeat ℕ 4 2 = cons 4 (cons 4 nil) := rfl

/-
Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.
-/

example : repeat bool ff 1 = cons ff nil := rfl

/-
Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).
-/

/- i don't want to lose the ability to use a/b in prod -/
namespace mumble_grumble

inductive mumble : Type
| a
| b (x : mumble) (y : ℕ)
| c

inductive grumble (α : Type) : Type
| d (m : mumble) : grumble
| e (a : α) : grumble

open mumble
open grumble

#check d (b a 5)
#check @d mumble (b a 5)
#check @d bool (b a 5)
#check @e mumble (b c 0)
-- #check @e bool (b c 0)
#check c

end mumble_grumble

/-
Fixpoint repeat' X x count : list X :=
  match count with
  | 0 ⇒ nil X
  | S count' ⇒ cons X x (repeat' X x count')
  end.
-/

def repeat' (α a) : ∀count, list α
| 0 := nil
| (count + 1) := cons a (repeat' count)

/-
Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)
-/

/-
Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 ⇒ nil _
  | S count' ⇒ cons _ x (repeat'' _ x count')
  end.
-/

def repeat'' {α} (a) : ∀count, list α
| 0 := @nil _
| (count + 1) := cons a (repeat'' count)

/-
Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).
-/

def list123 := cons 1 (cons 2 (cons 3 nil))

/-
Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).
-/

def list123' := @cons _ 1 (@cons _ 2 (@cons _ 3 (@nil _)))

/-
Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
-/

/-
arguments doesn't appear to exist in lean
-/

/-
let's go one step further
-/

variables {α β γ : Type}

/-
Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 ⇒ nil
  | S count' ⇒ cons x (repeat''' x count')
  end.
-/

/-
Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').
-/

inductive list' : Type
| nil' : list'
| cons' : α → list'

/-
Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil ⇒ l2
  | cons h t ⇒ cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil ⇒ nil
  | cons h t ⇒ app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil ⇒ 0
  | cons _ l' ⇒ S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.
-/

/-
to add something beyond polymorphism to this chapter,
let's also use generalized field notation
-/
def list.append : list α → list α → list α
| nil l₂ := l₂
| (cons h t) l₂ := cons h (t.append l₂)

def list.reverse : list α → list α
| nil := nil
| (cons h t) := t.reverse.append (cons h nil)

def list.length : list α → ℕ
| nil := 0
| (cons _ t) := t.length + 1

example :
  (cons 1 (cons 2 nil)).reverse = cons 2 (cons 1 nil) := rfl

example : (cons tt nil).reverse = cons tt nil := rfl

example : (cons 1 (cons 2 (cons 3 nil))).length = 3 := rfl

/-
Definition mynil : list nat := nil.
-/

def mynil : list ℕ := nil

/-
Check @nil.
Definition mynil' := @nil nat.
-/

#check @nil
def mynil' := @nil ℕ

/-
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
-/

local infixr :: := cons
local notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l
local infixr ++ := list.append

/-
Theorem app_nil_r : ∀(X:Type), ∀l:list X,
  l ++ [] = l.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem app_assoc : ∀A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma app_length : ∀(X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem cons_append (a : α) (l₁ l₂) : (a::l₁) ++ l₂ = a::(l₁ ++ l₂) := rfl

theorem append_nil (l : list α) : l ++ [] = l :=
begin
  induction l with a l ih,
    refl,
  rw cons_append,
  rw ih,
end

theorem nil_append (l : list α) : [] ++ l = l := rfl

theorem append_assoc (l m n : list α) : l ++ (m ++ n) = (l ++ m) ++ n :=
begin
  induction l with a l ih,
    refl,
  rw [cons_append, cons_append, cons_append],
  rw ih,
end

theorem length_nil : (@nil α).length = 0 := rfl

theorem length_cons (a : α) (l) : (a::l).length = l.length + 1 := rfl

lemma length_append (l₁ l₂ : list α) :
  (l₁ ++ l₂).length = l₁.length + l₂.length :=
begin
  induction l₁ with n l ih,
    rw nil_append,
    rw length_nil,
    rw zero_add,
  rw cons_append,
  rw [length_cons, length_cons],
  rw ih,
  rw [add_assoc _ 1, add_comm 1, add_assoc],
end

/-
Theorem rev_app_distr: ∀X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : ∀X : Type, ∀l : list X,
  rev (rev l) = l.
Proof.
  (* FILL IN HERE *) Admitted.
-/

open poly.list (reverse)

theorem reverse_append (l₁ l₂ : list α) :
  (l₁ ++ l₂).reverse = l₂.reverse ++ l₁.reverse :=
begin
  induction l₁ with a l₁ ih,
    rw nil_append,
    rw reverse,
    rw append_nil,
  rw cons_append,
  rw [reverse, reverse],
  rw ih,
  rw append_assoc,
end

theorem reverse_involutive (l : list α) : reverse (reverse l) = l :=
begin
  induction l with n l ih,
    refl,
  rw reverse,
  rw reverse_append,
  rw ih,
  refl,
end

/-
Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Arguments pair {X} {Y} _ _.
-/

/- something else new -/
structure prod (α β : Type) : Type := (fst : α) (snd : β)

open poly.prod

/-
Notation "( x , y )" := (pair x y).
-/

/-
this is going to break (update : yep, {} break typeclass stuff)
local should be fine though
i don't see anything like coq's scope in lean
-/
local notation {x, y} := prod.mk x y
local infix × := prod

/-
Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) ⇒ x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) ⇒ y
  end.
-/

#check fst
#check snd

/-
Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ ⇒ []
  | _, [] ⇒ []
  | x :: tx, y :: ty ⇒ (x, y) :: (combine tx ty)
  end.
-/

def combine : list α → list β → list (α × β)
| [] _ := []
| (a::ta) [] := []
| (a::ta) (b::tb) := {a, b}::combine ta tb

/-
Compute (combine [1;2] [false;false;true;true]).
-/

#check @combine
#reduce combine [1, 2] [ff, ff, tt, tt]

/-
Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* FILL IN HERE *) Admitted.
-/

/- lean caches so this won't be exponential -/
/- unfortunately lean seems incapable of unfolding this -/
def split' : list (α × β) → list α × list β
| [] := {[], []}
| ({a, b}::l) := {a::(split' l).fst, b::(split' l).snd}

/- can also uses explicit induction to clearly be linear -/
def split (l : list (α × β)) : list α × list β :=
begin
  induction l with h t ih,
    exact {[], []},
  exact {h.fst::ih.fst, h.snd::ih.snd},
end

example : split [{1, ff}, {2, ff}] = {[1, 2], [ff, ff]} := rfl

/-
Module OptionPlayground.
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.
-/

inductive option (α : Type) : Type
| none : option
| some (a : α) : option

open poly.option

/-
Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] ⇒ None
  | a :: l' ⇒ if n =? O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.

Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].

Example test_nth_error3 : nth_error [true] 2 = None.

-/

def nth_error : list α → ℕ → option α
| [] _ := none
| (h::_) 0 := some h
| (_::t) (n + 1) := nth_error t n

example : nth_error [4,5,6,7] 0 = some 4 := rfl

example : nth_error [[1],[2]] 1 = some [2] := rfl

example : nth_error [tt] 2 = none := rfl

/-
Definition hd_error {X : Type} (l : list X) : option X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
-/

def hd_error : list α → option α
| [] := none
| (h::_) := some h

/-
Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
 (* FILL IN HERE *) Admitted.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
 (* FILL IN HERE *) Admitted.
-/

#check @hd_error

example : hd_error [1,2] = some 1 := rfl

example : hd_error [[1], [2]] = some [1] := rfl

/-
Definition doit3times {X:Type} (f:X→X) (n:X) : X :=
  f (f (f n)).
-/

def doit3times {α : Type} (f: α → α) (n : α) : α :=
  f (f (f n))

/-
Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.
-/

#check @doit3times

example : doit3times sub_two 9 = 3 := rfl

example : doit3times bnot tt = ff := rfl

/-
Fixpoint filter {X:Type} (test: X→bool) (l:list X)
                : (list X) :=
  match l with
  | [] ⇒ []
  | h :: t ⇒ if test h then h :: (filter test t)
                        else filter test t
  end.
-/

def list.filter {α : Type} (test : α → bool)
  : list α → list α
| [] := []
| (h::t) := if test h then h::t.filter else t.filter

/-
Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.
-/

example : [1, 2, 3, 4].filter evenb = [2,4] := rfl

def length_is_1 {α : Type} (l : list α) : bool :=
  list.length l =? 1

example : [[1, 2], [3], [4], [5, 6, 7], [], [8]].filter length_is_1
  = [[3], [4], [8]] := rfl

/-
Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.
-/

open poly.list (filter length)

def countoddmembers := length ∘ (filter oddb)

example : countoddmembers [1, 0, 3, 1, 4, 5] = 4 := rfl

example : countoddmembers [0,2,4] = 0 := rfl

example : countoddmembers [] = 0 := rfl

/-
Example test_anon_fun':
  doit3times (fun n ⇒ n * n) 2 = 256.
Proof. reflexivity. Qed.
-/

/- commenting out as this is murdering my computer... -/
-- example : doit3times (λ (n : int), n * n) 2 = 256 := rfl

/-
Example test_filter2':
    filter (fun l ⇒ (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.
-/

example :
  [[1, 2], [3], [4], [5, 6, 7], [], [8]].filter (λ l, l.length =? 1)
  = [[3], [4], [8]] := rfl

/-
Definition filter_even_gt7 (l : list nat) : list nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *) Admitted.
-/

def filter_even_gt₇ := filter (λ n, evenb n && leb 7 n)

example :
  filter_even_gt₇ [1, 2, 6, 9, 10, 3, 12, 8] = [10, 12, 8] := rfl

example : filter_even_gt₇ [5, 2, 6, 19, 129] = [] := rfl

/-
Definition partition {X : Type}
                     (test : X → bool)
                     (l : list X)
                   : list X * list X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *) Admitted.

Example test_partition2: partition (fun x ⇒ false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *) Admitted.
-/

/- reminder: the translation will be linear -/

def list.partition (test : α → bool) : list α → list α × list α
| [] := {[], []}
| (h::t) := if test h
            then {h::t.partition.fst, t.partition.snd}
            else {t.partition.fst, h::t.partition.snd}

example :
  [1,2,3,4,5].partition oddb = {[1, 3, 5], [2, 4]} := rfl

example :
  [5,9,0].partition (λ _, ff) = {[], [5, 9, 0]} := rfl

/-
Fixpoint map {X Y: Type} (f:X→Y) (l:list X) : (list Y) :=
  match l with
  | [] ⇒ []
  | h :: t ⇒ (f h) :: (map f t)
  end.
-/

def list.map (f : α → β) : list α → list β
| [] := []
| (h::t) := f h :: t.map

/-
Example test_map1: map (fun x ⇒ plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
-/

example : [2, 0, 2].map (λx, 3 + x) = [5, 3, 5] := rfl

/-
Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.
-/

example : [2, 1, 2, 5].map oddb = [ff, tt, ff, tt] := rfl

/-
Example test_map3:
    map (fun n ⇒ [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.
-/

example : [2, 1, 2, 5].map (λn, [evenb n, oddb n])
  = [[tt, ff], [ff, tt], [tt, ff], [ff, tt]] := rfl

/-
Theorem map_rev : ∀(X Y : Type) (f : X → Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *) Admitted.
-/

open poly.list (map)

lemma map_append (f : α → β) (l₁ l₂ : list α) :
  (l₁ ++ l₂).map f = l₁.map f ++ l₂.map f :=
begin
  induction l₁ with a l₁ ih,
    refl,
  rw cons_append,
  rw [map, map],
  rw ih,
  rw cons_append,
end

def map_reverse (f : α → β) (l : list α) :
  l.reverse.map f = (l.map f).reverse :=
begin
  induction l with a l ih,
    refl,
  rw map,
  rw [reverse, reverse],
  rw map_append,
  rw ih,
  refl,
end

/-
Fixpoint flat_map {X Y: Type} (f: X → list Y) (l: list X)
                   : (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_flat_map1:
  flat_map (fun n ⇒ [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *) Admitted.
-/

/- i don't love the order that lean uses -/
def list.bind : list α → (α → list β) → list β
| [] f := []
| (h::t) f := f h ++ t.bind f

example : [1, 5, 4].bind (λn, [n, n, n])
  = [1, 1, 1, 5, 5, 5, 4, 4, 4] := rfl

/-
Definition option_map {X Y : Type} (f : X → Y) (xo : option X)
                      : option Y :=
  match xo with
    | None ⇒ None
    | Some x ⇒ Some (f x)
  end.
-/

def option.bind : option α → (α → β) → option β
| none f := none
| (some a) f := some (f a)

/-
Fixpoint fold {X Y: Type} (f: X→Y→Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil ⇒ b
  | h :: t ⇒ f h (fold f t b)
  end.
-/

def list.foldr (f: α → β → β) (b : β) : list α → β
| [] := b
| (a::t) := f a t.foldr

def list.foldl (f: α → β → α) : α → list β → α
| a [] := a
| a (b::t) := t.foldl (f a b)

/-
Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
-/

open poly.list (foldr)

#check foldr band

example : [1, 2, 3, 4].foldr mul 1 = 24 := rfl

example : [tt, tt, ff, tt].foldr band tt = ff := rfl

/-
why is this ambiguous?
type class resolution fails if using has_append.append
-/
example : [[1], [], [2, 3], [4]].foldr list.append [] = [1, 2, 3, 4] := rfl

/-
Definition constfun {X: Type} (x: X) : nat→X :=
  fun (k:nat) ⇒ x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
-/

def constfun (a: α) : ℕ → α := λ_, a

def ftrue := constfun tt

example : ftrue 0 = tt := rfl

example : constfun 5 99 = 5 := rfl

/-
Check plus.
(* ==> nat -> nat -> nat *)
-/

#check add

/-
Definition plus3 := plus 3.
Check plus3.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.

Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.

Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.
-/

def add₃ := add 3

example : add₃ 4 = 7 := rfl

example : doit3times add₃ 0 = 9 := rfl

example : doit3times (add 3) 0 = 9 := rfl

/-
Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n ⇒ S n) l 0.
Example test_fold_length1 : fold_length [4;7;0] = 3.
-/

def fold_length (l : list α) : ℕ := l.foldr (λ_ n, n + 1) 0

example : fold_length [4, 7, 0] = 3 := rfl

/-
Theorem fold_length_correct : ∀X (l : list X),
  fold_length l = length l.
Proof.
(* FILL IN HERE *) Admitted.
-/

theorem fold_length_correct (l : list α) : fold_length l = l.length :=
begin
  induction l with a l ih,
    refl,
  rw length,
  rw fold_length at ih ⊢,
  rw foldr,
  rw ih,
end

/-
Definition fold_map {X Y: Type} (f: X → Y) (l: list X) : list Y
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
-/

def fold_map (f : α → β) (l : list α) : list β :=
  l.foldr (λ h b, f h :: b) []

theorem fold_map_correct (f : α → β) (l : list α) :
  fold_map f l = l.map f :=
begin
  induction l with h t ih,
    refl,
  rw map,
  rw fold_map at ih ⊢,
  rw foldr,
  rw ih,
end

/-
Definition prod_curry {X Y Z : Type}
  (f : X * Y → Z) (x : X) (y : Y) : Z := f (x, y).
-/

def function.curry (f : α × β → γ) (a : α) (b : β) : γ := f {a, b}

/-
Definition prod_uncurry {X Y Z : Type}
  (f : X → Y → Z) (p : X * Y) : Z
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
-/

def function.uncurry (f : α → β → γ) (p : α × β) : γ := f p.fst p.snd

/-
Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
-/

example : [2, 0, 2].map (add 3) = [5, 3, 5] := rfl

/-
Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : ∀(X Y Z : Type)
                        (f : X → Y → Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : ∀(X Y Z : Type)
                        (f : (X * Y) → Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *) Admitted.
-/

open poly.function

#check @curry
#check @uncurry

theorem uncurry_curry (f : α → β → γ) (a : α) (b : β) :
  curry (uncurry f) a b = f a b := rfl

theorem curry_uncurry (f : α × β → γ) (p : α × β) :
  uncurry (curry f) p = f p :=
begin
  cases p with a b,
  refl,
end

/-
Definition cnat := ∀X : Type, (X → X) → X → X.
-/

def cnat := ∀α : Type, (α → α) → α → α

/-
Definition one : cnat :=
  fun (X : Type) (f : X → X) (x : X) ⇒ f x.
-/

def one : cnat := λ_ f, f

/-
Definition two : cnat :=
  fun (X : Type) (f : X → X) (x : X) ⇒ f (f x).
-/

def two : cnat := λ_ f, f ∘ f

/-
Definition zero : cnat :=
  fun (X : Type) (f : X → X) (x : X) ⇒ x.
-/

def zero : cnat := λ_ f x, x

/-
Definition three : cnat := @doit3times.
-/

def three : cnat := @doit3times

/-
Definition succ (n : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example succ_1 : succ zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example succ_2 : succ one = two.
Proof. (* FILL IN HERE *) Admitted.

Example succ_3 : succ two = three.
Proof. (* FILL IN HERE *) Admitted.
-/

def succ (n : cnat) : cnat := λα f x, f (n α f x)

example : succ zero = one := rfl

example : succ one = two := rfl

example : succ two = three := rfl

/-
Definition plus (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example plus_1 : plus zero one = one.
Proof. (* FILL IN HERE *) Admitted.

Example plus_2 : plus two three = plus three two.
Proof. (* FILL IN HERE *) Admitted.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. (* FILL IN HERE *) Admitted.
-/

def plus (m n : cnat) : cnat := λα f x, m α f (n α f x)

example : plus zero one = one := rfl

example : plus two three = plus three two := rfl

example : plus (plus two two) three = plus one (plus three three) := rfl

/-
Definition mult (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *) Admitted.
-/

def mult (m n : cnat) : cnat := λα f x, m α (n α f) x

example : mult one one = one := rfl

example : mult zero (plus three three) = zero := rfl

example : mult two three = plus three three := rfl

/-
Definition exp (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *) Admitted.
-/

def exp (m n : cnat) : cnat :=  λα f x, n (α → α) (m α) f x

example : exp two two = plus two two := rfl

example : exp three zero = one := rfl

example : exp three two = plus (mult two (mult two two)) one := rfl

end poly


import algebra.category
import .inverse .limit .fibrant .finite .matching

open sigma category eq.ops function functor

open reduced_coslice invcat

section MO_facts
   variables {C : Category.{1 1}}
             {D : Category}

    open reduced_coslice reduced_coslice.coslice_obs nat subcat_obj fincat matching_object invcat
    open equiv equiv.ops poly_unit
    open natural_transformation

    variables {z : C} {x : C_without_z z}
              {φ : C ⇒ ℕop} {reflecting_id : id_reflect φ}
              {max_rank : ∀ x, φ x ≤ φ z}
              [is_obj_finite C] [invcat C]
              (X : C ⇒ U)

    definition red_coslice_to_C' (o : x//C_without_z z) : (obj x)//C :=
    begin
      cases o with [t,f,non_id],
      refine red_coslice_obs.mk (obj t) f _, intros p, intros q,
      assert H : @eq (C_without_z z) x t, begin cases x, cases t, esimp at *, congruence, assumption end,
      apply non_id H, cases H, esimp, apply q
    end

    definition red_coslice_to_C'_hom (a b : x//C_without_z z) (f : a ⟶ b) : (red_coslice_to_C' a) ⟶ (red_coslice_to_C' b) :=
    begin
      cases f with [f, comm_tr], cases a with [a,g,non_id], cases b with [b,g', non_id'],
      unfold red_coslice_obs.to_coslice_obs at *, unfold red_coslice_to_C' at *, esimp at *,
      apply ⟨f,comm_tr⟩
    end

    -- (Danil) I pack this property as a lemma to prevent unnessesary unfolding
    -- which sometimes leads to errors when unfolding definitions dependent on this one
    lemma subcat_obj_eq {c c1: C} {P : C → Prop} {p : P c} {p1 : P c1}
      (q : subcat_obj.mk c p = subcat_obj.mk c1 p1) : c = c1 :=
      begin refine subcat_obj.no_confusion q (λ x y, x) end

    include φ max_rank reflecting_id

    definition red_coslice_ne_z (t : C) (f : x ⟶ t) : t ≠ z :=
    begin
      cases x with [x', x'_ne], esimp at *,
      cases (@fincat.has_decidable_eq _ _ t z) with [t_eq_z, t_ne_z], cases t_eq_z, exfalso,
      apply @no_incoming_non_id_arrows _ z φ max_rank reflecting_id, existsi x', existsi f, apply x'_ne, apply t_ne_z
    end

    definition red_coslice_from_C' [reducible] (o : (obj x)//C) : x//C_without_z z :=
    begin
      cases o with [t,f,non_id], esimp at *,
      cases x with [x', x'_ne], esimp at *,
      let t' := subcat_obj.mk t
      (@red_coslice_ne_z _ z (mk x' x'_ne) φ reflecting_id max_rank _ _ t f),
      refine red_coslice_obs.mk _ _ _, apply t', apply f, intros p,
      intros q,
      have q1 : x' = t, from subcat_obj_eq p,
      apply non_id q1, cases q1, esimp at *, apply q
    end

    definition red_coslice_from_C'_hom {a b : x//C} (f : a ⟶ b) :
    (@red_coslice_from_C' _ _ _ _ reflecting_id max_rank _ _ a) ⟶ (@red_coslice_from_C' _ _ _ _ reflecting_id max_rank _ _ b) :=
    begin
      cases f with [f, comm_tr], cases a with [a,g,non_id], cases b with [b,g', non_id'],
      unfold red_coslice_obs.to_coslice_obs at *, unfold red_coslice_from_C' at *, esimp at *,
      cases x, esimp at *,
      apply ⟨f,comm_tr⟩,
    end

    definition red_coslice_without_z_equiv : (obj x)//C ≃ₛ (x//C_without_z z) :=
    equiv.mk (@red_coslice_from_C' C _ _ _ reflecting_id max_rank _ _) red_coslice_to_C'
    begin
      intros y, cases y with [y,f,non_id],
      cases x with [x, x_ne], esimp
    end
    begin
      intros y, cases y with [y,f,non_id], unfold red_coslice_to_C',
      cases y, esimp, unfold red_coslice_from_C', cases x, esimp
    end

    definition red_coslice_eq_1 :
    ∀ y, object X (obj (red_coslice_obs.to ((@red_coslice_without_z_equiv  _ _ x _ reflecting_id max_rank _ _) ∙ y))) =
      X (red_coslice_obs.to y) :=
      begin
        intro, unfold fn, cases y with [y,f,y_ne], cases x with [x, x_ne], esimp
      end

    definition MO'_to_MO_map :
    matching_object (Functor_from_C' z X) x → matching_object X (obj x) :=
    begin
      let ψ := @red_coslice_without_z_equiv C z _ φ reflecting_id max_rank _ _,
      intros a,
      refine natural_transformation.mk _ _,
      { intros y uu, unfold functor.compose at *, unfold forget at *, esimp at *, unfold red_coslice_obs.to_coslice_obs,
        unfold Functor_from_C' at *,
        have HH : object X (red_coslice_obs.to (ψ ∙ y)), from (natural_map a) (ψ ∙ y) star,
        intro, unfold fn at *,
        cases y with [y,f,y_ne], cases x with [x', x_ne], esimp at *,
        apply HH },
      { cases a with [η, NatSq], intros x' y,
        intros f',
        let X' := Functor_from_C' z X,
        let C' := C_without_z z,
        assert HH : #function
        morphism (X' ∘f forget C' x) (red_coslice_from_C'_hom f') ∘ η (red_coslice_from_C' x') =
        η (@red_coslice_from_C' _ _ _ _ reflecting_id max_rank _ _ y),
        begin apply NatSq _ end,
        cases x with [x,f,non_id_f], cases y with [y,g,non_id_g], esimp at *,
        cases f' with [a,p1], esimp,
        cases x' with [o, o_ne], esimp,
        unfold Functor_from_C' at *, unfold functor.compose at *, unfold forget at *, esimp at *,
        unfold red_coslice_from_C'_hom at *, esimp at *,
        rewrite natural_map_proj,
        apply funext, intros uu, esimp, esimp, cases uu, refine happly HH _ }
    end

    definition MO_equiv : matching_object (Functor_from_C' z X) x ≃ₛ matching_object X (obj x) :=
    begin
      let C' := C_without_z z,
      let X' := Functor_from_C' z X,
      let  ψ := @red_coslice_without_z_equiv C z x φ reflecting_id max_rank _ _,

      -- we got two commuting triangles using equivalence  ((obj x)//C) ≃ (x//C')
      assert Htr1 : ∀ y, (X' ∘f !forget) (@to_fun _ _ ψ y) = (X ∘f !forget) y,
        begin intro, unfold functor.compose, unfold forget, unfold Functor_from_C',
          unfold red_coslice_obs.to_coslice_obs, esimp, refine red_coslice_eq_1 _ _,
        end,
      assert Htr2 : ∀ y, (X ∘f !forget) (@inv_fun _ _ ψ y) = (X' ∘f (!forget)) y,
        begin intro, unfold functor.compose, unfold forget, unfold Functor_from_C',
      unfold red_coslice_obs.to_coslice_obs, cases y with [y,f,y_ne], esimp end,
      unfold matching_object,
      refine equiv.mk (@MO'_to_MO_map _ _ _ _ reflecting_id max_rank _ _ X) _ _ _,
      { intros a, cases a with [η, NatSq], refine natural_transformation.mk _ _,
        intros y uu,
        have η' :  poly_unit → (X∘f forget C (obj x)) (@equiv.inv _ _ ψ y), from η _,
        intro, unfold functor.compose at *, unfold forget at *, unfold Functor_from_C' at *,
        unfold red_coslice_obs.to_coslice_obs, cases y with [y,f,y_ne], esimp, apply η' star,
        intros a b f,
        assert HH : morphism (X∘f forget C (obj x)) (red_coslice_to_C'_hom _ _ f) ∘ η (red_coslice_to_C' a)
        = η (red_coslice_to_C' b),
        begin refine NatSq _ end,
        unfold Functor_from_C' at *, unfold functor.compose at *, unfold forget at *, esimp at *,
        unfold red_coslice_to_C'_hom at *, esimp at *,
        cases f with [f,comm_tr], cases a with [a, ff, non_id_ff ], cases b with [b, gg, non_id_gg],
        apply funext, intros uu, cases uu,
        refine happly HH _},
      { intros a, refine nat_trans_eq, cases a with [η, NatSq], rewrite natural_map_proj,
        unfold MO'_to_MO_map, unfold fn, unfold equiv.inv, rewrite natural_map_proj,
        apply funext, intro y, apply funext, intro uu, cases uu,
        have Heq : (@to_fun _ _ ψ (@inv_fun (obj x//C) _ ψ y)) = y, from by apply right_inv,
        cases Heq, cases y with [y,f,non_id_f], esimp at *, cases x with [x,p], esimp },
      { intros a, refine nat_trans_eq, cases a with [η, NatSq],
        esimp, rewrite natural_map_proj,
        unfold MO'_to_MO_map, rewrite natural_map_proj,
        apply funext, intro y, apply funext, intro uu, cases uu,
        cases y, cases x, esimp }
    end

  end MO_facts


import main
import split_cycle
import algebra.linear_ordered_comm_group_with_zero

open_locale classical

variables {V X : Type}

def pareto (F : VSCC) (P : Prof V X ) : Prop := ∀ x y, ((∀ v, P v x y) → y ∉ F V X P)

lemma unanimous_margin [fintype V] [inhabited V] (P : Prof V X) [profile_asymmetric P] (x y : X) : (∀ v, P v x y) → margin_pos P x y :=
begin
    intro r,
    unfold margin_pos, unfold margin,
    classical,
    simp,
    have empty : (finset.filter (λ (x_1 : V), P x_1 y x) finset.univ).card = 0,
    apply finset.card_eq_zero.mpr,
    apply finset.eq_empty_iff_forall_not_mem.mpr,
    simp,
    intro v,
    have b := (_inst_3.asymmetric),
    specialize b v,
    specialize r v,
    specialize b x, specialize b y,
    exact b r,
    rw empty,
    apply zero_lt_iff.mpr,
    by_contradiction a,
    push_neg at a,
    have a := finset.card_eq_zero.mp a,
    have a := finset.eq_empty_iff_forall_not_mem.mp a,
    simp at a,
    specialize a (_inst_2.default),
    specialize r (_inst_2.default),
    exact a r,
end

lemma ineq6 (a b : ℤ) : a > b → a - b > 0  := by omega

lemma ineq7 (n : ℕ) : n > 0 → n - 1 < n := by omega

lemma ineq8 (n : ℕ) : n > 1 → (n - 1) ≠ 0 := by omega

lemma preference_acyclic_ineq (i n : ℕ) : i.succ < n → 0 < n - 1 := by omega
lemma preference_acyclic_ineq2 (i n : ℕ) : ¬ (i = 0) → (i.succ < n → i < n - 1) := by omega

def preference_acyclic (P : Prof V X) [profile_irreflexive P] [profile_transitive P] (v : V) : ¬ ∃ (l : list X), cycle (P v) l :=
begin
    by_contradiction a,
    cases a with l a,
    cases a with e a,
    rw list.chain_iff_pairwise at a,
    obviously,
    specialize a_left (l.last e),
    specialize a_left (list.last_mem e),
    have irrefl := _inst_1.irreflexive,
    specialize irrefl v,
    specialize irrefl (l.last e),
    exact irrefl a_left,

    have transitive := _inst_2.transitive,
    specialize transitive v,
    exact transitive ᾰ ᾰ_1,
end

lemma ineq9 (a b c : ℕ) : (a:ℤ) ≤ ↑b - ↑c → a ≤ b :=
begin
    intro a,
    have : (0:ℤ) ≤ c := int.coe_zero_le c,
    linarith,
end

def split_cycle_pareto [inhabited V] [fintype V] (P : Prof V X) [profile_asymmetric P] [profile_transitive P] : pareto split_cycle P :=
begin
    intros x y r,
    unfold split_cycle,
    unfold max_el_VSCC,
    simp,
    use x,
    unfold split_cycle_VCCR, unfold split_cycle_CCR,
    simp,
    introI _inst_10,
    split,
    exact unanimous_margin P x y r,

    intro c, intro x_mem, intro y_mem,

    by_contradiction a, -- suppose there is a "defending" cycle where x dominates y.
    cases a with e b,

    have pc : cycle (P _inst_1.default) c, -- show that the guaranteed voter has a cyclic preference
    unfold cycle,
    use e, -- since c is a cycle in dominate, it is of length ≠ 0.

    have everyone_prefers : margin P x y = fintype.card V, -- we will show that the margin is |V|
    unfold margin,
    haveI _inst_4 : fintype ↥{v : V | P v y x} := subtype.fintype (λ v, P v y x),
    have nobody : ((finset.filter (λ (v : V), P v y x) finset.univ).card) = 0, -- first, nobody prefers y to x.
    rw finset.card_eq_zero,
    apply finset.eq_empty_iff_forall_not_mem.mpr,
    simp,
    intro x_1,
    have asymm := _inst_3.asymmetric,
    specialize asymm x_1 x y (r x_1), -- we know this because of profile asymmetry
    exact asymm, -- thus nobody prefers y to x
    simp at nobody,
    rw nobody,
    simp, -- now we need to show that the cardinality of those that prefer x to y is the cardinality of V
    rw (eq.symm finset.card_univ),
    have everyone : (finset.filter (λ (x_1 : V), P x_1 x y) finset.univ) = finset.univ,
    refine finset.ext_iff.mpr _,
    simp,
    exact r,
    rw everyone,

    refine list.chain.imp _ b,
    intros z w,
    rw everyone_prefers,
    intro b',
    unfold margin at b',
    have b' := ineq9 (fintype.card V) ((finset.filter (λ (x : V), P x z w) finset.univ).card) ((finset.filter (λ (x : V), P x w z) finset.univ).card) b',
    contrapose b',
    simp,
    rw finset.card_lt_iff_ne_univ,
    contrapose b',
    push_neg at b', push_neg,
    rw finset.eq_univ_iff_forall at b',
    simp at b',
    exact b' (default V),

    haveI irrefl := irreflexive_of_asymmetric P,
    have acyclic := preference_acyclic P (default V),
    have exists_cycle : ∃ (l : list X), cycle (P (default V)) l,
    use c,
    exact pc,
    exact acyclic exists_cycle,
end


import data.stream
import unitb.logic
import util.logic
import util.classical
import util.data.array
import util.data.bijection
import util.data.stream
import util.meta.tactic

import temporal_logic

universe variables u v

namespace scheduling

open stream nat function
open predicate
namespace unitb

section target

parameters (lbl : Type)

structure target_mch :=
  (σ : Type)
  (s₀ : σ)
  (req : var σ (set lbl))
  (req_nemp : ∀ x, req.apply x ≠ ∅)
  (next : ∀ l s, l ∈ req.apply s → σ)

parameters {lbl}

def target_mch.action (t : target_mch) (l : lbl) (s s' : t.σ) : Prop :=
∃ P, s' = t.next l s P

-- def run (t : target_mch) (τ : stream lbl) : stream t.σ
--   | 0 := t.s₀
--   | (succ i) := t.next (τ i) (run i)

end target

end unitb

section

parameters {lbl lbl₀ lbl₁ : Type}

open has_mem scheduling.unitb temporal

structure fair (t : target_mch lbl) (τ : stream t.σ) : Prop :=
  (init : τ 0 = t.s₀)
  (valid : τ ⊨ ◻ (∃∃ l, •(↑l ∊ t.req) ⋀ ⟦ t.action l ⟧))
  (fair : ∀ l, τ ⊨ ◻◇•(↑l ∊ t.req) ⟶ ◻◇(•(↑l ∊ t.req) ⋀ ⟦ t.action l ⟧))
  -- (evts : stream lbl)
  -- (run_evts_eq_τ : run t evts = τ)

class inductive sched (l : Type u)
  | fin : finite l → sched
  | inf : infinite l → sched

instance fin_sched [pos_finite lbl] : sched lbl :=
sched.fin (by apply_instance)

instance inf_sched [infinite lbl] : sched lbl :=
sched.inf (by apply_instance)

instance sched_option : ∀ [sched lbl], sched (option lbl)
  | (sched.inf inf) := sched.inf (by apply_instance)
  | (sched.fin fin) := sched.fin (by apply_instance)

instance sched_sum : ∀ [sched lbl₀] [sched lbl₁], sched (lbl₀ ⊕ lbl₁)
  | (sched.fin fin) (sched.fin fin') := sched.fin (by apply_instance)
  | (sched.inf inf) (sched.fin fin') := sched.inf (by apply_instance)
  | (sched.fin fin) (sched.inf inf') := sched.inf (by apply_instance)
  | (sched.inf inf) (sched.inf inf') := sched.inf (by apply_instance)

def is_finite (l : Type u) : ∀ [sched l], Prop
  | (sched.fin x) := true
  | (sched.inf x) := false

def is_infinite (l : Type u) : ∀ [sched l], Prop
  | (sched.fin x) := false
  | (sched.inf x) := true

def is_empty (l : Type u) : ∀ [sched l], Prop
  | (sched.fin fn) := @finite.count l fn = 0
  | (sched.inf x)  := false

lemma is_empty_elim {α : Sort v} {l : Type u} (x : l) [sched l]
: is_empty l → α :=
begin
  intros H,
  cases _inst_1 with Hinst ;
  unfold is_empty at H,
  { have y := Hinst.to_nat.f x,
    rw H at y,
    apply y.elim0 },
  { cases H },
end

local attribute [instance] classical.prop_decidable

open bijection

def index_of {t : Type u} : ∀ [sched t], t → ℕ
  | (sched.inf inst) x := inst.to_nat.f x
  | (sched.fin inst) x := (inst.to_nat.f x).val

lemma injective_index_of {t : Type u} [sched t]
: injective (@index_of t _) :=
begin
  cases _inst_1
  ; intros i j
  ; unfold index_of,
  case sched.fin ifin
  { intros H,
    have H' := fin.eq_of_veq H,
    apply bijection.f_injective (finite.to_nat t) H', },
  case sched.inf iinf
  { apply bijection.f_injective },
end

def from_index {t : Type u} [inst : sched t] (Hinf : is_infinite t) (n : ℕ) : t :=
have infinite t, by { cases inst, cases Hinf, apply a },
(@infinite.to_nat t this).g n

lemma injective_from_index {t : Type u} [sched t]
  (Hinf : is_infinite t)
: injective (from_index Hinf) :=
by apply bijection.g_injective

section d

parameters {t : Type u} {f : t → Type v}
variable [sched t]
variable [∀ i, sched (f i)]
variable H : ∃ (i : t), is_infinite (f i)

def d' : (Σ (i : t), f i) → ℕ × ℕ
  | ⟨x,y⟩ := (index_of x,index_of y)

def d : (Σ (i : t), f i) → ℕ :=
bij.prod.g ∘ d'

lemma injective_d
: injective d :=
begin
  unfold d,
  apply @injective_comp _ _ _ (bij.prod).f d',
  { apply bijection.f_injective bij.prod },
  { intros i j,
    cases i with i₀ i₁,
    cases j with j₀ j₁,
    unfold d',
    intros H,
    injection H with H₀ H₁,
    have Hij : i₀ = j₀ := injective_index_of H₀,
    subst j₀,
    rw injective_index_of H₁, }
end

noncomputable def b (x : ℕ) : (Σ (i : t), f i) :=
⟨classical.some H,from_index (classical.some_spec H) x⟩

lemma injective_b
: injective (b H) :=
begin
  intros i j,
  unfold b,
  intros H,
  injection H with H₀ H₁,
  have H₂ := eq_of_heq H₁, clear H₁,
  apply bijection.g_injective _ H₂,
end

end d

section fg

parameters {t : Type u} {f : t → Type v}
parameter [sched t]
parameter [finite t]
parameter [Hs : ∀ i, sched (f i)]
parameter H : ¬ ∃ (i : t), is_infinite (f i)
include H
def m := finite.count t

set_option pp.implicit false

@[instance]
def H' (i : t) : finite (f i) :=
begin
  destruct (Hs i),
  case sched.fin
  { intros inst H', apply inst },
  case sched.inf
  { intros inst H',
    exfalso,
    apply H,
    existsi i, rw H',
    trivial }
end

def n : ℕ :=
array.maximum ( d_array.mk (λ i, (H' $ (finite.to_nat t).g i).count) )

lemma Hmn : ∀ i, (H' i).count ≤ n :=
begin
  intro i,
  unfold n,
  rw ← _inst_2.to_nat.f_inv i,
  change (d_array.mk $ λ i, (H' H ((finite.to_nat t).g i)).count).read _ ≤ _,
  apply array.le_maximum,
end

def fd' : (Σ (i : t), f i) → fin m × fin n
  | ⟨x,y⟩ := ((finite.to_nat t).f x,fin.nest' (Hmn x) $ (H' x).to_nat.f y)

def fd : (Σ (i : t), f i) → fin (m * n) :=
(@bij.prod.append.f m n) ∘ fd'

lemma injective_fd
: injective fd :=
begin
  unfold fd,
  apply injective_comp,
  { apply bijection.f_injective (bij.prod.append (m _) (n _)) },
  { intros i j,
    cases i with i₀ i₁, cases j with j₀ j₁,
    unfold fd', intros H,
    injection H with H₀ H₁,
    have H₂ := bijection.f_injective _ H₀,
    subst j₀,
    have H₃ := fin.nest'_injective _ H₁,
    have H₄ := bijection.f_injective _ H₃,
    subst j₁ },
end

end fg

section infinite_sigma

parameter {t : Type u}
parameter {f : t → Type v}
parameter [infinite t]
parameter [∀ i, sched (f i)]

def inf_to_nat' : (Σ (i : t), f i) → ℕ × ℕ
  | ⟨x,y⟩ := ((infinite.to_nat t).f x,index_of y)

def inf_to_nat : (Σ (i : t), f i) → ℕ :=
(bij.prod).f ∘ inf_to_nat'

lemma injective_inf_to_nat
: injective inf_to_nat :=
begin
  unfold inf_to_nat,
  apply injective_comp,
  { apply bijection.f_injective },
  { intros i j,
    cases i with i₀ i₁, cases j with j₀ j₁,
    unfold inf_to_nat',
    intros H,
    injection H with H₀ H₁,
    have H₂ := bijection.f_injective _ H₀,
    subst j₀,
    rw injective_index_of H₁, },
end

parameter H₀ : ¬ (∃ i, ∀ j : ℕ, i ≤ j → is_empty (f $ (infinite.to_nat t).g j))
include H₀

lemma H₁ (i : ℕ)
: ∃ j : ℕ, i ≤ j ∧ ¬ is_empty (f $ (infinite.to_nat t).g j) :=
begin
  simp [not_exists_iff_forall_not,not_forall_iff_exists_not,not_imp_iff_and_not] at H₀,
  apply exists_imp_exists _ (H₀ i),
  intros j H, apply H
end

noncomputable def inf_from_nat : ℕ → (Σ (i : t), f i) :=
begin
  have H₁ := H₁ H₀, clear H₀,
  let s := solutions H₁,
  intros i,
  let j := (infinite.to_nat t).g (s i),
  existsi j,
  destruct _inst_2 j ; intros _inst_3 Hinst,
  { apply _inst_3.to_nat.g,
    existsi 0,
    apply lt_of_le_of_ne,
    apply zero_le,
    have H := solutions_spec H₁ i,
    rw Hinst at H, unfold is_empty at H,
    rw eq_comm at H, apply H },
  { apply _inst_3.to_nat.g 0 },
end

lemma injective_inf_from_nat
: injective inf_from_nat :=
begin
  unfold inf_from_nat, simp,
  intros i j H,
  injection H with H₀ H₁,
  have H₂ := bijection.g_injective _ H₀,
  apply solutions_injective _ H₂,
end

end infinite_sigma

section inf_embed

parameters {t : Type u} {f : t → Type v}
parameters [infinite t] [∀ l, sched (f l)]
parameters h₀ : (∃ i, ∀ j : ℕ, i ≤ j → is_empty (f $ (infinite.to_nat t).g j))
parameters h₁ : ∀ [finite { i // nonempty (f i)}], sched (Σ i : { i // nonempty (f i)}, f i.1)
private noncomputable def n := classical.some h₀

noncomputable def embedded_F : { i // nonempty (f i)} → fin n
  | ⟨x,Hx⟩ :=
begin
  existsi (infinite.to_nat t).f x,
  apply classical.by_contradiction,
  intros h₁,
  have H' := classical.some_spec h₀ _ (le_of_not_gt h₁),
  rw bijection.f_inv at H',
  cases Hx with i,
  apply is_empty_elim i H'
end

def b_f : (Σ i, f i) → (Σ i : {i // nonempty (f i)}, f i.val)
  | ⟨x,Hx⟩ := ⟨⟨x,nonempty.intro Hx⟩,Hx⟩

def b_g : (Σ i : {i // nonempty (f i)}, f i.val) → (Σ i, f i)
  | ⟨⟨x,_⟩,Hx⟩ := ⟨x,Hx⟩

parameter (f)

def bij_ne : bijection (Σ i, f i) (Σ i : {i // nonempty (f i)}, f (i.val)) :=
bijection.mk b_f b_g
(by { intro x, cases x, refl })
(by { intro x, cases x with x, cases x, refl })

parameter {f}

include h₀ h₁

noncomputable def embedded : sched (Σ i, f i) :=
begin
  let n := classical.some h₀,
  have h : finite { i // nonempty (f i)},
  { apply @finite_of_injective _ n (embedded_F h₀),
    intros i j,
    cases i with i₀ i₁, cases j with j₀ j₁,
    unfold embedded_F, intros H,
    injection H with H₀,
    have H₁ := bijection.f_injective _ H₀,
    subst j₀ },
  have h₂ := @h₁ h,
  have h₀ :=  (bij_ne f),
  cases h₂ with Hfin Hinf,
  { apply sched.fin,
    have h₁ := Hfin.to_nat,
    apply finite.mk Hfin.count (h₁ ∘ h₀), },
  { apply sched.inf,
    have h₁ := Hinf.to_nat,
    apply infinite.mk (h₁ ∘ h₀), },
end

end inf_embed

noncomputable instance sched_sigma_of_finite {t : Type u} {f : t → Type v}
  [∀ l, sched (f l)] [finite t]
: sched (Σ i, f i) := have sched t, by { apply sched.fin, apply_instance },
                      if h : (∃ i, is_infinite (f i))
                      then sched.inf (infinite_of_injective
                                      (@injective_d _ _ this _)
                                      (@injective_b _ _ this _ h) )
                      else sched.fin (finite_of_injective
                                      (@injective_fd _ _ this _ _inst_1 h) )

noncomputable instance sched_sigma {t : Type u} {f : t → Type v} [∀ l, sched (f l)]
: ∀ [sched t], sched (Σ i, f i)
  | (sched.fin _) := by { apply scheduling.sched_sigma_of_finite }
  | (sched.inf x) := if h : (∃ i, ∀ j : ℕ, i ≤ j → is_empty (f $ (@infinite.to_nat t x).g j))
                     then @embedded _ _ x _ h (@scheduling.sched_sigma_of_finite _ _ _)
                     else sched.inf (infinite_of_injective
                                      (@injective_inf_to_nat _ _ x _)
                                      (@injective_inf_from_nat _ _ x _ h))

end

namespace unitb

section

open unitb has_mem temporal

parameters {lbl : Type}
parameters {s : Type u}
parameters [system_sem s]
parameters {α : Type}
parameters r : var α (set lbl)
parameters r_nemp : ∀ x, r.apply x ≠ ∅
parameters s₀ : α
parameters next : ∀ l s, r.apply s l → α
parameters {F : s}
parameters ch : var (unitb.state s) lbl
parameters object : var (unitb.state s) α
def req : var _ _  := r ∘' object
parameters P : ∀ l : lbl, (↑l ∊ req)  >~>  (ch ≃ l)  in  F
parameters INIT : system.init F (object ≃ s₀)
parameters STEP : unitb.co' F (λ σ σ', ∃ P, object.apply σ' = next (ch.apply σ) (object.apply σ) P)
parameters INV : ∀ σ, σ ⊨ ch ∊ req

def t := target_mch.mk _ s₀ r r_nemp next
open unitb.system_sem  unitb.system target_mch
include ch F INIT STEP INV P
lemma scheduling'
: ∃ τ : stream α, fair t τ :=
begin
  apply exists_imp_exists' (map object.apply) _ (system_sem.inhabited F),
  intros τ sem,
  apply fair.mk,
  { rw ← eq_judgement at sem,
    have h := system_sem.init_sem sem INIT,
    simp [temporal.init,comp] at h,
    unfold map nth, rw ← h, refl },
  { simp,
    begin [temporal]
      have Hsaf := system_sem.safety F Γ,
      replace Hsaf := Hsaf sem,
      clear sem,
      henceforth,
      existsi ch,
      split,
      explicit
      { simp [h], have := INV,
        simp [req] at this, apply this },
      { replace STEP := co_sem' Hsaf STEP,
        henceforth at STEP,
        revert STEP h,
        action
        { simp [on_fun,target_mch.action,comp],
          introv H₀ H₁, subst ch₀,
          split, rw H₁, refl }, }
    end, },
  { intros l h, simp at h ⊢,
    begin [temporal]
      replace P := often_imp_often_sem' (P l) sem,
      simp [req] at P h, replace  P := P h,
      have Hsaf := (system_sem.safety F Γ sem), clear sem,
      henceforth at P ⊢, eventually P ⊢,
      split, revert P,
      action { simp [req] at ⊢ INV,
               intros, subst l,
               apply INV, },
      { have H := co_sem' Hsaf STEP,
        henceforth at H,
        revert H P,
        action
        { simp [req] at ⊢ INV,
          intros, simp [target_mch.action,on_fun],
          subst l,
          existsi (INV σ), rw [a_1], refl, } }
      end },
end

end

open unitb has_mem

variable {lbl : Type}

variable t : target_mch lbl

def t_req : var t.σ (set lbl) := t.req

structure scheduler :=
 (s : Type u)
 (sem : system_sem s)
 (F : s)
 (ch : var (unitb.state s) lbl)
 (object : var (unitb.state s) t.σ)
 (INIT : system.init F (object ≃ t.s₀))
 (STEP : unitb.co' F (λ σ σ', ∃ P, object.apply σ' = t.next (ch.apply σ) (object.apply σ) P))
 (INV  : ∀ σ, σ ⊨ ch ∊ t.req ∘' object)
 (PROG : ∀ l : lbl, ↑l ∊ t_req t ∘' object  >~>  ch ≃ l in F)

instance (s : scheduler t) : system_sem (s.s) := s.sem

lemma scheduling
  (sch : scheduler t)
: ∃ τ : stream t.σ, fair t τ :=
begin
  have H : t = scheduling.unitb.t t.req t.req_nemp t.s₀ t.next,
  { cases t, refl },
  rw H,
  apply @scheduling' lbl sch.s sch.sem t.σ _ _ t.s₀ _ _
                     sch.ch sch.object sch.PROG sch.INIT sch.STEP sch.INV,
end
end unitb

end scheduling

-- TODO:
--   generalize finite and infinite so that all that each module only has to provide
--   a ranking system for events.