From Coq Require Import String List Psatz Peano Program.Equality.
From DanTrick Require Import DanTrickLanguage StackLanguage EnvToStack StackLangTheorems.
From DanTrick Require Import DanTrickSemanticsMutInd ImpVarMap ImpVarMapTheorems.
From DanTrick Require Import LogicTranslationBase DanImpHigherOrderRel DanImpHigherOrderRelTheorems.
From DanTrick Require Import FunctionWellFormed CompilerCorrectHelpers CompilerCorrectMoreHelpers.
From DanTrick Require Import StackFrame.

Local Open Scope nat_scope.
Local Open Scope string_scope.
Local Open Scope list_scope.

Local Definition P_compiler_sound (funcs: list fun_Dan) (i: imp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv nenv': nat_env): Prop :=
  forall (i_stk: imp_stack) (stk stk' rho: stack) (num_args: nat) (idents: list ident),
  forall (fenv_s: fun_env_stk),
  forall (FUN_WF: fun_app_imp_well_formed fenv funcs i),
  forall (FENV_WF: fenv_well_formed' funcs fenv),
    fenv_s = compile_fenv fenv ->
    List.length dbenv = num_args ->
    state_to_stack idents nenv dbenv stk ->
    state_to_stack idents nenv' dbenv stk' ->
    imp_rec_rel (var_map_wf_wrt_imp idents) i ->
    i_stk = compile_imp i (fun x => one_index_opt x idents) (List.length idents) ->
    imp_stack_sem i_stk fenv_s (stk ++ rho) (stk' ++ rho).

Local Definition P0_compiler_sound (funcs: list fun_Dan) (a: aexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (n: nat): Prop :=
  forall (a_stk: aexp_stack) (stk rho: stack) (num_args: nat) (idents: list ident),
  forall (fenv_s: fun_env_stk),
  forall (FUN_WF: fun_app_well_formed fenv funcs a),
  forall (FENV_WF: fenv_well_formed' funcs fenv),
    fenv_s = compile_fenv fenv ->
    List.length dbenv = num_args ->
    state_to_stack idents nenv dbenv stk ->
    var_map_wf_wrt_aexp idents a ->
    a_stk = compile_aexp a (fun x => one_index_opt x idents) (List.length idents) ->
    aexp_stack_sem a_stk fenv_s (stk ++ rho) (stk ++ rho, n).

Local Definition P1_compiler_sound (funcs: list fun_Dan) (b: bexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (v: bool): Prop :=
  forall (b_stk: bexp_stack) (stk rho: stack) (num_args: nat) (idents: list ident),
  forall (fenv_s: fun_env_stk),
  forall (FUN_WF: fun_app_bexp_well_formed fenv funcs b),
  forall (FENV_WF: fenv_well_formed' funcs fenv),
    fenv_s = compile_fenv fenv ->
    List.length dbenv = num_args ->
    state_to_stack idents nenv dbenv stk ->
    var_map_wf_wrt_bexp idents b ->
    b_stk = compile_bexp b (fun x => one_index_opt x idents) (List.length idents) ->
    bexp_stack_sem b_stk fenv_s (stk ++ rho) (stk ++ rho, v).

Local Definition P2_compiler_sound (funcs: list fun_Dan) (args: list aexp_Dan) (dbenv: list nat) (fenv: fun_env) (nenv: nat_env) (vals: list nat): Prop :=
  forall (args_stk: list aexp_stack) (stk rho: stack) (num_args: nat) (idents: list ident),
  forall (fenv_s: fun_env_stk),
  forall (FUN_WF: fun_app_args_well_formed fenv funcs args),
  forall (FENV_WF: fenv_well_formed' funcs fenv),
    fenv_s = compile_fenv fenv ->
    List.length dbenv = num_args ->
    state_to_stack idents nenv dbenv stk ->
    Forall (var_map_wf_wrt_aexp idents) args ->
    args_stk = map (fun a => compile_aexp a (fun x => one_index_opt x idents) (List.length idents)) args ->
    args_stack_sem args_stk fenv_s (stk ++ rho) (stk ++ rho, vals).

Lemma big_step_away_pushes (funcs: list fun_Dan)
      (dbenv : list nat)
      (fenv : DanTrickLanguage.ident -> fun_Dan)
      (nenv nenv'' : nat_env)
      (func : fun_Dan)
      (aexps : list aexp_Dan)
      (ns : list nat)
      (ret : nat)
      (f : DanTrickLanguage.ident)
      (FUN_WF: fun_app_well_formed fenv funcs (APP_Dan f aexps))
      (FENV_WF: fenv_well_formed' funcs fenv)
      (e : fenv f = func)
      (e0 : DanTrickLanguage.Args func = Datatypes.length aexps)
      (i : i_Dan (DanTrickLanguage.Body func) ns fenv init_nenv nenv'')
      (H0 : forall (i_stk : imp_stack) (stk stk' rho : stack)
         (num_args : nat) (idents : list ident) (fenv_s : fun_env_stk),
          fun_app_imp_well_formed fenv funcs (DanTrickLanguage.Body func) ->
          fenv_well_formed' funcs fenv ->
          fenv_s = compile_fenv fenv ->
          Datatypes.length ns = num_args ->
          state_to_stack idents init_nenv ns stk ->
          state_to_stack idents nenv'' ns stk' ->
          imp_rec_rel (var_map_wf_wrt_imp idents)
                      (DanTrickLanguage.Body func) ->
          i_stk =
            compile_imp (DanTrickLanguage.Body func)
                        (fun x : ident => one_index_opt x idents)
                        (Datatypes.length idents) ->
          imp_stack_sem i_stk fenv_s (stk ++ rho) (stk' ++ rho))
      (stk rho : stack)
      (num_args : nat)
      (idents : list ident)
      (fenv_s : fun_env_stk)
      (H1 : fenv_s = compile_fenv fenv)
      (H2 : Datatypes.length dbenv = num_args)
      (H3 : state_to_stack idents nenv dbenv stk)
      (H4 : var_map_wf_wrt_aexp idents (APP_Dan f aexps))
      (func' COMPD : fun_stk)
      (fidents : list ident)
      (Heqfidents : fidents = construct_trans (DanTrickLanguage.Body func))
      (HeqCOMPD : COMPD =
                    {|
                      Name := DanTrickLanguage.Name func;
                      Args := Datatypes.length aexps;
                      Body := fst (compile_code (DanTrickLanguage.Body func));
                      Return_expr :=
                      Var_Stk (stack_mapping (DanTrickLanguage.Body func) (Ret func));
                      Return_pop := Datatypes.length fidents
                    |})
      (Heqfunc' : func' =
                    {|
                      Name := DanTrickLanguage.Name func;
                      Args := Datatypes.length aexps;
                      Body :=
                      prepend_push
                        (compile_imp (DanTrickLanguage.Body func)
                                     (stack_mapping (DanTrickLanguage.Body func))
                                     (Datatypes.length fidents))
                        (Datatypes.length fidents);
                      Return_expr :=
                       Var_Stk (stack_mapping (DanTrickLanguage.Body func) (Ret func));
                      Return_pop := Datatypes.length fidents
                    |})
      (Hfunc' : func' = fenv_s f):
  imp_stack_sem
    (prepend_push
       (compile_imp (DanTrickLanguage.Body func)
                    (stack_mapping (DanTrickLanguage.Body func))
                    (Datatypes.length fidents)) (Datatypes.length fidents)) fenv_s
    (ns ++ stk ++ rho) ((map nenv'' fidents ++ ns) ++ stk ++ rho).
Proof.
  remember (Datatypes.length fidents) as fidents_len.
  revert Heqfidents_len. revert Heqfidents.
  remember (compile_imp (DanTrickLanguage.Body func) (stack_mapping (DanTrickLanguage.Body func)) fidents_len) as body_s.
  revert i.
  revert H0. revert ns.
  inversion FUN_WF.
  subst fenv0 wf_funcs f0 args.
  unfold fenv_well_formed' in FENV_WF. destruct FENV_WF as (FENV_WF & FENV_WF').

  induction fidents_len; intros.
  - simpl.
    eapply H0.
    + symmetry in e.
      apply FENV_WF' in e. destruct e as (_ & FUN_APP_BODY & _).
      assumption.
    + unfold fenv_well_formed'; split; assumption.
    + assumption.
    + ereflexivity.
    + assert (state_to_stack nil init_nenv ns ns).
      constructor. eassumption.
    + destruct fidents. simpl. econstructor.
      simpl in Heqfidents_len. invs Heqfidents_len.
    + unfold_wf_aexp_in H4.
      destruct fidents.
      symmetry in Heqfidents.
      eapply var_map_wf_imp_nil_trivial. assumption.
      simpl in Heqfidents_len. invs Heqfidents_len.
    + simpl.
      rewrite Heqbody_s.
      unfold stack_mapping.
      rewrite <- Heqfidents.
      destruct fidents.
      simpl. reflexivity.
      simpl in Heqfidents_len. invs Heqfidents_len.
  - simpl. destruct fidents.
    simpl in Heqfidents_len. invs Heqfidents_len. simpl in *.
    rewrite app_comm_cons. simpl. rewrite prepend_push_commutes. econstructor.
    + econstructor. ereflexivity.
    + rewrite app_comm_cons. rewrite app_comm_cons. eapply remove_prepend_push. rewrite app_assoc.
      eapply H0.
      * symmetry in e. apply FENV_WF' in e. destruct e as (_ & FUN_APP_BODY & _). assumption.
      * unfold fenv_well_formed'; split; assumption.
      * assumption.
      * ereflexivity.
      * assert (0 :: ns = 0 :: nil ++ ns) by (reflexivity).
        rewrite H. rewrite app_comm_cons. rewrite app_assoc. rewrite repeat_add_last. rewrite Heqfidents_len. change (S (Datatypes.length fidents)) with (Datatypes.length (i0 :: fidents)). rewrite <- init_fenv_map_is_repeat_0 with (idents := i0 :: fidents). econstructor.
      * rewrite app_comm_cons. rewrite <- map_cons. econstructor.
      * eapply var_map_wf_imp_self_imp_rec_rel. symmetry. assumption.
      * rewrite Heqbody_s. simpl. rewrite <- Heqfidents_len. unfold stack_mapping. rewrite <- Heqfidents. simpl. reflexivity.
Qed.

Lemma nth_error_map_commute_kinda :
  forall (A B: Type) (alist: list A) (a: A) (f: A -> B) (n: nat),
    nth_error alist n = Some a ->
    nth_error (map f alist) n = Some (f a).
Proof.
  induction alist; intros.
  - destruct n; simpl in H; invs H.
  - destruct n; simpl in H.
    + invs H. simpl. reflexivity.
    + simpl. apply IHalist. assumption.
Qed.

Theorem compiler_sound_mut_ind :
  forall (funcs: list fun_Dan),
    dantrick_sem_mut_ind_theorem (P_compiler_sound funcs) (P0_compiler_sound funcs) (P1_compiler_sound funcs) (P2_compiler_sound funcs).
Proof.
  unfold dantrick_sem_mut_ind_theorem, P_compiler_sound, P0_compiler_sound, P1_compiler_sound, P2_compiler_sound.
  intros funcs.
  dantrick_sem_mutual_induction' P P0 P1 P2 (P_compiler_sound funcs) (P0_compiler_sound funcs) (P1_compiler_sound funcs) (P2_compiler_sound funcs) P_compiler_sound P0_compiler_sound P1_compiler_sound P2_compiler_sound; intros.
  - simpl in H4. subst. invs H1. invs H2.
    constructor.
  - simpl in H6. subst. invs FUN_WF. eapply Stack_if_true.
    + eapply H.
      assumption. assumption.
      reflexivity. ereflexivity. eassumption.
      apply imp_rec_rel_self in H5.
      unfold_wf_imp_in H5.
      invs WF'. assumption. reflexivity.
    + eapply H0; eauto. invs H5. assumption.
  - simpl in H6. rewrite H6. clear H6. clear i_stk. inversion FUN_WF. subst fenv0 wf_funcs b0 i0 i3. eapply Stack_if_false.
    + eapply H; eauto. eapply imp_rec_rel_self in H5. unfold_wf_imp_in H5. invs WF'. assumption.
    + eapply H0; eauto. invs H5. assumption.
  - simpl in H5. rewrite H5. clear H5. clear i_stk.
    eapply imp_rec_rel_self in H4. unfold_wf_imp_in H4.
    inversion FUN_WF. subst fenv0 wf_funcs x0 a1.
    assert (In x idents).
    {
      eapply WF''. constructor. eapply String.eqb_eq. reflexivity.
    }
    econstructor.
    + apply one_index_opt_always_geq_1.
    + remember (one_index_opt x idents) as index.
      assert (imp_has_variable x (ASSIGN_Dan x a)).
      constructor. eapply String.eqb_eq. reflexivity.
      apply WF'' in H5.
      eapply inside_implies_within_range' with (index := index) in H5.
      invs H2. rewrite app_length. rewrite app_length. rewrite map_length.
      eapply Plus.le_plus_trans.
      eapply Plus.le_plus_trans. assumption.
      symmetry. assumption.
    + eapply H. assumption. assumption.
      assumption. eassumption. eassumption.
      invs WF'. assumption.
      reflexivity.
    + invs H3. invs H2. eapply stack_mutated_prefix_OK.
      pose proof (inside_implies_within_range').
      specialize (H0 idents x (one_index_opt x idents) H4 eq_refl).
      rewrite app_length. rewrite map_length. eapply Plus.le_plus_trans. assumption.
      eapply stack_mutated_prefix_OK.
      rewrite map_length. apply inside_implies_within_range' with (x := x).
      assumption. reflexivity.
      eapply stack_mutated_at_index_of_update. assumption. destruct WF as (WF & _). assumption.
  - simpl in H5. rewrite H5. clear H5. clear i_stk.
    pose proof (H5 := H4).
    eapply imp_rec_rel_self in H5. unfold_wf_imp_in H5.
    constructor.
    invs FUN_WF.
    invs H2. invs H3. eapply H; eauto.
    invs WF'. assumption.
  - simpl in H7. rewrite H7. clear H7. clear i_stk.
    revert H2. revert H3.
    invc H6.
    unfold_wf_imp_in H9. invs FUN_WF. intros.
    eapply Stack_while_step.
    + eapply H; eauto. invs WF'. assumption.
    + eapply H0; eauto. econstructor.
    + eapply H1; eauto.
      * econstructor.
      * econstructor. assumption.
        unfold_wf_imp; assumption.
  - simpl in H6. rewrite H6. clear H6. clear i_stk.
    revert H2. revert H3.
    invc H5.
    invs FUN_WF.
    unfold_wf_imp_in H9. intros.
    econstructor; [ eapply H | eapply H0 ]; eauto.
    + econstructor.
    + econstructor.
  - simpl in H3. rewrite H3. constructor.
  - simpl in H3. rewrite H3.
    unfold_wf_aexp_in H2.
    constructor.
    eapply one_index_opt_always_geq_1. invs H1.
    repeat rewrite app_length. rewrite map_length. repeat eapply Plus.le_plus_trans.

    eapply inside_implies_within_range'.
    eapply A. ereflexivity. simpl. left. reflexivity. reflexivity.
    invs H1.
    destruct WF as (NODUP & FIND_OPT & IN & _).
    assert (In x idents).
    {
      eapply A. reflexivity. simpl. left. reflexivity.
    }
    specialize (find_index_rel_in_stronger idents x H NODUP). intros.
    destruct H0.
    specialize (find_index_rel_within_range idents x x0 H0). intros.
    specialize (FIND_OPT x x0 H2). destruct FIND_OPT as (FIND_OPT & _).
    specialize (FIND_OPT H0). rewrite FIND_OPT.
    rewrite <- app_assoc.
    rewrite successor_minus_one_same.
    specialize (in_map nenv idents x H). intros.
    apply In_nth_error in H. destruct H.
    apply nth_error_vs_find_index_rel in H0. destruct H0.
    pose proof (map_length).
    specialize (H5 string nat nenv idents).
    erewrite <- map_length in H2.
    erewrite nth_error_app1.
    eapply map_nth_error with (f := nenv) in H0. assumption.
    destruct H2. eassumption.
  - simpl in H3. rewrite H3.
    clear H3. clear a_stk. constructor.
    lia.
    rewrite app_length. invs H1. rewrite app_length. rewrite map_length.
    repeat rewrite <- PeanoNat.Nat.add_assoc.
    eapply Plus.plus_le_compat_l.
    lia.
    invs H1. rewrite <- app_assoc.
    erewrite nth_error_app2.
    rewrite map_length.
    remember ((Nat.sub
             (Nat.add (Nat.add (@Datatypes.length ident idents) n) (S O))
             (S O))) as SUB.
    remember (Nat.add (@Datatypes.length ident idents) n) as ADD.
    rewrite PeanoNat.Nat.add_comm in HeqSUB.
    erewrite Minus.minus_plus in HeqSUB.
    rewrite HeqADD in HeqSUB. rewrite HeqSUB.
    erewrite Minus.minus_plus.
    rewrite nth_error_app1. assumption.
    destruct a. assumption.
    rewrite PeanoNat.Nat.add_sub. rewrite map_length. apply PeanoNat.Nat.le_add_r.
  - simpl in H5. rewrite H5. clear H5. clear a_stk.
    eapply var_map_wf_plus_dan_forwards in H4. destruct H4.
    inversion FUN_WF.
    subst fenv0 wf_funcs a3 a4.
    econstructor.
    + eapply H; eauto.
    + eapply H0; eauto.
  - simpl in H5. rewrite H5. clear H5. clear a_stk.
    eapply var_map_wf_minus_dan_forwards in H4. destruct H4.
    inversion FUN_WF. subst fenv0 wf_funcs a3 a4.
    econstructor.
    + eapply H; eauto.
    + eapply H0; eauto.
  - simpl in H5. rewrite H5. clear H5. clear a_stk.
    remember (fenv_s f) as func'.
    pose proof (Hfunc' := Heqfunc').
    rewrite H1 in Heqfunc'. unfold compile_fenv in Heqfunc'. unfold compile_function in Heqfunc'. rewrite e in Heqfunc'.
    remember (pre_compile_function func) as COMPD.
    unfold pre_compile_function in HeqCOMPD.
    rewrite e0 in HeqCOMPD.
    rewrite HeqCOMPD in Heqfunc'. simpl in Heqfunc'.
    remember (construct_trans (DanTrickLanguage.Body func)) as fidents.
    assert (imp_stack_sem
    (prepend_push
       (compile_imp (DanTrickLanguage.Body func)
          (stack_mapping (DanTrickLanguage.Body func))
          (Datatypes.length fidents)) (Datatypes.length fidents)) fenv_s
    (ns ++ stk ++ rho) (((map nenv'' fidents) ++ ns) ++ stk ++ rho)) by (eapply big_step_away_pushes; eassumption).
    inversion FUN_WF. subst fenv0 wf_funcs f0 args.
    econstructor.
    + symmetry in Hfunc'. eassumption.
    + rewrite Heqfunc'. simpl. ereflexivity.
    + rewrite Heqfunc'. simpl. ereflexivity.
    + rewrite Heqfunc'. simpl. ereflexivity.
    + rewrite map_length. apply args_Dan_preserves_length in a.
      rewrite a. reflexivity.
    + eapply H; eauto.
      induction aexps.
      * constructor.
      * eapply var_map_wf_app_dan_args_all. eassumption.
    + rewrite Heqfunc'. simpl.
      eapply H5.
    + assert (func0 = func) by (rewrite H9, e; reflexivity).
      subst func0. rewrite H6 in H10, H15, H14, H11.
      eapply free_vars_in_imp_has_variable in H14; [ | eauto ].
      assert (In (Ret func) (construct_trans (DanTrickLanguage.Body func))).
      {
        unfold construct_trans. eapply fold_left_containment_helper.
        assumption.
      }
      econstructor.
      * unfold stack_mapping. eapply one_index_opt_always_geq_1.
      * unfold stack_mapping. repeat rewrite app_length. rewrite map_length. rewrite Heqfidents.

        pose proof (inside_implies_within_range).
        specialize (H9 (construct_trans (DanTrickLanguage.Body func)) (Ret func) (Nat.pred (one_index_opt (Ret func) (construct_trans (DanTrickLanguage.Body func)))) H7).
        assert (one_index_opt (Ret func) (construct_trans (DanTrickLanguage.Body func)) =
                  S (Nat.pred (one_index_opt (Ret func) (construct_trans (DanTrickLanguage.Body func))))).
        rewrite <- Lt.S_pred_pos. reflexivity.
        specialize (one_index_opt_always_geq_1 (Ret func) (construct_trans (DanTrickLanguage.Body func))).
        intros.
        lia.
        apply H9 in H12. destruct H12. apply PeanoNat.Nat.lt_pred_le in H13.
        rewrite <- PeanoNat.Nat.add_assoc.
        apply Plus.le_plus_trans. assumption.
      * unfold stack_mapping.
        pose proof (IN := H7).
        eapply in_idents_one_index_opt in H7; [ | eapply nodup_construct_trans ].
        destruct H7.
        specialize (one_index_opt_always_geq_1 (Ret func) fidents).
        intros.
        rewrite Heqfidents in H9. assert (1 <= x) by (rewrite <- H7; assumption).
        destruct x; [ invs H12 | ].
        rewrite H7. rewrite successor_minus_one_same.
        pose proof (INSIDE := inside_implies_within_range).
        specialize (INSIDE (construct_trans (DanTrickLanguage.Body func)) (Ret func) x IN H7).
        rewrite <- Heqfidents in INSIDE.
        erewrite <- map_length with (f := nenv'') in INSIDE.
        erewrite nth_error_app1.
        rewrite nth_error_app1.
        2: destruct INSIDE; assumption.
        2: destruct INSIDE; rewrite app_length; apply Plus.lt_plus_trans; assumption.
        rewrite nth_error_map.
        rewrite map_length in INSIDE. rewrite Heqfidents in INSIDE.
        destruct INSIDE.
        eapply one_index_opt_vs_nth_error in H7; [ | try lia; try assumption .. ].
        rewrite Heqfidents.
        rewrite <- nth_error_map.
        apply nth_error_map_commute_kinda with (B := nat) (f := nenv'') in H7.
        rewrite e1 in H7. assumption.
    + enough ((Datatypes.length aexps + Datatypes.length fidents) = Datatypes.length (map nenv'' fidents ++ ns)).
      -- apply (same_after_popping_length1 (stk ++ rho) ((map nenv'' fidents ++ ns)) (stk ++ rho) (Datatypes.length aexps + Datatypes.length fidents)).
        symmetry; assumption. reflexivity.
      -- rewrite app_length. rewrite map_length. rewrite PeanoNat.Nat.add_comm.
        eapply args_Dan_preserves_length in a. rewrite a. reflexivity.
  - rewrite H3. simpl. econstructor.
  - rewrite H3. simpl. econstructor.
  - rewrite H4. simpl. econstructor.
    inversion FUN_WF. subst fenv0 wf_funcs b1.
    + eapply H; eauto.
      eapply var_map_wf_neg_dan; eauto.
    + reflexivity.
  - rewrite H5. simpl. eapply var_map_wf_and_or_dan_forwards in H4. destruct H4. inversion FUN_WF. subst fenv0 wf_funcs b3 b4.  econstructor.
    + eapply H. assumption. assumption. assumption. eassumption. eassumption. eapply H4. reflexivity.
    + eapply H0. assumption. assumption. assumption. eassumption. eassumption. eassumption. reflexivity.
    + reflexivity.
    + left. reflexivity.
  - rewrite H5. simpl. eapply var_map_wf_and_or_dan_forwards in H4. destruct H4. inversion FUN_WF. subst fenv0 wf_funcs b3 b4. econstructor.
    + eapply H. assumption. assumption. assumption. eassumption. eassumption. eapply H4. reflexivity.
    + eapply H0. assumption. assumption. assumption. eassumption. eassumption. eassumption. reflexivity.
    + reflexivity.
    + right. reflexivity.
  - rewrite H5. simpl. eapply var_map_wf_leq_dan_forwards in H4. destruct H4. inversion FUN_WF. subst fenv0 wf_funcs a3 a4. econstructor.
    + eapply H. assumption. assumption. assumption. eassumption. eassumption. eapply H4. reflexivity.
    + eapply H0. assumption. assumption. assumption. eassumption. eassumption. eassumption. reflexivity.
    + reflexivity.
    + reflexivity.
  - rewrite H3. simpl. econstructor.
  - rewrite H5. simpl. inversion FUN_WF. subst fenv0 wf_funcs arg args. econstructor.
    + eapply H; eauto. invs H4. assumption.
    + eapply H0; eauto. invs H4. assumption.
Qed.

Theorem compiler_sound :
  forall n_args idents fenv_d fenv_s func_list,
    fenv_well_formed' func_list fenv_d ->
    fenv_s = compile_fenv fenv_d ->
    (forall aD aS,
        aS = compile_aexp
               aD
               (fun x => one_index_opt x idents)
               (List.length idents) ->
        fun_app_well_formed fenv_d func_list aD ->
        var_map_wf_wrt_aexp idents aD ->
        forall nenv dbenv stk n rho,
          List.length dbenv = n_args ->
          state_to_stack idents nenv dbenv stk ->
          a_Dan aD dbenv fenv_d nenv n ->
          aexp_stack_sem aS fenv_s (stk ++ rho) (stk ++ rho, n)) /\
      (forall bD bS,
          bS = compile_bexp
                 bD
                 (fun x => one_index_opt x idents)
                 (List.length idents) ->
          fun_app_bexp_well_formed fenv_d func_list bD ->
          var_map_wf_wrt_bexp idents bD ->
          forall nenv dbenv stk bl rho,
            List.length dbenv = n_args ->
            state_to_stack idents nenv dbenv stk ->
            b_Dan bD dbenv fenv_d nenv bl ->
            bexp_stack_sem bS fenv_s (stk ++ rho) (stk ++ rho, bl)).
Proof.
  pose proof (SOUND := compiler_sound_mut_ind).
  intros.
  unfold dantrick_sem_mut_ind_theorem, P_compiler_sound, P0_compiler_sound, P1_compiler_sound, P2_compiler_sound in SOUND. specialize (SOUND func_list).
  destruct SOUND as (_ & AEXP & BEXP & _).
  split; intros.
  - eapply AEXP; try eassumption.
  - eapply BEXP; try eassumption.
Qed.

Lemma aexp_compiler_sound :
  forall n_args idents fenv_d fenv_s func_list,
    fenv_well_formed' func_list fenv_d ->
    fenv_s = compile_fenv fenv_d ->
    forall aD aS,
        aS = compile_aexp
               aD
               (fun x => one_index_opt x idents)
               (List.length idents) ->
        fun_app_well_formed fenv_d func_list aD ->
        var_map_wf_wrt_aexp idents aD ->
        forall nenv dbenv stk n rho,
          List.length dbenv = n_args ->
          state_to_stack idents nenv dbenv stk ->
          a_Dan aD dbenv fenv_d nenv n ->
          aexp_stack_sem aS fenv_s (stk ++ rho) (stk ++ rho, n).
Proof.
  pose proof (SOUND := compiler_sound).
  intros.
  specialize (SOUND n_args idents fenv_d fenv_s func_list H H0).
  destruct SOUND as (AEXP & _).
  eapply AEXP; eassumption.
Qed.

Lemma bexp_compiler_sound :
  forall n_args idents fenv_d fenv_s func_list,
    fenv_well_formed' func_list fenv_d ->
    fenv_s = compile_fenv fenv_d ->
    forall bD bS,
      bS = compile_bexp
             bD
             (fun x => one_index_opt x idents)
             (List.length idents) ->
      fun_app_bexp_well_formed fenv_d func_list bD ->
      var_map_wf_wrt_bexp idents bD ->
      forall nenv dbenv stk bl rho,
        List.length dbenv = n_args ->
        state_to_stack idents nenv dbenv stk ->
        b_Dan bD dbenv fenv_d nenv bl ->
        bexp_stack_sem bS fenv_s (stk ++ rho) (stk ++ rho, bl).
Proof.
  pose proof (SOUND := compiler_sound).
  intros. specialize (SOUND n_args idents fenv_d fenv_s func_list H H0).
  destruct SOUND as (_ & BEXP).
  eapply BEXP; eassumption.
Qed.


(*===========================================================================
    Anti-frame rule for registers

    This rule allows removing a register from the footprint of a program even
    though the program reads and writes it, as long as the value is restored at
    the end. This captures the common (PUSH r;; c;; POP r) pattern.
  ===========================================================================*)
Require Import ssreflect ssrbool ssrfun ssrnat eqtype tuple seq fintype.
Require Import procstate SPred spec pointsto reader safe septac.
Require Import triple (* for toPState *).
Require Import Setoid CSetoid Morphisms.
Require Import FunctionalExtensionality.

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

Local Transparent ILPre_Ops PStateSepAlgOps sepILogicOps ILFun_Ops.

Definition regNotFree (r: AnyReg) (P: SPred) :=
  (P ** ltrue) //\\ (r?  ** ltrue) |-- P ** r? ** ltrue.

Lemma regAny_sub (r: AnyReg) s:
  (r? ** ltrue) s -> exists v, s Registers r = Some v.
Proof.
  move => [sr [strue [Hs1 [[v Hsr] _]]]].
  move/stateSplitsAsIncludes: Hs1 => [Hs1 _].
  simpl in Hsr. rewrite <-Hsr in Hs1.
  exists v. apply Hs1. by rewrite /= eq_refl.
Qed.

Theorem antiframe_register (r: AnyReg) P S:
  regNotFree r P ->
  AtContra S ->
  (forall v, S @ (r~=v) |-- safe @ (P ** r~=v)) ->
  S |-- safe @ P.
Proof.
  move => HPr Hcontra H k R HS. move => s Hps.
  specialize (H (s.(registers) r)).
  rewrite ->lentails_eq, ->sepSPA, <-lentails_eq in Hps.
  destruct Hps as [sP [s' [Hsp [HsP Hs']]]].

  (* Without loss of generality, we can assume that register r is in s' (not
     sP). Otherwise, we can "move" it to s': regNotFree lets us isolate it in sP,
     and it can be added to s' because the ltrue assertion can absorb it. *)
  without loss : sP s' HsP Hsp Hs' / s' Registers r = (toPState s) Registers r.
  { edestruct stateSplitsAs_reg_or with (r:=r) as [HrP | HrQ];
      first apply Hsp; last first.
    { apply; try eassumption. }
    destruct (HPr sP) as [sP' [sr [HsP_split [HsP' Hsr]]]].
    { split.
      - by rewrite ->lentails_eq, <-(ltrueR empSP), empSPR, <-lentails_eq.
      - exists (addRegToPState emptyPState r (s.(registers) r)).
        exists (removeRegFromPState sP r).
        split; last split.
      - rewrite /removeRegFromPState /restrictState /matchRegInPStateDom.
        move => [] r'; try (destruct (sP _ r'); tauto); [].
        simpl. case Hr': (r == r') => /=.
        + rewrite -(eqP Hr') HrP /=. by left.
        + destruct (sP Registers r'); tauto.
      - exists (s.(registers) r). by rewrite /=.
      - done.
    }
    apply sa_mulC in Hsp.
    destruct (sa_mulA Hsp HsP_split) as [s'' [Hsp' Hs'']].
    move/(_ sP' s''). apply; try assumption.
    - destruct Hs' as [sR [strue [Hs' [HsR _]]]].
      exists sR. apply sa_mulC in Hs''.
      destruct (sa_mulA Hs'' Hs') as [sr' [Hs''_sr Hsr']]. by exists sr'.
    - rewrite <- HrP.
      move/stateSplitsAsIncludes: Hs'' => [_ Hsr_s''].
      move/stateSplitsAsIncludes: HsP_split => [_ Hsr_sP].
      move/regAny_sub: Hsr => [v Hsr].
      move/(_ _ _ _ Hsr): Hsr_s'' => ->.
      move/(_ _ _ _ Hsr): Hsr_sP => ->. done.
  }

  move => HsPr.
  specialize (H k (eq_pred (removeRegFromPState s' r))). simpl in H. apply H.
  { assert (regIs r (s.(registers) r) ** eq_pred (removeRegFromPState s' r)
            |-- R ** ltrue) as HRtrue.
    { rewrite ->lentails_eq in Hs'. rewrite <-Hs'. apply stateSplitsAs_eq.
      erewrite <-matchRegInPStateDom_addRegToPState; last eassumption.
      by apply stateSplitsOn. }
    rewrite ->HRtrue. rewrite sepSPC. by apply spec_frame. }
  rewrite ->lentails_eq, ->!sepSPA, <-lentails_eq.
  do 2 eexists. do 2 (split; first eassumption).
  clear - HsPr.
  exists (addRegToPState emptyPState r (s.(registers) r)).
  exists (removeRegFromPState s' r).
  split.
  - erewrite <-matchRegInPStateDom_addRegToPState; last eassumption.
    by apply stateSplitsOn.
  - split.
    + simpl. reflexivity.
    + do 2 eexists. split; first by apply sa_unitI. simpl. done.
Qed.

(* More concise formulation. Probably not very useful with the tactics in this
   development. *)
Corollary antiframe_register_spec_reads (r: AnyReg) P S:
  regNotFree r P ->
  AtContra S ->
  |-- (S -->> safe @ P) <@ r? ->
  S |-- safe @ P.
Proof.
  rewrite /stateIsAny. rewrite <-spec_reads_ex.
  move => HPr Hcontra H. apply: antiframe_register; first eassumption.
  move => v. lforwardR H.
  { apply lforallL with v. rewrite ->spec_reads_entails_at; last by apply _.
    autorewrite with push_at. reflexivity. }
  by apply limplValid.
Qed.

(* Now follows lemmas for proving regNotFree. *)

Instance regNotFree_lequiv r:
  Proper (lequiv --> Basics.impl) (regNotFree r).
Proof.
  rewrite /regNotFree /Basics.flip. by move => P P' ->.
Qed.

Lemma stateSplitsAs_move_register r v s:
  s Registers r = Some v ->
  stateSplitsAs s (addRegToPState emptyPState r v) (removeRegFromPState s r).
Proof.
  move => Hsr.
  rewrite /removeRegFromPState /restrictState /matchRegInPStateDom.
  move => [] r'; try (destruct (s _ r'); tauto); [].
  simpl. case Hr': (r == r') => /=.
  + rewrite -(eqP Hr') Hsr /=. tauto.
  + destruct (s Registers r'); tauto.
Qed.

(* A predicate, here "r?", is _atomic_ when it cannot be divided across sepSP *)
Lemma stateAny_atomic (r: AnyReg) P Q:
  (P ** Q) //\\ (r? ** ltrue) |--
  (P //\\ (r? ** ltrue)) ** Q \\// P ** (Q //\\ (r? ** ltrue)).
Proof.
  move => s [HPQ Hrtrue].
  destruct HPQ as [sP [sQ [Hs_PQ [HsP HsQ]]]].
  without loss : P Q sP sQ Hs_PQ HsP HsQ / sP Registers r = s Registers r.
  { edestruct stateSplitsAs_reg_or with (r:=r) as [HrP | HrQ];
      first apply Hs_PQ.
    { apply; try eassumption. }
    move/(_ Q P sQ sP). apply sa_mulC in Hs_PQ. move/(_ Hs_PQ HsQ HsP HrQ).
    rewrite ->!lentails_eq. etransitivity; first eassumption. apply lorL.
    - apply lorR2. by rewrite sepSPC.
    - apply lorR1. by rewrite sepSPC.
  }
  move => HrP. left. exists sP, sQ. split; first done. split; last done.
  split; first done. destruct Hrtrue as [sr [strue [Hs_r [[v Hsr] _]]]].
  simpl in Hsr. exists sr. exists (removeRegFromPState sP r).
  split; last first.
  { split; last done. exists v. assumption. }
  rewrite <-Hsr. apply stateSplitsAs_move_register. rewrite HrP.
  move/stateSplitsAsIncludes: Hs_r => [Hs_r _].
  erewrite <- Hs_r; first reflexivity. rewrite <-Hsr. by rewrite /= eq_refl.
Qed.

Lemma regNotFree_sepSP r P Q:
  regNotFree r P -> regNotFree r Q -> regNotFree r (P ** Q).
Proof.
  rewrite /regNotFree => HrNotInP HrNotInQ.
  rewrite ->stateAny_atomic.
  apply lorL; last first.
  - rewrite ![(P ** Q) ** _]sepSPA. cancel2. cancel2. by apply landL2.
  - rewrite ->stateAny_atomic. rewrite lor_sepSP. apply lorL.
    + rewrite -{1}[P]empSPR. rewrite ->(ltrueR empSP).
      rewrite ->HrNotInP. by ssimpl.
    + rewrite -{1}[Q]empSPR. rewrite ->(ltrueR empSP).
      rewrite ->HrNotInQ. by ssimpl.
Qed.
Hint Resolve regNotFree_sepSP : reg_not_in.

Lemma regNotFree_or r P Q:
  regNotFree r P -> regNotFree r Q -> regNotFree r (P \\// Q).
Proof.
  rewrite /regNotFree => HrNotInP HrNotInQ. rewrite lor_sepSP.
  apply landAdj; apply lorL; apply limplAdj.
  - rewrite lor_sepSP. by apply lorR1.
  - rewrite lor_sepSP. by apply lorR2.
Qed.
Hint Resolve regNotFree_or : reg_not_in.

Lemma regNotFree_exists r T (P: T -> SPred):
  (forall t, regNotFree r (P t)) -> regNotFree r (lexists P).
Proof.
  rewrite /regNotFree => HrNotInP.
  apply landAdj. sdestruct => t. apply limplAdj. ssplit. apply HrNotInP.
Qed.
Hint Resolve regNotFree_exists : reg_not_in.

(* This definition is stronger than regNotFree but is often easier to prove.
   It does not hold for P=ltrue. *)
Definition regMissingIn (r: AnyReg) (P: SPred) :=
  P //\\ (r?  ** ltrue) |-- lfalse.

Lemma regMissingIn_regNotFree r P:
  regMissingIn r P -> regNotFree r P.
Proof.
  rewrite /regMissingIn /regNotFree => H.
  rewrite ->stateAny_atomic. rewrite ->H.
  apply lorL; first by ssimpl.
  cancel2. by apply landL2.
Qed.
Hint Immediate regMissingIn_regNotFree : reg_not_in.

(* This morphism is not available for regNotFree, and it makes an important
   difference when dealing for spec_reads, whose definition contains lentails.
 *)
Instance regMissingIn_lentails r:
  Proper (lentails --> Basics.impl) (regMissingIn r).
Proof.
  rewrite /regMissingIn /Basics.flip => P P' HP H. by rewrite ->HP.
Qed.

Instance regMissingIn_lequiv r:
  Proper (lequiv ==> iff) (regMissingIn r).
Proof.
  move => P P' [HP HP']. split.
  - by rewrite ->HP'.
  - by rewrite <-HP.
Qed.

Lemma regMissingIn_empSP r:
  regMissingIn r empSP.
Proof.
  move => s [Hemp Hrtrue]. move/regAny_sub: Hrtrue => [vr Hsr].
  rewrite /empSP /sepLogicOps /SABIOps /= in Hemp. destruct Hemp as [Hs _].
  rewrite <-Hs in Hsr. discriminate.
Qed.
Hint Resolve regMissingIn_empSP : reg_not_in.

Lemma regMissingIn_false r:
  regMissingIn r lfalse.
Proof.
  by apply landL1.
Qed.
Hint Resolve regMissingIn_false : reg_not_in.

Lemma regNotFree_true r:
  regNotFree r ltrue.
Proof.
  rewrite /regNotFree. apply landL2. rewrite <-(ltrueR empSP) at 2. by ssimpl.
Qed.
Hint Resolve regNotFree_true : reg_not_in.

Lemma regNotFree_propand r p P:
  regNotFree r P -> regNotFree r (p /\\ P).
Proof.
  move => H. by apply regNotFree_exists.
Qed.
Hint Resolve regNotFree_propand : reg_not_in.

(* I have not found modular proofs of regNotFree for lforall, //\\, -* and -->>.
   Proofs exist for lforall and //\\ for a stronger definition: P is closed
   under removal of r from its states: [P //\\ (r?  ** ltrue) |-- P ** r?].
 *)

Lemma regMissingIn_sepSP r P Q:
  regMissingIn r P -> regMissingIn r Q -> regMissingIn r (P ** Q).
Proof.
  rewrite /regMissingIn => HP HQ. rewrite ->stateAny_atomic. apply lorL.
  - rewrite ->HP. by ssimpl.
  - rewrite ->HQ. by ssimpl.
Qed.
Hint Resolve regMissingIn_sepSP : reg_not_in.

Lemma regMissingIn_exists r T (P: T -> SPred):
  (forall t, regMissingIn r (P t)) -> regMissingIn r (lexists P).
Proof.
  rewrite /regMissingIn => H. apply landAdj. apply lexistsL => t.
  by apply limplAdj.
Qed.
Hint Resolve regMissingIn_exists : reg_not_in.

Lemma regMissingIn_propand r p P:
  regMissingIn r P -> regMissingIn r (p /\\ P).
Proof.
  move => H. by apply regMissingIn_exists.
Qed.
Hint Resolve regMissingIn_propand : reg_not_in.

Lemma regMissingIn_flag r (f: Flag) (v: FlagVal):
  regMissingIn r (f ~= v).
Proof.
  move => s [Hfv Hrtrue]. move/regAny_sub: Hrtrue => [vr Hsr].
  simpl in Hfv. rewrite <-Hfv in Hsr. discriminate.
Qed.
Hint Resolve regMissingIn_flag : reg_not_in.

Lemma regMissingIn_byte r i v:
  regMissingIn r (byteIs i v).
Proof.
  move => s [Hiv Hrtrue]. move/regAny_sub: Hrtrue => [vr Hsr].
  simpl in Hiv. rewrite <-Hiv in Hsr. discriminate.
Qed.
Hint Resolve regMissingIn_byte : reg_not_in.

Lemma regMissingIn_flagAny r (f: Flag):
  regMissingIn r (f?).
Proof.
  rewrite /stateIsAny. by auto with reg_not_in.
Qed.
Hint Resolve regMissingIn_flagAny : reg_not_in.

Lemma regMissingIn_reg (r r': AnyReg) (v: DWORD):
  r != r' -> regMissingIn r (r' ~= v).
Proof.
  move => Hrr' s [Hfv Hrtrue]. move/regAny_sub: Hrtrue => [vr Hsr].
  simpl in Hfv. rewrite <-Hfv in Hsr. rewrite /addRegToPState in Hsr.
  rewrite ifN_eqC in Hsr; last assumption. discriminate.
Qed.
Hint Resolve regMissingIn_reg : reg_not_in.

(* Needed because the regMissingIn_reg is cost 1 and won't apply after Hint
   Immediate. *)
Lemma regNotFree_reg (r r': AnyReg) (v: DWORD):
  r != r' -> regNotFree r (r' ~= v).
Proof.
  move => H. apply regMissingIn_regNotFree. auto with reg_not_in.
Qed.
Hint Resolve regNotFree_reg : reg_not_in.

Lemma regMissingIn_regAny r (r': AnyReg):
  r != r' -> regMissingIn r (r'?).
Proof.
  move => Hr'. rewrite /stateIsAny. by auto with reg_not_in.
Qed.
Hint Resolve regMissingIn_regAny : reg_not_in.

(* Unfortunately we cannot prove this for general memIs since the memIs
   definition does not limit the SPred predicate in any way. *)
Lemma regMissingIn_reader R {reader: Reader R} r i j (v: R) :
  regMissingIn r (i -- j :-> v).
Proof.
  rewrite readerMemIsSimpl. move: i j. induction reader => i j.
  - rewrite /interpReader. by eauto with reg_not_in.
  - rewrite /interpReader. destruct i; by eauto with reg_not_in.
  - rewrite /interpReader. destruct i; by eauto with reg_not_in.
  - rewrite /interpReader. by eauto with reg_not_in.
Qed.
Hint Resolve regMissingIn_reader : reg_not_in.

(* TODO: prove base cases of regNotFree simpler *)
(* TODO: extend antiframe to flags *)
(* TODO: reg_not_in hints for forall, -->>, -*, ->> *)
(* TODO: is the theorem strong enough to easily extend to multiple registers? *)
(* TODO: corollary for basic *)
(* TODO: extend to other RHS than [safe @ P]? The only property of [safe] we're
   really using here is that it adds [** ltrue] _and nothing more_ to the frame.
 *)


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Bihong Zhang <sa614257@mail.ustc.edu.cn>                         *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Definition PAGE_DATA_SIZE := 32.

Definition PAGE_OOB_SIZE := 8.

Definition ECC_IN_OOB_SIZE := 4.

Definition PAGE_SPARE_AREA_SIZE := 2.

Definition BLOCKS := 16.

Definition NUM_OF_BLOCKS := BLOCKS.

Definition PAGES_PER_BLOCK := 16.

Definition SECTOR_DATA_SIZE := PAGE_DATA_SIZE.

Definition MAX_PHYSICAL_BLOCKS := BLOCKS.

Definition MAX_LOGICAL_BLOCKS := 8.

Definition MIN_FREE_BLOCKS := 3.

Definition GC_THRESHOLD := 4.

Definition NUM_OF_SECTORS := MAX_LOGICAL_BLOCKS * PAGES_PER_BLOCK.

Definition CMT_LENGTH := 16.

Definition TRANS_RECORD_SIZE := 4.

Definition RECORD_PER_TRANS := 8.

Definition GTD_LENGTH := 32.


Require Import HoareDef IntroHeader IntroF1 IntroF2 SimModSem.
Import Sep.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

Require Import HTactics ProofMode.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG IRA.t Σ}.

  Let W: Type := Any.t * Any.t.

  Let wf: _ -> W -> Prop :=
    @mk_wf
      _
      unit
      (fun _ _ _ => ⌜True⌝%I)
  .

  Theorem correct: refines2 [IntroF1.F] [IntroF2.F].
  Proof.
    eapply adequacy_local2. econs; ss.
    i. econstructor 1 with (wf:=wf) (le:=top2); et; swap 2 3.
    { ss. }
    { esplits. econs; ss. eapply to_semantic. iIntros "H". iSplits; ss. }

    econs; ss. init. harg. mDesAll.
    des; clarify. unfold fF, ccallU. steps. astart 10. force_r. exists x. steps. force_r; ss. steps.
    unfold Ncall. steps. des_ifs.
    - unfold ccallU. steps. acatch. des. hcall _ _ with "*"; auto.
      { esplits; ss; et. }
      steps. astop. ss. steps. mDesAll; clarify. rewrite Any.upcast_downcast. ss. steps.
      force_r; ss. steps. force_l. esplits. steps. hret _; ss.
    - steps. astop. steps. force_l. esplits. steps.
      hret _; ss.
  Unshelve. all: ss. all: try exact 0.
  Qed.

End SIMMODSEM.


Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 7
*)

(** 1 Mutual Coinduction *)

Section Arg7_1.

Definition monotone7 T0 T1 T2 T3 T4 T5 T6 (gf: rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6) :=
  forall x0 x1 x2 x3 x4 x5 x6 r r' (IN: gf r x0 x1 x2 x3 x4 x5 x6) (LE: r <7= r'), gf r' x0 x1 x2 x3 x4 x5 x6.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable gf : rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6.
Arguments gf : clear implicits.

Theorem paco7_acc: forall
  l r (OBG: forall rr (INC: r <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7 gf rr),
  l <7= paco7 gf r.
Proof.
  intros; assert (SIM: paco7 gf (r \7/ l) x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_mon: monotone7 (paco7 gf).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_mult_strong: forall r,
  paco7 gf (upaco7 gf r) <7= paco7 gf r.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Corollary paco7_mult: forall r,
  paco7 gf (paco7 gf r) <7= paco7 gf r.
Proof. intros; eapply paco7_mult_strong, paco7_mon; eauto. Qed.

Theorem paco7_fold: forall r,
  gf (upaco7 gf r) <7= paco7 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco7_unfold: forall (MON: monotone7 gf) r,
  paco7 gf r <7= gf (upaco7 gf r).
Proof. unfold monotone7; intros; destruct PR; eauto. Qed.

End Arg7_1.

Hint Unfold monotone7.
Hint Resolve paco7_fold.

Arguments paco7_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].

Instance paco7_inst  T0 T1 T2 T3 T4 T5 T6 (gf : rel7 T0 T1 T2 T3 T4 T5 T6->_) r x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7 gf r x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_acc gf;
  pacomult   := paco7_mult gf;
  pacofold   := paco7_fold gf;
  pacounfold := paco7_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg7_2.

Definition monotone7_2 T0 T1 T2 T3 T4 T5 T6 (gf: rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6) :=
  forall x0 x1 x2 x3 x4 x5 x6 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4 x5 x6) (LE_0: r_0 <7= r'_0)(LE_1: r_1 <7= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4 x5 x6.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable gf_0 gf_1 : rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.

Theorem paco7_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7_2_0 gf_0 gf_1 rr r_1),
  l <7= paco7_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco7_2_0 gf_0 gf_1 (r_0 \7/ l) r_1 x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7_2_1 gf_0 gf_1 r_0 rr),
  l <7= paco7_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco7_2_1 gf_0 gf_1 r_0 (r_1 \7/ l) x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_2_0_mon: monotone7_2 (paco7_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_2_1_mon: monotone7_2 (paco7_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_2_0_mult_strong: forall r_0 r_1,
  paco7_2_0 gf_0 gf_1 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_2_1_mult_strong: forall r_0 r_1,
  paco7_2_1 gf_0 gf_1 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Corollary paco7_2_0_mult: forall r_0 r_1,
  paco7_2_0 gf_0 gf_1 (paco7_2_0 gf_0 gf_1 r_0 r_1) (paco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco7_2_0_mult_strong, paco7_2_0_mon; eauto. Qed.

Corollary paco7_2_1_mult: forall r_0 r_1,
  paco7_2_1 gf_0 gf_1 (paco7_2_0 gf_0 gf_1 r_0 r_1) (paco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco7_2_1_mult_strong, paco7_2_1_mon; eauto. Qed.

Theorem paco7_2_0_fold: forall r_0 r_1,
  gf_0 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco7_2_1_fold: forall r_0 r_1,
  gf_1 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1) <7= paco7_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco7_2_0_unfold: forall (MON: monotone7_2 gf_0) (MON: monotone7_2 gf_1) r_0 r_1,
  paco7_2_0 gf_0 gf_1 r_0 r_1 <7= gf_0 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone7_2; intros; destruct PR; eauto. Qed.

Theorem paco7_2_1_unfold: forall (MON: monotone7_2 gf_0) (MON: monotone7_2 gf_1) r_0 r_1,
  paco7_2_1 gf_0 gf_1 r_0 r_1 <7= gf_1 (upaco7_2_0 gf_0 gf_1 r_0 r_1) (upaco7_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone7_2; intros; destruct PR; eauto. Qed.

End Arg7_2.

Hint Unfold monotone7_2.
Hint Resolve paco7_2_0_fold.
Hint Resolve paco7_2_1_fold.

Arguments paco7_2_0_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_0_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_0_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_0_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_2_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].

Instance paco7_2_0_inst  T0 T1 T2 T3 T4 T5 T6 (gf_0 gf_1 : rel7 T0 T1 T2 T3 T4 T5 T6->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_2_0_acc gf_0 gf_1;
  pacomult   := paco7_2_0_mult gf_0 gf_1;
  pacofold   := paco7_2_0_fold gf_0 gf_1;
  pacounfold := paco7_2_0_unfold gf_0 gf_1 }.

Instance paco7_2_1_inst  T0 T1 T2 T3 T4 T5 T6 (gf_0 gf_1 : rel7 T0 T1 T2 T3 T4 T5 T6->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_2_1_acc gf_0 gf_1;
  pacomult   := paco7_2_1_mult gf_0 gf_1;
  pacofold   := paco7_2_1_fold gf_0 gf_1;
  pacounfold := paco7_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg7_3.

Definition monotone7_3 T0 T1 T2 T3 T4 T5 T6 (gf: rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6) :=
  forall x0 x1 x2 x3 x4 x5 x6 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6) (LE_0: r_0 <7= r'_0)(LE_1: r_1 <7= r'_1)(LE_2: r_2 <7= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4 x5 x6.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable gf_0 gf_1 gf_2 : rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6 -> rel7 T0 T1 T2 T3 T4 T5 T6.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.
Arguments gf_2 : clear implicits.

Theorem paco7_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <7= paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco7_3_0 gf_0 gf_1 gf_2 (r_0 \7/ l) r_1 r_2 x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <7= paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco7_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \7/ l) r_2 x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <7= rr) (CIH: l <_paco_7= rr), l <_paco_7= paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <7= paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \7/ l) x0 x1 x2 x3 x4 x5 x6) by eauto.
  clear PR; repeat (try left; do 8 paco_revert; paco_cofix_auto).
Qed.

Theorem paco7_3_0_mon: monotone7_3 (paco7_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_3_1_mon: monotone7_3 (paco7_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_3_2_mon: monotone7_3 (paco7_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_3_0_mult_strong: forall r_0 r_1 r_2,
  paco7_3_0 gf_0 gf_1 gf_2 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_3_1_mult_strong: forall r_0 r_1 r_2,
  paco7_3_1 gf_0 gf_1 gf_2 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Theorem paco7_3_2_mult_strong: forall r_0 r_1 r_2,
  paco7_3_2 gf_0 gf_1 gf_2 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 8 paco_revert; paco_cofix_auto). Qed.

Corollary paco7_3_0_mult: forall r_0 r_1 r_2,
  paco7_3_0 gf_0 gf_1 gf_2 (paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco7_3_0_mult_strong, paco7_3_0_mon; eauto. Qed.

Corollary paco7_3_1_mult: forall r_0 r_1 r_2,
  paco7_3_1 gf_0 gf_1 gf_2 (paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco7_3_1_mult_strong, paco7_3_1_mon; eauto. Qed.

Corollary paco7_3_2_mult: forall r_0 r_1 r_2,
  paco7_3_2 gf_0 gf_1 gf_2 (paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco7_3_2_mult_strong, paco7_3_2_mon; eauto. Qed.

Theorem paco7_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco7_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco7_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <7= paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco7_3_0_unfold: forall (MON: monotone7_3 gf_0) (MON: monotone7_3 gf_1) (MON: monotone7_3 gf_2) r_0 r_1 r_2,
  paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <7= gf_0 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone7_3; intros; destruct PR; eauto. Qed.

Theorem paco7_3_1_unfold: forall (MON: monotone7_3 gf_0) (MON: monotone7_3 gf_1) (MON: monotone7_3 gf_2) r_0 r_1 r_2,
  paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <7= gf_1 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone7_3; intros; destruct PR; eauto. Qed.

Theorem paco7_3_2_unfold: forall (MON: monotone7_3 gf_0) (MON: monotone7_3 gf_1) (MON: monotone7_3 gf_2) r_0 r_1 r_2,
  paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <7= gf_2 (upaco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone7_3; intros; destruct PR; eauto. Qed.

End Arg7_3.

Hint Unfold monotone7_3.
Hint Resolve paco7_3_0_fold.
Hint Resolve paco7_3_1_fold.
Hint Resolve paco7_3_2_fold.

Arguments paco7_3_0_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_acc            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_0_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_mon            [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_0_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_mult           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_0_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_fold           [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].
Arguments paco7_3_2_unfold         [ T0 T1 T2 T3 T4 T5 T6 ].

Instance paco7_3_0_inst  T0 T1 T2 T3 T4 T5 T6 (gf_0 gf_1 gf_2 : rel7 T0 T1 T2 T3 T4 T5 T6->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco7_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco7_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco7_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco7_3_1_inst  T0 T1 T2 T3 T4 T5 T6 (gf_0 gf_1 gf_2 : rel7 T0 T1 T2 T3 T4 T5 T6->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco7_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco7_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco7_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco7_3_2_inst  T0 T1 T2 T3 T4 T5 T6 (gf_0 gf_1 gf_2 : rel7 T0 T1 T2 T3 T4 T5 T6->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 : paco_class (paco7_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6) :=
{ pacoacc    := paco7_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco7_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco7_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco7_3_2_unfold gf_0 gf_1 gf_2 }.


CoInductive cotrue : Set :=
| d : cotrue -> cotrue.

Axiom loop : cotrue -> cotrue -> cotrue.

Lemma test : cotrue.
Proof.
  refine (cofix x (a : cotrue) : cotrue := (d (loop (d (x a)) (d (x a))))).
Defined.


(* =========================================================== *)
(* Static interpretation relation and the proof of termination *)
(* (the normalisation part of the Proposition 6.1)             *)
(* =========================================================== *)

Require Import String.
Require Import Vector.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Wf Coq.Program.Program Coq.Program.Tactics.
Require Import ProofIrrelevance FunctionalExtensionality.

Require Import Basics.
Require Import Syntax.
Require Import SemObjects.
Require Import Target.
Require Import IntObjects.
Require Import ElabCore.
Require Import MiniElab.
Require Import CpdtTactics.
Require Import CompCore.
Require Import CustomTactics.

Require Import NomEnv.

Import PermIEnvLabel.

Open Scope IEnv_scope.

(* -------------------------------------------------------------------- *)
(* Static interpretation rules for modules expressions and declarations *)
(* -------------------------------------------------------------------- *)

(* Some issues related to bound variables are left for further development *)
Inductive Mexp_int : IEnv -> mexp -> TSet -> IMod -> c -> Prop :=
| Bra_mexp_int : forall IE mdec N IE' c,
    Mdec_int IE mdec N IE' c ->
    Mexp_int IE (Bra_mexp mdec) N (INonParamMod IE') c
| Mid_mexp_int : forall IE mid IM,
    lookMidIE mid IE = Some IM ->
    Mexp_int IE (Mid_mexp mid) emptyTSet IM Emp_c
| Prj_mexp_int : forall IE mexp mid N c IE' IM,
    Mexp_int IE mexp N (INonParamMod IE') c ->
    lookMidIE mid IE' = Some IM ->
    Mexp_int IE (Prj_mexp mexp mid) N IM c
| Funct_mexp_int : forall IE0 mid mty mexp E0 M E,
    erasure_IEnv IE0 E0 ->
    Mty_melab E0 mty (MSigma emptyTSet (NonParamMod E)) ->
    Mexp_melab (addEnvMid mid (NonParamMod E) E0) mexp emptyTSet M ->
    Mexp_int IE0 (Funct_mexp mid mty mexp)
             emptyTSet (IFtor IE0 emptyTSet E (MSigma emptyTSet M) mid mexp) Emp_c
| App_mexp_int : forall IE0 longmid mexp mexp' IE IE' IE'' IE''' N N' c c' E' E'' mid,
    lookLongIMid longmid IE = Some (IFtor IE0 emptyTSet E' (MSigma emptyTSet (NonParamMod E'')) mid mexp') ->
    Mexp_int IE mexp N (INonParamMod IE') c ->
    filtering_IEnv IE' E' IE'' ->
    Mexp_int (addIEnvMid mid (INonParamMod IE'') IE0) mexp' N' IE''' c' ->
    Mexp_int IE (App_mexp longmid mexp) (unionTSet N N') IE''' (Seq_c c c')
with Mdec_int : IEnv -> mdec -> TSet -> IEnv -> c -> Prop :=
| Dec_mdec_int : forall IE dec N IE' c,
    Dec_comp IE dec N IE' c ->
    Mdec_int IE (Dec_mdec dec) N IE' c
| Type_mdec_int : forall IE tid ty Ty E,
    erasure_IEnv IE E ->
    Ty_elab E ty Ty ->
    Mdec_int IE (Type_mdec tid ty) emptyTSet (addIEnvTid tid Ty emptyIEnv) Emp_c
| Mod_mdec_int : forall IE mid mexp N IM c,
    Mexp_int IE mexp N IM c ->
    Mdec_int IE (Mod_mdec mid mexp) N (addIEnvMid mid IM emptyIEnv) c
| ModTyp_mdec_int : forall E IE mtid mty S,
    Mty_melab E mty S ->
    erasure_IEnv IE E ->
    Mdec_int IE (ModTyp_mdec mtid mty) emptyTSet (addIEnvTmid mtid S emptyIEnv) Emp_c
| Open_mdec_int : forall IE mexp N IE' c,
    Mexp_int IE mexp N (INonParamMod IE') c ->
    Mdec_int IE (Open_mdec mexp) N IE' c
| Seq_mdec_int : forall IE mdec1 mdec2 N1 N2 IE1 IE2 c1 c2,
    Mdec_int IE mdec1 N1 IE1 c1 ->
    Mdec_int (plusIEnvIEnv IE IE1) mdec2 N2 IE2 c2 ->
    (* (N1 # N2)%S -> *)
    (* (N1 # .fvs E)%S -> *)
    Mdec_int IE (Seq_mdec mdec1 mdec2) (unionTSet N1 N2) (plusIEnvIEnv IE1 IE2) (Seq_c c1 c2)
| IEmp_mdec_int : forall IE,
    Mdec_int IE Emp_mdec emptyTSet emptyIEnv Emp_c.

Scheme int_mexp_mut :=
  Induction for Mexp_int Sort Prop
  with int_mdec_mut := Induction for Mdec_int Sort Prop.

Combined Scheme int_mut from int_mexp_mut, int_mdec_mut.

Hint Resolve erasure_IEnv_tid_extend erasure_IEnv_tid_extend erasure_IEnv_empty.

Import EnvMod.

(* ----------------------------------------------------------- *)
(* Consistency relation between elaboration environments and   *)
(* interpretation environments.                                *)
(* ----------------------------------------------------------- *)

Definition consistent_IVEnv (VE:VEnv) (IVE:IVEnv) : Prop :=
   forall k t, (forall l, look k IVE = Some (l,t) -> look k VE = Some t) /\
               (look k VE = Some t -> exists l, look k IVE = Some (l,t)).

Notation Vec := Vector.t.
Import VectorNotations.
Module VE := EnvMod.VecEnv.

Local Coercion _to {A} := SemObjects.EnvMod.VecEnv._to (A:=A).
Local Coercion _from {A} := SemObjects.EnvMod.VecEnv._from (A:=A).

(** Consistency logical relation is defined by mutual recursion on
    the structure of the elaboration environments (semantic objects) *)
Fixpoint consistent_IEnv (E:Env) (IE:IEnv) : Prop :=
  match E, IE with
    EnvCtr TE VE ME MTE, IEnvCtr TE' IVE IME MTE' =>
    TE = TE' /\ consistent_IVEnv VE IVE /\ consistent_IMEnv ME IME /\ MTE = MTE'
  end
with consistent_IMEnv (ME:MEnv) (IME:IMEnv) : Prop :=
  match ME, IME with
    MEnvCtr me, IMEnvCtr ime =>
    dom (SemObjects.VE._to me) = dom (SemObjects.VE._to ime) /\
    match me,ime with
      (* NOTE : instead of forcing two vectors to be of the same length we
         just return False in case if vectors are not aligned *)
      VecEnv.mkVecEnv _  nn (exist _ ks _) vs,
      VecEnv.mkVecEnv _  nn' (exist _ ks' _) vs' =>
      (* We would like to use [VecEnv.Foralls.Forall2_fix consistent_IMod nn nn' vs vs']
         here, but unfortunately, this doesn't work in this situation.
         Probably, Coq doesn't unfold [Forall2_fix] here to see, that the
         argument is decreasing. Though, sometimes Coq does that, see
         definition of [ntsize] in Section 2.8 of CPDT *)
      (fix con_step {n n'} (l : Vec Mod n) (ll : Vec IMod n') : Prop :=
         match l,ll with
         | [],[] => True
         | m :: tl, im :: tl'  =>
           con_step tl tl' /\  consistent_IMod m im
         | _,_ => False
         end) nn nn' vs vs'
    end
  end
with consistent_IMod (M:Mod) (IM:IMod) : Prop :=
  match M with
    NonParamMod E =>
    match IM with
      INonParamMod IE => consistent_IEnv E IE
    | IFtor _ _ _ _ _ _ => False
    end
  | Ftor T0 E (MSigma T M) =>
    exists IE0 mid mexp,
    IM = IFtor IE0 T0 E (MSigma T M) mid mexp
    /\ forall IE, consistent_IEnv E IE ->
                  exists N IM c,
                    (Mexp_int (addIEnvMid mid (INonParamMod IE) IE0) mexp N IM c
                     /\ consistent_IMod M IM)
  end.

Import VecEnv.Foralls.

(* ----------------------- *)
(* Facts about consistency *)
(* ----------------------- *)

Lemma consistent_look_mid': forall mid IME ME M,
    consistent_IMEnv ME IME ->
    (lookMid mid ME = Some M) ->
    exists IM, lookIMid mid IME = Some IM /\ consistent_IMod M IM.
Proof.
  intros until M. intros Hcim Hmid. destruct ME, IME. simpl in *.
  destruct v0. destruct v.
  destruct keys,keys0. simpl in *.
  unfold dom,En.elements,En.Raw.elements in Hcim. simpl in *.
  generalize dependent x.  generalize dependent vals.
  generalize dependent v_size. generalize dependent v_size0.
  induction vals0; intros; dependent destruction x0.
  - crush. tryfalse.
  - destruct vals; dependent destruction x.
    + simpl in *. destruct Hcim. tryfalse.
    + destruct Hcim as [Hdom Tl]. destruct Tl as [Heq Hcm].
      unfold look,En.find in *. simpl in *.
      inversion Hdom. subst.
      remember (Key.compare mid h2) as mid_comp.
      destruct mid_comp.
      * tryfalse.
      * inversion Hmid. subst.
        exists h1;crush.
      * inversion v0. dependent destruction H2.
        inversion v. dependent destruction H2.
        apply IHvals0 with (x0:=x0); auto.
Qed.

Lemma consistent_look_mid: forall IE E M mid,
    consistent_IEnv E IE ->
    (lookMidE mid E = Some M) ->
    exists IM, lookMidIE mid IE = Some IM /\ consistent_IMod M IM.
Proof.
  intros.
  destruct E,IE. simpl in *.
  destruct H as [Heq Tl]. destruct Tl as [Hciv Tl]. destruct Tl as [Hcm Hmeq]. subst.
  eapply consistent_look_mid'; eauto.
Qed.

Lemma consistent_look_longvid: forall IE E t longvid,
    consistent_IEnv E IE ->
    (lookLongVid longvid E = Some t) ->
    exists l, lookLongIVid longvid IE = Some (l,t).
Proof.
  intros.
  generalize dependent IE. generalize dependent E.
  induction longvid.
  - intros. unfold consistent_IEnv in H. destruct E. destruct IE.
    destruct H as [eq H]. destruct H as [H2 x].
    clear x. unfold consistent_IVEnv in H2. subst.
    rename t1 into s.
    rename t0 into t.
    assert (H2':=H2 s t). destruct H2'. clear H.
    crush.
  - intros. simpl in *.
    destruct E, IE. simpl in *.
    rename t1 into s.
    remember (lookMid s m) as opt_mod. destruct opt_mod as [mod | ];tryfalse.
    destruct mod; tryfalse.
    destruct H as [Heqt tl]. destruct tl as [Hciv tl]. destruct tl as [Hcim Heqm]. subst.
    symmetry in Heqopt_mod.
    assert (H' : exists IM, lookIMid s i0 = Some IM /\ consistent_IMod (NonParamMod e) IM).
    intros. eapply consistent_look_mid'; eauto.
    destruct H' as [IM Hc]. destruct Hc as [Hmid Hcmod]. rewrite Hmid. destruct IM;tryfalse.
    simpl in Hcmod.
    eapply IHlongvid;eauto.
Qed.

Lemma consistent_look_longmid: forall IE E M longmid,
    consistent_IEnv E IE ->
    (lookLongMid longmid E = Some M) ->
    exists IM, lookLongIMid longmid IE = Some IM /\ consistent_IMod M IM.
Proof.
  intros.
  generalize dependent E. generalize dependent IE.
  induction longmid.
  - intros.
    destruct E. destruct IE. simpl in *.
    destruct H as [Heqt H]. destruct H as [H2 x].
    destruct x as [Hcim Heqm].
    eapply consistent_look_mid';eauto.
  - intros. simpl in *.
    destruct E. destruct IE. simpl in *.
    destruct H as [Heqt H]. destruct H as [H2 x].
    destruct x as [Hcim Heqm]. subst.
    destruct (lookMid t0 m) eqn:Hlook; tryfalse. destruct m0;tryfalse.
    assert (H' : exists IM, lookIMid t0 i0 = Some IM /\ consistent_IMod (NonParamMod e) IM).
    eapply consistent_look_mid'; eauto.
    destruct H' as [IM Hc]. destruct Hc as [Hmid Hcmod]. rewrite Hmid. destruct IM;tryfalse.
    eapply IHlongmid;eauto.
Qed.

Lemma consistent_IEnv_extend: forall IE E t l s,
  consistent_IEnv E IE -> consistent_IEnv (addEnvVid s t E) (addIEnvVid s (l,t) IE).
Proof.
  intros.
  destruct E,IE. crush.
  destruct v,i; simpl in *. unfold consistent_IVEnv in *.
  intros. split.
  + intros l0 H0. unfold look in *.
    rewrite FM.P.F.add_o in H0.
    destruct (FM.P.F.eq_dec s k).
    * inversion H0. subst.
      apply add_lookup.
    * destruct (H k t1) as [Hl Hr].
      rewrite FM.P.F.add_neq_o;auto. eapply Hl;eauto.
  + rewrite FM.P.F.add_o.
    destruct (FM.P.F.eq_dec s k).
    * exists l. subst. rewrite add_lookup in *. inversion H0.
      subst. reflexivity.
    * intros H'. unfold look in *. destruct (H k t1) as [Hl Hr].
       rewrite FM.P.F.add_neq_o;auto.
Qed.

Lemma consistent_IEnv_tid_extend: forall IE E t s,
  consistent_IEnv E IE -> consistent_IEnv (addEnvTid s t E) (addIEnvTid s t IE).
Proof.
  intros.
  destruct E,IE. crush.
Qed.

Lemma consistent_IEnv_mtid_extend: forall IE E t s,
  consistent_IEnv E IE -> consistent_IEnv (addEnvMtid s t E) (addIEnvTmid s t IE).
Proof.
  intros.
  destruct E,IE. crush.
Qed.

Set Printing Coercions.

(* NOTE : We prevent functions back and forth between environment the representations
   from unfolding and try just to use the fact that it is an isomorphism *)
Arguments SemObjects.VE._from A oe : simpl never.
Arguments SemObjects.VE._to A ve : simpl never.
Arguments SemObjects.VE.fromOrdEnv A oe : simpl never.
Arguments SemObjects.VE.toOrdEnv A ve : simpl never.

Lemma consistent_IEnv_mid_extend: forall IE E M IM s,
    consistent_IEnv E IE -> consistent_IMod M IM ->
    consistent_IEnv (addEnvMid s M E) (addIEnvMid s IM IE).
Proof.
  intros.
  destruct E,IE. destruct m,i0. simpl in *.
  destruct H as [Ht Htl]. destruct Htl as [Hc Htl].
  destruct Htl as [Ht' Htl'].
  rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in *.
  rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in *.
  (* NOTE : here we use an alternative variant of Lemma ForallEnv2_fold_unfold,
     because pattern-matching gets reduced. *)
  erewrite <- (ForallEnv2_fold_unfold' consistent_IMod);eauto.
  rewrite SemObjects.VE.Foralls.ForallEnv2_fix_EnvRel_iff in *;auto.
  rewrite SemObjects.VE.Foralls.ForallEnv2_fix_EnvRel_iff';eauto; try reflexivity.
  intuition;auto.
  repeat (rewrite VecEnv.toOrdEnv_fromOrdEnv_inv).
  unfold EnvRel.
  intuition;subst;simpl in *.
  + inversion Ht'. destruct (H1 k) as [L R].
    rewrite FM.P.F.add_in_iff in *. intuition;auto.
  + inversion Ht'. destruct (H1 k) as [L R].
    rewrite FM.P.F.add_in_iff in *. intuition;auto.
  + inversion Ht'.
    rename s into k'.
    rewrite FM.P.F.add_o in *.
    destruct (FM.P.F.eq_dec k' k).
    * assert (M = v2) by congruence. assert (IM = v') by congruence. subst. assumption.
    * apply (H3 k);auto.
Qed.

Lemma consistent_IEnv_empty: consistent_IEnv emptyEnv emptyIEnv.
Proof.
  constructor. constructor. split.
  - unfold consistent_IVEnv; crush;tryfalse.
  - crush. unfold emptyMTEnv. f_equal. unfold SemObjects.VE.ve_empty. compute. f_equal.
    f_equal. apply proof_irrelevance.
Qed.

Lemma consistent_IVEnv_plus e e' ie ie' :
  consistent_IVEnv e ie -> consistent_IVEnv e' ie'
  -> consistent_IVEnv (e ++ e') (ie ++ ie').
Proof.
  intros H1 H2.
  unfold consistent_IVEnv in *.
  split.
  + intros l Ht0.
    rewrite <- FM.P.F.find_mapsto_iff in *.
    rewrite FM.P.update_mapsto_iff in *.
    destruct Ht0.
    * destruct (H2 k t0). rewrite FM.P.F.find_mapsto_iff in *. left. eauto.
    * right. destruct H. split.
      ** destruct (H1 k t0). rewrite FM.P.F.find_mapsto_iff in *. eauto.
      ** unfold not. intro He'. apply H0.
         inversion He' as [v Hv].
         assert (Hv' : En.MapsTo k v e') by auto.
         rewrite FM.P.F.find_mapsto_iff in Hv'.
         destruct (H2 k v) as [L R].
         assert (Hex := R Hv'). destruct Hex as [l' Hlv].
         apply En.find_2 in Hlv. apply MapsTo_In in Hlv. assumption.
  + intros Ht0.
    rewrite <- FM.P.F.find_mapsto_iff in *.
    rewrite FM.P.update_mapsto_iff in *.
    destruct Ht0.
    * rewrite FM.P.F.find_mapsto_iff in *.
      destruct (H2 k t0) as [L R]. destruct (R H) as [l Hlt0].
      exists l.
      rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.update_mapsto_iff in *.
      left. auto.
    * destruct H as [He Hne'].
      rewrite FM.P.F.find_mapsto_iff in *.
      destruct (H1 k t0) as [L R]. destruct (R He) as [l Hlt0].
      exists l.
      rewrite <- FM.P.F.find_mapsto_iff in *.
      rewrite FM.P.update_mapsto_iff in *.
      right. split.
      ** assumption.
      ** unfold not. intro He'. apply Hne'.
         inversion He' as [v Hv].
         assert (Hv' : En.MapsTo k v ie') by auto.
         rewrite FM.P.F.find_mapsto_iff in Hv'.
         destruct v as [l' t'].
         destruct (H2 k t') as [L' R'].
         assert (Ht' := L' _ Hv').
         rewrite <- FM.P.F.find_mapsto_iff in Ht'. apply MapsTo_In in Ht'.
         assumption.
Qed.

Lemma consistent_IEnv_plus: forall IE1 E1 IE2 E2,
    consistent_IEnv E1 IE1 -> consistent_IEnv E2 IE2 ->
    consistent_IEnv (plusEnvEnv E1 E2) (plusIEnvIEnv IE1 IE2).
Proof.
  intros.
  destruct E1,IE1,E2,IE2. destruct m,m0,m2,m3,i0,m1,i2,m4. simpl in *.
  destruct H0 as [Ht Htl]. destruct Htl as [Hc Htl].
  destruct H as [Ht' Htl']. destruct Htl' as [Hc' Htl'].
  split. congruence.
  split. apply consistent_IVEnv_plus; auto.
  (* We are switching to the "extensional" representation to be able to
     use properties of environments in abstract way, without
     looking on the concrete representation *)
  rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in *.
  rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in *.
  rewrite ForallEnv2_fix_EnvRel_iff in *.
  repeat (rewrite VecEnv.toOrdEnv_fromOrdEnv_inv).
  (* ------------------------------------------------------ *)
  unfold EnvRel in *.
  intuition; subst.
  + inversion H0. inversion H2. subst. clear H0. clear H2.
    rewrite FM.P.update_in_iff in *.
    destruct H1.
    * left. rewrite <- H3. auto.
    * right. rewrite <- H. auto.
  + inversion H0. inversion H2. subst. clear H0. clear H2.
    rewrite FM.P.update_in_iff in *.
    destruct H1.
    * left. rewrite H3. auto.
    * right. rewrite H. auto.
  + inversion H0. inversion H2. subst. clear H0. clear H2.
    apply En.find_2 in H1. apply En.find_2 in H6.
    rewrite FM.P.update_mapsto_iff in *.
    destruct H1,H6.
    * apply (H5 k); apply En.find_1; assumption.
    * destruct H1. apply (H5 k).
      ** apply En.find_1. assumption.
      ** destruct (H k) as [L R].
         assert (H' := L (MapsTo_In H0)). exfalso. auto.
    * destruct H0. apply (H4 k).
      ** apply En.find_1. assumption.
      ** destruct (H k) as [L R].
         assert (H' := R (MapsTo_In H1)). exfalso. auto.
    * destruct H0,H1; apply (H4 k); auto.
  + inversion H0. inversion H2. subst. clear H0. clear H2. reflexivity.
Qed.

Lemma consistent_ienv_imod_lem : forall ie e,
    consistent_IEnv e ie -> consistent_IMod (NonParamMod e) (INonParamMod ie).
Proof.
  crush.
Qed.

Lemma consistent_imod_ienv_lem : forall ie e,
    consistent_IMod (NonParamMod e) (INonParamMod ie) -> consistent_IEnv e ie.
Proof.
  crush.
Qed.

Lemma consistent_imod_uniform : forall x E,
  consistent_IMod (NonParamMod E) x  -> exists IE, x = INonParamMod IE.
Proof.
  intros. destruct x; exists i; crush.
Qed.

Lemma consistent_imod_uniform_ftor : forall T IM E MS,
  consistent_IMod (Ftor T E MS) IM  -> exists IE T' E' MS' mid mexp, IM = IFtor IE T' E' MS' mid mexp.
Proof.
  intros. destruct IM.
  - destruct MS. simpl in *. do 4 destruct H. tryfalse.
  - destruct MS. simpl in *. do 4 destruct H. inversion H; subst. repeat eexists; eauto.
Qed.

Lemma EnvRel_unmatched_size {A B} (ve : VecEnv.VecEnv B) (P : A -> B -> Prop) :
  ve <> empty -> ~ EnvRel P empty ve.
Proof.
  intro Hneq.
  remember (_to ve) as E.
  destruct ve. destruct keys. simpl in *.
  unfold not. intro.
  destruct vals.
  * apply Hneq. f_equal. dependent destruction x. f_equal. apply proof_irrelevance.
  * unfold EnvRel in *. destruct H. dependent destruction x.
    destruct (H h) as [L R].
    assert (Hin : In B h E). subst. unfold In,En.In. simpl. unfold to_list.
    unfold En.Raw.PX.In. eexists. econstructor. eauto.
    assert (Hfail := R Hin). inversion Hfail as [a Hfail']. unfold empty in *. simpl in *.
    inversion Hfail'.
Qed.

Lemma Forall_look_nested_Forall2 {n A B} (vs : Vec A n) (vs' : Vec B n)
      (P : A -> B -> Prop) :
  Forall (fun v => Forall (P v) vs') vs ->
  Forall2 P vs vs'.
Proof.
  intro H.
    generalize dependent vs'.
    dependent induction vs.
    * dependent destruction vs'; constructor.
    * intros vs' H. dependent destruction vs'.
      constructor.
      ** inversion H. dependent destruction H2. inversion H3.
         *** subst. auto.
      ** apply IHvs. inversion H. dependent destruction H2.
         inversion H3. dependent destruction H2.
         eapply Forall_nested_cons. eauto.
Qed.

Lemma consistent_to_erasure : forall E IE,
    consistent_IEnv E IE -> erasure_IEnv IE E.
Proof.
  (* We do not introduce last hypothesis, otherwise
     application of the mutual induction principle fails *)
  intros E IE.
  (* It's important to keep E abstracted *)
  generalize dependent E.
  induction IE using IEnv_mut with
      (P0 := fun ime => forall me', consistent_IMEnv (MEnvCtr me') ime
                        -> erasure_IMEnv ime (MEnvCtr me'))
      (P1 := fun im => forall m, consistent_IMod m im ->
                 erasure_IMod im m); intro E.
  + crush. destruct E as [te ve me mte]. simpl in H. intuition. subst.
    destruct me. constructor; auto.
  + intro Hc.
    assert (Hc' := Hc). simpl in *.
    destruct Hc as [Hdom Hfix].
    assert (HH : EnvRel (fun (im : IMod) (m : Mod)  =>
                            consistent_IMod m im -> erasure_IMod im m)
           (_to t0) (_to E)).
    apply (Forall_EnvRel (eq_sym Hdom)).
    apply H.
    (*TODO: move rewrites below to a custom tactic *)
    rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in Hc'.
    rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in Hc'.
    rewrite ForallEnv2_fix_EnvRel_iff in Hc'.
    destruct t0. destruct E. destruct keys,keys0.
    constructor. simpl in *.
    destruct HH as [Hin He].
    split;auto.
    intros. apply He with (k:=k); auto.
    destruct Hc' as [Hin' Hcon]. apply Hcon with (k:=k); auto.
  + intros Hc. destruct E.
    * constructor. simpl in Hc. apply IHIE;auto.
    * simpl in *. destruct m. destruct Hc. destruct H. destruct H. destruct H. tryfalse.
  + intros Hc. destruct E.
    * tryfalse.
    * simpl in Hc. destruct m1.
      destruct Hc. destruct H. destruct H. destruct H.
      inversion H. subst. constructor.
Qed.

Lemma consistent_imod_uniform_ftor2 : forall T T' IM E M,
    consistent_IMod (Ftor T E (MSigma T' M)) IM ->
    exists IE mid mexp, IM = IFtor IE T E (MSigma T' M) mid mexp /\
                        forall IE',
                          consistent_IEnv E IE' ->
                          exists N IM' c, Mexp_int (addIEnvMid mid (INonParamMod IE') IE) mexp N IM' c /\
                                         consistent_IMod M IM'.
Proof.
  intros. simpl in *. do 4 destruct H. eauto.
Qed.

(** The filtering function satisfies the filtering relation, provided that
    environments are consistent *)
Lemma filt_IVEnv_fun_spec ive' ve' ve :
    consistent_IVEnv ve' ive' -> env_ext ve' ve ->
    filt_IVEnv ive' ve (filt_fun ive' ve).
Proof.
  intros Hc Hex.
  constructor.
  + unfold env_ext. intros e p H.
    apply En.find_1. apply En.find_2 in H. unfold filt_fun,restrict in H.
    apply FM.P.filter_iff in H; intuition.
  + constructor.
    * intros l H. apply En.find_1. apply En.find_2 in H. unfold filt_fun,restrict in H.
      apply FM.P.filter_iff in H; intuition.
      unfold consistent_IVEnv in Hc. unfold env_ext in *.
      destruct (Hc k t0) as [L R]. apply En.find_1 in H0.
      assert (HH := L l H0). apply En.find_2. apply En.mem_2 in H1.
      destruct H1 as [t1 Ht1]. apply En.find_1 in Ht1.
      assert (HH' := Hex _ _ Ht1).
      assert (t0 = t1) by congruence.
      subst. auto.
    * intro H.
      unfold consistent_IVEnv in Hc. unfold env_ext in *.
      destruct (Hc k t0) as [L R].
      assert (HH := R (Hex _ _ H)).
      destruct HH as [l Hl]. exists l.
      apply En.find_1. unfold filt_fun,restrict.
      rewrite FM.P.filter_iff;intuition. apply En.mem_1.
      apply En.find_2 in H. eapply MapsTo_In;eauto.
Qed.

Lemma env_ext_filt_fun_eq {A : Type} (e' e : AEnv A) :
  env_ext e' e -> filt_fun e' e = e.
Proof.
  intro H.
  unfold filt_fun,restrict. apply env_extensionality_alt.
  intros k v.
  split.
  + intros. apply En.find_2 in H0.
    rewrite FM.P.filter_iff in H0; intuition.
    apply En.mem_2 in H2.
    destruct H2 as [v1 Hv1]. apply En.find_1 in Hv1.
    assert (HH' := H _ _ Hv1).
    apply En.find_1 in H1. unfold look in *.
    assert (v = v1) by congruence;subst;auto.
  + intros Hl. apply En.find_1. rewrite FM.P.filter_iff; intuition.
    apply En.find_2 in Hl. apply En.mem_1. eapply MapsTo_In;eauto.
Qed.

Lemma filt_fun_env_ext {A B : Type} (e' : AEnv A) (e : AEnv B) :
  env_ext e' (filt_fun e' e).
Proof.
  unfold env_ext.
  intros k v Hv. unfold filt_fun,restrict in *. intros. apply En.find_2 in Hv.
  rewrite FM.P.filter_iff in Hv; intuition.
Qed.

Lemma filt_TEnv_fun_spec ite' te' :
  env_ext ite' te' ->
  filt_ITEnv ite' te' (filt_fun ite' te').
Proof.
  intros H.
  constructor.
  + unfold env_ext in *.
    intros k e Hl. apply En.find_1. apply En.find_2 in Hl. unfold filt_fun,restrict in Hl.
    apply FM.P.filter_iff in Hl; intuition.
  + apply env_ext_filt_fun_eq; auto.
Qed.

Definition restrict_map {A B} (f : A -> B -> A) (e : AEnv A) (e' : AEnv B) :=
  En.map2 (fun oe oe' =>
             match oe,oe' with
             | Some v, None => None
             | None, Some v => None
             | Some v, Some v' => Some (f v v')
             | None,None => None
             end)
          e e'.

(* Filtering relation, defined in more "algorithmic" style *)
Inductive flt_Env_rel : IEnv -> Env -> IEnv -> Prop :=
  flt_Env_r :
    forall TE' TE IVE VE IME' ME IME MTE,
      flt_IMEnv_rel IME' ME IME ->
      flt_Env_rel (IEnvCtr TE' IVE IME' MTE)
                  (EnvCtr TE VE ME  emptyMTEnv)
                  (IEnvCtr (filt_fun TE' TE) (filt_fun IVE VE) IME emptyMTEnv)
   with
   flt_IMEnv_rel : IMEnv -> MEnv -> IMEnv -> Prop :=
     flt_IMEnv_r : forall (ime' : VE.VecEnv IMod) (me : VE.VecEnv Mod) ime,
       RestrictionRel flt_IMod_rel (_to ime') (_to me) (_to ime) ->
       flt_IMEnv_rel (IMEnvCtr ime')
                     (MEnvCtr me)
                     (IMEnvCtr ime)
   with
   flt_IMod_rel :  IMod -> Mod -> IMod -> Prop :=
   | flt_IMod_nmp_r : forall ie' ie e,
       flt_Env_rel ie' e ie ->
       flt_IMod_rel (INonParamMod ie') (NonParamMod e) (INonParamMod ie)
   | flt_IMod_ftor_r : forall IE0 T E' E G G' mid mexp,
       E' = E ->
       G' = G ->
       (* enriches E' E -> *)
       (* enrichesModType G' G -> *)
       flt_IMod_rel (IFtor IE0 T E G' mid mexp) (Ftor T E' G) (IFtor IE0 T E' G mid mexp).

Scheme flt_mut :=
  Induction for flt_Env_rel Sort Prop
  with
    Induction for flt_IMEnv_rel Sort Prop
  with
    Induction for flt_IMod_rel Sort Prop.

Lemma flt_consistent ie' ie e' e :
  enriches e' e ->
  consistent_IEnv e' ie' ->
  flt_Env_rel ie' e ie ->
  consistent_IEnv e ie.
Proof.
  generalize dependent e. generalize dependent e'. generalize dependent ie.
  induction ie' using IEnv_mut
    with (P0 := fun ime' => forall me' me ime,
                    enrichesM me' me ->
                    consistent_IMEnv me' ime' ->
                    flt_IMEnv_rel ime' me ime ->
                    consistent_IMEnv me ime)
         (P1 := fun im' => forall m' m im,
                 enrichesMod m' m ->
                 consistent_IMod m' im' ->
                 flt_IMod_rel im' m im ->
                 consistent_IMod m im).
  + intros ie e' e Hen Hc.
    inversion Hen as [ve' ve te' te me' me mte' mte Hvext Htext Henm H2 H3]. subst.
    simpl in *. intuition. subst.
    rename t0 into te'. rename i into ive'. rename i0 into ime'.
    destruct ie.
    inversion_clear H.
    unfold consistent_IVEnv in H2.
    intuition.
    ** symmetry. apply env_ext_filt_fun_eq;auto.
    ** unfold consistent_IVEnv in *. intros.
       destruct (H2 k t1) as [Ht Hl].
         split.
         *** intros l Ht0. apply En.find_2 in Ht0.
             apply FM.P.filter_iff in Ht0. destruct Ht0.
             apply En.find_1 in H.
             assert (HH := Ht _ H). unfold env_ext in *.
             apply En.mem_2 in H3. destruct H3 as [t2 Ht2].
             apply En.find_1 in Ht2.
             assert (Ht1' := Hvext _ _ Ht2). assert (t1 = t2) by congruence. subst. auto.
             intuition.
         *** intros Ht0. assert (HH := Hl (Hvext _ _ Ht0)). destruct HH as [l Hl'].
             exists l. apply En.find_1. unfold filt_fun,restrict. rewrite FM.P.filter_iff.
             split. apply En.find_2. assumption. apply En.mem_1. eapply MapsTo_In;eauto.
             intuition.
    ** eapply IHie';eauto.
  + intros me0' me0 ime0 Hen Hc Hflt.
    inversion Hen as [me' me Hdom He Heq0 Heq1]. subst.
    rename t0 into ime'. simpl in *.
    rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in *.
    rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in *.
    rewrite ForallEnv2_fix_EnvRel_iff in *.
    inversion_clear Hc as [Hd Hcim].
    destruct ime0. inversion_clear Hflt as [? ? ? Hr].
    split.
    ** rewrite dom_extensionality in Hd. unfold _to in Hdom.
       eapply RestrictionRel_dom_eq; eauto.
       eapply domain_eq_r;eauto.
    ** rewrite <- (ForallEnv2_fold_unfold consistent_IMod).
       rename v into ime.
       assert (Hfa : dom (_to me) = dom ime /\
                     ForallEnv2_fix consistent_IMod me ime).
       rewrite ForallEnv2_fix_EnvRel_iff.
       unfold EnvRel.
       split.
       *** intros k'. apply dom_extensionality.
           rewrite dom_extensionality in Hd. unfold _to in Hdom.
           eapply RestrictionRel_dom_eq; eauto.
           eapply domain_eq_r;eauto.
       *** intros k v v' Hv Hv'.
           assert (HH : exists v v'',
                      look k ime' = Some v'' /\ look k me = Some v /\ flt_IMod_rel v'' v v') by
               (apply (RestrictionRel_spec Hr Hv');auto).
           destruct HH as [v0 Htmp]. destruct Htmp as [v'' Htmp].
           destruct Htmp as [Hv'' Htmp]. destruct Htmp as [Hv0 Hflt].
           unfold _to in *.
           assert (v = v0) by congruence. subst.
           assert (Hin_me := MapsTo_In (En.find_2 Hv)).
           assert (Hin_me' := Hdom _ Hin_me).
           inversion Hin_me' as [m' Hm']. apply En.find_1 in Hm'.
           assert (H' := Forall_forall_vals H). simpl in *.
           eapply H';eauto.
       *** destruct Hfa. auto.
  + intros. destruct m;destruct m';  destruct im; inversion H1; inversion H; subst.
    simpl in *. eapply IHie'; eauto.
  + intros m' m'' im Hen Hc Hflt.
    destruct m';destruct m''; inversion_clear Hen; inversion Hflt; subst;tryfalse.
    simpl in *.  destruct m2. destruct Hc.
    do 3 destruct H. inversion_clear H.
    exists x,x0,x1.
    split;auto.
Qed.

Lemma flt_exists ie' e' e :
  enriches e' e ->
  consistent_IEnv e' ie' ->
  exists ie, flt_Env_rel ie' e ie.
Proof.
  generalize dependent e. generalize dependent e'.
  induction ie' using IEnv_mut
    with (P0 := fun ime' => forall me' me,
                    enrichesM me' me ->
                    consistent_IMEnv me' ime' ->
                    exists ime, flt_IMEnv_rel ime' me ime)
         (P1 := fun im' => forall m' m,
                 enrichesMod m' m ->
                 consistent_IMod m' im' ->
                 exists im, flt_IMod_rel im' m im).
  + intros e' e Hen Hc.
    inversion Hen as [ve' ve te' te me' me mte' mte Hvext Htext Henm H2 H3]. subst.
    simpl in *. intuition. subst.
    rename t0 into te'. rename i into ive'. rename i0 into ime'.
    destruct (IHie' _ _ Henm H0) as [ime Hime].
    exists (IEnvCtr (filt_fun te' te) (filt_fun ive' ve) ime emptyMTEnv).
    constructor;auto.
  + intros me0' me0 Hen Hc.
    inversion Hen as [me' me Hdom He Heq0 Heq1]. subst.
    rename t0 into ime'. simpl in *.
    rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in *.
    rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in *.
    rewrite ForallEnv2_fix_EnvRel_iff in *.
    inversion Hc as [Hd Hcim].

    assert (Hex : exists ime, RestrictionRel flt_IMod_rel (_to ime') (_to me) ime).
    assert (H' := Forall_forall_vals H). simpl in *.
    apply RestrictionRel_exists. intros v k Hv v' Hv'.
    assert (Hin_me := MapsTo_In (En.find_2 Hv)).
    assert (Hin_me' := Hdom _ Hin_me).
    inversion Hin_me' as [m' Hm']. apply En.find_1 in Hm'.
    eapply (H' k _ Hv' m');eauto.

    destruct Hex as [ime Hime]. exists (IMEnvCtr (_from ime)).
    constructor. rewrite VE.toOrdEnv_fromOrdEnv_inv. assumption.
  + intros. destruct m;destruct m'; inversion H; subst.
    * simpl in *. destruct (IHie' _ e H3 H0) as [ie Hie].
      exists (INonParamMod ie). constructor. assumption.
    * simpl in *. destruct m. do 4 destruct H0.
      inversion H0.
  + intros m' m'' Hen Hc.
    destruct m';destruct m''; inversion Hen; tryfalse. subst.
    simpl in *. destruct m2. destruct Hc.
    inversion Hen. subst.
    do 3 destruct H. inversion_clear H.
    exists (IFtor x t2 e1 (MSigma t1 m1) x0 x1).
    apply flt_IMod_ftor_r;auto.
Qed.

(* NOTE : That's how the function, implementing filtering could look like. *)
(* Of course, this implementation doesn't work, because Coq's restriction on fixpoint. *)
(* [Program] tactic doesn't help here, because measure cannot be used with the mutual definitions *)

(* Program Fixpoint flt_Env_fun (ie : IEnv) (e : Env) {measure env_measure}: IEnv := *)
(*   match ie,e with *)
(*     IEnvCtr TE' IVE IME MTE', EnvCtr TE VE ME MTE => *)
(*     IEnvCtr (filt_fun TE' TE) (filt_fun IVE VE) (flt_IMEnv_fun IME ME) MTE *)
(*   end *)
(* with *)
(* flt_IMEnv_fun (ime' : IMEnv) (me : MEnv) := *)
(*   match ime', me with *)
(*   | IMEnvCtr ve', MEnvCtr ve => *)
(*     IMEnvCtr (restrict_map flt_IMod_fun (_to ve') (_to ve)) *)
(*   end *)
(* with *)
(* flt_IMod_fun (im' : IMod) (m : Mod) : IMod := *)
(*   match im',m with *)
(*   | INonParamMod ie, NonParamMod e => INonParamMod (flt_Env_fun ie e) *)
(*   | IFtor IE0 T E G mid mexp, Ftor T' E' G' => IFtor IE0 T E G mid mexp *)
(*   | IFtor IE0 T E G mid mexp, NonParamMod e => im' *)
(*   | INonParamMod ie, Ftor T' E' G' => im' *)
(*   end. *)

Definition filt_IMEnv_fun (ime' : IMEnv) (me : MEnv) :=
  match ime', me with
  | IMEnvCtr ve', MEnvCtr ve => IMEnvCtr (restrict (_to ve') (_to ve))
  end.

Definition filt_IEnv (ie : IEnv) (e : Env) :=
  match ie,e with
    IEnvCtr TE' IVE IME MTE', EnvCtr TE VE ME MTE =>
    IEnvCtr (filt_fun TE' TE) (filt_fun IVE VE) (filt_IMEnv_fun IME ME) (MTE')
  end.

Lemma flt_Env_rel_to_filtering_IEnv ie' e' e ie :
  enriches e' e ->
  consistent_IEnv e' ie' ->
  flt_Env_rel ie' e ie -> filtering_IEnv ie' e ie.
Proof.
 revert ie. revert e. revert e'.
 induction ie' using IEnv_mut with
      (P0 := fun ime' => forall me ime me',
               enrichesM me' me ->
               consistent_IMEnv me' ime' ->
               flt_IMEnv_rel ime' me ime ->
               filtering_IMEnv ime' me ime)
      (P1 := fun im' => forall m im m',
               enrichesMod m' m ->
               consistent_IMod m' im' ->
               flt_IMod_rel im' m im ->
               filtering_IMod im' m im).
 + intros e' e ie He Hc Hflt. destruct e',ie,e; simpl in *; inversion He; intuition; subst.
   inversion_clear Hflt.
   constructor.
   * eapply filt_IVEnv_fun_spec;eauto.
   * eapply filt_TEnv_fun_spec;eauto.
   * eapply IHie';eauto.
 + intros me ime me' He Hc Hflt.
   destruct me',ime,me; inversion He; simpl in *. intuition; subst.
   inversion Hflt. subst.
   constructor.
   * eapply RestrictionRel_dom_subset;eauto.
   * symmetry. eapply RestrictionRel_dom_eq;eauto. eapply domain_eq_r; eauto.
   * intros k im' m im Him' Hm Him.
     rename t0 into ime'. rename v1 into me. rename v0 into ime. rename v into me'.
     assert (HH : exists m0 im0',
                look k ime' = Some im0' /\ look k me = Some m0 /\ flt_IMod_rel im0' m0 im) by
         (apply (RestrictionRel_spec H7 Him);auto).
     destruct HH as [v0 Htmp]. destruct Htmp as [v'' Htmp].
     destruct Htmp as [Hv'' Htmp]. destruct Htmp as [Hv0 Hflt'].
     unfold _to in *.
     assert (v'' = im') by congruence.
     assert (v0 = m) by congruence. subst.
     eapply Forall_forall_vals in H;eauto.
     assert (Hem' : exists m', look k me' = Some m') by
         (apply En.find_2 in Hm; apply MapsTo_In in Hm; destruct (H2 _ Hm) as [m' Hm'];
          apply En.find_1 in Hm'; eexists;eauto).
     destruct Hem' as [m' Hm'].
     eapply H;eauto.
     rewrite <- (Forall2_fix_fold_unfold consistent_IMod) in *.
     rewrite <- (ForallEnv2_fold_unfold consistent_IMod) in *.
     assert (Hfa : EnvRel consistent_IMod me' ime') by
         (rewrite <- ForallEnv2_fix_EnvRel_iff; intuition).
     inversion Hfa as [Hdom Hcm]. eauto.
 + intros m im m' He Hc Hflt.
   destruct m,im,m'; inversion_clear Hflt; inversion_clear He.
   constructor. eauto.
 + rename m into t.
   intros m im m' He Hc Hflt.
   destruct m,im,m'; inversion_clear Hflt; inversion_clear He.
   constructor; eauto.
Qed.

Lemma consistent_enrich_to_filtering: forall E IE' E',
    enriches E' E ->
    consistent_IEnv E' IE' ->
    exists IE, filtering_IEnv IE' E IE /\ consistent_IEnv E IE.
Proof.
  intros e ie' e' He Hc.
  assert (Hie_ex : exists ie, flt_Env_rel ie' e ie) by (eapply flt_exists;eauto).
  destruct Hie_ex as [ie Hie].
  exists ie. split.
  + eapply flt_Env_rel_to_filtering_IEnv;eauto.
  + eapply flt_consistent;eauto.
Qed.

(* -------------------------------------- *)
(* Main proposition (see Proposition 6.1) *)
(* -------------------------------------- *)

Hint Resolve consistent_IEnv_extend consistent_IEnv_empty.

Lemma comp_consistent_dec: forall dec E E' IE,
    Dec_elab E dec E' -> consistent_IEnv E IE ->
    exists N IE' c, Dec_comp IE dec N IE' c  /\ consistent_IEnv E' IE'.
Proof.
  crush.
  pose (AtomN.Atom_inf (PermIEnvLabel.supp IE)) as fresh_l.
  destruct fresh_l as [l Hfresh].
  exists (addTSet l emptyTSet).

  inversion H. subst.
  apply consistent_to_erasure in H0.
  apply comp_exp with (IE := IE) in H1.
  - destruct H1. remember (Val_c l x) as c.
    exists (addIEnvVid v (l,t0) emptyIEnv). exists c.
    split.
    + remember (Val_dec v e) as dec.
      rename v into vid. rename x into ex. rename e into exp. subst dec c.
      clear H H0 E. constructor;auto.
    + apply consistent_IEnv_extend. apply consistent_IEnv_empty.
  - crush.
Qed.

Lemma interp :
  (forall E mexp T M,
      Mexp_melab E mexp T M -> forall IE,
      consistent_IEnv E IE ->
      exists N IM c, Mexp_int IE mexp N IM c /\ consistent_IMod M IM) /\
  (forall E mdec T E',
      Mdec_melab E mdec T E' -> forall IE,
      consistent_IEnv E IE ->
      exists N IE' c, Mdec_int IE mdec N IE' c /\ consistent_IEnv E' IE').
Proof.
  apply melab_mut; intros; tryfalse.
  - assert (H1 := H IE H0). crush. exists x. exists (INonParamMod x0). exists x1. split.
    + constructor; eauto.
    + auto.
  - exists emptyTSet. apply consistent_look_mid with (M:=M) (mid:=mid) in H; auto.
    destruct H. destruct H. exists x. exists Emp_c. split.
    + constructor. eauto.
    + assumption.
  - assert (H1:=H IE H0). clear H. destruct H1 as [N H1]. destruct H1. destruct H. destruct H.
    exists N. rename x0 into c. assert (H2:=H1). apply consistent_imod_uniform in H1. destruct H1. subst.
    apply consistent_imod_ienv_lem in H2.
    apply consistent_look_mid with (M:=M) (mid:=mid) in H2;auto.
    destruct H2. destruct H1. exists x. exists c. split.
    + clear E m e H0 E' H2 M. rename x into IM.
      rename x0 into IE'. apply Prj_mexp_int with (IE':=IE'); auto.
    + auto.
  - exists emptyTSet. exists (IFtor IE emptyTSet E (MSigma emptyTSet E') mid mexp). exists Emp_c.
    split.
    + apply consistent_to_erasure in H0. clear H. apply Funct_mexp_int with (E0:=E0); auto.
    + crush. exists IE. exists mid. exists mexp. split.
      * reflexivity.
      * intros IE' H1.
        apply consistent_IEnv_mid_extend
          with (M:=NonParamMod E) (IM:=INonParamMod IE') (s:=mid) (IE:=IE) (E:=E0)
                in H1.
        rename H into IH.
        apply IH;auto. auto.
  - remember (Ftor emptyTSet E' (MSigma emptyTSet (NonParamMod E''))) as M.
    assert (H1:=H0).
    apply consistent_look_longmid with (M:=M) (longmid:=longmid) in H0;auto.
    destruct H0 as [IM H0]. destruct H0.
    assert (H':=H IE H1).
    destruct H' as [N1 H']. destruct H' as [IM1 H']. destruct H' as [c1 H'].
    + subst M. assert (H3:=H2). apply consistent_imod_uniform_ftor2 in H2.
      destruct H2 as [IE1 H2]. destruct H2 as [mid H2]. destruct H2 as [mexp1 H2]. destruct H2.
      destruct H'. assert (H6':=H6). apply consistent_imod_uniform in H6.
      destruct H6 as [IE' HeqIE']. subst.
      apply consistent_imod_ienv_lem in H6'.
      apply consistent_enrich_to_filtering with (IE':=IE') in e0; auto.
      destruct e0 as [IE'' H2]. destruct H2 as [Hflt H6].
      assert (H4' := H4 IE'' H6).
      destruct H4' as [N2 H4']. destruct H4' as [IM2 H4']. destruct H4' as [c2 H4']. destruct H4'.
      exists (unionTSet N1 N2). exists IM2. exists (Seq_c c1 c2). split.
      * apply App_mexp_int with (IE0:=IE1) (mexp' := mexp1) (IE' := IE')
                                (IE'' := IE'') (E'' := E'') (E':=E') (mid:=mid); auto.
      * auto.
  - assert (H1:=H). apply consistent_to_erasure in H. apply comp_consistent_dec with (IE:=IE) in d; auto.
    + destruct d as [N H0]. destruct H0 as [IE' H0]. destruct H0 as [c H0].
      destruct H0 as [L R]. exists N. exists IE'. exists c. split.
      * constructor. auto.
      * auto.
  - exists emptyTSet. exists (addIEnvTid tid Ty emptyIEnv). exists Emp_c. split.
    + econstructor; eauto. apply consistent_to_erasure. auto.
    + apply consistent_IEnv_tid_extend. apply consistent_IEnv_empty.
  - assert (H':=H IE H0). destruct H' as [N H']. destruct H' as [IM H']. destruct H' as [c H']. destruct H' as [L R].
    exists N. exists (addIEnvMid mid IM emptyIEnv). exists c. split.
    + constructor; auto.
    + apply consistent_IEnv_mid_extend; auto.
  - exists emptyTSet, (addIEnvTmid mtid S emptyIEnv), Emp_c.
    split.
    + assert (He : erasure_IEnv IE E ) by (apply consistent_to_erasure;auto).
      apply ModTyp_mdec_int with (E:=E);auto.
    + apply consistent_IEnv_mtid_extend. apply consistent_IEnv_empty.
  - assert (H':=H IE H0). destruct H' as [N H']. destruct H' as [IM H']. destruct H' as [c H']. destruct H' as [L R].
    exists N.
    assert (R2:=R). apply consistent_imod_uniform in R. destruct R. subst.
    exists x. exists c. split.
    + constructor; auto.
    + apply consistent_imod_ienv_lem; auto.
  - assert (H':=H IE H1). destruct H' as [N1 H']. destruct H' as [IE1 H']. destruct H' as [c1 H'].
    destruct H' as [INT1 ERA1]. apply consistent_IEnv_plus with (IE2:=IE1) (E2:=E1) in H1; auto.
    assert (H0':=H0 (plusIEnvIEnv IE IE1) H1).
    destruct H0' as [N2 H0']. destruct H0' as [IE2 H0']. destruct H0' as [c2 H0'].
    destruct H0' as [INT2 ERA2].
    exists (unionTSet N1 N2). exists (plusIEnvIEnv IE1 IE2). exists (Seq_c c1 c2). split.
    + constructor; auto.
    + apply consistent_IEnv_plus; auto.
  - exists emptyTSet. exists emptyIEnv. exists Emp_c. split.
    + constructor; auto.
    + auto.
Qed.