(*Generated by Sail from riscv_duopod.*)
Require Import Sail.Base.
Require Import Sail.Real.
Require Import riscv_duopod_types.
Require Import mem_metadata.
Require Import riscv_extras.
Import ListNotations.
Open Scope string.
Open Scope bool.
Open Scope Z.

Definition is_none {a : Type} (opt : option a) : bool :=
   match opt with | Some _ => false | None => true end.

Definition is_some {a : Type} (opt : option a) : bool :=
   match opt with | Some _ => true | None => false end.

Definition eq_unit (_ : unit) (_ : unit) : {_bool : bool & ArithFact (_bool)} := build_ex (true).

Definition neq_int (x : Z) (y : Z) : {_bool : bool & ArithFact (Bool.eqb (negb (x =? y)) _bool)} :=
   build_ex (negb (Z.eqb x y)).

Definition neq_bool (x : bool) (y : bool) : bool := negb (Bool.eqb x y).

Definition __id (x : Z) : {_retval : Z & ArithFact (_retval =? x)} := build_ex (x).

Definition fdiv_int (n : Z) (m : Z) : Z :=
   if sumbool_of_bool (andb (Z.ltb n 0) (Z.gtb m 0)) then Z.sub (Z.quot (Z.add n 1) m) 1
   else if sumbool_of_bool (andb (Z.gtb n 0) (Z.ltb m 0)) then Z.sub (Z.quot (Z.sub n 1) m) 1
   else Z.quot n m.

Definition fmod_int (n : Z) (m : Z) : Z := Z.sub n (Z.mul m (fdiv_int n m)).

Definition concat_str_bits {n : Z} (str : string) (x : mword n) : string :=
   String.append str (string_of_bits x).

Definition concat_str_dec (str : string) (x : Z) : string := String.append str (dec_str x).

Definition sail_mask {v0 : Z} (len : Z) (v : mword v0) `{ArithFact ((len >=? 0) && (v0 >=? 0))}
: mword len :=
   if sumbool_of_bool (Z.leb len (length_mword v)) then vector_truncate v len else zero_extend v len.

Definition sail_ones (n : Z) `{ArithFact (n >=? 0)} : mword n := not_vec (zeros n).

Definition slice_mask (n : Z) (i : Z) (l : Z) `{ArithFact (n >=? 0)} : mword n :=
   if sumbool_of_bool (Z.geb l n) then shiftl (sail_ones n) i
   else
     let one : bits n := sail_mask n ('b"1"  : bits 1) in
     shiftl (sub_vec (shiftl one l) one) i.

Definition read_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 11))} : read_kind :=
   let l__33 := arg_ in
   if sumbool_of_bool (Z.eqb l__33 0) then Read_plain
   else if sumbool_of_bool (Z.eqb l__33 1) then Read_reserve
   else if sumbool_of_bool (Z.eqb l__33 2) then Read_acquire
   else if sumbool_of_bool (Z.eqb l__33 3) then Read_exclusive
   else if sumbool_of_bool (Z.eqb l__33 4) then Read_exclusive_acquire
   else if sumbool_of_bool (Z.eqb l__33 5) then Read_stream
   else if sumbool_of_bool (Z.eqb l__33 6) then Read_RISCV_acquire
   else if sumbool_of_bool (Z.eqb l__33 7) then Read_RISCV_strong_acquire
   else if sumbool_of_bool (Z.eqb l__33 8) then Read_RISCV_reserved
   else if sumbool_of_bool (Z.eqb l__33 9) then Read_RISCV_reserved_acquire
   else if sumbool_of_bool (Z.eqb l__33 10) then Read_RISCV_reserved_strong_acquire
   else Read_X86_locked.

Definition num_of_read_kind (arg_ : read_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 11))} :=
   build_ex (
      match arg_ with
      | Read_plain => 0
      | Read_reserve => 1
      | Read_acquire => 2
      | Read_exclusive => 3
      | Read_exclusive_acquire => 4
      | Read_stream => 5
      | Read_RISCV_acquire => 6
      | Read_RISCV_strong_acquire => 7
      | Read_RISCV_reserved => 8
      | Read_RISCV_reserved_acquire => 9
      | Read_RISCV_reserved_strong_acquire => 10
      | Read_X86_locked => 11
      end
   ).

Definition write_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 10))} : write_kind :=
   let l__23 := arg_ in
   if sumbool_of_bool (Z.eqb l__23 0) then Write_plain
   else if sumbool_of_bool (Z.eqb l__23 1) then Write_conditional
   else if sumbool_of_bool (Z.eqb l__23 2) then Write_release
   else if sumbool_of_bool (Z.eqb l__23 3) then Write_exclusive
   else if sumbool_of_bool (Z.eqb l__23 4) then Write_exclusive_release
   else if sumbool_of_bool (Z.eqb l__23 5) then Write_RISCV_release
   else if sumbool_of_bool (Z.eqb l__23 6) then Write_RISCV_strong_release
   else if sumbool_of_bool (Z.eqb l__23 7) then Write_RISCV_conditional
   else if sumbool_of_bool (Z.eqb l__23 8) then Write_RISCV_conditional_release
   else if sumbool_of_bool (Z.eqb l__23 9) then Write_RISCV_conditional_strong_release
   else Write_X86_locked.

Definition num_of_write_kind (arg_ : write_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 10))} :=
   build_ex (
      match arg_ with
      | Write_plain => 0
      | Write_conditional => 1
      | Write_release => 2
      | Write_exclusive => 3
      | Write_exclusive_release => 4
      | Write_RISCV_release => 5
      | Write_RISCV_strong_release => 6
      | Write_RISCV_conditional => 7
      | Write_RISCV_conditional_release => 8
      | Write_RISCV_conditional_strong_release => 9
      | Write_X86_locked => 10
      end
   ).

Definition a64_barrier_domain_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 3))}
: a64_barrier_domain :=
   let l__20 := arg_ in
   if sumbool_of_bool (Z.eqb l__20 0) then A64_FullShare
   else if sumbool_of_bool (Z.eqb l__20 1) then A64_InnerShare
   else if sumbool_of_bool (Z.eqb l__20 2) then A64_OuterShare
   else A64_NonShare.

Definition num_of_a64_barrier_domain (arg_ : a64_barrier_domain)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 3))} :=
   build_ex (
      match arg_ with
      | A64_FullShare => 0
      | A64_InnerShare => 1
      | A64_OuterShare => 2
      | A64_NonShare => 3
      end
   ).

Definition a64_barrier_type_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 2))}
: a64_barrier_type :=
   let l__18 := arg_ in
   if sumbool_of_bool (Z.eqb l__18 0) then A64_barrier_all
   else if sumbool_of_bool (Z.eqb l__18 1) then A64_barrier_LD
   else A64_barrier_ST.

Definition num_of_a64_barrier_type (arg_ : a64_barrier_type)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 2))} :=
   build_ex (match arg_ with | A64_barrier_all => 0 | A64_barrier_LD => 1 | A64_barrier_ST => 2 end).

Definition trans_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 2))} : trans_kind :=
   let l__16 := arg_ in
   if sumbool_of_bool (Z.eqb l__16 0) then Transaction_start
   else if sumbool_of_bool (Z.eqb l__16 1) then Transaction_commit
   else Transaction_abort.

Definition num_of_trans_kind (arg_ : trans_kind) : {e : Z & ArithFact ((0 <=? e) && (e <=? 2))} :=
   build_ex (
      match arg_ with
      | Transaction_start => 0
      | Transaction_commit => 1
      | Transaction_abort => 2
      end
   ).

Definition cache_op_kind_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 10))}
: cache_op_kind :=
   let l__6 := arg_ in
   if sumbool_of_bool (Z.eqb l__6 0) then Cache_op_D_IVAC
   else if sumbool_of_bool (Z.eqb l__6 1) then Cache_op_D_ISW
   else if sumbool_of_bool (Z.eqb l__6 2) then Cache_op_D_CSW
   else if sumbool_of_bool (Z.eqb l__6 3) then Cache_op_D_CISW
   else if sumbool_of_bool (Z.eqb l__6 4) then Cache_op_D_ZVA
   else if sumbool_of_bool (Z.eqb l__6 5) then Cache_op_D_CVAC
   else if sumbool_of_bool (Z.eqb l__6 6) then Cache_op_D_CVAU
   else if sumbool_of_bool (Z.eqb l__6 7) then Cache_op_D_CIVAC
   else if sumbool_of_bool (Z.eqb l__6 8) then Cache_op_I_IALLUIS
   else if sumbool_of_bool (Z.eqb l__6 9) then Cache_op_I_IALLU
   else Cache_op_I_IVAU.

Definition num_of_cache_op_kind (arg_ : cache_op_kind)
: {e : Z & ArithFact ((0 <=? e) && (e <=? 10))} :=
   build_ex (
      match arg_ with
      | Cache_op_D_IVAC => 0
      | Cache_op_D_ISW => 1
      | Cache_op_D_CSW => 2
      | Cache_op_D_CISW => 3
      | Cache_op_D_ZVA => 4
      | Cache_op_D_CVAC => 5
      | Cache_op_D_CVAU => 6
      | Cache_op_D_CIVAC => 7
      | Cache_op_I_IALLUIS => 8
      | Cache_op_I_IALLU => 9
      | Cache_op_I_IVAU => 10
      end
   ).

Definition not_bit (b : bitU) : bitU := if eq_bit b B1 then B0 else B1.

Definition neq_vec {n : Z} (x : mword n) (y : mword n) : bool := negb (eq_vec x y).

Definition string_of_bit (b : bitU) : M (string) :=
   (match b with | B0 => returnm "0b0" | B1 => returnm "0b1" | _ => exit tt  : M (string) end)
    : M (string).

Definition get_config_print_instr '(tt : unit) : bool := false.

Definition get_config_print_reg '(tt : unit) : bool := false.

Definition get_config_print_mem '(tt : unit) : bool := false.

Definition get_config_print_platform '(tt : unit) : bool := false.

Definition EXTS {n : Z} (m : Z) (v : mword n) `{ArithFact (m >=? n)} : mword m := sign_extend v m.

Definition EXTZ {n : Z} (m : Z) (v : mword n) `{ArithFact (m >=? n)} : mword m := zero_extend v m.

Definition zeros_implicit (n : Z) `{ArithFact (n >=? 0)} : mword n := zeros n.

Definition zeros (n : Z) `{ArithFact (n >=? 0)} : mword n :=
   autocast (replicate_bits ('b"0"  : mword 1) n).

Definition ones (n : Z) `{ArithFact (n >=? 0)} : mword n := sail_ones n.

Definition bool_to_bits (x : bool) : mword 1 :=
   if sumbool_of_bool x then 'b"1"  : mword 1 else 'b"0"  : mword 1.

Definition bit_to_bool (b : bitU) : M (bool) :=
   (match b with | B1 => returnm true | B0 => returnm false | _ => exit tt  : M (bool) end)
    : M (bool).

Definition to_bits (l : Z) (n : Z) `{ArithFact (l >=? 0)} : mword l := get_slice_int l n 0.

Definition zopz0zI_s {n : Z} (x : mword n) (y : mword n) `{ArithFact (n >? 0)} : bool :=
   Z.ltb (projT1 (sint x)) (projT1 (sint y)).

Definition zopz0zKzJ_s {n : Z} (x : mword n) (y : mword n) `{ArithFact (n >? 0)} : bool :=
   Z.geb (projT1 (sint x)) (projT1 (sint y)).

Definition zopz0zI_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.ltb (projT1 (uint x)) (projT1 (uint y)).

Definition zopz0zKzJ_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.geb (projT1 (uint x)) (projT1 (uint y)).

Definition zopz0zIzJ_u {n : Z} (x : mword n) (y : mword n) : bool :=
   Z.leb (projT1 (uint x)) (projT1 (uint y)).

Definition shift_right_arith64 (v : mword 64) (shift : mword 6) : mword 64 :=
   let v128 : bits 128 := EXTS 128 v in
   subrange_vec_dec (shift_bits_right v128 shift) 63 0.

Definition shift_right_arith32 (v : mword 32) (shift : mword 5) : mword 32 :=
   let v64 : bits 64 := EXTS 64 v in
   subrange_vec_dec (shift_bits_right v64 shift) 31 0.

Axiom spc_forwards_matches : forall  (_ : unit) , bool.

Axiom spc_backwards_matches : forall  (_ : string) , bool.

Axiom opt_spc_forwards_matches : forall  (_ : unit) , bool.

Axiom opt_spc_backwards_matches : forall  (_ : string) , bool.

Axiom def_spc_forwards_matches : forall  (_ : unit) , bool.

Axiom def_spc_backwards_matches : forall  (_ : string) , bool.

Axiom hex_bits_forwards : forall {n : Z} (_ : (Z * mword n)) , string.

Axiom hex_bits_backwards : forall {n : Z} (_ : string) , (Z * mword n).

Axiom hex_bits_forwards_matches : forall {n : Z} (_ : (Z * mword n)) , bool.

Axiom hex_bits_backwards_matches : forall  (_ : string) , bool.

Axiom hex_bits_matches_prefix : forall
{n : Z}
(_ : string)
,
option (((Z * mword n) * {n : Z & ArithFact (n >=? 0)})).

Fixpoint _rec_n_leading_spaces (s : string) (_reclimit : Z) (_acc : Acc (Zwf 0) _reclimit)
{struct _acc} : M ({n : Z & ArithFact (n >=? 0)}).
exact (
   assert_exp' (Z.geb _reclimit 0) "recursion limit reached" >>= fun _ =>
   let p0_ := s in
   (if generic_eq p0_ "" then returnm (build_ex 0)
    else
      let p0_ := string_take s 1 in
      (if generic_eq p0_ " " then
         (_rec_n_leading_spaces (string_drop s 1) (Z.sub _reclimit 1) (_limit_reduces _acc)) >>= fun '(existT _ w__0 _ : {n : Z & ArithFact (n >=?
           0)}) =>
         returnm (build_ex (Z.add 1 w__0))
       else returnm (build_ex 0))
       : M ({n : Z & ArithFact (n >=? 0)}))
    : M ({n : Z & ArithFact (n >=? 0)})
).
Defined.

Definition n_leading_spaces (s : string) : M ({n : Z & ArithFact (n >=? 0)}) :=
   (_rec_n_leading_spaces s ((projT1 (string_length s))  : Z) (Zwf_guarded _))
    : M ({n : Z & ArithFact (n >=? 0)}).

Definition spc_forwards '(tt : unit) : string := " ".

Definition spc_backwards (s : string) : unit := tt.

Definition spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (n_leading_spaces s) >>= fun '(existT _ n _) =>
   let l__5 := n in
   returnm (if sumbool_of_bool (Z.eqb l__5 0) then None else Some (tt, build_ex n)).

Definition opt_spc_forwards '(tt : unit) : string := "".

Definition opt_spc_backwards (s : string) : unit := tt.

Definition opt_spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (n_leading_spaces s) >>= fun '(existT _ w__0 _ : {n : Z & ArithFact (n >=? 0)}) =>
   returnm (Some (tt, build_ex w__0)).

Definition def_spc_forwards '(tt : unit) : string := " ".

Definition def_spc_backwards (s : string) : unit := tt.

Definition def_spc_matches_prefix (s : string) : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))) :=
   (opt_spc_matches_prefix s)  : M (option ((unit * {n : Z & ArithFact (n >=? 0)}))).

Definition rX (r : mword 5) : M (mword 64) :=
   let b__0 := r in
   (if eq_vec b__0 ('b"00000"  : mword 5) then returnm (EXTZ 64 (Ox"0"  : mword 4))
    else
      read_reg Xs_ref >>= fun w__0 : vec (mword 64) 32 =>
      returnm (vec_access_dec w__0 (projT1 (uint r))))
    : M (mword 64).

Definition wX (r : mword 5) (v : mword 64) : M (unit) :=
   (if neq_vec r ('b"00000"  : mword 5) then
      read_reg Xs_ref >>= fun w__0 : vec (mword 64) 32 =>
      write_reg Xs_ref (vec_update_dec w__0 (projT1 (uint r)) v)
       : M (unit)
    else returnm tt)
    : M (unit).

Definition read_mem (addr : mword 64) (width : Z) `{ArithFact (width >=? 0)} : M (mword (8 * width)) :=
   (MEMr 64 width (EXTZ 64 (Ox"0"  : mword 4)) addr)  : M (mword (8 * width)).

Definition iop_of_num (arg_ : Z) `{ArithFact ((0 <=? arg_) && (arg_ <=? 5))} : iop :=
   let l__0 := arg_ in
   if sumbool_of_bool (Z.eqb l__0 0) then RISCV_ADDI
   else if sumbool_of_bool (Z.eqb l__0 1) then RISCV_SLTI
   else if sumbool_of_bool (Z.eqb l__0 2) then RISCV_SLTIU
   else if sumbool_of_bool (Z.eqb l__0 3) then RISCV_XORI
   else if sumbool_of_bool (Z.eqb l__0 4) then RISCV_ORI
   else RISCV_ANDI.

Definition num_of_iop (arg_ : iop) : {e : Z & ArithFact ((0 <=? e) && (e <=? 5))} :=
   build_ex (
      match arg_ with
      | RISCV_ADDI => 0
      | RISCV_SLTI => 1
      | RISCV_SLTIU => 2
      | RISCV_XORI => 3
      | RISCV_ORI => 4
      | RISCV_ANDI => 5
      end
   ).

Definition execute_LOAD (imm : mword 12) (rs1 : mword 5) (rd : mword 5) : M (unit) :=
   (rX rs1) >>= fun w__0 : mword 64 =>
   let addr : xlenbits := add_vec w__0 (EXTS 64 imm) in
   (read_mem addr 8) >>= fun result : xlenbits => (wX rd result)  : M (unit).

Definition execute_ITYPE (arg0 : mword 12) (arg1 : mword 5) (arg2 : mword 5) (arg3 : iop) : M (unit) :=
   let merge_var := (arg0, arg1, arg2, arg3) in
   (match merge_var with
    | (imm, rs1, rd, RISCV_ADDI) =>
       (rX rs1) >>= fun rs1_val =>
       let imm_ext : xlenbits := EXTS 64 imm in
       let result := add_vec rs1_val imm_ext in
       (wX rd result)
        : M (unit)
    | _ => exit tt  : M (unit)
    end)
    : M (unit).

Definition execute (merge_var : ast) : M (unit) :=
   (match merge_var with
    | ITYPE (imm, rs1, rd, arg3) => (execute_ITYPE imm rs1 rd arg3)  : M (unit)
    | LOAD (imm, rs1, rd) => (execute_LOAD imm rs1 rd)  : M (unit)
    end)
    : M (unit).

Definition decode (v__0 : mword 32) : option ast :=
   if andb (eq_vec (subrange_vec_dec v__0 14 12) ('b"000"  : mword (14 - 12 + 1)))
        (eq_vec (subrange_vec_dec v__0 6 0) ('b"0010011"  : mword (6 - 0 + 1))) then
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     let rs1 : regbits := subrange_vec_dec v__0 19 15 in
     let rd : regbits := subrange_vec_dec v__0 11 7 in
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     Some (ITYPE (imm, rs1, rd, RISCV_ADDI))
   else if andb (eq_vec (subrange_vec_dec v__0 14 12) ('b"011"  : mword (14 - 12 + 1)))
             (eq_vec (subrange_vec_dec v__0 6 0) ('b"0000011"  : mword (6 - 0 + 1))) then
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     let rs1 : regbits := subrange_vec_dec v__0 19 15 in
     let rd : regbits := subrange_vec_dec v__0 11 7 in
     let imm : bits 12 := subrange_vec_dec v__0 31 20 in
     Some (LOAD (imm, rs1, rd))
   else None.

Definition initial_regstate : regstate :=
{| Xs :=
     (vec_of_list_len [Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64;Ox"0000000000000000"  : mword 64;
                       Ox"0000000000000000"
                        : mword 64;Ox"0000000000000000"  : mword 64]);
   nextPC := (Ox"0000000000000000"  : mword 64);
   PC := (Ox"0000000000000000"  : mword 64) |}.
Hint Unfold initial_regstate : sail.


(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

Require Import MSets.MSetWeakList.
Require Import Coq.Structures.OrdersEx.
Require Import Arith.
Require Import SetoidList.

(** Defines finite sets of natural. *)

Module NatSet := Make (Nat_as_OT).
Import NatSet.

Declare Scope natset_scope.

Infix "U" := union (at level 60, right associativity).
Infix "U+" := add (at level 60, right associativity).
Notation "{[ ]}" := empty (format "{[ ]}") : natset_scope.
Notation "{[ x , y , .. , z ]}" := (add x (add y .. (add z empty) ..)) : natset_scope.
Notation "{[ x ]}" := (add x empty) (at level 0) : natset_scope.

(* Include NatSet.Raw. *)

(* Lemma for_all_ind : forall Q x s, For_all Q (x :: s) -> For_all Q s. *)
(* Proof. *)
(*   intros Q x s Hforall y Hin_y_s. *)
(*   apply (Hforall y (InA_cons_tl x Hin_y_s)). *)
(* Defined. *)

(* Fixpoint filter_ Q (EltSubset := { e : elt | Q e }) (f : EltSubset -> bool) (s : t) : For_all Q s -> t := *)
(*   match s return For_all Q s -> t with *)
(*   | nil => (fun _ => nil) *)
(*   | x :: l => *)
(*     (fun for_all : For_all Q _ => *)

(*        (* Existantial version of t of type {t | In t (this (transitions sitpn))} *) *)
(*        let xe := exist Q x (for_all x (InA_cons_hd l (eq_refl x))) in *)

(*        (* Proof that for_all is valid on decreasing list. *)        *)
(*        if f xe then x :: filter_ Q f l (for_all_ind Q x l for_all) else filter_ Q f l (for_all_ind Q x l for_all)) *)
(*   end. *)


From iris.proofmode Require Export classes.
From iris.algebra Require Export cmra.

(* There are various versions of [IsOp] with different modes:

- [IsOp a b1 b2]: this one has no mode, it can be used regardless of whether
  any of the arguments is an evar. This class has only one direct instance:
  [IsOp (a ⋅ b) a b].
- [IsOp' a b1 b2]: requires either [a] to start with a constructor, OR [b1] and
  [b2] to start with a constructor. All usual instances should be of this
  class to avoid loops.
- [IsOp'LR a b1 b2]: requires either [a] to start with a constructor. This one
  has just one instance: [IsOp'LR (a ⋅ b) a b] with a very low precendence.
  This is important so that when performing, for example, an [iDestruct] on
  [own γ (q1 + q2)] where [q1] and [q2] are fractions, we actually get
  [own γ q1] and [own γ q2] instead of [own γ ((q1 + q2)/2)] twice.
*)
Class IsOp {A : cmraT} (a b1 b2 : A) := is_op : a ≡ b1 ⋅ b2.
Arguments is_op {_} _ _ _ {_}.
Hint Mode IsOp + - - - : typeclass_instances.

Instance is_op_op {A : cmraT} (a b : A) : IsOp (a ⋅ b) a b | 100.
Proof. by rewrite /IsOp. Qed.

Class IsOp' {A : cmraT} (a b1 b2 : A) := is_op' :> IsOp a b1 b2.
Hint Mode IsOp' + ! - - : typeclass_instances.
Hint Mode IsOp' + - ! ! : typeclass_instances.

Class IsOp'LR {A : cmraT} (a b1 b2 : A) := is_op_lr : IsOp a b1 b2.
Existing Instance is_op_lr | 0.
Hint Mode IsOp'LR + ! - - : typeclass_instances.
Instance is_op_lr_op {A : cmraT} (a b : A) : IsOp'LR (a ⋅ b) a b | 0.
Proof. by rewrite /IsOp'LR /IsOp. Qed.

(* FromOp *)
(* TODO: Worst case there could be a lot of backtracking on these instances,
try to refactor. *)
Global Instance is_op_pair {A B : cmraT} (a b1 b2 : A) (a' b1' b2' : B) :
  IsOp a b1 b2 → IsOp a' b1' b2' → IsOp' (a,a') (b1,b1') (b2,b2').
Proof. by constructor. Qed.
Global Instance is_op_pair_core_id_l {A B : cmraT} (a : A) (a' b1' b2' : B) :
  CoreId a → IsOp a' b1' b2' → IsOp' (a,a') (a,b1') (a,b2').
Proof. constructor=> //=. by rewrite -core_id_dup. Qed.
Global Instance is_op_pair_core_id_r {A B : cmraT} (a b1 b2 : A) (a' : B) :
  CoreId a' → IsOp a b1 b2 → IsOp' (a,a') (b1,a') (b2,a').
Proof. constructor=> //=. by rewrite -core_id_dup. Qed.

Global Instance is_op_Some {A : cmraT} (a : A) b1 b2 :
  IsOp a b1 b2 → IsOp' (Some a) (Some b1) (Some b2).
Proof. by constructor. Qed.
(* This one has a higher precendence than [is_op_op] so we get a [+] instead of
an [⋅]. *)
Global Instance is_op_plus (n1 n2 : nat) : IsOp (n1 + n2) n1 n2.
Proof. done. Qed.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.InvariantSearch
     ModelCheck.ProtocolFunctions
     ModelCheck.ModelCheck
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     NetAuth.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module NetAuthProtocolSecure <: AutomatedSafeProtocolSS.

  Import NetAuthProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    eexists.
    econstructor; simpl; find_runtime.

    Unshelve.
    all: exact 0.
  Qed.

  Require Import Coq.Program.Equality.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    Unshelve.
    all : exact TyDontCare.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: exact 0  || auto.
  Qed.

  Show Ltac Profile.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End NetAuthProtocolSecure.


Require Import Decision.
Require Import Semantics. (* for [module_layer_disjoint] *)
Require Export MakeProgramSpec.

Local Arguments ret : simpl never.
Local Arguments bind : simpl never.

Section MAKE_PROGRAM_FACTS.
  Context `{Hmkp: MakeProgram}.
  Context `{Hpf: ProgramFormat}.
  Context `{Hmodule: !Modules ident Fm (globvar Vm) module}.
  Context `{Hlayer: !Layers ident primsem (globvar Vm) layer}.

  Global Instance top_preo A:
    @PreOrder A ⊤%rel.
  Proof.
    firstorder.
  Qed.

  (** * Preliminaries *)

  (** ** Using [make_program_noconflict] *)

  Lemma make_program_make_globalenv {D} ML p:
    make_program D ML = OK p ->
    make_globalenv D ML = OK (Genv.globalenv p).
  Proof.
    intros Hp.
    unfold make_globalenv.
    rewrite Hp.
    reflexivity.
  Qed.

  Lemma make_globalenv_make_program {D} ML ge:
    make_globalenv D ML = OK ge ->
    exists p, make_program D ML = OK p.
  Proof.
    intros Hge.
    unfold make_globalenv in Hge.
    inv_monad Hge.
    eauto.
  Qed.

  Ltac noconflict_for H i :=
    lazymatch type of H with
      | make_program _ (?M, ?L) = _ =>
        let tac :=
          destruct (make_program_noconflict _ _ _ _ i H); eauto; discriminate
        in
          try assert (HMfi: get_module_function i M = OK None) by tac;
          try assert (HMvi: get_module_variable i M = OK None) by tac;
          try assert (HLpi: get_layer_primitive i L = OK None) by tac;
          try assert (HLvi: get_layer_globalvar i L = OK None) by tac;
          try assert (HMLv: get_layer_globalvar i L = get_module_variable i M) by tac
      | make_globalenv _ _ = _ =>
        let p := fresh "p" in
        let Hp := fresh "H" p in
          destruct (make_globalenv_make_program _ _ H) as [p Hp];
          noconflict_for Hp i
    end.

  (** ** Elementary relations for [make_program_rel] *)

  (** We're going to prove many theorems by constructing
    relation families that encode constraints on the module-layer pair
    corresponding to the theorem's premises, then showing that once
    the relations are transported to the program or global
    environment, they entail our conclusion. To facilitate this
    process we introduce the following language.

    So far the following relations can be used:
      - [mprc_empty] imposes no contraints on the program;
      - [mprc_fun i κ] requires that the program define [i] to be the
        internal function [κ];
      - [mprc_prim i σ] requires that the program define [i] to be the
        primitive with specification [σ];
      - [mprc_var i τ] requires that the program define [i] to be the
        global variable with definition [τ].

    Of course, we could come up with something much more general,
    however this suffices for now. *)

  Inductive mprc D :=
    | mprc_empty
    | mprc_fun (i: ident) (κ: Fm)
    | mprc_prim (i: ident) (σ: primsem D)
    | mprc_var (i: ident) (τ: globvar Vm).

  Definition mprc_funrel {D} (R: mprc D): funrel D D :=
    fun j =>
      (eq /\
       match R with
         | mprc_fun i κ =>
           if decide (i = j) then fun x y => y = Some (inl κ) else ⊤
         | mprc_prim i σ =>
           if decide (i = j) then fun x y => y = Some (inr σ) else ⊤
         | _ =>
           ⊤
       end)%rel.

  Definition mprc_varrel {D} (R: mprc D): varrel :=
    fun j =>
      (eq /\
       match R with
         | mprc_var i τ =>
           if decide (i = j) then fun x y => y = Some τ else ⊤
         | _ =>
           ⊤
       end)%rel.

  (** We will be interested in establishing that a module-layer pair
    is related to itself, and expoiting the fact that the resulting
    global environement is the related to itself as well. *)

  Definition mprc_pre {D} (R: @mprc D) (ML: module * layer D) :=
    match R with
      | mprc_empty =>
        True
      | mprc_fun i κ =>
        get_module_function i (fst ML) = OK (Some κ)
      | mprc_prim i σ =>
        get_layer_primitive i (snd ML) = OK (Some σ)
      | mprc_var i τ =>
        get_module_variable i (fst ML) = OK (Some τ) \/
        get_layer_globalvar i (snd ML) = OK (Some τ)
    end.

  (** XXX: we need this for the proof below; perhaps it should be in coqrel. *)

  Lemma rel_inter_preo {A} (R1 R2: rel A A):
    PreOrder R1 ->
    PreOrder R2 ->
    PreOrder (R1 /\ R2).
  Proof.
    intros HR1 HR2.
    split.
    - intros x.
      rauto.
    - intros x y z Hxy Hyz.
      split; etransitivity; rauto.
  Qed.

  Hint Extern 2 (PreOrder (_ /\ _)) =>
    eapply rel_inter_preo : typeclass_instances.

  Lemma mprc_pre_sound {D} R ML:
    @mprc_pre D R ML ->
    module_layer_rel D D (mprc_funrel R) (mprc_varrel R) ML ML.
  Proof.
    destruct ML as [M L], R;
    unfold mprc_pre, mprc_funrel, mprc_varrel, fst, snd;
    intros H j;
    try destruct H as [H|H];
    try destruct (decide (i = j)); subst;
    split;
    try reflexivity;
    unfold get_module_layer_function, get_module_layer_variable, fst, snd;
    rewrite H.
    - destruct (get_layer_primitive j L) as [[|]|]; repeat constructor.
    - destruct (get_module_function j M) as [[|]|]; repeat constructor.
    - destruct (get_layer_globalvar j L) as [[ τ'|]|]; repeat constructor.
      destruct (GlobalVars.globalvar_eq_dec τ τ').
      + subst. autorewrite with res_option_globalvar. repeat constructor.
      + rewrite GlobalVars.res_option_globalvar_oplus_diff by assumption.
        constructor.
    - destruct (get_module_variable j M) as [[ τ' |]|]; repeat constructor.
      destruct (GlobalVars.globalvar_eq_dec τ' τ).
      + subst. autorewrite with res_option_globalvar. repeat constructor.
      + rewrite GlobalVars.res_option_globalvar_oplus_diff by assumption.
        constructor.
  Qed.

  Definition mprc_post {D} (R: @mprc D) (ge: Genv.t Fp Vp) :=
    match R with
      | mprc_empty =>
        True
      | mprc_fun i κ =>
        exists fdef b,
          make_internal κ = OK fdef /\
          Genv.find_symbol ge i = Some b /\
          Genv.find_funct_ptr ge b = Some fdef
      | mprc_prim i σ =>
        exists fdef b,
          make_external D i σ = OK fdef /\
          Genv.find_symbol ge i = Some b /\
          Genv.find_funct_ptr ge b = Some fdef
      | mprc_var i τ =>
        exists vdef b,
          make_varinfo τ = OK vdef /\
          Genv.find_symbol ge i = Some b /\
          Genv.find_var_info ge b = Some vdef
    end.

  Lemma mprc_post_complete {D} R ge:
    genv_rel
      (fundef_rel D D (mprc_funrel R))
      (vardef_rel (mprc_varrel R))
      ge ge ->
    @mprc_post D R ge.
  Proof.
    intros H.
    destruct R; simpl; eauto;
    [ pose proof (genv_rel_find_funct_ptr _ _ _ _ i H) as H' ..
    | pose proof (genv_rel_find_var_info _ _ _ _ i H) as H' ];
    inv_monad H';
    destruct H2 as [? ?];
    simpl in *;
    (destruct (decide (i = i)); [ | congruence]; subst);
    inversion H1; clear H1; subst;
    inv_monad H3;
    simpl in *;
    eauto.
  Qed.

  (** We can use the relational property of [make_program] with
    [mprc_funrel] and [mprc_varrel] to brige these two things. *)

  Instance mprc_funrel_mpr D (R: mprc D) i:
    OptionRelationForward (mprc_funrel R i).
  Proof.
    destruct R; simpl; intros x y Hxy Hy;
    try destruct (decide (_ = _)); inversion Hxy; congruence.
  Qed.

  Instance mprc_varrel_mpr D (R: mprc D) i:
    OptionRelationForward (mprc_varrel R i).
  Proof.
    destruct R; simpl; intros x y Hxy Hy;
    try destruct (decide (_ = _)); inversion Hxy; congruence.
  Qed.

  Instance mprc_funrel_err D (R: mprc D) i:
    Monotonic (make_fundef D i) (mprc_funrel R i @@ Some ++> impl @@ isError).
  Proof.
    intros x y [Hxy _].
    inversion Hxy; subst; reflexivity.
  Qed.

  Instance mprc_varrel_err D (R: mprc D) i:
    Monotonic make_varinfo (mprc_varrel R i @@ Some ++> impl @@ isError).
  Proof.
    intros x y [Hxy _].
    inversion Hxy; subst; reflexivity.
  Qed.

  Lemma make_globalenv_rel_mprc D R ML ge:
    make_globalenv D ML = OK ge ->
    module_layer_rel D D (mprc_funrel R) (mprc_varrel R) ML ML ->
    genv_rel (fundef_rel D D (mprc_funrel R)) (vardef_rel (mprc_varrel R)) ge ge.
  Proof.
    intros Hge HML.
    assert (Hge':
      res_le (genv_rel (fundef_rel D D (mprc_funrel R))
                       (vardef_rel (mprc_varrel R))) (OK ge) (OK ge)).
    {
      rewrite <- !Hge.
      (* FIXME: solve_monotonic should work *)
      eapply make_globalenv_rel; eauto.
      typeclasses eauto.
    }
    inversion Hge'.
    assumption.
  Qed.

  (** We can now design a tactic that puts all of these components together. *)

  Ltac use_mprc H R :=
    lazymatch type of H with
      | make_program ?D ?ML = _ =>
        let Hge := fresh "Hge" in
        pose proof (make_program_make_globalenv _ _ H) as Hge;
        use_mprc Hge R
      | make_globalenv ?D ?ML = _ =>
        let HR := fresh "HR" in
        pose proof H as HR;
        eapply (make_globalenv_rel_mprc _ R) in HR;
        [ eapply mprc_post_complete in HR;
          simpl in H
        | eapply mprc_pre_sound;
          simpl;
          get_module_normalize;
          get_layer_normalize ]
    end.

  (** ** Other useful lemmas *)

  Instance res_le_refl `(Reflexive):
    Reflexive (res_le R).
  Proof.
    intros [|]; constructor; reflexivity.
  Qed.

  Global Instance module_layer_rel_refl D RF RV:
    (forall i, Reflexive (RF i)) ->
    (forall i, Reflexive (RV i)) ->
    Reflexive (module_layer_rel D D RF RV).
  Proof.
    intros HRF HRV [M L] i.
    split; reflexivity.
  Qed.

  Lemma make_globalenv_stencil_matches D ML ge:
    make_globalenv D ML = OK ge ->
    stencil_matches ge.
  Proof.
    intros Hge.
    eapply genv_le_stencil_matches_l.
    eapply (make_globalenv_rel_mprc D (mprc_empty D)); eauto.
    unfold mprc_funrel, mprc_varrel.
    reflexivity.
  Qed.

  Hint Resolve make_globalenv_stencil_matches.

  (** * Properties relating module-layer pairs with their global environments *)

  (** ** Intensional properties about single-binding module-layer pairs *)

  (** Those are only used in [MakeProgramInv] and we may want to
    relocate them there. *)

  Lemma make_globalenv_external {D} (i: ident) (σ: primsem D) ge:
    make_globalenv D (∅, i ↦ σ) = ret ge ->
    exists σdef b,
      make_external D i σ = OK σdef /\
      Genv.find_symbol ge i = Some b /\
      Genv.find_funct_ptr ge b = Some σdef.
  Proof.
    intros Hge.
    use_mprc Hge (mprc_prim D i σ); eauto.
  Qed.

  Lemma make_globalenv_internal {D} (i: ident) (f: Fm) ge:
    make_globalenv D (i ↦ f, ∅) = ret ge ->
    exists fdef b,
      make_internal f = OK fdef /\
      Genv.find_symbol ge i = Some b /\
      Genv.find_funct_ptr ge b = Some fdef.
  Proof.
    intros Hge.
    use_mprc Hge (mprc_fun D i f); eauto.
  Qed.

  Lemma make_globalenv_module_globvar {D} (i: ident) (τ: globvar Vm) ge:
    make_globalenv D (i ↦ τ, ∅) = ret ge ->
    exists vdef b,
      make_varinfo τ = OK vdef /\
      Genv.find_symbol ge i = Some b /\
      Genv.find_var_info ge b = Some vdef.
  Proof.
    intros Hge.
    use_mprc Hge (mprc_var D i τ); eauto.
  Qed.

  Lemma make_globalenv_layer_globvar {D} (i: ident) (τ: globvar Vm) ge:
    make_globalenv D (∅, i ↦ τ) = ret ge ->
    exists vdef b,
      make_varinfo τ = OK vdef /\
      Genv.find_symbol ge i = Some b /\
      Genv.find_var_info ge b = Some vdef.
  Proof.
    intros Hge.
    use_mprc Hge (mprc_var D i τ); eauto.
  Qed.

  (** ** Extensional properties *)

  (** Those are used by legacy code, and we may want to remove them if
    they end up unused after we migrate everything to use the
    relational property of [make_program] instead of painstakingly
    moving back-and-forth between the representations of modules and
    their global environments. *)

  Lemma make_globalenv_get_module_function {D} M L ge i fi f:
    make_globalenv D (M, L) = OK ge ->
    get_module_function i M = OK (Some fi) ->
    make_internal fi = OK f ->
    exists b,
      Genv.find_symbol ge i = Some b /\
      Genv.find_funct_ptr ge b = Some f.
  Proof.
    intros Hge HMi Hfi.
    use_mprc Hge (mprc_fun D i fi); eauto.
    destruct HR as (f' & b & Hf' & HR).
    replace f with f' by congruence.
    eauto.
  Qed.

  Lemma make_globalenv_get_module_variable {D} M L ge i vi v:
    make_globalenv D (M, L) = OK ge ->
    get_module_variable i M = OK (Some vi) ->
    make_varinfo vi = OK v ->
    exists b,
      Genv.find_symbol ge i = Some b /\
      Genv.find_var_info ge b = Some v.
  Proof.
    intros Hge HMi Hvi.
    use_mprc Hge (mprc_var D i vi); eauto.
    destruct HR as (v' & b & Hv' & Hb & Hbv').
    assert (v' = v) by congruence; subst.
    eauto.
  Qed.

  Lemma make_globalenv_get_layer_primitive {D} M L ge i fe f:
    make_globalenv D (M, L) = OK ge ->
    get_layer_primitive i L = OK (Some fe) ->
    make_external D i fe = OK f ->
    exists b,
      Genv.find_symbol ge i = Some b /\
      Genv.find_funct_ptr ge b = Some f.
  Proof.
    intros Hge HMi Hfe.
    use_mprc Hge (mprc_prim D i fe); eauto.
    destruct HR as (f' & b & Hf' & HR).
    replace f with f' by congruence.
    eauto.
  Qed.

  Lemma make_globalenv_get_layer_globalvar {D} M L ge i vi v:
    make_globalenv D (M, L) = OK ge ->
    get_layer_globalvar i L = OK (Some vi) ->
    make_varinfo vi = OK v ->
    exists b,
      Genv.find_symbol ge i = Some b /\
      Genv.find_var_info ge b = Some v.
  Proof.
    intros Hge HMi Hvi.
    use_mprc Hge (mprc_var D i vi); eauto.
    destruct HR as (v' & b & Hv' & Hb & Hbv').
    assert (v' = v) by congruence; subst.
    eauto.
  Qed.

  (** ** Consequences of single hypotheses *)

  Lemma genv_find_symbol_glob_threshold {F V} (ge: Genv.t F V) i b:
    stencil_matches ge ->
    Genv.find_symbol ge i = Some b ->
    (i < glob_threshold)%positive.
  Proof.
    intros Hge.
    rewrite stencil_matches_symbols by eauto.
    Local Transparent find_symbol.
    unfold find_symbol, find_symbol_upto.
    destruct (decide (i < glob_threshold)%positive).
    - tauto.
    - discriminate.
  Qed.

  Hint Resolve genv_find_symbol_glob_threshold.
  Hint Extern 1 (isOK _) => eexists.

  (** * Alternative monotonicity theorems *)

  (** The specification of [make_program] is a very general relational
    property, however prior to this we were already using simpler
    monotonicity properties to characterize some aspects of
    [make_program]. Here we prove those properties for backward
    compatibility. We will want to remove those eventually. *)

  Lemma module_layer_rel_intro:
    forall (D1 D2: layerdata)
      (ML1: module * layer D1)
      (ML2: module * layer D2)
      (R: simrel D1 D2)
      (LESIM: ( le * sim R)%rel ML1 ML2),
      module_layer_rel D1 D2 (fun _ => option_le (eq + sim R)) (fun _ => option_le eq) ML1 ML2.
  Proof.
    intros D1 D2 (M1 & L1) (M2 & L2) R (Hle & Hsim); simpl in *.
    split.
    - unfold get_module_layer_function; simpl.
      repeat match goal with
             | |- res_le _ (res_option_inj ?a ?b) _ =>
               let A := fresh "A" in
               let f := fresh "f" in
               let msg := fresh "msg" in
               destruct a as [[f|]|msg] eqn:A; simpl;
                 let B := fresh "B" in
                 let v := fresh "v" in
                 let msg := fresh "msg" in
                 destruct b as [[v|]|msg] eqn:B; simpl
             | H: le ?M1 ?M2, A: get_module_function ?i ?M1 = _ |- _
               =>
               generalize (get_module_function_monotonic i _ _ H); rewrite A;
                 let C := fresh "C" in
                 intro C; inv C; revert A
             | H: sim ?R ?L1 ?L2, A: get_layer_primitive ?i ?L1 = _ |- _
               =>
               generalize (get_layer_primitive_sim_monotonic _ _ R i _ _ H); rewrite A;
                 let C := fresh "C" in
                 intro C; inv C; revert A
             | H: option_le _ (Some _) _ |- _ => inv H
             | |- _ => simpl; repeat constructor
             end; intros; repeat rstep.
      + destruct y0; repeat constructor.
      + destruct y; repeat constructor. auto.
      + destruct y; repeat constructor.
      + destruct y; repeat constructor.
    - unfold get_module_layer_variable; simpl.
      repeat match goal with
             | |- res_le _ (_ (get_module_variable ?i ?M1) ?b) _ =>
               let A := fresh "A" in
               let f := fresh "f" in
               let msg := fresh "msg" in
               destruct (get_module_variable i M1) as [[f|]|msg] eqn:A; simpl;
                 let B := fresh "B" in
                 let v := fresh "v" in
                 let msg := fresh "msg" in
                 destruct b as [[v|]|msg] eqn:B; simpl
             | H: le ?M1 ?M2, A: get_module_variable ?i ?M1 = _ |- _
               =>
               generalize (get_module_variable_monotonic i _ _ H); rewrite A;
                 let C := fresh "C" in
                 intro C; inv C; revert A
             | H: sim ?R ?L1 ?L2, A: get_layer_globalvar ?i ?L1 = _ |- _
               =>
               generalize (get_layer_globalvar_sim_monotonic _ _ R i _ _ H); rewrite A;
                 let C := fresh "C" in
                 intro C; inv C; revert A
             | H: option_le _ (Some _) _ |- _ => inv H
             end; intros; repeat rstep.
  Qed.

  Global Instance make_program_monotonic:
    Monotonic
      make_program
      (forallr -, (≤) * (≤) ++> res_le (program_le (fun _ => eq))).
  Proof.
    intros D ML1 ML2 HML.
    unfold program_le.
    assert
      ((- ==> subrel)%rel
         (fundef_rel D D (fun i => option_le (eq + sim id)))
         (fun i => option_le eq)).
    {
      intros i x y Hxy.
      destruct Hxy as [fm1 fp1 Hf1 fm2 fp2 Hf2 Hfm].
      destruct Hf1, Hf2; inversion Hfm; constructor; subst.
      destruct H3; try congruence.
      unfold match_fundef in *; simpl in *.
      pose proof (make_external_monotonic i i eq_refl _ _ H1) as Hme.
      destruct Hme; congruence.
    }
    assert
      ((- ==> subrel)%rel
         (vardef_rel (fun i => option_le eq))
         (fun i => option_le eq)).
    {
      intros i x y Hxy.
      destruct Hxy as [vm1 vp1 Hv1 vm2 vp2 Hv2 Hvm].
      + destruct Hv1, Hv2; inversion Hvm; constructor; subst.
        unfold match_vardef in *; simpl in *.
        congruence.
    }
    pose (subrel_at := fun A B (R1 R2: rel A B) (HR: subrel R1 R2) x y (H: R1 x y) => HR x y H).
    eapply @subrel_at.
    - eapply res_le_monotonic.
      eapply program_subrel;
      eassumption.
    - assert
        (forall i,
           Monotonic
             (make_fundef D i)
             (option_le (eq + sim id) @@ (Some) ++> impl @@ (isError))).
      {
        intros i f1 f2 Hf.
        inversion Hf; clear Hf; subst.
        unfold make_fundef.
        repeat rstep.
        + subst.
          reflexivity.
        + eapply @make_external_monotonic; eauto. (* ?? *)
      }
      assert
        (Monotonic make_varinfo (option_le eq @@ (Some) ++> impl @@ (isError))).
      {
        intros v1 v2 Hv.
        inversion Hv; clear Hv; subst.
        reflexivity.
      }
      eapply make_program_rel. (** FIXME: monotonicity should work *)
      + typeclasses eauto.
      + apply module_layer_rel_intro; auto.
  Qed.

  Global Instance make_program_monotonic_params:
    Params (@make_program) 2.

  Global Instance make_globalenv_monotonic:
    Monotonic
      make_globalenv
      (forallr -, (≤) * (≤) ++> res_le (genv_le (fun _ => eq))).
  Proof.
    unfold make_globalenv, ret; simpl.
    rauto.
  Qed.

  Global Instance make_globalenv_monotonic_params:
    Params (@make_globalenv) 2.

  Global Instance make_program_sim_monotonic:
    Monotonic
      (fun D => make_external D)
      (forallr R, - ==> sim R ++> res_le eq) ->
    Monotonic
      (fun D => make_program D)
      (forallr R, (≤) * sim R ++> res_le (program_le (fun _ => eq))).
  Proof.
    intros Hme D1 D2 R ML1 ML2 HML.
    unfold program_le.
    assert
      ((- ==> subrel)%rel
         (fundef_rel D1 D2 (fun i => option_le (eq + sim R)))
         (fun i => option_le eq)).
    {
      intros i x y Hxy.
      destruct Hxy as [fm1 fp1 Hf1 fm2 fp2 Hf2 Hfm].
      destruct Hf1, Hf2; inversion Hfm; constructor; subst.
      destruct H3; unfold match_fundef in *; simpl in *; try congruence.
      pose proof (Hme D1 D2 R i _ _ H1) as Hme'.
      simpl in *.
      destruct Hme'; congruence.
    }
    assert
      ((- ==> subrel)%rel
         (vardef_rel (fun i => option_le eq))
         (fun i => option_le eq)).
    {
      intros i x y Hxy.
      destruct Hxy as [vm1 vp1 Hv1 vm2 vp2 Hv2 Hvm].
      + destruct Hv1, Hv2; inversion Hvm; constructor; subst.
        unfold match_vardef in *; simpl in *.
        congruence.
    }
    pose (subrel_at := fun A B (R1 R2: rel A B) (HR: subrel R1 R2) x y (H: R1 x y) => HR x y H).
    eapply @subrel_at.
    - eapply res_le_monotonic.
      eapply program_subrel; eassumption.
    - assert
        (forall i,
           Related
             (make_fundef D1 i)
             (make_fundef D2 i)
             (option_le (eq + sim R) @@ (Some) ++> impl @@ (isError))).
      {
        intros i f1 f2 Hf.
        inversion Hf; clear Hf; subst.
        unfold make_fundef.
        repeat rstep.
        + subst.
          reflexivity.
        + eapply Hme; eauto.
      }
      assert
        (Monotonic make_varinfo (option_le eq @@ (Some) ++> impl @@ (isError))).
      {
        intros v1 v2 Hv.
        inversion Hv; clear Hv; subst.
        reflexivity.
      }
      eapply make_program_rel. (** FIXME: monotonicity should work *)
      + typeclasses eauto.
      + apply module_layer_rel_intro; auto.
  Qed.

  (** * Other global properties *)

  Lemma make_program_layer_ok {D} M L:
    isOK (make_program D (M, L)) ->
    LayerOK L.
  Proof.
    intros [p Hp] i.
    split.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
  Qed.

  Lemma make_program_module_ok {D} M L:
    isOK (make_program D (M, L)) ->
    ModuleOK M.
  Proof.
    intros [p Hp] i.
    split.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
    - destruct (make_program_noconflict D M L p i Hp); eauto.
  Qed.

  Lemma make_program_module_layer_disjoint {D} M L:
    isOK (make_program D (M, L)) ->
    module_layer_disjoint M L.
  Proof.
    intros [p Hp] i.
    apply (make_program_noconflict D M L p i Hp).
  Qed.

  (** Our specification is probably not sufficient to prove
    [make_program_exists] below, but it should be possible to replace
    uses of that lemma.

      <<<
      make_program_exists {D} (L: _ D) M:
        LayerOK L ->
        ModuleOK M ->
        (forall i fe, get_layer_primitive i L = OK (Some fe) ->
                      isOK (make_external D i fe) /\
                      isOKNone (get_module_function i M) /\
                      isOKNone (get_module_variable i M) /\
                      (i < glob_threshold)%positive) ->
        (forall i fi, get_module_function i M = OK (Some fi) ->
                      isOK (make_internal fi) /\
                      isOKNone (get_layer_primitive i L) /\
                      isOKNone (get_layer_globalvar i L) /\
                      (i < glob_threshold)%positive) ->
        (forall i v, get_layer_globalvar i L = OK (Some v) ->
                     isOKNone (get_module_function i M) /\
                     isOKNone (get_module_variable i M) /\
                     (i < glob_threshold)%positive) ->
        (forall i v, get_module_variable i M = OK (Some v) ->
                     isOKNone (get_layer_primitive i L) /\
                     isOKNone (get_layer_globalvar i L) /\
                     (i < glob_threshold)%positive) ->
        isOK (make_program D (M, L))
      >>>
  *)

  (** We could add this one to the spec, but actually it should be
    enough that the [main] of two programs are equal, we don't need to
    know the specific identifier.

      <<<
      make_program_prog_main
        {D} (L: layer D)
        (M: module) (p: _)
        (prog: make_program D (M, L) = OK p)
      :
        (prog_main p) = xH;
      >>>
   *)
End MAKE_PROGRAM_FACTS.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool TestSuite.ssr_mini_mathcomp.
(* div fintype finfun path bigop. *)

Axiom daemon : False. Ltac myadmit := case: daemon.

Lemma big_load R (K K' : R -> Type) idx op I r (P : pred I) F :
  let s := \big[op/idx]_(i <- r | P i) F i in
  K s * K' s -> K' s.
Proof. by move=> /= [_]. Qed.
Arguments big_load [R] K [K' idx op I r P F].

Section Elim1.

Variables (R : Type) (K : R -> Type) (f : R -> R).
Variables (idx : R) (op op' : R -> R -> R).

Hypothesis Kid : K idx.

Ltac ASSERT1 := match goal with |- (K idx) => myadmit end.
Ltac ASSERT2 K := match goal with |- (forall x1 : R, R ->
    forall y1 : R, R -> K x1 -> K y1 -> K (op x1 y1)) => myadmit end.

Lemma big_rec I r (P : pred I) F
    (Kop : forall i x, P i -> K x -> K (op (F i) x)) :
  K (\big[op/idx]_(i <- r | P i) F i).
Proof.
elim/big_ind2: {-}_.
  ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => myadmit end. Undo 4.
elim/big_ind2: _ / {-}_.
  ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => myadmit end. Undo 4.

elim/big_rec2: (\big[op/idx]_(i <- r | P i) op idx (F i))
  / (\big[op/idx]_(i <- r | P i) F i).
  ASSERT1. match goal with |- (forall i : I, R -> forall y2 : R, is_true (P i) -> K y2 -> K (op (F i) y2)) => myadmit end. Undo 3.

elim/(big_load (phantom R)): _.
  Undo.

Fail elim/big_rec2: {2}_.

elim/big_rec2: (\big[op/idx]_(i <- r | P i) F i)
  / {1}(\big[op/idx]_(i <- r | P i) F i).
  Undo.

elim/(big_load (phantom R)): _.
Undo.

Fail elim/big_rec2: _ / {2}(\big[op/idx]_(i <- r | P i) F i).
Admitted.

Definition morecomplexthannecessary A (P : A -> A -> Prop) x y := P x y.

Lemma grab A (P : A -> A -> Prop) n m : (n = m) -> (P n n) -> morecomplexthannecessary A P n m.
by move->.
Qed.

Goal forall n m, m + (n + m) = m + (n * 1 + m).
Proof. move=> n m; elim/grab : (_ * _) / {1}n => //; exact: muln1. Qed.

End Elim1.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import Recdef.
#[export] Existing Instance NullExtension.Espec.
Require Import VST.progs64.switch.
Require Export VST.floyd.Funspec_old_Notation.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition twice_spec :=
  DECLARE _twice
    WITH n : Z
    PRE [ _n OF tint ]
      PROP  (Int.min_signed <= n+n <= Int.max_signed)
      LOCAL (temp _n (Vint (Int.repr n)))
      SEP ()
    POST [ tint ]
      PROP ()
      LOCAL (temp ret_temp (Vint (Int.repr (n+n))))
      SEP ().

Definition f_spec :=
  DECLARE _f
    WITH x : Z
    PRE [ _x OF tuint ]
      PROP  (0 <= x <= Int.max_unsigned)
      LOCAL (temp _x (Vint (Int.repr x)))
      SEP ()
    POST [ tint ]
      PROP ()
      LOCAL (temp ret_temp (Vint (Int.repr 1)))
      SEP ().

Definition Gprog : funspecs :=   ltac:(with_library prog [twice_spec]).

Lemma body_twice: semax_body Vprog Gprog f_twice twice_spec.
Proof.
start_function.
forward_if (PROP() LOCAL(temp _n (Vint (Int.repr (n+n)))) SEP()).
repeat forward; entailer!!.
repeat forward; entailer!!.
repeat forward; entailer!!.
repeat forward; entailer!!.
repeat forward; entailer!!.
repeat forward; entailer!!.
Qed.

Lemma body_f: semax_body Vprog Gprog f_f f_spec.
Proof.
start_function.
forward_if (@FF (environ->mpred) _).
forward.
forward.
forward.
forward.
forward.
Qed.


Require Export TrInccount.
Require Export TrInckn.

Section TrIncvreq_mon.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma vreq_monotonic_step :
    forall {eo : EventOrdering} (e : Event) r s u l s' c t (ls : MinBFTls),
      M_run_ls_on_this_one_event (MinBFTlocalSys_new r s u l) e = Some ls
      -> state_of_component MAINname ls = Some s'
      -> find_latest_executed_request c (vreq s) = Some t
      -> exists t',
          find_latest_executed_request c (vreq s') = Some t'
          /\ t <= t'.
  Proof.
    introv run eqst find.
    apply map_option_Some in run; exrepnd; simpl in *; rev_Some; minbft_simp.
    unfold M_run_ls_on_input_ls, M_run_ls_on_input in *; simpl in *.
    autorewrite with minbft in *.

    Time minbft_dest_msg Case;
      repeat (simpl in *; autorewrite with minbft in * );
      repeat smash_minbft2; eauto.
  Qed.

  Lemma vreq_monotonic :
    forall {eo : EventOrdering} (e1 e2 : Event) s1 s2 c t,
      is_replica e1
      -> e1 ⊏ e2
      -> M_state_sys_on_event MinBFTsys e1 MAINname = Some s1
      -> M_state_sys_before_event MinBFTsys e2 MAINname = Some s2
      -> find_latest_executed_request c (vreq s1) = Some t
      -> exists t',
          find_latest_executed_request c (vreq s2) = Some t'
          /\ t <= t'.
  Proof.
    introv isrep lte eqsta eqstb find.
    unfold M_state_sys_on_event, M_state_sys_before_event in *.
    unfold is_replica in *; exrepnd.
    applydup local_implies_loc in lte as eqloc.
    rewrite <- eqloc in *.
    rewrite isrep0 in *; simpl in *.

    unfold M_state_ls_on_event, M_state_ls_before_event in *.
    apply map_option_Some in eqsta; exrepnd; rev_Some.
    apply map_option_Some in eqstb; exrepnd; rev_Some.

    clear eqloc isrep0.

    revert dependent a0.
    revert dependent s2.
    revert dependent e2.

    induction e2 as [e ind] using predHappenedBeforeInd;[]; introv lte eqst2 comp2.

    apply local_implies_pred_or_local in lte; repndors.

    { rewrite M_run_ls_before_event_as_M_run_ls_on_event_pred in eqst2; eauto 3 with eo;[].
      unfold local_pred in eqst2; rewrite lte in eqst2.
      rewrite eqsta1 in eqst2; ginv.
      rewrite comp2 in eqsta0; ginv.
      eexists; dands; eauto. }

    exrepnd.
    pose proof (ind e0) as ind; repeat (autodimp ind hyp);[].
    rewrite M_run_ls_before_event_unroll in eqst2.
    assert (~ isFirst e) as nif by eauto 3 with eo.
    destruct (dec_isFirst e) as [d|d]; tcsp;[].
    apply map_option_Some in eqst2; exrepnd; rev_Some.
    applydup M_run_ls_before_event_ls_is_minbft in eqst1; exrepnd; subst; simpl in *.
    unfold local_pred in eqst0; rewrite lte1 in eqst0.
    unfold local_pred in eqst1; rewrite lte1 in eqst1.

    pose proof (ind s (MinBFTlocalSys_new r s s0 s3)) as ind.
    repeat (autodimp ind hyp);[].
    exrepnd.
    eapply vreq_monotonic_step in eqst0; try exact ind1;[|eauto].
    exrepnd.
    eexists; dands; eauto; try omega.
  Qed.

End TrIncvreq_mon.