Require Export Iron.Language.SystemF2Store.Store.
Require Export Iron.Language.SystemF2Store.StepContext.
Require Export Iron.Language.SystemF2Store.TyJudge.
Require Export Iron.Language.SystemF2Store.SubstExpExp.
Require Export Iron.Language.SystemF2Store.Exp.

(********************************************************************)
(** * Single Small Step Evaluation *)
(** The single step rules model the individual transitions that the
     machine can make at runtime. *)

Inductive STEP : store -> exp -> store -> exp -> Prop :=

 (* Step some sub-expression in an evaluation context *)
 | EsContext
   :  forall C s x s' x'
   ,  exp_ctx C
   -> STEP s x      s' x'
   -> STEP s (C x)  s' (C x')

 | EsLamApp
   : forall s t11 x12 v2
   ,  wnfX v2
   -> STEP s (XApp   (XLam t11 x12) v2)
           s (substXX 0 v2 x12)

 (* Type application *)
 | EsLAMAPP
   :  forall s x12 t2
   ,  STEP s (XAPP (XLAM x12) t2)
           s (substTX 0 t2 x12)

 (* Allocate a new data object in the store *)
 | EsAlloc
   :  forall s dc tsParam xs svs
   ,  Forall2 svalueOf xs svs
   -> STEP s                      (XCon dc tsParam xs)
           (snoc (SObj dc svs) s) (XLoc (length s))

 (* Case branching reads data objects from the store *)
 | EsCaseAlt
   :  forall s dc svs vs alts x l
   ,  get l s        = Some (SObj dc svs)
   -> getAlt dc alts = Some (AAlt dc x)
   -> Forall2 svalueOf vs svs
   -> STEP s (XCase (XLoc l) alts)
           s (substXXs 0 vs x)

 (* If an update operator matches the data constructor in the heap then
    update the appropriate field. *)
 | EsUpdate
   :  forall l s dc cn i tsParam svs vField svField
   ,  get l s =  Some (SObj dc svs)
   -> dc      =  cn
   -> svalueOf vField svField
   -> STEP s
           (XUpdate cn i tsParam (XLoc l) vField)
           (replace l (SObj dc (replace i svField svs)) s)
           xUnit

 (* If an update operator does not match the data constructor in the heap
    then just return unit. *)
 | EsUpdateSkip
   :  forall l s dc cn i tsParam svs vField
   ,  get l s =  Some (SObj dc svs)
   -> ~(dc    = cn)
   -> STEP s (XUpdate cn i tsParam (XLoc l) vField)
           s xUnit.

Hint Constructors STEP.

(* Multi-step evaluation
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   ESAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : store -> exp -> store -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall s1 x1
   ,  STEPS s1 x1 s1 x1

 (* Take a single step. *)
 | EsStep
   :  forall s1 x1 s2 x2
   ,  STEP  s1 x1 s2 x2
   -> STEPS s1 x1 s2 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall s1 x1 s2 x2 s3 x3
   ,  STEPS s1 x1 s2 x2 -> STEPS s2 x2 s3 x3
   -> STEPS s1 x1 s3 x3.

Hint Constructors STEPS.

(* Stepping a wnf doesn't change it. *)
Lemma step_wnfX
 :  forall x v s1 s2
 ,  wnfX x -> STEP s1 x s2 v -> v = x.
Proof.
 intros x v s1 s2 HW HS.
 induction HS; nope.
  destruct H; auto; nope.
Qed.

(* If we have a list context we can step some expression
   applied to a data constructor *)
Lemma step_context_XCon_exists
 :  forall  C x dc ts s1 s2
 ,  exps_ctx wnfX C
 -> (exists x', STEP s1 x s2 x')
 -> (exists x', STEP s1 (XCon dc ts (C x)) s2 (XCon dc ts (C x'))).
Proof.
 intros C x dc ts s1 s2 HC HS.
 shift x'.
 eapply (EsContext (fun xx => XCon dc ts (C xx))); auto.
Qed.

(* Multi-step evaluating a wnf doesn't change it. *)
Lemma steps_wnfX
 :  forall x v s1 s2
 ,  wnfX x -> STEPS s1 x s2 v -> v = x.
Proof.
 intros x v s1 s2 HW HS.
 induction HS; auto.
  Case "EsStep".
   eapply step_wnfX; eauto.

  Case "EsAppend".
   have (x2 = x1).
   subst. auto.
Qed.

(* Multi-step evaluation in a context. *)
Lemma steps_context
 :  forall C s1 x1 s2 x1'
 ,  exp_ctx C
 -> STEPS s1 x1     s2 x1'
 -> STEPS s1 (C x1) s2 (C x1').
Proof.
 intros C s1 x1 s2 x1' HC HS.
 induction HS; eauto.
Qed.

(* Multi-step evaluation of a data constructor argument. *)
Lemma steps_context_XCon
 :  forall C s1 x s2 v dc ts
 ,  exps_ctx wnfX C
 -> STEPS s1 x s2 v
 -> STEPS s1 (XCon dc ts (C x)) s2 (XCon dc ts (C v)).
Proof.
 intros C s1 x s2 v dc ts HC HS.
 induction HS; auto.

 Case "XCon".
  lets D: EsContext XcCon; eauto.
  eauto.
Qed.

(* TODO: First premise doesn't work because each xs uses a different store
Lemma steps_in_XCon
 :  forall xs ts vs dc
 ,  Forall2 STEPS xs vs
 -> Forall wnfX vs
 -> STEPS (XCon dc ts xs) (XCon dc ts vs).
Proof.
 intros xs ts vs dc HS HW.
 lets HC: make_chain HS HW.
  eapply steps_wnfX.

 clear HS. clear HW.
 induction HC; auto.
  eapply (EsAppend (XCon dc ts (C x)) (XCon dc ts (C v))); auto.
  eapply steps_context_XCon; auto.
Qed.
*)

(********************************************************************)
(* Left linearised multi-step evaluation
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma. *)
Inductive STEPSL : store -> exp -> store -> exp -> Prop :=
 | EslNone
   : forall s1 x1
   , STEPSL s1 x1 s1 x1

 | EslCons
   :  forall s1 x1 s2 x2 s3 x3
   ,  STEP   s1 x1 s2 x2 -> STEPSL s2 x2 s3 x3
   -> STEPSL s1 x1 s3 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall s1 x1 s2 x2 s3 x3
 ,  STEPSL s1 x1 s2 x2 -> STEPSL s2 x2 s3 x3
 -> STEPSL s1 x1 s3 x3.
Proof.
 intros s1 x1 s2 x2 s3 x3 H1 H2.
 induction H1; eauto.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions. *)
Lemma stepsl_of_steps
 :  forall s1 x1 s2 x2
 ,  STEPS  s1 x1 s2 x2
 -> STEPSL s1 x1 s2 x2.
Proof.
 intros s1 x1 s2 x2 HS.
 induction HS;
  eauto using stepsl_trans.
Qed.


Require Import Bool List String Peano_dec Lia.
Require Import Common FMap IndexSupport HVector Syntax Topology Semantics SemFacts StepM.
Require Import Invariant TrsInv Simulation Serial SerialFacts.
Require Import RqRsLang RqRsInvMsg RqRsCorrect.

Require Import Ex.Spec Ex.SpecInds Ex.Template.
Require Import Ex.Mesi Ex.Mesi.Mesi Ex.Mesi.MesiTopo.

Require Import Ex.Mesi.MesiInv.

Set Implicit Arguments.

Import PropMonadNotations.
Import CaseNotations.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

#[global] Existing Instance Mesi.ImplOStateIfc.

Definition InvL1DirI (cifc: CIfc) (st: State): Prop :=
  Forall (fun oidx =>
            ost <+- (st_oss st)@[oidx];
              ost#[dir].(dir_st) = mesiI)
         (c_l1_indices cifc).

Section InvL1DirI.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma mesi_InvL1DirI_init:
    Invariant.InvInit impl (InvL1DirI cifc).
  Proof.
    do 2 (red; simpl); intros.
    apply Forall_forall; intros oidx ?.
    destruct (implOStatesInit tr)@[oidx] as [ost|] eqn:Host; simpl; auto.
    rewrite implOStatesInit_value_non_root in Host;
      [|assumption|apply in_or_app; auto].
    inv Host.
    reflexivity.
  Qed.

  Lemma mesi_InvL1DirI_step:
    Invariant.InvStep impl step_m (InvL1DirI cifc).
  Proof. (* SKIP_PROOF_ON
    red; intros.
    inv H1; [assumption..|].
    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)
      red; simpl.
      apply Forall_forall; intros oidx ?.
      red in H0; simpl in H0.
      rewrite Forall_forall in H0; specialize (H0 _ H1).
      mred.

      exfalso.
      eapply tree2Topo_root_not_in_l1; eauto.

    - (*! Cases for Li caches *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.

      apply Forall_forall; intros roidx ?; simpl.
      red in H0; simpl in H0.
      rewrite Forall_forall in H0; specialize (H0 _ H1).
      mred.

      exfalso.
      pose proof (tree2Topo_WfCIfc tr 0) as [? _].
      apply (DisjList_NoDup idx_dec) in H4.
      apply tl_In in H2.
      eapply DisjList_In_1; eassumption.

    - (*! Cases for L1 caches *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.

      apply Forall_forall; intros roidx ?; simpl.
      red in H0; simpl in H0.
      rewrite Forall_forall in H0; specialize (H0 _ H1).
      mred; clear H1; simpl.
      simpl in H5; rewrite H5 in H0; simpl in H0.

      (** Do case analysis per a rule. *)
      dest_in.
      all: disc_rule_conds_ex. (* takes 10 seconds *)

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem mesi_InvL1DirI_ok:
    InvReachable impl step_m (InvL1DirI cifc).
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply mesi_InvL1DirI_init.
    - apply mesi_InvL1DirI_step.
  Qed.

End InvL1DirI.

Definition ObjWBDir (oidx: IdxT) (ost: OState) (msgs: MessagePool Msg) :=
  (ObjInvWRq oidx msgs \/ ObjInvRq oidx msgs \/ ObjInvRs oidx msgs) ->
  ost#[dir].(dir_st) = mesiI.

Definition InvWBDir (st: State): Prop :=
  forall oidx,
    ost <+- (st_oss st)@[oidx]; ObjWBDir oidx ost (st_msgs st).

(** NOTE: [InvWBCoh] requires [InvWBDir] during the proof *)
Definition InvWBCoh (st: State): Prop :=
  forall oidx,
    ost <+- (st_oss st)@[oidx];
      CohInvRq oidx ost (st_msgs st).

Section InvWBDir.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma mesi_InvWBDir_init:
    Invariant.InvInit impl InvWBDir.
  Proof.
    do 2 (red; simpl).
    intros.
    destruct (implOStatesInit tr)@[oidx] as [orq|] eqn:Host; simpl; auto.
    red; intros.
    exfalso; destruct H as [|[|]].
    - destruct H as [idm [? ?]].
      do 2 red in H; dest_in.
    - destruct H as [idm [? ?]].
      do 2 red in H; dest_in.
    - destruct H as [idm [? ?]].
      do 2 red in H; dest_in.
  Qed.

  Lemma mesi_InvWBDir_ext_in:
    forall oss orqs msgs,
      InvWBDir {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall eins,
        ValidMsgsExtIn impl eins ->
        InvWBDir {| st_oss := oss; st_orqs := orqs; st_msgs := enqMsgs eins msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H2 as [|[|]].
    - destruct H2 as [idm [? ?]].
      apply InMP_enqMsgs_or in H2.
      destruct H2; [|apply H; left; do 2 red; eauto].
      apply in_map with (f:= idOf) in H2; simpl in H2.
      apply H1 in H2; simpl in H2.
      exfalso; eapply DisjList_In_1.
      + apply tree2Topo_minds_merqs_disj.
      + eassumption.
      + eapply tree2Topo_obj_chns_minds_SubList.
        * specialize (H0 oidx); simpl in H0.
          rewrite Host in H0; simpl in H0.
          eassumption.
        * destruct idm as [midx msg]; inv H3.
          simpl; tauto.
    - destruct H2 as [idm [? ?]].
      apply InMP_enqMsgs_or in H2.
      destruct H2; [|apply H; right; left; do 2 red; eauto].
      apply in_map with (f:= idOf) in H2; simpl in H2.
      apply H1 in H2; simpl in H2.
      exfalso; eapply DisjList_In_1.
      + apply tree2Topo_minds_merqs_disj.
      + eassumption.
      + eapply tree2Topo_obj_chns_minds_SubList.
        * specialize (H0 oidx); simpl in H0.
          rewrite Host in H0; simpl in H0.
          eassumption.
        * destruct idm as [midx msg]; inv H3.
          simpl; tauto.
    - destruct H2 as [idm [? ?]].
      apply InMP_enqMsgs_or in H2.
      destruct H2; [|apply H; right; right; do 2 red; eauto].
      apply in_map with (f:= idOf) in H2; simpl in H2.
      apply H1 in H2; simpl in H2.
      exfalso; eapply DisjList_In_1.
      + apply tree2Topo_minds_merqs_disj.
      + eassumption.
      + eapply tree2Topo_obj_chns_minds_SubList.
        * specialize (H0 oidx); simpl in H0.
          rewrite Host in H0; simpl in H0.
          eassumption.
        * destruct idm as [midx msg]; inv H3.
          simpl; tauto.
  Qed.

  Lemma mesi_InvWBDir_ext_out:
    forall oss orqs msgs,
      InvWBDir {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall (eouts: list (Id Msg)),
        InvWBDir {| st_oss := oss;
                    st_orqs := orqs;
                    st_msgs := deqMsgs (idsOf eouts) msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H1 as [|[|]].
    - destruct H1 as [idm [? ?]].
      apply InMP_deqMsgs in H1.
      apply H; left; do 2 red; eauto.
    - destruct H1 as [idm [? ?]].
      apply InMP_deqMsgs in H1.
      apply H; right; left; do 2 red; eauto.
    - destruct H1 as [idm [? ?]].
      apply InMP_deqMsgs in H1.
      apply H; right; right; do 2 red; eauto.
  Qed.

  Lemma InvWBDir_no_update:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (post nost: OState),
        oss@[oidx] = Some post ->
        nost#[dir].(dir_st) = post#[dir].(dir_st) ->
        InvWBDir {| st_oss:= oss +[oidx <- nost];
                    st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    mred; simpl; auto.
    specialize (H oidx).
    rewrite H0 in H; simpl in H.
    red; intros.
    simpl; rewrite H1; auto.
  Qed.

  Lemma InvWBDir_update_status_NoRqI_NoRsI:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (ost: OState),
        NoRqI oidx msgs ->
        NoRsI oidx msgs ->
        InvWBDir {| st_oss:= oss +[oidx <- ost];
                    st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    mred; simpl; auto.
    red; intros.
    exfalso; destruct H2 as [|[|]].
    - eapply MsgExistsSig_MsgsNotExist_false; [apply H0| |eassumption].
      simpl; tauto.
    - eapply MsgExistsSig_MsgsNotExist_false; [apply H0| |eassumption].
      simpl; tauto.
    - eapply MsgExistsSig_MsgsNotExist_false; [apply H1| |eassumption].
      simpl; tauto.
  Qed.

  Lemma InvWBDir_enqMP_rq_valid:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx ost midx msg,
        oss@[oidx] = Some ost ->
        ost#[dir].(dir_st) = mesiI ->
        midx = rqUpFrom oidx ->
        msg.(msg_id) = mesiInvWRq \/ msg.(msg_id) = mesiInvRq ->
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    destruct (idx_dec oidx0 oidx); subst.
    - specialize (H oidx).
      rewrite H0 in *; simpl in *.
      red; intros; auto.
    - specialize (H oidx0).
      destruct (oss@[oidx0]) as [ost0|]; simpl in *; auto.
      red; intros.
      destruct H2 as [|[|]].
      + destruct H2 as [idm [? ?]].
        apply InMP_enqMP_or in H2; destruct H2.
        * dest; inv H4; rewrite H2 in H7; inv H7.
          exfalso; auto.
        * apply H; left; do 2 red; eauto.
      + destruct H2 as [idm [? ?]].
        apply InMP_enqMP_or in H2; destruct H2.
        * dest; inv H4; rewrite H2 in H7; inv H7.
          exfalso; auto.
        * apply H; right; left; do 2 red; eauto.
      + destruct H2 as [idm [? ?]].
        apply InMP_enqMP_or in H2; destruct H2.
        * dest; inv H4; rewrite H2 in H7; inv H7.
        * apply H; right; right; do 2 red; eauto.
  Qed.

  Lemma InvWBDir_enqMP_rs_valid:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx rqm midx msg,
        FirstMP msgs (rqUpFrom oidx) rqm ->
        (rqm.(msg_id) = mesiInvWRq \/ rqm.(msg_id) = mesiInvRq) ->
        rqm.(msg_type) = MRq ->
        midx = downTo oidx ->
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMP midx msg (deqMP (rqUpFrom oidx) msgs) |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    destruct (idx_dec oidx0 oidx); subst.
    - specialize (H oidx).
      destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
      red; intros; apply H.
      destruct H1.
      + left; do 2 red.
        exists (rqUpFrom oidx, rqm); split.
        * apply FirstMP_InMP; assumption.
        * unfold sigOf; simpl.
          rewrite H1, H2; reflexivity.
      + right; left; do 2 red.
        exists (rqUpFrom oidx, rqm); split.
        * apply FirstMP_InMP; assumption.
        * unfold sigOf; simpl.
          rewrite H1, H2; reflexivity.
    - specialize (H oidx0).
      destruct (oss@[oidx0]) as [ost0|]; simpl in *; auto.
      red; intros.
      destruct H3 as [|[|]].
      + destruct H3 as [idm [? ?]].
        apply InMP_enqMP_or in H3; destruct H3.
        * dest; inv H4; rewrite H3 in H7; inv H7.
        * apply InMP_deqMP in H3.
          apply H; left; do 2 red; eauto.
      + destruct H3 as [idm [? ?]].
        apply InMP_enqMP_or in H3; destruct H3.
        * dest; inv H4; rewrite H3 in H7; inv H7.
        * apply InMP_deqMP in H3.
          apply H; right; left; do 2 red; eauto.
      + destruct H3 as [idm [? ?]].
        apply InMP_enqMP_or in H3; destruct H3.
        * dest; inv H4; rewrite H3 in H7; inv H7.
          exfalso; auto.
        * apply InMP_deqMP in H3.
          apply H; right; right; do 2 red; eauto.
  Qed.

  Lemma InvWBDir_other_msg_id_enqMP:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx msg,
        msg.(msg_id) <> mesiInvWRq ->
        msg.(msg_id) <> mesiInvRq ->
        msg.(msg_id) <> mesiInvRs ->
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H3 as [|[|]].
    - destruct H3 as [idm [? ?]].
      apply InMP_enqMP_or in H3; destruct H3.
      + dest; subst; inv H4; exfalso; auto.
      + apply H; left; do 2 red; eauto.
    - destruct H3 as [idm [? ?]].
      apply InMP_enqMP_or in H3; destruct H3.
      + dest; subst; inv H4; exfalso; auto.
      + apply H; right; left; do 2 red; eauto.
    - destruct H3 as [idm [? ?]].
      apply InMP_enqMP_or in H3; destruct H3.
      + dest; subst; inv H4; exfalso; auto.
      + apply H; right; right; do 2 red; eauto.
  Qed.

  Lemma InvWBDir_other_msg_id_enqMsgs:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall nmsgs,
        Forall (fun idm => (valOf idm).(msg_id) <> mesiInvWRq /\
                           (valOf idm).(msg_id) <> mesiInvRq /\
                           (valOf idm).(msg_id) <> mesiInvRs) nmsgs ->
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMsgs nmsgs msgs |}.
  Proof.
    intros.
    generalize dependent msgs.
    induction nmsgs as [|[nmidx nmsg] nmsgs]; simpl; intros; auto.
    inv H0; dest.
    apply IHnmsgs; auto.
    apply InvWBDir_other_msg_id_enqMP; assumption.
  Qed.

  Lemma InvWBDir_deqMP:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx,
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= deqMP midx msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H0 as [|[|]].
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMP in H0.
      apply H; left; do 2 red; eauto.
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMP in H0.
      apply H; right; left; do 2 red; eauto.
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMP in H0.
      apply H; right; right; do 2 red; eauto.
  Qed.

  Lemma InvWBDir_deqMsgs:
    forall oss orqs msgs,
      InvWBDir {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall minds,
        InvWBDir {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= deqMsgs minds msgs |}.
  Proof.
    unfold InvWBDir; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    destruct H0 as [|[|]].
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMsgs in H0.
      apply H; left; do 2 red; eauto.
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMsgs in H0.
      apply H; right; left; do 2 red; eauto.
    - destruct H0 as [idm [? ?]].
      apply InMP_deqMsgs in H0.
      apply H; right; right; do 2 red; eauto.
  Qed.

  Ltac simpl_InvWBDir_enqMP :=
    simpl;
    try match goal with
        | [H: msg_id ?rmsg = _ |- msg_id ?rmsg <> _] => rewrite H
        end;
    discriminate.

  Ltac simpl_InvWBDir_enqMsgs :=
    let idm := fresh "idm" in
    let Hin := fresh "H" in
    apply Forall_forall; intros idm Hin;
    apply in_map_iff in Hin; dest; subst;
    repeat ssplit; simpl_InvWBDir_enqMP.

  Ltac simpl_InvWBDir :=
    repeat
      (first [apply InvWBDir_other_msg_id_enqMP; [|simpl_InvWBDir_enqMP..]
             |apply InvWBDir_other_msg_id_enqMsgs; [|simpl_InvWBDir_enqMsgs]
             |apply InvWBDir_deqMP
             |apply InvWBDir_deqMsgs
             |apply InvWBDir_update_status_NoRqI_NoRsI; [|assumption..]
             |eapply InvWBDir_no_update; [|eauto; fail..]
             |assumption]).

  Ltac solve_InvWBDir :=
    let oidx := fresh "oidx" in
    red; simpl; intros oidx;
    match goal with
    | [Hi: InvWBDir _ |- _] =>
      specialize (Hi oidx); simpl in Hi;
      mred; simpl;
      let Hinv := fresh "H" in
      intros Hinv;
      specialize (Hi Hinv)
    end;
    simpl in *; solve_mesi.

  Lemma mesi_InvWBDir_step:
    Invariant.InvStep impl step_m InvWBDir.
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (footprints_ok
                  (mesi_GoodORqsInit Htr)
                  (mesi_GoodRqRsSys Htr) H) as Hftinv.
    pose proof (mesi_InObjInds H) as Hioi.
    pose proof (mesi_MsgConflictsInv
                  (@mesi_RootChnInv_ok _ Htr) H) as Hpmcf.
    pose proof (MesiDownLockInv_ok H) as Hmdl.
    inv H1; [assumption
            |apply mesi_InvWBDir_ext_in; auto
            |apply mesi_InvWBDir_ext_out; auto
            |].

    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))) as Hin.
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }

      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.

      (** Do case analysis per a rule. *)
      apply concat_In in H3; destruct H3 as [crls [? ?]].
      apply in_map_iff in H1; destruct H1 as [cidx [? ?]]; subst.
      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBDir; fail).
      all: try (assert (NoRqI oidx msgs)
                 by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                assert (NoRsI oidx msgs)
                  by (solve_NoRsI_base; solve_NoRsI_by_no_uplock oidx);
                simpl_InvWBDir).
      all: try (eapply InvWBDir_enqMP_rs_valid; eauto;
                simpl_InvWBDir; fail).

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H3; destruct H3.

      1: { (** Rules per a child *)
        apply concat_In in H3; destruct H3 as [crls [? ?]].
        apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.
        dest_in; disc_rule_conds_ex.

        all: try (simpl_InvWBDir; fail).
        all: try (assert (NoRqI oidx msgs)
                   by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                  assert (NoRsI oidx msgs)
                    by (solve_NoRsI_base; solve_NoRsI_by_no_uplock oidx);
                  simpl_InvWBDir).
        all: try (eapply InvWBDir_enqMP_rs_valid; eauto;
                  simpl_InvWBDir; fail).
      }

      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBDir; fail).
      all: try (derive_footprint_info_basis oidx;
                assert (NoRqI oidx msgs)
                  by (solve_NoRqI_base; solve_NoRqI_by_rsDown oidx);
                assert (NoRsI oidx msgs)
                  by (solve_NoRsI_base; solve_NoRsI_by_rsDown oidx);
                simpl_InvWBDir).
      all: try (simpl_InvWBDir; solve_InvWBDir; fail).
      all: try (disc_MesiDownLockInv oidx Hmdl;
                simpl_InvWBDir; solve_InvWBDir; fail).
      { eapply InvWBDir_enqMP_rq_valid; eauto.
        { solve_InvWBDir. }
        { mred. }
        { assumption. }
      }
      { eapply InvWBDir_enqMP_rq_valid; eauto.
        { solve_InvWBDir. }
        { mred. }
        { assumption. }
      }

    - (*! Cases for L1 caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_l1_indices_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Register an invariant that holds only for L1 caches. *)
      pose proof (mesi_InvL1DirI_ok H) as Hl1d.
      red in Hl1d; simpl in Hl1d.
      rewrite Forall_forall in Hl1d; specialize (Hl1d _ H2).
      simpl in H5; rewrite H5 in Hl1d; simpl in Hl1d.

      (** Do case analysis per a rule. *)
      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBDir; fail).
      { eapply InvWBDir_enqMP_rq_valid; eauto.
        { solve_InvWBDir. }
        { mred. }
        { assumption. }
      }
      { eapply InvWBDir_enqMP_rq_valid; eauto.
        { solve_InvWBDir. }
        { mred. }
        { assumption. }
      }

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem mesi_InvWBDir_ok:
    InvReachable impl step_m InvWBDir.
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply mesi_InvWBDir_init.
    - apply mesi_InvWBDir_step.
  Qed.

End InvWBDir.

Ltac derive_InvWBDir oidx :=
  repeat
    match goal with
    | [Hi: InvWBDir _ |- _] =>
      specialize (Hi oidx); simpl in Hi;
      repeat
        match type of Hi with
        | _ <+- ?ov; _ =>
          match goal with
          | [Hv: ov = Some _ |- _] => rewrite Hv in Hi; simpl in Hi
          end
        end
    | [Ho: ObjWBDir _ _ _ |- _] => red in Ho
    end.

Section InvWBCoh.
  Variable (tr: tree).
  Hypothesis (Htr: tr <> Node nil).

  Let topo: DTree := fst (tree2Topo tr 0).
  Let cifc: CIfc := snd (tree2Topo tr 0).
  Let impl: System := impl Htr.

  Lemma mesi_InvWBCoh_init:
    Invariant.InvInit impl InvWBCoh.
  Proof.
    do 2 (red; simpl).
    intros.
    destruct (implOStatesInit tr)@[oidx] as [orq|] eqn:Host; simpl; auto.
    destruct (in_dec idx_dec oidx (c_li_indices cifc ++ c_l1_indices cifc)).
    - subst cifc; rewrite c_li_indices_head_rootOf in i by assumption.
      inv i.
      + rewrite implOStatesInit_value_root in Host by assumption.
        inv Host.
        red; intros.
        do 2 (red in H); dest_in.
      + rewrite implOStatesInit_value_non_root in Host by assumption.
        inv Host.
        red; intros.
        do 2 (red in H0); dest_in.
    - rewrite implOStatesInit_None in Host by assumption.
      discriminate.
  Qed.

  Lemma mesi_InvWBCoh_ext_in:
    forall oss orqs msgs,
      InvWBCoh {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall eins,
        ValidMsgsExtIn impl eins ->
        InvWBCoh {| st_oss := oss; st_orqs := orqs; st_msgs := enqMsgs eins msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    apply InMP_enqMsgs_or in H2.
    destruct H2; [|eapply H; eauto].
    apply in_map with (f:= idOf) in H2; simpl in H2.
    apply H1 in H2; simpl in H2.
    exfalso; eapply DisjList_In_1.
    - apply tree2Topo_minds_merqs_disj.
    - eassumption.
    - eapply tree2Topo_obj_chns_minds_SubList.
      + specialize (H0 oidx); simpl in H0.
        rewrite Host in H0; simpl in H0.
        eassumption.
      + destruct idm as [midx msg]; inv H3.
        simpl; tauto.
  Qed.

  Lemma mesi_InvWBCoh_ext_out:
    forall oss orqs msgs,
      InvWBCoh {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      InObjInds tr 0 {| st_oss := oss; st_orqs := orqs; st_msgs := msgs |} ->
      forall (eouts: list (Id Msg)),
        InvWBCoh {| st_oss := oss;
                    st_orqs := orqs;
                    st_msgs := deqMsgs (idsOf eouts) msgs |}.
  Proof.
    red; simpl; intros.
    specialize (H oidx); simpl in H.
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros; apply InMP_deqMsgs in H1; auto.
  Qed.

  Lemma InvWBCoh_no_update:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (post nost: OState),
        oss@[oidx] = Some post ->
        nost#[val] = post#[val] ->
        nost#[owned] = post#[owned] ->
        nost#[status] = post#[status] ->
        nost#[dir].(dir_st) = post#[dir].(dir_st) ->
        InvWBCoh {| st_oss:= oss +[oidx <- nost];
                    st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    mred; simpl; auto.
    specialize (H oidx).
    rewrite H0 in H; simpl in H.
    red; intros.
    specialize (H _ H5 H6).
    simpl in *.
    rewrite H1.
    apply H; auto.
    congruence.
  Qed.

  Lemma InvWBCoh_update_status_NoRqI:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx (ost: OState),
        NoRqI oidx msgs ->
        InvWBCoh {| st_oss:= oss +[oidx <- ost];
                    st_orqs:= orqs; st_msgs:= msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    mred; simpl; auto.
    red; intros.
    specialize (H0 _ H1).
    red in H0; rewrite H2 in H0.
    unfold map in H0.
    rewrite caseDec_head_neq in H0 by discriminate.
    rewrite caseDec_head_eq in H0 by reflexivity.
    exfalso; auto.
  Qed.

  Lemma InvWBCoh_enqMP_valid:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall oidx ost midx msg,
        oss@[oidx] = Some ost ->
        midx = rqUpFrom oidx ->
        msg.(msg_id) = mesiInvWRq ->
        msg.(msg_value) = ost#[val] ->
        InvWBCoh {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    destruct (idx_dec oidx0 oidx); subst.
    - specialize (H oidx).
      rewrite H0 in *; simpl in *.
      red; intros.
      apply InMP_enqMP_or in H1; destruct H1.
      + dest; simpl in *.
        intros; inv H4; assumption.
      + apply H; auto.
    - specialize (H oidx0).
      destruct (oss@[oidx0]) as [ost0|]; simpl in *; auto.
      red; intros.
      apply InMP_enqMP_or in H1; destruct H1.
      + exfalso; dest; subst.
        inv H4; rewrite H1 in H7; inv H7; auto.
      + apply H; auto.
  Qed.

  Lemma InvWBCoh_other_msg_id_enqMP:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx msg,
        msg.(msg_id) <> mesiInvWRq ->
        InvWBCoh {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMP midx msg msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros.
    apply InMP_enqMP_or in H1; destruct H1; auto.
    dest; subst.
    destruct idm as [midx msg]; simpl in *.
    inv H2; exfalso; auto.
  Qed.

  Lemma InvWBCoh_other_msg_id_enqMsgs:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall nmsgs,
        Forall (fun idm => (valOf idm).(msg_id) <> mesiInvWRq) nmsgs ->
        InvWBCoh {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= enqMsgs nmsgs msgs |}.
  Proof.
    intros.
    generalize dependent msgs.
    induction nmsgs as [|[nmidx nmsg] nmsgs]; simpl; intros; auto.
    inv H0; dest.
    apply IHnmsgs; auto.
    apply InvWBCoh_other_msg_id_enqMP; assumption.
  Qed.

  Lemma InvWBCoh_deqMP:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall midx,
        InvWBCoh {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= deqMP midx msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros; apply InMP_deqMP in H0; auto.
  Qed.

  Lemma InvWBCoh_deqMsgs:
    forall oss orqs msgs,
      InvWBCoh {| st_oss:= oss; st_orqs:= orqs; st_msgs:= msgs |} ->
      forall minds,
        InvWBCoh {| st_oss:= oss; st_orqs:= orqs;
                    st_msgs:= deqMsgs minds msgs |}.
  Proof.
    unfold InvWBCoh; simpl; intros.
    specialize (H oidx).
    destruct (oss@[oidx]) as [ost|] eqn:Host; simpl in *; auto.
    red; intros; apply InMP_deqMsgs in H0; auto.
  Qed.

  Ltac simpl_InvWBCoh_enqMP :=
    simpl;
    try match goal with
        | [H: msg_id ?rmsg = _ |- msg_id ?rmsg <> _] => rewrite H
        end;
    discriminate.

  Ltac simpl_InvWBCoh_enqMsgs :=
    let idm := fresh "idm" in
    let Hin := fresh "H" in
    apply Forall_forall; intros idm Hin;
    apply in_map_iff in Hin; dest; subst;
    simpl_InvWBCoh_enqMP.

  Ltac simpl_InvWBCoh :=
    repeat
      (first [apply InvWBCoh_other_msg_id_enqMP; [|simpl_InvWBCoh_enqMP..]
             |apply InvWBCoh_other_msg_id_enqMsgs; [|simpl_InvWBCoh_enqMsgs]
             |apply InvWBCoh_deqMP
             |apply InvWBCoh_deqMsgs
             |apply InvWBCoh_update_status_NoRqI; [|assumption]
             |eapply InvWBCoh_no_update; [|eauto; fail..]
             |assumption]).

  Ltac solve_InvWBCoh :=
    let oidx := fresh "oidx" in
    red; simpl; intros oidx;
    match goal with
    | [Hi: InvWBCoh _ |- _] =>
      specialize (Hi oidx); simpl in Hi
    end;
    mred; simpl;
    let Hin := fresh "H" in
    let Hsig := fresh "H" in
    red; intros ? Hin Hsig;
    repeat
      match goal with
      | [Hc: CohInvRq _ _ _ |- _] => specialize (Hc _ Hin Hsig); dest
      | [Hi: ObjInvWRq _ _ \/ _ -> _ |- _] =>
        specialize (Hi (or_introl (@ex_intro _ _ _ (conj Hin Hsig))))
      end;
    simpl in *;
    solve [exfalso; solve_mesi|
           simpl; intros;
           try match goal with
               | [H: context [invalidate ?st] |- _] =>
                 pose proof (invalidate_sound st)
               end;
           intuition solve_mesi].

  Lemma mesi_InvWBCoh_step:
    Invariant.InvStep impl step_m InvWBCoh.
  Proof. (* SKIP_PROOF_ON
    red; intros.
    pose proof (footprints_ok
                  (mesi_GoodORqsInit Htr)
                  (mesi_GoodRqRsSys Htr) H) as Hftinv.
    pose proof (mesi_InObjInds H) as Hioi.
    pose proof (mesi_MsgConflictsInv
                  (@mesi_RootChnInv_ok _ Htr) H) as Hpmcf.
    pose proof (MesiDownLockInv_ok H) as Hmdl.
    pose proof (mesi_InvWBDir_ok H) as Hidir.
    inv H1; [assumption
            |apply mesi_InvWBCoh_ext_in; auto
            |apply mesi_InvWBCoh_ext_out; auto
            |].

    simpl in H2; destruct H2; [subst|apply in_app_or in H1; destruct H1].

    - (*! Cases for the main memory *)

      (** Abstract the root. *)
      assert (In (rootOf (fst (tree2Topo tr 0)))
                 (c_li_indices (snd (tree2Topo tr 0)))) as Hin.
      { rewrite c_li_indices_head_rootOf by assumption.
        left; reflexivity.
      }

      remember (rootOf (fst (tree2Topo tr 0))) as oidx; clear Heqoidx.

      (** Do case analysis per a rule. *)
      apply concat_In in H3; destruct H3 as [crls [? ?]].
      apply in_map_iff in H1; destruct H1 as [cidx [? ?]]; subst.
      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBCoh; fail).
      all: try (assert (NoRqI oidx msgs)
                 by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                simpl_InvWBCoh).

    - (*! Cases for Li caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst; simpl in *.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_li_indices_tail_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      apply in_app_or in H3; destruct H3.

      1: { (** Rules per a child *)
        apply concat_In in H3; destruct H3 as [crls [? ?]].
        apply in_map_iff in H3; destruct H3 as [cidx [? ?]]; subst.
        dest_in; disc_rule_conds_ex.

        all: try (simpl_InvWBCoh; fail).
        all: try (assert (NoRqI oidx msgs)
                   by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                  simpl_InvWBCoh).
      }

      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBCoh; fail).
      all: try (assert (NoRqI oidx msgs)
                 by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                simpl_InvWBCoh).
      all: try (derive_footprint_info_basis oidx;
                assert (NoRqI oidx msgs)
                  by (solve_NoRqI_base; solve_NoRqI_by_rsDown oidx);
                simpl_InvWBCoh).
      all: try (simpl_InvWBCoh; solve_InvWBCoh; fail).
      all: try (disc_MesiDownLockInv oidx Hmdl;
                derive_InvWBDir oidx;
                simpl_InvWBCoh; solve_InvWBCoh; fail).
      { eapply InvWBCoh_enqMP_valid; eauto. }

    - (*! Cases for L1 caches *)

      (** Derive some necessary information: each Li has a parent. *)
      apply in_map_iff in H1; destruct H1 as [oidx [? ?]]; subst.

      pose proof (tree2Topo_TreeTopoNode tr 0) as Htn.
      pose proof (c_l1_indices_has_parent Htr _ _ H2).
      destruct H1 as [pidx [? ?]].
      pose proof (Htn _ _ H4); dest.

      (** Do case analysis per a rule. *)
      dest_in; disc_rule_conds_ex.

      all: try (simpl_InvWBCoh; fail).
      all: try (assert (NoRqI oidx msgs)
                 by (solve_NoRqI_base; solve_NoRqI_by_no_locks oidx);
                simpl_InvWBCoh).
      all: try (derive_footprint_info_basis oidx;
                assert (NoRqI oidx msgs)
                  by (solve_NoRqI_base; solve_NoRqI_by_rsDown oidx);
                simpl_InvWBCoh).
      all: try (simpl_InvWBCoh; solve_InvWBCoh; fail).
      { eapply InvWBCoh_enqMP_valid; eauto. }

      END_SKIP_PROOF_ON *) admit.
  Qed.

  Theorem mesi_InvWBCoh_ok:
    InvReachable impl step_m InvWBCoh.
  Proof.
    eapply inv_reachable.
    - typeclasses eauto.
    - apply mesi_InvWBCoh_init.
    - apply mesi_InvWBCoh_step.
  Qed.

End InvWBCoh.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2014                                          *)
(*                                                                        *)
(*     Michaël Armand                                                     *)
(*     Benjamin Grégoire                                                  *)
(*     Chantal Keller                                                     *)
(*                                                                        *)
(*     INRIA - École Polytechnique - MSR                                  *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Add LoadPath "." as SMTCoq.
Add LoadPath "cnf" as SMTCoq.cnf.
Add LoadPath "euf" as SMTCoq.euf.
Add LoadPath "lia" as SMTCoq.lia.
Add LoadPath "spl" as SMTCoq.spl.

Require Import Bool Int31 PArray.
Require Import Misc State SMT_terms Cnf Euf Lia Syntactic Arithmetic Operators.

Local Open Scope array_scope.
Local Open Scope int31_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Set Vm Optimize.
Section trace.

  (* We are given a certificate, a checker for it (that modifies a
     state), and a proof that the checker is correct: the state it
     returns must be valid and well-formed. *)

  Variable step : Type.

  Variable check_step : S.t -> step -> S.t.

  Variable rho : Valuation.t.

  (* We use [array array step] to allow bigger trace *)
  Definition _trace_ := array (array step).

  (* A checker for such a trace *)

  Variable is_false : C.t -> bool.
  Hypothesis is_false_correct : forall c, is_false c -> ~ C.interp rho c.

  Definition _checker_ (s: S.t) (t: _trace_) (confl:clause_id) : bool :=
    let s' := PArray.fold_left (fun s a => PArray.fold_left check_step s a) s t in
    is_false (S.get s' confl).
  Register _checker_ as PrimInline.

  (* For debugging *)
  (*

  Variable check_step_debug : S.t -> step -> option S.t.

  Definition _checker_debug_ (s: S.t) (t: _trace_) : sum S.t ((int*int)*S.t) :=
    let s' := PArray.foldi_left (fun i s a => PArray.foldi_left (fun j s' a' =>
      match s' with
        | inl s'' =>
          match check_step_debug s'' a' with
            | Some s''' => inl s'''
            | None => inr ((i,j),s'')
          end
        | u => u
      end) s a) (inl s) t in
    s'.

  Definition _checker_partial_ (s: S.t) (t: _trace_) (max:int) : S.t :=
    PArray.fold_left (fun s a => PArray.foldi_left (fun i s' a' => if i < max then check_step s' a' else s') s a) s t.
  *)

  (* Proof of its partial correction: if it returns true, then the
     initial state is not valid *)

  Hypothesis valid_check_step :
    forall s, S.valid rho s -> forall c, S.valid rho (check_step s c).

  Lemma _checker__correct :
    forall s, forall t confl, _checker_ s t confl-> ~ (S.valid rho s).
  Proof.
    unfold _checker_.
    intros s t' cid Hf Hv.
    apply (is_false_correct Hf).
    apply S.valid_get.
    apply PArray.fold_left_ind; auto.
    intros a i _ Ha;apply PArray.fold_left_ind;trivial.
    intros a0 i0 _ H1;auto.
  Qed.

End trace.

(* Application to resolution *)

Module Sat_Checker.

 Inductive step :=
   | Res (_:int) (_:resolution).

 Definition resolution_checker s t :=
    _checker_ (fun s (st:step) => let (pos, r) := st in S.set_resolve s pos r) s t.

 Lemma resolution_checker_correct :
    forall rho, Valuation.wf rho ->
    forall s t cid, resolution_checker C.is_false s t cid->
     ~S.valid rho s.
 Proof.
   intros rho Hwr;apply _checker__correct.
   intros; apply C.is_false_correct; trivial.
   intros s Hv (pos, r);apply S.valid_set_resolve;trivial.
 Qed.

 (** Application to Zchaff *)
 Definition dimacs := PArray.array (PArray.array _lit).

 Definition C_interp_or rho c :=
   afold_left _ _ false orb (Lit.interp rho) c.

 Lemma C_interp_or_spec : forall rho c,
   C_interp_or rho c = C.interp rho (to_list c).
 Proof.
   intros rho c; unfold C_interp_or; case_eq (C.interp rho (to_list c)).
   unfold C.interp; rewrite List.existsb_exists; intros [x [H1 H2]]; destruct (In_to_list _ _ H1) as [i [H3 H4]]; subst x; apply (afold_left_orb_true _ i); auto.
   unfold C.interp; intro H; apply afold_left_orb_false; intros i H1; case_eq (Lit.interp rho (c .[ i])); auto; intro Heq; assert (H2: exists x, List.In x (to_list c) /\ Lit.interp rho x = true).
   exists (c.[i]); split; auto; apply to_list_In; auto.
   rewrite <- List.existsb_exists in H2; rewrite H2 in H; auto.
Qed.

 Definition valid rho (d:dimacs) :=
   afold_left _ _ true andb (C_interp_or rho) d.

 Lemma valid_spec : forall rho d,
   valid rho d <->
   (forall i : int, i < length d -> C.interp rho (PArray.to_list (d.[i]))).
 Proof.
   unfold valid; intros rho d; split; intro H.
   intros i Hi; case_eq (C.interp rho (to_list (d .[ i]))); try reflexivity.
   intro Heq; erewrite afold_left_andb_false in H; try eassumption.
   rewrite C_interp_or_spec; auto.
   apply afold_left_andb_true; try assumption; intros i Hi; rewrite C_interp_or_spec; apply H; auto.
 Qed.

 Inductive certif :=
   | Certif : int -> _trace_ step -> clause_id -> certif.

 Definition add_roots s (d:dimacs) :=
   PArray.foldi_right (fun i c s => S.set_clause s i (PArray.to_list c)) d s.

 Definition checker (d:dimacs) (c:certif) :=
   let (nclauses, t, confl_id) := c in
   resolution_checker C.is_false (add_roots (S.make nclauses) d) t confl_id.

 Lemma valid_add_roots : forall rho, Valuation.wf rho ->
    forall d s, valid rho d -> S.valid rho s ->
    S.valid rho (add_roots s d).
 Proof.
   intros rho Hwr d s Hd Hs; unfold add_roots; apply (PArray.foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i Hlt Hv; apply S.valid_set_clause; auto; rewrite valid_spec in Hd; apply Hd; auto.
 Qed.

 Lemma checker_correct : forall d c,
    checker d c = true ->
    forall rho, Valuation.wf rho -> ~valid rho d.
 Proof.
   unfold checker; intros d (nclauses, t, confl_id) Hc rho Hwf Hv.
   apply (resolution_checker_correct Hwf Hc).
   apply valid_add_roots; auto.
   apply S.valid_make; auto.
 Qed.

 Definition interp_var rho x :=
   match compare x 1 with
   | Lt => true
   | Eq => false
   | Gt => rho (x - 1)
     (* This allows to have variable starting at 1 in the interpretation as in dimacs files *)
   end.

 Lemma theorem_checker :
   forall d c,
     checker d c = true ->
     forall rho, ~valid (interp_var rho) d.
 Proof.
  intros d c H rho;apply checker_correct with c;trivial.
  split;compute;trivial;discriminate.
 Qed.

End Sat_Checker.

Module Cnf_Checker.

  Inductive step :=
  | Res (pos:int) (res:resolution)
  | ImmFlatten (pos:int) (cid:clause_id) (lf:_lit)
  | CTrue (pos:int)
  | CFalse (pos:int)
  | BuildDef (pos:int) (l:_lit)
  | BuildDef2 (pos:int) (l:_lit)
  | BuildProj (pos:int) (l:_lit) (i:int)
  | ImmBuildDef (pos:int) (cid:clause_id)
  | ImmBuildDef2 (pos:int) (cid:clause_id)
  | ImmBuildProj (pos:int) (cid:clause_id) (i:int).

  Local Open Scope list_scope.

  Local Notation check_flatten t_form := (check_flatten t_form (fun i1 i2 => i1 == i2) (fun _ _ => false)) (only parsing).

  Definition step_checker t_form s (st:step) :=
    match st with
    | Res pos res => S.set_resolve s pos res
    | ImmFlatten pos cid lf => S.set_clause s pos (check_flatten t_form s cid lf)
    | CTrue pos => S.set_clause s pos Cnf.check_True
    | CFalse pos => S.set_clause s pos Cnf.check_False
    | BuildDef pos l => S.set_clause s pos (check_BuildDef t_form l)
    | BuildDef2 pos l => S.set_clause s pos (check_BuildDef2 t_form l)
    | BuildProj pos l i => S.set_clause s pos (check_BuildProj t_form l i)
    | ImmBuildDef pos cid => S.set_clause s pos (check_ImmBuildDef t_form s cid)
    | ImmBuildDef2 pos cid => S.set_clause s pos (check_ImmBuildDef2 t_form s cid)
    | ImmBuildProj pos cid i => S.set_clause s pos (check_ImmBuildProj t_form s cid i)
    end.

  Lemma step_checker_correct : forall rho t_form,
    Form.check_form t_form ->
    forall s, S.valid (Form.interp_state_var rho t_form) s ->
      forall st : step, S.valid (Form.interp_state_var rho t_form)
        (step_checker t_form s st).
  Proof.
    intros rho t_form Ht s H; destruct (Form.check_form_correct rho _ Ht) as [[Ht1 Ht2] Ht3]; intros [pos res|pos cid lf|pos|pos|pos l|pos l|pos l i|pos cid|pos cid|pos cid i]; simpl; try apply S.valid_set_clause; auto.
    apply S.valid_set_resolve; auto.
    apply valid_check_flatten; auto; try discriminate; intros a1 a2; unfold is_true; rewrite Int31Properties.eqb_spec; intro; subst a1; auto.
    apply valid_check_True; auto.
    apply valid_check_False; auto.
    apply valid_check_BuildDef; auto.
    apply valid_check_BuildDef2; auto.
    apply valid_check_BuildProj; auto.
    apply valid_check_ImmBuildDef; auto.
    apply valid_check_ImmBuildDef2; auto.
    apply valid_check_ImmBuildProj; auto.
  Qed.

  Definition cnf_checker t_form s t :=
    _checker_ (step_checker t_form) s t.

  Lemma cnf_checker_correct : forall rho t_form,
    Form.check_form t_form -> forall s t confl,
      cnf_checker t_form C.is_false s t confl ->
      ~ (S.valid (Form.interp_state_var rho t_form) s).
  Proof.
    unfold cnf_checker; intros rho t_form Ht; apply _checker__correct.
    intros c H; apply C.is_false_correct; auto.
    apply step_checker_correct; auto.
  Qed.

 Inductive certif :=
   | Certif : int -> _trace_ step -> int -> certif.

 Definition checker t_form l (c:certif) :=
   let (nclauses, t, confl) := c in
   Form.check_form t_form &&
   cnf_checker t_form C.is_false (S.set_clause (S.make nclauses) 0 (l::nil)) t confl.

 Lemma checker_correct : forall t_form l c,
    checker t_form l c = true ->
    forall rho, ~ (Lit.interp (Form.interp_state_var rho t_form) l).
 Proof.
   unfold checker; intros t_form l (nclauses, t, confl); unfold is_true; rewrite andb_true_iff; intros [H1 H2] rho H; apply (cnf_checker_correct (rho:=rho) H1 H2); destruct (Form.check_form_correct rho _ H1) as [[Ht1 Ht2] Ht3]; apply S.valid_set_clause; auto.
   apply S.valid_make; auto.
   unfold C.valid; simpl; rewrite H; auto.
 Qed.

 Definition checker_b t_form l (b:bool) (c:certif) :=
   let l := if b then Lit.neg l else l in
   checker t_form l c.

 Lemma checker_b_correct : forall t_var t_form l b c,
    checker_b t_form l b c = true ->
    Lit.interp (Form.interp_state_var (PArray.get t_var) t_form) l = b.
 Proof.
   unfold checker_b; intros t_var t_form l b c; case b; case_eq (Lit.interp (Form.interp_state_var (get t_var) t_form) l); auto; intros H1 H2; elim (checker_correct H2 (rho:=get t_var)); auto; rewrite Lit.interp_neg, H1; auto.
 Qed.

 Definition checker_eq t_form l1 l2 l (c:certif) :=
   negb (Lit.is_pos l) &&
   match t_form.[Lit.blit l] with
   | Form.Fiff l1' l2' => (l1 == l1') && (l2 == l2')
   | _ => false
   end &&
   checker t_form l c.

 Lemma checker_eq_correct : forall t_var t_form l1 l2 l c,
   checker_eq t_form l1 l2 l c = true ->
    Lit.interp (Form.interp_state_var (PArray.get t_var) t_form) l1 =
    Lit.interp (Form.interp_state_var (PArray.get t_var) t_form) l2.
 Proof.
   unfold checker_eq; intros t_var t_form l1 l2 l c; rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int31Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form).
   unfold checker in H3; destruct c as (nclauses, t, confl); rewrite andb_true_iff in H3; destruct H3 as [H3 _]; destruct (Form.check_form_correct (get t_var) _ H3) as [[Ht1 Ht2] Ht3]; split; auto.
   destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (get t_var) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (get t_var) t_form) l2); intro Heq2; auto; elim (checker_correct H3 (rho:=get t_var)); unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto.
 Qed.

End Cnf_Checker.

(* Application to resolution + cnf justification + euf + lia *)

(* Require Cnf.Cnf. *)
(* Require Euf.Euf. *)
(* Require Lia.Lia. *)

Module Euf_Checker.

  Inductive step :=
  | Res (pos:int) (res:resolution)
  | ImmFlatten (pos:int) (cid:clause_id) (lf:_lit)
  | CTrue (pos:int)
  | CFalse (pos:int)
  | BuildDef (pos:int) (l:_lit)
  | BuildDef2 (pos:int) (l:_lit)
  | BuildProj (pos:int) (l:_lit) (i:int)
  | ImmBuildDef (pos:int) (cid:clause_id)
  | ImmBuildDef2 (pos:int) (cid:clause_id)
  | ImmBuildProj (pos:int) (cid:clause_id) (i:int)
  | EqTr (pos:int) (l:_lit) (fl: list _lit)
  | EqCgr (pos:int) (l:_lit) (fl: list (option _lit))
  | EqCgrP (pos:int) (l1:_lit) (l2:_lit) (fl: list (option _lit))
  | LiaMicromega (pos:int) (cl:list _lit) (c:list ZMicromega.ZArithProof)
  | LiaDiseq (pos:int) (l:_lit)
  | SplArith (pos:int) (orig:clause_id) (res:_lit) (l:list ZMicromega.ZArithProof)
  | SplDistinctElim (pos:int) (orig:clause_id) (res:_lit).

  Local Open Scope list_scope.

  Local Notation check_flatten t_atom t_form := (check_flatten t_form (check_hatom t_atom) (check_neg_hatom t_atom)) (only parsing).

  Definition step_checker t_atom t_form s (st:step) :=
    match st with
      | Res pos res => S.set_resolve s pos res
      | ImmFlatten pos cid lf => S.set_clause s pos (check_flatten t_atom t_form s cid lf)
      | CTrue pos => S.set_clause s pos Cnf.check_True
      | CFalse pos => S.set_clause s pos Cnf.check_False
      | BuildDef pos l => S.set_clause s pos (check_BuildDef t_form l)
      | BuildDef2 pos l => S.set_clause s pos (check_BuildDef2 t_form l)
      | BuildProj pos l i => S.set_clause s pos (check_BuildProj t_form l i)
      | ImmBuildDef pos cid => S.set_clause s pos (check_ImmBuildDef t_form s cid)
      | ImmBuildDef2 pos cid => S.set_clause s pos (check_ImmBuildDef2 t_form s cid)
      | ImmBuildProj pos cid i => S.set_clause s pos (check_ImmBuildProj t_form s cid i)
      | EqTr pos l fl => S.set_clause s pos (check_trans t_form t_atom l fl)
      | EqCgr pos l fl => S.set_clause s pos (check_congr t_form t_atom l fl)
      | EqCgrP pos l1 l2 fl => S.set_clause s pos (check_congr_pred t_form t_atom l1 l2 fl)
      | LiaMicromega pos cl c => S.set_clause s pos (check_micromega t_form t_atom cl c)
      | LiaDiseq pos l => S.set_clause s pos (check_diseq t_form t_atom l)
      | SplArith pos orig res l => S.set_clause s pos (check_spl_arith t_form t_atom (S.get s orig) res l)
      | SplDistinctElim pos orig res => S.set_clause s pos (check_distinct_elim t_form t_atom (S.get s orig) res)
    end.

  Lemma step_checker_correct : forall t_i t_func t_atom t_form,
    let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form in
      Form.check_form t_form -> Atom.check_atom t_atom ->
      Atom.wt t_i t_func t_atom ->
      forall s, S.valid rho s ->
        forall st : step, S.valid rho (step_checker t_atom t_form s st).
  Proof.
    intros t_i t_func t_atom t_form rho H1 H2 H10 s Hs. destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [[Ht1 Ht2] Ht3]. destruct (Atom.check_atom_correct _ H2) as [Ha1 Ha2]. intros [pos res|pos cid lf|pos|pos|pos l|pos l|pos l i|pos cid|pos cid|pos cid i|pos l fl|pos l fl|pos l1 l2 fl|pos cl c|pos l|pos orig res l|pos orig res]; simpl; try apply S.valid_set_clause; auto.
    apply S.valid_set_resolve; auto.
    apply valid_check_flatten; auto; intros h1 h2 H.
    rewrite (Syntactic.check_hatom_correct_bool _ _ _ Ha1 Ha2 _ _ H); auto.
    rewrite (Syntactic.check_neg_hatom_correct_bool _ _ _ H10 Ha1 Ha2 _ _ H); auto.
    apply valid_check_True; auto.
    apply valid_check_False; auto.
    apply valid_check_BuildDef; auto.
    apply valid_check_BuildDef2; auto.
    apply valid_check_BuildProj; auto.
    apply valid_check_ImmBuildDef; auto.
    apply valid_check_ImmBuildDef2; auto.
    apply valid_check_ImmBuildProj; auto.
    apply valid_check_trans; auto.
    apply valid_check_congr; auto.
    apply valid_check_congr_pred; auto.
    apply valid_check_micromega; auto.
    apply valid_check_diseq; auto.
    apply valid_check_spl_arith; auto.
    apply valid_check_distinct_elim; auto.
  Qed.

  Definition euf_checker t_atom t_form s t :=
    _checker_ (step_checker t_atom t_form) s t.

  Lemma euf_checker_correct : forall t_i t_func t_atom t_form,
    let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form in
      Form.check_form t_form -> Atom.check_atom t_atom ->
      Atom.wt t_i t_func t_atom ->
      forall s t confl,
        euf_checker t_atom t_form C.is_false s t confl ->
        ~ (S.valid rho s).
  Proof.
    unfold euf_checker; intros t_i t_func t_atom t_form rho H1 H2 H10; apply _checker__correct.
    intros c H; apply C.is_false_correct; auto.
    apply step_checker_correct; auto.
  Qed.

  Inductive certif :=
  | Certif : int -> _trace_ step -> int -> certif.

  Definition add_roots s d used_roots :=
    match used_roots with
      | Some ur => PArray.foldi_right (fun i c_index s =>
        let c := if c_index < length d then (d.[c_index])::nil else C._true in
          S.set_clause s i c) ur s
      | None => PArray.foldi_right (fun i c s => S.set_clause s i (c::nil)) d s
    end.

  Definition valid t_i t_func t_atom t_form d :=
    let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form in
    afold_left _ _ true andb (Lit.interp rho) d.

  Lemma add_roots_correct : forall t_i t_func t_atom t_form,
    let rho := Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form in
      Form.check_form t_form -> Atom.check_atom t_atom ->
      Atom.wt t_i t_func t_atom ->
      forall s d used_roots, S.valid rho s -> valid t_func t_atom t_form d ->
        S.valid rho (add_roots s d used_roots).
  Proof.
    intros t_i t_func t_atom t_form rho H1 H2 H10 s d used_roots H3; unfold valid; intro H4; pose (H5 := (afold_left_andb_true_inv _ _ _ H4)); unfold add_roots; assert (Valuation.wf rho) by (destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H]; auto); case used_roots.
    intro ur; apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; case_eq (ur .[ i] < length d).
    intro; unfold C.valid; simpl; rewrite H5; auto.
    intros; apply C.interp_true; auto.
    apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; unfold C.valid; simpl; rewrite H5; auto.
  Qed.

  Definition checker t_i t_func t_atom t_form d used_roots (c:certif) :=
    let (nclauses, t, confl) := c in
    Form.check_form t_form && Atom.check_atom t_atom &&
    Atom.wt t_i t_func t_atom &&
    euf_checker t_atom t_form C.is_false (add_roots (S.make nclauses) d used_roots) t confl.
  Implicit Arguments checker [].

  Lemma checker_correct : forall t_i t_func t_atom t_form d used_roots c,
    checker t_i t_func t_atom t_form d used_roots c = true ->
    ~ valid t_func t_atom t_form d.
  Proof.
    unfold checker; intros t_i t_func t_atom t_form d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[[H1 H2] H10] H3] H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H4]; auto.
  Qed.

  Definition checker_b t_i t_func t_atom t_form l (b:bool) (c:certif) :=
    let l := if b then Lit.neg l else l in
    let (nclauses,_,_) := c in
    checker t_i t_func t_atom t_form (PArray.make nclauses l) None c.

  Lemma checker_b_correct : forall t_i t_func t_atom t_form l b c,
    checker_b t_func t_atom t_form l b c = true ->
    Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l = b.
  Proof.
   unfold checker_b; intros t_i t_func t_atom t_form l b (nclauses, t, confl); case b; intros H2; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l); auto; intros H1; elim (checker_correct H2 (t_func:=t_func)); auto; unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; auto; rewrite Lit.interp_neg, H1; auto.
 Qed.

  Definition checker_eq t_i t_func t_atom t_form l1 l2 l (c:certif) :=
    negb (Lit.is_pos l) &&
    match t_form.[Lit.blit l] with
      | Form.Fiff l1' l2' => (l1 == l1') && (l2 == l2')
      | _ => false
    end &&
    let (nclauses,_,_) := c in
    checker t_i t_func t_atom t_form (PArray.make nclauses l) None c.

  Lemma checker_eq_correct : forall t_i t_func t_atom t_form l1 l2 l c,
    checker_eq t_func t_atom t_form l1 l2 l c = true ->
    Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l1 =
    Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l2.
  Proof.
   unfold checker_eq; intros t_i t_func t_atom t_form l1 l2 l (nclauses, t, confl); rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int31Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form).
   unfold checker in H3; rewrite !andb_true_iff in H3; destruct H3 as [[[H3 _] _] _]; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H3) as [[Ht1 Ht2] Ht3]; split; auto.
   destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) t_form) l2); intro Heq2; auto; elim (checker_correct H3 (t_func:=t_func)); unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto.
 Qed.

  (* For debugging *)
  (*
  Fixpoint is__true (c:C.t) :=
    match c with
      | cons l q => if (l == 0) then true else is__true q
      | _ => false
    end.

  Definition step_checker_debug t_atom t_form s (st:step) :=
    match st with
      | Res pos res =>
        let s' := S.set_resolve s pos res in
          if is__true (s'.[pos]) then None else Some s'
      | ImmFlatten pos cid lf =>
        let c := check_flatten t_atom t_form s cid lf in
          if is__true c then None else Some (S.set_clause s pos c)
      | CTrue pos => Some (S.set_clause s pos Cnf.check_True)
      | CFalse pos => Some (S.set_clause s pos Cnf.check_False)
      | BuildDef pos l =>
        let c := check_BuildDef t_form l in
          if is__true c then None else Some (S.set_clause s pos c)
      | BuildDef2 pos l =>
        let c := check_BuildDef2 t_form l in
          if is__true c then None else Some (S.set_clause s pos c)
      | BuildProj pos l i =>
        let c := check_BuildProj t_form l i in
          if is__true c then None else Some (S.set_clause s pos c)
      | ImmBuildDef pos cid =>
        let c := check_ImmBuildDef t_form s cid in
          if is__true c then None else Some (S.set_clause s pos c)
      | ImmBuildDef2 pos cid =>
        let c := check_ImmBuildDef2 t_form s cid in
          if is__true c then None else Some (S.set_clause s pos c)
      | ImmBuildProj pos cid i =>
        let c := check_ImmBuildProj t_form s cid i in
          if is__true c then None else Some (S.set_clause s pos c)
      | EqTr pos l fl =>
        let c := check_trans t_form t_atom l fl in
          if is__true c then None else Some (S.set_clause s pos c)
      | EqCgr pos l fl =>
        let c := check_congr t_form t_atom l fl in
          if is__true c then None else Some (S.set_clause s pos c)
      | EqCgrP pos l1 l2 fl =>
        let c := check_congr_pred t_form t_atom l1 l2 fl in
          if is__true c then None else Some (S.set_clause s pos c)
      | LiaMicromega pos cl c =>
        let c := check_micromega t_form t_atom cl c in
          if is__true c then None else Some (S.set_clause s pos c)
      | LiaDiseq pos l =>
        let c := check_diseq t_form t_atom l in
          if is__true c then None else Some (S.set_clause s pos c)
      | SplArith pos orig res l =>
        let c := check_spl_arith t_form t_atom (S.get s orig) res l in
          if is__true c then None else Some (S.set_clause s pos c)
      | SplDistinctElim pos input res =>
        let c := check_distinct_elim t_form t_atom (S.get s input) res in
          if is__true c then None else Some (S.set_clause s pos c)
    end.

  Definition euf_checker_debug t_atom t_form s t :=
    _checker_debug_ (step_checker_debug t_atom t_form) s t.

  Definition euf_checker_partial t_atom t_form s t :=
    _checker_partial_ (step_checker t_atom t_form) s t.
  *)

End Euf_Checker.

Unset Implicit Arguments.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal21.

Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj1eqsynthconj4 : forall  (lv0 : lst), (@eq lst (lv0) (append lv0 Nil)).
Admitted.
QuickChick conj1eqsynthconj4.


(** * Definition of the generic part of the interface of the correctness proof of the CFG parser *)

Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.GenericBaseTypes.
Require Import Fiat.Parsers.BaseTypes.

Set Implicit Arguments.

Section correctness.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {predata : @parser_computational_predataT Char}
          {gendata : @generic_parser_dataT Char}.

  Class generic_parser_decidable_data {gendata : @generic_parser_dataT Char} :=
    {
      parse_nt_T_to_bool : parse_nt_T -> bool;
      parse_item_T_to_bool : parse_item_T -> bool;
      parse_production_T_to_bool : parse_production_T -> bool;
      parse_productions_T_to_bool : parse_productions_T -> bool
    }.

  Class generic_parser_decidable_correctness_data {gendata : @generic_parser_dataT Char} {gddata : generic_parser_decidable_data} :=
    {
      ret_Terminal_true_to_bool
      : forall ch, parse_item_T_to_bool (ret_Terminal_true ch) = true;
      ret_Terminal_false_to_bool
      : forall ch, parse_item_T_to_bool (ret_Terminal_false ch) = false;
      ret_NonTerminal_true_to_bool
      : forall nt rv, parse_item_T_to_bool (ret_NonTerminal_true nt rv) = parse_nt_T_to_bool rv;
      ret_NonTerminal_false_to_bool
      : forall nt, parse_item_T_to_bool (ret_NonTerminal_false nt) = false;
      ret_production_nil_true_to_bool
      : parse_production_T_to_bool ret_production_nil_true = true;
      ret_production_nil_false_to_bool
      : parse_production_T_to_bool ret_production_nil_false = false;
      ret_orb_production_base_to_bool
      : parse_production_T_to_bool ret_orb_production_base = false;
      ret_orb_production_to_bool
      : forall rv1 rv2, parse_production_T_to_bool (ret_orb_production rv1 rv2)
                        = orb (parse_production_T_to_bool rv1) (parse_production_T_to_bool rv2);
      ret_production_cons_to_bool
      : forall rv1 rv2, parse_production_T_to_bool (ret_production_cons rv1 rv2)
                        = andb (parse_item_T_to_bool rv1) (parse_production_T_to_bool rv2);
      ret_orb_productions_base_to_bool
      : parse_productions_T_to_bool ret_orb_productions_base = false;
      ret_orb_productions_to_bool
      : forall rv1 rv2, parse_productions_T_to_bool (ret_orb_productions rv1 rv2)
                        = orb (parse_production_T_to_bool rv1) (parse_productions_T_to_bool rv2);
      ret_nt_to_bool
      : forall nt v, parse_nt_T_to_bool (ret_nt nt v) = parse_productions_T_to_bool v;
      ret_nt_invalid_to_bool
      : parse_nt_T_to_bool ret_nt_invalid = false
    }.
End correctness.

Create HintDb generic_parser_decidable_correctness discriminated.
#[global]
Hint Rewrite @ret_Terminal_true_to_bool @ret_Terminal_false_to_bool @ret_NonTerminal_true_to_bool @ret_NonTerminal_false_to_bool @ret_production_nil_true_to_bool @ret_production_nil_false_to_bool @ret_orb_production_base_to_bool @ret_orb_production_to_bool @ret_production_cons_to_bool @ret_orb_productions_base_to_bool @ret_orb_productions_to_bool @ret_nt_to_bool @ret_nt_invalid_to_bool : generic_parser_decidable_correctness.

Lemma fold_right_ret_orb_production_eq
      {Char}
      {gendata : @generic_parser_dataT Char}
      {gddata : generic_parser_decidable_data}
      {gdcdata : generic_parser_decidable_correctness_data}
      ls b
  : parse_production_T_to_bool (List.fold_right ret_orb_production b ls)
    = List.fold_right orb (parse_production_T_to_bool b) (List.map parse_production_T_to_bool ls).
Proof.
  revert b; induction ls as [|?? IHls]; simpl; trivial; intros; [].
  rewrite <- IHls; clear IHls.
  autorewrite with generic_parser_decidable_correctness; trivial.
Qed.

Lemma fold_right_ret_orb_productions_eq
      {Char}
      {gendata : @generic_parser_dataT Char}
      {gddata : generic_parser_decidable_data}
      {gdcdata : generic_parser_decidable_correctness_data}
      ls b
  : parse_productions_T_to_bool (List.fold_right ret_orb_productions b ls)
    = List.fold_right orb (parse_productions_T_to_bool b) (List.map parse_production_T_to_bool ls).
Proof.
  revert b; induction ls as [|?? IHls]; simpl; trivial; intros; [].
  rewrite <- IHls; clear IHls.
  autorewrite with generic_parser_decidable_correctness; trivial.
Qed.

#[global]
Hint Rewrite @fold_right_ret_orb_production_eq @fold_right_ret_orb_productions_eq : generic_parser_decidable_correctness.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Bool String List ZArith.
Import ListNotations.
Open Scope string.
Open Scope list.
From coqutil Require Import Map.Interface.
From Utils Require Import Utils Natlike ExtraMaps Monad RelationalDB.
Import Sets.
From Utils Require ArrayList UnionFind.
From Named Require Import Term Rule Core.
From Named.egraph Require Import Defs.
Import StateMonad.

Section __.
  Context {idx : Type}
          `{Natlike idx}
          {array : Type -> Type}
          `{ArrayList.ArrayList idx array}.

  Notation named_list := (@named_list idx).
  Notation named_map := (@named_map idx).
  Notation term := (@term idx).
  Notation ctx := (@ctx idx).
  Notation sort := (@sort idx).
  Notation subst := (@subst idx).
  Notation rule := (@rule idx).
  Notation lang := (@lang idx).

  Notation union_find := (@UnionFind.union_find idx array).

  (*TODO: gather all contexts from (& in) Defs.v*)
  Context (eclass_map : map.map idx eclass).

  Notation egraph := (egraph (array:=array) eclass_map).
  Notation empty_egraph := (empty_egraph eclass_map).
  Notation find := (find (eclass_map := eclass_map)).

  Context (idx_set : set idx).
  Context (eqn_set : set (idx*idx)).

  (*Parameterize by query trie since the inductive can't be defined generically *)
  Context (query_trie : Type)
          (qt_unconstrained : query_trie -> query_trie)
          (trie_map : map.map idx query_trie)
          (qt_tree : trie_map -> query_trie)
          (values_of_next_var : query_trie -> set_with_top idx_set)
          (choose_next_val : idx -> query_trie -> query_trie).
  Context (relation : set (list idx))
          (db : map.map idx relation)
          (arg_map : map.map idx idx).

  Section WithLang.

    Context (l : lang).

    Notation check_ctx' :=
      (check_ctx' (idx:=idx) (array := array)
                  eclass_map eqn_set l
                  qt_unconstrained _ qt_tree
                  values_of_next_var choose_next_val relation db arg_map).

    Notation check_ctx :=
      (check_ctx (idx:=idx) (array := array)
                 eclass_map eqn_set l
                 qt_unconstrained _ qt_tree
                 values_of_next_var choose_next_val relation db arg_map).

    Notation add_and_check_ctx_cons :=
      (add_and_check_ctx_cons eqn_set l qt_unconstrained trie_map qt_tree values_of_next_var choose_next_val relation db arg_map).

    Notation Checker :=
      (Checker eclass_map eqn_set).

    Notation equality_saturation :=
      (equality_saturation l qt_unconstrained trie_map qt_tree values_of_next_var choose_next_val relation db
       arg_map).

    Notation resolve_checker' :=
      (resolve_checker' l qt_unconstrained trie_map qt_tree values_of_next_var choose_next_val relation db arg_map).

    (*possibly poor naming*)
    Definition principal_sort c e : option sort :=
      match e with
      | var x => named_list_lookup_err c x
      | con n s =>
          @! let (term_rule c' _ t) <?- named_list_lookup_err l n in
             ret t[/with_names_from c' s/]
      end.

    (*TODO: what's the best way to define this?
      In terms of find or in parallel?
      TODO: Move to UnionFind.v
     *)
    Definition union_find_equivalence uf a b :=
      snd (UnionFind.find uf a) = snd (UnionFind.find uf b).

    Inductive term_in_egraph_at_index (g : egraph) i : term -> Prop :=
    | var_in_egraph v
      : map.get g.(hashcons) (var_node v) = Some i ->
        term_in_egraph_at_index g i (var v)
    | con_in_egraph n s s_i
      : Forall2 (term_in_egraph_at_index g) s_i s ->
        (*TODO: handle s_i up to uf_equiv? *)
        map.get g.(hashcons) (con_node n s_i) = Some i ->
        term_in_egraph_at_index g i (con n s).

    Variant sort_in_egraph_at_index (g : egraph) i : sort -> Prop :=
    | scon_in_egraph n s s_i
      : Forall2 (term_in_egraph_at_index g) s_i s ->
        (*TODO: handle s_i up to uf_equiv? *)
        map.get g.(hashcons) (con_node n s_i) = Some i ->
        sort_in_egraph_at_index g i (scon n s).

    Definition is_ctx_of_egraph (g : egraph) (c : ctx) : Prop :=
      Forall2 (fun '(x1,i) '(x2,t) => x1 = x2 /\ sort_in_egraph_at_index g i t)
              g.(ectx) c.

    Section WithCtx.
      Context (wfl : wf_lang l)
              (c : ctx)
              (wfc : wf_ctx l c).

      Definition wf_egraph g (wf_ids : list idx) :=
        all (fun x => In x wf_ids) (map snd g.(ectx))
        /\ is_ctx_of_egraph g c
        /\ (forall t1 t2 i,
               sort_in_egraph_at_index g i t1 ->
               sort_in_egraph_at_index g i t2 ->
               In i wf_ids ->
               eq_sort l c t1 t2)
        /\ (forall e1 e2 t i,
               term_in_egraph_at_index g i e1 ->
               term_in_egraph_at_index g i e2 ->
               In i wf_ids ->
               (*TODO: does it matter whether the sort is in the egraph?*)
               principal_sort c e1 = Some t ->
               eq_term l c t e1 e2).

      Lemma wf_egraph_sort_wf g wf_ids t i
        : wf_egraph g wf_ids ->
          sort_in_egraph_at_index g i t ->
          In i wf_ids ->
          wf_sort l c t.
      Proof.
        unfold wf_egraph.
        basic_goal_prep.
        eapply eq_sort_wf_l; eauto.
      Qed.

      Lemma wf_egraph_term_wf g wf_ids e t i
        : wf_egraph g wf_ids ->
          term_in_egraph_at_index g i e ->
          In i wf_ids ->
          (*TODO: does it matter whether the sort is in the egraph?*)
          principal_sort c e = Some t ->
          wf_term l c e t.
      Proof.
        unfold wf_egraph.
        basic_goal_prep.
        eapply eq_term_wf_l; eauto.
      Qed.

      (*TODO: allow context extension?*)
      Definition egraph_extends g1 g2 :=
        (forall e i, term_in_egraph_at_index g1 i e ->
                     term_in_egraph_at_index g2 i e)
        /\ (forall t i, sort_in_egraph_at_index g1 i t ->
                        sort_in_egraph_at_index g2 i t)
        /\ (forall i j, union_find_equivalence g1.(id_equiv) i j ->
                        union_find_equivalence g2.(id_equiv) i j).

      Lemma egraph_extends_refl g : egraph_extends g g.
      Proof.
        unfold egraph_extends; intuition.
      Qed.

    End WithCtx.

    Lemma empty_egraph_is_wf : wf_egraph [] empty_egraph [].
    Proof.
      unfold wf_egraph, is_ctx_of_egraph; basic_goal_prep; basic_utils_crush.
    Qed.

    Definition indexed_terms_related c g i1 i2 :=
      (forall t1 t2,
          sort_in_egraph_at_index g i1 t1 ->
          sort_in_egraph_at_index g i2 t2 ->
          eq_sort l c t1 t2)
      /\ (forall e1 e2 t,
             term_in_egraph_at_index g i1 e1 ->
             term_in_egraph_at_index g i2 e2 ->
             (*TODO: does it matter whether the sort is in the egraph?*)
             principal_sort c e1 = Some t ->
             eq_term l c t e1 e2).

    Definition up_to_checking {A} P (ch : Checker A) c
      := forall g g' a eqns, ch g = (g', Some (a,eqns)) ->
                            (forall i j, member eqns (i,j) = true ->
                                         indexed_terms_related c g i j) ->
                     P g' a.

    Lemma equality_saturation_sound {A} upd pred base fuel g g' (a:A) c good_ids
      : (g', a) = equality_saturation upd pred base fuel g ->
        wf_egraph c g good_ids ->
        egraph_extends g g'
        /\ wf_egraph c g' good_ids.
    Proof.
      revert g g' a base.
      induction fuel; basic_goal_prep.
      {
        basic_utils_crush.
        eapply egraph_extends_refl.
      }
      {
        revert H1; case_match.
        {
          basic_utils_crush.
          eapply egraph_extends_refl.
        }
        {
          TODO: db reasoning

    Qed.

    Lemma resolve_checker'_sound {A} g fuel ch g' (a : A) P c
      : (g', Some a) = resolve_checker' ch fuel g ->
        up_to_checking P ch c ->
        P g' a.
    Proof.
      unfold resolve_checker'.
      simpl.
      case_match.
      case_match; [| cbv; congruence].
      destruct p.
      case_match.
      case_match; [| cbv; congruence].
      intro H'; inversion H'; subst; clear H'.

      case_match.

    Qed.

    Lemma add_and_check_ctx_cons_sound i t c g g' good_ids
      : (g',true) = add_and_check_ctx_cons i t g ->
        wf_egraph c g good_ids ->
        fresh i c ->
        exists good_ids',
          wf_egraph ((i,t)::c) g' (good_ids'++good_ids).
    Proof.
      unfold add_and_check_ctx_cons.

      case_match.
      [| cbv; congruence].
      case
    Qed.

    Lemma check_ctx'_sound c g
      : check_ctx' c = Some g -> exists good_ids, wf_egraph c g good_ids.
      revert g.
      induction c; basic_goal_prep; basic_utils_crush.
      { eexists;now eapply empty_egraph_is_wf. }
      {
        revert H1.
        case_match; [| cbv; congruence].
        symmetry in HeqH1; apply use_compute_fresh in HeqH1.
        case_match; [| cbv; congruence].
        specialize (IHc e eq_refl); destruct IHc.
        case_match.
        destruct b; [| cbv; congruence].
        basic_goal_prep; basic_utils_crush.
        eapply add_and_check_ctx_cons_sound in HeqH2; eauto.
        destruct HeqH2; eexists; eauto.
      }
    Qed.

    Abort.

    (*TODO: do I want a lookup_term function in defs?*)

    (*Properties I expect to hold:*)

    Lemma check_ctx'_sound c g
      : check_ctx' c = Some g -> wf_egraph g.
    Abort.

    Theorem check_ctx_sound c
      : check_ctx c = true -> wf_ctx l c.
    Abort.

    Lemma find_idempotent
      : find i1 g1 = (g2,i2) ->
        find i2 g2 = (g2,i2).
    Abort.

    (*Possibly useful definitions*)

    (*possibly poor naming*)
    Definition principal_sort l c e : option sort :=
      match e with
      | var x => named_list_lookup_err c x
      | con n s =>
          @! let (term_rule c' _ t) <?- named_list_lookup_err l n in
             ret t[/with_names_from c' s/]
      end.