Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Util.FixCoqMistakes.

Section language.
  Context {base_type_code : Type}.

  Section flat.
    Context (P : flat_type base_type_code -> Type).

    Local Ltac t :=
      let H := fresh in
      intro H; intros;
      match goal with
      | [ p : _ |- _ ] => specialize (H _ p)
      end;
      assumption.

    Definition preinvert_Tbase (Q : forall t, P (Tbase t) -> Type)
      : (forall t (p : P t), match t return P t -> Type with Tbase _ => Q _ | _ => fun _ => True end p)
        -> forall t p, Q t p.
    Proof. t. Defined.

    Definition preinvert_Unit (Q : P Unit -> Type)
      : (forall t (p : P t), match t return P t -> Type with Unit => Q | _ => fun _ => True end p)
        -> forall p, Q p.
    Proof. t. Defined.

    Definition preinvert_Prod (Q : forall A B, P (Prod A B) -> Type)
      : (forall t (p : P t), match t return P t -> Type with Prod _ _ => Q _ _ | _ => fun _ => True end p)
        -> forall A B p, Q A B p.
    Proof. t. Defined.

    Definition preinvert_Prod2 (Q : forall A B, P (Prod (Tbase A) (Tbase B)) -> Type)
      : (forall t (p : P t), match t return P t -> Type with Prod (Tbase _) (Tbase _) => Q _ _ | _ => fun _ => True end p)
        -> forall A B p, Q A B p.
    Proof. t. Defined.

    Definition preinvert_Prod3 (Q : forall A B C, P (Tbase A * Tbase B * Tbase C)%ctype -> Type)
      : (forall t (p : P t), match t return P t -> Type with Prod (Prod (Tbase _) (Tbase _)) (Tbase _) => Q _ _ _ | _ => fun _ => True end p)
        -> forall A B C p, Q A B C p.
    Proof. t. Defined.

    Definition preinvert_Prod4 (Q : forall A B C D, P (Tbase A * Tbase B * Tbase C * Tbase D)%ctype -> Type)
      : (forall t (p : P t), match t return P t -> Type with Prod (Prod (Prod (Tbase _) (Tbase _)) (Tbase _)) (Tbase _) => Q _ _ _ _ | _ => fun _ => True end p)
        -> forall A B C D p, Q A B C D p.
    Proof. t. Defined.
  End flat.

  Definition preinvert_Arrow (P : type base_type_code -> Type) (Q : forall A B, P (Arrow A B) -> Type)
    : (forall t (p : P t), match t return P t -> Type with
                           | Arrow A B => Q A B
                           end p)
      -> forall A B p, Q A B p.
  Proof.
    intros H A B p; specialize (H _ p); assumption.
  Defined.

  Section encode_decode.
    Definition flat_type_code (t1 t2 : flat_type base_type_code) : Prop
      := match t1, t2 with
         | Unit, Unit => True
         | Tbase t1, Tbase t2 => t1 = t2
         | Prod A B, Prod A' B' => A = A' /\ B = B'
         | Unit, _
         | Tbase _, _
         | Prod _ _, _
           => False
         end.

    Definition type_code (t1 t2 : type base_type_code) : Prop
      := domain t1 = domain t2 /\ codomain t1 = codomain t2.

    Definition flat_type_encode (x y : flat_type base_type_code) : x = y -> flat_type_code x y.
    Proof. intro p; destruct p, x; repeat constructor. Defined.
    Definition type_encode (x y : type base_type_code) : x = y -> type_code x y.
    Proof. intro p; destruct p, x; repeat constructor. Defined.

    Definition flat_type_decode (x y : flat_type base_type_code) : flat_type_code x y -> x = y.
    Proof.
      destruct x, y; simpl in *; intro H;
        try first [ apply f_equal; assumption
                  | exfalso; assumption
                  | reflexivity
                  | apply f_equal2; destruct H; assumption ].
    Defined.
    Definition type_decode (x y : type base_type_code) : type_code x y -> x = y.
    Proof.
      destruct x, y; simpl; intro H;
        try first [ exfalso; assumption
                  | apply f_equal; assumption
                  | apply f_equal2; destruct H; assumption ].
    Defined.
    Definition path_flat_type_rect {x y : flat_type base_type_code} (Q : x = y -> Type)
               (f : forall p, Q (flat_type_decode x y p))
      : forall p, Q p.
    Proof. intro p; specialize (f (flat_type_encode x y p)); destruct x, p; exact f. Defined.
    Definition path_type_rect {x y : type base_type_code} (Q : x = y -> Type)
               (f : forall p, Q (type_decode x y p))
      : forall p, Q p.
    Proof. intro p; specialize (f (type_encode x y p)); destruct x, p; exact f. Defined.
  End encode_decode.
End language.

Ltac preinvert_one_type e :=
  lazymatch type of e with
  | ?P (Tbase ?T)
    => is_var T;
       move e at top;
       revert dependent T;
       refine (preinvert_Tbase P _ _)
  | ?P (Prod (Tbase ?A) (Tbase ?B))
    => is_var A; is_var B;
       move e at top; revert dependent A; intros A e;
       move e at top; revert dependent B; revert A;
       refine (preinvert_Prod2 P _ _)
  | ?P (Prod (Prod (Tbase ?A) (Tbase ?B)) (Tbase ?C))
    => is_var A; is_var B; is_var C;
       move e at top; revert dependent A; intros A e;
       move e at top; revert dependent B; intros B e;
       move e at top; revert dependent C; revert A B;
       refine (preinvert_Prod3 P _ _)
  | ?P (Prod (Prod (Prod (Tbase ?A) (Tbase ?B)) (Tbase ?C)) (Tbase ?D))
    => is_var A; is_var B; is_var C; is_var D;
       move e at top; revert dependent A; intros A e;
       move e at top; revert dependent B; intros B e;
       move e at top; revert dependent C; intros C e;
       move e at top; revert dependent D; revert A B C;
       refine (preinvert_Prod4 P _ _)
  | ?P (Prod ?A ?B)
    => is_var A; is_var B;
       move e at top; revert dependent A; intros A e;
       move e at top; revert dependent B; revert A;
       refine (preinvert_Prod P _ _)
  | ?P Unit
    => revert dependent e;
       refine (preinvert_Unit P _ _)
  | ?P (Arrow ?A ?B)
    => is_var A; is_var B;
       move e at top; revert dependent A; intros A e;
       move e at top; revert dependent B; revert A;
       refine (preinvert_Arrow P _ _)
  end.

Ltac induction_type_in_using H rect :=
  induction H as [H] using (rect _ _ _);
  cbv [flat_type_code type_code] in H;
  let H1 := fresh H in
  let H2 := fresh H in
  try lazymatch type of H with
      | False => exfalso; exact H
      | True => destruct H
      | _ /\ _ => destruct H as [H1 H2]
      end.
Ltac inversion_flat_type_step :=
  lazymatch goal with
  | [ H : _ = Tbase _ |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  | [ H : Tbase _ = _ |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  | [ H : _ = Prod _ _ |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  | [ H : Prod _ _ = _ |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  | [ H : _ = Unit |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  | [ H : Unit = _ |- _ ]
    => induction_type_in_using H @path_flat_type_rect
  end.
Ltac inversion_flat_type := repeat inversion_flat_type_step.

Ltac inversion_type_step :=
  lazymatch goal with
  | [ H : _ = Arrow _ _ |- _ ]
    => induction_type_in_using H @path_type_rect
  | [ H : Arrow _ _ = _ |- _ ]
    => induction_type_in_using H @path_type_rect
  end.
Ltac inversion_type := repeat inversion_type_step.


Require Import Coq.Lists.List.

Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.Judgments.
Require Export SystemFR.EquivalentStar.

Opaque reducible_values.

Lemma annotated_equivalent_refine_equivalent:
  forall Θ Γ Γ' x T p,
    is_annotated_term p ->
    ~ x ∈ pfv p term_var ->
    (forall z, z ∈ pfv p term_var -> z ∈ support Γ -> False) ->
    [[ Θ; Γ ++ (x, T_refine T p) :: Γ' ⊨ open 0 p (fvar x term_var) ≡ ttrue ]].
Proof.
  unfold open_equivalent;
    repeat step || satisfies_cut || rewrite erase_context_append in * || step_inversion satisfies || list_utils || simp_red.

  rewrite substitute_append2; repeat step || fv_open || t_fv_erase || list_utils || erase_open || t_substitutions;
    eauto with fv;
    try solve [ equivalent_star ].

  apply (satisfies_y_in_support _ _ _ _ _ _ x0) in H3; repeat step;
    side_conditions.
Qed.

Lemma annotated_equivalence_in_context:
  forall Θ Γ Γ' x e1 e2,
    (forall z, z ∈ pfv e1 term_var -> z ∈ support Γ -> False) ->
    (forall z, z ∈ pfv e2 term_var -> z ∈ support Γ -> False) ->
    [[ Θ; Γ ++ (x, T_equiv e1 e2) :: Γ' ⊨ e1 ≡ e2 ]].
Proof.
  unfold open_equivalent;
    repeat step || satisfies_cut || rewrite erase_context_append in * || step_inversion satisfies || list_utils || simp_red.

  rewrite substitute_append2; repeat step || fv_open || t_fv_erase || list_utils || t_substitutions.
  - rewrite substitute_append2; repeat step || fv_open || t_fv_erase || list_utils || t_substitutions.
    apply (satisfies_y_in_support _ _ _ _ _ _ x0) in H2; repeat step;
      side_conditions.
  - apply (satisfies_y_in_support _ _ _ _ _ _ x0) in H2; repeat step;
      side_conditions.
Qed.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Misc.
Require Import Graph.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Local Open Scope morphism_scope.

Section DiagToGraph.
  Context `{Funext}.

  Definition DiagramToGraph {I C :  PreCategory} (D : Functor I C) : Graph C (object I) (Arrows I) :=
    {| gr_vertex := fun x => (D _0 x)%object
    ;  gr_edges  := fun m => {| proj1 := arr_src m
                          ;  proj2 := {| proj1 := arr_dst m
                                      ;  proj2 := D _1 (arr_mph m)
                                      |}
                          |}
    |}.

  Definition DiagConeToGraphCone {I C : PreCategory} (D : Functor I C) {c : object C} :
    NaturalTransformation (diagonal_functor' C I _0 c)%object D -> Cone (DiagramToGraph D).
  Proof.
    intro t. srapply mkCone; [ exact c | exact (components_of t) | idtac ].
    intro a. unfold DiagramToGraph; unfold gr_edge; unfold gr_src; unfold gr_dst; simpl.
    rewrite <- (right_identity C _ _ (t (arr_dst a))).
    destruct a as [ src dst m ]; simpl. apply (commutes_sym t src dst m).
  Defined.

  Definition DiagConeToGraphCone' {I C : PreCategory} (D : Functor I C) :
    forall(cn : Cone (DiagramToGraph D)),
      NaturalTransformation (diagonal_functor' C I _0 (cn_top cn))%object D.
  Proof.
    intro cn. srapply Build_NaturalTransformation; [ exact (cn_side cn) | idtac ].
    intros src dst m. simpl. rewrite right_identity.
    rewrite (cn_comm cn (mkArrow m)). reflexivity.
  Qed.

  Check IsLimit.

End DiagToGraph.


Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Graph.
Require Import Dict.
Require Import Misc.
Require Import CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import EqDec.
Require Import Enumerable.
Import ListNotations.

Section BGP.
  (* the bgp spec: https://tools.ietf.org/html/rfc4271

     We don't care about error-handling, session management,
     low level bit representation, etc. This means we can
     ignore sections:
     - 4.1 Message Header Format
     - 4.2 OPEN Message Format
     - 4.4 KEEPALIVE Message Format
     - 4.5 NOTIFICATION Message Format
     - 6.  BGP Error Handling.
     - 7.  BGP Version Negotiation.
     - 8.  BGP Finite State machine.
     - 9.1.2.1.  Route Resolvability Condition

     We also don't support
     - Route aggregation and information reduction techniques
     - Route reflectors
  *)

  Class PrefixClass := {
    Prefix : Type;
    eqDecPrefix :> eqDec Prefix
  }.
  Context `{PrefixClass}.

  (* 5.  Path Attributes *)
  Class PathAttributesClass := {
    PathAttributes : Type;
    eqDecPathAttributes :> eqDec PathAttributes;
    localPref : PathAttributes -> nat
  }.
  Context `{PathAttributesClass}.
  Arguments localPref {_} _.

  Inductive RoutingInformation :=
  | available (_:PathAttributes)
  | notAvailable.

  Instance eqDecRoutingInformation : eqDec RoutingInformation.
    constructor. decide equality. apply eqDecide.
  Defined.

  Instance enumerableRoutingInformation `{enumerable PathAttributes} : enumerable RoutingInformation.
    refine {|enumerate := notAvailable :: map available enumerate |}.
  Proof.
    intro a.
    cbn.
    destruct a.
    - right.
      apply in_map.
      apply enumerateContainsEverything.
    - left.
      reflexivity.
  Qed.

  Definition bindRoutingInformation (a:RoutingInformation) (f:PathAttributes -> RoutingInformation) : RoutingInformation :=
    match a with
    | notAvailable => notAvailable
    | available a => f a
    end.

  Inductive Mode := ibgp | ebgp.
  Instance eqDecMode : eqDec Mode.
    constructor. decide equality.
  Defined.

  Class TopologyClass := {
    Router : Type;
    eqDecRouter :> eqDec Router;
    enumerableRouter :> enumerable Router;
    connections : graph Router;
    eqDecConnection s d :> eqDec (edge connections s d);
    enumerableConnection s d :> enumerable (edge connections s d);
    mode {s d} : edge connections s d -> Mode
  }.
  Context `{TopologyClass}.

  Definition connection s d := edge connections s d.
  Typeclasses Transparent connection.
  Definition Connection :=  {c : Router * Router & connection (fst c) (snd c)}.
  Typeclasses Transparent Connection.

  (* 4.3 UPDATE Message Format

     The BGP Spec is very confusing regarding the meaning of multiple
     prefixes in the NLRI field of an Update Message. But the following
     sentence (added to RFC 4271) explains it:

     > Routes are advertised between BGP speakers in UPDATE messages.
     > Multiple routes that have the same path attributes can be advertised
     > in a single UPDATE message by including multiple prefixes in the NLRI
     > field of the UPDATE message.

     Update messages support the withdrawl and announcement of multiple routes
     at the same time. We limit it to one route withdrawl xor announcement.
  *)
  Record UpdateMessage : Type := updateMessage {
    (* the routes's prefix *)
    nlri : Prefix;
    attributes : RoutingInformation
  }.
  Instance eqDecUpdateMessage : eqDec UpdateMessage.
    idtac.
    constructor.
    repeat decide equality; apply eqDecide.
  Defined.

  Section RouterInternal.
    Variable r:Router.

    Inductive incoming :=
    | injected : incoming
    | received : {s : Router & connection s r} -> incoming.

    Instance eqDecIncoming : eqDec incoming.
      constructor.
      intros i i'.
      destruct i, i'.
      - left. reflexivity.
      - decide equality. apply eqDecide.
      - decide equality. apply eqDecide.
      - decide equality. apply eqDecide.
    Defined.
    Instance enumerableIncoming : enumerable incoming.
      refine {|
        enumerate := injected :: (received <$> enumerate)
      |}.
      intro i; destruct i.
      + crush.
      + apply in_cons.
        apply in_map.
        apply enumerateContainsEverything.
    Defined.
    Definition outgoing := {d : Router & connection r d}.
    Typeclasses Transparent outgoing.

    Class ConfigurationClass := {
      import : incoming -> Prefix -> PathAttributes -> RoutingInformation;
      export : incoming -> outgoing -> Prefix -> PathAttributes -> RoutingInformation;

      (* 9.4.  Originating BGP routes

         > A BGP speaker may originate BGP routes by injecting routing
         > information acquired by some other means (e.g., via an IGP) into BGP.
         > A BGP speaker that originates BGP routes assigns the degree of
         > preference (e.g., according to local configuration) to these routes
         > by passing them through the Decision Process (see Section 9.1).
         > These routes MAY also be distributed to other BGP speakers within the
         > local AS as part of the update process (see Section 9.2).

         It's unclear which import filter is run, since import filters are
         defined per neighbor, and routes that I originate don't have a neighbor.

         Looking at real configs, it appears that there simply is no import filter
         for internal routes, the routes are just injected directly into the locRIB,
         and then exported.

         A description of how to originate networks for Cisoc is here:
         http://www.cisco.com/c/en/us/support/docs/ip/border-gateway-protocol-bgp/26634-bgp-toc.html#networkcommand

         What we are doing now, is that we have a special adjRIBIn just for injected routes,
         which are then passed through the decision process as usual. The following
         function encodes the user's policy about installed static routes.
      *)
      originate : Prefix -> PathAttributes -> bool
    }.
    Context `{ConfigurationClass}.

    (* 3.2 Routing Information Bases *)

    (* The Routing Table (used for packet forwarding) is different from the RIB *)

    Record RIBs := {
      adjRIBsIn: dict (incoming * Prefix) RoutingInformation;
      locRIB: dict Prefix RoutingInformation;
      adjRIBsOut: dict (outgoing * Prefix) RoutingInformation
    }.

    Definition originate' p a :=
      match a with
      | notAvailable => true
      | available a => originate p a
      end.

    Definition localPref' (a:RoutingInformation) : nat :=
      match a with
      | notAvailable => 0
      | available a => S (localPref a)
      end.

    Definition import' s p a := bindRoutingInformation a (import s p).

    Definition export' (i:incoming) (o:outgoing) (p:Prefix) (a:RoutingInformation) : RoutingInformation :=
      match i with
      | injected => bindRoutingInformation a (export i o p)
      | received (existT _ _ ci) => let ' existT _ _ co := o in
                                    if (mode ci =? ibgp) && (mode co =? ibgp)
                                    then notAvailable
                                    else bindRoutingInformation a (export i o p)
      end.

    Definition decisionProcess (p:Prefix) (ribs:RIBs) : RIBs.
      refine(
      let in_ := adjRIBsIn ribs in
      let loc := locRIB ribs in
      let out := adjRIBsOut ribs in
      let in' := in_ in
      (* 9.1.  Decision Process

         > Once the BGP speaker updates the Adj-RIB-In, the speaker SHALL run
         > its Decision Process.

         Since adjsRIBin only changed for the prefix p, it is sufficient to run
         the decision process only the part of RIBs for prefix p.

         > The Decision Process takes place in three distinct phases,
      *)

      (* 9.1.1.  Phase 1: Calculation of Degree of Preference

         > a) Phase 1 is responsible for calculating the degree of preference
         >   for each route received from a peer.

         > The exact nature of this policy information, and the computation
         > involved, is a local matter.

         > The selection process is formalized by defining a function that takes
         > the attribute of a given route as an argument and returns either (a)
         > a non-negative integer denoting the degree of preference for the
         > route, or (b) a value denoting that this route is ineligible to be
         > installed in Loc-RIB and will be excluded from the next phase of
         > route selection.

         > If the AS_PATH attribute of a BGP route contains an AS loop, the BGP
         > route should be excluded from the Phase 2 decision function.

         We will implement that in the import function

         > The function that calculates the degree of preference for a given
         > route SHALL NOT use any of the following as its inputs: the existence
         > of other routes, the non-existence of other routes, or the path
         > attributes of other routes.  Route selection then consists of the
         > individual application of the degree of preference function to each
         > feasible route, followed by the choice of the one with the highest
         > degree of preference.
      *)

      (* 9.1.2.  Phase 2: Route Selection

         > The Phase 2 decision function is invoked on completion of Phase 1.

         > For each set of destinations for which a feasible route exists in the
         > Adj-RIBs-In, the local BGP speaker identifies the route that has:

         > a) the highest degree of preference of any route to the same set
         >    of destinations, or

         > c) is selected as a result of the Phase 2 tie breaking rules
         >    specified in Section 9.1.2.2.

         > The local speaker SHALL then install that route in the Loc-RIB,
         > replacing any route to the same destination that is currently being
         > held in the Loc-RIB.
      *)
      let n' := argMax' (fun s => localPref' (import' s p (lookup (adjRIBsIn ribs) (s,p)))) _ in
      let a' := import' n' p (lookup (adjRIBsIn ribs) (n',p)) in
      let loc' := overwrite loc p a' in

      (* 9.1.3.  Phase 3: Route Dissemination

         > The Phase 3 decision function is invoked on completion of Phase 2

         > c) Phase 3 is ...
         >    responsible for disseminating routes in the Loc-RIB to each
         >    peer

         > All routes in the Loc-RIB are processed into Adj-RIBs-Out according
         > to configured policy.  This policy MAY exclude a route in the Loc-RIB
         > from being installed in a particular Adj-RIB-Out.

         > 9.1.4.  Overlapping Routes

         > A BGP speaker may transmit routes with overlapping Network Layer
         > Reachability Information (NLRI) to another BGP speaker.

         We don't support aggregation

         > When a BGP speaker receives an UPDATE message from an internal peer,
         > the receiving BGP speaker SHALL NOT re-distribute the routing
         > information contained in that UPDATE message to other internal peers

         We implement that in the export' function
      *)
      let out' := build (fun k => let ' (o,p') := k in if p =? p' then export' n' o p a' else lookup out (o,p'))
      in  {| adjRIBsIn  := in'; locRIB := loc'; adjRIBsOut := out' |}
    ).
    Proof.
    - exact injected.
    Defined.

    Typeclasses Transparent const.

    Definition updateSendProcess (p:Prefix) (out out':dict (outgoing*Prefix) RoutingInformation) : dict outgoing (list UpdateMessage).
      (* 9.2 Update-Send Process

         > As part of Phase 3 of the route selection process, the BGP speaker
         > has updated its Adj-RIBs-Out.  All newly installed routes and all
         > newly unfeasible routes for which there is no replacement route SHALL
         > be advertised to its peers by means of an UPDATE message.
      *)
      refine(build (fun o => if lookup out (o,p) =? lookup out' (o,p)
                             then []
                             else [{| nlri:=p; attributes:=lookup out' (o,p) |}])).
    Defined.

    (* 9.  UPDATE Message Handling *)
    Definition messageHandling (s:incoming) (m:UpdateMessage) (ribs:RIBs) :
                               dict outgoing (list UpdateMessage) * RIBs.
      refine (
      let in_ := adjRIBsIn ribs in
      let loc := locRIB ribs in
      let out := adjRIBsOut ribs in
      let p := nlri m in
      let a := attributes m in

      (* > If the UPDATE message contains a non-empty WITHDRAWN ROUTES field,
         > the previously advertised routes, whose destinations (expressed as IP
         > prefixes) are contained in this field, SHALL be removed from the
         > Adj-RIB-In.

         > If the UPDATE message contains a feasible route, the Adj-RIB-In will
         > be updated with this route as follows: if the NLRI of the new route
         > is identical to the one the route currently has stored in the Adj-
         > RIB-In, then the new route SHALL replace the older route in the Adj-
         > RIB-In, thus implicitly withdrawing the older route from service.
         > Otherwise, if the Adj-RIB-In has no route with NLRI identical to the
         > new route, the new route SHALL be placed in the Adj-RIB-In.
      *)
      let in' := overwrite'' in_ (s,p) a in
      let rib' := decisionProcess p {| adjRIBsIn := in'; locRIB := loc; adjRIBsOut := out |} in
      let out' := adjRIBsOut rib' in
      let E := updateSendProcess p out out'
      in  (E, rib')).
    Defined.

  End RouterInternal.

  Context `{forall r, ConfigurationClass r}.

  Record NetworkState : Type := networkState {
    routerState : depDict Router RIBs;
    linkState : dict Connection (list UpdateMessage)
  }.

  Definition routerHandler r (i:incoming r) (m:UpdateMessage) (rs:forall r, RIBs r) :
                           dict Connection (list UpdateMessage) * (forall r, RIBs r).
    refine (let ' (E, ribs) := messageHandling r i m (lookup rs r) in _).
    refine (let rs' := overwrite' rs r ribs in _).
    refine (let E' := build(fun c' => _) in (E',rs')).
    unfold const.
    destruct c' as [r'd c'].
    destruct r'd as [r' d].
    refine (if r =? r' then _ else []).
    subst.
    unfold outgoing in *.
    refine(lookup E (existT _ d c')).
  Defined.

  Definition forwardHandler (c:Connection) (m:UpdateMessage) (rs:forall r, RIBs r) :
                           dict Connection (list UpdateMessage) * (forall r, RIBs r).
    destruct c as [sr c].
    destruct sr as [s r].
    exact (routerHandler r (received r [s & c]) m rs).
  Defined.

  Definition generateHandler (r:Router) (m:UpdateMessage) (rs:forall r, RIBs r) :
                             dict Connection (list UpdateMessage) * (forall r, RIBs r).
    exact (routerHandler r (injected r) m rs).
  Defined.

  (* TODO combine commonalities between the two *)
  Inductive transition : NetworkState -> NetworkState -> Type :=
  | generate m r rs ls : originate' r (nlri m) (attributes m) = true ->
      let Ers' := generateHandler r m rs in   (* Coq is weird and disallows: let ' (E, rs') := ... *)
      let E := fst Ers' in
      let rs' := snd Ers' in
      transition
        {| routerState := rs;  linkState := ls |}
        {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c) |}
  | forward m c rs ls :
      let Ers' := forwardHandler c m rs in   (* Coq is weird and disallows: let ' (E, rs') := ... *)
      let E := fst Ers' in
      let rs' := snd Ers' in
      transition
        {| routerState := rs;  linkState := update' ls c (fun ms => m::ms) |}
        {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c) |}.

  Definition emptyRIB {A} : dict A RoutingInformation := build (const notAvailable).

  Definition emptyNetworkState := {|
    routerState := build (fun _ => {|
        adjRIBsIn  := emptyRIB;
        locRIB     := emptyRIB;
        adjRIBsOut := emptyRIB
      |});
    linkState := build (fun _ => [])
  |}.

  Inductive star {S} {s0:S} {t:S->S->Type} : S -> Type :=
  | init : star s0
  | step {s s'} : star s -> t s s' -> star s'.

  Definition reachable := star (s0 := emptyNetworkState) (t := @transition).

End BGP.

Arguments adjRIBsIn {_ _ _ _} _ _.
Arguments locRIB {_ _ _ _} _ _.
Arguments adjRIBsOut {_ _ _ _} _ _.
Arguments available {_} _.
Arguments notAvailable {_}.
Arguments received {_ _} _.
Arguments injected {_ _}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.X25519.C64.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Coq.Lists.List.

Require Import Axioms.
Require Import Tactics.
Require Import Sequence.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.

Fixpoint ctxpred {object} (G : @context object) {struct G} : hpred
  :=
  match G with
  | nil => clo
  | cons h G' => permit (ctxpred G')
  end.

Lemma promote_ctxpred :
  forall object (G : @context object), hincl (ctxpred G) (ctxpred (promote G)).
Proof.
intros object G.
induct G; cbn; auto using clo_min.
intros h G IH.
apply permit_compat; auto.
Qed.

Lemma ctxpred_length :
  forall object (G : @context object), ctxpred G = (fun i => i < length G).
Proof.
intros object G.
fextensionality 1.
intro i.
apply propositional_extensionality.
revert i.
induct G.

(* nil *)
{
intros.
split; intro H; [destruct H | cbn in H; omega].
}

(* cons *)
{
intros h G IH i.
cbn.
split.
  {
  intro H.
  destruct i as [| i].
    {
    omega.
    }
  cut (i < length G).
    {
    omega.
    }
  apply IH.
  exact H.
  }

  {
  intros H.
  destruct i as [| i].
    {
    cbn; auto.
    }
  apply IH.
  omega.
  }
}
Qed.

Lemma project_closub :
  forall object (G : @context object) s i,
    closub (ctxpred G) s
    -> ctxpred G i
    -> @hygiene object clo (project s i).
Proof.
intros object G s i Hcls H.
replace (project s i) with (subst s (var i)) by (simpsub; reflexivity).
eapply subst_closub; eauto using hygiene_var.
Qed.

Inductive hygieneh {object} P : @hyp object -> Prop :=
| hygieneh_tpl :
    hygieneh P hyp_tpl

| hygieneh_tp :
    hygieneh P hyp_tp

| hygieneh_tml :
    forall a,
      hygiene P a
      -> hygieneh P (hyp_tml a)

| hygieneh_tm :
    forall a,
      hygiene P a
      -> hygieneh P (hyp_tm a)

| hygieneh_emp :
    hygieneh P hyp_emp
.

Inductive cloctx {object} : @context object -> Prop :=
| cloctx_nil :
    cloctx nil

| cloctx_cons :
    forall h G,
      cloctx G
      -> hygieneh (ctxpred G) h
      -> cloctx (cons h G)
.

Lemma hygieneh_promote :
  forall object P (h : @hyp object),
    hygieneh P h <-> hygieneh P (promote_hyp h).
Proof.
intros object P h.
cases h; cbn; try reflexivity; split; eauto using hygieneh_tpl, hygieneh_tp.
  {
  intro H.
  invertc H.
  intro H.
  apply hygieneh_tm; auto.
  }

  {
  intro H.
  invertc H.
  intro H.
  apply hygieneh_tml; auto.
  }
Qed.

Lemma cloctx_promote :
  forall object (G : @context object),
    cloctx G <-> cloctx (promote G).
Proof.
intros object G.
split.
  {
  intro H.
  induct H; eauto using cloctx_nil.
  intros h G _ IH Hcl.
  cbn.
  apply cloctx_cons; auto.
  rewrite <- hygieneh_promote.
  rewrite -> ctxpred_length in Hcl |- *.
  rewrite -> List.map_length.
  exact Hcl.
  }

  {
  induct G; auto.
  (* cons *)
  intros h G IH Hcl.
  cbn in Hcl.
  invertc Hcl.
  intros HclG Hcl.
  apply cloctx_cons; auto.
  rewrite <- hygieneh_promote in Hcl.
  rewrite -> ctxpred_length in Hcl |- *.
  rewrite -> List.map_length in Hcl.
  exact Hcl.
  }
Qed.

Lemma hincl_promote_adjust :
  forall object (G : @context object),
    hincl (ctxpred (promote G)) (ctxpred G).
Proof.
intros object G.
induct G.

(* nil *)
{
cbn.
intros i H; destruct H.
}

(* cons *)
{
intros h G IH i H.
cbn.
destruct i as [| i].
  {
  cbn.
  trivial.
  }

  {
  cbn in H |- *.
  apply IH; auto.
  }
}
Qed.

Lemma closub_promote :
  forall object (G : @context object) (s : @sub object),
    closub (ctxpred G) s
    -> closub (ctxpred (promote G)) s.
Proof.
intros object G s Hcl.
intros i H.
apply (Hcl i).
eapply hincl_promote_adjust; eauto.
Qed.

Lemma hygiene_promote :
  forall object (G : @context object) (m : @term object),
    hygiene (ctxpred G) m
    -> hygiene (ctxpred (promote G)) m.
Proof.
intros object G m Hhyg.
refine (hygiene_weaken _#4 _ Hhyg).
clear Hhyg m.
induct G.

(* nil *)
{
intros i H.
cbn in H.
destruct H.
}

(* cons *)
{
intros h G IH i Hadj.
destruct i as [| i].
  {
  destruct h; auto.
  }
cbn in Hadj |- *.
apply IH; auto.
}
Qed.

Lemma hygieneh_weaken :
  forall object P Q (h : @hyp object),
    hincl P Q
    -> hygieneh P h
    -> hygieneh Q h.
Proof.
intros object P Q h Hincl Hh.
induct Hh; intros;
[apply hygieneh_tpl | apply hygieneh_tp | apply hygieneh_tml | apply hygieneh_tm | apply hygieneh_emp];
eapply hygiene_weaken; eauto.
Qed.

Lemma hygieneh_subst :
  forall object P Q (s : @sub object) h,
    hygieneh P h
    -> (forall i, P i -> hygiene Q (project s i))
    -> hygieneh Q (substh s h).
Proof.
intros object P Q s h Hh Hs.
induct Hh; intros; simpsub;
[apply hygieneh_tpl | apply hygieneh_tp | apply hygieneh_tml | apply hygieneh_tm | apply hygieneh_emp];
eapply hygiene_subst; eauto.
Qed.

Lemma substh_closub :
  forall object P s (h : @hyp object),
    closub P s
    -> hygieneh P h
    -> hygieneh clo (substh s h).
Proof.
intros object P s m Hs Hm.
refine (hygieneh_subst _#5 Hm _).
intros i Hie.
apply (hygiene_weaken _ clo); auto using clo_min.
Qed.

Lemma hygieneh_subst_invert :
  forall object P (s : @sub object) h,
    hygieneh P (substh s h)
    -> hygieneh (fun j => hygiene P (project s j)) h.
Proof.
intros object P s h.
cases h; eauto using hygieneh_tpl, hygieneh_tp, hygieneh_emp.

(* tml *)
{
intros a H.
invertc H.
intros Hhyg.
so (hygiene_subst_invert _#4 Hhyg) as Hhyg'.
apply hygieneh_tml; auto.
}

(* tm *)
{
intros a H.
invertc H.
intros Hhyg.
so (hygiene_subst_invert _#4 Hhyg) as Hhyg'.
apply hygieneh_tm; auto.
}
Qed.

Lemma hygieneh_shift' :
  forall object P i (h : @hyp object),
    hygieneh (fun j => P (i + j)) h
    -> hygieneh P (substh (sh i) h).
Proof.
intros object P i h H.
induct H; intros;
[apply hygieneh_tpl | apply hygieneh_tp | apply hygieneh_tml | apply hygieneh_tm | apply hygieneh_emp];
eapply hygiene_shift'; eauto.
Qed.

Lemma cloctx_tail :
  forall object (G1 G2 : @context object),
    cloctx (G2 ++ G1) -> cloctx G1.
Proof.
intros object G1 G2.
induct G2; auto.
(* cons *)
intros h G2 IH H.
cbn in H.
invertc H.
auto.
Qed.

Lemma hygieneh_unshift :
  forall object P i (h : @hyp object),
    hygieneh P (substh (sh i) h)
    -> hygieneh (fun j => P (i + j)) h.
Proof.
intros object P i h Hhyg.
revert Hhyg.
cases h; intros; invertc Hhyg; intros; eauto using hygieneh_tpl, hygieneh_tp, hygieneh_tml, hygieneh_tm, hygieneh_emp, hygiene_unshift.
Qed.

Lemma hygieneh_shift_permit_iff :
  forall object P (h : @hyp object),
    hygieneh P h <-> hygieneh (permit P) (substh sh1 h).
Proof.
intros object P h.
split.
  {
  intro Hhyg.
  apply hygieneh_shift'.
  refine (hygieneh_weaken _#4 _ Hhyg).
  intros j H.
  cbn; auto.
  }

  {
  intro Hhyg.
  so (hygieneh_unshift _#4 Hhyg) as Hhyg'.
  cbn in Hhyg'.
  refine (hygieneh_weaken _#4 _ Hhyg').
  intro; intros; eauto.
  }
Qed.

Inductive hygienectx {object} (P : nat -> Prop) : @context object -> Prop :=
| hygienectx_nil :
    hygienectx P nil

| hygienectx_cons :
    forall h G,
      hygienectx P G
      -> hygieneh (fun i => i < length G \/ (i >= length G /\ P (i - length G))) h
      -> hygienectx P (cons h G)
.

Lemma cloctx_is_hygienectx :
  forall object (G : @context object),
    cloctx G <-> hygienectx clo G.
Proof.
intros object G.
split.
  {
  intro HclG.
  induct HclG; auto using hygienectx_nil.
  (* cons *)
  intros h G _ IH Hclh.
  apply hygienectx_cons; auto.
  eapply hygieneh_weaken; eauto.
  intros i Hi.
  rewrite -> ctxpred_length in Hi.
  left; auto.
  }

  {
  intro HclG.
  induct HclG; auto using cloctx_nil.
  intros h G _ IH Hh.
  apply cloctx_cons; auto.
  eapply hygieneh_weaken; eauto.
  intros i Hi.
  rewrite -> ctxpred_length.
  destruct Hi as [| (_ & H)]; auto.
  destruct H.
  }
Qed.

Lemma hygienectx_app :
  forall object P (G1 G2 : @context object),
    hygienectx P G1
    -> hygienectx (fun i => i < length G1 \/ (i >= length G1 /\ P (i - length G1))) G2
    -> hygienectx P (G2 ++ G1).
Proof.
intros object P G1 G2 HG1 HG2.
induct HG2; auto using hygienectx_nil.
intros h G _ IH Hh.
cbn.
apply hygienectx_cons; auto.
eapply hygieneh_weaken; eauto.
intros i Hi.
rewrite -> app_length.
destruct Hi as [Hi | Hi].
  {
  left.
  omega.
  }
destruct Hi as (Himin & [Hi | Hi]).
  {
  left.
  omega.
  }
destruct Hi as (Himin' & Hi).
right.
split.
  {
  omega.
  }
force_exact Hi.
f_equal.
omega.
Qed.

Lemma hygienectx_app_invert :
  forall object P (G1 G2 : @context object),
    hygienectx P (G2 ++ G1)
    -> hygienectx P G1
      /\ hygienectx (fun i => i < length G1 \/ (i >= length G1 /\ P (i - length G1))) G2.
Proof.
intros object P G1 G2.
induct G2.

(* nil *)
{
intros H.
split; auto.
apply hygienectx_nil.
}

(* cons *)
{
intros h G2 IH H.
cbn in H.
invertc H.
intros HG12 Hh.
so (IH HG12) as (HG1 & HG2).
split; auto.
apply hygienectx_cons; auto.
eapply hygieneh_weaken; eauto.
intros i Hi.
rewrite -> app_length in Hi.
destruct Hi as [Hi | Hi].
  {
  so (lt_dec i (length G2)) as [Hlt | Hnlt].
    {
    left; auto.
    }
  right.
  split; [omega |].
  left.
  omega.
  }

  {
  destruct Hi as (Himin & Hi).
  right.
  split; [omega |].
  right.
  split; [omega |].
  force_exact Hi.
  f_equal.
  omega.
  }
}
Qed.

Lemma hygienectx_subst :
  forall object (P Q : hpred) s (G : @context object),
    hygienectx P G
    -> (forall i, P i -> hygiene Q (project s i))
    -> hygienectx Q (substctx s G).
Proof.
intros object P Q s G HG HP.
induct HG; cbn; auto using hygienectx_nil.
(* cons *)
intros h G _ IH Hh.
apply hygienectx_cons; auto.
clear IH.
eapply hygieneh_subst; eauto.
clear Hh.
intros i Hi.
cbn in Hi.
destruct Hi as [Hi | (Himin & Hi)].
  {
  rewrite -> project_under_lt; auto.
  apply hygiene_var.
  rewrite -> length_substctx.
  left; auto.
  }
rewrite -> project_under_geq; auto.
apply hygiene_shift'.
so (HP _ Hi) as Hproj.
eapply hygiene_weaken; eauto.
clear i Himin Hi Hproj.
intros j Hj.
rewrite -> length_substctx.
right.
split.
  {
  omega.
  }

  {
  force_exact Hj.
  f_equal.
  omega.
  }
Qed.


From iris.algebra Require Import auth updates local_updates.
From iris.proofmode Require Import tactics.
From iris.bi.lib Require Import fractional.
From iris.prelude Require Import options.

(** XXX: TODO, upsteam, although this proof is a mess *)
Lemma auth_frac_update {A: ucmra} q (a b b': A) :
  (a,b) ~l~> (a,b') → ●{q} a ⋅ ◯ b ~~> ●{q} a ⋅ ◯ b'.
Proof.
  intros Hup; apply cmra_total_update.
  move=> n [[[? b0]|] bf1] [/= VL [a0 [Eq [[bf2 Ha] VL2]]]]; do 2 red; simpl in *.
  + split; auto.
    assert (✓{n} to_agree a0).
    { econstructor. }
    assert (✓{n} b0) as Hb0val.
    { eapply cmra_validN_includedN; last first.
      { econstructor. rewrite comm. by symmetry. }
      eauto. }
    apply to_agree_uninjN in Hb0val as (a1&Heqa1).
    assert (a ≡{n}≡ a0) as Heqa.
    {
      apply to_agree_injN. eapply agree_valid_includedN.
      - econstructor.
      - econstructor; by symmetry.
    }
    assert (a1 ≡{n}≡ a0) as Heqa1'.
    {
      apply to_agree_injN. eapply agree_valid_includedN.
      - econstructor.
      - econstructor. rewrite Heqa1 comm. by symmetry.
    }
    move: Ha; rewrite !left_id -assoc => Ha.
    destruct (Hup n (Some (bf1 ⋅ bf2))); simpl.
    { by rewrite Heqa. }
    { simpl. by rewrite Heqa. }
    simpl in H1.
    exists a0. rewrite -Heqa1 Heqa1'.
    eexists; split_and!; eauto.
    * intros ? Hin.
      inversion Hin; subst; eexists; split_and!; first econstructor; eauto.
    * intros ? Hin. inversion Hin; subst.
      ** exists a0; split; auto. repeat econstructor.
      ** inversion H4.
    * rewrite -Heqa H1. simpl.
      rewrite left_id assoc. econstructor; eauto.
  + split; [done|]. apply to_agree_injN in Eq.
    move: Ha; rewrite !left_id -assoc => Ha.
    destruct (Hup n (Some (bf1 ⋅ bf2))); [by rewrite Eq..|]. simpl in *.
    exists a. split; [done|]. split; [|done]. exists bf2.
    by rewrite left_id -assoc.
Qed.

Lemma auth_frac_update_alloc {A: ucmra} (dq: dfrac) (a b': A):
  (a, ε) ~l~> (a,b') → (●{dq} a ~~> ●{dq} a ⋅ ◯ b').
Proof. intros. rewrite -{1}(right_id _ _ (●{dq} a)). by eapply auth_frac_update in H. Qed.

Lemma auth_frac_update_core_id {A: ucmra} dq (a b: A) `{!CoreId b} :
  b ≼ a → ●{dq} a ~~> ●{dq} a ⋅ ◯ b.
Proof.
  intros Hincl. apply: auth_frac_update_alloc.
  rewrite -(left_id ε _ b). apply: core_id_local_update. done.
Qed.


(* En este archivo se demuestra que la ejecución de
*  la acción startActivity preserva los invariantes del sistema *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import MyList.
Require Import ListAuxFuns.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.
Require Import Semantica.

Section StartActivityInv.

Lemma StartActivityIsInvariant : forall (s s':System) (sValid:validstate s) (intt:Intent) (ic:iCmp), pre_startActivity intt ic s -> post_startActivity intt ic s s' -> validstate s'.
Proof.
    intro.
    intro.
    intro.
    intro.
    intro.
    intro preS.
    intro.
    unfold validstate.
    unfold post_startActivity in H.
    destruct H.
    unfold onlyIntentsChanged in H0.
    destruct_conj H0.
    assert (verified:= H9). clear H9.
    assert (H8 := H7). clear H7.

    unfold allCmpDifferent.
    split.
    intros.

    apply (inAppS'InAppS a1 s) in H7;auto.
    apply (inAppS'InAppS a2 s) in H9;auto.
    apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.

    unfold notRepeatedCmps.
    split.
    intros.
    apply (inAppS'InAppS a1 s) in H7;auto.
    apply (inAppS'InAppS a2 s) in H9;auto.
    apply (inAppSameCmp s sValid c a1 a2);auto.

    unfold notCPrunning.
    split.
    rewrite <-H4.
    destructVS sValid.
    auto.

    split.
    apply (delTmpRunS' s);auto.

    split.
    apply (cmpRunAppInsS' s);auto.

    split.
    apply (resContAppInstS' s);auto.

    split.
    apply (consistencyUnchanged s);auto.

    unfold notDupApp.
    split.
    rewrite <- H0.
    rewrite<-H1.
    destructVS sValid.
    auto.

    unfold notDupSysApp.
    split.
    rewrite <-H1.
    destructVS sValid.
    auto.

    split.
    apply (notDupPermS' s);auto.

    unfold allMapsCorrect.
    split.
    rewrite <-H2, <-H3, <-H4, <- H5, <-H6, <-H8, <-H1.
    repeat (split;auto; try mapcorrect sValid).

    split.
    apply (grantedPermsExistS' s);auto.

    unfold noDupSentIntents.
    intros.
    destruct preS.
    destruct_conj H12.
    unfold addIntent in H.
    destruct_conj H.
    assert (H':=H).
    specialize (H' i ic0 H7).
    assert (H'':=H).
    specialize (H'' i' ic' H9).
    clear H9 H7 H8 H6 H4 H5 H3 H2 H1 H0.
    destruct H'.
    destruct H''.
    destructVS sValid.
    apply sentIntentsCorrectVS;auto.
    destruct H1.
    destruct H15.
    exists i, ic0.
    split;auto.
    rewrite H10.
    unfold createIntent in H2.
    rewrite H2.
    simpl.
    auto.

    destruct H''.
    destruct H0.
    destruct H15.
    exists i', ic'.
    split;auto.
    rewrite<- H10.
    unfold createIntent in H2.
    rewrite H2.
    simpl.
    auto.
    destruct H0, H1.
    split.
    rewrite<- H0;auto.
    rewrite H3;auto.
Qed.

End StartActivityInv.


(*|
################################################
Function- and Type substitutions or Views in Coq
################################################

:Link: https://stackoverflow.com/q/29870487
|*)

(*|
Question
********

I proved some theorems about lists, and extracted algorithms from
them. Now I want to use heaps instead, because lookup and
concatenation are faster. What I currently do to achieve this is to
just use custom definitions for the extracted list type. I would like
to do this in a more formal way, but ideally without having to redo
all of my proofs. Lets say I have a type

.. code-block:: coq

    Heap : Set -> Set

and an isomorphism

.. code-block:: coq

    f : forall A, Heap A -> List A.

Furthermore, I have functions ``H_app`` and ``H_nth``, such that

.. code-block:: coq

    H_app (f a) (f b) = f (a ++ b)

and

.. code-block:: coq

    H_nth (f a) = nth a

On the one hand, I would have to replace every list-recursion by a
specialized function that mimics list recursion. On the other hand,
beforehand I would want to replace ``++`` and ``nth`` by ``H_app`` and
``H_nth``, so the extracted algorithms would be faster. The problem is
that I use tactics like ``simpl`` and ``compute`` in some places,
which will probably fail if I just replace everything in the proof
code. It would be good to have a possibility to "overload" the
functions afterwards.

Is something like this possible?

Edit: To clarify, a similar problem arises with numbers: I have some
old proofs that use ``nat``, but the numbers are getting too large.
Using ``BinNat`` would be better, but is it possible to use ``BinNat``
instead of ``nat`` also in the old proofs without too much
modification? (And especially, replace inefficient usages of ``+`` by
the more efficient definition for ``BinNat``?)
|*)

(*|
Answer
******

Just for the sake of clarity, I take it that ``Heap`` must look like
this:

.. coq:: none
|*)

Set Implicit Arguments.

Require Import List.
Import ListNotations.

(*||*)

Inductive Heap A : Type :=
| Node : Heap A -> A -> Heap A -> Heap A
| Leaf : Heap A.

(*| with ``f`` being defined as |*)

Fixpoint f A (h : Heap A) : list A :=
  match h with
  | Node h1 a h2 => f h1 ++ a :: f h2
  | Leaf _ => []
  end.

(*|
If this is the case, then ``f`` does *not* define an isomorphism
between ``Heap A`` and ``list A`` for all ``A``. Instead, we can find
a function ``g : forall A, list A -> Heap A`` such that

.. code-block:: coq

    forall A (l : list A), f (g l) = l

Nevertheless, we would like to say that both ``Heap`` and ``list`` are
equivalent in some sense when they are used to implement the same
abstraction, namely sets of elements of some type.

There is a precise and formal way in which we can validate this idea
in languages that have `parametric polymorphism
<http://en.wikipedia.org/wiki/Parametric_polymorphism>`__, such as
Coq. This principle, known as `parametricity
<http://en.wikipedia.org/wiki/Parametricity>`__, roughly says that
parametrically polymorphic functions respect relations that we impose
on types we instantiate them with.

This is a little bit abstract, so let's try to make it more concrete.
Suppose that you have a function over lists (say, ``foo``) that uses
only ``++`` and ``nth``. To be able to replace ``foo`` by an
equivalent version on ``Heap`` using parametricity, we need to make
``foo``'s definition polymorphic, abstracting over the functions over
lists:
|*)

Definition foo (T : Set -> Set)
           (app : forall A, T A -> T A -> T A)
           (nth : forall A, T A -> nat -> option A)
           A (l : T A) : T A.
  (* ... *)
Admitted. (* .none *)

(*|
You would first prove properties of foo by instantiating it over lists:

.. code-block:: coq

    Definition list_foo := foo list app nth_error.

    Lemma list_foo_lemma : (* Some statement *).

Now, because we now that ``H_app`` and ``H_nth`` are compatible with
their list counterparts, and because ``foo`` is polymorphic, the
theory of parametricity says that we can prove

.. code-block:: coq

    Definition H_foo := foo Heap H_app H_nth.

    Lemma foo_param : forall A (h : Heap A),
        f (H_foo h) = list_foo (f h).

with this lemma in hand, it should be possible to transport properties
of ``list_foo`` to similar properties of ``H_foo``. For instance, as a
trivial example, we can show that ``H_app`` is associative, up to
conversion to a list:

.. code-block:: coq

    forall A (h1 h2 h3 : Heap A),
      list_foo (H_app h1 (H_app h2 h3)) =
        list_foo (H_app (H_app h1 h2) h3).

What's nice about parametricity is that it applies to *any*
parametrically polymorphic function: as long as appropriate
compatibility conditions hold of your types, it should be possible to
relate two instantiations of a given function in a similar fashion to
``foo_param``.

There are two problems, however. The first one is having to change
your base definitions to polymorphic ones, which is probably not so
bad. What's worse, though, is that even though parametricity ensures
that it is always possible to prove lemmas such as ``foo_param`` under
certain conditions, Coq does not give you that for free, and you still
need to show these lemmas by hand. There are two things that could
help alleviate your pain:

1. There's a `parametricity plugin
   <https://github.com/mlasson/paramcoq>`__ for Coq (CoqParam) which
   should help deriving the boilerplate proofs for you automatically.
   I have never used it, though, so I can't really say how easy it is
   to use.

2. The Coq Effective Algebra Library (or `CoqEAL
   <https://github.com/CoqEAL/CoqEAL>`__, for short) uses
   parametricity to prove things about efficient algorithms while
   reasoning over more convenient ones. In particular, they define
   refinements that allow one to switch between ``nat`` and
   ``BinNat``, as you suggested. Internally, they use an
   infrastructure based on type-class inference, which you could adapt
   to your original example, but I heard that they are currently
   migrating their implementation to use CoqParam instead.
|*)


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation DeclarativeInstance.
From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity Reduction.

Set Universe Polymorphism.

Section Normalization.
Context `{GenericTypingProperties}.

Set Printing Primitive Projection Parameters.

Program Definition normRedΠ0 {Γ F G l} (h : [Γ ||-Π<l> tProd F G])
  : [Γ ||-Π<l> tProd F G] :=
  {| PiRedTyPack.dom := F ;
     PiRedTyPack.cod := G |}.
Solve All Obligations with
  intros;
  assert (wΠ : whnf (tProd F G)) by constructor;
  pose proof (e := redtywf_whnf (PiRedTyPack.red h) wΠ);
  symmetry in e; injection e; clear e;
  destruct h as [?????? domRed codRed codExt] ;
  intros; cbn in *; subst; eassumption + now eapply domRed +
  (unshelve eapply codRed ; tea ; irrelevance)
  + ( irrelevance0; [reflexivity| unshelve eapply codExt; tea]; irrelevance).

Definition normRedΠ {Γ F G l} (h : [Γ ||-<l> tProd F G])
  : [Γ ||-<l> tProd F G] :=
  LRPi' (normRedΠ0 (invLRΠ h)).

#[program]
Definition normLambda {Γ F F' G t l RΠ}
  (Rlam : [Γ ||-<l> tLambda F' t : tProd F G | normRedΠ RΠ ]) :
  [Γ ||-<l> tLambda F' t : tProd F G | normRedΠ RΠ ] :=
  {| PiRedTm.nf := tLambda F' t |}.
Solve All Obligations with
  intros;
  pose proof (e := redtmwf_whnf (PiRedTm.red Rlam) whnf_tLambda);
  destruct Rlam as [????? app eqq]; cbn in *; subst;
  first [eapply app | now eapply eqq| eassumption].

End Normalization.

(** ** Tactics for normalizing the proof relevant components of a reducible type *)

(* Normalizes a term reducible at a Π type *)

Ltac normRedΠin id X :=
  let g := type of X in
  match g with
  | [ LRAd.pack ?R | _ ||- ?t : _] =>
    pose (id := normRedΠ0 (invLRΠ R));
    let X' := fresh X in
    rename X into X' ;
    assert (X : [_ ||-<_> t : _ | LRPi' id]) by irrelevance; clear X'
  end.

Goal forall `{GenericTypingProperties} Γ A B l R f (Rf : [Γ ||-<l> f : arr A B | R]), True.
Proof.
  intros.
  normRedΠin ΠAB Rf.
  constructor.
Qed.

(* Normalizes a goal reducible at a Π type *)

Ltac normRedΠ id :=
  let G := fresh "G" in
  set (G := _);
  let g := eval unfold G in G in
  match g with
  | [ LRAd.pack ?R | _ ||- ?t : _] =>
    pose (id := normRedΠ0 (invLRΠ R)); subst G;
    enough [_ ||-<_> t : _ | LRPi' id] by irrelevance
  end.


Require Import String.
Require Import ZArith.
Require Import Omega.

Require Export epics.SpecRecords.
Require Export epics.SpecRecordData.
Require Export epics.SpecRecordSetters.
Require Export epics.SpecTypes.

Require Import epics.Types.
Require Import util.EqDec.
Require Import v1.Multi.
Require Import v1.NeutronTactics.

Tactic Notation "destruct_record" constr(r) "as" "[" ident(x) "]" :=
    destruct r as [
        x | x | x | (* acalcout*) ?n x | x |
        x | x | x | x | x |
        x | x | x | x | x |
        x | (* waveform *) ?ty ?n x | (* subArray *) ?ty ?n ?m x | x
    ].

Tactic Notation "destruct_record" constr(r) "as" "[" ident(x) ident(y) "]" :=
    destruct r as [
        x y | x y | x y | (* acalcout*) ?n x y | x y |
        x y | x y | x y | x y | x y |
        x y | x y | x y | x y | x y |
        x y | (* waveform *) ?ty ?n x y | (* subArray *) ?ty ?n ?m x y | x y
    ].

Tactic Notation "destruct_record" constr(r) := destruct_record r as [c s].

Canonical Structure dec_eq_record_type :=
    Build_DecidableEquality record_type_eq_dec.

Definition eq_dec_injective {A B} (f : A -> B)
    (Hinj : forall x y, f x = f y -> x = y)
    (eq_dec : forall (x y : A), { x = y } + { x <> y })
    (x y : A) :
    { f x = f y } + { f x <> f y }.
destruct (eq_dec x y).
- left. congruence.
- right. intro. eauto.
Defined.

Ltac decide_equality_with_epics_types :=
    decide equality; eauto using eq_dec, multi_eq_dec.

Definition record_state_eq_dec (x y : record_state) : { x = y } + { x <> y }.
destruct x.
all: destruct y; try solve [right; discriminate].
all: try (
    eapply eq_dec_injective;
    [ intros; congruence
    | decide_equality_with_epics_types ]
).

- (* ArrayCalcOut *)
  destruct (eq_nat_dec n n0); cycle 1.
    { right. congruence. }
  subst.  eapply eq_dec_injective.
  + intros. inversion H. fix_existT. auto.
  + decide_equality_with_epics_types.

- (* Waveform *)
  destruct (eq_nat_dec n n0); cycle 1.
    { right. congruence. }
  destruct (elem_type_eq_dec ty ty0); cycle 1.
    { right. congruence. }

  subst.  eapply eq_dec_injective.
  + intros. inversion H. fix_existT. auto.
  + decide_equality_with_epics_types.

- (* Subarray *)
  destruct (eq_nat_dec n n0); cycle 1.
    { right. congruence. }
  destruct (eq_nat_dec m m0); cycle 1.
    { right. congruence. }
  destruct (elem_type_eq_dec ty ty0); cycle 1.
    { right. congruence. }

  subst.  eapply eq_dec_injective.
  + intros. inversion H. fix_existT. auto.
  + decide_equality_with_epics_types.
Defined.

Canonical Structure dec_eq_record_state :=
    Build_DecidableEquality record_state_eq_dec.

Definition default_record (rt : record_type) : record_state :=
    match rt with
    | RtCalc => RsCalc (CalcState
            (multi_rep _ d_zero) d_zero)
    | RtCalcOut => RsCalcOut (CalcOutState
            (multi_rep _ d_zero) d_zero d_zero d_zero d_zero)
    | RtStrCalcOut => RsStrCalcOut (StrCalcOutState
            (multi_rep _ d_zero) (multi_rep _ EmptyString)
            d_zero EmptyString d_zero d_zero EmptyString d_zero)
    | RtArrayCalcOut n => RsArrayCalcOut n (ArrayCalcOutState n
            (multi_rep _ d_zero) (multi_rep _ (multi_rep _ d_zero))
            d_zero (multi_rep _ d_zero) d_zero d_zero (multi_rep _ d_zero) d_zero)
    | RtFanout => RsFanout (FanoutState)
    | RtDFanout => RsDFanout (DFanoutState d_zero)
    | RtSeq => RsSeq (SeqState
            (multi_rep _ d_zero) (EEnum 0 ltac:(hide; compute; split; congruence)))
    | RtAnalogIn => RsAnalogIn (AnalogInState d_zero)
    | RtAnalogOut => RsAnalogOut (AnalogOutState d_zero d_zero)
    | RtBinaryIn => RsBinaryIn (BinaryInState
            (EEnum 0 ltac:(hide; compute; split; congruence)))
    | RtBinaryOut => RsBinaryOut (BinaryOutState
            (EEnum 0 ltac:(hide; compute; split; congruence)))
    | RtMBBO => RsMBBO (MBBOState
            (EEnum 0 ltac:(hide; compute; split; congruence)))
    | RtStringIn => RsStringIn (StringInState EmptyString)
    | RtStringOut => RsStringOut (StringOutState EmptyString)
    | RtLongIn => RsLongIn (LongInState l_zero)
    | RtLongOut => RsLongOut (LongOutState l_zero)
    | RtWaveform ty n => RsWaveform ty n (WaveformState ty n
            (default_array ty n))
    | RtSubarray ty n m => RsSubarray ty n m (SubarrayState ty n m
            (default_array ty n) (default_array ty m))
    | RtAsyn => RsAsyn (AsynState)
    end.


Require Import Coq.ZArith.ZArith.
Require Coq.Strings.String.
Require Import coqutil.Map.Interface coqutil.Word.Interface.
Require Import bedrock2.MetricLogging.
Require Import compiler.SeparationLogic.
Require Import compiler.LowerPipeline.
Require Import compiler.Pipeline.

Section Params1.
  Context {width} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: Semantics.ExtSpec}.

  Set Implicit Arguments.

  Record ProgramSpec: Type := {
    datamem_start: word;
    datamem_pastend: word;
    (* trace invariant which holds at the beginning (and end) of each loop iteration,
       but might not hold in the middle of the loop because more needs to be appended *)
    goodTrace: Semantics.trace -> Prop;
    (* state invariant which holds at the beginning (and end) of each loop iteration *)
    isReady: Semantics.trace -> mem -> Prop;
  }.

  Definition hl_inv(spec: ProgramSpec)(t: Semantics.trace)(m: mem)
             (l: locals)(mc: bedrock2.MetricLogging.MetricLog)
    : Prop := (* Restriction: no locals can be shared between loop iterations *)
    spec.(isReady) t m /\ spec.(goodTrace) t.

  Local Set Warnings "-cannot-define-projection".

  Record ProgramSatisfiesSpec(init_f loop_f: String.string)
         (e: list (String.string * (list String.string * list String.string * Syntax.cmd)))
         (spec: ProgramSpec): Prop :=
  {
    funs_valid: valid_src_funs e = true;
    init_code: Syntax.cmd.cmd;
    get_init_code: map.get (map.of_list e) init_f = Some (nil, nil, init_code);
    init_code_correct: forall m0 mc0,
        mem_available spec.(datamem_start) spec.(datamem_pastend) m0 ->
        Semantics.exec (map.of_list e) init_code nil m0 map.empty mc0 (hl_inv spec);
    loop_body: Syntax.cmd.cmd;
    get_loop_body: map.get (map.of_list e) loop_f = Some (nil, nil, loop_body);
    loop_body_correct: forall t m l mc,
        hl_inv spec t m l mc ->
        Semantics.exec (map.of_list e) loop_body t m l mc (hl_inv spec);
  }.

End Params1.