/-
Copyright 2021 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import data.equiv.list
import formal_ml.prod_measure
import formal_ml.finite_pi_measure
import formal_ml.probability_space

/-
  This file allows the construction of new probability spaces. This is useful
  in particular when you want to consider a hypothetical scenario to relate back
  to a real one.

  For a family of random variables X indexed over β, there are a variety of operations.
  1. pi.random_variable: We can create a new family of random variables Y, where for all (b:β),
     X b and Y b are identical, and for any (b b':β), Y b and Y b' are independent.
     A new probability measure is created for Y.
  2. pi.random_variable_combine: create a new single random variable whose domain is
     a function. Note: this does not create a new probability measure.

  There are also some functions which work with a single random variable.
  1. pi.rv: create a random variable that maps from a product probability measure to
     a outcome space of a single measure in the product.

-/

noncomputable def prod.measure_space {α β:Type*} (Mα:measure_theory.measure_space α) (Mβ:measure_theory.measure_space β):measure_theory.measure_space (α × β) :=
  @measure_theory.measure_space.mk (α × β) (@prod.measurable_space α β Mα.to_measurable_space Mβ.to_measurable_space) (prod.measure Mα.volume Mβ.volume)

lemma prod.measure_space.apply (α β:Type*) (Mα:measure_theory.measure_space α) (Mβ:measure_theory.measure_space β) (S:set (α × β)):
  @measure_theory.measure_space.volume _ (prod.measure_space Mα Mβ) S =
  (prod.measure Mα.volume Mβ.volume) S := rfl

lemma prod.measure_space.apply_prod (α β:Type*) (Mα:measure_theory.measure_space α) (Mβ:measure_theory.measure_space β) (A:set α) (B:set β):measurable_set A →
  measurable_set B →
  @measure_theory.measure_space.volume _ (prod.measure_space Mα Mβ) (A.prod B) =
  (@measure_theory.measure_space.volume _ Mα (A)) *
  (@measure_theory.measure_space.volume _ Mβ (B)) := begin
  intros h1 h2,
  rw prod.measure_space.apply,
  rw prod.measure.apply_prod,
  apply h1,
  apply h2,
end
/- This is best understood through the lemma prod.probability_space.apply_prod -/
noncomputable def probability_space.prod {α β:Type*} (Pα:probability_space α) (Pβ:probability_space β):probability_space (α × β) :=
@probability_space.mk (α × β)
  (prod.measure_space Pα.to_measure_space Pβ.to_measure_space)
  begin
  simp,
  have A1:(@set.univ α).prod (@set.univ β) = (@set.univ (α × β)),
  { simp },
  rw ← A1,
  rw prod.measure_space.apply_prod,
  repeat { simp },
end

def event.prod {α β:Type*} {Pα:probability_space α} {Pβ:probability_space β}
  (A:event Pα) (B:event Pβ):
  event (Pα.prod Pβ) := measurable_setB.prod A B

lemma event.prod_def {α β:Type*} {Pα:probability_space α} {Pβ:probability_space β}
  (A:event Pα) (B:event Pβ):A.prod B = measurable_setB.prod A B := rfl

/- This proves that events are independent in the resulting probability space. -/
lemma prod.probability_space.apply_prod (α β:Type*) (Pα:probability_space α) (Pβ:probability_space β) (A:event Pα) (B:event Pβ):
  Pr[A.prod B] = Pr[A] * Pr[B] := begin
  rw ← ennreal.coe_eq_coe,
  rw ennreal.coe_mul,
  rw event_prob_def,
  rw event_prob_def,
  rw event_prob_def,
  simp,
  apply prod.measure_space.apply_prod,
  apply A.property,
  apply B.property,
end

/- Measurable functions from a product space to each multiplicand. -/

def rv_prod_fst {α β:Type*} (Pα:probability_space α) (Pβ:probability_space β):
(Pα.prod Pβ) →ᵣ Pα.to_measurable_space := mf_fst

def rv_prod_snd {α β:Type*} (Pα:probability_space α) (Pβ:probability_space β):
(Pα.prod Pβ) →ᵣ Pβ.to_measurable_space := mf_snd

/- Now that we have random variables mapping one probability space to another,
   we need to compose random variables. -/
def rv_compose_rv {α β γ:Type*} {Pα:probability_space α} {Pβ:probability_space β}
{Mγ:measurable_space γ} (X:Pβ →ᵣ Mγ) (Y:Pα →ᵣ Pβ.to_measurable_space):Pα →ᵣ Mγ :=
compose_measurable_fun X Y

noncomputable def random_variable.on_fst {α β γ:Type*} {Pα:probability_space α} {Mγ:measurable_space γ}
(X:Pα →ᵣ Mγ) (Pβ:probability_space β) := rv_compose_rv X (rv_prod_fst Pα Pβ)

noncomputable def random_variable.on_snd {α β γ:Type*} {Pβ:probability_space β} {Mγ:measurable_space γ}
(X:Pβ →ᵣ Mγ) (Pα:probability_space α) := rv_compose_rv X (rv_prod_snd Pα Pβ)

lemma Pr_rv_prod_fst_eq {α β:Type*} {Pα:probability_space α}
  {Pβ:probability_space β} (A:event Pα):

  Pr[(rv_prod_fst Pα Pβ) ∈ᵣ A] = Pr[A] :=
begin
  have h_event_rw:(rv_prod_fst Pα Pβ ∈ᵣ A) =
           A.prod event_univ,
  { apply event.eq, simp [rv_prod_fst, event_univ, event.prod], ext ω, simp,
    split; intros h_1; simp [h_1], },
  rw h_event_rw,
  rw prod.probability_space.apply_prod,
  simp [rv_prod_fst, mf_fst],
end

lemma Pr_rv_prod_snd_eq {α β:Type*} {Pα:probability_space α}
  {Pβ:probability_space β} (B:event Pβ):
  Pr[(rv_prod_snd Pα Pβ) ∈ᵣ B] = Pr[B] :=
begin
  have h_event_rw:(rv_prod_snd Pα Pβ ∈ᵣ B) =
           event_univ.prod B,
  { apply event.eq, simp [rv_prod_snd, event_univ, event.prod], ext ω, simp,
    split; intros h_1; simp [h_1], },
  rw h_event_rw,
  rw prod.probability_space.apply_prod,
  simp [rv_prod_fst, mf_fst],
end

lemma ind_rv_prod_fst_rv_prod_snd {α β:Type*} {Pα:probability_space α}
  {Pβ:probability_space β}:
  random_variable_independent_pair (rv_prod_fst Pα Pβ) (rv_prod_snd Pα Pβ) :=
begin
  intros A B,
  let A':event Pα := A,
  let B':event Pβ := B,
  begin
    unfold independent_event_pair,
    have h_event_rw:(rv_prod_fst Pα Pβ ∈ᵣ A∧rv_prod_snd Pα Pβ ∈ᵣ B) =
             A'.prod B',
    { apply event.eq, simp [rv_prod_fst, rv_prod_snd, A', B', event.prod], ext ω, simp },
    rw h_event_rw,
    rw Pr_rv_prod_fst_eq,
    rw Pr_rv_prod_snd_eq,
    rw prod.probability_space.apply_prod,
  end
end

lemma random_variable.on_fst_on_snd_ind {α β γ κ:Type*} {Pα:probability_space α}
  {Pβ:probability_space β} {Mγ:measurable_space γ} {Mκ:measurable_space κ}
{X:Pα →ᵣ Mγ} {Y:Pβ →ᵣ Mκ}:
  random_variable_independent_pair (X.on_fst Pβ) (Y.on_snd Pα) :=
begin
  simp [random_variable.on_fst, random_variable.on_snd, rv_compose_rv],
  apply compose_independent_pair_left,
  apply compose_independent_pair_right,
  apply ind_rv_prod_fst_rv_prod_snd,
end

/- Creates a pair of random variables that are independent and defined over the
   same probability space that are identical to the given random variables X and Y. -/
noncomputable def random_variable.pair_ind {α β γ κ:Type*} {Pα:probability_space α}
  {Pβ:probability_space β} {Mγ:measurable_space γ} {Mκ:measurable_space κ}
(X:Pα →ᵣ Mγ) (Y:Pβ →ᵣ Mκ):prod (Pα.prod Pβ →ᵣ Mγ) (Pα.prod Pβ →ᵣ Mκ) :=
   prod.mk (X.on_fst Pβ) (Y.on_snd Pα)

noncomputable def pi.measure_space {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} (M:∀ a, measure_theory.measure_space (β a)):
  measure_theory.measure_space (Π a, β a) :=
  @measure_theory.measure_space.mk (Π a, β a) (@measurable_space.pi α β (λ a, (M a).to_measurable_space)) (pi.measure (λ a, (M a).volume))

lemma pi.measure_space.apply {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} (M:∀ a, measure_theory.measure_space (β a)) (S:set (Π a, β a)):
  @measure_theory.measure_space.volume _ (pi.measure_space M) S =
  (pi.measure  (λ a, (M a).volume)) S := rfl

lemma pi.measure_space.apply_prod {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} (M:∀ a, measure_theory.measure_space (β a)) {S:Π a, set (β a)}:
  (∀ a, measurable_set (S a)) →
  @measure_theory.measure_space.volume _ (pi.measure_space M) (set.pi set.univ S) =
  finset.univ.prod (λ a, @measure_theory.measure_space.volume _ (M a) (S a)) := begin
  intros h1,
  rw pi.measure_space.apply,
  rw pi.measure.apply_prod,
  apply h1,
end

lemma pi.measure_space.Inf_sum2 {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} (M:Π (a:α), measure_theory.measure_space (β a)) {P:set (Π (a:α), β a)}:
  measurable_set P →
  @measure_theory.measure_space.volume _ (pi.measure_space M) P =

  (⨅ (f:ℕ → (Π (a:α), set (β a))) (h₁:∀ n m, measurable_set (f n m))
  (h₃:P ⊆ ⋃ (n:ℕ), set.pi set.univ (f n)),
  ∑' (n:ℕ), finset.univ.prod (λ (m:α),
  @measure_theory.measure_space.volume _ (M m) (f n m))) := begin
  intros h1,
  rw pi.measure_space.apply,
  rw pi.measure_apply,
  rw pi.outer_measure.Inf_sum2,
  apply h1,
end

noncomputable def pi.probability_space {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*}
   (P:Π a, probability_space (β a)):probability_space (Π a, β a) :=
  @probability_space.mk (Π a, β a)
  (pi.measure_space (λ a, (P a).to_measure_space))
  begin
  simp,
  have A1:set.pi set.univ (λ a, @set.univ (β a)) = (@set.univ (Π a, β a)),
  { ext1 ω, split;intros A1_1; simp at A1_1, simp, },
  rw ← A1,
  rw pi.measure_space.apply_prod,
  simp,
  simp,
end

def set.pi_event {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  {P:Π a, probability_space (β a)}
  (T:set α) (E:Π a, event (P a)):event (pi.probability_space P) := T.pi_measurable E

lemma set.pi_event_univ {α:Type*} [F:fintype α] [N:nonempty α]
{β:α → Type*} {P:Π a, probability_space (β a)}
(S:Π a, event (P a)) (T:set α) [decidable_pred T]:set.pi_event T S = set.pi_event
(@set.univ α) (λ (a:α), if (a∈ T) then (S a) else (@event_univ (β a) (P a))) :=
begin
  apply set.pi_measurable_univ,
end

lemma pi.probability_space.apply_prod {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  {P:Π a, probability_space (β a)}
  (E:Π a, event (P a)):Pr[set.pi_event set.univ E] = finset.univ.prod (λ a, Pr[E a]) := begin
  rw ← ennreal.coe_eq_coe,
  rw ennreal.coe_finset_prod,
  simp [event_prob_def],
  apply pi.measure_space.apply_prod,
  intros a,
  apply (E a).property,
end

lemma pi.probability_space.apply_prod' {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  {P:Π a, probability_space (β a)} {T:finset α}
  (E:Π a, event (P a)):Pr[set.pi_event (↑T) E] = T.prod (λ a, Pr[E a]) := begin
  classical,
  --have A1:=decidable.pred T,
  rw set.pi_event_univ,
  rw pi.probability_space.apply_prod,
  --rw @finset.prod_congr _ _ finset.univ finset.univ,

  have A2:finset.univ.prod (λ (a:α), if (a ∈ @coe (finset α) (set α) _ T) then Pr[E a] else 1) =
          T.prod (λ (a:α), if (a ∈ @coe (finset α) (set α) _ T) then Pr[E a] else 1),
  { rw ← finset.prod_subset,
    { rw finset.subset_iff, intros x h_1, simp },
    intros x h_unused h_x_notin_T,
    rw if_neg,
    intros contra,
    apply h_x_notin_T,
    rw ← finset.mem_coe,
    apply contra },
  have A3:T.prod (λ (a:α), if (a ∈ @coe (finset α) (set α) _ T) then Pr[E a] else 1) =
          T.prod (λ (a:α), Pr[E a]),
  { apply finset.prod_congr,
    refl,
    intros x A3_1,
    rw if_pos,
    simp,
    apply A3_1 },
  rw ← A3,
  rw ← A2,
  apply finset.prod_congr,
  { refl },
  { intros x A4,
    cases classical.em (x ∈ @coe (finset α) (set α) _ T) with A5 A5,
    rw if_pos A5,
    rw if_pos A5,
    rw if_neg A5,
    rw if_neg A5,
    simp },
end

def mf_pi {α:Type*} {β:α → Type*} (M:Π a, measurable_space (β a))
   (a:α):measurable_fun (@measurable_space.pi α β M) (M a) := @subtype.mk
  ((Π a, β a) → (β a))
  measurable
  (λ (d:Π a, β a), d a)
  begin
    apply measurable_pi_apply,
  end

def pi.rv {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  (P:Π a, probability_space (β a)) (a:α):(pi.probability_space P) →ᵣ (P a).to_measurable_space := mf_pi (λ a, (P a).to_measurable_space) a

noncomputable def pi.random_variable_proj {α:Type*} {β:α → Type*} {γ:Type*} [F:fintype α] [N:nonempty α]
  (P:Π a, probability_space (β a)) (a:α) {M:measurable_space γ} (X:(P a) →ᵣ (M)):(pi.probability_space P) →ᵣ M := X ∘r (pi.rv P a)

/- Unify a collection of random variables to be independent random variables under a single probability measure. -/
noncomputable def pi.random_variable {α:Type*} {β:α → Type*} {γ:α → Type*} [F:fintype α] [N:nonempty α]
  {P:Π a, probability_space (β a)} {M:Π a, measurable_space (γ a)} (X:Π a, (P a) →ᵣ (M a)):Π a, (pi.probability_space P) →ᵣ (M a) := (λ a, pi.random_variable_proj P a (X a))

lemma pi.rv_eq {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  (P:Π a, probability_space (β a)) (a:α) (E:event (P a)):
  Pr[(pi.rv P a)∈ᵣ E] = Pr[E] := begin
  classical,
  have A1:∀ (a':α), ∃ (E':event (P a')), Π (h:a=a'),E = @cast (event (P a'))
    (event (P a)) begin rw h end E',
  { intros a', cases classical.em (a=a') with A1_1 A1_1,
    { subst a', apply exists.intro E, intros h, refl },
    { apply exists.intro (@event_univ (β a') (P a')),
      intros h, exfalso, apply A1_1, apply h } },
  have A2 := classical.axiom_of_choice A1,
  cases A2 with E' A2,
  have A4:a=a := rfl,
  have A5 := A2 a A4,
  have A3:(set.pi_event (@coe (finset α) (set α) _ {a}) E') = ((pi.rv P a)∈ᵣ E),
  { apply event.eq,
    ext ω,
    simp [set.pi_event,pi.rv,set.pi_measurable,mf_pi],
    subst E,
    refl,
     },
  rw ← A3,
  rw pi.probability_space.apply_prod',
  simp,
  subst E,
  refl,
end

lemma pi.random_variable_proj_identical {α:Type*} {β:α → Type*} {γ:Type*} [F:fintype α] [N:nonempty α]
  (P:Π a, probability_space (β a)) (a:α) {M:measurable_space γ} (X:(P a) →ᵣ (M)):
  random_variable_identical (pi.random_variable_proj P a X) X :=
begin
  intros S,
  simp [pi.random_variable_proj],
  rw rv_compose_measurable_setB,
  apply pi.rv_eq,
end

--(pi.probability_space P) →ᵣ M := X ∘r (pi.rv P a)

lemma pi.rv_independent {α:Type*} {β:α → Type*} [F:fintype α] [N:nonempty α]
  (P:Π a, probability_space (β a)):
  random_variable_independent (pi.rv P) :=
begin
  classical,
  intros S,
  intros T,
  have h1:(∀ᵣ (s : α) in T,(λ (b : α), @pi.rv α (λ (a : α), β a) F N P b ∈ᵣ S b) s) =
          set.pi_event (↑T) S,
  { apply event.eq,
    ext1 ω,
    simp [set.pi_event, set.pi_measurable, pi.rv, mf_pi] },
  rw h1,
  rw pi.probability_space.apply_prod',
  apply finset.prod_congr,
  refl,
  intros x A1,
  rw pi.rv_eq,
end

lemma pi.random_variable_independent {α:Type*} {β:α → Type*} {γ:α → Type*} [F:fintype α]
  [N:nonempty α] (P:Π a, probability_space (β a)) {M:Π a, measurable_space (γ a)}
  (X:Π a, (P a) →ᵣ (M a)):
  random_variable_independent (pi.random_variable X) :=
begin
  simp [pi.random_variable, pi.random_variable_proj, rv_compose_rv],
  apply compose_independent',
  apply pi.rv_independent,
end

noncomputable def pi.random_variable_IID {β γ:Type*} {P:probability_space β}
  {M:measurable_space γ} (X:P →ᵣ M) (m:nat):(fin m.succ) →
  (pi.probability_space (λ (m:fin m.succ), P) →ᵣ M)

 :=
@pi.random_variable (fin m.succ) (λ (a:fin m.succ), β)
  (λ (a:fin m.succ), γ) _  _
  (λ a, P) (λ a, M) (λ a, X)

lemma pi.random_variable_IID_independent {β γ:Type*} {P:probability_space β}
  {M:measurable_space γ} (X:P →ᵣ M) (m:nat):
  random_variable_independent (pi.random_variable_IID X m) := begin
  simp [random_variable_independent],
  apply pi.random_variable_independent,
end

lemma pi.random_variable_IID_identical {β γ:Type*} {P:probability_space β}
  {M:measurable_space γ} (X:P →ᵣ M) (m:nat) (i:fin m.succ):
  random_variable_identical (pi.random_variable_IID X m i)
  X := begin
  simp [pi.random_variable_IID, pi.random_variable],
  apply pi.random_variable_proj_identical,
end

lemma pi.random_variable_IID_identical' {β γ:Type*} {P:probability_space β}
  {M:measurable_space γ} (X:P →ᵣ M) (m:nat) (i j:fin m.succ):
  random_variable_identical (pi.random_variable_IID X m i)
  (pi.random_variable_IID X m j) := begin
  apply random_variable_identical.trans,
  apply pi.random_variable_IID_identical,
  apply random_variable_identical.symm,
  apply pi.random_variable_IID_identical,
end

lemma pi.random_variable_IID_IID {β γ:Type*} {P:probability_space β}
  {M:measurable_space γ} (X:P →ᵣ M) (m:nat):
  random_variables_IID (pi.random_variable_IID X m) := begin
  simp [random_variables_IID],
  split,
  apply pi.random_variable_IID_independent,
  intros i j,
  apply pi.random_variable_IID_identical',
end

/- Pair a random variable with a collection of random variables.
   Since the collection of random variables already share a probability
   measure, we make sure that the resulting random variables
   share the product measure of Pα and Pβ. -/
noncomputable def random_variable.pair_collection {α β γ κ δ:Type*}
  {Pα:probability_space α}
  {Pβ:probability_space β} {Mγ:measurable_space γ} {Mκ:measurable_space κ}
(X:δ → Pα →ᵣ Mγ) (Y:Pβ →ᵣ Mκ):prod (δ → Pα.prod Pβ →ᵣ Mγ) (Pα.prod Pβ →ᵣ Mκ) :=
   prod.mk (λ (d:δ), (X d).on_fst Pβ) (Y.on_snd Pα)


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.reflexive
import Mathlib.category_theory.limits.preserves.limits
import Mathlib.category_theory.monad.limits
import Mathlib.category_theory.monad.coequalizer
import Mathlib.PostPort

universes v₁ u₁ u₂

namespace Mathlib

/-!
# Monadicity theorems

We prove monadicity theorems which can establish a given functor is monadic. In particular, we
show three versions of Beck's monadicity theorem, and the reflexive (crude) monadicity theorem:

`G` is a monadic right adjoint if it has a right adjoint, and:

* `D` has, `G` preserves and reflects `G`-split coequalizers, see
  `category_theory.monad.monadic_of_has_preserves_reflects_G_split_coequalizers`
* `G` creates `G`-split coequalizers, see
  `category_theory.monad.monadic_of_creates_G_split_coequalizers`
  (The converse of this is also shown, see
   `category_theory.monad.creates_G_split_coequalizers_of_monadic`)
* `D` has and `G` preserves `G`-split coequalizers, and `G` reflects isomorphisms, see
  `category_theory.monad.monadic_of_has_preserves_G_split_coequalizers_of_reflects_isomorphisms`
* `D` has and `G` preserves reflexive coequalizers, and `G` reflects isomorphisms, see
  `category_theory.monad.monadic_of_has_preserves_reflexive_coequalizers_of_reflects_isomorphisms`

## Tags

Beck, monadicity, descent

## TODO

Dualise to show comonadicity theorems.
-/

namespace category_theory

namespace monad

-- Hide the implementation details in this namespace.

namespace monadicity_internal

-- We use these parameters and notations to simplify the statements of internal constructions

-- here.

/--
The "main pair" for an algebra `(A, α)` is the pair of morphisms `(F α, ε_FA)`. It is always a
reflexive pair, and will be used to construct the left adjoint to the comparison functor and show it
is an equivalence.
-/
protected instance main_pair_reflexive {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) : is_reflexive_pair (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A))) := sorry

/--
The "main pair" for an algebra `(A, α)` is the pair of morphisms `(F α, ε_FA)`. It is always a
`G`-split pair, and will be used to construct the left adjoint to the comparison functor and show it
is an equivalence.
-/
protected instance main_pair_G_split {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) : functor.is_split_pair G (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A))) :=
  has_split_coequalizer.mk
    (Exists.intro (algebra.A A) (Exists.intro (algebra.a A) (Nonempty.intro (beck_split_coequalizer A))))

/-- The object function for the left adjoint to the comparison functor. -/
def comparison_left_adjoint_obj {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) [limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] : D :=
  limits.coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))

/--
We have a bijection of homsets which will be used to construct the left adjoint to the comparison
functor.
-/
def comparison_left_adjoint_hom_equiv {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) (B : D) [limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] : (comparison_left_adjoint_obj A ⟶ B) ≃ (A ⟶ functor.obj (comparison G) B) :=
  equiv.trans
    (equiv.trans
      (limits.cofork.is_colimit.hom_iso
        (limits.colimit.is_colimit
          (limits.parallel_pair (functor.map (left_adjoint G) (algebra.a A))
            (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
              (functor.obj (left_adjoint G) (algebra.A A)))))
        B)
      (equiv.subtype_congr (adjunction.hom_equiv (adjunction.of_right_adjoint G) (algebra.A A) B) sorry))
    (equiv.mk
      (fun
        (g :
        Subtype
          fun (g : algebra.A A ⟶ functor.obj G B) =>
            functor.map G (functor.map (left_adjoint G) g) ≫
                functor.map G (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) B) =
              algebra.a A ≫ g) =>
        algebra.hom.mk ↑g)
      (fun (f : A ⟶ functor.obj (comparison G) B) => { val := algebra.hom.f f, property := sorry }) sorry sorry)

/--
Construct the adjunction to the comparison functor.
-/
def left_adjoint_comparison {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] [∀ (A : algebra (left_adjoint G ⋙ G)),
  limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] : algebra (left_adjoint G ⋙ G) ⥤ D :=
  adjunction.left_adjoint_of_equiv
    (fun (A : algebra (left_adjoint G ⋙ G)) (B : D) => comparison_left_adjoint_hom_equiv A B) sorry

/--
Provided we have the appropriate coequalizers, we have an adjunction to the comparison functor.
-/
def comparison_adjunction {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] [∀ (A : algebra (left_adjoint G ⋙ G)),
  limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] : left_adjoint_comparison ⊣ comparison G :=
  adjunction.adjunction_of_equiv_left
    (fun (A : algebra (left_adjoint G ⋙ G)) (B : D) => comparison_left_adjoint_hom_equiv A B) sorry

theorem comparison_adjunction_unit_f_aux {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] [∀ (A : algebra (left_adjoint G ⋙ G)),
  limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] (A : algebra (left_adjoint G ⋙ G)) : algebra.hom.f (nat_trans.app (adjunction.unit comparison_adjunction) A) =
  coe_fn
    (adjunction.hom_equiv (adjunction.of_right_adjoint G) (algebra.A A)
      (limits.coequalizer (functor.map (left_adjoint G) (algebra.a A))
        (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
          (functor.obj (left_adjoint G) (algebra.A A)))))
    (limits.coequalizer.π (functor.map (left_adjoint G) (algebra.a A))
      (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))) := sorry

/--
This is a cofork which is helpful for establishing monadicity: the morphism from the Beck
coequalizer to this cofork is the unit for the adjunction on the comparison functor.
-/
@[simp] theorem unit_cofork_ι_app {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) [limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] (X : limits.walking_parallel_pair) : nat_trans.app (limits.cocone.ι (unit_cofork A)) X =
  limits.walking_parallel_pair.rec
    (functor.map G (functor.map (left_adjoint G) (algebra.a A)) ≫
      functor.map G
        (limits.coequalizer.π (functor.map (left_adjoint G) (algebra.a A))
          (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
            (functor.obj (left_adjoint G) (algebra.A A)))))
    (functor.map G
      (limits.coequalizer.π (functor.map (left_adjoint G) (algebra.a A))
        (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
          (functor.obj (left_adjoint G) (algebra.A A)))))
    X := sorry

theorem comparison_adjunction_unit_f {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] [∀ (A : algebra (left_adjoint G ⋙ G)),
  limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] (A : algebra (left_adjoint G ⋙ G)) : algebra.hom.f (nat_trans.app (adjunction.unit comparison_adjunction) A) =
  limits.is_colimit.desc (beck_coequalizer A) (unit_cofork A) := sorry

/--
The cofork which describes the counit of the adjunction: the morphism from the coequalizer of
this pair to this morphism is the counit.
-/
@[simp] theorem counit_cofork_ι_app {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (B : D) (X : limits.walking_parallel_pair) : nat_trans.app (limits.cocone.ι (counit_cofork B)) X =
  limits.walking_parallel_pair.rec
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
        (functor.obj (left_adjoint G) (functor.obj G B)) ≫
      nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) B)
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) B) X := sorry

/-- The unit cofork is a colimit provided `G` preserves it.  -/
def unit_colimit_of_preserves_coequalizer {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (A : algebra (left_adjoint G ⋙ G)) [limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
  (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] [limits.preserves_colimit
  (limits.parallel_pair (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A))))
  G] : limits.is_colimit (unit_cofork A) :=
  limits.is_colimit_of_has_coequalizer_of_preserves_colimit G (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))

/-- The counit cofork is a colimit provided `G` reflects it. -/
def counit_coequalizer_of_reflects_coequalizer {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] (B : D) [limits.reflects_colimit
  (limits.parallel_pair
    (functor.map (left_adjoint G) (functor.map G (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) B)))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
      (functor.obj (left_adjoint G) (functor.obj G B))))
  G] : limits.is_colimit (counit_cofork B) :=
  limits.is_colimit_of_is_colimit_cofork_map G (counit_cofork._proof_1 B)
    (beck_coequalizer (functor.obj (comparison G) B))

theorem comparison_adjunction_counit_app {C : Type u₁} {D : Type u₂} [category C] [category D] {G : D ⥤ C} [is_right_adjoint G] [∀ (A : algebra (left_adjoint G ⋙ G)),
  limits.has_coequalizer (functor.map (left_adjoint G) (algebra.a A))
    (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) (functor.obj (left_adjoint G) (algebra.A A)))] (B : D) : nat_trans.app (adjunction.counit comparison_adjunction) B =
  limits.colimit.desc
    (limits.parallel_pair
      (functor.map (left_adjoint G)
        (functor.map G (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G)) B)))
      (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint G))
        (functor.obj (left_adjoint G) (functor.obj G B))))
    (counit_cofork B) := sorry

end monadicity_internal

/--
If `G` is monadic, it creates colimits of `G`-split pairs. This is the "boring" direction of Beck's
monadicity theorem, the converse is given in `monadic_of_creates_G_split_coequalizers`.
-/
def creates_G_split_coequalizers_of_monadic {C : Type u₁} {D : Type u₂} [category C] [category D] (G : D ⥤ C) [monadic_right_adjoint G] {A : D} {B : D} (f : A ⟶ B) (g : A ⟶ B) [functor.is_split_pair G f g] : creates_colimit (limits.parallel_pair f g) G :=
  monadic_creates_colimit_of_preserves_colimit G (limits.parallel_pair f g)

/--
To show `G` is a monadic right adjoint, we can show it preserves and reflects `G`-split
coequalizers, and `C` has them.
-/
def monadic_of_has_preserves_reflects_G_split_coequalizers {C : Type u₁} {D : Type u₂} [category C] [category D] (G : D ⥤ C) [is_right_adjoint G] [∀ {A B : D} (f g : A ⟶ B) [_inst_5 : functor.is_split_pair G f g], limits.has_coequalizer f g] [{A B : D} →
  (f g : A ⟶ B) → [_inst_7 : functor.is_split_pair G f g] → limits.preserves_colimit (limits.parallel_pair f g) G] [{A B : D} →
  (f g : A ⟶ B) → [_inst_9 : functor.is_split_pair G f g] → limits.reflects_colimit (limits.parallel_pair f g) G] : monadic_right_adjoint G := sorry

/--
Beck's monadicity theorem. If `G` has a right adjoint and creates coequalizers of `G`-split pairs,
then it is monadic.
This is the converse of `creates_G_split_of_monadic`.
-/
def monadic_of_creates_G_split_coequalizers {C : Type u₁} {D : Type u₂} [category C] [category D] (G : D ⥤ C) [is_right_adjoint G] [{A B : D} → (f g : A ⟶ B) → [_inst_5 : functor.is_split_pair G f g] → creates_colimit (limits.parallel_pair f g) G] : monadic_right_adjoint G :=
  let _inst :
    ∀ {A B : D} (f g : A ⟶ B) [_inst_6 : functor.is_split_pair G f g],
      limits.has_colimit (limits.parallel_pair f g ⋙ G) :=
    sorry;
  monadic_of_has_preserves_reflects_G_split_coequalizers G

/--
An alternate version of Beck's monadicity theorem. If `G` reflects isomorphisms, preserves
coequalizers of `G`-split pairs and `C` has coequalizers of `G`-split pairs, then it is monadic.
-/
def monadic_of_has_preserves_G_split_coequalizers_of_reflects_isomorphisms {C : Type u₁} {D : Type u₂} [category C] [category D] (G : D ⥤ C) [is_right_adjoint G] [reflects_isomorphisms G] [∀ {A B : D} (f g : A ⟶ B) [_inst_6 : functor.is_split_pair G f g], limits.has_coequalizer f g] [{A B : D} →
  (f g : A ⟶ B) → [_inst_8 : functor.is_split_pair G f g] → limits.preserves_colimit (limits.parallel_pair f g) G] : monadic_right_adjoint G :=
  monadic_of_has_preserves_reflects_G_split_coequalizers G

/--
Reflexive (crude) monadicity theorem. If `G` has a right adjoint, `D` has and `G` preserves
reflexive coequalizers and `G` reflects isomorphisms, then `G` is monadic.
-/
def monadic_of_has_preserves_reflexive_coequalizers_of_reflects_isomorphisms {C : Type u₁} {D : Type u₂} [category C] [category D] (G : D ⥤ C) [is_right_adjoint G] [limits.has_reflexive_coequalizers D] [reflects_isomorphisms G] [{A B : D} → (f g : A ⟶ B) → [_inst_7 : is_reflexive_pair f g] → limits.preserves_colimit (limits.parallel_pair f g) G] : monadic_right_adjoint G := sorry


import Mathlib.Init.Function
import ExtParser.FinUtils

namespace Grammar

  inductive PEG (n : Nat) where
    | ε
    | any
    | terminal (c : Char)
    | nonTerminal (vn : Fin n)
    | seq (p1 p2 : PEG n)
    | prior (p1 p2 : PEG n)
    | star (p : PEG n)
    | notP (p : PEG n)
  deriving DecidableEq, Repr

  open PEG

  inductive PEG.le : PEG n → PEG n → Prop where
    | refl        : le p p
    | seq_left    : le e p1 → le e (.seq p1 p2)
    | seq_right   : le e p2 → le e (.seq p1 p2)
    | prior_left  : le e p1 → le e (.prior p1 p2)
    | prior_right : le e p2 → le e (.prior p1 p2)
    | star        : le e p → le e (.star p)
    | notP        : le e p → le e (.notP p)

  instance : LE (PEG n) where
    le := PEG.le

  theorem PEG.le_refl (G : PEG n) : G ≤ G := by exact .refl;

  theorem PEG.le_trans {G1 G2 G3 : PEG n} : G1 ≤ G2 → G2 ≤ G3 → G1 ≤ G3 := by
    intro h g;
    match g with
    | .refl => exact h;
    | .seq_left g => apply le.seq_left; exact le_trans h g;
    | .seq_right g => apply le.seq_right; exact le_trans h g;
    | .prior_left g => apply le.prior_left; exact le_trans h g;
    | .prior_right g => apply le.prior_right; exact le_trans h g;
    | .star g => apply le.star; exact le_trans h g;
    | .notP g => apply le.notP; exact le_trans h g;

  def stringPEG {n : Nat} (cs : List Char) : PEG n :=
    match cs with
      | [] => ε
      | c :: cs => seq (terminal c) (stringPEG cs)

  -- Grammar Production Rule
  structure GProd (n : Nat) where
    pos_n : 0 < n
    f : Fin n → PEG n

  -- Maybe Type for known and unknown properties
  inductive Maybe (p : α → Prop) (a : α) where
    | found : p a → Maybe p a
    | unknown

  open Maybe

  mutual
    -- Property of PEG grammar that can be failed
    inductive PropF : GProd n → PEG n → Prop where
      | any : PropF Pexp any
      | terminal : ∀ (c : Char), PropF Pexp (terminal c)
      | nonTerminal : ∀ (vn : Fin n), PropF Pexp (Pexp.f vn) → PropF Pexp (nonTerminal vn)
      | seq_F : ∀ (e1 e2 : PEG n), PropF Pexp e1 → PropF Pexp (seq e1 e2)
      | seq_0F : ∀ (e1 e2 : PEG n), Prop0 Pexp e1 → PropF Pexp e2 → PropF Pexp (seq e1 e2)
      | seq_SF : ∀ (e1 e2 : PEG n), PropS Pexp e1 → PropF Pexp e2 → PropF Pexp (seq e1 e2)
      | prior : ∀ (e1 e2 : PEG n), PropF Pexp e1 → PropF Pexp e2 → PropF Pexp (prior e1 e2)
      | notP_0 : ∀ (e : PEG n), Prop0 Pexp e → PropF Pexp (notP e)
      | notP_S : ∀ (e : PEG n), PropS Pexp e → PropF Pexp (notP e)

    -- Property of PEG grammar that can succeed without consuming input
    inductive Prop0 : GProd n → PEG n → Prop where
      | ε : Prop0 Pexp ε
      | nonTerminal : ∀ (vn : Fin n), Prop0 Pexp (Pexp.f vn) → Prop0 Pexp (nonTerminal vn)
      | seq : ∀ (e1 e2 : PEG n), Prop0 Pexp e1 → Prop0 Pexp e2 → Prop0 Pexp (seq e1 e2)
      | prior_0 : ∀ (e1 e2 : PEG n), Prop0 Pexp e1 → Prop0 Pexp (prior e1 e2)
      | prior_F0 : ∀ (e1 e2 : PEG n), PropF Pexp e1 → Prop0 Pexp e2 → Prop0 Pexp (prior e1 e2)
      | star : ∀ (e : PEG n), PropF Pexp e → Prop0 Pexp (star e)
      | notP : ∀ (e : PEG n), PropF Pexp e → Prop0 Pexp (notP e)

    -- Property of PEG grammar that can succeed only by consuming input
    inductive PropS : GProd n → PEG n → Prop where
      | any : PropS Pexp any
      | terminal : ∀ (c : Char), PropS Pexp (terminal c)
      | nonTerminal : ∀ (vn : Fin n), PropS Pexp (Pexp.f vn) → PropS Pexp (nonTerminal vn)
      | seq_S0 : ∀ (e1 e2 : PEG n), PropS Pexp e1 → Prop0 Pexp e2 → PropS Pexp (seq e1 e2)
      | seq_0S : ∀ (e1 e2 : PEG n), Prop0 Pexp e1 → PropS Pexp e2 → PropS Pexp (seq e1 e2)
      | seq_SS : ∀ (e1 e2 : PEG n), PropS Pexp e1 → PropS Pexp e2 → PropS Pexp (seq e1 e2)
      | prior_S : ∀ (e1 e2 : PEG n), PropS Pexp e1 → PropS Pexp (prior e1 e2)
      | prior_FS : ∀ (e1 e2 : PEG n), PropF Pexp e1 → PropS Pexp e2 → PropS Pexp (prior e1 e2)
      | star : ∀ (e : PEG n), PropS Pexp e → PropS Pexp (star e)
  end

  abbrev PropsTriple (Pexp : GProd n) (G : PEG n) := Maybe (PropF Pexp) G × Maybe (Prop0 Pexp) G × Maybe (PropS Pexp) G
  abbrev PropsTriplePred (Pexp : GProd n) := ∀ (i : Fin n), PropsTriple Pexp (Pexp.f i)

  -- Compute grammar properties in one iteration
  def g_props {Pexp : GProd n} (G : PEG n) (P : PropsTriplePred Pexp) : PropsTriple Pexp G :=
    match G with
    | ε => (unknown, found (Prop0.ε), unknown)
    | any => (found (PropF.any), unknown, found (PropS.any))
    | terminal c => (found (PropF.terminal c), unknown, found (PropS.terminal c))
    | nonTerminal vn =>
      have (e_f, e_0, e_s) := P vn
      (
        match e_f with
          | found h => found (PropF.nonTerminal vn h)
          | unknown => unknown
        ,
        match e_0 with
          | found h => found (Prop0.nonTerminal vn h)
          | unknown => unknown
        ,
        match e_s with
          | found h => found (PropS.nonTerminal vn h)
          | unknown => unknown
      )
    | seq e1 e2 =>
      have (e1_f, e1_0, e1_s) := g_props e1 P;
      have (e2_f, e2_0, e2_s) := g_props e2 P;
      (
        match (e1_f, e1_0, e1_s, e2_f) with
          | (found h, _, _, _) => found (PropF.seq_F e1 e2 h)
          | (_,found h0,_,found hf) => found (PropF.seq_0F e1 e2 h0 hf)
          | (_,_,found hs,found hf) => found (PropF.seq_SF e1 e2 hs hf)
          | _ => unknown
        ,
        match (e1_0, e2_0) with
          | (found h1, found h2) => found (Prop0.seq e1 e2 h1 h2)
          | _ => unknown
        ,
        match (e1_0, e1_s, e2_0, e2_s) with
          | (_,found hs,found h0,_) => found (PropS.seq_S0 e1 e2 hs h0)
          | (found h0,_,_,found hs) => found (PropS.seq_0S e1 e2 h0 hs)
          | (_,found h1,_,found h2) => found (PropS.seq_SS e1 e2 h1 h2)
          | _ => unknown
      )
    | prior e1 e2 =>
      have (e1_f, e1_0, _) := g_props e1 P;
      have (e2_f, e2_0, _) := g_props e2 P;
      (
        match (e1_f, e2_f) with
          | (found h1, found h2) => found (PropF.prior e1 e2 h1 h2)
          | _ => unknown
        ,
        match (e1_f, e1_0, e2_0) with
          | (_,found h,_) => found (Prop0.prior_0 e1 e2 h)
          | (found hf,_,found h0) => found (Prop0.prior_F0 e1 e2 hf h0)
          | _ => unknown
        ,
        unknown
      )
    | star e =>
      have (e_f, _, e_s) := g_props e P;
      (
        unknown
        ,
        match e_f with
          | found h => found (Prop0.star e h)
          | unknown => unknown
        ,
        match e_s with
          | found h => found (PropS.star e h)
          | unknown => unknown
      )
    | notP e =>
      have (e_f, e_0, e_s) := g_props e P;
      (
        match (e_0, e_s) with
          | (found h,_) => found (PropF.notP_0 e h)
          | (_,found h) => found (PropF.notP_S e h)
          | _ => unknown
        ,
        match e_f with
          | found h => found (Prop0.notP e h)
          | unknown => unknown
        ,
        unknown
      )

  inductive Maybe.le : Maybe p a → Maybe p a → Prop where
    | lhs_unknown : ∀ {p : α → Prop} {a : α} {mr : Maybe p a}, Maybe.le unknown mr
    | all_found : ∀ {p : α → Prop} {a : α}, (l r : p a) → Maybe.le (found l) (found r)

  instance : LE (Maybe p a) where
    le := Maybe.le

  theorem Maybe.le_refl : ∀ {x : Maybe p a}, x ≤ x := by
    intro x
    cases x
    apply Maybe.le.all_found
    apply Maybe.le.lhs_unknown

  theorem Maybe.le_trans : ∀ {x y z : Maybe p a}, x ≤ y → y ≤ z → x ≤ z := by
    intro x y z hxy hyz
    cases hxy
    apply Maybe.le.lhs_unknown
    cases hyz
    apply Maybe.le.all_found

  theorem Maybe.le.not_found_to_unknown : ∀ {p : α → Prop} {a : α}, (pa : p a) → ¬ (found pa ≤ unknown) := by
    intro p a pa h
    cases h

  theorem Maybe.le.equiv_to_imply : ∀ {p : α → Prop} {a : α} {x y : Maybe p a}, x ≤ y ↔ (x = unknown) ∨ (∃ x' y', x = found x' ∧ y = found y') := by
    intro p a x y
    apply Iff.intro
    {
      intro hxy;
      cases hxy with
      | lhs_unknown => apply Or.inl; rfl;
      | all_found l r => apply Or.inr; exists l; exists r;
    }
    {
      intro h;
      match h with
      | Or.inl g => simp [g]; exact Maybe.le.lhs_unknown;
      | Or.inr ⟨x',⟨y', ⟨fx, fy⟩⟩⟩ => simp [fx, fy]; exact Maybe.le.all_found x' y'
    }

  theorem Maybe.eq_of_le_le : ∀ {p : α → Prop} {a : α} {x y : Maybe p a}, x ≤ y → y ≤ x → x = y := by
    intro p a x y hxy hyx
    cases hxy <;> cases hyx <;> rfl

  inductive PropsTriple.le (P Q : PropsTriple Pexp G) : Prop where
    | mk : P.fst ≤ Q.fst → P.snd.fst ≤ Q.snd.fst → P.snd.snd ≤ Q.snd.snd → PropsTriple.le P Q

  instance : LE (PropsTriple Pexp G) where
    le := PropsTriple.le

  theorem PropsTriple.le_refl : ∀ {x : PropsTriple Pexp G}, x ≤ x := by
    intro x
    apply PropsTriple.le.mk <;> apply Maybe.le_refl

  theorem PropsTriple.le_trans : ∀ {x y z : PropsTriple Pexp G}, x ≤ y → y ≤ z → x ≤ z := by
    intro x y z hxy hyz
    cases hxy with
      | mk hxy_f hxy_0 hxy_s => cases hyz with
        | mk hyz_f hyz_0 hyz_s =>
          constructor
          apply Maybe.le_trans hxy_f hyz_f
          apply Maybe.le_trans hxy_0 hyz_0
          apply Maybe.le_trans hxy_s hyz_s

  theorem PropsTriple.eq_of_le_le : ∀ {x y : PropsTriple Pexp G}, x ≤ y → y ≤ x → x = y := by
    intro x y hxy hyx;
    match x with
    | (x1, x2, x3) => match y with
      | (y1, y2, y3) =>
        cases hxy <;> cases hyx <;> simp_all;
        apply And.intro; apply Maybe.eq_of_le_le; trivial; trivial;
        apply And.intro; apply Maybe.eq_of_le_le; trivial; trivial;
        apply Maybe.eq_of_le_le; trivial; trivial;

  inductive PropsTriplePred.le {Pexp : GProd n} (P Q : PropsTriplePred Pexp) : Prop where
    | mk : (∀ (i : Fin n), (P i) ≤ (Q i)) → PropsTriplePred.le P Q

  instance : LE (PropsTriplePred Pexp) where
    le := PropsTriplePred.le

  theorem PropsTriplePred.le_refl : ∀ {x : PropsTriplePred Pexp}, x ≤ x := by
    intro x
    constructor
    intro i
    apply PropsTriple.le_refl

  theorem PropsTriplePred.le_trans : ∀ {x y z : PropsTriplePred Pexp}, x ≤ y → y ≤ z → x ≤ z := by
    intro x y z (PropsTriplePred.le.mk fxy) (PropsTriplePred.le.mk fyz)
    constructor
    intro i
    apply PropsTriple.le_trans (fxy i) (fyz i)

  theorem PropsTriplePred.eq_of_le_le : ∀ {x y : PropsTriplePred Pexp}, x ≤ y → y ≤ x → x = y := by
    intro x y hxy hyx;
    apply funext;
    intro i;
    cases hxy with
    | mk fxy =>
      cases hyx with
      | mk fyx => apply PropsTriple.eq_of_le_le (fxy i) (fyx i);

  theorem g_props_growth_seq : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp} {e1 e2 : PEG n}, g_props e1 P ≤ g_props e1 Q → g_props e2 P ≤ g_props e2 Q → g_props (.seq e1 e2) P ≤ g_props (.seq e1 e2) Q := by
    intros Pexp P Q e1 e2 e1_growth e2_growth
    cases e1_growth with
    | mk le1_f le1_0 le1_s => cases e2_growth with
      | mk le2_f le2_0 le2_s =>
        {
          constructor <;> simp [g_props]
          {
            match (Maybe.le.equiv_to_imply.mp le1_f) with
            | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_f) with
              | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le1_0) with
                | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le1_s) with
                  | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).fst <;> cases (g_props e1 Q).snd.fst <;> simp <;> apply Maybe.le.all_found
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).fst <;> simp <;> apply Maybe.le.all_found
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
          }
          {
            match (Maybe.le.equiv_to_imply.mp le1_0) with
            | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le2_0) with
              | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
          }
          {
            match (Maybe.le.equiv_to_imply.mp le1_0) with
            | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le1_s) with
              | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le2_0) with
                | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_s) with
                  | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).snd.fst <;> cases (g_props e2 Q).snd.fst <;> simp <;> apply Maybe.le.all_found
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le1_s) with
              | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_0) with
                | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_s) with
                  | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).snd.snd <;> cases (g_props e2 Q).snd.fst <;> simp <;> apply Maybe.le.all_found
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le2_s) with
                  | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).snd.snd <;> simp <;> apply Maybe.le.all_found
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le2_0) with
                | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_s) with
                  | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e2 Q).snd.fst <;> simp <;> apply Maybe.le.all_found
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
          }
        }

  theorem g_props_growth_nonterminal : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp} {vn} , P ≤ Q → g_props (.nonTerminal vn) P ≤ g_props (.nonTerminal vn) Q := by
    intros Pexp P Q vn hpq
    have (PropsTriplePred.le.mk fpq) := hpq
    cases fpq vn with
    | mk le_f le_0 le_s =>
      {
        constructor <;> simp [g_props]
        {
          match (Maybe.le.equiv_to_imply.mp le_f) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
        {
          match (Maybe.le.equiv_to_imply.mp le_0) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
        {
          match (Maybe.le.equiv_to_imply.mp le_s) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
      }

  theorem g_props_growth_prior : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp} {e1 e2 : PEG n}, g_props e1 P ≤ g_props e1 Q → g_props e2 P ≤ g_props e2 Q  → g_props (.prior e1 e2) P ≤ g_props (.prior e1 e2) Q := by
    intros Pexp P Q e1 e2 e1_growth e2_growth
    cases e1_growth with
    | mk le1_f le1_0 le1_s => cases e2_growth with
      | mk le2_f le2_0 le2_s =>
        {
          constructor <;> simp [g_props]
          {
            match (Maybe.le.equiv_to_imply.mp le1_f) with
            | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le2_f) with
              | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
          }
          {
            match (Maybe.le.equiv_to_imply.mp le1_f) with
            | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le1_0) with
              | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; match (Maybe.le.equiv_to_imply.mp le1_0) with
              | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le2_0) with
                | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e1 Q).snd.fst <;> simp <;> apply Maybe.le.all_found
              | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
          }
          {
            apply Maybe.le.lhs_unknown
          }
        }

  theorem g_props_growth_star : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp} {e : PEG n}, g_props e P ≤ g_props e Q → g_props (.star e) P ≤ g_props (.star e) Q := by
    intros Pexp P Q e e_growth
    cases e_growth with
    | mk le_f le_0 le_s =>
      {
        constructor <;> simp [g_props]
        {
          apply Maybe.le.lhs_unknown
        }
        {
          match (Maybe.le.equiv_to_imply.mp le_f) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
        {
          match (Maybe.le.equiv_to_imply.mp le_s) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
      }

  theorem g_props_growth_notP : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp} {e : PEG n}, g_props e P ≤ g_props e Q → g_props (.notP e) P ≤ g_props (.notP e) Q := by
    intros Pexp P Q e e_growth
    cases e_growth with
    | mk le_f le_0 le_s =>
      {
        constructor <;> simp [g_props]
        {
          match (Maybe.le.equiv_to_imply.mp le_0) with
          | Or.inl h => simp [h]; match (Maybe.le.equiv_to_imply.mp le_s) with
            | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
            | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; cases (g_props e Q).snd.fst <;> simp <;> apply Maybe.le.all_found
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
        {
          match (Maybe.le.equiv_to_imply.mp le_f) with
          | Or.inl h => simp [h]; apply Maybe.le.lhs_unknown
          | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy']; apply Maybe.le.all_found
        }
        {
          apply Maybe.le.lhs_unknown
        }
      }

  theorem g_props_growth : ∀ {Pexp : GProd n} {G : PEG n} {P Q : PropsTriplePred Pexp}, P ≤ Q → g_props G P ≤ g_props G Q := by
    intro Pexp G P Q hpq
    cases G with
      | ε => apply PropsTriple.le_refl
      | any => apply PropsTriple.le_refl
      | terminal c => apply PropsTriple.le_refl
      | nonTerminal vn => exact g_props_growth_nonterminal hpq
      | seq e1 e2 =>
        {
          have e1_growth : g_props e1 P ≤ g_props e1 Q := g_props_growth hpq;
          have e2_growth : g_props e2 P ≤ g_props e2 Q := g_props_growth hpq;
          exact g_props_growth_seq e1_growth e2_growth
        }
      | prior e1 e2 =>
        {
          have e1_growth : g_props e1 P ≤ g_props e1 Q := g_props_growth hpq;
          have e2_growth : g_props e2 P ≤ g_props e2 Q := g_props_growth hpq;
          exact g_props_growth_prior e1_growth e2_growth
        }
      | star e =>
        {
          have e_growth : g_props e P ≤ g_props e Q := g_props_growth hpq;
          exact g_props_growth_star e_growth
        }
      | notP e =>
        {
          have e_growth : g_props e P ≤ g_props e Q := g_props_growth hpq;
          exact g_props_growth_notP e_growth
        }

  structure CoherentPred (Pexp : GProd n) where
    pred : PropsTriplePred Pexp
    coherent : ∀ (i : Fin n), pred i ≤ g_props (Pexp.f i) pred

  instance : LE (CoherentPred Pexp) where
    le := fun P Q => P.pred ≤ Q.pred

  theorem CoherentPred.eq_of_eq_pred : ∀ {x y : CoherentPred Pexp}, x.pred = y.pred → x = y := by
    intro x y h;
    cases x; cases y; simp_all;

  theorem CoherentPred.eq_of_le_le : ∀ {x y : CoherentPred Pexp}, x ≤ y → y ≤ x → x = y := by
    intro x y hxy hyx
    cases x with
    | mk xp xc => cases y with
      | mk yp yc =>
        cases hxy; cases hyx; simp_all; apply PropsTriplePred.eq_of_le_le <;> constructor <;> trivial;

  def g_extend {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp) : CoherentPred Pexp :=
    {
      pred := fun b =>  match Fin.decEq a b with
                        | isFalse h => P.pred b
                        | isTrue rfl => g_props (Pexp.f a) P.pred
      coherent := by
        intro i; simp
        cases Fin.decEq a i with
        | isFalse _ =>
          simp; apply PropsTriple.le_trans (P.coherent i);
          apply g_props_growth;
          constructor; intro b;
          cases Fin.decEq a b with
          | isFalse _ => simp; apply PropsTriple.le_refl
          | isTrue g => cases g; simp; apply P.coherent
        | isTrue h =>
          cases h; simp; apply g_props_growth;
          constructor; intro b;
          cases Fin.decEq a b with
          | isFalse _ => simp; apply PropsTriple.le_refl
          | isTrue g => cases g; simp; apply P.coherent
    }

  theorem g_extend_growth1 : ∀ {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp), P ≤ g_extend a P := by
    intro Pexp a P
    simp [g_extend]; constructor; simp;
    intro b;
    cases Fin.decEq a b with
    | isFalse _ => simp; apply PropsTriple.le_refl
    | isTrue h => cases h; simp; apply P.coherent

  theorem g_extend_growth2 : ∀ {Pexp : GProd n} (a : Fin n) (P Q : CoherentPred Pexp), P ≤ Q → g_extend a P ≤ g_extend a Q := by
    intro Pexp a P Q
    intro hpq; constructor; simp [g_extend, *]
    intro b;
    cases Fin.decEq a b with
    | isFalse _ => simp; cases hpq with
      | mk fpq => exact fpq b
    | isTrue h => cases h; simp; apply g_props_growth hpq

  def recompute_props {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp) : CoherentPred Pexp :=
    match Nat.decEq a.val.succ n with
    | isTrue _ => g_extend a P
    | isFalse hne =>
      have _ : n - a.val.succ < n - a.val := Nat.sub_succ_lt_self n a.val a.isLt; -- prove termination
      recompute_props (Fin.inbound_succ a hne) (g_extend a P)
  termination_by recompute_props a P => n - a.val

  theorem recompute_lemma1 : ∀ {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp), P ≤ recompute_props a P := by
    intro Pexp a P
    rw [recompute_props]
    cases Nat.decEq a.val.succ n
    {
      simp;
      have _ : n - a.val.succ < n - a.val := Nat.sub_succ_lt_self n a.val a.isLt;
      apply PropsTriplePred.le_trans (g_extend_growth1 a P);
      apply recompute_lemma1
    }
    {
      simp; apply g_extend_growth1
    }
  termination_by recompute_lemma1 a P => n - a.val

  theorem recompute_lemma2 : ∀ {Pexp : GProd n} (a : Fin n) (P Q : CoherentPred Pexp), P ≤ Q → recompute_props a P ≤ recompute_props a Q := by
    intro Pexp a P Q hpq
    rw [recompute_props, recompute_props]
    cases Nat.decEq a.val.succ n
    {
      simp;
      have _ : n - a.val.succ < n - a.val := Nat.sub_succ_lt_self n a.val a.isLt;
      apply recompute_lemma2;
      apply g_extend_growth2 a P Q hpq;
    }
    {
      simp; apply g_extend_growth2 a P Q hpq
    }
  termination_by recompute_lemma2 a P Q hpq => n - a.val

  theorem recompute_lemma3 : ∀ {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp), (hne : ¬(a.val.succ = n)) → recompute_props (Fin.inbound_succ a hne) P ≤ recompute_props a P := by
    intro Pexp a P hne
    have h : recompute_props a P = recompute_props (Fin.inbound_succ a hne) (g_extend a P) := by
      rw [recompute_props]
      cases Nat.decEq a.val.succ n
      simp
      contradiction
    rw [h]
    apply recompute_lemma2
    apply g_extend_growth1

  theorem recompute_le_recompute_zero : ∀ {Pexp : GProd n} (a : Fin n) (P : CoherentPred Pexp), recompute_props a P ≤ recompute_props (Fin.mk 0 Pexp.pos_n) P := by
    intro Pexp a P;
    match Nat.decEq a.val 0 with
    | isTrue h =>
      have g : a = (Fin.mk 0 Pexp.pos_n) := Fin.eq_of_val_eq h;
      rw [g];
      apply PropsTriplePred.le_refl;
    | isFalse h =>
        have g : a = Fin.inbound_succ_pred a h := by apply Fin.inbound_succ_pred_eq;
        rw [g, Fin.inbound_succ_pred]; simp;
        apply PropsTriplePred.le_trans (recompute_lemma3 _ P _);
        apply recompute_le_recompute_zero;
  termination_by recompute_le_recompute_zero a P => a.val

  structure Fixpoint (Pexp : GProd n) where
    coherent_pred : CoherentPred Pexp
    isFixed : recompute_props (Fin.mk 0 Pexp.pos_n) coherent_pred = coherent_pred

  instance : LE (Fixpoint Pexp) where
    le := fun P Q => P.coherent_pred ≤ Q.coherent_pred

  def Fixpoint.pred (P : Fixpoint Pexp) : PropsTriplePred Pexp := P.coherent_pred.pred

  theorem Fixpoint.eq_of_eq_coherent_pred : ∀ {x y : Fixpoint Pexp}, x.coherent_pred = y.coherent_pred → x = y := by
    intro x y h;
    cases x; cases y; simp_all;

  theorem Fixpoint.recompute_le_self : ∀ {Pexp : GProd n} (a : Fin n) (P : Fixpoint Pexp), recompute_props a P.coherent_pred ≤ P.coherent_pred := by
    intro Pexp a P;
    have helper : (recompute_props a P.coherent_pred ≤ P.coherent_pred) = (recompute_props a P.coherent_pred ≤ recompute_props (Fin.mk 0 Pexp.pos_n) P.coherent_pred) := by
      rw [P.isFixed]
    rw [helper];
    apply recompute_le_recompute_zero;

  theorem Fixpoint.no_growth : ∀ {Pexp : GProd n} (a : Fin n) (P : Fixpoint Pexp), P.coherent_pred = g_extend a P.coherent_pred := by
    intro Pexp a P;
    simp;
    apply CoherentPred.eq_of_le_le;
    {
      apply g_extend_growth1;
    }
    {
      have g_extend_le_recompute : g_extend a P.coherent_pred ≤ recompute_props a P.coherent_pred := by
        rw [recompute_props];
        cases Nat.decEq a.val.succ n with
        | isTrue h => simp [h]; apply PropsTriplePred.le_refl
        | isFalse h =>
          simp; apply recompute_lemma1;
      apply PropsTriplePred.le_trans g_extend_le_recompute;
      apply PropsTriplePred.le_trans;
      apply recompute_le_recompute_zero a;
      rw [P.isFixed];
      apply PropsTriplePred.le_refl;
    }

  def Maybe.count_found : Maybe p a → Fin 2
    | found _ => Fin.mk 1 (by trivial)
    | unknown => Fin.mk 0 (by trivial)

  theorem Maybe.count_growth : ∀ (P Q : Maybe p a), P ≤ Q → P.count_found ≤ Q.count_found := by
    intro P Q h
    simp [count_found];
    cases h <;> simp;
    apply Nat.zero_le;

  theorem Maybe.eq_of_same_count : ∀ (P Q : Maybe p a), P.count_found = Q.count_found → P = Q := by
    intro P Q;
    rw [count_found, count_found];
    cases P <;> cases Q <;> simp;

  def PropsTriple.count_found (P : PropsTriple Pexp G) : Fin 4 :=
    Fin.extended_add P.fst.count_found (Fin.extended_add P.snd.fst.count_found P.snd.snd.count_found)

  theorem PropsTriple.count_growth : ∀ (P Q : PropsTriple Pexp G), P ≤ Q → P.count_found ≤ Q.count_found := by
    intro P Q h
    rw [count_found, count_found];
    cases h;
    apply Fin.extended_add_le_add;
    apply Maybe.count_growth; assumption;
    apply Fin.extended_add_le_add <;> apply Maybe.count_growth <;> assumption;

  theorem Nat.eq_eq_of_le_le_eq : ∀ {a b c d : Nat}, a ≤ c → b ≤ d → a + b = c + d → (a = c ∧ b = d) := by
    intro a b c d le_ac le_bd h;
    cases Nat.eq_or_lt_of_le le_ac;
    {
      simp_all; exact Nat.add_left_cancel h;
    }
    {
      cases Nat.eq_or_lt_of_le le_bd;
      {
        simp_all;
        exact Nat.add_right_cancel h;
      }
      {
        have g : a + b ≠ c + d := by apply Nat.ne_of_lt; apply Nat.add_lt_add; assumption; assumption;
        contradiction;
      }
    }

  theorem PropsTriple.eq_of_le_with_same_count : ∀ (P Q : PropsTriple Pexp G), P ≤ Q → P.count_found = Q.count_found → P = Q := by
    intro P Q hle hcount;
    simp [count_found, Fin.extended_add] at hcount;
    match hle with
    | ⟨hf,h0,hs⟩ =>
      match P with
      | ⟨pf,p0,ps⟩ => match Q with
        | ⟨qf,q0,qs⟩ =>
          simp at *;
          have g1 : (Maybe.count_found pf).val = (Maybe.count_found qf).val ∧ ((Maybe.count_found p0).val + (Maybe.count_found ps).val) = ((Maybe.count_found q0).val + (Maybe.count_found qs).val) := by
          {
            apply Nat.eq_eq_of_le_le_eq;
            apply Maybe.count_growth _ _ hf;
            apply Nat.add_le_add;
            apply Maybe.count_growth _ _ h0;
            apply Maybe.count_growth _ _ hs;
            exact hcount;
          }
          have g2 : (Maybe.count_found p0).val = (Maybe.count_found q0).val ∧ (Maybe.count_found ps).val = (Maybe.count_found qs).val := by
          {
            apply Nat.eq_eq_of_le_le_eq;
            apply Maybe.count_growth _ _ h0;
            apply Maybe.count_growth _ _ hs;
            exact g1.right;
          }
          apply And.intro
          apply Maybe.eq_of_same_count;
          exact Fin.eq_of_val_eq g1.left;
          apply And.intro
          apply Maybe.eq_of_same_count;
          exact Fin.eq_of_val_eq g2.left;
          apply Maybe.eq_of_same_count;
          exact Fin.eq_of_val_eq g2.right;

  def PropsTriplePred.count_found_helper {Pexp : GProd n} (P : PropsTriplePred Pexp) (i : Fin n) (res : Fin (3*(n-i.val)-2)) : Fin (3*n+1) :=
    have new_res := (Fin.extended_add (P i).count_found res);
    match Nat.decEq i.val 0 with
    | isTrue h =>
      have c : 4 + (3 * (n - i.val) - 2) - 1 = 3 * n + 1 := by
      {
        simp_all;
        apply Nat.sub_eq_of_eq_add;
        rw [←Nat.add_sub_assoc (by rw[←Nat.mul_one 2]; apply Nat.mul_le_mul; trivial; exact Pexp.pos_n) 4, Nat.add_comm, Nat.add_sub_assoc];
        trivial;
      }
      Fin.cast c new_res
    | isFalse h =>
      have c : 4 + (3 * (n - i.val) - 2) - 1 = 3 * (n - (Fin.inbound_pred i h).val) - 2 := by
      {
        rw [Fin.inbound_pred]; simp;
        calc
          4 + (3 * (n - i.val) - 2) - 1 = 4 + (3 * (n - Nat.succ (Nat.pred i.val)) - 2) - 1 := by rw [Nat.succ_pred h]
          _ = 4 + (3 * (n - Nat.pred i.val - 1) - 2) - 1 := by rw [←Nat.add_one, ←Nat.sub_sub];
          _ = 4 + (3 * (n - Nat.pred i.val) - 3 - 2) - 1 := by rw [Nat.mul_sub_left_distrib];
          _ = 3 * (n - Nat.pred i.val) - (2 + 3) + 3 := by rw [Nat.add_comm, Nat.add_sub_assoc (by trivial), Nat.sub_sub];
          _ = 3 * (n - Nat.pred i.val) - 2 - 3 + 3 := by rw [←Nat.sub_sub]
        apply Nat.sub_add_cancel;
        apply Nat.le_sub_of_add_le;
        rw [Nat.add_comm 3 2]
        rw [←Nat.succ_sub_succ, Nat.succ_pred h, Nat.mul_sub_left_distrib, Nat.mul_succ];
        apply Nat.le_sub_of_add_le;
        rw [Nat.add_assoc, Nat.add_comm 3 (3 * i.val), ←Nat.add_assoc];
        apply Nat.add_le_add_right;
        have g : 2 + 3 * i.val ≤ 3 + 3 * i.val := by apply Nat.add_le_add_right; trivial;
        apply Nat.le_trans g;
        rw [Nat.add_comm, ←Nat.mul_succ];
        apply Nat.mul_le_mul_left;
        apply Nat.succ_le_of_lt;
        exact i.isLt;
      }
      have _ : (Fin.inbound_pred i h).val + 1 < i.val + 1 := by apply Nat.succ_lt_succ; rw [Fin.inbound_pred]; simp; apply Nat.pred_lt h;
      count_found_helper P (Fin.inbound_pred i h) (Fin.cast c new_res)
  termination_by count_found_helper P i res => i

  def PropsTriplePred.count_found {Pexp : GProd n} (P : PropsTriplePred Pexp) : Fin (3*n+1) :=
    have max_i : Fin n := Fin.mk (n-1) (by apply Nat.sub_lt Pexp.pos_n; trivial);
    have isLt : 0 < 3 * (n - max_i.val) - 2 := by
    {
      apply Nat.lt_sub_of_add_lt;
      simp;
      apply Nat.lt_of_succ_le;
      rw [←Nat.mul_one (Nat.succ 2)];
      apply Nat.mul_le_mul_left;
      apply Nat.succ_le_of_lt;
      apply Nat.lt_sub_of_add_lt;
      simp;
      exact max_i.isLt;
    }
    have fin_zero : Fin (3 * (n - max_i.val) - 2) := Fin.mk 0 isLt;
    P.count_found_helper max_i fin_zero

  theorem count_growth_helper_res {Pexp : GProd n} (P : PropsTriplePred Pexp) (i : Fin n) (res1 res2 : Fin (3*(n-i.val)-2))
                            : res1 ≤ res2 → P.count_found_helper i res1 ≤ P.count_found_helper i res2 := by
    intro h;
    rw [PropsTriplePred.count_found_helper, PropsTriplePred.count_found_helper];
    simp;
    match Nat.decEq i.val 0 with
    | isTrue g =>
      {
        simp [g, Fin.cast];
        apply Fin.extended_add_le_add_left;
        exact h;
      }
    | isFalse g =>
      {
        have _ : (Fin.inbound_pred i g).val + 1 < i.val + 1 := by
        {
          apply Nat.add_lt_add_right;
          rw [Fin.inbound_pred];
          apply Nat.pred_lt g;
        }
        simp [g, Fin.cast];
        apply count_growth_helper_res;
        apply Fin.extended_add_le_add_left;
        exact h;
      }
  termination_by count_growth_helper_res P i res1 res2 h => i

  theorem count_growth_helper_pred {Pexp : GProd n} (P Q : PropsTriplePred Pexp) (i : Fin n) (res : Fin (3*(n-i.val)-2))
                            : P ≤ Q → P.count_found_helper i res ≤ Q.count_found_helper i res := by
    intro hpq;
    match hpq with
    | PropsTriplePred.le.mk h =>
      {
        rw [PropsTriplePred.count_found_helper, PropsTriplePred.count_found_helper];
        simp;
        match Nat.decEq i.val 0 with
        | isTrue g =>
          {
            simp [g, Fin.cast];
            apply Fin.extended_add_le_add_right;
            rw [PropsTriple.count_found, PropsTriple.count_found];
            apply Fin.extended_add_le_add;
            {
              rw [count_found, count_found];
              simp;
              match (h i) with
              | ⟨h, _, _⟩ => match Maybe.le.equiv_to_imply.mp h with
                | Or.inl h => simp [h]; cases (Q i).fst <;> simp;
                | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
            }
            {
              apply Fin.extended_add_le_add;
              {
                rw [count_found, count_found];
                simp;
                match (h i) with
                | ⟨_, h, _⟩ => match Maybe.le.equiv_to_imply.mp h with
                  | Or.inl h => simp [h]; cases (Q i).snd.fst <;> simp;
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
              }
              {
                rw [count_found, count_found];
                simp;
                match (h i) with
                | ⟨_, _, h⟩ => match Maybe.le.equiv_to_imply.mp h with
                  | Or.inl h => simp [h]; cases (Q i).snd.snd <;> simp;
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
              }
            }
          }
        | isFalse g =>
          {
            simp [g];
            have _ : (Fin.inbound_pred i g).val + 1 < i.val + 1 := by
            {
              apply Nat.add_lt_add_right;
              rw [Fin.inbound_pred];
              apply Nat.pred_lt g;
            }
            have cpq : Fin.extended_add (PropsTriple.count_found (P i)) res ≤ Fin.extended_add (PropsTriple.count_found (Q i)) res := by
            {
              apply Fin.extended_add_le_add_right;
              rw [PropsTriple.count_found, PropsTriple.count_found];
              apply Fin.extended_add_le_add;
              {
                rw [count_found, count_found];
                simp;
                match (h i) with
                | ⟨h, _, _⟩ => match Maybe.le.equiv_to_imply.mp h with
                  | Or.inl h => simp [h]; cases (Q i).fst <;> simp;
                  | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
              }
              {
                apply Fin.extended_add_le_add;
                {
                  rw [count_found, count_found];
                  simp;
                  match (h i) with
                  | ⟨_, h, _⟩ => match Maybe.le.equiv_to_imply.mp h with
                    | Or.inl h => simp [h]; cases (Q i).snd.fst <;> simp;
                    | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
                }
                {
                  rw [count_found, count_found];
                  simp;
                  match (h i) with
                  | ⟨_, _, h⟩ => match Maybe.le.equiv_to_imply.mp h with
                    | Or.inl h => simp [h]; cases (Q i).snd.snd <;> simp;
                    | Or.inr ⟨x',⟨y',⟨hx', hy'⟩⟩⟩ => simp [hx', hy'];
                }
              }
            }
            apply Fin.le_trans;
            {
              apply count_growth_helper_res;
              apply Fin.le_cast cpq;
            }
            {
              apply count_growth_helper_pred;
              exact hpq;
            }
          }
      }
  termination_by count_growth_helper_pred P Q i res h => i

  theorem PropsTriplePred.count_found_helper_eq_pred_res {Pexp : GProd n} (P Q : PropsTriplePred Pexp) (i : Fin n) (res1 res2 : Fin (3*(n-i.val)-2))
                                                    : P ≤ Q → res1 ≤ res2 → P.count_found_helper i res1 = Q.count_found_helper i res2 → P i = Q i ∧ res1 = res2 := by
    intro le_pred le_res;
    rw [count_found_helper, count_found_helper];
    match Nat.decEq i.val 0 with
    | isTrue h =>
      {
        cases le_pred with
        | mk f =>
          {
            simp [h, Fin.cast] at *;
            intro hcount;
            have g := Fin.extended_eq_eq_of_le_le_eq (PropsTriple.count_growth _ _ (f i)) le_res (Fin.eq_of_val_eq hcount);
            exact ⟨PropsTriple.eq_of_le_with_same_count _ _ (f i) g.left,g.right⟩;
          }
      }
    | isFalse h =>
      {
        match le_pred with
        | PropsTriplePred.le.mk f =>
          {
            simp [h, Fin.cast] at *;
            have _ : (Fin.inbound_pred i h).val + 1 < i.val + 1 := by
            {
              apply Nat.add_lt_add_right;
              simp [Fin.inbound_pred];
              apply Nat.pred_lt h;
            }
            intro hcount;
            have g1 : Fin.extended_add (PropsTriple.count_found (P i)) res1 ≤ Fin.extended_add (PropsTriple.count_found (Q i)) res2 := by
            {
              apply Fin.extended_add_le_add;
              {
                apply PropsTriple.count_growth;
                exact f i;
              }
              exact le_res;
            }
            have g2 := count_found_helper_eq_pred_res P Q (Fin.inbound_pred i h) _ _ le_pred g1 hcount;
            have g3 : (Fin.extended_add (PropsTriple.count_found (P i)) res1).val = (Fin.extended_add (PropsTriple.count_found (Q i)) res2).val := by
            {
              have g := Fin.val_eq_of_eq g2.right;
              simp at g;
              exact g;
            }
            have g := Fin.extended_eq_eq_of_le_le_eq (PropsTriple.count_growth _ _ (f i)) le_res (Fin.eq_of_val_eq g3);
            exact ⟨PropsTriple.eq_of_le_with_same_count _ _ (f i) g.left,g.right⟩;
          }
      }
  termination_by PropsTriplePred.count_found_helper_eq_pred_res _ _ i _ _ _ _ _ => i

  theorem PropsTriplePred.count_found_helper_eq_pred_below {Pexp : GProd n} (P Q : PropsTriplePred Pexp) (i : Fin n) (res1 res2 : Fin (3*(n-i.val)-2))
                                                    : P ≤ Q → res1 ≤ res2 → P.count_found_helper i res1 = Q.count_found_helper i res2 → (∀ j, j ≤ i → P j = Q j) := by
    intro le_pred le_res hcount;
    have g1 := count_found_helper_eq_pred_res _ _ _ _ _ le_pred le_res hcount;
    rw [count_found_helper, count_found_helper] at hcount;
    match Nat.decEq i.val 0 with
    | isTrue h =>
      {
        cases i; cases h;
        intro j le_ji;
        cases g1;
        cases j; cases le_ji;
        assumption;
      }
    | isFalse h =>
      {
        have simp_hcount : Nat.decEq i.val 0 = isFalse h := by
        {
          match Nat.decEq i.val 0 with
          | isTrue _ => contradiction
          | isFalse h => rfl
        }
        have _ : (Fin.inbound_pred i h).val + 1 < i.val + 1 := by
        {
          apply Nat.add_lt_add_right;
          simp [Fin.inbound_pred];
          apply Nat.pred_lt h;
        }
        simp [simp_hcount] at hcount;
        match le_pred with
        | PropsTriplePred.le.mk f =>
          {
            have g2 := count_found_helper_eq_pred_res _ _ _ _ _ le_pred (by apply Fin.extended_add_le_add (PropsTriple.count_growth _ _ (f i)) le_res) hcount;
            have g := count_found_helper_eq_pred_below _ _ _ _ _ le_pred (Nat.le_of_eq (Fin.val_eq_of_eq g2.right)) hcount;
            intro j le_ji;
            cases Nat.eq_or_lt_of_le le_ji;
            {
              have eq_ji : j = i := by apply Fin.eq_of_val_eq; assumption;
              rw [eq_ji];
              exact g1.left;
            }
            {
              have lt_ji : j < i := by assumption;
              apply g;
              simp [Fin.inbound_pred];
              apply Nat.le_of_lt_succ;
              simp;
              rw [Nat.succ_pred h];
              exact lt_ji;
            }
          }
      }
  termination_by _ _ i _ _ _ _ _ => i

  theorem PropsTriplePred.count_growth : ∀ {Pexp : GProd n} {P Q : PropsTriplePred Pexp}, P ≤ Q → P.count_found ≤ Q.count_found := by
    intro Pexp P Q hpq;
    simp [count_found, Fin.cast];
    apply count_growth_helper_pred;
    exact hpq;

  theorem PropsTriplePred.eq_of_le_with_same_count : ∀ {Pexp : GProd n} (P Q : PropsTriplePred Pexp), P ≤ Q → P.count_found = Q.count_found → P = Q := by
    intro Pexp P Q hle hcount;
    rw [count_found, count_found] at hcount; simp at hcount;
    have g := count_found_helper_eq_pred_below P Q _ _ _ hle (by apply Nat.le_refl) hcount;
    apply funext;
    intro i;
    apply g i;
    apply Nat.le_sub_of_add_le;
    apply Nat.succ_le_of_lt;
    exact i.isLt;

  def CoherentPred.count_found {Pexp : GProd n} (P : CoherentPred Pexp) : Fin (3*n+1) := P.pred.count_found

  theorem CoherentPred.count_growth : ∀ {Pexp : GProd n} {P Q : CoherentPred Pexp}, P ≤ Q → P.count_found ≤ Q.count_found := by
    intros;
    apply PropsTriplePred.count_growth;
    assumption;

  theorem CoherentPred.eq_of_le_with_same_count : ∀ {Pexp : GProd n} (P Q : CoherentPred Pexp), P ≤ Q → P.count_found = Q.count_found → P = Q := by
    intro Pexp P Q hpq hcount;
    apply CoherentPred.eq_of_eq_pred;
    apply PropsTriplePred.eq_of_le_with_same_count;
    exact hpq;
    exact hcount;

  def compute_props {n : Nat} {Pexp : GProd n} (P : CoherentPred Pexp) : Fixpoint Pexp :=
    let fin_zero : Fin n := Fin.mk 0 Pexp.pos_n;
    let new_P : CoherentPred Pexp := recompute_props fin_zero P;
    have le_pred : P ≤ new_P := recompute_lemma1 fin_zero P;
    match Fin.decEq P.count_found new_P.count_found with
    | isTrue h => {coherent_pred := P, isFixed := by {
        apply Eq.symm;

        apply CoherentPred.eq_of_le_with_same_count P new_P le_pred h;
      }}
    | isFalse h =>
      have _ : 3 * n + 1 - (new_P.count_found).val < 3 * n + 1 - (P.count_found).val := by
      {
        have g : P.count_found < new_P.count_found := by
        {
          match Nat.eq_or_lt_of_le (CoherentPred.count_growth le_pred) with
          | Or.inl g => exact absurd (Fin.eq_of_val_eq g) h;
          | Or.inr g => exact g
        }
        have lem : ∀ {a b c : Nat}, b < a → c < a → b < c → a - c < a - b := by
        {
          intro a b c hba hca hbc;
          induction hbc with
          | refl => rw [Nat.sub_succ]; apply Nat.pred_lt; apply Nat.sub_ne_zero_of_lt hba;
          | step _ ih =>
            rw [Nat.sub_succ]; apply Nat.lt_trans; apply Nat.pred_lt; apply Nat.sub_ne_zero_of_lt;
            apply Nat.lt_of_succ_lt hca; apply ih; exact Nat.lt_of_succ_lt hca;
        }
        apply lem;
        exact P.count_found.isLt;
        exact new_P.count_found.isLt;
        exact g;
      }
      compute_props new_P
  termination_by compute_props n Pexp P => 3 * n + 1 - P.count_found

  def GProd.get_props (Pexp : GProd n) : Fixpoint Pexp :=
    let unknownPred : CoherentPred Pexp := CoherentPred.mk (fun _ => (unknown, unknown, unknown)) (by intro i; constructor <;> simp <;> exact Maybe.le.lhs_unknown);
    compute_props unknownPred

  def getPropF (Pexp : GProd n) (G : PEG n) : Maybe (PropF Pexp) G :=
    let P := Pexp.get_props.pred;
    (g_props G P).fst

  def getProp0 (Pexp : GProd n) (G : PEG n) : Maybe (Prop0 Pexp) G :=
    let P := Pexp.get_props.pred;
    (g_props G P).snd.fst

  def getPropS (Pexp : GProd n) (G : PEG n) : Maybe (PropS Pexp) G :=
    let P := Pexp.get_props.pred;
    (g_props G P).snd.snd

  inductive IsKnown (m : Maybe p a) : Prop where
  | mk : ∀ (h : p a), m = found h → IsKnown m

  theorem IsKnown.ne_of_unknown : ∀ m : Maybe p a, m = unknown → ¬IsKnown m := by
    intro m h_unknown h
    cases h;
    cases h_unknown;
    contradiction;

  theorem IsKnown.unknown_of_ne : ∀ m : Maybe p a, ¬IsKnown m → m = unknown := by
    intro m hne;
    match m with
    | found h => apply absurd _ hne; apply IsKnown.mk h rfl;
    | unknown => rfl

  def IsKnown.from_maybe (m : Maybe p a) : Decidable (IsKnown m) :=
    match m with
    | found h => isTrue (IsKnown.mk h rfl)
    | unknown => isFalse (by apply IsKnown.ne_of_unknown; rfl)

  def IsKnown.get_result {m : Maybe p a} (k : IsKnown m) : p a :=
    match k with
    | mk h _ => h

  inductive StructuralWF (Pexp : GProd n) : PEG n → Prop where
    | ε : StructuralWF Pexp ε
    | any : StructuralWF Pexp any
    | terminal : ∀ (c : Char), StructuralWF Pexp (terminal c)
    | nonTerminal : ∀ (vn : Fin n), StructuralWF Pexp (nonTerminal vn)
    | seq : ∀ (e1 e2 : PEG n), StructuralWF Pexp e1 → StructuralWF Pexp e2 → StructuralWF Pexp (seq e1 e2)
    | prior : ∀ (e1 e2 : PEG n), StructuralWF Pexp e1 → StructuralWF Pexp e2 → StructuralWF Pexp (prior e1 e2)
    | star : ∀ (e : PEG n), StructuralWF Pexp e → ¬IsKnown (getProp0 Pexp e) → StructuralWF Pexp (star e)
    | notP : ∀ (e : PEG n), StructuralWF Pexp e → StructuralWF Pexp (notP e)

  def check_StructuralWF (Pexp : GProd n) (G : PEG n) : Maybe (StructuralWF Pexp) G :=
    match G with
    | ε => found .ε
    | any => found .any
    | terminal c => found (.terminal c)
    | nonTerminal vn => found (.nonTerminal vn)
    | seq e1 e2 => match check_StructuralWF Pexp e1, check_StructuralWF Pexp e2 with
      | found h1, found h2 => found (.seq e1 e2 h1 h2)
      | _, _ => unknown
    | prior e1 e2 => match check_StructuralWF Pexp e1, check_StructuralWF Pexp e2 with
      | found h1, found h2 => found (.prior e1 e2 h1 h2)
      | _, _ => unknown
    | star e => match check_StructuralWF Pexp e, IsKnown.from_maybe (getProp0 Pexp e) with
      | found h1, isFalse h2 => found (.star e h1 h2)
      | _, _ => unknown
    | notP e => match check_StructuralWF Pexp e with
      | found h => found (.notP e h)
      | _ => unknown

  abbrev StructuralWF_GProd (Pexp : GProd n) := ∀ (i : Fin n), StructuralWF Pexp (Pexp.f i)
  abbrev StructuralWF_GProd_partial (u : Fin n) (Pexp : GProd n) := ∀ (i : Fin n), i ≤ u → StructuralWF Pexp (Pexp.f i)

  theorem StructuralWF_GProd.from_partial {Pexp : GProd n} {hlt : n-1 < n} : StructuralWF_GProd_partial {val := n-1, isLt := hlt} Pexp → StructuralWF_GProd Pexp := by
  {
    intro h i;
    apply h;
    apply Nat.le_sub_of_add_le;
    apply Nat.succ_le_of_lt;
    exact i.isLt;
  }

  def check_StructuralWF_GProd_partial (u : Fin n) (Pexp : GProd n) : Maybe (StructuralWF_GProd_partial u) Pexp :=
    let curr_check := check_StructuralWF Pexp (Pexp.f u);
    match curr_check, Nat.decEq u.val 0 with
    | found h, isTrue g => found (by {
      intro i hle;
      have heq : i = u := by apply Fin.eq_of_val_eq; cases u; cases i; simp_all; apply Nat.eq_zero_of_le_zero; exact hle;
      rw [heq];
      exact h;
    })
    | found h, isFalse g => match check_StructuralWF_GProd_partial (Fin.inbound_pred u g) Pexp with
      | found hpred => found (by {
        intro i hle;
        cases Nat.eq_or_lt_of_le hle with
        | inl heq => rw [Fin.eq_of_val_eq heq]; exact h;
        | inr hlt => apply hpred; rw [Fin.inbound_pred]; rw [←Nat.succ_pred g] at hlt; apply Nat.le_of_lt_succ; exact hlt;
      })
      | unknown => unknown
    | unknown, _ => unknown
  termination_by check_StructuralWF_GProd_partial u Pexp => u.val

  def check_StructuralWF_GProd (Pexp : GProd n) : Maybe StructuralWF_GProd Pexp :=
    let max_i : Fin n := Fin.mk (n-1) (by apply Nat.sub_lt Pexp.pos_n; trivial);
    match check_StructuralWF_GProd_partial max_i Pexp with
    | found h => found (StructuralWF_GProd.from_partial h)
    | unknown => unknown

  open Function

  inductive PatternWF {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) (A : Fin n) : PEG n → Prop where
    | ε : PatternWF Pexp σ A ε
    | any : PatternWF Pexp σ A any
    | terminal : ∀ (c : Char), PatternWF Pexp σ A (terminal c)
    | nonTerminal : ∀ (B : Fin n), p B < p A → PatternWF Pexp σ A (nonTerminal B)
    | seq : ∀ (e1 e2 : PEG n), PatternWF Pexp σ A e1 → (IsKnown (getProp0 Pexp e1) → PatternWF Pexp σ A e2) → PatternWF Pexp σ A (seq e1 e2)
    | prior : ∀ (e1 e2 : PEG n), PatternWF Pexp σ A e1 → PatternWF Pexp σ A e2 → PatternWF Pexp σ A (prior e1 e2)
    | star : ∀ (e : PEG n), PatternWF Pexp σ A e → PatternWF Pexp σ A (star e)
    | notP : ∀ (e : PEG n), PatternWF Pexp σ A e → PatternWF Pexp σ A (notP e)

  def check_PatternWF {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) (A : Fin n) (G : PEG n) : Maybe (PatternWF Pexp σ A) G :=
    match G with
    | ε => found .ε
    | any => found .any
    | terminal c => found (.terminal c)
    | nonTerminal B => match Fin.decLt (p B) (p A) with
      | isTrue h => found (.nonTerminal B h)
      | isFalse _ => unknown
    | seq e1 e2 => match check_PatternWF Pexp σ A e1, check_PatternWF Pexp σ A e2 with
      | found h1, found h2 => found (.seq e1 e2 h1 (fun _ => h2))
      | found h1, unknown => match IsKnown.from_maybe (getProp0 Pexp e1) with
        | isTrue _ => unknown
        | isFalse hne => found (.seq e1 e2 h1 (fun h => absurd h hne))
      | unknown, _ => unknown
    | prior e1 e2 => match check_PatternWF Pexp σ A e1, check_PatternWF Pexp σ A e2 with
      | found h1, found h2 => found (.prior e1 e2 h1 h2)
      | found _, unknown | unknown, found _ | unknown, unknown => unknown
    | star e => match check_PatternWF Pexp σ A e with
      | found h => found (.star e h)
      | unknown => unknown
    | notP e => match check_PatternWF Pexp σ A e with
      | found h => found (.notP e h)
      | unknown => unknown

  abbrev PatternWF_GProd {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) := ∀ (i : Fin n), PatternWF Pexp σ i (Pexp.f i)
  abbrev PatternWF_GProd_partial (u : Fin n) {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) := ∀ (i : Fin n), i ≤ u → PatternWF Pexp σ i (Pexp.f i)

  theorem PatternWF_GProd.from_partial {p : Fin n → Fin n} {Pexp : GProd n} {σ : Bijective p} {hlt : n-1 < n} : PatternWF_GProd_partial {val := n-1, isLt := hlt} Pexp σ → PatternWF_GProd Pexp σ := by
  {
    intro h i;
    apply h;
    apply Nat.le_sub_of_add_le;
    apply Nat.succ_le_of_lt;
    exact i.isLt;
  }

  def check_PatternWF_GProd_partial (u : Fin n) {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) : Maybe (PatternWF_GProd_partial u Pexp) σ :=
    let curr_check := check_PatternWF Pexp σ u (Pexp.f u);
    match curr_check, Nat.decEq u.val 0 with
    | found h, isTrue g => found (by {
      intro i hle;
      have heq : i = u := by apply Fin.eq_of_val_eq; cases u; cases i; simp_all; apply Nat.eq_zero_of_le_zero; exact hle;
      rw [heq];
      exact h;
    })
    | found h, isFalse g => match check_PatternWF_GProd_partial (Fin.inbound_pred u g) Pexp σ with
      | found hpred => found (by {
        intro i hle;
        cases Nat.eq_or_lt_of_le hle with
        | inl heq => rw [Fin.eq_of_val_eq heq]; exact h;
        | inr hlt => apply hpred; rw [Fin.inbound_pred]; rw [←Nat.succ_pred g] at hlt; apply Nat.le_of_lt_succ; exact hlt;
      })
      | unknown => unknown
    | unknown, _ => unknown
  termination_by check_PatternWF_GProd_partial u p Pexp σ => u.val

  def check_PatternWF_GProd {p : Fin n → Fin n} (Pexp : GProd n) (σ : Bijective p) : Maybe (PatternWF_GProd Pexp) σ :=
    let max_i : Fin n := Fin.mk (n-1) (by apply Nat.sub_lt Pexp.pos_n; trivial);
    match check_PatternWF_GProd_partial max_i Pexp σ with
    | found h => found (PatternWF_GProd.from_partial h)
    | unknown => unknown

  structure WellformedGrammar (Pexp : GProd n) where
    structural : StructuralWF_GProd Pexp
    pattern : ∃ σ : Bijective p, PatternWF_GProd Pexp σ

  def mapping_from_list (l : List (Fin n)) (length_eq : l.length = n) : Fin n → Fin n :=
    fun i => l.get (Fin.cast (Eq.symm length_eq) i)

  theorem bijective_from_list (l : List (Fin n)) (length_eq : l.length = n) (distinct : ∀ {i j}, l.get i = l.get j → i = j) : Bijective (mapping_from_list l length_eq) := by
    constructor;
    {
      rw [Injective];
      intro i j h;
      rw [mapping_from_list, mapping_from_list] at h;
      have g := Fin.val_eq_of_eq (distinct h);
      simp [Fin.cast] at g;
      apply Fin.eq_of_val_eq g;
    }
    {
      sorry
    }

end Grammar


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.topological_fiber_bundle
import Mathlib.geometry.manifold.smooth_manifold_with_corners
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u_5 l

namespace Mathlib

/-!
# Basic smooth bundles

In general, a smooth bundle is a bundle over a smooth manifold, whose fiber is a manifold, and
for which the coordinate changes are smooth. In this definition, there are charts involved at
several places: in the manifold structure of the base, in the manifold structure of the fibers, and
in the local trivializations. This makes it a complicated object in general. There is however a
specific situation where things are much simpler: when the fiber is a vector space (no need for
charts for the fibers), and when the local trivializations of the bundle and the charts of the base
coincide. Then everything is expressed in terms of the charts of the base, making for a much
simpler overall structure, which is easier to manipulate formally.

Most vector bundles that naturally occur in differential geometry are of this form:
the tangent bundle, the cotangent bundle, differential forms (used to define de Rham cohomology)
and the bundle of Riemannian metrics. Therefore, it is worth defining a specific constructor for
this kind of bundle, that we call basic smooth bundles.

A basic smooth bundle is thus a smooth bundle over a smooth manifold whose fiber is a vector space,
and which is trivial in the coordinate charts of the base. (We recall that in our notion of manifold
there is a distinguished atlas, which does not need to be maximal: we require the triviality above
this specific atlas). It can be constructed from a basic smooth bundled core, defined below,
specifying the changes in the fiber when one goes from one coordinate chart to another one. We do
not require that this changes in fiber are linear, but only diffeomorphisms.

## Main definitions

* `basic_smooth_bundle_core I M F`: assuming that `M` is a smooth manifold over the model with
  corners `I` on `(𝕜, E, H)`, and `F` is a normed vector space over `𝕜`, this structure registers,
  for each pair of charts of `M`, a smooth change of coordinates on `F`. This is the core structure
  from which one will build a smooth bundle with fiber `F` over `M`.

Let `Z` be a basic smooth bundle core over `M` with fiber `F`. We define
`Z.to_topological_fiber_bundle_core`, the (topological) fiber bundle core associated to `Z`. From it,
we get a space `Z.to_topological_fiber_bundle_core.total_space` (which as a Type is just
`Σ (x : M), F`), with the fiber bundle topology. It inherits a manifold structure (where the
charts are in bijection with the charts of the basis). We show that this manifold is smooth.

Then we use this machinery to construct the tangent bundle of a smooth manifold.

* `tangent_bundle_core I M`: the basic smooth bundle core associated to a smooth manifold `M` over a
  model with corners `I`.
* `tangent_bundle I M`     : the total space of `tangent_bundle_core I M`. It is itself a
  smooth manifold over the model with corners `I.tangent`, the product of `I` and the trivial model
  with corners on `E`.
* `tangent_space I x`      : the tangent space to `M` at `x`
* `tangent_bundle.proj I M`: the projection from the tangent bundle to the base manifold

## Implementation notes

In the definition of a basic smooth bundle core, we do not require that the coordinate changes of
the fibers are linear map, only that they are diffeomorphisms. Therefore, the fibers of the
resulting fiber bundle do not inherit a vector space structure (as an algebraic object) in general.
As the fiber, as a type, is just `F`, one can still always register the vector space structure, but
it does not make sense to do so (i.e., it will not lead to any useful theorem) unless this structure
is canonical, i.e., the coordinate changes are linear maps.

For instance, we register the vector space structure on the fibers of the tangent bundle. However,
we do not register the normed space structure coming from that of `F` (as it is not canonical, and
we also want to keep the possibility to add a Riemannian structure on the manifold later on without
having two competing normed space instances on the tangent spaces).

We require `F` to be a normed space, and not just a topological vector space, as we want to talk
about smooth functions on `F`. The notion of derivative requires a norm to be defined.

## TODO
construct the cotangent bundle, and the bundles of differential forms. They should follow
functorially from the description of the tangent bundle as a basic smooth bundle.

## Tags
Smooth fiber bundle, vector bundle, tangent space, tangent bundle
-/

/-- Core structure used to create a smooth bundle above `M` (a manifold over the model with
corner `I`) with fiber the normed vector space `F` over `𝕜`, which is trivial in the chart domains
of `M`. This structure registers the changes in the fibers when one changes coordinate charts in the
base. We do not require the change of coordinates of the fibers to be linear, only smooth.
Therefore, the fibers of the resulting bundle will not inherit a canonical vector space structure
in general. -/
structure basic_smooth_bundle_core {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] (I : model_with_corners 𝕜 E H) (M : Type u_4) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (F : Type u_5) [normed_group F] [normed_space 𝕜 F]
where
  coord_change : ↥(charted_space.atlas H M) → ↥(charted_space.atlas H M) → H → F → F
  coord_change_self : ∀ (i : ↥(charted_space.atlas H M)) (x : H),
  x ∈ local_equiv.target (local_homeomorph.to_local_equiv (subtype.val i)) → ∀ (v : F), coord_change i i x v = v
  coord_change_comp : ∀ (i j k : ↥(charted_space.atlas H M)) (x : H),
  x ∈
      local_equiv.source
        (local_homeomorph.to_local_equiv
          (local_homeomorph.trans (local_homeomorph.trans (local_homeomorph.symm (subtype.val i)) (subtype.val j))
            (local_homeomorph.trans (local_homeomorph.symm (subtype.val j)) (subtype.val k)))) →
    ∀ (v : F),
      coord_change j k (coe_fn (local_homeomorph.trans (local_homeomorph.symm (subtype.val i)) (subtype.val j)) x)
          (coord_change i j x v) =
        coord_change i k x v
  coord_change_smooth : ∀ (i j : ↥(charted_space.atlas H M)),
  times_cont_diff_on 𝕜 ⊤
    (fun (p : E × F) => coord_change i j (coe_fn (model_with_corners.symm I) (prod.fst p)) (prod.snd p))
    (set.prod
      (⇑I ''
        local_equiv.source
          (local_homeomorph.to_local_equiv
            (local_homeomorph.trans (local_homeomorph.symm (subtype.val i)) (subtype.val j))))
      set.univ)

/-- The trivial basic smooth bundle core, in which all the changes of coordinates are the
identity. -/
def trivial_basic_smooth_bundle_core {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] (I : model_with_corners 𝕜 E H) (M : Type u_4) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] (F : Type u_5) [normed_group F] [normed_space 𝕜 F] : basic_smooth_bundle_core I M F :=
  basic_smooth_bundle_core.mk (fun (i j : ↥(charted_space.atlas H M)) (x : H) (v : F) => v) sorry sorry sorry

namespace basic_smooth_bundle_core

protected instance inhabited {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] : Inhabited (basic_smooth_bundle_core I M F) :=
  { default := trivial_basic_smooth_bundle_core I M F }

/-- Fiber bundle core associated to a basic smooth bundle core -/
def to_topological_fiber_bundle_core {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) : topological_fiber_bundle_core (↥(charted_space.atlas H M)) M F :=
  topological_fiber_bundle_core.mk
    (fun (i : ↥(charted_space.atlas H M)) => local_equiv.source (local_homeomorph.to_local_equiv (subtype.val i))) sorry
    (fun (x : M) => { val := charted_space.chart_at H x, property := charted_space.chart_mem_atlas H x }) sorry
    (fun (i j : ↥(charted_space.atlas H M)) (x : M) (v : F) => coord_change Z i j (coe_fn (subtype.val i) x) v) sorry
    sorry sorry

@[simp] theorem base_set {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) (i : ↥(charted_space.atlas H M)) : topological_fiber_bundle_core.base_set (to_topological_fiber_bundle_core Z) i =
  local_equiv.source (local_homeomorph.to_local_equiv (subtype.val i)) :=
  rfl

/-- Local chart for the total space of a basic smooth bundle -/
def chart {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) {e : local_homeomorph M H} (he : e ∈ charted_space.atlas H M) : local_homeomorph (topological_fiber_bundle_core.total_space (to_topological_fiber_bundle_core Z)) (model_prod H F) :=
  local_homeomorph.trans
    (topological_fiber_bundle_core.local_triv (to_topological_fiber_bundle_core Z) { val := e, property := he })
    (local_homeomorph.prod e (local_homeomorph.refl F))

@[simp] theorem chart_source {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) (e : local_homeomorph M H) (he : e ∈ charted_space.atlas H M) : local_equiv.source (local_homeomorph.to_local_equiv (chart Z he)) =
  topological_fiber_bundle_core.proj (to_topological_fiber_bundle_core Z) ⁻¹'
    local_equiv.source (local_homeomorph.to_local_equiv e) := sorry

@[simp] theorem chart_target {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) (e : local_homeomorph M H) (he : e ∈ charted_space.atlas H M) : local_equiv.target (local_homeomorph.to_local_equiv (chart Z he)) =
  set.prod (local_equiv.target (local_homeomorph.to_local_equiv e)) set.univ := sorry

/-- The total space of a basic smooth bundle is endowed with a charted space structure, where the
charts are in bijection with the charts of the basis. -/
protected instance to_charted_space {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] {I : model_with_corners 𝕜 E H} {M : Type u_4} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {F : Type u_5} [normed_group F] [normed_space 𝕜 F] (Z : basic_smooth_bundle_core I M F) : charted_space (model_prod H F) (topologi


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

! This file was ported from Lean 3 source module category_theory.isomorphism_classes
! leanprover-community/mathlib commit 28aa996fc6fb4317f0083c4e6daf79878d81be33
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Cat
import Mathlib.CategoryTheory.Groupoid
import Mathlib.CategoryTheory.Types

/-!
# Objects of a category up to an isomorphism

`IsIsomorphic X Y := Nonempty (X ≅ Y)` is an equivalence relation on the objects of a category.
The quotient with respect to this relation defines a functor from our category to `Type`.
-/

universe v u

namespace CategoryTheory

section Category

variable {C : Type u} [Category.{v} C]

/-- An object `X` is isomorphic to an object `Y`, if `X ≅ Y` is not empty. -/
def IsIsomorphic : C → C → Prop := fun X Y => Nonempty (X ≅ Y)
#align category_theory.is_isomorphic CategoryTheory.IsIsomorphic

variable (C)

/-- `IsIsomorphic` defines a setoid. -/
def isIsomorphicSetoid : Setoid C where
  r := IsIsomorphic
  iseqv := ⟨fun X => ⟨Iso.refl X⟩, fun ⟨α⟩ => ⟨α.symm⟩, fun ⟨α⟩ ⟨β⟩ => ⟨α.trans β⟩⟩
#align category_theory.is_isomorphic_setoid CategoryTheory.isIsomorphicSetoid

end Category

/-- The functor that sends each category to the quotient space of its objects up to an isomorphism.
-/
def isomorphismClasses : Cat.{v, u} ⥤ Type u where
  obj C := Quotient (isIsomorphicSetoid C.α)
  map {C D} F := Quot.map F.obj fun X Y ⟨f⟩ => ⟨F.mapIso f⟩
  map_id {C} := by  -- Porting note: this used to be `tidy`
    dsimp; apply funext; intro x
    apply x.recOn  -- Porting note: `induction x` not working yet
    · intro _ _ p
      simp only [types_id_apply]
    · intro _
      rfl
  map_comp {C D E} f g := by -- Porting note(s): idem
    dsimp; apply funext; intro x
    apply x.recOn
    · intro _ _ _
      simp only [types_id_apply]
    · intro _
      rfl
#align category_theory.isomorphism_classes CategoryTheory.isomorphismClasses

end CategoryTheory