(** * Strenghthening
The Strenghthening property is about getting rid of useless hypothesis:
  if [Γ(x:A)Γ' ⊢ M : T] and [x] does not appear in [M] or [T], then
     [ΓΓ' ⊢ M : T].*)
(** This is true for all PTS, but the proof is quite subtle. This formalization
has been done from a paper for Jutting in 1993.

The following is not usefull for the proof PTS <-> PTSe
but it's still an interesting part of the metatheory of PTSs

*)
Require Import base.
Require Import ut_term.
Require Import ut_red.
Require Import ut_env.
Require Import ut_typ.
Require Import ut_sr.
Require Import List Le Lt Gt.
Require Compare_dec Peano_dec.

Unset Standard Proposition Elimination Names.

Module ut_strengh_mod (X:term_sig) (Y:pts_sig X) (TM:ut_term_mod X) (EM:ut_env_mod X TM) (RM: ut_red_mod X TM).
 Include (ut_sr_mod X Y TM EM RM).
  Import X Y TM EM RM.

Open Scope UT_scope.

(**
Tv Ts and Sigma are notation find in Jutting93

 We do a partition of [Term] in two families, one build around
vars and the other around sorts and Pi-types.*)
Inductive Tv : Term -> Prop :=
 | Tv_intro : forall x, Tv #x
 | Tv_la: forall M A, Tv M -> Tv (λ[A],M)
 | Tv_app :forall M N, Tv M -> Tv (M·N)
.

Inductive Ts : Term -> Prop :=
 | Ts_intro : forall s, Ts !s
 | Ts_pi : forall A B, Ts (Π(A),B)
 | Ts_la : forall A M, Ts M -> Ts (λ[A],M)
 | Ts_app : forall M N, Ts M -> Ts (M·N)
.

(** Telescopes are just a way to talk about n-ary Lam/Pi -terms: *)
(** Tels (A1,...,An)M ::= Π(A1),...,Π(An),M *)
Fixpoint Tels (Γ : Env) (M : Term) {struct Γ } : Term :=
 match Γ with
 | nil => M
 | cons A Δ => Π(A),(Tels Δ M)
end.

Fixpoint Tels' (Γ : Env) (M : Term) {struct Γ } : Term :=
 match Γ with
 | nil => M
 | cons A Δ => λ[A],(Tels' Δ M)
end.

Hint Constructors Tv Ts.

Import Compare_dec Peano_dec.
(** Some basic properties of [Tv] and [Ts]. *)
Lemma Tv_lift : forall M n m, Tv M <-> Tv (M ↑ n # m).
induction M; split; simpl in *; intros; intuition.
destruct le_gt_dec; intuition.
inversion  H; subst; clear H. constructor. eapply IHM1. trivial.
inversion  H; subst; clear H. constructor. eapply IHM1. apply H1.
inversion H. inversion H.
inversion  H; subst; clear H. constructor. eapply IHM2. trivial.
inversion  H; subst; clear H. constructor. eapply IHM2. apply H1.
Qed.

Lemma Ts_lift : forall M n m, Ts M <-> Ts (M ↑ n # m).
induction M; split; simpl in *; intros; intuition.
inversion H. destruct le_gt_dec; inversion H.
inversion  H; subst; clear H. constructor. eapply IHM1. trivial.
inversion  H; subst; clear H. constructor. eapply IHM1. apply H1.
inversion  H; subst; clear H. constructor. eapply IHM2. trivial.
inversion  H; subst; clear H. constructor. eapply IHM2. apply H1.
Qed.

Lemma Tx_ok : forall t, Tv t \/ Ts t.
induction t; intros.
left; trivial.
right; trivial.
destruct IHt1.
left; constructor; trivial.  right; constructor; trivial.
right; trivial.
destruct IHt2.
left; constructor; trivial.  right; constructor; trivial.
Qed.

Lemma fun_item_lift : forall A A' v Γ , A ↓ v ⊂ Γ -> A' ↓ v ⊂ Γ -> A = A'.
intros.
destruct H as (x & ?& ?). destruct H0 as (x' & ?& ?).
subst. replace x' with x. trivial. eapply fun_item. apply H1. apply H2.
Qed.

(** First result: if a term is in [Tv], then all of his types are convertible. *)
Theorem Shape_of_Type_Tv : forall Γ M A , Γ ⊢ M : A -> forall A',  Γ ⊢ M : A' -> Tv M ->  A ≡ A'.
induction 1; intros.
inversion H2.
(**)
apply gen_var in H1 as (B & ? &?).
replace A with B. intuition. eapply fun_item_lift. apply H3. trivial.
(**)
inversion H3; subst; clear H3.
(**)
inversion H4; subst; clear H4.
apply gen_la in H3 as (t1 & t2 & t3 & D & h); decompose [and] h;clear h.
eapply Betac_trans. eapply Betac_Pi. apply Betac_refl. eapply IHtyp3. apply H7. trivial.
intuition.
(**)
inversion H2; subst; clear H2.
apply gen_app in H1 as (C & D & ? & ?& ?).
destruct (PiInj A B C D). apply IHtyp1. trivial. trivial.
eapply Betac_trans. eapply Betac_subst2. apply H6. intuition.
(**)
eauto.
Qed.

(** Some properties over [Tels] (reduction, substitutions, ...). *)
Lemma Beta_Tels_inv : forall Γ M N, Tels Γ M  → N -> (exists Γ', N = Tels Γ' M /\ Γ →e Γ') \/
  (exists M', N = Tels Γ M' /\ M → M').
induction Γ; intros; simpl in *.
right. exists N; intuition.
inversion H; subst; clear H.
destruct (IHΓ M B' H3). destruct H as (Γ' & -> & ?).
left. exists (a::Γ'); intuition.
destruct H as (M' & -> & ?).
right. exists M'; intuition.

left. exists (A'::Γ); intuition.
Qed.

Lemma Betas_Tels_inv : forall Γ M N, Tels Γ M →→ N -> exists Γ', exists M', N = Tels Γ' M' /\ Γ →→e Γ' /\ M →→ M'.
intros.
remember (Tels Γ M) as MM. revert Γ M HeqMM.
induction H; intros; subst.
exists Γ; exists M0; intuition.
apply Beta_Tels_inv in H.
destruct H. destruct H as (Γ' & -> & ?).
exists Γ'; exists M0; intuition.
destruct H as (M0' & -> & ?).
exists Γ; exists M0'; intuition.
destruct (IHBetas1 Γ M0) as (Γ' & M' & -> & ?& ?); trivial.
destruct (IHBetas2 Γ' M') as (Γ'' & M'' & -> & ?& ?); trivial.
exists Γ''; exists M''; eauto.
Qed.

Lemma Betas_Tels : forall Γ Γ' M M', Γ →→e Γ' -> M →→ M' -> Tels Γ M →→ Tels Γ' M'.
assert (forall l l', l →→e l' -> forall t ,  Tels l t →→ Tels l' t).
induction 1; intros; eauto.
induction H; simpl; eauto.
assert (forall t t', t →→ t' -> forall l ,  Tels l t →→ Tels l t').
induction 1; intros; eauto.
induction l; simpl; eauto.
intros.
eauto.
Qed.

Lemma Betas_not_Pi_to_Sort : forall A B s,  ~ (Π (A), B →→ !s).
intros; intro. eapply Betac_not_Pi_sort. constructor. apply H.
Qed.

Fixpoint env_subst Γ n N {struct Γ} := match Γ with
 | nil => nil
 | A::Γ' => (A[n ← N]) :: (env_subst Γ' (S n) N)
end.

Notation "E  [[ n ← N ]]" := (env_subst E n N) (at level 80).

Lemma Tels_subst : forall Γ M n N, (Tels Γ M) [n ← N] = Tels (Γ [[n ← N]]) (M [(length Γ + n) ← N]).
induction Γ; simpl; intros.
trivial.
rewrite IHΓ.
rewrite plus_n_Sm. trivial.
Qed.

Lemma Tels'_subst : forall Γ M n N, (Tels' Γ M) [n ← N] = Tels' (Γ [[n ← N]]) (M [(length Γ + n) ← N]).
induction Γ; simpl; intros.
trivial.
rewrite IHΓ.
rewrite plus_n_Sm. trivial.
Qed.

(** Second Results: if a term is in [Ts], then all of its types are almost
  convertible: they all reduce to a telescope that ends with a sort,
  and the body of the telescope is the same for everyone (but not the final
  sort.*)
Theorem Shape_of_Type_Ts : forall Γ M T,  Γ ⊢ M : T -> forall T', Γ ⊢ M : T' -> Ts M ->
  exists s, exists s', exists Γ,  T →→ (Tels Γ !s) /\ T' →→ (Tels Γ !s').
induction 1; intros.
apply gen_sort in H1 as (s' & ?& ?).
apply Betac_sym in H1. apply conv_to_sort in H1.
exists t; exists s'; exists nil; simpl; intuition.
(**)
inversion H2.
(**)
clear IHtyp1 IHtyp2.
apply gen_pi in H2 as (s1 & s2 & s3 & h); decompose [and] h; clear h.
apply Betac_sym in H2. apply conv_to_sort in H2.
exists u; exists s3; exists nil; simpl; intuition.
(**)
inversion H4; subst; clear H4.
apply gen_la in H3 as (t1 & t2 & t3 & D & h); decompose [and] h; clear h.
destruct (IHtyp3 D H7 H6) as (u & v & l & ?& ?).
apply Betac_confl in H3 as (Z & ? &?).
apply Betas_Pi_inv in H11 as (K & L & -> & ? & ?).
destruct (Betas_diamond  D L (Tels l !v)) as ( Z & ?& ?); trivial.
apply Betas_Tels_inv in H14 as (l'' & ? & -> & ? &?).
apply Betas_S in H15; subst.
exists u; exists v; exists (K::l''); split.
apply Betas_trans with (Tels (A::l) !u). simpl. eauto. simpl.
apply Betas_Pi. trivial. apply Betas_Tels; trivial.
simpl. eauto.
(**)
inversion H2; subst; clear H2. clear IHtyp2.
apply gen_app in H1 as (C & D & ? & ?&  ?). destruct (IHtyp1 ( Π (C),D) ) as (u & v & l & ? & ?); trivial.
clear IHtyp1. destruct l; simpl in *. apply Betas_not_Pi_to_Sort in H5; elim H5.
apply Betas_Pi_inv in H5 as (B0 & A0 & ? & ?& ?). injection H5; intros;subst; clear H5.
apply Betas_Pi_inv in H6 as (D0 & C0 & ? & ?& ?). injection H5; intros;subst; clear H5.
apply Betac_confl in H1 as (Z & ?& ?).
destruct (Betas_diamond (D[←N]) Z ((Tels l !v)[←N]) H5) as (ZZ & ?& ?).
apply Betas_subst2; trivial.  rewrite Tels_subst in H11. simpl in H11.
apply Betas_Tels_inv in H11. destruct H11 as (l' & x & -> & ?& ?). apply Betas_S in H12. subst.
exists u ; exists v; exists l'; split. eapply Betas_trans. apply Betas_subst2.  apply H8.
rewrite Tels_subst. eapply Betas_Tels. trivial. simpl; trivial.
eauto.
(**)
destruct (IHtyp1 T' H2 H3) as (u & v & l & ? & ?).
apply Betac_confl in H as (Z & ? & ?). destruct (Betas_diamond A (Tels l !u) Z H4 H) as (ZZ & ?& ?).
apply Betas_Tels_inv in H7 as (l' & ? & -> & ? & ?). apply Betas_S in H9; subst.
exists u; exists v; exists l'; split.
apply Betas_trans with Z; trivial. apply Betas_trans with (Tels l !v); trivial.
apply Betas_Tels; trivial.
Qed.

(** Definition of the set [Sigma] for terms in [Ts]. It's almost the set
of all possible sorts that may appear at the end of the telescope, but
that not totally true, just a hint.*)
Inductive Sigma : Env -> Term -> Sorts -> Prop :=
 | Sigma_sorts : forall Γ s s', Ax s s' -> Sigma Γ !s s'
 | Sigma_pi : forall Γ A B s t u, Rel s t u ->
   ( Tv A -> Γ ⊢ A : !s) -> (Ts A -> Sigma Γ A s) ->
   ( Tv B -> A::Γ ⊢ B : !t) -> (Ts B -> Sigma (A::Γ) B t) -> Sigma Γ (Π(A),B) u
 | Sigma_la : forall Γ A M s, Sigma (A::Γ) M s -> Sigma Γ (λ[A],M) s
 | Sigma_app : forall Γ M N s, Sigma Γ M s -> Sigma Γ (M· N) s.

Hint Constructors Sigma.
(** Some handy functions.*)
Lemma Tels_tool : forall Γ Γ' s t, Tels Γ !s →→ Tels Γ' !t -> s = t /\ length Γ = length Γ'.
induction Γ; destruct Γ'; simpl in *; intros.
apply Betas_S in H. injection H; intros; subst; intuition.
apply Betas_S in H; discriminate.
apply Betas_not_Pi_to_Sort in H; elim H.
apply Betas_Pi_inv in H as ( C & D & ? & ? & ?). injection H ; intros; subst; clear H.
destruct (IHΓ Γ' s t0 H1). subst; intuition.
Qed.

Lemma ins_in_env_Sigma : forall a T Δ A n Γ Γ' sa, Γ ⊢ a : T -> Δ ⊢ A : !sa -> Ts a -> ins_in_env Δ A n Γ Γ' ->
  forall s , Sigma Γ a s <-> Sigma Γ' (a↑1#n) s.
induction a; intros; simpl in *.
(**)
inversion H1.
(**)
split; intros. inversion H3; subst; clear H3. intuition. inversion H3; subst; clear H3. intuition.
(**)
inversion H1; subst; clear H1. apply gen_app in H  as ( C & D & ? & ?& ?).
destruct (IHa1 (Π(C),D) Δ A n Γ Γ' sa H1 H0 H4 H2 s).
split; intros. inversion H7; subst; clear H7. intuition.  inversion H7; subst; clear H7. intuition.
(**)
apply gen_pi in H as (u & v & w & ? & ? & ? & ?).
split; intros. inversion H6; subst; clear H6. econstructor. apply H9.
intros. apply Tv_lift in H6. change !s0 with (!s0 ↑ 1 # n). eapply weakening. apply (H10 H6). apply H2. apply H0.
intros. apply Ts_lift in H6. eapply IHa1. apply H4. apply H0. trivial. apply H2. intuition.
intros. apply Tv_lift in H6. change !t with (!t ↑ 1 # (S n)). eapply weakening. apply (H13 H6). constructor; apply H2. apply H0.
intros. apply Ts_lift in H6. eapply IHa2. apply H5. apply H0. trivial. constructor; apply H2. intuition.

inversion H6; subst; clear H6. econstructor. apply H9.
intros. replace u with s0 in *. trivial. apply conv_sort. eapply Shape_of_Type_Tv. apply H10. apply Tv_lift. trivial. change !u with (!u ↑ 1 # n).
eapply weakening. apply H4. apply H2. apply H0. apply Tv_lift; trivial.
intros. eapply IHa1. apply H4. apply H0. trivial. apply H2. apply H11. apply Ts_lift; trivial.
intros. replace v with t in *. trivial. apply conv_sort. eapply Shape_of_Type_Tv. apply H13. apply Tv_lift. trivial. change !v with (!v ↑ 1 # (S n)).
eapply weakening. apply H5. constructor; apply H2. apply H0. apply Tv_lift; trivial.
intros. eapply IHa2. apply H5. apply H0. trivial. constructor; apply H2. apply H15. apply Ts_lift; trivial.
(**)
inversion H1; subst; clear H1. apply gen_la  in H as ( u & v & w &  D & ? & ?& ? & ? & ?).
destruct (IHa2 D Δ A (S n) (a1::Γ) (a1↑1#n :: Γ') sa H5 H0 H4) with (s := s). constructor; trivial.
split; intros. inversion H9; subst; clear H9. intuition.  inversion H9; subst; clear H9. intuition.
Qed.

Lemma In_Sigma_tool : forall Γ a A, Γ ⊢ a : A -> forall Δ s, Ts a -> A →→ Tels Δ !s -> Sigma Γ a s.
induction 1; intros.
(**)
apply Betas_S in H2. destruct Δ; simpl in H2; try discriminate. injection H2; intros; subst; clear H2.
intuition.
(**)
inversion H1.
(**)
apply Betas_S in H3. destruct Δ; simpl in H3; try discriminate. injection H3; intros; subst; clear H3.
apply Sigma_pi with s t; intros; trivial.
apply IHtyp1 with nil; simpl; intuition. apply IHtyp2 with nil; simpl; intuition.
(**)
inversion H3; subst; clear H3.
apply Betas_Pi_inv in H4 as (A' & ? & ? & ?& ?).
destruct Δ; simpl in H3. discriminate. injection H3; intros; subst; clear H3.
constructor. apply IHtyp3 with Δ; trivial.
(**)
inversion H1; subst; clear H1.
destruct (Shape_of_Type_Ts Γ M (Π(A),B) H (Π(A),B) H H4) as (s' & _ & Θ & ? & _ ).
apply Betas_Pi_inv in H1 as (A' & ? & ? & ?& ?).
destruct Θ; simpl in H1. discriminate. injection H1; intros; subst; clear H1.
replace s with s' in *.
constructor. apply IHtyp1 with (A::Θ); simpl; intuition.
destruct (Betas_diamond (B[← N]) (Tels Δ !s) (Tels Θ !s')[← N] H2) as (Z & ?& ?).
intuition. apply Betas_Tels_inv in H1 as (Δ' & ? & -> & ? & ?).
rewrite Tels_subst in H6. apply Betas_S in H7; subst. simpl in H6.
apply Tels_tool in H6; intuition.
(**)
destruct (Betac_confl A B H) as ( Z  & ?& ?). destruct (Betas_diamond B Z (Tels Δ !s0) H5 H3) as (ZZ & ?& ?).
apply Betas_Tels_inv in H7 as (Θ & ? & -> & ? & ?). apply Betas_S in H8; subst.
eauto.
Qed.

Lemma In_Sigma : forall Γ A s, Γ ⊢ A : !s -> Ts A -> Sigma Γ A s.
intros. apply In_Sigma_tool with !s nil; simpl; trivial.
Qed.

Lemma env_subst_tool : forall Γ n M, length (Γ[[n ← M]]) = length Γ.
induction Γ; simpl in *; intros; intuition.
Qed.

Fixpoint env_subst_down Γ N n {struct Γ } := match Γ with
 | nil => nil
 | A::Γ' => (A[length Γ' + n ← N]) :: (env_subst_down Γ' N n)
end.

Lemma env_subst_down_app :forall Γ Γ' t n,  env_subst_down (Γ++Γ') t n = (env_subst_down Γ t (length Γ' + n))++(env_subst_down Γ' t n).
induction Γ; simpl in *; intros. trivial.
replace (length (Γ++Γ')+n) with (length Γ + (length Γ' + n)).
rewrite IHΓ. trivial. rewrite app_length. intuition.
Qed.

Lemma env_subst_down_rev : forall Θ t n, rev (Θ [[n ← t]]) = env_subst_down (rev Θ) t n.
induction Θ; simpl in *; intros. trivial.
rewrite env_subst_down_app. rewrite IHΘ. simpl. trivial.
Qed.

Lemma env_subst_down_sub_in_env : forall Θ Γ t A, sub_in_env Γ t A (length Θ) (Θ ++ A :: Γ) (env_subst_down Θ t 0 ++ Γ).
induction Θ; simpl in * ;intros. constructor.
replace (length Θ+0) with (length Θ) by intuition. apply sub_S. trivial.
Qed.

Lemma sub_in_env_rev_append : forall Θ Γ t A ,  sub_in_env Γ t A (length Θ) (rev (A :: Θ) ++ Γ) (rev (Θ [[0 ←t]]) ++ Γ).
intros. rewrite env_subst_down_rev. simpl. rewrite <- app_assoc;  simpl. rewrite <- rev_length. apply env_subst_down_sub_in_env.
Qed.

Lemma Betas_env_length : forall Γ Γ', Γ →→e Γ' -> length Γ = length Γ'.
induction 1; intuition. induction H; simpl; intuition.
rewrite IHBetas_env1. trivial.
Qed.

(** Terms in [Ts] have a particular shape: they are build around sorts and
pi-types, two families of terms that cannot be type by a pi-type. Hence, if an
  application is in [Ts], it will reduce to some lambda-telescope whose head
is a sort or a pi-team.*)
(** (we don't talk of weak head normal form since not all PTS are normalizing
and we still want to be fully general.*)
Lemma Shape_of_Ts_Term : forall Γ a A, Γ ⊢ a : A -> forall Δ s s1, Ts a -> A →→ Tels Δ !s1 -> Sigma Γ a s ->
  exists Δ', exists a1, length Δ = length Δ' /\ a →→ Tels' Δ' a1 /\ rev Δ'++Γ ⊢ a1 : !s.
induction 1; intros.
(**)
exists nil; exists !s; simpl; intuition.
destruct Δ; simpl in H2. trivial. apply Betas_S in H2; discriminate.
inversion H3; subst; clear H3. intuition.
(**)
inversion H1.
(**)
replace Δ with (@nil Term) in *. simpl in *.
inversion H4; subst; clear H4.
destruct (Tx_ok A).
  destruct (Tx_ok B).
    exists nil; exists (Π(A),B); simpl; intuition. econstructor. apply H7. trivial. trivial.

    destruct (IHtyp2 nil t0 t H5 ) as (Δ' & b & ? & ? & ?). simpl; trivial. intuition.
    replace Δ' with (@nil Term) in *; simpl in *. exists nil; exists (Π(A), b); simpl; intuition.
    econstructor. apply H7. trivial. trivial. destruct Δ'. trivial. discriminate.
  destruct (IHtyp1 nil s2 s) as (Δ' & a & ? & ?& ?). trivial. simpl; trivial. intuition.
  replace Δ' with (@nil Term) in *; simpl in *. destruct (Tx_ok B).
    exists nil; exists (Π(a),B); simpl; intuition. econstructor. apply H7. trivial.
    eapply Betas_env_sound. apply H9. apply Betas_env_comp; intuition.

    destruct (IHtyp2 nil t0 t H12) as (Δ'' & b & ? & ? & ?). simpl; trivial. intuition.
    replace Δ'' with (@nil Term) in *; simpl in *. exists nil; exists (Π(a),b); simpl; intuition.
    econstructor. apply H7. trivial. eapply Betas_env_sound. apply H16. apply Betas_env_comp; intuition.
    destruct Δ''. trivial. discriminate.     destruct Δ'. trivial. discriminate.
    apply Betas_S in H3. destruct Δ. trivial. discriminate.
(**)
inversion H3; subst; clear H3. inversion H5; subst; clear H5. apply Betas_Pi_inv in H4 as (A' & B' & ? & ?& ?).
destruct Δ. discriminate. injection H3; intros; subst; clear H3.
destruct (IHtyp3 Δ s s0 H7 H5 H10) as (Δ' & b' & ? & ? & ?).
exists (A::Δ'); exists b'; simpl; intuition. rewrite <- app_assoc. simpl. trivial.
(**)
inversion H3; subst; clear H3. inversion H1; subst; clear H1.
destruct (Shape_of_Type_Ts Γ M (Π(A),B) H (Π(A),B) H H4) as ( sa & _ & Θ & ? & _ ).
apply Betas_Pi_inv in H1 as (A' & B' & ? & ?& ?). destruct Θ. discriminate.
injection H1; intros; subst; clear H1. replace sa with s1 in *.
destruct (IHtyp1 (A::Θ) s s1 H4) as ( Θ' & m & ? & ? &?). simpl; intuition. trivial.
destruct Θ' as [ | A'' Θ']. discriminate. simpl in H1. injection H1; intros; subst; clear H1.
exists (Θ'[[ 0 ← N]]); exists (m[ (length Θ' )← N]); repeat split.
rewrite env_subst_tool.   destruct (Betas_diamond (B[← N]) (Tels Δ !s1) (Tels Θ !s1)[← N] H2 ) as (Z & ?& ?).
intuition. apply Betas_Tels_inv in H1 as (? & ?& -> & ?& ?).
rewrite Tels_subst in H10. apply Betas_S in H11; subst.
apply Tels_tool in H10 as ( _ & ?). replace (length Δ) with (length x).
rewrite env_subst_tool in H10. rewrite <- H9; intuition. apply Betas_env_length in H1. intuition. apply Betas_trans with ((λ[A''],Tels' Θ' m)· N).
intuition. replace (length Θ') with (length Θ' + 0). rewrite <- Tels'_subst. constructor.
constructor. intuition. assert (A≡ A'' /\ exists s, Γ ⊢ A'' : !s).
assert ( Γ ⊢ λ[A''],Tels' Θ' m : Π(A),B). eapply SubjectRed. apply H. trivial.
  apply gen_la in H1 as ( ss & ? & ? & ? & ? & _ & ? & _ ). split.
  apply PiInj in H1; intuition. exists ss; trivial.
change !s with (!s[ (length Θ') ← N]).   destruct H1 as (? & ss & ?). eapply substitution. apply H7.  eapply Cnv. apply H1. apply H0.
apply H10. apply sub_in_env_rev_append. apply wf_typ in H7; trivial.  destruct (Betas_diamond (B[← N]) (Tels Δ !s1) (Tels Θ !sa)[← N] H2) as (Z & ?& ?).
intuition. apply Betas_Tels_inv in H1 as (Δ' & ? & -> & ? & ?).
rewrite Tels_subst in H6. apply Betas_S in H7; subst. simpl in H6.
apply Tels_tool in H6; intuition.
(**)
destruct (Betac_confl A B H) as (Z & ? & ?). destruct (Betas_diamond B (Tels Δ !s1) Z H3 H6) as (ZZ & ? &?).
apply Betas_Tels_inv in H7 as (? & ? & -> & ? & ?). apply Betas_S in H9; subst.
destruct (IHtyp1 x s0 s1 H2) as ( Δ' & a1 & ? & ? & ?). eauto. trivial.
exists Δ'; exists a1; intuition. rewrite <- H9. apply Betas_env_length in H7. trivial.
Qed.

Lemma Ts_Sigma_Shape : forall Γ A s, Γ ⊢ A : !s -> forall s', Ts A -> Sigma Γ A s' -> exists A', A →→ A' /\ Γ ⊢ A' : !s'.
intros.
destruct (Shape_of_Ts_Term Γ A !s H nil s' s H0) as ( ? & a & ? & ? & ?). simpl; trivial. trivial.
replace x with (@nil Term) in *; simpl in *.
exists a; intuition. destruct x. trivial. discriminate.
Qed.

(* begin hide *)
Lemma L1 : forall Δ Z n Γ0 Γ, ins_in_env Δ Z n Γ0 Γ -> forall v a, n <= v -> a ↓ S v ∈ Γ ->
  a ↓ v ∈ Γ0.
induction 1; intros. inversion H0; subst; clear H0. trivial.
inversion H1; subst; clear H1. destruct v. apply le_Sn_O in H0. contradict H0; intuition.
apply le_S_n in H0. constructor. intuition.
Qed.

Lemma L2 : forall Δ Z n Γ0 Γ, ins_in_env Δ Z n Γ0 Γ -> forall v a, n > v ->  a ↓ v ∈ Γ ->
 exists b, b ↓ v ∈ Γ0 /\ b↑1# (n-S v) = a.
induction 1; intros. unfold gt in H. apply lt_n_O in H; elim H. inversion H1; subst; clear H1.
exists d; intuition. replace (S n - 1) with n by intuition. trivial.
apply lt_S_n in H0. destruct (IHins_in_env n0 a) as ( b & ? & ?). intuition. trivial.
exists b; split. intuition. replace (S n - S (S n0)) with (n - S n0) by intuition.
trivial.
Qed.

Lemma ins_in_env_wf : forall Δ A n Γ Γ', ins_in_env Δ A n Γ Γ' -> Γ' ⊣ -> exists s, Δ ⊢ A : !s.
induction 1; intros.
inversion H; subst; clear H. exists s; trivial.
inversion H0; subst; clear H0. apply wf_typ in H2. intuition.
Qed.
(* \end *)
Lemma Beta_lift_inv : forall a b n m , a ↑ n # m → b -> exists a', a → a' /\  b = a' ↑ n # m .
induction a; intros; simpl in *.
destruct le_gt_dec. inversion H. inversion H. inversion H.
inversion H; subst; clear H. destruct a1; simpl in H1; try discriminate. destruct le_gt_dec ; discriminate.
injection H1; intros; subst; clear H1. exists (a1_2 [ ← a2]); intuition.
change m with (0+m). rewrite <- substP1. simpl; trivial.
apply IHa1 in H3 as ( a' & ?& ->). exists (App a' a2); intuition.
apply IHa2 in H3 as ( a' & ?& ->). exists (App a1 a'); intuition.
inversion H; subst; clear H. apply IHa2 in H3 as (a' & ? & ->). exists (Pi a1 a'); intuition.
apply IHa1 in H3 as (a' & ? & ->). exists (Pi a' a2); intuition.
inversion H; subst; clear H. apply IHa2 in H3 as (a' & ? & ->). exists (La a1 a'); intuition.
apply IHa1 in H3 as (a' & ? & ->). exists (La a' a2); intuition.
Qed.

Lemma Betas_lift_inv : forall a b n m , a ↑ n # m →→ b -> exists a', a →→ a' /\  b = a' ↑ n # m .
intros. remember (lift_rec n m a) as A. revert n m a HeqA.
induction H; intros; subst. exists a; intuition.
apply Beta_lift_inv in H as ( b & ? & ->). exists b; intuition.
destruct (IHBetas1 n m a) as (b & ? & -> ); trivial.
destruct (IHBetas2 n m b) as (c & ? & -> ); trivial.
exists c; intuition; eauto.
Qed.

(* end hide *)
(** To prove strenghthening, we will first prove that if the hypothesis is not
  used in the term, we can safely remove it, but we may need to beta reduce the
term in order to be still valid. *)
Theorem WeakStrenghthening : (forall Γ' M T, Γ' ⊢ M : T -> forall m n Δ A Γ, M = m ↑ 1 # n ->
  ins_in_env Δ A n Γ Γ' ->  exists T', T →→ T'↑ 1 # n /\ Γ ⊢ m : T' ) /\
  (forall Γ', Γ' ⊣ -> forall n Δ A Γ, ins_in_env Δ A n Γ Γ' -> Γ ⊣).
apply typ_induc; intros.
(**)
destruct m; simpl in H0; try discriminate. destruct le_gt_dec; discriminate. injection H0; intros; subst; clear H0.
exists !t; split; trivial. constructor. trivial. eauto.
(**)
destruct m; simpl in H0; try discriminate. destruct le_gt_dec; injection H0; intros; subst; clear H0.
destruct i as ( a & ? & ?).   exists (a ↑ (S v0)); split. rewrite liftP3; subst; intuition. simpl. constructor; trivial.
constructor. eauto. exists a; intuition. eapply L1. apply H1. trivial. trivial.

destruct i as (a & ? & ?). destruct (L2 Δ A0 n Γ0 Γ H1 v0 a g H2) as ( b& ? & ?). exists (b ↑ (S v0)); split.
replace n with (S v0 + (n - S v0)) by intuition. rewrite liftP2; intuition. rewrite H4. rewrite H0. intuition.
constructor. eauto. exists b; intuition.
(**)
destruct m; simpl in H1; try discriminate. destruct le_gt_dec; discriminate. injection H1; intros; subst; clear H1.
destruct (H m1 n Δ A0 Γ0) as (A' & ? & ?); trivial. replace A' with !s in *. clear H1; simpl in *. clear H.
destruct (H0 m2 (S n) Δ A0 (m1::Γ0)) as (B' & ? & ?); trivial. constructor. trivial. replace B' with !t in *. clear H; simpl in *. clear H0.
exists !u; intuition. apply cPi with s t; trivial.
apply Betas_S in H. destruct B'; try discriminate. unfold lift_rec in H; destruct le_gt_dec; discriminate. intuition.
apply Betas_S in H1. destruct A'; try discriminate. unfold lift_rec in H1; destruct le_gt_dec; discriminate. intuition.
(**)
destruct m; simpl in H2; try discriminate. destruct le_gt_dec; discriminate. injection H2; intros; subst; clear H2.
destruct (H m1 n Δ A0 Γ0) as (A' & ? & ?); trivial. replace A' with !s1 in *; simpl in *. clear H2. clear H.
destruct (H1 m2 (S n) Δ A0 (m1::Γ0)) as (M & ? & ?); trivial. constructor; trivial. clear H1.
assert (m1↑1#n::Γ ⊢ M ↑ 1 # (S n) : !s2). eapply SubjectRed. apply t0. trivial.
destruct (TypeCorrect (m1::Γ0) m2 M H2) as [ [w ?] | [w ?] ].
  subst; simpl in H1. apply gen_sort in H1 as (ss & ?  & ?). assert (m1::Γ0 ⊢ !w : !s2).
  apply conv_sort in H1. subst. constructor. trivial. apply wf_typ in H2; trivial.
  exists (Π(m1),!w);simpl; intuition. apply cLa with s1 s2 s3; trivial.

  assert (m1 ↑ 1 # n :: Γ ⊢ M ↑ 1 # (S n) : !w). change !w with (!w↑ 1 # (S n)). destruct (ins_in_env_wf Δ A0 n Γ0 Γ H3) as (a & ? ).
  apply wf_typ in t; trivial. eapply weakening. apply H5. constructor. apply H3. apply H6.
  destruct (Tx_ok (M↑ 1 # (S n))). replace w with s2 in *. exists (Π(m1),M); simpl; intuition.
  apply cLa with s1 s2 s3; trivial. apply conv_sort. eapply Shape_of_Type_Tv. apply H1. trivial. trivial.
  destruct (Ts_Sigma_Shape (m1::Γ0) M w H5 s2) as ( M' & ? & ?). apply Ts_lift in H7; trivial.
  destruct (ins_in_env_wf Δ A0 (S n) (m1::Γ0) (m1↑1#n::Γ)) as (d & ?). constructor; trivial. apply wf_typ in H1; trivial.
  eapply ins_in_env_Sigma. apply H5. apply H8. apply Ts_lift in H7; trivial. constructor. apply H3. apply In_Sigma; trivial.
  exists (Π(m1),M'); simpl; split. eauto. apply cLa with s1 s2 s3; trivial. eauto.
  apply Betas_S in H2. destruct A'; try discriminate. unfold lift_rec in H2; destruct le_gt_dec; discriminate. intuition.
(**)
destruct m; simpl in H1; try discriminate. destruct le_gt_dec; discriminate. injection H1; intros; subst; clear H1.
destruct (H m1 n Δ A0 Γ0) as (P & ? & ?); trivial. apply Betas_Pi_inv in H1 as (C & D & ? & ?& ?).
destruct P; try discriminate. unfold lift_rec in H1; destruct le_gt_dec; discriminate. injection H1; intros; subst; clear H1.
destruct (H0 m2 n Δ A0 Γ0) as (A' & ? & ?); trivial. destruct (Betas_diamond A (P1 ↑ 1 # n) (A' ↑ 1 # n) H4 H1) as ( Z & ?& ?).
apply Betas_lift_inv in H7. destruct H7 as (ZZ & ? & -> ).
apply Betas_lift_inv in H8. destruct H8 as (? & ? & ?). apply inv_lift in H9. subst.
exists (P2 [← m2 ]); split. change n with (0+n). rewrite substP1. intuition. apply cApp with x.
eapply Betas_typ_sound. apply H3. intuition. eapply Betas_typ_sound. apply H6. intuition.
(**)
destruct (H m n Δ A0 Γ0 H1 H2) as (a' & ? & ?).
destruct (Betac_confl A B b) as ( Z & ? &?). destruct (Betas_diamond A (a'↑ 1 # n) Z H3 H5) as (ZZ & ?& ?).
apply Betas_lift_inv in H7. destruct H7 as (aa & ? & -> ). exists aa; split. eauto.
eapply Betas_typ_sound. apply H4. trivial.
(* wf *)
inversion H.
(**)
inversion H0; subst; clear H0.
apply wf_typ in t; trivial.
destruct (H d n0 Δ A0 Δ0) as (? & ? & ?); trivial.
apply Betas_S in H0. destruct x; try discriminate. unfold lift_rec in H0; destruct le_gt_dec; discriminate.
eauto.
Qed.

(** With the previous lemma and Type Correctness, we can prove the full lemma:
if an hypothesis is not used in the term and it's type, we can simply remove
  it.*)
Theorem Strenghthening: forall Γ' M n T, Γ' ⊢ M ↑ 1 # n: T ↑ 1 # n -> forall Δ A Γ, ins_in_env Δ A n Γ Γ' ->
 Γ ⊢ M : T.
intros. destruct WeakStrenghthening as ( ? & _ ). destruct (H1 Γ' (M↑ 1 # n) (T↑ 1 # n) H M n Δ A Γ) as (T' & ? & ?); trivial.
apply Betas_lift_inv in H2 as ( ? & ?& ?). apply inv_lift in H4; subst.
apply TypeCorrect in H as [ [ w ?]|[ w ?] ]. destruct T ; try discriminate. unfold lift_rec in H; destruct le_gt_dec; discriminate.
apply Betas_S in H2; subst. trivial. destruct (H1 Γ' (T↑1#n) !w H T n Δ A Γ) as (T'' & ? & ?); trivial. apply Betas_S in H4.
destruct T'' ; try discriminate. unfold lift_rec in H4; destruct le_gt_dec; discriminate. eauto.
Qed.

End ut_strengh_mod.


Require Import CertiGraph.prim.prim_env.
Require Export CertiGraph.priq.priq_arr_specs.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Import CertiGraph.prim.prim_constants.
Require Import CertiGraph.graph.SpaceUAdjMatGraph2.
Require Export CertiGraph.prim.prim2.

Local Open Scope Z_scope.

Section PrimSpec.

Context {Z_EqDec : EquivDec.EqDec Z eq}.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Existing Instance CompSpecs.

Definition G := @UAdjMatGG size inf.
Identity Coercion UAdjMatGG_G: G >-> UAdjMatGG.

Definition getCell_spec :=
  DECLARE _getCell
  WITH g: G,
       graph_ptr: pointer_val,
       addresses: list val,
       u: V,
       i : V
  PRE [tptr tint, tint, tint]
    PROP (0 <= i < size;
         0 <= u < size;
         Forall (fun list => Zlength list = size) (@graph_to_mat size g eformat);
         (size * size <= Int.max_signed))
    PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
    GLOBALS ()
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val graph_ptr))
  POST [tint]
    PROP ()
    RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_symm_mat size g)))))
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val graph_ptr)).

Definition initialise_list_spec :=
  DECLARE _initialise_list
  WITH arr : val, old_list: list val, a: Z
  PRE [tptr tint, tint]
     PROP ( writable_share Tsh;
            repable_signed a;
            size <= Int.max_signed
          )
     PARAMS ( arr; Vint (Int.repr a) )
     GLOBALS ()
     SEP (data_at Tsh (tarray tint size) (old_list) (arr))
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (data_at Tsh (tarray tint size) (list_repeat (Z.to_nat size) (Vint (Int.repr a))) arr
         ).

Definition initialise_matrix_spec :=
  DECLARE _initialise_matrix
  WITH arr : val, old_contents: list Z, a: Z
  PRE [tptr tint, tint]
     PROP ( writable_share Tsh;
            Zlength old_contents = Z.mul size size;
            repable_signed a;
            0 < size <= Int.max_signed; (*this is not enough for malloc, requires*)
            size * (4 * size) <= Ptrofs.max_signed (*you can alloc the entire matrix. Can derive above from here*)
          )
     PARAMS ( arr ; Vint (Int.repr a) )
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh old_contents arr)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (list_repeat (Z.to_nat (Z.mul size size)) a) arr).

Definition prim_spec :=
  DECLARE _prim
  WITH g: G, garbage: list V, gptr : pointer_val, r: Z, parent_ptr : pointer_val
  PRE [tptr tint, tint, tptr tint]
     PROP ( writable_share Tsh;
            vvalid g r;
            size * (4 * size) <= Ptrofs.max_signed;
            Forall (fun list => Zlength list = size) (@graph_to_mat size g eformat)
          )
     PARAMS ( pointer_val_val gptr; (Vint (Int.repr r)); pointer_val_val parent_ptr)
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) garbage) (pointer_val_val parent_ptr)
         )
  POST [ tvoid ]
     EX mst: G,
     EX fmst: FiniteGraph mst,
     EX parents: list V,
     PROP ( (*connected_graph mst;*)
            @minimum_spanning_forest size inf mst g;
            Permutation (EList mst) (map (fun v => eformat (v, Znth v parents))
              (filter (fun v => Znth v parents <? size) (nat_inc_list (Z.to_nat size))))
          )
     RETURN ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_list size g eformat) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) parents) (pointer_val_val parent_ptr)
         ).

Definition Gprog: funspecs :=
  ltac:(with_library prog
                     [(@push_spec size inf _);
                     (@pq_emp_spec size inf _);
                     (@popMin_spec size inf Z_EqDec _);
                     (@adjustWeight_spec size inf _);
                     (@init_spec size _);
                     freePQ_spec;
                     getCell_spec;
                     initialise_list_spec;
                     initialise_matrix_spec;
                     prim_spec
       ]).

End PrimSpec.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Y P Z Q Qprime Cprime : Universe, ((wd_ A Y /\ (wd_ P Y /\ (wd_ Q Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ A Z /\ (wd_ B Y /\ (wd_ Y Qprime /\ (wd_ Qprime Cprime /\ (wd_ Y Z /\ (wd_ Z Y /\ (wd_ C Y /\ (wd_ P C /\ (wd_ Y Cprime /\ (wd_ Q C /\ (wd_ Q Qprime /\ (wd_ C Cprime /\ (wd_ Cprime Y /\ (wd_ P Q /\ (col_ P Y Q /\ (col_ P Y C /\ (col_ P Q C /\ (col_ Y Q C /\ (col_ A Y B /\ (col_ A Y Z /\ (col_ A B Z /\ (col_ Y B Z /\ (col_ Q Y P /\ (col_ Y Qprime Cprime /\ (col_ Y Cprime P /\ (col_ Y P Qprime /\ (col_ C Y Cprime /\ col_ Q Z Qprime)))))))))))))))))))))))))))))))))) -> col_ Y Q Qprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From ITree Require Import ITree.
From ITreeTutorial Require Import Imp.
From Coq Require Import NArith String.

Local Open Scope string_scope.

Import ImpNotations.

Definition loopy : stmt :=
  WHILE 1 DO Skip.

Fixpoint run {A} (n : nat) (t : itree void1 A) : option A :=
  match n, observe t with
  | O, _ => None
  | S _, RetF a => Some a
  | S n, TauF t => run n t
  | S _, VisF e _ => match e with end
  end.

Definition run_ (n : N) (s : stmt) : option env :=
  option_map fst (run (N.to_nat n) (eval_imp s)).

Require Extraction.
Require ExtrOcamlBasic.
Require ExtrOcamlString.
Require ExtrOcamlNatInt.

Parameter io : Type.
Extract Inlined Constant io => "(unit -> unit)".

Parameter seq : io -> io -> io.
Extract Constant seq => "fun a b () -> a (); b ()".

Parameter print_binding : var -> nat -> io.
Extract Constant print_binding =>
  "fun v n () ->
     let to_string l =
       let l_ = ref l in
       String.init (List.length l) (fun _ ->
         match !l_ with
         | h :: t -> l_ := t; h
         | [] -> assert false) in
     let v = to_string v in
     print_string v;
     print_string "":="";
     print_int n;
     print_string "";""".

Parameter print_newline : io.
Extract Inlined Constant print_newline => "print_newline".

Parameter nit : Type.
Extract Inlined Constant nit => "unit".

Parameter run_io : io -> nit.
Extract Constant run_io => "fun w -> w ()".

Fixpoint print_env (e : env) : io :=
  match e with
  | nil => print_newline
  | cons (v, n) e => seq (print_binding v n) (print_env e)
  end.

Definition run' (n : N) (s : stmt) : io :=
  match run_ n s with
  | None => print_newline
  | Some e => print_env e
  end.

Definition test : nit :=
  run_io (
    seq (run' 100 loopy)
        (run' 1000 (fact "X" "Y" 10)%string)
  ).

Extraction "imp_test.ml" test.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Computation of resource bounds for Linear code. *)

Require Import Coqlib.
Require Import AST.
Require Import Op.
Require Import Locations.
Require Import Linear.
Require Import Lineartyping.
Require Import Conventions.

Section WITHEF.
Context `{Hsc: SyntaxConfiguration}.

(** * Resource bounds for a function *)

(** The [bounds] record capture how many local and outgoing stack slots
  and callee-save registers are used by a function. *)

(** We demand that all bounds are positive or null.
  These properties are used later to reason about the layout of
  the activation record. *)

Record bounds : Type := mkbounds {
  bound_int_local: Z;
  bound_float_local: Z;
  bound_int_callee_save: Z;
  bound_float_callee_save: Z;
  bound_outgoing: Z;
  bound_stack_data: Z;
  bound_int_local_pos: bound_int_local >= 0;
  bound_float_local_pos: bound_float_local >= 0;
  bound_int_callee_save_pos: bound_int_callee_save >= 0;
  bound_float_callee_save_pos: bound_float_callee_save >= 0;
  bound_outgoing_pos: bound_outgoing >= 0;
  bound_stack_data_pos: bound_stack_data >= 0
}.

(** The following predicates define the correctness of a set of bounds
    for the code of a function. *)

Section BELOW.

Variable funct: function.
Variable b: bounds.

Definition mreg_within_bounds (r: mreg) :=
  match mreg_type r with
  | Tint => index_int_callee_save r < bound_int_callee_save b
  | Tfloat => index_float_callee_save r < bound_float_callee_save b
  end.

Definition slot_within_bounds (s: slot) :=
  match s with
  | Local ofs Tint => 0 <= ofs < bound_int_local b
  | Local ofs Tfloat => 0 <= ofs < bound_float_local b
  | Outgoing ofs ty => 0 <= ofs /\ ofs + typesize ty <= bound_outgoing b
  | Incoming ofs ty => In (S s) (loc_parameters funct.(fn_sig))
  end.

Definition instr_within_bounds (i: instruction) :=
  match i with
  | Lgetstack s r => slot_within_bounds s /\ mreg_within_bounds r
  | Lsetstack r s => slot_within_bounds s
  | Lop op args res => mreg_within_bounds res
  | Lload chunk addr args dst => mreg_within_bounds dst
  | Lcall sig ros => size_arguments sig <= bound_outgoing b
  | Lbuiltin ef args res => mreg_within_bounds res
  | Lannot ef args => forall s, In (S s) args -> slot_within_bounds s
  | _ => True
  end.

End BELOW.

Definition function_within_bounds (f: function) (b: bounds) : Prop :=
  forall instr, In instr f.(fn_code) -> instr_within_bounds f b instr.

(** * Inference of resource bounds for a function *)

(** The resource bounds for a function are computed by a linear scan
  of its instructions. *)

Section BOUNDS.

Variable f: function.

(** In the proof of the [Stacking] pass, we only need to bound the
  registers written by an instruction.  Therefore, this function
  returns these registers, ignoring registers used only as
  arguments. *)

Definition regs_of_instr (i: instruction) : list mreg :=
  match i with
  | Lgetstack s r => r :: nil
  | Lsetstack r s => r :: nil
  | Lop op args res => res :: nil
  | Lload chunk addr args dst => dst :: nil
  | Lstore chunk addr args src => nil
  | Lcall sig ros => nil
  | Ltailcall sig ros => nil
  | Lbuiltin ef args res => res :: nil
  | Lannot ef args => nil
  | Llabel lbl => nil
  | Lgoto lbl => nil
  | Lcond cond args lbl => nil
  | Ljumptable arg tbl => nil
  | Lreturn => nil
  end.

Fixpoint slots_of_locs (l: list loc) : list slot :=
  match l with
  | nil => nil
  | S s :: l' => s :: slots_of_locs l'
  | R r :: l' => slots_of_locs l'
  end.

Definition slots_of_instr (i: instruction) : list slot :=
  match i with
  | Lgetstack s r => s :: nil
  | Lsetstack r s => s :: nil
  | Lannot ef args => slots_of_locs args
  | _ => nil
  end.

Definition max_over_list (A: Type) (valu: A -> Z) (l: list A) : Z :=
  List.fold_left (fun m l => Zmax m (valu l)) l 0.

Definition max_over_instrs (valu: instruction -> Z) : Z :=
  max_over_list instruction valu f.(fn_code).

Definition max_over_regs_of_instr (valu: mreg -> Z) (i: instruction) : Z :=
  max_over_list mreg valu (regs_of_instr i).

Definition max_over_slots_of_instr (valu: slot -> Z) (i: instruction) : Z :=
  max_over_list slot valu (slots_of_instr i).

Definition max_over_regs_of_funct (valu: mreg -> Z) : Z :=
  max_over_instrs (max_over_regs_of_instr valu).

Definition max_over_slots_of_funct (valu: slot -> Z) : Z :=
  max_over_instrs (max_over_slots_of_instr valu).

Definition int_callee_save (r: mreg) := 1 + index_int_callee_save r.

Definition float_callee_save (r: mreg) := 1 + index_float_callee_save r.

Definition int_local (s: slot) :=
  match s with Local ofs Tint => 1 + ofs | _ => 0 end.

Definition float_local (s: slot) :=
  match s with Local ofs Tfloat => 1 + ofs | _ => 0 end.

Definition outgoing_slot (s: slot) :=
  match s with Outgoing ofs ty => ofs + typesize ty | _ => 0 end.

Definition outgoing_space (i: instruction) :=
  match i with Lcall sig _ => size_arguments sig | _ => 0 end.

Lemma max_over_list_pos:
  forall (A: Type) (valu: A -> Z) (l: list A),
  max_over_list A valu l >= 0.
Proof.
  intros until valu. unfold max_over_list.
  assert (forall l z, fold_left (fun x y => Zmax x (valu y)) l z >= z).
  induction l; simpl; intros.
  omega. apply Zge_trans with (Zmax z (valu a)).
  auto. apply Zle_ge. apply Zmax1. auto.
Qed.

Lemma max_over_slots_of_funct_pos:
  forall (valu: slot -> Z), max_over_slots_of_funct valu >= 0.
Proof.
  intros. unfold max_over_slots_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

Lemma max_over_regs_of_funct_pos:
  forall (valu: mreg -> Z), max_over_regs_of_funct valu >= 0.
Proof.
  intros. unfold max_over_regs_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

Program Definition function_bounds :=
  mkbounds
    (max_over_slots_of_funct int_local)
    (max_over_slots_of_funct float_local)
    (max_over_regs_of_funct int_callee_save)
    (max_over_regs_of_funct float_callee_save)
    (Zmax (max_over_instrs outgoing_space)
          (max_over_slots_of_funct outgoing_slot))
    (Zmax f.(fn_stacksize) 0)
    (max_over_slots_of_funct_pos int_local)
    (max_over_slots_of_funct_pos float_local)
    (max_over_regs_of_funct_pos int_callee_save)
    (max_over_regs_of_funct_pos float_callee_save)
    _ _.
Next Obligation.
  apply Zle_ge. eapply Zle_trans. 2: apply Zmax2.
  apply Zge_le. apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Zle_ge. apply Zmax2.
Qed.

(** We now show the correctness of the inferred bounds. *)

Lemma max_over_list_bound:
  forall (A: Type) (valu: A -> Z) (l: list A) (x: A),
  In x l -> valu x <= max_over_list A valu l.
Proof.
  intros until x. unfold max_over_list.
  assert (forall c z,
            let f := fold_left (fun x y => Zmax x (valu y)) c z in
            z <= f /\ (In x c -> valu x <= f)).
    induction c; simpl; intros.
    split. omega. tauto.
    elim (IHc (Zmax z (valu a))); intros.
    split. apply Zle_trans with (Zmax z (valu a)). apply Zmax1. auto.
    intro H1; elim H1; intro.
    subst a. apply Zle_trans with (Zmax z (valu x)).
    apply Zmax2. auto. auto.
  intro. elim (H l 0); intros. auto.
Qed.

Lemma max_over_instrs_bound:
  forall (valu: instruction -> Z) i,
  In i f.(fn_code) -> valu i <= max_over_instrs valu.
Proof.
  intros. unfold max_over_instrs. apply max_over_list_bound; auto.
Qed.

Lemma max_over_regs_of_funct_bound:
  forall (valu: mreg -> Z) i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  valu r <= max_over_regs_of_funct valu.
Proof.
  intros. unfold max_over_regs_of_funct.
  apply Zle_trans with (max_over_regs_of_instr valu i).
  unfold max_over_regs_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma max_over_slots_of_funct_bound:
  forall (valu: slot -> Z) i s,
  In i f.(fn_code) -> In s (slots_of_instr i) ->
  valu s <= max_over_slots_of_funct valu.
Proof.
  intros. unfold max_over_slots_of_funct.
  apply Zle_trans with (max_over_slots_of_instr valu i).
  unfold max_over_slots_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma int_callee_save_bound:
  forall i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  index_int_callee_save r < bound_int_callee_save function_bounds.
Proof.
  intros. apply Zlt_le_trans with (int_callee_save r).
  unfold int_callee_save. omega.
  unfold function_bounds, bound_int_callee_save.
  eapply max_over_regs_of_funct_bound; eauto.
Qed.

Lemma float_callee_save_bound:
  forall i r,
  In i f.(fn_code) -> In r (regs_of_instr i) ->
  index_float_callee_save r < bound_float_callee_save function_bounds.
Proof.
  intros. apply Zlt_le_trans with (float_callee_save r).
  unfold float_callee_save. omega.
  unfold function_bounds, bound_float_callee_save.
  eapply max_over_regs_of_funct_bound; eauto.
Qed.

Lemma int_local_slot_bound:
  forall i ofs,
  In i f.(fn_code) -> In (Local ofs Tint) (slots_of_instr i) ->
  ofs < bound_int_local function_bounds.
Proof.
  intros. apply Zlt_le_trans with (int_local (Local ofs Tint)).
  unfold int_local. omega.
  unfold function_bounds, bound_int_local.
  eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma float_local_slot_bound:
  forall i ofs,
  In i f.(fn_code) -> In (Local ofs Tfloat) (slots_of_instr i) ->
  ofs < bound_float_local function_bounds.
Proof.
  intros. apply Zlt_le_trans with (float_local (Local ofs Tfloat)).
  unfold float_local. omega.
  unfold function_bounds, bound_float_local.
  eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma outgoing_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Outgoing ofs ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_outgoing function_bounds.
Proof.
  intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing ofs ty)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_r. eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma size_arguments_bound:
  forall sig ros,
  In (Lcall sig ros) f.(fn_code) ->
  size_arguments sig <= bound_outgoing function_bounds.
Proof.
  intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_l. apply max_over_instrs_bound; auto.
Qed.

(** Consequently, all machine registers or stack slots mentioned by one
  of the instructions of function [f] are within bounds. *)

Lemma mreg_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall r, In r (regs_of_instr i) ->
  mreg_within_bounds function_bounds r.
Proof.
  intros. unfold mreg_within_bounds.
  case (mreg_type r).
  eapply int_callee_save_bound; eauto.
  eapply float_callee_save_bound; eauto.
Qed.

Lemma slot_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall s, In s (slots_of_instr i) -> Lineartyping.slot_valid f s ->
  slot_within_bounds f function_bounds s.
Proof.
  intros. unfold slot_within_bounds.
  destruct s.
  destruct t.
  split. exact H1. eapply int_local_slot_bound; eauto.
  split. exact H1. eapply float_local_slot_bound; eauto.
  exact H1.
  split. simpl in H1. exact H1. eapply outgoing_slot_bound; eauto.
Qed.

Lemma slots_of_locs_charact:
  forall s l, In s (slots_of_locs l) <-> In (S s) l.
Proof.
  induction l; simpl; intros.
  tauto.
  destruct a; simpl; intuition congruence.
Qed.

(** It follows that every instruction in the function is within bounds,
    in the sense of the [instr_within_bounds] predicate. *)

Lemma instr_is_within_bounds:
  forall i,
  In i f.(fn_code) ->
  Lineartyping.wt_instr f i ->
  instr_within_bounds f function_bounds i.
Proof.
  intros;
  destruct i;
  generalize (mreg_is_within_bounds _ H); generalize (slot_is_within_bounds _ H);
  simpl; intros; auto.
(* getstack *)
  inv H0. split; auto.
(* setstack *)
  inv H0; auto.
(* call *)
  eapply size_arguments_bound; eauto.
(* annot *)
  inv H0. apply H1. rewrite slots_of_locs_charact; auto.
  generalize (H8 _ H3). unfold loc_acceptable, slot_valid.
  destruct s; (contradiction || omega).
Qed.

Lemma function_is_within_bounds:
  Lineartyping.wt_code f f.(fn_code) ->
  function_within_bounds f function_bounds.
Proof.
  intros; red; intros. apply instr_is_within_bounds; auto.
Qed.

End BOUNDS.

End WITHEF.


Require Export SystemFR.ReducibilityDefinition.
Require Export SystemFR.TypeErasure.

Notation "'[[' Θ ';' Γ '⊨' t ':' T ']]'" := ([ Θ; erase_context Γ ⊨ erase_term t : erase_type T ])
  (at level 60, Θ at level 60, Γ at level 60, t at level 60).

Notation "'[[' Θ ';' Γ '⊨' T1 '<:' T2 ']]'" :=
  ([ Θ; erase_context Γ ⊨ erase_type T1 <: erase_type T2 ])
  (at level 60, Θ at level 60, Γ at level 60, T1 at level 60).

Notation "'[[' Θ ';' Γ '⊨' t1 '≡' t2 ']]'" :=
  ([ Θ; erase_context Γ ⊨ erase_term t1 ≡ erase_term t2 ])
  (at level 60, Θ at level 60, Γ at level 60, t1 at level 60).


Set Implicit Arguments.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Semantics.
  Module Import SemanticsMake := Semantics.Make E.

  Section TopSection.

    Local Infix ";;" := Syntax.Seq (right associativity, at level 95).

    Lemma RunsTo_Seq_Label :
      forall lbls fs x lbl k vs h v' w,
        lbls lbl = Some w ->
        RunsTo (lbls, fs) k (Locals.upd vs x w, h) v' ->
        RunsTo (lbls, fs) (Syntax.Label x lbl ;; k) (vs, h) v'.
      intros.
      econstructor.
      econstructor; eauto.
      eauto.
    Qed.

    Lemma RunsTo_Seq_Assign :
      forall env x e k vs h v',
        RunsTo env k (Locals.upd vs x (SemanticsExpr.eval vs e), h) v' ->
        RunsTo env (Syntax.Assign x e ;; k) (vs, h) v'.
      intros.
      econstructor.
      econstructor; eauto.
      eauto.
    Qed.

  End TopSection.

End Make.


Require Export FcEtt.tactics.
Require Export FcEtt.ett_inf.

Require Import FcEtt.utils.
Require Import FcEtt.imports.

Require Import FcEtt.ett_ind.
Require Import FcEtt.toplevel.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* --------------------------------------------------------------------------- *)
(* --------------------------------------------------------------------------- *)
(* --------------------------------------------------------------------------- *)

Ltac solve_binds :=
  match goal with
    | [ b : binds ?v _ ?G
      , H : forall v' _, binds v' _ ?G -> _ [<=] dom ?G ∧ _ [<=] dom ?G
      |- _ ] =>
      apply H in b; simpl in b; split_hyp; (done || fsetdec)
  end.

(*
Definition tm_context_fv_statement G a A (H: Typing G a A) :=

Definition PropWff_context_fv_statement G phi (H : PropWff G phi) :=
  fv_tm_tm_constraint phi [<=] dom G.
Definition  Iso_context_fv_statement G D p1 p2 (H : Iso G D p1 p2) :=
  fv_tm_tm_constraint p1 [<=] dom G /\
  fv_tm_tm_constraint p2 [<=] dom G.
Definition DefEq_context_fv_statement G D A B T (H : DefEq G D A B T) :=
  fv_tm_tm_tm A [<=] dom G /\ fv_tm_tm_tm B [<=] dom G.
Definition Ctx_context_fv_statement G (H : Ctx G) :=
  forall x A, binds x (Tm A) G -> fv_tm_tm_tm A [<=] dom G.
*)

(* FIXME: ? *)
Import AtomSetImpl.

Lemma in_singleton_subset : forall x (G : context), x `in` dom G -> singleton x [<=] dom G.
Proof.
  unfold Subset.
  intros.
  apply singleton_1 in H0.
  subst.
  done.
Qed.

Hint Unfold AtomSetImpl.Subset.
Hint Resolve binds_In AtomSetImpl.singleton_1 in_singleton_subset.

(*
*)

Theorem context_fv_mutual :
  (forall G (a : tm) A (H: Typing G a A),
      fv_tm_tm_tm a [<=] dom G /\ fv_co_co_tm a [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G)
  /\
  (forall G phi (H : PropWff G phi),
      fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)
  /\
  (forall G D p1 p2 (H : Iso G D p1 p2),
      fv_tm_tm_constraint p1 [<=] dom G /\ fv_co_co_constraint p1 [<=] dom G /\
      fv_tm_tm_constraint p2 [<=] dom G /\ fv_co_co_constraint p2 [<=] dom G)
  /\
  (forall G D A B T (H : DefEq G D A B T),
      (fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G /\
      fv_tm_tm_tm B [<=] dom G /\ fv_co_co_tm B [<=] dom G /\
      fv_tm_tm_tm T [<=] dom G /\ fv_co_co_tm T [<=] dom G))

  /\
  (forall G (H : Ctx G),
      (forall x A,
          binds x (Tm A)   G ->
          fv_tm_tm_tm         A   [<=] dom G /\ fv_co_co_tm         A   [<=] dom G) /\
      (forall c phi,
          binds c (Co phi) G ->
          fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)).

Proof.
  eapply typing_wff_iso_defeq_mutual.
  all: autounfold.

  (* We can't just use `repeat split` because we don't want to split under foralls *)
  all: intros; repeat match goal with |- _ ∧ _ => split end; split_hyp; simpl.
  all: eauto 1.
  (* split all asummptions about unions *)

  (* Do the cases about the context at the end. *)
  all: try (intros x0 A0 BI).
  all: try solve [inversion BI].
  all: try (match goal with |- _ ∧ _ => split end).

  all: try (intros y h1; inversion BI; [
              match goal with
                [ H5 : (_,_) = (_,_) |- _ ] =>
                inversion H5; subst; clear H5; eauto end|
              match goal with
                [ H5 : List.In (?x0, ?s ?a) ?G,
                  H : forall x A, binds x (?s A) ?G -> _ |- _ ] =>
                destruct (H x0 _ H5); eauto end]).

  (* rest of the cases *)
  all: intros y IN.

  (* more splitting, assumption has a union type *)
  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try solve [ apply notin_empty_1 in IN; contradiction].
  all: try solve [ assert (x = y) by auto; subst; eapply binds_In; eauto ].
  all: try solve [ destruct (H _ _ b); eauto ].

  all: try solve [apply H1; eauto; simpl; auto].
  all: try solve [apply H2; eauto; simpl; auto].
  all: try solve [apply H3; eauto; simpl; auto].
  all: try solve [apply H4; eauto; simpl; auto].

  all: try match goal with
    [ H5 : forall x : atom, (x `in` ?L -> False) -> ( _ /\ _ ) |- _ ] =>
    pick fresh x; destruct (H5 x); eauto; split_hyp
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_tm_open_tm_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_tm_open_tm_wrt_co_lower; auto);
    simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_co_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).

  all: try (apply H0 in IN; apply notin_empty_1 in IN; contradiction).
  all: try (apply H1 in IN; apply notin_empty_1 in IN; contradiction).

  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try (simpl in *; match goal with [ H : ?y `in` Metatheory.empty |- _ ] => apply notin_empty_1 in H; done end).

  all: try solve [destruct phi1; simpl in *; eauto].

  all: try solve [ simpl in *; eauto].

  (* all: try solve [ assert (c = y) by auto; subst; eapply binds_In; eauto ]. *)
  all: try solve [ destruct (H0 _ _ b0); simpl in *; eauto].

  all: try match goal with
      [ IN : ?y `in` ?fv_tm_tm_tm ?a,
        H : ∀ a : atom, a `in` ?fv_tm_tm_tm ?b → a `in` dom ?G,
        e : ∀ x : atom,
            (x `in` ?L → False) →
            ?open_tm_wrt_tm ?a (a_Var_f x) = ?c
       |- _ ] =>
      eapply H; pick fresh x; move: (e x ltac:(auto)) => h0;
      assert (x <> y); [ fsetdec|];
      clear Fr;
      have h1: y `in` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x));
      [ move: (fv_tm_tm_tm_open_tm_wrt_tm_lower a (a_Var_f x)) => ?;
        move: (fv_co_co_tm_open_tm_wrt_tm_lower a (a_Var_f x)) => ?;
        fsetdec|
      rewrite h0 in h1;
      simpl in h1;
      fsetdec ]
    end.

  all: try match goal with
      [ IN : ?y `in` ?fv_tm_tm_tm ?a,
        H : ∀ a : atom, a `in` ?fv_tm_tm_tm ?b → a `in` dom ?G,
        e : ∀ x : atom,
            (x `in` ?L → False) →
            ?open_tm_wrt_tm ?a (g_Var_f x) = ?c
       |- _ ] =>
      eapply H; pick fresh x; move: (e x ltac:(auto)) => h0;
      clear Fr;
      have h1: y `in` fv_tm_tm_tm (open_tm_wrt_tm a (g_Var_f x));
      [ move: (fv_tm_tm_tm_open_tm_wrt_co_lower a (g_Var_f x)) => ?;
        move: (fv_co_co_tm_open_tm_wrt_co_lower a (g_Var_f x)) => ?;
        fsetdec|];
      rewrite h0 in h1;
      simpl in h1;
      fsetdec
    end.
Qed.

Definition Typing_context_fv  := first context_fv_mutual.
Definition ProfWff_context_fv := second context_fv_mutual.
Definition Iso_context_fv     := third context_fv_mutual.
Definition DefEq_context_fv   := fourth context_fv_mutual.

(*
Lemma context_fv_mutual2 :
  (forall G0 (b : tm) B H, @tm_context_fv_statement G0 b B H
                                               fv_tm_tm_tm a [<=] dom G /\ fv_tm_tm_tm A [<=] dom G.
  ) /\
    (forall G0 phi H, @PropWff_context_fv_statement G0 phi H) /\
    (forall G0 D p1 p2 H,   @Iso_context_fv_statement G0 D p1 p2 H) /\
    (forall G0 D A B T H,   @DefEq_context_fv_statement G0 D A B T H) /\
    (forall G H, @Ctx_context_fv_statement G H).
Proof.
  repeat split; intros.
  all: try eapply (first context_fv_mutual _ _ _ H); eauto.
  all: try eapply (second context_fv_mutual _ _ H); eauto.
  all: try eapply (third context_fv_mutual _ _ _ _ H); eauto.
  - eapply (first (fourth context_fv_mutual _ _ _ _ _ H)); eauto.
  - eapply (third (fourth context_fv_mutual _ _ _ _ _ H)); eauto.
  - unfold Ctx_context_fv_statement.
    intros x A H0.
    eapply ((fifth context_fv_mutual _ H)); eauto.
Qed.

Definition typing_context_fv := @first _ _ _ _ _ context_fv_mutual2.
Definition ProfWff_context_fv := @second _ _ _ _ _ context_fv_mutual2.
Definition iso_context_fv := @third _ _ _ _ _ context_fv_mutual2.
Definition defeq_context_fv := @fourth _ _ _ _ _ context_fv_mutual2.

Definition tm_context_fv_co_statement G a A (H: Typing G a A) :=
  fv_co_co_tm a [<=] dom G /\ fv_co_co_tm A [<=] dom G.
Definition PropWff_context_fv_co_statement G phi (H : PropWff G phi) :=
  fv_co_co_constraint phi [<=] dom G.
Definition  Iso_context_fv_co_statement G D p1 p2 (H : Iso G D p1 p2) :=
  fv_co_co_constraint p1 [<=] dom G /\
  fv_co_co_constraint p2 [<=] dom G.
Definition DefEq_context_fv_co_statement G D A B T (H : DefEq G D A B T) :=
  fv_co_co_tm A [<=] dom G /\ fv_co_co_tm B [<=] dom G.
Definition Ctx_context_fv_co_statement G (H : Ctx G) := True.

Lemma context_fv_co_mutual :
    (forall G0 (b : tm) B H, @tm_context_fv_co_statement G0 b B H) /\
    (forall G0 phi H, @PropWff_context_fv_co_statement G0 phi H) /\
    (forall G0 D p1 p2 H,   @Iso_context_fv_co_statement G0 D p1 p2 H) /\
    (forall G0 D A B T H,   @DefEq_context_fv_co_statement G0 D A B T H) /\
    (forall G H, @Ctx_context_fv_co_statement G H).
Proof.
  repeat split; intros.
  all: try eapply (first context_fv_mutual _ _ _ H); eauto.
  all: try eapply (second context_fv_mutual _ _ H); eauto.
  all: try eapply (third context_fv_mutual _ _ _ _ H); eauto.
  - eapply (second (fourth context_fv_mutual _ _ _ _ _ H)); eauto.
  - eapply (fourth (fourth context_fv_mutual _ _ _ _ _ H)); eauto.
Qed.

Definition typing_context_fv_co := @first _ _ _ _ _ context_fv_co_mutual.
Definition ProfWff_context_fv_co := @second _ _ _ _ _ context_fv_co_mutual.
Definition iso_context_fv_co := @third _ _ _ _ _ context_fv_co_mutual.
Definition defeq_context_fv_co := @fourth _ _ _ _ _ context_fv_co_mutual.
*)


From Coq Require Import ZArith.ZArith MSets.MSetPositive FSets.FMapPositive
     Strings.String Strings.Ascii Bool.Bool Lists.List Strings.HexString.
From Crypto.Util Require Import
     ListUtil
     Strings.String Strings.Decimal Strings.Show
     ZRange.Operations ZRange.Show
     Option OptionList Bool.Equality.
(* Work around COQBUG(https://github.com/coq/coq/issues/12251) *)
Require Import Crypto.Util.ZRange.

From Crypto Require Import IR Stringification.Language AbstractInterpretation.ZRange.

Import ListNotations.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope zrange_scope.
Local Open Scope Z_scope.

Import IR.Compilers.ToString.
Import Stringification.Language.Compilers.
Import Stringification.Language.Compilers.Options.
Import Stringification.Language.Compilers.ToString.
Import Stringification.Language.Compilers.ToString.int.Notations.

Module JSON.
  Definition indent (indent : string) : list string -> list string
    := List.map (fun s => indent ++ s)%string.

  Definition int_type_to_string (t : ToString.int.type) : string :=
    ((if ToString.int.is_unsigned t then "u" else "i")
       ++ Decimal.Z.to_string (ToString.int.bitwidth_of t))%string.

  Definition primitive_type_to_string (t : IR.type.primitive)
             (r : option ToString.int.type) : string :=
    match t with
    | IR.type.Zptr => "*"
    | IR.type.Z => ""
    end ++ match r with
           | Some int_t => int_type_to_string int_t
           | None => "(auto)"
           end.

  Definition int_literal_to_string (t : IR.type.primitive) (v : BinInt.Z) : string :=
    match t with
    | IR.type.Z => HexString.of_Z v
    | IR.type.Zptr => "#error ""literal address " ++ HexString.of_Z v ++ """;"
    end.

  Import IR.Notations.

  Record op_data :=
    { datatype : string ; name : list string ; operation : string ; arguments : list (list string) }.

  Definition comma_concat (ls : list (list string)) : list string
    := let ret := List.flat_map (fun s => match s with
                                          | [] => []
                                          | _ => s ++ [","]
                                          end) ls in
       (* drop the final , *)
       List.firstn (List.length ret - 1) ret.

  Definition op_data_to_JSON (v : op_data) : list string
    := (["{"
         ; " ""datatype"": """ ++ v.(datatype) ++ ""","
         ; " ""name"": [" ++ String.concat ", " (List.map (fun n => """" ++ n ++ """")%string v.(name)) ++ "],"
         ; " ""operation"": """ ++ v.(operation) ++ ""","
         ; " ""arguments"": ["]%string)
         ++ (indent "  " (comma_concat v.(arguments)))
         ++ [" ]"
             ; "}"].

  Fixpoint arith_to_string (outargs : list string)
           {t} (sz : option ToString.int.type)
           (e : IR.arith_expr t)
    : list (list string)
    := let handle_op sz op outargs inargs
           := [op_data_to_JSON
                 {| datatype := match sz with None => "(auto)" | Some ty => int_type_to_string ty end
                    ; name := outargs
                    ; operation := op
                    ; arguments := inargs |}] in
       let handle_op1 op {t} inargs
           := handle_op sz op outargs (@arith_to_string [] t sz inargs) in
       let wrap_value res
           := match outargs with
              | [] => res
              | _ => handle_op sz "=" outargs res
              end in
       match e with
       (* integer literals *)
       | (IR.literal v @@@ _)
         => wrap_value [ ["""" ++ int_literal_to_string IR.type.Z v ++ """"] ]
       (* array dereference *)
       | (IR.List_nth n @@@ IR.Var _ v)
         => wrap_value [ ["""" ++ v ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "]"""] ]
       (* (de)referencing *)
       | (IR.Addr @@@ IR.Var _ v)
         => wrap_value [ ["""&" ++ v ++ """"] ]
       | (IR.Dereference @@@ IR.Var _ v)
         => wrap_value [ ["""*" ++ v ++ """"] ]
       | (IR.Dereference @@@ e)
         => handle_op sz "dereference" [] (arith_to_string [] sz e)
       (* bitwise operations *)
       | (IR.Z_shiftr offset @@@ e)
         => handle_op sz ">>" outargs
                      ((arith_to_string [] sz e)
                         ++ [ ["""" ++ Decimal.Z.to_string offset ++ """"]%string ])%list
       | (IR.Z_shiftl offset @@@ e)
         => handle_op sz "<<" outargs
                      ((arith_to_string [] sz e)
                         ++ [ ["""" ++ Decimal.Z.to_string offset ++ """"]%string ])%list
       | (IR.Z_land @@@ args)
         => handle_op1 "&" args
       | (IR.Z_lor @@@ args)
         => handle_op1 "|" args
       | (IR.Z_lxor @@@ args)
         => handle_op1 "^" args
       | (IR.Z_lnot _ @@@ args)
         => handle_op1 "~" args
       (* arithmetic operations *)
       | (IR.Z_add @@@ args)
         => handle_op1 "+" args
       | (IR.Z_mul @@@ args)
         => handle_op1 "*" args
       | (IR.Z_sub @@@ args)
         => handle_op1 "-" args
       | (IR.Z_bneg @@@ args)
         => handle_op1 "!" args
       | (IR.Z_mul_split lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz := Some (int.of_bitwidth false lg2s) in
            wrap_value (handle_op sz "mulx" [x1; x2] (arith_to_string [] sz args))
       | (IR.Z_add_with_get_carry lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz := Some (int.of_bitwidth false lg2s) in
            wrap_value (handle_op sz "addcarryx" [x1; x2] (arith_to_string [] sz args))
       | (IR.Z_sub_with_get_borrow lg2s @@@ ((IR.Addr @@@ IR.Var _ x1, IR.Addr @@@ IR.Var _ x2), args))
         => let sz := Some (int.of_bitwidth false lg2s) in
            wrap_value (handle_op sz "subborrowx" [x1; x2] (arith_to_string [] sz args))
       | (IR.Z_value_barrier ty @@@ args) => arith_to_string outargs sz args
       | (IR.Z_zselect ty @@@ (IR.Addr @@@ IR.Var _ v, args))
         => wrap_value (handle_op (Some ty) "cmovznz" [v] (arith_to_string [] (Some ty) args))
       | (IR.Z_static_cast int_t @@@ args)
         => handle_op (Some int_t) "static_cast" outargs (arith_to_string [] (Some int_t) args)
       | IR.Var _ v
         => wrap_value [ [ """" ++ v ++ """" ] ]
       | IR.Pair A B a b
         => wrap_value (arith_to_string [] sz a ++ arith_to_string [] sz b)%list
       | (IR.Z_add_modulo @@@ _)
         => wrap_value [ [ "#error addmodulo" ] ]
       | (IR.List_nth _ @@@ _)
       | (IR.Addr @@@ _)
       | (IR.Z_mul_split _ @@@ _)
       | (IR.Z_add_with_get_carry _ @@@ _)
       | (IR.Z_sub_with_get_borrow _ @@@ _)
       | (IR.Z_zselect _ @@@ _)
         => wrap_value [ [ "#error bad_arg" ] ]
       | IR.TT => wrap_value [ [ "#error tt" ] ]
       end%string%Cexpr.

  Definition stmt_to_string (e : IR.stmt) : list string
    := List.concat
         match e with
         | IR.Call val
           => arith_to_string [] None val
         | IR.Assign _ _ sz name val
           => arith_to_string [name] sz val
         | IR.AssignZPtr name sz val
           => arith_to_string [name] sz val
         | IR.AssignNth name n val
           => let name := (name ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "]")%string in
              arith_to_string [name] None val
         | IR.DeclareVar _ _ _
         | IR.Comment _ _
           => []
         end.

  Definition to_strings (e : IR.expr) : list string :=
    comma_concat (List.map stmt_to_string e).

  Import Rewriter.Language.Language.Compilers Crypto.Language.API.Compilers IR.OfPHOAS.

  Local Notation tZ := (base.type.type_base base.type.Z).
  Local Notation None_object := "null" (only parsing).
  Local Notation quote_string s := ("""" ++ s ++ """")%string (only parsing).

  Fixpoint to_base_arg_list {t} : base_var_data t -> Compilers.ZRange.type.base.option.interp t -> list (string * string * (string * string))
    := let show_Z s := quote_string (Hex.show_Z false s) in
       let opt_to_json T f (b : option T) :=
           match b with
           | None => (None_object, None_object)
           | Some v => f v
           end in
       let zrange_to_json b :=
           (show_Z b.(lower), show_Z b.(upper)) in
       let opt_zrange_to_json b :=
           opt_to_json _ zrange_to_json b in
       let opt_zrange_list_to_json ls :=
           let ls := List.map opt_zrange_to_json ls in
           ("[" ++ String.concat ", " (List.map (@fst _ _) ls) ++ "]",
            "[" ++ String.concat ", " (List.map (@snd _ _) ls) ++ "]")%string in
       let opt_opt_zrange_list_to_json ls :=
           opt_to_json _ opt_zrange_list_to_json ls in
       match t return base_var_data t -> Compilers.ZRange.type.base.option.interp t -> _ with
       | tZ
         => fun '(n, is_ptr, r) b
            => [(primitive_type_to_string IR.type.Z r, n, opt_zrange_to_json b)]
       | base.type.prod A B
         => fun '(va, vb) '(ba, bb) => (@to_base_arg_list A va ba ++ @to_base_arg_list B vb bb)%list
       | base.type.list tZ
         => fun '(n, r, len) b
            => [(primitive_type_to_string IR.type.Z r ++ "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]", n,
                 opt_opt_zrange_list_to_json b)]
       | base.type.list _ => fun _ _ => [("#error ""complex list""", "", (None_object, None_object))]
       | base.type.option _ => fun _ _ => [("#error option", "", (None_object, None_object))]
       | base.type.unit => fun _ _ => [("#error unit", "", (None_object, None_object))]
       | base.type.type_base t => fun _ _ => [("#error " ++ show false t, "", (None_object, None_object))]
       end%string.

  Definition to_arg_list {t} : var_data t -> Compilers.ZRange.type.option.interp t -> list (string * string * (string * string)) :=
    match t return var_data t -> Compilers.ZRange.type.option.interp t -> _ with
    | type.base t => to_base_arg_list
    | type.arrow _ _ => fun _ _ => [("#error arrow", "", (None_object, None_object))]
    end%string.

  Fixpoint to_arg_list_for_each_lhs_of_arrow {t} : type.for_each_lhs_of_arrow var_data t -> type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t -> list (string * string * (string * string))
    := match t return type.for_each_lhs_of_arrow _ t -> type.for_each_lhs_of_arrow _ t -> _ with
       | type.base t => fun _ _ => nil
       | type.arrow s d
         => fun '(x, xs) '(b, bs)
            => to_arg_list x b ++ @to_arg_list_for_each_lhs_of_arrow d xs bs
       end%list.

  (** * Language-specific numeric conversions to be passed to the PHOAS -> IR translation *)

  Definition JSON_bin_op_natural_output
    : IR.Z_binop -> ToString.int.type * ToString.int.type -> ToString.int.type
    := fun idc '(t1, t2)
       => ToString.int.union t1 t2.

  (* Does the binary operation commute with (-- mod 2^bw)? *)
  Definition bin_op_commutes_with_mod_pow2 (idc : IR.Z_binop)
    := match idc with
       | IR.Z_land
       | IR.Z_lor
       | IR.Z_lxor
       | IR.Z_add
       | IR.Z_mul
       | IR.Z_sub
         => true
       end.

  Definition JSON_bin_op_casts
    : IR.Z_binop -> option ToString.int.type -> ToString.int.type * ToString.int.type -> option ToString.int.type * (option ToString.int.type * option ToString.int.type)
    := fun idc desired_type '(t1, t2)
       => match desired_type with
          | Some desired_type
            => let ct := ToString.int.union t1 t2 in
               if bin_op_commutes_with_mod_pow2 idc
               then
                 (* these operations commute with mod, so we just pre-cast them *)
                 (None, (Some desired_type, Some desired_type))
               else
                 let desired_type' := Some (ToString.int.union ct desired_type) in
                 (desired_type',
                  (get_Zcast_up_if_needed desired_type' (Some t1),
                   get_Zcast_up_if_needed desired_type' (Some t2)))
          | None => (None, (None, None))
          end.

  Definition JSON_un_op_casts
    : IR.Z_unop -> option ToString.int.type -> ToString.int.type -> option ToString.int.type * option ToString.int.type
    := fun idc desired_type t
       => match idc with
          | IR.Z_shiftr offset
            => (** N.B. We must cast the expression up to a large
                   enough type to fit 2^offset (importantly, not just
                   2^offset-1), because C considers it to be undefined
                   behavior to shift >= width of the type.  We should
                   probably figure out how to not generate these
                   things in the first place...

                   N.B. We must preserve signedness of the value being
                   shifted, because shift does not commute with
                   mod. *)
            let t' := ToString.int.union_zrange r[0~>2^offset]%zrange t in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type (Some t'),
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed (Some t') (Some t))
          | IR.Z_shiftl offset
            => (** N.B. We must cast the expression up to a large
                   enough type to fit 2^offset (importantly, not just
                   2^offset-1), because C considers it to be undefined
                   behavior to shift >= width of the type.  We should
                   probably figure out how to not generate these
                   things in the first place...

                   N.B. We make sure that we only left-shift unsigned
                   values, since shifting into the sign bit is
                   undefined behavior. *)
            let rpre_out := match desired_type with
                            | Some rout => Some (ToString.int.union_zrange r[0~>2^offset] (ToString.int.unsigned_counterpart_of rout))
                            | None => Some (ToString.int.of_zrange_relaxed r[0~>2^offset]%zrange)
                            end in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type rpre_out,
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed rpre_out (Some t))
          | IR.Z_lnot ty
            => ((* if the result is too big, we cast it down; we
                       don't need to upcast it because it'll get
                       picked up by implicit casts if necessary *)
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_value_barrier ty
            => ((* if the result is too big, we cast it down; we
                       don't need to upcast it because it'll get
                       picked up by implicit casts if necessary *)
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_bneg
            => ((* bneg is !, i.e., takes the argument to 1 if its not zero, and to zero if it is zero; so we don't ever need to cast *)
              None, None)
          end.

  Local Instance JSONLanguageCasts : LanguageCasts :=
    {| bin_op_natural_output := JSON_bin_op_natural_output
       ; bin_op_casts := JSON_bin_op_casts
       ; un_op_casts := JSON_un_op_casts
       ; upcast_on_assignment := true
       ; upcast_on_funcall := true
       ; explicit_pointer_variables := false
    |}.

  Definition to_function_lines (static : bool) (name : string)
             {t}
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
             (f : type.for_each_lhs_of_arrow var_data t * var_data (type.base (type.final_codomain t)) * IR.expr)
    : list string :=
    let '(args, rets, body) := f in
    let args_list_to_string ls
        := ("["
              ++ (String.concat
                    ", "
                    (List.map
                       (fun '(typ, name, (lbound, ubound)) => "{""datatype"": """ ++ typ ++ """, ""name"": """ ++ name ++ """, ""lbound"": " ++ lbound ++ ", ""ubound"": " ++ ubound ++ "}")
                       ls))
              ++ "]")%string in
    ["{"]
      ++ (["""operation"": """ ++ name ++ ""","
           ; """arguments"": " ++ args_list_to_string (to_arg_list_for_each_lhs_of_arrow args inbounds) ++ ","
           ; """returns"": " ++ args_list_to_string (to_arg_list rets outbounds) ++ ","
           ; """body"": ["]%string)
      ++ to_strings body
      ++ ["]"
          ; "}"].

  (** We will treat all dead variables as _ *)
  Local Instance : consider_retargs_live_opt := fun _ _ _ => false.
  Local Instance : rename_dead_opt := fun s => "_".
  (** No need to lift declarations to the top *)
  Local Instance : lift_declarations_opt := false.

  Definition ToFunctionLines
             {relax_zrange : relax_zrange_opt}
             {language_naming_conventions : language_naming_conventions_opt}
             (machine_wordsize : Z)
             (do_bounds_check : bool) (internal_static : bool) (static : bool) (prefix : string) (name : string)
             {t}
             (e : API.Expr t)
             (comment : type.for_each_lhs_of_arrow var_data t -> var_data (type.base (type.final_codomain t)) -> list string)
             (name_list : option (list string))
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
    : (list string * ToString.ident_infos) + string :=
    match ExprOfPHOAS do_bounds_check e name_list inbounds with
    | inl (indata, outdata, f) =>
      inl (to_function_lines
             static name
             inbounds
             outbounds
             (indata, outdata, f),
           IR.ident_infos.collect_infos f)
    | inr nil =>
      inr ("Unknown internal error in converting " ++ name ++ " to JSON")%string
    | inr [err] =>
      inr ("Error in converting " ++ name ++ " to JSON:" ++ String.NewLine ++ err)%string
    | inr errs =>
      inr ("Errors in converting " ++ name ++ " to JSON:" ++ String.NewLine ++ String.concat String.NewLine errs)%string
    end.

  Definition OutputJSONAPI : ToString.OutputLanguageAPI :=
    {| ToString.comment_block _ := [];
       ToString.comment_file_header_block _ := [];
       ToString.ToFunctionLines := @ToFunctionLines;
       ToString.header := fun _ _ _ _ _ _ _ _ => [];
       ToString.footer := fun _ _ _ _ _ _ _ _ => [];
       (** No special handling for any functions *)
       ToString.strip_special_infos machine_wordsize infos := infos |}.

End JSON.


(** Used to trigger an anomaly with VM compilation *)

Set Universe Polymorphism.

Inductive t A : nat -> Type :=
| nil : t A 0
| cons : forall (h : A) (n : nat), t A n -> t A (S n).

Definition case0 {A} (P : t A 0 -> Type) (H : P (nil A)) v : P v :=
match v with
| nil _ => H
| _ => fun devil => False_ind (@IDProp) devil
end.