Require Import Graph.
Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Omega.
Require Import Bag.
Require Import Dict.
Require Import Misc.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import Tracking.
Require Import KonneTactics.
Require Import Equality.
Require Import BGPSpecFacts.
Require Import Policy.
Require Import FastPolicy.
Require Import SpaceSearch.
Require Import SingleAS.
Import EqNotations.
Import ListNotations.

Section BGPV.
  Context `{S:SpaceSearch}.
  Arguments policy [_ _ _ _] _.

  Context `{plainPrefix : PrefixClass}.
  Context `{freePrefix : @Free S Prefix}.

  Context `{plainAttributes : PathAttributesClass}.
  Context `{eqDecPathAttributes : eqDec PathAttributes}.
  Context `{freePathAttributes : @Free S PathAttributes}.

  Context `{SingleASTopologyClass}.
  Context `{@SingleASConfigurationClass _ _ _}.

  Context {freeNeighbors : forall {S:SpaceSearch} s, @Free S {d : router external & neighbor s d}}.
  Context {freeRouters : forall {S:SpaceSearch} t, @Free S (router t)}.

  Existing Instance singleASTopology.
  Existing Instance singleASConfiguration.
  Existing Instance enumerableIncoming.
  Existing Instance eqDecIncoming.
  Existing Instance eqDecSigT.
  Existing Instance enumerableSigT.
  Existing Instance enumerableRoutingInformation.
  Existing Instance eqDecRoutingInformation.
  Existing Instance eqDecRouterType.
  Existing Instance enumerableRouterType.
  Existing Instance freeEmpty.
  Existing Instance freeUnit.
  Existing Instance freeSigT.

  Definition trackingAttributes' := trackingAttributes.
  Definition trackingConfiguration' := @trackingConfiguration _ _ plainAttributes _.
  Existing Instance trackingAttributes' | 0.
  Existing Instance trackingConfiguration' | 0.
  Typeclasses Transparent trackingAttributes'.
  Typeclasses Transparent trackingConfiguration'.

  Ltac specialize_props := repeat
    match goal with
    | h:?P -> _, p:?P |- _ => match type of P with Prop => specialize (h p) end
    end.

  Notation "n <=? m" := (le_dec n m).

  Arguments fastPolicy [_ _ _ _] _.
  Arguments free [_] _ [_].

  Instance freeRouterType {S:SpaceSearch} : @Free S RouterType.
    refine {| free := union (single internal) (single external) |}.
  Proof.
    intros [].
    - apply unionOk.
      left.
      apply singleOk.
      reflexivity.
    - apply unionOk.
      right.
      apply singleOk.
      reflexivity.
  Defined.

  Instance freeOutgoing {S:SpaceSearch} : forall r, @Free S (outgoing [internal & r]).
    unfold outgoing.
    intro r.
    refine {| free := union (bind (free (router internal)) _)
                            (bind (free {d:router external & neighbor r d}) _) |}. {
      (* internal router *)
      intro d.
      destruct (r =? d).
      - exact empty.
      - refine (single [[internal & d] & _]).
        compute.
        break_match.
        + congruence.
        + exact tt.
    } {
      (* external router *)
      intros [d n].
      exact (single [[external & d] & n]).
    }
  Proof.
    (* freeOk *)
    cbn.
    intros [[[] d] c].
    - apply unionOk.
      left.
      apply bindOk.
      exists d.
      constructor; [apply freeOk|].
      case (r =? d).
      + intro.
        subst.
        exfalso.
        break_match.
        * destruct c.
        * congruence.
      + intro.
        apply singleOk.
        break_match.
        match goal with
        | |- [_ & ?E] = _ => generalize E
        end.
        intro c'.
        f_equal.
        clear -c c' n.
        cbn in *.
        compute in *.
        break_match; [destruct c'|].
        destruct c, c'.
        reflexivity.
    - apply unionOk.
      right.
      apply bindOk.
      exists [d & c].
      constructor; [apply freeOk|].
      apply singleOk.
      reflexivity.
  Defined.

  (* compied from freeOutgoing *)
  Instance freeReceivedIncoming {S:SpaceSearch} : forall r, @Free S {s : Router & connection s [internal & r]}.
    intro r.
    refine {| free := union (bind (free (router internal)) _)
                            (bind (free {d:router external & neighbor r d}) _) |}. {
      (* internal router *)
      intro d.
      destruct (r =? d).
      - exact empty.
      - refine (single [[internal & d] & _]).
        compute.
        break_match.
        + congruence.
        + exact tt.
    } {
      (* external router *)
      intros [d n].
      exact (single [[external & d] & n]).
    }
  Proof.
    (* freeOk *)
    cbn.
    intros [[[] d] c].
    - apply unionOk.
      left.
      apply bindOk.
      exists d.
      constructor; [apply freeOk|].
      case (r =? d).
      + intro.
        subst.
        exfalso.
        cbn in c.
        break_match.
        * destruct c.
        * congruence.
      + intro.
        apply singleOk.
        break_match.
        match goal with
        | |- [_ & ?E] = _ => generalize E
        end.
        intro c'.
        f_equal.
        clear -c c' n.
        cbn in *.
        compute in *.
        break_match; [destruct c'|].
        destruct c, c'.
        reflexivity.
    - apply unionOk.
      right.
      apply bindOk.
      exists [d & c].
      constructor; [apply freeOk|].
      apply singleOk.
      reflexivity.
  Defined.

  Instance freeIncoming {S:SpaceSearch} : forall r, @Free S (incoming [internal & r]).
    intros r.
    refine {| free := union (single injected) (bind (free _) (fun i => single (received i))) |}.
  Proof.
    intros s.
    rewrite <- unionOk.
    destruct s as [|s].
    - left.
      apply singleOk.
      reflexivity.
    - right.
      rewrite <- bindOk.
      exists s.
      constructor; [apply freeOk|].
      apply singleOk.
      reflexivity.
  Defined.

  Definition Forwardable r p :=
    {ai:@RoutingInformation trackingAttributes' & {s:incoming r | forwardable r s p ai}}.

  Instance eqDecForwardable : forall r p, eqDec (Forwardable r p).
    intros.
    unfold Forwardable.
    apply eqDecSigT.
  Defined.

  Definition feasiblePath (r ri:router internal) (re:router external)
                          (n:neighbor ri re) : incoming [internal & r] * Path.
    refine(match r =? ri with left e => _ | right e => _ end).
    - refine (let c : connection [external & re] [internal & r] := _ in (_,_)).
      + apply (rew <- [fun ri => neighbor ri re] e in n).
      + refine (received [[external & re] & _]).
        apply c.
      + exact (hop [external & re] [internal & r] c
              (start [external & re])).
    - refine (let c : connection [internal & ri] [internal & r] := _ in (_,_)).
      + cbn.
        break_match.
        * exfalso.
          apply e.
          symmetry.
          trivial.
        * exact tt.
      + refine (received [[internal & ri] & _]).
        apply c.
      + exact (hop [internal & ri] [internal & r] c
              (hop [external & re] [internal & ri] n
              (start [external & re]))).
  Defined.

  Definition transmit' (r ri:router internal) (re:router external) (n:neighbor ri re) (p:Prefix)
                       (a0:@PathAttributes plainAttributes) : incoming [internal & r] * RoutingInformation.
    refine(let sP := feasiblePath r ri re n in ((fst sP),_)).
    refine(match transmit (snd sP) p (available a0) _ with
    | available a => available {|current:=a; original:=a0; path:=(snd sP)|}
    | notAvailable => notAvailable
    end).
  Proof.
    abstract (
      inline_all;
      unfold feasiblePath;
      destruct (r =? ri); compute; intuition
    ).
  Defined.

  Lemma longPathsAreNotForwardable r s p (a0 a:@PathAttributes plainAttributes) r0 r1 r2 r3 r4 r5 P c01 c23 c45 :
    ~@forwardable _ _ plainAttributes _ [internal & r] s p (available {| original := a0; current := a; path := hop r0 r1 c01 (hop r2 r3 c23 (hop r4 r5 c45 P)) |}).
  Proof.
    unfold forwardable, not.
    intros [pok tok].
    specialize_props.
    destruct tok as [tok pok'].
    cbn in pok'.
    destruct pok' as [? pok'].
    subst_max.
    specialize (pok' eq_refl).
    cbn in pok'.
    subst_max.
    cbn in pok.
    break_and.
    subst_max.
    unfold path in *.
    Opaque transmit.
    cbn in *.
    rename r3 into ri.
    rename r5 into re.
    rename c01 into crri.
    rename c23 into crire.
    enough (available a = notAvailable) by congruence.
    rewrite <- tok; clear tok.
    destruct ri as [[] ri].
    Set Printing Width 200.
    - (* ri is internal *)
      destruct re as [[] re].
      + (* re is internal *)
        Transparent transmit.
        cbn.
        reflexivity.
      + (* ri is external *)
        cbn.
        unfold import'.
        unfold bindRoutingInformation.
        cbn.
        repeat break_match; congruence.
    - (* ri is external *)
      cbn.
      unfold import'.
      unfold bindRoutingInformation.
      cbn.
      repeat break_match; congruence.
  Qed.

  Definition forwardableImpliesTransmit r s p ai :
    @forwardable _ _ plainAttributes _ [internal & r] s p (available ai) -> {ri:router internal & {re:router external & {n:neighbor ri re |
          fst (transmit' r ri re n p (original ai)) = s /\ snd (transmit' r ri re n p (original ai)) = available ai}}}.
  Proof.
    intro tok.
    destruct ai as [a0 a P].
    refine (match P as P' return P = P' -> _ with
    | hop r' ri' c (hop ri re' n (start re)) => fun _ => _
    | hop r' re' c (start re) => fun _ => _
    | _ => fun _ => False_rect _ _
    end eq_refl).
    + (* path length is 0 *)
      idtac.
      subst_max.
      unfold forwardable in *.
      intuition.
      specialize_props.
      intuition.
      cbn in *.
      destruct r0 as [[] r'].
      - (* router is internal, which cannot originate *)
        cbn in *.
        congruence.
      - (* router is external, which means it's <> r *)
        intuition.
        congruence.
    + (* path length is 1 *)
      subst_max.
      Opaque transmit.
      Set Printing Width 200.
      cbn in tok.
      unfold original.
      destruct tok as [[] tok].
      subst_max.
      specialize (tok (conj I eq_refl)).
      destruct tok as [tok [? eq]].
      subst_max.
      specialize (eq eq_refl).
      cbn in eq.
      subst_max.
      exists r.
      destruct re as [[] re].
      - (* re coming from internal *)
        exfalso.
        Transparent transmit.
        cbn in *.
        congruence.
      - (* re coming from external *)
        Opaque transmit.
        exists re.
        exists c.
        intuition.
        * unfold transmit'.
          cbn.
          unfold feasiblePath.
          cbn in c.
          generalize (r =? r) at 1.
          intro.
          destruct s; [|congruence].
          cbn.
          simpl_eq.
          cbn.
          reflexivity.
        * unfold transmit'.
          cbn in *.
          assert (snd (feasiblePath r r re c) = hop [external & re] [internal & r] c (start [external & re])) as e. {
            clear.
            unfold feasiblePath.
            cbn.
            generalize (r =? r) at 1.
            intro s; destruct s; [|congruence].
            cbn.
            simpl_eq.
            cbn.
            reflexivity.
          }
          revert tok.
          generalize_proofs.
          revert p1.
          cbn in *.
          rewrite e.
          intros.
          unfold pathOk in p1.
          generalize_proofs.
          rewrite tok.
          reflexivity.
    + (* path length is 2 *)
      subst_max.
      Opaque transmit.
      Set Printing Width 200.
      cbn in tok.
      unfold original.
      destruct tok as [[[] ?] tok].
      subst_max.
      specialize (tok (conj (conj I eq_refl) eq_refl)).
      destruct tok as [tok [? eq]].
      subst_max.
      specialize (eq eq_refl).
      cbn in eq.
      subst_max.
      rename re' into ri.
      destruct ri as [[] ri]; destruct re as [[] re].
      - (* re coming from internal *)
        exfalso.
        Transparent transmit.
        cbn in *.
        congruence.
      - exists ri.
        exists re.
        exists n.
        intuition.
        * unfold transmit'.
          cbn.
          unfold feasiblePath.
          destruct (r =? ri). {
            exfalso.
            subst_max.
            clear -c.
            cbn in c.
            break_match; [|congruence].
            inversion c.
          } {
            cbn.
            f_equal.
            f_equal.
            cbn in c.
            clear.
            destruct (ri =? r).
            - congruence.
            - destruct c.
              reflexivity.
          }
        * unfold transmit'.
          cbn.
          case (ri =? r). {
            intro.
            exfalso.
            subst_max.
            clear -c.
            cbn in c.
            break_match; [|congruence].
            inversion c.
          } {
            intro.
            assert (snd (feasiblePath r ri re n) = (hop [internal & ri] [internal & r] c (hop [external & re] [internal & ri] n (start [external & re])))) as E. {
              clear -n0.
              unfold feasiblePath.
              break_match; [congruence|].
              cbn.
              f_equal.
              clear.
              cbn in c.
              break_match; [congruence|].
              destruct c.
              reflexivity.
            }
            generalize_proofs.
            revert p2.
            cbn.
            rewrite E.
            intro p2.
            revert tok.
            generalize_proofs.
            cbn.
            intro.
            rewrite tok.
            reflexivity.
          }
      - exfalso.
        Transparent transmit.
        cbn in *.
        congruence.
      - exfalso.
        Transparent transmit.
        cbn in *.
        break_match; congruence.
    + (* paths with length > 2 *)
      subst_max.
      apply longPathsAreNotForwardable in tok.
      trivial.
  Defined.

  Lemma transmitIsForwardable r ri re n p a0 :
    @forwardable _ _ plainAttributes _ [internal & r] (fst (transmit' r ri  re  n  p a0 )) p (snd (transmit' r ri  re  n  p a0 )).
  Proof.
    unfold forwardable.
    break_match; [|intuition].
    intuition.
    - cbn in *.
      break_match; [|congruence].
      find_inversion.
      clear.
      cbn.
      unfold feasiblePath.
      break_match.
      + cbn. intuition.
      + cbn. intuition.
    - cbn in *.
      break_match; [|congruence].
      find_inversion.
      cbn in *.
      match goal with h:_ = ?A |- _ = ?A => rewrite <- h end.
      generalize_proofs.
      congruence.
    - rename Heqr0 into e.
      unfold transmit' in e.
      revert e.
      generalize_proofs.
      cbn.
      intro.
      destruct (transmit (snd (feasiblePath r ri re n)) p (available a0) p1); [|congruence].
      find_inversion.
      clear.
      cbn.
      unfold feasiblePath.
      destruct (r =? ri).
      + cbn.
        intuition.
        simpl_eq.
        cbn.
        reflexivity.
      + cbn.
        intuition.
        simpl_eq.
        cbn.
        reflexivity.
  Qed.

  Definition localPolicy
    (Q:forall r, incoming [internal & r] -> outgoing [internal & r] -> Prefix ->
                 @RoutingInformation trackingAttributes' ->
                 @RoutingInformation trackingAttributes' ->
                 @RoutingInformation trackingAttributes' -> bool)
    (r:Router) (i:incoming r) (o:outgoing r) (p:Prefix)
    (ai:@RoutingInformation trackingAttributes')
    (al:@RoutingInformation trackingAttributes')
    (ae:@RoutingInformation trackingAttributes') : bool.
  destruct r as [[] r].
  - exact (Q r i o p ai al ae).
  - exact true.
  Defined.

  Definition TrackingOk r p := {s : incoming [internal & r] & {a : @RoutingInformation trackingAttributes' | @forwardable _ _ plainAttributes _ [internal & r] s p a}}.

  Instance freeNeighbor `{SpaceSearch} : forall s d, Free (neighbor s d).
    intros.
    refine {| free := bind (free {d':router external & neighbor s d'}) _ |}. {
      intros [d' c].
      destruct (d' =? d).
      + subst_max.
        exact (single c).
      + exact empty.
    }
  Proof.
    intro c.
    apply bindOk.
    exists [d & c].
    constructor; [apply freeOk|].
    cbn.
    break_match; [|congruence].
    simpl_eq.
    cbn.
    apply singleOk.
    reflexivity.
  Defined.

  Instance freeTrackingOk : forall r p, Free (TrackingOk r p).
    intros r p.
    refine {| free:=_; freeOk:=_ |}. {
    refine (union _ _).
    - refine (bind (free (incoming [internal & r])) (fun s => _)).
      refine (single _).
      refine [s & exist _ notAvailable _].
      cbn; trivial.
    - refine (bind (free (@PathAttributes plainAttributes)) (fun a0 => _)).
      refine (bind (free (router internal)) (fun ri => _)).
      refine (bind (free (router external)) (fun re => _)).
      refine (bind (free (neighbor ri re)) (fun n => _)).
      refine (single _).
      refine (let sai := transmit' r ri re n p a0 in _).
      refine [fst sai & exist _ (snd sai) _].
      inline_all.
      apply (transmitIsForwardable r ri re n p a0).
    } {
      idtac.
      unfold TrackingOk.
      intros [s [a F]].
      rewrite <- unionOk.
      destruct a as [a|].
      - right.
        specialize (forwardableImpliesTransmit r s p a F); intro T.
        destruct T as [ri [re [n [? h]]]].
        rewrite <- bindOk; exists (original a).
        constructor; [apply freeOk|].
        rewrite <- bindOk; exists ri.
        constructor; [apply freeOk|].
        rewrite <- bindOk; exists re.
        constructor; [apply freeOk|].
        rewrite <- bindOk; exists n.
        constructor; [apply freeOk|].
        rewrite <- singleOk.
        subst_max.
        f_equal.
        generalize_proofs.
        f_equal; [|trivial].
        intro P.
        revert f F.
        rewrite <- P.
        intros.
        generalize_proofs.
        reflexivity.
      - left.
        rewrite <- bindOk; exists s.
        constructor; [apply freeOk|].
        rewrite <- singleOk.
        generalize_proofs.
        reflexivity.
    }
  Defined.

  Require Import Coq.Logic.Classical_Pred_Type.
  Require Import Coq.Logic.Classical_Prop.

  Lemma bindFreeOk {A B} `{S':SpaceSearch} `{@Free S' A} {f} {b:B} (a:A) : ~contains b (bind (free A) f) -> ~contains b (f a).
    clear.
    intros h.
    rewrite <- bindOk in h.
    apply not_ex_all_not with (n:=a) in h.
    apply not_and_or in h.
    destruct h as [h|]. {
      exfalso.
      apply h.
      apply freeOk.
    }
    intuition.
  Qed.

  Definition constrain (b:bool) := if b then single tt else empty.

  Variable Query : Type.
  Variable denoteQuery : Query -> forall r, incoming [internal & r] -> outgoing [internal & r] -> Prefix ->
                         @RoutingInformation trackingAttributes' ->
                         @RoutingInformation trackingAttributes' ->
                         @RoutingInformation trackingAttributes' -> bool.

  Definition fastPolicyDec' (Q:Query) :
    option {r:router internal & incoming [internal & r] * outgoing [internal & r] * Prefix *
                 @RoutingInformation trackingAttributes' *
                 @RoutingInformation trackingAttributes' *
                 @RoutingInformation trackingAttributes' *
                 @RoutingInformation trackingAttributes'} % type.
    apply search.
    refine (bind (free (router internal)) (fun r => _)).
    refine (bind (free (outgoing [internal & r])) (fun d => _)).
    refine (bind (free Prefix) (fun p => _)).
    refine (bind (free (TrackingOk r p)) _); intros [s  [ai  _]].
    refine (bind (free (TrackingOk r p)) _); intros [s' [ai' _]].
    refine (let al' := @import' _ trackingAttributes' _ [internal & r] _ s  p ai in _).
    refine (let al  := @import' _ trackingAttributes' _ [internal & r] _ s' p ai' in _).
    refine (let ao  := @export' _ trackingAttributes' _ [internal & r] _ s' d p al in _).
    refine (if (_:bool) then single _ else empty).
    exact (sumBoolAnd (localPref'(al') <=? localPref'(al)) (bool2sumbool (negb (denoteQuery Q r s d p ai al ao)))).
    exact [r & (s, d, p, ai, ai', al, ao)].
  Defined.

  Definition fastPolicyDec Q : decide (fastPolicy (localPolicy (denoteQuery Q))).
    unfold decide.
    destruct (fastPolicyDec' Q) as [res|] eqn:e.
    - right.
      unfold fastPolicyDec' in *.
      apply searchOk in e.
      apply bindOk in e; destruct e as [r [_ e]].
      apply bindOk in e; destruct e as [d [_ e]].
      apply bindOk in e; destruct e as [p [_ e]].
      unfold TrackingOk in e.
      apply bindOk in e; destruct e as [[s  [ai  T ]] [_ e]].
      apply bindOk in e; destruct e as [[s' [ai' T']] [_ e]].
      unfold constrain in *.
      break_if; revgoals. {
        apply emptyOk in e.
        intuition.
      }
      Set Printing All.
      idtac.
      unfold sumbool2bool in *.
      break_match; [|congruence].
      Unset Printing All.
      idtac.
      break_and.
      unfold fastPolicy, not.
      intro h.
      specialize (h [internal & r] s d p s' ai ai' T T').
      intuition.
      rewrite negb_true_iff in *.
      unfold localPolicy in *.
      clear Heqb.
      enough (true = false) by congruence;
      match goal with
      | F:_ = false, T:_ = true |- _ => rewrite <- F; rewrite <- T
      end.
      reflexivity.
    - left.
      unfold fastPolicy.
      intros r s d p s' ai ai' F F' L.
      unfold fastPolicyDec' in *.
      destruct r as [[] r].
      + (* r is internal  *)
        cbn.
        eapply searchOk' in e.

        assert (forall {A B} `{S:SpaceSearch} `{@Free S A} {f} {b:B} (a:A), ~contains b (bind (free A) f) -> ~contains b (f a)) as bindFreeOk. {
          clear.
          intros A B ? ? f b a h.
          rewrite <- bindOk in h.
          apply not_ex_all_not with (n:=a) in h.
          Require Import Coq.Logic.Classical_Prop.
          apply not_and_or in h.
          destruct h as [h|]. {
            exfalso.
            apply h.
            apply freeOk.
          }
          intuition.
        }
        apply bindFreeOk  with (a:=r) in e.
        apply bindFreeOk with (a:=d) in e.
        apply bindFreeOk with (a:=p) in e.
        unfold TrackingOk in *.
        apply bindFreeOk with (a:=[s  & exist _ ai  F ]) in e.
        apply bindFreeOk with (a:=[s' & exist _ ai' F']) in e.
        unfold constrain in *.
        break_if. {
          exfalso.
          apply e.
          assert (forall {A} {a:A}, contains a (single a)) as singleOk'. {
            clear.
            intros.
            apply singleOk.
            reflexivity.
          }
          apply singleOk'.
        }
        Set Printing All.
        idtac.
        unfold sumbool2bool in *.
        break_match; [congruence|].
        Unset Printing All.
        idtac.
        apply not_and_or in n.
        destruct n; [intuition;fail|].
        rewrite negb_true_iff in *.
        rewrite not_false_iff_true in *.
        intuition.
      + (* policy always holds for external neighbors*)
        clear.
        cbn.
        reflexivity.
  Defined.

  Definition policySemiDec Q : option (policy (localPolicy (denoteQuery Q))).
    refine(if fastPolicyDec Q then Some _ else None).
    apply fastPolicyImpliesPolicy; trivial.
  Defined.

  Inductive Routing (r:router internal) :=
  | onlyNotAvailable : incoming [internal & r] -> Routing r
  | allAvailable (ri:router internal) (re:router external) : neighbor ri re -> Routing r.

  Arguments onlyNotAvailable [_] _.
  Arguments allAvailable [_] _ _ _.

  Definition routingToTracking r p (R:Routing r) : Space (TrackingOk r p).
    refine (match R with
    | onlyNotAvailable s => _
    | allAvailable ri re n => _
    end).
    - refine (single _).
      refine [s & exist _ notAvailable _].
      cbn; trivial.
    - refine (bind (free (@PathAttributes plainAttributes)) (fun a0 => _)).
      refine (single _).
      refine (let sai := transmit' r ri re n p a0 in _).
      refine [fst sai & exist _ (snd sai) _].
      inline_all.
      apply (transmitIsForwardable r ri re n p a0).
  Defined.

  Definition bgpvCore (Q:Query) (v:{r:router internal & (outgoing [internal & r] * Routing r * Routing r) % type}) :
    option {r:router internal & (incoming [internal & r] * outgoing [internal & r] * Prefix *
                     @RoutingInformation trackingAttributes' *
                     @RoutingInformation trackingAttributes' *
                     @RoutingInformation trackingAttributes' *
                     @RoutingInformation trackingAttributes') % type}.
    destruct v as [r [[d R] R']].
    apply search.
    refine (bind (free Prefix) (fun p => _)).
    refine (bind (routingToTracking r p R ) _); intros [s  [ai  _]].
    refine (bind (routingToTracking r p R') _); intros [s' [ai' _]].
    refine (let al' := @import' _ trackingAttributes' _ [internal & r] _ s  p ai in _).
    refine (let al  := @import' _ trackingAttributes' _ [internal & r] _ s' p ai' in _).
    refine (let ao  := @export' _ trackingAttributes' _ [internal & r] _ s' d p al in _).
    refine (if (_:bool) then single _ else empty).
    exact (sumBoolAnd (localPref'(al') <=? localPref'(al)) (bool2sumbool (negb (denoteQuery Q r s d p ai al ao)))).
    refine [r & (s, d, p, ai, ai', al, ao)].
  Defined.

  Definition optionToSpace `{SpaceSearch} {A} (o:option A) : Space A :=
    match o with None => empty | Some a => single a end.

  Context {S':SpaceSearch}.

  Variable bgpvScheduler : forall Q v, {o | o = search (bind v (compose optionToSpace (bgpvCore Q)))}.

  (*
  Variable parallelSearch : forall A B, (A -> option B) * Space A -> option B.
  Arguments parallelSearch [_ _] _.
  Variable parallelSearchOk : forall A B (f:A -> option B) S, parallelSearch (f,S) = search (bind S (compose optionToSpace f)).
  *)

  Instance freeRouting `{SpaceSearch} r : Free (Routing r).
    refine {|free := _ |}.
    refine (union _ _). {
      refine (bind (free (incoming [internal & r])) (fun s => _)).
      refine (single (onlyNotAvailable s)).
    } {
      refine (bind (free (router internal)) (fun ri => _)).
      refine (bind (free (router external)) (fun re => _)).
      refine (bind (free (neighbor ri re)) (fun n => _)).
      refine (single (allAvailable ri re n)).
    }
  Proof.
    intros R.
    rewrite <- unionOk.
    destruct R as [s|ri re n].
    - left.
      rewrite <- bindOk; exists s.
      constructor; [apply freeOk|].
      rewrite <- singleOk.
      reflexivity.
    - right.
      rewrite <- bindOk; exists ri.
      constructor; [apply freeOk|].
      rewrite <- bindOk; exists re.
      constructor; [apply freeOk|].
      rewrite <- bindOk; exists n.
      constructor; [apply freeOk|].
      rewrite <- singleOk.
      reflexivity.
  Defined.

  Instance freeSigT {A B} `{Free A} `{forall a:A, Free (B a)} : Free {a : A & B a}.
    refine {|
      free := bind (free A) (fun a =>
              bind (free (B a)) (fun b =>
              single [a & b]))
    |}.
  Proof.
    intros [a b].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    apply singleOk.
    reflexivity.
  Defined.

  Instance freeProd {A B} `{S:SpaceSearch} `{@Free S A} `{@Free S B} : @Free S (A * B).
    refine {|
      free := bind (free A) (fun a =>
              bind (free B) (fun b =>
              single (a, b)))
    |}.
  Proof.
    intros [a b].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    apply singleOk.
    reflexivity.
  Defined.

  Definition parallelBGPV (Q:Query) := let ' exist _ v _ := bgpvScheduler Q (free _) in v.

  Definition pickOne `{SpaceSearch} {A} : Space A -> Space A := compose optionToSpace search.

  Definition parallelBGPVImport (Q:Query) : option {r : router internal & (incoming [internal & r] * outgoing [internal & r] * Prefix * RoutingInformation * RoutingInformation * RoutingInformation * RoutingInformation)%type}.
    refine (let ' exist _ v _ := bgpvScheduler Q _ in v).
    refine (bind (free (router internal)) (fun r => _)).
    refine (bind (pickOne (free (outgoing [internal & r]))) (fun o => _)).
    refine (bind (free (Routing r)) (fun R => _)).
    refine (single [r & (o,R,R)]).
  Defined.

  Definition forwardableToRouting {r} {s} {p} {ai:@RoutingInformation trackingAttributes'} (F:@forwardable _ _ plainAttributes _ [internal & r] s p ai) : Routing r.
    destruct ai as [ai|].
    + destruct (forwardableImpliesTransmit r s p ai F) as [ri [re [n _]]].
      exact (allAvailable ri re n).
    + exact (onlyNotAvailable s).
  Defined.

  Lemma routingToTrackingComposedWithForwardableToRouting {B r s p ai f F} {b:B}:
    ~contains b (bind (routingToTracking r p (forwardableToRouting F)) f) -> ~contains b (f [s & exist _ ai F]).
  Proof.
    clear.
    intro e.
    unfold TrackingOk in *.
    Lemma bindOk' : forall {A B} `{SpaceSearch} {S} {f} {b:B} (a:A), ~contains b (bind S f) -> ~contains a S \/ ~contains b (f a).
        clear.
        intros A B ? S f b a h.
        rewrite <- bindOk in h.
        apply not_ex_all_not with (n:=a) in h.
        Require Import Coq.Logic.Classical_Prop.
        apply not_and_or in h.
        destruct h; intuition.
    Qed.
    refine (let e' := bindOk' _ e in _). {
      exact [s & exist _ ai F].
    }
    refine ((fun e'' => _) e'); clear e e'; rename e'' into e.
    destruct e; [|intuition;fail].
    exfalso.
    apply H1; clear H1.
    unfold forwardableToRouting.
    Require Import SymbolicExecution.
    branch; cbn.
    - branch.
      branch.
      branch.
      subst_max.
      clear Heqs0.
      rename x into ri.
      rename x0 into re.
      rename x1 into n.
      rename p0 into ai.
      idtac.
      unfold routingToTracking.
      apply bindOk.
      exists (original ai).
      constructor; [apply freeOk; fail|].
      apply singleOk.
      destruct a as [e e'].
      subst_max.
      f_equal.
      assert (forall {A} {P : A -> Prop} {a a':A} {p:P a} {p':P a'}, a = a' -> exist _ a p = exist _ a' p') as e. {
        intros.
        subst_max.
        f_equal.
        proof_irrelevance.
        reflexivity.
      }
      apply e.
      intuition.
    - apply singleOk.
      f_equal.
      f_equal.
      cbn in *.
      destruct F.
      reflexivity.
  Qed.

  Definition parallelBGPVDec Q : decide (fastPolicy (localPolicy (denoteQuery Q))).
    unfold decide.
    destruct (parallelBGPV Q) as [res|] eqn:e.
    - right.
      unfold parallelBGPV in *.
      break_match.
      subst_max.
      clear Heqs.
      apply searchOk in e.
      apply bindOk in e; destruct e as [[r [[d R] R']] [_ e]].
      unfold compose in e.
      unfold optionToSpace in e.
      branch; revgoals. {
        apply emptyOk in e.
        destruct e.
      }
      apply singleOk in e.
      subst_max.
      rename Heqo into e.
      unfold bgpvCore in e.
      apply searchOk in e.
      apply bindOk in e; destruct e as [p [_ e]].
      unfold TrackingOk in e.
      apply bindOk in e; destruct e as [[s  [ai  F ]] [? e]].
      apply bindOk in e; destruct e as [[s' [ai' F']] [? e]].
      branch; revgoals. {
        apply emptyOk in e.
        destruct e.
      }
      unfold sumbool2bool in *.
      break_match; [|congruence].
      break_and.
      unfold fastPolicy, not.
      intro h.
      specialize (h [internal & r] s d p s' ai ai' F F').
      intuition.
      rewrite negb_true_iff in *.
      unfold localPolicy in *.
      clear Heqb.
      enough (true = false) by congruence;
      match goal with
      | F:_ = false, T:_ = true |- _ => rewrite <- F; rewrite <- T
      end.
      reflexivity.
    - left.
      unfold parallelBGPV in *.
      unfold fastPolicy.
      intros r s d p s' ai ai' F F' L.
      destruct r as [[] r].
      + (* r is internal  *)
        cbn.
        break_match.
        subst_max.
        clear Heqs0.
        (* COPIED FROM fastPolicyDec *)
        assert (forall {A B} `{S:SpaceSearch} `{@Free S A} {f} {b:B} (a:A), ~contains b (bind (free A) f) -> ~contains b (f a)) as bindFreeOk. {
          clear.
          intros A B ? ? f b a h.
          rewrite <- bindOk in h.
          apply not_ex_all_not with (n:=a) in h.
          Require Import Coq.Logic.Classical_Prop.
          apply not_and_or in h.
          destruct h as [h|]. {
            exfalso.
            apply h.
            apply freeOk.
          }
          intuition.
        }
        assert (forall {A B} `{SpaceSearch} `{Free A} {f:A->Space B} {a:A}, search (bind (free A) f) = None -> forall b, ~contains b (f a)) as searchOk''. {
          clear -bindFreeOk.
          intros.
          rename H into e.
          eapply searchOk' in e.
          eapply bindFreeOk with (a:=a) in e.
          apply e.
        }
        refine (let e' := searchOk'' _ _ _ _ _ _ _ e in _). {
          refine [r & (d, forwardableToRouting F, forwardableToRouting F')].
        }
        refine ((fun e'' => _) e').
        clear e' e; rename e'' into e.
        unfold compose in e.
        unfold optionToSpace in e.
        break_match. {
          exfalso.
          specialize (e s0).
          apply e.
          apply singleOk.
          reflexivity.
        }
        clear e.
        rename Heqo into e.
        clear searchOk''.
        unfold bgpvCore in e.
        refine (let al  := @import' _ trackingAttributes' _ [internal & r] _ s' p ai' in _).
        refine (let ao  := @export' _ trackingAttributes' _ [internal & r] _ s' d p al in _).
        apply (searchOk' (a :=[r & (s, d, p, ai, ai', al, ao)])) in e.
        apply bindFreeOk with (a:=p) in e.
        unfold TrackingOk in *.
        apply routingToTrackingComposedWithForwardableToRouting in e.
        apply routingToTrackingComposedWithForwardableToRouting in e.
        cbn in e.
        break_match. {
          exfalso.
          apply e; clear e.
          apply singleOk.
          reflexivity.
        }
        clear e.
        rename Heqb into e.
        unfold sumbool2bool in *.
        break_match; [congruence|].
        apply not_and_or in n.
        destruct n; [intuition;fail|].
        rewrite negb_true_iff in *.
        rewrite not_false_iff_true in *.
        intuition; fail.
      + (* policy always holds for external neighbors*)
        clear.
        cbn.
        reflexivity.
  Qed.

  Definition parallelPolicySemiDec Q : option (policy (localPolicy (denoteQuery Q))).
    refine(if parallelBGPVDec Q then Some _ else None).
    apply fastPolicyImpliesPolicy; trivial.
  Defined.
End BGPV.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall H K O L Hprime Kprime Oprime Lprime Kprimeprime Lprimeprime I Iprime : Universe, ((wd_ Oprime Kprimeprime /\ (wd_ Oprime Kprime /\ (wd_ Oprime Lprimeprime /\ (wd_ Oprime Lprime /\ (wd_ O H /\ (wd_ K I /\ (wd_ I L /\ (wd_ K L /\ (wd_ O I /\ (wd_ Oprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ Kprimeprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ Kprimeprime Lprimeprime /\ (wd_ K O /\ (col_ Oprime Kprime Kprimeprime /\ (col_ Oprime Lprime Lprimeprime /\ (col_ K I L /\ (col_ Oprime Iprime Hprime /\ (col_ O I H /\ (col_ Kprimeprime Iprime Lprimeprime /\ col_ K O I))))))))))))))))))))) -> col_ K O L)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   C. Auger, P. Courtieu, L. Rieg, X. Urbain , R. Pelle                 *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Reals Lia Arith.Div2 Psatz SetoidDec.
Require Export Pactole.Setting.
Require Export Pactole.Spaces.Ring.
Require Export Pactole.Spaces.Isomorphism.
Require Export Pactole.Observations.MultisetObservation.

Close Scope Z_scope.
Set Implicit Arguments.
Typeclasses eauto := (bfs).

Section ExplorationDefs.

(** Setting definitions *)

(** Definition of the ring. *)
Context {RR : RingSpec}.
(* We do not care about threshold values, so we just take 1/2 everywhere. *)
Existing Instance localRing.
Notation ring_node := (finite_node ring_size).
(* NB: These instances will be replaced by the glob_* ones so they are local. *)

(* begin show *)
(** Number of good and Byzantine robots *)
Context {Robots : Names}.

(** Robots are on nodes *)
Global Instance Loc : Location := make_Location ring_node.

(** States of robots only contains their location. *)
Global Instance St : State location := OnlyLocation (fun _ => True).
Global Existing Instance proj_graph.

(** Robots observe the location of others robots with strong multiplicity. *)
Global Existing Instance multiset_observation.

(** Robots only decide in which direction they want to move. *)
Global Instance RC : robot_choice direction := { robot_choice_Setoid := direction_Setoid }.

(** Demon's frame choice: we move back the robot to the origin with a translation
                          and we can choose the orientation of the ring. *)
Global Instance FC : frame_choice (Z * bool) := {
  frame_choice_bijection :=
    fun nb => if snd nb then Ring.sym (fst nb) else Ring.trans (fst nb);
  frame_choice_Setoid := eq_setoid _ }.

Global Existing Instance NoChoice.
Global Existing Instance NoChoiceIna.
Global Existing Instance NoChoiceInaFun.

Global Instance UpdFun : update_function direction (Z * bool) unit := {
  update := fun config g _ dir _ => move_along (config (Good g)) dir;
  update_compat := ltac:(repeat intro; subst; now apply move_along_compat) }.
(* end show *)

(* Global Instance setting : GlobalDefinitions := {
  (* Number of good and Byzantine robots *)
  glob_Names := Robots;
  (* The space in which robots evolve *)
  glob_Loc := Loc;
  (* The state of robots (must contain at least the current location) *)
  glob_info := location;
  glob_State := OnlyLocation (fun _ => True);
  (* The observation: what robots can see from their surroundings *)
  glob_obs := multiset_observation;
  (* The output type of robograms: some information that we can use to get a target location *)
  glob_Trobot := direction;
  glob_robot_choice := RC;
  (* The frame decision made by the demon, used to build the frame change *)
  glob_Tframe := Z * bool;
  glob_frame_choice := FC;
  (* The influence of the demon on the state update of robots, when active *)
  glob_Tactive := unit;
  glob_update_choice := NoChoice;
  (* The influence of the demon on the state update of robots, when inactive *)
  glob_Tinactive := unit;
  glob_inactive_choice := NoChoiceIna;
  (* How a robots state is updated:
     - if active, using the result of the robogram and the decision from the demon
     - if inactive, using only the decision from the demon *)
  glob_update_function := UpdFun;
  glob_inactive_function := NoChoiceInaFun }. *)

(** ** Specification of exploration with stop *)

(** Any node will eventually be visited. *)
Definition is_visited (pt : location) (config : configuration) :=
  exists g, config (Good g) == pt.

Definition Will_be_visited (pt : location) (e : execution) : Prop :=
  Stream.eventually (Stream.instant (is_visited pt)) e.

(** Eventually, all robots stop moving. *)
Definition Stall (e : execution) := Stream.hd e == (Stream.hd (Stream.tl e)).

Definition Stopped (e : execution) : Prop :=
  Stream.forever Stall e.

Definition Will_stop (e : execution) : Prop :=
  Stream.eventually Stopped e.

(** [Exploration_with_stop r d config] means that executing [r] against demon [d] from
    configuration [config] indeed solves exploration with stop: after a finite time, every
    node of the space has been visited and all robots will stay at the same place forever. *)
Definition ExplorationWithStop (r : robogram) (d : demon) (config : configuration) :=
  (forall l, Will_be_visited l (execute r d config))
  /\ Will_stop (execute r d config).

(** [FullSolExplorationWithStop r d] means that the robogram [r] solves exploration with stop
    agains demon [d] regardless of the starting configuration.

    This is actually impossible when the number of robots is less than the size of the ring. *)
Definition FullSolExplorationWithStop (r : robogram) (d : demon) :=
  forall config, ExplorationWithStop r d config.

(** Acceptable starting configurations contain no tower,
    that is, all robots are at different locations. *)
Definition Valid_starting_config config : Prop :=
  Util.Preliminary.injective (@Logic.eq ident) (@equiv _ state_Setoid) config.
(*   forall pt : location, ((obs_from_config config (of_Z 0))[pt] <= 1)%nat. *)

Definition Explore_and_Stop (r : robogram) :=
  forall d config, Fair d -> Valid_starting_config config ->
  ExplorationWithStop r d config.

(** Compatibility properties *)
Global Instance is_visited_compat : Proper (equiv ==> equiv ==> iff) is_visited.
Proof using .
intros pt1 pt2 Hpt config1 config2 Hconfig.
split; intros [g Hv]; exists g.
- now rewrite <- Hconfig, Hv, Hpt.
- now rewrite Hconfig, Hv, Hpt.
Qed.

Global Instance Will_be_visited_compat : Proper (equiv ==> equiv ==> iff) Will_be_visited.
Proof using .
intros ? ? ?. now apply Stream.eventually_compat, Stream.instant_compat, is_visited_compat.
Qed.

Global Instance Stall_compat : Proper (equiv ==> iff) Stall.
Proof using .
intros e1 e2 He. split; intros Hs; unfold Stall in *;
(now rewrite <- He) || now rewrite He.
Qed.

Global Instance Stopped_compat : Proper (equiv ==> iff) Stopped.
Proof using .
intros e1 e2 He. split; revert e1 e2 He; coinduction rec.
- destruct H. now rewrite <- He.
- destruct H as [_ H], He as [_ He]. apply (rec _ _ He H).
- destruct H. now rewrite He.
- destruct H as [_ H], He as [_ He]. apply (rec _ _ He H).
Qed.

Global Instance Will_stop_compat : Proper (equiv ==> iff) Will_stop.
Proof using . apply Stream.eventually_compat, Stopped_compat. Qed.

Global Instance Valid_starting_config_compat : Proper (equiv ==> iff) Valid_starting_config.
Proof using .
intros ? ? Hconfig.
unfold Valid_starting_config, Util.Preliminary.injective.
now setoid_rewrite Hconfig.
Qed.

(** We can decide if a given configuration is a valid starting one. *)
Lemma Valid_starting_config_dec : forall config,
  {Valid_starting_config config} + {~ Valid_starting_config config}.
Proof using . intro config. unfold Valid_starting_config. apply config_injective_dec. Qed.

End ExplorationDefs.


Require Import Reals Psatz.
From iris.algebra Require Export ofe.
From iris.program_logic Require Export language.
From discprob.basic Require Import base sval order monad bigop_ext nify.
  From discprob.idxval Require Import idist_pidist_pair pival_dist ival pival ival_dist pival_dist ival_pair pidist_singleton irrel_equiv idist_pidist_pair.
From discprob.monad Require Import monad.
From mathcomp Require Import ssreflect bigop seq choice fintype finset ssrbool eqtype.
Set Default Proof Using "Type".
From discprob.prob Require Import prob countable.

Section prob_language_mixin.
  Context {expr val state : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  Context (prim_step : expr → state → expr → state → list expr → Prop).
  Context (prim_step_prob : expr → state → expr → state → list expr → R).

  Record ProbLanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None;
    mixin_prim_step_count e σ:
      Countable.class_of { esf: expr * state * list expr |
                           prim_step e σ (esf.1.1) (esf.1.2) (esf.2) };
    mixin_prim_step_sum1 e σ:
        (∃ e' σ' efs, prim_step e σ e' σ' efs) →
        is_series (countable_sum (λ t : Countable.Pack (mixin_prim_step_count e σ)
                                        { esf: expr * state * list expr |
                                          prim_step e σ (esf.1.1) (esf.1.2) (esf.2) },
                                    prim_step_prob e σ
                                                   (fst (fst (sval t)))
                                                   (snd (fst (sval t)))
                                                   (snd (sval t)))) 1;
    mixin_prim_step_nonneg : ∀ e1 σ1 e2 σ2 efs, (prim_step_prob e1 σ1 e2 σ2 efs >= 0)%R;
    mixin_prim_step_strict_gt :
    ∀ e1 σ1 e2 σ2 efs, prim_step e1 σ1 e2 σ2 efs ↔ (prim_step_prob e1 σ1 e2 σ2 efs > 0)%R
  }.
End prob_language_mixin.

Structure probLanguage := ProbLanguage  {
  expr : Type;
  val : Type;
  state : Type;

  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → expr → state → list expr → Prop;

  prim_step_prob : expr → state → expr → state → list expr → R;

  prob_language_mixin :
    ProbLanguageMixin of_val to_val prim_step prim_step_prob;
}.

Arguments ProbLanguage {_ _ _ _ _ _ _} _.
Arguments of_val {_} _%V.
Arguments to_val {_} _%E.
Arguments prim_step {_} _ _ _ _ _.
Arguments prim_step_prob {_} _ _ _ _ _.

Section prob_language.
  Context {Λ : probLanguage}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.
  Implicit Types σ : state Λ.

  Definition prob_lang_mixin : LanguageMixin (@of_val Λ) to_val prim_step.
  Proof.
    split.
    - apply prob_language_mixin.
    - apply prob_language_mixin.
    - apply prob_language_mixin.
  Qed.

  Canonical Structure prob_lang : language := Language prob_lang_mixin.

  Class ProbLanguageCtx (K : expr Λ → expr Λ) := {
    pfill_LanguageCtx : LanguageCtx K;
    pfill_prob e1 σ1 e2 σ2 efs :
      to_val e1 = None →
      prim_step_prob e1 σ1 e2 σ2 efs =
      prim_step_prob (K e1) σ1 (K e2) σ2 efs
  }.

  Inductive prim_step_result :=
  | prim_res_step : expr Λ → state Λ → list (expr Λ) → prim_step_result
  | prim_res_irred.

  Definition ival_prim_step e1 σ1 : ival (prim_step_result).
    destruct (ClassicalEpsilon.excluded_middle_informative (reducible e1 σ1)); last first.
    - unshelve (eexists).
      * apply [countType of unit].
      * intros; apply 1%R.
      * intros. apply (prim_res_irred).
      * intros [] => //=; auto with *.
    - set (ty := Countable.Pack (mixin_prim_step_count _ _ _ _ (prob_language_mixin Λ) e1 σ1)
                                { esf: expr Λ * state Λ * list (expr Λ) |
                                  prim_step e1 σ1 (esf.1.1) (esf.1.2) (esf.2) }).
        unshelve (eexists).
      * apply ty.
      * intros [esf Hpf].
        exact (prim_step_prob e1 σ1 (esf.1.1) (esf.1.2) (esf.2)).
      * intros [esf Hpf].
        exact (prim_res_step (esf.1.1) (esf.1.2) (esf.2)).
      * abstract (intros [[[e2 σ2] efs] Hpf];
          apply (mixin_prim_step_nonneg _ _ _ _ (prob_language_mixin Λ))).
  Defined.

  Lemma ivdist_prim_step_sum1 e1 σ1:
    is_series (countable_sum (ival.val (ival_prim_step e1 σ1))) 1%R.
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|]; last first.
    - rewrite //=.
      apply Series_correct'; last first.
      { eexists. apply finite.SeriesF_is_seriesC. }
      rewrite finite.SeriesC_SeriesF finite.SeriesF_big_op.
      { rewrite /index_enum [@Finite.enum]unlock //= big_cons big_nil //=. nra. }
    - rewrite //=.
      eapply is_seriesC_ext;
        last eapply (mixin_prim_step_sum1 _ _ _ _ (prob_language_mixin Λ) e1 σ1).
      * intros [[[e2 σ2] efs] Hpf] => //=.
      * eauto.
  Qed.

  Definition ivdist_prim_step e1 σ1 : ivdist (prim_step_result) :=
    {| ivd_ival := ival_prim_step e1 σ1; val_sum1 := ivdist_prim_step_sum1 e1 σ1 |}.

  Lemma ival_stuck_irred_nonval e σ :
    In_isupport prim_res_irred (ival_prim_step e σ) →
    irreducible e σ.
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - rewrite /irreducible. intros. apply not_reducible; eauto.
    - intros (x&Hind&?). rewrite //= in Hind.
      destruct x. congruence.
  Qed.

  Lemma ival_red_non_stuck' e σ:
    reducible e σ →
    ¬ (∃ i, ind (ival_prim_step e σ) i = prim_res_irred).
  Proof.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=.
    intros (e2&σ2&efs&Hstep) ([]&?); congruence.
  Qed.

  Lemma ival_red_non_stuck e σ:
    reducible e σ →
    ¬ (In_isupport prim_res_irred (ival_prim_step e σ)).
  Proof.
    intros ? (i&?&?); eapply ival_red_non_stuck'; eauto.
  Qed.

  Lemma ival_non_stuck_red e σ e' σ' efs:
    (reducible e σ ∨ to_val e = None) →
    (In_isupport (prim_res_step e' σ' efs) (ival_prim_step e σ)) →
    prim_step e σ e' σ' efs.
  Proof.
    intros Hred.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - rewrite //=. intros ([]&Hind&?). rewrite //= in Hind.
    - rewrite //=. intros (m&Hind&?). rewrite //= in Hind.
      destruct m. inversion Hind; subst; eauto.
  Qed.

  Lemma ivdist_non_stuck_red e σ e' σ' efs:
    (In_isupport (prim_res_step e' σ' efs) (ival_prim_step e σ)) →
    (prim_step e σ e' σ' efs).
  Proof.
    specialize (ival_non_stuck_red e σ e' σ' efs).
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => Hpre //=; last first.
    - intros (x&Hind&?). rewrite //= in Hind.
    - rewrite //=. intros. eapply Hpre; eauto.
  Qed.

  Lemma ivdist_step_idx' e1 σ1 e2 σ2 efs:
    prim_step e1 σ1 e2 σ2 efs →
    ∃ i, ind (ivdist_prim_step e1 σ1) i = prim_res_step e2 σ2 efs
         ∧ (ival.val (ivdist_prim_step e1 σ1) i = prim_step_prob e1 σ1 e2 σ2 efs)%R.
  Proof.
    intros Hstep.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    * exfalso. eapply Hnr. do 3 eexists; eauto.
    * unshelve (eexists).
      { exists (e2, σ2, efs) => //=. }
      rewrite //=.
  Qed.

  Lemma ivdist_step_idx e1 σ1 e2 σ2 efs:
    prim_step e1 σ1 e2 σ2 efs →
    ∃ i, ind (ivdist_prim_step e1 σ1) i = prim_res_step e2 σ2 efs
         ∧ (ival.val (ivdist_prim_step e1 σ1) i > 0)%R.
  Proof.
    intros Hstep.
    edestruct ivdist_step_idx' as (i&?&Heq); eauto; exists i; split; auto.
    rewrite Heq. by apply (prob_language_mixin).
  Qed.

  Lemma irred_non_val_stuck_ivdist e1 σ1:
    irreducible e1 σ1 →
    In_isupport prim_res_irred (ivdist_prim_step e1 σ1).
  Proof.
    intros Hirred.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    - exists (); split => //=. nra.
    - exfalso. destruct Hr as (?&?&?&?). eapply Hirred; eauto.
  Qed.

  Definition pidist_prim_step e1 σ1 : pidist (prim_step_result).
    unshelve (eexists).
    - unshelve (eexists).
      * exact (λ x, (ival_prim_step e1 σ1) = x).
      * eexists; eauto.
    - abstract (intros ? <-; apply ivdist_prim_step_sum1).
  Defined.

  Inductive step_result :=
  | res_step : list (expr Λ) → state Λ → step_result
  | res_stuck.

  Fixpoint tpool_step (tl tp: list (expr Λ)) (σ: state Λ) : pidist step_result :=
    match tp with
    | [::] => mret res_stuck
    | e :: tp' =>
      pidist_union
        (r ← pidist_prim_step e σ;
           match r with
           | prim_res_step e' σ' efs => mret (res_step (tl ++ e' :: tp' ++ efs) σ')
           | prim_res_irred => mret res_stuck
           end)
        ((tpool_step (tl ++ [::e]) tp' σ))
    end.

  Fixpoint tpool_stepN (n: nat) (tp: list (expr Λ)) (σ: state Λ): pidist (step_result) :=
    match n with
    | O => mret (res_step tp σ)
    | S n' =>
      r ← (tpool_step [::] tp σ);
        match r with
        | res_stuck => mret (res_stuck)
        | res_step tp' σ' =>
          tpool_stepN n' tp' σ'
        end
    end.

  Definition trace := list (cfg prob_lang).

  Definition scheduler := trace → nat.

  Inductive trace_step (sch: scheduler) (tr1 tr2 : trace) : Prop :=
    | trace_active_step i ρ1 ρ2 tr0:
          sch tr1 = i →
          tr1 = tr0 ++ [::ρ1] →
          tr2 = tr0 ++ (ρ1 :: ρ2 :: nil) →
          istep i ρ1 ρ2 →
          trace_step sch tr1 tr2
    | trace_stutter_step i ρ1 tr0:
        sch tr1 = i →
        (¬ ∃ ρ2, istep i ρ1 ρ2) →
        tr1 = tr0  ++ [::ρ1] →
        tr2 = tr0  ++ [ρ1; ρ1] →
        trace_step sch tr1 tr2.

  Definition ivdist_tpool_stepi i (tp: list (expr Λ)) (σ: state Λ) : ivdist (step_result) :=
    match (tp !! i) with
    | None => mret res_stuck
    | Some e =>
      r ← ivdist_prim_step e σ;
        match r with
        | prim_res_step e' σ' efs =>
          mret (res_step (list.take i tp ++ (e' :: list.drop (S i) tp) ++ efs) σ')
        | prim_res_irred => mret res_stuck
        end
    end.

  Definition ivdist_trace_step (s: scheduler) (tr: trace) (tp: list (expr Λ)) (σ: state Λ)
    : ivdist (list (expr Λ) * state Λ) :=
      r ← (ivdist_tpool_stepi (s (tr ++ [::(tp, σ)])) tp σ);
        match r with
        | res_step tp' σ' => mret (tp', σ')
        | res_stuck => mret (tp, σ)
        end.

  Fixpoint ivdist_trace_stepN_aux s tr tp σ n :=
    match n with
    | O => mret (tp, σ)
    | S n' =>
      r ← ivdist_trace_step s tr tp σ;
      ivdist_trace_stepN_aux s (tr ++ [::(tp, σ)])  (fst r) (snd r) n'
    end.

  Definition ivdist_tpool_stepN s tp σ n :=
    ivdist_trace_stepN_aux s [::] tp σ n.

  Definition terminates s tr n :=
    ∀ tr' cfg n', n ≤ n' → nsteps (trace_step s) n' tr (tr' ++ [::cfg]) →
               ∃ v tp, (fst cfg) = (of_val v :: tp).

  Lemma terminates_S s tr cfg cfg' i n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    istep i cfg cfg' →
    terminates s (tr ++ (cfg :: cfg' :: nil)) n.
  Proof.
    intros Hterm Hlookup Hi tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; [ econstructor |]; eauto.
  Qed.

  Lemma istep_idx_length i (cfg: language.cfg prob_lang) cfg':
    istep i cfg cfg' → (i < length (fst cfg))%nat.
  Proof.
    inversion 1; subst. rewrite app_length //=. omega.
  Qed.

  Lemma ivdist_prim_step_val_mret e σ:
    language.to_val e <> None →
    eq_ivd (ivdist_prim_step e σ) (mret (prim_res_irred)).
  Proof.
    intros Hval.
    rewrite /eq_ivd//=.
    rewrite /ival_prim_step.
    destruct ClassicalEpsilon.excluded_middle_informative as [r|?].
    { exfalso. destruct r as (?&?&?&?). eapply Hval. eapply language.val_stuck; eauto. }
    rewrite /language.to_val//= in Hval.
    destruct (to_val e); last congruence.
    rewrite //=.
    eapply eq_ival_quasi_refl.
  Qed.

  Lemma terminates_stutter_None s tr cfg i n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    (fst cfg !! i = None) →
    terminates s (tr ++ (cfg :: cfg :: nil)) n.
  Proof.
    intros Hterm Hsch Hi tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; last eauto.
    eapply trace_stutter_step; eauto.
    intros (cfg'&Hstep).
    assert (length (fst cfg) <= i)%nat.
    { eapply lookup_ge_None_1; eauto. }
    feed pose proof (istep_idx_length i cfg cfg'); eauto.
    omega.
  Qed.

  Lemma terminates_stutter_value s tr cfg i ei n :
    terminates s (tr ++ [::cfg]) (S n) →
    s (tr ++ [::cfg]) = i →
    (fst cfg !! i = Some ei) →
    (to_val ei <> None) →
    terminates s (tr ++ (cfg :: cfg :: nil)) n.
  Proof.
    intros Hterm Hsch Hi Hval tr' cfg'' n'' Hle Hsteps.
    eapply (Hterm _ _ (S n'')); first omega.
    econstructor; last eauto.
    eapply trace_stutter_step; eauto.
    intros (cfg'&Hstep).
    inversion Hstep.
    exfalso; eapply Hval. eapply language.val_stuck; eauto.
    subst.
    rewrite list_lookup_middle in Hi; eauto.
    inversion Hi; subst; eauto.
  Qed.

  Lemma terminates_mono s tr n n' :
    n ≤ n' →
    terminates s tr n →
    terminates s tr n'.
  Proof.
    intros Hle Hterm.
    intros tr' cfg n'' Hle'' Hnsteps.
    eapply (Hterm _ _ n''); eauto.
    omega.
  Qed.

  Definition terminating s tr := ∃ n, terminates s tr n.

  Lemma ivdist_prim_step_primitive e σ: ival_primitive (ivdist_prim_step e σ).
  Proof.
   rewrite //=/ival_prim_step.
   destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
   - rewrite /ival_primitive => //=. intros [] [] => //=.
   - rewrite /ival_primitive => //=.
     intros (((?&?)&?)&?) (((?&?)&?)&?) Heq.
     apply sval_inj_pi => //=.
     inversion Heq; eauto.
  Qed.

  Global Instance prob_lang_ctx_proj K `{ProbLanguageCtx K} : LanguageCtx K.
  Proof. apply pfill_LanguageCtx. Qed.

  Lemma ivdist_val_step e1 σ1 e2 σ2 efs i1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    ind (ivdist_prim_step e1 σ1) i1 = prim_res_step e2 σ2 efs →
    ival.val (ivdist_prim_step e1 σ1) i1 = prim_step_prob e1 σ1 e2 σ2 efs.
  Proof.
    intros Hred. revert i1.
    rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; [].
    rewrite //= => i Heq.
    destruct i as (((?&?)&?)&?).
    inversion Heq; subst; eauto.
  Qed.

  Lemma ivdist_stuck_val_1 e σ i:
    ind (ivdist_prim_step e σ) i = prim_res_irred →
    ival.val (ivdist_prim_step e σ) i = 1%R.
  Proof.
    move: i. rewrite /ivdist_prim_step/ival_prim_step//=.
    destruct ClassicalEpsilon.excluded_middle_informative as [Hr|Hnr] => //=; last first.
    intros (?&?). congruence.
  Qed.

  Lemma ivdist_bind_eq_post_fill K `{!ProbLanguageCtx K} e1 σ1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    eq_ivd (ivdist_prim_step (K e1) σ1)
                 (x ← (ivdist_prim_step e1 σ1);
                  mret (match x with
                        | prim_res_step e2 efs σ => prim_res_step (K e2) efs σ
                        | prim_res_irred => prim_res_irred
                        end)).
  Proof.
    intros Hred.
    symmetry. apply eq_ival_primitive_fmap_bij.
    - apply ivdist_prim_step_primitive.
    - apply ivdist_prim_step_primitive.
    - intros v Hin. destruct v.
      * eapply ival_non_stuck_red in Hin; eauto.
        edestruct ivdist_step_idx as (i&?&?); last first.
        { exists i; split; eauto. }
        by apply fill_step.
      * destruct Hred.
        ** exfalso.
           eapply ival_red_non_stuck; eauto.
        ** apply irred_non_val_stuck_ivdist.
           *** apply ival_stuck_irred_nonval in Hin.
               apply irreducible_fill; eauto.
    - intros v1 v1' ??.
      destruct v1, v1' => //=.
      inversion 1; f_equal. apply: (@fill_inj _ K); auto.
    - rewrite /ivdist_prim_step.
      intros v2 Hin.
      destruct v2 as [e σ2 efs |].
      ** efeed pose proof (ival_non_stuck_red); [| eauto |].
         { left. rewrite //= in Hin. apply ivdist_non_stuck_red in Hin.
           do 3 eexists; eauto.
         }
        rewrite //= in Hin.  edestruct (@fill_step_inv) as (e'&?&?); eauto; subst; try apply _.
           *** destruct Hred; auto. by eapply reducible_not_val; eauto.
           *** rewrite //=. exists (prim_res_step e' σ2 efs); split; eauto.
               edestruct ivdist_step_idx as (i&?&?); last first.
               { exists i; split; eauto. }
               eauto.
      ** destruct Hred as [Hred|Hnonval].
         *** exfalso. eapply ival_red_non_stuck; last by eauto.
             edestruct Hred as (e2&σ2&efs&Hstep).
             exists (K e2), σ2, efs.
             apply fill_step; eauto.
         *** exists prim_res_irred; split; auto.
             apply ival_stuck_irred_nonval in Hin as Hirred.
             apply irred_non_val_stuck_ivdist; auto.
             intros e2 σ2 efs Hstep. by apply (Hirred (K e2) σ2 efs), fill_step.
    - intros i1 i2.
      case_eq (ind (ivdist_prim_step e1 σ1) i1).
      * intros e2 σ2 efs Hind1 Hind2.
        erewrite ivdist_val_step; eauto; last first.
        { destruct Hred as [Hred|Hnonval].
          ** left. edestruct Hred as (?&?&?&?); do 3 eexists. by apply fill_step.
          ** right.  by apply fill_not_val.
        }
        erewrite ivdist_val_step; eauto.
        rewrite -pfill_prob //=.
        destruct Hred; auto. eapply reducible_not_val; eauto.
      * intros. destruct Hred.
        ** exfalso. eapply ival_red_non_stuck'; eauto.
        ** by rewrite ?ivdist_stuck_val_1.
  Qed.

  (* TODO: many of these proofs can be simplified, since reducible e1 σ1 implies
     e1 is not a value, so the left part of the disjunction is not necessary; however
     this disjunction was added on after the fact. *)
  Lemma ivdist_bind_coupling {X} K `{!ProbLanguageCtx K} e1 σ1 (I: pidist X) P:
    ∀ (Ic: irrel_couplingP (ivdist_prim_step e1 σ1) I P),
      (reducible e1 σ1 ∨ to_val e1 = None) →
      irrel_couplingP (ivdist_prim_step (K e1) σ1) I
                      (λ x y,
                       (match x with
                        | prim_res_step e2 σ efs =>
                          ∃ e2' pf, e2 = K e2' ∧ prim_step e1 σ1 e2' σ efs ∧
                                    ival.In_isupport (exist _ (prim_res_step e2' σ efs, y) pf) Ic
                       | prim_res_irred => ∃ pf,
                          ival.In_isupport (exist _ (prim_res_irred, y) pf) Ic
                        end)).
  Proof.
    intros.
      eapply irrel_coupling_proper.
      { symmetry. apply: ivdist_bind_eq_post_fill; eauto. }
      { apply pidist_right_id. }
      eapply irrel_coupling_bind.
      { apply (irrel_coupling_support _ _ _ Ic).  }
      intros x' y' HP.
      eapply irrel_coupling_mret.
      rewrite //= in HP.
      destruct HP as (Hpf&Hin1&Hin2&HIn3).
      destruct x' => //=.
      - do 2 eexists; repeat split; eauto.
        eapply ival_non_stuck_red; eauto.
      - eexists; eauto.
  Qed.

  Definition Kinv K `{LanguageCtx prob_lang K} : expr Λ → expr Λ.
    intros e. destruct (ClassicalEpsilon.excluded_middle_informative (∃ e', K e' = e)) as [Heq|Hneq].
    - apply ClassicalEpsilon.constructive_indefinite_description in Heq as (e'&?).
      exact e'.
    - exact e.
  Defined.

  Lemma Kinv_K K `{!LanguageCtx K} e:
    Kinv K (K e) = e.
  Proof.
    rewrite /Kinv.
    destruct ClassicalEpsilon.excluded_middle_informative as [?|Hfalse].
    - destruct ClassicalEpsilon.constructive_indefinite_description.
        by apply fill_inj.
    - exfalso. apply Hfalse. eauto.
  Qed.

  Lemma ivdist_bind_eq_post_fill_inv K `{!ProbLanguageCtx K} e1 σ1:
    (reducible e1 σ1 ∨ to_val e1 = None) →
    eq_ivd (ivdist_prim_step e1 σ1)
           (x ← (ivdist_prim_step (K e1) σ1);
              mret (match x with
                    | prim_res_step e2 efs σ => prim_res_step (Kinv K e2) efs σ
                    | prim_res_irred => prim_res_irred
                    end)).
  Proof.
    intros Hred.
    setoid_rewrite ivdist_bind_eq_post_fill; auto.
    rewrite /eq_ivd.
    setoid_rewrite ival.ival_bind_mret_mret.
    setoid_rewrite <-ival.ival_right_id at 1.
    eapply ival.ival_bind_congr; first by reflexivity.
    intros [|] => //=; rewrite ?Kinv_K; reflexivity.
  Qed.

  Lemma ivdist_bind_inv_coupling {X} K `{!ProbLanguageCtx K} e1 σ1 (I: pidist X) P:
    ∀ (Ic: irrel_couplingP (ivdist_prim_step (K e1) σ1) I P),
      (reducible e1 σ1 ∨ to_val e1 = None) →
      irrel_couplingP (ivdist_prim_step e1 σ1) I
                      (λ x y,
                       (match x with
                        | prim_res_step e2 σ efs =>
                         ∃ pf, prim_step (K e1) σ1 (K e2) σ efs ∧
                               ival.In_isupport (exist _ (prim_res_step (K e2) σ efs, y) pf) Ic
                       | prim_res_irred => ∃ pf,
                          ival.In_isupport (exist _ (prim_res_irred, y) pf) Ic
                        end)).
  Proof.
    intros Ic Hred.
      eapply irrel_coupling_proper.
      { symmetry. apply: ivdist_bind_eq_post_fill_inv; eauto. }
      { apply pidist_right_id. }
      eapply irrel_coupling_bind.
      { apply (irrel_coupling_support _ _ _ Ic).  }
      intros x' y' HP.
      eapply irrel_coupling_mret.
      rewrite //= in HP.
      destruct HP as (Hpf&Hin1&Hin2&HIn3).
      destruct x' as [e s l|] => //=.
    - assert (reducible (K e1) σ1 ∨ to_val (K e1) = None).
      { destruct Hred as [Hred|Hnonval].
        * left. edestruct Hred as (?&?&?&?). do 3 eexists.
          apply: fill_step; eauto.
        * right. by apply fill_not_val.
      }
        assert (prim_step (K e1) σ1 e s l) as Hstep1.
        { eapply ival_non_stuck_red; eauto. }

        assert (K (Kinv K e) = e) as Hrewrite.
        { eapply fill_step_inv in Hstep1 as (e0&?&?); last first.
          { destruct Hred; auto; eauto; (eapply reducible_not_val); eauto. }

          subst. rewrite Kinv_K. done.
        }

        rewrite Hrewrite.
        do 2 eexists; repeat split; eauto.
    - exists Hpf. auto.
  Qed.

End prob_language.

Arguments prob_lang : clear implicits.
Coercion prob_lang : probLanguage >-> language.

(* See the explanation in ectxLanguage *)

Definition LanguageOfProb (Λ : probLanguage) : language :=
  let '@ProbLanguage E V St of_val to_val prim_step prim_step_prob mix := Λ in
  @Language E V St of_val to_val _
    (@prob_lang_mixin (@ProbLanguage E V St of_val to_val prim_step prim_step_prob mix)).


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Clocks.
From Coq Require Import PArith.
From Coq Require Import Omega.
From Coq Require Import Sorting.Permutation.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

(** * The NLustre dataflow language *)

Module Type NLSYNTAX
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX Op).

  (** ** Equations *)

  Inductive equation : Type :=
  | EqDef : ident -> clock -> cexp -> equation
  | EqApp : list ident -> clock -> ident -> list exp -> option (ident * clock) -> equation
  | EqFby : ident -> clock -> const -> exp -> equation.

  Implicit Type eqn: equation.

  (** ** Node *)

  Definition var_defined (eq: equation) : list ident :=
    match eq with
    | EqDef x _ _ => [x]
    | EqApp x _ _ _ _ => x
    | EqFby x _ _ _ => [x]
    end.

  Definition vars_defined (eqs: list equation) : list ident :=
    flat_map var_defined eqs.

  Definition is_fby (eq: equation) : bool :=
    match eq with
    | EqFby _ _ _ _ => true
    | _ => false
    end.

  Definition is_app (eq: equation) : bool :=
    match eq with
    | EqApp _ _ _ _ _ => true
    | _ => false
    end.

  Definition is_def (eq: equation) : bool :=
    match eq with
    | EqDef _ _ _ => true
    | _ => false
    end.

  Record node : Type :=
    mk_node {
        n_name   : ident;
        n_in     : list (ident * (type * clock));
        n_out    : list (ident * (type * clock));
        n_vars   : list (ident * (type * clock));
        n_eqs    : list equation;

        n_ingt0  : 0 < length n_in;
        n_outgt0 : 0 < length n_out;
        n_defd   : Permutation (vars_defined n_eqs)
                               (map fst (n_vars ++ n_out));
        n_vout   : forall out, In out (map fst n_out) ->
                          ~ In out (vars_defined (filter is_fby n_eqs));
        n_nodup  : NoDupMembers (n_in ++ n_vars ++ n_out);
        n_good   : Forall (AtomOrGensym (PSP.of_list gensym_prefs)) (map fst (n_in ++ n_vars ++ n_out)) /\ atom n_name
      }.

  (** ** Program *)

  Definition global := list node.

  Implicit Type G: global.

  Definition find_node (f : ident) : global -> option node :=
    List.find (fun n=> ident_eqb n.(n_name) f).

  (** Structural properties *)

  Lemma find_node_name:
    forall G f n,
      find_node f G = Some n ->
      n.(n_name) = f.
  Proof.
    unfold find_node.
    induction G as [|m]; intros; try discriminate.
    simpl in H.
    destruct (ident_eqb (n_name m) f) eqn: E; auto.
    apply ident_eqb_eq; inv H; auto.
  Qed.

  Lemma find_node_other:
    forall f node G node',
      node.(n_name) <> f ->
      (find_node f (node::G) = Some node'
       <-> find_node f G = Some node').
  Proof.
    intros f node G node' Hnf.
    apply BinPos.Pos.eqb_neq in Hnf.
    simpl.
    unfold ident_eqb.
    rewrite Hnf.
    reflexivity.
  Qed.

  Lemma find_node_In:
    forall G f n,
      find_node f G = Some n ->
      n.(n_name) = f /\ In n G.
  Proof.
    induction G as [|n G IH]. now inversion 1.
    simpl. intros f n' Fn'.
    destruct (ident_eqb n.(n_name) f) eqn:Efn.
    - inv Fn'. apply ident_eqb_eq in Efn; auto.
    - apply IH in Fn'; tauto.
  Qed.

  Lemma is_filtered_eqs:
    forall eqs,
      Permutation
        (filter is_def eqs ++ filter is_app eqs ++ filter is_fby eqs)
        eqs.
  Proof.
    induction eqs as [|eq eqs]; auto.
    destruct eq; simpl.
    - now apply Permutation_cons.
    - rewrite <-Permutation_cons_app.
      apply Permutation_cons; reflexivity.
      now symmetry.
    - symmetry.
      rewrite <-Permutation_app_assoc.
      apply Permutation_cons_app.
      rewrite Permutation_app_assoc.
      now symmetry.
  Qed.

  Lemma is_filtered_vars_defined:
    forall eqs,
      Permutation
        (vars_defined (filter is_def eqs) ++ vars_defined (filter is_app eqs) ++ vars_defined (filter is_fby eqs))
        (vars_defined eqs).
  Proof.
    simpl.
    induction eqs as [|[] eqs]; simpl; auto.
    - rewrite Permutation_app_comm, 2 Permutation_app_assoc.
      apply Permutation_app_head.
      rewrite <-Permutation_app_assoc, Permutation_app_comm; auto.
    - symmetry.
      rewrite <-Permutation_app_assoc.
      apply Permutation_cons_app.
      symmetry.
      rewrite Permutation_app_assoc; auto.
  Qed.

  Lemma NoDup_var_defined_n_eqs:
    forall n,
      NoDup (vars_defined n.(n_eqs)).
  Proof.
    intro n.
    rewrite n.(n_defd).
    apply fst_NoDupMembers.
    apply (NoDupMembers_app_r _ _ n.(n_nodup)).
  Qed.

  Lemma n_eqsgt0:
    forall n, 0 < length n.(n_eqs).
  Proof.
    intro.
    pose proof (n_defd n) as Defd.
    pose proof (n_outgt0 n) as Out.
    unfold vars_defined in Defd.
    apply Permutation_length in Defd.
    rewrite flat_map_length, map_length, app_length in Defd.
    destruct (n_eqs n); simpl in *; omega.
  Qed.

  Definition gather_mem_eq (eq: equation): list ident :=
    match eq with
    | EqDef _ _ _
    | EqApp _ _ _ _ _ => []
    | EqFby x _ _ _ => [x]
    end.

  Definition gather_inst_eq (eq: equation): list (ident * ident) :=
    match eq with
    | EqDef _ _ _
    | EqFby _ _ _ _ => []
    | EqApp i _ f _ _ =>
      match i with
      | [] => []
      | i :: _ => [(i,f)]
      end
    end.

  Definition gather_app_vars_eq (eq: equation): list ident :=
    match eq with
    | EqDef _ _ _
    | EqFby _ _ _ _ => []
    | EqApp xs _ _ _ _ => tl xs
    end.

  Definition gather_mems := flat_map gather_mem_eq.
  Definition gather_insts := flat_map gather_inst_eq.
  Definition gather_app_vars := flat_map gather_app_vars_eq.

  (** Basic syntactical properties *)

  Lemma In_gather_mems_cons:
    forall eq eqs x,
      In x (gather_mems (eq :: eqs))
      <-> (In x (gather_mem_eq eq) \/ In x (gather_mems eqs)).
  Proof.
    destruct eq; simpl; split; intuition.
  Qed.

  Lemma In_gather_insts_cons:
    forall eq eqs x,
      InMembers x (gather_insts (eq :: eqs))
      <-> (InMembers x (gather_inst_eq eq) \/ InMembers x (gather_insts eqs)).
  Proof.
    destruct eq; simpl; try now intuition.
    destruct l.
    - setoid_rewrite app_nil_l. intuition.
    - now setoid_rewrite InMembers_app.
  Qed.

  Lemma In_gather_mems_dec:
    forall x eqs,
      { In x (gather_mems eqs) } + { ~In x (gather_mems eqs) }.
  Proof.
    induction eqs as [|eq eqs IH].
    now right; inversion 1.
    destruct eq; simpl; auto.
    destruct (ident_eq_dec x i).
    now subst; auto.
    destruct IH. auto.
    right. inversion 1; auto.
  Qed.

  Lemma In_gather_insts_dec:
    forall i eqs,
      { InMembers i (gather_insts eqs) } + { ~InMembers i (gather_insts eqs) }.
  Proof.
    induction eqs as [|eq eqs IH].
    now right; inversion 1.
    destruct eq; simpl; auto.
    destruct l as [|i'].
    now destruct IH; auto.
    destruct (ident_eq_dec i' i).
    subst; simpl; auto.
    destruct IH.
    now left; rewrite InMembers_app; auto.
    right; rewrite NotInMembers_app.
    split; auto. inversion 1; auto.
  Qed.

End NLSYNTAX.

Module NLSyntaxFun
       (Ids     : IDS)
       (Op      : OPERATORS)
       (CESyn   : CESYNTAX Op)
       <: NLSYNTAX Ids Op CESyn.
  Include NLSYNTAX Ids Op CESyn.
End NLSyntaxFun.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Bool List Int63 PArray.
Require Import State SMT_terms.
Local Open Scope array_scope.
Local Open Scope int63_scope.

Section certif.

  Variable t_form : PArray.array Form.form.
  Variable t_atom : PArray.array Atom.atom.

  Local Notation get_atom := (PArray.get t_atom) (only parsing).
  Local Notation get_form := (PArray.get t_form) (only parsing).

  Definition get_eq (x:var) (f : int -> int -> C.t) :=
    match get_form x with
    | Form.Fatom xa =>
      match get_atom xa with
      | Atom.Abop (Atom.BO_eq _) a b => f a b
      | _ => C._true
      end
    | _ => C._true
    end.
  (* Register get_eq as PrimInline. *)

  Fixpoint check_trans_aux (t1 t2:int)
      (eqs:list _lit) (res:_lit) (clause:C.t) : C.t :=
    match eqs with
    | nil =>
      let xres := Lit.blit res in
      get_eq xres (fun t1' t2' =>
         if ((t1 == t1') && (t2 == t2')) ||
            ((t1 == t2') && (t2 == t1')) then
            Lit.lit xres :: clause
         else C._true)
    | leq::eqs =>
      let xeq := Lit.blit leq in
      get_eq xeq (fun t t' =>
          if t2 == t' then
            check_trans_aux t1 t eqs res (Lit.nlit xeq :: clause)
          else
            if t2 == t then
              check_trans_aux t1 t' eqs res (Lit.nlit xeq :: clause)
            else
              if t1 == t' then
                check_trans_aux t t2 eqs res (Lit.nlit xeq :: clause)
              else
                if t1 == t then
                  check_trans_aux t' t2 eqs res (Lit.nlit xeq :: clause)
                else C._true)
    end.

  Definition check_trans (res:_lit) (eqs:list _lit) : C.t :=
    match eqs with
    | nil =>
      let xres := Lit.blit res in
        get_eq xres (fun t1 t2 =>
         if t1 == t2 then Lit.lit xres :: nil else C._true)
    | leq :: eqs =>
      let xeq := Lit.blit leq in
      get_eq xeq
        (fun t1 t2 => check_trans_aux t1 t2 eqs res (Lit.nlit xeq :: nil))
    end.

  Fixpoint build_congr (eqs:list (option _lit))
       (l r:list int) (c:C.t) {struct eqs} :=
    match eqs, l, r with
    | nil, nil, nil => c
    | eq::eqs, t1::l, t2::r =>
      match eq with
      | None => if t1 == t2 then build_congr eqs l r c else C._true
      | Some leq =>
        let xeq := Lit.blit leq in
        get_eq xeq (fun t1' t2' =>
          if ((t1 == t1') && (t2 == t2')) ||
             ((t1 == t2') && (t2 == t1')) then
            build_congr eqs l r (Lit.nlit xeq :: c)
          else C._true)
      end
    | _, _, _ => C._true
    end.

  Definition check_congr (leq:_lit) (eqs:list (option _lit)) :=
    let xeq := Lit.blit leq in
    get_eq xeq (fun t1 t2 =>
      match get_atom t1, get_atom t2 with
      | Atom.Abop o1 a1 a2, Atom.Abop o2 b1 b2 =>
        if Atom.bop_eqb o1 o2 then
           build_congr eqs (a1::a2::nil) (b1::b2::nil) (Lit.lit xeq :: nil)
        else C._true
      | Atom.Auop o1 a, Atom.Auop o2 b =>
        if Atom.uop_eqb o1 o2 then
           build_congr eqs (a::nil) (b::nil) (Lit.lit xeq :: nil)
        else C._true
      | Atom.Aapp f1 args1, Atom.Aapp f2 args2 =>
        if f1 == f2 then build_congr eqs args1 args2 (Lit.lit xeq :: nil)
        else C._true
      | _, _ => C._true
      end).

  Definition check_congr_pred (PA:_lit) (PB:_lit) (eqs:list (option _lit)) :=
    let xPA := Lit.blit PA in
    let xPB := Lit.blit PB in
    match get_form xPA, get_form xPB with
    | Form.Fatom pa, Form.Fatom pb =>
      match get_atom pa, get_atom pb with
      | Atom.Abop o1 a1 a2, Atom.Abop o2 b1 b2 =>
         if Atom.bop_eqb o1 o2 then
          build_congr eqs
          (a1::a2::nil) (b1::b2::nil) (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | Atom.Auop o1 a, Atom.Auop o2 b =>
         if Atom.uop_eqb o1 o2 then
          build_congr eqs
          (a::nil) (b::nil) (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | Atom.Aapp p a, Atom.Aapp p' b =>
        if p == p' then
          build_congr eqs a b (Lit.nlit xPA :: Lit.lit xPB :: nil)
        else C._true
      | _, _ => C._true
      end
    | _, _ => C._true
    end.

  Section Proof.

    Variables (t_i : array SMT_classes.typ_compdec)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_hatom :=
      (Atom.interp_hatom t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).

    Local Notation interp_form_hatom_bv :=
      (Atom.interp_form_hatom_bv t_i t_func t_atom).

    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom interp_form_hatom_bv t_form).

    Let wf_t_atom : Atom.wf t_atom.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_atom : default t_atom = Atom.Acop Atom.CO_xH.
    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.

    Let def_t_form : default t_form = Form.Ftrue.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _]; destruct H; auto.
    Qed.

    Let wf_t_form : Form.wf t_form.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [H _]; destruct H; auto.
    Qed.

    Let wf_rho : Valuation.wf rho.
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto.
    Qed.

    Lemma valid_C_true : C.interp rho C._true.
    Proof.
      apply C.interp_true.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form);trivial.
    Qed.
    Hint Resolve valid_C_true.

    Local Notation interp := (Atom.interp t_i t_func t_atom).

    Lemma wf_interp_form : forall x,
       rho x = Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[x]).
    Proof.
      destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form).
      destruct H; intros x;rewrite Form.wf_interp_form;trivial.
    Qed.

    Local Notation get_type :=
        (Atom.get_type t_i t_func t_atom).

    Local Notation check_type :=
        (Atom.check_aux t_i t_func get_type).

    Lemma get_eq_interp :
      forall (l:_lit) (f:Atom.hatom -> Atom.hatom -> C.t),
       (forall xa, t_form.[Lit.blit l] = Form.Fatom xa ->
        forall t a b, t_atom.[xa] = Atom.Abop (Atom.BO_eq t) a b ->
        rho (Lit.blit l) =
          Atom.interp_bool t_i
           (Atom.apply_binop t_i t t Typ.Tbool (Typ.i_eqb t_i t)
              (interp_hatom a) (interp_hatom b)) ->
        Typ.eqb (get_type a) t -> Typ.eqb (get_type b) t ->
        C.interp rho (f a b)) ->
      C.interp rho (get_eq (Lit.blit l) f).
    Proof.
      intros l f Hf;unfold get_eq.
      case_eq (t_form.[Lit.blit l]);trivial;intros.
      case_eq (t_atom.[i]);trivial;intros.
      destruct b;trivial.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H0, def_t_atom;discriminate.
      apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2.
      rewrite !andb_true_iff in H2;decompose [and] H2;clear H2.
      apply Hf with (2:= H0);trivial.
      rewrite wf_interp_form, H;simpl.
      unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl.
      rewrite Atom.t_interp_wf, H0;simpl;trivial.
    Qed.

    Let tunicity : forall A T U, Typ.eqb A T -> Typ.eqb A U -> T = U.
    Proof. intros A T U; rewrite !Typ.eqb_spec; intros; subst T U; auto. Qed.

    Ltac tunicity :=
      match goal with
      | [ H1 : is_true (Typ.eqb ?a ?t1),
          H2 : is_true (Typ.eqb ?a ?t2) |- _ ] =>
        assert (W:= tunicity _ _ _ H1 H2)
      | _ => idtac
      end.

    Lemma interp_binop_eqb_sym :
      forall u a b,
      Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u) a b =
      Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u) b a.
    Proof.
      unfold Atom.apply_binop;simpl;intros u (ta,va) (tb,vb).
      destruct (Typ.cast ta u);destruct (Typ.cast tb u);trivial.
      apply f_equal; apply eq_true_iff_eq.
      match goal with |- ?x = _ <-> ?y = _ =>
                      change (is_true x <-> is_true y) end.
      split; intro; rewrite Typ.i_eqb_sym in H; auto.
    Qed.

    Lemma interp_binop_eqb_trans:
      forall u a b c,
      Typ.eqb (get_type a) u -> Typ.eqb (get_type b) u -> Typ.eqb (get_type c) u ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom a) (interp_hatom b)) ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom b) (interp_hatom c)) ->
      Atom.interp_bool t_i
        (Atom.apply_binop t_i u u Typ.Tbool (Typ.i_eqb t_i u)
           (interp_hatom a) (interp_hatom c)).
    Proof.
      intros u a b c Ha Hb Hc.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom c). rewrite Typ.eqb_spec in Ha. rewrite Typ.eqb_spec in Hb. rewrite Typ.eqb_spec in Hc. unfold Atom.get_type in Ha, Hb, Hc. rewrite Ha, Hb, Hc. intros [va HHa] [vb HHb] [vc HHc].
      unfold Atom.interp_hatom.
      rewrite HHa, HHb, HHc;simpl;rewrite Typ.cast_refl.
      unfold Atom.interp_bool;simpl.
      apply Typ.i_eqb_trans.
    Qed.

    Lemma check_trans_aux_correct :
      forall eqs u t1 t2 res c,
       Typ.eqb (get_type t1) u -> Typ.eqb (get_type t2) u ->
       Atom.interp_bool t_i (interp (Atom.Abop (Atom.BO_eq u) t1 t2)) \/
       C.interp rho c ->
       C.interp rho (check_trans_aux t1 t2 eqs res c).
    Proof.
      induction eqs;simpl;intros.
      apply get_eq_interp;intros.
      match goal with |- context [if ?b then _ else _] => case_eq b end;
       intros;trivial.
      simpl;rewrite Lit.interp_lit;unfold Var.interp.
      destruct H1;[ | rewrite H1,orb_true_r;auto].
      rewrite orb_true_iff, !andb_true_iff in H7;destruct H7 as
        [[H7 H8] | [H7 H8]].
      rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst.
      tunicity. subst t. rewrite H4, H1;auto.
      rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst.
      tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto.
      apply get_eq_interp;intros.
      destruct (Int63Properties.reflect_eqb t2 b);subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (4:= H1);trivial.
      rewrite interp_binop_eqb_sym;trivial.
      destruct (Int63Properties.reflect_eqb t2 a0); subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (4:= H1);trivial.
      destruct (Int63Properties.reflect_eqb t1 b);subst;tunicity; try subst t.
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (5:= H1);trivial.
      destruct (Int63Properties.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto].
      apply (IHeqs u);trivial.
      simpl;unfold is_true;rewrite orb_true_iff.
      rewrite Lit.interp_nlit;unfold Var.interp.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *)
      case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto].
      destruct H1;[left | auto].
      apply interp_binop_eqb_trans with (5:= H1);trivial.
      rewrite interp_binop_eqb_sym;trivial.
    Qed.

    Lemma valid_check_trans :
      forall res eqs,
       C.interp rho (check_trans res eqs).
    Proof.
      unfold check_trans;intros res [ | leq eqs].
      apply get_eq_interp;intros.
      destruct (Int63Properties.reflect_eqb a b).
      unfold C.interp; simpl; rewrite orb_false_r.
      unfold Lit.interp; simpl; rewrite Lit.is_pos_lit.
      unfold Var.interp; simpl; rewrite Lit.blit_lit.
      rewrite H1.
      unfold Atom.interp_bool; simpl.
      rewrite e; simpl.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H3. rewrite H3. intros [vb HHb].
      unfold Atom.interp_hatom.
      rewrite HHb;simpl;rewrite Typ.cast_refl;simpl.
      apply Typ.i_eqb_refl.
      auto.
      apply get_eq_interp;intros.
      apply check_trans_aux_correct with t;trivial.
      simpl;rewrite Lit.interp_nlit;unfold Var.interp. rewrite <- H1.
      (* Attention ici on utilise la decidabilit'e de l'egalit'e sur t *)
      destruct (rho (Lit.blit leq));auto.
    Qed.

    Inductive Forall2 A B (P:A->B->Prop) : list A -> list B -> Prop :=
    | Forall2_nil : Forall2 A B P nil nil
    | Forall2_cons :
       forall a b la lb, P a b -> Forall2 A B P la lb ->
         Forall2 A B P (a::la) (b::lb).

    Lemma build_congr_correct : forall lp l r c,
      (Forall2 _ _ (fun a b => interp_hatom a = interp_hatom b) l r -> C.interp rho c) ->
      C.interp rho (build_congr lp l r c).
    Proof.
      induction lp;destruct l;destruct r;simpl;trivial;intros.
      apply H;constructor.
      destruct a.
      apply get_eq_interp;intros.
      match goal with |- context [if ?x then _ else _] =>
       case_eq x;intros;auto end.
      apply IHlp;simpl;intros.
      rewrite Lit.interp_nlit;unfold Var.interp.
      case_eq (rho (Lit.blit i1));intros;simpl;[ | auto].
      apply H;constructor;trivial.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. rewrite Typ.eqb_spec in H4. unfold Atom.get_type in H3, H4. rewrite H3,H4. intros [va HHa] [vb HHb].
      revert H7;rewrite H2;unfold Atom.apply_binop; simpl.
      unfold Atom.interp_hatom.
      rewrite HHa, HHb;simpl;rewrite Typ.cast_refl;simpl.
      intros W;change (is_true (Typ.i_eqb t_i t va vb)) in W.
      rewrite Typ.i_eqb_spec in W.
      rewrite orb_true_iff, !andb_true_iff in H5;destruct H5 as
        [ [H5 H7] | [H5 H7]].
      rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst.
      rewrite HHa, HHb;trivial.
      rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst.
      rewrite HHa, HHb;trivial.
      destruct (Int63Properties.reflect_eqb i i0);[subst | auto].
      apply IHlp;intros;apply H;constructor;auto.
    Qed.

    Lemma valid_check_congr :
       forall leq eqs,
          C.interp rho (check_congr leq eqs).
    Proof.
      unfold check_congr;intros leq eqs;apply get_eq_interp;intros.
      case_eq (t_atom .[ a]);intros;auto;
      case_eq (t_atom .[ b]);intros;auto.
      (* uop *)
      destruct (Atom.reflect_uop_eqb u u0);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa. simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
       inversion H6;subst.
       unfold Atom.interp_hatom in H10.
       rewrite <- HHa; rewrite <- HHb, H10;trivial.
       inversion H7.
       apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
       rewrite H9.
       apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
      (* bop *)
      destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop. unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa;simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
       inversion H6;clear H6;subst.
       inversion H12;clear H12;subst.
       unfold Atom.interp_hatom in H10, H8.
       rewrite <- HHa. rewrite <- HHb, H10, H8;trivial.
      inversion H7.
      apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
      rewrite H9.
      apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
      (* op *)
      destruct (Int63Properties.reflect_eqb i i0);[subst | auto].
      apply build_congr_correct;intros.
      simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp.
      rewrite H1.
      generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb].
      unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl.
      rewrite HHb, HHa;simpl.
      rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa.
      rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb.
      rewrite Typ.cast_refl;simpl.
      assert (Atom.Bval t_i t va = Atom.Bval t_i t vb).
        rewrite <- HHa;rewrite <- HHb;destruct (t_func.[i0]).
        apply f_equal;clear HHa HHb va vb H5 H4.
        induction H6;simpl;trivial.
        unfold Atom.interp_hatom in H4.
        rewrite IHForall2, H4;trivial.
      inversion H7.
      apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial.
      rewrite H9.
      apply Typ.i_eqb_refl.
      intros x y;destruct (Typ.reflect_eqb x y);auto.
    Qed.

    Lemma valid_check_congr_pred :
       forall lpa lpb eqs,
          C.interp rho (check_congr_pred lpa lpb eqs).
    Proof.
      unfold check_congr_pred;intros.
      case_eq (t_form.[Lit.blit lpa]);auto.
      case_eq (t_form.[Lit.blit lpb]);auto;intros.
      case_eq (t_atom.[i0]);auto; case_eq (t_atom.[i]);auto;intros.
      (* uop *)
      destruct (Atom.reflect_uop_eqb u0 u);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom;discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      apply f_equal;apply f_equal.
      inversion H3;clear H3;subst;trivial.

      (* bop *)
      destruct (Atom.reflect_bop_eqb b0 b);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom. discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      inversion H3;clear H3;subst.
      inversion H11;clear H11;subst.
      apply f_equal; apply f_equal2;trivial.

      (* op *)
      destruct (Int63Properties.reflect_eqb i2 i1);[subst | auto].
      apply build_congr_correct;simpl;intros.
      rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp.
      replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)).
       destruct (rho (Lit.blit lpa));reflexivity.
      rewrite !wf_interp_form, H, H0;simpl.
      generalize wt_t_atom;unfold Atom.wt;unfold is_true;
       rewrite PArray.forallbi_spec;intros.
      assert (i < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H1, def_t_atom;discriminate.
      assert (i0 < length t_atom).
        apply PArray.get_not_default_lt.
        rewrite H2, def_t_atom;discriminate.
      apply H4 in H5;apply H4 in H6;clear H4.
      unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl.
      rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial.
      apply f_equal;destruct (t_func.[i1]);apply f_equal.
      clear H H0 H1 H2 H5 H6.
      induction H3;simpl;trivial.
      unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial.
    Qed.

  End Proof.

End certif.

(*
   Local Variables:
   coq-load-path: ((rec ".." "SMTCoq"))
   End:
*)