Require Import List.
Require Import SepTheoryX PropX.
Require Import PropXTac.
Require Import RelationClasses EqdepClass.
Require Import Expr ExprUnify.
Require Import SepExpr SepHeap.
Require Import Setoid.
Require Import Prover.
Require Import SepExpr.
Require Import Folds.
Require Import Reflection.
Require SepUnify.

Set Implicit Arguments.
Set Strict Implicit.

Module Make (U : SynUnifier) (SH : SepHeap).
  Module Import SE := SH.SE.
  Module HEAP_FACTS := SepHeapFacts SH.
  Module Import SEP_FACTS := HEAP_FACTS.SEP_FACTS.
  Import HEAP_FACTS.
  Module Import SEP_UFACTS := SepUnify.Make U SH.

  Section env.
    Variable types : list type.
    Variable pcType : tvar.
    Variable stateType : tvar.

    Variable funcs : functions types.
    Variable preds : SE.predicates types pcType stateType.

    (** The actual tactic code **)
    Variable Prover : ProverT types.
    Variable Prover_correct : ProverT_correct Prover funcs.

    Definition unifyArgs (bound : nat) (summ : Facts Prover) (l r : list (expr types)) (ts : list tvar) (sub : U.Subst types)
      : option (U.Subst types) :=
      Folds.fold_left_3_opt
        (fun l r t (acc : U.Subst _) =>
          if Prove Prover summ (Expr.Equal t (U.exprInstantiate acc l) (U.exprInstantiate acc r))
            then Some acc
            else U.exprUnify bound l r acc)
        l r ts sub.

    Fixpoint unify_remove (bound : nat) (summ : Facts Prover) (l : exprs types) (ts : list tvar) (r : list (exprs types))
      (sub : U.Subst types)
      : option (list (list (expr types)) * U.Subst types) :=
        match r with
          | nil => None
          | a :: b =>
            match unifyArgs bound summ l a ts sub with
              | None =>
                match unify_remove bound summ l ts b sub with
                  | None => None
                  | Some (x,sub) => Some (a :: x, sub)
                end
              | Some sub => Some (b, sub)
            end
        end.

    Section with_typing.
      Variable tfuncs : tfunctions.
      Variables tU tG : tenv.
      Variables U G : env types.

      Hypothesis WT_funcs : WellTyped_funcs tfuncs funcs.
      Hypothesis WT_env_U : WellTyped_env tU U.
      Hypothesis WT_env_G : WellTyped_env tG G.

      Lemma unifyArgs_Extends_WellTyped : forall bound summ l r ts S S',
        U.Subst_WellTyped tfuncs tU tG S ->
        all2 (@is_well_typed _ tfuncs tU tG) l ts = true ->
        all2 (@is_well_typed _ tfuncs tU tG) r ts = true ->
        unifyArgs bound summ l r ts S = Some S' ->
        U.Subst_Extends S' S /\
        U.Subst_WellTyped tfuncs tU tG S'.
      Proof.
        unfold unifyArgs; induction l; destruct r; destruct ts; simpl; intros; try congruence.
        { inversion H2. subst; intuition; auto. }
        { repeat match goal with
          | [ H : (if ?X then _ else _) = true |- _ ] =>
            revert H; case_eq X; intros; [ | congruence ]
                   | [ |- context [ exprD ?A ?B ?C ?D ?E ] ] =>
                     case_eq (exprD A B C D E); intros
                 end; simpl in *;
        try solve [
          match goal with
            | [ H : is_well_typed _ _ _ ?e _ = true , H' : exprD _ _ _ (U.exprInstantiate ?S' ?e) _ = None |- _ ] =>
              exfalso; revert H; revert H'; clear; intros H' H;
                eapply WellTyped_exprInstantiate with (S := S') in H;
                  eapply is_well_typed_correct in H;
                    rewrite H' in H ; destruct H; congruence
          end ].
          consider (Prove Prover summ (Equal t (U.exprInstantiate S a) (U.exprInstantiate S e))); simpl; eauto.
          consider (U.exprUnify bound a e S); intros; try congruence.
          eapply IHl in H6; eauto using U.exprUnify_WellTyped.
          intuition. etransitivity; eauto using U.exprUnify_Extends. }
      Qed.

      Lemma unifyArgs_bad_cases : forall summ bound S S' ts t e a l r,
        U.Subst_WellTyped tfuncs tU tG S ->
(*        Valid Prover_correct U G summ -> *)
        all2 (@is_well_typed _ tfuncs tU tG) l ts = true ->
        all2 (@is_well_typed _ tfuncs tU tG) r ts = true ->
        @is_well_typed _ tfuncs tU tG a t = true ->
        @is_well_typed _ tfuncs tU tG e t = true ->
        match
          (if Prove Prover summ
            (Equal t (U.exprInstantiate S a) (U.exprInstantiate S e))
            then Some S
            else U.exprUnify bound a e S)
          with
          | Some acc =>
            fold_left_3_opt
            (fun (l r : expr types) (t : tvar) (acc0 : U.Subst types) =>
              if Prove Prover summ
                (Equal t (U.exprInstantiate acc0 l)
                  (U.exprInstantiate acc0 r))
                then Some acc0
                else U.exprUnify bound l r acc0) l r ts acc
          | None => None
        end = Some S' ->
        U.Subst_Extends S' S /\ U.Subst_WellTyped tfuncs tU tG S'.
      Proof.
        intros. destruct (Prove Prover summ (Equal t (U.exprInstantiate S a) (U.exprInstantiate S e))).
        apply unifyArgs_Extends_WellTyped in H4; eauto; intuition.
        revert H4. case_eq (U.exprUnify bound a e S); intros; eauto.
        generalize H4. eapply U.exprUnify_Extends in H4.
        intro. eapply U.exprUnify_WellTyped in H6; eauto.
        eapply unifyArgs_Extends_WellTyped in H5; eauto; intuition.
        etransitivity; eauto.
        congruence.
      Qed.

      Lemma unifyArgsOk : forall bound summ R l r ts f S S',
        U.Subst_WellTyped tfuncs tU tG S ->
        Valid Prover_correct U G summ ->
        all2 (@is_well_typed _ tfuncs tU tG) l ts = true ->
        all2 (@is_well_typed _ tfuncs tU tG) r ts = true ->
        unifyArgs bound summ l r ts S = Some S' ->
        U.Subst_equations funcs U G S' ->
        @applyD types (exprD funcs U G) ts (map (U.exprInstantiate S') l) R f =
        @applyD types (exprD funcs U G) ts (map (U.exprInstantiate S') r) R f /\
        U.Subst_Extends S' S /\
        U.Subst_WellTyped tfuncs tU tG S'.
      Proof.
        unfold unifyArgs; induction l; destruct r; destruct ts; simpl; intros; try congruence.
        { inversion H2. inversion H3; subst; intuition; auto. }
        { repeat match goal with
          | [ H : (if ?X then _ else _) = true |- _ ] =>
            revert H; case_eq X; intros; [ | congruence ]
                   | [ |- context [ exprD ?A ?B ?C ?D ?E ] ] =>
                     case_eq (exprD A B C D E); intros
                 end; simpl in *;
        try solve [
          match goal with
            | [ H : is_well_typed _ _ _ ?e _ = true , H' : exprD _ _ _ (U.exprInstantiate ?S' ?e) _ = None |- _ ] =>
              exfalso; revert H; revert H'; clear; intros H' H;
                eapply WellTyped_exprInstantiate with (S := S') in H;
                  eapply is_well_typed_correct in H;
                    rewrite H' in H ; destruct H; congruence
          end ].
          revert H3. case_eq (Prove Prover summ (Equal t (U.exprInstantiate S a) (U.exprInstantiate S e))); intros.
          { eapply Prove_correct in H3; eauto.
            erewrite U.exprInstantiate_WellTyped in H2 by eauto.
            erewrite U.exprInstantiate_WellTyped in H1 by eauto.
            eapply is_well_typed_correct in H2; eauto.
            eapply is_well_typed_correct in H1; eauto.
            destruct H2; destruct H1.
            unfold ValidProp, Provable in *. simpl in *.
            repeat match goal with
                     | [ H : _ = _ |- _ ] => rewrite H in *
                     | [ H : ?X -> ?Y |- _ ] =>
                       let H' := fresh in assert (H':X) by eauto; specialize (H H')
                   end.
            subst.
            eapply IHl with (f := f t0) in H9; eauto.
            intuition. rewrite H3. f_equal. f_equal.
            erewrite <- U.Subst_equations_exprInstantiate in H2 by eauto.
            erewrite <- U.Subst_equations_exprInstantiate in H1 by eauto.
            rewrite U.exprInstantiate_Extends in H2 by eauto.
            rewrite U.exprInstantiate_Extends in H1 by eauto.
            rewrite H2 in H8. rewrite H1 in H7. inversion H7; inversion H8; subst; auto. }
          { clear H3. revert H9. case_eq (U.exprUnify bound a e S); intros; try congruence.
            eapply IHl with (f := f t0) in H9; eauto using U.exprUnify_WellTyped.
            intuition. rewrite H10. f_equal. f_equal.
            eapply U.exprUnify_sound in H3.
            assert (U.exprInstantiate S' (U.exprInstantiate s a) = U.exprInstantiate S' (U.exprInstantiate s e)).
            rewrite H3; auto.
            repeat rewrite U.exprInstantiate_Extends in H11 by eauto. rewrite H11 in H7. rewrite H7 in H8. inversion H8; auto.

            etransitivity; eauto using U.exprUnify_Extends. }
          { exfalso.
            eapply unifyArgs_bad_cases in H3; eauto; intuition.
            do 2 match goal with
              | [ H : is_well_typed _ _ _ ?E _ = true ,
                  H' : exprD _ _ _ ?E _ = None |- _ ] =>
              (eapply is_well_typed_correct in H ; eauto) ; destruct H; congruence
              | [ H : exprD _ _ _ ?E _ = None |- _ ] =>
                assert (@is_well_typed _ tfuncs tU tG E t = true) by
                  (rewrite <- U.exprInstantiate_WellTyped; eauto)
            end. }
          { exfalso.
            eapply unifyArgs_bad_cases in H3; eauto; intuition.
            do 2 match goal with
              | [ H : is_well_typed _ _ _ ?E _ = true ,
                  H' : exprD _ _ _ ?E _ = None |- _ ] =>
              (eapply is_well_typed_correct in H ; eauto) ; destruct H; congruence
              | [ H : exprD _ _ _ ?E _ = None |- _ ] =>
                assert (@is_well_typed _ tfuncs tU tG E t = true) by
                  (rewrite <- U.exprInstantiate_WellTyped; eauto)
            end. }
          { exfalso.
            eapply unifyArgs_bad_cases in H3; eauto; intuition.
            do 2 match goal with
              | [ H : is_well_typed _ _ _ ?E _ = true ,
                  H' : exprD _ _ _ ?E _ = None |- _ ] =>
              (eapply is_well_typed_correct in H ; eauto) ; destruct H; congruence
              | [ H : exprD _ _ _ ?E _ = None |- _ ] =>
                assert (@is_well_typed _ tfuncs tU tG E t = true) by
                  (rewrite <- U.exprInstantiate_WellTyped; eauto)
            end. } }
      Qed.

      Lemma unify_removeOk : forall cs bound summ f p l S,
        U.Subst_WellTyped tfuncs tU tG S ->
        Valid Prover_correct U G summ ->
        nth_error preds f = Some p ->
        all2 (@is_well_typed _ tfuncs tU tG) l (SDomain p) = true ->
        forall r r' S' P,
          List.Forall (fun r => all2 (@is_well_typed _ tfuncs tU tG) r (SDomain p) = true) r ->
          unify_remove bound summ l (SDomain p) r S = Some (r', S') ->
          U.Subst_equations funcs U G S' ->
          forall Q,
          SE.himp funcs preds U G cs (SH.starred (SE.Func f) r' Q) P ->
          SE.himp funcs preds U G cs
            (SH.starred (SE.Func f) r Q) (SE.Star (SE.Func f l) P) /\
          U.Subst_Extends S' S.
      Proof.
        induction r; simpl; intros; try congruence.
        revert H4. case_eq (unifyArgs bound summ l a (SDomain p) S); intros; try congruence.
        { inversion H7; clear H7; subst.
          inversion H3; clear H3; subst.
          rewrite SH.starred_def. simpl. rewrite <- SH.starred_def.
          eapply unifyArgsOk with (R := ST.hprop (tvarD types pcType) (tvarD types stateType) nil) (f := SDenotation p) in H4;
            eauto.
          intuition.
          apply himp_star_frame; auto. unfold himp; simpl. rewrite H1.
          match goal with
            | [ |- ST.himp _ match ?X with _ => _ end match ?Y with _ => _ end ] =>
              cutrewrite (X = Y)
          end. reflexivity.
          revert H3. repeat rewrite applyD_forget_exprInstantiate by eauto; eauto. }
        { revert H7. case_eq (unify_remove bound summ l (SDomain p) r S); intros; try congruence.
          destruct p0. inversion H8; clear H8; subst. clear H4.
          inversion H3; clear H3; subst.
          rewrite SH.starred_def in H6. simpl in H6. rewrite <- SH.starred_def in H6.
          eapply IHr in H7; eauto.
          Focus 2. instantiate (2 := (SH.SE.Star (Func f a) Q)). instantiate (1 := P).
          etransitivity; [ | eapply H6 ].
          rewrite SH.starred_base. rewrite heq_star_assoc.
          rewrite SH.starred_base with (base := Q). reflexivity.
          intuition. rewrite starred_cons. rewrite <- H3.
          rewrite SH.starred_base. rewrite SH.starred_base with (base := SH.SE.Star (Func f a) Q).
          rewrite heq_star_assoc. reflexivity. }
      Qed.

      Require Import Reflection Tactics.

      Lemma unify_remove_PureFacts : forall bound summ f p l S,
        U.Subst_WellTyped tfuncs tU tG S ->
        nth_error preds f = Some p ->
        all2 (@is_well_typed _ tfuncs tU tG) l (SDomain p) = true ->
        forall r r' S',
          List.Forall (fun r => all2 (@is_well_typed _ tfuncs tU tG) r (SDomain p) = true) r ->
          unify_remove bound summ l (SDomain p) r S = Some (r', S') ->
             U.Subst_Extends S' S
          /\ U.Subst_WellTyped tfuncs tU tG S'
          /\ List.Forall (fun r => all2 (@is_well_typed _ tfuncs tU tG) r (SDomain p) = true) r'.
      Proof.
        induction r; simpl; intros; try congruence.
        consider (unifyArgs bound summ l a (SDomain p) S); intros.
        { inversion H4; clear H4; subst. inversion H2; clear H2; subst.
          eapply unifyArgs_Extends_WellTyped in H3; eauto. intuition eauto. }
        { consider (unify_remove bound summ l (SDomain p) r S); intros.
          { destruct p0. inversion H5; clear H5; subst. inversion H2; clear H2; subst.
            eapply IHr in H8; intuition. eauto. eauto. eauto. }
          { congruence. } }
      Qed.

    End with_typing.

    Require Ordering.

    Definition cancel_list : Type :=
      list (exprs types * nat).

    (** This function determines whether an expression [l] is more "defined"
     ** than an expression [r]. An expression is more defined if it "uses UVars later".
     ** NOTE: This is a "fuzzy property" but correctness doesn't depend on it.
     **)
    Fixpoint expr_count_meta (e : expr types) : nat :=
      match e with
        | Expr.Const _ _
        | Var _ => 0
        | UVar _ => 1
        | Not l => expr_count_meta l
        | Equal _ l r => expr_count_meta l + expr_count_meta r
        | Expr.Func _ args =>
          fold_left plus (map expr_count_meta args) 0
      end.

    Fixpoint exprs_count_meta (es : exprs types) : nat :=
      match es with
        | nil => O
        | e :: es' => expr_count_meta e + exprs_count_meta es'
      end.

    (** When expressions have the same number of uvars, we want to favor the larger
     ** expressions first, since they are less likely to match spuriously. *)
    Fixpoint expr_size (e : expr types) : nat :=
      match e with
        | Expr.Const _ _
        | Var _
        | UVar _ => 0
        | Not l => S (expr_size l)
        | Equal _ l r => S (expr_size l + expr_size r)
        | Expr.Func _ args => fold_left plus (map expr_size args) 1
      end.

    Definition meta_order_args (l r : exprs types) : Datatypes.comparison :=
      match Compare_dec.nat_compare (exprs_count_meta l) (exprs_count_meta r) with
        | Datatypes.Eq =>
          Ordering.list_lex_cmp _ (fun l r => Compare_dec.nat_compare (expr_size l) (expr_size r)) l r
        | v => v
      end.

    Definition meta_order_funcs (l r : exprs types * func) : Datatypes.comparison :=
      match snd l, snd r with
        | 2, 0 => Datatypes.Lt
        | 2, 1 => Datatypes.Lt
        | 2, S (S (S _)) => Datatypes.Lt
        | 0, 2 => Datatypes.Gt
        | 1, 2 => Datatypes.Gt
        | S (S (S _)), 2 => Datatypes.Gt
        | _, _ =>
          match meta_order_args (fst l) (fst r) with
            | Datatypes.Eq => Compare_dec.nat_compare (snd l) (snd r)
            | x => x
          end
      end.

    Definition order_impures (imps : MM.mmap (exprs types)) : cancel_list :=
      FM.fold (fun k => fold_left (fun (acc : cancel_list) (args : exprs types) =>
        Ordering.insert_in_order _ meta_order_funcs (args, k) acc)) imps nil.

    Lemma impuresD'_flatten : forall U G cs imps,
      SE.heq funcs preds U G cs
        (SH.impuresD _ _ imps)
        (SH.starred (fun v => SE.Func (snd v) (fst v))
          (FM.fold (fun f argss acc =>
            map (fun args => (args, f)) argss ++ acc) imps nil) SE.Emp).
    Proof.
      clear. intros. eapply MM.PROPS.fold_rec; intros.
        rewrite (SH.impuresD_Empty funcs preds U G cs H).
        rewrite SH.starred_def. simpl. reflexivity.

        rewrite SH.impuresD_Add; eauto. rewrite SH.starred_app.
        rewrite H2. symmetry. rewrite SH.starred_base. heq_canceler.
        repeat rewrite SH.starred_def.
        clear; induction e; simpl; intros; try reflexivity.
        rewrite IHe. reflexivity.
    Qed.

    Lemma fold_Permutation : forall imps L R,
      Permutation.Permutation L R ->
      Permutation.Permutation
      (FM.fold (fun (f : FM.key) (argss : list (exprs types)) (acc : list (exprs types * FM.key)) =>
        map (fun args : exprs types => (args, f)) argss ++ acc) imps L)
      (FM.fold
        (fun k : FM.key =>
         fold_left
           (fun (acc : cancel_list) (args : exprs types) =>
            Ordering.insert_in_order (exprs types * nat) meta_order_funcs
              (args, k) acc)) imps R).
    Proof.
      clear. intros.
      eapply @MM.PROPS.fold_rel; simpl; intros; auto.
        revert H1; clear. revert a; revert b; induction e; simpl; intros; auto.
        rewrite <- IHe; eauto.

        destruct (@Ordering.insert_in_order_inserts (exprs types * nat) meta_order_funcs (a,k) b) as [ ? [ ? [ ? ? ] ] ].
        subst. rewrite H.
        rewrite <- app_ass.
        eapply Permutation.Permutation_cons_app.
        rewrite app_ass. eapply Permutation.Permutation_app; eauto.
    Qed.

    Lemma order_impures_D : forall U G cs imps,
      heq funcs preds U G cs
        (SH.impuresD _ _ imps)
        (SH.starred (fun v => (Func (snd v) (fst v))) (order_impures imps) Emp).
    Proof.
      clear. intros. rewrite impuresD'_flatten. unfold order_impures.
      eapply starred_perm. eapply fold_Permutation. reflexivity.
    Qed.

    (** NOTE : l and r are reversed here **)
    (** cancel_in_order ls acc rem = (l,r,sub) ->
     ** r ===> l ->
     ** rem ===> ls * acc
     **)
    Fixpoint cancel_in_order (bound : nat) (summ : Facts Prover)
      (ls : cancel_list) (acc rem : MM.mmap (exprs types)) (sub : U.Subst types)
      (progress : bool)
      : option (MM.mmap (exprs types) * MM.mmap (exprs types) * U.Subst types) :=
      match ls with
        | nil =>
          if progress then Some (acc, rem, sub) else None
        | (args,f) :: ls =>
          match FM.find f rem with
            | None => cancel_in_order bound summ ls (MM.mmap_add f args acc) rem sub progress
            | Some argss =>
              match nth_error preds f with
                | None => cancel_in_order bound summ ls (MM.mmap_add f args acc) rem sub progress (** Unused! **)
                | Some ts =>
                  match unify_remove bound summ args (SDomain ts) argss sub with
                    | None => cancel_in_order bound summ ls (MM.mmap_add f args acc) rem sub progress
                    | Some (rem', sub) =>
                      cancel_in_order bound summ ls acc (FM.add f rem' rem) sub true
                  end
              end
          end
      end.

    Lemma cancel_in_order_equiv : forall bound summ ls acc rem sub L R S acc' progress,
      MM.mmap_Equiv acc acc' ->
      cancel_in_order bound summ ls acc rem sub progress = Some (L, R, S) ->
      exists L' R' S',
        cancel_in_order bound summ ls acc' rem sub progress = Some (L', R', S') /\
        MM.mmap_Equiv L L' /\
        MM.mmap_Equiv R R' /\
        U.Subst_Equal S S'.
    Proof.
      clear. induction ls; simpl; intros.
      { inversion H0; subst; auto.
        destruct progress; try congruence. inversion H0; clear H0; subst.
        do 3 eexists. split; [ reflexivity | intuition ]. }
      { repeat match goal with
                 | [ H : match ?X with
                           | (_,_) => _
                         end = _ |- _ ] => destruct X
                 | [ H : match ?X with
                           | Some _ => _ | None => _
                         end = _ |- _ ] =>
                 revert H; case_eq X; intros
               end;
        (eapply IHls; [ eauto using MM.mmap_add_mor | eassumption ]). }
    Qed.

    Lemma cancel_in_order_mmap_add_acc : forall bound summ ls n e acc rem sub L R S progress,
      cancel_in_order bound summ ls (MM.mmap_add n e acc) rem sub progress = Some (L, R, S) ->
      exists L' R' S',
        cancel_in_order bound summ ls acc rem sub progress = Some (L', R', S') /\
        MM.mmap_Equiv (MM.mmap_add n e L') L /\
        MM.mmap_Equiv R R' /\
        U.Subst_Equal S S'.
    Proof.
      clear. induction ls; simpl; intros.
      { inversion H; subst.
        destruct progress; try congruence. inversion H; clear H; subst.
        do 3 eexists; split.
        reflexivity. split; try reflexivity. split; try reflexivity. }
      { repeat match goal with
                 | [ H : match ?X with
                           | (_,_) => _
                         end = _ |- _ ] => destruct X
                 | [ H : match ?X with
                           | Some _ => _ | None => _
                         end = _ |- _ ] =>
                 revert H; case_eq X; intros
               end;
        try solve [ eapply IHls; eauto ];
        match goal with
          | [ H : cancel_in_order _ _ _ _ _ _ _ = _ |- _ ] =>
            eapply cancel_in_order_equiv in H; [ | eapply MM.mmap_add_comm ]
        end;
        repeat match goal with
                 | [ H : exists x, _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
               end;
        match goal with
          | [ H : cancel_in_order _ _ _ _ _ _ _ = _ |- _ ] =>
            eapply IHls in H
        end;
        repeat match goal with
                 | [ H : exists x, _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ |- exists x, _ /\ _ ] => eexists; split; [ eassumption | ]
                 | [ |- exists x, _ ] => eexists
                 | [ H : MM.mmap_Equiv _ _ |- _ ] => rewrite H
                 | [ H : U.Subst_Equal _ _ |- _ ] => rewrite H
               end; try intuition reflexivity. }
    Qed.

    Lemma nth_error_typeof_preds : forall p n,
      nth_error (typeof_preds p) n = option_map (@typeof_pred types pcType stateType) (nth_error p n).
    Proof.
      clear. unfold typeof_preds. intros. rewrite Tactics.map_nth_error_full. reflexivity.
    Qed.

    Require Import Tactics.

    Lemma WellTyped_impures_add : forall tf tp tU tG f l m,
      SH.WellTyped_impures (types := types) tf tp tU tG m = true ->
      match nth_error tp f with
        | None => false
        | Some p => allb (fun l => all2 (is_well_typed tf tU tG) l p) l
      end = true ->
      SH.WellTyped_impures tf tp tU tG (FM.add f l m) = true.
    Proof. clear.
      intros. eapply SH.WellTyped_impures_eq. intros.
      consider (nth_error tp f); try congruence; intros.
      rewrite MF.FACTS.add_o in H1. destruct (MF.FACTS.eq_dec f k); think.
      destruct v; auto.
      eapply SH.WellTyped_impures_eq in H; eauto.
    Qed.

    Lemma WellTyped_impures_mmap_add : forall tf tp tU tG f l m,
      SH.WellTyped_impures (types := types) tf tp tU tG m = true ->
      match nth_error tp f with
        | None => false
        | Some p => all2 (is_well_typed tf tU tG) l p
      end = true ->
      SH.WellTyped_impures tf tp tU tG (MM.mmap_add f l m) = true.
    Proof. clear.
      intros. eapply SH.WellTyped_impures_eq. intros.
      consider (nth_error tp f); try congruence; intros.
      unfold MM.mmap_add in *. consider (FM.find (elt:=list (list (expr types))) f m); intros.
      rewrite MF.FACTS.add_o in H3. destruct (MF.FACTS.eq_dec f k).
      { inversion H3; clear H3; subst. rewrite H0. simpl. rewrite H2.
        eapply SH.WellTyped_impures_eq in H. 2: eauto. destruct l0; auto. rewrite H0 in *. assumption. }
      { eapply SH.WellTyped_impures_eq; eauto. }
      { rewrite MF.FACTS.add_o in H3. destruct (MF.FACTS.eq_dec f k).
        inversion H3; clear H3; subst. rewrite H0. simpl; rewrite H2; auto.
        eapply SH.WellTyped_impures_eq; eauto. }
    Qed.

    Lemma cancel_in_order_PureFacts_weak : forall tU tG bound summ,
      let tf := typeof_funcs funcs in
      let tp := SE.typeof_preds preds in
(*
      let tU := typeof_env U in
      let tG := typeof_env G in *)
      forall ls acc rem sub L R S progress,
      U.Subst_WellTyped tf tU tG sub ->
      allb (fun v => SE.WellTyped_sexpr tf tp tU tG
        (Func (pcType := pcType) (stateType := stateType) (snd v) (fst v))) ls = true ->
      SH.WellTyped_impures tf tp tU tG acc = true ->
      SH.WellTyped_impures tf tp tU tG rem = true ->
(*      Valid Prover_correct U G summ ->  *)
      cancel_in_order bound summ ls acc rem sub progress = Some (L, R, S) ->
         U.Subst_Extends S sub
      /\ U.Subst_WellTyped tf tU tG S
      /\ SH.WellTyped_impures tf tp tU tG L = true
      /\ SH.WellTyped_impures tf tp tU tG R = true.
    Proof.
      induction ls; simpl; intros.
      { destruct progress; try congruence. inversion H3; clear H3; subst; intuition. }
      { subst tp. rewrite nth_error_typeof_preds in H0. destruct a; simpl in *.
        repeat match goal with
                 | H : context [ option_map _ ?X ] |- _ =>
                   (consider X; simpl in *; try congruence); [ intros ]
                 | [ H : match ?X with _ => _ end = _ |- _ ] =>
                   (consider X; intros; try congruence); [ intros ]
                 | [ H : match ?X with
                           | Some _ => _ | None => _
                         end = _ |- _ ] =>
                 consider X; intros
               end; simpl in *; subst.
{ assert (List.Forall
          (fun r : list (expr types) =>
            all2 (is_well_typed tf tU tG) r (SDomain p) = true) l0).
          { eapply SH.WellTyped_impures_eq in H2; try eassumption.
            destruct l0. constructor. rewrite nth_error_typeof_preds in H2.
            rewrite H0 in H2. generalize dependent (e :: l0); simpl; intros.
            unfold typeof_pred in H2. clear - H2.
            induction l2; simpl in *; constructor; think; auto. }
          eapply unify_remove_PureFacts in H7.
          2: eauto. 2: eauto. 2: eauto. 2: eauto.
          { eapply IHls in H8; eauto. intuition.
            etransitivity; eassumption.
            intuition. intuition.
            eapply SH.WellTyped_impures_eq. intros. rewrite MF.FACTS.add_o in H10.
            destruct (MF.FACTS.eq_dec f k); auto. inversion H10; clear H10; subst.
            rewrite nth_error_typeof_preds in *. rewrite H0 in *. simpl. destruct v; intuition.
            generalize dependent (e :: v); intros.
            clear - H11. unfold typeof_pred. induction H11; simpl; auto. rewrite H. auto.
            eapply SH.WellTyped_impures_eq; eauto. } }
        { clear H6. eapply IHls in H7; eauto.
          eapply WellTyped_impures_mmap_add; auto. rewrite nth_error_typeof_preds.
          rewrite H0. simpl. auto. }
        { clear H4. eapply IHls in H6; eauto.
          eapply WellTyped_impures_mmap_add; auto. rewrite nth_error_typeof_preds.
          rewrite H0. simpl. auto. } }
    Qed.

    Lemma cancel_in_order_PureFacts : forall U G bound summ,
      let tf := typeof_funcs funcs in
      let tp := SE.typeof_preds preds in
      let tU := typeof_env U in
      let tG := typeof_env G in
      forall ls acc rem sub L R S progress,
      U.Subst_WellTyped tf tU tG sub ->
      U.Subst_equations funcs U G S ->
      allb (fun v => SE.WellTyped_sexpr tf tp tU tG
        (Func (pcType := pcType) (stateType := stateType) (snd v) (fst v))) ls = true ->
      SH.WellTyped_impures tf tp tU tG acc = true ->
      SH.WellTyped_impures tf tp tU tG rem = true ->
      cancel_in_order bound summ ls acc rem sub progress = Some (L, R, S) ->
         U.Subst_equations funcs U G sub
      /\ U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) S
      /\ SH.WellTyped_impures tf tp tU tG L = true
      /\ SH.WellTyped_impures tf tp tU tG R = true.
    Proof.
      intros.
      eapply cancel_in_order_PureFacts_weak in H4; try eassumption. intuition.
      eapply U.Subst_equations_Extends. 2: eassumption. eauto.
    Qed.

    Lemma impuresD_mmap_add : forall cs U G f args m,
      heq funcs preds U G cs
      (SH.impuresD pcType stateType (MM.mmap_add f args m))
      (Star (Func f args) (SH.impuresD pcType stateType m)).
    Proof. clear.
      intros. unfold MM.mmap_add. consider (FM.find (elt:=list (exprs types)) f m); intros.
      { rewrite SH.impuresD_Add with (f := f) (argss := args :: l) (i := FM.remove f m).
        rewrite starred_cons.
        rewrite SH.impuresD_Add with (f := f) (argss := l) (i := FM.remove f m) (i' := m).
        heq_canceler.
        intro. repeat (rewrite MF.FACTS.add_o || rewrite MF.FACTS.remove_o). destruct (MF.FACTS.eq_dec f y); subst; auto.
        rewrite MF.FACTS.remove_in_iff. intro. intuition; congruence.
        intro. repeat (rewrite MF.FACTS.add_o || rewrite MF.FACTS.remove_o). destruct (MF.FACTS.eq_dec f y); subst; auto.
        rewrite MF.FACTS.remove_in_iff. intro. intuition; congruence. }
      { rewrite SH.impuresD_Add with (f := f) (argss := args :: nil) (i := m).
        rewrite starred_cons.
        heq_canceler.
        intro. repeat (rewrite MF.FACTS.add_o || rewrite MF.FACTS.remove_o). destruct (MF.FACTS.eq_dec f y); subst; auto.
        intro. destruct H0. apply MF.FACTS.find_mapsto_iff in H0; congruence. }
    Qed.

    Lemma cancel_in_order_common : forall
      (U G : env types)
      (cs : codeSpec (tvarD types pcType) (tvarD types stateType))
      (bound : nat) (summ : Facts Prover) (e : exprs types)
      (n : nat) (ls : list (exprs types * nat)),
      (forall (acc rem : MM.mmap (exprs types)) (sub : U.Subst types)
        (L R : MM.mmap (exprs types)) (S : U.Subst types) progress,
        U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) sub ->
        U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) S ->
        U.Subst_equations funcs U G S ->
        Valid Prover_correct U G summ ->
        cancel_in_order bound summ ls acc rem sub progress = Some (L, R, S) ->
        allb
        (fun v : list (expr types) * func =>
          match nth_error (typeof_preds preds) (snd v) with
            | Some ts =>
              all2
              (is_well_typed (typeof_funcs funcs) (typeof_env U)
                (typeof_env G)) (map (U.exprInstantiate S) (fst v)) ts
            | None => false
          end) ls = true ->
        SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) acc = true ->
        SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) rem = true ->
        forall P Q,
          himp funcs preds U G cs
          (Star (SH.impuresD pcType stateType (impuresInstantiate S R)) P)
          (Star (SH.impuresD pcType stateType (impuresInstantiate S L)) Q) ->
          himp funcs preds U G cs
          (Star (SH.impuresD pcType stateType (impuresInstantiate S rem)) P)
          (Star
            (Star
              (SH.starred
                (fun v : list (expr types) * func =>
                  Func (snd v) (map (U.exprInstantiate S) (fst v))) ls Emp)
              (SH.impuresD pcType stateType (impuresInstantiate S acc))) Q)) ->
      forall (acc rem : MM.mmap (exprs types)) (sub : U.Subst types)
        (L R : MM.mmap (exprs types)) (S : U.Subst types) progress,
        U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) sub ->
        U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) S ->
        U.Subst_equations funcs U G S ->
        Valid Prover_correct U G summ ->
        SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) acc = true ->
        SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) rem = true ->
        forall P Q,
          himp funcs preds U G cs
          (Star (SH.impuresD pcType stateType (impuresInstantiate S R)) P)
          (Star (SH.impuresD pcType stateType (impuresInstantiate S L)) Q) ->
          forall p : predicate types pcType stateType,
            nth_error preds n = Some p ->
            all2 (is_well_typed (typeof_funcs funcs) (typeof_env U) (typeof_env G))
            (map (U.exprInstantiate S) e) (typeof_pred p) = true ->
            allb
            (fun v : list (expr types) * func =>
              match nth_error (typeof_preds preds) (snd v) with
                | Some ts =>
                  all2
                  (is_well_typed (typeof_funcs funcs) (typeof_env U) (typeof_env G))
                  (map (U.exprInstantiate S) (fst v)) ts
                | None => false
              end) ls = true ->
            cancel_in_order bound summ ls (MM.mmap_add n e acc) rem sub progress = Some (L, R, S) ->
            himp funcs preds U G cs
            (Star (SH.impuresD pcType stateType (impuresInstantiate S rem)) P)
            (Star (Star
              (SH.SE.Star (Func n (map (U.exprInstantiate S) e))
                (SH.starred
                  (fun v : list (expr types) * func =>
                    Func (snd v) (map (U.exprInstantiate S) (fst v))) ls Emp))
              (SH.impuresD pcType stateType (impuresInstantiate S acc))) Q).
    Proof.
      intros.
      assert (allb (fun v : list (expr types) * func => WellTyped_sexpr (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) (Func (pcType := pcType) (stateType := stateType) (snd v) (fst v))) ls = true).
      { eapply allb_impl. eauto. simpl. intros. destruct (nth_error (typeof_preds preds) (snd x)); auto.
        rewrite all2_map_1 in H11. eapply all2_impl; try eassumption. intros.
        simpl in *. rewrite <- U.exprInstantiate_WellTyped in H12; eauto. }
      assert (SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
        (typeof_env U) (typeof_env G) (MM.mmap_add n e acc) = true).
      { eapply WellTyped_impures_mmap_add. eauto. rewrite nth_error_typeof_preds. rewrite H7. simpl.
        unfold typeof_pred. rewrite all2_map_1 in H8. eapply all2_impl. eauto. simpl.
        intros. rewrite <- U.exprInstantiate_WellTyped in H12; eauto. }
      generalize H10. eapply cancel_in_order_PureFacts in H10; eauto. intro.
      eapply H in H13; eauto. intuition.
      rewrite H13.
      do 2 rewrite SEP_UFACTS.impuresD_forget_impuresInstantiate by eassumption.
      rewrite impuresD_mmap_add. rewrite Func_forget_exprInstantiate by eassumption.
      rewrite heq_star_comm with (Q := SH.starred
        (fun v : list (expr types) * func =>
          Func (snd v) (map (U.exprInstantiate S) (fst v))) ls Emp).
      repeat rewrite heq_star_assoc. reflexivity.
    Qed.

    (** cancel_in_order ls acc rem = (l,r,sub) ->
     ** r ===> l ->
     ** rem ===> ls * acc
     **)
    Lemma cancel_in_orderOk : forall U G cs bound summ ls acc rem sub L R S progress,
      let tf := typeof_funcs funcs in
      let tp := SE.typeof_preds preds in
      let tU := typeof_env U in
      let tG := typeof_env G in
      U.Subst_WellTyped tf tU tG sub ->
      U.Subst_WellTyped tf tU tG S ->
      U.Subst_equations funcs U G S ->
      Valid Prover_correct U G summ ->
      cancel_in_order bound summ ls acc rem sub progress = Some (L, R, S) ->
      allb (fun v => SE.WellTyped_sexpr tf tp tU tG
        (Func (pcType := pcType) (stateType := stateType) (snd v) (map (@U.exprInstantiate _ S) (fst v)))) ls = true ->
      SH.WellTyped_impures tf tp tU tG acc = true ->
      SH.WellTyped_impures tf tp tU tG rem = true ->
      forall P Q,
      himp funcs preds U G cs
        (Star (SH.impuresD _ _ (impuresInstantiate S R)) P)
        (Star (SH.impuresD _ _ (impuresInstantiate S L)) Q) ->
      himp funcs preds U G cs
        (Star (SH.impuresD _ _ (impuresInstantiate S rem)) P)
        (Star (Star (SH.starred (fun v => (Func (snd v) (map (@U.exprInstantiate _ S) (fst v)))) ls Emp)
                    (SH.impuresD _ _ (impuresInstantiate S acc))) Q).
    Proof.
      induction ls; simpl; intros.
      { destruct progress; try congruence. inversion H3; clear H3; subst.
        repeat rewrite starred_nil. rewrite heq_star_emp_l. auto. }
      { rewrite starred_cons. rewrite nth_error_typeof_preds in H4. destruct a; simpl in *.
        repeat match goal with
                 | H : context [ option_map _ ?X ] |- _ =>
                   (consider X; simpl in *; try congruence); [ intros ]
                 | [ H : match ?X with _ => _ end = _ |- _ ] =>
                   (consider X; intros; try congruence); [ intros ]
                 | [ H : match ?X with
                           | Some _ => _ | None => _
                         end = _ |- _ ] =>
                 consider X; intros
               end; simpl in *; subst.
        { assert (all2 (is_well_typed (typeof_funcs funcs) (typeof_env U) (typeof_env G)) e (SDomain p) = true).
          { rewrite all2_map_1 in H8. eapply all2_impl. eapply H8. intros. simpl in *.
            rewrite <- U.exprInstantiate_WellTyped in H10; eauto. }
          assert (List.Forall (fun r : list (expr types) =>
            all2 (is_well_typed (typeof_funcs funcs) (typeof_env U) (typeof_env G)) r (SDomain p) = true) l).
          { eapply SH.WellTyped_impures_eq in H6; eauto. destruct l. constructor.
            rewrite nth_error_typeof_preds in *. rewrite H3 in H6. revert H6.
            generalize (e0 :: l). simpl. clear. induction l; simpl; intros; auto.
            consider (all2 (is_well_typed (typeof_funcs funcs) (typeof_env U) (typeof_env G)) a (typeof_pred p)); intros.
            constructor; auto. }
          generalize H11. eapply unify_remove_PureFacts in H11; eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs.
          intuition.
          assert (allb (fun v : list (expr types) * func =>
            WellTyped_sexpr (typeof_funcs funcs) (typeof_preds preds)
            (typeof_env U) (typeof_env G) (Func (pcType := pcType) (stateType := stateType) (snd v) (fst v))) ls = true).
          { eapply allb_impl. eassumption. simpl. intros.
            destruct (nth_error (typeof_preds preds) (snd x)); auto.
            rewrite all2_map_1 in H16. eapply all2_impl. eauto. simpl. intros.
            rewrite <- U.exprInstantiate_WellTyped in H18; eauto. }
          assert (SH.WellTyped_impures (typeof_funcs funcs) (typeof_preds preds)
            (typeof_env U) (typeof_env G) (FM.add n l0 rem) = true).
          { eapply WellTyped_impures_add; eauto.
            rewrite nth_error_typeof_preds in *. rewrite H3. simpl. clear - H17.
            unfold typeof_pred in *. induction H17; simpl; think; auto. }
          generalize H12. eapply cancel_in_order_PureFacts in H12; eauto. intuition.
          do 2 rewrite SEP_UFACTS.impuresD_forget_impuresInstantiate by eassumption.
          assert (MM.PROPS.Add n l (FM.remove (elt:=list (exprs types)) n rem) rem).
          { red. intro. rewrite MF.FACTS.add_o. rewrite MF.FACTS.remove_o.
            destruct (MF.FACTS.eq_dec n y); subst; auto. }
          assert (~FM.In (elt:=list (exprs types)) n (FM.remove (elt:=list (exprs types)) n rem)).
          { rewrite MF.FACTS.remove_in_iff. intro. intuition; congruence. }
          rewrite SH.impuresD_Add with (i := FM.remove n rem) (i' := rem) (f := n) (argss := l) by eassumption.
          rewrite heq_star_assoc.
          rewrite Func_forget_exprInstantiate by eassumption.
          eapply unify_removeOk with (cs := cs) in H14; [ | | | | eassumption | | | | | | ];
            eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs.
          destruct H14. repeat rewrite heq_star_assoc. rewrite <- H14. rewrite heq_star_comm. rewrite <- SH.starred_base.
          reflexivity.
          eapply IHls in H19; eauto.
          do 2 rewrite SEP_UFACTS.impuresD_forget_impuresInstantiate in H19 by eassumption.
          rewrite heq_star_assoc in H19. rewrite <- H19.
          rewrite SH.impuresD_Add with (i := FM.remove n rem) (i' := FM.add n l0 rem) (f := n) (argss := l0).
          rewrite SH.starred_base. rewrite heq_star_comm. rewrite heq_star_assoc. reflexivity.
          { intro. repeat (rewrite MF.FACTS.add_o || rewrite MF.FACTS.remove_o). destruct (MF.FACTS.eq_dec n y); auto. }
          { rewrite MF.FACTS.remove_in_iff. intro. intuition; congruence. } }
        { eapply cancel_in_order_common in H11; eauto. }
        { eapply cancel_in_order_common in H10; eauto. } }
    Qed.

    Lemma fold_left_insert_perm : forall e a k,
      Permutation.Permutation (map (fun x => (x,k)) e ++ a)
      (fold_left
        (fun (acc : cancel_list) (args : exprs types) =>
          Ordering.insert_in_order (exprs types * func) meta_order_funcs
          (args, k) acc) e a).
    Proof.
      clear. induction e; simpl.
      eauto.
      intros. rewrite <- IHe; clear IHe.
      destruct (@Ordering.insert_in_order_inserts _ meta_order_funcs (a,k) a0). destruct H.
      intuition subst. rewrite H0.
      rewrite <- app_ass. rewrite <- app_ass.
      eapply Permutation.Permutation_middle.
    Qed.

    (** TODO: it would be good to keep this somewhat general with respect to the order so that we can play around with it
     ** NOTE: return None if we don't make progress
     **)
    Definition sepCancel (bound : nat) (summ : Facts Prover) (l r : SH.SHeap types pcType stateType) (s : U.Subst types)
      (prog : bool) : option (SH.SHeap _ _ _ * SH.SHeap _ _ _ * U.Subst types) :=
      let ordered_r := order_impures (SH.impures r) in
      let sorted_l := FM.map (fun v => Ordering.sort _ meta_order_args v) (SH.impures l) in
      match
        cancel_in_order bound summ ordered_r (MM.empty _) sorted_l s prog
        with
        | None => None
        | Some (rf, lf, sub) =>
          Some ({| SH.impures := lf ; SH.pures := SH.pures l ; SH.other := SH.other l |},
                {| SH.impures := rf ; SH.pures := SH.pures r ; SH.other := SH.other r |},
                sub)
      end.

    Theorem sepCancel_PuresPrem : forall funcs U G bound summ l r l' r' s s' b,
      sepCancel bound summ l r s b = Some (l', r', s') ->
      AllProvable funcs U G (SH.pures l) ->
      AllProvable funcs U G (SH.pures l').
    Proof.
      unfold sepCancel. intros.
      destruct (cancel_in_order bound summ (order_impures (SH.impures r))
              (MM.empty (exprs types))
              (FM.map
                 (fun v : list (exprs types) =>
                  Ordering.sort (exprs types) meta_order_args v)
                 (SH.impures l)) s). destruct p. destruct p. inversion H.
      auto. congruence.
    Qed.

    Lemma starred_ext : forall T U G cs F F' (ls : list T) B,
      (forall x, heq funcs preds U G cs (F x) (F' x)) ->
      heq funcs preds U G cs (SH.starred F ls B) (SH.starred F' ls B).
    Proof. clear.
      induction ls; intros; repeat (rewrite starred_nil || rewrite starred_cons).
      reflexivity. rewrite H. rewrite IHls; auto. reflexivity.
    Qed.

    Lemma Equiv_map : forall T (E : T -> T -> Prop) (F : T -> T) a,
      (forall x, E (F x) x) ->
      FM.Equiv E (FM.map F a) a.
    Proof. clear.
      red; intros. split; intros.
      rewrite MF.PROPS.F.map_in_iff. tauto.
      apply MF.FACTS.map_mapsto_iff in H0. destruct H0. intuition; subst.
      apply MF.FACTS.find_mapsto_iff in H1. apply MF.FACTS.find_mapsto_iff in H3.
      rewrite H1 in H3; inversion H3; auto.
    Qed.

    Lemma allb_permutation : forall T F (a b : list T),
      Permutation.Permutation a b ->
      allb F a = allb F b.
    Proof. clear.
      induction 1; simpl; auto.
      destruct (F x); auto.
      destruct (F x); destruct (F y); auto.
      rewrite IHPermutation1; auto.
    Qed.

    Lemma fold_left_fold_left_insert_perm : forall l (B : cancel_list),
      Permutation.Permutation
      (B ++ fold_left (fun (a : cancel_list) (p : FM.key * list (list (expr types))) =>
        fold_left (fun (acc : cancel_list) (args : list (expr types)) =>
          Ordering.insert_in_order (list (expr types) * func) meta_order_funcs (args, fst p) acc) (snd p) a) l nil)
      (fold_left (fun (a : cancel_list) (p : FM.key * list (list (expr types))) =>
        fold_left (fun (acc : cancel_list) (args : list (expr types)) =>
          Ordering.insert_in_order (list (expr types) * func) meta_order_funcs (args, fst p) acc) (snd p) a) l B).
    Proof.
      induction l; simpl; intros.
      rewrite app_nil_r; reflexivity.
      etransitivity. 2: eapply IHl. destruct a; simpl.
      symmetry.
      rewrite Permutation.Permutation_app_tail.
      2: symmetry; apply (@fold_left_insert_perm l0 B k).
      rewrite Permutation.Permutation_app_tail.
      2: apply Permutation.Permutation_app_comm with (l' := B). rewrite app_ass.
      apply Permutation.Permutation_app_head.
      etransitivity. 2: eapply IHl. apply Permutation.Permutation_app_tail.
      etransitivity. 2: apply fold_left_insert_perm. rewrite app_nil_r; auto.
    Qed.

    Lemma WellTyped_empty : forall tf tp tU tG,
      SH.WellTyped_impures tf tp tU tG (MM.empty (exprs types)) = true.
    Proof. clear.
      intros. rewrite SH.WellTyped_impures_spec_eq. rewrite MF.PROPS.fold_Empty; auto with typeclass_instances.
      apply FM.empty_1.
    Qed.

    Lemma order_impures_WellTyped : forall tf tp tU tG imp,
      SH.WellTyped_impures tf tp tU tG imp = true ->
      allb (fun v : list (expr types) * func => WellTyped_sexpr tf tp tU tG
        (Func (pcType := pcType) (stateType := stateType) (snd v) (fst v))) (order_impures imp) = true.
    Proof. clear.
      intros. unfold order_impures.
      rewrite SH.WellTyped_impures_spec_eq in H.
      rewrite FM.fold_1 in *. revert H. unfold exprs in *. generalize true at 2 4.
      induction (FM.elements (elt:=list (list (expr types))) imp); auto; intros.
      simpl in *.
      assert (fold_left
        (fun (a : bool) (p : FM.key * list (list (expr types))) =>
          (a &&
            match snd p with
              | nil => true
              | _ :: _ =>
                match nth_error tp (fst p) with
                  | Some ts =>
                    allb
                    (fun args : list (expr types) =>
                      all2
                      (is_well_typed tf
                        tU tG) args ts)
                    (snd p)
                  | None => false
                end
            end)%bool) l false = false).
      { clear. induction l; simpl; auto. }
      destruct b; simpl in H; try congruence.
      destruct a. destruct l0; simpl in *. eauto.
      consider (nth_error tp k); intros; try congruence.
      consider (all2 (is_well_typed tf tU tG) l0 t); intros; try congruence.
      consider (allb
        (fun args : list (expr types) =>
          all2
          (is_well_typed tf tU tG) args t) l1); intros; try congruence.
      rewrite <- IHl by assumption.
      erewrite allb_permutation.
      2: symmetry; apply fold_left_fold_left_insert_perm.
      rewrite allb_app. erewrite <- allb_permutation.
      2: eapply fold_left_insert_perm.
      rewrite allb_app. rewrite allb_map. simpl. unfold exprs in *.
      think. simpl. auto.
    Qed.

    Lemma map_sort_WellTyped : forall C tf tp tU tG imp,
      SH.WellTyped_impures tf tp tU tG imp = true ->
      SH.WellTyped_impures tf tp tU tG
      (FM.map (fun v : list (exprs types) => Ordering.sort (exprs types) C v) imp) = true.
    Proof. clear.
      intros. eapply SH.WellTyped_impures_eq; intros. rewrite MF.FACTS.map_o in H0.
      consider (FM.find (elt:=list (exprs types)) k imp); simpl in *; try congruence; intros.
      inversion H1; clear H1; subst.
      eapply SH.WellTyped_impures_eq in H0. 2: eassumption.
      destruct l; auto. destruct (nth_error tp k); try contradiction.
      erewrite allb_permutation in H0. 2: symmetry; eapply Ordering.sort_permutation.
      rewrite H0. destruct (Ordering.sort (exprs types) C (e :: l)); auto.
    Qed.

    Theorem sepCancel_PureFacts : forall tU tG bound summ l r l' r' s s' b,
      let tf := typeof_funcs funcs in
      let tp := typeof_preds preds in
      sepCancel bound summ l r s b = Some (l', r', s') ->
      U.Subst_WellTyped tf tU tG s ->
      SH.WellTyped_sheap tf tp tU tG l = true ->
      SH.WellTyped_sheap tf tp tU tG r = true ->
         U.Subst_WellTyped tf tU tG s'
      /\ SH.WellTyped_sheap tf tp tU tG l' = true
      /\ SH.WellTyped_sheap tf tp tU tG r' = true.
    Proof.
      unfold sepCancel. intros.
      consider (cancel_in_order bound summ (order_impures (SH.impures r))
              (MM.empty (exprs types))
              (FM.map
                 (fun v : list (exprs types) =>
                  Ordering.sort (exprs types) meta_order_args v)
                 (SH.impures l)) s b); intros.
      destruct p. destruct p. inversion H3; clear H3; subst.
      rewrite SH.WellTyped_sheap_eq in H1.
      rewrite SH.WellTyped_sheap_eq in H2. think.
      eapply cancel_in_order_PureFacts_weak in H; try eassumption;
        eauto using order_impures_WellTyped, WellTyped_empty, map_sort_WellTyped.
      intuition.
      rewrite SH.WellTyped_sheap_eq; simpl; think; auto.
      rewrite SH.WellTyped_sheap_eq; simpl; think; auto.
      congruence.
    Qed.

    Theorem sepCancel_correct : forall U G cs bound summ l r l' r' sub sub' b,
      U.Subst_WellTyped (typeof_funcs funcs) (typeof_env U) (typeof_env G) sub' ->
      SH.WellTyped_sheap (typeof_funcs funcs) (typeof_preds preds) (typeof_env U) (typeof_env G) l = true ->
      SH.WellTyped_sheap (typeof_funcs funcs) (typeof_preds preds) (typeof_env U) (typeof_env G) r = true ->
      Valid Prover_correct U G summ ->
      sepCancel bound summ l r sub' b = Some (l', r', sub) ->
      himp funcs preds U G cs (SH.sheapD l') (SH.sheapD r') ->
      U.Subst_equations funcs U G sub ->
      himp funcs preds U G cs (SH.sheapD l) (SH.sheapD r).
    Proof.
      destruct l; destruct r. unfold sepCancel. simpl. intros.
      repeat match goal with
               | [ H : match ?X with _ => _ end = _ |- _ ] =>
                 revert H; case_eq X; intros; try congruence
               | [ H : prod _ _ |- _ ] => destruct H
               | [ H : (_,_) = (_,_) |- _ ] => inversion H; clear H; subst
               | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
             end.
      do 2 rewrite SH.sheapD_def. simpl.
      eapply cancel_in_orderOk with (cs := cs) (U := U) (G := G)
        (P := Star (SH.starred (SH.SE.Inj (stateType:=stateType)) pures SH.SE.Emp)
                   (SH.starred (SH.SE.Const (stateType:=stateType)) other SH.SE.Emp))
        (Q := Star (SH.starred (SH.SE.Inj (stateType:=stateType)) pures0 SH.SE.Emp)
                   (SH.starred (SH.SE.Const (stateType:=stateType)) other0 SH.SE.Emp)) in H3;
        eauto using typeof_env_WellTyped_env, typeof_funcs_WellTyped_funcs, U.Subst_empty_WellTyped.
      { clear H4.
        do 2 rewrite impuresD_forget_impuresInstantiate in H3 by eassumption.
        rewrite SH.impuresD_Empty with (i := MM.empty _) in H3.
        rewrite starred_ext with (ls := order_impures impures0) in H3. 2: intro; apply Func_forget_exprInstantiate; auto.
        rewrite SH.impuresD_Equiv with (b := impures) in H3.
        rewrite H3. repeat rewrite heq_star_assoc. apply himp_star_frame.
        rewrite <- order_impures_D. reflexivity.
        rewrite heq_star_emp_l. reflexivity.

        red.
        symmetry. erewrite Equiv_map. reflexivity. intros. eapply Ordering.sort_permutation.
        apply FM.empty_1. }
      { eapply U.Subst_equations_WellTyped; auto. }
      { rewrite SH.WellTyped_sheap_eq in H1. think. simpl in *.
        eapply order_impures_WellTyped in H1.
        eapply allb_impl; try eassumption. simpl; intros.
        destruct (nth_error (typeof_preds preds) (snd x)); auto.
        rewrite all2_map_1. erewrite all2_impl. 2: eauto. auto.
        simpl; intros.
        rewrite <- U.exprInstantiate_WellTyped; auto using U.Subst_equations_WellTyped. }
      { apply WellTyped_empty. }
      { apply map_sort_WellTyped. rewrite SH.WellTyped_sheap_eq in H0. think. simpl in *. auto. }
      { do 2 (rewrite SH.sheapD_def in H4; simpl in H4).
        do 2 rewrite impuresD_forget_impuresInstantiate by eassumption. eapply H4. }
    Qed.

  End env.

End Make.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect CRelationClasses.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config Universes uGraph.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICOnFreeVars
     PCUICLiftSubst PCUICEquality PCUICUnivSubst
     PCUICCases PCUICCumulativity PCUICTyping PCUICReduction PCUICWeakeningEnv PCUICWeakeningEnvTyp
     PCUICClosed PCUICPosition PCUICGuardCondition PCUICUnivSubstitutionConv.

Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.

(** * Universe Substitution lemmas for typing derivations. *)

Local Set Keyed Unification.

Set Default Goal Selector "!".

Local Ltac aa := rdest; eauto with univ_subst.

Section SubstIdentity.
  Context `{cf:checker_flags}.

Lemma compare_universe_subst_instance pb {Σ : global_env_ext} univs u :
  valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) ->
  RelationClasses.subrelation (compare_universe pb Σ)
    (fun x y : Universe.t =>
    compare_universe pb (global_ext_constraints (Σ.1, univs)) (subst_instance_univ u x)
      (subst_instance_univ u y)).
Proof using Type.
  intros v.
  destruct pb; cbn.
  - now apply eq_universe_subst_instance.
  - now apply leq_universe_subst_instance.
Qed.

Lemma cumulSpec_subst_instance (Σ : global_env_ext) Γ u A B pb univs :
  valid_constraints (global_ext_constraints (Σ.1, univs))
                    (subst_instance_cstrs u Σ) ->
  Σ ;;; Γ ⊢ A ≤s[pb] B ->
  (Σ.1,univs) ;;; subst_instance u Γ ⊢ subst_instance u A ≤s[pb] subst_instance u B.
Proof.
  intros e H. unfold cumulSpec.
  revert pb Γ A B H e.
  apply: cumulSpec0_ind_all; intros; cbn; try solve [econstructor; intuition eauto].
  - rewrite subst_instance_subst. solve [econstructor].
  - rewrite subst_instance_subst. solve [econstructor].
  - rewrite subst_instance_lift. eapply cumul_rel.
    unfold subst_instance.
    unfold option_map in *. destruct (nth_error Γ) eqn:E; inversion H.
    unfold map_context. rewrite nth_error_map E. cbn.
    rewrite map_decl_body. destruct c. cbn in *. subst.
    reflexivity.
  - rewrite subst_instance_mkApps. cbn.
    rewrite iota_red_subst_instance.
    change (bcontext br) with (bcotext (map_branch (subst_instance u) br)).
    eapply cumul_iota; eauto with pcuic.
    * rewrite nth_error_map H //.
    * simpl. now len.
  - rewrite !subst_instance_mkApps. cbn.
    eapply cumul_fix.
    + unfold unfold_fix in *. destruct (nth_error mfix idx) eqn:E.
      * inversion H.
        rewrite nth_error_map E. cbn.
        destruct d. cbn in *. cbn in *; try congruence.
        f_equal. f_equal.
        now rewrite subst_instance_subst fix_subst_instance_subst.
      * inversion H.
    + unfold is_constructor in *.
      destruct (nth_error args narg) eqn:E; inversion H0; clear H0.
      rewrite nth_error_map E. cbn.
     eapply isConstruct_app_subst_instance.
  - rewrite !subst_instance_mkApps.
    unfold unfold_cofix in *. destruct (nth_error mfix idx) eqn:E.
    + inversion H.
    eapply cumul_cofix_case.  fold subst_instance_constr.
    unfold unfold_cofix.
    rewrite nth_error_map E. cbn.
    rewrite subst_instance_subst.
    now rewrite cofix_subst_instance_subst.
    + cbn.
    inversion H.
  - unfold unfold_cofix in *.
    destruct nth_error eqn:E; inversion H.
    rewrite !subst_instance_mkApps.
    eapply cumul_cofix_proj. fold subst_instance.
    unfold unfold_cofix.
    rewrite nth_error_map. destruct nth_error; cbn.
     1: rewrite subst_instance_subst cofix_subst_instance_subst.
    all: now inversion E.
  - rewrite subst_instance_two. solve [econstructor; eauto].
  - rewrite !subst_instance_mkApps.
    eapply cumul_proj. now rewrite nth_error_map H.
  - eapply cumul_Trans; intuition.
    * rewrite on_free_vars_ctx_subst_instance; eauto.
    * rewrite on_free_vars_subst_instance. unfold is_open_term.
      replace #|Γ@[u]| with #|Γ|; eauto. rewrite map_length; eauto.
  - eapply cumul_Evar. eapply All2_map.
    eapply All2_impl. 1: tea. cbn; intros. eapply X0.2; eauto.
  - eapply cumul_Case; try solve [intuition; eauto].
    * destruct X as [X [Xuni [Xcont [_ Xret]]]]. repeat split; eauto; cbn.
      + apply All2_map. eapply All2_impl. 1: tea. cbn; intros. eapply X3.2; eauto.
      + apply precompose_subst_instance. eapply R_universe_instance_impl; eauto.
        now apply eq_universe_subst_instance.
      + rewrite subst_instance_app inst_case_predicate_context_subst_instance in Xret.
        eapply Xret; eauto.
    * eapply All2_map. eapply All2_impl. 1: tea. cbn; intros.
      repeat split; eauto; intuition.
      rewrite subst_instance_app inst_case_branch_context_subst_instance in X1; eauto.
  - eapply cumul_Fix. apply All2_map. eapply All2_impl. 1: tea.
    cbn; intros; intuition.
    rewrite subst_instance_app fix_context_subst_instance in X0; eauto.
  - eapply cumul_CoFix. apply All2_map. eapply All2_impl. 1: tea.
    cbn; intros; intuition.
    rewrite subst_instance_app fix_context_subst_instance in X0; eauto.
 - repeat rewrite subst_instance_mkApps. eapply cumul_Ind.
    * apply precompose_subst_instance_global.
      rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto.
      { now apply eq_universe_subst_instance. }
      { now apply compare_universe_subst_instance. }
    * eapply All2_map. eapply All2_impl. 1: tea. cbn; intros.
      eapply X0.2; eauto.
 - repeat rewrite subst_instance_mkApps. eapply cumul_Construct.
    * apply precompose_subst_instance_global. cbn.
      rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto.
      { now apply eq_universe_subst_instance. }
      { now apply compare_universe_subst_instance. }
    * eapply All2_map. eapply All2_impl. 1: tea. cbn; intros.
      eapply X0.2; eauto.
  - eapply cumul_Sort. now apply compare_universe_subst_instance.
  - eapply cumul_Const. apply precompose_subst_instance.
    eapply R_universe_instance_impl; eauto.
    now apply compare_universe_subst_instance.
Defined.

Lemma convSpec_subst_instance (Σ : global_env_ext) Γ u A B univs :
valid_constraints (global_ext_constraints (Σ.1, univs))
                  (subst_instance_cstrs u Σ) ->
  Σ ;;; Γ |- A =s B ->
  (Σ.1,univs) ;;; subst_instance u Γ |- subst_instance u A =s subst_instance u B.
Proof using Type.
  apply cumulSpec_subst_instance.
Qed.

Lemma conv_decls_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs d d' :
  valid_constraints (global_ext_constraints (Σ.1, univs))
    (subst_instance_cstrs u Σ) ->
  conv_decls cumulSpec0 Σ Γ Γ' d d' ->
  conv_decls cumulSpec0 (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ')
    (subst_instance u d) (subst_instance u d').
Proof using Type.
  intros valid Hd; depelim Hd; constructor; tas;
    eapply convSpec_subst_instance; tea.
Qed.

Lemma cumul_decls_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs d d' :
  valid_constraints (global_ext_constraints (Σ.1, univs))
    (subst_instance_cstrs u Σ) ->
  cumul_decls cumulSpec0 Σ Γ Γ' d d' ->
  cumul_decls cumulSpec0 (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ')
    (subst_instance u d) (subst_instance u d').
Proof using Type.
  intros valid Hd; depelim Hd; constructor; tas;
    (eapply convSpec_subst_instance || eapply cumulSpec_subst_instance); tea.
Qed.

Lemma conv_ctx_subst_instance (Σ : global_env_ext) {Γ Γ'} u univs :
  valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) ->
  conv_context cumulSpec0 Σ Γ Γ' ->
  conv_context cumulSpec0 (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ').
Proof using Type.
  intros valid.
  intros; eapply All2_fold_map, All2_fold_impl; tea => ? ? d d'.
  now eapply conv_decls_subst_instance.
Qed.

Lemma subst_instance_ws_cumul_ctx_pb_rel (Σ : global_env_ext) {Γ Γ'} u univs :
  valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) ->
  cumul_context cumulSpec0 Σ Γ Γ' ->
  cumul_context cumulSpec0 (Σ.1, univs) (subst_instance u Γ) (subst_instance u Γ').
Proof using Type.
  intros valid.
  intros; eapply All2_fold_map, All2_fold_impl; tea => ? ? d d'.
  now eapply cumul_decls_subst_instance.
Qed.

Hint Resolve subst_instance_cstrs_two
     satisfies_equal_sets satisfies_subsets : univ_subst.
Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext : univ_subst.
Hint Unfold CS.For_all : univ_subst.
Hint Resolve consistent_ext_trans : univ_subst.
Hint Resolve consistent_instance_valid_constraints : univ_subst.
Hint Rewrite subst_instance_extended_subst : substu.
Hint Rewrite expand_lets_subst_instance : substu.
Hint Rewrite subst_instance_subst_context subst_instance_lift_context
  subst_instance_lift subst_instance_mkApps
  subst_instance_subst
  subst_instance_it_mkProd_or_LetIn
  subst_instance_it_mkLambda_or_LetIn
  subst_instance_inds
  : substu.
Ltac substu := autorewrite with substu.
Hint Rewrite subst_instance_expand_lets_ctx : substu.
Hint Resolve subst_instance_wf_predicate
  subst_instance_wf_branch subst_instance_wf_branches : pcuic.
Hint Resolve All_local_env_over_subst_instance : univ_subst.
Hint Resolve declared_inductive_wf_ext_wk declared_inductive_wf_global_ext : pcuic.

Lemma typing_subst_instance :
  env_prop (fun Σ Γ t T => forall u univs,
                wf_ext_wk Σ ->
                consistent_instance_ext (Σ.1, univs) Σ.2 u ->
                (Σ.1,univs) ;;; subst_instance u Γ
                |- subst_instance u t : subst_instance u T)
          (fun Σ Γ => forall u univs,
          wf_ext_wk Σ ->
          consistent_instance_ext (Σ.1, univs) Σ.2 u ->
          wf_local(Σ.1,univs) (subst_instance u Γ)).
Proof using Type.
  apply typing_ind_env; intros Σ wfΣ Γ wfΓ; cbn  -[Universe.make] in *.
  - rewrite /subst_instance /=.
    induction 1.
    + constructor.
    + simpl. constructor; auto.
      eapply infer_typing_sort_impl; tea.
      intros Hty. eapply Hs; auto.
    + simpl. constructor; auto.
      ++ eapply infer_typing_sort_impl; tea.
         intros Hty. eapply Hs; auto.
      ++ apply Hc; auto.

  - intros n decl eq X u univs wfΣ' H. rewrite subst_instance_lift.
    rewrite map_decl_type. econstructor; aa.
    unfold subst_instance, map_context.
    now rewrite nth_error_map eq.
  - intros l X Hl u univs wfΣ' H.
    rewrite subst_instance_univ_super.
    + econstructor.
      * aa.
      * now apply wf_universe_subst_instance.
  - intros n t0 b s1 s2 X X0 X1 X2 X3 u univs wfΣ' H.
    rewrite product_subst_instance; aa. econstructor.
    + eapply X1; eauto.
    + eapply X3; eauto.
  - intros n t0 b s1 bty X X0 X1 X2 X3 u univs wfΣ' H.
    econstructor.
    + eapply X1; aa.
    + eapply X3; aa.
  - intros n b b_ty b' s1 b'_ty X X0 X1 X2 X3 X4 X5 u univs wfΣ' H.
    econstructor; eauto. eapply X5; aa.
  - intros t0 na A B s u X X0 X1 X2 X3 X4 X5 u0 univs wfΣ' H.
    rewrite subst_instance_subst. cbn. econstructor.
    + eapply X1; eauto.
    + eapply X3; eauto.
    + eapply X5; eauto.
  - intros. rewrite subst_instance_two. econstructor; [aa|aa|].
    clear X X0; cbn in *.
    eapply consistent_ext_trans; eauto.
  - intros. rewrite subst_instance_two. econstructor; [aa|aa|].
    clear X X0; cbn in *.
    eapply consistent_ext_trans; eauto.
  - intros. eapply meta_conv. 1: econstructor; aa.
    clear.
    unfold type_of_constructor; cbn.
    rewrite subst_instance_subst. f_equal.
    + unfold inds. induction #|ind_bodies mdecl|. 1: reflexivity.
      cbn. now rewrite IHn.
    + symmetry; apply subst_instance_two.

  - intros ci p c brs args u mdecl idecl isdecl hΣ hΓ indnp eqpctx wfp cup
      wfpctx pty Hpty Hcpc kelim
      IHctxi Hc IHc notCoFinite wfbrs hbrs i univs wfext cu.
    rewrite subst_instance_mkApps subst_instance_it_mkLambda_or_LetIn map_app.
    cbn.
    change (subst_instance i (preturn p)) with (preturn (subst_instance i p)).
    change (subst_instance i (pcontext p)) with (pcontext (subst_instance i p)).
    change (map_predicate _ _ _ _ _) with (subst_instance i p).
    rewrite subst_instance_case_predicate_context.
    eapply type_Case with (p:=subst_instance i p)
                          (ps:=subst_instance_univ i u); eauto with pcuic.
    3,4: constructor; eauto with pcuic.
    + rewrite -subst_instance_case_predicate_context - !subst_instance_app_ctx.
      eapply Hpty; eauto.
    + eapply IHc in cu => //.
      now rewrite subst_instance_mkApps map_app in cu.
    + simpl. eapply consistent_ext_trans; tea.
    + now rewrite -subst_instance_case_predicate_context -subst_instance_app_ctx.
    + cbn in *.
      eapply is_allowed_elimination_subst_instance; aa.
    + move: IHctxi. simpl.
      rewrite -subst_instance_app.
      rewrite -subst_instance_two_context.
      rewrite -[List.rev (subst_instance i _)]map_rev.
      clear -wfext cu. induction 1; try destruct t0; cbn; constructor; simpl; eauto.
      all:now rewrite -(subst_instance_subst_telescope i [_]).
    + rewrite -{1}(map_id (ind_ctors idecl)).
      eapply All2i_map. eapply All2i_impl; eauto.
      cbn -[case_branch_type case_branch_context subst_instance].
      intros k cdecl br (hctx & hcbctx & (hbod & ihbod) & hbty & ihbty).
      rewrite case_branch_type_fst.
      rewrite - !subst_instance_case_branch_context - !subst_instance_app_ctx.
      rewrite -subst_instance_case_predicate_context subst_instance_case_branch_type.
      repeat split; auto.
      * specialize (ihbod i univs wfext cu).
        cbn. eapply ihbod.
      * specialize (ihbty i univs wfext cu).
        cbn. eapply ihbty.
  - intros p c u mdecl idecl cdecl pdecl isdecl args X X0 X1 X2 H u0 univs wfΣ' H0.
    rewrite subst_instance_subst. cbn.
    rewrite !subst_instance_two.
    rewrite {4}/subst_instance /subst_instance_list /=.
    rewrite map_rev.
    econstructor; eauto. 2:now rewrite map_length.
    eapply X2 in H0; tas. rewrite subst_instance_mkApps in H0.
    eassumption.

  - intros mfix n decl H H0 H1 X X0 wffix u univs wfΣ'.
    rewrite (map_dtype _ (subst_instance u)). econstructor.
    + specialize (H1 u univs wfΣ' H2).
      rewrite subst_instance_app in H1.
      now eapply wf_local_app_inv in H1 as [].
    + now eapply fix_guard_subst_instance.
    + rewrite nth_error_map H0. reflexivity.
    + apply All_map, (All_impl X); simpl; intuition auto.
      eapply infer_typing_sort_impl with (tu := X1).
      intros [_ Hs]; now apply Hs.
    + eapply All_map, All_impl; tea.
      intros x [X1 X3].
      specialize (X3 u univs wfΣ' H2).
      rewrite (map_dbody (subst_instance u)) in X3.
      rewrite subst_instance_lift in X3.
      rewrite fix_context_length ?map_length in X0, X1, X3.
      rewrite (map_dtype _ (subst_instance u) x) in X3.
      rewrite subst_instance_app in X3.
      rewrite <- (fix_context_subst_instance u mfix).
      now len.
    + red; rewrite <- wffix.
      unfold wf_fixpoint, wf_fixpoint_gen.
      f_equal.
      { rewrite forallb_map. solve_all. cbn.
        destruct (dbody x) => //. }
      rewrite map_map_compose.
      now rewrite subst_instance_check_one_fix.

      - intros mfix n decl H H0 H1 X X0 wffix u univs wfΣ'.
      rewrite (map_dtype _ (subst_instance u)). econstructor.
      + specialize (H1 u univs wfΣ' H2).
        rewrite subst_instance_app in H1.
        now eapply wf_local_app_inv in H1 as [].
      + now eapply cofix_guard_subst_instance.
      + rewrite nth_error_map H0. reflexivity.
      + apply All_map, (All_impl X); simpl; intuition auto.
        eapply infer_typing_sort_impl with (tu := X1).
        intros [_ Hs]; now apply Hs.
      + eapply All_map, All_impl; tea.
        intros x [X1 X3].
        specialize (X3 u univs wfΣ' H2).
        rewrite (map_dbody (subst_instance u)) in X3.
        rewrite subst_instance_lift in X3.
        rewrite fix_context_length ?map_length in X0, X1, X3.
        rewrite (map_dtype _ (subst_instance u) x) in X3.
        rewrite subst_instance_app in X3.
        rewrite <- (fix_context_subst_instance u mfix).
        now len.
      + red; rewrite <- wffix.
        unfold wf_cofixpoint, wf_cofixpoint_gen.
        rewrite map_map_compose.
        now rewrite subst_instance_check_one_cofix.

  - econstructor; eauto.

  - intros t0 A B X X0 X1 X2 X3 X4 cum u univs wfΣ' H.
    econstructor.
    + eapply X2; aa.
    + eapply X4; aa.
    + eapply cumulSpec_subst_instance; aa.
Qed.

Lemma typing_subst_instance' Σ φ Γ t T u univs :
  wf_ext_wk (Σ, univs) ->
  (Σ, univs) ;;; Γ |- t : T ->
  consistent_instance_ext (Σ, φ) univs u ->
  (Σ, φ) ;;; subst_instance u Γ
            |- subst_instance u t : subst_instance u T.
Proof using Type.
  intros X X0 X1.
  eapply (typing_subst_instance (Σ, univs)); tas. apply X.
Qed.

Lemma typing_subst_instance_wf_local Σ φ Γ u univs :
  wf_ext_wk (Σ, univs) ->
  wf_local (Σ, univs) Γ ->
  consistent_instance_ext (Σ, φ) univs u ->
  wf_local (Σ, φ) (subst_instance u Γ).
Proof using Type.
  intros X X0 X1.
  eapply (env_prop_wf_local typing_subst_instance (Σ, univs)); tas. 1: apply X.
Qed.

Lemma typing_subst_instance'' Σ φ Γ t T u univs :
  wf_ext_wk (Σ, univs) ->
  (Σ, univs) ;;; Γ |- t : T ->
  consistent_instance_ext (Σ, φ) univs u ->
  (Σ, φ) ;;; subst_instance u Γ
            |- subst_instance u t : subst_instance u T.
Proof using Type.
  intros X X0 X1.
  eapply (typing_subst_instance (Σ, univs)); tas. 1: apply X.
Qed.

Lemma typing_subst_instance_ctx (Σ : global_env_ext) Γ t T ctx u :
  wf Σ.1 ->
  on_udecl_prop Σ (Polymorphic_ctx ctx) ->
  (Σ.1, Polymorphic_ctx ctx) ;;; Γ |- t : T ->
  consistent_instance_ext Σ (Polymorphic_ctx ctx) u ->
  Σ ;;; subst_instance u Γ
            |- subst_instance u t : subst_instance u T.
Proof using Type.
  destruct Σ as [Σ φ]. intros X X0 X1.
  eapply typing_subst_instance''; tea.
  split; tas.
Qed.

Lemma typing_subst_instance_decl Σ Γ t T c decl u :
  wf Σ.1 ->
  lookup_env Σ.1 c = Some decl ->
  (Σ.1, universes_decl_of_decl decl) ;;; Γ |- t : T ->
  consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
  Σ ;;; subst_instance u Γ
            |- subst_instance u t : subst_instance u T.
Proof using Type.
  destruct Σ as [Σ φ]. intros X X0 X1 X2.
  eapply typing_subst_instance''; tea.
  split; tas.
  eapply weaken_lookup_on_global_env'; tea.
Qed.

Lemma wf_local_instantiate_poly {Σ ctx Γ u} :
  wf_ext (Σ.1, Polymorphic_ctx ctx) ->
  consistent_instance_ext Σ (Polymorphic_ctx ctx) u ->
  wf_local (Σ.1, Polymorphic_ctx ctx) Γ ->
  wf_local Σ (subst_instance u Γ).
Proof using Type.
  intros wfΣ Huniv wf.
  epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty.
  - now simpl.
  - eapply typing_subst_instance_ctx in ty;
    cbn; eauto using typing_wf_local.
    * apply wfΣ.
    * destruct wfΣ. now eapply on_udecl_on_udecl_prop.
Qed.

Lemma wf_local_instantiate {Σ} {decl : global_decl} {Γ u c} :
  wf Σ.1 ->
  lookup_env Σ.1 c = Some decl ->
  consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
  wf_local (Σ.1, universes_decl_of_decl decl) Γ ->
  wf_local Σ (subst_instance u Γ).
Proof using Type.
  intros wfΣ Hdecl Huniv wf.
  epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty.
  - now simpl.
  - eapply typing_subst_instance_decl in ty;
    cbn; eauto using typing_wf_local.
Qed.

Lemma isType_subst_instance_decl Σ Γ T c decl u :
  wf Σ.1 ->
  lookup_env Σ.1 c = Some decl ->
  isType (Σ.1, universes_decl_of_decl decl) Γ T ->
  consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
  isType Σ (subst_instance u Γ) (subst_instance u T).
Proof using Type.
  intros wfΣ look isty cu.
  eapply infer_typing_sort_impl with (tu := isty).
  intros Hs; now eapply (typing_subst_instance_decl _ _ _ (tSort _)).
Qed.

Lemma isArity_subst_instance u T :
  isArity T ->
  isArity (subst_instance u T).
Proof using Type.
  induction T; cbn; intros; tauto.
Qed.

Lemma wf_local_subst_instance Σ Γ ext u :
  wf_global_ext Σ.1 ext ->
  consistent_instance_ext Σ ext u ->
  wf_local (Σ.1, ext) Γ ->
  wf_local Σ (subst_instance u Γ).
Proof using Type.
  destruct Σ as [Σ φ]. intros X X0 X1. simpl in *.
  induction X1; cbn; constructor; auto.
  1,2: eapply infer_typing_sort_impl with (tu := t0); intros Hs.
  3: rename t1 into Hs.
  all: eapply typing_subst_instance'' in Hs; eauto; apply X.
Qed.

Lemma wf_local_subst_instance_decl Σ Γ c decl u :
  wf Σ.1 ->
  lookup_env Σ.1 c = Some decl ->
  wf_local (Σ.1, universes_decl_of_decl decl) Γ ->
  consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
  wf_local Σ (subst_instance u Γ).
Proof using Type.
  destruct Σ as [Σ φ]. intros X X0 X1 X2.
  induction X1; cbn; constructor; auto.
  1,2: eapply infer_typing_sort_impl with (tu := t0); intros Hs.
  3: rename t1 into Hs.
  all: eapply typing_subst_instance_decl in Hs; eauto; apply X.
Qed.

  Lemma subst_instance_ind_sort_id Σ mdecl ind idecl :
    wf Σ ->
    declared_inductive Σ ind mdecl idecl ->
    let u := abstract_instance (ind_universes mdecl) in
    subst_instance_univ u (ind_sort idecl) = ind_sort idecl.
  Proof using Type.
    intros wfΣ decli u.
    pose proof (on_declared_inductive decli) as [onmind oib].
    pose proof (onArity oib) as ona.
    rewrite (oib.(ind_arity_eq)) in ona.
    red in ona. destruct ona.
    eapply typed_subst_abstract_instance in t.
    2:split; simpl; auto.
    - rewrite !subst_instance_it_mkProd_or_LetIn in t.
      eapply (f_equal (destArity [])) in t.
      rewrite !destArity_it_mkProd_or_LetIn in t. simpl in t. noconf t.
      simpl in H; noconf H. apply H0.
    - destruct decli as [declm _].
      eapply declared_inductive_wf_global_ext in declm; auto.
      destruct declm. apply o.
  Qed.

  Lemma subst_instance_ind_type_id Σ mdecl ind idecl :
    wf Σ ->
    declared_inductive Σ ind mdecl idecl ->
    let u := abstract_instance (ind_universes mdecl) in
    subst_instance u (ind_type idecl) = ind_type idecl.
  Proof using Type.
    intros wfΣ decli u.
    pose proof (on_declared_inductive decli) as [_ oib].
    pose proof (onArity oib) as ona.
    rewrite (oib.(ind_arity_eq)) in ona |- *.
    red in ona. destruct ona.
    eapply typed_subst_abstract_instance in t; eauto.
    destruct decli as [declm _].
    eapply declared_inductive_wf_global_ext in declm; auto.
  Qed.

  Lemma isType_subst_instance_id Σ Γ T :
    wf_ext_wk Σ ->
    let u := abstract_instance Σ.2 in
    isType Σ Γ T -> subst_instance u T = T.
  Proof using Type.
    intros wf_ext u isT.
    destruct isT. eapply typed_subst_abstract_instance in t; auto.
  Qed.

End SubstIdentity.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
Require Import ZArith_ext machine_int.
Import MachineInt.
Require Import mips_seplog.

Local Close Scope positive_scope.

Local Open Scope heap_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_hoare_scope.

(** * Frame rule *)

Definition modified_regs0 (c : cmd0) : seq store.var :=
  match c with
    | nop => nil
    | add rd _ _ => rd :: nil
    | addi rt _ _ => rt :: nil
    | addiu rt _ _ => rt :: nil
    | addu rd _ _ => rd :: nil
    | cmd_and rd _ _ => rd :: nil
    | andi rt _ _ => rt :: nil
    | lw rt _ _  => rt :: nil
    | lwxs rt _ _ => rt :: nil
    | maddu _ _ => nil
    | mflo rd => rd :: nil
    | movn rd _ _ => rd :: nil
    | movz rd _ _ => rd :: nil
    | mfhi rd => rd :: nil
    | mflhxu rd => rd :: nil
    | msubu _ _  => nil
    | mthi _ => nil
    | mtlo _ => nil
    | multu _ _  => nil
    | nor rd _ _ => rd :: nil
    | cmd_or rd _ _ => rd :: nil
    | sll rx _ _ => rx :: nil
    | sllv rd _ _ => rd :: nil
    | sra rd _ _ => rd :: nil
    | srl rd _ _ => rd :: nil
    | srlv rd _ _ => rd :: nil
    | sltu rd _ _ => rd :: nil
    | sw _ _ _ => nil
    | subu rd _ _ => rd :: nil
    | xor rd _ _ => rd :: nil
    | xori rt _ _ => rt :: nil
  end.

Fixpoint modified_regs (c : @while.cmd cmd0 expr_b) : seq store.var :=
  match c with
    | while.cmd_cmd0 c0 => modified_regs0 c0
    | while.while _ c => modified_regs c
    | c1 ; c2 => modified_regs c1 ++ modified_regs c2
    | while.ifte t c1 c2 => modified_regs c1 ++ modified_regs c2
  end.

Lemma inde_seq R c d : inde (modified_regs (c ; d)) R ->
  inde (modified_regs c) R /\ inde (modified_regs d) R.
Proof.
move=> H; split => s h x v H'; split => H''.
- rewrite -H //=; apply List.in_or_app; by left.
- rewrite (H _ _ x v) //=; apply List.in_or_app; by left.
- rewrite -H //=; apply List.in_or_app; by right.
- rewrite (H _ _ x v) //=; apply List.in_or_app; by right.
Qed.

Lemma inde_ifte R t c d : inde (modified_regs (while.ifte t c d)) R ->
  inde (modified_regs c) R /\ inde (modified_regs d) R.
Proof.
move=> H; split => s h x v H'; split => H''.
- rewrite -H //=; apply: List.in_or_app; by left.
- rewrite (H _ _ x v) //=; apply: List.in_or_app; by left.
- rewrite -H //=; apply List.in_or_app; by right.
- rewrite (H _ _ x v) //=; apply List.in_or_app; by right.
Qed.

Definition modifies_mult0 (c : cmd0) :=
  match c with
    | nop => false
    | add _ _ _ => false
    | addi _ _ _ => false
    | addiu _ _ _ => false
    | addu _ _ _ => false
    | cmd_and _ _ _ => false
    | andi _ _ _ => false
    | lw _ _ _ => false
    | lwxs _ _ _ => false
    | maddu _ _ => true
    | mfhi _ => false
    | mflhxu _ => true
    | mflo _ => false
    | movn _ _ _ => false
    | movz _ _ _ => false
    | msubu _ _ => true
    | mtlo _ => true
    | mthi _ => true
    | multu _ _ => true
    | nor _ _ _ => false
    | cmd_or _ _ _ => false
    | sll _ _ _ => false
    | sllv _ _ _ => false
    | sltu _ _ _ => false
    | sra _ _ _ => false
    | srl _ _ _ => false
    | srlv _ _ _ => false
    | subu _ _ _ => false
    | sw _ _ _ => false
    | xor _ _ _ => false
    | xori _ _ _ => false
  end.

Fixpoint modifies_mult (c : @while.cmd cmd0 expr_b) : bool :=
  match c with
    | while.cmd_cmd0 c => modifies_mult0 c
    | while.while _ c' => modifies_mult c'
    | c1 ; c2 => modifies_mult c1 || modifies_mult c2
    | while.ifte t c1 c2 => modifies_mult c1 || modifies_mult c2
  end.

(** an assert that is independent of the execution of a command modifying the multiplier *)
Definition inde_cmd_mult c (P : assert) := modifies_mult c -> inde_mult P.

Lemma inde_cmd_mult_TT : forall l, inde_cmd_mult l TT. Proof. by []. Qed.

Lemma inde_cmd_mult_seq R c d : inde_cmd_mult (c; d) R ->
  inde_cmd_mult c R /\ inde_cmd_mult d R.
Proof.
move=> H; split => H' s h m m'; split => H''.
- by rewrite -(H _ _ _ m) //= H'.
- by rewrite -(H _ _ _ m') //= H'.
- by rewrite -(H _ _ _ m) //= H' orbC.
- by rewrite -(H _ _ _ m') //= H' orbC.
Qed.

Lemma inde_cmd_mult_ifte R t c d : inde_cmd_mult (while.ifte t c d) R ->
  inde_cmd_mult c R /\ inde_cmd_mult d R.
Proof.
move=> H; split => H' s h m m'; split => H''.
- by rewrite -(H _ _ _ m) //= H'.
- by rewrite -(H _ _ _ m') //= H'.
- by rewrite -(H _ _ _ m) //= H' orbC.
- by rewrite -(H _ _ _ m') //= H' orbC.
Qed.

Lemma frame_rule0 (P Q : assert) (c : cmd0) : {{[ P ]}} c {{[ Q ]}} ->
  forall (R : assert), inde (modified_regs c) R ->
    inde_cmd_mult c R -> {{ P ** R }} c {{ Q ** R }}.
Proof.
elim; clear P Q c.
- (* nop *) move=> P R H1 H2; by do 2 constructor.
- (* add *) move=> Q rs rt rd R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_add rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [H3 [H4 [ [H5 H7] H6] ] ] ] ].
  split => //.
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* addi *)
  move=> Q rt rs imm R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_addi rt rs imm (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [ [H5 H7] H6] ] ] ] ].
  split => //.
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* addiu *) move=> Q rt rs imm R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_addiu rt rs imm (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [ H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* addu *) move=> Q rs rt rd R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_addu rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* cmd_and *) move=> P rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_and rd rs rt (P ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* andi *) move=> P rt rs imm R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_andi rt rs imm (P ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* lw *) move=> Q rt offset base R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_lw rt offset base (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [H3 [H4 [ [p [H7 [z [H8 H9] ] ] ] H6] ] ] ] ].
  exists p; split => //.
  exists z; split => //.
  rewrite H4.
  by apply heap.get_union_L.
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* lwxs *) move=> rt index base P0 R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_lwxs rt index base (P0 ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [H3 [H4 [ [p [H7 [z [H8 H9] ] ] ] H6] ] ] ] ].
  exists p; split => //.
  exists z; split => //.
  rewrite H4.
  by apply heap.get_union_L.
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* maddu *) move=> Q rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_maddu rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by rewrite -(H2 _ s h2 m).
- (* mfhi *) move=> Q rd R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_mfhi rd (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* mflhxu *) move=> rd Q R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_mflhxu rd (Q ** R))); last by do 2 constructor.
  move=> [s [a [hi lo]]] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  rewrite /=.
  case: ifP => [/eqP ? | X].
  + rewrite -(H2 _ _ _) //; by apply H6.
  + have : List.In rd (modified_regs (mflhxu rd)) by rewrite /=; auto.
    move/(H1 (s, (a, (hi, lo))) h2 rd lo).
    rewrite /store.upd X => {}H1.
    rewrite -(H2 _ _ _ (a, (hi, lo))) //; tauto.
- (* mflo *) move=> Q rd R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_mflo rd (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* movn *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_movn rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  split => H7.
  exists h1, h2; repeat (split => //).
  by apply (proj1 H5).
  by apply inde_upd_store.
  exists h1, h2; repeat (split => //).
  by apply (proj2 H5).
- (* movz *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_movz rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  split => H7.
  exists h1, h2; repeat (split => //).
  by apply (proj1 H5).
  by apply inde_upd_store.
  exists h1, h2; repeat (split => //).
  by apply (proj2 H5).
- (* msubu *) move=> Q rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_msubu rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by rewrite -(H2 _ s h2 m).
- (* mthi *) move=> Q rs R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_mthi rs (Q ** R))); last by do 2 constructor.
  move=> [s [a [hi lo]]] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  rewrite /= -(H2 _ _ _) //.
  by apply H6.
- (* mtlo *) move=> Q rs R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_mtlo rs (Q ** R))); last by do 2 constructor.
  move=> [s [a [hi lo]]] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  rewrite /= -(H2 _ s h2) //.
  by apply H6.
- (* multu *) move=> Q rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_multu rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by rewrite /= -(H2 _ s h2 m).
- (* nor *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_nor rd rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* or *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_or rd rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* sll *) move=> Q rx ry sa R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_sll rx ry sa (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* sllv *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_sllv rd rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* sltu *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_sltu rd rs rt (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* sra *) move=> Q rd rt sa R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_sra rd rt sa (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* srl *) move=> Q rd rt sa R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_srl rd rt sa (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [ H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* srlv *) move=> Q rd rt rs R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_srlv rd rt rs (Q ** R))); last by do 2 constructor.
  move=> [s m] h [h1 [h2 [H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* subu *) move=> Q rs rt rd R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_subu rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [H3 [H4 [H5 H6] ] ] ] ].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* sw *) move=> rt off b Q R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_sw rt off b (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [ [p [H7 [ [z H8] H9]]] H6]]]]].
  exists p; split => //.
  split.
  exists z.
  rewrite H4.
  by apply heap.get_union_L.
  exists (heap.upd p [rt]_s h1), h2; split.
  by apply heap.disj_upd.
  split => //.
  rewrite H4.
  by apply heap.upd_union_L with z.
- (* xor *) move=> Q rd rs rt R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_xor rd rs rt (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6]]]]].
  exists h1, h2; repeat (split => //).
  by apply inde_upd_store.
- (* xori *) move=> Q rt rs imm R H1 H2.
  apply (hoare_prop_m.hoare_stren (wp_xori rt rs imm (Q ** R))); last by do 2 constructor.
  move=> s h [h1 [h2 [ H3 [H4 [H5 H6]]]]].
  exists h1, h2; repeat (split=> //).
  by apply inde_upd_store.
Qed.

Lemma frame_rule_R (P : assert) c (Q : assert) : {{ P }} c {{ Q }} ->
  forall (R : assert), inde (modified_regs c) R -> inde_cmd_mult c R ->
    {{ P ** R }} c {{ Q ** R }}.
Proof.
elim; clear P c Q.
- exact frame_rule0.
- (* seq *) move=> Q P R c d H IHhoare1 H0 IHhoare2 U.
  case/inde_seq => H11 H12.
  case/inde_cmd_mult_seq => H21 H22.
  apply (while.hoare_seq _ _ _ _ _ _ (Q ** U)); by [apply IHhoare1 | apply IHhoare2].
- (* conseq *) move=> P P' Q Q' c H H0 H1 IHhoare R H2 H3.
  move: (IHhoare _ H2 H3) => H4.
  apply (hoare_prop_m.hoare_stren (P' ** R)).
  move=> s h [h1 [h2 [H5 [H6 [H7 H8]]]]]; by exists h1, h2; auto.
  apply (hoare_prop_m.hoare_weak (Q' ** R)) => //.
  move=> s h [h1 [h2 [ H5 [H6 [H7 H8]]]]]; by exists h1, h2; auto.
- (* while *) move=> P t c H IHhoare R H1 H2.
  apply (hoare_prop_m.hoare_weak (fun s h => (P ** R) s h /\ ~~ eval_b t s)).
  move=> s h [[h1 [h2 [H3 [H4 [H5 H6]]]]] H7]; by exists h1, h2.
  apply (hoare_prop_m.hoare_stren (P ** R)) => //.
  apply while.hoare_while with (P := P ** R).
  move: (IHhoare _ H1 H2) => H3.
  apply (hoare_prop_m.hoare_stren (fun s h => ((fun s0 h0 => P s0 h0 /\ eval_b t s) ** R) s h)) => //.
  move=> s h [ [h1 [h2 [ H4 [H5 [H6 H7] ] ] ] ] H8 ]; by exists h1, h2.
- (* ifte *) move=> P Q t c d H1 IHhoare1 H3 IHhoare2 R.
  case/inde_ifte => H51 H52.
  case/inde_cmd_mult_ifte => H61 H62.
  apply while.hoare_ifte.
  + apply (hoare_prop_m.hoare_stren ((fun s h => P s h /\ eval_b t s) ** R)).
    move=> s h [ [h1 [h2 [H8 [H9 [H10 H11] ] ] ] ] H12 ]; by exists h1, h2.
    by apply IHhoare1.
  + apply (hoare_prop_m.hoare_stren ((fun s h => P s h /\ ~~ eval_b t s) ** R)).
    move=> s h [ [h1 [h2 [H8 [H9 [H10 H11] ] ] ] ] H12 ]; by exists h1, h2.
    by apply IHhoare2.
Qed.

Lemma frame_rule_L (P : assert) (c : while.cmd) (Q : _assert) : {{P}}c {{Q}} ->
  forall R : assert, inde (modified_regs c) R ->
    inde_cmd_mult c R -> {{R ** P}}c {{R ** Q}}.
Proof.
move=> P_c_Q R H1 H2.
apply (while.hoare_conseq _ _ _ _ _ _ _ (P ** R) _ (Q ** R)).
by rewrite assert_m.conCE.
by rewrite assert_m.conCE.
by apply frame_rule_R.
Qed.

Lemma before_frame R P' Q' P c Q : {{ P' ** R }} c {{ Q' ** R }} ->
  P ===> P' ** R -> Q' ** R ===> Q -> {{ P }} c {{ Q }}.
Proof. move=> H1 H2 H3; by eapply while.hoare_conseq; eauto. Qed.


Require Import OptionExt.

(* option monad *)
Definition ret := fun (A:Type) (a:A) => Some a.
Definition bind : forall (A B:Type), option A -> (A -> option B) -> option B :=
  fun A B a f =>
  match a with
  | None => None
  | Some a => f a
  end.
Definition fail := fun (A:Type) => None (A:=A).

Implicit Arguments bind [A B].
Implicit Arguments ret [A].
Implicit Arguments fail [A].

Definition lift_bool : bool -> option unit := fun b => if b then ret tt else fail.

Notation "c1 ;; c2" := (bind c1 (fun _ => c2)) (at level 20, right associativity).
Notation "x <- c1 ;: c2" := (bind c1 (fun x => c2)) (at level 20, right associativity).

(* Tactics for option monad handling *)
Ltac destruct_opt t t' result resulteq :=
  destruct (option_dec t) as [[result resulteq] | resulteq];
  rewrite resulteq in t';
  [simpl in t' | discriminate].

Ltac ret_inject t :=
  unfold ret in t; injection t; clear t; intro t.