(**#+TITLE: galoisSolution.v

Proph

https://github.com/1337777/galois/blob/master/galoisSolution.v

solves some question of Galois [fn:1] which is how to program grammatical ("classifying")
functors-topos of some graph.

This starting lemma of polymorph mathematics ("categories") :

Coreflections( Set , Funtors( C* , Prop ) ) <=> Funtors( C , Set )

says that the senses ("functors models") onfrom some given primitive-syntax graph may be
instead dually-usefully-viewed as senses ("coreflective-functors models") into some
more-complete-grammatical ("classifying") functors-topos. And this starting lemma may be
upgraded such to perceive flat functors via geometric morphisms into some presheaf
functors-topos. Also this starting lemma may be upgraded such to perceive continuous flat
functors via geometric morphisms into some sheaf functors-topos ...

The question is whether these new more-complete-grammatical functors-topos are relatively
computational/decidable ? Some promised COQ program shall/may OK these. Promise only ...

[fn:1] ~Galois~ «Théorie des topos et cohomologie étale des schémas»

**)

(**

#+BEGIN_SRC coq :exports both :results silent **)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun eqtype ssrnat seq fintype.
Require Import Setoid.
Require Omega.

(**#+END_SRC

#+BEGIN_SRC coq :exports both :results silent **)

Module METAFUNCTORS.

Global Set Implicit Arguments.
Global Unset Strict Implicit.
Global Unset Printing Implicit Defensive.

Parameter obIndexer : Type (* regular cardinal *).
Parameter Indexer : obIndexer -> obIndexer -> Type (* regular cardinal *).
Notation "''Indexer' (0 A1 ~> A2 )0" :=
  (@Indexer A1 A2) (at level 25, format "''Indexer' (0  A1  ~>  A2  )0").
Parameter polyIndexer : forall (A2 A1 : obIndexer),
    Indexer A2 A1 -> forall A1' : obIndexer, (Indexer A1 A1') -> (Indexer A2 A1').
Notation "a_ o>Indexer a'" :=
  (@polyIndexer _ _ a_ _ a') (at level 25, right associativity).
Parameter unitIndexer : forall {A : obIndexer}, Indexer A A.
Parameter convIndexer : forall (A1 A2 : obIndexer),
    'Indexer(0 A1 ~> A2 )0 -> 'Indexer(0 A1 ~> A2 )0 -> Prop.
Notation "a2 ~~ a1" := (@convIndexer _ _ a2 a1) (at level 70).

Inductive obTopos : Type (* larger cardinal *) :=
| View0 : forall A : obIndexer, obTopos
| MetaFunctor : forall (func0 : obIndexer -> Type (* regular cardinal *))
                  (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    obTopos.

Reserved Notation "''Topos' (0 F1 ~> F2 )0"
         (at level 25, format "''Topos' (0  F1  ~>  F2  )0").

Inductive Topos00 : obTopos -> obTopos -> Type (* larger cardinal, possible *) :=

| UnitTopos : forall {F : obTopos}, 'Topos(0 F ~> F )0

| PolyTopos : forall (F2 : obTopos) (F1 : obTopos)
  , 'Topos(0 F2 ~> F1 )0 -> forall F1' : obTopos,
      'Topos(0 F1 ~> F1' )0 -> 'Topos(0 F2 ~> F1' )0

| View1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 ->
                                'Topos(0 (View0 A) ~> (View0 A') )0

| PolyMetaFunctor :
    forall (func0 : obIndexer -> Type (* same, regular cardinal *))
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      (forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0)

| PolyMetaTransf :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (func'0 : obIndexer -> Type)
      (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
    forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
      (forall (A : obIndexer), 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0
                          -> 'Topos(0 (View0 A) ~> (MetaFunctor func'1) )0)

| CoLimitator :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall F : obTopos,
    forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      (* cocone func1 v_ ->    cocone erased *)
      'Topos(0 (MetaFunctor func1) ~> F )0

where "''Topos' (0 F1 ~> F2 )0" := (@Topos00 F1 F2).

Notation "'uTopos'" := (@UnitTopos _)(at level 0).
Notation "@ 'uTopos' F" :=
  (@UnitTopos F) (at level 11, only parsing).

Notation "f_ o>Topos f'" :=
  (@PolyTopos _ _ f_ _ f') (at level 25, right associativity).

Notation "f o>Topos_ transf @ func'1" :=
  (@PolyMetaTransf _ _ _ func'1 transf _ f) (at level 25, transf at level 0, right associativity).

Notation "f o>Topos_ transf" :=
  (@PolyMetaTransf _ _ _ _ transf _ f) (at level 25, transf at level 0, right associativity).

Notation "[[ v_ @ func1 ]]" :=
  (@CoLimitator _ func1 _ v_ ) (at level 0).

Notation "[[ v_ ]]" :=
  (@CoLimitator _ _ _ v_ ) (at level 0).

Ltac rewriterTopos :=
  repeat match goal with
         | [ HH : @eq (Topos00 _ _) _ _  |- _ ] =>
           try rewrite -> HH in *; clear HH
         end.

Reserved Notation "f2 ~~~ f1"  (at level 70).

Inductive convTopos : forall (F1 F2 : obTopos),
    'Topos(0 F1 ~> F2 )0 -> 'Topos(0 F1 ~> F2 )0 -> Prop :=

(* equivalence *)

| Topos_Refl : forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
    f ~~~ f

| Topos_Trans : forall (F1 F2 : obTopos) (uTrans f : 'Topos(0 F1 ~> F2 )0),
    uTrans ~~~ f -> forall (f0 : 'Topos(0 F1 ~> F2 )0),
      f0 ~~~ uTrans -> f0 ~~~ f

| Topos_Sym : forall (F1 F2 : obTopos) (f f0 : 'Topos(0 F1 ~> F2 )0),
    f ~~~ f0 -> f0 ~~~ f

(* congruences *)

| PolyTopos_cong :
    forall (F F' : obTopos) (f_ f_0 : 'Topos(0 F ~> F' )0),
    forall (F'' : obTopos) (f' f'0 : 'Topos(0 F' ~> F'' )0),
      f_0 ~~~ f_ -> f'0 ~~~ f' -> ( f_0 o>Topos f'0 ) ~~~ ( f_ o>Topos f' )

| View_cong : forall (A A' : obIndexer) (a a0 : 'Indexer(0 A ~> A' )0),
    a0 ~~ a -> View1 a0 ~~~ ( View1 a
                             : 'Topos(0 View0 A ~> View0 A' )0 )

| PolyMetaFunctor_cong :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (A : obIndexer) (x x0 : func0 A),
      x0 = x -> PolyMetaFunctor func1 x0 ~~~ ( (PolyMetaFunctor func1 x)
                                              : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0)

| PolyMetaTransf_cong :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (func'0 : obIndexer -> Type)
      (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
    forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
    forall (A : obIndexer) (v v0 : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0),
      (* none lack to hold changes to transf because no such changes and uniform *)
      v0 ~~~ v -> v0 o>Topos_transf ~~~ ( v o>Topos_transf
                                          : 'Topos(0 (View0 A) ~> (MetaFunctor func'1) )0 )

| CoLimitator_cong :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall F : obTopos,
    forall (v_ v_0 : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      (* cocone func1 f_ ->    cocone erased *)
      ( forall (A : obIndexer) (x : func0 A), v_0 A x ~~~ v_ A x )
      ->  [[ v_0 @ func1 ]] ~~~ ( [[ v_ @ func1 ]]
                                 : 'Topos(0 MetaFunctor func1 ~> F )0 )

(* units *)

| Topos_unit :
    forall (F F' : obTopos) (f : 'Topos(0 F ~> F' )0),
      ( f )
        ~~~ ( ( uTopos ) o>Topos f
              : 'Topos(0 F ~> F' )0 )

| Topos_inputUnitTopos :
    forall (G F : obTopos) (g : 'Topos(0 G ~> F )0),
      ( g )
        ~~~  ( g o>Topos ( uTopos )
               : 'Topos(0 G ~> F )0 )

(* for sense only, non-necessary for reduction *)
| View_unitIndexer : forall (A : obIndexer),
    ( @UnitTopos (View0 A) )
      ~~~ ( View1 (@unitIndexer A)
            : 'Topos(0 View0 A ~> View0 A )0 )

(* polymorphism *)

(* non for reduction *)
| Topos_morphism :
    forall (G F : obTopos) (g : 'Topos(0 G ~> F )0)
      (F' : obTopos) (f_ : 'Topos(0 F ~> F' )0)
      (F'' : obTopos) (f' : 'Topos(0 F' ~> F'' )0),
      ( g o>Topos ( f_ o>Topos f' ) )
        ~~~ ( ( g o>Topos f_ ) o>Topos f'
              : 'Topos(0 G ~> F'' )0 )

| View_polyIndexer : forall (A A' : obIndexer) (a : 'Indexer(0 A ~> A' )0)
                       (A'' : obIndexer) (a' : 'Indexer(0 A' ~> A'' )0),
    (View1 (a o>Indexer a'))
      ~~~ ( (View1 a) o>Topos (View1 a')
            : 'Topos(0 View0 A ~> View0 A'' )0 )

(* functoriality-polymorphism follows from this _cocone property and
associativity-polymorphism of PolyTopos and functoriality-polymorphism
of View1 *)
| PolyMetaFunctor_cocone :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (A : obIndexer) (x : func0 A) (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
      ( PolyMetaFunctor func1 (func1 _ _ a x) )
        ~~~ ( (View1 a) o>Topos (PolyMetaFunctor func1 x)
              : 'Topos(0 View0 A' ~> MetaFunctor func1 )0 )

(* naturality-polymorphism is this, which is in operational form *)
| PolyMetaTransf_poly :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (func'0 : obIndexer -> Type)
      (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A)
      (transf : forall A : obIndexer, func0 A -> func'0 A),
    forall (A : obIndexer) (v : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0)
      (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
      ( ((View1 a) o>Topos v) o>Topos_transf )
        ~~~ ( (View1 a) o>Topos (v o>Topos_transf)
              : 'Topos(0 View0 A' ~> MetaFunctor func'1 )0 )

(* naturality-polymorphism of the bijection*)
| CoLimitator_morphism :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (F : obTopos) (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
    forall (F' : obTopos) (f : 'Topos(0 F ~> F' )0),
      ( [[ (fun A x => (v_ A x) o>Topos f) @ func1 ]] )
        ~~~ ( [[ v_ @ func1 ]] o>Topos f
              : 'Topos(0 MetaFunctor func1 ~> F' )0 )

| PolyMetaFunctor_CoLimitator :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall F : obTopos,
    forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
    forall (A : obIndexer) (x : func0 A),
      ( v_ A x )
        ~~~ ( (PolyMetaFunctor func1 x) o>Topos [[ v_ @ func1 ]]
              : 'Topos(0 View0 A ~> F )0 )

| PolyMetaTransf_CoLimitator :
    forall (func'0 : obIndexer -> Type)
      (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
    forall F : obTopos,
    forall (v_ : forall (A : obIndexer), func'0 A -> 'Topos(0 (View0 A) ~> F )0),
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (transf : forall (A : obIndexer), func0 A -> func'0 A)
      (A : obIndexer) (w : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0),
      (w o>Topos [[ (fun A0 => (v_ A0) \o (transf A0)) @ func1 ]])
        ~~~ (w o>Topos_transf) o>Topos [[ v_ @ func'1 ]]

(* for sense only, non-necessary for reduction *)
| PolyMetaTransf_PolyMetaFunctor :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (func'0 : obIndexer -> Type)
      (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A)
      (transf : forall A : obIndexer, func0 A -> func'0 A),
    forall (A : obIndexer) (x : func0 A),
      ( PolyMetaFunctor func'1 (transf A x) )
        ~~~ ( (PolyMetaFunctor func1 x o>Topos_transf)
              : 'Topos(0 View0 A ~> MetaFunctor func'1 )0 )

(* for sense only, non-necessary for reduction *)
| CoLimitator_PolyMetaFunctor :
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      ( @UnitTopos (MetaFunctor func1) )
        ~~~ ( [[ PolyMetaFunctor func1 ]]
              : 'Topos(0 (MetaFunctor func1) ~> (MetaFunctor func1) )0 )

where "f2 ~~~ f1" := (@convTopos _ _ f2 f1).

Hint Constructors convTopos.

Definition cocone_def :=
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (F : obTopos)
      (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      forall (A : obIndexer) (x : func0 A) (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
      ( v_ A' (func1 _ _ a x) )
        ~~~ ( (View1 a) o>Topos (v_ A x)
              : 'Topos(0 View0 A' ~> F )0 ) .

Notation cocone func1 v_ :=
  (forall (A : obIndexer) (x : _ A) (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
      ( v_ A' (func1 _ _ a x) )
        ~~~ ( (View1 a) o>Topos (v_ A x)
              : 'Topos(0 View0 A' ~> _ )0 )) .

Check
    forall (func0 : obIndexer -> Type)
      (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
    forall (F : obTopos)
      (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      cocone func1 v_ ->
      'Topos(0 (MetaFunctor func1) ~> F )0.

Module Sol.

  Section Section1.

    Inductive Topos00 : obTopos -> obTopos -> Type :=

    | UnitTopos : forall {F : obTopos}, 'Topos(0 F ~> F )0

    | View1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 ->
                                    'Topos(0 (View0 A) ~> (View0 A') )0

    | PolyMetaFunctor :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
          (forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0)

    | PolyMetaTransf :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        forall (func'0 : obIndexer -> Type)
          (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
        forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
          (forall (A : obIndexer), 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0
                              -> 'Topos(0 (View0 A) ~> (MetaFunctor func'1) )0)

    | CoLimitator :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        forall F : obTopos,
        forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
          (* cocone func1 v_ ->    cocone erased *)
          'Topos(0 (MetaFunctor func1) ~> F )0

    where "''Topos' (0 F1 ~> F2 )0" := (@Topos00 F1 F2).

  End Section1.

  Module Import Ex_Notations.
    Delimit Scope sol_scope with sol.
    Notation "''Topos' (0 F1 ~> F2 )0" := (@Topos00 F1 F2) : sol_scope.
    Notation "'uTopos'" := (@UnitTopos _)(at level 0) : sol_scope.
    Notation "@ 'uTopos' F" :=
      (@UnitTopos F) (at level 11, only parsing) : sol_scope.

    Notation "f o>Topos_ transf @ func'1" :=
      (@PolyMetaTransf _ _ _ func'1 transf _ f) (at level 25, transf at level 0, right associativity) : sol_scope.

    Notation "f o>Topos_ transf" :=
      (@PolyMetaTransf _ _ _ _ transf _ f) (at level 25, transf at level 0, right associativity) : sol_scope.

    Notation "[[ v_ @ func1 ]]" :=
      (@CoLimitator _ func1 _ v_ ) (at level 0) : sol_scope.

    Notation "[[ v_ ]]" :=
      (@CoLimitator _ _ _ v_ ) (at level 0) : sol_scope.
  End Ex_Notations.

  Definition toTopos :
    forall (F1 F2 : obTopos), 'Topos(0 F1 ~> F2 )0 %sol -> 'Topos(0 F1 ~> F2 )0.
  Proof.
    (move => F1 F2 f); elim : F1 F2 / f =>
    [ F
    | A A' a
    | func0 func1 A x
    | func0 func1 func'0 func'1 transf A fSol fSol_toMod
    | func0 func1 F vSol_ vSol_toMod ];
      [ apply: (@uTopos F)
      | apply: (METAFUNCTORS.View1 a)
      | apply: (METAFUNCTORS.PolyMetaFunctor func1 x)
      | apply: (fSol_toMod o>Topos_transf)
      | apply: [[ vSol_toMod ]]
      ].
  Defined.

  Module Destruct_domView.

    Inductive Topos00_domView : forall (A : obIndexer) (F2 : obTopos),
      ( 'Topos(0 View0 A ~> F2 )0 %sol ) -> Type :=

    | UnitTopos : forall {A : obIndexer}, Topos00_domView (@uTopos (View0 A))%sol

    | View1 : forall (A A' : obIndexer) (a : 'Indexer(0 A ~> A' )0),
        Topos00_domView (Sol.View1 a)%sol

    | PolyMetaFunctor :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        forall (A : obIndexer) (x : func0 A),
          Topos00_domView (Sol.PolyMetaFunctor func1 x)%sol

    | PolyMetaTransf :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        forall (func'0 : obIndexer -> Type)
          (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
        forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
          forall (A : obIndexer) (f : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0 %sol),
              Topos00_domView (f o>Topos_transf @ func'1)%sol .

    Lemma Topos00_domViewP : forall F1 F2 ( f : 'Topos(0 F1 ~> F2 )0 %sol ),
           match F1 as o return (forall F2 : obTopos, ('Topos(0 o ~> F2 )0)%sol -> Type) with
           | View0 A => fun F2 : obTopos => [eta Topos00_domView (F2:=F2)]
           | @MetaFunctor func0 func1 =>
             fun _ _  => unit
           end F2 f.
    Proof.
      intros. case: F1 F2 / f.
      - destruct F. constructor 1.  exact: tt.
      - constructor 2.
      - constructor 3.
      - constructor 4.
      - intros. exact: tt.
    Defined.

  End Destruct_domView.

  Module Destruct_domMetaFunctor.

    Inductive Topos00_domMetaFunctor :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (F2 : obTopos),
        ( 'Topos(0 MetaFunctor func1 ~> F2 )0 %sol ) -> Type :=

    | UnitTopos : forall (func0 : obIndexer -> Type)
                    (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        Topos00_domMetaFunctor (@uTopos (MetaFunctor func1))%sol

    | CoLimitator :
        forall (func0 : obIndexer -> Type)
          (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        forall F : obTopos,
        forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0 %sol),
          Topos00_domMetaFunctor ([[ v_ @ func1 ]] %sol).

    Lemma Topos00_domMetaFunctorP : forall F1 F2 ( f : 'Topos(0 F1 ~> F2 )0 %sol ),
           match F1 as o return (forall F2 : obTopos, ('Topos(0 o ~> F2 )0)%sol -> Type) with
           | View0 A => fun _ _  => unit
           | @MetaFunctor func0 func1 =>
             fun F2 : obTopos => [eta Topos00_domMetaFunctor (F2:=F2)]
           end F2 f.
    Proof.
      intros. case: F1 F2 / f.
      - destruct F.  exact: tt. constructor 1.
      - intros. exact: tt.
      - intros. exact: tt.
      - intros. exact: tt.
      - constructor 2.
    Defined.

  End Destruct_domMetaFunctor.

End Sol.

Module isSol.

  Inductive isSol : forall (F1 F2 : obTopos),
    'Topos(0 F1 ~> F2 )0 -> Prop :=

  | UnitTopos : forall {F : obTopos}, isSol (@uTopos F)

  | View1 : forall (A A' : obIndexer), forall (a : 'Indexer(0 A ~> A' )0),
        isSol (METAFUNCTORS.View1 a)

  | PolyMetaFunctor :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (A : obIndexer), forall (x : func0 A), isSol (METAFUNCTORS.PolyMetaFunctor func1 x)

  | PolyMetaTransf :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (func'0 : obIndexer -> Type)
        (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
      forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
      forall (A : obIndexer), forall (f : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0),
          isSol f -> isSol (f o>Topos_transf : 'Topos(0 (View0 A) ~> (MetaFunctor func'1) )0 )

  | CoLimitator :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall F : obTopos,
      forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
        (* cocone func1 v_ ->    cocone erased *)
        (forall A x, isSol (v_ A x)) -> isSol ([[v_ @ func1 ]]).

  Definition regularCardinalAll : forall (obIndexer : Type) (func0 : obIndexer -> Type),
      (forall (A : obIndexer), func0 A -> bool) -> bool.
  Admitted.

  Lemma regularCardinalAllP : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                                (b_ : forall (A : obIndexer), func0 A -> bool),
      reflect (exists A, exists x, ~~ b_ A x) (~~ regularCardinalAll b_).
  Admitted.

  Definition isSolbb : forall (F1 F2 : obTopos), forall (f : 'Topos(0 F1 ~> F2 )0), bool.
    move => F1 F2 f. elim: F1 F2 /f.
    - intros. exact: true.
    - intros. exact: false.
    - intros. exact: true.
    - intros. exact: true.
    - intros. assumption.
    - intros func0 func1 F v_ IH_v_. exact: (regularCardinalAll IH_v_).
  Defined.

  Lemma isSolbbP : forall (F1 F2 : obTopos), forall (f : 'Topos(0 F1 ~> F2 )0),
        reflect (isSol f) (isSolbb f).
  Admitted.

  Import Sol.Ex_Notations.
  Lemma isSolbbP2 : forall (F1 F2 : obTopos), forall (f : 'Topos(0 F1 ~> F2 )0),
        reflect (exists fSol : 'Topos(0 F1 ~> F2 )0 %sol , Sol.toTopos fSol = f) (isSolbb f).
  Admitted.

  Lemma topos_functional_extensionality :
    forall (func0 : obIndexer -> Type)
      (func1 : forall A A' : obIndexer, 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A)
      (F : obTopos)
      (f_ g_ : forall A : obIndexer, func0 A -> ('Topos(0 View0 A ~> F )0)),
      (forall A x, f_ A x = g_ A x ) -> f_ = g_ .
  Admitted.

  Lemma isSolbb_isSol : forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      isSolbb f -> ({ fSol : 'Topos(0 F1 ~> F2 )0 %sol | Sol.toTopos fSol = f}).
  Proof.
    move => F1 F2 f ; elim : F1 F2 / f =>
    [ F _  (* @uTopos F %sol*)
    | //
    | A A' a (* Sol.View1 a *)
    | func0 func1 A x _ (* Sol.PolyMetaFunctor func1 x *)
    | func0 func1 func'0 func'1 transf A f  (* f o>Topos_transf %sol *)
    | func0 func1 F f_ ] (* [[ f_ @ func1 ]] %sol *).
    - exists ((@uTopos F)%sol). reflexivity.
    - exists ((Sol.View1 a)%sol). reflexivity.
    - exists ((Sol.PolyMetaFunctor func1 x)%sol). reflexivity.
    - move => H /H [fSol fSol_prop].
      exists ((fSol o>Topos_transf)%sol). by subst.
    - move => IH /= /regularCardinalAllP f_isSolbb.
      have f_isSolbb' : (forall (A : obIndexer) (x : func0 A), isSolbb (f_ A x))
        by intros; clear -f_isSolbb; apply/negPn/negP; intuition eauto.
      set fSol_ := (fun A x => projT1(IH A x (f_isSolbb' A x))).
      set fSol_prop := (fun A x => projT2(IH A x (f_isSolbb' A x))).
      exists ([[ fSol_ ]] %sol). simpl; apply: congr1.
      apply: (topos_functional_extensionality func1).
        by move => A x; move: fSol_prop => <- .
  Qed.

  Lemma isSolbbN_isSolN : forall (F1 F2 : obTopos),
      forall fSol : 'Topos(0 F1 ~> F2 )0 %sol, forall (f : 'Topos(0 F1 ~> F2 )0), (Sol.toTopos fSol) = f -> isSolbb f.
  Proof.
    move => F1 F2 fSol ; elim : F1 F2 / fSol ; try (intros; subst; reflexivity).
    intros; subst; simpl. intuition.
    intros; subst; simpl. apply/regularCardinalAllP.
    move => [A [x isSolbb_v_] ]. move: isSolbb_v_. apply/negP/negPn. eapply H; reflexivity.
  Qed.

  Lemma isSolbbN_isSolN_alt : forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      ~~ isSolbb f ->  ~ ( exists fSol : 'Topos(0 F1 ~> F2 )0 %sol , (Sol.toTopos fSol) = f ).
  Proof.
    intros F1 F2 f f_isSolbbN []. move: f_isSolbbN. apply/negP/negPn. apply: isSolbbN_isSolN.
    eauto.
  Qed.

End isSol.

Definition regularCardinalMax : forall (obIndexer : Type (* regular cardinal *))
                                  (func0 : obIndexer -> Type (* same, regular cardinal *))
                                  (filter : (forall (A : obIndexer), func0 A -> Prop)),
    (forall (A : obIndexer), func0 A -> nat) -> nat.
Admitted.
Lemma regularCardinalMax_falsefilter : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                                         (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
      (forall A x, filter A x <-> False) ->
      regularCardinalMax filter v_ = 0 .
Admitted.
Lemma regularCardinalMax_subfilter : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                                       (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
    forall (filter' : (forall (A : obIndexer), func0 A -> Prop)),
      (forall A x, filter' A x -> filter A x) ->
      ( regularCardinalMax filter' v_ <= regularCardinalMax filter v_ )%coq_nat.
Admitted.
Lemma regularCardinalMax_samefilter : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                                       (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
    forall (filter' : (forall (A : obIndexer), func0 A -> Prop)),
      (forall A x, filter' A x <-> filter A x) ->
      ( regularCardinalMax filter' v_ = regularCardinalMax filter v_ )%coq_nat.
Admitted.
Lemma regularCardinalMax_unionfilter : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                                       (filter filter' : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
      ( regularCardinalMax (fun A x => filter A x \/ filter' A x) v_ <= (regularCardinalMax filter v_ + regularCardinalMax filter' v_)%coq_nat )%coq_nat.
Admitted.
Lemma regularCardinalMax_congr : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (w_ v_ : forall (A : obIndexer), func0 A -> nat),
      (forall A x, filter A x -> ( w_ A x = v_ A x )%coq_nat) ->
      ( regularCardinalMax filter w_ = regularCardinalMax filter v_ )%coq_nat.
Admitted.
Lemma regularCardinalMax_monotone_ge : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (w_ v_ : forall (A : obIndexer), func0 A -> nat),
      (forall A x, filter A x -> ( w_ A x <= v_ A x )%coq_nat) ->
      ( regularCardinalMax filter w_ <= regularCardinalMax filter v_ )%coq_nat.
Admitted.
Lemma regularCardinalMax_monotone_gt : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (w_ v_ : forall (A : obIndexer), func0 A -> nat),
      (forall A x, filter A x -> ( w_ A x < v_ A x )%coq_nat) ->
      forall A x, filter A x -> ( w_ A x < v_ A x )%coq_nat ->
             ( regularCardinalMax filter w_ < regularCardinalMax filter v_ )%coq_nat.
Admitted.
Lemma regularCardinalMax_addr_const : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat) (n : nat),
      regularCardinalMax filter (fun A x => (v_ A x + n)%coq_nat) = ((regularCardinalMax filter v_) + n)%coq_nat.
Admitted.
Lemma regularCardinalMax_addl_const : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat) (n : nat),
      regularCardinalMax filter (fun A x => (n + v_ A x)%coq_nat) = (n + (regularCardinalMax filter v_))%coq_nat.
Admitted.
Lemma regularCardinalMax_add_succ : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                            (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
      regularCardinalMax filter (fun A x => S (v_ A x)%coq_nat) = (S (regularCardinalMax filter v_))%coq_nat.
Admitted.
Lemma regularCardinalMax_add_le : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                       (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (w_ v_ : forall (A : obIndexer), func0 A -> nat),
      (regularCardinalMax filter (fun A x => (w_ A x + v_ A x)%coq_nat) <= ((regularCardinalMax filter w_) + (regularCardinalMax filter v_))%coq_nat)%coq_nat.
Admitted.
Lemma regularCardinalMax_ge : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                   (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat) A (x : func0 A),
      filter A x -> ( (v_ A x) <= (regularCardinalMax filter v_) )%coq_nat .
Admitted.
Lemma regularCardinalMax_transf : forall (obIndexer : Type) (func0 : obIndexer -> Type)
                       (filter : (forall (A : obIndexer), func0 A -> Prop)),
    forall (v_ : forall (A : obIndexer), func0 A -> nat),
    forall (func'0 : obIndexer -> Type) (transf : forall (A : obIndexer), func'0 A -> func0 A),
      ( regularCardinalMax (fun A => filter A \o transf A) (fun A => v_ A \o transf A) <= regularCardinalMax filter v_ )%coq_nat .
Admitted.

Fixpoint grade (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0) {struct f} : nat
with gradeMaxCom (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0) {struct f} : nat
with gradeTotal (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0) {struct f} : nat.
Proof. (* non-really mutual at the end *)
  case : F1 F2 / f.
  - intros F.
    exact (S O). (* UnitTopos *)
  - intros F2 F1 f_ F1' f'.
    refine ((S  (S (grade _ _ f_ + grade _ _ f')%coq_nat)) (* +
            (S  (S (gradeMaxCom _ _ f_ + (gradeMaxCom _ _ f' (* + (S (S (grade _ _ f_ + grade _ _ f')%coq_nat)) *))%coq_nat)%coq_nat)) *))%coq_nat. (* PolyTopos *)
  - intros A A' a.
    exact (S (S O)). (* View1 *)
  - intros func0 func1 A x.
    exact (S (S O)). (* PolyMetaFunctor *)
  - intros func0 func1 func'0 func'1 transf A f.
    refine ((S (S (grade _ _ f))) (* + (gradeMaxCom _ _ f) *))%coq_nat. (* PolyMetaTransf *)
  - intros func0 func1 F f_.
    refine (S (S ((regularCardinalMax (fun A x => ~~ isSol.isSolbb (f_ A x)) (fun A x => (  grade _ _ (f_ A x) (* +  gradeMaxCom _ _ (f_ A x) *) )%coq_nat)) +
                  (regularCardinalMax (fun A x => isSol.isSolbb (f_ A x)) (fun A x => (  grade _ _ (f_ A x) (* +  gradeMaxCom _ _ (f_ A x) *) )%coq_nat)))%coq_nat )). (* CoLimitator *)
Proof.
  case : F1 F2 / f.
  - intros F.
    exact (O). (* UnitTopos *)
  - intros F2 F1 f_ F1' f'.
    refine (  ( (gradeMaxCom _ _ f_ + (gradeMaxCom _ _ f' + (S (S (grade _ _ f_ + grade _ _ f')%coq_nat)))%coq_nat)%coq_nat)). (* PolyTopos *)
  - intros A A' a.
    exact (O). (* View1 *)
  - intros func0 func1 A x.
    exact (O). (* PolyMetaFunctor *)
  - intros func0 func1 func'0 func'1 transf A f.
    refine (gradeMaxCom _ _ f). (* PolyMetaTransf *)
  - intros func0 func1 F f_.
    refine ( ( ((regularCardinalMax (fun A x => ~~ isSol.isSolbb (f_ A x)) (fun A x => ( (* grade _ _ (f_ A x) + *) gradeMaxCom _ _ (f_ A x))%coq_nat)) +
             (regularCardinalMax (fun A x => isSol.isSolbb (f_ A x)) (fun A x => ( (* grade _ _ (f_ A x) + *) gradeMaxCom _ _ (f_ A x))%coq_nat)))%coq_nat)). (* CoLimitator *)
Proof.
  case : F1 F2 / f.
  - intros F.
    exact ((S O))%coq_nat. (* UnitTopos *)
  - intros F2 F1 f_ F1' f'.
    refine ((S  (S (gradeTotal _ _ f_ + gradeTotal _ _ f')%coq_nat)) +
            (  ( ((*gradeMaxCom _ _ f_ +*) ((*gradeMaxCom _ _ f' + *) (S (S (grade _ _ f_ + grade _ _ f')%coq_nat)) )%coq_nat)%coq_nat)) )%coq_nat. (* PolyTopos *)
  - intros A A' a.
    exact (S (S O)). (* View1 *)
  - intros func0 func1 A x.
    exact (S (S O)). (* PolyMetaFunctor *)
  - intros func0 func1 func'0 func'1 transf A f.
    refine ((S (S (gradeTotal _ _ f)))  (* + (gradeMaxCom _ _ f)*) )%coq_nat. (* PolyMetaTransf *)
  - intros func0 func1 F f_.
    refine (S (S ((regularCardinalMax (fun A x => ~~ isSol.isSolbb (f_ A x)) (fun A x => (  gradeTotal _ _ (f_ A x) )%coq_nat)) +
                 (regularCardinalMax (fun A x => isSol.isSolbb (f_ A x)) (fun A x => (  gradeTotal _ _ (f_ A x) )%coq_nat)) )%coq_nat)). (* CoLimitator *)
Defined.

(**TODO : make func'1 of PolyMetaTransf maximally implicit *)
Module Red.

  Import Sol.Ex_Notations.
  Reserved Notation "f2 <~~ f1" (at level 70).

  Inductive convTopos : forall (F1 F2 : obTopos),
      'Topos(0 F1 ~> F2 )0 -> 'Topos(0 F1 ~> F2 )0 -> Prop :=

  (* equivalence *)

  | Topos_Trans : forall (F1 F2 : obTopos) (uTrans f : 'Topos(0 F1 ~> F2 )0),
      uTrans <~~ f -> forall (f0 : 'Topos(0 F1 ~> F2 )0),
        f0 <~~ uTrans -> f0 <~~ f

  (* congruences *)

  | PolyTopos_cong_Pre :
      forall (F F' : obTopos) (f_ f_0 : 'Topos(0 F ~> F' )0),
      forall (F'' : obTopos) (f' : 'Topos(0 F' ~> F'' )0),
        f_0 <~~ f_ -> ( f_0 o>Topos f' ) <~~ ( f_ o>Topos f' )

  | PolyTopos_cong_Post :
      forall (F F' : obTopos) (f_ : 'Topos(0 F ~> F' )0),
      forall (F'' : obTopos) (f' f'0 : 'Topos(0 F' ~> F'' )0),
        f'0 <~~ f' -> ( f_ o>Topos f'0 ) <~~ ( f_ o>Topos f' )

  | PolyMetaTransf_cong :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (func'0 : obIndexer -> Type)
        (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
      forall (transf : forall (A : obIndexer), func0 A -> func'0 A),
      forall (A : obIndexer) (v v0 : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0),
        (* none lack to hold changes to transf because no such changes and uniform *)
        v0 <~~ v -> v0 o>Topos_transf <~~ ( v o>Topos_transf
                                        : 'Topos(0 (View0 A) ~> (MetaFunctor func'1) )0 )

  | CoLimitator_cong :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall F : obTopos,
      forall (v_ v_0 : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
        (* cocone func1 f_ ->    cocone erased *)
        (forall (A : obIndexer) (x : func0 A), ~~ isSol.isSolbb (v_ A x) -> v_0 A x <~~ v_ A x) ->
        (forall (A : obIndexer) (x : func0 A), isSol.isSolbb (v_ A x) -> v_0 A x = v_ A x) ->
        (forall (A : obIndexer) (x : func0 A), isSol.isSolbb (v_0 A x)) ->
        forall (A : obIndexer) (x : func0 A), ~~ isSol.isSolbb (v_ A x) ->
        [[ v_0 @ func1 ]] <~~ ( [[ v_ @ func1 ]]
                              : 'Topos(0 MetaFunctor func1 ~> F )0 )

  (* units *)

  | Topos_unit :
      forall (F F' : obTopos) (f : 'Topos(0 F ~> F' )0),
        ( f )
          <~~ ( ( uTopos ) o>Topos f
              : 'Topos(0 F ~> F' )0 )

  | Topos_inputUnitTopos :
      forall (G F : obTopos) (g : 'Topos(0 G ~> F )0),
        ( g )
          <~~  ( g o>Topos ( uTopos )
               : 'Topos(0 G ~> F )0 )

  (* polymorphism *)

  | View_polyIndexer : forall (A A' : obIndexer) (a : 'Indexer(0 A ~> A' )0)
                         (A'' : obIndexer) (a' : 'Indexer(0 A' ~> A'' )0),
      (View1 (a o>Indexer a'))
        <~~ ( (View1 a) o>Topos (View1 a')
            : 'Topos(0 View0 A ~> View0 A'' )0 )

  (* functoriality-polymorphism follows from this _cocone property and
associativity-polymorphism of PolyTopos and functoriality-polymorphism
of View1 *)
  | PolyMetaFunctor_cocone :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (A : obIndexer) (x : func0 A) (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
        ( PolyMetaFunctor func1 (func1 _ _ a x) )
          <~~ ( (View1 a) o>Topos (PolyMetaFunctor func1 x)
              : 'Topos(0 View0 A' ~> MetaFunctor func1 )0 )

  (* naturality-polymorphism is this, which is in operational form *)
  | PolyMetaTransf_poly :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (func'0 : obIndexer -> Type)
        (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A)
        (transf : forall A : obIndexer, func0 A -> func'0 A),
      forall (A : obIndexer) (v : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0)
        (A' : obIndexer) (a : 'Indexer(0 A' ~> A )0),
        ( ((View1 a) o>Topos v) o>Topos_transf )
          <~~ ( (View1 a) o>Topos (v o>Topos_transf)
              : 'Topos(0 View0 A' ~> MetaFunctor func'1 )0 )

  (* naturality-polymorphism of the bijection*)
  | CoLimitator_morphism :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (F : obTopos) (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      forall (F' : obTopos) (f : 'Topos(0 F ~> F' )0),
        ( [[ (fun A x => (v_ A x) o>Topos f) @ func1 ]] )
          <~~ ( [[ v_ @ func1 ]] o>Topos f
              : 'Topos(0 MetaFunctor func1 ~> F' )0 )

  | PolyMetaFunctor_CoLimitator :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall F : obTopos,
      forall (v_ : forall (A : obIndexer), func0 A -> 'Topos(0 (View0 A) ~> F )0),
      forall (A : obIndexer) (x : func0 A),
        ( v_ A x )
          <~~ ( (PolyMetaFunctor func1 x) o>Topos [[ v_ @ func1 ]]
              : 'Topos(0 View0 A ~> F )0 )

  | PolyMetaTransf_CoLimitator :
      forall (func'0 : obIndexer -> Type)
        (func'1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func'0 A' -> func'0 A),
      forall F : obTopos,
      forall (v_ : forall (A : obIndexer), func'0 A -> 'Topos(0 (View0 A) ~> F )0),
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
      forall (transf : forall (A : obIndexer), func0 A -> func'0 A)
        (A : obIndexer) (w : 'Topos(0 (View0 A) ~> (MetaFunctor func1) )0),
        (w o>Topos [[ (fun A0 => (v_ A0) \o (transf A0)) @ func1 ]])
          <~~ (w o>Topos_transf) o>Topos [[ v_ @ func'1 ]]
(*
  (* for sense only, non-necessary for reduction *)
  | CoLimitator_PolyMetaFunctor :
      forall (func0 : obIndexer -> Type)
        (func1 : forall (A A' : obIndexer), 'Indexer(0 A ~> A' )0 -> func0 A' -> func0 A),
        ( @UnitTopos (MetaFunctor func1) )
          <~~ ( [[ PolyMetaFunctor func1 ]]
              : 'Topos(0 (MetaFunctor func1) ~> (MetaFunctor func1) )0 ) *)

  where "f2 <~~ f1" := (@convTopos _ _ f2 f1).

  Module Export Ex_Notations.

    Notation "f2 <~~ f1" := (@convTopos _ _ f2 f1).
    Hint Constructors convTopos.

    (* help PolyMetaFunctor_CoLimitator to decompose
       the double-applications in (v_ A x) *)
    Hint Extern 0 (_ <~~ _) =>
    ( apply: Red.PolyMetaFunctor_CoLimitator ) .

  End Ex_Notations.

  Lemma Red_convTopos_convTopos :
  forall (F1 F2 : obTopos) (fDeg f : 'Topos(0 F1 ~> F2 )0),
    fDeg <~~ f -> fDeg ~~~ f.
  Proof.
    move => F1 F2 f fDeg. elim; rewriterTopos; try eauto.
    intros.
    apply: METAFUNCTORS.CoLimitator_cong. intros.
  Admitted.

  Lemma degrade :
    forall (F1 F2 : obTopos) (fDeg f : 'Topos(0 F1 ~> F2 )0),
      fDeg <~~ f ->  ((grade fDeg) <= (grade f))%coq_nat
                  (* /\  ((gradeMaxCom fDeg) <= (gradeMaxCom f))%coq_nat*)
                 /\ ((gradeTotal fDeg) < (gradeTotal f))%coq_nat.
  Proof.
    move => F1 F2 fDeg f red_f; elim : F1 F2 fDeg f / red_f;
             try solve [ rewrite (* /gradeTotal *)  /= => * ;
                                                    abstract intuition Omega.omega ].
    - (* CoLimitator_cong *)
      move => func0 func1 F v_ v_0 red_v_ IH_red_v iden_v_ sol_v0 A x red_v_A_x.

      move: (IH_red_v _ _ red_v_A_x) => IH_red_v_A_x.

      move: (fun A x p => congr1 (@grade _ _) (iden_v_ A x p)).
      move => /(@regularCardinalMax_congr _ _ (fun A x => isSol.isSolbb (v_ A x)) (fun A x => grade (v_0 A x)) (fun A x => grade (v_ A x))).
      move: (fun A x p => congr1 (@gradeTotal _ _) (iden_v_ A x p)).
      move => /(@regularCardinalMax_congr _ _ (fun A x => isSol.isSolbb (v_ A x)) (fun A x => gradeTotal (v_0 A x)) (fun A x => gradeTotal (v_ A x))).

      move: (fun A x p => proj1 (IH_red_v A x p)).
      move => /(@regularCardinalMax_monotone_ge _ _ (fun A x => ~~ isSol.isSolbb (v_ A x)) (fun A x => grade (v_0 A x)) (fun A x => grade (v_ A x))).

      move: (fun A x p => proj2 (IH_red_v A x p)).
      move => /(@regularCardinalMax_monotone_gt _ _ (fun A x => ~~ isSol.isSolbb (v_ A x)) (fun A x => gradeTotal (v_0 A x)) (fun A x => gradeTotal (v_ A x))) /(_ _ _ red_v_A_x (proj2 IH_red_v_A_x)) .

      have Hlogical : forall (A : obIndexer) (x : func0 A), ~~ isSol.isSolbb (v_0 A x) <-> False .
      { move => A0 x0. move: (sol_v0 A0 x0) -> => //. }
      move : (Hlogical) => /(regularCardinalMax_falsefilter (fun A x => grade (v_0 A x))).
      move : Hlogical => /(regularCardinalMax_falsefilter (fun A x => gradeTotal (v_0 A x))).

      have Hlogical2 : forall (A : obIndexer) (x : func0 A), isSol.isSolbb (v_0 A x) <-> (~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x)) .
      { move => A0 x0. by case: ( isSol.isSolbb (v_ A0 x0)); intuition. }
      move : (Hlogical2) => /(regularCardinalMax_samefilter (fun A x => grade (v_0 A x))).
      move : Hlogical2 => /(regularCardinalMax_samefilter (fun A x => gradeTotal (v_0 A x))).

      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
               (fun A x => grade (v_0 A x)) ).
      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
                                            (fun A x => gradeTotal (v_0 A x)) ).

      simpl; abstract intuition Omega.omega.

    - (* CoLimitator_morphism *)
      move => func0 func1 F v_ F' f .

      have Hlogical : forall (A : obIndexer) (x : func0 A), isSol.isSolbb (v_ A x o>Topos f) <-> False .
      { move => A0 x0 //= . }
      move : (Hlogical) => /(regularCardinalMax_falsefilter (fun A x => grade (v_ A x o>Topos f))).
      move : Hlogical => /(regularCardinalMax_falsefilter (fun A x => gradeTotal (v_ A x o>Topos f))).

      have Hlogical2 : forall (A : obIndexer) (x : func0 A), ~~ isSol.isSolbb (v_ A x o>Topos f) <-> (~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x)) .
      { move => A0 x0 /=. by case: ( isSol.isSolbb (v_ A0 x0)); intuition. }
      move : (Hlogical2) => /(regularCardinalMax_samefilter (fun A x => grade (v_ A x o>Topos f))).
      move : Hlogical2 => /(regularCardinalMax_samefilter (fun A x => gradeTotal (v_ A x o>Topos f))).

      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
               (fun A x => grade (v_ A x o>Topos f)) ).
      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
                                            (fun A x => gradeTotal (v_ A x o>Topos f)) ).

      rewrite /= !(regularCardinalMax_add_succ , regularCardinalMax_addl_const , regularCardinalMax_addr_const) /=.
      move: (regularCardinalMax_add_le (fun A x => ~~ isSol.isSolbb (v_ A x)) (fun (A : obIndexer) (x : func0 A) => (gradeTotal (v_ A x) + gradeTotal f)%coq_nat)
                          (fun (A : obIndexer) (x : func0 A) => (grade (v_ A x) + grade f)%coq_nat.+2) ).
      move: (regularCardinalMax_add_le (fun A x => isSol.isSolbb (v_ A x)) (fun (A : obIndexer) (x : func0 A) => (gradeTotal (v_ A x) + gradeTotal f)%coq_nat)
                          (fun (A : obIndexer) (x : func0 A) => (grade (v_ A x) + grade f)%coq_nat.+2) ).
      rewrite /= !(regularCardinalMax_add_succ , regularCardinalMax_addl_const , regularCardinalMax_addr_const) /=.
      simpl; abstract intuition Omega.omega. (* YES /!\ ONCE *)
    - (* PolyMetaFunctor_CoLimitator *)
      move => func0 func1 F v_ A x .

      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
               (fun A x => grade (v_ A x)) ).
      move: (regularCardinalMax_unionfilter (fun A x => ~~ isSol.isSolbb (v_ A x))
                                            (fun A x => isSol.isSolbb (v_ A x))
                                            (fun A x => gradeTotal (v_ A x)) ).

      have Hlogical: (~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x)).
      { by case: ( isSol.isSolbb (v_ A x)); intuition. }
      move: (Hlogical) => /(@regularCardinalMax_ge _ _ (fun A x => ~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x))
                                                 (fun (A0 : obIndexer) (x0 : func0 A0) => grade (v_ A0 x0)) ).
      move: Hlogical => /(@regularCardinalMax_ge _ _ (fun A x => ~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x))
                                              (fun (A0 : obIndexer) (x0 : func0 A0) => gradeTotal (v_ A0 x0)) ).
      simpl; abstract intuition Omega.omega.
    - (* PolyMetaTransf_CoLimitator *)
      move => func'0 func'1 F v_ func0 func1 transf A w /=.
      move: (regularCardinalMax_transf (fun A0 x => ~~ isSol.isSolbb (v_ A0 x)) (fun A0 x => grade (v_ A0 x)) transf)
              (regularCardinalMax_transf (fun A0 x => isSol.isSolbb (v_ A0 x)) (fun A0 x => grade (v_ A0 x)) transf)
              (regularCardinalMax_transf (fun A0 x => ~~ isSol.isSolbb (v_ A0 x)) (fun A0 x => gradeTotal (v_ A0 x)) transf)
              (regularCardinalMax_transf (fun A0 x => isSol.isSolbb (v_ A0 x)) (fun A0 x => gradeTotal (v_ A0 x)) transf).
      rewrite /funcomp => /= . abstract intuition Omega.omega.
Defined.

  Lemma degradeTotal :
    forall (F1 F2 : obTopos) (fDeg f : 'Topos(0 F1 ~> F2 )0),
      fDeg <~~ f ->  ((gradeTotal fDeg) < (gradeTotal f))%coq_nat.
  Proof.
    eapply degrade.
  Qed.

  Lemma degrade_gt0 :
    forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      ((S O) <= (grade f))%coq_nat.
  Proof.
    move=> F1 F2 f; apply/leP; case : f; simpl; auto. (* alt: Omega.omega. *)
  Qed.

  Lemma degradeTotal_gt0 :
    forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      ((S O) <= (gradeTotal f))%coq_nat.
  Proof.
    move=> F1 F2 f; case : f => /= * ; Omega.omega.
  Qed.

  Lemma isSolbb_isRed_False_alt : forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      forall fRed, fRed <~~ f ->
              isSol.isSolbb f -> False.
  Proof.
    induction 1; move => //= .
    move/isSol.regularCardinalAllP. move => J. apply: J. exists A , x. assumption.
  Qed.

  Lemma isSolbb_isRed_False : forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0),
      forall fSol : 'Topos(0 F1 ~> F2 )0 %sol,  Sol.toTopos fSol = f ->
                                           forall fRed, fRed <~~ f -> False.
    intros ? ? ? ? ? ? Hred. apply: (isSolbb_isRed_False_alt Hred).
    apply: isSol.isSolbbN_isSolN. eassumption.
  Qed.

End Red.

Section Section1.

  Import Sol.Ex_Notations.
  Import Red.Ex_Notations.

  Ltac rewriterTopos := repeat match goal with | [ HH : @eq (Topos00 _ _) _ _  |- _ ] =>  try rewrite -> HH in *; clear HH end.

  Ltac tac_reduce :=
    simpl in *; abstract (
                    intuition (eauto; try subst; rewriterTopos; try congruence;
                               eauto 12)).

  Ltac tac_degrade H_gradeTotal a_Sol_prop a'Sol_prop :=
    destruct a_Sol_prop as [a_Sol_prop |a_Sol_prop];
    [ move : (Red.degrade a_Sol_prop);
      destruct a'Sol_prop as [a'Sol_prop |a'Sol_prop];
      [ move : (Red.degrade a'Sol_prop)
      | subst ]
    | subst;
      destruct a'Sol_prop as [a'Sol_prop |a'Sol_prop];
      [ move : (Red.degrade a'Sol_prop)
      | subst ]
    ];
    move : H_gradeTotal; clear; rewrite /= ;
    move => * ; abstract intuition Omega.omega.

  Ltac tac_degrade_union v_ A x :=
    move: (regularCardinalMax_unionfilter
             (fun A x => ~~ isSol.isSolbb (v_ A x))
             (fun A x => isSol.isSolbb (v_ A x))
             (fun A x => grade (v_ A x)));
    move: (regularCardinalMax_unionfilter
             (fun A x => ~~ isSol.isSolbb (v_ A x))
             (fun A x => isSol.isSolbb (v_ A x))
             (fun A x => gradeTotal (v_ A x)));
    (have: (~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x))
      by (case: (isSol.isSolbb (v_ A x)); intuition)); intros Hlogical;
    move: (Hlogical) =>
    /(@regularCardinalMax_ge
        _ _ (fun A x => ~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x))
        (fun (A0 : obIndexer) (x0 : func0 A0) => grade (v_ A0 x0)) );
    move: Hlogical =>
    /(@regularCardinalMax_ge
        _ _ (fun A x => ~~ isSol.isSolbb (v_ A x) \/ isSol.isSolbb (v_ A x))
        (fun (A0 : obIndexer) (x0 : func0 A0) => gradeTotal (v_ A0 x0)) ).

  Ltac tac_degrade_transf v_ transf :=
    move: (regularCardinalMax_transf
             (fun A0 x => ~~ isSol.isSolbb (v_ A0 x))
             (fun A0 x => grade (v_ A0 x)) transf)
            (regularCardinalMax_transf
               (fun A0 x => isSol.isSolbb (v_ A0 x))
               (fun A0 x => grade (v_ A0 x)) transf)
            (regularCardinalMax_transf
               (fun A0 x => ~~ isSol.isSolbb (v_ A0 x))
               (fun A0 x => gradeTotal (v_ A0 x)) transf)
            (regularCardinalMax_transf
               (fun A0 x => isSol.isSolbb (v_ A0 x))
               (fun A0 x => gradeTotal (v_ A0 x)) transf);
    rewrite !/funcomp.

  Fixpoint solveTopos len {struct len} :
    forall (F1 F2 : obTopos) (f : 'Topos(0 F1 ~> F2 )0)
      (H_gradeTotal : (gradeTotal f <= len)%coq_nat),
      { fSol : 'Topos(0 F1 ~> F2 )0 %sol
      & {( (Sol.toTopos fSol) <~~ f )} + {( (Sol.toTopos fSol) = f )} }.
  Proof.
    case : len => [ | len ].

    (* n is O *)
    - clear; ( move => F1 F2 f H_gradeTotal ); exfalso;
        move : (Red.degradeTotal_gt0 f) => H_degradeTotal_gt0; abstract Omega.omega.

    (* n is (S n) *)
    - move => F1 F2 f; case : F1 F2 / f =>
      [ F  (* @uTopos F *)
      | F1 F2 f_ F1' f' (* f_ o>Topos f' *)
      | A A' a (* View1 a *)
      | func0 func1 A x (* PolyMetaFunctor func1 x *)
      | func0 func1 func'0 func'1 transf A f (* f o>Topos_transf *)
      | func0 func1 F v_ ] (* [[ v_ @ func1 ]] *).

      (* f is @uTopos F *)
      + move => H_gradeTotal. exists (@uTopos F)%sol. right. reflexivity.

      (* f id f_ o>Topos f' *)
      + all: cycle 1.

      (* f is View1 a *)
      + move => H_gradeTotal. exists (Sol.View1 a). right. reflexivity.

      (* f is PolyMetaFunctor func1 x *)
      + move => H_gradeTotal. exists (Sol.PolyMetaFunctor func1 x). right. reflexivity.

      (* f is f o>Topos_transf *)
      + move => H_gradeTotal.
        case : (solveTopos len _ _ f) =>
        [ | fSol fSol_prop ].
        * move : H_gradeTotal; clear;
            rewrite /gradeTotal /=; move => *; abstract Omega.omega.
        * exists (fSol o>Topos_transf)%sol.
          clear -fSol_prop. tac_reduce.

      (* f is [[ v_ @ func1 ]] *)
      + move => H_gradeTotal.
        have gradeTotal_v_ : forall A x , (gradeTotal (v_ A x) <= len)%coq_nat.
        { move => A x.
          clear -H_gradeTotal.
          tac_degrade_union v_ A x.
          move: H_gradeTotal; clear; simpl;
            abstract intuition Omega.omega.
        }

        set solveTopos_v_ := (fun A x => solveTopos len (View0 A) F (v_ A x) (gradeTotal_v_ A x)).
        set vSol_ := (fun A x => projT1 (solveTopos_v_ A x)).
        set vSol_prop_ := (fun A x => projT2 (solveTopos_v_ A x)).
        set vSol_propb_ := (fun A x => ~~ ((projT2 (solveTopos_v_ A x)) : bool)).

        case: (isSol.regularCardinalAllP (fun A x => isSol.isSolbb (v_ A x))) => H_someRed.
        * have vSol_prop_isRed_: forall (A : obIndexer) (x : func0 A),
            ~~ isSol.isSolbb (v_ A x) ->
            Sol.toTopos (vSol_ A x) <~~ v_ A x .
          { clear - vSol_prop_. intros A x.
            (case: (vSol_prop_ A x) => //= ) ;
              ( case (isSol.isSolbbP2 (v_ A x)) => //= ).
            move: (solveTopos_v_ A x) vSol_. clear. intros; exfalso.
            intuition eauto.
          }

          have vSol_prop_isSol_: forall (A : obIndexer) (x : func0 A),
              isSol.isSolbb (v_ A x) ->
              Sol.toTopos (vSol_ A x) = v_ A x .
          { clear - vSol_prop_. intros A x. (case: (vSol_prop_ A x) => //= ) .
            ( case (isSol.isSolbbP2 (v_ A x)) => //= ).
            intros [v_A_x_Sol v_A_x_Sol_prop] v_A_x_Red; exfalso;
            apply: Red.isSolbb_isRed_False; eassumption.
          }

          exists [[ fun A x => (vSol_ A x) ]]%sol. left.
          clear - H_someRed vSol_prop_isRed_ vSol_prop_isSol_ .
          simpl. move: H_someRed  => [A [x H_someRed_prop] ].
          apply: Red.CoLimitator_cong; [assumption | assumption | | eassumption].
          intros; apply/(introT (isSol.isSolbbP2 (_))); eexists; reflexivity.

        * (* have v_A_x_allSol' : (forall (A : obIndexer) (x : func0 A), isSol.isSolbb (v_ A x)).
          { intros. case E : (isSol.isSolbb _) => //=. exfalso; apply: H_someRed.
            exists A , x . by move: E => -> . } *)

          have v_A_x_allSol : forall A x,  ({ fSol  | Sol.toTopos fSol = v_ A x}).
          { intros. apply: isSol.isSolbb_isSol.
            case E : (isSol.isSolbb _) => //=. exfalso; apply: H_someRed.
            exists A , x . by move: E => -> . }

          set v_A_x_allSol_data := (fun A x => projT1 (v_A_x_allSol A x)).
          set v_A_x_allSol_prop := (fun A x => projT2 (v_A_x_allSol A x)).

          exists [[ fun A x => (v_A_x_allSol_data A x) ]]%sol. right.
          simpl. simpl in v_A_x_allSol_prop.
          About congr1. apply: congr1.
          Require FunctionalExtensionality.
          apply: Coq.Logic.FunctionalExtensionality.functional_extensionality_dep.
          intros A. apply: Coq.Logic.FunctionalExtensionality.functional_extensionality.
          intros x. apply: v_A_x_allSol_prop.

          (** TODO ADD functional extensionality for indexer obIndexer and elements of functors **)

    - (* f is f_ o>Topos f' *)
      move => H_gradeTotal.
      case : (solveTopos len _ _ f_) =>
        [ | f_Sol f_Sol_prop ];
          [ move : H_gradeTotal; clear;
            rewrite /gradeTotal /=; move => *; abstract Omega.omega | ].
        case : (solveTopos len _ _ f') =>
        [ | f'Sol f'Sol_prop ];
          [ move : H_gradeTotal; clear;
            rewrite /gradeTotal /=; move => *; abstract Omega.omega | ].

        (* f is (f_ o>Mod f') , to (f_Sol o>Mod f'Sol) *)
        destruct f_Sol as
            [ F  (* @uTopos F %sol*)
            | A A' f_a (* Sol.View1 f_a *)
            | func0 func1 A x (* Sol.PolyMetaFunctor func1 x *)
            | func0 func1 func'0 func'1 transf A f_Sol' (* f_Sol' o>Topos_transf %sol *)
            | func0 func1 F f_Sol_ ] (* [[ f_Sol_ @ func1 ]] %sol *).

      (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is ((@uTopos F) o>Topos f'Sol) *)
      + case : (solveTopos len _ _ ((Sol.toTopos f'Sol))) =>
        [ | f_Sol_o_f'Sol f_Sol_o_f'Sol_prop ].
        * tac_degrade H_gradeTotal f_Sol_prop f'Sol_prop.
        * exists (f_Sol_o_f'Sol).
          clear -f_Sol_prop f'Sol_prop f_Sol_o_f'Sol_prop. tac_reduce.

      (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (View1 f_a o>Topos f'Sol) *)
      + clear - solveTopos H_gradeTotal f_Sol_prop f'Sol_prop.
        move: (Sol.Destruct_domView.Topos00_domViewP f'Sol) => f'Sol_domViewP.
        destruct f'Sol_domViewP as
            [ _A  (* @uTopos F %sol*)
            | _A A' f'a (* Sol.View1 f'a *)
            | func0 func1 _A x (* Sol.PolyMetaFunctor func1 x *)
            | func0 func1 func'0 func'1 transf _A f'Sol' ] (* f'Sol' o>Topos_transf %sol *).

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (View1 f_a o>Topos f'Sol) , is  (View1 f_a o>Topos (@uTopos _A)) *)
        * exists ( (Sol.View1 f_a)%sol ) .
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (View1 f_a o>Topos f'Sol) , is  (View1 f_a o>Topos View1 f'a) *)
        * exists (Sol.View1 (f_a o>Indexer f'a)%sol).
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (View1 f_a o>Topos f'Sol) , is  (View1 f_a o>Topos Sol.PolyMetaFunctor func1 x) *)
        * exists (Sol.PolyMetaFunctor func1 (func1 _ _ f_a x)%sol).
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (View1 f_a o>Topos f'Sol) , is  (View1 f_a o>Topos (f'Sol' o>Topos_transf) *)
        * { case : (solveTopos len _ _ ((Sol.toTopos (Sol.View1 f_a) o>Topos (Sol.toTopos f'Sol')))) =>
            [ | f_Sol_o_f'Sol f_Sol_o_f'Sol_prop ].
            - tac_degrade H_gradeTotal f_Sol_prop f'Sol_prop.
            - exists (f_Sol_o_f'Sol o>Topos_transf)%sol.
              clear -f_Sol_prop f'Sol_prop f_Sol_o_f'Sol_prop. tac_reduce.
              (*OLD [ | f_Sol_o_f'Sol' f_Sol_o_f'Sol'_prop ].
            - tac_degrade H_gradeTotal f_Sol_prop f'Sol_prop.
            - exists (f_Sol_o_f'Sol' o>Topos_transf)%sol.
              clear -f_Sol_prop f'Sol_prop f_Sol_o_f'Sol'_prop. tac_reduce.*)
          }

      (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (Sol.PolyMetaFunctor func1 x o>Topos f'Sol) *)
      + clear - solveTopos H_gradeTotal f_Sol_prop f'Sol_prop.
        move: (Sol.Destruct_domMetaFunctor.Topos00_domMetaFunctorP f'Sol) => f'Sol_domMetaFunctorP.
        destruct f'Sol_domMetaFunctorP as
            [ func0 func1  (* @uTopos (MetaFunctor func1) %sol*)
            | func0 func1 F f'Sol_ ] (* [[ f'Sol_ @ func1 ]] *).

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (Sol.PolyMetaFunctor func1 x o>Topos (@uTopos (MetaFunctor func1))) *)
        * exists ( Sol.PolyMetaFunctor func1 x )%sol .
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is (Sol.PolyMetaFunctor func1 x o>Topos [[ f'Sol_ ]]) *)
        * exists ((f'Sol_ A x))%sol.
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

      (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is ((f_Sol' o>Topos_transf) o>Topos f'Sol) *)
      + clear - solveTopos H_gradeTotal f_Sol_prop f'Sol_prop.
        move: (Sol.Destruct_domMetaFunctor.Topos00_domMetaFunctorP f'Sol) => f'Sol_domMetaFunctorP.
        destruct f'Sol_domMetaFunctorP as
            [ _func0 _func1  (* @uTopos (MetaFunctor _func1) %sol*)
            | _func0 _func1 F f'Sol_ ] (* [[ f'Sol_ @ func1 ]] *).

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is ((f_Sol' o>Topos_transf) o>Topos (@uTopos (MetaFunctor _func1))) *)
        * exists ( f_Sol' o>Topos_transf )%sol .
          clear -f_Sol_prop f'Sol_prop. tac_reduce.

        (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is ((f_Sol' o>Topos_transf) o>Topos [[ f'Sol_ ]]) *)
        * { case : (solveTopos len _ _ ((Sol.toTopos f_Sol') o>Topos [[ (fun A0 => ((fun A1 x1 => Sol.toTopos (f'Sol_ A1 x1)) A0) \o (transf A0)) @ func1 ]] )) =>
            [ | f_Sol_o_f'Sol f_Sol_o_f'Sol_prop ].
            - (* copy-paste degrade lemma case PolyMetaTransf_CoLimitator *)
              tac_degrade_transf (fun A1 x1 => Sol.toTopos (f'Sol_ A1 x1)) transf.
              tac_degrade H_gradeTotal f_Sol_prop f'Sol_prop.
            - exists (f_Sol_o_f'Sol).
              clear -f_Sol_prop f'Sol_prop f_Sol_o_f'Sol_prop. tac_reduce.
          }

      (* f is (f_ o>Topos f') , to (f_Sol o>Topos f'Sol)  , is ( [[ f_Sol_ ]] o>Topos f'Sol) *)
      +
        have gradeTotal_f_Sol_o_f'Sol : forall A x , (gradeTotal (((fun A1 x1 => Sol.toTopos (f_Sol_ A1 x1)) A x) o>Topos (Sol.toTopos f'Sol)) <= len)%coq_nat.
        { move => A x.
          clear -H_gradeTotal f_Sol_prop f'Sol_prop.
          tac_degrade_union (fun A1 x1 => Sol.toTopos (f_Sol_ A1 x1)) A x.
          tac_degrade H_gradeTotal f_Sol_prop f'Sol_prop.
        }

        set v_ := (fun A x => (((fun A1 x1 => Sol.toTopos (f_Sol_ A1 x1)) A x) o>Topos (Sol.toTopos f'Sol))).
        set solveTopos_v_ := (fun A x => solveTopos len (View0 A) F1' (v_ A x) (gradeTotal_f_Sol_o_f'Sol A x)).
        set f_Sol_o_f'Sol := (fun A x => projT1 (solveTopos_v_ A x)).
        set f_Sol_o_f'Sol_prop := (fun A x => projT2 (solveTopos_v_ A x)).
        set f_Sol_o_f'Sol_propb := (fun A x => ~~ ((projT2 (solveTopos_v_ A x)) : bool)).

        exists ([[ f_Sol_o_f'Sol ]])%sol. left.

        (* now similar as the above congruence case:  f is [[ v_ @ func1 ]] *)
        case: (isSol.regularCardinalAllP (fun A x => isSol.isSolbb (v_ A x))) => H_someRed.
        * { apply: (Red.Topos_Trans (uTrans := [[ v_ ]] ));
            first by clear -f_Sol_prop f'Sol_prop; subst v_; tac_reduce.

            clear -H_someRed f_Sol_o_f'Sol_prop.
            have f_Sol_o_f'Sol_prop_isRed_ : forall (A : obIndexer) (x : func0 A),
                ~~ isSol.isSolbb (v_ A x) ->
                Sol.toTopos (f_Sol_o_f'Sol A x) <~~ (v_ A x) .
            { intros A x.  (case: (f_Sol_o_f'Sol_prop A x) => // ) ;
              ( case (isSol.isSolbbP2 (v_ A x)) => //= ) .
              move: (f_Sol_o_f'Sol A x) ((solveTopos_v_ A x)). move: (v_ A x).
              clear. intros. exfalso. intuition eauto.
            }

            have f_Sol_o_f'Sol_prop_isSol_ : forall (A : obIndexer) (x : func0 A),
                isSol.isSolbb (v_ A x) ->
                Sol.toTopos (f_Sol_o_f'Sol A x) = v_ A x .
            { by []. (* shorter exfalso on form of v_ *)
            }

            clear - H_someRed f_Sol_o_f'Sol_prop_isRed_ f_Sol_o_f'Sol_prop_isSol_ .
            move: H_someRed  => [A [x H_someRed_prop] ].
            apply: Red.CoLimitator_cong;
              [assumption | assumption | | eassumption].
            intros A1 x1; apply/(introT (isSol.isSolbbP2 (_))); eexists; reflexivity.
          }
        * (* memo: contradictory context [ H_someRed constrast form of v_ ]
             when the elements (A , x) of functor are non-empty *)
          suff: Sol.toTopos [[f_Sol_o_f'Sol]]%sol = [[ v_ @ func1 ]]
            by move ->; clear -f_Sol_prop f'Sol_prop; subst v_; tac_reduce.

          clear -H_someRed. simpl; apply: congr1.
          (* MEMO ONLY PARTICULAR FUNCTIONAL EXTENTIONALITY REQUIRED *)
          apply: Coq.Logic.FunctionalExtensionality.functional_extensionality_dep. intros A.
          apply: Coq.Logic.FunctionalExtensionality.functional_extensionality. intros x.
          (* here the elements (A , x) of functor are non-empty *)
          exfalso. apply: H_someRed. exists A , x. reflexivity.
  Defined.

End Section1.

End METAFUNCTORS.

(**#+END_SRC

Voila. **)


Require Import Monad.

Class MonadPlus (M : Type -> Type) : Type := {
  monad :> Monad M
  ; mzero : forall {A}, M A
  ; mplus : forall {A:Type}, M A -> M A -> M A
  (* laws *)
  ; mzero_left : forall A f, bind (@mzero A) f = @mzero A
  ; mzero_right : forall A B (m: M A),
      bind m (fun x => (@mzero B)) = mzero
  ; monoid_left_unit : forall A (m : M A),
      mplus mzero m = m
  ; monoid_right_unit : forall A (m : M A),
      mplus m mzero = m
  ; monoid_assoc : forall A (ma mb mc : M A),
      mplus (mplus ma mb) mc = mplus ma (mplus mb mc)
}.

Instance OptionMonadPlus : MonadPlus option := {
  monad := OptionMonad
  ; mzero A := @None A
  ; mplus A m1 m2 :=
      match m1 with
      | None => m2
      | Some x => m1
      end
}.
Proof.
 reflexivity.

 destruct m; reflexivity.

 reflexivity.

 destruct m; reflexivity.

 destruct ma; reflexivity.
Defined.


Require Import UNIVERSE.
(* Require Import EventsC. *)
(* Require Import Values. *)
(* Require Import AST. *)
(* Require Import Memory. *)
(* Require Import Globalenvs. *)
Require Import Smallstep.
From Paco Require Import paco.
Require Import sflib.
(* Require Import Skeleton. *)
Require Import CoqlibC.
Require Import Simulation.
Require Import ModSem.

Set Implicit Arguments.

Lemma spread_dstar
      ms st0 tr st1
      (DTM: forall st0, determinate_at ms st0)
      (STAR: Star ms st0 tr st1):
    <<DSTAR: DStar ms st0 tr st1>>.
Proof. ginduction STAR; ii; ss; econs; eauto. eapply IHSTAR; eauto. Qed.

Lemma spread_dplus
      ms st0 tr st1
      (DTM: forall st0, determinate_at ms st0)
      (PLUS: Plus ms st0 tr st1):
    <<DPLUS: DPlus ms st0 tr st1>>.
Proof. inv PLUS. econs; eauto. eapply spread_dstar; eauto. Qed.

Lemma at_external_receptive_at
      ms_src lst_src
      (CALL: ModSem.is_call ms_src lst_src):
    <<RCP: receptive_at ms_src lst_src>>.
Proof. econs; ii; ModSem.tac. Qed.

Lemma at_external_determinate_at
      ms_src lst_src
      (CALL: ModSem.is_call ms_src lst_src):
    <<RCP: determinate_at ms_src lst_src>>.
Proof. econs; ii; ModSem.tac. Qed.

Lemma final_frame_receptive_at
      ms_src lst_src
      (CALL: ModSem.is_return ms_src lst_src):
    <<RCP: receptive_at ms_src lst_src>>.
Proof. econs; ii; ModSem.tac. Qed.

Lemma final_frame_determinate_at
      ms_src lst_src
      (CALL: ModSem.is_return ms_src lst_src):
    <<RCP: determinate_at ms_src lst_src>>.
Proof. econs; ii; ModSem.tac. Qed.

(* Lemma atomic_step_continue_star *)
(*     (ms: ModSem.t) st0 tr *)
(*     (WBT: output_trace tr): *)
(*     <<STEP: Star (ModSem.Atomic.trans ms) (tr, st0) tr ([], st0)>>. *)
(* Proof. *)
(*   i. ginduction tr; ii; ss; econs; eauto. *)
(*   { econs; eauto. } *)
(*   { eapply IHtr; eauto. des; ss. } *)
(*   ss. *)
(* Qed. *)

(* Lemma step_atomic_step *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (WBT: well_behaved_traces ms) *)
(*       (STEP: Step ms st0 tr st1): *)
(*     <<STEP: Plus (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   destruct tr. *)
(*   { apply plus_one. econs; eauto. } *)
(*   s. econs; eauto; swap 2 3. *)
(*   { econs 2; eauto. } *)
(*   { ss. } *)
(*   exploit WBT; eauto. i; ss. hexploit atomic_step_continue_star; eauto. ss. eauto. *)
(* Qed. *)

(* Lemma star_atomic_star *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (WBT: well_behaved_traces ms) *)
(*       (STAR: Star ms st0 tr st1): *)
(*     <<STAR: Star (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   ginduction STAR; ii. *)
(*   - econs; eauto. *)
(*   - clarify. eapply star_trans. *)
(*     { exploit step_atomic_step; eauto. i. eapply plus_star; eauto. } *)
(*     { exploit IHSTAR; eauto. } *)
(*     ss. *)
(* Qed. *)

(* Lemma plus_atomic_plus *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (WBT: well_behaved_traces ms) *)
(*       (PLUS: Plus ms st0 tr st1): *)
(*     <<PLUS: Plus (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   inv PLUS. eapply plus_star_trans. *)
(*   { exploit step_atomic_step; eauto. } *)
(*   { eapply star_atomic_star; eauto. } *)
(*   ss. *)
(* Qed. *)

(* Lemma determ_atomic_determ *)
(*       (ms: ModSem.t) st0 tr *)
(*       (* (WBT: well_behaved_traces ms) *) *)
(*       (DTM: determinate_at ms st0) *)
(*       (WBT: output_trace tr): *)
(*     <<DTM: determinate_at (ModSem.Atomic.trans ms) (tr, st0)>>. *)
(* Proof. *)
(*   ii. inv DTM. econs; eauto; ii; ss; inv H; ss; try xomega; inv H0. *)
(*   - determ_tac sd_determ_at. esplits; eauto. i. exploit H0; eauto. i; des. clarify. *)
(*   - determ_tac sd_determ_at. inv H. *)
(*   - determ_tac sd_determ_at. inv H. *)
(*   - determ_tac sd_determ_at. esplits; eauto. *)
(*     { inv H; econs; eauto. } *)
(*     i; des. clarify. exploit H0; inv H; i; des; clarify; eauto. *)
(*   - esplits; eauto. ss. des. destruct ev; ss; econs; eauto. *)
(* Qed. *)

(* Lemma output_trace_determinate_at *)
(*       (ms: ModSem.t) *)
(*       ev tr st0 *)
(*       (WBT: output_event ev): *)
(*     determinate_at (ModSem.Atomic.trans ms) (ev :: tr, st0). *)
(* Proof. *)
(*   econs; eauto; ii; ss; inv H; ss; try xomega. inv H0. split; ss. destruct ev; ss; econs; eauto. *)
(* Qed. *)

(* Lemma atomic_dstep_continue_dstar *)
(*     (ms: ModSem.t) st0 tr *)
(*     (WBT: output_trace tr): *)
(*     <<STEP: DStar (ModSem.Atomic.trans ms) (tr, st0) tr ([], st0)>>. *)
(* Proof. *)
(*   i. ginduction tr; ii; ss. *)
(*   { econs; eauto. } *)
(*   (* exploit determ_atomic_determ; eauto. *) *)
(*   (* { instantiate (1:= []). ss. } *) *)
(*   (* intro DTM0; des. *) *)
(*   econs; eauto. *)
(*   { rr. des. esplits; eauto. *)
(*     - eapply output_trace_determinate_at; eauto. *)
(*     - econs; eauto. ss. *)
(*   } *)
(*   { eapply IHtr; eauto. des; ss. } *)
(*   ss. *)
(* Qed. *)

(* Lemma dstep_atomic_dstep *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (* (SINGLE: single_events ms) *) *)
(*       (WBT: well_behaved_traces ms) *)
(*       (STEP: DStep ms st0 tr st1): *)
(*     <<STEP: DPlus (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   rr in STEP. des. *)
(*   exploit determ_atomic_determ; eauto. *)
(*   { instantiate (1:= []). ss. } *)
(*   intro DTM; des. destruct tr. *)
(*   { apply plus_one. econs; eauto. econs; eauto. } *)
(*   s. econs; eauto; swap 2 3. *)
(*   { rr. split; ss. instantiate (1:= (_, _)). econs 2; eauto. } *)
(*   { ss. } *)
(*   eapply atomic_dstep_continue_dstar; eauto. exploit WBT; eauto. *)
(* Qed. *)

(* Lemma dstar_atomic_dstar *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (* (SINGLE: single_events ms) *) *)
(*       (WBT: well_behaved_traces ms) *)
(*       (STAR: DStar ms st0 tr st1): *)
(*     <<STAR: DStar (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   ginduction STAR; ii; ss. *)
(*   - econs; eauto. *)
(*   - exploit IHSTAR; eauto. i. eapply star_trans; eauto. apply plus_star. exploit dstep_atomic_dstep; eauto. *)
(* Qed. *)

(* Lemma dplus_atomic_dplus *)
(*       (ms: ModSem.t) st0 tr st1 *)
(*       (* (SINGLE: single_events ms) *) *)
(*       (WBT: well_behaved_traces ms) *)
(*       (PLUS: DPlus ms st0 tr st1): *)
(*     <<PLUS: DPlus (ModSem.Atomic.trans ms) ([], st0) tr ([], st1)>>. *)
(* Proof. *)
(*   inv PLUS. eapply plus_star_trans. *)
(*   { exploit dstep_atomic_dstep; eauto. } *)
(*   { eapply dstar_atomic_dstar; eauto. } *)
(*   ss. *)
(* Qed. *)

(* Lemma atomic_single_events_at: forall (ms: ModSem.t), *)
(*     <<SINGLE: forall st, single_events_at (ModSem.Atomic.trans ms) st>>. *)
(* Proof. ii. inv H; ss. xomega. Qed. *)

(* Lemma atomic_single_evnents: forall (ms: ModSem.t), *)
(*     <<SINGLE: single_events (ModSem.Atomic.trans ms)>>. *)
(* Proof. ii. inv H; ss. xomega. Qed. *)

(* Lemma atomic_receptive_at *)
(*       (ms: ModSem.t) st0 *)
(*       (SSR: strongly_receptive_at ms st0): *)
(*     <<RCP: forall tr, receptive_at (ModSem.Atomic.trans ms) (tr, st0)>>. *)
(* Proof. *)
(*   generalize (@atomic_single_evnents ms); eauto. intro SINGLE. *)
(*   inv SSR. econs; ss. *)
(*   { ii. ss. destruct t1; ss. *)
(*     { inv H. inv H0. esplits; eauto. econs; eauto. } *)
(*     exploit SINGLE; eauto. intro LEN. ss. destruct t1; ss; try xomega. destruct t2; ss. *)
(*     { inv H0. } *)
(*     destruct t2; ss; cycle 1. *)
(*     { inv H0. } *)
(*     inv H; ss. *)
(*     - exploit ssr_receptive_at; eauto. i; des. esplits; eauto. econs; eauto. *)
(*     - esplits; eauto. instantiate (1:= (_, _)). *)
(*       assert(e0 = e) by (des; inv H0; ss). clarify. econs 3; eauto. *)
(*   } *)
(*   eapply atomic_single_events_at; eauto. *)
(* Qed. *)

(* Lemma atomic_receptive_at_nonnil: forall (ms: ModSem.t), *)
(*     <<RCP: forall st0 ev tr, receptive_at (ModSem.Atomic.trans ms) (ev :: tr, st0)>>. *)
(* Proof. *)
(*   i. generalize (@atomic_single_evnents ms); eauto. intro SINGLE. ii. econs; ss. *)
(*   { ii. ss. destruct t1; ss. *)
(*     { inv H. } *)
(*     exploit SINGLE; eauto. intro LEN. ss. destruct t1; ss; try xomega. destruct t2; ss. *)
(*     { inv H0. } *)
(*     destruct t2; ss; cycle 1. *)
(*     { inv H0. } *)
(*     inv H; ss. des. assert(e = e0). { inv H0; ss. } clarify. *)
(*     esplits; eauto. econs; eauto. ss. *)
(*   } *)
(*   eapply atomic_single_events_at; eauto. *)
(* Qed. *)

(* Lemma atomic_receptive *)
(*       (ms: ModSem.t) *)
(*       (SSR: strongly_receptive ms): *)
(*     <<RCP: receptive (ModSem.Atomic.trans ms)>>. *)
(* Proof. *)
(*   generalize (@atomic_single_evnents ms); eauto. intro SINGLE. *)
(*   inv SSR. econs; ss. *)
(*   { ii. ss. destruct t1; ss. *)
(*     { inv H. inv H0. esplits; eauto. econs; eauto. } *)
(*     exploit SINGLE; eauto. intro LEN. ss. destruct t1; ss; try xomega. *)
(*     destruct t2; ss. *)
(*     { inv H0. } *)
(*     destruct t2; ss; cycle 1. *)
(*     { inv H0. } *)
(*     inv H; ss. *)
(*     - exploit ssr_receptive; eauto. i; des. esplits; eauto. econs; eauto. *)
(*     - esplits; eauto. instantiate (1:= (_, _)). *)
(*       assert(e0 = e) by (des; inv H0; ss). clarify. econs 3; eauto. *)
(*   } *)
(* Qed. *)

Lemma DStep_Step
      L st0 tr st1
      (STEP: DStep L st0 tr st1):
    <<STEP: Step L st0 tr st1>>.
Proof. rr in STEP. des. ss. Qed.

Lemma DStar_Star
      L st0 tr st1
      (STAR: DStar L st0 tr st1):
    <<STAR: Star L st0 tr st1>>.
Proof.
  ginduction STAR; ii; ss.
  { eapply star_refl. }
  clarify. eapply star_trans; eauto. eapply star_one. eapply DStep_Step; eauto.
Qed.

Lemma DPlus_Plus
      L st0 tr st1
      (PLUS: DPlus L st0 tr st1):
    <<PLUS: Plus L st0 tr st1>>.
Proof.
  inv PLUS.
  econs; eauto.
  { eapply DStep_Step; eauto. }
  { eapply DStar_Star; eauto. }
Qed.

Definition safe_modsem (ms: ModSem.t) (st0: ms.(ModSem.state)): Prop :=
  forall st1 (STAR: Star ms st0 E0 st1),
    (<<EVCALL: ms.(ModSem.is_call) st1>>) \/
    (<<EVRET: ms.(ModSem.is_return) st1>>) \/
    (<<EVSTEP: exists tr st2, Step ms st1 tr st2>>).
Hint Unfold safe_modsem.


From stdpp Require Export namespaces.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import auth gmap frac agree gset.
From Perennial.base_logic.lib Require Export own.
From Perennial.algebra Require Import gen_heap_names.
Set Default Proof Using "Type".
Import uPred.

Class partitionG (L V: Type) (Σ: gFunctors) `{Countable L, Infinite L, Countable V, Infinite V} := {
  partition_heap_inG :> gen_heapGS L (gset V) Σ;
}.

Class partition_preG (L V: Type) Σ `{Countable L, Infinite L, Countable V, Infinite V} := {
  partition_heap_preG :> gen_heapGpreS L (gset V) Σ;
}.

Definition partitionΣ (L V: Type) `{Countable L, Infinite L, Countable V, Infinite V} : gFunctors :=
    #[gen_heapΣ L (gset V)].

Instance subG_partitionG L V {Σ} `{Countable L, Infinite L, Countable V, Infinite V}:
  subG (partitionΣ L V) Σ → partition_preG L V Σ.
Proof. solve_inG. Qed.

Local Notation "l ↦{ q } v" := (mapsto l q v)
  (at level 20, q at level 50, format "l  ↦{ q }  v") : bi_scope.
Local Notation "l ↦ v" := (mapsto l 1 v) (at level 20) : bi_scope.

Local Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
  (at level 20, q at level 50, format "l  ↦{ q }  -") : bi_scope.
Local Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : bi_scope.

Section definitions.
Context `{Countable L, Infinite L, Countable V, Infinite V, hG : !partitionG L V Σ}.

Implicit Types l : L.
Implicit Types s : gset V.

Definition disjoint_images (σ: gmap L (gset V)) : Prop :=
  ∀ i1 i2 s1 s2, i1 ≠ i2 → σ !! i1 = Some s1 → σ !! i2 = Some s2 →
                 s1 ## s2.

Definition partition_ctx (σ: gmap L (gset V)) : iProp Σ :=
  (⌜ disjoint_images σ ⌝ ∗ gen_heap_ctx σ).

Definition union_partition (σ: gmap L (gset V)) : gset V :=
  map_fold (λ _ s1 s2, s1 ∪ s2) ∅ σ.

Lemma union_partition_elem_of_1 σ (v: V):
  v ∈ union_partition σ → ∃ i s, σ !! i = Some s ∧ v ∈ s.
Proof.
  revert v.
  eapply (map_fold_ind (λ b σ, ∀ v, v ∈ b → ∃ i s, σ !! i = Some s ∧ v ∈ s) _ ∅).
  - set_solver.
  - intros i s1 m s2 Hlookup HP v Hin.
    apply elem_of_union in Hin as [Hs1|Hs2].
    * exists i, s1. rewrite lookup_insert; auto.
    * edestruct (HP) as (i'&s'&?&?); eauto.
      exists i', s'. rewrite lookup_insert_ne //=. congruence.
Qed.

Lemma union_partition_elem_of_2 σ (v: V) i s:
  σ !! i = Some s → v ∈ s → v ∈ union_partition σ.
Proof.
  revert v i s.
  eapply (map_fold_ind (λ b σ, ∀ v i s, σ !! i = Some s → v ∈ s → v ∈ b) _ ∅).
  - set_solver.
  - intros i s1 m s2 Hlookup HP v i' s Hlookup2 Hin.
    destruct (decide (i = i')).
    * subst. rewrite lookup_insert in Hlookup2. apply elem_of_union_l.
      inversion Hlookup2; subst; eauto.
    * rewrite lookup_insert_ne in Hlookup2 * => //=.
      apply elem_of_union_r. eapply HP; eauto.
Qed.

Lemma union_partition_subset σ i s:
  σ !! i = Some s → s ⊆ union_partition σ.
Proof. set_unfold. intros. by eapply union_partition_elem_of_2. Qed.

Definition fresh_partition_value (σ: gmap L (gset V)) : V :=
  fresh (union_partition σ).

Lemma not_elem_of_union_partition σ x :
  x ∉ union_partition σ → ∀ i s, σ !! i = Some s → x ∉ s.
Proof.
  intros Hin1 i s Hlookup.
  intros Hin. eapply union_partition_elem_of_2 in Hlookup; eauto.
Qed.

Lemma fresh_partition_value_spec σ :
  ∀ i s, σ !! i = Some s → fresh_partition_value σ ∉ s.
Proof.
  rewrite /fresh_partition_value.
  apply not_elem_of_union_partition, is_fresh.
Qed.

Lemma partition_alloc σ:
  partition_ctx σ ==∗ ∃ l v (Hfresh1: σ !! l = None) (Hfresh2: v ∉ union_partition σ),
        partition_ctx (<[l := {[v]}]>σ) ∗ l ↦ {[v]} ∗ meta_token l ⊤.
Proof.
  iIntros "(Hdisj&Hctx)". iDestruct "Hdisj" as %Hdisj.
  iMod (gen_heap_alloc σ (fresh (dom σ)) ({[fresh_partition_value σ]}) with "Hctx")
       as "(Hctx&Hl&Hmeta)".
  { rewrite -(not_elem_of_dom (D := gset L)). apply is_fresh. }
  iModIntro. unshelve (iExists _, _, _, _; iFrame).
  { eapply (not_elem_of_dom (D := gset L)). apply is_fresh. }
  { rewrite /fresh_partition_value. eapply is_fresh. }
  iPureIntro.
  intros i j s1 s2 Hneq.
  destruct (decide (i = fresh (dom σ))) as [He1|Hne1].
  { subst. rewrite lookup_insert lookup_insert_ne //.
    inversion 1; subst. intros Hlookup.
    specialize (fresh_partition_value_spec σ j s2). set_solver. }
  destruct (decide (j = fresh (dom σ))) as [He2|Hne2].
  { subst. rewrite lookup_insert lookup_insert_ne //.
    inversion 1; subst. intros Hlookup.
    specialize (fresh_partition_value_spec σ i s1). set_solver. }
  rewrite ?lookup_insert_ne //. by eapply Hdisj.
Qed.

Lemma partition_valid_disj σ (l1 l2: L) (s1 s2: gset V):
  partition_ctx σ -∗ l1 ↦ s1 -∗ l2 ↦ s2 -∗ ⌜ l1 ≠ l2 ∧ s1 ## s2 ⌝.
Proof.
  iDestruct 1 as (Hdisj) "Hctx". iIntros "Hl1 Hl2".
  iDestruct (gen_heap_valid with "Hctx Hl1") as %Hin1.
  iDestruct (gen_heap_valid with "Hctx Hl2") as %Hin2.
  iAssert (⌜l1 ≠ l2⌝)%I with "[-]" as %Hneq.
  { iIntros (?). subst. iDestruct (mapsto_valid_2 with "[$] [$]") as %Hval.
    rewrite frac_valid in Hval * => Hlt. by apply Qp.not_plus_q_ge_1 in Hlt.
  }
  iPureIntro. split; auto. eapply Hdisj; eauto.
Qed.

Lemma union_partition_move σ (l1 l2: L) (s1 s1' s2: gset V):
  l1 ≠ l2 →
  s1 ## s1' →
  σ !! l1 = Some (s1 ∪ s1') →
  σ !! l2 = Some s2 →
  union_partition σ = union_partition (<[l1:=s1]> (<[l2:=s2 ∪ s1']> σ)).
Proof.
  intros Hneq Hdisj Hl1 Hl2.
  assert (<[l1:=s1]> (<[l2:=s2 ∪ s1']> σ) =
          <[l1:=s1]> (delete l1 (<[l2:=s2 ∪ s1']> (delete l2 σ)))) as Heq.
  { by rewrite ?insert_delete_insert. }
  rewrite Heq.

  assert (σ = <[l1:=s1 ∪ s1']> (delete l1 (<[l2:=s2]> (delete l2 σ)))) as Heq'.
  { rewrite ?insert_delete_insert ?insert_id //. }
  rewrite {1}Heq'.

  rewrite /union_partition ?map_fold_insert ?lookup_delete //; try set_solver+.
  rewrite ?delete_insert_ne //.
  assert (delete l1 (delete l2 σ) !! l2 = None).
  { rewrite lookup_delete_ne // lookup_delete //. }
  rewrite ?map_fold_insert //; set_solver+.
Qed.

Lemma partition_move σ (l1 l2: L) (s1 s1' s2: gset V):
  s1 ## s1' →
  partition_ctx σ -∗ l1 ↦ (s1 ∪ s1') -∗ l2 ↦ s2 ==∗
  partition_ctx (<[l1 := s1]>(<[l2 := s2 ∪ s1']>σ)) ∗ l1 ↦ s1 ∗ l2 ↦ (s2 ∪ s1').
Proof.
  iIntros (Hdisjs1) "Hpart Hl1 Hl2".
  iDestruct (partition_valid_disj with "Hpart Hl1 Hl2") as %Hdisj_s1s2.
  iDestruct "Hpart" as (Hdisj) "Hctx".
  iDestruct (gen_heap_valid with "Hctx Hl1") as %Hin1.
  iDestruct (gen_heap_valid with "Hctx Hl2") as %Hin2.
  iMod (gen_heap_update σ l2 _ (s2 ∪ s1') with "[$] [$]") as "(Hctx&Hl2)".
  iMod (gen_heap_update _ l1 _ (s1) with "[$] [$]") as "(Hctx&Hl1)".
  iModIntro. iFrame. iPureIntro.
  intros i j si sj Hneq.
  destruct (decide (i = l1)) as [He1|Hne1].
  { subst.
    rewrite lookup_insert. inversion 1; subst.
    rewrite lookup_insert_ne //.
    destruct (decide (j = l2)) as [He2|Hne2].
    {
      subst. rewrite lookup_insert. inversion 1; subst.
      set_solver.
    }
    rewrite lookup_insert_ne //; intros; eauto.
    cut (si ∪ s1' ## sj); first by set_solver.
    eapply Hdisj; [ | apply Hin1 | eauto ]; eauto.
  }
  rewrite lookup_insert_ne //.
  destruct (decide (i = l2)) as [He2|Hne2].
  {
    subst.
    rewrite lookup_insert.
    destruct (decide (j = l1)) as [He2|Hne2].
    {
      subst. rewrite lookup_insert. inversion 1; subst.
      set_solver.
    }
    inversion 1; subst.
    rewrite ?lookup_insert_ne //; intros; eauto.
    cut (s1 ∪ s1' ## sj ∧ s2 ## sj); first by set_solver.
    split.
    * eapply Hdisj; [ | apply Hin1 | eauto ]; eauto.
    * eapply Hdisj; [ | apply Hin2 | eauto ]; eauto.
  }
  rewrite lookup_insert_ne // => ?.
  destruct (decide (j = l1)) as [He3|Hne3].
  {
    subst. rewrite lookup_insert. inversion 1; subst.
    cut (sj ∪ s1' ## si); first by set_solver.
    eapply Hdisj; [ | apply Hin1 | eauto ]; eauto.
  }
  rewrite lookup_insert_ne //.
  destruct (decide (j = l2)) as [He4|Hne4].
  {
    subst. rewrite lookup_insert. inversion 1; subst.
    cut (s1 ∪ s1' ## si ∧ s2 ## si); first by set_solver.
    split.
    * eapply Hdisj; [ | apply Hin1 | eauto ]; eauto.
    * eapply Hdisj; [ | apply Hin2 | eauto ]; eauto.
  }
  rewrite lookup_insert_ne // => Hin4.
  eapply Hdisj; [ | | apply Hin4 ]; eauto.
Qed.

Lemma partition_move_1 σ (l1 l2: L) (v: V) (s: gset V):
  partition_ctx σ -∗ l1 ↦ {[v]} -∗ l2 ↦ s ==∗
  partition_ctx (<[l1 := ∅]>(<[l2 := s ∪ {[v]}]>σ)) ∗ l1 ↦ ∅ ∗ l2 ↦ (s ∪ {[v]}).
Proof.
  replace {[v]} with (∅ ∪ {[v]} : gset V) at 1 by set_solver.
  iApply partition_move; set_solver.
Qed.

Lemma partition_join σ (l1 l2: L) (s1 s2: gset V):
  partition_ctx σ -∗ l1 ↦ s1 -∗ l2 ↦ s2 ==∗
  partition_ctx (<[l1 := ∅]>(<[l2 := s2 ∪ s1]>σ)) ∗ l1 ↦ ∅ ∗ l2 ↦ (s2 ∪ s1).
Proof.
  replace s1 with (∅ ∪ s1) at 1 by set_solver.
  iApply partition_move; set_solver.
Qed.

End definitions.

Lemma partition_init `{hP: partition_preG L V Σ}:
  ⊢ |==> ∃ names : gen_heap_names,
        let _ := {| partition_heap_inG :=
                      gen_heapG_update_pre (@partition_heap_preG _ _ _ _ _ _ _ _ _ hP) names |} in
        partition_ctx (∅: gmap L (gset V)).
Proof.
  iMod (gen_heap_name_init ∅) as (names) "H".
  iModIntro. iExists names. iFrame. rewrite //=.
Qed.


Require Import
  Hask.Control.Monad
  Hask.Data.Maybe
  Coq.Lists.List.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Import ListNotations.

Definition Effect := (Type -> Type) -> Type.

Inductive Effects (m : Type -> Type) : list Effect -> Type :=
  | NilE : Effects m []
  | ConsE effects : forall effect : Effect,
      effect m -> Effects m effects -> Effects m (effect :: effects).

Arguments ConsE : default implicits.

Definition combine `(e : effect m) `(xs : Effects m effects) :
  Effects m (effect :: effects) := ConsE _ e xs.

Infix ".:" := combine (at level 48, right associativity).

Class Handles (fs : list Effect) (effect : Effect) := {
  getEffect : forall m, Effects m fs -> effect m
}.

#[export]
Instance Handles_hd {fs : list Effect}  {f : Effect} :
  Handles (f :: fs) f.
Proof.
  constructor; intros.
  inversion X.
  exact X0.
Defined.

#[export]
Instance Handles_tl `{_ : Handles fs f} : Handles (x :: fs) f.
Proof.
  constructor; intros.
  inversion H.
  apply getEffect0.
  inversion X.
  exact X1.
Defined.

Definition TFree `(xs : list Effect) m a :=
  Effects m xs -> m a.

Definition Eff := TFree.

Definition liftF `{Handles effects effect} `{Monad m}
  `(getOp : effect m -> m a) : Eff effects m a :=
  fun effects => getOp (getEffect m effects).

Definition interpret `{H : Monad m} `(interpreter : Effects m effects)
  `(program : Eff effects m a) : m a := program interpreter.

#[export]
Instance TFree_Functor `(xs : list Effect) `{Monad m} : Functor (TFree xs m) := {
  fmap := fun A B f run => fun xs => fmap f (run xs)
}.

#[export]
Instance TFree_Applicative `(xs : list Effect) `{Monad m} : Applicative (TFree xs m) := {
  pure := fun _ x => fun xs => pure x;
  ap   := fun A B runf runx => fun xs => runf xs <*> runx xs
}.

#[export]
Instance TFree_Monad `(xs : list Effect) `{Monad m} : Monad (TFree xs m) := {
  join := fun A run => fun xs => run xs >>= fun f => f xs
}.

Record Abortive (m : Type -> Type) := {
  abortE : m unit
}.

Definition abort `{Handles r Abortive} : Eff r unit :=
  liftF abortE.

Record Reader (e : Type) (m : Type -> Type) := {
  askE : m e
}.

Definition ask `{Handles r (Reader e)} : Eff r e :=
  liftF (askE e).

Require Import Arith.

Set Printing Universes.

Definition example1 `{Handles r (Reader nat)} `{Handles r Abortive} :
  Eff r nat :=
  (fun x y => y + 15) <$> abort <*> ask.

Definition maybeInterpreter : Effects Maybe [Reader nat; Abortive] :=
  combine {| askE   := Just 10 |} (combine {| abortE := Nothing |} (NilE _)).

Definition run {a} : Eff [Reader nat; Abortive] a -> Maybe a :=
  interpret maybeInterpreter.

Example run_example1 : run example1 = Nothing.
Proof. reflexivity. Qed.

Definition example2 `{Handles r (Reader nat)} : Eff r nat :=
  fmap (plus 15) ask.

Example run_example2 : run example2 = Just 25.
Proof. reflexivity. Qed.

(*
Definition example3 `{Handles r (Reader nat)} `{Handles r Abortive} :
  Eff r nat :=
  v <- ask;
  if leb v 15
  then abort ;; pure 0
  else pure (v+1).

Example run_example3 : run example3 = None.
Proof. reflexivity. Qed.
*)