Require Import SystemFR.SmallStep.
Require Import SystemFR.Trees.
Require Import SystemFR.Syntax.
Require Import SystemFR.Evaluator.
Require Import SystemFR.FVLemmas.
Require Import SystemFR.FVLemmasClose.
Require Import SystemFR.ListUtils.
Require Import SystemFR.BigStep.
Require Import SystemFR.TOpenTClose.
Require Import SystemFR.RewriteTactics.
Require Import SystemFR.CloseLemmas.
Require Import SystemFR.WFLemmasClose.
Require Import SystemFR.WFLemmas.

Require Import Coq.Strings.String.
Require Import Coq.Arith.Compare_dec.

Require Import Program.
From Equations Require Import Equations.
(* Require Import Equations.Prop.Subterm. *)

Require Import PeanoNat.
Require Import Relations.Relation_Operators.
Require Import Lia.

Lemma open_t_size: forall t i nf, tree_size (open i t (fvar nf term_var)) = tree_size t.
Proof.
  induction t; steps.
Qed.

#[export] Hint Rewrite open_t_size : cps.

Equations cps_rec (value : bool) (t : tree) (next_fv : nat) : option tree by wf (tree_size t) lt := {
  cps_rec false (fvar i term_var) _ := Some (notype_lambda (app (lvar 0 term_var) (fvar i term_var)));
  cps_rec false uu _ := Some (notype_lambda (app (lvar 0 term_var) uu));
  cps_rec false ttrue _ := Some (notype_lambda (app (lvar 0 term_var) ttrue));
  cps_rec false tfalse _ := Some (notype_lambda (app (lvar 0 term_var) tfalse));
  cps_rec false zero _ := Some (notype_lambda (app (lvar 0 term_var) zero));
  cps_rec false (succ t') nf :=
    if (is_open_value t') then
      option_map
        (fun cps_v => notype_lambda (app (lvar 0 term_var) (succ (cps_v))))
        (cps_rec true t' nf)
    else
      option_map
        (fun cps_t' =>
          (notype_lambda (
            app (cps_t') (notype_lambda (
              app (lvar 1 term_var) (succ (lvar 0 term_var))
            ))
          ))
        )
        (cps_rec false t' nf);
  cps_rec false (app t1 t2) nf :=
    match (cps_rec false t1 nf), (cps_rec false t2 nf) with
    | Some cps_t1, Some cps_t2 =>
      Some (notype_lambda (
        app (cps_t1) (notype_lambda (
          app (cps_t2) (notype_lambda (
            app (app (lvar 1 term_var) (lvar 0 term_var)) (lvar 2 term_var)
          ))
        ))
      ))
    | _, _ => None
    end;
  cps_rec false (notype_lambda t) nf :=
    match (cps_rec false (open 0 t (fvar nf term_var)) (S nf)) with
    | Some csp_open_t =>
      Some (notype_lambda (
        app (lvar 0 term_var) (notype_lambda (
          (* Don't need to add the second lambda as it is included in csp_open_t *)
          close 0 csp_open_t nf
        ))
      ))
    | _ => None
    end;

  cps_rec false (notype_tfix t) nf := None;

  cps_rec false notype_err nf := Some notype_err;
  cps_rec false (ite cond tthen telse) nf :=
  match (cps_rec false cond nf), (cps_rec false tthen nf), (cps_rec false telse nf) with
  | Some cps_cond, Some cps_tthen, Some cps_telse =>
    Some (notype_lambda (
      app (cps_cond) (notype_lambda (
        ite (lvar 0 term_var)
            (app cps_tthen (notype_lambda (app (lvar 2 term_var) (lvar 0 term_var))))
            (app cps_telse (notype_lambda (app (lvar 2 term_var) (lvar 0 term_var))))
      ))
    ))
  | _, _, _ => None
  end;
  cps_rec false (pp t1 t2) nf := None;
  cps_rec false (pi1 t) nf := None;
  cps_rec false (pi2 t) nf := None;

  (*
    tmatch t t0 ts =>
      λk.
        (cps_t (
          λrt. tmatch rt
                  (cps_t0 k)
                  ((close 0 cps_ts nf) k)
        ))
  *)
  cps_rec false (tmatch t t0 ts) nf :=
    match (cps_rec false t nf),
      (cps_rec false t0 nf),
      (cps_rec false (open 0 ts (fvar nf term_var)) (S nf)) with
    | Some cps_t, Some cps_t0, Some cps_ts =>
      Some (notype_lambda (
        app cps_t (notype_lambda (
          tmatch (lvar 0 term_var)
            (app cps_t0 (lvar 1 term_var))
            (* because 0 is used by the free variable of the pattern *)
            (app (close 0 cps_ts nf) (lvar 2 term_var))
        ))
      ))
    | _, _, _ => None
    end;
  cps_rec false (sum_match t tl tr) nf :=
    match (cps_rec false t nf),
      (cps_rec false (open 0 tl (fvar nf term_var)) (S nf)),
      (cps_rec false (open 0 tr (fvar nf term_var)) (S nf)) with
    | Some cps_t, Some cps_tl, Some cps_tr =>
      Some (notype_lambda (
        app cps_t (notype_lambda (
          sum_match (lvar 0 term_var)
            (* because 0 is used by the free variable of the pattern *)
            (app (close 0 cps_tl nf) (lvar 2 term_var))
            (app (close 0 cps_tr nf) (lvar 2 term_var))
        ))
      ))
    | _, _, _ => None
    end;
  cps_rec false (tleft t') nf :=
    if (is_open_value t') then
      option_map
        (fun cps_v => notype_lambda (app (lvar 0 term_var) (tleft (cps_v))))
        (cps_rec true t' nf)
    else
      option_map
        (fun cps_t' =>
          (notype_lambda (
            app (cps_t') (notype_lambda (
              app (lvar 1 term_var) (tleft (lvar 0 term_var))
            ))
          ))
        )
        (cps_rec false t' nf);
  cps_rec false (tright t') nf :=
    if (is_open_value t') then
      option_map
        (fun cps_v => notype_lambda (app (lvar 0 term_var) (tright (cps_v))))
        (cps_rec true t' nf)
    else
      option_map
        (fun cps_t' =>
          (notype_lambda (
            app (cps_t') (notype_lambda (
              app (lvar 1 term_var) (tright (lvar 0 term_var))
            ))
          ))
        )
        (cps_rec false t' nf);
  cps_rec false (boolean_recognizer r t) nf := None;
  cps_rec false (unary_primitive o t) nf := None;
  cps_rec false (binary_primitive o t1 t2) nf := None;
  cps_rec false (tsize t) nf := None;

  cps_rec false _ _ := None;

  (* CPS value *)
  cps_rec true (fvar n term_var) _ := Some (fvar n term_var);
  cps_rec true uu _ := Some uu;
  cps_rec true ttrue _ := Some ttrue;
  cps_rec true tfalse _ := Some tfalse;
  cps_rec true (pp e1 e2) _ := None;
  cps_rec true (tleft e) nf := option_map tleft (cps_rec true e nf);
  cps_rec true (tright e) nf := option_map tright (cps_rec true e nf);
  cps_rec true zero _ := Some zero;
  cps_rec true (succ e) nf :=
    option_map succ (cps_rec true e nf);
  cps_rec true (notype_lambda t') nf :=
    let open_t : tree := open 0 t' (fvar nf term_var) in
    let cps_t : option tree := cps_rec false open_t (S nf) in
    let close_t : option tree := option_map (fun cps_t => close 0 cps_t nf) cps_t in
      option_map (fun close_t => notype_lambda (close_t)) close_t;
  cps_rec true _ nf := None
}.

Ltac cps_rec_def :=
  program_simplify; CoreTactics.equations_simpl;
  try program_solve_wf;
  try solve [rewrite open_t_size; lia]; lia.

Solve Obligations with cps_rec_def.
Fail Next Obligation.

Definition cps (t : tree) := cps_rec false t 0.

Definition cps_value (t : tree) := cps_rec true t 0.

Opaque cps_rec.

Require Import Coq.Classes.RelationClasses.

(* see https://github.com/coq/coq/issues/3814 *)
#[export] Instance: subrelation eq Basics.impl.
Proof.
  steps.
Qed.

#[export] Instance: subrelation eq (Basics.flip Basics.impl).
Proof.
  steps.
Qed.

Ltac simp_cps_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat outermost hints cps_rec in H
  end.

Ltac simp_cps_top_level_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat hints cps_rec in H
  end.

Ltac simp_cps_goal := rewrite_strat outermost hints cps_rec.

Ltac simp_cps_top_level_goal := rewrite_strat hints cps_rec.

Ltac simp_cps := simp_cps_hyp || simp_cps_goal.

Lemma cps_not_def_cps_value_not_def: forall t nf,
  cps_rec false t nf = None -> cps_rec true t nf = None.
Proof.
  induction t;
  repeat light || simp_cps || options || destruct_match
  || destruct_tag || instantiate_any.
Qed.

#[export]
Hint Resolve cps_not_def_cps_value_not_def : cps.

Lemma cps_of_value: forall v nf, is_open_value v = true ->
  cps_rec false v nf =
  option_map
    (fun cps_value_v => notype_lambda (app (lvar 0 term_var) cps_value_v))
    (cps_rec true v nf).
Proof.
  induction v;
  repeat light || simp_cps || options
  || invert_constructor_equalities || destruct_match.
Qed.

#[export]
Hint Resolve cps_of_value : cps.

Ltac instantiate_cps_of_value :=
  match goal with
  | H: is_open_value ?t = true,
    H': cps_rec ?value ?t ?nf = Some _ |- _ =>
    poseNew (Mark t "cps_of_value");
    unshelve epose proof cps_of_value t nf _;
    eauto with open_value cps
  | H: cbv_value ?t,
    H': cps_rec ?value ?t ?nf = Some _ |- _ =>
    poseNew (Mark t "cps_of_value");
    unshelve epose proof cps_of_value t nf _;
    eauto with open_value cps
  end.

Lemma cps_of_value_is_open_value : forall p cps_p nf,
  cps_rec true p nf = Some cps_p -> is_open_value cps_p = true.
Proof.
  induction p; try destruct_tag;
  repeat light || simp_cps || options
  || destruct_match || invert_constructor_equalities;
  eauto.
Qed.

#[export]
Hint Resolve cps_of_value_is_open_value : cps.

Definition is_variable (t : tree) nf : Prop :=
  match t with
  | fvar i term_var => i < nf
  | _ => False
  end.

Lemma sub_wfs: forall sub nf,
  (forall s, s ∈ (range sub) -> is_variable s nf) ->
    wfs sub 0.
Proof.
  induction sub;
  repeat light || destruct_match || unfold is_variable in *.
  - unshelve epose proof H t _; repeat light || destruct_match.
  - eapply_any; repeat light.
    unshelve epose proof H s _; repeat light. eauto.
Qed.

#[export]
Hint Resolve sub_wfs: wf.

Lemma is_variable_monotonic: forall t nf,
  is_variable t nf -> is_variable t (S nf).
Proof.
  unfold is_variable; repeat light || destruct_match.
Qed.

#[export]
Hint Resolve is_variable_monotonic : open_value.

Lemma is_variable_is_open_value: forall s nf,
  is_variable s nf -> is_open_value s = true.
Proof.
  unfold is_variable; repeat light || destruct_match.
Qed.

Lemma is_variables_is_open_value: forall nf ls,
  (forall s', s' ∈ ls -> is_variable s' nf) ->
  forall s, s ∈ ls -> is_open_value s = true.
Proof.
  eauto using is_variable_is_open_value.
Qed.

#[export]
Hint Resolve is_variable_is_open_value is_variables_is_open_value : open_value.

Lemma substitute_close2: forall t k nf nf' sub, nf < nf' ->
  (forall s, s ∈ (range sub) -> is_variable s nf') ->
  (forall x, x ∈ (support sub) -> x < nf) ->
  (forall n, n ∈ (pfv t term_var) -> n < nf') ->
    close k (psubstitute t ((nf, fvar nf' term_var) :: sub) term_var) nf' =
    psubstitute (close k t nf) sub term_var.
Proof.
  induction t;
  repeat light || destruct_match || invert_constructor_equalities
   || t_equality || t_lookup || unfold is_variable in *; try lia;
  try solve [apply_any; auto; repeat light; apply_any; repeat list_utils; auto].
  - instantiate_any.
    repeat light || destruct_match; try lia.
  - unshelve epose proof H2 n _; lia.
Qed.

#[export]
Hint Resolve substitute_close2 : close.

Lemma open_keeps_wf: forall t i n nf, wf t n -> wf (open i t (fvar nf term_var)) n.
Proof.
  induction t; light; steps.
Qed.

Lemma close_keeps_wf: forall t nf i n,
  wf t n -> i < n -> wf (close i t nf) n.
Proof.
  induction t; light;
  auto with step_tactic lia.
Qed.

#[export]
Hint Resolve open_keeps_wf close_keeps_wf : wf.

Ltac instantiate_IH_cps_rec_outputs_erased_terms' IH :=
  match goal with
  | H: cps_rec _ _ _ = Some _ |- _ =>
      unshelve epose proof IH _ _ _ _ H _;
      clear H;
      eauto with lia erased
  end.

Lemma cps_rec_outputs_erased_terms': forall size_t t nf cps_t value,
  cps_rec value t nf = Some cps_t -> tree_size t < size_t -> is_erased_term cps_t.
Proof.
  induction size_t; try lia; destruct t; destruct value;
  repeat light || simp_cps || destruct_match
  || invert_constructor_equalities || options
  || destruct_tag
  || instantiate_IH_cps_rec_outputs_erased_terms' IHsize_t;
  rewrite open_t_size;
  eauto with lia.
Qed.

Lemma cps_rec_outputs_erased_terms: forall t nf cps_t value,
  cps_rec value t nf = Some cps_t -> is_erased_term cps_t.
Proof.
  eauto using cps_rec_outputs_erased_terms'.
Qed.

Ltac instantiate_cps_rec_erased :=
  match goal with
  | H: cps_rec _ _ _ = Some _ |- _ =>
    poseNew (Mark H "cps_rec_erased");
    unshelve epose proof cps_rec_outputs_erased_terms _ _ _ _ H;
    t_closer
  end.

#[export]
Hint Resolve cps_rec_outputs_erased_terms : cps.

Ltac apply_IH_cps_rec_wf' IH :=
  match goal with
  | H: cps_rec _ ?t ?nf = Some ?t' |- _ =>
    unshelve epose proof IH _ _ _ _ _ _ H; clear H
  end.

Lemma cps_rec_wf': forall size_t t nf cps_t value,
  tree_size t < size_t ->
    wf t 0 -> cps_rec value t nf = Some cps_t ->
      wf cps_t 0.
Proof.
  induction size_t; repeat light; try lia;
  destruct t; destruct value; try destruct_tag; simp_cps;
  repeat light || destruct_match
  || invert_constructor_equalities || apply_IH_cps_rec_wf' IHsize_t
  || rewrite open_t_size || options;
  eauto with lia wf step_tactic.
Qed.

Lemma cps_rec_wf: forall t nf cps_t value,
  cps_rec value t nf = Some cps_t -> wf t 0 ->
    wf cps_t 0.
Proof.
  eauto using cps_rec_wf'.
Qed.

Ltac instantiate_cps_rec_wf :=
  match goal with
  | H: cps_rec _ ?t _ = Some ?t',
    H': wf ?t 0 |- _ =>
      poseNew (Mark H "cps_rec_wf");
      unshelve epose proof cps_rec_wf _ _ _ _ H H'
  | H: cps_rec _ ?t _ = Some ?t',
    H': closed_term ?t |- _ =>
    poseNew (Mark H "cps_rec_wf");
    unshelve epose proof cps_rec_wf _ _ _ _ H _; t_closer
  | H: cps_rec _ ?t _ = Some ?t',
    H': closed_value ?t |- _ =>
    poseNew (Mark H "cps_rec_wf");
    unshelve epose proof cps_rec_wf _ _ _ _ H _; t_closer
  end.

Ltac rewrite_open_none :=
  repeat rewrite open_none;
  try solve [
    repeat instantiate_cps_rec_wf;
    eauto using wf_monotone2 with wf
  ].

#[export]
Hint Resolve cps_rec_wf : cps.

Ltac apply_IH_cps_rec_pfv' IH :=
  match goal with
  | H: cps_rec _ ?t ?nf = Some ?t',
    H': ?x ∈ (pfv ?t' term_var) |- _ =>
    unshelve epose proof IH t _ nf t' x _ H _ eq_refl _ _; clear H
  end.

Lemma cps_rec_pfv': forall size_t t fvs nf t' x value,
  cps_rec value t nf = Some t' ->
  tree_size t < size_t -> pfv t term_var = fvs ->
  (forall n, n ∈ fvs -> n < nf) ->
    x ∈ (pfv t' term_var) -> x ∈ fvs.
Proof.
  induction size_t; light; try lia.
  destruct t eqn:E; destruct value;
  repeat light || simp_cps_hyp || destruct_match || destruct_tag
  || invert_constructor_equalities || list_utils
  || apply_IH_cps_rec_pfv' IHsize_t
  || rewrite open_t_size || fv_close || fv_open || options;
  try lia.
Qed.

Lemma cps_rec_pfv: forall t fvs nf t' x value,
  cps_rec value t nf = Some t' ->
  pfv t term_var = fvs ->
  (forall n, n ∈ fvs -> n < nf) ->
    x ∈ (pfv t' term_var) -> x ∈ fvs.
Proof.
  eauto using cps_rec_pfv'.
Qed.

Lemma cps_rec_pfv_nil: forall t nf cps_t value,
  pfv t term_var = nil -> cps_rec value t nf = Some cps_t -> pfv cps_t term_var = nil.
Proof.
  light.
  destruct (pfv cps_t term_var) eqn:E; auto.
  unshelve epose proof cps_rec_pfv t nil nf cps_t n _ _ _ _ _;
  repeat light; try lia.
  rewrite E.
  repeat light.
Qed.

#[export]
Hint Resolve cps_rec_pfv cps_rec_pfv_nil : cps.

Ltac instantiate_cps_rec_pfv :=
  match goal with
  | H: cps_rec _ ?t _ = Some _,
    H': pfv ?t term_var = nil |- _ =>
      poseNew (Mark (H, H') "cps_rec_pfv_nill");
      unshelve epose proof cps_rec_pfv_nil _ _ _ _ H' H
  | H: cps_rec _ _ _ = Some ?t,
    H': ?n ∈ pfv ?t term_var |- _ =>
      poseNew (Mark (H, H') "cps_rec_pfv");
      unshelve epose proof cps_rec_pfv _ _ _ _ _ _ H eq_refl _ H';
      repeat light || fv_open || list_utils || destruct_match;
      eauto with cps; try lia
  end.

Lemma cps_rec_open_value: forall v cps_v value nf,
  is_open_value v = true ->
  cps_rec value v nf = Some cps_v ->
    is_open_value cps_v = true.
Proof.
  induction v; destruct value;
  repeat light || simp_cps || destruct_tag || invert_constructor_equalities
  || options || destruct_match;
  eauto.
Qed.

#[export]
Hint Resolve cps_rec_open_value : cps.

Ltac instantiate_cps_rec_open_value :=
  match goal with
  | H: cps_rec _ ?t _ = Some _,
    H': is_open_value ?t = true |- _ =>
      poseNew (Mark (H, H') "cps_rec_open_value");
      unshelve epose proof cps_rec_open_value _ _ _ _ H' H
  | H: cps_rec _ ?t _ = Some _,
    H': cbv_value ?t |- _ =>
      poseNew (Mark (H, H') "cps_rec_open_value");
      unshelve epose proof cps_rec_open_value _ _ _ _ _ H;
      eauto with open_value
  end.

Lemma cps_rec_closed_value_is_value: forall v cps_v value nf,
  closed_value v -> cps_rec value v nf = Some cps_v -> closed_value cps_v.
Proof.
  t_closing;
  eauto with cps open_value.
Qed.

Lemma fv_close_cps_rec: forall t cps_t k x nf value,
  pfv t term_var = nil -> x < nf ->
  cps_rec value (open k t (fvar x term_var)) nf = Some cps_t ->
    subset (pfv cps_t term_var) (x::nil).
Proof.
  unfold subset; repeat light.
  left.
  eapply cps_rec_pfv in H1; eauto;
  repeat light || fv_open || list_utils || destruct_match.
Qed.

#[export]
Hint Resolve fv_close_cps_rec : cps.

Lemma substitute_is_open_value: forall t sub tag,
  (forall s, s ∈ (range sub) -> is_open_value s = true) ->
    is_open_value t = true -> is_open_value (psubstitute t sub tag) = true.
Proof.
  induction t;
  repeat light || destruct_match || t_lookup || bools.
Qed.

Lemma substitute_is_not_open_value_contra: forall t sub,
  (forall s, s ∈ (range sub) -> is_open_value s = true) ->
    is_open_value (psubstitute t sub term_var) = true -> is_open_value t = true.
Proof.
  induction t;
  repeat light || destruct_match || bools || instantiate_any.
Qed.

Lemma substitute_is_not_open_value: forall t sub,
  (forall s, s ∈ (range sub) -> is_open_value s = true) ->
  is_open_value t = false ->
    is_open_value (psubstitute t sub term_var) = false.
Proof.
  light.
  destruct_is_open_value;
  repeat light.
  eapply_anywhere substitute_is_not_open_value_contra; eauto.
Qed.

Ltac apply_subst_is_value sub :=
  match goal with
  | H: is_open_value ?t = true |- _ =>
    unshelve epose proof substitute_is_open_value _ sub term_var _ H;
    eauto with open_value; try rewrite_any
  | H: is_open_value ?t = false |- _ =>
    unshelve epose proof substitute_is_not_open_value _ sub _ H;
    eauto with open_value; try rewrite_any
  end.

Ltac destruct_apply_subst_is_value :=
  match goal with
  | [|- context[is_open_value (psubstitute ?t ?sub term_var)]] =>
    let is_open_value_eqn := fresh "is_open_value_eqn" in
    destruct (is_open_value t) eqn:is_open_value_eqn;
    apply_subst_is_value sub;
    repeat light || t_lookup;
    try solve [t_closing; eauto with lia open_value]
  end.

#[export]
Hint Resolve substitute_is_open_value substitute_is_not_open_value : open_value.

Ltac apply_IH_cps_rec_subst_nf' IH :=
  match goal with
  | H: forall n, n ∈ pfv ?t term_var -> S n <= ?nf |-
    context[cps_rec ?value (psubstitute ?t ?sub term_var) ?nf'] =>
      poseNew (Mark (H, t) "apply IH");
      unshelve epose proof IH t sub (nf) (nf') value _ _ _ _ _;
      repeat light || list_utils || rewrite open_t_size || fv_open
      || destruct_match || invert_constructor_equalities || t_equality;
      eauto using is_variable_monotonic with lia
  | H: forall n, n ∈ pfv _ term_var -> S n <= ?nf |-
    context[cps_rec ?value (psubstitute ?t ?sub term_var) ?nf'] =>
      poseNew (Mark (H, t) "apply IH");
      unshelve epose proof IH t sub (S nf) (nf') value _ _ _ _ _;
      repeat light || list_utils || rewrite open_t_size || fv_open
      || destruct_match || invert_constructor_equalities || t_equality;
      eauto using is_variable_monotonic with lia
  | H: forall n, n ∈ pfv ?t term_var ++ pfv ?t' term_var -> S n <= ?nf |-
    context[cps_rec ?value (psubstitute _ ?sub term_var) ?nf'] =>
      poseNew (Mark (H) "apply IH");
      unshelve epose proof IH t sub (nf) (nf') value _ _ _ _ _;
      unshelve epose proof IH t' sub (nf) (nf') value _ _ _ _ _;
      repeat light || list_utils || rewrite open_t_size || fv_open
      || destruct_match || invert_constructor_equalities || t_equality;
      eauto using is_variable_monotonic with lia
  | H: forall n, n ∈ pfv ?t1 term_var ++ pfv ?t2 term_var ++ pfv ?t3 term_var ->
        S n <= ?nf |-
    context[cps_rec ?value (psubstitute ?t2 ?sub term_var) ?nf'] =>
      poseNew (Mark H "apply IH");
      unshelve epose proof IH t1 sub (nf) (nf') value _ _ _ _ _;
      unshelve epose proof IH t2 sub (nf) (nf') value _ _ _ _ _;
      unshelve epose proof IH
        (open 0 t3 (fvar nf term_var)) ((nf, fvar nf' term_var) :: sub)
        (S nf) (S nf') value _ _ _ _ _;
      repeat light || list_utils || rewrite open_t_size || fv_open
      || destruct_match || invert_constructor_equalities || t_equality;
      eauto using is_variable_monotonic with lia
  | H: forall n, n ∈ pfv ?t1 term_var ++ pfv ?t2 term_var ++ pfv ?t3 term_var ->
          S n <= ?nf |-
      context[cps_rec ?value (psubstitute ?t1 ?sub term_var) ?nf'] =>
        poseNew (Mark H "apply IH");
        unshelve epose proof IH t1 sub (nf) (nf') value _ _ _ _ _;
        unshelve epose proof IH
          (open 0 t2 (fvar nf term_var)) ((nf, fvar nf' term_var) :: sub)
          (S nf) (S nf') value _ _ _ _ _;
        unshelve epose proof IH
          (open 0 t3 (fvar nf term_var)) ((nf, fvar nf' term_var) :: sub)
          (S nf) (S nf') value _ _ _ _ _;
        repeat light || list_utils || rewrite open_t_size || fv_open
        || destruct_match || invert_constructor_equalities || t_equality;
        eauto using is_variable_monotonic with lia
  end.

Ltac contains_lookup :=
  match goal with
  | |- context[lookup Nat.eq_dec _ _] => idtac
  | |- _ => fail 2
  end.

Ltac contains_open :=
  match goal with
  | |- context[open _ _] => idtac
  | |- _ => fail 2
  end.

Lemma cps_rec_subst_nf': forall size_t t sub nf nf' value,
  tree_size t < size_t -> nf < nf' ->
  (forall n, n ∈ (pfv t term_var) -> n < nf) ->
  (forall s, s ∈ (range sub) -> is_variable s nf') ->
  (forall x, x ∈ (support sub) -> x < nf) ->
    cps_rec value (substitute t sub) nf' =
    option_map (fun res => substitute res sub)
    (cps_rec value t nf).
Proof.
  induction size_t; try lia.
  destruct t; destruct value;
  repeat light || simp_cps || invert_constructor_equalities
  || t_equality || options || destruct_tag;
  try solve [contains_lookup; unfold is_variable in *;
    repeat light || simp_cps || invert_constructor_equalities
    || t_equality || destruct_match || t_lookup || instantiate_any
  ];
  try solve [contains_open;
    repeat erewrite <- substitute_open3 with (x := nf);
    eauto with wf; try solve [
      repeat light || list_utils
      || instantiate_any;
      lia
    ];
    apply_IH_cps_rec_subst_nf' IHsize_t;
    apply substitute_close2;
    eauto with lia; light;
    instantiate_cps_rec_pfv;
    instantiate_any; lia
  ];
  try solve [try destruct_apply_subst_is_value;
  repeat apply_IH_cps_rec_subst_nf' IHsize_t; try lia;
  repeat light || list_utils
  || destruct_match || invert_constructor_equalities || t_equality].

  (* if *)
  unshelve epose proof IHsize_t t1 sub (nf) (nf') false _ _ _ _ _;
  unshelve epose proof IHsize_t t2 sub (nf) (nf') false _ _ _ _ _;
  unshelve epose proof IHsize_t t3 sub (nf) (nf') false _ _ _ _ _;
  repeat light || list_utils || rewrite open_t_size || fv_open
  || destruct_match || invert_constructor_equalities || t_equality;
  eauto using is_variable_monotonic with lia.
Qed.

Lemma cps_rec_subst_nf: forall t value sub nf nf',
  nf < nf' ->
  (forall n, n ∈ (pfv t term_var) -> n < nf) ->
  (forall s, s ∈ (range sub) -> is_variable s nf') ->
  (forall x, x ∈ (support sub) -> x < nf) ->
    cps_rec value (substitute t sub) nf' =
    option_map (fun res => substitute res sub)
    (cps_rec value t nf).
Proof.
  eauto using cps_rec_subst_nf'.
Qed.

Lemma cps_rec_nf: forall t nf nf' value,
  (forall n, n ∈ (pfv t term_var) -> n < nf) ->
  (forall n, n ∈ (pfv t term_var) -> n < nf') ->
    cps_rec value t nf = cps_rec value t nf'.
Proof.
  light.
  destruct (Compare_dec.lt_eq_lt_dec nf nf') as [[E | E] | E]; auto.
  - (* nf < nf' *)
    unshelve epose proof cps_rec_subst_nf t value nil nf nf' _ _ _ _; auto;
    repeat light || options || destruct_match || rewrite substitute_nothing3 in *.
  - (* nf > nf' *)
    unshelve epose proof cps_rec_subst_nf t value nil nf' nf _ _ _ _; auto;
    repeat light || options || destruct_match || rewrite substitute_nothing3 in *.
Qed.

#[export] Hint Rewrite cps_rec_nf : cps.

Ltac rewrite_with_cps_rec_nf :=
  match goal with
  | H: pfv ?t term_var = nil,
    H': cps_rec ?value ?t ?nf = Some _ |- _ =>
      rewrite (cps_rec_nf t nf 0 value) in *;
      repeat light || list_utils
  | H: pfv ?t term_var = nil |- cps_rec ?value ?t ?nf = Some _ =>
      rewrite (cps_rec_nf t nf 0 value) in *;
      repeat light || list_utils
  end.

Ltac apply_IH_cps_rec_subst IH :=
  match goal with
  | [|- context[cps_rec ?value (psubstitute ?t ((?x, ?v) :: nil) term_var) ?nf]] =>
    poseNew (Mark (value, t, x, v, nf) "apply_IH_cps_rec_subst");
    unshelve epose proof IH t nf value _ _ _;
    repeat light || fv_open || list_utils || rewrite open_t_size
    || invert_constructor_equalities;
    try solve [repeat light || destruct_match; lia]
  end.

Lemma cps_rec_subst: forall v cps_v x,
  closed_value v -> cps_rec true v 0 = Some cps_v -> forall p_size p nf value,
  tree_size p < p_size -> x < nf ->
  (forall n, n ∈ (pfv p term_var) -> n < nf) ->
    cps_rec value (substitute p ((x, v)::nil)) nf =
    option_map (fun cps_p => substitute cps_p ((x, cps_v)::nil)) (cps_rec value p nf) .
Proof.
  induction p_size; try lia; destruct p; destruct value; repeat light || simp_cps;
  try solve [t_closing;
    repeat light || simp_cps || destruct_match || destruct_tag || options
    || invert_constructor_equalities || t_equality || step_inversion cbv_value
    || instantiate_cps_of_value || rewrite_with_cps_rec_nf];
  try solve [
    repeat light || simp_cps || apply_IH_cps_rec_subst IHp_size || options
    || invert_constructor_equalities || t_equality || list_utils || destruct_match
  ]; try solve [
    destruct_apply_subst_is_value; apply_IH_cps_rec_subst IHp_size;
    repeat light || options || simp_cps || invert_constructor_equalities
    || t_equality || destruct_match
  ]; try solve [
    repeat rewrite substitute_open2 in *; repeat light || t_closer
    || invert_constructor_equalities || t_equality;
    try solve [repeat destruct_match || light; lia];
    repeat apply_IH_cps_rec_subst IHp_size;
    repeat light || options || destruct_match
    || invert_constructor_equalities || t_equality;
    rewrite substitute_close; repeat light; try lia;
    t_closing; eauto with cps
  ].
Qed.

Lemma cps_subst: forall v cps_v x nf,
  closed_value v -> cps_value v = Some cps_v -> forall p value, x < nf ->
  (forall n, n ∈ (pfv p term_var) -> n < nf) ->
    cps_rec value (substitute p ((x, v)::nil)) nf =
    option_map (fun cps_p => substitute cps_p ((x, cps_v)::nil)) (cps_rec value p nf).
Proof.
  eauto using cps_rec_subst.
Qed.

#[export]
Hint Resolve cps_subst : cps.

Lemma cps_value_def_for_values: forall v,
  cbv_value v -> exists cps_v, cps_value v = Some cps_v.
Proof.
Admitted.

Lemma cps_rec_defined_for_erased_wf_terms: forall t nf,
  wf t 0 -> is_erased_term t -> exists cps_t, cps_rec false t nf = Some cps_t.
Proof.
Admitted.

Lemma cps_defined_for_erased_wf_terms: forall t,
  wf t 0 -> is_erased_term t -> exists cps_t, cps t = Some cps_t.
Proof.
  eauto using cps_rec_defined_for_erased_wf_terms.
Qed.

#[export]
Hint Resolve cps_defined_for_erased_wf_terms cps_rec_defined_for_erased_wf_terms: cps.

Ltac solve_wf_cps_rec :=
  try solve [try apply wf_monotone2; eapply cps_rec_wf; eauto; t_closer];
  try solve [t_closing; eauto using wf_monotone2 with cps wf].

Ltac solve_pfv_nill_cps_rec :=
  try solve [eapply cps_rec_pfv_nil; eauto].

Ltac solve_erased_terms_cps_rec :=
  try solve [
    try eapply is_erased_term_close;
    eapply cps_rec_outputs_erased_terms; eauto].

Theorem cps_eval:
  forall p v, p ~~>* v -> closed_term p ->
    forall cps_p, cps p = Some cps_p ->
      exists cps_v, cps_value v = Some cps_v /\ (
        forall k r, closed_value k ->
          (app k (cps_v)) ~~>* r ->
            (app cps_p k) ~~>* r
      ).
Proof.
  induction 1; light; unfold cps, cps_value in *; repeat simp_cps;
  try solve [
    repeat invert_constructor_equalities || destruct_match || light || options;
    eexists; repeat light; econstructor; t_closer; auto
  ].
  - (* succ *)
    options; destruct_is_open_value;
    repeat light || invert_constructor_equalities.
    + unshelve epose proof bs_unique t v t _ _;
      try solve [
        t_closing;
      t_closing;
        t_closing;
        eauto using value_bs with values open_value
      ].
      repeat light || rewrite_any
      || destruct_match || invert_constructor_equalities.
      eexists; repeat light; t_closing.
      eapply ss_bs; [econstructor | idtac];
      repeat light.
      rewrite_open_none.
    + repeat light || invert_constructor_equalities
      || destruct_match;
      unshelve epose proof H2 _ eq_refl; steps.
      eexists; repeat light.
      eapply ss_bs; [econstructor | idtac];
      repeat light; t_closing.
      rewrite_open_none.
      apply_any; t_closer.
      remember H as H'; clear HeqH'.
      apply bs_closed_term in H; t_closing.
      apply bs_value in H'.
      repeat instantiate_cps_rec_pfv.
      instantiate_cps_rec_open_value.
      eapply ss_bs; [econstructor | idtac];
      eauto with open_value cps.
      repeat light.
      rewrite_open_none.
  - (* tmatch zero _ _ *)
    repeat invert_constructor_equalities || destruct_match || light || options || step.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl; t_closer; steps.
    unshelve epose proof IHbcbv_step2 _ _ eq_refl; t_closer; steps.
    rewrite_any.
    eexists; repeat light.
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    apply_any.
    + t_closing;
      eauto with cps;
      solve_wf_cps_rec;
      eauto with cps erased.
      eauto using fv_close_nil2, fv_close_cps_rec.
    + eapply ss_bs.
      econstructor; t_closer.
      repeat light.
      rewrite_open_none;
      solve_wf_cps_rec.
      econstructor; eauto with bcbv_step; repeat light.
  - (* tmatch (succ v) _ _ *)
    unshelve epose proof cps_rec_defined_for_erased_wf_terms (open 0 ts (fvar 0 term_var)) 1 _ _.
    apply wf_open; t_closer.
    apply is_erased_open; t_closer.
    apply bs_closed_term in H; t_closer.
    apply bs_closed_term in H0; t_closer.
    unshelve epose proof cps_value_def_for_values v' _; t_closer.
    steps.
    eexists; repeat light; eauto with cps.
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl; t_closer.
    steps.
    repeat light || options || destruct_match || invert_constructor_equalities.
    unshelve epose proof cps_rec_closed_value_is_value _ _ _ _ _ matched2;
    try solve [
      t_closing;
      step_inversion cbv_value;
      eauto
    ].
    apply_any; try solve [
      t_closing;
      repeat instantiate_cps_rec_pfv;
      repeat instantiate_cps_rec_wf;
      eauto using fv_close_cps_rec, fv_close_nil2 with cps wf;
      solve_wf_cps_rec;
      solve_erased_terms_cps_rec
    ].
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    eapply BSmatchS.
    + constructor.
      apply value_bs.
      t_closer.
    + repeat light.
      rewrite open_close; solve_wf_cps_rec.
      rewrite_open_none; solve_wf_cps_rec.
      unshelve epose proof cps_subst _ _ 0 1 _ matched2
        (open 0 ts (fvar 0 term_var)) false _ _;
      t_closer;
      repeat light || fv_open || list_utils || destruct_match;
      try solve [
        t_closing;
        step_inversion cbv_value;
        eauto
      ].
      repeat light || options || destruct_match || invert_constructor_equalities.
      rewrite substitute_open3 in *; t_closer.
      t_substitutions.
      rewrite (cps_rec_nf (open 0 ts v) 1 0 false) in *;
      repeat light || fv_open || list_utils || destruct_match; t_closer.
      unshelve epose proof IHbcbv_step2 _ _ H6; t_closer; steps.
      apply_any; t_closer.
      unfold cps_value in *.
      repeat light.
  - (* lambda *)
    repeat invert_constructor_equalities || destruct_match || light || options.
    eexists; repeat light; t_closing.
    econstructor;
    try solve [eapply value_bs; t_closer];
    repeat light.
    rewrite open_none;
    eauto using wf_monotone2, cps_rec_wf with bcbv_step wf lia.
  - (* app *)
    unshelve epose proof bs_closed_term _ _ H _;
    unshelve epose proof bs_closed_term _ _ H0 _; t_closer.
    repeat light.

    unshelve epose proof cps_rec_defined_for_erased_wf_terms (open 0 b1 (fvar 0 term_var)) 1 _ _.
    apply wf_open; t_closer.
    apply is_erased_open; t_closer.

    repeat invert_constructor_equalities|| destruct_match || light || options || step.
    unshelve epose proof IHbcbv_step2 _ _ eq_refl; repeat step;
    try solve [
      unfold closed_value; light; eauto with values;
      eapply bs_closed_term; eauto;
      t_closer
    ]; t_closer.

    unshelve epose proof IHbcbv_step3 _ (substitute cps_t ((0, cps_v)::nil)) _;
    t_closer.
    + unshelve epose proof cps_subst _ _ 0 1 _ H6 (open 0 b1 (fvar 0 term_var)) false _ _;
      repeat light; try lia; eauto with values.
      * repeat light || list_utils || fv_open; t_closer.
      * rewrite substitute_open3 in *; t_closer.
        t_substitutions.
        rewrite matched2 in *; repeat light.
        rewrite (cps_rec_nf _ _ 0) in H3; repeat light || fv_open; t_closer.
    + repeat step.
      eexists; light; eauto.
      econstructor; eauto with bcbv_step; repeat light;
      try solve [eapply value_bs; t_closer].
      rewrite_open_none; solve_wf_cps_rec.
      unshelve epose proof IHbcbv_step1 _ _ eq_refl; repeat step;
      t_closer; try solve [
        unfold closed_value; light; eauto with values;
        eapply bs_closed_term; eauto; t_closer
      ].
      apply_any. (* From IHbcbv_step1 *)
      * t_closing;
        eauto using wf_monotone2 with cps.
      * econstructor; eauto with bcbv_step; repeat light;
        try solve [eapply value_bs; t_closer].
        rewrite_open_none; solve_wf_cps_rec.
        apply_any. (* From IHbcbv_step2 *)
        -- t_closing;
          eauto using fv_close_nil2, fv_close_cps_rec;
          eauto 7 using wf_monotone2, close_keeps_wf, cps_rec_wf with wf;
          eauto using is_erased_term_close, cps_rec_outputs_erased_terms.
        -- econstructor; eauto with bcbv_step; repeat light;
          try solve [eapply value_bs; t_closer].
          eapply value_bs.
          try solve [
            t_closing;
            repeat instantiate_cps_rec_pfv;
            apply bs_value in H0;
            repeat instantiate_cps_rec_open_value
          ].
          rewrite_open_none;
          try solve [
            t_closing;
            eauto 7 using wf_monotone2, close_keeps_wf, cps_rec_wf with wf
          ].
          apply ss_bs with (app (psubstitute cps_t ((0, cps_v) :: nil) term_var) k);
          auto. (* From IHbcbv_step3 *)
          constructor.
          rewrite <- open_close with (k := 0);
          try solve [t_closing; eapply cps_rec_wf; eauto with wf].
          constructor.
          eauto with cps.
          t_closing.
          repeat apply_anywhere bs_value;
          repeat apply_anywhere cbv_value_is_open_value_true;
          repeat instantiate_cps_rec_pfv;
          repeat instantiate_cps_rec_open_value;
          eapply no_free_var_open_value_is_value;
          eauto.
  - (* if true _ _*)
    repeat invert_constructor_equalities || destruct_match || light || options || step.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl;
    unshelve epose proof IHbcbv_step2 _ _ eq_refl;
    t_closer.
    steps.
    eexists; repeat light; t_closing.
    eapply ss_bs; [econstructor | idtac];
    repeat light.
    rewrite_open_none.
    apply H6; repeat light || list_utils || solve_wf_cps_rec; eauto with wf fv cps.
    eapply ss_bs; [econstructor | idtac]; steps.
    econstructor; eauto with values.
    rewrite_open_none.
    apply H5; repeat light || list_utils; eauto with wf values.
    eapply ss_bs; [econstructor | idtac]; try solve [step; rewrite_open_none].
    eapply no_free_var_open_value_is_value.
    remember H0 as H'; clear HeqH'.
    repeat apply_anywhere bs_value;
    repeat instantiate_cps_rec_open_value.
    apply bs_closed_term in H0; t_closing.
    solve_pfv_nill_cps_rec.
  - (* if false _ _*)
    repeat invert_constructor_equalities || destruct_match || light || options || step.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl;
    unshelve epose proof IHbcbv_step2 _ _ eq_refl;
    t_closer.
    steps.
    eexists; repeat light; t_closing.
    eapply ss_bs; [econstructor | idtac];
    repeat light.
    rewrite_open_none.
    apply H6; repeat light || list_utils || solve_wf_cps_rec; eauto with wf fv cps.
    eapply ss_bs; [econstructor | idtac]; steps.
    apply BSitefalse; eauto with values.
    rewrite_open_none.
    apply H5; repeat light || list_utils; eauto with wf values.
    eapply ss_bs; [econstructor | idtac]; try solve [step; rewrite_open_none].
    eapply no_free_var_open_value_is_value.
    remember H0 as H'; clear HeqH'.
    repeat apply_anywhere bs_value;
    repeat instantiate_cps_rec_open_value.
    apply bs_closed_term in H0; t_closing.
    solve_pfv_nill_cps_rec.
  - (* tleft *)
    options; destruct_is_open_value;
    repeat light || invert_constructor_equalities.
    + unshelve epose proof bs_unique t v t _ _;
      try solve [
        t_closing;
      t_closing;
        t_closing;
        eauto using value_bs with values open_value
      ].
      repeat light || rewrite_any
      || destruct_match || invert_constructor_equalities.
      eexists; repeat light; t_closing.
      eapply ss_bs; [econstructor | idtac];
      repeat light.
      rewrite_open_none.
    + repeat light || invert_constructor_equalities
      || destruct_match;
      unshelve epose proof H2 _ eq_refl; steps.
      eexists; repeat light.
      eapply ss_bs; [econstructor | idtac];
      repeat light; t_closing.
      rewrite_open_none.
      apply_any; t_closer.
      remember H as H'; clear HeqH'.
      apply bs_closed_term in H; t_closing.
      apply bs_value in H'.
      repeat instantiate_cps_rec_pfv.
      instantiate_cps_rec_open_value.
      eapply ss_bs; [econstructor | idtac];
      eauto with open_value cps.
      repeat light.
      rewrite_open_none.
  - (* tright *)
    options; destruct_is_open_value;
    repeat light || invert_constructor_equalities.
    + unshelve epose proof bs_unique t v t _ _;
      try solve [
        t_closing;
      t_closing;
        t_closing;
        eauto using value_bs with values open_value
      ].
      repeat light || rewrite_any
      || destruct_match || invert_constructor_equalities.
      eexists; repeat light; t_closing.
      eapply ss_bs; [econstructor | idtac];
      repeat light.
      rewrite_open_none.
    + repeat light || invert_constructor_equalities
      || destruct_match;
      unshelve epose proof H2 _ eq_refl; steps.
      eexists; repeat light.
      eapply ss_bs; [econstructor | idtac];
      repeat light; t_closing.
      rewrite_open_none.
      apply_any; t_closer.
      remember H as H'; clear HeqH'.
      apply bs_closed_term in H; t_closing.
      apply bs_value in H'.
      repeat instantiate_cps_rec_pfv.
      instantiate_cps_rec_open_value.
      eapply ss_bs; [econstructor | idtac];
      eauto with open_value cps.
      repeat light.
      rewrite_open_none.
  - (* sum_match (tleft _) _ _ *)
    unshelve epose proof cps_rec_defined_for_erased_wf_terms (open 0 tl (fvar 0 term_var)) 1 _ _.
    apply wf_open; t_closer.
    apply is_erased_open; t_closer.

    apply bs_closed_term in H; t_closer.
    apply bs_closed_term in H0; t_closer.
    unshelve epose proof cps_value_def_for_values v' _; t_closer.
    steps.
    eexists; repeat light; eauto with cps.
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl; t_closer.
    steps.
    repeat light || options || destruct_match || invert_constructor_equalities.
    unshelve epose proof cps_rec_closed_value_is_value _ _ _ _ _ matched2;
    try solve [
      t_closing;
      step_inversion cbv_value;
      eauto
    ].
    apply_any; try solve [
      t_closing;
      repeat instantiate_cps_rec_pfv;
      repeat instantiate_cps_rec_wf;
      eauto using fv_close_cps_rec, fv_close_nil2 with cps wf;
      solve_wf_cps_rec;
      solve_erased_terms_cps_rec
    ].
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    eapply BSmatchLeft.
    + constructor.
      apply value_bs.
      t_closer.
    + repeat light.
      rewrite open_close; solve_wf_cps_rec.
      rewrite_open_none; solve_wf_cps_rec.
      unshelve epose proof cps_subst _ _ 0 1 _ matched2
        (open 0 tl (fvar 0 term_var)) false _ _;
      t_closer;
      repeat light || fv_open || list_utils || destruct_match;
      try solve [
        t_closing;
        step_inversion cbv_value;
        eauto
      ].
      repeat light || options || destruct_match || invert_constructor_equalities.
      rewrite substitute_open3 in *; t_closer.
      t_substitutions.
      rewrite (cps_rec_nf (open 0 tl v) 1 0 false) in *;
      repeat light || fv_open || list_utils || destruct_match; t_closer.
      unshelve epose proof IHbcbv_step2 _ _ H6; t_closer; steps.
      apply_any; t_closer.
      unfold cps_value in *.
      repeat light.
  - (* sum_match (tright _) _ _ *)
    unshelve epose proof cps_rec_defined_for_erased_wf_terms (open 0 tr (fvar 0 term_var)) 1 _ _.
    apply wf_open; t_closer.
    apply is_erased_open; t_closer.

    apply bs_closed_term in H; t_closer.
    apply bs_closed_term in H0; t_closer.
    unshelve epose proof cps_value_def_for_values v' _; t_closer.
    steps.
    eexists; repeat light; eauto with cps.
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    unshelve epose proof IHbcbv_step1 _ _ eq_refl; t_closer.
    steps.
    repeat light || options || destruct_match || invert_constructor_equalities.
    unshelve epose proof cps_rec_closed_value_is_value _ _ _ _ _ matched2;
    try solve [
      t_closing;
      step_inversion cbv_value;
      eauto
    ].
    apply_any; try solve [
      t_closing;
      repeat instantiate_cps_rec_pfv;
      repeat instantiate_cps_rec_wf;
      eauto using fv_close_cps_rec, fv_close_nil2 with cps wf;
      solve_wf_cps_rec;
      solve_erased_terms_cps_rec
    ].
    eapply ss_bs.
    econstructor; t_closer.
    repeat light.
    rewrite_open_none; solve_wf_cps_rec.
    eapply BSmatchRight.
    + constructor.
      apply value_bs.
      t_closer.
    + repeat light.
      rewrite open_close; solve_wf_cps_rec.
      rewrite_open_none; solve_wf_cps_rec.
      unshelve epose proof cps_subst _ _ 0 1 _ matched2
        (open 0 tr (fvar 0 term_var)) false _ _;
      t_closer;
      repeat light || fv_open || list_utils || destruct_match;
      try solve [
        t_closing;
        step_inversion cbv_value;
        eauto
      ].
      repeat light || options || destruct_match || invert_constructor_equalities.
      rewrite substitute_open3 in *; t_closer.
      t_substitutions.
      rewrite (cps_rec_nf (open 0 tr v) 1 0 false) in *;
      repeat light || fv_open || list_utils || destruct_match; t_closer.
      unshelve epose proof IHbcbv_step2 _ _ H6; t_closer; steps.
      apply_any; t_closer.
      unfold cps_value in *.
      repeat light.
Qed.

Theorem cps_correct:
  forall p v, p ~~>* v -> closed_term p ->
    forall cps_p, cps p = Some cps_p ->
      exists cps_v, cps_value v = Some cps_v /\
        (app cps_p (notype_lambda (lvar 0 term_var))) ~~>* cps_v.
Proof.
  repeat light.
  unshelve epose proof cps_eval p v _ _ _ _; eauto.
  steps.
  exists cps_v; repeat light.
  apply_any; t_closer.
  econstructor.
  - econstructor.
  - eapply value_bs; eauto.
    apply bs_closed_term in H; light.
    eapply cps_rec_closed_value_is_value in H; eauto.
    t_closer.
  - light.
    apply value_bs.
    eapply (cps_rec_closed_value_is_value v); eauto with values.
Qed.


(* En este archivo se demuestra que la ejecución de
*  la acción resolveIntent preserva los invariantes del sistema *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import MyList.
Require Import ListAuxFuns.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.
Require Import Semantica.
Require Import EqTheorems.

Section ResolveIntentInv.

Lemma ResolveIntentIsInvariant : forall (s s':System) (sValid:validstate s) (intt:Intent) (a:idApp) , pre_resolveIntent intt a s -> post_resolveIntent intt a s s' -> validstate s'.
Proof.
    intros.
    unfold validstate.
    unfold pre_resolveIntent in H.
    unfold post_resolveIntent in H0.
    destruct H0 as [verified H0].
    destruct_conj H0.

    unfold allCmpDifferent.
    split.
    intros.

    apply (inAppS'InAppS a1 s) in H8;auto.
    apply (inAppS'InAppS a2 s) in H10;auto.
    apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.

    unfold notRepeatedCmps.
    split.
    intros.
    apply (inAppS'InAppS a1 s) in H8;auto.
    apply (inAppS'InAppS a2 s) in H10;auto.
    apply (inAppSameCmp s sValid c a1 a2);auto.

    unfold notCPrunning.
    split.
    rewrite <-H5.
    destructVS sValid.
    auto.

    split.
    apply (delTmpRunS' s);auto.

    split.
    apply (cmpRunAppInsS' s);auto.

    split.
    apply (resContAppInstS' s);auto.

    split.
    apply (consistencyUnchanged s);auto.

    unfold notDupApp.
    split.
    rewrite <- H0.
    rewrite<-H2.
    destructVS sValid.
    auto.

    unfold notDupSysApp.
    split.
    rewrite <-H0.
    destructVS sValid.
    auto.

    split.
    apply (notDupPermS' s);auto.

    unfold allMapsCorrect.
    split.
    rewrite <-H0, <-H3, <-H4, <- H5, <-H6, <-H7, <-H9.
    repeat (split;auto; try mapcorrect sValid).

    split.
    apply (grantedPermsExistS' s);auto.

    unfold implicitToExplicitIntent in H1.

    unfold noDupSentIntents;intros.
    destruct H1.
    destruct H1.
    destruct_conj H1.
    assert (H15' := H15).
    specialize (H15 i ic H8).
    specialize (H15' i' ic' H10).

    clear H H1 H17 H14.

    destructVS sValid.

    destruct H15.
    destruct H.
    destruct H15'.
    destruct H14.
    apply sentIntentsCorrectVS;auto.
    destruct H14.
    destruct_conj H14.
    rewrite H11 in H1.
    rewrite <- H16 in H1.
    contradiction.
    destruct H15'.
    destruct H1.
    destruct H.
    destruct_conj H.
    rewrite <- H11 in H14.
    rewrite<- H16 in H14.
    contradiction.
    destruct H.
    destruct H1.
    destruct_conj H.
    destruct_conj H1.

    assert (ic=ic' /\ x1=x2).
    apply sentIntentsCorrectVS;auto.
    rewrite H1;auto.
    destruct H33.
    split;auto.
    rewrite H35 in *.

    rewrite <-H16 in H26.
    rewrite H17 in H27.
    rewrite H18 in H28.
    rewrite H19 in H29.
    rewrite H20 in H30.
    rewrite H21 in H31.
    rewrite H22 in H32.
    rewrite H24 in H34.

    destruct i;simpl in *.
    destruct i';simpl in *.
    rewrite H11 ,H26 ,H27 ,H28 ,H29 ,H30 ,H31 ,H32 ,H34.
    auto.

Qed.

End ResolveIntentInv.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C D Bprime X : Universe, ((wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ Eprime A /\ (wd_ X O /\ (wd_ Bprime X /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprime /\ (col_ O E X /\ col_ O Eprime D))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D P Dprime : Universe, ((wd_ B C /\ (wd_ A D /\ (wd_ A C /\ (wd_ C D /\ (wd_ A B /\ (wd_ C Dprime /\ (wd_ Dprime A /\ (wd_ P A /\ (wd_ P C /\ (wd_ D Dprime /\ (wd_ B D /\ (col_ C D Dprime /\ (col_ Dprime A C /\ (col_ P B Dprime /\ col_ P A C)))))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Combi.Combi.subseq : Subsequence of a sequence as a fintype *)
(******************************************************************************)
(*      Copyright (C) 2014-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Subsequence of a sequence as a [fintype]
We define a sigma-type [subseqs w] for subsequence of a given sequence [w]
We show that [subseqs w] is canonically a [finType]. We define the three
following constructor

- [Subseqs Pf] == construct a [subseqs w] from a proof [subseq x w].
- [sub_nil w] == the empty sequence [[::]] as a [subseqs w].
- [sub_full w] == [w] as as a [subseqs w].

 *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat bigop.
From mathcomp Require Import eqtype choice fintype seq path tuple.
Require Import tools combclass sorted.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(******************************************************************************)
(** TODO: these probably should be contributed to path.v                      *)
(******************************************************************************)

(** ** A few lemmas about [subseq] and [rcons] *)
Section RCons.

Variable (T : eqType).
Implicit Type s w : seq T.
Implicit Type a b l : T.

Lemma subseq_rcons_eq s w l : subseq s w = subseq (rcons s l) (rcons w l).
Proof using. by rewrite -!cats1 subseq_cat2r. Qed.

Lemma subseq_rcons_neq s si w wn :
  si != wn -> subseq (rcons s si) (rcons w wn) = subseq (rcons s si) w.
Proof using.
move/negbTE => neq.
by rewrite -subseq_rev !rev_rcons /= neq -rev_rcons subseq_rev.
Qed.

End RCons.

Section SubseqSorted.

Variable (T : eqType) (leT : rel T).
Implicit Type s : seq T.

Lemma sorted_subseqP s1 s2 :
  transitive leT -> irreflexive leT -> sorted leT s1 -> sorted leT s2 ->
  reflect {subset s1 <= s2} (subseq s1 s2).
Proof.
move=> leT_trans leT_irr s1_sort s2_sort.
apply (iffP idP) => [|sub_s12]; first exact: mem_subseq.
apply/subseqP; exists [seq i \in s1 | i <- s2]; first by rewrite size_map.
apply: (irr_sorted_eq leT_trans leT_irr s1_sort).
  exact: (sorted_mask leT_trans).
move=> i; rewrite -filter_mask mem_filter.
by case: (boolP (i \in s1)) => // /sub_s12 ->.
Qed.

End SubseqSorted.

Section SubseqSortedIn.

Variable (T : eqType) (leT : rel T).
Implicit Type s : seq T.

Lemma sorted_subseq_inP s1 s2 :
  {in s2 & &, transitive leT} -> {in s2, irreflexive leT} ->
  sorted leT s1 -> sorted leT s2 ->
  reflect {subset s1 <= s2} (subseq s1 s2).
Proof.
move=> leT_tr leT_irr ss1 ss2; apply (iffP idP); first exact: mem_subseq.
move: leT_tr leT_irr ss1 ss2 => /in3_sig leT_tr /in1_sig leT_irr .
have /all_sigP[s2' ->] := allss s2 => + + /[dup] subs12.
have /all_sigP[{subs12}s1 ->] : all (mem s2) s1.
  by apply/allP => i /subs12 /mapP [[j /= j_in_s2 _ ->{i}]].
rewrite !sorted_map => ss1 ss2' subs12.
apply/map_subseq/(sorted_subseqP leT_tr leT_irr ss1 ss2').
by move=> i /(map_f sval) /subs12 /mapP[j j_in_s2'] /val_inj->.
Qed.

End SubseqSortedIn.

(** * Subsequence of a sequence as a [fintype]                                *)
(**
We define a dependent type [SubSeq w] and provide it with a Canonical
[finType] structure
**)

Section FinType.

Variables (T : choiceType) (w : seq T).

Structure subseqs : predArgType :=
  Subseqs {subseqsval :> seq T; _ : subseq subseqsval w}.
Canonical subseqs_subType := Eval hnf in [subType for subseqsval].
Definition subseqs_eqMixin := Eval hnf in [eqMixin of subseqs by <:].
Canonical subseqs_eqType := EqType subseqs subseqs_eqMixin.
Definition subseqs_choiceMixin := Eval hnf in [choiceMixin of subseqs by <:].
Canonical subseqs_choiceType := ChoiceType subseqs subseqs_choiceMixin.

Implicit Type (s : subseqs).

Lemma subseqsP s : subseq s w.
Proof using. by case: s => /= s. Qed.

Definition sub_nil  : subseqs := Subseqs (sub0seq w).
Definition sub_full : subseqs := Subseqs (subseq_refl w).

Lemma to_mask_spec s : {m : (size w).-tuple bool | mask m w == s}.
Proof.
move: s => [s subs]; apply/sigW => /=.
by move: subs => /subseqP [m /eqP szm ->{s}]; exists (Tuple szm).
Qed.
Definition to_mask s := let: exist m _ := to_mask_spec s in m.

Lemma to_maskK : cancel to_mask (fun m => Subseqs (mask_subseq (val m) w)).
Proof.
by rewrite /to_mask => s; case: to_mask_spec => m /eqP eqm; apply val_inj.
Qed.

Lemma mask1E x0 i :
  i < size w -> mask [tuple val x == i | x < size w] w = [:: nth x0 w i].
Proof.
move=> lti.
rewrite [val (mktuple _)](_ : _ = [seq x == i | x <- iota 0 (size w)]);
  last by rewrite /= (map_comp (pred1 i) val) val_enum_ord.
elim: w i lti => //= v0 v IHv [_|i /ltnSE lti] /=.
  rewrite [map _ _](_ : _ = nseq (size v) false) ?mask_false //.
  apply (eq_from_nth (x0 := false)) => [|i].
    by rewrite size_map size_iota size_nseq.
  rewrite size_map => lti; rewrite (nth_map 0) //.
  by rewrite size_iota in lti; rewrite nth_nseq lti nth_iota.
by rewrite -(add1n 0) iotaDl -map_comp -{}IHv.
Qed.

Lemma mask_injP :
  reflect (injective (fun m : (size w).-tuple bool => mask (val m) w))
          (uniq w).
Proof.
apply (iffP idP) => [w_uniq m1 m2 eqmask |].
- apply: eq_from_tnth => i; rewrite !(tnth_nth false).
  have Z : T by case: w i {w_uniq m1 m2 eqmask} => [[]|].
  have nthE m : (nth false m i) = (nth Z w i \in mask m w).
    by rewrite in_mask // (mem_nth Z (ltn_ord i)) /= index_uniq.
  by rewrite !nthE eqmask.
- case Hw: w => [//|w0 w']; rewrite -Hw => minj.
  pose f := (fun i : T => [:: i]).
  apply/(uniqP w0) => i j; rewrite !inE => lti ltj Heq.
  have {Heq}:= congr1 (cons^~ [::]) Heq.
  rewrite -!mask1E // => /minj /(congr1 (fun t => tnth t (Ordinal lti))).
  by rewrite !tnth_mktuple /= eqxx => /esym/eqP.
Qed.

Lemma Subseqs_maskK :
  uniq w -> cancel (fun m => Subseqs (mask_subseq (val m) w)) to_mask.
Proof.
rewrite /to_mask=> w_uniq m; case: to_mask_spec => m' /= /eqP.
exact/mask_injP.
Qed.

Definition subseqs_countMixin := CanCountMixin to_maskK.
Canonical subseqs_countType := CountType subseqs subseqs_countMixin.
Definition subseqs_finMixin := CanFinMixin to_maskK.
Canonical subseqs_finType := FinType subseqs subseqs_finMixin.

Lemma enum_subseqsE :
  perm_eq
    (enum {: subseqs})
    (undup [seq Subseqs (mask_subseq (val m) w) | m : (size w).-tuple bool]).
Proof.
apply: uniq_perm; [exact: enum_uniq | exact: undup_uniq |].
move=> [s subs] /=; rewrite mem_enum inE mem_undup.
apply/esym/mapP; have /subseqP [m /eqP szm eqs] := subs.
by exists (Tuple szm); [exact: mem_enum | exact: val_inj].
Qed.

Lemma val_enum_subseqs :
  perm_eq
    (map val (enum {: subseqs}))
    (undup [seq mask (val m) w | m : (size w).-tuple bool]).
Proof.
have /permPl -> := perm_map val enum_subseqsE.
rewrite -(undup_map_inj val_inj) -map_comp.
exact: (eq_ind _ (perm_eq _)).
Qed.

Lemma seq_masks_uniq :
  uniq w -> uniq [seq mask (val m) w | m : (size w).-tuple bool].
Proof.
move=> w_uniq; rewrite map_inj_uniq; first exact: enum_uniq.
exact/mask_injP.
Qed.

Lemma subseqs_masks_uniq :
  uniq w ->
  uniq [seq Subseqs (mask_subseq (val m) w) | m : (size w).-tuple bool].
Proof.
move /seq_masks_uniq => s_uniq.
by rewrite -(map_inj_uniq val_inj) -map_comp.
Qed.

End FinType.

Section Bigop.

Context {R : Type} {idx : R} {op : Monoid.com_law idx}.
Local Notation "1" := idx.
Local Notation "'*%M'" := op (at level 0).
Local Notation "x * y" := (op x y).
Context {T : choiceType}.

Lemma big_subseqs (F : seq T -> R) (s : seq T) :
  uniq s ->
  \big[*%M/1]_(i : subseqs s) F i =
  \big[*%M/1]_(m : (size s).-tuple bool) F (mask m s).
Proof.
move=> suniq; rewrite -big_enum.
rewrite (perm_big _ (enum_subseqsE s)) undup_id ?subseqs_masks_uniq //.
by rewrite big_map big_enum; exact: eq_bigr.
Qed.

Lemma big_subseqs_cond (P : pred (seq  T)) (F : seq T -> R) (s : seq T) :
  uniq s ->
  \big[*%M/1]_(i : subseqs s | P i) F i =
  \big[*%M/1]_(m : (size s).-tuple bool | P (mask m s)) F (mask m s).
Proof.
move=> suniq; rewrite [LHS]big_mkcond [RHS]big_mkcond.
exact: (big_subseqs (fun i => if P i then F i else 1)).
Qed.

Lemma big_subseqs0 (F : seq T -> R) :
  \big[*%M/1]_(i : subseqs [::]) F i = F [::].
Proof.
transitivity (\big[*%M/1]_(s <- [:: sub_full [::]]) F s); last by rewrite big_seq1.
apply: perm_big; apply uniq_perm => //; first exact: index_enum_uniq.
by move=> [{}s Hs]; rewrite !inE mem_index_enum -val_eqE /= -subseq0 Hs.
Qed.

Lemma big_subseqs_cons (F : seq T -> R) (a : T) (s : seq T) :
  uniq (a :: s) ->
  \big[*%M/1]_(i : subseqs (a :: s)) F i =
  \big[*%M/1]_(i : subseqs s) F (a :: i) * \big[*%M/1]_(i : subseqs s) F (i).
Proof.
move=> asuniq; have := asuniq => /= /andP [_ suniq].
rewrite !big_subseqs //.
rewrite [X in X * _](big_subseqs (fun s => F (a :: s))) //.
rewrite (bigID (fun m => tnth m ord0)) /=; congr( _ * _).
- rewrite [RHS](eq_big
                  (fun m => tnth (cons_tuple true m) ord0)
                  (fun m => F (mask (cons_tuple true m) (a :: s)))) //.
  apply: (reindex (@cons_tuple _ _ true)); exists (@behead_tuple _ _).
  + by move=> m _; apply val_inj; case: m => [[|m0 m]].
  + by move=> m; rewrite inE; case: m => [[|[|] m]]//= Hm _; exact: val_inj.
- rewrite [RHS](eq_big
                  (fun m => ~~ tnth (cons_tuple false m) ord0)
                  (fun m => F (mask (cons_tuple false m) (a :: s)))) //.
  apply: (reindex (@cons_tuple _ _ false)); exists (@behead_tuple _ _).
  + by move=> m _; apply val_inj; case: m => [[|m0 m]].
  + by move=> m; rewrite inE; case: m => [[|[|] m]]//= Hm _; exact: val_inj.
Qed.

Lemma big_subseqs_cons_cond
      (F : seq T -> R) (P : pred (seq T)) (a : T) (s : seq T) :
  uniq (a :: s) ->
  \big[*%M/1]_(i : subseqs (a :: s) | P i) F i =
  \big[*%M/1]_(i : subseqs s | P (a :: i)) F (a :: i) *
  \big[*%M/1]_(i : subseqs s | P i) F (i).
Proof.
move=> asuniq.
rewrite big_mkcond (big_subseqs_cons (fun i => if P i then F i else 1)) //.
by congr (_ * _); rewrite -big_mkcond.
Qed.

Lemma big_subseqs_undup (F : seq T -> R) (s : seq T) :
  idempotent op ->
  \big[*%M/1]_(i : subseqs s) F i =
  \big[*%M/1]_(m : (size s).-tuple bool) F (mask m s).
Proof.
move=> opid; rewrite -big_enum.
rewrite (perm_big _ (enum_subseqsE s)) big_undup //.
by rewrite big_map big_enum; exact: eq_bigr.
Qed.

Lemma big_subseqs_undup_cond (F : seq T -> R) (P : pred (seq T)) (s : seq T) :
  idempotent op ->
  \big[*%M/1]_(i : subseqs s | P i) F i =
  \big[*%M/1]_(m : (size s).-tuple bool | P (mask m s)) F (mask m s).
Proof.
move=> opid; rewrite big_mkcond /=.
by rewrite (big_subseqs_undup (fun i => if P i then F i else 1)) // big_mkcond.
Qed.

End Bigop.

(** * Relating sub sequences of [iota] and being sorted *)
Lemma sorted_subseq_iota_rcons s n : subseq s (iota 0 n) = sorted ltn (rcons s n).
Proof.
apply/idP/idP.
- move=> Hsubs.
  apply: (subseq_sorted ltn_trans (s2 := (iota 0 n.+1))).
  + by rewrite -addn1 iotaD add0n /= cats1 -subseq_rcons_eq.
  + exact: iota_ltn_sorted.
- elim: n s => [/= [//=| s0 s]| n IHn s].
    rewrite rcons_cons /= => /(order_path_min ltn_trans) /= /allP Hall.
    exfalso.
    suff /Hall : 0 \in rcons s 0 by [].
    by rewrite mem_rcons inE eq_refl.
  case/lastP: s => [_| s sn]; first exact: sub0seq.
  case: (ltnP sn n) => Hsn.
  + move/sorted_rconsK => Hsort.
    have:= Hsn; rewrite -{1}(last_rcons n s sn) => /(sorted_rcons Hsort)/IHn.
    move/subseq_trans; apply.
    rewrite -addn1 iotaD add0n cats1.
    exact: subseq_rcons.
  + move=> Hsort; have H : sn = n.
      apply anti_leq; rewrite Hsn andbT.
      move: Hsort.
      rewrite -!cats1 -catA => /sorted_catR => /= /andP [].
      by rewrite ltnS.
    subst sn.
    rewrite -addn1 iotaD add0n /= cats1.
    rewrite -subseq_rcons_eq; apply IHn.
    exact: (sorted_rconsK Hsort).
Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2016 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

(** Instances of [Below] for the standard datatypes. To be used by
   [equations] when it needs to do recursion on a type. *)

Require Import Bvector.
Require Import Vectors.Vector.
Require Import Coq.Program.Program.
Require Export Equations.Init Equations.DepElim.

(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype,
   allowing to talk about course-of-value recursion on it. *)

Class BelowPackage (A : Type) := {
  Below : A -> Type ;
  below : forall (a : A), Below a }.

(** The [Recursor] class defines a recursor on a type *)

Class Recursor (A : Type) :=
  { rec_type : forall x : A, Type ; rec : forall x : A, rec_type x }.

(** A hintdb for transparency information of definitions related to [Below] and
   for solving goals related to [Below] instances. *)

Create HintDb Below discriminated.

(** Support simplification of unification constraints appearing in the goal
   and the hypothesis. *)

Hint Extern 0 (_ = _) => reflexivity : Below.
Hint Extern 0 (_ ~= _) => reflexivity : Below.
(* Hint Extern 3 => progress simpl : Below. *)

(** Use it as well as the [equations] simplifications. *)

Ltac unfold_equations ::= repeat progress autounfold with equations Below.
Ltac unfold_equations_in H ::= repeat progress autounfold with equations Below in H.

Ltac destruct_conj :=
  match goal with
    [ H : (_ * _)%type |- _ ] => destruct H
  end.

(** Simplify [Below] hyps for proof search. *)

Hint Extern 2 => progress (autorewrite with Below in * ;
  destruct_conj ; simplify_IH_hyps) : Below.

(** When solving goals with recursive prototypes in them, we allow an application
   only if it keeps the proof guarded (FIXME, guarded doesn't work). *)

Ltac apply_fix_proto :=
  match goal with
    [ f : fix_proto _ |- _ ] => unfold fix_proto in f ; apply f (*  ; guarded  *)
  | [ f : let _ := fixproto in _ |- _ ] => apply f
  end.

Hint Opaque fix_proto : Below.

Hint Extern 100 => apply_fix_proto : Below.

(** We now derive standard Below instances. *)

Derive Below for nat.

Definition rec_nat (P : nat -> Type) n (step : forall n, Below_nat P n -> P n) : P n :=
  step n (below_nat P step n).

Instance nat_Recursor : Recursor nat :=
  { rec_type := fun n => forall P step, P n ;
    rec := fun n P step => rec_nat P n step }.

Notation vector := Vector.t.
Import Vector.
Arguments nil {A}.
Arguments cons {A} _ {n}.

Equations(nocomp noind) Below_vector A (P : forall n, vector A n -> Type) n (v : vector A n) : Type :=
Below_vector A P ?(0) nil := unit ;
Below_vector A P ?(S n) (cons a n v) :=
  ((P n v) * Below_vector A P n v)%type.

Hint Rewrite Below_vector_equation_2 : Below.

(* Equations(nocomp noeqns noind) below_vector A (P : ∀ n, vector A n -> Type) *)
(*   (step : ∀ n (v : vector A n), Below_vector A P n v -> P n v) *)
(*   n (v : vector A n) : Below_vector A P n v := *)
(* below_vector A P _ ?(0) Vnil := tt ; *)
(* below_vector A P step ?(S n) (Vcons a n v) :=  *)
(*   let rest := below_vector A P step n v in *)
(*     (step n v rest, rest). *)

(* Global Opaque Below_vector. *)

(* Definition rec_vector A (P : ∀ n, vector A n -> Type) n v *)
(*   (step : ∀ n (v : vector A n), Below_vector A P n v -> P n v) : P n v := *)
(*   step n v (below_vector A P step n v). *)

(* Instance vect_Recursor A n : Recursor (vector A n) := *)
(*   { rec_type := λ v, ∀ (P : ∀ n, vector A n -> Type) step, P n v; *)
(*     rec := λ v P step, rec_vector A P n v step }. *)

(* Hint Unfold rec_nat rec_vector : Recursors. *)

Hint Extern 4 => progress (unfold hide_pattern in *) : Below.

Ltac add_pattern t :=
  match goal with
    |- ?T => change (add_pattern T t)
  end.

Ltac rec_fast v recname := intro_block v ; move v at top ;
  generalize_by_eqs_vars v ; (intros until v || revert_until v) ;
    let recv := eval simpl in (rec v) in
    (eapply recv || (dependent pattern v ; refine (recv _ _))) ;
    clear_except recname ;
    intros until 1 ; on_last_hyp ltac:(fun x => rename x into recname) ;
      simpl in * ; simplify_dep_elim ; intros ; unblock_goal ; intros ;
        (try move recname at bottom) ;
        add_pattern (hide_pattern recname).

Ltac rec_debug v recname := intro_block v ; move v at top ;
  generalize_by_eqs_vars v ; (intros until v || revert_until v) ;
    let recv := eval simpl in (rec v) in show_goal ;
    (eapply recv || (dependent pattern v ; refine (recv _ _))) ; show_hyps ; idtac "before clear";
    clear_except recname ;
    intros until 1 ; on_last_hyp ltac:(fun x => rename x into recname) ;
    idtac "after clear";
    show_hyps ; show_goal ; simpl in * ; simplify_dep_elim ; intros ; unblock_goal ; intros ;
      add_pattern (hide_pattern recname).

Ltac rec recname v := rec_fast v recname.