Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Syntax.
Require Import Ofe.
Require Import Spaces.
Require Import Uniform.
Require Import Urelsp.
Require Import Ordinal.
Require Import Equivalence.
Require Import MapTerm.
Require Import Hygiene.
Require Import Intensional.

Inductive pre_qkind (w : ordinal) (Ob : forall v, v << w -> Type) : Type :=
| pqone : fin 0 << w -> pre_qkind w Ob

| pqtype : forall v, v << w -> pre_qkind w Ob

| pqarrow : pre_qkind w Ob -> pre_qkind w Ob -> pre_qkind w Ob

| pqtarrow : forall v (h : v << w), car (urel_ofe (Ob v h)) -> pre_qkind w Ob -> pre_qkind w Ob

| pqprod : pre_qkind w Ob -> pre_qkind w Ob -> pre_qkind w Ob

| pqfut : pre_qkind w Ob -> pre_qkind w Ob
.

Fixpoint pre_space (w : ordinal)
  (Ob : forall v, v << w -> Type)
  (k : pre_qkind w Ob)
  : ofe :=
  match k with
  | pqone _ _ _ => unit_ofe

  | pqtype _ _  v h => iurel_ofe (Ob v h)

  | pqarrow _ _ k1 k2 => nearrow_ofe (pre_space w Ob k1) (pre_space w Ob k2)

  | pqtarrow _ _ v h A k2 => nearrow_ofe (urelsp A) (pre_space w Ob k2)

  | pqprod _ _ k1 k2 => prod_ofe (pre_space w Ob k1) (pre_space w Ob k2)

  | pqfut _ _ k1 => half (pre_space w Ob k1)
  end.

Fixpoint pre_obj (w : ordinal) (acc : Acc lt_ord w) {struct acc}
  : Type :=
  option
    (existsT (k : pre_qkind w (fun u h => pre_obj u (Acc_inv acc u h))),
       car (pre_space _ _ k)).

Definition obj (w : ordinal) : Type :=
  pre_obj w (lt_ord_wf w).

Definition wterm (w : ordinal) : Type := term (obj w).
Definition wurel (w : ordinal) : Type := urel (obj w).
Definition wurel_ofe (w : ordinal) : ofe := urel_ofe (obj w).
Definition wiurel (w : ordinal) : Type := iurel (obj w).
Definition wiurel_ofe (w : ordinal) : ofe := iurel_ofe (obj w).

Inductive qkind : Type :=
| qone : qkind

| qtype : ordinal -> qkind

| qarrow : qkind -> qkind -> qkind

| qtarrow : forall w, car (wurel_ofe w) -> qkind -> qkind

| qprod : qkind -> qkind -> qkind

| qfut : qkind -> qkind
.

Fixpoint level (k : qkind) : ordinal :=
  match k with
  | qone => fin 0

  | qtype w => w

  | qarrow k1 k2 => max_ord (level k1) (level k2)

  | qtarrow w _ k2 => max_ord w (level k2)

  | qprod k1 k2 => max_ord (level k1) (level k2)

  | qfut k1 => level k1
  end.

Fixpoint space (k : qkind) : ofe :=
  match k with
  | qone => unit_ofe

  | qtype w => wiurel_ofe w

  | qarrow k1 k2 => nearrow_ofe (space k1) (space k2)

  | qtarrow i A k2 => nearrow_ofe (urelsp A) (space k2)

  | qprod k1 k2 => prod_ofe (space k1) (space k2)

  | qfut k1 => half (space k1)
  end.

Definition spcar (k : qkind) := car (space k).

Definition candidate : Type :=
  existsT (k : qkind), car (space k).

Inductive xobj w : Type :=
| objsome : forall (Q : candidate), level (pi1 Q) << w -> xobj w
| objnone : xobj w.

Arguments objsome {w}.
Arguments objnone {w}.

Lemma objsome_compat :
  forall w Q Q' h h',
    Q = Q'
    -> @objsome w Q h = objsome Q' h'.
Proof.
intros w Q Q' h h' H.
subst Q'.
so (proof_irrelevance _ h h'); subst h'.
reflexivity.
Qed.

Local Definition Ob {w} (v : ordinal) (h : v << w) : Type := obj v.

Lemma obj_unroll :
  forall w,
    obj w
    =
    option (existsT (k : pre_qkind w Ob),
              car (pre_space _ _ k)).
Proof.
intros w.
unfold Ob.
unfold obj.
set (acc := lt_ord_wf w).
destruct acc as [IH].
cbn.
f_equal.
apply (exT_equal
         (forall u, u << w -> Type)
         (pre_qkind w)
         (fun Ob k => car (pre_space _ _ k))
         (fun Ob k => car (pre_space _ _ k))).
apply (eq_impl_eq_dep_fst
         (forall u, u << w -> Type)
         (fun Ob => pre_qkind w Ob -> Type)
         _ _
         (fun Ob k => car (pre_space _ _ k))).
fextensionality 2.
intros u H.
f_equal.
apply proof_irrelevance.
Qed.

Fixpoint pre_qkind_to_qkind {w : ordinal} (k : pre_qkind w Ob) {struct k}
  : qkind
  :=
  match k with
  | pqone _ _ _ => qone

  | pqtype _ _ v _ => qtype v

  | pqarrow _ _ k1 k2 => qarrow (pre_qkind_to_qkind k1) (pre_qkind_to_qkind k2)

  | pqtarrow _ _ v _ A k2 => qtarrow v A (pre_qkind_to_qkind k2)

  | pqprod _ _ k1 k2 => qprod (pre_qkind_to_qkind k1) (pre_qkind_to_qkind k2)

  | pqfut _ _ k1 => qfut (pre_qkind_to_qkind k1)
  end.

Fixpoint qkind_to_pre_qkind {w : ordinal} (k : qkind) {struct k}
  : level k << w -> pre_qkind w Ob
  :=
  match k
    as k
    return level k << w -> pre_qkind w Ob
  with
  | qone => (fun h => pqone _ _ h)

  | qtype v => (fun h => pqtype _ _ v h)

  | qarrow k1 k2 =>
      (fun h =>
         pqarrow _ _
           (qkind_to_pre_qkind k1 (max_ord_lub_strict_l _#3 h))
           (qkind_to_pre_qkind k2 (max_ord_lub_strict_r _#3 h)))

  | qtarrow v A k2 =>
      (fun h =>
         pqtarrow _ _
           v (max_ord_lub_strict_l _#3 h) A
           (qkind_to_pre_qkind k2 (max_ord_lub_strict_r _#3 h)))

  | qprod k1 k2 =>
      (fun h =>
         pqprod _ _
           (qkind_to_pre_qkind k1 (max_ord_lub_strict_l _#3 h))
           (qkind_to_pre_qkind k2 (max_ord_lub_strict_r _#3 h)))

  | qfut k1 =>
      (fun h =>
         pqfut _ _ (qkind_to_pre_qkind k1 h))
  end.

Lemma pre_qkind_level :
  forall w (k : pre_qkind w Ob),
    level (pre_qkind_to_qkind k) << w.
Proof.
intros w k.
induct k; cbn; auto using max_ord_lub_strict.
Qed.

Lemma qkind_to_pre_qkind_and_back :
  forall w (k : qkind) (h : level k << w),
    pre_qkind_to_qkind (qkind_to_pre_qkind k h) = k.
Proof.
intros w k.
induct k; intros; cbn; f_equal; auto.
Qed.

Lemma pre_qkind_to_qkind_and_back :
  forall w (k : pre_qkind w Ob) h,
    qkind_to_pre_qkind (pre_qkind_to_qkind k) h = k.
Proof.
intros w k.
induct k; try (intros; cbn; f_equal; auto using proof_irrelevance; done).
Qed.

Lemma pre_space_to_space :
  forall w (k : pre_qkind w Ob),
    pre_space w Ob k = space (pre_qkind_to_qkind k).
Proof.
intros w k.
induct k; intros; cbn; f_equal; auto.
Qed.

Lemma space_to_pre_space :
  forall w (k : qkind) (h : level k << w),
    space k = pre_space w Ob (qkind_to_pre_qkind k h).
Proof.
intros w k h.
symmetry.
etransitivity.
  {
  exact (pre_space_to_space w (qkind_to_pre_qkind k h)).
  }
f_equal.
apply qkind_to_pre_qkind_and_back.
Qed.

Definition objout {w : ordinal} (c : obj w) : xobj w
  :=
  match transport (obj_unroll w) (fun T => T) c with
  | Some c' =>
      objsome
        (expair
           (pre_qkind_to_qkind (pi1 c'))
           (transport (pre_space_to_space w (pi1 c')) car (pi2 c')))
        (pre_qkind_level w (pi1 c'))

  | None => objnone
  end.

Definition objin {w : ordinal} (c : xobj w) : obj w
  :=
  transport (eqsymm (obj_unroll w)) (fun T => T)
    (match c with
     | objsome Q h =>
         Some
           (expair (qkind_to_pre_qkind (pi1 Q) h)
              (transport (space_to_pre_space w (pi1 Q) h) car (pi2 Q)))

     | objnone => None
     end).

Lemma objout_objin :
  forall w (c : xobj w),
    objout (objin c) = c.
Proof.
intros w c.
unfold objout, objin.
rewrite -> transport_compose.
set (X := eqtrans (eqsymm (obj_unroll w)) (obj_unroll w)).
clearbody X.
substrefl X.
destruct c as [(k, x) h |].
  {
  cbn.
  apply objsome_compat; auto.
  apply expair_compat_heq.
    {
    apply qkind_to_pre_qkind_and_back.
    }
  rewrite -> !transport_compose.
  apply heq_transport.
  }

  {
  cbn.
  reflexivity.
  }
Qed.

Lemma objin_objout :
  forall w (c : obj w),
    objin (objout c) = c.
Proof.
intros w c.
unfold objout, objin.
transitivity (transport (eq_refl (obj w)) (fun T => T) c); [| reflexivity].
rewrite -> (proof_irrelevance (obj w = obj w) (eq_refl (obj w)) (eqtrans (obj_unroll w) (eqsymm (obj_unroll w)))).
rewrite <- transport_compose.
f_equal.
set (d := transport (obj_unroll w) (fun T => T) c).
clearbody d.
clear c.
cbn in d.
destruct d as [d |].
  {
  cbn.
  destruct d as (k, x).
  cbn.
  f_equal.
  apply expair_compat_heq.
    {
    apply pre_qkind_to_qkind_and_back.
    }
  eapply heq_trans; [apply heq_transport |].
  apply heq_transport.
  }

  {
  reflexivity.
  }
Qed.

Global Opaque obj objin objout.

Lemma objin_inj :
  forall w, injective (@objin w).
Proof.
intros w x y Heq.
so (f_equal objout Heq) as H.
rewrite -> !objout_objin in H.
auto.
Qed.


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

Require Import LensLaws.Isomorphism.
Require Import LensLaws.Crush.
Require Import LensLaws.Prism.

Theorem prism_sum {A B C} (ab : Prism A B) (ac : Prism A C)
  (law1 : forall c, prism_preview ab (prism_review ac c) = None)
  (law2 : forall b, prism_preview ac (prism_review ab b) = None)
  : Prism A (B + C).
Proof.
  set (review := fun (bc : B + C) => match bc with
    | inl b => prism_review ab b
    | inr c => prism_review ac c
    end).

  set (preview := fun (a : A) => match prism_preview ab a with
    | Some b => Some (inl b)
    | None   => match prism_preview ac a with
      | Some c => Some (inr c)
      | None   => None
      end
    end).

  apply (@prism_complete _ _ review preview); unfold review; unfold preview.

  - intros bc. destruct bc.
    + rewrite (prism_law1 ab). reflexivity.
    + rewrite law1. rewrite (prism_law1 ac). reflexivity.

  - intros a bc. destruct bc.
    + remember (prism_preview ab a) as pa. destruct pa; crush.
      * apply prism_law2. symmetry. apply Heqpa.
      * remember (prism_preview ac a) as pc. destruct pc; crush.

    + remember (prism_preview ab a) as pa. destruct pa; crush.
      remember (prism_preview ac a) as pc. destruct pc; crush.
      apply prism_law2. symmetry. apply Heqpc. Qed.


Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export Needle.
Section Namespace.
  Inductive Namespace : Type :=
    | tm .
  Lemma eq_namespace_dec (a : Namespace) (b : Namespace) :
    (sumbool (a =
    b) (not (a =
    b))).
  Proof.
    decide equality .
  Defined.
End Namespace.

Section HVarlist.
  Inductive Hvl : Type :=
    | H0
    | HS (a : Namespace) (k : Hvl).

  Fixpoint appendHvl (k : Hvl) (k0 : Hvl) {struct k0} : Hvl :=
    match k0 with
      | (H0) => k
      | (HS a k0) => (HS a (appendHvl k k0))
    end.

  Lemma appendHvl_assoc  :
    (forall (k : Hvl) (k0 : Hvl) (k1 : Hvl) ,
      ((appendHvl (appendHvl k k0) k1) =
      (appendHvl k (appendHvl k0 k1)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
End HVarlist.

Section Index.
  Inductive Index (a : Namespace) : Type :=
    | I0
    | IS : (Index a) -> (Index a).

  Global Arguments I0 [a] .
  Global Arguments IS [a] _ .

  Lemma eq_index_dec {a : Namespace} (i : (Index a)) (j : (Index a)) :
    (sumbool (i =
    j) (not (i =
    j))).
  Proof.
    decide equality .
  Qed.

  Fixpoint weakenIndextm (x : (Index tm)) (k : Hvl) {struct k} : (Index tm) :=
    match k with
      | (H0) => x
      | (HS a k) => match a with
        | (tm) => (IS (weakenIndextm x k))
      end
    end.
  Lemma weakenIndextm_append  :
    (forall (x : (Index tm)) (k : Hvl) (k0 : Hvl) ,
      ((weakenIndextm (weakenIndextm x k) k0) =
      (weakenIndextm x (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
End Index.

Section Terms.
  Inductive Ty : Set :=
    | tunit
    | tarr (T1 : Ty) (T2 : Ty).
  Scheme ind_Ty := Induction for Ty Sort Prop.

  Inductive Tm : Set :=
    | var (x : (Index tm))
    | tt
    | abs (T : Ty) (t : Tm)
    | app (t1 : Tm) (t2 : Tm).
  Scheme ind_Tm := Induction for Tm Sort Prop.
End Terms.

Section Functions.

End Functions.

Section Shift.
  Inductive Cutoff (a : Namespace) : Type :=
    | C0
    | CS : (Cutoff a) -> (Cutoff a).

  Global Arguments C0 {a} .
  Global Arguments CS {a} _ .
  Fixpoint weakenCutofftm (c : (Cutoff tm)) (k : Hvl) {struct k} : (Cutoff tm) :=
    match k with
      | (H0) => c
      | (HS a k) => match a with
        | (tm) => (CS (weakenCutofftm c k))
      end
    end.

  Lemma weakenCutofftm_append  :
    (forall (c : (Cutoff tm)) (k : Hvl) (k0 : Hvl) ,
      ((weakenCutofftm (weakenCutofftm c k) k0) =
      (weakenCutofftm c (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
  Fixpoint shiftIndex (c : (Cutoff tm)) (x : (Index tm)) {struct c} : (Index tm) :=
    match c with
      | (C0) => (IS x)
      | (CS c) => match x with
        | (I0) => I0
        | (IS x) => (IS (shiftIndex c x))
      end
    end.
  Fixpoint shiftTm (c : (Cutoff tm)) (s : Tm) {struct s} : Tm :=
    match s with
      | (var x) => (var (shiftIndex c x))
      | (tt) => (tt)
      | (abs T t) => (abs T (shiftTm (weakenCutofftm c (appendHvl (HS tm H0) H0)) t))
      | (app t1 t2) => (app (shiftTm (weakenCutofftm c H0) t1) (shiftTm (weakenCutofftm c H0) t2))
    end.
End Shift.

Section Weaken.
  Fixpoint weakenTy (S0 : Ty) (k : Hvl) {struct k} : Ty :=
    match k with
      | (H0) => S0
      | (HS tm k) => (weakenTy S0 k)
    end.
  Fixpoint weakenTm (s : Tm) (k : Hvl) {struct k} : Tm :=
    match k with
      | (H0) => s
      | (HS tm k) => (shiftTm C0 (weakenTm s k))
    end.
End Weaken.

Section Subst.
  Inductive Trace (a : Namespace) : Type :=
    | X0
    | XS (b : Namespace)
        (T : (Trace a)).

  Global Arguments X0 [a] .
  Global Arguments XS [a] b _ .
  Fixpoint weakenTrace {a : Namespace} (x : (Trace a)) (k : Hvl) {struct k} : (Trace a) :=
    match k with
      | (H0) => x
      | (HS b k) => (XS b (weakenTrace x k))
    end.
  Lemma weakenTrace_append (a : Namespace) :
    (forall (x : (Trace a)) (k : Hvl) (k0 : Hvl) ,
      ((weakenTrace (weakenTrace x k) k0) =
      (weakenTrace x (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
  Fixpoint substIndex (d : (Trace tm)) (s : Tm) (x : (Index tm)) {struct d} : Tm :=
    match d with
      | (X0) => match x with
        | (I0) => s
        | (IS x) => (var x)
      end
      | (XS tm d) => match x with
        | (I0) => (var I0)
        | (IS x) => (shiftTm C0 (substIndex d s x))
      end
    end.
  Fixpoint substTm (d : (Trace tm)) (s : Tm) (s0 : Tm) {struct s0} : Tm :=
    match s0 with
      | (var x) => (substIndex d s x)
      | (tt) => (tt)
      | (abs T t) => (abs T (substTm (XS tm d) s t))
      | (app t1 t2) => (app (substTm d s t1) (substTm d s t2))
    end.
End Subst.

Global Hint Resolve (f_equal (shiftTm C0)) : cong_shift0.
 Hint Rewrite weakenCutofftm_append : interaction.
 Hint Rewrite weakenCutofftm_append : weakencutoff_append.
 Hint Rewrite weakenTrace_append : interaction.
 Hint Rewrite weakenTrace_append : weakentrace_append.
Section SubstShiftReflection.
  Lemma substIndex0_shiftIndex0_reflection_ind (s : Tm) :
    (forall (k0 : Hvl) (x2 : (Index tm)) ,
      ((substIndex (weakenTrace X0 k0) s (shiftIndex (weakenCutofftm C0 k0) x2)) =
      (var x2))).
  Proof.
    needleGenericSubstIndexShiftIndexReflectionInd .
  Qed.
  Definition subst0_shift0_Tm_reflection_ind := (ind_Tm (fun (s0 : Tm) =>
    (forall (k1 : Hvl) (s1 : Tm) ,
      ((substTm (weakenTrace X0 k1) s1 (shiftTm (weakenCutofftm C0 k1) s0)) =
      s0))) (fun (x5 : (Index tm)) =>
    (fun (k1 : Hvl) (s0 : Tm) =>
      (substIndex0_shiftIndex0_reflection_ind s0 k1 x5))) (fun (k1 : Hvl) (s0 : Tm) =>
    eq_refl) (fun (T : Ty) (t : Tm) IHt5 (k1 : Hvl) (s0 : Tm) =>
    (f_equal2 abs eq_refl (eq_trans (f_equal3 substTm (weakenTrace_append tm X0 k1 (HS tm H0)) eq_refl eq_refl) (IHt5 (HS tm k1) s0)))) (fun (t1 : Tm) IHt5 (t2 : Tm) IHt6 (k1 : Hvl) (s0 : Tm) =>
    (f_equal2 app (IHt5 k1 s0) (IHt6 k1 s0)))).
  Definition substTm0_shiftTm0_reflection (s1 : Tm) : (forall (s0 : Tm) ,
    ((substTm X0 s0 (shiftTm C0 s1)) =
    s1)) := (subst0_shift0_Tm_reflection_ind s1 H0).
End SubstShiftReflection.
Section ShiftInteraction.
  Section ShiftIndexCommInd.
    Lemma shiftIndex_shiftIndex0_comm_ind  :
      (forall (k : Hvl) (c : (Cutoff tm)) (x : (Index tm)) ,
        ((shiftIndex (weakenCutofftm (CS c) k) (shiftIndex (weakenCutofftm C0 k) x)) =
        (shiftIndex (weakenCutofftm C0 k) (shiftIndex (weakenCutofftm c k) x)))).
    Proof.
      needleGenericShiftIndexCommInd .
    Qed.
  End ShiftIndexCommInd.
  Section ShiftCommInd.
    Definition shift_shift0_Tm_comm_ind := (ind_Tm (fun (s : Tm) =>
      (forall (k0 : Hvl) (c0 : (Cutoff tm)) ,
        ((shiftTm (weakenCutofftm (CS c0) k0) (shiftTm (weakenCutofftm C0 k0) s)) =
        (shiftTm (weakenCutofftm C0 k0) (shiftTm (weakenCutofftm c0 k0) s))))) (fun (x2 : (Index tm)) =>
      (fun (k0 : Hvl) (c0 : (Cutoff tm)) =>
        (f_equal var (shiftIndex_shiftIndex0_comm_ind k0 c0 x2)))) (fun (k0 : Hvl) (c0 : (Cutoff tm)) =>
      eq_refl) (fun (T : Ty) (t : Tm) IHt0 (k0 : Hvl) (c0 : (Cutoff tm)) =>
      (f_equal2 abs eq_refl (IHt0 (HS tm k0) c0))) (fun (t1 : Tm) IHt0 (t2 : Tm) IHt3 (k0 : Hvl) (c0 : (Cutoff tm)) =>
      (f_equal2 app (IHt0 k0 c0) (IHt3 k0 c0)))).
  End ShiftCommInd.
  Section ShiftComm.
    Definition shift_shift0_Tm_comm (s : Tm) : (forall (c0 : (Cutoff tm)) ,
      ((shiftTm (CS c0) (shiftTm C0 s)) =
      (shiftTm C0 (shiftTm c0 s)))) := (shift_shift0_Tm_comm_ind s H0).
  End ShiftComm.
End ShiftInteraction.
 Hint Rewrite shift_shift0_Tm_comm : interaction.
 Hint Rewrite shift_shift0_Tm_comm : shift_shift0.
Section WeakenShift.
  Lemma weakenTm_shiftTm  :
    (forall (k7 : Hvl) (c1 : (Cutoff tm)) (s7 : Tm) ,
      ((weakenTm (shiftTm c1 s7) k7) =
      (shiftTm (weakenCutofftm c1 k7) (weakenTm s7 k7)))).
  Proof.
    needleGenericWeakenShift .
  Qed.
End WeakenShift.
Section ShiftSubstInteraction.
  Section ShiftSubstIndexCommInd.
    Lemma shiftTm_substIndex0_comm_ind (c0 : (Cutoff tm)) (s0 : Tm) :
      (forall (k1 : Hvl) (x5 : (Index tm)) ,
        ((shiftTm (weakenCutofftm c0 k1) (substIndex (weakenTrace X0 k1) s0 x5)) =
        (substIndex (weakenTrace X0 k1) (shiftTm c0 s0) (shiftIndex (weakenCutofftm (CS c0) k1) x5)))).
    Proof.
      needleGenericShiftSubstIndexCommInd .
    Qed.
  End ShiftSubstIndexCommInd.
  Section ShiftSubstCommInd.
    Definition shift_subst0_Tm_comm_ind := (ind_Tm (fun (s1 : Tm) =>
      (forall (k2 : Hvl) (c1 : (Cutoff tm)) (s2 : Tm) ,
        ((shiftTm (weakenCutofftm c1 k2) (substTm (weakenTrace X0 k2) s2 s1)) =
        (substTm (weakenTrace X0 k2) (shiftTm c1 s2) (shiftTm (weakenCutofftm (CS c1) k2) s1))))) (fun (x8 : (Index tm)) =>
      (fun (k2 : Hvl) (c1 : (Cutoff tm)) (s1 : Tm) =>
        (shiftTm_substIndex0_comm_ind c1 s1 k2 x8))) (fun (k2 : Hvl) (c1 : (Cutoff tm)) (s1 : Tm) =>
      eq_refl) (fun (T : Ty) (t : Tm) IHt8 (k2 : Hvl) (c1 : (Cutoff tm)) (s1 : Tm) =>
      (f_equal2 abs eq_refl (eq_trans (f_equal2 shiftTm eq_refl (f_equal3 substTm (weakenTrace_append tm X0 k2 (HS tm H0)) eq_refl eq_refl)) (eq_trans (IHt8 (HS tm k2) c1 s1) (f_equal3 substTm (eq_sym (weakenTrace_append tm X0 k2 (HS tm H0))) eq_refl eq_refl))))) (fun (t1 : Tm) IHt8 (t2 : Tm) IHt9 (k2 : Hvl) (c1 : (Cutoff tm)) (s1 : Tm) =>
      (f_equal2 app (IHt8 k2 c1 s1) (IHt9 k2 c1 s1)))).
  End ShiftSubstCommInd.
  Section ShiftSubstComm.
    Definition shiftTm_substTm0_comm (s2 : Tm) : (forall (c1 : (Cutoff tm)) (s1 : Tm) ,
      ((shiftTm c1 (substTm X0 s1 s2)) =
      (substTm X0 (shiftTm c1 s1) (shiftTm (CS c1) s2)))) := (shift_subst0_Tm_comm_ind s2 H0).
  End ShiftSubstComm.
  Section SubstShiftIndexCommInd.
    Lemma substIndex_shiftTm0_comm_ind (d : (Trace tm)) (s1 : Tm) :
      (forall (k2 : Hvl) (x8 : (Index tm)) ,
        ((substIndex (weakenTrace (XS tm d) k2) s1 (shiftIndex (weakenCutofftm C0 k2) x8)) =
        (shiftTm (weakenCutofftm C0 k2) (substIndex (weakenTrace d k2) s1 x8)))).
    Proof.
      needleGenericShiftSubstIndexCommInd .
    Qed.
  End SubstShiftIndexCommInd.
  Section SubstShiftCommInd.
    Definition subst_shift0_Tm_comm_ind := (ind_Tm (fun (s5 : Tm) =>
      (forall (k6 : Hvl) (d3 : (Trace tm)) (s6 : Tm) ,
        ((substTm (weakenTrace (XS tm d3) k6) s6 (shiftTm (weakenCutofftm C0 k6) s5)) =
        (shiftTm (weakenCutofftm C0 k6) (substTm (weakenTrace d3 k6) s6 s5))))) (fun (x11 : (Index tm)) =>
      (fun (k6 : Hvl) (d3 : (Trace tm)) (s5 : Tm) =>
        (substIndex_shiftTm0_comm_ind d3 s5 k6 x11))) (fun (k6 : Hvl) (d3 : (Trace tm)) (s5 : Tm) =>
      eq_refl) (fun (T : Ty) (t : Tm) IHt11 (k6 : Hvl) (d3 : (Trace tm)) (s5 : Tm) =>
      (f_equal2 abs eq_refl (eq_trans (f_equal3 substTm (weakenTrace_append tm (XS tm d3) k6 (HS tm H0)) eq_refl eq_refl) (eq_trans (IHt11 (HS tm k6) d3 s5) (f_equal2 shiftTm eq_refl (f_equal3 substTm (eq_sym (weakenTrace_append tm d3 k6 (HS tm H0))) eq_refl eq_refl)))))) (fun (t1 : Tm) IHt11 (t2 : Tm) IHt12 (k6 : Hvl) (d3 : (Trace tm)) (s5 : Tm) =>
      (f_equal2 app (IHt11 k6 d3 s5) (IHt12 k6 d3 s5)))).
  End SubstShiftCommInd.
  Section SubstShiftComm.
    Definition substTm_shiftTm0_comm (s6 : Tm) : (forall (d3 : (Trace tm)) (s5 : Tm) ,
      ((substTm (XS tm d3) s5 (shiftTm C0 s6)) =
      (shiftTm C0 (substTm d3 s5 s6)))) := (subst_shift0_Tm_comm_ind s6 H0).
  End SubstShiftComm.
  Section SubstSubordInd.

  End SubstSubordInd.
  Section SubstSubord.

  End SubstSubord.
End ShiftSubstInteraction.
 Hint Rewrite substTm0_shiftTm0_reflection : interaction.
 Hint Rewrite substTm0_shiftTm0_reflection : reflection.
 Hint Rewrite substTm_shiftTm0_comm : interaction.
 Hint Rewrite substTm_shiftTm0_comm : subst_shift0.
 Hint Rewrite shiftTm_substTm0_comm : interaction.
 Hint Rewrite shiftTm_substTm0_comm : shift_subst0.
Section SubstSubstInteraction.
  Section SubstSubstIndexCommInd.
    Lemma substTm_substIndex0_commright_ind (d3 : (Trace tm)) (s5 : Tm) (s6 : Tm) :
      (forall (k6 : Hvl) (x11 : (Index tm)) ,
        ((substTm (weakenTrace d3 k6) s5 (substIndex (weakenTrace X0 k6) s6 x11)) =
        (substTm (weakenTrace X0 k6) (substTm d3 s5 s6) (substIndex (weakenTrace (XS tm d3) k6) s5 x11)))).
    Proof.
      needleGenericSubstSubstIndexCommInd .
    Qed.
  End SubstSubstIndexCommInd.
  Section SubstSubstCommInd.
    Definition subst_subst0_Tm_comm_ind := (ind_Tm (fun (s7 : Tm) =>
      (forall (k7 : Hvl) (d4 : (Trace tm)) (s8 : Tm) (s9 : Tm) ,
        ((substTm (weakenTrace d4 k7) s8 (substTm (weakenTrace X0 k7) s9 s7)) =
        (substTm (weakenTrace X0 k7) (substTm d4 s8 s9) (substTm (weakenTrace (XS tm d4) k7) s8 s7))))) (fun (x14 : (Index tm)) =>
      (fun (k7 : Hvl) (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) =>
        (substTm_substIndex0_commright_ind d4 s7 s8 k7 x14))) (fun (k7 : Hvl) (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) =>
      eq_refl) (fun (T : Ty) (t : Tm) IHt14 (k7 : Hvl) (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) =>
      (f_equal2 abs eq_refl (eq_trans (f_equal3 substTm (weakenTrace_append tm d4 k7 (HS tm H0)) eq_refl (f_equal3 substTm (weakenTrace_append tm X0 k7 (HS tm H0)) eq_refl eq_refl)) (eq_trans (IHt14 (HS tm k7) d4 s7 s8) (f_equal3 substTm (eq_sym (weakenTrace_append tm X0 k7 (HS tm H0))) eq_refl (f_equal3 substTm (eq_sym (weakenTrace_append tm (XS tm d4) k7 (HS tm H0))) eq_refl eq_refl)))))) (fun (t1 : Tm) IHt14 (t2 : Tm) IHt15 (k7 : Hvl) (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) =>
      (f_equal2 app (IHt14 k7 d4 s7 s8) (IHt15 k7 d4 s7 s8)))).
  End SubstSubstCommInd.
  Section SubstSubstComm.
    Definition substTm_substTm0_comm (s9 : Tm) : (forall (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) ,
      ((substTm d4 s7 (substTm X0 s8 s9)) =
      (substTm X0 (substTm d4 s7 s8) (substTm (XS tm d4) s7 s9)))) := (subst_subst0_Tm_comm_ind s9 H0).
  End SubstSubstComm.
  Section WeakenSubst.
    Lemma weakenTm_substTm  :
      (forall (k7 : Hvl) (d4 : (Trace tm)) (s7 : Tm) (s8 : Tm) ,
        ((weakenTm (substTm d4 s7 s8) k7) =
        (substTm (weakenTrace d4 k7) s7 (weakenTm s8 k7)))).
    Proof.
      needleGenericWeakenSubst .
    Qed.
  End WeakenSubst.
  Section WeakenAppend.
    Lemma weakenTy_append  :
      (forall (S0 : Ty) (k7 : Hvl) (k8 : Hvl) ,
        ((weakenTy (weakenTy S0 k7) k8) =
        (weakenTy S0 (appendHvl k7 k8)))).
    Proof.
      needleGenericWeakenAppend .
    Qed.
    Lemma weakenTm_append  :
      (forall (s7 : Tm) (k7 : Hvl) (k8 : Hvl) ,
        ((weakenTm (weakenTm s7 k7) k8) =
        (weakenTm s7 (appendHvl k7 k8)))).
    Proof.
      needleGenericWeakenAppend .
    Qed.
  End WeakenAppend.
End SubstSubstInteraction.
 Hint Rewrite substTm_substTm0_comm : interaction.
 Hint Rewrite substTm_substTm0_comm : subst_subst0.
 Hint Rewrite weakenTm_shiftTm : weaken_shift.
 Hint Rewrite weakenTm_substTm : weaken_subst.
Section WellFormed.
  Fixpoint wfindex {a : Namespace} (k7 : Hvl) (i : (Index a)) {struct k7} : Prop :=
    match k7 with
      | (H0) => False
      | (HS b k7) => match (eq_namespace_dec a b) with
        | (left e) => match i with
          | (I0) => True
          | (IS i) => (wfindex k7 i)
        end
        | (right n) => (wfindex k7 i)
      end
    end.
  Inductive wfTy (k7 : Hvl) : Ty -> Prop :=
    | wfTy_tunit :
        (wfTy k7 (tunit))
    | wfTy_tarr {T5 : Ty}
        (wf : (wfTy k7 T5)) {T6 : Ty}
        (wf0 : (wfTy k7 T6)) :
        (wfTy k7 (tarr T5 T6)).
  Inductive wfTm (k7 : Hvl) : Tm -> Prop :=
    | wfTm_var {x17 : (Index tm)}
        (wfi : (wfindex k7 x17)) :
        (wfTm k7 (var x17))
    | wfTm_tt : (wfTm k7 (tt))
    | wfTm_abs {T5 : Ty}
        (wf : (wfTy k7 T5)) {t17 : Tm}
        (wf0 : (wfTm (HS tm k7) t17)) :
        (wfTm k7 (abs T5 t17))
    | wfTm_app {t18 : Tm}
        (wf : (wfTm k7 t18)) {t19 : Tm}
        (wf0 : (wfTm k7 t19)) :
        (wfTm k7 (app t18 t19)).
  Scheme ind_wfTy := Induction for wfTy Sort Prop.
  Scheme ind_wfTm := Induction for wfTm Sort Prop.
End WellFormed.
Section ShiftWellFormed.
  Inductive shifthvl_tm : (forall (c2 : (Cutoff tm)) (k7 : Hvl) (k8 : Hvl) ,
    Prop) :=
    | shifthvl_tm_here (k7 : Hvl)
        : (shifthvl_tm C0 k7 (HS tm k7))
    | shifthvl_tm_there_tm
        (c2 : (Cutoff tm)) (k7 : Hvl)
        (k8 : Hvl) :
        (shifthvl_tm c2 k7 k8) -> (shifthvl_tm (CS c2) (HS tm k7) (HS tm k8)).
  Lemma weaken_shifthvl_tm  :
    (forall (k7 : Hvl) {c2 : (Cutoff tm)} {k8 : Hvl} {k9 : Hvl} ,
      (shifthvl_tm c2 k8 k9) -> (shifthvl_tm (weakenCutofftm c2 k7) (appendHvl k8 k7) (appendHvl k9 k7))).
  Proof.
    needleGenericWeakenHVarlistInsert .
  Qed.
  Lemma shift_wfindex_tm  :
    (forall (c2 : (Cutoff tm)) (k7 : Hvl) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) (x17 : (Index tm)) ,
      (wfindex k7 x17) -> (wfindex k8 (shiftIndex c2 x17))).
  Proof.
    needleGenericShiftWellFormedIndex .
  Qed.
  Definition shift_wfTy : (forall (k7 : Hvl) ,
    (forall (S0 : Ty) (wf : (wfTy k7 S0)) ,
      (forall (c2 : (Cutoff tm)) (k8 : Hvl) ,
        (shifthvl_tm c2 k7 k8) -> (wfTy k8 S0)))) := (fun (k7 : Hvl) =>
    (ind_wfTy k7 (fun (S0 : Ty) (wf : (wfTy k7 S0)) =>
      (forall (c2 : (Cutoff tm)) (k8 : Hvl) ,
        (shifthvl_tm c2 k7 k8) -> (wfTy k8 S0))) (fun (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
      (wfTy_tunit k8)) (fun (T1 : Ty) (wf : (wfTy k7 T1)) IHT1 (T2 : Ty) (wf0 : (wfTy k7 T2)) IHT2 (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
      (wfTy_tarr k8 (IHT1 c2 k8 (weaken_shifthvl_tm H0 ins)) (IHT2 c2 k8 (weaken_shifthvl_tm H0 ins)))))).
  Definition shift_wfTm : (forall (k7 : Hvl) ,
    (forall (s7 : Tm) (wf : (wfTm k7 s7)) ,
      (forall (c2 : (Cutoff tm)) (k8 : Hvl) ,
        (shifthvl_tm c2 k7 k8) -> (wfTm k8 (shiftTm c2 s7))))) := (ind_wfTm (fun (k7 : Hvl) (s7 : Tm) (wf : (wfTm k7 s7)) =>
    (forall (c2 : (Cutoff tm)) (k8 : Hvl) ,
      (shifthvl_tm c2 k7 k8) -> (wfTm k8 (shiftTm c2 s7)))) (fun (k7 : Hvl) (x17 : (Index tm)) (wfi : (wfindex k7 x17)) (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
    (wfTm_var k8 (shift_wfindex_tm c2 k7 k8 ins x17 wfi))) (fun (k7 : Hvl) (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
    (wfTm_tt k8)) (fun (k7 : Hvl) (T : Ty) (wf : (wfTy k7 T)) (t : Tm) (wf0 : (wfTm (HS tm k7) t)) IHt17 (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
    (wfTm_abs k8 (shift_wfTy k7 T wf c2 k8 (weaken_shifthvl_tm H0 ins)) (IHt17 (CS c2) (HS tm k8) (weaken_shifthvl_tm (HS tm H0) ins)))) (fun (k7 : Hvl) (t1 : Tm) (wf : (wfTm k7 t1)) IHt17 (t2 : Tm) (wf0 : (wfTm k7 t2)) IHt18 (c2 : (Cutoff tm)) (k8 : Hvl) (ins : (shifthvl_tm c2 k7 k8)) =>
    (wfTm_app k8 (IHt17 c2 k8 (weaken_shifthvl_tm H0 ins)) (IHt18 c2 k8 (weaken_shifthvl_tm H0 ins))))).
End ShiftWellFormed.
 Hint Resolve shift_wfindex_tm : infra.
 Hint Resolve shift_wfindex_tm : shift.
 Hint Resolve shift_wfindex_tm : shift_wf.
 Hint Resolve shift_wfindex_tm : wf.
 Hint Resolve shift_wfTm shift_wfTy : infra.
 Hint Resolve shift_wfTm shift_wfTy : shift.
 Hint Resolve shift_wfTm shift_wfTy : shift_wf.
 Hint Resolve shift_wfTm shift_wfTy : wf.
 Hint Constructors shifthvl_tm : infra.
 Hint Constructors shifthvl_tm : shift.
 Hint Constructors shifthvl_tm : shift_wf.
 Hint Constructors shifthvl_tm : wf.
 Hint Resolve weaken_shifthvl_tm : infra.
 Hint Resolve weaken_shifthvl_tm : shift.
 Hint Resolve weaken_shifthvl_tm : shift_wf.
 Hint Resolve weaken_shifthvl_tm : weaken.
 Hint Resolve weaken_shifthvl_tm : wf.
Section SubstWellFormed.
  Inductive substhvl_tm (k7 : Hvl) : (forall (d4 : (Trace tm)) (k8 : Hvl) (k9 : Hvl) ,
    Prop) :=
    | substhvl_tm_here :
        (substhvl_tm k7 X0 (HS tm k7) k7)
    | substhvl_tm_there_tm
        {d4 : (Trace tm)} {k8 : Hvl}
        {k9 : Hvl} :
        (substhvl_tm k7 d4 k8 k9) -> (substhvl_tm k7 (XS tm d4) (HS tm k8) (HS tm k9)).
  Lemma weaken_substhvl_tm  :
    (forall {k8 : Hvl} (k7 : Hvl) {d4 : (Trace tm)} {k9 : Hvl} {k10 : Hvl} ,
      (substhvl_tm k8 d4 k9 k10) -> (substhvl_tm k8 (weakenTrace d4 k7) (appendHvl k9 k7) (appendHvl k10 k7))).
  Proof.
    needleGenericWeakenSubstHvl .
  Qed.
  Lemma substhvl_tm_wfindex_tm {k7 : Hvl} {s7 : Tm} (wft : (wfTm k7 s7)) :
    (forall {d4 : (Trace tm)} {k8 : Hvl} {k9 : Hvl} ,
      (substhvl_tm k7 d4 k8 k9) -> (forall {x17 : (Index tm)} ,
        (wfindex k8 x17) -> (wfTm k9 (substIndex d4 s7 x17)))).
  Proof.
    needleGenericSubstHvlWfIndexHom .
  Qed.
  Definition substhvl_tm_wfTy {k7 : Hvl} : (forall (k8 : Hvl) ,
    (forall (S0 : Ty) (wf0 : (wfTy k8 S0)) ,
      (forall {d4 : (Trace tm)} {k9 : Hvl} ,
        (substhvl_tm k7 d4 k8 k9) -> (wfTy k9 S0)))) := (fun (k8 : Hvl) =>
    (ind_wfTy k8 (fun (S0 : Ty) (wf0 : (wfTy k8 S0)) =>
      (forall {d4 : (Trace tm)} {k9 : Hvl} ,
        (substhvl_tm k7 d4 k8 k9) -> (wfTy k9 S0))) (fun {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
      (wfTy_tunit k9)) (fun (T1 : Ty) (wf0 : (wfTy k8 T1)) IHT1 (T2 : Ty) (wf1 : (wfTy k8 T2)) IHT2 {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
      (wfTy_tarr k9 (IHT1 (weakenTrace d4 H0) k9 (weaken_substhvl_tm H0 del)) (IHT2 (weakenTrace d4 H0) k9 (weaken_substhvl_tm H0 del)))))).
  Definition substhvl_tm_wfTm {k7 : Hvl} {s7 : Tm} (wf : (wfTm k7 s7)) : (forall (k8 : Hvl) ,
    (forall (s8 : Tm) (wf0 : (wfTm k8 s8)) ,
      (forall {d4 : (Trace tm)} {k9 : Hvl} ,
        (substhvl_tm k7 d4 k8 k9) -> (wfTm k9 (substTm d4 s7 s8))))) := (ind_wfTm (fun (k8 : Hvl) (s8 : Tm) (wf0 : (wfTm k8 s8)) =>
    (forall {d4 : (Trace tm)} {k9 : Hvl} ,
      (substhvl_tm k7 d4 k8 k9) -> (wfTm k9 (substTm d4 s7 s8)))) (fun (k8 : Hvl) {x17 : (Index tm)} (wfi : (wfindex k8 x17)) {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
    (substhvl_tm_wfindex_tm wf del wfi)) (fun (k8 : Hvl) {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
    (wfTm_tt k9)) (fun (k8 : Hvl) (T : Ty) (wf0 : (wfTy k8 T)) (t : Tm) (wf1 : (wfTm (HS tm k8) t)) IHt17 {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
    (wfTm_abs k9 (substhvl_tm_wfTy k8 T wf0 (weaken_substhvl_tm H0 del)) (IHt17 (weakenTrace d4 (HS tm H0)) (HS tm k9) (weaken_substhvl_tm (HS tm H0) del)))) (fun (k8 : Hvl) (t1 : Tm) (wf0 : (wfTm k8 t1)) IHt17 (t2 : Tm) (wf1 : (wfTm k8 t2)) IHt18 {d4 : (Trace tm)} {k9 : Hvl} (del : (substhvl_tm k7 d4 k8 k9)) =>
    (wfTm_app k9 (IHt17 (weakenTrace d4 H0) k9 (weaken_substhvl_tm H0 del)) (IHt18 (weakenTrace d4 H0) k9 (weaken_substhvl_tm H0 del))))).
End SubstWellFormed.
 Hint Resolve substhvl_tm_wfindex_tm : infra.
 Hint Resolve substhvl_tm_wfindex_tm : subst.
 Hint Resolve substhvl_tm_wfindex_tm : subst_wf.
 Hint Resolve substhvl_tm_wfindex_tm : wf.
 Hint Resolve substhvl_tm_wfTm substhvl_tm_wfTy : infra.
 Hint Resolve substhvl_tm_wfTm substhvl_tm_wfTy : subst.
 Hint Resolve substhvl_tm_wfTm substhvl_tm_wfTy : subst_wf.
 Hint Resolve substhvl_tm_wfTm substhvl_tm_wfTy : wf.
 Hint Constructors substhvl_tm : infra.
 Hint Constructors substhvl_tm : subst.
 Hint Constructors substhvl_tm : subst_wf.
 Hint Constructors substhvl_tm : wf.
Section Context.
  Inductive Env : Type :=
    | empty
    | evar (G : Env) (T : Ty).
  Fixpoint appendEnv (G : Env) (G0 : Env) : Env :=
    match G0 with
      | (empty) => G
      | (evar G1 T) => (evar (appendEnv G G1) T)
    end.
  Fixpoint domainEnv (G : Env) : Hvl :=
    match G with
      | (empty) => H0
      | (evar G0 T) => (HS tm (domainEnv G0))
    end.
  Lemma appendEnv_assoc  :
    (forall (G : Env) (G0 : Env) (G1 : Env) ,
      ((appendEnv G (appendEnv G0 G1)) =
      (appendEnv (appendEnv G G0) G1))).
  Proof.
    needleGenericAppendEnvAssoc .
  Qed.
  Lemma domainEnv_appendEnv  :
    (forall (G : Env) (G0 : Env) ,
      ((domainEnv (appendEnv G G0)) =
      (appendHvl (domainEnv G) (domainEnv G0)))).
  Proof.
    needleGenericDomainEnvAppendEnv .
  Qed.
  Fixpoint shiftEnv (c2 : (Cutoff tm)) (G : Env) : Env :=
    match G with
      | (empty) => empty
      | (evar G0 T) => (evar (shiftEnv c2 G0) T)
    end.
  Fixpoint substEnv (d4 : (Trace tm)) (s7 : Tm) (G : Env) : Env :=
    match G with
      | (empty) => empty
      | (evar G0 T) => (evar (substEnv d4 s7 G0) T)
    end.
  Lemma domainEnv_shiftEnv  :
    (forall (c2 : (Cutoff tm)) (G : Env) ,
      ((domainEnv (shiftEnv c2 G)) =
      (domainEnv G))).
  Proof.
    needleGenericDomainEnvShiftEnv .
  Qed.
  Lemma domainEnv_substEnv  :
    (forall (d4 : (Trace tm)) (s7 : Tm) (G : Env) ,
      ((domainEnv (substEnv d4 s7 G)) =
      (domainEnv G))).
  Proof.
    needleGenericDomainEnvSubstEnv .
  Qed.
End Context.
 Hint Rewrite domainEnv_appendEnv : interaction.
 Hint Rewrite domainEnv_appendEnv : env_domain_append.
Section ContextStuff.
  Section ShiftEnvAppendEnv.
    Lemma shiftEnv_appendEnv  :
      (forall (c2 : (Cutoff tm)) (G : Env) (G0 : Env) ,
        ((shiftEnv c2 (appendEnv G G0)) =
        (appendEnv (shiftEnv c2 G) (shiftEnv (weakenCutofftm c2 (domainEnv G)) G0)))).
    Proof.
      needleGenericShiftEnvAppendEnv .
    Qed.
  End ShiftEnvAppendEnv.
  Section SubstEnvAppendEnv.
    Lemma substEnv_appendEnv  :
      (forall (d4 : (Trace tm)) (s7 : Tm) (G : Env) (G0 : Env) ,
        ((substEnv d4 s7 (appendEnv G G0)) =
        (appendEnv (substEnv d4 s7 G) (substEnv (weakenTrace d4 (domainEnv G)) s7 G0)))).
    Proof.
      needleGenericSubstEnvAppendEnv .
    Qed.
  End SubstEnvAppendEnv.
  Section Lookups.
    Inductive lookup_evar : Env -> (Index tm) -> Ty -> Prop :=
      | lookup_evar_here {G : Env}
          {T5 : Ty} :
          (wfTy (domainEnv G) T5) -> (lookup_evar (evar G T5) I0 T5)
      | lookup_evar_there_evar
          {G : Env} {x17 : (Index tm)}
          {T5 : Ty} {T6 : Ty} :
          (lookup_evar G x17 T5) -> (lookup_evar (evar G T6) (IS x17) T5).
    Lemma lookup_evar_inversion_here  :
      (forall (G : Env) (S0 : Ty) (S1 : Ty) ,
        (lookup_evar (evar G S0) I0 S1) -> (S0 =
        S1)).
    Proof.
      needleGenericLookupInversion .
    Qed.
    Lemma lookup_evar_functional  :
      (forall {G : Env} {x17 : (Index tm)} ,
        (forall {S0 : Ty} ,
          (lookup_evar G x17 S0) -> (forall {S1 : Ty} ,
            (lookup_evar G x17 S1) -> (S0 =
            S1)))).
    Proof.
      needleGenericLookupFunctional .
    Qed.
    Lemma lookup_evar_wf  :
      (forall {G : Env} {x17 : (Index tm)} {S0 : Ty} ,
        (lookup_evar G x17 S0) -> (wfTy (domainEnv G) S0)).
    Proof.
      needleGenericLookupWellformedData .
    Qed.
    Lemma weaken_lookup_evar  :
      (forall {G : Env} (G0 : Env) {x17 : (Index tm)} {T5 : Ty} ,
        (lookup_evar G x17 T5) -> (lookup_evar (appendEnv G G0) (weakenIndextm x17 (domainEnv G0)) (weakenTy T5 (domainEnv G0)))).
    Proof.
      needleGenericWeakenLookup .
    Qed.
    Lemma lookup_evar_wfindex  :
      (forall {G : Env} {x17 : (Index tm)} {S0 : Ty} ,
        (lookup_evar G x17 S0) -> (wfindex (domainEnv G) x17)).
    Proof.
      needleGenericLookupWellformedIndex .
    Qed.
  End Lookups.
  Inductive shift_evar : (Cutoff tm) -> Env -> Env -> Prop :=
    | shift_evar_here {G : Env}
        {T5 : Ty} :
        (shift_evar C0 G (evar G T5))
    | shiftevar_there_evar
        {c2 : (Cutoff tm)} {G : Env}
        {G0 : Env} {T : Ty} :
        (shift_evar c2 G G0) -> (shift_evar (CS c2) (evar G T) (evar G0 T)).
  Lemma weaken_shift_evar  :
    (forall (G : Env) {c2 : (Cutoff tm)} {G0 : Env} {G1 : Env} ,
      (shift_evar c2 G0 G1) -> (shift_evar (weakenCutofftm c2 (domainEnv G)) (appendEnv G0 G) (appendEnv G1 G))).
  Proof.
    needleGenericWeakenInsertEnv .
  Qed.
  Lemma shift_evar_shifthvl_tm  :
    (forall {c2 : (Cutoff tm)} {G : Env} {G0 : Env} ,
      (shift_evar c2 G G0) -> (shifthvl_tm c2 (domainEnv G) (domainEnv G0))).
  Proof.
    needleGenericInsertEnvInsertHvl .
  Qed.
  Inductive subst_evar (G : Env) (T5 : Ty) (s7 : Tm) : (Trace tm) -> Env -> Env -> Prop :=
    | subst_evar_here :
        (subst_evar G T5 s7 X0 (evar G T5) G)
    | subst_evar_there_evar
        {d4 : (Trace tm)} {G0 : Env}
        {G1 : Env} {T : Ty} :
        (subst_evar G T5 s7 d4 G0 G1) -> (subst_evar G T5 s7 (XS tm d4) (evar G0 T) (evar G1 T)).
  Lemma weaken_subst_evar {G : Env} {T5 : Ty} {s7 : Tm} :
    (forall (G0 : Env) {d4 : (Trace tm)} {G1 : Env} {G2 : Env} ,
      (subst_evar G T5 s7 d4 G1 G2) -> (subst_evar G T5 s7 (weakenTrace d4 (domainEnv G0)) (appendEnv G1 G0) (appendEnv G2 G0))).
  Proof.
    needleGenericWeakenSubstEnv .
  Qed.
  Lemma subst_evar_substhvl_tm {G : Env} {s7 : Tm} {T5 : Ty} :
    (forall {d4 : (Trace tm)} {G0 : Env} {G1 : Env} ,
      (subst_evar G T5 s7 d4 G0 G1) -> (substhvl_tm (domainEnv G) d4 (domainEnv G0) (domainEnv G1))).
  Proof.
    needleGenericSubstEnvSubstHvl .
  Qed.
End ContextStuff.
 Hint Constructors lookup_evar : infra.
 Hint Constructors lookup_evar : lookup.
 Hint Constructors lookup_evar : shift.
 Hint Constructors lookup_evar : subst.
 Hint Resolve weaken_lookup_evar : infra.
 Hint Resolve weaken_lookup_evar : lookup.
 Hint Resolve weaken_lookup_evar : shift.
 Hint Resolve weaken_lookup_evar : weaken.
Lemma weaken_lookup_evar_here  :
  (forall {G : Env} (G0 : Env) {T5 : Ty} (wf : (wfTy (domainEnv G) T5)) ,
    (lookup_evar (appendEnv (evar G T5) G0) (weakenIndextm I0 (domainEnv G0)) (weakenTy T5 (domainEnv G0)))).
Proof.
  eauto with lookup .
Qed.
 Hint Constructors wfTm wfTy : infra.
 Hint Constructors wfTm wfTy : wf.
 Hint Extern 10 ((wfTm _ _)) => autorewrite with env_domain_append in *  : infra wf.
 Hint Extern 10 ((wfTy _ _)) => autorewrite with env_domain_append in *  : infra wf.
 Hint Extern 2 ((wfTy _ _)) => match goal with
  | H : (wfTy _ (tunit)) |- _ => inversion H; subst; clear H
  | H : (wfTy _ (tarr _ _)) |- _ => inversion H; subst; clear H
end : infra wf.
 Hint Extern 2 ((wfTm _ _)) => match goal with
  | H : (wfTm _ (var _)) |- _ => inversion H; subst; clear H
  | H : (wfTm _ (tt)) |- _ => inversion H; subst; clear H
  | H : (wfTm _ (abs _ _)) |- _ => inversion H; subst; clear H
  | H : (wfTm _ (app _ _)) |- _ => inversion H; subst; clear H
end : infra wf.
 Hint Resolve lookup_evar_wf : infra.
 Hint Resolve lookup_evar_wf : wf.
 Hint Resolve lookup_evar_wfindex : infra.
 Hint Resolve lookup_evar_wfindex : lookup.
 Hint Resolve lookup_evar_wfindex : wf.
 Hint Constructors shift_evar : infra.
 Hint Constructors shift_evar : shift.
 Hint Constructors shift_evar : subst.
 Hint Resolve weaken_shift_evar : infra.
 Hint Resolve weaken_shift_evar : shift.
 Hint Resolve shift_evar_shifthvl_tm : infra.
 Hint Resolve shift_evar_shifthvl_tm : shift.
 Hint Resolve shift_evar_shifthvl_tm : shift_wf.
 Hint Resolve shift_evar_shifthvl_tm : wf.
 Hint Constructors subst_evar : infra.
 Hint Constructors subst_evar : subst.
 Hint Resolve weaken_subst_evar : infra.
 Hint Resolve weaken_subst_evar : subst.
 Hint Resolve subst_evar_substhvl_tm : infra.
 Hint Resolve subst_evar_substhvl_tm : subst.
 Hint Resolve subst_evar_substhvl_tm : subst_wf.
 Hint Resolve subst_evar_substhvl_tm : wf.
 Hint Resolve subst_evar_substhvl_tm : substenv_substhvl.
Lemma shift_evar_lookup_evar  :
  (forall {c2 : (Cutoff tm)} {G : Env} {G0 : Env} (ins : (shift_evar c2 G G0)) {x17 : (Index tm)} {T5 : Ty} ,
    (lookup_evar G x17 T5) -> (lookup_evar G0 (shiftIndex c2 x17) T5)).
Proof.
  needleGenericInsertLookup .
Qed.
 Hint Resolve shift_evar_lookup_evar : infra.
 Hint Resolve shift_evar_lookup_evar : lookup.
 Hint Resolve shift_evar_lookup_evar : shift.
Fixpoint size_Ty (S0 : Ty) {struct S0} : nat :=
  match S0 with
    | (tunit) => 1
    | (tarr T1 T2) => (plus 1 (plus (size_Ty T1) (size_Ty T2)))
  end.
Fixpoint size_Tm (s : Tm) {struct s} : nat :=
  match s with
    | (var x) => 1
    | (tt) => 1
    | (abs T t) => (plus 1 (plus (size_Ty T) (size_Tm t)))
    | (app t1 t2) => (plus 1 (plus (size_Tm t1) (size_Tm t2)))
  end.
Lemma shift_size_Tm  :
  (forall (s7 : Tm) (c1 : (Cutoff tm)) ,
    ((size_Tm (shiftTm c1 s7)) =
    (size_Tm s7))).
Proof.
  apply_mutual_ind ind_Tm.
  - intros x15 c1.
  reflexivity.
  - intros c2; simpl; apply ((f_equal S)); reflexivity.
  - intros T4 t14 IHt14.
  intros c2; simpl; apply ((f_equal S)); repeat (apply ((f_equal2 plus))).
  + reflexivity.
  + exact ((IHt14 (CS c2))).
  - intros t15 IHt15 t16 IHt16.
  intros c2; simpl; apply ((f_equal S)); repeat (apply ((f_equal2 plus))).
  + exact ((IHt15 c2)).
  + exact ((IHt16 c2)).
Qed.

 Hint Rewrite shift_size_Tm : interaction.
 Hint Rewrite shift_size_Tm : shift_size.
Lemma weaken_size_Tm  :
  (forall (k7 : Hvl) (s7 : Tm) ,
    ((size_Tm (weakenTm s7 k7)) =
    (size_Tm s7))).
Proof.
  needleGenericWeakenSize .
Qed.
Lemma weaken_size_Ty  :
  (forall (k7 : Hvl) (S0 : Ty) ,
    ((size_Ty (weakenTy S0 k7)) =
    (size_Ty S0))).
Proof.
  needleGenericWeakenSize .
Qed.
 Hint Rewrite weaken_size_Tm weaken_size_Ty : interaction.
 Hint Rewrite weaken_size_Tm weaken_size_Ty : weaken_size.


Require Export Derivation.

Module ElimU.

  Import Base Lists Definitions Symbols Derivation.

  Section ElimU.

    Context {Tt Vt: Type}.
    Context {Tt_eqdec: eq_dec Tt}.
    Context {Vt_eqdec: eq_dec Vt}.

    (** alternative definiton of Domain, with other type than dom *)
    Fixpoint domV (G: @grammar Tt Vt) : list var :=
      match G with
          [] => []
        | R A u :: Gr => A :: domV Gr
      end.

    Lemma dom_domV (G: @grammar Tt Vt) A :
      A el (domV G) <-> Vs A el (dom G).
    Proof.
      induction G as [| [B u] Gr] ; simpl ; [tauto|].
      rewrite IHGr. split ; intros [H | H] ; try inv H ; auto.
    Qed.

    Lemma rule_domVG G A u :
      R A u el G -> A el domV G.
    Proof.
      rewrite dom_domV.
      apply rule_domG.
    Qed.

    Lemma domVG_rule G A :
      A el (domV G) -> exists u, R A u el G.
    Proof.
      intros H.
      apply dom_domV, domG_rule in H.
      destruct H as [A' [u [H0 H1]]].
      exists u. now inv H0.
    Qed.

    (** * Elimination of Unit Rules *)

    Definition unitfree (G: @grammar Tt Vt) := forall A, ~ exists B, R A [Vs B] el G.

    Section UnitRules.
      Variable G : @grammar Tt Vt.

      Definition rules (u : list var) (v : list phrase) := product (@R Tt Vt) u v.
      Definition N : grammar := rules (domV G) (ran G).

      Definition step M s :=
        match s with
            R A u => (~ (exists B, u = [Vs B]) /\ R A u el G)
                    \/ (exists B, R A [Vs B] el G /\ R B u el M)
        end.

      Global Instance step_dec' G' M A u : dec (exists B, (@R Tt Vt) A [Vs B] el G' /\ (@R Tt Vt) B u el M).
      Proof.
        induction M as [| [C w] Mr IHMr].
        - right. intros [B [H0 []]].
        - destruct IHMr as [IH | IH].
          + left. destruct IH as [B [H0 H1]].
            exists B. split ; auto.
          + decide (R A [Vs C] el G' /\ w = u) as [D | D].
            * left. exists C. destruct D as [D0 D1]. rewrite D1. split ; auto.
            * right. intros [B [H0 [H1 | H1]]].
              { apply D. inv H1. auto. }
              { apply IH. exists B. split ; auto. }
      Defined.

      Global Instance step_dec M s : dec (step M s).
      Proof.
        destruct s as [A u].
        simpl. induction G as [| [B v] Gr IHGr].
        - right. intros [[H0 H1] | [B [H1 H2]]] ; try now inv H1.
        - destruct IHGr as [IH | IH].
          + left. destruct IH as [[IH0 IH1] | [C [IH0 IH1]]].
            * left. split ; auto.
            * right. exists C. split ; auto.
          + decide (R A u = R B v /\ ~ (exists C, u = [Vs C])) as [D | D].
            * left. destruct D as [H0 H1].
              left. inv H0. split ; auto.
            * decide (exists B0 : var, R A [Vs B0] el R B v :: Gr /\ R B0 u el M) as [D0 | D0].
              { left. now right. }
              { right. intros [[H0 [H1 | H1]] | H0] ; try inv H1 ; try split ; auto. }
      Defined.

      Definition elimU : grammar :=  FCI.C (step := step) N.

      (** ** elimU is unit-free *)

      Lemma unitfree_elimU' :
        inclp elimU (fun i => match i with R A u => ~ exists B, u = [Vs B] end).
      Proof.
        apply FCI.ind.
        intros M [A u] Icl VG S.
        destruct S as [[S0 S1] | [C [S0 S1]]] ; [|specialize (Icl (R C u) S1) ; simpl] ; auto.
      Qed.

      Lemma unitfree_elimU :
        unitfree elimU.
      Proof.
        intros A [B H]. apply (unitfree_elimU' H). now (exists B).
      Qed.

      (** ** elimU preserves languages *)
      Lemma elimU_corr A u :
        R A u el G -> (~ exists B, u = [Vs B]) -> R A u el elimU.
      Proof.
        intros H0 H1.
        apply FCI.closure.
        - apply prod_corr. exists A, u.
          repeat split ; eauto using rule_domVG, rule_ranG.
        - left. split ; auto.
      Qed.

      Lemma ran_elimU_G u :
        u el ran elimU -> u el ran G.
      Proof.
        intros H.
        apply ranG_rule in H. destruct H as [A H].
        unfold elimU in H. apply FCI.incl, prod_corr in H.
        destruct H as [? [? [H0 [_ ?]]]]. now inv H0.
      Qed.

      Lemma elimU_corr2 A B u :
        R A [Vs B] el G -> R B u el elimU -> R A u el elimU.
      Proof.
        intros H0 H1.
        apply FCI.closure.
        - apply prod_corr.
          exists A, u. repeat split ; auto.
          + eapply rule_domVG ; eauto.
          + apply rule_ranG in H1. now apply ran_elimU_G in H1.
        - simpl. right. exists B. split ; auto.
      Qed.

      (* TODO: del *)
      Hint Constructors derf.
      (** rules in elimU can be simulated by a derivation *)
      Lemma elimU_corr3' :
        inclp elimU (fun i => match i with R A u => derf G [Vs A] u end).
      Proof.
        unfold elimU. apply FCI.ind.
        intros M [A u] Icl V S.
        destruct S as [[S0 S1] | [B [S0 S1]]] ; [|specialize (Icl (R B u) S1)] ; eauto.
      Qed.

      Lemma elimU_corr3 A u :
        R A u el elimU -> derf G [Vs A] u.
      Proof. intros elimU. exact (elimU_corr3' elimU). Qed.

      (** completeness of derivability *)
      Lemma derfG_derfelimU u v :
        terminal v -> derf G u v -> derf elimU u v.
      Proof.
        intros T D.
        induction D as [| A u v H H0 IHD|] ; auto.
        - specialize (IHD T).
          decide (exists B, u = [Vs B]) as [D | D].
          + destruct D as [B U'].
            assert (H1 : exists v', R B v' el elimU /\ derf elimU v' v).
            { induction IHD as [| | ? ? ? ? IH0 IHD0 IH1 IHD1] ; subst.
              - assert (H1 : @Vs Tt Vt B el [Vs B]) by auto.
                destruct (T (Vs B) H1) as [t T']. inv T'.
              - exists u. split ; inv U' ; auto.
              - inv U'. inv IH1. rewrite app_nil_r in *. apply IHD0 ; auto. }
            destruct H1 as [v' [H1 H2]]. subst.
            apply (elimU_corr2 H) in H1 ; eauto.
          + apply elimU_corr in H ; eauto.
        - apply terminal_split in T.
          destruct T as [T0 T1]. eauto.
      Qed.

      (** soundness of derivability *)
      Lemma derfelimU_derfG u v :
        derf elimU u v -> derf G u v.
      Proof.
        induction 1 ; eauto using elimU_corr3, derf_trans.
      Qed.

      Lemma elimU_der_equiv u v :
        terminal v -> (derf G u v <-> derf elimU u v).
      Proof.
        intros H. split ; auto using derfelimU_derfG, derfG_derfelimU.
      Qed.

      Lemma unit_language A u :
        language G A u <-> language elimU A u.
      Proof.
        split ; intros [L0 L1] ; split ; auto ; apply derf_der_equiv ; apply derf_der_equiv in L0 ; [rewrite <- elimU_der_equiv | rewrite elimU_der_equiv] ; auto.
      Qed.

    End UnitRules.

  End ElimU.

End ElimU.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task_arrival
               prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.workload
               prosa.classic.model.schedule.uni.schedule.
Require Import prosa.classic.model.arrival.curves.bounds.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

Module MaxArrivalsWorkloadBound.

  Import Job ArrivalCurves TaskArrival Priority UniprocessorSchedule Workload Service.

  Section Lemmas.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence with consistent, non-duplicate arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arr_seq_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* Next, consider any uniprocessor schedule of this arrival sequence. *)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence: jobs_come_from_arrival_sequence sched arr_seq.

    (* Consider an FP policy that indicates a higher-or-equal priority relation. *)
    Variable higher_eq_priority: FP_policy Task.
    Let jlfp_higher_eq_priority := FP_to_JLFP job_task higher_eq_priority.

    (* For simplicity, let's define some local names. *)
    Let arrivals_between := jobs_arrived_between arr_seq.

    (* We define the notion of request bound function. *)
    Section RequestBoundFunction.

      (* Let max_arrivals denote any function that takes a task and an interval length
         and returns the associated number of job arrivals of the task. *)
      Variable max_arrivals: Task -> time -> nat.

      (* In this section, we define a bound for the workload of a single task
         under uniprocessor FP scheduling. *)
      Section SingleTask.

        (* Consider any task tsk that is to be scheduled in an interval of length delta. *)
        Variable tsk: Task.
        Variable delta: time.

        (* We define the following workload bound for the task. *)
        Definition task_request_bound_function := task_cost tsk * max_arrivals tsk delta.

      End SingleTask.

      (* In this section, we define a bound for the workload of multiple tasks. *)
      Section AllTasks.

        (* Consider a task set ts... *)
        Variable ts: list Task.

        (* ...and let tsk be any task in task set. *)
        Variable tsk: Task.

        (* Let delta be the length of the interval of interest. *)
        Variable delta: time.

        (* Recall the definition of higher-or-equal-priority task and
           the per-task workload bound for FP scheduling. *)
        Let is_hep_task tsk_other := higher_eq_priority tsk_other tsk.
        Let is_other_hep_task tsk_other := higher_eq_priority tsk_other tsk && (tsk_other != tsk).

        (* Using the sum of individual workload bounds, we define the following bound
           for the total workload of tasks in any interval of length delta. *)
        Definition total_request_bound_function :=
          \sum_(tsk <- ts) task_request_bound_function tsk delta.

        (* Similarly, we define the following bound for the total workload of tasks of
           higher-or-equal priority (with respect to tsk) in any interval of length delta. *)
        Definition total_hep_request_bound_function_FP :=
          \sum_(tsk_other <- ts | is_hep_task tsk_other)
           task_request_bound_function tsk_other delta.

        (* We also define bound for the total workload of higher-or-equal priority
           tasks other than tsk in any interval of length delta. *)
        Definition total_ohep_request_bound_function_FP :=
          \sum_(tsk_other <- ts | is_other_hep_task tsk_other)
           task_request_bound_function tsk_other delta.

      End AllTasks.

    End RequestBoundFunction.

    (* In this section we prove some lemmas about request bound functions. *)
    Section ProofWorkloadBound.

      (* Consider a task set ts... *)
      Variable ts: list Task.

      (* ...and let tsk be any task in ts. *)
      Variable tsk: Task.
      Hypothesis H_tsk_in_ts: tsk \in ts.

      (* Assume that a job cost cannot be larger than a task cost. *)
      Hypothesis H_job_cost_le_task_cost:
        forall j,
          arrives_in arr_seq j ->
          job_cost_le_task_cost task_cost job_cost job_task j.

      (* Next, we assume that all jobs come from the task set. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* Let max_arrivals be any arrival bound for taskset ts. *)
      Variable max_arrivals: Task -> time -> nat.
      Hypothesis H_is_arrival_bound:
        is_arrival_bound_for_taskset job_task arr_seq max_arrivals ts.

      (* Let's define some local names for clarity. *)
      Let task_rbf := task_request_bound_function max_arrivals tsk.
      Let total_rbf := total_request_bound_function max_arrivals ts.
      Let total_hep_rbf := total_hep_request_bound_function_FP max_arrivals ts tsk.
      Let total_ohep_rbf := total_ohep_request_bound_function_FP max_arrivals ts tsk.

      (* Next, we consider any job j of tsk. *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (* We define whether two jobs j1 and j2 are from the same task. *)
      Let same_task j1 j2 := job_task j1 == job_task j2.

      (* Next, we say that two jobs j1 and j2 are in relation other_higher_eq_priority, iff
         j1 has higher or equal priority than j2 and is produced by a different task. *)
      Let other_higher_eq_priority j1 j2 := jlfp_higher_eq_priority j1 j2 && (~~ same_task j1 j2).

      (* Next, we recall the notions of total workload of jobs... *)
      Let total_workload t1 t2 :=
        workload_of_jobs job_cost (arrivals_between t1 t2) (fun j => true).

      (* ...notions of workload of higher or equal priority jobs... *)
      Let total_hep_workload t1 t2 :=
        workload_of_jobs job_cost (arrivals_between t1 t2)
                         (fun j_other => jlfp_higher_eq_priority j_other j).

      (* ... workload of other higher or equal priority jobs... *)
      Let total_ohep_workload t1 t2 :=
        workload_of_jobs job_cost (arrivals_between t1 t2)
                         (fun j_other => other_higher_eq_priority j_other j).

      (* ... and the workload of jobs of the same task as job j. *)
      Let task_workload (t1: time) (t2: time) :=
        workload_of_jobs job_cost (arrivals_between t1 t2)
                         (fun j_other => same_task j_other j).

      (* In this section we prove that the workload of any jobs is
         no larger than the request bound function. *)
      Section WorkloadIsBoundedByRBF.

        (* Consider any time t and any interval of length delta. *)
        Variable t: time.
        Variable delta: time.

        (* First, we prove that workload of task is no larger
           than task request bound function. *)
        Lemma task_workload_le_task_rbf:
          task_workload t (t + delta) <= task_rbf delta.
        Proof.
          unfold task_workload.
          unfold task_rbf, task_request_bound_function.
          unfold is_arrival_bound in *.
          unfold arrivals_between.

          set l := jobs_arrived_between arr_seq t delta.
          apply leq_trans with (
            task_cost tsk * num_arrivals_of_task job_task arr_seq tsk t (t + delta)).
          {
            rewrite /num_arrivals_of_task -sum1_size big_distrr /= big_filter.
            rewrite -/l /workload_of_jobs.
            rewrite /is_job_of_task /same_task H_job_of_tsk muln1.
            apply leq_sum_seq; move => j0 IN0 /eqP EQ.
            rewrite -EQ.
            apply H_job_cost_le_task_cost.
              by apply in_arrivals_implies_arrived in IN0.
          }
          {
            rewrite leq_mul2l; apply/orP; right.
            rewrite -{2}[delta](addKn t).
            apply H_is_arrival_bound; first by done.
              by rewrite leq_addr.
          }
        Qed.

        (* Next, we prove that total workload of tasks is no larger
             than total request bound function. *)
        Lemma total_workload_le_total_rbf:
          total_ohep_workload t (t + delta) <= total_ohep_rbf delta.
        Proof.
          rewrite /total_ohep_rbf /total_ohep_request_bound_function_FP
                  /task_request_bound_function.
          rewrite /total_ohep_workload /workload_of_jobs
                  /other_higher_eq_priority.
          rewrite /jlfp_higher_eq_priority
                  /FP_to_JLFP /same_task H_job_of_tsk.
          rewrite /arrivals_between.

          set l := jobs_arrived_between arr_seq t (t + delta).
          set hep := higher_eq_priority.

          apply leq_trans with
          (\sum_(tsk' <- ts | hep tsk' tsk && (tsk' != tsk))
            (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
          {
            intros.
            have EXCHANGE :=
              exchange_big_dep
                (fun x => hep (job_task x) tsk && (job_task x != tsk)).
            rewrite EXCHANGE /=; last by move => tsk0 j0 HEP /eqP JOB0; rewrite JOB0.
            rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
            apply leq_sum; move => j0 /andP [IN0 HP0].
            rewrite big_mkcond (big_rem (job_task j0)) /=;
                    first by rewrite HP0 andTb eq_refl; apply leq_addr.
              by apply in_arrivals_implies_arrived in IN0;
              apply H_all_jobs_from_taskset.
          }
          apply leq_sum_seq; intros tsk0 INtsk0 HP0.
          apply leq_trans with (
            task_cost tsk0 * num_arrivals_of_task job_task arr_seq tsk0 t (t + delta)).
          {
            rewrite /num_arrivals_of_task -sum1_size big_distrr /= big_filter.
            rewrite -/l /workload_of_jobs.
            rewrite /is_job_of_task  muln1.
            apply leq_sum_seq; move => j0 IN0 /eqP EQ.
            rewrite -EQ.
            apply H_job_cost_le_task_cost.
              by apply in_arrivals_implies_arrived in IN0.
          }
          {
            rewrite leq_mul2l; apply/orP; right.
            rewrite -{2}[delta](addKn t).
            apply H_is_arrival_bound; first by done.
              by rewrite leq_addr.
          }
        Qed.

        Lemma total_workload_le_total_rbf':
          total_hep_workload t (t + delta) <= total_hep_rbf delta.
        Proof.
          intros.
          rewrite /total_hep_rbf /total_hep_request_bound_function_FP
                  /task_request_bound_function.
          rewrite /total_hep_workload /workload_of_jobs
                  /jlfp_higher_eq_priority /FP_to_JLFP /same_task H_job_of_tsk.
          rewrite /arrivals_between.

          set l := jobs_arrived_between arr_seq t (t + delta).
          set hep := higher_eq_priority.

          apply leq_trans with
          (n := \sum_(tsk' <- ts | hep tsk' tsk)
                 (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
          {
            intros.
            have EXCHANGE := exchange_big_dep (fun x => hep (job_task x) tsk).
            rewrite EXCHANGE /=; last by move => tsk0 j0 HEP /eqP JOB0; rewrite JOB0.
            rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
            apply leq_sum; move => j0 /andP [IN0 HP0].
            rewrite big_mkcond (big_rem (job_task j0)) /=;
                    first by rewrite HP0 andTb eq_refl; apply leq_addr.
              by apply in_arrivals_implies_arrived in IN0;
              apply H_all_jobs_from_taskset.
          }
          apply leq_sum_seq; intros tsk0 INtsk0 HP0.
          apply leq_trans with (
            task_cost tsk0 * num_arrivals_of_task job_task arr_seq tsk0 t (t + delta)).
          {
            rewrite /num_arrivals_of_task -sum1_size big_distrr /= big_filter.
            rewrite -/l /workload_of_jobs.
            rewrite /is_job_of_task  muln1.
            apply leq_sum_seq; move => j0 IN0 /eqP EQ.
            rewrite -EQ.
            apply H_job_cost_le_task_cost.
              by apply in_arrivals_implies_arrived in IN0.
          }
          {
            rewrite leq_mul2l; apply/orP; right.
            rewrite -{2}[delta](addKn t).
            apply H_is_arrival_bound; [by done | by rewrite leq_addr].
          }
        Qed.

        Lemma total_workload_le_total_rbf'':
          total_workload t (t + delta) <= total_rbf delta.
        Proof.
          intros.
          rewrite /total_rbf
                  /task_request_bound_function.
          rewrite /total_workload /workload_of_jobs.
          rewrite /arrivals_between.

          set l := jobs_arrived_between arr_seq t (t + delta).
          rewrite big_mkcond //=.

          apply leq_trans with
          (n := \sum_(tsk' <- ts)
                 (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
          {
            intros.
            have EXCHANGE := exchange_big_dep predT.
            rewrite EXCHANGE /=; last by done.
            rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
            apply leq_sum; move => j0 /andP [IN0 HP0].
            rewrite big_mkcond (big_rem (job_task j0)) /=.
            rewrite eq_refl; apply leq_addr.
              by apply in_arrivals_implies_arrived in IN0;
              apply H_all_jobs_from_taskset.
          }
          apply leq_sum_seq; intros tsk0 INtsk0 HP0.
          apply leq_trans with (
            task_cost tsk0 * num_arrivals_of_task job_task arr_seq tsk0 t (t + delta)).
          {
            rewrite /num_arrivals_of_task -sum1_size big_distrr /= big_filter.
            rewrite -/l /workload_of_jobs.
            rewrite /is_job_of_task  muln1.
            apply leq_sum_seq; move => j0 IN0 /eqP EQ.
            rewrite -EQ.
            apply H_job_cost_le_task_cost.
              by apply in_arrivals_implies_arrived in IN0.
          }
          {
            rewrite leq_mul2l; apply/orP; right.
            rewrite -{2}[delta](addKn t).
            apply H_is_arrival_bound; [by done | by rewrite leq_addr].
          }
        Qed.

      End WorkloadIsBoundedByRBF.

    End ProofWorkloadBound.

  End Lemmas.

End MaxArrivalsWorkloadBound.


Require Import Metalib.Metatheory.
(* verified in Coq 8.10.2 *)
(* requires The Penn Locally Nameless Metatheory Library, available via https://github.com/plclub/metalib *)

(** syntax *)
Definition i : Set := nat.

Inductive typ : Set :=  (* types *)
 | t_int : typ (* int *)
 | t_top : typ (* top *)
 | t_arrow (A:typ) (B:typ) (* function types *)
 | t_and (A:typ) (B:typ) (* intersection *).

Definition ctx : Set := list ( atom * typ ).

(* defns TopLikeType *)
Inductive topLike : typ -> Prop :=    (* defn topLike *)
 | TL_top :
     topLike t_top
 | TL_and : forall (A B:typ),
     topLike A ->
     topLike B ->
     topLike (t_and A B)
 | TL_arr : forall (A B:typ),
     topLike B ->
     topLike (t_arrow A B).

Inductive exp : Set :=  (* our expressions *)
 | e_var_b (_:nat) (* bound variables *)
 | e_var_f (x:var) (* free variables *)
 | e_top : exp (* top *)
 | e_lit (i5:i) (* lit *)
 | e_abs (A:typ) (e:exp) (B:typ) (* abstractions *)
 | e_fixpoint (e:exp) (A:typ) (* fixpoint *)
 | e_app (e1:exp) (e2:exp) (* applications *)
 | e_merge (e1:exp) (e2:exp) (* merge *)
 | e_anno (e:exp) (A:typ) (* annotation *).

(* opening up abstractions under locally nameless encoding *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e) B
  | (e_fixpoint e A) => e_fixpoint (open_exp_wrt_exp_rec (S k) e_5 e) A
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(* our system *)
(* defns Subtyping *)
Inductive sub : typ -> typ -> Prop :=    (* defn sub *)
 | S_z :
     sub t_int t_int
 | S_top : forall (A:typ),
     sub A t_top
 | S_toparr : forall (A B1 B2:typ),
     sub t_top B2 ->
     sub A (t_arrow B1 B2)
 | S_arr : forall (A1 A2 B1 B2:typ),
     sub B1 A1 ->
     sub A2 B2 ->
     sub (t_arrow A1 A2) (t_arrow B1 B2)
 | S_andl1 : forall (A1 A2 A3:typ),
     sub A1 A3 ->
     sub (t_and A1 A2) A3
 | S_andl2 : forall (A1 A2 A3:typ),
     sub A2 A3 ->
     sub (t_and A1 A2) A3
 | S_andr : forall (A1 A2 A3:typ),
     sub A1 A2 ->
     sub A1 A3 ->
     sub A1 (t_and A2 A3).

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_top :
     ord t_top
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     ord (t_arrow A B).

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (A:typ) (e:exp) (B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e B))
 | lc_e_fixpoint : forall (e:exp) (A:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint e A))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A)).

Inductive value : exp -> Prop :=
 | value_unit :
     value e_top
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_anno : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     value (e_abs A e B)
 | value_merge : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (e_merge v1 v2).

(* defns Semantics *)
Inductive TypedReduce : exp -> typ -> exp -> Prop :=    (* defn TypedReduce *)
 | TReduce_lit : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_lit i5)
 | TReduce_top : forall (v:exp),
     lc_exp v ->
     TypedReduce v t_top e_top
 | TReduce_toparr : forall (v:exp) (A B:typ),
     lc_exp v ->
     topLike B ->
     TypedReduce v (t_arrow A B) (e_abs t_top e_top B)
 | TReduce_arrow : forall (A:typ) (e:exp) (B C D:typ),
     lc_exp (e_abs A e B) ->
      not ( topLike D )  ->
     sub C A ->
     sub B D ->
     TypedReduce (e_abs A e B)  (t_arrow C D)  (e_abs A e D)
 | TReduce_mergevl : forall (v1 v2:exp) (A:typ) (v1':exp),
     lc_exp v2 ->
     TypedReduce v1 A v1' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v1'
 | TReduce_mergevr : forall (v1 v2:exp) (A:typ) (v2':exp),
     lc_exp v1 ->
     TypedReduce v2 A v2' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v2'
 | TReduce_and : forall (v:exp) (A B:typ) (v1 v2:exp),
     TypedReduce v A v1 ->
     TypedReduce v B v2 ->
     TypedReduce v (t_and A B) (e_merge v1 v2).

Definition disjointSpec A B :=
  forall C, sub A C -> sub B C -> topLike C.

Definition consistencySpec v1 v2 :=
  forall A v1' v2', TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.

(* typing in our system *)
Inductive Etyping : ctx -> exp -> typ -> Prop :=    (* defn Etyping *)
 | Etyp_top : forall (G:ctx),
      uniq  G  ->
     Etyping G e_top t_top
 | Etyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Etyping G (e_lit i5) t_int
 | Etyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Etyping G (e_var_f x) A
 | Etyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (D C B:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  B )  ->
     sub C A ->
     sub B D ->
     Etyping G  ( (e_abs A e D) )  (t_arrow C D)
 | Etyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ),
     Etyping G e2 A ->
     Etyping G e1 (t_arrow A B) ->
     Etyping G (e_app e1 e2) B
 | Etyp_merge : forall (G:ctx) (e1 e2:exp) (A B:typ),
     Etyping G e1 A ->
     Etyping G e2 B ->
      disjointSpec A B  ->
     Etyping G (e_merge e1 e2) (t_and A B)
 | Etyp_anno : forall (G:ctx) (e:exp) (A B:typ),
     Etyping G e B ->
     sub B A ->
     Etyping G  ( (e_anno e A) )  A
 | Etyp_fix : forall (L:vars) (G:ctx) (e:exp) (A:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  A )  ->
     Etyping G  ( (e_fixpoint e A) )  A
 | Etyp_mergev : forall (G:ctx) (v1 v2:exp) (A B:typ),
     uniq  G  ->
     value (e_merge v1 v2) ->
     Etyping  nil  v1 A ->
     Etyping  nil  v2 B ->
     consistencySpec v1 v2  ->
     Etyping G (e_merge v1 v2) (t_and A B).

(* lambda_i *)
Inductive dexp : Set :=  (* lambda_i expressions *)
 | de_var_b (_:nat) (* bound variables *)
 | de_var_f (x:var) (* free variables *)
 | de_top : dexp (* top *)
 | de_lit (i5:i) (* lit *)
 | de_abs (ee:dexp) (* abstractions *)
 | de_app (ee1:dexp) (ee2:dexp) (* applications *)
 | de_merge (ee1:dexp) (ee2:dexp) (* merge *)
 | de_ann (ee:dexp) (A:typ) (* annotation *)
 | de_fixpoint (ee:dexp) (* fixpoint *).

Inductive dirflag : Set :=  (* type checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

(* lambdai type wellformedness *)
Inductive WF : ctx -> typ -> Prop :=
 | Wf_int : forall (G:ctx),
     WF G t_int
 | Wf_top : forall (G:ctx),
     WF G t_top
 | Wf_arr : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
     WF G (t_arrow A B)
 | Wf_and : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
     disjointSpec A B  ->
     WF G (t_and A B).

(* opening up abstractions under locally nameless encoding *)
Fixpoint open_dexp_wrt_dexp_rec (k:nat) (ee_5:dexp) (ee__6:dexp) {struct ee__6}: dexp :=
  match ee__6 with
  | (de_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => de_var_b nat
        | inleft (right _) => ee_5
        | inright _ => de_var_b (nat - 1)
      end
  | (de_var_f x) => de_var_f x
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
  | (de_app ee1 ee2) => de_app (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_merge ee1 ee2) => de_merge (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_ann ee A) => de_ann (open_dexp_wrt_dexp_rec k ee_5 ee) A
  | (de_fixpoint ee) => de_fixpoint (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
  end.

Definition open_dexp_wrt_dexp ee_5 ee__6 := open_dexp_wrt_dexp_rec 0 ee__6 ee_5.

(* lambdai bidirectional typing *)
Inductive IBTyping : ctx -> dexp -> dirflag -> typ -> exp -> Prop :=
 | IBTyp_top : forall (G:ctx),
      uniq  G  ->
     IBTyping G de_top Inf t_top e_top
 | IBTyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     IBTyping G (de_lit i5) Inf t_int (e_lit i5)
 | IBTyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     IBTyping G (de_var_f x) Inf A (e_var_f x)
 | IBTyp_lam : forall (L:vars) (G:ctx) (ee:dexp) (A B:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> IBTyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  Chk B  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     IBTyping G (de_abs ee) Chk (t_arrow A B)  ( (e_abs A e B) )
 | IBTyp_app : forall (G:ctx) (ee1 ee2:dexp) (B:typ) (e1 e2:exp) (A:typ),
     IBTyping G ee1 Inf (t_arrow A B) e1 ->
     IBTyping G ee2 Chk A e2 ->
     IBTyping G (de_app ee1 ee2) Inf B (e_app e1 e2)
 | IBTyp_merge : forall (G:ctx) (ee1 ee2:dexp) (A B:typ) (e1 e2:exp),
     IBTyping G ee1 Inf A e1 ->
     IBTyping G ee2 Inf B e2 ->
      disjointSpec A B  ->
     IBTyping G (de_merge ee1 ee2) Inf (t_and A B) (e_merge e1 e2)
 | IBTyp_anno : forall (G:ctx) (ee:dexp) (A:typ) (e:exp),
     IBTyping G ee Chk A e ->
     IBTyping G (de_ann ee A) Inf A e
 | IBTyp_sub : forall (G:ctx) (ee:dexp) (B:typ) (e:exp) (A:typ),
     IBTyping G ee Inf A e ->
     sub A B ->
     IBTyping G ee Chk B (e_anno e B)
 | IBTyp_fix : forall (L:vars) (G:ctx) (ee:dexp) (A:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> IBTyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  Chk A  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     IBTyping G (de_fixpoint ee) Chk A (e_fixpoint e A).

(** infrastructure *)
Hint Constructors value topLike ord sub TypedReduce Etyping WF IBTyping lc_exp : core.

Lemma sub_reflexivity : forall A,
    sub A A.
Proof.
  intros A.
  induction A; eauto.
Qed.

(* completeness of typing with respect to the bidirectional type system in ICFP 2016 *)
Theorem typing_completeness : forall G ee dir A e,
    IBTyping G ee dir A e -> Etyping G e A.
Proof with eauto.
  intros G ee dir A e Typ.
  induction Typ...
  - (* abs *)
    eapply Etyp_abs.
    intros. apply H1 in H2...
    apply sub_reflexivity. apply sub_reflexivity.
Qed.


Require Import Reals.
Require Import Rpser_def Rpser_sums Rpser_usual Rpser_derivative.
Require Import Rfunction_classes.
Require Import Nth_derivative_def.
Require Import Rfunction_def Functions.
Require Import Rsequence_def.
Require Import List.
Require Import Option.

Local Open Scope Rseq_scope.

(* This file defines the differential equations and their
 interpretation as propositions. *)

Inductive side_equa : Set :=
    | cst  : forall (r : R), side_equa
    | scal : forall (r : R) (s : side_equa), side_equa
    | y    : forall (p : nat) (k : nat) (a : R), side_equa
    | opp  : forall (s1 : side_equa), side_equa
    | min  : forall (s1 s2 : side_equa), side_equa
    | plus : forall (s1 s2 : side_equa), side_equa
    | mult : forall (s1 s2 : side_equa), side_equa.

Definition diff_equa : Set := prod (side_equa) (side_equa).

Fixpoint interp_side_equa_in_N s (rho : list Rseq) : option Rseq :=
match s with
  | cst r      => Return (constant_seq r)
  | scal r e   => Bind (interp_side_equa_in_N e rho) (fun un => Return (r * un))
  | y i k a    => Bind (nth_error rho i) (fun un => Return (An_expand (An_nth_deriv un k) a))
  | opp e      => Bind (interp_side_equa_in_N e rho) (fun un => Return (- un))
  | min e1 e2  => Bind (interp_side_equa_in_N e1 rho) (fun un =>
                  Bind (interp_side_equa_in_N e2 rho) (fun vn => Return (un - vn)))
  | plus e1 e2 => Bind (interp_side_equa_in_N e1 rho) (fun un =>
                  Bind (interp_side_equa_in_N e2 rho) (fun vn => Return (un + vn)))
  | mult e1 e2 => Bind (interp_side_equa_in_N e1 rho) (fun un =>
                  Bind (interp_side_equa_in_N e2 rho) (fun vn => Return (un # vn)))
end.

Fixpoint interp_side_equa_in_R s (rho : list (sigT infinite_cv_radius)) : option (R -> R) :=
match s with
  | cst r      => Return (fun _ => r)
  | scal r e   => Bind (interp_side_equa_in_R e rho) (fun f => Return ((fun _ => r) * f)%F)
  | y i k a    => Bind (nth_error rho i) (fun f => Return (fun x => nth_derive (sum (projT1 f) (projT2 f))
                 (D_infty_Rpser (projT1 f) (projT2 f) k) (a * x)%R))
  | opp e      => Bind (interp_side_equa_in_R e rho) (fun f => Return (- f)%F)
  | min e1 e2  => Bind (interp_side_equa_in_R e1 rho) (fun f =>
                  Bind (interp_side_equa_in_R e2 rho) (fun g => Return (f - g)%F))
  | plus e1 e2 => Bind (interp_side_equa_in_R e1 rho) (fun f =>
                  Bind (interp_side_equa_in_R e2 rho) (fun g => Return (f + g)%F))
  | mult e1 e2 => Bind (interp_side_equa_in_R e1 rho) (fun f =>
                  Bind (interp_side_equa_in_R e2 rho) (fun g => Return (f * g)%F))
end.

Definition Invalid_context := False.

Definition interp {A B : Type} (e : diff_equa) (rho : list A)
  (f : side_equa -> list A -> option B) (P : B -> B -> Prop) :=
let (s1, s2) := e in
match (f s1 rho), (f s2 rho) with
  | Some b1, Some b2 => P b1 b2
  | _, _ => Invalid_context
end.

Definition interp_in_N e rho : Prop :=
  interp e rho interp_side_equa_in_N Rseq_eq.

Definition interp_in_R e rho : Prop :=
  interp e rho interp_side_equa_in_R Rfun_eq.

Declare Scope de_scope.
Delimit Scope de_scope with de.

(* Automatically open scope de_scope for arguments of type diff_equa *)
Bind Scope de_scope with diff_equa.
Bind Scope de_scope with side_equa.

Open Scope de_scope.

Notation "`c k" := (cst k) (at level 40) : de_scope.
Notation "- y" := (opp y) : de_scope.
(* Infix "*" := scal : de_scope. *)
Infix "+" := plus : de_scope.
Infix "*" := plus : de_scope.
Infix "-" := min : de_scope.
Infix ":=:" := (@pair side_equa side_equa) (at level 50): de_scope.

Notation "[| e |]N" := (interp_in_N e%de) (at level 69).
Notation "[| e |]R" := (interp_in_R e%de) (at level 69).


Require Import Basics Types WildCat.
Require Import HFiber.
Require Import Pointed.Core.
Require Import Pointed.pEquiv.
Require Import Pointed.Loops.

Local Open Scope pointed_scope.

(** ** Pointed fibers *)

Definition pfiber {A B : pType} (f : A ->* B) : pType.
Proof.
  nrefine ([hfiber f (point B), _]).
  exists (point A).
  apply point_eq.
Defined.

Definition pfib {A B : pType} (f : A ->* B) : pfiber f ->* A
  := (Build_pMap (pfiber f) A pr1 1).

(** The double fiber object is equivalent to loops on the base. *)
Definition pfiber2_loops {A B : pType} (f : A ->* B)
  : pfiber (pfib f) <~>* loops B.
Proof.
  snrapply Build_pEquiv'.
  { transitivity (f (point A) = point B).
    1: make_equiv_contr_basedpaths.
    apply equiv_concat_l.
    symmetry; apply point_eq. }
  cbn; apply concat_Vp.
Defined.

Definition pfiber_fmap_loops {A B : pType} (f : A ->* B)
  : pfiber (fmap loops f) <~>* loops (pfiber f).
Proof.
  srapply Build_pEquiv'.
  { etransitivity.
    2: srapply equiv_path_sigma.
    simpl; unfold hfiber.
    srapply equiv_functor_sigma_id.
    intro p; cbn.
    refine (_ oE equiv_moveL_Mp _ _ _).
    refine (_ oE equiv_concat_r (concat_p1 _) _).
    refine (_ oE equiv_moveL_Vp _ _ _).
    refine (_ oE equiv_path_inverse _ _).
    apply equiv_concat_l.
    apply transport_paths_Fl. }
  by pointed_reduce.
Defined.

Definition pr1_pfiber_fmap_loops {A B} (f : A ->* B)
  : fmap loops (pfib f) o* pfiber_fmap_loops f
    ==* pfib (fmap loops f).
Proof.
  srapply Build_pHomotopy.
  - intros [u v].
    refine (concat_1p _ @ concat_p1 _ @ _).
    exact (@ap_pr1_path_sigma _ _ (point A; point_eq f) (point A;point_eq f) _ _).
  - abstract (pointed_reduce_rewrite; reflexivity).
Defined.

Definition pfiber_fmap_iterated_loops {A B : pType} (n : nat) (f : A ->* B)
  : pfiber (fmap (iterated_loops n) f) <~>* iterated_loops n (pfiber f).
Proof.
  induction n.
  1: reflexivity.
  refine (_ o*E pfiber_fmap_loops _ ).
  rapply (emap loops).
  exact IHn.
Defined.

Definition functor_pfiber {A B C D}
           {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D}
           (p : k o* f ==* g o* h)
  : pfiber f ->* pfiber g.
Proof.
  srapply Build_pMap.
  + cbn. refine (functor_hfiber2 p (point_eq k)).
  + srapply path_hfiber.
    - apply point_eq.
    - refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. apply (point_htpy p)^.
Defined.

Definition pequiv_pfiber {A B C D}
           {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D)
           (p : k o* f ==* g o* h)
  : pfiber f <~>* pfiber g
  := Build_pEquiv _ _ (functor_pfiber p) _.

Definition square_functor_pfiber {A B C D}
           {f : A ->* B} {g : C ->* D} {h : A ->* C} {k : B ->* D}
           (p : k o* f ==* g o* h)
  : h o* pfib f ==* pfib g o* functor_pfiber p.
Proof.
  srapply Build_pHomotopy.
  - intros x; reflexivity.
  - apply moveL_pV. cbn; unfold functor_sigma; cbn.
    abstract (rewrite ap_pr1_path_sigma, concat_p1; reflexivity).
Defined.

Definition square_pequiv_pfiber {A B C D}
           {f : A ->* B} {g : C ->* D} (h : A <~>* C) (k : B <~>* D)
           (p : k o* f ==* g o* h)
  : h o* pfib f ==* pfib g o* pequiv_pfiber h k p
  := square_functor_pfiber p.

(** The triple-fiber functor is equal to the negative of the loopspace functor. *)
Definition pfiber2_fmap_loops {A B : pType} (f : A ->* B)
: pfiber2_loops f o* pfib (pfib (pfib f))
  ==* fmap loops f o* (loops_inv _ o* pfiber2_loops (pfib f)).
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _).
  - intros [[[x p] q] r]. simpl in *.
    (** Apparently [destruct q] isn't smart enough to generalize over [p]. *)
    move q before x; revert dependent x;
      refine (paths_ind_r _ _ _); intros p r; cbn.
    rewrite !concat_1p, concat_p1.
    rewrite paths_ind_r_transport.
    rewrite transport_arrow_toconst, transport_paths_Fl.
    rewrite concat_p1, inv_V, ap_V.
    refine (((r^)..2)^ @ _).
    rewrite transport_paths_Fl; cbn.
    rewrite pr1_path_V, !ap_V, !inv_V.
    apply concat_p1.
  - reflexivity.
Qed.


From Undecidability.FOL Require Import Syntax.Core Tarski.FullCore.
Require Import Vector.

Local Notation vec := Vector.t.

Inductive bterm `{funcs_signature} :=
  | bVar : nat -> bterm
  | bFunc : forall (f : syms), vec bterm (ar_syms f) -> bterm
  | bEmbedT : term -> bterm.

Inductive bform `{funcs_signature, preds_signature, operators, falsity_flag} :=
  | bFal : bform
  | bAtom : forall (P : preds), vec bterm (ar_preds P) -> bform
  | bBin : binop -> bform  -> bform  -> bform
  | bQuant : quantop -> (bterm -> bform)  -> bform
  | bFree : (bterm -> bform)  -> bform
  | bEmbedForm : form -> bform.

Arguments bFunc {_} _ _.
Arguments bAtom {_} {_} {_} {_} _ _.

Fixpoint conv_term `{funcs_signature} i (b : bterm) : term :=
  match b with
  | bVar m => var (i - m)
  | bEmbedT t => t
  | bFunc f v => func f (Vector.map (conv_term i) v)
  end.

Fixpoint conv `{funcs_signature, preds_signature, operators} i (phi : bform) : form :=
  match phi with
  | bFal => falsity
  | bAtom p v => atom p (Vector.map (conv_term i) v)
  | bBin op t1 t2 => bin op (conv i t1) (conv i t2)
  | bQuant op f => quant op (conv (S i) (f (bVar (S i))))
  | bFree f => conv (S i) (f (bVar (S i)))
  | bEmbedForm phi => phi
  end.

Declare Scope hoas_scope.
Delimit Scope hoas_scope with hoas.
Open Scope hoas_scope.

Notation "'Free' x .. y , p" := (bFree (fun x => .. (bFree (fun y => p)) ..)%hoas)
(at level 50, x binder, left associativity,
  format "'[' 'Free'  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "'∀'' x .. y , p" := (bQuant All (fun x => .. (bQuant All (fun y => p)) ..)%hoas)
(at level 50, x binder,  left associativity,
  format "'[' '∀''  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "'∃'' x .. y , p" := (bQuant Ex (fun x => .. (bQuant Ex (fun y => p)) ..)%hoas)
(at level 50, x binder, left associativity,
  format "'[' '∃''  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "⊥" := (bFal) : hoas_scope.
Notation "A ∧ B" := (bBin Conj A%hoas B%hoas) (at level 41) : hoas_scope.
Notation "A ∨ B" := (bBin Disj A%hoas B%hoas) (at level 42) : hoas_scope.
Notation "A '→' B" := (bBin Impl A%hoas B%hoas) (at level 43, right associativity) : hoas_scope.
Notation "¬ A" := ((A → ⊥)%hoas) (at level 42) : hoas_scope.
Notation "A '↔' B" := ((A → B)%hoas ∧ (B → A)%hoas) (at level 43) : hoas_scope.

Definition convert `{funcs_signature, preds_signature, operators} f := (@conv _ _ _ 0 f).
Arguments convert {_ _ _} f%hoas.

Notation "<< f" := (ltac:(let y := eval cbn -[subst_form] in (convert f) in exact y)) (at level 200, only parsing).

Coercion bEmbedT : term >-> bterm.
Definition vec_term `{funcs_signature} := Vector.t term.
Definition vec_bterm `{funcs_signature} := Vector.t bterm.
Definition vec_bEmbedT' `{funcs_signature} : forall n, vec_term n -> vec_bterm n := @Vector.map term bterm bEmbedT.
Coercion vec_bEmbedT `{funcs_signature} := vec_bEmbedT'.
Coercion bEmbedForm : form >-> bform.


(*Congruence is weaker than reflexivity when it comes to higher level than necessary equalities:*)

Goal @eq Set nat nat.
congruence.
Qed.

Goal @eq Type nat nat.
Fail congruence. (*bug*)
reflexivity.
Qed.

Variable T : Type.

Goal @eq Type T T.
congruence.
Qed.


(******************************************************************************)
(* Dr Daniel Kirk (c) 2021                                                    *)
(******************************************************************************)
(* Let R : ringType                                                           *)
(******************************************************************************)
(* lmodZeroType R == an lmodType R structure for the unit type                *)
(* lmodRingType R == an lmodType R structure for R as a module over itself    *)
(******************************************************************************)

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

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.

Declare Scope lmod_scope.

Section Results.
  Variable (R : ringType) (M : lmodType R).
  Lemma lmod_ifthenelse_sum (E : eqType) (Y : E -> R) (F : E -> M) (P : pred E) (b : E) :
    (if P b then Y b else 0) *: (F b)
      = (if P b then (Y b *: F b) else 0).
  Proof. case (P b)=>//; by rewrite GRing.scale0r. Qed.
End Results.

Module lmodZero.
  Section Def.
  Definition zeroAdd := fun _ _ : unit => tt.
  Definition zeroNeg := fun _ : unit => tt.
  Definition zeroAbGroupA : associative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroupC : commutative zeroAdd. Proof. by []. Qed.
  Definition zeroAbGroup0z : left_id tt zeroAdd. Proof. by case. Qed.
  Definition zeroAbGroupIz : left_inverse tt zeroNeg zeroAdd. Proof. by case. Qed.

  Definition zeroAbGroup : zmodType :=
    ZmodType unit (GRing.Zmodule.Mixin zeroAbGroupA zeroAbGroupC zeroAbGroup0z zeroAbGroupIz).
  Canonical zeroAbGroup.

  Variable R : ringType.

  Definition zeroScale := (fun (_ : R) (_ : unit) => tt).
  Lemma zeroScale_id : left_id 1%R zeroScale. Proof. by case. Qed.
  Lemma zeroScale_rD : right_distributive zeroScale +%R. Proof. by rewrite /(GRing.add)=>/=. Qed.

  Lemma zeroScaleScale (a b : R) (v : unit) :
    zeroScale a (zeroScale b v) = zeroScale (a * b) v.
  Proof. by rewrite /(GRing.add)=>/=. Qed.

  Lemma zeroScaleMorph (v : unit) : {morph zeroScale^~ v : a b / a + b >-> a + b}.
  Proof. by rewrite /(GRing.add)=>/=. Qed.

  Definition type : lmodType R :=
    LmodType R unit (LmodMixin zeroScaleScale zeroScale_id zeroScale_rD zeroScaleMorph).
  End Def.
End lmodZero.

Notation lmodZeroType := lmodZero.type.

Module lmods.
  Section Def.
    Variable (R : ringType).
    Program Definition ringMod : lmodType R
     := LmodType R R (LmodMixin (@GRing.mulrA R) (@GRing.mul1r R) (@GRing.mulrDr R) _).
    Next Obligation. by move=>x y; rewrite GRing.mulrDl. Qed.

    Variable (A : lalgType R) (V : lmodType A).
    Definition AtoRscale := fun (r : R) (v : V) => (r *: (GRing.one A)) *: v.
    Lemma AtoRscale_id : left_id 1 AtoRscale.
    Proof. by rewrite/AtoRscale=>x; rewrite !GRing.scale1r. Qed.
    Lemma AtoRscale_rD : right_distributive AtoRscale +%R.
    Proof. by rewrite/AtoRscale=> x y z; rewrite GRing.scalerDr. Qed.

    Lemma AtoRScaleScale (a b : R) (v : V) :
    AtoRscale a (AtoRscale b v) = AtoRscale (a * b) v.
    Proof.     by rewrite/AtoRscale GRing.scalerA -GRing.scalerAl GRing.mul1r GRing.scalerA. Qed.

    Lemma AtoRScaleMorph (v : V) : {morph AtoRscale^~ v : a b / a + b >-> a + b}.
    Proof. by rewrite/AtoRscale=>r s; rewrite !GRing.scalerDl. Qed.

    Definition AtoRmod : lmodType R
    := LmodType R V (LmodMixin AtoRScaleScale AtoRscale_id AtoRscale_rD AtoRScaleMorph).

  End Def.
End lmods.
Notation ringModType := lmods.ringMod.
Close Scope ring_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defparallel_1 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_2 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_10 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defmeet_11 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_12 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable defoppositeside_13 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_14 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable proposition_29B_15 : (forall A D G H : Universe, ((par_ A G H D /\ tS_ A G H D) -> congA_ A G H G H D)).
Variable lemma_ABCequalsCBA_16 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_17 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable cn_congruencereflexive_18 : (forall A B : Universe, cong_ A B A B).
Variable lemma_NCorder_19 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_congruenceflip_20 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable proposition_04_21 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable proposition_27B_22 : (forall A D E F : Universe, ((congA_ A E F E F D /\ tS_ A E F D) -> par_ A E F D)).

Theorem proposition_33_23 : (forall A B C D M : Universe, ((par_ A B C D /\ (cong_ A B C D /\ (betS_ A M D /\ betS_ B M C))) -> (par_ A C B D /\ cong_ A C B D))).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Primitive Projections.
Set Implicit Arguments.

Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.

Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.

Definition bar := @projT1.
Definition baz A P (x : @sigT A P) := projT1 x.

Definition foo (A: Type) (B: A -> Type) (C: A -> Type) (c: {x : A & {_ : B x & C x}}) : {x : A & {_ : C x & B x}}.
Proof.
  exists (projT1 c).
  exists (projT2 (projT2 c)).
  destruct c as [a [b c]].
  exact b.
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m19_10limbs_donna.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 Export Comma.Projection Cat Category.Duals FunctorCategory Category.Product.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope category_scope.

Section CommaCategoryInducedFunctor.
  Context `{Funext}.
  Variable A : PreCategory.
  Variable B : PreCategory.
  Variable C : PreCategory.

  Definition CommaCategoryInducedFunctor_ObjectOf s d
             (m : Morphism ([A, C]^op * [B, C]) s d)
             (x : fst s ↓ snd s)
  : (fst d ↓ snd d)
    := Build_CommaCategory_Object
         (fst d) (snd d)
         (CCO_a x)
         (CCO_b x)
         ((snd m) (CCO_b x) ∘ CCO_f x ∘ (fst m) (CCO_a x)).

  Definition CommaCategoryInducedFunctor_MorphismOf s d m s0 d0
             (m0 : Morphism (fst s ↓ snd s) s0 d0)
  : Morphism (fst d ↓ snd d)
             (@CommaCategoryInducedFunctor_ObjectOf s d m s0)
             (@CommaCategoryInducedFunctor_ObjectOf s d m d0).
  Proof.
    simpl.
    let s := match goal with |- CommaCategory_Morphism ?s ?d => constr:(s) end in
    let d := match goal with |- CommaCategory_Morphism ?s ?d => constr:(d) end in
    refine (Build_CommaCategory_Morphism s d (CCM_g m0) (CCM_h m0) _);
      simpl in *; clear.
    abstract (
        destruct_head prod;
        destruct_head CommaCategory_Morphism;
        destruct_head CommaCategory_Object;
        simpl in *;
          repeat try_associativity ltac:(rewrite <- !Commutes || (progress f_ap));
        repeat try_associativity ltac:(rewrite !Commutes || (progress f_ap));
        assumption
      ). (* 2.465 s *)
  Defined.

  Definition CommaCategoryInducedFunctor s d
             (m : Morphism ([A, C]^op * [B, C]) s d)
  : Functor (fst s ↓ snd s) (fst d ↓ snd d).
  Proof.
    refine (Build_Functor (fst s ↓ snd s) (fst d ↓ snd d)
                          (@CommaCategoryInducedFunctor_ObjectOf s d m)
                          (@CommaCategoryInducedFunctor_MorphismOf s d m)
                          _
                          _
           );
    abstract (
        intros; apply CommaCategory_Morphism_eq; reflexivity
      ).
  Defined.
End CommaCategoryInducedFunctor.

Section SliceCategoryInducedFunctor.
  Context `{Funext}.
  Variable C : PreCategory.

  Section Slice_Coslice.
    Variable D : PreCategory.

    (* TODO(jgross): See if this can be recast as an exponential law functor about how Cat ^ 1 is isomorphic to Cat, or something *)
    Definition SliceCategoryInducedFunctor_NT s d (m : Morphism D s d)
    : NaturalTransformation (FunctorFromTerminal D s)
                            (FunctorFromTerminal D d).
    Proof.
      exists (fun _ : Unit => m);
      simpl; intros; clear;
      abstract (autorewrite with category; reflexivity).
    Defined.

    Variable F : Functor C D.
    Variable a : D.

    Section Slice.
      Definition SliceCategoryInducedFunctor F' a' (m : Morphism D a a') (T : NaturalTransformation F' F)
      : Functor (F ↓ a) (F' ↓ a')
        := CommaCategoryInducedFunctor (s := (F, FunctorFromTerminal D a))
                                       (d := (F', FunctorFromTerminal D a'))
                                       (T, @SliceCategoryInducedFunctor_NT a a' m).

      Definition SliceCategoryNTInducedFunctor F' T := @SliceCategoryInducedFunctor F' a (Identity _) T.
      Definition SliceCategoryMorphismInducedFunctor a' m := @SliceCategoryInducedFunctor F a' m (IdentityNaturalTransformation _).
    End Slice.

    Section Coslice.
      Definition CosliceCategoryInducedFunctor F' a' (m : Morphism D a' a) (T : NaturalTransformation F F')
      : Functor (a ↓ F) (a' ↓ F')
        := CommaCategoryInducedFunctor (s := (FunctorFromTerminal D a, F))
                                       (d := (FunctorFromTerminal D a', F'))
                                       (@SliceCategoryInducedFunctor_NT a' a m, T).

      Definition CosliceCategoryNTInducedFunctor F' T := @CosliceCategoryInducedFunctor F' a (Identity _) T.
      Definition CosliceCategoryMorphismInducedFunctor a' m := @CosliceCategoryInducedFunctor F a' m (IdentityNaturalTransformation _).
    End Coslice.
  End Slice_Coslice.

  Definition SliceCategoryOverInducedFunctor a a' (m : Morphism C a a') : Functor (C / a) (C / a')
    := Eval hnf in SliceCategoryMorphismInducedFunctor _ _ _ m.
  Definition CosliceCategoryOverInducedFunctor a a' (m : Morphism C a' a) : Functor (a \ C) (a' \ C)
    := Eval hnf in CosliceCategoryMorphismInducedFunctor _ _ _ m.
End SliceCategoryInducedFunctor.

Section CatOverInducedFunctor.
  Context `{Funext}.
  Variable P : PreCategory -> Type.
  Context `{forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation Cat := (SubPreCat P).

  Definition CatOverInducedFunctor a a' (m : Morphism Cat a a') : Functor (Cat / a) (Cat / a')
    := SliceCategoryOverInducedFunctor Cat a a' m.

  Definition OverCatInducedFunctor a a' (m : Morphism Cat a' a) : Functor (a \ Cat) (a' \ Cat)
    := CosliceCategoryOverInducedFunctor Cat a a' m.
End CatOverInducedFunctor.


(* LEM: Law of excluded middle
   This module contains Theorems that are surprising to see
   requires LEM: `P /\ ~ P`
   or does not require LEM.
*)

Require Import CoqStock.WreckIt.

Theorem move_forall_inside_orl: forall (A: Type) (P: A -> Prop) (Q: Prop) (a : A),
  (forall x, P x) \/ Q
  -> (forall x, P x \/ Q).
Proof.
intros.
wreckit.
- specialize H with x.
  left.
  assumption.
- right.
  assumption.
Qed.

Theorem move_forall_outside_orl: forall (A: Type) (P: A -> Prop) (Q: Prop) (a : A),
  Q \/ ~ Q
  -> (
      (forall x, P x \/ Q)
      -> (forall x, P x) \/ Q
  ).
Proof.
intros.
wreckit.
- right.
  assumption.
- left.
  intros.
  specialize H0 with x.
  wreckit.
  + assumption.
  + contradiction.
Qed.