Require Import compcert.lib.Axioms.

Require Import concurrency.sepcomp. Import SepComp.
Require Import sepcomp.semantics_lemmas.

Require Import concurrency.pos.
Require Import concurrency.concurrent_machine.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

(*NOTE: because of redefinition of [val], these imports must appear
  after Ssreflect eqtype.*)
Require Import compcert.common.AST.     (*for typ*)
Require Import compcert.common.Values. (*for val*)
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.lib.Integers.
Require Import veric.shares msl.msl_standard.
Require Import concurrency.threads_lemmas.

Require Import Coq.ZArith.ZArith.

Require Import (*compcert_linking*) concurrency.permissions.

Module ThreadPool.
  Section ThreadPool.

    Variable cT : Type.

    Record t := mk
                  { num_threads : pos
                    ; pool :> 'I_num_threads -> (@ctl cT)
                    ; share_maps : 'I_num_threads -> share_map
                  }.

    Definition containsThread: t -> nat -> Prop:=
      fun tp tid => tid < (num_threads tp).

  End ThreadPool.
End ThreadPool.

Section poolDefs.

  Variable cT : Type.

  Import ThreadPool.

  Notation "x <= y" := (x <= y)%nat.
  Notation "x < y" := (x < y)%nat.
  Notation thread_pool := (t cT).

  Variable (tp : thread_pool).
  Notation num_threads := (ThreadPool.num_threads tp).

  (* Per-thread disjointness definition*)
  Definition race_free (tp : thread_pool) :=
    forall tid0 tid0' (Htid0 : containsThread tp tid0)
      (Htid0' : containsThread tp tid0')
      (Htid: tid0 <> tid0'),
      shareMapsJoins (share_maps tp (Ordinal Htid0))
                       (share_maps tp (Ordinal Htid0')).

  Definition newShareMap_wf smap :=
    forall tid0 (Htid0 : containsThread tp tid0),
      shareMapsJoins ((share_maps tp) (Ordinal Htid0)) smap.

  Require Import fintype.

  Lemma unlift_m_inv : forall tid (Htid : tid < num_threads.+1) ord
                         (Hunlift: unlift (ordinal_pos_incr num_threads)
                                          (Ordinal (n:=num_threads.+1) (m:=tid) Htid)
                                   = Some ord),
                         nat_of_ord ord = tid.
  Proof.
    intros.
    assert (Hcontra:
              unlift_spec (ordinal_pos_incr num_threads)
                          (Ordinal (n:=num_threads.+1) (m:=tid) Htid) (Some ord)).
    rewrite <- Hunlift.
    apply/unliftP.
    inversion Hcontra; subst.
    inversion H0.
    unfold bump.
    assert (pf: ord < num_threads)
      by (by rewrite ltn_ord).
    assert (H: num_threads <= ord = false).
    rewrite ltnNge in pf.
    rewrite <- Bool.negb_true_iff. auto.
    rewrite H. simpl. rewrite add0n. reflexivity.
  Defined.

  Definition addThread (c : cT) (smap : share_map) : thread_pool :=
    let: new_num_threads := pos_incr num_threads in
    let: new_tid := ordinal_pos_incr num_threads in
    mk new_num_threads
        (fun (n : 'I_new_num_threads) =>
           match unlift new_tid n with
             | None => Kresume c (*Could be a new state Kinit?? *)
             | Some n' => tp n'
           end)
        (fun (n : 'I_new_num_threads) =>
           match unlift new_tid n with
             | None => smap
             | Some n' => (share_maps tp) n'
           end).

  Lemma addThread_racefree :
    forall c p (Hwf: newShareMap_wf p) (Hrace: race_free tp),
      race_free (addThread c p).
  Proof.
    unfold race_free in *. intros.
    simpl.
    match goal with
      | [ |- context[ match ?Expr with _ => _ end]] =>
        destruct Expr as [ord0|] eqn:Hget0
    end;
      match goal with
        | [ |- context[ match ?Expr with _ => _ end]] =>
          destruct Expr as [ord1|] eqn:Hget1
      end; simpl in *.
    - apply unlift_m_inv in Hget0.
      apply unlift_m_inv in Hget1. subst.
      destruct ord0 as [tid0 pf0], ord1 as [tid1 pf1]; simpl in Htid.
      eapply Hrace; eauto.
    - apply unlift_m_inv in Hget0.
      subst. unfold newShareMap_wf in Hwf.
      destruct ord0. eapply Hwf; eauto.
    - apply unlift_m_inv in Hget1.
      subst. unfold newShareMap_wf in Hwf.
      destruct ord1. apply shareMapsJoins_comm. eapply Hwf; eauto.
    - destruct (tid0 == num_threads) eqn:Heq0.
      + move/eqP:Heq0=>Heq0. subst.
        assert (Hcontra: (ordinal_pos_incr num_threads) !=
                                                        (Ordinal (n:=num_threads.+1) (m:=tid0') Htid0')).
        { apply/eqP. intros Hcontra.
          unfold ordinal_pos_incr in Hcontra.
          inversion Hcontra; auto.
        }
        exfalso. apply unlift_some in Hcontra. rewrite Hget1 in Hcontra.
        destruct Hcontra. discriminate.
      + move/eqP:Heq0=>Heq0.
        assert (Hcontra: (ordinal_pos_incr num_threads) !=
                                                        (Ordinal (n:=num_threads.+1) (m:=tid0) Htid0)).
        { apply/eqP. intros Hcontra.
          unfold ordinal_pos_incr in Hcontra. inversion Hcontra. subst. auto. }
        exfalso. apply unlift_some in Hcontra. rewrite Hget0 in Hcontra. destruct Hcontra.
        discriminate.
  Defined.

  Definition updThreadC tid (cont: containsThread tp tid) (c' : ctl) : thread_pool :=
    mk num_threads (fun (n : 'I_num_threads) =>
                      if n == (Ordinal cont) then c' else tp n) (share_maps tp).

  Definition updThreadS tid (cont: containsThread tp tid) (smap' : share_map) :
    thread_pool :=
    mk num_threads (pool tp) (fun (n : 'I_num_threads) =>
                                if n == (Ordinal cont) then smap'
                                else (share_maps tp) n).

  Definition shareMap_wf smap tid :=
    forall tid0 (Htid0 : tid0 < num_threads) (Hneq: tid <> tid0),
      shareMapsJoins ((share_maps tp) (Ordinal Htid0)) smap.

  Definition updThread tid (cont : containsThread tp tid) (c' : ctl)
             (smap : share_map) : thread_pool :=
    mk num_threads
        (fun (n : 'I_num_threads) =>
           if n == (Ordinal cont) then c' else tp n)
        (fun (n : 'I_num_threads) =>
           if n == (Ordinal cont) then smap else (share_maps tp) n).

  Lemma updThread_wf : forall tid (pf : containsThread tp tid) smap
                         (Hwf: shareMap_wf smap tid)
                         c'
                         (Hrace_free: race_free tp),
                         race_free (updThread pf c' smap).
  Proof.
    intros.
    unfold race_free. intros.
    simpl.
    destruct (Ordinal (n:=num_threads) (m:=tid0) Htid0 ==  Ordinal (n:=num_threads) (m:=tid) pf) eqn:Heq0,
                                                                                (Ordinal (n:=num_threads) (m:=tid0') Htid0' == Ordinal (n:=num_threads) (m:=tid) pf) eqn:Heq0'.
    - move/eqP:Heq0 => Heq0. subst.
      move/eqP:Heq0' => Heq0'. inversion Heq0'. inversion Heq0; subst. exfalso; auto.
    - move/eqP:Heq0=>Heq0. inversion Heq0. subst.
      apply shareMapsJoins_comm.
      eapply Hwf. simpl; auto.
    - move/eqP:Heq0'=>Heq0'. inversion Heq0'. subst.
      eapply Hwf. simpl; auto.
    - simpl in *. eapply Hrace_free; eauto.
  Defined.

  Definition getThreadC tid (cont : containsThread tp tid) : ctl :=
    tp (Ordinal cont).

  Definition getThreadS tid (cont : containsThread tp tid) : share_map :=
    (share_maps tp) (Ordinal cont).

  Import Maps.

  Definition perm_compatible p :=
    forall tid (cont : containsThread tp tid) (b : positive) (ofs : Z) ,
      Mem.perm_order'' (Maps.PMap.get b p ofs)
                       (Maps.PMap.get b (share_to_access_map (getThreadS cont)) ofs).

  Record mem_compatible m :=
    { perm_comp: perm_compatible (getMaxPerm m);
      mem_canonical: isCanonical (getMaxPerm m)
    }.

End poolDefs.

Section poolLemmas.

  Context {cT : Type} (tp : ThreadPool.t cT).

  Import ThreadPool.

  Lemma updThreadS_cnt : forall tid tp' (cnt: containsThread tp tid) smap
                           (Hupd: tp' = updThreadS cnt smap),
      containsThread tp' tid.
  Proof.
    intros. unfold containsThread, updThreadS in *. subst. now simpl.
  Defined.

  (*This broke owhen lifting getters and setters for ThreadC. Should be fixed. Nick
    suggested to abstract the machine_state for both machines and have only one set
    of proofs.*)
  (*
  Lemma gssThreadCode (tid : 'I_(num_threads tp)) c' p' counter' :
    getThreadC (updThread tp tid c' p' counter') tid = c'.
  Proof. by rewrite /getThreadC /updThread /= eq_refl. Defined.

  Lemma gsoThread (tid tid' : 'I_(num_threads tp)) c' p' counter':
    tid' != tid -> getThreadC (updThread tp tid c' p' counter') tid' = getThreadC tp tid'.
  Proof. by rewrite /getThreadC /updThread /=; case Heq: (tid' == tid). Defined.

  Lemma gssThreadPerm (tid : 'I_(num_threads tp)) c' p' counter' :
    getThreadPerm (updThread tp tid c' p' counter') tid = p'.
  Proof. by rewrite /getThreadC /updThread /= eq_refl. Defined.

  Lemma gsoThreadPerm (tid tid' : 'I_(num_threads tp)) c' p' counter':
    tid' != tid -> getThreadPerm (updThread tp tid c' p' counter') tid' = getThreadPerm tp tid'.
  Proof. by rewrite /getThreadPerm /updThread /=; case Heq: (tid' == tid). Defined.

  Lemma getAddThread c pmap tid :
    tid = ordinal_pos_incr (num_threads tp) ->
    getThreadC (addThread tp c pmap) tid = c.
  Proof. by rewrite /getThreadC /addThread /= => <-; rewrite unlift_none. Qed. *)

  Lemma permMapsInv_lt : forall p (Hinv: perm_compatible tp p) tid
                           (cont : containsThread tp tid),
      permMapLt (share_to_access_map (getThreadS cont)) p.
  Proof.
    intros.
    unfold permMapLt; auto.
  Qed.

  Definition restrPermMap p' m (Hlt: permMapLt p' (getMaxPerm m)) : mem.
  Proof.
    refine ({|
               Mem.mem_contents := Mem.mem_contents m;
               Mem.mem_access :=
                 (fun ofs k =>
                    match k with
                      | Cur => None
                      | Max => fst (Mem.mem_access m) ofs k
                    end, Maps.PTree.map (fun b f =>
                                           fun ofs k =>
                                             match k with
                                               | Cur =>
                                                 (Maps.PMap.get b p') ofs
                                               | Max =>
                                                 f ofs Max
                                             end) (Mem.mem_access m).2);
               Mem.nextblock := Mem.nextblock m;
               Mem.access_max := _;
               Mem.nextblock_noaccess := _;
               Mem.contents_default := Mem.contents_default m |}).
    - unfold permMapLt in Hlt.
      assert (Heq: forall b ofs, Maps.PMap.get b (getMaxPerm m) ofs =
                            Maps.PMap.get b (Mem.mem_access m) ofs Max).
      { unfold getMaxPerm. intros.
        rewrite Maps.PMap.gmap. reflexivity. }
      intros.
      specialize (Hlt b ofs).
      specialize (Heq b ofs).
      unfold getMaxPerm in Hlt.
      unfold Maps.PMap.get in *. simpl in *.
      rewrite Maps.PTree.gmap; simpl.
      match goal with
        | [|- context[match Coqlib.option_map ?Expr1 ?Expr2  with _ => _ end]] =>
          destruct (Coqlib.option_map Expr1 Expr2) as [f|] eqn:?
      end; auto; unfold Coqlib.option_map in Heqo.
      destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:?; try discriminate.
      + inversion Heqo; subst; clear Heqo.
        rewrite Heq in Hlt. auto.
      + unfold Mem.perm_order''. by destruct ((Mem.mem_access m).1 ofs Max).
    - intros b ofs k Hnext.
    - unfold permMapLt in Hlt.
      assert (Heq: forall b ofs, Maps.PMap.get b (getMaxPerm m) ofs =
                            Maps.PMap.get b (Mem.mem_access m) ofs Max).
      { unfold getMaxPerm. intros.
        rewrite Maps.PMap.gmap. reflexivity. }
      specialize (Hlt b ofs).
      specialize (Heq b ofs).
      unfold Maps.PMap.get in *.
      simpl in *.
      rewrite Maps.PTree.gmap; simpl.
      assert (H := Mem.nextblock_noaccess m).
      specialize (H b). unfold Maps.PMap.get in H.
      match goal with
        | [|- context[match Coqlib.option_map ?Expr1 ?Expr2  with _ => _ end]] =>
          destruct (Coqlib.option_map Expr1 Expr2) as [f|] eqn:?
      end; auto; unfold Coqlib.option_map in Heqo;
      destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:Heqo2; try discriminate.
      inversion Heqo. subst f. clear Heqo.
      destruct k; auto.
      rewrite Heq in Hlt.
      specialize (H ofs Max). rewrite H in Hlt; auto.
      unfold Mem.perm_order'' in Hlt. destruct (Maps.PTree.get b p'.2).
      destruct (o0 ofs); tauto.
      destruct (p'.1 ofs); tauto.
      rewrite H; auto. destruct k; auto.
  Defined.

  Lemma restrPermMap_nextblock :
    forall p' m (Hlt: permMapLt p' (getMaxPerm m)),
      Mem.nextblock (restrPermMap Hlt) = Mem.nextblock m.
  Proof.
    intros. unfold restrPermMap. reflexivity.
  Qed.

  Lemma restrPermMap_irr : forall p' p'' m
                             (Hlt : permMapLt p' (getMaxPerm m))
                             (Hlt': permMapLt p'' (getMaxPerm m))
                             (Heq_new: p' = p''),
                             restrPermMap Hlt = restrPermMap Hlt'.
  Proof.
    intros. subst.
    apply f_equal. by apply proof_irr.
  Qed.

  Lemma restrPermMap_disjoint_inv:
    forall (mi mj m : mem) (pi pj : access_map)
      (Hcan_m: isCanonical (getMaxPerm m))
      (Hltj: permMapLt pj (getMaxPerm m))
      (Hlti: permMapLt pi (getMaxPerm m))
      (Hdisjoint: permMapsDisjoint pi pj)
      (Hrestrj: restrPermMap Hltj = mj)
      (Hrestri: restrPermMap Hlti = mi),
      permMapsDisjoint (getCurPerm mi) (getCurPerm mj).
  Proof.
    intros. rewrite <- Hrestri. rewrite <- Hrestrj.
    unfold restrPermMap, getCurPerm, permMapsDisjoint. simpl in *.
    intros b ofs.
    do 2 rewrite Maps.PMap.gmap.
    clear Hrestrj Hrestri.
    unfold permMapLt, Mem.perm_order'' in *.
    specialize (Hltj b ofs); specialize (Hlti b ofs).
    unfold getMaxPerm in *; simpl in *.
    rewrite Maps.PMap.gmap in Hlti, Hltj.
    unfold permMapsDisjoint, Maps.PMap.get in *; simpl in *.
    do 2 rewrite Maps.PTree.gmap. unfold Coqlib.option_map.
    specialize (Hdisjoint b ofs).
    assert (Hnone: (Mem.mem_access m).1 ofs Max = None)
      by (unfold isCanonical in Hcan_m; simpl in Hcan_m;
            by apply equal_f with (x:=ofs) in Hcan_m).
    destruct (Maps.PTree.get b (Mem.mem_access m).2) eqn:?; auto.
    rewrite Hnone in Hlti, Hltj;
      destruct (Maps.PTree.get b pi.2)
      as [f1 |] eqn:?;
                destruct (Maps.PTree.get b pj.2) as [f2|] eqn:?;
      repeat match goal with
               | [H: match ?Expr with _ => _ end |- _] => destruct Expr
             end; tauto.
  Qed.

  Lemma no_race_wf : forall tid (cont: containsThread tp tid) (Hrace: race_free tp),
                       shareMap_wf tp (getThreadS cont) tid.
  Proof.
    intros; unfold shareMap_wf, getThreadS in *; auto.
  Defined.

End poolLemmas.

Module Concur.
  Section Concur.

    Import ThreadPool.
    Context {cT G : Type} {the_sem : CoreSemantics G cT Mem.mem}.

    Notation thread_pool := (t cT).
    Notation perm_map := access_map.

    Variable the_ge : G.
    Definition ls_id : nat := 0.
    Definition sp_id : nat := 1.

    Record invariant (tp : thread_pool) :=
      { no_race : race_free tp;
        lock_set : forall (cont : containsThread tp ls_id), exists c,
              getThreadC cont = Krun c /\ halted the_sem c;
        share_pool : forall (cont : containsThread tp sp_id), exists c,
              getThreadC cont = Krun c /\ halted the_sem c }.

    (* Semantics of the coarse-grained concurrent machine*)
    (* Definition cont2ord {ms tid0} (cnt: containsThread ms tid0) := *)
    (*   Ordinal cnt. *)

    Inductive dry_step {tid0 tp m} (cnt: containsThread tp tid0)
      (Hcompatible: mem_compatible tp m) : thread_pool -> mem  -> Prop :=
    | step_dry :
        forall (tp':thread_pool) c m1 m' (c' : cT),
          let: smap := getThreadS cnt in
          forall (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompatible) cnt) = m1)
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt = Krun c)
            (Hcorestep: corestep the_sem the_ge c m1 c' m')
            (Htp': tp' = updThread cnt (Krun c')
                                   (access_to_share_map smap (getCurPerm m'))),
            dry_step cnt Hcompatible tp' m'.

    (*missing lock-ranges*)
    Inductive ext_step {tid0 tp m}
              (cnt0: containsThread tp tid0) (Hcompat: mem_compatible tp m):
      thread_pool -> mem -> Prop :=
    | step_lock :
        forall (tp' tp'':thread_pool) m1 c c' m' b ofs smap_sp' smap_tid' tmap
          (cnt_ls: containsThread tp ls_id)
          (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_sp := getThreadS cnt_sp in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (LOCK, ef_sig LOCK, Vptr b ofs::nil))
            (Hcompatible: mem_compatible tp m)
            (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompatible) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.one))
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
            (Hat_external: after_external the_sem (Some (Vint Int.zero)) c = Some c')
            (Hjoin1: shareMapsJoin smap_sp' tmap smap_sp)
            (Hjoin2: shareMapsJoin smap_tid tmap smap_tid')
            (Htp': tp' = updThreadS cnt_sp smap_sp')
            (Htp'': tp'' = updThread (updThreadS_cnt Htp') (Kresume c')
                                     smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_unlock :
        forall  (tp' tp'':thread_pool) m1 c c' m' b ofs smap_sp' smap_tid' tmap
           (cnt_ls: containsThread tp ls_id)
           (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_sp := getThreadS cnt_sp in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (UNLOCK, ef_sig UNLOCK, Vptr b ofs::nil))
            (Hrestrict_pmap:
               restrPermMap (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero))
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.one) = Some m')
            (Hat_external: after_external the_sem (Some (Vint Int.zero)) c = Some c')
            (Hjoin1: shareMapsJoin smap_tid' tmap smap_tid)
            (Hjoin2: shareMapsJoin smap_sp tmap smap_sp')
            (Htp': tp' = updThreadS cnt_sp smap_sp')
            (Htp'': tp'' = updThread (updThreadS_cnt Htp') (Kresume c')
                                   smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_create :
        forall  (tp_upd tp':thread_pool) c c' c_new vf arg smap_tid' tmap
           (cnt_ls: containsThread tp ls_id)
           (cnt_sp: containsThread tp sp_id),
          let: smap_tid := getThreadS cnt0 in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (CREATE, ef_sig CREATE, vf::arg::nil))
            (Hinitial: initial_core the_sem the_ge vf (arg::nil) = Some c_new)
            (Hafter_external: after_external the_sem
                                             (Some (Vint Int.zero)) c = Some c')
            (Hjoin: shareMapsJoin smap_tid' tmap smap_tid)
            (Htp_upd: tp_upd = updThread cnt0 (Kresume c') smap_tid')
            (Htp': tp' = addThread tp_upd c_new tmap),
            ext_step cnt0 Hcompat tp' m

    | step_mklock :
        forall  (tp' tp'': thread_pool) m1 c c' m' b ofs smap_tid' smap_ls'
           (cnt_ls: containsThread tp ls_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_ls := getThreadS cnt_ls in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (MKLOCK, ef_sig MKLOCK, Vptr b ofs::nil))
            (Hrestrict_pmap: restrPermMap
                               (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
            (Hdrop_share:
               setShare extern_retainer b (Int.intval ofs) smap_tid = smap_tid')
            (Hlp_share: setShare Ews
                               b (Int.intval ofs) smap_ls = smap_ls')
            (Hafter_external: after_external
                                the_sem (Some (Vint Int.zero)) c = Some c')
            (Htp': tp' = updThreadS cnt_ls smap_ls')
            (Htp'':
               tp'' = updThread (updThreadS_cnt Htp') (Kresume c') smap_tid'),
            ext_step cnt0 Hcompat tp'' m'

    | step_freelock :
        forall  (tp' tp'': thread_pool) c c' b ofs smap_tid' smap_ls'
           (cnt_ls: containsThread tp ls_id),
          let: smap_tid := getThreadS cnt0 in
          let: smap_ls := getThreadS cnt_ls in
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (FREE_LOCK, ef_sig FREE_LOCK, Vptr b ofs::nil))
            (Hdrop_share:
               setShare Share.bot b (Int.intval ofs) smap_ls = smap_ls')
            (Hafter_external: after_external
                                the_sem (Some (Vint Int.zero)) c = Some c')
            (Htp': tp' = updThreadS cnt_ls smap_ls')
            (Htp'':
               tp'' = updThread (updThreadS_cnt Htp') (Kresume c') smap_tid'),
            ext_step cnt0 Hcompat  tp'' m

    | step_lockfail :
        forall  c b ofs m1
           (cnt_ls: containsThread tp ls_id),
          forall
            (Hinv : invariant tp)
            (Hthread: getThreadC cnt0 = Kstop c)
            (Hat_external: at_external the_sem c =
                           Some (LOCK, ef_sig LOCK, Vptr b ofs::nil))
            (Hrestrict_pmap: restrPermMap
                               (permMapsInv_lt (perm_comp Hcompat) cnt_ls) = m1)
            (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero)),
            ext_step cnt0 Hcompat tp m.
  End Concur.

  Module ShareMachineSig (Sem: Semantics) <: ConcurrentMachineSig NatTID.
    (*TID = NAT*)
    Definition tid := nat.
    (*Memories*)
    Definition richMem: Type:= Sem.M.
    Definition dryMem: richMem -> mem:= fun x => x.

    (*CODE*)
    Definition cT: Type:= Sem.C.
    Definition G: Type:= Sem.G.
    Definition Sem := Sem.Sem.
    Definition cT': Type := @ctl cT.

    (*thread pool*)
    Import ThreadPool.
    Notation thread_pool := (t cT).

    (*MACHINE VARIABLES*)
    Definition machine_state: Type:= thread_pool.
    Definition containsThread: machine_state -> tid -> Prop:=
      fun ms tid0 => tid0 < (num_threads ms).
    Definition ls_id : tid:= 0.
    Definition sp_id : tid:= 1.

    (*INVARIANTS*)
    (*The state respects the memory*)
    Definition mem_compatible: machine_state -> mem -> Prop:=
      @mem_compatible cT.

    (*CODE GETTER AND SETTER*)
    Definition getThreadC: forall {ms tid0}, containsThread ms tid0 -> @ctl cT:= @getThreadC cT.
    Definition updThreadC: forall {ms tid0}, containsThread ms tid0 -> @ctl cT -> machine_state:= @updThreadC cT.

    (*Steps*)
    Definition cstep (genv:G): forall {tid0 ms m},
                                 containsThread ms tid0 -> mem_compatible ms m ->
                                 machine_state -> mem -> Prop:=
      @dry_step cT G Sem genv.

    Definition conc_call (genv:G):
      forall {tid0 ms m},
        containsThread ms tid0 -> mem_compatible ms m ->
        machine_state -> mem -> Prop:=
      fun tid ms m => @ext_step cT G Sem genv tid ms m.

    Inductive threadHalted': forall {tid0 ms},
                               containsThread ms tid0 -> Prop:=
    | thread_halted':
        forall tp c tid0
          (cnt: containsThread tp tid0),
          let: tid := Ordinal cnt in
          forall
            (Hthread: getThreadC cnt = Krun c)
            (Hcant: halted Sem c),
            threadHalted' cnt.
    Definition threadHalted: forall {tid0 ms},
                               containsThread ms tid0 -> Prop:= @threadHalted'.

    Lemma onePos: (0<1)%coq_nat. auto. Qed.
    Definition initial_machine c:=
      @mk cT (mkPos onePos) (fun _ => c) (fun _ => empty_share_map) .
    Definition init_mach  (genv:G)(v:val)(args:list val):option machine_state:=
      match initial_core Sem genv v args with
      | Some c => Some (initial_machine (Kresume c) )
      | None => None
      end.
  End ShareMachineSig.

  (* Here I make the core semantics*)
  Variable example_G: Type.
  Variable example_C: Type.
  Variable example_sem: CoreSemantics example_G example_C mem.
  Module Sem: Semantics.
    Definition G:= example_G.
    Definition C:= example_C.
    Definition M:= mem.
    Definition Sem:=example_sem.
  End Sem.
  Module mySchedule := ListScheduler NatTID.
  Module mySem := ShareMachineSig Sem.
  Module myCoarseSemantics :=
    CoarseMachine NatTID mySchedule mySem.
  Module myFineSemantics :=
    FineMachine NatTID mySchedule mySem.

  Definition coarse_semantics:=
    myCoarseSemantics.MachineSemantics.
  Definition fine_semantics:=
    myFineSemantics.MachineSemantics.

End Concur.

(* After this there needs to be some cleaning. *)

(* Section InitialCore. *)

(*   Context {cT G : Type} {the_sem : CoreSemantics G cT Mem.mem}. *)
(*   Import ThreadPool. *)

(*   Notation thread_pool := (t cT). *)
(*   Notation perm_map := access_map. *)

(*   Definition at_external (st : (list nat) * thread_pool) *)
(*   : option (external_function * signature * seq val) := None. *)

(*   Definition after_external (ov : option val) (st : list nat * thread_pool) : *)
(*     option (list nat * thread_pool) := None. *)

(*   Definition two_pos : pos := mkPos NPeano.Nat.lt_0_2. *)

(*   Definition ord1 := Ordinal (n := two_pos) (m := 1) (leqnn two_pos). *)

(*   (*not clear what the value of halted should be*) *)
(*   Definition halted (st : list nat * thread_pool) : option val := None. *)

(*   Variable compute_init_perm : G -> access_map. *)
(*   Variable lp_code : cT. *)
(*   Variable sched : list nat. *)

(*   Definition initial_core the_ge (f : val) (args : list val) : option (list nat * thread_pool) := *)
(*     match initial_core the_sem the_ge f args with *)
(*       | None => None *)
(*       | Some c => *)
(*         Some (sched, ThreadPool.mk *)
(*                        two_pos *)
(*                        (fun tid => if tid == ord0 then lp_code *)
(*                                 else if tid == ord1 then c *)
(*                                      else c (*bogus value; can't occur*)) *)
(*                        (fun tid => if tid == ord0 then empty_map else *)
(*                                   if tid == ord1 then compute_init_perm the_ge *)
(*                                   else empty_map) *)
(*                        0) *)
(*     end. *)

(*   Variable aggelos : nat -> access_map. *)

(*   Definition cstep (the_ge : G) (st : list nat * thread_pool) m *)
(*              (st' : list nat * thread_pool) m' := *)
(*     @step cT G the_sem the_ge aggelos (@coarse_step cT G the_sem the_ge) *)
(*           (fst st) (snd st) m (fst st') (snd st') m'. *)

(*   Definition fstep (the_ge : G) (st : list nat * thread_pool) m *)
(*              (st' : list nat * thread_pool) m' := *)
(*     @step cT G the_sem the_ge aggelos (@fine_step cT G the_sem the_ge) *)
(*           (fst st) (snd st) m (fst st') (snd st') m'. *)

(*   Program Definition coarse_semantics : *)
(*     CoreSemantics G (list nat * thread_pool) mem := *)
(*     Build_CoreSemantics _ _ _ *)
(*                         initial_core *)
(*                         at_external *)
(*                         after_external *)
(*                         halted *)
(*                         cstep *)
(*                         _ _ _. *)

(*   Program Definition fine_semantics : *)
(*     CoreSemantics G (list nat * thread_pool) mem := *)
(*     Build_CoreSemantics _ _ _ *)
(*                         initial_core *)
(*                         at_external *)
(*                         after_external *)
(*                         halted *)
(*                         fstep *)
(*                         _ _ _. *)

(* End InitialCore. *)

(* End Concur. *)


Require Import BinNat.
Require Import Bool.
Require Import Omega.
Require Import sflib.

Require Import Common.
Require Import Value.
Require Import Memory.
Require Import State.
Require Import Behaviors.
Require Import SmallStep.

Module Ir.

Module Refinement.

Definition refines_value (v_tgt v_src:Ir.val): bool :=
  match (v_tgt, v_src) with
  | (_, Ir.poison) => true
  | (Ir.num ntgt, Ir.num nsrc) => Nat.eqb ntgt nsrc
  | (Ir.ptr ptgt, Ir.ptr psrc) => Ir.ptr_eqb ptgt psrc
  | (_, _) => false
  end.

Definition refines_bit (b_tgt b_src:Ir.Bit.t): bool :=
  match (b_src, b_tgt) with
  | (Ir.Bit.bpoison, _) => true
  | (_, Ir.Bit.bpoison) => false
  | (Ir.Bit.bint b1, Ir.Bit.bint b2) => Bool.eqb b1 b2
  | (Ir.Bit.baddr p1 o1, Ir.Bit.baddr p2 o2) =>
    Nat.eqb o1 o2 && Ir.ptr_eqb p1 p2
  | (_, _) => false
  end.

Definition refines_byte (b_tgt b_src:Ir.Byte.t): bool :=
  refines_bit b_tgt.(Ir.Byte.b0) b_src.(Ir.Byte.b0) &&
  refines_bit b_tgt.(Ir.Byte.b1) b_src.(Ir.Byte.b1) &&
  refines_bit b_tgt.(Ir.Byte.b2) b_src.(Ir.Byte.b2) &&
  refines_bit b_tgt.(Ir.Byte.b3) b_src.(Ir.Byte.b3) &&
  refines_bit b_tgt.(Ir.Byte.b4) b_src.(Ir.Byte.b4) &&
  refines_bit b_tgt.(Ir.Byte.b5) b_src.(Ir.Byte.b5) &&
  refines_bit b_tgt.(Ir.Byte.b6) b_src.(Ir.Byte.b6) &&
  refines_bit b_tgt.(Ir.Byte.b7) b_src.(Ir.Byte.b7).

Definition refines_event (e_tgt e_src:Ir.event): bool :=
  match (e_tgt, e_src) with
  | (Ir.e_some vtgt, Ir.e_some vsrc) => Nat.eqb vtgt vsrc
  | (Ir.e_none, Ir.e_none) => true
  | _ => false
  end.

Definition refines_trace (tr_tgt tr_src:Ir.trace):bool :=
  let tr_tgt' := List.filter Ir.not_none tr_tgt in
  let tr_src' := List.filter Ir.not_none tr_src in
  if Nat.eqb (List.length tr_tgt') (List.length tr_src') then
    List.forallb (fun ee => refines_event ee.(fst) ee.(snd))
                 (List.combine tr_tgt' tr_src')
  else false.

(* If tgts_prefix is true, check whether tr_tgt has a prefix
   that refines tr_src.
   If tgts_prefix is false, check whether tr_src has a prefix
   so tr_tgt refines the prefix. *)
Definition refines_trace_prefix (tr_tgt tr_src:Ir.trace) (tgts_prefix:bool)
: bool :=
  let tr_tgt' := List.filter Ir.not_none tr_tgt in
  let tr_src' := List.filter Ir.not_none tr_src in
  let (tr_tgt', tr_src') :=
      if tgts_prefix then (List.firstn (List.length tr_src') tr_tgt', tr_src')
      else (tr_tgt', List.firstn (List.length tr_tgt') tr_src') in
  refines_trace tr_tgt' tr_src'.

(* Checks whether the behavior of a target program refines the behavior of a source program. *)
Definition refines (pb_tgt pb_src:Ir.program_behavior):bool :=
  match (pb_tgt, pb_src) with
  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_terminates tr_src ret_src) =>
    refines_trace tr_tgt tr_src && refines_value ret_tgt ret_src

  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_diverges tr_src) =>
    (* infinite loop without any event is UB.
       Chech whether target's trace has a prefix that refines trace of the source. *)
    refines_trace_prefix tr_tgt tr_src true

  | (Ir.b_terminates tr_tgt ret_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace_prefix tr_tgt tr_src true

  | (Ir.b_diverges tr_tgt, Ir.b_diverges tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_diverges tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_goes_wrong tr_tgt, Ir.b_diverges tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_goes_wrong tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace tr_tgt tr_src

  | (Ir.b_oom tr_tgt, Ir.b_terminates tr_src ret_src) =>
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_diverges tr_src) =>
    (* If source has UB and target has OOM,
       either the trace of source may be the prefix of the trace of target,
       or the trace of target may be the prefix of the trace of source. *)
    refines_trace_prefix tr_tgt tr_src true ||
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_goes_wrong tr_src) =>
    refines_trace_prefix tr_tgt tr_src true ||
    refines_trace_prefix tr_tgt tr_src false

  | (Ir.b_oom tr_tgt, Ir.b_oom tr_src) =>
    (* target trace should be prefix of source trace. *)
    refines_trace_prefix tr_tgt tr_src true

  | (_, _) => false
  end.

(***********************************************************
   Propositional definition of refinements on memory, state
 ***********************************************************)

Definition refines_memblock (mb_tgt mb_src:Ir.MemBlock.t) :=
  mb_tgt.(Ir.MemBlock.bt) = mb_src.(Ir.MemBlock.bt) /\
  mb_tgt.(Ir.MemBlock.r) = mb_src.(Ir.MemBlock.r) /\
  mb_tgt.(Ir.MemBlock.n) = mb_src.(Ir.MemBlock.n) /\
  mb_tgt.(Ir.MemBlock.a) = mb_src.(Ir.MemBlock.a) /\
  List.Forall2 (fun b1 b2 => refines_byte b1 b2 = true)
               mb_tgt.(Ir.MemBlock.c) mb_src.(Ir.MemBlock.c) /\
  mb_tgt.(Ir.MemBlock.P) = mb_src.(Ir.MemBlock.P).

Definition refines_memory (m_tgt m_src:Ir.Memory.t) :=
  m_tgt.(Ir.Memory.mt) = m_src.(Ir.Memory.mt) /\
  List.Forall2 (fun mbid_tgt mbid_src =>
                  fst mbid_tgt = fst mbid_src /\
                  refines_memblock (snd mbid_tgt) (snd mbid_src))
               m_tgt.(Ir.Memory.blocks) m_src.(Ir.Memory.blocks) /\
  m_tgt.(Ir.Memory.calltimes) = m_src.(Ir.Memory.calltimes) /\
  m_tgt.(Ir.Memory.fresh_bid) = m_src.(Ir.Memory.fresh_bid).

Definition refines_regfile (rf_tgt rf_src:Ir.Regfile.t) :=
  forall regid,
    (Ir.Regfile.get rf_tgt regid = None <-> Ir.Regfile.get rf_src regid = None) /\
    (forall vtgt
            (HGET:Ir.Regfile.get rf_tgt regid = Some vtgt),
        exists vsrc, Ir.Regfile.get rf_src regid = Some vsrc /\
                     refines_value vtgt vsrc = true).

Definition refines_stack (s_tgt s_src:Ir.Stack.t) :=
  List.Forall2 (fun itm_tgt itm_src =>
                  fst itm_tgt = fst itm_src /\
                  fst (snd itm_tgt) = fst (snd itm_src) /\
                  refines_regfile (snd (snd itm_tgt)) (snd (snd itm_src)))
               s_tgt s_src.

Definition refines_state (s_tgt s_src:Ir.Config.t) :=
  refines_memory s_tgt.(Ir.Config.m) s_src.(Ir.Config.m) /\
  refines_stack s_tgt.(Ir.Config.s) s_src.(Ir.Config.s) /\
  s_tgt.(Ir.Config.cid_to_f) = s_src.(Ir.Config.cid_to_f) /\
  s_tgt.(Ir.Config.cid_fresh) = s_src.(Ir.Config.cid_fresh).

Import Ir.SmallStep.

(* refines_step_res <tgt> <src> *)
Inductive refines_step_res: step_res -> step_res -> Prop :=
| srref_tgt_oom:
    forall sr_src,
      refines_step_res sr_oom sr_src
| srref_src_goes_wrong:
    forall sr_tgt,
      refines_step_res sr_tgt sr_goes_wrong
| srref_finish:
    forall v_tgt v_src
           (HREFV:refines_value v_tgt v_src),
    refines_step_res (sr_prog_finish v_tgt) (sr_prog_finish v_src)
| srref_success:
    forall e_tgt e_src s_tgt s_src
           (HREFE:refines_event e_tgt e_src)
           (HREFS:refines_state s_tgt s_src), (* Just checks equality. *)
    refines_step_res (sr_success e_tgt s_tgt) (sr_success e_src s_src).

(***********************************************************
               Lemmas about refinement.
 ***********************************************************)

Theorem refines_value_refl:
  forall (v:Ir.val), refines_value v v = true.
Proof.
  intros.
  destruct v; unfold refines_value.
  - rewrite Nat.eqb_eq. auto.
  - rewrite Ir.ptr_eqb_refl. reflexivity.
  - reflexivity.
Qed.

Theorem refines_value_trans:
  forall (v1 v2 v3:Ir.val)
         (HREF1:refines_value v1 v2 = true)
         (HREF2:refines_value v2 v3 = true),
    refines_value v1 v3 = true.
Proof.
  intros.
  unfold refines_value in *.
  des_ifs.
  rewrite PeanoNat.Nat.eqb_eq in *.
  congruence.
  unfold Ir.ptr_eqb in *.
  des_ifs; try rewrite andb_true_iff in *;
    repeat (rewrite PeanoNat.Nat.eqb_eq in *);
    destruct HREF1; destruct HREF2;
    try congruence.
  split; congruence.
  repeat (rewrite andb_true_iff in *);
    repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  destruct H. destruct H. destruct H1.  destruct H1.
  split; try congruence.
  split; try congruence.
  split; try congruence.
  eapply list_inclb_trans. eapply H4. ss.
  eapply list_inclb_trans. eapply H5. ss.
  split; try ss.
  repeat (rewrite andb_true_iff in *).
  repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  intuition.
  eapply list_inclb_trans. eapply H6. ss.
  eapply list_inclb_trans. eapply H5. ss.
Qed.

Theorem refines_bit_refl:
  forall b, refines_bit b b = true.
Proof.
  unfold refines_bit.
  intros.
  destruct b. destruct b; reflexivity.
  unfold Ir.ptr_eqb.
  destruct p; repeat (rewrite PeanoNat.Nat.eqb_refl); try reflexivity.
  repeat (rewrite Common.list_inclb_refl).
  destruct o. rewrite PeanoNat.Nat.eqb_refl. reflexivity.
  reflexivity.
  reflexivity.
Qed.

Lemma ptr_eqb_trans:
  forall p1 p2 p3
         (H1:Ir.ptr_eqb p1 p2 = true)
         (H2:Ir.ptr_eqb p2 p3 = true),
    Ir.ptr_eqb p1 p3 = true.
Proof.
  intros.
  unfold Ir.ptr_eqb in *.
  des_ifs; repeat (rewrite andb_true_iff in *);
           repeat (rewrite PeanoNat.Nat.eqb_eq in *);
           try (inv H1; inv H0; fail);
           try (inv H2; inv H0; fail).
  intuition.
  { inv H1. inv H. inv H0.
    inv H2. inv H. inv H0.
    split; try ss.
    split. { split. congruence.
             eapply list_inclb_trans. eapply H3. ss. }
           { eapply list_inclb_trans. eapply H2. ss. }
  }
  { inv H1. inv H. inv H1.
    inv H2. inv H. inv H2.
    split; try ss.
    split. { split. congruence.
             eapply list_inclb_trans. eapply H4. ss. }
           { eapply list_inclb_trans. eapply H5. ss. }
  }
Qed.

Theorem refines_bit_trans:
  forall b1 b2 b3
         (HREF1:refines_bit b1 b2 = true)
         (HREF2:refines_bit b2 b3 = true),
    refines_bit b1 b3 = true.
Proof.
  intros.
  unfold refines_bit in *.
  des_ifs.
  unfold eqb in *. des_ifs.
  rewrite andb_true_iff in *.
  repeat (rewrite PeanoNat.Nat.eqb_eq in *).
  intuition.
  eapply ptr_eqb_trans. eassumption. ss.
Qed.

Ltac unfold_all_ands_H :=
  repeat (match goal with
  | [ H : _ /\ _ |- _ ] => destruct H
  end).

Theorem refines_byte_trans:
  forall b1 b2 b3
         (HREF1:refines_byte b1 b2 = true)
         (HREF2:refines_byte b2 b3 = true),
    refines_byte b1 b3 = true.
Proof.
  intros.
  unfold refines_byte in *.
  repeat (rewrite andb_true_iff in *).
  unfold_all_ands_H.
  repeat (split; try (eapply refines_bit_trans; try eassumption; assumption)).
Qed.

Theorem refines_memblock_refl:
  forall mb1,
    refines_memblock mb1 mb1.
Proof.
  intros.
  repeat (split;try congruence).
  apply Forall2_samelist.
  intros.
  unfold refines_byte.
  repeat (rewrite andb_true_iff).
  repeat (rewrite refines_bit_refl).
  repeat (split; try reflexivity).
Qed.

Theorem refines_memblock_trans:
  forall mb1 mb2 mb3
         (HREF1:refines_memblock mb1 mb2)
         (HREF1:refines_memblock mb2 mb3),
    refines_memblock mb1 mb3.
Proof.
  intros.
  inv HREF1. inv H0. inv H2. inv H3.
  inv HREF0. inv H5. inv H7. inv H8.
  inv H4. inv H9.
  repeat (split;try congruence).
  eapply Forall2_trans.
  { intros. eapply refines_byte_trans. eassumption. ss.
  }
  eassumption. assumption.
Qed.

Theorem refines_memory_refl:
  forall (m1:Ir.Memory.t),
    refines_memory m1 m1.
Proof.
  intros.
  split.
  { congruence. }
  split.
  { eapply Forall2_samelist.
    intros. split. reflexivity. apply refines_memblock_refl.
  }
  split; reflexivity.
Qed.

Theorem refines_memory_trans:
  forall m1 m2 m3
         (HREF1:refines_memory m1 m2)
         (HREF1:refines_memory m2 m3),
    refines_memory m1 m3.
Proof.
  intros.
  destruct HREF1.
  destruct HREF0.
  unfold_all_ands_H.
  repeat (split; try congruence).
  eapply Forall2_trans.
  { intros.
    unfold_all_ands_H.
    split. congruence. eapply refines_memblock_trans. eassumption. ss.
  }
  eassumption. assumption.
Qed.

Theorem refines_event_refl:
  forall (e:Ir.event), refines_event e e = true.
Proof.
  intros.
  destruct e. unfold refines_event. reflexivity.
  unfold refines_event. rewrite Nat.eqb_eq. reflexivity.
Qed.

Theorem refines_trace_refl:
  forall (t:Ir.trace), refines_trace t t = true.
Proof.
  intros.
  induction t.
  - reflexivity.
  - unfold refines_trace in *.
    assert (forall {X:Type} (l:list X), (List.length l =? List.length l) = true).
    { intros.
      rewrite Nat.eqb_eq. reflexivity. }
    rewrite H. rewrite H in IHt.
    simpl.
    destruct (Ir.not_none a) eqn:HNN.
    simpl. rewrite IHt. rewrite refines_event_refl. reflexivity.
    assumption.
Qed.

Theorem refines_trace_prefix_refl:
  forall (t:Ir.trace) b, refines_trace_prefix t t b = true.
Proof.
  intros.
  destruct b; unfold refines_trace_prefix in *;
    rewrite List.firstn_all in *;
    rewrite refines_trace_refl;
    reflexivity.
Qed.

Lemma regfile_eq_empty_false:
  forall st1 st,
    ~ Ir.Regfile.eq (st::st1) [].
Proof.
  intros.
  intros HEQ.
  unfold Ir.Regfile.eq in HEQ.
  destruct st.
  assert (H := HEQ n).
  unfold Ir.Regfile.get in H.
  simpl in H. rewrite PeanoNat.Nat.eqb_refl in H. inv H.
Qed.

Theorem refines_regfile_eq:
  forall st1 st2 (HEQ:Ir.Regfile.eq st1 st2),
    refines_regfile st1 st2.
Proof.
  intros.
  unfold Ir.Regfile.eq in HEQ.
  unfold refines_regfile.
  intros.
  assert (HEQ' := HEQ regid).
  split.
  { split; intros; congruence. }
  { intros.
    eexists. rewrite HEQ' in HGET. split. eassumption.
    eapply refines_value_refl. }
Qed.

Theorem refines_regfile_trans:
  forall st1 st2 st3
         (HREF1:refines_regfile st1 st2)
         (HREF2:refines_regfile st2 st3),
    refines_regfile st1 st3.
Proof.
  intros.
  unfold refines_regfile in *.
  unfold_all_ands_H.
  intros.
  assert (H1 := HREF1 regid).
  assert (H2 := HREF2 regid).
  unfold_all_ands_H.

  split.
  {
    destruct H1. destruct H.
    split.
    { intros. apply H. apply H1. assumption. }
    { intros. apply H3. apply H4. assumption. }
  }
  intros.
  apply H2 in HGET.
  destruct HGET. destruct H3.
  apply H0 in H3. destruct H3. destruct H3.
  eexists. split. eassumption.
  eapply refines_value_trans. eassumption. ss.
Qed.

Theorem refines_stack_eq:
  forall st1 st2 (HEQ:Ir.Stack.eq st1 st2),
    refines_stack st1 st2.
Proof.
  intros.
  generalize dependent st1.
  induction st2.
  { intros. destruct st1. constructor.
    inv HEQ. }
  { intros.
    destruct st1. inv HEQ.
    inv HEQ.
    inv H2. inv H0.
    constructor.
    { split.  congruence. split. congruence.
      apply refines_regfile_eq. assumption. }
    eapply Forall2_implies.
    eapply H4.
    { intros.
      destruct x. destruct y. simpl in *.
      inv H0. inv H5. split. congruence. split. congruence.
      apply refines_regfile_eq. assumption.
    }
  }
Qed.

Theorem refines_stack_trans:
  forall st1 st2 st3
         (HREF1:refines_stack st1 st2)
         (HREF1:refines_stack st2 st3),
    refines_stack st1 st3.
Proof.
  intros.
  generalize dependent st2.
  generalize dependent st3.
  induction st1.
  { intros. inv HREF1. assumption. }
  { intros.
    destruct st2. inv HREF1.
    destruct st3. inv HREF0.
    inv HREF1. inv HREF0.
    unfold_all_ands_H.
    constructor.
    { split. congruence. split. congruence.
      eapply refines_regfile_trans. eassumption. ss. }
    { eapply Forall2_trans.
      intros.
      unfold_all_ands_H.
      split. congruence. split. congruence.
      eapply refines_regfile_trans. eassumption. ss.
      eassumption. ss.
    }
  }
Qed.

Theorem refines_state_eq:
  forall st1 st2 (HEQ:Ir.Config.eq st1 st2),
    refines_state st1 st2.
Proof.
  intros.
  inv HEQ.
  split.
  { rewrite H. eapply refines_memory_refl. }
  inv H0. split.
  apply refines_stack_eq. assumption.
  assumption.
Qed.

Theorem refines_refl:
  forall (pb:Ir.program_behavior), refines pb pb = true.
Proof.
  intros.
  destruct pb; unfold refines.
  - rewrite refines_trace_refl.
    rewrite refines_value_refl. reflexivity.
  - rewrite refines_trace_refl. reflexivity.
  - rewrite refines_trace_refl. reflexivity.
  - rewrite refines_trace_prefix_refl. reflexivity.
Qed.

Theorem refines_trace_none:
  forall (t1 t2:Ir.trace)
         (HREF:refines_trace t1 t2 = true),
    refines_trace (Ir.e_none::t1) t2 = true.
Proof. intros. unfold refines_trace in *.
       simpl. assumption.
Qed.

Theorem refines_trace_none2:
  forall (t1 t2:Ir.trace)
         (HREF:refines_trace t1 t2 = true),
    refines_trace t1 (Ir.e_none::t2) = true.
Proof. intros. unfold refines_trace in *.
       simpl. assumption.
Qed.

End Refinement.

End Ir.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import riscv.Utility.Monads.
Require Import riscv.Utility.MonadNotations.
Require Import riscv.Spec.Decode.
Require Import riscv.Spec.Machine.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.MetricPrimitives.
Require Import Coq.Lists.List. Import ListNotations.
Require Export riscv.Platform.RiscvMachine.
Require Export riscv.Platform.MetricRiscvMachine.
Require Import riscv.Platform.MinimalNoMul.
Require Import riscv.Platform.MetricLogging.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Import MetricRiscvMachine.

Local Open Scope Z_scope.
Local Open Scope bool_scope.

Section Riscv.
  Import List.
  Import free.

  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Mem: map.map word byte}.
  Context {Registers: map.map Register word}.

  Local Notation M := (free riscv_primitive primitive_result).

  Definition metrics_of(p: riscv_primitive): MetricLog -> MetricLog :=
    match p with
    | GetRegister a => id
    | SetRegister a b => id
    | LoadByte a b => addMetricLoads 1
    | LoadHalf a b => addMetricLoads 1
    | LoadWord a b => addMetricLoads 1
    | LoadDouble a b => addMetricLoads 1
    | StoreByte a b c => addMetricStores 1
    | StoreHalf a b c => addMetricStores 1
    | StoreWord a b c => addMetricStores 1
    | StoreDouble a b c => addMetricStores 1
    | MakeReservation a => id
    | ClearReservation a => id
    | CheckReservation a => id
    | GetCSRField f => id
    | SetCSRField f v => id
    | GetPrivMode => id
    | SetPrivMode m => id
    | Fence a b => id
    | GetPC => id
    | SetPC a => addMetricJumps 1
    | StartCycle => id
    | EndCycleNormal => addMetricInstructions 1
    | EndCycleEarly A => addMetricInstructions 1
    end.

  Definition interp_action p (m: MetricRiscvMachine) post :=
    interpret_action p m.(getMachine)
      (fun r mach => post r (mkMetricRiscvMachine mach (metrics_of p m.(getMetrics))))
      (fun _ => False).

  Arguments Memory.load_bytes: simpl never.
  Arguments Memory.store_bytes: simpl never.
  Arguments LittleEndian.combine: simpl never.

  Global Instance MetricMinimalNoMulPrimitivesParams: PrimitivesParams M MetricRiscvMachine :=
  {
    Primitives.mcomp_sat := @free.interp _ _ _ interp_action;
    Primitives.is_initial_register_value x := True;
    Primitives.nonmem_load := Primitives.nonmem_load (PrimitivesParams := MinimalNoMulPrimitivesParams);
    Primitives.nonmem_store := Primitives.nonmem_store (PrimitivesParams := MinimalNoMulPrimitivesParams);
    Primitives.valid_machine mach := no_M mach.(getMachine);
  }.

  Global Instance MinimalNoMulSatisfies_mcomp_sat_spec: mcomp_sat_spec MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; cbv [mcomp_sat MetricMinimalNoMulPrimitivesParams Monad_free Bind Return].
    { symmetry. eapply interp_bind_ex_mid; intros.
      eapply MinimalNoMul.interpret_action_weaken_post; eauto; cbn; eauto. }
    { symmetry. rewrite interp_ret; eapply iff_refl. }
  Qed.

  Lemma interp_action_weaken_post a (post1 post2:_->_->Prop)
    (H: forall r s, post1 r s -> post2 r s) s
    : interp_action a s post1 -> interp_action a s post2.
  Proof. eapply MinimalNoMul.interpret_action_weaken_post; eauto. Qed.
  Lemma interp_action_appendonly' a s post :
    interp_action a s post ->
    interp_action a s (fun v s' => post v s' /\ endswith s'.(getLog) s.(getLog)).
  Proof. eapply MinimalNoMul.interpret_action_appendonly''; eauto. Qed.
  Lemma interp_action_total{memOk: map.ok Mem} a (s: MetricRiscvMachine) post :
    no_M s ->
    interp_action a s post ->
    exists v s, post v s /\ no_M s.
  Proof.
    intros H H1.
    unshelve epose proof (MinimalNoMul.interpret_action_total _ _ _ _ _ H1) as H0; eauto.
    destruct H0 as (?&?&[[]|(?&?)]); eauto.
  Qed.
  Lemma interp_action_preserves_valid{memOk: map.ok Mem} a s post :
    no_M s.(getMachine) ->
    interp_action a s post ->
    interp_action a s (fun v s' => post v s' /\ no_M s'.(getMachine)).
  Proof.
    intros D I.
    unshelve epose proof (MinimalNoMul.interpret_action_preserves_valid' _ _ _ D I) as H0; eauto.
  Qed.

  Global Instance MetricMinimalNoMulPrimitivesSane{memOk: map.ok Mem} :
    MetricPrimitivesSane MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; cbv [mcomp_sane valid_machine MetricMinimalNoMulPrimitivesParams];
      intros *; intros D M;
      (split; [ exact (interp_action_total _ st _ D M)
              | eapply interp_action_preserves_valid; try eassumption;
                eapply interp_action_appendonly'; try eassumption ]).
  Qed.

  Global Instance MetricMinimalNoMulSatisfiesPrimitives{memOk: map.ok Mem}:
    MetricPrimitives MetricMinimalNoMulPrimitivesParams.
  Proof.
    split; try exact _.
    all : cbv [mcomp_sat spec_load spec_store MetricMinimalNoMulPrimitivesParams invalidateWrittenXAddrs].
    all: intros; destruct initialL;
      repeat match goal with
      | _ => progress subst
      | _ => Option.inversion_option
      | _ => progress cbn -[Memory.load_bytes Memory.store_bytes HList.tuple] in *
      | _ => progress cbv [id valid_register is_initial_register_value load store Memory.loadByte Memory.loadHalf Memory.loadWord Memory.loadDouble Memory.storeByte Memory.storeHalf Memory.storeWord Memory.storeDouble] in *
      | H : exists _, _ |- _ => destruct H
      | H : _ /\ _ |- _ => destruct H
      | |- _ => solve [ intuition (eauto || blia) ]
      | H : _ \/ _ |- _ => destruct H
      | |- context[match ?x with _ => _ end] => destruct x eqn:?
      | |- _ => progress unfold getReg, setReg
      | |-_ /\ _ => split
      end.
      (* setRegister *)
      destruct getMachine; eassumption.
  Qed.

End Riscv.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

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

  CFGV is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

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

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

*)

Require Export AlphaEquality.
Require Export SwapProps.

Set Implicit Arguments.

(** (re)defining it this way enables coq to successfully
    match the statement of [alphaEqTransitive]
    with the lemma [GAlphaInd] *)
Definition transRel {T : [univ]} (R : bin_rel T) :=
forall x y : T,
  R x y
  -> forall z : T,
     R y z -> R x z.

Lemma MakeAbsPnodeSame : forall
  {G : CFGV} {vc : VarSym G}
  (lps : list (GSym G))
  (m: Mixture (map (fun x : GSym G => (true, x)) (lps))),
  (MakeAbstractionsPNode vc m)
    = (MakeAbstractionsTNodeAux vc [] m).
Proof.
  induction m; cpx.
Qed.

Ltac remAlphaRight Hyp name :=
  match type of Hyp with
  | pAlphaEq _ _ ?r => remember r as name
  | tAlphaEq _ _ ?r => remember r as name
  end.

Ltac remAlphaLeft Hyp name :=
  match type of Hyp with
  | pAlphaEq _ ?l _ => remember l as name
  | tAlphaEq _ ?l _ => remember l as name
  end.

Section AlphaProps.
Context {G : CFGV} {vc  : VarSym G}.

Lemma alphaEquiVariant :
(
  (forall (s : GSym G) ,
      EquiVariantRelSame (@tSwap G vc s) (tAlphaEq vc))
   *
  (forall (s : GSym G),
      EquiVariantRelSame (@pSwap G vc s) (pAlphaEq vc))
  *
  (EquiVariantRelSame (@swapAbs G vc) (@AlphaEqAbs G vc))
  *
  (EquiVariantRelSame (@swapLAbs G vc) (@lAlphaEqAbs G vc))
).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
  allsimpl; try (econstructor; eauto; fail);[| | |].
- Case "tnode". constructor.
  unfold allBndngVars.
  rw <- swapLBoundVarsCommute.
  rw <- swapLBoundVarsCommute.
  rewrite <- MakeLAbsSwapCommute.
  rewrite <- MakeLAbsSwapCommute.
  cpx.
- Case "pnode". constructor.
  rewrite <- MakeAbsPNodeCommute.
  rewrite <- MakeAbsPNodeCommute.
  cpx.
- Case "termAbs".
  specialize (Hyp4 sw).
  rewrite (tcase swap_app) in Hyp4.
  rewrite (tcase swap_app) in Hyp4.
  rewrite (tcase swap_prop_e1Stronger) in Hyp4.
  match type of Hyp4 with
  tAlphaEq _ _ ?b => pattern b in Hyp4
  end.
  rewrite (tcase swap_prop_e1Stronger) in Hyp4.
  rewrite <- (tcase swap_app) in Hyp4.
  rewrite <- (tcase swap_app) in Hyp4.

  unfold swapSwap in Hyp4. rewrite map_combine in Hyp4.
  rewrite map_combine in Hyp4.
  fold (swapLVar sw lbva) in Hyp4.
  fold (swapLVar sw lbvb) in Hyp4.
  fold (swapLVar sw lbnew) in Hyp4.
  remember (swapLVar sw lbnew) as lbns.
  repnud Hyp1.
  allsimpl.
  eapply  alAbT with (lbnew := lbns); eauto;
  try ( subst; unfold swapLVar;
    autorewrite with fast; congruence; fail); cpx;
  subst;[unfolds_base; allsimpl;
  dands|];repeat (disjoint_reasoning);[ | | | | ].
  + rewrite <- (tcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + rewrite <- (tcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + apply NoRepeatsEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
  + apply DisjointEquivariant; trivial.

- Case "patAbs".
  specialize (Hyp4 sw).
  rewrite (pcase swap_app) in Hyp4.
  rewrite (pcase swap_app) in Hyp4.
  rewrite (pcase swap_prop_e1Stronger) in Hyp4.
  match type of Hyp4 with
  pAlphaEq _ _ ?b => pattern b in Hyp4
  end.
  rewrite (pcase swap_prop_e1Stronger) in Hyp4.
  rewrite <- (pcase swap_app) in Hyp4.
  rewrite <- (pcase swap_app) in Hyp4.

  unfold swapSwap in Hyp4. rewrite map_combine in Hyp4.
  rewrite map_combine in Hyp4.
  fold (swapLVar sw lbva) in Hyp4.
  fold (swapLVar sw lbvb) in Hyp4.
  fold (swapLVar sw lbnew) in Hyp4.
  remember (swapLVar sw lbnew) as lbns.
  repnud Hyp1.
  allsimpl.
  eapply  alAbP with (lbnew := lbns); eauto;
  try ( subst; unfold swapLVar;
    autorewrite with fast; congruence; fail); cpx;
  subst;[unfolds_base; allsimpl;
  dands|];repeat (disjoint_reasoning);[ | | | | ].
  + rewrite <- (pcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + rewrite <- (pcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + apply NoRepeatsEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
Qed.

Lemma tAlphaEqEquivariantRev : forall
  (sw : Swapping vc) s (ta tb : Term s),
  tAlphaEq vc (tSwap ta sw) (tSwap tb sw)
  -> tAlphaEq vc ta tb.
Proof.
  introv Hd.
  apply (tcase alphaEquiVariant) in Hd.
  specialize (Hd (rev sw)).
  autorewrite with SwapAppR in Hd.
  autorewrite with fast in Hd.
  trivial.
Qed.

Lemma pAlphaEqEquivariantRev : forall
  (sw : Swapping vc) s (ta tb : Pattern s),
  pAlphaEq vc (pSwap ta sw) (pSwap tb sw)
  -> pAlphaEq vc ta tb.
Proof.
  introv Hd.
  apply (tcase alphaEquiVariant) in Hd.
  specialize (Hd (rev sw)).
  autorewrite with SwapAppR in Hd.
  autorewrite with fast in Hd.
  trivial.
Qed.

(** todo : better name .. [lv] is not nil anymore *)
Lemma AlphaEqNilAbsT : forall
(gs : GSym G) (tma tmb : Term gs)
(lv : list (vType vc)),
tAlphaEq vc tma tmb
-> AlphaEqAbs (termAbs vc lv tma) (termAbs vc lv tmb).
Proof.
  introv Ha.
  pose proof (GFreshDistRenWSpec vc lv
  (tAllVars tma++tAllVars tmb++lv))
    as XX.
  exrepnd. repeat (disjoint_reasoning).
  eapply  alAbT with (lbnew := lvn); eauto;
  unfold tFresh; dands;allsimpl;
  repeat(disjoint_reasoning); auto;[].
  apply alphaEquiVariant; cpx.
Qed.

Lemma AlphaEqNilAbsP : forall
(gs : GSym G) (tma tmb : Pattern gs)
(lv : list (vType vc)),
pAlphaEq vc tma tmb
-> AlphaEqAbs (patAbs vc lv tma) (patAbs vc lv tmb).
Proof.
  introv Ha.
  pose proof (GFreshDistRenWSpec vc lv
  (pAllVars tma++pAllVars tmb++lv))
    as XX.
  exrepnd. repeat (disjoint_reasoning).
  eapply  alAbP with (lbnew := lvn); eauto;
  unfold pFresh; dands;allsimpl;
  repeat(disjoint_reasoning); auto;[].
  apply alphaEquiVariant; cpx.
Qed.

Notation vcType := (vType vc).
Notation vcAbstraction := (@Abstraction G vc).

Lemma alphaEqRefl :
     (  (forall (s : GSym G) (t : Term s),
            tAlphaEq vc t t)
         *
        (forall (s : GSym G) (pt : Pattern s),
            pAlphaEq vc pt pt)
         *
        (forall (l : MixtureParam) (m : Mixture l)
        (lbv : list (list (vType vc))),
           lAlphaEqAbs (MakeAbstractions vc m lbv)
                       (MakeAbstractions vc m lbv))).
Proof.
  GInduction; introns Hyp; intros; cpx; allsimpl;
  try dlist_len lbv;  try (econstructor; eauto with slow; fail).
- Case "mtcons". econstructor; eauto;[].
  remember (lhead lbv) as lbvh.
  apply AlphaEqNilAbsT;cpx.
- Case "mpcons". econstructor; eauto;[].
  remember (lhead lbv) as lbvh.
  apply AlphaEqNilAbsP;cpx.
Qed.

Hint Resolve
(tcase alphaEqRefl)
(pcase alphaEqRefl)
(mcase alphaEqRefl)
  AlphaEqNilAbsT
  AlphaEqNilAbsP

 : Alpha.

Lemma talphaEqRefl : forall (s : GSym G)
  (ta tb : Term s),
  ta=tb -> tAlphaEq vc ta tb.
Proof.
  intros. subst. eauto with Alpha.
Qed.

Require Import Eqdep_dec.

Hint Resolve deqMixP: Deq.

Lemma alphaEqSym :
(  (forall (s : GSym G) (ta tb : Term s),
      tAlphaEq vc ta tb -> tAlphaEq vc tb ta)
   *
  (forall (s : GSym G) (pta ptb : Pattern s),
      pAlphaEq vc pta ptb -> pAlphaEq vc ptb pta)
   *
  (forall (aa ab : Abstraction G vc),
      AlphaEqAbs aa ab -> AlphaEqAbs ab aa)
   *
  (forall (la lb : list (Abstraction G vc)),
      lAlphaEqAbs la lb -> lAlphaEqAbs lb la)).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
    try (econstructor; eauto; fail);[|].
- Case "termAbs".  eapply  alAbT with (lbnew := lbnew); eauto;
  [eauto with SetReasoning | repeat(disjoint_reasoning)].
- Case "patAbs".  eapply  alAbP with (lbnew := lbnew); eauto;
  [eauto with SetReasoning | repeat(disjoint_reasoning)].
Qed.

Lemma AlphaEqAbsTSameParam : forall (gsa gsb : GSym G)
  (lbva lbvb: list vcType)
  (tma : Term gsa) (tmb : Term gsb),
  AlphaEqAbs
      (termAbs vc lbva tma)
      (termAbs vc lbvb tmb)
  -> gsa =gsb.
Proof.
  introv Hal.
  inversion Hal.
  auto.
Qed.

Lemma AlphaEqAbsPSameParam : forall (gsa gsb : GSym G)
  (lbva lbvb: list vcType)
  (tma : Pattern gsa) (tmb : Pattern gsb),
  AlphaEqAbs
      (patAbs vc lbva tma)
      (patAbs vc lbvb tmb)
  -> gsa =gsb.
Proof.
  introv Hal.
  inversion Hal.
  auto.
Qed.

Lemma betterAbsTElim : forall (gs : GSym G)
  (lbva lbvb lvAvoid: list vcType)
  (tma tmb : Term gs),
  AlphaEqAbs
      (termAbs vc lbva tma)
      (termAbs vc lbvb tmb)
->{lbnew : list vcType $
      let swapa := combine lbva lbnew in
      let swapb := combine lbvb lbnew in
      length lbva = length lbnew #
      length lbvb = length lbnew #
      tFresh lbnew [tma, tmb] #
      (** naive elimination does not give the [lvAvoid] in the
         next hypothesis *)
      disjoint (lvAvoid++lbva++lbvb) lbnew #
      tAlphaEq vc (tSwap tma swapa) (tSwap tmb swapb)}.
Proof.
  introv Hab.
  inversion Hab. clear Hab.
  EqDecSndEq. subst.
  subst swapa. subst swapb.
  pose proof (GFreshDistRenWSpec vc lbnew
              (tAllVars tma++tAllVars tmb++
                    lbnew ++lbva ++ lbvb++ lvAvoid))
    as Hfr.
  exrepnd. exists lvn. simpl.
  dands; try congruence; unfold tFresh;
  allsimpl; dands; repeat(disjoint_reasoning);[].
  rename X0 into Htal.
  apply (tcase alphaEquiVariant ) in Htal.
  specialize (Htal (combine lbnew lvn)).
  rewrite (tcase swap_app) in Htal.
  rewrite (tcase swap_app) in Htal.
  unfold tFresh in X.
  allsimpl. repnd.
  autorewrite with slow in Htal; try congruence;
  cpx; repeat (disjoint_reasoning).
Qed.

Lemma betterAbsPElim : forall (gs : GSym G)
  (lbva lbvb lvAvoid: list vcType)
  (tma tmb : Pattern gs),
  AlphaEqAbs
      (patAbs vc lbva tma)
      (patAbs vc lbvb tmb)
->{lbnew : list vcType $
      let swapa := combine lbva lbnew in
      let swapb := combine lbvb lbnew in
      length lbva = length lbnew #
      length lbvb = length lbnew #
      pFresh lbnew [tma, tmb] #
      (** naive elimination does not give thhe next hypothesis *)
      disjoint (lvAvoid++lbva++lbvb) lbnew #
      pAlphaEq vc (pSwap tma swapa) (pSwap tmb swapb)}.
Proof.
  introv Hab.
  inversion Hab. clear Hab.
  EqDecSndEq. subst.
  subst swapa. subst swapb.
  pose proof (GFreshDistRenWSpec vc lbnew
              (pAllVars tma++pAllVars tmb++
                    lbnew ++lbva ++ lbvb++ lvAvoid))
    as Hfr.
  exrepnd. exists lvn. simpl.
  dands; try congruence; unfold pFresh;
  allsimpl; dands; repeat(disjoint_reasoning);[].
  rename X0 into Htal.
  apply (tcase alphaEquiVariant ) in Htal.
  specialize (Htal (combine lbnew lvn)).
  rewrite (pcase swap_app) in Htal.
  rewrite (pcase swap_app) in Htal.
  unfold pFresh in X.
  allsimpl. repnd.
  autorewrite with slow in Htal; try congruence;
  cpx; repeat (disjoint_reasoning).
Qed.

Lemma alphaEqTransitive :
(
  (forall (s : GSym G) ,
      transRel (@tAlphaEq _ vc s))
   *
  (forall (s : GSym G),
      transRel (@pAlphaEq _ vc s))
  *
      transRel (@AlphaEqAbs G vc)
  *
      transRel (@lAlphaEqAbs G vc)
).
Proof.
  intros.
  GAlphaInd; introns Hyp; intros;
  allsimpl; trivial; try (econstructor; eauto; fail);
    [ | | | | | |].
- Case "tnode". inverts Hyp1.
  EqDecSndEq. subst.
  rename mb0 into mc.
  econstructor; eauto with slow.

- Case "pvleaf".  inverts Hyp.
  EqDecSndEq. subst.
  constructor.

- Case "pembed".  inverts Hyp1;
  EqDecSndEq; subst;
  econstructor; eauto with slow.

- Case "pnode". inverts Hyp1.
  EqDecSndEq. subst.
  rename mb0 into mc.
  econstructor; eauto with slow.

- Case "termAbs".
  destruct z as [ss lbvc tmc|];[|inversion Hyp5].
  duplicate Hyp5 as Htal.
  apply AlphaEqAbsTSameParam in Hyp5.
  symmetry in Hyp5. subst.
  apply (betterAbsTElim (lbnew ++ lbva++ (tAllVars tma))) in Htal.
  allsimpl. exrepnd.
  rename lbnew0 into lbcnew.
  (** we need to prepare lhs of [Htal0] so that it can match
    the inductive hypothessis [Hyp4].
    then we can undo the extra swappings done
    to rhs in this process *)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbcnew lbnew)).
  rewrite (tcase swap_app) in Htal0.
  rewrite (tcase swap_app) in Htal0.
  unfold tFresh in Htal3.
  unfold tFresh in Hyp1.
  allsimpl. repnd.
  remAlphaRight Htal0 ll.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  apply Hyp4 in Htal0.  subst.
  (* undo the changes done to RHS of [Htal0]*)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbnew lbcnew)).
  remAlphaRight Htal0 ll.
  rewrite (tcase swap_app) in Htal0.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  rewrite (tcase swap_app) in Heqll.
  rw <- app_assoc in Heqll.
  rewrite <- (tcase swap_app) in Heqll.
  rewrite <- (tcase swap_app) in Heqll.
  rewrite (tcase swapSwitch) in Heqll.
  rewrite <- AssociationList.ALSwitchCombine in Heqll.
  rewrite (tcase swapRevNoRep) in Heqll; auto;
  autorewrite with fast; cpx;[| disjoint_reasoning; fail].
  rewrite (tcase swap_app) in Heqll.
  rewrite (tcase swap_prop_s2Stronger) in Heqll.
  subst.
  apply alAbT with (lbnew:=lbcnew); try congruence;
  [unfolds_base; simpl; dands |]; cpx;
  repeat (disjoint_reasoning).
- Case "patAbs".
  destruct z as [|ss lbvc tmc];[inversion Hyp5|];[].
  duplicate Hyp5 as Htal.
  apply AlphaEqAbsPSameParam in Hyp5.
  symmetry in Hyp5. subst.
  apply (betterAbsPElim (lbnew ++ lbva++ (pAllVars tma))) in Htal.
  allsimpl. exrepnd.
  rename lbnew0 into lbcnew.
  (** we need to prepare lhs of [Htal0] so that it can match
    the inductive hypothessis [Hyp4].
    then we can undo the extra swappings done
    to rhs in this process *)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbcnew lbnew)).
  rewrite (pcase swap_app) in Htal0.
  rewrite (pcase swap_app) in Htal0.
  unfold pFresh in Htal3.
  unfold pFresh in Hyp1.
  allsimpl. repnd.
  remAlphaRight Htal0 ll.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  apply Hyp4 in Htal0.  subst.

  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbnew lbcnew)).
  remAlphaRight Htal0 ll.
  rewrite (pcase swap_app) in Htal0.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  rewrite (pcase swap_app) in Heqll.
  rw <- app_assoc in Heqll.
  rewrite <- (pcase swap_app) in Heqll.
  rewrite <- (pcase swap_app) in Heqll.
  rewrite (pcase swapSwitch) in Heqll.
  rewrite <- AssociationList.ALSwitchCombine in Heqll.
  rewrite (pcase swapRevNoRep) in Heqll; auto;
  autorewrite with fast; cpx;[| disjoint_reasoning; fail].
  rewrite (pcase swap_app) in Heqll.
  rewrite (pcase swap_prop_s2Stronger) in Heqll.
  subst.
  apply alAbP with (lbnew:=lbcnew); try congruence;
  [unfolds_base; simpl; dands |]; cpx;
  repeat (disjoint_reasoning).
- Case "laCons".  inverts Hyp3.
  subst. constructor; auto.
Qed.

(*
Lemma alphaEqSym :
     (  (forall (s : GSym G) (ta tb : Term s)
        (lvA : list vcType),
            tAlphaEq lvA ta tb -> tAlphaEq lvA tb ta)
         *
        (forall (s : GSym G) (pta ptb : Pattern s)
        (lvA : list vcType),
            pAlphaEq lvA pta ptb -> pAlphaEq lvA ptb pta)
         *
        (forall (l : MixtureParam) (ma mb : Mixture l)
        (lvA : list vcType)
        (lbva lbvb : list (list (vType vc))),
           lAlphaEqAbs lvA (MakeAbstractions ma lbva)
                           (MakeAbstractions mb lbvb)
        -> lAlphaEqAbs lvA (MakeAbstractions mb lbvb)
                           (MakeAbstractions ma lbva))).
Proof.
  GInductionS; introns Hyp; cpx; allsimpl;
  try (inversion Hyp; EqDecSndEq; subst; econstructor; eauto; fail);
  try (inversion Hyp0; EqDecSndEq; subst; inversion Hyp0;
  subst; EqDecSndEq; subst; econstructor; eauto; fail);[|].
- inversion Hyp1. EqDecSndEq. subst. econstructor; eauto.
  inversion X. subst. subst swapa. subst swapb.
  EqDecSndEq. subst. econstructor; eauto.
  + eauto with SetReasoning.
  + apply Hyp; auto; autorewrite with fast. auto.
  + inversion mb. subst. destruct mb;
    inverts H. subst. duplicate X0 as XX.
    inversion X0;subst; cpx.

(* apply Hyp0.

apply Hyp0.
- inversion Hyp1. EqDecSndEq. subst. econstructor; eauto.
  inversion X. subst. subst swapa. subst swapb.
  EqDecSndEq. subst. econstructor; eauto.
  + eauto with SetReasoning.
  + apply Hyp; auto; autorewrite with fast. auto.
Qed.
*)

Abort.
*)

Lemma eqset_subtractv_if_left :
  forall l l1 l2,
    eqset l1 l2 -> eqset (@subtractv G vc l1 l) (subtractv l2 l).
Proof.
  unfold subtractv.
  apply eqset_diff_if_left.
Qed.

Lemma eqset_subtractv_if_right :
  forall l l1 l2,
    eqset l1 l2 -> eqset (@subtractv G vc l l1) (subtractv l l2).
Proof.
  unfold subtractv.
  apply eqset_diff_if_right.
Qed.

Lemma eq_subtractv_if_left :
  forall l l1 l2,
    l1 = l2 -> @subtractv G vc l1 l = subtractv l2 l.
Proof.
  sp; subst; sp.
Qed.

Lemma eq_subtractv_if_right :
  forall l l1 l2,
    l1 = l2 -> @subtractv G vc l l1 = subtractv l l2.
Proof.
  sp; subst; sp.
Qed.

Lemma subtractv_nil :
  forall l,
    @subtractv G vc l [] = l.
Proof.
  unfold subtractv; sp.
Qed.

Lemma subtractv_nil_l :
  forall l,
    @subtractv G vc [] l = [].
Proof.
  unfold subtractv; sp.
  rw diff_nil; auto.
Qed.

Lemma subtractv_app_l :
  forall l1 l2 l,
    @subtractv G vc (l1 ++ l2) l = subtractv l1 l ++ subtractv l2 l.
Proof.
  unfold subtractv; introv.
  rw diff_app_r; auto.
Qed.

Definition freevars_abs (a : Abstraction G vc) :=
  match a with
    | termAbs _ vars t => subtractv (tfreevars vc t) vars
    | patAbs  _ vars p => subtractv (pfreevars vc p) vars
  end.

Fixpoint freevars_labs (l : list (Abstraction G vc)) :=
  match l with
    | [] => []
    | a :: l => freevars_abs a ++ freevars_labs l
  end.

(* bad duplicate: this equality holds unconditionally
    see freevarsEquivariant in SwapProps.v*)
Lemma freevars_swap_eq :
  (
    (forall (gs : GSym G) (t : Term gs),
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> tFresh l [t]
       -> tfreevars vc (tSwap t (combine l1 l))
          = swapLVar (combine l1 l) (tfreevars vc t))
    *
    (forall (gs : GSym G) (p : Pattern gs),
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> pFresh l [p]
       -> pfreevars vc (pSwap p (combine l1 l))
          = swapLVar (combine l1 l) (pfreevars vc p))
    *
    (forall (lgs : list (bool * GSym G)) (m : Mixture lgs) lbvars,
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> mFresh l [m]
       -> mfreevars vc (mSwap m (combine l1 l)) (swapLLVar (combine l1 l) lbvars)
          = swapLVar (combine l1 l) (mfreevars vc m lbvars))
  ).
Proof.
  GInduction; auto; introv;
  try (complete (allsimpl; cpx));
  try (complete (allsimpl; introv f e; DDeqs; cpx; rw subtractv_nil_l; auto)).

  - Case "tnode".
    allsimpl.
    introv M len disj f.
    unfold allBndngVars.
    rewrite lBoundVars_swap.
    rw M; auto.

  - Case "pnode".
    allsimpl.
    introv M len disj f.
    apply (M []); auto.

  - Case "mtcons".
    allsimpl.
    introv T M len disj f.
    destruct lbvars; simpl;
    rewrite swapLVar_app;
    apply app_if.

    + apply T; auto;
      try (complete (unfold mFresh in f; unfold mFresh, tFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply (M []); auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + rewrite swapLVar_subtractv.
      rw T; auto;
      try (complete (unfold mFresh in f; unfold mFresh, tFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply M; auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

  - Case "mpcons".
    allsimpl.
    introv P M len disj f.
    destruct lbvars; simpl;
    rewrite swapLVar_app;
    apply app_if.

    + apply P; auto;
      try (complete (unfold mFresh in f; unfold mFresh, pFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply (M []); auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + rewrite swapLVar_subtractv.
      rw P; auto;
      try (complete (unfold mFresh in f; unfold mFresh, pFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply M; auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).
Qed.

Lemma tFresh_app :
  forall g l (l1 l2 : list (Term g)),
    @tFresh G vc g l (l1 ++ l2) <=> (tFresh l l1 # tFresh l l2).
Proof.
  introv.
  unfold tFresh.
  rw flat_map_app.
  rw disjoint_app_r.
  split; sp.
Qed.

Lemma pFresh_app :
  forall g l (l1 l2 : list (Pattern g)),
    @pFresh G vc g l (l1 ++ l2) <=> (pFresh l l1 # pFresh l l2).
Proof.
  introv.
  unfold pFresh.
  rw flat_map_app.
  rw disjoint_app_r.
  split; sp.
Qed.

(* duplicate *)
Lemma swapVar_unchanged :
  forall v l1 l2,
    !LIn v l1
    -> !LIn v l2
    -> @swapVar G vc (combine l1 l2) v = v.
Proof.
  induction l1; introv ni1 ni2; allsimpl; auto.
  allrw not_over_or; repnd.
  destruct l2; allsimpl; auto.
  allrw not_over_or; repnd.
  DDeqs; sp.
Qed.
(* duplicate *)
Lemma swapVar_in :
  forall l1 l2 v,
    LIn v l1
    -> disjoint l1 l2
    -> length l1 = length l2
    -> no_repeats l2
    -> LIn (@swapVar G vc (combine l1 l2) v) l2.
Proof.
  induction l1 as [|x1 l1]; introv i1 disj len norep; allsimpl; tcsp.
  destruct l2 as [|x2 l2]; allsimpl; cpx.
  allrw disjoint_cons_l; allrw disjoint_cons_r; repnd; allsimpl.
  allrw not_over_or; repnd.
  allrw no_repeats_cons; repnd.
  DDeqs; sp; GC; rw (swapVar_unchanged x2); auto.
Qed.

Lemma eq_subtractv :
  forall vs1 vs2 l1 l2 l,
    disjoint l vs1
    -> disjoint l vs2
    -> disjoint l l1
    -> disjoint l l2
    -> length l = length l1
    -> length l = length l2
    -> no_repeats l
    -> @swapLVar G vc (combine l1 l) vs1 = swapLVar (combine l2 l) vs2
    -> subtractv vs1 l1 = subtractv vs2 l2.
Proof.
  induction vs1; introv disj1 disj2 disj3 disj4 len1 len2 norep e;
  allsimpl; destruct vs2; allsimpl;
  allrw subtractv_nil; allrw subtractv_nil_l; auto; inj.
  allapply cons_inj; repnd.
  repeat (rewrite subtractv_cons).
  allrw disjoint_cons_r; repnd.
  DDeqs; try (complete (eapply IHvs1; eauto)).

  - rw (swapVar_unchanged v) in e0; auto.

    pose proof (@swapVar_in l1 l a) as h;
      repeat (autodimp h hyp);
      try (complete (apply disjoint_sym; auto)).
    rw e0 in h; sp.

  - rw (swapVar_unchanged a) in e0; auto.

    pose proof (@swapVar_in l2 l v) as h;
      repeat (autodimp h hyp);
      try (complete (apply disjoint_sym; auto)).
    rw <- e0 in h; sp.

  - rw (swapVar_unchanged v) in e0; auto.
    rw (swapVar_unchanged a) in e0; auto.
    subst.
    apply eq_cons; auto.
    apply IHvs1 with (l := l); auto.
Qed.

Lemma freevars_in_allvars :
  (
    (forall (gs : GSym G) (t : Term gs),
       subset (tfreevars vc t) (tAllVars t))
    *
    (forall (gs : GSym G) (p : Pattern gs),
       subset (pfreevars vc p) (pAllVars p))
    *
    (forall (lgs : list (bool * GSym G)) (m : Mixture lgs) lbvars,
       subset (mfreevars vc m lbvars) (mAllVars m))
  ).
Proof.
  GInduction; auto; introv;
  try (complete (allsimpl; cpx));
  try (complete (allsimpl; introv f e; DDeqs; cpx; rw subtractv_nil_l; auto)).

  - Case "mtcons".
    allsimpl.
    introv ss M; introv.
    destruct lbvars; allsimpl; apply subset_app_lr; auto.
    unfold subtractv.
    apply subset_diff.
    apply subset_app_r; auto.

  - Case "mpcons".
    allsimpl.
    introv ss M; introv.
    destruct lbvars; allsimpl; apply subset_app_lr; auto.
    unfold subtractv.
    apply subset_diff.
    apply subset_app_r; auto.
Qed.

Lemma alpha_preserves_free_vars :
  (
    (forall (s : GSym G) (t1 t2 : Term s),
       tAlphaEq vc t1 t2 -> tfreevars vc t1 = tfreevars vc t2)
    *
    (forall (s : GSym G) (p1 p2 : Pattern s),
       pAlphaEq vc p1 p2 -> pfreevars vc p1 = pfreevars vc p2)
    *
    (forall a1 a2,
       AlphaEqAbs a1 a2 -> freevars_abs a1 = freevars_abs a2)
    *
    (forall l1 l2,
       lAlphaEqAbs l1 l2 -> freevars_labs l1 = freevars_labs l2)
  ).
Proof.
  intros.
  GAlphaInd; introns Hyp; intros;
  try (complete (allsimpl; auto; ddeq; auto)).

  - Case "tnode".
    allsimpl.
    allunfold MakeAbstractionsTNode.
    allunfold MakeAbstractionsTNodeAux.
    clear Hyp.

    assert (forall ma : Mixture (tpRhsAugIsPat p),
              freevars_labs
                (MakeAbstractions vc ma
                                  (lBoundVars vc (bndngPatIndices p) ma))
              = mfreevars vc ma (lBoundVars vc (bndngPatIndices p) ma)) as eqs.
    (* begin proof of assert *)
    clear ma mb Hyp0.
    introv.
    remember (lBoundVars vc (bndngPatIndices p) ma); clear Heql.
    revert l.
    induction ma; introv; simpl; auto.
    destruct l; allsimpl.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    destruct l; allsimpl.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    (* end proof of assert *)

    repeat (rw <- eqs); auto.

  - Case "pnode".
    allsimpl.
    allunfold MakeAbstractionsPNode.
    clear Hyp.

    assert (forall ma : Mixture (map (fun x : GSym G => (true, x)) (ppRhsSym p)),
              freevars_labs (MakeAbstractions vc ma [])
              = mfreevars vc ma []) as eqs.
    (* begin proof of assert *)
    clear ma mb Hyp0.
    introv.
    induction ma; introv; simpl; auto.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    (* end proof of assert *)

    repeat (rw <- eqs); auto.

  - Case "termAbs".
    allsimpl.
    allrw disjoint_app_l; repnd.
    rw two_as_app in Hyp1.
    apply tFresh_app in Hyp1; repnd.
    repeat (rw (fst (fst freevars_swap_eq)) in Hyp4; auto).

    apply eq_subtractv with (l := lbnew); auto;
    try (complete (apply disjoint_sym; auto));
    unfold tFresh in Hyp1; unfold tFresh in Hyp6; repnd; auto;
    allrw disjoint_flat_map_r;
    pose proof (Hyp7 tmb) as h1; simpl in h1; autodimp h1 hyp;
    pose proof (Hyp8 tma) as h2; simpl in h2; autodimp h2 hyp.

    pose proof (fst (fst freevars_in_allvars) gs tma) as h.
    apply subset_disjoint_r with (l2 := tAllVars tma); auto.

    pose proof (fst (fst freevars_in_allvars) gs tmb) as h.
    apply subset_disjoint_r with (l2 := tAllVars tmb); auto.

  - Case "patAbs".
    allsimpl.
    allrw disjoint_app_l; repnd.
    rw two_as_app in Hyp1.
    apply pFresh_app in Hyp1; repnd.
    repeat (rw (snd (fst freevars_swap_eq)) in Hyp4; auto).

    apply eq_subtractv with (l := lbnew); auto;
    try (complete (apply disjoint_sym; auto));
    unfold pFresh in Hyp1; unfold pFresh in Hyp6; repnd; auto;
    allrw disjoint_flat_map_r;
    pose proof (Hyp7 tmb) as h1; simpl in h1; autodimp h1 hyp;
    pose proof (Hyp8 tma) as h2; simpl in h2; autodimp h2 hyp.

    pose proof (snd (fst freevars_in_allvars) gs tma) as h.
    apply subset_disjoint_r with (l2 := pAllVars tma); auto.

    pose proof (snd (fst freevars_in_allvars) gs tmb) as h.
    apply subset_disjoint_r with (l2 := pAllVars tmb); auto.

  - Case "laCons".
    allsimpl.
    apply app_if; auto.
Qed.

Ltac dvlin v l := destruct (in_deq _ (DeqVtype vc) v l).

(* duplicate : do SearchAbout tFresh app *)
Lemma tFresh_app_l :
  forall g l1 l2 ts,
    @tFresh G vc g (l1 ++ l2) ts
    <=>
    (tFresh l1 ts # tFresh l2 ts # disjoint l1 l2 # no_repeats l1 # no_repeats l2).
Proof.
  unfold tFresh; introv.
  rw disjoint_app_l.
  rw no_repeats_app; split; sp.
Qed.

Lemma simple_combine_app_app :
  forall T (l1 l2 l3 l4 : list T),
    length l1 = length l3
    -> combine (l1 ++ l2) (l3 ++ l4)
       = combine l1 l3 ++ combine l2 l4.
Proof.
  induction l1; simpl; introv len; destruct l3; allsimpl; cpx.
  rw IHl1; sp.
Qed.

End AlphaProps.

Lemma tAlphaEqTransEauto:
 forall
  {G : CFGV} {vc : VarSym G}
   (s : GSym G) (a b c : Term s),
   tAlphaEq vc a b
   -> tAlphaEq vc b c
   -> tAlphaEq vc a c.
Proof.
  introns Hyp.
  pose proof (@alphaEqTransitive G vc) as Hpr.
  repnd. unfold transRel in Hpr2.
  eauto.
Qed.

Lemma pAlphaEqTransEauto:
 forall
  {G : CFGV} {vc : VarSym G}
   (s : GSym G) (a b c : Pattern s),
   pAlphaEq vc a b
   -> pAlphaEq vc b c
   -> pAlphaEq vc a c.
Proof.
  introns Hyp.
  pose proof (@alphaEqTransitive G vc) as Hpr.
  repnd. unfold transRel in Hpr1.
  eauto.
Qed.

Definition ALtcase
  {A B C D} (t:A*B*C*D) : A
  := fst (fst (fst t)).

Definition ALpcase
  {A B C D} (t:A*B*C*D) : B
  := snd (fst (fst t)).

Definition Abcase
  {A B C D} (t:A*B*C*D) : C
  := (snd (fst t)).

Definition LAbcase
  {A B C D} (t:A*B*C*D) : D
  := ((snd t)).

Hint Resolve
(tcase alphaEqRefl)
(pcase alphaEqRefl)
(mcase alphaEqRefl)
  (ALtcase alphaEqSym)
  (ALpcase alphaEqSym)
  (Abcase alphaEqSym)
  (LAbcase alphaEqSym)
  AlphaEqNilAbsT
  AlphaEqNilAbsP
  tAlphaEqTransEauto
  pAlphaEqTransEauto : Alpha.

Lemma pAlphaSwapEmSwap
 : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s), True)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (sw : Swapping vc),
      pAlphaEq vc (pSwapEmbed pta sw)
                  (pSwap pta sw))
   *
  (forall (mp : MixtureParam) (ma: Mixture mp)
  (llbv : list (list (vType vc)))
  (sw : Swapping vc),
  (forall b s, LIn (b,s) mp -> b= true)
   -> lAlphaEqAbs (MakeAbstractions vc (mSwapEmbed ma sw) llbv)
                (MakeAbstractions vc (mSwap ma sw) llbv))).
Proof.
intros.
GInduction; cpx; allsimpl;
  try (econstructor; eauto with Alpha; fail).
- Case "pnode". introns Hyp.
  allsimpl. constructor.
  unfold MakeAbstractionsPNode.
  apply Hyp.
  introv Hin.
  apply in_map_iff in Hin; exrepnd; cpx.
- Case "mtcons". introns Hyp.
   pose proof (Hyp1 _ _ (inl eq_refl)). cpx.
Qed.

(** swapping by swapping that leaves the
    free vars unchanged results in an alpha equal term.
    A swapping with whose both domain and range
    are disjoint from freevars can be used *)
Lemma alphaEqSwapNonFree : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (t : Term s) (sw : Swapping vc),
      leavesLVarUnchanged sw (tfreevars vc t)
      -> tAlphaEq vc t (tSwap t sw))
   *
  (forall (s : GSym G) (pt : Pattern s) (sw : Swapping vc),
     leavesLVarUnchanged sw (pfreevars vc pt)
      -> pAlphaEq vc pt (pSwap pt sw))
   *
  (forall (l : MixtureParam) (m : Mixture l) (sw : Swapping vc)
  (lbv : list (list (vType vc))),
      leavesLVarUnchanged sw (mfreevars vc m lbv)
      -> lAlphaEqAbs
            (MakeAbstractions vc m lbv)
            (MakeAbstractions vc (mSwap m sw) (swapLLVar sw lbv)))).
Proof.
  intros.
  GInduction; introns Hyp; intros; cpx; allsimpl;
  try dlist_len lbv;  try (econstructor; eauto with slow; fail).

- Case "vleaf".
  rewrite DeqSym.
  ddeq; sp;[| eauto with Alpha; fail].
  destruct e. allsimpl.
  repeat (disjoint_reasoning).
  rewrite Hyp; cpx.
  eauto 1 with Alpha.

- Case "tnode". constructor. allunfold mAlphaEq.
  unfold MakeAbstractionsTNode.
  unfold MakeAbstractionsTNodeAux.
  unfold allBndngVars.
   rewrite <- lBoundVars_equivariant.
  cpx.

- Case "pnode". constructor. allunfold mAlphaEq.
  unfold MakeAbstractionsPNode.
  specialize (Hyp sw nil).
  simpl in Hyp. cpx.

- Case "mtcons". destruct lbv; cpx;
  apply lforallApp in Hyp1; repnd;
  [ allsimpl; specialize (Hyp0 sw []); simpl in Hyp0;
    constructor; cpx ;
     apply AlphaEqNilAbsT;
      apply Hyp; cpx|].

    constructor; cpx.
  allsimpl.
  pose proof  (GFreshDistRenWSpec vc l
            (tAllVars ph++tAllVars  (tSwap ph sw)++
              (swapLVar sw l)++ l ++ (tfreevars vc ph)++
                  ALDom sw ++ ALRange sw ++ l))
      as Hfr.
  exrepnd.
  apply alAbT with (lbnew:=lvn);
    try (unfold swapLVar ; autorewrite with fast;
      congruence; fail);
  [unfolds_base; simpl; dands | | ]; cpx;
  try (autorewrite with fast;
  repeat (disjoint_reasoning); fail);[].
  autorewrite with SwapAppR.
  assert (lvn = swapLVar sw lvn ) as XX by
    (symmetry; apply swapLVarNoChange;
        repeat (disjoint_reasoning)).

  remember (combine l lvn) as swt.
  rewrite XX.
  unfold swapLVar. rewrite <- map_combine.
  fold (swapSwap sw (combine l lvn)).
  rewrite <- (tcase swap_prop_e1Stronger).
  subst swt.
  apply tAlphaEqEquivariantRev with
    (sw0:=rev (combine l lvn)).
  autorewrite with SwapAppR.
  autorewrite with fast.
  apply Hyp.
  intros v Hin.
  unfolds_base.
  autorewrite with SwapAppL.
  assert (disjoint l lvn) as Xd by repeat(disjoint_reasoning).
  destruct (in_deq _ (DeqVtype vc) v l) as [Xin | Xnot].
  + dimp (@swapVar_in G vc l lvn v); cpx.
    remember (swapVar (combine l lvn) v) as vs.
    assert (leavesLVarUnchanged sw lvn)  as Xun by
    (apply leavesLVarUnchanged1;repeat (disjoint_reasoning)).
    apply Xun in hyp.
    repnud hyp. rw hyp. subst vs.
    autorewrite with SwapAppR.
    autorewrite with fast. refl.
  + assert (disjoint (tfreevars vc ph) lvn) as Hdiss by
      repeat (disjoint_reasoning).
    assert (LIn v (tfreevars vc ph -- l)) as Hins by
    (apply in_diff; dands; cpx).
    apply Hdiss in Hin.
    pattern ((swapVar (combine l lvn) v)).
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
    apply Hyp2 in Hins.
    rewrite Hins. apply swapVarNonChangeRev.
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.

(** exactly same as [mtcons] case *)
- Case "mpcons". destruct lbv; cpx;
  apply lforallApp in Hyp1; repnd;
  [ allsimpl; specialize (Hyp0 sw []); simpl in Hyp0;
    constructor; cpx ;
     apply AlphaEqNilAbsP;
      apply Hyp; cpx|].

    constructor; cpx.
  allsimpl.
  pose proof  (GFreshDistRenWSpec vc l
            (pAllVars ph++pAllVars  (pSwap ph sw)++
              (swapLVar sw l)++ l ++ (pfreevars vc ph)++
                  ALDom sw ++ ALRange sw ++ l))
      as Hfr.
  exrepnd.
  apply alAbP with (lbnew:=lvn);
    try (unfold swapLVar ; autorewrite with fast;
      congruence; fail);
  [unfolds_base; simpl; dands | | ]; cpx;
  try (autorewrite with fast;
  repeat (disjoint_reasoning); fail);[].
  autorewrite with SwapAppR.
  assert (lvn = swapLVar sw lvn ) as XX by
    (symmetry; apply swapLVarNoChange;
        repeat (disjoint_reasoning)).

  remember (combine l lvn) as swt.
  rewrite XX.
  unfold swapLVar. rewrite <- map_combine.
  fold (swapSwap sw (combine l lvn)).
  rewrite <- (pcase swap_prop_e1Stronger).
  subst swt.
  apply pAlphaEqEquivariantRev with
    (sw0:=rev (combine l lvn)).
  autorewrite with SwapAppR.
  autorewrite with fast.
  apply Hyp.
  intros v Hin.
  unfolds_base.
  autorewrite with SwapAppL.
  assert (disjoint l lvn) as Xd by repeat(disjoint_reasoning).
  destruct (in_deq _ (DeqVtype vc) v l) as [Xin | Xnot].
  + dimp (@swapVar_in G vc l lvn v); cpx.
    remember (swapVar (combine l lvn) v) as vs.
    assert (leavesLVarUnchanged sw lvn)  as Xun by
    (apply leavesLVarUnchanged1;repeat (disjoint_reasoning)).
    apply Xun in hyp.
    repnud hyp. rw hyp. subst vs.
    autorewrite with SwapAppR.
    autorewrite with fast. refl.
  + assert (disjoint (pfreevars vc ph) lvn) as Hdiss by
      repeat (disjoint_reasoning).
    assert (LIn v (pfreevars vc ph -- l)) as Hins by
    (apply in_diff; dands; cpx).
    apply Hdiss in Hin.
    pattern ((swapVar (combine l lvn) v)).
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
    apply Hyp2 in Hins.
    rewrite Hins. apply swapVarNonChangeRev.
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
Qed.

Lemma freeVarsSuppAux:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, ! LIn v (tfreevars vc t)
      -> (finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  introv Hin.
  exists (tfreevars vc t).
  introv Hntal.
  destruct (in_deq _ (DeqVtype vc) a
    (tfreevars vc t)) as [ ? | Hneq]; cpx.
  provefalse.
  apply Hntal.
  apply (tcase alphaEqSwapNonFree).
  apply leavesLVarUnchanged1.
  allsimpl. repeat (disjoint_reasoning); cpx.
Qed.

Lemma freeVarsSuppAux2:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, LIn v (tfreevars vc t)
      -> ! (finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  introv Hin. introv Hc.
  repnud Hc.
  exrepnd.
  pose proof (vFreshVarSpec
      ([v]++la ++ (tfreevars vc t)) v) as XX.
  remember (vFreshVar ([v]++la ++ tfreevars vc t) v) as vn.
  clear Heqvn.
  rw in_app_iff in XX.
  rw in_app_iff in XX.
  apply XX. right. left.
  apply Hc0. introv Hal.
  apply (ALtcase alpha_preserves_free_vars) in Hal.
  rewrite Hal in Hin. clear Hal.
  rewrite <- (tcase freevarsEquivariant) in Hin.
  rw in_map_iff in Hin.
  exrepnd.
  pose proof (swapVarInOrEq2 [(v,vn)] a) as Hs.
  rewrite <- Hin0 in Hs.
  clear Hin0.
  dimp Hs; simpl; cpx; try (constructor; auto; cpx; fail);

  [|]; cpx;
  repeat (disjoint_reasoning);cpx.
  introv Hc. dorn Hc; cpx.
  subst. clear Hs.
  apply XX. cpx.
Qed.

Lemma freeVarsSupp:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, LIn v (tfreevars vc t)
      <=> !(finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  intros. split.
  - apply freeVarsSuppAux2.
  - introv Hin. destruct (in_deq _ (DeqVtype vc) v
    (tfreevars vc t)) as [ ? | Hneq]; cpx.
    provefalse. apply Hin.
    apply freeVarsSuppAux.
    trivial.
Qed.

(*

(forall (s : GSym G) (pt : Pattern s) (sw : Swapping vc),
  forall v, LIn v (pfreevars vc pt)
    <=> !(finite
           (fun b => !(pAlphaEq vc pt
                            (pSwap pt [(v,b)])))))
   *
(forall (l : MixtureParam) (m : Mixture l) (sw : Swapping vc)
  (lbv : list (list (vType vc))),
  forall v, LIn v (mfreevars vc m lbv)
    <=> !(finite
           (fun b => !(mAlphaEq vc m
                            (mSwap m [(v,b)])))))
.

*)

(*
*** Local Variables:
*** coq-load-path: ("../")
*** End:
*)


(* This software is governed by the CeCILL license under French law and
 * abiding by the rules of distribution of free software.  You can  use,
 * modify and/ or redistribute the software under the terms of the CeCILL
 * license as circulated by CEA, CNRS and INRIA at the following URL
 * "http://www.cecill.info".

 * As a counterpart to the access to the source code and  rights to copy,
 * modify and redistribute granted by the license, users are provided only
 * with a limited warranty  and the software's author,  the holder of the
 * economic rights,  and the successive licensors  have only  limited
 * liability.

 * In this respect, the user's attention is drawn to the risks associated
 * with loading,  using,  modifying and/or developing or reproducing the
 * software by the user in light of its specific status of free software,
 * that may mean  that it is complicated to manipulate,  and  that  also
 * therefore means  that it is reserved for developers  and  experienced
 * professionals having in-depth computer knowledge. Users are therefore
 * encouraged to load and test the software's suitability as regards their
 * requirements in conditions enabling the security of their systems and/or
 * data to be ensured and,  more generally, to use and operate it in the
 * same conditions as regards security.

 * The fact that you are presently reading this means that you have had
 * knowledge of the CeCILL license and that you accept its terms.
 *)

(* /!\ Proof related content on Jobs are located in proof/JobsAxioms.v *)

From Scheduler.Model Require Import PureFunctionModels.
From Scheduler.Model.Interface.Types Require Import TypesModel.
From Scheduler.Model.Interface.Types Require Import Jobs.
Require Import List.
Module Type JobsAxiomsMod.

  (* job_id -> job *)
  (*Parameter Jobs : nat -> Job.*)

  (* oracle from scheduling plan *)
  Parameter jobs_arriving_at :
    forall (t:nat), list nat.

  Axiom job_duration_gt_0 : forall n, duration (Jobs n) > 0.

  Axiom job_budget_enough : forall n, budget (Jobs n) >= duration (Jobs n).

  Axiom job_arrival_plus_duration_le_deadline :
    forall i,
      arrival (Jobs i) + duration (Jobs i) <= deadline (Jobs i).

  Axiom jobs_id_index : forall i,   jobid (Jobs i) = i.

  (* In should be defined for C lists ? TODO *)
 Axiom jobs_arriving_at_prop : forall  t i,
      In i (jobs_arriving_at t) <-> arrival (Jobs i) = t.

  (* nth should be defined for C lists ? TODO *)

  Axiom jobs_arriving_at_unique : forall i i' t t',
      i < length (jobs_arriving_at t) ->  i' < length (jobs_arriving_at t') ->
      nth i (jobs_arriving_at t) 0 = nth i' (jobs_arriving_at t') 0 ->
      (t = t' /\ i = i').

End JobsAxiomsMod.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require list.Append.
Require list.Distinct.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v: (map.Map.map Z a))).

(* Why3 assumption *)
Inductive tree :=
  | Empty : tree
  | Node : tree -> tree -> tree.
Axiom tree_WhyType : WhyType tree.
Existing Instance tree_WhyType.

(* Why3 assumption *)
Fixpoint size (t:tree) {struct t}: Z :=
  match t with
  | Empty => 0%Z
  | (Node l r) => ((1%Z + (size l))%Z + (size r))%Z
  end.

Axiom size_nonneg : forall (t:tree), (0%Z <= (size t))%Z.

Axiom size_left : forall (t:tree), (0%Z < (size t))%Z -> exists l:tree,
  exists r:tree, (t = (Node l r)) /\ ((size l) < (size t))%Z.

(* Why3 assumption *)
Definition all_trees (n:Z) (l:(list tree)): Prop := (list.Distinct.distinct
  l) /\ forall (t:tree), ((size t) = n) <-> (list.Mem.mem t l).

Axiom all_trees_0 : (all_trees 0%Z
  (Init.Datatypes.cons Empty Init.Datatypes.nil)).

Axiom tree_diff : forall (l1:tree) (l2:tree), (~ ((size l1) = (size l2))) ->
  forall (r1:tree) (r2:tree), ~ ((Node l1 r1) = (Node l2 r2)).

(* Why3 goal *)
Theorem WP_parameter_combine : forall (i1:Z) (l1:(list tree)) (i2:Z)
  (l2:(list tree)), ((0%Z <= i1)%Z /\ ((all_trees i1 l1) /\ ((0%Z <= i2)%Z /\
  (all_trees i2 l2)))) -> forall (l11:(list tree)), (list.Distinct.distinct
  l11) -> forall (x:tree) (x1:(list tree)),
  (l11 = (Init.Datatypes.cons x x1)) -> forall (l21:(list tree)),
  (list.Distinct.distinct l21) -> forall (x2:tree) (x3:(list tree)),
  (l21 = (Init.Datatypes.cons x2 x3)) -> ((list.Distinct.distinct x3) ->
  forall (o:(list tree)), ((list.Distinct.distinct o) /\ forall (t:tree),
  (list.Mem.mem t o) <-> exists r:tree, (t = (Node x r)) /\ (list.Mem.mem r
  x3)) -> forall (t:tree), (list.Mem.mem t (Init.Datatypes.cons (Node x
  x2) o)) -> exists r:tree, (t = (Node x r)) /\ (list.Mem.mem r l21)).
intros i1 l1 i2 l2 (h1,(h2,(h3,h4))) l11 h5 x x1 h6 l21 h7 x2 x3 h8
        h9 o (h10,h11) t h12.
subst.
unfold Mem.mem in h12; fold @Mem.mem in h12.
destruct h12.
exists x2; intuition.
red; intuition.
generalize (h11 t). intuition.
destruct H0 as (r,h); exists r; intuition.
red; intuition.
Qed.