(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

This file is the development of the proof of well-foundedness of the
higher-order recursive path ordering due to Jouannaud and Rubio.
*)

Set Implicit Arguments.

From CoLoR Require Import RelExtras ListExtras Horpo Computability PairLex
  HorpoComp LogicUtil.
From CoLoR Require SN.

Module HorpoWf (S : TermsSig.Signature)
               (Prec : Horpo.Precedence with Module S := S).

  Module Export HC := HorpoComp.HorpoComp S Prec.

  Lemma acc_mul_acc_wfmul_aux : forall (M: Multiset),
    Acc horpo_mul_lt M ->
    forall (WM: WFterms), M = WM -> Acc H_WFterms_lt WM.

  Proof.
    intros M AccM.
    apply Acc_ind with
      (R := MultisetLT horpo)
      (P := fun M => forall (WM: WFterms),
                       M = WFterms_to_mul WM -> Acc H_WFterms_lt WM).
    intros x acc_mul acc_WM WM x_WM.
    constructor.
    intros y y_lt_WM.
    apply acc_WM with (WFterms_to_mul y).
    rewrite x_WM.
    trivial.
    trivial.
    trivial.
  Qed.

  Lemma acc_mul_acc_wfterms : forall (WM: WFterms),
    Acc horpo_mul_lt WM -> Acc H_WFterms_lt WM.

  Proof.
    intros WM acc_WM.
    apply acc_mul_acc_wfmul_aux with (WFterms_to_mul WM); trivial.
  Qed.

  Lemma wf_MulLt_WFterms : well_founded H_WFterms_lt.

  Proof.
    unfold well_founded; intro W.
    destruct W as [Ts CompTs].
    apply acc_mul_acc_wfterms.
    unfold horpo_mul_lt; apply mOrd_acc.
    class.
    intros x x_comp.
    assert (xComp: CompH x).
    apply CompTs.
    destruct (member_multiset_list Ts x_comp).
    unfold eqA in H0; unfold TermsEqset.eqA in H0; rewrite H0; trivial.
    apply horpo_comp_imp_acc; trivial.
  Qed.

  Module H_WFmul_ord <: Ord.

    Module SetWF <: SetA.
      Definition A := WFterms.
    End SetWF.
    Module S := Eqset_def SetWF.
    Definition A := WFterms.
    Definition gtA := transp H_WFterms_lt.
    Definition gtA_eqA_compat := Eqset_def_gtA_eqA_compat gtA.

  End H_WFmul_ord.

  Module Lex := PairLex.LexicographicOrder Prec.P.O H_WFmul_ord.
  Import Lex.

  Lemma compTerms : forall M N Ns, M [>>] Ns -> CompTerms (appArgs M) ->
    (forall n, In n Ns -> subterm n N) ->
    (forall N', subterm N' N -> M >> N' -> CompH N') ->
    CompTerms Ns.

  Proof.
    intros M N Ns M_red_Ns argsMcomp Ns_sub_N IH.
    induction M_red_Ns as
      [ M
      | M Th Tt M_red_Th M_red_Tt IHargs
      | M Th Tt Marg_red_Th M_red_Tt IHargs
      ]; unfold CompTerms.
     (*     case: list of arguments of N empty *)
    intros x in_x_nil; absurd (In x nil); auto.
     (*     case: head of arguments of N has the same type as M *)
     (*           and horpo holds between M and head of N *)
    intros x x_Th_Tt; case x_Th_Tt; intro xT.
    rewrite <- xT.
    apply IH.
    apply Ns_sub_N; auto with datatypes.
    trivial.
    fold (In x Tt) in xT; apply IHargs; auto with datatypes.
     (*     case: head of arguments of N has different type than M *)
     (*           and horpo holds between some argument of M and   *)
     (*           head of N *)
    intros x x_Th_Tt; case x_Th_Tt; intro xT.
    rewrite <- xT.
    destruct Marg_red_Th as [M' M'arg M'_red_Th].
    destruct M'_red_Th as [M' Th M_red_Th | M'].
    unfold CompH; apply horpo_comp_step_comp with M'.
    apply argsMcomp; trivial.
    trivial.
    apply argsMcomp; trivial.
    fold (In x Tt) in xT; apply IHargs; auto with datatypes.
  Qed.

  Lemma arg_mul_arg : forall m M, m in (list2multiset (appArgs M)) -> isArg m M.

  Proof.
    intros m M m_in_M.
    destruct (member_multiset_list (appArgs M) m_in_M) as
      [m' m'_in_M m_m'].
    unfold eqA in m_m'; unfold TermsEqset.eqA in m_m'; rewrite m_m'; trivial.
  Qed.

  Lemma argsComp_appComp_aux :
    forall Px: pair,
      (forall Py: pair, Py <lex Px ->
	forall M, algebraic M -> term (appHead M) = ^fst Py ->
          appArgs M = proj1_sig (snd Py) -> CompH M) ->
    forall M N,
      algebraic M -> term (appHead M) = ^fst Px -> appArgs M = proj1_sig (snd Px) ->
      (forall N', subterm N' N -> M >> N' -> CompH N') ->
      M >> N -> CompH N.

  Proof.
    intros Px IH_out M N Mnorm Mhead Margs IH_in MN.
    destruct Px as [f fArgs]; simpl in * .
     (* 1) order by horpo *)
    destruct MN as [M N eqTypeMN eqEnvMN _ Nnorm horpoMN].
    destruct horpoMN as
      [ M N _ Msub
      | M N f' g Mhead' Nhead f'_gt_g Margs_gt_N
      | M N f' Mhead' Nhead argsM_mul_argsN
      | M N Ns Napp Ns_flat_N Margs_Ns
      | M N Mapp' Napp Mhead' Margs_mul_Nargs
      | M N Mabs Nabs _
      | M N MNbeta
      ].
     (* 1a) HSub *)
    destruct Msub as [M' M'arg M'_ge_N].
    assert (M'comp: CompH M').
    apply (proj2_sig fArgs); rewrite <- Margs; exact M'arg.
    destruct M'_ge_N as [M' N M'_N | M'].
    unfold CompH; apply horpo_comp_step_comp with M'; auto with horpo.
    trivial.
     (* 1b) HFun *)
     (*    all arguments of N computable *)
    assert (argsNcomp: CompTerms (appArgs N)).
    apply compTerms with M N; trivial.
    rewrite Margs; exact (proj2_sig fArgs).
    intros; apply appUnit_subterm; auto with terms.
    term_inv N.
    set (Nmul := exist argsNcomp).
     (*    so we can use outer induction hypothesis *)
    apply IH_out with (Py := (g, Nmul)); auto with terms.
    assert (ff': f = f'); [congruence | idtac].
    constructor 1; rewrite ff'; auto with terms.
     (* 1c) HMul *)
     (*    first show that all agrumens of N are computable *)
    inversion argsM_mul_argsN as [aM aN argsM_horpo_argsN aMdef aNdef].
    assert (argsNcomp: CompTerms (appArgs N)).
    unfold CompTerms; intros n n_arg_N.
    assert (n_in_N: n in (list2multiset (appArgs N))).
    apply member_list_multiset; trivial.
    destruct (mOrd_elts_ge argsM_horpo_argsN n_in_N)
       as [m m_in_M [m_gt_n | m_eq_n]].
     (*    for every argument of N, say n, we have argument of M *)
     (*    which:                                                *)
     (*    -/ either in one step rewrites by horpo to n          *)
    apply horpo_comp_step_comp with m.
    apply (proj2_sig fArgs); rewrite <- Margs.
    apply arg_mul_arg; trivial.
    trivial.
     (*    -/ or is equal to n *)
    unfold eqA in m_eq_n; unfold TermsEqset.eqA in m_eq_n; rewrite <- m_eq_n.
    apply (proj2_sig fArgs); rewrite <- Margs.
    apply arg_mul_arg; trivial.
     (*   now we prove the goal by outer induction hypothesis *)
    set (Nmul := exist argsNcomp).
    assert (NfApp: isFunApp N).
    unfold isFunApp;  apply funS_is_funS with f'; trivial.
    apply IH_out with (Py := (f', Nmul)); auto with terms.
    constructor 2.
    assert (ff': f = f'); [congruence | rewrite ff'; auto with sets].
    unfold H_WFmul_ord.gtA, H_WFterms_lt, WFterms_to_mul,
           horpo_mul_lt,  MultisetLT, transp.
    simpl; apply mOrd_inclusion with horpo.
    intros x y x_y; trivial.
    rewrite <- Margs; trivial.
     (* 1d) HAppFlat *)
    assert (Ns_comp: CompTerms Ns).
    apply compTerms with M N; trivial.
    rewrite Margs; exact (proj2_sig fArgs).
    intros; apply partialFlattening_subterm with Ns; trivial.
    unfold CompH; apply horpo_comp_pflat with Ns; trivial.
     (* 1e) HApp *)
    absurd (isFunApp M); eauto with terms.
     (* 1f) HAbs *)
    rewrite appHead_notApp in Mhead; term_inv M.
     (* 1g) HBeta *)
     (*    M & N are applications *)
    assert (Napp: isApp N).
    apply app_beta_isapp with M f; trivial.
    assert (Mapp: isApp M).
    term_inv M.
    apply beta_notFunS with Tr N; unfold Tr; auto with terms.
     (*    we show that all arguments of N accessible *)
    assert (NargsComp: CompTerms (appArgs N)).
    unfold CompTerms; intros P P_arg_N.
    case (app_beta_args_eq P Mapp MNbeta Mhead P_arg_N).
     (*    -/ because they are either arguments of original M *)
    intro Parg.
    apply (proj2_sig fArgs P).
    rewrite <- Margs; exact Parg.
     (*    -/ or they are result of internal beta reduction on *)
     (*       one of arguments of M *)
    destruct 1 as [Mb Mb_P M_Mb].
    unfold CompH; apply horpo_comp_step_comp with Mb.
    apply (proj2_sig fArgs); rewrite <- Margs; trivial.
    apply beta_imp_horpo; trivial.
    apply algebraic_arg with M; trivial.
     (* Finally we show that N' Computable using induction hypothesis *)
    set (Nmul := exist NargsComp).
    fold CompH;
      apply IH_out with (Py := (f, Nmul))(M := N);
      auto with terms.
     (* Lexicographic order holds on second coordinate *)
    constructor 2.
    auto with sets.
    destruct (app_beta_args Mapp MNbeta Mhead) as
      [[al ar] [[tl tr] [tlM [trN [tltr [Mb_args Nb_args]]]]]].
    unfold H_WFmul_ord.gtA, transp, H_WFterms_lt, horpo_mul_lt,
      MultisetLT, transp, WFterms_to_mul; simpl in * .
    rewrite <- Margs, Mb_args, Nb_args.
    apply mulOrd_oneElemDiff.
    apply horpo_eq_compat'.
    refl.
    apply beta_imp_horpo; trivial. apply algebraic_arg with M; trivial.
    apply app_beta_headSymbol with M; trivial.
  Qed.

  Lemma argsComp_appComp_ind : forall (P: pair) M,
    algebraic M -> term (appHead M) = Fun (fst P) ->
    appArgs M = proj1_sig (snd P) -> CompH M.

  Proof.
     (* induction on pair *)
    intro P.
    apply well_founded_ind with
      (R := LexProd_Lt)
      (P := fun (Px: pair) =>
         forall M,
	   algebraic M ->
           term (appHead M) = Fun (fst Px) ->
           appArgs M = proj1_sig (snd Px) ->
         CompH M).
    apply lexprod_wf.
    apply Prec.Ord_wf.
    apply wf_MulLt_WFterms.
    clear P.
    intros P IH_out M Mnorm Mhead Margs.
    assert (Mneutral: isNeutral M).
    term_inv M.
    rewrite_rl (horpo_neutral_comp_step Mnorm Mneutral).
    intros N; fold CompH.
    apply well_founded_ind with
      (R := subterm)
      (P := fun (N: Term) =>
         M >> N -> CompH N).
    apply subterm_wf.
    clear N.
    intros N IH_in M_red_N.
    apply argsComp_appComp_aux with P M; trivial.
  Qed.

  Lemma argsComp_appComp : forall M, algebraic M -> isFunS (appHead M) ->
    (forall P, isArg P M -> CompH P) -> CompH M.

  Proof.
    intros M Mnorm Mhead argsComp.
    set (Args := @exist _ (fun Ts: Terms => CompTerms Ts) _ argsComp).
    assert (Mf: exists f, term (appHead M) = ^f).
    set (MH := appHead M) in *.
    term_inv MH.
    exists f; trivial.
    destruct Mf as [f Mhead_f].
    apply argsComp_appComp_ind with (P := (f, Args))(M := M); trivial.
  Qed.

  Lemma subst_comp : forall M G (MG: correct_subst M G),
    algebraic M -> CompSubst G -> algebraicSubstitution G ->
    CompH (subst MG).

  Proof.
     (* induction on structure of Pt *)
    intro M.
    apply well_founded_ind with
      (R := subterm)
      (P := fun (M: Term) =>
         forall G (MG: correct_subst M G),
	   algebraic M ->
           CompSubst G ->
	   (forall i T, G |-> i/T -> algebraic T) ->
           CompH (subst MG)).
    apply subterm_wf.
    clear M; intros M IH G MG Mnorm Gcomp Gnorm.
    destruct M as [E Pt TM TypM]; simpl in * .
    destruct Pt as [?|?|A0 ?|??].
     (* variable *)
    assert (Mvar: isVar (buildT TypM)).
    dependent inversion TypM; simpl; trivial.
    destruct (var_subst MG) as [[T [p GpT MGterm]] | MG_M]; trivial.
     (*   - variable substituted *)
    apply horpo_comp_conv with T.
    apply Gcomp; trivial.
    apply nth_some_in with p; trivial.
    apply terms_conv_criterion; auto.
    apply env_comp_sym.
    apply subst_env_compat with p; trivial.
     (*   - variable not substituted *)
    apply horpo_var_comp; trivial.
    apply var_is_var with x; trivial.
     (* function symbol *)
    assert (termMG: term (subst MG) = term (buildT TypM)).
    apply funS_presubst.
    apply funS_is_funS with f; trivial.
    apply argsComp_appComp; term_inv (subst MG).
    apply funS_algebraic.
    simpl; inversion termMG.
    replace (f_type f) with (type (buildT TypM)).
    apply algebraic_funS; trivial.
    apply funS_is_funS with f; trivial.
    destruct TypM; try_solve.
    apply funS_is_funS with f; trivial.

     (* abstraction *)
    assert (Mabs: isAbs (buildT TypM)).
    apply abs_isAbs with A0 Pt; trivial.
    unfold CompH; apply horpo_comp_abs with (abs_subst_abs Mabs MG).
    apply algebraic_subst; trivial.
    intros S CS T TS Tcomp.
    destruct (abs_subst Mabs MG) as [MG_type MG_body].
    set (CS_Mbody := subst_abs_c Mabs MG).
    assert (CSj : correct_subst (absBody Mabs)
             (Some T :: lift_subst G 1)).
    rewrite MG_body in CS.
    apply subst_disjoint_c with (subst_abs_c Mabs MG); trivial.
    apply singleton_correct_single with S; trivial.
    assert (CS_all: correct_subst (subst CS_Mbody) S).
    rewrite MG_body in CS; trivial.
    assert (S_Sj: subst CS = subst CSj).
    rewrite (subst_eq CS CS_all); trivial.
    set (CS_all' := singleton_correct_single CS_all TS).
    rewrite <- (singleton_subst CS_all' CS_all TS).
    apply subst_disjoint.
    rewrite S_Sj.
    apply IH.
    apply absBody_subterm.
    apply algebraic_absBody; trivial.
    intros Q Qin.
    case (in_inv Qin).
    intro Q_P.
    inversion Q_P; rewrite <- H0; trivial.
    intro Q_G.
    destruct (in_lift_subst Q G 1 Q_G) as [W W_G Q_lift_W].
    rewrite Q_lift_W.
    unfold CompH; apply horpo_comp_lift.
    apply Gcomp; trivial.
    intros i W SW.
    destruct i.
    inversion SW.
    rewrite <- H0; apply horpo_comp_algebraic; trivial.
    inversion SW.
    destruct (var_subst_lift_rev G 1 H0) as [W' [GW' WW']].
    rewrite WW'.
    apply algebraic_lift.
    apply (Gnorm i); trivial.

     (* application *)
    set (M := buildT TypM) in * .
    assert (Mapp: isApp M).
    eapply app_isApp; simpl; trivial.
    destruct (app_subst Mapp MG) as [SL SR].
    destruct (isFunApp_dec M).

     (*   - function application *)
    apply argsComp_appComp.
    apply algebraic_subst; trivial.
    apply funS_head_subst; trivial.
    intros P Parg.
    destruct (list_In_nth (tail (appUnits (subst MG))) P Parg) as [p unit_p].
    assert (nth_error (appUnits (subst MG)) (S p) = Some P).
    destruct (appUnits (subst MG)); trivial.
    destruct p; try_solve.
    destruct (appUnits_subst_rev (S p) MG i H) as [P' [MP' PP']].
    rewrite PP'.
    assert (P'arg_aux: nth_error (tail (appUnits M)) p = Some P').
    inversion MP'.
    clear PP'; destruct (appUnits M); try_solve.
    assert (P'arg: isArg P' M).
    unfold isArg, appArgs.
    apply nth_some_in with p; trivial.
    apply IH; trivial.
    apply appUnit_subterm; trivial.
    apply appArg_is_appUnit; trivial.
    apply algebraic_arg with M; trivial.

     (*   - non-functional application *)
    unfold CompH; apply horpo_comp_app with (app_subst_app Mapp MG).
    rewrite SL.
    apply IH; trivial.
    apply appBodyL_subterm.
    apply algebraic_appBodyL; trivial.
    rewrite SR.
    apply IH; trivial.
    apply appBodyR_subterm.
    apply algebraic_appBodyR; trivial.
  Qed.

  Lemma horpo_beta_wf : forall M, algebraic M -> SN.SN horpo M.

  Proof.
    intros M Mnorm.
    apply SN.Acc_transp_SN.
    apply horpo_comp_imp_acc.
    assert (Mid_comp: CompH (subst (emptySubst_correct M))).
    apply subst_comp; trivial.
    red; contr.
    intros p T; destruct p; try_solve.
    rewrite <- (emptySubst_neutral (emptySubst_correct M)); trivial.
    apply emptySubst_empty.
  Qed.

End HorpoWf.


Require Import riscv.Proofs.DecodeEncodeProver.

Lemma decodeI_encode: forall (inst: InstructionI) (iset: InstructionSet),
    verify (IInstruction inst) iset ->
    decode iset (encode (IInstruction inst)) = IInstruction inst.
Proof. prove_decode_encode. Qed.


(*CompCert imports*)
Require Import AST.
Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import Axioms.
Require Import Globalenvs.

Require Import Extensionality.

Lemma Forall2_length {A B} {f:A -> B -> Prop} {l1 l2} (F:Forall2 f l1 l2): length l1 = length l2.
Proof. induction F; trivial. simpl; rewrite IHF. trivial. Qed.

Lemma Forall2_Zlength {A B} {f:A -> B -> Prop} {l1 l2} (F:Forall2 f l1 l2): Zlength l1 = Zlength l2.
Proof. do 2 rewrite Zlength_correct. rewrite (Forall2_length F). trivial. Qed.

Lemma pos_succ_plus_assoc: forall n m,
    (Pos.succ n + m = n + Pos.succ m)%positive.
Proof. intros.
  do 2 rewrite Pplus_one_succ_r;
           rewrite (Pos.add_comm m);
           rewrite Pos.add_assoc; trivial.
Qed.

Lemma mem_unchanged_on_sub: forall (P Q: block -> BinInt.Z -> Prop) m m',
  Mem.unchanged_on Q m m' ->
  (forall b ofs, P b ofs -> Q b ofs) ->
  Mem.unchanged_on P m m'.
Proof.
intros until m'; intros [H1 H2] H3.
split; intros.
solve[apply (H1 b ofs k p (H3 b ofs H)); auto].
solve[apply (H2 b ofs); auto].
Qed.

Lemma mem_unchanged_on_sub_strong: forall (P Q: block -> BinInt.Z -> Prop) m m',
  Mem.unchanged_on Q m m' ->
  (forall b ofs, Mem.valid_block m b -> P b ofs -> Q b ofs) ->
  Mem.unchanged_on P m m'.
Proof.
intros until m'; intros [H1 H2] H3.
split; intros.
solve[apply (H1 b ofs k p (H3 b ofs H0 H) H0)].
apply (H2 b ofs); auto. apply H3; auto.
solve[eapply Mem.perm_valid_block; eauto].
Qed.

Lemma inject_separated_same_meminj: forall j m m',
  Events.inject_separated j j m m'.
Proof. intros j m m' b; intros. congruence. Qed.

Theorem drop_extends:
  forall m1 m2 lo hi b p m1',
  Mem.extends m1 m2 ->
  Mem.drop_perm m1 b lo hi p = Some m1'  ->
  exists m2',
     Mem.drop_perm m2 b lo hi p = Some m2'
  /\ Mem.extends m1' m2'.
Proof.
  intros. inv H.
  destruct (Mem.drop_mapped_inj  _ _ _ b b 0 _ _ _ _ mext_inj H0) as [m2' [D Inj]].
        intros b'; intros. inv H1. inv H2. left. assumption.
         reflexivity.
  repeat rewrite Zplus_0_r in D. exists m2'. split; trivial.
  split; trivial.
  rewrite (Mem.nextblock_drop _ _ _ _ _ _ H0).
  rewrite (Mem.nextblock_drop _ _ _ _ _ _ D). assumption.
Qed.

Lemma mem_inj_id_trans: forall m1 m2 (Inj12: Mem.mem_inj inject_id m1 m2) m3
          (Inj23: Mem.mem_inj inject_id m2 m3),Mem.mem_inj inject_id m1 m3.
Proof. intros.
  destruct Inj12. rename mi_perm into perm12. rename mi_align into align12.
  rename mi_memval into memval12.
  destruct Inj23. rename mi_perm into perm23. rename mi_align into align23.
  rename mi_memval into memval23.
  split; intros.
  (*mi_perm*)
  apply (perm12 _ _ _ _  _ _ H) in H0.
  assert (inject_id b2 = Some (b2, delta)).
  unfold inject_id in *. inv H. trivial.
  apply (perm23 _ _ _ _  _ _ H1) in H0.  inv H. inv H1. rewrite Zplus_0_r in H0.
  assumption.
  (*mi_align*)
  apply (align12 _ _ _ _  _ _ H) in H0.
  assert (inject_id b2 = Some (b2, delta)).
  unfold inject_id in *. inv H. trivial. assumption.
  (*mi_memval*)
  assert (MV1:= memval12 _ _ _ _  H H0).
  assert (inject_id b2 = Some (b2, delta)).
  unfold inject_id in *. inv H. trivial.
  assert (R2: Mem.perm m2 b2 ofs Cur Readable).
  apply (perm12 _ _ _ _  _ _ H) in H0. inv H. rewrite Zplus_0_r in H0.
  assumption.
  assert (MV2:= memval23 _ _ _ _  H1 R2).
  inv H. inv H1.  rewrite Zplus_0_r in *.
  remember  (ZMap.get ofs (PMap.get b2 (Mem.mem_contents m2))) as v.
  destruct v. inv MV1. apply MV2.
  inv MV1. apply MV2.
  inv MV2. constructor.
  inv MV1. inv MV2. inv H3. inv H4.
  rewrite Int.add_zero. rewrite Int.add_zero.
  econstructor. reflexivity.
  rewrite Int.add_zero. trivial.
  inv MV2. inv H3. rewrite Int.add_zero.
  rewrite Int.add_zero in H5. econstructor.
Qed.

Lemma extends_trans: forall m1 m2
  (Ext12: Mem.extends m1 m2) m3 (Ext23: Mem.extends m2 m3), Mem.extends m1 m3.
Proof. intros. inv Ext12. inv Ext23.
  split. rewrite mext_next. assumption. eapply mem_inj_id_trans; eauto.
Qed.

Lemma memval_inject_id_refl: forall v, memval_inject inject_id v v.
Proof.
destruct v. constructor. constructor. econstructor. reflexivity.
rewrite Int.add_zero. trivial.
Qed.

Lemma extends_refl: forall m, Mem.extends m m.
Proof. intros.
  split. trivial.
  split; intros.
     inv H.  rewrite Zplus_0_r. assumption.
     inv H. apply Z.divide_0_r. (*rewrite Zplus_0_r. assumption.*)
     inv H.  rewrite Zplus_0_r. apply memval_inject_id_refl.
Qed.

Lemma compose_meminj_idR: forall j, j = compose_meminj j inject_id.
Proof. intros. unfold  compose_meminj, inject_id.
   apply extensionality. intro b.
   remember (j b).
   destruct o; trivial. destruct p. rewrite Zplus_0_r. trivial.
Qed.

Lemma compose_meminj_idL: forall j, j = compose_meminj inject_id j.
Proof. intros. unfold  compose_meminj, inject_id.
   apply extensionality. intro b.
   remember (j b).
   destruct o; trivial. destruct p. rewrite Zplus_0_l. trivial.
Qed.

Lemma perm_decE:
  forall m b ofs k p PF,
  (Mem.perm_dec m b ofs k p = left PF <-> Mem.perm m b ofs k p).
Proof.
intros until p.
split; auto.
intros H1.
destruct (Mem.perm_dec m b ofs k p).
solve[f_equal; apply proof_irr].
solve[elimtype False; auto].
Qed.

Lemma flatinj_E: forall b b1 b2 delta (H:Mem.flat_inj b b1 = Some (b2, delta)),
  b2=b1 /\ delta=0 /\ Plt b2 b.
Proof.
  unfold Mem.flat_inj. intros.
  destruct (plt b1 b); inv H. repeat split; trivial.
Qed.

Lemma flatinj_I: forall bb b, Plt b bb -> Mem.flat_inj bb b = Some (b, 0).
Proof.
  intros. unfold Mem.flat_inj.
  destruct (plt b bb); trivial. exfalso. xomega.
Qed.

Lemma flatinj_mono: forall b b1 b2 b' delta
  (F: Mem.flat_inj b1 b = Some (b', delta)),
  Plt b1 b2 -> Mem.flat_inj b2 b = Some (b', delta).
Proof. intros.
  apply flatinj_E in F. destruct F as [? [? ?]]; subst.
  apply flatinj_I. xomega.
Qed.

(* A minimal preservation property we sometimes require. *)

Definition readonly m1 b m2 :=
    (forall ofs : Z, ~ Mem.perm m1 b ofs Max Writable) ->
    forall ch ofs, Mem.load ch m2 b ofs = Mem.load ch m1 b ofs.

Definition readonly_refl m b: readonly m b m.
  Proof. red; intros. trivial. Qed.

Definition mem_forward (m1 m2:mem) :=
  forall b, Mem.valid_block m1 b ->
    (Mem.valid_block m2 b
     /\ (forall ofs p, Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p)
     /\ readonly m1 b m2).

Lemma mem_forward_refl: forall m, mem_forward m m.
Proof. intros m b H. split; trivial.
  split; eauto. apply readonly_refl.
Qed.

Lemma mem_forward_trans: forall m1 m2 m3,
  mem_forward m1 m2 -> mem_forward m2 m3 -> mem_forward m1 m3.
Proof. intros. intros  b Hb.
  destruct (H _ Hb) as [? [? ?]].
  destruct (H0 _ H1) as [? [? ?]].
  split; eauto.
  split; eauto.
  red; intros. rewrite H6. apply H3. trivial.
   intros z N. apply H2 in N. apply (H7 _ N).
Qed.

Lemma forward_unchanged_trans: forall P m1 m2 m3,
Mem.unchanged_on P m1 m2 -> Mem.unchanged_on P m2 m3 ->
mem_forward m1 m2 -> mem_forward m2 m3 ->
mem_forward m1 m3 /\ Mem.unchanged_on P m1 m3.
Proof. intros.
split. eapply mem_forward_trans; eassumption.
split; intros.
  destruct H.
  destruct (unchanged_on_perm _ _ k p H3 H4).
  destruct H0. destruct (H1 _ H4).
  destruct (unchanged_on_perm0 _ _ k p H3 H0).
  split; intros; auto.
destruct H.
  rewrite <- (unchanged_on_contents _ _ H3 H4).
  destruct H0.
  apply (unchanged_on_contents0 _ _ H3).
  apply unchanged_on_perm; try assumption.
  apply Mem.perm_valid_block in H4. assumption.
Qed.

Lemma matchOptE: forall {A} (a:option A) (P: A -> Prop),
   match a with Some b => P b | None => False end ->
   exists b, a = Some b /\ P b.
Proof. intros. destruct a; try contradiction. exists a; auto. Qed.

Lemma compose_meminjD_None: forall j jj b,
  (compose_meminj j jj) b = None ->
  j b = None \/
  (exists b', exists ofs, j b = Some(b',ofs) /\ jj b' = None).
Proof.
  unfold compose_meminj; intros.
  destruct (j b).
  destruct p. right.
  remember (jj b0) as zz; destruct zz. destruct p. inv H.
  exists b0. exists z. rewrite <- Heqzz. auto.
  left; trivial.
Qed.

Lemma compose_meminjD_Some: forall j jj b b2 ofs2,
       (compose_meminj j jj) b = Some(b2,ofs2) ->
       exists b1, exists ofs1, exists ofs,
       j b = Some(b1,ofs1) /\ jj b1 = Some(b2,ofs) /\ ofs2=ofs1+ofs.
Proof. unfold compose_meminj; intros.
       remember (j b) as z; destruct z; apply eq_sym in Heqz.
         destruct p. exists b0. exists z.
         remember (jj b0) as zz.
         destruct zz; apply eq_sym in Heqzz.
           destruct p. inv H. exists z0. auto.
           inv H.
         inv H.
Qed.

Lemma compose_meminj_inject_incr: forall j12 j12' j23 j23'
  (InjIncr12: inject_incr j12 j12') (InjIncr23: inject_incr j23 j23'),
  inject_incr (compose_meminj j12 j23) (compose_meminj j12' j23').
Proof.
  intros. intros b; intros.
  apply compose_meminjD_Some in H.
  destruct H as [b1 [ofs1 [ofs [Hb [Hb1 Hdelta]]]]].
  unfold compose_meminj.
  rewrite (InjIncr12 _ _ _ Hb).
  rewrite (InjIncr23 _ _ _ Hb1). subst. trivial.
Qed.

Lemma compose_meminj_inject_separated: forall j12 j12' j23 j23' m1 m2 m3
   (InjSep12 : inject_separated j12 j12' m1 m2)
   (InjSep23 : inject_separated j23 j23' m2 m3)
   (InjIncr12: inject_incr j12 j12') (InjIncr23: inject_incr j23 j23')
   (BV12: forall b1 b2 ofs, j12 b1 = Some (b2,ofs) -> Mem.valid_block m1 b1 /\ Mem.valid_block m2 b2)
   (BV23: forall b1 b2 ofs, j23 b1 = Some (b2,ofs) -> Mem.valid_block m2 b1 /\ Mem.valid_block m3 b2),
   inject_separated (compose_meminj j12 j23) (compose_meminj j12' j23') m1 m3.
Proof. intros.
  unfold compose_meminj; intros b; intros.
  remember (j12 b) as j12b.
  destruct j12b; inv H; apply eq_sym in Heqj12b. destruct p.
    rewrite (InjIncr12 _ _ _ Heqj12b) in H0.
    remember (j23 b0) as j23b0.
    destruct j23b0; inv H2; apply eq_sym in Heqj23b0. destruct p. inv H1.
    remember (j23' b0) as j23'b0.
    destruct j23'b0; inv H0; apply eq_sym in Heqj23'b0. destruct p. inv H1.
    destruct (InjSep23 _ _ _ Heqj23b0 Heqj23'b0).
    split; trivial. exfalso. apply H. eapply BV12. apply Heqj12b.
  remember (j12' b) as j12'b.
  destruct j12'b; inv H0; apply eq_sym in Heqj12'b. destruct p.
    destruct (InjSep12 _ _ _ Heqj12b Heqj12'b). split; trivial.
    remember (j23' b0) as j23'b0.
    destruct j23'b0; inv H1; apply eq_sym in Heqj23'b0. destruct p. inv H3.
    remember (j23 b0) as j23b0.
    destruct j23b0; apply eq_sym in Heqj23b0. destruct p.
      rewrite (InjIncr23 _ _ _ Heqj23b0) in Heqj23'b0. inv Heqj23'b0.
      exfalso. apply H0. eapply BV23. apply Heqj23b0.
    destruct (InjSep23 _ _ _ Heqj23b0 Heqj23'b0). assumption.
Qed.

Lemma compose_meminj_inject_separated': forall j12 j12' j23 j23' m1 m2 m3
   (InjSep12 : inject_separated j12 j12' m1 m2)
   (InjSep23 : inject_separated j23 j23' m2 m3)
   (InjIncr12: inject_incr j12 j12') (InjIncr23: inject_incr j23 j23')
   (MInj12: Mem.inject j12 m1 m2)
   (MInj23: Mem.inject j23 m2 m3),
   inject_separated (compose_meminj j12 j23) (compose_meminj j12' j23') m1 m3.
Proof. intros.
  eapply compose_meminj_inject_separated; try eassumption.
  intros; split. apply (Mem.valid_block_inject_1 _ _ _ _ _ _ H MInj12).
    apply (Mem.valid_block_inject_2 _ _ _ _ _ _ H MInj12).
  intros; split. apply (Mem.valid_block_inject_1 _ _ _ _ _ _ H MInj23).
    apply (Mem.valid_block_inject_2 _ _ _ _ _ _ H MInj23).
Qed.

Lemma forall_lessdef_refl: forall vals,  Forall2 Val.lessdef vals vals.
Proof. induction vals; econstructor; trivial. Qed.

Lemma lessdef_hastype: forall v v' (V:Val.lessdef v v') T,
              Val.has_type v' T -> Val.has_type v T.
Proof. intros. inv V; simpl; trivial. Qed.

Lemma forall_lessdef_hastype: forall vals vals'
          (V:Forall2 Val.lessdef vals vals') Ts
          (HTs: Forall2 Val.has_type vals' Ts),
          Forall2 Val.has_type vals Ts.
Proof.
  intros vals vals' V.
  induction V; simpl in *; intros.
       trivial.
  inv HTs. constructor. eapply  lessdef_hastype; eassumption. apply (IHV _ H4).
Qed.

Lemma valinject_hastype:  forall j v v'
       (V: (val_inject j) v v') T,
       Val.has_type v' T -> Val.has_type v T.
Proof. intros. inv V; simpl; trivial. Qed.

Lemma forall_valinject_hastype:  forall j vals vals'
            (V:  Forall2 (val_inject j) vals vals')
            Ts (HTs: Forall2 Val.has_type vals' Ts),
            Forall2 Val.has_type vals Ts.
Proof.
  intros j vals vals' V.
  induction V; simpl in *; intros.
       trivial.
  inv HTs. constructor. eapply  valinject_hastype; eassumption. apply (IHV _ H4).
Qed.

Definition val_inject_opt (j: meminj) (v1 v2: option val) :=
  match v1, v2 with Some v1', Some v2' => val_inject j v1' v2'
  | None, None => True
  | _, _ => False
  end.

Lemma val_inject_split:
  forall v1 v3 j12 j23 (V: val_inject (compose_meminj j12 j23) v1 v3),
    exists v2, val_inject j12 v1 v2 /\ val_inject j23 v2 v3.
Proof. intros.
   inv V.
     exists (Vint i). split; constructor.
     exists (Vlong i); split; constructor.
     exists (Vfloat f). split; constructor.
     apply compose_meminjD_Some in H. rename b2 into b3.
       destruct H as [b2 [ofs2 [ofs3 [J12 [J23 DD]]]]]; subst.
       eexists. split. econstructor. apply J12. reflexivity.
          econstructor. apply J23. rewrite Int.add_assoc.
          assert (H: Int.repr (ofs2 + ofs3) = Int.add (Int.repr ofs2) (Int.repr ofs3)).
            clear - ofs2 ofs3. rewrite Int.add_unsigned.
            apply Int.eqm_samerepr. apply Int.eqm_add; apply Int.eqm_unsigned_repr.
          rewrite H. trivial.
     exists Vundef. split; constructor.
Qed.

Lemma forall_lessdef_trans:
  forall vals1 vals2 (V12: Forall2 Val.lessdef vals1 vals2)
    vals3  (V23: Forall2 Val.lessdef vals2 vals3),
    Forall2 Val.lessdef vals1 vals3.
Proof. intros vals1 vals2 V12.
   induction V12; intros; inv V23; econstructor.
   eapply Val.lessdef_trans; eauto.
          eapply IHV12; trivial.
Qed.

Lemma extends_loc_out_of_bounds:
  forall m1 m2 (Ext: Mem.extends m1 m2) b ofs,
    loc_out_of_bounds m2 b ofs -> loc_out_of_bounds m1 b ofs.
Proof. intros.
  inv Ext. inv mext_inj.
  intros N.  eapply H. apply (mi_perm _ b 0) in N.
    rewrite Zplus_0_r in N. assumption. reflexivity.
Qed.

Lemma extends_loc_out_of_reach:
  forall m1 m2 (Ext: Mem.extends m1 m2) b ofs j
    (Hj: loc_out_of_reach j m2 b ofs), loc_out_of_reach j m1 b ofs.
Proof.
  intros. unfold loc_out_of_reach in *. intros.
  intros N. eapply (Hj _ _ H). clear Hj H. inv Ext. inv mext_inj.
  specialize (mi_perm b0 _ 0 (ofs - delta) Max Nonempty (eq_refl _)).
    rewrite Zplus_0_r in mi_perm. apply (mi_perm N).
Qed.

Lemma valinject_lessdef:
  forall v1 v2 v3 j (V12:val_inject j v1 v2) (V23 : Val.lessdef v2 v3),
    val_inject j v1 v3.
Proof.
  intros.
  inv V12; inv V23; try constructor.
    econstructor. eassumption. trivial.
Qed.

Lemma forall_valinject_lessdef:
  forall vals1 vals2 j (VInj12 : Forall2 (val_inject j) vals1 vals2) vals3
    (LD23 : Forall2 Val.lessdef vals2 vals3), Forall2 (val_inject j) vals1 vals3.
Proof. intros vals1 vals2 j VInj12.
   induction VInj12; intros; inv LD23. constructor.
     econstructor. eapply valinject_lessdef; eassumption.
          eapply (IHVInj12 _ H4).
Qed.

Lemma val_lessdef_inject_compose:
  forall v1 v2 (LD12 : Val.lessdef v1 v2) j v3
    (InjV23 : val_inject j v2 v3), val_inject j v1 v3.
Proof. intros.
  apply val_inject_id in LD12.
  apply (val_inject_compose _ _ _ _ _ LD12) in InjV23.
  rewrite <- compose_meminj_idL in InjV23. assumption.
Qed.

Lemma forall_val_lessdef_inject_compose:
  forall v1 v2 (LD12 : Forall2 Val.lessdef v1 v2) j v3
    (InjV23 : Forall2 (val_inject j) v2 v3), Forall2 (val_inject j) v1 v3.
Proof. intros v1 v2 H.
  induction H; intros; inv InjV23; econstructor.
       eapply val_lessdef_inject_compose; eassumption.
       apply (IHForall2 _ _ H5).
Qed.

Lemma forall_val_inject_compose:
  forall vals1 vals2 j1 (ValsInj12 : Forall2 (val_inject j1) vals1 vals2)
     vals3 j2 (ValsInj23 : Forall2 (val_inject j2) vals2 vals3),
     Forall2 (val_inject (compose_meminj j1 j2)) vals1 vals3.
Proof.
  intros vals1 vals2 j1 ValsInj12.
  induction ValsInj12; intros; inv ValsInj23; econstructor.
     eapply val_inject_compose; eassumption.
  apply (IHValsInj12 _ _ H4).
Qed.

Lemma val_inject_flat:
  forall m1 m2 j (Inj: Mem.inject j m1 m2) v1 v2 (V: val_inject j v1 v2),
    val_inject  (Mem.flat_inj (Mem.nextblock m1)) v1 v1.
Proof. intros.
  inv V; try constructor.
    apply val_inject_ptr with (delta:=0).
            unfold Mem.flat_inj. inv Inj.
            destruct (plt b1 (Mem.nextblock m1)).
               trivial.
            assert (j b1 = None).
              apply mi_freeblocks. assumption. rewrite H in H0. inv H0.
            rewrite Int.add_zero. trivial.
Qed.

Lemma forall_val_inject_flat: forall m1 m2 j (Inj: Mem.inject j m1 m2) vals1 vals2
                (V: Forall2 (val_inject j) vals1 vals2),
                Forall2 (val_inject  (Mem.flat_inj (Mem.nextblock m1))) vals1 vals1.
Proof. intros.
  induction V; intros; try econstructor.
       eapply val_inject_flat; eassumption.
  apply IHV.
Qed.

Lemma po_trans: forall a b c, Mem.perm_order'' a b ->  Mem.perm_order'' b c ->
      Mem.perm_order'' a c.
Proof. intros.
   destruct a; destruct b; destruct c; simpl in *; try contradiction; try trivial.
   eapply perm_order_trans; eassumption.
Qed.

Lemma extends_perm: forall m1 m2 (Ext: Mem.extends m1 m2) b ofs k p,
   Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p.
Proof. intros. destruct Ext. destruct mext_inj.
  specialize (mi_perm b b 0 ofs k p (eq_refl _) H).
  rewrite Zplus_0_r in mi_perm. assumption.
Qed.

Lemma extends_permorder: forall m1 m2 (Ext: Mem.extends m1 m2) (b:block) ofs k,
  Mem.perm_order'' (PMap.get b (Mem.mem_access m2) ofs k)
                   (PMap.get b (Mem.mem_access m1) ofs k).
Proof.
  intros. destruct Ext.  destruct mext_inj as [prm _ _].
  specialize (prm b b 0 ofs k). unfold Mem.perm in prm.
  remember ((PMap.get b (Mem.mem_access m2) ofs k)) as z.
  destruct z; apply eq_sym in Heqz; simpl  in *.
    remember ((PMap.get b (Mem.mem_access m1) ofs k)) as zz.
    destruct zz; trivial; apply eq_sym in Heqzz; simpl  in *.
       rewrite Zplus_0_r in prm. rewrite Heqz in prm.
       specialize (prm p0 (eq_refl _)). apply prm. apply perm_refl.
  remember ((PMap.get b (Mem.mem_access m1) ofs k)) as zz.
    destruct zz; trivial; apply eq_sym in Heqzz; simpl  in *.
       rewrite Zplus_0_r in prm. rewrite Heqz in prm.
       specialize (prm p (eq_refl _)). exfalso. apply prm. apply perm_refl.
Qed.

Lemma fwd_maxperm: forall m1 m2 (FWD: mem_forward m1 m2) b
  (V:Mem.valid_block m1 b) ofs p,
  Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p.
Proof. intros. apply FWD; assumption. Qed.

Lemma fwd_maxpermorder: forall m1 m2 (FWD: mem_forward m1 m2) (b:block)
  (V:Mem.valid_block m1 b) ofs,
  Mem.perm_order'' (PMap.get b (Mem.mem_access m1) ofs Max)
                   (PMap.get b (Mem.mem_access m2) ofs Max).
Proof.
  intros. destruct (FWD b) as [? [? RD]]; try assumption.
  remember ((PMap.get b (Mem.mem_access m2) ofs Max)) as z.
  destruct z; apply eq_sym in Heqz; simpl  in *.
  remember ((PMap.get b (Mem.mem_access m1) ofs Max)) as zz.
  destruct zz; apply eq_sym in Heqzz; simpl  in *.
  specialize (H0 ofs p).  unfold Mem.perm in H0. unfold Mem.perm_order' in H0.
  rewrite Heqz in H0. rewrite Heqzz in H0. apply H0. apply perm_refl.
  specialize (H0 ofs p).  unfold Mem.perm in H0. unfold Mem.perm_order' in H0.
  rewrite Heqz in H0. rewrite Heqzz in H0. apply H0. apply perm_refl.
  remember ((PMap.get b (Mem.mem_access m1) ofs Max)) as zz.
  destruct zz; apply eq_sym in Heqzz; simpl in *; trivial.
Qed.

Lemma po_oo: forall p q, Mem.perm_order' p q = Mem.perm_order'' p (Some q).
Proof. intros. destruct p; trivial. Qed.

Lemma inject_permorder:
  forall j m1 m2 (Inj : Mem.inject j m1 m2) (b b':block) ofs'
      (J: j b = Some (b', ofs')) ofs k,
    Mem.perm_order'' (PMap.get b' (Mem.mem_access m2) (ofs + ofs') k)
   (PMap.get b (Mem.mem_access m1) ofs k).
Proof.
  intros. destruct Inj. destruct mi_inj as [prm _ _ ].
  specialize (prm b b' ofs' ofs k). unfold Mem.perm in prm.
  remember ((PMap.get b' (Mem.mem_access m2) (ofs + ofs') k)) as z.
  destruct z; apply eq_sym in Heqz; simpl  in *.
    remember ((PMap.get b (Mem.mem_access m1) ofs k)) as zz.
    destruct zz; trivial; apply eq_sym in Heqzz; simpl  in *.
       eapply prm. apply J. apply perm_refl.
  remember ((PMap.get b (Mem.mem_access m1) ofs k)) as zz.
    destruct zz; trivial; apply eq_sym in Heqzz; simpl  in *.
       eapply prm. apply J. apply perm_refl.
Qed.

Lemma PermExtNotnonempty:
  forall m1 m2
    (Inj: Mem.extends m1 m2) b ofs p
    (H: ~ Mem.perm m2 b ofs p Nonempty),
    ~Mem.perm m1 b ofs p Nonempty.
Proof. intros. destruct Inj. destruct mext_inj.
intros N. apply H. apply (mi_perm _ _ _ _ _ _ (eq_refl _)) in N.
  rewrite Zplus_0_r in N. apply N.
Qed.

Lemma PermInjNotnonempty:
  forall j m1 m2
    (Inj: Mem.inject j m1 m2) b b2 delta (J:j b = Some(b2,delta)) ofs p
    (H: ~Mem.perm m2 b2 (ofs+delta) p Nonempty),
    ~Mem.perm m1 b ofs p Nonempty.
Proof. intros. destruct Inj. destruct mi_inj.
intros N. apply H. apply (mi_perm _ _ _ _ _ _ J) in N. apply N.
Qed.

Lemma inject_LOOR_LOOB:
  forall m1 m2 j (Minj12 : Mem.inject j m1 m2) m3 m3',
  Mem.unchanged_on (loc_out_of_reach j m1) m3 m3' ->
  Mem.unchanged_on (loc_out_of_bounds m2) m3 m3'.
Proof. intros.
    split; intros; eapply H; trivial.
         intros b2; intros.
           unfold loc_out_of_bounds in H0. intros N. apply H0.
           inv Minj12. inv mi_inj. apply (mi_perm _ _ _ _ _ _ H2) in N.
           rewrite <- Zplus_comm in N. rewrite Zplus_minus in N.  apply N.
    intros b2; intros. unfold loc_out_of_bounds in H0. intros N. apply H0.
           inv Minj12. inv mi_inj. apply (mi_perm _ _ _ _ _ _ H2) in N.
           rewrite <- Zplus_comm in N. rewrite Zplus_minus in N.  apply N.
Qed.

Lemma free_neutral:
  forall (thr : block) (m : mem) (lo hi : Z) (b : block) (m' : Mem.mem')
  (FREE: Mem.free m b lo hi = Some m'),
  Mem.inject_neutral thr m -> Mem.inject_neutral thr m'.
Proof. intros. inv H.
  split; intros.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst.
       rewrite Zplus_0_r. assumption.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst.
       apply Z.divide_0_r.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst.
       rewrite Zplus_0_r.
       assert (X: Mem.flat_inj thr b1 = Some (b1,0)).
         { apply flatinj_I. assumption. }
       assert (Y:= Mem.perm_free_3 _ _ _ _ _ FREE _ _ _ _ H0).
        specialize (mi_memval _ _ _ _ X Y). rewrite Zplus_0_r in *.
        rewrite (Mem.free_result _ _ _ _ _ FREE) in *. simpl in *.
          apply mi_memval.
Qed.

Lemma getN_aux: forall n p c B1 v B2, Mem.getN n p c = B1 ++ v::B2 ->
    v = ZMap.get (p + Z.of_nat (length B1)) c.
Proof. intros n.
  induction n; simpl; intros.
    destruct B1; simpl in *. inv H. inv H.
    destruct B1; simpl in *.
      inv H. rewrite Zplus_0_r. trivial.
      inv H. specialize (IHn _ _ _ _ _ H2). subst.
        rewrite Zpos_P_of_succ_nat.
        remember (Z.of_nat (length B1)) as m. clear Heqm H2. rewrite <- Z.add_1_l.
         rewrite Zplus_assoc. trivial.
Qed.

Lemma getN_range: forall n ofs M bytes1 v bytes2,
  Mem.getN n ofs M = bytes1 ++ v::bytes2 ->
  (length bytes1 < n)%nat.
Proof. intros n.
  induction n; simpl; intros.
    destruct bytes1; inv H.
    destruct bytes1; simpl in *; inv H.
      omega.
    specialize (IHn _ _ _ _ _ H2). omega.
Qed.

Lemma loadbytes_D: forall m b ofs n bytes
      (LD: Mem.loadbytes m b ofs n = Some bytes),
      Mem.range_perm m b ofs (ofs + n) Cur Readable /\
      bytes = Mem.getN (nat_of_Z n) ofs (PMap.get b (Mem.mem_contents m)).
Proof. intros.
  Transparent Mem.loadbytes.
  unfold Mem.loadbytes in LD.
  Opaque Mem.loadbytes.
  remember (Mem.range_perm_dec m b ofs (ofs + n) Cur Readable) as d.
  destruct d; inv LD. auto.
Qed.

(******** Compatibility of memory operation with [mem_forward] ********)

Lemma store_forward: forall m b ofs v ch m'
      (M:Mem.store ch m b ofs v = Some m'),
      mem_forward m m'.
Proof. intros.
  split; intros.
    eapply Mem.store_valid_block_1; eassumption.
  split; intros.
    eapply Mem.perm_store_2; eassumption.
  red; intros.
    eapply Mem.load_store_other; try eassumption.
    destruct (eq_block b0 b); subst. 2: left; trivial.
    elim (H0 ofs).
    eapply Mem.perm_max.
    eapply Mem.store_valid_access_3; try eassumption.
    specialize (size_chunk_pos ch); intros; omega.
Qed.

Lemma storebytes_nil m b ofs m': Mem.storebytes m b ofs nil = Some m' ->
  forall ch bb z, Mem.load ch m' bb z = Mem.load ch m bb z.
Proof. intros.
  remember (Mem.load ch m' bb z) as u'; symmetry in Hequ'; destruct u'.
      symmetry.
      eapply Mem.load_unchanged_on; try eassumption.
      instantiate (1:= fun b ofs => True).
      split; intros.
        split; intros.
          eapply Mem.perm_storebytes_2; eassumption.
          eapply Mem.perm_storebytes_1; eassumption.
      rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H).
      destruct (eq_block b0 b); subst. rewrite PMap.gss; trivial.
      rewrite PMap.gso; trivial.
    intros; simpl; trivial.

    remember (Mem.load ch m bb z) as u; symmetry in Hequ; destruct u; trivial.
      rewrite <- Hequ'; clear Hequ'.
      eapply Mem.load_unchanged_on; try eassumption.
      instantiate (1:= fun b ofs => True).
      split; intros.
        split; intros.
          eapply Mem.perm_storebytes_1; eassumption.
          eapply Mem.perm_storebytes_2; eassumption.
      rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H).
      destruct (eq_block b0 b); subst. rewrite PMap.gss; trivial.
      rewrite PMap.gso; trivial.
    intros; simpl; trivial.
Qed.

Lemma storebytes_forward: forall m b ofs bytes m'
      (M: Mem.storebytes m b ofs bytes = Some m'),
      mem_forward m m'.
Proof. intros.
  split; intros.
    eapply Mem.storebytes_valid_block_1; eassumption.
  split; intros.
    eapply Mem.perm_storebytes_2; eassumption.
  red; intros.
  destruct bytes.
    eapply storebytes_nil; eassumption.
  eapply Mem.load_storebytes_other; try eassumption.
    destruct (eq_block b0 b); subst. 2: left; trivial.
    apply Mem.storebytes_range_perm in M.
    elim (H0 ofs). eapply Mem.perm_max. eapply M. simpl; xomega.
Qed.

Lemma alloc_forward:
      forall m lo hi m' b
      (A: Mem.alloc m lo hi = (m',b)),
      mem_forward m m'.
Proof. intros.
split; intros.
  eapply Mem.valid_block_alloc; eassumption.
split; intros.
  eapply Mem.perm_alloc_4; try eassumption.
  intros N; subst. eapply (Mem.fresh_block_alloc _ _ _ _ _ A H).
red; intros. eapply Mem.load_alloc_unchanged; try eassumption.
Qed.

Lemma free_forward: forall b z0 z m m'
      (M: Mem.free m b z0 z = Some m'),
      mem_forward m m'.
Proof. intros.
split; intros.
  eapply Mem.valid_block_free_1; eassumption.
split; intros.
  eapply Mem.perm_free_3; eassumption.
red; intros. eapply Mem.load_free; try eassumption.
  destruct (zlt z0 z).
    left; intros N; subst.
    eapply (H0 z0).
    eapply Mem.perm_max.
    eapply Mem.perm_implies.
      eapply Mem.free_range_perm; try eassumption.
      omega.
    constructor.
  right; left; trivial.
Qed.

Lemma freelist_forward: forall l m m'
      (M: Mem.free_list m l = Some m'),
      mem_forward m m'.
Proof. intros l.
  induction l; simpl; intros.
    inv M. apply mem_forward_refl.
  destruct a. destruct p.
  remember (Mem.free m b z0 z) as d.
  destruct d; inv M; apply eq_sym in Heqd.
  specialize (IHl _ _ H0).
  apply free_forward in Heqd.
  eapply mem_forward_trans; eassumption.
Qed.

Lemma forward_nextblock: forall m m',
  mem_forward m m' ->
  (Mem.nextblock m <= Mem.nextblock m')%positive.
Proof.
intros m m' H1.
unfold mem_forward in H1.
unfold Mem.valid_block in H1.
apply Pos.leb_le.
remember (Pos.leb (Mem.nextblock m) (Mem.nextblock m')).
destruct b; trivial.
assert (H2: (Mem.nextblock m' < Mem.nextblock m)%positive).
  apply Pos.leb_gt. rewrite Heqb. trivial.
destruct (H1 (Mem.nextblock m')); auto.
xomega.
Qed.

Lemma inject_separated_incr_fwd:
  forall j j' m1 m2 j'' m2'
    (InjSep : inject_separated j j' m1 m2)
    (InjSep' : inject_separated j' j'' m1 m2')
    (InjIncr' : inject_incr j' j'')
    (Fwd: mem_forward m2 m2'),
    inject_separated j j'' m1 m2.
Proof.
intros. intros b. intros. remember (j' b) as z.
destruct z; apply eq_sym in Heqz.
destruct p. specialize (InjIncr' _ _ _ Heqz).
rewrite InjIncr' in H0. inv H0.
apply (InjSep _ _ _ H Heqz).
destruct (InjSep' _ _ _ Heqz H0).
split. trivial.
intros N. apply H2. eapply Fwd. apply N.
Qed.

Lemma inject_separated_incr_fwd2:
  forall j0 j j' m10 m20 m1 m2,
  inject_incr j j' ->
  inject_separated j j' m1 m2 ->
  inject_incr j0 j ->
  mem_forward m10 m1 ->
  inject_separated j0 j m10 m20 ->
  mem_forward m20 m2 ->
  inject_separated j0 j' m10 m20.
Proof.
intros until m2; intros H1 H2 H3 H4 H5 H6.
apply (@inject_separated_incr_fwd j0 j m10 m20 j' m2); auto.
unfold inject_separated.
intros b1 b2 delta H7 H8.
unfold inject_separated in H2, H5.
specialize (H2 b1 b2 delta H7 H8).
destruct H2 as [H21 H22].
unfold mem_forward in H4, H6.
specialize (H4 b1).
specialize (H6 b2).
split; intros CONTRA.
solve[destruct (H4 CONTRA); auto].
apply H22; auto.
Qed.

Lemma forall_inject_val_list_inject:
  forall j args args' (H:Forall2 (val_inject j) args args' ),
    val_list_inject j args args'.
Proof.
intros j args.
induction args; intros;  inv H; constructor; eauto.
Qed.

Lemma val_list_inject_forall_inject:
  forall j args args' (H:val_list_inject j args args'),
    Forall2 (val_inject j) args args' .
Proof.
intros j args.
induction args; intros;  inv H; constructor; eauto.
Qed.

Lemma forall_lessdef_val_listless:
  forall args args' (H: Forall2 Val.lessdef args args'),
    Val.lessdef_list args args' .
Proof.
intros args.
induction args; intros;  inv H; constructor; eauto.
Qed.

Lemma val_listless_forall_lessdef:
  forall args args' (H:Val.lessdef_list args args'),
    Forall2 Val.lessdef args args' .
Proof.
intros args.
induction args; intros;  inv H; constructor; eauto.
Qed.

Lemma storev_valid_block_1:
forall ch m addr v m',
Mem.storev ch m addr v = Some m' ->
(forall b, Mem.valid_block m b -> Mem.valid_block m' b).
Proof. intros. destruct addr; inv H. eapply Mem.store_valid_block_1; eauto. Qed.

Lemma storev_valid_block_2:
forall ch m addr v m',
Mem.storev ch m addr v = Some m' ->
(forall b, Mem.valid_block m' b -> Mem.valid_block m b).
Proof. intros. destruct addr; inv H. eapply Mem.store_valid_block_2; eauto. Qed.

Lemma valid_block_dec: forall m b, {Mem.valid_block m b} +  {~Mem.valid_block m b}.
Proof. intros.
unfold Mem.valid_block.
remember (plt b (Mem.nextblock m)).
destruct s. left; assumption.
right. intros N. xomega.
Qed.

(*This is an [F,V]-independent definition of meminj_preserves_globals*)
Definition meminj_preserves_globals_ind (globals: (block->Prop)*(block->Prop)) f :=
  (forall b, fst globals b -> f b = Some (b, 0)) /\
  (forall b, snd globals b -> f b = Some (b, 0)) /\
  (forall b1 b2 delta, snd globals b2 -> f b1 = Some (b2, delta) -> b1=b2).

Definition genv2blocks {F V: Type} (ge: Genv.t F V) :=
  (fun b => exists id, Genv.find_symbol ge id = Some b,
   fun b => exists gv, Genv.find_var_info ge b = Some gv).

Lemma meminj_preserves_genv2blocks:
  forall {F V: Type} (ge: Genv.t F V) j,
  meminj_preserves_globals_ind (genv2blocks ge) j <->
  Events.meminj_preserves_globals ge j.
Proof.
intros ge; split; intro H1.
unfold meminj_preserves_globals in H1.
unfold Events.meminj_preserves_globals.
destruct H1 as [H1 [H2 H3]].
split.
intros.
apply H1; auto.
unfold genv2blocks.
unfold Genv.find_symbol in H.
simpl; exists id; auto.
split.
intros b gv H4.
apply H2; auto.
unfold genv2blocks.
unfold Genv.find_var_info in H4.
simpl; exists gv; auto.
intros until gv; intros H4 H5.
symmetry.
eapply H3; eauto.
unfold genv2blocks.
unfold Genv.find_var_info in H4.
simpl; exists gv; auto.
unfold meminj_preserves_globals.
destruct H1 as [H1 [H2 H3]].
split.
intros b H4.
unfold genv2blocks in H4.
destruct H4; eapply H1; eauto.
split.
intros b H4.
destruct H4; eapply H2; eauto.
intros b1 b2 delta H4 H5.
unfold genv2blocks in H4.
destruct H4.
eapply H3 in H; eauto.
Qed.

Definition genvs_domain_eq {F1 F2 V1 V2: Type}
  (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2) :=
    (forall b, fst (genv2blocks ge1) b <-> fst (genv2blocks ge2) b) /\
    (forall b, snd (genv2blocks ge1) b <-> snd (genv2blocks ge2) b) /\
    (forall b, (exists f, Genv.find_funct_ptr ge1 b = Some f)
           <-> (exists f, Genv.find_funct_ptr ge2 b = Some f)).

Lemma genvs_domain_eq_preserves:
  forall {F1 F2 V1 V2: Type} (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2) j,
  genvs_domain_eq ge1 ge2 ->
  (meminj_preserves_globals_ind (genv2blocks ge1) j <->
   meminj_preserves_globals_ind (genv2blocks ge2) j).
Proof.
intros until j; intros H1.
unfold meminj_preserves_globals.
destruct H1 as [DE1 DE2].
split; intros [H2 [H3 H4]].
split.
intros b H5.
cut (fst (genv2blocks ge1) b).
 intros H6.
apply (H2 b H6).
apply (DE1 b); auto.
split.
intros b H5.
apply H3; eauto.
apply DE2; auto.
intros b1 b2 delta H5 H6.
eapply H4; eauto.
apply DE2; auto.
split.
intros b H5.
eapply H2; eauto.
apply DE1; auto.
split.
intros b H5.
apply H3; auto.
apply DE2; auto.
intros until delta; intros H5 H6.
eapply H4; eauto.
apply DE2; auto.
Qed.

Lemma genvs_domain_eq_sym:
  forall {F1 F2 V1 V2: Type} (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2),
  genvs_domain_eq ge1 ge2 -> genvs_domain_eq ge2 ge1.
Proof.
intros until ge2.
unfold genvs_domain_eq; intros [H1 H2].
split. intros b. split; intro H3; solve[destruct (H1 b); auto].
split. intros b. split; intro H3.
  destruct H2; eapply H; eauto.
  destruct H2; eapply H; eauto.
intros b. split.
  intros [ef F]. destruct H2 as [H2 H3]. rewrite H3; eauto.
  intros [ef F]. destruct H2 as [H2 H3]. rewrite <-H3; eauto.
Qed.

Lemma genvs_domain_eq_refl:
  forall F V (ge: Genv.t F V), genvs_domain_eq ge ge.
Proof.
intros F V ge; unfold genvs_domain_eq; split; try solve[intro b; split; auto].
split. intro b; split; auto.
intros b; split; auto.
Qed.

Lemma genvs_domain_eq_trans: forall {F1 F2 F3 V1 V2 V3: Type}
  (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2) (ge3: Genv.t F3 V3),
  genvs_domain_eq ge1 ge2 -> genvs_domain_eq ge2 ge3 -> genvs_domain_eq ge1 ge3.
Proof. intros F1 F2 F3 V1 V2 V3 ge1 ge2 ge3; unfold genvs_domain_eq.
  intros. destruct H; destruct H0.
  split. intros b. rewrite H. apply H0.
  split. intros b. destruct H1 as [H1 _]. rewrite H1.
    destruct H2 as [H2 _]. apply H2.
  intros b. destruct H2 as [H2 H3]. destruct H1 as [H1 H4].
    rewrite <-H3. rewrite H4. split; auto.
Qed.

Lemma genvs_domain_eq_match_genvs: forall {F1 V1 F2 V2:Type}
  (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2),
  genvs_domain_eq ge1 ge2 -> genv2blocks ge1 = genv2blocks ge2.
Proof. intros F1 V1 F2 V2 ge1 ge2.
  unfold genvs_domain_eq, genv2blocks. simpl; intros.
  destruct H.
  f_equal; extensionality b.
(*We use Axiom prop_ext here, but Lemma genvs_domain_eq_match_genvsB
in effect_simulations.v shows the same result of this lemma for Bool
rather than Prop*)
    apply prop_ext. apply H.
    apply prop_ext. apply H0.
Qed.

Lemma meminj_preserves_globals_ind_compose:
   forall {F1 V1 F2 V2} (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2)
   j1 j2 (G: genvs_domain_eq ge1 ge2)
   (PG1: meminj_preserves_globals_ind (genv2blocks ge1) j1)
   (PG2: meminj_preserves_globals_ind (genv2blocks ge2) j2),
   meminj_preserves_globals_ind (genv2blocks ge1) (compose_meminj j1 j2).
Proof. intros.
  destruct PG1 as [A12 [B12 C12]].
  destruct PG2 as [A23 [B23 C23]].
  split; intros.
     unfold compose_meminj. rewrite (A12 _ H).
     rewrite (A23 b). reflexivity.
     apply G. apply H.
  split; intros. unfold compose_meminj.
     rewrite (B12 _ H).
     rewrite (B23 b). reflexivity.
     apply G. apply H.
  rename b2 into b3.
    destruct (compose_meminjD_Some _ _ _ _ _ H0)
      as [b2 [d1 [d2 [J1 [J2 D]]]]]; subst; clear H0.
    assert (snd (genv2blocks ge2) b3). apply G; eassumption.
    specialize (C23 _ _ _ H0 J2). subst.
    specialize (C12 _ _ _ H J1). subst. trivial.
Qed.

Lemma meminj_preserves_incr_sep:
  forall {F V:Type} ge j (PG: @meminj_preserves_globals F V ge j)
         m tm (MINJ : Mem.inject j m tm)
         j' (INCR : inject_incr j j') (SEP: inject_separated j j' m tm),
  meminj_preserves_globals ge j'.
Proof. intros.
     apply meminj_preserves_genv2blocks.
     apply meminj_preserves_genv2blocks in PG.
     destruct PG as [AA [BB CC]].
     split; intros. apply INCR. apply (AA _ H).
     split; intros. apply INCR. apply (BB _ H).
     remember (j b1) as d.
     destruct d; apply eq_sym in Heqd.
       destruct p. rewrite (INCR _ _ _ Heqd) in H0. inv H0.
       apply (CC _ _ _ H Heqd).
     destruct (SEP _ _ _ Heqd H0).
       specialize (BB _ H).
       exfalso. apply H2; clear - BB MINJ.
       eapply Mem.valid_block_inject_2; try eassumption.
Qed.

Lemma meminj_preserves_incr_sep_vb:
  forall {F V:Type} ge j (PG: @meminj_preserves_globals F V ge j)
         m tm
         (VB: forall b1 b2 ofs, j b1 = Some(b2,ofs) ->
               (Mem.valid_block m b1 /\ Mem.valid_block tm b2))
         j' (INCR : inject_incr j j') (SEP: inject_separated j j' m tm),
  meminj_preserves_globals ge j'.
Proof. intros.
     apply meminj_preserves_genv2blocks.
     apply meminj_preserves_genv2blocks in PG.
     destruct PG as [AA [BB CC]].
     split; intros. apply INCR. apply (AA _ H).
     split; intros. apply INCR. apply (BB _ H).
     remember (j b1) as d.
     destruct d; apply eq_sym in Heqd.
       destruct p. rewrite (INCR _ _ _ Heqd) in H0. inv H0.
       apply (CC _ _ _ H Heqd).
     destruct (SEP _ _ _ Heqd H0).
       specialize (BB _ H).
       destruct (VB _ _ _ BB). contradiction.
Qed.

Lemma forward_unchanged_on: forall m m' (FWD: mem_forward m m')
           b ofs (P: ~ Mem.perm m b ofs Max Nonempty),
     Mem.unchanged_on (fun b' ofs' => b' = b /\ ofs' = ofs) m m'.
Proof. intros.
split; intros.
  destruct H; subst.
  split; intros; elim P.
    eapply Mem.perm_max.
    eapply Mem.perm_implies; try eassumption. apply perm_any_N.
    eapply FWD. assumption.
    eapply Mem.perm_max.
    eapply Mem.perm_implies; try eassumption. apply perm_any_N.
destruct H; subst.
  elim P. eapply Mem.perm_max.
  eapply Mem.perm_implies; try eassumption. apply perm_any_N.
Qed.

Lemma unchanged_on_union:
      forall m m' P Q (HP: Mem.unchanged_on P m m') (HQ: Mem.unchanged_on Q m m')
             (PQ: block -> Z -> Prop) (HPQ: forall b ofs, PQ b ofs -> P b ofs \/ Q b ofs),
      Mem.unchanged_on PQ m m'.
Proof. intros.
  split; intros.
    destruct (HPQ _ _ H).
      eapply HP; eassumption.
      eapply HQ; eassumption.
    destruct (HPQ _ _ H).
      eapply HP; eassumption.
      eapply HQ; eassumption.
Qed.

Lemma unchanged_on_validblock: forall m m' (U V: Values.block -> Z -> Prop)
   (UV: forall b ofs, Mem.valid_block m b -> (U b ofs -> V b ofs)),
   Mem.unchanged_on V m m' -> Mem.unchanged_on U m m'.
  Proof. intros.
    destruct H.
    split; intros.
       eapply unchanged_on_perm; try eassumption. eauto.
       eapply unchanged_on_contents; try eassumption.
       apply Mem.perm_valid_block in H0. eauto.
Qed.

Lemma unchanged_on_validblock_invariant: forall m m' U V
   (UV: forall b ofs, Mem.valid_block m b -> (U b ofs <-> V b ofs)),
   Mem.unchanged_on V m m' <-> Mem.unchanged_on U m m'.
  Proof. intros.
    split; intros.
       eapply unchanged_on_validblock; try eassumption.
          intros. destruct (UV _ ofs H0). eauto.
       eapply unchanged_on_validblock; try eassumption.
          intros. destruct (UV _ ofs H0). eauto.
Qed.

Lemma unchanged_on_perm_intersection: forall m m' U (Fwd: mem_forward m m'),
   Mem.unchanged_on U m m' <->
   Mem.unchanged_on (fun b z => U b z /\ Mem.perm m b z Max Nonempty)  m m'.
  Proof. intros.
    split; intros Hyp.
    split; intros; eapply Hyp; eauto. apply H. apply H.
    split; intros.
      remember (Mem.perm_dec m b ofs Max Nonempty).
      destruct s; clear Heqs.
         eapply Hyp; eauto.
      split; intros. exfalso. apply n; clear Hyp n.
         eapply Mem.perm_implies. eapply Mem.perm_max; eassumption.
               apply perm_any_N.
        exfalso. apply n; clear Hyp n.
         eapply (Fwd _ H0).
           eapply Mem.perm_implies. eapply Mem.perm_max; eassumption.
               apply perm_any_N.
     eapply Hyp; trivial.
       split; trivial.
        eapply Mem.perm_implies. eapply Mem.perm_max; eassumption.
               apply perm_any_N.
Qed.

Lemma unchanged_on_trans: forall m1 m2 m3 U
      (U1: Mem.unchanged_on U m1 m2)
      (U2: Mem.unchanged_on U m2 m3)
      (Fwd12: mem_forward m1 m2),
  Mem.unchanged_on U m1 m3.
Proof. intros.
split; intros.
  split; intros.
    eapply U2; trivial. apply Fwd12; trivial.
    eapply U1; trivial.
  eapply U1; trivial. eapply U2; trivial. apply Fwd12; trivial.
destruct U1 as [P1 V1]; destruct U2 as [P2 V2].
  rewrite (V2 _ _ H).
    apply V1; trivial.
  apply P1; trivial. eapply Mem.perm_valid_block; eassumption.
Qed.

Lemma external_call_mem_forward:
  forall (ef : external_function) (F V : Type) (ge : Genv.t F V)
    (vargs : list val) (m1 : mem) (t : trace) (vres : val) (m2 : mem),
    external_call ef ge vargs m1 t vres m2 -> mem_forward m1 m2.
Proof.
intros. intros b Hb.
split; intros. eapply external_call_valid_block; eauto.
split. intros. eapply external_call_max_perm; eauto.
red; intros. eapply ec_readonly. apply (external_call_spec ef). eassumption. eassumption.
  intros. apply H0.
Qed.

Definition val_has_type_opt' (v: option val) (ty: typ) :=
 match v with
 | None => True
 | Some v' => Val.has_type v' ty
 end.

Definition val_has_type_opt (v: option val) (sig: signature) :=
  val_has_type_opt' v (proj_sig_res sig).

Definition is_vundef (v : val) : bool :=
  match v with
    | Vundef => true
    | _ => false
  end.

Definition vals_def (vs : list val) :=
  List.forallb (fun v => negb (is_vundef v)) vs.


Require Export FunctionalExtensionality.
Require Export Program.Equality.

Require Export FreeProving.Base.
Require Import FreeProving.Classes.

Set Implicit Arguments.
Unset Elimination Schemes.

Section Free.

  Inductive Free (C : Container) (A : Type) : Type :=
  | pure : A -> Free C A
  | impure : Ext C (Free C A) -> Free C A.

End Free.

Arguments pure [_] [_] _.
Arguments impure [_] [_].

Section Free_Principles.

  Variable C : Container.

  Section Free_Rect.

    Variable A : Type.
    Variable P__rect : Free C A -> Type.
    Variable Pure_rect : forall (x : A), P__rect (pure x).
    Variable Impure_rect : forall (s : Shape) (pf : Pos s -> Free C A),
        (forall p, P__rect (pf p)) -> P__rect (impure (ext s pf)).

    Fixpoint Free_Rect (fx : Free C A) : P__rect fx :=
      match fx with
      | pure x => Pure_rect x
      | impure (ext s pf) =>
        Impure_rect s pf (fun p : Pos s => Free_Rect (pf p))
      end.

  End Free_Rect.

  Section Free_Ind.

    Variable A : Type.
    Variable P__ind : Free C A -> Prop.
    Variable Pure_ind : forall (x : A), P__ind (pure x).
    Variable Impure_ind : forall (s : Shape) (pf : Pos s -> Free C A),
        (forall p, P__ind (pf p)) -> P__ind (impure (ext s pf)).

    Check Pure_ind.

    Definition Free_ind (fx : Free C A) : P__ind fx :=
      Free_Rect P__ind Pure_ind Impure_ind fx.

  End Free_Ind.

End Free_Principles.

Section Free_Instances.
  Variable C : Container.

  Section FunctorInstance.

    Section fmap.

      Variable A B : Type.
      Variable f : A -> B.

      Fixpoint freeMap (fx : Free C A) :=
        match fx with
        | pure x => pure (f x)
        | impure (ext s pf) => impure (ext s (fun p => freeMap (pf p)))
        end.

    End fmap.

  End FunctorInstance.

  Section MonadInstance.

    Section fbind.

      Variable A B : Type.
      Variable f : A -> Free C B.

      Fixpoint free_bind' (ffA : Free C A) :=
        match ffA with
        | pure x => f x
        | impure (ext s pf) => impure (ext s (fun p => free_bind' (pf p)))
        end.

    End fbind.

    Definition free_bind (A B : Type) (ffA : Free C A) (f : A -> Free C B) :=
      free_bind' f ffA.

  End MonadInstance.

End Free_Instances.

Module Free_Notation.

  Notation "mx >>= f" := (free_bind mx f) (at level 50, left associativity).
  Notation "'do' x <- mx ; f" :=
    (free_bind mx (fun x => f))
      (at level 50, x ident, mx at level 40, f at level 50).

End Free_Notation.

Section ForFree.

  Import Free_Notation.

  Variable C : Container.

  Inductive ForFree (A : Type) (P : A -> Prop) : Free C A -> Prop :=
  | For_pure : forall (x : A), P x -> ForFree P (pure x)
  | For_impure : forall (s : Shape) (pf : Pos s -> Free C A),
      (forall p, ForFree P (pf p)) -> ForFree P (impure (ext s pf)).

End ForFree.

Section Fold.

  Variable F : Type -> Type.
  Variable C : Container.
  Variable C__Iso : Iso F C.
  Variable F__F : Functor F.

  Fixpoint fold_free A B (pur : A -> B) (imp : F B -> B) (fx : Free C A) : B :=
    match fx with
    | pure x => pur x
    | impure (ext s pf) => imp (to (ext s (fun p => fold_free pur imp (pf p))))
    end.

  Variable M : Type -> Type.
  Variable M__M : Monad M.

  Definition induce A (f : forall X, F X -> M X) (fx : Free C A) : M A :=
    fold_free (fun x => ret x) (fun x => join (f (M A) x)) fx.

End Fold.

Arguments induce [_] [_] [_] [_] [_] [_].

Module Tactics.

  Ltac simplifyInductionHypothesis ident1 ident2 :=
  match goal with
  | [ ident1 : ForFree ?P (pure _) |- _ ] => inversion ident1 as [ Heq ident2 |]; clear ident1; subst
  | [ ident1 : ForFree ?P (impure (ext ?s ?pf)) |- _ ] =>
    dependent destruction ident1;
    match goal with
    | [ H1 : forall p, ForFree ?P (?pf p), H0 : forall p, ForFree _ (?pf p) -> _ = _ |- _ ] =>
      injection (H0 p (H1 p)) as IH; clear H1; clear H0
    end
  end.

  Tactic Notation "simplify" ident(H) "as" ident(IH) := (simplifyInductionHypothesis H IH).

End Tactics.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Set Implicit Arguments.

Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
  if H then x else y.

Theorem ifdec_left :
  forall (A B:Prop) (C:Set) (H:{A} + {B}),
    ~ B -> forall x y:C, ifdec H x y = x.
Proof.
  intros; case H; auto.
  intro; absurd B; trivial.
Qed.

Theorem ifdec_right :
  forall (A B:Prop) (C:Set) (H:{A} + {B}),
    ~ A -> forall x y:C, ifdec H x y = y.
Proof.
  intros; case H; auto.
  intro; absurd A; trivial.
Qed.

Unset Implicit Arguments.


Require Import Coq.Lists.List Coq.Bool.Bool.
Require Import MirrorShard.Folds.
Require Import MirrorShard.Expr.

Set Implicit Arguments.
Set Strict Implicit.

Section typed.
  Variable types : list type.
  Variable concl : Type.

  (** The type of one unfolding lemma *)
  Record lemma :=
  { Foralls : variables
    (* The lemma statement begins with this sequence of [forall] quantifiers over these types. *)
  ; Hyps : list (expr types)
    (* Next, we have this sequence of pure hypotheses. *)
  ; Concl : concl
  (* Finally, we have a conclusion. *)
  }.

  Variable WellTyped_concl : list tvar -> concl -> bool.

  Variable conclD : forall (meta_base var_base : env types), concl -> Prop.

  Definition WellTyped_lemma tfuncs (l : lemma) : bool :=
    allb (fun x => is_well_typed tfuncs nil (Foralls l) x tvProp) (Hyps l) &&
    WellTyped_concl (Foralls l) (Concl l).

  Variable funcs : functions types.

    (** Helper function to add a sequence of implications in front of a [Prop] *)
  Definition hypD (H : expr types) (meta_env var_env : env types) : Prop :=
    match exprD funcs meta_env var_env H tvProp with
      | None => False
      | Some P => P
    end.

  Fixpoint implyEach (Hs : list (expr types)) (meta_env var_env : env types) (P : Prop) : Prop :=
    match Hs with
      | nil => P
      | H :: Hs' => hypD H meta_env var_env -> implyEach Hs' meta_env var_env P
    end.

  (** The meaning of a lemma statement *)

  (* Redefine to use the opposite quantifier order *)
  Fixpoint forallEachR (ls : variables) : (env types -> Prop) -> Prop :=
    match ls with
      | nil => fun cc => cc nil
      | a :: b => fun cc =>
        forallEachR b (fun r => forall x : tvarD types a, cc (existT _ a x :: r))
    end.

  Definition lemmaD (meta_base var_base : env types) (lem : lemma) : Prop :=
    WellTyped_lemma (typeof_funcs funcs) lem = true /\
    forallEachR (Foralls lem) (fun env =>
      implyEach (Hyps lem) meta_base (var_base ++ env)
      (conclD meta_base (var_base ++ env) (Concl lem))).

  (** Lemmas **)
  Lemma forallEachR_sem : forall vs P,
    forallEachR vs P <-> (forall e, map (@projT1 _ _) e = vs -> P e).
  Proof.
    clear. split; revert P; induction vs; simpl; intros.
    destruct e; simpl in *; try congruence.
    destruct e; simpl in *; try congruence. inversion H0; clear H0; subst. eapply IHvs in H; eauto.
    destruct s; eapply H.
    eapply H; reflexivity.
    eapply IHvs; intros. eapply H. simpl. f_equal; auto.
  Qed.

  Lemma implyEach_instantiate : forall HYPS U G,
    AllProvable funcs U G HYPS ->
    forall cc,
      implyEach HYPS U G cc ->
      cc.
  Proof.
    induction HYPS; simpl; intros; auto;
      repeat match goal with
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : _ && _ = _ |- _ ] =>
                 apply andb_true_iff in H; destruct H
             end.
    eapply IHHYPS; eauto.
  Qed.

  Lemma implyEach_sem : forall cc U G es,
    implyEach es U G cc <-> (AllProvable funcs U G es -> cc).
  Proof. clear; induction es; simpl; intuition. Qed.

End typed.


(** * Focused Sequent system
This file specifies a one-sided focused system for MMLL The system is
   parametric to [theory: oo->Prop], defining the formulas that can be used in
   rule [tri_dec3]. In this implementation, all the atoms are assumed to be
   positive and then, proofs must finish with the initial rule focusing on
   atomic propositions of the form [perp A]. The exchange rule is embedded in
   the definition, e.g., of [tri_tensor].
 *)

Require Export MMLL.Misc.Utils.
Require Export MMLL.SL.Locations.

Export ListNotations.
Set Implicit Arguments.

Section LLSequent.
  Context `{SI : Signature}.
  Context `{OLS: OLSig}.

  Variable theory : oo -> Prop. (* theory Definition *)

  (* Andreoli's triadic system for linear logic *)
  Reserved Notation " n '|-F-' B ';' L ';' X " (at level 80).

  (** Sequent rules. in [n '|-F-' B ';' L ';' X], [n] is the height of
  the derivation ; [B] a list representing the classical context ; [L]
  the linear context and [X] and [Arrow] that can be [DW F] (for the
  positive phase) or [UP L] (for the negative phase). *)
  Inductive seqN:  nat -> list TypedFormula -> multiset oo -> Arrow -> Prop :=
  | tri_init1 : forall B A n, SetU B -> n |-F- B ; [atom A] ; DW (perp A)
  | tri_init2 : forall B C A n i, SetU C -> mt i = true -> Permutation ((i, atom A)::C) B -> n |-F- B ; [] ; DW (perp A)
  | tri_one : forall B n, SetU B ->  n |-F- B ; [] ; DW One

  | tri_tensor : forall B D BD M N MN F G n, Permutation MN (M++N) ->
                                      Permutation (getU BD) (getU B) ->
                                      Permutation (getU BD) (getU D) ->
                                      Permutation (getL BD) (getL B ++ getL D) ->
                                        (n |-F- B ; M ; DW F) ->
                                        (n |-F- D ; N ; DW G )->
                                        S n |-F- BD ; MN ; DW (MAnd F G)

  | tri_plus1 : forall B M F G n,
      n |-F- B ; M ; DW F -> S n |-F- B ; M ; DW (AOr F G)
  | tri_plus2 : forall B M F G n,
      n |-F- B ; M ; DW G -> S n |-F- B ; M ; DW (AOr F G)
  | tri_rel : forall B F L n,
      negativeFormula F -> n |-F- B ; L ; UP [F] ->  S n |-F- B ; L ; DW F
  | tri_top : forall B L M n,
      n |-F- B ; L ; UP (Top :: M)
  | tri_bot : forall B L M n,
      n |-F- B ; L ; UP M -> S n  |-F- B ; L ; UP (Bot :: M)
  | tri_par : forall B L M F G n,
      n |-F- B ; L ; UP (F::G::M) -> S n  |-F- B ; L ; UP((MOr F G) :: M)
  | tri_with : forall B L M F G n,
      (n |-F- B ; L ; UP (F :: M)) ->
      (n |-F- B ; L ; UP (G :: M)) -> S n|-F- B ; L ; UP ((AAnd F  G) :: M)
  | tri_quest : forall B L M F n i,
      n |-F- (i,F)::B ; L ; UP M -> S n  |-F- B ; L ; UP ((Quest i F) :: M)
  | tri_store : forall B L M F n,
      positiveLFormula  F-> n |-F- B ; F::L ; UP M -> S n |-F- B ; L ; UP (F::M)
  | tri_dec1 : forall B L L' F n,
      positiveFormula F -> Permutation (F::L') L -> n |-F- B ; L' ; DW F -> S n |-F- B ; L ; UP []
  | tri_dec2u : forall B L F n i,
     u i = true -> mt i = true -> ~IsPositiveAtom F -> In (i,F) B -> n |-F- B ; L ; DW F -> S n |-F- B ; L ; UP []
  | tri_dec2l : forall B B' L F n i,
     u i = false -> mt i = true -> ~IsPositiveAtom F -> Permutation ((i,F)::B') B -> n |-F- B' ; L ; DW F -> S n |-F- B ; L ; UP []
  | tri_dec3 : forall B L F n,
      theory F -> ~IsPositiveAtom F -> n |-F- B ; L ; DW F -> S n |-F- B ; L ; UP []
  | tri_ex  : forall B FX M t n,
      uniform_oo FX -> proper t -> n |-F- B; M ; DW (FX t) -> S n|-F- B; M ; DW (Some  FX)
  | tri_fx  : forall B L FX M n,
      uniform_oo FX -> (forall x, proper x -> n |-F- B ; L ; UP( (FX x) ::  M)) ->
      S n |-F- B ; L ; UP ((All FX) :: M)
  | tri_bangL : forall B F n,
     SetU B ->  n  |-F- B ; [] ; (UP [F]) -> S n  |-F- B ; [] ; DW (Bang loc F)
  | tri_bang : forall B F n i, i <> loc ->
     tri_bangK4 n B i [] [] (UP [F]) -> S n  |-F- B ; [] ; DW (Bang i F)
| tri_bangD : forall n B i,  tri_bangK4 n B i [] [] (UP [ ]) -> md i = true -> S n |-F- B ; [] ; UP []
     with
      tri_bangK4 : nat -> list TypedFormula -> subexp -> list TypedFormula -> multiset oo -> Arrow -> Prop :=
       | tri_copyK4 : forall b F n L M C B B' i, lt i b  -> m4 b = true ->
        Permutation ((b,F)::B') B -> tri_bangK4 n B' i (C++[(plust b,F)]) L (UP M) ->
                                          tri_bangK4 (S n) B i C L (UP M)
       | tri_copyUK : forall b F n L M C B B' i, lt i b  -> m4 b = false -> u b = true ->
        Permutation ((b,F)::B') B -> tri_bangK4 n B' i (C++[(loc,F)]) L (UP M) ->
                                          tri_bangK4 (S n) B i C L (UP M)
       | tri_copyLK : forall b F n L M C B B' i, lt i b  -> m4 b = false -> u b = false ->
        Permutation ((b,F)::B') B -> tri_bangK4 n B' i C L (UP (M++[F])) ->
                                          tri_bangK4 (S n) B i C L (UP M)
       | tri_exp : forall B C i L M n, SetU B ->
                  n |-F- C; L; UP M -> tri_bangK4 (S n) B i C L (UP M)

  where " n '|-F-' B ';' L ';' X " := (seqN n B L X).

  (** Well formedness conditions for arrows. *)
  Definition isArrow (Ar:Arrow) : Prop :=
    match Ar with
    | UP l => isFormulaL l
    | DW F => isFormula F
    end.

  Reserved Notation " '|-f-' B ';' L ';' X " (at level 80).

  (** The same system without the height of the derivation *)
  Inductive seq:  list TypedFormula -> multiset oo -> Arrow -> Prop :=
  | tri_init1' : forall B A ,  SetU B ->  |-f- B ; [atom A] ; DW (perp A)
  | tri_init2' : forall B C A i, SetU C -> mt i = true -> Permutation ((i, atom A)::C) B -> |-f- B ; [] ; DW (perp A)

  | tri_one' : forall B, SetU B -> |-f- B ; [] ; DW One
  | tri_tensor' : forall M N MN B D BD F G, Permutation MN (M++N) ->
                                      Permutation (getU BD) (getU B) ->
                                      Permutation (getU BD) (getU D) ->
                                      Permutation (getL BD) (getL B ++ getL D) ->
                                       |-f- B ; M ; DW F ->
                                        |-f- D ; N ; DW G ->
                                        |-f- BD ; MN ; DW (MAnd F G)
  | tri_plus1' : forall B M F G ,
      |-f- B ; M ; DW F -> |-f- B ; M ; DW (AOr F G)
  | tri_plus2' : forall B M F G,
      |-f- B ; M ; DW G -> |-f- B ; M ; DW (AOr F G)
  | tri_rel' : forall B F L,
      negativeFormula F -> |-f- B ; L ; UP [F] ->  |-f- B ; L ; DW F
  | tri_top' : forall B L M,
      |-f- B ; L ; UP (Top :: M)
  | tri_bot' : forall B L M,
      |-f- B ; L ; UP M -> |-f- B ; L ; UP (Bot :: M)
  | tri_par' : forall B L M F G,
      |-f- B ; L ; UP (F::G::M) -> |-f- B ; L ; UP((MOr F G) :: M)
  | tri_with' : forall B L M F G,
      |-f- B ; L ; UP (F :: M) ->
      |-f- B ; L ; UP (G :: M) -> |-f- B ; L ; UP ((AAnd F  G) :: M)
  | tri_quest' : forall B L M F i,
      |-f- (i,F)::B ; L ; UP M -> |-f- B ; L ; UP ((Quest i F) :: M)
  | tri_store' : forall B L M F,
      positiveLFormula  F-> |-f- B ; F::L; UP M -> |-f- B ; L ; UP (F::M)
  | tri_dec1' : forall B L L' F,
      positiveFormula F -> Permutation (F::L') L -> |-f- B ; L' ; DW F -> |-f- B ; L ; UP []
  | tri_dec2u' : forall B L F i,
     u i = true -> mt i = true -> ~IsPositiveAtom F -> In (i,F) B -> |-f- B ; L ; DW F -> |-f- B ; L ; UP []
  | tri_dec2l' : forall B B' L F i,
     u i = false -> mt i = true -> ~IsPositiveAtom F -> Permutation ((i,F)::B') B -> |-f- B' ; L ; DW F -> |-f- B ; L ; UP []

  | tri_dec3' : forall B L F ,
      theory F -> ~IsPositiveAtom F -> |-f- B ; L ; DW F -> |-f- B ; L ; UP []
  | tri_ex'  : forall B FX M t,
      uniform_oo FX -> proper t -> |-f- B; M ; DW (FX t) -> |-f- B; M ; DW (Some  FX)
  | tri_fx'  : forall B L FX M ,
      uniform_oo FX -> (forall x, proper x -> |-f- B ; L ; UP( (FX x) ::  M)) ->
      |-f- B ; L ; UP ((All FX) :: M)
 | tri_bangL' : forall B F,
    SetU B -> |-f- B ; [] ; (UP [F]) -> |-f- B ; [] ; DW (Bang loc F)

| tri_bang' : forall B F i, i <> loc ->
     tri_bangK4' B i [] [] (UP [F]) -> |-f- B ; [] ; DW (Bang i F)
| tri_bangD' : forall B i,  tri_bangK4' B i [] [] (UP []) -> md i = true -> |-f- B ; [] ; UP []
     with
      tri_bangK4' : list TypedFormula -> subexp -> list TypedFormula -> multiset oo -> Arrow -> Prop :=
       | tri_copyK4' : forall b F L M C B B' i, lt i b  -> m4 b = true ->
        Permutation ((b,F)::B') B-> tri_bangK4' B' i (C++[(plust b,F)]) L (UP M) ->
                                      tri_bangK4' B i C L (UP M)
       | tri_copyUK' : forall b F L M C B B' i, lt i b  -> m4 b = false -> u b = true ->
        Permutation ((b,F)::B') B -> tri_bangK4' B' i (C++[(loc,F)]) L (UP M) ->
                                      tri_bangK4' B i C L (UP M)
        | tri_copyLK' : forall b F L M C B B' i, lt i b  -> m4 b = false -> u b = false ->
        Permutation ((b,F)::B') B -> tri_bangK4' B' i C L (UP (M++[F])) ->
                                      tri_bangK4' B i C L (UP M)
       | tri_exp' : forall B C i L M , SetU B ->
                  |-f- C; L; UP M -> tri_bangK4' B i C L (UP M)

  where "'|-f-' B ';' L ';' X " := (seq B L X).

End LLSequent .

Module FLLNotations .

Notation "n ⊢ B ';' L ⇕ X " := (seqN _ n B L X)  (at level 80).
Notation "n ⊢ B ';' L ⇓ F " := (seqN _ n B L (DW F))  (at level 80).
Notation "n ⊢ B ';' L ⇑ F " := (seqN _ n B L (UP F))  (at level 80).
Notation "⊢ B ';' L ⇕ X " := (seq _ B L X)  (at level 80).
Notation "⊢ B ';' L ⇓ F " := (seq _ B L (DW F))  (at level 80).
Notation "⊢ B ';' L ⇑ F " := (seq _ B L (UP F))  (at level 80).

End FLLNotations .

Global Hint Constructors seqN seq: core .


From Coq Require Import Arith List.

Import ListNotations.

Set Implicit Arguments.

(** * Supplementary general tactics and results *)

Tactic Notation "spec" hyp(H) :=
  match type of H with ?a -> _ =>
  let H1 := fresh in (assert (H1: a);
  [|generalize (H H1); clear H H1; intro H]) end.
Tactic Notation "spec" hyp(H) constr(a) :=
  (generalize (H a); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) :=
  (generalize (H a b); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) :=
  (generalize (H a b c); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
  (generalize (H a b c d); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) :=
  (generalize (H a b c d e); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) :=
  (generalize (H a b c d e f); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr (g):=
  (generalize (H a b c d e f g); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr (g) constr(h) :=
  (generalize (H a b c d e f g h); clear H; intro H).

Lemma remove_subset :
  forall (A : Type) (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x1 x2 : A),
    In x1 (remove eq_dec x2 l) ->
    In x1 l.
Proof.
  intros A eq_dec l x1 x2 H_in.
  induction l as [|hd tl IHl].
  inversion H_in.
  simpl in H_in.
  destruct (eq_dec x2 hd). subst.
  spec IHl H_in. right. assumption.
  simpl in H_in. destruct H_in. subst. left; reflexivity.
  right. now apply IHl.
Qed.

Theorem modus_tollens : forall (P Q : Prop), (P -> Q) -> (~ Q -> ~ P).
Proof.
  intros P Q HPQ HQ.
  intro HP.
  contradict HQ.
  apply HPQ.
  assumption.
Qed.

Lemma le_S_disj :
  forall n m : nat,
    n <= S m -> n <= m \/ n = S m.
Proof.
  intros.
  inversion H.
  right; reflexivity.
  left; exact H1.
Qed.