Require Import Relations Classical.
From mathcomp Require Import all_ssreflect.
Require Import Util LambdaLet.
Require Heaps.

Inductive red_name : term -> term -> Prop :=
  | red_name_appL t1 t1' t2 :
      red_name t1 t1' ->
      red_name (App t1 t2) (App t1' t2)
  | red_name_beta t11 t2 :
      red_name (App (Abs t11) t2) (subst (scons t2 Var) t11)
  | red_name_let ts t :
      red_name (Let ts t) (subst (scat (map (Let ts) ts) Var) t).

Inductive eval_name : term -> term -> Prop :=
  | eval_name_app t0 t1 t2 v :
      eval_name t1 (Abs t0) ->
      eval_name (subst (scons t2 Var) t0) v ->
      eval_name (App t1 t2) v
  | eval_name_abs t0 :
      eval_name (Abs t0) (Abs t0)
  | eval_name_let ts t v :
      eval_name (subst (scat (map (Let ts) ts) Var) t) v ->
      eval_name (Let ts t) v.

CoInductive diverge_name : term -> Prop :=
  | diverge_name_appL t1 t2 :
      diverge_name t1 ->
      diverge_name (App t1 t2)
  | diverge_name_appabs t0 t1 t2 :
      eval_name t1 (Abs t0) ->
      diverge_name (subst (scons t2 Var) t0) ->
      diverge_name (App t1 t2)
  | diverge_name_let ts t :
      diverge_name (subst (scat (map (Let ts) ts) Var) t) ->
      diverge_name (Let ts t).

Hint Constructors eval_name diverge_name red_name.

Inductive corr_term (P : nat -> Prop) :
      seq (option term) -> (nat -> term) -> term -> term -> Prop :=
  | corr_term_indir H mu l t t' :
      nth None H l = Some t ->
      corr_term P H mu t t' ->
      corr_term P H mu (Loc l) t'
  | corr_term_loc H mu l t' :
      P l ->
      mu l = t' ->
      corr_term P H mu (Loc l) t'
  | corr_term_var H mu x :
      corr_term P H mu (Var x) (Var x)
  | corr_term_abs H mu t t' :
      corr_term P (map (omap (rename succn)) H) (rename succn \o mu) t t' ->
      corr_term P H mu (Abs t) (Abs t')
  | corr_term_app H mu t1 t1' t2 t2' :
      corr_term P H mu t1 t1' ->
      corr_term P H mu t2 t2' ->
      corr_term P H mu (App t1 t2) (App t1' t2')
  | corr_term_let H mu ts ts' t t' :
      size ts = size ts' ->
      ( forall x, x < size ts -> forall d,
        corr_term P
          (map (omap (rename (addn (size ts)))) H)
          (rename (addn (size ts)) \o mu)
          (nth d ts x) (nth d ts' x) ) ->
      corr_term P
        (map (omap (rename (addn (size ts)))) H)
        (rename (addn (size ts)) \o mu) t t' ->
      corr_term P H mu (Let ts t) (Let ts' t').

Hint Constructors corr_term.

Definition corr_heap_segment (P P' : nat -> Prop) H mu :=
  forall l, P l ->
  exists t, nth None H l = Some t /\
  exists ts' t', mu l = Let ts' t' /\
  corr_term P' H mu t (subst (scat (map (Let ts') ts') Var) t').
Definition corr_heap P := corr_heap_segment P P.

Lemma eq_omap A B (f g : A -> B) : forall o,
  (forall x, f x = g x) ->
  omap f o = omap g o.
Proof. by move => [ ? /= -> | ]. Qed.

Lemma omap_id A : forall (o : option A), omap id o = o.
Proof. by move => [ ]. Qed.

Lemma omap_comp A B C (f : B -> C) (g : A -> B) : forall o,
  omap f (omap g o) = omap (f \o g) o.
Proof. by move => [ ]. Qed.

Lemma nth_map_heap A B H l (f : A -> B) :
  nth None (map (omap f) H) l = omap f (nth None H l).
Proof.
  case (leqP (size H) l) => ?.
  - by rewrite !nth_default ?size_map.
  - exact: nth_map.
Qed.

Lemma neutral_dec t :
  { t0 | t = Abs t0 } + { forall t0, t = Abs t0 -> False }.
Proof. by destruct t; eauto; right. Qed.

Lemma value_normal t :
  value t -> forall t', red_name t t' -> False.
Proof. by inversion 1; inversion 1. Qed.

Lemma eval_name_value t v :
  eval_name t v ->
  value v.
Proof. induction 1; eauto. Qed.

Lemma red_name_det t t' :
  red_name t t' ->
  forall t'',
  red_name t t'' ->
  t' = t''.
Proof.
  induction 1; inversion 1; subst;
    try match goal with
    | H : red_name (Abs _) _ |- _ => inversion H
    end; f_equal; eauto.
Qed.

Lemma red_name_appL_multi t1 t1' t2 :
  clos_refl_trans _ red_name t1 t1' ->
  clos_refl_trans _ red_name (App t1 t2) (App t1' t2).
Proof. induction 1; eauto. Qed.

Theorem eval_name_red_name_multi t v :
  eval_name t v ->
  clos_refl_trans _ red_name t v.
Proof.
  induction 1 => //.
  - apply: rt_trans.
    + apply: red_name_appL_multi.
      exact: IHeval_name1.
    + eauto.
  - apply: rt_trans.
    + exact: rt_step.
    + eauto.
Qed.

Lemma red_name_eval_name t t' :
  red_name t t' ->
  forall v,
  eval_name t' v ->
  eval_name t v.
Proof.
  induction 1; eauto.
  inversion 1. subst. eauto.
Qed.

Lemma red_name_multi_eval_name t v :
  clos_refl_trans _ red_name t v ->
  value v ->
  eval_name t v.
Proof.
  move => /clos_rt_rt1n_iff.
  induction 1; inversion 1; subst; eauto.
  apply: red_name_eval_name; eauto.
Qed.

Lemma diverge_reducible t :
  diverge_name t ->
  exists t', red_name t t' /\ diverge_name t'.
Proof.
  induction t; inversion 1; subst; eauto.
  - case (IHt1 H1) => ? [ ]. eauto.
  - move: (eval_name_red_name_multi _ _ H2) => /clos_rt_rt1n_iff.
    inversion 1; subst; eauto.
    move: H1 => /clos_rt_rt1n_iff /red_name_multi_eval_name. eauto 6.
Qed.

Theorem diverge_name_red_name t t' :
  clos_refl_trans _ red_name t t' ->
  diverge_name t ->
  exists t'', red_name t' t''.
Proof.
  move => /clos_rt_rt1n_iff.
  induction 1.
  - move => /diverge_reducible [ ? [ ] ]. eauto.
  - by move => /diverge_reducible [ ? [ ] ] /(red_name_det _ _ H) <-.
Qed.

Theorem red_name_multi_diverge_name :
  forall t,
  ( forall t', clos_refl_trans _ red_name t t' ->
    exists t'', red_name t' t'' ) ->
  diverge_name t.
Proof.
  cofix red_name_multi_diverge_name.
  move => [ ? | ? | ? | t1 ? | ? ? ] Hdiv.
  - move: (Hdiv _ (rt_refl _ _ _)) => [ ]. inversion 1.
  - move: (Hdiv _ (rt_refl _ _ _)) => [ ]. inversion 1.
  - move: (Hdiv _ (rt_refl _ _ _)) => [ ]. inversion 1.
  - case (classic (exists t1',
      clos_refl_trans _ red_name t1 t1' /\
      forall t1'', red_name t1' t1'' -> False)) =>
    [ [ ? [ Hrt Hnf ] ] | Hdiv1 ].
    { move: (Hdiv _ (red_name_appL_multi _ _ _ Hrt)) => [ ]; inversion 1; subst.
      - by move: (Hnf _ H2).
      - apply: diverge_name_appabs.
        + apply: red_name_multi_eval_name; eauto.
        + apply: red_name_multi_diverge_name => ? ?.
          apply: Hdiv.
          apply: rt_trans.
          * apply: red_name_appL_multi. eauto.
          * eauto. }
    { apply: diverge_name_appL.
      apply: red_name_multi_diverge_name => t1' Hrt.
      case: (Hdiv _ (red_name_appL_multi _ _ _ Hrt)); inversion 1; subst; eauto.
      case Hdiv1. repeat (eexists; eauto). inversion 1. }
  - apply: diverge_name_let.
    apply: red_name_multi_diverge_name => ? ?.
    apply: Hdiv. eauto.
Qed.

Lemma corr_term_impl P H mu t t' :
  corr_term P H mu t t' ->
  forall (P' : nat -> Prop) H' mu',
  ( forall l, P l -> P' l ) ->
  ( forall l,
    nth None H l = None \/
    nth None H l = nth None H' l ) ->
  ( forall l, P l -> mu l = mu' l ) ->
  corr_term P' H' mu' t t'.
Proof.
  induction 1 => ? H' ? HP HQ HPmu; eauto.
  - apply: corr_term_indir; eauto.
    by move: H0 (HQ l) => -> [ ].
  - apply: corr_term_loc; eauto.
    erewrite <- HPmu; eauto.
  - constructor.
    ( apply: IHcorr_term; eauto ) => l.
    + rewrite !nth_map_heap.
      case (HQ l) => ->; eauto.
    + by move => /HPmu /= ->.
  - constructor; eauto.
    + move => ? ? ?.
      ( apply: H2; eauto ) => l.
      * rewrite !nth_map_heap.
        case (HQ l) => ->; eauto.
      * by move => /HPmu /= ->.
    + ( apply: IHcorr_term; eauto ) => l.
      * rewrite !nth_map_heap.
        case (HQ l) => ->; eauto.
      * by move => /HPmu /= ->.
Qed.

Corollary corr_term_ext P H mu t t' :
  corr_term P H mu t t' ->
  forall H',
  ( forall l t,
    nth None H l = Some t ->
    nth None H' l = Some t ) ->
  corr_term P H' mu t t'.
Proof.
  move => /corr_term_impl Hterm ? Hext.
  apply: Hterm => // l.
  move: (nth None H l) (Hext l) => [ ? /(_ _ erefl) | ]; eauto.
Qed.

Corollary corr_term_cat P H Hd mu t t' :
  corr_term P H mu t t' ->
  corr_term P (H ++ Hd) mu t t'.
Proof.
  move => /corr_term_ext.
  apply => l.
  by move: nth_cat (leqP (size H) l) => -> [ /(nth_default _) -> | ].
Qed.

Corollary corr_term_rcons P H o mu t t' :
  corr_term P H mu t t' ->
  corr_term P (rcons H o) mu t t'.
Proof. by rewrite -cats1 => /corr_term_cat. Qed.

Lemma corr_term_rename P H mu t t' :
  corr_term P H mu t t' ->
  forall H' mu' r,
  (forall l, mu' l = rename r (mu l)) ->
  (forall l, nth None H' l = omap (rename r) (nth None H l)) ->
  corr_term P H' mu' (rename r t) (rename r t').
Proof.
  induction 1 => H' ? ? Hmu Hnth /=; eauto.
  - apply: corr_term_indir; eauto.
    by rewrite Hnth H0.
  - apply: corr_term_loc; eauto.
    by rewrite Hmu H1.
  - constructor.
    apply: IHcorr_term => ?.
    + rewrite /funcomp Hmu !rename_rename_comp.
      exact: eq_rename.
    + rewrite !nth_map_heap Hnth !omap_comp.
      apply: eq_omap => ?.
      rewrite /funcomp !rename_rename_comp.
      exact: eq_rename.
  - constructor; rewrite !size_map -?H0; eauto.
    + move => ? ? d.
      rewrite !(nth_map d) -?H0 => //.
      apply: H2 => // ?.
      * rewrite /funcomp Hmu !rename_rename_comp.
        apply: eq_rename => ? /=.
        by rewrite upnren_unfold ltnNge leq_addr addKn.
      * rewrite !nth_map_heap Hnth !omap_comp.
        apply: eq_omap => ?.
        rewrite /funcomp !rename_rename_comp.
        apply: eq_rename => x /=.
        by rewrite upnren_unfold ltnNge leq_addr addKn.
    + apply: IHcorr_term => ?.
      * rewrite /funcomp Hmu !rename_rename_comp.
        apply: eq_rename => ? /=.
        by rewrite upnren_unfold ltnNge leq_addr addKn.
      * rewrite !nth_map_heap Hnth !omap_comp.
        apply: eq_omap => ?.
        rewrite /funcomp !rename_rename_comp.
        apply: eq_rename => ? /=.
        by rewrite upnren_unfold ltnNge leq_addr addKn.
Qed.

Lemma corr_term_subst P H mu t t' :
  corr_term P H mu t t' ->
  forall H' mu' s s',
  (forall x, corr_term P H' mu' (s x) (s' x)) ->
  (forall l, nth None H' l = omap (subst s) (nth None H l)) ->
  (forall l, mu' l = subst s' (mu l)) ->
  corr_term P H' mu' (subst s t) (subst s' t').
Proof.
  induction 1 => ? ? ? ? Hs Hnth Hmu /=; eauto.
  - apply: corr_term_indir; eauto.
    by rewrite Hnth H0.
  - apply: corr_term_loc; eauto.
    by rewrite Hmu H1.
  - constructor.
    apply: IHcorr_term => [ [ | ? ] //= | ? | ? ].
    + ( apply: corr_term_rename; eauto ) => ?.
      by rewrite nth_map_heap.
    + rewrite !nth_map_heap Hnth !omap_comp.
      apply: eq_omap => ?.
      rewrite /funcomp rename_subst_comp subst_rename_comp.
      exact: eq_subst.
    + rewrite /funcomp Hmu rename_subst_comp subst_rename_comp.
      exact: eq_subst.
  - constructor; rewrite !size_map -?H0; eauto.
    + move => ? ? d.
      rewrite !(nth_map d) -?H0 => //.
      apply: H2 => // x.
      * rewrite !upn_unfold.
        case (leqP (size ts) x) => ? //.
        ( apply: corr_term_rename; eauto ) => ?.
        by rewrite nth_map_heap.
      * rewrite !nth_map_heap Hnth !omap_comp.
        apply: eq_omap => ?.
        rewrite /funcomp rename_subst_comp subst_rename_comp.
        apply: eq_subst => ?.
        by rewrite /funcomp upn_unfold ltnNge leq_addr addKn.
      * rewrite /funcomp Hmu rename_subst_comp subst_rename_comp.
        apply: eq_subst => ?.
        by rewrite /funcomp upn_unfold ltnNge leq_addr addKn.
    + apply IHcorr_term => x.
      * rewrite !upn_unfold.
        case (leqP (size ts) x) => ? //.
        ( apply: corr_term_rename; eauto ) => ?.
        by rewrite nth_map_heap.
      * rewrite !nth_map_heap Hnth !omap_comp.
        apply: eq_omap => ?.
        rewrite /funcomp rename_subst_comp subst_rename_comp.
        apply: eq_subst => ?.
        by rewrite /funcomp upn_unfold ltnNge leq_addr addKn.
      * rewrite /funcomp Hmu rename_subst_comp subst_rename_comp.
        apply: eq_subst => ?.
        by rewrite /funcomp upn_unfold ltnNge leq_addr addKn.
Qed.

Lemma corr_heap_segment_impl P P' H mu :
  corr_heap_segment P P' H mu ->
  forall (Q Q' : nat -> Prop) H',
  ( forall l, Q l -> P l ) ->
  ( forall l, P' l -> Q' l ) ->
  ( forall l t, nth None H l = Some t -> nth None H' l = Some t ) ->
  corr_heap_segment Q Q' H' mu.
Proof.
  move => Hheap ? ? ? Hdom Hcod Hnth ? /Hdom /Hheap
    [ ? [ /Hnth -> [ ? [ ? [ -> ? ] ] ] ] ].
  repeat (eexists; eauto).
  ( apply: corr_term_impl; eauto ) => l.
  move: (nth None H l) (Hnth l) => [ ? /(_ _ erefl) | ]; eauto.
Qed.

Lemma corr_heap_ext P H mu :
  corr_heap P H mu ->
  forall mu',
  ( forall l, P l -> mu l = mu' l ) ->
  corr_heap P H mu'.
Proof.
  move => Hheap ? HPmu ? HP.
  move: (HPmu _ HP) (Hheap _ HP) => ->
    [ ? [ -> [ ? [ ? [ -> ? ] ] ] ] ].
  repeat (eexists; eauto).
  apply: corr_term_impl; eauto.
Qed.

Corollary corr_heap_segment_cat P P' H Hd mu :
  corr_heap_segment P P' H mu ->
  corr_heap_segment P P' (H ++ Hd) mu.
Proof.
  move => /corr_heap_segment_impl.
  apply => l //.
  by move: nth_cat (leqP (size H) l) =>
    -> [ /(nth_default _) -> | ].
Qed.

Corollary corr_heap_segment_rcons P P' H o mu :
  corr_heap_segment P P' H mu ->
  corr_heap_segment P P' (rcons H o) mu.
Proof. by rewrite -cats1 => /corr_heap_segment_cat. Qed.

Lemma corr_heap_segment_union P P' Q H mu :
  corr_heap_segment P Q H mu ->
  corr_heap_segment P' Q H mu ->
  corr_heap_segment (fun l => P l \/ P' l) Q H mu.
Proof.
  move => Hheap Hheap' ? [ /Hheap | /Hheap' ]
    [ ? [ -> [ ? [ ? [ -> ? ] ] ] ] ];
  repeat (eexists; eauto).
Qed.

Lemma corr_heap_segment_bound P P' H mu :
  corr_heap_segment P P' H mu ->
  forall l, P l ->
  l < size H.
Proof.
  move => Hheap l /Hheap [ ? [ ] ].
  by case (leqP (size H) l) => [ /(nth_default _) -> | ].
Qed.

Lemma unwind_indirection P H mu t1 t2 :
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  exists t1',
  clos_refl_trans _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) (H, t1) (H, t1') /\
  ( corr_term P H mu t1' t2 /\
    (forall H' t1'', Heaps.red_name H t1' H' t1'' -> False) /\
    (forall t2', red_name t2 t2' -> False) \/
    exists t2', red_name t2 t2' /\
    exists H' t1'', Heaps.red_name H t1' H' t1'' /\
    exists P' mu',
    corr_heap P' H' mu' /\
    corr_term P' H' mu' t1'' t2' /\
    (forall l, P l -> P' l) /\
    (forall l, P l -> mu l = mu' l) ).
Proof.
  induction 1 => Hheap.
  - move: (IHcorr_term Hheap) => [ ? [ ? ? ] ].
    do 2 eexists.
    + refine (rt_trans _ _ _ (_, _) _ (rt_step _ _ _ _ _) _) => /=; eauto.
    + assumption.
  - subst.
    move: (Hheap _ H0) => [ ? [ ? [ ? [ ? [ Hmu ? ] ] ] ] ].
    rewrite Hmu.
    repeat (eexists; eauto). right.
    repeat (eexists; eauto).
  - repeat (eexists; eauto). left.
    split; eauto. split; inversion 1.
  - repeat (eexists; eauto). left.
    split; eauto. split; inversion 1.
  - move: (IHcorr_term1 Hheap) =>
      [ t11 [ ? [ [ ] | [ ? [ ? [ ? [ ? [ Hred [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ] ] ] ] ] ] ] ].
    + case (neutral_dec t11) => [ [ t0 ? ] | Hneutral ]; subst.
      { inversion 1. subst => ?.
        do 2 eexists.
        - apply: Heaps.red_name_appL_multi. eassumption.
        - have Hterm' : corr_term P
            (rcons H (Some t2)) mu
            (subst (scons (Loc (size H)) Var) t0)
            (subst (scons t2' Var) t').
          { apply: corr_term_subst.
            - ( eapply (corr_term_impl _ _ _ _ _ H4 _
                (map (omap (rename succn)) (rcons H (Some t2)))); eauto ) => l.
              rewrite !nth_map_heap nth_rcons.
              case (leqP (size H) l) => [ /(nth_default _) -> | ]; eauto.
            - move => [ | ? ] //=.
              apply: corr_term_indir => /=.
              + by rewrite nth_rcons ltnn eqxx.
              + exact: corr_term_rcons.
            - move => ?.
              rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
              by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id.
            - move => ?.
              by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id. }
          have Hheap' : corr_heap P (rcons H (Some t2)) mu.
          { exact: corr_heap_segment_rcons. }
          right. repeat (eexists; eauto). }
      { move => Hterm [ Hnf1 Hnf2 ].
        do 2 eexists.
        - apply: Heaps.red_name_appL_multi. eassumption.
        - left. repeat split; eauto.
          + inversion 1; subst; eauto.
          + inversion 1; subst; eauto.
            inversion Hterm; subst; eauto.
            move: (Hheap _ H2) => [ ? [ ] ]. eauto. }
    + do 2 eexists.
      * apply: Heaps.red_name_appL_multi. eassumption.
      * right. repeat (econstructor; eauto).
        refine (corr_term_ext _ _ _ _ _ _ _
          (Heaps.red_name_heap _ _ _ _ _)); eauto.
        apply: corr_term_impl; eauto.
  - repeat (eexists; eauto).
    have Hterm' : corr_term
      (fun l => P l \/ size H <= l /\ l - size H < size ts)
      (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts)
      (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H))
      (subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var) t)
      (subst (scat (map (Let ts') ts') Var) t').
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H3 _
            (map (omap (rename (addn (size ts))))
              (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts))
            (rename (addn (size ts)) \o
              (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H)))); eauto ) => l.
        + rewrite !nth_map_heap nth_cat.
          case (leqP (size H) l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /(corr_heap_segment_bound _ _ _ _ Hheap) /= ->.
      - move => x.
        rewrite !nth_scat size_mkseq size_map -H0.
        case (leqP (size ts) x) => ?.
        + rewrite !nth_default ?size_mkseq ?size_map -?H0; eauto.
        + rewrite nth_mkseq => //=.
          apply: corr_term_loc.
          * rewrite leq_addr addKn. eauto.
          * rewrite ltnNge leq_addr addKn.
            apply: set_nth_default.
            by rewrite size_map -H0.
      - move => l.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => // ? /=.
        by rewrite nth_scat nth_default size_mkseq ?addKn ?leq_addr.
      - move => ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
        by rewrite nth_scat nth_default size_map -H0 ?addKn ?leq_addr. }
    have Hheap' : corr_heap
      (fun l => P l \/ size H <= l /\ l - size H < size ts)
      (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts)
      (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H)).
    { apply: corr_heap_segment_union.
      - apply: corr_heap_segment_cat.
        refine (corr_heap_segment_impl _ _ _ _
          (corr_heap_ext _ _ _ Hheap _ _) _ _ _ _ _ _); eauto.
        by move => ? /(corr_heap_segment_bound _ _ _ _ Hheap) ->.
      - move => ? [ Hge Hlt ].
        rewrite nth_cat ltnNge Hge (nth_map (Var 0)) => //=.
        repeat (eexists; eauto).
        + apply: (nth_map (Var 0)). by rewrite -H0.
        + apply: corr_term_subst.
          { ( refine (corr_term_impl _ _ _ _ _ (H1 _ _ _) _
              (map (omap (rename (addn (size ts))))
                (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts))
              (rename (addn (size ts)) \o
                (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H))) _ _ _); eauto ) => l.
            - rewrite !nth_map_heap nth_cat.
              case (leqP (size H) l) => [ /(nth_default _) -> | ]; eauto.
            - by move => /(corr_heap_segment_bound _ _ _ _ Hheap) /= ->. }
          { move => x.
            case (leqP (size ts) x) => ?.
            - by rewrite !nth_scat !nth_default ?size_mkseq ?size_map -?H0.
            - rewrite !nth_scat nth_mkseq ?(nth_map (Var 0)) -?H0 => //.
              apply: corr_term_loc.
              + rewrite leq_addr addKn. eauto.
              + by rewrite ltnNge leq_addr (nth_map (Var 0)) addKn -?H0. }
          { move => ?.
            rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_mkseq ?leq_addr ?addKn. }
          { move => ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_map -H0 ?leq_addr ?addKn. } }
    right. repeat (eexists; eauto).
    by move => ? /(corr_heap_segment_bound _ _ _ _ Hheap) ->.
Qed.

Lemma eval_name_sound_aux p p' :
  clos_refl_trans_1n _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) p p' ->
  forall H H'' t1 v1,
  p = (H, t1) ->
  p' = (H'', v1) ->
  value v1 ->
  forall P H' t1' mu t2,
  corr_term P H' mu t1' t2 ->
  corr_heap P H' mu ->
  clos_refl_trans_1n _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) (H, t1) (H', t1') ->
  exists v2,
  clos_refl_trans _ red_name t2 v2 /\
  value v2 /\
  exists P' mu',
  corr_heap P' H'' mu' /\
  corr_term P' H'' mu' v1 v2.
Proof.
  induction 1; inversion 1; inversion 1; inversion 4; subst.
  - inversion H3; subst; inversion H6; subst.
    repeat (eexists; eauto).
  - by move: (Heaps.value_normal _ H3 _ _ _ H9).
  - move: (unwind_indirection _ _ _ _ _ H7 H8) => [ ? [ /clos_rt_rt1n_iff ] ];
    inversion 1; subst => [ [ [ Hterm' [ Hnf ? ] ] | [ ? [ ? [ ? [ ? [ ] ] ] ] ] ] ].
    + by move: (Hnf _ _ H).
    + destruct y => /(Heaps.red_name_det _ _ _ _ H) /= [ ? ? ] [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ]. subst.
      move: (IHclos_refl_trans_1n _ _ _ _ erefl erefl H6 _ _ _ _ _ Hterm' Hheap' (rt1n_refl _ _ _)) =>
        [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ].
      do 2 eexists.
      * refine (rt_trans _ _ _ _ _ (rt_step _ _ _ _ _) _); eassumption.
      * repeat (eexists; eauto).
    + destruct y, y0.
      case: (Heaps.red_name_det _ _ _ _ H _ _ H1) => /= ? ?. subst.
      apply: IHclos_refl_trans_1n; eauto.
    + destruct y, y0 => [ ? [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ] ].
      case: (Heaps.red_name_det _ _ _ _ H _ _ H1) => /= ? ?. subst.
      move: (IHclos_refl_trans_1n _ _ _ _ erefl erefl H6 _ _ _ _ _ Hterm' Hheap') =>
        [ | ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ].
      { apply /clos_rt_rt1n_iff.
        refine (rt_trans _ _ _ (_, _) _ _ (rt_step _ _ _ _ _)) => /=.
        - apply /clos_rt_rt1n_iff. eassumption.
        - eauto. }
      do 2 eexists.
      { apply: rt_trans.
        - apply: rt_step. eassumption.
        - eassumption. }
      repeat (eexists; eauto).
  - destruct y, y0.
    case: (Heaps.red_name_det _ _ _ _ H _ _ H10) => /= ? ?. subst.
    apply: IHclos_refl_trans_1n; eauto.
Qed.

Corollary eval_name_sound H H' t1 v1 :
  Heaps.eval_name H t1 H' v1 ->
  forall P mu t2,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  exists v2, eval_name t2 v2 /\
  exists P' mu',
  corr_heap P' H' mu' /\
  corr_term P' H' mu' v1 v2.
Proof.
  move => Heval ? ? ? Hterm Hheap.
  move: (Heaps.eval_name_red_name_multi _ _ _ _ Heval) =>
    /clos_rt_rt1n_iff /eval_name_sound_aux
    /(_ _ _ _ _ erefl erefl
        (Heaps.eval_name_value _ _ _ _ Heval) _ _ _ _ _ Hterm Hheap (rt1n_refl _ _ _))
  [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ].
  repeat (eexists; eauto).
  exact: red_name_multi_eval_name.
Qed.

Lemma diverge_name_sound_aux t2 t2' :
  clos_refl_trans_1n _ red_name t2 t2' ->
  forall H t1,
  ( forall H' t1',
    clos_refl_trans _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) (H, t1) (H', t1') ->
    exists H'' t1'', Heaps.red_name H' t1' H'' t1'' ) ->
  forall P mu,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  exists t2'', red_name t2' t2''.
Proof.
  induction 1 => ? ? Hdiv ? ? Hterm Hheap.
  - move: (unwind_indirection _ _ _ _ _ Hterm Hheap) =>
      [ ? [ Hrt [ [ ? [ Hnf ? ] ] | [ ? [ ] ] ] ] ]; eauto.
    by move: (Hdiv _ _ Hrt) => [ ? [ ? /Hnf ] ].
  - move: (unwind_indirection _ _ _ _ _ Hterm Hheap) =>
      [ ? [ Hrt [ [ ? [ ? Hnf ] ] |
                  [ ? [ /(red_name_det _ _ H) <-
                         [ ? [ ? [ ? [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ] ] ] ] ] ] ] ] ].
    + edestruct Hnf. eauto.
    + refine (IHclos_refl_trans_1n _ _ _ _ _ Hterm' Hheap') => ? ? ?.
      apply: Hdiv.
      refine (rt_trans _ _ _ (_, _) _ _ (rt_trans _ _ _ (_, _) _ (rt_step _ _ _ _ _) _)) => /=; eauto.
Qed.

Corollary diverge_name_sound H t1 :
  Heaps.diverge_name H t1 ->
  forall P mu t2,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  diverge_name t2.
Proof.
  move => /Heaps.diverge_name_red_name ? ? ? ? ? ?.
  apply: red_name_multi_diverge_name => ? ?.
  apply: diverge_name_sound_aux; eauto.
  by apply /clos_rt_rt1n_iff.
Qed.

Lemma eval_name_complete_aux t2 v2 :
  clos_refl_trans_1n _ red_name t2 v2 ->
  value v2 ->
  forall P mu H t1,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  exists H' v1,
  clos_refl_trans _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) (H, t1) (H', v1) /\
  value v1 /\
  exists P' mu',
  corr_heap P' H' mu' /\
  corr_term P' H' mu' v1 v2.
Proof.
  induction 1 => Hv ? ? ? ? Hterm Hheap.
  - move: (unwind_indirection _ _ _ _ _ Hterm Hheap) =>
      [ ? [ ? [ [ Hterm' [ Hnf ? ] ] | [ ? [ /(value_normal _ Hv) ] ] // ] ] ].
    repeat (eexists; eauto).
    inversion Hv; subst; inversion Hterm'; subst; eauto.
    + edestruct Hnf. eauto.
    + move: (Hheap _ H0) => [ ? [ ? ] ].
      edestruct Hnf. eauto.
  - move: (unwind_indirection _ _ _ _ _ Hterm Hheap) =>
    [ ? [ ? [ [ ? [ ? Hnf ] ] |
              [ ? [ /(red_name_det _ _ H) <-
                     [ ? [ ? [ ? [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ] ] ] ] ] ] ] ] ].
    + edestruct Hnf. eauto.
    + move: (IHclos_refl_trans_1n Hv _ _ _ _ Hterm' Hheap') =>
        [ ? [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ] ].
      do 3 eexists.
      { refine (rt_trans _ _ _ (_, _) _ _ _).
        - eassumption.
        - refine (rt_trans _ _ _ (_, _) _ (rt_step _ _ _ _ _) _) => /=; eauto. }
      repeat (eexists; eauto).
Qed.

Corollary eval_name_complete t2 v2 :
  eval_name t2 v2 ->
  forall P mu H t1,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  exists H' v1,
  Heaps.eval_name H t1 H' v1 /\
  exists P' mu',
  corr_heap P' H' mu' /\
  corr_term P' H' mu' v1 v2.
Proof.
  move => Heval.
  move: (eval_name_red_name_multi _ _ Heval) => /clos_rt_rt1n_iff Hrt ? ? ? ? Hterm Hheap.
  have Hv := eval_name_value _ _ Heval.
  move: (eval_name_complete_aux _ _ Hrt Hv _ _ _ _ Hterm Hheap) =>
    [ ? [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ] ].
  repeat (eexists; eauto).
  exact: Heaps.red_name_multi_eval_name.
Qed.

Lemma diverge_name_complete_aux p p' :
  clos_refl_trans_1n _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) p p' ->
  forall H H'' t1 t1'',
  p = (H, t1) ->
  p' = (H'', t1'') ->
  forall P H' mu t1' t2,
  corr_term P H' mu t1' t2 ->
  corr_heap P H' mu ->
  clos_refl_trans_1n _ (fun p p' => Heaps.red_name p.1 p.2 p'.1 p'.2) (H, t1) (H', t1') ->
  ( forall t2',
    clos_refl_trans _ red_name t2 t2' ->
    exists t2'', red_name t2' t2'' ) ->
  exists H''' t1''', Heaps.red_name H'' t1'' H''' t1'''.
Proof.
  induction 1; inversion 1; inversion 1;
  inversion 3; subst => [ Hdiv ]; eauto.
  - move: (unwind_indirection _ _ _ _ _ H3 H6) => [ ? [ /clos_rt_rt1n_iff ] ]; inversion 1; subst; eauto.
    move => [ [ ? [ ? Hnf ] ] | [ ? [ ? [ ? [ ? [ ] ] ] ] ] ]; eauto.
    by case: (Hdiv _ (rt_refl _ _ _)) => ? /Hnf.
  - move: (unwind_indirection _ _ _ _ _ H6 H7) => [ ? [ /clos_rt_rt1n_iff ] ];
    inversion 1; subst => [ [ [ Hterm' [ Hnf ? ] ] | [ ? [ ? [ ? [ ? [ ] ] ] ] ] ] ].
    + case: (Hnf _ _ H).
    + destruct y => /(Heaps.red_name_det _ _ _ _ H) /= [ ? ? ].
      subst => [ [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ] ].
      apply: (IHclos_refl_trans_1n _ _ _ _ erefl erefl _ _ _ _ _ Hterm' Hheap' (rt1n_refl _ _ _)); eauto.
    + destruct y, y0.
      case (Heaps.red_name_det _ _ _ _ H _ _ H1) => /= ? ?. subst.
      apply: (IHclos_refl_trans_1n _ _ _ _ erefl erefl _ _ _ _ _ Hterm' H7); eauto.
    + destruct y, y0 => ? [ ? [ ? [ Hheap' [ Hterm' [ ? ? ] ] ] ] ].
      case (Heaps.red_name_det _ _ _ _ H _ _ H1) => /= ? ?. subst.
      apply: (IHclos_refl_trans_1n _ _ _ _ erefl erefl _ _ _ _ _ Hterm' Hheap'); eauto.
      { apply /clos_rt_rt1n_iff.
        refine (rt_trans _ _ _ (_, _) _ _ (rt_step _ _ _ _ _)) => /=.
        - apply /clos_rt_rt1n_iff. eassumption.
        - eauto. }
  - destruct y, y0.
    case: (Heaps.red_name_det _ _ _ _ H _ _ H9) => /= ? ?. subst.
    apply: IHclos_refl_trans_1n; eauto.
Qed.

Corollary diverge_name_complete t2 :
  diverge_name t2 ->
  forall P mu H t1,
  corr_term P H mu t1 t2 ->
  corr_heap P H mu ->
  Heaps.diverge_name H t1.
Proof.
  move => /diverge_name_red_name Hdiv ? ? ? ? Hterm Hheap.
  apply: Heaps.red_name_multi_diverge_name =>
    ? ? /clos_rt_rt1n_iff /diverge_name_complete_aux.
  apply; eauto using rt1n_refl.
Qed.

Theorem eval_name_sound' H1 H1' t1 v1 :
  Heaps.eval_name H1 t1 H1' v1 ->
  forall P mu t2,
  corr_heap P H1 mu ->
  corr_term P H1 mu t1 t2 ->
  exists v2,
  eval_name t2 v2 /\
  exists P' mu',
  corr_heap P' H1' mu' /\
  corr_term P' H1' mu' v1 v2 /\
  ( forall l, P l -> P' l ) /\
  ( forall l, P l -> mu l = mu' l ) /\
  ( forall l t, nth None H1 l = Some t -> mu l = mu' l ).
Proof.
  induction 1; inversion 2; subst.
  - move: (H0) H6 => ->. inversion 1. subst.
    exact: IHeval_name.
  - move: (H0) (H2 _ H6) => -> [ ? [ ] ].
    inversion 1. subst => [ [ ? [ ? [ -> ] ] ]
      /(IHeval_name _ _ _ H2) [ ? [ ? ? ] ] ].
    repeat (eexists; eauto).
  - move: (IHeval_name1 _ _ _ H2 H9) =>
      [ ? [ ? [ P' [ mu' [ Hheap [ ] ] ] ] ] ].
    inversion 1. subst => [ [ HP' [ ? HQmu' ] ] ].
    have Hterm' : corr_term P'
      (rcons H' (Some t2))
      [eta mu' with size H' |-> t2']
      (subst (scons (Loc (size H')) Var) t0)
      (subst (scons t2' Var) t').
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H8 _
            (map (omap (rename succn)) (rcons H' (Some t2)))
            (rename succn \o [eta mu' with size H' |-> t2'])); eauto ) => l.
        + rewrite !nth_map_heap nth_rcons.
          case (leqP (size H') l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /= /(corr_heap_segment_bound _ _ _ _ Hheap) /ltn_eqF ->.
      - move => [ | ? ] //=.
        apply: corr_term_indir => /=.
        + by rewrite nth_rcons ltnn eqxx.
        + ( apply: corr_term_impl; eauto ) => l /=.
          * move: nth_rcons  (nth None H l)
              (Heaps.eval_name_heap _ _ _ _ H0 l) =>
              -> [ ? /(_ _ erefl) | ]; eauto.
            case (leqP (size H') l) => [ /(nth_default _) -> | ? -> ]; eauto.
          * move => HP.
            rewrite (ltn_eqF
              (corr_heap_segment_bound _ _ _ _ Hheap _ (HP' _ HP))). eauto.
      - move => ?.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id.
      - move => ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id. }
    have Hheap' : corr_heap P'
      (rcons H' (Some t2))
      [eta mu' with size H' |-> t2'].
    { refine (corr_heap_segment_impl _ _ _ _
        (corr_heap_ext _ _ _ Hheap _ _) _ _ _ _ _ _); eauto.
      - by move => ? /(corr_heap_segment_bound _ _ _ _ Hheap) /ltn_eqF /= ->.
      - move => l.
        by move: nth_rcons (leqP (size H') l) => -> [ /(nth_default _) -> | ]. }
    move: (IHeval_name2 _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ HPmu'' HQmu'' ] ] ] ] ] ] ] ].
    repeat (eexists; eauto).
    + move => ? HP.
      rewrite -HPmu'' => /=; eauto.
      rewrite (ltn_eqF (corr_heap_segment_bound _ _ _ _ Hheap _ (HP' _ HP))). eauto.
    + move => l t HQ.
      move: nth_rcons (leqP (size H') l)
        (Heaps.eval_name_heap _ _ _ _ H0 _ _ HQ) (HQmu'' l t) =>
        -> [ /(nth_default _) -> // | Hlt ? <- //= ].
      rewrite (ltn_eqF Hlt). eauto.
  - repeat (eexists; eauto).
  - have Hterm' : corr_term
      (fun l => P l \/ size H <= l /\ l - size H < size ts)
      (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts)
      (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H))
      (subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var) t)
      (subst (scat (map (Let ts') ts') Var) t').
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H11 _
            (map (omap (rename (addn (size ts))))
              (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts))
            (rename (addn (size ts)) \o
              (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H)))); eauto ) => l.
        + rewrite !nth_map_heap nth_cat.
          case (leqP (size H) l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /(corr_heap_segment_bound _ _ _ _ H1) /= ->.
      - move => x.
        rewrite !nth_scat size_mkseq size_map -H6.
        case (leqP (size ts) x) => ?.
        + rewrite !nth_default ?size_mkseq ?size_map -?H6; eauto.
        + rewrite nth_mkseq => //=.
          apply: corr_term_loc.
          * rewrite leq_addr addKn. eauto.
          * rewrite ltnNge leq_addr addKn.
            apply: set_nth_default.
            by rewrite size_map -H6.
      - move => l.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => // ? /=.
        by rewrite nth_scat nth_default size_mkseq ?addKn ?leq_addr.
      - move => ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
        by rewrite nth_scat nth_default size_map -H6 ?addKn ?leq_addr. }
    have Hheap' : corr_heap
      (fun l => P l \/ size H <= l /\ l - size H < size ts)
      (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts)
      (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H)).
    { apply: corr_heap_segment_union.
      - ( refine (corr_heap_segment_impl _ _ _ _
          (corr_heap_ext _ _ _ H1 _ _) _ _ _ _ _ _); eauto ) => l.
        + by move => /(corr_heap_segment_bound _ _ _ _ H1) ->.
        + by move: nth_cat (leqP (size H) l) => -> [ /(nth_default _) -> | ].
      - move => ? [ Hge Hlt ].
        rewrite nth_cat ltnNge Hge (nth_map (Var 0)) => //=.
        repeat (eexists; eauto).
        + apply: (nth_map (Var 0)).
          by rewrite -H6.
        + apply: corr_term_subst.
          { ( refine (corr_term_impl _ _ _ _ _ (H9 _ _ _) _
              (map (omap (rename (addn (size ts))))
                (H ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts))
              (rename (addn (size ts)) \o
                (fun l => if l < size H then mu l else nth (mu l) (map (Let ts') ts') (l - size H))) _ _ _); eauto ) => l.
            - rewrite !nth_map_heap nth_cat.
              case (leqP (size H) l) => [ /(nth_default _) -> | ]; eauto.
            - by move => /(corr_heap_segment_bound _ _ _ _ H1) /= ->. }
          { move => x.
            case (leqP (size ts) x) => ?.
            - by rewrite !nth_scat !nth_default ?size_mkseq ?size_map -?H6.
            - rewrite !nth_scat nth_mkseq ?(nth_map (Var 0)) -?H6 => //.
              apply: corr_term_loc.
              + rewrite leq_addr addKn. eauto.
              + by rewrite ltnNge leq_addr (nth_map (Var 0)) addKn -?H6. }
          { move => l.
            rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_mkseq ?leq_addr ?addKn. }
          { move => l.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_map -H6 ?leq_addr ?addKn. } }
    move: (IHeval_name _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ HPmu' HQmu' ] ] ] ] ] ] ] ].
    repeat (eexists; eauto).
    + move => ? HP.
      rewrite -HPmu'; eauto.
      erewrite corr_heap_segment_bound; eauto.
    + move => l t_.
      by move: nth_cat (leqP (size H) l) (HQmu' l t_) =>
        -> [ /(nth_default _) -> | ].
Qed.

Theorem eval_name_complete' t2 v2 :
  eval_name t2 v2 ->
  forall P mu H1 t1 t2',
  corr_term P H1 mu t1 t2' ->
  corr_heap P H1 mu ->
  t2 = t2' ->
  exists H1' v1,
  Heaps.eval_name H1 t1 H1' v1 /\
  exists P' mu',
  corr_heap P' H1' mu' /\
  corr_term P' H1' mu' v1 v2 /\
  ( forall l, P l -> P' l ) /\
  ( forall l, P l -> mu l = mu' l ) /\
  ( forall l t, nth None H1 l = Some t -> mu l = mu' l ).
Proof.
  induction 1; induction 1; inversion 2; subst.
  - move: (IHcorr_term H4 erefl) => [ ? [ ? [ ? ? ] ] ].
    repeat (eexists; eauto).
  - by move: H6 (H4 _ H2) => <- [ ? [ ? [ ? [ ? [ ] ] ] ] ].
  - move: (IHeval_name1 _ _ _ _ _ H2_ H2 erefl) =>
      [ H1' [ ? [ Hcbn [ P' [ mu' [ Hheap [ ] ] ] ] ] ] ].
    move: (Heaps.eval_name_value _ _ _ _ Hcbn).
    inversion 1. inversion 1. subst => [ [ HP' [ ? HQmu' ] ] ].
    have Hterm' : corr_term P'
      (rcons H1' (Some t4))
      [eta mu' with size H1' |-> t2']
      (subst (scons (Loc (size H1')) Var) t)
      (subst (scons t2' Var) t0).
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H10 _
            (map (omap (rename succn)) (rcons H1' (Some t4)))
            (rename succn \o [eta mu' with size H1' |-> t2'])); eauto ) => l.
        + rewrite !nth_map_heap nth_rcons.
          case (leqP (size H1') l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /= /(corr_heap_segment_bound _ _ _ _ Hheap) /ltn_eqF ->.
      - move => [ | ? ] //=.
        apply: corr_term_indir => /=.
        + by rewrite nth_rcons ltnn eqxx.
        + ( apply: corr_term_impl; eauto ) => l /=.
          * move: nth_rcons  (nth None H1 l)
              (Heaps.eval_name_heap _ _ _ _ Hcbn l) =>
              -> [ ? /(_ _ erefl) | ]; eauto.
            case (leqP (size H1') l) => [ /(nth_default _) -> | ? -> ]; eauto.
          * move => HP.
            rewrite (ltn_eqF
              (corr_heap_segment_bound _ _ _ _ Hheap _ (HP' _ HP))). eauto.
      - move => ?.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id.
      - move => ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id. }
    have Hheap' : corr_heap P'
      (rcons H1' (Some t4))
      [eta mu' with size H1' |-> t2'].
    { refine (corr_heap_segment_impl _ _ _ _
        (corr_heap_ext _ _ _ Hheap _ _) _ _ _ _ _ _); eauto.
      - by move => ? /(corr_heap_segment_bound _ _ _ _ Hheap) /ltn_eqF /= ->.
      - move => l.
        by move: nth_rcons (leqP (size H1') l) => -> [ /(nth_default _) -> | ]. }
    move: (IHeval_name2 _ _ _ _ _ Hterm' Hheap' erefl) =>
      [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ HPmu'' HQmu'' ] ] ] ] ] ] ] ] ].
    repeat (eexists; eauto).
    + move => ? HP.
      rewrite -HPmu'' => /=; eauto.
      rewrite (ltn_eqF (corr_heap_segment_bound _ _ _ _ Hheap _ (HP' _ HP))). eauto.
    + move => l t_ HQ.
      move: nth_rcons (leqP (size H1') l)
        (Heaps.eval_name_heap _ _ _ _ Hcbn _ _ HQ) (HQmu'' l t_) =>
        -> [ /(nth_default _) -> // | Hlt ? <- //= ].
      rewrite (ltn_eqF Hlt). eauto.
  - move: (IHcorr_term H2 erefl) => [ ? [ ? [ ? ? ] ] ].
    repeat (eexists; eauto).
  - by move: H4 (H2 _ H0) => <- [ ? [ ? [ ? [ ? [ ] ] ] ] ].
  - repeat (eexists; eauto).
  - move: (IHcorr_term H3 erefl) => [ ? [ ? [ ? ? ] ] ].
    repeat (eexists; eauto).
  - move: H4 (H3 _ H1) => <- [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    inversion 1. subst => [ Hterm ].
    move: (IHeval_name _ _ _ _ _ Hterm H3 erefl) => [ ? [ ? [ ? ? ] ] ].
    repeat (eexists; eauto).
  - have Hterm' : corr_term
      (fun l => P l \/ size H0 <= l /\ l - size H0 < size ts0)
      (H0 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H0)) (size ts0)) Var)) ts0)
      (fun l => if l < size H0 then mu l else nth (mu l) (map (Let ts') ts') (l - size H0))
      (subst (scat (mkseq (Loc \o addn (size H0)) (size ts0)) Var) t0)
      (subst (scat (map (Let ts') ts') Var) t').
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H4 _
            (map (omap (rename (addn (size ts0))))
              (H0 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H0)) (size ts0)) Var)) ts0))
            (rename (addn (size ts0)) \o
              (fun l => if l < size H0 then mu l else nth (mu l) (map (Let ts') ts') (l - size H0)))); eauto ) => l.
        + rewrite !nth_map_heap nth_cat.
          case (leqP (size H0) l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /(corr_heap_segment_bound _ _ _ _ H5) /= ->.
      - move => x.
        rewrite !nth_scat size_mkseq size_map -H1.
        case (leqP (size ts0) x) => ?.
        + rewrite !nth_default ?size_mkseq ?size_map -?H1; eauto.
        + rewrite nth_mkseq => //=.
          apply: corr_term_loc.
          * rewrite leq_addr addKn. eauto.
          * rewrite ltnNge leq_addr addKn.
            apply: set_nth_default.
            by rewrite size_map -H1.
      - move => ?.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => // ? /=.
        by rewrite nth_scat nth_default size_mkseq ?addKn ?leq_addr.
      - move => ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
        by rewrite nth_scat nth_default size_map -H1 ?addKn ?leq_addr. }
    have Hheap' : corr_heap
      (fun l => P l \/ size H0 <= l /\ l - size H0 < size ts0)
      (H0 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H0)) (size ts0)) Var)) ts0)
      (fun l => if l < size H0 then mu l else nth (mu l) (map (Let ts') ts') (l - size H0)).
    { apply: corr_heap_segment_union.
      - ( refine (corr_heap_segment_impl _ _ _ _
          (corr_heap_ext _ _ _ H5 _ _) _ _ _ _ _ _); eauto ) => l.
        + by move => /(corr_heap_segment_bound _ _ _ _ H5) ->.
        + by move: nth_cat (leqP (size H0) l) => -> [ /(nth_default _) -> | ].
      - move => ? [ Hge Hlt ].
        rewrite nth_cat ltnNge Hge (nth_map (Var 0)) => //=.
        repeat (eexists; eauto).
        + apply: (nth_map (Var 0)).
          by rewrite -H1.
        + apply: corr_term_subst.
          { ( refine (corr_term_impl _ _ _ _ _ (H2 _ _ _) _
              (map (omap (rename (addn (size ts0))))
                (H0 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H0)) (size ts0)) Var)) ts0))
              (rename (addn (size ts0)) \o
                (fun l => if l < size H0 then mu l else nth (mu l) (map (Let ts') ts') (l - size H0))) _ _ _); eauto ) => l.
            - rewrite !nth_map_heap nth_cat.
              case (leqP (size H0) l) => [ /(nth_default _) -> | ]; eauto.
            - by move => /(corr_heap_segment_bound _ _ _ _ H5) /= ->. }
          { move => x.
            case (leqP (size ts0) x) => ?.
            - by rewrite !nth_scat !nth_default ?size_mkseq ?size_map -?H1.
            - rewrite !nth_scat nth_mkseq ?(nth_map (Var 0)) -?H1 => //.
              apply: corr_term_loc.
              + rewrite leq_addr addKn. eauto.
              + by rewrite ltnNge leq_addr (nth_map (Var 0)) addKn -?H1. }
          { move => ?.
            rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_mkseq ?leq_addr ?addKn. }
          { move => l.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_map -H1 ?leq_addr ?addKn. } }
    move: (IHeval_name _ _ _ _ _ Hterm' Hheap' erefl) =>
      [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ HPmu' HQmu' ] ] ] ] ] ] ] ] ].
    repeat (eexists; eauto).
    + move => ? ?.
      rewrite -HPmu'; eauto.
      erewrite corr_heap_segment_bound; eauto.
    + move => l t.
      by move: nth_cat (leqP (size H0) l) (HQmu' l t) =>
        -> [ /(nth_default _) -> | ].
Qed.

Theorem diverge_name_complete' :
  forall t2,
  diverge_name t2 ->
  forall P mu H1 t1,
  corr_term P H1 mu t1 t2 ->
  corr_heap P H1 mu ->
  Heaps.diverge_name H1 t1.
Proof.
  cofix diverge_name_complete.
  inversion 1; inversion 1; subst => [ Hheap0 ].
  - apply: Heaps.diverge_name_loc; eauto.
  - move: (Hheap0 _ H5) => [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    by rewrite H6.
  - apply: Heaps.diverge_name_appL; eauto.
  - apply: Heaps.diverge_name_loc; eauto.
  - move: (Hheap0 _ H6) => [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    by rewrite H7.
  - move: (eval_name_complete' _ _ H0 _ _ _ _ _ H11 Hheap0 erefl) =>
      [ H1' [ ? [ Hcbn [ P' [ mu' [ Hheap [ ] ] ] ] ] ] ].
    move: (Heaps.eval_name_value _ _ _ _ Hcbn).
    inversion 1; inversion 1. subst => [ [ ? [ ? ? ] ] ].
    have Hterm' : corr_term P'
      (rcons H1' (Some t6)) mu'
      (subst (scons (Loc (size H1')) Var) t)
      (subst (scons t3 Var) t0).
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H10 _
            (map (omap (rename succn)) (rcons H1' (Some t6)))); eauto ) => l.
        rewrite !nth_map_heap nth_rcons.
        case (leqP (size H1') l) => [ /(nth_default _) -> | ]; eauto.
      - move => [ | ? ] //=.
        apply: corr_term_indir => /=.
        + by rewrite nth_rcons ltnn eqxx.
        + ( apply: corr_term_impl; eauto ) => l /=.
          move: nth_rcons (nth None H3 l)
            (Heaps.eval_name_heap _ _ _ _ Hcbn l) =>
            -> [ ? /(_ _ erefl) | ]; eauto.
          case (leqP (size H1') l) => [ /(nth_default _) -> | ? -> ]; eauto.
      - move => ?.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id.
      - move => ?.
        by rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id. }
    have Hheap' : corr_heap P' (rcons H1' (Some t6)) mu'.
    { exact: corr_heap_segment_rcons. }
    apply: Heaps.diverge_name_appabs; eauto.
  - apply: Heaps.diverge_name_loc; eauto.
  - move: (Hheap0 _ H5) => [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    rewrite H6. inversion 1. subst => [ ? ].
    apply: Heaps.diverge_name_loc; eauto.
  - have Hterm' : corr_term
      (fun l => P l \/ size H2 <= l /\ l - size H2 < size ts0)
      (H2 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H2)) (size ts0)) Var)) ts0)
      (fun l => if l < size H2 then mu l else nth (mu l) (map (Let ts) ts) (l - size H2))
      (subst (scat (mkseq (Loc \o addn (size H2)) (size ts0)) Var) t0)
      (subst (scat (map (Let ts) ts) Var) t).
    { apply: corr_term_subst.
      - ( eapply (corr_term_impl _ _ _ _ _ H12 _
            (map (omap (rename (addn (size ts0))))
              (H2 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H2)) (size ts0)) Var)) ts0))
            (rename (addn (size ts0)) \o
              (fun l => if l < size H2 then mu l else nth (mu l) (map (Let ts) ts) (l - size H2)))); eauto ) => l.
        + rewrite !nth_map_heap nth_cat.
          case (leqP (size H2) l) => [ /(nth_default _) -> | ]; eauto.
        + by move => /(corr_heap_segment_bound _ _ _ _ Hheap0) /= ->.
      - move => x.
        rewrite !nth_scat size_mkseq size_map -H7.
        case (leqP (size ts0) x) => ?.
        + rewrite !nth_default ?size_mkseq ?size_map -?H1; eauto.
        + rewrite nth_mkseq => //=.
          apply: corr_term_loc.
          * rewrite leq_addr addKn. eauto.
          * rewrite ltnNge leq_addr addKn.
            apply: set_nth_default.
            by rewrite size_map -H7.
      - move => ?.
        rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => // ? /=.
        by rewrite nth_scat nth_default size_mkseq ?addKn ?leq_addr.
      - move => ?.
        rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
        by rewrite nth_scat nth_default size_map -H7 ?addKn ?leq_addr. }
    have Hheap' : corr_heap
      (fun l => P l \/ size H2 <= l /\ l - size H2 < size ts0)
      (H2 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H2)) (size ts0)) Var)) ts0)
      (fun l => if l < size H2 then mu l else nth (mu l) (map (Let ts) ts) (l - size H2)).
    { apply: corr_heap_segment_union.
      - apply: corr_heap_segment_cat.
        refine (corr_heap_segment_impl _ _ _ _
          (corr_heap_ext _ _ _ Hheap0 _ _) _ _ _ _ _ _); eauto.
        by move => ? /(corr_heap_segment_bound _ _ _ _ Hheap0) ->.
      - move => ? [ Hge Hlt ].
        rewrite nth_cat ltnNge Hge (nth_map (Var 0)) => //=.
        repeat (eexists; eauto).
        + apply: (nth_map (Var 0)). by rewrite -H7.
        + apply: corr_term_subst.
          { ( refine (corr_term_impl _ _ _ _ _ (H11 _ _ _) _
              (map (omap (rename (addn (size ts0))))
                (H2 ++ map (@Some _ \o subst (scat (mkseq (Loc \o addn (size H2)) (size ts0)) Var)) ts0))
              (rename (addn (size ts0)) \o
                (fun l => if l < size H2 then mu l else nth (mu l) (map (Let ts) ts) (l - size H2))) _ _ _); eauto ) => l.
            - rewrite !nth_map_heap nth_cat.
              case (leqP (size H2) l) => [ /(nth_default _) -> | ]; eauto.
            - by move => /(corr_heap_segment_bound _ _ _ _ Hheap0) /= ->. }
          { move => x.
            case (leqP (size ts0) x) => ?.
            - by rewrite !nth_scat !nth_default ?size_mkseq ?size_map -?H7.
            - rewrite !nth_scat nth_mkseq ?(nth_map (Var 0)) -?H7 => //.
              apply: corr_term_loc.
              + rewrite leq_addr addKn. eauto.
              + by rewrite ltnNge leq_addr (nth_map (Var 0)) addKn -?H7. }
          { move => ?.
            rewrite nth_map_heap omap_comp (eq_omap _ _ _ id) ?omap_id => // ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_mkseq ?leq_addr ?addKn. }
          { move => ?.
            rewrite /funcomp subst_rename_comp (eq_subst _ _ Var) ?subst_id => //= ?.
            by rewrite nth_scat nth_default size_map -H7 ?leq_addr ?addKn. } }
    apply: Heaps.diverge_name_let. eauto.
Qed.


(**********************************************************************************
 * The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
 * Traversal of Instruction Code) verification framework
 *
 * Developed by Kenneth Roe
 * For more information, check out www.cs.jhu.edu/~roe
 *
 * Tactics.v
 * This file contains the 'crunch' tactic plus a few auxiliary theorems.
 *
 **********************************************************************************)

Require Export SfLib.
Require Export SfLibExtras.
Require Export Coq.Logic.FunctionalExtensionality.
Require Import Omega.

Theorem or_comm:
    forall a b, (a \/ b) -> (b \/ a).
Proof.
    intros. inversion H. right. apply H0. left. apply H0.
Qed.

Theorem in_dist {t}:
    forall a (x:t) b,
        In x (a++b) -> (In x a) \/ (In x b).
Proof.
    induction a. intros. simpl in H. right. apply H.
    intros. simpl in H. inversion H. simpl. left. left. apply H0.
        simpl.
        assert (In x a0 \/ In x b -> (a = x \/ In x a0) \/ In x b).
            intros. inversion H1. left. right. apply H2. right. apply H2.
        apply H1. apply IHa. apply H0.
Qed.

Theorem in_split {t} :
    forall {x:t} l1 l2, In x l1 \/ In x l2 -> In x (l1++l2).
Proof.
    induction l1.
        intros. inversion H. inversion H0. simpl. apply H0.

        intros. simpl in *.
        assert (forall a b c, (a \/ b) \/ c -> a \/ (b \/ c)).
        intros. inversion H0. inversion H1. left. apply H2. right. left. apply H2.
        right. right. apply H1.
        apply H0 in H. inversion H. left. apply H1. right. apply IHl1. apply H1.
Qed.

Fixpoint subset {t} (a : list t) (b : list t) :=
    match a with
    | nil => True
    | (x::y) => In x b /\ subset y b
    end.

Theorem orComm :
    forall a b c, (a \/ b) \/ c -> a \/ (b \/ c).
Proof.
    intros. inversion H. inversion H0. left. apply H1. right. left. apply H1.
    right. right. apply H0.
Qed.

Theorem subsetAppend {t} :
    forall (l : list t) (a : list t), subset l (a++l).
        induction l.
            intros. unfold subset. apply I.

            intros. unfold subset. fold (@subset t).
            split.

            apply in_split. right. simpl. left. reflexivity.

            assert (forall (a:list t) (b:list t) (c:t),
                       (a++c::b)=(a++(c::nil))++b).
                induction a1. simpl. reflexivity.
                simpl. intros. rewrite IHa1. reflexivity.
            assert (forall (x : list t), x = (nil++x)). simpl. reflexivity.
            rewrite H. apply IHl.
Qed.

(*
 * Some glue theorems used in unfolding applications
 *)
Theorem or_imply_left1 : forall A B C,
    ((A \/ B) -> C) -> (A -> C).
Proof.
    intros. apply X. left. apply H.
Qed.

Theorem or_imply_left2 : forall A B C,
    ((A \/ B) -> C) -> (B -> C).
Proof.
    intros. apply X. right. apply H.
Qed.

Ltac crunchStep := match goal with
                   | [ |- _ ] => progress simpl
                   | [ |- _ ] => progress subst
                   | [ |- _ ] => progress (simpl in *)
                   | [ |- _ < _ ] => progress omega
                   | [ |- _ > _ ] => progress omega
                   | [ |- _ <= _ ] => progress omega
                   | [ |- _ >= _ ] => progress omega

                   | [ |- _ = _ ] => progress reflexivity
                   | [ H: ?X |- ?X ] => apply H
                   | [ |- True ] => apply I
                   | [ H: ?X _ |- ?X _ ] => apply H
                   | [ H: ?X _ _ |- ?X _ _] => apply H
                   | [ H: ?X _ _ _ |- ?X _ _ _] => apply H
                   | [ H: ?X _ _ _ _ |- ?X _ _ _ _] => apply H
                   | [ H: ?X _ _ _ _ _ |- ?X _ _ _ _ _] => apply H
                   | [ H: ?X _ _ _ _ _ _ |- ?X _ _ _ _ _ _] => apply H
                   | [ H: ?X _ _ _ _ _ _ _ |- ?X _ _ _ _ _ _ _] => apply H
                   | [ H: forall _, ?X _ |- ?X _] => apply H
                   | [ H: forall _, ?X _ _ |- ?X _ _] => apply H
                   | [ H: forall _, ?X _ _ _ |- ?X _ _ _] => apply H
                   | [ H: ?X \/ ?Y |- ?Y \/ ?X ] => apply or_comm
                   | [ H: forall _, (?X \/ ?Y) |- ?Y \/ ?X ] => apply or_comm

                   | [ |- ?A = ?A \/ _ ] => (left;reflexivity)
                   | [ |- _ \/ ?A = ?A ] => (right;reflexivity)
                   | [ |- _ \/ ?A = ?A \/ _] => (right;left;reflexivity)
                   | [ |- _ \/ _ \/ ?A = ?A] => (right;right;reflexivity)

                   | [ H: ?A |- ?A \/ _ ] => (left;apply H)
                   | [ H: ?A |- _ \/ ?A ] => (right;apply H)
                   | [ H: ?A |- _ \/ ?A \/ _] => (right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ ?A] => (right;right;apply H)
                   | [ H: ?A |- _ \/ _ \/ ?A \/ _] => (right;right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ ?A] => (right;right;right;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ ?A \/ _] => (right;right;right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ ?A] => (right;right;right;right;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ ?A \/ _] => (right;right;right;right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ _ \/ ?A] => (right;right;right;right;right;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ _ \/ ?A \/ _] => (right;right;right;right;right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ ?A] => (right;right;right;right;right;right;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ ?A \/ _] => (right;right;right;right;right;right;left;apply H)
                   | [ H: ?A |- _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ ?A] => (right;right;right;right;right;right;right;apply H)

                   | [ |- _ /\ _ ] => split
                   | [ |- _ <-> _ ] => split

                   | [ H: true = false |- _ ] => inversion H
                   | [ H: false = true |- _ ] => inversion H
                   | [ H: Some _ = None |- _ ] => inversion H
                   | [ H: In _ nil |- _ ] => inversion H
                   | [ H: False |- _ ] => inversion H
                   | [ H: None = Some _ |- _ ] => inversion H
                   | [ H: ?X <> ?X |- _ ] => elim H

                   | [ |- None <> Some _ ] => let x :=fresh in (intro x;inversion x)
                   | [ |- Some _ <> None ] => let x :=fresh in (intro x;inversion x)

                   | [ H: Some _ = Some _ |- _ ] => (inversion H;subst;clear H)
                   | [ H: (_,_) = (_,_) |- _ ] => (inversion H;subst;clear H)
                   | [ H: (_::_) = (_::_) |- _ ] => (inversion H;subst;clear H)
                   | [ H: _ \/ False |- _ ] => (inversion H;subst;clear H)
                   | [ H: False \/ _ |- _ ] => (inversion H;subst;clear H)

                   | [ H1: Some _ = ?P, H2: Some _ = ?P |- _ ] => rewrite <- H2 in H1
                   | [ H1: Some _ = ?P, H2: ?P = Some _ |- _ ] => rewrite H2 in H1
                   | [ H1: ?P = Some _, H2: Some _ = ?P |- _ ] => rewrite <- H2 in H1
                   | [ H1: ?P = Some _, H2: ?P = Some _ |- _ ] => rewrite H2 in H1
                   | [ H1: None = ?P, H2: Some _ = ?P |- _ ] => rewrite <- H2 in H1
                   | [ H1: None = ?P, H2: ?P = Some _ |- _ ] => rewrite H2 in H1
                   | [ H1: ?P = None, H2: Some _ = ?P |- _ ] => rewrite <- H2 in H1
                   | [ H1: ?P = None, H2: ?P = Some _ |- _ ] => rewrite H2 in H1

                   | [ H: ?A = ?B |- ?B = ?A ] => rewrite H

                   | [ H: _ /\ _ |- _ ] => (inversion H;subst;clear H)
                   | [ H: exists _, _ |- _ ] => (inversion H;subst;clear H)

                   | [ |- (fun _ => _) = (fun _ => _) ] => let x := fresh in extensionality x
                   (*| [ H: ?A=?B |- (?A::_) = (?B::_) ] => rewrite H
                   | [ H: ?B=?A |- (?A::_) = (?B::_) ] => rewrite H
                   | [ H: ?A=?B |- (_::?A) = (_::?B) ] => rewrite H
                   | [ H: ?B=?A |- (_::?A) = (_::?B) ] => rewrite H
                   | [ H: _ -> ?A=?B |- (?A::_) = (?B::_) ] => rewrite H
                   | [ H: _ -> ?B=?A |- (?A::_) = (?B::_) ] => rewrite H
                   | [ H: _ -> ?A=?B |- (_::?A) = (_::?B) ] => rewrite H
                   | [ H: _ -> ?B=?A |- (_::?A) = (_::?B) ] => rewrite H*)

                   | [ H: false = beq_id ?A ?B |- context [if beq_id ?B ?A then _ else _] ] => ((rewrite beq_id_comm);rewrite <- H) | [ H: false = beq_id ?A ?B |- context [if beq_id ?A ?B then _ else _] ] => rewrite <- H
                   | [ H: false = beq_id ?A ?B, H2: context [if beq_id ?B ?A then _ else _] |- _ ] => ((rewrite beq_id_comm in H2);rewrite <- H in H2)
                   | [ H: false = beq_id ?A ?B, H2: context [if beq_id ?A ?B then _ else _] |- _ ] => rewrite <- H in H2

                   | [ HE: ?C = None, H: context [match ?C with Some _ => _ | None => _ end] |- _] => rewrite HE in H
                   | [ HE: None = ?C, H: context [match ?C with Some _ => _ | None => _ end] |- _] => rewrite <- HE in H
                   | [ HE: ?C = None, H: context [match ?C with None => _ | Some _ => _ end] |- _] => rewrite HE in H
                   | [ HE: None = ?C, H: context [match ?C with None => _ | Some _ => _ end] |- _] => rewrite <- HE in H
                   | [ HE: ?C = Some _, H: context [match ?C with Some _ => _ | None => _ end] |- _] => rewrite HE in H
                   | [ HE: Some _ = ?C, H: context [match ?C with Some _ => _ | None => _ end] |- _] => rewrite <- HE in H
                   | [ HE: ?C = Some _, H: context [match ?C with None => _ | Some _ => _ end] |- _] => rewrite HE in H
                   | [ HE: Some _ = ?C, H: context [match ?C with None => _ | Some _ => _ end] |- _] => rewrite <- HE in H
                   | [ HE: ?C = None |- context [match ?C with Some _ => _ | None => _ end] ] => rewrite HE
                   | [ HE: None = ?C |- context [match ?C with Some _ => _ | None => _ end] ] => rewrite <- HE
                   | [ HE: ?C = None |- context [match ?C with None => _ | Some _ => _ end] ] => rewrite HE
                   | [ HE: None = ?C |- context [match ?C with None => _ | Some _ => _ end] ] => rewrite <- HE
                   | [ HE: ?C = Some _ |- context [match ?C with Some _ => _ | None => _ end] ] => rewrite HE
                   | [ HE: Some _ = ?C |- context [match ?C with Some _ => _ | None => _ end] ] => rewrite <- HE
                   | [ HE: ?C = Some _ |- context [match ?C with None => _ | Some _ => _ end] ] => rewrite HE
                   | [ HE: Some _ = ?C |- context [match ?C with None => _ | Some _ => _ end] ] => rewrite <- HE
                   | [ H: true = beq_id _ _ |- _ ] => (apply beq_id_eq in H;subst)

                   | [ |- forall (_ : _), _] => intros
                   | [ |- _ -> _] => intros

                   | [ H: In _ (_++_) |- _ ] => apply in_dist in H
                   | [ H: True |- _ ] => clear H
                   | [ |- In _ (_++_) ] => apply in_split
                   end.

Ltac caseAnalysisStep := match goal with
                         | [ H: context [match ?C with None => _ | Some _ => _ end] |- _] => let X := fresh in (remember C as X;destruct X)
                         | [ |- context [if ?C then _ else _]] => let X := fresh in (remember C as X;destruct X)
                         | [ |- context [match ?C with Some _ => _ | None => _ end]] => let X := fresh in (remember C as X;destruct X)
                         | [ |- context [match ?C with None => _ | Some _ => _ end]] => let X := fresh in (remember C as X;destruct X)
                         | [ H: context [match ?C with Some _ => _ | None => _ end] |- _] => let X := fresh in (remember C as X;destruct X)
                         | [ H: context [match ?C with None => _ | Some _ => _ end] |- _] => let X := fresh in (remember C as X;destruct X)
                         | [ H: _ \/ _ |- _] => (inversion H;subst;clear H)
                         end.

Ltac crunch := repeat crunchStep.

Ltac caseAnalysis := (repeat caseAnalysisStep);crunch.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export universe.

Definition decidable (P: [univ]):= (P + (!P))%type.
Definition d2b {x} (d : decidable x) : bool := if d then true else false.
Definition dassert {x} (d : decidable x) : Prop := d2b d = true.

Inductive void : [univ] := .

(* ========= Here is a constuctive iff ======== *)

(*Definition t_iff A B := (A -> B) # (B -> A).*)

Inductive t_iff (A B : [univ]) : [univ] :=
 | t_iff_cons : (A -> B) -> (B -> A) -> t_iff A B.

Notation "x <=> y" := (t_iff x y) (at level 95, no associativity).

Lemma tiff_trans :
  forall a b c, (a <=> b) -> (b <=> c) -> (a <=> c).
Proof.
  intros a b c i1 i2.
  destruct i1 as [i11 i12].
  destruct i2 as [i21 i22].
  split; intro k.
  apply i11 in k; apply i21 in k; auto.
  apply i22 in k; apply i12 in k; auto.
Qed.

Ltac dtiff :=
  match goal with
      [ H : ?x <=> ?y |- _ ] => destruct H
  end.

Ltac dtiffs := repeat dtiff.

Ltac dprod :=
  match goal with
      [ H : ?x # ?y |- _ ] => destruct H
  end.

Ltac dprods := repeat dprod.

Ltac dsum :=
  match goal with
      [ H : ?x [+] ?y |- _ ] => destruct H
  end.

Ltac dsums := repeat dsums.

Ltac dall :=
  repeat match goal with
           | [ H : ?x <=> ?y |- _ ] => destruct H
           | [ H : ?x # ?y   |- _ ] => destruct H
           | [ H : ?x [+] ?y |- _ ] => destruct H
         end.

Definition tiff_fst :=
  fun {A B : [univ]} (p : A <=> B) => let (x, _) := p in x.

Definition tiff_snd :=
  fun {A B : [univ]} (p : A <=> B) => let (_, y) := p in y.

Lemma tiff_is_prod_implies1 :
  forall A B,
    (A <=> B) <=> ((A -> B) # (B -> A)).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma tiff_is_prod_implies2 :
  forall A B : [univ],
    ((A -> B) # (B -> A)) <=> (A <=> B).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma combine_t_iff_proofs_imp :
  forall {A B A' B' : [univ]},
    (A <=> A') -> (B <=> B') -> ((A -> B) <=> (A' -> B')).
Proof.
  intros; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_t_iff :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A <=> B) <=> (A' <=> B')).
Proof.
  intros.
  dall; constructor; intro; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_prod :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A # B) <=> (A' # B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_sum :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A [+] B) <=> (A' [+] B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_not :
  forall {A A'},
    (A <=> A')
    -> (!A <=> !A').
Proof.
  intros.
  dall; constructor; repeat intro; auto.
Qed.

Lemma t_iff_refl :
  forall A, A <=> A.
Proof.
  intros; constructor; auto.
Qed.

Lemma t_iff_sym :
  forall {A B}, (A <=> B) -> (B <=> A).
Proof.
  intros.
  dall; constructor; auto.
Qed.

(* this build a proof object of T <=> T[b/a] where p is the proof of a<=>b.
*)
Ltac build_tiff_term T a b p :=
  match T with
    | a => p
    | ?x -> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_imp l r)
    | ?x <=> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_t_iff l r)
    | ?x # ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_prod l r)
    | ?x [+] ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_sum l r)
    | !?x =>
      let l := build_tiff_term x a b p in
      constr:(combine_t_iff_proofs_not l)
    | _ => constr:(t_iff_refl T)
  end.

Tactic Notation "thin_last" :=
  match goal with H: ?T |- _ => clear H end.

Ltac apply' H1 H2 :=
  let H3 := fresh in (
    (pose proof (H1 H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Ltac build_and_rewrite H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <=> ?B =>
          let d := build_tiff_term C A B H in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply  name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <=> ?B =>
      let d := build_tiff_term C A B H in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name) H2;
        clear name
  end.

Ltac build_and_rewrite_rev H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <=> ?B =>
          let d := build_tiff_term C B A (t_iff_sym H) in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp_rev H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <=> ?B =>
      let d := build_tiff_term C B A (t_iff_sym H) in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name)  H2;
        clear name
  end.

Tactic Notation "trewrite" ident(H) :=
       build_and_rewrite H.

Tactic Notation "trewrite" ident(H) "in" ident (H') :=
       build_and_rewrite_hyp H H'.

Tactic Notation "trewrite" "<-" ident(H) :=
       build_and_rewrite_rev H.

Tactic Notation "trewrite" "<-" ident(H) "in" ident(H') :=
       build_and_rewrite_hyp_rev H H'.

Ltac get_instance_of  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_fst T) h) as name)||
        (pose proof (fun h:H => (tiff_fst (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H; *)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H <=> H2) as Hn by (apply T)
         (*; idtac "really succeded" H *)
         end

    | ?Hl <=> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl # ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | !?Hl => get_instance_of T Hl Hn
    | ?Hl -> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
  end.

Ltac get_instance_of_rev  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_snd T) h) as name)||
        (pose proof (fun h:H => (tiff_snd (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H;*)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H2 <=> H) as Hn by (apply T)
         (** H2 in LHS; apply does not automatically take care
                    of symmetry *)
         (*; idtac "really succeded" H*)
         end

    | ?Hl <=> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl # ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | !?Hl => get_instance_of_rev T Hl Hn
    | ?Hl -> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
  end.

(** rewrite using a universally quantified t_iff relation T  in the conclusion *)
Ltac trw T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of T C name;
        build_and_rewrite name; clear name
  end.

Ltac trw_rev  T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of_rev T C name;
        build_and_rewrite_rev name ; clear name
  end.

Ltac trw_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of T C name;
    build_and_rewrite_hyp name h; clear name.

Ltac trw_rev_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of_rev T C name;
    build_and_rewrite_hyp_rev name h; clear name.

(* Some general notation to use the above tactics *)

Tactic Notation "rw" constr(T) :=
  trw T || rewrite T.
Tactic Notation "rw" "<-" constr(T) :=
  trw_rev T || rewrite <- T.
Tactic Notation "rw" constr(T) "in" ident(H) :=
  trw_h T H || rewrite T in H.
Tactic Notation "rw" "<-" constr(T) "in" ident(H) :=
  trw_rev_h T H || rewrite <- T in H.

Tactic Notation "onerw" :=
       match goal with
         | [ H : _ |- _ ] => progress (trw H || rewrite H)
       end.

Tactic Notation "allrw" := repeat onerw.

Tactic Notation "allrw" "<-" :=
  repeat match goal with
           | [ H : _ |- _ ] => progress (trw_rev H || rewrite <- H)
          end.

(*
Tactic Notation "onerw" constr(T) :=
       match goal with
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).
*)

Tactic Notation "onerw" constr(T) :=
       let t := type of T in
       match goal with
         | [ H : _, H' : t |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         | [ H : t |- _ ] => fail 1
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).

Tactic Notation "rww" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         end.

Tactic Notation "allrw" "<-" constr(T) :=
  repeat match goal with
           | [ H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

Tactic Notation "rww" "<-" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

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

(*
Theorem trw_demo: forall (P Q: nat -> Type),
 (forall n, P n <=> Q n )
  -> ((P 1 * void -> void ) <=> (Q 1 * void -> void )).
Proof.
  intros ? ?  Hiff.
  assert (P 1) by aXdmit.
  trw_h Hiff  X.
  trw Hiff .  apply t_iff_refl.
Qed.

(*
Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <=> forall m, Q m )
    -> ((P 1 * void -> void ) <=> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  constructor; intros.
  destruct X; auto.
  destruct X; auto.
Qed.
*)

Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <=> forall m, Q m )
    -> ((P 1 * void -> void ) <=> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  trw Hiff.
  apply t_iff_refl.
Qed.
*)

(**  --- setoid stuff -- delete? *)

Require Export Coq.Setoids.Setoid.

Inductive Cast (t : [univ]) : Prop :=
| cast : t -> Cast t.
Hint Constructors Cast.

Inductive Cast2 (p : Prop) : [univ] :=
| cast2 : p -> Cast2 p.
Hint Constructors Cast2.

Definition c_t_iff : relation [univ] :=
  fun A B : [univ] => Cast (A <=> B).

Notation "x <==> y" := (c_t_iff x y) (at level 95, no associativity).

Definition t_c_iff : relation [univ] :=
  fun A B : [univ] => Cast (A -> B) /\ Cast (B -> A).

Notation "x <~> y" := (t_c_iff x y) (at level 95, no associativity).

Lemma CType_S : Setoid_Theory [univ] c_t_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  inversion H; subst.
  dall.
  repeat constructor; auto.

  unfold Transitive; intros.
  inversion H; inversion H0; subst.
  dall.
  repeat constructor; auto.
Qed.

Lemma TypeC_S : Setoid_Theory [univ] t_c_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  destruct H.
  inversion H; subst.
  inversion H0; subst.
  repeat constructor; auto.

  unfold Transitive; intros.
  destruct H; destruct H0.
  inversion H; inversion H0; inversion H1; inversion H2; subst.
  repeat constructor; auto.
Qed.

Add Setoid [univ] c_t_iff CType_S as Type_iff_reg.
Add Setoid [univ] t_c_iff TypeC_S as Type_iff_reg2.

Hint Resolve (Seq_refl  [univ] c_t_iff CType_S): setoid.
Hint Resolve (Seq_sym   [univ] c_t_iff CType_S): setoid.
Hint Resolve (Seq_trans [univ] c_t_iff CType_S): setoid.

Hint Resolve (Seq_refl  [univ] t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_sym   [univ] t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_trans [univ] t_c_iff TypeC_S): setoid.

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

(*
Lemma test :
  forall a b (*c f*), (a <=> b) -> Cast a. (*.  # { x : c | f x }.*)
Proof.
  intros.
  rewrite X.
Qed.
*)

(** should not be required anymore? *)

Tactic Notation "trewrite" "<-" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_rev name;
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_rev name;
    clear name.
Tactic Notation "trewrite" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.
Tactic Notation "trewrite" "<-" ident(H) ident(p1) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Theorem dont_touch_forall :
  forall (P Q : (nat : Set) -> [univ]),
    (forall (n : (nat : Set)), P n <=> (forall (m : (nat : Set)), Q (m+n)))
    -> P (1 : (nat : Set))
    -> forall (m : (nat : Set)), Q (m+1).
Proof.
  intros ? ? Hif Hp1.

  rw Hif in Hp1; trivial.
Qed.

Theorem dont_touch_forall2 :
  forall (P Q : nat -> [univ]),
    (forall n, P n <=> (forall m, Q (m+n)))
    -> P 1
    -> forall m, Q (m+1).
Proof.
  intros ? ?  Hif Hp1.
  trw_rev Hif. trivial.
Qed.

Theorem dont_touch_forall3 :
  forall (P Q: nat -> [univ]),
    (forall n, P n <=> (forall m, Q (m+n)))
    -> (forall m, Q (m+1))
    -> P 1.
Proof.
  intros ? ? Hif Hq .
  trw_rev_h Hif Hq. trivial.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import Util Types Term Typing.

Lemma typed_rename M G t T :
  typed M G t T ->
  forall G' r,
  (forall d x, nth d G x = nth d G' (r x)) ->
  typed M G' (rename r t) T.
Proof.
  induction 1 => /= ? ? Hnth; eauto.
  - apply /typed_var => // ?.
    by rewrite -Hnth H.
  - apply /typed_abs; eauto.
    by apply /IHtyped => ? [ | ? ] /=.
  - apply /typed_let; eauto.
    + by rewrite value_rename.
    + by apply /IHtyped => ? [ | ? ] /=.
Qed.

Lemma typed_subst M G t T :
  typed M G t T ->
  forall s G',
  ( forall x T, (forall d, nth d G x = T) ->
    exists (L : seq _), forall s',
    (forall x, exists2 y, s' x = typ_fvar y & y \notin L) ->
    typed M G' (s x) (typ_open s' T) ) ->
  typed M G' (subst s t) T.
Proof.
  induction 1 => /= s0 G' Hnth; eauto.
  - move: (Hnth _ _ H) => [ L Hs' ].
    rewrite -(env_subst_fvar M) -(env_subst_fvar G') -(typ_subst_fvar T)
    -!(env_subst_ext (fun x => if x <= maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L))) then typ_fvar x else s (x - maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).-1) typ_fvar) => [ | ? Hin | ? Hin ].
    + rewrite -(typ_subst_ext (fun x => if x <= maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L))) then typ_fvar x else s (x - maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).-1)) => [ | ? Hin ].
      { rewrite -(typ_open_ext (typ_subst (fun x => if x <= maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L))) then typ_fvar x else s (x - maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).-1) \o (typ_fvar \o addn (maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).+1))) => [ | ? /typ_bv_subst_elim [ ? | [ z ] ] /= ].
        - rewrite -typ_subst_open_distr => [ | z ? ? ].
          + apply /typed_subst_typ => [ | z ? ].
            * apply Hs' => y. repeat eexists. apply /negP => Hin.
              have : (maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).+1 + y <= (maximum (env_enum_fv M (env_enum_fv G' (typ_enum_fv T L)))).
              { apply /maximum_sup.
                by rewrite !env_enum_fv_inE_aux typ_enum_fv_inE_aux Hin !orbT. }
              by rewrite addSn ltnNge leq_addr.
            * by rewrite 3!fun_if /= H0 if_same.
          + by rewrite 3!fun_if /= H0 if_same.
        - by rewrite addSn ltnNge leq_addr /= subSKn addnC addnK.
        - by rewrite 3!fun_if /= H0 if_same. }
      by rewrite maximum_sup // !env_enum_fv_inE_aux typ_enum_fv_inE_aux Hin !orbT.
    + by rewrite maximum_sup // !env_enum_fv_inE_aux typ_enum_fv_inE_aux Hin !orbT.
    + by rewrite maximum_sup // !env_enum_fv_inE_aux typ_enum_fv_inE_aux Hin.
  - apply /typed_abs; eauto.
    apply /IHtyped => [ [ ? /(_ (typ_fvar 0)) /= -> | ? ? /= /Hnth [ L ? ] ] ].
    + exists [::] => ? Hs. apply /typed_var => //= x. by case (Hs x) => ? ->.
    + exists L => ? ?. apply /typed_rename; eauto.
  - apply /typed_let; eauto.
    + exact /value_subst.
    + apply /IHtyped => [ [ ? /(_ (typ_fvar 0)) /= -> | ? ? /= /Hnth [ L' ? ] ] ].
      * exists L => ? Hs. apply /typed_var => //= x. by case (Hs x) => ? ->.
      * exists L' => ? ?. apply /typed_rename; eauto.
Qed.

Corollary typed_subst_single M G t t0 T T0 :
  typed M (T0 :: G) t T ->
  forall (L : seq _),
  (forall s',
    (forall x, exists2 y, s' x = typ_fvar y & y \notin L) ->
    typed M G t0 (typ_open s' T0)) ->
  typed M G (subst (scons t0 var) t) T.
Proof.
  move => /typed_subst Hsubst ? ?.
  apply /Hsubst => [ [ ? /(_ typ_unit) <- /= | /= ? ? ? ] ]; eauto.
  exists [::] => ? Hs.
  apply /typed_var => // x.
  by case (Hs x) => ? ->.
Qed.

Lemma preservation :
  forall H M G,
  size H = size M ->
  (forall i, typed M G (nth trm_unit H i) (nth typ_unit M i)) ->
  forall t H' t',
  cbv H t H' t' ->
  forall T,
  typed M G t T ->
  exists M', typed M' G t' T /\
  (forall x T, (forall d, nth d M x = T) -> forall d, nth d M' x = T) /\
  size H' = size M' /\
  (forall i, typed M' G (nth trm_unit H' i) (nth typ_unit M' i)).
Proof.
  induction 3; inversion 1; subst; eauto.
  - inversion H7. subst.
    exists M. repeat split; eauto.
    apply /(typed_subst_single _ _ _ _ _ _ H11 [::]) => ? Hs.
    rewrite typ_open_bvar_eq => // ?.
    by rewrite H10.
  - move: (IHcbv _ H7) => [ M' [ ? [ ? [ ? ? ] ] ] ].
    exists M'. repeat split; eauto.
    apply /typed_app; eauto.
    apply /(typed_weaken_store M); eauto.
  - move: (IHcbv _ H10) => [ M' [ ? [ ? [ ? ? ] ] ] ].
    exists M'. repeat split; eauto.
    apply /typed_app; eauto.
    apply /(typed_weaken_store M); eauto.
  - have ? : forall x T,
      (forall d, nth d M x = T) ->
      (forall d, nth d (rcons M T0) x = T).
    { move => x T Hnth d.
      by move: nth_rcons (leqP (size M) x)
        (Hnth (if x == size M then T0 else d)) => -> [ /(nth_default _) -> | ]. }
    exists (rcons M T0).
    (repeat split; eauto) => [ | | l ].
    + apply /typed_loc => /= [ | ? ].
      * apply /typed_closed. eauto.
      * by rewrite nth_rcons H0 ltnn eqxx.
    + by rewrite !size_rcons H0.
    + rewrite !nth_rcons -H0.
      case (ltngtP (size H) l) => ? //;
      apply /(typed_weaken_store M); eauto.
  - move: (IHcbv _ H6) => [ ? [ ? [ ? [ ? ? ] ] ] ]. eauto 6.
  - inversion H6. subst.
    rewrite -(H2 trm_unit) -(H9 typ_unit). eauto.
  - move: (IHcbv _ H6) => [ ? [ ? [ ? [ ? ? ] ] ] ]. eauto 6.
  - inversion H7. subst.
    exists M. (repeat split; eauto) => [ | l' ].
    + rewrite size_set_nth -H0.
      apply /maxn_idPr.
      case (leqP (size H) l) => // Hleq.
      move: (H10 typ_unit).
      by rewrite -(H10 (typ_fvar 0)) !nth_default -?H0.
    + rewrite nth_set_nth /=.
      case (@eqP _ l' l) => [ -> | ]; eauto.
      by rewrite H10.
  - move: (IHcbv _ H7) => [ M' [ ? [ ? [ ? ? ] ] ] ].
    exists M'. repeat split; eauto.
    apply /typed_update; eauto.
    apply /typed_weaken_store; eauto.
  - move: (IHcbv _ H10) => [ M' [ ? [ ? [ ? ? ] ] ] ].
    exists M'. repeat split; eauto.
    apply /typed_update; eauto.
    apply /typed_weaken_store; eauto.
  - exists M. repeat split; eauto.
    exact /(typed_subst_single _ _ _ _ _ _ H10 L).
  - by move: (cbv_value _ _ _ _ H2 H6).
Qed.

Lemma canonical_arrow : forall v M T1 T2,
  value v ->
  typed M [::] v (typ_arrow T1 T2) ->
  exists t, v = trm_abs t.
Proof. case => //; inversion 2. eauto. Qed.

Lemma canonical_ref : forall v M T,
  value v ->
  typed M [::] v (typ_ref T) ->
  exists l, v = trm_loc l.
Proof. case => //; inversion 2. eauto. Qed.

Lemma progress H M :
  size H = size M ->
  (forall i, typed M [::] (nth trm_unit H i) (nth typ_unit M i)) ->
  forall t T,
  typed M [::] t T ->
  value t \/ exists H' t', cbv H t H' t'.
Proof.
  move => Hsize Hstore t.
  induction t; inversion 1; subst; eauto.
  - move: (H2 typ_unit).
    by rewrite -(H2 (typ_bvar 0)) !nth_default.
  - move: (IHt1 _ H4) => [ /((canonical_arrow _ _ _ _)^~H4) [ ? -> ] | [ ? [ ? ? ] ] ]; eauto.
    move: (IHt2 _ H6) => [ ? | [ ? [ ? ? ] ] ]; eauto.
  - move: (IHt _ H3) => [ ? | [ ? [ ? ? ] ] ]; eauto.
  - move: (IHt _ H3) => [ /((canonical_ref _ _ _)^~H3) [ l ? ] | [ ? [ ? ? ] ] ]; subst; eauto.
    inversion H3. subst.
    right. repeat eexists. apply /(cbv_deref _ _ (nth trm_unit H l)) => ?.
    case (leqP (size H) l).
    + rewrite Hsize => ?.
      move: (H6 typ_unit).
      by rewrite -(H6 (typ_fvar 0)) !(@nth_default _ _ M).
    + exact /set_nth_default.
  - move: (IHt1 _ H4) => [ /((canonical_ref _ _ _)^~H4) [ l ? ] | [ ? [ ? ? ] ] ]; subst; eauto.
    inversion H4. subst.
    move: (IHt2 _ H6) => [ ? | [ ? [ ? ? ] ] ]; eauto.
Qed.