Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority prosa.classic.model.suspension.
Require Import prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.schedule.uni.jitter.schedule.
Require Import prosa.classic.analysis.uni.susp.dynamic.jitter.jitter_schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.

(* In this file we construct a jitter-aware task set that contains the
   jitter-aware schedule generated in the reduction. *)
Module JitterTaskSetGeneration.

  Import UniprocessorScheduleWithJitter Suspension Priority
         JitterScheduleConstruction.

  Section GeneratingTaskset.

    Context {Task: eqType}.

    (** Analysis Setup *)

    (* Let ts be the original, suspension-aware task set. *)
    Variable ts: seq Task.

    (* Assume that tasks have cost and suspension bound. *)
    Variable original_task_cost: Task -> time.
    Variable task_suspension_bound: Task -> time.

    (* Consider any FP policy that is reflexive, transitive and total, i.e., that
       indicates "higher-or-equal priority". *)
    Variable higher_eq_priority: FP_policy Task.

    (* Let tsk_i be any task to be analyzed... *)
    Variable tsk_i: Task.

    (* ...and recall the definition of higher-or-equal-priority tasks (other than tsk_i). *)
    Let other_hep_task tsk_other := higher_eq_priority tsk_other tsk_i && (tsk_other != tsk_i).

    (** Definition of Jitter-Aware Task Parameters *)

    (* We are going to define next a jitter-aware task set that models the jitter-aware
       schedule that we constructed in the reduction. *)

    (* First, using the task suspension bounds, we inflate the cost of the analyzed task
       in a suspension-oblivious manner. *)
    Definition inflated_task_cost (tsk: Task) :=
      if tsk == tsk_i then
        original_task_cost tsk + task_suspension_bound tsk
      else original_task_cost tsk.

    (* Next, assuming that higher-priority tasks have a valid response-time bound R,... *)
    Variable R: Task -> time.

    (* ...we define the task jitter as follows. *)
    Definition task_jitter (tsk: Task) :=
      if other_hep_task tsk then
        R tsk - original_task_cost tsk
      else 0.

  End GeneratingTaskset.

End JitterTaskSetGeneration.


From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructsLow.
From Fairness Require Import PCM.
Require Import String Lia Program.

Set Implicit Arguments.

Module NatMapRA.
  Section MAP.
    Variable A: Type.

    Definition car := option (NatMap.t A).

    Definition unit: car := Some (NatMap.empty A).

    Definition add (m0 m1: car): car :=
      match m0, m1 with
      | Some m0, Some m1 =>
          if (NatStructsLow.disjoint m0 m1) then Some (NatMapP.update m0 m1) else None
      | _, _ => None
      end.

    Definition wf (m: car): Prop :=
      match m with
      | None => False
      | _ => True
      end.

    Definition core (m: car): car := unit.

    Global Program Instance t: URA.t := {
        car := car;
        unit := unit;
        _add := add;
        _wf := wf;
        core := core;
      }
    .
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. apply disjoint_union_comm. apply disjoint_true_iff; auto. }
      { rewrite disjoint_comm in Heq. clarify. }
      { rewrite disjoint_comm in Heq. clarify. }
    Qed.
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. rewrite union_assoc. auto. }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        hexploit (proj2 (Disjoint_union t2 t t3)).
        { split.
          { apply NatMapP.Disjoint_sym. auto. }
          { apply NatMapP.Disjoint_sym. auto. }
        }
        i. apply NatMapP.Disjoint_sym in H.
        apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        apply disjoint_true_iff in Heq0. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq2.
        apply Disjoint_union in Heq2. des.
        hexploit (proj2 (Disjoint_union t t3 t2)).
        { split; auto. apply NatMapP.Disjoint_sym. auto. }
        i. apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq1.
        apply Disjoint_union in Heq1. des.
        apply NatMapP.Disjoint_sym in Heq3.
        apply disjoint_true_iff in Heq3. clarify.
      }
    Qed.
    Next Obligation.
      unseal "ra". unfold add, unit. des_ifs.
      hexploit Disjoint_empty. i.
      apply disjoint_true_iff in H. rewrite H in *. clarify.
    Qed.
    Next Obligation.
      unseal "ra". ss.
    Qed.
    Next Obligation.
      unseal "ra". unfold add in *. des_ifs.
    Qed.
    Next Obligation.
      unseal "ra". ss. des_ifs. f_equal.
      rewrite union_empty. auto.
    Qed.
    Next Obligation.
      exists unit. unseal "ra". unfold add, core, unit. des_ifs.
    Qed.

    Definition singleton (k: nat) (a: A): car := Some (NatMap.add k a (NatMap.empty A)).

    Lemma singleton_unique k0 a0 k1 a1
          (WF: URA.wf (singleton k0 a0 ⋅ singleton k1 a1))
      :
      k0 <> k1.
    Proof.
      ii. ur in WF. des_ifs.
      rewrite disjoint_true_iff in *.
      eapply Heq. split.
      { apply NatMapP.F.add_in_iff. eauto. }
      { apply NatMapP.F.add_in_iff. eauto. }
    Qed.

    Lemma extends_iff m0 m1
      :
      URA.extends (Some m0) (Some m1)
      <->
        (forall k a (FIND: NatMap.find k m0 = Some a), NatMap.find k m1 = Some a).
    Proof.
      split.
      { ii. rr in H. des. ur in H. des_ifs.
        apply NatMap.find_1. apply NatMapP.update_mapsto_iff.
        apply NatMap.find_2 in FIND. right. split; auto.
        apply disjoint_true_iff in Heq.
        ii. eapply Heq; eauto. split; eauto.
        apply NatMapP.F.in_find_iff. apply NatMap.find_1 in FIND. ii. clarify.
      }
      { i. exists (Some (NatMapP.diff m1 m0)).
        ur. des_ifs.
        { f_equal. apply nm_eq_is_equal.
          apply NatMapP.F.Equal_mapsto_iff. i.
          rewrite NatMapP.update_mapsto_iff.
          rewrite NatMapP.diff_mapsto_iff. split; i; des; auto.
          { apply NatMap.find_2. eapply H.
            apply NatMap.find_1. auto.
          }
          { destruct (NatMap.find k m0) eqn:FIND.
            { apply NatMap.find_1 in H0.
              hexploit H; eauto. i. clarify.
              right. split; auto.
              { apply NatMap.find_2; auto. }
              { ii. apply NatMapP.diff_in_iff in H0. des.
                eapply H2. apply NatMapP.F.in_find_iff. ii. clarify.
              }
            }
            { left. split; auto. ii.
              apply NatMapP.F.in_find_iff in H1. ss.
            }
          }
        }
        { apply disjoint_false_iff in Heq.
          exfalso. eapply Heq. ii. des.
          apply NatMapP.diff_in_iff in H1. des. ss.
        }
      }
    Qed.

    Lemma extends_singleton_iff m k a
      :
      URA.extends (singleton k a) (Some m)
      <->
        (NatMap.find k m = Some a).
    Proof.
      unfold singleton. rewrite extends_iff. split; i.
      { eapply H. apply nm_find_add_eq. }
      { rewrite NatMapP.F.add_o in FIND. des_ifs. }
    Qed.

    Lemma add_local_update m k a
          (NONE: NatMap.find k m = None)
      :
      Auth.local_update (Some m) unit (Some (NatMap.add k a m)) (singleton k a).
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. ur. des_ifs.
      { apply disjoint_true_iff in Heq.
        apply NatMapP.Disjoint_sym in Heq.
        apply Disjoint_add in Heq. des.
        f_equal. eapply eq_ext_is_eq. ii.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite ! NatMapP.update_mapsto_iff.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite NatMapP.F.empty_mapsto_iff.
        rewrite <- NatMapP.F.not_find_in_iff in NONE.
        rewrite NatMapP.update_in_iff in NONE.
        split; i; des; subst; auto.
        right. split; auto. ii. subst.
        eapply Heq. apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { exfalso. apply disjoint_false_iff in Heq. apply Heq.
        apply NatMapP.Disjoint_sym.
        eapply Disjoint_add. split.
        { apply NatMapP.F.not_find_in_iff in NONE.
          rewrite NatMapP.update_in_iff in NONE.
          ii. eapply NONE; eauto.
        }
        { apply Disjoint_empty. }
      }
    Qed.

    Lemma remove_local_update m k a
      :
      Auth.local_update (Some m) (singleton k a) (Some (NatMap.remove k m)) unit.
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. unfold unit. ur. f_equal.
      apply disjoint_true_iff in Heq.
      apply NatMapP.Disjoint_sym in Heq.
      apply Disjoint_add in Heq. des.
      eapply eq_ext_is_eq. ii.
      rewrite ! NatMapP.F.remove_mapsto_iff.
      rewrite ! NatMapP.update_mapsto_iff.
      rewrite ! NatMapP.F.add_mapsto_iff.
      rewrite NatMapP.F.empty_mapsto_iff.
      split; i; des; subst; auto.
      { splits; auto. ii. subst. eapply Heq.
        apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { split; auto. right; auto. }
    Qed.
  End MAP.
End NatMapRA.

From Fairness Require Import IProp IPM.
From iris.bi Require Import derived_laws. Import bi.

Section SUM.
  Context `{Σ: GRA.t}.

  Fixpoint list_prop_sum A (P: A -> iProp) (l: list A): iProp :=
    match l with
    | [] => True
    | hd::tl => P hd ** list_prop_sum P tl
    end.

  Lemma list_prop_sum_wand (A: Type) (P0 P1 : A → iProp)
        (l: list A)
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum (fun a => P0 a -* P1 a) l)
      -∗
      (list_prop_sum P1 l).
  Proof.
    induction l; ss.
    { iIntros. auto. }
    iIntros "[HD0 TL0] [HD1 TL1]". iSplitL "HD0 HD1".
    { iApply ("HD1" with "HD0"). }
    { iApply (IHl with "TL0 TL1"). }
  Qed.

  Lemma list_prop_sum_perm A P (l0 l1: list A)
        (PERM: Permutation l0 l1)
    :
    list_prop_sum P l0 ⊢ list_prop_sum P l1.
  Proof.
    induction PERM; ss.
    { iIntros "[H0 H1]". iFrame. iApply IHPERM. auto. }
    { iIntros "[H0 [H1 H2]]". iFrame. }
    { etrans; eauto. }
  Qed.

  Lemma list_prop_sum_nil A (P: A -> iProp)
    :
    ⊢ list_prop_sum P [].
  Proof.
    ss. auto.
  Qed.

  Lemma list_prop_sum_cons_fold A (P: A -> iProp) hd tl
    :
    (P hd ** list_prop_sum P tl)
      -∗
      (list_prop_sum P (hd::tl)).
  Proof.
    ss.
  Qed.

  Lemma list_prop_sum_cons_unfold A (P: A -> iProp) hd tl
    :
    (list_prop_sum P (hd::tl))
      -∗
      (P hd ** list_prop_sum P tl).
  Proof.
    ss.
  Qed.

  Lemma list_prop_sum_split A (P: A -> iProp) l0 l1
    :
    (list_prop_sum P (l0 ++ l1))
      -∗
      (list_prop_sum P l0 ** list_prop_sum P l1).
  Proof.
    induction l0; ss.
    { iIntros "SAT". iFrame. }
    { iIntros "[INTERP SAT]". iFrame. iApply IHl0; auto. }
  Qed.

  Lemma list_prop_sum_combine A (P: A -> iProp) l0 l1
    :
    (list_prop_sum P l0 ** list_prop_sum P l1)
      -∗
      (list_prop_sum P (l0 ++ l1)).
  Proof.
    induction l0; ss.
    { iIntros "[_ SAT]". auto. }
    { iIntros "[[INTERP SAT0] SAT1]". iFrame.
      iApply IHl0. iFrame.
    }
  Qed.

  Lemma list_prop_sum_add A (P: A -> iProp) l a
    :
    (P a ** list_prop_sum P l)
      -∗
      (list_prop_sum P (l++[a])).
  Proof.
    iIntros "[NEW SAT]". iApply list_prop_sum_combine. iFrame.
  Qed.

  Lemma list_prop_sum_impl A (P0 P1: A -> iProp) l
        (IMPL: forall a, P0 a ⊢ P1 a)
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum P1 l).
  Proof.
    induction l; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (IMPL with "HD"). }
    { iApply (IHl with "TL"). }
  Qed.

  Lemma list_prop_sum_sepconj A (P0 P1: A -> iProp) l
    :
    ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l))
      -∗
      list_prop_sum (fun a => (P0 a) ∗ (P1 a)) l.
  Proof.
    induction l; ss; auto.
    iIntros "[[HD1 TL1] [HD2 TL2]]". iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sepconj_sum A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a) ∗ (P1 a)) l)
      -∗
      ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l)).
  Proof.
    induction l; ss; auto.
    iIntros "[[HD1 HD2] TL]". iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_impl2 A (P0 P1 Q: A -> iProp) l
        (IMPL: forall a, (P0 a ∗ P1 a) -∗ Q a)
    :
    ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l))
      -∗
      list_prop_sum Q l.
  Proof.
    iIntros "SUMs". iApply list_prop_sum_impl. 2: iApply list_prop_sum_sepconj; iFrame.
    i. ss.
  Qed.

  Lemma list_prop_sum_persistent A (P: A -> iProp) l
        (PERSIST: forall a, Persistent (P a))
    :
    (list_prop_sum P l) -∗ (□ list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[#P Ps]".
    iApply intuitionistically_sep_2. iSplitL "P".
    - iModIntro. auto.
    - iApply IHl; iFrame.
  Qed.

  Global Program Instance Persistent_list_prop_sum
         A (P: A -> iProp) l (PERSIST: forall a, Persistent (P a)) : Persistent (list_prop_sum P l).
  Next Obligation.
  Proof.
    intros. iIntros "Ps". iPoseProof (list_prop_sum_persistent with "Ps") as "Ps". auto.
  Qed.

  Lemma list_map_forall2 A B (f: A -> B)
        l
    :
    List.Forall2 (fun a b => b = f a) l (List.map f l).
  Proof.
    induction l; ss. econs; eauto.
  Qed.

  Lemma list_prop_sum_forall2 A B
        (R: A -> B -> Prop)
        (P: A -> iProp) (Q: B -> iProp)
        la lb
        (FORALL: List.Forall2 R la lb)
        (IMPL: forall a b (INA: List.In a la) (INB: List.In b lb),
            R a b -> P a ⊢ Q b)
    :
    (list_prop_sum P la)
      -∗
      (list_prop_sum Q lb).
  Proof.
    revert IMPL. induction FORALL; i; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (IMPL with "HD"); auto. }
    { iApply (IHFORALL with "TL"). auto. }
  Qed.

  Lemma list_prop_sum_or_cases_l
        A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a ∨ P1 a)) l)
      -∗
      ((list_prop_sum P0 l) ∨ (∃ a, (⌜List.In a l⌝) ∗ (P1 a))).
  Proof.
    induction l.
    { iIntros "_". iLeft. ss. }
    ss. iIntros "[[C0|C1] SUM]".
    - iPoseProof (IHl with "SUM") as "[S0|S1]". iLeft; iFrame.
      iRight. iDestruct "S1" as "[% [%IN P1]]". iExists a0. iFrame. iPureIntro. auto.
    - iRight. iExists a. iFrame. iPureIntro. auto.
  Qed.

  Lemma list_prop_sum_or_cases_r
        A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a ∨ P1 a)) l)
      -∗
      ((list_prop_sum P1 l) ∨ (∃ a, (⌜List.In a l⌝) ∗ (P0 a))).
  Proof.
    iIntros "SUM". iApply list_prop_sum_or_cases_l. iApply list_prop_sum_impl. 2: iFrame.
    i. iIntros "[C0|C1]"; iFrame.
  Qed.

  Lemma list_prop_sum_pull_bupd
        Q
        A (P: A -> iProp) l
    :
    (list_prop_sum (fun a => #=( Q )=> P a) l)
      -∗
      #=( Q )=>(list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[PA SUM]". iSplitL "PA"; iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_pull_bupd_default
        A (P: A -> iProp) l
    :
    (list_prop_sum (fun a => #=> P a) l)
      -∗
      #=>(list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[PA SUM]". iSplitL "PA"; iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_in_split
        A (P: A -> iProp) l a
        (IN: In a l)
    :
    (list_prop_sum (fun a => P a) l)
      -∗ ((P a) ∗ ((P a) -∗ (list_prop_sum (fun a => P a) l))).
  Proof.
    iIntros "SUM". apply in_split in IN. des. rewrite cons_middle in IN. clarify.
    iPoseProof (list_prop_sum_split with "SUM") as "[SL SR]".
    iPoseProof (list_prop_sum_split with "SR") as "[SM SR]".
    iSplitL "SM". ss. iDestruct "SM" as "[PA _]". iFrame.
    iIntros "PA".
    iAssert (list_prop_sum (fun a0 => P a0) (a :: (l1 ++ l2)))%I with "[SL SR PA]" as "SP".
    { ss. iFrame. iApply list_prop_sum_combine. iFrame. }
    iApply (list_prop_sum_perm with "SP"). rewrite app_assoc. rewrite app_comm_cons.
    apply Permutation_app_tail. apply Permutation_cons_append.
  Qed.

  Lemma list_prop_sum_map
        A (P0: A -> iProp)
        B (P1: B -> iProp)
        l (f: A -> B)
        (MAP: forall a, (P0 a) -∗ (P1 (f a)))
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum P1 (List.map f l)).
  Proof.
    induction l; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (MAP with "HD"). }
    { iApply (IHl with "TL"). }
  Qed.

  Definition natmap_prop_sum A (f: NatMap.t A) (P: nat -> A -> iProp) :=
    list_prop_sum (fun '(k, v) => P k v) (NatMap.elements f).

  Lemma natmap_prop_sum_empty A P
    :
    ⊢ natmap_prop_sum (NatMap.empty A) P.
  Proof.
    unfold natmap_prop_sum. ss. auto.
  Qed.

  Lemma natmap_prop_remove_find A (f: NatMap.t A) P k v
        (FIND: NatMap.find k f = Some v)
    :
    (natmap_prop_sum f P)
      -∗
      (P k v ** natmap_prop_sum (NatMap.remove k f) P).
  Proof.
    hexploit NatMap.elements_1.
    { eapply NatMap.find_2; eauto. }
    i. eapply SetoidList.InA_split in H. des.
    destruct y. inv H. ss. subst.
    unfold natmap_prop_sum. rewrite H0.
    iIntros "H".
    iPoseProof (list_prop_sum_perm with "H") as "H".
    { instantiate (1:=(k0,a)::(l1 ++ l2)).
      symmetry. apply Permutation_middle.
    }
    iEval (ss) in "H". iDestruct "H" as "[H0 H1]". iFrame.
    iApply (list_prop_sum_perm with "H1").
    symmetry. eapply Permutation_remove.
    rewrite H0. symmetry. apply Permutation_middle.
  Qed.

  Lemma natmap_prop_remove A (f: NatMap.t A) P k
    :
    (natmap_prop_sum f P)
      -∗
      (natmap_prop_sum (NatMap.remove k f) P).
  Proof.
    destruct (NatMap.find k f) eqn:EQ.
    { iIntros "H". iPoseProof (natmap_prop_remove_find with "H") as "[_ H]"; eauto. }
    replace (NatMap.remove k f) with f; auto.
    eapply eq_ext_is_eq. ii.
    rewrite NatMapP.F.remove_mapsto_iff. split.
    { i. split; auto. ii.
      eapply NatMap.find_1 in H. clarify.
    }
    { i. des. auto. }
  Qed.

  Lemma natmap_prop_sum_add A P k v (f: NatMap.t A)
    :
    (natmap_prop_sum f P)
      -∗
      (P k v)
      -∗
      (natmap_prop_sum (NatMap.add k v f) P).
  Proof.
    destruct (NatMapP.F.In_dec f k).
    { rewrite <- nm_add_rm_eq. iIntros "H0 H1".
      unfold natmap_prop_sum.
      iApply list_prop_sum_perm.
      { symmetry. eapply Permutation_add; eauto. apply NatMap.remove_1; auto. }
      iPoseProof (natmap_prop_remove with "H0") as "H0".
      ss. iFrame.
    }
    { unfold natmap_prop_sum. iIntros "H0 H1".
      iApply list_prop_sum_perm.
      { symmetry. eapply Permutation_add; eauto. }
      ss. iFrame.
    }
  Qed.

  Lemma natmap_prop_sum_persistent A (P: nat -> A -> iProp) m
        (PERSIST: forall n a, Persistent (P n a))
    :
    (natmap_prop_sum m P) -∗ (□ natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. apply list_prop_sum_persistent. i. des_ifs.
  Qed.

  Global Program Instance Persistent_natmap_prop_sum
         A (P: nat -> A -> iProp) m
         (PERSIST: forall n a, Persistent (P n a)) : Persistent (natmap_prop_sum m P).
  Next Obligation.
  Proof.
    intros. iIntros "Ps". iPoseProof (natmap_prop_sum_persistent with "Ps") as "Ps". auto.
  Qed.

  Lemma natmap_prop_sum_in A P k a (m: NatMap.t A)
        (FIND: NatMap.find k m = Some a)
    :
    (natmap_prop_sum m P)
      -∗
      (P k a).
  Proof.
    iIntros "MAP". iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eauto. }
    eauto.
  Qed.

  Lemma natmap_prop_sum_impl A P0 P1 (m: NatMap.t A)
        (IMPL: forall k a (IN: NatMap.find k m = Some a), P0 k a ⊢ P1 k a)
    :
    (natmap_prop_sum m P0)
      -∗
      (natmap_prop_sum m P1).
  Proof.
    revert IMPL. pattern m. eapply nm_ind.
    { iIntros. iApply natmap_prop_sum_empty. }
    i. iIntros "MAP".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    iPoseProof (IMPL with "H0") as "H0".
    { rewrite nm_find_add_eq. auto. }
    iApply (natmap_prop_sum_add with "[H1] H0").
    iApply IH.
    { i. eapply IMPL. rewrite NatMapP.F.add_o; eauto. des_ifs. }
    { rewrite nm_find_none_rm_add_eq; auto. }
  Qed.

  Lemma natmap_prop_sum_wand (A: Type) P0 P1 (m: NatMap.t A)
    :
    (natmap_prop_sum m P0)
      -∗
      (natmap_prop_sum m (fun k v => P0 k v -* P1 k v))
      -∗
      (natmap_prop_sum m P1).
  Proof.
    pattern m. eapply nm_ind.
    { iIntros. iApply natmap_prop_sum_empty. }
    i. iIntros "MAP IMPL".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    iPoseProof (natmap_prop_remove_find with "IMPL") as "[G0 G1]".
    { eapply nm_find_add_eq. }
    iApply (natmap_prop_sum_add with "[H1 G1] [H0 G0]").
    { rewrite nm_find_none_rm_add_eq; auto. iApply (IH with "H1 G1"). }
    { iApply ("G0" with "H0"). }
  Qed.

  Lemma natmap_prop_sum_impl_strong (A: Type) P0 P1 Q (m: NatMap.t A)
        (IMPL: forall k v, P0 k v ** Q ⊢ P1 k v ** Q)
    :
    (natmap_prop_sum m P0 ** Q)
      -∗
      (natmap_prop_sum m P1 ** Q).
  Proof.
    pattern m. eapply nm_ind.
    { iIntros "[SUM H]". iFrame. }
    i. iIntros "[MAP H]".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    rewrite nm_find_none_rm_add_eq; [|auto].
    iPoseProof (IH with "[H1 H]") as "[H1 H]".
    { iFrame. }
    iPoseProof (IMPL with "[H0 H]") as "[H0 H]".
    { iFrame. }
    iFrame. iApply (natmap_prop_sum_add with "H1 H0").
  Qed.

  Lemma natmap_prop_sum_or_cases_l
        A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a ∨ P1 k a)))
      -∗
      ((natmap_prop_sum m P0) ∨ (∃ k a, (⌜NatMap.find k m = Some a⌝) ∗ (P1 k a))).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_or_cases_l with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs. iIntros "[P0|P1]".
      - iLeft. instantiate (1:=fun '(k, a) => P0 k a). ss.
      - iRight. instantiate (1:=fun '(k, a) => P1 k a). ss.
    }
    iDestruct "SUM" as "[SUM|ELSE]".
    { iFrame. }
    iRight. iDestruct "ELSE" as "[% [IN P]]". des_ifs. do 2 iExists _. iFrame.
    iPure "IN" as IN. iPureIntro. remember (NatMap.elements m) as ml.
    assert (ND: SetoidList.NoDupA (NatMap.eq_key (elt:=_)) ml).
    { subst. apply NatMap.elements_3w. }
    rewrite NatMapP.F.elements_o. rewrite <- Heqml. clear m Heqml.
    eapply SetoidList.In_InA in IN.
    { eapply SetoidList.findA_NoDupA; eauto. }
    econs; ss.
    - econs; des; clarify.
    - econs; des; clarify; auto. rewrite <- H0. auto. rewrite <- H1; auto.
  Qed.

  Lemma natmap_prop_sum_or_cases_r
        A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a ∨ P1 k a)))
      -∗
      ((natmap_prop_sum m P1) ∨ (∃ k a, (⌜NatMap.find k m = Some a⌝) ∗ (P0 k a))).
  Proof.
    iIntros "SUM". iApply natmap_prop_sum_or_cases_l. iApply natmap_prop_sum_impl. 2: iFrame.
    i. iIntros "[C0|C1]"; iFrame.
  Qed.

  Lemma natmap_prop_sum_pull_bupd
        Q
        A (P: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => #=( Q )=> P k a))
      -∗
      #=( Q )=>(natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_pull_bupd with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs.
      instantiate (1:=fun '(k, a) => P k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_pull_bupd_default
        A (P: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => #=> P k a))
      -∗
      #=>(natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_pull_bupd_default with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs.
      instantiate (1:=fun '(k, a) => P k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_sepconj A (P0 P1: nat -> A -> iProp) m
    :
    ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1))
      -∗
      natmap_prop_sum m (fun k a => (P0 k a) ∗ (P1 k a)).
  Proof.
    unfold natmap_prop_sum . iIntros "SUM".
    iPoseProof (list_prop_sum_sepconj with "SUM") as "SUM". iApply list_prop_sum_impl. 2: iFrame.
    i. ss. des_ifs; ss.
  Qed.

  Lemma natmap_prop_sepconj_sum A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a) ∗ (P1 k a)))
      -∗
      ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1)).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sepconj_sum with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. destruct a.
      instantiate (1:=fun '(k, a) => P1 k a). instantiate (1:=fun '(k, a) => P0 k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_impl2 A (P0 P1 Q: nat -> A -> iProp) m
        (IMPL: forall k a, (P0 k a ∗ P1 k a) -∗ Q k a)
    :
    ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1))
      -∗
      natmap_prop_sum m Q.
  Proof.
    iIntros "SUMs". iApply natmap_prop_sum_impl. 2: iApply natmap_prop_sum_sepconj; iFrame.
    i. ss.
  Qed.

  Lemma natmap_prop_sum_find_remove
        A (P: nat -> A -> iProp) m k a
        (FIND: NatMap.find k m = Some a)
    :
    (natmap_prop_sum m (fun k a => P k a))
      -∗ ((P k a) ∗ ((P k a) -∗ (natmap_prop_sum m (fun k a => P k a)))).
  Proof.
    unfold natmap_prop_sum. set (P' := fun x => P (fst x) (snd x)). remember (k, a) as x.
    cut
  (list_prop_sum (λ x, P' x) (NatMap.elements (elt:=A) m) -∗
                 P' x ∗ (P' x -∗ list_prop_sum (λ x, P' x) (NatMap.elements (elt:=A) m))).
    { subst. subst P'. ss. i. replace (λ '(k0, v), P k0 v) with (λ x : nat * A, P x.1 x.2). auto.
      extensionality x. destruct x. ss.
    }
    iIntros "SUMs". iApply (list_prop_sum_in_split with "SUMs").
    subst. apply InA_In'. rewrite NatMapP.F.elements_o in FIND.
    apply SetoidList.findA_NoDupA in FIND; eauto.
    apply NatMap.elements_3w.
  Qed.

End SUM.

Section UPDNATMAP.
  Variable A: Type.
  Context `{NATMAPRA: @GRA.inG (Auth.t (NatMapRA.t A)) Σ}.

  Lemma NatMapRA_find_some m k a
    :
    (OwnM (Auth.black (Some m: NatMapRA.t A)))
      -∗
      (OwnM (Auth.white (NatMapRA.singleton k a: NatMapRA.t A)))
      -∗
      (⌜NatMap.find k m = Some a⌝).
  Proof.
    iIntros "B W". iCombine "B W" as "BW". iOwnWf "BW".
    eapply Auth.auth_included in H. eapply NatMapRA.extends_singleton_iff in H. auto.
  Qed.

  Lemma NatMapRA_singleton_unique k0 k1 a0 a1
    :
    (OwnM (Auth.white (NatMapRA.singleton k0 a0: NatMapRA.t A)))
      -∗
      (OwnM (Auth.white (NatMapRA.singleton k1 a1: NatMapRA.t A)))
      -∗
      (⌜k0 <> k1⌝).
  Proof.
    iIntros "W0 W1". iCombine "W0 W1" as "W". iOwnWf "W".
    ur in H. eapply NatMapRA.singleton_unique in H. auto.
  Qed.

  Lemma NatMapRA_remove m k a
    :
    (OwnM (Auth.black (Some m: NatMapRA.t A)))
      -∗
      (OwnM (Auth.white (NatMapRA.singleton k a: NatMapRA.t A)))
      -∗
      #=>(OwnM (Auth.black (Some (NatMap.remove k m): NatMapRA.t A))).
  Proof.
    iIntros "B W". iCombine "B W" as "BW". iApply OwnM_Upd. 2: iFrame.
    eapply Auth.auth_dealloc. eapply NatMapRA.remove_local_update.
  Qed.

  Lemma NatMapRA_add m k a
        (NONE: NatMap.find k m = None)
    :
    (OwnM (Auth.black (Some m: NatMapRA.t A)))
      -∗
      #=>((OwnM (Auth.black (Some (NatMap.add k a m): NatMapRA.t A)
                            ⋅ Auth.white (NatMapRA.singleton k a: NatMapRA.t A)))
         ).
  Proof.
    iIntros "B". iApply OwnM_Upd. 2: iFrame.
    eapply Auth.auth_alloc. eapply NatMapRA.add_local_update. auto.
  Qed.

End UPDNATMAP.


Require Import Coq.Strings.String Coq.omega.Omega Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Computation ADT ADTRefinement ADTNotation BuildADTRefinements
        KVEnsembles CacheSpec.

Section AddDuplicateKeyStrategies.

  Context {Key : Type}.
  Context {Value : Type}.

  (* Two strategies : replace the key*)

  Lemma refine_ReplaceUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret (EnsembleReplaceKey kv r))
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertReplaceKey.
    - reflexivity.
  Qed.

  Lemma refine_IgnoreUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret r)
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertRefl.
    - reflexivity.
  Qed.

End AddDuplicateKeyStrategies.

Section UpdateMissingKeyStrategies.

  Context {Key : Type}.
  Context {Value : Type}.

  (* Best Practice : Just update the key, if its there. *)

  Lemma refine_IgnoreUnusedKeyUpdate
  : forall (kv : Key * (Value -> Value))
           (r : Ensemble (Key * Value)),
      refine { r' |
                (Same_set _ (fst r') (EnsembleUpdateKey (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- ret (EnsembleUpdateKey (fst kv) r (snd kv));
              ret (r', b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    apply refine_under_bind.
    destruct a; simpl; intros.
    - refine pick val _; [reflexivity | intuition ].
    - inversion_by computes_to_inv; simpl in H.
      f_equiv.
      apply refine_pick_val.
      unfold Same_set, Included; intuition; unfold In in *.
  Qed.

End UpdateMissingKeyStrategies.

Section CacheEvictionStrategies.

  Context {Key : Type}.
  Context {Value : Type}.

  (* First refinement- determine if there is a key to be replaced. *)

  Lemma refine_SubEnsembleInsert
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r r')}
             (k_opt <- {k_opt | forall k',
                                    k_opt = Some k' ->
                                    exists v', r (k', v')};
              Ifopt k_opt as k' Then
                                  ret (EnsembleInsert kv
                                                      (EnsembleRemoveKey k' r))
                                  Else
                                  ret (EnsembleInsert kv r)).
  Proof.
    intros; rewrite refine_Pick_If_Then_Opt with
            (P := fun k' => exists v', r (k', v')).
    f_equiv; unfold pointwise_relation; intros; simpl.
    destruct a;
      [ higher_order_1_reflexivity
      | reflexivity ].
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemoveKey in *; simpl; intros; intuition.
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemoveKey in *; simpl; intros; intuition.
  Qed.

  (* Never tab a key for replacement *)
  Lemma refine_pick_KeyToBeReplaced_never
  : forall (r : Ensemble (Key * Value)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', r (k', v')}
             (ret None).
  Proof.
    intros; rewrite refine_pick_val;
    [ reflexivity
      | discriminate ].
  Qed.

  Section LogicalIndex.

    (* To define various replacement strategies, we're going to
       add a logical index to the pairs of keys and values. *)

    Definition KVEnsemble_EquivalentKeys {A B}
               (ens : Ensemble (Key * A))
               (ens' : Ensemble (Key * B)) :=
      (forall k a, ens (k, a) -> (exists b, ens' (k, b)))
      /\ (forall k b, ens' (k, b) -> (exists a, ens (k, a))).

    Definition CacheADTwLogIndex_AbsR
             (or : Ensemble (Key * Value))
             (nr : Ensemble (Key * Value) *
                   Ensemble (Key * nat))
      := or = (fst nr)
         /\ (KVEnsemble_EquivalentKeys (fst nr) (snd nr)).

    Definition DropLogIndex
               (nr : Ensemble (Key * Value) *
                     Ensemble (Key * nat))
    : Ensemble (Key * Value) :=
      fst nr.

  (* Pick the key with the lowest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_min
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                idx <= snd ki))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

  (* Pick the key with the highest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_max
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                snd ki <= idx))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

    Lemma refine_LogIndexEmpty
    : refine {nr' |
              CacheADTwLogIndex_AbsR (fun _ : Key * Value => False) nr'}
             (ret (fun _  => False, fun _ => False)).
    Proof.
      apply refine_pick_val;
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys; intuition;
      destruct_ex; eauto.
    Qed.

    Lemma refine_LogIndexUsedKey
    : forall n or nr,
        CacheADTwLogIndex_AbsR or nr
        -> refine {b | decides b (usedKey or n)}
               {b | decides b (usedKey (fst nr) n)}.
    Proof.
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys;
      intros; apply refine_pick_pick;
      unfold usedKey; simpl; intros; unfold decides;
      find_if_inside; simpl in * ; destruct_ex;
      unfold Same_set, Included, In in *; intuition; subst; eauto.
    Qed.

    Lemma refine_pick_CacheADTwLogIndex_AbsR or' :
          refine
            {nr' | CacheADTwLogIndex_AbsR or' nr'}
            (nr' <- {nr' | KVEnsemble_EquivalentKeys or' nr'};
             ret (or', nr')).
    Proof.
      unfold CacheADTwLogIndex_AbsR; intros.
      setoid_rewrite refineEquiv_pick_pair_snd_dep; simpl.
      refine pick val or'.
      simplify with monad laws; f_equiv.
      unfold Same_set, Included; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Remove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (a : Key),
             KVEnsemble_EquivalentKeys (EnsembleRemoveKey a ens)
                                       (EnsembleRemoveKey a ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemoveKey in *;
        simpl in *; intuition.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Replace {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             kb c,
             KVEnsemble_EquivalentKeys (EnsembleReplaceKey kb ens)
                                       (EnsembleReplaceKey (fst kb, c) ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleReplaceKey,
        EnsembleRemoveKey in *;
        simpl in *; intuition; injections; eauto.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Update {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k f g,
             KVEnsemble_EquivalentKeys (EnsembleUpdateKey k ens f)
                                       (EnsembleUpdateKey k ens' g).
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleUpdateKey,
        EnsembleReplaceKey, EnsembleRemoveKey in *;
        simpl in *; intuition; injections; eauto; subst.
      destruct_ex; intuition; eauto; subst.
      apply H in H3; destruct_ex; eauto.
      exists (g x0); left; intuition; eauto.
      apply H in H3; destruct_ex; eauto.
      destruct_ex; intuition; subst.
      apply H0 in H3; destruct_ex;
      eexists; left; intuition; eauto.
      apply H0 in H3; destruct_ex;  eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Refl {B} :
      forall (ens : Ensemble (Key * B)),
        KVEnsemble_EquivalentKeys ens ens.
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemoveKey in *;
      simpl in *; intuition; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Insert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) (c : C),
             KVEnsemble_EquivalentKeys (EnsembleInsert ab ens)
                                       (EnsembleInsert (fst ab, c) ens').
    Proof.
      unfold refine; intros.
      unfold KVEnsemble_EquivalentKeys, EnsembleInsert in *;
        simpl in *; intuition; injections; eauto.
      apply H in H2; destruct_ex; eauto.
      apply H0 in H2; destruct_ex; eauto.
    Qed.

    Definition PickID {A} (_ : A) := True.

    Lemma refine_pick_KVEnsembleInsert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B),
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert ab ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleInsertRemove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) k,
        refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert
                           ab
                           (EnsembleRemoveKey k ens)) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b)
                                  (EnsembleRemoveKey k ens'))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleRemoveKey {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleRemoveKey k ens) ens''}
             (ret (EnsembleRemoveKey k ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleReplaceKey {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleReplaceKey k ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleReplaceKey (fst k, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Replace.
    Qed.

    Lemma refine_pick_KVEnsembleUpdateKey {B C}
    : forall (ens : Ensemble (Key * B))
                (ens' : Ensemble (Key * C))
                (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
                k f,
             refine
               {ens'' | KVEnsemble_EquivalentKeys
                          (EnsembleUpdateKey k ens f) ens''}
               (b <- {b | @PickID C b};
                ret (EnsembleUpdateKey k ens' (fun _ => b))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Update.
    Qed.

    Lemma refine_pick_KVEnsemble {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens'),
             refine
          {ens'' | KVEnsemble_EquivalentKeys ens ens''}
          (ret ens').
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto.
    Qed.
  End LogicalIndex.

End CacheEvictionStrategies.


Require Import  Algebra.Utils Algebra.SetoidCat Algebra.Monad Algebra.Monoid Algebra.Alternative SetoidUtils Algebra.Applicative Algebra.Functor Algebra.FoldableFunctor Algebra.Traversable Tactics Algebra.Monoid.Alternative Algebra.Applicative.Monad Algebra.Functor.Monad.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Require Import Coq.Lists.List.

Open Scope type_scope.

Section ContT.

  Context
    {R : Type} (SR : Setoid R)
    {m : forall A, Setoid A -> Type}
    (mS : forall A (SA : Setoid A), Setoid (m A SA))
  .

  Definition contT A {SA : Setoid A} := (SA ~~> mS _ SR) ~> mS _ SR.
  Definition contTS {A} (SA : Setoid A) := (SA ~~> mS _ SR) ~~> mS _ SR.

  Section Bind.
    Context A B (SA : Setoid A) (SB : Setoid B).
  Definition contT_bind  : contTS SA ~> (SA ~~> contTS SB) ~~> contTS SB.
    simple refine (injF (fun a => injF (fun f => injF (fun c => a @ injF (fun a' => f @ a' @ c) _) _) _) _).
    Lemma contT_bindE_1 : forall pr3 pr2 pr1, Proper (equiv ==> equiv)
     (fun a : (SA ~~> mS _ SR) ~> mS _ SR =>
      injF
        (fun f : SA ~> contTS SB =>
         injF
           (fun c : SB ~> mS _ SR => a @ injF (fun a' : A => f @ a' @ c) (pr3 f c))
           (pr2 a f)) (pr1 a)).
    repeat autounfold. intros. arrequiv.
  Qed.

  Lemma contT_bindE_2 : forall   (x : (SA ~~> mS _ SR) ~> mS _ SR) pr3 pr2 ,
   Proper (equiv ==> equiv)
     (fun f : SA ~> contTS SB =>
      injF
        (fun c : SB ~> mS _ SR => x @ injF (fun a' : A => f @ a' @ c) (pr3 f c))
        (pr2 f)).
    repeat autounfold. intros. arrequiv. apply eval_Proper. reflexivity. arrequiv.
  Qed.

  Lemma proper_f_x_a : forall A B C (SA : Setoid A) (SB : Setoid B) (SC : Setoid C) (x : SA ~> SB ~~> SC) (x0 : B),
                          Proper (equiv ==> equiv) (fun a' : A => x @ a' @ x0).
    repeat autounfold. intros. rewrite H. reflexivity.
  Qed.

  Lemma contT_bindE_3 : forall    (x : (SA ~~> mS _ SR) ~> mS _ SR) (x0 : SA ~> contTS SB) pr,
   Proper (equiv ==> equiv)
     (fun c : SB ~> mS _ SR =>
        x @ injF (fun a' : A => x0 @ a' @ c) (pr c)).
    repeat autounfold. intros.  apply eval_Proper. reflexivity. arrequiv.
  Qed.
    intros. apply proper_f_x_a.
    apply contT_bindE_3.
    apply contT_bindE_2.
    apply contT_bindE_1.
  Defined.
End Bind.

  Section Ret.
    Context A (SA : Setoid A).
    Definition contT_ret  : SA ~> contTS SA.
      simple refine (injF (fun a => injF (fun c => c @ a) _) _).
      Lemma proper_x_a : forall A B (SA : Setoid A) (SB : Setoid B) (a : A), Proper (equiv ==> equiv) (fun c : SA ~> SB => c @ a).
      Proof.
        repeat autounfold. intros. rewrite H. reflexivity.
      Qed.
      apply proper_x_a.
      Lemma contT_retE_1 : Proper (equiv ==> equiv)
                                  (fun a : A =>
                                     injF (fun c : SA ~> mS R SR => c @ a)
                                          (proper_x_a A (m R SR) SA (mS R SR) a)).
      Proof.
        repeat autounfold. intros. arrequiv.
      Qed.
      apply contT_retE_1.
    Defined.
  End Ret.

  Lemma contT_left_unit : forall (A B : Type) (SA : Setoid A) (SB : Setoid B)
     (a : A) (f : SA ~> contTS SB),
   contT_bind A B SA SB @ (contT_ret A SA @ a) @ f == f @ a.
  Proof.
    intros. simpl. arrequiv.
  Qed.

  Lemma contT_associativity : forall (A B C  : Type) (SA : Setoid A) (SB : Setoid B)
     (SC : Setoid C) (a : contT A)   (f : SA ~> contTS SB)
     (g : SB ~> contTS SC)
     (pr : Proper (equiv ==> equiv) (fun b : A => contT_bind B C SB SC @ (f @ b) @ g))
     ,
   contT_bind B C SB SC @ (contT_bind A B SA SB @ a @ f) @ g ==
   contT_bind A C SA SC @ a @
               injF (fun b : A => contT_bind B C SB SC @ (f @ b) @ g) pr.
  Proof.
    intros. simpl. arrequiv.  apply eval_Proper. reflexivity. arrequiv.
  Qed.

  Lemma contT_right_unit : forall (A  : Type) (SA : Setoid A)
     (a : contT A),
                             contT_bind A A SA SA @ a @ (contT_ret A SA) == a.
  Proof.

    intros. simpl. arrequiv.  apply eval_Proper. reflexivity. apply fun_ext. intros. simpl. reflexivity.
  Qed.
  Instance contT_Monad : @Monad (@contT) (@contTS).
  Proof.
    exists contT_ret contT_bind.
    apply contT_left_unit.
    apply contT_right_unit.
    apply contT_associativity.
  Defined.

  Section RunContT.
    Context {A} {SA : Setoid A}.
    Definition contT_runContT  : contTS SA ~> (SA ~~> mS _ SR) ~~> mS _ SR.
    simple refine (injF (fun a => injF (eval a) _) _).
    Lemma proper_evala : forall A B (SA : Setoid A ) (SB : Setoid B) (a : SA  ~> SB), Proper (equiv ==> equiv) (eval a).
    Proof.
      repeat autounfold. intros. rewrite H. reflexivity.
    Qed.
    apply proper_evala.
    Lemma proper_evalx  : forall (A B : Type) (SA : Setoid A) (SB : Setoid B)  pr,    Proper (equiv ==> equiv)
     (fun a : SA ~> SB =>
      injF (eval a)
           (pr a)).
      Proof.
    repeat autounfold. intros. arrequiv.

      Qed.
      apply proper_evalx.

    Defined.
  End RunContT.

  Context
    {R_Monoid : @Monoid _ SR}
    {alt : @Alternative m mS}.

  Definition contT_empty {A} {SA : Setoid A} : (contT A) := constS _ @ empty.

  Existing Instance alternative_Monoid.
  Definition contT_append {A} {SA : Setoid A} : contTS SA ~> contTS SA ~~> contTS SA.
    refine (injF3 (fun a b c =>
                     ((contT_runContT @ a @ c)) <|> (contT_runContT @ b @ c)) _).
    Lemma contT_append_1 : forall {A} {SA : Setoid A}, Proper (equiv ==> equiv ==> equiv ==> equiv)
     (fun (a b : contT A) (c : SA ~> mS _ SR) =>
      contT_runContT @ a @ c <|> contT_runContT @ b @ c).
  Proof.
    intros. solve_proper.
  Qed.
  apply contT_append_1.
  Defined.

  Instance contT_Alternative : @Alternative (@contT) (@contTS).
  Proof.
    exists (@contT_empty) (@contT_append).
    intros. simpl. arrequiv. apply left_unit_alt.

    intros. simpl. arrequiv. apply right_unit_alt.

    intros. simpl.  arrequiv.  apply associativity_alt.
  Defined.

  Instance contT_A_Monoid A AS: @Monoid (contT A) (contTS AS) := @alternative_Monoid (@contT) (@contTS) _ A _.

  Lemma contT_left_distributivity :
    forall A B (SA : Setoid A) (SB : Setoid B)
           (a a2 : contT A ) (f : SA ~> contTS SB),
      (mappend @ a @ a2) >>= f == mappend @ (a >>= f) @ (a2 >>= f).
  Proof.
    intros. simpl. arrequiv.
  Qed.

  Context
    {mnd : @Monad m mS}.
  Existing Instance monad_Applicative.
  Existing Instance monadFunctor.

  Lemma contT_ret_injective :
    injective SR (mS _ SR) (@ret m _ _ _ _) -> injective SR (contTS SR) (contT_ret R SR).
  Proof.
    unfold injective. simpl.  unfold arrEquiv. simpl.  intros. apply H. apply H0.
  Qed.

  Section Lift.
    Context {A} {SA : Setoid A}.
    Definition contT_lift : mS  _ SA ~> contTS SA := bind.

  End Lift.

End ContT.

Section Utils.
  Context
    {m mS} {mnd : @Monad m mS} {R} {SR : Setoid R}.

  Definition lift  {A} {SA : Setoid A} : mS _ SA ~> contTS SR mS SA := contT_lift SR mS.

  Definition runContT {A} {SA : Setoid A} : contTS SR mS SA ~> (SA ~~> mS _ SR) ~~> mS _ SR := contT_runContT SR mS.

  Definition finish {A} {SA : Setoid A} : SR ~> (contTS SR mS SA).
    simple refine (injF2 (fun r c => ret @ r) _).

    apply mS.
    exact mnd.

    Lemma finish_1 : forall {m mS} {mnd : @Monad m mS} {R} {SR : Setoid R} {A} {SA : Setoid A}, Proper (equiv ==> equiv ==> equiv)
                            (fun (r : R) (_ : SA ~> mS _ SR) => ret @ r).
    Proof.
      repeat autounfold. intros. rewrite H. reflexivity.
    Qed.

    apply finish_1.
  Defined.
End Utils.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.
Require Import Coq.Program.Equality.

Require Import LIR.maps.

Require Import LIR.pallene.
Require Import LIR.pall2lir.
Require Import LIR.lir.
Require Import LIR.dyn.

(*
** Sintax of λ-Lua
*)
Inductive LE : Set :=
| LENil : LE
| LENum : nat -> LE
| LEPlus : LE -> LE -> LE
| LENew : LE
| LETAddr : address -> LE
| LEFAddr : address -> LE
| LEGet  : LE -> LE -> LE
| LESet : LE -> LE -> LE -> LE
| LEVar : string -> LE
| LEApp : LE -> LE -> LE
| LEFun : string -> LE -> LE
| LELet : string -> LE -> LE -> LE
.

(*
** λ-Lua environments: Variables in Lua must be declared, but they have
** no types.
*)
Definition LEnv := Map unit.

(*
** A well-formed Lua expression cannot have free variables
*)

Reserved Notation "Γ '|l=' e"  (at level 40, no associativity,
                                     e at next level).

Inductive LEWT : LEnv -> LE -> Prop :=
| WTNil : forall Γ, Γ |l= LENil
| WTNum : forall Γ n, Γ |l= (LENum n)
| WTPlus : forall Γ e1 e2, Γ |l= e1 -> Γ |l= e2 -> Γ |l= (LEPlus e1 e2)
| WTNew : forall Γ, Γ |l= LENew
| WTTAddr : forall Γ a, Γ |l= (LETAddr a)
| WTFAddr : forall Γ a, Γ |l= (LEFAddr a)
| WTGet : forall Γ e1 e2, Γ |l= e1 -> Γ |l= e2 -> Γ |l= (LEGet e1 e2)
| WTSet : forall Γ e1 e2 e3, Γ |l= e1 -> Γ |l= e2 -> Γ |l= e3 ->
               Γ |l= (LESet e1 e2 e3)
| WTVar : forall Γ var, In Γ var = Some tt -> Γ |l= (LEVar var)
| WTApp : forall Γ e1 e2, Γ |l= e1 -> Γ |l= e2 -> Γ |l= (LEApp e1 e2)
| WTFun : forall Γ var body, (var |=> tt; Γ) |l= body ->
            Γ |l= (LEFun var body)
| WFLet : forall Γ var init body,
              Γ |l= init ->
              (var |=> tt; Γ) |l= body ->
              Γ |l= (LELet var init body)

where "Γ '|l=' e" := (LEWT Γ e)
.

(*
** Compilation of Lua programs to Lir
*)
Fixpoint Lua2Lir (e : LE) : IRE :=
  match e with
  | LENil => IREBox TgNil IRENil
  | LENum n => IREBox TgInt (IRENum n)
  | LEPlus e1 e2 => IREBox TgInt (IREPlus (IREUnbox TgInt (Lua2Lir e1))
                                          (IREUnbox TgInt (Lua2Lir e2)))
  | LENew => IREBox TgTbl IRENew
  | LETAddr a => IREBox TgTbl (IRETAddr a)
  | LEFAddr a => IREBox TgFun (IREFAddr a)
  | LEGet e1 e2 => IREGet (IREUnbox TgTbl (Lua2Lir e1)) (Lua2Lir e2)
  | LESet e1 e2 e3 => IREBox TgNil (IRESet (IREUnbox TgTbl (Lua2Lir e1))
                                           (Lua2Lir e2)
                                           (Lua2Lir e3))
  | LEVar var => IREVar var
  | LEFun var body =>
      IREBox TgFun (IREFun var
         (IRELet var IRTStar (IREVar var) (Lua2Lir body)))
  | LELet var init body =>
         (IRELet var IRTStar (Lua2Lir init) (Lua2Lir body))
  | LEApp e1 e2 => IREApp (IREUnbox TgFun (Lua2Lir e1)) (Lua2Lir e2)
  end.

(*
** Tanslation of Pallene programs to Lua (erasure)
*)
Fixpoint Pall2Lua (e : PE) : LE :=
  match e with
  | PENil => LENil
  | PENum n => LENum n
  | PEPlus e1 e2 => LEPlus (Pall2Lua e1) (Pall2Lua e2)
  | PENew _ => LENew
  | PETAddr a _ => LETAddr a
  | PEFAddr a _ _ => LEFAddr a
  | PEGet e1 e2 => LEGet (Pall2Lua e1) (Pall2Lua e2)
  | PESet e1 e2 e3 => LESet (Pall2Lua e1) (Pall2Lua e2) (Pall2Lua e3)
  | PEVar var => LEVar var
  | PEApp e1 e2 => LEApp (Pall2Lua e1) (Pall2Lua e2)
  | PEFun var _ e _ => LEFun var (Pall2Lua e)
  | PELet var _ init body => LELet var (Pall2Lua init) (Pall2Lua body)
  | PECast e _ => Pall2Lua e
  end.

(*
** Casts disapear under 'dyn'
*)
Lemma dynCast : forall (t1 t2 : IRType) (e : IRE),
    dyn (Cast t1 t2 e) = dyn e.
Proof.
  unfold Cast.
  intros.
  destruct t1; destruct t2; simpl;
  try match goal with t1:Tag, t2:Tag |- _ => destruct (dec_Tag t1 t2) end;
  trivial.
Qed.

(*
** Main syntactic theorem: compiling and erasuring commute
*)
Theorem PallLua : forall Γ e t,
    PTyping Γ e t -> Lua2Lir (Pall2Lua e) = dyn (Pall2Lir Γ e).
Proof.
  intros Γ e.
  generalize dependent Γ.
  induction e; intros * Hty; inversion Hty; subst;
  trivial;
  (* instantiate induction hypotheses *)
  repeat match goal with
    IH: _ -> _ -> PTyping _ ?E _ -> _,
    HTy: PTyping _ ?E _ |- _ =>
     specialize (IH _ _ HTy)
  end;
  (* eliminate casts *)
  simpl;
  repeat rewrite dynCast;
  (* break if's from casts *)
  repeat match goal with |- context [GtypeOf ?G ?E] =>
    destruct (GtypeOf G E) end;
  simpl;
  congruence.
Qed.

(*
** Lua programs are as dynamic as possible
*)
Theorem LuaIsDyn : forall e, Lua2Lir e = dyn (Lua2Lir e).
Proof.
  induction e; simpl; congruence.
Qed.

(*
** Direct semantics of Lua programs, without
** translation to Lir
*)

Unset Elimination Schemes.
Inductive LValue : LE -> Prop :=
| LVnil : LValue LENil
| LVnum : forall n, LValue (LENum n)
| LVtbl : forall a, LValue (LETAddr a)
| LVfun : forall a, LValue (LEFAddr a)
.
Set Elimination Schemes.

Scheme LValue_ind := Induction for LValue Sort Prop.

Lemma LV_unique: forall v  (V1 V2 : LValue v), V1 = V2.
Proof.
  intros *.
  induction V1; dependent destruction V2; trivial.
Qed.

Inductive LExpValue : Set :=
| LEV : forall e, LValue e -> LExpValue.

Definition LEV2Val (me : LExpValue) :=
  match me with
  | LEV v _ => v
  end.

Lemma LEV2ValEq : forall vv vv',
  LEV2Val vv = LEV2Val vv' -> vv = vv'.
Proof.
  intros * HEq.
  destruct vv. destruct vv'. simpl in HEq; subst.
  replace l0 with l by (apply LV_unique); trivial.
Qed.

Inductive LMem : Set :=
| LEmptyMem : LMem
| LUpdateT : address -> Index -> LExpValue -> LMem -> LMem
| LUpdateF : address -> string -> LE -> LMem -> LMem.

Definition LToIndex (e : LE) : Index :=
  match e with
  | LENil => I 0 TgNil
  | LENum n => I n TgInt
  | LETAddr a => I a TgTbl
  | LEFAddr a => I a TgFun
  | _ => NI
  end.

Lemma LuaIndex : forall e, LToIndex e = ToIndex (Lua2Lir e).
Proof.
  destruct e; trivial.
Qed.

Fixpoint LqueryT (a : address) (idx : LE) (m : LMem) : LE :=
  match m with
  | LEmptyMem => LENil
  | LUpdateT a' idx' e m' => if Nat.eq_dec a a' then
                           if Index_dec (LToIndex idx) idx' then (LEV2Val e)
                           else LqueryT  a idx m'
                         else LqueryT  a idx m'
  | LUpdateF _ _ _ m' => LqueryT a idx m'
  end.

Fixpoint LqueryF (a : address) (m : LMem) : (string * LE) :=
  match m with
  | LEmptyMem => (""%string, LENil)
  | LUpdateT a' _ _ m' => LqueryF a m'
  | LUpdateF a' var body m' => if Nat.eq_dec a a' then (var, body)
                              else LqueryF a m'
  end.

Fixpoint Lfreshaux (m : LMem) : address :=
  match m with
  | LEmptyMem => 1
  | LUpdateT _ _ _ m' => S (Lfreshaux m')
  | LUpdateF _ _ _ m' => S (Lfreshaux m')
  end.

Definition LfreshT (m : LMem) : (address * LMem) :=
  let f := Lfreshaux m in
    (f, LUpdateT f (I 0 TgNil) (LEV LENil LVnil) m).

Definition LfreshF (m : LMem) (v : string) (b : LE) : (address * LMem) :=
  let f := Lfreshaux m in
    (f, LUpdateF f v b m).

Reserved Notation "'[' x ':=' s ']l' t" (at level 20, x constr).

Fixpoint substitution (var : string) (y : LE)  (e : LE) : LE :=
 match e with
 | LENil => e
 | LENum n => e
 | LEPlus e1 e2 => LEPlus ([var := y]l e1) ([var := y]l e2)
 | LENew => e
 | LETAddr a => e
 | LEFAddr a => e
 | LEGet e1 e2 => LEGet ([var := y]l e1) ([var := y]l e2)
 | LESet e1 e2 e3 => LESet ([var := y]l e1) ([var := y]l e2) ([var := y]l e3)
 | LEVar var' => if string_dec var var' then y else e
 | LEFun var' body => if string_dec var var' then e
                       else LEFun var' ([var := y]l body)
 | LELet var' init body =>
      if string_dec var var'
         then LELet var' ([var := y]l init) body
         else LELet var' ([var := y]l init) ([var := y]l body)
 | LEApp e1 e2 => LEApp ([var := y]l e1) ([var := y]l e2)
end
where "'[' x ':=' s ']l' t" := (substitution x s t)
.

(*
** Bigstep semantics for Lua expressions
*)
Reserved Notation "m '/' e ==> m1 '/' e1"
(at level 40, e at level 39, m1 at level 39, e1 at level 39).

Inductive Lstep : LMem -> LE -> LMem -> LE -> Prop :=
| LStValue : forall m e, LValue e -> m / e ==> m / e
| LStPlus : forall m e1 e2 m' n1 m'' n2,
    m / e1 ==> m' / (LENum n1) ->
    m' / e2 ==> m'' / (LENum n2) ->
    m / LEPlus e1 e2 ==> m'' / LENum (n1 + n2)
| LStNew : forall m m' free,
    (free, m') = LfreshT m ->
    m / LENew ==> m' / LETAddr free
| LStGet : forall m e1 m' a e2 m'' idx,
    m / e1 ==> m' / LETAddr a ->
    m' / e2 ==> m'' / idx ->
    m / LEGet e1 e2 ==> m'' / LqueryT a idx m''
| LStSet : forall m e1 m' a e2 m'' idx e3 v m''',
    m / e1 ==> m' / LETAddr a ->
    m' / e2 ==> m'' / idx ->
    m'' / e3 ==> m''' / LEV2Val v ->
    m / LESet e1 e2 e3 ==> LUpdateT a (LToIndex idx) v m''' / LENil
| LStFun : forall m m' v b free,
    (free, m') = LfreshF m v b ->
    m / LEFun v b ==> m' / LEFAddr free
| LStLet : forall init vinit var body res m m' m'',
    m / init ==> m' / vinit ->
    m' / ([var := vinit]l body) ==> m'' / res ->
    m / LELet var init body ==> m'' / res
| LStApp : forall m e1 a var body e2 m' m'' v m''' res,
     m / e1 ==> m' / LEFAddr a ->
     m' / e2 ==> m'' / v ->
     (var, body) = LqueryF a m'' ->
     m'' / ([var := v]l body) ==> m''' / res ->
     m / LEApp e1 e2 ==> m''' / res

where "m / e ==> m1 / e1" := (Lstep m e m1 e1)
.

Example L1 : LEmptyMem / LEPlus (LENum 3) (LENum 5) ==>
             LEmptyMem / LENum 8.
Proof.
  replace 8 with (3 + 5) by trivial.
  eauto using Lstep, LValue.
Qed.

Lemma auxmem : forall a m m' v v' e e',
  LfreshF m v e = (a, m') ->
  LqueryF a m' = (v', e') ->
  v = v' /\ e = e'.
Proof.
  intros * Hf Hq.
  unfold LfreshF in Hf. inversion Hf; subst.
  simpl in Hq.
  breakIndexDec; intuition; congruence.
Qed.

Example L2 : exists m,
    LEmptyMem / LEApp (LEFun "x" (LEVar "x")) (LENum 10) ==>
    m / LENum 10.
Proof.
  destruct (LfreshF LEmptyMem "x" (LEVar "x")) as [a m'] eqn:Heq.
  destruct (LqueryF a m') eqn:Heq'.
  specialize (auxmem _ _ _ _ _ _ _ Heq Heq') as [? ?]; subst.
  eexists.
  eauto using Lstep, LValue.
Qed.

Lemma ValueStep : forall m e m' e',
  LValue e ->
  m / e ==> m' / e' ->
  m = m' /\ e = e'.
Proof.
  induction e; intros * HV HSt; try (inversion HV; fail);
  inversion HSt; subst; split; trivial.
Qed.

Ltac NoValue :=
  match goal with H: LValue _ |- _ => inversion H end.

Ltac applyH :=
  repeat match goal with
      H: forall _ _, (Lstep ?M ?E _ _) -> _,
        H1: Lstep ?M ?E _ _ |- _ =>
              specialize (H _ _ H1) as [? ?]; subst
  end.

Ltac LEV2ValEq :=
  match goal with
    H: LEV2Val ?v = LEV2Val ?v' |- _ =>
      replace v' with v in * by auto using LEV2ValEq
  end.

Theorem LuaDeterminism : forall m e m1' v1 m2' v2,
    m / e ==> m1' / v1  ->
    m / e ==> m2' / v2  ->
    m1' = m2' /\ v1 = v2.
Proof.
  intros * HSt1.
  generalize dependent m2'.
  generalize dependent v2.
  induction HSt1; intros * HSt2; only 1: auto using ValueStep;
  inversion HSt2; subst; try NoValue;
  try (applyH; try LEV2ValEq; split; congruence; fail).

  - (* LStLet *)
    repeat match goal with
      |[IH: forall _ _ , ?M / ?E ==> _ / _ -> _,
        H1: ?M / ?E ==> _ / _,
        H2: ?M / ?E ==> _ / _ |- _] =>
          specialize (IH _ _ H2) as [? ?]; subst
    end.
    eapply IHHSt1_3.
    match goal with
      H: LEFAddr ?a = LEFAddr ?a' |- _ =>
        replace a' with a in * by congruence
    end.
    match goal with
      H1: (?e1, ?e1') = ?E,
      H2: (?e2, ?e2') = ?E |- _ =>
         replace e1 with e2 by congruence;
         replace e1' with e2' by congruence
    end.
   trivial.
Qed.

Theorem L2LirValue : forall e, LValue e -> Value (Lua2Lir e).
Proof.
  inversion 1; simpl; subst; eauto using Value.
Defined.

Inductive Lmem_correct : LMem -> Prop :=
| LMCE : Lmem_correct LEmptyMem
| LMCU : forall a idx v m,
     MEmpty |l= (LEV2Val v) ->
     Lmem_correct m ->
     Lmem_correct (LUpdateT a idx v m)
| LMCF : forall a var body m,
     (var |=> tt; MEmpty) |l= body ->
     Lmem_correct m ->
     Lmem_correct (LUpdateF a var body m)
.

Lemma mem_correct_freshT : forall m m' free,
  Lmem_correct m -> (free,m') = LfreshT m -> Lmem_correct m'.
Proof.
  unfold LfreshT. inversion 2.
  eauto using Lmem_correct, LEWT.
Qed.

Lemma mem_correct_freshF : forall m m' free var body,
  (var |=> tt; MEmpty) |l= body ->
  Lmem_correct m ->
  (free,m') = LfreshF m var body ->
  Lmem_correct m'.
Proof.
  unfold LfreshF. inversion 3. subst.
  apply LMCF; trivial.
Qed.

Ltac DExpValue :=
  match goal with L: LExpValue |- _ => destruct L end.

Lemma LMCqueryT : forall a v m, LValue (LqueryT a v m).
Proof.
  intros.
  induction m; eauto using LValue.
  DExpValue. simpl.
  breakIndexDec; trivial.
Qed.

Lemma LMCqueryF : forall a m var body,
    (var, body) = LqueryF a m ->
    Lmem_correct m ->
    (var |=> tt; MEmpty) |l= body.
Proof.
  intros * Heq HMc. induction m.
  - inversion Heq; subst. auto using LEWT.
  - inversion HMc; subst.
    auto.
  - inversion HMc; subst.
    simpl in Heq.
    breakIndexDec; auto.
    inversion Heq; subst. trivial.
Qed.

Lemma LMCWT : forall a v m, Lmem_correct m -> MEmpty |l= (LqueryT a v m).
Proof.
  induction 1; eauto using LEWT.
  simpl. breakIndexDec; auto.
Qed.

Lemma inclusion_WT : forall Γ Γ' e,
  inclusion Γ Γ' -> Γ |l= e -> Γ' |l= e.
Proof.
  intros * Hin Hty.
  generalize dependent Γ'.
  induction Hty; eauto using LEWT, inclusion_update.
Qed.

Corollary WT_empty : forall Γ e, MEmpty |l= e -> Γ |l= e.
Proof.
  eauto using inclusion_WT, inclusion_empty.
Qed.

Lemma subst_WT : forall e2 Γ var e1,
  (var |=> tt; Γ) |l= e2 -> MEmpty |l= e1 -> Γ |l= ([var := e1]l e2).
Proof.
  induction e2; intros * HWT2 HWT1; simpl;
  inversion HWT2; subst;
  breakStrDec;
  eauto 6 using LEWT, WT_empty, InNotEq, inclusion_WT, inclusion_shadow,
  inclusion_permute.
Qed.

Lemma luaPreservation : forall e m v m',
  m / e ==> m' / v ->
  Lmem_correct m ->
  MEmpty |l= e ->
  Lmem_correct m' /\ LValue v /\ MEmpty |l= v.
Proof.
  intros e m v m' HSt HM HWT.
  induction HSt; inversion HWT; subst;
  try (repeat split; try apply HM; eauto using LValue; fail);
  (* instantiate and split induction hyphoteses *)
  repeat match goal with
    HM: Lmem_correct ?M,
    HWT: LEWT MEmpty ?E,
    IH: Lmem_correct ?M -> LEWT MEmpty ?E -> _ |- _ =>
     specialize (IH HM HWT) as [? [? ?]]
  end;
  eauto using LValue, LEWT;
  try match goal with
  |   HM: Lmem_correct ?M,
      HFr: _ = LfreshT ?M |- _ =>
     specialize (mem_correct_freshT _ _ _ HM HFr); clear HFr; intros
  |   HM: Lmem_correct ?M,
      HFr: _ = LfreshF ?M _ ?b,
      HTy: LEWT _ ?b |- _ =>
     specialize (mem_correct_freshF _ _ _ _ _ HTy HM HFr); intros
  end;
  eauto using LValue, LEWT,Lmem_correct, LMCqueryT, LMCqueryF, LMCWT,
              subst_WT.
Qed.

Corollary luaPreservationMem : forall e m v m',
  m / e ==> m' / v ->
  Lmem_correct m ->
  MEmpty |l= e ->
  Lmem_correct m'.
Proof. eapply luaPreservation. Qed.

Corollary luaPreservationWT : forall e m v m',
  m / e ==> m' / v ->
  Lmem_correct m ->
  MEmpty |l= e ->
  MEmpty |l= v.
Proof. eapply luaPreservation. Qed.

Lemma stepValue : forall e m v m',
  m / e ==> m' / v ->
  Lmem_correct m ->
  MEmpty |l= e ->
  LValue v.
Proof.
  intros * HSt HM HWT.
  induction HSt; inversion HWT; subst;
  eauto 10 using LValue, LMCqueryT, LMCqueryF, luaPreservationMem,
                 luaPreservationWT, subst_WT.
Qed.

(*
** Correspondence between λ-Lua reduction and LIR reduction.
*)

(* Translate a memory to LIR, lifting Lua2Lir pointwise. *)
Fixpoint MLua2Lir (m : LMem) : Mem :=
  match m with
  | LEmptyMem => EmptyMem
  | LUpdateT a n (LEV v vv) m =>
      UpdateT a n (EV (Lua2Lir v) (L2LirValue v vv)) (MLua2Lir m)
  | LUpdateF a var body m =>
      UpdateF a var
       (IRELet var IRTStar (IREVar var) (Lua2Lir body)) (MLua2Lir m)
  end.

(*
** Translates a λ-Lua environment to LIR: All variables have type '*'
*)
Fixpoint LEnv2Lir (Γ : LEnv) : IREnvironment :=
  match Γ with
  | MEmpty => MEmpty
  | MCons var _ Γ' => MCons var IRTStar (LEnv2Lir Γ')
  end.

Lemma InLEnv2Lir : forall v v' Γ,
    In Γ v = Some v' -> In (LEnv2Lir Γ) v = Some IRTStar.
Proof.
  induction Γ; intros H.
  - discriminate.
  - destruct a; simpl in *. breakStrDec; auto.
Qed.

Lemma ConsLEnv2Lir : forall v Γ,
  inclusion (LEnv2Lir (v |=> tt; Γ)) (v |=> IRTStar; LEnv2Lir Γ).
Proof. unfold inclusion. trivial. Qed.

Lemma Lua2LirTypeAux : forall Γ e,
  Γ |l= e -> LEnv2Lir Γ |= Lua2Lir e : IRTStar.
Proof.
  intros Γ e.
  generalize dependent Γ.
  induction e; intros Γ HLE; inversion HLE; subst; simpl;
  eauto 8 using IRTyping, eq_refl, inclusion_typing,
    inclusion_shadow', InEq, InLEnv2Lir, ConsLEnv2Lir.
Qed.

Corollary Lua2LirType : forall e,
    MEmpty |l= e ->  MEmpty |= Lua2Lir e : IRTStar.
Proof. eapply Lua2LirTypeAux. Qed.

Lemma MLua2LirCorrect : forall m, Lmem_correct m -> mem_correct (MLua2Lir m).
Proof.
  induction 1; simpl; try DExpValue; eauto using mem_correct, Lua2LirType.
  - eapply MCF; simpl; trivial.
    eauto using IRTyping, InEq,
       inclusion_typing, Lua2LirTypeAux, inclusion_shadow'.
Qed.

Lemma L2LirQueryT : forall mem a idx,
    Lua2Lir (LqueryT a idx mem) =
    queryT a (Lua2Lir idx) (MLua2Lir mem).
Proof.
  intros mem a idx.
  induction mem; trivial.
  DExpValue. simpl.
  destruct (Nat.eq_dec a a0); subst; trivial.
  rewrite <- LuaIndex.
  breakIndexDec; subst; trivial.
Qed.

Lemma L2LirQueryF : forall var body a m,
  (var, body) = LqueryF a m ->
  (var, IRELet var IRTStar (IREVar var) (Lua2Lir body)) =
         queryF a (MLua2Lir m).
Proof.
  intros * HQ.
  induction m; simpl in *; inversion HQ; subst; try DExpValue; breakIndexDec; eauto.
  congruence.
Qed.

Lemma L2LirFreshaux : forall m, Lfreshaux m = freshaux (MLua2Lir m).
Proof.
  induction m; trivial; try DExpValue; simpl; congruence.
Qed.

Lemma L2LirFreshT : forall free m m',
  (free, m') = LfreshT m -> (free, MLua2Lir m') = freshT (MLua2Lir m).
Proof.
  unfold LfreshT,  freshT.
  intros * H.
  injection H; intros; subst.
  simpl. f_equal. apply L2LirFreshaux.
  simpl. f_equal. apply L2LirFreshaux.
Qed.

Lemma L2LirFreshF : forall free m m' v b,
  (free, m') = LfreshF m v b ->
  (free, MLua2Lir m') = freshF (MLua2Lir m) v (IRELet v IRTStar (IREVar v) (Lua2Lir b)).
Proof.
  unfold LfreshF,  freshF.
  intros * H.
  injection H; intros; subst.
  simpl. f_equal. apply L2LirFreshaux.
  simpl. f_equal. apply L2LirFreshaux.
Qed.

Lemma L2LirSubst : forall e1 var e2,
  Lua2Lir ([var := e1]l e2) =
  [var := (Lua2Lir e1)] (Lua2Lir e2).
Proof.
  induction e2; simpl;
  breakStrDec;
  simpl; try congruence.
Qed.

(* Propagate 'Lmem_correct' to all memories *)
Ltac LmemC :=
  repeat match goal with
      [ M : LMem |- _] =>  (* for all memories *)
      match goal with
      | [ H : Lmem_correct M |- _] => fail 1  (* already done *)
      | [ HSt: Lstep _ ?E M _ |- _] =>  (* else *)
         assert(Lmem_correct M) by (eapply (luaPreservation E); eauto)
      end
    end.

(* Instanciate induction hypotheses *)
Ltac instHI :=
    repeat match goal with
      HI: Lmem_correct ?M -> LEWT MEmpty ?E -> _,
      HM: Lmem_correct ?M,
      HWT: LEWT MEmpty ?E |- _ =>
        specialize (HI HM HWT)
    end.

(*
** If a Lua program results in a value, its translation to Lir results
** in the Lir translation of the final value.
*)
Theorem SimLua : forall e m v m',
    Lmem_correct m ->
    MEmpty |l= e ->
    m /e ==> m' / v  ->
    (MLua2Lir m) / (Lua2Lir e) -->* (MLua2Lir m') / (Lua2Lir v).
Proof with eauto 16 using CongBox, CongUnbox, CongPlus1, CongPlus2,
                   CongGet1, CongGet2, CongSet1, CongSet2, CongSet3,
                   CongLet, CongApp1, CongApp2,
                   multiTrans, multistep1, step, Value, stepValue,
                   L2LirQueryT, L2LirValue, L2LirFreshT, L2LirFreshF,
                   L2LirQueryF,
                   subst_WT, luaPreservationWT, LMCqueryF.

  intros * HMC HWT HSt.
  induction HSt; eauto using multistep...

  - (* LStPlus *)
    inversion HWT; subst;
    LmemC; instHI;
    simpl...

  - (* LStGet *)
    inversion HWT; subst.
    LmemC. instHI.
    simpl.
    (* reduce e1 and e2 *)
    eapply multiTrans with (e1 := IREGet (IRETAddr a)  (Lua2Lir idx))...
    rewrite L2LirQueryT...

  - (* LStSet *)
    inversion HWT; subst.
    LmemC. instHI.
    destruct v.
    simpl in *.
    (* reduce e1,  e2, and e3 *)
    eapply multiTrans with
      (e1 := IREBox TgNil (IRESet (IRETAddr a) (Lua2Lir idx) (Lua2Lir e)))...
    rewrite LuaIndex...

  - (* LStLet *)
    inversion HWT; subst.
    LmemC. instHI.
    simpl.
    eapply multiTrans with
      (e1 := IRELet var IRTStar (Lua2Lir vinit) (Lua2Lir body))...
    eapply MStMStep...  (* StLet *)
    rewrite <- L2LirSubst...

  - (* LStApp *)
    inversion HWT; subst.
    LmemC. instHI.
    simpl.
    (* reduce e1 and e2 *)
    eapply multiTrans with (e1 := IREApp (IREFAddr a) (Lua2Lir v))...
    eapply MStMStep...  (* StApp *)
    eapply MStMStep...  (* StLet *)
    simpl.
    destruct (string_dec var var); try easy.
    eapply MStMStep...  (* StLet *)
    rewrite <- L2LirSubst...
Qed.


From hahn Require Import Hahn.
From imm Require Import Events.
From imm Require Import Prog.
From imm Require Import Execution.

Require Import Pomset.
Require Import Action.
Require Import Formula.
Import Formula.Properties.
Import Formula.Syntax.
Require Import PredTransformer.
Require Import AuxDef.
Require Import AuxRel.
Require Import Language.
Require Import Semantics.

Set Implicit Arguments.

Open Scope formula_scope.
Open Scope list_additional_scope.

Module SeqBuilder.

Section Internal.

Context
  (α : thread_id)
  (s1 s2 : Stmt.t)
  (P1 P2 : pomset)
  (tdep : relation Events.Event.t)
  (PE1 : Semantics α s1 P1)
  (PE2 : Semantics α s2 P2).

Definition tlambda :=
  fun e =>
    ifP (events_set P1 e)
    then (λ P1 e)
    else (λ P2 e).

Definition t := {|
  events := events P1 ++ events P2;
  dep    := tdep;
  λ      := tlambda;
  κ      := seq_κ_def P1 P2 tlambda tdep;
  τ D ψ  := τ P1 D (τ P2 D ψ);
  term   := term P1 ∧ (τ P1 (events_set P1) (term P2));
          |}.

Let E := events_set t.

Hypothesis EQLAB :
  forall d (PD1 : events_set P1 d) (PD2 : events_set P2 d),
    λ P1 d = λ P2 d.

Variable P12 : pomset.
Hypothesis (EQ : P12 = t).

Lemma props :
  << _WF1          : wf P1 >> /\
  << _WF2          : wf P2 >> /\
  << _EUNION       : events_set P12 ≡₁ events_set P1 ∪₁ events_set P2 >> /\
  << _LAB_UNION    : label_union P12 P1 P2 >> /\
  << _SAMELBL_12_1 : forall d (DD : events_set P1 d), tlambda d = λ P1 d >> /\
  << _SAMELBL_12_2 : forall d (DD : events_set P2 d), tlambda d = λ P2 d >> /\
  << _SDP          : forall l l', set_disjoint (lset (map fst (θ (l' -- l) tlambda)))
                                              (lset l) >> /\
  << _TP1       : forall ψ, τ P1 (events_set t) ψ ⇔ τ P1 (events_set P1) ψ >> /\
  << _TP2       : forall ψ, τ P2 (events_set t) ψ ⇔ τ P2 (events_set P2) ψ >>.
Proof using PE1 PE2 EQLAB EQ.
  subst.
  assert (wf P1 /\ wf P2) as [WF1 WF2].
  { splits; eapply semantics_wf; eauto. }
  assert (events_set t ≡₁ events_set P1 ∪₁ events_set P2) as EVENTS12.
  { unfold t. unfold events_set.
    now ins; rewrite lset_app. }

  splits; auto.
  { red. unfold t, tlambda; ins.
    split; ins; desf. now apply EQLAB. }

  { unfold tlambda. ins. desf. }
  { unfold tlambda. ins. desf. now apply EQLAB. }

  { unfold set_disjoint, lset. ins.
    rewrite theta_map_fst, filter_list_minus, in_list_minus in IN.
    destruct IN as [IN_l' NIN_l].
    apply NIN_l, in_filter_iff; splits; auto.
    apply in_filter_iff in IN_l'; desf. }

  1,2: ins; apply wf_pt_family_equiv_on_E; auto.
  1,2: rewrite EVENTS12; clear; basic_solver.
Qed.

Lemma partial_wf :
  << WF_PT : forall D,  predTransformer (τ P12 D) >> /\
  << WF_LPT : forall D φ (CONS : lconsistent t (τ P12 D φ)), lconsistent P12 φ >> /\
  << WF_PT_SE_INDEP : forall φ e_ext v D (NOTINE : ~ (events_set P12 e_ext)),
        Formula.subst_ereg_val (τ P12 D φ) e_ext v
        ⇔
        τ t D (Formula.subst_ereg_val φ e_ext v) >> /\
  << WF_PT_FAMILY      : forall D C (CED : (C ∩₁ E) ⊆₁ D) ψ, τ P12 C ψ ⊨ τ P12 D ψ >> /\
  << WF_TERM           : term P12 ⊨ τ P12 E (Formula.tt) >> /\
  << WF_NINEλ : forall e (NIN : ~ E e), λ P12 e = def_action >> /\
  << WF_NINEκ : forall e (NIN : ~ E e), κ P12 e ⇔ Formula.tt >>.
Proof using PE1 PE2 EQLAB EQ.
  cdes props. subst.

  unfold t; subst E. splits; ins.
  all: unfold events_set in *; ins.
  { eapply pt_compose; [apply _WF1|apply _WF2]. }
  { unfold lconsistent in *; ins.

    (* (* Substitute λ12 with λ0 *) *)
    (* erewrite theta_lbl_eqdom in CONS. *)
    (* erewrite theta_lbl_eqdom. *)
    (* 2,3: by unfold eq_dom; intros; rewrite SAMELBL_12_0. *)

    (* Rewrite: P1 ∪ P2  -->  P1 ∪ (P2 \ P1) *)
    rewrite subst_ereg_val_list_eqv_func_lists
      with (l' := θ (events P1 ++ (events P2 -- events P1)) tlambda)
      in CONS; [| by apply theta_func_list |].
    2: { rewrite !theta_app, !theta_list_minus,
         !lset_app, !lset_list_minus; auto.
         rewrite set_unionC, <- set_minus_union_same.
         basic_solver. }
    rewrite theta_app, subst_ereg_val_list_app in CONS.
    rewrite wf_pt_se_indep_list with (P := P1) in CONS; auto.

    (* Substitute λ12 with λ1 to apply wf_lpt *)
    erewrite theta_lbl_eqdom with (l := events P1) in CONS.
    2: { unfold eq_dom; intros; rewrite <- _SAMELBL_12_1; eauto. }

    eapply wf_lpt in CONS; auto.
    2: by apply _SDP.

    unfold lconsistent in CONS.
    erewrite theta_lbl_eqdom with (l := events P1) in CONS.
    2: { unfold eq_dom; intros; rewrite _SAMELBL_12_1; eauto. }

    rewrite <- subst_ereg_val_list_app, <- theta_app in CONS.
    rewrite subst_ereg_val_list_eqv_func_lists
      with (l' := θ (events P2 ++ (events P1 -- events P2)) tlambda)
      in CONS; [| by apply theta_func_list |].
    2: { rewrite !theta_app, !theta_list_minus, !lset_app, !lset_list_minus; auto.
         unfolder; split; ins; desf; tauto. }
    rewrite theta_app, subst_ereg_val_list_app in CONS.
    rewrite wf_pt_se_indep_list with (P := P2) in CONS; auto.
    2: now apply _SDP.

    erewrite theta_lbl_eqdom with (l := events P2) in CONS.
    2: { unfold eq_dom; intros; rewrite <- _SAMELBL_12_2; eauto. }

    eapply wf_lpt in CONS; auto.
    unfold lconsistent in CONS.
    erewrite theta_lbl_eqdom with (l := events P2) in CONS.
    2: { unfold eq_dom; intros; rewrite <- _SAMELBL_12_2; eauto. }

    rewrite <- subst_ereg_val_list_app, <- theta_app in CONS.

    rewrite subst_ereg_val_list_eqv_func_lists
      with (l' := θ (events P1 ++ events P2) tlambda)
      in CONS; [| by apply theta_func_list |]; auto.
    rewrite !theta_app, !theta_list_minus, !lset_app, !lset_list_minus; auto.
    unfolder; split; ins; desf; tauto. }
  { rewrite wf_pt_se_indep; auto.
    1: apply pt_more; [apply _WF1 | apply wf_pt_se_indep]; auto.
    all: intro QQ; apply NOTINE; apply lset_app; basic_solver. }

  { transitivity (τ P1 C (τ P2 D ψ)).
    { eapply pt_entails; [by apply _WF1 |].
      eapply wf_pt_family; eauto.
      rewrite <- CED.
      unfold events_set; simpls.
      rewrite lset_app; basic_solver. }
    eapply wf_pt_family; eauto.
    rewrite <- CED.
    unfold events_set; simpls.
    rewrite lset_app; basic_solver. }
  { apply entails_elim_conj_l2.
    etransitivity.
    2: { apply pt_entails; [by apply _WF1|].
         etransitivity; [by apply (wf_term _WF2)|].
         eapply wf_pt_family; eauto.
         rewrite lset_app. basic_solver. }
    eapply wf_pt_family; eauto.
    rewrite lset_app. basic_solver. }
  { unfold tlambda; ins; desf.
    all: apply wf_ninEλ; auto.
    all: intros HH; apply NIN; apply lset_app; basic_solver. }
  unfold seq_κ_def. desf.
  all: exfalso; apply NIN; apply lset_app; red; auto.
Qed.

End Internal.

End SeqBuilder.


Require Import Reals.
Require Export VST.veric.base.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.slice.
Require Import VST.veric.res_predicates.

(* This file contains lemmas regarding "superprecise",
and in principle, almost proving that "mapsto" is superprecise.

However, mapsto is not superprecise, because it's not quite true
that decode_val is injective.  The only reason is the treatment
of single-precision floating-point NaNs, where the conversion
from single-prec to double-prec loses one bit of information:
both quiet 32-bit NaNs and signalling 32-bit NaNs are quietly turned into
quite 64-bit NaNs.

If CompCert ever changes so that this does not happen, then
the lemmas in this file might become useful.

*)

Lemma int_of_bytes_uniq:
  forall i j, length i = length j -> int_of_bytes i = int_of_bytes j -> i = j.
Proof.
  induction i; intros.
 destruct j; inv H. auto.
 destruct j; inv H.
 specialize (IHi _ H2).
 simpl in H0.
do 2 rewrite (Z.add_comm (Byte.unsigned _)) in H0.
 remember (int_of_bytes j * 256 + Byte.unsigned i0) as v eqn:?H.
 symmetry in H0.
 rename i0 into b.
 pose proof (Zmod_unique _ _ _ _ H (Byte.unsigned_range _)).
 pose proof (Zmod_unique _ _ _ _ H0 (Byte.unsigned_range _)).
 assert (Byte.repr (Byte.unsigned a) = Byte.repr (Byte.unsigned b)) by congruence.
 repeat rewrite Byte.repr_unsigned in H4.
 subst b.
 f_equal. clear H1.
 apply IHi.
 omega.
Qed.

Lemma decode_int_uniq:
  forall i j, length i = length j -> decode_int i = decode_int j -> i=j.
Proof.
 unfold decode_int, rev_if_be.
 destruct Archi.big_endian.
 intros. rewrite <- (rev_involutive i). rewrite <- (rev_involutive j).
 f_equal.
 assert (length (rev i) = length (rev j)).
 repeat rewrite rev_length; auto.
 eapply int_of_bytes_uniq; eauto.
 apply int_of_bytes_uniq.
Qed.

Lemma decode_int_range:
  forall l N, N = two_p (8 * Z.of_nat (length l)) -> 0 <= decode_int l < N.
Proof.
intros; subst; revert l.
unfold decode_int.
assert (forall l, 0 <= int_of_bytes l < two_p (8 * Z.of_nat (length l))).
2: intros; rewrite <- rev_if_be_length; auto.
induction l.
simpl; omega.
simpl int_of_bytes. simpl length.
rewrite Nat2Z.inj_succ.
unfold Z.succ.
rewrite Z.mul_add_distr_l.
rewrite two_p_is_exp; try omega.
change (two_p (8*1)) with 256.
pose proof (Byte.unsigned_range a).
change Byte.modulus with 256 in H.
omega.
Qed.

Lemma sign_ext_injective:
 forall n i j,
    0 < n < Int.zwordsize ->
    0 <= i < two_p n ->
    0 <= j < two_p n ->
    Int.sign_ext n (Int.repr i) = Int.sign_ext n (Int.repr j) ->
    i=j.
Proof.
intros.
pose proof (Int.eqmod_sign_ext n (Int.repr i) H).
pose proof (Int.eqmod_sign_ext n (Int.repr j) H).
rewrite H2 in H3.
apply Int.eqmod_sym in H3.
pose proof (Int.eqmod_trans _ _ _ _ H3 H4).
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
apply Int.eqmod_small_eq in H5; auto.
Qed.

Lemma zero_ext_injective:
 forall n i j,
    0 <= n < Int.zwordsize ->
    0 <= i < two_p n ->
    0 <= j < two_p n ->
    Int.zero_ext n (Int.repr i) = Int.zero_ext n (Int.repr j) ->
    i=j.
Proof.
intros.
pose proof (Int.eqmod_zero_ext n (Int.repr i) H).
pose proof (Int.eqmod_zero_ext n (Int.repr j) H).
rewrite H2 in H3.
apply Int.eqmod_sym in H3.
pose proof (Int.eqmod_trans _ _ _ _ H3 H4).
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
apply Int.eqmod_small_eq in H5; auto.
Qed.

Lemma repr_decode_int_inj:
  forall l1 l2, length l1 = 4%nat -> length l2 = 4%nat ->
    Int.repr (decode_int l1) = Int.repr (decode_int l2) ->
    l1=l2.
Proof.
intros.
apply decode_int_uniq; [congruence | ].
rewrite <- (Int.unsigned_repr (decode_int l1)).
Focus 2.
pose proof (decode_int_range l1 _ (eq_refl _)).
rewrite H in H2.
change (two_p (8 * Z.of_nat 4)) with (Int.max_unsigned + 1) in H2.
omega.
rewrite <- (Int.unsigned_repr (decode_int l2)).
Focus 2.
pose proof (decode_int_range l2 _ (eq_refl _)).
rewrite H0 in H2.
change (two_p (8 * Z.of_nat 4)) with (Int.max_unsigned + 1) in H2.
omega.
congruence.
Qed.

Lemma repr_decode_int64_inj:
  forall l1 l2, length l1 = 8%nat -> length l2 = 8%nat ->
    Int64.repr (decode_int l1) = Int64.repr (decode_int l2) ->
    l1=l2.
Proof.
intros.
apply decode_int_uniq; [congruence | ].
rewrite <- (Int64.unsigned_repr (decode_int l1)).
Focus 2.
pose proof (decode_int_range l1 _ (eq_refl _)).
rewrite H in H2.
change (two_p (8 * Z.of_nat 8)) with (Int64.max_unsigned + 1) in H2.
omega.
rewrite <- (Int64.unsigned_repr (decode_int l2)).
Focus 2.
pose proof (decode_int_range l2 _ (eq_refl _)).
rewrite H0 in H2.
change (two_p (8 * Z.of_nat 8)) with (Int64.max_unsigned + 1) in H2.
omega.
congruence.
Qed.

Transparent Float.of_bits.
Transparent Float32.of_bits.

Lemma double_of_bits_inj:
  forall i j, Float.of_bits i = Float.of_bits j -> i=j.
Proof.
intros.
unfold Float.of_bits in H.
rewrite <- (Int64.repr_unsigned i).
rewrite <- (Int64.repr_unsigned j).
f_equal.
unfold Fappli_IEEE_bits.b64_of_bits in H.
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _) (Int64.unsigned i))
  by (apply Int64.unsigned_range).
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _) (Int64.unsigned j))
  by (apply Int64.unsigned_range).
f_equal; apply H.
Qed.

Require Import ZArith.
From compcert Require Import Fappli_IEEE Fcore_Zaux Fcore_generic_fmt.

Lemma binary_normalize_inj:
  forall s1 m1 e1 (h1 : bounded 24 128 m1 e1 = true),
  forall s2 m2 e2 (h2 : bounded 24 128 m2 e2 = true),
   binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s1 (Zpos m1)) e1 s1 =
   binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s2 (Zpos m2)) e2 s2 ->
  B754_finite 24 128 s1 m1 e1 h1 = B754_finite 24 128 s2 m2 e2 h2.
Proof.
intros s1 m1 e1 h1 s2 m2 e2 h2 Hn.
apply B2R_inj ; try easy.
assert (H: forall s m e h,
  B2R 24 128 (B754_finite 24 128 s m e h) =
  B2R 53 1024 (binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s)).
2: now rewrite 2!H, Hn.
clear.
intros s m e h.
generalize (binary_normalize_correct 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s).
rewrite round_generic ; auto with typeclass_instances.
rewrite  Fcore_Raux.Rlt_bool_true.
intros [-> _].
easy.
apply Raxioms.Rlt_trans with (1 := abs_B2R_lt_emax _ _ (B754_finite 24 128 s m e h)).
now apply Fcore_Raux.bpow_lt.
apply Fcore_FLT.generic_format_FLT.
assert (h' := generic_format_B2R 24 128 (B754_finite 24 128 s m e h)).
apply Fcore_FLT.FLT_format_generic in h'.
destruct h' as [f [H1 [H2 H3]]].
exists f.
rewrite <- H1.
repeat split.
apply Zlt_trans with (1 := H2).
now apply Zpower_lt.
now apply Zle_trans with (2 := H3).
easy.
Qed.

Lemma binary_normalize_finite:
  forall b m e,
  bounded (23 + 1) (2 ^ (8 - 1)) m e = true ->
 match
     binary_normalize 53 1024 eq_refl eq_refl mode_NE
          (cond_Zopp b (Z.pos m)) e b
 with B754_finite _ _ _ _ => True | _ => False
 end.
Proof.
intros s m e h.
generalize (binary_normalize_correct 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s).
rewrite round_generic ; auto with typeclass_instances.
rewrite Fcore_Raux.Rlt_bool_true.
(****)
intros [H _].
assert (H': B2R 53 1024 (binary_normalize 53 1024 eq_refl eq_refl mode_NE (cond_Zopp s (Z.pos m)) e s) <> 0%R).
  rewrite H, <- (Fcore_float_prop.F2R_0 radix2 e).
  case s.
  now apply RIneq.Rlt_not_eq, Fcore_float_prop.F2R_lt_compat.
  now apply RIneq.Rgt_not_eq, Fcore_float_prop.F2R_lt_compat.
clear H.
destruct binary_normalize ; try easy ; now elim H'.
(****)
apply Raxioms.Rlt_trans with (1 := abs_B2R_lt_emax _ _ (B754_finite 24 128 s m e h)).
now apply Fcore_Raux.bpow_lt.
apply Fcore_FLT.generic_format_FLT.
assert (h' := generic_format_B2R 24 128 (B754_finite 24 128 s m e h)).
apply Fcore_FLT.FLT_format_generic in h'.
destruct h' as [f [H1 [H2 H3]]].
exists f.
rewrite <- H1.
repeat split.
apply Zlt_trans with (1 := H2).
now apply Zpower_lt.
now apply Zle_trans with (2 := H3).
easy.
Qed.

Lemma float32_preserves_payload:
 forall s pl,
    let '(s1,pl1) := Float.of_single_pl s pl in
      (s=s1 /\ (536870912 * (Pos.lor (proj1_sig pl) 4194304))%positive = proj1_sig pl1).
Proof.
 intros.
 unfold Float.of_single_pl.
 split; auto.
Qed.

Lemma pos_lor_inj:  (* not true *)
  forall k N (a b: nan_pl k),
     Zpower_nat 2 (Z.to_nat (k-2)) = Zpos N ->
     Pos.lor (proj1_sig a) N =  Pos.lor (proj1_sig b) N ->
    a=b.
Proof.
intros.
 destruct a as [a Ha]. destruct b as [b Hb].
 simpl in *.
 assert (a=b); [ | subst a; f_equal; apply Axioms.proof_irr].
Abort.

Inductive wishes_eq_horses := .

Lemma float32_payload_inj:
  wishes_eq_horses ->
  forall s1 pl1 s2 pl2,
    Float.of_single_pl s1 pl1= Float.of_single_pl s2 pl2 ->
    (s1,pl1) = (s2,pl2).
Proof.
intro WH; intros.
 pose proof (float32_preserves_payload s1 pl1).
 pose proof (float32_preserves_payload s2 pl2).
 rewrite H in H0. clear H.
 destruct (Float.of_single_pl s2 pl2).
 destruct H0,H1. subst.
 f_equal.
 rewrite <- H2 in H0; clear - WH H0.
 apply Pos.mul_reg_l in H0.
 contradiction WH.
Qed.

Lemma single_of_bits_inj:
  forall i j : Int.int, Float32.of_bits i = Float32.of_bits j -> i=j.
Proof.
intros.
unfold Float32.of_bits in H.
rewrite <- (Int.repr_unsigned i).
rewrite <- (Int.repr_unsigned j).
f_equal.
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _) (Int.unsigned i))
  by (apply Int.unsigned_range).
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _) (Int.unsigned j))
  by (apply Int.unsigned_range).
f_equal.
unfold Fappli_IEEE_bits.b32_of_bits in H.
match goal with |- ?A = ?B => remember A as u eqn:H9; remember B as v eqn:H10;
   clear H9 H10 end.
clear i j.

destruct u,v; auto; try congruence.
Qed.

Lemma Vint_inj: forall i j, Vint i = Vint j -> i=j.
Proof. congruence. Qed.

Lemma decode_val_uniq:
   (* Just not true any more, with Fragments *)
  forall ch b1 b2 v,
    v <> Vundef ->
    length b1 = size_chunk_nat ch ->
    length b2 = size_chunk_nat ch ->
    decode_val ch b1 = v ->
    decode_val ch b2 = v ->
    b1=b2.
Proof.
 intros.
 unfold size_chunk_nat in *.
 unfold decode_val in *.
 destruct (proj_bytes b1) eqn:B1.
subst v.
(*
unfold proj_pointer in H3.
destruct b1; try congruence.
destruct m; try congruence.
if_tac in H3; try congruence.
clear - H2 H3 H.
subst v.
unfold proj_pointer in *.
destruct b1; try congruence.
destruct m; try congruence.
destruct b2; try congruence. destruct m; try congruence.
destruct (check_pointer 4 b i (Pointer b i n :: b1)) eqn:?; try congruence.
destruct (check_pointer 4 b0 i0 (Pointer b0 i0 n0 :: b2)) eqn:?; try congruence.
inv H3.
clear H.
unfold check_pointer in *; simpl in *.
repeat match goal with
| H: ?A = true |- _ =>
  match A with
  | context [eq_block ?a ?b]  =>
     destruct (eq_block a b); simpl in *; try congruence
  | context [Int.eq_dec ?i ?j] =>
     destruct (Int.eq_dec i j); simpl in *; try congruence
  | context [match ?n with _ => _ end] =>
     destruct n; simpl in *; try congruence
  end
end.
} Unfocus.
destruct (proj_bytes b2) eqn:B2.
Focus 2. {
destruct ch; try congruence.
unfold proj_pointer in H3.
destruct b2; try congruence.
destruct m; try congruence.
if_tac in H3; try congruence.
} Unfocus.
pose proof (length_proj_bytes _ _ B1).
pose proof (length_proj_bytes _ _ B2).
rewrite <- H4 in *; rewrite <- H5 in *.
assert (l=l0).
Focus 2. {
clear - H6 B1 B2.
revert l0 b1 b2 B1 B2 H6; induction l; destruct l0; intros; inv H6.
destruct b1; inv B1. destruct b2; inv B2; auto.
destruct m; try congruence.
destruct (proj_bytes b2);  inv H0.
destruct m; inv H0.
destruct (proj_bytes b1);  inv H1.
destruct b1; inv B1.
destruct m; inv H0.
destruct (proj_bytes b1) eqn:?; inv H1.
destruct b2; inv B2.
destruct m; inv H0.
destruct (proj_bytes b2) eqn:?; inv H1.
specialize (IHl _ _ _ Heqo Heqo0).
f_equal; auto.
} Unfocus.
clear b1 b2 H4 H5 B1 B2.
clear H.
subst v.
destruct ch; try apply Vint_inj in H3;
simpl in H0,H1; unfold Pos.to_nat in H0,H1; simpl in H0,H1;
 (* this "try" takes care of all signed and unsigned bytes and shorts *)
try (apply decode_int_uniq; [ congruence | ];
(apply sign_ext_injective in H3 || apply zero_ext_injective in H3);
 [ congruence |  compute; split; congruence
 | apply decode_int_range; rewrite H1; reflexivity
 | apply decode_int_range; rewrite H0; reflexivity
 ]).

* (* Mint32 *)  apply repr_decode_int_inj; auto.
* (* Mint64 *) apply repr_decode_int64_inj; congruence.
* (* Mfloat32 *)
  inv H3.
  apply decode_int_uniq; [congruence | ].
  apply single_of_bits_inj in H2.
  apply repr_decode_int_inj in H2; auto.
  congruence.
  apply WH.
* (* Mfloat64 *)
  inv H3.
  apply decode_int_uniq; [congruence | ].
  apply double_of_bits_inj in H2.
  apply repr_decode_int64_inj in H2; auto.
  congruence.
Qed.
*)
Abort.

Lemma superprecise_ewand_lem1:
  forall S P: pred rmap, superprecise P ->
          S |-- P * TT ->
          S = (P * (ewand P S))%pred.
Proof.
intros.
apply pred_ext.
intros w ?. specialize (H0 w H1).
destruct H0 as [w1 [w2 [? [? _]]]].
exists w1; exists w2; split3; auto.
exists w1; exists w; split3; auto.
intros w [w1 [w2 [? [? ?]]]].
destruct H3 as [w3 [w4 [? [? ?]]]].
assert (w1=w3). eapply H; eauto.
apply join_core2 in H1; apply join_core2 in H3; unfold comparable; congruence.
subst w3.
pose proof (join_eq H1 H3); subst w4.
auto.
Qed.

Lemma superprecise_address_mapsto:
  wishes_eq_horses ->
  forall ch v sh loc,
   v<>Vundef -> superprecise (address_mapsto ch v sh loc).
Proof.
intro WH.
intros.
hnf; intros.
unfold address_mapsto in *.
destruct H0 as [b1 [[? [? ?]] ?]]; destruct H1 as [b2 [[? [? ?]] ?]].
(* just not true anymore, with Fragments *)
(*
assert (b1=b2) by (eapply decode_val_uniq; eauto).
subst b2.
assert (level w1 = level w2).
clear - H2; unfold comparable in H2.
rewrite <- level_core. rewrite <- (level_core w2).
congruence.
apply rmap_ext.
auto.
intro.
clear - H5 H8 H9 H2.
specialize (H5 l); specialize (H8 l).
hnf in H5,H8.
if_tac in H5.
destruct H5 as [p ?]. destruct H8 as [p' ?].
hnf in H0,H1.
rewrite H0,H1.
f_equal.
f_equal.
apply proof_irr.
congruence.
do 3 red in H5, H8.
unfold comparable in H2; clear - H5 H8 H2.
assert (core (w1 @ l) = core (w2 @ l)).
repeat rewrite core_resource_at.
congruence.
clear H2.
transitivity (core (w1 @ l)).
apply unit_core.
apply  identity_unit_equiv.
auto.
rewrite H.
symmetry.
apply unit_core.
apply  identity_unit_equiv.
auto.
Qed.

Require Import VST.veric.extend_tc.
Require Import VST.veric.seplog.

Lemma superprecise_mapsto:
 wishes_eq_horses ->
  forall sh t v1 v2,
    v2 <> Vundef ->
   superprecise (mapsto sh t v1 v2).
Proof.
intro WH.
assert (WH' := superprecise_address_mapsto WH); clear WH.
intros. rename H into Hv2.
hnf; intros.
unfold mapsto in *;
simpl in H,H0.
destruct (access_mode t); try contradiction.
destruct (type_is_volatile t); try contradiction.
destruct v1; try contradiction.
destruct H as [[_ H]|[Hz [u1 H]]]; try congruence.
destruct H0 as [[_ H0]|[Hz [u2 H0]]]; try congruence.
eapply WH'; eauto.
Qed.
*)
Abort.