(** This file is a tutorial to learn how to use the Cerise Program Logic within Coq.
    We will specify a simple program and explain how to use the tactics of the
    Cerise Proofmode to prove the specification.

    Prerequisites:
    We assume the user already knows how to use Iris and the Iris Proofmode,
    for instance with Heaplang. Learning material for Iris is available
    at this URL: https://iris-project.org/ *)

From iris.proofmode Require Import tactics.
From cap_machine Require Import rules proofmode macros_helpers.
From cap_machine Require Import contiguous.
Open Scope Z_scope.

(** The imports correspond to the following:
    - the Iris tactics and the Iris proofmode
    - the WP rules of the Cerise program logic
    - the automated tactics of the Cerise proofmode
    - some additional tactics for the Cerise proofmode

    We recommand to check the documentation of the proofmode of Cerise:
    https://github.com/logsem/cerise/blob/main/proofmode.md *)

Section base_program.
  (** Iris requires the ressources in the context. The resources of our machine
      are the registers and the memory. Moreover, we need the machine parameters
      in the context, which abstract the encoding and the decoding function
      (for instance, to encode the instructions). *)
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (** The program is a list of instructions. As the machine has a Von Neumann
      architecture, the instructions are encoded data. The function
      `encodeInstrsW` transforms a list of instructions into integers.
      The encoding does not matter, as we always manipulate the encoded
      instructions with the decoding function. *)

  (** The program we will study in this file moves a pointer in a buffer and
      stores a value at this new location. More precisely, we assumes that the
      register `r1` of the machine contains a capability pointing to a memory
      buffer of size >= 1. The program derives a capability to the next address,
      and stores the value of the register `r2` at this address. *)

  Definition prog_instrs : list Word :=
    encodeInstrsW [
      Lea r_t1 1 ;    (* load effective address 1 into `r1` *)
      Store r_t1 r_t2 (* store value from `r2` at address specified by `r1` *)
    ].

  (** We use the program logic to specify the program. In the program logic,
      there is 2 types of ressources:
      - the register /reg/ maps to the word /w/, reg ↦ᵣ w
      - the address /a/ maps to the word /w/, a ↦ₐ w.
      The notation [[a1, a2]] ↦ₐ [[lw]] maps the list of words /lw/ to the
      contiguous fragment of memory between the adresses /a1/ and /a2/.

      To write the specification, we need to have the separation logic
      assertion that describe all the resources required throughout the
      execution. In this case, we need the ownership of:
      - the fragment of the memory with the instructions of the program,
        stored between the adresses `a_prog` and `a_prog + len(prog)`
      - the memory buffer on which the program stores the new value,
        between the addresses `b_mem` and `b_mem + 2`
      - the PC contains a capability pointing to the first addresse of the
        program `a_prog`, with all the required permissions
        (i.e. validity range and executable)
      - the registers `r1` and `r2`, where `r1` contains the capability to the
        buffer and `r2` contains the new data (in our case, 42)

      The usual way to specify a program in Cerise in Coq is to use the
      weakest-precondition (WP) with a Continuation Passing Style, instead of
      the Hoare Triples.
      The CPS style is defined as follows:

      {P} e {Q} ≡ ∀ ϕ, (P ∗ ▷(Q -∗ WP e { ϕ })) -∗ WP e { ϕ }

      It is important to notice that, for a such low-level programming language,
      there is no notion of expression. The semantic only describes how the
      state of the machine changes at each execution step, as soon as the machine
      is in a Running state.
      However, the WP property requires an expression. In this way, an
      expression in the Cerise program logic encodes only the execution state of
      the machine (Running, Halted or Failed) (1).
      Thus, the WP rules only describes how the resources of the machine evolve
      at each execution step.

      (1) For technical purpose, an expression in actually either a (non-atomic)
          Sequence of instructions, or an (atomic) Instruction. *)

  (** The following lemma `prog_spec_instr` is a specification of the program
      previously defined.

      The SL assertion for the fragment of code is `codefrag a_prog prog_instr`.

      The PCC (PC Capability) has the permission `pc_p`, which has, at least,
      the execution permission: `ExecPCPerm p_pc`.
      The validity range of the PCC, between the addresses `pc_b` and `pc_e`,
      is larger than the actual range of the code fragment. Indeed, for
      modular purposes, the program we are specifying may be a part of a larger
      program. Thus, we need to ensure the fragment of the code is included in
      the PCC range, i.e. `SubBounds b_pc e_pc a_prog e_prog`.

      Because we work with addresses, which are actually finite integers,
      we need to assume the addresses are always valid when we do addresses
      arithmetic operations (for instance, there is no overflow of the memory).
      In particular, the memory buffer is a contiguous region of memory where
      all the addresses are in the bounds of the memory.

      For simplicity, we assume the buffer is filled with 0.

      When the whole program is a list of instructions, it is required to
      manually get some helping facts before reasoning on the instructions,
      using the tactic `codefrag_facts "Hprog"`. This tactic has to be used
      when the `codefrag` assertion is used. It allows to get some additionnal
      facts about the memory addresses containing the code. It is a boilerplate.

      To prove the specification, the idea is to manipulate the resources, such
      that we have all the required assertion that fit with the corresponding
      WP rule. Once all the resource are ready, the tactic `iInstr "Hprog"`
      steps through one instruction, automatically finds the appropriate rule,
      and tries to discharge as much goal as possible (e.g. side-condition
      about the PC). It only remains some side-condition to prove manually,
      such as address arithmetic.
      We can use the tactic `solve_addr` to solve automatically the address
      arithmetic goals. It sometimes requires to transform the goal or
      hypotheses a bit to work.

      We advice to read carefully the following specification and to try to
      understand each statement in the lemma.
      Then, we urge to execute the proof step by step, and to understand
      each time what happens to the proof state and why we are doing it. *)

  Lemma prog_spec_instr
    p_pc b_pc e_pc a_prog (* pc *)
    b_mem (* mem *)
    φ :

    let e_mem := (b_mem ^+ 2)%a in (* end of memory buffer at b_mem+2 *)
    let e_prog := (a_prog ^+ length prog_instrs)%a in (* end of program at a_prog + length of instructions *)

    ExecPCPerm p_pc -> (* p_pc has at least the executable permission*)
    SubBounds b_pc e_pc a_prog e_prog -> (* [b_pc : e_pc) contains [a_prog : e_prog) *)
    ContiguousRegion b_mem 2 → (* addresses in [b_mem : b_mem+2) are valid *)

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog (* PC points to the prog *)
        ∗ codefrag a_prog prog_instrs (* the prog instruction start at a_prog *)
        ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem (* r1 points to the allocated memory *)
        ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]] (* memory buffer, filled with 0 *)
        ∗ r_t2 ↦ᵣ WInt 42 (* new value 42 *)
         ∗ ▷ ( (* everything under the later `▷` and before the wand `-*` is our postcondition *)
                PC ↦ᵣ WCap p_pc b_pc e_pc e_prog (* PC has reached the end of the program *)
                ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+1)%a (* r1 points to b_mem + 1*)
                ∗ r_t2 ↦ᵣ WInt 42 (* unchanged *)
                ∗ codefrag a_prog prog_instrs (* unchanged *)
                ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]] (* our memory buffer now contains 42 *)
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
  Proof.
    intros * Hpc_perm Hpc_bounds Hmem_bounds.
    unfold ContiguousRegion in Hmem_bounds.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr2& Hcont)".

    (* 1 - prepare the assertions for the proof *)
    subst e_mem e_prog; simpl. (* replace e_mem and e_prog with their known values *)
    (* Derives the facts from the codefrag *)
    codefrag_facts "Hprog".
    simpl in *.

    (* 2 - wp rules for each instructions *)
    (* Lea *)
    iInstr "Hprog".

    (* Store requires the resource (b_mem ^+ 1), we need to
       destruct the region_mapsto.
       This essentially the same as destructing a list into (first element)::(rest of list).
       We do it twice since we need the second element (b_mem ^+ 1). *)
    iDestruct (region_mapsto_cons with "Hmem") as "(Hmem0& Hmem1)".
    { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr.  }
    { by solve_addr. }
    iDestruct (region_mapsto_single with "Hmem1") as "Hmem1".
    { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr. }
    iDestruct "Hmem1" as (v) "(Hmem1& %Hr)".
    injection Hr ; intro Hr' ; subst ; clear Hr.

    (* Store *)
    iInstr "Hprog".

    (* 3 - Continuation *)
    iApply "Hcont".
    iFrame.
    iApply region_mapsto_cons.
    { transitivity (Some (b_mem ^+1)%a) ; auto ; by solve_addr.  }
    { by solve_addr. }
    iFrame.
    iApply region_mapsto_cons.
    { transitivity (Some (b_mem ^+(1+1))%a) ; auto ; by solve_addr.  }
    { by solve_addr. }
    iFrame.
    replace (b_mem ^+ (1 + 1))%a with (b_mem ^+ 2)%a by solve_addr.
    unfold region_mapsto.
    rewrite finz_seq_between_empty ; last solve_addr.
    done.
  Qed.

  (** The tactic `iGo "Hprog"` steps through multiple instructions,
     until a side-condition needs to be prove manually. *)

  (** **** Exercise 1 --- More automation with iGo
      Prove the specification of the previous example using the automated
      tactic `iGo`. In order to leverage the strengh of the tactic, the memory
      resources should be ready before the execution of the tactic, in
      particular, the memory buffer should be split at the beginning of the
      proof: it will allows the tactic `iGo` to step through multiple
      instructions at once.

      Tips: take inspiration on the proof of the previous exercise, but we
            recommend to try to manipulate the SL resources and the address
            arithmetic by yourself.
            Indeed, address arithmetic is a very common side-condition,
            and the lemmas often require you to manipulate the PL resources
            in order to make them fit with the hypothesis. *)

  Lemma prog_spec_igo
    p_pc b_pc e_pc a_prog (* pc *)
    b_mem (* mem *)
    φ :

    let e_mem := (b_mem ^+ 2)%a in
    let e_prog := (a_prog ^+ length prog_instrs)%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog e_prog ->
    ContiguousRegion b_mem 2 →

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ codefrag a_prog prog_instrs
        ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem
        ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]]
        ∗ r_t2 ↦ᵣ WInt 42
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
                ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+1)%a
                ∗ r_t2 ↦ᵣ WInt 42
                ∗ codefrag a_prog prog_instrs
                ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]]
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
  Proof.
    intros * Hpc_perm Hpc_bounds Hmem_bounds.
    unfold ContiguousRegion in Hmem_bounds.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr2& Hcont)".
    subst e_mem e_prog; simpl.

    (* Derive the facts from the codefrag *)
    (* FILL IN HERE *)

    (* Prepare the memory resource for the Store *)
    (* FILL IN HERE *)

    (* 2 - step through multiple instructions *)
    (* FILL IN HERE *)

    (* 3 - Continuation *)
    (* FILL IN HERE *)
    Admitted.

  (** The tactics `iInstr` and `iGo` automatically lookup the PC, find the
      corresponding instruction in the `codefrag` instruction, find the
      right WP rule to apply accordingly with the instruction, instantiate
      the lemma and try to prove as much precondition as possible.

      However, in order to get a better understanding of the way to use the
      WP rules in Cerise, we propose to prove the previous lemma using the
      fully detailed tactics.
      It is also useful if the assertion that embeds the code is not the
      `codefrag` predicate, but for instance, the big conjonction separation
      `[∗ list]` --- even though it is usually possible to rewrite the one
      in term of the other. *)

  (** **** Exercise 2 --- Manual detailled proofs
        For this exercise, we propose to re-do the proof of the previous
        specification, using the manual WP rules.
        We explain the different steps for the first instruction `Lea`.
        Complete the proof.
   *)

  Lemma prog_spec_detailed
    p_pc b_pc e_pc (* pc *)
    a_prog a
    b_mem (* mem *)
    φ :

    let e_mem := (b_mem ^+ 2)%a in
    let e_prog := (a_prog ^+ length prog_instrs)%a in

    ExecPCPerm p_pc ->
    SubBounds b_pc e_pc a_prog e_prog ->
    contiguous_between a a_prog (e_prog) →
    ContiguousRegion b_mem 2 →

    ⊢ ( PC ↦ᵣ WCap p_pc b_pc e_pc a_prog
        ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I
        ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem b_mem
        ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 0] ]]
        ∗ r_t2 ↦ᵣ WInt 42
         ∗ ▷ ( PC ↦ᵣ WCap p_pc b_pc e_pc e_prog
                ∗ r_t1 ↦ᵣ WCap RW b_mem e_mem (b_mem ^+1)%a
                ∗ r_t2 ↦ᵣ WInt 42
               ∗ ([∗ list] a_i;w ∈ a;prog_instrs, a_i ↦ₐ w)%I
                ∗ [[b_mem, e_mem]] ↦ₐ [[ [WInt 0; WInt 42] ]]
               -∗ WP Seq (Instr Executable) {{ φ }}))
       -∗ WP Seq (Instr Executable) {{ φ }}%I.
  Proof.
    intros * Hpc_perm Hpc_bounds Hprog_addr Hmem_bounds.
    iIntros "(HPC& Hprog& Hr1& Hmem& Hr2& Hcont)".
    subst e_mem e_prog; simpl in *.
    (* In order to use the tactic `iCorrectPC` that solves the side-condition
       about the PC, we need this assertion, equivalent to
       `Hpc_perm /\ Hpc_bounds` *)
    assert (Hpc_correct : isCorrectPC_range p_pc b_pc e_pc a_prog (a_prog ^+ 2)%a).
    { unfold isCorrectPC_range. intros.
      apply isCorrectPC_ExecPCPerm_InBounds ; auto ; solve_addr.
    }

    (* 2 - step through instructions *)
    (* 2.1 - Lea *)
    (* Prepare the resources
       Destruct the list of addresses of the code fragment *)
    iDestruct (big_sepL2_length with "Hprog") as %Hlength_prog.
    destruct_list a.
    pose proof (contiguous_between_cons_inv_first _ _ _ _ Hprog_addr) as ->.
    (* Focus to the atomic expression (regarding the operational semantic) *)
    iDestruct "Hprog" as "[Hi Hprog]".
    iApply (wp_bind (fill [SeqCtx])).
    (* Apply the WP rule corresponding to the instruction
       and prove the preconditions of the rule *)
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr1]").
    { apply decode_encode_instrW_inv. }
    { iCorrectPC a_prog (a_prog ^+ 2)%a. }
    { iContiguous_next Hprog_addr 0%nat. }
    { transitivity (Some (b_mem ^+ 1 )%a) ; auto ; solve_addr. }
    { auto. }
    (* Introduce the postconditions of the rule and re-focus the expression. *)
    iNext; iIntros "(HPC& Hdone& Hr1)"; iSimpl.
    iApply wp_pure_step_later;auto;iNext.

    (* 2.2 - Store *)
    (* Destruct the list of addresses of the code fragment *)
    pose proof (contiguous_between_last _ _ _ a Hprog_addr eq_refl) as Hlast.

    (* Prepare the memory resource for the Store *)
    (* FILL IN HERE *)

    (* Focus to the atomic expression (regarding the operational semantic) *)
    (* FILL IN HERE *)

    (* Apply the WP rule corresponding to the instruction
       and prove the preconditions of the rule *)
    (* FILL IN HERE *)

    (* Introduce the postconditions of the rule and re-focus the expression. *)
    (* FILL IN HERE *)

    (* 3 - Continuation *)
    (* FILL IN HERE *)

    Admitted.

  (** The next step to learn how to use the Cerise Proofmode is to leverage
      the modularity of program logic to define macros and use their
      specification inside bigger programs.
      The next part of the tutorial "cerise_modularity.v" will learn you how
      to define, specify and use user-defined macros, and present you the main
      macros already defined in Cerise.
   *)

End base_program.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.list_dt.  Import LsegSpecial.
Require Import VST.progs.queue2.

Open Scope logic.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_elem := Tstruct _elem noattr.
Definition t_struct_fifo := Tstruct _fifo noattr.

Instance QS: listspec _elem _next (fun sh => malloc_token Ews t_struct_elem).
Proof. eapply mk_listspec; reflexivity. Defined.

Lemma isnil: forall {T: Type} (s: list T), {s=nil}+{s<>nil}.
Proof. intros. destruct s; [left|right]; auto. intro Hx; inv Hx. Qed.

Lemma field_at_list_cell:
  forall sh i v p,
  data_at sh t_struct_elem (i,v) p
  = list_cell QS sh i p *
  field_at sh t_struct_elem [StructField _next] v p.
Proof.
intros.
unfold_data_at (data_at _ _ _ _).
f_equal.
unfold field_at, list_cell.
autorewrite with gather_prop.
f_equal.
apply ND_prop_ext.
rewrite field_compatible_cons; simpl.
intuition.
left; auto.
Qed.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vint (Int.repr (sizeof t))) GLOBALS (gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       RETURN (p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition fifo_body (contents: list val) (hd tl : val) :=
     (if isnil contents
      then (!!(hd=nullval) && emp)
      else (EX prefix: list val, EX last: val,
              !!(contents = prefix++last::nil)
            &&  (lseg QS Ews prefix hd tl
                   * malloc_token Ews t_struct_elem tl
                   * data_at Ews t_struct_elem (last, nullval) tl)))%logic.

Definition fifo (contents: list val) (p: val) : mpred :=
  EX ht: (val*val), let (hd,tl) := ht in
      !! is_pointer_or_null hd && !! is_pointer_or_null tl &&
      data_at Ews t_struct_fifo (hd, tl) p * malloc_token Ews t_struct_fifo p *
      fifo_body contents hd tl.

Definition fifo_new_spec :=
 DECLARE _fifo_new
  WITH gv: globals
  PRE  [  ]
       PROP() PARAMS() GLOBALS (gv) SEP (mem_mgr gv)
  POST [ (tptr t_struct_fifo) ]
    EX v:val, PROP() RETURN (v) SEP (mem_mgr gv; fifo nil v).

Definition fifo_put_spec :=
 DECLARE _fifo_put
  WITH q: val, contents: list val, p: val, last: val
  PRE  [ tptr t_struct_fifo , tptr t_struct_elem ]
          PROP () PARAMS (q; p)
          SEP (fifo contents q;
                 malloc_token Ews t_struct_elem p;
                 data_at Ews t_struct_elem (last,Vundef) p)
  POST [ tvoid ]
          PROP() RETURN() SEP (fifo (contents++(last :: nil)) q).

Definition fifo_empty_spec :=
 DECLARE _fifo_empty
  WITH q: val, contents: list val
  PRE  [ tptr t_struct_fifo ]
     PROP() PARAMS (q) SEP(fifo contents q)
  POST [ tint ]
      PROP ()
      RETURN (if isnil contents then Vtrue else Vfalse)
      SEP (fifo (contents) q).

Definition fifo_get_spec :=
 DECLARE _fifo_get
  WITH q: val, contents: list val, first: val
  PRE  [ tptr t_struct_fifo ]
       PROP() PARAMS(q) SEP (fifo (first :: contents) q)
  POST [ (tptr t_struct_elem) ]
      EX p:val,
       PROP ()
       RETURN (p)
       SEP (fifo contents q;
              malloc_token Ews t_struct_elem p;
              data_at Ews t_struct_elem (first,Vundef) p).

Definition make_elem_spec :=
 DECLARE _make_elem
  WITH i: int, gv: globals
  PRE  [ tint ]
        PROP() PARAMS (Vint i) GLOBALS (gv) SEP(mem_mgr gv)
  POST [ (tptr t_struct_elem) ]
    EX p:val,
       PROP()
       RETURN (p)
       SEP (mem_mgr gv;
              malloc_token Ews t_struct_elem p;
              data_at Ews t_struct_elem (Vint i, Vundef) p).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
       PROP() RETURN (Vint (Int.repr 1)) SEP(TT).

Definition Gprog : funspecs :=
  ltac:(with_library prog
    [surely_malloc_spec; fifo_new_spec; fifo_put_spec;
     fifo_empty_spec; fifo_get_spec; make_elem_spec;
     main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     (t,gv).
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call 1.
    contradiction.
*
    if_tac.
    + forward. subst p. congruence.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma fifo_isptr: forall al q, fifo al q |-- !! isptr q.
Proof.
intros.
 unfold fifo, fifo_body.
 Intros ht; destruct ht; Intros.
 if_tac.  entailer!.  Intros prefix; entailer!.
Qed.

#[export] Hint Resolve fifo_isptr : saturate_local.

Lemma body_fifo_empty: semax_body Vprog Gprog f_fifo_empty fifo_empty_spec.
Proof.
start_function.
unfold fifo.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* h = Q->head; *)
forward. (* return (h == NULL); *)
{
unfold fifo, fifo_body.
destruct (isnil contents).
+ Intros. subst. auto with valid_pointer.
+ entailer!.
  destruct hd; inv PNhd; entailer!.
}
unfold fifo, fifo_body.
Exists (hd,tl).
destruct (isnil contents).
* entailer!.
* Intros prefix last.
Exists prefix last.
  assert_PROP (isptr hd).
    destruct prefix.
    rewrite @lseg_nil_eq; entailer!.
    rewrite @lseg_cons_eq by auto. Intros y.
    entailer!.
 destruct hd; try contradiction.
 entailer!.
Qed.

Lemma body_fifo_new: semax_body Vprog Gprog f_fifo_new fifo_new_spec.
Proof.
  start_function.

  forward_call (* Q = surely_malloc(sizeof ( *Q)); *)
     (t_struct_fifo, gv).
  Intros q.
  assert_PROP (field_compatible t_struct_fifo [] q).
   entailer!.
  forward. (* Q->head = NULL; *)
  forward. (* Q->tail = NULL; *)
  forward. (* return Q; *)
  Exists q. unfold fifo, fifo_body. Exists (nullval,nullval).
  rewrite if_true by auto.
  simpl sizeof.
  entailer!.
Qed.

Lemma body_fifo_put: semax_body Vprog Gprog f_fifo_put fifo_put_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* p->next = NULL; *)
forward. (*   h = Q->head; *)
forward_if
  (PROP() LOCAL () SEP (fifo (contents ++ last :: nil) q))%assert.
* unfold fifo_body; if_tac. entailer!. Intros prefix last0; entailer!.
* (* then clause *)
  subst.
  forward. (* Q->head=p; *)
  forward. (* Q->tail=p; *)
  entailer!.
  unfold fifo, fifo_body.
  destruct (isnil contents).
  + subst. Exists (p,p).
     simpl. rewrite if_false by congruence.
     Exists (@nil val) last.
      rewrite @lseg_nil_eq by auto.
      entailer!.
   + Intros prefix last0.
      destruct prefix;
      entailer!.
      rewrite @lseg_cons_eq by auto. simpl.
      Intros y.
      entailer!.
* (* else clause *)
  forward. (*  t = Q->tail; *)
  unfold fifo_body.
  destruct (isnil contents).
  + Intros. contradiction H; auto.
  + Intros prefix last0.
     forward. (*  t->next=p; *)
     forward. (* Q->tail=p; *)
     entailer!.
     unfold fifo, fifo_body. Exists (hd, p).
     rewrite if_false by (clear; destruct prefix; simpl; congruence).
     Exists  (prefix ++ last0 :: nil) last.
     entailer.   (* not entailer!, which would cancel *)
     rewrite (field_at_list_cell Ews last0 p).
     unfold_data_at (@data_at CompSpecs Ews t_struct_elem (last,nullval) p).
     unfold_data_at (data_at _ _ _ p).
     simpl sizeof.
     match goal with
     | |- _ |-- _ * _ * (_ * ?AA) => remember AA as A
     end.     (* prevent it from canceling! *)
     cancel. subst A.
     eapply derives_trans;
        [ | apply (lseg_cons_right_neq QS Ews prefix hd last0 tl nullval p ); auto].
     simpl sizeof.  cancel.
Qed.

Lemma body_fifo_get: semax_body Vprog Gprog f_fifo_get fifo_get_spec.
Proof.
start_function.
unfold fifo at 1, fifo_body.
Intros ht; destruct ht as [hd tl].
rewrite if_false by congruence.
Intros prefix last.
forward.  (*   h = Q->head; *)
destruct prefix; inversion H; clear H.
+
   rewrite @lseg_nil_eq by auto.
   Intros.
   subst_any.
   forward. (*  n=h->next; *)
   forward. (* Q->head=n; *)
   forward. (* return p; *)
   unfold fifo, fifo_body. Exists tl (nullval, tl).
   rewrite if_true by congruence.
   entailer!. simpl sizeof.
   do 2 unfold_data_at (data_at _ _ _ _). cancel.
+ rewrite @lseg_cons_eq by auto.
    Intros x.
    simpl @valinject. (* can we make this automatic? *)
    subst_any.
    forward. (*  n=h->next; *)
    forward. (* Q->head=n; *)
    forward. (* return p; *)
    Exists hd. unfold fifo, fifo_body. Exists (x, tl).
    rewrite if_false by (destruct prefix; simpl; congruence).
    Exists prefix last.
    entailer!.
    rewrite field_at_list_cell. simpl sizeof. cancel.
Qed.

Lemma body_make_elem: semax_body Vprog Gprog f_make_elem make_elem_spec.
Proof.
start_function.
forward_call (*  p = surely_malloc(sizeof ( *p));  *)
    (t_struct_elem, gv).
Intros p.
forward.  (*  p->data=i; *)
simpl.
forward. (* return p; *)
Exists p.
entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
forward_call (* Q = fifo_new(); *)  gv.
Intros q.

forward_call  (*  p = make_elem(1); *)
     (Int.repr 1, gv).
Intros p'.
forward_call (* fifo_put(Q,p);*)
    ((q, @nil val),p', Vint (Int.repr 1)).

forward_call  (*  p = make_elem(2); *)
     (Int.repr 2, gv).
Intros p2.
simpl app.
 forward_call  (* fifo_put(Q,p); *)
    (((q,[Vint (Int.repr 1)]),p2), Vint (Int.repr 2)).
simpl app.
forward_call  (*   p' = fifo_get(Q); p = p'; *)
    ((q,[Vint (Int.repr 2)]), Vint (Int.repr 1)).
Intros p3.
forward. (*   i = p->data;  *)
forward_call (*  free(p); *)
   (t_struct_elem, p3, gv).
assert_PROP (isptr p3); [entailer! | rewrite if_false by (intro; subst; contradiction) ]; cancel.
forward. (* return i; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
  prove_semax_prog.
  semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
  semax_func_cons body_free.
  semax_func_cons body_exit.
  semax_func_cons body_surely_malloc.
  semax_func_cons body_fifo_new.
  semax_func_cons body_fifo_put.
  semax_func_cons body_fifo_empty.
  semax_func_cons body_fifo_get.
  semax_func_cons body_make_elem.
  semax_func_cons body_main.
Qed.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Named.Syntax.

Module Export Named.
  Section language.
    Context {base_type_code : Type}
            {interp_base_type : base_type_code -> Type}
            {op : flat_type base_type_code -> flat_type base_type_code -> Type}
            {Name : Type}.

    (** [SmartVar] is like [Var], except that it inserts
          pair-projections and [Pair] as necessary to handle
          [flat_type], and not just [base_type_code] *)
    Definition SmartVar {t} : interp_flat_type (fun _ => Name) t -> @exprf base_type_code op Name t
      := smart_interp_flat_map (f:=fun _ => Name) (g:=@exprf _ _ _) (fun t => Var) TT (fun A B x y => Pair x y).
  End language.
End Named.

Global Arguments SmartVar {_ _ _ _} _.


Require Import CSet Le ListUpdateAt Coq.Classes.RelationClasses.

Require Import Plus Util AllInRel Map Terminating ContextMap.
Require Import Val Var Envs IL Annotation AnnotationLattice.
Require Import Infra.Lattice DecSolve LengthEq MoreList Status AllInRel OptionR.
Require Import Keep Subterm Analysis.
Require Import FiniteFixpointIteration.

Set Implicit Arguments.

Definition forwardF (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)}
           (forward: forall s (ST:subTerm s sT),
               ctxmap (Dom sT) -> ann (Dom sT) -> ann (Dom sT) * ctxmap (Dom sT))
           (F:list (params * stmt))
           (ST:forall n s, get F n s -> subTerm (snd s) sT)
           (AL:ctxmap (Dom sT)) (anF:list (ann (Dom sT)))
  : list (ann (Dom sT)) * ctxmap (Dom sT).
  revert AL F anF ST.
  fix g 2. intros.
  destruct F as [|Zs F'].
  - eapply (nil, AL).
  - destruct anF as [|a anF'].
    + eapply (nil, AL).
    + pose proof (forward (snd Zs) (ST 0 Zs ltac:(eauto using get)) AL a).
      pose proof (g (snd X) F' anF' ltac:(eauto using get)).
      eapply (fst X :: fst X0, snd X0).
Defined.

Arguments forwardF [sT] [Dom] {H} {H0} forward F ST AL anF.

Fixpoint forwardF_length (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)} forward         (F:list (params * stmt))
         (ST:forall n s, get F n s -> subTerm (snd s) sT)
         AL (anF:list (ann (Dom sT)))
         {struct F}
  : length (fst (forwardF forward F ST AL anF)) = min (length F) (length anF).
Proof.
  destruct F as [|Zs F'], anF; simpl; eauto.
Qed.

Smpl Add
     match goal with
     | [ |- context [ ❬fst (@forwardF ?sT ?Dom ?H ?JSL ?f ?F ?ST ?AL ?anF)❭ ] ] =>
       rewrite (@forwardF_length sT Dom H JSL f F ST AL anF)
     | [ H : context [ ❬fst (@forwardF ?sT ?Dom ?H ?JSL ?f ?F ?ST ?AL ?anF)❭ ] |- _ ] =>
       rewrite (@forwardF_length sT Dom H JSL f F ST AL anF) in H
     end : len.

Lemma forwardF_length_ass (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)}
      forward AL F anF ST k
  : length F = k
    -> length F = length anF
    -> length (fst (forwardF forward F ST AL anF)) = k.
Proof.
  intros. rewrite forwardF_length, <- H2.
  repeat rewrite Nat.min_idempotent; eauto.
Qed.

Hint Resolve @forwardF_length_ass : len.

Fixpoint forward (sT:stmt) (Dom: stmt -> Type)
         `{JoinSemiLattice (Dom sT)}
         `{@LowerBounded (Dom sT) H}
           (ftransform :
              forall sT, ctxmap params ->
                    forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
           (ZL:ctxmap params)
           (st:stmt) (ST:subTerm st sT)
           (AL:ctxmap (Dom sT)) (a:ann (Dom sT)) {struct st}
  :  ann (Dom sT) * ctxmap (Dom sT)
  := match st as st', a return st = st' -> ann (Dom sT) * ctxmap (Dom sT) with
    | stmtLet x e s as st, ann1 d ans =>
      fun EQ =>
        let d' := getAnni d (ftransform sT ZL st ST d) in
        let (ans', AL) := forward Dom ftransform ZL (subTerm_EQ_Let EQ ST)
                                 AL (setTopAnn ans d') in
        (ann1 d ans', AL)

    | stmtIf x s t, ann2 d ans ant =>
      fun EQ =>
        let an := ftransform sT ZL st ST d in
        let d1 := (getAnniLeft d an) in
        let d2 := (getAnniRight d an) in
        let (ans', AL') := forward Dom ftransform ZL (subTerm_EQ_If1 EQ ST)
                                  AL (setTopAnn ans d1) in
        let (ant', AL'') := forward Dom ftransform ZL (subTerm_EQ_If2 EQ ST)
                                   AL' (setTopAnn ant d2) in
        (ann2 d ans' ant', AL'')

    | stmtApp f Y as st, ann0 d as an =>
      fun EQ =>
        let an := ftransform sT ZL st ST d in
        (ann0 d, ctxmap_join_at AL (counted f) (getAnni d an))

    | stmtReturn x as st, ann0 d as an =>
      fun EQ => (ann0 d, AL)

    | stmtFun F t as st, annF d anF ant =>
      fun EQ =>
        let ZL' := ctxmap_app (List.map fst F) ZL in
        let AL' := ctxmap_extend AL (length F) in
        let (ant', ALt) := forward Dom ftransform ZL' (subTerm_EQ_Fun1 EQ ST)
                                  AL' (setTopAnn ant d) in
        let (anF', AL'') := forwardF (forward Dom ftransform ZL') F (subTerm_EQ_Fun2 EQ ST)
                                    ALt anF in
        (annF d (MoreList.mapi (fun i a => setTopAnn a (ctxmap_at_def AL'' i)) anF') ant',
         ctxmap_drop ❬F❭ AL'')
    | _, an => fun EQ => (an, AL)
  end eq_refl.

(*
Lemma get_forwardF  (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)}
           (forward: forall s (ST:subTerm s sT) (a:ann (Dom sT)),
                       ann (Dom sT) * list (Dom sT))
           (F:list (params * stmt)) (anF:list (ann (Dom sT)))
           (ST:forall n s, get F n s -> subTerm (snd s) sT) n Zs a
  :get F n Zs
   -> get anF n a
   -> { ST' | get (forwardF forward F anF ST) n (forward (snd Zs) ST' a) }.
Proof.
  intros GetF GetAnF.
  eapply get_getT in GetF.
  eapply get_getT in GetAnF.
  general induction GetAnF; destruct Zs as [Z s]; inv GetF; simpl.
  - eexists; econstructor.
  - edestruct IHGetAnF; eauto using get.
Qed.

Ltac inv_get_step_analysis_forward :=
  match goal with
  | [ H: get (@forwardF ?sT ?Dom ?PO ?BSL ?f ?F ?anF ?ST) ?n ?x |- _ ]
    => eapply (@forwardF_get sT Dom PO BSL f F anF ST x n) in H;
      destruct H as [? [? [? [? [? ]]]]]
  end.

Smpl Add inv_get_step_analysis_forward : inv_get.
 *)

Lemma forwardF_monotone' (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)}
      (forward: forall s (ST:subTerm s sT),
          ctxmap (Dom sT) -> ann (Dom sT) -> ann (Dom sT) * ctxmap (Dom sT))
      F
      (forward_mon: forall AL AL', poLe AL AL' -> forall n Zs, get F n Zs -> forall (ST:subTerm (snd Zs) sT),
          forall (a b : ann (Dom sT)), a ⊑ b ->
                                  forward _ ST AL a ⊑ forward _ ST AL' b)
  : forall AL AL', poLe AL AL' -> forall ST,
    forall anF bnF, anF ⊑ bnF ->
               forwardF forward F ST AL anF ⊑ forwardF forward F ST AL' bnF.
Proof.
  intros. general induction H2; destruct F; simpl; eauto 20 using get.
Qed.

Lemma snd_forwardF_exp' (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)}
      (forward: forall s (ST:subTerm s sT),
          ctxmap (Dom sT) -> ann (Dom sT) -> ann (Dom sT) * ctxmap (Dom sT))
      F
      (forward_exp: forall AL AL' n Zs, get F n Zs -> forall (ST:subTerm (snd Zs) sT),
          forall (a : ann (Dom sT)), AL ⊑ AL' -> AL ⊑ snd (forward _ ST AL' a))
  : forall AL AL' ST anF, AL ⊑ AL' -> AL ⊑ snd (forwardF forward F ST AL' anF).
Proof.
  intros. general induction anF; destruct F; simpl; eauto using get.
Qed.

Lemma forwardF_ext' (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)}
      (forward: forall s (ST:subTerm s sT),
          ctxmap (Dom sT) -> ann (Dom sT) -> ann (Dom sT) * ctxmap (Dom sT))
      F
      (forward_mon: forall AL AL', AL ≣ AL' -> forall n Zs, get F n Zs -> forall (ST:subTerm (snd Zs) sT),
              forall (a b : ann (Dom sT)), a ≣ b ->
                                      forward _ ST AL a ≣ forward _ ST AL' b)
  : forall AL AL', AL ≣ AL' -> forall ST,
    forall anF bnF, anF ≣ bnF ->
               forwardF forward F ST AL anF ≣ forwardF forward F ST AL' bnF.
Proof.
  intros. general induction H2; destruct F; simpl; eauto 20 using get.
Qed.

(*
Lemma forward_length_ass
      (sT:stmt) (Dom : stmt -> Type) `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, list params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall (s : stmt) (ST:subTerm s sT) (ZL:list params) k,
    forall (a : ann (Dom sT)), ❬ZL❭ = k -> ❬snd (forward Dom f ZL ST a)❭ = k.
Proof.
  intros. rewrite forward_length; eauto.
Qed.

Lemma forward_length_le_ass
      (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, list params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall (s : stmt) (ST:subTerm s sT) (ZL:list params) k,
    forall (a : ann (Dom sT)), ❬ZL❭ <= k -> ❬snd (forward Dom f ZL ST a)❭ <= k.
Proof.
  intros. rewrite forward_length; eauto.
Qed.

Lemma forward_length_le_ass_right
      (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, list params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall (s : stmt) (ST:subTerm s sT) (ZL:list params) k,
    forall (a : ann (Dom sT)), k <= ❬ZL❭ -> k <= ❬snd (forward Dom f ZL ST a)❭.
Proof.
  intros. rewrite forward_length; eauto.
Qed.

Hint Resolve @forward_length_ass forward_length_le_ass forward_length_le_ass_right : len.
 *)

Lemma forwardF_ann  (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)}
      (forward: forall s (ST:subTerm s sT),
          ctxmap (Dom sT) -> ann (Dom sT) -> ann (Dom sT) * ctxmap (Dom sT))
           (F:list (params * stmt)) (anF:list (ann (Dom sT))) AL
           (ST:forall n s, get F n s -> subTerm (snd s) sT) aa n
           (GetBW:get (fst (forwardF forward F ST AL anF)) n aa) Zs
           (Get: get F n Zs)
           (IH: forall AL Zs ST  a, get F n Zs -> get anF n a ->
                             annotation (snd Zs) (fst (forward (snd Zs) ST AL a)))
      : annotation (snd Zs) aa.
Proof.
  eapply get_getT in GetBW.
  general induction anF; destruct F as [|[Z s] F']; inv GetBW.
  - inv_get. simpl. exploit IH; eauto using get.
  - eapply IHanF; eauto using get.
Qed.

Lemma forward_annotation sT (Dom:stmt->Type)
      `{JoinSemiLattice (Dom sT)} s `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall AL ZL a (ST:subTerm s sT), annotation s a
               -> annotation s (fst (forward Dom f ZL ST AL a)).
Proof.
  induction s using stmt_ind'; intros AL ZL a ST Ann; inv Ann; simpl;
    repeat let_pair_case_eq; subst; eauto 20 using @annotation, setTopAnn_annotation.
  - econstructor; eauto using setTopAnn_annotation.
    + len_simpl; eauto.
    + intros. inv_get.
      eapply forwardF_ann in H3; eauto.
      * eauto using setTopAnn_annotation, setAnn_annotation.
Qed.

Lemma forward_getAnn' (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT)) s (ST:subTerm s sT) ZL AL an
  : getAnn (fst (@forward sT Dom _ _ _ f ZL s ST AL an)) = getAnn an.
Proof.
  intros. destruct s, an; simpl in *; eauto;
  repeat let_pair_case_eq; simpl; eauto.
Qed.

(*
Lemma forward_getAnn (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, list params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT)) s (ST:subTerm s sT) ZL a an
  : ann_R eq (fst (@forward sT Dom _ _ _ f ZL s ST an)) an
    -> getAnn an = a.
Proof.
  intros. eapply ann_R_get in H2.
  rewrite forward_getAnn' in H2. eauto.
Qed.
 *)

(*
Ltac simpl_forward_setTopAnn :=
  repeat match goal with
         | [H : poEq (fst (forward ?reachability_transform ?ZL
                                       ?s ?ST ?a ?sa)) ?sa |- _ ] =>
           let X := fresh "H" in
           match goal with
           | [ H' : getAnn sa = a |- _ ] => fail 1
           | _ => exploit (forward_getAnn _ _ _ _ _ H) as X
           end
         end; subst; try eassumption.

Smpl Add 130
    match goal with
    | [H : poEq (fst (forward ?reachability_transform ?ZL
                              ?s ?ST ?a ?sa)) ?sa |- _ ] =>
      let X := fresh "H" in
      match goal with
      | [ H' : getAnn sa = a |- _ ] => fail 1
      | _ =>
        first [ unify a (getAnn sa); fail 1
              | exploit (forward_getAnn _ _ _ _ _ H) as X; subst ]
      end
    end : inv_trivial.
 *)

Ltac fold_po :=
  repeat match goal with
         | [ H : context [ @ann_R ?A ?A (@poLe ?A ?I) ] |- _ ] =>
           change (@ann_R A A (@poLe A I)) with (@poLe (@ann A) _) in H
         | [ H : context [ PIR2 poLe ?x ?y ] |- _ ] =>
           change (PIR2 poLe x y) with (poLe x y) in H
         | [ |- context [ ann_R poLe ?x ?y ] ] =>
           change (ann_R poLe x y) with (poLe x y)
  end.

Ltac PI_simpl :=
  match goal with
    [ H : subTerm ?s ?t, H' : subTerm ?s ?t |- _ ]
    => assert (H = H') by eapply subTerm_PI; try subst H'; try subst H
  end.

Lemma poLe_mapi D `{PartialOrder D} D' `{PartialOrder D'} (f g:nat -> D -> D') (L L':list D)
      (LEf:forall i a b, poLe a b -> poLe (f i a) (g i b))
      (LE: poLe L L') n
  : poLe (mapi_impl f n L) (mapi_impl g n L').
Proof.
  general induction LE; simpl; eauto.
Qed.

Lemma poEq_mapi D `{PartialOrder D} D' `{PartialOrder D'} (f g:nat -> D -> D') (L L':list D)
      (LEf:forall i a b, poEq a b -> poEq (f i a) (g i b))
      (LE: poEq L L') n
  : poEq (mapi_impl f n L) (mapi_impl g n L').
Proof.
  general induction LE; simpl; eauto.
Qed.

Lemma forward_monotone (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ⊑ b -> f sT ZL s ST a ⊑ f sT ZL s ST b)
  : forall (s : stmt) (ST:subTerm s sT) ZL,
    forall AL AL', poLe AL AL' ->
        forall (a b : ann (Dom sT)), a ⊑ b ->
                                forward Dom f ZL ST AL a ⊑ forward Dom f ZL ST AL' b.
Proof with eauto using poLe_setTopAnn, poLe_getAnni.
  intros s.
  induction s using stmt_ind'; intros ST ZL AL AL' ALLE a b LE; simpl forward; inv LE;
    simpl forward; repeat let_pair_case_eq; subst; eauto.
  - eauto 100.
  - eauto 100.
  - clear_trivial_eqs. eapply PIR2_get in H5; eauto.
    eapply poLe_struct; eauto.
    + eapply annF_poLe; eauto.
      * eapply poLe_mapi; eauto 20 using forwardF_monotone'.
    + eapply ctxmap_drop_poLe.
      eapply forwardF_monotone'; eauto.
Qed.

Lemma forward_exp (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall (s : stmt) (ST:subTerm s sT) ZL,
    forall AL AL', poLe AL AL' ->
        forall a, AL ⊑ snd (forward Dom f ZL ST AL' a).
Proof with eauto using poLe_setTopAnn, poLe_getAnni.
  intros s.
  induction s using stmt_ind'; intros ST ZL AL AL' ALLE a; destruct a; simpl forward;
    simpl forward; repeat let_pair_case_eq; subst; eauto.
  - simpl. rewrite <- ctxmap_join_at_exp; eauto.
  - simpl. etransitivity; eauto.
    rewrite <- ctxmap_drop_eta at 1.
    eapply ctxmap_drop_poLe.
    eapply snd_forwardF_exp'; eauto.
Qed.

Lemma snd_forwardF_exp (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      f ZL F
  : forall AL ST anF, AL ⊑ snd (forwardF (@forward sT Dom _ _ _ f ZL) F ST AL anF).
Proof.
  intros. eapply snd_forwardF_exp'; eauto.
  intros. eapply forward_exp; eauto.
Qed.

Hint Resolve ann_R_setTopAnn_poEq.

Lemma forwardF_monotone (sT:stmt) (Dom : stmt -> Type)
      `{PartialOrder (Dom sT)}
      `{@JoinSemiLattice (Dom sT) H} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ⊑ b -> f sT ZL s ST a ⊑ f sT ZL s ST b)
      F
  : forall AL AL', poLe AL AL' -> forall ST ZL,
    forall anF bnF, anF ⊑ bnF ->
               forwardF (@forward sT Dom _ _ _ f ZL) F ST AL anF
                        ⊑ forwardF (@forward sT Dom _ _ _ f ZL) F ST AL' bnF.
Proof.
  intros.
  general induction H3; destruct F; simpl; eauto 20 using get, forward_monotone.
Qed.

Lemma forward_ext (sT:stmt) (Dom : stmt -> Type)
      `{JoinSemiLattice (Dom sT)} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ≣ b -> f sT ZL s ST a ≣ f sT ZL s ST b)
  : forall (s : stmt) (ST:subTerm s sT) ZL,
    forall AL AL', poEq AL AL' ->
    forall (a b : ann (Dom sT)), a ≣ b ->
                            forward Dom f ZL ST AL a ≣ forward Dom f ZL ST AL' b.
Proof with eauto using poLe_setTopAnn, poLe_getAnni.
  intros s.
  induction s using stmt_ind'; intros ST ZL AL AL' ALLE a b LE; simpl forward; inv LE;
    simpl forward; repeat let_pair_case_eq; subst; eauto.
  - eauto 100.
  - eauto 100.
  - clear_trivial_eqs. eapply PIR2_get in H5; eauto.
    eapply poEq_struct; eauto.
    + eapply annF_poEq; eauto.
      * eapply poEq_mapi; eauto 20 using forwardF_ext'.
    + eapply ctxmap_drop_poEq.
      eapply forwardF_ext'; eauto.
Qed.

Lemma forwardF_ext (sT:stmt) (Dom : stmt -> Type) `{H:PartialOrder (Dom sT)}
      `{@JoinSemiLattice (Dom sT) H} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ≣ b -> f sT ZL s ST a ≣ f sT ZL s ST b)
      F
  : forall ZL AL AL', AL ≣ AL' -> forall ST,
      forall anF bnF, anF ≣ bnF ->
                 forwardF (@forward sT Dom H _ _ f ZL) F ST AL anF
                          ≣ forwardF (@forward sT Dom _ _ _ f ZL) F ST AL' bnF.
Proof.
  intros. eapply forwardF_ext'; eauto.
  intros. eapply forward_ext; eauto.
Qed.

Instance forwardF_proper (sT:stmt) (Dom : stmt -> Type) `{H:PartialOrder (Dom sT)}
      `{@JoinSemiLattice (Dom sT) H} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ≣ b -> f sT ZL s ST a ≣ f sT ZL s ST b) ZL F ST
  : Proper (poEq ==> poEq ==> poEq)
           (forwardF (@forward sT Dom H _ _ f ZL) F ST).
Proof.
  unfold Proper, respectful.
  intros. eapply forwardF_ext; eauto.
Qed.

Instance forwardF_proper' (sT:stmt) (Dom : stmt -> Type) `{H:PartialOrder (Dom sT)}
      `{@JoinSemiLattice (Dom sT) H} `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
      (fMon:forall s (ST:subTerm s sT) ZL,
          forall a b, a ⊑ b -> f sT ZL s ST a ⊑ f sT ZL s ST b) ZL F ST
  : Proper (poLe ==> poLe ==> poLe)
           (forwardF (@forward sT Dom H _ _ f ZL) F ST).
Proof.
  unfold Proper, respectful.
  intros. eapply forwardF_monotone; eauto.
Qed.

Lemma forward_length (sT:stmt) (Dom : stmt -> Type) `{JoinSemiLattice (Dom sT)}
      `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall (s : stmt) (ST:subTerm s sT) ZL AL
    (a : ann (Dom sT)), ctxmap_len (snd (forward Dom f ZL ST AL a)) = ctxmap_len AL.
Proof.
  induction s using stmt_ind'; destruct a; simpl; eauto with len;
    repeat let_pair_case_eq; subst; simpl in *; eauto.
  - setoid_rewrite IHs2.
    setoid_rewrite IHs1. reflexivity.
  - rewrite <- snd_forwardF_exp'; eauto; try reflexivity.
    rewrite IHs.
    + len_simpl. omega.
    + intros. eapply forward_exp; eauto.
Qed.

Smpl Add
     match goal with
     | [ |- context [ ctxmap_len (snd (@forward ?sT ?Dom ?H ?JSL ?LB ?f ?ZL ?s ?ST ?AL ?a)) ] ] =>
       setoid_rewrite (@forward_length sT Dom H JSL LB f s ST ZL AL a)
     end : len.

Lemma snd_forwardF_length (sT:stmt) (Dom : stmt -> Type) `{JoinSemiLattice (Dom sT)}
      `{@LowerBounded (Dom sT) H}
      (f: forall sT, ctxmap params ->
                forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
  : forall ZL F ST AL anF,
    ctxmap_len (snd (forwardF (@forward sT Dom H _ _ f ZL) F ST AL anF))
    = ctxmap_len AL.
Proof.
  intros.
  general induction F; destruct anF; simpl; eauto.
  rewrite IHF. eauto with len.
Qed.

Smpl Add
     match goal with
     | [ |- context [ ctxmap_len (snd
                                   (@forwardF ?sT ?Dom ?H ?JSL
                                              (@forward ?sT ?Dom ?H ?JSL ?LB ?f ?ZL)
                                              ?F ?ST ?AL ?anF)) ] ] =>
       setoid_rewrite (@snd_forwardF_length sT Dom H JSL LB f ZL F ST AL anF)
     end : len.

Lemma forwardF_get  (sT:stmt) (Dom:stmt->Type) `{JoinSemiLattice (Dom sT)}
      `{@LowerBounded (Dom sT) H}
           (F:list (params * stmt)) (anF:list (ann (Dom sT))) AL
           (ST:forall n s, get F n s -> subTerm (snd s) sT) aa n f ZL
           (GetBW:get (fst (forwardF (@forward sT Dom H _ _ f ZL) F ST AL anF)) n aa)
      :
        { Zs : params * stmt & {GetF : get F n Zs &
        { a : ann (Dom sT) & { getAnF : get anF n a & { AL' : ctxmap (Dom sT) |
        { ST' : subTerm (snd Zs) sT |
          fst (@forward sT Dom H _ _ f ZL (snd Zs) ST' AL' a) = aa
          /\ poLe (snd (@forward sT Dom H _ _ f ZL (snd Zs) ST' AL'  a))
                 (snd (forwardF (@forward sT Dom H _ _ f ZL) F ST AL anF))
        } } } } } }.
Proof.
  eapply get_getT in GetBW.
  general induction anF; destruct F as [|[Z s] F']; inv GetBW.
  - exists (Z, s). simpl. do 5 (eexists; eauto 20 using get).
    split. reflexivity. eapply snd_forwardF_exp.
  - edestruct IHanF as [Zs [? [? [? ]]]]; eauto; dcr; subst.
    exists Zs. do 5 (eexists; eauto 20 using get).
Qed.

Instance makeForwardAnalysis (Dom:stmt -> Type)
         (PO:forall s, PartialOrder (Dom s))
         (BSL:forall s, JoinSemiLattice (Dom s))
         (LB:forall s, @LowerBounded (Dom s) (PO s))
         (f: forall sT, ctxmap params ->
                   forall s, subTerm s sT -> Dom sT -> anni (Dom sT))
         (fMon:forall sT s (ST:subTerm s sT) ZL,
             forall a b, a ⊑ b -> f sT ZL s ST a ⊑ f sT ZL s ST b)
         (Trm: forall s, Terminating (Dom s) poLt)

  : forall s (i:Dom s), Iteration { a : ann (Dom s) | annotation s a } :=
  {
    step := fun X : {a : ann (Dom s) | annotation s a} =>
                      exist (fun a0 : ann (Dom s) => annotation s a0)
                            (fst (forward Dom f (ctxmap_emp _)
                                          (subTerm_refl _) (ctxmap_emp _) (proj1_sig X)))
                                 (forward_annotation Dom f (ctxmap_emp _) (ctxmap_emp _) (subTerm_refl _) _);
    initial_value :=
      exist (fun a : ann (Dom s) => annotation s a)
            (setTopAnn (setAnn bottom s) i)
            (setTopAnn_annotation _ (setAnn_annotation bottom s))
  }.
Proof.
  - destruct X; eauto.
  - eapply ann_R_setTopAnn_left.
    + simpl. rewrite forward_getAnn'. rewrite getAnn_setTopAnn. reflexivity.
    + eapply ann_bottom.
      eapply forward_annotation; eauto.
      eapply setTopAnn_annotation.
      eapply setAnn_annotation.
  - intros [a Ann] [b Bnn] LE; simpl in *.
    eapply (forward_monotone Dom f (fMon s)); eauto.
Defined.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal24.

From lfind Require Import LFind.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal24_theorem0_45_lem/goal24_lfind_orig.ml"  Coq.Init.Datatypes.negb adtind.goal24.plus adtind.goal24.even.
Success.


From Undecidability Require Import TM.Util.TM_facts TM.Basic.Mono TM.Combinators.Combinators TM.Compound.Multi.
Require Import List.
From Undecidability Require Import TMTac.
From Coq Require Import List.

Set Default Proof Using "Type".

(* Useful for running time stuff *)
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

(* The correctness and definition of [WriteString] is non-standard, because it is defined (and verified) by recursion (or induction). *)
Section Write_String.

  Variable sig : finType.
  Variable D : move.

  Fixpoint WriteString (l : list sig) : pTM sig unit 1 :=
    match l with
    | [] => Nop
    | [x] => Write x
    | x :: xs => WriteMove x D;; WriteString xs
    end.

  Fixpoint WriteString_Fun (sig' : Type) (t : tape sig') (str : list sig') :=
    match str with
    | nil => t
    | [x] => tape_write t (Some x)
    | x :: str' => WriteString_Fun (doAct t (Some x, D)) str'
    end.

  Lemma WriteString_Fun_eq (sig' : Type) (t : tape sig') (str : list sig') :
    WriteString_Fun t str =
    match str with
    | nil => t
    | [x] => tape_write t (Some x)
    | x :: str' => WriteString_Fun (doAct t (Some x, D)) str'
    end.
  Proof. destruct str; auto. Qed.

  Lemma Write_String_nil (sig' : Type) (t : tape sig') :
    WriteString_Fun t nil = t.
  Proof. destruct t; cbn; auto. Qed.

  Fixpoint WriteString_sem_fix (str : list sig) : pRel sig unit 1 :=
    match str with
    | nil => Nop_Rel
    | [x] => Write_Rel x
    | x :: str' =>
      WriteMove_Rel x D |_tt ∘ WriteString_sem_fix str'
    end.

  Definition WriteString_steps l :=
    2 * l - 1.

  Lemma WriteString_fix_Sem (str : list sig) :
    WriteString str ⊨c(WriteString_steps (length str)) (WriteString_sem_fix str).
  Proof.
    induction str as [ | s [ | s' str'] IH ].
    - cbn. change (2 * 0 - 1) with 0. TM_Correct.
    - cbn. change (2 * 1 - 1) with 1. TM_Correct.
    - change (WriteString (s :: s' :: str')) with (WriteMove s D;; WriteString (s' :: str')).
      eapply RealiseIn_monotone.
      { TM_Correct. TM_Correct. apply IH. }
      { unfold WriteString_steps. cbn. lia. }
      { intros t1 t3 H. destruct H as (()&t2&H1&H2).
        change (WriteString_sem_fix (s :: s' :: str')) with (WriteMove_Rel s D |_tt ∘ WriteString_sem_fix (s' :: str')).
        exists t2. split; auto.
      }
  Qed.

  Definition WriteString_Rel str : Rel (tapes sig 1) (unit * tapes sig 1) :=
    Mono.Mk_R_p (ignoreParam (fun tin tout => tout = WriteString_Fun tin str)).

  Lemma WriteString_Sem str :
    WriteString str ⊨c(WriteString_steps (length str)) (WriteString_Rel str).
  Proof.
    eapply RealiseIn_monotone.
    { apply WriteString_fix_Sem. }
    { reflexivity. }
    { induction str as [ | s [ | s' str'] IH]; intros tin (yout, tout) H.
      - cbn. now TMSimp.
      - cbn. now TMSimp.
      - change (WriteString_sem_fix (s :: s' :: str')) with ((WriteMove_Rel s D |_tt ∘ WriteString_sem_fix (s' :: str'))) in H.
        destruct H as (tmid&H1&H2). hnf in H1. apply IH in H2.
        (* cbv [WriteString_Rel Mk_R_p ignoreParam].
        change (WriteString_Fun tin[@Fin0] (s :: s' :: str')) with (WriteString_Fun (tape_move_mono tin[@Fin0] (Some s, D)) (s' :: str')). *)
        now TMSimp.
    }
  Qed.

End Write_String.

Arguments WriteString : simpl never.
Arguments WriteString_Rel {sig} (D) (str) x y/.

Lemma skipn_S (X : Type) (xs : list X) (n : nat) :
  skipn (S n) xs = tl (skipn n xs).
Proof.
  revert xs. induction n as [ | n IH]; intros; cbn in *.
  - destruct xs; auto.
  - destruct xs; auto.
Qed.

(*
Compute skipn 3 (tl [1;2;3;4;5;6;7]).
Compute tl (skipn 3 [1;2;3;4;5;6;7]).
*)

Lemma skipn_tl (X : Type) (xs : list X) (n : nat) :
  skipn n (tl xs) = tl (skipn n xs).
Proof.
  revert xs. induction n as [ | n IH]; intros; cbn in *.
  - destruct xs; auto.
  - destruct xs; cbn; auto.
    replace (match xs with
             | [] => []
             | _ :: l => skipn n l
             end)
      with (skipn n (tl xs)); auto.
    destruct xs; cbn; auto. apply skipn_nil.
Qed.

Lemma WriteString_L_local (sig : Type) (str : list sig) t :
  str <> nil ->
  tape_local (WriteString_Fun Lmove t str) = rev str ++ right t.
Proof.
  revert t. induction str as [ | s [ | s' str'] IH]; intros; cbn in *.
  - tauto.
  - reflexivity.
  - rewrite IH. 2: congruence. simpl_tape. rewrite <- !app_assoc. reflexivity.
Qed.

(*
Section Test.
  Let t : tape nat := midtape [3;2;1] 4 [5;6;7].
  Let str := [3;2;1].
  Compute WriteString_Fun Lmove t str.
  Compute (left t).
  Compute (left (WriteString_Fun Lmove t str)).
  Compute (skipn (length str - 1) (left t)).
End Test.
*)

Lemma WriteString_L_left (sig : Type) (str : list sig) t :
  left (WriteString_Fun Lmove t str) = skipn (pred (length str)) (left t).
Proof.
  revert t. induction str as [ | s [ | s' str'] IH]; intros; cbn -[skipn] in *.
  - reflexivity.
  - reflexivity.
  - rewrite IH. simpl_tape. now rewrite skipn_S, skipn_tl.
Qed.

Lemma WriteString_L_right (sig : Type) (str : list sig) t :
   right (WriteString_Fun Lmove t str) = tl (rev str) ++ right t.
Proof.
  revert t. induction str as [ | s [ | s' str'] IH]; intros; cbn in *.
  - tauto.
  - reflexivity.
  - rewrite IH. simpl_tape. rewrite tl_app with (ys:=[s]),<- !app_assoc. reflexivity. intros (?&[=])%app_eq_nil.
Qed.

Lemma WriteString_L_current (sig : Type) (str : list sig) t :
   current (WriteString_Fun Lmove t str) = hd None (map Some (rev str ++ tape_local t)).
Proof.
  revert t. induction str as [ | s [ | s' str'] IH]; intros; cbn in *.
  - now destruct t.
  - reflexivity.
  - rewrite IH. autorewrite with list. setoid_rewrite app_assoc at 1 2.
    rewrite !hd_app with (xs:=(map Some (rev str') ++ map Some [s'])). easy. all:intros (?&[=])%app_eq_nil.
Qed.


From compcert Require Import common.Separation.
From compcert Require Import common.Values.
From compcert Require common.Errors.
From compcert Require Import cfrontend.Ctypes.
From compcert Require Import lib.Maps.
From compcert Require Import lib.Coqlib.
From compcert Require Import lib.Integers.

From Velus Require Import Common.
From Velus Require Import VelusMemory.
From Velus Require Import Common.CompCertLib.

From Coq Require Import List.
From Coq Require Import ZArith.BinInt.

From Coq Require Import Program.Tactics.
From Coq Require Sorting.Permutation.

Open Scope list.
Open Scope sep_scope.
Open Scope Z.

Notation "m -*> m'" := (massert_imp m m') (at level 70, no associativity) : sep_scope.
Notation "m <-*-> m'" := (massert_eqv m m') (at level 70, no associativity) : sep_scope.

Lemma sepconj_eqv:
  forall P P' Q Q',
    P <-*-> P' ->
    Q <-*->  Q' ->
    (P ** Q) <-*-> (P' ** Q').
Proof.
  intros * HP HQ.
  rewrite HP. rewrite HQ.
  reflexivity.
Qed.

Lemma pure_imp:
  forall P Q,
    (pure P -*> pure Q) <-> (P -> Q).
Proof.
  split; intro Imp.
  - eapply Imp.
  - split; auto.
  Grab Existential Variables.
  exact Memory.Mem.empty.
Qed.

Lemma pure_eqv:
  forall P Q,
    (pure P <-*-> pure Q) <-> (P <-> Q).
Proof.
  split; intro Eqv; destruct Eqv.
  - split; now rewrite <-pure_imp.
  - split; now rewrite pure_imp.
Qed.

Lemma disjoint_footprint_sepconj:
  forall P Q R,
    disjoint_footprint R (P ** Q) <-> disjoint_footprint R P /\ disjoint_footprint R Q.
Proof.
  intros.
  split; intro H.
  - split; intros b ofs; specialize (H b ofs); intros HfR HfP; apply H; auto.
    + now left.
    + now right.
  - destruct H as [HfP HfQ].
    intros b ofs.
    specialize (HfP b ofs).
    specialize (HfQ b ofs).
    intros HfR HPQ.
    destruct HPQ.
    + now apply HfP.
    + now apply HfQ.
Qed.

(* * * * * * * * Separating Wand * * * * * * * * * * * * * * *)

From compcert Require Import common.Memory.
From Coq Require Import Morphisms.

Definition wand_footprint (P Q: massert) (b: block) (ofs: Z) : Prop :=
  ~m_footprint P b ofs /\ m_footprint Q b ofs.

Program Definition sepwand (P Q: massert) : massert := {|
  m_pred := fun m =>
              (forall m', Mem.unchanged_on (wand_footprint P Q) m m' ->
                          m' |= P -> m' |= Q)
              /\ (forall b ofs, wand_footprint P Q b ofs -> Mem.valid_block m b);
  m_footprint := wand_footprint P Q
|}.
Next Obligation.
  rename H into HPQ, H1 into Hval, H0 into Hun1.
  repeat split.
  - intros m'' Hun2 HP.
    apply Mem.unchanged_on_trans with (1:=Hun1) in Hun2.
    now apply HPQ with (1:=Hun2) (2:=HP).
  - intros b ofs Hwfoot.
    apply Mem.valid_block_unchanged_on with (1:=Hun1).
    apply Hval with (1:=Hwfoot).
Qed.

Infix "-*" := sepwand (at level 65, right associativity) : sep_scope.

Definition decidable_footprint (P: massert) : Prop :=
  forall b ofs, Decidable.decidable (m_footprint P b ofs).

Instance decidable_footprint_Proper:
  Proper (massert_eqv ==> iff) decidable_footprint.
Proof.
  intros P Q HPQ.
  unfold decidable_footprint, Decidable.decidable.
  split; intros.
  now rewrite <-HPQ.
  now rewrite HPQ.
Qed.

Lemma decidable_footprint_sepconj:
  forall P Q,
    decidable_footprint P ->
    decidable_footprint Q ->
    decidable_footprint (P ** Q).
Proof.
  intros P Q HP HQ b ofs.
  specialize (HP b ofs).
  specialize (HQ b ofs).
  simpl; intuition.
Qed.

Hint Resolve decidable_footprint_sepconj.

Lemma decidable_ident_eq:
  forall (b b': AST.ident), Decidable.decidable (b = b').
Proof.
  intros b b'. unfold Decidable.decidable.
  destruct (peq b' b); intuition.
Qed.

Lemma decidable_footprint_range:
  forall {f} b lo hi,
    decidable_footprint (range' f b lo hi).
Proof.
  unfold decidable_footprint.
  intros.
  apply Decidable.dec_and.
  apply decidable_ident_eq.
  apply Decidable.dec_and.
  apply Z.le_decidable.
  apply Z.lt_decidable.
Qed.

Hint Resolve decidable_footprint_range.

Lemma decidable_footprint_contains:
  forall {f} chunk b ofs spec,
    decidable_footprint (contains' f chunk b ofs spec).
Proof.
  unfold decidable_footprint.
  intros.
  apply Decidable.dec_and.
  apply decidable_ident_eq.
  apply Decidable.dec_and.
  apply Z.le_decidable.
  apply Z.lt_decidable.
Qed.

Hint Resolve decidable_footprint_contains.

Lemma sep_unwand:
  forall P Q,
    decidable_footprint P ->
    (P ** (P -* Q)) -*> Q.
Proof.
  intros P Q Hdec.
  split.
  - intros m HPPQ.
    destruct HPPQ as (HP & HW & Hdj).
    destruct HW as [Hu ?].
    apply Hu.
    apply Mem.unchanged_on_refl.
    assumption.
  - intros b ofs HfQ.
    destruct (Hdec b ofs); [now left|right].
    split; intuition.
Qed.

Lemma disjoint_sepwand:
  forall P Q, disjoint_footprint P (P -* Q).
Proof.
  intros P Q b ofs HfP HfPQ.
  destruct HfPQ as [HfnP HfQ].
  intuition.
Qed.

Lemma merge_disjoint:
  forall P Q R m,
    disjoint_footprint P Q ->
    m |= P ** R ->
    m |= Q ** R ->
    m |= P ** Q ** R.
Proof.
  intros P Q R m HdPQ HPR HQR.
  rewrite <-sep_assoc.
  repeat split.
  - apply sep_proj1 with (1:=HPR).
  - apply sep_proj1 with (1:=HQR).
  - assumption.
  - apply sep_proj2 with (1:=HPR).
  - intros b ofs Hfw HfR.
    destruct Hfw as [HfP|HfPQ].
    + destruct HPR as [? [? HdPR]].
      unfold disjoint_footprint in HdPR.
      apply HdPR with (1:=HfP) (2:=HfR).
    + destruct HQR as [? [? HdQR]].
      unfold disjoint_footprint in HdQR.
      apply HdQR with (1:=HfPQ) (2:=HfR).
Qed.

Lemma merge_sepwand:
  forall P Q R m,
    m |= P ** R ->
    m |= (P -* Q) ** R ->
    m |= P ** (P -* Q) ** R.
Proof.
  intros. apply merge_disjoint; try assumption.
  now apply disjoint_sepwand.
Qed.

Lemma sepwand_mp:
  forall m P Q,
    m |= P ->
    m |= P -* Q ->
    m |= Q.
Proof.
  intros m P Q HP HPQ.
  apply HPQ; [|assumption].
  apply Mem.unchanged_on_refl.
Qed.

Instance wand_footprint_massert_imp_Proper:
  Proper (massert_imp ==> massert_imp --> eq ==> eq ==> Basics.impl)
         wand_footprint.
Proof.
  intros P Q HPQ R S HRS b' b Hbeq ofs' ofs Hoeq.
  subst.
  unfold wand_footprint.
  now rewrite HPQ, HRS.
Qed.

Instance wand_footprint_massert_eqv_Proper:
  Proper (massert_eqv ==> massert_eqv ==> eq ==> eq ==> iff) wand_footprint.
Proof.
  intros P Q HPQ R S HRS b' b Hbeq ofs' ofs Hoeq.
  subst.
  unfold wand_footprint.
  rewrite HPQ, HRS. reflexivity.
Qed.

Instance sepwand_massert_Proper:
  Proper (massert_eqv ==> massert_eqv ==> massert_eqv) sepwand.
Proof.
  intros P Q HPQ R S HRS.
  split; [split|split].
  - intros m HPR.
    destruct HPR as [HPR1 HPR2].
    split.
    + intros m' Hun HQ.
      rewrite <-HRS.
      rewrite <-HPQ in HQ.
      apply HPR1 with (2:=HQ).
      apply Mem.unchanged_on_implies with (1:=Hun).
      intros b ofs HfW Hv.
      now rewrite HPQ, HRS in HfW.
    + intros b ofs.
      rewrite <-HPQ, <-HRS.
      apply HPR2.
  - intros b ofs Hf.
    simpl in Hf.
    now rewrite <-HPQ, <-HRS in Hf.
  - intros m HQS.
    destruct HQS as [HQS1 HQS2].
    split.
    + intros m' Hun HP.
      rewrite HPQ in HP.
      rewrite HRS.
      apply HQS1 with (2:=HP).
      apply Mem.unchanged_on_implies with (1:=Hun).
      intros b ofs HfW Hv.
      now rewrite HPQ, HRS.
    + intros b ofs.
      rewrite HPQ, HRS.
      apply HQS2.
  - intros b ofs Hf.
    simpl in Hf. rewrite HPQ, HRS in Hf.
    assumption.
Qed.

Lemma hide_in_sepwand:
  forall P Q R,
    decidable_footprint Q ->
    P <-*-> (Q ** R) ->
    P <-*-> (Q ** (Q -* P)).
Proof.
  intros P Q R HQdec HPQR.
  rewrite HPQR at 2.
  split; [split|].
  - intros m HP.
    apply HPQR in HP.
    split; [|split].
    + apply sep_proj1 with (1:=HP).
    + split.
      * intros m' Hun HQ'.
        destruct HP as (HQ & HR & Hdj).
        repeat split; try assumption.
        apply m_invar with (1:=HR).
        apply Mem.unchanged_on_implies with (1:=Hun).
        intros b ofs HfR Hv.
        destruct (HQdec b ofs).
        now (exfalso; apply Hdj with (2:=HfR)).
        split; [assumption|now right].
      * intros b ofs.
        destruct 1 as [HnfQ [|HfR]]; [contradiction|].
        apply sep_proj2 in HP.
        apply m_valid with (1:=HP) (2:=HfR).
    + apply disjoint_sepwand.
  - intros b ofs Hf.
    rewrite HPQR.
    destruct Hf as [|Hf]; [now left|].
    destruct Hf as [HfQ [|HfR]]; [now left|].
    now right.
  - rewrite sep_unwand with (1:=HQdec).
    rewrite HPQR. reflexivity.
Qed.

Lemma sepwand_out:
  forall P Q,
    decidable_footprint P ->
    (P ** Q) <-*-> (P ** (P -* (P ** Q))).
Proof.
  split.
  - now rewrite <-hide_in_sepwand.
  - now rewrite sep_unwand.
Qed.

Lemma pure_wand_footprint:
  forall (P: Prop) Q b ofs,
    wand_footprint (pure P) Q b ofs <-> m_footprint Q b ofs.
Proof.
  split.
  - inversion 1; auto.
  - split; auto.
Qed.

Lemma unchanged_on_imp:
  forall P (Q: block -> Z -> Prop) m m',
    Mem.unchanged_on P m m' ->
    (forall b ofs, Q b ofs -> P b ofs) ->
    Mem.unchanged_on Q m m'.
Proof.
  intros * Hun Hpq.
  inversion_clear Hun.
  constructor; auto.
Qed.

Lemma pure_sepwand:
  forall (P: Prop) Q,
    P -> (pure P -* Q) <-*-> Q.
Proof.
  intros P Q HH.
  constructor.
  - constructor.
    + inversion_clear 1 as (Hun & Hf).
      apply Hun; auto using Mem.unchanged_on_refl.
    + constructor; auto.
  - constructor.
    + intros m Hq. constructor.
      * intros m' Hun Hmp.
        apply m_invar with (1:=Hq).
        apply unchanged_on_imp with (1:=Hun).
        apply pure_wand_footprint.
      * intros * Hwf.
        apply pure_wand_footprint in Hwf.
        eauto using m_valid.
    + simpl. intros * Hf.
      now apply pure_wand_footprint in Hf.
Qed.

(* Reynold's "rules capturing the adjunctive relationship between separating
   conjunction and separating implication". *)

Lemma reynolds1:
  forall P1 P2 P3,
    (P1 ** P2) -*> P3 ->
    (forall b ofs, m_footprint P1 b ofs -> wand_footprint P2 P3 b ofs) ->
    P1 -*> (P2 -* P3).
Proof.
  intros P1 P2 P3 HH Hfi.
  split.
  - intros m HP1.
    split.
    + intros m' Hun HP2.
      apply HH.
      split; [|split].
      * apply m_invar with (1:=HP1).
        apply Mem.unchanged_on_implies with (1:=Hun).
        intros; now apply Hfi.
      * assumption.
      * intros b ofs HfP1 HfP2.
        apply Hfi in HfP1.
        destruct HfP1. contradiction.
    + intros b ofs.
      destruct 1 as [HnfP2 HfP3].
      destruct HH as [HHm HHf].
      apply HHf in HfP3.
      destruct HfP3 as [HfP1|]; [|contradiction].
      apply m_valid with (1:=HP1) (2:=HfP1).
  - intros b ofs.
    destruct 1 as [HnfP2 HfP3].
    destruct HH as [HHm HHf].
    apply HHf in HfP3.
    destruct HfP3; intuition.
Qed.

Lemma reynolds2:
  forall P1 P2 P3,
    decidable_footprint P2 ->
    P1 -*> (P2 -* P3) ->
    (P1 ** P2) -*> P3.
Proof.
  intros P1 P2 P3 HD2 HH.
  rewrite HH. rewrite sep_comm.
  rewrite sep_unwand with (1:=HD2).
  reflexivity.
Qed.

Definition footprint_perm' (p: permission) (P: massert) (b: block) (lo hi: Z) : Prop :=
  (forall m, m |= P ->
             (forall i k, m_footprint P b i ->
                          lo <= i < hi ->
                          Mem.perm m b i k p)).

Notation footprint_perm := (footprint_perm' Freeable).
Notation footprint_perm_w := (footprint_perm' Writable).

Lemma footprint_perm_sepconj:
  forall p P Q b lo hi,
    footprint_perm' p P b lo hi ->
    footprint_perm' p Q b lo hi ->
    footprint_perm' p (P ** Q) b lo hi.
Proof.
  intros f P Q b lo hi HfpP HfpQ.
  intros m HPQ i k Hf Hi.
  destruct HPQ as (HP & HQ & Hdj).
  destruct Hf as [HfP|HfQ].
  - now apply HfpP.
  - now apply HfpQ.
Qed.

Lemma footprint_perm_range:
  forall p b lo hi b' lo' hi',
    footprint_perm' p (range' p b lo hi) b' lo' hi'.
Proof.
  intros p b lo hi b' lo' hi' m Hm i k Hf Hi.
  destruct Hf. subst.
  destruct Hm as (Hlo & Hhi & Hp).
  now apply Hp.
Qed.

Lemma footprint_perm_contains:
  forall p chunk b ofs spec b' lo hi,
    footprint_perm' p (contains' p chunk b ofs spec) b' lo hi.
Proof.
  intros p chunk b ofs spec b' lo hi m Hm i k Hf Hi.
  destruct Hf. subst.
  destruct Hm as (Hlo & Hhi & Hv & Hl).
  destruct Hv as (Hperm & j & Hofs).
  apply Mem.perm_cur.
  now apply Hperm.
Qed.

Hint Resolve footprint_perm_sepconj
             footprint_perm_range
             footprint_perm_contains.

Lemma range_imp_with_wand:
  forall p P b lo hi,
    (range' p b lo hi) -*> P ->
    decidable_footprint P ->
    footprint_perm' p P b lo hi ->
    (range' p b lo hi) <-*-> (P ** (P -* range' p b lo hi)).
Proof.
  intros p P b lo hi HRP HPfdec HPperm.
  split; [|now rewrite sep_unwand].
  split.
  - intros m HR.
    split; [|split].
    + now apply HRP.
    + split.
      * intros m' Hun HP.
        assert (HR':=HR).
        destruct HR' as (Hlo & Hhi & Hperm).
        repeat split; try assumption.
        intros i k Hi.
        destruct (HPfdec b i) as [HfPi|HnfPi].
        now apply HPperm with (1:=HP) (2:=HfPi) (3:=Hi).
        apply Mem.perm_unchanged_on with (1:=Hun).
        split; [assumption|simpl; now intuition].
        now apply Hperm.
      * intros b' ofs.
        destruct 1 as [? HfR].
        assert (b = b') by (simpl in HfR; intuition).
        subst. apply (m_valid _ _ _ _ HR HfR).
    + intros b' ofs HfP HfPR.
      destruct HfPR. contradiction.
  - intros b' ofs Hf.
    destruct HRP as [HRP HfPR].
    destruct Hf as [|Hf]; [now apply HfPR|].
    now destruct Hf.
Qed.

Definition subseteq_footprint (P Q: massert) :=
  (forall b ofs, m_footprint P b ofs -> m_footprint Q b ofs).

Instance subseteq_footprint_footprint_Proper:
  Proper (subseteq_footprint ==> eq ==> eq ==> Basics.impl) m_footprint.
Proof.
  intros P Q Hsub b b' Heqb ofs ofs' Heqofs HP.
  subst. apply Hsub with (1:=HP).
Qed.

Lemma subseteq_footprint_refl:
  forall P, subseteq_footprint P P.
Proof.
  now unfold subseteq_footprint.
Qed.

Lemma subseteq_footprint_trans:
  forall P Q R, subseteq_footprint P Q ->
                subseteq_footprint Q R ->
                subseteq_footprint P R.
Proof.
  unfold subseteq_footprint. intuition.
Qed.

Add Parametric Relation: massert subseteq_footprint
    reflexivity proved by subseteq_footprint_refl
    transitivity proved by subseteq_footprint_trans
      as subseteq_footprint_rel.

Instance subseteq_footprint_massert_imp_Proper:
  Proper (massert_imp ==> massert_imp --> Basics.impl) subseteq_footprint.
Proof.
  intros P Q HPQ R S HSR HPsR b ofs HfQ.
  apply HPQ in HfQ.
  specialize (HPsR b ofs HfQ).
  now apply HSR in HPsR.
Qed.

Instance subseteq_footprint_massert_eqv_Proper:
  Proper (massert_eqv ==> massert_eqv ==> iff) subseteq_footprint.
Proof.
  intros P Q HPQ R S HSR.
  destruct HPQ as [HPQ HQP].
  destruct HSR as [HSR HRS].
  split; intro HH.
  - rewrite HPQ in HH; now rewrite HRS.
  - rewrite HQP in HH. now rewrite HSR.
Qed.

Lemma subseteq_footprint_sepconj:
  forall P Q R S,
    subseteq_footprint P Q ->
    subseteq_footprint R S ->
    subseteq_footprint (P ** R) (Q ** S).
Proof.
  intros P Q R S HPQ HRS.
  intros b ofs.
  destruct 1 as [HP|HR].
  - left; now apply HPQ.
  - right; now apply HRS.
Qed.

Lemma unify_distinct_wands:
  forall P Q R S,
    disjoint_footprint R S ->
    subseteq_footprint P R ->
    subseteq_footprint Q S ->
    (P -* R) ** (Q -* S)
    -*> (P ** Q) -* (R ** S).
Proof.
  intros P Q R S HdjRS HsPR HsQS.
  split.
  - intros m HH.
    split.
    + intros m' Hun.
      destruct HH as (HPR & HQS & Hdj).
      destruct 1 as (HP & HQ & HdjPQ).
      repeat split.
      * apply m_invar with (m':=m') in HPR.
        now apply sepwand_mp with (1:=HP) in HPR.
        apply Mem.unchanged_on_implies with (1:=Hun).
        intros b ofs HfPR Hv.
        destruct HfPR as (HnfP & HfR).
        split.
        destruct 1 as [HfP|HfQ]; [contradiction|].
        apply HdjRS with (1:=HfR).
        apply HsQS with (1:=HfQ).
        now left.
      * apply m_invar with (m':=m') in HQS.
        now apply sepwand_mp with (1:=HQ) in HQS.
        apply Mem.unchanged_on_implies with (1:=Hun).
        intros b ofs HfQS Hv.
        destruct HfQS as (HnfQ & HfS).
        split.
        destruct 1 as [HfP|HfQ]; [|contradiction].
        apply HdjRS with (2:=HfS).
        apply HsPR with (1:=HfP).
        now right.
      * assumption.
    + intros b ofs Hfw.
      apply (m_valid _ _ _ ofs HH).
      destruct Hfw as [HnfPQ [HfR|HfS]]; [left|right]; split;
        try (intro; apply HnfPQ; simpl); intuition.
  - intros b ofs.
    destruct 1 as [HnfPQ [HfR|HfS]]; [left|right]; split;
      try (intro; apply HnfPQ; simpl); intuition.
Qed.

(* * * * * * * * sepall * * * * * * * * * * * * * * *)

Program Definition sepemp: massert :=  pure True.

Lemma sepemp_disjoint:
  forall P, disjoint_footprint P sepemp.
Proof.
  unfold disjoint_footprint. auto.
Qed.

Lemma sepemp_trivial:
  forall m, m |= sepemp.
Proof.
  split.
Qed.
Hint Resolve sepemp_trivial.

Lemma sepemp_right:
  forall P,
    P <-*-> (P ** sepemp).
Proof.
  split; split; simpl; try (auto using sepemp_disjoint); intuition.
Qed.

Lemma sepemp_left:
  forall P,
    P <-*-> (sepemp ** P).
Proof.
  intros. rewrite sep_comm. rewrite <-sepemp_right. reflexivity.
Qed.

Lemma wandwand_sepemp:
  forall P, massert_eqv (P -* P) sepemp.
Proof.
  firstorder.
Qed.

Lemma wand_footprint_sepemp:
  forall P b ofs,
    wand_footprint sepemp P b ofs <-> m_footprint P b ofs.
Proof.
  firstorder.
Qed.

Lemma sepemp_wand:
  forall P,
    sepemp -* P <-*-> P.
Proof.
  split; split.
  - inversion 1 as [Hun Hv].
    apply Hun.
    apply Mem.unchanged_on_refl.
    now simpl.
  - now split.
  - intros m HP. split.
    + intros m' Hun He.
      apply m_invar with (1:=HP).
      apply Mem.unchanged_on_implies with (1:=Hun).
      intros; now apply wand_footprint_sepemp.
    + intros b ofs Hw.
      rewrite wand_footprint_sepemp in Hw.
      apply m_valid with (1:=HP) (2:=Hw).
  - intros b ofs Hf.
    simpl in Hf.
    now apply wand_footprint_sepemp in Hf.
Qed.

Lemma decidable_footprint_sepemp:
  decidable_footprint sepemp.
Proof.
  unfold decidable_footprint. simpl.
  intros; apply Decidable.dec_False.
Qed.

Lemma footprint_perm_sepemp:
  forall p b lo hi, footprint_perm' p sepemp b lo hi.
Proof.
  intros lo hi m. inversion 2.
Qed.

Hint Resolve decidable_footprint_sepemp footprint_perm_sepemp.

Lemma empty_range:
  forall {f} b lo hi,
    hi <= lo ->
    0 <= lo ->
    hi <= Ptrofs.modulus ->
    sepemp <-*-> (range' f b lo hi).
Proof.
  intros b lo hi Hgt.
  split; [split|split].
  - simpl. intuition.
  - inversion 1. intuition.
  - intros; exact I.
  - inversion 1.
Qed.

Definition sepfalse := pure False.

Lemma decidable_footprint_sepfalse:
  decidable_footprint sepfalse.
Proof.
  unfold decidable_footprint. simpl.
  intros; apply Decidable.dec_False.
Qed.

Lemma footprint_perm_sepfalse:
  forall p b lo hi, footprint_perm' p sepfalse b lo hi.
Proof.
  intros p b lo hi m Hm. inversion Hm.
Qed.

Hint Resolve decidable_footprint_sepfalse footprint_perm_sepfalse.

Section MassertPredEqv.
  Context {A: Type}.

  Definition massert_pred_eqv (P: A -> massert) (Q: A -> massert) : Prop :=
    forall x, massert_eqv (P x) (Q x).

  Lemma massert_pred_eqv_refl:
    forall P, massert_pred_eqv P P.
  Proof.
    now unfold massert_pred_eqv.
  Qed.

  Lemma massert_pred_eqv_sym:
    forall P Q, massert_pred_eqv P Q -> massert_pred_eqv Q P.
  Proof.
    unfold massert_pred_eqv. intros P Q HPQ x. now rewrite (HPQ x).
  Qed.

  Lemma massert_pred_eqv_trans:
    forall P Q R,
      massert_pred_eqv P Q ->
      massert_pred_eqv Q R ->
      massert_pred_eqv P R.
  Proof.
    unfold massert_pred_eqv. intros P Q R HPQ HQR x.
    now rewrite (HPQ x), (HQR x).
  Qed.

  Lemma massert_pred_eqv_inst:
    forall P Q x,
      massert_pred_eqv P Q ->
      massert_eqv (P x) (Q x).
  Proof.
    intros P Q x HPQ. apply HPQ.
  Qed.

End MassertPredEqv.

Add Parametric Relation (A: Type) : (A -> massert) massert_pred_eqv
    reflexivity proved by massert_pred_eqv_refl
    symmetry proved by massert_pred_eqv_sym
    transitivity proved by massert_pred_eqv_trans
as massert_pred_eqv_prel.

Section Sepall.
  Context {A: Type}.

  Definition sepall (p: A -> massert): list A -> massert :=
    fold_right (fun x => sepconj (p x)) sepemp.

  Lemma sepall_permutation:
    forall p xs ys,
      Permutation.Permutation xs ys ->
      (sepall p xs) <-*-> (sepall p ys).
  Proof.
    intros p xs ys Hperm.
    induction Hperm.
    - reflexivity.
    - simpl. now rewrite IHHperm.
    - simpl.
      rewrite sep_swap; reflexivity.
    - rewrite IHHperm1, <-IHHperm2.
      clear Hperm1 Hperm2 IHHperm1 IHHperm2.
      now induction l'.
  Qed.

  Lemma sepall_app:
    forall p xs ys,
      sepall p (xs ++ ys) <-*-> sepall p xs ** sepall p ys.
  Proof.
    intros.
    induction xs.
    - intros.
      rewrite sep_comm.
      rewrite <-sepemp_right.
      reflexivity.
    - intros.
      simpl.
      rewrite sep_assoc.
      rewrite IHxs.
      reflexivity.
  Qed.

  Lemma sepall_cons:
    forall p x xs,
      sepall p (x::xs) <-*-> p x ** sepall p xs.
  Proof.
    constructor; constructor; trivial.
  Qed.

  Lemma sepall_breakout:
    forall ys ws x xs p,
      ys = ws ++ x :: xs ->
      sepall p ys <-*-> p x ** sepall p (ws ++ xs).
  Proof.
    intros * Hys.
    rewrite sepall_app.
    rewrite sep_swap.
    rewrite <-sepall_cons.
    rewrite <-sepall_app.
    rewrite <-Hys.
    reflexivity.
  Qed.

  Lemma sepall_in:
    forall x ys,
      In x ys ->
      exists ws xs,
        ys = ws ++ x :: xs
        /\ (forall p,
              sepall p ys <-*-> p x ** sepall p (ws ++ xs)).
  Proof.
    intros x ys Hin.
    apply in_split in Hin.
    destruct Hin as [ws [xs Hys]].
    exists ws, xs.
    split; auto.
    intro p. apply sepall_breakout with (1:=Hys).
  Qed.

  Lemma sepall_wandout:
    forall p x xs,
      decidable_footprint (p x) ->
      In x xs ->
      (sepall p xs) <-*-> (p x ** (p x -* sepall p xs)).
  Proof.
    intros p x xs Hdec Hin.
    apply in_split in Hin.
    destruct Hin as (ws & ys & Hin).
    rewrite sepall_breakout with (1:=Hin).
    now apply sepwand_out.
  Qed.

  Lemma sepall_sepfalse:
    forall m p xs,
      m |= sepall p xs ->
      (forall x, In x xs -> p x <> sepfalse).
  Proof.
    intros m p xs Hall x Hin Hp.
    apply sepall_in in Hin.
    destruct Hin as [ws [ys [Hys Heq]]].
    rewrite Heq in Hall.
    apply sep_comm in Hall.
    apply sep_drop in Hall.
    rewrite Hp in Hall.
    destruct Hall.
  Qed.

  Lemma sepall_weakenp:
    forall P P' xs,
      (forall x, In x xs -> (P x) -*> (P' x)) ->
      (sepall P xs) -*> (sepall P' xs).
  Proof.
    intros P P' xs Hx.
    induction xs.
    reflexivity.
    simpl. apply sep_imp'.
    - apply Hx. apply in_eq.
    - rewrite IHxs. reflexivity.
      intros x Hin.
      apply Hx. apply in_cons with (1:=Hin).
  Qed.

  Lemma sepall_swapp:
    forall P P' xs,
      (forall x, In x xs -> P x <-*-> P' x) ->
      sepall P xs <-*-> sepall P' xs.
  Proof.
    intros P P' xs Hx.
    induction xs.
    reflexivity.
    simpl. apply sepconj_eqv.
    - rewrite Hx. reflexivity. apply in_eq.
    - rewrite IHxs. reflexivity.
      intros x Hin.
      apply Hx. apply in_cons with (1:=Hin).
  Qed.

  Lemma decidable_footprint_sepall:
    forall P xs,
      (forall x, decidable_footprint (P x)) ->
      decidable_footprint (sepall P xs).
  Proof.
    induction xs as [|x xs IH].
    now (intros; apply decidable_footprint_sepemp).
    intro HPx.
    simpl. apply decidable_footprint_sepconj.
    - apply HPx.
    - apply IH with (1:=HPx).
  Qed.

  Lemma footprint_perm_sepall:
    forall p P xs b lo hi,
      (forall x b lo hi, footprint_perm' p (P x) b lo hi) ->
      footprint_perm' p (sepall P xs) b lo hi.
  Proof.
    induction xs as [|x xs IH].
    now (intros; apply footprint_perm_sepemp).
    intros b lo hi Hfp.
    simpl. apply footprint_perm_sepconj.
    - apply Hfp.
    - apply IH with (1:=Hfp).
  Qed.

  Hint Resolve decidable_footprint_sepall footprint_perm_sepall.

  Lemma sepall_unwand:
  forall xs P Q,
    (forall x, decidable_footprint (P x)) ->
    (sepall P xs ** sepall (fun x => P x -* Q x) xs) -*> sepall Q xs.
  Proof.
    induction xs; simpl; intros * Hdec.
    - now rewrite sepemp_left.
    - rewrite sep_assoc, sep_swap23, <-sep_assoc.
      apply sep_imp'.
      + apply sep_unwand.
        apply Hdec.
      + apply IHxs; auto.
  Qed.

  Lemma subseteq_footprint_sepall:
    forall p q xs,
      (forall x, In x xs -> subseteq_footprint (p x) (q x)) ->
      subseteq_footprint (sepall p xs) (sepall q xs).
  Proof.
    intros p q xs Hsub.
    induction xs as [|x xs IH].
    now apply subseteq_footprint_refl.
    simpl. apply subseteq_footprint_sepconj.
    now (apply Hsub; constructor).
    apply IH.
    intros x' Hin.
    apply Hsub. now apply in_cons.
  Qed.

  Lemma sepall_outwand_cons:
    forall p q x xs,
      (forall x, decidable_footprint (p x)) ->
      (forall x, subseteq_footprint (p x) (q x)) ->
      (p x ** (p x -* q x)) ** sepall p xs ** (sepall p xs -* sepall q xs)
      -*> sepall p (x::xs) ** (sepall p (x::xs) -* sepall q (x::xs)).
  Proof.
    intros p q x xs Hdec Hsub.
    rewrite sep_assoc.
    split.
    - intros m Hm.
      rewrite sep_swap23 in Hm.
      rewrite unify_distinct_wands in Hm.
      + Opaque sepconj. simpl. Transparent sepconj. now rewrite sep_assoc.
      + rewrite sep_swap23 in Hm.
        rewrite <-sep_assoc in Hm.
        rewrite sep_unwand in Hm; [|now auto].
        rewrite sep_unwand in Hm; [|now auto].
        apply Hm.
      + apply Hsub.
      + apply subseteq_footprint_sepall.
        intros.
        apply Hsub.
    - intros b ofs Hf.
      rewrite sep_unwand; [|now auto].
      rewrite <-sep_assoc, sep_unwand; [|now auto].
      destruct Hf as [Hfp|Hf].
      + now rewrite subseteq_footprint_sepall with (q:=q) in Hfp.
      + now destruct Hf.
  Qed.

End Sepall.

Hint Resolve decidable_footprint_sepall footprint_perm_sepall.

Instance sepall_massert_pred_eqv_permutation_eqv_Proper A:
  Proper (massert_pred_eqv ==> @Permutation.Permutation A ==> massert_eqv)
         sepall.
Proof.
  intros p q Heq xs ys Hperm.
  rewrite sepall_permutation with (1:=Hperm).
  induction Hperm.
  - reflexivity.
  - simpl. now rewrite IHHperm, (massert_pred_eqv_inst _ _ _ Heq).
  - simpl.
    repeat rewrite (massert_pred_eqv_inst _ _ _ Heq).
    repeat apply sepconj_eqv; try reflexivity.
    induction l; [reflexivity|].
    simpl.
    now rewrite IHl, (massert_pred_eqv_inst _ _ _ Heq).
  - now rewrite IHHperm2.
Qed.

(* * * * * * * * Ranges * * * * * * * * * * * * * * *)

Section SplitRange.
  Variable env: composite_env.
  Variable id: ident.
  Variable co: composite.

  Hypothesis Henv: Ctypes.composite_env_consistent env.
  Hypothesis Hco: env!id = Some co.
  Hypothesis Hstruct: co_su co = Struct.

  Definition field_range' (p: permission) (flds: list (AST.ident * type))
             (b: block) (lo: Z) (fld: AST.ident * type) : massert :=
    let (id, ty) := fld in
    match field_offset env id flds with
      | Errors.OK ofs  => range' p b (lo + ofs) (lo + ofs + sizeof env ty)
      | Errors.Error _ => sepfalse
    end.

  Lemma decidable_footprint_field_range:
    forall p lo b flds,
      decidable_footprint (sepall (field_range' p flds b lo) flds).
  Proof.
    intros.
    apply decidable_footprint_sepall.
    intro fld. destruct fld as [x ty].
    simpl. destruct (field_offset env x flds); auto.
  Qed.

  Lemma footprint_perm_field_range:
    forall p flds b pos x b' lo hi,
      footprint_perm' p (field_range' p flds b pos x) b' lo hi.
  Proof.
    intros p flds b pos x b' lo hi.
    destruct x as [x ty].
    simpl. destruct (field_offset env x flds); auto.
  Qed.

  Lemma split_range_fields':
    forall p b lo flds,
      NoDupMembers flds ->
      massert_imp (range' p b lo (lo + sizeof_struct env 0 flds))
                  (sepall (field_range' p flds b lo) flds).
  Proof.
    intros p b lo flds Hndup.
    cut (forall cur,
            massert_imp
              (range' p b (lo + cur)
                       (lo + sizeof_struct env cur flds))
              (sepall (fun fld : AST.ident * type =>
                         let (id0, ty) := fld in
                         match field_offset_rec env id0 flds cur with
                         | Errors.OK ofs =>
                             range' p b (lo + ofs) (lo + ofs + sizeof env ty)
                         | Errors.Error _ => sepfalse
                         end) flds)).
    - intro HH.
      specialize HH with 0. rewrite Z.add_0_r in HH.
      apply HH.
    - induction flds as [|x xs IH]; [now constructor|].
      destruct x as [id' ty'].
      apply nodupmembers_cons in Hndup.
      destruct Hndup as [Hnin Hndup].
      specialize (IH Hndup).
      intro cur.
      Opaque sepconj. simpl.
      rewrite peq_true.
      erewrite sepall_swapp.
      + rewrite range_split'
        with (mid:=lo + (align cur (alignof env ty') + sizeof env ty')).
        * apply sep_imp'.
          2:now apply IH.
          rewrite range_split'
          with (mid:=lo + align cur (alignof env ty')).
          rewrite sep_drop. rewrite Z.add_assoc. reflexivity.
          split.
          now apply Z.add_le_mono_l; apply align_le; apply alignof_pos.
          apply Z.add_le_mono_l.
          rewrite <-Z.add_0_r at 1. apply Z.add_le_mono_l.
          apply Z.ge_le. apply sizeof_pos.
        * split.
          2:now apply Z.add_le_mono_l; apply sizeof_struct_incr.
          apply Z.add_le_mono_l.
          rewrite <-Z.add_0_r at 1. apply Z.add_le_mono.
          apply align_le. apply alignof_pos.
          apply Z.ge_le. apply sizeof_pos.
      + intros fld Hin.
        destruct fld.
        rewrite peq_false.
        reflexivity.
        intro Heq; subst.
        apply Hnin.
        eapply In_InMembers; eassumption.
  Qed.

  Lemma split_range_fields:
    forall p b lo,
      NoDupMembers (co_members co) ->
      massert_imp (range' p b lo (lo + co_sizeof co))
                  (sepall (field_range' p (co_members co) b lo) (co_members co)).
  Proof.
    intros p b lo Hndup.
    apply Henv in Hco.
    rewrite (co_consistent_sizeof _ _ Hco).
    rewrite (co_consistent_alignof _ _ Hco).
    rewrite Hstruct.
    simpl.
    rewrite range_split'
    with (mid:=lo + sizeof_struct env 0 (co_members co)).
    + rewrite split_range_fields' with (1:=Hndup).
      now rewrite sep_comm, sep_drop.
    + split.
      * rewrite <-Z.add_0_r at 1.
        apply Z.add_le_mono_l.
        apply sizeof_struct_incr.
      * apply Z.add_le_mono_l.
        apply align_le.
        apply alignof_composite_pos.
  Qed.

End SplitRange.

Notation field_range ge := (field_range' ge Freeable).
Notation field_range_w ge := (field_range' ge Writable).

(* * * * * * * * Initial memory * * * * * * * * * * * * * * *)

Import Globalenvs.
Import AST.
Import Clight.

Section Galloc.

  (* Variables F V : Type. *)
  Variable p : program (* (fundef F) V *).

  Definition grange (idg : ident * globdef fundef type) :=
    let (id, g) := idg in
    match Genv.find_symbol (Genv.globalenv p) id with
    | None => sepfalse
    | Some b =>
      match g with
      | Gfun f => range' Nonempty b 0 1
      | Gvar v =>
        pure (init_data_list_size (gvar_init v) <= Ptrofs.modulus)
             -* range' (Genv.perm_globvar v) b 0
                       (init_data_list_size v.(gvar_init))
      end
    end.

  Lemma init_grange:
    forall m0,
      NoDupMembers p.(prog_defs) ->
      Genv.init_mem p = Some m0 ->
      m0 |= sepall grange p.(prog_defs).
  Proof.
    pose proof (eq_refl p.(prog_defs)) as Hps.
    revert Hps. generalize p.(prog_defs) at 2 4.
    intros ps Hps' m0 Hndups Hinit.
    assert (exists ps', p.(prog_defs) = ps' ++ ps) as Hps
        by (exists nil; auto).
    clear Hps'.
    induction ps; auto.
    destruct a as (id, g).
    destruct Hps as (ps' & Hps).
    assert (m0 |= sepall grange ps) as IH
        by (apply IHps; exists (ps' ++ (id, g)::nil);
            now rewrite <- List_shift_first).
    clear IHps.
    assert ((prog_defmap p) ! id = Some g) as Hpdm
        by (apply prog_defmap_norepet;
            [now apply NoDup_norepet, fst_NoDupMembers|
             rewrite Hps; intuition]).
    apply Genv.find_def_symbol in Hpdm.
    destruct Hpdm as (b & Hfs & Hfd).
    apply sepall_cons.
    repeat constructor; auto.
    - (* m0 |= grange (id, g) *)
      simpl. rewrite Hfs.
      destruct g.
      + (* g = Gfun f *)
        apply Genv.find_funct_ptr_iff in Hfd.
        apply Genv.init_mem_characterization_2 with (2:=Hinit) in Hfd.
        destruct Hfd as (Hperm & Hperm').
        repeat constructor.
        * omega.
        * rewrite Z.one_succ; apply Zlt_le_succ, Z.gt_lt, two_power_nat_pos.
        * intros * HH. assert (i = 0) by omega.
          subst. now apply Mem.perm_cur.
      + (* g = Gvar v *)
        apply Genv.find_var_info_iff in Hfd.
        eapply Genv.init_mem_characterization with (2:=Hinit) in Hfd.
        destruct Hfd as (Hrp & Hfd).
        repeat constructor; auto.
        * reflexivity.
        * intros i k Hi.
          apply Mem.perm_cur.
          unfold wand_footprint in H.
          apply Mem.perm_unchanged_on with (1:=H); simpl; auto.
        * inversion_clear 1 as (? & Hf). simpl in *.
          destruct Hf as (Hb & Hf). subst.
          eapply Mem.perm_valid_block; eauto.
    - (* disjoint_footprint (grange (id, g)) (sepall grange ids) *)
      rewrite Hps in Hndups.
      apply NoDupMembers_app_cons in Hndups.
      destruct Hndups as (Hndups1 & Hndups2).
      apply NotInMembers_app in Hndups1.
      apply proj1 in Hndups1.
      clear Hndups2 Hinit Hps Hfd ps'.
      induction ps; auto using sepemp_disjoint.
      destruct a as (id' & g').
      apply NotInMembers_cons in Hndups1.
      destruct Hndups1 as (Hndups & Hnid').
      apply sepall_cons in IH.
      specialize (IHps Hndups (sep_proj2 _ _ _ IH)).
      apply sep_proj1 in IH.
      rewrite sepall_cons.
      apply disjoint_footprint_sepconj.
      split; auto. clear IHps.
      intros b' ofs' Hf1 Hf2.
      simpl in *.
      rewrite Hfs in Hf1.
      destruct (Genv.find_symbol (Genv.globalenv p) id') eqn:Hfs'; [|inv IH].
      apply Genv.global_addresses_distinct with (1:=Hnid') (2:=Hfs) in Hfs'.
      apply Hfs'.
      destruct g, g'; inversion_clear Hf1; inversion_clear Hf2;
        simpl in *; subst; intuition; now subst b b0.
  Qed.

End Galloc.

Lemma sep_swap56:
  forall P Q R S T U V, (P ** Q ** R ** S ** T ** U ** V) <-*-> (P ** Q ** R ** S ** U ** T ** V).
Proof.
  intros. rewrite (sep_swap T). reflexivity.
Qed.

Lemma sep_swap67:
  forall P Q R S T U V W, (P ** Q ** R ** S ** T ** U ** V ** W) <-*-> (P ** Q ** R ** S ** T ** V ** U ** W).
Proof.
  intros. rewrite (sep_swap U). reflexivity.
Qed.

Lemma sep_swap78:
  forall P Q R S T U V W X, (P ** Q ** R ** S ** T ** U ** V ** W ** X) <-*-> (P ** Q ** R ** S ** T ** U ** W ** V ** X).
Proof.
  intros. rewrite (sep_swap V). reflexivity.
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import Epsilon.
Require Import Init_ext ssrZ ZArith_ext seq_ext uniq_tac machine_int.
Require Import multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import multi_one_u_prg multi_one_u_triple multi_zero_u_safe_termination.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope zarith_ext_scope.

Lemma safe_termination_one_u a0 a1 rx x rk d : uniq(rk, rx, a0, a1, r0) ->
  safe_termination
  (fun st s h => state_mint (x |=> unsign rk rx \U+ d) st s h /\
                 (0 < '|u2Z ([rk ]_ s)|)%nat)
  (multi_one_u rk rx a0 a1).
Proof.
move=> Hset.
rewrite /safe_termination.
move=> st s h st_s_h.
set code := multi_one_u _ _ _ _.
have [x0 Htermi] : {x0 | Some (s, h) -- code ---> x0}.
  have [sf Htermi] : {x0 | Some (s, h) -- code ---> x0 /\ forall s, x0 = Some s -> True}.
    rewrite /code /multi_one_u.
    apply exists_seq_P with (fun s => forall s', s = Some s' -> True).
      apply constructive_indefinite_description.
      move: (multi_zero_u_safe_termination a0 a1 rx x rk d Hset).
      case/(_ _ _ _ (proj1 st_s_h)) => sf Htermi_zero_u.
      by exists (Some sf).
    destruct si as [[sti hi]|].
    move=> HP.
    eapply exists_addiu_seq_P.
    repeat Reg_upd.
    rewrite add0i.
    exists_sw1 l_idx H_l_idx z_idx H_z_idx => //.
    move=> HP.
    exists None.
    split=> //; exact: while.exec_none.
  exists sf.
  by case: Htermi.
have H1 : u2Z ([ rx ]_ s) + 4 * Z_of_nat '|u2Z ([rk ]_ s)| < \B^1.
  apply state_mint_head_unsign_fit with x d st h.
  by apply st_s_h.
have H3 : size (Z2ints 32 '|u2Z ([ rk ]_ s)| ([ x ]_st)%pseudo_expr) =
  '|u2Z ([rk ]_ s)|.
  by rewrite size_Z2ints.
have Hnk : (0 < '|u2Z ([ rk ]_ s)|)%nat by tauto.
move: (multi_one_u_triple _ _ _ _ Hset _ _ _ Hnk H3 H1) => triple_hoare.
apply constructive_indefinite_description'.
apply (triple_exec_precond _ _ _ triple_hoare _ _ _ Htermi
  (seq.iota '|u2Z ([rx ]_ s) / 4| '|u2Z ([rk ]_ s)|)).
split; first by [].
split.
- rewrite Z_of_nat_Zabs_nat //; exact: min_u2Z.
- case: st_s_h => st_s_h _.
  apply (state_mint_var_mint _ _ _ _ x (unsign rk rx)) in st_s_h; last by assoc_get_Some.
  by apply st_s_h.
Qed.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonDefinitions.
Require Import VerdiRaft.TraceUtil.

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

  Section inner.
    Variable client : clientId.
    Variable id : nat.
    Variable i : input.

    Definition correct_entry (e : entry) : Prop :=
      eClient e = client /\
      eId e = id /\
      eInput e = i.

    Definition applied_implies_input_state (net : network) : Prop :=
      exists e,
        correct_entry e /\
        ((exists h, In e (log (nwState net h))) \/
         (exists p entries, In p (nwPackets net) /\
                            mEntries (pBody p) = Some entries /\
                            In e entries)).

  End inner.

  Class applied_implies_input_interface : Prop :=
    {
      applied_implies_input :
        forall client id failed net tr e,
          step_failure_star step_failure_init (failed, net) tr ->
          eClient e = client ->
          eId e = id ->
          applied_implies_input_state client id (eInput e) net ->
          in_input_trace client id (eInput e) tr
    }.
End AppliedImpliesInputInterface.


Require Import VST.floyd.proofauto.
Require Import VST.progs.funcptr.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition myspec :=
  WITH i: Z
  PRE [ tint ]
          PROP (Int.min_signed <= i < Int.max_signed)
          PARAMS (Vint (Int.repr i))
          SEP ()
  POST [ tint ]
         PROP() RETURN (Vint (Int.repr (i+1)))
          SEP().

Definition myfunc_spec := DECLARE _myfunc myspec.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    myfunc_spec; main_spec]).

Lemma body_myfunc: semax_body Vprog Gprog f_myfunc myfunc_spec.
Proof.
unfold myfunc_spec.
unfold myspec.
start_function.
forward.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function. fold cc_default noattr tint.
make_func_ptr _myfunc.
forward.

forward_call 3.
forward.
Qed.