(*
For some properties, if they hold for all the fibers of the index map,
then they hold for the Indexed W type.
We assume function extensionality throughout.

We work with the concrete inductive implementation IW, since
it has nice judgemental equalities. Since all implementations are equivalent,
the results hold for any implementation.

We show below that being a subsingleton / mere proposition is such a property.

We also show below that, assuming we can lift decisions over the children
(if the children are finitely enumerable, this is possible)
that decidability of equality is another such property.

Since we showed that the fibers of the index map of the equality family are
equivalent to equality in a fiber of the index map, we have by recursion
that all positive h-levels are also inherited.

In the case of non-indexed W types, the Index type is unit, so the unique
fiber is equivalent to the Data set, and this result coincides with
the result by Danielsson:
https://homotopytypetheory.org/2012/09/21/positive-h-levels-are-closed-under-w/
*)

From IWTypes Require Import IWType.
From IWTypes Require Import FunctionExtensionality.
From IWTypes Require Eqdep_dec.
Import IWType.concrete.

(* We aren't working with nat, and we want to use the + notation for types. *)
Close Scope nat_scope.

Definition fib {A B} (f : A -> B) (b : B) := {a : A & f a = b}.

Definition isProp A := forall x y : A, x = y.

Definition isProp_inherited {FunExt : FunExt} (S : spec)
  (fibers_prop : forall i, isProp (fib (@index S) i))
  : forall i, isProp (IW S i)
  := fix isProp i a : forall b, a = b := match a with
     | IWsup x children1 => fun (b : IW S (index x)) =>
       let children_contract children2 : children1 = children2
        := funext (fun c => isProp _ (children1 c) (children2 c)) in
       match b in (IW _ i)
       return
         forall iy : i = index x,
         IWsup x children1 =
         eq_rect i (IW S) b (index x) iy
       with IWsup y children2 => fun iy : index y = index x =>
         match fibers_prop (index x) (existT _ x eq_refl) (existT _ y iy)
         in (_ = existT _ y iy)
         return
           forall children2,
           IWsup x children1 =
           eq_rect (index y) _ (IWsup y children2) (index x) iy
         with eq_refl => fun children2 =>
           f_equal (IWsup x) (children_contract children2)
         end children2
       end eq_refl
     end.

Definition decidable (A : Type) := A + (A -> False).
Definition decidable_eq (A : Type) := forall x y : A, decidable (x = y).

(* If Children x is finitely enumerable, we have liftP. *)
Definition decidable_eq_inherited {FunExt : FunExt} (S : spec)
  (liftP : forall (x : Data S) (P : Children x -> Type),
   (forall c, decidable (P c)) -> decidable (forall c, P c))
  (fibers_dec : forall i, decidable_eq (fib (@index S) i))
  : forall i, decidable_eq (IW S i)
  := let children_for (x : Data S) := forall c, IW S (child_index x c) in
     let getfib {i} (a : IW S i) : fib (@index S) i
      := match a with IWsup x _ => existT _ x eq_refl end in
     let getfib_computes x y children p
      : getfib (eq_rect (index y) (IW S) (IWsup y children) (index x) p) =
        existT _ y p
      := match p
         return getfib (eq_rect _ _ (IWsup y children) _ p) = existT _ y p
         with eq_refl => eq_refl end in
     let getfib_plus {i} (a : IW S i)
      : {f : fib (@index S) i & children_for (projT1 f)}
      := match a with IWsup x children =>
         existT _ (existT _ x eq_refl) children end in
     let children_eq (x : Data S) children1 children2
      : IWsup x children1 = IWsup x children2 -> children1 = children2
      := fun aeqb => Eqdep_dec.inj_right_pair_on
         _ (fibers_dec _ (existT _ x eq_refl))
         (fun f => children_for (projT1 f))
         _ _ (f_equal getfib_plus aeqb) in
     fix decide_eq i a : forall b, decidable (a = b) := match a with
     | IWsup x children1 => fun (b : IW S (index x)) =>
       let decide_children children2 : decidable (children1 = children2)
        := match liftP x (fun c => children1 c = children2 c)
                 (fun c => decide_eq _ (children1 c) (children2 c))
           with
           | inl agree => inl (funext agree)
           | inr disagree => inr (fun agree => disagree (happly agree))
           end in
       match b in (IW _ i)
       return
         forall iy : i = index x,
         decidable (
           IWsup x children1 =
           eq_rect i (IW S) b (index x) iy
         )
       with IWsup y children2 => fun iy : index y = index x =>
         match fibers_dec (index x) (existT _ x eq_refl) (existT _ y iy)
         with
         | inl fiber_eq => match fiber_eq in (_ = existT _ y iy)
           return
             forall children2,
             decidable (
               IWsup x children1 =
               eq_rect (index y) (IW S) (IWsup y children2) (index x) iy
             )
           with eq_refl => fun children2 =>
             match decide_children children2 with
             | inl children_eq => inl (f_equal (IWsup x) children_eq)
             | inr children_neq => inr (fun aeqb => children_neq
               (children_eq x children1 children2 aeqb))
             end
           end children2
         | inr fiber_neq => inr
           (fun aeqb
              : IWsup x children1 = eq_rect _ _ (IWsup y children2) _ iy =>
            fiber_neq (eq_trans
             (f_equal getfib aeqb)
             (getfib_computes x y children2 iy)))
         end
       end eq_refl
     end.


Require Import MoSel.

Import adequacy_gensym_SLList.

Inductive Tree (X : Type) :=
| Leaf : X -> Tree X
| Node : Tree X -> Tree X -> Tree X.

Arguments Leaf {_}.
Arguments Node {X}.

Fixpoint label {X} (t : Tree X) : mon Fresh (Tree ident) :=
  match t with
  | Leaf _ =>
    let! v := gensym in
    ret (Leaf v)
  | Node l r =>
    let! l' := label l in
    let! r' := label r in
    ret (Node l' r')
  end.

Definition relabel {X} (t : Tree X): Tree ident := snd (run (label t) initial_state).

Fixpoint flatten {X} (t: Tree X) : list X :=
  match t with
  | Leaf v => cons v nil
  | Node l r => flatten l ++ flatten r
  end.

Fixpoint sameShape {X Y} (t1 : Tree X) (t2 : Tree Y) : Prop :=
  match t1,t2 with
  | Leaf _, Leaf _ => True
  | Node l r, Node l_res r_res  => sameShape l l_res /\ sameShape r r_res
  | _, _ => False
  end.

Definition labelPost {X} (t: Tree X) (t_res : Tree ident) : iProp :=
  ([∗ list] x ∈ (flatten t_res), IsFresh x) ∗ ⌜sameShape t t_res⌝.

Lemma label_spec : forall X (t : Tree X),
    ⊢ {{ emp }} label t {{ t'; labelPost t t' }}.
Proof.
  induction t.
  - iBind. eapply gensym_spec. iRet. rewrite /labelPost. simpl; auto.
  - simpl label. iBind. eapply IHt1. iBind. Frame. eapply IHt2. iRet.
    rewrite /labelPost. iIntros "[[HA %] [HB %]]". iSplitL; auto.
    simpl. iApply big_sepL_app. iFrame.
Qed.

Lemma sep_list_fold : forall a l, ⊢ (IsFresh a -∗ ([∗ list] x ∈ l, IsFresh x) -∗ ⌜a ∉ l⌝ : iProp).
Proof.
  induction l; iIntros "* HA HB".
  - iPureIntro. intro. inversion H.
  - iDestruct "HB" as "[HA' HB]".
    iDestruct (singleton_neq with "HA HA'") as "%".
    iDestruct (IHl with "HA HB") as "%". iPureIntro.
    intro. inversion H1; subst; auto.
Qed.

Lemma fold_nodup : forall l,
    ⊢ (([∗ list] x ∈ l, IsFresh x) : iProp) -∗ ⌜NoDup l⌝.
Proof.
  induction l; simpl; iIntros; norm_all; auto.
  - iPureIntro. apply NoDup_nil_2.
  - iDestruct (IHl with "HC") as "%". iDestruct (sep_list_fold with "HB HC") as "%".
    iPureIntro. constructor; auto.
Qed.

Lemma finish_him : forall X (t : Tree X) t' h,
    labelPost t t' () h -> NoDup (flatten t') /\ sameShape t t'.
Proof.
  intros. apply soundness3 in H. apply (soundness1 h).
  iIntros "HA". iDestruct (H with "HA") as "[HA HB]".
  iDestruct (fold_nodup with "HA") as "HA". iSplit; auto.
Qed.

Lemma relabel_spec : forall X (t : Tree X) t',
    relabel t = t' -> NoDup (flatten t') /\ sameShape t t'.
Proof.
  intros. unfold relabel in H. destruct (run (label t) initial_state) eqn:?.
  destruct H. simpl.
  destruct (use_adequacy _ _ _ _ _ emp_trivial (label_spec _ _) Heqp).
  eapply finish_him. eapply H.
Qed.


Require Export GeoCoq.Tarski_dev.Ch06_out_lines.
Require Import GeoCoq.Tactics.Coinc.tactics_axioms.

(** In this file we prove that Tarski neutral dimensionless is a Col_theory. *)

Section Tarski_is_a_Col_theory.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Global Instance Tarski_is_a_Col_theory : (Col_theory Tpoint Col).
Proof.
exact (Build_Col_theory Tpoint Col col_trivial_1 col_permutation_1 col_permutation_5 col3).
Defined.

End Tarski_is_a_Col_theory.


Require Export Bridges_order.

Module lub_spec (N:Num_w).

Import N.
Module Export XX:=mBridges(N).

(** LUB specifications *)
Definition subset := HRw->Prop.

Definition upper_bound (X:subset) (m:HRw) : Prop := forall x:HRw, X x -> m [>] x.

Definition bound_above  (X:subset) := exists m:HRw, upper_bound X m.

Definition non_empty (X:subset):= {x:HRw| X x}. (** actually implements the axiom of choice *)

Definition power (x:HRw) (n:A) : std n /\ 0<=n -> HRw.
intros Hn.
apply (nat_like_induction (fun _ => HRw)) with (n:=n).
exact [1].
intros k Hk xk.
apply (HRwmult xk x).
assumption.
Defined.

Parameter power_lim : forall x, x [>] [0] -> [1] [>] x -> forall a:HRw, a [>] [0] ->
  forall eps:HRw, eps [>] [0] ->
  exists n:A, std n/\0 <=n /\ forall H:std n/\ 0 <= n, eps [>] (a[*] (power x n H)).
(*0<x<1 -> a >0 -> \forall eps, eps > 0, exists n, a [*] x^n < eps *)
(* one must choose an n such that n > ln (eps) / ln (x)  in order to show this property - may be adapted from Coq reals *)

(** Technical lemmas *)

Lemma test1 :
([2] [*] (HRwinv [3] lemma_HRw3)) [=] ((HRwinv [3] lemma_HRw3) [+] HRwinv [3] lemma_HRw3).
Proof.
intros; unfold HRw2; ring.
Qed.

Lemma test2 : forall a b, (HRwinv [3] lemma_HRw3 [*] b) [+] (([2] [*] HRwinv [3] lemma_HRw3) [*] a) [=]
((HRwinv [3] lemma_HRw3) [*] a)[+] (HRwinv [3] lemma_HRw3 [*] b) [+] (HRwinv [3] lemma_HRw3  [*] a).
intros; unfold HRw2; ring.
Qed.

Lemma HRwgt_one_third : one_third [>] [0].
Proof.
unfold HRwgt, one_third, HRw3, HRw2.
simpl.
exists (1+1+1+1+1+1).
split.
repeat apply ANS2a;apply ANS1.
split.
setoid_replace 0 with (0+0+0+0+0+0) by ring.
repeat apply lt_plus; apply lt_0_1.
setoid_replace (w * w / (w + w + w) + - 0) with (w * w / (w + w + w)) by ring.
apply le_mult_inv with (x:=w).
apply Aw.
setoid_replace  (w * ((1 + 1 + 1 + 1 + 1 + 1) * (w * w / (w + w + w))))
with ((1+1) * ((w+ w + w) * (w * w / (w + w + w)))) by ring.
rewrite div_mod2.
setoid_replace ((1 + 1) * (w * w + - (w * w %% w + w + w))) with ((1+1)* (w* w) + - (1+1)*(w* w %% (w+ w + w))) by ring.
apply le_trans with (w* w + (w * w + - (1+1)*(w+ w+ w))).
pattern (w* w) at 1; setoid_replace (w* w) with ((w* w) +0) by ring.
apply le_plus.
ring_simplify; apply le_refl.
setoid_replace (w * w + 0 + - (1 + 1) * (w + w + w)) with (w * (w + - (1+1+1+1+1+1))) by ring.
setoid_replace 0 with (w * 0) by ring.
apply le_mult.
apply lt_le; apply Aw.
apply le_plus_inv with (1+1+1+1+1+1).
ring_simplify.
apply lt_le; apply lim_lt_w.
split.
repeat( apply ANS2a || apply ANS2b); apply ANS1.
setoid_replace 0 with ((1+1)*(0+ (0+0))) by ring.
apply le_mult.
setoid_replace 0 with (0+0) by ring.
apply le_plus; apply lt_le; apply lt_0_1.
repeat apply le_plus; apply lt_le; apply lt_0_1.
setoid_replace ((1+1) * (w* w)) with (w * w + w* w) by ring.
rewrite plus_assoc.
apply le_plus.
apply le_refl.
apply le_mult_neg.
apply lt_plus_inv with (1+1).
ring_simplify.
setoid_replace 0 with (0+0) by ring.
apply lt_plus; apply lt_0_1.
apply lt_le.
apply div_mod3a.
setoid_replace 0 with (0+0+0) by ring.
repeat apply lt_plus; apply Aw.
left; setoid_replace 0 with (0+0+0) by ring; repeat apply lt_plus; apply Aw.
Qed.

Lemma HRwgt_morphism1 :
  forall x y : HRw, x [=] y -> forall x0 y0 : HRw, x0 [=] y0 -> (x [>] x0 -> y [>] y0).
Proof.
intros x y Hxy t z Htz;
  destruct x as [x Hx]; destruct y as [y Hy]; destruct z as [z Hz]; destruct t as [t Ht]; simpl.
unfold HRwequal in *.
intros.
destruct H as [n [Hlim [Hn0 Hn]]].
exists (n+n+n).
assert (H3lim : lim (n+n+n)).
repeat apply ANS2a; assumption.
assert (H3n:0<n+n+n).
setoid_replace 0 with (0+0+0) by ring.
repeat apply lt_plus; assumption.
split.
apply H3lim.
split.
apply H3n.
setoid_replace ((n+n+n)*(y+ -z)) with ((n+n+n)*(y + -x)+ n*(x + -t)+n*(x+ - t) +n*(x + - t) +(n+n+n)*(t + -z)) by ring.
apply le_trans with (oppA w + w + w + w + (oppA w)).
ring_simplify.
apply le_refl.
apply le_plus.
apply le_plus.
apply le_plus.
apply le_plus.
apply abs_new2.
rewrite abs_prod.
rewrite (abs_pos_val (n+n+n)) by (apply lt_le; apply H3n).
setoid_replace (y + - x) with (- (x + - y)) by ring.
rewrite abs_minus.
apply Hxy.
apply H3lim.
apply H3n.
assumption.
assumption.
assumption.
apply abs_new2.
rewrite abs_prod.
rewrite (abs_pos_val (n+n+n)) by (apply lt_le; apply H3n).
apply Htz.
apply H3lim.
apply H3n.
Qed.

Instance HRwgt_morphism : Proper (HRwequal ==> HRwequal ==> Logic.iff) HRwgt.
Proof.
repeat red; split.
apply HRwgt_morphism1; assumption.
apply HRwgt_morphism1; symmetry; assumption.
Qed.

Lemma HRwge_morphism1 :
  forall x y : HRw, x [=] y -> forall x0 y0 : HRw, x0 [=] y0 -> (x [>=] x0 -> y [>=] y0).
Proof.
intros.
generalize (HRwge_prop1 _  _ H1); intros.
apply HRwge_prop2.
intros.
setoid_rewrite <- H.
apply H2.
setoid_rewrite H0.
assumption.
Qed.

Instance HRwge_morphism : Proper (HRwequal ==> HRwequal ==> Logic.iff) HRwge.
repeat red.
intros; split.
apply HRwge_morphism1; assumption.
apply HRwge_morphism1; symmetry; assumption.
Qed.

Lemma R2_4' : forall X Y, X [>=] Y -> forall Z, X [+] Z [>=] Y [+] Z.
Proof.
intros x y Hxy z.
eapply HRwge_prop2.
generalize (HRwge_prop1 _ _ Hxy).
intros.

generalize (H (c [+] -w z)).
intros.

eapply HRwgt_HRwplus_inv_r with (-w z).
rewrite HRwplus_assoc.
rewrite HRwplus_opp.
rewrite HRwplus_comm.
rewrite HRwplus_zero.
apply H1.
eapply HRwgt_HRwplus_inv_r with (z).
rewrite HRwplus_assoc.
rewrite (HRwplus_comm (-w z) z).
rewrite HRwplus_opp.
rewrite (HRwplus_comm c [0]).
rewrite HRwplus_zero.
assumption.
Qed.

Lemma step_thirds : forall a b:HRw, a [>] b ->
((HRwinv [3] lemma_HRw3 [*] b) [+] (([2] [*] HRwinv [3] lemma_HRw3) [*] a)) [>]
((([2] [*] HRwinv [3] lemma_HRw3) [*] b) [+] (HRwinv [3] lemma_HRw3 [*] a)).
Proof.
intros a b Hab.
apply HRwgt_HRwplus_inv_r
  with (Z:= -w ((([2] [*] HRwinv [3] lemma_HRw3) [*] b) [+] (HRwinv [3] lemma_HRw3 [*] a))).
ring_simplify; unfold HRwminus.
setoid_replace (-w ((HRwinv [3] lemma_HRw3)[*] a)) with ((HRwinv [3] lemma_HRw3)[*] (-w a)) by ring.
setoid_replace (-w (HRwinv [3] lemma_HRw3)) with ((HRwinv [3] lemma_HRw3)[*] (-w [1])) by ring.
repeat rewrite HRwmult_assoc.
repeat rewrite <- HRw_distr.
setoid_replace (((-w [1]) [*] (b [*] [2])) [+] b) with (-w b) by (unfold HRw2; ring).
rewrite HRwplus_assoc.
setoid_replace (([2][*] a)[+] (-w a)) with a by (unfold HRw2;ring).
apply R2_5.
split.
apply HRwgt_one_third.
apply HRwgt_HRwplus_inv_l with b.
ring_simplify; assumption.
Qed.

Lemma two_thirds_one_third : forall x : HRw, x [=] ((two_third [*] x) [+] (one_third [*] x)).
Proof.
intros.
setoid_rewrite two_one_third.
setoid_rewrite HRwmult_comm.
setoid_rewrite <- HRw_distr.
setoid_rewrite three_one_third.
ring.
Qed.

Lemma HRw1_3 : forall a b , a [>] b ->
((HRwinv [3] lemma_HRw3) [*] a) [>] ((HRwinv [3] lemma_HRw3) [*] b).
Proof.
intros a b Hab.
eapply HRwgt_HRwplus_inv_r with (-w (one_third [*] b)).
unfold one_third; ring_simplify; unfold HRwminus.
setoid_replace (-w (HRwinv [3] lemma_HRw3 [*] b)) with ((HRwinv [3] lemma_HRw3) [*] (-w b)) by ring.
rewrite <- HRw_distr.
apply R2_5.
split.
apply HRwgt_one_third.
apply HRwgt_HRwplus_inv_l with b.
ring_simplify; assumption.
Qed.

(** properties of power *)
Lemma power_0 : forall a, forall H0: std 0 /\ 0<= 0, (power a 0 H0) [=] [1].
Proof.
intros a H0.
unfold power.
rewrite nat_like_induction_r1.
reflexivity.
Qed.

Lemma power_n1 : forall a, forall n, forall Hn:std n /\ 0<=n, forall Hn1: std (n+1)/\ 0<= (n+1),
  power a (n+1) Hn1 [=] power a n Hn [*] a.
Proof.
intros a n Hn Hn1.
unfold power at 1.
rewrite nat_like_induction_r2 with (H:=Hn).
unfold power.
reflexivity.
Qed.

Lemma HRwgt_HRwmult : forall a b c, a [>] [0] -> b [>] c -> (a [*] b) [>] (a[*] c).
Proof.
intros.
apply HRwgt_HRwplus_inv_r with (-w (a[*] c)).
setoid_replace (((a [*] c) [+] (-w (a [*] c)))) with [0] by ring.
setoid_replace ((a[*] b) [+] (-w (a [*] c))) with (a[*](b [+] -w c)) by ring.
apply R2_5.
split.
assumption.
apply HRwgt_HRwplus_inv_r with c.
ring_simplify.
assumption.
Qed.

Lemma power_HRwgt : forall a,  a [>] [0] -> forall n, forall H:(std n /\0<=n), power a n H [>] [0].
Proof.
intros a Ha n Hn.
apply (nat_like_induction (fun (x:A) => forall Hx: std x /\ 0<=x, power a x Hx [>] [0])).
intros; rewrite power_0.
exists 1.
split.
apply ANS1.
split.
apply lt_0_1.
ring_simplify.
apply le_refl.
intros.
rewrite power_n1 with (Hn:=H).
setoid_replace [0] with (a[*] [0]) by ring.
rewrite <- (HRwmult_comm a).
apply HRwgt_HRwmult.
assumption.
eapply H0.
apply Hn.
Qed.

Lemma lt_power_Sn_n : forall a, forall n, forall Hn:std n /\ 0<=n, forall Hn1: std (n+1)/\ 0<= (n+1),
  a [>] [0] -> [1] [>] a -> (power a n Hn) [>] (power a (n+1) Hn1).
Proof.
intros.
rewrite power_n1 with (Hn:=Hn).
setoid_replace (power a n Hn) with ((power a n Hn)[*] [1]) at 1 by ring.
apply HRwgt_HRwmult.
apply power_HRwgt.
assumption.
assumption.
Qed.

End lub_spec.


Require Import List.
Import ListNotations.
Require Import Strings.String.

(*
   I will buy you a copy of the book: CoqArt,
   if you are one of the first two contributing to this repo,
   https://github.com/awalterschulze/regex-reexamined-coq/issues/17
   that makes a pull request that solves a `Good First Issue`.

   GetFreeBook is an inductive predicate that defines a few ways
   that will result in Walter buying you a book.
   GetFreeBook says whether a person with a name is getting a free book,
   based on the list of contributors.
*)
Inductive GetFreeBook (contributors: list string) (you: string): Prop :=
  (* If you are the only contributor, then you get a free book.
     This contributors equals the list that only contains you.
  *)
  | only_contributor:
    contributors = [you]
    -> GetFreeBook contributors you
  (* But you could also be the first contributor,
     in a long list of contributors.
     This is means there exists a list of other contributors
     and you are the first or second in the list.
  *)
  | first_or_second_contributor:
    (exists
      (contributor1: string)
      (contributor2: string)
      (others: list string),
      contributors = contributor1 :: contributor2 :: others /\
      (
         you = contributor1
         \/ you = contributor2
      )
    )
    -> GetFreeBook contributors you
  .

(* Now we can prove that if you are the only contributor,
   I will buy you a book.
*)
Theorem you_get_a_free_book_if_you_are_the_only_contributor:
  forall (you: string)
         (contributors: list string),
  contributors = [you] -> GetFreeBook contributors you.
Proof.
intros.
apply only_contributor.
exact H.
Qed.

(* We can also prove that I will buy you a book,
   if you are the first or second contributor
*)
Theorem you_get_a_free_book_if_you_are_the_first_or_second_contributor:
  forall (you: string)
         (someone: string)
         (others: list string)
         (contributors: list string),
  contributors = you :: someone :: others \/
  contributors = someone :: you :: others
  -> GetFreeBook contributors you.
Proof.
intros.
apply first_or_second_contributor.
(*
With exists we have to provide the possibilities,
but to know if you are the first or second contributor,
we have to destruct the hypothesis H.
*)
destruct H.
- (* Now we know you are the first contributor *)
  exists you.
  exists someone.
  exists others.
  (* This looks provable *)
  auto.
- (* Now it is easy to also proof that case,
     where you are the second contributor. *)
  exists someone.
  exists you.
  exists others.
  auto.
Qed.

(* After buying two contributors a book,
   I will be out of money.
*)

Inductive WalterIsOutOfMoney: Prop := .

(* Doesn't seem like this induction predicate can be constructed.
   It doesn't have any constructors, hmmm.
   Is it possible for Walter to run out of money?
*)

Inductive MyFalse: Prop := .

(* Continuing the Curry-Howard Isomorphism
   This is the Void data type, which has no constructors.
   Doesn't seem like Walter will run out of money,
   but he is trying to passive aggressively say
   that these books aren't cheap and
   he is not buying everyone a book, I am sorry.
*)

(* I wonder if it is possible to have a book anyway *)
Inductive HaveTheBook: Prop :=
  | pdf_is_illegally_downloadable: HaveTheBook
  .

Inductive MyTrue: Prop :=
  | I: MyTrue.
(* Continuing the Curry-Howard Isomorphism
   This is the Unit data type `()`, which represents one value
   that you can always construct out of thin air.
*)

(* Seems it is always possible to get a book *)
Theorem always_a_way_to_get_the_book:
  WalterIsOutOfMoney -> HaveTheBook.
Proof.
intro WalterIsLying.
induction WalterIsLying.
(* If you assume False, you can prove anything *)
Qed.

Theorem always_a_way_to_get_the_book_2:
  HaveTheBook.
Proof.
(* I did not say this *)
apply pdf_is_illegally_downloadable.
Qed.

(* Here is an inductive predicate that is recursively
   defined to say whether a string is in a list.
*)
Inductive Contains (you: string): list string -> Prop :=
  | head_contributor (others: list string):
    Contains you (you :: others)
  | a_contributor (another: string) (others_and_you: list string):
    (* This is the recursive bit *)
    Contains you others_and_you -> Contains you (another :: others_and_you)
  .

Inductive BonusPoints (you: string) (all_contributors: list string): Prop :=
  | bonus_points:
    (*
       If you contribute not just if you are the first or second contributor.
       You can get bonus points for the functional programming course.
    *)
    Contains you all_contributors ->
    BonusPoints you all_contributors.

(*
   `not A`
   is the same as
   `A -> False`

   Seems as though if you do not contribute
   you will not get bonus points.
*)
Theorem no_bonus_points_for_you:
  forall (you: string)
         (contributors: list string),
         not (Contains you contributors) ->
         not (BonusPoints you contributors).
Proof.
intros.
unfold not.
(* Now we can see the goal -> False *)
intros B.
destruct B.
(* We have a hypothesis that says:
   you are not a contributor
   and
   you are a contributor
   that is a contradiction
  *)
contradiction.
Qed.

Fixpoint contains (x: string) (xs: list string): bool :=
  match xs with
  | [] => false
  | (x'::xs') =>
    if eqb x x'
    then true
    else contains x xs'
  end.

Theorem contains_correct:
  forall (x: string) (xs: list string),
  contains x xs = true <-> Contains x xs.
Proof.
intros.
split.
- intros.
  induction xs.
  + cbn in H.
    discriminate.
  + cbn in H.
    remember (eqb x a).
    destruct b.
    * Search eqb.
      symmetry in Heqb.
      rewrite eqb_eq in Heqb.
      subst.
      apply head_contributor.
    * apply a_contributor.
      apply IHxs.
      exact H.
- intros.
  induction xs.
  + inversion H.
  + inversion H.
    * cbn.
      rewrite eqb_refl.
      reflexivity.
    * subst.
      cbn.
      apply IHxs in H1.
      rewrite H1.
      remember (eqb x a).
      destruct b; reflexivity.
Qed.


Require Import FP.CoreData.Function.
Require Import FP.CoreClasses.RelDec.
Require Import FP.CoreClasses.Injection.
Require Import FP.CoreClasses.Setoid.

Import FunctionNotation.
Import ProperNotation.

Class Eqv T := { eqv : T -> T -> Prop }.
Arguments eqv {T Eqv} _ _ : simpl never.
Class PER_WF T `{! Eqv T } := { per_wf :> PER eqv }.
Class ER_WF T `{! Eqv T } := { er_wf :> Equivalence eqv }.
Class EqvDec T := { eqv_dec : T -> T -> bool }.
Class Eqv_RDC T `{! Eqv T ,! EqvDec T } := { eqv_rdc :> RelDecCorrect T eqv eqv_dec }.

Section Eqv.
  Context {T} `{! Eqv T }.

  Definition not_eqv : T -> T -> Prop := not '.:' eqv.
End Eqv.

Section EqvDec.
  Context {T} `{! EqvDec T }.

  Definition neg_eqv_dec : T -> T -> bool := negb '.:' eqv_dec.

  Context `{! Eqv T ,! Eqv_RDC T }.

  Definition eqv_dec_p : forall x y:T, {eqv x y} + {~eqv x y} := rel_dec_p.
  Definition neg_eqv_dec_p : forall x y:T, {~eqv x y} + {eqv x y} := neg_rel_dec_p.
End EqvDec.
Arguments eqv_dec {T EqvDec} _ _ : simpl never.

(* Logical equivalence *)

Module EqvNotation.
  Infix "~=!" := eqv_dec (at level 35, no associativity).
  Infix "/~=!" := neg_eqv_dec (at level 35, no associativity).

  Infix "~=?" := eqv_dec_p (at level 35, no associativity).
  Infix "/~=?" := neg_eqv_dec_p (at level 35, no associativity).

  Infix "~=" := eqv (at level 70, no associativity).
  Infix "/~=" := not_eqv (at level 70, no associativity).
End EqvNotation.
Section Fun_Eqv.
  Context {A} `{! Eqv A }.
  Context {B} `{! Eqv B }.

  Definition fun_eqv : (A -> B) -> (A -> B) -> Prop := eqv ==> eqv.
  Global Instance Fun_Eqv : Eqv (A -> B) := { eqv := fun_eqv }.
  Definition fun_eqv_intro {f:A -> B} {g:A -> B} : (eqv ==> eqv) f g -> eqv f g := id.
  Definition fun_eqv_elim {f:A -> B} {g:A -> B} : eqv f g -> (eqv ==> eqv) f g := id.
  Global Opaque fun_eqv.
End Fun_Eqv.

Ltac logical_eqv_intro_once :=
  match goal with
  | [ |- eqv ?A ?B ] =>
      match type of A with
      | ?T -> ?U => apply fun_eqv_intro ; unfold "==>" at 1 ; intros
      | Fun ?T ?U => apply fun_eqv_intro ; unfold "==>" at 1 ; intros
      end
  end.

Ltac logical_eqv_intro := repeat logical_eqv_intro_once.
Ltac logical_eqv_elim_once :=
  match goal with
  | [ |- eqv (?f ?x) (?g ?y) ] => apply fun_eqv_elim
  end.
Ltac logical_eqv_elim := repeat logical_eqv_elim_once.

Create HintDb logical_eqv_db.

Ltac logical_eqv_once :=
  match goal with
  | [ |- eqv (?f ?x) (?g ?y) ] =>
      let g_type := type of g in
      match type of f with
      | g_type => apply fun_eqv_elim
      end
  | [ |- eqv (fun _ => _) _ ] =>
      apply fun_eqv_intro ; unfold "==>" at 1 ; intros
  | [ |- eqv _ (fun _ => _) ] =>
      apply fun_eqv_intro ; unfold "==>" at 1 ; intros
  end.
Ltac logical_eqv :=
  match goal with
  | [ |- Proper eqv ?x ] => unfold Proper
  | _ => idtac
  end ;
  repeat logical_eqv_once ;
  match goal with
  | [ |- eqv (T:=?T) (Eqv:=?_Eqv) ?x ?x ] =>
      change (eqv x x) with (Proper (eqv (T:=T) (Eqv:=_Eqv)) x)
  | _ => idtac
  end ;
  eauto with logical_eqv_db typeclass_instances.

Section Fun_WFPER.
  Context {A} `{! Eqv A ,! PER_WF A}.
  Context {B} `{! Eqv B ,! PER_WF B}.

  Global Instance Fun_WFPER : PER_WF (A -> B).
  Proof.
    repeat constructor.
    - unfold Symmetric ; intros.
      logical_eqv_intro.
      symmetry ; auto.
      logical_eqv_elim ; auto.
      symmetry ; auto.
    - unfold Transitive ; intros.
      logical_eqv_intro.
      transitivity (y x0).
      logical_eqv_elim ; auto.
      transitivity y0 ; auto.
      symmetry ; auto.
      logical_eqv_elim ; auto.
  Qed.
End Fun_WFPER.
Hint Extern 9 (PER_WF (_ -> _)) => apply Fun_WFPER : typeclass_instances.

Section Eqv_Logical.
  Context {A} `{! Eqv A ,! PER_WF A }.
  Context {B} `{! Eqv B }.
  Context {C} `{! Eqv C }.
  Context {D} `{! Eqv D }.

  Global Instance Proper_PER_elim1 {f:A -> B} `{! Proper eqv f }
    : Proper (eqv ==> eqv) f := Proper0.
  Global Instance Proper_PER_elim2 {f:A -> B -> C} `{! Proper eqv f }
    : Proper (eqv ==> eqv ==> eqv) f := Proper0.
  Global Instance Proper_PER_elim3 {f:A -> B -> C -> D} `{! Proper eqv f }
    : Proper (eqv ==> eqv ==> eqv ==> eqv) f := Proper0.
  Global Instance Proper_app (f:A -> B) `(! Proper eqv f ) (a:A) `(! Proper eqv a )
    : Proper eqv (f a) := Proper0 a a Proper1.
  Definition per_Proper_left (x:A) (y:A) `(! eqv x y ) : Proper eqv x.
  Proof.
    unfold Proper.
    transitivity y ; auto.
    symmetry ; auto.
  Qed.
  Definition per_Proper_right (x:A) (y:A) `(! eqv x y ) : Proper eqv y.
  Proof.
    unfold Proper.
    transitivity x ; auto.
    symmetry ; auto.
  Qed.
End Eqv_Logical.
Hint Extern 1 (Proper eqv _) => eapply per_Proper_left ; trivial : typeclass_instances.
Hint Extern 1 (Proper eqv _) => eapply per_Proper_right ; trivial : typeclass_instances.

Section Injection.
  Context {T U} `{! Eqv T ,! Eqv U }.

  Definition Proper_inj {inj} `{! InjectionRespect T U inj eqv eqv }
    : Proper eqv inj.
  Proof.
    unfold Proper ; apply fun_eqv_intro.
    apply InjectionRespect_eta.
  Qed.
End Injection.

Section Function.
  Context {A} `{! Eqv A ,! PER_WF A }.
  Context {B} `{! Eqv B ,! PER_WF B }.
  Context {C} `{! Eqv C ,! PER_WF C }.

  Global Instance id_Proper : Proper eqv (id (A:=A)).
  Proof.
    unfold Proper ; logical_eqv_intro ; auto.
  Qed.

  Global Instance compose_Proper : Proper eqv (compose (A:=A) (B:=B) (C:=C)).
  Proof.
    unfold Proper ; logical_eqv_intro ; simpl ; logical_eqv.
  Qed.

  Global Instance const_Proper : Proper eqv (const (A:=A)).
  Proof.
    unfold Proper ; logical_eqv_intro ; auto.
  Qed.

  Global Instance apply_Proper : Proper eqv (apply (A:=A) (B:=B)).
  Proof.
    unfold Proper ; logical_eqv_intro ; simpl ; logical_eqv.
  Qed.

  Global Instance apply_to_Proper : Proper eqv (apply_to (A:=A) (B:=B)).
  Proof.
    unfold Proper ; logical_eqv_intro ; simpl ; logical_eqv.
  Qed.

End Function.


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

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

Print Assumptions opp.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Theorem t : forall m n, m + n = n + m.


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

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

Print Assumptions opp.


(** Coq coding by choukh, July 2022 **)

Require Import Meta Notions.

Section 模型实装.

Record 偏 A := {
  求值 : ℕ → A?;
  求值安定 : 安定 求值
}.
Arguments 求值 {_} _ _.
Notation "x @ n" := (求值 x n) (at level 50).

Section 给定类型A.
Context {A : Type}.

Definition 解包关系 (x : 偏 A) (a : A) := ∃ n, x @ n = Some a.
Notation "x ?= a" := (解包关系 x a) (at level 70).

Lemma 解包关系单射 : ∀ (x : 偏 A) a b, x ?= a → x ?= b → a = b.
Proof.
  intros x a b [n Hn] [m Hm].
  eapply 安定平稳. apply 求值安定. eauto. eauto.
Qed.

End 给定类型A.
End 模型实装.

Require PartialFunc.

(* TODO *)
Global Instance 可选值序列 : PartialFunc.偏函数模型.
Proof.
  unshelve econstructor.
  - exact 偏.
  - exact @解包关系.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - exact @解包关系单射.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
Admitted.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Theorems about the 2-sphere [S^2]. *)

Require Import HoTT.Basics HSet.
Require Import Types.Paths Types.Forall Types.Arrow Types.Universe Types.Empty Types.Unit.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

(* ** Definition of the 2-sphere. *)

Module Export TwoSphere.

Private Inductive S2 : Type0 :=
| base : S2.

Axiom surf : idpath base = idpath base.

Definition S2_ind (P : S2 -> Type) (b : P base) (s : idpath b = transport2 P surf b)
  : forall (x:S2), P x
  := fun x => match x with base => fun _ => b end s.

Axiom S2_ind_beta_surf
  : forall (P : S2 -> Type) (b : P base) (s : idpath b = transport2 P surf b),
      apD02 (S2_ind P b s) surf = s @ (concat_p1 _)^.

End TwoSphere.

(* ** The non-dependent eliminator *)

Definition S2_rec (P : Type) (b : P) (s : idpath b = idpath b)
  : S2 -> P
  := S2_ind (fun _ => P) b (s @ (transport2_const surf b) @ (concat_p1 _)).

Definition S2_rec_beta_surf (P : Type) (b : P) (s : idpath b = idpath b)
: ap02 (S2_rec P b s) surf = s.
Proof.
  apply (cancel2L (transport2_const surf b)).
  apply (cancelL (apD_const (S2_rec P b s) (idpath base))).
  apply (cancelR _ _ (concat_p_pp _ (transport_const _ b) _)^).
  apply (cancelR _ _ (whiskerL (transport2 _ surf b) (apD_const _ _)^)).
  refine ((apD02_const (S2_rec P b s) surf)^ @ _).
  refine ((S2_ind_beta_surf _ _ _) @ _).
  refine (_ @ (ap (fun w => _ @ w)
                  (triangulator
                     (transport2 (fun _ : S2 => P) surf b) _))).
  cbn. refine (_ @ (ap (fun w => (w @ _) @ _) (concat_1p _)^)).

  refine (_ @ (concat_p_pp _ _ _)).
  refine (_ @ (ap (fun w => _ @ w) (concat_pp_p _ _ _))).
  refine (_ @ (ap (fun w => _ @ (w @ _)) (concat_Vp _)^)).
  refine (_ @ (ap (fun w => _ @ (w @ _))
                  (concat_pV (concat_p1
                                (transport2 (fun _ : S2 => P) surf b @ 1))))).
  refine (_ @ (ap (fun w => _ @ w) (concat_p_pp _ _ _))).
  refine (_ @ (concat_pp_p _ _ _)). apply moveR_pV.
  refine (_ @ (concat_p_pp _ _ _)).
  refine (_ @ (ap (fun w => _ @ w) (whiskerR_p1 _)^)). f_ap.
  refine ((ap (fun w => w @ _) (whiskerL_1p_1 _)^) @ _).
  refine ((ap (fun w => _ @ w) (whiskerR_p1 _)^) @ _). cbn.
  refine ((concat_p_pp _ _ _) @ _). f_ap.
  refine ((ap (fun w => _ @ w) (concat_1p _)) @ _).
  refine ((concat_whisker 1 _ _ 1 (transport2_const surf b) s)^ @ _).

  symmetry.
  refine ((ap (fun w => w @@ _) (concat_p1 _)^) @ _).
  refine ((ap (fun w => _ @@ w) (concat_1p _)^) @ _).
  refine ((concat_concat2 _ _ _ _)^ @ _). f_ap.
Defined.


Require Import ssreflect.
From Tweetnacl.Libs Require Import Export.
From Tweetnacl.Libs Require Import HeadTailRec.
From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import ABCDEF.
From Tweetnacl.Gen Require Import step_gen.

Section Abstract_Rec.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : Ops T T' Mod}.

Fixpoint abstract_rec (m : nat) (z:T') (a b c d e f x : T) : (T * T * T * T * T * T) :=
  match m with
  | 0%nat => (a,b,c,d,e,f)
  | S n =>
      let r := Getbit (Z.of_nat n) z in
      abstract_rec n z
        (Gen.fa r a b c d e f x)
        (Gen.fb r a b c d e f x)
        (Gen.fc r a b c d e f x)
        (Gen.fd r a b c d e f x)
        (Gen.fe r a b c d e f x)
        (Gen.ff r a b c d e f x)
        x
    end.

Arguments rec_fn [T] _ _ _.

Lemma abstract_rec_equiv_rec_fn: forall n z a b c d e f x,
  abstract_rec n z a b c d e f x = rec_fn (step_gen z x) n (a,b,c,d,e,f).
Proof.
  induction n => z x a b c d e f.
  reflexivity.
  simpl.
  apply IHn.
Qed.

End Abstract_Rec.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.arrival.basic.arrival_sequence
               rt.model.priority rt.model.suspension rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.uni.schedule rt.model.schedule.uni.schedulability.
Require Import rt.model.schedule.uni.susp.suspension_intervals
               rt.model.schedule.uni.susp.schedule rt.model.schedule.uni.susp.platform.
Require Import rt.analysis.uni.basic.fp_rta_comp.
Require Import rt.analysis.uni.susp.dynamic.oblivious.reduction.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module SuspensionObliviousFP.

  Import Job TaskArrival SporadicTaskset Suspension Priority Schedulability
         PlatformWithSuspensions SuspensionIntervals.
  Export ResponseTimeIterationFP ReductionToBasicSchedule.

  (* In this section, we formalize the suspension-oblivious RTA
     for fixed-priority tasks under the dynamic self-suspension model.
     This is just a straightforward application of the reduction
     in analysis/uni/susp/dynamic/oblivious/reduction.v with the basic
     response-time analysis for uniprocessor FP scheduling. *)
  Section ReductionToBasicAnalysis.

    Context {SporadicTask: eqType}.
    Variable task_cost: SporadicTask -> time.
    Variable task_period: SporadicTask -> time.
    Variable task_deadline: SporadicTask -> time.

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

    (* Let ts be any task set to be analyzed... *)
    Variable ts: taskset_of SporadicTask.

    (* ...such that tasks have valid parameters. *)
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Next, consider any job 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_arrival_sequence_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* ...in which all jobs come from task set ts, ... *)
    Hypothesis H_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* ...have valid parameters,...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* ... and satisfy the sporadic task model. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Consider any FP policy that is reflexive, transitive and total, indicating
       "higher or equal task priority". *)
    Variable higher_eq_priority: FP_policy SporadicTask.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: FP_is_transitive higher_eq_priority.
    Hypothesis H_priority_is_total: FP_is_total_over_task_set higher_eq_priority ts.

    (* Assume that the total suspension time of any job is bounded according
       to the dynamic suspension model. *)
    Variable next_suspension: job_suspension Job.
    Variable task_suspension_bound: SporadicTask -> time.
    Hypothesis H_dynamic_suspensions:
      dynamic_suspension_model job_cost job_task next_suspension task_suspension_bound.

    (* As part of the analysis, we are going to use task costs inflated with suspension bounds, ... *)
    Let inflated_cost := inflated_task_cost task_cost task_suspension_bound.

    (* ...with the condition that they are no larger than the deadline nor the period of each task. *)
    Hypothesis H_inflated_cost_le_deadline_and_period:
      forall tsk,
        tsk \in ts ->
          inflated_cost tsk <= task_deadline tsk /\
          inflated_cost tsk <= task_period tsk.

    (* Now we proceed with the schedulability analysis. *)
    Section MainProof.

      (* Consider any suspension-aware schedule of the arrival sequence... *)
      Variable sched: schedule Job.
      Hypothesis H_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.

      (* ...where jobs only execute after they arrive... *)
      Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.

      (* ...and no longer than their execution costs. *)
      Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

      (* Also assume that the schedule is work-conserving when there are non-suspended jobs, ... *)
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost next_suspension arr_seq sched.

      (* ...that the schedule respects job priority... *)
      Hypothesis H_respects_priority:
        respects_FP_policy job_arrival job_cost job_task next_suspension arr_seq
                           sched higher_eq_priority.

      (* ...and that suspended jobs are not allowed to be scheduled. *)
      Hypothesis H_respects_self_suspensions:
        respects_self_suspensions job_arrival job_cost next_suspension sched.

      (* For simplicity, let's also define some local names. *)
      Let task_is_schedulable :=
        task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

      (* Next, recall the response-time analysis for FP scheduling instantiated with
         the inflated task costs. *)
      Let claimed_to_be_schedulable :=
        fp_schedulable inflated_cost task_period task_deadline higher_eq_priority.

      (* Then, we prove that if this suspension-oblivious response-time analysis suceeds... *)
      Hypothesis H_claimed_schedulable_by_suspension_oblivious_RTA:
        claimed_to_be_schedulable ts.

      (* ...then no task misses its deadline in the suspension-aware schedule.
         The proof is a straightforward application of the following lemma from
         reduction.v: suspension_oblivious_preserves_schedulability. *)
      Theorem suspension_oblivious_fp_rta_implies_schedulability:
        forall tsk,
          tsk \in ts ->
          task_is_schedulable tsk.
      Proof.
        rename H_claimed_schedulable_by_suspension_oblivious_RTA into SCHED,
               H_jobs_from_taskset into FROMTS, H_inflated_cost_le_deadline_and_period into LEdl.
        intros tsk INts j ARRj JOBtsk.
        apply suspension_oblivious_preserves_schedulability with
              (higher_eq_priority0 := (FP_to_JLDP job_task higher_eq_priority))
              (arr_seq0 := arr_seq) (next_suspension0 := next_suspension); try (by done).
        - by intros t y x z; apply H_priority_is_transitive.
        - by intros j1 j2 t ARR1 ARR2; apply/orP; apply H_priority_is_total; apply FROMTS.
        apply jobs_schedulable_by_fp_rta with (task_cost0 := inflated_cost) (ts0 := ts)
            (task_period0 := task_period) (task_deadline0 := task_deadline) (job_task0 := job_task)
            (higher_eq_priority0 := higher_eq_priority); try (by done).
        - by apply suspension_oblivious_task_parameters_remain_valid.
        - by apply suspension_oblivious_job_parameters_remain_valid with (ts0 := ts)
                                                       (task_period0 := task_period).
        - by apply sched_newjobs_come_from_arrival_sequence.
        - by apply sched_new_jobs_must_arrive_to_execute.
        - by apply sched_new_completed_jobs_dont_execute.
        - by apply sched_new_work_conserving.
        {
          intros j_low j_hp t; apply sched_new_respects_policy; try (by done).
          - by intros t' j1 j2 j3; apply H_priority_is_transitive.
          - by intros j1 j2 t' ARR1 ARR2; apply/orP; apply H_priority_is_total; apply FROMTS.
        }
      Qed.

    End MainProof.

  End ReductionToBasicAnalysis.

End SuspensionObliviousFP.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. lfind. Admitted.


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

 Cartesian and cocartesian monoidal categories

 In this file, we discuss several variations of cartesian monoidal categories. We
 also prove some properties about them.

 Contents
 1. Cartesan monoidal categories
 2. Cartesian monoidal categories are symmetric
 3. Cocartesian monoidal categories

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Import BifunctorNotations.
Import MonoidalNotations.

Local Open Scope cat.
Local Open Scope moncat.

(**
 1. Cartesan monoidal categories
 *)
Definition is_semicartesian
           {C : category}
           (M : monoidal C)
  : UU
  := isTerminal C (I_{M}).

Section ProjectionsSemiCartesian.
  Context {M : monoidal_cat}
          (HM : is_semicartesian M).

  Definition semi_cart_to_unit
             (x : M)
    : x --> I_{M}
    := TerminalArrow (I_{M} ,, HM) x.

  Proposition semi_cart_to_unit_eq
              {x : M}
              (f g : x --> I_{M})
    : f = g.
  Proof.
    exact (@TerminalArrowEq _ (I_{M} ,, HM) x f g).
  Qed.

  Definition semi_cart_tensor_pr1
             (x y : M)
    : x ⊗ y --> x
    := identity _ #⊗ semi_cart_to_unit y · mon_runitor x.

  Definition semi_cart_tensor_pr2
             (x y : M)
    : x ⊗ y --> y
    := semi_cart_to_unit x #⊗ identity _ · mon_lunitor y.
End ProjectionsSemiCartesian.

Definition tensor_isBinProduct
           {M : monoidal_cat}
           (HM : is_semicartesian M)
  : UU
  := ∏ (x y : M),
     isBinProduct
       _ _ _ _
       (semi_cart_tensor_pr1 HM x y)
       (semi_cart_tensor_pr2 HM x y).

Definition is_cartesian
           (M : monoidal_cat)
  : UU
  := ∑ (HM : is_semicartesian M), tensor_isBinProduct HM.

Coercion is_cartesian_to_semicartesian
         {M : monoidal_cat}
         (M_cart : is_cartesian M)
  : is_semicartesian M
  := pr1 M_cart.

Definition is_cartesian_BinProduct
           {M : monoidal_cat}
           (M_cart : is_cartesian M)
           (x y : M)
  : BinProduct M x y
  := make_BinProduct _ _ _ _ _ _ (pr2 M_cart x y).

(**
 2. Cartesian monoidal categories are symmetric
 *)
Section CartesianSymmetric.
  Context {M : monoidal_cat}
          (M_cart : is_cartesian M).

  Definition cartesian_to_braiding_data
    : braiding_data M.
  Proof.
    intros x y.
    use (BinProductArrow _ (is_cartesian_BinProduct M_cart y x)).
    - apply (semi_cart_tensor_pr2 M_cart).
    - apply (semi_cart_tensor_pr1 M_cart).
  Defined.

  Proposition cartesian_to_braiding_data_pr1
              (x y : M)
    : cartesian_to_braiding_data x y
      · semi_cart_tensor_pr1 (pr1 M_cart) y x
      =
      semi_cart_tensor_pr2 M_cart x y.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct M_cart y x)).
  Qed.

  Proposition cartesian_to_braiding_data_pr2
              (x y : M)
    : cartesian_to_braiding_data x y
      · semi_cart_tensor_pr2 (pr1 M_cart) y x
      =
      semi_cart_tensor_pr1 M_cart x y.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct M_cart y x)).
  Qed.

  Proposition cartesian_tensor_pr1
              {x₁ x₂ y₁ y₂ : M}
              (f : x₁ --> x₂)
              (g : y₁ --> y₂)
    : f #⊗ g · semi_cart_tensor_pr1 M_cart x₂ y₂
      =
      semi_cart_tensor_pr1 M_cart x₁ y₁ · f.
  Proof.
    unfold semi_cart_tensor_pr1.
    rewrite !assoc'.
    rewrite <- tensor_runitor.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite <- !tensor_comp_mor.
    rewrite !id_left, !id_right.
    apply maponpaths.
    apply (semi_cart_to_unit_eq M_cart).
  Qed.

  Proposition cartesian_tensor_pr2
              {x₁ x₂ y₁ y₂ : M}
              (f : x₁ --> x₂)
              (g : y₁ --> y₂)
    : f #⊗ g · semi_cart_tensor_pr2 M_cart x₂ y₂
      =
      semi_cart_tensor_pr2 M_cart x₁ y₁ · g.
  Proof.
    unfold semi_cart_tensor_pr2.
    rewrite !assoc'.
    rewrite <- tensor_lunitor.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite <- !tensor_comp_mor.
    rewrite !id_left, !id_right.
    apply maponpaths_2.
    apply (semi_cart_to_unit_eq M_cart).
  Qed.

  Proposition cartesian_tensor_mor
              {x₁ x₂ y₁ y₂ : M}
              (f : x₁ --> x₂)
              (g : y₁ --> y₂)
    : f #⊗ g
      =
      BinProductOfArrows
        _
        (is_cartesian_BinProduct M_cart x₂ y₂)
        (is_cartesian_BinProduct M_cart x₁ y₁)
        f
        g.
  Proof.
    use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)).
    - refine (!_).
      etrans.
      {
        apply (BinProductOfArrowsPr1
                 _
                 (is_cartesian_BinProduct M_cart x₂ y₂)
                 (is_cartesian_BinProduct M_cart x₁ y₁)).
      }
      cbn.
      rewrite cartesian_tensor_pr1.
      apply idpath.
    - refine (!_).
      etrans.
      {
        apply (BinProductOfArrowsPr2
                 _
                 (is_cartesian_BinProduct M_cart x₂ y₂)
                 (is_cartesian_BinProduct M_cart x₁ y₁)).
      }
      cbn.
      rewrite cartesian_tensor_pr2.
      apply idpath.
  Qed.

  Proposition mon_lunitor_pr1
              (x y : M)
    : mon_lunitor (x ⊗ y) · semi_cart_tensor_pr1 M_cart _ _
      =
      identity _ #⊗ semi_cart_tensor_pr1 M_cart _ _ · mon_lunitor x.
  Proof.
    rewrite tensor_lunitor.
    apply idpath.
  Qed.

  Proposition mon_lunitor_pr2
              (x y : M)
    : mon_lunitor (x ⊗ y) · semi_cart_tensor_pr2 M_cart _ _
      =
      identity _ #⊗ semi_cart_tensor_pr2 M_cart _ _ · mon_lunitor y.
  Proof.
    rewrite tensor_lunitor.
    apply idpath.
  Qed.

  Proposition mon_runitor_pr1
              (x y : M)
    : mon_runitor (x ⊗ y) · semi_cart_tensor_pr1 M_cart _ _
      =
      semi_cart_tensor_pr1 M_cart _ _ #⊗ identity _ · mon_runitor x.
  Proof.
    rewrite tensor_runitor.
    apply idpath.
  Qed.

  Proposition mon_runitor_pr2
              (x y : M)
    : mon_runitor (x ⊗ y) · semi_cart_tensor_pr2 M_cart _ _
      =
      semi_cart_tensor_pr2 M_cart _ _ #⊗ identity _ · mon_runitor y.
  Proof.
    rewrite tensor_runitor.
    apply idpath.
  Qed.

  Proposition mon_lassociator_pr1
              (x y z : M)
    : mon_lassociator x y z · semi_cart_tensor_pr1 M_cart _ _
      =
      semi_cart_tensor_pr1 M_cart _ _ · semi_cart_tensor_pr1 M_cart _ _.
  Proof.
    unfold semi_cart_tensor_pr1.
    rewrite !assoc.
    apply maponpaths_2.
    refine (_ @ id_left _).
    rewrite <- mon_lassociator_rassociator.
    rewrite !assoc'.
    apply maponpaths.
    refine (!_).
    rewrite !assoc.
    rewrite <- tensor_id_id.
    rewrite <- tensor_rassociator.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite mon_runitor_triangle.
      apply idpath.
    }
    rewrite <- !tensor_comp_id_l.
    apply maponpaths.
    apply (semi_cart_to_unit_eq M_cart).
  Qed.

  Proposition mon_lassociator_pr2
              (x y z : M)
    : mon_lassociator x y z
      · semi_cart_tensor_pr2 M_cart x (y ⊗ z)
      =
      semi_cart_tensor_pr2 M_cart x y #⊗ identity _.
  Proof.
    unfold semi_cart_tensor_pr2.
    rewrite <- tensor_id_id.
    rewrite !assoc.
    rewrite <- tensor_lassociator.
    rewrite !assoc'.
    rewrite mon_lunitor_triangle.
    rewrite !tensor_comp_id_r.
    apply idpath.
  Qed.

  Proposition cartesian_to_symmetric_laws
    : sym_mon_cat_laws_tensored M cartesian_to_braiding_data.
  Proof.
    repeat split.
    - intros x y.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart x y)).
      + rewrite !assoc' ; cbn.
        etrans.
        {
          apply maponpaths.
          apply cartesian_to_braiding_data_pr1.
        }
        rewrite id_left.
        apply cartesian_to_braiding_data_pr2.
      + rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply cartesian_to_braiding_data_pr2.
        }
        rewrite id_left.
        apply cartesian_to_braiding_data_pr1.
    - intros x₁ x₂ y₁ y₂ f g.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)).
      + rewrite !assoc' ; cbn.
        etrans.
        {
          apply maponpaths.
          apply cartesian_to_braiding_data_pr1.
        }
        rewrite cartesian_tensor_pr2.
        rewrite cartesian_tensor_pr1.
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply cartesian_to_braiding_data_pr1.
      + rewrite !assoc' ; cbn.
        etrans.
        {
          apply maponpaths.
          apply cartesian_to_braiding_data_pr2.
        }
        rewrite cartesian_tensor_pr2.
        rewrite cartesian_tensor_pr1.
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply cartesian_to_braiding_data_pr2.
    - intros x y z.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)) ; cbn.
      + rewrite !assoc'.
        rewrite cartesian_tensor_pr1.
        rewrite id_right.
        rewrite !mon_lassociator_pr1.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          apply cartesian_to_braiding_data_pr1.
        }
        refine (!_).
        rewrite !assoc.
        rewrite cartesian_tensor_pr1.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply cartesian_to_braiding_data_pr1.
        }
        rewrite !assoc.
        rewrite mon_lassociator_pr2.
        rewrite cartesian_tensor_pr1.
        apply idpath.
      + rewrite !assoc'.
        rewrite mon_lassociator_pr2.
        rewrite cartesian_tensor_pr2.
        rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
        rewrite mon_lassociator_pr2.
        rewrite !assoc.
        rewrite <- tensor_comp_id_r.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths_2.
          apply cartesian_to_braiding_data_pr2.
        }
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct M_cart _ _)) ; cbn.
        * rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply cartesian_to_braiding_data_pr1.
          }
          rewrite cartesian_tensor_pr2.
          rewrite id_right.
          rewrite cartesian_tensor_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply cartesian_to_braiding_data_pr1.
          }
          rewrite !assoc.
          rewrite mon_lassociator_pr2.
          rewrite cartesian_tensor_pr2.
          rewrite id_right.
          apply idpath.
        * rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply cartesian_to_braiding_data_pr2.
          }
          rewrite cartesian_tensor_pr2.
          rewrite id_right.
          rewrite cartesian_tensor_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            apply cartesian_to_braiding_data_pr2.
          }
          rewrite mon_lassociator_pr1.
          apply idpath.
  Qed.

  Definition cartesian_to_symmetric
    : symmetric M.
  Proof.
    use make_symmetric.
    - exact cartesian_to_braiding_data.
    - exact cartesian_to_symmetric_laws.
  Defined.
End CartesianSymmetric.

(**
 3. Cocartesian monoidal categories
 *)
Definition is_semicocartesian
           {C : category}
           (M : monoidal C)
  : UU
  := isInitial C (I_{M}).

Section ProjectionsSemiCocartesian.
  Context {M : monoidal_cat}
          (HM : is_semicocartesian M).

  Definition semi_cocart_to_unit
             (x : M)
    : I_{M} --> x
    := InitialArrow (I_{M} ,, HM) x.

  Proposition semi_cocart_from_unit_eq
              {x : M}
              (f g : I_{M} --> x)
    : f = g.
  Proof.
    exact (@InitialArrowEq _ (I_{M} ,, HM) x f g).
  Qed.

  Definition semi_cocart_tensor_inl
             (x y : M)
    : x --> x ⊗ y
    := mon_rinvunitor x · identity _ #⊗ semi_cocart_to_unit y.

  Definition semi_cocart_tensor_inr
             (x y : M)
    : y --> x ⊗ y
    := mon_linvunitor y · semi_cocart_to_unit x #⊗ identity _.
End ProjectionsSemiCocartesian.

Definition tensor_isBinCoproduct
           {M : monoidal_cat}
           (HM : is_semicocartesian M)
  : UU
  := ∏ (x y : M),
     isBinCoproduct
       _ _ _ _
       (semi_cocart_tensor_inl HM x y)
       (semi_cocart_tensor_inr HM x y).

Definition is_cocartesian
           (M : monoidal_cat)
  : UU
  := ∑ (HM : is_semicocartesian M), tensor_isBinCoproduct HM.

Coercion is_cocartesian_to_semicocartesian
         {M : monoidal_cat}
         (M_cocart : is_cocartesian M)
  : is_semicocartesian M
  := pr1 M_cocart.

Definition is_cartesian_BinCoproduct
           {M : monoidal_cat}
           (M_cocart : is_cocartesian M)
           (x y : M)
  : BinCoproduct x y
  := make_BinCoproduct _ _ _ _ _ _ (pr2 M_cocart x y).


Require Import Coq.Lists.List.

Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Equivalence.
Require Import Defined.
Require Page.
Require Candidate.

Definition obj := Candidate.obj Page.stop.

Inductive tr : @context obj -> judgement -> Prop :=

(* Hypotheses *)

| tr_hyp_tm :
    forall G i a,
      index i G (hyp_tm a)
      -> tr G (deq (var i) (var i) (subst (sh (S i)) a))

| tr_hyp_tp :
    forall G i,
      index i G hyp_tp
      -> tr G (deqtype (var i) (var i))

(* Pi/Arrow/Karrow/Intersect *)

| tr_pi_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype b b')
      -> tr G (deqtype (pi a b) (pi a' b'))

| tr_pi_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq b b' (univ (subst sh1 lv)))
      -> tr G (deq (pi a b) (pi a' b') (univ lv))

| tr_pi_intro :
    forall G a b m n,
      tr G (deqtype a a)
      -> tr (cons (hyp_tm a) G) (deq m n b)
      -> tr G (deq (lam m) (lam n) (pi a b))

| tr_pi_elim :
    forall G a b m n p q,
      tr G (deq m n (pi a b))
      -> tr G (deq p q a)
      -> tr G (deq (app m p) (app n q) (subst1 p b))

| tr_pi_eta :
    forall G a b m,
      tr G (deq m m (pi a b))
      -> tr G (deq m (lam (app (subst sh1 m) (var 0))) (pi a b))

| tr_pi_ext :
    forall G a b m n a' a'' b' b'',
      tr G (deqtype a a)
      -> tr (cons (hyp_tm a) G)
           (deq
              (app (subst sh1 m) (var 0))
              (app (subst sh1 n) (var 0))
              b)
      -> tr G (deq m m (pi a' b'))
      -> tr G (deq n n (pi a'' b''))
      -> tr G (deq m n (pi a b))

| tr_arrow_kind_formation :
    forall G lv a b k l,
      tr G (deq a b (univ lv))
      -> tr G (deq k l (kuniv lv))
      -> tr G (deq (arrow a k) (arrow b l) (kuniv lv))

| tr_arrow_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr G (deqtype b b')
      -> tr G (deqtype (arrow a b) (arrow a' b'))

| tr_arrow_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr G (deq b b' (univ lv))
      -> tr G (deq (arrow a b) (arrow a' b') (univ lv))

| tr_arrow_pi_equal :
    forall G a b,
      tr G (deqtype a a)
      -> tr G (deqtype b b)
      -> tr G (deqtype (arrow a b) (pi a (subst sh1 b)))

| tr_arrow_pi_equal_univ :
    forall G lv a b,
      tr G (deq a a (univ lv))
      -> tr G (deq b b (univ lv))
      -> tr G (deq (arrow a b) (pi a (subst sh1 b)) (univ lv))

| tr_arrow_eta :
    forall G a b m,
      tr G (deq m m (arrow a b))
      -> tr G (deq m (lam (app (subst sh1 m) (var 0))) (arrow a b))

| tr_karrow_kind_formation :
    forall G lv k k' l l',
      tr G (deq k k' (kuniv lv))
      -> tr G (deq l l' (kuniv lv))
      -> tr G (deq (karrow k l) (karrow k' l') (kuniv lv))

| tr_karrow_formation :
    forall G k k' l l',
      tr G (deqtype k k')
      -> tr G (deqtype l l')
      -> tr G (deqtype (karrow k l) (karrow k' l'))

| tr_karrow_formation_univ :
    forall G lv k k' l l',
      tr G (deq k k' (univ lv))
      -> tr G (deq l l' (univ lv))
      -> tr G (deq (karrow k l) (karrow k' l') (univ lv))

| tr_karrow_pi_equal :
    forall G a b,
      tr G (deqtype a a)
      -> tr G (deqtype b b)
      -> tr G (deqtype (karrow a b) (pi a (subst sh1 b)))

| tr_karrow_pi_equal_univ :
    forall G lv a b,
      tr G (deq a a (univ lv))
      -> tr G (deq b b (univ lv))
      -> tr G (deq (karrow a b) (pi a (subst sh1 b)) (univ lv))

| tr_arrow_karrow_equal :
    forall G a b,
      tr G (deqtype a a)
      -> tr G (deqtype b b)
      -> tr G (deqtype (arrow a b) (karrow a b))

| tr_arrow_karrow_equal_univ :
    forall G lv a b,
      tr G (deq a a (univ lv))
      -> tr G (deq b b (univ lv))
      -> tr G (deq (arrow a b) (karrow a b) (univ lv))

| tr_karrow_eta :
    forall G a b m,
      tr G (deq m m (karrow a b))
      -> tr G (deq m (lam (app (subst sh1 m) (var 0))) (karrow a b))

| tr_pi_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (pi a b) (pi a' b'))
      -> tr G (deqtype a a')

| tr_pi_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (pi a b) (pi a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype b b')

| tr_arrow_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (arrow a b) (arrow a' b'))
      -> tr G (deqtype a a')

| tr_arrow_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (arrow a b) (arrow a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype (subst sh1 b) (subst sh1 b'))

| tr_karrow_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (karrow a b) (karrow a' b'))
      -> tr G (deqtype a a')

| tr_karrow_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (karrow a b) (karrow a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype (subst sh1 b) (subst sh1 b'))

| tr_intersect_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype b b')
      -> tr G (deqtype (intersect a b) (intersect a' b'))

| tr_intersect_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq b b' (univ (subst sh1 lv)))
      -> tr G (deq (intersect a b) (intersect a' b') (univ lv))

| tr_intersect_intro :
    forall G a b m n,
      tr G (deqtype a a)
      -> tr (cons (hyp_tm a) G) (deq (subst sh1 m) (subst sh1 n) b)
      -> tr G (deq m n (intersect a b))

| tr_intersect_elim :
    forall G a b m n p q,
      tr G (deq m n (intersect a b))
      -> tr G (deq p q a)
      -> tr G (deq m n (subst1 p b))

| tr_intersect_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (intersect a b) (intersect a' b'))
      -> tr G (deqtype a a')

| tr_intersect_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (intersect a b) (intersect a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype b b')

(* Strong sums *)

| tr_sigma_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype b b')
      -> tr G (deqtype (sigma a b) (sigma a' b'))

| tr_sigma_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq b b' (univ (subst sh1 lv)))
      -> tr G (deq (sigma a b) (sigma a' b') (univ lv))

| tr_sigma_intro :
    forall G a b m m' n n',
      tr G (deq m m' a)
      -> tr G (deq n n' (subst1 m b))
      -> tr (cons (hyp_tm a) G) (deqtype b b)
      -> tr G (deq (ppair m n) (ppair m' n') (sigma a b))

| tr_sigma_elim1 :
    forall G a b m n,
      tr G (deq m n (sigma a b))
      -> tr G (deq (ppi1 m) (ppi1 n) a)

| tr_sigma_elim2 :
    forall G a b m n,
      tr G (deq m n (sigma a b))
      -> tr G (deq (ppi2 m) (ppi2 n) (subst1 (ppi1 m) b))

| tr_sigma_eta :
    forall G a b m,
      tr G (deq m m (sigma a b))
      -> tr G (deq m (ppair (ppi1 m) (ppi2 m)) (sigma a b))

| tr_sigma_eta_hyp :
    forall G1 G2 a b m n c,
      tr (substctx (dot (ppair (var 1) (var 0)) (sh 2)) G2 ++ cons (hyp_tm b) (cons (hyp_tm a) G1)) (deq m n (subst (under (length G2) (dot (ppair (var 1) (var 0)) (sh 2))) c))
      -> tr (G2 ++ cons (hyp_tm (sigma a b)) G1) (deq (subst (under (length G2) (dot (ppi2 (var 0)) (dot (ppi1 (var 0)) sh1))) m) (subst (under (length G2) (dot (ppi2 (var 0)) (dot (ppi1 (var 0)) sh1))) n) c)

| tr_sigma_ext :
    forall G a b m n a' a'' b' b'',
      tr G (deq (ppi1 m) (ppi1 n) a)
      -> tr G (deq (ppi2 m) (ppi2 n) (subst1 (ppi1 m) b))
      -> tr (cons (hyp_tm a) G) (deqtype b b)
      -> tr G (deq m m (sigma a' b'))
      -> tr G (deq n n (sigma a'' b''))
      -> tr G (deq m n (sigma a b))

| tr_prod_kind_formation :
    forall G lv k k' l l',
      tr G (deq k k' (kuniv lv))
      -> tr G (deq l l' (kuniv lv))
      -> tr G (deq (prod k l) (prod k' l') (kuniv lv))

| tr_prod_formation :
    forall G k k' l l',
      tr G (deqtype k k')
      -> tr G (deqtype l l')
      -> tr G (deqtype (prod k l) (prod k' l'))

| tr_prod_formation_univ :
    forall G lv k k' l l',
      tr G (deq k k' (univ lv))
      -> tr G (deq l l' (univ lv))
      -> tr G (deq (prod k l) (prod k' l') (univ lv))

| tr_prod_sigma_equal :
    forall G a b,
      tr G (deqtype a a)
      -> tr G (deqtype b b)
      -> tr G (deqtype (prod a b) (sigma a (subst sh1 b)))

| tr_prod_sigma_equal_univ :
    forall G lv a b,
      tr G (deq a a (univ lv))
      -> tr G (deq b b (univ lv))
      -> tr G (deq (prod a b) (sigma a (subst sh1 b)) (univ lv))

| tr_prod_elim1 :
    forall G a b m n,
      tr G (deq m n (prod a b))
      -> tr G (deq (ppi1 m) (ppi1 n) a)

| tr_prod_elim2 :
    forall G a b m n,
      tr G (deq m n (prod a b))
      -> tr G (deq (ppi2 m) (ppi2 n) b)

| tr_sigma_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (sigma a b) (sigma a' b'))
      -> tr G (deqtype a a')

| tr_sigma_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (sigma a b) (sigma a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype b b')

| tr_prod_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (prod a b) (prod a' b'))
      -> tr G (deqtype a a')

| tr_prod_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (prod a b) (prod a' b'))
      -> tr (cons (hyp_tm a) G) (deqtype (subst sh1 b) (subst sh1 b'))

(* Fut *)

| tr_fut_kind_formation :
    forall G lv k k',
      tr (promote G) (deq k k' (kuniv lv))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq (fut k) (fut k') (kuniv lv))

| tr_fut_formation :
    forall G a b,
      tr (promote G) (deqtype a b)
      -> tr G (deqtype (fut a) (fut b))

| tr_fut_formation_univ :
    forall G lv a b,
      tr (promote G) (deq a b (univ lv))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq (fut a) (fut b) (univ lv))

| tr_fut_intro :
    forall G m n a,
      tr (promote G) (deq m n a)
      -> tr G (deq (next m) (next n) (fut a))

| tr_fut_elim :
    forall G m n a p q b,
      tr G (deq m n (fut a))
      -> tr (promote G) (deqtype a a)
      -> tr (cons (hyp_tml a) G) (deq p q b)
      -> tr G (deq (subst1 (prev m) p) (subst1 (prev n) q) (subst1 (prev m) b))

| tr_fut_elim_eqtype :
    forall G m n a b c,
      tr G (deq m n (fut a))
      -> tr (promote G) (deqtype a a)
      -> tr (cons (hyp_tml a) G) (deqtype b c)
      -> tr G (deqtype (subst1 (prev m) b) (subst1 (prev n) c))

| tr_fut_eta :
    forall G m a,
      tr G (deq m m (fut a))
      -> tr G (deq m (next (prev m)) (fut a))

| tr_fut_eta_hyp :
    forall G1 G2 a m n b,
      tr (promote G1) (deqtype a a)
      -> tr (substctx (dot (next (var 0)) sh1) G2 ++ cons (hyp_tml a) G1) (deq m n (subst (under (length G2) (dot (next (var 0)) sh1)) b))
      -> tr (G2 ++ cons (hyp_tm (fut a)) G1) (deq (subst (under (length G2) (dot (prev (var 0)) sh1)) m) (subst (under (length G2) (dot (prev (var 0)) sh1)) n) b)

| tr_fut_ext :
    forall G a b c m n,
      tr G (deq m m (fut b))
      -> tr G (deq n n (fut c))
      -> tr G (deq (next (prev m)) (next (prev n)) (fut a))
      -> tr G (deq m n (fut a))

(* Guarded recursive types *)

| tr_rec_kind_formation :
    forall G lv k k',
      tr (cons (hyp_tml (kuniv lv)) G) (deq k k' (kuniv (subst sh1 lv)))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq (rec k) (rec k') (kuniv lv))

| tr_rec_formation :
    forall G a b,
      tr (cons hyp_tpl G) (deqtype a b)
      -> tr G (deqtype (rec a) (rec b))

| tr_rec_formation_univ :
    forall G lv a b,
      tr (cons (hyp_tml (univ lv)) G) (deq a b (univ (subst sh1 lv)))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq (rec a) (rec b) (univ lv))

| tr_rec_unroll :
    forall G a,
      tr (cons hyp_tpl G) (deqtype a a)
      -> tr G (deqtype (rec a) (subst1 (rec a) a))

| tr_rec_unroll_univ :
    forall G lv a,
      tr (cons (hyp_tml (univ lv)) G) (deq a a (univ (subst sh1 lv)))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq (rec a) (subst1 (rec a) a) (univ lv))

| tr_rec_bisim :
    forall G a b,
      tr (cons hyp_tpl G) (deqtype a a)
      -> tr G (deqtype b (subst1 b a))
      -> tr G (deqtype b (rec a))

(* Void *)

| tr_voidtp_formation_univ :
    forall G,
      tr G (deq voidtp voidtp (univ nzero))

| tr_voidtp_elim :
    forall G m n p q a,
      tr G (deq m n voidtp)
      -> tr G (deq p q a)

(* Unit *)

| tr_unittp_kind_formation :
    forall G lv,
      tr G (deq lv lv pagetp)
      -> tr G (deq unittp unittp (kuniv lv))

| tr_unittp_formation_univ :
    forall G,
      tr G (deq unittp unittp (univ nzero))

| tr_unittp_intro :
    forall G,
      tr G (deq triv triv unittp)

| tr_unittp_eta :
    forall G p,
      tr G (deq p p unittp)
      -> tr G (deq p triv unittp)

| tr_unittp_eta_hyp :
    forall G1 G2 m n b,
      tr (substctx (dot triv id) G2 ++ G1) (deq m n (subst (under (length G2) (dot triv id)) b))
      -> tr (G2 ++ hyp_tm unittp :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) b)

(* Bool *)

| tr_booltp_formation_univ :
    forall G,
      tr G (deq booltp booltp (univ nzero))

| tr_booltp_intro_btrue :
    forall G,
      tr G (deq btrue btrue booltp)

| tr_booltp_intro_bfalse :
    forall G,
      tr G (deq bfalse bfalse booltp)

| tr_booltp_elim :
    forall G m n p q r s a,
      tr G (deq m n booltp)
      -> tr G (deq p q (subst1 btrue a))
      -> tr G (deq r s (subst1 bfalse a))
      -> tr G (deq (bite m p r) (bite n q s) (subst1 m a))

| tr_booltp_elim_eqtype :
    forall G m n a b c d,
      tr G (deq m n booltp)
      -> tr G (deqtype a b)
      -> tr G (deqtype c d)
      -> tr G (deqtype (bite m a c) (bite n b d))

| tr_booltp_eta_hyp :
    forall G1 G2 m n p q a,
      tr (substctx (dot btrue id) G2 ++ G1) (deq m n (subst (under (length G2) (dot btrue id)) a))
      -> tr (substctx (dot bfalse id) G2 ++ G1) (deq p q (subst (under (length G2) (dot bfalse id)) a))
      -> tr (G2 ++ cons (hyp_tm booltp) G1)
           (deq
              (bite (var (length G2))
                 (subst (under (length G2) sh1) m)
                 (subst (under (length G2) sh1) p))
              (bite (var (length G2))
                 (subst (under (length G2) sh1) n)
                 (subst (under (length G2) sh1) q) )
              a)

(* W-types (obsolete) *)

| tr_wt_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype b b')
      -> tr G (deqtype (wt a b) (wt a' b'))

| tr_wt_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq b b' (univ (subst sh1 lv)))
      -> tr G (deq (wt a b) (wt a' b') (univ lv))

| tr_wt_elim :
    forall G a b c m m' n n',
      tr G (deq m m' (wt a b))
      -> tr
           (cons
              (hyp_tm (pi (subst sh1 b) (subst (dot (app (var 1) (var 0)) (sh 3)) c)))
              (cons (hyp_tm (arrow b (subst sh1 (wt a b)))) (cons (hyp_tm a) G)))
           (deq n n' (subst (dot (ppair (var 2) (var 1)) (sh 3)) c))
      -> tr G (deq (app (wind (lam (lam (lam n)))) m) (app (wind (lam (lam (lam n')))) m') (subst1 m c))

| tr_wt_subtype_sigma :
    forall G a b,
      tr G (deqtype a a)
      -> tr (cons (hyp_tm a) G) (deqtype b b)
      -> tr G (dsubtype (wt a b) (sigma a (arrow b (subst sh1 (wt a b)))))

| tr_wt_sigma_subtype :
    forall G a b,
      tr G (deqtype a a)
      -> tr (cons (hyp_tm a) G) (deqtype b b)
      -> tr G (dsubtype (sigma a (arrow b (subst sh1 (wt a b)))) (wt a b))

| tr_wt_formation_inv1 :
    forall G a b,
      tr G (deqtype (wt a b) (wt a b))
      -> tr G (deqtype a a)

| tr_wt_formation_inv2 :
    forall G a b,
      tr G (deqtype (wt a b) (wt a b))
      -> tr (cons (hyp_tm a) G) (deqtype b b)

(* Impredicative polymorphism *)

| tr_all_formation :
    forall G glv k l a b,
      tr G (deq k l (kuniv glv))
      -> tr (cons (hyp_tm k) G) (deqtype a b)
      -> tr G (deqtype (all glv k a) (all glv l b))

| tr_all_formation_univ :
    forall G glv lv k l a b,
      tr G (deq k l (kuniv glv))
      -> tr (cons (hyp_tm k) G) (deq a b (univ (subst sh1 lv)))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq triv triv (leqpagetp glv lv))
      -> tr G (deq (all glv k a) (all glv l b) (univ lv))

| tr_all_intro :
    forall G lv k a m n,
      tr G (deq k k (kuniv lv))
      -> tr (cons (hyp_tm k) G) (deq (subst sh1 m) (subst sh1 n) a)
      -> tr G (deq m n (all lv k a))

| tr_all_elim :
    forall G lv k a m n p,
      tr G (deq m n (all lv k a))
      -> tr G (deq p p k)
      -> tr (cons (hyp_tm k) G) (deqtype a a)
      -> tr G (deq m n (subst1 p a))

| tr_alltp_formation :
    forall G a b,
      tr (cons hyp_tp G) (deqtype a b)
      -> tr G (deqtype (alltp a) (alltp b))

| tr_alltp_intro :
    forall G a m n,
      tr (cons hyp_tp G) (deq (subst sh1 m) (subst sh1 n) a)
      -> tr G (deq m n (alltp a))

| tr_alltp_elim :
    forall G a b m n,
      tr G (deq m n (alltp a))
      -> tr G (deqtype b b)
      -> tr (cons hyp_tp G) (deqtype a a)
      -> tr G (deq m n (subst1 b a))

(* Impredicative existential *)

| tr_exist_formation :
    forall G glv k l a b,
      tr G (deq k l (kuniv glv))
      -> tr (cons (hyp_tm k) G) (deqtype a b)
      -> tr G (deqtype (exist glv k a) (exist glv l b))

| tr_exist_formation_univ :
    forall G glv lv k l a b,
      tr G (deq k l (kuniv glv))
      -> tr (cons (hyp_tm k) G) (deq a b (univ (subst sh1 lv)))
      -> tr G (deq lv lv pagetp)
      -> tr G (deq triv triv (leqpagetp glv lv))
      -> tr G (deq (exist glv k a) (exist glv l b) (univ lv))

| tr_exist_intro :
    forall G lv k a b m n,
      tr G (deq k k (kuniv lv))
      -> tr G (deq b b k)
      -> tr G (deq m n (subst1 b a))
      -> tr (cons (hyp_tm k) G) (deqtype a a)
      -> tr G (deq m n (exist lv k a))

| tr_exist_elim :
    forall G lv k a b m n p q,
      tr G (deq m n (exist lv k a))
      -> tr G (deqtype k k)
      -> tr (cons (hyp_tm k) G) (deqtype a a)
      -> tr (cons (hyp_tm a) (cons (hyp_tm k) G)) (deq (subst (dot (var 0) (sh 2)) p) (subst (dot (var 0) (sh 2)) q) (subst (sh 2) b))
      -> tr G (deq (subst1 m p) (subst1 n q) b)

| tr_exist_elim_eqtype :
    forall G lv k a m n p q,
      tr G (deq m n (exist lv k a))
      -> tr G (deqtype k k)
      -> tr (cons (hyp_tm k) G) (deqtype a a)
      -> tr (cons (hyp_tm a) (cons (hyp_tm k) G)) (deqtype (subst (dot (var 0) (sh 2)) p) (subst (dot (var 0) (sh 2)) q))
      -> tr G (deqtype (subst1 m p) (subst1 n q))

(* Inductive types *)

| tr_mu_formation :
    forall G a b,
      tr (hyp_tp :: G) (deqtype a b)
      -> tr G (deq triv triv (ispositive a))
      -> tr G (deq triv triv (ispositive b))
      -> tr G (deqtype (mu a) (mu b))

| tr_mu_formation_univ :
    forall G lv a b,
      tr G (deq lv lv pagetp)
      -> tr (hyp_tm (univ lv) :: G) (deq a b (univ (subst sh1 lv)))
      -> tr G (deq triv triv (ispositive a))
      -> tr G (deq triv triv (ispositive b))
      -> tr G (deq (mu a) (mu b) (univ lv))

| tr_mu_roll :
    forall G a,
      tr (hyp_tp :: G) (deqtype a a)
      -> tr G (deq triv triv (ispositive a))
      -> tr G (dsubtype (subst1 (mu a) a) (mu a))

| tr_mu_unroll :
    forall G a,
      tr (hyp_tp :: G) (deqtype a a)
      -> tr G (deq triv triv (ispositive a))
      -> tr G (dsubtype (mu a) (subst1 (mu a) a))

| tr_mu_roll_univ :
    forall G lv a,
      tr G (deq lv lv pagetp)
      -> tr (hyp_tm (univ lv) :: G) (deq a a (univ (subst sh1 lv)))
      -> tr G (deq triv triv (ispositive a))
      -> tr G (dsubtype (subst1 (mu a) a) (mu a))

| tr_mu_unroll_univ :
    forall G lv a,
      tr G (deq lv lv pagetp)
      -> tr (hyp_tm (univ lv) :: G) (deq a a (univ (subst sh1 lv)))
      -> tr G (deq triv triv (ispositive a))
      -> tr G (dsubtype (mu a) (subst1 (mu a) a))

| tr_mu_ind :
    forall G a b m,
      tr (hyp_tp :: G) (deqtype a a)
      -> tr G (deq triv triv (ispositive a))
      -> tr
           (hyp_tm (pi (var 2) (subst (under 1 (sh 3)) b)) ::
            hyp_tm (subtype (var 1) (mu (subst (under 1 (sh 2)) a))) ::
            hyp_tm a ::
            hyp_tp ::
            G)
           (deq triv triv (subst (dot (var 2) (sh 4)) b))
      -> tr G (deq m m (mu a))
      -> tr G (deq triv triv (subst1 m b))

| tr_mu_ind_univ :
    forall G lv a b m,
      tr G (deq lv lv pagetp)
      -> tr (hyp_tm (univ lv) :: G) (deq a a (univ (subst sh1 lv)))
      -> tr G (deq triv triv (ispositive a))
      -> tr
           (hyp_tm (pi (var 2) (subst (under 1 (sh 3)) b)) ::
            hyp_tm (subtype (var 1) (mu (subst (under 1 (sh 2)) a))) ::
            hyp_tm a ::
            hyp_tm (univ lv) ::
            G)
           (deq
              (subst (dot (var 2) (sh 4)) b)
              (subst (dot (var 2) (sh 4)) b)
              (univ (subst (sh 4) lv)))
      -> tr
           (hyp_tm (pi (var 2) (subst (under 1 (sh 3)) b)) ::
            hyp_tm (subtype (var 1) (mu (subst (under 1 (sh 2)) a))) ::
            hyp_tm a ::
            hyp_tm (univ lv) ::
            G)
           (deq triv triv (subst (dot (var 2) (sh 4)) b))
      -> tr G (deq m m (mu a))
      -> tr G (deq triv triv (subst1 m b))

(* Positive/Negative *)

| tr_positive_algorithm :
    forall G a P N,
      hpositive P N 0 a
      -> (forall b,
            In b P
            -> tr G (deq triv triv (ispositive b)))
      -> (forall b,
            In b N
            -> tr G (deq triv triv (isnegative b)))
      -> tr G (deq triv triv (ispositive a))

| tr_positive_eta :
    forall G a p,
      tr G (deq p p (ispositive a))
      -> tr G (deq p triv (ispositive a))

| tr_negative_algorithm :
    forall G a P N,
      hnegative P N 0 a
      -> (forall b,
            In b P
            -> tr G (deq triv triv (ispositive b)))
      -> (forall b,
            In b N
            -> tr G (deq triv triv (isnegative b)))
      -> tr G (deq triv triv (isnegative a))

| tr_negative_eta :
    forall G a p,
      tr G (deq p p (isnegative a))
      -> tr G (deq p triv (isnegative a))

(* Equality *)

| tr_equal_formation :
    forall G a b m n p q,
      tr G (deqtype a b)
      -> tr G (deq m n a)
      -> tr G (deq p q a)
      -> tr G (deqtype (equal a m p) (equal b n q))

| tr_equal_formation_univ :
    forall G lv a b m n p q,
      tr G (deq a b (univ lv))
      -> tr G (deq m n a)
      -> tr G (deq p q a)
      -> tr G (deq (equal a m p) (equal b n q) (univ lv))

| tr_equal_intro :
    forall G a m n,
      tr G (deq m n a)
      -> tr G (deq triv triv (equal a m n))

| tr_equal_elim :
    forall G a m n,
      tr G (deq triv triv (equal a m n))
      -> tr G (deq m n a)

| tr_equal_eta :
    forall G a m n p,
      tr G (deq p p (equal a m n))
      -> tr G (deq p triv (equal a m n))

| tr_equal_eta_hyp :
    forall G1 G2 a p q m n b,
      tr (substctx (dot triv id) G2 ++ G1) (deq m n (subst (under (length G2) (dot triv id)) b))
      -> tr (G2 ++ hyp_tm (equal a p q) :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) b)

| tr_equal_formation_invert1 :
    forall G a a' m m' n n',
      tr G (deqtype (equal a m n) (equal a' m' n'))
      -> tr G (deqtype a a')

| tr_equal_formation_invert1_univ :
    forall G lv a a' m m' n n',
      tr G (deq (equal a m n) (equal a' m' n') (univ lv))
      -> tr G (deq a a' (univ lv))

| tr_equal_formation_invert2 :
    forall G a a' m m' n n',
      tr G (deqtype (equal a m n) (equal a' m' n'))
      -> tr G (deq m m' a)

| tr_equal_formation_invert3 :
    forall G a a' m m' n n',
      tr G (deqtype (equal a m n) (equal a' m' n'))
      -> tr G (deq n n' a)

(* Set Types *)

| tr_set_formation :
    forall G a a' b b' mr ml,
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype b b)
      -> tr (cons (hyp_tm a) G) (deqtype b' b')
      (* b implies b' *)
      -> tr (hyp_tm b :: hyp_tm a :: G)
           (deq mr mr (subst sh1 b'))
      (* b' implies b *)
      -> tr (hyp_tm b' :: hyp_tm a :: G)
           (deq ml ml (subst sh1 b))
      -> tr G (deqtype (set a b) (set a' b'))

| tr_set_formation_univ :
    forall G lv a a' b b' mr ml,
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq b b (univ (subst sh1 lv)))
      -> tr (cons (hyp_tm a) G) (deq b' b' (univ (subst sh1 lv)))
      (* b implies b' *)
      -> tr (hyp_tm b :: hyp_tm a :: G)
           (deq mr mr (subst sh1 b'))
      (* b' implies b *)
      -> tr (hyp_tm b' :: hyp_tm a :: G)
           (deq ml ml (subst sh1 b))
      -> tr G (deq (set a b) (set a' b') (univ lv))

| tr_set_intro :
    forall G a b m n p,
      tr G (deq m n a)
      -> tr G (deq p p (subst1 m b))
      -> tr (hyp_tm a :: G) (deqtype b b)
      -> tr G (deq m n (set a b))

| tr_set_elim1 :
    forall G a b m n,
      tr G (deq m n (set a b))
      -> tr G (deq m n a)

| tr_set_elim2 :
    forall G a b m J,
      tr G (deq m m (set a b))
      -> tr (hyp_tm a :: G) (deqtype b b)
      -> tr (hyp_tm (subst1 m b) :: G) (substj sh1 J)
      -> tr G J

| tr_set_hyp_weaken :
    forall G1 G2 a b J,
      tr (G2 ++ hyp_tm b :: hyp_tm a :: G1) J
      -> tr (G2 ++ hyp_tm b :: hyp_tm (set a b) :: G1) J

| tr_set_formation_invert :
    forall G a a' b b',
      tr G (deqtype (set a b) (set a' b'))
      -> tr G (deqtype a a')

| tr_squash_idem :
    forall G a b,
      tr G (deqtype (set a b) (set a b))
      -> tr G (deqtype (set a b) (set a (squash b)))

(* Quotient types *)

| tr_quotient_formation :
    forall G a a' b b' mr ml ms mt,
      tr G (deqtype a a')
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype b b)
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype b' b')
      (* b implies b' *)
      -> tr (hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G)
           (deq mr mr (subst sh1 b'))
      (* b' implies b *)
      -> tr (hyp_tm b' :: hyp_tm (subst sh1 a) :: hyp_tm a :: G)
           (deq ml ml (subst sh1 b))
      (* symmetry *)
      -> tr (hyp_tm b ::
             hyp_tm (subst sh1 a) ::
             hyp_tm a ::
             G)
           (deq ms ms (subst (dot (var 2) (dot (var 1) (sh 3))) b))
      (* transitivity *)
      -> tr (hyp_tm (subst (dot (var 1) (dot (var 2) (sh 4))) b) ::
             hyp_tm (subst sh1 b) ::
             hyp_tm (subst (sh 2) a) ::
             hyp_tm (subst sh1 a) ::
             hyp_tm a ::
             G)
           (deq mt mt (subst (dot (var 2) (dot (var 4) (sh 5))) b))
      -> tr G (deqtype (quotient a b) (quotient a' b'))

| tr_quotient_formation_univ :
    forall G lv a a' b b' mr ml ms mt,
      tr G (deq a a' (univ lv))
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deq b b (univ (subst (sh 2) lv)))
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deq b' b' (univ (subst (sh 2) lv)))
      (* b implies b' *)
      -> tr (hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G)
           (deq mr mr (subst sh1 b'))
      (* b' implies b *)
      -> tr (hyp_tm b' :: hyp_tm (subst sh1 a) :: hyp_tm a :: G)
           (deq ml ml (subst sh1 b))
      (* symmetry *)
      -> tr (hyp_tm b ::
              hyp_tm (subst sh1 a) ::
              hyp_tm a ::
              G)
           (deq ms ms (subst (dot (var 2) (dot (var 1) (sh 3))) b))
      (* transitivity *)
      -> tr (hyp_tm (subst (dot (var 1) (dot (var 2) (sh 4))) b) ::
              hyp_tm (subst sh1 b) ::
              hyp_tm (subst (sh 2) a) ::
              hyp_tm (subst sh1 a) ::
              hyp_tm a ::
              G)
           (deq mt mt (subst (dot (var 2) (dot (var 4) (sh 5))) b))
      -> tr G (deq (quotient a b) (quotient a' b') (univ lv))

| tr_quotient_intro :
    forall G a b m n p,
      tr G (deqtype (quotient a b) (quotient a b))
      -> tr G (deq m m a)
      -> tr G (deq n n a)
      -> tr G (deq p p (subst (dot n (dot m id)) b))
      -> tr G (deq m n (quotient a b))

| tr_quotient_elim :
    forall G a b c m n p q,
      tr G (deq m n (quotient a b))
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype b b)
      -> tr (hyp_tm (quotient a b) :: G) (deqtype c c)
      -> tr (hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deq (subst (sh 2) p) (subst (dot (var 1) (sh 3)) q) (subst (sh 2) c))
      -> tr G (deq (subst1 m p) (subst1 n q) (subst1 m c))

| tr_quotient_elim_eqtype :
    forall G a b m n c d,
      tr G (deq m n (quotient a b))
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype b b)
      -> tr (hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype (subst (sh 2) c) (subst (dot (var 1) (sh 3)) d))
      -> tr G (deqtype (subst1 m c) (subst1 n d))

| tr_descent :
    forall G a b c m n p,
      tr G (deq m m a)
      -> tr G (deq n n a)
      -> tr G (deq m n (quotient a b))
      -> tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G) (deqtype b b)
      -> tr G (deqtype c c)
      -> tr (hyp_tm (subst (dot n (dot m id)) b) :: G) (deq (subst sh1 p) (subst sh1 p) (subst sh1 c))
      -> tr G (deq p p c)

| tr_quotient_hyp :
    forall G1 G2 a b m n c,
      tr (G2 ++ hyp_tm (quotient a b) :: G1) (deqtype c c)
      -> tr (G2 ++ hyp_tm a :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) c)
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) c)

| tr_quotient_hyp_with_refl :
    forall G1 G2 a b m n c,
      tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G1) (deqtype b b)
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deqtype c c)
      -> tr
           (substctx sh1 G2 ++ hyp_tm (subst (dot (var 0) (dot (var 0) sh1)) b) :: hyp_tm a :: G1)
           (deq
              (subst (under (length G2) (sh 2)) m)
              (subst (under (length G2) (sh 2)) n)
              (subst (under (length G2) sh1) c))
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) c)

| tr_quotient_hyp_eqtype :
    forall G1 G2 a b c d,
      tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G1) (deqtype b b)
      -> tr (substctx (sh 2) G2 ++ hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G1) (deqtype (subst (under (length G2) (sh 2)) c) (subst (under (length G2) (dot (var 1) (sh 3))) d))
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deqtype c d)

| tr_quotient_hyp_eq :
    forall G1 G2 a b c m n,
      tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G1) (deqtype b b)
      -> tr
           (substctx (sh 2) G2 ++ hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G1)
           (deq
              (subst (under (length G2) (sh 2)) m)
              (subst (under (length G2) (dot (var 1) (sh 3))) n)
              (subst (under (length G2) (sh 3)) c))
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deq m n (subst (under (length G2) sh1) c))

| tr_quotient_hyp_eq_dep :
    forall G1 G2 a b c m n,
      tr (hyp_tm (subst sh1 a) :: hyp_tm a :: G1) (deqtype b b)
      -> tr
           (substctx (sh 2) G2 ++ hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G1)
           (deqtype
              (subst (under (length G2) (sh 2)) c)
              (subst (under (length G2) (dot (var 1) (sh 3))) c))
      -> tr
           (substctx (sh 2) G2 ++ hyp_tm b :: hyp_tm (subst sh1 a) :: hyp_tm a :: G1)
           (deq
              (subst (under (length G2) (sh 2)) m)
              (subst (under (length G2) (dot (var 1) (sh 3))) n)
              (subst (under (length G2) (sh 2)) c))
      -> tr (G2 ++ hyp_tm (quotient a b) :: G1) (deq m n c)

| tr_quotient_formation_invert :
    forall G a a' b b',
      tr G (deqtype (quotient a b) (quotient a' b'))
      -> tr G (deqtype a a')

(* Guarded types *)

| tr_guard_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr (cons (hyp_tm a) G) (deqtype (subst sh1 b) (subst sh1 b'))
      -> tr G (deqtype (guard a b) (guard a' b'))

| tr_guard_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr (cons (hyp_tm a) G) (deq (subst sh1 b) (subst sh1 b') (univ (subst sh1 lv)))
      -> tr G (deq (guard a b) (guard a' b') (univ lv))

| tr_guard_sat_eq :
    forall G a b m n,
      tr G (deq m n a)
      -> tr G (deqtype b b)
      -> tr G (deqtype b (guard a b))

| tr_guard_intro :
    forall G a b m n,
      tr G (deqtype a a)
      -> tr (hyp_tm a :: G) (deq (subst sh1 m) (subst sh1 n) (subst sh1 b))
      -> tr G (deq m n (guard a b))

| tr_guard_elim :
    forall G a b m n p q,
      tr G (deq m n (guard a b))
      -> tr G (deq p q a)
      -> tr G (deq m n b)

(* Universes *)

| tr_univ_kind_formation :
    forall G lv lv1 lv2,
      tr G (deq lv1 lv2 pagetp)
      -> tr G (deq lv1 lv pagetp)
      -> tr G (deq (univ lv1) (univ lv2) (kuniv lv))

| tr_univ_formation :
    forall G lv lv',
      tr G (deq lv lv' pagetp)
      -> tr G (deqtype (univ lv) (univ lv'))

| tr_univ_formation_univ :
    forall G lv lv1 lv2,
      tr G (deq lv1 lv2 pagetp)
      -> tr G (deq lv lv pagetp)
      -> tr G (deq triv triv (ltpagetp lv1 lv))
      -> tr G (deq (univ lv1) (univ lv2) (univ lv))

| tr_univ_cumulative :
    forall G lv lv' a b,
      tr G (deq a b (univ lv))
      -> tr G (deq lv' lv' pagetp)
      -> tr G (deq triv triv (leqpagetp lv lv'))
      -> tr G (deq a b (univ lv'))

| tr_formation_weaken :
    forall G lv a b,
      tr G (deq a b (univ lv))
      -> tr G (deqtype a b)

| tr_formation_strengthen :
    forall G lv a b,
      tr G (deqtype a b)
      -> tr G (deq a a (univ lv))
      -> tr G (deq b b (univ lv))
      -> tr G (deq a b (univ lv))

| tr_univ_formation_invert :
    forall G lv lv',
      tr G (deqtype (univ lv) (univ lv'))
      -> tr G (deq lv lv' pagetp)

(* Kind universes *)

| tr_kuniv_formation :
    forall G lv lv',
      tr G (deq lv lv' pagetp)
      -> tr G (deqtype (kuniv lv) (kuniv lv'))

| tr_kuniv_formation_univ :
    forall G lv lv1 lv2,
      tr G (deq lv1 lv2 pagetp)
      -> tr G (deq lv lv pagetp)
      -> tr G (deq triv triv (ltpagetp (nsucc lv1) lv))
      -> tr G (deq (kuniv lv1) (kuniv lv2) (univ lv))

| tr_kuniv_weaken :
    forall G lv a b,
      tr G (deq a b (kuniv lv))
      -> tr G (deq a b (univ (nsucc lv)))

| tr_kuniv_formation_invert :
    forall G lv lv',
      tr G (deqtype (kuniv lv) (kuniv lv'))
      -> tr G (deq lv lv' pagetp)

(* Type equality *)

| tr_eqtype_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr G (deqtype b b')
      -> tr G (deqtype (eqtype a b) (eqtype a' b'))

| tr_eqtype_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr G (deq b b' (univ lv))
      -> tr G (deq (eqtype a b) (eqtype a' b') (univ lv))

| tr_eqtype_convert :
    forall G m n a b,
      tr G (deqtype a b)
      -> tr G (deq m n a)
      -> tr G (deq m n b)

| tr_eqtype_convert_hyp :
    forall G1 G2 a b J,
      tr G1 (deqtype a b)
      -> tr (G2 ++ hyp_tm b :: G1) J
      -> tr (G2 ++ hyp_tm a :: G1) J

| tr_eqtype_symmetry :
    forall G a b,
      tr G (deqtype a b)
      -> tr G (deqtype b a)

| tr_eqtype_transitivity :
    forall G a b c,
      tr G (deqtype a b)
      -> tr G (deqtype b c)
      -> tr G (deqtype a c)

| tr_eqtype_eta :
    forall G a b p,
      tr G (deq p p (eqtype a b))
      -> tr G (deq p triv (eqtype a b))

| tr_eqtype_eta_hyp :
    forall G1 G2 a a' m n b,
      tr (substctx (dot triv id) G2 ++ G1) (deq m n (subst (under (length G2) (dot triv id)) b))
      -> tr (G2 ++ hyp_tm (eqtype a a') :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) b)

| tr_eqtype_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (eqtype a b) (eqtype a' b'))
      -> tr G (deqtype a a')

| tr_eqtype_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (eqtype a b) (eqtype a' b'))
      -> tr G (deqtype b b')

(* Subtyping *)

| tr_subtype_formation :
    forall G a a' b b',
      tr G (deqtype a a')
      -> tr G (deqtype b b')
      -> tr G (deqtype (subtype a b) (subtype a' b'))

| tr_subtype_formation_univ :
    forall G lv a a' b b',
      tr G (deq a a' (univ lv))
      -> tr G (deq b b' (univ lv))
      -> tr G (deq (subtype a b) (subtype a' b') (univ lv))

| tr_subtype_intro :
    forall G a b,
      tr G (deqtype a a)
      -> tr G (deqtype b b)
      -> tr (hyp_tm a :: G) (deq (var 0) (var 0) (subst sh1 b))
      -> tr G (deq triv triv (subtype a b))

| tr_subtype_elim :
    forall G a b m n,
      tr G (deq triv triv (subtype a b))
      -> tr G (deq m n a)
      -> tr G (deq m n b)

| tr_subtype_eta :
    forall G a b p,
      tr G (deq p p (subtype a b))
      -> tr G (deq p triv (subtype a b))

| tr_subtype_eta_hyp :
    forall G1 G2 a a' m n b,
      tr (substctx (dot triv id) G2 ++ G1) (deq m n (subst (under (length G2) (dot triv id)) b))
      -> tr (G2 ++ hyp_tm (subtype a a') :: G1) (deq (subst (under (length G2) sh1) m) (subst (under (length G2) sh1) n) b)

| tr_subtype_convert_hyp :
    forall G1 G2 a b J,
      tr (cons (hyp_tm (eqtype a a)) G1) (dsubtype (subst sh1 a) (subst sh1 b))
      -> tr (cons (hyp_tm (eqtype a a)) G1) (dsubtype (subst sh1 b) (subst sh1 a))
      -> tr (G2 ++ hyp_tm b :: G1) J
      -> tr (G2 ++ hyp_tm a :: G1) J

| tr_subtype_formation_invert1 :
    forall G a a' b b',
      tr G (deqtype (subtype a b) (subtype a' b'))
      -> tr G (deqtype a a')

| tr_subtype_formation_invert2 :
    forall G a a' b b',
      tr G (deqtype (subtype a b) (subtype a' b'))
      -> tr G (deqtype b b')

(* Substitution *)

| tr_substitution :
    forall G1 G2 a m n n' b,
      tr (G2 ++ cons (hyp_tm a) G1) (deqtype b b)
      -> tr (G2 ++ cons (hyp_tm a) G1) (deq (var (length G2)) (subst (sh (S (length G2))) m) (subst (sh (S (length G2))) a))
      -> tr (substctx (dot m id) G2 ++ G1) (deq n n' (subst (under (length G2) (dot m id)) b))
      -> tr (G2 ++ cons (hyp_tm a) G1) (deq (subst (under (length G2) sh1) n) (subst (under (length G2) sh1) n') b)

| tr_substitution_simple :
    forall G1 G2 a m n n' b,
      tr (G2 ++ cons (hyp_tm a) G1) (deq (var (length G2)) (subst (sh (S (length G2))) m) (subst (sh (S (length G2))) a))
      -> tr (substctx (dot m id) G2 ++ G1) (deq n n' b)
      -> tr (G2 ++ cons (hyp_tm a) G1) (deq (subst (under (length G2) sh1) n) (subst (under (length G2) sh1) n') (subst (under (length G2) sh1) b))

| tr_strengthen_context :
    forall G1 G2 a b J,
      tr G1 (deqtype a a)
      -> tr (G2 ++ hyp_tm b :: G1) (dsubtype (subst (sh (S (length G2))) a) (subst (sh (S (length G2))) b))
      -> tr (G2 ++ hyp_tm b :: G1) (deq (var (length G2)) (var (length G2)) (subst (sh (S (length G2))) a))
      -> tr (G2 ++ hyp_tm a :: G1) J
      -> tr (G2 ++ hyp_tm b :: G1) J

| tr_generalize :
    forall G a m J,
      tr G (deq m m a)
      -> tr (cons (hyp_tm a) G) J
      -> tr G (substj (dot m id) J)

| tr_generalize_tp :
    forall G a J,
      tr G (deqtype a a)
      -> tr (cons hyp_tp G) J
      -> tr G (substj (dot a id) J)

| tr_generalize_eq :
    forall G a b m n p q,
      tr G (deq m n a)
      -> tr (cons (hyp_tm a) G) (deq p q b)
      -> tr G (deq (subst1 m p) (subst1 n q) (subst1 m b))

| tr_generalize_eq_type :
    forall G a b m n p q,
      tr G (deq m n a)
      -> tr (cons (hyp_tm a) G) (deq p q b)
      -> tr G (deqtype (subst1 m b) (subst1 n b))

(* Direct computation *)

| tr_compute :
    forall G a a' m m' n n',
      equiv a a'
      -> equiv m m'
      -> equiv n n'
      -> tr G (deq m' n' a')
      -> tr G (deq m n a)

| tr_compute_hyp :
    forall G1 G2 h h' J,
      equivh h h'
      -> tr (G2 ++ cons h' G1) J
      -> tr (G2 ++ cons h G1) J

(* Structural rules *)

| tr_symmetry :
    forall G m n a,
      tr G (deq m n a)
      -> tr G (deq n m a)

| tr_transitivity :
    forall G m n p a,
      tr G (deq m n a)
      -> tr G (deq n p a)
      -> tr G (deq m p a)

| tr_weakening :
    forall G1 G2 h J,
      tr (G2 ++ G1) J
      -> tr (substctx sh1 G2 ++ cons h G1) (substj (under (length G2) sh1) J)

| tr_contraction :
    forall G1 G2 h i m m' a,
      index i G1 h
      -> tr (substctx sh1 G2 ++ substh (sh (S i)) h :: G1) (deq m m' (subst (under (length G2) sh1) a))
      -> tr (G2 ++ G1) (deq (subst (under (length G2) (dot (var i) id)) m) (subst (under (length G2) (dot (var i) id)) m') a)

| tr_exchange :
    forall G1 G2 h1 h2 m m' a,
      tr (substctx (dot (var 1) (dot (var 0) (sh 2))) G2 ++ substh sh1 h1 :: h2 :: G1) (deq m m' (subst (under (length G2) (dot (var 1) (dot (var 0) (sh 2)))) a))
      -> tr (G2 ++ substh sh1 h2 :: h1 :: G1) (deq (subst (under (length G2) (dot (var 1) (dot (var 0) (sh 2)))) m) (subst (under (length G2) (dot (var 1) (dot (var 0) (sh 2)))) m') a)

(* Miscellaneous rules *)

| tr_inhabitation_formation :
    forall G m n a,
      tr G (deq m n a)
      -> tr G (deqtype a a)
.