(** Bounded Instantiated Maps **)
Require Import Coq.Bool.Bool.
Require Import Coq.omega.Omega.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relations.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Data.Pair.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.ListFirstnSkipn.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.VariablesI.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.Instantiate.

Require Import MirrorCore.Util.Quant.
Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

(** TODO: This has to be somewhere else **)
Instance Reflexive_pointwise
         {T U} {R : U -> U -> Prop} (Refl : Reflexive R)
: Reflexive (pointwise_relation T R).
Proof.
  red. red. reflexivity.
Qed.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Context {ExprVar_expr : ExprVar expr}.
  Context {ExprVarOk_expr : ExprVarOk _}.
  Context {ExprUVar_expr : ExprUVar expr}.
  Context {ExprUVarOk_expr : ExprUVarOk _}.

  Local Instance RelDec_eq_typ : RelDec (@eq typ) :=
    RelDec_Rty _.
  Local Instance RelDecOk_eq_typ : RelDec_Correct RelDec_eq_typ :=
    @RelDec_Correct_Rty _ _ _.

  Local Existing Instance SUBST.Subst_subst.
  Local Existing Instance SUBST.SubstOk_subst.
  Local Existing Instance SUBST.SubstOpen_subst.
  Local Existing Instance SUBST.SubstOpenOk_subst.

  Definition amap : Type := SUBST.raw expr.
  Definition WellFormed_amap : amap -> Prop := @SUBST.WellFormed _ _ _ _.
  Definition amap_empty : amap := UVarMap.MAP.empty _.
  Definition amap_lookup : nat -> amap -> option expr :=
    @UVarMap.MAP.find _.
  Definition amap_check_set : nat -> expr -> amap -> option amap :=
    @SUBST.raw_set _ _ _ _.
  Definition amap_instantiate (f : nat -> option expr) : amap -> amap :=
    UVarMap.MAP.map (fun e => instantiate f 0 e).
  Definition amap_substD
  : forall (tus tvs : tenv typ), amap -> option (exprT tus tvs Prop) :=
    @SUBST.raw_substD _ _ _ _.
  Definition amap_is_full (* min : uvar *) (len : nat) (m : amap) : bool :=
    UVarMap.MAP.cardinal m ?[ eq ] len.
  Definition amap_domain (m : amap) : list uvar :=
    map fst (UVarMap.MAP.elements m).
  Fixpoint amap_aslist (m : amap) (f n : nat) : list (option expr) :=
    match n with
      | O => nil
      | S n => amap_lookup f m :: amap_aslist m (S f) n
    end.

  Definition Forall_amap (P : uvar -> expr -> Prop) (m : amap) : Prop :=
    forall u e,
      amap_lookup u m = Some e ->
      P u e.

  Lemma Forall_amap_empty
  : forall P, Forall_amap P amap_empty.
  Proof.
    clear. intros.
    red. unfold amap_lookup, amap_empty.
    intros. rewrite FMapSubst.SUBST.FACTS.empty_o in H. congruence.
  Qed.

  Definition bimap_max (maxU maxV : nat) e : Prop :=
    mentionsAny (fun u' => u' ?[ ge ] maxU)
                (fun v' => v' ?[ ge ] maxV) e = false.

  Definition WellFormed_bimap (min : nat) (len : nat) (maxV : nat) (m : amap)
  : Prop :=
    (** 'acyclic' **)
    SUBST.WellFormed m /\
    (** only in this range **)
    Forall_amap (fun k _ => min <= k < min + len) m /\
    (** no forward pointers **)
    Forall_amap (fun k e => bimap_max (min + len) maxV e) m.

  Lemma WellFormed_bimap_empty
  : forall a b c, WellFormed_bimap a b c amap_empty.
  Proof.
    clear - RTypeOk_typ Expr_expr. red.
    intros. refine (conj _ (conj _ _));
            eauto using SUBST.WellFormed_empty, Forall_amap_empty.
    eapply SUBST.WellFormed_empty.
  Qed.

  Lemma WellFormed_bimap_WellFormed_amap
  : forall a b c s,
      WellFormed_bimap a b c s ->
      WellFormed_amap s.
  Proof.
    destruct 1. assumption.
  Qed.

  Lemma amap_instantiates_substD
  : forall tus tvs C (_ : CtxLogic.ExprTApplicative C) f s sD a b c,
      WellFormed_bimap a b c s ->
      amap_substD tus tvs s = Some sD ->
      sem_preserves_if_ho C f ->
      exists sD',
        amap_substD tus tvs (amap_instantiate f s) = Some sD' /\
        C (fun us vs => sD us vs <-> sD' us vs).
  Proof.
    unfold amap_instantiate.
    intros.
    eapply SUBST.raw_substD_instantiate_ho in H2; eauto.
    forward_reason.
    eexists; split; eauto.
    revert H3.
    eapply CtxLogic.exprTAp.
    eapply CtxLogic.exprTPure.
    intros us vs.
    clear. tauto.
  Qed.

  Lemma amap_lookup_substD
  : forall (s : amap) (uv : uvar) (e : expr),
      amap_lookup uv s = Some e ->
      forall (tus tvs : list typ)
             (sD : hlist typD tus -> hlist typD tvs -> Prop),
        amap_substD tus tvs s = Some sD ->
        exists
          (t : typ) (val : exprT tus tvs (typD t))
          (get : hlist typD tus -> typD t),
          nth_error_get_hlist_nth typD tus uv =
          Some (existT (fun t0 : typ => hlist typD tus -> typD t0) t get) /\
          exprD tus tvs t e = Some val /\
          (forall (us : hlist typD tus) (vs : hlist typD tvs),
             sD us vs -> get us = val us vs).
  Proof. eapply SUBST.substD_lookup'; eauto. Qed.

  Lemma amap_substD_amap_empty
    : forall tus tvs,
      exists sD,
        amap_substD tus tvs amap_empty = Some sD /\
        forall a b, sD a b.
  Proof using.
    intros.
    eapply FMapSubst.SUBST.substD_empty.
  Qed.

  Lemma amap_domain_WellFormed
  : forall (s : amap) (ls : list uvar),
       WellFormed_amap s ->
       amap_domain s = ls ->
       forall n : nat, In n ls <-> amap_lookup n s <> None.
  Proof. eapply SUBST.WellFormed_domain. Qed.

  Lemma amap_lookup_normalized
  : forall (s : amap) (e : expr) (u : nat),
      WellFormed_amap s ->
      amap_lookup u s = Some e ->
      forall (u' : nat) (e' : expr),
        amap_lookup u' s = Some e' -> mentionsU u' e = false.
  Proof. eapply SUBST.normalized_fmapsubst. Qed.

  Lemma amap_lookup_amap_instantiate
  : forall u f m,
      amap_lookup u (amap_instantiate f m) =
      match amap_lookup u m with
        | None => None
        | Some e => Some (instantiate f 0 e)
      end.
  Proof.
    unfold amap_lookup, amap_instantiate; intros.
    apply SUBST.FACTS.map_o.
  Qed.

  Lemma syn_check_set
  : forall uv e s s',
      WellFormed_amap s ->
      amap_check_set uv e s = Some s' ->
      let e' := instantiate (fun u => amap_lookup u s) 0 e in
      WellFormed_amap s' /\
      mentionsU uv e'= false /\
      forall u,
        amap_lookup u s' =
        if uv ?[ eq ] u then Some e'
        else
          match amap_lookup u s with
            | None => None
            | Some e =>
              Some (instantiate (fun u =>
                                   if uv ?[ eq ] u then Some e'
                                   else None) 0 e)
          end.
  Proof.
    intros. unfold amap_check_set, SUBST.raw_set in *.
    forward. inv_all; subst.
    split.
    { eapply SUBST.raw_set_WellFormed; eauto.
      instantiate (1 := e). instantiate (1 := uv).
      unfold amap_check_set, SUBST.raw_set in *.
      rewrite H0. reflexivity. }
    split.
    { assumption. }
    intros.
    unfold amap_lookup.
    rewrite SUBST.FACTS.add_o.
    destruct (SUBST.PROPS.F.eq_dec uv u); subst.
    { rewrite rel_dec_eq_true; eauto with typeclass_instances. }
    { rewrite rel_dec_neq_false; eauto with typeclass_instances.
      unfold SUBST.raw_instantiate.
      rewrite SUBST.FACTS.map_o.
      destruct (UVarMap.MAP.find u s); try reflexivity. }
  Qed.

  Lemma mentionsAny_false_mentionsV
    : forall fU fV v e,
      mentionsAny fU fV e = false ->
      mentionsV v e = true ->
      fV v = false.
  Proof.
    intros. eapply mentionsAny_complete_false in H.
    destruct H.
    eauto. eauto.
  Qed.

  Lemma mentionsAny_false_mentionsU
    : forall fU fV u e,
      mentionsAny fU fV e = false ->
      mentionsU u e = true ->
      fU u = false.
  Proof.
    intros. eapply mentionsAny_complete_false in H.
    destruct H.
    eauto. eauto.
  Qed.

  Lemma WellFormed_bimap_check_set
  : forall uv e s min len maxV s',
      amap_check_set uv e s = Some s' ->
      mentionsAny (fun u' => u' ?[ ge ] (min + len))
                  (fun v' => v' ?[ ge ] maxV) e = false ->
      min <= uv < min + len ->
      WellFormed_bimap min len maxV s ->
      WellFormed_bimap min len maxV s'.
  Proof.
    intros.
    eapply syn_check_set in H; eauto.
    red in H2. red.
    { forward_reason.
      split; auto.
      split.
      { red in H3. red.
        intros.
        rewrite H7 in H8.
        consider (uv ?[ eq ] u); intros; subst.
        omega.
        forward. eapply H3; eauto. }
      { red in H4; red; intros.
        rewrite H7 in H8; clear H7.
        consider (uv ?[ eq ] u); intros; subst.
        { inv_all; subst.
          eapply mentionsAny_complete_false; [ eauto | ].
          split; intros.
          { eapply mentionsU_instantiate in H7.
            eapply mentionsAny_complete_false in H0; try eassumption.
            destruct H0.
            destruct H7.
            { eapply H0. tauto. }
            { forward_reason.
              eapply H4 in H7.
              eapply mentionsAny_complete_false in H7; try eassumption.
              destruct H7; eauto. } }
          { eapply mentionsV_instantiate_0 in H7; try eassumption.
            destruct H7.
            { eapply mentionsAny_false_mentionsV in H0; eauto. }
            { destruct H7.
              forward_reason.
              eapply H4 in H8. eapply mentionsAny_false_mentionsV in H8; eauto. } } }
        { forward.
          inv_all; subst.
          eapply mentionsAny_complete_false; try eassumption.
          split.
          { intros.
            eapply H4 in H8.
            eapply mentionsU_instantiate in H9.
            destruct H9.
            { forward_reason; forward.
              eapply mentionsAny_false_mentionsU in H8; eauto. }
            { forward_reason. forward.
              subst. inv_all; subst.
              eapply mentionsU_instantiate in H11.
              destruct H11.
              { forward_reason.
                eapply mentionsAny_false_mentionsU in H11. eapply H11.
                eapply H0. }
              { forward_reason.
                eapply mentionsAny_false_mentionsU in H12. eapply H12.
                eapply H4. eauto. } } }
          { intros.
            eapply mentionsV_instantiate_0 in H9; try eassumption.
            destruct H9.
            { eapply H4 in H8.
              eapply mentionsAny_false_mentionsV in H8; eauto. }
            { forward_reason. forward.
              inv_all; subst.
              eapply mentionsV_instantiate_0 in H11; try eassumption.
              destruct H11.
              { eapply mentionsAny_false_mentionsV in H10. eapply H10.
                eapply H0. }
              { forward_reason.
                eapply H4 in H11.
                eapply mentionsAny_false_mentionsV in H11. eapply H11. auto. } } } } } }
    { destruct H2. assumption. }
  Qed.

  Lemma Forall_amap_instantiate
  : forall (P Q : uvar -> expr -> Prop) f m,
      (forall u e, Q u e -> P u (instantiate f 0 e)) ->
      Forall_amap Q m ->
      Forall_amap P (amap_instantiate f m).
  Proof.
    clear.
    intros. red.
    unfold amap_lookup, amap_instantiate, amap_lookup. intros u e.
    rewrite SUBST.FACTS.map_o.
    consider (UVarMap.MAP.find u m); simpl; intros; try congruence.
    inv_all. eapply H0 in H1. subst; eauto.
  Qed.

  Lemma WellFormed_bimap_instantiate
  : forall s f min len maxV s',
      amap_instantiate f s = s' ->
      (forall u e,
         f u = Some e ->
         mentionsAny (fun u' => u' ?[ ge ] min)
                     (fun v' => v' ?[ ge ] maxV) e = false) ->
      WellFormed_bimap min len maxV s ->
      WellFormed_bimap min len maxV s'.
  Proof.
    red; intros; subst.
    red in H1. forward_reason.
    split.
    { red. intros.
      rewrite SUBST.PROPS.F.find_mapsto_iff in H3.
      unfold amap_instantiate in *.
      rewrite SUBST.FACTS.map_o in H3.
      red. intros.
      consider (UVarMap.MAP.find k s); simpl in *; try congruence.
      intros. inv_all; subst.
      eapply SUBST.PROPS.F.not_find_in_iff.
      rewrite SUBST.FACTS.map_o.
      consider (UVarMap.MAP.find u s); try reflexivity.
      intros. exfalso.
      eapply mentionsU_instantiate in H4.
      destruct H4.
      { destruct H4.
        eapply H. 2: eassumption.
        eapply SUBST.PROPS.F.find_mapsto_iff. eassumption.
        red. eexists.
        eapply SUBST.PROPS.F.find_mapsto_iff. eassumption. }
      { forward_reason.
        specialize (H0 _ _ H4).
        eapply mentionsAny_false_mentionsU in H0; [ | eassumption ].
        eapply H1 in H5. consider (u ?[ ge ] min).
        { congruence. }
        { intros. omega. } } }
    split.
    { revert H1. eapply Forall_amap_instantiate. trivial. }
    { revert H2. eapply Forall_amap_instantiate; intros.
      unfold bimap_max in *.
      eapply mentionsAny_complete_false; [ eauto | ].
      eapply mentionsAny_complete_false in H2; [ | eauto ].
      forward_reason; split.
      { intros.
        eapply mentionsU_instantiate in H4.
        destruct H4; forward_reason.
        { eauto. }
        { eapply H0 in H4.
          eapply mentionsAny_false_mentionsU in H4. 2: eassumption.
          clear - H4.
          consider (u0 ?[ ge ] (min + len)); auto.
          intros. rewrite rel_dec_eq_true in H4; eauto with typeclass_instances.
          omega. } }
      { intros.
        eapply mentionsV_instantiate_0 in H4; try eassumption.
        destruct H4.
        eauto.
        forward_reason. eapply H0 in H5.
        eapply mentionsAny_false_mentionsV in H5. 2: eauto. eauto. } }
  Qed.

  Definition nothing_in_range a b m : Prop :=
    forall u, u < b -> amap_lookup (a + u) m = None.
  Definition only_in_range min len m :=
    Forall_amap (fun k _ => min <= k < min + len) m.

  Lemma only_in_range_0_empty
  : forall a am,
      only_in_range a 0 am ->
      UVarMap.MAP.Equal am amap_empty.
  Proof.
    clear. unfold Forall_amap. red.
    intros.
    specialize (H y). unfold amap_lookup in *.
    rewrite SUBST.FACTS.empty_o.
    destruct (UVarMap.MAP.find y am); auto.
    exfalso. specialize (H _ eq_refl). omega.
  Qed.

  Lemma Forall_amap_Proper
  : Proper (pointwise_relation _ (pointwise_relation _ iff) ==> UVarMap.MAP.Equal ==> iff)
           Forall_amap.
  Proof.
    do 3 red; intros.
    split; intros; red; intros;
    eapply SUBST.FACTS.find_mapsto_iff in H2;
    eapply SUBST.FACTS.Equal_mapsto_iff in H0; eauto.
    - eapply H0 in H2.
      eapply H1 in H2.
      eapply H; eauto.
    - eapply H0 in H2.
      eapply H1 in H2.
      eapply H; eauto.
  Qed.

  Lemma only_in_range_0_WellFormed_pre_entry
  : forall a am mV,
      only_in_range a 0 am ->
      WellFormed_bimap a 0 mV am.
  Proof.
    clear. unfold WellFormed_bimap.
    intros. eapply only_in_range_0_empty in H.
    split.
    - red. intros.
      eapply SUBST.FACTS.Equal_mapsto_iff in H.
      eapply H in H0. clear - H0.
      eapply SUBST.FACTS.empty_mapsto_iff in H0.
      destruct H0.
    - split.
      + eapply Forall_amap_Proper; eauto.
        eapply Reflexive_pointwise.
        eapply Reflexive_pointwise. eauto with typeclass_instances.
        eapply Forall_amap_empty.
      + eapply Forall_amap_Proper; eauto.
        eapply Reflexive_pointwise.
        eapply Reflexive_pointwise. eauto with typeclass_instances.
        eapply Forall_amap_empty.
  Qed.

  (** Start pigeonhole stuff **)
  Lemma cardinal_remove
  : forall m x y,
      amap_lookup x m = Some y ->
      UVarMap.MAP.cardinal m = S (UVarMap.MAP.cardinal (UVarMap.MAP.remove x m)).
  Proof.
    clear. intros.
    do 2 rewrite SUBST.PROPS.cardinal_fold.
    assert (UVarMap.MAP.Equal m (UVarMap.MAP.add x y (UVarMap.MAP.remove x m))).
    { red. intros.
      rewrite SUBST.PROPS.F.add_o.
      rewrite SUBST.PROPS.F.remove_o.
      destruct (SUBST.PROPS.F.eq_dec x y0). subst; auto.
      auto. }
    etransitivity.
    (rewrite SUBST.PROPS.fold_Equal with (eqA := @eq nat); try eassumption); eauto.
    compute; intros; subst; auto.
    compute; intros; subst; auto.
    rewrite <- plus_n_O.
    rewrite SUBST.PROPS.fold_add. reflexivity.
    eauto.
    compute; intros; subst; auto.
    compute; intros; subst; auto.
    eapply UVarMap.MAP.remove_1. reflexivity.
  Qed.

  Lemma cardinal_not_remove
  : forall m x,
      amap_lookup x m = None ->
      UVarMap.MAP.cardinal m = UVarMap.MAP.cardinal (UVarMap.MAP.remove x m).
  Proof.
    clear. intros.
    assert (UVarMap.MAP.Equal m (UVarMap.MAP.remove x m)).
    { red. intros.
      rewrite SUBST.PROPS.F.remove_o.
      destruct (SUBST.PROPS.F.eq_dec x y). subst; auto.
      auto. }
    rewrite <- H0. reflexivity.
  Qed.

  Lemma subst_pull_sound
  : forall b a m m',
      subst_pull a b m = Some m' ->
      nothing_in_range a b m' /\
      UVarMap.MAP.cardinal m' = UVarMap.MAP.cardinal m - b /\
      (forall u, u < a \/ u >= a + b -> amap_lookup u m = amap_lookup u m') /\
      (forall u, u < b -> amap_lookup (a + u) m <> None).
  Proof.
    clear.
    induction b.
    { simpl. intros. inv_all; subst.
      split.
      { red. intros; exfalso; omega. }
      split.
      { omega. }
      split.
      { auto. }
      { intros. exfalso; omega. } }
    { simpl. unfold SUBST.raw_drop.
      intros. forwardy.
      eapply IHb in H. forward_reason.
      inv_all. subst.
      split.
      { red. intros.
        unfold amap_lookup. rewrite SUBST.PROPS.F.remove_o.
        destruct (SUBST.PROPS.F.eq_dec a (a + u)); auto.
        destruct u.
        { exfalso; omega. }
        { replace (a + S u) with (S a + u) by omega.
          red in H. eapply H. omega. } }
      split.
      { replace (UVarMap.MAP.cardinal m - S b) with
        ((UVarMap.MAP.cardinal m - b) - 1) by omega.
        rewrite <- H2. clear - H0.
        rewrite (@cardinal_remove _ _ _ H0). omega. }
      split.
      { intros.
        destruct H1.
        + rewrite H3; [ | left; eauto ].
          unfold amap_lookup.
          rewrite SUBST.PROPS.F.remove_neq_o; auto.
        + rewrite H3; [ | right; omega ].
          unfold amap_lookup.
          rewrite SUBST.PROPS.F.remove_neq_o; auto.
          omega. }
      { intros.
        destruct u.
        { rewrite H3; [ | left; omega ].
          replace (a + 0) with a. change_rewrite H0. congruence.
          clear. apply plus_n_O. }
        { replace (a + S u) with (S a + u) by omega.
          apply H4. omega. } } }
  Qed.

  Lemma subst_pull_complete
  : forall b a m,
      (forall u, u < b -> amap_lookup (a + u) m <> None) ->
      exists m',
        subst_pull a b m = Some m'.
  Proof.
    clear. induction b; simpl; intros; eauto.
    { destruct (IHb (S a) m); clear IHb.
      { intros. replace (S a + u) with (a + S u) by omega.
        eapply H. omega. }
      { rewrite H0.
        eapply subst_pull_sound in H0.
        forward_reason. unfold SUBST.raw_drop.
        rewrite <- H2 by (left; omega).
        specialize (H 0).
        replace (a + 0) with a in H by omega.
        destruct (amap_lookup a m); eauto.
        exfalso. eapply H; auto. omega. } }
  Qed.

  Fixpoint test_range from len m :=
    match len with
      | 0 => true
      | S len =>
        match amap_lookup from m with
          | None => false
          | Some _ => test_range (S from) len (UVarMap.MAP.remove from m)
        end
    end.

  Lemma test_range_true_all
  : forall l f m,
      test_range f l m = true ->
      forall u, u < l -> amap_lookup (f + u) m <> None.
  Proof.
    clear. induction l.
    { intros; exfalso; omega. }
    { simpl; intros; forward.
      specialize (IHl _ _ H1).
      destruct u.
      { replace (f + 0) with f by omega. congruence. }
      { replace (f + S u) with (S f + u) by omega.
        cutrewrite (amap_lookup (S f + u) m =
                    amap_lookup (S f + u) (UVarMap.MAP.remove f m)).
        { apply IHl. omega. }
        unfold amap_lookup.
        rewrite SUBST.PROPS.F.remove_neq_o; auto. omega. } }
  Qed.

  Lemma cardinal_le_range
  : forall len min m,
      only_in_range min len m ->
      UVarMap.MAP.cardinal m <= len.
  Proof.
    clear.
    induction len.
    { intros.
      eapply only_in_range_0_empty in H.
      cut (UVarMap.MAP.cardinal m = 0); try omega.
      apply SUBST.PROPS.cardinal_1.
      rewrite H.
      apply UVarMap.MAP.empty_1. }
    { intros.
      assert (only_in_range min len (UVarMap.MAP.remove (min + len) m)).
      { red. red in H. red. intros.
        unfold amap_lookup in H0.
        rewrite SUBST.PROPS.F.remove_o in H0.
        destruct (SUBST.PROPS.F.eq_dec (min + len) u); try congruence.
        eapply H in H0. omega. }
      { eapply IHlen in H0.
        consider (UVarMap.MAP.find (min + len) m); intros.
        { erewrite cardinal_remove; eauto.
          omega. }
        { erewrite cardinal_not_remove; eauto. } } }
  Qed.

  Lemma subst_getInstantiation
  : forall tus tvs ts m maxV P,
      WellFormed_bimap (length tus) (length ts) maxV m ->
      amap_substD (tus ++ ts) tvs m = Some P ->
      amap_is_full (length ts) m = true ->
      exists x : hlist (fun t => exprT tus tvs (typD t)) ts,
        forall us vs,
          let us' :=
              hlist_map (fun t (x : exprT tus tvs (typD t)) => x us vs) x
          in
          P (HList.hlist_app us us') vs.
  Proof.
    intros.
    assert (exists m',
              subst_pull (length tus) (length ts) m = Some m' /\
              UVarMap.MAP.Empty m').
    { unfold amap_is_full in H1.
      consider (UVarMap.MAP.cardinal m ?[ eq ] length ts); intros.
      assert (only_in_range (length tus) (length ts) m).
      { clear - H. red in H. red; intros.
        tauto. }
      clear - H1 H2.
      destruct (@subst_pull_complete (length ts) (length tus) m).
      { eapply test_range_true_all.
        generalize dependent (length tus).
        generalize dependent m.
        induction (length ts); intros.
        { reflexivity. }
        { simpl.
          consider (amap_lookup n0 m).
          { intros.
            eapply IHn.
            - erewrite cardinal_remove in H1; eauto.
            - red. intros. red. intros.
              unfold amap_lookup in H0.
              rewrite SUBST.PROPS.F.remove_o in H0.
              destruct (SUBST.PROPS.F.eq_dec n0 u); try congruence.
              eapply H2 in H0. omega. }
          { intros. exfalso.
            assert (only_in_range (S n0) n m).
            { red. red; intros. red in H2.
              consider (n0 ?[ eq ] u); intros; subst; try congruence.
              eapply H2 in H0. omega. }
            eapply cardinal_le_range in H0. omega. } }  }
      rewrite H. eexists; split; eauto.
      eapply subst_pull_sound in H.
      assert (only_in_range (length tus) 0 x).
      { forward_reason.
        red. red. intros.
        exfalso.
        assert ((u < length tus \/ u >= length tus + length ts) \/
                (exists u', u' < length ts /\ u = length tus + u')).
        { consider (u ?[ lt ] length tus); try auto; intros.
          consider (u ?[ ge ] (length tus + length ts)); try auto; intros.
          right. exists (u - length tus). split; try omega. }
        destruct H6.
        { rewrite <- H3 in H5; eauto.
          eapply H2 in H5. omega. }
        { forward_reason. subst.
          red in H.
          rewrite H in H5. congruence. auto. } }
      { eapply  only_in_range_0_empty in H0.
        rewrite H0.
        eapply UVarMap.MAP.empty_1. } }
    { forward_reason.
      eapply pull_sound in H2; eauto using SUBST.SubstOpenOk_subst.
      { forward_reason.
        specialize (@H4 tus ts tvs _ eq_refl eq_refl H0).
        forward_reason.
        exists x2. simpl. intros.
        eapply H9.
        assert (UVarMap.MAP.Equal x (UVarMap.MAP.empty expr)).
        { red. red in H3. intros.
          rewrite SUBST.FACTS.empty_o.
          eapply SUBST.FACTS.not_find_in_iff.
          red. intro. destruct H10. eapply H3.
          eauto. }
        generalize (@SUBST.raw_substD_Equal typ _ _ _ tus tvs x (UVarMap.MAP.empty _) _ H7 H10).
        destruct (SUBST.substD_empty tus tvs).
        intros.
        forward_reason.
        eapply H13; clear H13.
        change_rewrite H12 in H11. inv_all; subst. eauto. }
      { eapply WellFormed_bimap_WellFormed_amap; eauto. } }
  Qed.

  Lemma only_in_range_empty : forall a b,
      only_in_range a b amap_empty.
  Proof.
    clear. red. intros.
    eapply Forall_amap_empty.
  Qed.

  Lemma WellFormed_amap_amap_empty : WellFormed_amap amap_empty.
  Proof. red. eapply FMapSubst.SUBST.WellFormed_empty. Qed.

  Lemma list_substD_app
  : forall tus tvs l2 l1 from sD,
      FMapSubst.SUBST.list_substD tus tvs from (l1 ++ l2) = Some sD ->
      exists s1D s2D,
        FMapSubst.SUBST.list_substD tus tvs from l1 = Some s1D /\
        FMapSubst.SUBST.list_substD tus tvs (from + length l1) l2 = Some s2D /\
        forall us vs,
          sD us vs <-> (s1D us vs /\ s2D us vs).
  Proof.
    induction l1; simpl; intros.
    { rewrite <- plus_n_O.
      do 2 eexists; split; eauto. split; eauto.
      intuition. }
    { destruct a; forward; inv_all.
      { eapply IHl1 in H2; forward_reason.
        Cases.rewrite_all_goal.
        do 2 eexists; split; eauto.
        simpl. split.
        rewrite <- Plus.plus_Snm_nSm. eassumption.
        subst; intros. rewrite H5. intuition. }
      { eapply IHl1 in H; forward_reason.
        rewrite <- Plus.plus_Snm_nSm.
        eauto. } }
  Qed.

  Lemma amap_substD_list_substD
  : forall tus tvs am (from len : nat) sD maxV,
      WellFormed_bimap from len maxV am ->
      amap_substD tus tvs am = Some sD ->
      exists sD',
        FMapSubst.SUBST.list_substD tus tvs from (amap_aslist am from len) = Some sD' /\
        forall us vs,
          sD us vs <-> sD' us vs.
  Proof.
    destruct 1.
    intros; eapply FMapSubst.SUBST.amap_substD_list_substD; eauto.
    destruct H0. eauto.
  Qed.

  Lemma amap_aslist_app
    : forall a y x z,
      amap_aslist a x (y + z) =
      amap_aslist a x y ++ amap_aslist a (x + y) z.
  Proof.
    induction y; simpl.
    { intros. f_equal. omega. }
    { intros. f_equal. rewrite IHy. f_equal. f_equal. omega. }
  Qed.

  Lemma amap_aslist_nth_error
    : forall ln st (mp : amap) n,
      nth_error (amap_aslist mp st ln) n =
      if n ?[ lt ] ln then Some (amap_lookup (st + n) mp) else None.
  Proof.
    clear.
    induction ln; simpl; intros; destruct n; auto.
    - simpl. unfold value. f_equal. f_equal. omega.
    - simpl nth_error. rewrite IHln.
      consider (n ?[ lt ] ln);
        consider (S n ?[ lt ] S ln);
        auto; try solve [ intros; exfalso; omega ].
      intros.
      f_equal. f_equal. omega.
  Qed.

  Lemma pigeon_principle'
  : forall n (m : amap) low,
      UVarMap.MAP.cardinal m > n ->
      Forall_amap (fun k _ => low <= k < low + n) m ->
      False.
  Proof using.
    induction n.
    { simpl. intros.
      assert (exists x, UVarMap.MAP.cardinal m = S x).
      { destruct (UVarMap.MAP.cardinal m); eauto.
        exfalso; omega. }
      destruct H1.
      eapply FMapSubst.SUBST.PROPS.cardinal_inv_2 in H1.
      destruct H1.
      eapply FMapSubst.SUBST.FACTS.find_mapsto_iff in m0.
      eapply H0 in m0.
      omega. }
    { intros.
      consider (UVarMap.MAP.find low m).
      { intros.
        specialize (IHn (UVarMap.MAP.remove low m) (S low)).
        apply IHn; clear IHn.
        { erewrite cardinal_remove in H; [ | eassumption ].
          eapply gt_S_n in H. assumption. }
        { red. red in H0.
          intros.
          unfold amap_lookup in *.
          rewrite FMapSubst.SUBST.PROPS.F.remove_o in H2.
          destruct (UVarMap.MAP.E.eq_dec low u); try congruence.
          eapply H0 in H2. omega. } }
      { intros.
        eapply IHn with (m:=m) (low :=S low).
        { omega. }
        { clear - H0 H1.
          unfold Forall_amap in *.
          intros.
          assert (u <> low).
          { unfold amap_lookup in H.
            intro. subst.
            rewrite H1 in H. congruence. }
          { eapply H0 in H.
            omega. } } } }
  Qed.

  Lemma pigeon_principle
  : forall (m : amap) n low,
      amap_is_full n m = true ->
      Forall_amap (fun k _ => low <= k < low + n) m ->
      forall k, k < n ->
                amap_lookup (low + k) m <> None.
  Proof using.
    unfold amap_is_full.
    intros m n low H.
    rewrite rel_dec_correct in H.
    red; intros. revert H2. revert H0. revert H.
    revert low. revert m. generalize dependent n. induction k.
    { intros.
      destruct n; try omega.
      eapply pigeon_principle' with (m:=m) (n:=n) (low:=S low).
      { omega. }
      { red. intros.
        assert (low <> u).
        { intro. subst. replace (u + 0) with u in H2 by omega. congruence. }
        eapply H0 in H3. omega. } }
    { intros.
      destruct n; try omega.
      eapply lt_S_n in H1.
      consider (amap_lookup low m).
      { intros.
        unfold amap_lookup in *.
        eapply (IHk _ H1 (UVarMap.MAP.remove low m) (S low)).
        { erewrite cardinal_remove in H by eassumption.
          omega. }
        { clear - H0.
          unfold Forall_amap in *. intros.
          unfold amap_lookup in H.
          rewrite FMapSubst.SUBST.FACTS.remove_o in H.
          destruct (UVarMap.MAP.E.eq_dec low u); try congruence.
          eapply H0 in H. omega. }
        { rewrite FMapSubst.SUBST.FACTS.remove_o.
          destruct (UVarMap.MAP.E.eq_dec low (S low + k)); auto.
          rewrite <- H2. f_equal. omega. } }
      { intros.
        apply (@pigeon_principle' n m (S low)).
        { omega. }
        { unfold Forall_amap in *; intros.
          assert (u <> low) by congruence.
          eapply H0 in H4.
          omega. } } }
  Qed.

End parameterized.


Require Import CSet Util Filter Take MoreList OUnion AllInRel MapDefined MapUpdate Position.
Require Import IL Annotation LabelsDefined.
Require Import Liveness.Liveness TrueLiveness SimI.
Require Import RenamedApart.
Require Import SpillSound ReconstrLive DoSpill.
Require Import SlotLiftArgs SlotLiftParams.
Require Export SpillMovesAgree.

Set Implicit Arguments.
Unset Printing Records.

Fixpoint extend_list X (L:list X) (Z:params) (RM : ⦃var⦄ * ⦃var⦄)
  : list X
  :=
    match L, Z with
    | l::L, z::Z => if [z ∈ fst RM ∩ snd RM]
             then l::l::extend_list L Z RM
             else l::extend_list L Z RM
    | _, _ => nil
    end.

(** * SpillSim *)

Lemma extend_list_length X (L:list X) (RM : ⦃var⦄ * ⦃var⦄) (Z : params)
      (NoDup:NoDupA eq Z) (Len:❬L❭ = ❬Z❭)
  : ❬extend_list L Z RM❭ = ❬Z❭ + cardinal (of_list Z ∩ (fst RM ∩ snd RM)).
Proof.
  general induction Len; simpl; eauto.
  inv NoDup.
  repeat cases; simpl; rewrite IHLen; eauto.
  - rewrite cap_special_in; eauto.
    rewrite add_cardinal_2; eauto. cset_tac.
  - rewrite cap_special_notin; eauto.
Qed.

Lemma slot_lift_params_extend_list_length X slot RM Z (L:list X)
      (Len:❬Z❭ = ❬L❭)
  : ❬slot_lift_params slot RM Z❭ = ❬extend_list L Z RM❭.
Proof.
  general induction Len; simpl; eauto.
  repeat cases; eauto; simpl; eauto.
Qed.

Lemma omap_slotlift (slot : var -> var) (V V'':onv val) Yv (xl Z:params) (Len:❬xl❭=❬Z❭) RM RMapp
      (Agr4 : agree_on eq (fst RMapp) V V'')
      (Agr5 : agree_on eq (snd RMapp) V (fun x : var => V'' (slot x)))
      (FVincl: of_list xl [<=] fst RMapp ∪ snd RMapp)
  : omap (op_eval V) (Var ⊝ xl) = Some Yv
    -> omap (op_eval V'') (slot_lift_args slot RM RMapp (Var ⊝ xl) Z)
      = Some (extend_list Yv Z RM).
Proof.
  intros.
  general induction Len; simpl in *; eauto;
    monad_inv H; simpl in *. unfold choose_y.
  cases; simpl.
  - assert (y ∈ fst RM /\ y ∈ snd RM) by (revert COND; clear_all; cset_tac).
    destruct H. repeat (cases; simpl).
    + rewrite <- Agr4; eauto. rewrite EQ. simpl.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
    + rewrite <- Agr5; eauto.
      * rewrite EQ; eauto; simpl.
        erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
      * revert FVincl NOTCOND. clear_all. cset_tac.
  - assert ((y ∈ fst RM -> y ∈ snd RM -> False))
      by (revert NOTCOND; clear_all; cset_tac).
    unfold choose_y; repeat cases; simpl; eauto.
    + rewrite <- Agr4; [ rewrite EQ | ]; simpl; eauto.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
    + rewrite <- Agr5; [ rewrite EQ | eauto]; simpl.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
      cset_tac.
    + rewrite <- Agr4; [ rewrite EQ | ]; simpl; eauto.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
    + rewrite <- Agr5; [ rewrite EQ | eauto]; simpl.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
      cset_tac.
    + rewrite <- Agr5; [ rewrite EQ | eauto]; simpl.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
    + rewrite <- Agr4; [ rewrite EQ | ]; simpl; eauto.
      erewrite IHLen; eauto; [ | rewrite <- FVincl; eauto with cset ]; eauto.
      cset_tac.
Qed.

Lemma update_with_list_lookup_in_list_first_slot (slot:var->var)
      A (E:onv A) n (R M:set var)
      Z (Y:list A) z
: length Z = length Y
  -> get Z n z
  -> z ∈ R
  -> disj (of_list Z) (map slot (of_list Z))
  -> (forall n' z', n' < n -> get Z n' z' -> z' =/= z)
  -> exists y, get Y n y
         /\ E [slot_lift_params slot (R, M) Z <--
                               Some ⊝ extend_list Y Z (R, M)] z = Some y.
Proof.
  intros Len Get In Disj First. length_equify.
  general induction Len; simpl in *; isabsurd.
  inv Get.
  - exists y; repeat split; eauto using get.
    cases; simpl.
    + lud; eauto using get.
    + cases; simpl.
      * lud; eauto using get.
  - edestruct (IHLen slot E n0) as [? [? ]]; eauto using get; dcr.
    + eapply disj_incl; eauto with cset.
    + intros. eapply (First (S n')); eauto using get. omega.
    + exists x0. eexists; repeat split; eauto using get.
      exploit (First 0); eauto using get; try omega.
      cases; simpl.
      * rewrite lookup_nequiv; eauto.
        rewrite lookup_nequiv; eauto.
        intro.
        eapply (Disj z). eapply get_in_of_list in H3.
        cset_tac. rewrite <- H2.
        eapply map_iff; eauto. eexists x; split; eauto with cset.
      * cases; simpl; lud.
        -- eauto.
        -- exfalso.
           eapply (Disj (slot x)).
           ++ eapply get_in_of_list in H3. rewrite <- H5. cset_tac.
           ++ eapply map_iff; eauto. eexists x; split; eauto with cset.
        -- eauto.
Qed.

Lemma slot_lift_params_agree (slot : var -> var) X (E:onv X) E' R M Z VL (Len:❬Z❭=❬VL❭)
      (Agr2:agree_on eq (R \ of_list Z) E E')
      (Disj:disj (R ∪ of_list Z) (map slot (R ∪ of_list Z)))
      (Incl:of_list Z [<=] R ∪ M)
  : agree_on eq R (E [Z <-- Some ⊝ VL])
             (E' [slot_lift_params slot (R, M) Z <-- Some ⊝ extend_list VL Z (R, M)]).
Proof.
  hnf; intros.
  decide (x ∈ of_list Z).
  - assert (❬Z❭=❬Some ⊝ VL❭) by eauto with len.
    edestruct (of_list_get_first _ i) as [n]; eauto; dcr.
    edestruct update_with_list_lookup_in_list_first; eauto; dcr.
    + intros; rewrite H2. eauto.
    + rewrite <- H2. rewrite H6. inv_get.
      edestruct update_with_list_lookup_in_list_first_slot;
        try eapply Len; try eapply H3; try eapply H; dcr.
      * eapply disj_incl; eauto with cset.
      * intros; eauto.
      * erewrite H7. inv_get. eauto.
  - rewrite !lookup_set_update_not_in_Z; eauto.
    + eapply Agr2. cset_tac.
    + rewrite of_list_slot_lift_params; eauto.
      clear - n Disj H; cset_tac.
Qed.

Lemma update_with_list_lookup_in_list_first_slot' (slot : var -> var) A (E:onv A) n (R M:set var)
      Z (Y:list A) z
: length Z = length Y
  -> get Z n z
  -> z ∈ M
  -> disj (of_list Z ∪ R ∪ M) (map slot (of_list Z ∪ R ∪ M))
  -> injective_on (of_list Z ∪ R ∪ M) slot
  -> (forall n' z', n' < n -> get Z n' z' -> z' =/= z)
  -> exists y, get Y n y /\ E [slot_lift_params slot (R, M) Z <--
                  Some ⊝ extend_list Y Z (R, M)] (slot z) = Some y.
Proof.
  intros Len Get In Disj Inj First. length_equify.
  general induction Len; simpl in *; isabsurd.
  inv Get.
  - exists y; repeat split; eauto using get.
    cases; simpl.
    + lud; eauto using get.
    + cases; simpl.
      * exfalso. cset_tac.
      * lud; eauto using get.
  - edestruct (IHLen slot E n0 R M) as [? [? ]]; eauto using get; dcr.
    + eapply disj_incl; eauto.
      clear; cset_tac.
      clear; cset_tac'; eauto 20.
    + eapply injective_on_incl; eauto.
      clear; cset_tac.
    + intros. eapply (First (S n')); eauto using get. omega.
    + exists x0. eexists; repeat split; eauto using get.
      exploit (First 0); eauto using get; try omega.
      cases; simpl.
      * rewrite lookup_nequiv; eauto.
        rewrite lookup_nequiv; eauto.
        -- intro. eapply Inj in H2; eauto with cset.
        -- intro. hnf in H2; subst.
           eapply (Disj (slot z)); eauto with cset.
      * cases; simpl; lud; eauto.
        -- exfalso. hnf in e; subst.
           eapply (Disj (slot z)); eauto with cset.
        -- exfalso. eapply H2. eapply Inj; eauto with cset.
Qed.

Lemma slot_lift_params_agree_slot (slot : var -> var) X (E:onv X) E' R M Z VL (Len:❬Z❭=❬VL❭)
      (Agr2:agree_on eq (M \ of_list Z) E (fun x => E' (slot x)))
      (Disj:disj (of_list Z ∪ R ∪ M) (map slot (of_list Z ∪ R ∪ M)))
      (Inj:injective_on (of_list Z ∪ R ∪ M) slot)
      (Incl:of_list Z [<=] R ∪ M)
        : agree_on eq M (E [Z <-- Some ⊝ VL])
             (fun x => E' [slot_lift_params slot (R, M) Z <--
                        Some ⊝ extend_list VL Z (R, M)] (slot x)).
Proof.
  hnf; intros.
  decide (x ∈ of_list Z).
  - assert (❬Z❭=❬Some ⊝ VL❭) by eauto with len.
    edestruct (of_list_get_first _ i) as [n]; eauto; dcr. hnf in H2; subst.
    edestruct update_with_list_lookup_in_list_first; eauto; dcr.
    rewrite H4. inv_get.
    edestruct (@update_with_list_lookup_in_list_first_slot' slot); try eapply Len; try eapply H5;
      try eapply Disj;
      eauto; dcr.
    rewrite H6. get_functional. eauto.
  - rewrite !lookup_set_update_not_in_Z; eauto.
    + eapply Agr2. cset_tac.
    + rewrite of_list_slot_lift_params; eauto.
      intro. eapply union_iff in H0; destruct H0.
      * eapply (Disj (slot x)). cset_tac. cset_tac.
      * eapply (Disj x). cset_tac.
        eapply map_iff in H0; eauto. dcr.
        eapply Inj in H3; eauto with cset.
        exfalso; cset_tac.
        cset_tac.
Qed.

Instance SR (slot : var -> var) (VD:set var)
  : PointwiseProofRelationI (((set var) * (set var)) * params) := {
   ParamRelIP RMZ Z Z' := Z' = slot_lift_params slot (fst RMZ) Z /\ Z = snd RMZ;
   ArgRelIP V V' RMZ VL VL' :=
     VL' = extend_list VL (snd RMZ) (fst RMZ) /\
     agree_on eq (fst (fst RMZ) \ of_list (snd RMZ)) V V' /\
     agree_on eq (snd (fst RMZ) \ of_list (snd RMZ)) V (fun x => V' (slot x)) /\
     ❬VL❭ = ❬snd RMZ❭ /\
     defined_on (fst (fst RMZ) \ of_list (snd RMZ)
                     ∪ map slot (snd (fst RMZ) \ of_list (snd RMZ))) V'
}.

Require Import AppExpFree Subset1.

Lemma sim_I (slot : var -> var) k Λ ZL LV VD r L L' V V' R M s lv sl ra
  : agree_on eq R V V'
    -> agree_on eq M V (fun x => V' (slot x))
    -> live_sound Imperative ZL LV s lv
    -> spill_sound k ZL Λ (R,M) s sl
    -> spill_live VD sl lv
    -> injective_on VD slot
    -> disj VD (map slot VD)
    -> defined_on (R ∪ map slot M) V'
    -> R ∪ M ⊆ fst (getAnn ra)
    -> labenv_sim SimExt (sim r) (SR slot VD) (zip pair Λ ZL) L L'
    -> (fst (getAnn ra) ∪ snd (getAnn ra)) ⊆ VD
    -> renamedApart s ra
    -> app_expfree s
    -> ann_R Subset1 lv ra
    -> sim r SimExt (L, V, s) (L', V', do_spill slot s sl ZL Λ).
Proof.
  simpl. unfold sim.
  move VD before k. move s before VD. revert_until s.
  sind s.
  intros ? ? ? ? ? ? ? ? ? ? ? ? ?
         Agr1 Agr2 LS SLS SL Inj Disj Def Incl' LSim RAincl RA AEF Sub1.
  assert (Incl:R ∪ M [<=] VD). {
    rewrite <- RAincl, <- Incl'. eauto with cset.
  }
  exploit L_sub_SpM as LSpM; eauto.
  exploit Sp_sub_R as SpR; eauto.
  assert (VDincl:getSp sl ∪ getL sl [<=] VD). {
    rewrite LSpM, SpR.
    rewrite <- Incl.
    clear; cset_tac.
  }
  eapply sim_I_moves; eauto.
  eapply injective_on_incl; eauto with cset.
  eapply disj_incl; eauto with cset.
  eapply defined_on_incl; eauto.
  rewrite SpR at 1. rewrite LSpM.
  rewrite map_union; eauto. clear; cset_tac.
  rewrite !lookup_list_map. intros ? Agr3.
  time (destruct s; invt spill_sound; invt spill_live; invt live_sound;
        invt renamedApart; invt app_expfree; try invtc (@ann_R _ _ Subset1);
    (exploit regs_agree_after_spill_load as Agr4); try eassumption;
      exploit mem_agrees_after_spill_load as Agr5; try eassumption;
        simpl in *; rewrite !elements_empty; simpl).
  - destruct e; simpl in *.
    + eapply (sim_let_op il_statetype_I); eauto.
      * symmetry; eapply op_eval_agree; eauto using agree_on_incl.
      * intros. left.
        eapply (IH s); try eassumption.
        -- eauto.
        -- eapply agree_on_update_same; eauto.
           eapply agree_on_incl; eauto.
           clear; cset_tac.
        -- eapply mem_agrees_after_spill_load_update; eauto.
           rewrite SpR, Incl'; eauto.
           rewrite H18 in RAincl.
           revert RAincl; clear; cset_tac.
        -- eapply defined_on_update_some.
           eapply defined_on_incl.
           eapply defined_on_after_spill_load; eauto.
           instantiate (1:=K). clear; cset_tac.
        -- pe_rewrite.
           rewrite LSpM, SpR, <- Incl'. clear; cset_tac.
        -- pe_rewrite. rewrite <- RAincl.
           rewrite H18. clear; cset_tac.
    + eapply (sim_let_call il_statetype_I).
      * symmetry; eapply omap_op_eval_agree; eauto using agree_on_incl.
      * intros. left. eapply (IH s); try eassumption.
        -- eauto.
        -- eapply agree_on_update_same; eauto.
           eapply agree_on_incl; eauto.
           clear; cset_tac.
        -- eapply mem_agrees_after_spill_load_update; eauto.
           rewrite SpR, Incl'; eauto.
           rewrite H18 in RAincl.
           revert RAincl; clear; cset_tac.
        -- eapply defined_on_update_some.
           eapply defined_on_incl.
           eapply defined_on_after_spill_load; eauto.
           instantiate (1:=K). clear; cset_tac.
        -- pe_rewrite. rewrite LSpM, SpR, <- Incl'.
           clear; cset_tac.
        -- pe_rewrite. rewrite <- RAincl.
           rewrite H18. clear; cset_tac.
  - simpl in *.
    eapply (sim_cond il_statetype_I).
    + symmetry; eapply op_eval_agree; eauto using agree_on_incl.
    + intros; left. eapply IH; try eassumption.
      * eauto.
      * eapply defined_on_after_spill_load; eauto.
      * pe_rewrite. rewrite LSpM, SpR, <- Incl'. clear; cset_tac.
      * pe_rewrite. rewrite <- RAincl, <- H9. clear; cset_tac.
    + intros; left. eapply IH; try eassumption.
      * eauto.
      * eapply defined_on_after_spill_load; eauto.
      * pe_rewrite. rewrite LSpM, SpR, <- Incl'. clear; cset_tac.
      * pe_rewrite. rewrite <- RAincl, <- H9. clear; cset_tac.
  - eapply labenv_sim_app; eauto using zip_get.
    intros; simpl in *. dcr; subst; repeat get_functional.
    split; eauto; intros.
    erewrite !get_nth; eauto using zip_get.
    edestruct op_eval_var; eauto; subst.
    erewrite omap_slotlift; only 6: eauto.
    eexists; split; eauto. split; eauto.
    eapply slot_lift_params_extend_list_length; eauto.
    split; eauto.
    split; eauto using agree_on_incl.
    split; eauto using agree_on_incl.
    split; eauto.
    eapply defined_on_incl.
    eapply defined_on_after_spill_load; eauto. instantiate (1:=K).
    rewrite H8, H11. reflexivity.
    len_simpl. rewrite <- H17. eauto with len.
    simpl. eapply agree_on_incl; eauto.
    simpl. eapply agree_on_incl; eauto. simpl.
    rewrite <- H12. eapply of_list_freeVars_vars.
  - pno_step. simpl.
    erewrite op_eval_agree; [reflexivity| |reflexivity]. symmetry.
    eapply agree_on_incl; eauto using regs_agree_after_spill_load; eauto.
  - eapply sim_fun_ptw; try eapply LSim; try eassumption.
    + intros. left.
      eapply (IH s); eauto.
      * eapply defined_on_after_spill_load; eauto.
      * pe_rewrite. rewrite LSpM, SpR, <- Incl'. clear; cset_tac.
      * pe_rewrite. rewrite <- RAincl, <- H25. clear; cset_tac.
    + intros. hnf; intros; simpl in *; dcr. subst.
      inv_get.
      exploit H12 as SPS'; try eassumption.
      exploit H20 as LS'; try eassumption.
      exploit H15 as SL'; try eassumption. destruct x as (R_f,M_f).
      exploit H14 as In'; try eassumption; simpl in *; destruct In' as [In1 In2].
      exploit H2 as RA'; try eassumption.
      exploit (get_PIR2 H7) as EQ; only 1-2: eauto.
      exploit H21 as In3; try eassumption.
      destruct In3 as [In3 _].
      unfold merge in EQ. simpl in *.
      eapply IH; eauto.
      * eapply slot_lift_params_agree; only 1-2: eauto.
        -- eapply disj_incl; eauto.
           ++ rewrite In3, <- EQ, In1, In2.
             clear; eauto with cset.
           ++ rewrite In3, <- EQ, In1, In2.
             clear; eauto with cset.
        -- rewrite EQ; eauto.
      * eapply slot_lift_params_agree_slot; only 1-2: eauto.
        -- eapply disj_incl; eauto.
           rewrite In3, <- EQ, In1, In2. clear; cset_tac.
           eapply map_incl; eauto.
           rewrite In3, <- EQ, In1, In2. clear; cset_tac.
        -- eapply injective_on_incl; eauto.
           rewrite In3, <- EQ, In1, In2. clear; cset_tac.
        -- rewrite EQ; eauto.
      * eapply defined_on_update_list'.
        -- len_simpl.
           edestruct H8; eauto; dcr. simpl in *.
           eapply slot_lift_params_extend_list_length; eauto.
        -- rewrite of_list_slot_lift_params; eauto.
           eapply defined_on_incl; eauto.
           rewrite <- EQ in In3; revert In3; clear.
           ++ cset_tac'.
             ** eexists x. cset_tac.
             ** eexists x; eauto.
           ++ rewrite EQ; eauto.
        -- eapply get_defined; intros; inv_get; eauto.
      * edestruct H8; eauto; dcr.
        simpl in *. rewrite EQ.
        exploit H33; eauto. eapply ann_R_get in H4. eauto.
      * edestruct H8; eauto; dcr.
        rewrite H3. simpl. rewrite union_comm. rewrite <- union_assoc.
        eapply union_incl_split.
        -- rewrite <- RAincl. eapply incl_union_right.
           rewrite <- H25. eapply incl_union_left.
           eapply incl_list_union; eauto using zip_get.
           unfold defVars. simpl. clear; eauto with cset.
        -- rewrite <- RAincl. eauto with cset.
      * exploit H24; eauto.
    + hnf; intros; simpl in *; subst.
      inv_get; simpl; eauto.
    + eauto with len.
    + eauto with len.
Qed.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.

Set Implicit Arguments.

Lemma write_step_promise
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (PROMISES: (Local.promises lc1) = Memory.bot):
  (Local.promises lc2) = Memory.bot.
Proof.
  inv STEP. rewrite PROMISES in *. s.
  apply Memory.ext. i. rewrite Memory.bot_get.
  inv WRITE.
  erewrite Memory.remove_o; eauto. condtac; ss. guardH o.
  inv PROMISE; ss.
  - erewrite Memory.add_o; eauto. condtac; ss.
    apply Memory.bot_get.
  - erewrite Memory.split_o; eauto. repeat condtac; ss.
    + guardH o0. des. subst.
      exploit Memory.split_get0; try exact PROMISES0; eauto. i. des.
      rewrite Memory.bot_get in *. congr.
    + apply Memory.bot_get.
  - erewrite Memory.lower_o; eauto. condtac; ss.
    apply Memory.bot_get.
Qed.

Lemma program_step_promise
      lang e
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (STEP: Thread.program_step e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2))
      (PROMISES: (Local.promises lc1) = Memory.bot):
  (Local.promises lc2) = Memory.bot.
Proof.
  inv STEP. inv LOCAL; ss; try by inv LOCAL0.
  - eapply write_step_promise; eauto.
  - eapply write_step_promise; eauto.
    inv LOCAL1. auto.
Qed.

Lemma closed_timemap_max_ts
      loc tm mem
      (CLOSED: Memory.closed_timemap tm mem):
  Time.le (tm loc) (Memory.max_ts loc mem).
Proof.
  specialize (CLOSED loc). des.
  eapply Memory.max_ts_spec. eauto.
Qed.

Lemma closed_timemap_max_concrete_ts
      loc tm mem mts
      (CLOSED: Memory.closed_timemap tm mem)
      (MAX: Memory.max_concrete_ts mem loc mts):
  Time.le (tm loc) mts.
Proof.
  specialize (CLOSED loc). des.
  eapply Memory.max_concrete_ts_spec; eauto.
Qed.

Lemma progress_promise_step
      lc1 sc1 mem1
      loc to val releasedm ord
      (LT: Time.lt (Memory.max_ts loc mem1) to)
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (WF_REL: View.opt_wf releasedm)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1):
  exists promises2 mem2,
    Local.promise_step lc1 mem1 loc (Memory.max_ts loc mem1) to
                       (Message.concrete val (TView.write_released (Local.tview lc1) sc1 loc to releasedm ord))
                       (Local.mk (Local.tview lc1) promises2) mem2 Memory.op_kind_add.
Proof.
  exploit (@Memory.add_exists_max_ts
             mem1 loc to
             (Message.concrete val (TView.write_released (Local.tview lc1) sc1 loc to releasedm ord))); eauto.
  { econs. eapply TViewFacts.write_future0; eauto. apply WF1. }
  i. des.
  exploit Memory.add_exists_le; try apply WF1; eauto. i. des.
  hexploit Memory.add_inhabited; try apply x0; [viewtac|]. i. des.
  esplits. econs; eauto.
  - econs; eauto; try congr.
    + econs. unfold TView.write_released.
      viewtac; repeat (condtac; viewtac);
        (try by apply Time.bot_spec);
        (try by unfold TimeMap.singleton, LocFun.add; condtac; [refl|congr]);
        (try by left; eapply TimeFacts.le_lt_lt; [|eauto];
         eapply closed_timemap_max_ts; apply WF1).
      left. eapply TimeFacts.le_lt_lt; [|eauto].
      eapply closed_timemap_max_ts. apply Memory.unwrap_closed_opt_view; viewtac.
    + i. inv x0. inv ADD. clear DISJOINT MSG_WF CELL2.
      exploit Memory.get_ts; try exact GET. i. des.
      { subst. inv TO. }
      exploit Memory.max_ts_spec; try exact GET. i. des.
      eapply Time.lt_strorder. etrans; try exact TO.
      eapply TimeFacts.lt_le_lt; eauto.
  - econs. unfold TView.write_released. condtac; econs.
    viewtac;
      repeat condtac; viewtac;
        (try eapply Memory.add_closed_view; eauto);
        (try apply WF1).
    + viewtac.
    + erewrite Memory.add_o; eauto. condtac; eauto. ss. des; congr.
    + erewrite Memory.add_o; eauto. condtac; eauto. ss. des; congr.
Qed.

Lemma progress_read_step
      lc1 mem1
      loc ord
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1):
  exists val released lc2 mts,
    <<MAX: Memory.max_concrete_ts mem1 loc mts>> /\
    <<READ: Local.read_step lc1 mem1 loc mts val released ord lc2>>.
Proof.
  dup MEM1. inv MEM0.
  exploit (Memory.max_concrete_ts_exists); eauto. i. des.
  exploit (Memory.max_concrete_ts_spec); eauto. i. des.
  esplits; eauto. econs; eauto.
  econs; i; eapply Memory.max_concrete_ts_spec2; eauto; apply WF1.
Qed.

Lemma progress_read_step_cur
      lc1 mem1
      loc ord
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1):
  exists val released lc2,
    <<READ: Local.read_step lc1 mem1 loc ((TView.cur (Local.tview lc1)).(View.rlx) loc) val released ord lc2>>.
Proof.
  dup WF1. inv WF0. inv TVIEW_CLOSED. inv CUR.
  specialize (RLX loc). des.
  esplits. econs; eauto.
  econs; try apply TVIEW_WF; try refl.
Qed.

Lemma progress_write_step
      lc1 sc1 mem1
      loc to val releasedm ord
      (LT: Time.lt (Memory.max_ts loc mem1) to)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (WF_REL: View.opt_wf releasedm)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1)):
  exists released lc2 sc2 mem2,
    Local.write_step lc1 sc1 mem1 loc (Memory.max_ts loc mem1) to val releasedm released ord lc2 sc2 mem2 Memory.op_kind_add.
Proof.
  exploit progress_promise_step; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des. inv x0.
  exploit Memory.remove_exists; eauto.
  { inv PROMISE. erewrite Memory.add_o; try eexact PROMISES.
    condtac; eauto. ss. des; exfalso; apply o; eauto.
  }
  i. des.
  esplits. econs; eauto.
  econs; i; (try eapply TimeFacts.le_lt_lt; [|eauto]).
  apply Memory.max_ts_spec2. apply WF1.
Qed.

Lemma progress_write_step_split
      lc1 sc1 mem1
      loc from to msg val releasedm ord
      (GET: Memory.get loc to (Local.promises lc1) = Some (from, msg))
      (CONS: Time.lt ((TView.cur (Local.tview lc1)).(View.rlx) loc) to)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (WF_REL: View.opt_wf releasedm)
      (TS_REL: Time.le ((View.rlx (View.unwrap releasedm)) loc) from)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1))
      (RESERVE: exists val' released', msg = Message.concrete val' released'):
  exists released lc2 sc2 mem2,
    Local.write_step lc1 sc1 mem1 loc from (Time.middle from to) val releasedm
                     released ord lc2 sc2 mem2 (Memory.op_kind_split to msg).
Proof.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv WF1. rewrite BOT in GET. ss. }
  exploit (@Memory.split_exists
             (Local.promises lc1) loc from (Time.middle from to) to
             (Message.concrete val (TView.write_released (Local.tview lc1) sc1 loc (Time.middle from to) releasedm ord))
             msg);
    try apply Time.middle_spec; auto.
  { econs. eapply TViewFacts.write_future0; eauto. apply WF1. }
  i. des.
  exploit Memory.split_exists_le; try apply WF1; eauto. i. des.
  exploit Memory.split_get0; try exact x1. i. des.
  exploit Memory.remove_exists; try exact GET2. i. des.
  clear GET0 GET1 GET2 GET3.
  assert (TS: Time.le ((TView.cur (Local.tview lc1)).(View.rlx) loc) from).
  { destruct (TimeFacts.le_lt_dec ((TView.cur (Local.tview lc1)).(View.rlx) loc) from); ss.
    inv WF1. inv TVIEW_CLOSED. inv CUR.
    specialize (RLX loc). des.
    clear REL ACQ PLN.
    exploit PROMISES; try exact GET. i.
    exploit Memory.get_ts; try exact RLX. i. des.
    { subst. rewrite x4 in l. inv l. }
    exploit Memory.get_disjoint; [exact RLX|exact x|..]. i. des.
    { subst. timetac. }
    exfalso.
    eapply x6; econs; [|refl|..]; ss. econs. ss.
  }
  esplits. econs; eauto.
  - econs; ss.
    eapply TimeFacts.le_lt_lt; eauto.
    apply Time.middle_spec. ss.
  - econs; eauto. econs; eauto.
    econs. unfold TView.write_released. ss.
    condtac; ss; try by unfold TimeMap.bot; apply Time.bot_spec.
    unfold LocFun.add. condtac; ss.
    unfold TimeMap.join. condtac; ss.
    + unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      repeat apply Time.join_spec; ss; try refl.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
    + unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      repeat apply Time.join_spec; ss; try refl.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
      * inv WF1. inv TVIEW_WF. etrans; try eapply REL_CUR.
        etrans; eauto. econs. apply Time.middle_spec; ss.
Qed.

Lemma progress_fence_step
      lc1 sc1
      ordr ordw
      (PROMISES1: Ordering.le Ordering.strong_relaxed ordw -> Memory.nonsynch (Local.promises lc1))
      (PROMISES2: ordw = Ordering.seqcst -> (Local.promises lc1) = Memory.bot):
  exists lc2 sc2,
    Local.fence_step lc1 sc1 ordr ordw lc2 sc2.
Proof.
  esplits. econs; eauto.
Qed.


Require Import Framework TotalMem.
Import ListNotations.

Set Implicit Arguments.

Section DiskLayer.

  Variable A: Type.
  Variable AEQ: EqDec A.
  Variable V : Type.
  Variable in_domain: A -> Prop.

  Inductive token' :=
  | Crash : token'
  | Cont : token'.

  Definition state' :=  @total_mem A AEQ (V * list V).

  Inductive disk_prog : Type -> Type :=
  | Read : A -> disk_prog V
  | Write : A -> V -> disk_prog unit
  | Sync : disk_prog unit.

  Inductive exec' :
    forall T, user -> token' ->  state' -> disk_prog T -> @Result state' T -> Prop :=
  | ExecRead :
      forall d a u,
        in_domain a ->
        exec' u Cont d (Read a) (Finished d (fst (d a)))

  | ExecWrite :
      forall d a v u,
        in_domain a ->
        exec' u Cont d (Write a v) (Finished (upd d a (v, (fst (d a)::snd (d a)))) tt)

  | ExecSync :
      forall d u,
        exec' u Cont d Sync (Finished (sync d) tt)

  | ExecCrash :
      forall T d (p: disk_prog T) u,
        exec' u Crash d p (Crashed d).

  Hint Constructors exec' : core.

  Theorem exec_deterministic_wrt_token' :
    forall u o s T (p: disk_prog T) ret1 ret2,
      exec' u o s p ret1 ->
      exec' u o s p ret2 ->
      ret1 = ret2.
  Proof.
    intros; destruct p; simpl in *; cleanup;
    repeat
      match goal with
      | [H: exec' _ _ _ _ _ |- _] =>
        inversion H; clear H; cleanup
      end; eauto.
  Qed.

  Definition DiskOperation :=
    Build_Core
      disk_prog
      exec'
      exec_deterministic_wrt_token'.

  Definition DiskLang := Build_Layer DiskOperation.

Notation "| p |" := (Op DiskOperation p)(at level 60).
Notation "x <-| p1 ; p2" := (Bind (Op DiskOperation p1) (fun x => p2))(right associativity, at level 60).
Notation "p >> s" := (p s) (right associativity, at level 60, only parsing).

End DiskLayer.

Arguments Read {_ _}.
Arguments Sync {_ _}.


(* The seppapp operator: separating append, useful for contiguous memory regions *)
Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import coqutil.Tactics.Tactics coqutil.Tactics.fwd.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface coqutil.Word.Properties coqutil.Word.Bitwidth.
Require Import coqutil.Map.Interface.
Require Import bedrock2.Map.Separation bedrock2.Map.SeparationLogic.
Require Import bedrock2.SepLib.
Require Import bedrock2.PurifySep.

Definition sepapp{width: Z}{BW: Bitwidth width}{word: word.word width}
  {mem: map.map word Byte.byte}
  (P1 P2: word -> mem -> Prop){P1size: PredicateSize P1}: word -> mem -> Prop :=
  fun addr => sep (P1 addr) (P2 (word.add addr (word.of_Z P1size))).

Declare Scope sepapp_scope. Local Open Scope sepapp_scope.
Infix "*+" := sepapp (at level 36, left associativity) : sepapp_scope.

#[export] Hint Extern 1 (PredicateSize (sepapp ?P1 ?P2)) =>
  lazymatch constr:(_: PredicateSize P1) with
  | ?sz1 => lazymatch constr:(_: PredicateSize P2) with
            | ?sz2 => exact (Z.add sz1 sz2)
            end
  end
: typeclass_instances.

(* Placeholder for use with sepapp.
   After removing one clause out of a series of sepapps, we get
   (stuffBefore start_addr * stuffAfter (start_addr + size_of_stuffBefore + size_of_hole))
   Using `hole`, we can write it more concisely:
   (stuffBefore *+ hole size_of_hole *+ stuffAfter) start_addr *)
Definition hole{key value}{mem: map.map key value}(n: Z)(addr: key): mem -> Prop :=
  emp True.
#[export] Hint Extern 1 (PredicateSize (hole ?n)) => exact n : typeclass_instances.
#[export] Hint Opaque hole : typeclass_instances.

(* pair of a predicate and its size, used as tree leaves *)
Inductive sized_predicate{width: Z}{BW: Bitwidth width}{word: word.word width}
  {mem: map.map word Byte.byte}: Type :=
| mk_sized_predicate(p: word -> mem -> Prop)(sz: PredicateSize p).

Section Reassociate_sepapp.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {word_ok: word.ok word}
    {mem: map.map word byte} {mem_ok: map.ok mem}.

  Import List.ListNotations. Local Open Scope list_scope.

  Lemma sep_assoc_eq: forall (p q r: mem -> Prop),
      sep (sep p q) r = sep p (sep q r).
  Proof.
    intros. eapply iff1ToEq. eapply sep_assoc.
  Qed.

  Lemma sepapp_assoc(P1 P2 P3: word -> mem -> Prop)
    {sz1: PredicateSize P1}{sz2: PredicateSize P2}:
    sepapp (sepapp P1 P2) P3 = sepapp P1 (sepapp P2 P3).
  Proof.
    unfold sepapp. extensionality addr.
    rewrite sep_assoc_eq. rewrite <- word.add_assoc, word.ring_morph_add.
    reflexivity.
  Qed.

  Definition sized_emp := mk_sized_predicate (fun a => emp True) 0.

  Definition sepapp_sized_predicates(sp1 sp2: sized_predicate): sized_predicate :=
    match sp1, sp2 with
    | mk_sized_predicate p1 sz1, mk_sized_predicate p2 sz2 =>
        mk_sized_predicate (@sepapp _ _ _ mem p1 p2 sz1) (sz1 + sz2)
    end.

  Definition proj_predicate(sp: sized_predicate): word -> mem -> Prop :=
    match sp with
    | mk_sized_predicate p _ => p
    end.

  Definition proj_size(sp: sized_predicate): Z :=
    match sp with
    | mk_sized_predicate _ sz => sz
    end.

  Definition sepapps(l: list sized_predicate): word -> mem -> Prop :=
    proj_predicate (List.fold_right sepapp_sized_predicates sized_emp l).

  (* Could be made stronger, but probably better to purify before a record
     has been unfolded into sepapps *)
  Lemma purify_sepapps: forall l a, purify (sepapps l a) True.
  Proof. unfold purify. intros. constructor. Qed.

  Definition sepapps_size(l: list sized_predicate): Z :=
    List.fold_right Z.add 0 (List.map proj_size l).

  Lemma sepapps_nil: forall a, sepapps nil a = emp True.
  Proof. intros. reflexivity. Qed.

  Lemma sepapps_cons: forall p l a,
      sepapps (cons p l) a = sep (proj_predicate p a)
                                 (sepapps l (word.add a (word.of_Z (proj_size p)))).
  Proof.
    intros. unfold sepapps. destruct p as [P sz]. simpl.
    destruct (List.fold_right sepapp_sized_predicates sized_emp l). simpl.
    unfold sepapp. reflexivity.
  Qed.

  Lemma sepapps_app: forall l1 l2 a,
      sepapps (l1 ++ l2) a = sep (sepapps l1 a)
                                 (sepapps l2 (word.add a (word.of_Z (sepapps_size l1)))).
  Proof.
    induction l1; intros; simpl.
    - rewrite sepapps_nil. eapply iff1ToEq. rewrite sep_emp_True_l.
      change (sepapps_size nil) with 0. rewrite word.add_0_r. reflexivity.
    - rewrite 2sepapps_cons. rewrite IHl1.
      rewrite sep_assoc_eq.
      f_equal. f_equal. f_equal.
      change (sepapps_size (a :: l1)) with (proj_size a + sepapps_size l1).
      rewrite word.ring_morph_add.
      symmetry. apply word.add_assoc.
  Qed.

  Lemma expose_nth_sepapp: forall l n a P sz,
      List.nth_error l n = Some (mk_sized_predicate P sz) ->
      sepapps l a = sep (P (word.add a (word.of_Z (sepapps_size (List.firstn n l)))))
                        (sepapps (List.firstn n l ++
                                  cons (mk_sized_predicate (hole sz) sz)
                                  (List.skipn (S n) l)) a).
  Proof.
    intros. rewrite (List.nth_error_expose _ _ _ H) at 1.
    rewrite ?sepapps_app, ?sepapps_cons. eapply iff1ToEq.
    cbn [proj_predicate proj_size]. unfold hole. cancel.
  Qed.

  Lemma merge_back_nth_sepapp: forall l n a P sz,
      List.nth_error l n = Some (mk_sized_predicate (hole sz) sz) ->
      sep (P (word.add a (word.of_Z (sepapps_size (List.firstn n l))))) (sepapps l a) =
        (sepapps (List.firstn n l ++ cons (mk_sized_predicate P sz) (List.skipn (S n) l)) a).
  Proof.
    intros. rewrite (List.nth_error_expose _ _ _ H) at 2.
    rewrite ?sepapps_app, ?sepapps_cons. eapply iff1ToEq.
    cbn [proj_predicate proj_size]. unfold hole. cancel.
  Qed.

(* Not sure if needed at all
  Definition interp_sepapp_tree(t: Tree.Tree sized_predicate): word -> mem -> Prop :=
    proj_predicate (Tree.interp id sepapp_sized_predicates t).

  Lemma flatten_eq_interp_sepapp_tree_aux(t: Tree.Tree sized_predicate):
    forall sp0: sized_predicate,
      match List.fold_left sepapp_sized_predicates (Tree.flatten t) sp0,
        sepapp_sized_predicates sp0 (Tree.interp id sepapp_sized_predicates t) with
      | mk_sized_predicate p1 sz1, mk_sized_predicate p2 sz2 =>
          p1 = p2 /\ sz1 = sz2
      end.
  Proof.
    induction t; intros.
    - simpl. destruct sp0. destruct a. simpl. auto.
    - simpl. change @app with @List.app.
      rewrite List.fold_left_app.
      specialize (IHt1 sp0).
      specialize (IHt2 (List.fold_left sepapp_sized_predicates (Tree.flatten t1) sp0)).
      destruct_one_match.
      destr sp0.
      destr (List.fold_left sepapp_sized_predicates (Tree.flatten t1)
               (mk_sized_predicate p0 sz0)).
      destr (Tree.interp id sepapp_sized_predicates t1).
      destr (Tree.interp id sepapp_sized_predicates t2).
      simpl in *.
      fwd. subst. rewrite <- sepapp_assoc. rewrite Z.add_assoc. split; reflexivity.
  Qed.

  Lemma flatten_eq_interp_sepapp_tree(t : Tree.Tree sized_predicate):
    sepapps (Tree.flatten t) = interp_sepapp_tree t.
  Proof.
    unfold sepapps, interp_sepapp_tree, proj_predicate.
    pose proof (flatten_eq_interp_sepapp_tree_aux t sized_emp) as P.
    unfold sized_emp in *. do 2 destruct_one_match. simpl in P. apply proj1 in P.
    subst.
    extensionality a. unfold sepapp. eapply iff1ToEq.
    rewrite word.add_0_r. eapply sep_emp_True_l.
  Qed.

  Lemma interp_sepapp_tree_eq_of_flatten_eq(LHS RHS : Tree.Tree sized_predicate):
    Tree.flatten LHS = Tree.flatten RHS ->
    interp_sepapp_tree LHS = interp_sepapp_tree RHS.
  Proof. intros. rewrite <-2flatten_eq_interp_sepapp_tree. f_equal. assumption. Qed.
*)

End Reassociate_sepapp.

#[export] Hint Resolve purify_sepapps: purify.

Ltac is_ground_Z x :=
  lazymatch x with
  | ?op ?a ?b =>
      lazymatch (lazymatch op with
                 | Z.add => constr:(true)
                 | Z.mul => constr:(true)
                 | _ => constr:(false)
                 end) with
      | true => lazymatch is_ground_Z a with
                | true => lazymatch is_ground_Z b with
                          | true => constr:(true)
                          | false => constr:(false)
                          end
                | false => constr:(false)
                end
      | false => constr:(false)
      end
  | _ => isZcst x
  end.

Ltac sized_predicate_list_size l :=
  lazymatch l with
  | cons (mk_sized_predicate _ ?sz) nil => sz
  | cons (mk_sized_predicate _ ?sz) ?rest =>
      let sz' := sized_predicate_list_size rest in
      constr:(Z.add sz sz')
  | nil => Z0
  end.

(* Often, only the last field of a record is of variable size,
   so computing the size left-associatively and adding up all
   the constant sizes can simplify the expressions *)
Ltac sepapps_size_with_ground_acc acc l :=
  lazymatch l with
  | cons (mk_sized_predicate _ ?sz) ?rest =>
      lazymatch is_ground_Z sz with
      | true => let acc' := eval cbv in (Z.add acc sz) in
                  sepapps_size_with_ground_acc acc' rest
      | false => lazymatch sized_predicate_list_size rest with
                 | Z0 => constr:(Z.add acc sz)
                 | ?sz' => constr:(Z.add acc (Z.add sz sz'))
                 end
      end
  | nil => acc
  end.

#[export] Hint Extern 1 (PredicateSize (sepapps ?l)) =>
  let sz := sepapps_size_with_ground_acc Z0 l in exact sz
: typeclass_instances.


Require Import oeuf.Common.

Require Import oeuf.Utopia.
Require Import oeuf.Metadata.
Require Import Program.

Require Import oeuf.ListLemmas.
Require Import oeuf.HList.
Require Import oeuf.CompilationUnit.
Require Import oeuf.Semantics.
Require Import oeuf.HighestValues.

Require oeuf.Untyped1.
Require oeuf.Untyped2.

Module A := Untyped1.
Module B := Untyped2.
Module S := Untyped1.

Definition compile_genv :=
    let fix go g :=
        match g with
        | [] => []
        | e :: g' =>
                map S.weaken_expr (e :: go g')
        end in go.

Definition compile_cu (cu : list S.expr * list metadata) :
        list S.expr * list metadata :=
    let '(exprs, metas) := cu in
    (compile_genv exprs, metas).

Lemma compile_get_weaken : forall AE fname,
    A.get_weaken AE fname = nth_error (compile_genv AE) fname.
induction AE; destruct fname; intros; simpl.
- reflexivity.
- reflexivity.
- reflexivity.
- rewrite IHAE. simpl.
  destruct (nth_error _ fname) eqn:Heq.
  + eapply map_nth_error in Heq. erewrite Heq. reflexivity.
  + symmetry. rewrite nth_error_None in *. rewrite map_length. auto.
Qed.

Ltac i_ctor := intros; constructor; eauto.
Ltac i_lem H := intros; eapply H; eauto.

Theorem I_sim : forall (AE BE : list S.expr) s s',
    compile_genv AE = BE ->
    A.sstep AE s s' ->
    B.sstep BE s s'.

destruct s as [e l k | v];
intros0 Henv Astep; inv Astep.
all: try solve [i_ctor].

- i_lem B.SMakeCall. rewrite <- compile_get_weaken. auto.
Qed.

Lemma compile_cu_compile_genv : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    compile_genv A = B.
simpl. inversion 1. auto.
Qed.

Lemma compile_cu_metas : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    Ameta = Bmeta.
simpl. inversion 1. auto.
Qed.

Lemma compile_genv_length : forall a,
    length a = length (compile_genv a).
induction a; simpl in *.
- reflexivity.
- rewrite map_length. f_equal. auto.
Qed.

Lemma compile_genv_weaken_expr : forall A,
    map S.weaken_expr (compile_genv A) =
    compile_genv (map S.weaken_expr A).
induction A; simpl.
- reflexivity.
- rewrite IHA. reflexivity.
Qed.

Lemma compile_genv_get_nth : forall A fname body,
    nth_error (compile_genv A) fname = Some body ->
    A.get_weaken A fname = Some body.
induction A; intros0 Hnth; destruct fname; try discriminate; simpl in *.
- auto.
- eapply map_nth_error' in Hnth.  destruct Hnth as (? & ? & ?).
  erewrite IHA; eauto.
  f_equal. eauto.
Qed.

Section Preservation.

    Variable aprog : A.prog_type.
    Variable bprog : B.prog_type.

    Hypothesis Hcomp : compile_cu aprog = bprog.

    Theorem fsim : Semantics.forward_simulation (A.semantics aprog) (B.semantics bprog).
    destruct aprog as [A Ameta], bprog as [B Bmeta].
    fwd eapply compile_cu_compile_genv; eauto.
    fwd eapply compile_cu_metas; eauto.

    eapply Semantics.forward_simulation_step with
        (match_states := @eq S.state)
        (match_values := @eq value).

    - simpl. intros0 Bcall Hf Ha. invc Bcall.
      fwd eapply compile_genv_get_nth as HH; eauto.
      eexists. split; i_ctor.

    - simpl. intros0 II Afinal. invc Afinal.
      eexists. split. i_ctor. i_ctor.

    - simpl. eauto.
    - simpl. intros. tauto.

    - intros0 Astep. intros0 II.
      fwd eapply I_sim; eauto.
      subst s1. eexists. eauto.

    Qed.

End Preservation.