(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect ssrbool.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
  PCUICReduction
  PCUICClosed PCUICTyping PCUICWcbvEval PCUICLiftSubst PCUICInversion PCUICArities
  PCUICSR PCUICGeneration PCUICSubstitution PCUICElimination
  PCUICWeakeningEnv PCUICWeakeningEnvTyp
  PCUICWellScopedCumulativity
  PCUICContextConversion PCUICConversion PCUICCanonicity
  PCUICSpine PCUICInductives PCUICInductiveInversion PCUICConfluence
  PCUICArities PCUICPrincipality.

From MetaCoq.Erasure Require Import Extract.

Notation "Σ ⊢p s ▷ t" := (eval Σ s t) (at level 50, s, t at next level) : type_scope.

Require Import Program.
From Equations Require Import Equations.

Local Existing Instance extraction_checker_flags.

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

(* TODO move *)
#[global] Existing Instance extends_refl.

Lemma isErasable_Proof Σ Γ t :
  Is_proof Σ Γ t -> isErasable Σ Γ t.
Proof.
  intros. destruct X as (? & ? & ? & ? & ?). exists x. split. eauto. right.
  eauto.
Qed.

Lemma isType_isErasable Σ Γ T : isType Σ Γ T -> isErasable Σ Γ T.
Proof.
  intros [s Hs].
  exists (tSort s). intuition auto. left; simpl; auto.
Qed.

Lemma isType_red:
  forall (Σ : global_env_ext) (Γ : context) (T : term), wf Σ -> wf_local Σ Γ ->
    isType Σ Γ T -> forall x5 : term, red Σ Γ T x5 -> isType Σ Γ x5.
Proof.
  intros. destruct X1 as [].
  eexists. eapply subject_reduction ; eauto.
Qed.

Lemma it_mkProd_isArity:
  forall (l : list context_decl) A,
    isArity A ->
    isArity (it_mkProd_or_LetIn l A).
Proof.
  induction l; cbn; intros; eauto.
  eapply IHl. destruct a, decl_body; cbn; eauto.
Qed.

Lemma isArity_ind_type (Σ : global_env_ext) mind ind idecl :
  wf Σ ->
  declared_inductive (fst Σ) ind mind idecl ->
  isArity (ind_type idecl).
Proof.
  intros.
  eapply (declared_inductive_inv weaken_env_prop_typing) in H; eauto.
  - inv H. rewrite ind_arity_eq.
    change PCUICEnvironment.it_mkProd_or_LetIn with it_mkProd_or_LetIn.
    rewrite <- it_mkProd_or_LetIn_app.
    clear.
    eapply it_mkProd_isArity. econstructor.
Qed.

Lemma isWfArity_prod_inv (Σ : global_env_ext) (Γ : context) (x : aname) (x0 x1 : term) :
    wf Σ ->
    isWfArity Σ Γ (tProd x x0 x1) -> (isType Σ Γ x0 × isWfArity Σ (Γ,, vass x x0) x1).
Proof.
  intros wfΣ (? & ? & ? & ?). cbn in e.
  eapply isType_tProd in i as [dom codom]; auto.
  split; auto.
  split; auto.
  clear dom codom.
  eapply destArity_app_Some in e as (? & ? & ?); subst.
  eexists. eexists; eauto.
Qed.

Lemma inds_nth_error ind u l n t :
  nth_error (inds ind u l) n = Some t -> exists n, t = tInd {| inductive_mind := ind ; inductive_ind := n |} u.
Proof.
  unfold inds in *. generalize (#|l|). clear. revert t.
  induction n; intros.
  - destruct n. cbn in H. congruence. cbn in H. inv H.
    eauto.
  - destruct n0. cbn in H. congruence. cbn in H.
    eapply IHn. eauto.
Qed.

Lemma it_mkProd_arity :
  forall (l : list context_decl) (A : term), isArity (it_mkProd_or_LetIn l A) -> isArity A.
Proof.
  induction l; cbn; intros.
  - eauto.
  - eapply IHl in H. destruct a, decl_body; cbn in *; eauto.
Qed.

Lemma isArity_mkApps t L : isArity (mkApps t L) -> isArity t /\ L = [].
Proof.
  revert t; induction L; cbn; intros.
  - eauto.
  - eapply IHL in H. cbn in H. tauto.
Qed.

Lemma typing_spine_red (Σ : global_env_ext) Γ (args args' : list PCUICAst.term)
  (X : All2 (red Σ Γ) args args') (wfΣ : wf Σ)
  (T x x0 : PCUICAst.term)
  (t0 : typing_spine Σ Γ x args x0)
  (c : Σ;;; Γ ⊢ x0 ≤ T) x1
  (c0 : Σ;;; Γ ⊢ x1 ≤ x) :
  isType Σ Γ x1 ->
  isType Σ Γ T ->
  typing_spine Σ Γ x1 args' T.
Proof.
  intros ? ?. revert args' X.
  dependent induction t0; intros.
  - inv X. econstructor; eauto. transitivity ty => //.
    now transitivity ty'.
  - inv X. econstructor; tea.
    + transitivity ty => //.
    + eapply subject_reduction; eauto.
    + eapply IHt0; eauto.
      eapply red_ws_cumul_pb_inv.
      unfold subst1.
      eapply isType_tProd in i0 as [dom codom].
      eapply (closed_red_red_subst (Δ := [vass na A]) (Γ' := [])); auto.
      simpl. eapply isType_wf_local in codom. fvs.
      constructor; auto. eapply into_closed_red; auto. fvs. fvs.
      repeat constructor. eapply isType_is_open_term in codom; fvs.
      eapply isType_apply in i0; tea.
      eapply subject_reduction; tea.
Qed.

Lemma it_mkProd_red_Arity {Σ : global_env_ext} {Γ c0 i u l} {wfΣ : wf Σ} :
  ~ Is_conv_to_Arity Σ Γ (it_mkProd_or_LetIn c0 (mkApps (tInd i u) l)).
Proof.
  intros (? & [] & ?). eapply red_it_mkProd_or_LetIn_mkApps_Ind in X as (? & ? & ?). subst.
  eapply it_mkProd_arity in H. eapply isArity_mkApps in H as [[] ].
Qed.

Lemma invert_it_Ind_eq_prod:
  forall (u : Instance.t) (i : inductive) (x : aname) (x0 x1 : term) (x2 : context) (x3 : list term),
    tProd x x0 x1 = it_mkProd_or_LetIn x2 (mkApps (tInd i u) x3) -> exists (L' : context) (l' : list term), x1 = it_mkProd_or_LetIn L' (mkApps (tInd i u) l').
Proof.
  intros u i x x0 x1 x2 x3 H0.
  revert x0 x3 x1 x H0. induction x2 using rev_ind; intros.
  - cbn. assert (decompose_app (tProd x x0 x1) = decompose_app (mkApps (tInd i u) x3)) by now rewrite H0.
    rewrite decompose_app_mkApps in H; cbn; eauto. cbn in H. inv H.
  - rewrite it_mkProd_or_LetIn_app in H0. cbn in *.
    destruct x, decl_body; cbn in H0; try now inv H0.
Qed.

(* if a constructor is a type or proof, it is a proof *)

Lemma declared_constructor_type_not_arity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ind n mdecl idecl cdecl u} :
  declared_constructor Σ (ind, n) mdecl idecl cdecl ->
  ~ Is_conv_to_Arity Σ Γ (type_of_constructor mdecl cdecl (ind, n) u).
Proof.
  intros decl; sq.
  unfold type_of_constructor.
  destruct (on_declared_constructor decl) as [XX [s [XX1 Ht]]].
  rewrite (cstr_eq Ht). clear -wfΣ decl.
  rewrite !PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn.
  rewrite /cstr_concl.
  rewrite /cstr_concl_head. len.
  rewrite subst_cstr_concl_head.
  destruct decl as [[] ?]. now eapply nth_error_Some_length in H0.
  rewrite -it_mkProd_or_LetIn_app.
  now eapply it_mkProd_red_Arity.
Qed.

Lemma conv_to_arity_cumul {Σ : global_env_ext} {wfΣ : wf Σ} :
  forall (Γ : context) (C : term) T,
    Is_conv_to_Arity Σ Γ T ->
    Σ;;; Γ ⊢ C ≤ T ->
    Is_conv_to_Arity Σ Γ C.
Proof.
  intros Γ C T [? []] cum. sq.
  eapply invert_cumul_arity_r_gen; tea.
  exists x. split; auto. now sq.
Qed.

Lemma typing_spine_mkApps_Ind_ex {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ ind u args args' T' :
  typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd ind u) args)) args' T' ->
  ∑ Δ' args', Σ ;;; Γ ⊢ it_mkProd_or_LetIn Δ' (mkApps (tInd ind u) args') ≤ T'.
Proof.
  induction Δ in args, args' |- * using PCUICInduction.ctx_length_rev_ind.
  - simpl. intros sp.
    dependent elimination sp as [spnil i i' e|spcons i i' e e' c].
    * now exists [], args.
    * now eapply invert_cumul_ind_prod in e.
  - rewrite it_mkProd_or_LetIn_app /=; destruct d as [na [b|] ty].
    * rewrite /mkProd_or_LetIn /=. simpl => /= sp.
      eapply typing_spine_letin_inv in sp; eauto.
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r subst_mkApps /= in sp.
      apply (X (subst_context [b] 0 Γ0) ltac:(now len) _ _ sp).
    * rewrite /mkProd_or_LetIn /=. simpl => /= sp.
      simpl.
      dependent elimination sp as [spnil i i' e|spcons i i' e e' sp].
      { exists (Γ0 ++ [vass na ty]).
        exists args. now rewrite it_mkProd_or_LetIn_app. }
      eapply ws_cumul_pb_Prod_Prod_inv in e as [eqna dom codom]; pcuic.
      eapply (substitution0_ws_cumul_pb (t:=hd0)) in codom; eauto.
      eapply typing_spine_strengthen in sp. 3:tea.
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r subst_mkApps /= in sp.
      apply (X (subst_context [hd0] 0 Γ0) ltac:(len; reflexivity) _ _ sp).
      eapply isType_apply in i; tea.
      eapply (type_ws_cumul_pb (pb:=Conv)); tea. 2:now symmetry.
      now eapply isType_tProd in i as [].
Qed.

Lemma typing_spine_Is_conv_to_Arity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ ind u args args' T'} :
  typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd ind u) args)) args' T' ->
  ~ Is_conv_to_Arity Σ Γ T'.
Proof.
  move/typing_spine_mkApps_Ind_ex => [Δ' [args'' cum]].
  intros iscv.
  eapply invert_cumul_arity_r_gen in iscv; tea.
  now eapply it_mkProd_red_Arity in iscv.
Qed.

Lemma declared_constructor_typing_spine_not_arity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ind n mdecl idecl cdecl u args' T'} :
  declared_constructor Σ (ind, n) mdecl idecl cdecl ->
  typing_spine Σ Γ (type_of_constructor mdecl cdecl (ind, n) u) args' T' ->
  ~ Is_conv_to_Arity Σ Γ T'.
Proof.
  intros decl; sq.
  unfold type_of_constructor.
  destruct (on_declared_constructor decl) as [XX [s [XX1 Ht]]].
  rewrite (cstr_eq Ht). clear -wfΣ decl.
  rewrite !PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn !subst_it_mkProd_or_LetIn.
  rewrite /cstr_concl.
  rewrite /cstr_concl_head. len.
  rewrite subst_cstr_concl_head.
  destruct decl as [[] ?]. now eapply nth_error_Some_length in H0.
  rewrite -it_mkProd_or_LetIn_app.
  apply typing_spine_Is_conv_to_Arity.
Qed.

Lemma type_mkApps_tConstruct_n_conv_arity (Σ : global_env_ext) Γ ind c u x1 T : wf Σ ->
  Σ ;;; Γ |- mkApps (tConstruct ind c u) x1 : T ->
  ~ Is_conv_to_Arity Σ Γ T.
Proof.
  intros.
  eapply PCUICValidity.inversion_mkApps in X0 as (? & ? & ?); eauto.
  eapply inversion_Construct in t as (? & ? & ? & ? & ? & ? & ?) ; auto.
  eapply typing_spine_strengthen in t0. 3:tea.
  eapply declared_constructor_typing_spine_not_arity in t0; tea.
  eapply PCUICValidity.validity. econstructor; eauto.
Qed.

Lemma nIs_conv_to_Arity_nArity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} :
  isType Σ Γ T ->
  ~ Is_conv_to_Arity Σ Γ T -> ~ isArity T.
Proof.
  intros isty nisc isa. apply nisc.
  exists T. split => //. sq.
  destruct isty as [s Hs].
  eapply wt_closed_red_refl; tea.
Qed.

Lemma tConstruct_no_Type (Σ : global_env_ext) Γ ind c u x1 : wf Σ ->
  isErasable Σ Γ (mkApps (tConstruct ind c u) x1) ->
  Is_proof Σ Γ (mkApps (tConstruct ind c u) x1).
Proof.
  intros wfΣ (? & ? & [ | (? & ? & ?)]).
  - exfalso.
    eapply nIs_conv_to_Arity_nArity; tea.
    eapply PCUICValidity.validity; tea.
    eapply type_mkApps_tConstruct_n_conv_arity in t; auto.
  - exists x, x0. eauto.
Qed.

(* if a cofixpoint is a type or proof, it is a proof *)

Lemma tCoFix_no_Type (Σ : global_env_ext) Γ mfix idx x1 : wf Σ ->
  isErasable Σ Γ (mkApps (tCoFix mfix idx) x1) ->
  Is_proof Σ Γ (mkApps (tCoFix mfix idx) x1).
Proof.
  intros wfΣ (? & ? & [ | (? & ? & ?)]).
  - exfalso.
    eapply PCUICValidity.inversion_mkApps in t as (? & ? & ?); eauto.
    pose proof (typing_spine_isType_codom t0).
    assert(c0 : Σ ;;; Γ ⊢ x ≤ x) by now eapply (isType_ws_cumul_pb_refl).
    revert c0 t0 i. generalize x at 1 3.
    intros x2 c0 t0 i.
    assert (HWF : isType Σ Γ x2).
    { eapply PCUICValidity.validity.
      eapply type_mkApps. 2:eauto. eauto.
    }
    eapply inversion_CoFix in t as (? & ? & ? & ? & ? & ? & ?) ; auto.
    eapply invert_cumul_arity_r in c0; eauto.
    eapply typing_spine_strengthen in t0. 3:eauto.
    eapply wf_cofixpoint_spine in i0; eauto.
    2-3:eapply nth_error_all in a; eauto; simpl in a; eauto.
    destruct i0 as (Γ' & T & DA & ind & u & indargs & (eqT & ck) & cum).
    destruct (Nat.ltb #|x1| (context_assumptions Γ')).
    eapply invert_cumul_arity_r_gen in c0; eauto.
    destruct c0. destruct H as [[r] isA].
    move: r; rewrite subst_it_mkProd_or_LetIn eqT; autorewrite with len.
    rewrite PCUICSigmaCalculus.expand_lets_mkApps subst_mkApps /=.
    move/red_it_mkProd_or_LetIn_mkApps_Ind => [ctx' [args' eq]].
    subst x4. now eapply it_mkProd_arity, isArity_mkApps in isA.
    move: cum => [] Hx1; rewrite eqT PCUICSigmaCalculus.expand_lets_mkApps subst_mkApps /= => cum.
    eapply invert_cumul_arity_r_gen in c0; eauto.
    now eapply Is_conv_to_Arity_ind in c0.
  - eexists _, _; intuition eauto.
Qed.

Lemma typing_spine_wat (Σ : global_env_ext) (Γ : context) (L : list term)
  (x x0 : term) :
    wf Σ ->
    typing_spine Σ Γ x L x0 ->
    isType Σ Γ x0.
Proof.
  intros wfΣ; induction 1; auto.
Qed.

Section Elim'.

Context `{cf : checker_flags}.
Context {Σ : global_env_ext} {wfΣ : wf_ext Σ}.
Variable Hcf : prop_sub_type = false.
Variable Hcf' : check_univs.

Lemma cumul_prop1 Γ A B u :
  Universe.is_prop u ->
  isType Σ Γ A ->
  Σ ;;; Γ |- B : tSort u ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u.
Proof using Hcf Hcf' wfΣ.
  intros; eapply cumul_prop1; tea.
  now apply ws_cumul_pb_forget in X1.
Qed.

Lemma cumul_prop2 Γ A B u :
  Universe.is_prop u ->
  isType Σ Γ B ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u ->
  Σ ;;; Γ |- B : tSort u.
Proof using Hcf Hcf' wfΣ.
  intros. eapply cumul_prop2; tea.
  now apply ws_cumul_pb_forget in X0.
Qed.

Lemma cumul_sprop1 Γ A B u :
  Universe.is_sprop u ->
  isType Σ Γ A ->
  Σ ;;; Γ |- B : tSort u ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u.
Proof using Hcf Hcf' wfΣ.
  intros. eapply cumul_sprop1; tea.
  now apply ws_cumul_pb_forget in X1.
Qed.

Lemma cumul_sprop2 Γ A B u :
  Universe.is_sprop u ->
  isType Σ Γ B ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u ->
  Σ ;;; Γ |- B : tSort u.
Proof using Hcf Hcf' wfΣ.
  intros. eapply cumul_sprop2; tea.
  now apply ws_cumul_pb_forget in X0.
Qed.
End Elim'.

Lemma cumul_propositional (Σ : global_env_ext) Γ A B u :
  wf_ext Σ ->
  is_propositional u ->
  isType Σ Γ B ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u ->
  Σ ;;; Γ |- B : tSort u.
Proof.
  intros wf.
  destruct u => //.
  intros _ [s Hs] cum Ha.
  eapply cumul_prop2; eauto. now exists s.
  intros _ [s Hs] cum Ha.
  eapply cumul_sprop2; eauto. now exists s.
Qed.

Lemma sort_typing_spine:
  forall (Σ : global_env_ext) (Γ : context) (L : list term) (u : Universe.t) (x x0 : term),
    wf_ext Σ ->
    is_propositional u ->
    typing_spine Σ Γ x L x0 ->
    Σ;;; Γ |- x : tSort u ->
    ∑ u', Σ;;; Γ |- x0 : tSort u' × is_propositional u'.
Proof.
  intros Σ Γ L u x x0 HΣ ? t1 c0.
  assert (X : wf Σ) by apply HΣ.
  revert u H c0.
  induction t1; intros.
  - destruct u => //. eapply cumul_prop2 in c0; eauto.
    eapply cumul_sprop2 in c0; eauto.
  - eapply cumul_propositional in c0; auto. 2-3: tea.
    eapply inversion_Prod in c0 as (? & ? & ? & ? & e0) ; auto.
    eapply ws_cumul_pb_Sort_inv in e0.
    unfold is_propositional in H.
    destruct (Universe.is_prop u) eqn:isp => //.
    eapply leq_universe_prop_r in e0 as H0; cbn; eauto.
    eapply is_prop_sort_prod in H0. eapply IHt1; [unfold is_propositional; now rewrite -> H0|].
    change (tSort x0) with ((tSort x0) {0 := hd}).
    eapply substitution0; eauto.
    eapply leq_universe_sprop_r in e0 as H0; cbn; eauto.
    eapply is_sprop_sort_prod in H0. eapply IHt1; [unfold is_propositional; now rewrite -> H0, orb_true_r|].
    change (tSort x0) with ((tSort x0) {0 := hd}).
    eapply substitution0; eauto.
Qed.

Lemma arity_type_inv (Σ : global_env_ext) Γ t T1 T2 : wf_ext Σ -> wf_local Σ Γ ->
  Σ ;;; Γ |- t : T1 -> isArity T1 -> Σ ;;; Γ |- t : T2 -> Is_conv_to_Arity Σ Γ T2.
Proof.
  intros wfΣ wfΓ. intros.
  destruct (common_typing _ _ X X0) as (? & e & ? & ?).
  eapply invert_cumul_arity_l_gen; tea.
  eapply invert_cumul_arity_r_gen. 2:exact e.
  exists T1. split; auto. sq.
  eapply PCUICValidity.validity in X as [s Hs].
  eapply wt_closed_red_refl; eauto.
Qed.

Lemma cumul_prop1' (Σ : global_env_ext) Γ A B u :
  check_univs ->
  wf_ext Σ ->
  isType Σ Γ A ->
  is_propositional u ->
  Σ ;;; Γ |- B : tSort u ->
  Σ ;;; Γ ⊢ A ≤ B ->
  Σ ;;; Γ |- A : tSort u.
Proof.
  intros.
  destruct X0 as [s Hs].
  destruct u => //.
  eapply cumul_prop1 in X2; eauto. now exists s.
  eapply cumul_sprop1 in X2; eauto. now exists s.
Qed.

Lemma cumul_prop2' (Σ : global_env_ext) Γ A B u :
  check_univs ->
  wf_ext Σ ->
  isType Σ Γ A ->
  is_propositional u ->
  Σ ;;; Γ |- B : tSort u ->
  Σ ;;; Γ ⊢ B ≤ A ->
  Σ ;;; Γ |- A : tSort u.
Proof.
  intros.
  destruct X0 as [s Hs].
  destruct u => //.
  eapply cumul_prop2 in X2; eauto. now exists s.
  eapply cumul_sprop2 in X2; eauto. now exists s.
Qed.

Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} :
  wf_ext Σ ->
  PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' ->
  Σ;;; Γ |- v : tSort u ->
  Σ;;; Γ |- v' : tSort u' -> is_propositional u ->
  leq_universe (global_ext_constraints Σ) u' u.
Proof.
  intros wf leq Hv Hv' isp.
  unfold is_propositional in isp.
  destruct u => //.
  eapply leq_term_prop_sorted_l; eauto.
  eapply leq_term_sprop_sorted_l; eauto.
Qed.

Lemma leq_term_propopositional_sorted_r {Σ Γ v v' u u'} :
  wf_ext Σ ->
  PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' ->
  Σ;;; Γ |- v : tSort u ->
  Σ;;; Γ |- v' : tSort u' -> is_propositional u' ->
  leq_universe (global_ext_constraints Σ) u u'.
Proof.
  intros wfΣ leq hv hv' isp.
  unfold is_propositional in isp.
  destruct u' => //.
  eapply leq_term_prop_sorted_r; eauto.
  eapply leq_term_sprop_sorted_r; eauto.
Qed.

Lemma Is_type_app (Σ : global_env_ext) Γ t L T :
  wf_ext Σ ->
  wf_local Σ Γ ->
  Σ ;;; Γ |- mkApps t L : T ->
  isErasable Σ Γ t ->
  ∥isErasable Σ Γ (mkApps t L)∥.
Proof.
  intros wfΣ wfΓ ? ?.
  assert (HW : isType Σ Γ T). eapply PCUICValidity.validity; eauto.
  eapply PCUICValidity.inversion_mkApps in X as (? & ? & ?); auto.
  destruct X0 as (? & ? & [ | [u]]).
  - eapply common_typing in t2 as (? & e & e0 & ?). 2:eauto. 2:exact t0.
    eapply invert_cumul_arity_r in e0; eauto.
    destruct e0 as (? & ? & ?). destruct H as [].
    eapply ws_cumul_pb_red_l_inv in e. 2:exact X.
    eapply type_reduction_closed in t2; tea.
    eapply typing_spine_strengthen in t1. 3:tea.
    unshelve epose proof (isArity_typing_spine wfΓ t1).
    2:{ eapply PCUICValidity.validity in t2; tea; pcuic. }
    forward H. eapply arity_type_inv; tea.
    destruct H as [T' [[]]].
    sq. exists T'. split. eapply type_mkApps; tea.
    eapply typing_spine_weaken_concl; tea.
    now eapply red_conv.
    eapply isType_red; tea; pcuic. exact X0.
    now left.
  - destruct p.
    eapply PCUICPrincipality.common_typing in t2 as (? & e & e0 & ?). 2:eauto. 2:exact t0.
    eapply cumul_prop1' in e0; eauto.
    eapply cumul_propositional in e; eauto.
    econstructor. exists T. split. eapply type_mkApps. 2:eassumption. eassumption. right.
    eapply sort_typing_spine in t1; eauto.
    now eapply PCUICValidity.validity in t0.
    now apply PCUICValidity.validity in t2.
Qed.

Lemma leq_universe_propositional_r {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : Universe.t_) :
  check_univs ->
  consistent ϕ ->
  leq_universe ϕ u1 u2 -> is_propositional u2 -> is_propositional u1.
Proof.
  intros cu cons leq; unfold is_propositional.
  destruct u2 => //.
  apply leq_universe_prop_r in leq => //.
  now rewrite leq.
  intros _.
  apply leq_universe_sprop_r in leq => //.
  now rewrite leq orb_true_r.
Qed.

Lemma leq_universe_propositional_l {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : Universe.t_) :
  check_univs ->
  prop_sub_type = false ->
  consistent ϕ ->
  leq_universe ϕ u1 u2 -> is_propositional u1 -> is_propositional u2.
Proof.
  intros cu ps cons leq; unfold is_propositional.
  destruct u1 => //.
  eapply leq_universe_prop_no_prop_sub_type in leq => //.
  now rewrite leq.
  intros _.
  apply leq_universe_sprop_l in leq => //.
  now rewrite leq orb_true_r.
Qed.

Lemma is_propositional_sort_prod x2 x3 :
  is_propositional (Universe.sort_of_product x2 x3) -> is_propositional x3.
Proof.
  unfold is_propositional.
  destruct (Universe.is_prop (Universe.sort_of_product x2 x3)) eqn:eq => //.
  simpl.
  intros _.
  apply is_prop_sort_prod in eq. now rewrite eq.
  destruct (Universe.is_sprop (Universe.sort_of_product x2 x3)) eqn:eq' => //.
  apply is_sprop_sort_prod in eq'. now rewrite eq' !orb_true_r.
Qed.

Lemma Is_type_lambda (Σ : global_env_ext) Γ na T1 t :
  wf_ext Σ ->
  wf_local Σ Γ ->
  isErasable Σ Γ (tLambda na T1 t) ->
  ∥isErasable Σ (vass na T1 :: Γ) t∥.
Proof.
  intros ? ? (T & ? & ?).
  eapply inversion_Lambda in t0 as (? & ? & ? & ? & e); auto.
  destruct s as [ | (u & ? & ?)].
  - eapply invert_cumul_arity_r in e; eauto. destruct e as (? & [] & ?).
    eapply invert_red_prod in X1 as (? & ? & []); eauto; subst. cbn in H.
    econstructor. exists x3. econstructor.
    eapply type_reduction_closed; eauto. econstructor; eauto.
  - sq. eapply cumul_prop1' in e; eauto.
    eapply inversion_Prod in e as (? & ? & ? & ? & e) ; auto.
    eapply ws_cumul_pb_Sort_inv in e.
    eapply leq_universe_propositional_r in e as H0; cbn; eauto.
    eexists. split. eassumption. right. eexists. split. eassumption.
    eapply is_propositional_sort_prod in H0; eauto.
    eapply type_Lambda in t1; eauto.
    now apply PCUICValidity.validity in t1.
Qed.

Lemma Is_type_red (Σ : global_env_ext) Γ t v:
  wf Σ ->
  red Σ Γ t v ->
  isErasable Σ Γ t ->
  isErasable Σ Γ v.
Proof.
  intros ? ? (T & ? & ?).
  exists T. split.
  - eapply subject_reduction; eauto.
  - eauto.
Qed.

Lemma Is_type_eval (Σ : global_env_ext) t v:
  wf Σ ->
  eval Σ t v ->
  isErasable Σ [] t ->
  isErasable Σ [] v.
Proof.
  intros; eapply Is_type_red. eauto.
  red in X1. destruct X1 as [T [HT _]].
  eapply wcbeval_red; eauto. assumption.
Qed.

(* Thanks to the restriction to Prop </= Type, erasability is also closed by expansion
  on well-typed terms. *)

Lemma Is_type_eval_inv (Σ : global_env_ext) t v:
  wf_ext Σ ->
  welltyped Σ [] t ->
  PCUICWcbvEval.eval Σ t v ->
  isErasable Σ [] v ->
  ∥ isErasable Σ [] t ∥.
Proof.
  intros wfΣ [T HT] ev [vt [Ht Hp]].
  eapply wcbeval_red in ev; eauto.
  pose proof (subject_reduction _ _ _ _ _ wfΣ.1 HT ev).
  pose proof (common_typing _ wfΣ Ht X) as [P [Pvt [Pt vP]]].
  destruct Hp.
  eapply arity_type_inv in X. 5:eauto. all:eauto.
  red in X. destruct X as [T' [[red] isA]].
  eapply type_reduction_closed in HT; eauto.
  sq. exists T'; intuition auto.
  sq. exists T. intuition auto. right.
  destruct s as [u [vtu isp]].
  exists u; intuition auto.
  eapply cumul_propositional; eauto. now eapply PCUICValidity.validity in HT.
  eapply cumul_prop1'; eauto. now eapply PCUICValidity.validity in vP.
Qed.

Lemma isType_closed_red_refl {Σ} {wfΣ : wf Σ} {Γ T} :
  isType Σ Γ T -> Σ ;;; Γ ⊢ T ⇝ T.
Proof.
  intros [s hs]; eapply wt_closed_red_refl; tea.
Qed.

Lemma nIs_conv_to_Arity_isWfArity_elim {Σ} {wfΣ : wf Σ} {Γ x} :
  ~ Is_conv_to_Arity Σ Γ x ->
  isWfArity Σ Γ x ->
  False.
Proof.
  intros nis [isTy [ctx [s da]]]. apply nis.
  red. exists (it_mkProd_or_LetIn ctx (tSort s)).
  split. sq. apply destArity_spec_Some in da.
  simpl in da. subst x.
  eapply isType_closed_red_refl; pcuic.
  now eapply it_mkProd_isArity.
Qed.

Definition isErasable_Type (Σ : global_env_ext) Γ T :=
  (Is_conv_to_Arity Σ Γ T +
    (∑ u : Universe.t, Σ;;; Γ |- T : tSort u × is_propositional u))%type.

Lemma isErasable_any_type {Σ} {wfΣ : wf_ext Σ} {Γ t T} :
  isErasable Σ Γ t ->
  Σ ;;; Γ |- t : T ->
  isErasable_Type Σ Γ T.
Proof.
  intros [T' [Ht Ha]].
  intros HT.
  destruct (PCUICPrincipality.common_typing _ wfΣ Ht HT) as [P [le [le' tC]]]. sq.
  destruct Ha.
  left. eapply arity_type_inv. 3:exact Ht. all:eauto using typing_wf_local.
  destruct s as [u [Hu isp]].
  right.
  exists u; split; auto.
  eapply cumul_propositional; eauto. eapply PCUICValidity.validity; eauto.
  eapply cumul_prop1'; eauto. eapply PCUICValidity.validity; eauto.
Qed.

Lemma Is_proof_ty Σ Γ t :
  wf_ext Σ ->
  Is_proof Σ Γ t ->
  forall t' ty,
  Σ ;;; Γ |- t : ty ->
  Σ ;;; Γ |- t' : ty ->
  Is_proof Σ Γ t'.
Proof.
  intros wfΣ [ty [u [Hty isp]]].
  intros t' ty' Hty'.
  epose proof (PCUICPrincipality.common_typing _ wfΣ Hty Hty') as [C [Cty [Cty' Ht'']]].
  intros Ht'.
  exists ty', u; intuition auto.
  eapply PCUICValidity.validity in Hty; eauto.
  eapply PCUICValidity.validity in Hty'; eauto.
  eapply PCUICValidity.validity in Ht''; eauto.
  eapply cumul_prop1' in Cty; eauto.
  eapply cumul_propositional in Cty'; eauto.
Qed.

Lemma is_propositional_bottom {Σ Γ T s s'} :
  wf_ext Σ ->
  check_univs ->
  prop_sub_type = false ->
  Σ ;;; Γ ⊢ T ≤ tSort s ->
  Σ ;;; Γ ⊢ T ≤ tSort s' ->
  PCUICCumulProp.eq_univ_prop s s'.
Proof.
  intros wf cu pst h h'; rewrite /PCUICCumulProp.eq_univ_prop.
  split. split; eapply PCUICCumulProp.is_prop_bottom; tea.
  split; eapply PCUICCumulProp.is_sprop_bottom; tea.
Qed.

Import PCUICGlobalEnv PCUICUnivSubst PCUICValidity PCUICCumulProp.

Notation " Σ ;;; Γ |- t ~~ u " := (cumul_prop Σ Γ t u)  (at level 50, Γ, t, u at next level) : type_scope.

Lemma is_propositional_bottom' {Σ Γ T s s'} :
  wf_ext Σ ->
  check_univs ->
  prop_sub_type = false ->
  Σ ;;; Γ |- T ~~ tSort s ->
  Σ ;;; Γ |- T ~~ tSort s' ->
  PCUICCumulProp.eq_univ_prop s s'.
Proof.
  intros wf cu pst h h'; rewrite /PCUICCumulProp.eq_univ_prop.
  pose proof (cumul_prop_trans _ _ _ _ _ _ (cumul_prop_sym _ _ _ _ _ h') h).
  split. split; intros; eapply PCUICCumulProp.cumul_prop_props; tea. now symmetry.
  split; intros; eapply PCUICCumulProp.cumul_sprop_props; tea. now symmetry.
Qed.

Lemma is_propositional_lower {Σ s u u'} :
  consistent Σ ->
  leq_universe Σ s u ->
  leq_universe Σ s u' ->
  PCUICCumulProp.eq_univ_prop u u'.
Proof.
  intros wf leu leu'.
  unfold eq_univ_prop; split.
  - split. intros pu. eapply leq_universe_prop_r in leu; tea => //.
    eapply leq_universe_prop_no_prop_sub_type in leu'; trea => //.
    intros pu'. eapply leq_universe_prop_r in leu'; tea => //.
    eapply leq_universe_prop_no_prop_sub_type in leu; tea => //.
  - split. intros pu. eapply leq_universe_sprop_r in leu; tea => //.
    eapply leq_universe_sprop_l in leu'; tea => //.
    intros pu'. eapply leq_universe_sprop_r in leu'; tea => //.
    eapply leq_universe_sprop_l in leu; tea => //.
Qed.

Lemma typing_spine_inj {Σ Γ Δ s args args' u u'} :
  wf_ext Σ ->
  check_univs ->
  prop_sub_type = false ->
  let T := it_mkProd_or_LetIn Δ (tSort s) in
  typing_spine Σ Γ T args (tSort u) ->
  typing_spine Σ Γ T args' (tSort u') ->
  PCUICCumulProp.eq_univ_prop u u'.
Proof.
  intros wf cu ips T.
  move/typing_spine_it_mkProd_or_LetIn_full_inv => su.
  move/typing_spine_it_mkProd_or_LetIn_full_inv => su'.
  eapply is_propositional_lower; tea. apply wf.
Qed.

Lemma Is_proof_ind Σ Γ t :
  wf_ext Σ ->
  Is_proof Σ Γ t ->
  forall t' ind u args args',
  Σ ;;; Γ |- t : mkApps (tInd ind u) args ->
  Σ ;;; Γ |- t' : mkApps (tInd ind u) args' ->
  Is_proof Σ Γ t'.
Proof.
  intros wfΣ [ty [u [Hty isp]]].
  intros t' ind u' args args' Hty' Hty''.
  epose proof (PCUICPrincipality.common_typing _ wfΣ Hty Hty') as [C [Cty [Cty' Ht'']]].
  destruct isp.
  assert (Σ ;;; Γ |- C : tSort u).
  eapply cumul_prop1'; tea => //. now eapply validity.
  assert (Σ ;;; Γ |- mkApps (tInd ind u') args : tSort u).
  eapply cumul_prop2'; tea => //. now eapply validity.
  eapply inversion_mkApps in X0 as x1. destruct x1 as [? []].
  eapply inversion_Ind in t1 as [mdecl [idecl [wf [decli ?]]]]; eauto.
  destruct (validity Hty'') as [u'' tyargs'].
  eapply inversion_mkApps in X0 as x1. destruct x1 as [? []].
  eapply invert_type_mkApps_ind in X0 as [sp cum]; eauto.
  eapply invert_type_mkApps_ind in tyargs' as f; tea. destruct f as [sp' cum']; eauto.
  do 2 eexists. split => //. tea. instantiate (1 := u'').
  split => //.
  rewrite (declared_inductive_type decli) in sp, sp'.
  rewrite subst_instance_it_mkProd_or_LetIn /= in sp, sp'.
  eapply typing_spine_inj in sp. 5:exact sp'. all:eauto.
  destruct sp as [H H0]. apply/orP. rewrite H H0. now apply/orP.
Qed.

Lemma red_case_isproof {Σ : global_env_ext} {Γ ip p discr discr' brs T} {wfΣ : wf_ext Σ} :
  PCUICReduction.red Σ Γ (tCase ip p discr brs) (tCase ip p discr' brs) ->
  Σ ;;; Γ |- tCase ip p discr brs : T ->
  Is_proof Σ Γ discr -> Is_proof Σ Γ discr'.
Proof.
  intros hr hc.
  eapply subject_reduction in hr; tea; eauto.
  eapply inversion_Case in hc as [mdecl [idecl [isdecl [indices ?]]]]; eauto.
  eapply inversion_Case in hr as [mdecl' [idecl' [isdecl' [indices' ?]]]]; eauto.
  pose proof (wfΣ' := wfΣ.1).
  unshelve eapply declared_inductive_to_gen in isdecl, isdecl'; eauto.
  destruct (declared_inductive_inj isdecl isdecl'). subst mdecl' idecl'.
  intros hp.
  epose proof (Is_proof_ind _ _ _ wfΣ hp).
  destruct p0 as [[] ?]. destruct p1 as [[] ?].
  exact (X _ _ _ _ _ scrut_ty scrut_ty0).
Qed.

Lemma Is_proof_app {Σ Γ t args ty} {wfΣ : wf_ext Σ} :
  Is_proof Σ Γ t ->
  Σ ;;; Γ |- mkApps t args : ty ->
  Is_proof Σ Γ (mkApps t args).
Proof.
  intros [ty' [u [Hty [isp pu]]]] Htargs.
  eapply PCUICValidity.inversion_mkApps in Htargs as [A [Ht sp]].
  pose proof (PCUICValidity.validity Hty).
  pose proof (PCUICValidity.validity Ht).
  epose proof (PCUICPrincipality.common_typing _ wfΣ Hty Ht) as [C [Cty [Cty' Ht'']]].
  eapply PCUICSpine.typing_spine_strengthen in sp. 3:tea.
  edestruct (sort_typing_spine _ _ _ u _ _ _ pu sp) as [u' [Hty' isp']].
  eapply cumul_prop1'. 5:tea. all:eauto.
  eapply validity; eauto.
  exists ty, u'; split; auto.
  eapply PCUICSpine.type_mkApps; tea; eauto.
  now eapply validity.
Qed.

Lemma isErasable_Propositional {Σ : global_env_ext} {Γ ind n u args} :
  wf_ext Σ ->
  isErasable Σ Γ (mkApps (tConstruct ind n u) args) -> isPropositional Σ ind true.
Proof.
  intros wfΣ ise.
  eapply tConstruct_no_Type in ise; eauto.
  destruct ise as [T [s [HT [Ts isp]]]].
  unfold isPropositional.
  eapply PCUICValidity.inversion_mkApps in HT as (? & ? & ?); auto.
  eapply inversion_Construct in t as (? & ? & ? & ? & ? & ? & ?); auto.
  pose proof (wfΣ' := wfΣ.1).
  unshelve epose proof (d_ := declared_constructor_to_gen d); eauto.
  unfold lookup_inductive. rewrite (declared_inductive_lookup_gen d_.p1).
  destruct (on_declared_constructor d).
  destruct p as [onind oib].
  rewrite oib.(ind_arity_eq).
  rewrite /isPropositionalArity !destArity_it_mkProd_or_LetIn /=.
  eapply PCUICSpine.typing_spine_strengthen in t0; eauto.
  unfold type_of_constructor in t0.
  destruct s0 as [indctors [nthcs onc]].
  rewrite onc.(cstr_eq) in t0.
  rewrite !subst_instance_it_mkProd_or_LetIn !PCUICLiftSubst.subst_it_mkProd_or_LetIn in t0.
  len in t0.
  rewrite subst_cstr_concl_head in t0. destruct d as [decli declc].
  destruct decli as [declm decli]. now eapply nth_error_Some_length.
  rewrite -it_mkProd_or_LetIn_app in t0.
  eapply PCUICElimination.typing_spine_proofs in Ts; eauto.
  destruct Ts as [_ Hs].
  specialize (Hs _ _ d c) as [Hs _].
  specialize (Hs isp). subst s. move: isp.
  now destruct (ind_sort x1).
  eapply validity. econstructor; tea.
Qed.

Lemma nisErasable_Propositional {Σ : global_env_ext} {Γ ind n u} :
  wf_ext Σ ->
  welltyped Σ Γ (tConstruct ind n u) ->
  (isErasable Σ Γ (tConstruct ind n u) -> False) -> isPropositional Σ ind false.
Proof.
  intros wfΣ wt ise.
  destruct wt as [T HT].
  epose proof HT as HT'.
  eapply inversion_Construct in HT' as (? & ? & ? & ? & ? & ? & e); auto.
  pose proof (declared_constructor_valid_ty _ _ _ _ _ _ _ _ wfΣ a d c).
  pose proof d as [decli ?].
  destruct (on_declared_constructor d).
  destruct p as [onind oib].
  red. unfold lookup_inductive.
  pose proof (wfΣ' := wfΣ.1).
  unshelve epose proof (decli_ := declared_inductive_to_gen decli); eauto.
  rewrite (declared_inductive_lookup_gen decli_).
  rewrite oib.(ind_arity_eq).
  rewrite /isPropositionalArity !destArity_it_mkProd_or_LetIn /=.
  destruct (is_propositional (ind_sort x0)) eqn:isp; auto.
  elimtype False; eapply ise.
  red. eexists; intuition eauto. right.
  unfold type_of_constructor in e, X.
  destruct s as [indctors [nthcs onc]].
  rewrite onc.(cstr_eq) in e, X.
  rewrite !subst_instance_it_mkProd_or_LetIn !PCUICLiftSubst.subst_it_mkProd_or_LetIn in e, X.
  len in e; len in X.
  rewrite subst_cstr_concl_head in e, X.
  destruct decli. eapply nth_error_Some_length in H1; eauto.
  rewrite -it_mkProd_or_LetIn_app in e, X.
  exists (subst_instance_univ u (ind_sort x0)).
  rewrite is_propositional_subst_instance => //.
  split; auto.
  eapply cumul_propositional; eauto.
  rewrite is_propositional_subst_instance => //.
  eapply PCUICValidity.validity; eauto.
  destruct X as [cty ty].
  eapply type_Cumul_alt; eauto.
  eapply isType_Sort. 2:eauto.
  destruct (ind_sort x0) => //.
  eapply PCUICSpine.inversion_it_mkProd_or_LetIn in ty; eauto.
  epose proof (typing_spine_proofs _ _ [] _ _ _ [] _ _ eq_refl wfΣ ty).
  forward H0 by constructor. eexists; eauto.
  simpl. now exists cty. eapply PCUICConversion.ws_cumul_pb_eq_le_gen, PCUICSR.wt_cumul_pb_refl; eauto.
  destruct H0 as [_ sorts].
  specialize (sorts _ _ decli c) as [sorts sorts'].
  forward sorts' by constructor.
  do 2 constructor.
  rewrite is_propositional_subst_instance in sorts, sorts' |- *.
  specialize (sorts' isp). rewrite -sorts'. reflexivity.
Qed.

Lemma isPropositional_propositional Σ {wfΣ: wf Σ} (Σ' : E.global_context) ind mdecl idecl mdecl' idecl' :
  PCUICAst.declared_inductive Σ ind mdecl idecl ->
  EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' ->
  erases_mutual_inductive_body mdecl mdecl' ->
  erases_one_inductive_body idecl idecl' ->
  forall b, isPropositional Σ ind b -> EGlobalEnv.inductive_isprop_and_pars Σ' ind = Some (b, mdecl.(ind_npars)).
Proof.
  intros decli decli' [_ indp] [] b.
  unfold isPropositional, EGlobalEnv.inductive_isprop_and_pars.
  unfold lookup_inductive.
  unshelve epose proof (decli_ := declared_inductive_to_gen decli); eauto.
  rewrite (declared_inductive_lookup_gen decli_).
  rewrite (EGlobalEnv.declared_inductive_lookup decli') /=
    /isPropositionalArity.
  destruct H0 as [_ [_ [_ isP]]]. red in isP.
  destruct destArity as [[ctx s]|] eqn:da => //.
  rewrite isP. intros ->. f_equal. f_equal. now rewrite indp.
Qed.

Lemma isPropositional_propositional_cstr Σ (Σ' : E.global_context) ind c mdecl idecl cdecl mdecl' idecl' :
  wf Σ ->
  PCUICAst.declared_constructor Σ (ind, c) mdecl idecl cdecl ->
  EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' ->
  erases_mutual_inductive_body mdecl mdecl' ->
  erases_one_inductive_body idecl idecl' ->
  forall b, isPropositional Σ ind b ->
  EGlobalEnv.constructor_isprop_pars_decl Σ' ind c =
  Some (b, mdecl.(ind_npars), EAst.mkConstructor cdecl.(cstr_name) (context_assumptions cdecl.(cstr_args))).
Proof.
  intros wfΣ declc decli' em ei b isp.
  pose proof declc as [decli'' _].
  eapply isPropositional_propositional in decli''; tea.
  move: decli''.
  rewrite /EGlobalEnv.inductive_isprop_and_pars.
  unfold EGlobalEnv.constructor_isprop_pars_decl.
  unfold EGlobalEnv.lookup_constructor.
  rewrite (EGlobalEnv.declared_inductive_lookup decli') /=.
  intros [= <- <-].
  destruct ei. clear H0.
  eapply Forall2_nth_error_Some in H as [cdecl' []]; tea. 2:apply declc.
  rewrite H //. f_equal. f_equal.
  destruct cdecl'. cbn in *. destruct H0. subst. f_equal.
  destruct (on_declared_constructor declc) as [[] [? []]].
  now eapply cstr_args_length in o1.
Qed.

Lemma eval_tCase {cf : checker_flags} {Σ : global_env_ext}  ci p discr brs res T :
  wf Σ ->
  Σ ;;; [] |- tCase ci p discr brs : T ->
  eval Σ (tCase ci p discr brs) res ->
  ∑ c u args, PCUICReduction.red Σ [] (tCase ci p discr brs) (tCase ci p ((mkApps (tConstruct ci.(ci_ind) c u) args)) brs).
Proof.
  intros wf wt H. depind H; try now (cbn in *; congruence).
  - eapply inversion_Case in wt as (? & ? & ? & ? & cinv & ?); eauto.
    eexists _, _, _. eapply PCUICReduction.red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv.
  - eapply inversion_Case in wt as wt'; eauto. destruct wt' as (? & ? & ? & ? & cinv & ?).
    assert (Hred1 : PCUICReduction.red Σ [] (tCase ip p discr brs) (tCase ip p (mkApps fn args) brs)). {
      etransitivity. { eapply PCUICReduction.red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. }
      econstructor. econstructor.
      rewrite closed_unfold_cofix_cunfold_eq. eauto.
      enough (closed (mkApps (tCoFix mfix idx) args)) as Hcl by (rewrite closedn_mkApps in Hcl; solve_all).
      eapply eval_closed. eauto.
      2: eauto. eapply @PCUICClosedTyp.subject_closed with (Γ := []); eauto. eapply cinv. eauto.
    }
    edestruct IHeval2 as (c & u & args0 & IH); eauto using subject_reduction.
    exists c, u, args0. etransitivity; eauto.
Qed.

Lemma Informative_cofix v ci p brs T (Σ : global_env_ext) :
   wf_ext Σ ->
   forall (mdecl : mutual_inductive_body) (idecl : one_inductive_body) mfix idx,
   declared_inductive Σ.1 ci.(ci_ind) mdecl idecl ->
   forall (args : list term), Informative Σ ci.(ci_ind) ->
   Σ ;;; [] |- tCase ci p (mkApps (tCoFix mfix idx) args) brs : T ->
   Σ ⊢p tCase ci p (mkApps (tCoFix mfix idx) args) brs ▷ v ->
   Is_proof Σ [] (mkApps (tCoFix mfix idx) args) ->
   #|ind_ctors idecl| <= 1.
Proof.
  intros. destruct Σ as [Σ1 Σ2]. cbn in *.
  eapply eval_tCase in X0 as X2'; eauto. destruct X2' as (? & ? & ? & ?).
  eapply subject_reduction in X0 as X2'; eauto.
  eapply inversion_Case in X2' as (? & ? & ? & ? & [] & ?); eauto.
  eapply inversion_Case in X0 as (? & ? & ? & ? & [] & ?); eauto.
  pose (X' := X.1). unshelve eapply declared_inductive_to_gen in x8, x4, H; eauto.
  destruct (declared_inductive_inj x8 x4); subst.
  destruct (declared_inductive_inj x8 H); subst.
  eapply H0; eauto. apply declared_inductive_from_gen; eauto.
  reflexivity.
  eapply Is_proof_ind; tea.
Qed.

Lemma isErasable_unfold_cofix {Σ : global_env_ext} {Γ mfix idx} {wfΣ : wf Σ} decl :
  isErasable Σ Γ (tCoFix mfix idx) ->
  nth_error mfix idx = Some decl ->
  isErasable Σ Γ (subst0 (cofix_subst mfix) (dbody decl)).
Proof.
  intros [Tty []] hred.
  exists Tty. split => //.
  eapply type_tCoFix_inv in t as t''; eauto.
  destruct t'' as [decl' [[[] h'] h'']].
  rewrite e in hred. noconf hred.
  eapply type_ws_cumul_pb; tea.
  now eapply validity.
Qed.

Lemma isErasable_red {Σ : global_env_ext} {Γ T U} {wfΣ : wf Σ} :
  isErasable Σ Γ T -> PCUICReduction.red Σ Γ T U -> isErasable Σ Γ U.
Proof.
  intros [Tty []] hred.
  exists Tty. split => //. eapply subject_reduction; tea.
Qed.


Require Import VST.floyd.proofauto.
Require Import fastpile.
Require Import spec_stdlib.
Global Open Scope funspec_scope.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition tpile := Tstruct _pile noattr.

Definition sumlist : list Z -> Z := List.fold_right Z.add 0.

Definition pilerep (sigma: list Z) (p: val) : mpred :=
 EX s:Z, !! (0 <= s <= Int.max_signed /\
   Forall (Z.le 0) sigma /\
  (0 <= sumlist sigma <= Int.max_signed -> s=sumlist sigma))
   &&  data_at Ews tpile (Vint (Int.repr s)) p.

Definition pile_freeable (p: val) : mpred :=
            malloc_token Ews tpile p.

Lemma pilerep_local_facts:
  forall sigma p,
   pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold pilerep.
Intros q.
entailer!.
Qed.

Hint Resolve pilerep_local_facts : saturate_local.

Lemma pilerep_valid_pointer:
  forall sigma p,
   pilerep sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold pilerep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vint (Int.repr (sizeof t))) GLOBALS (gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS () GLOBALS (gv) SEP(mem_mgr gv)
 POST[ tptr tpile ]
   EX p: val,
     PROP() LOCAL(temp ret_temp p)
     SEP(pilerep nil p; pile_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(pilerep sigma p; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep (n::sigma) p; mem_mgr gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p) GLOBALS ()
    SEP(pilerep sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) GLOBALS (gv)
    SEP(pilerep sigma p; pile_freeable p; mem_mgr gv)
 POST[ tvoid ]
      PROP() LOCAL() SEP(mem_mgr gv).

Definition ispecs := [surely_malloc_spec].
Definition specs := [Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].


(*
 * Copyright (c) 2020-21 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
From iris.proofmode Require Import proofmode.
From bedrock.lang.bi Require Import fractional.

From bedrock.lang.cpp Require Import
  bi.cfractional
  semantics ast logic.pred logic.path_pred.

Export bedrock.lang.cpp.logic.pred.
(* ^^ Should this be exported? this file is supposed to provide wrappers
   so that clients do not work directly with [pred.v] *)
Export bedrock.lang.cpp.algebra.cfrac.

#[local] Set Printing Coercions.

Implicit Types (σ resolve : genv) (p : ptr) (o : offset).

Section defs.
  Context `{Σ : cpp_logic}.

  (** object identity *)
  Definition identityR {σ : genv} (cls : globname) (mdc : list globname)
             (q : cQp.t) : Rep :=
    as_Rep (identity cls mdc q).

  Definition validR_def : Rep := as_Rep valid_ptr.
  Definition validR_aux : seal (@validR_def). Proof. by eexists. Qed.
  Definition validR := validR_aux.(unseal).
  Definition validR_eq : @validR = _ := validR_aux.(seal_eq).

  Definition svalidR_def : Rep := as_Rep strict_valid_ptr.
  Definition svalidR_aux : seal (@svalidR_def). Proof. by eexists. Qed.
  Definition svalidR := svalidR_aux.(unseal).
  Definition svalidR_eq : @svalidR = _ := svalidR_aux.(seal_eq).

  Definition type_ptrR_def σ (t : type) : Rep := as_Rep (@type_ptr _ _ σ t).
  Definition type_ptrR_aux : seal (@type_ptrR_def). Proof. by eexists. Qed.
  Definition type_ptrR := type_ptrR_aux.(unseal).
  Definition type_ptrR_eq : @type_ptrR = _ := type_ptrR_aux.(seal_eq).

End defs.

Arguments type_ptrR {_ Σ σ} _.

Section with_cpp.
  Context `{Σ : cpp_logic}.

  (** [varargsR ts_ps] is the ownership of a group of variadic arguments.
      The [type] is the type of the argument and the [ptr] is the location
      of the argument. *)
  Parameter varargsR : list (type * ptr) -> Rep.

  (** [primR ty q v]: the argument pointer points to an initialized value [v] of C++ type [ty].
   *
   * NOTE [ty] *must* be a primitive type.
   *)
  Definition primR_def {resolve:genv} (ty : type) (q : cQp.t) (v : val) : Rep :=
    as_Rep (fun p : ptr => tptsto ty q p v **
             [| not(exists raw, v = Vraw raw) |] **
             [| has_type v (drop_qualifiers ty) |]).
  Definition primR_aux : seal (@primR_def). Proof. by eexists. Qed.
  Definition primR := primR_aux.(unseal).
  Definition primR_eq : @primR = _ := primR_aux.(seal_eq).
  #[global] Arguments primR {resolve} ty q v : rename.

  #[global] Instance primR_proper :
    Proper (genv_eq ==> (=) ==> (=) ==> (=) ==> (⊣⊢)) (@primR).
  Proof.
    intros σ1 σ2 Hσ ??-> ??-> ??->.
    rewrite primR_eq/primR_def. by setoid_rewrite Hσ.
  Qed.
  #[global] Instance primR_mono :
    Proper (genv_leq ==> (=) ==> (=) ==> (=) ==> (⊢)) (@primR).
  Proof.
    intros σ1 σ2 Hσ ??-> ??-> ??->.
    rewrite primR_eq/primR_def. by setoid_rewrite Hσ.
  Qed.

  #[global] Instance primR_timeless resolve ty q v
    : Timeless (primR ty q v).
  Proof. rewrite primR_eq. apply _. Qed.

  #[global] Instance primR_cfractional resolve ty :
    CFractional1 (primR ty).
  Proof. rewrite primR_eq. apply _. Qed.
  #[global] Instance primR_as_cfractional resolve ty :
    AsCFractional1 (primR ty).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance primR_observe_cfrac_valid resolve ty :
    CFracValid1 (primR ty).
  Proof. rewrite primR_eq. solve_cfrac_valid. Qed.

  Section TEST.
    Context {σ : genv} (p : ptr).

    Goal
        p |-> primR Tint (cQp.m (1/2)) 0
        |-- p |-> primR Tint (cQp.m (1/2)) 0 -* p |-> primR Tint (cQp.m 1) 0.
    Proof.
      iIntros "H1 H2".
      iCombine "H1 H2" as "$".
    Abort.

    Goal
        p |-> primR Tint (cQp.c 1) 0 |-- p |-> primR Tint (cQp.c (1/2)) 0 ** p |-> primR Tint (cQp.c (1/2)) 0.
    Proof.
      iIntros "H".
      iDestruct "H" as "[H1 H2]".
    Abort.

    Goal p |-> primR Tint (cQp.c 1) 1 |-- True.
    Proof.
      iIntros "H".
      iDestruct (observe [| 1 ≤ 1 |]%Qp with "H") as %? (* ; [] << FAILS *).
    Abort.
  End TEST.

  #[global] Instance primR_observe_agree resolve ty q1 q2 v1 v2 :
    Observe2 [| v1 = v2 |]
      (primR ty q1 v1)
      (primR ty q2 v2).
  Proof.
    rewrite primR_eq/primR_def; apply: as_Rep_only_provable_observe_2=> p.
    iIntros "(Htptsto1 & %Hnotraw1 & %Hhas_type1)
             (Htptsto2 & %Hnotraw2 & %Hhas_type2)".
    iApply (observe_2 with "Htptsto1 Htptsto2").
    iApply observe_2_derive_only_provable => Hvs.
    induction Hvs; subst; auto; exfalso;
        [apply Hnotraw1 | apply Hnotraw2];
        eauto.
  Qed.

  (* Typical [f] are [Vint], [Vn] etc; this gives agreement for [u64R] etc. *)
  #[global] Instance primR_observe_agree_constr resolve ty q1 q2 {A} f `{!Inj eq eq f} (v1 v2 : A) :
    Observe2 [| v1 = v2 |]
      (primR ty q1 (f v1))
      (primR ty q2 (f v2)).
  Proof. apply (observe2_inj f), _. Qed.

  #[global] Instance primR_observe_has_type resolve ty q v :
    Observe [| has_type v (drop_qualifiers ty) |] (primR ty q v).
  Proof. rewrite primR_eq. apply _. Qed.

  Lemma primR_has_type {σ} ty q v :
    primR (resolve:=σ) ty q v |--
    primR (resolve:=σ) ty q v ** [| has_type v (drop_qualifiers ty) |].
  Proof. apply: observe_elim. Qed.

  (**
     [uninitR ty q]: the argument pointer points to an uninitialized value [Vundef] of C++ type [ty].
     Unlike [primR], does not imply [has_type].

     NOTE the [ty] argument *must* be a primitive type.

     TODO is it possible to generalize this to support aggregate types? structures seem easy enough
          but unions seem more difficult, possibly we can achieve that through the use of disjunction?
   *)
  Definition uninitR_def {resolve:genv} (ty : type) (q : cQp.t) : Rep :=
    as_Rep (fun addr => @tptsto _ _ resolve ty q addr Vundef).
  Definition uninitR_aux : seal (@uninitR_def). Proof. by eexists. Qed.
  Definition uninitR := uninitR_aux.(unseal).
  Definition uninitR_eq : @uninitR = _ := uninitR_aux.(seal_eq).
  #[global] Arguments uninitR {resolve} ty q : rename.

  #[global] Instance uninitR_proper
    : Proper (genv_eq ==> (=) ==> (=) ==> (≡)) (@uninitR).
  Proof.
    intros σ1 σ2 Hσ ??-> ??->     .
    rewrite uninitR_eq/uninitR_def. by setoid_rewrite Hσ.
  Qed.
  #[global] Instance uninitR_mono
    : Proper (genv_leq ==> (=) ==> (=) ==> (⊢)) (@uninitR).
  Proof.
    intros σ1 σ2 Hσ ??-> ??->     .
    rewrite uninitR_eq/uninitR_def. by setoid_rewrite Hσ.
  Qed.

  #[global] Instance uninitR_timeless resolve ty q
    : Timeless (uninitR ty q).
  Proof. rewrite uninitR_eq. apply _. Qed.

  #[global] Instance uninitR_cfractional resolve ty :
    CFractional (uninitR ty).
  Proof. rewrite uninitR_eq. apply _. Qed.
  #[global] Instance unintR_as_fractional resolve ty :
    AsCFractional0 (uninitR ty).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance uninitR_observe_frac_valid resolve ty :
    CFracValid0 (uninitR ty).
  Proof. rewrite uninitR_eq. solve_cfrac_valid. Qed.

  Lemma test:
    forall σ ty v v',
      v' = Vundef ->
      val_related σ ty v v' ->
      v = Vundef.
  Proof.
    intros * Hv' Hval_related; induction Hval_related;
      try (by inversion Hv'); auto.
  Qed.

  (** This seems odd, but it's relevant to the (former) proof that [anyR] is
  fractional; currently unused. *)
  Lemma primR_uninitR {resolve} ty q1 q2 v :
    primR ty q1 v |--
    uninitR ty q2 -*
    primR ty (q1 ⋅ q2) Vundef.
  Proof.
    rewrite primR_eq/primR_def uninitR_eq/uninitR_def. constructor=>p /=.
    rewrite monPred_at_wand. iIntros "[T1 [%Hnotraw %Hty]]" (? <-%ptr_rel_elim) "/= T2".
    iDestruct (observe_2 [| val_related resolve ty v Vundef |] with "T1 T2") as "%Hrelated".
    assert (v = Vundef)
      by (remember Vundef as v'; induction Hrelated;
          try (by inversion Heqv'); auto); subst.
    iCombine "T1 T2" as "T"; by iFrame "∗%".
  Qed.

  (** [anyR] The argument pointers points to a value of C++ type [ty] that might be
      uninitialized. *)
  Parameter anyR : ∀ {resolve} (ty : type) (q : cQp.t), Rep.
  #[global] Arguments anyR {resolve} ty q : rename.
  #[global] Declare Instance anyR_timeless : ∀ resolve ty q, Timeless (anyR ty q).
  #[global] Declare Instance anyR_cfractional : ∀ resolve ty, CFractional (anyR ty).
  #[global] Declare Instance anyR_observe_frac_valid resolve ty : CFracValid0 (anyR ty).

  Axiom primR_anyR : ∀ resolve t q v, primR t q v |-- anyR t q.
  Axiom uninitR_anyR : ∀ resolve t q, uninitR t q |-- anyR t q.
  Axiom tptsto_raw_anyR : forall resolve p q r, tptsto Tu8 q p (Vraw r) |-- p |-> anyR Tu8 q.
  #[global] Declare Instance anyR_type_ptr_observe σ ty q : Observe (type_ptrR ty) (anyR ty q).

  #[global] Instance anyR_as_fractional resolve ty : AsCFractional0 (anyR ty).
  Proof. solve_as_cfrac. Qed.

  Axiom _at_anyR_ptr_congP_transport : forall {σ} p p' ty q,
    ptr_congP σ p p' ** type_ptr ty p' |-- p |-> anyR ty q -* p' |-> anyR ty q.
End with_cpp.

#[global] Typeclasses Opaque primR.
#[global] Opaque primR.

Section with_cpp.
  Context `{Σ : cpp_logic} {σ : genv}.

  (********************* DERIVED CONCEPTS ****************************)
  #[global] Instance validR_persistent : Persistent validR.
  Proof. rewrite validR_eq; refine _. Qed.
  #[global] Instance validR_timeless : Timeless validR.
  Proof. rewrite validR_eq; refine _. Qed.
  #[global] Instance validR_affine : Affine validR.
  Proof. rewrite validR_eq; refine _. Qed.

  Import heap_notations.INTERNAL.

  Lemma monPred_at_validR p : validR p -|- valid_ptr p.
  Proof. by rewrite validR_eq. Qed.
  Lemma _at_validR (p : ptr) : _at p validR -|- valid_ptr p.
  Proof. by rewrite validR_eq _at_eq /_at_def. Qed.

  #[global] Instance svalidR_persistent : Persistent svalidR.
  Proof. rewrite svalidR_eq; refine _. Qed.
  #[global] Instance svalidR_timeless : Timeless svalidR.
  Proof. rewrite svalidR_eq; refine _. Qed.
  #[global] Instance svalidR_affine : Affine svalidR.
  Proof. rewrite svalidR_eq; refine _. Qed.

  Lemma monPred_at_svalidR p : svalidR p -|- strict_valid_ptr p.
  Proof. by rewrite svalidR_eq. Qed.
  Lemma _at_svalidR (p : ptr) : _at p svalidR -|- strict_valid_ptr p.
  Proof. by rewrite svalidR_eq _at_eq. Qed.

  #[global] Instance type_ptrR_persistent t : Persistent (type_ptrR t).
  Proof. rewrite type_ptrR_eq; refine _. Qed.
  #[global] Instance type_ptrR_timeless t : Timeless (type_ptrR t).
  Proof. rewrite type_ptrR_eq; refine _. Qed.
  #[global] Instance type_ptrR_affine t : Affine (type_ptrR t).
  Proof. rewrite type_ptrR_eq; refine _. Qed.

  Lemma monPred_at_type_ptrR ty p : type_ptrR ty p -|- type_ptr ty p.
  Proof. by rewrite type_ptrR_eq. Qed.
  Lemma _at_type_ptrR (p : ptr) ty : _at p (type_ptrR ty) -|- type_ptr ty p.
  Proof. by rewrite type_ptrR_eq _at_eq. Qed.

  Lemma svalidR_validR : svalidR |-- validR.
  Proof.
    rewrite validR_eq/validR_def svalidR_eq/svalidR_def.
    constructor =>p /=. by apply strict_valid_valid.
  Qed.
  Lemma type_ptrR_svalidR ty : type_ptrR ty |-- svalidR.
  Proof.
    rewrite type_ptrR_eq/type_ptrR_def svalidR_eq/svalidR_def.
    constructor =>p /=. by apply type_ptr_strict_valid.
  Qed.
  Lemma type_ptrR_validR ty : type_ptrR ty |-- validR.
  Proof. by rewrite type_ptrR_svalidR svalidR_validR. Qed.

  #[global] Instance svalidR_validR_observe : Observe validR svalidR.
  Proof. rewrite svalidR_validR. red; iIntros "#$". Qed.
  #[global] Instance type_ptrR_svalidR_observe t : Observe svalidR (type_ptrR t).
  Proof. rewrite type_ptrR_svalidR; red; iIntros "#$". Qed.

  Definition nullR_def : Rep :=
    as_Rep (fun addr => [| addr = nullptr |]).
  Definition nullR_aux : seal (@nullR_def). Proof. by eexists. Qed.
  Definition nullR := nullR_aux.(unseal).
  Definition nullR_eq : @nullR = _ := nullR_aux.(seal_eq).

  #[global] Hint Opaque nullR : typeclass_instances.

  #[global] Instance nullR_persistent : Persistent nullR.
  Proof. rewrite nullR_eq. apply _. Qed.
  #[global] Instance nullR_affine : Affine nullR.
  Proof. rewrite nullR_eq. apply _. Qed.
  #[global] Instance nullR_timeless : Timeless nullR.
  Proof. rewrite nullR_eq. apply _. Qed.
  #[global] Instance nullR_fractional : Fractional (λ _, nullR).
  Proof. apply _. Qed.
  #[global] Instance nullR_as_fractional q : AsFractional nullR (λ _, nullR) q.
  Proof. exact: Build_AsFractional. Qed.
  #[global] Instance nullR_cfractional : CFractional (λ _, nullR).
  Proof. apply _. Qed.
  #[global] Instance nullR_as_cfractional q : AsCFractional nullR (λ _, nullR) q.
  Proof. solve_as_cfrac. Qed.

  Definition nonnullR_def : Rep :=
    as_Rep (fun addr => [| addr <> nullptr |]).
  Definition nonnullR_aux : seal (@nonnullR_def). Proof. by eexists. Qed.
  Definition nonnullR := nonnullR_aux.(unseal).
  Definition nonnullR_eq : @nonnullR = _ := nonnullR_aux.(seal_eq).

  #[global] Hint Opaque nonnullR : typeclass_instances.

  #[global] Instance nonnullR_persistent : Persistent nonnullR.
  Proof. rewrite nonnullR_eq. apply _. Qed.
  #[global] Instance nonnullR_affine : Affine nonnullR.
  Proof. rewrite nonnullR_eq. apply _. Qed.
  #[global] Instance nonnullR_timeless : Timeless nonnullR.
  Proof. rewrite nonnullR_eq. apply _. Qed.

  Definition alignedR_def (al : N) : Rep := as_Rep (λ p, [| aligned_ptr al p |]).
  Definition alignedR_aux : seal (@alignedR_def). Proof. by eexists. Qed.
  Definition alignedR := alignedR_aux.(unseal).
  Definition alignedR_eq : @alignedR = _ := alignedR_aux.(seal_eq).
  #[global] Instance alignedR_persistent {al} : Persistent (alignedR al).
  Proof. rewrite alignedR_eq. apply _. Qed.
  #[global] Instance alignedR_affine {al} : Affine (alignedR al).
  Proof. rewrite alignedR_eq. apply _. Qed.
  #[global] Instance alignedR_timeless {al} : Timeless (alignedR al).
  Proof. rewrite alignedR_eq. apply _. Qed.

  #[global] Instance alignedR_divide_mono :
    Proper (flip N.divide ==> bi_entails) alignedR.
  Proof.
    intros m n ?.
    rewrite alignedR_eq /alignedR_def. constructor=>p/=. iIntros "!%".
    exact: aligned_ptr_divide_weaken.
  Qed.

  #[global] Instance alignedR_divide_flip_mono :
    Proper (N.divide ==> flip bi_entails) alignedR.
  Proof. solve_proper. Qed.

  Lemma alignedR_divide_weaken m n :
    (n | m)%N ->
    alignedR m ⊢ alignedR n.
  Proof. by move->. Qed.

  Lemma null_nonnull (R : Rep) : nullR |-- nonnullR -* R.
  Proof.
    rewrite nullR_eq /nullR_def nonnullR_eq /nonnullR_def.
    constructor=>p /=. rewrite monPred_at_wand/=.
    by iIntros "->" (? <-%ptr_rel_elim) "%".
  Qed.

  Lemma null_validR : nullR |-- validR.
  Proof.
    rewrite nullR_eq /nullR_def validR_eq /validR_def.
    constructor => p /=. iIntros "->". iApply valid_ptr_nullptr.
  Qed.

  (** [blockR sz q] represents [q] ownership of a contiguous chunk of
      [sz] bytes without any C++ structure on top of it. *)
  Definition blockR_def {σ} sz (q : cQp.t) : Rep :=
    _offsetR (o_sub σ Tu8 (Z.of_N sz)) validR **
    (* ^ Encodes valid_ptr (this .[ Tu8 ! sz]). This is
    necessary to get [l |-> blockR n -|- l |-> blockR n ** l .[ Tu8 ! m] |-> blockR 0]. *)
    [∗list] i ∈ seq 0 (N.to_nat sz),
      _offsetR (o_sub σ Tu8 (Z.of_nat i)) (anyR (resolve:=σ) Tu8 q).
  Definition blockR_aux : seal (@blockR_def). Proof. by eexists. Qed.
  Definition blockR := blockR_aux.(unseal).
  Definition blockR_eq : @blockR = _ := blockR_aux.(seal_eq).
  #[global] Arguments blockR {_} _%N _%Qp.

  #[global] Instance blockR_timeless {resolve : genv} sz q :
    Timeless (blockR sz q).
  Proof. rewrite blockR_eq /blockR_def. unfold_at. apply _. Qed.
  #[global] Instance blockR_cfractional resolve sz :
    CFractional (blockR sz).
  Proof. rewrite blockR_eq. apply _. Qed.
  #[global] Instance blockR_as_cfractional {resolve : genv} sz :
    AsCFractional0 (blockR sz).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance blockR_observe_frac_valid {resolve : genv} sz :
    TCLt (0 ?= sz)%N ->
    CFracValid0 (blockR sz).
  Proof.
    rewrite TCLt_N blockR_eq/blockR_def. intros.
    destruct (N.to_nat sz) eqn:?; [ lia | ] => /=.
    solve_cfrac_valid.
  Qed.

  (* [tblockR ty] is a [blockR] that is the size of [ty] and properly aligned.
   * it is a convenient short-hand since it happens frequently, but there is nothing
   * special about it.
   *)
  Definition tblockR {σ} (ty : type) (q : cQp.t) : Rep :=
    match size_of σ ty , align_of ty with
    | Some sz , Some al => blockR (σ:=σ) sz q ** alignedR al
    | _ , _  => False
    end.

  #[global] Instance tblockR_timeless ty q :
    Timeless (tblockR ty q).
  Proof. rewrite/tblockR. case_match; apply _. Qed.
  #[global] Instance tblockR_cfractional ty :
    CFractional (tblockR ty).
  Proof.
    rewrite/tblockR. do 2!(case_match; last by apply _).
    apply _.
  Qed.
  #[global] Instance tblockR_as_cfractional ty : AsCFractional0 (tblockR ty).
  Proof. solve_as_cfrac. Qed.
  #[global] Instance tblockR_observe_frac_valid ty n :
    SizeOf ty n -> TCLt (0 ?= n)%N ->
    CFracValid0 (tblockR ty).
  Proof.
    rewrite/tblockR=>-> ?. case_match; solve_cfrac_valid.
  Qed.

  #[global] Instance identityR_timeless cls mdc q : Timeless (identityR cls mdc q) := _.
  #[global] Instance identityR_cfractional cls mdc : CFractional (identityR cls mdc) := _.
  #[global] Instance identityR_as_frac cls mdc :
    AsCFractional0 (identityR cls mdc).
  Proof. solve_as_cfrac. Qed.

  #[global] Instance identityR_strict_valid cls mdc q : Observe svalidR (identityR cls mdc q).
  Proof.
    red. eapply Rep_entails_at. intros.
    rewrite _at_as_Rep _at_pers svalidR_eq _at_as_Rep.
    apply identity_strict_valid.
  Qed.
  #[global] Instance identity_not_null p cls path q : Observe [| p <> nullptr |] (p |-> identityR cls path q).
  Proof.
    red.
    iIntros "X".
    destruct (decide (p = nullptr)); eauto.
    iDestruct (observe (p |-> svalidR) with "X") as "#SV".
    subst; rewrite _at_svalidR not_strictly_valid_ptr_nullptr.
    iDestruct "SV" as "[]".
  Qed.

  (** Observing [type_ptr] *)
  #[global]
  Instance primR_type_ptr_observe ty q v : Observe (type_ptrR ty) (primR ty q v).
  Proof.
    red. rewrite primR_eq/primR_def.
    apply Rep_entails_at => p. rewrite _at_as_Rep _at_pers _at_type_ptrR.
    apply: observe.
  Qed.
  #[global]
  Instance uninitR_type_ptr_observe ty q : Observe (type_ptrR ty) (uninitR ty q).
  Proof.
    red. rewrite uninitR_eq/uninitR_def.
    apply Rep_entails_at => p. rewrite _at_as_Rep _at_pers _at_type_ptrR.
    apply: observe.
  Qed.

  (** Observing [valid_ptr] *)
  #[global]
  Instance primR_valid_observe {ty q v} : Observe validR (primR ty q v).
  Proof. rewrite -svalidR_validR -type_ptrR_svalidR; refine _. Qed.
  #[global]
  Instance anyR_valid_observe {ty q} : Observe validR (anyR ty q).
  Proof. rewrite -svalidR_validR -type_ptrR_svalidR; refine _. Qed.
  #[global]
  Instance uninitR_valid_observe {ty q} : Observe validR (uninitR ty q).
  Proof. rewrite -svalidR_validR -type_ptrR_svalidR; refine _. Qed.

  #[global]
  Instance observe_type_ptr_pointsto (p : ptr) ty (R : Rep) :
    Observe (type_ptrR ty) R -> Observe (type_ptr ty p) (_at p R).
  Proof. rewrite -_at_type_ptrR. apply _at_observe. Qed.

  #[global] Instance type_ptrR_size_observe ty :
    Observe [| is_Some (size_of σ ty) |] (type_ptrR ty).
  Proof.
    apply monPred_observe_only_provable => p.
    rewrite monPred_at_type_ptrR. apply _.
  Qed.

  #[global]
  Instance null_valid_observe : Observe validR nullR.
  Proof. rewrite -null_validR. refine _. Qed.

  Lemma off_validR o
    (Hv : ∀ p, valid_ptr (p ,, o) |-- valid_ptr p) :
    _offsetR o validR |-- validR.
  Proof.
    apply Rep_entails_at => p. by rewrite _at_offsetR !_at_validR.
  Qed.

  Lemma _field_validR f : _offsetR (_field f) validR |-- validR.
  Proof. apply off_validR => p. apply _valid_ptr_field. Qed.

  (** Observation of [nonnullR] *)
  #[global]
  Instance primR_nonnull_observe {ty q v} :
    Observe nonnullR (primR ty q v).
  Proof.
    rewrite nonnullR_eq primR_eq. apply monPred_observe=>p /=. apply _.
  Qed.
  #[global]
  Instance uninitR_nonnull_observe {ty q} :
    Observe nonnullR (uninitR ty q).
  Proof.
    rewrite nonnullR_eq uninitR_eq. apply monPred_observe=>p /=. apply _.
  Qed.
  Axiom anyR_nonnull_observe : ∀ {ty q}, Observe nonnullR (anyR ty q).
  #[global] Existing Instance anyR_nonnull_observe.

  #[global] Instance blockR_nonnull n q :
    TCLt (0 ?= n)%N -> Observe nonnullR (blockR n q).
  Proof.
    rewrite TCLt_N blockR_eq/blockR_def.
    destruct (N.to_nat n) eqn:Hn; [ lia | ] => {Hn} /=.
    rewrite o_sub_0 ?_offsetR_id; [ | by eauto].
    apply _.
  Qed.
  #[global] Instance blockR_valid_ptr sz q : Observe validR (blockR sz q).
  Proof.
    rewrite blockR_eq/blockR_def.
    destruct sz.
    { iIntros "[#A _]".
      rewrite o_sub_0; last by econstructor.
      rewrite _offsetR_id. eauto. }
    { iIntros "[_ X]".
      simpl. destruct (Pos.to_nat p) eqn:?; first lia.
      simpl. iDestruct "X" as "[X _]".
      rewrite o_sub_0; last by econstructor. rewrite _offsetR_id.
      iApply (observe with "X"). }
  Qed.

  #[global] Instance tblockR_nonnull n ty q :
    SizeOf ty n -> TCLt (0 ?= n)%N ->
    Observe nonnullR (tblockR ty q).
  Proof.
    intros Heq ?. rewrite/tblockR {}Heq.
    case_match; by apply _.
  Qed.

  #[global] Instance tblockR_valid_ptr ty q : Observe validR (tblockR ty q).
  Proof.
    rewrite /tblockR. case_match; refine _.
    case_match; refine _.
  Qed.

  #[global] Instance type_ptrR_observe_nonnull ty :
    Observe nonnullR (type_ptrR ty).
  Proof.
    apply monPred_observe=>p /=.
    rewrite monPred_at_type_ptrR nonnullR_eq /=. refine _.
  Qed.
End with_cpp.

#[global] Typeclasses Opaque identityR.
#[global] Typeclasses Opaque type_ptrR validR svalidR alignedR.

#[deprecated(note="since 2022-04-07; use `nonnullR` instead")]
Notation is_nonnull := nonnullR (only parsing).
#[deprecated(note="since 2022-04-07; use `nonnullR_eq` instead")]
Notation is_nonnull_eq := nonnullR_eq (only parsing).
#[deprecated(note="since 2022-04-07; use `nonnullR_def` instead")]
Notation is_nonnull_def := nonnullR_def (only parsing).

#[deprecated(note="since 2022-04-07; use `nullR` instead")]
Notation is_null := nullR (only parsing).
#[deprecated(note="since 2022-04-07; use `nullR_eq` instead")]
Notation is_null_eq := nullR_eq (only parsing).
#[deprecated(note="since 2022-04-07; use `nullR_def` instead")]
Notation is_null_def := nullR_def (only parsing).


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Seqs Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* auxiliary lemmas *)

Lemma enc_bits_drop E n ls bs :
  enc_bits E ls bs -> enc_bits E (drop n ls) (drop n bs) .
Proof .
  move => Hlsbs .
  move : (enc_bits_size Hlsbs) => Hsize .
  move : ls bs Hsize Hlsbs n .
  apply : seq_ind2 => [|ls_hd bs_hd ls_tl bs_tl Hsize IH] .
  - by rewrite /= .
  - rewrite enc_bits_cons => /andP [Hlsbshd Hlsbstl] .
    case => [|n] .
    + by rewrite /= enc_bits_cons Hlsbshd Hlsbstl .
    + by rewrite /= (IH Hlsbstl) .
Qed .

Lemma newer_than_lits_drop g n ls :
  newer_than_lits g ls -> newer_than_lits g (drop n ls) .
Proof .
  elim : ls n => [|ls_hd ls_tl IH] n .
  - by rewrite /= .
  - rewrite newer_than_lits_cons => /andP [Hlshd Hlstl] .
    case : n => [|n] .
    + rewrite /=; apply /andP; split; assumption .
    + by rewrite /= (IH n) .
Qed .

(* ===== bit_blast_high ===== *)

Definition bit_blast_high g n ls : generator * cnf * word :=
  (g, [::], copy (n - size ls) lit_ff ++ drop (size ls - n) ls) .

Definition mk_env_high E g n ls : env * generator * cnf * word :=
  (E, g, [::], copy (n - size ls) lit_ff ++ drop (size ls - n) ls) .

Lemma bit_blast_high_correct E g n bs ls g' cs lrs :
  bit_blast_high g n ls = (g', cs, lrs) ->
  enc_bits E ls bs -> interp_cnf E (add_prelude cs) ->
  enc_bits E lrs (high n bs) .
Proof .
  rewrite /bit_blast_high /high; case => _ <- <- Hlsbs Hcnf .
  rewrite (enc_bits_size Hlsbs) /zeros /b0 enc_bits_cat; first done .
  - apply: enc_bits_copy. exact: (add_prelude_enc_bit_ff Hcnf).
  - exact : (enc_bits_drop (size bs - n) Hlsbs) .
Qed .

Lemma mk_env_high_is_bit_blast_high E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) ->
  bit_blast_high g n ls = (g', cs, lrs) .
Proof .
  by rewrite /mk_env_high /bit_blast_high; case => _ <- <- <- .
Qed .

Lemma mk_env_high_newer_gen E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) -> (g <=? g')%positive .
Proof .
  rewrite /mk_env_high; by t_auto_newer .
Qed .

Lemma mk_env_high_newer_res E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls -> newer_than_lits g' lrs .
Proof .
  rewrite /mk_env_high; case => _ <- _ <- Htt Hls .
  rewrite newer_than_lits_cat .
  apply /andP; split .
  - exact : newer_than_lits_copy .
  - exact : newer_than_lits_drop .
Qed .

Lemma mk_env_high_newer_cnf E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls ->
  newer_than_cnf g' cs .
Proof .
  by rewrite /mk_env_high; case => _ <- <- _ .
Qed .

Lemma mk_env_high_preserve E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) -> env_preserve E E' g .
Proof .
  by rewrite /mk_env_high; case => <- _ _ _ .
Qed .

Lemma mk_env_high_sat E g n ls E' g' cs lrs :
  mk_env_high E g n ls = (E', g', cs, lrs) ->
  newer_than_lits g ls -> interp_cnf E' cs .
Proof .
  by rewrite /mk_env_high; case => <- _ <- _ _ .
Qed .

Lemma mk_env_high_env_equal E1 E2 g n ls E1' E2' g1 g2 cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_high E1 g n ls = (E1', g1, cs1, lrs1) ->
  mk_env_high E2 g n ls = (E2', g2, cs2, lrs2) ->
  env_equal E1' E2' /\ g1 = g2 /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_high => Heq.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Compile-time evaluation of initializers for global C variables. *)

Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import AST.
Require Import Memory.
Require Import Ctypes.
Require Import Cop.
Require Import Csyntax.

Open Scope error_monad_scope.

(** * Evaluation of compile-time constant expressions *)

(** To evaluate constant expressions at compile-time, we use the same [value]
  type and the same [sem_*] functions that are used in CompCert C's semantics
  (module [Csem]).  However, we interpret pointer values symbolically:
  [Vptr (Zpos id) ofs] represents the address of global variable [id]
  plus byte offset [ofs]. *)

(** [constval a] evaluates the constant expression [a].

If [a] is a r-value, the returned value denotes:
- [Vint n], [Vfloat f]: the corresponding number
- [Vptr id ofs]: address of global variable [id] plus byte offset [ofs]
- [Vundef]: erroneous expression

If [a] is a l-value, the returned value denotes:
- [Vptr id ofs]: global variable [id] plus byte offset [ofs]
*)

Definition do_cast (v: val) (t1 t2: type) : res val :=
  match sem_cast v t1 t2 with
  | Some v' => OK v'
  | None => Error(msg "undefined cast")
  end.

Fixpoint constval (a: expr) : res val :=
  match a with
  | Eval v ty =>
      match v with
      | Vint _ | Vfloat _ => OK v
      | Vptr _ _ | Vundef => Error(msg "illegal constant")
      end
  | Evalof l ty =>
      match access_mode ty with
      | By_reference | By_copy => constval l
      | _ => Error(msg "dereferencing of an l-value")
      end
  | Eaddrof l ty =>
      constval l
  | Eunop op r1 ty =>
      do v1 <- constval r1;
      match sem_unary_operation op v1 (typeof r1) with
      | Some v => OK v
      | None => Error(msg "undefined unary operation")
      end
  | Ebinop op r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match sem_binary_operation op v1 (typeof r1) v2 (typeof r2) Mem.empty with
      | Some v => OK v
      | None => Error(msg "undefined binary operation")
      end
  | Ecast r ty =>
      do v1 <- constval r; do_cast v1 (typeof r) ty
  | Esizeof ty1 ty =>
      OK (Vint (Int.repr (sizeof ty1)))
  | Ealignof ty1 ty =>
      OK (Vint (Int.repr (alignof ty1)))
  | Eseqand r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some true => do v3 <- do_cast v2 (typeof r2) type_bool; do_cast v3 type_bool ty
      | Some false => OK (Vint Int.zero)
      | None => Error(msg "undefined && operation")
      end
  | Eseqor r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some false => do v3 <- do_cast v2 (typeof r2) type_bool; do_cast v3 type_bool ty
      | Some true => OK (Vint Int.one)
      | None => Error(msg "undefined || operation")
      end
  | Econdition r1 r2 r3 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      do v3 <- constval r3;
      match bool_val v1 (typeof r1) with
      | Some true => do_cast v2 (typeof r2) ty
      | Some false => do_cast v3 (typeof r3) ty
      | None => Error(msg "condition is undefined")
      end
  | Ecomma r1 r2 ty =>
      do v1 <- constval r1; constval r2
  | Evar x ty =>
      OK(Vptr (Zpos x) Int.zero)
  | Ederef r ty =>
      constval r
  | Efield l f ty =>
      match typeof l with
      | Tstruct id fList _ =>
          do delta <- field_offset f fList;
          do v <- constval l;
          OK (Val.add v (Vint (Int.repr delta)))
      | Tunion id fList _ =>
          constval l
      | _ =>
          Error(msg "ill-typed field access")
      end
  | Eparen r ty =>
      do v <- constval r; do_cast v (typeof r) ty
  | _ =>
    Error(msg "not a compile-time constant")
  end.

(** * Translation of initializers *)

Inductive initializer :=
  | Init_single (a: expr)
  | Init_compound (il: initializer_list)
with initializer_list :=
  | Init_nil
  | Init_cons (i: initializer) (il: initializer_list).

(** Translate an initializing expression [a] for a scalar variable
  of type [ty].  Return the corresponding initialization datum. *)

Definition transl_init_single (ty: type) (a: expr) : res init_data :=
  do v1 <- constval a;
  do v2 <- do_cast v1 (typeof a) ty;
  match v2, ty with
  | Vint n, Tint I8 sg _ => OK(Init_int8 n)
  | Vint n, Tint I16 sg _ => OK(Init_int16 n)
  | Vint n, Tint I32 sg _ => OK(Init_int32 n)
  | Vint n, Tpointer _ _ => OK(Init_int32 n)
  | Vfloat f, Tfloat F32 _ => OK(Init_float32 f)
  | Vfloat f, Tfloat F64 _ => OK(Init_float64 f)
  | Vptr (Zpos id) ofs, Tint I32 sg _ => OK(Init_addrof id ofs)
  | Vptr (Zpos id) ofs, Tpointer _ _ => OK(Init_addrof id ofs)
  | Vundef, _ => Error(msg "undefined operation in initializer")
  | _, _ => Error (msg "type mismatch in initializer")
  end.

(** Translate an initializer [i] for a variable of type [ty].
  Return the corresponding list of initialization data. *)

Definition padding (frm to: Z) : list init_data :=
  let n := to - frm in
  if zle n 0 then nil else Init_space n :: nil.

Fixpoint transl_init (ty: type) (i: initializer)
                     {struct i} : res (list init_data) :=
  match i, ty with
  | Init_single a, _ =>
      do d <- transl_init_single ty a; OK (d :: nil)
  | Init_compound il, Tarray tyelt sz _ =>
      if zle sz 0
      then OK (Init_space(sizeof tyelt) :: nil)
      else transl_init_array tyelt il sz
  | Init_compound il, Tstruct _ Fnil _ =>
      OK (Init_space (sizeof ty) :: nil)
  | Init_compound il, Tstruct id fl _ =>
      transl_init_struct id ty fl il 0
  | Init_compound il, Tunion _ Fnil _ =>
      OK (Init_space (sizeof ty) :: nil)
  | Init_compound il, Tunion id (Fcons _ ty1 _) _ =>
      transl_init_union id ty ty1 il
  | _, _ =>
      Error (msg "wrong type for compound initializer")
  end

with transl_init_array (ty: type) (il: initializer_list) (sz: Z)
                       {struct il} : res (list init_data) :=
  match il with
  | Init_nil =>
      if zeq sz 0
      then OK nil
      else Error (msg "wrong number of elements in array initializer")
  | Init_cons i1 il' =>
      do d1 <- transl_init ty i1;
      do d2 <- transl_init_array ty il' (sz - 1);
      OK (d1 ++ d2)
  end

with transl_init_struct (id: ident) (ty: type)
                        (fl: fieldlist) (il: initializer_list) (pos: Z)
                        {struct il} : res (list init_data) :=
  match il, fl with
  | Init_nil, Fnil =>
      OK (padding pos (sizeof ty))
  | Init_cons i1 il', Fcons _ ty1 fl' =>
      let pos1 := align pos (alignof ty1) in
      do d1 <- transl_init (unroll_composite id ty ty1) i1;
      do d2 <- transl_init_struct id ty fl' il' (pos1 + sizeof ty1);
      OK (padding pos pos1 ++ d1 ++ d2)
  | _, _ =>
      Error (msg "wrong number of elements in struct initializer")
  end

with transl_init_union (id: ident) (ty ty1: type) (il: initializer_list)
                       {struct il} : res (list init_data) :=
  match il with
  | Init_nil =>
      Error (msg "empty union initializer")
  | Init_cons i1 _ =>
      do d <- transl_init (unroll_composite id ty ty1) i1;
      OK (d ++ padding (sizeof ty1) (sizeof ty))
  end.


Require Import Vars.
Require Import PhaserMap.
Require Import Phaser.
Require Import Syntax.
Require Import TaskMap.

(** A state pairs the state of all phasers and the state of all tasks. *)

Definition state := (phasermap * taskmap) % type.

Definition get_tasks (s:state) :taskmap := snd s.
Definition get_phasers (s:state) : phasermap := fst s.

Import Syntax.CST.

(** Control-flow reduction: *)

Module ControlFlow.
Inductive Reduces : cflow -> prog -> prog -> Prop :=
  | r_skip:
    forall p,
    Reduces skip p p
  | r_iter:
    forall p q,
    Reduces (loop p) q (concat p (LOOP(p);; q))
  | r_elide:
    forall p q,
    Reduces (loop p) q q.
End ControlFlow.

(** Small step semantics for states. *)

Inductive Reduces: state -> state -> Prop :=
  | r_new_task:
  (** Creates a new task. Task id [t'] must not be present in
      defined in the task map. *)
    forall (t t':tid) (p:prog) (pm:phasermap) (tm:taskmap),
    TaskMap.MapsTo t (t' <- NEW_TID;; p) tm ->
    ~ TaskMap.In t' tm ->
    Reduces (pm, tm) (pm, newTask tm t')
  | r_fork:
    (** Fork assigns a program to an "empty" task. *)
    forall (t t':tid) (p p':prog) (pm:phasermap) (tm:taskmap),
    TaskMap.MapsTo t (FORK(t', p');; p) tm ->
    TaskMap.MapsTo t' pnil tm ->
    Reduces (pm, tm) (pm, (TaskMap.add t p (TaskMap.add t' p' tm)))
  | r_phaser:
    (** Invokes a phaser operation on a given phaser identifier. *)
    forall (o:PhaserMap.op) (t:tid) (p:prog) (pm:phasermap) (tm:taskmap),
    TaskMap.MapsTo t ((pm_op o) ;; p) tm ->
    Reduces (pm, tm) ((PhaserMap.eval pm t o), (TaskMap.add t p tm))
  | r_cflow:
    (** Runs a control-flow operation. *)
    forall t c p q pm tm,
    TaskMap.MapsTo t (CFLOW c;; p) tm ->
    ControlFlow.Reduces c p q ->
    Reduces (pm, tm) (pm, (TaskMap.add t q tm)).

(** Creates a new state from a given program. *)

Definition load (t:tid) (b:prog) := (PhaserMap.make, TaskMap.add t b TaskMap.make).

(* begin hide *)

(* Naive substitution, does not replace names in newphaser. *)

Fixpoint phid_subst (o_ph:phid) (n_ph:phid) (b:prog) :=
  let subst := phid_subst o_ph n_ph in
  match b with
    | pcons i b' =>
      let rest := subst b' in
      let same := i ;; rest in
      match i with
        | pm_op mo =>
          match mo with
            | PhaserMap.NEW ph =>
              if PHID.eq_dec o_ph ph
              then b
              else same
            | PhaserMap.APP ph o =>
              if PHID.eq_dec o_ph ph
              then pm_op (PhaserMap.APP n_ph o) ;; rest
              else same
          end
        | fork t p => fork t (subst p) ;; rest
        | c_op c =>
          match c with
            | loop p => LOOP (subst p) ;; rest
            | skip => same
          end
        | _ => same
      end
    | END => END
  end.

Fixpoint tid_subst (o_t:tid) (n_t:tid) (b:prog) :=
  let subst := tid_subst o_t n_t in
  match b with
    | pcons i b' =>
      let kont := subst b' in
      let same := i ;; kont in
      match i with
        | new_tid t =>
          if TID.eq_dec o_t t
          then b (* no substitution *)
          else same
        | fork t p =>
          if TID.eq_dec o_t t
          then fork n_t (subst p) ;; kont
          else fork t (subst p) ;; kont
        | pm_op po =>
          match po with
            | PhaserMap.APP p o =>
              match o with
                | Phaser.REG t =>
                  if TID.eq_dec o_t t
                  then REG(p, n_t) ;; kont
                  else same
                | _ => same
              end
            | _ => same
          end
        | c_op c =>
          match c with
            | loop p => LOOP (subst p) ;; kont
            | skip => same
          end
        | _ => same
      end
    | END => END
  end.

(* end hide *)