(** * Data types for the crowdfunding contract tailored for extraction *)

Require Import String ZArith Basics.
From ConCert.Embedding Require Import Ast Notations PCUICTranslate Utils.
From ConCert.Embedding.Examples Require Import SimpleBlockchain.
From ConCert.Extraction.Examples Require Import Prelude.

Require Import List PeanoNat ssrbool.

Import ListNotations.
From MetaCoq.Template Require Import All.

Import MonadNotation.
Import BaseTypes.
Open Scope list.

Import AcornBlockchain.

(** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in  [Ast.v] and make use of the "custom entries" feature. *)

(** Brackets like [[\ \]] delimit the scope of data type definitions and like [[| |]] the scope of programs *)

(** Generating names for the data structures  *)
Run TemplateProgram
      (mkNames ["State" ; "mkState"; "balance" ; "donations" ; "owner"; "deadline"; "goal"; "done";
                "Res" ; "Error";
                "msg"; "Donate"; "GetFunds"; "Claim";
                "Action"; "Transfer"; "Empty" ] "_coq").

Import ListNotations.

(** ** Definitions of data structures for the contract *)

(** Parameters of the contract *)
Definition params_ty : type :=
  (* Deadline, Goal, Owner *)
  [! time × (money × address)!].

(** The internal state of the contract that is modified during the execution *)
Definition state_ty : type :=
  (* Contributions, Done *)
  [! Map × Bool !].

(** The full type of contract's internal state  *)
Definition full_state_ty :=
  [! {params_ty} × {state_ty} !].

(** Messages *)
Definition msg_syn :=
  [\ data msg =
       Donate [_]
     | GetFunds [_]
     | Claim [_] \].

Make Inductive (global_to_tc msg_syn).

(** ** Custom notations for projections from the state type *)

Notation "'get_params' st" :=
  [| first {params_ty} {state_ty} {st} |]
    (in custom expr at level 0).

Notation "'get_state' st" :=
  [| second {params_ty} {state_ty} {st} |]
    (in custom expr at level 0).

Notation "'deadline' st" :=
  [| first time (money × address) (get_params {st}) |]
    (in custom expr at level 0).

Notation "'goal' st" :=
  [| first money address (second time (money × address) (get_params {st})) |]
    (in custom expr at level 0).

Notation "'owner' st" :=
  [| second money address (second time (money × address) (get_params {st})) |]
    (in custom expr at level 0).

Notation "'contribs' st" :=
    [| first Map Bool (get_state {st}) |]
      (in custom expr at level 0).

Notation "'done' st" :=
  [| second Map Bool (get_state {st}) |]
    (in custom expr at level 0).

(** ** State "updates" *)

Notation "'mkFullState' prms st" :=
    [| Pair {params_ty} {state_ty} {prms} {st} |]
      (in custom expr at level 0,
          prms custom expr at next level,
          st custom expr at next level).

Notation "'mkParams' dl g o" :=
  [| Pair time (money × address) {dl} (Pair money address {g} {o}) |]
      (in custom expr at level 0,
          dl custom expr at next level,
          g custom expr at next level,
          o custom expr at next level).

Notation "'mkState' cs dn" :=
    [| Pair Map Bool {cs} {dn} |]
      (in custom expr at level 0,
          cs custom expr at next level,
          dn custom expr at next level).

Definition update_contribs_syn :=
  [| \"f_st" : {full_state_ty} => \"cs" : Map =>
     let "ps" : {params_ty} := get_params "f_st" in
     let "new_st" : {state_ty} := mkState "cs" (done "f_st") in
     mkFullState "ps" "new_st" |].

Make Definition update_contribs :=
  (expr_to_tc Σ (indexify nil update_contribs_syn)).

Definition set_done_syn :=
  [| \"f_st" : {full_state_ty} =>
     let "ps" : {params_ty} := get_params "f_st" in
     let "new_st" : {state_ty} := mkState (contribs "f_st") True in
     mkFullState "ps" "new_st" |].

Make Definition set_done :=
  (expr_to_tc Σ (indexify nil set_done_syn)).

(** ** Custom notations for projections from the call context and global state *)
Module Notations.

  Notation "'ctx_from' a" := [| {eConst "Ctx_from"} {a} |]
                             (in custom expr at level 0).
  Notation "'ctx_contract_address' a" :=
    [| {eConst "Ctx_contract_address"} {a} |]
      (in custom expr at level 0).
  Notation "'amount' a" := [| {eConst "Ctx_amount"} {a} |]
                             (in custom expr at level 0).

  (** New global context with the constants defined above (in addition to the ones defined in the Oak's "StdLib") *)

  Definition Σ' :=
    Prelude.Σ ++ [ Prelude.AcornMaybe;
           msg_syn;
           addr_map_acorn;
           AcornBlockchain.SimpleChainAcorn;
           AcornBlockchain.SimpleContractCallContextAcorn;
           AcornBlockchain.SimpleActionBodyAcorn;
           gdInd "Z" 0 [("Z0", []); ("Zpos", [(None,tyInd "positive")]);
                          ("Zneg", [(None,tyInd "positive")])] false].

  Notation "0 'z'" := (eConstr "Z" "Z0") (in custom expr at level 0).
  End Notations.

Notation SCtx := "SimpleContractCallContext".


Require Import VST.floyd.proofauto.
Require Import fastpile.
Require Import spec_stdlib.
Global Open Scope funspec_scope.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition tpile := Tstruct _pile noattr.

Definition countrep (s: Z) (p: val) : mpred :=
  EX s':Z, !! (0 <= s /\ 0 <= s' <= Int.max_signed /\
                 (s <= Int.max_signed -> s'=s)) &&
  data_at Ews tpile (Vint (Int.repr s')) p.

Definition count_freeable (p: val) :=
   malloc_token Ews tpile p.

Lemma countrep_local_facts:
  forall s p,
   countrep s p |-- !! isptr p.
Proof.
intros.
unfold countrep.
Intros s'.
entailer!.
Qed.

Hint Resolve countrep_local_facts : saturate_local.

Lemma countrep_valid_pointer:
  forall s p,
   countrep s p |-- valid_pointer p.
Proof.
 intros.
 unfold countrep. Intros s'.
 auto with valid_pointer.
Qed.
Hint Resolve countrep_valid_pointer : valid_pointer.

Local Open Scope assert.

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 ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS () GLOBALS (gv) SEP(mem_mgr gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(countrep 0 p; count_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, s: Z, gv: globals
 PRE [ tptr tpile, tint ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(countrep s p; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(countrep (n+s) p; mem_mgr gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, s: Z
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) GLOBALS ()
    SEP(countrep s p)
 POST[ tint ]
   EX s':Z,
      PROP(s <= Int.max_signed -> s'=s)
      LOCAL(temp ret_temp (Vint (Int.repr s')))
      SEP(countrep s p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, s: Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) GLOBALS (gv)
    SEP(countrep s p; count_freeable p; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL() SEP(mem_mgr gv).

Definition ispecs := [surely_malloc_spec].
Definition specs := [Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export nuprl_props.
Require Export choice.
Require Export cvterm.

Lemma tequality_uatom {p} :
  forall lib, @tequality p lib mkc_uatom mkc_uatom.
Proof.
  introv.
  unfold tequality.
  exists (@equality_of_uatom p lib).
  unfold nuprl.
  apply CL_uatom.
  unfold per_uatom; sp; spcast;
  try (apply computes_to_valc_refl);
  try (apply iscvalue_mkc_uatom; auto).
Qed.

Lemma equality_in_uatom_iff {p} :
  forall lib (t1 t2 : @CTerm p),
    equality lib t1 t2 mkc_uatom
    <=> {a : get_patom_set p
        , t1 ===>(lib) (mkc_utoken a)
        # t2 ===>(lib) (mkc_utoken a)}.
Proof.
  intros; split; intro i; exrepnd.
  - unfold equality, nuprl in i; exrepnd.
    inversion i1; subst; try not_univ.
    allunfold @per_uatom; repnd.
    allunfold @eq_term_equals.
    discover.
    allunfold @equality_of_uatom; exrepnd.
    exists u; sp.
  - exists (@equality_of_uatom p lib); dands.
    apply CL_uatom; unfold per_uatom; sp;
    spcast; apply computes_to_value_isvalue_refl; repeat constructor; simpl; sp.
    exists a; sp.
Qed.

Lemma tequality_atom {p} :
  forall lib, @tequality p lib mkc_atom mkc_atom.
Proof.
  introv.
  unfold tequality.
  exists (@equality_of_atom p lib).
  unfold nuprl.
  apply CL_atom.
  unfold per_atom; sp; spcast;
  try (apply computes_to_valc_refl);
  try (apply iscvalue_mkc_atom; auto).
Qed.

Lemma equality_in_atom_iff {p} :
  forall lib (t1 t2 : @CTerm p),
    equality lib t1 t2 mkc_atom
    <=> {a : String.string
        , t1 ===>(lib) (mkc_token a)
        # t2 ===>(lib) (mkc_token a)}.
Proof.
  intros; split; intro i; exrepnd.
  - unfold equality, nuprl in i; exrepnd.
    inversion i1; subst; try not_univ.
    allunfold @per_atom; repnd.
    allunfold @eq_term_equals.
    discover.
    allunfold @equality_of_atom; exrepnd.
    exists s; sp.
  - exists (@equality_of_atom p lib); dands.
    apply CL_atom; unfold per_atom; sp;
    spcast; apply computes_to_value_isvalue_refl; repeat constructor; simpl; sp.
    exists a; sp.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.

Lemma red306to310 : reducible_in_range 306 310 the_configs.
Proof. CheckReducible. Qed.


From iris.bi Require Export bi.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

(** The class of laterable assertions *)
Class Laterable {PROP : bi} (P : PROP) := laterable :
  P -∗ ∃ Q, ▷ Q ∗ □ (▷ Q -∗ ◇ P).
Global Arguments Laterable {_} _%I : simpl never.
Global Arguments laterable {_} _%I {_}.
Global Hint Mode Laterable + ! : typeclass_instances.

(** Proofmode class for turning [P] into a laterable [Q].
    Will be the identity if [P] already is laterable, and add
    [▷] otherwise. *)
Class IntoLaterable {PROP : bi} (P Q : PROP) : Prop := {
  (** This is non-standard; usually we would just demand
      [P ⊢ make_laterable Q]. However, we need these stronger properties for
      the [make_laterable_id] hack in [atomic.v]. *)
  into_laterable : P ⊢ Q;
  into_laterable_result_laterable : Laterable Q;
}.
Global Arguments IntoLaterable {_} P%I Q%I.
Global Arguments into_laterable {_} P%I Q%I {_}.
Global Arguments into_laterable_result_laterable {_} P%I Q%I {_}.
Global Hint Mode IntoLaterable + ! - : typeclass_instances.

Section instances.
  Context {PROP : bi}.
  Implicit Types P : PROP.
  Implicit Types Ps : list PROP.

  Global Instance laterable_proper : Proper ((⊣⊢) ==> (↔)) (@Laterable PROP).
  Proof. solve_proper. Qed.

  Global Instance later_laterable P : Laterable (▷ P).
  Proof.
    rewrite /Laterable. iIntros "HP". iExists P. iFrame.
    iIntros "!> HP !>". done.
  Qed.

  Global Instance timeless_laterable P :
    Timeless P → Laterable P.
  Proof.
    rewrite /Laterable. iIntros (?) "HP". iExists P%I. iFrame.
    iSplitR; first by iNext. iIntros "!> >HP !>". done.
  Qed.

  (** This lemma is not very useful: It needs a strange assumption about
      emp, and most of the time intuitionistic propositions can be just kept
      around anyway and don't need to be "latered".  The lemma exists
      because the fact that it needs the side-condition is interesting;
      it is not an instance because it won't usually get used. *)
  Lemma intuitionistic_laterable P :
    Timeless (PROP:=PROP) emp → Affine P → Persistent P → Laterable P.
  Proof.
    rewrite /Laterable. iIntros (???) "#HP".
    iExists emp%I. iSplitL; first by iNext.
    iIntros "!> >_". done.
  Qed.

  (** This instance, together with the one below, can lead to massive
      backtracking, but only when searching for [Laterable]. In the future, it
      should be rewritten using [Hint Immediate] or [Hint Cut], where the latter
      is preferred once we figure out how to use it. *)
  Global Instance persistent_laterable `{!BiAffine PROP} P :
    Persistent P → Laterable P.
  Proof.
    intros ?. apply intuitionistic_laterable; apply _.
  Qed.

  Global Instance sep_laterable P Q :
    Laterable P → Laterable Q → Laterable (P ∗ Q).
  Proof.
    rewrite /Laterable. iIntros (LP LQ) "[HP HQ]".
    iDestruct (LP with "HP") as (P') "[HP' #HP]".
    iDestruct (LQ with "HQ") as (Q') "[HQ' #HQ]".
    iExists (P' ∗ Q')%I. iSplitL; first by iFrame.
    iIntros "!> [HP' HQ']". iSplitL "HP'".
    - iApply "HP". done.
    - iApply "HQ". done.
  Qed.

  Global Instance exist_laterable {A} (Φ : A → PROP) :
    (∀ x, Laterable (Φ x)) → Laterable (∃ x, Φ x).
  Proof.
    rewrite /Laterable. iIntros (LΦ). iDestruct 1 as (x) "H".
    iDestruct (LΦ with "H") as (Q) "[HQ #HΦ]".
    iExists Q. iIntros "{$HQ} !> HQ". iExists x. by iApply "HΦ".
  Qed.

  Lemma big_sep_sepL_laterable Q Ps :
    Laterable Q →
    TCForall Laterable Ps →
    Laterable (Q ∗ [∗] Ps).
  Proof.
    intros HQ HPs. revert Q HQ. induction HPs as [|P Ps ?? IH]; intros Q HQ.
    { simpl. rewrite right_id. done. }
    simpl. rewrite assoc. apply IH; by apply _.
  Qed.

  Global Instance big_sepL_laterable Ps :
    Laterable (PROP:=PROP) emp →
    TCForall Laterable Ps →
    Laterable ([∗] Ps).
  Proof.
    intros. assert (Laterable (emp ∗ [∗] Ps)) as Hlater.
    { apply big_sep_sepL_laterable; done. }
    rewrite ->left_id in Hlater; last by apply _. done.
  Qed.

  (** A wrapper to obtain a weaker, laterable form of any assertion.
     Alternatively: the modality corresponding to [Laterable].
     The ◇ is required to make [make_laterable_intro'] hold.
   TODO: Define [Laterable] in terms of this (see [laterable_alt] below). *)
  Definition make_laterable (Q : PROP) : PROP :=
    ∃ P, ▷ P ∗ □ (▷ P -∗ ◇ Q).

  Global Instance make_laterable_ne : NonExpansive make_laterable.
  Proof. solve_proper. Qed.
  Global Instance make_laterable_proper : Proper ((≡) ==> (≡)) make_laterable := ne_proper _.
  Global Instance make_laterable_mono' : Proper ((⊢) ==> (⊢)) make_laterable.
  Proof. solve_proper. Qed.
  Global Instance make_laterable_flip_mono' :
    Proper (flip (⊢) ==> flip (⊢)) make_laterable.
  Proof. solve_proper. Qed.

  Lemma make_laterable_mono Q1 Q2 :
    (Q1 ⊢ Q2) → (make_laterable Q1 ⊢ make_laterable Q2).
  Proof. by intros ->. Qed.

  Lemma make_laterable_except_0 Q :
    make_laterable (◇ Q) -∗ make_laterable Q.
  Proof.
    iIntros "(%P & HP & #HPQ)". iExists P. iFrame.
    iIntros "!# HP". iMod ("HPQ" with "HP"). done.
  Qed.

  Lemma make_laterable_sep Q1 Q2 :
    make_laterable Q1 ∗ make_laterable Q2 -∗ make_laterable (Q1 ∗ Q2).
  Proof.
    iIntros "[HQ1 HQ2]".
    iDestruct "HQ1" as (P1) "[HP1 #HQ1]".
    iDestruct "HQ2" as (P2) "[HP2 #HQ2]".
    iExists (P1 ∗ P2)%I. iFrame. iIntros "!# [HP1 HP2]".
    iDestruct ("HQ1" with "HP1") as ">$".
    iDestruct ("HQ2" with "HP2") as ">$".
    done.
  Qed.

  (** A stronger version of [make_laterable_mono] that lets us keep laterable
  resources. We cannot keep arbitrary resources since that would let us "frame
  in" non-laterable things. *)
  Lemma make_laterable_wand Q1 Q2 :
    make_laterable (Q1 -∗ Q2) -∗ (make_laterable Q1 -∗ make_laterable Q2).
  Proof.
    iIntros "HQ HQ1".
    iDestruct (make_laterable_sep with "[$HQ $HQ1 //]") as "HQ".
    iApply make_laterable_mono; last done.
    by rewrite bi.wand_elim_l.
  Qed.

  (** A variant of the above for keeping arbitrary intuitionistic resources.
      Sadly, this is not implied by the above for non-affine BIs. *)
  Lemma make_laterable_intuitionistic_wand Q1 Q2 :
    □ (Q1 -∗ Q2) -∗ (make_laterable Q1 -∗ make_laterable Q2).
  Proof.
    iIntros "#HQ HQ1". iDestruct "HQ1" as (P) "[HP #HQ1]".
    iExists P. iFrame. iIntros "!> HP".
    iDestruct ("HQ1" with "HP") as "{HQ1} >HQ1".
    iModIntro. iApply "HQ". done.
  Qed.

  Global Instance make_laterable_laterable Q :
    Laterable (make_laterable Q).
  Proof.
    rewrite /Laterable. iIntros "HQ". iDestruct "HQ" as (P) "[HP #HQ]".
    iExists P. iFrame. iIntros "!> HP !>". iExists P. by iFrame.
  Qed.

  Lemma make_laterable_elim Q :
    make_laterable Q -∗ ◇ Q.
  Proof.
    iIntros "HQ". iDestruct "HQ" as (P) "[HP #HQ]". by iApply "HQ".
  Qed.

  (** Written internally (as an entailment of wands) to reflect
      that persistent assertions can be kept unchanged. *)
  Lemma make_laterable_intro P Q :
    Laterable P →
    □ (P -∗ Q) -∗ P -∗ make_laterable Q.
  Proof.
    iIntros (?) "#HQ HP".
    iDestruct (laterable with "HP") as (P') "[HP' #HPi]". iExists P'.
    iFrame. iIntros "!> HP'".
    iDestruct ("HPi" with "HP'") as ">HP". iModIntro.
    iApply "HQ". done.
  Qed.
  Lemma make_laterable_intro' Q :
    Laterable Q →
    Q -∗ make_laterable Q.
  Proof.
    intros ?. iApply make_laterable_intro. iIntros "!# $".
  Qed.

  Lemma make_laterable_idemp Q :
    make_laterable (make_laterable Q) ⊣⊢ make_laterable Q.
  Proof.
    apply (anti_symm (⊢)).
    - trans (make_laterable (◇ Q)).
      + apply make_laterable_mono, make_laterable_elim.
      + apply make_laterable_except_0.
    - apply make_laterable_intro', _.
  Qed.

  Lemma laterable_alt Q :
    Laterable Q ↔ (Q -∗ make_laterable Q).
  Proof.
    split.
    - intros ?. apply make_laterable_intro'. done.
    - intros ?. done.
  Qed.

  (** * Proofmode integration

      We integrate [make_laterable] with [iModIntro]. All non-laterable
      hypotheses have a ▷ added in front of them to ensure a laterable context.
  *)
  Global Instance into_laterable_laterable P :
    Laterable P →
    IntoLaterable P P.
  Proof. intros ?. constructor; done. Qed.

  Global Instance into_laterable_fallback P :
    IntoLaterable P (▷ P) | 100.
  Proof. constructor; last by apply _. apply bi.later_intro. Qed.

  Lemma modality_make_laterable_mixin `{!Timeless (PROP:=PROP) emp} :
    modality_mixin make_laterable MIEnvId (MIEnvTransform IntoLaterable).
  Proof.
    split; simpl; eauto using make_laterable_intro', make_laterable_mono,
      make_laterable_sep, intuitionistic_laterable with typeclass_instances; [].
    intros P Q ?. rewrite (into_laterable P).
    apply make_laterable_intro'. eapply (into_laterable_result_laterable P), _.
  Qed.

  Definition modality_make_laterable `{!Timeless (PROP:=PROP) emp} :=
    Modality _ modality_make_laterable_mixin.

  Global Instance from_modal_make_laterable `{!Timeless (PROP:=PROP) emp} P :
    FromModal True modality_make_laterable (make_laterable P) (make_laterable P) P.
  Proof. by rewrite /FromModal. Qed.

End instances.

Typeclasses Opaque make_laterable.


From iris.algebra Require Import
  excl
  proofmode_classes.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.
From caml5.algebra Require Import
  lib.auth_option.

Definition auth_excl A :=
  auth_option (exclR A).
Definition auth_excl_R A :=
  auth_option_R (exclR A).
Definition auth_excl_UR A :=
  auth_option_UR (exclR A).

Definition auth_excl_auth {A : ofe} dq (a : A) : auth_excl_UR A :=
  ●O{dq} (Excl a).
Definition auth_excl_frag {A : ofe} (a : A) : auth_excl_UR A :=
  ◯O (Excl a).
Notation "●E{ dq } a" := (auth_excl_auth dq a)
( at level 20,
  format "●E{ dq }  a"
).
Notation "●E{# q } a" := (●E{DfracOwn q} a)
( at level 20,
  format "●E{# q }  a"
).
Notation "●E a" := (●E{#1} a)
( at level 20
).
Notation "●E□ a" := (●E{DfracDiscarded} a)
( at level 20
).
Notation "◯E a" := (auth_excl_frag a)
( at level 20
).

Section ofe.
  Context {A : ofe}.
  Implicit Types a b : A.

  #[global] Instance auth_excl_auth_ne dq :
    NonExpansive (@auth_excl_auth A dq).
  Proof.
    solve_proper.
  Qed.
  #[global] Instance auth_excl_auth_proper dq :
    Proper ((≡) ==> (≡)) (@auth_excl_auth A dq).
  Proof.
    solve_proper.
  Qed.
  #[global] Instance auth_excl_frag_ne :
    NonExpansive (@auth_excl_frag A).
  Proof.
    solve_proper.
  Qed.
  #[global] Instance auth_excl_frag_proper :
    Proper ((≡) ==> (≡)) (@auth_excl_frag A).
  Proof.
    solve_proper.
  Qed.

  #[global] Instance auth_excl_auth_dist_inj n :
    Inj2 (=) (≡{n}≡) (≡{n}≡) (@auth_excl_auth A).
  Proof.
    intros ?* (-> & ?%(inj Excl))%(inj2 auth_option_auth). done.
  Qed.
  #[global] Instance auth_excl_auth_inj :
    Inj2 (=) (≡) (≡) (@auth_excl_auth A).
  Proof.
    intros ?* (-> & ?%(inj Excl))%(inj2 auth_option_auth). done.
  Qed.
  #[global] Instance auth_excl_frag_dist_inj n :
    Inj (≡{n}≡) (≡{n}≡) (@auth_excl_frag A).
  Proof.
    intros ?* ?%(inj auth_option_frag)%(inj Excl). done.
  Qed.
  #[global] Instance auth_excl_frag_inj :
    Inj (≡) (≡) (@auth_excl_frag A).
  Proof.
    intros ?* ?%(inj auth_option_frag)%(inj Excl). done.
  Qed.

  #[global] Instance auth_excl_auth_discrete dq a :
    Discrete a →
    Discrete (●E{dq} a).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_excl_frag_discrete a :
    Discrete a →
    Discrete (◯E a).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_excl_cmra_discrete :
    OfeDiscrete A →
    CmraDiscrete (auth_excl_R A).
  Proof.
    apply _.
  Qed.

  Lemma auth_excl_auth_dfrac_op dq1 dq2 a :
    ●E{dq1 ⋅ dq2} a ≡ ●E{dq1} a ⋅ ●E{dq2} a.
  Proof.
    apply auth_option_auth_dfrac_op.
  Qed.
  #[global] Instance auth_excl_auth_dfrac_is_op dq dq1 dq2 a :
    IsOp dq dq1 dq2 →
    IsOp' (●E{dq} a) (●E{dq1} a) (●E{dq2} a).
  Proof.
    apply _.
  Qed.

  #[global] Instance auth_excl_auth_core_id a :
    CoreId (●E□ a).
  Proof.
    apply _.
  Qed.

  Lemma auth_excl_auth_dfrac_validN n dq a :
    ✓{n} (●E{dq} a) ↔
    ✓ dq.
  Proof.
    rewrite auth_option_auth_dfrac_validN. naive_solver.
  Qed.
  Lemma auth_excl_auth_dfrac_valid dq a :
    ✓ (●E{dq} a) ↔
    ✓ dq.
  Proof.
    rewrite auth_option_auth_dfrac_valid. naive_solver.
  Qed.
  Lemma auth_excl_auth_validN n a :
    ✓{n} (●E a).
  Proof.
    rewrite auth_option_auth_validN //.
  Qed.
  Lemma auth_excl_auth_valid a :
    ✓ (●E a).
  Proof.
    rewrite auth_option_auth_valid //.
  Qed.

  Lemma auth_excl_auth_dfrac_op_validN n dq1 a1 dq2 a2 :
    ✓{n} (●E{dq1} a1 ⋅ ●E{dq2} a2) ↔
    ✓ (dq1 ⋅ dq2) ∧ a1 ≡{n}≡ a2.
  Proof.
    rewrite auth_option_auth_dfrac_op_validN. split.
    - naive_solver eauto using (inj Excl).
    - naive_solver solve_proper.
  Qed.
  Lemma auth_excl_auth_dfrac_op_valid dq1 a1 dq2 a2 :
    ✓ (●E{dq1} a1 ⋅ ●E{dq2} a2) ↔
    ✓ (dq1 ⋅ dq2) ∧ a1 ≡ a2.
  Proof.
    rewrite auth_option_auth_dfrac_op_valid. split.
    - naive_solver eauto using (@inj _ _ equiv equiv Excl) with typeclass_instances.
    - naive_solver solve_proper.
  Qed.
  Lemma auth_excl_auth_op_validN n a1 a2 :
    ✓{n} (●E a1 ⋅ ●E a2) ↔
    False.
  Proof.
    rewrite auth_option_auth_op_validN //.
  Qed.
  Lemma auth_excl_auth_op_valid a b :
    ✓ (●E a ⋅ ●E b) ↔
    False.
  Proof.
    rewrite auth_option_auth_op_valid //.
  Qed.

  Lemma auth_excl_frag_validN n a :
    ✓{n} (◯E a).
  Proof.
    rewrite auth_option_frag_validN //.
  Qed.
  Lemma auth_excl_frag_valid a :
    ✓ (◯E a).
  Proof.
    rewrite auth_option_frag_valid //.
  Qed.

  Lemma auth_excl_frag_op_validN n a b :
    ✓{n} (◯E a ⋅ ◯E b) ↔
    False.
  Proof.
    rewrite auth_option_frag_op_validN //.
  Qed.
  Lemma auth_excl_frag_op_valid a b :
    ✓ (◯E a ⋅ ◯E b) ↔
    False.
  Proof.
    rewrite auth_option_frag_op_valid //.
  Qed.

  Lemma auth_excl_both_dfrac_validN n dq a b :
    ✓{n} (●E{dq} a ⋅ ◯E b) ↔
    ✓ dq ∧ a ≡{n}≡ b.
  Proof.
    rewrite auth_option_both_dfrac_validN. split.
    - intros (? & [?%(inj Excl) | ?%exclusive_includedN] & ?); done || apply _.
    - naive_solver solve_proper.
  Qed.
  Lemma auth_excl_both_dfrac_valid dq a b :
    ✓ (●E{dq} a ⋅ ◯E b) ↔
    ✓ dq ∧ a ≡ b.
  Proof.
    rewrite auth_option_both_dfrac_valid. split.
    - intros (? & H & ?). split; first done.
      rewrite equiv_dist. intros n.
      specialize (H n) as [?%(inj Excl) | ?%exclusive_includedN]; done || apply _.
    - intros. destruct_and!. split_and!; try done.
      intros. left. f_equiv. eauto using equiv_dist.
  Qed.
  Lemma auth_excl_both_validN n a b :
    ✓{n} (●E a ⋅ ◯E b) ↔
    a ≡{n}≡ b.
  Proof.
    rewrite auth_excl_both_dfrac_validN. naive_solver done.
  Qed.
  Lemma auth_excl_both_valid a b :
    ✓ (●E a ⋅ ◯E b) ↔
    a ≡ b.
  Proof.
    rewrite auth_excl_both_dfrac_valid. naive_solver done.
  Qed.

  Lemma auth_excl_auth_persist dq a :
    ●E{dq} a ~~> ●E□ a.
  Proof.
    apply auth_option_auth_persist.
  Qed.
  Lemma auth_excl_both_update a b a' b' :
    a' ≡ b' →
    ●E a ⋅ ◯E b ~~> ●E a' ⋅ ◯E b'.
  Proof.
    intros <-. apply auth_option_both_update, exclusive_local_update. done.
  Qed.
End ofe.

#[global] Opaque auth_excl_auth.
#[global] Opaque auth_excl_frag.


Require Import Coq.Lists.List.

Require Export SystemFR.ReducibilitySubst.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducibility_candidate_empty:
  reducibility_candidate (fun _ => False).
Proof.
  unfold reducibility_candidate; steps.
Qed.

Lemma reducible_type_abs:
  forall ρ t T X,
    fv t = nil ->
    fv T = nil ->
    wf t 0 ->
    wf T 1 ->
    is_erased_term t ->
    valid_interpretation ρ ->
    (X ∈ pfv T type_var -> False) ->
    (X ∈ support ρ -> False) ->
    (forall RC,
      reducibility_candidate RC ->
      [ (X,RC) :: ρ ⊨ t : topen 0 T (fvar X type_var) ]) ->
   [ ρ ⊨ t : T_abs T ].
Proof.
  intros.
  unshelve epose proof (H7 (fun _ => False) _); steps; eauto using reducibility_candidate_empty; t_closing.

  unfold reduces_to in *; repeat step || simp_red; t_closing.
  exists v; repeat step || simp_red; t_closing;
    eauto 3 using red_is_val, reducibility_candidate_empty with step_tactic.
  exists X; steps.
  instantiate_any; repeat step || t_deterministic_star;
    eauto 3 using red_is_val, reducibility_candidate_empty with step_tactic.
Qed.

Lemma open_reducible_type_abs:
  forall Θ Γ t T (X : nat),
    subset (pfv t term_var) (support Γ) ->
    subset (pfv T term_var) (support Γ) ->
    wf t 0 ->
    wf T 1 ->
    (X ∈ pfv_context Γ term_var -> False) ->
    (X ∈ pfv_context Γ type_var -> False) ->
    (X ∈ pfv t term_var -> False) ->
    (X ∈ pfv T term_var -> False) ->
    (X ∈ pfv T type_var -> False) ->
    (X ∈ Θ -> False) ->
    is_erased_term t ->
    [ X :: Θ; Γ ⊨ t : topen 0 T (fvar X type_var) ] ->
    [ Θ; Γ ⊨ t : T_abs T ].
Proof.
  unfold open_reducible; repeat step || t_termlist.

  apply reducible_type_abs with X;
    repeat step || rewrite fv_subst_different_tag in * by (steps; eauto with fv);
      eauto with wf;
      eauto with fv;
      eauto with erased.

  match goal with
  | H: forall _ _, _ |- _ =>
      unshelve epose proof (H ((X,RC) :: ρ) lterms _ _ _)
  end;
    repeat step || t_substitutions;
    eauto using satisfies_unused.
Qed.

Lemma reducible_inst:
  forall ρ t U V,
    wf V 0 ->
    twf V 0 ->
    pfv V term_var = nil ->
    wf U 0 ->
    pfv U term_var = nil ->
    valid_interpretation ρ ->
    is_erased_type U ->
    is_erased_type V ->
    [ ρ ⊨ t : T_abs U ] ->
    [ ρ ⊨ t : topen 0 U V ].
Proof.
  unfold reduces_to in *;
    repeat step || list_utils || simp_red || unfold reduces_to in *.
  match goal with
  | H: forall RC, reducibility_candidate RC -> _ |- _ =>
      unshelve epose proof (H (fun v => [ ρ ⊨ v : V ]v) _); steps;
        eauto using reducibility_is_candidate
  end.
  exists v; steps; eauto using star_trans with cbvlemmas.
  apply (reducible_rename_one _ _ _ _ _ (makeFresh (pfv U type_var :: pfv V type_var :: nil))) in H12;
    repeat step || finisher; eauto using reducibility_is_candidate.
  eapply reducible_values_subst_head; eauto; repeat step || list_utils || finisher.
Qed.

Lemma open_reducible_inst:
  forall Θ (Γ : context) t U V,
    wf U 0 ->
    wf V 0 ->
    twf V 0 ->
    is_erased_type U ->
    is_erased_type V ->
    subset (fv U) (support Γ) ->
    subset (fv V) (support Γ) ->
    [ Θ; Γ ⊨ t : T_abs U ] ->
    [ Θ; Γ ⊨ t : topen 0 U V ].
Proof.
  unfold open_reducible;
    repeat step || t_instantiate_sat3 || rewrite substitute_topen || apply reducible_inst ||
      rewrite fv_subst_different_tag in * by (steps; eauto with fv);
    t_closer;
    eauto with twf.
Qed.


Require Import List String.
Require Import Lib.CommonTactics Lib.Struct Lib.FMap.
Require Import Kami.Syntax Kami.Semantics Kami.SemFacts Kami.Wf.

Set Implicit Arguments.
Set Asymmetric Patterns.

Fixpoint composeLabels (ls1 ls2: LabelSeqT) :=
  match ls1, ls2 with
    | l1 :: ls1', l2 :: ls2' =>
      (hide (mergeLabel l1 l2)) :: (composeLabels ls1' ls2')
    | _, _ => nil
  end.

Section TwoModules.
  Variables (ma mb: Modules).

  Hypotheses (HmaEquiv: ModEquiv type typeUT ma)
             (HmbEquiv: ModEquiv type typeUT mb).

  Hypotheses (Hinit: DisjList (namesOf (getRegInits ma)) (namesOf (getRegInits mb)))
             (Hdefs: DisjList (getDefs ma) (getDefs mb))
             (Hcalls1: DisjList (getCalls ma) (getIntCalls mb))
             (Hcalls2: DisjList (getIntCalls ma) (getCalls mb))
             (Hvr: ValidRegsModules type (ConcatMod ma mb)).

  Definition regsA (r: RegsT) := M.restrict r (namesOf (getRegInits ma)).
  Definition regsB (r: RegsT) := M.restrict r (namesOf (getRegInits mb)).

  Definition mergeUnitLabel (ul1 ul2: UnitLabel): UnitLabel :=
    match ul1, ul2 with
      | Rle (Some _), _ => ul1
      | _, Rle (Some _) => ul2
      | Meth (Some _), _ => ul1
      | _, Meth (Some _) => ul2
      | Rle None, _ => ul1
      | _, Rle None => ul2
      | _, _ => Meth None (* unspecified *)
    end.

  Definition OneMustMethNone (ul1 ul2: UnitLabel) :=
    ul1 = Meth None \/ ul2 = Meth None.
  #[local] Hint Unfold OneMustMethNone.

  Lemma substep_split:
    forall o u ul cs,
      Substep (ConcatMod ma mb) o u ul cs ->
      exists ua ub ula ulb csa csb,
        Substep ma (regsA o) ua ula csa /\
        Substep mb (regsB o) ub ulb csb /\
        M.Disj ua ub /\ u = M.union ua ub /\
        OneMustMethNone ula ulb /\ ul = mergeUnitLabel ula ulb /\
        M.Disj csa csb /\ cs = M.union csa csb.
  Proof.
    induction 1; simpl; intros.

    - exists (M.empty _), (M.empty _).
      exists (Rle None), (Meth None), (M.empty _), (M.empty _).
      repeat split; auto; constructor.

    - exists (M.empty _), (M.empty _).
      exists (Meth None), (Meth None), (M.empty _), (M.empty _).
      repeat split; auto; constructor.

    - simpl in HInRules; apply in_app_or in HInRules.
      destruct HInRules.
      + exists u, (M.empty _).
        exists (Rle (Some k)), (Meth None), cs, (M.empty _).
        repeat split; auto; econstructor; eauto.
        apply validRegsAction_old_regs_restrict; auto.
        eapply validRegsRules_rule; eauto.
        inv Hvr; apply validRegsModules_validRegsRules; auto.
      + exists (M.empty _), u.
        exists (Meth None), (Rle (Some k)), (M.empty _), cs.
        repeat split; auto; econstructor; eauto.
        apply validRegsAction_old_regs_restrict; auto.
        eapply validRegsRules_rule; eauto.
        inv Hvr; apply validRegsModules_validRegsRules; auto.

    - simpl in HIn; apply in_app_or in HIn.
      destruct HIn.
      + exists u, (M.empty _).
        eexists (Meth (Some _)), (Meth None), cs, (M.empty _).
        repeat split; auto; econstructor; eauto.
        apply validRegsAction_old_regs_restrict; auto.
        eapply validRegsDms_dm; eauto.
        inv Hvr; apply validRegsModules_validRegsDms; auto.
      + exists (M.empty _), u.
        eexists (Meth None), (Meth (Some _)), (M.empty _), cs.
        repeat split; auto; econstructor; eauto.
        apply validRegsAction_old_regs_restrict; auto.
        eapply validRegsDms_dm; eauto.
        inv Hvr; apply validRegsModules_validRegsDms; auto.

  Qed.

  Lemma substepsInd_split:
    forall o u l,
      SubstepsInd (ConcatMod ma mb) o u l ->
      exists ua ub la lb,
        SubstepsInd ma (regsA o) ua la /\
        SubstepsInd mb (regsB o) ub lb /\
        M.Disj ua ub /\ u = M.union ua ub /\
        CanCombineLabel la lb /\ l = mergeLabel la lb.
  Proof.
    induction 1; simpl; intros.
    - exists (M.empty _), (M.empty _), emptyMethLabel, emptyMethLabel.
      repeat split; auto; try constructor;
        simpl; intro; eapply M.F.P.F.empty_in_iff; eauto.

    - subst.
      destruct IHSubstepsInd as [pua [pub [pla [plb ?]]]]; dest; subst.
      apply substep_split in H0.
      destruct H0 as [sua [sub [sula [sulb [scsa [scsb ?]]]]]];
        dest; subst.

      exists (M.union pua sua), (M.union pub sub).
      exists (mergeLabel (getLabel sula scsa) pla),
      (mergeLabel (getLabel sulb scsb) plb).
      inv H1; inv H6; dest.

      repeat split.

      + eapply SubstepsCons; eauto.
        repeat split; auto.
        { destruct pla, plb; simpl in *; mdisj. }
        { destruct pla as [[[|]|] ? ?], plb as [[[|]|] ? ?];
          destruct sula as [[|]|[|]], sulb as [[|]|[|]];
          simpl in *; auto; findeq; try (inv H9; discriminate).
        }

      + eapply SubstepsCons; eauto.
        repeat split; auto.
        { destruct pla, plb; simpl in *; mdisj. }
        { destruct pla as [[[|]|] ? ?], plb as [[[|]|] ? ?];
          destruct sula as [[|]|[|]], sulb as [[|]|[|]];
          simpl in *; auto; findeq; try (inv H9; discriminate);
          try (destruct (M.find a defs); discriminate).
        }

      + auto.
      + auto.
      + destruct pla as [[[|]|] pdsa pcsa], plb as [[[|]|] pdsb pcsb];
          destruct sula as [[|]|[[? ?]|]], sulb as [[|]|[[? ?]|]];
          simpl in *; try (inv H9; discriminate); auto.
      + destruct pla as [[[|]|] pdsa pcsa], plb as [[[|]|] pdsb pcsb];
          destruct sula as [[|]|[[? ?]|]], sulb as [[|]|[[? ?]|]];
          simpl in *; try (inv H9; discriminate); auto.
      + destruct pla as [[[|]|] ? ?], plb as [[[|]|] ? ?];
          destruct sula as [[|]|[|]], sulb as [[|]|[|]];
          simpl in *; try (inv H9; discriminate); auto.
      + destruct pla as [[[|]|] pdsa pcsa], plb as [[[|]|] pdsb pcsb];
          destruct sula as [[|]|[[? ?]|]], sulb as [[|]|[[? ?]|]];
          simpl in *; try (inv H9; discriminate);
            try (intuition auto; fail);
            try (f_equal; auto; fail).
  Qed.

  Definition WellHiddenConcat (ma mb: Modules) (la lb: LabelT) :=
    wellHidden (ConcatMod ma mb) (hide (mergeLabel la lb)).

  Lemma stepInd_split:
    forall o u l,
      StepInd (ConcatMod ma mb) o u l ->
      exists ua ub la lb,
        StepInd ma (regsA o) ua la /\ StepInd mb (regsB o) ub lb /\
        M.Disj ua ub /\ u = M.union ua ub /\
        CanCombineLabel la lb /\ wellHidden (ConcatMod ma mb) (hide (mergeLabel la lb)) /\
        WellHiddenConcat ma mb la lb /\ l = hide (mergeLabel la lb).
  Proof.
    induction 1; simpl; intros.
    pose proof (substepsInd_split HSubSteps)
      as [ua [ub [la [lb ?]]]]; dest; subst.
    exists ua, ub, (hide la), (hide lb).
    intuition auto.

    - constructor; auto.
      inv H3; dest.
      pose proof (substepsInd_calls_in HmaEquiv H).
      pose proof (substepsInd_defs_in H).
      pose proof (substepsInd_calls_in HmbEquiv H0).
      pose proof (substepsInd_defs_in H0).
      eapply wellHidden_split
      with (ma:= ma) (mb:= mb) (la:= la) (lb:= lb); eauto.
    - constructor; auto.
      inv H3; dest.
      pose proof (substepsInd_calls_in HmaEquiv H).
      pose proof (substepsInd_defs_in H).
      pose proof (substepsInd_calls_in HmbEquiv H0).
      pose proof (substepsInd_defs_in H0).
      eapply wellHidden_split
      with (ma:= ma) (mb:= mb) (la:= la) (lb:= lb); eauto.
    - apply CanCombineLabel_hide; auto.
    - inv H3; dest.
      rewrite <-hide_mergeLabel_idempotent; auto.
    - unfold WellHiddenConcat; intros.
      inv H3; rewrite <-hide_mergeLabel_idempotent; auto.
    - inv H3; rewrite <-hide_mergeLabel_idempotent; auto.
  Qed.

  Lemma step_split:
    forall o u l,
      Step (ConcatMod ma mb) o u l ->
      exists ua ub la lb,
        Step ma (regsA o) ua la /\ Step mb (regsB o) ub lb /\
        M.Disj ua ub /\ u = M.union ua ub /\
        CanCombineLabel la lb /\ wellHidden (ConcatMod ma mb) (hide (mergeLabel la lb)) /\
        WellHiddenConcat ma mb la lb /\ l = hide (mergeLabel la lb).
  Proof.
    intros; apply step_consistent in H.
    pose proof (stepInd_split H) as [ua [ub [la [lb ?]]]]; dest; subst.
    exists ua, ub, la, lb.
    inv H4; inv H5; dest.
    repeat split; auto; apply step_consistent; auto.
  Qed.

  Inductive WellHiddenConcatSeq (ma mb: Modules): LabelSeqT -> LabelSeqT -> Prop :=
  | WHCSNil: WellHiddenConcatSeq ma mb nil nil
  | WHCSCons:
      forall la lb lsa lsb,
        WellHiddenConcatSeq ma mb lsa lsb ->
        WellHiddenConcat ma mb la lb ->
        WellHiddenConcatSeq ma mb (la :: lsa) (lb :: lsb).

  Lemma wellHiddenConcatSeq_length:
    forall ma mb lsa lsb,
      WellHiddenConcatSeq ma mb lsa lsb ->
      List.length lsa = List.length lsb.
  Proof. induction lsa; intros; inv H; simpl; auto. Qed.

  Lemma multistep_split:
    forall s ls ir,
      Multistep (ConcatMod ma mb) ir s ls ->
      ir = initRegs (getRegInits ma ++ getRegInits mb) ->
      exists sa lsa sb lsb,
        Multistep ma (initRegs (getRegInits ma)) sa lsa /\
        Multistep mb (initRegs (getRegInits mb)) sb lsb /\
        M.Disj sa sb /\ s = M.union sa sb /\
        CanCombineLabelSeq lsa lsb /\ WellHiddenConcatSeq ma mb lsa lsb /\
        ls = composeLabels lsa lsb.
  Proof.
    induction 1; simpl; intros; subst.
    - do 2 (eexists; exists nil); repeat split; try (econstructor; eauto; fail).
      + eapply M.DisjList_KeysSubset_Disj with (d1:= namesOf (getRegInits ma)); eauto;
          unfold initRegs; rewrite rawInitRegs_namesOf;
            apply makeMap_KeysSubset; auto.
      + subst; unfold initRegs.
        rewrite <-makeMap_union.
        * unfold rawInitRegs; rewrite map_app; auto.
        * rewrite <- !rawInitRegs_namesOf; auto.

    - intros; subst.
      specialize (IHMultistep eq_refl).
      destruct IHMultistep as [sa [lsa [sb [lsb ?]]]]; dest; subst.

      apply step_split in HStep.
      destruct HStep as [sua [sub [sla [slb ?]]]]; dest; subst.

      inv Hvr.
      pose proof (validRegsModules_multistep_newregs_subset H8 H0 eq_refl).
      pose proof (validRegsModules_multistep_newregs_subset H12 H1 eq_refl).
      pose proof (validRegsModules_step_newregs_subset H8 H3).
      pose proof (validRegsModules_step_newregs_subset H12 H6).

      inv H9; dest.
      exists (M.union sua sa), (sla :: lsa).
      exists (M.union sub sb), (slb :: lsb).
      repeat split; auto.

      + constructor; auto.
        p_equal H3.
        unfold regsA; rewrite M.restrict_union.
        rewrite M.restrict_KeysSubset; auto.
        rewrite M.restrict_DisjList with (d1:= namesOf (getRegInits mb)); auto.
        apply DisjList_comm; auto.

      + constructor; auto.
        p_equal H6.
        unfold regsB; rewrite M.restrict_union.
        rewrite M.restrict_KeysSubset with (m:= sb); auto.
        rewrite M.restrict_DisjList with (d1:= namesOf (getRegInits ma)); auto.

      + mdisj.
        * eapply M.DisjList_KeysSubset_Disj with (d1:= namesOf (getRegInits mb)); eauto.
          apply DisjList_comm; auto.
        * eapply M.DisjList_KeysSubset_Disj with (d1:= namesOf (getRegInits mb)); eauto.
          apply DisjList_comm; auto.

      + pose proof (M.DisjList_KeysSubset_Disj Hinit H13 H16).
        meq.

      + constructor; auto.
  Qed.

  Lemma behavior_split:
    forall s ls,
      Behavior (ConcatMod ma mb) s ls ->
      exists sa lsa sb lsb,
        Behavior ma sa lsa /\ Behavior mb sb lsb /\
        M.Disj sa sb /\ s = M.union sa sb /\
        CanCombineLabelSeq lsa lsb /\ WellHiddenConcatSeq ma mb lsa lsb /\
        ls = composeLabels lsa lsb.
  Proof.
    induction 1.
    apply multistep_split in HMultistepBeh.
    destruct HMultistepBeh as [sa [lsa [sb [lsb ?]]]]; dest; subst.
    exists sa, lsa, sb, lsb.
    repeat split; auto.
    reflexivity.
  Qed.

  (** Now modular theorem begins *)

  Lemma substepsInd_modular:
    forall oa ua la,
      SubstepsInd ma oa ua la ->
      forall ob ub lb,
        M.Disj oa ob -> CanCombineUL ua ub la lb ->
        SubstepsInd mb ob ub lb ->
        SubstepsInd (ConcatMod ma mb) (M.union oa ob) (M.union ua ub) (mergeLabel la lb).
  Proof.
    induction 1; simpl; intros; subst.
    - destruct lb as [annb dsb csb]; simpl in *.
      do 3 rewrite M.union_empty_L.
      apply substepsInd_modules_weakening with (mc:= mb); [|eauto].
      eapply substepsInd_oldRegs_weakening; eauto.
      apply M.Sub_union_2; auto.
    - rewrite mergeLabel_assoc.
      inv H1; dest.
      rewrite M.union_comm with (m1:= u); [|auto].
      eapply SubstepsCons.
      + eapply IHSubstepsInd; eauto.
        clear -H5.

        (* Better to extract a lemma *)
        inv H5; inv H0; dest.
        destruct (getLabel sul scs), l, lb; simpl in *.
        repeat split; simpl; auto.
        destruct annot, annot0, annot1; auto.

      + apply substep_modules_weakening with (mc:= ma); [|eauto].
        eapply substep_oldRegs_weakening; eauto.
        apply M.Sub_union_1.
      + inv H5; inv H8; dest.
        destruct l, lb; repeat split; simpl in *; auto.
        destruct annot, annot0, sul as [|[[? ?]|]]; auto; findeq.
      + inv H5; inv H8; dest; auto.
      + reflexivity.
  Qed.

  Definition WellHiddenModular (ma mb: Modules) (la lb: LabelT) :=
    ValidLabel ma la ->
    ValidLabel mb lb ->
    wellHidden ma (hide la) ->
    wellHidden mb (hide lb) ->
    wellHidden (ConcatMod ma mb) (hide (mergeLabel la lb)).

  Inductive WellHiddenModularSeq (ma mb: Modules): LabelSeqT -> LabelSeqT -> Prop :=
  | WHMSNil: WellHiddenModularSeq ma mb nil nil
  | WHMSCons:
      forall la lb lsa lsb,
        WellHiddenModularSeq ma mb lsa lsb ->
        WellHiddenModular ma mb la lb ->
        WellHiddenModularSeq ma mb (la :: lsa) (lb :: lsb).

  Lemma wellHidden_concat_modular:
    forall ma mb la lb, WellHiddenConcat ma mb la lb ->
                        WellHiddenModular ma mb la lb.
  Proof. unfold WellHiddenModular, WellHiddenConcat; intros; auto. Qed.

  Lemma wellHidden_concat_modular_seq:
    forall ma mb la lb, WellHiddenConcatSeq ma mb la lb ->
                        WellHiddenModularSeq ma mb la lb.
  Proof.
    induction la; intros.
    - inv H; constructor.
    - inv H; constructor; auto.
      apply wellHidden_concat_modular; auto.
  Qed.

  Lemma validLabel_wellHidden_calls_disj:
    forall la lb,
      ValidLabel ma la -> wellHidden ma (hide la) ->
      ValidLabel mb lb -> wellHidden mb (hide lb) ->
      M.Disj (calls (hide la)) (calls (hide lb)) ->
      M.Disj (calls la) (calls lb).
  Proof.
    unfold ValidLabel, wellHidden; intros; dest.
    destruct la as [anna dsa csa], lb as [annb dsb csb].
    simpl in *.
    unfold M.Disj, M.KeysDisj, M.KeysSubset in *; intros.
    specializeAll k.
    repeat rewrite M.F.P.F.in_find_iff in *.
    rewrite M.subtractKV_find in H0, H2, H3, H4, H6.
    rewrite M.subtractKV_find in H3.
    destruct (M.find k csa); [right|auto].
    destruct (M.find k csb); [|auto].
    exfalso.
    specialize (H5 (opt_discr _)).
    specialize (H7 (opt_discr _)).
    destruct (M.find k dsa).
    1: {
      specialize (H (opt_discr _)).
      specialize (Hcalls2 k); destruct Hcalls2.
      { elim H8.
        apply filter_In; split; [auto|].
        apply existsb_exists; exists k.
        split; [auto|apply StringEq.string_eq_true].
      }
      { elim H8; assumption. }
    }

    destruct (M.find k dsb).
    1: {
      specialize (H1 (opt_discr _)).
      specialize (Hcalls1 k); destruct Hcalls1.
      { elim H8; assumption. }
      { elim H8.
        apply filter_In; split; [auto|].
        apply existsb_exists; exists k.
        split; [auto|apply StringEq.string_eq_true].
      }
    }

    destruct H3; elim H3; discriminate.
  Qed.

  Lemma stepInd_modular:
    forall oa ua la,
      StepInd ma oa ua la ->
      forall ob ub lb,
        M.Disj oa ob -> CanCombineUL ua ub la lb ->
        WellHiddenModular ma mb la lb ->
        StepInd mb ob ub lb ->
        StepInd (ConcatMod ma mb) (M.union oa ob) (M.union ua ub)
                (hide (mergeLabel la lb)).
  Proof.
    intros; inv H; inv H3.

    pose proof (substepsInd_defs_in HSubSteps).
    pose proof (substepsInd_calls_in HmaEquiv HSubSteps).
    pose proof (substepsInd_defs_in HSubSteps0).
    pose proof (substepsInd_calls_in HmbEquiv HSubSteps0).

    inv H1; inv H7; dest.
    assert (M.Disj (defs l) (defs l0))
      by (eapply M.DisjList_KeysSubset_Disj with (d1:= getDefs ma); eauto).
    assert (M.Disj (calls l) (calls l0))
      by (apply validLabel_wellHidden_calls_disj; auto; try (split; assumption)).

    replace (hide (mergeLabel (hide l) (hide l0))) with (hide (mergeLabel l l0))
      by (apply hide_mergeLabel_idempotent; auto).
    constructor.
    - apply substepsInd_modular; auto.
      constructor; auto.
      repeat split; auto.
    - unfold WellHiddenModular, ValidLabel in H2.
      rewrite <-hide_mergeLabel_idempotent in H2 by auto.
      apply H2.
      + split.
        * apply M.KeysSubset_Sub with (m2:= defs l); auto.
          apply M.subtractKV_sub.
        * apply M.KeysSubset_Sub with (m2:= calls l); auto.
          apply M.subtractKV_sub.
      + split.
        * apply M.KeysSubset_Sub with (m2:= defs l0); auto.
          apply M.subtractKV_sub.
        * apply M.KeysSubset_Sub with (m2:= calls l0); auto.
          apply M.subtractKV_sub.
      + rewrite <-hide_idempotent; auto.
      + rewrite <-hide_idempotent; auto.
  Qed.

  Lemma step_modular:
    forall oa ua la,
      Step ma oa ua la ->
      forall ob ub lb,
        M.Disj oa ob -> CanCombineUL ua ub la lb ->
        WellHiddenModular ma mb la lb ->
        Step mb ob ub lb ->
        Step (ConcatMod ma mb) (M.union oa ob) (M.union ua ub) (hide (mergeLabel la lb)).
  Proof.
    intros.
    apply step_consistent in H; apply step_consistent in H3.
    apply step_consistent.
    apply stepInd_modular; auto.
  Qed.

  Lemma multistep_modular:
    forall lsa oa sa,
      Multistep ma oa sa lsa ->
      oa = initRegs (getRegInits ma) ->
      forall ob sb lsb,
        Multistep mb ob sb lsb ->
        ob = initRegs (getRegInits mb) ->
        CanCombineLabelSeq lsa lsb ->
        WellHiddenModularSeq ma mb lsa lsb ->
        Multistep (ConcatMod ma mb) (initRegs (getRegInits (ConcatMod ma mb)))
                  (M.union sa sb) (composeLabels lsa lsb).
  Proof.
    induction lsa; simpl; intros; subst.

    - destruct lsb; [|intuition idtac].
      inv H; inv H1; constructor.
      unfold initRegs.
      rewrite <-makeMap_union; auto.
      + unfold rawInitRegs; rewrite map_app; auto.
      + rewrite <- !rawInitRegs_namesOf; auto.

    - destruct lsb as [|]; [intuition idtac|].
      destruct H3; inv H4.
      inv H; inv H1.
      pose proof Hvr as Hvr'.
      inv Hvr'.

      pose proof (validRegsModules_multistep_newregs_subset H HMultistep eq_refl).
      pose proof (validRegsModules_multistep_newregs_subset H1 HMultistep0 eq_refl).
      pose proof (validRegsModules_step_newregs_subset H HStep).
      pose proof (validRegsModules_step_newregs_subset H1 HStep0).

      replace (M.union (M.union u n) (M.union u0 n0))
      with (M.union (M.union u u0) (M.union n n0))
        by (pose proof (M.DisjList_KeysSubset_Disj Hinit H3 H6); meq).

      inv H0; dest.
      constructor; eauto.
      apply step_modular; auto.
      + eapply M.DisjList_KeysSubset_Disj with (d1:= namesOf (getRegInits ma)); eauto.
      + repeat split; auto.
        eapply M.DisjList_KeysSubset_Disj with (d1:= namesOf (getRegInits ma)); eauto.
  Qed.

  Lemma behavior_modular:
    forall sa sb lsa lsb,
      Behavior ma sa lsa ->
      Behavior mb sb lsb ->
      CanCombineLabelSeq lsa lsb ->
      WellHiddenModularSeq ma mb lsa lsb ->
      Behavior (ConcatMod ma mb) (M.union sa sb) (composeLabels lsa lsb).
  Proof.
    intros; inv H; inv H0; constructor.
    eapply multistep_modular; eauto.
  Qed.

End TwoModules.


Require Import Coq.omega.Omega.
Require Import compcert.cfrontend.Clight.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Maps.
Require Import compcert.common.Memory.
Require Import compcert.common.Values.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Smallstep.

Require Import VST.sepcomp.semantics.
Require Import VST.sepcomp.event_semantics.
Require Import VST.concurrency.common.semantics.
Require Import VST.concurrency.common.permissions.
Require Import VST.concurrency.compiler.advanced_permissions.
Require Import VST.concurrency.compiler.diagrams.
Require Import VST.concurrency.lib.tactics.

Require Import VST.concurrency.compiler.mem_equiv.
Require Import VST.concurrency.lib.setoid_help.
Require Import Coq.Classes.Morphisms.

Set Bullet Behavior "Strict Subproofs".
Set Nested Proofs Allowed.

(*Self simulations say that a program has equivalent executions
  in equivalent memories.
  - Equivalent memories: VISIBLE locations are injected
    one to one (same values and permissions).
  - Equivalent executions: the executions have equivalent memories and
    none visible locations are unchanged (in the execution).
 *)

Section SelfSim.

  Variable Sem: semantics.

  (*Separate state and memory*)
  Variable core: Type.
  Variable state_to_memcore: state Sem -> (core * Mem.mem).
  Variable memcore_to_state: core -> Mem.mem -> state Sem.
  Hypothesis state_to_memcore_correct:
    forall c m, state_to_memcore (memcore_to_state c m) = (c,m).
  Hypothesis memcore_to_state_correct: forall s c m,
   state_to_memcore  s = (c,m) -> s = memcore_to_state c m.

  (*extension of a mem_injection
  (slightly stengthens the old inject_separated - LENB: not sure you need the stronger prop*)
  Definition is_ext (f1:meminj)(nb1: positive)(f2:meminj)(nb2:positive) : Prop:=
    forall b1 b2 ofs,
      f2 b1 = Some (b2, ofs) ->
      f1 b1 = None ->
      (ofs = 0 /\ ~ Plt b1 nb1 /\  ~ Plt b2 nb2).

  (*The code is also injected*)
  Variable code_inject: meminj -> core -> core -> Prop.
  Variable code_inj_incr: forall c1 mu c2 mu',
      code_inject mu c1 c2 ->
      inject_incr mu mu' ->
      code_inject mu' c1 c2.

  (*The current permisions OF THIS THREAD are unchanged! *)
  (*This is slightly stronger than Mem.inject/mi_inj which allows
    permissions to grow (on compilation). *)
  (*also it could be restricted to take only the Cur permissions*)
  (*NEVERMIND... BOTH FOLLOW from Mem.inject!*)
  Definition perm_inject1 (f:meminj)(m1:mem)(m2:mem): Prop:=
    forall b1 b2 delta,
      f b1 = Some (b2, delta) ->
      forall ofs p,
        Mem.perm m1 b1 (ofs ) Cur p  ->
        Mem.perm m2 b2 (ofs + delta) Cur p.

  Definition perm_inject2 (f:meminj)(m1:mem)(m2:mem): Prop:=
    forall b1 b2 delta,
      f b1 = Some (b2, delta) ->
      forall ofs p,
        Mem.perm m2 b2 (ofs + delta) Cur p ->
        Mem.perm m1 b1 (ofs ) Cur p \/ ~ Mem.perm m1 b1 ofs Cur Nonempty.

  Record match_mem (f: meminj) (m1:mem) (m2:mem): Prop:=
    { minject: Mem.inject f m1 m2
      ; pimage: perm_image f (getCurPerm m1)
      ; ppreimage: perm_surj f (getCurPerm m1) (getCurPerm m2)
    }.

  Instance proper_match_mem:
    Proper (Logic.eq ==> mem_equiv ==> mem_equiv ==> iff) match_mem.
  Proof.
    setoid_help.proper_iff; setoid_help.proper_intros; subst.
    inversion H2; econstructor.
    - rewrite <- H1, <- H0; assumption.
    - pose proof (cur_eqv _ _ H0).
      unfold Cur_equiv in *.
      rewrite <- H; assumption.
    - inv H0; inv H1.
      unfold Cur_equiv in *.
      rewrite <- cur_eqv, <- cur_eqv0; assumption.
  Qed.

  Record match_self (f: meminj) (c1:core) (m1:mem) (c2:core) (m2:mem): Prop:=
    { cinject: code_inject f c1 c2
    ; matchmem: match_mem f m1 m2
    }.

  Lemma all_order_eq:
    forall a b, (forall p, Mem.perm_order' a p <->  Mem.perm_order' b p) <-> a = b.
  Proof.
    clear.
    intros. destruct a, b; auto.
    4: tauto.
    3: { simpl; split; intros; try congruence.
         specialize (H Nonempty).
         destruct H as [_ HH].
         contradict HH. apply perm_any_N. }

    2: { simpl; split; intros; try congruence.
         specialize (H Nonempty).
         destruct H as [ HH _].
         contradict HH. apply perm_any_N. }

    intros; split.
    - intros.
      dup H as H'.
      specialize (H p ); destruct H as [H _].
      specialize (H ltac:(simpl; apply perm_refl)).
      specialize (H' p0); destruct H' as [_ H'].
      specialize (H' ltac:(simpl; apply perm_refl)).
      simpl in *.
      destruct p, p0; inversion H; inversion H'; auto.
    - intros H; invert H; intros; auto. reflexivity.
  Qed.

  Lemma match_source_forward:
    forall mu c1 m1 c2 m2,
      match_self mu c1 m1 c2 m2 ->
      forall mu' m1' m2',
        inject_incr mu mu' ->
        Mem.inject mu' m1' m2' ->
        same_visible m1 m1' ->
        same_visible m2 m2' ->
        match_self mu' c1 m1' c2 m2'.
  Proof.
  intros ? ? ? ? ? MATCH ? ? ? INCR INJ VIS1 VIS2.
  constructor.
  - eapply code_inj_incr; eauto; apply MATCH.
  - inv MATCH.
    split; trivial.
    * (*perm_image*) (*Easy ... use lemmas to simplify same_visible*)
      intros b1 ofs PERM.
      assert (PERM':Mem.perm m1' b1 ofs Cur Nonempty).
      { apply at_least_Some_perm_Cur; assumption. }
      apply VIS1 in PERM'.
      pose proof (pimage _ _ _ matchmem0 b1 ofs); unfold perm_image in *.
      apply at_least_Some_perm_Cur in PERM'.
      eapply H in PERM'; eauto.
      destruct PERM' as (? & ? & ?).
      do 2 eexists; eapply INCR; eauto.
    * (*Pre_image*) (*Easy ... use lemmas to simplify same_visible*)
      intros b2 ofs_delta PERM.
      assert (PERM':Mem.perm m2' b2 ofs_delta Cur Nonempty).
      { apply at_least_Some_perm_Cur; assumption. }
      apply VIS2 in PERM'.
      pose proof (ppreimage _ _ _ matchmem0 b2 ofs_delta).
      apply at_least_Some_perm_Cur in PERM'.
      eapply H in PERM'; eauto.
      destruct PERM' as (? & ? & ? & ? & ? & ?).
      do 3 eexists; repeat split; try eapply INCR; eauto.
      repeat rewrite getCurPerm_correct in *.
      repeat unfold permission_at in *.
      pose proof (same_cur _ _ VIS1 x x0) as HH1.
      pose proof (same_cur _ _ VIS2 b2 ofs_delta) as HH2.
      unfold Mem.perm in *.
      etransitivity. etransitivity.
      symmetry.
      1,3: eapply all_order_eq.
      eapply HH2.
      eapply HH1.
      eauto.
  Qed.

End SelfSim.
Arguments match_self {core}.

Section SelfSimulation.

  Variable state:Type.
  Variable Sem: semantics.CoreSemantics state mem.
  Variable state_to_memcore: state -> (state * Mem.mem).
  Variable memcore_to_state: state -> Mem.mem -> state.
  Notation get_core s:= (fst (state_to_memcore s)).
  Notation get_mem s:= (snd (state_to_memcore s)).

  Import Integers.
  Import Ptrofs.

  Definition self_preserves_atx_inj {s m} (Sem:semantics.CoreSemantics s m) match_states:=
    forall (j:meminj) s1 m1 s2 m2,
      match_states j s1 m1 s2 m2 ->
      forall f args,
        at_external Sem s1 m1 = Some (f,args) ->
        exists args',
          at_external Sem s2 m2 = Some (f,args') /\
          Val.inject_list j args args'.

 Record self_simulation: Type :=
    { code_inject: meminj -> state -> state -> Prop;
      code_inj_incr: forall c1 mu c2 mu',
          code_inject mu c1 c2 ->
          inject_incr mu mu' ->
          code_inject mu' c1 c2;
      ssim_diagram: forall f t c1 m1 c2 m2,
        match_self code_inject f c1 m1 c2 m2 ->
        forall c1' m1',
          semantics.corestep Sem c1 m1  c1' m1' ->
          exists c2' f' t' m2',
          semantics.corestep Sem c2 m2  c2' m2'  /\
          match_self code_inject f' c1' m1' c2' m2' /\
          inject_incr f f' /\
          is_ext f (Mem.nextblock m1) f' (Mem.nextblock m2) /\
          Events.inject_trace f' t t'
      ; ssim_external: forall c1 c2 m1 m2 j b1 ofs func_name,
        code_inject j c1 c2 ->
        Mem.inject j m1 m2 ->
        semantics.at_external Sem c1 m1  =
        Some (func_name, Vptr b1 ofs :: nil) ->
        exists b2 delt,
        j b1 = Some (b2, delt) /\
        semantics.at_external Sem c2 m2 =
        Some (func_name, Vptr b2 (add ofs (repr delt)) :: nil)
      ; ssim_preserves_atx:
          self_preserves_atx_inj Sem (match_self code_inject)
    }.

End SelfSimulation.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.

Require Import compcert.common.AST.
Require Import compcert.common.Values.

Require Import VST.sepcomp.extspec.
Require Import VST.sepcomp.semantics.
Require Import VST.sepcomp.semantics_lemmas.

Definition has_opttyp (v : option val) (t : option typ) :=
  match v, t with
    None, None => True
  | Some v, Some t => Val.has_type v t
  | _, _ => False
  end.

Section safety.
  Context {G C M Z:Type}.
  Context {genv_symb: G -> PTree.t block}.
  Context {Hrel: nat -> M -> M -> Prop}.
  Context (Hcore:@CoreSemantics G C M).
  Variable (Hspec:external_specification M external_function Z).

  Variable ge : G.

  Inductive safeN_ : nat -> Z -> C -> M -> Prop :=
  | safeN_0: forall z c m, safeN_ O z c m
  | safeN_step:
      forall n z c m c' m',
      corestep Hcore ge c m c' m' ->
      safeN_ n z c' m' ->
      safeN_ (S n) z c m
  | safeN_external:
      forall n z c m e args x,
      at_external Hcore c = Some (e,args) ->
      ext_spec_pre Hspec e x (genv_symb ge) (sig_args (ef_sig e)) args z m ->
      (forall ret m' z' n'
         (Hargsty : Val.has_type_list args (sig_args (ef_sig e)))
         (Hretty : has_opttyp ret (sig_res (ef_sig e))),
         (n' <= n)%nat ->
         Hrel n' m m' ->
         ext_spec_post Hspec e x (genv_symb ge) (sig_res (ef_sig e)) ret z' m' ->
         exists c',
           after_external Hcore ret c = Some c' /\
           safeN_ n' z' c' m') ->
      safeN_ (S n) z c m
  | safeN_halted:
      forall n z c m i,
      halted Hcore c = Some i ->
      ext_spec_exit Hspec (Some i) z m ->
      safeN_ n z c m.

  Definition corestep_fun  :=
       forall ge m q m1 q1 m2 q2 ,
       corestep Hcore ge q m q1 m1 ->
       corestep Hcore ge q m q2 m2 ->
       (q1, m1) = (q2, m2).

  Lemma safe_corestep_forward:
     corestep_fun ->
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN_ (S n) z c m -> safeN_ n z c' m'.
  Proof.
    simpl; intros; inv H1.
    assert ((c',m') = (c'0,m'0)) by (eapply H; eauto).
    inv H1; auto.
    erewrite corestep_not_at_external in H3; eauto; congruence.
    erewrite corestep_not_halted in H2; eauto; congruence.
  Qed.

  Lemma safe_corestep_backward:
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN_ n z c' m' -> safeN_ (S n) z c m.
  Proof.
    intros; eapply safeN_step; eauto.
  Qed.

  Lemma safe_downward1 :
    forall n c m z,
      safeN_ (S n) z c m -> safeN_ n z c m.
  Proof.
    induction n. econstructor; eauto.
    intros c m z H. inv H.
    + econstructor; eauto.
    + eapply safeN_external; eauto.
    + eapply safeN_halted; eauto.
  Qed.

  Lemma safe_downward :
    forall n n' c m z,
      le n' n ->
      safeN_ n z c m -> safeN_ n' z c m.
  Proof.
    do 6 intro. revert c m z. induction H; auto.
    intros. apply IHle. apply safe_downward1. auto.
  Qed.

  Lemma safe_corestepN_forward:
    corestep_fun ->
    forall z c m c' m' n n0,
      corestepN Hcore ge n0 c m c' m' ->
      safeN_ (n + S n0) z c m ->
      safeN_ n z c' m'.
  Proof.
    intros.
    revert c m c' m' n H0 H1.
    induction n0; intros; auto.
    simpl in H0; inv H0.
    eapply safe_downward in H1; eauto. omega.
    simpl in H0. destruct H0 as [c2 [m2 [STEP STEPN]]].
    apply (IHn0 _ _ _ _ n STEPN).
    assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
    rewrite Heq in H1.
    eapply safe_corestep_forward in H1; eauto.
  Qed.

  Lemma safe_step'_back2 :
    forall
      {ora st m st' m' n},
      corestep Hcore ge st m st' m' ->
      safeN_ (n-1) ora st' m' ->
      safeN_ n ora st m.
  Proof.
    intros.
    destruct n.
    constructor.
    simpl in H0. replace (n-0)%nat with n in H0.
    eapply safe_corestep_backward; eauto.
    omega.
  Qed.

  Lemma safe_corestepN_backward:
    forall z c m c' m' n n0,
      corestepN Hcore ge n0 c m c' m' ->
      safeN_ (n - n0) z c' m' ->
      safeN_ n z c m.
  Proof.
    simpl; intros.
    revert c m c' m' n H H0.
    induction n0; intros; auto.
    simpl in H; inv H.
    solve[assert (Heq: (n = n - 0)%nat) by omega; rewrite Heq; auto].
    simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
    assert (H: safeN_ (n - 1 - n0) z c' m').
    eapply safe_downward in H0; eauto. omega.
    specialize (IHn0 _ _ _ _ (n - 1)%nat STEPN H).
    solve[eapply safe_step'_back2; eauto].
  Qed.

  Lemma convergent_controls_safe :
    forall m q1 q2,
      (at_external Hcore q1 = at_external Hcore q2) ->
      (forall ret q', after_external Hcore ret q1 = Some q' ->
                      after_external Hcore ret q2 = Some q') ->
      (halted Hcore q1 = halted Hcore q2) ->
      (forall q' m', corestep Hcore ge q1 m q' m' ->
                     corestep Hcore ge q2 m q' m') ->
      (forall n z, safeN_ n z q1 m -> safeN_ n z q2 m).
  Proof.
    intros. destruct n; simpl in *; try constructor.
    inv H3.
    + econstructor; eauto.
    + eapply safeN_external; eauto.
      rewrite <-H; auto.
      intros ???? Hargsty Hretty ? H8 H9.
      specialize (H7 _ _ _ _ Hargsty Hretty H3 H8 H9).
      destruct H7 as [c' [? ?]].
      exists c'; split; auto.
    + eapply safeN_halted; eauto.
      rewrite <-H1; auto.
  Qed.

  Lemma wlog_safeN_gt0 : forall
    n z q m,
    (lt 0 n -> safeN_ n z q m) ->
    safeN_ n z q m.
  Proof.
    intros. destruct n. constructor.
    apply H. omega.
  Qed.

End safety.

Section dry_safety.
  Context {G C M Z:Type}.
  Context {genv_symb: G -> PTree.t block}.
  Context (Hcore:@CoreSemantics G C M).
  Variable (Hspec:external_specification M external_function Z).
  Definition dry_safeN := @safeN_ G C M Z genv_symb (fun n' m m' => True) Hcore Hspec.
End dry_safety.


From iris.proofmode Require Import base tactics classes.
From iris.base_logic.lib Require Export fancy_updates.
From iris.program_logic Require Export language.
(* FIXME: If we import iris.bi.weakestpre earlier texan triples do not
   get pretty-printed correctly. *)
From iris.bi Require Export weakestpre.
From iris.prelude Require Import options.
Import uPred.

Class irisG (Λ : language) (Σ : gFunctors) := IrisG {
  iris_invG :> invG Σ;

  (** The state interpretation is an invariant that should hold in between each
  step of reduction. Here [Λstate] is the global state, [list Λobservation] are
  the remaining observations, and [nat] is the number of forked-off threads
  (not the total number of threads, which is one higher because there is always
  a main thread). *)
  state_interp : state Λ → list (observation Λ) → nat → iProp Σ;

  (** A fixed postcondition for any forked-off thread. For most languages, e.g.
  heap_lang, this will simply be [True]. However, it is useful if one wants to
  keep track of resources precisely, as in e.g. Iron. *)
  fork_post : val Λ → iProp Σ;
}.
Global Opaque iris_invG.

Definition wp_pre `{!irisG Λ Σ} (s : stuckness)
    (wp : coPset -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ) :
    coPset -d> expr Λ -d> (val Λ -d> iPropO Σ) -d> iPropO Σ := λ E e1 Φ,
  match to_val e1 with
  | Some v => |={E}=> Φ v
  | None => ∀ σ1 κ κs n,
     state_interp σ1 (κ ++ κs) n ={E,∅}=∗
       ⌜if s is NotStuck then reducible e1 σ1 else True⌝ ∗
       ∀ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅}=∗ ▷ |={∅,E}=>
         state_interp σ2 κs (length efs + n) ∗
         wp E e2 Φ ∗
         [∗ list] i ↦ ef ∈ efs, wp ⊤ ef fork_post
  end%I.

Local Instance wp_pre_contractive `{!irisG Λ Σ} s : Contractive (wp_pre s).
Proof.
  rewrite /wp_pre=> n wp wp' Hwp E e1 Φ.
  repeat (f_contractive || f_equiv); apply Hwp.
Qed.

Definition wp_def `{!irisG Λ Σ} : Wp Λ (iProp Σ) stuckness :=
  λ s : stuckness, fixpoint (wp_pre s).
Definition wp_aux : seal (@wp_def). Proof. by eexists. Qed.
Definition wp' := wp_aux.(unseal).
Global Arguments wp' {Λ Σ _}.
Existing Instance wp'.
Lemma wp_eq `{!irisG Λ Σ} : wp = @wp_def Λ Σ _.
Proof. rewrite -wp_aux.(seal_eq) //. Qed.

Section wp.
Context `{!irisG Λ Σ}.
Implicit Types s : stuckness.
Implicit Types P : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.

(* Weakest pre *)
Lemma wp_unfold s E e Φ :
  WP e @ s; E {{ Φ }} ⊣⊢ wp_pre s (wp (PROP:=iProp Σ) s) E e Φ.
Proof. rewrite wp_eq. apply (fixpoint_unfold (wp_pre s)). Qed.

Global Instance wp_ne s E e n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (wp (PROP:=iProp Σ) s E e).
Proof.
  revert e. induction (lt_wf n) as [n _ IH]=> e Φ Ψ HΦ.
  rewrite !wp_unfold /wp_pre.
  (* FIXME: figure out a way to properly automate this proof *)
  (* FIXME: reflexivity, as being called many times by f_equiv and f_contractive
  is very slow here *)
  do 24 (f_contractive || f_equiv). apply IH; first lia.
  intros v. eapply dist_le; eauto with lia.
Qed.
Global Instance wp_proper s E e :
  Proper (pointwise_relation _ (≡) ==> (≡)) (wp (PROP:=iProp Σ) s E e).
Proof.
  by intros Φ Φ' ?; apply equiv_dist=>n; apply wp_ne=>v; apply equiv_dist.
Qed.
Global Instance wp_contractive s E e n :
  TCEq (to_val e) None →
  Proper (pointwise_relation _ (dist_later n) ==> dist n) (wp (PROP:=iProp Σ) s E e).
Proof.
  intros He Φ Ψ HΦ. rewrite !wp_unfold /wp_pre He.
  by repeat (f_contractive || f_equiv).
Qed.

Lemma wp_value_fupd' s E Φ v : WP of_val v @ s; E {{ Φ }} ⊣⊢ |={E}=> Φ v.
Proof. rewrite wp_unfold /wp_pre to_of_val. auto. Qed.

Lemma wp_strong_mono s1 s2 E1 E2 e Φ Ψ :
  s1 ⊑ s2 → E1 ⊆ E2 →
  WP e @ s1; E1 {{ Φ }} -∗ (∀ v, Φ v ={E2}=∗ Ψ v) -∗ WP e @ s2; E2 {{ Ψ }}.
Proof.
  iIntros (? HE) "H HΦ". iLöb as "IH" forall (e E1 E2 HE Φ Ψ).
  rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:?.
  { iApply ("HΦ" with "[> -]"). by iApply (fupd_mask_mono E1 _). }
  iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E2 E1) as "Hclose"; first done.
  iMod ("H" with "[$]") as "[% H]".
  iModIntro. iSplit; [by destruct s1, s2|]. iIntros (e2 σ2 efs Hstep).
  iMod ("H" with "[//]") as "H". iIntros "!> !>".
  iMod "H" as "(Hσ & H & Hefs)".
  iMod "Hclose" as "_". iModIntro. iFrame "Hσ". iSplitR "Hefs".
  - iApply ("IH" with "[//] H HΦ").
  - iApply (big_sepL_impl with "Hefs"); iIntros "!>" (k ef _).
    iIntros "H". iApply ("IH" with "[] H"); auto.
Qed.

Lemma fupd_wp s E e Φ : (|={E}=> WP e @ s; E {{ Φ }}) ⊢ WP e @ s; E {{ Φ }}.
Proof.
  rewrite wp_unfold /wp_pre. iIntros "H". destruct (to_val e) as [v|] eqn:?.
  { by iMod "H". }
  iIntros (σ1 κ κs n) "Hσ1". iMod "H". by iApply "H".
Qed.
Lemma wp_fupd s E e Φ : WP e @ s; E {{ v, |={E}=> Φ v }} ⊢ WP e @ s; E {{ Φ }}.
Proof. iIntros "H". iApply (wp_strong_mono s s E with "H"); auto. Qed.

Lemma wp_atomic s E1 E2 e Φ `{!Atomic (stuckness_to_atomicity s) e} :
  (|={E1,E2}=> WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }}) ⊢ WP e @ s; E1 {{ Φ }}.
Proof.
  iIntros "H". rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { by iDestruct "H" as ">>> $". }
  iIntros (σ1 κ κs n) "Hσ". iMod "H". iMod ("H" $! σ1 with "Hσ") as "[$ H]".
  iModIntro. iIntros (e2 σ2 efs Hstep).
  iMod ("H" with "[//]") as "H". iIntros "!>!>".
  iMod "H" as "(Hσ & H & Hefs)". destruct s.
  - rewrite !wp_unfold /wp_pre. destruct (to_val e2) as [v2|] eqn:He2.
    + iDestruct "H" as ">> $". by iFrame.
    + iMod ("H" $! _ [] with "[$]") as "[H _]". iDestruct "H" as %(? & ? & ? & ? & ?).
      by edestruct (atomic _ _ _ _ _ Hstep).
  - destruct (atomic _ _ _ _ _ Hstep) as [v <-%of_to_val].
    rewrite wp_value_fupd'. iMod "H" as ">H".
    iModIntro. iFrame "Hσ Hefs". by iApply wp_value_fupd'.
Qed.

Lemma wp_step_fupd s E1 E2 e P Φ :
  TCEq (to_val e) None → E2 ⊆ E1 →
  (|={E1}[E2]▷=> P) -∗ WP e @ s; E2 {{ v, P ={E1}=∗ Φ v }} -∗ WP e @ s; E1 {{ Φ }}.
Proof.
  rewrite !wp_unfold /wp_pre. iIntros (-> ?) "HR H".
  iIntros (σ1 κ κs n) "Hσ". iMod "HR". iMod ("H" with "[$]") as "[$ H]".
  iIntros "!>" (e2 σ2 efs Hstep). iMod ("H" $! e2 σ2 efs with "[% //]") as "H".
  iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
  iMod "HR". iModIntro. iFrame "Hσ Hefs".
  iApply (wp_strong_mono s s E2 with "H"); [done..|].
  iIntros (v) "H". by iApply "H".
Qed.

Lemma wp_bind K `{!LanguageCtx K} s E e Φ :
  WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }} ⊢ WP K e @ s; E {{ Φ }}.
Proof.
  iIntros "H". iLöb as "IH" forall (E e Φ). rewrite wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { apply of_to_val in He as <-. by iApply fupd_wp. }
  rewrite wp_unfold /wp_pre fill_not_val //.
  iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
  { destruct s; eauto using reducible_fill. }
  iIntros (e2 σ2 efs Hstep).
  destruct (fill_step_inv e σ1 κ e2 σ2 efs) as (e2'&->&?); auto.
  iMod ("H" $! e2' σ2 efs with "[//]") as "H". iIntros "!>!>".
  iMod "H" as "(Hσ & H & Hefs)".
  iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.

Lemma wp_bind_inv K `{!LanguageCtx K} s E e Φ :
  WP K e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, WP K (of_val v) @ s; E {{ Φ }} }}.
Proof.
  iIntros "H". iLöb as "IH" forall (E e Φ). rewrite !wp_unfold /wp_pre.
  destruct (to_val e) as [v|] eqn:He.
  { apply of_to_val in He as <-. by rewrite !wp_unfold /wp_pre. }
  rewrite fill_not_val //.
  iIntros (σ1 κ κs n) "Hσ". iMod ("H" with "[$]") as "[% H]". iModIntro; iSplit.
  { destruct s; eauto using reducible_fill_inv. }
  iIntros (e2 σ2 efs Hstep).
  iMod ("H" $! (K e2) σ2 efs with "[]") as "H"; [by eauto using fill_step|].
  iIntros "!>!>". iMod "H" as "(Hσ & H & Hefs)".
  iModIntro. iFrame "Hσ Hefs". by iApply "IH".
Qed.

(** * Derived rules *)
Lemma wp_mono s E e Φ Ψ : (∀ v, Φ v ⊢ Ψ v) → WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
Proof.
  iIntros (HΦ) "H"; iApply (wp_strong_mono with "H"); auto.
  iIntros (v) "?". by iApply HΦ.
Qed.
Lemma wp_stuck_mono s1 s2 E e Φ :
  s1 ⊑ s2 → WP e @ s1; E {{ Φ }} ⊢ WP e @ s2; E {{ Φ }}.
Proof. iIntros (?) "H". iApply (wp_strong_mono with "H"); auto. Qed.
Lemma wp_stuck_weaken s E e Φ :
  WP e @ s; E {{ Φ }} ⊢ WP e @ E ?{{ Φ }}.
Proof. apply wp_stuck_mono. by destruct s. Qed.
Lemma wp_mask_mono s E1 E2 e Φ : E1 ⊆ E2 → WP e @ s; E1 {{ Φ }} ⊢ WP e @ s; E2 {{ Φ }}.
Proof. iIntros (?) "H"; iApply (wp_strong_mono with "H"); auto. Qed.
Global Instance wp_mono' s E e :
  Proper (pointwise_relation _ (⊢) ==> (⊢)) (wp (PROP:=iProp Σ) s E e).
Proof. by intros Φ Φ' ?; apply wp_mono. Qed.
Global Instance wp_flip_mono' s E e :
  Proper (pointwise_relation _ (flip (⊢)) ==> (flip (⊢))) (wp (PROP:=iProp Σ) s E e).
Proof. by intros Φ Φ' ?; apply wp_mono. Qed.

Lemma wp_value_fupd s E Φ e v : IntoVal e v → WP e @ s; E {{ Φ }} ⊣⊢ |={E}=> Φ v.
Proof. intros <-. by apply wp_value_fupd'. Qed.
Lemma wp_value' s E Φ v : Φ v ⊢ WP (of_val v) @ s; E {{ Φ }}.
Proof. rewrite wp_value_fupd'. auto. Qed.
Lemma wp_value s E Φ e v : IntoVal e v → Φ v ⊢ WP e @ s; E {{ Φ }}.
Proof. intros <-. apply wp_value'. Qed.

Lemma wp_frame_l s E e Φ R : R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
Proof. iIntros "[? H]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.
Lemma wp_frame_r s E e Φ R : WP e @ s; E {{ Φ }} ∗ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
Proof. iIntros "[H ?]". iApply (wp_strong_mono with "H"); auto with iFrame. Qed.

Lemma wp_frame_step_l s E1 E2 e Φ R :
  TCEq (to_val e) None → E2 ⊆ E1 →
  (|={E1}[E2]▷=> R) ∗ WP e @ s; E2 {{ Φ }} ⊢ WP e @ s; E1 {{ v, R ∗ Φ v }}.
Proof.
  iIntros (??) "[Hu Hwp]". iApply (wp_step_fupd with "Hu"); try done.
  iApply (wp_mono with "Hwp"). by iIntros (?) "$$".
Qed.
Lemma wp_frame_step_r s E1 E2 e Φ R :
  TCEq (to_val e) None → E2 ⊆ E1 →
  WP e @ s; E2 {{ Φ }} ∗ (|={E1}[E2]▷=> R) ⊢ WP e @ s; E1 {{ v, Φ v ∗ R }}.
Proof.
  rewrite [(WP _ @ _; _ {{ _ }} ∗ _)%I]comm; setoid_rewrite (comm _ _ R).
  apply wp_frame_step_l.
Qed.
Lemma wp_frame_step_l' s E e Φ R :
  TCEq (to_val e) None → ▷ R ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ v, R ∗ Φ v }}.
Proof. iIntros (?) "[??]". iApply (wp_frame_step_l s E E); try iFrame; eauto. Qed.
Lemma wp_frame_step_r' s E e Φ R :
  TCEq (to_val e) None → WP e @ s; E {{ Φ }} ∗ ▷ R ⊢ WP e @ s; E {{ v, Φ v ∗ R }}.
Proof. iIntros (?) "[??]". iApply (wp_frame_step_r s E E); try iFrame; eauto. Qed.

Lemma wp_wand s E e Φ Ψ :
  WP e @ s; E {{ Φ }} -∗ (∀ v, Φ v -∗ Ψ v) -∗ WP e @ s; E {{ Ψ }}.
Proof.
  iIntros "Hwp H". iApply (wp_strong_mono with "Hwp"); auto.
  iIntros (?) "?". by iApply "H".
Qed.
Lemma wp_wand_l s E e Φ Ψ :
  (∀ v, Φ v -∗ Ψ v) ∗ WP e @ s; E {{ Φ }} ⊢ WP e @ s; E {{ Ψ }}.
Proof. iIntros "[H Hwp]". iApply (wp_wand with "Hwp H"). Qed.
Lemma wp_wand_r s E e Φ Ψ :
  WP e @ s; E {{ Φ }} ∗ (∀ v, Φ v -∗ Ψ v) ⊢ WP e @ s; E {{ Ψ }}.
Proof. iIntros "[Hwp H]". iApply (wp_wand with "Hwp H"). Qed.
Lemma wp_frame_wand_l s E e Q Φ :
  Q ∗ WP e @ s; E {{ v, Q -∗ Φ v }} -∗ WP e @ s; E {{ Φ }}.
Proof.
  iIntros "[HQ HWP]". iApply (wp_wand with "HWP").
  iIntros (v) "HΦ". by iApply "HΦ".
Qed.

End wp.

(** Proofmode class instances *)
Section proofmode_classes.
  Context `{!irisG Λ Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val Λ → iProp Σ.

  Global Instance frame_wp p s E e R Φ Ψ :
    (∀ v, Frame p R (Φ v) (Ψ v)) →
    Frame p R (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Ψ }}).
  Proof. rewrite /Frame=> HR. rewrite wp_frame_l. apply wp_mono, HR. Qed.

  Global Instance is_except_0_wp s E e Φ : IsExcept0 (WP e @ s; E {{ Φ }}).
  Proof. by rewrite /IsExcept0 -{2}fupd_wp -except_0_fupd -fupd_intro. Qed.

  Global Instance elim_modal_bupd_wp p s E e P Φ :
    ElimModal True p false (|==> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      (bupd_fupd E) fupd_frame_r wand_elim_r fupd_wp.
  Qed.

  Global Instance elim_modal_fupd_wp p s E e P Φ :
    ElimModal True p false (|={E}=> P) P (WP e @ s; E {{ Φ }}) (WP e @ s; E {{ Φ }}).
  Proof.
    by rewrite /ElimModal intuitionistically_if_elim
      fupd_frame_r wand_elim_r fupd_wp.
  Qed.

  Global Instance elim_modal_fupd_wp_atomic p s E1 E2 e P Φ :
    ElimModal (Atomic (stuckness_to_atomicity s) e) p false
            (|={E1,E2}=> P) P
            (WP e @ s; E1 {{ Φ }}) (WP e @ s; E2 {{ v, |={E2,E1}=> Φ v }})%I | 100.
  Proof.
    intros ?. by rewrite intuitionistically_if_elim
      fupd_frame_r wand_elim_r wp_atomic.
  Qed.

  Global Instance add_modal_fupd_wp s E e P Φ :
    AddModal (|={E}=> P) P (WP e @ s; E {{ Φ }}).
  Proof. by rewrite /AddModal fupd_frame_r wand_elim_r fupd_wp. Qed.

  Global Instance elim_acc_wp_atomic {X} E1 E2 α β γ e s Φ :
    ElimAcc (X:=X) (Atomic (stuckness_to_atomicity s) e)
            (fupd E1 E2) (fupd E2 E1)
            α β γ (WP e @ s; E1 {{ Φ }})
            (λ x, WP e @ s; E2 {{ v, |={E2}=> β x ∗ (γ x -∗? Φ v) }})%I | 100.
  Proof.
    iIntros (?) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
    iApply (wp_wand with "(Hinner Hα)").
    iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
  Qed.

  Global Instance elim_acc_wp_nonatomic {X} E α β γ e s Φ :
    ElimAcc (X:=X) True (fupd E E) (fupd E E)
            α β γ (WP e @ s; E {{ Φ }})
            (λ x, WP e @ s; E {{ v, |={E}=> β x ∗ (γ x -∗? Φ v) }})%I.
  Proof.
    iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
    iApply wp_fupd.
    iApply (wp_wand with "(Hinner Hα)").
    iIntros (v) ">[Hβ HΦ]". iApply "HΦ". by iApply "Hclose".
  Qed.
End proofmode_classes.


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

Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj1synthconj5 : forall  (lv0 : lst), (@eq lst (lv0) lv0).
Admitted.
QuickChick conj1synthconj5.


(** 依存関数型のモジュールです。 *)

Require Googology_In_Coq.Base.

(** ライブラリを要求します。 *)

Import Googology_In_Coq.Base.

(** ライブラリを開きます。 *)

Definition Dependent_Function@{ i | } ( A : Type@{ i } ) ( B : A -> Type@{ i } ) : Type@{ i } := forall x : A, B x.
(* from: originally defined by Hexirp *)

(** 依存関数型です。 *)

Definition map_Dependent_Function@{ i j k l | } ( A : Type@{ i } ) ( B : A -> Type@{ j } ) ( C : Type@{ k } ) ( D : C -> Type@{ l } ) ( f : C -> A ) ( g : forall x : C, B ( f x ) -> D x ) ( x : forall a : A, B a ) : forall c : C, D c := fun y : C => g y ( x ( f y ) ).
(* from: originally defined by Hexirp *)

(** 依存関数型から依存関数への写像です。 *)


(*========================================================================*)
(*                                                                        *)
(*                    CompcertTSO                                         *)
(*                                                                        *)
(*          Jaroslav Sevcik, University of Cambridge                      *)
(*          Viktor Vafeiadis, University of Cambridge                     *)
(*          Francesco Zappa Nardelli, INRIA Rocquencourt                  *)
(*          Suresh Jagannathan, Purdue University                         *)
(*          Peter Sewell, University of Cambridge                         *)
(*                                                                        *)
(*          (building on CompCert 1.5 and a 1.8 pre-release)              *)
(*                                                                        *)
(*  This document and the CompCertTSO sources are copyright 2005, 2006,   *)
(*  2007, 2008, 2009, 2010, 2011 Institut National de Recherche en        *)
(*  Informatique et en Automatique (INRIA), and Suresh Jagannathan,       *)
(*  Jaroslav Sevcik, Peter Sewell and Viktor Vafeiadis.                   *)
(*                                                                        *)
(*  All rights reserved.  This file is distributed under the terms of     *)
(*  the INRIA Non-Commercial License Agreement.                           *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*========================================================================*)

Require Import Coqlib.
Require Import Integers.

(** pointers are block-id--offset pairs. *)
Inductive pointer : Type :=
  | Ptr : Z -> int -> pointer.

Definition nullptr := Ptr 0 Int.zero.

Module MPtr.

Definition block (p : pointer) : Z :=
  match p with
  | Ptr b off => b
  end.

Definition offset (p : pointer) : int :=
  match p with
  | Ptr b off => off
  end.

Definition add (p : pointer) (i : int) : pointer :=
  match p with
  | Ptr b off => Ptr b (Int.add off i)
  end.

Definition sub_int (p : pointer) (i : int) : pointer :=
  match p with
  | Ptr b off => Ptr b (Int.sub off i)
  end.

Definition sub_ptr (p1 p2 : pointer) : option int :=
  match p1, p2 with
  | Ptr b1 off1, Ptr b2 off2 =>
    if zeq b1 b2
      then Some(Int.sub off1 off2)
      else None
  end.

Definition eq_dec (p q : pointer) : { p = q } + {p <> q}.
Proof.
  decide equality. apply Int.eq_dec. apply Z_eq_dec.
Defined.

Definition eq (p q : pointer) : bool :=
  if (eq_dec p q) then true else false.

Lemma eq_true:
  forall (A: Type) (x: pointer) (a b: A), (if eq x x then a else b) = a.
Proof.
  by intros; unfold eq; case eq_dec.
Qed.

Lemma eq_false:
  forall (A: Type) (x y: pointer) (a b: A),
    x <> y -> (if eq x y then a else b) = b.
Proof.
  by intros; unfold eq; case eq_dec.
Qed.

Lemma eq_sym:
  forall x y, eq x y = eq y x.
Proof.
  intros; unfold eq.
  case (eq_dec x y); case (eq_dec y x); auto.
  intros H1 H2. elim H1. auto.
Qed.

(** Signed comparison *)

Definition lt_bool (p1 p2 : pointer) : bool :=
  match p1, p2 with
  | Ptr b1 off1, Ptr b2 off2 =>
    if zlt b1 b2
    then true
    else if zeq b1 b2
         then Int.lt off1 off2
         else false
  end.

Definition lt (p1 p2 : pointer) : bool3 :=
  match p1, p2 with
  | Ptr b1 off1, Ptr b2 off2 =>
    if zeq b1 b2 then bool2bool3 (Int.lt off1 off2)
                 else b3_unknown
  end.

Definition cmp (c: comparison) (x y : pointer) : bool3 :=
  match c with
  | Ceq => bool2bool3 (eq x y)
  | Cne => bool2bool3 (negb (eq x y))
  | Clt => lt x y
  | Cle => negb3 (lt y x)
  | Cgt => lt y x
  | Cge => negb3 (lt x y)
  end.

Lemma negate_cmp:
  forall c x y, cmp (negate_comparison c) x y = negb3 (cmp c x y).
Proof.
  by intros; destruct c; simpl; b3_simps.
Qed.

Lemma swap_cmp:
  forall c x y, cmp (swap_comparison c) x y = cmp c y x.
Proof.
  by intros; destruct c; simpl; auto; rewrite eq_sym.
Qed.

(** Unsigned comparison *)

Definition ltu_bool (p1 p2 : pointer) : bool :=
  match p1, p2 with
  | Ptr b1 off1, Ptr b2 off2 =>
    if zlt b1 b2
    then true
    else if zeq b1 b2
         then Int.ltu off1 off2
         else false
  end.

Definition ltu (p1 p2 : pointer) : bool3 :=
  match p1, p2 with
  | Ptr b1 off1, Ptr b2 off2 =>
    if zeq b1 b2 then bool2bool3 (Int.ltu off1 off2)
                 else b3_unknown
  end.

Definition cmpu (c: comparison) (x y : pointer) : bool3 :=
  match c with
  | Ceq => bool2bool3 (eq x y)
  | Cne => bool2bool3 (negb (eq x y))
  | Clt => ltu x y
  | Cle => negb3 (ltu y x)
  | Cgt => ltu y x
  | Cge => negb3 (ltu x y)
  end.

Lemma negate_cmpu:
  forall c x y, cmpu (negate_comparison c) x y = negb3 (cmpu c x y).
Proof.
  by intros; destruct c; simpl; b3_simps.
Qed.

Lemma swap_cmpu:
  forall c x y, cmpu (swap_comparison c) x y = cmpu c y x.
Proof.
  by intros; destruct c; simpl; auto; rewrite eq_sym.
Qed.

Lemma add_zero_r: forall p,
  MPtr.add p Int.zero = p.
Proof.
  by intros; destruct p; simpl; rewrite Int.add_zero.
Qed.

Lemma add_add_r: forall p n1 n2,
  MPtr.add p (Int.add n1 n2) = MPtr.add (MPtr.add p n1) n2.
Proof.
  by intros; destruct p; simpl; rewrite Int.add_assoc.
Qed.

Lemma add_sub_r: forall p n1 n2,
  MPtr.add p (Int.sub n1 n2) = MPtr.add (MPtr.sub_int p n2) n1.
Proof.
  intros; destruct p; simpl.
  by rewrite <- Int.sub_add_l, (Int.add_commut _ n1),
            Int.sub_add_l, Int.add_commut.
Qed.

Lemma add_add_l: forall p n1 n2,
  MPtr.add (MPtr.add p n1) n2 = MPtr.add p (Int.add n1 n2).
Proof.
  by symmetry; apply add_add_r.
Qed.

Lemma add_sub_l: forall p n1 n2,
  MPtr.add (MPtr.sub_int p n2) n1 = MPtr.add p (Int.sub n1 n2).
Proof.
  by symmetry; apply add_sub_r.
Qed.

Lemma sub_zero_r: forall p,
  MPtr.sub_int p Int.zero = p.
Proof.
  by intros; destruct p; simpl; rewrite Int.sub_zero_r.
Qed.

Lemma sub_add_r: forall p n1 n2,
  MPtr.sub_int p (Int.add n1 n2) = MPtr.sub_int (MPtr.sub_int p n1) n2.
Proof.
  intros; destruct p; simpl.
  by rewrite !Int.sub_add_opp, !Int.neg_add_distr, Int.add_assoc.
Qed.

Lemma sub_sub_r: forall p n1 n2,
  MPtr.sub_int p (Int.sub n1 n2) = MPtr.add (MPtr.sub_int p n1) n2.
Proof.
  intros; destruct p; simpl.
  by rewrite !Int.sub_add_opp, !Int.neg_add_distr, !Int.neg_involutive, Int.add_assoc.
Qed.

Lemma sub_add_l: forall p n1 n2,
  MPtr.sub_int (MPtr.add p n1) n2 = MPtr.add p (Int.sub n1 n2).
Proof.
  by intros; destruct p; simpl; rewrite !Int.sub_add_opp, Int.add_assoc.
Qed.

Lemma sub_sub_l: forall p n1 n2,
  MPtr.sub_int (MPtr.sub_int p n1) n2 = MPtr.sub_int p (Int.add n1 n2).
Proof.
  by symmetry; apply sub_add_r.
Qed.

End MPtr.

Bind Scope pointer_scope with pointer.

Notation "p + i" := (MPtr.add p i) : pointer_scope.

Delimit Scope pointer_scope with pointer.