(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import IZF_logic.
Require Import IZF_base.
Require Import IZF_nat.

(*************)
(** * Zero   *)
(*************)

(** In set theory, zero is implemented as the empty set.  As a
    pointed graph, we can take any (non-empty) carrier and any
    root, with an empty edge relation: *)

Definition unit : Typ1 := forall X : Typ0, X -> X.
Definition id : unit := fun X x => x.
Definition ZERO : Rel unit := fun _ _ => bot.

Lemma ZERO_elim :
 forall (X : Typ1) (A : Rel X) (a : X), ELT X A a unit ZERO id -> bot.

Proof.
intros X A a H; apply H.
intros b' H1 H2; exact H1.
Qed.

(*******************************)
(** * The successor function   *)
(*******************************)

(** In set theory, the successor of von Neumann numeral n is encoded
    as the set  n U {n}, whose existence follows from the pairing
    axiom (used twice) and the union axiom, that have been already
    derived in the files "IZF_pair.v"  and "IZF_union.v".

    However, it is simpler to give here a direct implementation of the
    successor as follows.  Formally, the successor of a given pointed
    graph (X, A, a) is represented as the pointed graph

        ((opt X), (SUCC X A a), (none X))

    whose edge relation is defined by the following three clauses:

    1. Delocate A in the new graph via (some X):

         if (A x' x), then (SUCC X A a (some X x') (some X x))

    2. Connect the image of any direct element of the old root a:X
       to the new root:

         if (A x a), then (SUCC X A a (some X x) (none X))

    3. Connect the old root to the new root:

         (SUCC X A a (some X a) (none X)).

    As usual, we use a second-order encoding to define this relation. *)

Definition SUCC (X : Typ1) (A : Rel X) (a : X) : Rel (opt X) :=
  fun z' z =>
  forall E : Prop,
  (forall x x' : X,
   eq (opt X) z (some X x) -> eq (opt X) z' (some X x') -> A x' x -> E) ->
  (forall x' : X,
   eq (opt X) z (none X) -> eq (opt X) z' (some X x') -> A x' a -> E) ->
  (eq (opt X) z (none X) -> eq (opt X) z' (some X a) -> E) -> E.

Lemma SUCC_in :
 forall (X : Typ1) (A : Rel X) (a x x' : X),
 A x' x -> SUCC X A a (some X x') (some X x).

Proof
  fun X A a x x' H E H1 _ _ =>
  H1 x x' (eq_refl (opt X) (some X x)) (eq_refl (opt X) (some X x')) H.

Lemma SUCC_rt1 :
 forall (X : Typ1) (A : Rel X) (a x' : X),
 A x' a -> SUCC X A a (some X x') (none X).

Proof
  fun X A a x' H E _ H2 _ =>
  H2 x' (eq_refl (opt X) (none X)) (eq_refl (opt X) (some X x')) H.

Lemma SUCC_rt2 :
 forall (X : Typ1) (A : Rel X) (a : X), SUCC X A a (some X a) (none X).

Proof
  fun X A a E _ _ H3 =>
  H3 (eq_refl (opt X) (none X)) (eq_refl (opt X) (some X a)).

Lemma SUCC_deloc :
 forall (X : Typ1) (A : Rel X) (a : X),
 deloc X A (opt X) (SUCC X A a) (some X).

Proof.
intros X A a; unfold deloc in |- *; apply and_intro.
(* Deloc 1 *)
intros; apply SUCC_in; assumption.
(* Deloc 2 *)
intros x y' H; apply H; clear H.
(* Deloc 2, case 1 *)
intros x0 x' H1 H2 H3; apply ex2_intro with x'.
apply (eq_sym _ _ _ (eq_some_some X x x0 H1)); assumption.
assumption.
(* Deloc 2, case 2 (absurd) *)
intros x' H1 H2 H3; apply (eq_some_none _ _ H1).
(* Deloc 2, case 3 (absurd) *)
intros H1 H2; apply (eq_some_none _ _ H1).
Qed.

Lemma SUCC_eqv :
 forall (X : Typ1) (A : Rel X) (a x : X),
 EQV X A x (opt X) (SUCC X A a) (some X x).

Proof.
intros X A a x; apply EQV_deloc; apply SUCC_deloc.
Qed.

Lemma SUCC_intro1 :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 ELT Y B b X A a -> ELT Y B b (opt X) (SUCC X A a) (none X).

Proof.
intros X A a Y B b H; apply H; clear H; intros a' H1 H2.
apply ELT_intro with (some X a'). apply SUCC_rt1; assumption.
apply EQV_trans with X A a'. assumption. apply SUCC_eqv.
Qed.

Lemma SUCC_intro2 :
 forall (X : Typ1) (A : Rel X) (a : X),
 ELT X A a (opt X) (SUCC X A a) (none X).

Proof.
intros X A a; apply ELT_intro with (some X a).
apply SUCC_rt2. apply SUCC_eqv.
Qed.

Lemma SUCC_elim :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 ELT Y B b (opt X) (SUCC X A a) (none X) ->
 or (ELT Y B b X A a) (EQV Y B b X A a).

Proof.
intros X A a Y B b H; apply H; clear H.
intros z' H H1; apply H; clear H.
(* Case 1 (absurd) *)
intros x x' H2 H3 H4; apply (eq_none_some _ _ H2).
(* Case 2 *)
intros x' H2 H3 H4; apply or_inl; apply ELT_intro with x'.
assumption.
apply EQV_trans with (opt X) (SUCC X A a) (some X x').
apply H3; assumption. apply EQV_sym; apply SUCC_eqv.
(* Case 3 *)
intros H2 H3; apply or_inr.
apply EQV_trans with (opt X) (SUCC X A a) (some X a).
apply H3; assumption. apply EQV_sym; apply SUCC_eqv.
Qed.

Lemma successor :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 iff (ELT Y B b (opt X) (SUCC X A a) (none X))
   (or (ELT Y B b X A a) (EQV Y B b X A a)).

Proof.
intros X A a Y B b; unfold iff in |- *.
apply and_intro; intro H.
(* Direct implication (elim) *)
apply SUCC_elim; assumption.
(* Converse implication (intro1,2) *)
apply H; clear H; intro H.
apply SUCC_intro1; assumption.
apply ELT_compat_l with X A a.
assumption. apply SUCC_intro2.
Qed.

Lemma SUCC_compat :
 forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
 EQV X A a Y B b ->
 EQV (opt X) (SUCC X A a) (none X) (opt Y) (SUCC Y B b) (none Y).

Proof.
cut
 (forall (X : Typ1) (A : Rel X) (a : X) (Y : Typ1) (B : Rel Y) (b : Y),
  EQV X A a Y B b ->
  SUB (opt X) (SUCC X A a) (none X) (opt Y) (SUCC Y B b) (none Y)).
intros H X A a Y B b H1; apply extensionality.
apply H; assumption. apply H; apply EQV_sym; assumption.
unfold SUB in |- *; intros X A a Y B b H Z C c H1.
apply (SUCC_elim X A a Z C c H1); clear H1; intro H1.
apply SUCC_intro1; apply ELT_compat_r with X A a; assumption.
apply ELT_compat_l with Y B b.
apply EQV_trans with X A a; assumption.
apply SUCC_intro2.
Qed.

(**************************************)
(** * The set of von Neuman numerals  *)
(**************************************)

(** The set omega of von Neumann numerals is represented as the
    pointed graph ((opt nat), OMEGA, (none nat)) whose edge
    relation OMEGA : (Rel (opt nat)) is defined by the following
    two clauses:

    1. Delocation of the strict ordering "lt"

         if (wf_nat n), (wf_nat m) and (lt n m),
         then (OMEGA (some nat n) (some nat m))

    2. Connecting wf_nat's to the new root:

         if (wf_nat n), then (OMEGA (some nat n) (none nat)).

    As usual, we define it via a second-order encoding: *)

Definition OMEGA : Rel (opt nat) :=
  fun z' z =>
  forall E : Prop,
  (forall n n' : nat,
   eq (opt nat) z (some nat n) ->
   eq (opt nat) z' (some nat n') -> wf_nat n -> wf_nat n' -> lt n' n -> E) ->
  (forall n' : nat,
   eq (opt nat) z (none nat) ->
   eq (opt nat) z' (some nat n') -> wf_nat n' -> E) -> E.

(** The corresponding constructors are the following: *)

Lemma OMEGA_in :
 forall n : nat,
 wf_nat n ->
 forall m : nat, wf_nat m -> lt n m -> OMEGA (some nat n) (some nat m).

Proof
  fun n Hn m Hm H E H1 _ =>
  H1 m n (eq_refl (opt nat) (some nat m)) (eq_refl (opt nat) (some nat n)) Hm
    Hn H.

Lemma OMEGA_rt : forall n : nat, wf_nat n -> OMEGA (some nat n) (none nat).

Proof
  fun n Hn E _ H2 =>
  H2 n (eq_refl (opt nat) (none nat)) (eq_refl (opt nat) (some nat n)) Hn.

(** The pointed graph ((opt nat), OMEGA, (some nat O)) is bisimilar
    to the pointed graph (unit ZERO id) that represents the empty set.
    This is done by extensionality. *)

Lemma OMEGA_ZERO : EQV (opt nat) OMEGA (some nat O) unit ZERO id.

Proof.
apply extensionality; unfold SUB in |- *; intros X A a H.
(* Direct inclusion *)
apply H; clear H; intros z H H1; apply H; clear H.
(* Case 1 (absurd) *)
intros n m H2 H3 Hn Hm H4.
generalize (eq_sym _ _ _ (eq_some_some _ _ _ H2)); intro H5.
apply (lt_n_O m (H5 (lt m) H4)).
(* Case 2 (absurd) *)
intros n H2 H3 Hn; apply (eq_some_none _ _ H2).
(* Converse inclusion *)
apply H; clear H; intros u H H1; apply H.
Qed.

(** Inductive case: for any n:nat such that (wf_nat n), the pointed
    graph ((opt nat), OMEGA, (some nat (S n))) is bisimilar to the
    successor of the pointed graph ((opt nat), OMEGA, (some nat n)).
    Again, this is done by extensionality. *)

Lemma OMEGA_SUCC :
 forall n : nat,
 wf_nat n ->
 EQV (opt nat) OMEGA (some nat (S n)) (opt (opt nat))
   (SUCC (opt nat) OMEGA (some nat n)) (none (opt nat)).

Proof.
intros n Hn; apply extensionality; unfold SUB in |- *; intros X A a H.
(* Direct inclusion *)
apply H; clear H; intros z H H1; apply H; clear H.
(* Case 1 *)
intros n0 m H H2 Hn0 Hm H3.
generalize (eq_sym _ _ _ (eq_some_some _ _ _ H)); clear H; intro H.
generalize (H (lt m) H3); clear H H3 Hn0 n0; intro H3.
(* Case 1: Case disjunction on (lt m (S n)) *)
apply (lt_n_Sm m Hm n Hn H3); clear H3; intro H3.
(* Case 1a: (lt m n) *)
apply SUCC_intro1; apply ELT_intro with (some nat m).
exact (OMEGA_in m Hm n Hn H3).  apply H2; assumption.
(* Case 1b: (eq nat m n) *)
apply ELT_compat_l with (opt nat) OMEGA (some nat n).
apply H3; apply H2; assumption.  apply SUCC_intro2.
(* Case 2 (absurd) *)
intros m H H2 Hm; apply (eq_some_none _ _ H).
(* Converse inclusion *)
apply (SUCC_elim _ _ _ _ _ _ H); clear H; intro H.
(* Case 1 *)
apply H; clear H; intros z H H1; apply H; clear H.
(* Case 1a *)
intros n0 m H H2 Hn0 Hm H3.
generalize (eq_sym _ _ _ (eq_some_some _ _ _ H)); clear H; intro H.
generalize (H (lt m) H3); clear H H3 Hn0 n0; intro H3.
apply ELT_intro with (some nat m).
exact (OMEGA_in m Hm (S n) (wf_nat_S n Hn) (lt_S m n H3)).
apply H2; assumption.
(* Case 1b (absurd) *)
intros m H H2 Hm; apply (eq_some_none _ _ H).
(* Case 2 *)
apply ELT_intro with (some nat n).
exact (OMEGA_in n Hn (S n) (wf_nat_S n Hn) (lt_n_Sn n)).
assumption.
Qed.

(** ** The axiom of infinity **)

(** The set denoted by the pointed graph ((opt nat), OMEGA, (none nat))
    contains zero (i.e. the empty set)... *)

Theorem omega_zero : ELT unit ZERO id (opt nat) OMEGA (none nat).

Proof.
apply ELT_intro with (some nat O).
exact (OMEGA_rt O wf_nat_O).
apply EQV_sym; exact OMEGA_ZERO.
Qed.

(** ... and is closed under successor: *)

Theorem omega_succ :
 forall (X : Typ1) (A : Rel X) (a : X),
 ELT X A a (opt nat) OMEGA (none nat) ->
 ELT (opt X) (SUCC X A a) (none X) (opt nat) OMEGA (none nat).

Proof.
intros X A a H; apply H; clear H; intros z H H1; apply H; clear H.
(* Case 1 (absurd) *)
intros n m H H2 Hn Hm H3; apply (eq_none_some _ _ H).
(* Case 2 *)
intros n H0 H Hn; apply ELT_intro with (some nat (S n)).
exact (OMEGA_rt (S n) (wf_nat_S n Hn)).
apply
 EQV_trans
  with (opt (opt nat)) (SUCC (opt nat) OMEGA (some nat n)) (none (opt nat)).
apply SUCC_compat; apply H; assumption.
apply EQV_sym; apply OMEGA_SUCC; assumption.
Qed.

(** And we now check the induction principle on omega: *)

Require Import IZF_select.  (* For PRED and Compat *)

Theorem omega_ind
 :
 (* If P is a compatible predicate such that: *)
 forall P : PRED,
 Compat P ->
 (* 1. P holds for zero *)
 P unit ZERO id ->
 (* 2. If P holds for an element of omega, then
         P holds for the successor of this element *)
 (forall (X : Typ1) (A : Rel X) (a : X),
  ELT X A a (opt nat) OMEGA (none nat) ->
  P X A a -> P (opt X) (SUCC X A a) (none X)) ->
 (* Then: P holds for any element of omega *)
 forall (X : Typ1) (A : Rel X) (a : X),
 ELT X A a (opt nat) OMEGA (none nat) -> P X A a.

Proof.
intros P HP HO HS X A a H; apply H; clear H.
intros z H H1; apply H; clear H.
(* Case 1 (absurd) *)
intros n m H H2 Hn Hm H3; apply (eq_none_some _ _ H).
(* Case 2 *)
intros n H0 H Hn; clear H0.
apply (HP _ _ _ _ _ _ (EQV_sym _ _ _ _ _ _ H1)).
apply (eq_sym _ _ _ H); clear H H1 a A X z.
(* Perform induction on n:nat *)
apply (nat_ind' n Hn); clear Hn n.
(* Basic case *)
apply HP with unit ZERO id.
apply EQV_sym; exact OMEGA_ZERO. assumption.
(* Inductive case *)
intros n Hn Hind.
apply
 HP with (opt (opt nat)) (SUCC (opt nat) OMEGA (some nat n)) (none (opt nat)).
apply EQV_sym; apply OMEGA_SUCC; assumption.
apply HS. apply ELT_direct; apply OMEGA_rt; assumption.
assumption.
Qed.


From Mtac2 Require Import Mtac2.

Import M.

Require Import Lists.List.
Import ListNotations.

Set Use Unicoq.

Structure execV {A} (f : M A) B := ExecV { value : B } .

Canonical Structure the_value {A} (f : M A) v := ExecV _ f (lift f v) v.

Arguments value {A} f {B} {e}.

Definition exec {A} (f : M A) {v:A} : lift f v := v.

Goal True.
refine (let H := _ in let _ : value (ret I) = H := eq_refl in H).
Qed.

Goal True.
refine (exec (print "hola";; ret I)).
Qed.

Goal True.
refine (exec (raise exception)).
Abort. (* note that it doesn't fail, it just silently leaves the goal open
 (in fact, the proof will contain exec) *)

Notation "'[ex' t ']'" := (exec t) (at level 0).

Goal [ex ret True] = True.
  unfold exec.
  reflexivity.
Qed.
Import M.notations.
Definition silly :=
  fix f (n: nat) : M Prop :=
    match n with
    | 0 => ret True
    | S n' => f n' >>= fun r=>ret (True -> r)
    end.

Goal [ex silly 3] : _. (* we need the : to make sure it triggers the rule for lift *)
  unfold exec.
Abort.

(*
Module Second.
Import First.
Section Inlist.

Parameter A : Type.

Structure inlist x := Inlist { list_of :> list A; proof : In x list_of }.
Arguments list_of {x} i.
Arguments proof {x} i.

Program
Definition unify {A} (x y : A) (P : A -> Type) (f : P y) : M (P x) :=
    mmatch x with
    | y => [H] ret (meq_rect_r P f H)
    | _ => raise exception
    end.

Import M.notations.

Program Canonical Structure cons_inst x y s (f : execV (
  mtry
    unify y x (fun z=>In x (z :: s)) (in_eq x s)
  with exception =>
    e <- evar (inlist x);
    unify s (list_of e) (fun l=>In x (y :: l))
      (in_cons y x (list_of e) (proof e))
  end))
 := Inlist x (y :: value _ f) (result f).

Program Canonical app_inst x s1 (f : execV (fun s2=>
  e <- evar (inlist x);
  mtry
    unify s1 (list_of e) (fun s1 => In x (s1 ++ s2))
      (in_or_app (list_of e) s2 x (or_introl (proof e)))
  with NotUnifiableException =>
    unify s2 (list_of e) (fun s2 => In x (s1 ++ s2))
      (in_or_app s1 (list_of e) x (or_intror (proof e)))
  end))  := Inlist x (s1 ++ value _ f) (result f).

Definition test (x y z : A) : In x (x :: y :: z :: nil) := proof _.
Definition test1 (x y z : A) : In y (x :: y :: z :: nil) := proof _.
Definition test3 (x y z : A) : In y ([z;y] ++ [x;z]) := proof _.
Definition test4 (x y z : A) s : In z (s ++ [x;z]) := proof _.

End Inlist.

*)


Require Import FunctionalExtensionality ProofIrrelevance JMeq.
Require Export Adjoint Functor Category.
Require Import Common Notations FunctorCategory NaturalTransformation Hom Duals SetLimits SetColimits LimitFunctors LimitFunctorTheorems InducedLimitFunctors DefinitionSimplification FEqualDep FunctorialComposition ExponentialLaws FunctorProduct NatCategory DiscreteCategoryFunctors ProductLaws CommaCategoryFunctors.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Local Open Scope category_scope.

Local Ltac pre_anihilate :=
  simpl;
  subst_body;
  clear;
  nt_hideProofs;
  unfold NTComposeF, NTComposeT; simpl;
  nt_hideProofs;
  clear; simpl in *.

(* TODO(jgross): Check if [simpl in *] would make this faster. *)
Local Ltac step := clear; subst_body;
                   ((abstract (autorewrite with category; reflexivity))
                      (*|| (abstract apply SliceCategoryInducedFunctor_FIdentityOf)
                      || (abstract apply CosliceCategoryInducedFunctor_FIdentityOf)
                      || (abstract apply SliceCategoryInducedFunctor_FCompositionOf)
                      || (abstract apply CosliceCategoryInducedFunctor_FCompositionOf)*)
                      || apply CommaSpecializedCategory_Morphism_eq
                      || apply f_equal
                      || (apply f_equal2; try reflexivity; [])
                      || apply sigT_eq (* simpl_eq *)
                      || (progress nt_eq)
                      || (progress functor_eq)
                      || (progress (destruct_head_hnf @CommaSpecializedCategory_Object;
                                    destruct_head_hnf @CommaSpecializedCategory_Morphism;
                                    destruct_sig)));
                   simpl; trivial.

Local Ltac anihilate := repeat step.

Local Ltac t :=
  repeat match goal with
           | _ => reflexivity
           | _ => progress (subst_body; trivial)
           | _ => progress (simpl in *; unfold Object in *; repeat intro)
           (* | _ => progress nt_hideProofs *) (* makes things slower, I think; it probably needs a more delicate application *)
           | _ => progress simpl_eq'
           | _ => progress (apply Functor_eq || apply Functor_JMeq)
           | _ => progress (apply NaturalTransformation_eq || apply NaturalTransformation_JMeq)
           | _ => progress apply CommaSpecializedCategory_Morphism_eq
           | _ => progress (destruct_head_hnf @CommaSpecializedCategory_Object; destruct_head_hnf @CommaSpecializedCategory_Morphism)
           | _ => progress destruct_sig
           | _ => progress autorewrite with morphism
           | _ => progress repeat rewrite FIdentityOf
           | [ |- @eq (LaxCosliceSpecializedCategory_Object _ _) _ _ ] => expand; apply f_equal
           | [ |- @eq (LaxCosliceSpecializedCategory_Morphism _ _) _ _ ] => expand; apply f_equal
           | [ |- @eq (LaxSliceSpecializedCategory_Object _ _) _ _ ] => expand; apply f_equal
           | [ |- @eq (LaxSliceSpecializedCategory_Morphism _ _) _ _ ] => expand; apply f_equal
           | _ => progress (apply functional_extensionality_dep_JMeq; intros)
         end.

Section DataMigrationFunctors.
  Context `(C : LocallySmallSpecializedCategory objC).
  Context `(D : LocallySmallSpecializedCategory objD).
  Context `(S : SpecializedCategory objS).

  Section Δ.
    Definition PullbackAlongFunctor : ((S ^ C) ^ (S ^ D)) ^ (D ^ C)
      := (ExponentialLaw4Functor_Inverse _ _ _) (FunctorialComposition _ _ _).
    Definition PullbackAlong (F : SpecializedFunctor C D) : (S ^ C) ^ (S ^ D)
      := Eval hnf in PullbackAlongFunctor F.
    (*

    Local Arguments ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf / .
    Local Arguments ExponentialLaw4Functor_Inverse_ObjectOf / .
    Local Arguments FunctorialComposition / .
    Local Arguments ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf / .

    Let PullbackAlongFunctor'' : { F | PullbackAlongFunctor' = F }.
      assert (Hf : focus (exist _ PullbackAlongFunctor' eq_refl)) by constructor.
      subst_body.
      simpl in Hf.

      Implicit Arguments exist [A P].
      unfold IdentityFunctor, IdentityNaturalTransformation, NTComposeF, NTComposeT, ComposeFunctors in Hf.
      simpl in Hf.
    Let PullbackAlong' (F : SpecializedFunctor C D) : { PA : (S ^ C) ^ (S ^ D) | PullbackAlongFunctor' F = PA }.
      pre_abstract_trailing_props.
      functor_simpl_abstract_trailing_props_with_equality.
    Defined.
    Let PullbackAlongFunctor'_MorphismOf' s d m : { T : Morphism _ (proj1_sig (PullbackAlong' s)) (proj1_sig (PullbackAlong' d))
                                                 | T == MorphismOf PullbackAlongFunctor' (s := s) (d := d) m }.
      repeat match goal with
               | [ |- context[proj1_sig ?E] ] => destruct (proj2_sig E)
             end.
      pre_abstract_trailing_props.
      nt_simpl_abstract_trailing_props_with_equality.
    Defined.

    Definition PullbackAlong (F : SpecializedFunctor C D) : (S ^ C) ^ (S ^ D)
      := Eval hnf in proj1_sig (PullbackAlong' F).

    Let PullbackAlongFunctor'' : ((S ^ C) ^ (S ^ D)) ^ (D ^ C).
      hnf.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
                                           PullbackAlong
                                           (fun s d m => proj1_sig (@PullbackAlongFunctor'_MorphismOf' s d m))
                                           _
                                           _)
      end.
      intros.
      change PullbackAlong with (fun F => proj1_sig (PullbackAlong' F)); cbv beta.
      unfold PullbackAlongFunctor'_MorphismOf'.
      simpl.
      match goal with
        | [ |- context[proj1_sig ?E] ] => let H := fresh in let H' := fresh in set (H' := E) in *; set (H := proj2_sig H'); destruct H; simpl
      end.

      repeat m
      exact (FCompositionOf PullbackAlongFunctor').
      let f := fresh in pose PullbackAlongFunctor' as f; destruct f.
      assumption.
      destruct PullbackAlongFunctor'.

      refine (

    Let PullbackAlongFunctor'_MorphismOf'' s d (m : Morphism (D ^ C) s d) : Morphism _ (PullbackAlong s) (PullbackAlong d)
      := Eval cbv beta iota zeta delta [PullbackAlongFunctor'_MorphismOf' proj1_sig proj2_sig PullbackAlong'] in proj1_sig (@PullbackAlongFunctor'_MorphismOf' s d m).
    Print PullbackAlongFunctor'_MorphismOf''.

    Definition PullbackAlongFunctor'_MorphismOf'' s d (m : Morphism (D ^ C) s d) : Morphism _ (PullbackAlong s) (PullbackAlong d)
    Print PullbackAlongFunctor'_MorphismOf''.

                                                 | T == MorphismOf PullbackAlongFunctor' (s := s) (d := d) m }.

    Let
    Print PullbackAlong''.

      pre_abstract_trailing_props.
      functor_simpl_abstract_trailing_props_with_equality.
    Defined.
    Let Definition
    Goal True.
    pose (fun F => proj1_sig (PullbackAlong' F)) as f.
    unfold PullbackAlong' in f.
    hnf in f.
    simpl in f.
    simpl in f.
    pose (fun s d m => proj1_sig (@PullbackAlongFunctor'_MorphismOf' s d m)) as g.
    unfold PullbackAlongFunctor'_MorphismOf' in g.
    hnf in g.
    simpl in g.
    simpl in g.
    Eval simpl in PullbackAlong'.
    Let PullbackAlongFunctor'_MorphismOf s d m : { T : Morphism _ (proj1_sig (PullbackAlong' s)) (proj1_sig (PullbackAlong' d))
                                                 | T == MorphismOf PullbackAlongFunctor' (s := s) (d := d) m }.
      assert (Hf : focus (proj1_sig (@PullbackAlongFunctor'_MorphismOf' s d m))) by constructor.
      unfold PullbackAlongFunctor'_MorphismOf' in Hf.
      simpl in Hf.
      destruct_match_in_hyp Hf.
      simpl in Hf.
      destruct (projT2 (PullbackAlong' s)).
      destruct (projT2 (PullbackAlong' d)).

(* HERE *)
      match type of Hf with
        | focus ?E => (exists E)
      end.

      subst_body.

      pose
      unfold PullbackAlongFunctor'_MorphismOf in f.
      simpl in f.
      let f' := (eval hnf in f) in
      match f' with
        | appcontext[match ?E with _ => _ end] => let x := fresh in set (x := E) in *; destruct x
      end.
      simpl in f.
      revert f; clear.

      set (x := projT2 (PullbackAlong' s)) in *.
      destruct x.
      set (x := projT2 (PullbackAlong' d)) in *.
      destruct x.
      simpl.
      destruct (projT2 (PullbackAlong' s)).
      revert f; subst_body; intro f.
      hnf in f.
      simpl in f.
      set (H := (PullbackAlong'_subproof1 (PullbackAlong'_subproof d)
                 (PullbackAlong'_subproof0 d))) in *.
      simpl in *.
      hnf.
      intro f.
      destruct H.
      match type of H with
        | ?a = ?b => set (A := a) in *; set (B := b) in *
      end.
      destruct H.

      destruct (projT2 (PullbackAlong' s)).
      hnf in f.
      revert f; subst_body; clear; intro f.
      let f' := (eval hnf in f) in
      match f' with
        | appcontext[match ?E with _ => _ end] => destruct E
      end.
      Transparent JMeq_rect_r.
      Print JMeq_rect_r.
      unfold JMeq_rect_r.

      revert f; subst_body; clear; intro f.
      subst PullbackAlongFunctor'_MorphismOf.
      re

      simpl in *.
      simpl.
      unfold Morphism.
      change
      unfold Morphism, FunctorCategory at 1.
      functor_simpl_abstract_trailing_props_with_equality.
    Defined.
    Definition PullbackAlong (F : SpecializedFunctor C D) : SpecializedFunctor (S ^ D) (S ^ C)
      := Eval hnf in PullbackAlong' F.
    Print PullbackAlong.
      := ComposeFunctors (FunctorialComposition C D S)
                         (ComposeFunctors ((IdentityFunctor (S ^ D)) * (FunctorFromDiscrete (D ^ C) (fun _ : Object 1 => F)))
                                          (ProductLaw1Functor_Inverse _)).

*)
  End Δ.
  Local Arguments PullbackAlongFunctor / .
  Eval simpl in PullbackAlongFunctor.

  Section Π.
    Local Notation "A ↓ F" := (CosliceSpecializedCategory A F).
    (*Local Notation "C / c" := (@SliceSpecializedCategoryOver _ _ C c).*)

    (** Quoting David Spivak in "Functorial Data Migration":
       Definition 2.1.2. Let [F : C -> D] be a morphism of schemas and
       [Δ_F : D–Set -> C–Set] be the associated data pull-back functor
       (see Definition 1.3.1). There exists a right adjoint to [Δ_F]
       called the right push-forward functor associated to [F], denoted
       [Π_F : C–Set -> D–Set], and defined as follows.
       Given an object [ɣ : C -> Set] in [C–Set] define [Π_F ɣ] on an
       object [d : D] as
       [[
         Π_F ɣ(d) := lim_{d ↓ F} (ɣ ○ (π^F d))
       ]]
       This is simply the limit of the functor
       [[
         (d ↓ F) --- (π^F d) ---> C --- ɣ ---> Set
       ]]
       Given a map [h : d -> d'] in D one obtains a map
       [Π_F ɣ(h) : Π_F ɣ(d) -> Π_F ɣ(d')] by the universal property of
       limits.
       The idea is this. We have some [C-set] [ɣ] and we want a [D-set]
       [Π_F ɣ]. To each object in [d] we look at the objects in [C]
       which are sent to the right of [d] (i.e. those equipped with a
       chosen morphism from [d]). Each has been assigned by [ɣ]some
       set of rows; we take the limit of all these sets and assign
       that to [Π_F ɣ(d)].
     *)

    Section pre_functorial.
      Variable F : SpecializedFunctor C D.

      (* Define [ɣ ○ (π^F d)] *)
      Definition RightPushforwardAlong_pre_pre_Functor (g : S ^ C) (d : D) : SpecializedFunctor (d ↓ F) S.
        refine (ComposeFunctors (ComposeFunctors g (projT2 (CosliceCategoryProjectionFunctor C D F d))) _).
        unfold CosliceSpecializedCategory, SliceSpecializedCategory_Functor, Object; simpl.
        refine (CommaCategoryInducedFunctor (s := (_, F)) (d := (_, F)) (_, IdentityNaturalTransformation F)).
        simpl.
        match goal with
          | [ |- SpecializedNaturalTransformation ?F ?G ] =>
            refine (Build_SpecializedNaturalTransformation F G
                                                           (fun _ => Identity _)
                                                           _)
        end;
          simpl; abstract (intros; reflexivity).
      Defined.

      (*Variable HasLimits : forall g d, Limit (RightPushforwardAlong_pre_Functor g d).*)
      (* Variable HasLimits : forall d (F' : SpecializedFunctor (d ↓ F) S), Limit F'.*)

      Let Index2Cat d := d ↓ F.

      Local Notation "'CAT' ⇑ D" := (@LaxCosliceSpecializedCategory _ _ Index2Cat _ D).

      (*Let HasLimits' (C0 : CAT ⇑ S) : Limit (projT2 C0)
        := HasLimits (projT2 C0). *)

      Let RightPushforwardAlong_pre_curried_ObjectOf_pre (g : S ^ C) (d : D) : CAT ⇑ S
        := existT _ (tt, _) (RightPushforwardAlong_pre_pre_Functor g d) : LaxCosliceSpecializedCategory_ObjectT Index2Cat S.

      Let RightPushforwardAlong_pre_curried_ObjectOf (gd : (S ^ C) * D) : CAT ⇑ S
        := RightPushforwardAlong_pre_curried_ObjectOf_pre (fst gd) (snd gd).

      Let RightPushforwardAlong_pre_curried_MorphismOf_pre g d g' d' (m : Morphism (S ^ C) g g') (m' : Morphism D d d') :
        Morphism (CAT ⇑ S) (RightPushforwardAlong_pre_curried_ObjectOf_pre g d) (RightPushforwardAlong_pre_curried_ObjectOf_pre g' d').
        constructor.
        exists (tt, CosliceCategoryMorphismInducedFunctor F _ _ m').
        subst_body; simpl in *;
        unfold RightPushforwardAlong_pre_pre_Functor;
        simpl;
        unfold Object, Morphism, GeneralizeFunctor.
        match goal with
          | [ |- SpecializedNaturalTransformation ?F ?G ] =>
            let F' := eval hnf in F in let G' := eval hnf in G in change (SpecializedNaturalTransformation F' G')
        end.
        exists (fun c : d' ↓ F => m (snd (projT1 c)) : Morphism S _ _).
        simpl;
          abstract (
              intros; rewrite Commutes; reflexivity
            ).
      Defined.

      Definition RightPushforwardAlong_pre_curried_MorphismOf gd g'd' (m : Morphism ((S ^ C) * D) gd g'd') :
        Morphism (CAT ⇑ S) (RightPushforwardAlong_pre_curried_ObjectOf gd) (RightPushforwardAlong_pre_curried_ObjectOf g'd')
        := @RightPushforwardAlong_pre_curried_MorphismOf_pre (fst gd) (snd gd) (fst g'd') (snd g'd') (fst m) (snd m).

      Lemma RightPushforwardAlong_pre_curried_FCompositionOf (s d d' : SpecializedFunctor C S * LSObject D)
            (m1 : Morphism ((S ^ C)%functor * D) s d)
            (m2 : Morphism ((S ^ C)%functor * D) d d') :
        RightPushforwardAlong_pre_curried_MorphismOf (Compose m2 m1) =
        Compose (RightPushforwardAlong_pre_curried_MorphismOf m2)
                (RightPushforwardAlong_pre_curried_MorphismOf m1).
      Proof.
        unfold RightPushforwardAlong_pre_curried_MorphismOf, RightPushforwardAlong_pre_curried_ObjectOf.
      (*(* for speed *)
      Admitted. *)
        Time pre_anihilate.
        Time anihilate.
      Qed.

      Lemma RightPushforwardAlong_pre_curried_FIdentityOf (o : SpecializedFunctor C S * LSObject D) :
        RightPushforwardAlong_pre_curried_MorphismOf (Identity o) =
        Identity (RightPushforwardAlong_pre_curried_ObjectOf o).
      Proof.
        unfold RightPushforwardAlong_pre_curried_MorphismOf, RightPushforwardAlong_pre_curried_ObjectOf.
      (*(* for speed *)
      Admitted. *)
        Time pre_anihilate.
        Time anihilate.
      Qed.

      Definition RightPushforwardAlong_pre_curried : SpecializedFunctor ((S ^ C) * D) (CAT ⇑ S).
        match goal with
          | [ |- SpecializedFunctor ?F ?G ] =>
            exact (Build_SpecializedFunctor F G
                                            RightPushforwardAlong_pre_curried_ObjectOf
                                            RightPushforwardAlong_pre_curried_MorphismOf
                                            RightPushforwardAlong_pre_curried_FCompositionOf
                                            RightPushforwardAlong_pre_curried_FIdentityOf
                  )
        end.
      Defined.
    End pre_functorial.

    Section functorial.
      Let Index2Cat (dF : D * (D ^ C)) := (fst dF) ↓ (snd dF).

      Local Notation "'CAT' ⇑ D" := (@LaxCosliceSpecializedCategory _ _ Index2Cat _ D).

      Let RightPushforwardAlongFunctor_pre_curried_ObjectOf (dgF : D * ((S ^ C) * (OppositeCategory (D ^ C)))) : CAT ⇑ S
        := let d := fst dgF in
           let g := fst (snd dgF) in
           let F := snd (snd dgF) in
           existT _ (tt, (d, F)) (projT2 (RightPushforwardAlong_pre_curried F (g, d))) : LaxCosliceSpecializedCategory_ObjectT Index2Cat S.

      Definition RightPushforwardAlongFunctor_pre_curried_MorphismOf dgF d'g'F' (m : Morphism (D * ((S ^ C) * (OppositeCategory (D ^ C)))) dgF d'g'F') :
        Morphism (CAT ⇑ S)
                 (RightPushforwardAlongFunctor_pre_curried_ObjectOf dgF)
                 (RightPushforwardAlongFunctor_pre_curried_ObjectOf d'g'F').
        constructor.
        let d := constr:(fst dgF) in
        let g := constr:(fst (snd dgF)) in
        let F := constr:(snd (snd dgF)) in
        let d' := constr:(fst d'g'F') in
        let g' := constr:(fst (snd d'g'F')) in
        let F' := constr:(snd (snd d'g'F')) in
        let md := constr:(fst m) in
        let mg := constr:(fst (snd m)) in
        let mF := constr:(snd (snd m)) in
        exists (tt, CosliceCategoryInducedFunctor d' d md mF);
          exists (fun c : CommaSpecializedCategory_Object (SliceSpecializedCategory_Functor D d') F'
                  => mg (snd (projT1 c)));
          simpl; subst_body;
          abstract (
              intros;
              destruct_head @CommaSpecializedCategory_Object;
              destruct_head @CommaSpecializedCategory_Morphism;
              destruct_sig;
              destruct_head_hnf @prod;
              simpl in *;
                apply Commutes
            ).
      Defined.

      Definition RightPushforwardAlongFunctor_pre_curried : SpecializedFunctor (D * ((S ^ C) * (OppositeCategory (D ^ C)))) (CAT ⇑ S).
        match goal with
          | [ |- SpecializedFunctor ?C ?D ] =>
            refine (Build_SpecializedFunctor C D
                                             RightPushforwardAlongFunctor_pre_curried_ObjectOf
                                             RightPushforwardAlongFunctor_pre_curried_MorphismOf
                                             _
                                             _)
        end.
        Time abstract t.
        Time abstract t.
      Defined.
    End functorial.

    Section applied.
      Variable HasLimits : forall (F : SpecializedFunctor C D) d (F' : SpecializedFunctor (d ↓ F) S), Limit F'.

      Let Index2Cat (dF : D * (D ^ C)) := (fst dF) ↓ (snd dF).

      Local Notation "'CAT' ⇑ D" := (@LaxCosliceSpecializedCategory _ _ Index2Cat _ D).

      Let HasLimits' (C0 : CAT ⇑ S) : Limit (projT2 C0)
        := HasLimits (projT2 C0).

      Definition RightPushforwardAlongFunctor_curried : SpecializedFunctor (D * ((S ^ C) * (OppositeCategory (D ^ C)))) S
        := ComposeFunctors (InducedLimitFunctor HasLimits') RightPushforwardAlongFunctor_pre_curried.

      Definition RightPushforwardAlongFunctor : ((S ^ D) ^ (S ^ C)) ^ (OppositeCategory (D ^ C))
        := (ExponentialLaw4Functor_Inverse _ _ _) ((ExponentialLaw4Functor_Inverse _ _ _) RightPushforwardAlongFunctor_curried).

      (*Definition RightPushforwardAlong_ObjectOf (x : S ^ C) (F : (OppositeCategory (D ^ C))) : S ^ D
        := ComposeFunctors RightPushforwardAlongFunctor_curried (ComposeFunctors (IdentityFunctor _ * FunctorFrom1 _ (x, F)) (ProductLaw1Functor_Inverse _)).
      Definition RightPushforwardAlong_MorphismOf s0 d0 (m0 : Morphism (S ^ C) s0 d0) s1 d1 (m1 : Morphism (OppositeCategory (D ^ C)) s1 d1) :
        Morphism (S ^ D) (RightPushforwardAlong_ObjectOf s0 s1) (RightPushforwardAlong_ObjectOf d0 d1).
        hnf.
        assert (forall x, Morphism _ ((RightPushforwardAlong_ObjectOf s0 s1) x) ((RightPushforwardAlong_ObjectOf d0 d1) x)).
        intro.
        Print ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf.
        simpl.
        Print ExponentialLaw4Functor_Inverse.
        Check ExponentialLaw4Functor_Inverse_ObjectOf _. *)

      (*
      Definition RightPushforwardAlong_MorphismOf_ComponentsOf_Pre (s d : S ^ C) (m : SpecializedNaturalTransformation s d) (c : D) :
        NaturalTransformation
          (ComposeFunctors (RightPushforwardAlong_pre_Functor s c) (IdentityFunctor _))
          (RightPushforwardAlong_pre_Functor d c).
      Proof.
        eapply (NTComposeT (ComposeFunctorsAssociator1 _ _ _) _).
        Grab Existential Variables.
        match goal with
          | [ |- SpecializedNaturalTransformation ?F ?G ] =>
            refine (Build_SpecializedNaturalTransformation F G
                                                           (fun x => m (snd (projT1 x)))
                                                           _
                   )
        end;
          abstract (
              repeat (let H := fresh in intro H; destruct H as [ [ [ ] ] ]; simpl in * );
              match goal with
                | [ H : _ |- _ ] => rewrite RightIdentity in H
                | [ H : _ |- _ ] => rewrite LeftIdentity in H
              end;
              subst;
              apply Commutes
            ).
      Defined.

      Definition RightPushforwardAlong_MorphismOf_ComponentsOf (s d : S ^ C) (m : SpecializedNaturalTransformation s d) (c : D) :
        Morphism S ((RightPushforwardAlong_ObjectOf s) c) ((RightPushforwardAlong_ObjectOf d) c).
      Proof.
        simpl; subst_body; simpl.
        apply (InducedLimitMap (G := IdentityFunctor _)).
        exact (@RightPushforwardAlong_MorphismOf_ComponentsOf_Pre s d m c).
      Defined.

      Definition RightPushforwardAlong_MorphismOf (s d : S ^ C) (m : SpecializedNaturalTransformation s d) :
        SpecializedNaturalTransformation (RightPushforwardAlong_ObjectOf s) (RightPushforwardAlong_ObjectOf d).
      Proof.
        exists (@RightPushforwardAlong_MorphismOf_ComponentsOf s d m).
        rename d into t.
        intros d d' g.
        unfold RightPushforwardAlong_MorphismOf_ComponentsOf, RightPushforwardAlong_ObjectOf, RightPushforwardAlong_ObjectOf_MorphismOf; simpl.
        pose InducedLimitFunctor_FCompositionOf as H;
          unfold InducedLimitFunctor_MorphismOf in *.
        rewrite <- H.
        simpl in *.

       *)
      End applied.
  End Π.

  Section Σ.
    Local Notation "F ↓ A" := (SliceSpecializedCategory A F).
    (*Local Notation "C / c" := (@SliceSpecializedCategoryOver _ _ C c).*)

    (** Quoting David Spivak in "Functorial Data Migration":
       Definition 2.1.3. Let [F : C -> D] be a morphism of schemas and
       [Δ_F : D–Set -> C–Set] be the associated data pull-back functor
       (see Definition 1.3.1). There exists a left adjoint to [Δ_F]
       called the left push-forward functor associated to [F], denoted
       [Σ_F : C–Set -> D–Set], and defined as follows.
       Given an object [ɣ : C -> Set] in [C–Set] define [Σ_F ɣ] on an
       object [d : D] as
       [[
         Σ_F ɣ(d) := colim_{F ↓ d} (ɣ ○ (π_F d))
       ]]
       This is simply the limit of the functor
       [[
         (F ↓ d) --- (π_F d) ---> C --- ɣ ---> Set
       ]]
       Given a map [h : d -> d'] in D one obtains a map
       [Σ_F ɣ(h) : Σ_F ɣ(d) -> Σ_F ɣ(d')] by the universal property of
       colimits.

       Here, we have some [C-set] [ɣ] and we want a [D-set] [Σ_F ɣ].
       To each object in [d] we look at the objects in [C] which are
       sent to the left of [d] (i.e. those equipped with a chosen
       morphism to [d]). Each has been assigned by [ɣ] some set of
       rows; we take the colimit of all these sets and assign that to
       [Σ_F ɣ(d)].
     *)

    Section pre_functorial.
      Variable F : SpecializedFunctor C D.

      Let Index2Cat d := F ↓ d.

      Local Notation "'CAT' ⇓ D" := (@LaxSliceSpecializedCategory _ _ Index2Cat _ D).

      (* Define [ɣ ○ (π_F d)] *)
      Definition LeftPushforwardAlong_pre_pre_Functor (g : S ^ C) (d : D) : SpecializedFunctor (F ↓ d) S.
        refine (ComposeFunctors (ComposeFunctors g (projT2 (SliceCategoryProjectionFunctor C D F d))) _).
        unfold SliceSpecializedCategory, SliceSpecializedCategory_Functor, Object; simpl.
        refine (CommaCategoryInducedFunctor (s := (F, _)) (d := (F, _)) (IdentityNaturalTransformation F, _)).
        simpl.
        match goal with
          | [ |- SpecializedNaturalTransformation ?F ?G ] =>
            refine (Build_SpecializedNaturalTransformation F G
                                                           (fun _ => Identity _)
                                                           _)
        end;
          simpl; abstract (intros; reflexivity).
      Defined.

      Let LeftPushforwardAlong_pre_curried_ObjectOf_pre (g : S ^ C) (d : D) : CAT ⇓ S
        := existT _ (_, tt) (LeftPushforwardAlong_pre_pre_Functor g d) : LaxSliceSpecializedCategory_ObjectT _ Index2Cat S.

      Let LeftPushforwardAlong_pre_curried_ObjectOf (gd : (S ^ C) * D) : CAT ⇓ S
        := LeftPushforwardAlong_pre_curried_ObjectOf_pre (fst gd) (snd gd).

      Let LeftPushforwardAlong_pre_curried_MorphismOf_pre g d g' d' (m : Morphism (S ^ C) g g') (m' : Morphism D d d') :
        Morphism (CAT ⇓ S) (LeftPushforwardAlong_pre_curried_ObjectOf_pre g d) (LeftPushforwardAlong_pre_curried_ObjectOf_pre g' d').
        constructor.
        exists (SliceCategoryMorphismInducedFunctor F _ _ m', tt).
        subst_body; simpl in *;
        unfold LeftPushforwardAlong_pre_pre_Functor;
        simpl;
        unfold Object, Morphism, GeneralizeFunctor.
        match goal with
          | [ |- SpecializedNaturalTransformation ?F ?G ] =>
            let F' := eval hnf in F in let G' := eval hnf in G in change (SpecializedNaturalTransformation F' G')
        end.
        exists (fun c : F ↓ d => m (fst (projT1 c)) : Morphism S _ _).
        simpl;
          abstract (
              intros; rewrite Commutes; reflexivity
            ).
      Defined.

      Definition LeftPushforwardAlong_pre_curried_MorphismOf gd g'd' (m : Morphism ((S ^ C) * D) gd g'd') :
        Morphism (CAT ⇓ S) (LeftPushforwardAlong_pre_curried_ObjectOf gd) (LeftPushforwardAlong_pre_curried_ObjectOf g'd')
        := @LeftPushforwardAlong_pre_curried_MorphismOf_pre (fst gd) (snd gd) (fst g'd') (snd g'd') (fst m) (snd m).

      Lemma LeftPushforwardAlong_pre_curried_FCompositionOf (s d d' : SpecializedFunctor C S * LSObject D)
            (m1 : Morphism ((S ^ C)%functor * D) s d)
            (m2 : Morphism ((S ^ C)%functor * D) d d') :
        LeftPushforwardAlong_pre_curried_MorphismOf (Compose m2 m1) =
        Compose (LeftPushforwardAlong_pre_curried_MorphismOf m2)
                (LeftPushforwardAlong_pre_curried_MorphismOf m1).
      Proof.
        unfold LeftPushforwardAlong_pre_curried_MorphismOf, LeftPushforwardAlong_pre_curried_ObjectOf.
      (* (* for speed *)
      Admitted. *)
        Time pre_anihilate.
        Time anihilate.
      Qed.

      Lemma LeftPushforwardAlong_pre_curried_FIdentityOf (o : SpecializedFunctor C S * LSObject D) :
        LeftPushforwardAlong_pre_curried_MorphismOf (Identity o) =
        Identity (LeftPushforwardAlong_pre_curried_ObjectOf o).
      Proof.
        unfold LeftPushforwardAlong_pre_curried_MorphismOf, LeftPushforwardAlong_pre_curried_ObjectOf.
      (* (* for speed *)
      Admitted. *)
        Time pre_anihilate.
        Time anihilate.
      Qed.

      Definition LeftPushforwardAlong_pre_curried : SpecializedFunctor ((S ^ C) * D) (CAT ⇓ S).
        match goal with
          | [ |- SpecializedFunctor ?F ?G ] =>
            exact (Build_SpecializedFunctor F G
                                            LeftPushforwardAlong_pre_curried_ObjectOf
                                            LeftPushforwardAlong_pre_curried_MorphismOf
                                            LeftPushforwardAlong_pre_curried_FCompositionOf
                                            LeftPushforwardAlong_pre_curried_FIdentityOf
                  )
        end.
      Defined.
    End pre_functorial.

    Section functorial.
      Let Index2Cat (dF : D * (D ^ C)) := (snd dF) ↓ (fst dF).

      Local Notation "'CAT' ⇓ D" := (@LaxSliceSpecializedCategory _ _ Index2Cat _ D).

      Let LeftPushforwardAlongFunctor_pre_curried_ObjectOf (dgF : D * ((S ^ C) * (OppositeCategory (D ^ C)))) : CAT ⇓ S
        := let d := fst dgF in
           let g := fst (snd dgF) in
           let F := snd (snd dgF) in
           existT _ ((d, F), tt) (projT2 (LeftPushforwardAlong_pre_curried F (g, d))) : LaxSliceSpecializedCategory_ObjectT _ Index2Cat S.

      Definition LeftPushforwardAlongFunctor_pre_curried_MorphismOf dgF d'g'F' (m : Morphism (D * ((S ^ C) * (OppositeCategory (D ^ C)))) dgF d'g'F') :
        Morphism (CAT ⇓ S)
                 (LeftPushforwardAlongFunctor_pre_curried_ObjectOf dgF)
                 (LeftPushforwardAlongFunctor_pre_curried_ObjectOf d'g'F').
        constructor.
        let d := constr:(fst dgF) in
        let g := constr:(fst (snd dgF)) in
        let F := constr:(snd (snd dgF)) in
        let d' := constr:(fst d'g'F') in
        let g' := constr:(fst (snd d'g'F')) in
        let F' := constr:(snd (snd d'g'F')) in
        let md := constr:(fst m) in
        let mg := constr:(fst (snd m)) in
        let mF := constr:(snd (snd m)) in
        exists (SliceCategoryInducedFunctor d d' md mF, tt);
          exists (fun c : CommaSpecializedCategory_Object F (SliceSpecializedCategory_Functor D d)
                  => mg (fst (projT1 c)));
          simpl; subst_body;
          abstract (
              intros;
              destruct_head @CommaSpecializedCategory_Object;
              destruct_head @CommaSpecializedCategory_Morphism;
              destruct_sig;
              destruct_head_hnf @prod;
              simpl in *;
                apply Commutes
            ).
      Defined.

      Definition LeftPushforwardAlongFunctor_pre_curried : SpecializedFunctor (D * ((S ^ C) * (OppositeCategory (D ^ C)))) (CAT ⇓ S).
        match goal with
          | [ |- SpecializedFunctor ?C ?D ] =>
            refine (Build_SpecializedFunctor C D
                                             LeftPushforwardAlongFunctor_pre_curried_ObjectOf
                                             LeftPushforwardAlongFunctor_pre_curried_MorphismOf
                                             _
                                             _)
        end.
        Time abstract t.
        Time abstract t.
      Defined.
    End functorial.

    Section applied.
      Variable HasColimits : forall (F : SpecializedFunctor C D) d (F' : SpecializedFunctor (F ↓ d) S), Colimit F'.

      Let Index2Cat (dF : D * (D ^ C)) := (snd dF) ↓ (fst dF).

      Local Notation "'CAT' ⇓ D" := (@LaxSliceSpecializedCategory _ _ Index2Cat _ D).

      Let HasColimits' (C0 : CAT ⇓ S) : Colimit (projT2 C0)
        := HasColimits (projT2 C0).

      Definition LeftPushforwardAlongFunctor_curried : SpecializedFunctor (D * ((S ^ C) * (OppositeCategory (D ^ C)))) S
        := ComposeFunctors (InducedColimitFunctor HasColimits') LeftPushforwardAlongFunctor_pre_curried.

      Definition LeftPushforwardAlongFunctor : ((S ^ D) ^ (S ^ C)) ^ (OppositeCategory (D ^ C))
        := (ExponentialLaw4Functor_Inverse _ _ _) ((ExponentialLaw4Functor_Inverse _ _ _) LeftPushforwardAlongFunctor_curried).
    End applied.
  End Σ.
End DataMigrationFunctors.


(** * Synthesis.RTL: RTL language, with three address code. *)
Require Import Common.
Require Import DList.
Require  Core Front IR Equality.

Section t.
  Variable Phi : Core.state.

  Notation updates := (DList.T (Common.comp option  Core.eval_mem) Phi).

  Section defs.
    Import Core.
    Variable Var : type -> Type.

    Inductive expr : type -> Type :=
    | Evar : forall t, Var t -> expr t
    | Einput : forall t, var Phi (Tinput t) -> expr t
    | Eread : forall t,  var Phi (Treg t) -> expr t
    | Eread_rf : forall n t, var Phi (Tregfile n t) -> Var (Tint n) -> expr t

    | Eandb : Var B -> Var B -> expr B
    | Eorb  : Var B -> Var B -> expr B
    | Exorb : Var B -> Var B -> expr B
    | Enegb : Var B -> expr B

    (* "type-class" *)
    | Eeq   : forall t, Var t -> Var t -> expr B

    (* integer operations *)
    | Elt   : forall n, Var (Int n) -> Var (Int n) -> expr B
    | Ele   : forall n, Var (Int n) -> Var (Int n) -> expr B
    | Eadd  : forall n, Var (Int n) -> Var (Int n) -> expr (Int n)
    | Esub  : forall n, Var (Int n) -> Var (Int n) -> expr (Int n)
    | Elow  : forall n m, Var (Int (n + m)) -> expr (Int n)
    | Ehigh  : forall n m, Var (Int (n + m)) -> expr (Int m)
    | EcombineLH   : forall n m, Var (Int n) -> Var (Int m) -> expr (Int (n + m))

    | Econstant : forall ty : type, constant ty -> expr ty
    | Emux : forall t : type,
               Var Tbool ->  Var t -> Var t -> expr  t
    | Efst : forall (l : list type) (t : type),
               Var (Ttuple (t :: l)) -> expr t
    | Esnd : forall (l : list type) (t : type),
               Var (Ttuple (t :: l)) -> expr (Ttuple l)
    | Enth : forall (l : list type) (t : type),
               var l t -> Var (Ttuple l) -> expr t
    | Etuple : forall l : list type,
                 DList.T (Var) l -> expr  (Ttuple l).

    Inductive telescope (A : Type): Type :=
    | telescope_end : A -> telescope A
    | telescope_bind : forall arg, expr arg -> (Var arg -> telescope A) -> telescope A.

    Fixpoint compose {A B}
                     (tA : telescope  A)
                     (f : A -> telescope  B) :
      telescope  B :=
      match tA with
        | telescope_end e => f e
        | telescope_bind arg b cont => telescope_bind _  arg b (fun x => compose (cont x) f)
      end.
    Notation "e :-- t1 ; t2 " := (compose t1 (fun e => t2)) (right associativity, at level 80, e1 at next level).

    Inductive effect  : mem -> Type :=
    | effect_reg_write : forall t,  Var t -> Var Tbool -> effect (Treg t)
    | effect_regfile_write : forall n t,  Var t -> Var (Tint n) -> Var Tbool ->
                                     effect (Tregfile n t).

    Definition effects := DList.T (option ∘ effect) Phi.

    Definition block t := telescope (Var t * Var Tbool *  effects).
    Notation ret x := (telescope_end _ x).
    Notation " & e " := (telescope_bind _ _ e (fun x => ret x)) (at level 71).
    Notation "x :- e1 ; e2" := (telescope_bind  _ _  e1 (fun x => e2)) (right associativity, at level 80, e1 at next level).

    Fixpoint compile_expr t (e : Front.expr Var t) : telescope (Var t) :=
      match e with
        | Front.Evar t v => ret v
        | Front.Eandb a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Eandb a b)
        | Front.Eorb a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Eorb a b)
        | Front.Exorb a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Exorb a b)
        | Front.Enegb a => a :-- compile_expr _ a;
                          & (Enegb a)
        | Front.Eeq t a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Eeq _ a b)
        | Front.Elt n a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Elt _ a b)
        | Front.Ele n a b => a :-- compile_expr _ a;
                            b :-- compile_expr _ b;
                            & (Ele _ a b)
        | Front.Eadd n a b => a :-- compile_expr _ a;
                             b :-- compile_expr _ b;
                             & (Eadd _ a b)
        | Front.Esub n a b => a :-- compile_expr _ a;
                              b :-- compile_expr _ b;
                              & (Esub _ a b)
        | Front.Elow n m a => a :-- compile_expr _ a;
                             & (Elow n m a)
        | Front.Ehigh n m a => a :-- compile_expr _ a;
                              & (Ehigh n m a)
        | Front.EcombineLH n m a b  => a :-- compile_expr _ a;
                                      b :-- compile_expr _ b;
                                      & (EcombineLH n m a b)
        | Front.Econstant ty c => & (Econstant _ c)
        | Front.Emux t c l r =>
            c :-- compile_expr _ c;
            l :-- compile_expr _ l;
            r :-- compile_expr _ r;
            & (Emux t c l r)
        | Front.Efst l t x =>
          x :-- compile_expr _ x;
          & (Efst l t x)
        | Front.Esnd l t x =>
          x :-- compile_expr _ x;
          & (Esnd l t x)
        | Front.Enth l t m x =>
          x :-- compile_expr _ x;
          & (Enth l t m x)
        | Front.Etuple l exprs =>
          let fix of_list
                  (l : list type)
                  (x : DList.T (Front.expr Var) l) :
                telescope (DList.T Var l) :=
              match x in  (DList.T _ l)
                    return
                    (telescope (DList.T Var l)) with
                | DList.nil => ret ([ :: ])%dlist
                | DList.cons t q dt dq =>
                  x  :-- compile_expr t dt;
                    dq :--   of_list q dq;
                   ret (x :: dq)%dlist
              end in

                  exprs :-- of_list l exprs;
                & (Etuple l exprs)
      end.

    Fixpoint compile_exprs l (x: DList.T (Front.expr Var) l) :  telescope (DList.T Var l) :=
      match x in  (DList.T _ l)
         return
         (telescope (DList.T Var l)) with
        | DList.nil => ret ([ :: ])%dlist
        | DList.cons t q dt dq =>
            x  :-- compile_expr t dt;
            dq :--   compile_exprs q dq;
            ret  (x :: dq)%dlist
      end.

    Lemma compile_exprs_fold :
      (fix of_list (l : list Core.type)
           (x0 : DList.T
                       (Front.expr Var) l)
           {struct x0} :
       telescope
                   (DList.T Var l) :=
       match
         x0 in (DList.T _ l0)
          return
          (telescope (DList.T Var l0))
       with
         | DList.nil => ret DList.nil
         | DList.cons t1 q0 dt dq =>
             x1 :-- compile_expr t1 dt;
             dq0 :-- of_list q0 dq;
             ret (DList.cons x1 dq0)
       end) = compile_exprs.
    Proof. reflexivity. Qed.

    Definition compile_effects (e : IR.effects Phi Var)  : effects.
    unfold effects. refine  (DList.map _  e).
    intros a x.
    refine (match x with
              | None => None
              | Some x => match x with
                           | IR.effect_reg_write t v g =>
                               Some (effect_reg_write t v g)
                           | IR.effect_regfile_write n t v adr g =>
                               Some (effect_regfile_write n t v adr g)
                         end
            end).

    Defined.

    Definition compile t  (b : IR.block Phi Var t) : block t.
    refine (let fold := fix fold t (b : IR.block Phi Var t) : block t :=
                match b with
                  | IR.telescope_end x =>
                      match x with
                          (r, g,e) => g :-- compile_expr _ g; ret (r,g,compile_effects e)
                        end
                  | IR.telescope_bind a bd k =>
                      match bd with
                        | IR.bind_input_read v =>
                          x :- Einput a v; fold _ (k x)
                        | IR.bind_expr x =>
                            x :-- compile_expr _ x ; fold _ (k x)
                        | IR.bind_reg_read x =>
                            x :- Eread a x; fold _ (k x)
                        | IR.bind_regfile_read n x x0 =>
                            x :- Eread_rf n a x x0; fold _ (k x)
                      end
                end in fold t b
           ).
      Defined.
  End defs.
  Section sem.

    Variable st : Core.eval_state Phi.

    Definition eval_expr (t : Core.type) (e : expr Core.eval_type t) : Core.eval_type t:=
      match e with
        | Evar t v => v
        | Eread t v => (DList.get v st)
        | Einput t v => DList.get v st
        | Eread_rf n t v adr =>
          let rf := DList.get  v st in
          Common.Regfile.get rf (adr)
        | Eandb a b => andb a b
        | Eorb a b =>  orb  a b
        | Exorb a b => xorb  a b
        | Enegb a => negb a
        | Eeq t a b => Core.type_eq t a b
        | Elt n a b => Word.lt a b
        | Ele n a b => Word.le a b
        | Eadd n a b => Word.add a b
        | Esub n a b => Word.sub a b
        | Elow n m a =>  Word.low n m a
        | Ehigh n m a => Word.high n m a
        | EcombineLH n m a b  =>  Word.combineLH n m  a b
        | Emux t b x y => if b then x else y
        | Econstant ty c => c
        | Etuple l exprs =>
          DList.to_tuple (fun _ X => X) exprs
        | Enth l t v e =>
          Common.Tuple.get _ _ v e
        | Efst l t  e =>
          Common.Tuple.fst e
        | Esnd l t  e =>
          Common.Tuple.snd e
      end.

    Definition eval_effects (e : effects Core.eval_type) (Delta : updates) : updates.
    unfold effects in e.

    (* refine (DList.fold Phi _ e Delta).  *)
    refine (DList.map3 _ Phi e st Delta).
    Import Common Core.
    Definition eval_effect (a : Core.mem) :
      (Common.comp option (effect Core.eval_type)) a ->
      Core.eval_mem a -> (Common.comp option Core.eval_mem) a -> (Common.comp option Core.eval_mem) a.

    refine (fun  eff =>
              match eff with
                | Some eff =>
                    match eff in effect _ s return eval_mem s -> (option ∘ eval_mem) s -> (option ∘ eval_mem) s  with
                      |  effect_reg_write t val we =>
                           fun _ old =>
                             match old with
                               | Some _ => old
                               | None => if we then Some val else None
                             end
                      |  effect_regfile_write n t val adr we =>
                           fun rf old =>
                             match old with
                               | Some _ => old
                               | None =>
                                   if we then
                                     let rf := Regfile.set rf adr val in
                                       Some rf
                                   else
                                     None
                             end
                    end
                | None => fun _ old => old
              end).
    Defined.
    apply eval_effect.
    Defined.

    Fixpoint eval_telescope { A B} (F : A -> B) (T : telescope  eval_type A) :=
      match T with
        | telescope_end X => F X
        | telescope_bind arg bind cont =>
            let res := eval_expr arg bind in
              eval_telescope F (cont res)
      end.

    Definition eval_block  t  (T : block eval_type t) Delta :
      option (eval_type t * updates) :=
      eval_telescope (fun x => match x with (p,g,e)  =>
                                             if g : bool then
                                               Some (p, eval_effects e Delta)
                                             else None end) T.
  End sem.
End t.

Notation "e :-- t1 ; t2 " := (compose _ _  t1 (fun e => t2)) (right associativity, at level 80, e1 at next level).
Notation "x :- e1 ; e2" := (telescope_bind _ _ _ _ (e1) (fun x => e2)) (right associativity, at level 80, e1 at next level).
Notation " & e " := (telescope_end _   _ _ e) (at level 71).

Section correctness.
  Import Equality.

  Lemma compile_effects_correct Phi st   e :
    forall Delta,
      eval_effects Phi st (compile_effects Phi Core.eval_type e) Delta =
                 IR.eval_effects Phi st e Delta.
  Proof.
    induction Phi. simpl. auto.
    simpl; intros. unfold IR.effects in e. repeat DList.inversion.
    case_eq x; intros; simpl; subst;
    destruct x1.
    dependent destruction e0. simpl.
    rewrite IHPhi; reflexivity.
    simpl; f_equal; auto.
    simpl; f_equal; auto.
    simpl; f_equal; auto.
    destruct e. simpl. reflexivity.
    simpl. reflexivity.
    simpl. f_equal. auto.
  Qed.

  Hint Resolve compile_effects_correct.

  Lemma foo {Phi R A B C} (T: telescope Phi R A) (f : A -> telescope  Phi R B)  (g : B -> telescope Phi R C) :
    (X :-- (Y :-- T; f Y); (g X) )= (Y :-- T; X :-- f Y; g X).
  Proof.
    induction T. reflexivity. simpl.
    f_equal.
    Require Import  FunctionalExtensionality.
    apply functional_extensionality.
    apply H.
  Qed.

  Section compile_expr.
    Context {A B : Type}.
    Context {E : A -> B}.
    Variable (Phi : Core.state) (st : Core.eval_state Phi).
    Notation Ev := (eval_telescope Phi st E).

    Section compile_exprs.
      Notation P := (fun t e =>
                       forall  (f : Core.eval_type t -> telescope _ _ A),
                         Ev(r :-- compile_expr Phi Core.eval_type t e; f r) =
                           Ev (f (Front.eval_expr t e))).
      Lemma compile_exprs_correct : forall l dl f,
                                      DList.Forall P dl ->
                                      Ev (Y :-- compile_exprs Phi Core.eval_type l dl; f Y) =
                                         Ev (f (DList.map Front.eval_expr dl )).
      Proof.
        induction dl. simpl. reflexivity.
        simpl. intros. rewrite foo. destruct H. rewrite H. rewrite foo. simpl. apply IHdl. auto.
      Qed.
    End compile_exprs.
    Lemma compile_expr_correct t e (f : Core.eval_type t -> telescope _ _ A):
      Ev (r :-- compile_expr Phi Core.eval_type t e; f r) = Ev (f (Front.eval_expr t e)).
    Proof.

      revert t e f .

      fix IHe 2; destruct e; intros f; simpl;
      repeat (match goal with
                  |- context [ (_ :-- _ :-- _; _ ; _) ] => (rewrite foo; simpl)
                | |- context [_ :-- compile_expr _ _ ?t ?x; _] => rewrite (IHe t x)

             end); try reflexivity.

      { simpl. rewrite (compile_exprs_fold Phi Core.eval_type). repeat rewrite foo; simpl.
        rewrite compile_exprs_correct.
        simpl; rewrite DList.map_to_tuple_commute. reflexivity.

        clear f. induction exprs; simpl. auto.
        split. apply IHe. auto.  }  Qed.
  End compile_expr.

  Lemma compile_correct Phi st t (b : IR.block Phi Core.eval_type t) :
    forall Delta,
      eval_block Phi st t (compile Phi Core.eval_type t b) Delta = IR.eval_block Phi st t b Delta.
  Proof.
    intros.
    induction b.
    simpl. destruct a as [[r g] e]; simpl.
    unfold eval_block.

    rewrite (compile_expr_correct Phi st Core.Tbool g). simpl.
    destruct (Front.eval_expr Core.Tbool g); repeat f_equal.

    apply compile_effects_correct.

    simpl. rewrite <- H. clear H.
    unfold eval_block. destruct b; try reflexivity.

    rewrite (compile_expr_correct Phi st arg e) . reflexivity.
  Qed.
End correctness.

Section equiv.
  Import Core.
  Variable U V : type -> Type.
  Variable Phi : state.

  Reserved Notation "x == y" (at level 70, no associativity).
  Reserved Notation "x ==e y" (at level 70, no associativity).

  Section inner_equiv.
  Variable R : forall t, U t -> V t -> Type.
  Notation "x -- y" := (R _ x y) (at level 70, no associativity).

  Inductive expr_equiv : forall t,  expr Phi U t -> expr Phi V t -> Type :=
  | Eq_read : forall t v, Eread Phi U t v == Eread Phi V t v
  | Eq_read_rf : forall n t v adr1 adr2,
                   adr1 -- adr2 ->
                   Eread_rf Phi U n t v adr1 == Eread_rf Phi V n t v adr2
  | Eq_andb : forall a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Eandb Phi U a1 b1 == Eandb Phi V a2 b2
  | Eq_orb : forall a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Eorb Phi U a1 b1 == Eorb Phi V a2 b2
  | Eq_xorb : forall a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Exorb Phi U a1 b1 == Exorb Phi V a2 b2
  | Eq_negb : forall a1 a2, a1 -- a2 ->
                             Enegb Phi U a1 == Enegb Phi V a2
  | Eq_eq : forall t a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Eeq Phi U t a1 b1 == Eeq Phi V t a2 b2
  | Eq_lt : forall n a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Elt Phi U n a1 b1 == Elt Phi V n a2 b2
  | Eq_add : forall n a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                             Eadd Phi U n a1 b1 == Eadd Phi V n a2 b2
  | Eq_sub : forall n a1 a2 b1 b2, a1 -- a2 -> b1 -- b2 ->
                              Esub Phi U n a1 b1 == Esub Phi V n a2 b2
  | Eq_low : forall n m a1 a2,  a1 -- a2 ->
                           Elow Phi U n m a1 == Elow Phi V n m a2
  | Eq_high : forall n m a1 a2,  a1 -- a2 ->
                            Ehigh Phi U n m a1 == Ehigh Phi V n m a2
  | Eq_combineLH : forall n m a1 a2 b1 b2,  a1 -- a2 -> b1 -- b2 ->
                            EcombineLH Phi U n m a1 b1 == EcombineLH Phi V n m a2 b2
  | Eq_constant : forall ty c, Econstant Phi U ty c == Econstant Phi V ty c
  | Eq_mux : forall t c1 c2 l1 l2 r1 r2,
               c1 -- c2 -> l1 -- l2 -> r1 -- r2 ->
               Emux Phi U t c1 l1 r1 ==  Emux Phi V t c2 l2 r2

  | Eq_fst : forall (l : list type) (t : type) dl1 dl2,
               dl1 -- dl2 ->
               Efst Phi U l t dl1 == Efst Phi V l t dl2

  | Eq_snd : forall (l : list type) (t : type) dl1 dl2,
               dl1 -- dl2 ->
               Esnd Phi U l t dl1 == Esnd Phi V l t dl2

  | Eq_nth : forall (l : list type) (t : type) (v : Common.var l t)  dl1 dl2,
               dl1 -- dl2 ->
               Enth Phi U l t v dl1 == Enth Phi V l t v dl2

  | Eq_tuple : forall (l : list type) dl1 dl2,
                 DList.pointwise R l dl1 dl2 ->
               Etuple Phi U l dl1 == Etuple Phi V l dl2
                            where "x == y" := (expr_equiv _ x y).

  Inductive effect_equiv : forall t,  option (effect U t) -> option (effect V t) -> Type :=
  | Eq_none : forall t, effect_equiv t None None
  | Eq_write : forall t v1 v2 we1 we2,
                 v1 -- v2 -> we1 -- we2 ->
                 Some (effect_reg_write U t v1 we1) ==e Some  (effect_reg_write V t v2 we2)
  | Eq_write_rf : forall n t v1 v2 adr1 adr2 we1 we2,
                    v1 -- v2 -> adr1 -- adr2 -> we1 -- we2 ->
                    Some (effect_regfile_write U n t v1 adr1 we1) ==e
                         Some (effect_regfile_write V n t v2 adr2 we2)
                                  where "x ==e y" := (effect_equiv _ x y).

  Definition effects_equiv : effects Phi U -> effects Phi V -> Type :=
    DList.pointwise  effect_equiv Phi.

  End inner_equiv.

  Inductive Gamma : Type :=
  | nil : Gamma
  | cons : forall t, U t -> V t -> Gamma -> Gamma.

  Inductive In t (x : U t) (y : V t) : Gamma -> Type :=
  | In_ok : forall Gamma x' y', x' = x -> y' = y ->
              In t x y (cons t x' y' Gamma )
  | In_skip : forall Gamma t' x' y',
                In t x y Gamma ->
                In t x y (cons t' x' y' Gamma ).

  Definition R G := fun t x y => In t x y G.

  Reserved Notation "G |- x ==b y" (at level 70, no associativity).
  Notation "G |- x -- y" := (In _ x y G) (at level 70, no associativity).

  Inductive block_equiv t : forall (G : Gamma), block Phi U t -> block Phi V t -> Type :=
  | Eq_end : forall G (v1 : U t) v2 g1 g2 e1 e2,
               G |- v1 -- v2 -> G |- g1 -- g2 -> effects_equiv (R G) e1 e2 ->
               G |- telescope_end Phi U _ (v1, g1, e1) ==b telescope_end Phi V _ (v2,g2, e2 )
  | Eq_bind : forall G a (e1 : expr Phi U a) e2 (k1 : U a -> block Phi U t) k2,
                expr_equiv (R G) _ e1 e2 ->
                (forall v1 v2, (* G |- v1 -- v2 ->  *)cons _ v1 v2 G |- k1 v1 ==b k2 v2) ->
                G |- telescope_bind Phi U _ a e1 k1 ==b telescope_bind Phi V _ a e2 k2
                 where "G |- x ==b y" := (block_equiv _ G x y).
End equiv.

Definition Block Phi t := forall V, block Phi V t.
Definition WF Phi t (b : Block Phi t) := forall U V, block_equiv U V Phi t (nil _ _) (b _) (b _).
Definition Compile Phi t (B : IR.Block Phi t) : Block Phi t :=
  fun V => compile _ _ _ (B _).

Definition Next Phi st t (B : Block Phi t) :=
  match eval_block Phi st t (B _) (Front.Diff.init Phi) with
    | None => None
    | Some Delta => Some (fst Delta, Front.Diff.apply Phi (snd Delta) st)
  end.

Theorem Compile_correct Phi t b st:
  Next Phi st t (Compile Phi t b) =  IR.Next Phi st t b.
Proof.
  unfold Next, Compile, IR.Next. intros. rewrite compile_correct. reflexivity.
Qed.

Arguments Evar {Phi Var t} v.
Arguments Eread {Phi Var t} v.
Arguments Eread_rf {Phi Var n t} _ _ .
Arguments Econstant {Phi Var ty} _.
Arguments Emux {Phi Var t} _ _ _.
Arguments Efst {Phi Var l t} _.
Arguments Esnd {Phi Var l t} _.
Arguments Enth {Phi Var l t} _ _.
Arguments Etuple {Phi Var l} _%dlist.


Require Import FP.Classes.Monad.
Require Import FP.Data.Unit.
Require Import FP.Data.List.
Require Import FP.Data.Product.
Require Import FP.Data.Option.
Require Import FP.Core.

Definition store (D:qtype -> qtype) L V := list (L × D V).

Class MonadStoreState D L V m :=
  { getStore : dom (m (store D L V))
  ; putStore : dom (store D L V ⇒ m unit)
  }.

Section MonadStoreState.
  Context {D L V m} `{! Monad m ,! MonadStoreState D L V m }.

  Definition modifyStore : dom ((store D L V ⇒ store D L V) ⇒ m unit) := λ f →
    e ← getStore ;;
    putStore $ f ∙ e.

  Definition lookupStore `{! DecEqv (dom L) ,! MonadPlus m } : dom (L ⇒ m (D V)) := λ n →
    (liftOption ⊙ llookup ∙ n) =<< getStore.
End MonadStoreState.


Require Import FP.Core.

Class Galois (A B:qtype) :=
  { galoisα : dom (A ⇒ B)
  ; galoisγ : dom (B ⇒ A)
  ; galois_id_αγ : galoisα ⊙ galoisγ ⊑ id
  ; galois_id_γα : id ⊑ galoisγ ⊙ galoisα
  }.
Global Opaque galoisα.
Global Opaque galoisγ.

Ltac GaloisRewrite :=
  match goal with
  | |- ⟨ (galoisα (A:=?A) (B:=?B)) ⊙ (galoisγ (A:=?A) (B:=?B)) IN _ |LTE| _ ⟩ =>
      WeakenBy (galois_id_αγ (A:=A) (B:=B))
  | |- ⟨ galoisα ∙ (galoisγ ∙ ?e) IN _ |LTE| _ ⟩ =>
      WeakenBy (qmonotonic_elim galois_id_αγ e e libReflexivity)
  | |- ⟨ (galoisγ (A:=?A) (B:=?B)) ⊙ (galoisα (A:=?A) (B:=?B)) IN _ |GTE| _ ⟩ =>
      StrengthenBy (galois_id_γα (A:=A) (B:=B))
  | |- ⟨ galoisγ ∙ (galoisα ∙ ?e) IN _ |GTE| _ ⟩ =>
      StrengthenBy (qmonotonic_elim galois_id_γα e e libReflexivity)
  end.

Instance : forall A B `{! Galois A B }, Galois (A ⇒ A) (B ⇒ B) :=
  { galoisα := λ f → galoisα ⊙ f ⊙ galoisγ
  ; galoisγ := λ g → galoisγ ⊙ g ⊙ galoisα
  }.
Proof.
  - Re fail || GaloisRewrite.
  - Re fail || GaloisRewrite.
Defined.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_withdrawFromPoolingRound (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Opaque RoundsBase_Ф_withdrawStakeInPoolingRound DePoolFuncs.RoundsBase_Ф_withdrawStakeInPoolingRound.

Lemma DePoolContract_Ф_withdrawFromPoolingRound_exec: forall (Л_withdrawValue: Z) (l: Ledger),
 let sender := eval_state msg_sender l in
 let isExtMsg : bool := negb (sender =? 0) in
 let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
 let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
 let partHasValue : bool := xMaybeIsSome optParticipant in
 let participant := maybeGet optParticipant  in
 let minStake := eval_state (↑12 ε DePoolContract_ι_m_minStake) l in
 let (rp', l_withdraw) := run (↓ RoundsBase_Ф_withdrawStakeInPoolingRound participant sender Л_withdrawValue minStake) l in
 let (removedPoolingStake, participant') := rp' in
 let sender' := eval_state msg_sender l_withdraw in
 let l_set := exec_state (↓ ParticipantBase_Ф__setOrDeleteParticipant sender' participant') l_withdraw in
 let l_transfer := exec_state (tvm_transfer sender' removedPoolingStake false 64 default) l_set in

 exec_state (↓ DePoolContract_Ф_withdrawFromPoolingRound Л_withdrawValue) l =
 if isExtMsg then
    if isPoolClosed then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_DEPOOL_CLOSED 0 ) l
       else if (negb partHasValue) then exec_state (DePoolContract_Ф__sendError DePool_ι_STATUS_NO_PARTICIPANT 0 ) l
                                   else l_transfer
 else l.
 Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve. idtac.
  all: try destructFunction4 RoundsBase_Ф_withdrawStakeInPoolingRound; auto. idtac.
  all: try destruct x; auto. idtac.
  all: time repeat destructIf_solve.

 Qed.

Lemma DePoolContract_Ф_withdrawFromPoolingRound'_eval: forall (Л_withdrawValue: Z) (l: Ledger),
let sender := eval_state msg_sender l in
let isExtMsg : bool := negb ( sender =? 0) in
let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let partHasValue : bool := xMaybeIsSome optParticipant in

eval_state (↓ (DePoolContract_Ф_withdrawFromPoolingRound' Л_withdrawValue)) l =
if isExtMsg then
   if isPoolClosed then Value (Error I)
      else if (negb partHasValue) then Value (Error I) else Value (Value I)
else Error Errors_ι_IS_EXT_MSG .
Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve. idtac.
  all: try destructFunction4 RoundsBase_Ф_withdrawStakeInPoolingRound; auto. idtac.
  all: try destruct x; auto. idtac.
  all: time repeat destructIf_solve.

Qed.

Lemma DePoolContract_Ф_withdrawFromPoolingRound_eval: forall (Л_withdrawValue: Z) (l: Ledger),
let sender := eval_state msg_sender l in
let isExtMsg : bool := negb ( sender =? 0) in
let isPoolClosed : bool := eval_state (↑12 ε DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let partHasValue : bool := xMaybeIsSome optParticipant in

eval_state (↓ (DePoolContract_Ф_withdrawFromPoolingRound Л_withdrawValue)) l =
if isExtMsg then
   if isPoolClosed then Value I
      else if (negb partHasValue) then Value I else Value I
else Error Errors_ι_IS_EXT_MSG .
Proof.

  intros.

  assert (eval_state (↓ DePoolContract_Ф_withdrawFromPoolingRound Л_withdrawValue) l =
  xErrorMapDefaultF (xValue ∘ fromValueValue) (eval_state (↓ DePoolContract_Ф_withdrawFromPoolingRound' Л_withdrawValue) l) xError ).
  unfold DePoolContract_Ф_withdrawFromPoolingRound.
  unfold callEmbeddedStateAdj.
  remember (DePoolContract_Ф_withdrawFromPoolingRound' Л_withdrawValue).
  setoid_rewrite runbind.
  setoid_rewrite eval_bind2.
  rewrite eval_get.
  rewrite exec_get.
  remember (run l0 (injEmbed (T:=LocalState) DePoolFuncs.DePoolSpec.LedgerClass.local0 l)).
  setoid_rewrite <- Heqp.
  destruct p.
  destruct x.
  auto. auto.

  (**********************)
  rewrite H.
  rewrite DePoolContract_Ф_withdrawFromPoolingRound'_eval.
  compute.
  repeat destructIf; auto.
Qed.

End DePoolContract_Ф_withdrawFromPoolingRound.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma eq_term_equals_per_union_eq_if {p} :
  forall lib (eqa1 eqa2 eqb1 eqb2 : per(p)),
    eq_term_equals eqa1 eqa2
    -> eq_term_equals eqb1 eqb2
    -> eq_term_equals (per_union_eq lib eqa1 eqb1) (per_union_eq lib eqa2 eqb2).
Proof.
  introv eqta eqtb.
  unfold eq_term_equals, per_union_eq, per_union_eq_L, per_union_eq_R;
    introv; split; intro k; repdors; exrepnd.

  left.
  exists x y; sp.
  apply eqta; sp.

  right.
  exists x y; sp.
  apply eqtb; sp.

  left.
  exists x y; sp.
  apply eqta; sp.

  right.
  exists x y; sp.
  apply eqtb; sp.
Qed.

Lemma per_union_eq_symmetric {p} :
  forall lib (eqa eqb : per(p)) t1 t2,
    term_equality_symmetric eqa
    -> term_equality_symmetric eqb
    -> per_union_eq lib eqa eqb t1 t2
    -> per_union_eq lib eqa eqb t2 t1.
Proof.
  unfold per_union_eq, per_union_eq_L, per_union_eq_R.
  introv tesa tesb per; repdors; exrepnd.

  left.
  exists y x; sp.

  right.
  exists y x; sp.
Qed.

Lemma per_union_eq_transitive {p} :
  forall lib (eqa eqb : per(p)) t1 t2 t3,
    term_equality_transitive eqa
    -> term_equality_transitive eqb
    -> per_union_eq lib eqa eqb t1 t2
    -> per_union_eq lib eqa eqb t2 t3
    -> per_union_eq lib eqa eqb t1 t3.
Proof.
  unfold per_union_eq, per_union_eq_L, per_union_eq_R.
  introv teta tetb per1 per2; repdors; exrepnd; ccomputes_to_eqval.

  left.
  exists x0 y; sp; spcast; sp.
  apply teta with (t2 := y0); sp.

  right.
  exists x0 y; sp; spcast; sp.
  apply tetb with (t2 := y0); sp.
Qed.

Lemma per_union_eq_cequiv {p} :
  forall lib (eqa eqb : per(p)) t1 t2,
    term_equality_respecting lib eqa
    -> term_equality_respecting lib eqb
    -> term_equality_symmetric eqa
    -> term_equality_symmetric eqb
    -> term_equality_transitive eqa
    -> term_equality_transitive eqb
    -> cequivc lib t1 t2
    -> per_union_eq lib eqa eqb t1 t1
    -> per_union_eq lib eqa eqb t1 t2.
Proof.
  unfold per_union_eq, per_union_eq_L, per_union_eq_R.
  introv resa resb syma symb tra trb ceq per; repdors; exrepnd.

  left; spcast.
  generalize (cequivc_mkc_inl lib t1 t2 x); introv k;
  repeat (autodimp k hyp); exrepnd.
  exists x b; sp; spcast; sp.
  apply resa; spcast; sp.
  apply tra with (t2 := y); sp.

  right; spcast.
  generalize (cequivc_mkc_inr lib t1 t2 x); introv k;
  repeat (autodimp k hyp); exrepnd.
  exists x b; sp; spcast; sp.
  apply resb; spcast; sp.
  apply trb with (t2 := y); sp.
Qed.

Lemma close_type_system_union {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A1 A2 B1 B2 eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_union A1 B1)
    -> computes_to_valc lib T' (mkc_union A2 B2)
    -> close lib ts A1 A2 eqa
    -> type_sys_props lib (close lib ts) A1 A2 eqa
    -> close lib ts B1 B2 eqb
    -> type_sys_props lib (close lib ts) B1 B2 eqb
    -> (forall t t' : CTerm, eq t t' <=> per_union_eq lib eqa eqb t t')
    -> per_union lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv tysys dou c1 c2 cla reca clb recb eqiff per.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  - SCase "uniquely_valued".
    dclose_lr.

    + SSCase "CL_union".
      clear per.
      allunfold @per_union; exrepd.
      unfold eq_term_equals; intros.
      allrw.
      ccomputes_to_eqval.
      revert t1 t2; rw @fold_eq_term_equals.
      apply eq_term_equals_per_union_eq_if.
      apply type_sys_props_eq_term_equals4 with (B := A3) (eq1 := eqa0) in reca; sp.
      apply type_sys_props_eq_term_equals4 with (B := B3) (eq1 := eqb0) in recb; sp.

  - SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_union;
    clear per;
    allunfold @per_union; exrepd;
    unfold per_union;
    ccomputes_to_eqval.

    + exists eqa0 eqb0 A1 A3 B1 B3; sp; spcast; sp.
      apply eq_term_equals_trans with (eq2 := eq); sp.
      apply eq_term_equals_sym; sp.

  - SCase "type_value_respecting"; repdors; subst;
    apply CL_union; unfold per_union.

    (* 1 *)
    generalize (cequivc_mkc_union lib T T3 A1 B1); introv k; repeat (autodimp k hyp); exrepnd.
    exists eqa eqb A1 a' B1 b'; sp; spcast; sp.
    generalize (type_sys_props_cequivc lib (close lib ts) A1 A2 a' eqa); sp.
    generalize (type_sys_props_cequivc lib (close lib ts) B1 B2 b' eqb); sp.

    (* 2 *)
    generalize (cequivc_mkc_union lib T' T3 A2 B2); introv k; repeat (autodimp k hyp); exrepnd.
    exists eqa eqb A2 a' B2 b'; sp; spcast; sp.
    apply type_sys_props_sym in reca.
    generalize (type_sys_props_cequivc lib (close lib ts) A2 A1 a' eqa); sp.
    apply type_sys_props_sym in recb.
    generalize (type_sys_props_cequivc lib (close lib ts) B2 B1 b' eqb); sp.

  - SCase "term_symmetric".
    unfold term_equality_symmetric; introv eqt.
    rw eqiff in eqt; rw eqiff.
    apply per_union_eq_symmetric; sp;
    onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 tymt1; sp;
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2; sp.

  - SCase "term_transitive".
    unfold term_equality_transitive; introv eqt1 eqt2.
    rw eqiff in eqt1; rw eqiff in eqt2; rw eqiff.
    apply @per_union_eq_transitive with (t2 := t2); sp;
    onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 tymt1; sp;
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2; sp.

  - SCase "term_value_respecting".
    unfold term_equality_respecting; introv eqt ceq.
    rw eqiff in eqt; rw eqiff.
    spcast.
    apply per_union_eq_cequiv; sp;
    onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 tymt1; sp;
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2; sp.

  - SCase "type_gsymmetric".
    repdors; subst; split; sp; dclose_lr;
    apply CL_union;
    clear per;
    allunfold @per_union; exrepd;
    ccomputes_to_eqval;
    unfold per_union.

    (* 1 *)
    exists eqa0 eqb0 A3 A1 B3 B1; sp; spcast; sp.
    generalize (type_sys_props_ts_sym3 lib (close lib ts) A1 A3 A2 eqa eqa0); sp.
    generalize (type_sys_props_ts_sym3 lib (close lib ts) B1 B3 B2 eqb eqb0); sp.

    (* 2 *)
    exists eqa0 eqb0 A1 A0 B1 B0; sp; spcast; sp.
    generalize (type_sys_props_ts_sym2 lib (close lib ts) A1 A0 A2 eqa eqa0); sp.
    generalize (type_sys_props_ts_sym2 lib (close lib ts) B1 B0 B2 eqb eqb0); sp.

  - SCase "type_gtransitive"; sp.

  - SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_union lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_union lib (close lib ts) T' T4 eq2));
    allunfold @per_union; exrepd;
    ccomputes_to_eqval.

    + dands; apply CL_union; unfold per_union.

      * exists eqa1 eqb1 A4 A3 B4 B3; sp; spcast; sp.
        generalize (type_sys_props_ts_trans3 lib (close lib ts) A4 A1 A3 A2 eqa1 eqa0 eqa); sp.
        generalize (type_sys_props_ts_trans3 lib (close lib ts) B4 B1 B3 B2 eqb1 eqb0 eqb); sp.

      * exists eqa0 eqb0 A4 A3 B4 B3; sp; spcast; sp.
        generalize (type_sys_props_ts_trans4 lib (close lib ts) A4 A1 A3 A2 eqa1 eqa0 eqa); sp.
        generalize (type_sys_props_ts_trans4 lib (close lib ts) B4 B1 B3 B2 eqb1 eqb0 eqb); sp.

    + dands; apply CL_union; unfold per_union.

      * exists eqa1 eqb1 A4 A3 B4 B3; sp; spcast; sp.
        apply type_sys_props_sym in reca.
        generalize (type_sys_props_ts_trans3 lib (close lib ts) A4 A2 A3 A1 eqa1 eqa0 eqa); sp.
        apply type_sys_props_sym in recb.
        generalize (type_sys_props_ts_trans3 lib (close lib ts) B4 B2 B3 B1 eqb1 eqb0 eqb); sp.

      * exists eqa0 eqb0 A4 A3 B4 B3; sp; spcast; sp.
        apply type_sys_props_sym in reca.
        generalize (type_sys_props_ts_trans4 lib (close lib ts) A4 A2 A3 A1 eqa1 eqa0 eqa); sp.
        apply type_sys_props_sym in recb.
        generalize (type_sys_props_ts_trans4 lib (close lib ts) B4 B2 B3 B1 eqb1 eqb0 eqb); sp.
Qed.