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

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

Section BGPConvergence.
  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 `{IS:@InitialState PR IT AT IP OD RU}.

  Variable e : evolutionFrom _ FairTransition s0.

  Instance eConvergence : Convergence _ := convergence (s0;e).

  Definition alwaysE P := always _ _ P (s0;e).

  Lemma inductiveAlways (P:_->Prop) : P s0 -> (forall s s', FairTransition s s' -> P s -> P s') -> alwaysE P.
    intros p t.
    unfold alwaysE, always.
    exists p.
    apply InductiveForall.
    exact t.
  Qed.

  Lemma inductiveAlwaysEx (P Q:_->Prop) : alwaysE Q -> P s0 ->
    (forall s s', FairTransition s s' -> Q s -> Q s' -> P s -> P s') -> alwaysE P.
  Proof.
    intros conv p t.
    unfold alwaysE, always in *.
    exists p.
    destruct conv as [q conv].
    eapply InductiveForallEx; eauto.
  Qed.

  Lemma alwaysEConverges {P} : alwaysE P -> converges P.
    intros h.
    exists 0.
    exact h.
  Qed.

  Definition linksAll s C := linkState (networkState' s) C.

  Definition TransitionEq (s0 s1:FairNetworkState) (t:FairTransition s0 s1) : Prop.
    refine (_ \/ _).
    + refine (_ /\ _).
      - refine (networkState' s0 = networkState' s1).
      - refine (forall srcX srcR dstX dstR (c:link srcX srcR dstX dstR), _ : Prop).
        refine (let C := mkConnection srcX srcR dstX dstR c in _).
        refine (forall h h', linkTimer s0 C h = S (linkTimer s1 C h')).
    + refine (exists (mp:Prefix) (ma:RoutingInformation), _).
      refine (exists mSrcX mSrcR mDstX mDstR (mc:link mSrcX mSrcR mDstX mDstR), _).
      pose (mi := mkReceived mDstX mDstR mSrcX mSrcR mc).
      pose (ins p x r i := if @eqDecide (∑ p, ∑ x, ∑ r, incoming (x;r)) _
                                        (mp;(mDstX;(mDstR;mi)))
                                        (p ;(x    ;(r    ;i)))
                         then ma
                         else adjRIBsIn (ribs s0 x r) (i,p)).
      pose (imports p x r i := import' (x;r) i p (ins p x r i)).
      pose (iBest p x r := bestIncoming (x;r) (imports p x r)).
      pose (loc p x r := if (mp;(mDstX;mDstR)) =? (p;(x;r))
                       then imports p x r (iBest p x r)
                       else locRIB (ribs s0 x r) p).
      pose (exports p x r o := if (mp;(mDstX;mDstR)) =? (p;(x;r))
                             then export' (x;r) (iBest p x r) o p (loc p x r)
                             else adjRIBsOut (ribs s0 x r) (o,p)).
      refine (_ /\ _ /\ _ /\ _ /\ _).
      - refine (forall p x r i, adjRIBsIn (ribs s1 x r) (i,p) = ins p x r i).
      - refine (forall p x r, locRIB (ribs s1 x r) p = loc p x r).
      - refine (forall p x r o, adjRIBsOut (ribs s1 x r) (o,p) = exports p x r o).
      - refine (forall srcX srcR dstX dstR (c:link srcX srcR dstX dstR), _ : Prop).
        refine (let C := mkConnection srcX srcR dstX dstR c in _).
        refine (if @eqDecide (∑ x, ∑ r, ∑ x', ∑ r', link x r x' r') _
                             (mSrcX;(mSrcR;(mDstX;(mDstR;mc))))
                             (srcX ;(srcR ;(dstX ;(dstR ;c)))) then _ else _). {
          exact (linksAll s0 C = updateMessage mp ma :: linksAll s1 C).
        } {
          refine (linksAll s1 C = _).
          refine (if (mDstX;mDstR) =? (srcX;srcR) then _ else _). {
            refine (let o : outgoing (srcX; srcR) := ((dstX;dstR);c) in _).
            refine (if exports mp srcX srcR o =? adjRIBsOut (ribs s0 srcX srcR) (o,mp) then _ else _). {
              exact (linksAll s0 C).
            } {
              exact (linksAll s0 C ++ [updateMessage mp (exports mp srcX srcR o)]).
            }
          } {
            exact (linksAll s0 C).
          }
        }
      - refine (forall srcX srcR dstX dstR (c:link srcX srcR dstX dstR), _ : Prop).
        refine (let C := mkConnection srcX srcR dstX dstR c in _).
        refine (if @eqDecide (∑ x, ∑ r, ∑ x', ∑ r', link x r x' r') _
                             (mSrcX;(mSrcR;(mDstX;(mDstR;mc))))
                             (srcX ;(srcR ;(dstX ;(dstR ;c)))) then _ else _). {
          exact (forall h, linkTimer s0 C h = 0).
        } {
          exact (forall h h', linkTimer s0 C h = S (linkTimer s1 C h')).
        }
  Defined.

  Lemma noLinkToSameRouter {x r} (c:link x r x r) : False.
    inversion c as [x' r' c'|]; revgoals.
    + (* internal *)
      crush.
    + (* external *)
      inversion c' as [h | h | ].
      * (* customer to provider *)
        eapply well_founded_irreflexive.
        apply h.
      * (* provider to customer *)
        eapply well_founded_irreflexive.
        apply h.
      * (* peer to peer *)
        apply (peerToPeerIrreflexive x).
        assumption.
  Unshelve.
    apply customerToProviderWellFounded.
    apply customerToProviderWellFounded.
  Qed.

  Lemma transitionEq s0 s1 t : TransitionEq s0 s1 t.
  Proof.
    destruct t as [nt ft].
    destruct ft; revgoals. {
      (* holds for skip *)
      left.
      constructor; [reflexivity|].
      subst lt.
      cbn.
      intros.
      generalize_proofs.
      reflexivity.
    }
    right.
    destruct c as [[[mSrcX mSrcR] [mDstX mDstR]] mc].
    destruct m as [mp ma].
    exists mp, ma, mSrcX, mSrcR, mDstX, mDstR, mc.
    repeat break_let.
    match goal with
    | |- (forall p x r, @?A p x r) /\ (forall p x r, @?B p x r) /\ (forall p x r, @?C p x r) /\ ?D /\ ?E => enough ((forall p x r, A p x r /\ B p x r /\ C p x r) /\ (D /\ E)) as h
    end. {
      destruct h as [h h'].
      repeat constructor.
      all: first [intros p x r; specialize (h p x r); tauto|tauto].
    }
    apply reuseConjProof; [|constructor].
    - intros p x r.
      cbn.
      unfold overwrite'.
      break_match; revgoals. {
        (* different AS or router *)
        repeat constructor.
        - intros i.
          subst ins; cbn.
          eliminate_dead_code.
          reflexivity.
        - subst loc; cbn.
          eliminate_dead_code.
          reflexivity.
        - intros o.
          subst exports; cbn.
          eliminate_dead_code.
          reflexivity.
      }
      (* same AS and router *)
      match goal with
      | e:_=_ |- _ => inversion e
      end.
      subst_max.
      break_sig_uip.
      subst_max.
      match goal with
      | e:_=_ |- _ => rewrite (UIP_refl _ _ e); clear e
      end.
      Opaque eqDecide.
      Opaque enumerate.
      cbn.
      unfold overwrite, overwrite', lookup.
      destruct (mp =? mp); [|congruence].
      destruct (mp =? p); revgoals. {
        (* different prefix *)
        cbn.
        destruct (p =? mp); [congruence|].
        repeat constructor.
        - intros i.
          subst ins; cbn.
          break_match; [|reflexivity].
          break_sig.
          break_sig_uip.
          break_sig_uip.
          subst_max.
          congruence.
        - subst loc; cbn.
          eliminate_dead_code.
          reflexivity.
        - intros o.
          subst exports; cbn.
          eliminate_dead_code.
          reflexivity.
      }
      (* same prefix *)
      subst_max.
      destruct (p =? p); [|congruence].
      match goal with
      |- context [argMax ?F ?D] => remember (proj1_sig (argMax F D)) as iMax
      end.
      apply reuseConjProof.
      + (* adjRIBsIn works *)
        intros i.
        subst ins mi; cbn.
        unfold mkReceived.
        break_match; revgoals. {
          (* adjRIBs is not overwritten by received announcement *)
          break_match; [|reflexivity].
          repeat break_sig_uip.
          congruence.
        }
        (* adjRIBs is overwritten by received announcement *)
        subst.
        break_match; [reflexivity|].
        exfalso.
        repeat break_sig_uip.
        unfold not in *.
        intuition.
      + intros h.
        rewrite h.
        assert (iMax = iBest p mDstX r) as h'. {
          subst iMax.
          cbn.
          Transparent argMax.
          unfold argMax.
          cbn.
          Opaque argMax.
          f_equal.
          extensionality i.
          rewrite h.
          reflexivity.
        }
        apply reuseConjProof.
        * (* locRIBs works *)
          unfold loc.
          eliminate_dead_code.
          subst imports.
          cbn beta.
          rewrite h'.
          reflexivity.
        * (* adjRIBsOut works *)
          intros h'' o.
          unfold exports.
          eliminate_dead_code.
          rewrite h''.
          rewrite h'.
          reflexivity.
    - (* holds for messages on links *)
      Opaque forwardHandler.
      match goal with h:_ |- _ => rename h into ribFacts end.
      intros srcX srcR dstX dstR c.
      break_let.
      Transparent forwardHandler.
      Opaque import' export'.
      unfold forwardHandler in *.
      unfold routerHandler in *.
      unfold build in *.
      unfold lookup in *.
      unfold mkConnection in *.
      unfold linksAll.
      unfold networkState'.
      simpl.
      unfold update'.
      unfold overwrite'.
      subst C.
      break_match.
      + (* router receives message, message removed from link *)
        repeat break_sig.
        subst_max.
        break_match; revgoals. {
          exfalso.
          unfold not in *.
          intuition.
        }
        match goal with h:_=_ |- _ => destruct h end.
        unfold eq_rect_r.
        unfold eq_sym.
        simpl.
        unfold lookup.
        match goal with
        | |- context [E ?C] => enough (E C = []) as h
        end. {
          rewrite h.
          rewrite app_nil_r.
          reflexivity.
        }
        cbn.
        break_match; [|reflexivity].
        (* cannot send from src to dst *)
        exfalso.
        break_sig.
        subst_max.
        exact (noLinkToSameRouter c).
      + symmetry.
        subst_max.
        match goal with
        | |- context [match ?C with left _ => _ | right _ => ls _ end] => destruct C as [h|]
        end. {
          exfalso.
          inversion h.
          subst_max.
          inversion h.
          assert (srcR = mSrcR) by crush.
          subst_max.
          assert (dstR = mDstR) by crush.
          subst_max.
          break_sig_uip.
          subst_max.
          congruence.
        }
        break_match; revgoals. {
          (* message sent to some random router *)
          match goal with
          | |- context [E ?C] => enough (E C = []) as h
          end. {
            rewrite h.
            rewrite app_nil_r.
            reflexivity.
          }
          cbn.
          break_match; congruence.
        }
        (* router sends message, message added to link *)
        destruct (ribFacts mp srcX srcR) as [_ [_ ribOutFacts]].
        unfold const in *.
        Opaque updateSendProcess.
        Opaque decisionProcess.
        cbn.
        symmetry.
        break_match; [|congruence].
        break_sig.
        subst_max.
        match goal with h:_=_ |- _ => rewrite (UIP_refl _ _ h); clear h end.
        cbn.
        subst ns'.
        cbn in ribOutFacts.
        unfold overwrite' in ribOutFacts.
        match goal with h : context[match ?A with _ => _ end] |- _ => destruct A as [e'|]; [|congruence] end.
        rewrite (UIP_refl _ _ e') in *.
        clear e'.
        cbn in ribOutFacts.
        Transparent updateSendProcess.
        unfold updateSendProcess.
        unfold lookup.
        unfold build.
        rewrite ribOutFacts.
        clear ribOutFacts ribFacts.
        break_match. {
          (* ribOut didn't change *)
          break_match; [|crush].
          cbn.
          rewrite app_nil_r.
          reflexivity.
        }
        (* ribOut changed *)
        idtac.
        break_match; [crush|].
        reflexivity.
    - intros srcX srcR dstX dstR c.
      break_let.
      break_match.
      + (* link message delivered *)
        repeat break_sig; subst_max.
        subst lt.
        cbn.
        unfold C.
        unfold mkConnection.
        unfold update', overwrite'.
        break_match; revgoals. {
          cbn in *.
          congruence.
        }
        match goal with
        | e:_=_ |- _ => rewrite (UIP_refl _ _ e); clear e
        end.
        cbn.
        intros h.
        reflexivity.
      + (* link message not delivered *)
        subst lt.
        cbn.
        unfold C.
        unfold mkConnection.
        unfold update', overwrite', build, lookup.
        break_match. {
          exfalso.
          match goal with e:_<>_ |- _ => apply e; clear e end.
          inversion e0.
          subst_max.
          assert (srcR = mSrcR) by crush.
          assert (dstR = mDstR) by crush.
          subst_max.
          assert (c = mc) by crush.
          subst_max.
          reflexivity.
        }
        intros h h'.
        generalize_proofs.
        reflexivity.
  Qed.

  Lemma noLinkToSameRouter' {x r x' r'} (c:link x r x' r') : (x;r) <> (x';r').
    intros h.
    break_sig.
    subst_max.
    apply (noLinkToSameRouter c).
  Qed.

  Definition ribsFromInInductive s0 s1 (t:FairTransition s0 s1) :
    ribsFromIn s0 -> ribsFromIn s1.
  Proof.
    intros h0 p x r.
    destruct (transitionEq s0 s1 t) as [tEq|tEq]. {
      (* skip transition *)
      destruct tEq as [tEq _].
      unfold ribs, links in *.
      cbn in *.
      rewrite <- tEq.
      apply h0.
    }
    clear t.
    break_let_as imports1.
    break_let_as iBest1.
    destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
    repeat break_let.
    destruct tEq as [inEq [locEq [outEq [_ _]]]].
    specialize (h0 p x r).
    break_let_as imports0.
    break_let_as iBest0.
    assert (imports1 = imports p x r) as h. {
      (* rewrite adjRIbsin under binder *)
      unfold imports1, imports.
      extensionality i.
      f_equal.
      apply inEq.
    }
    remember iBest1 as iBest1'; subst iBest1; rename iBest1' into iBest1.
    rewrite h in *; clear h imports1.
    destruct h0 as [locH0 outH0].
    apply reuseConjProof.
    - (* locRIB *)
      rewrite locEq.
      clear outH0 outEq inEq locEq exports s1.
      unfold loc; clear loc.
      break_if; revgoals. {
        (* this router didn't receive message *)
        rewrite locH0; clear locH0.
        subst imports0 imports ins.
        cbn beta.
        repeat eliminate_dead_code.
        enough (iBest0 = iBest1) by congruence.
        subst iBest0 iBest1.
        f_equal.
        extensionality i.
        repeat eliminate_dead_code.
        reflexivity.
      }
      repeat break_sig; subst_max.
      subst iBest.
      cbn beta.
      reflexivity.
    - intros locH1 o.
      rewrite outEq.
      subst exports.
      cbn beta.
      break_if; revgoals. {
        (* this router didn't receive message *)
        rewrite outH0; clear outH0.
        subst imports0 imports ins.
        cbn beta.
        repeat eliminate_dead_code.
        enough (iBest0 = iBest1) by congruence.
        subst iBest0 iBest1.
        f_equal.
        extensionality i.
        repeat eliminate_dead_code.
        reflexivity.
      }
      rewrite <- locH1.
      rewrite <- locEq.
      f_equal.
      subst iBest iBest1.
      reflexivity.
  Qed.

  Lemma lastIgnoresPrefix {A} {l a t} {d:A} : last (l ++ (a :: t)) d = last (a :: t) d.
    induction l as [|a' l' rec].
    - reflexivity.
    - rewrite <- rec; clear rec.
      cbn.
      destruct l'; reflexivity.
  Qed.

  Definition inOutRIBsInductive s0 s1 (t:FairTransition s0 s1) :
    inOutRIBs s0 -> inOutRIBs s1.
  Proof.
    intros h0 p x r x' r' c.
    cbv delta [ribs links].
    refine (_).
    repeat break_let.
    specialize (noLinkToSameRouter' c); intros neqR.
    destruct (transitionEq s0 s1 t) as [tEq|tEq]. {
      (* skipping *)
      destruct tEq as [tEq _].
      rewrite <- tEq.
      apply h0.
    }
    destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
    repeat break_let.
    destruct tEq as [inEq [locEq [outEq [linkEq _]]]].
    (* specialize h0 *)
    specialize (h0 p _ _ _ _ c).
    unfold inOutRIBs, ribs, links, linksAll, mkConnection in *.
    (* rewrite adjRIBsIn *)
    specialize (inEq p x' r' i).
    unfold ribs in inEq.
    rewrite inEq.
    (* rewrite adjRIBsOut *)
    specialize (outEq p x r o).
    unfold ribs in outEq.
    rewrite outEq.
    (* rewrite link *)
    specialize (linkEq _ _ _ _ c).
    clear inEq locEq outEq.
    subst C.
    break_if. {
      (* r' is receiving message from r *)
      repeat break_sig; subst_max.
      subst ins mi i exports o.
      cbv beta.
      repeat eliminate_dead_code.
      clear loc.
      rewrite h0; clear h0.
      rewrite linkEq; clear linkEq.
      refine (_ : last (_ _ ([_] ++ _)) _ = _).
      rewrite projLinkApp.
      match goal with
      |- context [projLink p (linkState ?A ?B)] => generalize (projLink p (linkState A B))
      end; intros oldMs.
      match goal with
      |- context [adjRIBsIn ?A ?B] => generalize (adjRIBsIn A B)
      end; intros ribsIn.
      unfold projLink.
      destruct oldMs; revgoals. {
        (* no more messages on the link *)
        rewrite lastIgnoresPrefix.
        exact lastNonEmptyList.
      } {
        (* still messages on the link *)
        break_match; eliminate_dead_code; reflexivity.
      }
    }
    break_if. {
      (* r is receiving message, and thus potentially sending a message to r' *)
      repeat break_sig; subst_max.
      rewrite linkEq; clear linkEq.
      subst i o ins exports loc.
      cbn beta.
      repeat eliminate_dead_code.
      break_if. {
        (* same prefix *)
        repeat break_sig; subst_max.
        break_if. {
          (* ribOut didn't change, no message sent *)
          unfold mkOutgoing in *.
          repeat break_sig.
          congruence.
        }
        rewrite projLinkApp.
        cbn.
        eliminate_dead_code.
        rewrite lastAppend.
        reflexivity.
      } {
        (* different prefix *)
        break_if. {
          (* ribOut didn't change, no message sent *)
          unfold mkOutgoing in *.
          repeat break_sig.
          congruence.
        }
        rewrite projLinkApp.
        cbn.
        eliminate_dead_code.
        rewrite app_nil_r.
        assumption.
      }
    }
    unfold ribs, links in *.
    rewrite linkEq; clear linkEq.
    subst exports ins o i mi.
    cbn beta.
    eliminate_dead_code.
    rewrite h0.
    f_equal.
    break_if. {
      unfold mkReceived in *.
      repeat break_sig; subst_max.
      match goal with
      | h:received ?A = received ?B |- _ => assert (A = B) by crush
      end.
      assert (mSrcX = x) by crush.
      subst_max.
      assert (mSrcR = r) by crush.
      subst_max.
      assert (mc = c) by crush.
      congruence.
    }
    reflexivity.
  Qed.

  Lemma inOutRIBsConverges : alwaysE inOutRIBs.
    exact (inductiveAlways _ initiallyInOutRIBs inOutRIBsInductive).
  Qed.

  Lemma ribsFromInConverges : alwaysE ribsFromIn.
    exact (inductiveAlways _ initiallyRibsFromIn ribsFromInInductive).
  Qed.

  Lemma specializeExists {A B} {P:A->Prop} (f:B->A) : (exists b, P (f b)) -> (exists a, P a).
    intros [b Pb].
    eexists.
    exact Pb.
  Qed.

  Section LinkPropertyConvergence.
    Variable prefix : Prefix.
    Variable Q : RoutingInformation -> Prop.
    Variable x : AS.
    Variable r : router x.
    Variable x': AS.
    Variable r': router x'.
    Variable c : link x r x' r'.

    Local Definition C := mkConnection x r x' r' c.
    Local Definition o := mkOutgoing x r x' r' c.

    Local Definition P p a := p = prefix -> Q a.

    Local Definition forward n := (fastForward _ _ (s0;e) n).1.
    Local Definition eventuallyF P := eventually _ FairTransition P (s0;e).
    Local Definition afterF n P := always _ _ P (fastForward _ _ (s0;e) n).

    Local Definition OutQ s := Q (adjRIBsOut (ribs s x r) (o,prefix)).

    Local Definition PartiallyP notP s := exists alreadyP, (forall p a, In (updateMessage p a) alreadyP -> P p a) /\ linkState (networkState' s) C = notP ++ alreadyP.

    Lemma pIsHereToStay n : PartiallyP [] (forward n) ->
                            afterF n OutQ ->
                            eventuallyF (PartiallyP []).
      intros h [baseOutQ outQ].
      unfold eventuallyF, eventually.
      exists n.
      unfold afterF, always in *.
      exists h.
      apply (InductiveForallEx _ _ _ _ _ _ _ outQ).
      clear h; intros s s' tss' outQs outQs' h.
      unfold PartiallyP in *.
      cbn in *.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip transition *)
        destruct tEq as [tEq _].
        rewrite <- tEq.
        assumption.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [outEq [linksEq _]]]].
      specialize (linksEq x r x' r' c).
      break_let.
      unfold linksAll in linksEq.
      break_match. {
        (* announcement removed from link *)
        destruct h as [alreadyP [allP linkP]].
        exists (linkState (networkState' s') C).
        subst C. unfold C in *.
        constructor; [|reflexivity].
        intros p a.
        specialize (allP p a).
        intros h.
        apply allP.
        rewrite <- linkP; clear linkP.
        rewrite linksEq.
        cbn.
        right.
        assumption.
      }
      break_match. {
        break_match. {
          (* ribs out didn't change, and thus link did not change *)
          subst C. unfold C.
          rewrite linksEq.
          exact h.
        }
        (* announcement added to link *)
        destruct h as [alreadyP [allP linkP]].
        exists (linkState (networkState' s') C).
        subst C. unfold C in *.
        constructor; [|reflexivity].
        intros p a.
        specialize (allP p a).
        intros h.
        rewrite linksEq in h; clear linksEq.
        rewrite linkP in h; clear linkP.
        apply in_app_or in h.
        cbn in h.
        intuition.
        match goal with h:_=_ |- _ => inversion h; clear h end.
        subst_max.
        rewrite <- outEq.
        unfold P.
        intros.
        unfold OutQ in *.
        subst_max.
        unfold o in *.
        assumption.
      }
      (* link did not change *)
      subst C. unfold C.
      rewrite linksEq.
      exact h.
    Qed.

    Lemma notEmpty {n np notP} : PartiallyP (np :: notP) (forward n) -> linkState (networkState' (forward n)) C <> [].
      intros h.
      unfold PartiallyP in h.
      destruct (indefinite_description h) as [l [_ h']].
      intros h''.
      cbn in h'.
      congruence.
    Qed.

    Definition timer n h := linkTimer (forward n) C h.

    Lemma timersUpDelivery {np notP s s'} (tss' : FairTransition s s')
          {nonEmpty : linkState (networkState' s) C <> []} :
          linkTimer s C nonEmpty = 0 ->
          PartiallyP (np :: notP) s ->
          PartiallyP notP s'.
    Proof.
      intros timersUp partialP.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip transition, impossibe because timer is up *)
        exfalso.
        destruct tEq as [stateEq timerEq].
        specialize (timerEq _ _ _ _ c nonEmpty).
        unfold C in *.
        rewrite timersUp in timerEq.
        refine ((fun nonEmpty' => _) nonEmpty).
        rewrite stateEq in nonEmpty'.
        specialize (timerEq nonEmpty').
        congruence.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [_ [linkEq timerEq]]]].
      unfold PartiallyP in *.
      destruct partialP as [alreadyP [partialP' partialP]].
      exists alreadyP.
      constructor; [intuition|].
      clear partialP'.
      specialize (linkEq x r x' r' c).
      break_match; revgoals. {
        (* some other message delivered, impossible because timer is up *)
        exfalso.
        specialize (timerEq _ _ _ _ c).
        break_match; [congruence|].
        specialize (timerEq nonEmpty).
        unfold C in *.
        rewrite timersUp in timerEq.
        unfold linksAll in linkEq.
        refine (_ (timerEq _)); [congruence|].
        rewrite linkEq.
        break_match; [break_match|].
        - assumption.
        - intros h.
          apply app_eq_nil in h.
          destruct h as [_ h].
          congruence.
        - assumption.
      }
      move linkEq after e0.
      unfold linksAll, C in *.
      cbn in *.
      congruence.
    Qed.

    Lemma linkTimerDecreases
      m s s' (tss' : FairTransition s s')
      (empty : linkState (networkState' s) C <> [])
      (empty' : linkState (networkState' s') C <> []) :
      linkTimer s C empty = S m -> linkTimer s' C empty' = m.
    Proof.
      intros h.
      unfold C in *.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* decreases on skip *)
        destruct tEq as [_ timerEq].
        specialize (timerEq _ _ _ _ c empty empty').
        congruence.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      destruct tEq as [_ [_ [_ [_ timerEq]]]].
      specialize (timerEq _ _ _ _ c).
      cbn in *.
      break_match.
      - (* link activated *)
        specialize (timerEq empty).
        congruence.
      - (* link not activated *)
        specialize (timerEq empty empty').
        congruence.
    Qed.

    Lemma timerAintUp
      np notP m s s' (tss' : FairTransition s s')
      (nonEmpty : linkState (networkState' s) C <> []) :
      OutQ s' ->
      PartiallyP (np :: notP) s ->
      linkTimer s C nonEmpty = S m ->
      PartiallyP (np :: notP) s'.
    Proof.
      intros outQ h h'.
      unfold PartiallyP in *.
      destruct h as [alreadyP [alreadyPHolds linkEq']].
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip *)
        destruct tEq as [tEq _].
        exists alreadyP.
        constructor; [assumption|].
        congruence.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [outEq [linkEq timerEq]]]].
      specialize (timerEq _ _ _ _ c).
      break_let_as Ct.
      specialize (linkEq _ _ _ _ c).
      break_let_as Cl.
      subst Ct Cl. unfold C in *.
      break_match. {
        (* message removed from link, impossible because of timer *)
        exfalso.
        specialize (timerEq nonEmpty).
        congruence.
      }
      break_match; revgoals. {
        (* link not activated *)
        unfold linksAll in *.
        exists alreadyP.
        constructor; [assumption|].
        congruence.
      }
      break_match. {
        (* message not sent because ribOut didn't change *)
        unfold linksAll in *.
        exists alreadyP.
        constructor; [assumption|].
        congruence.
      }
      (* message sent to link *)
      exists (alreadyP ++ [updateMessage mp (exports mp x r ((x'; r'); c))]).
      constructor; revgoals.
      - unfold linksAll in *.
        rewrite linkEq' in linkEq.
        rewrite linkEq.
        rewrite app_assoc.
        reflexivity.
      - intros p a h.
        apply in_app_or in h.
        destruct h as [|h]; [intuition|].
        cbn in h.
        destruct h as [h|]; [|intuition].
        inversion h; clear h.
        subst_max.
        unfold OutQ in outQ.
        unfold P.
        intros h.
        subst_max.
        rewrite <- outEq.
        exact outQ.
    Qed.

    Lemma notPGettingShorter n np notP :
      afterF n OutQ ->
      PartiallyP (np :: notP) (forward n) ->
      exists m, PartiallyP notP (forward (n + m)).
    Proof.
      intros outQ h.
      remember (timer n (notEmpty h)) as m eqn:teq.
      symmetry in teq.
      unfold timer in *.
      exists (m + 1).
      revert m n outQ h teq.
      induction m as [|m rec].
      - (* timer is up, message is delivered *)
        intros n outQ h.
        generalize (notEmpty h).
        intros ? timesUp.
        unfold forward in *.
        cbn in *.
        rewrite FastForwardPlus.
        destruct (fastForward _ _ (s0;e) n) as [s0' [s s' tss' e']].
        cbn in *.
        eapply (timersUpDelivery tss' timesUp h).
      - (* timer is not yet up *)
        intros n outQ h timeAintUp.
        specialize (rec (S n)).
        cbn.
        rewrite <- plus_Snm_nSm.
        assert (S n = (n + 1)) as h'' by omega.
        assert (PartiallyP (np :: notP) (forward (S n))) as h'. {
          clear rec.
          revert timeAintUp.
          generalize (notEmpty h).
          revert h.
          rewrite h''; clear h''.
          unfold afterF in *.
          unfold forward.
          rewrite FastForwardPlus.
          destruct (fastForward _ _ (s0;e) n) as [s0' [s s' tss' e']].
          cbn.
          intros h nonEmpty h'.
          cbn in *.
          eapply timerAintUp.
          - exact tss'.
          - destruct outQ as [base step].
            inversion step.
            subst_max.
            assumption.
          - exact h.
          - exact h'.
        }
        assert (afterF (S n) OutQ) as h'''. {
          clear -outQ.
          unfold afterF in *.
          assert (S n = n + 1) as h by omega.
          rewrite h.
          rewrite FastForwardPlus.
          destruct (fastForward _ _ (s0;e) n) as [s0' [s s' tss' e']].
          cbn.
          unfold always in *.
          cbn in *.
          destruct outQ as [base step].
          inversion step.
          break_sig_uip.
          subst_max.
          match goal with h:OutQ s' |- _ => exists h end.
          assumption.
        }
        specialize (rec h''' h').
        apply rec; clear rec.
        revert timeAintUp.
        generalize (notEmpty h').
        generalize (notEmpty h).
        clear h h'.
        rewrite h''; clear h''.
        unfold forward.
        rewrite FastForwardPlus.
        destruct (fastForward _ _ (s0;e) n) as [s0' [s s' tss' e']].
        cbn.
        cbn in *.
        apply linkTimerDecreases.
        assumption.
    Qed.

    Lemma eventuallyPartiallyP notP n : afterF n OutQ ->
                                        PartiallyP notP (forward n) ->
                                        eventuallyF (PartiallyP []).
      revert n.
      induction notP as [|np notP rec].
      - intros n h h'.
        exact (pIsHereToStay n h' h).
      - intros n h h'.
        destruct (notPGettingShorter n np notP h h') as [m h''].
        refine (rec _ _ h'').
        clear -h.
        unfold afterF in *.
        rewrite FastForwardPlus.
        destruct (fastForward _ _ (s0; e) n) as [e0' e'].
        unfold always in *.
        destruct h as [base step].
        exact (@FastForwardSpec _ _ _ _ _ m base step).
    Qed.

    Definition AllQ s := forall a, In (updateMessage prefix a) (linksAll s C) -> Q a.
    Definition i := mkReceived x' r' x r c.
    Definition InQ s := Q (adjRIBsIn (ribs s x' r') (i, prefix)).

    Lemma allQinQStep n : afterF n AllQ ->
                          InQ (forward n) ->
                          eventuallyF InQ.
    Proof.
      intros allQ inQbase.
      unfold afterF, eventuallyF, eventually, forward in *.
      exists n.
      destruct (fastForward _ _ (s0; e) n) as [s0' e']; clear n.
      cbn in *.
      unfold always in *.
      destruct allQ as [allQbase allQstep].
      cbn in *.
      exists inQbase.
      apply (InductiveForallEx _ _ _ _ _ _ _ allQstep).
      intros s s' tss' allQ _ inQ.
      unfold InQ, AllQ, ribs in *.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip transition *)
        destruct tEq as [tEq _].
        rewrite <- tEq.
        assumption.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [inEq [_ [_ [linkEq _]]]].
      specialize (inEq prefix x' r' i).
      specialize (linkEq _ _ _ _ c).
      break_let.
      unfold ribs in *.
      rewrite inEq.
      subst ins.
      cbn.
      break_if; revgoals.
      - (* not processing message *)
        assumption.
      - (* processing message *)
        break_sig.
        assert (x' = mDstX) by crush.
        subst_max.
        break_sig_uip.
        break_sig.
        unfold i in *. subst mi.
        inversion e0.
        subst_max.
        break_sig_uip.
        subst_max.
        unfold mkReceived in e0.
        assert (mc = c). {
          clear -e0.
          match goal with
          | _:received ?A = received ?B |- _ => assert (A = B) by crush
          end.
          break_sig_uip.
          congruence.
        }
        subst_max.
        break_match; [|congruence].
        specialize (allQ ma).
        apply allQ.
        subst C.
        unfold C.
        rewrite linkEq.
        intuition.
    Qed.

    Lemma ImpliedAlways {S T : _ -> Prop} {e'} : (forall s, S s -> T s) ->
                        always FairNetworkState FairTransition S e' ->
                        always FairNetworkState FairTransition T e'.
    Proof.
      unfold always.
      intros h [base step].
      exists (h _ base).
      apply ImpliedForallStates.
      assumption.
    Qed.

    Lemma ForwardAlways {S: _ -> Prop} {e'} {n} :
      always FairNetworkState FairTransition S e' ->
      always FairNetworkState FairTransition S (fastForward FairNetworkState FairTransition e' n).
    Proof.
      unfold always.
      intros [base step].
      destruct e' as [s0' e'].
      exact (@FastForwardSpec _ _ S s0' e' n base step).
    Qed.

    Lemma InProjLink {a ls} : In a (projLink prefix ls) ->
                              In (updateMessage prefix a) ls.
    Proof.
      induction ls as [|[p a'] ls' rec].
      - cbn.
        intuition.
      - cbn.
        intros h.
        break_match.
        + subst_max.
          cbn in h.
          destruct h.
          * subst_max.
            intuition.
          * intuition.
        + intuition.
    Qed.

    Lemma getMyMessage {a ls s} : links prefix s C = a::ls ->
                                  exists ls ls', linksAll s C = ls ++ [updateMessage prefix a] ++ ls'.
      intros h.
      unfold links, linksAll in *.
      apply in_split.
      apply InProjLink.
      rewrite h.
      intuition.
    Qed.

    Lemma linkConsNonNil {A} {a:A} {l l'} : l = a::l' -> l <> [].
      congruence.
    Qed.

    Arguments fastForward {_ _} _ _.

    Lemma deliverMessage s s' (tss' : FairTransition s s') p a ls
      (eq:linksAll s C = {| nlri := p; attributes := a |} :: ls) :
      linkTimer s C (linkConsNonNil eq) = 0 ->
      linksAll s' C = ls /\ adjRIBsIn (ribs s' x' r') (i, p) = a.
    Proof.
      intros timersUp.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip transition, impossibe because timer is up *)
        exfalso.
        destruct tEq as [stateEq timerEq].
        specialize (linkConsNonNil eq); intros nonEmpty.
        specialize (timerEq _ _ _ _ c (linkConsNonNil eq)).
        unfold C in *.
        rewrite timersUp in timerEq.
        unfold linksAll in *.
        rewrite stateEq in nonEmpty.
        specialize (timerEq nonEmpty).
        congruence.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [inEq [_ [_ [linkEq timerEq]]]].
      specialize (linkEq x r x' r' c).
      specialize (timerEq x r x' r' c).
      break_match; revgoals. {
        (* some other message delivered, impossible because timer is up *)
        exfalso.
        specialize (timerEq (linkConsNonNil eq)).
        unfold C in *.
        rewrite timersUp in timerEq.
        unfold linksAll in linkEq.
        refine (_ (timerEq _)); [congruence|].
        rewrite linkEq.
        break_match; [break_match|].
        - exact (linkConsNonNil eq).
        - intros h.
          apply app_eq_nil in h.
          destruct h as [_ h].
          congruence.
        - exact (linkConsNonNil eq).
      }
      idtac.
      break_sig.
      inversion e0.
      subst_max.
      break_sig_uip.
      break_sig_uip.
      assert (r' = mDstR) by crush.
      subst_max.
      break_sig_uip.
      subst_max.
      cbn in linkEq.
      unfold C in *.
      rewrite eq in linkEq.
      assert (p = mp) by crush.
      subst_max.
      assert (a = ma) by crush.
      subst_max.
      constructor; [crush|].
      clear linkEq.
      rewrite inEq.
      subst ins.
      cbn.
      subst mi.
      unfold i.
      break_match; congruence.
    Qed.

    Lemma messageNotYetDelivered {n ls a m}
      (eq:linksAll (forward n) C = a :: ls) :
      linkTimer (forward n) C (linkConsNonNil eq) = S m ->
      exists ls', linksAll (forward (n + 1)) C = a :: ls ++ ls'.
    Proof.
      unfold forward in *.
      rewrite FastForwardPlus.
      destruct (fastForward (s0;e) n) as [s0' [s s' tss' e']]; clear n.
      cbn.
      intros timeAintUp.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip *)
        destruct tEq as [stateEq _].
        exists [].
        unfold linksAll in *.
        rewrite <- stateEq.
        rewrite app_nil_r.
        assumption.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [_ [linkEq timerEq]]]].
      specialize (linkEq x r x' r' c).
      specialize (timerEq x r x' r' c).
      break_match. {
        (* message delivered, impossible because timer isn' up *)
        exfalso.
        specialize (timerEq (linkConsNonNil eq)).
        move timeAintUp after timerEq.
        unfold C in *.
        cbn in *.
        congruence.
      }
      clear timerEq timeAintUp.
      unfold C in *.
      cbn in linkEq.
      move eq after linkEq.
      cbn in eq.
      break_match; [break_match|].
      - (* no message sent because ribs didn't change *)
        exists [].
        rewrite app_nil_r.
        congruence.
      - (* message sent because ribs did change *)
        match goal with _:_ = _ ++ ?A |- _ => exists A end.
        rewrite linkEq.
        rewrite eq.
        cbn.
        reflexivity.
      - (* no message sent because link didn't do anything *)
        exists [].
        rewrite app_nil_r.
        congruence.
    Qed.

    Lemma deliverMessageEventually {n p a ls} :
      linksAll (forward n) C = (updateMessage p a) :: ls ->
      exists m ls', let s := forward (n + m) in
               linksAll s C = ls ++ ls' /\
               adjRIBsIn (ribs s x' r') (i, p) = a.
    Proof.
      intros eq.
      remember (linkTimer (forward n) C (linkConsNonNil eq)) as m eqn:teq.
      symmetry in teq.
      cbn.
      exists (m + 1).
      cbn in *.
      revert n ls eq teq.
      induction m as [|m rec].
      - (* timer is up, message is delivered *)
        intros n ls eq timersUp.
        unfold forward in *.
        rewrite FastForwardPlus.
        destruct (fastForward (s0;e) n) as [s0' e']; clear n.
        destruct e' as [s s' tss' e'].
        cbn in *.
        exists [].
        rewrite app_nil_r.
        exact (deliverMessage s s' tss' _ _ _ eq timersUp).
      - (* timer is not yet up *)
        intros n ls eq timeAintUp.
        specialize (rec (S n)).
        cbn.
        destruct (messageNotYetDelivered eq timeAintUp) as [ls' eq'].
        rewrite <- plus_Snm_nSm.
        assert (S n = (n + 1)) as h'' by omega.
        rewrite h'' in *; clear h''.
        refine ((fun rec' => _) (rec _ eq' _)); clear rec; revgoals. {
          unfold forward in *.
          generalize_proofs.
          cbn in *.
          revert timeAintUp.
          apply linkTimerDecreases.
          clear.
          rewrite FastForwardPlus.
          destruct (fastForward (s0;e) n) as [s0' [s s' tss' e']].
          cbn.
          exact tss'.
        }
        destruct rec' as [ls'' [h h']].
        rewrite <- app_assoc in h.
        exists (ls' ++ ls'').
        intuition.
    Qed.

    Lemma allQinQNonEmpty n a ls ls' : Q a ->
                                       linksAll (forward n) C = ls ++ [updateMessage prefix a] ++ ls' ->
                                       exists m, InQ (forward (n + m)).
    Proof.
      intros aQ.
      revert n ls'.
      induction ls as [| [p a'] ls'' rec].
      - cbn.
        intros n ls' eq.
        destruct (deliverMessageEventually eq) as [m [_ [_ h]]].
        exists m.
        unfold InQ.
        congruence.
      - intros n ls' eq.
        destruct (deliverMessageEventually eq) as [m [ls''' [h _]]].
        clear eq.
        rewrite <- app_assoc in h.
        rewrite <- app_assoc in h.
        specialize (rec _ _ h).
        destruct rec as [m' inQ].
        rewrite <- plus_assoc in *.
        eexists.
        exact inQ.
    Qed.

    Lemma allQinQ : eventuallyF OutQ ->
                    eventuallyF AllQ ->
                    eventuallyF InQ.
    Proof.
      intros outQ allQ.
      specialize (combineConverges _ (combineConverges _ (alwaysEConverges inOutRIBsConverges) outQ) allQ).
      clear allQ outQ.
      intros conv.
      unfold eventuallyF, eventually in *.
       destruct conv as [n conv].
      destruct (links prefix (forward n) C) as [|a ls] eqn:eq.
      - (* no message on link *)
        refine (allQinQStep n _ _). {
          unfold afterF.
          refine (ImpliedAlways _ conv).
          intros s [_ h].
          assumption.
        }
        unfold forward in *.
        destruct (fastForward (s0; e) n) as [s0' e']; clear n.
        destruct conv as [[[inOut outQ] partialP] _].
        cbn in *.
        unfold linksAll, AllQ, InQ, OutQ, inOutRIBs, links in *.
        specialize (inOut prefix x r x' r' c).
        setoid_rewrite eq in inOut.
        unfold o, i in *.
        cbn in *.
        rewrite <- inOut.
        congruence.
      - (* messages on link *)
        destruct (getMyMessage eq) as [ls' [ls'' leq]].
        refine ((fun h => _) (allQinQNonEmpty n a ls' ls'' _ leq)). {
          destruct h as [m h].
          refine (allQinQStep (n + m) _ h).
          clear h leq eq.
          unfold afterF.
          rewrite FastForwardPlus.
          destruct (fastForward (s0; e) n) as [s0' e']; clear n.
          apply ForwardAlways.
          refine (ImpliedAlways _ conv).
          intros s [_ h].
          assumption.
        }
        unfold forward in *.
        destruct (fastForward (s0; e) n) as [s0' e']; clear n.
        destruct conv as [[_ allQ] _].
        cbn in *.
        unfold AllQ in *.
        specialize (allQ a).
        apply allQ.
        rewrite leq.
        apply in_or_app.
        intuition.
    Qed.

    Lemma LinkPropertyConvergence :
        converges OutQ ->
        converges (fun s => Q (adjRIBsIn (ribs s x' r') (i,prefix))).
    Proof.
      intros h.
      apply allQinQ; [assumption|].
      unfold converges, eventually.
      cbn.
      destruct h as [n h].
      enough (converges (PartiallyP [])) as h'. {
        refine (impliedConverges _ _ h').
        unfold PartiallyP.
        intros s [l [allP leq]].
        cbn in leq.
        subst_max.
        intros a h''.
        specialize (allP prefix a h'').
        unfold P in allP.
        exact (allP eq_refl).
      }
      eapply eventuallyPartiallyP.
      - exact h.
      - shelve.
        Unshelve.
        exact (linksAll (forward n) C).
        unfold PartiallyP.
        exists [].
        intuition.
        rewrite app_nil_r.
        reflexivity.
    Qed.
  End LinkPropertyConvergence.

  Context `{SP:@SinglePrefixClass PR}.

  Lemma StableLinkHasAnnouncement {x r x' r' c} :
    let o := mkOutgoing x r x' r' c in
      converges (StableLink x r x' r' c) ->
      { a | converges (fun s => a = adjRIBsOut (ribs s x r) (o,p))}.
  Proof.
    break_let.
    cbn.
    unfold eventually.
    intros h.
    apply indefinite_description in h.
    destruct h as [n h].
    exists (adjRIBsOut (ribs (fastForward _ _ (s0;e) n).1 x r) (o, p)).
    exists n.
    destruct (fastForward _ _ (s0;e) n) as [sn en].
    cbn in *.
    refine (ex_intro _ _ _); [reflexivity|].
    unfold always in *.
    destruct h as [h0 h].
    cbn in *.
    apply (InductiveForallEx _ _ _ _ _ _ _ h).
    clear h.
    intros s s' tss' _ stable' rec.
    unfold ribs in *.
    rewrite rec; clear rec.
    destruct (transitionEq s s' tss') as [tEq|tEq]. {
      (* skip transition *)
      destruct tEq as [tEq _].
      rewrite <- tEq.
      reflexivity.
    }
    destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
    repeat break_let.
    destruct tEq as [_ [_ [outEq [linkEq _]]]].
    specialize (linkEq x r x' r' c).
    break_let.
    rewrite outEq.
    unfold exports.
    (* if this router didn't receive a message nothing changes *)
    break_match; [|reflexivity].
    repeat break_sig; subst_max.
    break_match. {
      exfalso.
      repeat break_sig; subst_max.
      exact (noLinkToSameRouter c).
    }
    cbn in linkEq.
    break_match; [|congruence].
    break_match.
    - (* router didn't send message because ribs didn't change *)
      unfold ribs in e1.
      subst o.
      unfold mkOutgoing.
      simpl.
      rewrite <- e1.
      unfold exports.
      eliminate_dead_code.
      reflexivity.
    - (* router sent message, which is impossible due to link stability *)
      exfalso.
      unfold StableLink in stable'.
      subst C.
      unfold links, linksAll in *.
      rewrite linkEq in stable'.
      rewrite projLinkApp in stable'.
      cbn in stable'.
      apply app_eq_nil in stable'.
      destruct stable' as [_ stable'].
      break_if; congruence.
  Qed.

  Lemma injectedInstalledInductive s0 s1 (t:FairTransition s0 s1) :
    injectedInstalled s0 -> injectedInstalled s1.
  Proof.
    intros h0 p x r.
    destruct (transitionEq s0 s1 t) as [tEq|tEq]. {
      (* skip transition *)
      unfold ribs, links in *.
      destruct tEq as [tEq _].
      rewrite <- tEq.
      apply h0.
    }
    clear t.
    destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
    destruct tEq as [inEq [_ [_ _]]].
    specialize (h0 p x r).
    specialize (inEq p x r injected).
    unfold mkReceived in *.
    match goal with | h:context[if ?P then _ else _] |- _ => destruct P end.
    * repeat break_sig; subst_max.
      crush.
    * crush.
  Qed.

  Lemma injectedInstalledConverges : alwaysE injectedInstalled.
    exact (inductiveAlways _ initiallyInjectedInstalled injectedInstalledInductive).
  Qed.

  Lemma InjectedConvergence :
      converges (fun s => forall x r, adjRIBsIn (ribs s x r) (injected,p) =
                         if (x;r) =? (x0;r0) then (available a0) else notAvailable).
  Proof.
    refine (impliedConverges _ _ (alwaysEConverges injectedInstalledConverges)).
    unfold ribsFromIn.
    intros s h x r.
    specialize (h p x r).
    apply h.
  Qed.

  Lemma EmptyLinkConvergence x r x' r' c :
    let i := mkReceived x' r' x r c in
    let o := mkOutgoing x r x' r' c in
      converges (StableLink x r x' r' c) ->
      { a | converges (fun s => a = adjRIBsOut (ribs s x r) (o,p) /\
                             a = adjRIBsIn  (ribs s x' r') (i,p))}.
  Proof.
    repeat break_let.
    intros h.
    destruct (StableLinkHasAnnouncement h) as [a h'].
    exists a.
    refine (impliedConverges _ _ (combineConverges _ (alwaysEConverges inOutRIBsConverges)
                                 (combineConverges _ h h'))).
    unfold inOutRIBs, StableLink.
    intros s [inOut [stable out]].
    specialize (inOut p x r x' r' c).
    rewrite stable in inOut.
    cbn in inOut.
    subst i o.
    cbn.
    rewrite <- inOut.
    intuition.
  Qed.

  Lemma LocRIBConvergence :
      converges (fun s => forall x r,
        let iBest := bestImport x r s in
          locRIB (ribs s x r) p = imports x r iBest s).
  Proof.
    refine (impliedConverges _ _ (alwaysEConverges ribsFromInConverges)).
    unfold ribsFromIn.
    intros s h x r.
    specialize (h p x r).
    destruct h as [h _].
    apply h.
  Qed.

  Lemma AdjRIBsOutConvergence :
      converges (fun s => forall x r o,
        let iBest := bestImport x r s in
          adjRIBsOut (ribs s x r) (o,p) = export' (x;r) iBest o p (imports x r iBest s)).
  Proof.
    refine (impliedConverges _ _ (alwaysEConverges ribsFromInConverges)).
    unfold ribsFromIn.
    intros s h x r.
    specialize (h p x r).
    destruct h as [_ h].
    apply h.
  Qed.

  Section StableRIBsOutEmptyLink.
    Variable x:AS.
    Variable r:router x.
    Variable x':AS.
    Variable r':router x'.
    Variable c:link x r x' r'.
    Variable aOut:RoutingInformation.

    Definition CC := mkConnection x r x' r' c.
    Definition oo := mkOutgoing x r x' r' c.

    Definition StableOut s := adjRIBsOut (ribs s x r) (mkOutgoing x r x' r' c, p) = aOut.

    Arguments fastForward {_ _} _ _.

    Lemma forwardAfterF {P n} m : afterF n P -> afterF (n + m) P.
      unfold afterF, always.
      intros [base step].
      eapply FastForwardMore; [|eauto].
      omega.
    Qed.

    Lemma messageNotYetDelivered' {n ls a m}
      (eq:linksAll (forward n) CC = a :: ls) :
      afterF n StableOut ->
      linkTimer (forward n) CC (linkConsNonNil eq) = S m ->
      exists ls', linksAll (forward (n + 1)) CC = a :: ls ++ ls' /\
             projLink p ls' = [].
    Proof.
      unfold forward, afterF, always in *.
      rewrite FastForwardPlus.
      destruct (fastForward (s0;e) n) as [s0' [s s' tss' e']]; clear n.
      cbn.
      intros stableOut timeAintUp.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip *)
        destruct tEq as [stateEq _].
        exists [].
        unfold linksAll in *.
        rewrite <- stateEq.
        rewrite app_nil_r.
        cbn in *.
        intuition.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [outEq [linkEq timerEq]]]].
      specialize (linkEq x r x' r' c).
      specialize (timerEq x r x' r' c).
      break_match. {
        (* message delivered, impossible because timer isn' up *)
        exfalso.
        specialize (timerEq (linkConsNonNil eq)).
        move timeAintUp after timerEq.
        unfold CC in *.
        cbn in *.
        congruence.
      }
      clear timerEq timeAintUp.
      unfold CC in *.
      cbn in linkEq.
      move eq after linkEq.
      cbn in eq.
      break_match; [break_match|].
      - (* no message sent because ribs didn't change *)
        exists [].
        rewrite app_nil_r.
        cbn in *.
        constructor; [|reflexivity].
        congruence.
      - (* message sent because ribs did change *)
        match goal with _:_ = _ ++ ?A |- _ => exists A end.
        rewrite linkEq.
        rewrite eq.
        cbn.
        constructor; [reflexivity|].
        break_match; [|reflexivity].
        (* we don't sent for prefix, because that rib didn't change *)
        exfalso.
        rewrite <- outEq in *.
        destruct stableOut as [stableS stableOut].
        inversion stableOut.
        subst_max.
        unfold StableOut, mkOutgoing in *.
        cbn in *.
        congruence.
      - (* no message sent because link didn't do anything *)
        exists [].
        rewrite app_nil_r.
        constructor; [|reflexivity].
        congruence.
    Qed.

    Lemma deliverMessageEventually' {n p a ls} :
      afterF n StableOut ->
      linksAll (forward n) CC = (updateMessage p a) :: ls ->
      exists m ls', let s := forward (n + m) in
               linksAll s CC = ls ++ ls' /\
               projLink Sugar.p ls' = [].
    Proof.
      (* strongly inspired by deliverMessageEventually *)
      intros stableOut eq.
      remember (linkTimer (forward n) CC (linkConsNonNil eq)) as m eqn:teq.
      symmetry in teq.
      cbn.
      exists (m + 1).
      cbn in *.
      revert n ls eq teq stableOut.
      induction m as [|m rec].
      - (* timer is up, message is delivered *)
        intros n ls eq timersUp _.
        unfold forward, afterF, always in *.
        rewrite FastForwardPlus.
        destruct (fastForward (s0;e) n) as [s0' e']; clear n.
        destruct e' as [s s' tss' e'].
        cbn in *.
        exists [].
        rewrite app_nil_r.
        cbn.
        constructor; [|reflexivity].
        eapply deliverMessage; eauto.
        exact (fun _ => False). (* just needed by the library, not by us *)
      - (* timer is not yet up *)
        intros n ls eq timeAintUp stableOut.
        specialize (rec (S n)).
        cbn.
        destruct (messageNotYetDelivered' eq stableOut timeAintUp) as [ls' [eq' eqProj]].
        rewrite <- plus_Snm_nSm.
        assert (S n = (n + 1)) as h'' by omega.
        rewrite h'' in *; clear h''.
        refine ((fun rec' => _) (rec _ eq' _)); clear rec; revgoals. {
          unfold forward in *.
          generalize_proofs.
          cbn in *.
          revert timeAintUp.
          apply linkTimerDecreases.
          clear.
          rewrite FastForwardPlus.
          destruct (fastForward (s0;e) n) as [s0' [s s' tss' e']].
          cbn.
          exact tss'.
        }
        refine ((fun rec => _) (rec' _ )); clear rec'; revgoals. {
          eapply forwardAfterF.
          eauto.
        }
        destruct rec as [ls'' [h h']].
        rewrite <- app_assoc in h.
        exists (ls' ++ ls'').
        intuition.
        cbn in *.
        rewrite projLinkApp.
        rewrite h'.
        rewrite eqProj.
        reflexivity.
    Qed.

    Lemma linkEventuallyEmpty n ls ls' :
      linksAll (forward n) CC = ls ++ ls' ->
      projLink p ls' = [] ->
      afterF n StableOut ->
      exists m, links p (forward (n + m)) CC = [].
    Proof.
      revert n ls'.
      induction ls as [| [p a'] ls'' rec].
      - intros.
        exists 0.
        cbn in *.
        assert (n + 0 = n) by omega.
        unfold links, linksAll in *.
        congruence.
      - intros n ls' lsEq projEq stableOut.
        destruct (deliverMessageEventually' stableOut lsEq) as [m [ls''' [h h']]].
        clear lsEq.
        rewrite <- app_assoc in h.
        specialize (rec _ _ h).
        refine (_ (rec _ _)).
        + intros [m' rec'].
          rewrite <- plus_assoc in rec'.
          eauto.
        + rewrite projLinkApp.
          rewrite h'.
          rewrite projEq.
          reflexivity.
        + eapply forwardAfterF.
          eauto.
    Qed.

    Lemma StableRIBsOutEmptyLink :
      converges StableOut ->
      converges (StableLink x r x' r' c).
    Proof.
      intros [n stableOut].
      unfold converges in *; cbn in *.
      unfold eventually, always, const in *.
      specialize (linkEventuallyEmpty n (linksAll (forward n) CC) []).
      intros emptyAfterM.
      rewrite app_nil_r in *.
      cbn in *.
      specialize (emptyAfterM eq_refl eq_refl stableOut).
      destruct emptyAfterM as [m emptyAfterM].
      exists (n + m).
      eapply (forwardAfterF m) in stableOut.
      unfold afterF, forward in *.
      destruct (fastForward (s0;e) (n + m)) as [s0' e']; clear n m.
      cbn in *.
      unfold StableLink.
      exists emptyAfterM.
      destruct stableOut.
      eapply InductiveForallEx; [eauto|].
      (* once the link is empty, it will always be empty *)
      intros s s' tss' stableOutS stableOutS'.
      destruct (transitionEq s s' tss') as [tEq|tEq]. {
        (* skip *)
        destruct tEq as [stateEq _].
        unfold links in *.
        congruence.
      }
      destruct tEq as [mp [ma [mSrcX [mSrcR [mDstX [mDstR [mc tEq]]]]]]].
      repeat break_let.
      destruct tEq as [_ [_ [outEq [linkEq _]]]].
      specialize (linkEq x r x' r' c).
      break_match. {
        (* message delivered *)
        unfold CC, links, linksAll in *.
        rewrite linkEq.
        refine (_:projLink _ ([_]++_) = _ -> _).
        intros h.
        rewrite projLinkApp in h.
        apply app_eq_nil in h.
        intuition.
      }
      unfold CC in *.
      unfold linksAll, links in *.
      break_match; [break_match|].
      - (* no message sent because ribs didn't change *)
        congruence.
      - (* message sent because ribs did change *)
        rewrite linkEq; clear linkEq.
        intros h.
        rewrite projLinkApp.
        rewrite h.
        cbn.
        break_match; [|reflexivity].
        (* we don't sent for prefix, because that rib didn't change *)
        exfalso.
        rewrite <- outEq in *.
        subst_max.
        unfold StableOut, mkOutgoing in *.
        cbn in *.
        congruence.
      - (* no message sent because link didn't do anything *)
        congruence.
    Qed.
  End StableRIBsOutEmptyLink.

  Instance bgpConvergence : BGPConvergence := {|
    stableRIBsOutEmptyLink := StableRIBsOutEmptyLink;
    linkPropertyConvergence := LinkPropertyConvergence p;
    emptyLinkConvergence := EmptyLinkConvergence;
    injectedConvergence := InjectedConvergence;
    locRIBConvergence := LocRIBConvergence;
    adjRIBsOutConvergence := AdjRIBsOutConvergence
  |}.
End BGPConvergence.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Correct.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.

Set Implicit Arguments.

Local Open Scope list_scope.
Local Open Scope grammar_fixedpoint_scope.

Section fold_correctness.
  Context {Char : Type} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {T : Type}.
  Context {fpdata : @grammar_fixedpoint_lattice_data T}
          {aidata : @AbstractInterpretation Char T fpdata}
          (prerelated : Ensemble String -> T -> Prop)
          {aicdata : AbstractInterpretationCorrectness prerelated}.
  Context (G : pregrammar' Char).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Definition fold_grammar : aggregate_state (fixedpoint_by_abstract_interpretation G)
    := pre_Fix_grammar _ initial_nonterminals_data.

  Record ensemble_result (str : String) (fold_state : state) :=
    { er_ensemble :> Ensemble String;
      er_state :> state;
      er_related :> related er_ensemble er_state;
      er_correct :> Ensembles.In _ er_ensemble str;
      er_state_le :> er_state <= fold_state }.

  Definition er_lift {str st1 st2}
             (v : ensemble_result str st1)
             (Hle : st1 <= st2)
    : ensemble_result str st2
    := {| er_ensemble := v;
          er_state := v;
          er_related := er_related v;
          er_correct := er_correct v;
          er_state_le := transitivity (R := state_le) (er_state_le v) Hle |}.

  Definition er_combine_production n str st1 st2 (it : ensemble_result (take n str) st1) (its : ensemble_result (drop n str) st2)
    : ensemble_result str (combine_production st1 st2)
    := {| er_ensemble := ensemble_combine_production it its;
          er_state := combine_production (T := T) (it : state) (its : state);
          er_related := combine_production_correct it it (er_related it) its its (er_related its);
          er_correct := ex_intro _ n (conj (er_correct it) (er_correct its));
          er_state_le := combine_production_Proper_le (er_state_le it) (er_state_le its) |}.

  Lemma fold_le nt st
        (H : st <= fold_productions' G (lookup_state fold_grammar) (Lookup_string G nt))
    : st <= lookup_state fold_grammar (of_nonterminal nt).
  Proof.
    unfold fold_grammar.
    rewrite pre_Fix_grammar_fixedpoint.
    unfold aggregate_step.
    rewrite lookup_state_aggregate_state_lub, <- least_upper_bound_correct_r.
    rewrite lookup_state_aggregate_prestep, (find_pre_Fix_grammar_to_lookup_state _ G).
    let v := match goal with |- context[if ?v then _ else _] => v end in
    destruct v eqn:Hvalid; unfold option_rect; [ | apply top_top ].
    unfold step_constraints.
    unfold fixedpoint_by_abstract_interpretation at 3.
    unfold fold_constraints.
    rewrite <- list_to_productions_to_nonterminal.
    change (default_to_nonterminal ?nt) with (to_nonterminal nt).
    rewrite to_of_nonterminal by (eapply initial_nonterminals_correct; assumption).
    assumption.
  Qed.

  Definition lift_ensemble_result {str nt}
             (res : ensemble_result str (fold_productions' G (lookup_state fold_grammar) (G nt)))
    : ensemble_result str (lookup_state fold_grammar (of_nonterminal nt))
    := {| er_ensemble := er_ensemble res;
          er_state := er_state res;
          er_related := er_related res;
          er_correct := er_correct res;
          er_state_le := fold_le _ _ (er_state_le res) |}.

  Section step.
    Context (state_of_parse : forall str pats, parse_of G str pats -> ensemble_result str (fold_productions' G (lookup_state fold_grammar) pats))
            (state_of_parse_production : forall str pat, parse_of_production G str pat -> ensemble_result str (fold_production' G (lookup_state fold_grammar) pat))
            (state_of_parse_item : forall str it, parse_of_item G str it -> ensemble_result str (fold_item' G (lookup_state fold_grammar) it)).

    Definition state_of_parse_item'
               str it (p : parse_of_item G str it)
      : ensemble_result str (fold_item' G (lookup_state fold_grammar) it)
      := match p in parse_of_item _ _ it return ensemble_result _ (fold_item' _ _ it) with
         | ParseTerminal ch P Hch Hstr
           => {| er_state := on_terminal P;
                 er_ensemble := ensemble_on_terminal P;
                 er_related := on_terminal_correct P;
                 er_correct := ex_intro _ ch (conj Hch Hstr);
                 er_state_le := reflexivity (R := state_le) _ |}
         | ParseNonTerminal nt Hvalid p' => lift_ensemble_result (state_of_parse p')
         end.

    Definition state_of_parse_production'
               str pat (p : parse_of_production G str pat)
      : ensemble_result str (fold_production' G (lookup_state fold_grammar) pat)
      := match p with
         | ParseProductionNil Hlen
           => {| er_state := on_nil_production;
                 er_ensemble := ensemble_on_nil_production;
                 er_related := on_nil_production_correct (prerelated := prerelated);
                 er_correct := Hlen;
                 er_state_le := reflexivity (R := state_le) _ |}
         | ParseProductionCons n pat pats p' p's
           => er_combine_production
                n
                str
                (state_of_parse_item p')
                (state_of_parse_production p's)
         end.

    Definition state_of_parse'
               str pats (p : parse_of G str pats)
      : ensemble_result str (fold_productions' G (lookup_state fold_grammar) pats)
      := match p in parse_of _ _ pats return ensemble_result _ (fold_productions' _ _ pats) with
         | ParseHead pat pats p' => er_lift (state_of_parse_production p') (least_upper_bound_correct_l _ _)
         | ParseTail pat pats p' => er_lift (state_of_parse p') (least_upper_bound_correct_r _ _)
         end.
  End step.

  Fixpoint state_of_parse str pats (p : parse_of G str pats)
    := @state_of_parse' (@state_of_parse) (@state_of_parse_production) str pats p
  with state_of_parse_production str pat (p : parse_of_production G str pat)
    := @state_of_parse_production' (@state_of_parse_production) (@state_of_parse_item) str pat p
  with state_of_parse_item str it (p : parse_of_item G str it)
    := @state_of_parse_item' (@state_of_parse) str it p.

  Lemma fold_grammar_correct_item str nt
        (p : parse_of_item G str (NonTerminal nt))
    : exists P, P str /\ related P (lookup_state fold_grammar (of_nonterminal nt)).
  Proof.
    pose proof (@state_of_parse_item _ _ p) as p'.
    unfold fold_item' in p'.
    exists (er_ensemble p').
    split; [ apply p' | ].
    eapply (related_monotonic _); apply p'.
  Qed.

  Lemma fold_grammar_correct_item' str it
        (p : parse_of_item G str it)
    : exists P, P str /\ related P (fold_item' G (lookup_state fold_grammar) it).
  Proof.
    destruct p as [ch P Ppf Hch|] eqn:Hp.
    { simpl.
      eexists; split; [ | apply on_terminal_correct ].
      eexists; split; eassumption. }
    { apply fold_grammar_correct_item; assumption. }
  Qed.

  Lemma fold_grammar_correct_production str ps
        (p : parse_of_production G str ps)
    : exists P, P str /\ related P (fold_production' G (lookup_state fold_grammar) ps).
  Proof.
    unfold fold_production'.
    induction p as [|str n pat pats p ps IHps].
    { eexists; split; [ | apply on_nil_production_correct ]; assumption. }
    { simpl.
      apply fold_grammar_correct_item' in p.
      destruct IHps as [P [IHps0 IHps1]], p as [Ps [IHp0 IHp1]].
      eexists; split; [ | apply combine_production_correct ];
        hnf; eauto using ex_intro, conj with nocore. }
  Qed.

  Lemma fold_grammar_correct str nt
        (p : parse_of G str (Lookup G nt))
    : exists P, P str /\ related P (lookup_state fold_grammar (of_nonterminal nt)).
  Proof.
    destruct (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt)) eqn:Hvalid.
    { apply fold_grammar_correct_item; constructor.
      { apply initial_nonterminals_correct; assumption. }
      { assumption. } }
    { unfold fold_grammar.
      rewrite (lookup_state_invalid_pre_Fix_grammar _ G) by assumption.
      do 2 esplit; [ | eapply top_related ].
      constructor. }
  Qed.
End fold_correctness.

Global Arguments fold_grammar_correct {_ HSLM HSL HSLP _ _ _ _ _} [_ _ _] _.
Global Arguments fold_grammar_correct_item {_ HSLM HSL HSLP _ _ _ _ _} [_ _ _] _.

Class fold_grammar_data {Char T} {fpdata : grammar_fixedpoint_lattice_data T}
      {aidata : AbstractInterpretation}
      (G : pregrammar' Char) :=
  { fgd_fold_grammar : aggregate_state (fixedpoint_by_abstract_interpretation G);
    fgd_fold_grammar_correct : fgd_fold_grammar = fold_grammar G }.
Coercion fgd_fold_grammar : fold_grammar_data >-> aggregate_state.

Ltac make_fold_grammar_data_from v :=
  let lem := match v with
             | @fold_grammar ?Char ?T ?fpdata ?aidata ?G
               => constr:(@Build_fold_grammar_data Char T fpdata aidata G)
             end in
  let v' := (eval vm_compute in v) in
  constr:(lem v' (_ : eq_refl_vm_cast_l v' v)).

Ltac make_fold_grammar_data G :=
  let v := constr:(fold_grammar G) in
  make_fold_grammar_data_from v.


Require Import src.rproof.
Require Import src.CDCLtransition.
Require Import Coq.Unicode.Utf8.
Require Import  Coq.Strings.String.
Require Import  Coq.Lists.List.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.
Require Import ExtrOcamlNatInt.

Require Coq.extraction.Extraction.
Extraction Language OCaml.
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Constant plus =>"( + )".
Extract Constant mult => "( * )".
Extract Constant eqb => "( = )".
Extract Inductive sumbool => "bool" ["true" "false"].
(* Extract Inductive string => "string" [ """""" "(fun a b -> (string_of_char a) ^ b)"] "(fun e c s -> if s = "" then e else c s.[0] (String.sub s 1 (String.length s - 1)))". *)
Instance EqDec_eq_of_Str: EqDec_eq string.
unfold EqDec_eq.
intros. eapply string_dec.
Qed.

Class Show A : Type :=
    show : A -> string.

Instance showString : Show string :=
{
  show := id
}.

Notation p := positive.
Notation n := negative.

Instance showLiteral {V: Set} `{Show V} : Show (Literal V) :=
{
  show :=
    fun x => match x with
              | p a => show a
              | n a => append "¬" (show a)
    end
}.
Open Scope list_scope.
Open Scope string_scope.

Instance showClause {V: Set} `{Show V} : Show (Clause V) :=
{
  show := fun input =>
    let fix showC l : string :=
    match l with
    | nil => ""
    | cons h t => append (append (show h) ",") (showC t)
    end
    in append "[" (append (showC input) "]")
}.
Instance showCNF {V: Set} `{Show V} : Show (CNF V) :=
{
  show := fun input =>
    let fix showCNF l : string :=
    match l with
    | nil => ""
    | cons h t => append (append (show h) ",") (showCNF t)
    end
    in  append "{" (append (showCNF input) "}")
}.

Instance showBool : Show bool :=
{
  show := fun x =>
    match x with
    | true => "T"
    | false => "F"
    end
}.

Definition showSingleAssignment {V:Set} `{Show V} (v:V) (b:bool) :=
  append "[" (append (show v) (append ":=" (append (show b) "]"))).

Instance showFiniteAssignment {V: Set} `{Show V} `{EqDec_eq V} {h : V -> option bool} : (Show (FiniteAssignment h)).
unfold Show. intros fa.
induction fa.
exact "∅".
exact (append (showSingleAssignment v b) IHfa).
Defined.
Print showFiniteAssignment.

Instance showPAssignment {V: Set} `{Show V} `{EqDec_eq V}: (Show (PAssignment V)).
unfold PAssignment. unfold Show.
intros [f1 f2]. exact (show f2).
Defined.

Import VanillaCDCL.
Import CDCLtransition.
Definition VanillaCDCLAlg
(fuel : nat) (f: CNF string):
{g | CNFByPAssignment f g =  Some true}
+ RProof (CNFFormula f) fbot
+ {l2 & {st2 : CDCLState f l2 |  ~ FinalState st2 /\ ~ ConflictingState st2}}.
eapply (VanillaCDCL.Main.CDCLAlg fuel).
Qed.

Section DemoExample.

Definition PrintVanillaCDCLAlg
(fuel : nat) (f: CNF string):
string.
destruct (VanillaCDCLAlg fuel f) as [[result1 | noresult] | noresult].

+ destruct result1 as [pa h].
  exact (show pa).
+ exact (append (show f) " ⊢ Bottom").
+ exact ("Cannot Finish Computing in these fuel").
Qed.

(* Open Scope list_scope.
Open Scope string_scope.

 *)

 Notation p := positive.
 Notation n := negative.
 Import ListNotations.
Definition VanillaCDCLAlg' := PrintVanillaCDCLAlg 2000.

Example Tests : list (CNF string) := [
  [[p "a"; n "a"]];
  [[p "a"]; [n "a"]];
  [[p "a"; p "b"]; [n "a"]];
  [[n "b"; p "a"; n "a"]; [n "b"; p "a"]; [n "b"; p "a"]];
  [[p "b"; n "a"]; [p "b"; p "a"]];
  [[n "a"; p "b"]; [n "b"; p "c"]; [n "c"; p "d"]; [n "d"; p "e"]; [n "e"; p "f"]];
  [[n "a"; p "b"]; [n "a"; n "b"; p "c"]; [n "a"; n "b"; n "c"; p "d"]; [n "a"; n "b"; n "c"; n "d"; p "e"]; [n "a"; n "b"; n "c"; n "d"; n "e"; p "f"]];
  (* Small *)
  [[n "b"]; [p "a"; n "a"]];
  [[p "b"; n "b"]; [p "b"; n "a"; p "a"]];
  [[p "a"; n "a"]; [n "b"; p "a"]];
  [[n "b"]; [p "b"; n "a"]];
  [[n "b"; n "a"]; [p "a"]];
  [[n "b"; p "a"]; [p "b"; n "b"]];
  [[n "b"]; [p "b"; n "b"]];
  [[n "b"; p "a"; n "a"]; [n "b"; p "a"; n "a"]; [n "a"]];
  [[n "a"; p "b"]; [n "b"; p "c"]];
  [[n "a"; p "a"]; [p "c"; p "a"]; [n "c"]; [p "c"; n "b"]; [n "a"]; [n "c"; p "a"]];

  (* Random Small 2 *)
  [[p "a"]; [p "a"]; [n "b"; p "a"; p "b"]; [n "b"]; [n "b"; n "c"; p "b"; n "a"]; [p "a"]];
  [[n "a"; n "c"]; [n "a"; p "b"]; [p "b"]; [p "d"]];
  [[p "a"; p "b"]; [n "a"; n "b"; p "a"]; [p "a"; p "c"]; [p "a"; p "b"; p "c"]; [n "b"; p "a"; n "a"]; [n "a"]; [n "b"; n "c"; p "a"; n "d"]; [p "c"]; [n "b"; n "a"]; [n "a"]];
  [[p "a"; p "e"]; [n "a"; n "b"]; [n "b"; p "a"; p "b"]; [n "d"]; [n "f"]; [n "b"; n "d"; p "b"]];
  [[p "a"; n "d"; p "b"]; [p "b"]; [p "a"]; [n "a"]];
  [[p "c"]; [p "a"; p "b"; p "f"]; [n "c"; p "b"]; [n "a"; p "a"]; [n "c"]];
  [[n "a"]; [n "b"; n "c"; p "d"]; [n "b"; p "a"]; [p "a"; p "c"]; [n "c"; p "c"]; [n "a"; p "a"]; [n "b"; p "c"]];
  [[n "b"; p "a"; p "c"; p "d"]; [p "d"]; [n "b"]; [p "b"; p "c"]];
  [[n "a"; p "a"]; [n "d"; p "a"]; [p "a"]; [n "a"; n "c"]; [n "a"; p "b"]; [p "a"; p "b"; p "c"]; [n "a"; n "b"; n "c"; p "b"]; [n "b"; p "a"; n "a"]; [n "c"; p "a"]; [p "a"]];
  [[n "a"; p "c"]; [n "a"; n "b"; p "a"]; [n "a"; p "c"]; [p "b"]; [n "b"; p "b"]; [n "b"; p "a"]; [n "b"; p "b"]; [n "b"]; [n "a"; n "c"]];
  (* Random Larger : poisson(3) + 1 *)
  [[p "b"; n "e"; n "c"; n "d"; n "b"]; [p "d"; p "c"; p "b"; p "f"; n "c"]; [p "d"; p "c"; n "d"; n "b"; n "a"; p "i"]; [n "h"; p "a"; n "f"]; [p "d"; n "b"]; [p "c"; p "b"; n "e"; n "c"; n "b"]];
[[p "d"; n "d"; n "f"]; [p "d"; n "d"; n "c"]; [p "d"; p "c"; n "e"; p "f"; n "d"; n "c"]; [p "d"]; [p "d"; p "c"; n "e"; p "e"; n "b"]; [n "e"; n "d"; n "b"]];
[[p "f"; p "c"]; [p "e"; p "d"; p "b"; p "g"]; [p "d"; p "b"; n "e"; n "d"; n "c"]; [p "c"; n "e"; n "d"]; [p "c"; n "b"]];
[[p "e"; p "d"; n "c"]; [p "c"; n "e"; n "d"; n "c"]; [p "e"; p "d"; p "f"]; [p "d"; n "d"; p "h"; n "f"]];
[[p "d"; p "g"; n "e"]; [p "d"; n "e"; n "b"]; [p "e"; n "b"; n "d"; n "c"]; [n "e"; n "d"]; [p "i"; n "d"; n "b"]; [p "d"; n "d"; n "b"]];
[[p "d"; p "c"]; [p "d"; p "c"; p "f"; n "g"; n "b"]; [p "d"; p "c"; n "e"; n "g"; p "e"; n "b"; n "c"]; [p "d"; p "c"; n "c"; n "b"; n "a"]; [p "d"; p "c"; p "b"; n "g"; p "e"; n "d"]];
[[p "d"; p "b"; n "d"]; [p "d"; n "e"; n "d"; n "c"; n "a"; p "a"]; [p "e"; p "d"; n "e"; n "b"]; [p "c"; n "e"; p "f"; p "e"; n "d"; n "b"]; [n "h"; p "d"; p "g"; n "d"]; [p "e"; p "c"; n "c"]];
[[p "f"; p "c"; p "g"; n "k"]; [p "c"; p "h"; p "e"; n "c"; p "a"]; [p "e"; p "d"; p "c"; n "e"]; [p "d"; p "c"; n "f"; p "e"; n "c"; n "a"; p "a"]; [p "f"; p "c"; p "d"; n "b"]; [n "c"; n "f"; n "b"]; [p "e"; p "d"; p "c"; n "e"]; [p "f"; n "j"; p "b"; n "c"]; [p "b"; n "e"; n "d"; n "c"]; [p "d"; p "b"; p "e"; n "d"; n "b"; p "g"]];
[[p "d"; p "c"; n "e"; p "f"; n "b"]; [p "d"; p "c"; n "e"; p "f"; p "e"; p "a"]; [n "a"; p "f"; n "d"; n "f"]; [p "b"; n "g"; p "e"; n "b"; n "c"]; [p "d"; p "c"; n "d"]; [p "f"; p "g"]];
[[p "d"; p "b"; p "f"; n "c"; p "a"]; [p "b"; n "e"; p "h"; n "b"]; [p "f"; n "e"; n "d"; n "c"]; [p "d"; p "c"; p "a"]; [n "g"; p "c"; n "e"; n "c"]];

  (* Random Even Larger : poisson(5) + 1*)

  [[p "h"; p "c"; n "d"; n "j"; p "e"; n "g"; n "l"; n "e"]; [n "d"; n "f"; n "h"; p "d"; p "f"; n "e"; n "i"]; [n "f"; p "g"; p "e"; n "h"; n "k"; n "g"; n "b"; n "e"]; [p "n"; p "e"; n "h"; n "e"; n "c"]; [p "h"; n "d"; p "c"; p "f"; n "g"; n "b"; n "e"]];
[[p "d"; p "f"; n "e"; n "i"]; [p "h"; p "c"; n "c"; p "e"]; [n "d"; n "g"; p "c"; p "i"; n "b"; n "e"]; [n "f"; p "i"; n "d"; n "l"]; [n "d"; p "c"; p "g"; p "e"; n "g"]];
[[n "d"; p "g"; n "j"; p "b"; n "g"]; [p "h"; n "d"; p "j"; n "f"; p "k"; n "h"]; [n "f"; p "e"; n "j"; n "g"]; [p "h"; n "f"; p "g"; p "f"; n "h"; p "c"; p "d"; p "i"; n "b"; n "e"]; [p "c"; n "j"; p "e"; n "g"; p "d"]; [p "f"; p "h"; n "i"]; [p "j"; p "g"; n "g"; p "d"; p "f"]; [n "m"; n "f"; p "g"; p "e"; n "h"; n "g"]; [p "h"; n "f"; p "g"; p "e"; p "d"; p "i"; p "f"]; [n "f"; p "g"; n "k"; p "e"]];
[[n "d"; p "j"; p "k"; p "b"; p "c"; p "i"; n "e"; n "c"; n "i"]; [n "f"; p "e"; p "i"; n "e"; n "c"]; [n "f"; n "e"]; [n "d"; p "h"; n "f"; p "g"; p "e"; n "e"]];
[[p "i"; p "g"; n "d"; n "g"]; [p "g"; p "e"; p "d"; p "f"; n "e"]; [p "h"; n "f"; p "e"; p "d"; p "f"]; [p "d"; n "k"; n "g"]; [n "h"; n "d"]; [p "c"; n "f"; p "e"; n "g"; p "i"; p "f"; n "e"]];
[[n "d"; p "h"; n "g"; p "e"; p "c"; p "f"; n "e"; n "c"]; [n "d"; p "h"; p "g"; p "e"; n "h"; n "e"]; [n "i"; p "f"; p "e"]; [p "i"; p "f"; n "e"; n "d"]; [n "d"; p "g"; p "e"; n "g"; n "e"; n "c"]];
[[n "d"; p "g"; p "b"; p "d"; n "e"; n "i"]; [n "h"; p "e"; n "e"; n "g"]; [p "h"; n "f"; p "e"; n "g"; n "e"; n "i"]; [n "d"; n "f"; p "e"; p "f"; n "e"]; [n "f"; p "d"; n "l"; p "f"; n "c"; n "i"]];
[[n "d"; p "h"; p "g"; p "e"; p "f"]; [n "d"; p "h"; p "g"; p "a"; n "h"; n "g"; p "f"; n "e"]; [p "g"; p "b"; n "h"; p "a"; p "c"; p "f"; n "e"; n "c"; n "i"]; [n "d"; p "g"; p "k"; p "e"; n "e"; n "i"]; [n "d"; p "c"; p "e"]; [n "h"; n "e"; n "g"]; [p "g"; n "e"; p "b"; n "g"]; [p "j"; p "g"; p "b"; p "d"; n "e"]; [p "e"; n "g"; p "d"; p "f"; n "e"; n "c"]];
[[p "g"; n "e"; p "h"]; [p "h"; p "j"; n "g"; p "d"; p "i"]; [p "h"; p "g"; p "e"; p "d"; n "e"]; [n "d"; n "j"; p "e"; n "g"; p "d"; p "f"]; [p "h"; n "f"; p "b"; n "g"; p "i"; n "e"]; [n "h"; n "b"; n "d"]; [n "f"; p "g"; p "l"; n "h"; n "b"; p "f"]; [p "d"; p "i"; n "c"; n "i"]; [p "h"; n "f"; p "e"; p "f"; n "e"; n "i"]];
[[n "f"; p "e"; n "h"; n "b"; p "f"; n "e"; n "c"; n "i"]; [p "h"; n "j"; p "e"; n "h"; p "f"; n "e"; n "i"]; [p "h"; n "d"; p "e"; p "d"; p "i"; n "b"; n "e"; n "c"]; [n "h"; p "e"; n "b"; p "g"]; [p "k"; p "e"; n "g"; p "d"; p "f"]; [n "f"; n "l"; p "g"; p "c"]; [n "h"; p "f"; p "h"; p "e"]; [p "b"; p "e"; p "c"; p "d"; p "i"; p "f"]; [n "j"; p "e"; p "c"; p "d"; p "f"; n "e"; n "i"]; [n "d"; p "k"; p "b"; p "e"; n "g"; p "d"; p "f"; n "c"]; [n "d"; p "h"; p "j"; p "g"; p "e"; n "g"; p "f"; n "e"]]
].

Example RunTests : list string :=
  map (fun x =>
        (append
          (show x)
          (append
            " ===> "
            (VanillaCDCLAlg' x)))) Tests.

End DemoExample.

Extraction "tests/CDCLTests.ml" RunTests.


Require Import VST.msl.msl_standard.

Local Open Scope pred.

Lemma andp_TT {A}`{ageable A}: forall (P: pred A), P && TT = P.
Proof.
intros.
apply pred_ext; intros w ?.
destruct H0; auto.
split; auto.
Qed.

Lemma sepcon_andp_prop' {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall P Q R, (!!Q && P)*R = !!Q&&(P*R).
Proof.
intros.
rewrite sepcon_comm. rewrite sepcon_andp_prop.
rewrite sepcon_comm; auto.
Qed.

Hint Rewrite @sepcon_emp @emp_sepcon @TT_and @andp_TT
             @exp_sepcon1 @exp_sepcon2
               @exp_andp1 @exp_andp2
         @sepcon_andp_prop @sepcon_andp_prop'
        : normalize.

Definition pure {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
     (P: pred A) : Prop :=
   P |-- emp.

Lemma pure_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall (P : pred A), pure P -> P*P=P.
Proof.
pose proof I.
intros.
apply pred_ext; intros w ?.
assert ((emp * P)%pred w).
eapply sepcon_derives; try apply H1; auto.
rewrite emp_sepcon in H2.
auto.
exists w; exists w.
split; [|split]; auto.
apply H0 in H1.
do 3 red in H1. apply identity_unit' in H1.
apply H1.
Qed.

Lemma pure_e {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall (P: pred A), pure P -> (P |-- emp).
Proof.
intros.
apply H.
Qed.

#[export] Hint Resolve pure_e : core.

Lemma sepcon_pure_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall P Q, pure P -> pure Q -> ((P * Q) = (P && Q)).
Proof.
intros.
apply pred_ext; intros w ?.
destruct H1 as [w1 [w2 [? [? ?]]]].
unfold pure in *.
assert (unit_for w1 w2). apply H in H2; simpl in H2;
apply identity_unit; auto. exists w; auto.
unfold unit_for in H4.
assert (w2=w) by (apply (join_eq H4 H1)).
subst w2.
assert (join w w1 w1).
apply identity_unit; apply H0 in H3; simpl in H3; auto. exists w; auto.
assert (w1=w) by (apply (join_eq H5 (join_comm H1))).
subst w1.
split; auto.
destruct H1.
exists w; exists w; split; [|split]; auto.
apply H in H1.
do 3 red in H1.
clear dependent P. clear dependent Q.
pose proof (core_unit w); unfold unit_for in *.
pose proof (H1 _ _ (join_comm H)).
rewrite H0 in H; auto.
Qed.

Lemma pure_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: pure emp.
Proof.
intros. unfold pure; auto.
Qed.
#[export] Hint Resolve pure_emp : core.

Lemma join_equiv_refl {A}: forall x:A, @join A (Join_equiv A) x x x.
Proof. split; auto. Qed.
#[export] Hint Resolve join_equiv_refl : core.

Lemma pure_sepcon1'' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall P Q R, pure P -> Q |-- R -> P * Q |-- R.
Proof.
pose proof I.
intros.
intros w [w1 [w2 [? [? ?]]]].
apply H0 in H3.
apply join_unit1_e in H2; auto.
subst; auto.
Qed.

Lemma pure_existential {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall B (P: B -> pred A),    (forall x: B , pure (P x)) -> pure (exp P).
Proof.
intros.
unfold pure in *.
intros w [x ?].
apply (H x); auto.
Qed.

#[export] Hint Resolve pure_existential : core.

Lemma pure_core {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P w, pure P -> P w -> P (core w).
Proof.
intros.
rewrite <- identity_core; auto.
apply H; auto.
Qed.

Lemma FF_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
           forall P, FF * P = FF.
Proof.
intros.
apply pred_ext; intros w ?; try contradiction.
destruct H as [w1 [w2 [? [? ?]]]]; contradiction.
Qed.
Lemma sepcon_FF {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
            forall P, P * FF = FF.
Proof.
intros.
rewrite sepcon_comm. apply FF_sepcon.
Qed.
Hint Rewrite @FF_sepcon @sepcon_FF : normalize.

Hint Rewrite @prop_true_andp using (solve [auto]) : normalize.

Lemma true_eq {A} `{ageable A}:  forall P: Prop, P -> (!! P) = (TT: pred A).
Proof.
intros. apply pred_ext; intros ? ?; simpl in *; intuition.
Qed.
Hint Rewrite @true_eq using (solve [auto]) : normalize.

Lemma pure_con' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
      forall P Q, pure P -> pure Q -> pure (P*Q).
Proof.
intros.
unfold pure in *.
rewrite <- sepcon_emp.
apply sepcon_derives; auto.
Qed.
#[export] Hint Resolve pure_con' : core.

Lemma pure_intersection1: forall {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
       (P Q: pred A), pure P -> pure (P && Q).
Proof.
unfold pure; intros; auto.
intros w [? ?]; auto.
Qed.
Lemma pure_intersection2: forall {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}
     (P Q: pred A), pure Q -> pure (P && Q).
Proof.
unfold pure; intros; auto.
intros w [? ?]; auto.
Qed.
#[export] Hint Resolve pure_intersection1 pure_intersection2 : core.

Lemma FF_andp {A} `{ageable A}:  forall P: pred A, FF && P = FF.
Proof.
unfold FF, prop, andp; intros; apply pred_ext; intros ? ?; simpl in *; intuition.
Qed.
Lemma andp_FF {A}`{ageable A}:  forall P: pred A, P && FF = FF.
Proof.
unfold FF, prop, andp; intros; apply pred_ext; intros ? ?; simpl in *; intuition.
Qed.
Hint Rewrite @FF_andp @andp_FF : normalize.

Hint Rewrite @andp_dup : normalize.

Lemma andp_emp_sepcon_TT {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall (Q: pred A),
     (forall w1 w2, core w1 = core w2 -> Q w1 -> Q w2) ->
      (Q && emp * TT = Q).
Proof.
intros.
apply pred_ext.
intros w [w1 [w2 [? [[? ?] ?]]]].
apply H with w1; auto.
apply join_core in H0; auto.
intros w ?.
destruct (join_ex_identities w) as [e [He [? Hj]]].
exists e; exists w; split; [|split]; auto.
specialize (He _ _ Hj); subst; auto.
split; auto.
apply H with w; auto.
symmetry; eapply join_core2; eauto.
Qed.

Lemma sepcon_TT {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall (P: pred A), P |-- (P * TT).
Proof.
intros.
rewrite <- (sepcon_emp P) at 1.
eapply sepcon_derives; try apply H0; auto.
Qed.
#[export] Hint Resolve sepcon_TT : core.

Lemma imp_extract_exp_left {B A: Type} `{ageable A}:
    forall    (p : B -> pred A) (q: pred A),
  (forall x, p x |-- q) ->
   exp p |-- q.
Proof.
intros.
intros w [x ?].
eapply H0; eauto.
Qed.

Lemma pure_sepcon_TT_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, pure P -> (P * TT) && Q = (P*Q).
Proof.
 pose proof I.
intros.
apply pred_ext.
intros w [? ?].
destruct H1 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; split; [|split]; auto.
apply join_unit1_e in H1; auto.
subst; auto.
apply H0 in H3; auto.
apply andp_right.
apply sepcon_derives; auto.
intros w [w1 [w2 [? [? ?]]]].
apply join_unit1_e in H1; auto.
subst; auto.
apply H0 in H2; auto.
Qed.

Lemma pure_sepcon_TT_andp' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q, pure P -> Q && (P * TT) = (Q*P).
Proof.
intros. rewrite andp_comm.
rewrite pure_sepcon_TT_andp; auto.
apply sepcon_comm.
Qed.

Hint Rewrite @pure_sepcon_TT_andp @pure_sepcon_TT_andp' using (solve [auto]): normalize.

Lemma pure_sepcon1' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:

  forall P Q R, pure P -> P * Q |-- P * R -> P * Q |-- R.
Proof.
intros.
eapply derives_trans; try apply H0.
apply pure_sepcon1''; auto.
Qed.

Lemma pull_right {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall P Q R,
   (Q * P * R) = (Q * R * P).
Proof.
intros. repeat rewrite sepcon_assoc. rewrite (sepcon_comm P); auto.
Qed.

Lemma pull_right0 {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall P Q,
   (P * Q) = (Q * P).
Proof.
intros. rewrite (sepcon_comm P); auto.
Qed.

Ltac pull_left A := repeat (rewrite <- (pull_right A) || rewrite <- (pull_right0 A)).

Ltac pull_right A := repeat (rewrite (pull_right A) || rewrite (pull_right0 A)).

Lemma pure_modus {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall P Q,  P |-- Q -> pure Q -> P |-- Q && P.
Proof.
intros.
intros w ?.
split; auto.
Qed.

Lemma imp_exp_right {B A : Type} `{saA: ageable A}:
  forall (x: B) (p: pred A) (q: B -> pred A),
    p |-- q x ->
    p |-- exp q.
Proof.
intros.
eapply derives_trans; try apply H.
intros w ?; exists x; auto.
Qed.

Lemma derives_extract_prop {A} `{ageable A}:
  forall (P: Prop) (Q R: pred A), (P -> Q |-- R) ->  !!P && Q |-- R.
Proof.
unfold derives, prop, andp; hnf in *; intuition.
hnf in H1; intuition.
Qed.

Lemma derives_extract_prop' {A} `{ageable A}:
  forall (P: Prop) (Q R: pred A), (P -> Q |-- R) ->  Q && !!P|-- R.
Proof.
unfold derives, prop, andp; intuition; hnf in *; intuition.
hnf in *; intuition. apply H1; auto.
Qed.

Ltac normalize1 :=
             match goal with
                | |- _ => contradiction
                | |- context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) by (auto with normalize)
                | |- context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) by (auto with normalize)
                | |- context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) by (auto with normalize)
                | |- context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) by (auto with normalize)
                | |- _ => progress  (autorewrite with normalize); auto with typeclass_instances
                | |- _ = ?x -> _ => intro; subst x
                | |- ?x = _ -> _ => intro; subst x
                |  |- ?ZZ -> _ => match type of ZZ with
                                               | Prop =>
                                                    let H := fresh in
                                                       ((assert (H:ZZ) by auto; clear H; intros _) || intro H)
                                               | _ => intros _
                                              end
                | |- forall _, _ => let x := fresh "x" in (intro x; normalize1; try generalize dependent x)
                | |- exp _ |-- _ => apply imp_extract_exp_left
                | |- !! _ && _ |-- _ => apply derives_extract_prop
                | |- _ && !! _ |-- _ => apply derives_extract_prop'
                | |- _ |-- !! (?x = ?y) && _ =>
                            (rewrite prop_true_andp with (P:= (x=y))
                                            by (unfold y; reflexivity); unfold y in *; clear y) ||
                            (rewrite prop_true_andp with (P:=(x=y))
                                            by (unfold x; reflexivity); unfold x in *; clear x)
                | |- _ => solve [auto with typeclass_instances]
                end.

Ltac normalize1_in Hx :=
             match type of Hx with
                | app_pred (exp _) _ => destruct Hx
                | app_pred (!! _ && _) _ => let H1 := fresh in destruct Hx as [H1 Hx]; unfold prop in H1
                | context [ !! ?P ] =>
                                    rewrite (true_eq P) in Hx by auto with typeclass_instances
                | context [ !! ?P && ?Q ] =>
                                    rewrite (prop_true_andp P Q) in Hx by auto with typeclass_instances
                | context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) in Hx by (auto with normalize)
                | context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) in Hx by (auto with normalize)
                | context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) in Hx by (auto with normalize)
                | context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) in Hx by (auto with normalize)
                | _ => progress  (autorewrite with normalize in Hx); auto with typeclass_instances
                end.

Ltac normalize := repeat normalize1.

Tactic Notation "normalize" "in" hyp(H) := repeat (normalize1_in H).

Definition mark {A: Type} (i: nat) (j: A) := j.

Lemma swap_mark1 {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall i j Pi Pj B, (i<j)%nat -> B * mark i Pi * mark j Pj = B * mark j Pj * mark i Pi.
Proof.
intros.
repeat rewrite sepcon_assoc.
f_equal.
apply sepcon_comm.
Qed.

Lemma swap_mark0 {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall i j Pi Pj,  (i<j)%nat -> mark i Pi * mark j Pj = mark j Pj * mark i Pi.
Proof.
intros.
apply sepcon_comm.
Qed.

Ltac select_left n :=
  repeat match goal with
 | |- context [(_ * mark ?i _ * mark n _)%pred] =>
      rewrite (swap_mark1 i n); [ | solve [simpl; auto]]
 | |- context [(mark ?i _ * mark n _)%pred] =>
      rewrite (swap_mark0 i n); [ | solve [simpl; auto]]
end.
Ltac select_all n := match n with
                                | O => idtac
                                | S ?n' => select_left n; select_all n'
                              end.
Ltac markem n P :=
   match P with
   | (?Y * ?Z) =>
        (match goal with H: mark _ Z = Z |- _ => idtac end
        || assert (mark n Z = Z) by auto); markem (S n) Y
   | ?Z =>  match goal with H: mark _ Z = Z |- _ => idtac end
                || assert (mark n Z = Z) by auto
  end.

Ltac prove_assoc_commut :=
 clear;
 try (match goal with |- ?F _ -> ?G _ => replace G with F; auto end);
  (repeat rewrite <- sepcon_assoc;
   match goal with |- ?P = _ => markem O P end;
   let LEFT := fresh "LEFT" in match goal with |- ?P = _ => set (LEFT := P) end;
  match goal with H: mark ?n _ = _ |- _ =>
     repeat  match goal with H: mark ?n _ = ?P |- _ => rewrite <- H; clear H end;
     select_all n;
     reflexivity
   end).

Lemma test_prove_assoc_commut {T}{JA: Join T}{PA: Perm_alg T}{agA: ageable T}{AgeA: Age_alg T} : forall A B C D E : pred T,
   D * E * A * C * B = A * B * C * D * E.
Proof.
intros.
prove_assoc_commut.
Qed.


Require Import Platform.Cito.CompileStmtSpec.
Require Import Bedrock.StringSet.
Require Import Platform.Cito.FreeVars.
Require Import Platform.Cito.SynReqFactsUtil.

Local Infix ";;" := Syntax.Seq (right associativity, at level 95).

Lemma syn_req_Label_in : forall vars temp_size x lbl k, syn_req vars temp_size (Syntax.Label x lbl ;; k) -> List.In x vars.
  unfold syn_req, in_scope; simpl; intuition.
  apply Subset_union_left in H; intuition.
  apply Subset_singleton in H0.
  apply to_set_In; auto.
Qed.

Lemma syn_req_Assign_in : forall vars temp_size x e k, syn_req vars temp_size (Syntax.Assign x e ;; k) -> List.In x vars.
  unfold syn_req, in_scope; simpl; intuition.
  apply Subset_union_left in H; intuition.
  apply Subset_union_left in H0; intuition.
  apply Subset_singleton in H.
  apply to_set_In; auto.
Qed.


(** Based on https://github.com/xuanruiqi/categories/blob/master/functor.v and natural.v *)

From sgdt Require Import preamble category.

Local Open Scope category_scope.
Set Universe Polymorphism.

Module Prefunctor.
  Structure mixin_of(C D : Category.type) (F : C -> D) : Type :=
    Mixin {fhom : forall {x y : C} (f : x ~> y), F x ~> F y}.

  Structure type (C D : Category.type) := Pack {func : C -> D; class : mixin_of C D func}.

  Arguments func [C] [D].
  Arguments class [C] [D].

  Lemma ext {C D}: forall F G : type C D, forall h : func F = func G, rew h in class F = class G -> F = G.
  Proof.
    move=> [F homF] [G homG] //= FG.
    move: G FG homG.
    by apply: eq_ind=> homG//= ->.
  Qed.

  Module Exports.
    Coercion func : type >-> Funclass.

    Section fhom.
      Context {C D : Category.type}.
      Definition fhom (F : type C D) {x y : C} : x ~> y -> F x ~> F y.
        move=> xy.
        apply: fhom.
        - apply: class.
        - apply: xy.
      Defined.
    End fhom.

    Notation "F @@ f" := (fhom F f) (at level 50) : category_scope.
  End Exports.
End Prefunctor.

Export Prefunctor.Exports.

Module Functor.
  Section Laws.
    Context {C D : Category.type} (F : Prefunctor.type C D).
    Definition law_fidn := forall x : C, F @@ (idn x) = idn (F x).
    Definition law_fseq := forall (u v w : C) (uv : u ~> v) (vw : v ~> w), F @@ (uv >> vw) = F @@ uv >> F @@ vw.
  End Laws.

  Section ClassDef.
    Context (C D : Category.type).
    Structure mixin_of (F : Prefunctor.type C D) := Mixin {fidn : law_fidn F; fseq : law_fseq F}.
    Structure type := Pack {func : Prefunctor.type C D; class : mixin_of func}.
  End ClassDef.
  Arguments func [C] [D].

  Lemma ext {C D} : forall F G : type C D, func F = func G -> F = G.
  Proof.
    move=> [F hF] [G hG] //= FG.
    move: G FG hG.
    apply: eq_ind=> hG.
    by congr Pack.
  Qed.

  Module Exports.
    Coercion func : type >-> Prefunctor.type.
    Global Hint Unfold law_fidn law_fseq : core.
  End Exports.
End Functor.

Export Functor.Exports.

Infix "~~>" := Functor.type (at level 100) : category_scope.

Section Facts.
  Variables (C D : Category.type) (F : C ~~> D).

  Lemma fidn : Functor.law_fidn F.
  Proof. by case: (Functor.class _ _ F). Qed.

  Lemma fseq : Functor.law_fseq F.
  Proof. by case: (Functor.class _ _ F). Qed.
End Facts.

Module StrictCat.
  Definition hom_mixin : Hom.mixin_of Category.type.
  Proof. by build=> C D; exact (C ~~> D). Defined.

  Canonical hom : Hom.type.
  Proof. by esplit; apply: hom_mixin. Defined.

  Definition precat_mixin : Precategory.mixin_of hom.
  Proof.
    build.
    - move=> C D E CD DE.
      build.
      + build.
        * by move=> c; apply/DE/CD/c.
        * build=> x y xy.
          by do 2 apply: fhom.
      + build.
        * move=> x; cbn.
          by rewrite ?fidn.
        * move=> u v w uv vw; cbn.
          by rewrite ?fseq.
    - by move=> X; build; build.
  Defined.

  Canonical precat : Precategory.type.
  Proof. esplit; apply: precat_mixin. Defined.

  Definition cat_mixin : Category.mixin_of precat.
  Proof.
    build.
    - move=> C D E F CD DE EF.
      by apply: Functor.ext.
    - move=> C D CD.
      apply: Functor.ext; cbn.
      by case: CD; case=>+ []//=.
    - move=> C D CD.
      apply: Functor.ext.
      by case: CD; case=>+ []//=.
  Qed.

  Canonical cat : Category.type.
  Proof. esplit; apply: cat_mixin. Defined.
End StrictCat.

Canonical StrictCat.hom.
Canonical StrictCat.precat.
Canonical StrictCat.cat.

Module Compose.
  Section Defs.
    Context {C D E : Category.type} (F : C ~~> D) (G : D ~~> E).

    Definition ob : C -> E.
    Proof. by move/F/G. Defined.

    Definition prefunctor_mixin : Prefunctor.mixin_of C E ob.
    Proof.
      build=> x y f.
      by exact: (G @@ (F @@ f)).
    Defined.

    Canonical prefunctor : Prefunctor.type C E.
    Proof. by esplit; apply: prefunctor_mixin. Defined.

    Definition functor_mixin : Functor.mixin_of C E prefunctor.
    Proof.
      build.
      - move=> x; cbn.
        by rewrite ?fidn.
      - move=> x y z f g; cbn.
        by rewrite ?fseq.
    Qed.

    Canonical functor : C ~~> E.
    Proof. by esplit; apply: functor_mixin. Defined.
  End Defs.
End Compose.

Module NatTrans.
  Section ClassDef.
    Context {C : Category.type} {D : Category.type} (F G : C ~~> D).

    Definition natural (η : forall x, F x ~> G x) :=
      forall (x y : C) (f : x ~> y), F @@ f >> η y = η x >> G @@ f.

    Structure mixin_of (η : forall x, F x ~> G x) :=
      Mixin {_ : natural η}.

    Structure type := Pack {transf; class : mixin_of transf}.
  End ClassDef.

  Arguments class [C] [D] [F] [G] η : rename.
  Arguments transf [C] [D] [F] [G].

  Definition ext {C D} {F G : C ~~> D} : forall (f g : type F G), transf f = transf g -> f = g.
  Proof.
    move=> [f hf] [g hg] //= fg.
    move: g fg hg.
    apply: eq_ind=> hg.
    by congr Pack.
  Qed.

  Module Exports.
    Coercion transf : type >-> Funclass.
  End Exports.
End NatTrans.

Infix "~~~>" := NatTrans.type (at level 55) : category_scope.
Export NatTrans.Exports.

Section naturality.
  Context {C D} {F G : C ~~> D} (η : F ~~~> G).

  Lemma naturality : NatTrans.natural _ _ η.
  Proof. by case/NatTrans.class: η. Qed.
End naturality.

Module NatCompose.
  Section Defs.
    Context {C : Category.type} {D : Category.type} {F G H : C ~~> D} (f : F ~~~> G) (g : G ~~~> H).

    Definition fam : forall x, F x ~> H x.
    Proof.
      move=> x.
      by exact: (f x >> g x).
    Defined.

    Definition mixin : NatTrans.mixin_of _ _ fam.
    Proof.
      build=> x y xy.
      rewrite /fam.
      rewrite seqA.
      rewrite naturality.
      rewrite -seqA.
      rewrite naturality.
      by rewrite seqA.
    Qed.

    Canonical transf : F ~~~> H.
    Proof. by esplit; apply: mixin. Defined.
  End Defs.
End NatCompose.

Module NatIdn.
  Section Defs.
    Context {C D : Category.type} (F : C ~~> D).

    Definition fam : forall x, F x ~> F x.
    Proof.
      move=> x.
      apply: idn.
    Defined.

    Definition mixin : NatTrans.mixin_of _ _ fam.
    Proof.
      build=> x y xy.
      by rewrite /fam seqR seqL.
    Defined.

    Canonical transf : F ~~~> F.
    Proof. by esplit; apply: mixin. Defined.
  End Defs.
End NatIdn.

Module FunctorCategory.
  Section FunctorCategory.
    Context (C : Category.type) (D : Category.type).

    Definition hom_mixin : Hom.mixin_of (C ~~> D).
    Proof. by build=> f g; exact (f ~~~> g). Defined.

    Canonical hom : Hom.type.
    Proof. esplit; apply: hom_mixin. Defined.

    Definition functor_seq : Precategory.op_seq hom.
    Proof.
      move=> F G H FG GH.
      build.
      - move=> x; exact: (FG x >> GH x).
      - abstract by build=> x y xy; rewrite seqA naturality -seqA naturality seqA.
    Defined.

    Definition functor_idn : Precategory.op_idn hom.
    Proof.
      move=> F.
      build.
      - by move=> ?; apply: idn.
      - abstract by build=> x y f; rewrite seqL seqR.
    Defined.

    Definition precat_mixin : Precategory.mixin_of hom.
    Proof.
      build.
      - apply: functor_seq.
      - apply: functor_idn.
    Defined.

    Canonical precat : Precategory.type.
    Proof. esplit; apply: precat_mixin. Defined.

    Definition cat_mixin : Category.mixin_of precat.
    Proof.
      build.
      - move=> F G H I FG GH HI.
        apply/NatTrans.ext/dfunE=> x//=.
        by rewrite seqA.
      - move=> F G FG.
        apply/NatTrans.ext/dfunE=> x//=.
        by rewrite seqL.
      - move=> F G FG.
        apply/NatTrans.ext/dfunE=> x//=.
        by rewrite seqR.
    Qed.

    Canonical cat : Category.type.
    Proof. esplit; apply: cat_mixin. Defined.
  End FunctorCategory.
End FunctorCategory.

Canonical FunctorCategory.hom.
Canonical FunctorCategory.precat.
Canonical FunctorCategory.cat.

Notation "Cat[ C , D ]" := (FunctorCategory.cat C D).

Module ConstantFunctor.
  Section ConstantFunctor.
    Context {C D : Category.type} (d : D).

    Definition const : Functor.type C D.
    Proof.
      build.
      - build.
        + by move=> _; exact: d.
        + by build=> _ _ _; apply: idn.
      - by build=> x y z xy yz; rewrite seqL.
    Defined.
  End ConstantFunctor.
End ConstantFunctor.

Notation "{{ x }}" := (ConstantFunctor.const x) : category_scope.
Canonical ConstantFunctor.const.