(**

  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we define a number of theorems to extend Coq's
  standard library to aid our formalisation.

*)

Require Export Coq.micromega.Lia
               Coq.Lists.List
               Coq.Arith.PeanoNat.
Import ListNotations.

Theorem indexed_to_forall {A : Type} (l : list A) : forall P def,
  Forall P l
<->
  (forall i, i < Datatypes.length l -> P (nth i l def)).
Proof.
  induction l; split; intros.
  * inversion H0.
  * constructor.
  * inversion H. subst. destruct i.
    - simpl. auto.
    - simpl. apply IHl. exact H4. simpl in H0. lia.
  * constructor.
    - apply (H 0). simpl. lia.
    - eapply IHl. intros. apply (H (S i)). simpl. lia.
Qed.

Lemma element_exist {A : Type} : forall n (l : list A), S n = Datatypes.length l -> exists e l', l = e::l'.
Proof.
  intros. destruct l.
  * inversion H.
  * apply ex_intro with a. apply ex_intro with l. reflexivity.
Qed.

Theorem map_id {T} : forall (l : list T), List.map id l = l.
Proof.
  induction l; simpl; try rewrite IHl; auto.
Qed.

Theorem last_element_exists {T} :
  forall (l: list T) n, S n = Datatypes.length l -> exists l' x, l = l' ++ [x].
Proof.
  induction l; intros.
  * inversion H.
  * inversion H. destruct l.
    - exists [], a. reflexivity.
    - simpl in H1. epose (IHl (pred n) _). destruct e, H0. subst. rewrite H0.
      exists (a::x), x0. apply app_comm_cons. Unshelve. simpl. lia.
Qed.

(** Similar Forall, but this checks a property that is satisfied pairwise
    by the elements of two lists. *)
Inductive list_biforall {T1 T2 : Type} (P : T1 -> T2 -> Prop) : list T1 -> list T2 -> Prop :=
| biforall_nil : list_biforall P [] []
| biforall_cons hd hd' tl tl' : P hd hd' -> list_biforall P tl tl' -> list_biforall P (hd::tl) (hd'::tl').

Theorem indexed_to_biforall {T1 T2 : Type} : forall (P : T1 -> T2 -> Prop) (l1 : list T1) (l2 : list T2) (d1 : T1) (d2 : T2),
   list_biforall P l1 l2 <-> (forall i, i < length l1 -> P (nth i l1 d1) (nth i l2 d2)) /\ length l1 = length l2.
Proof.
  split; intros.
  * induction H.
    - split; intros; auto. inversion H.
    - destruct IHlist_biforall. split. 2: simpl; lia. destruct i; intros.
      + exact H.
      + apply H1. simpl in H3. lia.
  * destruct H. revert H0 H. generalize dependent l2. generalize dependent d1.
    generalize dependent d2. induction l1; intros.
    - simpl in H0. apply eq_sym, length_zero_iff_nil in H0. subst. constructor.
    - simpl in H0. apply element_exist in H0 as G. destruct G, H1. subst. inversion H0.
      constructor. apply (H 0); simpl; lia. eapply IHl1; auto. intros. apply (H (S i)).
      simpl. lia.
Qed.

Theorem biforall_length :
  forall {T1 T2 : Type} (es : list T1) (es' : list T2) P, list_biforall P es es' -> length es = length es'.
Proof.
  intros. induction H; auto. simpl. auto.
Qed.

Lemma biforall_impl : forall {T1 T2} (l1 : list T1) (l2 : list T2) (P Q : T1 -> T2 -> Prop),
  (forall x y, P x y -> Q x y) ->
  list_biforall P l1 l2 -> list_biforall Q l1 l2.
Proof.
  induction l1; intros; inversion H0; constructor; subst.
  now apply H.
  eapply IHl1; eauto.
Qed.

Lemma biforall_app : forall {T1 T2} (l1 l1' : list T1) (l2 l2' : list T2) P,
  list_biforall P l1 l2 -> list_biforall P l1' l2'
->
  list_biforall P (l1 ++ l1') (l2 ++ l2').
Proof.
  induction l1; intros.
  * inversion H. auto.
  * inversion H. subst. do 2 rewrite <- app_comm_cons. constructor; auto.
Qed.

Lemma biforall_map :
  forall {T1 T2 T1' T2'} l l' f1 f2 (P : T1 -> T2 -> Prop) (Q : T1' -> T2' -> Prop), list_biforall P l l' ->
  (forall x y, P x y -> Q (f1 x) (f2 y))
->
  list_biforall Q (map f1 l) (map f2 l').
Proof.
  induction l; intros; inversion H; simpl; constructor; subst.
  * inversion H. subst. apply H0; auto.
  * eapply IHl; eauto.
Qed.

Lemma biforall_forall_refl : forall {T} (l: list T) P, list_biforall P l l -> Forall (fun x => P x x) l.
Proof.
  induction l; constructor; inversion H; subst; auto.
Qed.

Lemma forall_biforall_refl : forall {T} (l: list T) P, Forall (fun x => P x x) l -> list_biforall P l l.
Proof.
  induction l; constructor; inversion H; subst; auto.
Qed.

Lemma nth_possibilities {T : Type}:
  forall (l1 l2 : list T) (def : T) i, i < length (l1 ++ l2) ->
    (nth i (l1 ++ l2) def = nth i l1 def) /\ i < length l1 \/
    nth i (l1 ++ l2) def = nth (i - length l1) l2 def /\ (i - length l1) < length l2.
Proof.
  intros. destruct (i <? length l1) eqn:P.
  * apply Nat.ltb_lt in P. left. split; [ apply app_nth1 | ]; auto.
  * apply Nat.ltb_nlt in P. right. split; [ apply app_nth2 | rewrite app_length in H ]; lia.
Qed.

Lemma nth_possibilities_alt {T : Type}:
  forall (l1 l2 : list T) (def : T) i, i < length (l1 ++ l2) ->
    (nth i (l1 ++ l2) def = nth i l1 def) /\ i < length l1 \/
    nth i (l1 ++ l2) def = nth (i - length l1) l2 def /\ (i - length l1) < length l2 /\ i >= length l1.
Proof.
  intros. destruct (i <? length l1) eqn:P.
  * apply Nat.ltb_lt in P. left. split; [ apply app_nth1 | ]; auto.
  * apply Nat.ltb_nlt in P. right. split; [ apply app_nth2 | rewrite app_length in H ]; lia.
Qed.

Definition Injective {A B} (f : A->B) :=
 forall x y, f x = f y -> x = y.

Theorem map_not_in {T T' : Type} : forall (l : list T) (x: T) (f : T -> T'),
  Injective f -> ~In x l -> ~In (f x) (map f l).
Proof.
  induction l; intros; intro.
  * inversion H1.
  * inversion H1.
    - apply H in H2. subst. apply H0. intuition.
    - eapply IHl; eauto. apply not_in_cons in H0. destruct H0. auto.
Qed.

Section list_length_ind.
  Variable A : Type.
  Variable P : list A -> Prop.

  Hypothesis H : forall xs, (forall l, length l < length xs -> P l) -> P xs.

  Theorem list_length_ind : forall xs, P xs.
  Proof.
    assert (forall xs l : list A, length l <= length xs -> P l) as H_ind.
    { induction xs; intros l Hlen; apply H; intros l0 H0.
      - inversion Hlen. lia.
      - apply IHxs. simpl in Hlen. lia.
    }
    intros xs.
    apply H_ind with (xs := xs).
    lia.
  Qed.
End list_length_ind.

Theorem cons_neq :
  forall {T:Type}(l : list T) e, e :: l = l -> False.
Proof.
  induction l; intros; inversion H. eapply IHl. eauto.
Qed.

Lemma cons_cons_neq :
  forall {T : Type} (l : list T) a b, l = a :: b :: l -> False.
Proof.
  induction l; intros; inversion H.
  eapply IHl. eauto.
Qed.

Ltac break_match_hyp :=
match goal with
| [ H : context [ match ?X with _=>_ end ] |- _] =>
     match type of X with
     | sumbool _ _=>destruct X
     | _=>destruct X eqn:?
     end
end.

Ltac break_match_goal :=
match goal with
| [ |- context [ match ?X with _=>_ end ] ] =>
    match type of X with
    | sumbool _ _ => destruct X
    | _ => destruct X eqn:?
    end
end.

Corollary app_not_in {T : Type} : forall (x:T) (l1 l2 : list T),
  ~In x l1 -> ~In x l2 -> ~In x (l1 ++ l2).
Proof.
  intros.
  intro. eapply in_app_or in H1. destruct H1; contradiction.
Qed.

Theorem app_cons_swap {T : Type} : forall (l l' : list T) (a : T),
  l ++ a::l' = l ++ [a] ++ l'.
Proof.
  firstorder.
Qed.

Theorem list_app_neq :
  forall {T : Type} (l2 l1 : list T) t, l1 = l2 ++ t :: l1 -> False.
Proof.
  intros. assert (length l1 = length (l2 ++ t :: l1)). { rewrite H at 1. auto. }
  rewrite app_length in H0. simpl in H0. lia.
Qed.

Theorem fold_left_map :
  forall (T T2 T3 : Type) (l : list T) f (f2 : T -> T2 -> T3 -> T) d t2 t3,
  (forall a b t2 t3, f2 (f a b) t2 t3 = f (f2 a t2 t3) (f2 b t2 t3)) ->
  f2 (fold_left f l d) t2 t3 = fold_left f (map (fun x => f2 x t2 t3) l) (f2 d t2 t3).
Proof.
  induction l; intros; auto.
  intros. cbn.
  rewrite IHl; auto. rewrite H. auto.
Qed.

Theorem map_const :
  forall {T T2} (l : list T) (a : T2), map (fun _ => a) l = repeat a (length l).
Proof.
  induction l; intros.
  auto.
  simpl. rewrite IHl. auto.
Qed.

Lemma Forall_map T (l : list T) : forall (P : T -> Prop) (f : T -> T),
  (forall x, P x -> P (f x))
->
  Forall P l -> Forall P (map f l).
Proof.
  induction l; intros; constructor;
  inversion H0; subst. auto.
  apply IHl; auto.
Qed.

Lemma map_Forall T (l : list T) : forall (P : T -> Prop) (f : T -> T),
  (forall x, P (f x) -> P x)
->
  Forall P (map f l) -> Forall P l.
Proof.
  induction l; intros; constructor;
  inversion H0; subst. auto.
  eapply IHl; eauto.
Qed.

Lemma biforall_refl {T} (l : list T) (P : T -> T -> Prop) :
  (forall x, P x x)
->
  list_biforall P l l.
Proof.
  induction l; intros; constructor; auto.
Qed.

Fixpoint removeFirst {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y})
                     (x : A) (l : list A) {struct l} : list A :=
  match l with
  | [] => []
  | y :: tl => if eq_dec x y then tl else y :: removeFirst eq_dec x tl
  end.

Theorem removeFirst_In :
  forall A eq_dec x (l : list A), In x l -> forall y, y <> x -> In x (removeFirst eq_dec y l).
Proof.
  induction l; intros.
  * inversion H.
  * inversion H; subst; simpl.
    - break_match_goal; subst. congruence. now constructor.
    - break_match_goal; subst; auto. eapply IHl in H1; eauto.
      now constructor 2.
Qed.

Notation "x '.1'" := (fst x) (at level 65, left associativity).
Notation "x '.2'" := (snd x) (at level 65, left associativity).

Theorem not_in_app :
  forall {A : Type} (l1 l2 : list A) x, ~In x (l1 ++ l2) ->
  ~In x l1 /\ ~In x l2.
Proof.
  induction l1; intros.
  * simpl in *. intuition.
  * simpl in *. apply Decidable.not_or in H as [H1 H2]. apply IHl1 in H2 as [H2 H3].
    intuition.
Qed.

Lemma eq_rev :
  forall {T : Type} (l1 l2 : list T), rev l1 = rev l2 -> l1 = l2.
Proof.
  induction l1; simpl; intros.
  * destruct l2; auto. cbn in H. destruct (rev l2); inversion H.
  * destruct l2.
    - destruct (rev l1); inversion H.
    - simpl in H. apply app_inj_tail in H as [H_1 H_2].
      subst. apply IHl1 in H_1. now subst.
Qed.

Lemma in_list_order :
  forall T (l : list T) x1 x2, ~In x1 l -> ~In x2 l -> x1 <> x2 ->
  forall l1 l2 l3, l ++ [x1; x2] <> l1 ++ x2::l2 ++ x1 :: l3.
Proof.
  induction l; simpl app; intros; intro.
  * destruct l1; simpl.
    - inversion H2. congruence.
    - inversion H2; subst. destruct l1; inversion H5.
      + destruct l2; inversion H4.
      + destruct l1; inversion H6.
  * destruct l1; simpl app in *.
    - inversion H2; subst; clear H2. apply H0. constructor. auto.
    - inversion H2. apply IHl in H5; auto.
      intro. apply H. now constructor 2.
      intro. apply H0. now constructor 2.
Qed.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


(** * Functor category [D → C] (also [Cᴰ] and [[D, C]]) *)
Require Import Category.Core Category.Strict Functor.Core NaturalTransformation.Core Functor.Paths.
Require Import HoTT.Basics HoTT.Types.
(** These must come last, so that [identity], [compose], etc., refer to natural transformations. *)
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Identity NaturalTransformation.Composition.Laws NaturalTransformation.Paths.

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

(** ** Definition of [C → D] *)
Section functor_category.
  Context `{Funext}.

  Variables C D : PreCategory.

  (** There is a category Fun(C, D) of functors from [C] to [D]. *)
  Definition functor_category : PreCategory
    := @Build_PreCategory (Functor C D)
                          (@NaturalTransformation C D)
                          (@identity C D)
                          (@compose C D)
                          (@associativity _ C D)
                          (@left_identity _ C D)
                          (@right_identity _ C D)
                          _.
End functor_category.

Local Notation "C -> D" := (functor_category C D) : category_scope.

(** ** [C → D] is a strict category if [D] is *)
Lemma isstrict_functor_category `{Funext} C `{IsStrictCategory D}
: IsStrictCategory (C -> D).
Proof.
  typeclasses eauto.
Defined.

Module Export FunctorCategoryCoreNotations.
  (*Notation "C ^ D" := (functor_category D C) : category_scope.
  Notation "[ C , D ]" := (functor_category C D) : category_scope.*)
  Notation "C -> D" := (functor_category C D) : category_scope.
End FunctorCategoryCoreNotations.


(** printing ~ $\neg$ #¬# *)
(** printing -> $\ra$ #→# *)
(** printing => $\Ra$ #⇒# *)
(** printing ==> $\Ra$ #⇒# *)
(** printing <-> $\lra$ #↔# *)
(** printing /\ $\wedge$ #∧# *)
(** printing \/ $\vee$ #∨# *)
(** printing forall $\forall$ #∀# *)
(** printing exist $\exists$ #&exists;# *)

(** * Misc.v: Preliminaries *)

Set Implicit Arguments.
(* Require Export Setoid. *)
Require Export Arith.
From Coq Require Import Lia.

Require Import Coq.Classes.SetoidTactics.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Classes.Morphisms.

Local Open Scope signature_scope.

(* Should be in standard library Arith.EqNat.beq_nat. *)
Lemma beq_nat_neq: forall x y : nat, x <> y -> false = beq_nat x y.
Proof.
  induction x;induction y;simpl;auto.
Qed.

Lemma if_beq_nat_nat_eq_dec : forall A (x y:nat) (a b:A),
  (if beq_nat x y then a else b) = if eq_nat_dec x y then a else b.
Proof.
  intros A x y a b.
  destruct (eq_nat_dec x y);intros;subst.
  rewrite <- beq_nat_refl;trivial.
  rewrite <- beq_nat_neq;auto.
Qed.

Definition ifte A (test:bool) (thn els:A) := if test then thn else els.

Add Parametric Morphism (A:Type) : (@ifte A)
  with signature (eq ==>eq ==> eq ==> eq) as ifte_morphism1.
Proof.
  trivial.
Qed.

Add Parametric Morphism (A:Type) x : (@ifte A x)
  with signature (eq ==> eq ==> eq) as ifte_morphism2.
Proof.
  trivial.
Qed.

Add Parametric Morphism (A:Type) x y : (@ifte A x y)
  with signature (eq ==> eq) as ifte_morphism3.
Proof.
  trivial.
Qed.

(** ** Definition of iterator [compn]
   [compn f u n x] is defined as (f (u (n-1)).. (f (u 0) x)) *)

Fixpoint compn (A:Type)(f:A -> A -> A) (x:A) (u:nat -> A) (n:nat) {struct n}: A :=
   match n with O => x | (S p) => f (u p) (compn f x u p) end.

Lemma comp0 : forall (A:Type) (f:A -> A -> A) (x:A) (u:nat -> A), compn f x u 0 = x.
trivial.
Qed.

Lemma compS : forall (A:Type) (f:A -> A -> A) (x:A) (u:nat -> A) (n:nat),
              compn f x u (S n) = f (u n) (compn f x u n).
trivial.
Qed.

(** ** Reducing if constructs *)

Lemma if_then : forall (P:Prop) (b:{ P }+{ ~ P })(A:Type)(p q:A),
      P -> (if b then p else q) = p.
destruct b; simpl; intuition.
Qed.

Lemma if_else : forall (P :Prop) (b:{ P }+{ ~ P })(A:Type)(p q:A),
      ~P -> (if b then p else q) = q.
destruct b; simpl; intuition.
Qed.

Lemma if_then_not : forall (P Q:Prop) (b:{ P }+{ Q })(A:Type)(p q:A),
      ~ Q -> (if b then p else q) = p.
destruct b; simpl; intuition.
Qed.

Lemma if_else_not : forall (P Q:Prop) (b:{ P }+{ Q })(A:Type)(p q:A),
      ~P -> (if b then p else q) = q.
destruct b; simpl; intuition.
Qed.

(** ** Classical reasoning *)

Definition class (A:Prop) := ~ ~ A -> A.

Lemma class_neg : forall A:Prop, class ( ~ A).
unfold class; intuition.
Qed.

Lemma class_false : class False.
unfold class; intuition.
Qed.
#[export] Hint Resolve class_neg class_false : core.

Definition orc (A B:Prop) := forall C:Prop, class C -> (A -> C) -> (B -> C) -> C.

Lemma orc_left : forall A B:Prop, A -> orc A B.
red;intuition.
Qed.

Lemma orc_right : forall A B:Prop, B -> orc A B.
red;intuition.
Qed.

#[export] Hint Resolve orc_left orc_right : core.

Lemma class_orc : forall A B, class (orc A B).
repeat red; intros.
apply H0; red; intro.
apply H; red; intro.
apply H3; apply H4; auto.
Qed.

Arguments class_orc [A B].

Lemma orc_intro : forall A B, ( ~ A -> ~ B -> False) -> orc A B.
intros; apply class_orc; red; intros.
apply H; red; auto.
Qed.

Lemma class_and : forall A B, class A -> class B -> class (A /\ B).
unfold class; intuition.
Qed.

Lemma excluded_middle : forall A, orc A ( ~ A).
red; intros.
apply H; red; intro.
intuition.
Qed.

Definition exc (A :Type)(P:A -> Prop) :=
   forall C:Prop, class C -> (forall x:A, P x -> C) -> C.

Lemma exc_intro : forall (A :Type)(P:A -> Prop) (x:A), P x -> exc P.
red;firstorder.
Qed.

Lemma class_exc : forall (A :Type)(P:A -> Prop), class (exc P).
repeat red; intros.
apply H0; clear H0; red; intro.
apply H; clear H; red; intro H2.
apply H2; intros; auto.
apply H0; apply (H1 x); auto.
Qed.

Lemma exc_intro_class : forall (A:Type) (P:A -> Prop), ((forall x, ~ P x) -> False) -> exc P.
intros; apply class_exc; red; intros.
apply H; red; intros; auto.
apply H0; apply exc_intro with (x:=x);auto.
Qed.

Lemma not_and_elim_left : forall A B, ~ (A /\ B) -> A -> ~B.
intuition.
Qed.

Lemma not_and_elim_right : forall A B, ~ (A /\ B) -> B -> ~A.
intuition.
Qed.

#[export] Hint Resolve class_orc class_and class_exc excluded_middle : core.

Lemma class_double_neg : forall P Q: Prop, class Q -> (P -> Q) -> ~ ~ P -> Q.
intros.
apply (excluded_middle (A:=P)); auto.
Qed.

(** ** Extensional equality *)

Definition feq A B (f g : A -> B) := forall x, f x = g x.

Lemma feq_refl : forall A B (f:A->B), feq f f.
red; trivial.
Qed.

Lemma feq_sym : forall A B (f g : A -> B), feq f g -> feq g f.
unfold feq; auto.
Qed.

Lemma feq_trans : forall A B (f g h: A -> B), feq f g -> feq g h -> feq f h.
unfold feq; intros.
transitivity (g x); auto.
Qed.

#[export] Hint Resolve feq_refl : core.
#[export] Hint Immediate feq_sym : core.
#[export] Hint Unfold feq : core.

Add Parametric Relation (A B : Type) : (A -> B) (feq (A:=A) (B:=B))
  reflexivity proved by (feq_refl (A:=A) (B:=B))
  symmetry proved by (feq_sym (A:=A) (B:=B))
  transitivity proved by (feq_trans (A:=A) (B:=B))
as feq_rel.

(** Computational version of elimination on CompSpec *)

Lemma CompSpec_rect : forall (A : Type) (eq lt : A -> A -> Prop) (x y : A)
       (P : comparison -> Type),
       (eq x y -> P Eq) ->
       (lt x y -> P Lt) ->
       (lt y x -> P Gt)
    -> forall c : comparison, CompSpec eq lt x y c -> P c.
intros A eq lt x y P Peq Plt1 Plt2; destruct c; intro.
apply Peq; inversion H; auto.
apply Plt1; inversion H; auto.
apply Plt2; inversion H; auto.
Defined.

(** Decidability *)
Lemma dec_sig_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {i | i < n /\ P i}+{forall i, i < n -> ~ P i}.
intros P Pdec.
induction n.
right; intros; exfalso; lia.
destruct IHn as [(i,(He1,He2))|Hn]; auto.
left; exists i; auto.
destruct (Pdec n) as [HP|HnP].
left; exists n; auto.
right; intros; assert (i < n \/ i = n) as [H1|H2]; subst; auto; try lia.
Defined.

Lemma dec_exists_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {exists i, i < n /\ P i}+{~ exists i, i < n /\ P i}.
intros P decP n; destruct (dec_sig_lt P decP n) as [(i,(H1,H2))|H].
left; exists i; auto.
right; intros (i,(H1,H2)); apply (H i H1 H2).
Qed.

Definition eq_nat2_dec : forall p q : nat*nat, { p=q }+{~ p=q }.
intros (p1,p2) (q1,q2).
destruct (eq_nat_dec p1 q1) as [H1|H1]; subst.
destruct (eq_nat_dec p2 q2) as [H2|H2]; subst; auto with zarith.
right; intro Heq; apply H2.
injection Heq; trivial.
right; intro Heq; apply H1.
injection Heq; trivial.
Defined.

Lemma nat_compare_specT
   : forall x y : nat, CompareSpecT (x = y) (x < y)%nat (y < x)%nat (Nat.compare x y).
intros; apply CompareSpec2Type.
apply Nat.compare_spec.
Qed.

(** * Preliminary lemmas relating the ordre on nat and N *)

Require Export NArith.

Lemma N2Nat_lt_mono : forall n m, (n < m)%N <-> (N.to_nat n < N.to_nat m)%nat.
unfold N.lt; intros n m; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_lt; split; auto.
Qed.

Lemma N2Nat_le_mono : forall n m, (n <= m)%N <-> (N.to_nat n <= N.to_nat m)%nat.
unfold N.le; intros n m; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_le; split; trivial.
Qed.

Lemma N2Nat_inj_lt : forall n m, (n < m)%N -> (N.to_nat n < N.to_nat m)%nat.
intros; rewrite <- N2Nat_lt_mono; trivial.
Qed.

Lemma N2Nat_inj_le : forall n m, (n <= m)%N -> (N.to_nat n <= N.to_nat m)%nat.
intros; rewrite <- N2Nat_le_mono; trivial.
Qed.

Lemma N2Nat_inj_pos : forall n, (0 < n)%N -> (0 < N.to_nat n)%nat.
unfold N.lt; intros n; rewrite N2Nat.inj_compare.
rewrite <- nat_compare_lt; trivial.
Qed.
#[export] Hint Resolve N2Nat_inj_lt N2Nat_inj_pos N2Nat_inj_le : core.

Lemma Nsucc_pred_pos: forall n : N, (0 < n)%N -> N.succ (N.pred n) = n.
intros; apply N.lt_succ_pred with (0%N); trivial.
Qed.
#[export] Hint Resolve Nsucc_pred_pos : core.

Lemma Npos : forall n, (0 <= n)%N.
destruct n; discriminate.
Qed.
#[export] Hint Resolve Npos : core.

Lemma Neq_lt_0 : forall n, (n=0)%N \/ (0<n)%N.
intros; destruct (N.lt_eq_cases 0 n) as (Heq,_); intros.
destruct Heq; auto.
Qed.
#[export] Hint Resolve Neq_lt_0 : core.

Lemma Nlt0_le1 : forall n, (0<n)%N -> (1<=n)%N.
intros; change (N.succ 0 <= n)%N; rewrite N.le_succ_l; auto.
Qed.
#[export] Hint Immediate Nlt0_le1 : core.

(* Tactic to deal with closed inequalities on N *)
Ltac Nineq :=
     match goal with
      |- (N.le ?n ?m) => compute; discriminate
    | |- (N.lt ?n ?m) => compute; reflexivity
    | |- ~ (eq (A:=N) ?n ?m) => rewrite <- N.compare_eq_iff; compute; discriminate
    end.


(**
Complements about hset_category (true of any topos: Cf. Sheaves and Geometry)
(actually could be generalized to non hset types)
 - bin products of epi is epi
 - distributive

 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Require Import UniMath.CategoryTheory.Adjunctions.Core.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.BinProductComplements.
Require Import Modules.Prelims.CoproductsComplements.
Require Import UniMath.SubstitutionSystems.ModulesFromSignatures.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.

Require Import UniMath.CategoryTheory.categories.HSET.All.

Lemma hset_category_isDistributive (I : hSet)  :
   bp_coprod_isDistributive BinProductsHSET (CoproductsHSET  I (setproperty I)).
Proof.
  intros f X.
  eapply is_iso_from_is_z_iso.
  use make_is_z_isomorphism.
  - intros [[i a] b].
    exact (i ,, (a ,, b)).
  - use make_is_inverse_in_precat; apply idpath.
Defined.

Lemma isEpiBinProdHSET {X X' Y Y' : hSet} (f : X -> Y)(g : X' -> Y') :
  isEpi (C := SET) f -> isEpi (C:=SET) g -> isEpi (C:=SET)
                                                (BinProductOfArrows _
                                                                    (BinProductsHSET Y Y')
                                                                    (BinProductsHSET X X')
                                                            f g).
Proof.
  intros epif epig.
  apply EpisAreSurjective_HSET in epif.
  apply EpisAreSurjective_HSET in epig.
  intros Z u v h.
  apply funextfun.
  apply toforallpaths in h.
  red.
  eapply surjectionisepitosets; [| apply setproperty | apply h].
  intros [y y'].
  generalize (epif y).
  generalize (epig y').
  apply hinhfun2.
  intros  [x' hx'][x hx].
  use make_hfiber.
  - exact (x,,x').
  - cbn.
    apply dirprodeq; apply hx' || apply hx.
Qed.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


(** * Propositions with a distinguished representation of [True], [False], [and], [or], and [impl] *)
(** This allows for something between [bool] and [Prop], where we can
    computationally reduce things like [True /\ True], but can still
    express equality of types. *)
Require Import Coq.Setoids.Setoid.
Require Import Coq.Program.Tactics.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.DestructHyps.
Require Import Crypto.Util.Tactics.BreakMatch.

Delimit Scope reified_prop_scope with reified_prop.
Inductive reified_Prop := rTrue | rFalse | rAnd (x y : reified_Prop) | rOr (x y : reified_Prop) | rImpl (x y : reified_Prop) | rForall {T} (f : T -> reified_Prop) | rEq {T} (x y : T) | inject (_ : Prop).
Bind Scope reified_prop_scope with reified_Prop.

Fixpoint to_prop (x : reified_Prop) : Prop
  := match x with
     | rTrue => True
     | rFalse => False
     | rAnd x y => to_prop x /\ to_prop y
     | rOr x y => to_prop x \/ to_prop y
     | rImpl x y => to_prop x -> to_prop y
     | @rForall _ f => forall x, to_prop (f x)
     | @rEq _ x y => x = y
     | inject x => x
     end.

Coercion reified_Prop_of_bool (x : bool) : reified_Prop
  := if x then rTrue else rFalse.

Definition and_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, y => y
     | x, rTrue => x
     | rFalse, y => rFalse
     | x, rFalse => rFalse
     | rEq T a b, rEq T' a' b' => rEq (a, a') (b, b')
     | x', y' => rAnd x' y'
     end.
Definition or_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, y => rTrue
     | x, rTrue => rTrue
     | rFalse, y => y
     | x, rFalse => x
     | x', y' => rOr x' y'
     end.
Definition impl_reified_Prop (x y : reified_Prop) : reified_Prop
  := match x, y with
     | rTrue, y => y
     | x, rTrue => rTrue
     | rFalse, y => rTrue
     | rImpl x rFalse, rFalse => x
     | x', y' => rImpl x' y'
     end.

Infix "/\" := and_reified_Prop : reified_prop_scope.
Infix "\/" := or_reified_Prop : reified_prop_scope.
Infix "->" := impl_reified_Prop : reified_prop_scope.
Infix "=" := rEq : reified_prop_scope.
Notation "~ P" := (P -> rFalse)%reified_prop : reified_prop_scope.
Notation "∀  x .. y , P" := (rForall (fun x => .. (rForall (fun y => P%reified_prop)) .. ))
                              (at level 200, x binder, y binder, right associativity) : reified_prop_scope.

Definition reified_Prop_eq (x y : reified_Prop)
  := match x, y with
     | rTrue, _ => y = rTrue
     | rFalse, _ => y = rFalse
     | rAnd x0 x1, rAnd y0 y1
       => x0 = y0 /\ x1 = y1
     | rAnd _ _, _ => False
     | rOr x0 x1, rOr y0 y1
       => x0 = y0 /\ x1 = y1
     | rOr _ _, _ => False
     | rImpl x0 x1, rImpl y0 y1
       => x0 = y0 /\ x1 = y1
     | rImpl _ _, _ => False
     | @rForall Tx fx, @rForall Ty fy
       => exists pf : Tx = Ty,
                      forall x, fx x = fy (eq_rect _ (fun t => t) x _ pf)
     | rForall _ _, _ => False
     | @rEq Tx x0 x1, @rEq Ty y0 y1
       => exists pf : Tx = Ty,
                      eq_rect _ (fun t => t) x0 _ pf = y0
                      /\ eq_rect _ (fun t => t) x1 _ pf = y1
     | rEq _ _ _, _ => False
     | inject x, inject y => x = y
     | inject _, _ => False
     end.

Section rel.
  Local Ltac t :=
    cbv;
    repeat (match goal with |- forall x, _ => intro end (* work around broken Ltac [match] in 8.4 that diverges on things under binders *)
            || break_match
            || break_match_hyps
            || intro
            || (simpl in * )
            || intuition try congruence
            || (exists eq_refl)
            || eauto
            || (subst * )
            || apply conj
            || destruct_head' ex
            || solve [ apply reflexivity
                     | apply symmetry; eassumption
                     | eapply transitivity; eassumption ] ).

  Global Instance Reflexive_reified_Prop_eq : Reflexive reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Symmetric_reified_Prop_eq : Symmetric reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Transitive_reified_Prop_eq : Transitive reified_Prop_eq.
  Proof. t. Qed.
  Global Instance Equivalence_reified_Prop_eq : Equivalence reified_Prop_eq.
  Proof. split; exact _. Qed.
End rel.

Definition reified_Prop_leq_to_eq (x y : reified_Prop) : x = y -> reified_Prop_eq x y.
Proof. intro; subst; simpl; reflexivity. Qed.

Ltac inversion_reified_Prop_step :=
  let do_on H := apply reified_Prop_leq_to_eq in H; unfold reified_Prop_eq in H in
  match goal with
  | [ H : False |- _ ] => solve [ destruct H ]
  | [ H : (_ = _ :> reified_Prop) /\ (_ = _ :> reified_Prop) |- _ ] => destruct H
  | [ H : ?x = ?x :> reified_Prop |- _ ] => clear H
  | [ H : exists pf : _ = _ :> Type, forall x, _ = _ :> reified_Prop |- _ ]
    => destruct H as [? H]; subst; simpl @eq_rect in H
  | [ H : ?x = _ :> reified_Prop |- _ ] => is_var x; subst x
  | [ H : _ = ?y :> reified_Prop |- _ ] => is_var y; subst y
  | [ H : rTrue = rFalse |- _ ] => solve [ inversion H ]
  | [ H : rFalse = rTrue |- _ ] => solve [ inversion H ]
  | [ H : rTrue = _ |- _ ] => do_on H; progress subst
  | [ H : rFalse = _ |- _ ] => do_on H; progress subst
  | [ H : rAnd _ _ = _ |- _ ] => do_on H
  | [ H : rOr _ _ = _ |- _ ] => do_on H
  | [ H : rImpl _ _ = _ |- _ ] => do_on H
  | [ H : rForall _ = _ |- _ ] => do_on H
  | [ H : rEq _ _ = _ |- _ ] => do_on H
  | [ H : inject _ = _ |- _ ] => do_on H
  end.
Ltac inversion_reified_Prop := repeat inversion_reified_Prop_step.

Lemma to_prop_and_reified_Prop x y : to_prop (x /\ y) <-> (to_prop x /\ to_prop y).
Proof.
  destruct x, y; simpl; try tauto.
  { split; intro H; inversion H; subst; repeat split. }
Qed.

(** Remove all possibly false terms in a reified prop *)
Fixpoint trueify (p : reified_Prop) : reified_Prop
  := match p with
     | rTrue => rTrue
     | rFalse => rTrue
     | rAnd x y => rAnd (trueify x) (trueify y)
     | rOr x y => rOr (trueify x) (trueify y)
     | rImpl x y => rImpl x (trueify y)
     | rForall T f => rForall (fun x => trueify (f x))
     | rEq T x y => rEq x x
     | inject x => inject True
     end.

Lemma trueify_true : forall p, to_prop (trueify p).
Proof.
  induction p; simpl; auto.
Qed.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.

Import ListNotations.

Set Printing Parentheses.

Inductive typ : Set :=
| typ_int : typ
| typ_top : typ
| typ_arrow : typ -> typ -> typ
| typ_and : typ -> typ -> typ.

Hint Constructors typ : core.

Notation "A → B" := (typ_arrow A B) (at level 20).
Notation "A & B" := (typ_and A B) (at level 20).

Inductive trm : Set :=
| trm_int : nat -> trm
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_abs : typ -> trm -> trm
| trm_app : trm -> trm -> trm
| trm_merge : trm -> trm -> trm
| trm_anno : trm -> typ -> trm.

Hint Constructors trm : core.

Notation "e ∷ A" := (trm_anno e A) (at level 20).

Coercion trm_fvar : atom >-> trm.

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

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_int n => trm_int n
  | trm_bvar i => if k == i then u else (trm_bvar i)
  | trm_fvar x => trm_fvar x
  | trm_abs A t1 => trm_abs A (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_merge t1 t2 => trm_merge (open_rec k u t1) (open_rec k u t2)
  | trm_anno t1 A => trm_anno (open_rec k u t1) A
  end.

Definition open t u := open_rec 0 u t.

Inductive pvalue : trm -> Prop :=
| pvalue_nat : forall (n : nat), pvalue (trm_int n)
| pvalue_abs : forall (e : trm) (A : typ), pvalue (trm_abs A e).

Inductive value : trm -> Prop :=
| value_anno : forall (A : typ) (e : trm),
    pvalue e -> value (trm_anno e A)
| value_merge : forall (v1 v2 : trm),
    value v1 -> value v2 -> value (trm_merge v1 v2).

Hint Constructors pvalue : core.
Hint Constructors value : core.

Inductive toplike : typ -> Prop :=
| tl_top : toplike typ_top
| tl_and : forall (A B : typ), toplike A -> toplike B -> toplike (typ_and A B)
| tl_arrow : forall (A B : typ), toplike B -> toplike (typ_arrow A B).

Hint Constructors toplike : core.

Inductive ordinary : typ -> Prop :=
| ord_top : ordinary typ_top
| ord_int : ordinary typ_int
| ord_arrow : forall (A B : typ), ordinary (typ_arrow A B).

Hint Constructors ordinary : core.

Inductive sub : typ -> typ -> Prop :=
| sub_int :
    sub typ_int typ_int
| sub_top : forall (A:typ),
    sub A typ_top
| sub_top_arr : forall (A B C : typ),
    sub typ_top C -> sub A (typ_arrow B C)
| sub_arrow : forall (A B C D:typ),
    sub C A -> sub B D -> sub (typ_arrow A B) (typ_arrow C D)
| sub_and : forall (A B C:typ),
    sub A B -> sub A C -> sub A (typ_and B C)
| sub_and_l : forall (A B C:typ),
    sub A C -> sub (typ_and A B) C
| sub_and_r : forall (A B C:typ),
    sub B C -> sub (typ_and A B) C.

Hint Constructors sub : core.

Notation "A <: B" := (sub A B) (at level 40).

Definition arg := list typ.

Inductive auxas : arg -> typ -> typ -> Prop :=
| aas_refl : forall (A : typ),
    auxas nil A A
| aas_fun : forall (A B C D : typ) (S : arg),
    sub C A ->
    auxas S B D ->
    auxas (cons C S) (typ_arrow A B) (typ_arrow C D)
| aas_and_l : forall (A B C D: typ) (S : arg),
    auxas (cons C S) A D ->
    auxas (cons C S) (typ_and A B) D
| aas_and_r : forall (A B C D: typ) (S : arg),
    auxas (cons C S) B D ->
    auxas (cons C S) (typ_and A B) D.

Inductive appsub : arg -> typ -> typ -> Prop :=
| as_refl : forall (A : typ),
    appsub nil A A
| as_fun : forall (A B C D : typ) (S : arg),
    sub C A ->
    appsub S B D ->
    appsub (cons C S) (typ_arrow A B) (typ_arrow C D)
| as_and_l : forall (A B C D: typ) (S : arg),
    appsub (cons C S) A D ->
    not (auxas (cons C S) B D) ->
    appsub (cons C S) (typ_and A B) D
| as_and_r : forall (A B C D: typ) (S : arg),
    appsub (cons C S) B D ->
    not (auxas (cons C S) A D) ->
    appsub (cons C S) (typ_and A B) D.

Hint Constructors appsub : core.

Notation "S ⊢ A <: B" := (appsub S A B) (at level 40).
Notation "S ➤ A <: B" := (auxas S A B) (at level 40).

Definition disjoint_spec A B :=
  forall (C : typ), sub A C -> sub B C -> toplike C.

Inductive typedred : trm -> typ -> trm -> Prop :=
| tred_int_anno : forall (n : nat),
    typedred (trm_anno (trm_int n) typ_int) typ_int (trm_anno (trm_int n) typ_int)
| tred_top : forall (A : typ) (v : trm),
    toplike A -> ordinary A ->
    typedred v A (trm_anno (trm_int 1) A)
| tred_arrow_anno : forall (A B C D E : typ) (e : trm),
    not (toplike D) -> sub A (typ_arrow C D) ->
    typedred (trm_anno (trm_abs E e) A)
             (typ_arrow C D)
             (trm_anno (trm_abs E e) (typ_arrow C D))
| tred_merge_l : forall (v1 v2 v1': trm) (A : typ),
    typedred v1 A v1' -> ordinary A ->
    typedred (trm_merge v1 v2) A v1'
| tred_merge_r : forall (v1 v2 v2': trm) (A : typ),
    typedred v2 A v2' -> ordinary A ->
    typedred (trm_merge v1 v2) A v2'
| tred_and : forall (v1 v2 v : trm) (A B : typ),
    typedred v A v1 ->
    typedred v B v2 ->
    typedred v (typ_and A B) (trm_merge v1 v2).

Hint Constructors typedred : core.

Notation "e ~->> A e'" := (typedred e A e') (at level 68).

Definition consistency_spec e1 e2 :=
  forall (A : typ) (e1' e2' : trm), typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.

Inductive typing : ctx -> arg -> trm -> typ -> Prop :=
| typing_int : forall (T : ctx) (n : nat),
    uniq T -> typing T nil (trm_int n) typ_int
| typing_var : forall (T : ctx) (x : var) (A : typ),
    uniq T -> binds x A T -> typing T nil (trm_fvar x) A
| typing_lam1 : forall (L : vars) (T : ctx) (A B : typ) (e : trm),
    (forall x, x \notin L -> (typing ((x ~ A) ++ T)) nil (open e (trm_fvar x)) B) ->
    typing T nil (trm_abs A e) (typ_arrow A B)
| typing_lam2 : forall (L : vars) (S : arg) (T : ctx) (A B C : typ) (e : trm),
    (forall x, x \notin L -> (typing ((x ~ A) ++ T)) S (open e (trm_fvar x)) B) ->
    sub C A ->
    typing T (cons C S) (trm_abs A e) (typ_arrow A B)
| typing_anno : forall (S : arg) (T : ctx) (A B C : typ) (e : trm),
    typing T nil e C -> sub C A -> appsub S A B ->
    typing T S (trm_anno e A) B
| typing_app : forall (L : vars) (S : arg) (T : ctx) (A B : typ) (e1 e2 : trm),
    typing T nil e2 A ->
    typing T (cons A S) e1 (typ_arrow A B) ->
    typing T S (trm_app e1 e2) B
| typing_merge : forall (T : ctx) (A B : typ) (e1 e2 : trm) (S : arg),
    disjoint_spec A B ->
    typing T S e1 A ->
    typing T S e2 B ->
    typing T S (trm_merge e1 e2) (typ_and A B)
| typing_merge_value : forall (T : ctx) (A B : typ) (v1 v2 : trm) (S : arg),
    value v1 -> value v2 ->
    typing nil S v1 A ->
    typing nil S v2 B ->
    consistency_spec v1 v2 ->
    typing T S (trm_merge v1 v2) (typ_and A B)
| typing_merge_pick : forall (T : ctx) (S : arg) (A B C : typ) (e1 e2 : trm),
    typing T nil (trm_merge e1 e2) B ->
    appsub (cons A S) B C ->
    typing T (cons A S) (trm_merge e1 e2) C.

Hint Constructors typing : core.

Notation "T S ⊢ e ⇒ A" := (typing T S e A) (at level 50).

Inductive ptype : trm -> typ -> Prop :=
| ptype_int : forall (n : nat),
    ptype (trm_int n) typ_int
| ptype_anno : forall (e : trm) (A : typ),
    ptype (trm_anno e A) A
| ptype_merge : forall (e1 e2 : trm) (A B : typ),
    ptype e1 A ->
    ptype e2 B ->
    ptype (trm_merge e1 e2) (typ_and A B).

Hint Constructors ptype : core.

Inductive papp : trm -> trm -> trm -> Prop :=
| papp_top : forall (v vl : trm) (A : typ),
    ptype v A ->
    toplike A ->
    papp v vl (trm_anno (trm_int 1) A)
| papp_abs_anno : forall (A B C : typ) (e v v' : trm),
    typedred v A v' ->
    not (toplike B) ->
    papp (trm_anno (trm_abs C e) (typ_arrow A B)) v
         (trm_anno (open e v') B)
| papp_merge_l : forall (A B C : typ) (v1 v2 v vl e : trm),
    ptype v1 A -> ptype vl B -> ptype (trm_merge v1 v2) C ->
    appsub (cons B nil) C A ->
    not (toplike C) ->
    papp v1 vl e ->
    papp (trm_merge v1 v2) vl e
| papp_merge_r : forall (A B C : typ) (v1 v2 v vl e : trm),
    ptype v2 A -> ptype vl B -> ptype (trm_merge v1 v2) C ->
    appsub (cons B nil) C A ->
    not (toplike C) ->
    papp v2 vl e ->
    papp (trm_merge v1 v2) vl e.

Hint Constructors papp : core.

Notation "v ◐ vl ~-> e" := (papp v vl e) (at level 69).

Inductive step : trm -> trm -> Prop :=
| step_int_anno : forall (n : nat),
    step (trm_int n) (trm_anno (trm_int n) typ_int)
| step_papp : forall (v vl e : trm),
    value v -> value vl ->
    papp v vl e ->
    step (trm_app v vl) e
| step_anno_value : forall (v v' : trm) (A : typ),
    value v -> typedred v A v' ->
    step (trm_anno v A) v'
| step_anno : forall (e e' : trm) (A : typ),
    not (value (trm_anno e A)) ->
    step e e' -> step (trm_anno e A) (trm_anno e' A)
| step_app_l : forall (e1 e2 e1' : trm),
    step e1 e1' -> step (trm_app e1 e2) (trm_app e1' e2)
| step_app_v : forall (v e2 e2' : trm),
    value v -> step e2 e2' -> step (trm_app v e2) (trm_app v e2')
| step_merge_l : forall (e1 e2 e1' : trm),
    step e1 e1' ->
    step (trm_merge e1 e2) (trm_merge e1' e2)
| step_merge_r : forall (v e2 e2' : trm),
    value v -> step e2 e2' ->
    step (trm_merge v e2) (trm_merge v e2').

Hint Constructors step : core.
Notation "e ~-> e'" := (step e e') (at level 68).


From mathcomp Require Export ssrbool.
Require Export prosa.behavior.all.

(** * Task Type *)

(** As in case of the job model, we make no assumptions about the structure or
    type of tasks, i.e., like jobs, we consider tasks to be mathematically
    opaque objects. We only assume that any type that represents tasks has a
    decidable equality. *)
Definition TaskType := eqType.

(** * Task Model Core Parameters *)

(** In the following, we define three central parameters of the task model: how
    jobs map to tasks, deadlines of tasks, and each task's WCET parameter. *)

(** First, we define a job-model parameter [job_task] that maps each job to its
    corresponding task. *)
Class JobTask (Job : JobType) (Task : TaskType) := job_task : Job -> Task.

(** Second, we define a task-model parameter to express each task's relative
    deadline. *)
Class TaskDeadline (Task : TaskType) := task_deadline : Task -> duration.

(** Third, we define a task-model parameter to express each task's worst-case
    execution cost (WCET). *)
Class TaskCost (Task : TaskType) := task_cost : Task -> duration.

(** * Task Model Validity *)

(** In the following section, we introduce properties that a reasonable task
    model must satisfy. *)
Section ModelValidity.

  (** Consider any type of tasks with WCETs and relative deadlines. *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskDeadline Task}.

  (** First, we constrain the possible WCET values of a valid task. *)
  Section ValidCost.

    (** Consider an arbitrary task. *)
    Variable tsk: Task.

    (** The WCET of the task should be positive. *)
    Definition task_cost_positive := task_cost tsk > 0.

    (** The WCET should not be larger than the deadline, as otherwise the task
        is trivially infeasible. *)
    Definition task_cost_at_most_deadline := task_cost tsk <= task_deadline tsk.

  End ValidCost.

  (** Second, we relate the cost of a task's jobs to its WCET. *)
  Section ValidJobCost.

    (** Consider any type of jobs associated with the tasks ... *)
    Context {Job : JobType}.
    Context `{JobTask Job Task}.
    (** ... and consider the cost of each job. *)
    Context `{JobCost Job}.

    (** The cost of any job [j] cannot exceed the WCET of its respective
        task. *)
    Definition valid_job_cost j :=
      job_cost j <= task_cost (job_task j).

    (** ... and any arrival sequence. *)
    Variable arr_seq : arrival_sequence Job.

    (** The cost of a job from the arrival sequence cannot
       be larger than the task cost. *)
    Definition arrivals_have_valid_job_costs :=
      forall j,
        arrives_in arr_seq j ->
        valid_job_cost j.

  End ValidJobCost.

End ModelValidity.

(** * Task Sets *)

(** Next, we introduce the notion of a task set and define properties of valid
    task sets. *)

(** For simplicity, we represent sets of such tasks simply as (finite) sequences of
    tasks. *)
Definition TaskSet := seq.

Section ValidTaskSet.

  (** Consider any type of tasks with WCETs ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks ... *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  (** ... as well as their individual execution costs. *)
  Context `{JobCost Job}.

  (** Further, consider an arrival sequence of these jobs... *)
  Variable arr_seq : arrival_sequence Job.

  (** ...and the set of tasks that generate them.  *)
  Variable ts : TaskSet Task.

  (** All jobs in the arrival sequence should come from the task set. *)
  Definition all_jobs_from_taskset :=
    forall j,
      arrives_in arr_seq j ->
      job_task j \in ts.

End ValidTaskSet.

(** Finally, for readability, we define two ways in which jobs and tasks
    relate. *)
Section SameTask.

  (** For any type of job associated with any type of tasks... *)
  Context {Job : JobType}.
  Context {Task : TaskType}.
  Context `{JobTask Job Task}.

  (** ... we say that two jobs [j1] and [j2] are from the same task iff
      [job_task j1] is equal to [job_task j2]. *)
  Definition same_task (j1 j2 : Job) := job_task j1 == job_task j2.

  (** We further say that a job [j] is a job of task [tsk] iff [job_task j] is
      equal to [tsk]. *)
  Definition job_of_task (tsk : Task) (j : Job) := job_task j == tsk.

End SameTask.


Require Import Modal.
Require Import is_pos_neg.
Require Import at_pv.
Require Import occ_in_phi.
Require Import p_occurs_in.
Require Import Arith.EqNat.
Require Import my_bool.
Require Import my_arith__my_leb_nat.
Require Import is_pos_neg_lemmas.

(* ---------------------------------------------------------------------------- *)
(* All occurrences of p in phi are positive. *)

Definition p_is_pos (phi : Modal) (p : propvar) : Prop :=
  (p_occurs_in_phi phi p = true ->
    forall i : nat, occ_in_phi phi i = true ->
      match p, at_pv (pv_in phi) i with
      | pv pn, pv qm => pn = qm
      end
        -> is_pos phi i = true) /\
   (p_occurs_in_phi phi p = false -> False).

Definition p_is_neg (phi : Modal) (p : propvar) : Prop :=
  (p_occurs_in_phi phi p = true ->
    forall i : nat, occ_in_phi phi i = true ->
      match p, at_pv (pv_in phi) i with
      | pv pn, pv qm => pn = qm
      end
        -> is_neg phi i = true) /\
   (p_occurs_in_phi phi p = false -> False).

(* ---------------------------------------------------------------------------- *)
(* p_is_pos lemmas *)

Lemma p_is_pos_notin : forall (phi : Modal) (p : propvar),
  p_is_pos phi p -> p_occurs_in_phi phi p = true.
Proof.
  intros phi p H_pos.
  unfold p_is_pos in H_pos.
  case_eq (p_occurs_in_phi phi p); intros H_occ;
  rewrite H_occ in *.
    reflexivity.

    destruct H_pos as [t f].
    assert (false = false) as Hf by reflexivity.
    specialize (f Hf); contradiction.
Qed.

Lemma p_is_pos_atom : forall (p q : propvar),
  p_is_pos (atom q) p -> p = q.
Proof.
  intros p q H_pos.
  destruct p as [pn]; destruct q as [qm].
  unfold p_is_pos in H_pos.
  destruct H_pos as [t f].
  simpl in *.
  case_eq (p_occurs_in_phi (atom (pv qm)) (pv pn));
  intros H_eq; rewrite H_eq in *.
    unfold p_occurs_in_phi in H_eq.
    simpl in H_eq.
    case_eq (beq_nat pn qm); intros H_beq;
    rewrite H_beq in *.
      pose proof (beq_nat_true pn qm H_beq) as H.
      rewrite H; reflexivity.

      discriminate.

    assert (false = false) as Hf by reflexivity.
    pose proof (f Hf); contradiction.
Qed.

Lemma p_is_pos_mneg : forall (phi : Modal) (p : propvar),
  p_is_pos (mneg phi) p -> ~ p_is_pos phi p .
Proof.
  unfold not; intros phi p H_neg H_pos.
  unfold p_is_pos in *. unfold p_occurs_in_phi in *.
  simpl in *.
  destruct H_neg as [t1 l1]; destruct H_pos as [t2 l2].
  case_eq (p_occurs_in_l (pv_in phi) p); intros H_eq.
    pose proof (p_occurs_in_l_ex (pv_in phi) p H_eq) as H.
    destruct H as [L1 [L2 H]].
    rewrite <- H in *.
    rewrite H_eq in *.
    specialize (t1 true_true (length L1 + 1));
    specialize (t2 true_true (length L1 + 1)).

pose proof (@List.app_length propvar) as tryin.
(*    rewrite length_app_pv in *. *)
    simpl length in *.
    rewrite not_zero in *.
    pose proof (leb_refl (length L1 )) as HL1.
    pose proof (leb_plus_gen (length L1) (length L1) 1 (S (length L2))) as H2.
    assert (Nat.leb 1 (S (length L2))=true) as H3 by reflexivity.
    specialize (H2 HL1 H3).
rewrite List.app_length in t1.
simpl length in t1.
rewrite H2 in t1.

(*    rewrite H2 in *. *)
    rewrite occ_in_phi_leb3 in t2.
    specialize (t1 true_true); specialize (t2 true_true).
    destruct p as [pn].
    rewrite (at_pv_app_cons) in *.
    assert (pn = pn) as Hpn by reflexivity.
    specialize (t1 Hpn); specialize (t2 Hpn).
    rewrite t2 in t1.
    discriminate.

      rewrite not_zero; reflexivity.
    rewrite <- H.
    rewrite List.app_length.
    simpl.
    rewrite arith_plus_comm.
    rewrite (arith_plus_comm (length L1) (S (length L2))).
    pose proof ( leb_plus 1 (S (length L2)) (length L1)) as H4.
    rewrite H3 in H4.
    symmetry; exact H4.

    apply l1; exact H_eq.
Qed.

Lemma p_is_pos_mconj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mconj phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  unfold p_is_pos in *.
  destruct Hpos as [l r].
  apply conj.
    intros H i Hocc2 Heq.
    destruct p as [pn].
    assert (p_occurs_in_phi phi1 (pv pn) = true \/
         p_occurs_in_phi phi2 (pv pn) = true) as H2.
      left; exact Hocc.
    destruct (p_occurs_in_phi_mconj phi1 phi2 (pv pn)) as [Hf Hr].
    specialize (Hr H2).
    clear H2 Hf.
    specialize (l Hr i (occ_in_phi_mconj_l phi1 phi2 i Hocc2)).
    pose proof (is_pos_mconj phi1 phi2 i) as H4.
    destruct H4 as [H4l H4r].
      apply l.
      simpl.
      rewrite at_pv_app_l.
        exact Heq.

        apply PeanoNat.Nat.leb_le.
        apply occ_in_phi_leb; exact Hocc2.

      apply H4l.
      exact Hocc2.

    rewrite Hocc; intros; discriminate.
Qed.

Lemma p_is_pos_mconj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mconj phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  unfold p_is_pos.
  destruct Hpos as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mconj_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mconj phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_pos_mconj_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.
        specialize (H1 H2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_pos_mdisj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mdisj phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  unfold p_is_pos in *.
  destruct Hpos as [l r].
  apply conj.
    intros H i Hocc2 Heq.
    destruct p as [pn].
    assert (p_occurs_in_phi phi1 (pv pn) = true \/
         p_occurs_in_phi phi2 (pv pn) = true) as H2.
      left; exact Hocc.
    destruct (p_occurs_in_phi_mdisj phi1 phi2 (pv pn)) as [Hf Hr].
    specialize (Hr H2).
    clear H2 Hf.
    specialize (l Hr i (occ_in_phi_mdisj_l phi1 phi2 i Hocc2)).
    pose proof (is_pos_mdisj phi1 phi2 i) as H4.
    destruct H4 as [H4l H4r].
      apply l.
      simpl.
      rewrite at_pv_app_l.
        exact Heq.

        apply PeanoNat.Nat.leb_le.
        apply occ_in_phi_leb; exact Hocc2.

      apply H4l.
      exact Hocc2.

    rewrite Hocc; intros; discriminate.
Qed.

Lemma p_is_pos_mdisj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mdisj phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  unfold p_is_pos.
  destruct Hpos as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mdisj_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mconj phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_pos_mdisj_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.
        specialize (H1 H2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_pos_mimpl2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mimpl phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hpos Hocc.
  unfold p_is_pos in *.
  unfold p_is_neg.
  destruct Hpos as [l r].
  apply conj.
    intros H i Hocc2 Heq.
    destruct p as [pn].
    assert (p_occurs_in_phi phi1 (pv pn) = true \/
         p_occurs_in_phi phi2 (pv pn) = true) as H2.
      left; exact Hocc.
    destruct (p_occurs_in_phi_mimpl phi1 phi2 (pv pn)) as [Hf Hr].
    specialize (Hr H2).
    clear H2 Hf.
    specialize (l Hr i (occ_in_phi_mimpl_l phi1 phi2 i Hocc2)).
    pose proof (is_pos_neg_mimpl phi1 phi2 i) as H4.
    destruct H4 as [H4l H4r].
      apply l.
      simpl.
      rewrite at_pv_app_l.
        exact Heq.

        apply PeanoNat.Nat.leb_le.
        apply occ_in_phi_leb; exact Hocc2.

      apply H4l.
      exact Hocc2.

    rewrite Hocc; intros; discriminate.
Qed.

Lemma p_is_pos_mimpl2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_pos (mimpl phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_pos phi2 p.
Proof.
  intros phi1 phi2 p Hpos Hpocc.
  unfold p_is_pos.
  destruct Hpos as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mimpl_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mimpl phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_pos_neg_mimpl_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.
        specialize (H1 H2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_pos_box : forall (phi : Modal) (p : propvar),
  p_is_pos (box phi) p -> p_is_pos phi p.
Proof.
  intros phi p H.
  unfold p_is_pos in *.
  destruct H as [t f].
  apply conj.
    intros Hoccp i Hocc Hat.
    destruct p as [pn].
    case_eq (at_pv (pv_in phi) i).
      intros qm Hat2.
      rewrite Hat2 in *.
      destruct (p_occurs_in_phi_box phi (pv pn)) as [forw rev].
      specialize (rev Hoccp).
      rewrite rev in t.
      clear forw rev.
      specialize (t true_true i).
      destruct (occ_in_phi_box phi i) as [forw rev];
      specialize (rev Hocc); rewrite rev in t; clear forw rev.
      simpl pv_in in t.
      rewrite Hat2 in t.
      specialize (t true_true Hat).
      apply is_pos_box; exact t.

    intros Hf.
    apply f.
    pose proof (contrapos_bool_tt (p_occurs_in_phi (box phi) p)
                               (p_occurs_in_phi phi p)) as H.
    destruct (p_occurs_in_phi_box phi p) as [forw rev].
    specialize (H forw).
    apply H; exact Hf.
Qed.

Lemma p_is_pos_diam : forall (phi : Modal) (p : propvar),
  p_is_pos (diam phi) p -> p_is_pos phi p.
Proof.
  intros phi p H.
  unfold p_is_pos in *.
  destruct H as [t f].
  apply conj.
    intros Hoccp i Hocc Hat.
    destruct p as [pn].
    case_eq (at_pv (pv_in phi) i).
      intros qm Hat2.
      rewrite Hat2 in *.
      destruct (p_occurs_in_phi_diam phi (pv pn)) as [forw rev].
      specialize (rev Hoccp).
      rewrite rev in t.
      clear forw rev.
      specialize (t true_true i).
      destruct (occ_in_phi_diam phi i) as [forw rev];
      specialize (rev Hocc); rewrite rev in t; clear forw rev.
      simpl pv_in in t.
      rewrite Hat2 in t.
      specialize (t true_true Hat).
      apply is_pos_diam; exact t.

    intros Hf.
    apply f.
    pose proof (contrapos_bool_tt (p_occurs_in_phi (diam phi) p)
                               (p_occurs_in_phi phi p)) as H.
    destruct (p_occurs_in_phi_diam phi p) as [forw rev].
    specialize (H forw).
    apply H; exact Hf.
Qed.

(* ---------------------------------------------------------------------------- *)
(* p_is_neg lemmas *)

Lemma p_is_neg_notin : forall (phi : Modal) (p : propvar),
  p_is_neg phi p -> p_occurs_in_phi phi p = true.
Proof.
  intros phi p Hneg.
  case_eq (p_occurs_in_phi phi p); intros Hpocc.
    reflexivity.

    unfold p_is_neg in Hneg.
    destruct Hneg as [t f].
    specialize (f Hpocc); contradiction.
Qed.

Lemma p_is_neg_atom : forall (p q : propvar),
  p_is_neg (atom q) p -> p = q.
Proof.
  intros p q H.
  pose proof (p_is_neg_notin (atom q) p H) as H2.
  unfold p_occurs_in_phi in H2.
  simpl in *.
  destruct p as [pn]; destruct q as [qm].
  case_eq (beq_nat pn qm); intros Hbeq; rewrite Hbeq in *.
    rewrite (beq_nat_true pn qm Hbeq); reflexivity.

    discriminate.
Qed.

Lemma p_is_neg_mconj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mconj phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  assert (p_occurs_in_phi (mconj phi1 phi2) p = true) as Hpocc3.
    apply p_occurs_in_phi_mconj.
    left; exact Hpocc.
  apply conj; intros Hpocc2.
    intros i Hocc Heq.
    assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
      apply occ_in_phi_leb.
      exact Hocc.
    assert (beq_nat i 0 = false) as Hbeq.
      apply occ_in_phi_0 with (phi:=phi1).
      exact Hocc.
    pose proof (occ_in_phi_mconj_l phi1 phi2 i Hocc) as Hocc2.
    specialize (l Hpocc3 i Hocc2).
    simpl pv_in in l.
    rewrite at_pv_app_l in l.
      specialize (l Heq).
      destruct (is_neg_mconj phi1 phi2 i l) as [Hl Hr].
      apply Hl.
      exact Hocc.

      apply PeanoNat.Nat.leb_le.
      exact Hleb.

    rewrite Hpocc2 in *; discriminate.
Qed.

Lemma p_is_neg_mconj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mconj phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg.
  destruct Hneg as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mconj_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mconj phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_neg_mconj_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.

        case_eq (occ_in_phi phi1 (length (pv_in phi1) + i)); intros Hocc2.
          destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
          apply leb_minus with (i := length (pv_in phi1)) in Hb.
          rewrite arith_plus_3 in Hb.
          rewrite arith_minus_refl in Hb.
          rewrite leb_beq_zero in Hb.
          rewrite (beq_nat_true _ _ Hb) in *.
          apply occ_in_phi_0 in Hocc; discriminate.

        specialize (H1 Hocc2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_neg_mdisj2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mdisj phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_neg phi1 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  assert (p_occurs_in_phi (mdisj phi1 phi2) p = true) as Hpocc3.
    apply p_occurs_in_phi_mdisj.
    left; exact Hpocc.
  apply conj; intros Hpocc2.
    intros i Hocc Heq.
    assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
      apply occ_in_phi_leb.
      exact Hocc.
    assert (beq_nat i 0 = false) as Hbeq.
      apply occ_in_phi_0 with (phi:=phi1).
      exact Hocc.
    pose proof (occ_in_phi_mdisj_l phi1 phi2 i Hocc) as Hocc2.
    specialize (l Hpocc3 i Hocc2).
    simpl pv_in in l.
    rewrite at_pv_app_l in l.
      specialize (l Heq).
      destruct (is_neg_mdisj phi1 phi2 i l) as [Hl Hr].
      apply Hl.
      exact Hocc.

      apply PeanoNat.Nat.leb_le.
      exact Hleb.

    rewrite Hpocc2 in *; discriminate.
Qed.

Lemma p_is_neg_mdisj2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mdisj phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg.
  destruct Hneg as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mdisj_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mdisj phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_neg_mdisj_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.

        case_eq (occ_in_phi phi1 (length (pv_in phi1) + i)); intros Hocc2.
          destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
          apply leb_minus with (i := length (pv_in phi1)) in Hb.
          rewrite arith_plus_3 in Hb.
          rewrite arith_minus_refl in Hb.
          rewrite leb_beq_zero in Hb.
          rewrite (beq_nat_true _ _ Hb) in *.
          apply occ_in_phi_0 in Hocc; discriminate.

        specialize (H1 Hocc2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_neg_mimpl2l: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mimpl phi1 phi2) p ->
    p_occurs_in_phi phi1 p = true ->
      p_is_pos phi1 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  assert (p_occurs_in_phi (mimpl phi1 phi2) p = true) as Hpocc3.
    apply p_occurs_in_phi_mimpl.
    left; exact Hpocc.
  apply conj; intros Hpocc2.
    intros i Hocc Heq.
    assert (Nat.leb i (length (pv_in phi1)) = true) as Hleb.
      apply occ_in_phi_leb.
      exact Hocc.
    assert (beq_nat i 0 = false) as Hbeq.
      apply occ_in_phi_0 with (phi:=phi1).
      exact Hocc.
    pose proof (occ_in_phi_mimpl_l phi1 phi2 i Hocc) as Hocc2.
    specialize (l Hpocc3 i Hocc2).
    simpl pv_in in l.
    rewrite at_pv_app_l in l.
      specialize (l Heq).
      destruct (is_neg_mimpl phi1 phi2 i l) as [Hl Hr].
      apply is_neg_pos_f.
        assumption.

        apply Hl; assumption.
      apply PeanoNat.Nat.leb_le.
      assumption.
    rewrite Hpocc2 in *; discriminate.
Qed.

Lemma p_is_neg_mimpl2r: forall (phi1 phi2 : Modal) (p : propvar),
  p_is_neg (mimpl phi1 phi2) p ->
    p_occurs_in_phi phi2 p = true ->
      p_is_neg phi2 p.
Proof.
  intros phi1 phi2 p Hneg Hpocc.
  unfold p_is_neg.
  destruct Hneg as [Hpocct Hpoccf].
  apply conj; intros H.
    intros i Hocc Heq.
    pose proof (occ_in_phi_mimpl_r phi1 phi2 i Hocc) as H0.
    destruct p as [pn].
    case_eq (p_occurs_in_phi (mimpl phi1 phi2) (pv pn));
    intros Hpocc2.
      specialize (Hpocct Hpocc2 (length (pv_in phi1) + i) H0).
      simpl pv_in in Hpocct.
      rewrite at_pv_app_r in Hpocct.
        remember (at_pv (pv_in phi2) i) as t;
        destruct t as [qm].
        specialize (Hpocct Heq).
        pose proof (is_neg_mimpl_r phi1 phi2 (length (pv_in phi1) + i)
             Hpocct).
        assert (Nat.leb (length (pv_in phi1) + 1) (length (pv_in phi1) + i)
                    = true) as H2.
          rewrite <- leb_plus_pre with (m := (length (pv_in phi1))).
          unfold Nat.leb.
          destruct i.
            apply occ_in_phi_0 in Hocc.
            simpl in Hocc; discriminate.

            reflexivity.

        case_eq (occ_in_phi phi1 (length (pv_in phi1) + i)); intros Hocc2.
          destruct (occ_in_phi_leb2 _ _ Hocc2) as [Ha Hb].
          apply leb_minus with (i := length (pv_in phi1)) in Hb.
          rewrite arith_plus_3 in Hb.
          rewrite arith_minus_refl in Hb.
          rewrite leb_beq_zero in Hb.
          rewrite (beq_nat_true _ _ Hb) in *.
          apply occ_in_phi_0 in Hocc; discriminate.

        specialize (H1 Hocc2).
        rewrite arith_plus_3 in H1.
        assumption.

        apply occ_in_phi_leb2 in Hocc.
        apply Hocc.

      specialize (Hpoccf Hpocc2); contradiction.

    rewrite H in *; discriminate.
Qed.

Lemma p_is_neg_box : forall (phi : Modal) (p : propvar),
  p_is_neg (box phi) p -> p_is_neg phi p.
Proof.
  intros phi p Hneg.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  apply conj; intros Hpocc.
    intros i Hocc Heq.
    apply is_neg_box.
    apply l.
      apply p_occurs_in_phi_box; exact Hpocc.

      apply occ_in_phi_box; exact Hocc.

      simpl; exact Heq.

    apply r.
    destruct (p_occurs_in_phi_box phi p) as [forw rev].
    apply (contrapos_bool_tt _ _ forw).
    exact Hpocc.
Qed.

Lemma p_is_neg_diam : forall (phi : Modal) (p : propvar),
  p_is_neg (diam phi) p -> p_is_neg phi p.
Proof.
  intros phi p Hneg.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  apply conj; intros Hpocc.
    intros i Hocc Heq.
    apply is_neg_diam.
    apply l.
      apply p_occurs_in_phi_diam; exact Hpocc.

      apply occ_in_phi_diam; exact Hocc.

      simpl; exact Heq.

    apply r.
    destruct (p_occurs_in_phi_diam phi p) as [forw rev].
    apply (contrapos_bool_tt _ _ forw).
    exact Hpocc.
Qed.

(* ---------------------------------------------------------------------------- *)
(* p_is_pos and p_is_neg relationship *)

Lemma p_is_pos_neg : forall (phi : Modal) (p : propvar),
  p_is_pos (mneg phi) p -> p_is_neg phi p.
Proof.
  intros phi p Hpos.
  unfold p_is_neg.
  unfold p_is_pos in *.
  destruct Hpos as [l r].
  apply conj.
    intros Hpocc i Hocc Heq.
    apply is_pos_neg_f; try assumption.

    apply is_pos_mneg.
    apply l; try assumption.
      apply occ_in_phi_mneg; assumption.

      assumption.
Qed.

Lemma p_is_neg_pos : forall (phi : Modal) (p : propvar),
  p_is_neg (mneg phi) p -> p_is_pos phi p.
Proof.
  intros phi p Hneg.
  unfold p_is_pos.
  unfold p_is_neg in *.
  destruct Hneg as [l r].
  apply conj.
    intros Hpocc i Hocc Heq.
    apply contrapos_bool_ft with (b := is_neg phi i).
      intro H.
      exact (is_pos_neg_f phi i Hocc H).

      apply is_neg_mneg.
      apply l;
        try apply p_occurs_in_phi_mneg;
        try exact Hpocc.

        apply occ_in_phi_mneg.
        exact Hocc.

        simpl.
        exact Heq.

    intros; apply r.
      apply contrapos_bool_tt with (b := p_occurs_in_phi phi p).
        apply p_occurs_in_phi_mneg.

        assumption.
Qed.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.
Require Import Coq.Program.Equality.
Require Export Subtyping.

Module MDisjointness
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MSubtyping := MSubtyping(VarTyp)(set).
Export MSubtyping.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Top        => 3
  | PBVarT n   => 4
  | PFVarT v   => 5
  | And t1 t2  => 6
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 3 /\ hd t2 < 3 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d1 d2 t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis (And d1 d2)) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                PType (And d1 d2) ->
                Ortho Gamma (ForAll d1 t1) (ForAll d2 t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub A ty ->
                       PType ty ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub A ty ->
                          PType ty ->
                          Ortho Gamma ty (PFVarT x)
  | OTop1 : forall Gamma t, Ortho Gamma Top t
  | OTop2 : forall Gamma t, Ortho Gamma t Top
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

(** Ortho environment properties **)

Lemma ortho_weaken :
  forall G E F t1 t2, Ortho (E ++ G) t1 t2 ->
                 Ortho (E ++ F ++ G) t1 t2.
Proof.
  intros.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto; subst.
  - apply_fresh OForAll as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    rewrite <- app_comm_cons.
    unfold extend; simpl; reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_strengthen : forall z U E F ty1 ty2,
  not (In z (union (fv_ptyp ty1) (fv_ptyp ty2))) ->
  Ortho (E ++ ((z,U) :: nil) ++ F) ty1 ty2 ->
  Ortho (E ++ F) ty1 ty2.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - apply OAnd1; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OAnd2; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OFun;
    apply IHOrtho; simpl in H; not_in_L z; auto.
  - apply_fresh OForAll as x.
    subst; unfold extend; simpl.
    rewrite app_comm_cons.
    eapply H1.
    not_in_L x.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.union_1 in HH.
    destruct HH as [HH | HH]; apply fv_open_rec_typ_source in HH.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_2.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_3.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    unfold extend; now simpl.
    auto.
  - subst.
    apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H3.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H4.
    now apply MSetProperties.Dec.F.singleton_2.
Qed.

Hint Resolve ortho_weaken ortho_strengthen.

Lemma ortho_extend_comm :
  forall F E x v ty1 ty2,
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2 ->
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ E ++ (x, v) :: nil).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ (x, v) :: E) with
           (((y, TyDis (And d1 d2)) :: F) ++ ((x, v) :: nil) ++ E).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_extend_comm' :
  forall F E x v ty1 ty2,
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2 ->
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ (x, v) :: nil ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ E ++ (x, v) :: nil) with
           (((y, TyDis (And d1 d2)) :: F) ++ E ++ (x, v) :: nil).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_app_comm :
  forall E F ty1 ty2, Ortho (F ++ E) ty1 ty2 -> Ortho (E ++ F) ty1 ty2.
Proof.
  intros E F ty1 ty2 HOrtho.
  remember (F ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H0 with (F0 := extend x (TyDis (And d1 d2)) F) (E0 := E) in Ha.
    apply ortho_extend_comm' in Ha.
    change ((x, TyDis (And d1 d2)) :: E ++ F) with (nil ++ (x, TyDis (And d1 d2)) :: E ++ F).
    apply ortho_extend_comm with (E := E ++ F).
    simpl in *.
    rewrite <- app_assoc.
    apply Ha.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
Qed.

Lemma ortho_middle_comm : forall H E F G ty1 ty2,
              Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
              Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  induction H; intros.
  - rewrite app_nil_r in *.
    rewrite app_assoc.
    apply ortho_app_comm.
    generalize dependent E.
    generalize dependent F.
    induction G; intros.
    + intros; rewrite app_nil_r in *; now apply ortho_app_comm.
    + intros.
      change (F ++ E ++ a :: G) with (F ++ E ++ (a :: nil) ++ G).
      destruct a.
      assert ((F ++ E ++ ((v, t0) :: nil) ++ G) = (F ++ (E ++ ((v, t0) :: nil)) ++ G))
             by now rewrite <- app_assoc.
      rewrite H0; clear H0.
      apply IHG.
      rewrite <- app_assoc.
      apply ortho_extend_comm.
      change (E ++ F ++ (v, t0) :: G) with (E ++ F ++ ((v, t0) :: nil) ++ G) in H.
      rewrite app_assoc in H.
      apply ortho_extend_comm' in H.
      now rewrite <- app_assoc in *.
  - change (E ++ G ++ F ++ a :: H) with (E ++ G ++ F ++ (a :: nil) ++ H).
    destruct a.
    assert ((E ++ G ++ F ++ ((v, t0) :: nil) ++ H) =
            (E ++ G ++ (F ++ ((v, t0) :: nil)) ++ H)) by
    now rewrite <- app_assoc.
    rewrite H1; clear H1.
    apply IHlist.
    rewrite <- app_assoc.
    rewrite app_assoc.
    apply ortho_extend_comm.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite app_assoc in H0.
    rewrite app_assoc in H0.
    change (((E ++ F) ++ G) ++ (v, t0) :: H) with
           (((E ++ F) ++ G) ++ ((v, t0) :: nil) ++ H).
    apply ortho_extend_comm' in H0.
    repeat rewrite <- app_assoc in H0.
    apply H0.
Qed.

Hint Resolve in_or_app.
Hint Resolve in_app_or.

Lemma ortho_env_comm :
  forall E F G H ty1 ty2, Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
                     Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl; rewrite app_comm_cons; apply H1.
    not_in_L x.
    reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
  - apply OVarSym with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
Qed.

Lemma ortho_weaken_sub :
  forall E G x t1 t2 d1 d2,
    ~ (In x (union (dom E) (dom G))) ->
    Ortho (E ++ extend x (TyDis d1) G) t1 t2 ->
    usub d2 d1  ->
    Ortho (E ++ extend x (TyDis d2) G) t1 t2.
Proof.
  intros E G x t1 t2 d1 d2 HNotIn HOrtho Husub.
  remember (E ++ extend x (TyDis d1) G) as Gamma.
  generalize dependent HeqGamma.
  generalize dependent E.
  induction HOrtho; intros; subst; eauto.
  - apply_fresh OForAll as x.
    assert (extend y (TyDis (And d0 d3)) (E ++ extend x (TyDis d2) G) =
            (extend y (TyDis (And d0 d3)) E) ++ extend x (TyDis d2) G) by
        (unfold extend; now simpl).
    rewrite H2.
    apply H0.
    not_in_L y.
    simpl.
    unfold not; intros; apply HNotIn.
    rewrite MSetProperties.union_add in H3.
    assert (Ha : x <> y).
    not_in_L y; unfold not; intros; subst; apply H16.
    now apply MSetProperties.Dec.F.singleton_iff.
    apply MSetProperties.Dec.F.add_iff in H3.
    destruct H3; auto.
    symmetry in H3; contradiction.
    now simpl.
    auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVar with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVar with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVarSym with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVarSym with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
Qed.

Lemma ortho_weaken_sub_extend :
  forall Gamma x t1 t2 d1 d2, ~ In x (dom Gamma) ->
                     Ortho (extend x (TyDis d1) Gamma) t1 t2 ->
                     usub d2 d1 ->
                     Ortho (extend x (TyDis d2) Gamma) t1 t2.
Proof.
  intros Gamma x t1 t2 d1 d2 HNotIn HOrtho Husub.
  change (extend x (TyDis d2) Gamma) with (nil ++ extend x (TyDis d2) Gamma).
  apply ortho_weaken_sub with (d1 := d1); auto.
Qed.

Lemma Ortho_sym : forall Gamma t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma t2 t1.
Proof.
  intros Gamma t1 t2 HOrtho.
  induction HOrtho; eauto.
  - inversion H1; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply USAnd1.
    apply USAnd3; auto.
    apply usub_refl; auto.
    apply USAnd2.
    apply usub_refl; auto.
    auto.
    auto.
  - apply OAx; auto.
    destruct H as [H1 [H2 H3]].
    unfold OrthoAx; auto.
Qed.

Lemma Ortho_usub_trans :
  forall Gamma u ty d,
    PType ty ->
    Ortho Gamma u d ->
    usub d ty ->
    Ortho Gamma u ty.
Proof.
  intros Gamma u ty d HWFty HOrtho HSub.
  generalize dependent ty.
  induction HOrtho; intros; eauto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
    inversion H1; subst.
    clear IHty1 IHty2.
    inversion HWFty; subst.
    inversion HSub; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H9.
    not_in_L x.
    apply USAnd1.
    apply USAnd2; auto.
    apply usub_refl; auto.
    apply USAnd3; auto.
    auto.
  - pose (usub_trans _ _ _ HWFty H0 HSub).
    apply OVar with (A := A) ; auto.
  - induction ty0; try (now inversion HSub).
    inversion HSub; subst; inversion HWFty; auto.
    inversion HSub; subst; eauto.
  - dependent induction HSub.
    inversion HWFty.
    apply OAnd2; auto.
    auto.
  - destruct t1; destruct t2;
    try (destruct H0 as [_ [_ H0]]; exfalso; now apply H0);
    try (now orthoax_inv_r H0); try (now orthoax_inv_l H0);
    try now (induction ty; inversion HSub; subst; inversion HWFty; auto).
Qed.

(* Properties concerning substitution and sub/ortho/wf *)

Lemma ortho_subst_not_in :
  forall Gamma z u t1 t2,
    not (In z (union (fv_ptyp t1) (fv_ptyp t2))) ->
    PType u ->
    Ortho Gamma t1 t2 ->
    Ortho (subst_env Gamma z u) t1 t2.
Proof.
  intros Gamma z u t1 t2 HNotIn HWFu HOrtho.
  generalize dependent z.
  induction HOrtho; intros z HNotIn; simpl in HNotIn; auto.
  - apply OAnd1; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt1.
  - apply OAnd2; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt2.
  - apply OFun; apply IHHOrtho; auto; not_in_L z.
  - assert (Ha : Ortho (subst_env Gamma z u) (ForAll (subst_typ_source z u d1) t1)
                       (ForAll (subst_typ_source z u d2) t2)).
    apply_fresh OForAll as x. apply H0. not_in_L x.
    unfold not; intros HH; rewrite union_spec in HH; destruct HH as [HH | HH];
    apply fv_open_rec_typ_source in HH; simpl in HH; rewrite union_spec in HH;
    destruct HH as [HH | HH]; try (now not_in_L z);
    not_in_L x; apply H11; apply MSetProperties.Dec.F.singleton_iff;
    apply MSetProperties.Dec.F.singleton_iff in HH; auto.
    apply PType_And.
    apply subst_source_lc; inversion H1; subst; auto.
    apply subst_source_lc; inversion H1; subst; auto.
    assert (Ha1 : d1 = subst_typ_source z u d1) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    assert (Ha2 : d2 = subst_typ_source z u d2) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    now rewrite Ha1, Ha2.
  - apply OVar with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply OVarSym with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
Qed.

Lemma ortho_subst :
  forall z u Gamma d t1 t2,
    not (In z (fv_ptyp u)) ->
    WFEnv (subst_env Gamma z u) ->
    WFEnv Gamma ->
    MapsTo Gamma z d ->
    Ortho Gamma u d ->
    Ortho Gamma t1 t2 ->
    PType u ->
    PType t1 ->
    PType t2 ->
    Ortho (subst_env Gamma z u) (subst_typ_source z u t1) (subst_typ_source z u t2).
Proof.
  intros z u Gamma d t1 t2 HNotIn HWFEnvS HWFEnv HMapsTo HOrthoud HOrthot1t2 HWFu HWFt1 HWFt2.
  induction HOrthot1t2.
  - simpl; inversion HWFt1; auto.
  - simpl; inversion HWFt2; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst.
    apply_fresh OForAll as x.
    repeat rewrite subst_typ_source_open_source_var.
    simpl in H0.
    apply H0.
    not_in_L x.
    apply WFPushV; auto.
    simpl.
    not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    apply WFPushV; auto; not_in_L x.
    simpl in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply MapsTo_extend; auto.
    not_in_L x.
    rewrite <- app_nil_l with (l := (extend x (TyDis (And d1 d2)) Gamma)).
    apply ortho_weaken.
    now simpl.
    apply H5.
    not_in_L x.
    apply H9.
    not_in_L x.
    not_in_L x.
    assumption.
    not_in_L x.
    assumption.
    apply PType_And; apply subst_source_lc; auto.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVar with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      apply Ortho_sym.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVarSym with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - simpl; apply OTop1.
  - simpl; apply OTop2.
  - apply OAx; auto.
    assert (Ha : OrthoAx t1 t2) by assumption.
    destruct t1; destruct t2; auto; simpl; try (now orthoax_inv_r H0);
    try now orthoax_inv_l H0.
Qed.

End MDisjointness.