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

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import Constant.
Require Import RealParams.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import CalRealSMSPool.

Require Import ObjLMM.

Section OBJ_ShareMEM.

  Context `{real_params: RealParams}.

  Function shared_mem_arg (pid1 pid2: Z) :=
    if zle_lt 0 pid1 num_proc then
      if zle_lt 0 pid2 num_proc then
        if zeq pid1 pid2 then false
        else true
      else false
    else false.

  Function shared_mem_arg' (pid1 pid2: Z) :=
    if zle_lt 0 pid1 num_proc then
      if zle_lt 0 pid2 num_proc then
        true
      else false
    else false.

  Function get_shared_mem_state_spec (pid1 pid2: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid i s vadr => Some (SharedMemInfo2Z i)
          | _ => None
        end
      | _ => None
    end.

  Function get_shared_mem_seen_spec (pid1 pid2: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid i s vadr => Some (BooltoZ s)
          | _ => None
        end
      | _ => None
    end.

  Function get_shared_mem_loc_spec (pid1 pid2: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid i s vadr => Some vadr
          | _ => None
        end
      | _ => None
    end.

  Function set_shared_mem_state_spec (pid1 pid2 n: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match (ZMap.get pid2 (ZMap.get pid1 (smspool adt)), Z2SharedMemInfo n) with
          | (SHRDValid _ s vadr, Some i) =>
            Some adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid i s vadr)
                                                       (ZMap.get pid1 (smspool adt)))
                                        (smspool adt)}
          | _ => None
        end
      | _ => None
    end.

  Function set_shared_mem_seen_spec (pid1 pid2 n: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match (ZMap.get pid2 (ZMap.get pid1 (smspool adt)), ZtoBool n) with
          | (SHRDValid i _ vadr, Some s) =>
            Some adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid i s vadr)
                                                       (ZMap.get pid1 (smspool adt)))
                                        (smspool adt)}
          | _ => None
        end
      | _ => None
    end.

  Function set_shared_mem_loc_spec (pid1 pid2 vadr: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid i s _  =>
            Some adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid i s vadr)
                                                       (ZMap.get pid1 (smspool adt)))
                                        (smspool adt)}
          | _ => None
        end
      | _ => None
    end.

  Function clear_shared_mem_spec (pid1 pid2: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg' pid1 pid2) with
      | (true, true, true, true, true) =>
        Some adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDDEAD true 0)
                                                   (ZMap.get pid1 (smspool adt)))
                                    (smspool adt)}
      | _ => None
    end.

  Function shared_mem_to_pending_spec (pid1 pid2 vadr: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid _ _ _ =>
            Some adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDPEND true vadr)
                                                       (ZMap.get pid1 (smspool adt)))
                                        (smspool adt)}
          | _ => None
        end
      | _ => None
    end.

  Function shared_mem_to_dead_spec (pid1 pid2 vadr: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match (ZMap.get pid2 (ZMap.get pid1 (smspool adt)), ZMap.get pid1 (ZMap.get pid2 (smspool adt))) with
          | (SHRDValid _ _ _, SHRDValid _ _ _) =>
            let smsp := (ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDDEAD true 0) (ZMap.get pid1 (smspool adt)))
                                  (smspool adt)) in
            let smsp' := (ZMap.set pid2 (ZMap.set pid1 (SHRDValid SHRDDEAD false 0) (ZMap.get pid2 smsp))
                                   smsp) in
            Some adt {smspool: smsp'}
          | _ => None
        end
      | _ => None
    end.

  Function shared_mem_to_ready_spec (pid1 pid2 vadr: Z) (adt: RData) : option (RData * Z) :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid _ _ _ =>
            match ZMap.get pid1 (ZMap.get pid2 (smspool adt)) with
              | SHRDValid _ _ vadr' =>
                if zle_lt 0 vadr' adr_max then
                  match ptResv2_spec pid1 vadr PT_PERM_PTU pid2 vadr' PT_PERM_PTU adt with
                    | Some (adt', rest) =>
                      if zeq rest MagicNumber then Some (adt', MagicNumber)
                      else
                        let smsp := (ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDREADY true 0) (ZMap.get pid1 (smspool adt')))
                                              (smspool adt')) in
                        let smsp' := (ZMap.set pid2 (ZMap.set pid1 (SHRDValid SHRDREADY false 0) (ZMap.get pid2 smsp))
                                               smsp) in
                        Some (adt' {smspool: smsp'}, rest)
                    | _ => None
                  end
                else None
              | _ => None
            end
          | _ => None
        end
      | _ => None
    end.

  Function get_shared_mem_status_seen_spec (pid1 pid2: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid1 (ZMap.get pid2 (smspool adt)) with
          | SHRDValid st _ _ =>
            if SharedMemInfo_dec st SHRDPEND then Some SHARED_MEM_PEND
            else
              match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
                | SHRDValid i' _ _ => Some (SharedMemInfo2Z i')
                | _ => None
              end
          | _ => None
        end
      | _ => None
    end.

  Function sharedmem_init_spec (mbi_adr:Z) (adt: RData): option RData :=
    match (init adt, pg adt, ikern adt, ihost adt, ipt adt) with
      | (false, false, true, true, true) =>
        Some adt {vmxinfo: real_vmxinfo} {pg: true} {LAT: real_LAT (LAT adt)} {nps: real_nps}
             {AC: real_AC} {init: true} {PT: 0} {ptpool: real_pt (ptpool adt)}
             {idpde: real_idpde (idpde adt)}
             {smspool: real_smspool (smspool adt)}
      | _ => None
    end.

  Function shared_mem_status_spec (pid1 pid2: Z) (adt: RData) : option (RData * Z) :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid i' true _ =>
            match ZMap.get pid1 (ZMap.get pid2 (smspool adt)) with
              | SHRDValid st _ _ =>
                if SharedMemInfo_dec st SHRDPEND then Some (adt, SHARED_MEM_PEND)
                else Some (adt, SharedMemInfo2Z i')
              | _ => None
            end
          | SHRDValid i' false vadr =>
            Some (adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid i' true vadr)
                                                        (ZMap.get pid1 (smspool adt)))
                                         (smspool adt)}, SharedMemInfo2Z i')
          | _ => None
        end
      | _ => None
    end.

  Function offer_shared_mem_spec (pid1 pid2 vadr: Z) (adt: RData) : option (RData * Z) :=
    match (ikern adt, ihost adt, pg adt, ipt adt, shared_mem_arg pid1 pid2) with
      | (true, true, true, true, true) =>
        match ZMap.get pid2 (ZMap.get pid1 (smspool adt)) with
          | SHRDValid st _ _ =>
            if SharedMemInfo_dec st SHRDPEND then Some (adt, SHARED_MEM_PEND)
            else
              match ZMap.get pid1 (ZMap.get pid2 (smspool adt)) with
                | SHRDValid st' _ vadr' =>
                  if zle_lt 0 vadr' adr_max then
                    if SharedMemInfo_dec st' SHRDPEND then
                      match ptResv2_spec pid1 vadr PT_PERM_PTU pid2 vadr' PT_PERM_PTU adt with
                        | Some (adt', re) =>
                          if zeq re MagicNumber
                          then
                            let smsp := (ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDDEAD true 0) (ZMap.get pid1 (smspool adt)))
                                                  (smspool adt')) in
                            let smsp' := (ZMap.set pid2 (ZMap.set pid1 (SHRDValid SHRDDEAD false 0) (ZMap.get pid2 smsp))
                                                   smsp) in
                            Some (adt' {smspool: smsp'}, SHARED_MEM_DEAD)
                          else
                            let smsp := (ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDREADY true 0) (ZMap.get pid1 (smspool adt')))
                                                  (smspool adt')) in
                            let smsp' := (ZMap.set pid2 (ZMap.set pid1 (SHRDValid SHRDREADY false 0) (ZMap.get pid2 smsp))
                                                   smsp) in
                            Some (adt' {smspool: smsp'}, SHARED_MEM_READY)
                        | _ => None
                      end
                    else
                      Some (adt {smspool: ZMap.set pid1 (ZMap.set pid2 (SHRDValid SHRDPEND true vadr)
                                                                  (ZMap.get pid1 (smspool adt)))
                                                   (smspool adt)}, SHARED_MEM_PEND)
                  else None
                | _ => None
              end
          | _ => None
        end
      | _ => None
    end.

End OBJ_ShareMEM.

Require Import liblayers.compat.CompatGenSem.
Require Import liblayers.compat.CompatLayers.
Require Import CommonTactic.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import Observation.

Section OBJ_SIM.

  Context `{Hobs: Observation}.

  Context `{data : CompatData(Obs:=Obs) RData}.
  Context `{data0 : CompatData(Obs:=Obs) RData}.

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

  Notation HDATAOps := (cdata (cdata_prf := data) RData).
  Notation LDATAOps := (cdata (cdata_prf := data0) RData).

  Context `{rel_prf: CompatRel _ (Obs:=Obs) (memory_model_ops:= memory_model_ops) _
                               (stencil_ops:= stencil_ops) HDATAOps LDATAOps}.

  Section Shared_MEM_GETTER.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_smspool}.

    Lemma get_shared_mem_state_exists:
      forall s habd labd i1 i2 z f,
      get_shared_mem_state_spec i1 i2 habd = Some z
      -> relate_AbData s f habd labd
      -> get_shared_mem_state_spec i1 i2 labd = Some z.
    Proof.
      unfold get_shared_mem_state_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto; intros.
      exploit relate_impl_smspool_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_shared_mem_seen_exists:
      forall s habd labd i1 i2 z f,
      get_shared_mem_seen_spec i1 i2 habd = Some z
      -> relate_AbData s f habd labd
      -> get_shared_mem_seen_spec i1 i2 labd = Some z.
    Proof.
      unfold get_shared_mem_seen_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto; intros.
      exploit relate_impl_smspool_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_shared_mem_state_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem get_shared_mem_state_spec)
            (id ↦ gensem get_shared_mem_state_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'.
      match_external_states_simpl.
      erewrite get_shared_mem_state_exists; eauto. reflexivity.
    Qed.

    Lemma get_shared_mem_seen_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem get_shared_mem_seen_spec)
            (id ↦ gensem get_shared_mem_seen_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'.
      match_external_states_simpl.
      erewrite get_shared_mem_seen_exists; eauto. reflexivity.
    Qed.

  End Shared_MEM_GETTER.

  Section Shared_MEM_SETTER.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_smspool}.

    Lemma set_shared_mem_seen_exists:
      forall s habd habd' labd i1 i2 z f,
        set_shared_mem_seen_spec i1 i2 z habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', set_shared_mem_seen_spec i1 i2 z labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold set_shared_mem_seen_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto; intros.
      exploit relate_impl_smspool_eq; eauto; intros.
      revert H. subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.
      apply relate_impl_smspool_update. assumption.
    Qed.

    Context {mt1: match_impl_smspool}.

    Lemma set_shared_mem_seen_match:
      forall s d d' m i1 i2 z f,
        set_shared_mem_seen_spec i1 i2 z d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold set_shared_mem_seen_spec; intros. subdestruct; inv H; trivial.
      eapply match_impl_smspool_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) set_shared_mem_seen_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) set_shared_mem_seen_spec}.

    Lemma set_shared_mem_seen_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem set_shared_mem_seen_spec)
            (id ↦ gensem set_shared_mem_seen_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'.
      exploit set_shared_mem_seen_exists; eauto 1; intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply set_shared_mem_seen_match; eauto.
    Qed.

  End Shared_MEM_SETTER.

  Section Shared_MEM_STATUS.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_smspool}.

    Lemma shared_mem_status_exists:
      forall s habd habd' labd i1 i2 z f,
        shared_mem_status_spec i1 i2 habd = Some (habd', z)
        -> relate_AbData s f habd labd
        -> exists labd', shared_mem_status_spec i1 i2 labd = Some (labd', z)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold shared_mem_status_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto; intros.
      exploit relate_impl_smspool_eq; eauto; intros.
      revert H. subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.
      apply relate_impl_smspool_update. assumption.
    Qed.

    Context {mt1: match_impl_smspool}.

    Lemma shared_mem_status_match:
      forall s d d' m i1 i2 z f,
        shared_mem_status_spec i1 i2 d = Some (d', z)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold shared_mem_status_spec; intros. subdestruct; inv H; trivial.
      eapply match_impl_smspool_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) shared_mem_status_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) shared_mem_status_spec}.

    Lemma shared_mem_status_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem shared_mem_status_spec)
            (id ↦ gensem shared_mem_status_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'.
      exploit shared_mem_status_exists; eauto 1. intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply shared_mem_status_match; eauto.
    Qed.

  End Shared_MEM_STATUS.

  Section PT_RESV2_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_LAT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_pperm}.
    Context {re6: relate_impl_ipt}.
    Context {re7: relate_impl_ptpool}.
    Context {re8: relate_impl_HP}.
    Context {re9: relate_impl_AC}.

    Lemma ptResv2_exist:
      forall s habd habd' labd i n v p n' v' p' f,
        ptResv2_spec n v p n' v' p' habd = Some (habd', i)
        -> relate_AbData s f habd labd
        -> exists labd', ptResv2_spec n v p n' v' p' labd = Some (labd', i)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold ptResv2_spec; intros.
      subdestruct. destruct p0.
      - exploit alloc_exist; eauto.
        intros (? & ? & ?).
        subrewrite'. inv H. refine_split'; trivial.
      - exploit alloc_exist; eauto.
        intros (? & ? & ?).
        exploit ptInsert0_exist; eauto.
        intros (? & ? & ?).
        subrewrite'. inv H. refine_split'; trivial.
      - exploit alloc_exist; eauto.
        intros (? & ? & ?).
        revert Hdestruct2; intros Hc.
        exploit ptInsert0_exist; eauto.
        intros (? & ? & ?).
        subrewrite'. clear Hc H3.
        exploit ptInsert0_exist; eauto.
    Qed.

    Context {mt1: match_impl_pperm}.
    Context {mt2: match_impl_LAT}.
    Context {mt3: match_impl_ptpool}.
    Context {mt4: match_impl_HP}.
    Context {mt5: match_impl_AC}.

    Lemma ptResv2_match:
      forall s d d' m i n v p n' v' p' f,
        ptResv2_spec n v p n' v' p' d = Some (d', i)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold ptResv2_spec; intros. subdestruct; inv H; trivial.
      - eapply ptInsert0_match; eauto.
        eapply alloc_match; eauto.
      - eapply ptInsert0_match; eauto.
        eapply ptInsert0_match; eauto.
        eapply alloc_match; eauto.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) ptResv2_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) ptResv2_spec}.

    Lemma ptResv2_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem ptResv2_spec)
            (id ↦ gensem ptResv2_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit ptResv2_exist; eauto 1; intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply ptResv2_match; eauto.
    Qed.

  End PT_RESV2_SIM.

  Section Offer_Shared_MEM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_LAT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_pperm}.
    Context {re6: relate_impl_ipt}.
    Context {re7: relate_impl_ptpool}.
    Context {re8: relate_impl_HP}.
    Context {re9: relate_impl_smspool}.
    Context {re10: relate_impl_AC}.

    Lemma offer_shared_mem_exists:
      forall s habd habd' labd i1 i2 v z f,
        offer_shared_mem_spec i1 i2 v habd = Some (habd', z)
        -> relate_AbData s f habd labd
        -> exists labd', offer_shared_mem_spec i1 i2 v labd = Some (labd', z)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold offer_shared_mem_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_smspool_eq; eauto; intros.
      exploit relate_impl_ipt_eq; eauto; intros.
      revert H. subrewrite.
      subdestruct; inv HQ; try(refine_split'; trivial; fail).
      - exploit ptResv2_exist; eauto.
        intros (? & ? & ?).
        exploit relate_impl_smspool_eq; eauto; intros.
        subrewrite'. refine_split'. trivial.
        apply relate_impl_smspool_update. assumption.
      - exploit ptResv2_exist; eauto.
        intros (? & ? & ?).
        exploit relate_impl_smspool_eq; eauto; intros.
        subrewrite'. refine_split'; trivial.
        apply relate_impl_smspool_update. assumption.
      - refine_split'; trivial.
        apply relate_impl_smspool_update. assumption.
    Qed.

    Context {mt1: match_impl_pperm}.
    Context {mt2: match_impl_LAT}.
    Context {mt3: match_impl_ptpool}.
    Context {mt4: match_impl_HP}.
    Context {mt5: match_impl_smspool}.
    Context {mt6: match_impl_AC}.

    Lemma offer_shared_mem_match:
      forall s d d' m i1 i2 v z f,
        offer_shared_mem_spec i1 i2 v d = Some (d', z)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold offer_shared_mem_spec; intros. subdestruct; inv H; trivial.
      - eapply match_impl_smspool_update.
        eapply ptResv2_match; eauto.
      - eapply match_impl_smspool_update.
        eapply ptResv2_match; eauto.
      - eapply match_impl_smspool_update.
        assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) offer_shared_mem_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) offer_shared_mem_spec}.

    Lemma offer_shared_mem_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem offer_shared_mem_spec)
            (id ↦ gensem offer_shared_mem_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'.
      exploit offer_shared_mem_exists; eauto 1. intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply offer_shared_mem_match; eauto.
    Qed.

  End Offer_Shared_MEM.

  (** ** The low level specifications exist*)
  Section SHAREDMEMINIT_SIM.

    Context `{real_params: RealParams}.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_LAT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_init}.
    Context {re6: relate_impl_PT}.
    Context {re7: relate_impl_ptpool}.
    Context {re8: relate_impl_idpde}.
    Context {re9: relate_impl_smspool}.
    Context {re10: relate_impl_vmxinfo}.
    Context {re11: relate_impl_AC}.

    Lemma sharedmem_init_exist:
      forall s habd habd' labd i f,
        sharedmem_init_spec i habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', sharedmem_init_spec i labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold sharedmem_init_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_LAT_eq; eauto.
      exploit relate_impl_ptpool_eq; eauto.
      exploit relate_impl_idpde_eq; eauto.
      exploit relate_impl_vmxinfo_eq; eauto.
      exploit relate_impl_smspool_eq; eauto. intros.
      revert H; subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_smspool_update.
      apply relate_impl_idpde_update.
      apply relate_impl_ptpool_update.
      apply relate_impl_PT_update.
      apply relate_impl_init_update.
      apply relate_impl_AC_update.
      apply relate_impl_nps_update.
      apply relate_impl_LAT_update.
      apply relate_impl_pg_update.
      apply relate_impl_vmxinfo_update.
      assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_ipt}.
    Context {mt3: match_impl_LAT}.
    Context {mt4: match_impl_nps}.
    Context {mt5: match_impl_init}.
    Context {mt6: match_impl_PT}.
    Context {mt7: match_impl_ptpool}.
    Context {mt8: match_impl_idpde}.
    Context {mt10: match_impl_smspool}.
    Context {mt11: match_impl_vmxinfo}.
    Context {mt12: match_impl_AC}.

    Lemma sharedmem_init_match:
      forall s d d' m i f,
        sharedmem_init_spec i d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold sharedmem_init_spec; intros. subdestruct. inv H.
      eapply match_impl_smspool_update.
      eapply match_impl_idpde_update.
      eapply match_impl_ptpool_update.
      eapply match_impl_PT_update.
      eapply match_impl_init_update.
      eapply match_impl_AC_update.
      eapply match_impl_nps_update.
      eapply match_impl_LAT_update.
      eapply match_impl_pg_update.
      eapply match_impl_vmxinfo_update.
      assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) sharedmem_init_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) sharedmem_init_spec}.

    Lemma sharedmem_init_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem sharedmem_init_spec)
            (id ↦ gensem sharedmem_init_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit sharedmem_init_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply sharedmem_init_match; eauto.
    Qed.

  End SHAREDMEMINIT_SIM.

  Section SHARED_MEM_TO_READY_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_LAT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_pperm}.
    Context {re6: relate_impl_ipt}.
    Context {re7: relate_impl_ptpool}.
    Context {re8: relate_impl_HP}.
    Context {re9: relate_impl_smspool}.
    Context {re10: relate_impl_AC}.

    Lemma shared_mem_to_ready_exist:
      forall s habd habd' labd pid1 pid2 vadr rest f,
        shared_mem_to_ready_spec pid1 pid2 vadr habd = Some (habd', rest)
        -> relate_AbData s f habd labd
        -> exists labd', shared_mem_to_ready_spec pid1 pid2 vadr labd = Some (labd', rest)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold shared_mem_to_ready_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_smspool_eq; eauto. intros.
      revert H. subrewrite.
      subdestruct;
        eapply ptResv2_exist in Hdestruct7; eauto;
        destruct Hdestruct7 as (labd' & -> & rel_labd');
	subrewrite';
        inv HQ; refine_split'; trivial.

      rewrite (relate_impl_smspool_eq _ _ _ _ rel_labd').
      apply relate_impl_smspool_update; assumption.
    Qed.

  End SHARED_MEM_TO_READY_SIM.

  Section SHARED_MEM_TO_PENDING_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_smspool}.

    Lemma shared_mem_to_pending_exist:
      forall s habd habd' labd pid1 pid2 vadr f,
        shared_mem_to_pending_spec pid1 pid2 vadr habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', shared_mem_to_pending_spec pid1 pid2 vadr labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold shared_mem_to_pending_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_smspool_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ; refine_split'; trivial.

      apply relate_impl_smspool_update; assumption.
    Qed.

  End SHARED_MEM_TO_PENDING_SIM.

  Section SHARED_MEM_TO_DEAD_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ipt}.
    Context {re3: relate_impl_smspool}.

    Lemma shared_mem_to_dead_exist:
      forall s habd habd' labd pid1 pid2 vadr f,
        shared_mem_to_dead_spec pid1 pid2 vadr habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', shared_mem_to_dead_spec pid1 pid2 vadr labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold shared_mem_to_dead_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_smspool_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ; refine_split'; trivial.

      apply relate_impl_smspool_update; assumption.
    Qed.

  End SHARED_MEM_TO_DEAD_SIM.

End OBJ_SIM.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef3.Specs.table_create3.
Require Import TableDataOpsRef3.LowSpecs.table_create3.
Require Import TableDataOpsRef3.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       table_create_spec
       table_create2_spec
    .

  Lemma table_create3_spec_exists:
    forall habd habd'  labd g_rd map_addr level g_rtt rtt_addr res
           (Hspec: table_create3_spec g_rd map_addr level g_rtt rtt_addr habd = Some (habd', res))
            (Hrel: relate_RData habd labd),
    exists labd', table_create3_spec0 g_rd map_addr level g_rtt rtt_addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    Local Opaque peq ptr_eq granule_fill_table.fill_table.
    intros. duplicate Hrel. destruct D. clear hrepl lrepl. destruct g_rtt, g_rd.
    unfold table_create3_spec, table_create3_spec0 in *.
    unfold Assertion in *. rm_bind Hspec; rm_bind'. simpl in *.
    unfold Assertion; rm_bind'; grewrite.
    repeat simpl_hyp Hspec; extract_prop_dec; simpl_query_oracle; rm_bind'; grewrite.
    - rewrite_oracle_rel rel_oracle C10.
      repeat (grewrite; try simpl_htarget; simpl).
      unfold create_table in *. simpl in *. autounfold in *. simpl in *. grewrite.
      repeat simpl_hyp Hspec; simpl; inversion Hspec;
        (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C10.
      repeat (grewrite; try simpl_htarget; simpl).
      unfold create_table in *. simpl in *. autounfold in *. simpl in *. grewrite.
      repeat simpl_hyp Hspec; simpl; inversion Hspec;
        (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C10.
      repeat (grewrite; try simpl_htarget; simpl).
      unfold create_table in *. simpl in *. autounfold in *. simpl in *. grewrite.
      repeat simpl_hyp Hspec; simpl; inversion Hspec;
        (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C10.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec; (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
    - rewrite_oracle_rel rel_oracle C10.
      repeat (grewrite; try simpl_htarget; simpl).
      inversion Hspec; (eexists; split; [reflexivity| constructor; destruct Hrel; simpl; try assumption; try reflexivity]).
  Qed.

End Refine.


Require Import Coq.Init.Tactics.

Definition id_True (x : True) : True := x.

Goal True.  Time do 1000 simple refine (id_True _). exact I. Time Optimize Proof. Time Qed.
(* Finished transaction in 0.034 secs (0.013u,0.02s) (successful)
   Evars: 2001 -> 0
   Finished transaction in 0. secs (0.u,0.s) (successful)
   Finished transaction in 0.002 secs (0.002u,0.s) (successful) *)
Goal True.  Time do 10000 simple refine (id_True _). exact I. Time Optimize Proof. Time Qed.
(* Finished transaction in 0.284 secs (0.221u,0.062s) (successful)
   Evars: 20001 -> 0
   Finished transaction in 0.005 secs (0.005u,0.s) (successful)
   Finished transaction in 0.015 secs (0.015u,0.s) (successful) *)
Goal True.  Time do 100000 simple refine (id_True _). exact I. Time Optimize Proof. Time Qed.
(* Finished transaction in 2.411 secs (2.324u,0.079s) (successful)
   Evars: 200001 -> 0
   Finished transaction in 0.056 secs (0.056u,0.s) (successful)
   Finished transaction in 0.221 secs (0.197u,0.023s) (successful) *)
Goal True.  Time do 1000000 simple refine (id_True _). exact I. Time Optimize Proof. Time Qed.
(* Finished transaction in 27.145 secs (26.175u,0.84s) (successful)
   Evars: 2000001 -> 0
   Finished transaction in 0.669 secs (0.607u,0.059s) (successful)
   Finished transaction in 5.337 secs (5.254u,0.066s) (successful) *)

(* sh -c 'ulimit -s unlimited ; coqc bench/refine_id.v'  35.18s user 1.30s system 99% cpu 36.639 total *)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

 *)

Require Export per_props_nat.
Require Export per_props_uni.

Lemma union_all_types {o} :
  forall lib (v : NVar),
    @type o lib (mkc_tunion mkc_tnat v (mkcv_tuni [v] (mkc_var v))).
Proof.
  introv.
  apply tequality_tunion; dands; [apply type_tnat|].
  introv en.
  apply equality_in_tnat in en.
  allrw @mkcv_tuni_substc; spcast.
  allrw @mkc_var_substc.
  apply tequality_mkc_tuni; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../close/")
*** End:
*)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

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

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export list.
Require Export per_props_function.
Require Export continuity_defs.
Require Export stronger_continuity_defs0.
Require Export cequiv_fresh.

Lemma hasvalue_like_apply {o} :
  forall lib (t u : @NTerm o),
    wf_term t
    -> wf_term u
    -> hasvalue_like lib (mk_apply t u)
    -> ({v : NVar
         & {b : NTerm
         & reduces_to lib t (mk_lam v b)
         # hasvalue_like lib (subst b v u)}}
        [+] {s : nseq
             & reduces_to lib t (mk_nseq s)
             # hasvalue_like lib (mk_eapply (mk_nseq s) u) }
        [+] {s : ntseq
             & reduces_to lib t (mk_ntseq s)
             # hasvalue_like lib (mk_eapply (sterm s) u) }
        [+] {n : NTerm
             & {e : NTerm
             & computes_to_exception lib n t e }}).
Proof.
  introv wt wu hv.
  unfold hasvalue_like, reduces_to in hv; exrepnd.
  revert dependent t.
  induction k; introv wt comp.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    allunfold @isvalue_like; allsimpl; tcsp.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp1; allsimpl.
    destruct t as [v1|f1|op bs]; allsimpl; ginv.

    { right; right; left.
      exists f1; dands; eauto 3 with slow.
      exists v; dands; auto.
      exists k; auto. }

    dopid op as [can|ncan|exc|abs] Case; allsimpl; ginv.

    + Case "Can".
      clear IHk.
      apply compute_step_apply_success in comp1; repndors; exrepnd; subst; fold_terms; ginv.

      { left.
        exists v0 b; dands; eauto 3 with slow.
        exists v; dands; auto.
        exists k; auto. }

      { right; left.
        exists f; dands; eauto 3 with slow.
        exists v; dands; auto.
        exists k; auto. }

    + remember (compute_step lib (oterm (NCan ncan) bs)) as cs.
      symmetry in Heqcs; destruct cs; allsimpl; ginv; fold_terms.
      applydup @compute_step_preserves_wf in Heqcs; auto.
      apply IHk in comp0; auto; repndors; exrepnd.

      * left.
        exists v0 b; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; left.
        exists s; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; right; left.
        exists s; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; right; right.
        exists n0 e.
        eapply reduces_to_if_split2; eauto.

    + apply reduces_in_atmost_k_steps_if_isvalue_like in comp0; eauto 3 with slow; subst.
      allapply @wf_exception_implies; exrepnd; subst; fold_terms.
      right; right; right.
      exists a t.
      eapply reduces_to_symm.

    + remember (compute_step lib (oterm (Abs abs) bs)) as cs.
      symmetry in Heqcs; destruct cs; allsimpl; ginv; fold_terms.
      applydup @compute_step_preserves_wf in Heqcs; auto.
      apply IHk in comp0; auto; repndors; exrepnd.

      * left.
        exists v0 b; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; left.
        exists s; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; right; left.
        exists s; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right; right; right.
        exists n0 e.
        eapply reduces_to_if_split2; eauto.
Qed.

(* !!MOVE *)
Lemma alpha_eq_mk_nseq {o} :
  forall s (t : @NTerm o),
    alpha_eq (mk_nseq s) t
    -> t = mk_nseq s.
Proof.
  introv aeq.
  inversion aeq; allsimpl; cpx.
Qed.

(* !!MOVE *)
Lemma hasvalue_like_apseq {o} :
  forall lib s (t : @NTerm o),
    wf_term t
    -> hasvalue_like lib (mk_eapply (mk_nseq s) t)
    -> {n : nat & computes_to_value lib t (mk_nat n) }
       [+] raises_exception lib t.
Proof.
  introv wt hv.
  unfold hasvalue_like, reduces_to in hv; exrepnd.
  revert dependent t.
  induction k; introv wt comp.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    allunfold @isvalue_like; allsimpl; tcsp.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp1; allsimpl.
    destruct t as [v1|f1|op bs]; allsimpl; ginv;[].
    dopid op as [can|ncan|exc|abs] Case; allsimpl; ginv.

    + Case "Can".
      clear IHk.
      apply compute_step_eapply_success in comp1; exrepnd.
      destruct l; try (complete (allsimpl; ginv)); ginv.
      repndors; exrepnd; subst.

      * apply compute_step_eapply2_success in comp1; repnd; GC.
        repndors; exrepnd; subst; ginv.
        allunfold @mk_nat; allunfold @mk_integer; ginv; fold_terms.
        left; exists n; fold_terms.
        apply computes_to_value_isvalue_refl; eauto 3 with slow.

      * allsimpl; tcsp.

      * allunfold @isnoncan_like; allsimpl; tcsp.

    + remember (compute_step lib (oterm (NCan ncan) bs)) as cs.
      symmetry in Heqcs; destruct cs; allsimpl; ginv; fold_terms.
      applydup @compute_step_preserves_wf in Heqcs; auto.
      dcwf xx; allsimpl; ginv; fold_terms.
      apply IHk in comp0; auto; repndors; exrepnd.

      * left.
        exists n0; dands; auto.
        allunfold @computes_to_value; repnd; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right.
        allunfold @raises_exception; exrepnd.
        exists a e.
        eapply reduces_to_if_split2; eauto.

    + dcwf h; allsimpl; ginv.
      apply reduces_in_atmost_k_steps_if_isvalue_like in comp0; eauto 3 with slow; subst.
      right.
      unfold raises_exception.
      allapply @wf_exception_implies; exrepnd; subst; fold_terms.
      exists a t.
      eapply reduces_to_symm.

    + dcwf h; allsimpl; ginv.
      remember (compute_step lib (oterm (Abs abs) bs)) as cs.
      symmetry in Heqcs; destruct cs; allsimpl; ginv; fold_terms.
      applydup @compute_step_preserves_wf in Heqcs; auto.
      apply IHk in comp0; auto; repndors; exrepnd.

      * left.
        exists n0; dands; auto.
        allunfold @computes_to_value; repnd; dands; auto.
        eapply reduces_to_if_split2; eauto.

      * right.
        allunfold @raises_exception; exrepnd.
        exists a e.
        eapply reduces_to_if_split2; eauto.
Qed.

Lemma approx_apply_fresh1 {o} :
  forall lib v (t : @NTerm o) u,
    isprog u
    -> isprog_vars [v] t
    -> approx
         lib
         (mk_fresh v (mk_apply t u))
         (mk_apply (mk_fresh v t) u).
Proof.
  introv ispu ispt.

  pose proof (change_bvars_alpha_wspec [v] u) as hu.
  destruct hu as [u' hu]; repnd.
  allrw disjoint_singleton_l.
  applydup @alpha_eq_preserves_isprog in hu as ispu'; auto.
  eapply approx_alpha_rw_l_aux;
    [apply implies_alpha_eq_mk_fresh;
      apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_refl|apply alpha_eq_sym;exact hu]
    |].
  eapply approx_alpha_rw_r_aux;
    [apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_refl|apply alpha_eq_sym;exact hu]
    |].
  clear dependent u.
  rename ispu' into ispu.
  rename u' into u.

  pose proof (change_bvars_alpha_wspec [v] t) as ht.
  destruct ht as [t' ht]; repnd.
  allrw disjoint_singleton_l.
  applydup (alphaeq_preserves_isprog_vars t t' [v]) in ht as ispt'; auto.
  eapply approx_alpha_rw_l_aux;
    [apply implies_alpha_eq_mk_fresh;
      apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_sym;exact ht|apply alpha_eq_refl]
    |].
  eapply approx_alpha_rw_r_aux;
    [apply implies_alpha_eq_mk_apply;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact ht
      |apply alpha_eq_refl]
    |].
  clear dependent t.
  rename ispt' into ispt.
  rename t' into t.

  apply approx_assume_hasvalue;
    try (apply isprogram_apply);
    try (apply isprogram_fresh);
    try (apply isprog_vars_apply_implies);
    eauto 3 with slow;[].

  introv hv.
  pose proof (fresh_atom o (get_utokens t ++ get_utokens u)) as fa.
  destruct fa as [a fa].
  allrw in_app_iff; allrw not_over_or; repnd.

  pose proof (hasvalue_like_fresh_implies lib a v (mk_apply t u)) as h.
  repeat (autodimp h hyp); simpl;
  try (apply wf_apply); eauto 3 with slow;
  allrw app_nil_r; allrw in_app_iff; tcsp.
  rw @cl_subst_subst_aux in h; eauto 2 with slow.
  unfold subst_aux in h; allsimpl; fold_terms.
  rw (lsubst_aux_trivial_cl_term2 u) in h; eauto 3 with slow.

  apply hasvalue_like_apply in h;
    try (apply lsubst_aux_preserves_wf_term2);
    eauto 3 with slow;[].

  repndors; exrepnd.

  - pose proof (reduces_to_fresh2 lib (mk_apply t u) (subst b v0 u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h0|].
      csunf; simpl; auto. }
    exrepnd.

    pose proof (reduces_to_fresh2 lib t (mk_lam v0 b) v a) as r.
    repeat (autodimp r hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms. }
    exrepnd.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_fresh;
          apply isprog_vars_apply_implies;
          eauto 3 with slow
        |exact q1]
      |].
    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           eauto 3 with slow
         |apply reduces_to_prinarg;exact r1]
      ].
    fold_terms.

    eapply approx_alpha_rw_l_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact q0
      |].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_apply;
        [apply implies_alpha_eq_mk_fresh;exact r0
        |apply alpha_eq_refl]
      |].

    pose proof (unfold_subst_utokens [(a,mk_var v)] (subst b v0 u)) as unfa.
    exrepnd.
    rw unfa0.

    pose proof (unfold_subst_utokens [(a,mk_var v)] (mk_lam v0 b)) as unfb.
    exrepnd.
    rw unfb0.
    apply alpha_eq_mk_lam in unfb1; exrepnd; subst.

    allsimpl; fold_terms.
    allrw app_nil_r.
    allrw disjoint_singleton_r; allsimpl.
    allrw in_app_iff; allrw not_over_or; repnd.

    rw <- @cl_lsubst_lsubst_aux in h0; eauto 2 with slow.
    applydup @reduces_to_preserves_isprog in h0;
      [|apply isprog_eq;
         apply isprogram_lsubst_if_isprog_sub;
         simpl; eauto 3 with slow;
         apply isprog_vars_eq in ispt;
         repnd; allrw subvars_eq;auto];[].

    apply isprog_lam_iff in h2.
    applydup @alpha_eq_bterm_preserves_isprog_vars in unfb1;auto.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           try (apply isprog_vars_lam);
           try (apply implies_isprog_vars_subst_utokens_aux);
           try (apply implies_isprog_vars_utok_sub_cons);
           eauto 3 with slow
         |apply reduces_to_prinarg;
           apply reduces_to_if_step;
           csunf; simpl;auto
         ]
      ];[]; fold_terms.

    unfold maybe_new_var; rw memvar_singleton; boolvar; tcsp;[].

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_lam);
           try (apply isprog_vars_fresh_implies);
           try (apply implies_isprog_vars_subst_utokens_aux);
           try (apply implies_isprog_vars_utok_sub_cons);
           eauto 3 with slow
         |apply reduces_to_if_step;csunf;simpl;auto]
      ];[].
    unfold apply_bterm; simpl.

    rw @cl_lsubst_lsubst_aux; eauto 3 with slow;[].
    simpl; rw memvar_singleton; boolvar; tcsp;[].
    fold_terms.

    assert (isprogram t') as ispt'.
    { apply alphaeq_preserves_program in unfa1; apply unfa1.
      apply isprogram_subst_if_bt; eauto 3 with slow. }
    apply isprogram_eq in ispt'.

    apply alpha_implies_approx3;
      try (apply isprogram_fresh);
      try (apply implies_isprog_vars_subst_utokens_aux);
      try (apply implies_isprog_vars_utok_sub_cons);
      eauto 3 with slow.
    apply implies_alpha_eq_mk_fresh.

    rw @lsubst_aux_subst_utokens_aux_disj;
      try (complete (unfold get_utokens_sub; simpl; allrw app_nil_r; allrw disjoint_singleton_r; auto));
      try (complete (unfold free_vars_utok_sub; simpl; apply disjoint_singleton_l; simpl; tcsp));
      [].

    pose proof (lsubst_alpha_congr4 [v0] [v'] b b' [(v0,u)] [(v',u)]) as aeq.
    allsimpl.
    repeat (autodimp aeq hyp); eauto 3 with slow;[].
    rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow;[].
    allrw @fold_subst.

    assert (alpha_eq t' (subst b' v' u)) as aeq' by eauto 3 with slow.

    apply alpha_eq_subst_utokens_aux; simpl; allrw disjoint_singleton_l;
    eauto 3 with slow.
    unfsubst; intro i.
    apply subset_bound_vars_lsubst_aux in i; allsimpl; allrw app_nil_r.
    allrw in_app_iff; sp.

  - pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_eapply (mk_nseq s) u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    unfold subst_utokens in q0; allsimpl; allrw app_nil_r.
    boolvar; allrw disjoint_singleton_r; tcsp;[].
    fold_terms.
    rw @trivial_subst_utokens_aux in q0; simpl; allrw disjoint_singleton_r; auto.

    pose proof (reduces_to_fresh2 lib t (mk_nseq s) v a) as r.
    repeat (autodimp r hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms. }
    exrepnd.

    unfold subst_utokens in r0; allsimpl; fold_terms.
    apply alpha_eq_sym in r0.
    apply alpha_eq_mk_nseq in r0; subst.

    assert (reduces_to lib (mk_fresh v t) (mk_nseq s)) as r.
    { eapply reduces_to_if_split1;[exact r1|].
      csunf; simpl; auto. }
    clear r1.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_fresh;
          apply isprog_vars_apply_implies;
          eauto 3 with slow
        |exact q1]
      |].
    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           eauto 3 with slow
         |apply reduces_to_prinarg;exact r]
      ].
    fold_terms.

    eapply approx_alpha_rw_l_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact q0
      |].

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_mk_nseq);
           eauto 3 with slow
         |apply reduces_to_if_step;
           csunf;simpl;reflexivity]
      ].

    eapply cequiv_le_approx.
    apply cequiv_shadowed_fresh.
    apply isprogram_eapply; eauto 3 with slow.

  - pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_eapply (sterm s) u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    unfold subst_utokens in q0; allsimpl; allrw app_nil_r.
    boolvar; allrw disjoint_singleton_r; tcsp;[].
    fold_terms.
    rw @trivial_subst_utokens_aux in q0; simpl; allrw disjoint_singleton_r; auto.

    pose proof (reduces_to_fresh2 lib t (mk_ntseq s) v a) as r.
    repeat (autodimp r hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms. }
    exrepnd.

    unfold subst_utokens in r0; allsimpl; fold_terms.
    apply alpha_eq_sym in r0.
    apply alpha_eq_sterm in r0; exrepnd; subst.

    assert (reduces_to lib (mk_fresh v t) (sterm g)) as r.
    { eapply reduces_to_if_split1;[exact r1|].
      csunf; simpl; auto. }
    clear r1.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_fresh;
          apply isprog_vars_apply_implies;
          eauto 3 with slow
        |exact q1]
      |].
    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           eauto 3 with slow
         |apply reduces_to_prinarg;exact r]
      ].
    fold_terms.

    eapply approx_alpha_rw_l_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact q0
      |].

    applydup @reduces_to_preserves_program in r;
      try (apply isprogram_fresh; auto);[].

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;eauto 3 with slow
         |apply reduces_to_if_step; csunf;simpl;reflexivity]
      ].

    eapply cequiv_le_approx.
    eapply cequiv_rw_r_eauto;
      [apply implies_alpha_eq_mk_eapply;
        [constructor;exact r2|apply alpha_eq_refl]
      |].
    apply cequiv_shadowed_fresh.
    apply isprogram_eapply; eauto 2 with slow.
    eapply alpha_prog_eauto;[|exact r0].
    apply alpha_eq_sym; auto.

  - pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_exception n e) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    pose proof (reduces_to_fresh2 lib t (mk_exception n e) v a) as r.
    repeat (autodimp r hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms. }
    exrepnd.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_fresh;
          apply isprog_vars_apply_implies;
          eauto 3 with slow
        |exact q1]
      |].
    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           eauto 3 with slow
         |apply reduces_to_prinarg;exact r1]
      ].
    fold_terms.

    eapply approx_alpha_rw_l_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact q0
      |].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_apply;
        [apply implies_alpha_eq_mk_fresh;exact r0
        |apply alpha_eq_refl]
      |].

    pose proof (unfold_subst_utokens [(a,mk_var v)] (mk_exception n e)) as unf.
    exrepnd.
    rw unf0.
    apply alpha_eq_exception in unf1; exrepnd; subst.

    allsimpl; fold_terms.
    allrw app_nil_r.
    allrw disjoint_singleton_r; allsimpl.
    allrw in_app_iff; allrw not_over_or; repnd.

    rw <- @cl_lsubst_lsubst_aux in h1; eauto 2 with slow.
    applydup @reduces_to_preserves_isprog in h1;
      [|apply isprog_eq;
         apply isprogram_lsubst_if_isprog_sub;
         simpl; eauto 3 with slow;
         apply isprog_vars_eq in ispt;
         repnd; allrw subvars_eq;auto];[].

    apply isprog_exception_iff in h0; repnd.
    applydup @alpha_eq_preserves_isprog in unf1; auto.
    applydup @alpha_eq_preserves_isprog in unf4; auto.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_apply;
           try (apply isprogram_fresh);
           try (apply isprog_vars_exception);dands;
           try (apply implies_isprog_vars_subst_utokens_aux);
           try (apply implies_isprog_vars_utok_sub_cons);
           eauto 3 with slow
         |eapply reduces_to_if_split2;
           [csunf;simpl;auto|];fold_terms;
           eapply reduces_to_if_step;
           csunf;simpl;auto
         ]
      ];[]; fold_terms.

    unfold maybe_new_var; simpl.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_fresh;
          try (apply isprog_vars_exception);dands;
          try (apply implies_isprog_vars_subst_utokens_aux);
          try (apply implies_isprog_vars_utok_sub_cons);
          eauto 3 with slow
        |apply reduces_to_if_step;csunf;simpl;auto]
      |];[];fold_terms.

    unfold maybe_new_var; simpl.
    apply approx_refl.
    apply isprogram_exception;
      apply isprogram_fresh;
      try (apply implies_isprog_vars_subst_utokens_aux);
      try (apply implies_isprog_vars_utok_sub_cons);
      eauto 3 with slow.
Qed.

Lemma approx_apply_fresh2 {o} :
  forall lib v (t : @NTerm o) u,
    isprog u
    -> isprog_vars [v] t
    -> approx
         lib
         (mk_apply (mk_fresh v t) u)
         (mk_fresh v (mk_apply t u)).
Proof.
  introv ispu ispt.

  pose proof (change_bvars_alpha_wspec [v] u) as hu.
  destruct hu as [u' hu]; repnd.
  allrw disjoint_singleton_l.
  applydup @alpha_eq_preserves_isprog in hu as ispu'; auto.
  eapply approx_alpha_rw_r_aux;
    [apply implies_alpha_eq_mk_fresh;
      apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_refl|apply alpha_eq_sym;exact hu]
    |].
  eapply approx_alpha_rw_l_aux;
    [apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_refl|apply alpha_eq_sym;exact hu]
    |].
  clear dependent u.
  rename ispu' into ispu.
  rename u' into u.

  pose proof (change_bvars_alpha_wspec [v] t) as ht.
  destruct ht as [t' ht]; repnd.
  allrw disjoint_singleton_l.
  applydup (alphaeq_preserves_isprog_vars t t' [v]) in ht as ispt'; auto.
  eapply approx_alpha_rw_r_aux;
    [apply implies_alpha_eq_mk_fresh;
      apply implies_alpha_eq_mk_apply;
      [apply alpha_eq_sym;exact ht|apply alpha_eq_refl]
    |].
  eapply approx_alpha_rw_l_aux;
    [apply implies_alpha_eq_mk_apply;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_sym;exact ht
      |apply alpha_eq_refl]
    |].
  clear dependent t.
  rename ispt' into ispt.
  rename t' into t.

  apply approx_assume_hasvalue;
    try (apply isprogram_apply);
    try (apply isprogram_fresh);
    try (apply isprog_vars_apply_implies);
    eauto 3 with slow;[].

  introv hv.
  pose proof (fresh_atom o (get_utokens t ++ get_utokens u)) as fa.
  destruct fa as [a fa].
  allrw in_app_iff; allrw not_over_or; repnd.

  apply hasvalue_like_apply in hv;
    try (apply wf_fresh);
    eauto 3 with slow.

  repndors; exrepnd.

  - eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_apply;
          try (apply isprogram_fresh);
          eauto 3 with slow
        |eapply reduces_to_trans;
          [apply reduces_to_prinarg;exact hv0|];
         apply reduces_to_if_step;csunf;simpl;auto]
      |].
    unfold apply_bterm; simpl; allrw @fold_subst.

    pose proof (fresh_reduces_to_implies lib v t (mk_lam v0 b) a) as h.
    repeat (autodimp h hyp); unfold isvalue_like; simpl; tcsp; eauto 3 with slow;[].
    exrepnd.

    pose proof (unfold_subst_utokens [(a,mk_var v)] u0) as unf.
    exrepnd.
    rw unf0 in h0.
    allsimpl; allrw disjoint_singleton_r.

    assert {v1 : NVar & {t1 : NTerm & t' = mk_lam v1 t1}} as e.
    { apply alpha_eq_mk_lam in h0; exrepnd.
      destruct t' as [v1|f1|op1 bs1]; ginv.
      dopid op1 as [can|ncan|exc|abs] Case; ginv.
      destruct can; ginv.
      - allsimpl.
        repeat (destruct bs1; allsimpl; ginv).
        destruct b0 as [l1 t1].
        repeat (destruct l1; allsimpl; ginv).
        fold_terms; ginv.
        eexists; eexists; eauto.
      - allsimpl.
        unfold subst_utok in h2; allsimpl; boolvar; ginv.
    }

    exrepnd; subst; allsimpl; fold_terms.
    allrw app_nil_r; allrw not_over_or; repnd.
    unfold maybe_new_var in h0; allrw memvar_singleton; boolvar; tcsp;[].
    apply alpha_eq_sym in unf1.
    apply alpha_eq_mk_lam in unf1; exrepnd; subst.
    apply alpha_eq_mk_lam in h0; exrepnd; subst; ginv.

    pose proof (reduces_to_fresh2 lib (mk_apply t u) (subst b' v' u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      allrw @fold_subst.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_fresh;
           apply isprog_vars_apply;
           dands;eauto 3 with slow
         |exact q1]
      ].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_fresh;
        exact q0
      |].

    pose proof (lsubst_alpha_congr4 [v'0] [v'] t1 b' [(v'0,u)] [(v',u)]) as aeq.
    allsimpl.
    repeat (autodimp aeq hyp); eauto 3 with slow;[].
    allrw @fold_subst.

    eapply approx_alpha_rw_r_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_subst_utokens_same;
        exact aeq
      |].

    pose proof (lsubst_alpha_congr4
                  [v0] [v'0] b
                  (mk_fresh v (subst_utokens_aux t1 [(a,mk_var v)]))
                  [(v0,u)] [(v'0,u)]) as aeq'.
    allsimpl.
    repeat (autodimp aeq' hyp); eauto 3 with slow;[].
    allrw @fold_subst.

    eapply approx_alpha_rw_l_aux;
      [apply alpha_eq_sym;exact aeq'|].

    applydup @reduces_to_preserves_isprog in h1 as ispb';
      try (apply subst_preserves_isprog);
      eauto 3 with slow;[].
    apply isprog_lam_iff in ispb'.
    apply alpha_eq_bterm_sym in unf1.
    applydup @alpha_eq_bterm_preserves_isprog_vars in unf1; auto;[].

    apply alpha_implies_approx3;
      try (apply isprogram_subst_if_bt);
      try (apply isprog_vars_iff_isprogram_bt);
      try (apply isprog_vars_fresh_implies);
      try (apply implies_isprog_vars_subst_utokens_aux);
      eauto 3 with slow;[].

    rw @cl_subst_subst_aux; eauto 3 with slow;[].
    unfold subst_aux; simpl; rw memvar_singleton; boolvar; tcsp;[].
    fold_terms.
    apply implies_alpha_eq_mk_fresh.

    rw @lsubst_aux_subst_utokens_aux_disj;
      unfold get_utokens_sub;
      allsimpl; allrw app_nil_r; allrw disjoint_singleton_r;
      allsimpl; tcsp;
      eauto 3 with slow;[].

    rw @cl_subst_subst_aux; eauto 3 with slow;[].
    unfold subst_aux.

    unfold subst_utokens; simpl; boolvar; allrw disjoint_singleton_r; eauto 3 with slow.
    destruct n; intro i.
    apply subset_bound_vars_lsubst_aux in i; allsimpl; allrw app_nil_r.
    allrw in_app_iff; sp.

  - eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_apply;
          try (apply isprogram_fresh);
          eauto 3 with slow
        |eapply reduces_to_trans;
          [apply reduces_to_prinarg;exact hv1|];
         apply reduces_to_if_step;csunf;simpl;auto]
      |].
    unfold apply_bterm; simpl; allrw @fold_subst.

    pose proof (fresh_reduces_to_implies lib v t (mk_nseq s) a) as h.
    repeat (autodimp h hyp); unfold isvalue_like; simpl; tcsp; eauto 3 with slow;[].
    exrepnd.

    pose proof (unfold_subst_utokens [(a,mk_var v)] u0) as unf.
    exrepnd.
    rw unf0 in h0.
    allsimpl; allrw disjoint_singleton_r.
    destruct t' as [x|f|op bs]; allsimpl; GC; try (complete (inversion h0));[].
    dopid op as [can|ncan|exc|abs] Case; try (complete (inversion h0));[].
    destruct can; allsimpl; try (complete (inversion h0));
    [|unfold subst_utok in h0; allsimpl; boolvar; allsimpl; inversion h0].
    apply alpha_eq_mk_nseq in h0.
    destruct bs; allsimpl; ginv; fold_terms; ginv; GC.
    apply alpha_eq_sym in unf1.
    apply alpha_eq_mk_nseq in unf1; subst.
    clear unf0.

    pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_eapply (mk_nseq s) u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      allrw @fold_subst.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_fresh;
           apply isprog_vars_apply;
           dands;eauto 3 with slow
         |exact q1]
      ].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_fresh;
        exact q0
      |].
    unfold subst_utokens; simpl; allrw app_nil_r.
    boolvar; allrw disjoint_singleton_r; tcsp;[].
    fold_terms.
    rw @trivial_subst_utokens_aux; simpl; allrw disjoint_singleton_r; auto.

    eapply cequiv_le_approx.
    apply cequiv_sym.
    apply cequiv_shadowed_fresh.
    apply isprogram_eapply; eauto 3 with slow.

  - eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_apply;
          try (apply isprogram_fresh);
          eauto 3 with slow
        |eapply reduces_to_trans;
          [apply reduces_to_prinarg;exact hv1|];
         apply reduces_to_if_step;csunf;simpl;auto]
      |].
    unfold apply_bterm; simpl; allrw @fold_subst.

    pose proof (fresh_reduces_to_implies lib v t (sterm s) a) as h.
    repeat (autodimp h hyp); unfold isvalue_like; simpl; tcsp; eauto 3 with slow;[].
    exrepnd.

    pose proof (unfold_subst_utokens [(a,mk_var v)] u0) as unf.
    exrepnd.
    rw unf0 in h0.
    allsimpl; allrw disjoint_singleton_r.

    destruct t' as [x|f|op bs]; allsimpl; GC; try (complete (inversion h0));
    [|destruct op; allsimpl; try (complete (inversion h0));[];
      destruct c; allsimpl; try (complete (inversion h0));[];
      allunfold @subst_utok; allsimpl; boolvar; allsimpl; try (complete (inversion h0))].

    inversion h0 as [|? ? aeq|]; subst; clear h0.
    apply alpha_eq_sym in unf1.
    apply alpha_eq_sterm in unf1; exrepnd; subst.
    unfold subst_utokens in unf0; allsimpl; ginv.
    clear unf2.

    pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_eapply (sterm f) u) v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      allrw @fold_subst.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_fresh;
           apply isprog_vars_apply;
           dands;eauto 3 with slow
         |exact q1]
      ].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_fresh;
        exact q0
      |].
    unfold subst_utokens; simpl; allrw app_nil_r.
    boolvar; allrw disjoint_singleton_r; tcsp;[].
    fold_terms.
    rw @trivial_subst_utokens_aux; simpl; allrw disjoint_singleton_r; auto.

    applydup @reduces_to_preserves_program in hv1;
      try (apply isprogram_fresh; auto);[].

    eapply cequiv_le_approx.
    apply cequiv_sym.
    eapply cequiv_rw_r_eauto;
      [apply implies_alpha_eq_mk_eapply;
        [apply alpha_eq_sym;constructor;apply aeq|apply alpha_eq_refl]
      |].
    apply cequiv_shadowed_fresh.
    apply isprogram_eapply; eauto 2 with slow.
    eapply alpha_prog_eauto;[|exact hv2]; auto.

  - eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [apply isprogram_apply;
          try (apply isprogram_fresh);
          eauto 3 with slow
        |eapply reduces_to_trans;
          [apply reduces_to_prinarg;exact hv1|];
         apply reduces_to_if_step;csunf;simpl;auto]
      |].
    fold_terms.

    pose proof (fresh_reduces_to_implies lib v t (mk_exception n e) a) as h.
    repeat (autodimp h hyp); unfold isvalue_like; simpl; tcsp; eauto 3 with slow;[].
    exrepnd.

    pose proof (unfold_subst_utokens [(a,mk_var v)] u0) as unf.
    exrepnd.
    rw unf0 in h0; clear unf0.
    allsimpl; allrw disjoint_singleton_r.

    assert {n1 : NTerm & {e1 : NTerm & t' = mk_exception n1 e1}} as xx.
    { apply alpha_eq_exception in h0; exrepnd.
      destruct t' as [v1|f1|op1 bs1]; ginv.
      dopid op1 as [can|ncan|exc|abs] Case; ginv.
      - destruct can; ginv.
        allsimpl.
        unfold subst_utok in h2; allsimpl; boolvar; ginv.
      - allsimpl.
        repeat (destruct bs1; allsimpl; ginv).
        destruct b as [l1 t1].
        destruct b0 as [l2 t2].
        repeat (destruct l1; allsimpl; ginv).
        repeat (destruct l2; allsimpl; ginv).
        fold_terms; ginv.
        eexists; eexists; eauto. }

    exrepnd; subst; allsimpl; fold_terms.
    allrw app_nil_r; allrw not_over_or; repnd.
    unfold maybe_new_var in h0; allrw memvar_singleton; boolvar; tcsp; GC;[].
    apply alpha_eq_sym in unf1.
    apply alpha_eq_exception in unf1; exrepnd; subst.
    apply alpha_eq_exception in h0; exrepnd; subst; ginv.

    pose proof (reduces_to_fresh2 lib (mk_apply t u) (mk_exception a' e') v a) as q.
    repeat (autodimp q hyp); simpl;
    try (apply wf_apply); eauto 3 with slow;
    allrw app_nil_r; allrw in_app_iff; tcsp.
    { unfsubst; simpl; fold_terms.
      rw (lsubst_aux_trivial_cl_term2 u); eauto 3 with slow.
      rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow.
      allrw @fold_subst.
      eapply reduces_to_if_split1;[apply reduces_to_prinarg; exact h1|].
      csunf; simpl; auto. }
    exrepnd.
    allrw not_over_or; repnd.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_fresh;
           apply isprog_vars_apply;
           dands;eauto 3 with slow
         |exact q1]
      ].

    eapply approx_alpha_rw_r_aux;
      [apply alpha_eq_sym;
        apply implies_alpha_eq_mk_fresh;
        exact q0
      |].

    eapply approx_alpha_rw_r_aux;
      [apply implies_alpha_eq_mk_fresh;
        apply alpha_eq_subst_utokens_same;
        apply implies_alphaeq_exception;
        [exact unf3|exact unf1]
      |].

    unfold subst_utokens; simpl; allrw app_nil_r; fold_terms.
    boolvar; allrw disjoint_singleton_r; allrw in_app_iff;
    allrw not_over_or; try (complete (destruct n0; sp));[].
    repnd; GC.

    applydup @reduces_to_preserves_isprog in h1 as ispb';
      try (apply subst_preserves_isprog);
      eauto 3 with slow;[].
    apply isprog_exception_iff in ispb'; repnd.
    apply alpha_eq_sym in unf1.
    apply alpha_eq_sym in unf3.
    applydup @alpha_eq_preserves_isprog in unf1;auto.
    applydup @alpha_eq_preserves_isprog in unf3;auto.

    eapply approx_trans;
      [|apply reduces_to_implies_approx1;
         [apply isprogram_fresh;
           apply isprog_vars_exception_implies;
           try (apply implies_isprog_vars_subst_utokens_aux);
           eauto 3 with slow
         |apply reduces_to_if_step;csunf;simpl;auto]
      ].
    fold_terms.
    unfold maybe_new_var; simpl.

    apply alpha_eq_sym in h0.
    apply alpha_eq_sym in h3.
    applydup @alpha_eq_preserves_isprog in h0;auto;
    try(apply isprog_fresh_implies;
        try (apply implies_isprog_vars_subst_utokens_aux);
        eauto 3 with slow).
    applydup @alpha_eq_preserves_isprog in h3;auto;
    try(apply isprog_fresh_implies;
        try (apply implies_isprog_vars_subst_utokens_aux);
        eauto 3 with slow).

    apply alpha_implies_approx3;
      try (apply isprogram_exception);
      eauto 3 with slow.

    apply implies_alphaeq_exception; eauto 3 with slow.
Qed.

Lemma cequiv_apply_fresh {o} :
  forall lib v (t : @NTerm o) a,
    isprog a
    -> isprog_vars [v] t
    -> cequiv
         lib
         (mk_fresh v (mk_apply t a))
         (mk_apply (mk_fresh v t) a).
Proof.
  introv ispa ispt.
  split.
  - apply approx_apply_fresh1; auto.
  - apply approx_apply_fresh2; auto.
Qed.

Lemma cequivc_apply_fresh {o} :
  forall lib v (t : @CVTerm o [v]) a,
    cequivc
      lib
      (mkc_fresh v (mkcv_apply [v] t (mk_cv [v] a)))
      (mkc_apply (mkc_fresh v t) a).
Proof.
  introv.
  destruct_cterms.
  unfold cequivc; simpl.
  apply cequiv_apply_fresh;auto.
Qed.

Lemma fresh_in_function {o} :
  forall lib v (t1 t2 : @CVTerm o [v]) A x B,
    type lib A
    -> (forall a1 a2,
          equality lib a1 a2 A
          -> tequality lib (substc a1 x B) (substc a2 x B))
    -> (forall a1 a2,
          equality lib a1 a2 A
          -> equality
               lib
               (mkc_fresh v (mkcv_apply [v] t1 (mk_cv [v] a1)))
               (mkc_fresh v (mkcv_apply [v] t2 (mk_cv [v] a2)))
               (substc a1 x B))
    -> equality lib (mkc_fresh v t1) (mkc_fresh v t2) (mkc_function A x B).
Proof.
  introv tA tB imp.
  apply equality_in_function.
  dands; auto.
  introv ea.
  applydup imp in ea.

  eapply equality_respects_cequivc_left in ea0;
    [|apply cequivc_apply_fresh].

  eapply equality_respects_cequivc_right in ea0;
    [|apply cequivc_apply_fresh].

  auto.
Qed.


From iris.proofmode Require Import tactics.
From iris.algebra.lib Require Import mono_list.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.

Class mono_listG (A : Type) Σ :=
  MonoListG { mono_list_inG : inG Σ (mono_listR (leibnizO A)) }.
Local Existing Instance mono_list_inG.

Definition mono_listΣ (A : Type) : gFunctors :=
  #[GFunctor (mono_listR (leibnizO A))].

Global Instance subG_mono_listΣ {A Σ} :
  subG (mono_listΣ A) Σ → (mono_listG A) Σ.
Proof. solve_inG. Qed.

Local Definition mono_list_auth_def `{!mono_listG A Σ}
    (γ : gname) (q : Qp) (l : list A) : iProp Σ :=
  own γ (●ML{#q} (l : listO (leibnizO A))).
Local Definition mono_list_auth_aux : seal (@mono_list_auth_def).
Proof. by eexists. Qed.
Definition mono_list_auth := mono_list_auth_aux.(unseal).
Local Definition mono_list_auth_unseal :
  @mono_list_auth = @mono_list_auth_def := mono_list_auth_aux.(seal_eq).
Global Arguments mono_list_auth {A Σ _} γ q l.

Local Definition mono_list_lb_def `{!mono_listG A Σ}
    (γ : gname) (l : list A) : iProp Σ :=
  own γ (◯ML (l : listO (leibnizO A))).
Local Definition mono_list_lb_aux : seal (@mono_list_lb_def).
Proof. by eexists. Qed.
Definition mono_list_lb := mono_list_lb_aux.(unseal).
Local Definition mono_list_lb_unseal :
  @mono_list_lb = @mono_list_lb_def := mono_list_lb_aux.(seal_eq).
Global Arguments mono_list_lb {A Σ _} γ l.

Definition mono_list_mapsto `{!mono_listG A Σ}
    (γ : gname) (i : nat) (a : A) : iProp Σ :=
  ∃ l : list A, ⌜ l !! i = Some a ⌝ ∗ mono_list_lb γ l.

Local Ltac unseal := rewrite
  /mono_list_mapsto ?mono_list_auth_unseal /mono_list_auth_def
  ?mono_list_lb_unseal /mono_list_lb_def.

Section mono_list_own.
  Context `{!mono_listG A Σ}.
  Implicit Types (l : list A) (i : nat) (a : A).

  Global Instance mono_list_auth_timeless γ q l : Timeless (mono_list_auth γ q l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_lb_timeless γ l : Timeless (mono_list_lb γ l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_lb_persistent γ l : Persistent (mono_list_lb γ l).
  Proof. unseal. apply _. Qed.
  Global Instance mono_list_mapsto_timeless γ i a :
    Timeless (mono_list_mapsto γ i a) := _.
  Global Instance mono_list_mapsto_persistent γ i a :
    Persistent (mono_list_mapsto γ i a) := _.

  Global Instance mono_list_auth_fractional γ l :
    Fractional (λ q, mono_list_auth γ q l).
  Proof. unseal. intros p q. by rewrite -own_op -mono_list_auth_dfrac_op. Qed.
  Global Instance mono_list_auth_as_fractional γ q l :
    AsFractional (mono_list_auth γ q l) (λ q, mono_list_auth γ q l) q.
  Proof. split; [auto|apply _]. Qed.

  Lemma mono_list_auth_agree γ q1 q2 l1 l2 :
    mono_list_auth γ q1 l1 -∗
    mono_list_auth γ q2 l2 -∗
    ⌜(q1 + q2 ≤ 1)%Qp ∧ l1 = l2⌝.
  Proof.
    unseal. iIntros "H1 H2".
    by iDestruct (own_valid_2 with "H1 H2") as %?%mono_list_auth_dfrac_op_valid_L.
  Qed.
  Lemma mono_list_auth_exclusive γ l1 l2 :
    mono_list_auth γ 1 l1 -∗ mono_list_auth γ 1 l2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct (mono_list_auth_agree with "H1 H2") as %[]; done.
  Qed.

  Lemma mono_list_auth_lb_valid γ q l1 l2 :
    mono_list_auth γ q l1 -∗
    mono_list_lb γ l2 -∗
    ⌜ (q ≤ 1)%Qp ∧ l2 `prefix_of` l1 ⌝.
  Proof.
    unseal. iIntros "Hauth Hlb".
    by iDestruct (own_valid_2 with "Hauth Hlb") as %?%mono_list_both_dfrac_valid_L.
  Qed.

  Lemma mono_list_lb_valid γ l1 l2 :
    mono_list_lb γ l1 -∗
    mono_list_lb γ l2 -∗
    ⌜ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1 ⌝.
  Proof.
    unseal. iIntros "H1 H2".
    by iDestruct (own_valid_2 with "H1 H2") as %?%mono_list_lb_op_valid_L.
  Qed.

  Lemma mono_list_mapsto_agree γ i a1 a2 :
    mono_list_mapsto γ i a1 -∗ mono_list_mapsto γ i a2 -∗ ⌜ a1 = a2 ⌝.
  Proof.
    iDestruct 1 as (l1 Hl1) "H1". iDestruct 1 as (l2 Hl2) "H2".
    iDestruct (mono_list_lb_valid with "H1 H2") as %Hpre.
    iPureIntro.
    destruct Hpre as [Hpre|Hpre]; eapply prefix_lookup in Hpre; eauto; congruence.
  Qed.

  Lemma mono_list_auth_mapsto_lookup γ q l i a :
    mono_list_auth γ q l -∗ mono_list_mapsto γ i a -∗ ⌜ l !! i = Some a ⌝.
  Proof.
    iIntros "Hauth". iDestruct 1 as (l1 Hl1) "Hl1".
    iDestruct (mono_list_auth_lb_valid with "Hauth Hl1") as %[_ Hpre].
    iPureIntro.
    eapply prefix_lookup in Hpre; eauto; congruence.
  Qed.

  Lemma mono_list_lb_get γ q l :
    mono_list_auth γ q l -∗ mono_list_lb γ l.
  Proof. intros. unseal. by apply own_mono, mono_list_included. Qed.
  Lemma mono_list_lb_le {γ l} l' :
    l' `prefix_of` l →
    mono_list_lb γ l -∗ mono_list_lb γ l'.
  Proof. unseal. intros. by apply own_mono, mono_list_lb_mono. Qed.

  Lemma mono_list_mapsto_get {γ l} i a :
    l !! i = Some a →
    mono_list_lb γ l -∗ mono_list_mapsto γ i a.
  Proof. iIntros (Hli) "Hl". iExists l. by iFrame. Qed.

  Lemma mono_list_alloc l :
    ⊢ |==> ∃ γ, mono_list_auth γ 1 l ∗ mono_list_lb γ l.
  Proof.
    unseal. setoid_rewrite <- own_op. by apply own_alloc, mono_list_both_valid_L.
  Qed.
  Lemma mono_list_auth_update {γ l} l' :
    l `prefix_of` l' →
    mono_list_auth γ 1 l ==∗ mono_list_auth γ 1 l' ∗ mono_list_lb γ l'.
  Proof.
    iIntros (?) "Hauth".
    iAssert (mono_list_auth γ 1 l') with "[> Hauth]" as "Hauth".
    { unseal. iApply (own_update with "Hauth"). by apply mono_list_update. }
    iModIntro. iSplit; [done|]. by iApply mono_list_lb_get.
  Qed.

  Lemma mono_list_auth_update_app {γ l} l' :
    mono_list_auth γ 1 l ==∗
    mono_list_auth γ 1 (l ++ l') ∗ mono_list_lb γ (l ++ l').
  Proof. by apply mono_list_auth_update, prefix_app_r. Qed.
End mono_list_own.


(** * AND instruction *)
Require Import x86proved.x86.instrrules.core.
Import x86.instrrules.core.instrruleconfig.

(** ** Generic AND *)
Lemma AND_rule sz (ds:DstSrc sz) (v1: VWORD sz) :
   |-- specAtDstSrc ds (fun D v2 =>
       basic (D v1 ** OSZCP?)
             (BOP _ OP_AND ds)
             (let v := andB v1 v2 in
              D v ** OSZCP false (msb v) (v == #0) false (lsb v))).
Proof. do_instrrule_triple. Qed.

(** We make this rule an instance of the typeclass, and leave
    unfolding things like [specAtDstSrc] to the getter tactic
    [get_instrrule_of]. *)
Global Instance: forall sz (ds : DstSrc sz), instrrule (BOP sz OP_AND ds) := @AND_rule.

(** ** AND r1, r2 *)
Corollary AND_RR_rule (r1 r2:Reg) v1 (v2:DWORD) :
  |-- basic (r1~=v1 ** r2 ~= v2 ** OSZCP?)
            (AND r1, r2)
            (let v := andB v1 v2 in r1~=v ** r2 ~= v2 **
             OSZCP false (msb v) (v == #0) false (lsb v)).
Proof. basic apply *. Qed.

(** ** AND r1, [r2 + offset] *)
Corollary AND_RM_rule (pbase:DWORD) (r1 r2:Reg) v1 (v2:DWORD) (offset:nat) :
  |-- basic (r1~=v1 ** OSZCP?)
            (AND r1, [r2 + offset])
            (let v:= andB v1 v2 in r1~=v ** OSZCP false (msb v) (v == #0) false (lsb v))
      @ (r2 ~= pbase ** pbase +# offset :-> v2).
Proof. autorewrite with push_at. basic apply *. Qed.

Corollary AND_RM_ruleNoFlags (pd:DWORD) (r1 r2:Reg) v1 (v2:DWORD) (offset:nat):
  |-- basic (r1~=v1) (AND r1, [r2 + offset]) (r1~=andB v1 v2)
             @ (r2 ~= pd ** pd +# offset :-> v2 ** OSZCP?).
Proof. autorewrite with push_at. basic apply *. Qed.

(** ** AND r, v *)
Lemma AND_RI_rule (r:Reg) v1 (v2:DWORD) :
  |-- basic (r~=v1 ** OSZCP?)
            (AND r, v2)
            (let v:= andB v1 v2 in r~=v ** OSZCP false (msb v) (v == #0) false (lsb v)).
Proof. basic apply *. Qed.