Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import maps_ext.
Require Import infrastructure_props.
Require Import Program.Tactics.
Require Import Program.Equality.

(* This file implements and proves libraries for domination analysis. *)

(* A signature for a worklist of Kildall. *)
Module Type PNODE_SET.

  Variable t: Type.
  Variable add: positive -> t -> t.
  Variable pick: t -> option (positive * t).
  Variable initial: PTree.t (list positive) -> t.

  Variable In: positive -> t -> Prop.
  Hypothesis add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Hypothesis pick_none:
    forall s n, pick s = None -> ~In n s.
  Hypothesis pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Hypothesis initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).

End PNODE_SET.

Require Import FSets.
Require Import FSetAVL.
Require Import Ordered.
Module PositiveSet := FSetAVL.Make(OrderedPositive).
Module PositiveSetFacts := FSetFacts.Facts(PositiveSet).

(* A worklist that picks the maximal node. *)
Module PNodeSetMax <: PNODE_SET.
  Definition t := PositiveSet.t.
  Definition add (n: positive) (s: t) : t := PositiveSet.add n s.
  Definition pick (s: t) :=
    match PositiveSet.max_elt s with
    | Some n => Some(n, PositiveSet.remove n s)
    | None => None
    end.
  Definition initial (successors: PTree.t (list positive)) :=
    PTree.fold (fun s pc scs => PositiveSet.add pc s) successors PositiveSet.empty.
  Definition In := PositiveSet.In.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof.
    intros. exact (PositiveSetFacts.add_iff s n n').
  Qed.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PositiveSet.max_elt s); intros.
    congruence.
    apply PositiveSet.max_elt_3. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PositiveSet.max_elt s); intros.
    inversion H0; clear H0; subst.
    split; intros.
    destruct (peq n n'). auto. right. apply PositiveSet.remove_2; assumption.
    elim H0; intro. subst n'. apply PositiveSet.max_elt_1. auto.
    apply PositiveSet.remove_3 with n; assumption.
    congruence.
  Qed.

  Lemma initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n s, succ ? n = Some s -> In n set).
    (* extensionality *)
    intros. rewrite <- H in H1. eauto.
    (* base case *)
    intros. rewrite PTree.gempty in H. congruence.
    (* inductive case *)
    intros. rewrite PTree.gsspec in H2. apply add_spec.
    destruct (Coqlib.peq n k). auto. eauto.
  Qed.

  Lemma pick_in:
    forall s n s', pick s = Some(n, s') -> In n s.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
    uniq_result.
    apply PositiveSet.max_elt_1. auto.
  Qed.

  Lemma pick_notin:
    forall s n s', pick s = Some(n, s') -> ~ In n s'.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
    uniq_result.
    apply PositiveSet.remove_1. auto.
  Qed.

  Lemma pick_max:
    forall s n s', pick s = Some(n, s') ->
      PositiveSet.max_elt s = Some n.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
  Qed.

  Lemma pick_remove:
    forall s n s', pick s = Some(n, s') -> s' = PositiveSet.remove n s.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
  Qed.

  Lemma initial_spec':
    forall successors n,
    In n (initial successors) ->
    exists s, successors ? n = Some s.
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n, In n set -> exists s, succ ? n = Some s).
    (* extensionality *)
    intros. rewrite <- H. eauto.
    (* base case *)
    intros. apply PositiveSet.empty_1 in H. tauto.
    (* inductive case *)
    intros. rewrite PTree.gsspec. apply add_spec in H2.
    destruct (Coqlib.peq n k); eauto.
      destruct H2 as [H2 | H2]; subst.
        congruence.
        eauto.
  Qed.

End PNodeSetMax.

(* A worklist that picks the minimal node. *)
Module PNodeSetMin <: PNODE_SET.
  Definition t := PositiveSet.t.
  Definition add (n: positive) (s: t) : t := PositiveSet.add n s.
  Definition pick (s: t) :=
    match PositiveSet.min_elt s with
    | Some n => Some(n, PositiveSet.remove n s)
    | None => None
    end.
  Definition initial (successors: PTree.t (list positive)) :=
    PTree.fold (fun s pc scs => PositiveSet.add pc s) successors PositiveSet.empty.
  Definition In := PositiveSet.In.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof.
    intros. exact (PositiveSetFacts.add_iff s n n').
  Qed.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PositiveSet.min_elt s); intros.
    congruence.
    apply PositiveSet.min_elt_3. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PositiveSet.min_elt s); intros.
    inversion H0; clear H0; subst.
    split; intros.
    destruct (peq n n'). auto. right. apply PositiveSet.remove_2; assumption.
    elim H0; intro. subst n'. apply PositiveSet.min_elt_1. auto.
    apply PositiveSet.remove_3 with n; assumption.
    congruence.
  Qed.

  Lemma initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n s, succ ? n = Some s -> In n set).
    (* extensionality *)
    intros. rewrite <- H in H1. eauto.
    (* base case *)
    intros. rewrite PTree.gempty in H. congruence.
    (* inductive case *)
    intros. rewrite PTree.gsspec in H2. apply add_spec.
    destruct (Coqlib.peq n k). auto. eauto.
  Qed.
End PNodeSetMin.

Import AtomSet.
Require Import Sorted.
Require Import ListSet.

(* A signature of merging two sorted lists by preserving orders. *)
Module Type MERGE.

  Variable Pcmp: positive -> positive -> Prop.
  Variable merge : list positive -> list positive -> list positive * bool.
  Hypothesis merge_cmp_cons: forall p ps (Hlt: Forall (Pcmp p) ps),
    merge ps (p :: ps) = (ps, false).
  Hypothesis merge_spec: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed)),
    sublist rl Xsdms /\ sublist rl Ysdms /\
    (changed = false <-> rl = Xsdms).
  Hypothesis merge_commut: forall Xsdms Ysdms rl changed rl' changed'
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hmerge': merge Ysdms Xsdms = (rl', changed')),
    rl = rl'.
  Hypothesis merge_refl: forall Xsdms, merge Xsdms Xsdms = (Xsdms, false).

  Hypothesis merge_inter: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms),
    set_eq (set_inter positive_eq_dec Xsdms Ysdms) (rev rl).

End MERGE.

Ltac uniq_result' :=
match goal with
| H: Eq = (_ ?= _)%positive Eq |- _ =>
    symmetry in H; apply Pcompare_Eq_eq in H; subst
| H: (_ ?= _)%positive Eq = Eq |- _ =>
    apply Pcompare_Eq_eq in H; subst
| H: nil = _ ++ _ |- _ =>
    symmetry in H; apply app_eq_nil in H; destruct H; subst
| H: _ ++ _ = _ |- _ =>
    apply app_eq_nil in H; destruct H; subst
| H: _::_ = nil |- _ => inv H
| H: nil = _::_ |- _ => inv H
| _ => uniq_result
end.

Require Import CpdtTactics.

Ltac fill_holes_in_ctx :=
let fill e H :=
  match goal with
  | H1: _ = e |- _ => rewrite <- H1 in H
  | H1: e = _ |- _ => rewrite H1 in H
  end
in
repeat match goal with
| H: match ?e with
     | Some _ => _
     | None => _
     end |- _ => fill e H
| H: match ?e with
     | inl _ => _
     | inr _ => _
     end |- _ => fill e H
| H: match ?e with
     | (_,_) => _
     end = _ |- _ => fill e H
| H: _ = match ?e with
     | (_,_) => _
     end |- _ => fill e H
end.

Ltac destruct_let :=
match goal with
| _:context [match ?e with
             | (_, _) => _
             end] |- _ => remember e as R; destruct R
| |- context [match ?e with
              | (_, _) => _
              end] => remember e as R; destruct R
end.

(* Merging two lists sorted by less-than. *)
Module MergeLt <: MERGE.

  Definition Pcmp := Plt.

  Program Fixpoint merge_aux (l1 l2: list positive) (acc:list positive * bool)
    {measure (length l1 + length l2)%nat}
    : (list positive * bool) :=
  let '(rl, changed) := acc in
  match l1, l2 with
  | p1::l1', p2::l2' =>
      match (Pcompare p1 p2 Eq) with
      | Eq => merge_aux l1' l2' (p1::rl, changed)
      | Lt => merge_aux l1' l2 (rl, true)
      | Gt => merge_aux l1 l2' (rl, changed)
      end
  | nil, _ => acc
  | _::_, nil => (rl, true)
  end.
  Next Obligation.
    simpl. omega.
  Qed.
  Next Obligation.
    simpl. omega.
  Qed.

  Definition merge_aux_spec_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 rl2 changed2
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    exists rl3, rl2 = rl3 ++ rl1 /\
                sublist (List.rev rl3) Xsdms /\
                sublist (List.rev rl3) Ysdms /\
                (changed2 = false -> List.rev rl3 = Xsdms) /\
                (List.rev rl3 = Xsdms -> changed2 = changed1) /\
                (changed1 = true -> changed2 = true).

  Ltac fold_merge_aux :=
  match goal with
  | |- context [merge_aux_func (existT _ ?arg1 (existT _ ?arg2 ?arg3))] =>
         fold (merge_aux arg1 arg2 arg3)
  end.

  Ltac unfold_merge_aux :=
  match goal with
  | |- appcontext [merge_aux ?arg] =>
     unfold merge_aux; unfold merge_aux_func;
     Program.Wf.WfExtensionality.unfold_sub merge_aux arg; simpl;
     repeat Program.Wf.fold_sub merge_aux_func;
     repeat fold_merge_aux
  end.

  Lemma merge_aux_spec_aux: forall n, merge_aux_spec_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_spec_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge. uniq_result.
      exists nil. simpl. repeat (split; try solve [auto | constructor]).

      compute in Hmerge. uniq_result.
      exists nil. simpl. repeat (split; try solve [auto | constructor]).

      compute in Hmerge. uniq_result.
      exists nil. simpl.
      repeat (split; try solve [auto | constructor | congruence]).

      uniq_result.
      revert Hmerge. unfold_merge_aux.
      remember (Pos.compare_cont Eq Xd Yd) as Cmp.
      intro.
      destruct Cmp; subst.
        apply Hrec with (y:=(length Xsdms + length Ysdms)%nat) in Hmerge;
          try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists (rl3++[Xd]). simpl_env.
        rewrite rev_app_distr. simpl.
        uniq_result'.
        repeat (split; try solve [auto | constructor; auto]).
          symmetry in HeqCmp.
          apply Pcompare_Eq_eq in HeqCmp. subst Yd. constructor. auto.
          intro J. apply J4 in J. f_equal; auto.
          intro J. inv J. auto.

        apply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat) in Hmerge;
           try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists rl3.
        repeat (split; try solve [auto | constructor; auto]).
          intro J. assert (J':=J). apply J4 in J. apply J5 in J. congruence.
          intro J. rewrite J in J2. apply sublist_cons_false in J2. tauto.

        apply Hrec with (y:=(S (length Xsdms) + length Ysdms)%nat) in Hmerge;
           try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists rl3.
        repeat (split; try solve [auto | constructor; auto]).
  Qed.

  Lemma merge_aux_spec: forall Xsdms Ysdms rl1 changed1 rl2 changed2
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    exists rl3, rl2 = rl3 ++ rl1 /\
                sublist (List.rev rl3) Xsdms /\
                sublist (List.rev rl3) Ysdms /\
                (changed2 = false -> (List.rev rl3) = Xsdms) /\
                (List.rev rl3 = Xsdms -> changed2 = changed1) /\
                (changed1 = true -> changed2 = true).
  Proof.
    intros.
    assert (J:=@merge_aux_spec_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_spec_prop in J.
    auto.
  Qed.

  Definition merge (l1 l2: list positive) : (list positive * bool) :=
    let '(rl, changed) := merge_aux l1 l2 (nil, false) in
    (rev rl, changed).

  Lemma merge_spec: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed)),
    sublist rl Xsdms /\ sublist rl Ysdms /\
    (changed = false <-> rl = Xsdms).
  Proof.
    unfold merge.
    intros.
    destruct_let.
    fill_holes_in_ctx. uniq_result.
    symmetry in HeqR.
    apply merge_aux_spec in HeqR.
    destruct_conjs.
    subst. simpl_env.
    crush.
  Qed.

  Definition merge_aux_commut_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 changed1' rl2 changed2 rl2' changed2'
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2))
    (Hmerge': merge_aux Ysdms Xsdms (rl1, changed1') = (rl2', changed2')),
    rl2 = rl2'.

  Lemma merge_aux_commut_aux: forall n, merge_aux_commut_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_commut_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge, Hmerge'. uniq_result. auto.
      compute in Hmerge, Hmerge'. uniq_result. auto.
      compute in Hmerge, Hmerge'. uniq_result. auto.

      revert Hmerge. unfold_merge_aux. intro.
      revert Hmerge'. unfold_merge_aux. intro.
      remember (Pos.compare_cont Eq Xd Yd) as Cmp.
      destruct Cmp; subst.
        uniq_result'.
        symmetry in HeqCmp. apply Pcompare_Eq_eq in HeqCmp. subst Yd.
        rewrite Pcompare_refl in Hmerge'.
        eapply Hrec with (y:=(length Xsdms + length Ysdms)%nat);
          try solve [eauto | simpl; omega].

        symmetry in HeqCmp. rewrite ZC4 in HeqCmp.
        apply CompOpp_iff in HeqCmp. simpl in HeqCmp.
        rewrite HeqCmp in Hmerge'.

        eapply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat);
          eauto; simpl; omega.

        symmetry in HeqCmp. rewrite ZC4 in HeqCmp.
        apply CompOpp_iff in HeqCmp. simpl in HeqCmp.
        rewrite HeqCmp in Hmerge'.

        eapply Hrec with (y:=(S (length Xsdms) + length Ysdms)%nat);
          eauto; simpl; omega.
  Qed.

  Lemma merge_commut: forall Xsdms Ysdms rl changed rl' changed'
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hmerge': merge Ysdms Xsdms = (rl', changed')),
    rl = rl'.
  Proof.
    unfold merge.
    intros. destruct_let. destruct_let. uniq_result.
    assert (J:=@merge_aux_commut_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_commut_prop in J.
    f_equal. eauto.
  Qed.

  Definition merge_aux_refl_prop (n:nat) := forall Xsdms
    (Hlen: (length Xsdms + length Xsdms = n)%nat) rl changed,
    merge_aux Xsdms Xsdms (rl, changed) = (rev Xsdms++rl, changed).

  Lemma merge_aux_refl_aux: forall n, merge_aux_refl_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_refl_prop; intros.
    destruct Xsdms as [|Xd Xsdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute. auto.

      unfold_merge_aux.
      simpl_env.
      rewrite Pcompare_refl.
      erewrite Hrec with (y:=(length Xsdms + length Xsdms)%nat);
        try solve [eauto | simpl; omega].
  Qed.

  Lemma merge_refl: forall Xsdms, merge Xsdms Xsdms = (Xsdms, false).
  Proof.
    unfold merge. intros. destruct_let.
    assert (J:=@merge_aux_refl_aux (length Xsdms + length Xsdms)).
    unfold merge_aux_refl_prop in J.
    rewrite J in HeqR; auto.
    uniq_result. simpl_env.
    rewrite rev_involutive. auto.
  Qed.

  Lemma merge_cmp_cons: forall p ps (Hlt: Forall (Plt p) ps),
    merge ps (p :: ps) = (ps, false).
  Proof.
    destruct 1; intros.
      compute. auto.

      unfold merge. unfold_merge_aux.
      replace (Pos.compare_cont Eq x p) with Gt.
      erewrite merge_aux_refl_aux; eauto.
      simpl_env.
      rewrite rev_involutive. auto.

      symmetry. apply Pcompare_eq_Gt. apply Pos.lt_gt. auto.
  Qed.

  Definition merge_aux_inter_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 rl2 changed2
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms)
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    set_eq (set_union positive_eq_dec rl1
           (set_inter positive_eq_dec Xsdms Ysdms)) rl2.

  Lemma merge_aux_inter_aux: forall n, merge_aux_inter_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_inter_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge. uniq_result. simpl. auto with atomset.
      compute in Hmerge. uniq_result. simpl. auto with atomset.
      compute in Hmerge. uniq_result. simpl.
        apply set_eq_trans with (y:=set_union positive_eq_dec rl2 nil).
          apply set_eq_union; auto with atomset.
          apply set_union_empty_eq_empty2.

      inv Hsortx. inv Hsorty.
      revert Hmerge. unfold_merge_aux. intro.
      remember (Pos.compare_cont Eq Xd Yd) as Cmp.
      destruct Cmp; subst; symmetry in HeqCmp.
      Case "1".
        uniq_result'.
        destruct_if.
        SCase "1.1".
          clear HeqR.
          eapply Hrec with (y:=(length Xsdms + length Ysdms)%nat) in Hmerge;
            try solve [eauto | simpl; omega].
          (* (a :: Z) \/ (X /\ Y) = Z \/ (a :: (X /\ Y)) *)
          split; intros x Hin.
          SSCase "1.1.1".
            apply Hmerge.
            apply set_union_elim in Hin.
            apply set_union_intro.
            simpl.
            destruct Hin as [Hin | Hin]; auto.
            simpl in Hin.
            destruct Hin as [Hin | Hin]; subst; auto.
            apply set_inter_elim in Hin.
            destruct Hin as [Hin1 Hin2].
            simpl in Hin2.
            destruct Hin2 as [Hin2| Hin2]; auto.
            left. left. apply Pos.compare_eq in HeqCmp. subst Yd; auto.
            right. apply set_inter_intro; auto.

          SSCase "1.1.2".
            apply Hmerge in Hin.
            apply set_union_elim in Hin.
            apply set_union_intro.
            simpl.
            destruct Hin as [Hin | Hin].
            SSSCase "1.1.2.1".
              simpl in Hin.
              destruct Hin as [Hin | Hin]; subst; auto.

            SSSCase "1.1.2.2".
              apply set_inter_elim in Hin.
              destruct Hin as [Hin1 Hin2].
              right. right.
              apply set_inter_intro; simpl; auto.

        SCase "1.2".
          destruct_if. apply Pos.compare_eq in HeqCmp. congruence.

      Case "2".
        destruct_if.
        SCase "2.1".
          (* X < Y < Ysdms => ~ In X (Y::Ysdms) *)
          destruct_if.
          SSCase "2.1.1".
            rewrite Pcompare_refl in HeqCmp. congruence.
          SSCase "2.1.2".
            apply ZC2 in HeqCmp.
            rewrite Forall_lt__notin in H0; eauto using order_lt_order.
              congruence.

        SCase "2.2".
          clear HeqR.
          eapply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat) in Hmerge;
            try solve [eauto | simpl; omega | constructor; auto].

      Case "3".
        eapply Hrec with (y:=(S (length Xsdms) + (length Ysdms))%nat) in Hmerge;
          try solve [eauto | simpl; omega | constructor; auto].
        destruct_if.
        SCase "3.1".
          (* X > Y, In X (Y::Ysdms) => In X Ysdms
             In X Ysdms => (X :: Xsdms) /\ Ysdms = X ++ (Xsdms /\ Ysdms)
             X > Y, Xsdms > X => ~ In Y Xsdms
             ~ In Y Xsdms => Xsdms /\ Ysdms = Xsdms /\ (Y :: Ysdms)
             so,
             rl1 \/ ((X :: Xsdms) /\ Ysdms) =
             rl1 \/ (X :: (Xsdms /\ Ysdms)) =
             rl1 \/ (X :: Xsdms /\ (Y :: Ysdms)) *)
          assert (set_mem positive_eq_dec Xd Ysdms = true) as XinYsdms.
            destruct_if; auto.
            rewrite Pcompare_refl in HeqCmp. congruence.
          clear HeqR.
          eapply set_eq_trans; eauto.
          apply set_union_eq_right.
          simpl_env.
          apply set_eq_trans with
            (y:=[Xd] ++
                set_inter positive_eq_dec Xsdms Ysdms).
          SSCase "1".
            apply set_eq_app; auto with atomset.
            assert (J1:=set_inter_union_distr_r positive_eq_dec [Yd] Ysdms Xsdms).
            eapply set_eq_trans; eauto.
            clear J1.
            assert (~ In Yd (Xsdms)) as Hnotin.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
              apply Forall_lt__notin; eauto using order_lt_order.
            rewrite_env (Yd::nil).
            rewrite set_inter_notin_r; auto.
            apply set_union_empty_eq_empty1.

          SSCase "2".
            assert (J1:=set_inter_prefix positive_eq_dec Xsdms Ysdms [Xd]).
            eapply set_eq_trans; eauto.
            clear J1.
            apply set_inter_drop_incl; auto.
              apply set_mem_correct1 in XinYsdms.
              apply in_incl; auto.

        SCase "3.2".
          (* ~ In X (Y::Ys) => ~ In X Ys
             ~ In X Ys => (X :: Xs) /\ Ys = Xs /\ Ys
             X > Y, Xs > X => ~ In Y Xs
             ~ In Y Xs => Xs /\ Ys = Xs /\ (Y :: Ys)
             so,
             rl1 \/ ((X :: Xs) /\ Ys) =
             rl1 \/ (Xs /\ Ys) =
             rl1 \/ (Xs /\ (Y :: Ys))
          *)
          eapply set_eq_trans; eauto.
          apply set_union_eq_right.
          simpl_env.
          apply set_eq_trans with
            (y:=set_inter positive_eq_dec Xsdms Ysdms).
          SSCase "1".
            rewrite_env (Yd::nil).
            apply set_inter_drop_notin_r.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
              apply Forall_lt__notin; eauto using order_lt_order.
          SSCase "2".
            apply set_eq_sym.
            rewrite_env (Xd::nil).
            apply set_inter_drop_notin_l.
              destruct_if.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
  Qed.

  Lemma merge_inter: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms),
    set_eq (set_inter positive_eq_dec Xsdms Ysdms) (rev rl).
  Proof.
    unfold merge.
    intros. destruct_let. uniq_result.
    assert (J:=@merge_aux_inter_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_inter_prop in J.
    symmetry in HeqR.
    apply_clear J in HeqR; auto.
    rewrite rev_involutive.
    simpl in HeqR.
    eapply set_eq_trans; eauto.
      apply set_eq_sym.
      apply set_union_empty_eq_empty1.
  Qed.

End MergeLt.

(* A signature of lattice used for computing dominators. *)
Module Type LATTICEELT.

  Variable t: Type.
  Variable eq: t -> t -> Prop.
  Hypothesis eq_refl: forall x, eq x x.
  Hypothesis eq_sym: forall x y, eq x y -> eq y x.
  Hypothesis eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
(*
  Variable beq: t -> t -> bool.
  Hypothesis beq_correct: forall x y, beq x y = true -> eq x y.
*)
  Variable bot: t.
  Variable lub: t -> t -> t * bool.
  Variable top: t.
  Variable ge: t -> t -> Prop.
  Hypothesis ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Hypothesis ge_refl: forall x, ge x x.

End LATTICEELT.

(* A signature of lattice maps used for computing dominators. *)
Module LATTICEELT_MAP (L: LATTICEELT).

Definition in_incr (in1 in2: PMap.t L.t) : Prop :=
  forall n, L.ge in2 ?? n in1 ?? n.

Lemma in_incr_refl:
  forall in1, in_incr in1 in1.
Proof.
  unfold in_incr; intros. apply L.ge_refl.
Qed.

Lemma in_incr_trans:
  forall in1 in2 in3, in_incr in1 in2 -> in_incr in2 in3 -> in_incr in1 in3.
Proof.
  unfold in_incr; intros. apply L.ge_trans with in2 ?? n; auto.
Qed.

Definition eq bd (in1 in2: PMap.t L.t) : Prop :=
  forall n (Hin: In n bd), L.eq in2 ?? n in1 ?? n.

End LATTICEELT_MAP.

(* A lattice used for computing dominators, parameterized by a merging
   function. *)
Module Doms (MG:MERGE) <: LATTICEELT.

  Definition t := option (list positive).

  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).

  Definition bot : t := None.

  Definition lub (x y:t) : t * bool :=
  match x, y with
  | Some x', Some y' =>
     let '(r, changed) := (MG.merge x' y') in (Some r, changed)
  | _, None => (x, false)
  | None, _ => (y, true)
  end.

  Definition top : t := Some nil.

  Definition ge (x y:t) : Prop :=
  match x, y with
  | _, None => True
  | Some x', Some y' => sublist x' y'
  | _, _ => False
  end.

  Lemma ge_trans: forall x y z (Hxy: ge x y) (Hyz: ge y z), ge x z.
  Proof.
    unfold ge.
    destruct x as [x|]; destruct y as [y|]; destruct z as [z|];
      eauto using sublist_trans.
      tauto.
  Qed.

  Lemma ge_refl: forall x, ge x x.
  Proof.
    unfold ge.
    destruct x as [x|]; auto using sublist_refl.
  Qed.

  Lemma merge_cmp_cons: forall p ps (Hlt: Forall (MG.Pcmp p) ps),
    MG.merge ps (p :: ps) = (ps, false).
  Proof. apply MG.merge_cmp_cons. Qed.

  Definition transfer (n:positive) (input:t) : t :=
  match input with
  | None => None
  | Some ps => Some (n::ps)
  end.

  Lemma ge_lub_left': forall x y, ge (fst (lub x y)) x.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety.
      caseEq x; simpl; auto.
        intros Xsdms Hgetx.
        simpl.
        destruct_let.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        simpl. tauto.

      intros Hgety.
      caseEq x; simpl; auto with sublist.
  Qed.

  Lemma ge_lub_left: forall x y r changed (Hlub: lub x y = (r, changed)),
    ge r x.
  Proof.
    intros.
    replace r with (fst (lub x y)); try solve [rewrite Hlub; auto].
    apply ge_lub_left'.
  Qed.

  Lemma lub_commut: forall x y, fst (lub x y) = fst (lub y x).
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety.
      caseEq x; simpl; auto.
        intros Xsdms Hgetx.
        simpl.
        repeat destruct_let.
        symmetry in HeqR.
        eapply MG.merge_commut in HeqR; eauto.
        simpl. congruence.

      intros Hgety.
      caseEq x; simpl; auto.
  Qed.

  Lemma ge_lub_right': forall x y, ge (fst (lub x y)) y.
  Proof.
    intros.
    rewrite lub_commut.
    apply ge_lub_left'.
  Qed.

  Lemma ge_lub_right: forall x y r changed (Hlub: lub x y = (r, changed)),
    ge r y.
  Proof.
    intros.
    replace r with (fst (lub x y)); try solve [rewrite Hlub; auto].
    apply ge_lub_right'.
  Qed.

  Lemma lub_bot_inv: forall x y (Hlub: fst (lub x y) = bot),
    x = bot /\ y = bot.
  Proof.
    unfold bot.
    intros.
    destruct x; destruct y; inv Hlub; auto.
    destruct_let. simpl in *. congruence.
  Qed.

  Lemma lub_nonbot_spec': forall x y (Hnonbot: x <> bot \/ y <> bot),
    fst (lub x y) <> bot.
  Proof.
    intros.
    destruct x; destruct y; try tauto.
      simpl. unfold bot. destruct_let. simpl. congruence.
  Qed.

  Lemma Leq_nonbot_inv_r: forall x y (Hnonbot: y <> bot) (Heq: eq x y),
    x <> None.
  Proof.
    unfold eq. intros. subst. auto.
  Qed.

  Lemma Leq_nonbot_inv_l: forall x y (Hnonbot: x <> bot) (Heq: eq x y),
    y <> None.
  Proof.
    unfold eq. intros. subst. auto.
  Qed.

  Lemma transfer_nonbot: forall p dms (Hnonbot: dms <> bot),
    transfer p dms <> bot.
  Proof.
    unfold transfer, bot.
    intros.
    destruct dms; congruence.
  Qed.

  Lemma ge_Forall: forall P ox y (Hlt : Forall P y)
    (Hge: ge ox (Some y)),
    match ox with
    | Some x => Forall P x
    | _ => True
    end.
  Proof.
    intros.
    destruct ox as [x|]; tinv Hge.
    simpl in Hge. eauto with sublist.
  Qed.

  Lemma lub_bot_invl: forall x y changed
    (Hlub: lub x y = (bot, changed)),
    x = bot.
  Proof.
    intros. assert (J:=lub_bot_inv x y).
    rewrite Hlub in J. simpl in J. eapply J; eauto.
  Qed.

  Lemma lub_bot_invr: forall x y changed
    (Hlub: lub x y = (bot, changed)),
    y = bot.
  Proof.
    intros. assert (J:=lub_bot_inv x y).
    rewrite Hlub in J. simpl in J. eapply J; eauto.
  Qed.

  Lemma lub_nonbot_spec : forall (x y r : t) changed
    (Hnbot: x <> bot \/ y <> bot)
    (Hlub: lub x y = (r, changed)),
    r <> bot.
  Proof.
    intros.
    apply lub_nonbot_spec' in Hnbot.
    rewrite Hlub in Hnbot.
    simpl in Hnbot. auto.
  Qed.

  Lemma Lub_unchanged_rnonbot__lnonbot: forall x y r
    (Hnonbot : y <> None)
    (HeqR : (r, false) = lub x y),
    x <> None.
  Proof.
    intros.
    intro J. rewrite J in HeqR. simpl in HeqR.
    destruct y; congruence.
  Qed.

  Lemma lub_unchanged_eq_left: forall x y r (Hlub: lub x y = (r, false)),
    x = r.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety. subst.
      caseEq x; simpl.
        intros Xsdms Hgetx. subst.
        simpl in *.
        destruct_let. uniq_result.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        destruct_conjs. f_equal. symmetry. apply H1; auto.

        intros. subst. simpl in Hlub. congruence.

      intros Hgety. subst.
      caseEq x; intros; subst; simpl in *; try congruence.
  Qed.

  Lemma lub_changed_neq_left: forall x y r (Hlub: lub x y = (r, true)),
    x <> r.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety. subst.
      caseEq x; simpl.
        intros Xsdms Hgetx. subst.
        simpl in *.
        destruct_let. uniq_result.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        destruct_conjs. intro J. inv J.
        assert (l=l) as EQ. auto.
        apply H1 in EQ. congruence.

        intros. subst. simpl in Hlub. congruence.
       intros Hgety. subst.
      caseEq x; intros; subst; simpl in *; try congruence.
  Qed.

  Lemma add_mono: forall p x y,
    ge x y -> ge (transfer p x) (transfer p y).
  Proof.
    unfold transfer. intros.
    destruct x as [x|]; destruct y as [y|]; auto.
      simpl in *. auto with sublist.
  Qed.

  Definition gt (x y: t) : Prop :=
  match x, y with
  | Some _, None => True
  | Some x', Some y' => sublist x' y' /\ exists a, In a y' /\ ~ In a x'
  | _, _ => False
  end.

End Doms.

Require Import syntax.
Import LLVMsyntax.

(* Converting an atom-named successor map to a positive-named successor map. *)
Definition atolist_ptolist_fun (a2p:ATree.t positive) :=
  fun acc ato =>
   match ATree.get ato a2p with
   | Some pto => pto::acc
   | _ => acc
   end.

Definition atolist_ptolist (a2p: ATree.t positive) (tolist: list l): list positive :=
  List.fold_left (atolist_ptolist_fun a2p) tolist nil.

Definition asucc_psucc (a2p: ATree.t positive)
                       (pred: PTree.t (list positive))
                       (from: l) (tolist: list l)
                       : PTree.t (list positive) :=
  match ATree.get from a2p with
  | Some pfrom => PTree.set pfrom (atolist_ptolist a2p tolist) pred
  | _ => pred
  end.

Definition asuccs_psuccs (mapping: ATree.t positive) (succs: ATree.t ls)
  : PTree.t (list positive) :=
  ATree.fold (asucc_psucc mapping) succs (PTree.empty (list positive)).


Require Import Coq.Strings.String.
Require Import Coq.PArith.BinPos.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.String.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.HList.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.provers.DefaultProver.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import MirrorCharge.ILogicFunc.
Require Import MirrorCharge.OrderedCanceller.
Require Import MirrorCharge.BILNormalize.
Require Import MirrorCharge.SynSepLog.
Require Import MirrorCharge.SepLogFold.

Require Import MirrorCharge.Java.Semantics.
Require Import MirrorCharge.Java.JavaType.
Require Import MirrorCharge.Java.JavaFunc.

Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.

Require Import MirrorCharge.RTac.ReifyLemma.

Require Import MirrorCharge.RTac.PullConjunct.

Require Import MirrorCore.Reify.Reify.

Require Import MirrorCharge.Java.Reify.

Require Import MirrorCharge.RTac.Subst.

Require Import Java.Language.Lang.
Require Import Java.Language.Program.

Require Import MirrorCharge.RTac.Apply.
Require Import MirrorCharge.RTac.Cancellation.
Require Import MirrorCharge.RTac.Intro.
Require Import MirrorCharge.RTac.EApply.
Require Import MirrorCharge.RTac.Instantiate.

Require Import Coq.Arith.Peano_dec.

Fixpoint mkStars n P Q : expr typ func :=
	match n with
		| 0 => mkStar tySasn P Q
		| S n => mkStar tySasn (mkStars n P Q) (mkStars n P Q)
	end.

Definition cancelTest n :=
      mkForall tySasn tyProp
      (mkForall tySasn tyProp
          (mkEntails tySasn (mkStars n (Var 0) (Var 1)) (mkStars n (Var 1) (Var 0)))).

Section blurb.

Context {fs : Environment}.

Time Eval vm_compute in typeof_expr nil nil (cancelTest 10).
Check THEN.
Check runOnGoals.
Time Eval vm_compute in
	(THEN (REPEAT 10 (INTRO typ func))
	(runOnGoals (CANCELLATION typ func tySasn is_pure)))
		nil nil 0 0 (CTop nil nil) (ctx_empty (expr := expr typ func)) (cancelTest 10).

Fixpoint search_NoDup
    {A} (A_dec: forall a b: A, {a=b}+{a=b->False}) (l: list A) : option (NoDup l) :=
  match l with
  | nil => Some (NoDup_nil A)
  | a::l' =>
      match search_NoDup A_dec l' with
      | Some nodup =>
          match In_dec A_dec a l' with
          | left isin => None
          | right notin =>
 			match search_NoDup A_dec l' with
 				| Some pf => Some (NoDup_cons _ notin pf)
 				| None => None
            end
          end
      | None => None
      end
  end.
(*

Definition list_notin_set lst s :=
  	fold_right (fun a acc => andb (SS.for_all (fun b => negb (string_dec a b)) s) acc) true lst.

Definition method_specI : stac typ (expr typ func) subst :=
  fun tus tvs s lst e =>
    match e with
    	| mkEntails [l, mkProgEq [mkProg [P]], mkMethodSpec [C, m, mkVarList [args], mkString [r], p, q]] =>
    	      match C, m with
    	        | Inj (inl (inr (pString Cname))), Inj (inl (inr (pString Mname))) =>
    	          match SM.find Cname (p_classes P) with
    	          	| Some Class =>
    	          	  match SM.find Mname (c_methods Class) with
    	          	    | Some Method =>
						  match search_NoDup Coq.Strings.String.string_dec args with
						  	| Some pf =>
						  	  match eq_nat_dec (length args) (length (m_params Method)) with
						  	    | left pf' =>
						  	      if list_notin_set args (modifies (m_body Method)) then
						  	        More tus tvs s lst
						  	        mkEntails [l, mkProgEq [mkProg [P]],
						  	                      mkTriple [mkApplyTruncSubst [tyAsn, p, mkSubstList [mkVarList [args], mkExprList [map E_var (m_params Method)]] ], mkCmd [m_body Method],
						  	                               mkApplyTruncSubst [tyAsn, q, mkSubstList [mkVarList [r::args], mkConsExprList [App fEval (mkExpr [m_ret Method]), mkExprList[map E_var (m_params Method)]]] ]]]
						  	      else
						  	        @Fail _ _ _
						  	    | right _ => @Fail _ _ _
						  	  end
						  	| None => @Fail _ _ _
						  end
    	          	    | None => @Fail _ _ _
    	          	  end
    	          	| None => @Fail _ _ _
    	          end
    	        | _, _ => @Fail _ _ _
    	      end
      	| _ => @Fail _ _ _
    end.
*)

Require Import MirrorCharge.Java.Semantics.

(** Skip **)
Definition skip_lemma : lemma typ (expr typ func) (expr typ func).
reify_lemma reify_imp rule_skip.
Defined.
Print skip_lemma.

Lemma skip_lemma_sound :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil skip_lemma.
Proof.
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
  apply rule_skip. apply H.
Qed.

Example test_skip_lemma : test_lemma skip_lemma. Admitted.

Definition skip_lemma2 : lemma typ (expr typ func) (expr typ func).
reify_lemma reify_imp rule_skip2.
Defined.
Print skip_lemma2.

Example test_skip_lemma2 : test_lemma skip_lemma2. Admitted.

Definition seq_lemma (c1 c2 : cmd) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_seq c1 c2).
Defined.
Print seq_lemma.

Lemma seq_lemma_sound c1 c2 :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (seq_lemma c1 c2).
Proof.
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
  eapply rule_seq; [apply H | apply H0].
Qed.

Example test_seq_lemma (c1 c2 : cmd) : test_lemma (seq_lemma c1 c2). Admitted.

Definition if_lemma (e : dexpr) (c1 c2 : cmd) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_if e c1 c2).
Defined.

Require Import ExtLib.Tactics.
(*
Lemma if_lemma_sound e c1 c2 :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (if_lemma e c1 c2).
Proof.
  remember (exprD nil nil (evalDExpr e) tyExpr).
  Check rule_if.
  unfold lemmaD; simpl.
  unfold lemmaD', exprD'_typ0.
  unfold le
  unfold if_lemma.
  destruct o.
  unfold exprD in Heqo. simpl in Heqo.
  remember (ExprDsimul.ExprDenote.exprD' nil nil tyVal (evalDExpr e)).
  destruct o; inv_all; subst; try congruence.
  unfold lemmaD, lemmaD', exprD'_typ0, ExprDsimul.ExprDenote.exprD'; simpl in *; intros.
 unfold ExprDsimul.ExprDenote.exprD' in *; simpl in *; intros.
 unfold exprT_App, exprT_Inj, Rcast_val, Rcast in *; simpl in *.
 unfold OpenFunc.typ2_cast_bin, OpenFunc.typ3_cast_bin in *; simpl in *.
 unfold exprT, OpenT in *; simpl in *.
 rewrite <- Heqo0.
 unfold ExprDsimul.ExprDenote.exprD' in Heqo0. simpl in Heqo0.
 rewrite <- Heqo0.
 repeat red.
 setoid_rewrite <- Heqo.
 rewrite <- Heqo.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].
  + unfold lemmaD; simpl; intros.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].
  + unfold lemmaD; simpl; intros.
    unfold exprT_App, exprT_Inj, Rcast_val, Rcast in * ; simpl in *.
    eapply rule_if; [eapply H | eapply H0].

  Print if_lemma.
  vm_compute.
  unfold lemmaD'. simpl.
  unfold exprD'_typ0. simpl.
  unfold ExprDsimul.ExprDenote.exprD'.
  simpl.
  unfold if_lemma. simpl.
  apply rule_skip. apply H.
Qed.
*)
Example test_if_lemma e (c1 c2 : cmd) : test_lemma (if_lemma e c1 c2). Admitted.

Definition read_lemma (x y : var) (f : field) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_read_fwd x y f).
Defined.

Lemma read_lemma_sound x y f :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (read_lemma x y f).
Proof.
  (*
  unfold lemmaD; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast, OpenFunc.typ3_cast_bin, OpenFunc.typ2_cast_bin, eq_rect_r in * ; simpl in *.
  eapply rule_read_fwd; [eapply H | eapply H0].
  *)
  admit.
Qed.

Example test_read_lemma x y f : test_lemma (read_lemma x y f). Admitted.

Set Printing Width 140.

Definition write_lemma (x : var) (f : field) (e : dexpr) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_write_fwd x f e).
Defined.
(*
Lemma write_lemma_sound x f e :
	lemmaD (exprD'_typ0 (T:=Prop)) nil nil (write_lemma x f e).
Proof.
  induction e.
  Check evalDExpr.
  unfold lemmaD, lemmaD'; simpl; intros.
  unfold exprT_App, exprT_Inj, Rcast_val, Rcast, OpenFunc.typ3_cast_bin, OpenFunc.typ2_cast_bin, eq_rect_r,
  fPointsto, typ2_cast_bin, BaseFunc.mkString; simpl.
  unfold exprD'_typ0; simpl.
  unfold ExprDsimul.ExprDenote.exprD'; simpl.
  vm_compute.
  eapply rule_write_fwd; [eapply H | eapply H0].
Qed.
*)

Example test_write_lemma x f e : test_lemma (write_lemma x f e). Admitted.

Definition assign_lemma (x : var) (e : dexpr) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_assign_fwd x e).
Defined.
Print assign_lemma.
Example test_assign_lemma x e : test_lemma (assign_lemma x e). Admitted.

Definition alloc_lemma (x : var) (C : class) : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@rule_alloc_fwd x C).
Defined.
Example test_alloc_lemma x C : test_lemma (alloc_lemma x C). Admitted.

Definition pull_exists_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@pull_exists val).
Defined.
Example test_pull_exists_lemma : test_lemma pull_exists_lemma. Admitted.
Eval vm_compute in pull_exists_lemma.

Definition ent_exists_right_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp (@ent_left_exists val).
Defined.
Example test_pull_exists_lemma2 : test_lemma ent_exists_right_lemma. Admitted.

Definition eq_to_subst_lemma : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp eq_to_subst.
Defined.
Eval vm_compute in eq_to_subst_lemma.
Example test_eq_lemma : test_lemma (eq_to_subst_lemma). Admitted.
Check rule_static_complete.
Definition scall_lemma (x : Lang.var) (C : class) (m : string) (es : list dexpr)
  : lemma typ (expr typ func) (expr typ func).
Proof.
  reify_lemma reify_imp rule_static_complete.
Qed.

Print scall_lemma.

Print pull_exists_lemma.

Example test_pull_exists : test_lemma (pull_exists_lemma). Admitted.

Require Import MirrorCharge.ModularFunc.BaseFunc.

Definition fieldLookupTac : rtac typ (expr typ func) :=
	fun tus tvs n m c s e =>
		match e with
		  | App (App (App (Inj (inr pFieldLookup)) (Inj (inr (pProg P)))) C) f =>
		    match baseS C with
		      | Some C' =>
		        match C' with
		          | pString C'' =>
				  	match class_lookup C'' P with
		    	      | Some Class =>
		    	        match @exprUnify (ctx_subst c) typ func _ _ _ _ _ 3
		                                 tus tvs 0 f (mkFields (c_fields Class)) tyVarList s with
		                  | Some s => Solved s
		                  | None   => Fail
		                end
		    	      | None => Fail
				    end
				  | _ => Fail
				end
			  | None => Fail
			end
		  | _ => Fail
		end.

Definition FIELD_LOOKUP := fieldLookupTac.

Require Import ExtLib.Tactics.

Lemma FIELD_LOOKUP_sound : rtac_sound FIELD_LOOKUP.
Proof.
  unfold rtac_sound, rtac_spec; intros.
  unfold FIELD_LOOKUP, fieldLookupTac in H.
  destruct g; subst; try apply I.
  forward.
  simpl in H10.
  forward.
  SearchAbout exprUnify'.
  Print exprUnify'.
  Print ExprUnify_common.unify_sound_ind.
  pose proof (exprUnify_sound).
  specialize(H13 (ctx_subst ctx) typ func _ _ _ _ _ _ _ _ _ _ 3).
  red in H13.
  red in H13.
  apply H13 with (tv' := nil) in H10; clear H13; [|assumption].
  forward_reason; split; auto.
  forward. simpl in H13.
  simpl in H15.
  unfold Ctx.propD, exprD'_typ0 in H15.
  forward; inv_all; subst.
  simpl in H15.
  autorewrite with exprD_rw in H15; [|apply _];
  simpl in H15; forward; inv_all; subst.
  autorewrite with exprD_rw in H0.
  simpl in H0; forward; inv_all; subst.
  autorewrite with exprD_rw in H2; [|apply _];
  simpl in H2; forward; inv_all; subst.
  autorewrite with exprD_rw in H2; [|apply _];
  simpl in H2; forward; inv_all; subst.
  unfold funcAs in H2. simpl in H2.
  forward; inv_all; subst.
  pose proof (pctxD_substD H12 H14).
  destruct H as [? [? ?]].
  specialize (H13 _ _ _ H5 eq_refl H).
  forward; inv_all; subst.
  destruct H6 as [? [? ?]].
  pose proof (substD_pctxD _ H10 H14 H6).
  destruct H13 as [? [? ?]].
  simpl in *. unfold Expr_expr.
  rewrite H13.
  split. admit.
  intros. unfold exprT_App, exprT_Inj in *; simpl in *.
  destruct e0; inv_all; try congruence.
  destruct f; try congruence.
  destruct s1; try congruence.
  destruct s1; try congruence.
  destruct s1; try congruence.
  destruct s1; try congruence.
  destruct s1; try congruence.
  inv_all; subst. simpl in *.
  Check Ap_pctxD.
  gather_facts.
  eapply Pure_pctxD; eauto.
  intros.
  specialize (H7 _ _ H8).
  destruct H7 as [? ?]. specialize (H15 HList.Hnil). simpl in H15.
  rewrite H15; clear H15.
  unfold field_lookup. exists c; split; [|reflexivity].
  autorewrite with exprD_rw in H3; [|apply _];
  simpl in H2; forward; inv_all; subst.
  simpl.
  unfold eq_rect_r. simpl.

  Require Import ExtLib.Data.String.

  Lemma class_lookup_sound s p c (H : class_lookup s p = Some c) : In (s, c) (p_classes p).
  Proof.
    destruct p. induction p_classes; simpl in *.
    * unfold class_lookup in H. simpl in H; congruence.
    * unfold class_lookup in H. simpl in H.
      destruct a; simpl in *. consider (s ?[ eq ] s0); intros; subst.
      + left. rewrite rel_dec_eq_true in H; inv_all; subst; [reflexivity| apply _|reflexivity].
      + right. rewrite rel_dec_neq_false in H; [apply IHp_classes; apply H | apply _ | apply H0].
  Qed.

  apply class_lookup_sound.
  apply H9.
  apply _.
Qed.

Require Import MirrorCharge.ModularFunc.ListFunc.

	Definition foldTac (e : expr typ func) (args : list (expr typ func))
	: expr typ func :=
	  match listS e with
	    | Some (pFold t u) =>
	      match args with
	        | f :: acc :: (Inj (inr (pFields fs)))::nil =>
	            fold_right (fun x acc => beta (beta (App (App f (mkString x)) acc))) acc fs
	        | _ => apps e args
	      end
	    | _ => apps e args
	  end.

Require Import MirrorCore.Lambda.ExprTac.

  Lemma foldTacOk : partial_reducer_ok foldTac.
  Proof.
    unfold partial_reducer_ok; intros.
    unfold foldTac.
    remember (listS e); destruct o; [| exists val; tauto].
    destruct l; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct e2; try (exists val; tauto).
    destruct f; try (exists val; tauto).

    destruct j; try (exists val; tauto).
    destruct es; try (exists val; tauto).
    destruct e; simpl in Heqo; try congruence.
    destruct f; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    destruct s; simpl in Heqo; try congruence.
    inv_all; subst.
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst.
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H; simpl in H; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H0; simpl in H0; forward; inv_all; subst; [|apply _].
    autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst; [|apply _].
    unfold funcAs in H2.
    Opaque type_cast.
    simpl in H2. forward; inv_all; subst. red in r. inv_all.
    inversion r; subst.
    rewrite (UIP_refl r) in H4. unfold Rcast in H4; simpl in H4.
    inversion H4; unfold eq_rect_r in H6; simpl in H6.
    subst. clear H4.
    clear H2 r.
    Opaque beta.
    simpl.
    unfold exprT_App, eq_rect_r. simpl.
    cut (exists val' : exprT tus tvs (typD t),
  ExprDsimul.ExprDenote.exprD' tus tvs t
    (fold_right
       (fun (x : string) (acc : expr typ func) =>
        beta (beta (App (App e0 (mkString x)) acc))) e1 l) = Some val' /\
  (forall (us : hlist typD tus) (vs : hlist typD tvs),
   fold_right (e4 us vs) (e3 us vs) (exprT_Inj tus tvs l us vs) = val' us vs)).
   intros [? [? ?]].
   eexists; split; [eassumption | intros; apply H4].
    induction l; simpl; intros.

    + exists e3; tauto.
    + destruct IHl as [? [? ?]].
      eexists; split; [|intros; reflexivity].

  Lemma exprD'_remove_beta tus tvs t e de (H : exprD' tus tvs e t = Some de) :
    exprD' tus tvs (beta e) t = Some de.
  Proof.
    pose proof (beta_sound tus tvs e t).
    unfold exprD' in *. simpl in *. forward; inv_all; subst.
	Require Import FunctionalExtensionality.
	f_equal. symmetry.
    apply functional_extensionality; intros.
    apply functional_extensionality; intros.
    apply H2.
  Qed.

      do 2 (apply exprD'_remove_beta).
      unfold exprD'. simpl.

      red_exprD; [|apply _].
      pose proof (exprD_typeof_Some).
      specialize (H5  _ _ _ _ _ _ _ _ _ _ _ _ _ H2). rewrite H5; clear H5.
      red_exprD; [|apply _].
      forward; inv_all; subst.
      unfold mkString. forward.
      red_exprD; [|apply _].
      Transparent type_cast.
      unfold funcAs. simpl.
	  f_equal. unfold exprT_App; simpl.
	  unfold eq_rect_r. simpl.
	  apply functional_extensionality; intros.
	  apply functional_extensionality; intros.
	  rewrite H4. reflexivity.
Qed.
SearchAbout partial_reducer_ok.

Print partial_reducer_ok.
Print apps_reducer.
Print full_reducer_ok.
Print full_reducer.
Check @idred.
SearchAbout idred.
Print idred.
Print idred'.
Check @beta_all.

Definition FOLD := SIMPLIFY (typ := typ) (fun _ _ _ _ => (beta_all (fun _ => foldTac))).

Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Lambda.RedAll.
Print partial_reducer.

(*
  Lemma foldTacOk2 : partial_reducer_ok foldTac.
  Proof.
    unfold full_reducer_ok; intros.
    Print var_termsP.
    Print partial_reducer_ok.
    unfold exprT, OpenT in P.
    unfold foldTac.
    remember (listS e). destruct o.
    Focus 2.
    simpl.
  Qed.
*)
Lemma FOLD_sound : rtac_sound FOLD.
Proof.
  admit.
  (*
  unfold FOLD.
  apply SIMPLIFY_sound.
  intros; simpl.
  forward.
  rewrite <- H.
  simpl.
  unfold Ctx.propD, exprD'_typ0 in H3; forward; inv_all; subst.
  destruct (beta_all_sound foldTacOk _ _ e0 H3) as [v [H4 H5]].
  apply beta_all_sound.
  Check beta_all_sound.
  (* beta_all_sound is missing *)

  *)
Qed.
Check apps.
Definition BETA := SIMPLIFY (typ := typ) (fun _ _ _ _ => beta_all (fun _ => @apps typ func)).

Lemma BETA_sound : rtac_sound BETA.
Proof.
  unfold BETA.
  apply SIMPLIFY_sound.
  intros; simpl; forward.
  (*
  SearchAbout full_reducer.
  assert (full_reducer_ok (fun _ => apps (sym := func))). {
    clear.
    intros e vars tus tvs tus' tvs' P Hvars es t targs Hexpr.
  }
  unfold full_reducer_ok.

  Print full_reducer.
  pose proof (beta_all_sound).
  SearchAbout beta_all.
  rewrite <- H.*)
  admit.
Qed.

Definition THEN' := @MirrorCore.RTac.Then.THEN typ (expr typ func).
Require Import MirrorCharge.RTac.Minify.

Let EAPPLY lem := THEN' (EAPPLY typ func lem) (MINIFY typ func).

Definition THEN (r1 r2 : rtac typ (expr typ func)) :=
  THEN (THEN (THEN (INSTANTIATE typ func) (runOnGoals r1)) (runOnGoals (INSTANTIATE typ func))) (runOnGoals r2).

Definition EQSUBST := THEN (EAPPLY eq_to_subst_lemma) (SUBST typ func).

(*
Notation "'ap_eq' '[' x ',' y ']'" :=
	 (ap (T := Fun stack) (ap (T := Fun stack) (pure (T := Fun stack) (@eq val)) x) y).
*)

Require Import MirrorCharge.ModularFunc.OpenFunc.
Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.EmbedFunc.

Definition match_ap_eq (e : expr typ func) : bool :=
	match e with
	  | App emb (App (App f (App (App g (App h e)) x)) y) =>
	  	match embedS emb, open_funcS f, open_funcS g, open_funcS h, baseS e with
	  		| Some (eilf_embed _ _), Some (of_ap _ _), Some (of_ap _ _), Some (of_const _), Some (pEq _) => true
	  		| _, _, _, _, _ => false
	  	end
	  | _ => false
	end.

Definition PULLEQL := PULLCONJUNCTL typ func match_ap_eq ilops.

                        (*
	THEN (INSTANTIATE typ func subst) (runOnGoals (THEN (THEN (TRY FIELD_LOOKUP)
		(runOnGoals (CANCELLATION typ func subst tySpec (fun _ => false)))) (runOnGoals FOLD))) ::
		solve_entailment :: nil).
	           *)
Require Import MirrorCharge.AutoSetoidRewrite.
Require Import MirrorCharge.SetoidRewrite.Base.
Require Import MirrorCharge.SetoidRewrite.ILSetoidRewrite.
Require Import MirrorCharge.SetoidRewrite.BILSetoidRewrite.

  Definition spec_respects (e : expr typ func) (_ : list (RG (expr typ func)))
	   (rg : RG (expr typ func)) : m (expr typ func) :=
	   match e with
	     | Inj (inr pTriple) =>
	       rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg
	         (RGrespects (RGflip (RGinj (fEntails tySasn)))
	           (RGrespects (RGinj (fEq tyCmd))
	             (RGrespects (RGinj (fEntails tySasn))
	               (RGinj (fEntails tySpec))))))
	         (fun _ => rg_ret fTriple)
	     | _ => rg_fail
	   end.

Definition step_unfold vars rw :=
  setoid_rewrite vars _ (fEntails : typ -> expr typ func) rw
    (sr_combine il_respects
               (sr_combine (@il_respects_reflexive typ func _ _ _ ilops _ _)
                                        (sr_combine bil_respects
                                                    (sr_combine eq_respects
                                                    (sr_combine spec_respects refl)))))
    (fun _ => rw_fail).

  Definition STEP_REWRITE rw : rtac typ (expr typ func) :=
    fun tus tvs lus lvs c s e =>
      match step_unfold (getVars c) rw tyProp e with
        | Some (e', _) => More s (GGoal e')
        | _ => More s (GGoal e)
      end.

Definition PULL_TRIPLE_EXISTS : rtac typ (expr typ func) :=
  THEN (THEN (EAPPLY pull_exists_lemma) (INTRO typ func)) BETA.

Definition solve_entailment (rw : rewriter (typ := typ) (func := func)) : rtac typ (expr typ func) :=
	THEN (INSTANTIATE typ func)
		(FIRST (SOLVE (CANCELLATION typ func tySasn is_pure) ::
	           (THEN (THEN (THEN (THEN PULLEQL (REPEAT 1000 EQSUBST))
	           (STEP_REWRITE rw)) (REPEAT 1000 (INTRO typ func)))
	              (CANCELLATION typ func tySasn is_pure)::
	           nil))).

Definition solve_alloc rw : rtac typ (expr typ func) :=
    THEN (INSTANTIATE typ func)
    (FIRST (SOLVE (CANCELLATION typ func tySpec (fun _ => false)) ::
                        FIELD_LOOKUP ::
                        THEN FOLD (solve_entailment rw) :: nil)).

Check MINIFY.
Print rtacK.
Check runOnGoals (SUBST typ func).
Check THENK.
Print rtacK.

Definition simStep (rw : rewriter (typ := typ) (func := func)) (r : rtac typ (expr typ func)) :=
    THEN (THEN (THEN (THEN (SUBST typ func)
    	(TRY PULL_TRIPLE_EXISTS)) (STEP_REWRITE rw)) (REPEAT 10 PULL_TRIPLE_EXISTS)) r.

Require Import MirrorCharge.RTac.Minify.

Fixpoint tripleE (c : cmd) rw : rtac typ (expr typ func) :=
	match c with
	    | cskip => simStep rw (THEN (EAPPLY skip_lemma) (solve_entailment rw))
	    | calloc x C => simStep rw (THEN (EAPPLY (alloc_lemma x C))
	        (FIRST (solve_alloc rw::solve_entailment rw::nil)))
		| cseq c1 c2 => simStep rw (THEN' (EAPPLY (seq_lemma c1 c2))
		    (THENK (runOnGoals (TRY (tripleE c1 rw))) (THENK (MINIFY typ func) (runOnGoals (tripleE c2 rw)))))
		| cassign x e => simStep rw (THEN (EAPPLY (assign_lemma x e)) (solve_entailment rw))
		| cread x y f => simStep rw (THEN (EAPPLY (read_lemma x y f)) (solve_entailment rw))
		| cwrite x f e => simStep rw (THEN (EAPPLY (write_lemma x f e)) (solve_entailment rw))
		| _ => IDTAC
	end.

Definition symE rw : rtac typ (expr typ func) :=
	(fun tus tvs n m ctx s e =>
		(match e return rtac typ (expr typ func) with
			| App (App (Inj f) G) H =>
			  match ilogicS f, H with
			  	| Some (ilf_entails tySpec), (* tySpec is a pattern, should be checked for equality with tySpec *)
			  	  App (App (App (Inj (inr pTriple)) P) Q) (Inj (inr (pCmd c))) =>
			  	  	tripleE c rw
			  	| _, _ => FAIL
			  end
			| _ => FAIL
		end) tus tvs n m ctx s e).

Definition runTac rw :=
   (THEN (THEN (REPEAT 1000 (INTRO typ func)) (symE rw))
	(INSTANTIATE typ func)).

Lemma runTac_sound rw : rtac_sound (runTac rw).
Proof.
  admit.
Qed.

Definition mkPointsto (x : expr typ func) (f : field) (e : expr typ func) : expr typ func :=
   mkAp tyVal tyAsn
        (mkAp tyString (tyArr tyVal tyAsn)
              (mkAp tyVal (tyArr tyString (tyArr tyVal tyAsn))
                    (mkConst (tyArr tyVal (tyArr tyString (tyArr tyVal tyAsn)))
                             fPointsto)
                    x)
              (mkConst tyString (mkString f)))
        e.

Require Import Java.Semantics.OperationalSemantics.
Require Import Java.Logic.SpecLogic.
Require Import Java.Logic.AssertionLogic.
Require Import Java.Examples.ListClass.
Require Import Charge.Logics.ILogic.

Fixpoint seq_skip n :=
	match n with
	  | 0 => cskip
	  | S n => cseq cskip (seq_skip n)
	end.

Require Import ExtLib.Structures.Applicative.
Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

Definition testSkip n : Prop :=
  forall (G : spec) (P : sasn), G |-- triple P P (seq_skip n).

Lemma INTRO_sound : rtac_sound (INTRO typ func).
Proof.
  admit.
Qed.

Require Import MirrorCharge.RTac.Tactics.
Check IDTAC_sound.

Ltac rtac_result reify term_table tac :=
	  let name := fresh "e" in
	  match goal with
	    | |- ?P =>
	      reify_aux reify term_table P name;
	      let t := eval vm_compute in (typeof_expr nil nil name) in
	      let goal := eval unfold name in name in
	      match t with
	        | Some ?t =>
	          let goal_result := constr:(run_tac tac (GGoal name)) in
	          let result := eval vm_compute in goal_result in
	          idtac result
	        | None => idtac "expression " goal "is ill typed" t
	      end
	  end.

Lemma test_skip_lemma3 : testSkip 10.
Proof.
  idtac "start".
  unfold testSkip; simpl.

  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Time Qed.

Definition test_alloc : expr typ func :=
	mkEntails tySpec (mkProgEq (mkProg ListProg))
		(mkTriple (mkTrue tySasn) (mkCmd (cseq (calloc "x" "NodeC") cskip)) (mkFalse tySasn)).

Require Import Charge.Logics.BILogic.

  Lemma test_alloc_correct :
  prog_eq ListProg |-- triple empSP lfalse ((calloc "x" "NodeC");;Skip).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
  unfold open_func_symD. simpl.
  admit.
Qed.

Lemma test_read : ltrue |--
    triple
      (ap_pointsto [("o": var), ("f" : field), pure (T := Fun (Lang.stack)) (vint 3)] **
       ap_pointsto [("o": var), ("g" : field), pure (T := Fun (Lang.stack)) (vint 4)])
      (ap_pointsto [("o": var), ("f": field), pure (T := Fun (Lang.stack)) (vint 3)] **
      (ap_pointsto [("o": var), ("g": field), pure (T := Fun (Lang.stack)) (vint 4)]))
      (cseq (cread "x" "o" "f") (cseq (cread "y" "o" "g") cskip)).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Qed.

Lemma test_write :
	ltrue |--
	triple
      (ap_pointsto [("o": var), ("f" : field), pure (T := Fun (Lang.stack)) (vint 3)])
      (ap_pointsto [("o": var), ("f": field), pure (T := Fun (Lang.stack)) (vint 4)])
      (cseq (cwrite "o" "f" (E_val (vint 4))) cskip).
Proof.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Qed.

Require Import BinInt.

Fixpoint mkSwapPre n : sasn :=
	match n with
	  | 0   => empSP
	  | S n => ap_pointsto [("o": Lang.var), (append "f" (nat2string10 n) : field),
	  	                     (eval (E_val (vint (Z.of_nat n))))] **
	           mkSwapPre n
	end.

Fixpoint mkSwapPostAux n m :=
  match n with
    | 0 => empSP
	| S n => ap_pointsto [("o": Lang.var), (append "f" (nat2string10 n) : field),
	  	                     (eval (E_val (vint (Z.of_nat (m - (S n))))))] **
	         mkSwapPostAux n m
  end.

Definition mkSwapPost n := mkSwapPostAux n n.

Fixpoint mkRead n c :=
	match n with
	  | 0 => c
	  | S n => cseq (cread ((append "x" (nat2string10 n):Lang.var)) ("o":Lang.var) ((append "f" (nat2string10 n)):field))
	                (mkRead n c)
    end.

Fixpoint mkWriteAux n m c :=
	match n with
	  | 0 => c
	  | S n => cseq (cwrite ("o":Lang.var) (append "f" (nat2string10 n)) (E_var (append "x" (nat2string10 (m - (S n))))))
	                (mkWriteAux n m c)
    end.

Definition mkWrite n c := mkWriteAux n n c.

Definition mkSwapProg (n : nat) (c : cmd) := mkRead n (mkWrite n c).

Definition mkSwap n :=
	ltrue |-- triple (mkSwapPre n) (mkSwapPost n) (mkSwapProg n cskip).

Set Printing Depth 100.

Lemma test_swap : mkSwap 20.
Proof.
  Opaque ap.
  unfold mkSwap, mkSwapPre, mkSwapPost, mkSwapProg, mkSwapPostAux, mkRead, mkWrite, mkWriteAux.
  Time run_rtac reify_imp term_table (@runTac_sound rw_fail).
Time Qed.

End blurb.


(* Time-stamp: "2018-02-09 17:01:14 pierre" *)
(****************************************************************)
(*                       yinYang.v                             *)
(*                                                              *)
(**          © Pierre Lescanne  (December 2015)                 *)
(*                                                              *)
(*              LIP (ENS-Lyon, CNRS, INRIA)                     *)
(*                                                              *)
(*                                                              *)
(*  Developed in  V8.4pl4               January -- May   2016   *)
(****************************************************************)

Section YinYang.

Add LoadPath ".".

Require Import games_Choice_Dependent.

(* Setting sets for agents and choices *)
Inductive AliceBob : Set := | Alice | Bob.
Inductive DorR : Set := | down | right.
Inductive YinYang: Set := | ying | yang.
Definition Choice: AliceBob -> Set := fun a => DorR.

Arguments StratProf [Agent Utility Choice].
Arguments Game [Agent Utility Choice].
Arguments UAssignment [Agent Utility Choice] s H a.
Arguments game [Agent Utility Choice] s.
Arguments StratProf_decomposition [Agent Utility Choice] s.
Arguments Convergent [Agent Utility Choice] s.
Arguments AlwaysConvergent [Agent Utility Choice] s.
Arguments convLeaf [Agent Utility Choice] f.
Arguments convNode [Agent Utility Choice] a c next _.
Arguments SPE [Agent Utility Choice] preference  s.
Arguments Uassign [Agent Utility Choice] s a u.
Arguments good [Agent Utility Choice] preference s.
Arguments gEqual [Agent Utility Choice] g1 g2.
Arguments Divergent  [Agent Utility Choice] s.
Arguments AlwaysGood  [Agent Utility Choice] preference s.

Notation "<< f >>" := (sLeaf AliceBob YinYang Choice  f).
Notation "<< a , c , next >>" :=
  (sNode AliceBob YinYang Choice a c next).
Notation "[ x , y ]" :=
  (fun a:AliceBob => match a with Alice => x | Bob => y end).
Notation "<| f |>" := (gLeaf  AliceBob YinYang Choice f).
Notation "<| a , next |>" := (gNode AliceBob YinYang Choice a next).

Notation "s1 +++ s2" :=
  (fun c:DorR => match c with down => s1 | right => s2 end)
  (at level 30).
Notation "↓ s " := (Convergent s) (at level 5).
Notation "⇓ s" := (AlwaysConvergent s)
                    (at level 15).
Notation "↑ s " := (Divergent s) (at level 5).
Notation "g == g'" := (gEqual g g') (at level 80).

Ltac decomp := rewrite <- StratProf_decomposition; simpl.

(* --------------------------------- *)
(**    Infinite Game Zero One        *)
(* --------------------------------- *)

(* Definitions *)
CoFixpoint yinYangAcBs := <<Alice, right, <<[yang,ying]>> +++ yinYangBsAc>>
  with yinYangBsAc := <<Bob, down, <<[ying,yang]>> +++ yinYangAcBs>>.

CoFixpoint yinYangAsBc := <<Alice, down, <<[yang,ying]>> +++ yinYangBcAs>>
  with yinYangBcAs := <<Bob, right, <<[ying,yang]>> +++ yinYangAsBc>>.

CoFixpoint yinYangAcBc := <<Alice, right, <<[yang,ying]>> +++ yinYangBcAc>>
  with yinYangBcAc := <<Bob, right, <<[ying,yang]>> +++ yinYangAcBc>>.

(* == Lemmas on utility assignments == *)

(* A continue Bob stops *)

Lemma UassignYyBsAcya: Uassign yinYangBsAc Alice ying.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangBsAc); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignYyBsAcyi: Uassign yinYangBsAc Bob yang.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangBsAc); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignYyAcBsyi: Uassign yinYangAcBs Bob yang.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangAcBs); simpl.
  apply UassignNode.
  apply UassignYyBsAcyi.
Qed.

(* A stops Bob continues *)
Lemma UassignYyAsBcyi: Uassign yinYangAsBc Alice yang.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangAsBc); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignYyAsBcya: Uassign yinYangAsBc Bob ying.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangAsBc); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignYyBcAsyi: Uassign yinYangBcAs Alice yang.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangBcAs); simpl.
  apply UassignNode.
  apply UassignYyAsBcyi.
Qed.

Lemma UassignYyBcAsya:  Uassign yinYangBcAs Bob ying.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangBcAs); simpl.
  apply UassignNode.
  apply UassignYyAsBcya.
Qed.

(* Lemmas on Convergence of strategy profiles *)
Lemma ConvYyBsAc: ↓ yinYangBsAc.
Proof.
  decomp.
  apply ConvNode.
  apply ConvLeaf.
Qed.

Lemma ConvYyAcBs: ↓ yinYangAcBs.
Proof.
  decomp.
  decomp.
  apply ConvNode.
  apply ConvYyBsAc.
Qed.

Lemma ConvYyAsBc: ↓ yinYangAsBc.
Proof.
  decomp;apply ConvNode; apply ConvLeaf.
Qed.

Lemma ConvYyBcAs: ↓ yinYangBcAs.
Proof.
  decomp; apply ConvNode; apply ConvYyAsBc.
Qed.

(* Lemmas on Always Convergence of strategy profiles *)
Lemma AlwsConvYyAcBs: ⇓ yinYangAcBs.
Proof.
  cofix AlwsConvYyAcBs;
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvYyBsAc |
   induction c'; [apply AlwaysLeaf | decomp; apply AlwaysNode; [apply ConvNode; apply ConvLeaf |
                                                                 induction c'; [apply AlwaysLeaf | apply AlwsConvYyAcBs]]]].
Qed.

Lemma AlwsConvYyBsAc: ⇓ yinYangBsAc.
Proof.
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvLeaf |
   induction c'; [apply AlwaysLeaf | apply AlwsConvYyAcBs]].
Qed.

Lemma AlwsConvYyBcAs: ⇓ yinYangBcAs.
Proof.
  cofix AlwsConvYyBcAs;
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvYyAsBc |
   induction c'; [apply AlwaysLeaf |
                   decomp; apply AlwaysNode;
                   [apply ConvNode; apply ConvLeaf|
                    induction c'; [apply AlwaysLeaf | apply AlwsConvYyBcAs]]]].
Qed.

Lemma AlwsConvYyAsBc: ⇓ yinYangAsBc.
Proof.
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvLeaf |
   induction c'; [apply AlwaysLeaf | apply AlwsConvYyBcAs]].
Qed.

(* Equality of the underlying game *)
Lemma sameGameBcAc_BsAc: game yinYangBcAc == game yinYangBsAc.
Proof.
  cofix sameGameBcAc_BsAc.
  rewrite <- StratProf_decomposition with (s:=yinYangBcAc);
  rewrite <- StratProf_decomposition with (s:=yinYangBsAc);
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c;
  [apply refGEqual |
   rewrite <- StratProf_decomposition with (s:=yinYangAcBc);
     rewrite <- StratProf_decomposition with (s:=yinYangAcBs);
     simpl;
     rewrite gameNode; rewrite gameNode; apply gEqualNode;
     induction c; [apply refGEqual | apply sameGameBcAc_BsAc]].
Qed.

Lemma sameGameAcBc_AcBs: game yinYangAcBc == game yinYangAcBs.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangAcBc);
  rewrite <- StratProf_decomposition with (s:=yinYangAcBs);
  simpl.
  rewrite gameNode; rewrite gameNode; apply gEqualNode.
  induction c; [apply refGEqual | apply sameGameBcAc_BsAc].
Qed.

Lemma sameGameBcAs_BcAc: game yinYangBcAc == game yinYangBcAs.
Proof.
  cofix sameGameBcAc_BsAc.
  rewrite <- StratProf_decomposition with (s:=yinYangBcAc);
  rewrite <- StratProf_decomposition with (s:=yinYangBcAs);
  simpl.
  rewrite gameNode; rewrite gameNode; apply gEqualNode.
  induction c.
  apply refGEqual.
  rewrite <- StratProf_decomposition with (s:=yinYangAcBc);
  rewrite <- StratProf_decomposition with (s:=yinYangAsBc);
  simpl.
  rewrite gameNode; rewrite gameNode; apply gEqualNode.
  induction c; [apply refGEqual | apply sameGameBcAc_BsAc].
Qed.

Lemma sameGameAcBc_AsBc: game yinYangAcBc == game yinYangAsBc.
Proof.
  rewrite <- StratProf_decomposition with (s:=yinYangAcBc);
  rewrite <- StratProf_decomposition with (s:=yinYangAsBc);
  simpl.
  rewrite gameNode; rewrite gameNode; apply gEqualNode.
  induction c; [apply refGEqual | apply sameGameBcAs_BcAc].
Qed.

(* SPE *)
Lemma SPEYyAcBs: SPE eq yinYangAcBs.
Proof.
  cofix SPEYyAcBs;
  decomp;
  apply SPENode with (c':=right)(u:=ying)(u':=ying);
  [apply AlwaysNode; [apply ConvNode; apply ConvYyBsAc |
                      induction c';  [apply AlwaysLeaf | apply AlwsConvYyBsAc]] |
   apply UassignYyBsAcya |
   apply UassignYyBsAcya |
   reflexivity |
   decomp ; apply SPENode with (c':=right)(u:=yang)(u':=yang);
   [apply AlwaysNode; [apply ConvNode; apply ConvLeaf |
                       induction c'; [apply AlwaysLeaf | apply AlwsConvYyAcBs]] |
    apply UassignYyAcBsyi |
    apply UassignLeaf |
    reflexivity |
    apply SPEYyAcBs]].
Qed.

Lemma SPEYyBsAc: SPE eq yinYangBsAc.
Proof.
  cofix SPEYyBsAc.
  decomp.
  apply SPENode with (c':=right)(u:=yang)(u':=yang).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvLeaf.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyAcBs.
  apply UassignYyAcBsyi.
  apply UassignLeaf.
  reflexivity.
  apply SPEYyAcBs.
Qed.

Lemma SPEYyAsBc: SPE eq yinYangAsBc.
Proof.
  cofix SPEYyAsBc.
  decomp.
  apply SPENode with (c':=right)(u:=yang)(u':=yang).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvLeaf.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyBcAs.
  apply UassignYyBcAsyi.
  apply UassignLeaf.
  reflexivity.
  decomp.
  apply SPENode with (c':=right)(u:=ying)(u':=ying).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvYyAsBc.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyAsBc.
  apply UassignYyAsBcya.
  apply UassignYyAsBcya.
  reflexivity.
  apply SPEYyAsBc.
Qed.

Lemma SPEYyBcAs: SPE eq yinYangBcAs.
Proof.
  decomp.
  apply SPENode with (c':=right)(u:=ying)(u':=ying).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvYyAsBc.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyAsBc.
  apply UassignYyAsBcya.
  apply UassignYyAsBcya.
  reflexivity.
  apply SPEYyAsBc.
Qed.

(* Good *)
Lemma GoodYyAcBc: good eq yinYangAcBc.
Proof.
  decomp.
  apply goodNode with (next':= <<[yang,ying]>> +++ yinYangBsAc).
  split.
  rewrite gameNode; rewrite gameNode.
  apply gEqualNode.
  induction c.
  rewrite gameLeaf.
  apply gEqualLeaf.
  apply sameGameBcAc_BsAc.
  apply SPENode with (c':=right)(u:=ying)(u':=ying).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvYyBsAc.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyBsAc.
  apply UassignYyBsAcya.
  apply UassignYyBsAcya.
  reflexivity.
  apply SPEYyBsAc.
Qed.

Lemma GoodYyBcAc: good eq yinYangBcAc.
Proof.
  decomp.
  apply goodNode with (next':= <<[ying,yang]>> +++ yinYangAsBc).
  split.
  rewrite gameNode; rewrite gameNode.
  apply gEqualNode.
  induction c.
  rewrite gameLeaf.
  apply gEqualLeaf.
  apply sameGameAcBc_AsBc.
  apply SPENode with (c':=right)(u:=ying)(u':=ying).
  apply AlwaysNode.
  apply ConvNode.
  apply ConvYyAsBc.
  induction c'.
  apply AlwaysLeaf.
  apply AlwsConvYyAsBc.
  apply UassignYyAsBcya.
  apply UassignYyAsBcya.
  reflexivity.
  apply SPEYyAsBc.
Qed.

(* Always Good AcBc *)
Lemma AlwaysGoodYyAcBc: AlwaysGood eq yinYangAcBc.
Proof.
  cofix AlwaysGoodYyAcBc.
  decomp.
  apply AlwaysNode.
  replace (<< Alice, right, << [yang,ying] >> +++ yinYangBcAc >>) with yinYangAcBc.
  apply GoodYyAcBc.
  rewrite <- StratProf_decomposition with (s:=yinYangAcBc); simpl; reflexivity.
  induction c'.
  apply AlwaysLeaf.
  decomp.
  apply AlwaysNode.
  replace (<< Bob, right, << [ying,yang] >> +++ yinYangAcBc >>) with yinYangBcAc.
  apply GoodYyBcAc.
  rewrite <- StratProf_decomposition with (s:=yinYangBcAc); simpl; reflexivity.
  induction c'; [apply AlwaysLeaf | apply AlwaysGoodYyAcBc].
Qed.

(* Divergent *)
Lemma DivergenceYyAcBc: ↑ yinYangAcBc.
Proof.
  cofix DivergenceYyAcBc.
  decomp.
  apply divNode.
  decomp.
  apply divNode.
  apply DivergenceYyAcBc.
Qed.

End YinYang.