(* in Coq 8.8.0 -no-is *)

Unset Elimination Schemes.

Notation "x -> y" := (forall (_ : x), y)
 (at level 99, right associativity, y at level 200)
.

Inductive bool : Type :=
| false : bool
| true : bool
.

Definition bool_rec
 {P : Type} (cf : P) (ct : P) (x : bool) : P
:=
 match x with
 | false => cf
 | true => ct
 end
.

Definition bool_rect
 {P : bool -> Type} (cf : P false) (ct : P true) (x : bool) : P x
:=
 match x with
 | false => cf
 | true => ct
 end
.

Definition and (x y : bool) : bool :=
 match x, y with
 | false, false => false
 | false, true => false
 | true, false => false
 | true, true => true
 end
.

Definition or (x y : bool) : bool :=
 match x, y with
 | false, false => false
 | false, true => true
 | true, false => true
 | true, true => true
 end
.

Definition not (x : bool) : bool :=
 match x with
 | false => true
 | true => false
 end
.

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

Fixpoint nat_rec
 {P : Type} (co : P) (cs : P -> P) (x : nat) : P
:=
 match x with
 | O => co
 | S xp => cs (nat_rec co cs xp)
 end
.

Fixpoint nat_rect
 {P : nat -> Type} (co : P O) (cs : forall xp, P xp -> P (S xp)) (x : nat) : P x
:=
 match x with
 | O => co
 | S xp => cs xp (nat_rect co cs xp)
 end
.

Fixpoint plus (m n : nat) : nat :=
 match m with
 | O => n
 | S mp => S (plus mp n)
 end
.

Fixpoint mult (m n : nat) : nat :=
 match m with
 | O => O
 | S mp => plus n (mult mp n)
 end
.

Fixpoint power (m n : nat) : nat :=
 match n with
 | O => S O
 | S np => mult m (power m np)
 end
.

Inductive prod (A B : Type) : Type :=
| pair : A -> B -> prod A B
.

Arguments pair {A B} x y.

Definition prod_rec
 {A B P : Type} (cp : A -> B -> P) (x : prod A B) : P
:=
 match x with
 | pair a b => cp a b
 end
.

Definition prod_rect
 {A B : Type} {P : prod A B -> Type} (cp : forall a b, P (pair a b))
 (x : prod A B) : P x
:=
 match x as x' return P x' with
 | pair a b => cp a b
 end
.

Definition fst {A B : Type} (x : prod A B) : A :=
 match x with
 | pair a _ => a
 end
.

Definition snd {A B : Type} (x : prod A B) : B :=
 match x with
 | pair _ b => b
 end
.

Inductive sum (A B : Type) : Type :=
| left : A -> sum A B
| right : B -> sum A B
.

Arguments left {A B} x.
Arguments right {A B} x.

Definition sum_rec
 {A B P : Type} (cl : A -> P) (cr : B -> P) (x : sum A B) : P
:=
 match x with
 | left a => cl a
 | right b => cr b
 end
.

Definition sum_rect
 {A B : Type} {P : sum A B -> Type}
 (cl : forall a, P (left a)) (cr : forall b, P (right b))
 (x : sum A B) : P x
:=
 match x with
 | left a => cl a
 | right b => cr b
 end
.

Inductive Unit : Type :=
| unit : Unit
.

Definition Unit_rec
 {P : Type} (cu : P) (x : Unit) : P
:=
 match x with
 | unit => cu
 end
.

Definition Unit_rect
 {P : Unit -> Type} (cu : P unit) (x : Unit) : P x
:=
 match x with
 | unit => cu
 end
.

Inductive Empty : Type :=
.

Definition Empty_rec
 {P : Type} (x : Empty) : P
:=
 match x with
 end
.

Definition Empty_rect
 {P : Empty -> Type} (x : Empty) : P x
:=
 match x with
 end
.

Definition neg (A : Type) : Type := A -> Empty.

Definition all {A : Type} (P : A -> Type) : Type := forall x, P x.

Inductive ex {A : Type} (P : A -> Type) : Type :=
| ex_pair : forall x, P x -> ex P
.

Arguments ex_pair {A P} x _.

Definition ex_rec
 {A : Type} {B : A -> Type} {P : Type} (c : forall x, B x -> P) (x : ex B) : P
:=
 match x with
 | ex_pair x H => c x H
 end
.

Definition ex_rect
 {A : Type} {B : A -> Type} {P : ex B -> Type}
 (c : forall (x : A) (H : B x), P (ex_pair x H))
 (x : ex B) : P x
:=
 match x with
 | ex_pair x H => c x H
 end
.

Definition ex_fst {A : Type} {P : A -> Type} (x : ex P) : A :=
 match x with
 | ex_pair x _ => x
 end
.

Definition ex_snd {A : Type} {P : A -> Type} (x : ex P) : P (ex_fst x) :=
 match x with
 | ex_pair _ H => H
 end
.

Inductive paths {A : Type} (a : A) : A -> Type :=
| idpath : paths a a
.

Arguments idpath {A a} , [A] a.

Definition paths_rec
 {A : Type} {a : A} {P : A -> Type} (ci : P a)
 {a' : A} (x : paths a a') : P a'
:=
 match x with
 | idpath => ci
 end
.

Definition paths_rect
 {A : Type} {a : A} {P : forall a', paths a a' -> Type} (ci : P a idpath)
 {a' : A} (x : paths a a') : P a' x
:=
 match x with
 | idpath => ci
 end
.

Definition paths_rec_nop
 {A : Type} {P : A -> A -> Type} (ci : forall a, P a a)
 {a a' : A} (x : paths a a') : P a a'
:=
 match x with
 | idpath => ci a
 end
.

Definition paths_rect_nop
 {A : Type} (P : forall a a', paths a a' -> Type) (ci : forall a, P a a idpath)
 {a a' : A} (x : paths a a') : P a a' x
:=
 match x with
 | idpath => ci a
 end
.

Definition concat
 {A : Type} {x y z : A} (p : paths x y) (q : paths y z) : paths x z
:=
 match q with
 | idpath =>
  match p with
  | idpath => idpath
  end
 end
.

Definition inverse
 {A : Type} {x y : A} (p : paths x y) : paths y x
:=
 match p with
 | idpath => idpath
 end
.

Definition ap
 {A B : Type} (f : A -> B) {x y : A} (p : paths x y) : paths (f x) (f y)
:=
 match p with
 | idpath => idpath
 end
.

Declare ML Module "ltac_plugin".

Export Set Default Proof Mode "Classic".

Notation "x && y" := (and x y) (at level 40, left associativity).

Notation "x || y" := (or x y) (at level 40, left associativity).

Notation "x + y" := (plus x y) (at level 50, left associativity).

Notation "x * y" := (mult x y) (at level 40, left associativity).

Notation "x /\ y" := (prod x y) (at level 80, right associativity).

Notation "x \/ y" := (sum x y) (at level 85, right associativity).

Notation "~ x" := (neg x) (at level 75, right associativity).

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
 (
  at level 200,
  x binder,
  right associativity,
  format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
.

Notation "x = y :> A" := (@paths A x y)
 (at level 70, y at next level, no associativity)
.

Notation "x = y" := (x = y :> _) (at level 70, no associativity).

Notation "x @( ty )@ y" := (concat (y := ty) x y)
 (at level 20, right associativity)
.

Notation "x @ y" := (x @( _ )@ y) (at level 20, no associativity).

Ltac pull x := refine (fun x => _).
Ltac push x := revert x.

Definition plus_O_n {n : nat} : O + n = n.
Proof.
 change (O + n) with n.
 exact idpath.
Defined.

Definition plus_n_O {n : nat} : n + O = n.
Proof.
 push n.
 refine (nat_rect _ _).
 -
  change (O + O) with O.
  exact idpath.
 -
  pull np.
  pull IHnp.
  change (S np + O) with (S (np + O)).
  refine (ap _ _).
  exact IHnp.
Defined.

Definition plus_Sm_n {m n : nat} : S m + n = S (m + n).
Proof.
 change (S m + n) with (S (m + n)).
 exact idpath.
Defined.

Definition plus_m_Sn {m n : nat} : m + S n = S (m + n).
Proof.
 push n.
 push m.
 refine (nat_rect _ _).
 -
  pull n.
  change (O + S n) with (S n).
  change (O + n) with n.
  exact idpath.
 -
  pull mp.
  pull IHmp.
  pull n.
  change (S mp + S n) with (S (mp + S n)).
  refine (ap _ _).
  exact (IHmp n).
Defined.

Definition plus_comm {m n : nat} : m + n = n + m.
Proof.
 push n.
 push m.
 refine (nat_rect _ _).
 -
  pull n.
  change (O + n) with n.
  refine (inverse _).
  exact plus_n_O.
 -
  pull mp.
  pull IHmp.
  pull n.
  change (S mp + n) with (S (mp + n)).
  refine (_ @(S (n + mp))@ _).
  +
   refine (ap _ _).
   exact (IHmp n).
  +
   refine (inverse _).
   exact plus_m_Sn.
Defined.

Definition plus_assoc {m n o : nat} : (m + n) + o = m + (n + o).
Proof.
 push o.
 push n.
 push m.
 refine (nat_rect _ _).
 -
  pull n.
  pull o.
  change (O + n) with n.
  change (O + (n + o)) with (n + o).
  exact idpath.
 -
  pull mp.
  pull IHmp.
  pull n.
  pull o.
  change (S mp + n) with (S (mp + n)).
  change (S (mp + n) + o) with (S (mp + n + o)).
  change (S mp + (n + o)) with (S (mp + (n + o))).
  refine (ap _ _).
  exact (IHmp n o).
Defined.

Definition plus_accom_l {m n o : nat} : m + (n + o) = n + (m + o).
Proof.
 refine (_ @((m + n) + o)@ _ @((n + m) + o)@ _).
 -
  refine (inverse _).
  exact plus_assoc.
 -
  refine (ap (fun x => x + _) _).
  exact plus_comm.
 -
  exact plus_assoc.
Defined.

Definition mult_O_n {n : nat} : O * n = O.
Proof.
 change (O * n) with O.
 exact idpath.
Defined.

Definition mult_n_O {n : nat} : n * O = O.
Proof.
 push n.
 refine (nat_rect _ _).
 -
  change (O * O) with O.
  exact idpath.
 -
  pull np.
  pull IHnp.
  change (S np * O) with (O + np * O).
  change (O + np * O) with (np * O).
  exact IHnp.
Defined.

Definition mult_Sm_n {m n : nat} : S m * n = n + m * n.
Proof.
 change (S m * n) with (n + m * n).
 exact idpath.
Defined.

Definition mult_m_Sn {m n : nat} : m * S n = m + m * n.
Proof.
 push n.
 push m.
 refine (nat_rect _ _).
 -
  pull n.
  change (O * S n) with O.
  change (O * n) with O.
  change (O + O) with O.
  exact idpath.
 -
  pull mp.
  pull IHmp.
  pull n.
  change (S mp * S n) with (S n + mp * S n).
  change (S n + mp * S n) with (S (n + mp * S n)).
  change (S mp + S mp * n) with (S (mp + S mp * n)).
  refine (ap _ _).
  change (S mp * n) with (n + mp * n).
  refine (_ @(n + (mp + mp * n))@ _).
  +
   refine (ap _ _).
   exact (IHmp n).
  +
   exact plus_accom_l.
Defined.

Definition mult_comm {m n : nat} : m * n = n * m.
Proof.
 push n.
 push m.
 refine (nat_rect _ _).
 -
  pull n.
  change (O * n) with O.
  refine (inverse _).
  exact mult_n_O.
 -
  pull mp.
  pull IHmp.
  pull n.
  change (S mp * n) with (n + mp * n).
  refine (_ @(n + n * mp)@ _).
  +
   refine (ap _ _).
   exact (IHmp n).
  +
   refine (inverse _).
   exact mult_m_Sn.
Defined.

Definition pointwise_paths
 {A : Type} {P : A -> Type} (f g : forall x, P x) : Type
:=
 forall x, f x = g x
.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity).

Definition pointwise_concat
 {A : Type} {P : A -> Type} {f g h : forall x, P x}
 (p : f == g) (q : g == h) : f == h
.
Proof.
 change (forall x, f x = h x).
 pull x.
 refine (_ @(g x)@ _).
 -
  change (forall x, f x = g x) in p.
  exact (p x).
 -
  change (forall x, g x = h x) in q.
  exact (q x).
Defined.

Section Rel.
 Variable A : Type.
 Variable R : A -> A -> Type.

 Definition Noetherian_induction : Type :=
  forall P, (forall x, (forall y, R y x -> P y) -> P x) -> forall x, P x
 .

 Definition is_empty_set (x : A) : Type :=
  forall y, ~ R y x
 .

 Definition has_a_predecessor (x : A) : Type :=
  exists y, R y x
 .

 Definition forall_has_a_predecessor : Type :=
  forall x, has_a_predecessor x
 .

 Definition is_predecessor_function (f : A -> A) : Type :=
  forall x, R (f x) x
 .

 Definition exists_is_predecessor_function : Type :=
  exists f, is_predecessor_function f
 .

 Definition predecessor_function_fhap
  (H: forall_has_a_predecessor) : A -> A
 .
 Proof.
  pull x.
  change (forall x, has_a_predecessor x) in H.
  change (forall x, exists y, R y x) in H.
  refine (ex_fst (P := fun y => R y x) _).
  exact (H x).
 Defined.

 Definition predecessor_function_eipf
  (H : exists_is_predecessor_function) : A -> A
 .
 Proof.
  change (exists f, is_predecessor_function f) in H.
  refine (ex_fst (P := is_predecessor_function) _).
  exact H.
 Defined.

 Definition eipf_fhap
  (H : forall_has_a_predecessor) : exists_is_predecessor_function
 .
 Proof.
  change (exists f, is_predecessor_function f).
  pose (pf := predecessor_function_fhap H).
  refine (ex_pair pf _).
  change (forall x, R (pf x) x).
  pull x.
  change (R (predecessor_function_fhap H x) x).
  change (R (ex_fst (H x)) x).
  change (forall x, has_a_predecessor x) in H.
  change (forall x, exists y, R y x) in H.
  exact (ex_snd (H x)).
 Defined.

 Definition fhap_eipf
  (H : exists_is_predecessor_function) : forall_has_a_predecessor
 .
 Proof.
  change (forall x, has_a_predecessor x).
  pull x.
  change (exists y, R y x).
  pose (pf := predecessor_function_eipf H).
  refine (ex_pair (pf x) _).
  change (R (predecessor_function_eipf H x) x).
  change (R (ex_fst H x) x).
  change (exists f, forall x, R (f x) x) in H.
  exact (ex_snd H x).
 Defined.

 Definition Contradict_ni_fhap
  (ni : Noetherian_induction) (fhap : forall_has_a_predecessor) (x : A) : Empty
 .
 Proof.
  change (
   forall P, (forall x, (forall y, R y x -> P y) -> P x) -> forall x, P x
  ) in ni.
  refine (ni (fun _ => Empty) _ _).
  -
   clear x.
   pull x.
   pull xH.
   change (forall x, has_a_predecessor x) in fhap.
   change (forall x, exists y, R y x) in fhap.
   refine (xH (ex_fst (fhap x)) _).
   exact (ex_snd (fhap x)).
  -
   exact x.
 Defined.

 Definition Contradict_ni_eipf
  (ni : Noetherian_induction) (eipf : exists_is_predecessor_function) (x : A) : Empty
 .
 Proof.
  change (
   forall P, (forall x, (forall y, R y x -> P y) -> P x) -> forall x, P x
  ) in ni.
  refine (ni (fun _ => Empty) _ _).
  -
   clear x.
   pull x.
   pull xH.
   change (exists f, is_predecessor_function f) in eipf.
   change (exists f, forall y, R (f y) y) in eipf.
   refine (xH (ex_fst eipf x) _).
   exact (ex_snd eipf x).
  -
   exact x.
 Defined.
End Rel.

Definition is_empty_set
 {A : Type} (R : A -> A -> Type) : Type
:=
 forall x, ~ forall y, ~ R y x
.

Definition Kuroda's_exists_empty_set
 {A : Type} (R : A -> A -> Type) : Type
:=
 ~ ~ exists x, forall y, ~ ~ ~ R y x
.

Definition Keee_eee
 {A : Type} (R : A -> A -> Type)
 : exists_empty_set R -> Kuroda's_exists_empty_set R
.
Proof.
 pull eee.
 change (~ ~ exists x, forall y, ~ ~ ~ R y x).
 change ((~ exists x, forall y, ~ ~ ~ R y x) -> Empty).
 pull H0.
 change ((exists x : A, forall y : A, ~ ~ ~ R y x) -> Empty) in H0.
 refine (H0 _).
 push eee.
 change (exists_empty_set R) with (exists x, forall y, ~ R y x).
 refine (ex_rec _).
 pull x.
 pull xH.
 refine (ex_pair x _).
 pull y.
 change ((~ ~ R y x) -> Empty).
 pull H1.
 change (~ R y x -> Empty) in H1.
 refine (H1 _).
 exact (xH y).
Defined.

Definition exists_predecessor
 {A : Type} (R : A -> A -> Type) : Type
:=
 forall x, exists y, R y x
.

Definition Kuroda's_exists_predecessor
 {A : Type} (R : A -> A -> Type) : Type
:=
 ~ ~ forall x, ~ ~ exists y, R y x
.

Definition Keae_nKeee
 {A : Type} (R : A -> A -> Type)
 : ~ Kuroda's_exists_empty_set R -> Kuroda's_exists_predecessor R
.
Proof.
 pull nKeee.
 change (~ ~ forall x, ~ ~ exists y, R y x).
 change (~ (forall x, ~ ~ exists y, R y x) -> Empty).
 pull pKep.
 change (Kuroda's_exists_empty_set R -> Empty) in nKeee.
 refine (nKeee _).
 change (~ ~ exists x, forall y, ~ ~ ~ R y x).
 change (~ (exists x, forall y, ~ ~ ~ R y x) -> Empty).
 pull pKeee.
 change ((forall x, ~ ~ (exists y, R y x)) -> Empty) in pKep.
 refine (pKep _).
 pull ppKep_x.
 change (~ (exists y : A, R y ppKep_x) -> Empty).
 pull ppKep_xH.
 change ((exists x, forall y, ~ ~ ~ R y x) -> Empty) in pKeee.
 refine (pKeee _).
 refine (ex_pair ppKep_x _).
 pull ppKeee_x.
 change (~ ~ R ppKeee_x ppKep_x -> Empty).
 pull ppKeee_xH.
 change ((exists y, R y ppKep_x) -> Empty) in ppKep_xH.
 refine (ppKep_xH _).
 refine (ex_pair ppKeee_x _).
 admit.
Admitted.

Definition nne3_Ni
 {A : Type} (R : A -> A -> Type)
 : Noetherian_induction R -> exists_empty_set R
.
Proof.
 admit.
Admitted.

Inductive fol (U : Type) : Type -> Type :=
| fol_unit : fol U Unit
| fol_empty : fol U Empty
| fol_prod : forall A B, fol U A -> fol U B -> fol U (A /\ B)
| fol_sum : forall A B, fol U A -> fol U B -> fol U (A \/ B)
| fol_forall : forall P, (forall x : U, fol U (P x)) -> fol U (forall x, P x)
| fol_exists : forall P, (exists x : U, fol U (P x)) -> fol U (exists x, P x)
| fol_neg : forall A, fol U A -> fol U (~ A)
| fol_atom : forall A, fol U A
.

(** Gödel–Gentzen translation *)
Inductive GG : Type -> Type -> Type :=
| GG_unit
 : GG Unit Unit
| GG_empty
 : GG Empty Empty
| GG_prod
 : forall A B C D, GG A C -> GG B D -> GG (A /\ B) (C /\ D)
| GG_sum
 : forall A B C D, GG A C -> GG B D -> GG (A \/ B) (~ (~ C \/ ~ D))
| GG_forall
 : forall A P G,
  (forall x : A, GG (P x) (G x)) -> GG (forall x, P x) (forall x, G x)
| GG_exists
 : forall A P G,
  (forall x : A, GG (P x) (G x)) -> GG (exists x, P x) (~ forall x, ~ G x)
| GG_neg
 : forall A B, GG A B -> GG (~ A) (~ B)
| GG_atom
 : forall A, GG A (~ ~ A)
.

Fixpoint GG_soundness
 (A B : Type) (H : GG A B)
 : ((forall X, ~ ~ X -> X) -> A) -> B
.
Proof.
 admit.
Admitted.

Fixpoint GG_completeness
 (A B : Type) (H : GG A B)
 : B -> (forall X, ~ ~ X -> X) -> A
.
Proof.
 admit.
Admitted.


Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.SetoidClass.
Require Import Coq.Classes.Equivalence.

Require Import Quotient.quotient.
From Quotient.Construction Require Import function_util equalizer coequalizer construction_of_equalizer power hyper_power co_equalizer_in_power construction_of_coequalizer.

Open Scope equiv_scope.

Require Import ChoiceFacts ClassicalFacts.

Definition weak_functional_extentionality
  := forall (A : Type) (f1 f2 : A -> bool), (forall a, f1 a = f2 a) -> f1 = f2.

Section Conclution.

  Variable proof_weak_functional_extentionality : weak_functional_extentionality.
  Variable proof_ConstructiveDefiniteDescription : ConstructiveDefiniteDescription.
  Variable proof_excluded_middle : excluded_middle.

  Instance instance_power_exists : axiom_power_exists.
  Proof.
    split.
    unfold power_exists.
    intros.
    apply (@Build_quotient _ _ (A -> bool) id).
    intros f1 f2 eqf.
    apply proof_weak_functional_extentionality in eqf.
    unfold id.
    rewrite eqf.
    reflexivity.
    exact epi_id.
    intros B f PropperH.
    exists f.
    rewrite f_comp_id_R.
    reflexivity.
  Qed.

  Instance instance_proof_irrelevance : axiom_proof_irrelevance.
  Proof.
    split.
    unfold proof_irrelevance.
    apply proof_irrelevance_cci.
    exact proof_excluded_middle.
  Qed.

  Instance instance_preserve_reflexive_equalizer : axiom_preserve_reflexive_equalizer.
  Proof.
    split.
    apply HPEM_preserve_reflexive_equalizer; assumption.
  Qed.

  Instance instance_power_reflects_iso : axiom_power_reflects_iso.
  Proof.
    split.
    apply HPEM_power_reflects_iso; assumption.
  Qed.

  Instance instance_power_f_faithful : axiom_power_f_faithful.
  Proof.
    split.
    apply HPEM_power_f_faithful; assumption.
  Qed.

  Theorem ccc_coequalizer_exists : coequalizer_exists.
  Proof.
    apply (XX__coequalizer_exists
             instance_proof_irrelevance
             instance_power_exists
             instance_preserve_reflexive_equalizer
             instance_power_reflects_iso
             instance_power_f_faithful
          ).
  Qed.

  Theorem ccc_quotient_exists : quotient_exists.
  Proof.
    apply coequalizer_exists__quotient_exists.
    apply ccc_coequalizer_exists.
  Qed.

End Conclution.

Goal
  weak_functional_extentionality ->
  ConstructiveDefiniteDescription ->
  excluded_middle ->
  quotient_exists.
Proof.
  exact ccc_quotient_exists.
Qed.


Require Export hexamys.

Lemma a_chasles_th : forall A B C P Q II J K I' K' J' X, hexamy ->
dist6 II I' Q K K' P ->
line B K <> line B II ->
B<> P -> B<> Q -> P<> C -> Q<> C ->
B<> K -> B <> II -> Q<>A -> P<>A ->
is_on_inter II P B Q C ->
is_on_inter I' P C Q B ->
is_on_inter J P C Q A ->
is_on_inter J' P A Q C ->
is_on_inter K P A Q B ->
is_on_inter K' P B Q A ->
is_on_inter X II I' K K' ->
Col X J J'.
Proof.
intros.
unfold is_transverse, is_on_inter, dist6 in *.
geo_norm.
remove_line_occ.
collapse.
not_eq x x0.
not_eq x5 x12.
not_eq x8 x9.

hexamy_proof  II I' Q  K K' P II I' P K K' Q .
Qed.


(** * Polarized syntax with polyadic binders *)

Require Export fintype.

Require Import Vectors.Vector Lia.
Require Import Utils.Various_utils.
Import VectorNotations.

Section ptypentype.
Context {w : nat} .

(** ** Syntax for types and contexts  *)
Inductive ptype (nntype : nat) : Type :=
  | top : ptype (nntype)
  | bAllN : (Vector.t (ntype  (nntype)) w) -> ntype  ((S) nntype) -> ptype (nntype)
 with ntype (nntype : nat) : Type :=
  | var_ntype : fin w -> (fin) (nntype) -> ntype (nntype)
  | uAllN : ptype  (S nntype) -> ntype (nntype).

Inductive ctx : nat -> Type :=
  | empty : ctx 0
  | add : forall {m : nat}, Vector.t (ntype m) w -> ctx m -> ctx (S m).

Definition nonEmptyCtx {m : nat} (Γ : ctx (S m)) : forall (P : ctx (S m) -> Type) (H : forall h t, P (add h t)), P Γ
  := match Γ with
    | add h t => fun P H => H h t
    | _ => fun x => False_rect (@IDProp) x
    end.

(** ** Custom induction for types
  Size induction is requiered to define the mutual induction principle.
*)

Fixpoint psize {m} (t : @ptype m) : nat := match t with
  | top _ => 1
  | bAllN _ v s => 1 + vsum (map nsize v) + nsize s
  end
with nsize {m} (s : @ntype m) : nat := match s with
  | var_ntype _ _ _ => 1
  | uAllN _ t => 1 + psize t
  end.

Lemma ptype_ntype_size_ind (P : forall m, @ptype m -> Prop) (Q : forall m, @ntype m -> Prop) :
  (forall m t, (forall m' s, nsize s < psize t -> Q m' s) -> P m t) ->
  (forall m t, (forall m' s, psize s < nsize t -> P m' s) -> Q m t) ->
  forall m, (forall t, P m t) /\ (forall s, Q m s).
Proof. intros Hp Hq. split; intros; [apply Hp | apply Hq].
  -assert (H : forall n m s, nsize s < n -> Q m s).
   {intro. induction n; intros. exfalso. lia. apply Hq. intros. apply Hp. intros. apply IHn. lia. }
   apply H.
  -assert (H : forall n m s, psize s < n -> P m s).
   {intro. induction n; intros. exfalso. lia. apply Hp. intros. apply Hq. intros. apply IHn. lia. }
   apply H.
Qed.

Fact in_ns {m} a t s: In a t -> @nsize m a < psize (bAllN _ t s).
Proof. intro. cbn.
  assert (In (nsize a) (map nsize t)). { induction H; simpl. apply In_cons_hd. now apply In_cons_tl. }
  pose (in_smaller _ _ H0). lia.
Qed.

Lemma ptype_ntype_mutind : forall (P : forall m : nat, @ptype m -> Prop)
  (Q : forall m : nat, @ntype m -> Prop),
  (forall m : nat, P m (@top m)) ->
  (forall (m : nat) (t : Vector.t (@ntype m) w) (n : @ntype (S m)),
    Q (S m) n -> @Forall (@ntype m) (Q m) _ t ->  P m (@bAllN m t n)) ->
  (forall (m : nat) (t0 : fin m) (t : fin w), Q m (@var_ntype m t t0)) ->
  (forall (m : nat) (p : @ptype (S m)), P (S m) p -> Q m (@uAllN m p)) ->
  forall m : nat, (forall p : @ptype m, P m p) /\ (forall n : @ntype m, Q m n).
Proof. intros P Q Htop HbAllN Hvar HuAllN. eapply ptype_ntype_size_ind.
  -intros. destruct t. apply Htop. apply HbAllN. apply H. cbn. lia.
   apply Forall_forall. intros. apply H. now apply in_ns.
  -intros. destruct t. apply Hvar. apply HuAllN, H. cbn. lia.
Qed.

(** ** Modified Autosubst output
Renamings and substitutions have an extra argument to access the vectors, this argument remains unchanged when the renaming or substitution is modified
*)

Lemma congr_top { mntype : nat } : top (mntype) = top (mntype) .
Proof. congruence. Qed.

Lemma congr_bAllN { mntype : nat } { s0 : (Vector.t (ntype  (mntype)) w) } { s1 : ntype  ((S) mntype) } { t0 : (Vector.t (ntype  (mntype)) w) } { t1 : ntype  ((S) mntype) } (H1 : s0 = t0) (H2 : s1 = t1) : bAllN (mntype) s0 s1 = bAllN (mntype) t0 t1 .
Proof. congruence. Qed.

Lemma congr_uAllN { mntype : nat } { s0 : ptype  (S mntype) } { t0 : ptype  (S mntype) } (H1 : s0 = t0) : uAllN (mntype) s0 = uAllN (mntype) t0 .
Proof. congruence. Qed.

Definition upRen_ntype_ntype { m : nat } { n' : nat } (xi : (fin) (m) -> (fin) (n')) : (fin) ((S) (m)) -> (fin) ((S) (n')) := (up_ren) (xi).

Fixpoint ren_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (s : ptype (mntype)) : ptype (nntype) :=
    match s return ptype (nntype) with
    | top (_)  => top (nntype)
    | bAllN (_) s0 s1 => bAllN (nntype) (Vector.map (ren_ntype xintype) s0) ((ren_ntype (upRen_ntype_ntype xintype)) s1)
    end
 with ren_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (s : ntype (mntype)) : ntype (nntype) :=
    match s return ntype (nntype) with
    | var_ntype (_) i s => (var_ntype (nntype)) i (xintype s)
    | uAllN (_) s0 => uAllN (nntype) ((ren_ptype (upRen_ntype_ntype xintype)) s0)
    end.

Definition ctx_at {m} (Γ : ctx m) (i : fin w) (j : fin m) : ntype m.
Proof. induction Γ. contradiction. apply (ren_ntype ↑). destruct j. apply IHΓ, f. exact (nth' t i).
Defined.

Definition up_ntype_ntype { m : nat } { nntype : nat } (sigma : fin w -> (fin) (m) -> ntype (nntype)) : fin w -> (fin) ((S) (m)) -> ntype ((S) nntype) :=
  fun i => (scons) ((var_ntype ((S) nntype) i) (var_zero)) ((funcomp) (ren_ntype (shift)) (sigma i)).

Fixpoint subst_ptype { mntype : nat } { nntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (s : ptype (mntype)) : ptype (nntype) :=
    (match s return ptype (nntype) with
    | top (_)  => top (nntype)
    | bAllN (_) s0 s1 => bAllN (nntype) (Vector.map (subst_ntype sigmantype) s0) ((subst_ntype (up_ntype_ntype sigmantype)) s1)
    end)
 with subst_ntype { mntype : nat } { nntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (s : ntype (mntype)) : ntype (nntype) :=
    match s return ntype (nntype) with
    | var_ntype (_) i s => sigmantype i s
    | uAllN (_) s0 => uAllN (nntype) ((subst_ptype (up_ntype_ntype sigmantype)) s0)
    end.

(* Instantiations *)
Definition ninst {m} (v : Vector.t (ntype m) w) (s : ntype (S m)) : ntype m
  := subst_ntype (fun i : fin w => nth' v i .; var_ntype m i) s.

Definition pinst {m}  (v : Vector.t (ntype m) w) (s : ptype (S m)) : ptype m
  := subst_ptype (fun i : fin w => nth' v i .; var_ntype m i) s.

Definition upId_ntype_ntype { mntype : nat } (sigma : fin w -> (fin) (mntype) -> ntype (mntype)) (Eq : forall i x, sigma i x = (var_ntype (mntype) i) x) : forall i x, (up_ntype_ntype sigma i) x = (var_ntype ((S) mntype) i) x :=
  fun i n => match n with
  | Some fin_n => (ap) (ren_ntype (shift)) (Eq i fin_n)
  | None  => eq_refl
  end.

(* Fixpoint idSubst_ptype { mntype : nat } (sigmantype : fin n -> (fin) (mntype) -> ntype (mntype)) (Eqntype : forall i x, sigmantype i x = (var_ntype (mntype) i) x) (s : ptype (mntype)) : subst_ptype sigmantype s = s :=
    match s return subst_ptype sigmantype s = s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((idSubst_ntype sigmantype Eqntype) s0) ((idSubst_ntype (up_ntype_ntype sigmantype) (upId_ntype_ntype (_) Eqntype)) s1)
    end
 with idSubst_ntype { mntype : nat } (sigmantype : fin n -> (fin) (mntype) -> ntype (mntype)) (Eqntype : forall i x, sigmantype i x = (var_ntype (mntype) i) x) (s : ntype (mntype)) : subst_ntype sigmantype s = s :=
    match s return subst_ntype sigmantype s = s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((idSubst_ptype sigmantype Eqntype) s0)
    end. *)
(** In general each lemma is proved for both positive and negative types simultaneously with the mutual induction principle *)
Lemma idSubst_ptype_ntype : forall m,
   (forall s (sigmantype : fin w -> fin m -> ntype m) (Eq : forall i x, sigmantype i x = var_ntype m i x), subst_ptype sigmantype s = s)
/\ (forall s (sigmantype : fin w -> fin m -> ntype m) (Eq : forall i x, sigmantype i x = var_ntype m i x), subst_ntype sigmantype s = s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +rewrite (map_ext_in _ _ _ id). apply map_id. unfold id. apply Forall_forall. apply (Forall_impl _ (fun n0 : ntype m => forall sigmantype : fin w -> fin m -> ntype m, (forall i x, sigmantype i x = var_ntype m i x) -> subst_ntype sigmantype n0 = n0)); auto.
    +apply H. intros. apply (upId_ntype_ntype _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (upId_ntype_ntype _ Eq).
Qed.

(**  We can now define the lemma for positive and negative types individually *)
Definition idSubst_ptype { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (mntype)) (Eqntype : forall i x, sigmantype i x = (var_ntype (mntype) i) x) (s : ptype (mntype)) : subst_ptype sigmantype s = s.
Proof. destruct (idSubst_ptype_ntype mntype). now apply H. Defined.

Definition idSubst_ntype { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (mntype)) (Eqntype : forall i x, sigmantype i x = (var_ntype (mntype) i) x) (s : ntype (mntype)) : subst_ntype sigmantype s = s.
Proof. destruct (idSubst_ptype_ntype mntype). now apply H0. Defined.

Definition upExtRen_ntype_ntype { m : nat } { n' : nat } (xi : (fin) (m) -> (fin) (n')) (zeta : (fin) (m) -> (fin) (n')) (Eq : forall x, xi x = zeta x) : forall x, (upRen_ntype_ntype xi) x = (upRen_ntype_ntype zeta) x :=
  fun n => match n with
  | Some fin_n => (ap) (shift) (Eq fin_n)
  | None  => eq_refl
  end.

(* Fixpoint extRen_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (zetantype : (fin) (mntype) -> (fin) (nntype)) (Eqntype : forall x, xintype x = zetantype x) (s : ptype (mntype)) : ren_ptype xintype s = ren_ptype zetantype s :=
    match s return ren_ptype xintype s = ren_ptype zetantype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((extRen_ntype xintype zetantype Eqntzype) s0) ((extRen_ntype (upRen_ntype_ntype xintype) (upRen_ntype_ntype zetantype) (upExtRen_ntype_ntype (_) (_) Eqntype)) s1)
    end
 with extRen_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (zetantype : (fin) (mntype) -> (fin) (nntype)) (Eqntype : forall x, xintype x = zetantype x) (s : ntype (mntype)) : ren_ntype xintype s = ren_ntype zetantype s :=
    match s return ren_ntype xintype s = ren_ntype zetantype s with
    | var_ntype (_) s => (ap) (var_ntype (nntype)) (Eqntype s)
    | uAllN (_) s0 => congr_uAllN ((extRen_ptype xintype zetantype Eqntype) s0)
    end. *)
Lemma extRen_ptype_ntype : forall m,
   (forall s l (xintype : fin m -> fin l) (zetantype : fin m -> fin l) (Eqntype : forall x, xintype x = zetantype x), ren_ptype xintype s = ren_ptype zetantype s)
/\ (forall s l (xintype : fin m -> fin l) (zetantype : fin m -> fin l) (Eqntype : forall x, xintype x = zetantype x), ren_ntype xintype s = ren_ntype zetantype s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +apply map_ext_in. apply Forall_forall. apply (Forall_impl _ (fun n : ntype m => forall (l : nat) (xintype zetantype : fin m -> fin l), (forall x : fin m, xintype x = zetantype x) -> ren_ntype xintype n = ren_ntype zetantype n)); auto.
    +apply H. intros. apply (upExtRen_ntype_ntype _ _ Eqntype).
  -apply (ap (var_ntype l t)). apply Eqntype.
  -apply congr_uAllN. apply H. intros. apply (upExtRen_ntype_ntype _ _ Eqntype).
Qed.
Definition extRen_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (zetantype : (fin) (mntype) -> (fin) (nntype)) (Eqntype : forall x, xintype x = zetantype x) (s : ptype (mntype)) : ren_ptype xintype s = ren_ptype zetantype s.
Proof. destruct (extRen_ptype_ntype mntype). now apply H. Defined.
Definition extRen_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (zetantype : (fin) (mntype) -> (fin) (nntype)) (Eqntype : forall x, xintype x = zetantype x) (s : ntype (mntype)) : ren_ntype xintype s = ren_ntype zetantype s.
Proof. destruct (extRen_ptype_ntype mntype). now apply H0. Defined.

Definition upExt_ntype_ntype { m : nat } { nntype : nat } (sigma : fin w -> (fin) (m) -> ntype (nntype)) (tau : fin w -> (fin) (m) -> ntype (nntype)) (Eq : forall i x, sigma i x = tau i x) : forall i x, (up_ntype_ntype sigma) i x = (up_ntype_ntype tau) i x :=
  fun i n => match n with
  | Some fin_n => (ap) (ren_ntype (shift)) (Eq i fin_n)
  | None  => eq_refl
  end.

(* Fixpoint ext_ptype { mntype : nat } { nntype : nat } (sigmantype : (fin) (mntype) -> ntype (nntype)) (tauntype : (fin) (mntype) -> ntype (nntype)) (Eqntype : forall x, sigmantype x = tauntype x) (s : ptype (mntype)) : subst_ptype sigmantype s = subst_ptype tauntype s :=
    match s return subst_ptype sigmantype s = subst_ptype tauntype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((ext_ntype sigmantype tauntype Eqntype) s0) ((ext_ntype (up_ntype_ntype sigmantype) (up_ntype_ntype tauntype) (upExt_ntype_ntype (_) (_) Eqntype)) s1)
    end
 with ext_ntype { mntype : nat } { nntype : nat } (sigmantype : (fin) (mntype) -> ntype (nntype)) (tauntype : (fin) (mntype) -> ntype (nntype)) (Eqntype : forall x, sigmantype x = tauntype x) (s : ntype (mntype)) : subst_ntype sigmantype s = subst_ntype tauntype s :=
    match s return subst_ntype sigmantype s = subst_ntype tauntype s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((ext_ptype sigmantype tauntype Eqntype) s0)
    end. *)
Lemma ext_ptype_ntype : forall m,
    (forall s l (sig : fin w -> fin m -> ntype l) (tau : fin w -> fin m -> ntype l) (Eq : forall i x, sig i x = tau i x),
      subst_ptype sig s = subst_ptype tau s)
/\  (forall s l (sig : fin w -> fin m -> ntype l) (tau : fin w -> fin m -> ntype l) (Eq : forall i x, sig i x = tau i x),
      subst_ntype sig s = subst_ntype tau s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +apply map_ext_in. apply Forall_forall. apply (Forall_impl _ (fun n0 : ntype m => forall (l : nat) (sig tau : fin w -> fin m -> ntype l), (forall (i : fin w) (x : fin m), sig i x = tau i x) -> subst_ntype sig n0 = subst_ntype tau n0)); auto.
    +apply H. intros. apply (upExt_ntype_ntype _ _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (upExt_ntype_ntype _ _ Eq).
Qed.
Definition ext_ptype { mntype : nat } { nntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (tauntype : fin w -> (fin) (mntype) -> ntype (nntype)) (Eqntype : forall i x, sigmantype i x = tauntype i x) (s : ptype (mntype)) : subst_ptype sigmantype s = subst_ptype tauntype s.
Proof. destruct (ext_ptype_ntype mntype). now apply H. Defined.
Definition ext_ntype { mntype : nat } { nntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (tauntype : fin w -> (fin) (mntype) -> ntype (nntype)) (Eqntype : forall i x, sigmantype i x = tauntype i x) (s : ntype (mntype)) : subst_ntype sigmantype s = subst_ntype tauntype s.
Proof. destruct (ext_ptype_ntype mntype). now apply H0. Defined.

Definition up_ren_ren_ntype_ntype { k : nat } { l : nat } { m : nat } (xi : (fin) (k) -> (fin) (l)) (tau : (fin) (l) -> (fin) (m)) (theta : (fin) (k) -> (fin) (m)) (Eq : forall x, ((funcomp) (tau) (xi)) x = theta x) : forall x, ((funcomp) (upRen_ntype_ntype tau) (upRen_ntype_ntype xi)) x = (upRen_ntype_ntype theta) x :=
  up_ren_ren (xi) (tau) (theta) (Eq).

(* Fixpoint compRenRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (rhontype : (fin) (mntype) -> (fin) (lntype)) (Eqntype : forall x, ((funcomp) zetantype xintype) x = rhontype x) (s : ptype (mntype)) : ren_ptype zetantype (ren_ptype xintype s) = ren_ptype rhontype s :=
    match s return ren_ptype zetantype (ren_ptype xintype s) = ren_ptype rhontype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((compRenRen_ntype xintype zetantype rhontype Eqntype) s0) ((compRenRen_ntype (upRen_ntype_ntype xintype) (upRen_ntype_ntype zetantype) (upRen_ntype_ntype rhontype) (up_ren_ren (_) (_) (_) Eqntype)) s1)
    end
 with compRenRen_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (rhontype : (fin) (mntype) -> (fin) (lntype)) (Eqntype : forall x, ((funcomp) zetantype xintype) x = rhontype x) (s : ntype (mntype)) : ren_ntype zetantype (ren_ntype xintype s) = ren_ntype rhontype s :=
    match s return ren_ntype zetantype (ren_ntype xintype s) = ren_ntype rhontype s with
    | var_ntype (_) s => (ap) (var_ntype (lntype)) (Eqntype s)
    | uAllN (_) s0 => congr_uAllN ((compRenRen_ptype xintype zetantype rhontype Eqntype) s0)
    end. *)
Lemma compRenRen_ptype_ntype : forall m,
   (forall s k l (xi : fin m -> fin k) (zet : fin k -> fin l) (rho : fin m -> fin l)
      (Eq : forall x, funcomp (zet) (xi) x = rho x),
      ren_ptype zet (ren_ptype xi s) = ren_ptype rho s)
/\ (forall s k l (xi : fin m -> fin k) (zet : fin k -> fin l) (rho : fin m -> fin l)
      (Eq : forall x, funcomp (zet) (xi) x = rho x),
      ren_ntype zet (ren_ntype xi s) = ren_ntype rho s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +rewrite map_map. apply map_ext_in. apply Forall_forall. apply (Forall_impl _ (fun n : ntype m =>
        forall (k l : nat) (xi : fin m -> fin k) (zet : fin k -> fin l) (rho : fin m -> fin l),
        (forall x : fin m, (xi >> zet) x = rho x) -> ren_ntype zet (ren_ntype xi n) = ren_ntype rho n)); auto.
    +apply H. intros. apply (up_ren_ren _ _ _ Eq).
  -apply (ap (var_ntype l t)). apply Eq.
  -apply congr_uAllN. apply H. intros. apply (up_ren_ren _ _ _ (Eq)).
Qed.
Definition compRenRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (rhontype : (fin) (mntype) -> (fin) (lntype)) (Eqntype : forall x, ((funcomp) (zetantype) (xintype)) x = rhontype x) (s : ptype (mntype)) : ren_ptype zetantype (ren_ptype xintype s) = ren_ptype rhontype s.
Proof. destruct (compRenRen_ptype_ntype mntype). now apply H. Defined.
Definition compRenRen_ntype { kntype : nat } { lntype : nat } { mntype : nat }(xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (rhontype : (fin) (mntype) -> (fin) (lntype)) (Eqntype : forall x, ((funcomp) (zetantype) (xintype)) x = rhontype x) (s : ntype (mntype)) : ren_ntype zetantype (ren_ntype xintype s) = ren_ntype rhontype s.
Proof. destruct (compRenRen_ptype_ntype mntype). now apply H0. Defined.

Definition up_ren_subst_ntype_ntype { k : nat } { l : nat } { mntype : nat } (xi : (fin) (k) -> (fin) (l)) (tau : fin w -> (fin) (l) -> ntype (mntype)) (theta : fin w -> (fin) (k) -> ntype (mntype)) (Eq : forall i x, ((funcomp) (tau i) (xi)) x = theta i x) : forall i x, ((funcomp) (up_ntype_ntype tau i) (upRen_ntype_ntype xi)) x = (up_ntype_ntype theta) i x :=
  fun i n => match n with
  | Some fin_n => (ap) (ren_ntype (shift)) (Eq i fin_n)
  | None  => eq_refl
  end.

(* Fixpoint compRenSubst_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : (fin) (kntype) -> ntype (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) tauntype xintype) x = thetantype x) (s : ptype (mntype)) : subst_ptype tauntype (ren_ptype xintype s) = subst_ptype thetantype s :=
    match s return subst_ptype tauntype (ren_ptype xintype s) = subst_ptype thetantype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((compRenSubst_ntype xintype tauntype thetantype Eqntype) s0) ((compRenSubst_ntype (upRen_ntype_ntype xintype) (up_ntype_ntype tauntype) (up_ntype_ntype thetantype) (up_ren_subst_ntype_ntype (_) (_) (_) Eqntype)) s1)
    end
 with compRenSubst_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : (fin) (kntype) -> ntype (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) tauntype xintype) x = thetantype x) (s : ntype (mntype)) : subst_ntype tauntype (ren_ntype xintype s) = subst_ntype thetantype s :=
    match s return subst_ntype tauntype (ren_ntype xintype s) = subst_ntype thetantype s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((compRenSubst_ptype xintype tauntype thetantype Eqntype) s0)
    end. *)
Lemma compRenSubst_ptype_ntype : forall m,
   (forall s k l (xi : fin m -> fin k) (tau : fin w -> fin k -> ntype l) (theta : fin w -> fin m -> ntype l)
     (Eq : forall i x, (xi >> (tau i)) x = theta i x), subst_ptype tau (ren_ptype xi s) = subst_ptype theta s)
/\ (forall s k l (xi : fin m -> fin k) (tau : fin w -> fin k -> ntype l) (theta : fin w -> fin m -> ntype l)
     (Eq : forall i x, (xi >> (tau i)) x = theta i x), subst_ntype tau (ren_ntype xi s) = subst_ntype theta s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +rewrite map_map. apply map_ext_in. apply Forall_forall. apply (Forall_impl _ (fun n0 : ntype m =>
        forall (k l : nat) (xi : fin m -> fin k) (tau : fin w -> fin k -> ntype l)
          (theta : fin w -> fin m -> ntype l),
        (forall (i : fin w) (x : fin m), (xi >> tau i) x = theta i x) ->
        subst_ntype tau (ren_ntype xi n0) = subst_ntype theta n0)); auto.
    +apply H. intros. apply (up_ren_subst_ntype_ntype _ _ _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (up_ren_subst_ntype_ntype _ _ _ Eq).
Qed.
Definition compRenSubst_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (tauntype i) (xintype)) x = thetantype i x) (s : ptype (mntype)) : subst_ptype tauntype (ren_ptype xintype s) = subst_ptype thetantype s.
Proof. destruct (compRenSubst_ptype_ntype mntype). now apply H. Defined.
Definition compRenSubst_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (tauntype i) (xintype)) x = thetantype i x) (s : ntype (mntype)) : subst_ntype tauntype (ren_ntype xintype s) = subst_ntype thetantype s.
Proof. destruct (compRenSubst_ptype_ntype mntype). now apply H0. Defined.

Definition up_subst_ren_ntype_ntype { k : nat } { lntype : nat } { mntype : nat } (sigma : fin w -> (fin) (k) -> ntype (lntype)) (zetantype : (fin) (lntype) -> (fin) (mntype)) (theta : fin w -> (fin) (k) -> ntype (mntype)) (Eq : forall i x, ((funcomp) (ren_ntype zetantype) (sigma i)) x = theta i x) : forall i x, ((funcomp) (ren_ntype (upRen_ntype_ntype zetantype)) (up_ntype_ntype sigma i)) x = (up_ntype_ntype theta) i x :=
  fun i n => match n with
  | Some fin_n => (eq_trans) (compRenRen_ntype (shift) (upRen_ntype_ntype zetantype) ((funcomp) (shift) zetantype) (fun x => eq_refl) (sigma i fin_n)) ((eq_trans) ((eq_sym) (compRenRen_ntype zetantype (shift) ((funcomp) (shift) zetantype) (fun x => eq_refl) (sigma i fin_n))) ((ap) (ren_ntype (shift)) (Eq i fin_n)))
  | None  => eq_refl
  end.

(* Definition up_subst_ren_ntype_ntype { k : nat } { lntype : nat } { mntype : nat } (sigma : fin n -> (fin) (k) -> ntype (lntype)) (zetantype : (fin) (lntype) -> (fin) (mntype)) (theta : fin n -> (fin) (k) -> ntype (mntype)) (Eq : forall i x, ((funcomp) (ren_ntype zetantype) (sigma i)) x = theta i x) : forall i x, ((funcomp) (ren_ntype (upRen_ntype_ntype zetantype)) (up_ntype_ntype sigma i)) x = (up_ntype_ntype theta) i x
:= fun i x =>  match x as o return ((up_ntype_ntype sigma i >> ren_ntype (upRen_ntype_ntype zetantype)) o = up_ntype_ntype theta i o) with
 | Some fin_n => eq_trans (compRenRen_ntype (↑) (upRen_ntype_ntype zetantype)
          (fun (i0 : fin n) (x0 : fin lntype) => ↑ (zetantype i0 x0))
          (fun (i0 : fin n) (x0 : fin lntype) => eq_refl)
          (sigma i fin_n))
       (eq_trans (eq_sym (compRenRen_ntype zetantype (fun _ : fin n => ↑)
                (fun (i0 : fin n) (x0 : fin lntype) => ↑ (zetantype i0 x0))
                (fun (i0 : fin n) (x0 : fin lntype) => eq_refl)
                (sigma i fin_n)))
       (ap (ren_ntype (fun _ : fin n => ↑)) (Eq i fin_n)))
 | None => eq_refl
end. *)

(* Fixpoint compSubstRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) (ren_ntype zetantype) sigmantype) x = thetantype x) (s : ptype (mntype)) : ren_ptype zetantype (subst_ptype sigmantype s) = subst_ptype thetantype s :=
    match s return ren_ptype zetantype (subst_ptype sigmantype s) = subst_ptype thetantype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((compSubstRen_ntype sigmantype zetantype thetantype Eqntype) s0) ((compSubstRen_ntype (up_ntype_ntype sigmantype) (upRen_ntype_ntype zetantype) (up_ntype_ntype thetantype) (up_subst_ren_ntype_ntype (_) (_) (_) Eqntype)) s1)
    end
 with compSubstRen_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) (ren_ntype zetantype) sigmantype) x = thetantype x) (s : ntype (mntype)) : ren_ntype zetantype (subst_ntype sigmantype s) = subst_ntype thetantype s :=
    match s return ren_ntype zetantype (subst_ntype sigmantype s) = subst_ntype thetantype s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((compSubstRen_ptype sigmantype zetantype thetantype Eqntype) s0)
    end. *)
Lemma compSubstRen_ptype_ntype : forall m,
   (forall s k l (sig : fin w -> fin m -> ntype k) (zeta : fin k -> fin l) (theta : fin w -> fin m -> ntype l)
    (Eq : forall i x, ((sig i) >> (ren_ntype zeta)) x = theta i x), ren_ptype zeta (subst_ptype sig s) = subst_ptype theta s)
/\ (forall s k l (sig : fin w -> fin m -> ntype k) (zeta : fin k -> fin l) (theta : fin w -> fin m -> ntype l)
    (Eq : forall i x, ((sig i) >> (ren_ntype zeta)) x = theta i x), ren_ntype zeta (subst_ntype sig s) = subst_ntype theta s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +rewrite map_map. apply map_ext_in. apply Forall_forall. apply (Forall_impl _ (fun n0 : ntype m => forall (k l : nat) (sig : fin w -> fin m -> ntype k) (zeta : fin k -> fin l) (theta : fin w -> fin m -> ntype l), (forall (i : fin w) (x : fin m), (sig i >> ren_ntype zeta) x = theta i x) -> ren_ntype zeta (subst_ntype sig n0) = subst_ntype theta n0)); auto.
    +apply H. intros. apply (up_subst_ren_ntype_ntype _ _ _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (up_subst_ren_ntype_ntype _ _ _ Eq).
Qed.
Definition compSubstRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (ren_ntype zetantype) (sigmantype i)) x = thetantype i x) (s : ptype (mntype)) : ren_ptype zetantype (subst_ptype sigmantype s) = subst_ptype thetantype s.
Proof. destruct (compSubstRen_ptype_ntype mntype). now apply H. Defined.
Definition compSubstRen_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (ren_ntype zetantype) (sigmantype i)) x = thetantype i x) (s : ntype (mntype)) : ren_ntype zetantype (subst_ntype sigmantype s) = subst_ntype thetantype s.
Proof. destruct (compSubstRen_ptype_ntype mntype). now apply H0. Defined.

(* Definition up_subst_subst_ntype_ntype { k : nat } { lntype : nat } { mntype : nat } (sigma : (fin) (k) -> ntype (lntype)) (tauntype : (fin) (lntype) -> ntype (mntype)) (theta : (fin) (k) -> ntype (mntype)) (Eq : forall x, ((funcomp) (subst_ntype tauntype) sigma) x = theta x) : forall x, ((funcomp) (subst_ntype (up_ntype_ntype tauntype)) (up_ntype_ntype sigma)) x = (up_ntype_ntype theta) x :=
  fun n => match n with
  | Some fin_n => (eq_trans) (compRenSubst_ntype (shift) (up_ntype_ntype tauntype) ((funcomp) (up_ntype_ntype tauntype) (shift)) (fun x => eq_refl) (sigma fin_n)) ((eq_trans) ((eq_sym) (compSubstRen_ntype tauntype (shift) ((funcomp) (ren_ntype (shift)) tauntype) (fun x => eq_refl) (sigma fin_n))) ((ap) (ren_ntype (shift)) (Eq fin_n)))
  | None  => eq_refl
  end. *)
Definition up_subst_subst_ntype_ntype { k : nat } { lntype : nat } { mntype : nat } (sigma : fin w -> (fin) (k) -> ntype (lntype)) (tauntype : fin w -> (fin) (lntype) -> ntype (mntype)) (theta : fin w -> (fin) (k) -> ntype (mntype)) (Eq : forall i x, ((funcomp) (subst_ntype tauntype) (sigma i)) x = theta i x) : forall i x, ((funcomp) (subst_ntype (up_ntype_ntype tauntype)) (up_ntype_ntype sigma i)) x = (up_ntype_ntype theta) i x
:= fun i x => match x as o return ((up_ntype_ntype sigma i >> subst_ntype (up_ntype_ntype tauntype)) o = up_ntype_ntype theta i o) with
 | Some fin_n => eq_trans
       (compRenSubst_ntype (↑) (up_ntype_ntype tauntype)
          (fun (i0 : fin w) (x0 : fin lntype) =>
           up_ntype_ntype tauntype i0 (↑ x0))
          (fun (i0 : fin w) (x0 : fin lntype) => eq_refl)
          (sigma i fin_n))
       (eq_trans (eq_sym (compSubstRen_ntype tauntype (↑)
                (fun (i0 : fin w) (x0 : fin lntype) =>
                 ren_ntype (↑) (tauntype i0 x0))
                (fun (i0 : fin w) (x0 : fin lntype) => eq_refl)
                (sigma i fin_n)))
          (ap (ren_ntype (↑)) (Eq i fin_n)))
 | None => eq_refl
 end.

(* Fixpoint compSubstSubst_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : (fin) (mntype) -> ntype (kntype)) (tauntype : (fin) (kntype) -> ntype (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) (subst_ntype tauntype) sigmantype) x = thetantype x) (s : ptype (mntype)) : subst_ptype tauntype (subst_ptype sigmantype s) = subst_ptype thetantype s :=
    match s return subst_ptype tauntype (subst_ptype sigmantype s) = subst_ptype thetantype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((compSubstSubst_ntype sigmantype tauntype thetantype Eqntype) s0) ((compSubstSubst_ntype (up_ntype_ntype sigmantype) (up_ntype_ntype tauntype) (up_ntype_ntype thetantype) (up_subst_subst_ntype_ntype (_) (_) (_) Eqntype)) s1)
    end
 with compSubstSubst_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : (fin) (mntype) -> ntype (kntype)) (tauntype : (fin) (kntype) -> ntype (lntype)) (thetantype : (fin) (mntype) -> ntype (lntype)) (Eqntype : forall x, ((funcomp) (subst_ntype tauntype) sigmantype) x = thetantype x) (s : ntype (mntype)) : subst_ntype tauntype (subst_ntype sigmantype s) = subst_ntype thetantype s :=
    match s return subst_ntype tauntype (subst_ntype sigmantype s) = subst_ntype thetantype s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((compSubstSubst_ptype sigmantype tauntype thetantype Eqntype) s0)
    end. *)
Lemma compSubstSubst_ptype_ntype : forall m,
   (forall s k l (sig : fin w -> fin m -> ntype k) (tau : fin w -> fin k -> ntype l) (theta : fin w -> fin m -> ntype l)
    (Eq : forall i x, (sig i >> subst_ntype tau) x = theta i x), subst_ptype tau (subst_ptype sig s) = subst_ptype theta s)
/\ (forall s k l (sig : fin w -> fin m -> ntype k) (tau : fin w -> fin k -> ntype l) (theta : fin w -> fin m -> ntype l)
    (Eq : forall i x, (sig i >> subst_ntype tau) x = theta i x), subst_ntype tau (subst_ntype sig s) = subst_ntype theta s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +rewrite map_map. apply map_ext_in,Forall_forall. apply (Forall_impl _ (fun n0 : ntype m => forall (k l : nat) (sig : fin w -> fin m -> ntype k) (tau : fin w -> fin k -> ntype l) (theta : fin w -> fin m -> ntype l), (forall (i : fin w) (x : fin m), (sig i >> subst_ntype tau) x = theta i x) -> subst_ntype tau (subst_ntype sig n0) = subst_ntype theta n0)); auto.
    +apply H. intros. apply (up_subst_subst_ntype_ntype _ _ _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (up_subst_subst_ntype_ntype _ _ _ Eq).
Qed.
Definition compSubstSubst_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (subst_ntype tauntype) (sigmantype i)) x = thetantype i x) (s : ptype (mntype)) : subst_ptype tauntype (subst_ptype sigmantype s) = subst_ptype thetantype s.
Proof. destruct (compSubstSubst_ptype_ntype mntype). now apply H. Defined.
Definition compSubstSubst_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (thetantype : fin w -> (fin) (mntype) -> ntype (lntype)) (Eqntype : forall i x, ((funcomp) (subst_ntype tauntype) (sigmantype i)) x = thetantype i x) (s : ntype (mntype)) : subst_ntype tauntype (subst_ntype sigmantype s) = subst_ntype thetantype s.
Proof. destruct (compSubstSubst_ptype_ntype mntype). now apply H0. Defined.

Definition rinstInst_up_ntype_ntype { m : nat } { nntype : nat } (xi : (fin) (m) -> (fin) (nntype)) (sigma : fin w -> (fin) (m) -> ntype (nntype)) (Eq : forall i x, ((funcomp) (var_ntype (nntype) i) (xi)) x = sigma i x) : forall i x, ((funcomp) (var_ntype ((S) nntype) i) (upRen_ntype_ntype xi)) x = (up_ntype_ntype sigma) i x :=
  fun i n => match n with
  | Some fin_n => (ap) (ren_ntype (shift)) (Eq i fin_n)
  | None  => eq_refl
  end.

(* Fixpoint rinst_inst_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (sigmantype : (fin) (mntype) -> ntype (nntype)) (Eqntype : forall x, ((funcomp) (var_ntype (nntype)) xintype) x = sigmantype x) (s : ptype (mntype)) : ren_ptype xintype s = subst_ptype sigmantype s :=
    match s return ren_ptype xintype s = subst_ptype sigmantype s with
    | top (_)  => congr_top
    | bAllN (_) s0 s1 => congr_bAllN ((rinst_inst_ntype xintype sigmantype Eqntype) s0) ((rinst_inst_ntype (upRen_ntype_ntype xintype) (up_ntype_ntype sigmantype) (rinstInst_up_ntype_ntype (_) (_) Eqntype)) s1)
    end
 with rinst_inst_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (sigmantype : (fin) (mntype) -> ntype (nntype)) (Eqntype : forall x, ((funcomp) (var_ntype (nntype)) xintype) x = sigmantype x) (s : ntype (mntype)) : ren_ntype xintype s = subst_ntype sigmantype s :=
    match s return ren_ntype xintype s = subst_ntype sigmantype s with
    | var_ntype (_) s => Eqntype s
    | uAllN (_) s0 => congr_uAllN ((rinst_inst_ptype xintype sigmantype Eqntype) s0)
    end. *)
Lemma rinst_inst_ptype_ntype : forall m,
   (forall s l (xi : fin m -> fin l) (sig : fin w -> fin m -> ntype l) (Eq : forall i x, var_ntype l i (xi x) = sig i x),
      ren_ptype xi s = subst_ptype sig s)
/\ (forall s l (xi : fin m -> fin l) (sig : fin w -> fin m -> ntype l) (Eq : forall i x, var_ntype l i (xi x) = sig i x),
      ren_ntype xi s = subst_ntype sig s).
Proof. eapply ptype_ntype_mutind; intros.
  -apply congr_top.
  -apply congr_bAllN.
    +apply map_ext_in,Forall_forall. apply (Forall_impl _ (fun n0 : ntype m => forall (l : nat) (xi : fin m -> fin l) (sig : fin w -> fin m -> ntype l), (forall (i : fin w) (x : fin m), var_ntype l i (xi x) = sig i x) -> ren_ntype xi n0 = subst_ntype sig n0)); auto.
    +apply H. intros. apply (rinstInst_up_ntype_ntype _ _ Eq).
  -apply Eq.
  -apply congr_uAllN. apply H. intros. apply (rinstInst_up_ntype_ntype _ _ Eq).
Qed.
Definition rinst_inst_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (Eqntype : forall i x, ((funcomp) (var_ntype (nntype) i) (xintype)) x = sigmantype i x) (s : ptype (mntype)) : ren_ptype xintype s = subst_ptype sigmantype s.
Proof. destruct (rinst_inst_ptype_ntype mntype). now apply H. Defined.
Definition rinst_inst_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) (Eqntype : forall i x, ((funcomp) (var_ntype (nntype) i) (xintype)) x = sigmantype i x) (s : ntype (mntype)) : ren_ntype xintype s = subst_ntype sigmantype s.
Proof. destruct (rinst_inst_ptype_ntype mntype). now apply H0. Defined.

Lemma rinstInst_ptype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) : ren_ptype xintype = subst_ptype (fun i => (funcomp) (var_ntype (nntype) i) (xintype)).
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => rinst_inst_ptype xintype (_) (fun i n => eq_refl) x)). Qed.

Lemma rinstInst_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) : ren_ntype xintype = subst_ntype (fun i => (funcomp) (var_ntype (nntype) i) (xintype)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => rinst_inst_ntype xintype (_) (fun _ n => eq_refl) x)). Qed.

Lemma instId_ptype { mntype : nat } : subst_ptype (fun i => var_ntype (mntype) i) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_ptype (var_ntype (mntype)) (fun _ n => eq_refl) ((id) x))). Qed.

Lemma instId_ntype { mntype : nat } : subst_ntype (fun i => var_ntype (mntype) i) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_ntype (var_ntype (mntype)) (fun _ n => eq_refl) ((id) x))). Qed.

Lemma rinstId_ptype { mntype : nat } : @ren_ptype (mntype) (mntype) (id) = id .
Proof. exact ((eq_trans) (rinstInst_ptype ((id) (_))) instId_ptype). Qed.

Lemma rinstId_ntype { mntype : nat } : @ren_ntype (mntype) (mntype) (id) = id .
Proof. exact ((eq_trans) (rinstInst_ntype ((id) (_))) instId_ntype). Qed.

Lemma varL_ntype { mntype : nat } { nntype : nat } {i : fin w} (sigmantype : fin w -> (fin) (mntype) -> ntype (nntype)) : (fun i => funcomp (subst_ntype sigmantype) (var_ntype (mntype) i)) = sigmantype .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma varLRen_ntype { mntype : nat } { nntype : nat } (xintype : (fin) (mntype) -> (fin) (nntype)) : (fun i => funcomp (ren_ntype xintype) (var_ntype (mntype) i)) = (fun i => funcomp (var_ntype (nntype) i) (xintype)).
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma compComp_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (s : ptype (mntype)) : subst_ptype tauntype (subst_ptype sigmantype s) = subst_ptype (fun i => (funcomp) (subst_ntype tauntype) (sigmantype i)) s .
Proof. exact (compSubstSubst_ptype sigmantype tauntype (_) (fun _ n => eq_refl) s). Qed.

Lemma compComp_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (s : ntype (mntype)) : subst_ntype tauntype (subst_ntype sigmantype s) = subst_ntype (fun i => (funcomp) (subst_ntype tauntype) (sigmantype i)) s .
Proof. exact (compSubstSubst_ntype sigmantype tauntype (_) (fun _ n => eq_refl) s). Qed.

Lemma compComp'_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) : (funcomp) (subst_ptype tauntype) (subst_ptype sigmantype) = subst_ptype (fun i => (funcomp) (subst_ntype tauntype) (sigmantype i)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_ptype sigmantype tauntype n)). Qed.

Lemma compComp'_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) : (funcomp) (subst_ntype tauntype) (subst_ntype sigmantype) = subst_ntype (fun i => (funcomp) (subst_ntype tauntype) (sigmantype i)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_ntype sigmantype tauntype n)). Qed.

Lemma compRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (s : ptype (mntype)) : ren_ptype zetantype (subst_ptype sigmantype s) = subst_ptype (fun i => (funcomp) (ren_ntype zetantype) (sigmantype i)) s .
Proof. exact (compSubstRen_ptype sigmantype zetantype (_) (fun _ n => eq_refl) s). Qed.

Lemma compRen_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (s : ntype (mntype)) : ren_ntype zetantype (subst_ntype sigmantype s) = subst_ntype (fun i => (funcomp) (ren_ntype zetantype) (sigmantype i)) s .
Proof. exact (compSubstRen_ntype sigmantype zetantype (_) (fun _ n => eq_refl) s). Qed.

Lemma compRen'_ptype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) : (funcomp) (ren_ptype zetantype) (subst_ptype sigmantype) = subst_ptype (fun i => (funcomp) (ren_ntype zetantype) (sigmantype i)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compRen_ptype sigmantype zetantype n)). Qed.

Lemma compRen'_ntype { kntype : nat } { lntype : nat } { mntype : nat } (sigmantype : fin w -> (fin) (mntype) -> ntype (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) : (funcomp) (ren_ntype zetantype) (subst_ntype sigmantype) = subst_ntype (fun i => (funcomp) (ren_ntype zetantype) (sigmantype i)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compRen_ntype sigmantype zetantype n)). Qed.

Lemma renComp_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (s : ptype (mntype)) : subst_ptype tauntype (ren_ptype xintype s) = subst_ptype (fun i => (funcomp) (tauntype i) (xintype)) s .
Proof. exact (compRenSubst_ptype xintype tauntype (_) (fun _ n => eq_refl) s). Qed.

Lemma renComp_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) (s : ntype (mntype)) : subst_ntype tauntype (ren_ntype xintype s) = subst_ntype (fun i => (funcomp) (tauntype i) (xintype)) s .
Proof. exact (compRenSubst_ntype xintype tauntype (_) (fun _ n => eq_refl) s). Qed.

Lemma renComp'_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) : (funcomp) (subst_ptype tauntype) (ren_ptype xintype) = subst_ptype (fun i => (funcomp) (tauntype i) (xintype )) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renComp_ptype xintype tauntype n)). Qed.

Lemma renComp'_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (tauntype : fin w -> (fin) (kntype) -> ntype (lntype)) : (funcomp) (subst_ntype tauntype) (ren_ntype xintype) = subst_ntype (fun i => (funcomp) (tauntype i) (xintype)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renComp_ntype xintype tauntype n)). Qed.

Lemma renRen_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) (s : ptype (mntype)) : ren_ptype zetantype (ren_ptype xintype s) = ren_ptype ((funcomp) (zetantype) (xintype)) s .
Proof. exact (compRenRen_ptype xintype zetantype (_) (fun n => eq_refl) s). Qed.

Lemma renRen_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype :(fin) (kntype) -> (fin) (lntype)) (s : ntype (mntype)) : ren_ntype zetantype (ren_ntype xintype s) = ren_ntype ((funcomp) (zetantype) (xintype)) s .
Proof. exact (compRenRen_ntype xintype zetantype (_) (fun n => eq_refl) s). Qed.

Lemma renRen'_ptype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) : (funcomp) (ren_ptype zetantype) (ren_ptype xintype) = ren_ptype ((funcomp) (zetantype) (xintype)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renRen_ptype xintype zetantype n)). Qed.

Lemma renRen'_ntype { kntype : nat } { lntype : nat } { mntype : nat } (xintype : (fin) (mntype) -> (fin) (kntype)) (zetantype : (fin) (kntype) -> (fin) (lntype)) : (funcomp) (ren_ntype zetantype) (ren_ntype xintype) = ren_ntype ((funcomp) (zetantype) (xintype)) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renRen_ntype xintype zetantype n)). Qed.

End ptypentype.

Arguments top {w} {nntype}.

Arguments bAllN {w} {nntype}.

Arguments var_ntype {w} {nntype}.

Arguments uAllN {w} {nntype}.
(*
Global Instance Subst_ptype { mntype : nat } { nntype : nat } : Subst1 ((fin) (mntype) -> ntype (nntype)) (ptype (mntype)) (ptype (nntype)) := @subst_ptype (mntype) (nntype) .

Global Instance Subst_ntype { mntype : nat } { nntype : nat } : Subst1 ((fin) (mntype) -> ntype (nntype)) (ntype (mntype)) (ntype (nntype)) := @subst_ntype (mntype) (nntype) .

Global Instance Ren_ptype { mntype : nat } { nntype : nat } : Ren1 ((fin) (mntype) -> (fin) (nntype)) (ptype (mntype)) (ptype (nntype)) := @ren_ptype (mntype) (nntype) .

Global Instance Ren_ntype { mntype : nat } { nntype : nat } : Ren1 ((fin) (mntype) -> (fin) (nntype)) (ntype (mntype)) (ntype (nntype)) := @ren_ntype (mntype) (nntype) .

Global Instance VarInstance_ntype { mntype : nat } : Var ((fin) (mntype)) (ntype (mntype)) := @var_ntype (mntype) .

Notation "x '__ntype'" := (var_ntype x) (at level 5, format "x __ntype") : subst_scope.

Notation "x '__ntype'" := (@ids (_) (_) VarInstance_ntype x) (at level 5, only printing, format "x __ntype") : subst_scope.

Notation "'var'" := (var_ntype) (only printing, at level 1) : subst_scope.

Class Up_ntype X Y := up_ntype : X -> Y.

Notation "↑__ntype" := (up_ntype) (only printing) : subst_scope.

Notation "↑__ntype" := (up_ntype_ntype) (only printing) : subst_scope.

Global Instance Up_ntype_ntype { m : nat } { nntype : nat } : Up_ntype (_) (_) := @up_ntype_ntype (m) (nntype) .
 *)
(* Notation "s [ sigmantype ]" := (subst_ptype sigmantype s) (at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "[ sigmantype ]" := (subst_ptype sigmantype) (at level 1, left associativity, only printing) : fscope. *)

(* Notation "s ⟨ xintype ⟩" := (ren_ptype xintype s) (at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "⟨ xintype ⟩" := (ren_ptype xintype) (at level 1, left associativity, only printing) : fscope. *)

(* Notation "s [ sigmantype ]" := (subst_ntype sigmantype s) (at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "[ sigmantype ]" := (subst_ntype sigmantype) (at level 1, left associativity, only printing) : fscope. *)

(* Notation "s ⟨ xintype ⟩" := (ren_ntype xintype s) (at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "⟨ xintype ⟩" := (ren_ntype xintype) (at level 1, left associativity, only printing) : fscope. *)

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2(*,   Subst_ptype,  Subst_ntype,  Ren_ptype,  Ren_ntype,  VarInstance_ntype *).

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2(* ,  Subst_ptype,  Subst_ntype,  Ren_ptype,  Ren_ntype,  VarInstance_ntype *) in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_ptype| progress rewrite ?compComp_ptype| progress rewrite ?compComp'_ptype| progress rewrite ?instId_ntype| progress rewrite ?compComp_ntype| progress rewrite ?compComp'_ntype| progress rewrite ?rinstId_ptype| progress rewrite ?compRen_ptype| progress rewrite ?compRen'_ptype| progress rewrite ?renComp_ptype| progress rewrite ?renComp'_ptype| progress rewrite ?renRen_ptype| progress rewrite ?renRen'_ptype| progress rewrite ?rinstId_ntype| progress rewrite ?compRen_ntype| progress rewrite ?compRen'_ntype| progress rewrite ?renComp_ntype| progress rewrite ?renComp'_ntype| progress rewrite ?renRen_ntype| progress rewrite ?renRen'_ntype| progress rewrite ?varL_ntype| progress rewrite ?varLRen_ntype| progress (unfold up_ren, upRen_ntype_ntype, up_ntype_ntype)| progress (cbn [subst_ptype subst_ntype ren_ptype ren_ntype])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_ptype in *| progress rewrite ?compComp_ptype in *| progress rewrite ?compComp'_ptype in *| progress rewrite ?instId_ntype in *| progress rewrite ?compComp_ntype in *| progress rewrite ?compComp'_ntype in *| progress rewrite ?rinstId_ptype in *| progress rewrite ?compRen_ptype in *| progress rewrite ?compRen'_ptype in *| progress rewrite ?renComp_ptype in *| progress rewrite ?renComp'_ptype in *| progress rewrite ?renRen_ptype in *| progress rewrite ?renRen'_ptype in *| progress rewrite ?rinstId_ntype in *| progress rewrite ?compRen_ntype in *| progress rewrite ?compRen'_ntype in *| progress rewrite ?renComp_ntype in *| progress rewrite ?renComp'_ntype in *| progress rewrite ?renRen_ntype in *| progress rewrite ?renRen'_ntype in *| progress rewrite ?varL_ntype in *| progress rewrite ?varLRen_ntype in *| progress (unfold up_ren, upRen_ntype_ntype, up_ntype_ntype in *)| progress (cbn [subst_ptype subst_ntype ren_ptype ren_ntype] in *)| fsimpl in *].

Ltac substify := auto_unfold; try repeat (erewrite rinstInst_ptype); try repeat (erewrite rinstInst_ntype).

Ltac renamify := auto_unfold; try repeat (erewrite <- rinstInst_ptype); try repeat (erewrite <- rinstInst_ntype).

Notation "⊤" := (top).
Notation "∀+ S « T »" := (bAllN S T).
Notation "∀- « T »" := (uAllN T).


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Abstract Array Block.  *)

Set Implicit Arguments.

Require Import ZArith Morphisms.
Require Import hpattern vgtac DLat DItv DProd DMap DPow DomBasic.
Require Import VocabA.

Module ArrInfo <: LAT.

(** Abstract type of array information is [offset * size * stride]. *)

Include Prod3 Itv Itv Itv.

Definition top : t := (Itv.top, Itv.top, Itv.top).

Definition make (o sz st : Itv.t) : t := (o, sz, st).

Definition plus_offset (x : t) (i : Itv.t) : t :=
  let '(o, s, st) := x in
  if Itv.eq_dec Itv.bot o then x else
  (Itv.plus o i, s, st).

Lemma plus_offset_mor : Proper (eq ==> Itv.eq ==> eq) plus_offset.
Proof.
unfold plus_offset; intros [[o1 s1] st1] [[o2 s2] st2] Hx i1 i2 Hi.
destruct (Itv.eq_dec Itv.bot o1), (Itv.eq_dec Itv.bot o2)
; [ by auto
  | elim f; apply Itv.eq_trans with o1; [by apply e|by apply Hx]
  | elim f; apply Itv.eq_trans with o2
    ; [by apply e|apply Itv.eq_sym; by apply Hx] |].
split; [split|]; [|by apply Hx|by apply Hx].
apply Itv.plus_mor; [by apply Hx|by apply Hi].
Qed.

Lemma plus_offset_non_bot :
  forall (x : t) (i : Itv.t) (Hx : ~ eq x bot) (Hi : ~ Itv.eq i Itv.bot),
    ~ eq (plus_offset x i) bot.
Proof.
i; destruct x as [[o sz] st]; ss.
destruct (Itv.eq_dec Itv.bot o); [by elim Hx|].
inversion FH as [[Ho Hsz] Hst]; ss.
eapply Itv.plus_non_bot; [|apply Hi|apply FH].
i; apply Hx; repeat econs; by done.
Qed.

Definition minus_offset (x : t) (i : Itv.t) : t :=
  let '(o, s, st) := x in
  if Itv.eq_dec Itv.bot o then x else
  (Itv.minus o i, s, st).

Lemma minus_offset_mor : Proper (eq ==> Itv.eq ==> eq) minus_offset.
Proof.
unfold minus_offset; intros [[o1 s1] st1] [[o2 s2] st2] Hx i1 i2 Hi.
destruct (Itv.eq_dec Itv.bot o1), (Itv.eq_dec Itv.bot o2)
; [ by auto
  | elim f; apply Itv.eq_trans with o1; [by apply e|by apply Hx]
  | elim f; apply Itv.eq_trans with o2
    ; [by apply e|apply Itv.eq_sym; by apply Hx] |].
split; [split|]; [|by apply Hx|by apply Hx].
apply Itv.minus_mor; [by apply Hx|by apply Hi].
Qed.

Lemma minus_offset_non_bot :
  forall (x : t) (i : Itv.t) (Hx : ~ eq x bot) (Hi : ~ Itv.eq i Itv.bot),
    ~ eq (minus_offset x i) bot.
Proof.
i; destruct x as [[o sz] st]; ss.
destruct (Itv.eq_dec Itv.bot o); [by elim Hx|].
inversion FH as [[Ho Hsz] Hst]; ss.
eapply Itv.minus_non_bot; [|apply Hi|apply FH].
i; apply Hx; repeat econs; by done.
Qed.

End ArrInfo.

Module ArrayBlk <: LAT.

(** ArrayBlock is a map from allocsites to array informations. *)

Include Map Allocsite ArrInfo.

Definition make (a : Allocsite.t) (o sz st : Itv.t) : t :=
  add a (ArrInfo.make o sz st) bot.

Definition extern (a : Allocsite.t) : t := add a ArrInfo.top empty.

Definition plus_offset (ab : t) (i : Itv.t) : t :=
  if Itv.eq_dec i Itv.bot then bot else
    map (fun a => ArrInfo.plus_offset a i) ab.

Lemma plus_offset_mor : Proper (eq ==> Itv.eq ==> eq) plus_offset.
Proof.
unfold eq, plus_offset; intros ab1 ab2 Hab i1 i2 Hi.
destruct (Itv.eq_dec i1 Itv.bot), (Itv.eq_dec i2 Itv.bot)
; [ by apply eq_refl
  | elim f; by eauto using Itv.eq_trans, Itv.eq_sym
  | elim f; by eauto using Itv.eq_trans, Itv.eq_sym |].
intro a. specialize Hab with a.
unfold find, map in *.
do 2 rewrite M.P.F.map_o.
remember (M.find a ab1) as opt_v1; destruct opt_v1 as [v1|]
; remember (M.find a ab2) as opt_v2; destruct opt_v2 as [v2|]; s.
- by apply ArrInfo.plus_offset_mor.
- destruct v1 as [[o1 s1] st1].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot o1).
  + split; [split|]; s; by auto.
  + elim f1; apply Itv.eq_sym; by auto.
- destruct v2 as [[o2 s2] st2].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot o2).
  + split; [split|]; s; by auto.
  + elim f1; by auto.
- by apply ArrInfo.eq_refl.
Qed.

Definition minus_offset (ab : t) (i : Itv.t) : t :=
  if Itv.eq_dec i Itv.bot then bot else
    map (fun a => ArrInfo.minus_offset a i) ab.

Lemma minus_offset_mor : Proper (eq ==> Itv.eq ==> eq) minus_offset.
Proof.
unfold eq, minus_offset; intros ab1 ab2 Hab i1 i2 Hi.
destruct (Itv.eq_dec i1 Itv.bot), (Itv.eq_dec i2 Itv.bot)
; [ by apply eq_refl
  | elim f; by eauto using Itv.eq_trans, Itv.eq_sym
  | elim f; by eauto using Itv.eq_trans, Itv.eq_sym |].
intro a. specialize Hab with a.
unfold find, map in *.
do 2 rewrite M.P.F.map_o.
remember (M.find a ab1) as opt_v1; destruct opt_v1 as [v1|]
; remember (M.find a ab2) as opt_v2; destruct opt_v2 as [v2|]; s.
- by apply ArrInfo.minus_offset_mor.
- destruct v1 as [[o1 s1] st1].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot o1).
  + split; [split|]; s; by auto.
  + elim f1; apply Itv.eq_sym; by auto.
- destruct v2 as [[o2 s2] st2].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot o2).
  + split; [split|]; s; by auto.
  + elim f1; by auto.
- by apply ArrInfo.eq_refl.
Qed.

Definition cast_array (new_st : Itv.t) (ab : t) : t :=
  let resize orig_st x := Itv.divide (Itv.times x orig_st) new_st in
  let cast_offset x :=
      let '((o, s), orig_st) := x in
      let new_o := resize orig_st o in
      let new_s := resize orig_st s in
      if Itv.eq_dec Itv.bot orig_st then x else
        (new_o, new_s, new_st) in
  map cast_offset ab.

Lemma cast_array_mor : Proper (Itv.eq ==> eq ==> eq) cast_array.
Proof.
unfold cast_array, eq; intros i1 i2 Hi ab1 ab2 Hab.
intro a. specialize Hab with a.
unfold find, map in *.
do 2 rewrite M.P.F.map_o.
remember (M.find a ab1) as opt_v1; destruct opt_v1 as [v1|]
; remember (M.find a ab2) as opt_v2; destruct opt_v2 as [v2|]; s.
- destruct v1 as [[o1 s1] st1].
  destruct v2 as [[o2 s2] st2].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot st1); destruct (Itv.eq_dec Itv.bot st2).
  + split; [split|]; s; by auto.
  + elim f; apply Itv.eq_trans with st1; by auto.
  + elim f; apply Itv.eq_trans with st2; [|apply Itv.eq_sym]; by auto.
  + split; [split|]; s.
    * apply Itv.divide_mor; [|by auto].
      apply Itv.times_mor; by auto.
    * apply Itv.divide_mor; [|by auto].
      apply Itv.times_mor; by auto.
    * assumption.
- destruct v1 as [[o1 s1] st1].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot st1).
  + split; [split|]; s; by auto.
  + elim f; apply Itv.eq_sym; by auto.
- destruct v2 as [[o2 s2] st2].
  destruct Hab as [[Ho Hs] Hst]; simpl in *.
  destruct (Itv.eq_dec Itv.bot st2).
  + split; [split|]; s; by auto.
  + elim f; by auto.
- by apply ArrInfo.eq_refl.
Qed.

Definition cast_array_int (z : Z) (ab : t) : t := cast_array (Itv.of_int z) ab.

Lemma cast_array_int_mor (z : Z) : Proper (eq ==> eq) (cast_array_int z).
Proof.
unfold cast_array_int; intros ab1 ab2 Hab.
apply cast_array_mor; [by apply Itv.eq_refl|by auto].
Qed.

Definition pow_loc_of_array (ab : t) : PowLoc.t :=
  let add_array_to_pow_loc k v acc :=
      if ArrInfo.eq_dec ArrInfo.bot v then acc else
        PowLoc.add (loc_of_allocsite k) acc in
  foldi add_array_to_pow_loc ab PowLoc.empty.

Lemma pow_loc_of_array_mor : Proper (eq ==> PowLoc.eq) pow_loc_of_array.
Proof.
unfold pow_loc_of_array; intros ab1 ab2 Hab.
apply foldi_mor; [| | |by auto|by apply PowLoc.eq_refl].
- constructor.
  + intros x; by apply PowLoc.eq_refl.
  + intros x y z; by apply PowLoc.eq_trans.
  + intros x y; by apply PowLoc.eq_sym.
- intros k1 k2 Hk v1 v2 Hv acc1 acc2 Hacc.
  destruct (ArrInfo.eq_dec ArrInfo.bot v1), (ArrInfo.eq_dec ArrInfo.bot v2)
  ; [ by auto
    | elim f; apply ArrInfo.eq_trans with v1; by auto
    | elim f; apply ArrInfo.eq_trans with v2; by auto using ArrInfo.eq_sym |].
  apply PowLoc.add_mor; [|by auto].
  by apply loc_of_allocsite_mor.
- i. destruct (ArrInfo.eq_dec ArrInfo.bot v); [by apply PowLoc.eq_refl|tauto].
Qed.

Definition pow_loc_of_struct_w_field (ab : t) (f : Field.t) : PowLoc.t :=
  let add_to_pow_loc a v acc :=
    if ArrInfo.eq_dec v ArrInfo.bot then acc else
      PowLoc.add (append_field (loc_of_allocsite a) f) acc in
  foldi add_to_pow_loc ab PowLoc.bot.

Lemma pow_loc_of_struct_w_field_mor :
  Proper (eq ==> Field.eq ==> PowLoc.eq) pow_loc_of_struct_w_field.
Proof.
intros s1 s2 Hs f1 f2 Hf. unfold pow_loc_of_struct_w_field. apply foldi2_1.
- i; dest_if_dec. elim f; by apply ArrInfo.eq_sym.
- i; dest_if_dec. elim f; by apply ArrInfo.eq_sym.
- i; dest_if_dec.
  + dest_if_dec.
    elim f; apply ArrInfo.eq_trans with v1; [by apply ArrInfo.eq_sym|by auto].
  + dest_if_dec.
    * elim f; apply ArrInfo.eq_trans with v2; by auto.
    * apply PowLoc.add_mor; [|by auto].
      apply append_field_mor; [by apply loc_of_allocsite_mor|by auto].
- by apply PowLoc.eq_refl.
- by auto.
Qed.

End ArrayBlk.


(* "LXM: Better Splittable Pseudorandom Number Generators (and Almost as Fast)"
   Guy L. Steele Jr. and Sebastiano Vigna, OOPSLA 2021. *)
(* Also at https://github.com/ocaml/ocaml/pull/10742/ *)

Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Arrays.
Require Import Rupicola.Lib.WordNotations.
From bedrock2 Require Import BasicC64Semantics.

Coercion co_word_of_Z := word.of_Z (word := word).
#[export] Hint Unfold co_word_of_Z : compiler_side_conditions.

Definition M : word :=
  word.of_Z 0xd1342543de82ef95.

Definition rotl (x: word) (k: Z) :=
  (x <<w word.of_Z k) |w (x >>w word.of_Z (64 - k)).

Definition lxm_next (a s: word) (x: list word) :=
  let/n x0 := ListArray.get x 0 in
  let/n z := s +w x0 in

  let/n z := (z ^w (z >>w 32)) *w 0xdaba0b6eb09322e3 in
  let/n z := (z ^w (z >>w 32)) *w 0xdaba0b6eb09322e3 in
  let/n z := (z ^w (z >>w 32)) in

  let/n s := s *w M +w a in

  let/n q0 := ListArray.get x 0 in
  let/n q1 := ListArray.get x 1 in
  let/n q1 := q1 ^w q0 in
  let/n q0 := rotl q0 24 in
  let/n q0 := q0 ^w q1 ^w (q1 <<w 16) in
  let/n q1 := rotl q1 37 in
  let/n x := ListArray.put x 0 q0 in
  let/n x := ListArray.put x 1 q1 in

  \< s, z, x \>.

Implicit Type R : mem -> Prop.
Instance spec_of_lxm_next : spec_of "lxm_next" :=
  fnspec! "lxm_next" a s xptr / x R ~> s' z,
  { requires tr mem :=
      (sizedlistarray_value AccessWord 2%nat xptr x ⋆ R) mem;
    ensures tr' mem' :=
      let '\<sn, zn, xn\> := lxm_next a s x in
      tr = tr' /\
      (sizedlistarray_value AccessWord 2 xptr xn ⋆ R) mem' /\
      s' = sn /\ z = zn  }.

Import SizedListArrayCompiler.
#[local] Hint Unfold rotl : compiler_cleanup.
#[local] Hint Extern 10 => lia : compiler_side_conditions.

Derive lxm_next_br2fn SuchThat
       (defn! "lxm_next"("a", "s", "x") ~> "s", "z" { lxm_next_br2fn },
        implements lxm_next)
       As lxm_next_br2fn_ok.
Proof.
  compile.
Qed.

Definition lxm_next_cbytes := Eval vm_compute in
  list_byte_of_string (ToCString.c_module [("dummy_main_for_static",([],[],cmd.skip)); lxm_next_br2fn]).


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : extension for Qc (canonical rational number).
  author    : ZhengPu Shi
  date      : 2022.07
*)

Require Export BasicConfig.

Require Export QExt Qcanon.
Open Scope Qc.

(* ######################################################################### *)
(** ** Convertion between Qc and other types *)

(** Qc to Q *)
Definition Qc2Q (qc : Qc) : Q := this qc.

(** Z to Qc *)
Definition Z2Qc (z : Z) : Qc := Q2Qc (Z2Q z).

(** nat to Qc *)
Definition nat2Qc (n : nat) : Qc := Q2Qc (nat2Q n).

(** Qc to Z *)
Definition Qc2Z_ceiling (q : Qc) : Z := Q2Z_ceiling (Qc2Q q).
Definition Qc2Z_floor (q : Qc) : Z := Q2Z_floor (Qc2Q q).

(** list Q to list Qc *)
Definition Q2Qc_list l := List.map (fun q => Q2Qc q) l.

(** list (list Q) to list (list Qc) *)
Definition Q2Qc_dlist dl := List.map Q2Qc_list dl.

(* ######################################################################### *)
(** * Properties for Qeqb and Qeq *)

Notation Qceqdec := Qc_eq_dec.

Notation Qceqb := Qc_eq_bool.

Infix     "=?"          := Qceqb          : Qc_scope.

(** Reflection of (=) and (=?) *)
Lemma Qceqb_true_iff : forall x y, x =? y = true <-> x = y.
Proof.
  intros; split; intros.
  - apply Qc_eq_bool_correct; auto.
  - subst. unfold Qceqb, Qc_eq_bool.
    unfold Qceqdec.
    destruct (Qeq_dec y y) eqn: E1; auto.
    destruct n. apply Qeq_refl.
Qed.

Lemma Qceqb_false_iff : forall x y, x =? y = false <-> x <> y.
Proof.
  intros; split; intros.
  - intro. apply Qceqb_true_iff in H0. rewrite H in H0. easy.
  - destruct (Qceqb x y) eqn:E1; auto. apply Qceqb_true_iff in E1. easy.
Qed.

(* ######################################################################### *)
(** * Others *)

(** ** sqrt of Q *)

(* Definition Qsqrt (q : Q) := Qmake (Z.sqrt (Qnum q)) (Pos.sqrt (Qden q)). *)

(* Example *)
(* Compute Qsqrt 1.21. *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e256m88x2e240m1_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.


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

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

Print Assumptions sub.


Require Import Coq.omega.Omega.
Require Import Crypto.Compilers.Z.Bounds.Interpretation.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.NatUtil.

Notation round_up_monotone_T round_up
  := (forall x y,
         (x <= y)%nat
         -> match round_up x, round_up y with
            | Some x', Some y' => (x' <= y')%nat
            | None, None => True
            | Some _, None => True
            | None, Some _ => False
            end)
       (only parsing).

Lemma round_up_to_in_list_monotone (allowable_lgsz : list nat)
  : round_up_monotone_T (Bounds.round_up_to_in_list allowable_lgsz).
Proof.
  intros x y H.
  induction allowable_lgsz as [|s ss].
  { constructor. }
  { unfold Bounds.round_up_to_in_list in *.
    repeat match goal with
           | _ => solve [ trivial ]
           | _ => progress simpl in *
           | _ => progress break_innermost_match_step
           | _ => progress break_innermost_match_hyps_step
           | [ H : ?leb _ _ = true |- _ ] => apply NPeano.Nat.leb_le in H
           | [ H : ?leb _ _ = false |- _ ] => apply NPeano.Nat.leb_gt in H
           | _ => omega *
           end. }
Qed.


(* LEB128 integer format *)
(* https://en.wikipedia.org/wiki/LEB128 *)
(* TODO: size bound *)
Require Import Numbers.BinNums.
Require Import NArith.BinNat.
Require Import Coq.Init.Byte.
From parseque Require Import Parseque.

(** expects 7 bits, with MSB at head *)
Definition byte_of_7_bits (bs : list bool) : byte :=
  (* using lists is very inefficient *)
  match bs with
  | cons b1 (cons b2 (cons b3 (cons b4 (cons b5 (cons b6 (cons b7 nil)))))) =>
    Byte.of_bits (b7, (b6, (b5, (b4, (b3, (b2, (b1, false)))))))
  | _ => (* should never happen *) x00
  end.

Definition rebalance (bytes_produced : list byte) (bits_produced : list bool) (the_bit : bool) :
  ((list byte) * (list bool)) :=
  if Nat.eqb (List.length bits_produced) 6 then (cons (byte_of_7_bits (cons the_bit bits_produced)) bytes_produced, nil)
  else (bytes_produced, cons the_bit bits_produced).

Fixpoint binary_of_aux2 (acc1 : list byte) (acc2 : list bool (* MSB at head *)) (n : positive) : list byte :=
  (* using lists is very inefficient *)
  match n with
  | xH =>
    let (acc1', acc2') := rebalance acc1 acc2 true in
    let acc2'' := List.app (List.repeat false (6 - List.length acc2)) acc2' in
    cons (byte_of_7_bits acc2'') acc1'
  | xI n' =>
    let (acc1', acc2') := rebalance acc1 acc2 true in
    binary_of_aux2 acc1' acc2' n'
  | xO n' =>
    let (acc1', acc2') := rebalance acc1 acc2 false in
    binary_of_aux2 acc1' acc2' n'
  end.

Definition incr_mod (len: nat) (pad: nat) : nat :=
  if Nat.eqb (S len) pad then 0 else (S len).

(* Convert pos to bits, MSB at head *)
Fixpoint bits_of_pos_pad (acc: list bool) (len: nat) (pad: nat) (n: positive) : list bool :=
  match n with
  | xH =>
    List.app (List.repeat false (pad - 1 - len)) (cons true acc)
  | xI n' =>
    bits_of_pos_pad (cons true acc) (incr_mod len pad) pad n'
  | xO n' =>
    bits_of_pos_pad (cons false acc) (incr_mod len pad) pad n'
  end.

(* Evaluate two's complement LEB128 encoding. Need LSB at head *)
Fixpoint complement_of_one_two_aux (zeros: nat) (bs: list bool) : list bool :=
  match bs with
  | nil => List.repeat false zeros
  | cons true bs' => List.app (List.repeat false zeros) (cons true (List.map negb bs'))
  | cons false bs' => complement_of_one_two_aux (S zeros) bs'
  end.

(* MSB at head *)
Definition complement_of_one_two (bs: list bool) : list bool :=
  List.rev (complement_of_one_two_aux 0 (List.rev bs)).

Fixpoint bytes_of_bits (bs: list bool): list byte :=
  match bs with
  | cons b1 (cons b2 (cons b3 (cons b4 (cons b5 (cons b6 (cons b7 bs')))))) =>
    cons (Byte.of_bits (b7, (b6, (b5, (b4, (b3, (b2, (b1, false)))))))) (bytes_of_bits bs')
  | _ => (* should never happen *) nil
  end.

Definition make_msb_one (b : byte) : byte :=
  let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, _))))))) := Byte.to_bits b in
  Byte.of_bits (b1, (b2, (b3, (b4, (b5, (b6, (b7, true))))))).

Definition make_msb_zero (b : byte) : byte :=
  let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, _))))))) := Byte.to_bits b in
  Byte.of_bits (b1, (b2, (b3, (b4, (b5, (b6, (b7, false))))))).

Definition make_msb_of_non_first_byte_one (bs : list byte) : list byte :=
  match bs with
  | nil => nil
  | cons b bs' => cons b (List.map make_msb_one bs')
  end.

(** LSB at head of list *)
Definition encode_unsigned_aux (n : N) : list byte :=
  match n with
  | N0 => cons x00 nil
  | Npos n' => make_msb_of_non_first_byte_one (binary_of_aux2 nil nil n')
  end.

Definition encode_unsigned (n : N) : list byte :=
  List.rev (encode_unsigned_aux n).

Definition encode_signed_aux (z : Z) : list byte :=
  match z with
  | Z0 => cons x00 nil
  | Zpos n' => make_msb_of_non_first_byte_one (binary_of_aux2 nil nil n')
  | Zneg n' => make_msb_of_non_first_byte_one
                (bytes_of_bits
                   (complement_of_one_two
                      (bits_of_pos_pad nil 0 7 n')))
  end.

Definition encode_signed (z : Z) : list byte :=
  List.rev (encode_signed_aux z).

Section Language.

  Context
    {Toks : nat -> Type} `{Sized Toks byte}
    {M : Type -> Type} `{RawMonad M} `{RawAlternative M}.

  Definition byte_parser A n := Parser Toks byte M A n.

  Definition byte_as_N {n} : byte_parser N n :=
    Coq.Strings.Byte.to_N <$> anyTok.

  (* parse a final byte *)
  Definition parse_unsigned_end {n} : byte_parser N n :=
    guardM
      (fun b =>
        let '(_, (_, (_, (_, (_, (_, (_, msb))))))) := Byte.to_bits b in
        if msb then None else Some (Coq.Strings.Byte.to_N b))
      anyTok.

  (* parse a non-final byte *)
  Definition parse_unsigned_ctd {n} : byte_parser N n :=
    guardM
      (fun b =>
       let '(b1, (b2, (b3, (b4, (b5, (b6, (b7, msb))))))) := Byte.to_bits b in
       if msb then Some (Coq.Strings.Byte.to_N (make_msb_zero b))
       else None)
      anyTok.

  Section Unsigned_sec.

    Record Unsigned (n : nat) : Type := MkUnsigned
    { _unsigned : byte_parser N n;
    }.

    Arguments MkUnsigned {_}.

    Context
      {Tok : Type} {A B : Type} {n : nat}.

    Definition parse_unsigned_aux : [ Unsigned ] := Fix Unsigned (fun _ rec =>
      let aux := Induction.map _unsigned _ rec in
      let unsigned_ :=
        parse_unsigned_end <|>
        (((fun lsb rest => BinNatDef.N.add lsb (BinNatDef.N.mul 128 rest)) <$> parse_unsigned_ctd) <*> aux) in
      MkUnsigned unsigned_).

    (** top-level function *)
    Definition parse_unsigned : [ byte_parser N ] := fun n => _unsigned n (parse_unsigned_aux n).

  End Unsigned_sec.

Definition sub_2_7 (k : N) :=
  BinIntDef.Z.sub (BinInt.Z_of_N k) (BinIntDef.Z.pow (BinInt.Z.of_nat 2) (BinInt.Z.of_nat 7)).

(* parse a non-final byte *)
Definition parse_signed_end {n} : byte_parser Z n :=
guardM
  (fun b =>
    let '(_, (_, (_, (_, (_, (_, (b7, b8))))))) := Byte.to_bits b in
    if b8 then None
    else if b7 then  Some (sub_2_7 (Coq.Strings.Byte.to_N b))
    else Some (ZArith.BinInt.Z_of_N (Coq.Strings.Byte.to_N b)))
  anyTok.

(* parse a final byte *)
Definition parse_signed_ctd {n} : byte_parser Z n :=
  guardM
    (fun b =>
      let '(_, (_, (_, (_, (_, (_, (_, msb))))))) := Byte.to_bits b in
      if msb then Some (sub_2_7 (Coq.Strings.Byte.to_N b))
      else None)
    anyTok.

Section Signed_sec.

  Record Signed (n : nat) : Type := MkSigned
  { _signed : byte_parser BinNums.Z n;
  }.

  Arguments MkUnsigned {_}.

  Context
    {Tok : Type} {A B : Type} {n : nat}.

    Definition signed_aux : [ Signed ] := Fix Signed (fun _ rec =>
      let aux := Induction.map _signed _ rec in
      let signed_ :=
        parse_signed_end <|>
        (((fun lsb rest => ZArith.BinInt.Zplus lsb (ZArith.BinInt.Zmult (ZArith.BinInt.Z_of_nat 128) rest)) <$> parse_signed_ctd) <*> aux) in
      MkSigned _ signed_).

    Definition parse_signed : [ byte_parser Z ] := fun n => _signed n (signed_aux n).

  End Signed_sec.

End Language.