(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for PTIntro layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MAL layer and MPTIntro layer*)
Require Import PTIntroGenDef.
Require Export PTIntroGenAccessorDef.

(** * Definition of the refinement relation*)
Section Refinement.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Require Import LoadStoreSem1.
    Require Import XOmega.
    Require Import HostAccess1.
    Require Import GuestAccessIntel1.
    Require Import HostAccess2.
    Require Import LoadStoreGeneral.

    Notation hStore := (fun F V => exec_storeex2 (flatmem_store := flatmem_store) (F:=F) (V:=V)).

    Notation lStore := (fun F V => exec_storeex1 (flatmem_store := flatmem_store) (F:=F) (V:=V)).

    Lemma store_correct:
      store_accessor_sim_def HDATAOps LDATAOps (one_crel HDATA LDATA) hStore lStore.
    Proof.
      unfold store_accessor_sim_def. intros.
      pose proof H2 as Hmatch.
      inv H2. inv match_extcall_states.

      unfold exec_storeex2 in *.
      unfold exec_storeex1.
      unfold exec_host_store1, exec_host_store2 in *.
      inv H4.
      exploit (eval_addrmode_correct ge1 ge2 a); eauto. intros HW.
      Local Opaque Z.sub.
      simpl in *. revert H1. inv match_related. subrewrite''. intros HLoad.
      destruct (eval_addrmode ge1 a rs1) eqn: Hev; contra_inv.
      - (* addr is Vint*)
        inv HW. destruct (ihost d2) eqn:HPH; contra_inv.
        destruct (pg d2) eqn:HPE; contra_inv.
        destruct (ikern d2) eqn:HPK; contra_inv.
        specialize (valid_PT refl_equal).
        + (* host *)
          generalize match_match; intros HM. inv match_match.
          inv H1. inv relate_PT_re.
          * (* PT = -1 *)
            rewrite <- H7 in valid_PT; omega.
          * assert (HFB: Genv.find_symbol ge2 PTPool_LOC = Some b).
            {
              inv H0. congruence.
            }
            rewrite HFB. lift_trivial. rewrite H8.
            assert (valid_PT': 0 <= PT d1 < 64) by omega.
            specialize (H5 _ valid_PT').
            set (pt := (ZMap.get (PT d1) (ptpool d1))) in *. inv H5.
            assert (HI: 0<= PDX (Int.unsigned i) <= PDX Int.max_unsigned).
            {
              specialize (Int.unsigned_range_2 i).
              clear. unfold PDX. Local Transparent Z.sub.
              xomega. Local Opaque Z.sub.
            }
            specialize (H7 _ HI).
            destruct H7 as [v[HLD [_ HP]]].
            assert (HI1: 0<= PTX (Int.unsigned i) <= PTX Int.max_unsigned).
            {
              unfold PTX; change ((Int.max_unsigned / 4096) mod 1024) with 1023.
              specialize (Z_mod_lt (Int.unsigned i/PgSize) one_k).
              omega.
            }
            inv HP; try rewrite <- H9 in HLoad; try rewrite <- H5 in HLoad; contra_inv.
            pose proof relate_PMap_re as HPP.
            inv HPP. specialize (H9 _ valid_PT' _ HI pi pdx).
            rewrite H5 in H9. specialize (H9 refl_equal _ HI1).
            destruct H9 as [v1[HLD1 HP]].
            rewrite Int.unsigned_repr; [|rewrite_omega].
            rewrite HLD, H7.
            rewrite Z_div_plus_full_l; [|omega].
            rewrite (Zdiv_small PT_PERM_PTU); [|omega].
            rewrite Z.add_0_r. rewrite HLD1. clear HLD1.
            destruct (zle (Int.unsigned i mod 4096) (4096 - size_chunk chunk)); contra_inv.
            destruct (Zdivide_dec (align_chunk chunk) (Int.unsigned i mod 4096)
                                  (Memdata.align_chunk_pos chunk)); contra_inv.
            inv HP; try rewrite <- H11 in HLoad; contra_inv.
            {
              change (Int.unsigned Int.zero mod 4096) with 0; simpl.
              eapply pagefault_correct; eauto.
            }
            {
              rewrite <- H9 in HLoad; contra_inv. rewrite H12.
              assert (HW1: (padr * PgSize + v) mod PgSize = v mod PgSize).
              {
                rewrite Zplus_mod.
                rewrite Z_mod_mult.
                rewrite Z.add_0_l.
                apply Zmod_mod.
              }
              assert (HW2: (padr * PgSize + v) / PgSize = padr).
              {
                rewrite Z_div_plus_full_l; [|omega].
                rewrite (Zdiv_small v). omega.
                functional inversion H11; subst; omega.
              }
              rewrite HW1, HW2.
              functional inversion H11; rewrite <- H13 in HLoad; contra_inv;
              (rewrite Zmod_small; trivial; [|omega]; simpl;
               eapply exec_flatmem_store_correct; eauto).
              apply PTADDR_mod_lt. assumption.
              apply PTADDR_mod_lt. assumption.
            }
        + (* guest *)
          eapply guest_intel_store_correct1; eauto.
      - (* adr is (b,ofs) *)
        inv HW; subdestruct; eapply storel_correct; eauto.
    Qed.

  End WITHMEM.

End Refinement.


Require Import VST.floyd.proofauto.
Require Import fastpile.
Require Import spec_stdlib.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition tlist := Tstruct _list noattr.
Definition tpile := Tstruct _pile noattr.

Definition sumlist : list Z -> Z := List.fold_right Z.add 0.

Definition pilerep (sigma: list Z) (p: val) : mpred :=
 EX s:Z, !! (0 <= s <= Int.max_signed /\
   Forall (Z.le 0) sigma /\
  (0 <= sumlist sigma <= Int.max_signed -> s=sumlist sigma))
   &&  data_at Ews tpile (Vint (Int.repr s)) p.

Definition pile_freeable (p: val) : mpred :=
            malloc_token Ews tpile p.

Lemma pilerep_local_facts:
  forall sigma p,
   pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold pilerep.
Intros q.
entailer!.
Qed.

Hint Resolve pilerep_local_facts : saturate_local.

Lemma pilerep_valid_pointer:
  forall sigma p,
   pilerep sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold pilerep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ _n OF tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       LOCAL (temp _n (Vint (Int.repr (sizeof t))); gvars gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() LOCAL(gvars gv) SEP(mem_mgr gv)
 POST[ tptr tpile ]
   EX p: val,
     PROP() LOCAL(temp ret_temp p)
     SEP(pilerep nil p; pile_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ _p OF tptr tpile, _n OF tint  ]
    PROP(0 <= n <= Int.max_signed)
    LOCAL(temp _p p; temp _n (Vint (Int.repr n)); gvars gv)
    SEP(pilerep sigma p; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep (n::sigma) p; mem_mgr gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ _p OF tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    LOCAL(temp _p p)
    SEP(pilerep sigma p)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ _p OF tptr tpile  ]
    PROP()
    LOCAL(temp _p p; gvars gv)
    SEP(pilerep sigma p; pile_freeable p; mem_mgr gv)
 POST[ tvoid ]
      PROP() LOCAL() SEP(mem_mgr gv).

Definition ispecs := [surely_malloc_spec].
Definition specs := [Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].


Require Import Prelude.
Require Import Infrastructure.
Require Import Regularity.
Require Import CanonicalForms.
Require Import Equations.

#[export] Hint Resolve binds_empty_inv.

Ltac empty_binding :=
  match goal with
  | H: binds ?x ?v empty |- _ => apply binds_empty_inv in H; contradiction
  | _ => fail "no empty bindings found"
  end.

Ltac IHT e :=
  match goal with
  | Ht: {?Σ, ?D, ?E} ⊢(?TT) e ∈ ?T |- _ =>
    match goal with
    | IH: forall T, ?P0 -> {Σ, D, E} ⊢(?TT2) e ∈ T -> ?P |- _ =>
      let H := fresh "IHt" in
      assert P as H; eauto
    end
  end.

Ltac generalize_typings :=
  match goal with
  | [ H: {?Σ, ?D, ?E} ⊢(?TT) ?e ∈ ?T |- _ ] =>
    match TT with
    | Tgen => fail 1
    | Treg => fail 1
    | _ => apply Tgen_from_any in H
    end
  end.

#[export] Hint Constructors value red.
Theorem progress_thm : progress.
Proof.
  unfold progress.
  introv Typ.
  assert (Hterm: term e).
  1: {
    eapply typing_implies_term; eauto.
  }
  apply Tgen_from_any in Typ. clear TT.

  gen T Hterm.
  induction e using trm_ind;
    introv TypGen Hterm;
    lets [T2 [TypReg EQ]]: inversion_typing_eq TypGen;
    inversion TypReg;
    inversion Hterm;
    subst;
    try solve [
          left*
        | repeat generalize_typings;
          forwards* [Hv1 | [e1' Hred1]]: IHe1;
          forwards* [Hv2 | [e2' Hred2]]: IHe2
        ]; clear TypGen EQ T; try rename T2 into T.
  - empty_binding.
  - repeat generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
  - generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H0.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 [v2 ?]]: CanonicalFormTuple Typ2; subst.
    right*.
  - generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H0.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 [v2 ?]]: CanonicalFormTuple Typ2; subst.
    right*.
  - repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe1.
    forwards * [Hval2 | [? ?]]: IHe2.
    right.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H5.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 ?]: CanonicalFormAbs Typ2; subst.
    eexists.
    apply* red_beta.
  - repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe.
    right.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H1.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 ?]: CanonicalFormTAbs Typ2; subst.
    eexists.
    apply* red_tbeta.
  - repeat generalize_typings.
    right.
    eexists.
    eauto.
  - right.
    rename l into branches.
    repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H2.
    apply empty_eq_is_equivalent in EQ; subst.
    lets* [GCargs [cid [ctor_e ?]]]: CanonicalFormGadt Typ2; subst.
    inversions Typ2.
    match goal with
    | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
      let H := fresh "H" in
      lets H: binds_ext H1 H2;
        inversions H
    end.
    match goal with
    | [ Hnth: List.nth_error ?As ?i = Some ?A |- _ ] =>
      match goal with
      | [ Hlen: length As = length ?Bs |- _ ] =>
        lets* [[clA clT] [nth_cl inzip]]: nth_error_implies_zip Hnth Hlen
      end
    end.
    assert (clA = length GCargs).
    * match goal with
      | [ H: forall def clause, List.In (def, clause) ?A -> clauseArity clause = Carity def |- _ ] =>
        lets*: H inzip
      end.
    * subst.
      eexists.
      eauto.
Qed.

Check progress_thm.


(* PREAMBLE *)

From compcert.cfrontend           Require Csyntax Csem.
From compcert.common              Require Values.
From compcert.lib                 Require Coqlib.

From trancert.lib                 Require All.
From trancert.analysis            Require Appears ImmediatePointers.
From trancert.simulations.memory  Require bijection.Def bijection.AST.

Import bijection.Def common.Values Memdata Csyntax BinNums Coqlib lib.All
       analysis.Appears analysis.ImmediatePointers bijection.AST.

Theorem biject_appears:
  forall f a b i,
    biject_expr f a b ->
    appears_expr i b ->
    appears_expr i a
  with biject_appears_exprlist:
         forall f a b i,
           biject_exprlist f a b ->
           appears_exprlist i b ->
           appears_exprlist i a.
Proof.
  {
    clear biject_appears.
    intros f a b i H H0.
    generalize dependent b.
    induction a;intros;
      try solve [
            match goal with | [H: biject_expr _ _ _|-_] => inv H end; auto;
            match goal with | [H: appears_expr _ _ |-_] => inv H end;
            unfold ExprQuant.expr_is_var; decomp
          |
          match goal with | [H: biject_expr _ _ _|-_] => inv H end;
          match goal with | [H: appears_expr _ _ |-_] => inv H end; eauto;
          unfold ExprQuant.expr_is_var in *; decomp
          |

          match goal with | [H: biject_expr _ _ _|-_] => inv H end;
          constructor;
          match goal with | [H: appears_expr _ _ |-_] => inv H end; eauto; decomp;
          [eapply IHa; eauto| unfold ExprQuant.expr_is_var in *; decomp]
          |
          constructor;
          match goal with | [H: biject_expr _ _ _|-_] => inv H end;
          match goal with | [H: appears_expr _ _ |-_] => inv H end; eauto; decomp;
          [
              exploit IHa1; eauto|
              exploit IHa2; eauto|
              unfold ExprQuant.expr_is_var in *; decomp]
          ].
    - inv H.
      constructor.
      inv H0; decomp;
          [
              exploit IHa1; eauto|
              exploit IHa2; eauto|
              exploit IHa3; eauto|
              unfold ExprQuant.expr_is_var in *; decomp
          ].
    - inv H.
      inv H0; decomp.
      constructor; eauto.
      + left. eapply IHa; eauto.
      + constructor. right. eapply biject_appears_exprlist; eauto.
      + unfold ExprQuant.expr_is_var in *; decomp.
    - inv H. constructor. inv H0.
      + eapply biject_appears_exprlist; eauto.
      + unfold ExprQuant.expr_is_var in *; decomp.
  }
  {
    clear biject_appears_exprlist.
    induction a; intros; auto; inv H; auto.
    constructor.
    inv H0; decomp.
    + eapply biject_appears in H1; eauto.
    + eapply IHa in H1; eauto.
  }
Qed.

Section NoPointers.
  Context (f: embedding).

  Theorem biject_expr_idemp:
    forall e, ~ expr_has_addr e -> biject_expr f e e
    with biject_exprlist_idemp:
           forall el, ~ exprlist_has_addr el -> biject_exprlist f el el.
  Proof.
    {
      clear biject_expr_idemp.
      induction e; intros; eauto; try solve [
                                        by constructor
                                      |
                                      constructor;
                                      [apply IHe1; contradict H; by constructor; eauto
                                      | apply IHe2; contradict H; by constructor; eauto
                                      ]
                                      | constructor;
                                        [ apply IHe1; contradict H; by constructor; eauto
                                        | apply IHe2; contradict H; by constructor; eauto
                                        | apply IHe3; contradict H; by constructor; eauto
                                        ]
                                      | constructor; eauto; eapply IHe; contradict H; by constructor
                                      ].
      - constructor.
        destruct v; constructor.
        contradict H. repeat constructor.
      - constructor.
        + eapply biject_exprlist_idemp; eauto.
          contradict H; by constructor; eauto.
        + eapply IHe.
          contradict H; by constructor; eauto.
      - constructor.
        + eapply biject_exprlist_idemp; eauto.
          contradict H; by constructor; eauto.
      - constructor.
        contradict H.
        repeat constructor.
    }
    {
      clear biject_exprlist_idemp.
      induction el; constructor.
      - eapply biject_expr_idemp; eauto.
        contradict H; by constructor; auto.
      - eapply IHel; eauto.
        contradict H; by constructor; auto.
    }
  Qed.

  Theorem biject_statement_idemp:
    forall e, ~ stmt_has_addr e -> biject_statement f e e
    with biject_labeled_statements_idemp:
           forall el, ~ ls_has_addr el -> biject_labeled_statements f el el.
  Proof.
    {
      clear biject_statement_idemp.
      induction e; intros; eauto; try constructor;
        try solve [ done |
                    eapply biject_expr_idemp; by contradict H; constructor; auto|
                    eapply IHe; contradict H; by constructor; eauto|
                    eapply IHe1; contradict H; by constructor; eauto|
                    eapply IHe2; contradict H; by constructor; eauto|
                    eapply IHe3; contradict H; by constructor; eauto].
      - destruct o.
        econstructor.
        + eapply biject_expr_idemp; by contradict H; constructor; auto.
        + constructor.
      -  eapply biject_labeled_statements_idemp.
         contradict H.
           by constructor; auto.
    }
    {
      clear biject_labeled_statements_idemp.
      induction el; constructor.
      - apply biject_statement_idemp. contradict H. constructor; auto.
      - apply IHel; contradict H. constructor; auto.
    }
  Qed.

End NoPointers.


Require Export DEX_ElemLemmas.

Import DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_BigStep.DEX_Dom DEX_Prog.

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.

Lemma some_eq: forall (A:Type) (x y:A), Some x = Some y -> x = y.
Proof. intros; inversion H; auto. Qed.

Lemma leql_join_eq: forall (k k1 k2: L.t) , k2 = L.join k k1 -> L.leql k k2.
Proof. intros. subst; apply leql_join2; apply L.leql_refl; auto. Qed.

Ltac indist2_intra_normal_aux Hindistreg rn:=
  specialize Hindistreg with rn;
  inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist];
  try (constructor 1 with (k:=lvl) (k':=lvl');
  try (rewrite MapList.get_update2; auto); auto);
  try (constructor 2; rewrite ?DEX_Registers.get_update_old; auto).

Lemma indist2_intra_normal :
 forall se reg m sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2',
   instructionAt m pc = Some i ->

   NormalStep se reg m sgn i (pc,r1) rt1 (pc2,r2) rt2 ->
   NormalStep se reg m sgn i (pc,r1') rt1' (pc2',r2') rt2' ->
   st_in kobs rt1 rt1' (pc,r1) (pc,r1') ->

   st_in kobs rt2 rt2' (pc2,r2) (pc2',r2').
Proof.
  intros se reg m sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2'
    Hins Hstep Hstep' Hindist.
  destruct i; simpl in Hstep, Hstep';
  inversion_clear Hstep in Hins Hstep' Hindist;
  inversion_clear Hstep' in Hindist;
  apply inv_st_in in Hindist;
  constructor; auto.
  (* DEX_Move *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k0 (se pc)) (k':=L.join k1 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H7; inversion H7; subst; apply not_leql_join1; auto.
    rewrite Hget' in H17; inversion H17; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H5 in Hvalueindist; rewrite <- H15 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Const *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    constructor 1. constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Ineg *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H5; inversion H5; subst; apply not_leql_join1; auto.
    rewrite Hget' in H14; inversion H14; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H4 in Hvalueindist; rewrite <- H13 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H15. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_Inot *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H5; inversion H5; subst; apply not_leql_join1; auto.
    rewrite Hget' in H14; inversion H14; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H4 in Hvalueindist; rewrite <- H13 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H15. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX I2b *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H5; inversion H5; subst; apply not_leql_join1; auto.
    rewrite Hget' in H14; inversion H14; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H4 in Hvalueindist; rewrite <- H13 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H15. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_I2s *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=rs).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H5; inversion H5; subst; apply not_leql_join1; auto.
    rewrite Hget' in H14; inversion H14; subst; apply not_leql_join1; auto.
    constructor 2. rewrite <- H4 in Hvalueindist; rewrite <- H13 in Hvalueindist.
    rewrite ?DEX_Registers.get_update_new; auto.
    inversion Hvalueindist. inversion H15. constructor 1; constructor.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_IBinop *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    assert (Hindistreg' := Hindistreg).
    specialize Hindistreg with (rn:=ra).
    specialize Hindistreg' with (rn:=rb).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k1 (L.join k2 (se pc))) (k':=L.join k0 (L.join k3 (se pc)));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H8; inversion H8; subst; apply not_leql_join1; auto.
    rewrite Hget' in H21; inversion H21; subst; apply not_leql_join1; auto.
    (* case of register b *)
    inversion Hindistreg' as [lvl2 lvl2' Hget2 Hget2' Hleq2 Hleq2' | Hvalueindist'].
    constructor 1 with (k:=L.join k1 (L.join k2 (se pc))) (k':=L.join k0 (L.join k3 (se pc)));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget2 in H9; inversion H9; subst.
    apply not_leql_join2; apply not_leql_join1; auto.
    rewrite Hget2' in H22; inversion H22; subst.
    apply not_leql_join2; apply not_leql_join1; auto.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    rewrite <- H6 in Hvalueindist; rewrite <- H19 in Hvalueindist.
    rewrite <- H7 in Hvalueindist'; rewrite <- H20 in Hvalueindist'.
    inversion Hvalueindist as [v v' Hin | Hnone]; inversion Hvalueindist' as [v2 v2' Hin' | Hnone'];
    inversion Hin; inversion Hin'. repeat (constructor); auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.
  (* DEX_IBinopConst *)
  subst.
  inversion Hindist as [Heqset Hindistreg].
  constructor; auto.
  (* proving eq_set *)
  rewrite MapList.domain_inv; auto. rewrite MapList.domain_inv; auto.
  intros rn.
  destruct Reg_eq_dec with (x:=rn) (y:=rt) as [Hreg | Hreg].
    (* rn = rt *)
    rewrite Hreg.
    specialize Hindistreg with (rn:=r).
    inversion Hindistreg as [lvl lvl' Hget Hget' Hleq Hleq' | Hvalueindist].
    constructor 1 with (k:=L.join k (se pc)) (k':=L.join k0 (se pc));
      try (rewrite MapList.get_update1; auto); auto.
    rewrite Hget in H5; inversion H5; subst; apply not_leql_join1; auto.
    rewrite Hget' in H14; inversion H14; subst; apply not_leql_join1; auto.
    constructor 2.
    rewrite ?DEX_Registers.get_update_new.
    rewrite <- H4 in Hvalueindist; rewrite <- H13 in Hvalueindist.
    inversion Hvalueindist as [val val' Hin | Hnone]; inversion Hin;
    repeat (constructor); auto.
    (* rn <> rt *)
    indist2_intra_normal_aux Hindistreg rn.

Qed.

End p.


Load loadpath.
Require Import ZArith Coq.Lists.List Permutation.
Require Import msl.Axioms.
Require Import msl.predicates_sa.
Require Import veric.Coqlib2.
Require Import veristar.variables veristar.datatypes veristar.clauses
               veristar.list_denote veristar.model_type veristar.model
               veristar.basic veristar.compare.

Module Type SPRED_LEMMAS.
Declare Module VSM : VERISTAR_MODEL.
Import VSM VeriStarLogic.

End SPRED_LEMMAS.

Module SPredLemmas (VSM : VERISTAR_MODEL) <: SPRED_LEMMAS
  with Module VSM := VSM.
Module VSM := VSM.
Import VSM VeriStarLogic.

Import sepalg.

(* properties of spred operators *)

Module spred. Section spred.
Variables x y z : spred.

Local Open Scope pred.

Lemma andpN : x && TT = x.
Proof. apply andp_TT. Qed.

Lemma andpS : x && y = y && x.
Proof. apply andp_comm. Qed.

Lemma andpA : x && (y && z) = (x && y) && z.
Proof. rewrite andp_assoc; auto. Qed.

Lemma orpN : x || FF = x.
Proof.
extensionality; apply prop_ext; split; [solve[intros [H|H]; [auto|case H]; auto]
|solve[left; auto]].
Qed.

Lemma orpS : x || y = y || x.
Proof. apply union_com. Qed.

Lemma orpA : x || (y || z) = (x || y) || z.
Proof. rewrite union_assoc; auto. Qed.

Lemma sepconS : sepcon x y = sepcon y x.
Proof. apply sepcon_comm. Qed.

Lemma sepconA : x * (y * z) = (x * y) * z.
Proof. rewrite sepcon_assoc; auto. Qed.

End spred. End spred.

Lemma emp_sep_emp h h1 h2 : join h h1 h2 -> emp h -> emp h1 -> emp h2.
Proof. intros; rewrite <-(emp_sepcon emp); exists h; exists h1; split; auto. Qed.

Lemma space_denote_permute l l' :
  Permutation l l' -> space_denote l = space_denote l'.
Proof.
intros;
apply (listd_perm space_atom_denote _ emp spred.sepconS spred.sepconA l l' H).
Qed.

Lemma space_insert sa l :
  space_denote (insert (rev_cmp compare_space_atom) sa l) =
  space_denote (sa :: l).
Proof.
intros; eapply listd_perm;
[apply spred.sepconS|apply spred.sepconA|apply perm_insert].
Qed.

Lemma eq_space_atomlist_sound (al bl : list space_atom) :
  true = eq_space_atomlist al bl ->
  space_denote al = space_denote bl.
Proof.
intros H; unfold eq_space_atomlist, isEq in H.
remember (compare_list compare_space_atom al bl) as j; destruct j; inversion H.
solve[apply comp_eq in Heqj; subst; auto].
Qed.

Lemma expr_eq_eq' : forall e1 e2, true = expr_eq e1 e2 -> e1=e2.
Proof.
unfold expr_eq; intros; do_comp expr_cspec e1 e2; subst; auto; congruence.
Qed.

Lemma pure_atom_denote_order_eqv_pure_atom : forall a,
  pure_atom_denote a = pure_atom_denote (order_eqv_pure_atom a).
Proof.
intros; destruct a; unfold pure_atom_denote in *; simpl in *.
remember (expr_cmp e e0) as b; destruct b; try reflexivity.
solve[apply var_eq_sym'].
Qed.

Lemma list_denote_normalize_pure_atoms:
 forall Q (B:spred) (l:list pure_atom)
     (Qassoc: forall x y z , Q x (Q y z) = Q (Q x y) z)
     (Qsymm: forall x y, Q x y = Q y x)
     (Hcmp: forall x y, Eq = pure_atom_cmp x y ->
                        (forall P, Q (pure_atom_denote x) (Q (pure_atom_denote y) P) = Q (pure_atom_denote y) P)),
list_denote pure_atom_denote Q B l =
list_denote pure_atom_denote Q B (normalize_atoms l).
Proof.
intros.
unfold normalize_atoms.
  rewrite listd_sort_uniq.
    rewrite listd_map.
      reflexivity.
      intros. rewrite <- pure_atom_denote_order_eqv_pure_atom. trivial.
      apply Qsymm.
      apply Qassoc.
    apply Hcmp.
Qed.

Lemma union_contractive:
forall {A} x, (@orp A) x x = x.
Proof.
intros. unfold orp.
extensionality a. apply prop_ext. split; intros.
 destruct H; assumption. left; assumption.
Qed.

Lemma list_denote_union_normalize_pure_atoms:
 forall(B:spred) (l:list pure_atom),
list_denote pure_atom_denote (@orp state) B l =
list_denote pure_atom_denote (@orp state) B (normalize_atoms l).
Proof.
intros.
apply list_denote_normalize_pure_atoms.
  intros. rewrite union_assoc; trivial.
  intros. rewrite union_com; trivial.
  intros. rewrite <- pure_atom_cmp_eq in H. rewrite H.
      rewrite <- union_assoc.
      rewrite union_contractive. reflexivity.
Qed.

Lemma intersection_contractive:
forall {A} x, (@andp A) x x = x.
Proof.
intros. unfold andp.
extensionality a. apply prop_ext. split; intros. destruct H; assumption. split; assumption.
Qed.

Lemma list_denote_intersection_normalize_pure_atoms:
 forall(B:spred) (l:list pure_atom),
list_denote pure_atom_denote (@andp state) B l =
list_denote pure_atom_denote (@andp state) B (normalize_atoms l).
Proof.
intros.
apply list_denote_normalize_pure_atoms.
  intros. rewrite andp_assoc; trivial.
  intros. rewrite andp_comm; trivial.
  intros.
  rewrite <- pure_atom_cmp_eq in H. rewrite H.
      rewrite <- andp_assoc.
      rewrite intersection_contractive. reflexivity.
Qed.

Lemma expr_cmp_eq: forall e e',
  expr_cmp e e' = Eq -> (e === e') = TT.
Proof.
intros.
extensionality s; apply prop_ext.
split; intros; trivial.
clear H0.
destruct e; simpl.
  destruct e'; simpl. reflexivity. inversion H.
  destruct e'; simpl. inversion H.
    inversion H.
symmetry in H. apply comp_eq in H; auto.
inversion H; subst; reflexivity.
Qed.

Lemma expr_cmp_eq': forall e e' s,
  expr_cmp e e' = Eq -> (e === e') s.
Proof.
intros.
rewrite (expr_cmp_eq _ _ H). trivial.
Qed.

Lemma list_denote_intersection_filter_nonreflex:
 forall(B:spred) (l:list pure_atom),
list_denote pure_atom_denote (@andp state) B l =
list_denote pure_atom_denote (@andp state) B (filter nonreflex_atom l).
Proof.
intros.
induction l; simpl. reflexivity.
rewrite IHl. clear IHl.
remember (nonreflex_atom a) as b; destruct b; simpl.
  reflexivity.
destruct a; simpl in *.
  assert (expr_cmp e e0 = Eq).
    remember (expr_cmp e e0) as b; destruct b; try reflexivity.
    inversion Heqb. inversion Heqb.
  clear Heqb.
rewrite (expr_cmp_eq _ _ H). rewrite TT_and. reflexivity.
Qed.

Lemma list_denote_normalize_filter_nonreflex_atom:
forall B l,
list_denote pure_atom_denote (@andp state) B
            (normalize_atoms (filter nonreflex_atom l))
= list_denote pure_atom_denote (@andp state) B l.
Proof.
intros.
rewrite <- list_denote_intersection_normalize_pure_atoms.
rewrite <- list_denote_intersection_filter_nonreflex; reflexivity.
Qed.

Lemma list_denote_inter_app : forall {A} (f: A -> spred) cs1 cs2 s,
  list_denote f (@andp state) TT (cs1 ++ cs2) s ->
  (list_denote f (@andp state) TT cs1 s /\
   list_denote f (@andp state) TT cs2 s).
Proof.
intros A f.
induction cs1; simpl; intros.
  split. trivial. assumption.
destruct H as [H1 H2].
 destruct (IHcs1 _ _ H2) as [H3 H4].
 split. split; assumption. assumption.
Qed.

Lemma list_denote_assoc_sym_id : forall {A T} (E: A -> T) Q B C l
  (CID : forall x, Q x C = x)
  (QSYM : forall x y, Q x y = Q y x)
  (QASSOC : forall x y z, Q x (Q y z) = Q (Q x y) z),
  list_denote E Q B l = Q B (list_denote E Q C l).
Proof.
intros.
induction l; simpl; intros; auto.
rewrite IHl. rewrite QSYM. rewrite <- QASSOC.
pattern (Q (list_denote E Q C l) (E a)).
rewrite QSYM. auto.
Qed.

Lemma list_denote_union_left : forall {A} (f: A -> spred) cs1 cs2 s,
  list_denote f (@orp state) FF cs1 s ->
  list_denote f (@orp state) FF (cs1 ++ cs2) s.
Proof.
intros.
rewrite listd_app.
rewrite (@listd_unfold_un _ state).
left. assumption.
Qed.

Lemma list_denote_union_right : forall {A} (f: A -> spred) cs1 cs2 s,
  list_denote f (@orp state) FF cs2 s ->
  list_denote f (@orp state) FF (cs1 ++ cs2) s.
Proof.
intros.
rewrite listd_app.
rewrite (@listd_unfold_un _ state).
right. assumption.
Qed.

Lemma list_denote_sepcon_sort :
  forall {A} (E:A -> spred) (B:spred) (l:list A) cmp s,
    list_denote E sepcon B l s <->
    list_denote E sepcon B (rsort cmp l) s.
Proof.
intros.
rewrite (listd_sort). split; trivial.
intros; rewrite sepcon_comm; auto.
intros; rewrite sepcon_assoc; auto.
Qed.

Lemma empty_not_singleton: forall c, M.empty <> M.singleton c.
 Proof. intros. intro.
   contradiction (@M.empty_spec c).
   rewrite H. rewrite M.singleton_spec. auto.
Qed.

Lemma singleton_inv:
  forall x y, M.singleton x = M.singleton y -> x=y.
Proof.
intros.
apply (M.singleton_spec y).
rewrite <- H. apply M.singleton_spec. auto.
Qed.

Lemma elements_singleton: forall c, M.elements (M.singleton c) = [c].
Proof.
intros.
assert (X:= M.singleton_spec c).
assert (ND := M.elements_spec2w (M.singleton c)).
inversion ND; clear ND.
  apply False_ind.
  remember (M.elements (M.singleton c)) as l.
  destruct l.
    apply eq_sym in Heql.
    apply empty_set_elems' in Heql.
    unfold M.Empty in Heql. apply (Heql c). apply X. trivial.
  inversion H0.
assert (x = c).
  apply X. rewrite <- elements_In. rewrite <- H. left. trivial.
subst.
destruct l. trivial.
assert (c0 = c).
  apply X. rewrite <- elements_In. rewrite <- H. right. left. trivial.
subst. exfalso. apply H0. left. trivial.
Qed.

Lemma var_eq_Next: forall e e' g g' s, (e === e') s -> (g === g') s ->
space_atom_denote (Next e g) s = space_atom_denote (Next e' g') s.
Proof.
intros; simpl.
apply prop_ext; split; intros.
  rewrite H in H1. rewrite H0 in H1. assumption.
  rewrite H. rewrite H0. assumption.
Qed.

Lemma var_eq_Lseg1: forall e e' g s, (e === e') s ->
space_atom_denote (Lseg e g) s = space_atom_denote (Lseg e' g) s.
Proof.
intros; simpl.
rewrite H; auto.
Qed.

Lemma var_eq_Lseg2: forall g e e' s, (e === e') s ->
space_atom_denote (Lseg g e) s = space_atom_denote (Lseg g e') s.
Proof.
intros; simpl.
rewrite H; auto.
Qed.

Lemma var_eq_Lseg: forall e e' g g' s, (e === e') s -> (g === g') s ->
space_atom_denote (Lseg e g) s = space_atom_denote (Lseg e' g') s.
Proof.
intros.
eapply eq_trans. apply var_eq_Lseg2. apply H0.
apply var_eq_Lseg1. apply H.
Qed.

Lemma join_stacks_eq : forall s0 s1 s : state,
  join s0 s1 s -> stk s0=stk s1 /\ stk s0=stk s.
Proof.
intros.
destruct H. destruct H.
subst; split; auto.
transitivity (stk s1); auto.
Qed.

Lemma expr_denote_join: forall e s r t,
join s r t -> expr_denote e t = expr_denote e s.
Proof.
intros.
destruct e; simpl in H; simpl; intros. trivial.
destruct (join_stacks_eq _ _ _ H) as [_ D].
rewrite <- D. trivial.
Qed.

Lemma expr_denote_eq_dec_loc:
   forall x y s,
        nil_or_loc (expr_denote x s) ->
        Decidable.decidable (expr_denote x s = expr_denote y s).
Proof.
intros.
destruct H.
rewrite H.
destruct (nil_dec (expr_denote y s)); [left | right]; auto.
destruct H as [l ?].
case_eq (val2loc (expr_denote y s)); intros.
destruct (loc_eq_dec l l0).
left; subst.
eapply val2loc_inj; eauto.
right.
contradict H1. rewrite H1 in *. congruence.
right.
intro.
rewrite H1 in *; congruence.
Qed.

Lemma expr_denote_heap_ind : forall x s h h',
  expr_denote x (State s h)=expr_denote x (State s h').
Proof.
intros. destruct x; auto.
Qed.

Lemma state_join_var_eq : forall (s0 s1 s : state) x y,
  join s0 s1 s ->
  (x === y) s0 ->
  (x === y) s.
Proof.
intros.
destruct s; destruct s0; destruct s1. destruct H. simpl in *. destruct H.
unfold var_eq in *; subst; auto.
Qed.

Lemma state_join_var_eq' : forall (s0 s1 s : state) x y,
  join s0 s1 s ->
  (x === y) s ->
  (x === y) s0.
Proof.
intros.
destruct s; destruct s0; destruct s1. destruct H. simpl in *. destruct H.
unfold var_eq in *; subst; auto.
Qed.

Lemma unXX {A:Type} (P: pred A) b : un P (un P b) = un P b.
Proof.
extensionality a; apply prop_ext; split; firstorder.
Qed.

Lemma lseg_appN: forall x y s r t,
 lseg x y s -> lseg y nil_val r -> join s r t -> lseg x nil_val t.
Proof.
intros.
revert r H0 t H1; induction H; intros.
apply join_unit1_e in H2; auto. subst; auto.
specialize (IHlseg _ H4).
destruct (join_assoc H3 H5) as [hf [? ?]].
specialize (IHlseg _ H6).
econstructor 2; eauto.
intro; subst. rewrite nil_not_loc in H0; inversion H0.
Qed.

Lemma pure_atom_denote_heap_ind: forall a s h h',
pure_atom_denote a (State s h) = pure_atom_denote a (State s h').
Proof.
intros.
destruct a; simpl.
unfold var_eq. simpl.
rewrite (expr_denote_heap_ind e s h h').
rewrite (expr_denote_heap_ind e0 s h h').
reflexivity.
Qed.

Lemma pure_atoms_denote_intersection_heap_ind: forall Delta s h h',
list_denote pure_atom_denote (@andp state) TT Delta (State s h) =
list_denote pure_atom_denote (@andp state) TT Delta (State s h').
Proof.
intros Delta.
induction Delta; simpl; intros.
  reflexivity.
apply prop_ext.
split; intros; destruct H.
  split. rewrite <- (pure_atom_denote_heap_ind a s h h'). assumption.
  rewrite <- (IHDelta s h h'). assumption.
split. rewrite (pure_atom_denote_heap_ind a s h h'). assumption.
  rewrite (IHDelta s h h'). assumption.
Qed.

Lemma pure_atoms_denote_union_heap_ind: forall Delta s h h',
list_denote pure_atom_denote (@orp state) FF Delta (State s h) =
list_denote pure_atom_denote (@orp state) FF Delta (State s h').
Proof.
intros Delta.
induction Delta; simpl; intros.
  reflexivity.
apply prop_ext.
split; intros; destruct H.
  left. rewrite <- (pure_atom_denote_heap_ind a s h h'). assumption.
  right. rewrite <- (IHDelta s h h'). assumption.
left. rewrite (pure_atom_denote_heap_ind a s h h'). assumption.
  right. rewrite (IHDelta s h h'). assumption.
Qed.

Lemma lseg_nil_or_loc:
  forall x y h, lseg x y h -> nil_or_loc y.
Proof.
induction 1; auto.
Qed.

Lemma lseg_end: forall x y h,
  lseg x y h -> (x = y /\ emp h) \/ y = nil_val \/
     (exists l, val2loc y = Some l /\ emp_at l h).
Proof.
induction 1; intros; auto.
right.
destruct IHlseg as [[? ?] | [?|[l [? ?]]]]; auto.
subst.
apply join_unit2_e in H3; auto. subst h0.
apply lseg_nil_or_loc in H2.
clear H5.
destruct H2; auto; right.
destruct H2 as [l ?]; exists l.
split; auto.
apply (rawnext_out H1 H2).
contradict H.
subst l.
apply val2loc_inj with x'; auto.
right; exists l.
split; auto.
apply emp_at_join with l in H3.
apply H3. split; auto.
assert (l<>x') by (contradict H; subst; eapply val2loc_inj; eauto).
eapply rawnext_out; eauto.
Qed.

Lemma lseg_lseg_app: forall x y z h1 h2 h tz,
  lseg x y h1 ->
  lseg y z h2 ->
  join h2 h1 h ->
 val2loc z = Some tz ->
  emp_at tz h ->
  lseg x z h.
Proof.
intros.
revert z h2 H0 h H1 tz H2 H3; induction H; intros.
apply join_unit2_e in H2; auto; subst; auto.
specialize (IHlseg _ _ H4).
destruct (join_assoc H3 (join_comm H5)) as [hf [? ?]].
specialize (IHlseg _ (@join_comm _ _ Perm_heap _ _ _ H8) _ H6).
assert (emp_at tz hf). apply emp_at_join with tz in H9. apply H9 in H7. destruct H7; auto.
specialize (IHlseg H10).
eapply lseg_cons; eauto.
intro; subst z0.
assert (x'=tz) by congruence. subst x'.
clear H6.
apply emp_at_join with tz in H9.
apply H9 in H7. destruct H7.
clear - H1 H6. eapply rawnext_not_emp; eauto.
eapply rawnext2rawnext'; eauto.
Qed.

Lemma Space_denote_cons: forall a L,
space_denote (a::L) = sepcon (space_atom_denote a) (space_denote L).
Proof.
intros.
apply listd_cons.
Qed.

Lemma Space_denote_app: forall M L,
space_denote (M ++ L) = sepcon (space_denote M) (space_denote L).
Proof.
intros M.
induction M; simpl.
  intros. rewrite (emp_sepcon (space_denote L)). trivial.
intros.
  rewrite (IHM L). rewrite sepconA; auto with typeclass_instances.
Qed.

Lemma Space_denote_rev: forall L,
space_denote (rev L) = (space_denote L).
Proof.
intros.
apply space_denote_permute. apply Permutation_sym.  apply Permutation_rev.
Qed.

End SPredLemmas.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From fcsl
Require Import pred.
From scilla
Require Import Automata2.
From scilla
Require Import options.

Section Crowdfunding.
(* Encoding of the Crowdfunding contract from the Scilla whitepaper *)

(******************************************************
contract Crowdfunding
 (owner     : address,
  max_block : uint,
  goal      : uint)

(* Mutable state description *)
{
  backers : address => uint = [];
  funded  : boolean = false;
}

(* Transition 1: Donating money *)
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)

(* Transition 2: Sending the funds to the owner *)
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block < blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)

(* Transition 3: Reclaim funds by a backer *)
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)

 *******************************************************)

Record crowdState := CS {
   owner_mb_goal : address * nat * value;
   backers : seq (address * value);
   funded : bool;
}.

(* Administrative setters/getters *)
Definition get_owner cs : address := (owner_mb_goal cs).1.1.
Definition get_goal cs : value := (owner_mb_goal cs).2.
Definition get_max_block cs : nat := (owner_mb_goal cs).1.2.

Definition set_backers cs bs : crowdState :=
  CS (owner_mb_goal cs) bs (funded cs).

Definition set_funded cs f : crowdState :=
  CS (owner_mb_goal cs) (backers cs) f.

(* Parameters *)
Variable init_owner : address.
Variable init_max_block : nat.
Variable init_goal : value.

(* Initial state *)
Definition init_state := CS (init_owner, init_max_block, init_max_block) [::] false.

(*********************************************************)
(********************* Transitions ***********************)
(*********************************************************)

(* Transition 1 *)
(*
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)
 *)

(* Definition of the protocol *)
Variable crowd_addr : address.

Notation tft := (trans_fun_type crowdState).
Definition ok_msg := [:: (0, [:: 1])].
Definition no_msg := [:: (0, [:: 0])].

Definition donate_tag := 1.
Definition donate_fun : tft := fun id bal s m bc =>
  if method m == donate_tag then
    let bs := backers s in
    let nxt_block := block_num bc + 1 in
    let from := sender m in
    if get_max_block s <= nxt_block
    then (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else if all [pred e | e.1 != from] bs
         (* new backer *)
         then let bs' := (from, val m) :: bs in
              let s'  := set_backers s bs' in
              (s', Some (Msg 0 crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition donate := CTrans donate_tag donate_fun.

(* Transition 2: Sending the funds to the owner *)
(*
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block < blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)
 *)

Definition getfunds_tag := 2.
Definition getfunds_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if (method m == getfunds_tag) && (from == (get_owner s)) then
    let blk := block_num bc + 1 in
    if (get_max_block s < blk)
    then if get_goal s <= bal
         then let s' := set_funded s true in
              (s', Some (Msg bal crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition get_funds := CTrans getfunds_tag getfunds_fun.

(* Transition 3: Reclaim funds by a backer *)
(*
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)
*)

Definition claim_tag := 3.
Definition claim_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if method m == claim_tag then
    let blk := block_num bc in
    if blk <= get_max_block s
    then
      (* Too early! *)
      (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else let bs := backers s in
         if [|| funded s | get_goal s <= bal]
         (* Cannot reimburse: campaign suceeded *)
         then (s, Some (Msg 0 crowd_addr from 0 no_msg))
         else let n := seq.find [pred e | e.1 == from] bs in
              if n < size bs
              then let v := nth 0 (map snd bs) n in
                   let bs' := filter [pred e | e.1 != from] bs in
                   let s'  := set_backers s bs' in
                   (s', Some (Msg v crowd_addr from 0 ok_msg))
              else
                (* Didn't back or already claimed *)
                (s, None)
  else (s, None).

Definition claim := CTrans claim_tag claim_fun.

Program Definition crowd_prot : Protocol crowdState :=
  @CProt _ crowd_addr 0 init_state [:: donate; get_funds; claim] _.

Lemma crowd_tags : tags crowd_prot = [:: 1; 2; 3].
Proof. by []. Qed.

Lemma find_leq {A : eqType} (p : pred (A * nat)) (bs : seq (A * nat)) :
  nth 0 [seq i.2 | i <- bs] (seq.find p bs) <= sumn [seq i.2 | i <- bs].
Proof.
elim: bs=>//[[a w]]bs/=Gi; case:ifP=>_/=; first by rewrite leq_addr.
by rewrite (leq_trans Gi (leq_addl w _)).
Qed.

(***********************************************************)
(**             Correctness properties                    **)
(***********************************************************)

(************************************************************************

1. The contract always has sufficient balance to reimburse everyone,
unless it's successfully finished its campaign:

The "funded" flag is set only if the campaign goals were reached, then
all money goes to owner. Otherwise, the contract keeps all its money
intact.

Perhaps, we should make it stronger, adding a temporal property that
one's reimbursement doesn't change.

************************************************************************)

Definition balance_backed (st: cstate crowdState) : Prop :=
  (* If the campaign not funded... *)
  ~~ (funded (state st)) ->
  (* the contract has enough funds to reimburse everyone. *)
  sumn (map snd (backers (state st))) <= balance st.

Lemma sufficient_funds_safe : safe crowd_prot balance_backed.
Proof.
apply: safe_ind=>[|[id bal s]bc m M Hi]//.
rewrite crowd_tags !inE in M.
(* Get the exact transitions and start struggling... *)
rewrite /= /apply_prot; case/orP: M; [|case/orP]=>/eqP M; rewrite M/=.

(* Donate transition *)
rewrite /donate_fun M eqxx.
case: ifP=>/=_; [move=> {}/Hi Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>/=_; move=> {}/Hi Hi; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
by rewrite subn0 /balance_backed/= in Hi *; rewrite addnC leq_add2r.

(* Get funds transition. *)
rewrite /getfunds_fun M eqxx.
case: ifP=>//=_; case:ifP=>//=_;[|move=> {}/Hi Hi]; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=_; move=> {}/Hi Hi.
by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).

(* Claim funds back *)
rewrite /claim_fun M eqxx.
case: ifP=>//=_; [move=> {}/Hi Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=X.
- case/orP: X; first by rewrite /balance_backed/==>->.
  by move=>_/Hi Z; rewrite subn0; apply: (leq_trans Z (leq_addr (val m) bal)).
case: ifP=>//=G/=; move=> {}/Hi /= Hi.
rewrite addnC.
have H1: nth 0 [seq i.2 | i <- backers s]
             (seq.find [pred e | e.1 == sender m] (backers s)) <=
         sumn [seq i.2 | i <- backers s] by apply: find_leq.
move: (leq_trans H1 Hi)=> H2.
rewrite -(addnBA _ H2); clear H2.
suff H3: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         bal - nth 0 [seq i.2 | i <- backers s]
                   (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H3 (leq_addl (val m) _ )).
clear M.
suff H2: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         sumn [seq i.2 | i <- backers s] -
         nth 0 [seq i.2 | i <- backers s] (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H2); apply: leq_sub.
clear Hi H1 X G bc bal id crowd_addr init_goal init_max_block init_owner.
move: (backers s)=>bs{s}.
elim:bs=>//[[a v]] bs/= Hi/=; case:ifP; last first.
- move/negbT; case: ifP=>//= _ _; rewrite addnC -addnBA//subnn addn0.
  clear Hi; elim: bs=>//={a v}[[a v]]bs/=.
  case:ifP=>//=_ H; first by rewrite leq_add2l.
  by rewrite (leq_trans H (leq_addl _ _)).
move/negbTE=>->/={a}; rewrite -(leq_add2l v) in Hi.
by rewrite addnBA in Hi; last by apply: find_leq.
Qed.

(***********************************************************************)
(******           Proving temporal properties                     ******)
(***********************************************************************)

(* Contribution of backer b is d is recorded in the `backers` *)
Definition donated b (d : value) st :=
  (filter [pred e | e.1 == b] (backers (state st))) == [:: (b, d)].

(* b doesn't claim its funding back *)
Definition no_claims_from b (q : bstate * message) := sender q.2 != b.

(************************************************************************

2. The following lemma shows that the donation record is going to be
preserved by the protocol since the moment it's been contributed, as
long, as no messages from the corresponding backer b is sent to the
contract. This guarantees that the contract doesn't "drop" the record
about someone's donations.

In conjunctions with sufficient_funds_safe (proved above) this
guarantees that, if the campaign isn't funded, there is always a
necessary amount on the balance to reimburse each backer, in the case
of failure of the campaign.

************************************************************************)

Lemma donation_preserved (b : address) (d : value):
  since_as_long crowd_prot (donated b d)
                (fun _ s' => donated b d s') (no_claims_from b).
Proof.
(* This is where we would need a temporal logic, but, well.. *)
(* Let's prove it out of the definition. *)
elim=>[|[bc m] sc Hi]st st' P R; first by rewrite /reachable'=>/=Z; subst st'.
rewrite /reachable'/==>E.
apply: (Hi (post (step_prot crowd_prot st bc m))); last 2 first; clear Hi.
- by move=>q; move:(R q)=>{R}-R G; apply: R; apply/In_cons; right.
- rewrite E; set st1 := (step_prot crowd_prot st bc m); clear E R P.
  by case: sc st1=>//=[[bc' m']] sc st1/=.
clear E.
have N: sender m != b.
- suff B: no_claims_from b (bc, m) by [].
  by apply: R; apply/In_cons; left.
case M: (method m \in tags crowd_prot); last first.
- by move/negbT: M=>M; rewrite (bad_tag_step bc st M).
case: st P=>id a s; rewrite /donated/==>D.
case/orP: M; [|case/orP;[| rewrite orbC]]=>/eqP T;
rewrite /apply_prot T/=.
- rewrite /donate_fun T/=; case: ifP=>//_; case: ifP=>//_/=.
  by move/negbTE: N=>->.
- by rewrite /getfunds_fun T/=; case: ifP=>//_; case: ifP=>//_; case:ifP.
rewrite /claim_fun T/=; case:ifP=>//_; case: ifP=>//_; case: ifP=>//=X.
rewrite -filter_predI/=; move/eqP:D=><-; apply/eqP.
elim: (backers s)=>//=x xs Hi; rewrite Hi; clear Hi.
case B: (x.1 == b)=>//=.
by move/eqP: B=>?; subst b; move/negbTE: N; rewrite eq_sym=>/negbT=>->.
Qed.

(************************************************************************

3. The final property: if the campaign has failed (goal hasn't been
reached and the deadline has passed), every registered backer can get
its donation back.

TODO: formulate and prove it.

************************************************************************)

Lemma can_claim_back b d st bc:
  (* We have donated, so the contract holds that state *)
  donated b d st ->
  (* Not funded *)
  ~~(funded (state st)) ->
  (* Balance is small: not reached the goal *)
  balance st < (get_goal (state st)) ->
  (* Block number exceeds the set number *)
  get_max_block (state st) < block_num bc ->
  (* Can emit message from b *)
  exists (m : message),
    sender m == b /\
    out (step_prot crowd_prot st bc m) = Some (Msg d crowd_addr b 0 ok_msg).
Proof.
move=>D Nf Nb Nm.
exists (Msg 0 b crowd_addr claim_tag [::]); split=>//.
rewrite /step_prot.
case: st D Nf Nb Nm =>id bal s/= D Nf Nb Nm.
rewrite /apply_prot/=/claim_fun/=leqNgt Nm/= leqNgt Nb/=.
rewrite /donated/= in D.
move/negbTE: Nf=>->/=; rewrite -(has_find [pred e | e.1 == b]) has_filter.
move/eqP: D=>D; rewrite D/=.
congr (Some _); congr (Msg _ _ _ _ _).
elim: (backers s) D=>//[[a w]]bs/=; case:ifP; first by move/eqP=>->{a}/=_; case.
by move=>X Hi H; move/Hi: H=><-.
Qed.

(************************************************************************

4. Can we have a logic that allows to express all these properties
declaratively? Perhaps, we could do it in TLA?

(This is going to be our future work.)

************************************************************************)

End Crowdfunding.


From Undecidability Require Import TM.Util.TM_facts TM.Util.Relations.
From Undecidability.L Require Import LM_heap_def UnfoldClos Programs.
From Undecidability.L Require Import LambdaDepth.

Set Default Proof Using "Type".
Require Import FunInd.

Lemma lookup_el H alpha x c: lookup H alpha x = Some c -> exists beta, Some (c,beta) el H.
Proof.
  induction x in alpha, c|-*.
  all:cbn. all:destruct nth_error as [[[] | ]| ] eqn:eq.
  all:intros [= eq'].
  1:subst.
  all:eauto using nth_error_In.
Qed.

Definition boundHeap (H:Heap) maxPro maxVar maxDepth:=
  (forall a P beta, Some ((a,P),beta) el H ->
    sizeP P <= maxPro /\ a <= length H /\ beta <= length H /\ lambdaDepthP 1 P <= maxDepth/\ largestVarP P <= maxVar ).

Definition unfoldTailRecStep_sizes (H:Heap) maxPro maxVar maxDepth: list (HClos * nat) -> Prop :=
  fun stack =>
    forall a P k, ((a,P),k) el stack
      -> sizeP P <= maxPro
      /\ a <= length H
      /\ largestVarP P <= maxVar
      /\ lambdaDepthP k P <= maxDepth + 1.

Lemma unfoldTailRecStep_sizes_correct' H maxPro maxVar maxDepth a k s P s' stack stack' res fuel :
  boundHeap H maxPro maxVar maxDepth
  -> LM_heap_correct.unfolds H a k s s'
  -> ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel ((a,compile s++P,k)::stack,res) stack'
  -> (sizeP (compile s++P) <= maxPro /\ a <= length H /\ largestVarP (compile s++P) <= maxVar /\ lambdaDepthP k ((compile s++P)) <= maxDepth)
  -> (unfoldTailRecStep_sizes H maxPro maxVar maxDepth stack)
  -> (exists fuel', fuel' < fuel /\
      ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel' ((a,P,k)::stack,rev (compile s')++res) stack')
     \/ unfoldTailRecStep_sizes H maxPro maxVar maxDepth (fst stack').
Proof.
  intros HH.
  revert a k s P s' stack stack' res.
  induction fuel as [fuel IH] using lt_wf_ind.
  intros ? ? ? ? ? ? ? ? Hunf HR Hhd Htl.
  destruct fuel as [|fuel].
  {hnf in HR. subst stack'. cbn [fst]in *. right. intros ? ? ? [[= <- <- <-]|]. all:now eauto. }
  change (S fuel) with (1+fuel) in *. eapply pow_add in HR as (stack''&Hstep%(rcomp_1)&HR).
  symmetry in Hstep.
  induction Hunf in P,stack,Hstep,Hhd,Htl|-*. 1-3:cbn in Hstep.
  - destruct (Nat.leb_spec k n). now exfalso;nia.
    injection Hstep as [= <-]. left. eauto.
  - destruct (Nat.leb_spec k n). 2: now exfalso;nia.
    rewrite H1 in Hstep. injection Hstep as [= <-]. inv H2. inv Hunf.
    destruct (lookup_el H1) as (?&Hel). hnf in HH. specialize HH with (1:= Hel) as (?&?&?&?&?).
    specialize IH with (2:= H5) (P:=[]) as IH'. rewrite app_nil_r in IH'. specialize IH' with (2:=HR) as [(fuel'&?&IH')|IH'].
    + nia.
    + specialize (lambdaDepthP_min 1 (compile s0)). repeat simple apply conj;try nia.
    + hnf. intros ? ? ? [[= <- <- <-]|]. 2:now eauto.
      specialize (lambdaDepthP_min k P).
      cbn - [max] in Hhd|-*. repeat simple apply conj;try nia.
    + destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-] | [[= <- <- <-]| ]].
        3:now eauto. { cbn. unfold sizeP in *. nia. }
        cbn - [max] in Hhd|-*. unfold sizeP, largestVarP in *. specialize (lambdaDepthP_min k P). repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP, largestVarP in *. specialize (lambdaDepthP_min k P). repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      cbn. autorewrite with list;cbn. left;eexists;split. 2:eassumption. nia.
    +now right.
  - injection Hstep as [= <-]. cbn in Hhd. rewrite <- app_assoc in HR,Hhd.
    specialize IH with (2:=Hunf) (3:=HR) as [(fuel'&?&IH')|IH'].
    + nia.
    + cbn in Hhd|-*. unfold sizeP,largestVarP. nia.
    + easy.
    + cbn in Hhd|-*. autorewrite with list in Hhd|-*. rewrite lambdaDepthP_compile', maxl_app in Hhd. cbn - [max]in Hhd|-*.
      destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP in *. repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      left;do 2 eexists. 2:eassumption. nia.
    + easy.
  - cbn [compile] in Hstep,Hhd. rewrite <- !app_assoc in Hstep,Hhd.
    edestruct IHHunf1  as [(fuel'&?&IH')|IH']. 3:eassumption.
    1,2,4:easy.
    cbn in Hhd|-*. unfold sizeP,largestVarP in Hhd. autorewrite with list in Hhd|-*.
    rewrite !lambdaDepthP_compile', !maxl_app in Hhd. cbn - [max]in Hhd|-*.
    specialize IH with (3:=IH') as [(fuel''&?&IH'')|IH'']. 2:eassumption.
    + nia.
    + cbn in Hhd|-*. unfold sizeP,largestVarP in Hhd|-*. autorewrite with list. rewrite !lambdaDepthP_compile', !maxl_app;cbn.
      repeat simple apply conj;try nia.
    + easy.
    + destruct fuel'' as [|fuel''].
      {
        hnf in IH''. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP in *. repeat simple apply conj;try nia.
      }
      change (S fuel'') with (1+fuel'') in *. eapply pow_add in IH'' as (stack'''&Hstep'%(rcomp_1)&IH''').
      cbn in Hstep. injection Hstep' as [=->].
      left;do 2 eexists. 2:eassumption. nia.
    + easy.
Qed.

Lemma unfoldTailRecStep_sizes_correct H maxPro maxVar maxDepth a k s s' stack' res fuel :
  boundHeap H maxPro maxVar maxDepth
  -> LM_heap_correct.unfolds H a k s s'
  -> ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel ([(a,compile s,k)],res) stack'
  -> sizeP (compile s) <= maxPro /\ a <= length H /\ LargestVar.largestVar s<= maxVar /\ k + lambdaDepth s <= maxDepth
  -> unfoldTailRecStep_sizes H maxPro maxVar maxDepth (fst stack').
Proof.
  intros H1 H2 H3 ?.
  edestruct unfoldTailRecStep_sizes_correct' with (P:=@nil Tok) (1:=H1) (2:=H2)as [(fuel'&?&H')|H'].
  -rewrite app_nil_r. eassumption.
  -rewrite app_nil_r. rewrite lambdaDepthP_compile, largestVar_compile. easy.
  -easy.
  -destruct fuel'.
   { hnf in H'. subst stack';cbn. hnf. intros ? ? ? [[= <- <- <-]|[]];cbn. unfold sizeP in *. nia. }
   change (S fuel') with (1+fuel') in *. eapply pow_add in H' as (stack''&Hstep%(rcomp_1)&H').
   cbn in Hstep. injection Hstep as [=->].
   destruct fuel'.
   +hnf in H'. subst stack';cbn. hnf. easy.
   +exfalso.  change (S fuel') with (1+fuel') in *. eapply pow_add in H' as (stack''&Hstep%(rcomp_1)&_). easy.
  -easy.
Qed.

From Undecidability.L.AbstractMachines Require Import SizeAnalysisStep SubtermProperty.

Lemma abstractMachine_boundHeap k s a s0 H :
  ARS.pow step k (LM_heap_def.init s) ([], [(a, compile s0)], H) ->
  boundHeap H (sizeP (compile s)) (LargestVar.largestVar s) (lambdaDepth s).
Proof.
  intros H'. unfold boundHeap. intros ? ? ? HH.
  specialize subterm_property with (1:=H') as (_&_&Hsub). specialize Hsub with (1:=HH) as (?&?&tmp);cbn in tmp;subst P.
  specialize size_clos with (1:=H') as (_&Hlength). easy. specialize Hlength with (1:=HH) as (?&?&?&?).
  repeat simple apply conj;try eassumption.
  -apply lambdaDepth_subterm in H0 as <-. cbn. now rewrite lambdaDepthP_compile.
  -now rewrite <- largestVar_compile.
Qed.

Lemma abstractMachine_boundRes k s a s0 H :
  ARS.pow step k (LM_heap_def.init s) ([], [(a, compile s0)], H) ->
  sizeP (compile s0) <= sizeP (compile s) /\
  a <= | H | /\
  LargestVar.largestVar s0 <= LargestVar.largestVar s /\
  1 + lambdaDepth s0 <= lambdaDepth s.
Proof.
  intros H'.
  specialize subterm_property with (1:=H') as (_&Hsub&_). specialize Hsub as (?&?&tmp). now left.
  apply compile_inj in tmp as <-.
  specialize size_clos with (1:=H') as (Hlength&_). easy. specialize Hlength as (?&?&?). now left.
  repeat simple apply conj;try eassumption.
  -now rewrite <- !largestVar_compile.
  -apply lambdaDepth_subterm in H0 as <-. cbn. easy.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.MinMax.

(* Why3 assumption *)
Inductive list (a:Type) {a_WT:WhyType a} :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a] [a_WT]].
Implicit Arguments Cons [[a] [a_WT]].

(* Why3 assumption *)
Fixpoint infix_plpl {a:Type} {a_WT:WhyType a}(l1:(list a)) (l2:(list
  a)) {struct l1}: (list a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.

Axiom Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((infix_plpl l (Nil :(list a))) = l).

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a}(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.

Axiom Length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), (0%Z <= (length l))%Z.

Axiom Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), ((length (infix_plpl l1
  l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Fixpoint mem {a:Type} {a_WT:WhyType a}(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.

Axiom mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x
  l2)).

Axiom mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (infix_plpl l1 (Cons x l2))).

Axiom map : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, Type.
Parameter map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

Parameter const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).

Axiom Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Inductive datatype  :=
  | TYunit : datatype
  | TYint : datatype
  | TYbool : datatype .
Axiom datatype_WhyType : WhyType datatype.
Existing Instance datatype_WhyType.

(* Why3 assumption *)
Inductive value  :=
  | Vvoid : value
  | Vint : Z -> value
  | Vbool : bool -> value .
Axiom value_WhyType : WhyType value.
Existing Instance value_WhyType.

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

Axiom mident : Type.
Parameter mident_WhyType : WhyType mident.
Existing Instance mident_WhyType.

Axiom mident_decide : forall (m1:mident) (m2:mident), (m1 = m2) \/
  ~ (m1 = m2).

(* Why3 assumption *)
Inductive ident  :=
  | mk_ident : Z -> ident .
Axiom ident_WhyType : WhyType ident.
Existing Instance ident_WhyType.

(* Why3 assumption *)
Definition ident_index(v:ident): Z := match v with
  | (mk_ident x) => x
  end.

Parameter result: ident.

Axiom ident_decide : forall (m1:ident) (m2:ident), (m1 = m2) \/ ~ (m1 = m2).

(* Why3 assumption *)
Inductive term  :=
  | Tvalue : value -> term
  | Tvar : ident -> term
  | Tderef : mident -> term
  | Tbin : term -> operator -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint var_occurs_in_term(x:ident) (t:term) {struct t}: Prop :=
  match t with
  | (Tvalue _) => False
  | (Tvar i) => (x = i)
  | (Tderef _) => False
  | (Tbin t1 _ t2) => (var_occurs_in_term x t1) \/ (var_occurs_in_term x t2)
  end.

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : ident -> term -> fmla -> fmla
  | Fforall : ident -> datatype -> fmla -> fmla .
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Inductive expr  :=
  | Evalue : value -> expr
  | Ebin : expr -> operator -> expr -> expr
  | Evar : ident -> expr
  | Ederef : mident -> expr
  | Eassign : mident -> expr -> expr
  | Eseq : expr -> expr -> expr
  | Elet : ident -> expr -> expr -> expr
  | Eif : expr -> expr -> expr -> expr
  | Eassert : fmla -> expr
  | Ewhile : expr -> fmla -> expr -> expr .
Axiom expr_WhyType : WhyType expr.
Existing Instance expr_WhyType.

(* Why3 assumption *)
Definition type_value(v:value): datatype :=
  match v with
  | Vvoid => TYunit
  | (Vint int) => TYint
  | (Vbool bool1) => TYbool
  end.

(* Why3 assumption *)
Inductive type_operator : operator -> datatype -> datatype
  -> datatype -> Prop :=
  | Type_plus : (type_operator Oplus TYint TYint TYint)
  | Type_minus : (type_operator Ominus TYint TYint TYint)
  | Type_mult : (type_operator Omult TYint TYint TYint)
  | Type_le : (type_operator Ole TYint TYint TYbool).

(* Why3 assumption *)
Definition type_stack  := (list (ident* datatype)%type).

Parameter get_vartype: ident -> (list (ident* datatype)%type) -> datatype.

Axiom get_vartype_def : forall (i:ident) (pi:(list (ident* datatype)%type)),
  match pi with
  | Nil => ((get_vartype i pi) = TYunit)
  | (Cons (x, ty) r) => ((x = i) -> ((get_vartype i pi) = ty)) /\
      ((~ (x = i)) -> ((get_vartype i pi) = (get_vartype i r)))
  end.

(* Why3 assumption *)
Definition type_env  := (map mident datatype).

(* Why3 assumption *)
Inductive type_term : (map mident datatype) -> (list (ident* datatype)%type)
  -> term -> datatype -> Prop :=
  | Type_value : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_term sigma pi (Tvalue v)
      (type_value v))
  | Type_var : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_term sigma pi (Tvar v) ty)
  | Type_deref : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_term sigma pi (Tderef v) ty)
  | Type_bin : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t1:term) (t2:term) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_term sigma pi t1 ty1) ->
      ((type_term sigma pi t2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_term sigma pi (Tbin t1 op t2) ty))).

(* Why3 assumption *)
Inductive type_fmla : (map mident datatype) -> (list (ident* datatype)%type)
  -> fmla -> Prop :=
  | Type_term : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:term), (type_term sigma pi t TYbool) ->
      (type_fmla sigma pi (Fterm t))
  | Type_conj : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fand f1 f2)))
  | Type_neg : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f:fmla), (type_fmla sigma pi f) -> (type_fmla sigma
      pi (Fnot f))
  | Type_implies : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fimplies f1 f2)))
  | Type_let : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (t:term) (f:fmla) (ty:datatype),
      (type_term sigma pi t ty) -> ((type_fmla sigma (Cons (x, ty) pi) f) ->
      (type_fmla sigma pi (Flet x t f)))
  | Type_forall1 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYint)
      pi) f) -> (type_fmla sigma pi (Fforall x TYint f))
  | Type_forall2 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYbool)
      pi) f) -> (type_fmla sigma pi (Fforall x TYbool f))
  | Type_forall3 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYunit)
      pi) f) -> (type_fmla sigma pi (Fforall x TYunit f)).

(* Why3 assumption *)
Inductive type_expr : (map mident datatype) -> (list (ident* datatype)%type)
  -> expr -> datatype -> Prop :=
  | Type_Evalue : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_expr sigma pi (Evalue v)
      (type_value v))
  | Type_Evar : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_expr sigma pi (Evar v) ty)
  | Type_Ederef : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_expr sigma pi (Ederef v) ty)
  | Type_Ebinop : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_expr sigma pi e1 ty1) ->
      ((type_expr sigma pi e2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_expr sigma pi (Ebin e1 op e2) ty)))
  | Type_seq : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (ty:datatype), (type_expr sigma pi
      e1 TYunit) -> ((type_expr sigma pi e2 ty) -> (type_expr sigma pi
      (Eseq e1 e2) ty))
  | Type_assigns : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:mident) (e:expr) (ty:datatype), ((get sigma
      x) = ty) -> ((type_expr sigma pi e ty) -> (type_expr sigma pi
      (Eassign x e) TYunit))
  | Type_if : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:expr) (e1:expr) (e2:expr) (ty:datatype),
      (type_expr sigma pi t TYbool) -> ((type_expr sigma pi e1 ty) ->
      ((type_expr sigma pi e2 ty) -> (type_expr sigma pi (Eif t e1 e2) ty)))
  | Type_assert : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (p:fmla), (type_fmla sigma pi p) -> (type_expr sigma
      pi (Eassert p) TYbool)
  | Type_while : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (guard:expr) (body:expr) (inv:fmla) (ty:datatype),
      (type_fmla sigma pi inv) -> ((type_expr sigma pi guard TYbool) ->
      ((type_expr sigma pi body ty) -> (type_expr sigma pi (Ewhile guard inv
      body) ty)))
  | Type_Elet : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (e1:expr) (e2:expr) (ty1:datatype)
      (ty2:datatype), (type_expr sigma pi e1 ty1) -> ((type_expr sigma
      (Cons (x, ty1) pi) e2 ty2) -> (type_expr sigma pi (Elet x e1 e2) ty2)).

(* Why3 assumption *)
Definition env  := (map mident value).

(* Why3 assumption *)
Definition stack  := (list (ident* value)%type).

Parameter get_stack: ident -> (list (ident* value)%type) -> value.

Axiom get_stack_def : forall (i:ident) (pi:(list (ident* value)%type)),
  match pi with
  | Nil => ((get_stack i pi) = Vvoid)
  | (Cons (x, v) r) => ((x = i) -> ((get_stack i pi) = v)) /\ ((~ (x = i)) ->
      ((get_stack i pi) = (get_stack i r)))
  end.

Axiom get_stack_eq : forall (x:ident) (v:value) (r:(list (ident*
  value)%type)), ((get_stack x (Cons (x, v) r)) = v).

Axiom get_stack_neq : forall (x:ident) (i:ident) (v:value) (r:(list (ident*
  value)%type)), (~ (x = i)) -> ((get_stack i (Cons (x, v) r)) = (get_stack i
  r)).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = Vvoid)
  end.

(* Why3 assumption *)
Fixpoint eval_term(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (t:term) {struct t}: value :=
  match t with
  | (Tvalue v) => v
  | (Tvar id) => (get_stack id pi)
  | (Tderef id) => (get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.

Axiom eval_bool_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (sigmat:(map mident datatype)) (pit:(list (ident*
  datatype)%type)) (t:term), (type_term sigmat pit t TYbool) ->
  exists b:bool, ((eval_term sigma pi t) = (Vbool b)).

(* Why3 assumption *)
Fixpoint eval_fmla(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (Cons (x, (eval_term sigma pi t)) pi)
      f1)
  | (Fforall x TYint f1) => forall (n:Z), (eval_fmla sigma (Cons (x,
      (Vint n)) pi) f1)
  | (Fforall x TYbool f1) => forall (b:bool), (eval_fmla sigma (Cons (x,
      (Vbool b)) pi) f1)
  | (Fforall x TYunit f1) => (eval_fmla sigma (Cons (x, Vvoid) pi) f1)
  end.

Parameter msubst_term: term -> mident -> ident -> term.

Axiom msubst_term_def : forall (t:term) (r:mident) (v:ident),
  match t with
  | ((Tvalue _)|(Tvar _)) => ((msubst_term t r v) = t)
  | (Tderef x) => ((r = x) -> ((msubst_term t r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((msubst_term t r v) = t))
  | (Tbin t1 op t2) => ((msubst_term t r v) = (Tbin (msubst_term t1 r v) op
      (msubst_term t2 r v)))
  end.

Parameter subst_term: term -> ident -> ident -> term.

Axiom subst_term_def : forall (t:term) (r:ident) (v:ident),
  match t with
  | ((Tvalue _)|(Tderef _)) => ((subst_term t r v) = t)
  | (Tvar x) => ((r = x) -> ((subst_term t r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term t r v) = t))
  | (Tbin t1 op t2) => ((subst_term t r v) = (Tbin (subst_term t1 r v) op
      (subst_term t2 r v)))
  end.

(* Why3 assumption *)
Definition fresh_in_term(id:ident) (t:term): Prop := ~ (var_occurs_in_term id
  t).

Axiom fresh_in_binop : forall (t:term) (t':term) (op:operator) (v:ident),
  (fresh_in_term v (Tbin t op t')) -> ((fresh_in_term v t) /\
  (fresh_in_term v t')).

(* Why3 assumption *)
Fixpoint fresh_in_fmla(id:ident) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst(f:fmla) (x:ident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

(* Why3 assumption *)
Fixpoint msubst(f:fmla) (x:mident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (msubst_term e x v))
  | (Fand f1 f2) => (Fand (msubst f1 x v) (msubst f2 x v))
  | (Fnot f1) => (Fnot (msubst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (msubst f1 x v) (msubst f2 x v))
  | (Flet y t f1) => (Flet y (msubst_term t x v) (msubst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (msubst f1 x v))
  end.

Axiom subst_fresh_term : forall (t:term) (x:ident) (v:ident),
  (fresh_in_term x t) -> ((subst_term t x v) = t).

Axiom subst_fresh : forall (f:fmla) (x:ident) (v:ident), (fresh_in_fmla x
  f) -> ((subst f x v) = f).

Axiom eval_msubst_term : forall (e:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (msubst_term e x v)) = (eval_term (set sigma x
  (get_stack v pi)) pi e)).

Axiom eval_msubst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (msubst f x v)) <-> (eval_fmla (set sigma x
  (get_stack v pi)) pi f)).

Axiom eval_swap_term : forall (t:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (l:(list (ident* value)%type)) (id1:ident)
  (id2:ident) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_term sigma
  (infix_plpl l (Cons (id1, v1) (Cons (id2, v2) pi))) t) = (eval_term sigma
  (infix_plpl l (Cons (id2, v2) (Cons (id1, v1) pi))) t)).

Axiom eval_swap_term_2 : forall (t:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id1:ident) (id2:ident) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_term sigma (Cons (id1, v1) (Cons (id2, v2) pi))
  t) = (eval_term sigma (Cons (id2, v2) (Cons (id1, v1) pi)) t)).

Axiom eval_swap : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (l:(list (ident* value)%type)) (id1:ident)
  (id2:ident) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_fmla sigma
  (infix_plpl l (Cons (id1, v1) (Cons (id2, v2) pi))) f) <-> (eval_fmla sigma
  (infix_plpl l (Cons (id2, v2) (Cons (id1, v1) pi))) f)).

(* Why3 goal *)
Theorem eval_swap_2 : forall (f:fmla) (id1:ident) (id2:ident) (v1:value)
  (v2:value), (~ (id1 = id2)) -> forall (sigma:(map mident value)) (pi:(list
  (ident* value)%type)), (eval_fmla sigma (Cons (id1, v1) (Cons (id2, v2)
  pi)) f) <-> (eval_fmla sigma (Cons (id2, v2) (Cons (id1, v1) pi)) f).
intros f id1 id2 v1 v2 h1 sigma pi.
assert (h: ((eval_fmla sigma
  (infix_plpl Nil (Cons (id1, v1) (Cons (id2, v2) pi))) f) <-> (eval_fmla sigma
  (infix_plpl Nil (Cons (id2, v2) (Cons (id1, v1) pi))) f))).
apply eval_swap; auto.
simpl in h; auto.
Qed.


Set Implicit Arguments.

Require Import Platform.Cito.Syntax.
Require Import Coq.Strings.String.

Definition Optimizer := Stmt -> string -> Stmt.

Definition compose (f g : Optimizer) : Optimizer := fun s r => g (f s r) r.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Semantics.
  Module Import SemanticsMake := Semantics.Make E.

  Section TopSection.

    Definition PreserveRunsTo (opt : Optimizer) :=  forall ret fs s v v', RunsTo fs (opt s ret) v v' -> exists vs', RunsTo fs s v (vs', snd v') /\ Locals.sel vs' ret = Locals.sel (fst v') ret.

    Definition PreserveSafe (opt : Optimizer) := forall fs s v, Safe fs s v -> forall ret, Safe fs (opt s ret) v.

    Require Import Platform.Cito.GetLocalVars.
    Require Import Platform.Cito.Depth.
    Require Import Bedrock.IL.

    Definition PreserveGoodSize (opt : Optimizer) :=
      forall stmt argvars retvar,
        let size s := List.length (get_local_vars s argvars retvar) + depth s in
        goodSize (size stmt) ->
        goodSize (size (opt stmt retvar)).

    Require Import Platform.Cito.CompileStmtSpec.
    Require Import Coq.Lists.List.

    Definition PreserveSynReq (opt : Optimizer) :=
      forall stmt argvars retvar,
        let vars s := argvars ++ get_local_vars s argvars retvar in
        let stmt' := opt stmt retvar in
        syn_req (vars stmt) (depth stmt) stmt ->
        syn_req (vars stmt') (depth stmt') stmt'.

    Definition GoodOptimizer opt :=
      PreserveRunsTo opt /\
      PreserveSafe opt /\
      PreserveGoodSize opt /\
      PreserveSynReq opt.

    Require Import Platform.Cito.GoodFunc.
    Require Import Platform.Cito.SyntaxFunc.
    Definition PreserveGoodSize' (opt : Optimizer) :=
      forall f,
        GoodFunc f ->
        let s := opt (Body f) (RetVar f) in
        goodSize (length (get_local_vars s (ArgVars f) (RetVar f)) + depth s).

    Definition PreserveSynReq' (opt : Optimizer) :=
      forall f,
        GoodFunc f ->
        let s := opt (Body f) (RetVar f) in
        syn_req (ArgVars f ++ get_local_vars s (ArgVars f) (RetVar f)) (depth s) s.

    Lemma GoodOptimizer_Safe : forall opt, GoodOptimizer opt -> PreserveSafe opt.
      unfold GoodOptimizer; intuition.
    Qed.

    Lemma GoodOptimizer_RunsTo : forall opt, GoodOptimizer opt -> PreserveRunsTo opt.
      unfold GoodOptimizer; intuition.
    Qed.

    Require Import Platform.Cito.GeneralTactics.

    Lemma GoodFunc_GoodOptimizer_goodSize : forall opt, GoodOptimizer opt -> PreserveGoodSize' opt.
      unfold GoodOptimizer.
      intros.
      openhyp.
      unfold PreserveGoodSize'.
      unfold PreserveGoodSize in *.
      intros.
      simpl in *.
      eapply H1; eauto.
      destruct H3; openhyp; eauto.
    Qed.

    Lemma GoodFunc_GoodOptimizer_syn_req : forall opt, GoodOptimizer opt -> PreserveSynReq' opt.
      unfold GoodOptimizer.
      intros.
      openhyp.
      unfold PreserveSynReq'.
      unfold PreserveSynReq in *.
      intros.
      simpl in *.
      eapply H2; eauto.
      eapply GoodFunc_syn_req; eauto.
    Qed.

    Lemma PreserveRunsTo_trans : forall a b, PreserveRunsTo a -> PreserveRunsTo b -> PreserveRunsTo (compose a b).
      unfold PreserveRunsTo, compose; intros.
      eapply H0 in H1; eauto; openhyp.
      eapply H in H1; eauto; openhyp.
      descend; intuition eauto.
    Qed.

    Lemma PreserveSafe_trans : forall a b, PreserveSafe a -> PreserveSafe b -> PreserveSafe (compose a b).
      unfold PreserveSafe, compose; intros.
      eauto.
    Qed.

    Lemma PreserveGoodSize_trans : forall a b, PreserveGoodSize a -> PreserveGoodSize b -> PreserveGoodSize (compose a b).
      unfold PreserveGoodSize, compose; intros.
      eauto.
    Qed.

    Lemma PreserveSynReq_trans : forall a b, PreserveSynReq a -> PreserveSynReq b -> PreserveSynReq (compose a b).
      unfold PreserveSynReq, compose; intros.
      eauto.
    Qed.

    Lemma GoodOptimizer_trans :
      forall a b,
        GoodOptimizer a ->
        GoodOptimizer b ->
        GoodOptimizer (compose a b).
    Proof.
      unfold GoodOptimizer; intros.
      openhyp.
      split.
      eapply PreserveRunsTo_trans; eauto.
      split.
      eapply PreserveSafe_trans; eauto.
      split.
      eapply PreserveGoodSize_trans; eauto.
      eapply PreserveSynReq_trans; eauto.
    Qed.

  End TopSection.

End Make.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Import Ref.
Require Import Exception.
Require Import ESoundES.

Open Scope string_scope.

Section Test_Section.

  Definition D := RefType :+: UnitType.

  Definition E := RefE :+: (ExceptE D).

  Definition V := StuckValue :+: UnitValue :+: LocValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{StateM_ME : StateM ME (list (Value V))}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Definition WFV := (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).

  Instance DType_Env_CE : ConsExtensionC (list (DType D)). eauto with typeclass_instances. Defined.
  Instance DType_Env_WFE : WF_EnvC V (list (DType D)). apply (DType_Env_WFE _ _ WFV). Defined.

  Definition WFVM :=
    (WFValueM_base D V MT ME (list (DType D)) WFV) ::+::
    (WFValueM_State D V MT ME _) ::+::
    (WFValueM_Except D V MT ME _).

  Instance typeof_alg : forall T : Set, FAlgebra TypeofName T (typeofR D MT) E.
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T : Set, FAlgebra EvalName T (evalMR V ME) E.
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

    Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env : list (Value V)),
      (exists a, exists env',
        put env >> mte = put env' >> return_ a) \/
      (exists env', put env >> mte = put env' >> throw tt)}.
    Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
      put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
    Context {Put_Exception_Disc :
      forall (A B : Set) (a : A) (mb : ME B) env n,
        (put env >>= fun _ => return_ a) <> mb >>= fun _ => throw n}.
    Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
      put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
      put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.

  Theorem eval_Sound :
    forall (e : Exp E) Sigma (T : DType D)
      (env : list (Value V)),
      WF_Environment D V _ WFV Sigma env Sigma ->
      fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
      (exists v : Value V, exists env', exists Sigma',
        (put env) >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> return_ (M := ME) v /\
        WFValueC D V _ WFV Sigma' v T) \/
      (exists t, exists env', exists Sigma',
        put env >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> throw t
        /\ WF_Environment D V _ WFV Sigma' env' Sigma'
        /\ (forall n T, lookup Sigma n = Some T -> lookup Sigma' n = Some T)).
  Proof.
    apply eval_Except_State_Sound with (WFVM' := WFVM).
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    intros; repeat apply @P2Algebra_Plus.
    eapply Ref_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Except_eval_soundness';
      eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Soundness for 'Ref :+: Exceptions ' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import AllInRel Util Map Envs Exp IL Annotation Coherence DecSolve.
Require Import Liveness.Liveness Restrict Delocation Indexwise.

Set Implicit Arguments.
Unset Printing Records.

Local Hint Extern 1 =>
match goal with
  [ H : annotation _ _ |- annotation _ _ ] => inv H; eassumption
end.

Lemma trs_dec DL s ans_lv ans
  : {trs DL s ans_lv ans} +
    {~ trs DL s ans_lv ans}.
Proof.
  revert DL ans_lv ans.
  sind s.
  time (destruct s; destruct ans; try solve [dec_right]; destruct ans_lv; try solve [dec_right]).
  + destruct a; [ | dec_right];
      destruct (IH s (ltac:(eauto))
                   (restr (getAnn ans_lv \ singleton x) ⊝  DL) ans_lv ans);
      [| dec_right].
    dec_solve.
  + destruct a; [| dec_right];
    destruct (IH s1 (ltac:(eauto)) DL ans_lv1 ans1); [| dec_right];
    destruct (IH s2 (ltac:(eauto)) DL ans_lv2 ans2); [| dec_right].
    dec_solve.
  + destruct (get_dec DL (counted l)) as [[[G'|]]|];[| dec_right | dec_right];
      destruct a; [| dec_right];
        dec_solve.
  + destruct a;[| dec_right].
    dec_solve.
  + ensure (length F = length a);
    ensure (length F = length sa);
    ensure(length F = length sa0).
    destruct (IH s (ltac:(eauto)) (Some ⊝ (getAnn ⊝ sa0) \\ app (A:=var) ⊜ (fst ⊝ F) a ++ DL)
                 ans_lv ans);[| dec_right].
    edestruct (indexwise_R4_dec
                 (R:=fun lvs Zs Za' ans' =>
                       trs (restr (getAnn lvs \ of_list (fst Zs ++ Za'))
                                     ⊝ (Some ⊝ (getAnn ⊝ sa0) \\ app (A:=var) ⊜ (fst ⊝ F) a ++ DL))
                           (snd Zs) lvs ans')
                 (LA:=sa0)
                 (LB:=F)
                 (LC:=a)
                 (LD:=sa)); intros; eauto.
    hnf; intros. eapply IH; eauto.
    dec_solve. dec_right.
Defined.

Instance trs_dec_inst DL s lv Y
: Computable (trs DL s lv Y).
Proof.
  hnf; eauto using trs_dec.
Defined.