Require Import Miscy.
Require Import BGPSpec.
Require Import EvolutionLemmas.
Require Import Environment.
Require Import Claims.
Require Import DominantConvergence.
Require Import Fairness.
Require Import Sugar.
Import RTC.

Opaque export'.
Opaque import'.
Opaque eqDecide.
Opaque enumerate.
Opaque argMax.

Section AllASTypesConverge.
  Context `{PR:@PrefixClass}.
  Context `{IT:@InternetTopologyClass}.
  Context `{AT:@AttributesClass IT}.
  Context `{IP:@InitialPrefixClass PR IT AT}.
  Context `{OD:@OrderingClass IT AT}.
  Context `{RU:@RuleClass IT AT PR IP OD}.
  Context `{FA:@Convergence FairNetworkState}.
  Context `{SP:@SinglePrefixClass PR}.
  Context `{B:@BGPConvergence PR IT AT IP OD RU FA SP}.

  Definition ASConverges x := forall r, exists i a, converges (StableRouter x r i a).

  Definition ASConvergesWithRoute x := forall r, exists i a, import' (x;r) i p a <> notAvailable /\
                                                   converges (StableRouter x r i a).

  Global Instance convergenceDefinitions : ConvergenceDefinitions.
    refine {|
      ConvergentLink x r x' r' c := converges (StableLink x r x' r' c);
      ConvergentAS := ASConverges;
      ConvergentASWithRoute := ASConvergesWithRoute
    |}.
    - (* convergentASLinkConverges *)
      intros x r x' r' c h.
      unfold ASConverges in h.
      specialize (h r).
      destruct h as [i [a h]].
      unfold const in *.
      eapply stableRIBsOutEmptyLink.
      refine (impliedConverges _ _ (combineConverges _ h adjRIBsOutConvergence)).
      intros s [[iStable aStable] outEq].
      rewrite outEq.
      unfold StableRouter in *.
      unfold imports.
      rewrite iStable.
      rewrite aStable.
      reflexivity.
    - (* convergentASWithRouteConverges *)
      intros x h r.
      destruct (h r) as [i [a [_ h']]].
      exists i. exists a. exact h'.
  Defined.

  Context `{@LinkConvergenceLemmas _ _ _ _ _ convergenceDefinitions}.

  Section ASWithStableIncomingLinksConverges.
    Variable x : AS.
    Variable neqX0 : x <> x0.
    Variable stableIn : forall r x' r' c, ConvergentLink x' r' x r (external c).

    Definition ExternalAnnouncementConverges r x' r' c : {a |
      let i := mkReceived x r x' r' (external c) in
      converges (fun s  => a = adjRIBsIn (ribs s x r) (i, p))}.
    Proof.
      destruct (emptyLinkConvergence x' r' x r (external c) (stableIn _ _ _ _ )) as [a h].
      exists a.
      refine (impliedConverges _ _ h).
      intuition.
    Defined.

    Definition ExternalAnnouncementsConverge :
      {exA | converges (fun s => forall r x' r' c,
        let i := mkReceived x r x' r' (external c) in
        exA r x' r' c = adjRIBsIn (ribs s x r) (i, p))}.
    Proof.
      specialize ExternalAnnouncementConverges.
      intros h.
      unfold const in *; cbn in h.
      refine ((fun h' => _) (fun r x' r' => _)); revgoals. {
        exact (swap_ex_forall (h r x' r')).
      } clear h; rename h' into h.
      refine ((fun h' => _) (fun r x' => _)); revgoals. {
        exact (swap_ex_forall (h r x')).
      } clear h; rename h' into h.
      refine ((fun h' => _) (fun r => _)); revgoals. {
        exact (swap_ex_forall (h r)).
      } clear h; rename h' into h.
      apply swap_ex_forall in h.
      cbn in h.
      destruct h as [exA h].
      exists exA.
      apply (distributeForallConverges FairNetworkState); intros r.
      apply (distributeForallConverges FairNetworkState); intros x'.
      apply (distributeForallConverges FairNetworkState); intros r'.
      apply (distributeForallConverges FairNetworkState); intros c.
      apply h.
    Defined.

    Definition InjectedAnnouncementsConverge :
      {injA | converges (fun s => forall r, adjRIBsIn (ribs s x r) (injected, p) = injA r)}.
    Proof.
      unfold const; cbn.
      exists (const notAvailable).
      refine (impliedConverges _ _ injectedConvergence).
      intros s h r.
      specialize (h x r).
      break_match; [congruence|].
      apply h.
    Defined.

    Definition aNonInternal {r} (nii:@nonInternalIncoming _ x r) : RoutingInformation.
      refine (match nii with
      | Some (x';(r';c)) => (proj1_sig ExternalAnnouncementsConverge) r x' r' c
      | None => (proj1_sig InjectedAnnouncementsConverge) r
      end).
    Defined.

    Lemma aNonInternalConverges :
      converges (fun s => forall r (nii:nonInternalIncoming r),
        adjRIBsIn (ribs s x r) (nii2i nii, p) = aNonInternal nii).
    Proof.
      unfold aNonInternal.
      refine (impliedConverges _ _ (combineConverges _
                                    (proj2_sig ExternalAnnouncementsConverge)
                                    (proj2_sig InjectedAnnouncementsConverge))).
      intros s [exCon injCon].
      destruct nii as [[x' [r' c]]|].
      - (* nii is external *)
        rewrite exCon.
        reflexivity.
      - (* nii is internal *)
        rewrite injCon.
        reflexivity.
    Qed.
    Opaque aNonInternal.

    Definition aNonInternalImp {r} nii := import' (x;r) (nii2i nii) p (aNonInternal nii).

    Instance enumerableNii x (r:router x) : enumerable (nonInternalIncoming r).
      unfold nonInternalIncoming.
      eapply enumerableOption.
    Unshelve.
      eapply enumerableSigT.
    Unshelve.
      - intros x'; apply eqDecAll.
      - intros x'.
        eapply enumerableSigT.
    Unshelve.
      intros r'; apply eqDecAll.
    Qed.

    Definition niiBest (r:router x) : nonInternalIncoming r.
      refine (proj1_sig (argMax (fun nii => (nii2i nii, @aNonInternalImp r nii)) None)).
    Defined.

    Definition localDominance r niiBest s :=
      adjRIBsIn (ribs s x r) (nii2i niiBest, p) = aNonInternal niiBest /\
      forall nii, (nii2i niiBest, aNonInternalImp niiBest) >= (nii2i nii, imports x r (nii2i nii) s).

    Lemma niiBestConverges r : converges (localDominance r (niiBest r)).
      refine (impliedConverges _ _ aNonInternalConverges).
      intros s con.
      unfold niiBest.
      match goal with
      |- context[argMax ?F ?D] => destruct (argMax F D) as [niiBest niiBestBeatsEveryone]
      end.
      constructor; cbn.
      - apply con.
      - intro nii.
        unfold imports.
        rewrite con.
        apply niiBestBeatsEveryone.
    Qed.

    Definition aNiiBestImp r := aNonInternalImp (niiBest r).

    Definition globalDominance r := forall r', aNiiBestImp r >= aNiiBestImp r'.

    Instance stableIncomingDominanceSet : DominanceSet x.
      refine {|
        dominant := globalDominance;
        nonInternalBest r dom := niiBest r;
        aBest r dom := aNonInternal (niiBest r);
        designatedDominantRouter := argMax aNiiBestImp (designatedRouter x)
      |}.
      intros.
      apply decidableAll.
    Defined.

    Instance stableIncomingDominanceLemmas : DominanceLemmas x.
      constructor.
      - (* dominantDominatesDominants *)
        intros r dom r' dom'.
        cbn in dom.
        unfold globalDominance in dom.
        apply (dom r').
      - (* globalDominanceInj *)
        apply (distributeForallConverges FairNetworkState); intros r.
        apply (distributeForallConverges FairNetworkState); intros r'.
        refine (impliedConverges _ _ (niiBestConverges r')).
        intros s [_ better] dom noDom' h.
        cbn in dom, noDom'; unfold globalDominance in dom, noDom'.
        apply noDom'; clear noDom'.
        intros r''.
        eapply prefTransitive; [apply dom|].
        eapply prefTransitive; [apply h|]; clear h.
        eapply preferenceRelationship.
        apply (better None).
      - (* globalDominanceExt *)
        apply (distributeForallConverges _); intros r.
        apply (distributeForallConverges _); intros r'.
        apply (distributeForallConverges _); intros xe.
        apply (distributeForallConverges _); intros re.
        apply (distributeForallConverges _); intros c.
        refine (impliedConverges _ _ (niiBestConverges r')).
        intros s [_ better] dom noDom' h.
        cbn in dom, noDom'; unfold globalDominance in dom, noDom'.
        apply noDom'; clear noDom'.
        intros r''.
        eapply prefTransitive; [apply dom|].
        eapply prefTransitive; [apply h|]; clear h.
        eapply preferenceRelationship.
        apply (better (Some (xe;(re;c)))).
      - (* bestInstalled *)
        apply (distributeForallConverges _); intros r.
        refine (impliedConverges _ _ (niiBestConverges r)).
        intros s [h _] dom.
        apply h.
      - (* localDominanceInj *)
        apply (distributeForallConverges _); intros r.
        refine (impliedConverges _ _ (niiBestConverges r)).
        intros s [_ h] dom.
        apply (h None).
      - (* localDominanceExt *)
        apply (distributeForallConverges _); intros r.
        refine (impliedConverges _ _ (niiBestConverges r)).
        intros s [_ h] dom.
        intros xe re c.
        apply (h (Some (xe;(re;c)))).
    Qed.

    Lemma ASWithStableIncomingLinksConverges : ASConverges x.
      intros r.
      specialize (ASWithDominantRoutersConverges x r); intros h.
      break_match; eexists; eexists; apply h.
    Qed.
  End ASWithStableIncomingLinksConverges.

  Lemma internalImportNotNa x r r' h a : a <> notAvailable ->
    import' (x; r) (mkReceived x r x r' (internal h)) p a <> notAvailable.
  Proof.
    Transparent import'.
    unfold import', bindRoutingInformation.
    Opaque import'.
    break_match; [|congruence].
    rename p into a'.
    intros _ h'.
    cbn in *.
    apply (availableGtNa a').
    specialize (internalImportRuleEq p x r r' h a').
    rewrite h'; unfold prefEq.
    intuition.
  Qed.

  Lemma internalExportNotNa x r r' nii h a : a <> notAvailable ->
    export' (x; r) (nii2i nii) (mkOutgoing x r x r' (internal h)) p a <> notAvailable.
  Proof.
    Transparent export'.
    unfold export', bindRoutingInformation.
    Opaque export'.
    unfold nii2i.
    destruct nii as [[? [? c]]|].
    - (* external *)
      cbn.
      break_match.
      + (* customer isn't from internal *)
        exfalso.
        break_match; [|crush].
        break_match; [|crush].
        subst_max.
        cbn in *.
        inversion c.
        * eapply customerIrreflexive; eauto.
        * eapply customerIrreflexive; eauto.
        * eapply peerToPeerIrreflexive; eauto.
      + (* <copy of code D> *)
        break_match; [|congruence].
        (* announcement is available *)
        rename p into a'.
        intros _ h'.
        cbn in *.
        apply (availableGtNa a').
        match goal with (* match h' *)
        | _:exportRule _ ?I _ _ _ = notAvailable |- _ =>
          specialize (internalExportRuleEq p x r r' I h a')
        end.
        rewrite h'; unfold prefEq.
        intuition.
        (* </copy of code D> *)
    - (* injected *)
      (* <copy of code D> *)
      break_match; [|congruence].
      (* announcement is available *)
      rename p into a'.
      intros _ h'.
      cbn in *.
      apply (availableGtNa a').
      match goal with (* match h' *)
      | _:exportRule _ ?I _ _ _ = notAvailable |- _ =>
        specialize (internalExportRuleEq p x r r' I h a')
      end.
      rewrite h'; unfold prefEq.
      intuition.
      (* </copy of code D> *)
  Qed.

  Section ASWithStableCustomersConverges.
    Variable x : AS.
    Variable customerAS : AS.
    Variable neqX0 : x <> x0.
    Variable customerASIsCustomer : x >> customerAS.
    Variable customerASRoute : ConvergentASWithRoute customerAS.
    Variable allCustomersConverged : forall r x' r' (cust:x >> x') c,
                                       ConvergentLink x' r' x r (external (c2pLink cust c)).

    Definition CustomerAnnouncementConverges r (cust:customer x r) :
      {a | converges (fun s => a = adjRIBsIn (ribs s x r) (c2i cust, p))}.
    Proof.
      destruct cust as [x' [r' [cust c]]].
      destruct (emptyLinkConvergence x' r' x r (external (c2pLink cust c)) (allCustomersConverged _ _ _ _ _)) as [a h].
      exists a.
      refine (impliedConverges _ _ h).
      intuition.
    Defined.

    Definition CustomerAnnouncementsConverge :
      {a | converges (fun s => forall r cust, a r cust = adjRIBsIn (ribs s x r) (c2i cust, p))}.
    Proof.
      specialize CustomerAnnouncementConverges.
      intros h.
      unfold const in *; cbn in h.
      refine ((fun h' => _) (fun r => _)); revgoals. {
        exact (swap_ex_forall (h r)).
      } clear h; rename h' into h.
      apply swap_ex_forall in h.
      cbn in h.
      destruct h as [exA h].
      exists exA.
      apply (distributeForallConverges _); intros r.
      apply (distributeForallConverges _); intros cust.
      apply h.
    Qed.

    Definition aCustomer {r} (cust:customer x r) : RoutingInformation :=
      (proj1_sig CustomerAnnouncementsConverge) r cust.

    Definition aCustomerConverges :
      converges (fun s => forall r cust, aCustomer cust = adjRIBsIn (ribs s x r) (c2i cust, p)) :=
        proj2_sig CustomerAnnouncementsConverge.

    Definition aCustomerImp {r} cust := import' (x;r) (c2i cust) p (aCustomer cust).

    Definition designatedCustomer : ∑ r, customer x r.
      destruct (designatedLink customerAS x customerASIsCustomer) as [r' [r c]].
      unfold customer.
      exact (r; (customerAS;(r';(customerASIsCustomer;c)))).
    Defined.

    Definition bestCustomer r (cust:customer x r) : customer x r.
      refine (proj1_sig (argMax (fun cust => (c2i cust, aCustomerImp cust)) cust)).
    Defined.

    Definition isBestCustomer r cust := forall r' cust',
      @aCustomerImp r cust >= @aCustomerImp r' cust'.

    Definition hasBestCustomer r := exists cust, isBestCustomer r cust.

    Definition getCustomer r (dom:hasBestCustomer r) := proj1_sig (indefinite_description dom).

    Definition aCustomerAvailable {r} cust : isBestCustomer r cust -> aCustomer cust <> notAvailable.
      intros custIsBest.
      unfold ConvergentASWithRoute in *.
      cbn in *.
      unfold ASConvergesWithRoute in *.
      destruct (designatedLink customerAS x customerASIsCustomer) as [rCust [r' c]].
      specialize (emptyLinkConvergence _ _ _ _ _ (allCustomersConverged _ _ _ _ c)).
      intros [aLink inOutRIBs] notNaCust.
      cbn in *.
      (* if aCustomer cust were notAvailable, the AS would converge to false! *)
      eapply falseConvergence.
      cbn.
      destruct (customerASRoute rCust) as [i [a [notNa stableRouter]]].
      refine (impliedConverges _ _ (combineConverges _ inOutRIBs
                                   (combineConverges _ adjRIBsOutConvergence
                                   (combineConverges _ stableRouter
                                                       aCustomerConverges)))).
      clear inOutRIBs stableRouter customerASRoute.
      unfold StableRouter in *.
      intros s [[aOutEq aInEq] [outEq [[iStable aStable] aCustIn]]].
      rewrite outEq in aOutEq; clear outEq.
      unfold imports in aOutEq.
      rewrite iStable in aOutEq; clear iStable.
      rewrite aStable in aOutEq; clear aStable.
      revert notNa aOutEq.
      match goal with |- ?A <> notAvailable -> _ => generalize A end.
      intros aImp notNaImp aOutEq.
      assert (aLink <> notAvailable) as notNaLink. {
        rewrite aOutEq; clear aOutEq.
        Transparent export'.
        unfold export', bindRoutingInformation.
        Opaque export'.
        break_match.
        - break_match; [|congruence].
          apply exportToProviderAvailable.
        - unfold mkOutgoing.
          break_match.
          cbn in *.
          break_match. {
            exfalso.
            break_match; [|intuition; congruence].
            break_match; [|intuition; congruence].
            apply (customerIrreflexive (x:=x)).
            rewrite <- e0 at 1.
            assumption.
          }
          break_match; [|congruence].
          apply exportToProviderAvailable.
      }
      clear aOutEq notNaImp.
      refine (let cust' : customer x r' := _ in _). {
        unfold customer.
        refine (customerAS; (rCust; (_; c))).
      }
      assert (aCustomer cust' <> notAvailable) as notNaCust'. {
        rewrite aCustIn.
        subst cust'.
        cbn in *.
        rewrite <- aInEq.
        assumption.
      }
      clear notNaLink aCustIn aInEq aImp.
      (* cust isn't na because its better than cust', and cust' isn't na *)
      unfold isBestCustomer in *.
      specialize (custIsBest r' cust').
      apply notNaCust'; clear notNaCust'.
      unfold aCustomerImp in *.
      rewrite notNaCust in custIsBest.
      Transparent import'.
      unfold import', bindRoutingInformation in custIsBest.
      Opaque import'.
      break_match; [|reflexivity].
      exfalso.
      eapply importFromCustomerAvailable.
      eapply ltNaIsNa.
      exact custIsBest.
    Qed.

    Instance stableCustomersDominanceSet : DominanceSet x.
      refine {|
        dominant := hasBestCustomer;
        nonInternalBest r dom := _;
        aBest r dom := _;
        designatedDominantRouter := _
      |}.
      - (* nonInternalBest *)
        exact (c2nii (bestCustomer r (getCustomer r dom))).
      - (* a Best *)
        exact (aCustomer (bestCustomer r (getCustomer r dom))).
      - intros.
        apply decidableAll.
      - (* designatedDominantRouter *)
        refine (_ (argMax (fun rCust => @aCustomerImp rCust.1 rCust.2) designatedCustomer)); revgoals. {
          eapply enumerableSigT.
          Unshelve.
          intros r'.
          apply eqDecAll.
        }
        intros [[r cust] h].
        exists r, cust.
        intros r' cust'.
        specialize (h (r';cust')).
        eauto.
    Defined.

    Instance enumerableHasBestCustomer r : enumerable (hasBestCustomer r).
      eapply enumerableDecidable.
    Unshelve.
      apply decidableAll.
    Qed.

    Lemma dominantRoutersBestCustomerIsBest r
      (dom: hasBestCustomer r) (bestCust : customer x r) :
      (forall cust : customer x r, (c2i bestCust, aCustomerImp bestCust) >= (c2i cust, aCustomerImp cust)) ->
      isBestCustomer r bestCust.
    Proof.
      intros locallyBest.
      destruct dom as [bestCust' dom].
      specialize (locallyBest bestCust').
      unfold isBestCustomer in *.
      intros r' cust'.
      specialize (dom r' cust').
      cbn in *.
      eapply preferenceRelationship in locallyBest.
      eapply prefTransitive; eauto.
    Qed.

    Lemma customerImportNotNa r dom :
      let cust := bestCustomer r (getCustomer r dom)
      in  import' (x; r) (c2i cust) p (aCustomer cust) <> notAvailable.
    Proof.
      Transparent import'.
      unfold import', bindRoutingInformation.
      Opaque import'.
      break_match.
      - (* aCustomer is available *)
        eapply importFromCustomerAvailable.
      - (* aCustomer is unavailable *)
        exfalso.
        revert Heqr0.
        generalize (getCustomer r dom).
        unfold bestCustomer.
        intros cust.
        cbn.
        match goal with
        | |- context[argMax ?F ?D] => destruct (argMax F D) as [bestCust bestCustIseBest]
        end.
        cbn.
        eapply aCustomerAvailable.
        apply dominantRoutersBestCustomerIsBest; eauto.
    Qed.

    Instance stableCustomersDominanceLemmas : DominanceLemmas x.
      constructor.
      - (* dominantDominatesDominants *)
        intros r dom r' dom'.
        unfold aBestImp, iBest; cbn; unfold bestCustomer, getCustomer.
        destruct (indefinite_description dom ) as [cust  best ].
        destruct (indefinite_description dom') as [cust' best'].
        cbn.
        match goal with |- context[argMax ?F ?C] => destruct (argMax F cust ) as [bestCust  locallyBest ] end.
        match goal with |- context[argMax ?F ?C] => destruct (argMax F cust') as [bestCust' locallyBest'] end.
        cbn; unfold aCustomerImp in *.
        eapply prefTransitive; [apply best|].
        eapply preferenceRelationship.
        apply (locallyBest cust).
      - (* globalDominanceInj *)
        refine (impliedConverges _ _ (combineConverges _ injectedConvergence
                                                         aCustomerConverges)).
        intros s [injConv aConv] r r' dom noDom'.
        specialize (injConv x r').
        break_match; [congruence|].
        unfold imports.
        rewrite injConv.
        Transparent import'.
        unfold import', bindRoutingInformation.
        Opaque import'.
        unfold aBestImp, iBest.
        apply notNaGtNa.
        apply customerImportNotNa.
      - (* globalDominanceExt *)
        apply (distributeForallConverges _); intros r.
        apply (distributeForallConverges _); intros r'.
        apply (distributeForallConverges _); intros xe.
        apply (distributeForallConverges _); intros re.
        apply (distributeForallConverges _); intros c.
        refine (impliedConverges _ _ aCustomerConverges).
        intros s stable dom noDom'.
        unfold dominant in *; cbn in *.
        unfold hasBestCustomer in *.
        cbn in *.
        destruct c as [cust custC| | ].
        + (* external customer *)
          (* there exists some router rBetter whose customer is > that the one of r' *)
          specialize (not_ex_all_not _ _ noDom'); clear noDom'; intros noDom'.
          refine (let custR' : customer x r' := (xe;(re;(cust;custC))) in _).
          specialize (noDom' custR').
          specialize (not_all_ex_not _ _ noDom'); clear noDom'; intros [rBetter noDom'].
          specialize (not_all_ex_not _ _ noDom'); clear noDom'; intros [rBetterCust rBetterCustIsBetter].
          specialize (stable r' custR').
          unfold imports.
          unfold c2i, nii2i, c2nii in stable.
          cbn in stable.
          rewrite <- stable.
          eapply prefTransitiveGtR; [|apply rBetterCustIsBetter]; clear rBetterCustIsBetter.
          (* there exist a customer of r that is equal or better than rBetter's customer *)
          inversion dom as [bestCust bestCustIsBest].
          specialize (bestCustIsBest rBetter rBetterCust).
          eapply prefTransitive; [apply bestCustIsBest|].
          (* the best announcement of r is even better than that customer *)
          unfold aBestImp.
          unfold iBest.
          unfold nonInternalBest.
          cbn.
          unfold bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [theBestCustomer theBestCustomerIsTheBest]
          end.
          cbn.
          eapply preferenceRelationship.
          apply theBestCustomerIsTheBest.
        + (* external provider *)
          (* <copy of A> *)
          unfold aBestImp, iBest, nii2i, c2nii, nonInternalBest.
          cbn.
          unfold c2nii, bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [bestCust bestCustIsTheBest]
          end.
          cbn.
          unfold imports.
          match goal with
          | |- context[adjRIBsIn ?R ?I] => generalize (adjRIBsIn R I); intros a
          end.
          refine (_ (aCustomerAvailable bestCust _)); revgoals. {
            apply dominantRoutersBestCustomerIsBest; eauto.
          }
          intros bestCustAvailable.
          (* </copy of A> *)
          specialize (customerGtProvider p x r bestCust); intros customerGtProvider.
          (* <copy of B> *)
          destruct bestCust as [? [? [? ?]]].
          Transparent import'.
          unfold import', bindRoutingInformation.
          unfold isBestCustomer in *.
          match goal with
          | |- context[match aCustomer ?C with _ => _ end] => destruct (aCustomer C) eqn:h'
          end; [|congruence].
          intros.
          (* </copy of B> *)
          (* <copy of C> *)
          break_match; revgoals. {
            (* na is worse than available *)
            cbn in *.
            eapply gtAnythingGtNA.
            eauto.
          Unshelve.
            all: first [exact xe | auto].
          }
          apply customerGtProvider.
          Opaque import'.
          (* </copy of C> *)
        + (* external peer *)
          (* <copy of A> *)
          unfold aBestImp, iBest, nii2i, c2nii, nonInternalBest.
          cbn.
          unfold c2nii, bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [bestCust bestCustIsTheBest]
          end.
          cbn.
          unfold imports.
          match goal with
          | |- context[adjRIBsIn ?R ?I] => generalize (adjRIBsIn R I); intros a
          end.
          refine (_ (aCustomerAvailable bestCust _)); revgoals. {
            apply dominantRoutersBestCustomerIsBest; eauto.
          }
          intros bestCustAvailable.
          (* </copy of A> *)
          specialize (customerGtPeer p x r bestCust); intros customerGt.
          (* <copy of B> *)
          destruct bestCust as [? [? [? ?]]].
          Transparent import'.
          unfold import', bindRoutingInformation.
          unfold isBestCustomer in *.
          match goal with
          | |- context[match aCustomer ?C with _ => _ end] => destruct (aCustomer C) eqn:h'
          end; [|congruence].
          (* </copy of B> *)
          (* <copy of C> *)
          intros.
          break_match; revgoals. {
            (* na is worse than available *)
            cbn in *.
            eapply gtAnythingGtNA.
            eauto.
          Unshelve.
            all: first [exact xe | auto].
          }
          apply customerGt.
          Opaque import'.
          (* </copy of C> *)
      - (* bestInstalled *)
        apply (distributeForallConverges _); intros r.
        apply (distributeForallConverges _); intros dom.
        refine (impliedConverges _ _ aCustomerConverges).
        intros s stable.
        symmetry.
        apply stable.
      - (* localDominanceInj *)
        refine (impliedConverges _ _ (combineConverges _ injectedConvergence
                                                         aCustomerConverges)).
        intros s [injConv aConv] r dom.
        specialize (injConv x r).
        break_match; [congruence|].
        unfold imports.
        rewrite injConv.
        Transparent import'.
        unfold import', bindRoutingInformation.
        Opaque import'.
        apply GtImpliesGe.
        apply preferenceRelationshipGt.
        unfold aBestImp, iBest.
        apply notNaGtNa.
        apply customerImportNotNa.
      - (* localDominanceExt *)
        apply (distributeForallConverges _); intros r.
        apply (distributeForallConverges _); intros dom.
        refine (impliedConverges _ _ aCustomerConverges).
        intros s stable xe re c.
        cbn.
        destruct c.
        + (* customer *)
          unfold aBestImp.
          unfold iBest.
          unfold nonInternalBest.
          cbn.
          unfold bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [theBestCustomer theBestCustomerIsTheBest]
          end.
          cbn.
          unfold aCustomerImp in *.
          refine (let cust : customer x r := (xe;(re;(h;c))) in _).
          specialize (theBestCustomerIsTheBest cust).
          cbn in *.
          eapply prefTransitive; [|apply theBestCustomerIsTheBest].
          unfold imports.
          rewrite stable.
          subst cust.
          cbn.
          unfold aCustomer.
          apply prefReflexive.
        + (* provider *)
          (* <copy of A> *)
          unfold aBestImp, iBest, nii2i, c2nii, nonInternalBest.
          cbn.
          unfold c2nii, bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [bestCust bestCustIsTheBest]
          end.
          cbn.
          unfold imports.
          match goal with
          | |- context[adjRIBsIn ?R ?I] => generalize (adjRIBsIn R I); intros a
          end.
          refine (_ (aCustomerAvailable bestCust _)); revgoals. {
            apply dominantRoutersBestCustomerIsBest; eauto.
          }
          intros bestCustAvailable.
          (* </copy of A> *)
          specialize (customerGtProvider p x r bestCust); intros customerGt.
          (* <copy of B> *)
          destruct bestCust as [? [? [? ?]]].
          Transparent import'.
          unfold import', bindRoutingInformation.
          unfold isBestCustomer in *.
          match goal with
          | |- context[match aCustomer ?C with _ => _ end] => destruct (aCustomer C) eqn:h'
          end; [|congruence].
          intros.
          (* </copy of B> *)
          apply GtImpliesGe.
          apply preferenceRelationshipGt.
          (* <copy of C> *)
          break_match; revgoals. {
            (* na is worse than available *)
            cbn in *.
            eapply gtAnythingGtNA.
            eauto.
          Unshelve.
            all: first [exact xe | auto].
          }
          apply customerGt.
          Opaque import'.
          (* </copy of C> *)
        + (* peer *)
          (* <copy of A> *)
          unfold aBestImp, iBest, nii2i, c2nii, nonInternalBest.
          cbn.
          unfold c2nii, bestCustomer.
          cbn.
          match goal with
          | |- context[argMax ?F ?D] => destruct (argMax F D) as [bestCust bestCustIsTheBest]
          end.
          cbn.
          unfold imports.
          match goal with
          | |- context[adjRIBsIn ?R ?I] => generalize (adjRIBsIn R I); intros a
          end.
          refine (_ (aCustomerAvailable bestCust _)); revgoals. {
            apply dominantRoutersBestCustomerIsBest; eauto.
          }
          intros bestCustAvailable.
          (* </copy of A> *)
          specialize (customerGtPeer p x r bestCust); intros customerGt.
          (* <copy of B> *)
          destruct bestCust as [? [? [? ?]]].
          Transparent import'.
          unfold import', bindRoutingInformation.
          unfold isBestCustomer in *.
          match goal with
          | |- context[match aCustomer ?C with _ => _ end] => destruct (aCustomer C) eqn:h'
          end; [|congruence].
          intros.
          (* </copy of B> *)
          apply GtImpliesGe.
          apply preferenceRelationshipGt.
          (* <copy of C> *)
          break_match; revgoals. {
            (* na is worse than available *)
            cbn in *.
            eapply gtAnythingGtNA.
            eauto.
          Unshelve.
            all: first [exact xe | auto].
          }
          apply customerGt.
          Opaque import'.
          (* </copy of C> *)
    Qed.

    Lemma ASWithStableCustomersConverges : ConvergentASWithRoute x.
      intros r.
      specialize (ASWithDominantRoutersConverges x r); intros h.
      break_match.
      - (* r is dominant *)
        eexists.
        eexists.
        constructor; [|apply h].
        unfold iBest; cbn.
        apply customerImportNotNa.
      - (* r not dominant *)
        eexists.
        eexists.
        constructor; [|apply h].
        unfold aBestImpExp, aBestImp, iBest; cbn.
        apply internalImportNotNa.
        apply internalExportNotNa.
        apply customerImportNotNa.
    Qed.
  End ASWithStableCustomersConverges.

  Section ASWithInitialAnnouncementConverges.
    Instance initialASDominanceSet : DominanceSet x0.
      refine {|
        dominant r := r = r0;
        nonInternalBest r dom := None;
        aBest r dom := available a0;
        designatedDominantRouter := exist _ r0 _
      |}.
      - intros r.
        constructor.
        destruct (r =? r0); eauto.
      - reflexivity.
    Defined.

    Lemma injectedGtExternal' : forall r xe re ce a,
      ~(@le RoutingInformation _
        (import' (x0;r0) injected p (available a0))
        (import' (x0;r) (mkReceived x0 r xe re (external ce)) p a)).
    Proof.
      intros.
      Transparent import'.
      unfold import', bindRoutingInformation; cbn.
      break_match.
      - apply injectedGtExternal.
      - specialize importFromInjectedAvailable; intros h.
        match goal with | |- _ < ?A => destruct A eqn:? end.
        + eapply availableGtNa.
        + unfold x0, a0, r0 in *.
          congruence.
    Qed.

    Instance initialASDominanceLemmas : DominanceLemmas x0.
      constructor.
      - (* dominantDominatesDominants *)
        intros.
        cbn in *.
        subst_max.
        apply prefReflexive.
      - (* globalDominanceInj *)
        refine (impliedConverges _ _ injectedConvergence).
        intros s h r r' dom noDom.
        unfold aBestImp, imports.
        cbn in *.
        subst_max.
        rewrite h; clear h.
        break_match. {
          assert (r' = r0) by crush.
          congruence.
        }
        Transparent import'.
        cbn.
        specialize importFromInjectedAvailable; intros h.
        match goal with | |- _ < ?A => destruct A eqn:? end.
        + eapply availableGtNa.
        + unfold x0, a0, r0 in *.
          congruence.
        Opaque import'.
      - (* globalDominanceExt *)
        refine (impliedConverges _ _ injectedConvergence).
        intros s h r r' xe re ce dom noDom.
        cbn in *.
        unfold aBestImp, imports.
        subst_max.
        eapply injectedGtExternal'.
      - (* bestInstalled *)
        refine (impliedConverges _ _ injectedConvergence).
        intros s h r dom.
        cbn in *.
        rewrite h; clear h.
        subst_max.
        break_match; [|congruence].
        reflexivity.
      - (* localDominanceInj *)
        refine (impliedConverges _ _ injectedConvergence).
        intros s h r dom.
        unfold aBestImp, imports.
        cbn in *.
        rewrite h; clear h.
        subst_max.
        break_match; [|congruence].
        apply prefReflexive.
      - (* localDominanceExt *)
        refine (impliedConverges _ _ injectedConvergence).
        intros s x r dom x' r' c.
        cbn in *.
        apply GtImpliesGe.
        apply preferenceRelationshipGt.
        unfold imports, aBestImp.
        cbn in *.
        subst_max.
        eapply injectedGtExternal'.
    Qed.

    Lemma ASWithInitialAnnouncementConverges : ConvergentASWithRoute x0.
      intros r.
      specialize (ASWithDominantRoutersConverges x0 r); intros h.
      break_match.
      - (* r is dominant *)
        eexists.
        eexists.
        constructor; [|apply h].
        unfold iBest; cbn.
        cbn in *.
        break_match; [|congruence].
        subst_max.
        unfold x0, a0, r0 in *.
        Transparent import'.
        apply importFromInjectedAvailable.
        Opaque import'.
      - (* r not dominant *)
        eexists.
        eexists.
        constructor; [|apply h].
        unfold aBestImpExp, aBestImp, iBest; cbn.
        apply internalImportNotNa.
        refine (_ : export' _ (nii2i None) _ _ _ <> _).
        apply internalExportNotNa.
        specialize (dominatorDom x0 r n); intros h'.
        cbn in h'.
        rewrite h'.
        Transparent import'.
        apply importFromInjectedAvailable.
        Opaque import'.
    Qed.
  End ASWithInitialAnnouncementConverges.

  Instance asConvergenceLemmas : ASConvergenceLemmas := {|
    InitialASConverges := ASWithInitialAnnouncementConverges;
    ASWithConvergentCustomersIsConvergent := ASWithStableCustomersConverges;
    ASWithConvergentNeighborsIsConvergent := ASWithStableIncomingLinksConverges
  |}.
End AllASTypesConverge.


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.UnionFindGraph.
Require Import CertiGraph.msl_application.GList.

Local Open Scope logic.

Section GList_UnionFind.

  Context {pSGG: pPointwiseGraph_GList}.
  Context {sSGG: sPointwiseGraph_GList nat unit}.

  Definition SGraph := (PointwiseGraph addr (addr * unit) (nat * addr) unit).

  Definition LGraph := (@LGraph addr (addr * unit) _ _ nat unit unit).
  Definition UFGraph := (@UFGraph addr (addr * unit) _ _ is_null_SGBA (fun x => (x, tt)) nat unit unit).

  Definition UFGraph_LGraph (G: UFGraph): LGraph := lg_gg G.
  Definition LGraph_SGraph (G: LGraph): SGraph := Graph_PointwiseGraph G.

  Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
  Local Coercion LGraph_SGraph: LGraph >-> SGraph.

  Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
  Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.
  Local Identity Coercion SGraph_SpatialGraph: SGraph >-> PointwiseGraph.

  Global Existing Instance fml.

  #[export] Instance maGraph(G: UFGraph): MathGraph G is_null_SGBA := maGraph G.
  #[export] Instance finGraph (G: UFGraph): FiniteGraph G := finGraph G.
  #[export] Instance liGraph (G: UFGraph):  LstGraph G (fun x => (x, tt)) := liGraph G.

  Definition vgamma := (@vgamma addr (addr * unit) SGBA_VE SGBA_EE is_null_SGBA (fun x => (x, tt)) nat unit unit).

  Definition Graph_gen_redirect_parent (g: UFGraph) (x: addr) (pa: addr) (H: weak_valid g pa) (Hv: vvalid g x) (Hn: ~ reachable g pa x): UFGraph :=
    Graph_gen_redirect_parent g x pa H Hv Hn.

  Lemma graph_gen_redirect_parent_ramify: forall (g: UFGraph) x r pa root (H: weak_valid g root) (Hv: vvalid g x) (Hn: ~ reachable g root x),
      vgamma g x = (r, pa) -> root <> null ->
      (vertices_at (vvalid g) g: pred)
        |-- vertex_at x (r, pa) * (vertex_at x (r, root) -* vertices_at (vvalid g) (Graph_gen_redirect_parent g x root H Hv Hn)).
  Proof.
    intros. assert (vgamma (Graph_gen_redirect_parent g x root H Hv Hn) x = (r, root)). {
      simpl in *. remember (updateEdgeFunc (dst (lg_gg g)) (x, tt) root (x, tt)).
      inversion H0. unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal. unfold updateEdgeFunc in *. destruct (equiv_dec (x, tt) (x, tt)).
      2: compute in c; exfalso; apply c; auto. subst a. destruct (SGBA_VE root null); [exfalso| ]; auto.
    } apply vertices_at_ramif_1; auto. eexists. split; [|split].
    - apply Ensemble_join_Intersection_Complement.
      + unfold Included, In; intro y. intros. subst. auto.
      + intros; destruct_eq_dec x x0; auto.
    - apply Ensemble_join_Intersection_Complement.
      + unfold Included, In; intro y. intros. subst. auto.
      + intros; destruct_eq_dec x x0; auto.
    - rewrite vertices_identical_spec. simpl. intros. change (lg_gg g) with (g: LGraph).
      rewrite Intersection_spec in H3. destruct H3. unfold Complement, In in H4. unfold vgamma, UnionFindGraph.vgamma. simpl. unfold updateEdgeFunc.
      destruct (equiv_dec (x, tt) (x0, tt)); auto. compute in e. exfalso. inversion e. auto.
  Qed.

  Definition ggrp_rel (g : UFGraph) (x root : addr) (g' : UFGraph) : Prop :=
    exists H1 H2 H3, g' = Graph_gen_redirect_parent g x root H1 H2 H3.

  Lemma graph_gen_redirect_parent_ramify_rel: forall (g: UFGraph) x r pa root g',
      ggrp_rel g x root g' ->
      vgamma g x = (r, pa) -> root <> null ->
      (vertices_at (vvalid g) g: pred)
        |-- vertex_at x (r, pa) * (vertex_at x (r, root) -* vertices_at (vvalid g) g').
  Proof. intros g x r pa root g' [Ha [Hb [Hc Heq]]] ? ?. subst g'. apply graph_gen_redirect_parent_ramify; auto. Qed.

  Definition Graph_vgen (G: UFGraph) (x: addr) (d: nat) : UFGraph := Graph_vgen G x d.

  Lemma graph_vgen_ramify: forall (g: UFGraph) x r1 r2 pa,
      vvalid g x -> vgamma g x = (r1, pa) -> (vertices_at (vvalid g) g: pred) |-- vertex_at x (r1, pa) * (vertex_at x (r2, pa) -* vertices_at (vvalid g) (Graph_vgen g x r2)).
  Proof.
    intros. assert (vgamma (Graph_vgen g x r2) x = (r2, pa)). {
      simpl in *. inversion H0. unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal. unfold update_vlabel. destruct (equiv_dec x x); auto. compute in c. exfalso; auto.
    } apply vertices_at_ramif_1; auto. eexists. split; [|split].
    - apply Ensemble_join_Intersection_Complement.
      + unfold Included, In; intro y. intros. subst. auto.
      + intros; destruct_eq_dec x x0; auto.
    - apply Ensemble_join_Intersection_Complement.
      + unfold Included, In; intro y. intros. subst. auto.
      + intros; destruct_eq_dec x x0; auto.
    - rewrite vertices_identical_spec. simpl. intros. change (lg_gg g) with (g: LGraph).
      rewrite Intersection_spec in H2. destruct H2. unfold Complement, In in H3. unfold vgamma, UnionFindGraph.vgamma. simpl.
      unfold update_vlabel. f_equal. destruct (equiv_dec x x0); auto. hnf in e. exfalso; auto.
  Qed.

  Lemma uf_under_bound_redirect_parent: forall (g: UFGraph) root x (Hw : weak_valid g root) (Hv : vvalid g x) (Hr: ~ reachable g root x),
      uf_root g x root -> uf_under_bound id g -> uf_under_bound id (Graph_gen_redirect_parent g x root Hw Hv Hr).
  Proof.
    intros. hnf in H0 |-* . simpl. unfold uf_bound, id in *. intros. destruct p as [p l]. destruct H. destruct (redirect_to_root g (liGraph g) _ _ _ _ _ Hv Hr H4 H2 H3).
    - destruct H5. apply H0; auto.
    - destruct H5 as [? [l1 [? ?]]]. subst l. subst v. simpl. destruct H as [l2 ?]. destruct l2 as [? l2]. assert (a = x) by (destruct H as [[? _] ?]; simpl in H; auto).
      subst a. destruct l2. 1: destruct H as [[_ ?] ?]; simpl in H; subst root; exfalso; apply Hr; apply reachable_refl; auto.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H7 H). unfold path_glue in H3. simpl in H3. destruct H3 as [[_ ?] [? _]].
      rewrite <- H5 in H3. pose proof (H0 _ H1 _ H6 H3). simpl in H8.
      clear -H8. rewrite app_length in *. simpl in *. intuition.
  Qed.

  Lemma uf_under_bound_redirect_parent_lt: forall (g: UFGraph) root x (Hw : weak_valid g root) (Hv : vvalid g x) (Hr: ~ reachable g root x),
      vlabel g x < vlabel g root -> (forall y, reachable g root y -> root = y) -> uf_under_bound id g -> uf_under_bound id (Graph_gen_redirect_parent g x root Hw Hv Hr).
  Proof.
    intros. hnf in H1 |-* . simpl. unfold uf_bound, id in *. intros. destruct p as [p l]. destruct (redirect_to_root g (liGraph g) _ _ _ _ _ Hv Hr H0 H3 H4).
    - destruct H5; apply H1; auto.
    - destruct H5 as [? [l1 [? ?]]]. subst l. clear H4. subst v. simpl. destruct H7 as [[_ ?] [? _]]. specialize (H1 _ Hv _ H5 H4). simpl in H1. rewrite app_length. simpl length.
      clear - H H1. unfold UFGraph_LGraph in H. assert (vlabel (lg_gg g) x < vlabel (lg_gg g) root) by intuition. intuition.
  Qed.

  Lemma uf_under_bound_redirect_parent_eq: forall (g: UFGraph) root x (Hw : weak_valid g root) (Hv : vvalid g x) (Hr: ~ reachable g root x),
      vlabel g x = vlabel g root -> (forall y, reachable g root y -> root = y) -> uf_under_bound id g ->
      uf_under_bound id (Graph_vgen (Graph_gen_redirect_parent g x root Hw Hv Hr) root (vlabel g root + 1)).
  Proof.
    intros. hnf in H1 |-* . simpl. unfold uf_bound, id, update_vlabel in *. intros. destruct p as [p l]. destruct (redirect_to_root g (liGraph g) _ _ _ _ _ Hv Hr H0 H3 H4).
    - destruct H5. specialize (H1 _ H2 _ H5 H6). simpl in H1 |-* . clear -H1. destruct (equiv_dec root v); [hnf in e; subst v |]; intuition.
    - destruct H5 as [? [l1 [? ?]]]. subst l. clear H4. subst v. destruct (equiv_dec root root). 2: compute in c; exfalso; apply c; auto. simpl. destruct H7 as [[_ ?] [? _]].
      specialize (H1 _ Hv _ H5 H4). simpl in H1. rewrite app_length. simpl. clear -H H1. unfold UFGraph_LGraph in *. assert (vlabel (lg_gg g) x = vlabel g root) by intuition. intuition.
  Qed.

  Definition make_set_Graph (default_dv: nat) (default_de: unit) (default_dg: unit) (v: addr) (g: UFGraph) (Hn: v <> null) (Hi: ~ vvalid g v) : UFGraph := make_set_Graph default_dv default_de default_dg v g Hn Hi.
End GList_UnionFind.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Coq.omega.Omega
        Fiat.Common.ilist2
        Fiat.Common.StringBound
        Fiat.ADT
        Fiat.ADT.ComputationalADT
        Fiat.ADTNotation
        Fiat.ADTRefinement
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

(* Computational ADT definitions for Tuples. *)
Section TupleADT.

  Open Scope string_scope.
  Open Scope methSig_scope.
  Open Scope consSig_scope.
  Open Scope cMethDef_scope.
  Open Scope cMethDefParsing_scope.
  Open Scope cConsDef_scope.

  Variable heading : Heading.   (* The heading of the tuple. *)

  (* Tuple Initialization *)
  Definition Tuple_Init := "Init".

  Definition InitTupleDom := @Tuple heading.

  Definition InitTupleSig : consSig :=
    {| consID := Tuple_Init;
       consDom := Vector.to_list (AttrList (HeadingRaw heading)) |}.

  (*Fixpoint InitTuple heading' :
    constructorType (@Tuple heading') (Vector.to_list (AttrList (HeadingRaw heading'))).
      refine (match heading' return
                    constructorType (@Tuple heading') (Vector.to_list (AttrList (HeadingRaw heading'))) with
              |
              |

  Definition InitTupleDef :=
    Def Constructor Tuple_Init (inits : InitTupleDom) : rep :=
      InitTuple inits. *)

  (* Getters and Setters for Tuples *)

  Definition GetTupleSig id aType :=
    Method ("Get" ++ id) : rep -> rep * aType.

  Definition SetTupleSig id aType :=
    Method ("Set" ++ id) : rep * aType -> rep.

  Definition TupleSigs'
             {n'}
             (HeadingTypes : Vector.t Type n')
             (HeadingNames : Vector.t string n')
    : Vector.t methSig (n' * 2) :=
    Vector.rect2
      (fun (n : nat) (_ : Vector.t Type n) (_ : Vector.t string n) =>
         Vector.t methSig (n * 2)) (Vector.nil methSig)
      (fun (n : nat) (_ : Vector.t Type n) (_ : Vector.t string n)
           (TupleSigs' : Vector.t methSig (n * 2)) (aType : Type)
           (id : string) =>
         Vector.cons methSig (GetTupleSig id aType) (S (n * 2))
                     (Vector.cons methSig (SetTupleSig id aType) (n * 2) TupleSigs'))
      HeadingTypes HeadingNames.

  Definition TupleSigs :=
    TupleSigs' (AttrList heading)
               (HeadingNames heading).

  Definition GetTupleDef
             (attr : Fin.t (NumAttr heading)) :
    cMethDef (Rep := @Tuple heading) (GetTupleSig (Vector.nth (HeadingNames heading) attr)
                                                  (Vector.nth (AttrList heading) attr)) :=
    Def Method _ (msg : rep)
    : rep * (Vector.nth (AttrList heading) attr) :=
      (msg, ith2 msg attr).

  Definition SetTupleDef
             (attr : Fin.t (NumAttr heading)) :
    cMethDef (Rep := @Tuple heading) (SetTupleSig (Vector.nth (HeadingNames heading) attr)
                                                  (Vector.nth (AttrList heading) attr)) :=
    (Def Method1 _ (msg : @Tuple heading) (val : Vector.nth (AttrList heading) attr) : rep :=
      replace_Index2 _ msg attr val)%cMethDefParsing.

  Definition TupleDefs'
           {n'}
           (HeadingTypes : Vector.t Type n')
           (HeadingNames : Vector.t string n')
    : (forall (attr : Fin.t n'),
          cMethDef (Rep := @Tuple heading) (GetTupleSig (Vector.nth HeadingNames attr)
                                                        (Vector.nth HeadingTypes attr)))
      -> (forall (attr : Fin.t n'),
             cMethDef (Rep := @Tuple heading) (SetTupleSig (Vector.nth HeadingNames attr)
                                                           (Vector.nth HeadingTypes attr)))
      -> ilist (B := cMethDef (Rep := @Tuple heading))
            (TupleSigs' HeadingTypes HeadingNames) :=
    Vector.rect2
      (fun n HeadingTypes HeadingNames =>
         (forall (attr : Fin.t n),
             cMethDef (Rep := @Tuple heading) (GetTupleSig (Vector.nth HeadingNames attr)
                                                           (Vector.nth HeadingTypes attr)))
         -> (forall (attr : Fin.t n),
                cMethDef (Rep := @Tuple heading) (SetTupleSig (Vector.nth HeadingNames attr)
                                                              (Vector.nth HeadingTypes attr)))
         -> ilist (n := n * 2) (B := cMethDef (Rep := @Tuple heading))
                  (TupleSigs' HeadingTypes HeadingNames)) (fun _ _ => ())
      (fun n HeadingTypes HeadingNames
           TupleDefs' aType id
           GetTupleDef' SetTupleDef' =>
         icons (GetTupleDef' Fin.F1)
               (icons (SetTupleDef' Fin.F1)
                      (TupleDefs' (fun n => GetTupleDef' (Fin.FS n))
                                  (fun n => SetTupleDef' (Fin.FS n)))))
      HeadingTypes HeadingNames.

    Definition TupleDefs :=
      TupleDefs' (AttrList heading) (HeadingNames heading)
                 GetTupleDef SetTupleDef.

    (* Tuple ADT Definitions *)
    Definition TupleADTSig : ADTSig :=
      BuildADTSig (Vector.cons _ InitTupleSig _ (Vector.nil _))
                  TupleSigs.

    (*Definition TupleADT : cADT TupleADTSig :=
      BuildcADT (icons InitTupleDef inil) TupleDefs. *)

    (* Support for building messages. *)

    (*Definition ConstructTuple subtopics :=
      CallConstructor TupleADT Tuple_Init subtopics. *)

    (* Support for calling message getters. *)
    Lemma BuildGetTupleMethodID_ibound'
          {n'}
          (HeadingTypes : Vector.t Type n')
          (HeadingNames : Vector.t string n')
      : forall (idx : Fin.t n'),
        Vector.nth (Vector.map methID (TupleSigs' HeadingTypes HeadingNames))
                   (Fin.depair idx Fin.F1) =
        ("Get" ++ Vector.nth HeadingNames idx)%string.
    Proof.
      pattern n', HeadingTypes, HeadingNames.
      eapply Vector.rect2.
      - intro; inversion idx.
      - intros; generalize dependent idx; intro; revert v1 v2 H.
        pattern n, idx.
        eapply Fin.rectS; simpl; intros; eauto.
    Qed.

    Definition BuildGetTupleMethodID
               (idx : Fin.t (NumAttr heading))
    : BoundedString (Vector.map methID TupleSigs) :=
      {| bindex := ("Get" ++ (Vector.nth (HeadingNames heading) idx))%string;
         indexb := {| ibound := Fin.depair idx (@Fin.F1 1);
                      boundi := BuildGetTupleMethodID_ibound' _ _ idx |}
      |}.

    (*Definition CallTupleGetMethod
               (r : Tuple)
               idx
      := cMethods TupleADT (ibound (indexb (BuildGetTupleMethodID idx))) r. *)

    (* Support for calling message setters. *)
    Lemma BuildSetTupleMethodID_ibound
          {n'}
          (HeadingTypes : Vector.t Type n')
          (HeadingNames : Vector.t string n')
      : forall (idx : Fin.t n'),
        Vector.nth (Vector.map methID (TupleSigs' HeadingTypes HeadingNames))
                   (Fin.depair idx (Fin.FS Fin.F1)) =
        ("Set" ++ Vector.nth HeadingNames idx)%string.
    Proof.
      pattern n', HeadingTypes, HeadingNames.
      eapply Vector.rect2.
      - intro; inversion idx.
      - intros; generalize dependent idx; intro; revert v1 v2 H.
        pattern n, idx.
        eapply Fin.rectS; simpl; intros; eauto.
    Qed.

    Definition BuildSetTupleMethodID
               (idx : Fin.t (NumAttr heading))
    : BoundedString (Vector.map methID TupleSigs) :=
      {| bindex := ("Set" ++ (Vector.nth (HeadingNames heading) idx))%string;
         indexb := {| ibound := Fin.depair idx (Fin.FS Fin.F1);
                      boundi := BuildSetTupleMethodID_ibound _ _ idx |}
      |}.

    (*Definition CallTupleSetMethod
               (r : Tuple)
               idx
      := cMethods TupleADT (ibound (indexb (BuildSetTupleMethodID idx))) r. *)

End TupleADT.


Require Import BagsInterface.
Require Import AdditionalLemmas.
Require Import EnsembleListEquivalence.

Ltac is_sumbool expr :=
  match type of expr with
    | (sumbool _ _) => idtac
    | _ => fail
  end.

Ltac unfold_functions expr :=
  match expr with
    | appcontext [ ?f _ ] => unfold f
  end.

Ltac destruct_ifs_inside conditional :=
  match conditional with
    | context [ if ?sub_conditional then _ else _ ] => destruct_ifs_inside sub_conditional
    | _ => first [ is_sumbool conditional; destruct conditional | progress unfold_functions conditional ]
  end.

Ltac destruct_ifs :=
  intros;
  repeat (match goal with
            | [ |- ?body ] =>
              destruct_ifs_inside body
          end; simpl in *).

Ltac prove_extensional_eq :=
  clear;
  unfold ExtensionalEq;
  destruct_ifs; first [ solve [intuition] | solve [exfalso; intuition] | idtac ].

Require Import String Arith.

Example ifs_destruction :
  forall w x y z,
    (if (if string_dec w x then true else false) then (if eq_nat_dec y z then false else true) else (if eq_nat_dec z y then true else false)) = (if (if eq_nat_dec y z then true else false) then (if string_dec x w then false else true) else (if string_dec x w then true else false)).
Proof.
  destruct_ifs; intuition.
Qed.

Require Import QueryStructureNotations.
Require Import ListImplementation.
Require Import BagsOfTuples.

Ltac autoconvert func :=
  match goal with
    | [ src := cons ?head ?tail |- list _ ] =>
      refine (func head _ :: _);
        [ solve [ eauto with * ] | clear src;
                            set (src := tail);
                            autoconvert func ]
    | [ src := nil |- list _ ] => apply []
    | _ => idtac
  end.

(* [mkIndex] builds a [BagPlusProof] record packaging an indexed
   with all its operations and proofs of correctness. *)
Ltac mkIndex heading attributes' :=
  set (src := attributes');
  assert (list (@ProperAttribute heading)) as decorated_source by autoconvert (@CheckType heading);
  apply (@NestedTreeFromAttributesAsCorrectBagPlusProof heading decorated_source).

Tactic Notation "lift" "list" "property" constr(prop) "as" ident(name) :=
  pose proof prop as name;
  setoid_rewrite EnsembleIndexedListEquivalence_lift_property in name;
  [ | eassumption].

Tactic Notation "call" "eapply" constr(hypothesis) "after" tactic1(preprocessor) :=
  first [ preprocessor; eapply hypothesis | eapply hypothesis ].

Tactic Notation
       "rewrite" "filter" "over" reference(indexed_storage)
       "using" "search" "term" constr(keyword) :=
  match goal with
    | [ H: EnsembleBagEquivalence ?bag_plus ?table ?storage
        |- appcontext [ filter ?filter1 (benumerate ?storage) ] ] =>
      let temp := fresh in
      let filter2 := constr:(bfind_matcher (Bag := BagPlus indexed_storage)
                                           keyword) in
          assert (ExtensionalEq filter1 filter2) as temp by prove_extensional_eq;
            rewrite (filter_by_equiv filter1 filter2 temp);
            clear temp
      end.

Tactic Notation
       "rewrite" "dependent" "filter" constr(filter1)
       "over" reference(indexed_storage)
       "using" "dependent" "search" "term" constr(keyword) :=
  let temp := fresh in
  let filter2 := constr:(fun x => bfind_matcher (Bag := BagPlus indexed_storage) (keyword x)) in
  assert (forall x, ExtensionalEq (filter1 x) (filter2 x)) as temp by prove_extensional_eq;
    setoid_rewrite (filter_by_equiv_meta filter1 filter2 temp);
    clear temp.

(* The following tactic is useful when we have a set of hypotheses
     of the form

     H0 : In DB tuple
     H  : tupleAgree tuple <COL :: x, ...> COL
     H' : forall tuple', In DB tuple' -> (tuple'!COL <> x)

     which essentially means that we have a tuple that's in the DB and
     matches another one on the COL column, and an hypothesis H' that
     guarantees that such a match is in fact impossible. In that case,
     it's essentially enough to call exfalso, which this tactic does
 *)

Tactic Notation "prove" "trivial" "constraints" :=
  unfold decides, not in *;
  intros;
  match goal with
    | [ H: tupleAgree _ _ (?column :: _) |- _ ] =>
      specialize (H column);
        exfalso;
        match goal with
          | [ H': _ |- _] =>
            eapply H';
              try eassumption;
              call eapply H after symmetry;
              simpl;
              auto
        end
  end.

Definition ID {A} := fun (x: A) => x.

Lemma ens_red {heading}
      {BagType TSearchTerm TUpdateTerm} :
  forall (y_is_bag: Bag BagType (@Tuple heading) TSearchTerm TUpdateTerm) x y,
    @EnsembleIndexedListEquivalence heading x (benumerate (Bag := y_is_bag) y) =
    (ID (fun y => EnsembleIndexedListEquivalence x (benumerate y))) y.
Proof.
  intros; reflexivity.
Qed.

Lemma EnsembleBagEquivalence_pick_new_index {heading} :
  forall storage (ens : Ensemble (@IndexedTuple heading)) seq,
    EnsembleBagEquivalence storage ens seq ->
    exists bound, UnConstrFreshIdx ens bound.
Proof.
  intros * (indexes & equiv) ** ;
  eapply EnsembleIndexedListEquivalence_pick_new_index; eauto.
  apply indexes.
Qed.

Lemma refine_bag_update_other_table :
  forall (db_schema : QueryStructureSchema) (qs : UnConstrQueryStructure db_schema)
         (index1 index2 : BoundedString) bag_store store Rel,
    EnsembleBagEquivalence bag_store (GetUnConstrRelation qs index2) store ->
    index1 <> index2 ->
      EnsembleBagEquivalence bag_store
                             (GetUnConstrRelation
                                (UpdateUnConstrRelation qs index1 Rel) index2)
                             store.
Proof.
  intros; rewrite get_update_unconstr_neq; eauto.
Qed.

Ltac refine_bag_update_other_table :=
  match goal with
    | [ |- appcontext [
               EnsembleBagEquivalence
                 ?bag
                 (GetUnConstrRelation
                    (UpdateUnConstrRelation ?qs ?index1 ?Rel) ?index2) ] ] =>
      apply (@refine_bag_update_other_table _ qs index1 index2 bag);
        [ eauto | intuition discriminate ]
  end.

(* Workaround Coq's algorithms not being able to infer ther arguments to refineEquiv_pick_pair *)
Ltac refineEquiv_pick_pair_benumerate :=
  setoid_rewrite refineEquiv_pick_pair;
  unfold ID; cbv beta.

Ltac snd_bdelete_correct search_term :=
  match goal with
      H : EnsembleBagEquivalence ?bag_plus (GetUnConstrRelation ?Rel' ?Ridx) ?bag
      |- EnsembleBagEquivalence
           ?bag_plus
           (GetUnConstrRelation
              (UpdateUnConstrRelation
                 ?Rel ?Ridx
                 (EnsembleDelete (GetUnConstrRelation ?Rel' ?Ridx) ?DeletedTuples))
              ?Ridx) _ =>
      eapply (@bdeletePlus_correct_DB_snd _ Rel Ridx bag_plus bag H DeletedTuples _ search_term);
        prove_extensional_eq
  end.

Ltac binsert_correct_DB :=
  match goal with
    | [ H: EnsembleBagEquivalence ?bag_plus
                                  (GetUnConstrRelation ?qs ?index)
                                  ?store,
        H0 : UnConstrFreshIdx (GetUnConstrRelation ?qs ?index) ?bound |- _ ] =>
      solve [ simpl; apply (binsertPlus_correct_DB qs index bag_plus store H _ bound H0) ]
  end.


From stdpp Require Export coPset.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export own.
From iris.base_logic.lib Require Import wsat.
From iris.prelude Require Import options.
Export invG.
Import uPred.

(** * Suffix subsets *)
Fixpoint coPset_suffixes_of_raw (p : positive) (E: coPset_raw) : coPset_raw :=
  match p with
  | 1 => E
  | p~0 => coPNode' false (coPset_suffixes_of_raw p E) (coPLeaf false)
  | p~1 => coPNode' false (coPLeaf false) (coPset_suffixes_of_raw p E)
  end%positive.
Lemma coPset_suffixes_of_wf p E : coPset_wf E → coPset_wf (coPset_suffixes_of_raw p E).
Proof. induction p; simpl; eauto. Qed.
Definition coPset_suffixes_of (p : positive) (E : coPset) : coPset :=
  coPset_suffixes_of_raw p (`E) ↾ coPset_suffixes_of_wf _ _ (proj2_sig E).
Lemma elem_coPset_suffixes_of p q E : p ∈ coPset_suffixes_of q E ↔ ∃ q', (p = Papp q' q) ∧ q' ∈ E.
Proof.
  unfold elem_of, coPset_elem_of; simpl; split.
  - revert p; induction q; intros [?|?|]; simpl;
      rewrite ?coPset_elem_of_node; naive_solver.
  - by intros [q' (->&Helem)]; induction q; simpl; rewrite ?coPset_elem_of_node.
Qed.
Lemma coPset_suffixes_of_top p :
  coPset_suffixes_of p ⊤ = coPset_suffixes p.
Proof.
  rewrite -leibniz_equiv_iff => x.
  rewrite elem_coPset_suffixes_of elem_coPset_suffixes. naive_solver set_solver.
Qed.

Definition coPset_inl (E: coPset) : coPset := coPset_suffixes_of (positives_flatten (1::nil))%positive E.
Definition coPset_inr (E: coPset) : coPset := coPset_suffixes_of (positives_flatten (2::nil))%positive E.

Lemma coPset_suffixes_of_infinite p E:
  (¬ set_finite E) → (¬ set_finite (coPset_suffixes_of p E)).
Proof.
  rewrite ?coPset_finite_spec; simpl. intros Hsuff.
  induction p; simpl; rewrite ?coPset_finite_node; rewrite ?andb_True //=; naive_solver.
Qed.

Lemma coPset_inl_inr_disj E1 E2 :
  coPset_inl E1 ## coPset_inr E2.
Proof.
  intros q. rewrite ?elem_coPset_suffixes_of.
  intros (q1'&Heq1&Hin1) (q2'&Heq2&Hin2).
  rewrite Heq1 in Heq2.
  apply positives_flatten_suffix_eq in Heq2 => //=.
Qed.

Definition AlwaysEn := coPset_inl ⊤.
Definition MaybeEn := coPset_inr.

Local Hint Extern 0 (AlwaysEn ## MaybeEn _) => apply coPset_inl_inr_disj : core.

Definition uPred_fupd_def `{!invG Σ} (E1 E2 : coPset) (P : iProp Σ) : iProp Σ :=
  wsat_all ∗ ownE (AlwaysEn ∪ MaybeEn E1) ==∗ ◇ (wsat_all ∗ ownE (AlwaysEn ∪ MaybeEn E2) ∗ P).
Definition uPred_fupd_aux : seal (@uPred_fupd_def). Proof. by eexists. Qed.
Definition uPred_fupd := uPred_fupd_aux.(unseal).
Global Arguments uPred_fupd {Σ _}.
Lemma uPred_fupd_eq `{!invG Σ} : @fupd _ uPred_fupd = uPred_fupd_def.
Proof. rewrite -uPred_fupd_aux.(seal_eq) //. Qed.

Lemma coPset_suffixes_of_union p E1 E2 :
  coPset_suffixes_of p (E1 ∪ E2) = coPset_suffixes_of p E1 ∪ coPset_suffixes_of p E2.
Proof.
  rewrite -leibniz_equiv_iff.
  intros x. set_unfold. rewrite ?elem_coPset_suffixes_of. set_unfold. naive_solver.
Qed.

Lemma coPset_suffixes_of_disj p E1 E2 :
  E1 ## E2 ↔ coPset_suffixes_of p E1 ## coPset_suffixes_of p E2.
Proof.
  set_unfold. split => Hin x.
  - rewrite ?elem_coPset_suffixes_of.
    intros (q1'&Heq1&Hin1) (q2'&Heq2&Hin2).
    rewrite Heq1 in Heq2.
    apply Papp_inj in Heq2; naive_solver.
  - intros. apply (Hin (Papp x p)); apply elem_coPset_suffixes_of; eauto.
Qed.

Lemma MaybeEn_union E1 E2 : MaybeEn (E1 ∪ E2) = MaybeEn E1 ∪ MaybeEn E2.
Proof. apply coPset_suffixes_of_union. Qed.
Lemma MaybeEn_disj E1 E2 : E1 ## E2 ↔ MaybeEn E1 ## MaybeEn E2.
Proof. apply coPset_suffixes_of_disj. Qed.
Lemma MaybeEn_infinite E:
  (¬ set_finite E) → (¬ set_finite (MaybeEn E)).
Proof. apply coPset_suffixes_of_infinite. Qed.

Lemma ownE_op_MaybeEn `{!invG Σ} E1 E2 :
  E1 ## E2 → ownE (MaybeEn (E1 ∪ E2)) ⊣⊢ ownE (MaybeEn E1) ∗ ownE (MaybeEn E2).
Proof. intros Hdisj. rewrite MaybeEn_union ownE_op //=. by apply coPset_suffixes_of_disj. Qed.

Lemma ownE_op_MaybeEn' `{!invG Σ} E1 E2 :
  ⌜ E1 ## E2 ⌝ ∧ ownE (MaybeEn (E1 ∪ E2)) ⊣⊢ ownE (MaybeEn E1) ∗ ownE (MaybeEn E2).
Proof. rewrite MaybeEn_union MaybeEn_disj ownE_op' //=. Qed.

Lemma uPred_fupd_mixin `{!invG Σ} : BiFUpdMixin (uPredI (iResUR Σ)) uPred_fupd.
Proof.
  split.
  - rewrite uPred_fupd_eq. solve_proper.
  - intros E1 E2 (E1''&->&?)%subseteq_disjoint_union_L.
    rewrite uPred_fupd_eq /uPred_fupd_def ?ownE_op // ?ownE_op_MaybeEn //.
    by iIntros "($ & $ & ($ & HE)) !> !> [$ [$ $]] !> !>" .
  - rewrite uPred_fupd_eq. iIntros (E1 E2 P) ">H [Hw HE]". iApply "H"; by iFrame.
  - rewrite uPred_fupd_eq. iIntros (E1 E2 P Q HPQ) "HP HwE". rewrite -HPQ. by iApply "HP".
  - rewrite uPred_fupd_eq. iIntros (E1 E2 E3 P) "HP HwE".
    iMod ("HP" with "HwE") as ">(Hw & HE & HP)". iApply "HP"; by iFrame.
  - intros E1 E2 Ef P HE1Ef. rewrite uPred_fupd_eq /uPred_fupd_def ?ownE_op // ownE_op_MaybeEn //.
    iIntros "Hvs (Hw & HAE & HE1 & HEf)".
    iMod ("Hvs" with "[Hw HAE HE1]") as ">($ & (HAE & HE2) & HP)"; first by iFrame.
    iDestruct (ownE_op_MaybeEn' with "[HE2 HEf]") as "[? $]"; first by iFrame.
    iIntros "!> !>". iFrame. by iApply "HP".
  - rewrite uPred_fupd_eq /uPred_fupd_def. by iIntros (????) "[HwP $]".
Qed.
Global Instance uPred_bi_fupd `{!invG Σ} : BiFUpd (uPredI (iResUR Σ)) :=
  {| bi_fupd_mixin := uPred_fupd_mixin |}.

Global Instance uPred_bi_bupd_fupd `{!invG Σ} : BiBUpdFUpd (uPredI (iResUR Σ)).
Proof. rewrite /BiBUpdFUpd uPred_fupd_eq. by iIntros (E P) ">? [$ $] !> !>". Qed.

Global Instance uPred_bi_fupd_plainly `{!invG Σ} : BiFUpdPlainly (uPredI (iResUR Σ)).
Proof.
  split.
  - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P) "H [Hw HE]".
    iAssert (◇ ■ P)%I as "#>HP".
    { by iMod ("H" with "[$]") as "(_ & _ & HP)". }
    by iFrame.
  - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P Q) "[H HQ] [Hw HE]".
    iAssert (◇ ■ P)%I as "#>HP".
    { by iMod ("H" with "HQ [$]") as "(_ & _ & HP)". }
    by iFrame.
  - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E P) "H [Hw HE]".
    iAssert (▷ ◇ ■ P)%I as "#HP".
    { iNext. by iMod ("H" with "[$]") as "(_ & _ & HP)". }
    iFrame. iIntros "!> !> !>". by iMod "HP".
  - rewrite uPred_fupd_eq /uPred_fupd_def. iIntros (E A Φ) "HΦ [Hw HE]".
    iAssert (◇ ■ ∀ x : A, Φ x)%I as "#>HP".
    { iIntros (x). by iMod ("HΦ" with "[$Hw $HE]") as "(_&_&?)". }
    by iFrame.
Qed.

Lemma ownE_mono_le_acc `{!invG Σ} E1 E2:
  E1 ⊆ E2 →
  ownE E2 -∗ ownE E1 ∗ (ownE E1 -∗ ownE E2).
Proof.
  iIntros (?). replace E2 with (E2 ∖ E1 ∪ E1).
  { rewrite ownE_op; last by set_solver. iIntros "(Hrest&$) H". iFrame. }
  { rewrite difference_union_L. set_solver. }
Qed.

Lemma ownE_weaken `{!invG Σ} E1 E2 : E2 ⊆ E1 → ownE E1 -∗ ownE E2.
Proof.
  iIntros (?) "H". by iDestruct (ownE_mono_le_acc with "H") as "($&_)".
Qed.

Lemma fupd_plain_soundness `{!invPreG Σ} E1 E2 (P: iProp Σ) `{!Plain P} :
  (∀ `{Hinv: !invG Σ}, ⊢ |={E1,E2}=> P) → ⊢ P.
Proof.
  iIntros (Hfupd). apply later_soundness. iMod wsat_alloc' as (Hinv) "[Hw HE]".
  iAssert (|={⊤,E2}=> P)%I as "H".
  { iMod (fupd_mask_subseteq E1) as "_"; first done. iApply Hfupd. }
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("H" with "[$Hw HE]") as "[Hw [HE >H']]"; iFrame.
  iApply (ownE_weaken with "HE"). set_solver.
Qed.

Lemma step_fupdN_soundness `{!invPreG Σ} φ n :
  (∀ `{Hinv: !invG Σ}, ⊢@{iPropI Σ} |={⊤,∅}=> |={∅}▷=>^n ⌜ φ ⌝) →
  φ.
Proof.
  intros Hiter.
  apply (soundness (M:=iResUR Σ) _  (S n)); simpl.
  apply (fupd_plain_soundness ⊤ ⊤ _)=> Hinv.
  iPoseProof (Hiter Hinv) as "H". clear Hiter.
  iApply fupd_plainly_mask_empty. iMod "H".
  iMod (step_fupdN_plain with "H") as "H". iModIntro.
  rewrite -later_plainly -laterN_plainly -later_laterN laterN_later.
  iNext. iMod "H" as %Hφ. auto.
Qed.

Lemma step_fupdN_soundness' `{!invPreG Σ} φ n :
  (∀ `{Hinv: !invG Σ}, ⊢@{iPropI Σ} |={⊤}[∅]▷=>^n ⌜ φ ⌝) →
  φ.
Proof.
  iIntros (Hiter). eapply (step_fupdN_soundness _ n)=>Hinv. destruct n as [|n].
  { by iApply fupd_mask_intro_discard; [|iApply (Hiter Hinv)]. }
   simpl in Hiter |- *. iMod Hiter as "H". iIntros "!>!>!>".
  iMod "H". clear. iInduction n as [|n] "IH"; [by iApply fupd_mask_intro_discard|].
  simpl. iMod "H". iIntros "!>!>!>". iMod "H". by iApply "IH".
Qed.


Require Import Lang.Syntax Lang.Bindings FinFun.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_L_bind_inj.

Local Fact disjoint_same_inv A (x : A) : disjoint \{x} \{x} → False.
Proof.
unfold disjoint ; rewrite inter_same ; intro H.
erewrite <- in_empty.
rewrite <- H.
rewrite in_singleton ; reflexivity.
Qed.

Lemma L_bind_lid_inj
L L' (f : L → lid L')
(Inj : Injective f)
(i1 i2 : lid L)
(Q1 : ∀ α, disjoint (Xs_lid (f α)) (Xs_lid i1))
(Q2 : ∀ α, disjoint (Xs_lid (f α)) (Xs_lid i2))
(H : L_bind_lid f i1 = L_bind_lid f i2) :
i1 = i2.
Proof.
destruct i1 as [ α1 | X1 ], i2 as [ α2 | X2 ] ; simpl in *.
+ specialize (Inj α1 α2 H) ; congruence.
+ exfalso.
  specialize (Q2 α1) ; rewrite H in Q2 ; simpl in Q2.
  apply disjoint_same_inv in Q2 ; auto.
+ exfalso.
  specialize (Q1 α2) ; rewrite <- H in Q1 ; simpl in Q1.
  apply disjoint_same_inv in Q1 ; auto.
+ crush.
Qed.

Lemma L_bind_lbl_inj
HV L L' (f : L → lid L')
(Inj : Injective f)
(l1 l2 : lbl HV L)
(Q1 : ∀ α, disjoint (Xs_lid (f α)) (Xs_lbl l1))
(Q2 : ∀ α, disjoint (Xs_lid (f α)) (Xs_lbl l2))
(H : L_bind_lbl f l1 = L_bind_lbl f l2) :
l1 = l2.
Proof.
destruct l1, l2 ; simpl in * ; try inversion H ; clear H ;
repeat match goal with
| [ H : L_bind_lid ?f _ = L_bind_lid ?f _ |- _ ] =>
  apply L_bind_lid_inj in H ; subst ; clear H
end ;
crush.
Qed.

Lemma L_bind_ef_inj
EV HV L L' (f : L → lid L')
(Inj : Injective f)
(ε1 ε2 : ef EV HV L)
(Q1 : ∀ α, disjoint (Xs_lid (f α)) (Xs_ef ε1))
(Q2 : ∀ α, disjoint (Xs_lid (f α)) (Xs_ef ε2))
(H : L_bind_ef f ε1 = L_bind_ef f ε2) :
ε1 = ε2.
Proof.
destruct ε1, ε2 ; simpl in * ; try inversion H ; clear H ;
repeat match goal with
| [ H : L_bind_lbl ?f _ = L_bind_lbl ?f _ |- _ ] =>
  apply L_bind_lbl_inj in H ; subst ; clear H
end ;
crush.
Qed.

End section_L_bind_inj.

Lemma lbl_EV_bind_hd
EV EV' HV V L (f : EV → eff EV' HV L)
(h : hd EV HV V L) :
lbl_hd (EV_bind_hd f h) = lbl_hd h.
Proof.
induction h ; crush.
Qed.

Lemma lbl_L_bind_hd EV HV V L L'
  (f : L → lid L') (h : hd EV HV V L) :
  lbl_hd (L_bind_hd f h) = L_bind_lbl f (lbl_hd h).
Proof.
  induction h ; crush.
Qed.

Lemma lbl_V_bind_hd EV HV V V' L
  (f : V → val EV HV V' L) (h : hd EV HV V L) :
  lbl_hd (V_bind_hd f h) = lbl_hd h.
Proof.
  induction h ; crush.
Qed.

Lemma lbl_HV_bind_hd EV EV' HV HV' V V' L
  (f : HV → hd EV HV' V L) (g : HV → hd EV' HV' V' L)
  (Q : ∀ p, lbl_hd (f p) = lbl_hd (g p))
  (h : hd EV' HV V' L) :
  lbl_hd (HV_bind_hd g h) = HV_bind_lbl f (lbl_hd h).
Proof.
  induction h ; crush.
Qed.

Lemma EV_bind_XEnv_empty
EV EV' HV (f : EV → eff EV' HV ∅) :
EV_bind_XEnv f empty = empty.
Proof.
apply map_empty.
Qed.

Lemma EV_bind_XEnv_single
EV EV' HV (f : EV → eff EV' HV ∅) X (T : ty EV HV ∅) (𝓔 : eff EV HV ∅) :
EV_bind_XEnv f (X ~ (T, 𝓔)) = X ~ (EV_bind_ty f T, EV_bind_eff f 𝓔).
Proof.
apply map_single.
Qed.

Lemma EV_bind_XEnv_concat
EV EV' HV (f : EV → eff EV' HV ∅) (Ξ Ξ' : XEnv EV HV) :
EV_bind_XEnv f (Ξ & Ξ') =
(EV_bind_XEnv f Ξ) & (EV_bind_XEnv f Ξ').
Proof.
apply map_concat.
Qed.

Lemma EV_bind_XEnv_dom
EV EV' HV (f : EV → eff EV' HV ∅) (Ξ : XEnv EV HV) :
dom (EV_bind_XEnv f Ξ) = dom Ξ.
Proof.
induction Ξ as [ | ? ? [? ?] IHΞ ] using env_ind.
+ rewrite EV_bind_XEnv_empty.
  repeat rewrite dom_empty.
  reflexivity.
+ rewrite EV_bind_XEnv_concat, EV_bind_XEnv_single.
  repeat rewrite dom_concat, dom_single.
  rewrite IHΞ.
  reflexivity.
Qed.

Lemma HV_bind_XEnv_empty
EV HV HV' V (f : HV → hd EV HV' V ∅) :
HV_bind_XEnv f (empty : XEnv EV HV) = empty.
Proof.
apply map_empty.
Qed.

Lemma HV_bind_XEnv_single
EV HV HV' V (f : HV → hd EV HV' V ∅) X (T : ty EV HV ∅) (𝓔 : eff EV HV ∅) :
HV_bind_XEnv f (X ~ (T, 𝓔)) = X ~ (HV_bind_ty f T, HV_bind_eff f 𝓔).
Proof.
apply map_single.
Qed.

Lemma HV_bind_XEnv_concat
EV HV HV' V (f : HV → hd EV HV' V ∅) (Ξ Ξ' : XEnv EV HV) :
HV_bind_XEnv f (Ξ & Ξ') =
(HV_bind_XEnv f Ξ) & (HV_bind_XEnv f Ξ').
Proof.
apply map_concat.
Qed.

Lemma HV_bind_XEnv_dom
EV HV HV' V (f : HV → hd EV HV' V ∅) (Ξ : XEnv EV HV) :
dom (HV_bind_XEnv f Ξ) = dom Ξ.
Proof.
induction Ξ as [ | ? ? [? ?] IHΞ ] using env_ind.
+ rewrite HV_bind_XEnv_empty.
  repeat rewrite dom_empty.
  reflexivity.
+ rewrite HV_bind_XEnv_concat, HV_bind_XEnv_single.
  repeat rewrite dom_concat, dom_single.
  rewrite IHΞ.
  reflexivity.
Qed.

Section section_binds_EV_bind.
Context (EV EV' HV : Set).
Context (f : EV → eff EV' HV ∅).
Context (X : var).

Lemma binds_EV_bind T 𝓔 (Ξ : XEnv EV HV) :
binds X (T, 𝓔) Ξ →
binds X (EV_bind_ty f T, EV_bind_eff f 𝓔) (EV_bind_XEnv f Ξ).
Proof.
intro Hbinds.
induction Ξ as [ | Ξ' X' [ T' 𝓔' ] IHΞ' ] using env_ind.
+ apply binds_empty_inv in Hbinds ; crush.
+ apply binds_concat_inv in Hbinds.
  rewrite EV_bind_XEnv_concat, EV_bind_XEnv_single.
  destruct Hbinds as [ Hbinds | Hbinds ].
  - apply binds_single_inv in Hbinds ; crush.
  - destruct Hbinds as [ FrX Hbinds ] ; auto.
Qed.

Lemma binds_EV_bind_inv
(T' : ty EV' HV ∅) (𝓔' : eff EV' HV ∅) (Ξ : XEnv EV HV) :
binds X (T', 𝓔') (EV_bind_XEnv f Ξ) →
∃ T 𝓔,
T' = EV_bind_ty f T ∧ 𝓔' = EV_bind_eff f 𝓔 ∧ binds X (T, 𝓔) Ξ.
Proof.
intro Hbinds'.
induction Ξ as [ | Ξ Y [ T 𝓔 ] IHΞ ] using env_ind.
+ rewrite EV_bind_XEnv_empty in Hbinds'.
  apply binds_empty_inv in Hbinds' ; crush.
+ rewrite EV_bind_XEnv_concat, EV_bind_XEnv_single in Hbinds'.
  apply binds_concat_inv in Hbinds'.
  destruct Hbinds' as [ Hbinds' | Hbinds' ].
  - apply binds_single_inv in Hbinds'.
    destruct Hbinds' as [ [] Heq ].
    inversion Heq ; subst.
    eauto.
  - destruct Hbinds' as [ FrX Hbinds' ].
    specialize (IHΞ Hbinds').
    destruct IHΞ as [T'' [𝓔'' [? [? ?]]]].
    repeat eexists ; eauto.
Qed.

End section_binds_EV_bind.

Section section_binds_HV_bind.
Context (EV HV HV' V : Set).
Context (f : HV → hd EV HV' V ∅).
Context (X : var).

Lemma binds_HV_bind T 𝓔 (Ξ : XEnv EV HV) :
binds X (T, 𝓔) Ξ →
binds X (HV_bind_ty f T, HV_bind_eff f 𝓔) (HV_bind_XEnv f Ξ).
Proof.
intro Hbinds.
induction Ξ as [ | Ξ' X' [ T' 𝓔' ] IHΞ' ] using env_ind.
+ apply binds_empty_inv in Hbinds ; crush.
+ apply binds_concat_inv in Hbinds.
  rewrite HV_bind_XEnv_concat, HV_bind_XEnv_single.
  destruct Hbinds as [ Hbinds | Hbinds ].
  - apply binds_single_inv in Hbinds ; crush.
  - destruct Hbinds as [ FrX Hbinds ] ; auto.
Qed.

Lemma binds_HV_bind_inv
(T' : ty EV HV' ∅) (𝓔' : eff EV HV' ∅) (Ξ : XEnv EV HV) :
binds X (T', 𝓔') (HV_bind_XEnv f Ξ) →
∃ T 𝓔,
T' = HV_bind_ty f T ∧ 𝓔' = HV_bind_eff f 𝓔 ∧ binds X (T, 𝓔) Ξ.
Proof.
intro Hbinds'.
induction Ξ as [ | Ξ Y [ T 𝓔 ] IHΞ ] using env_ind.
+ rewrite HV_bind_XEnv_empty in Hbinds'.
  apply binds_empty_inv in Hbinds' ; crush.
+ rewrite HV_bind_XEnv_concat, HV_bind_XEnv_single in Hbinds'.
  apply binds_concat_inv in Hbinds'.
  destruct Hbinds' as [ Hbinds' | Hbinds' ].
  - apply binds_single_inv in Hbinds'.
    destruct Hbinds' as [ [] Heq ].
    inversion Heq ; subst.
    eauto.
  - destruct Hbinds' as [ FrX Hbinds' ].
    specialize (IHΞ Hbinds').
    destruct IHΞ as [T'' [𝓔'' [? [? ?]]]].
    repeat eexists ; eauto.
Qed.

End section_binds_HV_bind.


From cap_machine Require Import rules_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ, MonRef: MonRefG (leibnizO _) CapR_rtc Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive Jnz_spec (regs: Reg) (dst src: RegName) : Reg → cap_lang.val → Prop :=
  | Jnz_spec_failure w:
      regs !! src = Some w →
      nonZero w = false →
      incrementPC regs = None →
      Jnz_spec regs dst src regs FailedV
  | Jnz_spec_success1 w regs':
      regs !! src = Some w →
      nonZero w = false →
      incrementPC regs = Some regs' →
      Jnz_spec regs dst src regs' NextIV
  | Jnz_spec_success2 w w':
      regs !! src = Some w →
      regs !! dst = Some w' →
      nonZero w = true →
      Jnz_spec regs dst src (<[PC := updatePcPerm w' ]> regs) NextIV.

  Lemma wp_Jnz Ep pc_p pc_g pc_b pc_e pc_a pc_p' w dst src regs :
    decodeInstrW w = Jnz dst src ->

    PermFlows pc_p pc_p' →
    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of (Jnz dst src) ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ[pc_p'] w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ Jnz_spec regs dst src regs' retv ⌝ ∗
        pc_a ↦ₐ[pc_p'] w ∗
        [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    assert (pc_p' ≠ O).
    { destruct pc_p'; auto. destruct pc_p; inversion Hfl. inversion Hvpc; naive_solver. }
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid_cap with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    unfold regs_of in Hri, Dregs.
    destruct (Hri src) as [wsrc [H'src Hsrc]]. by set_solver+.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (nonZero wsrc) eqn:Hnz; pose proof Hnz as H'nz;
      cbn in Hstep; rewrite /RegLocate Hsrc Hdst Hnz in Hstep.
    { inv Hstep. simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFrame. iApply "Hφ". iFrame. iPureIntro. econstructor 3; eauto. }

    destruct (incrementPC regs) eqn:HX; pose proof HX as H'X; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in HX.
      eapply updatePC_fail_incl with (m':=m) in HX; eauto. simplify_pair_eq.
      inv Hstep. iFrame. iApply "Hφ". iFrame. iPureIntro; econstructor; eauto. }

    destruct (incrementPC_success_updatePC _ m _ HX)
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & ->).
    eapply updatePC_success_incl with (m':=m) in HuPC; eauto. simplify_pair_eq.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iApply "Hφ". iFrame. iPureIntro. econstructor 2; eauto.
  Qed.

  Lemma wp_jnz_success_jmp E r1 r2 pc_p pc_g pc_b pc_e pc_a w w1 w2 pc_p' :
    decodeInstrW w = Jnz r1 r2 →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w
        ∗ ▷ r1 ↦ᵣ w1
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w1
          ∗ pc_a ↦ₐ[pc_p'] w
          ∗ r1 ↦ᵣ w1
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hr2) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmp2 E r2 pc_p pc_g pc_b pc_e pc_a w w2 pc_p' :
    decodeInstrW w = Jnz r2 r2 →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w2
          ∗ pc_a ↦ₐ[pc_p'] w
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr2) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr2") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC E pc_p pc_g pc_b pc_e pc_a w pc_p' :
    decodeInstrW w = Jnz PC PC →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm (inr ((pc_p,pc_g),pc_b,pc_e,pc_a))
          ∗ pc_a ↦ₐ[pc_p'] w }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc ϕ) "(>HPC & >Hpc_a) Hφ".
    iDestruct (map_of_regs_1 with "HPC") as "Hmap".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; [ by simplify_map_eq .. | ].
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_1 with "Hmap") as "?"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC1 E r2 pc_p pc_g pc_b pc_e pc_a w w2 pc_p' :
    decodeInstrW w = Jnz PC r2 →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm (inr ((pc_p,pc_g),pc_b,pc_e,pc_a))
          ∗ pc_a ↦ₐ[pc_p'] w
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr2) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr2") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC2 E r1 pc_p pc_g pc_b pc_e pc_a w w1 pc_p' :
    decodeInstrW w = Jnz r1 PC →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w
        ∗ ▷ r1 ↦ᵣ w1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w1
          ∗ pc_a ↦ₐ[pc_p'] w
          ∗ r1 ↦ᵣ w1 }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; [ by simplify_map_eq .. | ].
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_next E r1 r2 pc_p pc_g pc_b pc_e pc_a pc_a' w w1 pc_p' :
    decodeInstrW w = Jnz r1 r2 →
    PermFlows pc_p pc_p' → isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ[pc_p'] w
        ∗ ▷ r1 ↦ᵣ w1
        ∗ ▷ r2 ↦ᵣ inl 0%Z }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ[pc_p'] w
          ∗ r1 ↦ᵣ w1
          ∗ r2 ↦ᵣ inl 0%Z }}}.
  Proof.
    iIntros (Hinstr Hfl Hvpc Hpc_a' ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hr2) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; try incrementPC_inv; simplify_map_eq; eauto.
   { congruence. }
   { iApply "Hφ". iFrame. rewrite insert_insert.
     iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
  Qed.

End cap_lang_rules.


(************************************************************************)
(* Copyright (c) 2022, Gergei Bana, Rohit Chadha, Ajay Kumar Eeralla,   *)
(* Qianli Zhang                                                         *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Import Coq.micromega.Lia.
Require Export prop21.
Import ListNotations.

(*  *)

(**)
Proposition prop26_formula16_isinkc_TRue: forall s,
  (fun c0 c1 =>
     isinkc kc0 kc1 (＜ π2 (π1 (FGO1 c0 c1 ⫠ ⫠)), π2 (π1 (FGO2 c0 c1 ⫠ ⫠)), π2 (π1 (FGO3 c0 c1 ⫠ ⫠)) ＞) = TRue) (c0 s) (c1 s).
Proof.
  intros.
  unfold isinkc.
  assert (isin kc0 (＜ π2 (π1 FGO1 (c0 s) (c1 s) ⫠ ⫠), π2 (π1 FGO2 (c0 s) (c1 s) ⫠ ⫠), π2 (π1 FGO3 (c0 s) (c1 s) ⫠ ⫠) ＞) = FAlse).
    unfold isin.
    rewrite Tau1Tri, Tau2Tri, Tau3Tri.
    rewrite Freshkc0FGO1_16, Freshkc0FGO2_16, Freshkc0FGO3_16.
    repeat rewrite If_false.
    reflexivity.
  assert (isin kc1 (＜ π2 (π1 FGO1 (c0 s) (c1 s) ⫠ ⫠), π2 (π1 FGO2 (c0 s) (c1 s) ⫠ ⫠), π2 (π1 FGO3 (c0 s) (c1 s) ⫠ ⫠) ＞) = FAlse).
    unfold isin.
    rewrite Tau1Tri, Tau2Tri, Tau3Tri.
    rewrite Freshkc1FGO1_16, Freshkc1FGO2_16, Freshkc1FGO3_16.
    repeat rewrite If_false.
    reflexivity.
  rewrite H. clear H.
  rewrite H0. clear H0.
  repeat rewrite If_false.
  reflexivity.
Qed.

(* When both encryptions are bot, neither isinkc0 nor isinkc1 will success,
   so using prop11, we can get rid of those process checks to reduce Do to FDO *)

Proposition prop26_formula16_Do_FDO : forall s,
  (fun c0 c1 =>
     [b0 c0; b1 c1; acc0 c0 c1 & acc1 c0 c1;
     bnlcheck c0 n0 (fΦΦ3 c0 c1); bnlcheck c1 n1 (fΦΦ3 c0 c1);
  ＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞,
     ＜ ⫠, ⫠, Do (FGO1 c0 c1 ⫠ ⫠) (FGO2 c0 c1 ⫠ ⫠) (FGO3 c0 c1 ⫠ ⫠) ＞ ＞]) (c0 s) (c1 s)
 ~
   (fun c0 c1 =>
      [b0 c0; b1 c1; acc0 c0 c1 & acc1 c0 c1;
      bnlcheck c0 n0 (fΦΦ3 c0 c1); bnlcheck c1 n1 (fΦΦ3 c0 c1);
  ＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞,
     ＜ ⫠, ⫠, FDO (FGO1 c0 c1 ⫠ ⫠) (FGO2 c0 c1 ⫠ ⫠) (FGO3 c0 c1 ⫠ ⫠) ＞ ＞]) (c0 s) (c1 s).
Proof.
  intros.
  simpl.
  unfold Do.
  rewrite (prop26_formula16_isinkc_TRue s).
  repeat rewrite <- If_tf.
  reflexivity.
  unfold pchko. Provebool.
Qed.

(* formula 16 on page 40  *)
Proposition prop26_formula16 :
  (fun c0 c1 =>
     [b0 c0; b1 c1; acc0 c0 c1 & acc1 c0 c1;
     bnlcheck c0 n0 (fΦΦ3 c0 c1); bnlcheck c1 n1 (fΦΦ3 c0 c1);
  ＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞,
     ＜ ⫠, ⫠, Do (FGO1 c0 c1 ⫠ ⫠) (FGO2 c0 c1 ⫠ ⫠) (FGO3 c0 c1 ⫠ ⫠) ＞ ＞]) (c0 lhs) (c1 lhs)
 ~
   (fun c0 c1 =>
      [b0 c0; b1 c1; acc0 c0 c1 & acc1 c0 c1;
      bnlcheck c0 n0 (fΦΦ3 c0 c1); bnlcheck c1 n1 (fΦΦ3 c0 c1);
  ＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞,
     ＜ ⫠, ⫠, Do (FGO1 c0 c1 ⫠ ⫠) (FGO2 c0 c1 ⫠ ⫠) (FGO3 c0 c1 ⫠ ⫠) ＞ ＞]) (c0 rhs) (c1 rhs).
Proof.
  intros. simpl.

(* First we need to get rid of the "isinkc" check in Do, namely change Do to FDO*)
  rewrite (prop26_formula16_Do_FDO lhs).
  rewrite (prop26_formula16_Do_FDO rhs).

(* use commitment hidding *)
  apply (@CompHidEx (fun lx => let c0 := Nth 0 lx in let c1 := Nth 1 lx in
         [b0 c0; b1 c1; acc0 c0 c1 & acc1 c0 c1; bnlcheck c0 n0 (fΦΦ3 c0 c1); bnlcheck c1 n1 (fΦΦ3 c0 c1);
          ＜ ＜ e0 c0 c1 n0, e1 c0 c1 n1, dv (v1 c0 c1) (v2 c0 c1) (v3 c0 c1) (s26 c0 c1 (v3 c0 c1)) ＞,
             ＜ ⫠, ⫠, FDO (FGO1 c0 c1 ⫠ ⫠) (FGO2 c0 c1 ⫠ ⫠) (FGO3 c0 c1 ⫠ ⫠) ＞ ＞])
                     vot0 vot1 0 1).
  apply voteLen. lia.
  1, 3: ProveFresh.
  apply Freshc_kc0_Lemma26_16.
  apply Freshc_kc1_Lemma26_16.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export terms5.
Require Export computation7.
Require Export computation_exc.
Require Export computation_dec1.

Lemma decidable_isprog {o} :
  forall (t : @NTerm o),
    decidable (isprog t).
Proof.
  introv.
  apply decidable_eq_bool.
Qed.

Lemma decidable_isprogram {o} :
  forall (t : @NTerm o),
    decidable (isprogram t).
Proof.
  introv.
  destruct (decidable_isprog t) as [d|d];[left|right]; eauto 3 with slow.
  intro xx; destruct d; eauto 3 with slow.
Qed.

Lemma decidable_wf_term {o} :
  forall (t : @NTerm o),
    decidable (wf_term t).
Proof.
  introv.
  apply decidable_eq_bool.
Qed.

Lemma decidable_isvalue {o} :
  forall (t : @NTerm o),
    decidable (isvalue t).
Proof.
  introv.
  destruct t as [v|op bs]; try (complete (right; allsimpl; intro xx; inversion xx)).
  dopid op as [c|nc|e|a] Case; try (complete (right; allsimpl; intro xx; inversion xx)).
  destruct (decidable_isprogram (oterm (Can c) bs)) as [d|d];[left|right]; auto.
  introv xx; destruct d.
  inversion xx; auto.
Qed.

Lemma decidable_iscvalue {o} :
  forall (t : @CTerm o),
    decidable (iscvalue t).
Proof.
  introv.
  destruct_cterms.
  unfold iscvalue; simpl.
  apply decidable_isvalue.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ Aprime Bprimeprime Aprime /\ (col_ G Aprimeprime Aprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ Aprime Bprimeprime G))))))))))))))))))))))))))))))))) -> col_ A B G)).
Proof.
  time tac.
Qed.

End FOFProblem.