(* autogenerated from github.com/mit-pdos/gokv/paxi/reconf *)
From Perennial.goose_lang Require Import prelude.
From Goose Require github_com.mit_pdos.gokv.connman.
From Goose Require github_com.mit_pdos.gokv.urpc.
From Goose Require github_com.tchajed.marshal.

From Perennial.goose_lang Require Import ffi.grove_prelude.

(* 0_quorums.go *)

Definition Config := struct.decl [
  "Members" :: slice.T uint64T;
  "NextMembers" :: slice.T uint64T
].

(* Returns some integer i with the property that
   there exists W such that W contains a majority of members and of nextMembers,
   and every node n in W has indices[n] >= i.
   Even more precisely, it returns the largest such i. *)
Definition GetHighestIndexOfQuorum: val :=
  rec: "GetHighestIndexOfQuorum" "config" "indices" :=
    let: "orderedIndices" := ref_to (slice.T uint64T) (NewSlice uint64T ((slice.len (struct.loadF Config "Members" "config") + #1) `quot` #2)) in
    ForSlice uint64T <> "m" (struct.loadF Config "Members" "config")
      (let: "indexToInsert" := Fst (MapGet "indices" "m") in
      ForSlice uint64T "i" <> (![slice.T uint64T] "orderedIndices")
        ((if: SliceGet uint64T (![slice.T uint64T] "orderedIndices") "i" > "indexToInsert"
        then
          let: "j" := ref_to uint64T "i" in
          (for: (λ: <>, ![uint64T] "j" < slice.len (![slice.T uint64T] "orderedIndices") - #1); (λ: <>, "j" <-[uint64T] ![uint64T] "j" + #1) := λ: <>,
            SliceSet uint64T (![slice.T uint64T] "orderedIndices") ("i" + #1) (SliceGet uint64T (![slice.T uint64T] "orderedIndices") "i");;
            Continue)
        else #())));;
    let: "ret" := SliceGet uint64T (![slice.T uint64T] "orderedIndices") (slice.len (struct.loadF Config "Members" "config") - #1) in
    (if: (slice.len (struct.loadF Config "NextMembers" "config") = #0)
    then "ret"
    else #0).

(* Returns true iff w is a (write) quorum for the config `config`. *)
Definition IsQuorum: val :=
  rec: "IsQuorum" "config" "w" :=
    let: "num" := ref (zero_val uint64T) in
    ForSlice uint64T <> "member" (struct.loadF Config "Members" "config")
      ((if: Fst (MapGet "w" "member")
      then "num" <-[uint64T] ![uint64T] "num" + #1
      else #()));;
    (if: #2 * ![uint64T] "num" ≤ slice.len (struct.loadF Config "Members" "config")
    then #false
    else
      (if: (slice.len (struct.loadF Config "NextMembers" "config") = #0)
      then #true
      else
        "num" <-[uint64T] #0;;
        ForSlice uint64T <> "member" (struct.loadF Config "NextMembers" "config")
          ((if: Fst (MapGet "w" "member")
          then "num" <-[uint64T] ![uint64T] "num" + #1
          else #()));;
        (if: #2 * ![uint64T] "num" ≤ slice.len (struct.loadF Config "NextMembers" "config")
        then #false
        else #true))).

Definition Config__ForEachMember: val :=
  rec: "Config__ForEachMember" "c" "f" :=
    ForSlice uint64T <> "member" (struct.loadF Config "Members" "c")
      ("f" "member");;
    ForSlice uint64T <> "member" (struct.loadF Config "NextMembers" "c")
      ("f" "member");;
    #().

Definition Config__Contains: val :=
  rec: "Config__Contains" "c" "m" :=
    let: "ret" := ref_to boolT #false in
    ForSlice uint64T <> "member" (struct.loadF Config "Members" "c")
      ((if: ("member" = "m")
      then "ret" <-[boolT] #true
      else #()));;
    ForSlice uint64T <> "member" (struct.loadF Config "NextMembers" "c")
      ((if: ("member" = "m")
      then "ret" <-[boolT] #true
      else #()));;
    ![boolT] "ret".

(* 1_marshal.go *)

Definition EncConfig: val :=
  rec: "EncConfig" "pre" "conf" :=
    let: "enc" := ref_to (slice.T byteT) "pre" in
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (slice.len (struct.loadF Config "Members" "conf"));;
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (slice.len (struct.loadF Config "NextMembers" "conf"));;
    ForSlice uint64T <> "member" (struct.loadF Config "Members" "conf")
      ("enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") "member");;
    ForSlice uint64T <> "member" (struct.loadF Config "NextMembers" "conf")
      ("enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") "member");;
    ![slice.T byteT] "enc".

Definition DecConfig: val :=
  rec: "DecConfig" "encoded" :=
    let: "dec" := ref_to (slice.T byteT) "encoded" in
    let: "conf" := struct.alloc Config (zero_val (struct.t Config)) in
    let: ("numMembers", "dec") := marshal.ReadInt (![slice.T byteT] "dec") in
    let: ("numNextMembers", "dec") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF Config "Members" "conf" (NewSlice uint64T "numMembers");;
    struct.storeF Config "NextMembers" "conf" (NewSlice uint64T "numNextMembers");;
    ForSlice uint64T "i" <> (struct.loadF Config "Members" "conf")
      (let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
      SliceSet uint64T (struct.loadF Config "Members" "conf") "i" "0_ret";;
      "dec" <-[slice.T byteT] "1_ret");;
    ForSlice uint64T "i" <> (struct.loadF Config "NextMembers" "conf")
      (let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
      SliceSet uint64T (struct.loadF Config "Members" "conf") "i" "0_ret";;
      "dec" <-[slice.T byteT] "1_ret");;
    ("conf", ![slice.T byteT] "dec").

Definition MonotonicValue := struct.decl [
  "version" :: uint64T;
  "val" :: slice.T byteT;
  "conf" :: ptrT
].

Definition EncMonotonicValue: val :=
  rec: "EncMonotonicValue" "pre" "mval" :=
    let: "enc" := ref_to (slice.T byteT) "pre" in
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (struct.loadF MonotonicValue "version" "mval");;
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (slice.len (struct.loadF MonotonicValue "val" "mval"));;
    "enc" <-[slice.T byteT] marshal.WriteBytes (![slice.T byteT] "enc") (struct.loadF MonotonicValue "val" "mval");;
    "enc" <-[slice.T byteT] EncConfig (![slice.T byteT] "enc") (struct.loadF MonotonicValue "conf" "mval");;
    ![slice.T byteT] "enc".

Definition DecMonotonicValue: val :=
  rec: "DecMonotonicValue" "encoded" :=
    let: "mval" := struct.alloc MonotonicValue (zero_val (struct.t MonotonicValue)) in
    let: "dec" := ref_to (slice.T byteT) "encoded" in
    let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF MonotonicValue "version" "mval" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    let: ("valLen", "dec") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF MonotonicValue "val" "mval" (SliceTake (![slice.T byteT] "dec") "valLen");;
    "dec" <-[slice.T byteT] SliceSkip byteT (![slice.T byteT] "dec") "valLen";;
    let: ("0_ret", "1_ret") := DecConfig (![slice.T byteT] "dec") in
    struct.storeF MonotonicValue "conf" "mval" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    ("mval", ![slice.T byteT] "dec").

Definition PrepareReply := struct.decl [
  "Err" :: uint64T;
  "Term" :: uint64T;
  "Val" :: ptrT
].

Definition EncPrepareReply: val :=
  rec: "EncPrepareReply" "pre" "reply" :=
    let: "enc" := ref_to (slice.T byteT) "pre" in
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (struct.loadF PrepareReply "Err" "reply");;
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (struct.loadF PrepareReply "Term" "reply");;
    "enc" <-[slice.T byteT] EncMonotonicValue (![slice.T byteT] "enc") (struct.loadF PrepareReply "Val" "reply");;
    ![slice.T byteT] "enc".

Definition DecPrepareReply: val :=
  rec: "DecPrepareReply" "encoded" :=
    let: "dec" := ref_to (slice.T byteT) "encoded" in
    let: "reply" := struct.alloc PrepareReply (zero_val (struct.t PrepareReply)) in
    let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF PrepareReply "Err" "reply" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF PrepareReply "Term" "reply" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    let: ("0_ret", "1_ret") := DecMonotonicValue (![slice.T byteT] "dec") in
    struct.storeF PrepareReply "Val" "reply" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    "reply".

Definition ProposeArgs := struct.decl [
  "Term" :: uint64T;
  "Val" :: ptrT
].

Definition EncProposeArgs: val :=
  rec: "EncProposeArgs" "args" :=
    let: "enc" := ref_to (slice.T byteT) (NewSlice byteT #0) in
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (struct.loadF ProposeArgs "Term" "args");;
    "enc" <-[slice.T byteT] EncMonotonicValue (![slice.T byteT] "enc") (struct.loadF ProposeArgs "Val" "args");;
    ![slice.T byteT] "enc".

Definition DecProposeArgs: val :=
  rec: "DecProposeArgs" "encoded" :=
    let: "dec" := ref_to (slice.T byteT) "encoded" in
    let: "args" := struct.alloc ProposeArgs (zero_val (struct.t ProposeArgs)) in
    let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
    struct.storeF ProposeArgs "Term" "args" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    let: ("0_ret", "1_ret") := DecMonotonicValue (![slice.T byteT] "dec") in
    struct.storeF ProposeArgs "Val" "args" "0_ret";;
    "dec" <-[slice.T byteT] "1_ret";;
    ("args", ![slice.T byteT] "dec").

Definition TryCommitReply := struct.decl [
  "err" :: uint64T;
  "version" :: uint64T
].

Definition EncMembers: val :=
  rec: "EncMembers" "members" :=
    let: "enc" := ref_to (slice.T byteT) (NewSlice byteT #0) in
    "enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") (slice.len "members");;
    ForSlice uint64T <> "member" "members"
      ("enc" <-[slice.T byteT] marshal.WriteInt (![slice.T byteT] "enc") "member");;
    ![slice.T byteT] "enc".

Definition DecMembers: val :=
  rec: "DecMembers" "encoded" :=
    let: "dec" := ref_to (slice.T byteT) "encoded" in
    let: ("numMembers", "dec") := marshal.ReadInt (![slice.T byteT] "dec") in
    let: "members" := NewSlice uint64T "numMembers" in
    ForSlice uint64T "i" <> "members"
      (let: ("0_ret", "1_ret") := marshal.ReadInt (![slice.T byteT] "dec") in
      SliceSet uint64T "members" "i" "0_ret";;
      "dec" <-[slice.T byteT] "1_ret");;
    ("members", ![slice.T byteT] "dec").

(* client.go *)

Definition ClerkPool := struct.decl [
  "cl" :: ptrT
].

Definition RPC_PREPARE : expr := #0.

Definition RPC_PROPOSE : expr := #1.

Definition RPC_TRY_COMMIT_VAL : expr := #2.

Definition RPC_TRY_CONFIG_CHANGE : expr := #3.

Definition MakeClerkPool: val :=
  rec: "MakeClerkPool" <> :=
    struct.new ClerkPool [
      "cl" ::= connman.MakeConnMan #()
    ].

Definition ClerkPool__PrepareRPC: val :=
  rec: "ClerkPool__PrepareRPC" "ck" "srv" "newTerm" "reply_ptr" :=
    let: "raw_reply" := ref (zero_val (slice.T byteT)) in
    connman.ConnMan__CallAtLeastOnce (struct.loadF ClerkPool "cl" "ck") "srv" RPC_PREPARE (marshal.WriteInt (NewSlice byteT #0) "newTerm") "raw_reply" #10;;
    struct.store PrepareReply "reply_ptr" (struct.load PrepareReply (DecPrepareReply (![slice.T byteT] "raw_reply")));;
    #().

Definition ClerkPool__ProposeRPC: val :=
  rec: "ClerkPool__ProposeRPC" "ck" "srv" "term" "val" :=
    let: "args" := struct.new ProposeArgs [
      "Term" ::= "term";
      "Val" ::= "val"
    ] in
    let: "raw_reply" := ref (zero_val (slice.T byteT)) in
    connman.ConnMan__CallAtLeastOnce (struct.loadF ClerkPool "cl" "ck") "srv" RPC_PROPOSE (EncProposeArgs "args") "raw_reply" #10;;
    let: ("err", <>) := marshal.ReadInt (![slice.T byteT] "raw_reply") in
    ("err" = #0).

Definition ClerkPool__TryCommitVal: val :=
  rec: "ClerkPool__TryCommitVal" "ck" "srv" "v" :=
    let: "raw_reply" := ref (zero_val (slice.T byteT)) in
    connman.ConnMan__CallAtLeastOnce (struct.loadF ClerkPool "cl" "ck") "srv" RPC_TRY_COMMIT_VAL "v" "raw_reply" #1000;;
    let: ("err", <>) := marshal.ReadInt (![slice.T byteT] "raw_reply") in
    ("err" = #0).

Definition ClerkPool__TryConfigChange: val :=
  rec: "ClerkPool__TryConfigChange" "ck" "srv" "newMembers" :=
    let: "raw_args" := EncMembers "newMembers" in
    let: "raw_reply" := ref (zero_val (slice.T byteT)) in
    connman.ConnMan__CallAtLeastOnce (struct.loadF ClerkPool "cl" "ck") "srv" RPC_TRY_CONFIG_CHANGE "raw_args" "raw_reply" #50;;
    let: ("err", <>) := marshal.ReadInt (![slice.T byteT] "raw_reply") in
    ("err" = #0).

(* server.go *)

Definition MonotonicValue__GreaterThan: val :=
  rec: "MonotonicValue__GreaterThan" "lhs" "rhs" :=
    struct.loadF MonotonicValue "version" "lhs" > struct.loadF MonotonicValue "version" "rhs".

Definition Replica := struct.decl [
  "mu" :: ptrT;
  "promisedTerm" :: uint64T;
  "acceptedTerm" :: uint64T;
  "acceptedMVal" :: ptrT;
  "clerkPool" :: ptrT;
  "isLeader" :: boolT
].

Definition ENone : expr := #0.

Definition ETermStale : expr := #1.

Definition ENotLeader : expr := #2.

Definition EQuorumFailed : expr := #3.

Definition Replica__PrepareRPC: val :=
  rec: "Replica__PrepareRPC" "r" "term" "reply" :=
    lock.acquire (struct.loadF Replica "mu" "r");;
    (if: "term" > struct.loadF Replica "promisedTerm" "r"
    then
      struct.storeF Replica "promisedTerm" "r" "term";;
      struct.storeF PrepareReply "Term" "reply" (struct.loadF Replica "acceptedTerm" "r");;
      struct.storeF PrepareReply "Val" "reply" (struct.loadF Replica "acceptedMVal" "r");;
      struct.storeF PrepareReply "Err" "reply" ENone
    else
      struct.storeF PrepareReply "Err" "reply" ETermStale;;
      struct.storeF PrepareReply "Val" "reply" (struct.alloc MonotonicValue (zero_val (struct.t MonotonicValue)));;
      struct.storeF MonotonicValue "conf" (struct.loadF PrepareReply "Val" "reply") (struct.alloc Config (zero_val (struct.t Config)));;
      struct.storeF PrepareReply "Term" "reply" (struct.loadF Replica "promisedTerm" "r"));;
    lock.release (struct.loadF Replica "mu" "r");;
    #().

Definition Replica__ProposeRPC: val :=
  rec: "Replica__ProposeRPC" "r" "term" "v" :=
    lock.acquire (struct.loadF Replica "mu" "r");;
    (if: "term" ≥ struct.loadF Replica "promisedTerm" "r"
    then
      struct.storeF Replica "promisedTerm" "r" "term";;
      struct.storeF Replica "acceptedTerm" "r" "term";;
      (if: MonotonicValue__GreaterThan "v" (struct.loadF Replica "acceptedMVal" "r")
      then struct.storeF Replica "acceptedMVal" "r" "v"
      else #());;
      lock.release (struct.loadF Replica "mu" "r");;
      ENone
    else
      lock.release (struct.loadF Replica "mu" "r");;
      ETermStale).

Definition Replica__TryBecomeLeader: val :=
  rec: "Replica__TryBecomeLeader" "r" :=
    lock.acquire (struct.loadF Replica "mu" "r");;
    let: "newTerm" := struct.loadF Replica "promisedTerm" "r" + #1 in
    struct.storeF Replica "promisedTerm" "r" "newTerm";;
    let: "highestTerm" := ref (zero_val uint64T) in
    "highestTerm" <-[uint64T] #0;;
    let: "highestVal" := ref (zero_val ptrT) in
    "highestVal" <-[ptrT] struct.loadF Replica "acceptedMVal" "r";;
    let: "conf" := struct.loadF MonotonicValue "conf" (struct.loadF Replica "acceptedMVal" "r") in
    lock.release (struct.loadF Replica "mu" "r");;
    let: "mu" := lock.new #() in
    let: "prepared" := NewMap boolT #() in
    Config__ForEachMember "conf" ((λ: "addr",
      Fork (let: "reply_ptr" := struct.alloc PrepareReply (zero_val (struct.t PrepareReply)) in
            ClerkPool__PrepareRPC (struct.loadF Replica "clerkPool" "r") "addr" "newTerm" "reply_ptr";;
            (if: (struct.loadF PrepareReply "Err" "reply_ptr" = ENone)
            then
              lock.acquire "mu";;
              MapInsert "prepared" "addr" #true;;
              (if: struct.loadF PrepareReply "Term" "reply_ptr" > ![uint64T] "highestTerm"
              then "highestVal" <-[ptrT] struct.loadF PrepareReply "Val" "reply_ptr"
              else
                (if: (struct.loadF PrepareReply "Term" "reply_ptr" = ![uint64T] "highestTerm")
                then
                  (if: MonotonicValue__GreaterThan (![ptrT] "highestVal") (struct.loadF PrepareReply "Val" "reply_ptr")
                  then "highestVal" <-[ptrT] struct.loadF PrepareReply "Val" "reply_ptr"
                  else #())
                else #()));;
              lock.release "mu"
            else #()));;
      #()
      ));;
    time.Sleep (#50 * #1000000);;
    lock.acquire "mu";;
    (if: IsQuorum (struct.loadF MonotonicValue "conf" (![ptrT] "highestVal")) "prepared"
    then
      lock.acquire (struct.loadF Replica "mu" "r");;
      (if: (struct.loadF Replica "promisedTerm" "r" = "newTerm")
      then
        struct.storeF Replica "acceptedMVal" "r" (![ptrT] "highestVal");;
        struct.storeF Replica "isLeader" "r" #true
      else #());;
      lock.release (struct.loadF Replica "mu" "r");;
      lock.release "mu";;
      #true
    else
      lock.release "mu";;
      #false).

(* Returns true iff there was an error;
   The error is either that r is not currently a primary, or that r was unable
   to commit the value within one round of commits.

   mvalModifier is not allowed to modify the version number in the given mval. *)
Definition Replica__tryCommit: val :=
  rec: "Replica__tryCommit" "r" "mvalModifier" "reply" :=
    lock.acquire (struct.loadF Replica "mu" "r");;
    (if: ~ (struct.loadF Replica "isLeader" "r")
    then
      lock.release (struct.loadF Replica "mu" "r");;
      struct.storeF TryCommitReply "err" "reply" ENotLeader;;
      #()
    else
      "mvalModifier" (struct.loadF Replica "acceptedMVal" "r");;
      (* log.Printf("Trying to commit value; node state: %+v\n", r) *)
      struct.storeF MonotonicValue "version" (struct.loadF Replica "acceptedMVal" "r") (struct.loadF MonotonicValue "version" (struct.loadF Replica "acceptedMVal" "r") + #1);;
      let: "term" := struct.loadF Replica "promisedTerm" "r" in
      let: "mval" := struct.loadF Replica "acceptedMVal" "r" in
      lock.release (struct.loadF Replica "mu" "r");;
      let: "mu" := lock.new #() in
      let: "accepted" := NewMap boolT #() in
      Config__ForEachMember (struct.loadF MonotonicValue "conf" "mval") ((λ: "addr",
        Fork ((if: ClerkPool__ProposeRPC (struct.loadF Replica "clerkPool" "r") "addr" "term" "mval"
              then
                lock.acquire "mu";;
                MapInsert "accepted" "addr" #true;;
                lock.release "mu"
              else #()));;
        #()
        ));;
      time.Sleep (#100 * #1000000);;
      lock.acquire "mu";;
      (if: IsQuorum (struct.loadF MonotonicValue "conf" "mval") "accepted"
      then
        struct.storeF TryCommitReply "err" "reply" ENone;;
        struct.storeF TryCommitReply "version" "reply" (struct.loadF MonotonicValue "version" "mval")
      else struct.storeF TryCommitReply "err" "reply" EQuorumFailed);;
      (* log.Printf("Result of trying to commit: %+v\n", reply) *)
      #()).

Definition Replica__TryCommitVal: val :=
  rec: "Replica__TryCommitVal" "r" "v" "reply" :=
    lock.acquire (struct.loadF Replica "mu" "r");;
    (if: ~ (struct.loadF Replica "isLeader" "r")
    then
      lock.release (struct.loadF Replica "mu" "r");;
      Replica__TryBecomeLeader "r"
    else lock.release (struct.loadF Replica "mu" "r"));;
    Replica__tryCommit "r" ((λ: "mval",
      struct.storeF MonotonicValue "val" "mval" "v";;
      #()
      )) "reply";;
    #().

(* requires that newConfig has overlapping quorums with r.config *)
Definition Replica__TryEnterNewConfig: val :=
  rec: "Replica__TryEnterNewConfig" "r" "newMembers" :=
    let: "reply" := struct.alloc TryCommitReply (zero_val (struct.t TryCommitReply)) in
    Replica__tryCommit "r" ((λ: "mval",
      (if: (slice.len (struct.loadF Config "NextMembers" (struct.loadF MonotonicValue "conf" "mval")) = #0)
      then
        struct.storeF Config "NextMembers" (struct.loadF MonotonicValue "conf" "mval") "newMembers";;
        #()
      else #())
      )) "reply";;
    Replica__tryCommit "r" ((λ: "mval",
      (if: slice.len (struct.loadF Config "NextMembers" (struct.loadF MonotonicValue "conf" "mval")) ≠ #0
      then
        struct.storeF Config "Members" (struct.loadF MonotonicValue "conf" "mval") (struct.loadF Config "NextMembers" (struct.loadF MonotonicValue "conf" "mval"));;
        struct.storeF Config "NextMembers" (struct.loadF MonotonicValue "conf" "mval") (NewSlice uint64T #0);;
        #()
      else #())
      )) "reply";;
    #().

Definition StartReplicaServer: val :=
  rec: "StartReplicaServer" "me" "initConfig" :=
    let: "s" := struct.alloc Replica (zero_val (struct.t Replica)) in
    struct.storeF Replica "mu" "s" (lock.new #());;
    struct.storeF Replica "promisedTerm" "s" #0;;
    struct.storeF Replica "acceptedTerm" "s" #0;;
    struct.storeF Replica "acceptedMVal" "s" (struct.alloc MonotonicValue (zero_val (struct.t MonotonicValue)));;
    struct.storeF MonotonicValue "conf" (struct.loadF Replica "acceptedMVal" "s") "initConfig";;
    struct.storeF Replica "clerkPool" "s" (MakeClerkPool #());;
    struct.storeF Replica "isLeader" "s" #false;;
    let: "handlers" := NewMap ((slice.T byteT -> ptrT -> unitT)%ht) #() in
    MapInsert "handlers" RPC_PREPARE ((λ: "args" "raw_reply",
      let: ("term", <>) := marshal.ReadInt "args" in
      let: "reply" := struct.alloc PrepareReply (zero_val (struct.t PrepareReply)) in
      Replica__PrepareRPC "s" "term" "reply";;
      "raw_reply" <-[slice.T byteT] EncPrepareReply (NewSlice byteT #0) "reply";;
      DecPrepareReply (![slice.T byteT] "raw_reply");;
      #()
      ));;
    MapInsert "handlers" RPC_PROPOSE ((λ: "raw_args" "raw_reply",
      let: ("args", <>) := DecProposeArgs "raw_args" in
      let: "reply" := Replica__ProposeRPC "s" (struct.loadF ProposeArgs "Term" "args") (struct.loadF ProposeArgs "Val" "args") in
      "raw_reply" <-[slice.T byteT] marshal.WriteInt (NewSliceWithCap byteT #0 #8) "reply";;
      #()
      ));;
    MapInsert "handlers" RPC_TRY_COMMIT_VAL ((λ: "raw_args" "raw_reply",
      (* log.Println("RPC_TRY_COMMIT_VAL") *)
      let: "val" := "raw_args" in
      let: "reply" := struct.alloc TryCommitReply (zero_val (struct.t TryCommitReply)) in
      Replica__TryCommitVal "s" "val" "reply";;
      "raw_reply" <-[slice.T byteT] marshal.WriteInt (NewSliceWithCap byteT #0 #8) (struct.loadF TryCommitReply "err" "reply");;
      #()
      ));;
    MapInsert "handlers" RPC_TRY_CONFIG_CHANGE ((λ: "raw_args" "raw_reply",
      let: ("args", <>) := DecMembers "raw_args" in
      Replica__TryEnterNewConfig "s" "args";;
      "raw_reply" <-[slice.T byteT] NewSlice byteT #0;;
      #()
      ));;
    let: "r" := urpc.MakeServer "handlers" in
    urpc.Server__Serve "r" "me";;
    #().


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e384m317_17limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Set Warnings "-notation-overridden,-parsing".

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div ssralg.
From Tweetnacl.High Require Import mc.
From Tweetnacl.High Require Import mcgroup.
From Tweetnacl.High Require Import ladder.
From Tweetnacl.High Require Import montgomery.
From Tweetnacl.High Require Export opt_ladder.

From Tweetnacl.Gen Require Import Get_abcdef.

Import GRing.Theory.

Local Open Scope ring_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Section OptimizedLadder.
  Variable K : finECUFieldType.
  Variable M : mcuType K.

  Fixpoint opt_montgomery_rec_extr (n m : nat) (x a b c d : K) : (K * K * K * K * K * K) :=
    if m is m.+1 then
      let (a, b) := cswap (bitn n m) a b in
      let (c, d) := cswap (bitn n m) c d in
      let e := a + c in
      let a := a - c in
      let c := b + d in
      let b := b - d in
      let d := e^+2 in
      let f := a^+2 in
      let a := c * a in
      let c := b * e in
      let e := a + c in
      let a := a - c in
      let b := a^+2 in
      let c := d - f in
      let a := c * ((M#a - 2%:R) / 4%:R) in
      let a := a + d in
      let c := c * a in
      let a := d * f in
      let d := b * x in
      let b := e^+2 in
      let (a, b) := cswap (bitn n m) a b in
      let (c, d) := cswap (bitn n m) c d in
      opt_montgomery_rec_extr n m x a b c d
    else
      (a,0,c,0,0,0).

Lemma opt_montgomery_rec_equiv:
  forall m n x a b c d,
  opt_montgomery_rec M n m x a b c d = get_a (opt_montgomery_rec_extr n m x a b c d) * (get_c (opt_montgomery_rec_extr n m x a b c d))^-1.
Proof.
elim => [|m IHm] n x a b c d //=.
by do! case: (cswap _ _ _) => *.
(* or... *)
(* by repeat match goal with
  | [|- context[(cswap (bitn ?N ?M) ?A ?B)] ] => let H := fresh "H" in destruct (cswap (bitn N M) A B) eqn:H; rewrite ?H
end. *)
Qed.

End OptimizedLadder.


(** this file contains the simulations used to proof our logic soundness, we build three levels of simulations to support mudular reasoning of function calls and interrupts  **)

Require Import include_frm.

CoInductive ProgSim :   lprog -> tasks -> osstate  -> hprog -> tasks -> osabst -> clientst -> tid -> Prop:=
| prog_sim:
    forall (pl:lprog) (ph:hprog) (Tl Th:tasks) (S:osstate) (O:osabst) (cst:clientst) t,
      get O curtid = Some (oscurt t) ->
      (
        forall Tl' S' cst' t',
          lpstep pl Tl cst S t Tl' cst' S' t'->
          exists Th' O', hpstepstar ph Th cst O Th' cst' O' /\
                         (ProgSim pl Tl' S' ph Th' O' cst' t')
      ) ->
      (
        forall Tl' S' cst' ev t',
          lpstepev pl Tl cst S t Tl' cst' S' t' ev ->
          exists Th' O', hpstepevstar ph Th cst O Th' cst' O' ev /\
                         (ProgSim pl Tl' S' ph Th' O' cst' t' )
      )->
      (
        lpstepabt pl Tl cst S t-> hpstepabtstar ph Th cst O
      )
      -> ProgSim pl Tl S ph Th O cst t.

Definition reltaskpred := prod taskst osabst -> Prop.

(*  (EX tp : type, GV OSTCBCur @ Tptr tp |-r-> Vptr t) ** p t lg ** [|GoodLInvAsrt p|].*)

Definition getmem (o:taskst) :=  get_mem (get_smem o).

Definition getapi (pl : lprog) := (fst (fst (snd pl))).

Definition getifun (pl : lprog) := (snd (fst (snd pl))).

Definition getsched (ph: hprog) := (snd (snd ph)).

Definition joinm2 o M1 M2  o' :=   exists o1,  joinmem o M1  o1 /\  joinmem o1 M2 o' .

CoInductive TaskSim:
  lprog -> code -> taskst -> hprog -> code -> osabst ->
  LocalInv -> Inv -> reltaskpred -> tid -> Prop :=
| task_sim :
    forall (pl:lprog) (ph:hprog) (Cl Ch:code) (o:taskst) (O:osabst)
           (t:tid) lasrt (I:Inv) (P:reltaskpred),
      (
        forall Cl' Ms Mf cst cst' o'' Os  o2  OO,
          satp (substaskst o  Ms) Os (INV I)->
          joinm2 o Ms Mf o2 ->
          join O Os OO ->
          ltstep pl t Cl cst o2 Cl' cst' o'' ->
          (
            exists Ch' OO'  o'  Ms'  O' Os',
              htstepstar ph t Ch cst OO Ch' cst' OO'/\
              joinm2 o' Ms' Mf o'' /\
              join O' Os' OO' /\
              satp (substaskst o' Ms') Os' (INV I) /\
              satp  o' O' (CurLINV lasrt t)  /\
              TaskSim pl Cl' o' ph Ch' O'  lasrt I P t
          )
      )->
      (
        forall Cl' Ms Mf cst cst' o'' Os  o2  OO ev,
          satp (substaskst o  Ms) Os (INV I)->
          joinm2 o Ms Mf o2 ->
          join O Os OO ->
          ltstepev pl t Cl cst o2 Cl' cst' o'' ev->
          (
            exists Ch' OO'  o'  Ms'  O' Os',
              htstepevstar ph t Ch cst OO Ch' cst' OO' ev /\
              joinm2 o' Ms' Mf o'' /\
              join O' Os' OO' /\
              satp (substaskst o' Ms') Os' (INV I) /\
              satp  o' O' (CurLINV lasrt t)  /\
              TaskSim pl Cl' o' ph Ch' O'  lasrt I P t
          )
      )->
      (
        forall   Ms ks x Os OO,
          Cl = (curs (sprim (switch x)), (kenil, ks)) ->
          (*InOS Cl (pumerge (getapi pl) (getifun pl))->*)
          satp (substaskst o Ms)  Os  (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists Ch' s k  OO'  Mc ol O' Os' Ol Oc ,
              Ch' = (curs (hapi_code (spec_seq sched s)),k) /\
              (forall cst, htstepstar ph t Ch cst OO Ch' cst OO')  /\
              joinmem ol Mc o /\
              join O' Os' OO'/\
              join Ol Oc O' /\
              satp (substaskst o Ms) Os'  (INV I) /\
              satp  (substaskst o Mc) Oc (SWINVt I t) /\
              satp ol Ol  (EX lg', LINV lasrt t lg' ** Atrue) /\
              (
                (
                  satp (substaskst o Mc) Oc (SWPRE_NDEAD (getsched ph) x t) /\
                  (
                    forall Mc' Oc' o' O'',
                      satp  (substaskst o Mc') Oc' (SWINVt I t) ->
                      joinmem ol Mc' o' ->
                      join Ol Oc' O'' ->
                      TaskSim pl  (SKIP, (kenil, ks))  o'  ph (curs (hapi_code s),k) O''  lasrt I P t
                  )
                )
                \/

                satp (substaskst o Mc) Oc (SWPRE_DEAD (getsched ph) x t)
              )
          )
      )->
      (*
      (
        forall  Ms ks x Os OO,
          Cl = (curs (sprim (switch x)), (kenil, ks)) ->
          InOS Cl (pumerge (getapi pl) (getifun pl))->
          satp (substaskst o  Ms) Os  (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO  ->
          (
            exists Ch' s k OO' Mc ol O' Os' Ol Oc,
              Ch' = (curs (hapi_code (spec_seq sched s)),k) /\
              (forall cst, htstepstar ph t Ch cst OO Ch' cst OO') /\
              joinmem ol Mc o /\
              join O' Os' OO'/\
              join Ol Oc  O' /\
              satp (substaskst o Ms) Os'  (INV I) /\
              satp (substaskst o Mc) Oc  (SWINVt I t) /\
              satp (substaskst o Mc) Oc (SWPRE_DEAD t)  /\
              satp ol Ol  (EX lg', LINV lasrt t lg' ** Atrue)
          )
      )->*)
      (
        forall Ms Os OO,
          IsEnd Cl ->
          satp (substaskst o Ms) Os  (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists O' Os' Ch OO',
              IsEnd Ch /\
              (forall cst, htstepstar ph t Ch cst OO Ch cst OO') /\
              join O' Os' OO'/\
              satp (substaskst o  Ms) Os' (INV I) /\
              satp o O (CurLINV lasrt t) /\
              P (o, O')
          )
      )->
      (
        forall cst o' Ms Os Mf OO Of OOO,
          ~(IsEnd Cl) ->
          ~(IsSwitch Cl) ->
          ~(IsStkInit Cl)->
          ~(IsStkFree Cl) ->
          satp (substaskst o Ms)  Os  (INV I) ->
          joinm2 o Ms  Mf o' ->
          join O Os OO ->
          join OO Of OOO ->
          ltstepabt pl t Cl cst o' ->
          htstepabtstar ph t Ch cst OOO
      )->
      (
        forall  Ms Os e1 e2 e3 ks OO,
          Cl = (curs (sprim (stkinit e1 e2 e3)),(kenil,ks))->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists Ch'  v1 v2  t' p s k   OO' OO''  ,
              exists ol Mcre O' Os' Ol Ocre ,
                Ch' = (curs (hapi_code (spec_seq (spec_crt v1 v2 (Vint32 p)) s)), k) /\
                evalval e1 (get_smem o) = Some v1  /\
                evalval e2 (get_smem o) = Some v2 /\
                evalval e3 (get_smem o) = Some (Vptr t') /\
                (forall cst, htstepstar ph t Ch cst OO Ch' cst OO')  /\
                abs_crt_step OO' OO'' t t' p /\
                joinmem ol Mcre o /\
                join O' Os' OO'' /\
                join Ol Ocre O' /\
                satp (substaskst o Ms) Os' (INV I) /\
                satp ol Ol (CurLINV lasrt t) /\
                satp (substaskst o Mcre) Ocre (lasrt t' init_lg**[|GoodLInvAsrt lasrt|]) /\
                TaskSim pl  (SKIP,(kenil,ks))  ol ph  (curs (hapi_code s),k) Ol  lasrt I P t
          )
      )->
      (*
      (
        forall Cl  Ms  Os e ks OO,
          Cl = (curs (sprim (stkfree e)),(kenil,ks))->
          evalval e (get_smem o) = Some (Vptr t) ->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms  ->
          join O Os OO->
          (
            exists Ch' p s k  OO' OO'' O' Os',
              Ch' = (curs (hapi_code (spec_seq (spec_del (Vint32 p)) s)),k) /\
              (forall cst, htstepstar ph t Ch cst OO Ch' cst OO')  /\
              abs_delself_step OO' OO'' t p /\
              join O' Os' OO'' /\
              satp (substaskst o Ms) Os'  (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              TaskSim pl (SKIP ,(kenil,ks))  o ph  (curs (hapi_code s),k)   O' lasrt I P t
          )
      )->
       *)
      (
        forall Ms  Os e ks  OO,
          Cl = (curs (sprim (stkfree e)),(kenil,ks))->
          satp (substaskst o Ms) Os  (INV I) ->
          disjoint (getmem o) Ms  ->
          join O Os  OO->
          (
            exists Ch' p s k t' OO' OO''  O' Os' ,
              Ch' = (curs (hapi_code (spec_seq (spec_del (Vint32 p)) s)),k) /\
              evalval e (get_smem o) = Some (Vptr t')  /\
              (forall cst, htstepstar ph t Ch cst OO Ch' cst OO') /\
              (
                (
                  abs_delself_step OO' OO'' t t' p /\
                  join O' Os' OO'' /\
                  satp (substaskst o Ms) Os' (INV I) /\
                  satp o O' (CurLINV lasrt t) /\
                  TaskSim pl (SKIP ,(kenil,ks))  o ph  (curs (hapi_code s),k)   O' lasrt I P t
                )
                \/
                (
                  abs_delother_step OO' OO'' t t' p /\
                  join O' Os' OO'' /\
                  satp (substaskst o Ms) Os' (INV I) /\
                  satp o O' (CurLINV lasrt t) /\
                  forall o' O'' Mdel Odel,
                    (
                      satp (substaskst o Mdel) Odel  (EX lg, LINV lasrt t' lg)  ->
                      joinmem o Mdel o' ->
                      join O' Odel O'' ->
                      TaskSim pl  (SKIP, (kenil,ks))  o' ph  (curs (hapi_code s),k)  O''  lasrt I P t
                    )
                )
              )
          )
      )->
      TaskSim pl Cl o ph Ch O  lasrt I P t.

Definition TaskSimAsrt
           (pl:lprog) (Cl:code) (ph:hprog) (Ch:code)
           (t:tid) lasrt (I:Inv) (P:reltaskpred):Prop:=
  forall (o:taskst) (O:osabst),
    P (o, O)  /\  satp o O (CurLINV lasrt t)  -> TaskSim pl Cl o ph Ch O lasrt I P t.

(*
Definition TcbBJ (tls : TcbMod.map) :=
  (
    forall t t' pr a pr' a' msg msg',
     t<>t' ->
     get tls t = Some (pr,a,msg)->
     get tls t' = Some (pr',a',msg') ->
     pr <>   pr'
  )
  /\
  (
    forall t t' pr a pr' a' msg msg',
     pr<>pr' ->
     get tls t = Some (pr,a,msg) ->
     get tls t' = Some (pr',a',msg') ->
     t <> t'
  ).
 *)

Definition notabort (C:code):=
  ~IsSwitch C /\ ~IsEnd C /\
  ~ IsRet C /\ ~IsRetE C /\ ~IsIRet C /\
  ~IsStkInit C /\
  ~IsStkFree C.

Definition notabortm (C:code):= ~IsFcall C /\ notabort C.

CoInductive MethSimMod : funspec -> ossched ->  code -> taskst -> absop -> osabst  -> LocalInv ->
                         Inv -> retasrt -> asrt -> retasrt -> tid -> Prop :=
| meth_sim_mod :
    forall (spec :funspec) sd (C:code)
           (gamma:absop) (O:osabst) t lasrt (I:Inv)
           (r q : retasrt) (ri: asrt)  (o:taskst) ,
      (
        forall p C' Ms Mf Os OO o2 o2',
          ~IsFcall C ->
          satp (substaskst o Ms) Os (INV I) ->
          joinm2 o Ms Mf o2 ->
          join O Os OO ->
          loststep p C o2 C' o2' ->
          (
            exists gamma' OO'  o' Ms'  O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              joinm2 o' Ms' Mf o2' /\
              join O' Os' OO' /\
              satp (substaskst o'  Ms') Os' (INV I)/\
              satp o' O' (CurLINV lasrt t) /\
              MethSimMod spec sd C' o' gamma' O' lasrt I r ri q t
          )
      )->
      (
        forall Ms Os ks f vl tl OO,
          C = (curs (sfexec f vl tl), (kenil,ks)) ->
          satp (substaskst o  Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' om M O' Os' Ot Of ,
              exists pre post tp logicl,
                hmstepstar sd gamma OO gamma' OO' /\
                joinmem om M o /\
                join O' Os' OO' /\
                join Ot Of O'/\
                tl_vl_match tl vl = true /\
                spec f = Some (pre, post,  (tp ,List.rev tl)) /\
                sat (om, Ot, gamma') (getasrt (pre (rev vl) logicl t)) /\
                satp om Ot (CurLINV lasrt t) /\
                satp (substaskst o Ms) Os' (INV I) /\
                (
                  forall o1 O1  v gamma'',
                    sat (o1,O1,gamma'') (getasrt (post (rev vl) v logicl t)) ->
                    (
                      satp o1 O1 (CurLINV lasrt t) /\
                      (
                        forall o' O'',
                          (* satp o' O'' (CurLINV lasrt t) -> *)
                          joinmem o1 M o' ->
                          join O1 Of O'' ->
                          eqenv o o' ->
                          MethSimMod spec sd (curs (sskip v), (kenil,ks)) o' gamma'' O'' lasrt I r ri q t
                      )
                    )
                )
          )
      )->
      (*
      (
        forall  Ms ks x Os OO,
          C = (curs (sprim (switch x)), (kenil, ks)) ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' s OO' ol Mc O' Os' Ol Oc,
              gamma' = spec_seq sched s /\
              hmstepstar sd gamma OO gamma' OO' /\
              joinmem ol Mc o /\
              join O' Os' OO'/\
              join Ol Oc O' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp (substaskst o Mc)  Oc (SWINVt I t) /\
              satp ol Ol  (EX lg', LINV lasrt t lg' ** Atrue) /\
              satp (substaskst o Mc) Oc (SWPRE sd x t)  /\
              (
                forall Mc' Oc' o' O'',
                  satp (substaskst o  Mc') Oc' (SWINVt I t)->
                  joinmem ol Mc' o' ->
                  join Ol Oc' O'' ->
                  MethSimMod spec sd (SKIP, (kenil, ks))  o' s O'' lasrt I r ri q t
              )
          )
      )->*)
      (
        forall Ms ks x Os OO,
          C = (curs (sprim (switch x)), (kenil, ks)) ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' s OO' ol Mc O' Os' Ol Oc,
              gamma' = spec_seq sched s /\
              hmstepstar sd gamma OO gamma' OO' /\
              joinmem ol Mc o /\
              join O' Os' OO'/\
              join Ol Oc  O' /\
              satp (substaskst o Ms) Os'  (INV I) /\
              satp (substaskst o Mc) Oc  (SWINVt I t) /\
              satp ol Ol  (EX lg', LINV lasrt t lg' ** Atrue) /\
              (
                (
                  satp (substaskst o Mc) Oc (SWPRE_NDEAD sd x t)  /\
                  (
                    forall Mc' Oc' o' O'',
                      satp (substaskst o  Mc') Oc' (SWINVt I t)->
                      joinmem ol Mc' o' ->
                      join Ol Oc' O'' ->
                      MethSimMod spec sd (SKIP, (kenil, ks))  o' s O'' lasrt I r ri q t
                  )
                )

                \/

                satp (substaskst o Mc) Oc  (SWPRE_DEAD sd x t)
              )
          )
      )->

      (
        forall v Ms Os OO,
          C = (curs (sskip v), (kenil, kstop)) ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') (q v)
          )
      )->

      (
        forall ks Os Ms OO,
          C = (curs sret, (kenil, ks)) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I)/\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') (r None)
          )
      )->

      (
        forall ks Os Ms v OO,
          C = ([v], (kenil, (kret ks))) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'), gamma')  (r (Some v))
          )
      )->

      (
        forall ks Os Ms OO,
          C = (curs (sprim exint), (kenil, ks)) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists  gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I)/\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') ri
          )
      )->
      (
        forall p Os Ms Mf o2 ,
          notabortm C ->
          satp (substaskst o Ms) Os (INV I) ->
          joinm2 o Ms Mf o2 ->
          disjoint O Os ->
          ~ (loststepabt p C o2)
      )->
      (
        forall  Ms Os e1 e2 e3 ks  OO,
          C = (curs (sprim (stkinit e1 e2 e3)),(kenil,ks))->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' v1 v2 t' p s  OO'  OO'' ol ,
              exists Mcre O' Os' Ol Ocre ,
                gamma' = (spec_seq (spec_crt v1 v2 (Vint32 p)) s) /\
                evalval e1 (get_smem o) = Some v1 /\
                evalval e2 (get_smem o) = Some v2 /\
                evalval e3 (get_smem o) = Some (Vptr t') /\
                hmstepstar sd gamma OO gamma' OO' /\
                abs_crt_step OO' OO'' t t' p /\
                joinmem ol Mcre o /\
                join O' Os' OO'' /\
                join Ol Ocre O' /\
                satp (substaskst o Ms) Os' (INV I) /\
                satp ol Ol (CurLINV lasrt t) /\
                satp (substaskst o Mcre) Ocre (lasrt t' init_lg**[|GoodLInvAsrt lasrt|]) /\
                MethSimMod spec sd  (SKIP, (kenil,ks))  ol s Ol lasrt I r ri q t
          )
      )->
      (
        forall  Ms Os e ks OO,
          C = (curs (sprim (stkfree e)),(kenil,ks))->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms  ->
          join O Os OO->
          (
            exists gamma' p s t'  OO' ,
              gamma' = (spec_seq (spec_del (Vint32 p)) s) /\
              evalval e (get_smem o) = Some (Vptr t')  /\
              hmstepstar sd gamma OO gamma' OO' /\
              (
                (
                  exists OO'' O' Os',
                    abs_delself_step OO' OO'' t t' p /\
                    join O' Os' OO'' /\
                    satp (substaskst o Ms) Os'  (INV I) /\
                    satp o O' (CurLINV lasrt t) /\
                    MethSimMod spec sd  (SKIP, (kenil,ks))  o s O' lasrt I r ri q t
                )
                \/
                (
                  exists OO'' O' Os',
                    abs_delother_step OO' OO'' t t' p /\
                    join O' Os' OO'' /\
                    satp (substaskst o Ms) Os' (INV I) /\
                    satp o O' (CurLINV lasrt t) /\
                    forall o' O'' Mdel Odel,
                      (
                        satp (substaskst o Mdel) Odel  (EX lg, LINV lasrt t' lg)  ->
                        joinmem o Mdel o' ->
                        join O' Odel O'' ->
                        MethSimMod spec sd  (SKIP, (kenil,ks))  o' s O''  lasrt I r ri q t
                      )
                )
              )
          )
      )->
      (*
      (
        forall  Ms Os e ks t' OO,
          C = (curs (sprim (stkfree e)),(kenil,ks))->
          evalval e (get_smem o) = Some (Vptr t') ->
          satp (substaskst o Ms) Os  (INV I) ->
          disjoint (getmem o) Ms  ->
          join O Os  OO->
          (
            exists gamma' p s OO' OO'' O' Os' ,
              gamma' = (spec_seq (spec_del (Vint32 p)) s) /\
              hmstepstar sd gamma OO gamma' OO' /\
              abs_delother_step OO' OO' t t' p /\
              join O' Os' OO'' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              forall o' O'' Mdel Odel,
                (
                  satp (substaskst o Mdel) Odel  (EX lg, LINV lasrt t' lg)  ->
                  joinmem o Mdel o' ->
                  join O' Odel O'' ->
                  MethSimMod spec sd  (SKIP, (kenil,ks))  o' s O''  lasrt I r ri q t
                )
          )
      )->
       *)
      MethSimMod spec sd C o gamma O lasrt I r ri q t.

Notation "  '{[' p , sd , li , I , r , ri , q  ']}'  '||-' t '(' C , o ')'  '<_msim' '(' gamma ,  O  ')' "
  :=  (MethSimMod p sd  C o gamma O li I r ri q t) (at level 200).

CoInductive MethSim : progunit -> ossched -> code -> taskst -> absop -> osabst -> LocalInv ->
                      Inv -> retasrt -> asrt -> retasrt -> tid -> Prop :=
| meth_sim :
    forall (p:progunit) sd (C:code)
           (gamma:absop) (O:osabst) (I:Inv)
           (r q: retasrt) (ri: asrt)  (o:taskst) t lasrt,
      (
        forall  C' Ms Mf Os OO o2 o2',
          satp (substaskst o Ms) Os (INV I) ->
          joinm2 o Ms Mf o2 ->
          join O Os OO ->
          loststep p C o2 C' o2' ->
          (
            exists gamma' OO'  o' Ms'  O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              joinm2 o' Ms' Mf o2' /\
              join O' Os' OO' /\
              satp (substaskst o'  Ms') Os' (INV I)/\
              satp o' O' (CurLINV lasrt t) /\
              MethSim p sd C' o' gamma' O' lasrt I r ri q t
          )
      )->
      (
        forall  Ms ks x Os OO,
          C = (curs (sprim (switch x)), (kenil, ks)) ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' s OO' ol Mc O' Os' Ol Oc,
              gamma' = spec_seq sched s /\
              hmstepstar sd gamma OO gamma' OO' /\
              joinmem ol Mc o /\
              join O' Os' OO'/\
              join Ol Oc O' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp (substaskst o Mc)  Oc (SWINVt I t) /\
              satp ol Ol  (EX lg', LINV lasrt t lg' ** Atrue) /\
              (
                (
                  satp (substaskst o Mc) Oc (SWPRE_NDEAD sd x t)  /\
                  (
                    forall Mc' Oc' o' O'',
                      satp (substaskst o  Mc') Oc' (SWINVt I t)->
                      joinmem ol Mc' o' ->
                      join Ol Oc' O'' ->
                      MethSim p sd (SKIP, (kenil, ks))  o' s O'' lasrt I r ri q t
                  )
                )
                \/

                satp (substaskst o Mc) Oc (SWPRE_DEAD sd x t)
              )
          )
      )->
      (
        forall v Ms Os OO,
          C = (curs (sskip v), (kenil, kstop)) ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') (q v)
          )
      )->
      (
        forall ks Os Ms OO,
          C = (curs sret, (kenil, ks)) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I)->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I)/\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') (r None)
          )
      )->
      (
        forall ks Os Ms v OO,
          C = ([v], (kenil, (kret ks))) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I) /\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'), gamma')  (r (Some v))
          )
      )->
      (
        forall ks Os Ms OO,
          C = (curs (sprim exint), (kenil, ks)) ->
          callcont ks = None ->
          intcont ks =None ->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists  gamma' OO' O' Os',
              hmstepstar sd gamma OO gamma' OO' /\
              join O' Os' OO' /\
              satp (substaskst o Ms) Os' (INV I)/\
              satp o O' (CurLINV lasrt t) /\
              sat ((o, O'),gamma') ri
          )
      )->
      (
        forall  Os Ms Mf o2 ,
          notabort C ->
          satp (substaskst o Ms) Os (INV I) ->
          joinm2 o Ms Mf o2 ->
          disjoint O Os ->
          ~ (loststepabt p C o2)
      )->
      (
        forall  Ms Os e1 e2 e3 ks  OO,
          C = (curs (sprim (stkinit e1 e2 e3)),(kenil,ks))->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms ->
          join O Os OO ->
          (
            exists gamma' v1 v2 t' pri s  OO'  OO'' ol ,
              exists Mcre O' Os' Ol Ocre ,
                gamma' = (spec_seq (spec_crt v1 v2 (Vint32 pri)) s) /\
                evalval e1 (get_smem o) = Some v1 /\
                evalval e2 (get_smem o) = Some v2  /\
                evalval e3 (get_smem o) = Some (Vptr t')  /\
                hmstepstar sd gamma OO gamma' OO' /\
                abs_crt_step OO' OO'' t t' pri /\
                joinmem ol Mcre o /\
                join O' Os' OO'' /\
                join Ol Ocre O' /\
                satp (substaskst o Ms) Os' (INV I) /\
                satp ol Ol (CurLINV lasrt t) /\
                satp (substaskst o Mcre) Ocre (lasrt t' init_lg**[|GoodLInvAsrt lasrt|]) /\
                MethSim p sd  (SKIP, (kenil,ks))  ol s Ol lasrt I r ri q t
          )
      )->
      (
        forall  Ms Os e ks OO,
          C = (curs (sprim (stkfree e)),(kenil,ks))->
          satp (substaskst o Ms) Os (INV I) ->
          disjoint (getmem o) Ms  ->
          join O Os OO->
          (
            exists gamma' pri s t'  OO' OO'' O' Os' ,
              gamma' = (spec_seq (spec_del (Vint32 pri)) s) /\
              evalval e (get_smem o) = Some (Vptr t')  /\
              hmstepstar sd gamma OO gamma' OO' /\
              (
                (
                  abs_delself_step OO' OO'' t t' pri /\
                  join O' Os' OO'' /\
                  satp (substaskst o Ms) Os'  (INV I) /\
                  satp o O' (CurLINV lasrt t) /\
                  MethSim  p  sd  (SKIP, (kenil,ks))  o s O' lasrt I r ri q t
                )
                \/
                (
                  abs_delother_step OO' OO'' t t' pri /\
                  join O' Os' OO'' /\
                  satp (substaskst o Ms) Os' (INV I) /\
                  satp o O' (CurLINV lasrt t) /\
                  forall o' O'' Mdel Odel,
                    (
                      satp (substaskst o Mdel) Odel  (EX lg, LINV lasrt t' lg)  ->
                      joinmem o Mdel o' ->
                      join O' Odel O'' ->
                      MethSim  p  sd  (SKIP, (kenil,ks))  o' s O''  lasrt I r ri q t
                    )
                )
              )
          )
      )->
      MethSim p sd C o gamma O lasrt I r ri q t.

Lemma buldp_some_imp_gooddecl : forall dl vl p, buildp dl vl = Some p -> good_decllist dl = true .
Proof.
  introv Hbul.
  inductions dl.
  simpl; auto.
  simpl.
  simpl in Hbul.
  remember (negb (in_decllist i dl) && good_decllist dl) as H.
  apply sym_eq in HeqH.
  destruct H.
  auto.
  inverts Hbul.
Qed.

Definition RuleSem (spec : funspec) (sd : ossched) lasrt (I:Inv) (r:retasrt) (ri:asrt)
           (p:asrt) (s:stmts)  (q:asrt) t :Prop:=
  forall o O aop,  (sat ((o, O),aop) p /\  satp o O  (CurLINV lasrt t))  ->
                   MethSimMod spec sd (nilcont s) o aop O lasrt I r ri (lift q) t.

Definition MethSimAsrt (P : progunit) (sd:ossched) lasrt (I:Inv) (r:retasrt) (ri:asrt)
           (p:asrt) (s:stmts)  (q:asrt) t :Prop:=
  forall o O aop, (sat ((o, O),aop) p /\  satp o O  (CurLINV lasrt t))  ->
                  MethSim P sd (nilcont s) o aop O lasrt I r ri (lift q) t.

Definition WFFuncsSim (P:progunit) (FSpec:funspec) (sd:ossched) lasrt (I:Inv) :Prop:=
  EqDom P FSpec /\
  forall f pre post t tl,
    FSpec f = Some (pre, post, (t, tl)) ->
    exists  d1 d2 s,
      P f = Some (t, d1, d2, s)/\
      tlmatch tl d1 /\
      good_decllist (revlcons d1 d2) = true /\
      (
        forall vl p r logicl tid,
          Some p = BuildPreI P f vl logicl pre tid->
          Some r = BuildRetI P f vl logicl post tid ->
          RuleSem FSpec sd lasrt I r Afalse p s Afalse tid
      ).

Definition WFFuncsSim' (P:progunit) (FSpec:funspec) (sd:ossched) lasrt (I:Inv) :Prop:=
  EqDom P FSpec /\
  forall f pre post t tl,
    FSpec f = Some (pre, post, (t, tl)) ->
    exists  d1 d2 s,
      P f = Some (t, d1, d2, s)/\
      tlmatch tl d1 /\
      good_decllist (revlcons d1 d2) = true /\
      (
        forall vl p r logicl tid,
          Some p = BuildPreI P f vl logicl pre tid ->
          Some r = BuildRetI P f vl logicl post tid ->
          (
            forall o O aop,
              (o, O, aop) |= p /\ satp o O (CurLINV lasrt tid) ->
              MethSim P sd (nilcont s) o aop O lasrt I r Afalse (lift Afalse) tid
          )
      ).

Notation " '[' Spec , sd , lasrt , I , r , ri  , n ']'  '|=' t '{{' pre  '}}' s '{{' post '}}' "
  := (RuleSem Spec sd lasrt I r ri pre s post n t) (at level 200).

Notation "  '{[' p , sd , lasrt , I , r , ri , q   ']}'  '||-' t '(' C , o ')'  '<_msim' '(' gamma ,  O  ')' "
  :=  (MethSimMod p sd C o gamma O lasrt I r ri q t) (at level 200).

Notation "  '{{[' p , sc , lasrt , I , r , ri , q ']}}'  '||-' t '(' C , o ')'  '<_msim' '(' gamma ,  O  ')' "
  :=  (MethSim p sc C o gamma O lasrt I r ri q t) (at level 201).


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.

Axiom prevCurValidator : forall l , prevValidator l <> currentValidator l.

Axiom validatorsNeverSame : forall l1 l2 l3,
    now l1 < now l2 ->
    now l2 < now l3 ->
    currentValidator l2 <> currentValidator l3 ->
    currentValidator l1 <> currentValidator l3.

Axiom validatorsMonotonic : forall l1 l2,
    prevValidator l2 = currentValidator l1 ->
    now l1 < now l2.

Axiom unfreezeLessMax : forall l,
    validationStart l + currentValidator l < MAX_INT l.

Axiom nowLessMax : forall l,
    now l < MAX_INT l.

Axiom unfreezeLagLessNow : forall l,
    ELECTOR_UNFREEZE_LAG l < now l.


(*
This is the first of a sequence of files with the purpose of showing that the bicategory of univalent monoidal categories is again univalent.
In this file we construct one side of the first displayed layer above the bicategory of univalent categories, more precisely:
The total category corresponding to this displayed layer is the univalent bicategory defined as followed:
- The objects are categories together with a fixed object (which will be the unit for the monoidal structure).
- The morphisms are functors which preserve the unit in a lax/weak sense (i.e. a non-necessarily isomorphic morphism).
- The 2-cells are natural transformations which (at the unit) preserve the morphisms for source and target functor.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section UnitLayer.

  Definition disp_unit_disp_ob_mor : disp_cat_ob_mor bicat_of_univ_cats.
  Proof.
    exists (λ C, ob (C : univalent_category)).
    exact (λ C D IC ID F, (D : univalent_category)⟦ID, (pr1 F) IC⟧).
  Defined.

  Definition disp_unit_disp_cat_data : disp_cat_data bicat_of_univ_cats.
  Proof.
    exists disp_unit_disp_ob_mor.
    use tpair.
    - intros C I.
      apply identityfunctor_preserves_unit.
    - intros C D E F G IC ID IE puF puG.
      apply (composition_preserves_unit puF puG).
  Defined.

  Definition bidisp_unit_disp_2cell_struct : disp_2cell_struct disp_unit_disp_cat_data.
  Proof.
    intros C D F G α IC ID puF puG.
    apply (preservesunit_commutes puF puG α).
  Defined.

  Lemma isaprop_bidisp_unit_disp_2cell_struct
        {C D : bicat_of_univ_cats}
        {F G : bicat_of_univ_cats ⟦C,D⟧ }
        {α : prebicat_cells bicat_of_univ_cats F G}
        {IC : disp_unit_disp_cat_data C}
        {ID : disp_unit_disp_cat_data D}
        (puF : IC -->[ F] ID)
        (puG : IC -->[ G] ID)
    : isaprop (bidisp_unit_disp_2cell_struct C D F G α IC ID puF puG).
  Proof.
    apply isaprop_preservesunit_commutes.
  Qed.

  Definition bidisp_unit_disp_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats
    := (disp_unit_disp_cat_data,, bidisp_unit_disp_2cell_struct).

  Definition bidisp_unit_disp_prebicat_ops : disp_prebicat_ops bidisp_unit_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split; cbn; unfold bidisp_unit_disp_2cell_struct.
    - intros C D F IC ID puF.
      apply identitynattrans_preservesunit_commutes.
    - intros C D F IC ID puF.
      etrans. { apply id_right. }
      etrans. {
        unfold composition_preserves_unit.
        apply maponpaths.
        apply functor_id.
      }
      apply id_right.
    - intros C D F IC ID puF.
          etrans. { apply id_right. }
          apply id_left.
    - intros C D F IC ID puF.
      apply cancel_precomposition.
      apply pathsinv0.
      apply functor_id.
    - intros C D F IC ID puF.
      etrans. { apply id_right. }
      apply pathsinv0.
      apply id_left.
    - intros C D E W F G H IC ID IE IW puF puG puH.
      cbn.
      unfold bidisp_unit_disp_2cell_struct.
      cbn.
      etrans. { apply id_right. }
      etrans. {
        apply cancel_precomposition.
        apply functor_comp.
      }
      etrans. { apply assoc. }
      apply idpath.
    - intros C D E W F G H IC ID IE IW puF puG puH.
      cbn.
      unfold bidisp_unit_disp_2cell_struct.
      cbn.
      etrans.  { apply id_right. }
      etrans. { apply assoc'. }
      apply cancel_precomposition.
      apply pathsinv0.
      apply functor_comp.
    - intros C D F G H α β IC ID puF puG puH pucα pucβ.
      etrans. { apply assoc. }
      etrans. {
        apply cancel_postcomposition.
        apply pucα.
      }
      apply pucβ.
    - intros C D E F G H α IC ID IE puF puG puH pucα.
      etrans. { apply assoc'. }
      etrans. {
        apply cancel_precomposition.
        apply (pr2 α).
      }
      etrans. { apply assoc. }
      apply cancel_postcomposition.
      apply pucα.
    - cbn in *.
      intros C D E F G H α IC ID IE puF puG puH pucα.
      etrans. { apply assoc'. }
      etrans. {
        apply cancel_precomposition.
        simpl.
        apply (pathsinv0 (functor_comp _ _ _)).
      }
      unfold composition_preserves_unit.
      unfold preservesunit_commutes in pucα.
      do 2 apply maponpaths.
      apply pucα.
  Qed.

  Definition bidisp_unit_disp_prebicat_data : disp_prebicat_data bicat_of_univ_cats
    := (bidisp_unit_disp_prebicat_1_id_comp_cells,, bidisp_unit_disp_prebicat_ops).

  Definition bidisp_unit_disp_prebicat_laws : disp_prebicat_laws bidisp_unit_disp_prebicat_data.
  Proof.
    repeat split; intro; intros; apply isaprop_bidisp_unit_disp_2cell_struct.
  Qed.

  Definition bidisp_unit_disp_prebicat : disp_prebicat bicat_of_univ_cats
    := (bidisp_unit_disp_prebicat_data,,bidisp_unit_disp_prebicat_laws).

  Definition bidisp_unit_disp_bicat : disp_bicat bicat_of_univ_cats.
  Proof.
    refine (bidisp_unit_disp_prebicat,, _).
    intros C D F G α IC ID puF puG.
    apply isasetaprop.
    apply univalent_category_has_homsets.
  Defined.

  Lemma bidisp_unit_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_unit_disp_bicat.
  Proof.
    apply fiberwise_local_univalent_is_univalent_2_1.
    intros C D F IC ID puF puG.
    apply isweqimplimpl.
    - cbn.
      intros α.
      pose (pr1 α) as d.
      cbn in *.
      unfold bidisp_unit_disp_2cell_struct in *.
      unfold preservesunit_commutes in d.
      rewrite id_right in d.
      exact d.
    - apply univalent_category_has_homsets.
    - apply invproofirrelevance.
      intro ; intro.
      use subtypePath.
      + intro x0.
        apply isaprop_is_disp_invertible_2cell.
      + apply univalent_category_has_homsets.
  Qed.

  Lemma dispadjequiv_to_iso (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) :
       disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID -> z_iso IC ID.
  Proof.
    intro equalunits.
    induction equalunits as [f adj].
    induction adj as [data [ladj_ax weq_ax]].
    induction data as [finv [dunit dcounit]].
    cbn in *.
    unfold functor_identity in dunit.
    unfold nat_trans_id in dunit.
    cbn in dunit.

    exists finv.
    exists f.
    split.
    - etrans. { apply (pathsinv0 dunit). }
      apply id_left.
    - apply pathsinv0.
      etrans. { apply (pathsinv0 dcounit). }
      apply id_right.
  Defined.

  Lemma iso_to_dispadjequiv (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) :
    z_iso IC ID -> disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID.
  Proof.
    intro i.
    induction i as [finv [f [li ri]]].
    split with f.
    unfold disp_left_adjoint_equivalence.
    repeat (use tpair); try apply univalent_category_has_homsets.
    - exact finv.
    - etrans. { apply id_left. }
      exact (! li).
    - etrans. {
        apply cancel_postcomposition.
        apply ri.
      }
      apply id_right.
    - etrans. {
        apply cancel_postcomposition.
        apply li.
      }
      apply id_left.
    - etrans. { apply id_left. }
      exact (! ri).
  Defined.

  Lemma iso_dispadjequiv_equivalence (C : bicat_of_univ_cats) (IC ID : bidisp_unit_disp_bicat C) :
    z_iso IC ID ≃ disp_adjoint_equivalence (idtoiso_2_0 C C (idpath C)) IC ID.
  Proof.
    use make_weq.
    - apply iso_to_dispadjequiv.
    - use isweq_iso.
      + apply dispadjequiv_to_iso.
      + intro i.
        induction i.
        use subtypePath.
        * intro f.
          apply isaprop_is_z_isomorphism.
        * apply idpath.
      + intro adjequiv.
        induction adjequiv.
        use subtypePath.
        * intro f.
          apply isaprop_disp_left_adjoint_equivalence.
          -- apply univalent_cat_is_univalent_2_1.
          -- apply bidisp_unit_disp_prebicat_is_locally_univalent.
        * apply idpath.
  Defined.

  Lemma bidisp_unit_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_unit_disp_bicat.
  Proof.
    intros C D equalcats IC ID.
    induction equalcats.
    use weqhomot.
    - set (i1 := iso_dispadjequiv_equivalence C IC ID).
      set (i3 := (_ ,, (pr2 C) IC ID)).
      exact (i1 ∘ i3)%weq.
    - intro p.
      induction p; cbn.
      use subtypePath.
      + intro; simpl.
        apply (@isaprop_disp_left_adjoint_equivalence bicat_of_univ_cats  bidisp_unit_disp_bicat).
        * exact univalent_cat_is_univalent_2_1.
        * exact bidisp_unit_disp_prebicat_is_locally_univalent.
      + apply idpath.
  Defined.

  Lemma bidisp_unit_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_unit_disp_bicat.
  Proof.
    apply make_disp_univalent_2.
    - apply bidisp_unit_disp_prebicat_is_globally_univalent.
    - apply bidisp_unit_disp_prebicat_is_locally_univalent.
  Defined.

  Definition bidisp_unit_disp_2cells_isaprop : disp_2cells_isaprop bidisp_unit_disp_bicat.
  Proof.
    intros C D F G α IC ID puC puD.
    apply isaprop_bidisp_unit_disp_2cell_struct.
  Qed.

  Definition bidisp_unit_disp_locally_groupoid : disp_locally_groupoid bidisp_unit_disp_bicat.
  Proof.
    intros C D F G α IC ID puC puD puc.
    use tpair.
    - set (α_natiso := invertible_2cell_to_nat_z_iso F G α).
      set (α_natisoIC := nat_z_iso_pointwise_z_iso α_natiso IC : z_iso (pr1 F IC) (pr1 G IC)).
      cbn.
      unfold bidisp_unit_disp_2cell_struct.
      red.
      apply pathsinv0, (z_iso_inv_on_left _ _ _ _ α_natisoIC).
      exact (! puc).
    - split; apply isaprop_bidisp_unit_disp_2cell_struct.
  Qed.

End UnitLayer.


(** * Near-univalence of [type_precat] *)

(** The precategory of types is not quite univalent - it doesn't have
    hom-sets. However, it is the case that [idtoiso] is a weak equivalence.

    Much of this material is copied near-verbatim from the results for
    sets. *)

Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import UniMath.CategoryTheory.categories.Type.Core.
Require Import UniMath.CategoryTheory.categories.Type.MonoEpiIso.

Local Open Scope cat.

(*
Definition type_id_weq_iso (A B : ob type_precat) :
  (A = B) ≃ (iso A B) :=
  weqcomp (univalence _ _) (type_equiv_weq_iso A B).

Lemma type_id_weq_iso_is (A B : ob type_precat):
    @idtoiso _ A B = pr1 (type_id_weq_iso A B).
Proof.
  apply funextfun.
  intro p; elim p.
  apply eq_iso; simpl.
  - apply funextfun; intro.
    apply idpath.
Defined.

Lemma type_is_weq_idtoiso (A B : ob type_precat):
   isweq (@idtoiso _ A B).
Proof.
  rewrite type_id_weq_iso_is.
  apply (pr2 (type_id_weq_iso A B)).
Defined.
*)


Require Import Coq.Strings.String.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Relations.Relation_Definitions.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.P4light.Syntax.Value.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.SvalRefine.
Require Import ProD3.core.ExtPred.
Require Import Coq.Numbers.BinNums.
Require Import Hammer.Plugin.Hammer.
Open Scope type_scope.

Section AssertionLang.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (string).
Notation path := (list ident).
Notation P4Int := (P4Int.t tags_t).
Notation P4String := (P4String.t tags_t).
Notation P4Type := (@P4Type tags_t).
Notation mem := Semantics.mem.

Context `{@Target tags_t (@Expression tags_t)}.

Definition mem_unit := path * Sval.

Definition mem_assertion := list mem_unit.

Definition mem_satisfies_unit (m : mem) (a_unit : mem_unit) : Prop :=
  let (p, sv) := a_unit in
  match PathMap.get p m with
  | Some sv' => sval_refine sv sv'
  | None => False
  end.

Definition mem_satisfies (m : mem) (a : mem_assertion) : Prop :=
  fold_right and True (map (mem_satisfies_unit m) a).

Definition mem_denote (a : mem_assertion) : mem -> Prop :=
  fun m => mem_satisfies m a.

Definition arg_assertion := list Sval.

Definition arg_satisfies (args : list Sval) (a : arg_assertion) : Prop :=
  Forall2 sval_refine a args.

Definition arg_denote (a : arg_assertion) : list Sval -> Prop :=
  fun args => arg_satisfies args a.

Definition ret_assertion := Sval.

Definition ret_satisfies (retv : Val) (a : ret_assertion) : Prop :=
  (forall sv', val_to_sval retv sv' -> sval_refine a sv').

Definition ret_denote (a : ret_assertion) : Val -> Prop :=
  fun retv => ret_satisfies retv a.

Definition ext_assertion := list ext_pred.

Definition ext_satisfies (es : extern_state) (a : ext_assertion) : Prop :=
  fold_right and True (map (fun (ep : ext_pred) => ep es) a).

Definition ext_denote (a : ext_assertion) : extern_state -> Prop :=
  fun es => ext_satisfies es a.

(* For setoid rewrite on ext_assertion. *)

Definition ext_assertion_equiv (a a' : ext_assertion) : Prop :=
  ext_denote a = ext_denote a'.

Global Add Parametric Relation : ext_assertion ext_assertion_equiv
  reflexivity proved by (fun a => eq_refl (ext_denote a))
  symmetry proved by (fun a1 a2 => eq_sym (x := ext_denote a1) (y := ext_denote a2))
  transitivity proved by (fun a1 a2 a3 => eq_trans (x := ext_denote a1) (y := ext_denote a2) (z := ext_denote a3))
  as ext_assertion_equiv_rel.

Definition ext_denote_cons : forall ep eps,
  ext_denote (ep :: eps) = (fun es => ep es /\ ext_denote eps es).
Proof. auto. Qed.

(* Current ununsed, but looks good to have. *)
Global Add Parametric Morphism : ext_denote with
  signature (SetoidList.eqlistA ExtPred.equiv) ==> eq as ext_denote_mor.
Proof.
  intros a1 a2; induction 1; auto.
  do 2 rewrite ext_denote_cons.
  rewrite H0.
  rewrite IHeqlistA.
  auto.
Qed.

Global Add Parametric Morphism : cons with
  signature ExtPred.equiv ==> ext_assertion_equiv ==> ext_assertion_equiv as cons_mor.
Proof.
  intros. red.
  do 2 rewrite ext_denote_cons.
  rewrite H0, H1.
  auto.
Qed.

Lemma ext_pred_and_cons : forall ep1 ep2 eps,
  ext_assertion_equiv
    (ExtPred.and ep1 ep2 :: eps)
    (ep1 :: ep2 :: eps).
Proof.
  intros.
  unfold ext_assertion_equiv.
  unfold ext_denote, ext_satisfies.
  simpl.
  unfold lift.
  apply FunctionalExtensionality.functional_extensionality.
  intros. apply prop_ext.
  rewrite <- and_assoc; reflexivity.
Qed.

Lemma ext_pred_wrap_cons : forall ps eps1 H eps2,
  ext_assertion_equiv
    (ExtPred.wrap ps eps1 H :: eps2)
    (eps1 ++ eps2).
Proof.
  intros.
  unfold ext_assertion_equiv, ext_denote, ExtPred.wrap.
  unfold ext_satisfies.
  simpl; clear.
  apply FunctionalExtensionality.functional_extensionality;
    intros es.
  induction eps1.
  - apply prop_ext.
    sfirstorder.
  - simpl. rewrite <- IHeps1.
    apply prop_ext.
    hauto lq: on.
Qed.

(* A lemma to handle assertion representations. *)

Lemma fold_right_and_True : forall l,
  fold_right and True l <-> Forall id l.
Proof.
  intros; induction l; only 2 : destruct IHl; split; intros.
  - constructor.
  - constructor.
  - constructor; sfirstorder.
  - inv H2; sfirstorder.
Qed.

Lemma mem_denote_app : forall a a' m,
  mem_denote (a ++ a') m <-> mem_denote a m /\ mem_denote a' m.
Proof.
  intros.
  unfold mem_denote, mem_satisfies.
  rewrite !fold_right_and_True.
  rewrite map_app.
  rewrite Forall_app.
  reflexivity.
Qed.

Lemma ext_denote_app : forall a a' es,
  ext_denote (a ++ a') es <-> ext_denote a es /\ ext_denote a' es.
Proof.
  intros.
  unfold ext_denote, ext_satisfies.
  rewrite !fold_right_and_True.
  rewrite map_app.
  rewrite Forall_app.
  reflexivity.
Qed.

(* Assertion language properties *)

Lemma path_eqb_eq : forall (p1 p2 : path), path_eqb p1 p2 -> p1 = p2.
Proof.
  induction p1; intros.
  - destruct p2; auto. unfold path_eqb in H0. simpl in H0. now exfalso.
  - destruct p2.
    + unfold path_eqb in H0. simpl in H0. now exfalso.
    + unfold path_eqb in H0. simpl in H0. apply andb_prop in H0.
      destruct H0. apply eqb_eq in H0. subst. f_equal. apply IHp1. apply H1.
Qed.

Fixpoint alist_get' {A} (a : list (path * A)) (p : path) : option A :=
  match a with
  | (p', v) :: tl =>
      if path_eqb p p' then Some v else alist_get' tl p
  | [] => None
  end.

Lemma alist_get'_spec : forall {A} a p,
  @alist_get' A a p = AList.get a p.
Proof.
  induction a; intros.
  - auto.
  - destruct a. simpl.
    destruct (path_eqb p l) eqn:?.
    + symmetry. apply AList.get_eq_cons. auto.
      apply path_eqb_eq. auto.
    + replace (AList.get ((l, a) :: a0) p) with (AList.get a0 p). 2 : {
        symmetry. apply AList.get_neq_cons.
        intro. red in H0. subst.
        rewrite path_eqb_refl in Heqb.
        inv Heqb.
      }
      apply IHa.
Qed.

Lemma mem_denote_get : forall (a : mem_assertion) p sv,
  AList.get a p = Some sv ->
  forall m, mem_denote a m ->
  mem_satisfies_unit m (p, sv).
Proof.
  intros.
  rewrite <- alist_get'_spec in H0.
  induction a.
  - inv H0.
  - destruct a as [p' sv']. simpl in H0.
    destruct (path_eqb p p') eqn:H_p.
    + apply path_eqb_eq in H_p; subst.
      inv H0. inv H1. auto.
    + inv H1; apply IHa; auto.
Qed.

(* Seems deprecated *)
(* Lemma ext_denote_get : forall (a : ext_assertion) p eo,
  AList.get a p = Some eo ->
  forall es, ext_denote a es ->
  ext_satisfies_unit es (p, eo).
Proof.
  intros.
  rewrite <- alist_get'_spec in H0.
  induction a.
  - inv H0.
  - destruct a as [p' sv']. simpl in H0.
    destruct (path_eqb p p') eqn:H_p.
    + apply path_eqb_eq in H_p; subst.
      inv H0. inv H1. auto.
    + inv H1; apply IHa; auto.
Qed. *)

(** * Update and Get *)

(* Current behavior:
    validate a header regardless of the sucess of writing *)
Fixpoint upd_sval_once (v: Sval) (p: path) (f: Sval) : Sval :=
  match v, p with
  | _, [] => f
  | ValBaseStruct fields, hd :: tl =>
      match AList.get fields hd with
      | Some v' =>
          match AList.set fields hd (upd_sval_once v' tl f) with
          | Some fields' => ValBaseStruct fields'
          | None => v (* Impossible *)
          end
      | None => v
      end
  | ValBaseUnion fields, hd :: tl =>
      match AList.get fields hd with
      | Some v' =>
          match AList.set fields hd (upd_sval_once v' tl f) with
          | Some fields' => ValBaseUnion fields'
          | None => v (* Impossible *)
          end
      | None => v
      end
  | ValBaseHeader fields vbit, hd :: tl =>
      match AList.get fields hd with
      | Some v' =>
          match AList.set fields hd (upd_sval_once v' tl f) with
          | Some fields' => ValBaseHeader fields' (Some true)
          | None => v (* Impossible *)
          end
      | None => v
      end
  | _, _ => v
  end.

Definition upd_sval (v: Sval) (upds: list (path * Sval)): Sval :=
  List.fold_left (fun v pf => upd_sval_once v (fst pf) (snd pf)) upds v.

Definition gen_sval (typ: P4Type) (upds: list (path * Sval)): option Sval :=
  match uninit_sval_of_typ (Some false) typ with
  | Some v =>
      Some (List.fold_left (fun v pf => upd_sval_once v (fst pf) (snd pf)) upds v)
  | None =>
      None
  end.

End AssertionLang.


(** * Category of commrigs *)
(** ** Contents
- Precategory of commrigs
- Category of commrigs
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.RigsAndRings.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Local Open Scope cat.

(** * Precategory of commrigs *)
Section def_commrig_precategory.

  Definition commrig_fun_space (A B : commrig) : hSet := make_hSet (rigfun A B) (isasetrigfun A B).

  Definition commrig_precategory_ob_mor : precategory_ob_mor :=
    tpair (λ ob : UU, ob -> ob -> UU) commrig (λ A B : commrig, commrig_fun_space A B).

  Definition commrig_precategory_data : precategory_data :=
    make_precategory_data
      commrig_precategory_ob_mor (λ (X : commrig), (rigisotorigfun (idrigiso X)))
      (fun (X Y Z : commrig) (f : rigfun X Y) (g : rigfun Y Z) => rigfuncomp f g).

  Local Lemma commrig_id_left (X Y : commrig) (f : rigfun X Y) :
    rigfuncomp (rigisotorigfun (idrigiso X)) f = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque commrig_id_left.

  Local Lemma commrig_id_commright (X Y : commrig) (f : rigfun X Y) :
    rigfuncomp f (rigisotorigfun (idrigiso Y)) = f.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque commrig_id_commright.

  Local Lemma commrig_assoc (X Y Z W : commrig) (f : rigfun X Y) (g : rigfun Y Z) (h : rigfun Z W) :
    rigfuncomp f (rigfuncomp g h) = rigfuncomp (rigfuncomp f g) h.
  Proof.
    use rigfun_paths. apply idpath.
  Defined.
  Opaque commrig_assoc.

  Lemma is_precategory_commrig_precategory_data : is_precategory commrig_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros a b f. use commrig_id_left.
    - intros a b f. use commrig_id_commright.
    - intros a b c d f g h. use commrig_assoc.
  Qed.

  Definition commrig_precategory : precategory :=
    make_precategory commrig_precategory_data is_precategory_commrig_precategory_data.

  Lemma has_homsets_commrig_precategory : has_homsets commrig_precategory.
  Proof.
    intros X Y. use isasetrigfun.
  Qed.

End def_commrig_precategory.

(** * Category of commrigs *)
Section def_commrig_category.

  Definition commrig_category : category := make_category _ has_homsets_commrig_precategory.

  (** ** (rigiso X Y) ≃ (z_iso X Y) *)

  Lemma commrig_iso_is_equiv (A B : ob commrig_category) (f : z_iso A B) : isweq (pr1 (pr1 f)).
  Proof.
    use isweq_iso.
    - exact (pr1rigfun _ _ (inv_from_z_iso f)).
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_inv_after_z_iso f)) x).
      intros x0. use isapropisrigfun.
    - intros x.
      use (toforallpaths _ _ _ (subtypeInjectivity _ _ _ _ (z_iso_after_z_iso_inv f)) x).
      intros x0. use isapropisrigfun.
  Defined.
  Opaque commrig_iso_is_equiv.

  Lemma commrig_iso_equiv (X Y : ob commrig_category) :
    z_iso X Y -> rigiso (X : commrig) (Y : commrig).
  Proof.
    intro f.
    use make_rigiso.
    - exact (make_weq (pr1 (pr1 f)) (commrig_iso_is_equiv X Y f)).
    - exact (pr2 (pr1 f)).
  Defined.

  Lemma commrig_equiv_is_z_iso (X Y : ob commrig_category)
        (f : rigiso (X : commrig) (Y : commrig)) :
    @is_z_isomorphism commrig_precategory X Y (rigfunconstr (pr2 f)).
  Proof.
    exists (rigfunconstr (pr2 (invrigiso f))).
    use make_is_inverse_in_precat.
    - use rigfun_paths. use funextfun. intros x. use homotinvweqweq.
    - use rigfun_paths. use funextfun. intros y. use homotweqinvweq.
  Defined.
  Opaque commrig_equiv_is_z_iso.

  Lemma commrig_equiv_iso (X Y : ob commrig_category) :
    rigiso (X : commrig) (Y : commrig) -> z_iso X Y.
  Proof.
    intros f. exact (_,,commrig_equiv_is_z_iso X Y f).
  Defined.

  Lemma commrig_iso_equiv_is_equiv (X Y : commrig_category) : isweq (commrig_iso_equiv X Y).
  Proof.
    use isweq_iso.
    - exact (commrig_equiv_iso X Y).
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
  Defined.
  Opaque commrig_iso_equiv_is_equiv.

  Definition commrig_iso_equiv_weq (X Y : ob commrig_category) :
    weq (z_iso X Y) (rigiso (X : commrig) (Y : commrig)).
  Proof.
    use make_weq.
    - exact (commrig_iso_equiv X Y).
    - exact (commrig_iso_equiv_is_equiv X Y).
  Defined.

  Lemma commrig_equiv_iso_is_equiv (X Y : ob commrig_category) : isweq (commrig_equiv_iso X Y).
  Proof.
    use isweq_iso.
    - exact (commrig_iso_equiv X Y).
    - intros y. use rigiso_paths. use subtypePath.
      + intros x0. use isapropisweq.
      + apply idpath.
    - intros x. use z_iso_eq. use rigfun_paths. apply idpath.
  Defined.
  Opaque commrig_equiv_iso_is_equiv.

  Definition commrig_equiv_weq_iso (X Y : ob commrig_category) :
    (rigiso (X : commrig) (Y : commrig)) ≃ (z_iso X Y).
  Proof.
    use make_weq.
    - exact (commrig_equiv_iso X Y).
    - exact (commrig_equiv_iso_is_equiv X Y).
  Defined.

  (** ** Category of commrigs *)

  Definition commrig_category_isweq (X Y : ob commrig_category) :
    isweq (λ p : X = Y, idtoiso p).
  Proof.
    use (@isweqhomot
           (X = Y) (z_iso X Y)
           (pr1weq (weqcomp (commrig_univalence X Y) (commrig_equiv_weq_iso X Y)))
           _ _ (weqproperty (weqcomp (commrig_univalence X Y) (commrig_equiv_weq_iso X Y)))).
    intros e. induction e.
    use (pathscomp0 weqcomp_to_funcomp_app).
    use total2_paths_f.
    - apply idpath.
    - use proofirrelevance. use isaprop_is_z_isomorphism.
  Defined.
  Opaque commrig_category_isweq.

 Definition commrig_category_is_univalent : is_univalent commrig_category.
  Proof.
    intros X Y. exact (commrig_category_isweq X Y).
  Defined.

  Definition commrig_univalent_category : univalent_category :=
    make_univalent_category commrig_category commrig_category_is_univalent.

End def_commrig_category.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e382m105_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Coq.ZArith.BinInt.
Require Import Coq.NArith.BinNat.
Require Import Coq.Strings.String.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.examples.sbf.Utils.
Require Import ProD3.examples.cms.ConModel.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Import ListNotations.
Open Scope list_scope.

Section FilterRepr.

Notation ident := string.
Notation path := (list ident).

Context {num_frames num_rows num_slots frame_tick_tocks : Z}.

(* I hard-code the value width 32 because I do not want to have
  an additional parameter. *)

Definition Z_to_val (i : Z) : ValueBase :=
  ValBaseBit (P4Arith.to_lbool 32 (Z.min i (Z.pow 2 32 - 1))).

Definition row_reg_repr (p : path) (cr : ConModel.row num_slots) : ext_pred :=
  ExtPred.and
    (ExtPred.singleton (p ++ ["reg_row"]) (Tofino.ObjRegister (map Z_to_val (proj1_sig cr))))
    (ExtPred.prop (Forall (fun x => x >= 0) (proj1_sig cr))).

Program Definition row_repr (p : path) (cr : ConModel.row num_slots) : ext_pred :=
  ExtPred.wrap [p] [row_reg_repr p cr] _.
Next Obligation.
  unfold in_scope.
  rewrite <- (app_nil_r p) at 1.
  rewrite is_prefix_cancel. auto.
Qed.

Lemma row_query_bound : forall p cr i,
  0 <= i < num_slots ->
  ext_implies [row_repr p cr] [ExtPred.prop (row_query cr i >= 0)].
Proof.
  intros.
  unfold row_repr, row_reg_repr.
  destruct cr as [cr ?H]. unfold row_query. cbn [proj1_sig].
  normalize_EXT.
  Intros_prop.
  apply ext_implies_prop_intro.
  list_solve.
Qed.

Program Definition frame_repr (p : path) (rows : list string) (cf : ConModel.frame num_rows num_slots) : ext_pred :=
  ExtPred.wrap [p] (map2 (fun row cr => row_repr (p ++ [row]) cr) rows cf) _.
Next Obligation.
  unfold map2. generalize (combine rows (proj1_sig cf)) as rows_cf.
  clear; intros.
  induction rows_cf; auto.
  destruct a.
  simpl.
  rewrite IHrows_cf.
  unfold in_scope.
  rewrite <- (app_nil_r p) at 1.
  rewrite is_prefix_cancel. auto.
Qed.

Program Definition fil_clear_index_repr (p : path) (w : N) (i : Z) : ext_pred :=
  ExtPred.ex (fun i' =>
    ExtPred.and
      (ExtPred.singleton (p ++ ["reg_clear_index"])
        (Tofino.ObjRegister [ValBaseBit (P4Arith.to_lbool 32 i')]))
      (ExtPred.prop (i' mod (2 ^ (Z.of_N w)) = i)))
    [p ++ ["reg_clear_index"]] _.
Next Obligation.
  unfold in_scope.
  rewrite is_prefix_refl.
  auto.
Qed.

Definition timer_repr_sval (t : Z * bool) :=
  ValBaseStruct [("hi", P4Bit 16 (fst t));
                 ("lo", P4Bit 16 (Z.b2z (snd t)))].

Definition timer_repr_val (t : Z * bool) :=
  force_sval_to_val (timer_repr_sval t).

Definition timer_repr (p : path) (t : Z * bool) : ext_pred :=
  ExtPred.and
    (ExtPred.prop (timer_wf num_frames frame_tick_tocks t))
    (ExtPred.singleton (p ++ ["reg_clear_window"])
          (Tofino.ObjRegister [timer_repr_val t])).

Program Definition cms_repr (p : path) (w : N) (panes : list string) (rows : list string) (cf : ConModel.cms num_frames num_rows num_slots) : ext_pred :=
  ExtPred.wrap [p] (
    let 'mk_cms pns clear_index timer := cf in
    map2 (fun pane cpa => frame_repr (p ++ [pane]) rows cpa) panes pns ++
    [fil_clear_index_repr p w clear_index] ++
    [timer_repr p timer]) _.
Next Obligation.
  destruct cf as [pns clear_index timer].
  rewrite forallb_app, Reflect.andE; split.
  2 : simpl; rewrite Reflect.andE; split.
  - unfold map2. generalize (combine panes (proj1_sig pns)) as panes_pns.
    clear; intros.
    induction panes_pns; auto.
    destruct a.
    simpl.
    rewrite IHpanes_pns.
    unfold in_scope.
    rewrite <- (app_nil_r p) at 1.
    rewrite is_prefix_cancel. auto.
  - unfold in_scope.
    rewrite <- (app_nil_r p) at 1.
    rewrite is_prefix_cancel. auto.
  - unfold in_scope.
    rewrite <- (app_nil_r p) at 1.
    rewrite is_prefix_cancel. auto.
Qed.

End FilterRepr.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5eqsynthconj3 : forall  (lv0 : natural), (@eq natural (plus lv0 Zero) (plus Zero (plus Zero lv0))).
Admitted.
QuickChick conj5eqsynthconj3.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e450m2e225m1_10limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.