Require Import LibTactics.
Require Import Coq.micromega.Lia.
Require Import LN_Lemmas.
Require Export SimpleSub.

Definition typ_as_ftyp := fty_StackArg.
Coercion typ_as_ftyp : typ >-> Fty.

Notation "[| A |]"        := (fty_StackTyArg A)
                               (at level 5) : type_scope.

(*****************************************************************************)

#[export] Hint Immediate orduFty_lc : core.

Lemma napplyty_lc_1 : forall A B, NApplyTy A B -> lc_typ A.
Proof.  introv H.  induction* H.  Qed.

Lemma napplyty_lc_2 : forall A B, NApplyTy A B -> lc_Fty B.
Proof.  introv H.  induction* H.  Qed.

#[export] Hint Immediate napplyty_lc_1 napplyty_lc_2 : core.

Lemma applyty_lc_1 : forall A B C, ApplyTy A B C -> lc_typ A.
Proof.  introv H.  induction* H.  Qed.

Lemma applyty_lc_2 : forall A B C, ApplyTy A B C -> lc_Fty B.
Proof.  introv H.  induction* H. Qed.

Lemma applyty_lc_3 : forall A B C, ApplyTy A B C -> lc_typ C.
Proof.  introv H.  induction~ H. inverts H. eauto with lngen. Qed.

#[export] Hint Immediate applyty_lc_1 applyty_lc_2 applyty_lc_3 : core.

Lemma lc_fty_inv_1 : forall A:typ , lc_Fty A -> lc_typ A.
Proof. introv H. inverts~ H. Qed.

Lemma lc_fty_inv_2 : forall A:typ , lc_Fty [| A |] -> lc_typ A.
Proof. introv H. inverts~ H. Qed.

#[export] Hint Resolve lc_fty_inv_1 lc_fty_inv_2 : core.

Lemma napplyty_bot : forall A,
    NApplyTy t_bot A -> False.
Proof.
  introv App. inductions App.
  all: eauto.
Qed.

#[export] Hint Immediate napplyty_bot : core.

Lemma napplyty_splitu_arg_inv : forall A B B1 B2,
    NApplyTy A (fty_StackArg B) -> splu B B1 B2 ->
    NApplyTy A (fty_StackArg B1) \/ NApplyTy A (fty_StackArg B2).
Proof.
  introv HN HS.
  inverts HN; solve_false; auto_unify; eauto.
Qed.

Lemma applyty_contradication : forall A B C,
   ApplyTy A B C -> NApplyTy A B -> False.
Proof with solve_false.
  introv HA HN.
  indTypFtySize (size_typ A + size_Fty B).

  inverts HA;
    match goal with
    | H1: NApplyTy _ (fty_StackArg ?B), H2: splu ?B _ _  |- _ =>
      forwards~ [?|?]: napplyty_splitu_arg_inv H1 H2
    | _ => inverts HN
    end.

  all: repeat match goal with
  | H1: ApplyTy (t_forall _) (fty_StackArg _) _ |- _ => forwards: IH H1; elia; applys~ NApplyFunTy
  | H1: ApplyTy (t_arrow _ _) (fty_StackTyArg _) _ |- _ => forwards: IH H1; elia; applys~ NApplyTyFunFty
  | H1: ApplyTy ?A ?B _, H2: NApplyTy ?A ?B |- _ => forwards: IH H2 H1; elia
              end.
  all: solve_false.
Qed.

#[export] Hint Extern 1 => lazymatch goal with
                            | H1: ApplyTy ?T _ _, H2: NApplyTy ?T _  |- _ =>
                              applys applyty_contradication H1 H2
                            end : FalseHd.

Lemma applyty_unique : forall A B C1 C2,
    ApplyTy A B C1 -> ApplyTy A B C2 -> C1 = C2.
Proof.
  introv HA1 HA2. gen C1 C2.
  indTypFtySize (size_typ A + size_Fty B).
  inverts HA1; inverts HA2.
  all: auto_unify; repeat match goal with
  | H1: ApplyTy ?A ?B _, H2: ApplyTy ?A ?B _ |- _ => forwards: IH H1 H2; elia; clear H1 H2
              end; subst~.
  all: solve_false.
Qed.

Ltac auto_unify_2 :=
  auto_unify; (* unify split *)
  (* unify applyty *)
  repeat lazymatch goal with
         | [ H1: ApplyTy ?A ?B _ , H2: ApplyTy ?A ?B _ |- _ ] =>
           (forwards : applyty_unique H1 H2;
            subst; clear H2)
             end.

Lemma ordu_or_split_Fty: forall F,
    lc_Fty F -> UnionOrdinaryFty F \/ exists A B C, F = fty_StackArg A /\ splu A B C.
Proof.
  introv HL.
  destruct~ HL.
  forwards~ [?|(?&?&?)]: ordu_or_split A. intuition eauto.
Qed.

Lemma applyty_total : forall A F,
    lc_typ A -> lc_Fty F -> (exists C, ApplyTy A F C) \/ NApplyTy A F.
Proof with (elia; destruct_conj).
  introv.
  indTypFtySize (size_typ A + size_Fty F).
  lets~ [?|(?&?&?&?&?)]: (ordu_or_split_Fty F).
  - destruct* H.
    (* and / or *)
    all: try forwards~ [?|?]: IH F A1...
    all: try forwards~ [?|?]: IH F A2...
    all: eauto.

    (* arrow / forall *)
    all: destruct H0.
    2,3: now right*.

    + destruct* (sub_dec A0 A).
    + eauto.

  - subst.
    forwards~ [?|?]: IH (fty_StackArg x0) A...
    forwards~ [?|?]: IH (fty_StackArg x1) A...
    all: eauto.
Qed.

Lemma applyty_splitu_arg_inv : forall A B B1 B2 C,
    ApplyTy A (fty_StackArg B) C -> splu B B1 B2 ->
    exists C1 C2, C = (t_or C1 C2) /\
    ApplyTy A (fty_StackArg B1) C1 /\ ApplyTy A (fty_StackArg B2) C2.
Proof.
  introv HA HS.
  inverts HA; auto_unify; solve_false; eauto.
Qed.

Lemma applyty_splitu_fun_aux : forall A A1 A2 F,
    (forall C1 C2, ApplyTy A1 F C1 -> ApplyTy A2 F C2 -> splu A A1 A2 ->
     exists C', ApplyTy A F C') /\
    (NApplyTy A1 F \/ NApplyTy A2 F -> splu A A1 A2 -> NApplyTy A F).
Proof with elia; solve_false; try eassumption.
  introv.
  indTypFtySize (size_typ A + size_Fty F).
  split.

  introv HA1 HA2 HS.
  lets~ [?|(?&?&?&?&?)]: (ordu_or_split_Fty F). eauto.
  - inverts HS...
    + (* or *) exists*.
    + (* and *) inverts HA1...
      * (* interBoth *) inverts HA2... forwards (?&?): proj1 (IH F A0) H1... exists*.
      * (* interR *) exists*. applys* ApplyTyInterR.
        forwards~ : proj2 (IH F A0) H1...
      * (* Both *)  inverts HA2...
        ** exists*. applys* ApplyTyInterR. forwards~ : proj2 (IH F A0) H1...
        ** forwards (?&?): proj1 (IH F A0) H1... exists*.
    + (* and *) inverts HA1...
      * (* interL *) exists*. applys* ApplyTyInterL. forwards~ : proj2 (IH F B) H1...
      * (* interBoth *) inverts HA2... forwards (?&?): proj1 (IH F B) H1... exists*.
      * (* Both *)  inverts HA2...
        ** exists*. applys* ApplyTyInterL. forwards~ : proj2 (IH F B) H1...
        ** forwards (?&?): proj1 (IH F B) H1... exists*.
    + (* forall *) inverts HA1... inverts HA2... exists~.
    + (* rcd *) inverts HA1...
  - subst.
    forwards: applyty_splitu_arg_inv HA1 H0. forwards: applyty_splitu_arg_inv HA2 H0.
    destruct_conj. subst.
    forwards (?&?): proj1 (IH (fty_StackArg x0) A) H4 H2...
    forwards (?&?): proj1 (IH (fty_StackArg x1) A) H5 H3...
    exists*.

  -
    intros [HA|HA] HS;
      lets~ [?|(?&?&?&?&?)]: (ordu_or_split_Fty F); subst; eauto.
    + (* ord *) inverts~ HS...
      * (* and *) inverts HA... forwards~ : proj2 (IH F A0) H1...
      * (* and *) inverts HA... forwards~ : proj2 (IH F B) H1...
      * (* forall *) inverts HA... constructor~.
    + (* split *) forwards* [?|?]: napplyty_splitu_arg_inv HA.
      * forwards~ : proj2 (IH (fty_StackArg x0) A) HS... eauto.
      * forwards~ : proj2 (IH (fty_StackArg x1) A) HS... eauto.
    + (* ord *) inverts~ HS...
      * (* and *) inverts HA... forwards~ : proj2 (IH F A0) H1...
      * (* and *) inverts HA... forwards~ : proj2 (IH F B) H1...
      * (* forall *) inverts HA... constructor~.
    + (* split *) forwards* [?|?]: napplyty_splitu_arg_inv HA.
      * forwards~ : proj2 (IH (fty_StackArg x0) A) HS... eauto.
      * forwards~ : proj2 (IH (fty_StackArg x1) A) HS... eauto.

   Unshelve. all: apply t_top.
Qed.

(* Lemma B.9 *)
Lemma napplyty_splitu_fun : forall A A1 A2 F,
    NApplyTy A1 F \/ NApplyTy A2 F -> splu A A1 A2 -> NApplyTy A F.
Proof.
  intros.
  forwards* (?&?): applyty_splitu_fun_aux.
Qed.

Lemma napplyty_rename : forall A B C,
    NApplyTy A (fty_StackTyArg B) -> lc_typ C -> NApplyTy A (fty_StackTyArg C).
Proof.
  introv H Lc. inductions H; eauto.
Qed.

Lemma applyty_rename : forall A B X C,
    ApplyTy A (fty_StackTyArg (t_tvar_f X)) B -> lc_typ C -> X `notin` [[A]] ->
    ApplyTy A (fty_StackTyArg C) ( [X ~~> C] B).
Proof.
  introv H Lc Fry. inductions H; simpl; simpl in Fry; eauto.
  all: try solve [ simpl_rename_goal; simpl in Fry; solve_notin ].
  - forwards~: napplyty_rename C H1.
  - forwards~: napplyty_rename C H0.
Qed.

(*------------------- Soundness Type-Level Dispatch --------------------------*)

(* Soundness of Type-Level Dispatch [1] *)
Lemma applyty_soundness_1 : forall A B C,
    ApplyTy A (fty_StackArg B) C -> A <: (t_arrow B C).
Proof with try eassumption; try applys ASub_refl; try match goal with |- lc_typ _ => eauto with lngen end.
  introv H. inductions H.
  all: try match goal with
           | H: UnionOrdinaryFty (_ _) |- _ => inverts H
           end.
  1-2: eauto.
  all: try forwards~ : IHApplyTy.
  all: try forwards~ : IHApplyTy1. all: try forwards~ : IHApplyTy2.
  - convert2asub. split_l.
    applys algo_trans H. applys ASub_arrow... use_left_r...
    applys algo_trans H2. applys ASub_arrow... use_right_r...
  - convert2asub.
    applys algo_trans ((t_arrow B1 (B1' | B2'))&(t_arrow B2 (B1' | B2'))).
    applys algo_trans ((t_arrow B1 B1')&(t_arrow B2 B2')). split_r...
    + split_r... * use_left_l... applys ASub_arrow... use_left_r...
      * use_right_l... applys ASub_arrow... use_right_r...
    + applys asub2nsub. applys NSub_and. applys NSpI_arrowUnion...
      applys splu2nsplu H. all: applys asub2nsub.
      * use_left_l... * use_right_l...
  - convert2asub. use_left_l...
  - convert2asub. swap_and_l... use_left_l...
  - convert2asub. split_r; eauto.
Qed.

(* Soundness of Type-Level Dispatch [2] *)
Lemma applyty_soundness_2 : forall A B C,
    ApplyTy A (fty_StackTyArg B) C ->
    exists C',  C = C'^-^B /\
                forall X, X `notin` [[C]] -> ApplyTy A (fty_StackTyArg (t_tvar_f X)) (C'-^X) /\ A <: (t_forall C').
Proof with simpl in *; try eassumption; try applys ASub_refl; try match goal with |- lc_typ _ => eauto with lngen end; destruct_conj.
  introv H. inductions H.
  all: try match goal with
           | H: UnionOrdinaryFty (_ _) |- _ => inverts H
           end.
  all: try forwards~ : IHApplyTy.
  all: try forwards~ : IHApplyTy1. all: try forwards~ : IHApplyTy2.
  all: destruct_conj.
  - exists t_bot. split~.
  - exists A. split~.
  - exists (x0|x). split~.
    + assert (Heq: forall B C X, (t_or B C) ^-^ X = t_or (B ^-^ X) (C ^-^ X)) by eauto.
      rewrite Heq. congruence.
    + assert (Heq: forall B C X, (t_or B C) -^ X = t_or (B -^ X) (C -^ X)) by eauto.
      intros X Fry... forwards~ : H5 X. forwards~ : H4 X...
      split~.
      * rewrite Heq. applys~ ApplyTyUnion H6 H4.
      * convert2asub.
        split_l. use_left_r...  use_right_r...
  - exists. split... intros X Fry. forwards~ : H2 X...
    split. eapply napplyty_rename in H1. eauto. eauto.
    convert2asub. use_left_l...
  - exists. split... intros X Fry. forwards~ : H2 X...
    split. eapply napplyty_rename in H0. eauto. eauto.
    convert2asub. swap_and_l... use_left_l...
  - exists (x0 & x). split...
    + assert (Heq: forall B C X, (t_and B C) ^-^ X = t_and (B ^-^ X) (C ^-^ X)) by eauto.
      rewrite Heq. congruence.
    + intros X Fry. forwards~ : H4 X... forwards~ : H5 X...
      split.
      * assert (Heq: forall B C X, (t_and B C) -^ X = t_and (B -^ X) (C -^ X)) by eauto.
        rewrite Heq. eauto.
      * convert2asub. split_r; eauto.
  Unshelve. all: apply empty.
Qed.

(* Soundness of Type-Level Dispatch [2] *)
Lemma applyty_soundness_2_simple : forall A B C,
    ApplyTy A (fty_StackTyArg B) C ->
    exists A', A <: t_forall A' /\ C <: (A' ^-^ B).
Proof.
  introv H. pick fresh X.
  forwards~ (?&?&?): applyty_soundness_2 H.
  subst. forwards~ (?&?): H1 X.
  exists x. split~. convert2asub. applys* ASub_refl.
Qed.

Lemma applyty_completeness_1 : forall A B D,
    A <: (t_arrow B D) -> ordu B ->
         exists C, ApplyTy A (fty_StackArg B) C /\ (t_arrow B C) <: (t_arrow B D).
Proof with try eassumption; elia; solve_false; destruct_conj.
  introv HS Hord. apply dsub2asub in HS.
  indTypFtySize (size_typ A + size_typ D).
  forwards (?&?): algo_sub_lc HS. inverts_all_lc.
  lets~ [?|(?&?&?)]: (ordi_or_split D).
  - destruct H...
    + forwards~ [Ha|Ha]: algo_sub_andlr_inv HS;
        forwards: IH Ha...
      * forwards~ [?|?]: applyty_total A2 (fty_StackArg B)...
        inv_arrow.
        exists (t_and x x0). split~. applys~ DSub_CovArr. applys~ DSub_InterLL.
        eauto with lngen. solve_dsub...
        exists* x.
      * forwards~ [?|?]: applyty_total A1 (fty_StackArg B)...
        inv_arrow.
        exists (t_and x0 x). split~. applys~ DSub_CovArr. applys~ DSub_InterLR.
        eauto with lngen. solve_dsub...
        exists x. split~.
    + apply dsub2asub in HS.
      assert (EASY1: A1 <: (t_arrow B D)) by applys~ DSub_Trans HS. apply dsub2asub in EASY1.
      assert (EASY2: A2 <: (t_arrow B D)) by applys~ DSub_Trans HS. apply dsub2asub in EASY2.
      forwards: IH B EASY1... forwards: IH B EASY2...
      exists (t_or x x0). split~. inv_arrow. applys~ DSub_CovArr.
      convert2dsub. applys~ DSub_UnionL.
    + inv_arrow. convert2dsub. exists B0. split~.
    + exists*.
  -  forwards~ (Ha1&Ha2): algo_sub_and_inv HS. eauto.
     forwards: IH Ha1... forwards: IH Ha2... inv_arrow.
     auto_unify_2. exists x2. split~. applys~ DSub_CovArr.
     convert2asub. eauto.
Qed.

Lemma applyty_completeness_1_all : forall A B D,
    A <: (t_arrow B D) ->
         exists C, ApplyTy A (fty_StackArg B) C /\ (t_arrow B C) <: (t_arrow B D).
Proof with try eassumption; elia.
  introv Sub.
  indTypFtySize (size_Fty B).
  forwards [?|(T&T1&T2&?&?)]: ordu_or_split_Fty B... now eauto.
  - applys applyty_completeness_1... inverts~ H.
  - inverts H.
    assert (Sub1: A <: t_arrow T1 D).
    { applys DSub_Trans Sub. constructor~. convert2asub. eauto. }
    assert (Sub2: A <: t_arrow T2 D).
    { applys DSub_Trans Sub. constructor~. convert2asub. eauto. }
    forwards: IH Sub1... forwards: IH Sub2...
    all: destruct_conj.
    + exists (x0 | x). split. econstructor...
      convert2asub.  auto_inv. constructor*.
Qed.

Lemma applyty_completeness_2 : forall A B,
    A <: (t_forall B) ->
         exists C L, forall X, X `notin` L ->
             ApplyTy A (fty_StackTyArg (t_tvar_f X)) (C-^X) /\ (t_forall C) <: (t_forall B).
Proof with try eassumption; elia; solve_false; destruct_conj.
  introv HS. apply dsub2asub in HS.
  indTypFtySize (size_typ A + size_typ B).
  lets~ [?|(?&?&?)]: (ordi_or_split (t_forall B)).
  - assert (lc_typ A) by eauto. destruct H0...
    + forwards~ [Ha|Ha]: algo_sub_andlr_inv HS;
        forwards: IH Ha...
      * pick fresh X for ([[A1]] `union` [[A2]] `union` x0 `union` [[x]]). forwards~ : H0 X.
        forwards~ [?|?]: applyty_total A2 (fty_StackTyArg (t_tvar_f X))...
        ** exists. intros Y Fry.
           forwards~ HR1: applyty_rename (t_tvar_f Y) H1. forwards~ HR2: applyty_rename (t_tvar_f Y) H2.
           simpl_rename HR1. simpl_rename HR2.
           assert (Heq: forall Y, (t_and x (close_typ_wrt_typ X x1)) -^ Y = t_and (x -^ Y) (close_typ_wrt_typ X x1 -^ Y)) by eauto. rewrite Heq.
           split~. applys DSub_CovAll. intros X0 Fry2.
           apply dsub2asub in H3. forwards: algo_sub_forall_inv X0 H3.
           rewrite Heq. applys DSub_InterLL. eauto.
           solve_dsub...
           autorewrite with lngen. all: solve_notin.
        ** exists. intros Y Fry.
           forwards~ HR1: applyty_rename (t_tvar_f Y) H1. simpl_rename HR1.
           forwards~ HR2: napplyty_rename (t_tvar_f Y) H2.
           split. applys~ ApplyTyInterL HR1. auto. eauto with lngen.
      * pick fresh X for ([[A1]] `union` [[A2]] `union` x0 `union` [[x]]). forwards~ : H0 X.
        forwards~ [?|?]: applyty_total A1 (fty_StackTyArg (t_tvar_f X))...
        ** exists. intros Y Fry.
           forwards~ HR1: applyty_rename (t_tvar_f Y) H1. forwards~ HR2: applyty_rename (t_tvar_f Y) H2.
           simpl_rename HR1. simpl_rename HR2.
           assert (Heq: forall Y, (t_and (close_typ_wrt_typ X x1) x) -^ Y = t_and (close_typ_wrt_typ X x1 -^ Y) (x -^ Y)) by eauto. rewrite Heq.
           split~. applys DSub_CovAll. intros X0 Fry2.
           apply dsub2asub in H3. forwards: algo_sub_forall_inv X0 H3.
           rewrite Heq. applys DSub_InterLR. eauto.
           solve_dsub...
           autorewrite with lngen.
           all : solve_notin.
        ** exists. intros Y Fry.
           forwards~ HR1: applyty_rename (t_tvar_f Y) H1. simpl_rename HR1.
           forwards~ HR2: napplyty_rename (t_tvar_f Y) H2.
           split. applys~ ApplyTyInterR HR1. auto. eauto with lngen.

    + apply dsub2asub in HS.
      assert (EASY1: A1 <: (t_forall B)) by applys~ DSub_Trans HS. apply dsub2asub in EASY1.
      assert (EASY2: A2 <: (t_forall B)) by applys~ DSub_Trans HS. apply dsub2asub in EASY2.
      forwards: IH B EASY1... forwards: IH B EASY2...
      exists (t_or x x1).
      exists (union x0
                 (union x2
                    (union [[B]]
                           (union [[A1]] (union [[A2]] (union [[x]] [[x1]])))))).
      intros. instantiate_cofinites.
      assert (Heq:forall X, (x | x1 -^ X) = (x -^ X) | (x1-^X)) by eauto. rewrite Heq.
      split~. applys DSub_CovAll. intros. rewrite Heq. inv_forall.
      convert2dsub. applys~ DSub_UnionL H3 H6.
    + exists B0. exists (union [[B]] [[B0]]). convert2dsub. split~.
    + exists t_bot. exists. split~. eauto.
  -  forwards~ (Ha1&Ha2): algo_sub_and_inv HS... inverts H.
     forwards: IH Ha1... forwards: IH Ha2...
     exists x. exists (x0 `union` x2 `union` [[x]] `union` [[x1]]).
     intros. instantiate_cofinites.
     auto_unify_2. forwards~ : open_typ_wrt_typ_inj H5.
     subst. split~.
     convert2asub. applys ASub_forall. intros Y Fry.
     instantiate_cofinites_with Y.
     inv_forall. applys* ASub_and H1.

     Unshelve. all: apply empty.
Qed.

Lemma napplyty_sub_inv : forall (A B C : typ),
    NApplyTy (t_arrow A B) C -> C <: A -> False.
Proof.
  introv HA Sub.
  indTypSize (size_typ C).
  lets~ [Hu|(?&?&Hu)]: ordu_or_split C...
  - forwards~ : applyty_completeness_1 (t_arrow A B) C B.
    applys~ DSub_FunCon. forwards* : napplyty_lc_1 HA.
    destruct_conj.
    solve_false.
  - forwards [?|?]: napplyty_splitu_arg_inv HA Hu.
    + cut (x <: A).
      * intros Sub'. applys IH H Sub'. elia.
      * applys DSub_Trans Sub. convert2asub. eauto.
    + cut (x0 <: A).
      * intros Sub'. applys IH H Sub'. elia.
      * applys DSub_Trans Sub. convert2asub. eauto.
Qed.

Lemma applyty_forall_inv : forall (A B C : typ),
    ApplyTy (t_forall A) B C -> False.
Proof.
  introv HA. inductions HA. eauto.
Qed.

#[export] Hint Immediate napplyty_sub_inv applyty_forall_inv : FalseHd.

(*------------------------------ Lemma B.10 ----------------------------------*)

(* B.10 [1] *)
Lemma monotonicity_applyty_1 : forall A A' (F : Fty) C,
    ApplyTy A F C -> A' <: A -> exists C', C' <: C /\ ApplyTy A' F C'.
Proof with try eassumption; elia; solve_false; destruct_conj.
  introv HA HS.
  indTypFtySize (size_typ A' + size_typ A + size_Fty F).
  lets~ [HF|(?&?&?&?&?)]: (ordu_or_split_Fty F). eauto.
  2: { subst. forwards : applyty_splitu_arg_inv HA H0. destruct_conj.
       subst. forwards (?&?&?): IH H1... forwards (?&?&?): IH H2...
       exists. split. 2: applys~ ApplyTyUnionArg H0...
       applys~ DSub_UnionL. }
  inverts HF.
  - forwards: applyty_soundness_1 HA.
    forwards HSN: DSub_Trans HS...
    forwards~ : applyty_completeness_1 HSN. destruct_conj.
    inv_arrow. convert2dsub. exists* x.
  - forwards: applyty_soundness_2 HA...
    pick_fresh Y. forwards~ : H1 Y...
    forwards HSN: DSub_Trans HS...
    forwards~ : applyty_completeness_2 HSN...
    pick fresh X.
    forwards~ : H4 X. destruct_conj.
    eapply applyty_rename in H5. exists. split...
    simpl_rename_goal. subst~.
    convert2asub.
    forwards : algo_sub_forall_inv X H6.
    eapply asub2nsub in H0.
    eapply typsubst_typ_new_sub in H0.
    rewrite 2 typsubst_typ_spec in H0;
      rewrite 2 close_typ_wrt_typ_open_typ_wrt_typ in H0.
    apply asub2nsub.
    all: eauto.
Qed.

(* B.10 [2] *)
Lemma monotonicity_applyty_2_1 : forall (A B B' C : typ),
    ApplyTy A B C -> B' <: B ->
    exists C', C' <: C /\ ApplyTy A B' C'.
Proof with try eassumption; elia; solve_false; destruct_conj.
  introv HA HS.
  indTypFtySize (size_typ A + size_typ B' + size_typ B).
  lets~ [HF|(?&?&?)]: (ordu_or_split B').
  - forwards: applyty_soundness_1 HA.
    forwards HSN: DSub_Trans H... applys DSub_FunCon HS. eauto.
    forwards~ : applyty_completeness_1 HSN. destruct_conj.
    inv_arrow. convert2dsub. exists* x.
  - assert (S1: x <: B). {
      applys~ DSub_Trans HS.
      convert2asub. use_left_r... applys ASub_refl. eauto.
    }
    forwards: IH S1...
    assert (S2: x0 <: B). {
      applys~ DSub_Trans HS.
      convert2asub. use_right_r... applys ASub_refl. eauto.
    }
    forwards: IH S2...
    exists (x1|x2). split~. applys~ ApplyTyUnionArg H.
Qed.

(*---------------------- Inversion of Subtyping on (Co-)Value types ----------*)

(* [5] *)
Lemma applyty_arrow : forall A1 A2 V B,
    ApplyTy (t_arrow A1 A2) V B -> isValFty V -> exists V', V = fty_StackArg V' /\ isValTyp V'.
Proof.
  introv App Val.
  inductions App.
  - inverts* Val.
  - inverts* Val.
Qed.

(* [6] *)
Lemma applyty_forall : forall A V B,
    ApplyTy (t_forall A) V B -> isValFty V -> exists C, V = fty_StackTyArg C.
Proof.
  introv App Val.
  inductions App.
  - inverts* Val.
  - exfalso.
    inverts Val. inverts_typ.
    forwards~ (?&?): IHApp1. solve_false.
Qed.

(* [7] *)
Lemma apply_top_false_1 : forall V,
    isValTyp V -> NApplyTy t_top [| V |].
  introv Val. constructor*.
Qed.

(* [7] *)
Lemma apply_top_false_2 : forall V,
    isValTyp V -> NApplyTy t_top V.
Proof with eauto.
  introv Val. induction* Val.
Qed.

(* [7] *)
Lemma applyty_top : forall V A,
    ApplyTy t_top V A -> False.
Proof.
  introv App.
  inductions App.
  forwards~ : IHApp1.
Qed.

#[export] Hint Immediate applyty_top : FalseHd.

(* [8] *)
Lemma apply_box_false_1 : forall l V1 V2,
    isValTyp V1 -> isValTyp V2 -> NApplyTy (t_rcd l V1) [| V2 |].
  introv Val. constructor*.
Qed.

(* [8] *)
Lemma apply_box_false_2 : forall l V1 V2,
    isValTyp V1 -> isValTyp V2 -> NApplyTy (t_rcd l V1) V2.
Proof with eauto.
  introv Val. induction* Val.
Qed.

(*------------------------- Inversion of Type-Level Dispatch -----------------*)

(* [1] *)
Lemma applyty_bot : forall B C,
    ApplyTy t_bot B C -> C ~= t_bot.
Proof. introv H. inductions H; eauto using iso_or_2. Qed.

(* [2] the argument must be a type *)
Lemma applyty_arrow_sound_1 : forall A B F D,
    ApplyTy (t_arrow A B) F D -> exists (C:typ), F = C.
Proof. introv H. inverts* H. Qed.

(* [2] *)
Lemma applyty_arrow_sound_2 : forall (A B C D : typ),
    ApplyTy (t_arrow A B) C D -> C <: A /\ B ~= D.
Proof with try eassumption; elia; destruct_conj; auto_unify_2.
  introv HA.
  indTypSize (size_typ C).
  forwards [?|(?&?&?)]: ordu_or_split C. now eauto.
  - forwards Sub: applyty_soundness_1 HA.
    convert2asub. inv_arrow. convert2dsub.
    splits*. split~.
    forwards~ : applyty_completeness_1 (t_arrow A B) C B...
    convert2asub. inv_arrow. convert2dsub. easy.
  - forwards (?&?) : applyty_splitu_arg_inv HA...
    forwards: IH H1...
    forwards: IH H2...
    split.
    + convert2asub. applys ASub_or...
    + subst. applys~ iso_dup_1.
Qed.

(* [3] the argument must be a type argument *)
Lemma applyty_forall_sound_1 : forall A F D,
    ApplyTy (t_forall A) F D -> exists (C:typ), F = [| C |].
Proof. introv H. inductions H.
       - eauto.
       - forwards~ : IHApplyTy1. forwards~ : IHApplyTy2. destruct_conj.
         solve_false.
Qed.

(* [3] *)
Lemma applyty_forall_sound_2 : forall (A B D : typ),
    ApplyTy (t_forall A) [|B|] D -> D ~= (A ^-^ B).
Proof with destruct_conj.
  introv HA. inverts HA.
  applys iso_refl.
  inverts* H1. eauto with lngen.
Qed.

(* [7] *)
Lemma napplyty_splitu_inv : forall A (F: Fty) A1 A2,
    NApplyTy A F -> splu A A1 A2 ->
    NApplyTy A1 F \/ NApplyTy A2 F.
Proof.
  introv HA HS. gen A1 A2.
  induction HA; intros; solve_false; inverts_all_spl; auto_unify.
  all: try (forwards: IHHA; [ eassumption |.. ]).
  all: try (forwards [?|?]: IHHA; [ eassumption |.. ]).
  all: try (forwards [?|?]: IHHA1; [ eassumption |.. ]).
  all: try (forwards [?|?]: IHHA2; [ eassumption |.. ]).
  all: try solve [left*; auto]; try solve [right*; auto].
Qed.

(* [4] *)
Lemma applyty_splitu_inv : forall A (F: Fty) A1 A2 C,
    ApplyTy A F C -> splu A A1 A2 ->
    exists C1 C2, C ~= C1 | C2 /\ ApplyTy A1 F C1 /\ ApplyTy A2 F C2.
Proof with exists; splits.
  introv HA HS. gen A1 A2.
  induction HA; intros; solve_false; inverts_all_spl; auto_unify.
  all: try (forwards: IHHA; [ eassumption |.. ]).
  all: try solve [exists; splits; eauto].
  all: try (forwards: IHHA; [ eassumption |.. ]; destruct_conj).
  all: try (forwards: IHHA1; [ eassumption |.. ]; destruct_conj).
  all: try (forwards: IHHA2; [ eassumption |.. ]; destruct_conj).
  all: try lazymatch goal with
         | H: NApplyTy _ _ |- _ =>
             forwards [?|?]: napplyty_splitu_inv H; [ eassumption | .. ]
         end.
  all: auto_unify_2.
  - instantiate_cofinites...
    forwards HN: splu2nsplu H2. forwards HN': typsubst_typ_splu x B HN.
    now eauto.
    rewrite 3 typsubst_typ_spec in HN'.
    rewrite 3 close_typ_wrt_typ_open_typ_wrt_typ in HN'; [ eauto | .. ].
    all: try solve_notin.
  - exists; splits.
    2-3: applys ApplyTyUnionArg; try eassumption.
    applys iso_trans. 2: applys iso_shuffle.
    applys* iso_or_match.
    all: iso_inverts_all_lc; eauto.
  - exists; splits.
    2-3: applys ApplyTyInterL; try eassumption.
    all: eauto.
  - forwards~ [(?&?)|?]: applyty_total B2 Fty5...
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    all: try applys iso_absorb_1.
    all: try applys* iso_dup_1.
    all: iso_inverts_all_lc; eauto.
  - forwards~ [(?&?)|?]: applyty_total B1 Fty5...
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    all: try applys iso_absorb_2.
    all: try applys iso_dup_1.
    all: iso_inverts_all_lc; eauto.
  - forwards~ [(?&?)|?]: applyty_total A5 Fty5...
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    all: try applys iso_absorb_3.
    all: try applys iso_dup_1.
    all: iso_inverts_all_lc; eauto.
  - forwards~ [(?&?)|?]: applyty_total A4 Fty5...
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    all: try applys iso_absorb_4.
    all: try applys iso_dup_1.
    all: iso_inverts_all_lc; eauto.
  - exists; splits.
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    all: easy.
  - exists; splits.
    all: try (applys ApplyTyInterBoth; now eassumption).
    all: try (applys ApplyTyInterL; now eassumption).
    all: try (applys ApplyTyInterR; now eassumption).
    applys iso_trans. 2: applys* iso_dist_1.
    applys* iso_and_match.
    all: iso_inverts_all_lc; eauto.
  - exists; splits.
    all: try (applys ApplyTyInterBoth; now eassumption).
    applys iso_trans. 2: applys* iso_dist_2.
    applys* iso_and_match.
    all: iso_inverts_all_lc; eauto.
Qed.

(* [5] *)
Lemma napplyty_spliti_inv : forall A B A1 A2,
    NApplyTy A B -> spli A A1 A2 ->
    NApplyTy A1 B /\ NApplyTy A2 B.
Proof with destruct_conj; try match goal with |- lc_typ _ => eauto end; try eassumption.
  introv HN HS. gen A1 A2.
  induction HN; intros; solve_false; inverts_all_spl; auto_unify.
  all: try (forwards: IHHN; [ eassumption |.. ])...
  all: try solve [split; eauto]...
  - cut (~ B <: A3). cut (~ B <: A4).
    + split; eauto.
    + intro HF. apply H2. convert2asub.
      applys algo_trans HF. applys ASub_orr... eauto.
    + intro HF. apply H2. convert2asub.
      applys algo_trans HF. applys ASub_orl... eauto.
Qed.

(* [6] *)
Lemma apply_top_false : forall A,
    lc_typ A -> NApplyTy t_top A.
Proof with eauto.
  introv Lc. induction* Lc.
Qed.

(*------------------------------ Lemma B.22 -----------------------------------*)

(* B.22 (1) *)
Lemma applyty_arrow_complete : forall A B C,
    C <: A -> lc_typ B -> exists D, ApplyTy (t_arrow A B) C D.
Proof with elia.
  introv Sub HB.
  indTypSize (size_typ C).
  forwards [?|(?&?&?)]: ordu_or_split C. now eauto.
  - forwards: applyty_completeness_1 (t_arrow A B) C B.
    + convert2asub. applys* ASub_arrow.
    + easy.
    + destruct_conj. eauto.
  - cut (x <: A). cut (x0 <: A).
    + introv Sub1 Sub2.
      forwards~ : IH A B Sub1...
      forwards~ : IH A B Sub2...
      destruct_conj.
      exists*.
    + convert2asub. applys* algo_trans Sub.
    + convert2asub. applys* algo_trans Sub.
Qed.

(* B.22 (2) *)
Lemma applyty_forall_complete : forall A B,
    lc_typ (t_forall A) -> lc_typ B -> exists C, ApplyTy (t_forall A) [|B|] C.
Proof with elia.
  intros. exists.
  constructor*.
Qed.

(* B.22 (3) *)
Lemma applyty_inter : forall B A1 A2 C1 C2,
    ApplyTy A1 B C1 -> ApplyTy A2 B C2 ->
    exists C, ApplyTy (A1&A2) B C.
Proof with destruct_conj.
  introv H1 H2.
  indTypFtySize (size_Fty B).
  forwards [?|(?&?&?)]: ordu_or_split_Fty B... now eauto.
  - exists. applys* ApplyTyInterBoth.
  - subst.
    forwards* (?&?) : applyty_splitu_arg_inv H1.
    forwards* (?&?) : applyty_splitu_arg_inv H2...
    forwards: IH (fty_StackArg x0) A1 A2; try eassumption; elia.
    forwards: IH (fty_StackArg x1) A1 A2; try eassumption; elia...
    exists*.
Qed.

(* B.22 (4) *)
Lemma applyty_union : forall B A1 A2 C1 C2,
    ApplyTy A1 B C1 -> ApplyTy A2 B C2 ->
    exists C, ApplyTy (A1 | A2) B C.
Proof with try eassumption; destruct_conj.
  introv H1 H2.
  indTypFtySize (size_Fty B).
  forwards [?|(?&?&?)]: ordu_or_split_Fty B... now eauto.
  - exists. applys ApplyTyUnion...
  - subst.
    forwards* (?&?) : applyty_splitu_arg_inv H1.
    forwards* (?&?) : applyty_splitu_arg_inv H2...
    forwards: IH (fty_StackArg x0) A1 A2; try eassumption; elia.
    forwards: IH (fty_StackArg x1) A1 A2; try eassumption; elia...
    exists*.
Qed.

(*------------------------- Type Substitution --------------------------------*)
Lemma typsubst_iso : forall A B C X,
  A ~= B -> lc_typ C ->
  ([X ~~> C] A) ~= ([X ~~> C] B).
Proof.
  introv (HS1&HS2) Lc. unfold iso.
  split; convert2asub;
    applys~ typsubst_typ_algo_sub.
Qed.

Lemma applyty_iso : forall (A A' B B' C : typ),
    ApplyTy A B C -> A' ~= A -> B' ~= B ->
    exists C', C' <: C /\ ApplyTy A' B' C'.
Proof with try eassumption.
  introv App (HS1&HS1') (HS2&HS2').
  forwards (?&Sub&App'): monotonicity_applyty_1 App...
  forwards (?&Sub'&App''): monotonicity_applyty_2_1 App'...
  exists. split. applys DSub_Trans... apply App''.
Qed.

(* Type Substitution Over Type-Level Dispatch *)
Lemma typsubst_applyty : forall (A B C U : typ) X,
    ApplyTy A B C -> lc_typ U ->
    exists C', ApplyTy ([X ~~> U] A) ([X ~~> U] B) C' /\ C' <: [X ~~> U] C.
Proof with try eassumption.
  introv App Lc.
  apply applyty_soundness_1 in App.
  convert2asub. eapply typsubst_typ_algo_sub in App...
  convert2dsub. simpl in App.
  forwards (?&?&?): applyty_completeness_1_all App.
  exists x; split; convert2asub; auto_inv...
Qed.


Require Import VST.floyd.proofauto.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Export RBTree.definitions2.
Require Import RBTree.AuxiliaryTac.
Require Import Coq.Logic.Classical.
Import ListNotations.
Local Open Scope Z.

(* --------------------------------------------------------- *)

(* --------------------------------------------------------- *)
Module getColor1.

Definition get_color1_spec :=
  DECLARE _get_color1
  WITH p: val,
       p_par: val,
       p_l: val,
       p_r: val,
       n: Node,
       b: bool
  PRE [tptr t_struct_tree]
    PROP (b = false <-> p = nullval)
    PARAMS (p)
    GLOBALS ()
    SEP (if b then
           data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node n))),
                                      (Vint (Int.repr (key_of_node n)),
                                       (Vint (Int.repr (value_of_node n)),
                                        (p_l, (p_r, p_par))))) p
         else emp)
  POST [tint]
    PROP (b = false <-> p = nullval)
    RETURN ( Vint (Int.repr (
      if b then (* p <> nullval *)
        Col2Z (color_of_node n)
      else -1)) )
    SEP (if b then
           data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node n))),
                                      (Vint (Int.repr (key_of_node n)),
                                       (Vint (Int.repr (value_of_node n)),
                                        (p_l, (p_r, p_par))))) p
         else emp)
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ get_color1_spec ]).

Lemma body_get_color1: semax_body Vprog Gprog
                                    f_get_color1 get_color1_spec.
Proof.
  start_function.
  destruct b.
  + (* b = true *)
    assert_PROP (p <> nullval) by entailer!.
    forward_if. (* if (p == NULL) *)
    - congruence. (* p == NULL *)
    - forward.
      forward.
  + (* b = false *)
    assert_PROP (p = nullval).
    { entailer!.
      pose proof proj1 H eq_refl.
      auto. }
    forward_if. (* if (p == NULL) *)
    - forward. (* p == NULL *)
    - congruence.
Qed.

End getColor1.

(*  --------------------------------------------------------- *)

Module getColor2.

Definition get_color2_spec :=
  DECLARE _get_color2
  WITH t: tree,
       p: val,
       p_par: val,
       b: bool
  PRE [tptr t_struct_tree]
    PROP (b = false <-> p = nullval)
    PARAMS (p)
    GLOBALS ()
    SEP (if b then
           rbtree_rep t p p_par
         else emp)
  POST [tint]
    PROP (b = false <-> p = nullval)
    RETURN ( Vint (Int.repr (
      if b then (* p <> nullval *)
        match t with
        | T _ n _ => Col2Z(color_of_node(n))
        | E => -2 (* unknown error *)
        end
      else -1)) )
    SEP (if b then
           rbtree_rep t p p_par
         else emp)
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ get_color2_spec ]).

Lemma body_get_color2: semax_body Vprog Gprog
                                    f_get_color2 get_color2_spec.
Proof.
  start_function.
  destruct b.
  + (* b = true *)
    assert_PROP (p <> nullval).
    { entailer!.
      pose proof proj2 H eq_refl.
      congruence. }
    forward_if. (* if (p == NULL) *)
    - congruence. (* p == NULL *)
    - assert_PROP ( t <> E ).
      { entailer!.
        pose proof proj2 H2 eq_refl.
        tauto. }
      destruct t as [|l n r] eqn:Et; [tauto|]. (* t = T l n r *)
      expand rbtree_rep.
      Intros p_lch p_rch.
      forward.
      forward.
      expand rbtree_rep.
      Exists p_lch p_rch.
      entailer!.
  + (* b = false *)
    assert_PROP (p = nullval).
    { entailer!.
      pose proof proj1 H eq_refl.
      auto. }
    forward_if. (* if (p == NULL) *)
    - forward. (* p == NULL *)
    - congruence.
Qed.

End getColor2.

(* --------------------------------------------------------- *)
Module makeBlack.
Definition make_black_spec :=
  DECLARE _make_black
  WITH t_initial: tree,
       b_initial: val,
       p_par_initial: val
  PRE [ tptr (tptr t_struct_tree) ]
    PROP (b_initial <> nullval)
    PARAMS (b_initial)
    GLOBALS ()
    SEP (treebox_rep t_initial b_initial p_par_initial)
  POST [ Tvoid ]
    PROP ()
    RETURN ()
    SEP (treebox_rep (makeBlack t_initial) b_initial p_par_initial)
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ make_black_spec ]).

Lemma body_make_black: semax_body Vprog Gprog
                                    f_make_black make_black_spec.
Proof.
  start_function.
  forward_if.
  + forward.
  + expand treebox_rep.
    Intros p_initial.
    forward.
    forward_if.
    - assert_PROP(t_initial = E).
      pose proof rbtree_rep_nullval t_initial p_par_initial.
      entailer!. tauto.
      forward.
      simpl. unfold treebox_rep, rbtree_rep. Exists nullval.
      entailer!.
    - assert_PROP(t_initial <> E).
      { destruct t_initial.
        { unfold rbtree_rep. entailer!. }
        { pose proof T_neq_E t_initial1 t_initial2 n.
          entailer!. } }
      destruct t_initial; [congruence|].
      unfold makeBlack.
      expand rbtree_rep.
      Intros p_lch p_rch.
      forward.
      expand treebox_rep.
      Exists p_initial.
      entailer!.
      expand rbtree_rep.
      Exists p_lch p_rch.
      entailer!.
Qed.
End makeBlack.

(* --------------------------------------------------------- *)
Module leftRotate.

Definition left_rotate_spec :=
  DECLARE _left_rotate
  WITH p_l: val,
       p_r: val,
       p_par: val,
       p_mid: val,
       p_l_l: val,
       p_r_r: val,
       l_n: Node,
       r_n: Node,
       tree_l_l: tree,
       tree_r_r: tree,
       tree_mid: tree
  PRE [ tptr t_struct_tree ]
    PROP (is_pointer_or_null p_par;
          Int.min_signed <= key_of_node r_n <= Int.max_signed;
          Int.min_signed <= key_of_node l_n <= Int.max_signed)
    PARAMS (p_l)
    GLOBALS ()
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_r, p_par))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_mid, (p_r_r, p_l))))) p_r;
         rbtree_rep tree_mid p_mid p_r;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r )
  POST [ tptr t_struct_tree ]
    PROP (isptr p_r; p_r <> nullval;
          is_pointer_or_null p_par;
          Int.min_signed <= key_of_node r_n <= Int.max_signed;
          Int.min_signed <= key_of_node l_n <= Int.max_signed)
    RETURN (p_r)
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_mid, p_r))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_l, (p_r_r, p_par))))) p_r;
         rbtree_rep tree_mid p_mid p_l;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r ) (* p_par还连在p_l上 *)
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ left_rotate_spec ]).

Lemma body_left_rotate: semax_body Vprog Gprog
                                    f_left_rotate left_rotate_spec.
Proof.
  start_function.
  forward. (* struct tree * r = l->right; *)
  forward. (* struct tree * mid = r->left; *)
  forward.
  forward. (* r->left = l; *)
  forward.
  forward.
  forward. (* l->par = r; *)
  forward_if (
    PROP (isptr p_r; is_pointer_or_null p_par)
    LOCAL (temp _t'1 p_par; temp _mid p_mid; temp _r p_r; temp _l p_l)
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_mid, p_r))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_l, (p_r_r, p_par))))) p_r;
         rbtree_rep tree_mid p_mid p_l;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r )).
  + assert_PROP (tree_mid <> E) by (entailer!; tauto). (* mid != NULL *)
    destruct tree_mid eqn:tree_mid_fact; [congruence|]. (* tree_mid = T t1 n t2 *)
    expand rbtree_rep. (* rbtree_rep (T t1 n t2) p_mid p_r *)
    Intros p_mid_l p_mid_r.
    forward. (* mid->par = l; *)
    entailer!.
    expand rbtree_rep.
    Exists p_mid_l p_mid_r.
    entailer!.
  + forward. (* mid = NULL *)
    entailer!.
    assert (tree_mid = E) by tauto.
    subst.
    expand rbtree_rep.
    entailer!.
  + forward. (* return r; 证明r满足后条件 *)
Qed.

End leftRotate.

(* --------------------------------------------------------- *)
Module leftRotateWrap.

Definition left_rotate_wrap_spec := (* 就是为了处理p_l父亲的不同情况的 *)
  DECLARE _left_rotate_wrap
  WITH p_l: val,
       p_r: val,
       p_par: val,
       p_mid: val,
       p_l_l: val,
       p_r_r: val,
       p_root: val,
       p_top: val,
       l_n: Node,
       r_n: Node,
       tree_l_l: tree,
       tree_r_r: tree,
       tree_mid: tree,
       root: val,
       b: bool,
       isleft: bool,
       p_gpar: val,
       p_unc: val,
       par_n: Node,
       uncisnull: bool,
       tree_unc: tree
  PRE [ tptr t_struct_tree, tptr (tptr t_struct_tree) ]
    PROP (nullval = p_par <-> b = false;
          Int.min_signed <= key_of_node r_n <= Int.max_signed;
          Int.min_signed <= key_of_node l_n <= Int.max_signed;
          p_top = nullval; p_l <> nullval;
          is_pointer_or_null p_par;
          is_pointer_or_null p_unc;
          p_unc <> p_l)
    PARAMS (p_l; root)
    GLOBALS ()
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_r, p_par))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_mid, (p_r_r, p_l))))) p_r;
         rbtree_rep tree_mid p_mid p_r;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r;
         if b then
           data_at Tsh (tptr t_struct_tree) p_root root *
           (if uncisnull then !! (p_unc = nullval) &&emp
             else rbtree_rep tree_unc p_unc p_par) *
           if isleft then
             data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_l, (p_unc, p_gpar))))) p_par
           else
             data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_unc, (p_l, p_gpar))))) p_par
         else
           data_at Tsh (tptr t_struct_tree) p_root root
         )
  POST [ tvoid ]
      PROP (nullval = p_par <-> b = false;
            isptr p_r; p_r <> nullval;
            Int.min_signed <= key_of_node r_n <= Int.max_signed;
            Int.min_signed <= key_of_node l_n <= Int.max_signed;
            is_pointer_or_null p_par;
            is_pointer_or_null p_unc;
            p_unc <> p_l)
      RETURN ()
      SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                      (Vint (Int.repr (key_of_node l_n)),
                                       (Vint (Int.repr (value_of_node l_n)),
                                        (p_l_l, (p_mid, p_r))))) p_l;
           data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                      (Vint (Int.repr (key_of_node r_n)),
                                       (Vint (Int.repr (value_of_node r_n)),
                                        (p_l, (p_r_r, p_par))))) p_r;
           rbtree_rep tree_mid p_mid p_l;
           rbtree_rep tree_l_l p_l_l p_l;
           rbtree_rep tree_r_r p_r_r p_r;
           if b then
             data_at Tsh (tptr t_struct_tree) p_root root *
             (if uncisnull then !! (p_unc = nullval) &&emp
               else rbtree_rep tree_unc p_unc p_par) *
             if isleft then
               data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_r, (p_unc, p_gpar))))) p_par
             else
               data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_unc, (p_r, p_gpar))))) p_par
           else
             data_at Tsh (tptr t_struct_tree) p_r root )
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ leftRotate.left_rotate_spec; left_rotate_wrap_spec ]).

Lemma body_left_rotate_wrap: semax_body Vprog Gprog
                                    f_left_rotate_wrap left_rotate_wrap_spec.
Proof.
  start_function.
  subst p_top.
  (* assert_PROP (is_pointer_or_null p_par) by entailer!. *)
  forward.
  forward_if.
  { destruct b. destruct isleft; entailer!.
    assert (nullval = p_par) by tauto.
    entailer!. }
  + destruct b.
    { subst p_par. assert(true = false) by tauto.
      congruence. }
    forward_call(p_l, p_r, (* l->par == NULL *)
        p_par, p_mid,
        p_l_l, p_r_r,
        l_n, r_n,
        tree_l_l, tree_r_r, tree_mid).
    forward.
    entailer!.
  + destruct b.
    2: { assert(nullval = p_par) by tauto. congruence. }
    destruct isleft; destruct uncisnull; Intros;
    forward; forward; forward_if_wrp; try contradiction;
    forward_call(p_l, p_r,
        p_par, p_mid,
        p_l_l, p_r_r,
        l_n, r_n,
        tree_l_l, tree_r_r, tree_mid);
    forward; entailer!.
Qed.

End leftRotateWrap.

(* --------------------------------------------------------- *)
Module rightRotate.

Definition right_rotate_spec :=
  DECLARE _right_rotate
  WITH p_l: val,
       p_r: val,
       p_par: val,
       p_mid: val,
       p_l_l: val,
       p_r_r: val,
       l_n: Node,
       r_n: Node,
       tree_l_l: tree,
       tree_r_r: tree,
       tree_mid: tree
  PRE [ tptr t_struct_tree ]
    PROP (is_pointer_or_null p_par;
          Int.min_signed <= key_of_node l_n <= Int.max_signed;
          Int.min_signed <= key_of_node r_n <= Int.max_signed)
    PARAMS (p_r)
    GLOBALS ()
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_mid, p_r))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_l, (p_r_r, p_par))))) p_r;
         rbtree_rep tree_mid p_mid p_l;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r )
  POST [ tptr t_struct_tree ]
    PROP (isptr p_l; p_l <> nullval;
          is_pointer_or_null p_par;
          Int.min_signed <= key_of_node r_n <= Int.max_signed;
          Int.min_signed <= key_of_node l_n <= Int.max_signed)
    RETURN (p_l)
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_r, p_par))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_mid, (p_r_r, p_l))))) p_r;
         rbtree_rep tree_mid p_mid p_r;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r )
.
Definition Gprog : funspecs :=
         ltac:(with_library prog [ right_rotate_spec ]).

Lemma body_right_rotate: semax_body Vprog Gprog
                                    f_right_rotate right_rotate_spec.
Proof.
  start_function.
  forward.
  forward.
  forward.
  forward.
  forward.
  forward.
  forward.
  forward_if (
    PROP (isptr p_l; is_pointer_or_null p_par)
    LOCAL (temp _t'1 p_par; temp _mid p_mid; temp _r p_r; temp _l p_l)
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_r, p_par))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_mid, (p_r_r, p_l))))) p_r;
         rbtree_rep tree_mid p_mid p_r;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r )).
  + assert_PROP (tree_mid <> E) by (entailer!; tauto).
    destruct tree_mid eqn:tree_mid_fact; [congruence|].
    expand rbtree_rep.
    Intros p_mid_l p_mid_r.
    forward.
    entailer!.
    expand rbtree_rep.
    Exists p_mid_l p_mid_r.
    entailer!.
  + forward. (* mid = NULL *)
    entailer!.
    assert (tree_mid = E) by tauto.
    subst.
    expand rbtree_rep.
    entailer!.
  + forward.
Qed.

End rightRotate.

(* --------------------------------------------------------- *)
Module rightRotateWrap.

Definition right_rotate_wrap_spec := (* 就是为了处理p_r父亲的不同情况的 *)
  DECLARE _right_rotate_wrap
  WITH p_l: val,
       p_r: val,
       p_par: val,
       p_mid: val,
       p_l_l: val,
       p_r_r: val,
       p_root: val,
       p_top: val,
       l_n: Node,
       r_n: Node,
       tree_l_l: tree,
       tree_r_r: tree,
       tree_mid: tree,
       root: val,
       b: bool,
       isleft: bool,
       p_gpar: val,
       p_unc: val,
       par_n: Node,
       uncisnull: bool,
       tree_unc: tree
  PRE [ tptr t_struct_tree, tptr (tptr t_struct_tree) ]
    PROP (nullval = p_par <-> b = false;
          Int.min_signed <= key_of_node l_n <= Int.max_signed;
          Int.min_signed <= key_of_node r_n <= Int.max_signed;
          p_r <> nullval; p_top = nullval;
          is_pointer_or_null p_par;
          is_pointer_or_null p_unc;
          p_unc <> p_r)
    PARAMS (p_r; root)
    GLOBALS ()
    SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                    (Vint (Int.repr (key_of_node l_n)),
                                     (Vint (Int.repr (value_of_node l_n)),
                                      (p_l_l, (p_mid, p_r))))) p_l;
         data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                    (Vint (Int.repr (key_of_node r_n)),
                                     (Vint (Int.repr (value_of_node r_n)),
                                      (p_l, (p_r_r, p_par))))) p_r;
         rbtree_rep tree_mid p_mid p_l;
         rbtree_rep tree_l_l p_l_l p_l;
         rbtree_rep tree_r_r p_r_r p_r;
         if b then
           data_at Tsh (tptr t_struct_tree) p_root root *
           (if uncisnull then !! (p_unc = nullval) && emp
               else rbtree_rep tree_unc p_unc p_par) *
           if isleft then
             data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_r, (p_unc, p_gpar))))) p_par
           else
             data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_unc, (p_r, p_gpar))))) p_par
         else
           data_at Tsh (tptr t_struct_tree) p_root root
         )
  POST [ tvoid ]
      PROP (nullval = p_par <-> b = false;
            Int.min_signed <= key_of_node l_n <= Int.max_signed;
            Int.min_signed <= key_of_node r_n <= Int.max_signed;
            is_pointer_or_null p_par;
            is_pointer_or_null p_unc;
            p_unc <> p_r)
      RETURN ()
      SEP (data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node l_n))),
                                      (Vint (Int.repr (key_of_node l_n)),
                                       (Vint (Int.repr (value_of_node l_n)),
                                        (p_l_l, (p_r, p_par))))) p_l;
           data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node r_n))),
                                      (Vint (Int.repr (key_of_node r_n)),
                                       (Vint (Int.repr (value_of_node r_n)),
                                        (p_mid, (p_r_r, p_l))))) p_r;
           rbtree_rep tree_mid p_mid p_r;
           rbtree_rep tree_l_l p_l_l p_l;
           rbtree_rep tree_r_r p_r_r p_r;
           if b then
             data_at Tsh (tptr t_struct_tree) p_root root *
             (if uncisnull then !! (p_unc = nullval) && emp
               else rbtree_rep tree_unc p_unc p_par) *
             if isleft then
               data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_l, (p_unc, p_gpar))))) p_par
             else
               data_at Tsh t_struct_tree (Vint (Int.repr (Col2Z (color_of_node par_n))),
                                        (Vint (Int.repr (key_of_node par_n)),
                                         (Vint (Int.repr (value_of_node par_n)),
                                          (p_unc, (p_l, p_gpar))))) p_par
           else
             data_at Tsh (tptr t_struct_tree) p_l root )
.

Definition Gprog : funspecs :=
         ltac:(with_library prog [ rightRotate.right_rotate_spec; right_rotate_wrap_spec ]).

Lemma body_right_rotate_wrap: semax_body Vprog Gprog
                                    f_right_rotate_wrap right_rotate_wrap_spec.
Proof.
  start_function.
  subst p_top.
  (* assert_PROP (is_pointer_or_null p_par) by entailer!. *)
  forward.
  forward_if.
  { destruct b. destruct isleft; entailer!.
    assert (nullval = p_par) by tauto.
    entailer!. }
  + destruct b.
    { subst p_par. assert(true = false) by tauto.
      congruence. }
    forward_call(p_l, p_r, (* l->par == NULL *)
        p_par, p_mid,
        p_l_l, p_r_r,
        l_n, r_n,
        tree_l_l, tree_r_r, tree_mid).
    forward.
    entailer!.
  + destruct b.
    2: { assert(nullval = p_par) by tauto. congruence. }
    destruct isleft, uncisnull; Intros;
    forward; forward; forward_if_wrp; try contradiction; try solve[
    forward_call(p_l, p_r,
        p_par, p_mid,
        p_l_l, p_r_r,
        l_n, r_n,
        tree_l_l, tree_r_r, tree_mid);
    forward; entailer!].
Qed.

End rightRotateWrap.


Require Import Iron.Language.SimpleData.Exp.
Require Export Iron.Data.Context.
Require Export Iron.Data.Chain.

(********************************************************************)
(*  Evaluation contexts for expressions.
    This describes a place in the exp AST where the sub-expression
    there is able to take an evaluation step *)
Inductive exp_ctx : (exp -> exp) -> Prop :=

 (* The top level context names the entire expression *)
 | XcTop
   : exp_ctx  (fun x => x)

 (* Left of an application *)
 | XcApp1
   :  forall x2
   ,  exp_ctx  (fun xx => XApp xx x2)

 (* The right of an application can step only when the left is
    already a value. *)
 | XcApp2
   :  forall v1
   ,  value v1
   -> exp_ctx  (fun xx => XApp v1 xx)

 (* As the XCon constructor contains a list of sub-expressions,
    we need an additional exps_ctx context to indicate which one
    we're talking about. *)
 | XcCon
   :  forall dc C
   ,  exps_ctx wnfX C
   -> exp_ctx  (fun xx => XCon dc (C xx))

 (* We need to reduce the discriminant of a case to a value. *)
 | XcCase
   :  forall alts
   ,  exp_ctx  (fun xx => XCase xx alts).

Hint Constructors exp_ctx.


Require Import memory.
Require Import language.
Require Import opsem.
Require Import assertion.
Set Asymmetric Patterns.
(*
Definition emposspec : osspec :=
  ( fun (i : fid) => None,   fun (i : hid) => None, fun _ _ =>  True ).
 *)

Notation hmstep := spec_step.
Notation hmstepstar:=spec_stepstar.

(*
Definition absimp' sc (p p' : asrt) :=
forall (s : taskst) (O : osabst) (gamma : absop),
(s, O, gamma) |= p ->
forall Of OO,
  join O Of OO ->
  exists O' gamma' OO OO',
    join O' Of OO' /\
    hmstepstar sc gamma OO gamma'
               OO' /\ (s, O', gamma') |= p'.
 *)

Definition satp o O p := forall aop,   (o,O, aop)  |= p.

Definition LocalInv := tid -> list logicvar ->  asrt.

Definition p_exact lasrt :=
  forall ge le M ir aux O le' M' aux' ir' O',
    satp (ge,le,M,ir,aux) O lasrt ->
    satp (ge,le',M',ir',aux') O' lasrt ->
    M' = M /\ O' = O.

Definition GoodLInvAsrt (p : LocalInv):= forall t lg, GoodLocalInvAsrt (p t lg) /\ p_exact (p t lg).

Definition CurTid t :=  (EX tp : type, GV OSTCBCur @ Tptr tp |-r-> Vptr t).

Definition LINV p t lg :=  p t lg ** [|GoodLInvAsrt p|].

Definition p_local (p : LocalInv) (t:tid) lg  := CurTid t **  LINV p t lg.

Definition CurLINV p t := EX lg, CurTid t **  LINV p t lg ** Atrue.

(**For specifying the spawned tasked in ucos**)
Definition  init_lg := (logic_val  (Vint32 (Int.repr 1%Z)) :: nil).
(**Configure it in terms of different target kernels***)

Definition  absimplication sc (li : LocalInv) (p p' : asrt) (t : tid) :=
  forall (s : taskst) (O : osabst) (gamma : absop),
    (s, O, gamma) |= p /\ satp s O  (CurLINV li t)  ->
    exists O' gamma',
      hmstepstar sc gamma O gamma' O' /\ (s, O', gamma') |= p' /\
      satp s O'  (CurLINV li t)  .

Definition sched_self sc (O : osabst) :=
  exists t, get O curtid = Some (oscurt t) /\ sc O t.

Inductive absinferfull : ossched ->LocalInv ->  asrt -> asrt -> tid -> Prop :=
| absinfer_eq' :
    forall p sc li t,
      absinferfull sc li p p t

| absinfer_trans' :
    forall p q r sc li t,
      absinferfull sc li p q t -> absinferfull sc li  q r t -> absinferfull sc li  p r t

| absinfer_disj':
    forall p1 p2 q1 q2 sc li t,
      absinferfull sc li p1 q1 t ->
      absinferfull sc li p2 q2 t ->
      absinferfull sc li (p1\\//p2) (q1\\// q2) t

| absinfer_conseq' :
    forall p q p' q' sc li t,
      q ==> q' ->
      absinferfull sc li p q  t->
      p'==> p -> absinferfull sc li p' q' t

| absinfer_ex' :
    forall  (tp:Type) (p:tp->asrt) q sc li t,
      (forall x,absinferfull sc li (p x) q t)  -> absinferfull sc li  (EX x:tp,p x) q t

| absinfer_frm' :
    forall p q r sc li t,
      can_change_aop r ->
      p ==> (CurLINV li t)  ->
      absinferfull sc li p q t -> absinferfull sc li (p ** r) (q ** r) t

| absinfer_prim':
    forall p q step vl v sc li t,
      can_change_aop p ->
      can_change_aop q ->
      absimplication sc li (<||step (|vl|)||> ** p) (<||END v||> ** q) t
      -> absinferfull sc li (<||step (|vl|)||> ** p) (<||END v||> ** q) t

| absinfer_seq': forall p q s1 s2 s1' sc li t,
                   can_change_aop p ->
                   can_change_aop q ->
                   absinferfull sc li (<||s1||> ** p) (<||s1'||> ** q) t ->
                   absinferfull sc li  (<||s1 ;; s2 ||> **p ) (<||s1';;s2||>**q) t

| absinfer_seq_end': forall p q s v sc li t,
                       can_change_aop p ->
                       can_change_aop q ->
                       p ==> q ->
                       absinferfull sc li  (<||END v ;; s ||> **p ) (<||s||> ** q) t

| absinfer_choice1':
    forall p q s1 s2 sc li t,
      can_change_aop p ->
      can_change_aop q ->
      p ==> q ->
      absinferfull sc li (<||s1 ?? s2 ||> ** p) (<||s1||> ** q) t

| absinfer_choice2' :
    forall p q s1 s2 sc li t,
      can_change_aop p ->
      can_change_aop q ->
      p ==> q ->
      absinferfull sc li (<||s1 ?? s2 ||> ** p ) (<||s2||> ** q) t

|absinfer_assume' :
   forall  p (b:absexpr) q sc li t,
     can_change_aop p ->
     can_change_aop q ->
     p  ==> q ->
     (forall s, (s |= p) -> b (getabst s)) ->
     absinferfull sc li (<||ASSUME b||> ** p) (<||END None||> ** q) t

|absinfer_sched' :
   forall  p (b:absexpr) q sc li t,
     can_change_aop p ->
     can_change_aop q ->
     p  ==> q ->
     (forall s, (s |= p) -> sched_self sc  (getabst s)) ->
     absinferfull sc li (<||sched||> ** p) (<||END None||> ** q) t.

Notation "  '#' sc , li , t '⊢' p '⇒' q " := (absinferfull sc li  p q t) (at level 80).

Definition match_tid_prio (tls:  TcbMod.map) (v v' : val) :=
  (exists pr a tid msg, v = Vptr tid /\
                        get tls tid = Some (pr, a, msg) /\ v' = Vint32 pr).

Definition  retpost (p : fpost) : Prop :=
  forall s vl v logicl tid, sat s (getasrt (p vl v logicl tid)) -> v <> None.

Fixpoint GoodStmt' s :=
  match s with
    | sskip _ => True
    | sassign _ _ => True
    | sif _ s1 s2 => GoodStmt' s1 /\ GoodStmt' s2
    | sifthen _ s => GoodStmt' s
    | swhile _ s' => GoodStmt' s'
    | sret => True
    | srete _ => True
    | scall f _ => True
    | scalle _ f _ => True
    | sseq s1 s2 => GoodStmt' s1 /\ GoodStmt' s2
    | sprint _ => True
    | sfexec _ _ _ => False
    | sfree _ _ => False
    | salloc _ _ => False
    | sprim _ => True
    | hapi_code _ => False
  end.

Definition GoodSched (sd : ossched) :=
  (
    forall x a y t, join x a y -> sd x t -> sd y t
  ) /\
  (
    forall x t,  sd x t ->
                 (exists tcbls tcb,
                    get x abstcblsid =
                    Some (abstcblist tcbls) /\
                    get tcbls t = Some tcb)
  ) /\
  (
    forall O1 O2 O t t',
      join O1 O2 O ->
      sd O1 t ->
      sd O t' ->
      sd O1 t'
  ).

Fixpoint GoodFrm (p : asrt){struct p}: Prop :=
  match p with
    | Aie _ => False
    | Ais _ => False
    | ATopis  _ =>  False
    | Aisr _ => False
    | Acs _ => False
    | p' //\\ q' =>  GoodFrm  p' /\ GoodFrm q'
    | p' \\// q' => GoodFrm  p' /\ GoodFrm  q'
    | p' ** q' => GoodFrm p' /\ GoodFrm q'
    | Aexists t p' => forall x, GoodFrm (p' x)
    | Anot _ => False
    | Aop _ => False
    | _ => True
  end.

Definition GoodI (I:Inv) (sd : ossched) (pa:LocalInv):=
  (
    forall o O O' ab OO, (o,O,ab) |= starinv_noisr I 0%nat (S INUM) -> join O O' OO-> O' = empabst
  ) /\
  (
    forall o O ab tid, (o,O,ab)|= SWINVt I tid->
                       exists b tp, get (get_genv (get_smem o)) OSTCBCur = Some (b,(Tptr tp)) /\
                                    load (Tptr tp) (get_mem (get_smem o)) (b,0%Z) = Some (Vptr tid) /\
                                    get O curtid = Some (oscurt tid)
  )  /\
  (
    forall o O ab tid b tp M' ct,
      (o,O,ab)|= SWINVt I ct ->
      (o,O,ab) |= AHprio sd tid ** Atrue ->
      get (get_genv (get_smem o)) OSTCBCur = Some (b,(Tptr tp))  ->
      store (Tptr tp) (get_mem (get_smem o)) (b,0%Z) (Vptr tid) = Some M' ->
      exists tls,
        get O abstcblsid = Some (abstcblist tls)/\
        (
          (
            indom tls ct /\
            (substaskst o M', set O curtid (oscurt tid), ab) |= SWINVt I tid
          ) \/

          (
            ~ indom tls ct /\
            forall Mx Ox MM OO,
              satp (substaskst o Mx) Ox (EX lg, pa ct lg) ->
              join M' Mx MM ->
              join O Ox OO ->
              (substaskst o MM, set OO curtid (oscurt tid), ab) |= SWINVt I tid)
        )
  )/\
  GoodSched sd.

Definition SWPRE_NDEAD sd x tc:= SWPRE sd x tc //\\ EX tls,Aabsdata abstcblsid (abstcblist tls) ** [| indom tls tc |] ** Atrue.

Definition SWPRE_DEAD sd x tc:= SWPRE sd x tc //\\ EX tls,Aabsdata abstcblsid (abstcblist tls) ** [|~indom tls tc |] ** Atrue.

(*
Definition p_local (p : LocalInv) (t:tid) lg  :=
  (EX tp : type, GV OSTCBCur @ Tptr tp |-r-> Vptr t) ** p t lg ** [|GoodLInvAsrt p|].
 *)

Inductive InfRules: funspec -> ossched -> LocalInv -> Inv -> retasrt -> asrt ->
                    asrt -> stmts -> asrt -> tid -> Prop:=
(*| skip_rule :  forall (Spec:funspec) (I:Inv) (r:retasrt) (ri:asrt) (t:tid)
        (p:asrt) (v:option val),  InfRules Spec I r ri t p (sskip v) p (*done*)*)
| pfalse_rule: forall Spec  sd I r ri q s pa t,
                 InfRules Spec sd pa I r ri
                          Afalse s q t
| pure_split_rule: forall Spec sd I r ri p q (pu:Prop) s pa t,
                     (pu -> InfRules Spec sd pa I r ri
                                     p s q t) -> (InfRules Spec sd pa I r ri
                                                           (p**[|pu|]) s q t)

| genv_introret_rule :  forall Spec sd I r ri p q  s G pa t,
                          InfRules Spec sd pa I r ri p s q  t->
                          InfRules Spec sd pa I (fun v => (Agenv G //\\ r v)) ri
                                   (Agenv G //\\ p) s q t

| genv_introexint_rule :  forall Spec sd I r ri p q s G pa t,
                            InfRules Spec sd pa I r ri p s q t ->
                            InfRules Spec sd pa I r (Agenv G //\\ ri)
                                     (Agenv G //\\ p) s q t

| ret_rule : forall Spec sd  I r p pa t,
               (p ==> r None) ->
               InfRules Spec sd pa I r Afalse p sret Afalse  t(*done*)

| iret_rule : forall Spec sd I ri p pa t,  (p ==>  ri ) ->
                                           InfRules Spec  sd pa I arfalse ri p  (sprim exint ) Afalse  t(*done*)

| rete_rule :  forall (Spec:funspec) sd I r p e v t pa tid,
                 (p ==>  r (Some v) //\\  Rv e@t == v) ->
                 InfRules Spec sd pa I r Afalse p (srete e) Afalse tid

| call_rule :forall f Spec sd I r ri pre post p P el vl logicl tp tl pa t,
               GoodFrm p ->
               Spec f = Some (pre, post, (tp, tl)) ->
               P ==> PRE [pre, vl, logicl, t] ** p ->
               P ==> Rvl el @ tl == vl ->
               tl_vl_match tl vl = true ->
               PRE [pre, vl, logicl, t] ==> CurLINV pa t ->
               EX v : option val, POST [post, vl, v, logicl, t] ==> CurLINV pa t ->
                InfRules Spec sd pa I r ri (P) (scall f el)
                        (EX v,POST[post, vl, v ,logicl,t] ** p ) t (*done*)

      | calle_rule :  forall f e l Spec sd  I r ri pre post p P el v' vl logicl tp tl pa t,
                        GoodFrm p ->
                        retpost post ->
                        Spec f = Some (pre, post, (tp, tl)) ->
                        P ==> PRE [pre, vl, logicl, t] ** PV l @ tp |-> v' ** p ->
                        P ==> Rvl el @ tl == vl ->
                        PV l @ tp |-> v' ** p ==> Lv e @ tp == l ->
                        tl_vl_match tl vl = true ->
                        PRE [pre, vl, logicl, t] ==> CurLINV pa t ->
                        EX v : option val, POST [post, vl, v, logicl, t] ==> CurLINV pa t ->
                                           InfRules Spec sd pa I r ri ( P)
                                                    (scalle e f el) (EX v, POST[post, vl, Some v,logicl,t] ** PV l @ tp|-> v ** p )  t(*done*)

      | calle_rule_lvar: forall f x Spec sd t I r ri pre post P p el v' vl logicl tp tl pa tid,
                           GoodFrm p ->
                           retpost post ->
                           Spec f = Some (pre, post, (tp, tl)) ->
                           P ==> PRE [pre, vl, logicl, tid] ** LV x @ t |-> v' ** p ->
                           P ==> Rvl el @ tl == vl ->
                           tl_vl_match tl vl = true ->
                           PRE [pre, vl, logicl, tid] ==> CurLINV pa tid ->
                           EX v : option val, POST [post, vl, v, logicl, tid] ==>
                                                   CurLINV pa tid ->
                                              InfRules Spec sd pa I r ri (P )
                                                       (scalle (evar x) f el) (EX v, POST[post, vl, Some v,logicl,tid] ** LV x @ t |-> v ** p) tid

| conseq_rule : forall   Spec  sd  I r ri p' p q q' s pa t,
                  (p' ==>  p) ->  (q ==> q') ->
                  InfRules Spec sd pa I r ri p s q t->
                  InfRules Spec sd pa I r ri p' s q' t (*done*)

| r_conseq_rule : forall   Spec sd  I r ri r' p q ri' s pa t,
                    (forall v,r v ==> r' v) ->  (ri ==> ri') ->
                    InfRules Spec  sd pa I r ri p s q t->
                    InfRules Spec sd pa I r' ri' p s q t (*done*)

| abscsq_rule_full : forall   Spec sd  I r ri p' p q q' s pa t,
                       #sd,pa,t ⊢ p'⇒p  -> #sd, pa, t ⊢ q ⇒ q' ->
                                                    InfRules Spec sd pa I r ri p s q  t->
                                                    InfRules Spec sd pa I r ri p' s q' t (*done*)

  | seq_rule : forall  Spec sd  I r ri p p' q  s1 s2 pa t,
                     InfRules Spec sd pa I r ri p s1 p' t ->
                     InfRules Spec sd pa I r ri p' s2 q t ->
                     InfRules Spec sd pa I r ri p (sseq s1 s2) q t (*done*)

   | if_rule :  forall Spec  sd I r ri p q e tp s1 s2 pa t,
                     (p ==> EX v , Rv e @ tp ==  v) ->
                     InfRules Spec sd pa I r ri (p//\\ Aistrue e) s1 q t  ->
                     InfRules Spec sd pa I r ri (p //\\ Aisfalse e) s2 q t ->
                     InfRules Spec sd pa I r ri p (sif e s1 s2) q t (*done*)

   | ift_rule :  forall Spec sd  I r ri p q e tp s pa t,
                      (p ==> EX v , Rv e @ tp ==  v) ->
                      (p//\\ Aisfalse e ==> q) ->
                      InfRules Spec sd pa I r ri (p//\\ Aistrue e) s q t  ->
                      InfRules Spec  sd pa I r ri p (sifthen e s) q  t(*done*)

   | while_rule :  forall Spec sd  I r ri p  e s  tp pa t,
                        ( p ==> EX v , Rv e @ tp ==  v) ->
                        InfRules  Spec sd pa I r ri ( p //\\ (Aistrue e)) s p t  ->
                        InfRules Spec sd pa I r ri p (swhile e s) (p //\\ (Aisfalse e)) t   (*done*)

   | frame_rule :  forall Spec sd I p q frm s aop aop' pa t,
                     GoodI I sd pa ->
                     GoodStmt' s ->
                     GoodFrm frm ->
                     p ==> CurLINV pa t ->
                     InfRules Spec sd pa I arfalse Afalse ( <|| aop ||> ** p) s ( <|| aop' ||> ** q) t ->
                     InfRules Spec  sd pa I arfalse Afalse ( <|| aop ||> ** p ** frm ) s (<|| aop' ||> ** q ** frm) t (*done*)

   | frame_rule_all:  forall Spec sd  I r ri p q frm s pa t,
                        GoodI I sd pa ->
                        GoodStmt' s ->
                        GoodFrm frm ->
                        p ==> CurLINV pa t ->
                        InfRules  Spec sd pa I r ri p s q t ->
                        InfRules Spec sd pa I  (fun v =>(r v) ** frm)
                                 (ri**frm) (p ** frm ) s (q ** frm )  t(*done*)

   | retspec_intro_rule :  forall Spec sd pa I r ri p q s t,
                                InfRules Spec sd pa I arfalse Afalse p s q t ->
                                InfRules Spec  sd pa I r  ri p  s q  t (*done*)

   | assign_rule : forall Spec  sd I r ri p e1 e2 l v1 v2 tp1 tp2 aop pa t,
                        assign_type_match tp1 tp2 ->
                        ((p ** PV l @ tp1|-> v1) ==> Lv e1 @ tp1 == l //\\ Rv e2 @ tp2 == v2) ->
                        (p ** PV l @ tp1 |-> v2 ==> CurLINV pa t) ->
                        InfRules Spec sd pa I r ri ((<||aop||> ** p ** PV l @ tp1 |-> v1)
                                                   ) (sassign e1 e2) (<|| aop ||> ** p ** PV l @ tp1 |-> v2 ) t (*done*)

   | encrit1_rule : forall Spec sd I r ri isr is cs i aop pa t  P,
                         GoodFrm P ->
                         InfRules Spec sd pa I r ri
                                  ( <|| aop ||> ** OS[isr, true, is, cs] ** (ATopis i) ** (Apure (i <= INUM)%nat) ** P )
                                  (sprim encrit)
                                  (<||aop||> ** OS[isr, false, is, true::cs] ** (invlth_isr I O i) ** P) t (*done*)

   | encrit2_rule :  forall Spec sd  I r ri isr is cs  aop pa t  P,
                          GoodFrm P ->
                          InfRules Spec sd pa I r ri
                                   (<||aop||> ** OS[isr, false, is, cs] ** P)
                                   (sprim encrit)
                                   (<||aop||> ** OS[isr, false, is, false::cs] ** P) t

   | excrit1_rule : forall Spec sd  I r ri isr is cs  i aop pa t  P,
                         GoodFrm P ->
                         P ==> CurLINV pa t ->
                         InfRules Spec sd pa I r ri
                                  (<||aop||> ** OS[isr, false, is, true::cs] ** (ATopis i) ** (invlth_isr I O i) ** P)
                                  (sprim excrit)
                                  (<||aop||> ** OS[isr, true,  is, cs] ** P) t

   | excrit2_rule :  forall Spec  sd I r ri isr is cs aop pa t  P,
                          GoodFrm P ->
                          InfRules Spec sd pa I r ri
                                   (<||aop||> ** OS[isr, false, is, false::cs] ** P)
                                   (sprim excrit)
                                   (<||aop||> ** OS[isr, false, is, cs] ** P) t

   | cli1_rule :forall Spec sd  I r ri isr is i aop pa t P,
                     GoodFrm P ->
                     InfRules Spec sd pa I r ri
                              ( <||aop||> ** OS[isr, true, is, nil]  ** (ATopis i) ** (Apure (i <= INUM)%nat) ** P
                              )
                              (sprim cli)
                              (<||aop||> ** OS[isr, false,is, nil] ** (invlth_isr I O i) ** P) t

   | cli2_rule : forall Spec  sd I r ri isr is aop pa t  P,
                      GoodFrm P ->
                      InfRules Spec sd pa I r ri
                               (<||aop||> ** OS[isr, false, is, nil] ** P)
                               (sprim cli)
                               (<||aop||> ** OS[isr, false, is, nil] ** P) t

   | sti1_rule : forall Spec  sd I r ri isr i is  aop pa t P,
                      GoodFrm P ->
                      P ==> CurLINV pa  t ->
                      InfRules Spec  sd pa I r ri
                               (<||aop||> ** OS[isr, false, is, nil] **  (ATopis i) ** (invlth_isr I O i) ** P)
                               (sprim sti)
                               (<||aop||> ** OS[isr, true, is, nil] ** P) t

   | sti2_rule :  forall Spec pa sd I r ri isr is aop t P,
                    GoodFrm P ->
                    InfRules Spec sd pa I r ri
                             (<||aop||> ** OS[isr, true, is, nil] ** P)
                             (sprim sti)
                             (<||aop||> ** OS[isr, true, is, nil] ** P) t

   | switch_rule :  forall  Spec sd lg  I r ri x li   t aop P P'  Px is cs,
                      GoodFrm Px ->
                      P ==> P' ** Px ->
                      P' ==> <|| sched;; aop ||>  ** SWINVt I t ** Ais is ** Acs cs  ->
                      P' ==> SWPRE_NDEAD sd x t ->
                      Px ==> LINV li t lg ** Atrue ->
                      InfRules Spec sd li  I r ri  P
                               (sprim (switch x))  (<|| aop ||>  ** SWINVt I t ** Ais is ** Acs cs ** Px) t

   | switchdead_rule :
       forall  Spec sd lg  I r ri x li   t aop P P'  Px is cs,
         GoodFrm Px ->
         P ==> P' ** Px ->
         P' ==> <|| sched;; aop ||>  ** SWINVt I t ** Ais is ** Acs cs  ->
         P' ==> SWPRE_DEAD sd x t  ->
         Px ==> LINV li t lg ** Atrue ->
         InfRules Spec sd li  I r ri  P
                 (sprim (switch x))  Afalse t

   | checkis_rule : forall  Spec sd pa I r ri x aop isr is ie cs v t P,
                         GoodFrm P ->
                         P ==> CurLINV pa t->
                         InfRules Spec sd pa I r ri
                                  (<||aop||> ** OS[isr, ie, is, cs] **  LV x @ Tint32 |-> v **  P)
                                  (sprim (checkis x))
                                  (<||aop||> ** OS[isr, ie, is, cs] **  LV x @ Tint32 |-> (is_length is) ** P)  t

   | eoi_ieon_rule  :  forall Spec sd pa I r ri isr is id cs  i aop t  P,
                        (0 <= Int.unsigned id < Z.of_nat INUM)%Z ->
                         i = Z.to_nat (Int.intval id) ->
                         GoodFrm P ->
                         P ==> CurLINV pa t ->
                         isr i = true ->
                          InfRules Spec sd pa I r ri
                                     (  <||aop||> ** OS[isr, true, i::is, cs] ** (getinv (I i)) **  P)
                                     (sprim (eoi id))
                                     (  <||aop||> ** OS[isrupd isr i false, true, i::is, cs]  ** P) t

   | eoi_ieoff_rule  :  forall Spec sd pa I r ri isr is id  i cs aop t  P,
                          (0 <= Int.unsigned id < Z.of_nat INUM)%Z ->
                          i = Z.to_nat (Int.unsigned id) ->
                          GoodFrm P ->
                          InfRules Spec sd pa I r ri
                                      (<||aop||> ** OS[isr, false, i::is, cs] ** P)
                                      (sprim (eoi id))
                                      (<||aop||> ** OS[isrupd isr i false, false, i::is, cs] ** P) t

   | ex_intro_rule : forall Spec sd pa I r ri q s {tp:Type} p t,
                          (forall v',InfRules Spec sd pa I r ri (p v') s q t) ->
                          InfRules Spec sd pa I r ri (EX v:tp,p v) s q t

   | disj_rule : forall Spec sd pa I r ri p1 p2 s q t,
                      InfRules Spec sd pa I r ri p1 s q  t ->
                      InfRules Spec sd pa I r ri p2 s q t ->
                      InfRules Spec sd pa I r ri (p1\\//p2) s q t

  | cre_rule :  forall (Spec : funspec) (sd : ossched)
                           (I : Inv) (r : retasrt) (ri P : asrt)
                           (aop : spec_code) (tls : TcbMod.map)
                           (t1 : addrval) (prio : int32) (tls' : TcbMod.map)
                           (v1 v2 : val) (e1 e2 e3 : expr) (tp1 tp3 : type)
                           (pa : LocalInv) (t : tid) isr ie is cs,
                      GoodLInvAsrt pa ->
                      GoodFrm P ->
                      joinsig t1 (prio, rdy, Vnull) tls tls'  ->
                      indom tls t ->
                      P ==>
                       Rv e1 @ tp1 == v1 //\\
                       Rv e2 @ Tptr Tvoid == v2 //\\
                       Rv e3 @ tp3 == Vptr t1 //\\  CurLINV pa t ->
                      InfRules Spec sd pa I r ri
                               (
                                 <|| spec_crt v1 v2 (Vint32 prio);; aop ||>  ** P **
                                     pa t1 init_lg  **
                                     Aabsdata abstcblsid (abstcblist tls) **
                                     Aabsdata curtid (oscurt t) **
                                     OS[isr, ie, is, cs]
                               )
                               (sprim (stkinit e1 e2 e3))
                               (
                                 <|| aop ||>   ** P **
                                     Aabsdata abstcblsid (abstcblist tls') **
                                     Aabsdata curtid (oscurt t)  **
                                     OS[isr, ie, is, cs]
                               ) t

  | delself_rule : forall pa P  prio st msg tls' tls t e tp  aop r ri sd Spec I isr ie is cs,
                         GoodLInvAsrt pa ->
                         GoodFrm P ->
                         joinsig t (prio, st, msg) tls' tls  ->
                         P ==>  Rv e @ tp == Vptr t //\\  CurLINV pa t ->
                         InfRules Spec sd pa I r ri
                                 (
                                   <|| spec_del  (Vint32 prio);; aop ||>  **
                                       P ** Aabsdata abstcblsid (abstcblist tls) **
                                       Aabsdata curtid (oscurt t) **
                                       OS[isr, ie, is, cs]
                                 )
                                 (sprim (stkfree e))
                                 (
                                   <|| aop ||>  ** P  **
                                       Aabsdata abstcblsid (abstcblist tls') **
                                       Aabsdata curtid (oscurt t) **
                                       OS[isr, ie, is, cs]
                                 ) t

 | delother_rule : forall pa P  prio st msg tls' tls t e tp t1 aop r ri sd Spec I isr ie is cs,
                         GoodLInvAsrt pa ->
                         GoodFrm P ->
                         joinsig t1 (prio, st, msg) tls' tls  ->
                         indom tls t ->
                         t <> t1 ->
                         P ==>  Rv e @ tp == Vptr t1 //\\  CurLINV pa t ->
                         InfRules Spec sd pa I r ri
                                 (
                                   <|| spec_del  (Vint32 prio);; aop ||>  **
                                       P ** Aabsdata abstcblsid (abstcblist tls) **
                                       Aabsdata curtid (oscurt t) **
                                       OS[isr, ie, is, cs]
                                 )
                                 (sprim (stkfree e))
                                 (
                                   <|| aop ||>  ** P ** (EX lg,  pa t1 lg)  **
                                       Aabsdata abstcblsid (abstcblist tls') **
                                       Aabsdata curtid (oscurt t) **
                                       OS[isr, ie, is, cs]
                                 ) t.

Notation   " '{|' F , sd , pa , I , r , ri '|}' '|-' t '{{' p '}}' s '{{' q '}}'" :=
  (InfRules F sd pa I r ri p s q t) (at level 50).

Definition EqDom (P : progunit) (F : funspec) : Prop :=
  forall f, (exists a, P f = Some a) <-> (exists b, F f = Some b).

Fixpoint getlenvdom  (dl:decllist) : edom :=
  match dl with
    |  dnil => nil
    |  dcons x t dl' => (x,t)::(getlenvdom dl')
  end.

Fixpoint in_decllist (x:var) (dl : decllist) : bool :=
  match dl with
    | dnil => false
    | dcons x' t' dl' => orb (Zeq_bool x x')  (in_decllist x dl')
  end.

Fixpoint good_decllist (dl: decllist) : bool :=
  match dl with
    | dnil => true
    | dcons x t dl' => andb ( negb (in_decllist x dl')) (good_decllist dl')
  end.

Fixpoint buildp (dl:decllist) (vl:vallist) :option asrt:=
  match good_decllist dl with
    | true =>
      match dl, vl with
        | dnil,nil => Some Aemp
        | dcons x t dl',cons v vl' => match buildp dl' vl' with
                                        | Some p => Some (Astar (LV x @ t |-> v) p)
                                        | None => None
                                      end
        | dcons x t dl',nil => match buildp dl' nil with
                                 | Some p => Some (Astar (Aexists (fun (v:val) =>
                                                                     LV x @ t |-> v)) p)
                                 | None => None
                               end
        | _,_ => None
      end
    | false => None
  end.

Fixpoint buildq (dl:decllist) : option asrt:=
  if good_decllist dl then
    match dl with
      | dnil => Some Aemp
      | dcons x t dl' => match buildq dl' with
                           | Some p => Some ( (EX v, LV x @ t|-> v)  ** p )
                           | None => None
                         end
    end
  else None.

Fixpoint dl_vl_match (dl:decllist) (vl:vallist) :=
  match dl with
    | dnil => match vl with
                | nil => true
                | _ => false
              end
    | dcons x t dl' => match vl with
                         | v :: vl' => if type_val_match t v then dl_vl_match dl' vl' else false
                         | _ => false
                       end
  end.

(*
Definition BuildPreA (p:progunit) (f:fid) (abs:osapi) (vl:vallist) G:option asrt:=
    match p f with
      | Some (t, d1, d2, s) =>
        match dl_vl_match d1 (rev vl) with
          | true =>
            match buildp (revlcons d1 d2) vl with
              | Some p =>Some (Aconj (Agenv G)
                                     (Aconj
                                        (Astar (p ** Aie true ** Ais nil ** Acs nil ** Aisr empisr)
                                               (A_dom_lenv (getlenvdom  (revlcons d1 d2))))
                                        (Aop (fst abs (rev vl)))))
              | _ => None
            end
          | false => None
        end
      | _ => None
    end.

Definition BuildRetA (p:progunit) (f:fid) (abs:osapi) (vl:vallist) G:option retasrt:=
  match p f with
    | Some (t, d1, d2, s) => match buildq (revlcons d1 d2) with
                               | Some p =>
                                 Some
                                   (fun (v:option val) =>
                                      (Aconj (Agenv G)
                                             (Aconj (Astar
                                                       (p** Aie true ** Ais nil ** Acs nil ** Aisr empisr)
                                                       (A_dom_lenv (getlenvdom  (revlcons d1 d2))))
                                                    (Aop (spec_done v)))))
                                       |_ => None
                                     end
    | _ => None
 end.
 *)

Definition BuildPreI (p:progunit) (f:fid) (vl:vallist) (logicl:list logicvar) (fp:fpre) tid : option asrt:=
  match p f with
    | Some (t, d1, d2, s) =>
      match dl_vl_match d1 (rev vl) with
        | true =>
          match buildp (revlcons d1 d2) vl with
            | Some p => Some  (p ** (getasrt (fp (rev vl) logicl tid))**
                                 (A_dom_lenv (getlenvdom  (revlcons d1 d2))))
            | _ => None
          end
        | false => None
      end
    | _ => None
  end.

Definition BuildRetI (p:progunit) (f:fid) (vl:vallist) (logicl:list logicvar) (fq:fpost) tid :option retasrt:=
  match p f with
    | Some (t, d1 , d2,  s) =>
      match buildq (revlcons d1 d2) with
        | Some p => Some (fun (v:option val) =>
                            (p **  (getasrt (fq (rev vl) v logicl tid)) **
                               (A_dom_lenv (getlenvdom  (revlcons d1 d2)))))
        | _ => None
      end
    | _ => None
  end.

Definition lift (q : asrt):  retasrt := fun _ => q.

Definition WFFunEnv (P:progunit) (FSpec:funspec) (sd:ossched) pa (I:Inv) :Prop:=
  EqDom P FSpec /\
  forall f pre post t tl, FSpec f = Some (pre, post, (t, tl)) ->
                          exists  d1 d2 s,   P f = Some (t, d1, d2, s)/\
                                             tlmatch tl d1 /\
                                             good_decllist (revlcons d1 d2) = true /\
                                             (
                                               forall vl p r logicl tid,
                                                 Some p = BuildPreI P f vl logicl pre tid->
                                                 Some r = BuildRetI P f vl logicl post tid->
                                                 InfRules FSpec sd pa I r Afalse p s Afalse tid
                                             ).

(*----------------------*)

Definition EqDomAPI (api:progunit) (aspec:osapispec) :=
  (forall f,
     (exists fdef, api f = Some fdef) <-> (exists fspec,aspec f=Some fspec))/\
  (forall f fdef fspec,  api f = Some fdef -> aspec f = Some fspec ->
                         tlmatch (snd (snd fspec)) (snd (fst (fst fdef))) /\ fst (fst (fst fdef)) = (fst (snd fspec)) ).

Definition EqDomInt (P:intunit) (intspec:osintspec) :=
  (forall i,
     (exists idef, P i = Some idef) <-> (exists absi,intspec i=Some absi)).

Definition InitAsrt:= osstate -> osabst -> Prop.

Definition retfalse:= fun (v:option val)=> Afalse.

Fixpoint dladd (d1 d2 : decllist) : decllist :=
  match d1 with
    | dnil => d2
    | dcons x y d1' => revlcons d1' (dcons x y d2)
  end.

Fixpoint dl_add d1 d2:=
  match d1 with
    | dnil => d2
    | dcons a b d1' => dcons a b (dl_add d1' d2)
  end.

Definition BuildPreA':=
  fun (p : progunit) (f : fid) (abs : osapi) (vl : vallist)  (pa : LocalInv) t lg=>
    match p f with
      | Some (_, d1, d2, _) =>
        match dl_vl_match d1 (rev vl) with
          | true =>
            match buildp (dladd d1 d2) vl with
              | Some p2 =>
                Some
                  ( ((<|| (fst abs) (rev vl) ||> ** p_local pa t lg ** p2 **Aie true ** Ais nil ** Acs nil ** Aisr empisr) ** A_dom_lenv (getlenvdom (revlcons d1 d2))))

              | None => None
            end
          |false => None
        end
      | None => None
    end.

Definition BuildRetA':=
  fun (p : progunit) (f : fid) (_ : osapi) (_ : vallist) (pa : LocalInv) t lg=>
    match p f with
      | Some (_, d1, d2, _) =>
        match buildq (dladd d1 d2) with
          | Some p2 =>
            Some
              (fun v : option val =>
                 ((  <|| spec_done v ||>  ** p_local pa t lg **p2 **  Aie true ** Ais nil ** Acs nil ** Aisr empisr) **  A_dom_lenv (getlenvdom (revlcons d1 d2))) )

          | None => None
        end
      | None => None
    end.

Inductive APIRule: progunit -> osapispec -> funspec -> ossched -> LocalInv -> Inv  -> list logicvar-> Prop :=
| api_rule :
    forall (P:progunit) (apispec:osapispec) (pa : LocalInv) (Spec:funspec) (sd : ossched) (I : Inv) lg,
      EqDomAPI P apispec ->
      (
        forall (f:fid) ab vl p r ft tid,
          apispec f = Some (ab,ft) ->
          Some p = BuildPreA' P f (ab,ft) vl pa tid lg->
          Some r = BuildRetA' P f (ab,ft) vl pa tid lg ->
          (
            exists  t d1 d2 s,
              P f = Some (t, d1, d2, s) /\
              InfRules Spec sd pa I r Afalse p s Afalse tid
          )
      ) ->
      APIRule P apispec Spec sd pa I lg.

Inductive InterRule: progunit -> funspec -> ossched -> LocalInv -> Inv  -> Prop :=
| inter_rule :
    forall (P : progunit) (FSpec : funspec) (sd : ossched) (I : Inv) pa,
      EqDom P FSpec ->
      (forall (f : fid) (pre : fpre) (post : fpost) (t : type) (tl : typelist),
         FSpec f = Some (pre, post, (t, tl)) ->
         exists d1 d2 s,
           P f = Some (t, d1, d2, s) /\
           tlmatch tl d1 /\
           (forall (vl : vallist) (p : asrt) (r : retasrt) (logicl : list logicvar) tid,
              Some p = BuildPreI P f vl logicl pre tid->
              Some r = BuildRetI P f vl logicl post tid->
              {|FSpec , sd, pa , I, r, Afalse|}|- tid {{p}} s {{Afalse}})) ->
      InterRule P FSpec sd pa I.

Definition iretasrt' (i:hid) (isrreg:isr) (si:is)  (I:Inv) :asrt:=
  (Astar (Aop (spec_done None))
         (Astar (Aisr (isrupd isrreg i false))
                (Astar (Ais (cons i si))
                       (Astar (Acs  nil)
                              (IRINV I ** A_dom_lenv nil))))).

Definition ipreasrt' (i:hid) (isrreg:isr) (si:is) (ispec:spec_code) (I:Inv):=
  (Astar (Aop ispec)
         (Astar (Aisr (isrupd isrreg i true))
                (Astar (Ais (cons i si))
                       (Astar (Acs  nil)
                              ((Astar (Aie false))
                                 (isr_inv ** invlth_noisr I 0%nat i ** A_dom_lenv nil)))))).

Definition BuildintPre (i:nat) i_spec (isrreg:isr) (si:is) (I:Inv) (pintpre:LocalInv) t lg:=
  match i_spec i with
    | None => None
    | Some ispec => Some (ipreasrt' i isrreg si ispec  I ** p_local pintpre t lg)
  end.

Definition BuildintRet (i:nat) (i_spec:osintspec) (isrreg:isr) (si:is) (I:Inv) (pa:LocalInv) t lg:=
  match i_spec i with
    | None => None
    | Some ispec => Some (iretasrt' i isrreg si I ** p_local pa  t lg)
  end.

Inductive ItrpRule: intunit -> osintspec ->  funspec -> ossched  -> LocalInv  -> Inv  -> Prop :=
| itrp_rule: forall (P:intunit) (intspec:osintspec) (pa: LocalInv)(Spec:funspec) sd (I:Inv),
               EqDomInt P intspec ->
               (
                 forall i isrreg si p r t  lg,
                   Some p = BuildintPre i intspec isrreg si I pa t lg->
                   Some r = BuildintRet i intspec isrreg si I pa t lg->
                   exists s,
                     P i = Some s /\
                     {|Spec , sd, pa , I, retfalse, r|}|-t {{p}}s {{Afalse}}

               ) ->
               ItrpRule P intspec Spec sd pa  I.

Definition eqevntls (env: CltEnvMod.map) (tls:TcbMod.map) :=
  forall (t:tid), indom env t <-> indom tls t.

Definition eqisttls (lst:ltaskstset) (tls:TcbMod.map) :=
  forall (t:tid), indom lst t <-> indom tls t.

Definition eqdomSO (S : osstate)  (O:osabst) :=
  match S with
    | (G,pi,M,isr,lst) =>
      match get O abstcblsid with
        | Some (abstcblist tls) => eqevntls pi tls /\ eqisttls lst tls
        | _ => False
      end
  end.

Definition init_rdy (pa : tid-> list logicvar -> asrt) (t:tid)  lg := pa t lg ** [| GoodLInvAsrt pa |] **  OS [empisr, true, nil , nil ]  ** A_dom_lenv nil.

Definition init_cur I (pa : tid-> list logicvar -> asrt)  t lg := (INV I) ** (EX tp : type, GV OSTCBCur @ Tptr tp |-r-> Vptr t)  ** init_rdy pa t lg.

Inductive initst: osstate -> osabst -> Inv -> LocalInv -> list logicvar -> Prop:=
| init_O: forall S O G envs M isr lst E auxs I pa t lg,
            S = ((G,envs,M),isr,lst) ->
            envs = sig t E ->
            lst = sig t auxs ->
            get O curtid = Some (oscurt t) ->
            (forall ab, sat (((G,E,M),isr,auxs),O,ab) (init_cur I pa t lg)) ->
            initst S O I pa lg
| init_S: forall S O G envs envs' M m M' isr lst lst' E auxs I pa t tc lg,
            S = ((G,envs,M),isr,lst) ->
            join (sig t E) envs' envs ->
            join (sig t auxs) lst' lst ->
            join m M' M ->
            get O curtid = Some (oscurt tc) ->
            t <> tc ->
            (forall ab, sat (((G,E,m),isr,auxs),emp,ab) (init_rdy pa t lg ** A_dom_lenv nil)) ->
            initst ((G,envs',M'),isr,lst') O I pa lg ->
            initst S O I pa lg.
(*
Definition side_condition I pa schedmethod init:=
  (
    GoodI I schedmethod /\
    (forall S O,  init S O ->
                      (forall o, (projS S tid) = Some o  ->
                         forall ab, sat ((pair o O),ab) (init_asrt I pa tid )) /\ eqdomSO S O)
  ).
 *)
Definition side_condition I pa schedmethod init lg:=
  (
    GoodI I schedmethod pa /\
    (forall S O,  init S O ->
                  initst S O I pa lg/\ eqdomSO S O)
  ).

Inductive TopRule : oscode -> osspec -> InitAsrt -> Prop :=
| top_rule: forall osc A (init:InitAsrt) (I:Inv) (lasrt: LocalInv )(Spec:funspec)
                   pa pi ip apispec intspec schedmethod ,
              osc = (pa,pi,ip) ->
              A = (apispec,intspec,schedmethod) ->
              APIRule pa apispec Spec schedmethod lasrt I init_lg ->
              ItrpRule ip intspec Spec schedmethod lasrt I ->
              InterRule pi Spec schedmethod lasrt  I ->
              side_condition I lasrt  schedmethod init init_lg ->
              TopRule osc A init.

(***Abstract Implications when local invariants do not specify high-level states *****)

Definition  NoAbs (p: LocalInv) :=
  forall  o O t, satp o O  (CurLINV p t) ->
                 forall O', satp o O'  (CurLINV p t).

Definition  absimp sc (p p' : asrt) :=
  forall (s : taskst) (O : osabst) (gamma : absop),
    (s, O, gamma) |= p ->
    exists O' gamma',
      hmstepstar sc gamma O gamma' O' /\ (s, O', gamma') |= p'.

Lemma absimp_imp_full:
  forall sc p p' li t,
    absimp sc  p p' ->
    NoAbs li ->
    absimplication sc li p p' t.
Proof.
  intros.
  unfolds.
  intros.
  destruct H1.
  apply H in H1.
  simp join.
  do 2 eexists; splits; eauto.
Qed.

Inductive absinfer :  ossched -> asrt -> asrt -> Prop :=
| absinfer_eq :
    forall p sc,
      absinfer sc p p

| absinfer_trans :
    forall p q r sc,
      absinfer sc p q -> absinfer sc q r -> absinfer sc p r

| absinfer_disj:
    forall p1 p2 q1 q2 sc,
      absinfer sc p1 q1 ->
      absinfer sc p2 q2 ->
      absinfer sc (p1\\//p2) (q1\\// q2)

| absinfer_conseq :
    forall p q p' q' sc,
      q ==> q' ->
      absinfer sc p q ->
      p'==> p -> absinfer sc p' q'

| absinfer_ex :
    forall  (tp:Type) (p:tp->asrt) q sc,
      (forall x,absinfer sc (p x) q) -> absinfer sc (EX x:tp,p x) q
(**
| absinfer_frm :
    forall p q r sc,
     p ==>
      can_change_aop r ->
      absinfer sc p q -> absinfer sc (p ** r) (q ** r)
 *)

| absinfer_prim:
    forall p q step vl v sc,
      can_change_aop p ->
      can_change_aop q ->
      absimp sc (<||step (|vl|)||> ** p) (<||END v||> ** q)
      -> absinfer sc (<||step (|vl|)||> ** p) (<||END v||> ** q)

| absinfer_seq: forall p q s1 s2 s1' sc,
                  can_change_aop p ->
                  can_change_aop q ->
                  absinfer sc (<||s1||> ** p) (<||s1'||> ** q) ->
                  absinfer sc (<||s1 ;; s2 ||> **p ) (<||s1';;s2||>**q)

| absinfer_seq_end: forall p q s v sc,
                      can_change_aop p ->
                      can_change_aop q ->
                      p ==> q ->
                      absinfer sc (<||END v ;; s ||> **p ) (<||s||> ** q)

| absinfer_choice1 :
    forall p q s1 s2 sc,
      can_change_aop p ->
      can_change_aop q ->
      p ==> q ->
      absinfer sc (<||s1 ?? s2 ||> ** p) (<||s1||> ** q)

| absinfer_choice2 :
    forall p q s1 s2 sc,
      can_change_aop p ->
      can_change_aop q ->
      p ==> q ->
      absinfer sc (<||s1 ?? s2 ||> ** p ) (<||s2||> ** q)

|absinfer_assume :
   forall  p (b:absexpr) q sc,
     can_change_aop p ->
     can_change_aop q ->
     p  ==> q ->
     (forall s, (s |= p) -> b (getabst s)) ->
     absinfer sc (<||ASSUME b||> ** p) (<||END None||> ** q)

|absinfer_sched :
   forall  p (b:absexpr) q sc,
     can_change_aop p ->
     can_change_aop q ->
     p  ==> q ->
     (forall s, (s |= p) -> sched_self sc  (getabst s)) ->
     absinfer sc (<||sched||> ** p) (<||END None||> ** q).

Notation " sc '⊢' p '⇒' q " := (absinfer sc p q) (at level 80).

Lemma  absinfer_imp_full:
  forall li sc p q t,
    NoAbs li ->
    absinfer sc p q ->
    absinferfull sc li p q t .
Proof.
  intros.
  inductions H0.
  apply  absinfer_eq'.
  eapply absinfer_trans'; eauto.
  eapply absinfer_disj'; eauto.
  eapply absinfer_conseq'; eauto.
  eapply absinfer_ex'; eauto.
  eapply absinfer_prim'; eauto.
  eapply  absimp_imp_full; eauto.
  eapply  absinfer_seq'; eauto.
  eapply absinfer_seq_end'; eauto.
  eapply absinfer_choice1'; eauto.
  eapply absinfer_choice2'; eauto.
  eapply absinfer_assume' ; eauto.
  eapply absinfer_sched' ; eauto.
Qed.

Lemma   abscsq_rule :
  forall   Spec sd  I r ri p' p q q' s pa t,
    NoAbs pa ->
    sd ⊢ p'⇒p  ->  sd  ⊢ q ⇒ q' ->
    InfRules Spec sd pa I r ri p s q  t->
    InfRules Spec sd pa I r ri p' s q' t .
Proof.
  intros.
  eapply abscsq_rule_full; eauto.
  eapply absinfer_imp_full; eauto.
  eapply absinfer_imp_full; eauto.
Qed.