Require Import
        Coq.Vectors.Vector
        Coq.omega.Omega
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Bool.Bool
        Coq.Vectors.VectorDef
        Coq.Lists.List.

Require Import
        Fiat.Common.BoundedLookup
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

Require Import
        Bedrock.Word
        Bedrock.Memory.

Import Lists.List.ListNotations.
Import Vectors.VectorDef.VectorNotations.

Local Open Scope string_scope.
Local Open Scope Tuple_scope.
Local Open Scope vector_scope.

Require Export Fiat.Narcissus.Examples.DNS.SimpleRRecordTypes.

Section QTypes.

  (* DNS packet Query Types are a superset of RR Types. *)
  Definition QTypes :=
    ["TKEY"; (* Transaction Key 	[RFC2930] *)
     "TSIG"; (* Transaction Signature 	[RFC2845] *)
     "IXFR"; (* incremental transfer 	[RFC1995] *)
     "AXFR"; (* transfer of an entire zone 	[RFC1035][RFC5936] *)
     "MAILB"; (* mailbox-related RRs (MB, MG or MR) 	[RFC1035] *)
     "MAILA"; (* mail agent RRs (OBSOLETE - see MX) 	[RFC1035] *)
     "STAR" (*A request for all records the server/cache has available 	[RFC1035][RFC6895] *)
    ].

  Definition QType_Ws : t (word 16) 11 :=
    Eval simpl in RRecordType_Ws ++ Vector.map (natToWord 16)
                             [249; (*"TKEY" *)
                                250; (*"TSIG" *)
                                251; (*"IXFR" *)
                                252; (*"AXFR" *)
                                253;(*"MAILB" *)
                                254;(*"MAILA" *)
                                255 (* "STAR" *)].

  Definition QType := EnumType ((OurRRecordTypes(* ++ ExtraRRecordTypes) *) ++ QTypes)).

  Definition QType_inj (rr : RRecordType) : QType :=
    Fin.L _ rr.

  Definition beq_QType (a b : QType) : bool :=
    fin_beq a b.

  Definition QType_dec (a b : QType) :=
    fin_eq_dec a b.

  Lemma beq_QType_sym :
    forall rrT rrT', beq_QType rrT rrT' = beq_QType rrT' rrT.
  Proof.
    intros; eapply fin_beq_sym.
  Qed.

  Coercion QType_inj : RRecordType >-> QType.

  Definition QType_match (rtype : RRecordType) (qtype : QType) :=
    qtype = ```"STAR" \/ qtype = rtype.

End QTypes.

Section RRecordClass.

  Definition RRecordClasses :=
    [ "Internet"; (* (IN) 	[RFC1035] *)
        "Chaos"; (* (CH) 	[D. Moon, "Chaosnet", A.I. Memo 628, Massachusetts Institute of Technology Artificial Intelligence Laboratory, June 1981.] *)
        "Hesiod" (* (HS) 	[Dyer, S., and F. Hsu, "Hesiod", Project Athena Technical Plan - Name Service, April 1987.] *)
    ].

  Definition RRecordClass_Ws : t (word 16) 3 :=
    Eval simpl in Vector.map (natToWord 16)
                             [1; (* "IN" *)
                                3; (* "CH" *)
                                4 (* "Hesiod" *)].

  Definition RRecordClass := EnumType RRecordClasses.

  Definition beq_RRecordClass (a b : RRecordClass) : bool
    := fin_beq a b.

  Definition RRecordClass_dec (a b : RRecordClass) :=
    fin_eq_dec a b.

  (* DNS Packet Question Classes *)
  Definition QClass := EnumType (RRecordClasses ++ ["Any"]).

  Definition QClass_Ws : t (word 16) 4 :=
    Eval simpl in Vector.append
                    RRecordClass_Ws
                    [natToWord 16 255 (* "Any"*)].

  Definition QClass_inj (qclass : RRecordClass) : QClass :=
    Fin.L _ qclass.

  Definition beq_QClass (a b : QClass) : bool
    := fin_beq a b.

  Definition QClass_dec (a b : QClass) :=
    fin_eq_dec a b.

End RRecordClass.

Section ResponseCode.

    Definition ResponseCodes :=
    ["NoError";  (* No Error [RFC1035] *)
       "FormErr";  (* Format Error [RFC1035] *)
       "ServFail"; (* Server Failure [RFC1035] *)
       "NXDomain"; (* Non-Existent  Domain 	[RFC1035] *)
       "NotImp";   (* Not Implemented [RFC1035] *)
       "Refused";  (* Query Refused [RFC1035] *)
       "YXDomain"; (* Name Exists when it should not [RFC2136][RFC6672] *)
       "YXRRSet";  (* RR Set Exists when it should not 	[RFC2136] *)
       "NXRRSet";  (* RR Set that should exist does not 	[RFC2136] *)
       "NotAuth";  (* Server Not Authoritative for zone 	[RFC2136] *)
                   (* and Not Authorized [RFC2845] *)
       "NotZone" 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition RCODE_Ws : t (word 4) 11 :=
    Eval simpl in Vector.map (natToWord 4)
    [0;  (* No Error [RFC1035] *)
     1;  (* Format Error [RFC1035] *)
     2; (* Server Failure [RFC1035] *)
     3; (* Non-Existent  Domain 	[RFC1035] *)
     4;   (* Not Implemented [RFC1035] *)
     5;  (* Query Refused [RFC1035] *)
     6; (* Name Exists when it should not [RFC2136][RFC6672] *)
     7;  (* RR Set Exists when it should not 	[RFC2136] *)
     8;  (* RR Set that should exist does not 	[RFC2136] *)
     9;  (* Server Not Authoritative for zone 	[RFC2136] *)
         (* and Not Authorized [RFC2845] *)
     10 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition ResponseCode := EnumType ResponseCodes.

  Definition beq_ResponseCode (a b : ResponseCode) : bool
    := fin_beq a b.

  Definition ResponseCode_dec (a b : ResponseCode) :=
    fin_eq_dec a b.
End ResponseCode.

Section OpCode.

  Definition OpCodes :=
    ["Query";    (* RFC1035] *)
     "IQuery"; (* Inverse Query  OBSOLETE) [RFC3425] *)
     "Status"; (* [RFC1035] *)
     "Notify"  (* [RFC1996] [RFC2136] *)
    ].

  Definition OpCode := EnumType OpCodes.

  Definition Opcode_Ws : t (word 4) 4 :=
    Eval simpl in Vector.map (natToWord 4)
                             [0;    (* RFC1035] *)
                              1; (* Inverse Query  OBSOLETE) [RFC3425] *)
                              2; (* [RFC1035] *)
                              4  (* [RFC1996] [RFC2136] *)].

  Definition beq_OpCode (a b : OpCode) : bool
    := fin_beq a b.

  Definition OpCode_dec (a b : OpCode) :=
    fin_eq_dec a b.

End OpCode.

Section Packet.

  (* The question section of a DNS packet. *)
  Definition question :=
    @Tuple <
    "qname" :: DomainName,
    "qtype" :: QType,
    "qclass" :: QClass >%Heading.
  (* ["google", "com"] *)

  (* DNS Resource Records. *)
  Definition sRRecords := "ResourceRecords".
  Definition sNAME := "Name".
  Definition sTTL := "TTL".
  Definition sCLASS := "Class".
  Definition sTYPE := "Type".
  Definition sRDATA := "rdata".
  Definition sRLENGTH := "rlength".

  Definition resourceRecordHeading :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDataType>%Heading.

  Definition resourceRecord := @Tuple resourceRecordHeading.

  (* Variant headings for each RDataType *)
  Definition VariantResourceRecordHeading RDATAT :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDATAT >%Heading.

  Definition VariantResourceRecord RDATAT := @Tuple (VariantResourceRecordHeading RDATAT).

  (* Aliases for the Common Record Types *)
  Definition CNAME_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurCNAME].
  Definition A_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurA ].
  Definition NS_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurNS].
  Definition SOA_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurSOA].

  Definition RRecord2VariantResourceRecord
             (rr : resourceRecord)
    : VariantResourceRecord ResourceRecordTypeTypes[@(SumType_index ResourceRecordTypeTypes (rr!sRDATA))] :=
    < sNAME :: rr!sNAME,
      sTTL :: rr!sTTL,
      sCLASS :: rr!sCLASS,
      sRDATA :: SumType_proj _ (rr!sRDATA)>.

  Definition VariantResourceRecord2RRecord
             {idx}
             (vrr : VariantResourceRecord ResourceRecordTypeTypes[@idx])
    : resourceRecord :=
    < sNAME :: vrr!sNAME,
      sTTL :: vrr!sTTL,
      sCLASS :: vrr!sCLASS,
      sRDATA :: inj_SumType _ idx (vrr!sRDATA)>.

  Definition CNAME_Record2RRecord
             (vrr : CNAME_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition A_Record2RRecord
             (vrr : A_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition NS_Record2RRecord
             (vrr : NS_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition SOA_Record2RRecord
             (vrr : SOA_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.

  (* Binary Format of DNS Header:
                              1  1  1  1  1  1
0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                      ID                       |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    QDCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ANCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    NSCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ARCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
   *)

  (* DNS Packet Layout:
+---------------------+
|        Header       |
+---------------------+
|       Question      |
+---------------------+
|        Answer       |
+---------------------+
|      Authority      |
+---------------------+
|      Additional     |
+---------------------+
   *)

(* Unique Request IDs *)
Definition ID : Type := word 16.

  Definition packetHeading :=
    < "id" :: ID, (* 16 bit Word. *)
      "QR" :: bool, (* is packet a query (0), or a response (1) *)
      "Opcode" :: OpCode, (* kind of query in packet *)
      "AA" :: bool, (* is responding server authorative *)
      "TC" :: bool, (* is packet truncated *)
      "RD" :: bool, (* are recursive queries desired *)
      "RA" :: bool, (* are recursive queries supported by responding server *)
      "RCODE" :: ResponseCode, (* response code *)
      "question" :: question, (* `list question` in case we can have multiple questions? *)
      "answers" :: list resourceRecord,
      "authority" :: list resourceRecord,
      "additional" :: list resourceRecord >%Heading.

  Definition packet := @Tuple packetHeading.

  Definition buildempty (is_authority : bool)
             (rcode : BoundedIndex ResponseCodes)
             (p : packet) :=
    p ○ [ "AA" ::= is_authority; (* Update Authority field *)
          "QR" ::= true; (* Set response flag to true *)
          "RCODE" ::= ibound (indexb rcode);
          "answers" ::= nil;
          "authority"  ::= nil;
          "additional" ::= nil ].

  (* add a resource record to a packet's answers *)
  Definition add_answer (p : packet) (t : resourceRecord) :=
    p ○ [o !! "answers" / t :: o].

  (* add a resource record authority to a packet's authorities
   (ns = name server). *)
  Definition add_ns (p : packet) (t : resourceRecord) :=
    p ○ [o !! "authority" / t :: o].

  (* combine with above? *)
  Definition add_additional (p : packet) (t : resourceRecord) :=
    p ○ [o !! "additional" / t :: o].

  Definition updateRecords (p : packet) answers' authority' additional' :=
    p ○ ["answers" ::= answers';
           "authority" ::= authority';
           "additional" ::= additional'].

  Definition get_name (r : resourceRecord) := r!sNAME.
  Definition name_length (r : resourceRecord) := String.length (get_name r).

  Definition isQuestion (p : packet) :=
    match p!"answers", p!"authority", p!"additional" with
    | nil, nil, nil => true
    | _, _, _ => false
    end.

  Definition is_empty {A} (l : list A) : bool :=
    match l with
    | nil => true
    | _ => false
    end.

  Lemma is_empty_app {A} :
    forall (l l' : list A),
      is_empty (l ++ l') = andb (is_empty l) (is_empty l').
  Proof.
    induction l; simpl; eauto.
  Qed.

  Definition isAnswer (p : packet) := negb (is_empty (p!"answers")).

  Definition isReferral (p : packet) :=
    is_empty (p!"answers")
             && (negb (is_empty (p!"authority")))
             && (negb (is_empty (p!"additional"))).

  Definition add_answers := List.fold_left add_answer.
  Definition add_nses := List.fold_left add_ns.
  Definition add_additionals := List.fold_left add_additional.

End Packet.

Coercion CNAME_Record2RRecord : CNAME_Record >-> resourceRecord.
Coercion A_Record2RRecord : A_Record >-> resourceRecord.
Coercion NS_Record2RRecord : NS_Record >-> resourceRecord.
Coercion SOA_Record2RRecord : SOA_Record >-> resourceRecord.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module WorldGetters.
Section WorldGetters.

(* It's okay to have duplicating nodes in this list *)

(* World is a dependent partial map of protocols *)

Definition context := union_map Label protocol.

(*
The hooks are dependencies between:

1. a hook's unique id
2. a core protocol
3. a client protocol
4. a send-transition (represented by its tag) of a client protocol

*)
Definition hook_domain := [ordType of ((nat * Label) * (Label * nat))%type].

(*

A hook is a constraint from the local state wrt. core protocol (1st
heap argument), relating the local state wrt. the client protocol (2ns
heap argument), message to be sent, and the destination node id.

*)
Definition hook_type := heap -> heap -> seq nat -> nid -> Prop.

Definition hooks := union_map hook_domain hook_type.
Definition world := (context * hooks)%type.

Definition getc (w: world) : context := fst w.
Coercion getc : world >-> context.

Definition geth (w: world) : hooks := snd w.
Coercion geth : world >-> hooks.

Variable w : world.

Variables (p : protocol).

(* The function is, in fact, partially defined and returns Empty
   Protocol for a non-present label. *)
Definition getProtocol i : protocol:=
  match find i (getc w) with
  | Some p => p
  | None => EmptyProt i
  end.

End WorldGetters.
End WorldGetters.

Export WorldGetters.

(* Defining coherence of a state with respect to the world *)

Module Worlds.

Module Core.
Section Core.

(* The following definition ties together worlds and states *)

Definition hooks_consistent (c : context) (h : hooks) : Prop :=
  forall z lc ls t, ((z, lc), (ls, t)) \in dom h ->
  (lc \in dom c) && (ls \in dom c).

Definition hook_complete w := hooks_consistent (getc w) (geth w).

Lemma hook_complete0 c : hook_complete (c, Unit).
Proof. by move=>????; rewrite dom0. Qed.

Definition Coh (w : world) : Pred state := fun s =>
  let: c := fst w in
  let: h := snd w in
  [/\ valid w, valid s, hook_complete w,
      dom c =i dom s &
      forall l, coh (getProtocol w l) (getStatelet s l)].

Lemma cohW w s : Coh w s -> valid w.
Proof. by case w=>[c h]; case. Qed.

Lemma cohS w s : Coh w s -> valid s.
Proof. by case w=>[c h]; case. Qed.

Lemma cohH w s : Coh w s -> hook_complete w.
Proof. by case w=>[c h]; case. Qed.

Lemma cohD w s : Coh w s -> dom (getc w) =i dom s.
Proof. by case w=>[c h]; case. Qed.

Lemma coh_coh w s l : Coh w s -> coh (getProtocol w l) (getStatelet s l).
Proof. by case w=>[c h]; case. Qed.

(* Now we need to establish a bunch of natural properties with respect
   to coherence of worlds and states. *)

Lemma unit_coh w s :
  Coh w s -> w = Unit <-> s = Unit.
Proof.
case: (w)=>[c h].
case=>V V' Hc E H; split.
case=>Z1 Z2; subst c h; rewrite dom0 in E; last by rewrite (dom0E V').
move=>Z; subst s; move/andP: V=>/=[V1 V2].
have Z: c = Unit by apply: (dom0E V1); move=>z; rewrite E dom0.
subst c; suff Z: (h = Unit) by subst h.
simpl in Hc; clear E H V1 V'.
apply: (dom0E V2); move=> x; case X: (x \in dom h)=>//.
by move: x X=>[[z lc] [ls t]]/Hc/andP[]; rewrite !dom0.
Qed.

Lemma Coh0 (w : world) (s : state) :
  w = Unit -> s = Unit -> Coh w s.
Proof.
move=>->->{w s}; split; rewrite ?valid_unit ?dom0=>//=; last first.
- by move=>l; rewrite /getProtocol /getStatelet !find0E.
by move=>z lc ls t; rewrite dom0.
Qed.

Lemma CohUn (w1 w2 : world) (s1 s2 : state) :
  Coh w1 s1 -> Coh w2 s2 ->
  valid (w1 \+ w2) -> Coh (w1 \+ w2) (s1 \+ s2).
Proof.
case: w1=>[c1 h1]; case: w2=>[c2 h2]; move=>C1 C2 V.
case: (C1)=>_ G1 K1 J1 H1; case: (C2)=>_ G2 K2 J2 H2.
case/andP: V=>V V'; simpl in V, V'.
have X: valid (s1 \+ s2).
- case: validUn=>//; [by rewrite G1|by rewrite G2|move=>l; rewrite -J1 -J2=>D1 D2].
  by case: validUn V=>//=V1 V2; move/(_ _ D1); rewrite D2.
have Y: dom (c1 \+ c2) =i dom (s1 \+ s2).
- by move=>z; rewrite !domUn !inE/=;rewrite V X/= J1 J2.
have Z1:  valid ((c1, h1) \+ (c2, h2)) by rewrite /valid/= V V'.
split=>//[|l]; last first.
- rewrite /getProtocol /getStatelet.
  case: (dom_find l (s1 \+ s2))=>[|v]Z.
  - by move/find_none: (Z); rewrite -Y; case: dom_find=>//->_; rewrite Z.
  move/find_some: (Z)=>D; rewrite Z; rewrite -Y in D=> E.
  case: dom_find D=>// p Z' _ _; rewrite Z'.
  rewrite findUnL // in Z; rewrite findUnL // J1 in Z'.
  by case: ifP Z Z'=>_ F1 F2; [move: (H1 l)|move: (H2 l)];
     rewrite /getProtocol /getStatelet F1 F2.
by move=>z lc ls t/=; rewrite domUn inE=>/andP[_]/orP[];[move/K1|move/K2];
   move/andP=>[A1 A2]; rewrite !domUn !inE A1 A2 V -?(orbC true).
Qed.

(* Coherence is trivially precise wrt. statelets *)
Lemma coh_prec w: precise (Coh w).
Proof.
move=>s1 s2 t1 t2 V C1 C2.
case: C1 => H1 G1 K1 D1 _.
case: C2 => H2 G2 K2 D2 _ H.
by apply: (@dom_prec _ _ _ _ s1 s2 t1 t2) =>//z; rewrite -D1 -D2.
Qed.

Lemma locE i n k x y :
  k \in dom i -> valid i -> valid (dstate (getStatelet i k)) ->
  getLocal n (getStatelet (upd k
       {| dstate := upd n x (dstate (getStatelet i k));
          dsoup := y |} i) k) = x.
Proof.
move=>D V; rewrite /getStatelet; case:dom_find (D) =>//d->_ _.
by rewrite findU eqxx/= V /getLocal/= findU eqxx/==>->.
Qed.

Lemma locE' d n x y :
  valid (dstate d) ->
  getLocal n {| dstate := upd n x (dstate d);
                dsoup := y |} = x.
Proof. by move=>V; rewrite /getLocal findU eqxx/= V. Qed.

Lemma locU n n' x st s :
  n != n' ->
  valid st ->
  getLocal n {| dstate := upd n' x st; dsoup := s |} =
  getLocal n {| dstate := st; dsoup := s |}.
Proof.
by move=>/negbTE N V; rewrite /getLocal findU/= N.
Qed.

Section MakeWorld.

Variable p : protocol.
Notation l := (plab p).

Definition mkWorld : world := (l \\-> p, Unit).

Lemma prEq : (getProtocol mkWorld l) = p.
Proof. by rewrite /getProtocol findPt. Qed.

(*

Here's an incomplete list of procedures and facts, which might be
useful eventually:

- Define getters for particular transitions of worlds;

 *)

End MakeWorld.

(* TODO: try_recv should be restricted by a set of labels and a set of
   protocols *)
End Core.
End Core.

End Worlds.

Export Worlds.Core.


(* Evaluation contexts of the L6 CPS language
 * Part of the CertiCoq project
 *)

From Coq Require Import Arith.Arith NArith.BinNat Lists.List omega.Omega.
From SFS Require Import cps tactics set_util.

Import ListNotations.

(** Expression evaluation contexts *)
Inductive exp_ctx : Type :=
| Hole_c : exp_ctx
| Econstr_c : var -> cTag -> list var -> exp_ctx -> exp_ctx
| Eproj_c  : var -> cTag -> N -> var -> exp_ctx -> exp_ctx
| Eprim_c : var -> prim -> list var -> exp_ctx -> exp_ctx
| Ecase_c : var -> list (cTag * exp) -> cTag ->
            exp_ctx -> list (cTag * exp) -> exp_ctx
| Efun1_c : fundefs -> exp_ctx -> exp_ctx
| Efun2_c : fundefs_ctx -> exp -> exp_ctx
with fundefs_ctx :=
     | Fcons1_c:  var -> cTag -> list var -> exp_ctx -> fundefs -> fundefs_ctx
     | Fcons2_c:  var -> cTag -> list var -> exp -> fundefs_ctx -> fundefs_ctx.

(** Evaluation context application - Relational definition *)
Inductive app_ctx: exp_ctx -> exp -> exp -> Prop :=
| Hole_ac: forall e, app_ctx Hole_c e e
| Constr_ac : forall x t c ys e ce,
                app_ctx c e ce ->
                app_ctx (Econstr_c x t ys c) e (Econstr x t ys ce)
| Proj_ac : forall x t n y e c ce,
              app_ctx c e ce ->
              app_ctx (Eproj_c x t n y c) e (Eproj x t n y ce)
| Case_ac : forall x te t e te' c ce,
              app_ctx c e ce ->
              app_ctx (Ecase_c x te t c te') e
                      (Ecase x (te ++ (t, ce) :: te'))
| Prim_ac : forall x f ys e c ce,
              app_ctx c e ce ->
              app_ctx (Eprim_c x f ys c) e (Eprim x f ys ce)
| Fun1_ac : forall c e ce fds,
              app_ctx c e ce ->
              app_ctx (Efun1_c fds c) e (Efun fds ce)
| Fun2_ac : forall e cfds cfdse e',
              app_f_ctx cfds e cfdse ->
              app_ctx (Efun2_c cfds e') e (Efun cfdse e')
with app_f_ctx : fundefs_ctx -> exp -> fundefs -> Prop :=
     | Fcons1_ac : forall c e ce f t ys fds,
                     app_ctx c e ce ->
                     app_f_ctx (Fcons1_c f t ys c fds) e (Fcons f t ys ce fds)
     | Fcons2_ac: forall e cfdse f cfds ys e' t,
                    app_f_ctx cfds e cfdse ->
                    app_f_ctx (Fcons2_c f t ys e' cfds) e (Fcons f t ys e' cfdse).

Hint Constructors app_ctx app_f_ctx.

(** Evaluation context application - Computational definition *)
Fixpoint app_ctx_f (c:exp_ctx) (e:exp) : exp :=
  match c with
    | Hole_c => e
    | Econstr_c x t ys c => Econstr x t ys (app_ctx_f c e)
    | Eproj_c x t n y c => Eproj x t n y (app_ctx_f c e)
    | Ecase_c x te t c te' =>
      Ecase x (te ++ (t, app_ctx_f c e) :: te')
    | Eprim_c x f ys c => Eprim x f ys (app_ctx_f c e)
    | Efun1_c fds c => Efun fds (app_ctx_f c e)
    | Efun2_c cfds e' => Efun (app_f_ctx_f cfds e) e'
  end
with app_f_ctx_f (c: fundefs_ctx) (e:exp) : fundefs :=
       match c with
         | Fcons1_c f t ys c fds => Fcons f t ys (app_ctx_f c e) fds
         | Fcons2_c f t ys e' cfds => Fcons f t ys e' (app_f_ctx_f cfds e)
       end.

(** Composition of evaluation context - Relational definition *)
Inductive  comp_ctx: exp_ctx -> exp_ctx -> exp_ctx -> Prop :=
| Hole_cc: forall e, comp_ctx Hole_c e e
| Constr_cc : forall x t c ys e ce,
                comp_ctx c e ce ->
                comp_ctx (Econstr_c x t ys c) e (Econstr_c x t ys ce)
| Proj_cc : forall x t n y e c ce,
              comp_ctx c e ce ->
              comp_ctx (Eproj_c x t n y c) e (Eproj_c x t n y ce)
| Case_cc : forall x te t c te' c' cc,
              comp_ctx c c' cc ->
              comp_ctx (Ecase_c x te t c te') c' (Ecase_c x te t cc te')
| Prim_cc : forall x f ys e c ce,
              comp_ctx c e ce ->
              comp_ctx (Eprim_c x f ys c) e (Eprim_c x f ys ce)
| Fun1_cc : forall c e ce fds,
              comp_ctx c e ce ->
              comp_ctx (Efun1_c fds c) e (Efun1_c fds ce)
| Fun2_cc : forall e cfds cfdse e',
              comp_f_ctx cfds e cfdse ->
              comp_ctx (Efun2_c cfds e') e (Efun2_c cfdse e')
with comp_f_ctx : fundefs_ctx -> exp_ctx -> fundefs_ctx -> Prop :=
     | Fcons1_cc :
         forall c e ce f t ys fds,
           comp_ctx c e ce ->
           comp_f_ctx (Fcons1_c f t ys c fds) e (Fcons1_c f t ys ce fds)
     | Fcons2_cc:
         forall e cfdse f cfds ys e' t,
           comp_f_ctx cfds e cfdse ->
           comp_f_ctx (Fcons2_c f t ys e' cfds) e (Fcons2_c f t ys e' cfdse).

(** Composition of evaluation context - Computational definition *)
Fixpoint comp_ctx_f (c1:exp_ctx) (c2:exp_ctx) : exp_ctx :=
  match c1 with
    | Hole_c => c2
    | Econstr_c x t ys c => Econstr_c x t ys (comp_ctx_f c c2)
    | Eproj_c x t n y c => Eproj_c x t n y (comp_ctx_f c c2)
    | Ecase_c x te t c te' => Ecase_c x te t (comp_ctx_f c c2) te'
    | Eprim_c x f ys c => Eprim_c x f ys (comp_ctx_f c c2)
    | Efun1_c fds c => Efun1_c fds (comp_ctx_f c c2)
    | Efun2_c cfds e' => Efun2_c (comp_f_ctx_f cfds c2) e'
  end
with comp_f_ctx_f (c: fundefs_ctx) (c2:exp_ctx) : fundefs_ctx :=
       match c with
         | Fcons1_c f t ys c fds =>
           Fcons1_c f t ys (comp_ctx_f c c2) fds
         | Fcons2_c f t ys e' cfds =>
           Fcons2_c f t ys e' (comp_f_ctx_f cfds c2)
       end.

Notation "c '|[' e ']|' " := (app_ctx_f c e)  (at level 28, no associativity)
                             : ctx_scope.
Notation "f '<[' e ']>'" := (app_f_ctx_f f e)  (at level 28, no associativity)
                            : ctx_scope.
Open Scope ctx_scope.

Scheme ctx_exp_mut := Induction for exp_ctx Sort Prop
with ctx_fundefs_mut := Induction for fundefs_ctx Sort Prop.

Scheme ctx_exp_mut' := Induction for exp_ctx Sort Type
with ctx_fundefs_mut' := Induction for fundefs_ctx Sort Type.

Lemma exp_fundefs_ctx_mutual_ind :
  forall (P : exp_ctx -> Prop) (P0 : fundefs_ctx -> Prop),
    P Hole_c ->
    (forall (v : var) (t : cTag) (l : list var) (e : exp_ctx),
       P e -> P (Econstr_c v t l e)) ->
    (forall (v : var) (t : cTag) (n : N) (v0 : var) (e : exp_ctx),
       P e -> P (Eproj_c v t n v0 e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp_ctx),
       P e -> P (Eprim_c v p l e)) ->
    (forall (v : var) (l : list (cTag * exp)) (t : cTag) (e : exp_ctx),
       P e -> forall l0 : list (cTag * exp), P (Ecase_c v l t e l0)) ->
    (forall (f4 : fundefs) (e : exp_ctx), P e -> P (Efun1_c f4 e)) ->
    (forall f5 : fundefs_ctx, P0 f5 -> forall e : exp, P (Efun2_c f5 e)) ->
    (forall (v : var) (t : fTag) (l : list var) (e : exp_ctx),
       P e -> forall f6 : fundefs, P0 (Fcons1_c v t l e f6)) ->
    (forall (v : var) (t : fTag) (l : list var)
            (e : exp) (f7 : fundefs_ctx), P0 f7 -> P0 (Fcons2_c v t l e f7)) ->
    (forall e : exp_ctx, P e) /\ (forall f : fundefs_ctx, P0 f).
Proof.
  intros. split.
  apply (ctx_exp_mut P P0); assumption.
  apply (ctx_fundefs_mut P P0); assumption.
Qed.

(** Name the induction hypotheses only *)
Ltac exp_fundefs_ctx_induction IH1 IH2 :=
  apply exp_fundefs_ctx_mutual_ind;
  [ | intros ? ? ? ? IH1
    | intros ? ? ? ? ? IH1
    | intros ? ? ? ? IH1
    | intros ? ? ? ? IH1
    | intros ? ? IH1
    | intros ? IH2 ?
    | intros ? ? ? ? IH1 ?
    | intros ? ? ? ? ? IH2 ].

(** Alternative definition of subterm relation *)
Definition subterm_e' (e':exp) (e:exp): Prop :=
  exists c, Hole_c <> c /\ app_ctx c e' e.

Definition subterm_or_eq' (e':exp) (e:exp) : Prop :=
  exists c, app_ctx c e' e.

(** Theorems about context application and composition *)
Lemma app_ctx_f_correct_mut:
  (forall c e e',
     c |[ e ]|  = e' <-> app_ctx c e e') /\
  (forall cf B B',
     cf <[ B ]> = B' <-> app_f_ctx cf B B').
Proof.
  exp_fundefs_ctx_induction IHe IHf; simpl; intros; split; intros H';
  first
    [ inversion H'; subst; constructor;
      eapply IHe; congruence
    | inversion H'; subst; repeat f_equal; eapply IHe;
      eassumption
    | inversion H'; subst; constructor;
      eapply IHf; congruence
    | inversion H'; subst; repeat f_equal; eapply IHf ];
  inversion H'; subst; eassumption.
Qed.

Corollary app_ctx_f_correct :
  forall c e e',
    c |[ e ]|  = e' <-> app_ctx c e e'.
Proof.
  now apply app_ctx_f_correct_mut.
Qed.

Corollary app_f_ctx_f_correct :
  forall cf B B',
    cf <[ B ]> = B' <-> app_f_ctx cf B B'.
Proof.
  now apply app_ctx_f_correct_mut.
Qed.

Lemma comp_ctx_f_correct_mut:
  (forall c c' cc',
     comp_ctx_f c c'  = cc' <-> comp_ctx c c' cc') /\
  (forall cf cf' ccf',
     comp_f_ctx_f cf cf' = ccf' <-> comp_f_ctx cf cf' ccf').
Proof.
  exp_fundefs_ctx_induction IHe IHf; simpl; intros; split; intros H';
  first
    [ inversion H'; subst; constructor;
      eapply IHe; congruence
    | inversion H'; subst; repeat f_equal; eapply IHe;
      eassumption
    | inversion H'; subst; constructor;
      eapply IHf; congruence
    | inversion H'; subst; repeat f_equal; eapply IHf ];
  inversion H'; subst; eassumption.
Qed.

Corollary comp_ctx_f_correct :
  forall c c' cc',
    comp_ctx_f c c'  = cc' <-> comp_ctx c c' cc'.
Proof.
  now apply comp_ctx_f_correct_mut.
Qed.

Corollary comp_f_ctx_f_correct :
  forall cf cf' ccf',
   comp_f_ctx_f cf cf' = ccf' <-> comp_f_ctx cf cf' ccf'.
Proof.
  now apply comp_ctx_f_correct_mut.
Qed.

Lemma app_ctx_f_fuse_mut :
  (forall c c' e,
     c |[ c' |[ e ]| ]| = (comp_ctx_f c c') |[ e ]|) /\
  (forall cf c e,
     cf <[ c |[ e ]| ]> = (comp_f_ctx_f cf c) <[ e ]>).
Proof.
  exp_fundefs_ctx_induction IHe IHf; simpl; intros;
  try (rewrite IHe; reflexivity); try (rewrite IHf; reflexivity).
  reflexivity.
Qed.

Corollary app_ctx_f_fuse :
  forall c c' e,
    c |[ c' |[ e ]| ]| = (comp_ctx_f c c') |[ e ]|.
Proof.
  now apply app_ctx_f_fuse_mut.
Qed.

Corollary app_f_ctx_f_fuse :
  forall cf c e,
    cf <[ c |[ e ]| ]> = (comp_f_ctx_f cf c) <[ e ]>.
Proof.
  now apply app_ctx_f_fuse_mut.
Qed.

Lemma app_ctx_fuse:
  forall (c c' : exp_ctx) (e1 e2 e3 : exp),
    app_ctx c e1 e2 ->
    app_ctx c' e2 e3 ->
    app_ctx (comp_ctx_f c' c) e1 e3.
Proof.
  intros c c' e1 e2 e3 H1 H2. rewrite <- app_ctx_f_correct.
  rewrite <- app_ctx_f_fuse.
  rewrite <- app_ctx_f_correct in H1, H2. rewrite H1. eauto.
Qed.

Lemma comp_ctx_f_assoc_mut:
  (forall c1 c2 c3,
     comp_ctx_f (comp_ctx_f c1 c2) c3 = comp_ctx_f c1 (comp_ctx_f c2 c3)) /\
  (forall f c2 c3, comp_f_ctx_f (comp_f_ctx_f f c2) c3 =
              comp_f_ctx_f f (comp_ctx_f c2 c3)).
Proof.
  exp_fundefs_ctx_induction IHc1 IHf; intros; simpl; auto; try (rewrite IHc1; auto).
  - rewrite IHf; auto.
  - rewrite IHf; auto.
Qed.

Theorem comp_ctx_f_assoc:
  (forall c1 c2 c3,
     comp_ctx_f (comp_ctx_f c1 c2) c3 = comp_ctx_f c1 (comp_ctx_f c2 c3)).
Proof.
  intros; apply comp_ctx_f_assoc_mut; auto.
Qed.

Theorem comp_f_ctx_f_assoc:
  (forall f c2 c3, comp_f_ctx_f (comp_f_ctx_f f c2) c3 =
              comp_f_ctx_f f (comp_ctx_f c2 c3)).
Proof.
  intros; apply comp_ctx_f_assoc_mut; auto.
Qed.

Theorem comp_ctx_split_mut:
  (forall c1 c2 c3 c4,
     comp_ctx_f c1 c2 = comp_ctx_f c3 c4 ->
     (exists c41 c42, c4 = comp_ctx_f c41 c42 /\ c1 = comp_ctx_f c3 c41 /\ c2 = c42) \/
     (exists c31 c32, c3 = comp_ctx_f c31 c32 /\ c1 = c31 /\ c2 = comp_ctx_f c32 c4)) /\
  (forall f1 c2 f3 c4, comp_f_ctx_f f1 c2 = comp_f_ctx_f f3 c4 ->
                  (exists c41 c42, c4 = comp_ctx_f c41 c42 /\ f1 = comp_f_ctx_f f3 c41 /\ c2 = c42) \/
                  (exists f31 c32, f3 = comp_f_ctx_f f31 c32 /\ f1 = f31 /\ c2 = comp_ctx_f c32 c4)).
Proof.
  exp_fundefs_ctx_induction IHc1 IHf; intros.
  - simpl in H.
    right.
    exists Hole_c, c3.
    auto.
  - simpl in H. destruct c3; inv H.
    + simpl in H0.
      left.
      destruct c4; inv H0.
      exists ( Econstr_c v0 c l0 e), c2.
      auto.
    + apply IHc1 in H4. destruct H4.
      * left.
        destructAll.
        exists x, x0.
        auto.
      * right. destructAll.
        exists (Econstr_c v0 c l0 x), x0.
        auto.
  - simpl in H. destruct c3; inv H.
    + simpl in H0.
      left.
      destruct c4; inv H0.
      exists ( Eproj_c v1 c n0 v2 e ),  c2; auto.
    + apply IHc1 in H5. destruct H5.
      * left.
        destructAll.
        exists x, x0.
        auto.
      * right. destructAll.
        exists ( Eproj_c v1 c n0 v2 x), x0;
          auto.
  - simpl in H. destruct c3; inv H.
    + simpl in H0.
      left.
      destruct c4; inv H0.
      exists ( Eprim_c v0 p0 l0 e ),  c2; auto.
    + apply IHc1 in H4. destruct H4.
      * left.
        destructAll.
        exists x, x0.
        auto.
      * right. destructAll.
        exists (Eprim_c v0 p0 l0 x ), x0;
          auto.
  - simpl in H. destruct c3; inv H.
    + simpl in H0. left.
      exists (Ecase_c v l t e l0), c2.
      auto.
    + apply IHc1 in H4.
      destruct H4; destructAll.
      * left.
        exists x, x0; auto.
      * right.
        exists (Ecase_c v0 l1 c x l2), x0.
        auto.
  - simpl in H.
    destruct c3; inv H.
    + simpl in H0.
      left.
      exists (Efun1_c f4 e), c2.
      auto.
    + apply IHc1 in H2.
      destruct H2; destructAll.
      * left.
        exists x, x0; auto.
      * right.
        exists (Efun1_c f x), x0.
        auto.
  - simpl in H.
    destruct c3; inv H.
    + simpl in H0.
      left.
      exists (Efun2_c f5 e), c2.
      auto.
    + apply IHf in H1.
      destruct H1.
      * left.
        destructAll.
        simpl. exists x, x0.
        auto.
      * right.
        destructAll.
        exists ( Efun2_c x e0), x0.
        auto.
  - destruct f3; inv H.
    apply IHc1 in H4.
    destruct H4; destructAll.
    * left.
      simpl.
      exists x, x0.
      auto.
    * right.
      exists (Fcons1_c v0 c l0 x f), x0; auto.
  - simpl in H.
    destruct f3; inv H.
    apply IHf in H5.
    destruct H5.
    * left.
      destructAll.
      simpl. exists x, x0.
      auto.
    * right.
      destructAll.
      exists (Fcons2_c v0 c l0 e0 x), x0.
      auto.
Qed.

Theorem comp_ctx_split:
  (forall c1 c2 c3 c4,
     comp_ctx_f c1 c2 = comp_ctx_f c3 c4 ->
     (exists c41 c42, c4 = comp_ctx_f c41 c42 /\ c1 = comp_ctx_f c3 c41 /\ c2 = c42) \/
     (exists c31 c32, c3 = comp_ctx_f c31 c32 /\ c1 = c31 /\ c2 = comp_ctx_f c32 c4)).
Proof.
  apply comp_ctx_split_mut; auto.
Qed.

Theorem comp_f_ctx_split:
  (forall f1 c2 f3 c4, comp_f_ctx_f f1 c2 = comp_f_ctx_f f3 c4 ->
                  (exists c41 c42, c4 = comp_ctx_f c41 c42 /\ f1 = comp_f_ctx_f f3 c41 /\ c2 = c42) \/
                  (exists f31 c32, f3 = comp_f_ctx_f f31 c32 /\ f1 = f31 /\ c2 = comp_ctx_f c32 c4)).
Proof.
  apply comp_ctx_split_mut; auto.
Qed.

(* prefix a fundefs ctx with a fundefs *)
Fixpoint app_fundefs_ctx (f:fundefs) (fc:fundefs_ctx): fundefs_ctx:=
  match f with
    | Fnil => fc
    | Fcons x t xs e f' =>
      Fcons2_c x t xs e (app_fundefs_ctx f' fc)
  end.

Lemma comp_ctx_f_Hole_c C :
  comp_ctx_f C Hole_c = C
with comp_f_ctx_f_Hole_c f :
       comp_f_ctx_f f Hole_c = f.
Proof.
  - destruct C; simpl; eauto;
    try (rewrite comp_ctx_f_Hole_c; reflexivity).
    rewrite comp_f_ctx_f_Hole_c. reflexivity.
  - destruct f; simpl; eauto.
    rewrite comp_ctx_f_Hole_c; reflexivity.
    rewrite comp_f_ctx_f_Hole_c. reflexivity.
Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.util.BitWidths.
Require Import riscv.Decode.
Require Import riscv.Memory.
Require Import riscv.Utility.

Class RegisterFile{RF R V: Type} := mkRegisterFile {
  getReg: RF -> R -> V;
  setReg: RF -> R -> V -> RF;
  initialRegs: RF;
}.

Arguments RegisterFile: clear implicits.

Section Riscv.

  Context {mword: Set}.
  Context {MW: MachineWidth mword}.
  Context {Mem: Set}.
  Context {MemIsMem: Memory Mem mword}.
  Context {RF: Type}.
  Context {RFI: RegisterFile RF Register mword}.

  Record RiscvMachineCore := mkRiscvMachineCore {
    registers: RF;
    pc: mword;
    nextPC: mword;
    exceptionHandlerAddr: MachineInt;
  }.

  Record RiscvMachine := mkRiscvMachine {
    core: RiscvMachineCore;
    machineMem: Mem;
  }.

  Definition with_registers r ma :=
    mkRiscvMachine (mkRiscvMachineCore
        r ma.(core).(pc) ma.(core).(nextPC) ma.(core).(exceptionHandlerAddr))
        ma.(machineMem).
  Definition with_pc p ma :=
    mkRiscvMachine (mkRiscvMachineCore
        ma.(core).(registers) p ma.(core).(nextPC) ma.(core).(exceptionHandlerAddr))
        ma.(machineMem).
  Definition with_nextPC npc ma :=
    mkRiscvMachine (mkRiscvMachineCore
        ma.(core).(registers) ma.(core).(pc) npc ma.(core).(exceptionHandlerAddr))
        ma.(machineMem).
  Definition with_exceptionHandlerAddr eh ma :=
    mkRiscvMachine (mkRiscvMachineCore
        ma.(core).(registers) ma.(core).(pc) ma.(core).(nextPC) eh)
        ma.(machineMem).
  Definition with_machineMem m ma :=
    mkRiscvMachine ma.(core) m.

End Riscv.