(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) : natural := Zero.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(************************************************************************)
(*   This file has been modified for the purposes of the HoTT library.  *)
(************************************************************************)

Set Implicit Arguments.

Require Export Basics.Notations.

Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

(** * Propositional connectives *)

(** [True] is the unit type. *)
Inductive True : Type :=
  I : True.

(** [False] is the empty type. *)
Inductive False : Type :=.

(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Type) : Type := A -> False.

(* Notation "~ x" := (not x) : type_scope. *)

#[export] Hint Unfold not : core.
#[export] Hint Resolve I : core.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e191m19_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Coq.Arith.EqNat.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.
Require Import GDTC.
Require Import CaseStudy.Names.
Require Import CaseStudy.PNames.

Section Lambda.

  (* ============================================== *)
  (* TYPES                                          *)
  (* ============================================== *)

  (* Function Types. *)
  Inductive LType (A : Set) : Set :=
    TArrow : A -> A -> LType A.

  Definition ltype_pto (A : Set) : ExtP A (I * I) -> LType A.
    intro x.
    inversion x; subst.
    inversion H1.
    inversion H2.
    constructor.
    apply H.
    apply H0.
  Defined.

  Definition ltype_pfrom (A : Set) : LType A -> ExtP A (I * I) :=
    fun x => match x with
               | TArrow y z => ep _ (ei _ y) (ei _ z)
             end.

  Global Instance LType_Polynomial : Polynomial LType :=
    {| PCode := (I * I)%poly;
       pto   := ltype_pto;
       pfrom := ltype_pfrom
    |}.
  Proof.
    intros A a;
      dependent destruction a;
      reflexivity.
    intros A a;
      dependent destruction a;
      dependent destruction a1;
      dependent destruction a2.
    reflexivity.
  Defined.

  Global Instance LType_Container : Container LType | 6 :=
    PolynomialContainer LType.

  Variable D : Set -> Set.
  Context {Sub_LType_D  : LType :<: D}.
  Context `{spf_D : SPF D}.
  Definition DType := DType D.

  (* Constructor + Universal Property. *)
  Context {WF_Sub_LType_D : WF_Functor _ _ Sub_LType_D}.

  Definition tarrow (t1 t2 : DType) := inject LType D (TArrow _ t1 t2).

  (* Algebra for testing type equality. *)

  Definition isTArrow : DType -> option (_ * _) :=
    fun typ =>
      match project LType D typ with
       | Some (TArrow t1 t2)  => Some (t1, t2)
       | None                 => None
      end.

  Context {Eq_DType : Eq DType}.

  (* End type equality section. *)

  (* ============================================== *)
  (* EXPRESSIONS                                    *)
  (* ============================================== *)

  (* Lambda Expressions *)
  Inductive Lambda (A E : Set) : Set :=
  | Var : A -> Lambda A E
  | App : E -> E -> Lambda A E
  | Lam : DType -> (A -> E) -> Lambda A E.

  (** Container Instance **)

  Global Instance Lambda_Iso (A : Set) :
    Iso (Lambda A) (K A :+: Id :*: Id :+: K DType :*: Fn A) :=
    {| fromIso := fun E e => match e with
                               | Var a     => inl a
                               | App e1 e2 => inr (inl (e1,e2))
                               | Lam d f   => inr (inr (d,f))
                             end;
       toIso   := fun E e => match e with
                               | inl a             => Var _ _ a
                               | inr (inl (e1,e2)) => App _ _ e1 e2
                               | inr (inr (d,f))   => Lam _ _ d f
                             end
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a as [n|[[e1 e2]|[d f]]]; reflexivity.
  Defined.

  Global Instance Lambda_Container (A : Set) : Container (Lambda A) :=
    ContainerIso (Lambda_Iso A).

  (* Inductive LambdaS (A : Set) := *)
  (* | SVar : A -> LambdaS A *)
  (* | SApp : LambdaS A *)
  (* | SLam : DType -> LambdaS A. *)

  (* Inductive LambdaP (A : Set) : LambdaS A -> Set := *)
  (* | PApp1 : LambdaP A (SApp A) *)
  (* | PApp2 : LambdaP A (SApp A) *)
  (* | PLam  : forall d, A -> LambdaP A (SLam _ d). *)

  (* Global Implicit Arguments PApp1 [[A]]. *)
  (* Global Implicit Arguments PApp2 [[A]]. *)
  (* Global Implicit Arguments PLam [[A]]. *)

  (* Definition fromLambda (A E : Set) (x : Lambda A E) : Ext (LambdaS A) (LambdaP A) E. *)
  (*   destruct x. *)
  (*   apply ext with (s := SVar _ a). *)
  (*   intro p. *)
  (*   inversion p. *)
  (*   apply ext with (s := SApp _). *)
  (*   intro p. *)
  (*   inversion p. *)
  (*   apply e. *)
  (*   apply e0. *)
  (*   apply ext with (s := SLam _ d). *)
  (*   intro p. *)
  (*   inversion p. *)
  (*   apply (e H0). *)
  (* Defined. *)

  (* Definition toLambda (A E : Set) (x : Ext (LambdaS A) (LambdaP A) E) : Lambda A E := *)
  (*   match x with *)
  (*     | ext s pf => *)
  (*       match s as s return ((LambdaP A s -> E) -> Lambda A E) with *)
  (*         | SVar a => fun pf => Var A E a *)
  (*         | SApp   => fun pf => App A E (pf PApp1) (pf PApp2) *)
  (*         | SLam d => fun pf => Lam A E d (fun p => pf (PLam d p)) *)
  (*       end pf *)
  (*   end. *)

  (* Global Instance Lambda_Container (A : Set) : Container (Lambda A) := *)
  (*   {| Shape    := LambdaS A; *)
  (*      Position := LambdaP A; *)
  (*      from     := fromLambda A; *)
  (*      to       := toLambda A |}. *)
  (* Proof. *)
  (*   intros E x. *)
  (*   destruct x; reflexivity. *)
  (*   intros E x. *)
  (*   destruct x as [[] pf]; *)
  (*     simpl; *)
  (*     f_equal; *)
  (*     extensionality p; *)
  (*     dependent destruction p; *)
  (*     reflexivity. *)
  (* Defined. *)

  Variable F : Set -> Set -> Set.
  Context {Sub_Lambda_F : forall A : Set, Lambda A :<: F A}.
  Context {fun_F : forall A, Functor (F A)}.
  Context {pfun_F: forall A, PFunctor (F A)}.
  Context {spf_F : forall A, SPF (F A)}.
  Definition Exp (A : Set) := Fix (F A).

  (* Constructors + Universal Property. *)

  Context {WF_Sub_Lambda_F : forall A, WF_Functor _ _ (Sub_Lambda_F A)}.

  Definition var {A : Set} (a : A) : Exp A := inject (Lambda A) (F A) (Var _ _ a).
  Definition app {A : Set} (e1 e2 : Exp A) := inject (Lambda A) (F A) (App _ _ e1 e2).
  Definition lam {A : Set} (t1 : DType) (f : A -> Exp A) := inject (Lambda A) (F A) (Lam _ _ t1 f).

  (* Induction Principle for Lambda. *)
  Definition ind_alg_Lambda {A : Set}
    (P : Fix (F A) -> Prop)
    (Hvar : forall x, P (var x))
    (Happ : forall e1 e2, P e1 -> P e2 -> P (app e1 e2))
    (Hlam : forall t1 f, (forall a, P (f a)) -> P (lam t1 f))
      : PAlgebra (inject (Lambda A) (F A)) P :=
    fun xs =>
      match xs return All P xs -> P (inject (Lambda A) (F A) xs) with
        | Var a     => fun _ => Hvar a
        | App e1 e2 =>
          fun Axs : forall p : _ + _, _ =>
            Happ e1 e2 (Axs (inl tt)) (Axs (inr tt))
        | Lam d f =>
          fun Axs : forall p : _ + _, _ =>
            Hlam d f (fun a => Axs (inr a))
      end.

  (* Typing for Lambda Expressions. *)

  Definition Lambda_typeof (R : Set) (rec : R -> typeofR D) (e : Lambda (typeofR D) R) : typeofR D:=
  match e with
    | Var v => v
    | App e1 e2 =>
      match (rec e1, rec e2) with
        | (Some t1, Some t3) =>
          match (isTArrow t1) with
            | Some (t1, t2) =>
              if (eq_DType D t1 t3) then Some t2 else None
            | _ => None
          end
        | _ => None
      end
    | Lam t1 f =>
      match rec (f (Some t1)) with
        | Some t2 => Some (inject LType D (TArrow _ t1 t2))
        | _ => None
      end
  end.

  Global Instance MAlgebra_typeof_Lambda T:
    FAlgebra TypeofName T (typeofR D) (Lambda (typeofR D)) :=
    {| f_algebra := Lambda_typeof T|}.

  (* Function Values. *)

  Inductive ClosValue (A : Set) : Set :=
  | Clos : Exp nat -> Env A -> ClosValue A.

  Global Instance ClosValue_Iso : Iso ClosValue (K (Exp nat) :*: list) :=
    {| fromIso := fun A x => match x with
                               | Clos e env => (e , env)
                             end;
       toIso   := fun A x => match x with
                               | (e , env) => Clos _ e env
                             end
    |}.
  Proof.
    destruct a; auto.
    destruct a; auto.
  Qed.

  Global Instance ContainerClos : Container ClosValue :=
    ContainerIso ClosValue_Iso.

  Variable V : Set -> Set.
  Context `{spf_V : SPF V}.
  Context {Sub_ClosValue_V : ClosValue :<: V}.
  Definition Value := Value V.

  (* Constructor + Universal Property. *)
  Context {WF_Sub_ClosValue_V : WF_Functor _ _ (Sub_ClosValue_V)}.

  Definition closure f env : Value := inject ClosValue V (Clos _ f env).

  (* Constructor Testing for Function Values. *)

  Definition isClos : Fix V -> option _ :=
    fun exp =>
     match project ClosValue V exp with
      | Some (Clos f env)  => Some (f, env)
      | None             => None
     end.

  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Context {Sub_BotValue_V : BotValue :<: V}.

  Definition Lambda_eval : Mixin (Exp nat) (Lambda nat) (evalR V) :=
    fun rec e =>
      match e with
        | Var v =>
          fun env =>
            match lookup env v with
              | Some y => y
              | None => stuck _ 20
            end
        | App e1 e2 =>
          fun env =>
            let reced := (rec e1 env) in
            match isClos reced with
              | Some (f, env') => rec f (insert _ (rec e2 env) env')
              | None => if isBot _ reced then bot _ else stuck _ 5
            end
        | Lam t1 f => fun env => closure (f (length env)) env
      end.

  Global Instance MAlgebra_eval_Lambda :
    FAlgebra EvalName (Exp nat) (evalR V) (Lambda nat) :=
    {| f_algebra := Lambda_eval|}.

  (* ============================================== *)
  (* PRETTY PRINTING                                *)
  (* ============================================== *)

  Require Import String.
  Require Import Ascii.

  Global Instance MAlgebra_DTypePrint_AType T:
    FAlgebra DTypePrintName T DTypePrintR LType :=
    {| f_algebra :=
         fun rec e =>
           match e with
             | TArrow t1 t2 => append "(" ((rec t1) ++ " -> " ++ (rec t2) ++ ")")
           end
    |}.

  Context {DTypePrint_DT : forall T, FAlgebra DTypePrintName T DTypePrintR D}.

  Definition Lambda_ExpPrint (R : Set) (rec : R -> ExpPrintR)
    (e : Lambda nat R) : ExpPrintR :=
    match e with
      | Var v => fun n => append "x" (String (ascii_of_nat (v)) EmptyString)
      | App e1 e2 => fun n => append "(" ((rec e1 n) ++ ") @ (" ++ (rec e2 n) ++ ")")
      | Lam t1 f => fun n => append "\x" ((String (ascii_of_nat n) EmptyString) ++
        " : " ++ (DTypePrint _ t1) ++ ". " ++
        (rec (f n) (S n)) ++ ")")
    end.

  Global Instance MAlgebra_Print_Lambda T :
    FAlgebra ExpPrintName T ExpPrintR (Lambda nat) :=
    {| f_algebra := Lambda_ExpPrint T|}.

  Context {ExpPrint_E : forall T, FAlgebra ExpPrintName T ExpPrintR (F nat)}.

  Global Instance MAlgebra_ValuePrint_AType T:
  FAlgebra ValuePrintName T ValuePrintR ClosValue :=
  {| f_algebra := fun rec e =>
    match e with
      | Clos f _ => append "\x0. " (ExpPrint _ f 0)
    end |}.

  (* ============================================== *)
  (* SUBVALUE RELATION FOR LAMBDAS                  *)
  (* ============================================== *)

  Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}.
  Context `{ispf_SV : iSPF _ SV}.

  Inductive SubValue_Clos (A : SubValue_i V -> Prop) : SubValue_i V -> Prop :=
    SV_Clos : forall f env env',
      P2_Env (fun e e' : Value => A (mk_SubValue_i V e e')) env env' ->
      SubValue_Clos A (mk_SubValue_i _ (closure f env) (closure f env')).

  Inductive SV_Clos_S : SubValue_i V -> Set :=
    SSV_Clos : forall f env env', P2_Shape env env' ->
                 SV_Clos_S (mk_SubValue_i _ (closure f env) (closure f env')).

  Definition SV_Clos_P : forall (i : SubValue_i V), SV_Clos_S i -> Set :=
    fun i H =>
      match H in SV_Clos_S i return Set with
          SSV_Clos f env env' s => { a : _ & {b : _ & P2_Index a b s }}
      end.
  Definition SV_Clos_R (i : SubValue_i V) (s : SV_Clos_S i) (p : SV_Clos_P i s) :
    SubValue_i V.
    destruct s as [f env env' s].
    destruct p as [e [e' i]].
    apply (mk_SubValue_i V e e').
  Defined.

  Definition SV_Clos_to A i : IExt _ _ SV_Clos_R A i -> SubValue_Clos A i :=
    fun x =>
      match x with
        | iext s pf =>
          match s in SV_Clos_S i return
                ((forall p, A (SV_Clos_R i s p)) ->SubValue_Clos A i)
          with
            | SSV_Clos f env env' e =>
              fun pf =>
                SV_Clos A f env env'
                        (P2_tabulate (P := fun e e' => A (mk_SubValue_i V e e')) e
                                     (fun a b H => pf (existT _ a (existT _ b H))))
          end pf
      end.

  Definition SV_Clos_from A i : SubValue_Clos A i -> IExt _ _ SV_Clos_R A i.
    intros sv.
    destruct sv as [f env env' ps].
    constructor 1 with (s := SSV_Clos _ _ _ (P2_Env_Shape ps)).
    intros.
    destruct p as [a [b i]].
    apply (P2_lookup _ ps _ _ i).
  Defined.

  Global Instance SV_Clos_Container : IContainer SubValue_Clos :=
    {| IS    := SV_Clos_S;
       IP    := SV_Clos_P;
       IR    := SV_Clos_R;
       ifrom := SV_Clos_from;
       ito   := SV_Clos_to
    |}.
  Proof.
    intros; destruct a; simpl.
    rewrite P2_tabulate_lookup.
    reflexivity.
    intros; destruct a; destruct s; simpl.
    erewrite (P2_Shape_irrelevance _ p).
    f_equal.
    extensionality x; destruct x as [a [b idx]].
    rewrite P2_lookup_tabulate.
    reflexivity.
  Defined.

  Definition ind_alg_SV_Clos (P : SubValue_i V -> Prop)
    (P' : Env Value -> Env Value -> Prop)
    (H : forall f env env',
      P' env env' ->
      P (mk_SubValue_i _ (closure f env) (closure f env')))
    (H0 : P' nil nil)
    (H1 : forall i env env', P i -> P' env env' ->
      P' (sv_a _ i :: env) (sv_b _ i :: env'))
    i (e : SubValue_Clos P i) : P i :=
    match e in SubValue_Clos _ i return P i with
      | SV_Clos f env env' Sub_env_env' =>
        H f env env'
        ((fix P_Env_ind' (env : Env _) (env' : Env _)
          (P_env_env' : P2_Env (fun e e' => P (mk_SubValue_i _ e e')) env env') :=
          match P_env_env' in P2_Env _ As Bs return P' As Bs with
            | P2_Nil => H0
            | P2_Cons a b As Bs P_a_b P_As_Bs =>
              H1 (mk_SubValue_i _ a b) As Bs P_a_b (P_Env_ind' _ _ P_As_Bs)
          end) _ _ Sub_env_env')
    end.

  (* ============================================== *)
  (* TYPE SOUNDNESS                                 *)
  (* ============================================== *)

  Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}.
  Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Lambda nat) (F nat)
    (Sub_Lambda_F nat) (MAlgebra_eval_Lambda) (eval_F)}.

  (* Continuity of Evaluation. *)

  Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V}.
  Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}.
  Context {Sub_SV_Clos_SV : Sub_iFunctor SubValue_Clos SV}.

  (* Lit case. *)

  Lemma eval_continuous_Exp_H : forall x,
    eval_continuous_Exp_P V (F nat) SV (var x).
  Proof.
    unfold eval_continuous_Exp_P; intros.
    unfold beval, var, inject; simpl.
    rewrite out_in_inverse.
    repeat rewrite (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    caseEq (@lookup Value gamma x); unfold Value in *|-*;
      rewrite H2.
    destruct (P2_Env_lookup _ _ _ _ _ H0 _ _ H2) as [v' [lookup_v' Sub_v_v']].
    unfold Value; rewrite lookup_v'; eauto.
    unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H0 _ H2).
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto.
  Qed.

  (* Lambda case. *)

  Lemma eval_continuous_Exp_H1 : forall t1 f
    (IHf : forall a, eval_continuous_Exp_P V (F nat) SV (f a)),
    eval_continuous_Exp_P V (F nat) SV (lam t1 f).
  Proof.
    unfold eval_continuous_Exp_P; intros.
    unfold beval, lam, inject; simpl.
    rewrite out_in_inverse.
    repeat rewrite (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    rewrite (P2_Env_length _ _ _ _ _ H0).
    apply (inject_i (subGF := Sub_SV_Clos_SV)); constructor; auto.
  Qed.

  (* App case. *)

  Context {Dis_Clos_Bot : Distinct_Sub_Functor ClosValue BotValue V}.

  Global Instance SV_invertBot_Clos :
    iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SubValue_Clos.
  Proof.
    constructor; intros.
    unfold iAlgebra; intros.
    inversion H; subst; simpl.
    unfold SV_invertBot_P; intros.
    discriminate_inject H1.
  Qed.

  Context {SV_invertBot_SV :
    iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}.

  (* Inversion principles for function SubValues. *)
  Definition SV_invertClos_P (i : SubValue_i V) :=
    SubValue _ SV i /\
    forall f env, sv_a _ i = closure f env ->
      exists env', sv_b _ i = closure f env'
        /\ Sub_Environment V SV env env'.

  Inductive SV_invertClos_Name := ece_invertclosure_name.
  Context {SV_invertClos_SV :
    iPAlgebra SV_invertClos_Name SV_invertClos_P SV}.

  Global Instance SV_invertClos_refl :
    iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_refl V).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros; unfold SV_invertClos_P.
    inversion H; subst; simpl; intros.
    split; intros.
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; auto.
    exists env; split; auto.
    apply Sub_Environment_refl; auto.
  Defined.

  Global Instance SV_invertClos_Clos :
    iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Clos).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros.
    apply ind_alg_SV_Clos with (P' := Sub_Environment V SV).
    unfold SV_invertClos_P; intros.
    subst; simpl in *|-*.
    split; intros.
    apply (inject_i (subGF := Sub_SV_Clos_SV)); constructor; auto.
    apply inject_inject in H1; inversion H1; subst.
    exists env'; repeat split; auto.
    constructor.
    intros.
    constructor; auto.
    destruct H0 as [i' H0].
    destruct i0; apply i'.
    apply H.
  Qed.

  Variable Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV.

  Global Instance SV_invertClos_Bot :
    iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Bot V).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros; unfold SV_invertClos_P.
    inversion H; subst; simpl; intros.
    split; intros.
    apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto.
    discriminate_inject H0.
  Defined.

  Definition SV_invertClos := ifold_ (if_algebra (iPAlgebra := SV_invertClos_SV)).

  Definition SV_invertClos'_P (i : SubValue_i V) :=
    SubValue _ SV i /\
    forall f env, sv_b _ i = closure f env ->
      sv_a _ i = bot _ \/
      (exists f,
        exists env', sv_a _ i = closure f env' /\
        Sub_Environment V SV env' env).

  Inductive SV_invertClos'_Name := ece_invertclosure'_name.
  Variable SV_invertClos'_SV : iPAlgebra SV_invertClos'_Name SV_invertClos'_P SV.

  Global Instance SV_invertClos'_refl :
    iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_refl V).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold SV_invertClos'_P.
    inversion H; subst; simpl; split; intros.
    apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; auto.
    right; eexists; eexists; split; eauto.
    apply Sub_Environment_refl; eauto.
  Defined.

  Global Instance SV_invertClos'_Bot :
    iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Bot V).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold SV_invertClos'_P.
    inversion H; subst; simpl; split; intros; eauto.
    apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; reflexivity.
  Defined.

  Global Instance SV_invertClos'_Clos :
    iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Clos).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros.
    apply ind_alg_SV_Clos with (P' := Sub_Environment V SV);
      try eassumption; intros.
    unfold SV_invertClos'_P; intros; simpl; split; intros.
    apply (inject_i (subGF := Sub_SV_Clos_SV)); constructor; auto.
    right; exists f; exists env; split; auto.
    apply inject_inject in H1; inversion H1; subst.
    exact H0.
    constructor.
    constructor.
    destruct H0 as [i' H0].
    destruct i0; apply i'.
    apply H1.
  Qed.

  Definition SV_invertClos' := ifold_ (if_algebra (iPAlgebra := SV_invertClos'_SV)).

  Lemma eval_continuous_Exp_H0 : forall (e1 e2 : Exp nat)
    (IHe1 : eval_continuous_Exp_P V (F nat) SV e1)
    (IHe2 : eval_continuous_Exp_P V (F nat) SV e2),
    eval_continuous_Exp_P V (F nat) SV (app e1 e2).
  Proof.
    intros; unfold eval_continuous_Exp_P; intros.
    unfold beval, app, inject; simpl.
    rewrite out_in_inverse; simpl.
    repeat rewrite (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    unfold isClos.
    generalize (H e1 _ _ _ H0 H1) as Sub_e1_m_e1_n; intro.
    fold (Exp nat).
    caseEq (project ClosValue V
      (boundedFix m (f_algebra EvalName (FAlgebra := eval_F))
        (fun _ : Env (Names.Value V) => Names.bot V) e1 gamma)).
    apply inject_project in H2; rename H2 into Eval_m.
    destruct c.
    destruct (SV_invertClos _ Sub_e1_m_e1_n) as [_ SF']; simpl in SF';
      destruct (SF' _ _ Eval_m) as [env' [Eval_n Sub_env_env']].
    unfold beval, evalR, Exp in Eval_n; simpl in Eval_n.
    unfold beval, evalR, Exp.
    rewrite Eval_n; simpl.
    unfold closure.
    rewrite project_inject.
    eapply H; eauto.
    eapply P2_Env_insert; eauto.
    unfold isBot.
    caseEq (project BotValue V
      (boundedFix m (f_algebra EvalName (FAlgebra := eval_F))
        (fun _ : Env (Names.Value V) => Names.bot V) e1 gamma)).
    destruct b.
    apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor.
    eauto.
    caseEq (project ClosValue V
      (boundedFix n (f_algebra EvalName (FAlgebra := eval_F))
        (fun _ : Env (Names.Value V) => Names.bot V) e1 gamma')).
    destruct c.
    apply inject_project in H4; rename H4 into Eval_n.
    destruct (SV_invertClos' _ Sub_e1_m_e1_n) as [_ SF']; simpl in SF';
      destruct (SF' _ _ Eval_n) as [Eval_m |
      [f' [env' [Eval_m Sub_env_env']]]]; simpl in Eval_m.
    unfold beval, evalR, Exp in *|-*; rewrite Eval_m in H3.
    unfold bot in H3.
    rewrite project_inject in H3.
    discriminate.
    unfold beval, evalR, Exp in *|-*; rewrite Eval_m in H2.
    unfold closure in H2.
    rewrite project_inject in H2.
    discriminate.
    caseEq (project BotValue V
      (boundedFix n (f_algebra EvalName (FAlgebra := eval_F))
        (fun _ : Env (Names.Value V) => Names.bot V) e1 gamma')).
    destruct b.
    apply inject_project in H5; rename H5 into Eval_n.
    generalize (SV_invertBot _ _ _ Sub_e1_m_e1_n Eval_n). simpl;
    intros Eval_m; unfold beval, evalR, Exp in *|-*; rewrite Eval_m in H3.
    unfold bot, Names.bot in H3.
    rewrite project_inject in H3.
    discriminate.
    eapply (inject_i (subGF := Sub_SV_refl_SV)); constructor.
    reflexivity.
  Qed.

  Global Instance Lambda_eval_continuous_Exp :
    FPAlgebra (eval_continuous_Exp_P V (F nat) SV) (inject (Lambda nat) (F nat)).
  Proof.
    constructor; unfold PAlgebra; intros.
    apply ind_alg_Lambda.
    apply eval_continuous_Exp_H.
    apply eval_continuous_Exp_H0.
    apply eval_continuous_Exp_H1.
    assumption.
  Defined.

  (* ============================================== *)
  (* EQUIVALENCE OF EXPRESSIONS                     *)
  (* ============================================== *)

  (** SuperFunctor for Equivalence Relation. **)

  Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop.
  Context {ifun_EQV_E : forall A B, iFunctor (EQV_E A B)}.
  Context {ispf_EQV_E : forall A B, iSPF (EQV_E A B)}.

  Definition E_eqv A B := iFix (EQV_E A B).
  Definition E_eqvC {A B : Set} gamma gamma' e e' :=
    E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e').

  Inductive Lambda_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop :=
  | Var_eqv : forall (gamma : Env _) gamma' n a b,
    lookup gamma n = Some a -> lookup gamma' n = Some b ->
    Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' (var a) (var b))
  | App_eqv : forall (gamma : Env _) gamma' a b a' b',
    E (mk_eqv_i _ _ _ gamma gamma' a a') ->
    E (mk_eqv_i _ _ _ gamma gamma' b b') ->
    Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' (app a b) (app a' b'))
  | Lam_eqv : forall (gamma : Env _) gamma' f g t,
    (forall (a : A) (b : B), E (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) ->
    Lambda_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' (lam t f) (lam t g)).

  Inductive Lambda_eqv_S (A B : Set) : eqv_i F A B -> Set :=
  | SVar_eqv : forall (gamma : Env _) gamma' n a b,
    lookup gamma n = Some a -> lookup gamma' n = Some b ->
    Lambda_eqv_S A B (mk_eqv_i _ _ _ gamma gamma' (var a) (var b))
  | SApp_eqv : forall (gamma : Env _) gamma' a b a' b',
    Lambda_eqv_S A B (mk_eqv_i _ _ _ gamma gamma' (app a b) (app a' b'))
  | SLam_eqv : forall (gamma : Env _) gamma' f g t,
    Lambda_eqv_S A B (mk_eqv_i _ _ _ gamma gamma' (lam t f) (lam t g)).

  Definition Lambda_eqv_P (A B : Set) (i : eqv_i F A B) (s : Lambda_eqv_S A B i) : Set.
    destruct s.
    apply Empty_set.
    apply ((unit + unit)%type).
    apply ((A * B)%type).
  Defined.

  Definition Lambda_eqv_R (A B : Set) (i : eqv_i F A B)
             (s : Lambda_eqv_S A B i)
             (p : Lambda_eqv_P A B i s) : eqv_i F A B.
    destruct s; simpl in p.
    destruct p.
    destruct p as [p|p].
    apply (mk_eqv_i _ _ _ gamma gamma' a a').
    apply (mk_eqv_i _ _ _ gamma gamma' b b').
    destruct p.
    apply (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b)).
  Defined.

  Definition Lambda_eqv_to (A B : Set) (C : eqv_i F A B -> Prop) (i : eqv_i F A B) :
    IExt _ _ (Lambda_eqv_R A B) C i -> Lambda_eqv A B C i.
  Proof.
    intros x; destruct x; destruct s; simpl in pf.
    constructor 1 with (n := n); auto.
    constructor 2.
    apply (pf (inl tt)).
    apply (pf (inr tt)).
    constructor 3.
    intros.
    apply (pf (a , b)).
  Defined.

  Definition Lambda_eqv_from (A B : Set) (C : eqv_i F A B -> Prop) (i : eqv_i F A B) :
    Lambda_eqv A B C i -> IExt _ _ (Lambda_eqv_R A B) C i.
  Proof.
    intros x; destruct x.
    constructor 1 with (s := SVar_eqv _ _ gamma gamma' n a b H H0); simpl.
    intro p; destruct p.
    constructor 1 with (s := SApp_eqv _ _ gamma gamma' a b a' b'); simpl.
    intro p; destruct p as [p|p]; auto.
    constructor 1 with (s := SLam_eqv _ _ gamma gamma' f g t); simpl.
    intro p; destruct p; auto.
  Defined.

  Global Instance Lambda_eqv_Container (A B : Set) : IContainer (Lambda_eqv A B) :=
    {| IS    := Lambda_eqv_S A B;
       IP    := Lambda_eqv_P A B;
       IR    := Lambda_eqv_R A B;
       ifrom := Lambda_eqv_from A B;
       ito   := Lambda_eqv_to A B
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a; destruct s; simpl; f_equal;
      extensionality x; destruct x; try destruct u; reflexivity.
  Defined.

  Definition ind_alg_Lambda_eqv
    (A B : Set)
    (P : eqv_i F A B -> Prop)
    (H : forall gamma gamma' n a b lookup_a lookup_b,
      P (mk_eqv_i _ _ _ gamma gamma' (var a) (var b)))
    (H0 : forall gamma gamma' a b a' b'
      (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a'))
      (IHb : P (mk_eqv_i _ _ _ gamma gamma' b b')),
      P (mk_eqv_i _ _ _ gamma gamma' (app a b) (app a' b')))
    (H1 : forall gamma gamma' f g t
      (IHf : forall a b, P (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))),
      P (mk_eqv_i _ _ _ gamma gamma' (lam t f) (lam t g)))
    i (e : Lambda_eqv A B P i) : P i :=
    match e in Lambda_eqv _ _ _ i return P i with
      | Var_eqv gamma gamma' n a b lookup_a lookup_b =>
        H gamma gamma' n a b lookup_a lookup_b
      | App_eqv gamma gamma' a b a' b' eqv_a_a' eqv_b_b' =>
        H0 gamma gamma' a b a' b' eqv_a_a' eqv_b_b'
      | Lam_eqv gamma gamma' f g t eqv_f_g  =>
        H1 gamma gamma' f g t eqv_f_g
    end.

  Variable Sub_Lambda_eqv_EQV_E : forall A B,
    Sub_iFunctor (Lambda_eqv A B) (EQV_E A B).

  Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}.

  (* ============================================== *)
  (* WELL-FORMED FUNCTION VALUES                    *)
  (* ============================================== *)

  Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
  Context `{ispf_WFV : iSPF _ WFV}.
  Variable typeof_rec : Exp (typeofR D) -> typeofR D.
  (** Functions are well-formed **)

  Inductive WFValue_Clos
    (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop :=
  | WFV_Clos : forall (f : option DType -> Exp _) f' env gamma gamma'
    (t1 t2 : DType) v T,
    v = closure (f' (List.length gamma)) env ->
    T = tarrow t1 t2 ->
    (forall a b, E_eqvC (insert _ a gamma) (insert _ b gamma') (f a) (f' b)) ->
    (forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T) ->
    List.length gamma = List.length gamma' ->
    P2_Env (fun v T => match T with
                         | Some T => WFV (mk_WFValue_i _ _ v T)
                         | _ => False
                       end) env gamma ->
    (forall n b, lookup gamma' n = Some b -> b = n) ->
    typeof_rec (f (Some t1)) = Some t2 ->
    WFValue_Clos  WFV (mk_WFValue_i D V v T).

  Inductive WFValue_Clos_S : WFValue_i D V -> Set :=
  | SWFV_Clos : forall (f : option DType -> Exp _) f' env gamma gamma'
    (t1 t2 : DType) v T,
    v = closure (f' (List.length gamma)) env ->
    T = tarrow t1 t2 ->
    (forall a b, E_eqvC (insert _ a gamma) (insert _ b gamma') (f a) (f' b)) ->
    (forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T) ->
    List.length gamma = List.length gamma' ->
    forall (s : P2_Shape env gamma),
    (forall a b, P2_Index a b s -> exists T, b = Some T) ->
    (forall n b, lookup gamma' n = Some b -> b = n) ->
    typeof_rec (f (Some t1)) = Some t2 ->
    WFValue_Clos_S (mk_WFValue_i D V v T).

  Definition WFValue_Clos_P (i : WFValue_i D V) (s : WFValue_Clos_S i) : Type :=
    match s with
      | SWFV_Clos _ _ env gamma _ _ _ _ _ _ _ _ _ _ s _ _ _ =>
        {a : _ & {b : DType & P2_Index a (Some b) s }}
    end.

  Definition WFValue_Clos_R (i : WFValue_i D V)
           (s : WFValue_Clos_S i)
           (p : WFValue_Clos_P i s) : WFValue_i D V.
    destruct s; simpl in *.
    destruct p as [a [b idx]].
    apply (mk_WFValue_i _ _ a b).
  Defined.

  Definition WFValue_Clos_to (A : WFValue_i D V -> Prop) (i : WFValue_i D V) :
    IExt _ _ WFValue_Clos_R A i -> WFValue_Clos A i.
    intros x; destruct x; destruct s; simpl in pf.
    apply (WFV_Clos _ f f' env gamma gamma' t1 t2 v T); auto.
    apply (P2_tabulate s).
    intros.
    destruct b.
    apply (pf (existT _ a (existT _ d H))).
    generalize (e4 _ _ H).
    intros; destruct H0; discriminate.
  Defined.

  Definition WFValue_Clos_from (A : WFValue_i D V -> Prop) (i : WFValue_i D V) :
    WFValue_Clos A i -> IExt _ _ WFValue_Clos_R A i.
    intros x; destruct x.
    assert (P2_Shape env gamma) as ps.
    apply (P2_Env_Shape H4).
    constructor 1 with (s := SWFV_Clos f f' env gamma gamma' t1 t2 v T H H0 H1 H2 H3 ps
                      (fun a b =>
                         match b return (P2_Index a b ps -> exists T0 : DType, b = Some T0) with
                           | Some T => fun idx => ex_intro _ T eq_refl
                           | None => fun idx => False_rec _ (P2_lookup ps H4 _ _ idx)
                         end
                      ) H5 H6); simpl; intro p.
    destruct p as [a [b idx]].
    apply (P2_lookup _ H4 _ _ idx).
  Defined.

  Lemma e4_irrelevance {A B : Set} {As Bs} (s : P2_Shape As Bs)
        (f g : forall (a : Fix V) (b : option DType),
                 P2_Index a b s -> exists T : DType, b = Some T)
  : f = g.
  Proof.
    extensionality a; extensionality b; extensionality idx.
    destruct (f a b idx); destruct (g a b idx); subst.
    dependent destruction e0; reflexivity.
  Defined.

  Global Instance WFValue_Clos_Container : IContainer WFValue_Clos :=
    {| IS    := WFValue_Clos_S;
       IP    := WFValue_Clos_P;
       IR    := WFValue_Clos_R;
       ifrom := WFValue_Clos_from;
       ito   := WFValue_Clos_to
    |}.
  Proof.
    intros; destruct a; simpl.
    f_equal.
    rewrite <- (P2_tabulate_lookup p (P2_Env_Shape p)) at 2.
    f_equal.
    extensionality a; extensionality b; extensionality idx.
    destruct b; simpl.
    reflexivity.
    destruct (P2_lookup (P2_Env_Shape p) p a None idx).
    intros; destruct a; destruct s; simpl.
    rewrite (P2_Shape_irrelevance _ s).
    erewrite (@e4_irrelevance Value (option DType) _ _ s _ e4).
    f_equal.
    extensionality p.
    destruct p as [a [b idx]].
    rewrite P2_lookup_tabulate.
    reflexivity.
  Defined.

  Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T (typeofR D) _ _
    (Sub_Lambda_F _) (MAlgebra_typeof_Lambda T) (Typeof_F _)}.
  Context {WF_Value_continous_alg :
    iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}.

  Definition ind_alg_WFV_Clos
    (P : WFValue_i D V -> Prop)
    (P' : Env Value -> Env (option DType) -> Prop)
    (H : forall f f' env gamma gamma' t1 t2 v T
      v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma'
      P2_env lookup_gamma'' type_of_f,
      P' env gamma ->
      P (mk_WFValue_i _ _ v T))
    (H0 : P' nil nil)
    (H1 : forall a b env env',
      match b with
        | Some T => P {| wfv_a := a; wfv_b := T |}
        | None => False
      end -> P' env env' ->
      P' (a :: env) (b :: env'))
    i (e : WFValue_Clos  P i) : P i :=
    match e in WFValue_Clos _ i return P i with
      | WFV_Clos f f' env gamma gamma' t1 t2 v T
      v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma'
      P2_env lookup_gamma'' type_of_f =>
      H f f' env gamma gamma' t1 t2 v T
      v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma'
      P2_env lookup_gamma'' type_of_f
      ((fix P_Env_ind' (env : Env Value) (env' : Env (option DType))
        (P_env_env' : P2_Env (fun v T => match T with
                                           | Some T => P (mk_WFValue_i _ _ v T)
                                           | _ => False
                                         end) env env') :=
        match P_env_env' in P2_Env _ As Bs return P' As Bs with
          | P2_Nil => H0
          | P2_Cons a b As Bs P_a_b P_As_Bs =>
            H1 a b As Bs P_a_b (P_Env_ind' _ _ P_As_Bs)
        end) env gamma P2_env)
    end.

  Variable Sub_WFV_Clos_WFV : Sub_iFunctor WFValue_Clos WFV.
  Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV.

  (* Inversion principles for Well-formed natural numbers. *)
  Definition WF_invertClos_P (i : WFValue_i D V) :=
    WFValue _ _ WFV i /\
    forall t1 t2, wfv_b _ _ i = tarrow t1 t2 ->
    WFValue_Clos  (iFix WFV) i \/ WFValue_Bot _ _ (iFix WFV) i.

  Inductive WF_invertClos_Name := wfv_invertclosure_name.
  Context {WF_invertClos_WFV :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P ) WFV}.

  Global Instance WF_invertClos_Clos  :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Clos ).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' :=
      P2_Env (fun v T => match T with
                           | Some T => WFValueC _ _ WFV v T
                           | _ => False
                         end)).
    inversion H; subst; simpl; intros; split.
    eapply (inject_i (subGF := Sub_WFV_Clos_WFV ));
      econstructor 1; simpl in *|-*; eauto.
    left; econstructor 1; simpl in *|-*; eauto; try congruence.
    rewrite T_e1 in H1; apply inject_inject in H1.
    injection H1; intros; congruence.
    constructor.
    constructor.
    destruct b; destruct H0; eauto.
    assumption.
    exact H.
  Defined.

  Global Instance WF_invertClos_Bot  :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Bot _ _).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros; unfold WF_invertClos_P.
    inversion H; subst; simpl; intros.
    split.
    apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto.
    right; constructor; reflexivity.
  Defined.

  Definition WF_invertClos  := ifold_ (if_algebra (iPAlgebra := WF_invertClos_WFV )).

  Definition WF_invertClos'_P  (i : WFValue_i D V) :=
    WFValue _ _ WFV i /\
    forall v : ClosValue _, wfv_a _ _ i = inject _ _ v ->
    WFValue_Clos  (iFix WFV) i.

  Inductive WF_invertClos'_Name := wfv_invertclosure'_name.
  Context {WF_invertClos'_WFV :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) WFV}.

  Global Instance WF_invertClos'_Clos  :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Clos ).
  Proof.
    constructor; intros.
    unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' :=
      P2_Env (fun v T => match T with
                           | Some T => WFValueC _ _ WFV v T
                           | _ => False
                         end)).
    inversion H; subst; simpl; intros; split.
    eapply (inject_i (subGF := Sub_WFV_Clos_WFV ));
      econstructor 1;
      simpl in *|-*; eauto.
    intros; econstructor 1; simpl in *|-*; eauto.
    left; econstructor; simpl in *|-*; eauto; try congruence.
    intros; constructor; auto.
    destruct b; destruct H0; auto.
    assumption.
  Defined.

  Global Instance WF_invertClos'_Bot  :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Bot _ _).
  Proof.
    econstructor; intros.
    unfold iAlgebra; intros; unfold WF_invertClos'_P.
    inversion H; subst; simpl; intros.
    split.
    apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto.
    intros; discriminate_inject H0.
  Defined.

  Definition WF_invertClos'  :=
    ifold_ (if_algebra (iPAlgebra := WF_invertClos'_WFV )).

  Global Instance WFV_Value_continuous_Clos :
    iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SubValue_Clos.
  Proof.
    constructor; unfold iAlgebra; intros.
    eapply ind_alg_SV_Clos with (P' := fun env env' => forall gamma,
      P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) =>
        match T0 with
          | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |}
          | None => False
        end) env' gamma ->
      P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) =>
        match T0 with
          | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |}
          | None => False
        end) env gamma); try eassumption; auto.
    unfold WF_Value_continuous_P; simpl; intros.
    destruct (WF_invertClos'  _ H1) as [_ H5]; simpl in H5;
      generalize (H5 _ eq_refl); clear H5.
    intros H1'; inversion H1'; subst.
    apply inject_inject in H4; injection H4; intros; subst; clear H4.
    apply (inject_i (subGF := (Sub_WFV_Clos_WFV ))).
    econstructor 1 with (f' := f') (env := env) (gamma := gamma); auto.
    intros; inversion H2; subst.
    econstructor.
    destruct b; try destruct H5.
    apply H0; auto.
    apply H1; auto.
  Defined.

  Lemma isClos_closure : forall t1 f, isClos (closure t1 f) =
    Some (t1, f).
  Proof.
    intros; unfold isClos, closure. rewrite project_inject; reflexivity.
  Qed.

  Lemma isClos_bot :
    isClos (bot _) = None.
  Proof.
    unfold isClos; simpl.
    crush_project.
  Qed.

  Lemma isBot_closure :
    forall t1 f, isBot _ (closure t1 f) = false.
  Proof.
    intros; unfold isBot.
    crush_project.
  Qed.

  Global Instance Lambda_eqv_eval_soundness_alg : forall eval_rec,
    iPAlgebra soundness_XName
    (soundness_X'_P D V F EQV_E WFV
      typeof_rec eval_rec
      (f_algebra TypeofName (FAlgebra := Typeof_F _))
      (f_algebra EvalName (FAlgebra := eval_F))) (Lambda_eqv _ _).
  Proof.
    constructor; unfold iAlgebra; intros.
    apply ind_alg_Lambda_eqv; try eassumption;
    unfold soundness_X'_P, eval_alg_Soundness_P; simpl; intros.
    (* Var Case *)
    split.
    apply inject_i; econstructor; eauto.
    intros; unfold var, inject; rewrite out_in_inverse; simpl.
    rewrite (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]];
      simpl in *|-*.
    rewrite (WF_gamma' _ _ lookup_b) in *|-*.
    destruct (P2_Env_lookup' _ _ _ _ _ WF_gamma'' _ _ lookup_a) as [v [lookup_v WF_v]];
        unfold Value; rewrite lookup_v.
    destruct a; eauto.
    rename H0 into typeof_d.
    unfold var, inject in typeof_d; rewrite out_in_inverse in typeof_d;
      rewrite (wf_mixin (WF_Mixin := WF_typeof_F _)) in typeof_d;
        simpl in typeof_d; injection typeof_d; intros; subst; auto.
    destruct WF_v.
    (* app case *)
    destruct (IHa IH) as [eqv_a _]; destruct (IHb IH) as [eqv_b _].
    split.
    apply inject_i; econstructor 2; simpl; eauto.
    intros; unfold app, inject; rewrite out_in_inverse; simpl.
    rewrite (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    rename H0 into typeof_e.
    unfold app, inject in typeof_e; rewrite out_in_inverse in typeof_e;
      rewrite (wf_mixin (WF_Mixin := WF_typeof_F _)) in typeof_e;
        simpl in typeof_e.
    caseEq (typeof_rec a); rename H0 into typeof_a;
      rewrite typeof_a in typeof_e; try discriminate.
    caseEq (typeof_rec b); rename H0 into typeof_b;
      rewrite typeof_b in typeof_e; try discriminate.
    caseEq (isTArrow d); rewrite H0 in typeof_e; try discriminate.
    destruct p as [t1 t2].
    caseEq (eq_DType D t1 d0); rename H1 into eq_t1;
      rewrite eq_t1 in typeof_e; try discriminate; injection typeof_e; intros; subst; clear typeof_e.
    apply eq_DType_eq in eq_t1; subst.
    generalize (IH a _ _ _ WF_gamma'' d eqv_a typeof_a); intros WF_a.
    unfold isTArrow in H0.
    caseEq (project LType D d); rename H1 into typeof_d;
      rewrite typeof_d in H0; try discriminate; destruct l.
    inversion H0; subst.
    apply inject_project in typeof_d.
    destruct (WF_invertClos  _ WF_a) as [_ VWF_a']; clear WF_a;
      destruct (VWF_a' _ _ typeof_d) as [WF_a' | WF_a']; inversion WF_a'; subst.
    rewrite H3, isClos_closure.
    apply inject_inject in H4; inversion H4; subst.
    eapply IH; simpl; eauto.
    eapply WF_eqv_environment_P_insert; repeat split; eauto.
    rewrite <- H7.
    apply H5.
    rewrite H2.
    generalize isClos_bot; unfold bot, Names.bot; intro H'; rewrite H'.
    generalize isBot_bot; unfold bot, Names.bot; intro H''; rewrite H''.
    apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto.
    (* lam case *)
    split; intros.
    generalize (fun a b => proj1 (IHf a b IH)); intro IHf'.
    apply inject_i; econstructor 3; eauto.
    unfold lam, inject in H0; rewrite out_in_inverse in H0;
      rewrite (wf_mixin (WF_Mixin := WF_typeof_F _)) in H0; simpl in H0.
    caseEq (typeof_rec (f (Some t)));
      rename H1 into typeof_f; unfold DType, Names.DType in *|-*; rewrite typeof_f in H0; try discriminate.
    injection H0; intros; subst; clear H0.
    unfold lam, inject at 1; rewrite out_in_inverse, (wf_mixin (WF_Mixin := WF_eval_F)); simpl.
    destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]].
    apply (inject_i (subGF := Sub_WFV_Clos_WFV)).
    rewrite (P2_Env_length _ _ _ _ _ WF_gamma''); simpl.
    eapply WFV_Clos with (f' := g) (gamma := gamma).
    reflexivity.
    reflexivity.
    intros; apply (proj1 (IHf a b IH)); auto.
    auto.
    auto.
    auto.
    auto.
    auto.
  Defined.

End Lambda.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e140m27_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


From Interval Require Import Tactic.
From Coq Require Import Reals.
From Coquelicot Require Import Coquelicot.
Open Scope R_scope.

Goal RInt (fun x => x) 0 1 <= 2.
Proof. integral. Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e251m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e198m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e379m19_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import String.
Require Import Bool.
Require Import Nat.
Require Import List.
Require Import Multiset.
Require Import ListSet.

Require Import core.utils.Utils.

Require Import core.Syntax.
Require Import core.Semantics.
Require Import core.Model.
Require Import core.EqDec.
Require Import core.TransformationConfiguration.

Require Import TT2BDD.TT.
Require Import TT2BDD.BDD.

Require Import Coq.Lists.List.
Require Import Coq.Init.Nat.

Definition div_roundup (a b : nat) :=
  match modulo a b with
  | 0 => a / b
  | _ => (a / b) + 1
  end.

Definition times (lv : nat) := pow 2 lv.

Definition list_max (l:list nat) := fold_right max 0 l.

(* In this example, we try to explore that
   - we can write transformation without reflection
   -
 *)

Definition guard (sp: list TTElem) :=
    match hd_error sp with
    | Some e => isColumn e
    | _ => false
    end.

Definition iter_col (sp: list TTElem) :=
  match hd_error sp with
  | Some e => match (Column_Level e) with
              | None => 0
              | Some lv => (times (lv-1))
              end
  | _ => 0
  end.

Definition oelem_name (sp: list TTElem) (iter: nat) :=
  match hd_error sp with
  | Some e => append (Column_Name e) (natToString iter)
  | _ => ""%string
  end.

Definition upper_level (sp: list TTElem) :=
  match hd_error sp with
  | Some e => match (Column_Level e) with
              | None => None
              | Some n => Some (n - 1)
              end
  | _ => None
  end.

Definition locate (m: Model TTElem TTRef) (lv: nat) :=
  find (fun e => match (Column_Level e) with
          | None => false
          | Some n => Nat.eqb n lv
          end) (allModelElements m).

Definition output_name (sp: list TTElem) :=
  match hd_error sp with
  | Some e => match (Row_Output e) with
              | None => ""%string
              | Some str => append "S_" str
              end
  | _ => ""%string
  end.

Definition maxLv (m: Model TTElem TTRef) := list_max (optionList2List (map Column_Level (allModelElements m))).

Fixpoint semantic (input: list nat) : nat :=
  match input with
  | nil => 0
  | a :: r => a * pow 2 ((length input)-1) + semantic r
  end.

(* Eval compute in semantic (0::0::1::nil). *)

#[export]
Instance TT2BDDConfiguration : TransformationConfiguration :=
  Build_TransformationConfiguration TTM BDDM.

Definition TT2BDD :=
  buildTransformation 1
  [ (* rules *)
    (buildRule "Columns2Tree"
      (fun m sp => option_map isColumn (hd_error sp))
      (fun m sp => return iter_col sp)
      [buildOutputPatternElement "node"
          (fun i m col => return BuildBDDNode (oelem_name col i))
          (fun tls i m col output =>
            ulv <- (upper_level col);
            ucol <- locate m ulv;
            parent <- resolveIter tls m "node" [ucol] ((div_roundup i 2)-1);
            return [BuildBDDEdge output parent])
      ]
    ) ;
    (buildRule "Row2Output"
      (fun m sp => option_map isRow (hd_error sp))
      (fun m sp => return 1)
      [buildOutputPatternElement "output"
          (fun i m sp => return BuildBDDNode (output_name sp))
          (fun tls i m sp output =>
            height <- Some (maxLv m);           (* get depth *)
            col <- locate m height;             (* get node of depth *)
            row <- hd_error sp;
            input <- (Row_Input row);
            parent <- resolveIter tls m "node" [col] ((div_roundup (semantic input) 2)-1);   (* attach output to the corresponding leaf node*)
            return [BuildBDDEdge output parent])
      ]
    )
  ].


(********************************************************************

 The Kleisli category

 The usual definition of the Kleisli category (given in the file
 `Monads.KleisliCategory.v` does not give rise to a univalent
 category. In this file, we give an alternative definition of the
 Kleisli category in such a way that we do get a univalent category.
 This definition can be found here:

 https://ncatlab.org/nlab/show/Kleisli+category#in_terms_of_free_algebras

 We also prove its universal property.

 Note: to prove its universal property, we use that the usual
 definition of the Kleisli category (which is not necessarily
 univalent), satisfies the universal property. We also use that we
 have a weak equivalence between these two categories.

 Contents
 1. The free algebra functor
 2. The univalent Kleisli category
 3. The weak equivalence
 4. The universal property

 ********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.KleisliCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecompEquivalence.

Local Open Scope cat.

(**
 1. The free algebra functor
 *)
Section FreeAlgebraFunctor.
  Context {C : category}
          (m : Monad C).

  Definition free_alg_em_data
    : functor_data C (eilenberg_moore_cat m).
  Proof.
    use make_functor_data.
    - refine (λ x, make_ob_eilenberg_moore m (m x) (μ m x) _ _).
      + apply Monad_law1.
      + refine (!_).
        apply Monad_law3.
    - simple refine (λ x y f, make_mor_eilenberg_moore _ _ _).
      + exact (#m f).
      + exact (!(nat_trans_ax (μ m) _ _ f)).
  Defined.

  Definition free_alg_em_is_functor
    : is_functor free_alg_em_data.
  Proof.
    split.
    - intro x.
      use eq_mor_eilenberg_moore ; cbn.
      apply functor_id.
    - intros x y z f g.
      use eq_mor_eilenberg_moore ; cbn.
      apply functor_comp.
  Qed.

  Definition free_alg_em
    : C ⟶ eilenberg_moore_cat m.
  Proof.
    use make_functor.
    - exact free_alg_em_data.
    - exact free_alg_em_is_functor.
  Defined.
End FreeAlgebraFunctor.

(**
 2. The univalent Kleisli category
 *)
Definition kleisli_cat
           {C : category}
           (m : Monad C)
  : category
  := full_img_sub_precategory (free_alg_em m).

Definition univalent_kleisli_cat
           {C : univalent_category}
           (m : Monad C)
  : univalent_category
  := @univalent_image
       C
       (eilenberg_moore_univalent_cat C m)
       (free_alg_em m).

Definition is_z_iso_kleisli_cat
           {C : category}
           (m : Monad C)
           {x₁ x₂ : kleisli_cat m}
           {f : x₁ --> x₂}
           (Hf : is_z_isomorphism (pr111 f))
  : is_z_isomorphism f.
Proof.
  use is_iso_full_sub.
  use is_z_iso_eilenberg_moore.
  exact Hf.
Defined.

Definition z_iso_kleisli_cat
           {C : category}
           (m : Monad C)
           {x₁ x₂ : kleisli_cat m}
           (f : z_iso (pr1 x₁) (pr1 x₂))
  : z_iso x₁ x₂.
Proof.
  simple refine (_ ,, _).
  - exact (pr1 f ,, tt).
  - use is_iso_full_sub.
    exact (pr2 f).
Defined.

Definition from_z_iso_kleisli_cat
           {C : category}
           (m : Monad C)
           {x₁ x₂ : kleisli_cat m}
           (f : z_iso x₁ x₂)
  : z_iso (pr111 x₁) (pr111 x₂).
Proof.
  use make_z_iso.
  - exact (pr1 (pr111 f)).
  - exact (pr111 (inv_from_z_iso f)).
  - split.
    + exact (maponpaths (λ z, pr111 z) (z_iso_inv_after_z_iso f)).
    + exact (maponpaths (λ z, pr111 z) (z_iso_after_z_iso_inv f)).
Defined.

Definition eq_mor_kleisli_cat
           {C : category}
           (m : Monad C)
           {x₁ x₂ : kleisli_cat m}
           {f₁ f₂ : x₁ --> x₂}
           (p : pr111 f₁ = pr111 f₂)
  : f₁ = f₂.
Proof.
  use subtypePath.
  {
    intro.
    apply isapropunit.
  }
  use eq_mor_eilenberg_moore.
  exact p.
Qed.

Definition kleisli_incl
           {C : category}
           (m : Monad C)
  : C ⟶ kleisli_cat m
  := functor_full_img _.

Definition kleisli_nat_trans
           {C : category}
           (m : Monad C)
  : m ∙ kleisli_incl m ⟹ kleisli_incl m.
Proof.
  use make_nat_trans.
  - intro x.
    simple refine (_ ,, tt).
    use make_mor_eilenberg_moore ; cbn.
    + exact (μ m x).
    + abstract
        (refine (!_) ;
         apply Monad_law3).
  - abstract
      (intros x y f ;
       use eq_mor_kleisli_cat ; cbn ;
       apply (nat_trans_ax (μ m))).
Defined.

(**
 3. The weak equivalence
 *)
Definition functor_to_kleisli_cat_data
           {C : category}
           (m : Monad C)
  : functor_data (Kleisli_cat_monad m) (kleisli_cat m).
Proof.
  use make_functor_data.
  - refine (λ x, free_alg_em m x ,, hinhpr (x ,, _)).
    apply identity_z_iso.
  - refine (λ x y f, _ ,, tt).
    use make_mor_eilenberg_moore.
    + exact (# m f · μ m y).
    + abstract
        (cbn ;
         rewrite !assoc ;
         refine (maponpaths (λ z, z · _) (!(nat_trans_ax (μ m) _ _ f)) @ _) ;
         cbn ;
         rewrite !functor_comp ;
         rewrite !assoc' ;
         apply maponpaths ;
         refine (!_) ;
         apply Monad_law3).
Defined.

Definition functor_to_kleisli_cat_is_functor
           {C : category}
           (m : Monad C)
  : is_functor (functor_to_kleisli_cat_data m).
Proof.
  split.
  - intro x.
    use eq_mor_kleisli_cat.
    cbn.
    apply Monad_law2.
  - intros x y z f g.
    use eq_mor_kleisli_cat.
    cbn ; unfold bind.
    rewrite !functor_comp.
    rewrite !assoc'.
    apply maponpaths.
    rewrite !assoc.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply (nat_trans_ax (μ m)).
    }
    cbn.
    rewrite !assoc'.
    apply maponpaths.
    refine (!_).
    apply Monad_law3.
Qed.

Definition functor_to_kleisli_cat
           {C : category}
           (m : Monad C)
  : Kleisli_cat_monad m ⟶ kleisli_cat m.
Proof.
  use make_functor.
  - exact (functor_to_kleisli_cat_data m).
  - exact (functor_to_kleisli_cat_is_functor m).
Defined.

Definition functor_to_kleisli_cat_incl_nat_trans
           {C : category}
           (m : Monad C)
  : kleisli_incl m
    ⟹
    Left_Kleisli_functor m ∙ functor_to_kleisli_cat m.
Proof.
  use make_nat_trans.
  - refine (λ x, make_mor_eilenberg_moore _ (identity _) _ ,, tt).
    abstract
      (cbn ;
       rewrite functor_id, id_left, id_right ;
       apply idpath).
  - abstract
      (intros x y f ;
       use eq_mor_kleisli_cat ; cbn ;
       rewrite id_left, id_right ;
       rewrite functor_comp ;
       rewrite !assoc' ;
       refine (!_) ;
       refine (_ @ id_right _) ;
       apply maponpaths ;
       apply Monad_law2).
Defined.

Definition functor_to_kleisli_cat_incl_nat_z_iso
           {C : category}
           (m : Monad C)
  : nat_z_iso
      (kleisli_incl m)
      (Left_Kleisli_functor m ∙ functor_to_kleisli_cat m).
Proof.
  use make_nat_z_iso.
  - exact (functor_to_kleisli_cat_incl_nat_trans m).
  - intro.
    use is_z_iso_kleisli_cat.
    apply is_z_isomorphism_identity.
Defined.

Definition full_functor_to_kleisli_cat
           {C : category}
           (m : Monad C)
  : full (functor_to_kleisli_cat m).
Proof.
  intros x y f.
  apply hinhpr.
  simple refine (_ ,, _).
  - exact (η m x · pr111 f).
  - use eq_mor_kleisli_cat.
    cbn.
    rewrite functor_comp.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      exact (!(pr211 f)).
    }
    cbn.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply Monad_law2.
    }
    apply id_left.
Qed.

Definition faithful_functor_to_kleisli_cat
           {C : category}
           (m : Monad C)
  : faithful (functor_to_kleisli_cat m).
Proof.
  intros x y f.
  use invproofirrelevance.
  intros ψ₁ ψ₂.
  use subtypePath.
  {
    intro.
    apply homset_property.
  }
  pose (pr2 ψ₁ @ !(pr2 ψ₂)) as p.
  cbn in p.
  pose (maponpaths (λ z, η m _ · pr111 z) p) as q.
  cbn in q.
  rewrite !assoc in q.
  refine (_ @ q @ _).
  - refine (!_).
    etrans.
    {
      apply maponpaths_2.
      exact (!(nat_trans_ax (η m) _ _ (pr1 ψ₁))).
    }
    cbn.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply Monad_law1.
    }
    apply id_right.
  - etrans.
    {
      apply maponpaths_2.
      exact (!(nat_trans_ax (η m) _ _ (pr1 ψ₂))).
    }
    cbn.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply Monad_law1.
    }
    apply id_right.
Qed.

Definition fully_faithful_functor_to_kleisli_cat
           {C : category}
           (m : Monad C)
  : fully_faithful (functor_to_kleisli_cat m).
Proof.
  use full_and_faithful_implies_fully_faithful.
  split.
  - exact (full_functor_to_kleisli_cat m).
  - exact (faithful_functor_to_kleisli_cat m).
Defined.

Definition essentially_surjective_functor_to_kleisli_cat
           {C : category}
           (m : Monad C)
  : essentially_surjective (functor_to_kleisli_cat m).
Proof.
  intro x.
  induction x as [ x Hx ].
  revert Hx.
  use factor_dep_through_squash.
  - intro.
    apply isapropishinh.
  - intros Hx.
    apply hinhpr.
    refine (pr1 Hx ,, _).
    use z_iso_kleisli_cat.
    exact (pr2 Hx).
Defined.

(**
 4. The universal property
 *)
Section KleisliUMP1.
  Context {C₁ C₂ : univalent_category}
          (m : Monad C₁)
          (F : C₁ ⟶ C₂)
          (γ : m ∙ F ⟹ F)
          (p₁ : ∏ (x : C₁), #F (η m x) · γ x = identity _)
          (p₂ : ∏ (x : C₁), γ _ · γ x = #F (μ m x) · γ x).

  Definition functor_from_univalent_kleisli_cat
    : kleisli_cat m ⟶ C₂
    := lift_functor_along
         C₂
         (functor_to_kleisli_cat m)
         (essentially_surjective_functor_to_kleisli_cat m)
         (fully_faithful_functor_to_kleisli_cat m)
         (functor_from_kleisli_cat_monad m F γ p₁ p₂).

  Definition functor_from_univalent_kleisli_cat_nat_trans
    : kleisli_incl m ∙ functor_from_univalent_kleisli_cat ⟹ F
    := nat_trans_comp
         _ _ _
         (nat_trans_comp
            _ _ _
            (post_whisker
               (functor_to_kleisli_cat_incl_nat_z_iso m)
               functor_from_univalent_kleisli_cat)
            (pre_whisker
               _
               (lift_functor_along_comm
                  C₂
                  (functor_to_kleisli_cat m)
                  (essentially_surjective_functor_to_kleisli_cat m)
                  (fully_faithful_functor_to_kleisli_cat m)
                  (functor_from_kleisli_cat_monad m F γ p₁ p₂))))
         (functor_from_kleisli_cat_monad_nat_trans m F γ p₁ p₂).

  Definition functor_from_univalent_kleisli_cat_nat_trans_is_z_iso
    : is_nat_z_iso functor_from_univalent_kleisli_cat_nat_trans.
  Proof.
    unfold functor_from_univalent_kleisli_cat_nat_trans.
    use (@is_nat_z_iso_comp
             _ _ _ _ _
             _
             (functor_from_kleisli_cat_monad_nat_trans m F γ p₁ p₂)).
    - use (@is_nat_z_iso_comp
             _ _
             _
             (Left_Kleisli_functor m
              ∙ functor_to_kleisli_cat m
              ∙ functor_from_univalent_kleisli_cat)).
      + use post_whisker_z_iso_is_z_iso.
        apply (functor_to_kleisli_cat_incl_nat_z_iso m).
      + use (pre_whisker_on_nat_z_iso
               (Left_Kleisli_functor m)
               (lift_functor_along_comm C₂ (functor_to_kleisli_cat m)
                  (essentially_surjective_functor_to_kleisli_cat m)
                  (fully_faithful_functor_to_kleisli_cat m)
                  (functor_from_kleisli_cat_monad m F γ p₁ p₂))).
        apply (lift_functor_along_comm
                 C₂
                 (functor_to_kleisli_cat m)
                 (essentially_surjective_functor_to_kleisli_cat m)
                 (fully_faithful_functor_to_kleisli_cat m)
                 (functor_from_kleisli_cat_monad m F γ p₁ p₂)).
    - apply functor_from_kleisli_cat_monad_nat_trans_is_z_iso.
  Defined.

  Definition functor_from_univalent_kleisli_cat_eq
             (x : C₁)
    : functor_from_univalent_kleisli_cat_nat_trans (m x) · γ x
      =
      # functor_from_univalent_kleisli_cat (kleisli_nat_trans m x)
      · functor_from_univalent_kleisli_cat_nat_trans x.
  Proof.
    cbn -[lift_functor_along_comm functor_from_univalent_kleisli_cat].
    etrans.
    {
      apply maponpaths_2.
      apply id_right.
    }
    etrans.
    {
      do 2 apply maponpaths_2.
      refine (_ @ functor_id _ _).
      apply maponpaths.
      use eq_mor_kleisli_cat.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths_2.
      apply id_left.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      refine (id_right _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (_ @ functor_id _ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      apply id_left.
    }
    pose (nat_trans_ax
             (lift_functor_along_comm
                C₂ (functor_to_kleisli_cat m)
                (essentially_surjective_functor_to_kleisli_cat m)
                (fully_faithful_functor_to_kleisli_cat m)
                (functor_from_kleisli_cat_monad m F γ p₁ p₂))
             (m x) x
             (kleisli_monad_nat_trans m x))
      as p.
    refine (_ @ p @ _).
    - apply maponpaths_2.
      refine (maponpaths (λ z, # _ z) _).
      use eq_mor_kleisli_cat.
      cbn.
      rewrite functor_id, id_left.
      apply idpath.
    - apply maponpaths.
      cbn.
      rewrite functor_id, id_left.
      apply idpath.
  Qed.
End KleisliUMP1.

Section KleisliUMP2.
  Context {C₁ C₂ : univalent_category}
          (m : Monad C₁)
          {G₁ G₂ : kleisli_cat m ⟶ C₂}
          (α : kleisli_incl m ∙ G₁ ⟹ kleisli_incl m ∙ G₂)
          (p : ∏ (x : C₁),
               #G₁ (kleisli_nat_trans m x) · α x
               =
               α (m x) · # G₂ (kleisli_nat_trans m x)).

  Definition nat_trans_from_univalent_kleisli_cat_help
    : Left_Kleisli_functor m ∙ (functor_to_kleisli_cat m ∙ G₁)
      ⟹
      Left_Kleisli_functor m ∙ (functor_to_kleisli_cat m ∙ G₂)
    := nat_trans_comp
         _ _ _
         (nat_trans_comp
            _ _ _
            (post_whisker
               (nat_z_iso_inv (functor_to_kleisli_cat_incl_nat_z_iso m))
               _)
            α)
         (post_whisker
            (functor_to_kleisli_cat_incl_nat_z_iso m)
            _).

  Definition nat_trans_from_univalent_kleisli_cat_help_eq
             (x : C₁)
    : # (functor_to_kleisli_cat m ∙ G₁) (kleisli_monad_nat_trans m x)
      · nat_trans_from_univalent_kleisli_cat_help x
      =
      nat_trans_from_univalent_kleisli_cat_help (m x)
      · # (functor_to_kleisli_cat m ∙ G₂) (kleisli_monad_nat_trans m x).
  Proof.
    refine (_ @ p x @ _).
    - cbn.
      rewrite !assoc.
      rewrite <- (functor_comp G₁).
      etrans.
      {
        apply maponpaths.
        refine (_  @ functor_id G₂ _).
        apply maponpaths.
        use subtypePath ; [ intro ; apply isapropunit | ].
        use eq_mor_eilenberg_moore.
        apply idpath.
      }
      rewrite id_right.
      apply maponpaths_2.
      apply maponpaths.
      use eq_mor_kleisli_cat.
      cbn.
      rewrite functor_id.
      rewrite id_left, id_right.
      apply idpath.
    - cbn.
      rewrite !assoc'.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (_  @ functor_id G₁ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      rewrite id_left.
      rewrite <- (functor_comp G₂).
      do 2 apply maponpaths.
      use eq_mor_kleisli_cat.
      cbn.
      rewrite functor_id.
      rewrite !id_left.
      apply idpath.
  Qed.

  Definition nat_trans_from_univalent_kleisli_cat
    : G₁ ⟹ G₂
    := lift_nat_trans_along
         C₂
         (functor_to_kleisli_cat m)
         (essentially_surjective_functor_to_kleisli_cat m)
         (fully_faithful_functor_to_kleisli_cat m)
         (nat_trans_from_kleisli_cat_monad
            m
            nat_trans_from_univalent_kleisli_cat_help
            nat_trans_from_univalent_kleisli_cat_help_eq).

  Definition pre_whisker_nat_trans_from_univalent_kleisli_cat
    : pre_whisker _ nat_trans_from_univalent_kleisli_cat = α.
  Proof.
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    pose (nat_trans_eq_pointwise
            (lift_nat_trans_along_comm
               C₂
               (functor_to_kleisli_cat m)
               (essentially_surjective_functor_to_kleisli_cat m)
               (fully_faithful_functor_to_kleisli_cat m)
               (nat_trans_from_kleisli_cat_monad
                  m
                  nat_trans_from_univalent_kleisli_cat_help
                  nat_trans_from_univalent_kleisli_cat_help_eq))
            x)
      as q.
    refine (q @ _).
    cbn.
    etrans.
    {
      apply maponpaths.
      refine (_  @ functor_id G₂ _).
      apply maponpaths.
      use eq_mor_kleisli_cat.
      apply idpath.
    }
    refine (id_right _ @ _).
    etrans.
    {
      apply maponpaths_2.
      refine (_  @ functor_id G₁ _).
      apply maponpaths.
      use eq_mor_kleisli_cat.
      apply idpath.
    }
    apply id_left.
  Qed.

  Definition nat_trans_from_univalent_kleisli_cat_unique
             {β₁ β₂ : G₁ ⟹ G₂}
             (q₁ : pre_whisker _ β₁ = α)
             (q₂ : pre_whisker _ β₂ = α)
    : β₁ = β₂.
  Proof.
    use (lift_nat_trans_eq_along
             C₂
             (functor_to_kleisli_cat m)
             (essentially_surjective_functor_to_kleisli_cat m)
             (fully_faithful_functor_to_kleisli_cat m)).
    use (@nat_trans_from_kleisli_cat_monad_unique
             _ _
             m
             (functor_to_kleisli_cat m ∙ G₁)
             (functor_to_kleisli_cat m ∙ G₂)).
    - exact nat_trans_from_univalent_kleisli_cat_help.
    - use nat_trans_eq.
      {
        apply homset_property.
      }
      intro ; cbn.
      refine (nat_trans_eq_pointwise q₁ _ @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (_  @ functor_id G₂ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      refine (id_right _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (_  @ functor_id G₁ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      apply id_left.
    - use nat_trans_eq.
      {
        apply homset_property.
      }
      intro ; cbn.
      refine (nat_trans_eq_pointwise q₂ _ @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (_  @ functor_id G₂ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      refine (id_right _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (_  @ functor_id G₁ _).
        apply maponpaths.
        use eq_mor_kleisli_cat.
        apply idpath.
      }
      apply id_left.
  Qed.
End KleisliUMP2.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Require Import coqutil.Tactics.Tactics.

Lemma sub_succ_l_same n : S n - n = 1.
Proof. lia. Qed.

(* Note: Do NOT add anything that produces side conditions; this causes problems
   because of a bug in autorewrite that means it doesn't backtrack if it fails
   to solve a side condition (see https://github.com/coq/coq/issues/7672) *)
Hint Rewrite Nat.add_0_l Nat.add_0_r Nat.sub_0_r Nat.sub_0_l
     Nat.sub_diag Nat.sub_succ sub_succ_l_same : natsimpl.
Hint Rewrite Nat.mul_0_l Nat.mul_0_r Nat.mul_1_l Nat.mul_1_r : natsimpl.
Hint Rewrite Nat.div_1_r : natsimpl.
Hint Rewrite Nat.mod_1_r : natsimpl.
Ltac natsimpl_step :=
  first [ progress autorewrite with natsimpl
        | rewrite Min.min_r by lia
        | rewrite Min.min_l by lia
        | rewrite Nat.add_sub by lia
        | rewrite (fun n m => proj2 (Nat.sub_0_le n m)) by lia
        | rewrite Nat.div_0_l by lia
        | rewrite Nat.div_same by lia
        | rewrite Nat.mod_0_l by lia
        | rewrite Nat.mod_same by lia
        | rewrite Nat.mod_1_l by lia
        ].

Ltac natsimpl := repeat natsimpl_step.

(* convert to Z and use Z.to_euclidean_division_equations, then solve with
   [solver] *)
Ltac prove_by_zify' solver :=
  Zify.zify;
  (* extra step because zify fails to zify Nat.modulo and Nat.div *)
  repeat (progress rewrite ?mod_Zmod, ?div_Zdiv in * by lia;
          Zify.zify);
  Z.to_euclidean_division_equations; solver.
Ltac prove_by_zify := prove_by_zify' lia.

Module Nat.
  Lemma mul_div_exact_r a b :
    b <> 0 -> a mod b = 0 ->  a / b * b = a.
  Proof. intros. prove_by_zify. Qed.

  Lemma add_sub_cancel a b : a + b - a = b.
  Proof. lia. Qed.

  Definition ceiling (a b : nat) :=
    (a + b - 1) / b.

  Lemma ceiling_add_le_mono a b c :
    Nat.ceiling a b <= Nat.ceiling (a + c) b.
  Proof.
    cbv [Nat.ceiling]. destruct (Nat.eq_dec b 0); [ subst; reflexivity | ].
    prove_by_zify' nia.
  Qed.

  Lemma ceiling_equiv a b :
    Nat.ceiling a b = a / b + if a mod b =? 0 then 0 else 1.
  Proof.
    cbv [Nat.ceiling]. destruct (Nat.eq_dec b 0); [ subst; reflexivity | ].
    destruct (Nat.eq_dec (a mod b) 0).
    { rewrite (proj2 (Nat.eqb_eq _ _)) by lia.
      rewrite (Nat.div_mod a b) by lia. replace (a mod b) with 0 by lia.
      natsimpl. rewrite <-Nat.add_sub_assoc by lia.
      rewrite !(Nat.mul_comm b), Nat.div_mul, Nat.div_add_l by lia.
      rewrite (Nat.div_small (b - 1)) by lia.
      lia. }
    { rewrite (proj2 (Nat.eqb_neq _ _)) by lia.
      pose proof Nat.mod_bound_pos a b ltac:(lia) ltac:(lia).
      rewrite (Nat.div_mod a b) by lia.
      replace (b * (a / b) + a mod b + b - 1) with
          ((a / b + 1) * b + (a mod b - 1)) by lia.
      rewrite (Nat.mul_comm b (a / b)).
      rewrite !Nat.div_add_l by lia.
      rewrite (Nat.div_small (a mod b - 1)) by lia.
      rewrite (Nat.div_small (a mod b)) by lia.
      lia. }
  Qed.

  Lemma ceiling_add_same a b c :
    1 < c < b - 1 -> a mod b <= b - c ->
    Nat.ceiling (a + c) b = Nat.ceiling (a + 1) b.
  Proof.
    cbv [Nat.ceiling]. intros.
    destruct (Nat.eq_dec b 0); [ subst; reflexivity | ].
    rewrite (Nat.div_mod a b) by lia.
    replace (b * (a / b) + a mod b + c + b - 1) with
        ((a / b + 1) * b + (a mod b + c - 1)) by lia.
    replace (b * (a / b) + a mod b + 1 + b - 1) with
        ((a / b + 1) * b + a mod b) by lia.
    rewrite !Nat.div_add_l by lia.
    f_equal; [ ].
    rewrite !Nat.div_small; lia.
  Qed.

  Lemma ceiling_add_diff a b c :
    0 < b -> 0 < c < b -> b - c < a mod b ->
    Nat.ceiling (a + c) b = Nat.ceiling a b + 1.
  Proof.
    intros; rewrite !ceiling_equiv.
    destruct (Nat.eq_dec (a mod b) 0);
      [ rewrite (proj2 (Nat.eqb_eq _ _)) by lia
      | rewrite (proj2 (Nat.eqb_neq (a mod b) _)) by lia ].
    all:(destruct (Nat.eq_dec ((a + c) mod b) 0);
         [ rewrite (proj2 (Nat.eqb_eq _ _)) by lia
         | rewrite (proj2 (Nat.eqb_neq _ _)) by lia ]).
    all:prove_by_zify' nia.
  Qed.

  Lemma ceiling_range a b :
    0 < b -> 0 < a ->
    Nat.ceiling a b * b - b < a <= Nat.ceiling a b * b.
  Proof. cbv [Nat.ceiling]. intros. prove_by_zify. Qed.

  Lemma sub_mod_no_underflow x y :
    x < 2 ^ y -> 0 < x ->
    ((x + 2 ^ y - 1) mod 2 ^ y) = (x - 1).
  Proof.
    intros.
    rewrite Nat.add_sub_swap by trivial.
    rewrite Nat.add_mod by lia.
    rewrite Nat.mod_same by (try apply Nat.pow_nonzero; lia).
    rewrite Nat.add_0_r.
    rewrite Nat.mod_mod by lia.
    rewrite Nat.mod_small; lia.
  Qed.
End Nat.
Hint Rewrite Nat.add_sub_cancel : natsimpl.

Module Nat2N.
  Lemma inj_pow a n : (N.of_nat a ^ N.of_nat n)%N = N.of_nat (a ^ n).
  Proof.
    induction n; intros; [ reflexivity | ].
    rewrite Nat.pow_succ_r by Lia.lia.
    rewrite Nat2N.inj_succ, N.pow_succ_r by lia.
    rewrite IHn. lia.
  Qed.

  Lemma of_nat_if (b : bool) (x y: nat):
    N.of_nat (if b then x else y) = if b then N.of_nat x else N.of_nat y.
  Proof. now destruct b. Qed.
End Nat2N.

Module Pos.
  Lemma size_nat_equiv (x : positive) :
    Pos.size_nat x = Pos.to_nat (Pos.size x).
  Proof.
    induction x; intros; cbn [Pos.size_nat Pos.size];
      rewrite ?Pnat.Pos2Nat.inj_succ; (reflexivity || congruence).
  Qed.
End Pos.

Module N.
  Lemma size_nat_equiv (x : N) :
    N.size_nat x = N.to_nat (N.size x).
  Proof.
    destruct x as [|p]; [ reflexivity | ].
    apply Pos.size_nat_equiv.
  Qed.

  Lemma size_nat_le (n : nat) (x : N) :
    (x < 2 ^ N.of_nat n)%N ->
    N.size_nat x <= n.
  Proof.
    destruct (N.eq_dec x 0);
      [ intros; subst; cbn [N.size_nat]; lia | ].
    destruct n; [ rewrite N.pow_0_r; lia | ].
    intros. rewrite size_nat_equiv, N.size_log2 by auto.
    pose proof (proj1 (N.log2_lt_pow2 x (N.of_nat (S n)) ltac:(lia))
                      ltac:(eassumption)).
    lia.
  Qed.

  Lemma size_nat_le_nat sz n : n < 2 ^ sz -> N.size_nat (N.of_nat n) <= sz.
  Proof.
    clear; intros. apply size_nat_le.
    change 2%N with (N.of_nat 2).
    rewrite Nat2N.inj_pow. lia.
  Qed.

  Lemma double_succ_double n : (N.double n + 1 = N.succ_double n)%N.
  Proof.
    rewrite !N.double_spec, !N.succ_double_spec. reflexivity.
  Qed.

  Lemma succ_double_succ n : (N.succ_double n + 1 = N.double (n + 1))%N.
  Proof.
    rewrite !N.double_spec, !N.succ_double_spec. lia.
  Qed.

  Lemma succ_double_double_neq n m : N.succ_double n <> N.double m.
  Proof.
    rewrite N.double_spec, N.succ_double_spec. nia.
  Qed.

  Lemma succ_double_testbit n i :
    N.testbit (N.succ_double n) i = if (i =? 0)%N then true else N.testbit n (i-1).
  Proof.
    destruct i; subst.
    { rewrite N.bit0_odd; apply Ndouble_plus_one_bit0. }
    { destruct n, p; try congruence; try reflexivity. }
  Qed.

  Lemma double_testbit n i :
    N.testbit (N.double n) i = if (i =? 0)%N then false else N.testbit n (i-1).
  Proof.
    destruct i; subst.
    { rewrite N.bit0_odd. apply Ndouble_bit0. }
    { destruct n, p; try congruence; try reflexivity. }
  Qed.

  Lemma mod_pow2_bits_full n m i :
    N.testbit (n mod 2 ^ m) i = if (i <? m)%N then N.testbit n i else false.
  Proof.
    case_eq (N.ltb i m); rewrite ?N.ltb_lt, ?N.ltb_ge; intros;
     rewrite ?N.mod_pow2_bits_low, ?N.mod_pow2_bits_high by lia;
      try reflexivity.
  Qed.

  Lemma div_mul_l a b : (b <> 0)%N -> ((b * a) / b)%N = a.
  Proof. intros; rewrite N.mul_comm. apply N.div_mul. auto. Qed.

  Lemma mod_mul_l a b : (b <> 0)%N -> ((b * a) mod b = 0)%N.
  Proof. intros; rewrite N.mul_comm. apply N.mod_mul. auto. Qed.

  Lemma succ_double_double n : (N.succ_double n- 1)%N = N.double n.
  Proof. destruct n; reflexivity. Qed.

  Lemma ones_succ sz : N.ones (N.of_nat (S sz)) = N.succ_double (N.ones (N.of_nat sz)).
  Proof.
    cbv [N.ones].
    rewrite !N.shiftl_1_l, !N.pred_sub, N.succ_double_spec.
    rewrite Nat2N.inj_succ, N.pow_succ_r by lia.
    assert (2 ^ N.of_nat sz <> 0)%N by (apply N.pow_nonzero; lia).
    lia.
  Qed.

  Lemma mod_mod_mul_l a b c : b <> 0%N -> c <> 0%N -> ((a mod (b * c)) mod c = a mod c)%N.
  Proof.
    intros. rewrite (N.mul_comm b c).
    rewrite N.mod_mul_r, N.add_mod, N.mod_mul_l, N.add_0_r by lia.
    rewrite !N.mod_mod by lia. reflexivity.
  Qed.

  Lemma div_floor a b : b <> 0%N -> ((a - a mod b) / b = a / b)%N.
  Proof.
    intros. rewrite (N.div_mod a b) at 1 by lia.
    rewrite N.add_sub, N.div_mul_l; lia.
  Qed.

  Lemma mod_mul_div_r a b c :
    b <> 0%N -> c <> 0%N -> (a mod (b * c) / c = (a / c) mod b)%N.
  Proof.
    intros.
    rewrite (N.mul_comm b c), N.mod_mul_r by lia.
    rewrite (N.mul_comm c (_ mod b)), N.div_add by lia.
    rewrite (N.div_small (_ mod c) c) by (apply N.mod_bound_pos; lia).
    lia.
  Qed.

  Lemma lor_high_low_add a b c :
    N.lor (a * 2 ^ b) (c mod 2 ^ b) = (a * 2 ^ b + c mod 2 ^ b)%N.
  Proof.
    rewrite <-!N.shiftl_mul_pow2, <-!N.land_ones.
    apply N.bits_inj; intro i.
    rewrite !N.lor_spec, !N.land_spec.
    pose proof N.mod_pow2_bits_full (a * 2 ^ b + c mod 2 ^ b) b i as Hlow.
    rewrite N.add_mod, N.mod_mul, N.add_0_l, !N.mod_mod in Hlow
      by (apply N.pow_nonzero; lia).
    rewrite <-!N.shiftl_mul_pow2, <-!N.land_ones in Hlow.
    (* helpful assertion *)
    assert (2 ^ b <> 0)%N by (apply N.pow_nonzero; lia).
    destruct (i <? b)%N eqn:Hi;
      [ rewrite N.ltb_lt in Hi | rewrite N.ltb_ge in Hi ].
    { rewrite <-Hlow. rewrite !N.land_spec.
      rewrite N.shiftl_spec_low by lia.
      cbn [orb]. reflexivity. }
    { rewrite !N.land_spec in Hlow. rewrite Hlow.
      rewrite N.shiftl_spec_high by lia.
      rewrite Bool.orb_false_r.
      replace i with (i - b + b)%N by lia.
      rewrite N.add_sub. rewrite <-N.div_pow2_bits.
      rewrite N.shiftl_mul_pow2, N.land_ones.
      rewrite N.div_add_l by lia.
      rewrite N.div_small by (apply N.mod_bound_pos; lia).
      f_equal; lia. }
  Qed.

  Lemma testbit_high x n : (x < 2 ^ n)%N -> N.testbit x n = false.
  Proof.
    intros. destruct (N.eq_dec x 0%N); subst; [ reflexivity | ].
    apply N.bits_above_log2. apply N.log2_lt_pow2; lia.
  Qed.

  Lemma lor_lt x y xs ys: (x < 2 ^ xs -> y < 2^ys -> N.lor x y < N.max (2^xs) (2^ys))%N.
  Proof.
    intros.
    destr (xs <? ys)%N.
    {
      rewrite <- N.mod_small with (a:=y) (b:=(2^ys)%N) by lia.
      rewrite <- N.mod_small with (a:=x) (b:=(2^ys)%N) by
          (apply (N.lt_trans _ (2^xs));
            [|apply N.pow_lt_mono_r]; lia).

      rewrite <- N.land_ones.
      rewrite <- N.land_ones.

      rewrite <- N.land_lor_distr_l.
      rewrite N.land_ones.
      rewrite N.max_r by (apply N.pow_le_mono_r; lia).
      apply N.mod_upper_bound.
      lia.
    }

    {
      rewrite <- N.mod_small with (a:=x) (b:=(2^xs)%N) by lia.
      rewrite <- N.mod_small with (a:=y) (b:=(2^xs)%N) by
          (apply (N.lt_le_trans _ (2^ys));
            [|apply N.pow_le_mono_r]; lia).

      rewrite <- N.land_ones.
      rewrite <- N.land_ones.

      rewrite <- N.land_lor_distr_l.
      rewrite N.land_ones.
      rewrite N.max_l by (apply N.pow_le_mono_r; lia).
      apply N.mod_upper_bound.
      lia.
    }
  Qed.

  Lemma testbit_high_lt x n a: (x < 2 ^ n -> n <= a -> N.testbit x a = false)%N.
  Proof.
    intros.
    apply testbit_high.
    apply (N.lt_le_trans _ (2^n));
      [ lia | apply N.pow_le_mono_r; lia ].
  Qed.

  Lemma mod_mod_smaller: forall a n m: N, (((a mod 2 ^ n) mod 2 ^ m = a mod 2 ^ (N.min n m)))%N.
  Proof.
    intros.
    clear. intros.
    apply N.bits_inj.
    cbv [N.eqf]; intros x.

    destr (x <? m)%N;
    destr (x <? n)%N;
    destr (n <? m)%N;
    try rewrite N.min_l by lia;
    try rewrite N.min_r by lia;
    repeat rewrite N.mod_pow2_bits_low by easy;
    repeat rewrite N.mod_pow2_bits_high by easy;
    try reflexivity.

    { pose (N.lt_trans _ _ _ E0 E1). lia. }
  Qed.

  (* tactic for transforming boolean expressions about N arithmetic into Props *)
  Ltac bool_to_prop :=
    repeat lazymatch goal with
           | H : (_ =? _)%N = true |- _ => rewrite N.eqb_eq in H
           | H : (_ =? _)%N = false |- _ => rewrite N.eqb_neq in H
           | H : (_ <=? _)%N = true |- _ => rewrite N.leb_le in H
           | H : (_ <=? _)%N = false |- _ => rewrite N.leb_gt in H
           | H : (_ <? _)%N = true |- _ => rewrite N.ltb_lt in H
           | H : (_ <? _)%N = false |- _ => rewrite N.ltb_ge in H
           end.
End N.

(* Note: Do NOT add anything that produces side conditions; this causes problems
   because of a bug in autorewrite that means it doesn't backtrack if it fails
   to solve a side condition (see https://github.com/coq/coq/issues/7672) *)
Hint Rewrite N.clearbit_eq N.b2n_bit0 N.shiftr_spec'
     N.pow2_bits_true N.add_bit0 N.land_spec N.lor_spec
     N.testbit_even_0 N.setbit_eqb N.pow2_bits_eqb N.ldiff_spec
     N.div2_bits N.double_bits_succ N.clearbit_eqb
     N.bits_0 N.succ_double_testbit N.double_testbit
     N.mod_pow2_bits_full : push_Ntestbit.

Ltac push_Ntestbit_step :=
  match goal with
  | _ => progress autorewrite with push_Ntestbit
  | |- context [N.testbit (N.ones ?n) ?m]  =>
    first [ rewrite (N.ones_spec_high n m) by lia
          | rewrite (N.ones_spec_low n m) by lia ]
  | |- context [N.testbit (N.shiftl ?a ?n) ?m] =>
    first [ rewrite (N.shiftl_spec_high' a n m) by lia
          | rewrite (N.shiftl_spec_low a n m) by lia ]
  | |- context [N.testbit (N.lnot ?a ?n) ?m] =>
    first [ rewrite (N.lnot_spec_high a n m) by lia
          | rewrite (N.lnot_spec_low a n m) by lia ]
  | |- context [N.testbit ?x ?m] =>
    rewrite (N.testbit_high x m) by lia
  end.
Ltac push_Ntestbit := repeat push_Ntestbit_step.

Lemma le_1_is_0 x: (1 <=? x)%nat = negb (x =? 0)%nat.
Proof. destruct x; reflexivity. Qed.

Module N2Nat.
  (* TODO: these exists in latest Coq *)
  Lemma inj_mod a a' :
    N.to_nat (a mod a') = N.to_nat a mod N.to_nat a'.
  Proof. Admitted.
  Lemma inj_pow a a' :
    N.to_nat (a ^ a')%N = (N.to_nat a ^ N.to_nat a')%nat.
  Proof. Admitted.

  Lemma inj_leb x y: (x <=? y)%N = (N.to_nat x <=? N.to_nat y)%nat.
  Proof. Admitted.

  Lemma inj_ltb x y: (x <? y)%N = (N.to_nat x <? N.to_nat y)%nat.
  Proof. Admitted.

  Lemma inj_eqb x y: (x =? y)%N = (N.to_nat x =? N.to_nat y)%nat.
  Proof. Admitted.

  (* Get nice constants *)
  Lemma inj_0: N.to_nat 0 = 0. trivial. Qed.
  Lemma inj_1: N.to_nat 1 = 1. trivial. Qed.
  Lemma inj_2: N.to_nat 2 = 2. trivial. Qed.
  Lemma inj_3: N.to_nat 3 = 3. trivial. Qed.
End N2Nat.

Hint Rewrite
  N2Nat.inj_eqb N2Nat.inj_ltb N2Nat.inj_leb N2Nat.inj_mod N2Nat.inj_pow
  N2Nat.inj_0 N2Nat.inj_1 N2Nat.inj_2 N2Nat.inj_3
  : Nnat.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import PreSheaf.PreSheaf.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.

Section PSh_GenProd.
  Context (C : Category) (A : Type) (map : A → PreSheaf C).

  Local Notation Fm := (Discr_Func (PShCat C) map) (only parsing).

  Local Hint Extern 1 => match goal with [|- context [(?F _a id)%morphism]] => rewrite (F_id F) end.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  (** The generalized product presheaf. *)
  Program Definition PSh_GenProd_func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          ∀ x : A, ((Fm _o x) _o c)%object;
      FA :=
        fun _ _ h f x => (map x _a h (f x))%morphism
    |}.

  (** The projections of generalized product presheaf. *)
  Program Definition PSh_GenProd_proj (x : A) : (PSh_GenProd_func –≻ map x)%nattrans :=
    {|
      Trans := fun c y => y x
    |}.

  (** The cone for generalized product presheaf. *)
  Program Definition PSh_GenProd_Cone : Cone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => PSh_GenProd_func;
          FA :=
            fun _ _ h => id
        |};
      cone_edge := {|Trans := fun x => PSh_GenProd_proj x |}
    |}.

  Local Hint Extern 1 =>
    match goal with
      [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
      cbn_rewrite (equal_f (Trans_com f h))
    end.

  Local Hint Extern 1 => match goal with [H : unit |- _] => destruct H end.

  Local Hint Resolve NatTrans_eq_simplify.

  Local Hint Extern 1 => rewrite From_Term_Cat.

  (** The morphism that maps to the generalized product given a map to its components. *)
  Program Definition PSh_GenProd_morph_ex
          (Cn : LoKan_Cone (Functor_To_1_Cat (Discr_Cat A)) (Discr_Func (PShCat C) map))
    : ((Cn _o)%object tt –≻ PSh_GenProd_func)%nattrans :=
    {|
      Trans := fun c y x => Trans (Trans (cone_edge Cn) x) c y
    |}.

  Local Hint Extern 1 => progress cbn.

  Local Obligation Tactic := basic_simpl; auto 10.

  Program Definition PSh_GenProd : @GenProd _ (PShCat C) map :=
    {|
      LRKE := PSh_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|
                Trans :=
                  fun x =>
                    match x as u return ((Cn _o)%object u –≻ PSh_GenProd_func)%nattrans with
                      tt => PSh_GenProd_morph_ex Cn
                    end
              |}
          |}
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros Cn h h'.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply NatTrans_eq_simplify.
    extensionality y.
    extensionality z.
    extensionality u.
    cbn in *.
    destruct x.
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (
                fun w : (Cn ∘ Functor_To_1_Cat (Discr_Cat A) –≻ Discr_Func (PShCat C) map)%nattrans
                => Trans (Trans w u) y
              )
              (cone_morph_com h)
          )
          z
      ).
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (
                fun w : (Cn ∘ Functor_To_1_Cat (Discr_Cat A) –≻ Discr_Func (PShCat C) map)%nattrans
                => Trans (Trans w u) y
              )
              (cone_morph_com h')
          )
          z
      ).
    trivial.
  Qed.

End PSh_GenProd.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This module states propositional extensionality and draws
    consequences of it *)

Axiom propositional_extensionality :
  forall (P Q : Prop), (P <-> Q) -> P = Q.

Require Import ClassicalFacts.

Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
Proof.
  apply ext_prop_dep_proof_irrel_cic.
  exact propositional_extensionality.
Qed.


Require Import Coq.Program.Tactics.
From mathcomp Require Import ssreflect ssrfun.
From mathcomp Require Import eqtype choice seq bigop.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
    From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.
Open Scope ring_scope.

Module idempotent.
    Section Def.
        Variable (R : ringType).
        Definition axiom (e : R) := e*e == e.
        Record type := Pack { sort : _ ; _ : axiom sort; }.
        Local Coercion sort : type >-> GRing.Ring.sort.

        Definition orthogonal (e1 e2 : type) := ((sort e1) == (sort e2)) || ((sort e1)*e2 == 0) && (e2*e1 == 0).
    End Def.
    Module Exports.
        Notation idempType := type.
        Coercion sort : type >-> GRing.Ring.sort.
    End Exports.
End idempotent.
Export idempotent.Exports.
Module basicAlgebra.
    Section Def.
        Variable (R : ringType).

        Definition allUnique {A : algType R} (L : seq (idempType A))
            := uniq (map (@idempotent.sort A) L).

        Definition allOrthogonal {A : algType R} (L : seq (idempType A))
            := all2 (@idempotent.orthogonal A) L L.

        Definition allPrimitive {A : algType R} (L : seq (idempType A))
            := forall e1 e2 : idempType A,
                all (fun e : idempType A => ((idempotent.sort e) != (idempotent.sort e1) + (idempotent.sort e2))%R) L.

        Definition sumToOne {A : algType R} (L : seq (idempType A))
            := \sum_(e <- L)(idempotent.sort e) == 1.

        Definition axiom {A : algType R} (L : seq (idempType A))
            := all2 (fun e1 e2 => true) L L.

        Record class (A : algType R) := Class {
            cpoi : seq (idempType A);
            _ : allUnique cpoi;
            _ : allOrthogonal cpoi;
            _ : allPrimitive cpoi;
            _ : sumToOne cpoi;
            _ : axiom cpoi;
        }.
        Record type := Pack { sort : _; class_of : class sort; }.
    End Def.
    Local Notation basicAlgType := type.
    Local Coercion sort : type >-> GRing.Algebra.type.

    Section Theory.
    Variable (R : ringType) (A : basicAlgType R).

    Definition makeQuiver : quiverType.

    End Theory.
    Module Exports.
        Notation basicLAlgType := type.
        Coercion sort : type >-> GRing.Algebra.type.
    End Exports.
End basicAlgebra.


Require Export Program Omega.
Obligation Tactic := program_simpl;omega.
Program Definition le_ind_using_nat_ind n (P : nat -> Prop)
  (p : P n)(p' : forall m : nat, n <= m -> P m -> P (S m)) n0 (lep : n <= n0) : P n0 :=
  nat_ind (fun x => P (x + n)) p (fun x => p' (x + n) _) (n0 - n).
Goal le_ind_using_nat_ind = le_ind.
  apply proof_irrelevance.
Qed.