Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list Mmx.encode.

Lemma encode_decode_t_n : forall (i : instruction_tern_n) (bi : binary_instruction),
    encode_t_n i = Some bi -> decode bi = Some (instr_t_n i).
Proof.
  (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_encdecP in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_n (instr_opcode_t_n i))) f = f (tag_t_n (instr_opcode_t_n i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis1_t_n in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis2_t_n in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis3_t_n in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_n := instr_opcode_t_n i;
       instr_operande1_t_n := instr_operande1_t_n i;
       instr_operande2_t_n := instr_operande2_t_n i;
       instr_operande3_t_n := instr_operande3_t_n i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i : forall (i : instruction_tern_i) (bi : binary_instruction),
    encode_t_i i = Some bi -> decode bi = Some (instr_t_i i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_encdecP in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i (instr_opcode_t_i i))) f = f (tag_t_i (instr_opcode_t_i i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis1_t_i in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis2_t_i in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis3_t_i in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i := instr_opcode_t_i i;
       instr_operande1_t_i := instr_operande1_t_i i;
       instr_operande2_t_i := instr_operande2_t_i i;
       instr_operande3_t_i := instr_operande3_t_i i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_d_n : forall (i : instruction_duo_n) (bi : binary_instruction),
    encode_d_n i = Some bi -> decode bi = Some (instr_d_n i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_encdecP in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_n (instr_opcode_d_n i))) f = f (tag_d_n (instr_opcode_d_n i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis1_d_n in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis2_d_n in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_n := instr_opcode_d_n i;
       instr_operande1_d_n := instr_operande1_d_n i;
       instr_operande2_d_n := instr_operande2_d_n i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_d_i : forall (i : instruction_duo_i) (bi : binary_instruction),
    encode_d_i i = Some bi -> decode bi = Some (instr_d_i i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_encdecP in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_i (instr_opcode_d_i i))) f = f (tag_d_i (instr_opcode_d_i i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis1_d_i in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis2_d_i in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_i := instr_opcode_d_i i;
       instr_operande1_d_i := instr_operande1_d_i i;
       instr_operande2_d_i := instr_operande2_d_i i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  reflexivity.
Qed.

Lemma encode_decode : forall (i : instruction) (bi : binary_instruction),
    encode i = Some bi -> decode bi = Some i.
Proof.
  destruct i.
  -apply encode_decode_t_n.
  -apply encode_decode_t_i.
  -apply encode_decode_d_n.
  -apply encode_decode_d_i.
Qed.


Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.RTac.Core.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {Expr_expr : Expr typ expr}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {ExprUVar_expr : ExprUVar expr}.

  Variable tac
  : forall ctx : Ctx typ expr, ctx_subst ctx -> expr
                               -> rtac typ expr.

  Definition AT_GOAL
  : rtac typ expr :=
    fun ctx s e => (@tac ctx s e) ctx s e.

  Hypothesis tac_sound : forall c s e, rtac_sound (@tac c s e).

  Theorem AT_GOAL_sound : rtac_sound AT_GOAL.
  Proof.
    unfold AT_GOAL; simpl.
    red. intros; subst.
    eapply tac_sound. reflexivity.
  Qed.

End parameterized.

Typeclasses Opaque AT_GOAL.
Hint Opaque AT_GOAL : typeclass_instances.

Arguments AT_GOAL {typ expr} _%rtac _ _ _.


Require Import AutoSep Malloc Bootstrap FactorialRecur.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "top"!"top" @ [topS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Call "top"!"top"()
        [PREonly[_] [| False |] ]
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Definition m0 := link Malloc.m boot.
  Definition m1 := link all m0.

  Lemma ok0 : moduleOk m0.
    link Malloc.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link all_ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, ($(size * 4) <= w)%word -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*                               Oct 1st 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                            MapProperty.v                                 *)
(*                            A. SAIBI (May 95)                             *)
(****************************************************************************)

Require Export Map.

Set Implicit Arguments.
Unset Strict Implicit.

(* Injective Map *)

Section inj_surj_def.

Variable A B : Setoid.

Definition Inj_law (f : Map A B) := forall x y : A, f x =_S f y -> x =_S y.

Structure > Inj : Type :=  {Inj_map :> Map A B; Prf_isInj :> Inj_law Inj_map}.

(* Surjective Map *)

Definition Surj_law (f : Map A B) (h : B -> A) := forall b : B, b =_S f (h b).

Structure > Surj : Type :=
  {Surj_map :> Map A B;
   Surj_elt : B -> A;
   Prf_isSurj :> Surj_law Surj_map Surj_elt}.

End inj_surj_def.


Require Import List.
Import ListNotations.
Require Import String.
Require Import Flocq.Appli.Fappli_IEEE_bits.
Require Import Flocq.Appli.Fappli_IEEE.
Require Import ZArith.

Require Import v1.EpicsTypes.
Require Import v1.Multi.
Require Import v1.NeutronTactics.
Require Import v1.FloatAux.
Require Import v1.Util.

Require Import v1.Expr.
Require v1.ExprDbl.  (* reuse some of the double arithmetic functions *)

Inductive ty := Nil | Dbl | Str.
Scheme Equality for ty.

Definition require_not_nil x :=
    match x with
    | Nil => None
    | _ => Some x
    end.

Definition require_dbl x :=
    match x with
    | Dbl => Some Dbl
    | _ => None
    end.

Definition require_match y x :=
    if ty_eq_dec x y then Some x else None.

Definition always (x : ty) := fun (_ : ty) => Some x.

Definition unary_op_type (op : unary_op) (arg : ty) : option ty :=
    match op with
    | NotAlg => require_dbl arg
    | NotLog => require_dbl arg
    end.

Definition binary_op_type (op : binary_op) arg1 arg2 :=
    match op with
    | Add => require_not_nil arg1 >>= require_match arg2
    | Sub => require_dbl arg1 >>= require_match arg2
    | Mul => require_dbl arg1 >>= require_match arg2
    | Div => require_dbl arg1 >>= require_match arg2
    | Ge => require_dbl arg1 >>= require_match arg2
    | Gt => require_dbl arg1 >>= require_match arg2
    | Le => require_dbl arg1 >>= require_match arg2
    | Lt => require_dbl arg1 >>= require_match arg2
    | Ne => require_not_nil arg1 >>= require_match arg2 >>= always Dbl
    | Eq => require_not_nil arg1 >>= require_match arg2 >>= always Dbl
    | AndLog => require_dbl arg1 >>= require_match arg2
    | OrLog => require_dbl arg1 >>= require_match arg2
    end.

Definition varary_op_type (op : varary_op) (args : list ty) :=
    match op return option ty with
    | Min => None (* TODO *)
    | Max => None (* TODO *)
    end.

Definition seq_result_type t1 t2 :=
    match t1, t2 with
    | Nil, x => Some x
    | x, Nil => Some x
    | _, _ => None      (* Error to have two subexpressions that both produce results *)
    end.

Inductive well_typed {n : nat} : ty -> expr (e_double + e_string) n -> Prop :=
| WtVar : forall i, well_typed Dbl (EVar i)
| WtEVar : forall i, well_typed Str (EXVar i)
| WtLitDbl : forall x, well_typed Dbl (ELit (inl x))
| WtLitStr : forall x, well_typed Str (ELit (inr x))
| WtUnary : forall op t x t',
        unary_op_type op t = Some t' ->
        well_typed t x ->
        well_typed t' (EUnary op x)
| WtBinary : forall op t1 x1 t2 x2 t',
        binary_op_type op t1 t2 = Some t' ->
        well_typed t1 x1 ->
        well_typed t2 x2 ->
        well_typed t' (EBinary op x1 x2)
| WtVarary : forall op ts xs t',
        varary_op_type op ts = Some t' ->
        Forall2 well_typed ts xs ->
        well_typed t' (EVarary op xs)
| WtAssign : forall i x,
        well_typed Dbl x ->
        well_typed Nil (EAssign i x)
| WtXAssign : forall i x,
        well_typed Str x ->
        well_typed Nil (EXAssign i x)
| WtCond : forall t cond body1 body2,
        well_typed Dbl cond ->
        well_typed t body1 ->
        well_typed t body2 ->
        well_typed t (ECond cond body1 body2)
| WtSeq : forall t1 e1 t2 e2 t,
        well_typed t1 e1 ->
        well_typed t2 e2 ->
        seq_result_type t1 t2 = Some t ->
        well_typed t (ESeq e1 e2)
.

Fixpoint count_results {n} (e : expr e_double n) :=
    match e with
    | EAssign _ _ => 0
    | EXAssign _ _ => 0
    | ESeq e1 e2 => count_results e1 + count_results e2
    | _ => 1
    end.

Notation b64_eq := (ExprDbl.b64_eq) (only parsing).
Notation b64_ne := (ExprDbl.b64_eq) (only parsing).
Notation b64_lt := (ExprDbl.b64_eq) (only parsing).
Notation b64_le := (ExprDbl.b64_eq) (only parsing).
Notation b64_gt := (ExprDbl.b64_eq) (only parsing).
Notation b64_ge := (ExprDbl.b64_eq) (only parsing).

Notation b64_and := (ExprDbl.b64_and) (only parsing).
Notation b64_or := (ExprDbl.b64_or) (only parsing).

Definition denote_ty t :=
    match t with
    | Nil => unit
    | Dbl => e_double
    | Str => e_string
    end.

Inductive unary_denotation : ty -> Set :=
| UnaryD (t t' : ty) (f : denote_ty t -> denote_ty t') :
        unary_denotation t
.

Definition double_unary t t' (f : e_double -> denote_ty t') :
        option (unary_denotation t) :=
    match t with
    | Dbl => Some (UnaryD Dbl t' f)
    | _ => None
    end.

Definition denote_unary_op op t : option (unary_denotation t) :=
    match op with
    | NotAlg => double_unary t Dbl (fun x => b64_opp x)
    | NotLog => double_unary t Dbl (fun x => if is_zero x then one else zero)
    end.

Inductive binary_denotation : ty -> ty -> Set :=
| BinaryD (t1 t2 t' : ty) (f : denote_ty t1 -> denote_ty t2 -> denote_ty t') :
        binary_denotation t1 t2
.

Definition double_binary t1 t2 t' (f : e_double -> e_double -> denote_ty t') :
        option (binary_denotation t1 t2) :=
    match t1, t2 with
    | Dbl, Dbl => Some (BinaryD Dbl Dbl t' f)
    | _, _ => None
    end.

Definition denote_binary_op op t1 t2 : option (binary_denotation t1 t2) :=
    match op with
    | Add => match t1, t2 with
        | Dbl, Dbl => Some (BinaryD Dbl Dbl Dbl (b64_plus mode_NE))
        | Str, Str => Some (BinaryD Str Str Str append)
        | _, _ => None
        end
    | Sub => double_binary t1 t2 Dbl (b64_minus mode_NE)
    | Mul => double_binary t1 t2 Dbl (b64_mult mode_NE)
    | Div => double_binary t1 t2 Dbl (b64_div mode_NE)
    | Ge => double_binary t1 t2 Dbl b64_ge
    | Gt => double_binary t1 t2 Dbl b64_gt
    | Le => double_binary t1 t2 Dbl b64_le
    | Lt => double_binary t1 t2 Dbl b64_lt
    | Ne => match t1, t2 with
        | Dbl, Dbl => Some (BinaryD Dbl Dbl Dbl b64_ne)
        | Str, Str => Some (BinaryD Str Str Dbl
                (fun a b => if string_dec a b then zero else one))
        | _, _ => None
        end
    | Eq => match t1, t2 with
        | Dbl, Dbl => Some (BinaryD Dbl Dbl Dbl b64_eq)
        | Str, Str => Some (BinaryD Str Str Dbl
                (fun a b => if string_dec a b then one else zero))
        | _, _ => None
        end
    | AndLog => double_binary t1 t2 Dbl b64_and
    | OrLog => double_binary t1 t2 Dbl b64_or
    end.

Definition state_fn n A :=
    (multi n e_double -> multi n e_string ->
     multi n e_double * multi n e_string * A)%type.

Inductive denotation n :=
| Denot (t : ty) (f : state_fn n (denote_ty t))
.
Implicit Arguments Denot [n].

Definition double_f {n} (x : option (denotation n))  :=
    match x with
    | Some (Denot t f) =>
            match t as t_ return state_fn n (denote_ty t_) -> _ with
            | Dbl => fun f => Some f
            | _ => fun _ => None
            end f
    | None => None
    end.

Definition string_f {n} (x : option (denotation n))  :=
    match x with
    | Some (Denot t f) =>
            match t as t_ return state_fn n (denote_ty t_) -> _ with
            | Str => fun f => Some f
            | _ => fun _ => None
            end f
    | None => None
    end.

Definition unpack_denot {n} (d : option (denotation n))
        (f : forall (t : ty), state_fn n (denote_ty t) -> option (denotation n)) :
        option (denotation n) :=
    match d with
    | Some (Denot t f') => f t f'
    | None => None
    end.

Definition pack_denot {n} t (f : state_fn n (denote_ty t)) := Some (@Denot n t f).

Definition unpack_unary {n} {t} (d : option (unary_denotation t))
        (f : forall (t' : ty), (denote_ty t -> denote_ty t') -> option (denotation n)) :
        option (denotation n).
destruct d as [ d | ]; [ | exact None ].
destruct d. destruct t'; eapply f; eassumption.
Defined.

Definition unpack_binary {n} {t1 t2} (d : option (binary_denotation t1 t2))
        (f : forall (t' : ty), (denote_ty t1 -> denote_ty t2 -> denote_ty t') ->
            option (denotation n)) :
        option (denotation n).
destruct d as [ d | ]; [ | exact None ].
destruct d. destruct t'; eapply f; eassumption.
Defined.

Fixpoint denote' {n} (e : expr (e_double + e_string) n) : option (denotation n) :=
    match e with
    | EVar i => pack_denot Dbl (fun sd ss => (sd, ss, sd !! i))
    | EXVar i => pack_denot Str (fun sd ss => (sd, ss, ss !! i))
    | ELit (inl d) => pack_denot Dbl (fun sd ss => (sd, ss, d))
    | ELit (inr s) => pack_denot Str (fun sd ss => (sd, ss, s))
    | EUnary op xe =>
            unpack_denot (denote' xe) (fun xt xf =>
            unpack_unary (denote_unary_op op xt) (fun t' opf =>
            pack_denot t'
                (fun sd ss =>
                    let '(sd', ss', x) := xf sd ss in
                    (sd', ss', opf x))))
    | EBinary op xe ye =>
            unpack_denot (denote' xe) (fun xt xf =>
            unpack_denot (denote' ye) (fun yt yf =>
            unpack_binary (denote_binary_op op xt yt) (fun t' opf =>
            pack_denot t'
                (fun sd ss =>
                    let '(sd', ss', x) := xf sd ss in
                    let '(sd'', ss'', y) := yf sd' ss' in
                    (sd'', ss'', opf x y)))))
    | EVarary _ _ => None (* unsupported *)
    | EAssign i xe =>
            double_f (denote' xe) >>= fun xf =>
            pack_denot Nil (fun sd ss =>
                let '(sd', ss', x) := xf sd ss in
                (multi_set sd' i x, ss', tt))
    | EXAssign i xe =>
            string_f (denote' xe) >>= fun xf =>
            pack_denot Nil (fun sd ss =>
                let '(sd', ss', x) := xf sd ss in
                (sd', multi_set ss' i x, tt))
    | ECond ce xe ye =>
            double_f (denote' ce) >>= fun cf =>
            unpack_denot (denote' xe) (fun xt xf =>
            unpack_denot (denote' ye) (fun yt yf =>
            if ty_eq_dec xt yt then
                pack_denot xt
                    ltac:(subst; refine (fun sd ss =>
                        let '(sd', ss', c) := cf sd ss in
                        if negb (is_zero c) then xf sd' ss' else yf sd' ss'))
            else
                None))
    | ESeq xe ye =>
            unpack_denot (denote' xe) (fun xt xf =>
            unpack_denot (denote' ye) (fun yt yf =>
            match xt, yt with
            | Nil, _ =>
                    pack_denot yt
                        (fun sd ss =>
                            let '(sd', ss', _) := xf sd ss in
                            let '(sd'', ss'', y) := yf sd' ss' in
                            (sd'', ss'', y))
            | _, Nil =>
                    pack_denot xt
                        (fun sd ss =>
                            let '(sd', ss', x) := xf sd ss in
                            let '(sd'', ss'', _) := yf sd' ss' in
                            (sd'', ss'', x))
            | _, _ => None (* both sides evaluate to results *)
            end))
    end.

Definition denote {n} (e : expr (e_double + e_string) n) :
    option (state_fn n (e_double + e_string)) :=
    match denote' e with
    | Some (Denot Dbl f) => Some (fun sd ss =>
            let '(sd', ss', x) := f sd ss in
            (sd', ss', inl x))
    | Some (Denot Str f) => Some (fun sd ss =>
            let '(sd', ss', x) := f sd ss in
            (sd', ss', inr x))
    | _ => None
    end.

Lemma denote_unary_op_ok : forall op t t',
    unary_op_type op t = Some t' ->
    exists f, denote_unary_op op t = Some (UnaryD t t' f).
destruct op; simpl in *; try discriminate;
destruct t; simpl in *; try discriminate;
intros0 Hty; fancy_injr <- Hty; eauto.
Qed.

Lemma denote_binary_op_ok : forall op t1 t2 t',
    binary_op_type op t1 t2 = Some t' ->
    exists f, denote_binary_op op t1 t2 = Some (BinaryD t1 t2 t' f).
destruct op; simpl in *; try discriminate;
destruct t1; simpl in *; try discriminate;
destruct t2; simpl in *; try discriminate;
intros0 Hty; compute in Hty; fancy_injr <- Hty; eauto.
Qed.

Lemma denote_valid_unary_op_rev : forall op t t' f,
    denote_unary_op op t = Some (UnaryD t t' f) ->
    unary_op_type op t = Some t'.
destruct op; simpl in *; try discriminate;
destruct t; simpl in *; try discriminate;
intros0 Hd; inversion Hd; eauto.
Qed.

Lemma denote_valid_binary_op_rev : forall op t1 t2 t' f,
    denote_binary_op op t1 t2 = Some (BinaryD t1 t2 t' f) ->
    binary_op_type op t1 t2 = Some t'.
destruct op; simpl in *; try discriminate;
destruct t1; simpl in *; try discriminate;
destruct t2; simpl in *; try discriminate;
intros0 Hd; inversion Hd; eauto.
Qed.

Theorem well_typed_denote' : forall n (e : expr (e_double + e_string) n) t,
    well_typed t e ->
    exists f, denote' e = Some (Denot t f).
intro n.
induction e; intros0 Hwt; try invc Hwt.

- compute [denote denote' pack_denot]. eauto.
- compute [denote denote' pack_denot]. eauto.
- compute [denote denote' pack_denot]. eauto.
- compute [denote denote' pack_denot]. eauto.

- (* EUnary *) simpl.
  forward eapply IHe as [ef Hef]; eauto. rewrite Hef. simpl.
  forward eapply denote_unary_op_ok as [opf Hopf]; eauto. rewrite Hopf. simpl.
  destruct t; unfold pack_denot; eauto.

- (* EBinary *) simpl.
  forward eapply IHe1 as [e1f He1f]; eauto. rewrite He1f. simpl.
  forward eapply IHe2 as [e2f He2f]; eauto. rewrite He2f. simpl.
  forward eapply denote_binary_op_ok as [opf Hopf]; eauto. rewrite Hopf. simpl.
  destruct t; unfold pack_denot; eauto.

- (* EVarary *) simpl. destruct v; try discriminate.

- (* EAssign *) simpl.
  forward eapply IHe as [ef Hef]; eauto. rewrite Hef. simpl.
  unfold pack_denot; eauto.

- (* EXAssign *) simpl.
  forward eapply IHe as [ef Hef]; eauto. rewrite Hef. simpl.
  unfold pack_denot; eauto.

- (* ECond *) simpl.
  forward eapply IHe1 as [e1f He1f]; eauto. rewrite He1f. simpl.
  forward eapply IHe2 as [e2f He2f]; eauto. rewrite He2f. simpl.
  forward eapply IHe3 as [e3f He3f]; eauto. rewrite He3f. simpl.
  break_match; try congruence.
  unfold pack_denot; eauto.

- (* ESeq *) simpl.
  forward eapply IHe1 as [e1f He1f]; eauto. rewrite He1f. simpl.
  forward eapply IHe2 as [e2f He2f]; eauto. rewrite He2f. simpl.
  destruct t1, t2; (on (seq_result_type _ _ = _), fun H =>
        try discriminate H; simpl in H; fancy_injr <- H);
  unfold pack_denot; eauto.

Qed.

Theorem well_typed_denote : forall n (e : expr (e_double + e_string) n),
    (well_typed Dbl e \/ well_typed Str e) -> exists f, denote e = Some f.
intros0 Hwt. destruct Hwt;
forward eapply well_typed_denote' as [f Hf]; eauto;
    unfold denote; rewrite Hf; eauto.
Qed.

Definition denote_total n (e : expr (e_double + e_string) n) :
    (well_typed Dbl e \/ well_typed Str e) ->
    { f | denote e = Some f }.
intros0 Hwt.
forward eapply well_typed_denote; eauto.
destruct (denote _) eqn:?.
- eauto.
- exfalso. break_exists. discriminate.
Defined.

Section typecheck.
Open Scope string.

Definition ty_name t :=
    match t with
    | Nil => "Nil"
    | Dbl => "Dbl"
    | Str => "Str"
    end.

Local Definition concat xs := fold_left append xs "".

Local Ltac require_type t t' loc :=
    destruct t eqn:?;
    match goal with
    | [ H : t = t' |- _ ] => clear H
    | [ |- _ ] =>
            (* We're in the case where `t` is something other than `t'` *)
            right; exact (concat ["bad type in "; loc; ": got "; ty_name t;
                " but expected "; ty_name t' ])
    end.

Definition typecheck_expr' n (e : expr (e_double + e_string) n) :
    { t | well_typed t e } + string.
induction e using expr_rect_mut with (Pl := fun _ => unit).

- left. eexists. constructor.
- left. eexists. constructor.
- destruct x.
  + left. eexists. constructor.
  + left. eexists. constructor.

- destruct IHe as [[t ?]| ? ]; [ | right; assumption ].
  destruct (unary_op_type op t) as [ t' | ] eqn:?;
      [ | right; exact (concat ["unary op "; unary_op_name op;
              " can't apply to ("; ty_name t; ")"]) ].
  left. exists t'. econstructor; eassumption.

- destruct IHe1 as [[t1 ?]| ? ]; [ | right; assumption ].
  destruct IHe2 as [[t2 ?]| ? ]; [ | right; assumption ].
  destruct (binary_op_type op t1 t2) as [ t' | ] eqn:?;
      [ | right; exact (concat ["unary op "; binary_op_name op;
              " can't apply to ("; ty_name t1; ", "; ty_name t2; ")"]) ].
  left. exists t'. econstructor; eassumption.

- right; exact "varary ops are not yet supported".

- destruct IHe as [[t ?] | ?]; [ require_type t Dbl "rhs of assign" | right; assumption ].
  left. eexists. constructor. assumption.

- destruct IHe as [[t ?] | ?]; [ require_type t Str "rhs of xassign" | right; assumption ].
  left. eexists. constructor. assumption.

- destruct IHe1 as [[t1 ?] | ?]; [ require_type t1 Dbl "condition of cond" | right; assumption ].
  destruct IHe2 as [[t2 ?] | ?]; [ | right; assumption ].
  destruct IHe3 as [[t3 ?] | ?]; [ | right; assumption ].
  destruct (ty_eq_dec t2 t3).
  + left. eexists. constructor; eauto. congruence.
  + right. exact (concat ["conditional branches have mismatched types: ";
              ty_name t1; " <> "; ty_name t2]).

- destruct IHe1 as [[t1 ?] | ?]; [ | right; assumption ].
  destruct IHe2 as [[t2 ?] | ?]; [ | right; assumption ].
  destruct (seq_result_type t1 t2) as [ t' | ] eqn:?;
          [ | right; exact "multiple result values in seq" ].
  left. eexists. econstructor; eauto.

- exact tt.
- exact tt.

Qed.

Definition typecheck_expr n (e : expr (e_double + e_string) n) :
    (well_typed Dbl e \/ well_typed Str e) + string.
destruct (typecheck_expr' n e) as [[t ?] | ?].
- destruct t.
  + right. exact "no subexpression produced a value".
  + left. left. assumption.
  + left. right. assumption.
- right. assumption.
Qed.

End typecheck.


Require Import Verdi.GhostSimulations.
Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RefinementCommonDefinitions.

Require Import VerdiRaft.PrevLogCandidateEntriesTermInterface.
Require Import VerdiRaft.VotesCorrectInterface.
Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.LeaderSublogInterface.

Require Import VerdiRaft.PrevLogLeaderSublogInterface.

Hint Extern 4 (@BaseParams) => apply base_params : typeclass_instances.
Hint Extern 4 (@MultiParams _) => apply multi_params : typeclass_instances.
Hint Extern 4 (@FailureParams _ _) => apply failure_params : typeclass_instances.

Section PrevLogLeaderSublogProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.

  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.

  Context {lsi : leader_sublog_interface}.

  Context {plceti : prevLog_candidateEntriesTerm_interface}.

  Lemma prevLog_leader_sublog_init :
   raft_net_invariant_init prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_init, prevLog_leader_sublog.
    simpl. intuition.
  Qed.

  Lemma handleClientRequest_log_In :
    forall h st client id c out st' ps e,
      handleClientRequest h st client id c = (out, st', ps) ->
      In e (log st) -> In e (log st').
  Proof using.
    intros.
    find_apply_lem_hyp handleClientRequest_log.
    intuition.
    - find_rewrite. auto.
    - break_exists. intuition. find_rewrite. intuition.
  Qed.

  Lemma prevLog_leader_sublog_client_request :
    raft_net_invariant_client_request prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_client_request, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp handleClientRequest_type. break_and.
      repeat find_rewrite.
      eapply_prop_hyp In In; eauto.
      break_exists_exists. intuition.
      eauto using handleClientRequest_log_In.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. eapply handleClientRequest_no_append_entries; eauto.
      subst. simpl in *. find_rewrite. eauto 10.
  Qed.

  Lemma prevLog_leader_sublog_timeout :
    raft_net_invariant_timeout prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_timeout, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp handleTimeout_type.
      intuition; repeat find_rewrite; try discriminate.
      eapply_prop_hyp In In; eauto.
      break_exists_exists. intuition.
      erewrite handleTimeout_log_same by eauto.
      eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. subst. simpl in *.
      eapply handleTimeout_packets; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma handleAppendEntries_type_log :
    forall h st t n pli plt es ci st' ps,
      handleAppendEntries h st t n pli plt es ci = (st', ps) ->
      type st' = Follower \/ (type st' = type st /\ log st' = log st /\ currentTerm st' = currentTerm st).
  Proof using.
    unfold handleAppendEntries.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto.
  Qed.

  Lemma prevLog_leader_sublog_append_entries :
    raft_net_invariant_append_entries prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_append_entries, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleAppendEntries_type_log.
      intuition.
      + congruence.
      + repeat find_rewrite.
        eapply_prop_hyp In In; eauto.
    - find_apply_lem_hyp handleAppendEntries_not_append_entries.
      simpl in *. subst. exfalso. eauto 10.
  Qed.

  Lemma prevLog_leader_sublog_append_entries_reply :
    raft_net_invariant_append_entries_reply prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_append_entries_reply, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleAppendEntriesReply_log.
      find_rewrite.
      find_copy_apply_lem_hyp handleAppendEntriesReply_type.
      intuition; repeat find_rewrite; try discriminate.
      eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. subst. simpl in *.
      find_apply_lem_hyp handleAppendEntriesReply_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_leader_sublog_request_vote :
    raft_net_invariant_request_vote prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_request_vote, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleRequestVote_log.
      find_copy_apply_lem_hyp handleRequestVote_type.
      intuition; repeat find_rewrite; try discriminate.
      eauto.
    - find_apply_lem_hyp handleRequestVote_no_append_entries.
      simpl in *. subst. exfalso. eauto 10.
  Qed.

  Definition candidateEntriesTerm_lowered (net : network) t p : Prop :=
    In p (nwPackets net) ->
    pBody p = RequestVoteReply t true ->
    currentTerm (nwState net (pDst p)) = t ->
    wonElection (dedup name_eq_dec (pSrc p :: votesReceived (nwState net (pDst p)))) = true ->
    type (nwState net (pDst p)) <> Candidate.

  Lemma deghost_packet_exists :
    forall net p,
      In p (nwPackets (deghost net)) ->
      exists (q : packet (params := raft_refined_multi_params (raft_params := raft_params))),
        In q (nwPackets net) /\ p = deghost_packet q.
  Proof using.
    unfold deghost.
    simpl.
    intros.
    do_in_map.
    eauto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_lowered' :
    forall net,
      prevLog_candidateEntriesTerm net ->
      votes_correct net ->
      cronies_correct net ->
      forall p p' t leaderId prevLogIndex prevLogTerm entries leaderCommit,
        In p (nwPackets (deghost net)) ->
        pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                                entries leaderCommit ->
        0 < prevLogTerm ->
        candidateEntriesTerm_lowered (deghost net) prevLogTerm p'.
  Proof using rri.
    unfold candidateEntriesTerm_lowered,
           cronies_correct, votes_correct.
    intros. break_and.
    rewrite deghost_spec.

    find_apply_lem_hyp deghost_packet_exists.
    find_apply_lem_hyp deghost_packet_exists.
    break_exists.  break_and. subst.
    eapply_prop_hyp votes_nw pBody. concludes.
    eapply_prop_hyp prevLog_candidateEntriesTerm pBody; auto.

    concludes.
    unfold candidateEntriesTerm in *. break_exists. break_and.

    match goal with
    | H : wonElection _ = _ |- _ =>
      eapply wonElection_one_in_common in H; [|clear H; eauto]
    end.
    break_exists. break_and.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.

    simpl in *.
    break_or_hyp.
    - apply_prop_hyp cronies_votes In.
      assert (pDst x = x1) by (eapply_prop one_vote_per_term; eauto).
      subst. auto.
    - intro.
      assert (pDst x = x1).
      { eapply_prop one_vote_per_term;
        eapply_prop cronies_votes.
        - eapply_prop votes_received_cronies; eauto.
        - repeat find_reverse_rewrite. auto.
      }
      subst.
      concludes. contradiction.
  Qed.

  Lemma prevLog_candidateEntriesTerm_lowered :
    forall net,
      raft_intermediate_reachable net ->
      forall p p' t leaderId prevLogIndex prevLogTerm entries leaderCommit,
        In p (nwPackets net) ->
        pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                                entries leaderCommit ->
        0 < prevLogTerm ->
        candidateEntriesTerm_lowered net prevLogTerm p'.
  Proof using plceti cci vci rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.

    eapply prevLog_candidateEntriesTerm_lowered';
      eauto using prevLog_candidateEntriesTerm_invariant, votes_correct_invariant,
      cronies_correct_invariant.
  Qed.

  Lemma handleRequestVoteReply_type_term_won :
    forall h st src t v st',
      handleRequestVoteReply h st src t v = st' ->
      type st' = type st \/
      type st' = Follower \/
      (v = true /\
       wonElection (dedup name_eq_dec (src :: votesReceived st)) = true /\
       currentTerm st' = t).
  Proof using.
    unfold handleRequestVoteReply.
    intros.
    repeat break_match; repeat find_inversion; subst; simpl in *; auto; do_bool; intuition.
  Qed.

  Lemma prevLog_leader_sublog_request_vote_reply :
    raft_net_invariant_request_vote_reply prevLog_leader_sublog.
  Proof using plceti cci vci rri.
    unfold raft_net_invariant_request_vote_reply, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp.
    find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
    find_rewrite. break_if; eauto.
    find_copy_apply_lem_hyp handleRequestVoteReply_type.
    find_copy_apply_lem_hyp handleRequestVoteReply_log.
    intuition; repeat find_rewrite.
    - eauto.
    - discriminate.
    - exfalso.
      find_apply_lem_hyp handleRequestVoteReply_type_term_won.
      intuition; try congruence.
      eapply prevLog_candidateEntriesTerm_lowered with (p := p0) ; eauto.
      + congruence.
      + congruence.
  Qed.

  Lemma prevLog_leader_sublog_do_leader :
    raft_net_invariant_do_leader prevLog_leader_sublog.
  Proof using lsi.
    unfold raft_net_invariant_do_leader, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp doLeader_type. break_and.
      find_copy_apply_lem_hyp doLeader_log.
      repeat find_rewrite. eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and. subst.
      simpl in *.
      find_copy_eapply_lem_hyp doLeader_messages; eauto.
      intuition.
      + omega.
      + break_exists. break_and. subst.
        exists x0. find_apply_lem_hyp findAtIndex_elim. intuition.
        break_if.
        * congruence.
        * pose proof (leader_sublog_invariant_invariant _ ltac:(eauto)).
          unfold leader_sublog_invariant, leader_sublog_host_invariant in *. break_and.
          eauto.
  Qed.

  Lemma prevLog_leader_sublog_do_generic_server :
    raft_net_invariant_do_generic_server prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_do_generic_server, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_eapply_lem_hyp doGenericServer_type. break_and.
      find_copy_eapply_lem_hyp doGenericServer_log.
      repeat find_rewrite.
      eauto.
    - find_copy_eapply_lem_hyp doGenericServer_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_leader_sublog_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset, prevLog_leader_sublog.
    intros.
    find_apply_hyp_hyp.
    repeat find_reverse_higher_order_rewrite.
    eauto.
  Qed.

  Lemma prevLog_leader_sublog_reboot :
    raft_net_invariant_reboot prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_reboot, prevLog_leader_sublog, reboot.
    intros.  subst. simpl in *.
    repeat find_reverse_higher_order_rewrite.

    match goal with
    | [ H : context [In _ _], H' : In _ _ |- _ ] =>
      eapply H with (leader0 := leader) in H'; eauto
    end.
    - break_exists_exists. intuition.
      repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
    - repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
      discriminate.
    - repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
  Qed.

  Lemma prevLog_leader_sublog_invariant :
    forall net,
      raft_intermediate_reachable net ->
      prevLog_leader_sublog net.
  Proof using plceti lsi cci vci rri.
    intros.
    apply raft_net_invariant; auto.
    - apply prevLog_leader_sublog_init.
    - apply prevLog_leader_sublog_client_request.
    - apply prevLog_leader_sublog_timeout.
    - apply prevLog_leader_sublog_append_entries.
    - apply prevLog_leader_sublog_append_entries_reply.
    - apply prevLog_leader_sublog_request_vote.
    - apply prevLog_leader_sublog_request_vote_reply.
    - apply prevLog_leader_sublog_do_leader.
    - apply prevLog_leader_sublog_do_generic_server.
    - apply prevLog_leader_sublog_state_same_packet_subset.
    - apply prevLog_leader_sublog_reboot.
  Qed.

  Instance pllsi : prevLog_leader_sublog_interface.
  Proof.
    constructor.
    apply prevLog_leader_sublog_invariant.
  Qed.
End PrevLogLeaderSublogProof.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Array.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import Bedrock2Experiments.StateMachineProperties.
Require Import Bedrock2Experiments.Tactics.
Require Import Bedrock2Experiments.Word.
Require Import Bedrock2Experiments.WordProperties.
Require Import Bedrock2Experiments.Aes.Aes.
Require Import Bedrock2Experiments.Aes.AesExample.
Require Import Bedrock2Experiments.Aes.AesSemantics.
Require Import Bedrock2Experiments.Aes.AesProperties.
Require Import Bedrock2Experiments.Aes.Constants.
Import Syntax.Coercions List.ListNotations.
Local Open Scope Z_scope.

Section Proofs.
  Context {word: word.word 32} {mem: map.map word Byte.byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}
          {ASpec: AesSpec}
          {consts : aes_constants Z} {timing : timing}
          {consts_ok : aes_constants_ok consts}.
  Existing Instance constant_literals.

  Global Instance spec_of_aes_encrypt : spec_of "b2_aes_encrypt" :=
    fun function_env =>
      forall (tr : trace) (m : mem) R
        (plaintext_ptr key_ptr iv_ptr ciphertext_ptr : word)
        (* values of input arrays *)
        (plaintext0 plaintext1 plaintext2 plaintext3
                    key0 key1 key2 key3 key4 key5 key6 key7
                    iv0 iv1 iv2 iv3 : word)
        (* initial values of output array (used only for determining length) *)
        (ciphertext_arr : list word),
        let plaintext_arr := [plaintext0; plaintext1; plaintext2; plaintext3] in
        let key_arr := [key0; key1; key2; key3; key4; key5; key6; key7] in
        let iv_arr := [iv0; iv1; iv2; iv3] in
        (* arrays are in memory *)
        (array scalar32 (word.of_Z 4) plaintext_ptr plaintext_arr
         * array scalar32 (word.of_Z 4) key_ptr key_arr
         * array scalar32 (word.of_Z 4) iv_ptr iv_arr
         * array scalar32 (word.of_Z 4) ciphertext_ptr ciphertext_arr
         * R)%sep m ->
        (* output array has the right length *)
        length ciphertext_arr = 4%nat ->
        (* circuit must start in the UNINITIALIZED state *)
        execution tr UNINITIALIZED ->
        (* determine expected output using aes_spec *)
        let is_decrypt := false in
        let expected_output :=
            aes_spec
              is_decrypt
              (key0, key1, key2, key3, key4, key5, key6, key7)
              (iv0, iv1, iv2, iv3)
              (plaintext0, plaintext1, plaintext2, plaintext3) in
        call function_env aes_encrypt tr m
             [plaintext_ptr; key_ptr; iv_ptr; ciphertext_ptr]
             (fun tr' m' rets =>
                let '(out0, out1, out2, out3) := expected_output in
                (* the circuit is back in the IDLE state *)
                (exists data, execution tr' (IDLE data))
                (* ...and the input arrays are unchanged, while the ciphertext
                     array now holds the values from the expected output *)
                /\ (array scalar32 (word.of_Z 4) plaintext_ptr plaintext_arr
                   * array scalar32 (word.of_Z 4) iv_ptr iv_arr
                   * array scalar32 (word.of_Z 4) key_ptr key_arr
                   * array scalar32 (word.of_Z 4) ciphertext_ptr
                           [out0; out1; out2; out3] * R)%sep m'
                (* ...and there are no return values *)
                /\ rets = []).

  Local Ltac precondition_hammer :=
    lazymatch goal with
    | |- enum_member ?e _ => cbv [enum_member]; try apply in_map; cbn [In]; tauto
    | |- boolean _ => cbv [boolean]; tauto
    | |- execution _ _ => eassumption
    | |- output_matches_state _ _ => reflexivity
    | H : sep _ _ ?m |- _ ?m => ecancel_assumption
    | _ => try reflexivity
    end.

  Lemma aes_encrypt_correct :
    program_logic_goal_for_function! aes_encrypt.
  Proof.
    (* initial processing *)
    repeat straightline.
    destruct_lists_by_length.

    (* call aes_init *)
    straightline_call; precondition_hammer; [ ].
    repeat straightline.

    (* call aes_key_put *)
    straightline_call; precondition_hammer; [ | ].
    { (* prove key array has the correct length *)
      pose proof (enum_unique aes_key_len) as Hunique.
      simplify_unique_words_in Hunique.
      cbn [kAes256 kAes128 kAes192].
      repeat destruct_one_match; subst; try congruence; [ ].
      reflexivity. }

    repeat straightline.
    lazymatch goal with
    | H : execution ?t _ |- context [?t] =>
      cbn in H
    end.

    (* call aes_iv_put *)
    straightline_call; precondition_hammer; [ ].
    repeat straightline.
    lazymatch goal with
    | H : execution ?t _ |- context [?t] =>
      cbn in H
    end.

    (* call aes_data_put_wait *)
    straightline_call; precondition_hammer; [ ].
    repeat straightline.
    lazymatch goal with
    | H : execution ?t _ |- context [?t] =>
      cbn in H
    end.
    repeat lazymatch goal with
           | H : context [match ?p with pair _ _ => _ end] |- _ =>
             rewrite (surjective_pairing p) in H
           end.

    (* call aes_data_get_wait *)
    straightline_call; precondition_hammer; [ ].
    repeat straightline.

    (* done; prove postcondition *)
    repeat destruct_pair_let.
    ssplit; eauto; [ ].
    repeat lazymatch goal with H : execution _ _ |- _ => clear H end.
    cbn [busy_exp_output data_out0 data_out1 data_out2 data_out3] in *.
    lazymatch goal with
    | Hsep : sep _ _ ?m |- sep _ _ ?m =>
      lazymatch type of Hsep with
        context [aes_spec ?op ?keys ?iv ?plaintext] =>
        replace (aes_spec op keys iv plaintext)
        with expected_output in Hsep
      end
    end; [ ecancel_assumption | ].
    subst_lets. f_equal; [ ].
    lazymatch goal with
    | H : ctrl_operation _ = _ |- _ =>
      cbv [ctrl_operation] in H;
        cbn [AES_CTRL_OPERATION] in H;
        rewrite H
    end.
    rewrite word.unsigned_eqb.
    rewrite kAesEnc_eq. push_unsigned.
    cbn [Z.eqb negb]. reflexivity.
  Qed.
End Proofs.


(*
 * Copyright (c) 2022 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

(** [object_repr.v] contains bundled definitions and utilities which are useful
    when operating on (or reasoning about) the "object representation" of a C++
    object (cf. <https://eel.is/c++draft/basic.types.general#4>). In BRiCk,
    [rawR]/[rawsR] - which are wrappers around [Vraw] [val]ues and lists of them,
    respectively - are used to refer to and manipulate these "object representations".
 *)
Require Import iris.proofmode.proofmode.
Require Import bedrock.prelude.base.

Require Import bedrock.lang.bi.big_op.
Require Import bedrock.lang.cpp.semantics.
From bedrock.lang.cpp.logic Require Import arr pred heap_pred layout raw.

Section Utilities.
  Context `{Σ : cpp_logic} {σ : genv}.

  #[local]
  Lemma big_sepL_shift_aux_N {PROP : bi} {p : ptr} {ty : type} (P : ptr -> PROP) (j : N) {n m : N} :
    (j <= n)%N ->
        ([∗list] i ∈ seqN n m, P (p .[ ty ! Z.of_N i ]))
    -|- ([∗list] i ∈ seqN j m, P (p .[ ty ! Z.of_N (n - j) ] .[ty ! Z.of_N i ])).
  Proof.
    setoid_rewrite o_sub_sub.
    intros Hsz.
    rewrite {Hsz} (big_sepL_seqN_shift _ _ Hsz).
    f_equiv => _ i.
    by rewrite N2Z.inj_add.
  Qed.

  #[local]
  Lemma big_sepL_shift_aux_nat {PROP : bi} {p : ptr} {ty : type} (P : ptr -> PROP) (j : nat) {n m : nat}  :
    (j <= n)%nat ->
        ([∗list] i ∈ seq n m, P (p .[ ty ! Z.of_nat i ]))
    -|- ([∗list] i ∈ seq j m, P (p .[ ty ! Z.of_nat (n - j) ] .[ty ! Z.of_nat i ])).
  Proof.
    intros Hsz.
    setoid_rewrite o_sub_sub.
    rewrite {Hsz} (big_sepL_seq_shift _ _ Hsz).
    f_equiv => _ i.
    by rewrite Nat2Z.inj_add.
  Qed.

  Lemma big_sepL_shift_N {PROP : bi} (P : ptr -> PROP) (n m : N) :
    forall (p : ptr) (ty : type),
          ([∗list] i ∈ seqN n m, P (p .[ ty ! Z.of_N i ]))
      -|- ([∗list] i ∈ seqN 0 m, P (p .[ ty ! Z.of_N n ] .[ty ! Z.of_N i ])).
  Proof.
    intros p ty.
    rewrite (big_sepL_shift_aux_N P 0 ltac:(lia)).
    f_equiv=> _ i; by rewrite N.sub_0_r.
  Qed.

  Lemma big_sepL_shift_nat {PROP : bi} (P : ptr -> PROP) (n m : nat) :
    forall (p : ptr) (ty : type),
          ([∗list] i ∈ seq n m, P (p .[ ty ! Z.of_nat i ]))
      -|- ([∗list] i ∈ seq 0 m, P (p .[ ty ! Z.of_nat n ] .[ty ! Z.of_nat i ])).
  Proof.
    intros p ty.
    rewrite (big_sepL_shift_aux_nat P 0 ltac:(lia)).
    f_equiv=> _ i; by rewrite Nat.sub_0_r.
  Qed.

  Lemma big_sepL_type_ptr_shift (n m : N) (p : ptr) (ty : type) :
          ([∗list] i ∈ seqN n m, type_ptr ty (p .[ ty ! Z.of_N i ]))
      -|- ([∗list] i ∈ seqN 0 m, type_ptr ty (p .[ ty ! Z.of_N n ] .[ty ! Z.of_N i ] )).
  Proof. by apply big_sepL_shift_N. Qed.

  Lemma big_sepL_type_ptr_shift' (n m : nat) (p : ptr) (ty : type) :
          ([∗list] i ∈ seq n m, type_ptr ty (p .[ ty ! Z.of_nat i ]))
      -|- ([∗list] i ∈ seq 0 m, type_ptr ty (p .[ ty ! Z.of_nat n ] .[ty ! Z.of_nat i ] )).
  Proof. by apply big_sepL_shift_nat. Qed.
End Utilities.

Section rawsR_transport.
  Context `{Σ : cpp_logic} {σ : genv}.

  Lemma _at_rawsR_ptr_congP_transport (p1 p2 : ptr) (q : cQp.t) (rs : list raw_byte) :
        ptr_congP σ p1 p2 ** ([∗list] i ∈ seqN 0 (lengthN rs), type_ptr Tu8 (p2 .[ Tu8 ! Z.of_N i ]))
    |-- p1 |-> rawsR q rs -* p2 |-> rawsR q rs.
  Proof.
    generalize dependent p2; generalize dependent p1; induction rs;
      iIntros (p1 p2) "[#congP tptrs]"; iAssert (ptr_congP σ p1 p2) as "(% & #tptr1 & #tptr2)"=> //.
    - rewrite /rawsR !arrayR_nil !_at_sep !_at_only_provable !_at_validR.
      iIntros "[_ %]"; iFrame "%"; iApply (type_ptr_valid with "tptr2").
    - rewrite /rawsR !arrayR_cons !_at_sep !_at_type_ptrR !_at_offsetR; fold (rawsR q rs).
      iIntros "[_ [raw raws]]"; iFrame "#"; iSplitL "raw".
      + iApply (_at_rawR_ptr_congP_transport with "congP"); iFrame "∗".
      + destruct rs.
        * rewrite /rawsR !arrayR_nil !_at_sep !_at_only_provable !_at_validR.
          iDestruct "raws" as "[#valid %]"; iFrame "%".
          iApply type_ptr_valid_plus_one; iFrame "#".
        * specialize (IHrs (p1 .[ Tu8 ! 1 ]) (p2 .[ Tu8 ! 1 ])).

          iDestruct (observe (type_ptr Tu8 (p1 .[ Tu8 ! 1 ])) with "raws") as "#tptr1'". 1: {
            rewrite /rawsR arrayR_cons; apply: _.
          }

          iDestruct (observe (type_ptr Tu8 (p2 .[ Tu8 ! 1 ])) with "tptrs") as "#tptr2'". 1: {
            rewrite !lengthN_cons !N.add_1_r !seqN_S_start/=; apply: _.
          }

          rewrite lengthN_cons N.add_1_r seqN_S_start/=.
          rewrite big_sepL_type_ptr_shift; auto.
          replace (Z.of_N 1) with 1%Z by lia.
          iDestruct "tptrs" as "#[tptr' tptrs]".

          iApply (IHrs with "[tptrs]"); iFrame "#∗".
          unfold ptr_congP, ptr_cong; iPureIntro.
          destruct H as [p [o1 [o2 [Ho1 [Ho2 Hoffset_cong]]]]]; subst.
          exists p, (o1 .[ Tu8 ! 1 ]), (o2 .[ Tu8 ! 1 ]).
          rewrite ?offset_ptr_dot; intuition.
          unfold offset_cong in *.
          apply option.same_property_iff in Hoffset_cong as [? [Ho1 Ho2]].
          apply option.same_property_iff.
          rewrite !eval_offset_dot !eval_o_sub Ho1 Ho2 /=.
          by eauto.
  Qed.
End rawsR_transport.

(* Definitions to ease consuming and reasoning about the collection of [type_ptr Tu8]
   facts induced by [type_ptr_obj_repr].
 *)
Section raw_type_ptrs.
  Context `{Σ : cpp_logic} {σ : genv}.

  (* [obj_type_ptr ty p] collects all of the constituent [type_ptr Tu8] facts
     for the "object representation" of an object of type [ty] rooted at [p].
   *)
  Definition raw_type_ptrs_def (ty : type) (p : ptr) : mpred :=
    Exists (sz : N),
      [| size_of σ ty = Some sz |] **
      [∗list] i ∈ seqN 0 sz, type_ptr Tu8 (p .[ Tu8 ! Z.of_N i ]).
  Definition raw_type_ptrs_aux : seal (@raw_type_ptrs_def). Proof. by eexists. Qed.
  Definition raw_type_ptrs := raw_type_ptrs_aux.(unseal).
  Definition raw_type_ptrs_eq : @raw_type_ptrs = _ := raw_type_ptrs_aux.(seal_eq).

  (* [obj_type_ptr ty p] collects all of the constituent [type_ptr Tu8] facts
     for the "object representation" of an object of type [ty] rooted at [p].
   *)
  Definition raw_type_ptrsR_def (ty : type) : Rep := as_Rep (raw_type_ptrs ty).
  Definition raw_type_ptrsR_aux : seal (@raw_type_ptrsR_def). Proof. by eexists. Qed.
  Definition raw_type_ptrsR := raw_type_ptrsR_aux.(unseal).
  Definition raw_type_ptrsR_eq : @raw_type_ptrsR = _ := raw_type_ptrsR_aux.(seal_eq).

  Lemma type_ptr_raw_type_ptrs :
    forall (ty : type) (p : ptr),
      is_Some (size_of σ ty) ->
      type_ptr ty p |-- raw_type_ptrs ty p.
  Proof.
    intros * Hsz; rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
    destruct Hsz as [sz Hsz].
    iIntros "#tptr"; iExists sz; iFrame "%".
    by iApply type_ptr_obj_repr.
  Qed.

  Section Instances.
    #[global]
    Instance raw_type_ptrs_persistent : forall p ty,
      Persistent (raw_type_ptrs ty p).
    Proof. rewrite raw_type_ptrs_eq/raw_type_ptrs_def; apply: _. Qed.
    #[global]
    Instance raw_type_ptrsR_persistent : forall ty,
      Persistent (raw_type_ptrsR ty).
    Proof. rewrite raw_type_ptrsR_eq/raw_type_ptrsR_def; apply: _. Qed.

    #[global]
    Instance raw_type_ptrs_affine : forall p ty,
      Affine (raw_type_ptrs ty p).
    Proof. rewrite raw_type_ptrs_eq/raw_type_ptrs_def; apply: _. Qed.
    #[global]
    Instance raw_type_ptrsR_affine : forall ty,
      Affine (raw_type_ptrsR ty).
    Proof. rewrite raw_type_ptrsR_eq/raw_type_ptrsR_def; apply: _. Qed.

    #[global]
    Instance raw_type_ptrs_timeless : forall p ty,
      Timeless (raw_type_ptrs ty p).
    Proof. rewrite raw_type_ptrs_eq/raw_type_ptrs_def; apply: _. Qed.
    #[global]
    Instance raw_type_ptrsR_timeless : forall ty,
      Timeless (raw_type_ptrsR ty).
    Proof. rewrite raw_type_ptrsR_eq/raw_type_ptrsR_def; apply: _. Qed.

    Section observations.
      #[global]
      Instance raw_type_ptrs_type_ptr_Tu8_obs (ty : type) (i : N) :
        forall (p : ptr) (sz : N),
          size_of σ ty = Some sz ->
          (i < sz)%N ->
          Observe (type_ptr Tu8 (p .[ Tu8 ! i ])) (raw_type_ptrs ty p).
      Proof.
        iIntros (p sz Hsz Hi) "#raw_tptrs !>".
        rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
        iDestruct "raw_tptrs" as (sz') "[%Hsz' tptrs]".
        rewrite {}Hsz' in Hsz; inversion Hsz; subst.
        iStopProof.
        induction sz as [| sz' IHsz'] using N.peano_ind; first lia.
        iIntros "#tptrs".
        assert (i = sz' \/ i < sz')%N as [Hi' | Hi'] by lia;
          rewrite seqN_S_end_app big_opL_app; cbn;
          iDestruct "tptrs" as "(#tptrs & #tptr & _)";
          by [subst | iApply IHsz'].
      Qed.

      Lemma raw_type_ptrs_Tarray_elem (i : N) :
        forall (p : ptr) (ty : types.type) (cnt sz : N)
          (Hcnt : (cnt <> 0)%N) (Hsz : types.size_of σ ty = Some sz) (Hi : N.lt i cnt),
          raw_type_ptrs (Tarray ty cnt) p |-- raw_type_ptrs ty (p .[Tu8 ! sz * i]).
      Proof.
        intros **; iIntros "#raw_tptrs_array".
        rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
        iDestruct "raw_tptrs_array" as (sz_array) "[%Hsz_array tptrs]".
        iExists sz; iSplit; first by iPureIntro.
        rewrite -N2Z.inj_mul -(big_sepL_type_ptr_shift (sz * i) sz p Tu8).
        iApply (big_sepL_submseteq with "tptrs").
        apply sublist_submseteq.
        apply seqN_sublist; first by done.
        erewrite size_of_array in Hsz_array; eauto; inversion Hsz_array.
        rewrite N.add_0_l -N.mul_succ_r N.mul_comm.
        apply N.mul_le_mono_r.
        lia.
      Qed.

      #[global]
      Instance raw_type_ptrs_Tarray_elem_observe (i : N) :
        forall (p : ptr) (ty : types.type) (cnt sz : N)
          (Hcnt : (cnt <> 0)%N) (Hsz : types.size_of σ ty = Some sz) (Hi : N.lt i cnt),
          Observe (raw_type_ptrs ty (p .[Tu8 ! sz * i])) (raw_type_ptrs (Tarray ty cnt) p).
      Proof. intros **; rewrite (raw_type_ptrs_Tarray_elem i); eauto; by apply: _. Qed.

      #[global]
      Instance raw_type_ptrs_blockR_obs (ty : type) :
        forall (p : ptr) (sz : N) q,
          size_of σ ty = Some sz ->
          Observe (raw_type_ptrs ty p) (p |-> blockR sz q).
      Proof.
        intros * Hsz.
        rewrite blockR_eq/blockR_def raw_type_ptrs_eq/raw_type_ptrs_def !_at_sep.
        apply observe_sep_r.
        iIntros "anyRs".
        rewrite bi.persistently_exist; iExists sz.
        rewrite bi.persistently_sep; iSplitR "anyRs";
          first by (iModIntro; iPureIntro).
        rewrite _at_big_sepL.

        unshelve iDestruct (big_sepL_mono with "anyRs") as "H";
          [ by exact (fun _ v =>  <pers> type_ptr Tu8 (p .[Tu8 ! v]))%I
          | by intros k v Hlookup; cbn;
            rewrite _at_offsetR anyR_type_ptr_observe _at_pers _at_type_ptrR
          | ]; cbn.
        rewrite -big_sepL_persistently; iDestruct "H" as "#tptrs"; iModIntro.

        (* NOTE (JH): There is probably a better way to relate these *)
        iStopProof.
        clear Hsz; generalize dependent p; induction sz using N.peano_ind=> p;
          iIntros "#tptrs"; first by done.
        rewrite seqN_S_start N2Nat.inj_succ; cbn.
        iDestruct "tptrs" as "[#tptr tptrs]"; iSplitL "tptr".
        - by replace (Z.of_nat 0) with 0%Z by lia.
        - rewrite big_sepL_type_ptr_shift big_sepL_type_ptr_shift'.
          specialize (IHsz (p .[Tu8 ! 1%N])).
          by iApply IHsz.
      Qed.
    End observations.
  End Instances.

  Section equivalences.
    Lemma _at_raw_type_ptrsR_equiv :
      forall (p : ptr) (ty : type),
        p |-> raw_type_ptrsR ty -|- raw_type_ptrs ty p.
    Proof. by intros p ty; rewrite raw_type_ptrsR_eq/raw_type_ptrsR_def _at_as_Rep. Qed.

    Lemma raw_type_ptrs_arrayR_Tu8_emp `(xs : list X) :
      forall (ty : type) (p : ptr) (sz : N),
        size_of σ ty = Some sz ->
        lengthN xs = sz ->
        xs <> nil ->
            raw_type_ptrs ty p
        -|- p |-> arrayR Tu8 (const emp) xs.
    Proof.
      intros * Hsz Hlen Hnonnil.
      rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
      rewrite arrayR_eq/arrayR_def arrR_eq/arrR_def.
      split'.
      - iIntros "P"; iDestruct "P" as (sz') "[%Hsz' #tptrs]".
        rewrite !_at_sep !_at_offsetR !_at_only_provable.
        assert (is_Some (size_of σ Tu8)) by eauto; iFrame "%".
        rewrite fmap_length -to_nat_lengthN Hlen N_nat_Z.
        rewrite Hsz' in Hsz; inversion Hsz; subst.
        iSplit.
        + rewrite (big_sepL_lookup _ _ (Nat.pred (length xs))). 2: {
            rewrite list_lookup_lookupN.
            eapply lookupN_seqN.
            intuition eauto.
            destruct xs; simpl; [by exfalso; apply Hnonnil |].
            rewrite /lengthN/=; lia.
          }
          rewrite N.add_0_l Nat2N.inj_pred; fold (lengthN xs).
          replace (Z.of_N (lengthN xs))
            with (N.pred (lengthN xs) + 1)%Z
            by (destruct xs; by [contradiction | rewrite /lengthN/=; lia]).
          rewrite -o_sub_sub _at_validR.
          by iApply type_ptr_valid_plus_one.
        + rewrite _at_big_sepL.
          iApply (big_sepL_mono (fun n _ => type_ptr Tu8 (p .[ Tu8 ! n ]))).
          2: {
            iStopProof; generalize dependent p; clear -Hnonnil;
              destruct xs as [| x xs]; first by contradiction.
            generalize dependent x; induction xs as [| x' xs IHxs];
              iIntros (x Hnonnil p) "#tptrs"; first done.
            specialize (IHxs x' ltac:(auto) (p .[ Tu8 ! 1 ])).
            rewrite fmap_cons big_sepL_cons.
            replace (lengthN (x :: x' :: xs))
              with (N.succ (lengthN (x' :: xs)))
              by (rewrite !lengthN_cons; lia).
            rewrite seqN_S_start big_sepL_cons.
            iDestruct "tptrs" as "[$ tptrs]".
            iApply (big_sepL_mono (fun n _ => type_ptr Tu8 (p .[ Tu8 ! 1 ] .[Tu8 ! n ])));
              first by (intros **; rewrite o_sub_sub;
                          by replace (Z.of_nat (S k)) with (1 + k)%Z by lia).
            iApply IHxs; iModIntro.
            by iApply (big_sepL_type_ptr_shift 1%N).
          }
          intros k y Hy.
          rewrite list_lookup_fmap in Hy.
          destruct (xs !! k); last by done.
          inversion Hy; subst.
          rewrite _at_offsetR _at_sep _at_emp _at_type_ptrR.
          iIntros "$".
      - rewrite !_at_sep !_at_offsetR _at_only_provable _at_validR _at_big_sepL.
        iIntros "(_ & _ & tptrs)".
        iExists sz; iFrame "%"; rewrite -Hlen; clear -Hnonnil.
        iDestruct (big_sepL_mono _ (fun n y => type_ptr Tu8 (p .[ Tu8 ! n ])) with "tptrs") as "tptrs".
        2: {
          iStopProof; generalize dependent p;
             destruct xs as [| x xs]; first by contradiction.
          generalize dependent x; induction xs as [| x' xs IHxs];
            iIntros (x Hnonnil p) "tptrs"; first by done.
          specialize (IHxs x' ltac:(auto) (p .[ Tu8 ! 1 ])).
          rewrite fmap_cons big_sepL_cons.
          replace (lengthN (x :: x' :: xs))
            with (N.succ (lengthN (x' :: xs)))
            by (rewrite !lengthN_cons; lia).
          rewrite seqN_S_start big_sepL_cons.
          iDestruct "tptrs" as "[$ tptrs]".
          iDestruct (big_sepL_mono _ (fun n _ => type_ptr Tu8 (p .[ Tu8 ! 1 ] .[Tu8 ! n ]))
                      with "tptrs") as "tptrs";
            first by (intros **; rewrite o_sub_sub;
                        by replace (Z.of_nat (S k)) with (1 + k)%Z by lia).
          iDestruct (IHxs with "tptrs") as "tptrs".
          by iApply (big_sepL_type_ptr_shift 1%N).
        }
        intros k y Hy.
        rewrite list_lookup_fmap in Hy.
        destruct (xs !! k); last by done.
        inversion Hy; subst.
        rewrite _at_offsetR _at_sep _at_emp _at_type_ptrR.
        iIntros "[$ _]".
    Qed.

    #[local]
    Lemma raw_type_ptrs_array_aux :
      forall (ty : type) (cnt : N) (p : ptr) (i sz : N),
        size_of σ ty = Some sz ->
            ([∗list] j ∈ seqN (i * sz) (cnt * sz)%N,
               type_ptr Tu8 (p .[ Tu8 ! Z.of_N (i * sz) ] .[ Tu8 ! Z.of_N j ]))
        -|- ([∗list] j ∈ seqN i cnt,
               raw_type_ptrs ty (p .[ Tu8 ! Z.of_N ((i + j) * sz) ])).
    Proof.
      intros ty cnt; induction cnt as [| cnt' IHcnt'] using N.peano_ind=> p i sz Hsz;
        first by rewrite N.mul_0_l !seqN_0.
      rewrite Nmult_Sn_m {1}/seqN N2Nat.inj_add seq_app -N2Nat.inj_add fmap_app.
      fold (seqN (i * sz) sz) (seqN (i * sz + sz)%N (cnt' * sz)).
      replace (i * sz + sz)%N with ((i + 1) * sz)%N by lia;
        rewrite big_sepL_app.
      rewrite seqN_S_start big_sepL_cons -N.add_1_r.
      specialize (IHcnt' (p .[ Tu8 ! -sz ]) (i + 1)%N sz Hsz).
      rewrite !o_sub_sub in IHcnt'.
      split'; iIntros "[P Q]"; iSplitL "P".
      - rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
        iExists sz; iFrame "%".
        iDestruct (big_sepL_type_ptr_shift with "P") as "?"; auto.
        rewrite o_sub_sub.
        by replace (Z.add (Z.of_N (i * sz)) (Z.of_N (i * sz)))
          with (Z.of_N ((i + i) * sz))
          by lia.
      - iApply big_sepL_mono; last iApply IHcnt'.
        + intros **; simpl.
          rewrite o_sub_sub.
          by replace (Z.add (-sz) (Z.of_N ((i + 1 + y) * sz)))
            with (Z.of_N ((i + y) * sz))
            by lia.
        + iApply big_sepL_mono; last by iFrame.
          intros **; simpl.
          by replace (Z.add (-sz) (Z.of_N ((i + 1) * sz)))
            with (Z.of_N (i * sz))
            by lia.
      - rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
        iDestruct "P" as (sz') "[%Hsz' tptrs]".
        rewrite Hsz' in Hsz; inversion Hsz; subst.
        iApply big_sepL_type_ptr_shift; auto.
        rewrite o_sub_sub.
        by replace (Z.add (Z.of_N (i * sz)) (Z.of_N (i * sz)))
          with (Z.of_N ((i + i) * sz))
          by lia.
      - iApply big_sepL_mono; last iApply IHcnt'.
        + intros **; simpl.
          by replace (Z.add (-sz) (Z.of_N ((i + 1) * sz)))
            with (Z.of_N (i * sz))
            by lia.
        + iApply big_sepL_mono; last by iFrame.
          intros **; simpl.
          rewrite o_sub_sub.
          by replace (Z.add (-sz) (Z.of_N ((i + 1 + y) * sz)))
            with (Z.of_N ((i + y) * sz))
            by lia.
    Qed.

    Lemma raw_type_ptrs_big_array :
      forall (p : ptr) (ty : type) (cnt sz : N),
        size_of σ ty = Some sz ->
            raw_type_ptrs (Tarray ty cnt) p
        -|- [∗list] i ∈ seqN 0 cnt, raw_type_ptrs ty (p .[ Tu8 ! Z.of_N (i * sz) ]).
    Proof.
      intros p ty cnt sz Hsz.
      pose proof (raw_type_ptrs_array_aux ty cnt p 0 sz Hsz) as Haux.
      split'; iIntros "P";
        rewrite o_sub_0 in Haux; auto; rewrite offset_ptr_id in Haux;
        rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
      - iDestruct "P" as (array_sz) "[%Harray_sz tptrs]".
        apply size_of_array_shatter in Harray_sz as [sz' [? [Hsz' Harray_sz]]]; subst.
        rewrite Hsz' in Hsz; inversion Hsz; subst.
        rewrite N.mul_0_l in Haux; rewrite Haux.
        iApply big_sepL_mono; last by iFrame.
        intros k y Hk=> /=.
        by rewrite raw_type_ptrs_eq/raw_type_ptrs_def N.add_0_l.
      - pose proof (size_of_array ty cnt sz Hsz).
        iExists (cnt * sz)%N; iFrame "%".
        iApply Haux.
        iApply big_sepL_mono; last by iFrame.
        intros k y Hk=> /=.
        by rewrite raw_type_ptrs_eq/raw_type_ptrs_def N.add_0_l.
    Qed.
  End equivalences.
End raw_type_ptrs.
#[global] Arguments raw_type_ptrs {_ Σ σ} _ _.
#[global] Arguments raw_type_ptrsR {_ Σ σ} _.
#[global] Hint Opaque raw_type_ptrs raw_type_ptrsR : typeclass_instances.

Section primR_transport.
  Context `{Σ : cpp_logic} {σ : genv}.

  Lemma _at_primR_ptr_congP_transport p p' ty q v :
    ptr_congP σ p p' ** type_ptr ty p' |-- p |-> primR ty q v -* p' |-> primR ty q v.
  Proof.
    iIntros "#[cong tptr'] prim".
    iDestruct (type_ptr_size with "tptr'") as "%Hsz"; destruct Hsz as [sz Hsz].
    iDestruct (type_ptr_raw_type_ptrs with "tptr'") as "raw_tptrs"; eauto.
    rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
    iDestruct "raw_tptrs" as (sz') "[%Hsz' tptrs]".
    rewrite Hsz' in Hsz; inversion Hsz; subst.
    rewrite primR_to_rawsR !_at_exists.
    iDestruct "prim" as (rs) "H"; iExists rs.
    rewrite !_at_sep !_at_only_provable !_at_type_ptrR.
    iDestruct "H" as "(raws & %raw_bytes & _)"; iFrame "#%".
    pose proof (raw_bytes_of_val_sizeof raw_bytes) as Hlen.
    rewrite Hlen in Hsz'; inversion Hsz'; subst.
    rewrite lengthN_fold.
    iRevert "raws".
    iApply _at_rawsR_ptr_congP_transport.
    by iFrame "#".
  Qed.
End primR_transport.

(* [Rep]s which can be encoded as [raw] bytes enjoy certain transport and cancellation properties *)
Section with_rawable.
  Context `{Σ : cpp_logic} {σ : genv}.
  Context {X : Type} (R : cQp.t -> X -> Rep).
  Context (decode : list raw_byte -> X -> Prop) (encode : X -> list raw_byte -> Prop).
  Context (enc_dec_uniq : forall (x x' : X) (raws : list raw_byte),
              encode x raws -> decode raws x' -> x = x').
  (* NOTE (JH): structs with padding are rawable, but this direction is too strict to permit
     the nondeterminism inherent in the representation of padding.
   *)
  (* Context (dec_enc_uniq : forall (x x' : X) (raws : list raw_byte), *)
  (*             decode raws x -> encode x raws' -> ). *)
  Context (ty : type) (sz : N) (Hsz : size_of σ ty = Some sz) (Hnonzero : (sz <> 0)%N).
  Context (Hdecode_sz : forall (x : X) (rs : list raw_byte), decode rs x -> lengthN rs = sz).
  Context (Hencode_sz : forall (x : X) (rs : list raw_byte), encode x rs -> lengthN rs = sz).
  Context (HR_decode : forall (rs : list raw_byte) (p : ptr) q,
                             p |-> rawsR q rs ** type_ptr ty p
                         |-- Exists (x : X),
                                [| decode rs x |] ** p |-> R q x).
  Context (HR_encode : forall (x : X) (p : ptr) q,
                             p |-> R q x
                         |-- type_ptr ty p **
                             Exists (rs : list raw_byte),
                               [| encode x rs |] ** p |-> rawsR q rs).

  #[local] Lemma _at_rawable_R_obj_repr_aux (i : N) :
    forall (p : ptr) q (rs : list raw_byte),
          p .[ Tu8 ! i ] |-> rawsR q (dropN i rs)
      |-- p .[ Tu8 ! i ] |-> arrayR Tu8 (fun tt => anyR Tu8 q)
                                        (replicateN (lengthN rs - i) ()).
  Proof.
    intros **; clear Hsz Hdecode_sz Hencode_sz Hnonzero HR_decode HR_encode.
    generalize dependent i; generalize dependent p.
    induction rs as [| r rs IHrs]; intros p i.
    - rewrite replicateN_0 dropN_nil /rawsR !arrayR_nil.
      done.
    - destruct i as [| i' _] using N.peano_ind=>//.
      + rewrite -> o_sub_0 in *; auto.
        specialize (IHrs (p .[ Tu8 ! 1 ]) 0%N).
        rewrite -> offset_ptr_id in *.
        rewrite -> N.sub_0_r in *.
        rewrite lengthN_cons replicateN_succ /rawsR !arrayR_cons
                !_at_sep !_at_offsetR.
        iIntros "(#tptr & raw & raws)".
        iFrame "#"; iSplitL "raw".
        * rewrite rawR_eq/rawR_def _at_as_Rep.
          by iApply tptsto_raw_anyR.
        * rewrite o_sub_0 in IHrs; auto; rewrite offset_ptr_id in IHrs.
          iApply IHrs.
          rewrite dropN_zero /rawsR _at_type_ptrR; iFrame "#∗".
      + replace (dropN (N.succ i') (r :: rs))
          with (dropN i' rs)
          by (rewrite -N.add_1_r dropN_cons_succ//).
        rewrite lengthN_cons.
        replace (lengthN rs + 1 - N.succ i')%N
          with (lengthN rs - i')%N
          by lia.
        specialize (IHrs (p .[ Tu8 ! 1 ]) i').
        rewrite o_sub_sub in IHrs.
        replace (1 + Z.of_N i')%Z with (Z.of_N (N.succ i')) in IHrs by lia.
        by iApply IHrs.
  Qed.

  Lemma _at_rawable_R_arrayR_anyR :
    forall (p : ptr) q (x : X),
          p |-> R q x
      |-- p |-> arrayR Tu8 (fun tt => anyR Tu8 q) (replicateN sz ()).
  Proof using encode ty Hsz Hencode_sz Hnonzero HR_encode.
    intros **.
    rewrite HR_encode.
    iIntros "[#tptr H]"; iDestruct "H" as (rs) "[%Hrs raws]".
    pose proof (_at_rawable_R_obj_repr_aux 0 p q rs) as Haux.
    rewrite o_sub_0 in Haux; auto; rewrite offset_ptr_id in Haux.
    rewrite dropN_zero N.sub_0_r (Hencode_sz x) in Haux; last by assumption.
    by iApply Haux.
  Qed.

  Lemma _at_rawable_R_anyR :
    forall (p : ptr) q (x : X),
          p |-> R q x
      |-- p |-> anyR (Tarray Tu8 sz) q.
  Proof using encode ty Hsz Hencode_sz Hnonzero HR_encode.
    intros **; rewrite anyR_array repeatN_replicateN.
    by apply _at_rawable_R_arrayR_anyR.
  Qed.

  Lemma R_ptr_congP_transport_via_rawsR :
    forall (p p' : ptr) q (x : X),
      ptr_congP σ p p' ** type_ptr ty p' |-- p |-> R q x -* p' |-> R q x.
  Proof using decode encode enc_dec_uniq sz Hdecode_sz Hencode_sz Hsz HR_decode HR_encode Hnonzero.
    intros p p' q x; rewrite HR_encode.
    iIntros "#[cong tptr'] [#tptr H]"; iDestruct "H" as (rs) "[%Henc raws]".
    iDestruct (type_ptr_raw_type_ptrs with "tptr'") as "#raw_tptrs'"; auto.
    assert (rs <> []) as Hrs_nonnil
        by (intro CONTRA; subst; specialize (Hencode_sz x [] Henc);
            apply Hnonzero; rewrite -Hencode_sz; by apply lengthN_nil).
    rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
    iDestruct "raw_tptrs'" as (sz') "[%Hsz' tptrs']".
    rewrite Hsz in Hsz'; inversion Hsz'; subst.
    assert (sz' = lengthN rs) as -> by (by erewrite <- Hencode_sz).
    iDestruct (_at_rawsR_ptr_congP_transport with "[$] [$]") as "raws'".
    iCombine "raws' tptr'" as "H".
    iDestruct (HR_decode with "H") as "H".
    iDestruct "H" as (x') "[%Hdec R]".
    by rewrite (enc_dec_uniq x x' rs).
  Qed.
End with_rawable.

Section blockR_transport.
  Context `{Σ : cpp_logic} {σ : genv}.

  Lemma blockR_ptr_congP_transport_raw (sz : N) :
    forall (p p' : ptr) (ty : type) q,
      size_of σ ty = Some sz ->
          ptr_congP σ p p' ** raw_type_ptrs ty p'
      |-- p |-> blockR sz q -* p' |-> blockR sz q.
  Proof.
    iIntros (p p' ty q Hty) "[#cong #raw_tptrs'] block".
    iDestruct (raw_type_ptrs_blockR_obs with "block") as "#raw_tptrs"; eauto.
    assert (sz = 0 \/ 0 < sz)%N as [Hsz | Hsz] by lia.
    - subst; rewrite blockR_eq/blockR_def !_at_sep !_at_offsetR/=.
      rewrite o_sub_0; eauto; rewrite !offset_ptr_id !_at_emp.
      iDestruct "block" as "[_ $]".
      rewrite _at_validR.
      iDestruct "cong" as "#(cong & tptr & tptr')".
      by iApply type_ptr_valid.
    - rewrite blockR_eq/blockR_def !_at_sep !_at_offsetR.
      iDestruct "block" as "[block_valid block]"; iSplit.
      + iDestruct (raw_type_ptrs_type_ptr_Tu8_obs
                     ty (N.pred sz) p' sz Hty ltac:(lia)
                    with "raw_tptrs'")
          as "#tptr_end'".
        rewrite !_at_validR.
        iDestruct (type_ptr_valid_plus_one with "tptr_end'") as "valid_end'".
        rewrite o_sub_sub.
        by have ->: (N.pred sz + 1)%Z = Z.of_N sz by lia.
      + rewrite !_at_big_sepL.
        (* TODO: find a strengthened [big_sepL] lemma for monotonicity in a given context *)
        rewrite raw_type_ptrs_eq/raw_type_ptrs_def.
        iDestruct "raw_tptrs" as (sz') "[%Hty' tptrs]".
        iDestruct "raw_tptrs'" as (sz'') "[%Hty'' tptrs']".
        rewrite Hty' in Hty; inversion Hty; subst; clear Hty.
        rewrite Hty'' in Hty'; inversion Hty'; subst; clear Hty' Hty''.
        iClear "block_valid".

        iDestruct "cong" as "-#cong".
        iDestruct "tptrs" as "-#tptrs".
        iDestruct "tptrs'" as "-#tptrs'".
        iRevert "block"; iStopProof.

        generalize dependent p'; generalize dependent p;
          induction sz as [| sz' IHsz'] using N.peano_ind;
          first by lia.

        assert (sz' = 0 \/ 0 < sz')%N as [Hsz' | Hsz'] by lia. 1: {
          iIntros (p p') "#(cong & tptrs & tptrs')"; subst.
          rewrite !N2Nat.inj_succ/= o_sub_0; eauto; rewrite !offset_ptr_id !_offsetR_id.
          iIntros "[any $]"; iRevert "any".
          iApply _at_anyR_ptr_congP_transport.
          by iFrame "cong"; iDestruct "cong" as "(_&_&$)".
        }

        iIntros (p p') "#(cong & tptrs & tptrs')".
        rewrite !seqN_S_start !N2Nat.inj_succ/=.
        rewrite o_sub_0; eauto; rewrite !_offsetR_id !offset_ptr_id.
        iDestruct "tptrs" as "[tptr tptrs]".
        iDestruct "tptrs'" as "[tptr' tptrs']".
        iIntros "[any REST]"; iSplitL "any".
        * iRevert "any"; iApply _at_anyR_ptr_congP_transport.
          by iFrame "cong tptr'".
        * rewrite !(big_sepL_type_ptr_shift 1 sz'); eauto.
          specialize (IHsz' Hsz' (p .[ Tu8 ! 1%N ]) (p' .[ Tu8 ! 1%N ])).
          iDestruct (IHsz' with "[]") as "IH".
          -- iFrame "tptrs tptrs'"; unfold ptr_congP.
             iDestruct "cong" as "(%Hcong & _ & _)".
             iSplitR.
             ++ iPureIntro; unfold ptr_cong in *.
                destruct Hcong as [p'' [o1 [o2 [-> [-> Hcong]]]]].
                exists p'', (o1 .[ Tu8 ! 1%N ]), (o2 .[ Tu8 ! 1%N ]).
                rewrite !offset_ptr_dot; intuition.
                unfold offset_cong in *.
                rewrite -> option.same_property_iff in *.
                destruct Hcong as [z [Ho1 Ho2]].
                exists (z + 1)%Z; rewrite !eval_offset_dot !eval_o_sub.
                by rewrite Ho1 Ho2//=.
             ++ iSplitL "tptrs"; destruct sz' using N.peano_ind; try lia;
                  rewrite seqN_S_start/= o_sub_0; eauto; rewrite !offset_ptr_id.
                ** by iDestruct "tptrs" as "[$ _]".
                ** by iDestruct "tptrs'" as "[$ _]".
          -- setoid_rewrite _at_offsetR.
             rewrite !(big_sepL_shift_nat (λ p, p |-> anyR Tu8 q) 1 (N.to_nat sz')).
             by iRevert "REST".
  Qed.

  (* NOTE (JH): In practice this will likely be difficult to use due to the
     [type_ptr ty p'] obligation.
   *)
  Lemma blockR_ptr_congP_transport (sz : N) :
    forall (p p' : ptr) (ty : type) q,
      size_of σ ty = Some sz ->
          ptr_congP σ p p' ** type_ptr ty p ** type_ptr ty p'
      |-- p |-> blockR sz q -* p' |-> blockR sz q.
  Proof.
    intros **; iIntros "(cong & _ & tptr')".
    rewrite type_ptr_raw_type_ptrs; eauto.
    by iApply blockR_ptr_congP_transport_raw; eauto.
  Qed.
End blockR_transport.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From bpf.comm Require Import MemRegion State Monad rBPFMonadOp.
From Coq Require Import List Lia.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.
Require Import ZArith.

From bpf.clightlogic Require Import Clightlogic CorrectRel CommonLemma.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
static __attribute__((always_inline)) inline unsigned int eval_mrs_num(struct bpf_state* st){
  return ( *st).mrs_num;
}

Print eval_mrs_num.
eval_mrs_num = fun st : State.state => Some (eval_mem_num st, st)
     : M nat

*)

Section Eval_mrs_num.
  Context {S : special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  Definition args : list Type := [].
  Definition res : Type := (nat:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M State.state res) := eval_mrs_num.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_eval_mrs_num.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) ((unit:Type) ::args) :=
    (dcons (fun _ => StateLess _ is_state_handle)
                (DList.DNil _)).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state := fun re => StateFull _ (fun v st m => nat_correct re v /\ re = (mrs_num st)).

  Instance correct_function_eval_mrs_num : forall a, correct_function _ p args res f fn ModNothing false match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f.
    repeat intro.
    get_invariant _st.
    unfold eval_inv, is_state_handle in c.
    subst.

    assert (Hst' := MS).
    destruct Hst'. clear - MS p0 mmrs_num mem_regs.

    eexists. exists m, Events.E0.

    split_and.
    {
      repeat forward_star.
      rewrite Ptrofs.add_zero_l.
      unfold Coqlib.align; simpl. change (832 / 8)%Z with 104%Z.

      destruct mmrs_num as (mmrs_num & _).
      unfold Mem.loadv in mmrs_num.
      rewrite mmrs_num.
      reflexivity.
      reflexivity.
    }
    split.
    {
      unfold match_res, nat_correct, eval_mem_num.
      split.
      reflexivity.
      unfold match_regions in mem_regs.
      destruct mem_regs as (_ & Hlen & Hrange & _).
      rewrite Hlen in Hrange.
      change Int.max_unsigned with Ptrofs.max_unsigned.
      lia.
    }
    unfold eval_mem_num. reflexivity.
    constructor. reflexivity.
    auto.
    apply unmodifies_effect_refl.
  Qed.

End Eval_mrs_num.

Existing Instance correct_function_eval_mrs_num.