Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Common.Types.
Require Import Common.Bisimulation.
Require Import Common.AllDiff.
Require Import Bag.Bag2.
Require Import FwOF.FwOFSignatures.
Require FwOF.FwOFWellFormednessLemmas.

Local Open Scope list_scope.
Local Open Scope bag_scope.

Module Make (Import RelationDefinitions : RELATION_DEFINITIONS) <: RELATION.

  Module RelationDefinitions := RelationDefinitions.
  Import AtomsAndController.
  Import Machine.
  Import Atoms.
  Module Import Lemmas := FwOF.FwOFWellFormednessLemmas.Make (RelationDefinitions).

  Hint Resolve OfLinksHaveSrc_pres1 OfLinksHaveSrc_pres2 OfLinksHaveSrc_pres3.
  Hint Unfold UniqSwIds.
  Hint Resolve P_entails_FlowTablesSafe step_preserves_P.
  Hint Resolve DevicesFromTopo_pres0 DevicesFromTopo_pres1 SwitchesHaveOpenFlowLinks_pres0
       SwitchesHaveOpenFlowLinks_pres1.
  Hint Resolve LinksHaveSrc_untouched.
  Hint Resolve LinksHaveDst_untouched.
  Hint Resolve FlowTablesSafe_untouched.
  Hint Resolve UniqSwIds_pres.
  Hint Resolve FlowTablesSafe_PacketOut.
  Hint Resolve AllDiff_preservation.
  Hint Resolve NoBarriersInCtrlm_preservation.

  Ltac sauto := solve[eauto with datatypes].

  Lemma simpl_step : forall (st1 st2 : state) obs
    (tblsOk1 : FlowTablesSafe (switches st1))
    (linksTopoOk1 : ConsistentDataLinks (links st1))
    (haveSrc1 : LinksHaveSrc (switches st1) (links st1))
    (haveDst1 : LinksHaveDst (switches st1) (links st1))
    (uniqSwIds1 : UniqSwIds (switches st1))
    (P0 : P (switches st1) (ofLinks st1) (ctrl st1))
    (uniqOfLinkIds1 : AllDiff of_to (ofLinks st1))
    (ofLinksHaveSw1 : OFLinksHaveSw (switches st1) (ofLinks st1))
    (devsFromTopo1 : DevicesFromTopo st1)
    (swsHaveOFLinks1 : SwitchesHaveOpenFlowLinks (switches st1) (ofLinks st1))
    (noBarriersInCtrlm1 : NoBarriersInCtrlm (switches st1)),
    step st1 obs st2 ->
    exists tblsOk2 linksTopoOk2 haveSrc2 haveDst2 uniqSwIds2 P1
           uniqOfLinkIds2 ofLinksHaveSw2 devsFromTopo2 swsHaveOFLinks2
           noBarriersInCtrlm2,
      concreteStep
        (ConcreteState st1 tblsOk1 linksTopoOk1 haveSrc1 haveDst1 uniqSwIds1
                       P0 uniqOfLinkIds1 ofLinksHaveSw1 devsFromTopo1
                       swsHaveOFLinks1 noBarriersInCtrlm1)
        obs
        (ConcreteState st2 tblsOk2 linksTopoOk2 haveSrc2 haveDst2 uniqSwIds2
                       P1 uniqOfLinkIds2 ofLinksHaveSw2 devsFromTopo2
                       swsHaveOFLinks2 noBarriersInCtrlm2).
  Proof with simpl;eauto with datatypes.
    intros.
    unfold concreteStep.
    simpl.
    { inversion H; subst; simpl in *.
      (* Case 1. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 2: processed a buffered FlowMod *)
      + eexists.
        unfold FlowTablesSafe.
        intros.
        apply Bag.in_union in H0. simpl in H0.
        { destruct H0 as [[HIn | HContra] | HIn];
          [idtac | solve[inversion HContra] | idtac].
          (* interesting case, where the flow table has been modified *)
          - inversion HIn; subst; clear HIn.
            assert (FlowModSafe swId1 tbl0 (({|FlowMod fm|}) <+> ctrlm1)) as J.
            { unfold FlowTablesSafe in tblsOk1.
              eapply tblsOk1.
              apply Bag.in_union. left. simpl... }
            inversion J; subst.
            * assert (NotFlowMod (FlowMod fm)) as Hcontra.
              { apply H0. apply Bag.in_union; simpl... }
              inversion Hcontra.
            * assert (FlowMod fm = FlowMod f /\ ctrlm1 = ctrlm0) as HEq.
              { eapply Bag.singleton_union_disjoint.
                apply Bag.union_from_ordered in H0...
                intros.
                assert (NotFlowMod (FlowMod fm)) as X...
                inversion X. }
              destruct HEq as [HEq HEq0].
              inversion HEq; subst...
              apply NoFlowModsInBuffer...
          - unfold FlowTablesSafe in tblsOk1.
            eapply tblsOk1.
            apply Bag.in_union... }
        eexists...
        eexists...
        eexists...
        eexists...
        eexists...
        eexists...
        eexists...
        eexists. sauto.
        eexists. sauto.
        eexists.
        { unfold NoBarriersInCtrlm in *.
          intros.
          apply Bag.in_union in H0; simpl in H0.
          destruct H0 as [[H0|H0]|H0].
          + refine (noBarriersInCtrlm1 (Switch swId0 pts0 tbl0 inp0 outp0 (({|FlowMod fm|}) <+> ctrlm0) switchm0) _ _ _).
            - apply Bag.in_union. simpl...
            - apply Bag.in_union.
              rewrite <- H0 in H1.
              simpl in H1.
              right...
          + inversion H0.
          + refine (noBarriersInCtrlm1 sw _ _ _)...
            apply Bag.in_union... }
        sauto.
      (* Case 4. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { unfold NoBarriersInCtrlm in *.
          intros.
          apply Bag.in_union in H0; simpl in H0.
          destruct H0 as [[H0|H0]|H0].
          + refine (noBarriersInCtrlm1 (Switch swId0 pts0 tbl0 inp0 outp0 (({|PacketOut pt pk|}) <+> ctrlm0) switchm0) _ _ _).
            - apply Bag.in_union. simpl...
            - apply Bag.in_union.
              rewrite <- H0 in H1.
              simpl in H1.
              right...
          + inversion H0.
          + refine (noBarriersInCtrlm1 sw _ _ _)...
            apply Bag.in_union... }
        sauto.
      (* Case 5. *)
      + eexists. sauto.
        exists (LinkTopoOK_inv pks0 (pk::pks0) linksTopoOk1).
        exists (LinksHaveSrc_inv pks0 (pk::pks0) (LinksHaveSrc_untouched haveSrc1)).
        exists (LinksHaveDst_inv pks0 (pk::pks0) (LinksHaveDst_untouched haveDst1)).
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 6. *)
      + eexists. sauto.
        exists (LinkTopoOK_inv (pks0 ++ [pk]) pks0 linksTopoOk1).
        exists
          (LinksHaveSrc_inv (pks0 ++ [pk]) pks0 (LinksHaveSrc_untouched haveSrc1)).
        exists
          (LinksHaveDst_inv (pks0 ++ [pk]) pks0 (LinksHaveDst_untouched haveDst1)).
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 7. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 8. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { eapply AllDiff_preservation.
          exact uniqOfLinkIds1.
          do 2 rewrite -> map_app... }
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 9. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { eapply AllDiff_preservation.
          exact uniqOfLinkIds1.
          do 2 rewrite -> map_app... }
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 10. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { eapply AllDiff_preservation.
          exact uniqOfLinkIds1.
          do 2 rewrite -> map_app... }
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      (* Case 11. *)
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { eapply AllDiff_preservation.
          exact uniqOfLinkIds1.
          do 2 rewrite -> map_app... }
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        sauto.
      + eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { eapply AllDiff_preservation.
          exact uniqOfLinkIds1.
          do 2 rewrite -> map_app... }
        eexists. sauto.
        eexists. sauto.
        eexists. sauto.
        eexists.
        { unfold NoBarriersInCtrlm in *.
          intros.
          apply Bag.in_union in H1; simpl in H1.
          destruct H1 as [[H1|H1]|H1].
          + rewrite <- H1 in H2.
            simpl in H2.
            apply Bag.in_union in H2. simpl in H2.
            destruct H2 as [[H2|H2]|H2].
            * subst. exact H0.
            * inversion H2.
            * refine (noBarriersInCtrlm1 (Switch swId0 pts0 tbl0 inp0 outp0 ctrlm0 switchm0) _ _ _).
              apply Bag.in_union. simpl...
              simpl...
          + inversion H1.
          + refine (noBarriersInCtrlm1 sw _ _ _)...
            apply Bag.in_union... }
        sauto.
    (* epic fail of a proof script *)
    Grab Existential Variables.
    eauto. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto. eauto. eauto. eauto. eauto. eauto.
    eauto. eauto.
    }
  Qed.

  Lemma simpl_multistep' : forall (st1 st2 : state) obs
    (tblsOk1 : FlowTablesSafe (switches st1))
    (linksTopoOk1 : ConsistentDataLinks (links st1))
    (haveSrc1 : LinksHaveSrc (switches st1) (links st1))
    (haveDst1 : LinksHaveDst (switches st1) (links st1))
    (uniqSwIds1 : UniqSwIds (switches st1))
    (P1 : P (switches st1) (ofLinks st1) (ctrl st1))
    (uniqOfLinkIds1 : AllDiff of_to (ofLinks st1))
    (ofLinksHaveSw1 : OFLinksHaveSw (switches st1) (ofLinks st1))
    (devsFromTopo1 : DevicesFromTopo st1)
    (swsHaveOFLinks1 : SwitchesHaveOpenFlowLinks (switches st1) (ofLinks st1))
    (noBarriersInCtrlm1 : NoBarriersInCtrlm (switches st1)),
    multistep step st1 obs st2 ->
    exists tblsOk2 linksTopoOk2 haveSrc2 haveDst2 uniqSwIds2 P2
           uniqOfLinkIds2 ofLinksHaveSw2 devsFromTopo2 swsHaveOFLinks2
           noBarriersInCtrlm2,
      multistep concreteStep
                (ConcreteState st1 tblsOk1 linksTopoOk1 haveSrc1 haveDst1
                               uniqSwIds1 P1 uniqOfLinkIds1
                               ofLinksHaveSw1 devsFromTopo1 swsHaveOFLinks1
                               noBarriersInCtrlm1)
                obs
                (ConcreteState st2 tblsOk2 linksTopoOk2 haveSrc2 haveDst2
                               uniqSwIds2 P2 uniqOfLinkIds2
                               ofLinksHaveSw2 devsFromTopo2 swsHaveOFLinks2
                               noBarriersInCtrlm2).
  Proof with eauto with datatypes.
    intros.
    induction H.
    (* zero steps. *)
    + solve [ eauto 13 ].
    (* tau step *)
    + destruct (simpl_step tblsOk1 linksTopoOk1 haveSrc1 haveDst1
                           uniqSwIds1 P1 uniqOfLinkIds1 ofLinksHaveSw1
                           devsFromTopo1 swsHaveOFLinks1
                           noBarriersInCtrlm1
                           H)
        as [tblsOk2 [linksTopoOk2 [haveSrc2 [haveDst2 [uniqSwIds2
           [P2 [uniqOfLinkIds2 [ofLinksHaveSw2
           [devsFromTopo2 [swsHaveOFLinks2
           [noBarriersInCtrlm2 step]]]]]]]]]]].
      destruct (IHmultistep tblsOk2 linksTopoOk2 haveSrc2 haveDst2
                            uniqSwIds2 P2 uniqOfLinkIds2 ofLinksHaveSw2
                            devsFromTopo2 swsHaveOFLinks2 noBarriersInCtrlm2)
        as [tblsOk3 [linksTopoOk3 [haveSrc3 [haveDst3
                [uniqSwIds3 [PN [uniqOfLinkIdsN [ofLinksHaveSwN
           [devsFromTopoN [swsHaveOFLinksN [noBarriersInCtrlmN stepN]]]]]]]]]]].
      solve [ eauto 13 ].
    (* The script below is an identical copy of the case above. *)
    + destruct (simpl_step tblsOk1 linksTopoOk1 haveSrc1 haveDst1
                           uniqSwIds1 P1 uniqOfLinkIds1 ofLinksHaveSw1
                           devsFromTopo1 swsHaveOFLinks1
                           noBarriersInCtrlm1
                           H)
        as [tblsOk2 [linksTopoOk2 [haveSrc2 [haveDst2 [uniqSwIds2
           [P2 [uniqOfLinkIds2 [ofLinksHaveSw2
           [devsFromTopo2 [swsHaveOFLinks2
           [noBarriersInCtrlm2 step]]]]]]]]]]].
      destruct (IHmultistep tblsOk2 linksTopoOk2 haveSrc2 haveDst2
                            uniqSwIds2 P2 uniqOfLinkIds2 ofLinksHaveSw2
                            devsFromTopo2 swsHaveOFLinks2 noBarriersInCtrlm2)
        as [tblsOk3 [linksTopoOk3 [haveSrc3 [haveDst3
                [uniqSwIds3 [PN [uniqOfLinkIdsN [ofLinksHaveSwN
           [devsFromTopoN [swsHaveOFLinksN [noBarriersInCtrlmN stepN]]]]]]]]]]].
      solve [ eauto 13 ].
  Qed.

  Lemma simpl_multistep : forall (st1 : concreteState) (devs2 : state) obs,
    multistep step (devices st1) obs devs2 ->
    exists (st2 : concreteState),
      devices st2 = devs2 /\
      multistep concreteStep st1 obs st2.
  Proof with simpl;auto.
    intros.
    destruct st1.
    destruct (simpl_multistep' concreteState_flowTableSafety0
      concreteState_consistentDataLinks0 linksHaveSrc0 linksHaveDst0
      uniqSwIds0 ctrlP0 uniqOfLinkIds0 ofLinksHaveSw0 devicesFromTopo0
      swsHaveOFLinks0 noBarriersInCtrlm0 H) as [v0 [v1 [v2 [v3 [v4 [v5 [v6 [v7 [v8 [v9 [v10 Hstep]]]]]]]]]]].
    exists (ConcreteState devs2 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)...
  Qed.

  Lemma relate_step_simpl_tau : forall st1 st2,
    concreteStep st1 None st2 ->
    relate (devices st1) = relate (devices st2).
  Proof with eauto with datatypes.
    intros.
    inversion H; subst.
    (* Case 2. *)
    idtac "Proving relate_step_simpl_tau (Case 2 of 11)...".
    destruct st1. destruct st2. subst. unfold relate. simpl.
    autorewrite with bag using simpl.
    bag_perm 100.
    (* 3. PacketOut case. *)
    idtac "Proving relate_step_simpl_tau (Case 3 of 11)...".
    destruct st1. destruct st2. subst. unfold relate. simpl.
    autorewrite with bag using simpl.
    bag_perm 100.
    (* 4. SendDataLink case. *)
    idtac "Proving relate_step_simpl_tau (Case 4 of 11)...".
    destruct st1. destruct st2. subst. unfold relate. simpl.
    autorewrite with bag using simpl.
    destruct dst0.
    rewrite -> Bag.from_list_cons.
    assert (topo (src (DataLink (swId0, pt) pks0 (s,p))) =
            Some (dst (DataLink (swId0, pt) pks0 (s,p)))) as Jtopo.
    {
      unfold ConsistentDataLinks in concreteState_consistentDataLinks0.
      apply concreteState_consistentDataLinks0.
        simpl in H1.
        rewrite <- H1.
        simpl... }
    simpl in Jtopo.
    rewrite -> Jtopo.
    bag_perm 100.
    (* 5. RecvDataLink case. *)
    idtac "Proving relate_step_simpl_tau (Case 5 of 11)...".
    destruct st1. destruct st2. subst. unfold relate. simpl.
    autorewrite with bag using simpl.
    bag_perm 100.
    (* 6. Controller steps *)
    idtac "Proving relate_step_simpl_tau (Case 6 of 11)...".
    unfold relate.
    simpl.
    rewrite -> (ControllerRemembersPackets H2).
    reflexivity.
    (* 7. Controller receives. *)
    idtac "Proving relate_step_simpl_tau (Case 7 of 11)...".
    unfold relate.
    simpl.
    repeat rewrite -> map_app.
    simpl.
    repeat rewrite -> unions_app.
    autorewrite with bag using simpl.
    rewrite -> (ControllerRecvRemembersPackets H2).
    bag_perm 100.
    (* 8. Controller sends *)
    idtac "Proving relate_step_simpl_tau (Case 8 of 11)...".
    unfold relate.
    simpl.
    repeat rewrite -> map_app.
    simpl.
    repeat rewrite -> unions_app.
    autorewrite with bag using simpl.
    rewrite -> (ControllerSendForgetsPackets H2).
    bag_perm 100.
    (* 9. Switch sends to controller *)
    idtac "Proving relate_step_simpl_tau (Case 9 of 11)...".
    unfold relate.
    simpl.
    repeat rewrite -> map_app.
    simpl.
    repeat rewrite -> unions_app.
    autorewrite with bag using simpl.
    bag_perm 100.
    (* 10. Switch receives a barrier. *)
    idtac "Proving relate_step_simpl_tau (Case 10 of 11)...".
    unfold relate.
    simpl.
    repeat rewrite -> map_app.
    simpl.
    repeat rewrite -> unions_app.
    autorewrite with bag using simpl.
    bag_perm 100.
    (* 11. Switch receives a non-barrier. *)
    idtac "Proving relate_step_simpl_tau (Case 11 of 11)...".
    unfold relate.
    simpl.
    repeat rewrite -> map_app.
    simpl.
    repeat rewrite -> unions_app.
    autorewrite with bag using simpl.
    bag_perm 100.
  Qed.

  Lemma relate_multistep_simpl_tau : forall st1 st2,
    multistep concreteStep st1 nil st2 ->
    relate (devices st1) = relate (devices st2).
  Proof with eauto.
    intros.
    remember nil.
    induction H...
    + apply relate_step_simpl_tau in H.
      rewrite -> H...
    + inversion Heql.
  Qed.

  Lemma relate_step_simpl_obs : forall  sw pt pk lps st1 st2,
    relate (devices st1) = ({| (sw,pt,pk) |} <+> lps) ->
    concreteStep st1 (Some (sw,pt,pk)) st2 ->
    relate (devices st2) =
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps).
  Proof with eauto with datatypes.
    intros.
    inversion H0.
    destruct st1.
    destruct st2.
    destruct devices0.
    destruct devices1.
    subst.
    simpl in *.
    inversion H1; subst; clear H1.
    inversion H6; subst; clear H6.
    assert (FlowTableSafe sw tbl0) as Z.
    { assert (FlowModSafe sw tbl0 ctrlm0) as Z.
      { unfold FlowTablesSafe in concreteState_flowTableSafety0.
        eapply concreteState_flowTableSafety0...
        apply Bag.in_union; simpl... }
      unfold FlowTableSafe in Z.
      inversion Z... }
    remember (Z pt pk outp' pksToCtrl H3) as Y eqn:X. clear X Z.
    rewrite <- Y. clear Y.

    unfold relate in *.
    simpl in *.
    autorewrite with bag using simpl.
    apply (Bag.pop_union_r _ ({|(sw,pt,pk)|})).
    repeat rewrite -> Bag.union_assoc.
    rewrite -> (Bag.union_comm _ lps).
    rewrite <- H.
    simpl.
    autorewrite with bag using simpl.
    bag_perm 100.
  Qed.

  Lemma relate_multistep_simpl_obs : forall  sw pt pk lps st1 st2,
    relate (devices st1) = ({| (sw,pt,pk) |} <+> lps) ->
    multistep concreteStep st1 [(sw,pt,pk)] st2 ->
    relate (devices st2) =
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps).
  Proof with eauto.
    intros.
    remember [(sw,pt,pk)] as obs.
    induction H0; subst.
    inversion Heqobs.
    apply IHmultistep...
    apply relate_step_simpl_tau in H0.
    symmetry in H0.
    rewrite -> H0...
    destruct obs; inversion Heqobs.
    subst.
    clear Heqobs.
    apply relate_multistep_simpl_tau in H1.
    apply relate_step_simpl_obs with (lps := lps) in H0 .
    rewrite <- H0.
    symmetry...
    trivial.
  Qed.

  Lemma simpl_weak_sim : forall st1 devs2 sw pt pk lps,
    multistep step (devices st1) [(sw,pt,pk)] devs2 ->
    relate (devices st1) = ({| (sw,pt,pk) |} <+> lps) ->
    abstractStep
      ({| (sw,pt,pk) |} <+> lps)
      (Some (sw,pt,pk))
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps) ->
   exists st2 : concreteState,
     inverse_relation
       bisim_relation
       (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps)
       st2 /\
     multistep concreteStep st1 [(sw,pt,pk)] st2.
  Proof with eauto.
    intros.
    destruct (simpl_multistep st1 H) as [st2 [Heq Hmultistep]].
    assert (relate (devices st1) = ({| (sw,pt,pk) |} <+> lps)) as Hrel.
      subst. simpl...
    exists st2.
    split.
    unfold inverse_relation.
    unfold bisim_relation.
    symmetry...
    exact (relate_multistep_simpl_obs Hrel Hmultistep).
    trivial.
  Qed.

End Make.


Require Export CalculusSM_tacs.

Section CalculusSM_derived.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pm  : @Msg }.
  Context { qc  : @Quorum_context pn}.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : @ContainedAuthData pd pat pm }.
  Context { dtc : @DTimeContext }.
  Context { iot : @IOTrustedFun }.
  Context { ctp : @ComponentTrust pd pn pat qc iot }.
  Context { cap : @ComponentAuth pd pn pk pat pm dtc iot }.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { base_fun_io       : baseFunIO           }.
  Context { base_state_fun    : baseStateFun        }.
  Context { trusted_state_fun : trustedStateFun     }.
  Context { pkc               : KnowledgeComponents }.

  Local Open Scope kn.

  (************************************************************************************************)
  Definition DERIVED_RULE_KLD_implies_or_owns {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_knew_or_learns_or_gen d @ e'])
      (⟬R⟭ H ⊢ ASSUMPTION_learns_or_owns d @ e).

  Lemma DERIVED_RULE_KLD_implies_or_owns_true :
    forall {eo : EventOrdering} e R H d,
      rule_true (DERIVED_RULE_KLD_implies_or_owns e R H d).
  Proof.
    start_proving_derived st.

    LOCKapply (PRIMITIVE_RULE_cut_true "x" (ASSUMPTION_knows_implies_learned_or_gen d @ e)).
    { LOCKapply DERIVED_RULE_KLD_implies_or_true; inst_hyp e0 w. }

    LOCKintro1 "y".
    LOCKelim "x"; try LOCKauto.

    LOCKelim "x".
    { LOCKintro 0; try LOCKauto. }

    LOCKintro 1.
    LOCKapply@ "x" (DERIVED_RULE_unlocal_before_eq_hyp_true "u").
    LOCKelim "x" "z".
    LOCKapply@ "u" DERIVED_RULE_owns_change_localle_true; try LOCKauto.
  Qed.

  (***********************************************************)
  Definition DERIVED_RULE_owns_dec {eo : EventOrdering} e d R H :=
    MkRule0
      []
      (⟬R⟭ H ⊢ KE_OR (KE_OWNS d) (KE_NOT (KE_OWNS d)) @ e).

  Lemma DERIVED_RULE_owns_dec_true :
    forall {eo : EventOrdering} e d R H,
      rule_true (DERIVED_RULE_owns_dec e d R H).
  Proof.
    start_proving_derived st.
    destruct (implies_ex_node e) as [n cond].
    LOCKapply (PRIMITIVE_RULE_cut_true "x" (KE_OR (KE_HAS_OWNER d n) (KE_NOT (KE_HAS_OWNER d n)) @ e)).
    { LOCKapply PRIMITIVE_RULE_has_owner_dec_true. }
    LOCKelim "x".
    { LOCKintro 0.
      LOCKapply (PRIMITIVE_RULE_exists_node_intro_true n).
      LOCKintro; try LOCKauto. }
    LOCKintro 1.
    LOCKintro "o".
    LOCKelim "x"; try LOCKauto.
    LOCKapply@ "o" PRIMITIVE_RULE_exists_node_elim_true.
    LOCKapply@ "o" (PRIMITIVE_RULE_and_elim_true "o" "x").
    LOCKapply (PRIMITIVE_RULE_subst_node_in_has_owner_true n0); try LOCKauto.
    LOCKapply (PRIMITIVE_RULE_cut_true "a" (KE_AT n @ e)); try LOCKauto.
    LOCKapply PRIMITIVE_RULE_at_implies_same_node_true; try LOCKauto.
  Qed.

  (***************************************************************************)
  Definition DERIVED_RULE_disseminate_if_learned_and_disseminated
             p a {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_disseminate_if_knows d   @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_knew_or_learns_or_gen d  @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_learns_if_gen d          @ e',
          ⟬R⟭ H ⊢ KE_AT a                 @ e,
          ⟬R⟭ H ⊢ KE_DISS d               @ e,
          ⟬R⟭ H ⊢ KE_HAS_OWNER d p        @ e,
          ⟬R⟭ H ⊢ KE_NOT (KE_NODE_EQ p a) @ e])
      (⟬R⟭ H ⊢ KE_HAPPENED_BEFORE (KE_DISS_OWN d) @ e).

  Lemma DERIVED_RULE_disseminate_if_learned_and_disseminated_true :
    forall p a {eo : EventOrdering} (e : EventN) R H (d : kc_data),
      rule_true(DERIVED_RULE_disseminate_if_learned_and_disseminated p a e R H d).
  Proof.
    start_proving_derived st.
    inst_hyp e w.

    LOCKapply (PRIMITIVE_RULE_cut_true "ass" (ASSUMPTION_learned_if_gen d @ e)).
    { LOCKapply DERIVED_RULE_implies_learned_if_gen_true; inst_hyp e0 q. }

    LOCKelim "ass"; try LOCKauto.
    LOCKapply (DERIVED_RULE_knows_and_not_owns_implies_learns2_true p a).
    { LOCKapply DERIVED_RULE_KLD_implies_or_owns_true; inst_hyp e0 w. }

    LOCKapply (PRIMITIVE_RULE_cut_true "ass" (ASSUMPTION_disseminate_if_knows d @ e)).

    LOCKelim "ass"; try LOCKauto.
    LOCKintro; try LOCKauto.
  Qed.

  (***************************************************************************)
  Definition ASSUMPTION_disseminate_if_knows_trusted (d : kc_data) : KExpression :=
    KE_IMPLIES
      (KE_ANDS
         [KE_DISS d,
          KE_NODE,
          KE_LOCAL_CORRECT_TRACE_BEFORE])
      (KE_EX_TRUST
         (fun t =>
            KE_AND
              (KE_TKNOWS t)
              (KE_GEN_FOR d t))).

  Definition ASSUMPTION_trusted_learned_if_gen (t : kc_trust) :=
    KE_IMPLIES
      (KE_TLEARNED t)
      (KE_HAPPENED_BEFORE (KE_TDISS_OWN t)).

  (***************************************************************************)
  Definition DERIVED_RULE_disseminate_if_learned_and_disseminated2
             {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ KE_ALL_DATA ASSUMPTION_disseminate_if_knows_trusted @ e',
          ⟬R⟭ H ⊢ KE_ALL_DATA ASSUMPTION_knew_or_learns_or_gen        @ e',
          ⟬R⟭ H ⊢ KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen       @ e',
          ⟬R⟭ H ⊢ KE_LOCAL_CORRECT_TRACE_BEFORE @ e,
          ⟬R⟭ H ⊢ KE_DISS d @ e])
      (⟬R⟭ H ⊢ KE_EX_TRUST (fun t =>
                              KE_ANDS
                                [KE_GEN_FOR d t,
                                 KE_TKNOWS t,
                                 KE_OR
                                   (KE_HAPPENED_BEFORE (KE_TDISS_OWN t))
                                   (KE_TOWNS t)]) @ e).

  Lemma DERIVED_RULE_disseminate_if_learned_and_disseminated2_true :
    forall {eo : EventOrdering} (e : EventN) R H (d : kc_data),
      rule_true (DERIVED_RULE_disseminate_if_learned_and_disseminated2 e R H d).
  Proof.
    start_proving_derived st.
    inst_hyp e w.

    LOCKapply (PRIMITIVE_RULE_cut_true "ass" (KE_ALL_DATA ASSUMPTION_disseminate_if_knows_trusted @ e)).
    LOCKapply@ "ass" (PRIMITIVE_RULE_all_data_elim_true "ass" d).
    LOCKelim "ass"; repeat LOCKintro; try LOCKauto.
    LOCKapply@ "ass" PRIMITIVE_RULE_exists_trust_elim_true.
    LOCKelim "ass" "kn".
    LOCKapply (PRIMITIVE_RULE_exists_trust_intro_true t).
    repeat LOCKintro; try LOCKauto.

    LOCKapply (PRIMITIVE_RULE_cut_true "o" (KE_OR (KE_TOWNS t) (KE_NOT (KE_TOWNS t)) @ e)).
    { LOCKapply DERIVED_RULE_owns_dec_true. }

    LOCKelim "o".
    { LOCKintro 1; try LOCKauto. }
    LOCKintro 0.

    LOCKapply (PRIMITIVE_RULE_cut_true "lrn" (KE_TLEARNED t @ e)).
    { LOCKapply DERIVED_RULE_knows_and_not_owns_implies_learns_true; try LOCKauto.
      LOCKapply DERIVED_RULE_KLD_implies_or_owns_true.
      inst_hyp e0 z.
      repeat LOCKclear.
      LOCKapply (PRIMITIVE_RULE_cut_true "x" (KE_ALL_DATA ASSUMPTION_knew_or_learns_or_gen @ e0)).
      LOCKapply@ "x" (PRIMITIVE_RULE_all_data_elim_true "x" (kc_trust2data t)); LOCKauto. }

    LOCKapply (PRIMITIVE_RULE_cut_true "lid" (ASSUMPTION_trusted_learned_if_gen t @ e)).
    { repeat LOCKclear.
      LOCKapply DERIVED_RULE_implies_learned_if_gen_true.
      inst_hyp e0 z.
      LOCKapply (PRIMITIVE_RULE_cut_true "x" (KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen @ e0)).
      LOCKapply@ "x" (PRIMITIVE_RULE_all_trust_elim_true "x" t); LOCKauto. }

    LOCKelim "lid"; try LOCKauto.
  Qed.

  (***************************************************************************)
  Definition DERIVED_RULE_knows_if_learned_and_disseminated
             p a {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_disseminate_if_knows d   @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_knew_or_learns_or_gen d  @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_learns_if_gen d          @ e',
          ⟬R⟭ H ⊢ KE_AT a                 @ e,
          ⟬R⟭ H ⊢ KE_DISS d               @ e,
          ⟬R⟭ H ⊢ KE_HAS_OWNER d p        @ e,
          ⟬R⟭ H ⊢ KE_NOT (KE_NODE_EQ p a) @ e])
      (⟬R⟭ H ⊢ KE_HAPPENED_BEFORE (KE_KNOWS_OWN d) @ e).

  Lemma DERIVED_RULE_knows_if_learned_and_disseminated_true :
    forall p a {eo : EventOrdering} (e : EventN) R H (d : kc_data),
      rule_true (DERIVED_RULE_knows_if_learned_and_disseminated p a e R H d).
  Proof.
    start_proving_derived st.

    LOCKapply (PRIMITIVE_RULE_cut_true "x" (KE_HAPPENED_BEFORE (KE_DISS_OWN d) @ e)).
    { LOCKapply (DERIVED_RULE_disseminate_if_learned_and_disseminated_true p a); inst_hyp e0 q. }
    LOCKapply@ "x" (PRIMITIVE_RULE_unhappened_before_hyp_true "u").
    LOCKapply@ "u" PRIMITIVE_RULE_unhappened_before_if_causal_true.
    LOCKelim "x" "y".

    LOCKintro; try LOCKauto.

    LOCKapply (PRIMITIVE_RULE_cut_true "ass" (ASSUMPTION_disseminate_if_knows d @ e0)).
    { inst_hyp e0 h.
      LOCKclear "x".
      LOCKclear "y".
      LOCKclear "u". }

    LOCKelim "ass"; try LOCKauto.
    LOCKintro; try LOCKauto.
  Qed.

  (***************************************************************************)
  Definition DERIVED_RULE_knows_if_learned_and_disseminated2
             p {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_disseminate_if_knows d   @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_knew_or_learns_or_gen d  @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_learns_if_gen d          @ e',
          ⟬R⟭ H ⊢ KE_DISS d        @ e,
          ⟬R⟭ H ⊢ KE_HAS_OWNER d p @ e])
      (⟬R⟭ H ⊢ KE_HAPPENED_BEFORE_EQ (KE_KNOWS_OWN d) @ e).

  Lemma DERIVED_RULE_knows_if_learned_and_disseminated2_true :
    forall p {eo : EventOrdering} (e : EventN) R H (d : kc_data),
      rule_true (DERIVED_RULE_knows_if_learned_and_disseminated2 p e R H d).
  Proof.
    start_proving_derived st.
    LOCKapply (PRIMITIVE_RULE_cut_true "y" (KE_OR (KE_OWNS d) (KE_NOT (KE_OWNS d)) @ e)).
    { LOCKapply DERIVED_RULE_owns_dec_true. }
    LOCKelim "y".
    { LOCKintro 1; try LOCKintro; try LOCKauto.
      LOCKintro; try LOCKauto.
      LOCKapply (PRIMITIVE_RULE_cut_true "x" (ASSUMPTION_disseminate_if_knows d @ e)).
      { LOCKclear "y"; inst_hyp e h. }
      LOCKelim "x"; try LOCKauto.
      LOCKintro; try LOCKauto.
      LOCKclear "y"; inst_hyp e h. }

    destruct (implies_ex_node e) as [n cond].

    LOCKintro 0.
    LOCKapply (DERIVED_RULE_knows_if_learned_and_disseminated_true p n); try LOCKauto;
      try (complete (LOCKclear "y"; inst_hyp e0 h)).
    LOCKintro "o".
    LOCKelim "y"; try LOCKauto.
    LOCKapply (PRIMITIVE_RULE_exists_node_intro_true n); try LOCKintro; try LOCKauto.
    LOCKapply (PRIMITIVE_RULE_subst_node_in_has_owner_true p); try LOCKauto.
    LOCKclear "o"; inst_hyp e h.
  Qed.

End CalculusSM_derived.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Type system for the Mach intermediate language. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Memory.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Mach.

(** * Typing rules *)

Inductive wt_instr : instruction -> Prop :=
  | wt_Mlabel:
     forall lbl,
     wt_instr (Mlabel lbl)
  | wt_Mgetstack:
     forall ofs ty r,
     mreg_type r = ty ->
     wt_instr (Mgetstack ofs ty r)
  | wt_Msetstack:
     forall ofs ty r,
     mreg_type r = ty ->
     wt_instr (Msetstack r ofs ty)
  | wt_Mgetparam:
     forall ofs ty r,
     mreg_type r = ty ->
     wt_instr (Mgetparam ofs ty r)
  | wt_Mopmove:
     forall r1 r,
     mreg_type r1 = mreg_type r ->
     wt_instr (Mop Omove (r1 :: nil) r)
  | wt_Mop:
     forall op args res,
      op <> Omove ->
      (List.map mreg_type args, mreg_type res) = type_of_operation op ->
      wt_instr (Mop op args res)
  | wt_Mload:
      forall chunk addr args dst,
      List.map mreg_type args = type_of_addressing addr ->
      mreg_type dst = type_of_chunk chunk ->
      wt_instr (Mload chunk addr args dst)
  | wt_Mstore:
      forall chunk addr args src,
      List.map mreg_type args = type_of_addressing addr ->
      mreg_type src = type_of_chunk chunk ->
      wt_instr (Mstore chunk addr args src)
  | wt_Mcall:
      forall sig ros,
      match ros with inl r => mreg_type r = Tint | inr s => True end ->
      wt_instr (Mcall sig ros)
  | wt_Mtailcall:
      forall sig ros,
      tailcall_possible sig ->
      match ros with inl r => mreg_type r = Tint | inr s => True end ->
      wt_instr (Mtailcall sig ros)
  | wt_Mbuiltin:
     forall ef args res,
      List.map mreg_type args = (ef_sig ef).(sig_args) ->
      mreg_type res = proj_sig_res (ef_sig ef) ->
      wt_instr (Mbuiltin ef args res)
  | wt_Mannot:
      forall ef args,
      ef_reloads ef = false ->
      wt_instr (Mannot ef args)
  | wt_Mgoto:
      forall lbl,
      wt_instr (Mgoto lbl)
  | wt_Mcond:
      forall cond args lbl,
      List.map mreg_type args = type_of_condition cond ->
      wt_instr (Mcond cond args lbl)
  | wt_Mjumptable:
      forall arg tbl,
      mreg_type arg = Tint ->
      list_length_z tbl * 4 <= Int.max_unsigned ->
      wt_instr (Mjumptable arg tbl)
  | wt_Mreturn:
      wt_instr Mreturn.

Record wt_function (f: function) : Prop := mk_wt_function {
  wt_function_instrs:
    forall instr, In instr f.(fn_code) -> wt_instr instr;
  wt_function_stacksize:
    0 <= f.(fn_stacksize) <= Int.max_unsigned
}.

Inductive wt_fundef: fundef -> Prop :=
  | wt_fundef_external: forall ef,
      wt_fundef (External ef)
  | wt_function_internal: forall f,
      wt_function f ->
      wt_fundef (Internal f).

Definition wt_program (p: program) : Prop :=
  forall i f, In (i, f) (prog_funct p) -> wt_fundef f.