(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
Require Import ssreflect ssrfun ssrbool.
From MetaCoq.Utils Require Import utils MCPred.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
  PCUICLiftSubst PCUICUnivSubst
  PCUICEquality PCUICSigmaCalculus PCUICClosed.

Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
Set Equations With UIP.

(** * Preservation of free variables *)

Open Scope sigma_scope.
Set Keyed Unification.

Set Default Goal Selector "!".

(** Hint database for solving closed/on_free_vars goals *)
Create HintDb fvs.
Ltac fvs := eauto with fvs.

Implicit Type (cf : checker_flags).

Definition shiftnP k p i :=
  (i <? k) || p (i - k).

#[global]
Instance shiftnP_ext k : Proper (`=1` ==> `=1`) (shiftnP k).
Proof. intros f g Hfg i. now rewrite /shiftnP Hfg. Qed.

Lemma shiftnP0 P : shiftnP 0 P =1 P.
Proof. rewrite /shiftnP. intros i; rewrite Nat.sub_0_r //. Qed.

Lemma shiftnP_add n k P : shiftnP n (shiftnP k P) =1 shiftnP (n + k) P.
Proof. rewrite /shiftnP. intros i; repeat nat_compare_specs => // /=. lia_f_equal. Qed.

Lemma shiftnP_shiftn P f i : (shiftnP i P) ∘ (shiftn i f) =1 shiftnP i (P ∘ f).
Proof.
  intros k.
  rewrite !/shiftnP /shiftn.
  destruct (Nat.ltb_spec k i) => /=.
  all: nat_compare_specs => //=.
  by rewrite Nat.add_comm Nat.add_sub.
Qed.

Lemma shiftnP_impl (p q : nat -> bool) : (forall i, p i -> q i) ->
  forall n i, shiftnP n p i -> shiftnP n q i.
Proof.
  intros Hi n i. rewrite /shiftnP.
  nat_compare_specs => //. apply Hi.
Qed.

Lemma shiftnP_S P n : shiftnP (S n) P =1 shiftnP 1 (shiftnP n P).
Proof. now rewrite (shiftnP_add 1). Qed.

Definition closedP (n : nat) (P : nat -> bool) :=
  fun i => if i <? n then P i else false.

#[global]
Instance closedP_proper n : Proper (`=1` ==> `=1`) (closedP n).
Proof. intros f g Hfg. intros i; rewrite /closedP. now rewrite Hfg. Qed.

Lemma shiftnP_closedP k n P : shiftnP k (closedP n P) =1 closedP (k + n) (shiftnP k P).
Proof.
  intros i; rewrite /shiftnP /closedP.
  repeat nat_compare_specs => //.
Qed.

Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool :=
  match t with
  | tRel i => p i
  | tEvar ev args => List.forallb (on_free_vars p) args
  | tLambda _ T M | tProd _ T M => on_free_vars p T && on_free_vars (shiftnP 1 p) M
  | tApp u v => on_free_vars p u && on_free_vars p v
  | tLetIn na b t b' => [&& on_free_vars p b, on_free_vars p t & on_free_vars (shiftnP 1 p) b']
  | tCase ind pred c brs =>
    [&& forallb (on_free_vars p) pred.(pparams),
      on_free_vars (shiftnP #|pred.(pcontext)| p) pred.(preturn),
      test_context_k (fun k => on_free_vars (closedP k xpredT)) #|pred.(pparams)| pred.(pcontext),
      on_free_vars p c &
      forallb (fun br =>
        test_context_k (fun k => on_free_vars (closedP k xpredT)) #|pred.(pparams)| br.(bcontext) &&
        on_free_vars (shiftnP #|br.(bcontext)| p) br.(bbody)) brs]
  | tProj _ c => on_free_vars p c
  | tFix mfix idx | tCoFix mfix idx =>
    List.forallb (test_def (on_free_vars p) (on_free_vars (shiftnP #|mfix| p))) mfix
  | tVar _ | tSort _ | tConst _ _ | tInd _ _ | tConstruct _ _ _ => true
  | tPrim _ => true
  end.

Lemma on_free_vars_ext (p q : nat -> bool) t :
  p =1 q ->
  on_free_vars p t = on_free_vars q t.
Proof.
  revert p q.
  induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros;
    unfold test_def;
    rewrite ?forallb_map; try eapply All_forallb_eq_forallb; tea; eauto 2.
  all: try now rewrite (IHt1 p q) // ?(IHt2 (shiftnP 1 p) (shiftnP 1 q)) // H.
  - now rewrite (IHt1 p q) // ?(IHt2 p q) // (IHt3 (shiftnP 1 p) (shiftnP 1 q)) // H.
  - rewrite (IHt1 p q) // (IHt2 p q) //.
  - destruct X as [? [? ?]]. red in X0.
    f_equal.
    * eapply All_forallb_eq_forallb; tea. solve_all.
    * f_equal; [eapply e; rewrite H //|].
      f_equal.
      f_equal; [eapply IHt; rewrite H //|].
        eapply All_forallb_eq_forallb; tea. intros.
        destruct X.
        f_equal. eapply e0; rewrite H //.
  - simpl; intuition auto. f_equal; eauto 2.
    eapply b; rewrite H //.
  - simpl; intuition auto. f_equal; eauto 2.
    eapply b; rewrite H //.
Qed.

#[global]
Instance on_free_vars_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars.
Proof. intros f g Hfg ? ? ->. now apply on_free_vars_ext. Qed.

#[global]
Instance on_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars.
Proof. intros f g Hfg x. now apply on_free_vars_ext. Qed.

Lemma shiftnP_xpredT n : shiftnP n xpredT =1 xpredT.
Proof. intros i; rewrite /shiftnP. nat_compare_specs => //. Qed.

Lemma test_context_k_ctx p k (ctx : context) : test_context_k (fun=> p) k ctx = test_context p ctx.
Proof.
  induction ctx; simpl; auto.
Qed.
#[global]
Hint Rewrite test_context_k_ctx : map.

(* (* (* Lemma on_free_vars_true t : on_free_vars xpredT t.
Proof.
  revert t.
  induction t using PCUICInduction.term_forall_list_ind; simpl => //; solve_all.
  all:try (rtoProp; now rewrite ?shiftnP_xpredT ?IHt1 ?IHt2 ?IHt3; eauto 2;
    try rtoProp; solve_all).
  - rtoProp. setoid_rewrite shiftnP_xpredT.
    rewrite test_context_k_ctx.
    now move/onctxP: a0.
  - setoid_rewrite shiftnP_xpredT.
    rewrite test_context_k_ctx.
    now move/onctxP: a1.
  - unfold test_def in *. apply /andP. now rewrite shiftnP_xpredT.
  - unfold test_def in *. apply /andP. now rewrite shiftnP_xpredT.
Qed. *)

Lemma on_free_vars_xpredT : on_free_vars xpredT =1 xpredT.
Proof.
  intros t; apply on_free_vars_true.
Qed. *)

Lemma test_context_k_true n ctx : test_context_k (fun=> on_free_vars xpredT) n ctx.
Proof.
  setoid_rewrite on_free_vars_xpredT.
  induction ctx; simpl; auto.
  rewrite /test_decl IHctx /=.
  destruct a as [na [b|] ty] => /= //.
Qed. *)

Lemma on_free_vars_impl (p q : nat -> bool) t :
  (forall i, p i -> q i) ->
  on_free_vars p t ->
  on_free_vars q t.
Proof.
  unfold pointwise_relation, Basics.impl.
  intros Himpl onf. revert onf Himpl.
  revert t p q.
  induction t using PCUICInduction.term_forall_list_ind; simpl => //; solve_all.
  all:unfold test_def in *; rtoProp; now (eauto using shiftnP_impl with all).
Qed.

Lemma closedP_on_free_vars {n t} : closedn n t = on_free_vars (closedP n xpredT) t.
Proof.
  revert t n.
  apply: term_forall_list_ind; simpl => //; intros.
  all:(rewrite ?shiftnP_closedP ?shiftnP_xpredT).
  all:try (rtoProp; now rewrite ?H ?H0 ?H1 ?andb_assoc).
  - rewrite /closedP /=. now nat_compare_specs.
  - solve_all.
  - destruct X. rtoProp. rewrite /test_predicate_k /= !andb_assoc.
    rewrite H /=. f_equal. 2:solve_all.
    * f_equal. rewrite andb_comm andb_assoc. f_equal; solve_all.
      rewrite andb_comm. f_equal; solve_all.
    * rewrite /test_branch_k. f_equal; solve_all.
      rewrite b0.
      now rewrite shiftnP_closedP shiftnP_xpredT.
  - unfold test_def. solve_all.
    rewrite shiftnP_closedP shiftnP_xpredT.
    now len in b.
  - unfold test_def; solve_all.
    rewrite shiftnP_closedP shiftnP_xpredT.
    now len in b.
Qed.

Lemma closedn_on_free_vars {P n t} : closedn n t -> on_free_vars (shiftnP n P) t.
Proof.
  rewrite closedP_on_free_vars.
  eapply on_free_vars_impl.
  intros i; rewrite /closedP /shiftnP /= //.
  nat_compare_specs => //.
Qed.

(** Any predicate is admissible as there are no free variables to consider *)
Lemma closed_on_free_vars_none {t} : closed t = on_free_vars xpred0 t.
Proof.
  now rewrite closedP_on_free_vars /closedP /=.
Qed.

Lemma closed_on_free_vars {P t} : closed t -> on_free_vars P t.
Proof.
  rewrite closedP_on_free_vars /closedP /=.
  eapply on_free_vars_impl => //.
Qed.

Lemma on_free_vars_subst_instance {p u t} : on_free_vars p (subst_instance u t) = on_free_vars p t.
Proof.
  rewrite /subst_instance /=. revert t p.
  apply: term_forall_list_ind; simpl => //; intros.
  all:try (rtoProp; now rewrite -?IHt1 -?IHt2 -?IHt3).
  - rewrite forallb_map. eapply All_forallb_eq_forallb; eauto.
  - repeat (solve_all; f_equal).
  - unfold test_def. solve_all.
  - unfold test_def; solve_all.
Qed.

Definition on_free_vars_decl P d :=
  test_decl (on_free_vars P) d.

#[global]
Instance on_free_vars_decl_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars_decl.
Proof. rewrite /on_free_vars_decl => f g Hfg x y <-. now rewrite Hfg. Qed.

#[global]
Instance on_free_vars_decl_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars_decl.
Proof. rewrite /on_free_vars_decl => f g Hfg x. now rewrite Hfg. Qed.

Definition on_free_vars_ctx P ctx :=
  alli (fun k => (on_free_vars_decl (shiftnP k P))) 0 (List.rev ctx).

#[global]
Instance on_free_vars_ctx_proper : Proper (`=1` ==> `=1`) on_free_vars_ctx.
Proof.
  rewrite /on_free_vars_ctx => f g Hfg x.
  now setoid_rewrite Hfg.
Qed.

Notation is_open_term Γ := (on_free_vars (shiftnP #|Γ| xpred0)).
Notation is_open_decl Γ := (on_free_vars_decl (shiftnP #|Γ| xpred0)).
Notation is_closed_context := (on_free_vars_ctx xpred0).

Lemma on_free_vars_decl_impl (p q : nat -> bool) d :
  (forall i, p i -> q i) ->
  on_free_vars_decl p d -> on_free_vars_decl q d.
Proof.
  intros hpi.
  apply test_decl_impl. intros t.
  now apply on_free_vars_impl.
Qed.

Lemma on_free_vars_ctx_impl (p q : nat -> bool) ctx :
  (forall i, p i -> q i) ->
  on_free_vars_ctx p ctx -> on_free_vars_ctx q ctx.
Proof.
  intros hpi.
  eapply alli_impl => i x.
  apply on_free_vars_decl_impl.
  intros k; rewrite /shiftnP.
  now nat_compare_specs.
Qed.

Lemma closed_decl_on_free_vars {n d} : closed_decl n d = on_free_vars_decl (closedP n xpredT) d.
Proof.
  rewrite /on_free_vars_decl /test_decl.
  rewrite !closedP_on_free_vars /=.
  destruct (decl_body d) eqn:db => /= //.
  now rewrite closedP_on_free_vars.
Qed.

Lemma closedn_ctx_on_free_vars {n ctx} : closedn_ctx n ctx = on_free_vars_ctx (closedP n xpredT) ctx.
Proof.
  rewrite /on_free_vars_ctx test_context_k_eq.
  eapply alli_ext. intros i d.
  rewrite shiftnP_closedP shiftnP_xpredT Nat.add_comm.
  apply closed_decl_on_free_vars.
Qed.

Lemma closedP_shiftnP (n : nat) : closedP n xpredT =1 shiftnP n xpred0.
Proof.
  rewrite /closedP /shiftnP => i.
  destruct Nat.ltb => //.
Qed.

Lemma closedP_shiftnP_impl n P i : closedP n xpredT i -> shiftnP n P i.
Proof.
  rewrite closedP_shiftnP.
  rewrite /shiftnP.
  nat_compare_specs => //.
Qed.

Lemma closedn_ctx_on_free_vars_shift {n ctx P} :
  closedn_ctx n ctx ->
  on_free_vars_ctx (shiftnP n P) ctx.
Proof.
  rewrite closedn_ctx_on_free_vars.
  rewrite /on_free_vars_ctx.
  apply alli_impl => i x.
  eapply on_free_vars_decl_impl => //.
  intros k. rewrite shiftnP_add shiftnP_closedP shiftnP_xpredT.
  apply closedP_shiftnP_impl.
Qed.

(** This uses absurdity elimination as [ctx] can't have any free variable *)
Lemma closed_ctx_on_free_vars P ctx : closed_ctx ctx -> on_free_vars_ctx P ctx.
Proof.
  rewrite closedn_ctx_on_free_vars => /=.
  rewrite /closedP /=.
  eapply on_free_vars_ctx_impl => //.
Qed.

Definition nocc_betweenp k n i :=
  (i <? k) || (k + n <=? i).

Definition nocc_between k n t :=
  (on_free_vars (nocc_betweenp k n) t).

Definition noccur_shift p k := fun i => (i <? k) || p (i - k).

#[global] Hint Resolve All_forallb_eq_forallb : all.

Definition strengthenP k n (p : nat -> bool) :=
  fun i => if i <? k then p i else
    if i <? k + n then false
    else p (i - n).

#[global]
Instance strengthenP_proper n k : Proper (`=1` ==> `=1`) (strengthenP n k).
Proof.
  intros f g Hfg i. rewrite /strengthenP. now rewrite (Hfg i) (Hfg (i - k)).
Qed.

Lemma shiftnP_strengthenP k' k n p :
  shiftnP k' (strengthenP k n p) =1 strengthenP (k' + k) n (shiftnP k' p).
Proof.
  intros i. rewrite /shiftnP /strengthenP.
  repeat nat_compare_specs => /= //.
  lia_f_equal.
Qed.

Lemma on_free_vars_lift (p : nat -> bool) n k t :
  on_free_vars (strengthenP k n p) (lift n k t) = on_free_vars p t.
Proof.
  intros. revert t n k p.
  induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros;
    rewrite ?forallb_map; try eapply All_forallb_eq_forallb; tea; simpl.
  2-6:try now rewrite ?shiftnP_strengthenP ?IHt1 ?IHt2 ?IHt3.
  - rename n0 into i. rewrite /strengthenP.
    repeat nat_compare_specs => //.
    lia_f_equal.
  - rtoProp; solve_all. len; rewrite !shiftnP_strengthenP e IHt.
    f_equal; solve_all. f_equal; solve_all. f_equal; solve_all. f_equal.
    solve_all.
    f_equal; solve_all.
    len. now rewrite !shiftnP_strengthenP.
  - unfold test_def in *. simpl; intros ? [].
    len; rewrite shiftnP_strengthenP. f_equal; eauto.
  - unfold test_def in *. simpl; intros ? [].
    len; rewrite shiftnP_strengthenP. f_equal; eauto.
Qed.

Definition on_free_vars_terms p s :=
  forallb (on_free_vars p) s.

Definition substP (k : nat) n (q p : nat -> bool) : nat -> bool :=
  fun i =>
    if i <? k then p i
    else p (i + n) || strengthenP 0 k q i.

Lemma shiftnP_substP k' k n q p :
  shiftnP k' (substP k n q p) =1 substP (k' + k) n q (shiftnP k' p).
Proof.
  intros i; rewrite /shiftnP /substP.
  repeat nat_compare_specs => /= //.
  f_equal; [f_equal|] => /= //.
  * lia_f_equal.
  * rewrite /strengthenP. simpl.
    repeat nat_compare_specs => //.
    lia_f_equal.
Qed.

Lemma on_free_vars_subst_gen (p q : nat -> bool) s k t :
  on_free_vars_terms q s ->
  on_free_vars p t ->
  on_free_vars (substP k #|s| q p) (subst s k t).
Proof.
  revert t p k.
  induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros;
    simpl.
  all:try (rtoProp; rewrite ?shiftnP_substP; now rewrite ?IHt1 ?IHt2 ?IHt3).
  - intros. destruct (Nat.leb_spec k n).
    * destruct nth_error eqn:eq.
      + unfold on_free_vars_terms in *. toAll.
        pose proof (nth_error_Some_length eq).
        eapply nth_error_all in eq; eauto.
        simpl in eq. rewrite /substP.
        eapply on_free_vars_impl.
        2:now rewrite -> on_free_vars_lift.
        rewrite /strengthenP. simpl.
        intros i. nat_compare_specs => //.
        intros ->. now rewrite orb_true_r.
      + eapply nth_error_None in eq.
        simpl. rewrite /substP.
        replace (n - #|s| + #|s|) with n by lia.
        nat_compare_specs.
        now rewrite H0.
    * simpl. rewrite /substP /strengthenP /=.
      rewrite H0. now nat_compare_specs.
  - solve_all.
  - rtoProp. destruct X. solve_all.
    * len. rewrite shiftnP_substP. solve_all.
    * len. rewrite shiftnP_substP; solve_all.
  - unfold test_def in *; red in X; solve_all.
    rtoProp. rewrite shiftnP_substP; len. solve_all.
  - unfold test_def in *; solve_all. rtoProp.
    rewrite shiftnP_substP; len. solve_all.
Qed.

Lemma rshiftk_S x f : S (rshiftk x f) = rshiftk (S x) f.
Proof. reflexivity. Qed.

Lemma substP_shiftnP n p :
  substP 0 n p (shiftnP n p) =1 p.
Proof.
  intros i; rewrite /shiftnP /substP /= /strengthenP /=.
  nat_compare_specs.
  replace (i + n - n) with i by lia.
  now rewrite Nat.sub_0_r orb_diag.
Qed.

Lemma on_free_vars_subst (p : nat -> bool) s t :
  forallb (on_free_vars p) s ->
  on_free_vars (shiftnP #|s| p) t ->
  on_free_vars p (subst s 0 t).
Proof.
  intros hs ht.
  epose proof (on_free_vars_subst_gen (shiftnP #|s| p) p s 0 t).
  rewrite -> substP_shiftnP in H.
  apply H.
  - exact hs.
  - apply ht.
Qed.

Lemma on_free_vars_subst1 (p : nat -> bool) s t :
  on_free_vars p s ->
  on_free_vars (shiftnP 1 p) t ->
  on_free_vars p (subst1 s 0 t).
Proof.
  intros hs ht.
  rewrite /subst1.
  epose proof (on_free_vars_subst_gen (shiftnP 1 p) p [s] 0 t).
  rewrite -> substP_shiftnP in H.
  apply H.
  - now rewrite /on_free_vars_terms /= hs.
  - apply ht.
Qed.

Definition addnP n (p : nat -> bool) :=
  fun i => p (n + i).

#[global]
Instance addnP_proper n : Proper (`=1` ==> Logic.eq ==> Logic.eq) (addnP n).
Proof.
  intros i f g Hfg; now rewrite /addnP.
Qed.

#[global]
Instance addnP_proper_pointwise : Proper (Logic.eq ==> `=1` ==> `=1`) addnP.
Proof.
  intros i f g Hfg; now rewrite /addnP.
Qed.

Lemma addnP_add n k p : addnP n (addnP k p) =1 addnP (n + k) p.
Proof.
  rewrite /addnP => i. lia_f_equal.
Qed.

Lemma addnP0 p : addnP 0 p =1 p.
Proof. reflexivity. Qed.

Lemma addnP_shiftnP n P : addnP n (shiftnP n P) =1 P.
Proof.
  intros i; rewrite /addnP /shiftnP /=.
  nat_compare_specs => /=. lia_f_equal.
Qed.

Lemma addnP_orP n p q : addnP n (predU p q) =1 predU (addnP n p) (addnP n q).
Proof. reflexivity. Qed.

Definition on_ctx_free_vars P ctx :=
  alli (fun k d => P k ==> (on_free_vars_decl (addnP (S k) P) d)) 0 ctx.

#[global]
Instance on_ctx_free_vars_proper : Proper (`=1` ==> eq ==> eq) on_ctx_free_vars.
Proof.
  rewrite /on_ctx_free_vars => f g Hfg x y <-.
  apply alli_ext => k.
  now setoid_rewrite Hfg.
Qed.

#[global]
Instance on_ctx_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_ctx_free_vars.
Proof.
  rewrite /on_ctx_free_vars => f g Hfg x.
  apply alli_ext => k.
  now setoid_rewrite Hfg.
Qed.

Lemma nth_error_on_free_vars_ctx P n ctx i d :
  on_ctx_free_vars (addnP n P) ctx ->
  P (n + i) ->
  nth_error ctx i = Some d ->
  test_decl (on_free_vars (addnP (n + S i) P)) d.
Proof.
  rewrite /on_ctx_free_vars.
  solve_all.
  eapply alli_Alli, Alli_nth_error in H; eauto.
  rewrite /= {1}/addnP H0 /= in H.
  now rewrite Nat.add_comm -addnP_add.
Qed.

Definition aboveP k (p : nat -> bool) :=
  fun i => if i <? k then false else p i.

Lemma strengthenP_addn i p : strengthenP 0 i (addnP i p) =1 aboveP i p.
Proof.
   intros k.
   rewrite /strengthenP /= /addnP /aboveP.
   nat_compare_specs => //.
   lia_f_equal.
Qed.

Lemma on_free_vars_lift0 i p t :
  on_free_vars (addnP i p) t ->
  on_free_vars p (lift0 i t).
Proof.
  rewrite -(on_free_vars_lift _ i 0).
  rewrite /strengthenP /= /aboveP /addnP.
  unshelve eapply on_free_vars_impl.
  simpl. intros i'. nat_compare_specs => //.
  now replace (i + (i' - i)) with i' by lia.
Qed.

Lemma on_free_vars_lift0_above i p t :
  on_free_vars (addnP i p) t = on_free_vars (aboveP i p) (lift0 i t).
Proof.
  rewrite -(on_free_vars_lift _ i 0).
  rewrite /strengthenP /= /aboveP /addnP.
  unshelve eapply on_free_vars_ext.
  simpl. intros i'. nat_compare_specs => //.
  now replace (i' - i + i) with i' by lia.
Qed.

Lemma on_free_vars_mkApps p f args :
  on_free_vars p (mkApps f args) = on_free_vars p f && forallb (on_free_vars p) args.
Proof.
  induction args in f |- * => /=.
  - now rewrite andb_true_r.
  - now rewrite IHargs /= andb_assoc.
Qed.

Lemma extended_subst_shiftn p ctx n k :
  forallb (on_free_vars (strengthenP 0 n (shiftnP (k + context_assumptions ctx) p)))
    (extended_subst ctx (n + k)) =
  forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p))
    (extended_subst ctx k).
Proof.
  rewrite lift_extended_subst' forallb_map.
  eapply forallb_ext => t.
  rewrite -(on_free_vars_lift _ n 0 t) //.
Qed.

Lemma extended_subst_shiftn_aboveP p ctx n k :
  forallb (on_free_vars (aboveP n p)) (extended_subst ctx (n + k)) =
  forallb (on_free_vars (addnP n p)) (extended_subst ctx k).
Proof.
  rewrite lift_extended_subst' forallb_map.
  eapply forallb_ext => t.
  rewrite -(on_free_vars_lift0_above) //.
Qed.

Lemma extended_subst_shiftn_impl p ctx n k :
  forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p))
    (extended_subst ctx k) ->
  forallb (on_free_vars (shiftnP (n + k + context_assumptions ctx) p))
    (extended_subst ctx (n + k)).
Proof.
  rewrite lift_extended_subst' forallb_map.
  eapply forallb_impl => t _.
  rewrite -(on_free_vars_lift _ n 0 t).
  rewrite /strengthenP /=.
  apply on_free_vars_impl => i.
  rewrite /shiftnP.
  repeat nat_compare_specs => /= //.
  intros.
  red; rewrite -H2. lia_f_equal.
Qed.

Definition occ_betweenP k n :=
  fun i => (k <=? i) && (i <? k + n).

Lemma on_free_vars_decl_all_term P d s :
  on_free_vars_decl P d = on_free_vars P (mkProd_or_LetIn d (tSort s)).
Proof.
  rewrite /on_free_vars_decl /= /test_decl.
  destruct d as [na [b|] ty] => /= //; now rewrite andb_true_r.
Qed.

Lemma on_free_vars_mkProd_or_LetIn P d t :
  on_free_vars P (mkProd_or_LetIn d t) =
  on_free_vars_decl P d && on_free_vars (shiftnP 1 P) t.
Proof.
  destruct d as [na [b|] ty]; rewrite /mkProd_or_LetIn /on_free_vars_decl /test_decl /=
    ?andb_assoc /foroptb /=; try bool_congr.
Qed.

Lemma on_free_vars_ctx_all_term P ctx s :
  on_free_vars_ctx P ctx = on_free_vars P (it_mkProd_or_LetIn ctx (tSort s)).
Proof.
  rewrite /on_free_vars_ctx.
  rewrite -{2}[P](shiftnP0 P).
  generalize 0 as k.
  induction ctx using rev_ind; simpl; auto; intros k.
  rewrite List.rev_app_distr alli_app /= andb_true_r.
  rewrite IHctx it_mkProd_or_LetIn_app /= on_free_vars_mkProd_or_LetIn.
  now rewrite shiftnP_add.
Qed.

Definition on_free_vars_ctx_k P n ctx :=
  alli (fun k => (on_free_vars_decl (shiftnP k P))) n (List.rev ctx).

Definition predA {A} (p q : pred A) : simpl_pred A :=
  [pred i | p i ==> q i].

Definition eq_simpl_pred {A} (x y : simpl_pred A) :=
  `=1` x y.

#[global]
Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predA A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predA /=.
  now rewrite Hfg Hfg'.
Qed.

Lemma on_free_vars_implP p q t :
  predA p q =1 xpredT ->
  on_free_vars p t -> on_free_vars q t.
Proof.
  rewrite /predA /=. intros Hp.
  eapply on_free_vars_impl.
  intros i hp. specialize (Hp i). now rewrite /= hp in Hp.
Qed.

Definition shiftnP_predU n p q :
  shiftnP n (predU p q) =1 predU (shiftnP n p) (shiftnP n q).
Proof.
  intros i.
  rewrite /shiftnP /predU /=.
  repeat nat_compare_specs => //.
Qed.

#[global]
Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predU A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predU /=.
  now rewrite Hfg Hfg'.
Qed.

#[global]
Instance andP_Proper A : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predI A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predI /=.
  now rewrite Hfg Hfg'.
Qed.

#[global]
Instance pred_of_simpl_proper {A} : Proper (eq_simpl_pred ==> `=1`) (@PredOfSimpl.coerce A).
Proof.
  now move=> f g; rewrite /eq_simpl_pred => Hfg.
Qed.

Lemma orPL (p q : pred nat) : (predA p (predU p q)) =1 predT.
Proof.
  intros i. rewrite /predA /predU /=.
  rewrite (ssrbool.implybE (p i)).
  destruct (p i) => //.
Qed.

Lemma orPR (p q : nat -> bool) i : q i -> (predU p q) i.
Proof.
  rewrite /predU /= => ->; rewrite orb_true_r //.
Qed.

(** We need a disjunction here as the substitution can be made of
    expanded lets (properly lifted) or just the variables of
    [ctx] (lifted by [k]).

    The proof could certainly be simplified using a more high-level handling of
    free-variables predicate, which form a simple classical algebra.
    To investigate: does ssr's library support this? *)

Lemma on_free_vars_extended_subst p k ctx :
  on_free_vars_ctx_k p k ctx ->
  forallb (on_free_vars
    (predU (strengthenP 0 (context_assumptions ctx + k) (shiftnP k p))
      (occ_betweenP k (context_assumptions ctx))))
    (extended_subst ctx k).
Proof.
  rewrite /on_free_vars_ctx_k.
  induction ctx as [|[na [b|] ty] ctx] in p, k |- *; auto.
  - simpl. rewrite alli_app /= andb_true_r => /andP [] hctx.
    rewrite /on_free_vars_decl /test_decl /=; len => /andP [] hty /= hb.
    specialize (IHctx _ k hctx).
    rewrite IHctx // andb_true_r.
    eapply on_free_vars_subst => //.
    len. erewrite on_free_vars_implP => //; cycle 1.
    { erewrite on_free_vars_lift; eauto. }
    now rewrite shiftnP_predU /= shiftnP_strengthenP Nat.add_0_r shiftnP_add /= orPL.
  - cbn. rewrite alli_app /= andb_true_r => /andP [] hctx.
    rewrite /on_free_vars_decl /test_decl /= => hty.
    len in hty.
    specialize (IHctx p k).
    rewrite andb_idl.
    * move => _. rewrite /occ_betweenP. repeat nat_compare_specs => /= //.
    * specialize (IHctx hctx).
      rewrite (lift_extended_subst' _ 1).
      rewrite forallb_map.
      solve_all.
      apply on_free_vars_lift0.
      rewrite addnP_orP.
      eapply on_free_vars_implP; eauto.
      intros i. rewrite /predA /predU /=.
      rewrite /strengthenP /= /addnP /=.
      repeat nat_compare_specs => /= //.
      + rewrite /occ_betweenP /implb => /=.
        repeat nat_compare_specs => /= //.
      + rewrite /shiftnP /occ_betweenP /=.
        repeat nat_compare_specs => /= //.
        rewrite !orb_false_r.
        replace (i + 1 - S (context_assumptions ctx + k) - k) with
          (i - (context_assumptions ctx + k) - k) by lia.
        rewrite implybE. destruct p; auto.
Qed.

Lemma on_free_vars_expand_lets_k P Γ n t :
  n = context_assumptions Γ ->
  on_free_vars_ctx P Γ ->
  on_free_vars (shiftnP #|Γ| P) t ->
  on_free_vars (shiftnP n P) (expand_lets_k Γ 0 t).
Proof.
  intros -> HΓ Ht.
  rewrite /expand_lets_k /=.
  eapply on_free_vars_impl; cycle 1.
  - eapply on_free_vars_subst_gen.
    1:eapply on_free_vars_extended_subst; eauto.
    rewrite -> on_free_vars_lift. eauto.
  - len. rewrite /substP /= /strengthenP /=.
    intros i. simpl. rewrite /shiftnP.
    repeat nat_compare_specs => /= //.
    rewrite Nat.sub_0_r. rewrite /orP.
    replace (i + #|Γ| - context_assumptions Γ - #|Γ|) with (i - context_assumptions Γ) by lia.
    rewrite /occ_betweenP. repeat nat_compare_specs => /= //.
    rewrite orb_false_r Nat.sub_0_r.
    now rewrite orb_diag.
Qed.

Lemma on_free_vars_terms_inds P ind puinst bodies :
  on_free_vars_terms P (inds ind puinst bodies).
Proof.
  rewrite /inds.
  induction #|bodies|; simpl; auto.
Qed.

Lemma on_free_vars_decl_map P f d :
  (forall i, on_free_vars P i = on_free_vars P (f i)) ->
  on_free_vars_decl P d = on_free_vars_decl P (map_decl f d).
Proof.
  intros Hi.
  rewrite /on_free_vars_decl /test_decl.
  rewrite Hi. f_equal.
  simpl. destruct (decl_body d) => //.
  now rewrite /foroptb /= (Hi t).
Qed.

Lemma on_free_vars_ctx_subst_instance P u Γ :
  on_free_vars_ctx P (subst_instance u Γ) = on_free_vars_ctx P Γ.
Proof.
  rewrite /on_free_vars_ctx.
  rewrite /subst_instance -map_rev alli_map.
  apply alli_ext => i d.
  symmetry. apply on_free_vars_decl_map.
  intros. now rewrite on_free_vars_subst_instance.
Qed.

Lemma on_free_vars_map2_cstr_args p bctx ctx :
  #|bctx| = #|ctx| ->
  on_free_vars_ctx p ctx =
  on_free_vars_ctx p (map2 set_binder_name bctx ctx).
Proof.
  rewrite /on_free_vars_ctx.
  induction ctx as [|d ctx] in bctx |- *; simpl; auto.
  - destruct bctx; reflexivity.
  - destruct bctx => /= //.
    intros [= hlen].
    rewrite alli_app (IHctx bctx) // alli_app. f_equal.
    len. rewrite map2_length // hlen. f_equal.
Qed.

Lemma on_free_vars_to_extended_list P ctx :
  forallb (on_free_vars (shiftnP #|ctx| P)) (to_extended_list ctx).
Proof.
  rewrite /to_extended_list /to_extended_list_k.
  change #|ctx| with (0 + #|ctx|).
  have: (forallb (on_free_vars (shiftnP (0 + #|ctx|) P)) []) by easy.
  generalize (@nil term), 0.
  induction ctx; intros l n.
  - simpl; auto.
  - simpl. intros Hl.
    destruct a as [? [?|] ?].
    * rewrite Nat.add_succ_r in Hl.
      specialize (IHctx _ (S n) Hl).
      now rewrite Nat.add_succ_r Nat.add_1_r.
    * rewrite Nat.add_succ_r Nat.add_1_r. eapply (IHctx _ (S n)).
      rewrite -[_ + _](Nat.add_succ_r n #|ctx|) /= Hl.
      rewrite /shiftnP.
      nat_compare_specs => /= //.
Qed.

(** This is less precise than the strengthenP lemma above *)
Lemma on_free_vars_lift_impl (p : nat -> bool) (n k : nat) (t : term) :
  on_free_vars (shiftnP k p) t ->
  on_free_vars (shiftnP (n + k) p) (lift n k t).
Proof.
  rewrite -(on_free_vars_lift _ n k t).
  eapply on_free_vars_impl.
  intros i.
  rewrite /shiftnP /strengthenP.
  repeat nat_compare_specs => /= //.
  now replace (i - n - k) with (i - (n + k)) by lia.
Qed.

Lemma foron_free_vars_extended_subst brctx p :
  on_free_vars_ctx p brctx ->
  forallb (on_free_vars (shiftnP (context_assumptions brctx) p))
    (extended_subst brctx 0).
Proof.
  move/on_free_vars_extended_subst.
  eapply forallb_impl.
  intros x hin.
  rewrite Nat.add_0_r shiftnP0.
  eapply on_free_vars_impl.
  intros i. rewrite /orP /strengthenP /= /occ_betweenP /shiftnP.
  repeat nat_compare_specs => /= //.
  now rewrite orb_false_r.
Qed.

Lemma on_free_vars_fix_subst P mfix idx :
  on_free_vars P (tFix mfix idx) ->
  forallb (on_free_vars P) (fix_subst mfix).
Proof.
  move=> /=; rewrite /fix_subst.
  intros hmfix. generalize hmfix.
  induction mfix at 2 4; simpl; auto.
  move/andP => [ha hm]. rewrite IHm // andb_true_r //.
Qed.

Lemma on_free_vars_unfold_fix P mfix idx narg fn :
  unfold_fix mfix idx = Some (narg, fn) ->
  on_free_vars P (tFix mfix idx) ->
  on_free_vars P fn.
Proof.
  rewrite /unfold_fix.
  destruct nth_error eqn:hnth => // [=] _ <- /=.
  intros hmfix; generalize hmfix.
  move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody.
  eapply on_free_vars_subst; len => //.
  eapply (on_free_vars_fix_subst _ _ idx) => //.
Qed.

Lemma on_free_vars_cofix_subst P mfix idx :
  on_free_vars P (tCoFix mfix idx) ->
  forallb (on_free_vars P) (cofix_subst mfix).
Proof.
  move=> /=; rewrite /cofix_subst.
  intros hmfix. generalize hmfix.
  induction mfix at 2 4; simpl; auto.
  move/andP => [ha hm]. rewrite IHm // andb_true_r //.
Qed.

Lemma on_free_vars_unfold_cofix P mfix idx narg fn :
  unfold_cofix mfix idx = Some (narg, fn) ->
  on_free_vars P (tCoFix mfix idx) ->
  on_free_vars P fn.
Proof.
  rewrite /unfold_cofix.
  destruct nth_error eqn:hnth => // [=] _ <- /=.
  intros hmfix; generalize hmfix.
  move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody.
  eapply on_free_vars_subst; len => //.
  eapply (on_free_vars_cofix_subst _ _ idx) => //.
Qed.

Lemma lenm_eq {n m} : n <= m -> n - m = 0.
Proof. lia. Qed.

Lemma addnP_shiftnP_comm n (P : nat -> bool) : P 0 -> addnP 1 (shiftnP n P) =1 shiftnP n (addnP 1 P).
Proof.
  intros p0 i; rewrite /addnP /shiftnP /=.
  repeat nat_compare_specs => /= //.
  - now rewrite (lenm_eq H0).
  - lia_f_equal.
Qed.

Lemma on_ctx_free_vars_concat P Γ Δ :
  on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ) =
  on_ctx_free_vars P Γ && on_ctx_free_vars (shiftnP #|Δ| P) Δ.
Proof.
  rewrite /on_ctx_free_vars alli_app.
  rewrite /= alli_shiftn andb_comm; f_equal.
  eapply alli_ext => i d /=.
  rewrite {1}/shiftnP. nat_compare_specs.
  replace (#|Δ| + i - #|Δ|) with i by lia.
  simpl. f_equal.
  replace (S (#|Δ| + i)) with (S i + #|Δ|) by lia.
  now rewrite -addnP_add addnP_shiftnP.
Qed.

Lemma on_ctx_free_vars_tip P d : on_ctx_free_vars P [d] = P 0 ==> on_free_vars_decl (addnP 1 P) d.
Proof.
  now rewrite /on_ctx_free_vars /= /= andb_true_r.
Qed.

Lemma shiftnPS n P : shiftnP (S n) P n.
Proof.
  rewrite /shiftnP /=.
  now nat_compare_specs.
Qed.

Lemma shiftnPSS n i P : shiftnP (S n) P (S i) = shiftnP n P i.
Proof.
  rewrite /shiftnP /=. lia_f_equal.
Qed.

Lemma closedP_xpredT n i : closedP n xpredT i -> xpredT i.
Proof.
  rewrite /closedP /xpredT. auto.
Qed.

Lemma on_free_vars_ctx_on_ctx_free_vars {P Γ} :
  on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ| P) Γ =
  on_free_vars_ctx P Γ.
Proof.
  induction Γ => /= //.
  rewrite /on_free_vars_ctx /= alli_app /= andb_true_r; len.
  setoid_rewrite <-(shiftnP_add 1 #|Γ|); rewrite addnP_shiftnP andb_comm.
  f_equal. rewrite /on_free_vars_ctx in IHΓ. rewrite -IHΓ.
  rewrite (alli_shift _ _ 1) /=.
  apply alli_ext => i d /=.
  now rewrite shiftnPSS -(Nat.add_1_r (S i)) -addnP_add addnP_shiftnP.
Qed.

(* Lemma on_ctx_free_vars_impl {P Q Γ} *)

Lemma on_free_vars_ctx_on_ctx_free_vars_xpredT {P Γ} :
  on_free_vars_ctx P Γ ->
  on_ctx_free_vars xpredT Γ.
Proof.
  move/(on_free_vars_ctx_impl _ xpredT _ ltac:(easy)).
  now rewrite -on_free_vars_ctx_on_ctx_free_vars shiftnP_xpredT.
Qed.

Lemma on_ctx_free_vars_extend P Γ Δ :
  on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ) =
  on_ctx_free_vars P Γ && on_free_vars_ctx P Δ.
Proof.
  rewrite on_ctx_free_vars_concat => //. f_equal.
  apply on_free_vars_ctx_on_ctx_free_vars.
Qed.

Lemma on_free_vars_fix_context P mfix :
  All (fun x : def term =>
      test_def (on_free_vars P) (on_free_vars (shiftnP #|mfix| P)) x)
      mfix ->
  on_free_vars_ctx P (fix_context mfix).
Proof.
  intros a.
  assert (All (fun x => on_free_vars P x.(dtype)) mfix).
  { solve_all. now move/andP: H=> []. } clear a.
  induction mfix using rev_ind; simpl; auto.
  rewrite /fix_context /= mapi_app List.rev_app_distr /=.
  rewrite /on_free_vars_ctx /= alli_app. len.
  rewrite andb_true_r.
  eapply All_app in X as [X Hx].
  depelim Hx. clear Hx.
  specialize (IHmfix X).
  rewrite /on_free_vars_ctx in IHmfix.
  rewrite IHmfix /= /on_free_vars_decl /test_decl /= /=.
  apply on_free_vars_lift0.
  now rewrite addnP_shiftnP.
Qed.

Lemma test_context_k_on_free_vars_ctx P ctx :
  test_context_k (fun k => on_free_vars (shiftnP k P)) 0 ctx =
  on_free_vars_ctx P ctx.
Proof.
  now rewrite test_context_k_eq.
Qed.

(* Not necessary for the above lemma, but still useful at some point presumably,
   e.g. for strenghtening *)
(*
Lemma on_free_vars_case_predicate_context {cf} {Σ} {wfΣ : wf Σ} {P ci mdecl idecl p} :
   let pctx := case_predicate_context ci mdecl idecl p in
   declared_inductive Σ ci mdecl idecl ->
   wf_predicate mdecl idecl p ->
   forallb (on_free_vars P) (pparams p) ->
   on_free_vars (shiftnP #|pcontext p| P) (preturn p) ->
   on_free_vars_ctx P pctx.
 Proof.
   intros pctx decli wfp wfb havp.
   rewrite /pctx /case_predicate_context /case_predicate_context_gen
     /pre_case_predicate_context_gen /ind_predicate_context.
   set (ibinder := {| decl_name := _ |}).
   rewrite -on_free_vars_map2_cstr_args /=; len.
   { eapply (wf_predicate_length_pcontext wfp). }
   rewrite alli_app; len; rewrite andb_true_r.
   apply andb_true_iff. split.
   - rewrite -/(on_free_vars_ctx P _).
     rewrite (on_free_vars_ctx_all_term _ _ Universe.type0).
     rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)).
     apply on_free_vars_subst.
     { rewrite forallb_rev => //. }
     rewrite -on_free_vars_ctx_all_term.
     rewrite on_free_vars_ctx_subst_instance.
     rewrite (on_free_vars_ctx_all_term _ _ (Universe.type0)).
     rewrite -(expand_lets_it_mkProd_or_LetIn _ _ 0 (tSort _)).
     eapply on_free_vars_expand_lets_k; len.
     * rewrite (wf_predicate_length_pars wfp).
       apply (declared_minductive_ind_npars decli).
     * eapply closed_ctx_on_free_vars.
       apply (declared_inductive_closed_params decli).
     * eapply on_free_vars_impl; cycle 1.
       { rewrite <- on_free_vars_ctx_all_term.
         instantiate (1 := closedP #|mdecl.(ind_params)| xpredT).
         eapply closedn_ctx_on_free_vars.
         move: (declared_inductive_closed_pars_indices wfΣ decli).
         now rewrite closedn_ctx_app => /andP []. }
        intros i'.
       rewrite /substP /= /closedP /shiftnP. len.
       now repeat nat_compare_specs => /= //.
   - rewrite /on_free_vars_decl /ibinder /test_decl /= /foroptb /=.
     rewrite on_free_vars_mkApps /= forallb_app /=.
     rewrite on_free_vars_to_extended_list /= andb_true_r.
     rewrite -/(is_true _).
     rewrite forallb_map. unshelve eapply (forallb_impl _ _ _ _ wfb).
     intros. simpl.
     eapply on_free_vars_lift0. now rewrite addnP_shiftnP.
 Qed.

 Lemma on_free_vars_case_branch_context {cf} {Σ} {wfΣ : wf Σ} {P ci i mdecl idecl p br cdecl} :
   let brctx := case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl in
   declared_constructor Σ (ci, i) mdecl idecl cdecl ->
   wf_predicate mdecl idecl p ->
   wf_branch cdecl br ->
   forallb (on_free_vars P) (pparams p) ->
   on_free_vars_ctx P brctx.
 Proof.
   intros brctx decli wfp wfb havp.
   rewrite /brctx /case_branch_context /case_branch_context_gen.
   rewrite (on_free_vars_ctx_all_term _ _ Universe.type0).
   rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)).
   apply on_free_vars_subst => //.
   { rewrite forallb_rev //. }
   rewrite -(expand_lets_it_mkProd_or_LetIn _ _ 0 (tSort _)).
   eapply on_free_vars_expand_lets_k; len.
   * rewrite (wf_predicate_length_pars wfp).
     apply (declared_minductive_ind_npars decli).
   * eapply closed_ctx_on_free_vars.
     rewrite closedn_subst_instance_context.
     apply (declared_inductive_closed_params decli).
   * rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)).
     eapply on_free_vars_impl; cycle 1.
     + eapply (on_free_vars_subst_gen _ P).
       { eapply on_free_vars_terms_inds. }
       rewrite -on_free_vars_ctx_all_term.
       rewrite on_free_vars_ctx_subst_instance.
       rewrite -on_free_vars_map2_cstr_args.
       { len. apply (wf_branch_length wfb). }
       instantiate (1 := closedP (#|mdecl.(ind_bodies)| + #|mdecl.(ind_params)|) xpredT).
       eapply closedn_ctx_on_free_vars.
       now move/andP: (declared_constructor_closed wfΣ decli) => [] /andP [].
     + intros i'.
       rewrite /substP /= /closedP /shiftnP. len.
       now repeat nat_compare_specs => /= //.
 Qed.
*)

Lemma on_free_vars_ctx_inst_case_context P n pars puinst ctx :
  n = #|pars| ->
  forallb (on_free_vars P) pars ->
  test_context_k (fun k => on_free_vars (closedP k xpredT)) n ctx ->
  on_free_vars_ctx P (inst_case_context pars puinst ctx).
Proof.
  intros hpars hn.
  rewrite /inst_case_context.
  rewrite test_context_k_eq.
  rewrite (on_free_vars_ctx_all_term _ _ Universe.type0).
  rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)).
  intros a.
  apply on_free_vars_subst => //.
  { rewrite forallb_rev //. }
  rewrite -on_free_vars_ctx_all_term.
  rewrite on_free_vars_ctx_subst_instance.
  len. subst n.
  rewrite /on_free_vars_ctx.
  setoid_rewrite shiftnP_add.
  unshelve eapply (alli_impl _ _ _ _ _ a).
  cbn; intros.
  rewrite /on_free_vars_decl.
  eapply test_decl_impl; tea.
  intros. eapply on_free_vars_impl; tea.
  intros k. rewrite Nat.add_comm.
  apply closedP_shiftnP_impl.
Qed.

Lemma on_ctx_free_vars_snoc {P Γ d} :
  on_ctx_free_vars (shiftnP 1 P) (Γ ,, d) =
  on_ctx_free_vars P Γ && on_free_vars_decl P d.
Proof.
  rewrite (on_ctx_free_vars_concat _ _ [_]) /=. f_equal.
  now rewrite on_ctx_free_vars_tip {1}/shiftnP /= addnP_shiftnP.
Qed.

#[global]
Hint Rewrite @on_ctx_free_vars_snoc : fvs.

Lemma test_context_k_closed_on_free_vars_ctx k ctx :
  test_context_k (fun k => on_free_vars (closedP k xpredT)) k ctx =
  on_free_vars_ctx (closedP k xpredT) ctx.
Proof.
  rewrite test_context_k_eq /on_free_vars_ctx.
  now setoid_rewrite shiftnP_closedP; setoid_rewrite shiftnP_xpredT; setoid_rewrite Nat.add_comm at 1.
Qed.

Lemma inv_on_free_vars_decl {P d} :
  on_free_vars_decl P d ->
  match d with
  | {| decl_body := None; decl_type := t |} => on_free_vars P t
  | {| decl_body := Some b; decl_type := t |} => on_free_vars P b /\ on_free_vars P t
  end.
Proof.
  unfold on_free_vars_decl, test_decl; destruct d; cbn => //.
  move/andP => [] //. destruct decl_body; cbn => //.
Qed.

Ltac inv_on_free_vars :=
  repeat match goal with
  | [ H : is_true (on_free_vars_decl _ (vass _ _)) |- _ ] => apply inv_on_free_vars_decl in H; cbn in H
  | [ H : is_true (on_free_vars_decl _ (vdef _ _ _)) |- _ ] => apply inv_on_free_vars_decl in H as []
  | [ H : is_true (_ && _) |- _ ] =>
    move/andP: H => []; intros
  | [ H : is_true (on_free_vars ?P ?t) |- _ ] =>
    progress (cbn in H || rewrite on_free_vars_mkApps in H);
    (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] ||
      eapply forallb_All in H); intros
  | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] =>
    move/andP: H => []; rewrite ?shiftnP_xpredT; intros
  | [ H : is_true (test_context_k _ _ _ ) |- _ ] =>
    rewrite -> test_context_k_closed_on_free_vars_ctx in H
  end.

Notation byfvs := (ltac:(cbn; eauto with fvs)) (only parsing).

Lemma on_free_vars_vass {P na t} :
  on_free_vars P t ->
  on_free_vars_decl P (vass na t).
Proof.
  rewrite /on_free_vars_decl /= /test_decl /=. rtoProp; tauto.
Qed.

Lemma on_free_vars_vdef {P na b t} :
  on_free_vars P b -> on_free_vars P t ->
  on_free_vars_decl P (vdef na b t).
Proof.
  rewrite /on_free_vars_decl /= /test_decl /=. rtoProp; tauto.
Qed.

#[global] Hint Resolve on_free_vars_vass on_free_vars_vdef : fvs.

Lemma onctx_All_fold P Q (Γ : context) :
  onctx P Γ ->
  (forall Γ x, All_fold Q Γ -> ondecl P x -> Q Γ x) ->
  All_fold Q Γ.
Proof.
  intros o H; induction o; constructor; auto.
Qed.

Lemma substP_shiftnP_gen k n p :
  substP k n p (shiftnP (k + n) p) =1 shiftnP k p.
Proof.
  intros i; rewrite /shiftnP /substP /= /strengthenP /=.
  repeat nat_compare_specs.
  - cbn.
    assert (i + n - (k + n) = i - k) by lia.
    rewrite H1. now rewrite orb_diag.
Qed.

Lemma on_free_vars_ctx_subst_context P s k ctx :
  on_free_vars_ctx (shiftnP (k + #|s|) P) ctx ->
  forallb (on_free_vars P) s ->
  on_free_vars_ctx (shiftnP k P) (subst_context s k ctx).
Proof.
  intros onctx ons.
  rewrite (on_free_vars_ctx_all_term _ _ Universe.type0).
  rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)).
  eapply on_free_vars_impl; revgoals.
  - eapply on_free_vars_subst_gen => //; tea.
    rewrite -on_free_vars_ctx_all_term //. exact onctx.
  - intros i. rewrite substP_shiftnP_gen //.
Qed.

Lemma on_free_vars_ctx_subst_context0 P s ctx :
  on_free_vars_ctx (shiftnP #|s| P) ctx ->
  forallb (on_free_vars P) s ->
  on_free_vars_ctx P (subst_context s 0 ctx).
Proof.
  intros onctx ons.
  rewrite -(shiftnP0 P). eapply on_free_vars_ctx_subst_context => /= //.
Qed.

Lemma on_free_vars_ctx_lift_context p k n ctx :
  on_free_vars_ctx p ctx =
  on_free_vars_ctx (strengthenP k n p) (lift_context n k ctx).
Proof.
  rewrite !(on_free_vars_ctx_all_term _ _ Universe.type0).
  rewrite -(lift_it_mkProd_or_LetIn _ _ _ (tSort _)).
  rewrite on_free_vars_lift => //.
Qed.

Lemma on_free_vars_ctx_lift_context0 p n ctx :
  on_free_vars_ctx (addnP n p) ctx ->
  on_free_vars_ctx p (lift_context n 0 ctx).
Proof.
  rewrite {1}(on_free_vars_ctx_lift_context _ 0 n) => h.
  eapply on_free_vars_ctx_impl; tea.
  rewrite /strengthenP /= /shiftnP /addnP => i.
  repeat nat_compare_specs => // /=.
  now replace (n + (i - n)) with i by lia.
Qed.

Lemma on_free_vars_ctx_snoc {P Γ d} :
  on_free_vars_ctx P (Γ ,, d) =
  on_free_vars_ctx P Γ && on_free_vars_decl (shiftnP #|Γ| P) d.
Proof.
  rewrite - !on_free_vars_ctx_on_ctx_free_vars /snoc /=.
  rewrite -(shiftnP_add 1) (on_ctx_free_vars_concat _ _ [_]) /=. f_equal.
  now rewrite on_ctx_free_vars_tip {1 2}/shiftnP /= addnP_shiftnP.
Qed.

Lemma on_free_vars_ctx_snoc_impl {P Γ d} :
  on_free_vars_ctx P (Γ ,, d) ->
  on_free_vars_ctx P Γ /\ on_free_vars_decl (shiftnP #|Γ| P) d.
Proof.
  now rewrite on_free_vars_ctx_snoc => /andP.
Qed.

Lemma on_free_vars_ctx_smash P Γ acc :
  on_free_vars_ctx P Γ ->
  on_free_vars_ctx (shiftnP #|Γ| P) acc ->
  on_free_vars_ctx P (smash_context acc Γ).
Proof.
  induction Γ in P, acc |- *.
  - cbn. now rewrite shiftnP0.
  - destruct a as [na [b|] ty].
    * rewrite /= on_free_vars_ctx_snoc /= => /andP[] onΓ.
      rewrite /on_free_vars_decl /test_decl /= /= => /andP[] onb onty onacc.
      eapply IHΓ => //.
      eapply on_free_vars_ctx_subst_context0 => /= //.
      + rewrite shiftnP_add //.
      + now rewrite onb //.
    * rewrite /= on_free_vars_ctx_snoc /= => /andP[] onΓ ont onacc.
      eapply IHΓ => //.
      rewrite -on_free_vars_ctx_on_ctx_free_vars /=; len.
      rewrite shiftnP_add -Nat.add_assoc -(shiftnP_add).
      rewrite on_ctx_free_vars_concat.
      rewrite on_free_vars_ctx_on_ctx_free_vars onacc /=.
      now rewrite /on_ctx_free_vars /= ont.
Qed.

Lemma on_free_vars_ctx_subst_context_xpredT s ctx :
  on_free_vars_ctx xpredT ctx ->
  forallb (on_free_vars xpredT) s ->
  on_free_vars_ctx xpredT (subst_context s 0 ctx).
Proof.
  intros onctx ons.
  apply on_free_vars_ctx_subst_context0 => //.
  rewrite shiftnP_xpredT //.
Qed.

Lemma on_free_vars_ctx_All_fold P Γ :
  on_free_vars_ctx P Γ <~> All_fold (fun Γ => on_free_vars_decl (shiftnP #|Γ| P)) Γ.
Proof.
  split.
  - now move/alli_Alli/Alli_rev_All_fold.
  - intros a. apply (All_fold_Alli_rev (fun k => on_free_vars_decl (shiftnP k P)) 0) in a.
    now apply alli_Alli.
Qed.

Lemma term_on_free_vars_ind :
  forall (P : (nat -> bool) -> term -> Type),
    (forall (p : nat -> bool) (i : nat), p i -> P p (tRel i)) ->
    (forall p (i : ident), P p (tVar i)) ->
    (forall p (id : nat) (l : list term),
      All (on_free_vars p) l ->
      All (P p) l ->
      P p (tEvar id l)) ->
    (forall p s, P p (tSort s)) ->
    (forall p (na : aname) (t : term) dom codom,
      on_free_vars p dom ->
      P p dom ->
      on_free_vars (shiftnP 1 p) codom ->
      P (shiftnP 1 p) codom ->
      P p (tProd na dom codom)) ->
    (forall p (na : aname) (ty : term) (body : term),
      on_free_vars p ty -> P p ty ->
      on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body ->
      P p (tLambda na ty body)) ->
    (forall p (na : aname) (def : term) (ty : term) body,
      on_free_vars p def -> P p def ->
      on_free_vars p ty -> P p ty ->
      on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body ->
      P p (tLetIn na def ty body)) ->
    (forall p (t u : term),
      on_free_vars p t -> P p t ->
      on_free_vars p u -> P p u -> P p (tApp t u)) ->
    (forall p s (u : list Level.t), P p (tConst s u)) ->
    (forall p (i : inductive) (u : list Level.t), P p (tInd i u)) ->
    (forall p (i : inductive) (c : nat) (u : list Level.t), P p (tConstruct i c u)) ->
    (forall p (ci : case_info) (pred : predicate term) discr brs,
      All (on_free_vars p) pred.(pparams) ->
      All (P p) pred.(pparams) ->
      on_free_vars_ctx (closedP #|pred.(pparams)| xpredT) pred.(pcontext) ->
      All_fold (fun Γ => ondecl (P (closedP (#|Γ| + #|pred.(pparams)|) xpredT))) pred.(pcontext) ->
      on_free_vars (shiftnP #|pred.(pcontext)| p) pred.(preturn) ->
      P (shiftnP #|pred.(pcontext)| p) pred.(preturn) ->
      on_free_vars p discr ->
      P p discr ->
      All (fun br =>
        [× on_free_vars_ctx (closedP #|pred.(pparams)| xpredT) br.(bcontext),
          All_fold (fun Γ => ondecl (P (closedP (#|Γ| + #|pred.(pparams)|) xpredT))) br.(bcontext),
          on_free_vars (shiftnP #|br.(bcontext)| p) br.(bbody) &
          P (shiftnP #|br.(bcontext)| p) br.(bbody)]) brs ->
      P p (tCase ci pred discr brs)) ->
    (forall p (s : projection) (t : term),
      on_free_vars p t -> P p t -> P p (tProj s t)) ->
    (forall p (m : mfixpoint term) (i : nat),
      tFixProp (on_free_vars p) (on_free_vars (shiftnP #|fix_context m| p)) m ->
      tFixProp (P p) (P (shiftnP #|fix_context m| p)) m -> P p (tFix m i)) ->
    (forall p (m : mfixpoint term) (i : nat),
      tFixProp (on_free_vars p) (on_free_vars (shiftnP #|fix_context m| p)) m ->
      tFixProp (P p) (P (shiftnP #|fix_context m| p)) m -> P p (tCoFix m i)) ->
    (forall p pr, P p (tPrim pr)) ->
    forall p (t : term), on_free_vars p t -> P p t.
Proof.
  intros until t. revert p t.
  fix auxt 2.
  move auxt at top.
  intros p t.
  destruct t; intros clt;  match goal with
                 H : _ |- _ => apply H
              end; auto; simpl in clt;
            try move/andP: clt => [cl1 cl2];
            try move/andP: cl2 => [cl2 cl3];
            try move/andP: cl3 => [cl3 cl4];
            try move/andP: cl4 => [cl4 cl5];
            try solve[apply auxt; auto]; simpl in *;
            try inv_on_free_vars; tas.

  - solve_all.
  - revert l clt.
    fix auxl' 1.
    destruct l; constructor; [|apply auxl'].
    * apply auxt. simpl in clt. now move/andP: clt  => [clt cll].
    * now move/andP: clt => [clt cll].

  - solve_all.
  - revert cl1. generalize (pparams p0).
    fix auxl' 1.
    case => [|t' ts] /= //; cbn => /andP[] Ht' Hts; constructor; [apply auxt|apply auxl'] => //.
  - rewrite -test_context_k_closed_on_free_vars_ctx in cl3.
    revert cl3. clear -auxt.
    generalize (pcontext p0).
    fix auxl 1.
    intros [].
    * cbn. intros _. constructor.
    * cbn. move/andP => [] cll clc.
      constructor.
      + now apply auxl.
      + destruct c as [na [b|] ty]; cbn in *; constructor; cbn; apply auxt || exact tt.
        { now move/andP: clc => []. }
        { now move/andP: clc => []. }
        apply clc.

  - rename cl5 into cl. revert brs cl. clear -auxt.
    fix auxl' 1.
    destruct brs; [constructor|].
    move=> /= /andP [/andP [clctx clb] cll].
    constructor; tas.
    * split => //.
      + now rewrite test_context_k_closed_on_free_vars_ctx in clctx.
      + move: clctx. clear -auxt.
        generalize (bcontext b).
        fix auxl 1.
        { intros [].
        * cbn. intros _. constructor.
        * cbn. move/andP => [] cll clc.
          constructor.
          + now apply auxl.
          + destruct c as [na [b'|] ty]; cbn in *; constructor; cbn; apply auxt || exact tt.
            { now move/andP: clc => []. }
            { now move/andP: clc => []. }
            apply clc. }
      + now apply auxt.
    * now apply auxl'.

  - red. len; solve_all;
     now move/andP: H=> [].

  - red.
    rewrite fix_context_length.
    revert clt.
    generalize (#|mfix|).
    revert mfix.
    fix auxm 1.
    destruct mfix; [constructor|].
    move=> n /= /andP[] /andP[] clb clty clmfix; constructor.
    * split => //; apply auxt => //.
    * now apply auxm.

  - red. len; solve_all;
    now move/andP: H=> [].

  - red.
    rewrite fix_context_length.
    revert clt.
    generalize (#|mfix|).
    revert mfix.
    fix auxm 1.
    destruct mfix; [constructor|].
    move=> n /= /andP[] /andP[] clb clty clmfix; constructor.
    * split => //; apply auxt => //.
    * now apply auxm.
Defined.

Lemma alpha_eq_on_free_vars P (Γ Δ : context) :
  All2 (PCUICEquality.compare_decls eq eq) Γ Δ ->
  on_free_vars_ctx P Γ -> on_free_vars_ctx P Δ.
Proof.
  induction 1; cbn; auto.
  rewrite !alli_app /= !andb_true_r.
  move/andP => [] IH hx.
  specialize (IHX IH).
  unfold PCUICOnFreeVars.on_free_vars_ctx in IHX.
  rewrite IHX /=.
  len in hx. len. rewrite -(All2_length X).
  destruct r; cbn in *; subst; auto.
Qed.

Lemma on_free_vars_ctx_any_xpredT P Γ :
  on_free_vars_ctx P Γ -> on_free_vars_ctx xpredT Γ.
Proof.
  intros. eapply on_free_vars_ctx_impl; tea => //.
Qed.

Lemma on_free_vars_ctx_on_ctx_free_vars_closedP Γ :
  on_ctx_free_vars (closedP #|Γ| xpredT) Γ =
  on_free_vars_ctx xpred0 Γ.
Proof.
  rewrite closedP_shiftnP on_free_vars_ctx_on_ctx_free_vars //.
Qed.

Lemma on_free_vars_ctx_on_ctx_free_vars_closedP_impl Γ :
  on_free_vars_ctx xpred0 Γ ->
  on_ctx_free_vars (closedP #|Γ| xpredT) Γ.
Proof.
  now rewrite on_free_vars_ctx_on_ctx_free_vars_closedP.
Qed.

Lemma on_free_vars_ctx_app P Γ Δ :
  on_free_vars_ctx P (Γ ,,, Δ) =
  on_free_vars_ctx P Γ && on_free_vars_ctx (shiftnP #|Γ| P) Δ.
Proof.
  rewrite /on_free_vars_ctx List.rev_app_distr alli_app. f_equal.
  rewrite List.rev_length alli_shift.
  setoid_rewrite shiftnP_add.
  setoid_rewrite Nat.add_comm at 1.
  now setoid_rewrite Nat.add_0_r.
Qed.

#[global] Hint Extern 4 (is_true (on_free_vars_ctx _ (_ ,,, _))) =>
  rewrite on_free_vars_ctx_app : fvs.

Lemma on_ctx_free_vars_snoc_ass P Γ na ty :
  on_ctx_free_vars P Γ ->
  on_free_vars P ty ->
  on_ctx_free_vars (PCUICOnFreeVars.shiftnP 1 P) (Γ ,, vass na ty).
Proof.
  now rewrite on_ctx_free_vars_snoc => -> /=; rewrite /on_free_vars_decl /test_decl /=.
Qed.

Lemma on_ctx_free_vars_snoc_def P Γ na def ty :
  on_ctx_free_vars P Γ ->
  on_free_vars P ty ->
  on_free_vars P def ->
  on_ctx_free_vars (PCUICOnFreeVars.shiftnP 1 P) (Γ ,, vdef na def ty).
Proof.
  now rewrite on_ctx_free_vars_snoc => -> /=; rewrite /on_free_vars_decl /test_decl /= => -> ->.
Qed.
#[global] Hint Resolve on_ctx_free_vars_snoc_def on_ctx_free_vars_snoc_ass : pcuic.

Lemma on_ctx_free_vars_snocS P Γ d :
  on_ctx_free_vars (PCUICOnFreeVars.shiftnP (S #|Γ|) P) (d :: Γ) =
  on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ| P) Γ && on_free_vars_decl (PCUICOnFreeVars.shiftnP #|Γ| P) d.
Proof.
  rewrite -(shiftnP_add 1).
  now rewrite on_ctx_free_vars_snoc.
Qed.

Lemma on_ctx_free_vars_inst_case_context P Γ pars puinst pctx :
  forallb (on_free_vars P) pars ->
  test_context_k (fun k : nat => on_free_vars (closedP k xpredT)) #|pars| pctx ->
  on_ctx_free_vars P Γ ->
  on_ctx_free_vars (shiftnP #|pctx| P) (Γ ,,, inst_case_context pars puinst pctx).
Proof.
  intros.
  relativize #|pctx|; [erewrite on_ctx_free_vars_concat|]; try now len.
  rewrite H1 /=.
  rewrite on_free_vars_ctx_on_ctx_free_vars.
  eapply on_free_vars_ctx_inst_case_context; trea.
Qed.
#[global] Hint Resolve on_ctx_free_vars_inst_case_context : fvs.

Lemma on_free_vars_ctx_inst_case_context_weak P Γ pars puinst pctx :
  forallb (on_free_vars (shiftnP #|Γ| P)) pars ->
  test_context_k (fun k : nat => on_free_vars (closedP k xpredT)) #|pars| pctx ->
  on_free_vars_ctx P Γ ->
  on_free_vars_ctx P (Γ ,,, inst_case_context pars puinst pctx).
Proof.
  intros.
  rewrite on_free_vars_ctx_app H1 /=.
  eapply on_free_vars_ctx_inst_case_context; trea.
Qed.
#[global] Hint Resolve on_free_vars_ctx_inst_case_context : fvs.

Lemma on_ctx_free_vars_fix_context P Γ mfix :
  All (fun x : def term => test_def (on_free_vars P) (on_free_vars (shiftnP #|mfix| P)) x) mfix ->
  on_ctx_free_vars P Γ ->
  on_ctx_free_vars (shiftnP #|mfix| P) (Γ ,,, fix_context mfix).
Proof.
  intros.
  relativize #|mfix|; [erewrite on_ctx_free_vars_concat|].
  - rewrite H /=.
    rewrite on_free_vars_ctx_on_ctx_free_vars.
    eapply on_free_vars_fix_context => //.
  - now len.
Qed.

Lemma on_free_vars_ctx_fix_context_weak P Γ mfix :
  All (fun x : def term => test_def (on_free_vars (shiftnP #|Γ| P)) (on_free_vars (shiftnP #|mfix| (shiftnP #|Γ| P))) x) mfix ->
  on_free_vars_ctx P Γ ->
  on_free_vars_ctx P (Γ ,,, fix_context mfix).
Proof.
  intros.
  rewrite -on_free_vars_ctx_on_ctx_free_vars; len.
  rewrite -shiftnP_add.
  eapply on_ctx_free_vars_fix_context => //.
  now rewrite on_free_vars_ctx_on_ctx_free_vars.
Qed.

#[global] Hint Resolve on_ctx_free_vars_fix_context : fvs.
#[global] Hint Resolve on_free_vars_ctx_fix_context_weak : fvs.
#[global] Hint Resolve on_ctx_free_vars_snoc_ass on_ctx_free_vars_snoc_def : fvs.
#[global] Hint Resolve on_ctx_free_vars_inst_case_context : fvs.
#[global] Hint Extern 3 (is_true (_ && _)) => apply/andP; idtac : fvs.
#[global] Hint Extern 4 (is_true (on_ctx_free_vars (shiftnP _ xpred0) _)) =>
  rewrite on_free_vars_ctx_on_ctx_free_vars : fvs.

Lemma on_free_vars_ctx_snoc_ass P Γ na t :
  on_free_vars_ctx P Γ ->
  on_free_vars (shiftnP #|Γ| P) t ->
  on_free_vars_ctx P (Γ ,, vass na t).
Proof.
  intros onΓ ont.
  rewrite on_free_vars_ctx_snoc onΓ /=; eauto with fvs.
Qed.

Lemma on_free_vars_ctx_snoc_def P Γ na b t :
  on_free_vars_ctx P Γ ->
  on_free_vars (shiftnP #|Γ| P) b ->
  on_free_vars (shiftnP #|Γ| P) t ->
  on_free_vars_ctx P (Γ ,, vdef na b t).
Proof.
  intros onΓ ont.
  rewrite on_free_vars_ctx_snoc onΓ /=; eauto with fvs.
Qed.

#[global] Hint Resolve on_free_vars_ctx_snoc_ass on_free_vars_ctx_snoc_def : fvs.

Lemma on_free_vars_all_subst P s :
  All (on_free_vars P) s ->
  forall x, on_free_vars xpredT ((s ⋅n ids) x).
Proof.
  induction 1 => n; rewrite /subst_consn /subst_compose /=.
  - rewrite nth_error_nil //.
  - destruct n => /=; eauto.
    now eapply on_free_vars_impl; tea.
Qed.


Require Import Common.
Require TRS.
Notation type2 := TRS.type2.
Notation type1 := TRS.type1.

Section expr.
  (* Environement is the same in the whole expr *)
  Import TRS.
  Inductive expr1' : list type2 ->  type1 -> Type :=
  | Elet : forall E F t t', pattern1 F t -> expr1' E t -> expr1' (E++F) t' -> expr1' E t'
  | Eprim : forall E args res (f : builtin args res), dlist  (fun t => expr1' E (T01 t)) args -> expr1' E (T01 res)
  | Econstant : forall E (c : constant), expr1' E (T01 (cst_ty c))
  (* get a register of level 1 *)
  | Eget : forall E t (v : var E (Treg t)), expr1' E (t)
  (* get for input/output  *)
  | Eget_input  : forall E t (v : var E (Tinput t)), expr1' E (t)
  | Eget_output : forall E t (v : var E (Toutput t)), expr1' E (t)

  (* TODO: Use Tenum instead of Tint *)
  | Eget_regfile : forall E size t (v : var E  (Tregfile size t)) n, expr1' E (T01 (Tint n)) -> expr1' E t
  | Efirst : forall E n t (v : var E (Tfifo n t)), expr1' E t
  | Eisfull : forall E n t (v : var E (Tfifo n t)), expr1' E (T01 Tbool)
  | Eisempty : forall E n t (v : var E (Tfifo n t)), expr1' E (T01 Tbool)

  | Eunion : forall E {id fl} (case : expr1'_disjunct E fl), expr1' E (Tunion id fl)
  | Etuple : forall E l (v : dlist (expr1' E) l), expr1' E (Ttuple l)
  with expr1'_disjunct : list type2 -> list (ident * type1) -> Type :=
  | expr1'_disjunct_hd:forall E id t q, expr1' E t -> expr1'_disjunct E ((id,t) :: q)
  | expr1'_disjunct_tl:forall E id t q, expr1'_disjunct E q -> expr1'_disjunct E ((id,t)::q) .

  Inductive expr2 E : type2 -> Type :=
  | Eset : forall t, expr1' E t ->  expr2 E (Treg t)
  | Eset_regfile : forall size t n,
                     expr1' E (T01 (Tint n)) -> expr1' E t -> expr2 E (Tregfile size t)
  (* operations on fifos *)
  | Epush : forall n t, expr1' E t -> expr2 E (Tfifo n t)
  | Epop  : forall n t, expr2 E (Tfifo n t) (* forgets the first element *)
  | Epushpop : forall n t, expr1' E t -> expr2 E (Tfifo n t)
  | Eclear : forall n t, expr2 E (Tfifo n t)

  (* set an output *)
  | Eset_output : forall t, expr1' E t -> expr2 E (Toutput t)
  (* do nothing *)
  | Enop : forall t, expr2 E t.

  Definition expr2_vector (E : list type2) := dlist (@expr2 E).
End expr.

Record rule mem :=
  mk_rule
    {
      cond: expr1' mem (TRS.T01 Tbool);
      rhs : expr2_vector mem mem
    }.

Section i.

Definition repl E t := match t with
                         | TRS.Treg t' => expr1' E t'
                         | _  => var E t
                       end.

Fixpoint insert (t : type2) (G : list type2) (n : nat) {struct n} : list type2 :=
  match n with
    | O => t :: G
    | S n' => match G with
               | nil => t :: G
               | t' :: G' => t' :: insert t G' n'
             end
  end.

Fixpoint lift_var t G (x : var G t) t' n : var (insert t' G n) t :=
  match x with
    | var_0 G' _ =>
        match n with
          | 0 => var_S var_0
          | _ => var_0
        end
    | var_S G' _ t'' x'  =>
        match n with
          | 0 => var_S (var_S x')
          | S n' =>
              (var_S (lift_var _ _ x' _ n') : var (insert t' (_ :: G') (S n')) t'')
        end
  end.
End i.

Definition lift_expr1' : forall E t, TRS.expr1 E t -> expr1' E t. Admitted.

Section t.
  Variable mem : list type2.

  Variable R : TRS.rule mem.

  Definition S : rule mem.
  constructor.

  (* map each variable from context G to a replacement that is valid in context G' *)
  Definition subst G G' := dlist (repl G') G.

  Definition repl_0 E x : repl (x :: E) x.
  Proof.
    unfold repl; destruct x; try apply var_0. apply Eget. apply var_0.
  Defined.

  Definition lift_expr E x a:   expr1' E x -> expr1' (a :: E) x.
  Proof.
  Admitted.

  Definition lift_repl a E x  : repl E x -> repl (a :: E) x.
  Proof.
    unfold repl; destruct x; try apply (var_S). apply lift_expr.
  Defined.

  Definition subst_id : forall E, subst E E.
  Proof.
    unfold subst.
    induction E. constructor.
    constructor.
    apply repl_0.

    apply (dlist_map (lift_repl a E ) _ IHE).
  Defined.

  Definition subst_compose : forall E F G, subst E F -> subst F G -> subst E G.
  Proof.
    unfold subst.
    intros.

  Definition lifting_transformation E F  : (forall t, expr1' E t -> expr1' F t) -> forall t, repl E t -> repl F t.
  Admitted.

  eapply dlist_map.
  2 : apply X.
  apply lifting_transformation.

  Definition map_subst t E F (s : subst E F) ( x : expr1' E t) :  expr1' F t.
  induction x.

  refine (let f := fix f t E F s x : expr1' F t :=
  match x with
    | Elet E F t t' patF expr body => _
    | Eprim E args res f x => _
    | Econstant E c =>  _
    | Eget E t v => _
    | Eget_input E t v => _
    | Eget_output E t v => _
    | Eget_regfile E size t v n x => _
    | Efirst E n t v => _
    | Eisfull E n t v => _
    | Eisempty E n t v => _
    | Eunion E id fl case => _
    | Etuple E l v => _
  end
          in f t E F s x).
  admit.
  apply Eprim.
  intros.
  induction X1.

  Definition where_to_subst E F : TRS.where_clause E F -> subst F E.
  induction 1.
  apply subst_id.
  eapply subst_compose. apply IHX.
 eapply dlist_map.
 intros.
 eapply lifting_transformation.
  intros.
eapply Elet.  apply p.
  apply lift_expr1'. apply e. apply X1. apply X0. apply subst_id.
Defined.
  apply lift_expr1'.
  intros.
  eapply Elet.
  apply p. apply lift_expr1'. apply e.
  auto.
  Defined.

  Definition abort_pattern2_vector E F :
    TRS.pattern2_vector E F ->
    TRS.where_clause E F.

  refine (let f := fix f E F (p : TRS.pattern2_vector E F) : TRS.where_clause E F :=
              match p with
                | TRS.pattern2_vector_nil =>  _
                | TRS.pattern2_vector_cons E' F' t q
                                       pat pats =>
                    _
              end
          in
            f E F

         ).
  constructor.
  auto.
  Definition w_append : forall A B C, TRS.where_clause A B -> TRS.where_clause B C ->
                                 TRS.where_clause A C.
  Admitted.
  apply f in pats.

  Definition test : forall E t, TRS.pattern2 E t -> TRS.where_clause (t :: nil) E.
  intros E t.
  refine (fun X => match X with
              TRS.Pvar2 t' =>  TRS.where_clause_nil _
            | TRS.Phole2 t' =>  _
            | TRS.Plift E' t'  p =>  _
          end
         ).

  inversion pat;  subst; simpl.

  simpl.

eapply f in pats.
  eapply w_append.
  2: apply X.

End t.
  Fixpoint pattern2_vector_match E F (P : pattern2_vector E F ) :
    eval_type2_list E -> option (eval_env eval_type2 F) :=
    match P with
      | pattern2_vector_nil => fun _ => Some tt
      | pattern2_vector_cons E F t q p2Et p2vFq =>
          fun X =>
            let (A, B) := X in
              do X <- pattern2_match E t p2Et A;
              do Y <- pattern2_vector_match _ _ p2vFq B;
              Some (append_envs _ _  X Y)
    end.

  Fixpoint where_clause_match {E F} (W : where_clause E F) {struct W}:
    eval_type2_list E -> option (eval_type2_list F) :=
    match W with
      | where_clause_nil _ => fun X => Some X
      | where_clause_cons E F G t pat exp w =>
          fun x =>
            do e <- eval_expr1' _ x t exp;
            do B <- pattern1_match F t pat e;
            where_clause_match w (append_envs _ _ x B  )
    end.

  Definition eval_expr2_vector mem env (v : @expr2_vector env mem) :
    eval_type2_list env -> eval_type2_list mem -> option (eval_type2_list mem) :=
    (fun ENV MEM =>  (dlist_fold _ _ _ (eval_expr2 _ ENV) mem v MEM)).

  Definition eval_rule mem (r : rule mem) : relation (eval_type2_list mem) :=
    fun M1 M2 =>
      exists E, exists F,  (pattern2_vector_match _ _ (lhs r) M1 = Some E
           /\ where_clause_match (where_clauses _ r) E = Some F
           /\ eval_expr1' _ F _ (cond r) = Some true
           /\ eval_expr2_vector _ _ (rhs r) F M1 = Some M2).

  Fixpoint eval_rules ty (l : list (rule ty)) : relation (eval_type2_list (ty)) :=
    match l with
      | nil => fun _ _ => True
      | cons t q => union (eval_rule ty t) (eval_rules ty q)
    end.

  Definition eval_TRS T := eval_rules _ (trs_rules T).

  Definition run_rule ty (r : rule ty) : eval_type2_list ty -> option (eval_type2_list ty) :=
    fun M1 =>
      do E <- pattern2_vector_match _ _ (lhs  r) M1;
      do F <- where_clause_match (where_clauses _ r) E;

      if (@eval_expr1' (env2  r) F _ (cond  r))
      then (@eval_expr2_vector _ _  (rhs  r) F M1)
      else None .

  Fixpoint iter_option {A} n (f : A -> option A) x :=
    match n with
      | 0 => Some x
      | S n => match f x with | None => Some x | Some x => iter_option n f x end
    end.

  Fixpoint first_rule {ty} (l : list (rule ty)) x :=
    match l with
      | nil => Some x
      | cons t q =>
          match run_rule _ t x with
            | None => first_rule q x
            | Some x => Some x
          end
    end.

  Fixpoint run_unfair n T x :=
    match n with
      | 0 => Some x
    | S n =>
        match first_rule (trs_rules T) x with
          | None => Some x
          | Some x => run_unfair n T x
        end
  end.

  Notation "[]" := nil.
  Notation "a :: b" := (cons a b).
  Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
  Open Scope string_scope.

  Delimit Scope expr_scope with expr.
  Notation "[| x , .. , z |]"  :=  (Etuple _ _ (dlist_cons x .. (dlist_cons z dlist_nil ).. )) (at level  0): expr_scope.

  Notation "{< f ; x ; y >}" := (Eprim _ _ _ (f) (dlist_cons  x (dlist_cons y dlist_nil))).

  Notation "{< f ; x >}" := (Eprim _ _ _ (f) (dlist_cons x dlist_nil)).

  Notation "~ x" :=  ({< BI_negb ; x >}) : expr_scope.
  Notation "a || b" := ({< BI_orb ; a ; b >}) : expr_scope.
  Notation "a - b" := ({< BI_minus _ ; a ; b >}) : expr_scope.
  Notation "a + b" := ({< BI_plus _ ; a ; b >}) : expr_scope.
  Notation "a = b" := ({< BI_eq _ ; a ; b >}) : expr_scope.
  Notation "a < b" := ({< BI_lt _ ; a ; b >}) : expr_scope.
  Notation "x <= y" := ((x < y) || (x = y))%expr : expr_scope.
  Notation "x <> y" := (~(x = y))%expr : expr_scope.
  Notation "! x" := (Eget _ _ x) (at level  10) : expr_scope .
  Notation "[| x |]"  :=  (Etuple _ _ (dlist_cons x dlist_nil )) (at level  0): expr_scope.
  Notation "{< x >}" := (Econstant _ x): expr_scope.

  Delimit Scope pattern_scope with pattern.
  Notation "[| x , .. , z |]" := (Ptuple _ _ (pattern_vector_cons _ _ _ _ x .. (pattern_vector_cons _ _ _ _ z pattern_vector_nil ).. )) (at  level 0): pattern_scope.

  Notation "X 'of' u :: q " := ((X,u)::q) (at level 60, u at next level,  right associativity).

  (* Notations for expr2 *)
  Delimit Scope expr2_scope with expr2.
  Arguments Eset_regfile {E} size t n _%expr _%expr.

  (* Arguments dlist_cons {T P} t q _ _ .  *)
  (* Arguments dlist_nil {T P}.  *)
  Notation "[| x , .. , z |]"  :=  ((dlist_cons x .. (dlist_cons  z (dlist_nil ) ).. )) (at level  0): expr2_scope.
  Notation "'[' key '<-' v ']' " := ( Eset_regfile  _ _ _  key v )(at level 0, no associativity) : expr2_scope.
  Notation "•" := (Enop _ _) : expr2_scope.

  Definition mk_rule' {mem} env pat cond expr : rule mem :=
    mk_rule mem env env pat (where_clause_nil _ ) cond expr.


Require Import Raft.
Require Import RaftRefinementInterface.

Section RequestVoteTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition requestVote_term_sanity (net : network) : Prop :=
    forall t h mi mt p,
      In p (nwPackets net) ->
      pBody p = RequestVote t h mi mt ->
      t <= currentTerm (snd (nwState net (pSrc p))).

  Class requestVote_term_sanity_interface : Prop :=
    {
      requestVote_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          requestVote_term_sanity net
    }.
End RequestVoteTermSanity.


Require Import Preloaded Coq.Lists.List VST.floyd.proofauto.

Lemma bt_invert_involution : forall (A : Type) (tree : bt A),
  bt_invert (bt_invert tree) = tree.
Proof. intros A tree; induction tree; simpl; congruence. Qed.

Lemma bt_invert_inorder : forall (A : Type) (tree : bt A),
  bt_inorder (bt_invert tree) = rev (bt_inorder tree).
Proof.
  intros A tree; induction tree; simpl; auto.
  rewrite IHtree1, IHtree2, rev_app_distr; simpl.
  now rewrite <- app_assoc.
Qed.

Lemma btrep_local_facts: forall sigma p,
   btrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=bt_leaf)).
Proof.
  induction sigma; intros.
  - unfold btrep.
    entailer!.
    split; auto.
  - unfold btrep; fold btrep.
    Intros y z.
    entailer!.
    split; intros H3.
    + subst p.
      eapply field_compatible_nullval; eauto.
    + discriminate.
Qed.

#[export] Hint Resolve btrep_local_facts : saturate_local.

Lemma btrep_valid_pointer: forall sigma p,
   btrep sigma p |-- valid_pointer p.
Proof.
  destruct sigma; intros; unfold btrep; fold btrep.
  - entailer!.
  - Intros y z.
    entailer!.
Qed.

#[export] Hint Resolve btrep_valid_pointer : valid_pointer.

Lemma body_invert: semax_body Vprog Gprog f_invert invert_spec.
Proof.
  start_function.
  forward_if (PROP (isptr p)  LOCAL (temp _p p)  SEP (btrep sigma p)).
  - forward.
    rewrite (proj1 H0) by auto.
    Exists nullval.
    entailer!.
  - forward.
    entailer!.
    destruct p; simpl in PNp; try now exfalso; try subst i.
    now simpl.
  - destruct sigma; unfold btrep; fold btrep.
    + Intros; subst p; inversion Pp.
    + Intros y z.
      forward.
      forward_call (sigma1, y).
      Intros vret.
      do 2 forward.
      forward_call (sigma2, z).
      Intros vret0.
      do 3 forward.
      simpl; unfold btrep; fold btrep.
      Exists p vret0 vret.
      entailer!.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** THIS FILE IS DEPRECATED. *)

Require Import BinInt Zcompare Zorder.

Local Open Scope Z_scope.

(** Definition [Z.min] is now [BinInt.Z.min]. *)

(** Exact compatibility *)

Notation Zmin_case := Z.min_case (compat "8.6").
Notation Zmin_case_strong := Z.min_case_strong (compat "8.6").
Notation Zle_min_l := Z.le_min_l (compat "8.6").
Notation Zle_min_r := Z.le_min_r (compat "8.6").
Notation Zmin_glb := Z.min_glb (compat "8.6").
Notation Zmin_glb_lt := Z.min_glb_lt (compat "8.6").
Notation Zle_min_compat_r := Z.min_le_compat_r (only parsing).
Notation Zle_min_compat_l := Z.min_le_compat_l (only parsing).
Notation Zmin_idempotent := Z.min_id (only parsing).
Notation Zmin_n_n := Z.min_id (only parsing).
Notation Zmin_comm := Z.min_comm (compat "8.6").
Notation Zmin_assoc := Z.min_assoc (compat "8.6").
Notation Zmin_irreducible_inf := Z.min_dec (only parsing).
Notation Zsucc_min_distr := Z.succ_min_distr (compat "8.6").
Notation Zmin_SS := Z.succ_min_distr (only parsing).
Notation Zplus_min_distr_r := Z.add_min_distr_r (only parsing).
Notation Zmin_plus := Z.add_min_distr_r (only parsing).
Notation Zpos_min := Pos2Z.inj_min (only parsing).

(** Slightly different lemmas *)

Lemma Zmin_spec x y :
  x <= y /\ Z.min x y = x  \/  x > y /\ Z.min x y = y.
Proof.
 Z.swap_greater. rewrite Z.min_comm. destruct (Z.min_spec y x); auto.
Qed.

Lemma Zmin_irreducible n m : Z.min n m = n \/ Z.min n m = m.
Proof. destruct (Z.min_dec n m); auto. Qed.

Notation Zmin_or := Zmin_irreducible (only parsing).

Lemma Zmin_le_prime_inf n m p : Z.min n m <= p -> {n <= p} + {m <= p}.
Proof. apply Z.min_case; auto. Qed.

Lemma Zpos_min_1 p : Z.min 1 (Zpos p) = 1.
Proof.
 now destruct p.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import CRelationClasses.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst
     PCUICUnivSubst PCUICTyping PCUICInduction PCUICReduction PCUICClosed.

Require Import ssreflect ssrbool.
From Equations Require Import Equations.

(** * Closed single substitution:

    no lifting involved and one term at a time. *)

Local Ltac inv H := inversion H; subst.

Fixpoint csubst t k u :=
  match u with
  | tRel n =>
     match Nat.compare k n with
    | Datatypes.Eq => t
    | Gt => tRel n
    | Lt => tRel (Nat.pred n)
    end
  | tEvar ev args => tEvar ev (List.map (csubst t k) args)
  | tLambda na T M => tLambda na (csubst t k T) (csubst t (S k) M)
  | tApp u v => tApp (csubst t k u) (csubst t k v)
  | tProd na A B => tProd na (csubst t k A) (csubst t (S k) B)
  | tLetIn na b ty b' => tLetIn na (csubst t k b) (csubst t k ty) (csubst t (S k) b')
  | tCase ind p c brs =>
    let brs' := List.map (fun br => map_branch_k (csubst t) id k br) brs in
    tCase ind (map_predicate_k id (csubst t) k p)
      (csubst t k c) brs'
  | tProj p c => tProj p (csubst t k c)
  | tFix mfix idx =>
    let k' := List.length mfix + k in
    let mfix' := List.map (map_def (csubst t k) (csubst t k')) mfix in
    tFix mfix' idx
  | tCoFix mfix idx =>
    let k' := List.length mfix + k in
    let mfix' := List.map (map_def (csubst t k) (csubst t k')) mfix in
    tCoFix mfix' idx
  | x => x
  end.

(** It is equivalent to general substitution when substituting a closed term *)
Lemma closed_subst t k u : closed t ->
    csubst t k u = subst [t] k u.
Proof.
  revert k; induction u using term_forall_list_ind; intros k Hs;
    simpl; try f_equal; eauto with pcuic; solve_all.
  - destruct (PeanoNat.Nat.compare_spec k n).
    + subst k.
      rewrite PeanoNat.Nat.leb_refl Nat.sub_diag /=.
      now rewrite lift_closed.
    + destruct (leb_spec_Set k n); try lia.
      destruct (nth_error_spec [t] (n - k) ).
      simpl in l0; lia.
      now rewrite Nat.sub_1_r.
    + now destruct (Nat.leb_spec k n); try lia.
Qed.

(** It respects closedness of the substitutend as well. *)
Lemma closed_csubst t k u : closed t -> closedn (S k) u -> closedn k (csubst t 0 u).
Proof.
  intros.
  rewrite closed_subst; auto.
  eapply closedn_subst0. simpl. erewrite closed_upwards; eauto. lia.
  simpl. now rewrite Nat.add_1_r.
Qed.


From stdpp Require Import nat_cancel.
From iris.proofmode Require Import base tactics modality_instances classes.
From iris.bi Require Export derived_laws derived_connectives.
From iris.algebra Require Import monoid cmra.
From Perennial.base_logic Require Import own.
From Perennial.algebra Require Export laterN.
Import interface.bi.
Import derived_laws.bi.
Import derived_laws_later.bi.

Set Default Proof Using "Type".

Definition bi_atleast {PROP : bi} (k : nat) (P : PROP) : PROP := (▷^k False ∨ P)%I.
Arguments bi_atleast {_} _ _%I : simpl never.
Notation "◇_ n P" := (bi_atleast n P) (at level 20, n at level 9, P at level 20,
   format "◇_ n  P").
#[global]
Instance: Params (@bi_atleast) 2 := {}.
Typeclasses Opaque bi_atleast.

Class AbsolutelyTimeless {PROP : bi} (P : PROP) := abs_timeless : ∀ k, ▷^k P ⊢ ◇_k P.
Arguments AbsolutelyTimeless {_} _%I : simpl never.
Arguments abs_timeless {_} _%I {_}.
#[global]
Hint Mode AbsolutelyTimeless + ! : typeclass_instances.
#[global]
Instance: Params (@AbsolutelyTimeless) 1 := {}.

Section PROP_laws.
Context {PROP : bi}.
Context {H: BiLöb PROP}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types Ps : list PROP.
Implicit Types A : Type.

Local Hint Resolve or_elim or_intro_l' or_intro_r' True_intro False_elim : core.
Local Hint Resolve and_elim_l' and_elim_r' and_intro forall_intro : core.

(* Force implicit argument PROP *)
Notation "P ⊢ Q" := (P ⊢@{PROP} Q).
Notation "P ⊣⊢ Q" := (P ⊣⊢@{PROP} Q).

Global Instance atleast_ne k : NonExpansive (@bi_atleast PROP k).
Proof. solve_proper. Qed.
Global Instance atleast_proper k : Proper ((⊣⊢) ==> (⊣⊢)) (@bi_atleast PROP k).
Proof. solve_proper. Qed.
Global Instance atleast_mono' k : Proper ((⊢) ==> (⊢)) (@bi_atleast PROP k).
Proof. solve_proper. Qed.
Global Instance atleast_flip_mono' k :
  Proper (flip (⊢) ==> flip (⊢)) (@bi_atleast PROP k).
Proof. solve_proper. Qed.

Section laws.
Context (k: nat).
Lemma atleast_intro P : P ⊢ ◇_k P.
Proof. rewrite /bi_atleast; auto. Qed.
Lemma atleast_mono P Q : (P ⊢ Q) → ◇_k P ⊢ ◇_k Q.
Proof. by intros ->. Qed.
Lemma atleast_le k1 k2 P : k1 ≤ k2 → ◇_k1 P ⊢ ◇_k2 P.
Proof.
  rewrite /bi_atleast. iIntros (?) "[Hf|HP]".
  - iLeft. iApply laterN_le; eauto.
  - iRight. eauto.
Qed.
Lemma atleast_idemp P : ◇_k ◇_k P ⊣⊢ ◇_k P.
Proof.
  apply (anti_symm _); rewrite /bi_atleast; auto.
Qed.

Lemma except_0_atleast P : ◇ P ⊣⊢ ◇_1 P.
Proof. rewrite /bi_atleast/bi_except_0//=. Qed.

Lemma atleast_True : ◇_k True ⊣⊢ True.
Proof using H. rewrite /bi_atleast. apply (anti_symm _); auto. Qed.
Lemma atleast_emp `{!BiAffine PROP} : ◇_k emp ⊣⊢ emp.
Proof using H. by rewrite -True_emp atleast_True. Qed.
Lemma atleast_or P Q : ◇_k (P ∨ Q) ⊣⊢ ◇_k P ∨ ◇_k Q.
Proof.
  rewrite /bi_atleast. apply (anti_symm _); auto.
Qed.
Lemma atleast_and P Q : ◇_k (P ∧ Q) ⊣⊢ ◇_k P ∧ ◇_k Q.
Proof. by rewrite /bi_atleast or_and_l. Qed.
Lemma atleast_sep P Q : ◇_k (P ∗ Q) ⊣⊢ ◇_k P ∗ ◇_k Q.
Proof.
  rewrite /bi_atleast. apply (anti_symm _).
  - apply or_elim; last by auto using sep_mono.
    by rewrite -!or_intro_l -persistently_pure -laterN_sep -persistently_sep_dup.
  - rewrite sep_or_r !sep_or_l {1}(later_intro P) {1}(later_intro Q).
    rewrite -!laterN_sep !left_absorb.
    iIntros "[[?|(?&?)]|[(?&?)|?]]"; eauto.
Qed.
Lemma atleast_exist_2 {A} (Φ : A → PROP) : (∃ a, ◇_k Φ a) ⊢ ◇_k ∃ a, Φ a.
Proof. apply exist_elim=> a. by rewrite (exist_intro a). Qed.
Lemma atleast_exist `{Inhabited A} (Φ : A → PROP) :
  ◇_k (∃ a, Φ a) ⊣⊢ (∃ a, ◇_k Φ a).
Proof.
  apply (anti_symm _); [|by apply atleast_exist_2]. apply or_elim.
  - rewrite -(exist_intro inhabitant). by apply or_intro_l.
  - apply exist_mono=> a. apply atleast_intro.
Qed.
Lemma atleast_laterN_le P j (Hle: j ≤ k) : ◇_k ▷^j P ⊢ ▷^k P.
Proof. by rewrite /bi_atleast (laterN_le j k) // -laterN_or False_or. Qed.
Lemma atleast_laterN P : ◇_k ▷^k P ⊢ ▷^k P.
Proof. by apply atleast_laterN_le. Qed.
Lemma atleast_later P (Hle: 1 <= k): ◇_k ▷ P ⊢ ▷^k P.
Proof. rewrite (atleast_laterN_le _ 1) //=. Qed.
(*
Lemma atleast_laterN n P (Hle: 1 ≤ k) : ◇_k ▷^n P ⊢ ▷^n ◇_k P.
Proof. destruct n as [|n]; rewrite //= ?atleast_later //=. -atleast_intro. Qed.
*)
Lemma atleast_into_later P : ◇_k P ⊢ ▷^k P.
Proof. by rewrite -atleast_laterN -laterN_intro. Qed.
Lemma atleast_persistently P : ◇_k <pers> P ⊣⊢ <pers> ◇_k P.
Proof.
  by rewrite /bi_atleast persistently_or -laterN_persistently persistently_pure.
Qed.
Lemma atleast_affinely_2 P : <affine> ◇_k P ⊢ ◇_k <affine> P.
Proof. rewrite /bi_affinely atleast_and. auto using atleast_intro. Qed.
Lemma atleast_intuitionistically_2 P : □ ◇_k P ⊢ ◇_k □ P.
Proof. by rewrite /bi_intuitionistically -atleast_persistently atleast_affinely_2. Qed.
Lemma atleast_intuitionistically_if_2 p P : □?p ◇_k P ⊢ ◇_k □?p P.
Proof. destruct p; simpl; auto using atleast_intuitionistically_2. Qed.
Lemma atleast_absorbingly P : ◇_k <absorb> P ⊣⊢ <absorb> ◇_k P.
Proof using H. by rewrite /bi_absorbingly atleast_sep atleast_True. Qed.

Lemma atleast_frame_l P Q : P ∗ ◇_k Q ⊢ ◇_k (P ∗ Q).
Proof. by rewrite {1}(atleast_intro P) atleast_sep. Qed.
Lemma atleast_frame_r P Q : ◇_k P ∗ Q ⊢ ◇_k (P ∗ Q).
Proof. by rewrite {1}(atleast_intro Q) atleast_sep. Qed.

Lemma later_affinely_1 `{!AbsolutelyTimeless (PROP:=PROP) emp} P : ▷^k <affine> P ⊢ ◇_k <affine> ▷^k P.
Proof.
  rewrite /bi_affinely laterN_and (abs_timeless emp%I) atleast_and.
  by apply and_mono, atleast_intro.
Qed.

Global Instance atleast_persistent P : Persistent P → Persistent (◇_k P).
Proof. rewrite /bi_atleast; apply _. Qed.
Global Instance atleast_absorbing P : Absorbing P → Absorbing (◇_k P).
Proof. rewrite /bi_atleast; apply _. Qed.
(* AbsolutelyTimeless instances *)
Global Instance AbsolutelyTimeless_proper : Proper ((≡) ==> iff) (@AbsolutelyTimeless PROP).
Proof.
  rewrite /AbsolutelyTimeless.
  intros ?? Heq. split; intros ? k0.
  * rewrite -Heq; eauto.
  * rewrite Heq; eauto.
Qed.

Lemma atleast_bupd `{!BiBUpd PROP} P : ◇_k (|==> P) ⊢ (|==> ◇_k P).
Proof.
  rewrite /bi_atleast. apply or_elim; eauto using bupd_mono, or_intro_r.
Qed.

End laws.

Global Instance and_abs_timeless P Q : AbsolutelyTimeless P → AbsolutelyTimeless Q → AbsolutelyTimeless (P ∧ Q).
Proof. intros ???; rewrite /AbsolutelyTimeless atleast_and laterN_and; auto. Qed.
Global Instance or_abs_timeless P Q : AbsolutelyTimeless P → AbsolutelyTimeless Q → AbsolutelyTimeless (P ∨ Q).
Proof. intros ???; rewrite /AbsolutelyTimeless atleast_or laterN_or; auto. Qed.

Global Instance sep_abs_timeless P Q: AbsolutelyTimeless P → AbsolutelyTimeless Q → AbsolutelyTimeless (P ∗ Q).
Proof.
  intros ???; rewrite /AbsolutelyTimeless atleast_sep laterN_sep; auto using sep_mono.
Qed.

Global Instance persistently_abs_timeless P : AbsolutelyTimeless P → AbsolutelyTimeless (<pers> P).
Proof.
  intros ??. rewrite /AbsolutelyTimeless /bi_atleast laterN_persistently.
  by rewrite (abs_timeless P) persistently_or {1}persistently_elim.
Qed.

Global Instance affinely_abs_timeless P :
  AbsolutelyTimeless (PROP:=PROP) emp → AbsolutelyTimeless P → AbsolutelyTimeless (<affine> P).
Proof. rewrite /bi_affinely; apply _. Qed.
(*
Global Instance absorbingly_abs_timeless P : AbsolutelyTimeless P → AbsolutelyTimeless (<absorb> P).
Proof. rewrite /bi_absorbingly; apply _. Qed.
*)

Global Instance intuitionistically_abs_timeless P :
  AbsolutelyTimeless (PROP:=PROP) emp → AbsolutelyTimeless P → AbsolutelyTimeless (□ P).
Proof. rewrite /bi_intuitionistically; apply _. Qed.

Global Instance from_option_abs_timeless {A} P (Ψ : A → PROP) (mx : option A) :
  (∀ x, AbsolutelyTimeless (Ψ x)) → AbsolutelyTimeless P → AbsolutelyTimeless (from_option Ψ P mx).
Proof. destruct mx; apply _. Qed.
End PROP_laws.

Section uPred_laws.
Context {M: ucmra}.
Implicit Types φ : Prop.
Implicit Types P Q R : (uPred M).
Implicit Types Ps : list (uPred M).
Implicit Types A : Type.

Local Hint Resolve or_elim or_intro_l' or_intro_r' True_intro False_elim : core.
Local Hint Resolve and_elim_l' and_elim_r' and_intro forall_intro : core.

(* TODO: Is there a syntactic proof of this for all BI?
   The generalization of the syntactic proof for except_0 did not seem to work out. *)
Lemma atleast_forall {A} k (Φ : A → uPred M) : ◇_k (∀ a, Φ a) ⊣⊢ ∀ a, ◇_k Φ a.
Proof.
  apply (anti_symm _).
  { apply forall_intro=> a. by rewrite (forall_elim a). }
  split => n x Hval Hall.
  destruct (decide (n < k)).
  - rewrite /bi_atleast/bi_or//=. uPred.unseal. left. apply laterN_small; eauto.
  - move: Hall. rewrite /bi_atleast/bi_or//=. uPred.unseal. right.
    intros a. specialize (Hall a) as [Hleft|Hright].
    * exfalso. eapply (laterN_big n k x); eauto.
      { lia. }
      { uPred.unseal; eauto. }
    * eauto.
Qed.

Global Instance pure_abs_timeless φ : AbsolutelyTimeless (PROP:=uPredI M) ⌜φ⌝.
Proof.
  intros k'. rewrite /bi_atleast pure_alt laterN_exist_false.
  apply or_mono; first auto.
  apply exist_elim. intros. eauto.
Qed.
Global Instance emp_abs_timeless `{BiAffine PROP} : AbsolutelyTimeless (PROP:=uPredI M) emp.
Proof. rewrite -True_emp. apply _. Qed.
Global Instance forall_abs_timeless {A} (Ψ : A → uPred M) :
  (∀ x, AbsolutelyTimeless (Ψ x)) → AbsolutelyTimeless (∀ x, Ψ x).
Proof.
  rewrite /AbsolutelyTimeless=> HQ k. rewrite atleast_forall laterN_forall.
  apply forall_mono; auto.
Qed.
Global Instance exist_abs_timeless {A} (Ψ : A → uPred M) :
  (∀ x, AbsolutelyTimeless (Ψ x)) → AbsolutelyTimeless (∃ x, Ψ x).
Proof.
  rewrite /AbsolutelyTimeless=> ??. rewrite laterN_exist_false. apply or_elim.
  - rewrite /bi_atleast; auto.
  - apply exist_elim=> x. rewrite -(exist_intro x); auto.
Qed.

Global Instance eq_abs_timeless {A : ofe} (a b : A) :
  Discrete a → AbsolutelyTimeless (PROP:=uPredI M) (a ≡ b).
Proof. intros. rewrite /Discrete !discrete_eq => k. apply (abs_timeless _). Qed.

(* These next two instances hold for Timeless, but they appear to not be true for AbsolutelyTimeless.

   However, a quick test suggests that the corresponding Timeless versions are un-used in Perennial,
   so losing them for AbsolutelyTimeless is not a problem. *)

(*
Global Instance impl_abs_timeless `{!BiLöb PROP} P Q : AbsolutelyTimeless Q → AbsolutelyTimeless (P → Q).
Proof.
  rewrite /AbsolutelyTimeless=> HQ k.
  split => n x Hval HPQ.
  destruct (decide (n < k)).
  - rewrite /bi_atleast//=. uPred.unseal. left. apply laterN_small; eauto.
  - move: HQ HPQ. rewrite /bi_atleast//=. uPred.unseal. right.
    intros n' x' Hincl Hle Hval' HP.
    assert (HPQ_later: (uPred_impl_def P Q) (n - k) x).
    assert (HP_later: P (n' - k) x).
Abort.
*)

(*
Global Instance wand_abs_timeless `{!BiLöb PROP} P Q : AbsolutelyTimeless Q → AbsolutelyTimeless (P -∗ Q).
Proof.
Abort.
*)

Import base_logic.bi.uPred.
Global Instance valid_abs_timeless {A : cmra} `{!CmraDiscrete A} (a : A) :
  AbsolutelyTimeless (✓ a : uPred M)%I.
Proof. rewrite /AbsolutelyTimeless => k. rewrite !discrete_valid. apply (abs_timeless _). Qed.

Global Instance ownM_abs_timeless (a : M) : Discrete a → AbsolutelyTimeless (uPred_ownM a).
Proof.
  intros ? k. rewrite laterN_ownM.
  apply exist_elim=> b.
  rewrite (abs_timeless (a≡b)) (atleast_intro k (uPred_ownM b)) -atleast_and.
  apply atleast_mono. rewrite internal_eq_sym.
  apply (internal_eq_rewrite' b a (uPred_ownM) _);
    auto using and_elim_l, and_elim_r.
Qed.
End uPred_laws.

Class IntoAtLeast {PROP : bi} k (P Q : PROP) := into_atleast : P ⊢ ◇_k Q.
Arguments IntoAtLeast {_} _ _%I _%I : simpl never.
Arguments into_atleast {_} _ _%I _%I {_}.
#[global]
Hint Mode IntoAtLeast + - ! - : typeclass_instances.
#[global]
Hint Mode IntoAtLeast + - - ! : typeclass_instances.

Class IsAtLeast {PROP : bi} k (Q : PROP) := is_atleast : ◇_k Q ⊢ Q.
Arguments IsAtLeast {_} _ _%I : simpl never.
Arguments is_atleast {_} _ _%I {_}.
#[global]
Hint Mode IsAtLeast + + ! : typeclass_instances.

Class MakeAtLeast {PROP : bi} k (P Q : PROP) :=
  make_atleast : ◇_k P ⊣⊢ Q.
Arguments MakeAtLeast {_} _ _%I _%I.
#[global]
Hint Mode MakeAtLeast + - - - : typeclass_instances.
Class KnownMakeAtLeast {PROP : bi} k (P Q : PROP) :=
  known_make_except_0 :> MakeAtLeast k P Q.
Arguments KnownMakeAtLeast {_} _ _%I _%I.
#[global]
Hint Mode KnownMakeAtLeast + + ! - : typeclass_instances.

Section class_instances_atleast.
Context {M: ucmra}.
Context (k: nat).
Implicit Types P Q R : uPred M.

Global Instance from_assumption_atleast p P Q :
  FromAssumption p P Q → KnownRFromAssumption p P (◇_k Q)%I.
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply atleast_intro. Qed.

Global Instance from_pure_atleast a P φ : FromPure a P φ → FromPure a (◇_k P) φ.
Proof. rewrite /FromPure=> ->. apply atleast_intro. Qed.

Global Instance from_and_atleast P Q1 Q2 :
  FromAnd P Q1 Q2 → FromAnd (◇_k P) (◇_k Q1) (◇_k Q2).
Proof. rewrite /FromAnd=><-. by rewrite atleast_and. Qed.

Global Instance from_sep_atleast P Q1 Q2 :
  FromSep P Q1 Q2 → FromSep (◇_k P) (◇_k Q1) (◇_k Q2).
Proof. rewrite /FromSep=><-. by rewrite atleast_sep. Qed.

Global Instance into_and_atleast p P Q1 Q2 :
  IntoAnd p P Q1 Q2 → IntoAnd p (◇_k P) (◇_k Q1) (◇_k Q2).
Proof.
  rewrite /IntoAnd=> HP. apply intuitionistically_if_intro'.
  by rewrite atleast_intuitionistically_if_2 HP
             intuitionistically_if_elim atleast_and.
Qed.

Global Instance into_sep_atleast P Q1 Q2 :
  IntoSep P Q1 Q2 → IntoSep (◇_k P) (◇_k Q1) (◇_k Q2).
Proof. rewrite /IntoSep=> ->. by rewrite atleast_sep. Qed.

Global Instance from_or_atleast P Q1 Q2 :
  FromOr P Q1 Q2 → FromOr (◇_k P) (◇_k Q1) (◇_k Q2).
Proof. rewrite /FromOr=><-. by rewrite atleast_or. Qed.

Global Instance into_or_atleast P Q1 Q2 :
  IntoOr P Q1 Q2 → IntoOr (◇_k P) (◇_k Q1) (◇_k Q2).
Proof. rewrite /IntoOr=>->. by rewrite atleast_or. Qed.

Global Instance from_exist_atleast {A} P (Φ : A → uPred M) :
  FromExist P Φ → FromExist (◇_k P) (λ a, ◇_k (Φ a))%I.
Proof. rewrite /FromExist=> <-. by rewrite atleast_exist_2. Qed.

Global Instance into_exist_atleast {A} P (Φ : A → uPred M) i :
  IntoExist P Φ i → Inhabited A → IntoExist (◇_k P) (λ a, ◇_k (Φ a))%I i.
Proof. rewrite /IntoExist=> HP ?. by rewrite HP atleast_exist. Qed.

Global Instance into_forall_atleast {A} P (Φ : A → uPred M) :
  IntoForall P Φ → IntoForall (◇_k P) (λ a, ◇_k (Φ a))%I.
Proof. rewrite /IntoForall=> HP. by rewrite HP atleast_forall. Qed.

Global Instance from_forall_atleast {A} P (Φ : A → uPred M) i :
  FromForall P Φ i → FromForall (◇_k P)%I (λ a, ◇_k (Φ a))%I i.
Proof. rewrite /FromForall=> <-. by rewrite atleast_forall. Qed.

Global Instance from_modal_atleast P : FromModal True modality_id (◇_k P) (◇_k P) P.
Proof. by rewrite /FromModal /= -atleast_intro. Qed.

(** IsAtLeast *)
Global Instance is_atleast_atleast P : IsAtLeast k (◇_k P).
Proof. by rewrite /IsAtLeast atleast_idemp. Qed.
Global Instance is_atleast_later P : IsAtLeast k (▷^k P).
Proof. by rewrite /IsAtLeast atleast_laterN. Qed.

(** IntoAtLeast *)
Global Instance into_atleast_atleast P : IntoAtLeast k (◇_k P) P.
Proof. by rewrite /IntoAtLeast. Qed.
Global Instance into_atleast_later P : AbsolutelyTimeless P → IntoAtLeast k (▷^k P) P.
Proof. by rewrite /IntoAtLeast. Qed.

(* Special instances of above for k=1 and k=2. This could be done more generically, but it seems like
   we will only use k=1 and k=2 in practice anyway, so for now we just add directly the instances needed. *)
Global Instance into_atleast_later1 P : AbsolutelyTimeless P → IntoAtLeast 1 (▷ P) P.
Proof. rewrite /IntoAtLeast. by replace (▷ P)%I with (▷^1 P)%I by auto. Qed.
Global Instance into_atleast_later2 P : AbsolutelyTimeless P → IntoAtLeast 2 (▷▷ P) P.
Proof. rewrite /IntoAtLeast. by replace (▷▷ P)%I with (▷^2 P)%I by auto. Qed.
Global Instance into_atleast_later2' P : AbsolutelyTimeless P → IntoAtLeast 2 (▷ P) P.
Proof. rewrite /IntoAtLeast => ?. transitivity (▷▷ P)%I; first eauto. by apply into_atleast_later2. Qed.

(* XXX should this be added?
Global Instance into_atleast_later P : Timeless P → IntoAtLeast 1 (▷ P) P.
Proof. by rewrite /IntoAtLeast. Qed.
Global Instance into_atleast_later_if p P : Timeless P → IntoAtLeast (▷?p P) P.
Proof. rewrite /IntoAtLeast. destruct p; auto using atleast_intro. Qed.
*)

Global Instance into_atleast_affinely P Q :
  IntoAtLeast k P Q → IntoAtLeast k (<affine> P) (<affine> Q).
Proof. rewrite /IntoAtLeast=> ->. by rewrite atleast_affinely_2. Qed.
Global Instance into_atleast_intuitionistically P Q :
  IntoAtLeast k P Q → IntoAtLeast k (□ P) (□ Q).
Proof. rewrite /IntoAtLeast=> ->. by rewrite atleast_intuitionistically_2. Qed.
Global Instance into_atleast_absorbingly P Q :
  IntoAtLeast k P Q → IntoAtLeast k (<absorb> P) (<absorb> Q).
Proof. rewrite /IntoAtLeast=> ->. by rewrite atleast_absorbingly. Qed.
Global Instance into_atleast_persistently P Q :
  IntoAtLeast k P Q → IntoAtLeast k (<pers> P) (<pers> Q).
Proof. rewrite /IntoAtLeast=> ->. by rewrite atleast_persistently. Qed.

Global Instance elim_modal_abstimeless p P Q P' :
  IntoAtLeast k P P' → IsAtLeast k Q → ElimModal True p p P P' Q Q.
Proof.
  intros. rewrite /ElimModal (atleast_intro k (_ -∗ _)%I) (into_atleast k P).
  by rewrite atleast_intuitionistically_if_2 -atleast_sep wand_elim_r.
Qed.

Global Instance add_modal_atleast P Q : AddModal (◇_k P) P (◇_k Q) | 1.
Proof.
  intros. rewrite /AddModal (atleast_intro k (_ -∗ _)%I).
  by rewrite -atleast_sep wand_elim_r atleast_idemp.
Qed.
Global Instance add_modal_atleast_later P Q : AddModal (◇_k P) P (▷^k Q) | 1.
Proof.
  intros. rewrite /AddModal (atleast_intro k (_ -∗ _)%I).
  by rewrite -atleast_sep wand_elim_r atleast_laterN.
Qed.

Global Instance make_atleast_True : @KnownMakeAtLeast (uPredI M) k True True.
Proof. by rewrite /KnownMakeAtLeast /MakeAtLeast atleast_True. Qed.
Global Instance make_atleast_default P : MakeAtLeast k P (◇_k P) | 100.
Proof. by rewrite /MakeAtLeast. Qed.

Global Instance frame_atleast p R P Q Q' :
  Frame p R P Q → MakeAtLeast k Q Q' → Frame p R (◇_k P) Q'.
Proof.
  rewrite /Frame /MakeAtLeast=><- <-.
  by rewrite atleast_sep -(atleast_intro k (□?p R)%I).
Qed.

Global Instance is_atleast_bupd P : IsAtLeast k P → IsAtLeast k (|==> P).
Proof.
  rewrite /IsAtLeast=> HP.
  by rewrite -{2}HP -(atleast_idemp k P) -atleast_bupd -(atleast_intro k P).
Qed.

End class_instances_atleast.

Section iprop_instances.

  Global Instance own_abs_timeless {A: cmra} `{inG Σ A} γ (a: A):
    Discrete a →
    AbsolutelyTimeless (own γ a).
  Proof.
    intros ?. rewrite own.own_eq /own.own_def.
    apply ownM_abs_timeless, iRes_singleton_discrete. done.
  Qed.

End iprop_instances.


Load GradVer9Ltac.
Import Semantics.

Definition A_sSubsts m (A : A_s) : A_s :=
  flat_map (fun p =>
    match p with
    | phiAcc x f => [(x, f)]
    | _ => []
    end
  )
  (phiSubsts m (map (fun a => phiAcc (fst a) (snd a)) A)).

Definition mMapsTo (m : list (x * x)) (x' : x) : Prop :=
  exists m', In m' m /\ snd m' = x'.

Definition mMapsToUnique (m : list (x * x)) (x' : x) : Prop :=
  forall f1 f2 x1 x2,
      In (f1, x1) m ->
      In (f2, x2) m ->
      x1 = x' ->
      x2 = x' ->
      f1 = f2
.

(* sfrme (A_sSubsts (a => b) (a.f)) (eSubsts (a => b) (b.f)) -> sfrme (a.f) (b.f) *)
Lemma sfrmeSubst : forall m e a,
      (forall x, mMapsToUnique m x /\ (mMapsTo m x -> (~ In x (FVe e) /\ ~ In x (FVA_s a)))) ->
      sfrme (A_sSubsts m a) (eSubsts m e) ->
      sfrme a e.
Proof.
  induction e0; intros; try (constructor; fail).
  inversionx H1.
  constructor; try (apply IHe0; auto).
  generalize a H0 H5. clear.

  induction a; intros; simpl in *; try tauto.
  inversionx H5.
  - destruct a. simpl in *.
    inversionx H1.
    assert (CL := classic (e0 = e1)).
    inversionx CL; subst; eauto.
    contradict H1.
    generalize e0 e1 H3 H0. clear.
    induction e0; intros; simpl in *;
    destruct e1; simpl in *; inversionx H3; try tauto.
    * unfold mMapsToUnique in *.
      unfold xSubsts in *.
      destruct (find (λ r : x * x, x_decb x0 (fst r)) m0) eqn: ff0;
      destruct (find (λ r : x * x, x_decb x1 (fst r)) m0) eqn: ff1.
      + destruct p0, p1.
        subst.
        apply find_some in ff0. unf.
        apply find_some in ff1. unf.
        simpl in *.
        dec (x_dec x1 x4); inversionx H4.
        dec (x_dec x0 x2); inversionx H2.
        specialize (H0 x3).
        unf.
        eapply H2 in H1; eauto.
        subst.
        tauto.
      + destruct p0.
        subst.
        apply find_some in ff0. unf.
        eapply find_none in ff1; eauto.
        simpl in *.
        dec (x_dec x3 x2); inversionx ff1. rename de2 into asd.
        dec (x_dec x0 x2); inversionx H2.
        specialize (H0 x3).
        unf. assert (mMapsTo m0 x3). eexists; eauto. intuition.
      + destruct p0.
        subst.
        apply find_some in ff1. unf.
        eapply find_none in ff0; eauto.
        simpl in *.
        dec (x_dec x0 x2); inversionx ff0. rename de2 into asd.
        dec (x_dec x1 x2); inversionx H2.
        specialize (H0 x0).
        unf. assert (mMapsTo m0 x0). eexists; eauto. intuition.
      + subst.
        tauto.
    * apply IHe0 in H2; subst; intuition.
  - apply or_intror.
    eapply IHa; auto.
    intros.
    specialize (H0 x0).
    unfold FVA_s in *.
    simpl in *.
    intuition.
Qed.

Lemma sfrmeSubstEmpty : forall m e,
      sfrme [] (eSubsts m e) -> sfrme [] e.
Proof.
  intros.
  induction e0; try constructor;
  simpl in *;
  inversionx H0;
  inversion H4.
Qed.

Lemma sfrmphi'Subst : forall m e a,
     (forall x, mMapsToUnique m x /\ (mMapsTo m x -> (~ In x (FV' e) /\ ~ In x (FVA_s a)))) ->
      sfrmphi' (A_sSubsts m a) (phi'Substs m e)
      ->
      sfrmphi' a e.
Proof.
  intros.
  destruct e0; constructor;
  inversionx H1;
  apply (sfrmeSubst m0); intuition;
  try apply H0;
  apply H0 in H1;
  inversionx H1;
  intuition;
  contradict H3;
  simpl;
  intuition.
Qed.

(* counter-examples:
sfrmphi [] (phiSubsts (a => c, b => c) (acc(b.f) * a.f = 3)) ->
sfrmphi [] (acc(b.f) * a.f = 3)

sfrmphi [] (phiSubsts (a => b) (acc(b.f) * a.f = 3)) ->
sfrmphi [] (acc(b.f) * a.f = 3)

sfrmphi [] (phiSubsts (b => a) (acc(b.f) * a.f = 3)) ->
sfrmphi [] (acc(b.f) * a.f = 3)
*)

Lemma sfrmphiSubst : forall e m a,
     (forall x, mMapsToUnique m x /\ (mMapsTo m x -> (~ In x (FV e) /\ ~ In x (FVA_s a)))) ->
      sfrmphi (A_sSubsts m a) (phiSubsts m e)
      ->
      sfrmphi a e.
Proof.
  induction e0; intros; constructor.
  - inversionx H1.
    eapply sfrmphi'Subst; eauto.
    intros.
    split; try apply H0.
    intros.
    apply H0 in H1.
    inversionx H1.
    intuition.
    contradict H4.
    simpl.
    intuition.
  - inversionx H1.
    apply (IHe0 m0); intros.
    * specialize (H0 x0).
      unf.
      intuition.
      + contradict H4.
        simpl.
        intuition.
      + destruct a; simpl in *; intuition.
        unfold FVA_s in *.
        apply in_flat_map in H5.
        unf.
        apply in_map_iff in H5.
        unf.
        subst.
        inversionx H9; simpl in *; intuition.
        contradict H6.
        apply in_flat_map.
        eexists; split; eauto.
        apply in_map_iff.
        eexists; split; eauto.
    * destruct a; simpl in *; intuition.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.
From fourcolor Require Import job215to218 job219to222 job223to226.
From fourcolor Require Import job227to230 job231to234.

(******************************************************************************)
(* Reducibility of configurations number 215 to 234, whose indices in         *)
(* the_configs range over segment [214, 234).                                 *)
(******************************************************************************)

Lemma red214to234 : reducible_in_range 214 234 the_configs.
Proof.
CatReducible red214to218 red218to222 red222to226 red226to230 red230to234.
Qed.