Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import Poulet4.P4light.Architecture.Tofino.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.count.common.
Require Import ProD3.examples.count.ModelRepr.
Require Import Hammer.Plugin.Hammer.
Require Export Coq.Program.Program.
Import ListNotations.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition p := ["pipe"; "ingress"].

Open Scope func_spec.

Definition regact_counter_apply_body :=
  ltac:(auto_regact ge am_ge (p ++ ["regact_counter"])).

Definition regact_counter_execute_body :=
  ltac:(build_execute_body ge regact_counter_apply_body).

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply regact_counter_execute_body) : func_specs.

Definition counter_act_fundef :=
  ltac:(get_fd ["SwitchIngress"; "act_counter"] ge).

Definition counter_act_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ig_md"]]) [p]
    WITH (counter : Z),
      PRE
        (ARG []
        (MEM [(["ig_md"], ValBaseStruct [("num_pkt", P4Bit_ 32)])]
        (EXT [counter_repr p counter])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ig_md"], ValBaseStruct [("num_pkt", P4Bit 32 (counter + 1))])]
        (EXT [counter_repr p (counter + 1)]))).

Lemma counter_act_body:
  func_sound ge counter_act_fundef nil counter_act_spec.
Proof.
  start_function.
  unfold counter_repr, counter_reg_repr.
  normalize_EXT.
  Intros_prop. simpl.
  step_call regact_counter_execute_body;
    [entailer | list_solve | lia | reflexivity |].
  step.
  entailer.
  repeat intro. hnf. simpl. lia.
Qed.

Definition tbl_counter_fd :=
  ltac:(get_fd ["SwitchIngress"; "tbl_counter"; "apply"] ge).

Definition tbl_counter_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ig_md"]]) [p]
    WITH (counter : Z),
      PRE
        (ARG []
        (MEM [(["ig_md"], ValBaseStruct [("num_pkt", P4Bit_ 32)])]
        (EXT [counter_repr p counter])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ig_md"], ValBaseStruct [("num_pkt", P4Bit 32 (counter + 1))])]
        (EXT [counter_repr p (counter + 1)]))))%arg_ret_assr.

Lemma tbl_counter_body:
  func_sound ge tbl_counter_fd nil tbl_counter_spec.
Proof.
  start_function.
  table_action counter_act_body.
  { entailer. }
  { entailer. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_counter_body) : func_specs.

Definition Ingress_fd :=
  ltac:(get_fd ["SwitchIngress"; "apply"] ge).

Definition header_t: P4Type := ltac:(get_type "header_t" ge).
Definition metadata_t: P4Type := ltac:(get_type "metadata_t" ge).
Definition ingress_intrinsic_metadata_t: P4Type :=
  ltac:(get_type "ingress_intrinsic_metadata_t" ge).
Definition ingress_intrinsic_metadata_from_parser_t: P4Type :=
  ltac:(get_type "ingress_intrinsic_metadata_from_parser_t" ge).
Definition ingress_intrinsic_metadata_for_deparser_t: P4Type :=
  ltac:(get_type "ingress_intrinsic_metadata_for_deparser_t" ge).
Definition ingress_intrinsic_metadata_for_tm_t: P4Type :=
  ltac:(get_type "ingress_intrinsic_metadata_for_tm_t" ge).

Definition Ingress_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD None [p]
    WITH (counter : Z) (dprsr_md: Sval),
      PRE
        (ARG [force ValBaseNull (uninit_sval_of_typ None header_t);
              force ValBaseNull (uninit_sval_of_typ None metadata_t);
              force ValBaseNull (uninit_sval_of_typ None ingress_intrinsic_metadata_t);
              force ValBaseNull (uninit_sval_of_typ None ingress_intrinsic_metadata_from_parser_t);
              dprsr_md;
              force ValBaseNull (uninit_sval_of_typ None ingress_intrinsic_metadata_for_tm_t)
           ]
        (MEM []
        (EXT [counter_repr p counter])))
      POST
        (ARG_RET [force ValBaseNull (uninit_sval_of_typ None header_t);
                  ValBaseStruct [("num_pkt", P4Bit 32 (counter + 1))];
                  if (Z.eqb ((counter + 1) mod 1024) 0) then
                    (update "digest_type" (P4Bit 3 1) dprsr_md)
                  else dprsr_md;
                  force ValBaseNull (uninit_sval_of_typ None ingress_intrinsic_metadata_for_tm_t)
         ] ValBaseNull
        (MEM []
        (EXT [counter_repr p (counter + 1)]))).

Lemma Ingress_body:
  func_sound ge Ingress_fd nil Ingress_spec.
Proof.
  start_function.
  step_call tbl_counter_body.
  { entailer. }
  Intros _.
  step_if; simpl abs_eq in H;
    replace (Pos.to_nat 9) with (N.to_nat (10 - 1)) in H by lia;
    rewrite bitstring_slice_lower_bit in H by lia; rewrite abs_eq_bit in H;
    unfold P4Arith.BitArith.mod_bound, P4Arith.BitArith.upper_bound in H;
    rewrite Zmod_0_l in H; change (2 ^ Z.of_N 10) with 1024 in H; simpl in H;
    destruct ((counter + 1) mod 1024 =? 0); try now exfalso.
  - step. step. step. entailer.
  - step. step. entailer.
Qed.


From iris.base_logic.lib Require Export invariants.
From aneris.aneris_lang Require Import lang tactics proofmode.

Definition coin_flip : val :=
  λ: <>, let: "l" := ref #true in Fork ("l" <- #false);; !"l".

Section proof.
  Context `{!anerisG Mdl Σ}.

  Lemma coin_flip_spec ip :
    {{{ True }}} coin_flip #() @[ip] {{{ (b : bool), RET #b; True }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam. wp_alloc l as "Hl". wp_let.
    pose proof (nroot .@ "rnd") as rndN.
    iMod (inv_alloc rndN _ (∃ (b : bool), l ↦[ip] #b)%I with "[Hl]") as "#Hinv";
      first by eauto.
    wp_apply aneris_wp_fork; iSplitL.
    - iModIntro. wp_seq. iInv rndN as (?) "?". wp_load.
      iSplitR "HΦ"; first by eauto. by iApply "HΦ".
    - iModIntro. iInv rndN as (?) "?". wp_store; eauto.
  Qed.

End proof.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys.

Lemma defines_only_universes_eq_L :
  forall ts : candidate-type-system,
  forall T T1 T2 eq1 eq2,
    type_system ts
    -> defines_only_universes ts
    -> ts T T2 eq2
    -> per_eq (close ts) T T1 eq1
    -> False.
Proof.
  intros.
  allunfold defines_only_universes.
  assert (ts T T eq2) by (apply type_system_type_mem with (T' := T2); allunfold type_system; sp).
  apply_in_hyp p; close_diff.
Qed.

Lemma defines_only_universes_eq_LR :
  forall ts : candidate-type-system,
  forall T T1 T2 eq1 eq2,
    type_system ts
    -> defines_only_universes ts
    -> ts T2 T eq2
    -> per_eq (close ts) T T1 eq1
    -> False.
Proof.
  intros.
  allunfold defines_only_universes.
  assert (ts T T eq2) by (apply type_system_type_mem with (T' := T2); allunfold type_system; sp).
  apply_in_hyp p; close_diff.
Qed.

Lemma defines_only_universes_eq_R :
  forall ts : candidate-type-system,
  forall T T1 T2 eq1 eq2,
    type_system ts
    -> defines_only_universes ts
    -> ts T T2 eq2
    -> per_eq (close ts) T1 T eq1
    -> False.
Proof.
  intros.
  allunfold defines_only_universes.
  assert (ts T T eq2) by (apply type_system_type_mem with (T' := T2); allunfold type_system; sp).
  apply_in_hyp p; close_diff.
Qed.

Lemma defines_only_universes_eq_RR :
  forall ts : candidate-type-system,
  forall T T1 T2 eq1 eq2,
    type_system ts
    -> defines_only_universes ts
    -> ts T2 T eq2
    -> per_eq (close ts) T1 T eq1
    -> False.
Proof.
  intros.
  allunfold defines_only_universes.
  assert (ts T T eq2) by (apply type_system_type_mem with (T' := T2); allunfold type_system; sp).
  apply_in_hyp p; close_diff.
Qed.

Lemma close_type_system_eq :
  forall ts : candidate-type-system,
    type_system ts
    -> is_type_system (per_eq ts).
Proof.
  introv tysys.
  unfold is_type_system; introv pereq.
  unfold per_eq in pereq; exrepnd.
  unfold type_system_props; dands.

  - unfold uniquely_valued_body.
    introv pereq'.
    allunfold per_eq; exrepnd.
    spcast; repeat computes_to_eqval.
    unfold eq_term_equals; introv.
    rw pereq0.
    rw pereq'0.
    onedts uv tye tys tyt tyvr tes tet tevr.
    generalize (uv A B eqa eqa0); intro k; repeat (dest_imp k hyp).
    rw k; sp.

  - unfold type_extensionality_body; introv teq.
    unfold per_eq.
    exists A B a1 a2 b1 b2 eqa; sp.
    rw <- teq.
    rw pereq0; sp.

  - unfold type_symmetric_body; introv.
    unfold per_eq.

    generalize (type_system_ts_refl ts A B eqa); introv r;
    repeat (dest_imp r hyp); repnd.

    assert (term_equality_symmetric eqa)
      as eqs
        by (onedts uv tye tys tyt tyvr tes tet tevr; apply (tes A B eqa); sp).

    assert (term_equality_transitive eqa)
      as eqt
        by (onedts uv tye tys tyt tyvr tes tet tevr; apply (tet A B eqa); sp).

    assert (term_equality_respecting eqa)
      as eqc
        by (onedts uv tye tys tyt tyvr tes tet tevr; apply (tevr A eqa); sp).

    exists B A b1 b2 a1 a2 eqa; sp.
    onedts uv tye tys tyt tyvr tes tet tevr.
    generalize (tys A B eqa); intro k; dest_imp k hyp.
    apply eqorsq_sym; sp.
    apply eqorsq_sym; sp.
    rw pereq0; split; sp.

    apply eqorsq_commutes with (a := a1) (c := a2); sp.

    apply eqorsq_commutes with (a := b1) (c := b2); sp;
    apply eqorsq_sym; sp.

  - unfold type_transitive_body; introv pereq.
    unfold per_eq in pereq; exrepnd.
    spcast; repeat computes_to_eqval.
    unfold per_eq.

    assert (eq_term_equals eqa eqa0)
      as eqt
        by (apply uniquely_valued_eq2_ts with (ts := ts) (T := B) (T1 := A) (T2 := B0); sp).

    exists A B0 a1 a2 b0 b3 eqa; sp.

Qed.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import PeanoNat.
Require Import Psatz. (* lia tactic for linear integer arithmetic *)

Require Export Parser.FocusedSyntaxDerive.
Require Export Parser.HasConflictFun.

Opaque unfocus_helper.
Opaque should_not_follow_fun.
Opaque locate.

Opaque FocusedSyntaxDerive.derive_obligation_1.
Opaque FocusedSyntaxDerive.derive_obligation_2.

Lemma should_not_follow_fun_unfocus_monotone:
  forall A T (ls: Layers T A) k core1 core2,
    In k (should_not_follow_fun (unfocus_helper ls core1)) ->
    (forall ts v, matches core1 ts v -> exists ts' v', matches core2 ts' v') ->
    (forall k, In k (should_not_follow_fun core1) -> In k (should_not_follow_fun core2)) ->
    In k (should_not_follow_fun (unfocus_helper ls core2)).
Proof.
  induction ls; lights; destruct_layer; unfocus_helper_def; eapply IHls; eauto;
    repeat light || invert_matches ||
           match goal with
           | H1: forall _ _, _ -> _, H2: matches _ _ _ |- _ => pose proof (H1 _ _ H2); clear H1
           end;
    eauto with matches;
    eauto with should_not_follow_fun;
    eauto using should_not_follow_fun_seq_monotone_l.
Qed.

Lemma should_not_follow_fun_plug_subset:
  forall A T (ls: Layers T A) (v: T) core k ts0 v0,
    matches core ts0 v0 ->
    In k (should_not_follow_fun (unfocus (plug ls v))) ->
    In k (should_not_follow_fun (unfocus_helper ls core)).
Proof.
  induction ls;
    repeat light || unfocus_helper_def || plug_def ||
           unfold unfocus in * || destruct_layer || apply_anywhere should_not_follow_fun_eps_seq2;
    eauto using should_not_follow_fun_epsilon with exfalso matches.

  eapply should_not_follow_fun_unfocus_monotone; eauto;
    repeat light || invert_matches || invert_constructor_equalities;
    eauto with matches.

  eapply should_not_follow_fun_seq_monotone_l;
    eauto using should_not_follow_fun_epsilon with exfalso matches.
Qed.

Lemma should_not_follow_fun_locate_subset_helper:
  forall n A (fs fs': Focused_Syntax A) k1 k2,
    length (layers fs) + count_follow_by (layers fs) < n ->
    locate k1 fs = Some fs' ->
    In k2 (should_not_follow_fun (unfocus fs')) ->
    In k2 (should_not_follow_fun (unfocus fs)).
Proof.
  unfold unfocus; induction n; destruct fs; intros; try lia.

  locate_def; repeat light || destruct_match || invert_constructor_equalities.

  unshelve epose proof (IHn _ _ _ _ _ _ H0 H1);
    repeat light || nullable_fun_spec;
    try solve [ pose proof (plug_count_follow_by _ _ layers i); lights; eauto with lia ];
    eauto using should_not_follow_fun_plug_subset with eapply_any.
Qed.

Lemma should_not_follow_fun_locate_subset:
  forall A (fs fs': Focused_Syntax A) k1 k2,
    locate k1 fs = Some fs' ->
    In k2 (should_not_follow_fun (unfocus fs')) ->
    In k2 (should_not_follow_fun (unfocus fs)).
Proof.
  eauto using should_not_follow_fun_locate_subset_helper.
Qed.

Lemma should_not_follow_fun_pierce_helper_subset_helper:
  forall m A T (ls: Layers A T) core t k gv pre,
    (List.length vars - List.length gv, syntax_size core) = m ->
    In k (should_not_follow_fun (unfocus_helper (pierce_helper (get_kind t) core ls gv pre) (Epsilon t))) ->
    In k (should_not_follow_fun (unfocus_helper ls core)).
Proof.
  induction m using measure_induction; destruct core;
    repeat light || pierce_helper_def || find_false || unfocus_helper_def || destruct_match.

  - eapply should_not_follow_fun_unfocus_monotone; eauto;
      repeat light;
      eauto with matches;
      eauto using should_not_follow_fun_epsilon with exfalso.

  - apply should_not_follow_fun_unfocus_monotone with core1; lights;
      eauto with matches;
      eauto with should_not_follow_fun;
      eauto with lex;
      try solve [ eapply_any; eauto; eauto with lex has_conflict_ind ].

  - apply should_not_follow_fun_unfocus_monotone with core2; lights;
      eauto with matches;
      eauto with should_not_follow_fun;
      eauto with lex;
      try solve [ eapply_any; eauto; eauto with lex has_conflict_ind ].

  - unshelve epose proof (H _ _ _ _ _ _ _ _ _ _ eq_refl H1);
      repeat light || unfocus_helper_def; try lex.

  - pose proof i as ip.
    repeat light || options || destruct_match.
    destruct (nullable_fun core1) eqn:N in ip; lights.
    pose proof (nullable_fun_some _ _ _ N).

    unshelve epose proof (H _ _ _ _ _ _ _ _ _ _ eq_refl H1) as IH;
      repeat light || unfocus_helper_def || options || destruct_match || clear_some_dec; try lex.

    revert IH.
    generalize i.
    generalize (FocusedSyntaxPierce.pierce_helper'_obligations_obligation_9 A B
                          (get_kind t) core1 core2 gv pre).
    rewrite N;
      lights.

    eapply should_not_follow_fun_unfocus_monotone; eauto;
      repeat light || invert_matches;
      eauto with matches;
      eauto with should_not_follow_fun.

  - unshelve epose proof (H _ _ _ _ _ _ _ _ _ _ eq_refl H1) as IH;
      repeat light || unfocus_helper_def || options || destruct_match || clear_some_dec; try lex.

  - unshelve epose proof (H _ _ _ _ _ _ _ _ _ _ eq_refl H1) as IH;
      repeat light || unfocus_helper_def || options || destruct_match || clear_some_dec; try lex.

  - unshelve epose proof (H _ _ _ _ _ _ _ _ _ _ eq_refl H1) as IH;
      repeat light || unfocus_helper_def || options || destruct_match || destruct_and ||
             clear_some_dec;
      try lex;
        eauto using pierce_var_measure.

    eapply should_not_follow_fun_unfocus_monotone; eauto;
      repeat light || invert_matches;
      eauto with matches;
      eauto with should_not_follow_fun.
Qed.

Lemma should_not_follow_fun_pierce_helper_subset:
  forall A T (ls: Layers A T) core t k gv pre,
    In k (should_not_follow_fun (unfocus_helper (pierce_helper (get_kind t) core ls gv pre) (Epsilon t))) ->
    In k (should_not_follow_fun (unfocus_helper ls core)).
Proof.
  eauto using should_not_follow_fun_pierce_helper_subset_helper.
Qed.

Lemma should_not_follow_fun_pierce_subset:
  forall A T (ls: Layers A T) core t k pre,
    In k (should_not_follow_fun (unfocus_helper (pierce (get_kind t) core ls pre) (Epsilon t))) ->
    In k (should_not_follow_fun (unfocus_helper ls core)).
Proof.
  unfold pierce;
    eauto using should_not_follow_fun_pierce_helper_subset.
Qed.

Lemma should_not_follow_fun_derive_subset:
  forall A (s ds: Focused_Syntax A) t k pre,
    derive s t pre = Some ds ->
    In k (should_not_follow_fun (unfocus ds)) ->
    In k (should_not_follow_fun (unfocus s)).
Proof.
  unfold derive, unfocus;
    repeat light || destruct_match || invert_constructor_equalities.

  clear matched.
  revert H0.
  generalize (FocusedSyntaxDerive.derive_obligation_2 A s t pre).
  generalize (FocusedSyntaxDerive.derive_obligation_1 A s t pre).
  repeat light || options || destruct_match.
  generalize (locate (get_kind t) s).
  destruct (locate (get_kind t) s) eqn:L;
    repeat light || invert_constructor_equalities.
  eapply should_not_follow_fun_locate_subset; eauto; unfold unfocus;
    eauto using should_not_follow_fun_pierce_subset.
Qed.

Theorem should_not_follow_fun_complete':
  forall xs A (fs: Focused_Syntax A) t ys v1 v2,
    matches (unfocus fs) xs v1 ->
    matches (unfocus fs) (xs ++ t :: ys) v2 ->
    ll1_fun (unfocus fs) = true ->
    In (get_kind t) (should_not_follow_fun (unfocus fs)).
Proof.
  unfold unfocus;
    induction xs; repeat light || apply_anywhere ll1_fun_true;
    eauto using should_not_follow_fun_first.

  unshelve epose proof (derive_complete _ fs a xs _ v1 H);
    repeat light || options || destruct_match;
    eauto using unfocus_conflict_remains;
    eauto using unfocus_conflict_remains2.

  eapply should_not_follow_fun_derive_subset; eauto; lights.
  apply IHxs with ys v1 v2; lights;
    try solve [ eapply derive_sound_remove; eauto ].

  destruct (ll1_fun (unfocus_helper (layers f) (core f))) eqn:LL1;
    repeat light || apply_anywhere ll1_fun_false || apply_anywhere derive_no_conflict_unfocus.
Qed.

Theorem should_not_follow_fun_complete:
  forall xs A (s: Syntax A) t ys v1 v2,
    matches s xs v1 ->
    matches s (xs ++ t :: ys) v2 ->
    ll1_fun s = true ->
    In (get_kind t) (should_not_follow_fun s).
Proof.
  intros.
  pose proof (unfocus_focus _ s) as HU.
  rewrite <- HU in *; eauto using should_not_follow_fun_complete'.
Qed.

Theorem should_not_follow_ind_correct:
  forall A (s: Syntax A) k,
    ll1_ind s ->
      should_not_follow_ind s k <->
      exists t ts1 ts2 v1 v2,
        get_kind t = k /\
        matches s ts1 v1 /\
        matches s (ts1 ++ t :: ts2) v2.
Proof.
  lights.
  - apply_anywhere should_not_follow_ind_sound; lights; eauto 8.
  - apply should_not_follow_ind_fun.
    apply should_not_follow_fun_complete with ts1 ts2 v1 v2; lights.
    unfold ll1_ind in *; repeat light || bools.
    destruct (ll1_fun s) eqn:LL1; lights; eauto using ll1_fun_false.
Qed.


(********************)
(********************)
(****            ****)
(****   Monads   ****)
(****            ****)
(********************)
(********************)

Require Import Coq.Logic.ProofIrrelevance.
Require Import Main.CategoryTheory.Functor.
Require Import Main.CategoryTheory.NaturalTransformation.

#[local] Set Universe Polymorphism.

(* Metavariable for monads: `M` *)

Record monad
  {C}
  {F : endofunctor C}
  (Eta : naturalTransformation idFunctor F)
  (Mu : naturalTransformation (compFunctor F F) F) :=
newMonad {
  mAssoc :
    eta (vertCompNaturalTransformation Mu (leftWhisker Mu F)) =
    eta (vertCompNaturalTransformation Mu (rightWhisker F Mu));
  mIdent1 :
    eta (vertCompNaturalTransformation Mu (leftWhisker Eta F)) =
    eta idNaturalTransformation;
  mIdent2 :
    eta (vertCompNaturalTransformation Mu (rightWhisker F Eta)) =
    eta idNaturalTransformation;
}.

#[export] Hint Resolve mAssoc : main.
#[export] Hint Resolve mIdent1 : main.
#[export] Hint Rewrite @mIdent1 : main.
#[export] Hint Resolve mIdent2 : main.
#[export] Hint Rewrite @mIdent2 : main.

Theorem eqMonad
  {C}
  {F : endofunctor C}
  (Eta : naturalTransformation idFunctor F)
  (Mu : naturalTransformation (compFunctor F F) F)
  (M1 M2 : monad Eta Mu)
: M1 = M2.
Proof.
  destruct M1.
  destruct M2.
  f_equal; apply proof_irrelevance.
Qed.

#[export] Hint Resolve eqMonad : main.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.MinMax.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

Axiom char : Type.
Parameter char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Definition word := (list char).

(* Why3 assumption *)
Inductive dist: (list char) -> (list char) -> Z -> Prop :=
  | dist_eps : (dist Init.Datatypes.nil Init.Datatypes.nil 0%Z)
  | dist_add_left : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (Init.Datatypes.cons a w1) w2
      (n + 1%Z)%Z)
  | dist_add_right : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist w1 (Init.Datatypes.cons a w2)
      (n + 1%Z)%Z)
  | dist_context : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (Init.Datatypes.cons a w1)
      (Init.Datatypes.cons a w2) n).

(* Why3 assumption *)
Definition min_dist (w1:(list char)) (w2:(list char)) (n:Z): Prop := (dist w1
  w2 n) /\ forall (m:Z), (dist w1 w2 m) -> (n <= m)%Z.

(* Why3 assumption *)
Fixpoint last_char (a:char) (u:(list char)) {struct u}: char :=
  match u with
  | Init.Datatypes.nil => a
  | (Init.Datatypes.cons c u') => (last_char c u')
  end.

(* Why3 assumption *)
Fixpoint but_last (a:char) (u:(list char)) {struct u}: (list char) :=
  match u with
  | Init.Datatypes.nil => Init.Datatypes.nil
  | (Init.Datatypes.cons c u') => (Init.Datatypes.cons a (but_last c u'))
  end.

Axiom first_last_explicit : forall (u:(list char)) (a:char),
  ((Init.Datatypes.app (but_last a u) (Init.Datatypes.cons (last_char a
  u) Init.Datatypes.nil)) = (Init.Datatypes.cons a u)).

Axiom first_last : forall (a:char) (u:(list char)), exists v:(list char),
  exists b:char,
  ((Init.Datatypes.app v (Init.Datatypes.cons b Init.Datatypes.nil)) = (Init.Datatypes.cons a u)) /\
  ((list.Length.length v) = (list.Length.length u)).

Axiom key_lemma_right : forall (w1:(list char)) (w'2:(list char)) (m:Z)
  (a:char), (dist w1 w'2 m) -> forall (w2:(list char)),
  (w'2 = (Init.Datatypes.cons a w2)) -> exists u1:(list char),
  exists v1:(list char), exists k:Z, (w1 = (Init.Datatypes.app u1 v1)) /\
  ((dist v1 w2 k) /\ ((k + (list.Length.length u1))%Z <= (m + 1%Z)%Z)%Z).

Axiom dist_symetry : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
  w2 n) -> (dist w2 w1 n).

Axiom key_lemma_left : forall (w1:(list char)) (w2:(list char)) (m:Z)
  (a:char), (dist (Init.Datatypes.cons a w1) w2 m) -> exists u2:(list char),
  exists v2:(list char), exists k:Z, (w2 = (Init.Datatypes.app u2 v2)) /\
  ((dist w1 v2 k) /\ ((k + (list.Length.length u2))%Z <= (m + 1%Z)%Z)%Z).

Axiom dist_concat_left : forall (u:(list char)) (v:(list char))
  (w:(list char)) (n:Z), (dist v w n) -> (dist (Init.Datatypes.app u v) w
  ((list.Length.length u) + n)%Z).

Axiom dist_concat_right : forall (u:(list char)) (v:(list char))
  (w:(list char)) (n:Z), (dist v w n) -> (dist v (Init.Datatypes.app u w)
  ((list.Length.length u) + n)%Z).

Axiom min_dist_equal : forall (w1:(list char)) (w2:(list char)) (a:char)
  (n:Z), (min_dist w1 w2 n) -> (min_dist (Init.Datatypes.cons a w1)
  (Init.Datatypes.cons a w2) n).

Axiom min_dist_diff : forall (w1:(list char)) (w2:(list char)) (a:char)
  (b:char) (m:Z) (p:Z), (~ (a = b)) -> ((min_dist (Init.Datatypes.cons a w1)
  w2 p) -> ((min_dist w1 (Init.Datatypes.cons b w2) m) -> (min_dist
  (Init.Datatypes.cons a w1) (Init.Datatypes.cons b w2)
  ((ZArith.BinInt.Z.min m p) + 1%Z)%Z))).

Axiom min_dist_eps : forall (w:(list char)) (a:char) (n:Z), (min_dist w
  Init.Datatypes.nil n) -> (min_dist (Init.Datatypes.cons a w)
  Init.Datatypes.nil (n + 1%Z)%Z).

Axiom min_dist_eps_length : forall (w:(list char)), (min_dist
  Init.Datatypes.nil w (list.Length.length w)).

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

Parameter make: forall {a:Type} {a_WT:WhyType a}, Z -> a -> (array a).

Axiom make_length : forall {a:Type} {a_WT:WhyType a}, forall (n:Z) (v:a),
  ((length (make n v)) = n).

Axiom make_elts : forall {a:Type} {a_WT:WhyType a}, forall (n:Z) (i:Z) (v:a),
  ((get (make n v) i) = v).

Parameter suffix: (array char) -> Z -> (list char).

Axiom suffix_nil : forall (a:(array char)), ((suffix a
  (length a)) = Init.Datatypes.nil).

Axiom suffix_cons : forall (a:(array char)) (i:Z), ((0%Z <= i)%Z /\
  (i < (length a))%Z) -> ((suffix a i) = (Init.Datatypes.cons (get a
  i) (suffix a (i + 1%Z)%Z))).

Axiom suffix_length : forall (a:(array char)) (i:Z), ((0%Z <= i)%Z /\
  (i <= (length a))%Z) -> ((list.Length.length (suffix a
  i)) = ((length a) - i)%Z).

(* Why3 assumption *)
Definition min_suffix (a1:(array char)) (a2:(array char)) (i:Z) (j:Z)
  (n:Z): Prop := (min_dist (suffix a1 i) (suffix a2 j) n).

(* Why3 goal *)
Theorem WP_parameter_distance : forall (w1:Z) (w11:(map.Map.map Z char))
  (w2:Z) (w21:(map.Map.map Z char)), let w22 := (mk_array w2 w21) in
  let w12 := (mk_array w1 w11) in (((0%Z <= w1)%Z /\ (0%Z <= w2)%Z) ->
  let o := (w2 + 1%Z)%Z in ((0%Z <= o)%Z -> forall (t:Z) (t1:(map.Map.map Z
  Z)), ((0%Z <= t)%Z /\ ((t = o) /\ forall (i:Z), ((map.Map.get t1
  i) = 0%Z))) -> ((0%Z <= w2)%Z -> forall (t2:(map.Map.map Z Z)),
  (forall (j:Z), ((0%Z <= j)%Z /\ (j < (w2 + 1%Z)%Z)%Z) -> ((map.Map.get t2
  j) = (w2 - j)%Z)) -> let o1 := (w1 - 1%Z)%Z in ((0%Z <= o1)%Z ->
  forall (t3:(map.Map.map Z Z)), forall (i:Z), ((i <= o1)%Z /\
  (0%Z <= i)%Z) -> ((forall (j:Z), ((0%Z <= j)%Z /\ (j <= w2)%Z) -> (min_dist
  (suffix w12 (i + 1%Z)%Z) (suffix w22 j) (map.Map.get t3 j))) ->
  (((0%Z <= t)%Z /\ ((0%Z <= w2)%Z /\ (w2 < t)%Z)) -> (((0%Z <= w2)%Z /\
  (w2 < t)%Z) -> (((0%Z <= w2)%Z /\ (w2 < t)%Z) -> forall (t4:(map.Map.map Z
  Z)), ((0%Z <= t)%Z /\ (t4 = (map.Map.set t3 w2 ((map.Map.get t3
  w2) + 1%Z)%Z))) -> let o2 := (w2 - 1%Z)%Z in ((0%Z <= o2)%Z ->
  forall (oldt:Z) (t5:(map.Map.map Z Z)), forall (j:Z), ((j <= o2)%Z /\
  (0%Z <= j)%Z) -> (((forall (k:Z), ((j < k)%Z /\ (k <= w2)%Z) -> (min_dist
  (suffix w12 i) (suffix w22 k) (map.Map.get t5 k))) /\ ((forall (k:Z),
  ((0%Z <= k)%Z /\ (k <= j)%Z) -> (min_dist (suffix w12 (i + 1%Z)%Z)
  (suffix w22 k) (map.Map.get t5 k))) /\ (min_dist (suffix w12 (i + 1%Z)%Z)
  (suffix w22 (j + 1%Z)%Z) oldt))) -> (((0%Z <= t)%Z /\ ((0%Z <= j)%Z /\
  (j < t)%Z)) -> forall (oldt1:Z), (oldt1 = (map.Map.get t5 j)) ->
  (((0%Z <= j)%Z /\ (j < w2)%Z) -> (((0%Z <= i)%Z /\ (i < w1)%Z) ->
  ((~ ((map.Map.get w11 i) = (map.Map.get w21 j))) -> let o3 :=
  (j + 1%Z)%Z in (((0%Z <= o3)%Z /\ (o3 < t)%Z) -> (((0%Z <= j)%Z /\
  (j < t)%Z) -> (((0%Z <= j)%Z /\ (j < t)%Z) -> forall (t6:(map.Map.map Z
  Z)), ((0%Z <= t)%Z /\ (t6 = (map.Map.set t5 j
  ((ZArith.BinInt.Z.min (map.Map.get t5 j) (map.Map.get t5
  o3)) + 1%Z)%Z))) -> forall (k:Z), (((j - 1%Z)%Z < k)%Z /\ (k <= w2)%Z) ->
  (min_dist (suffix w12 i) (suffix w22 k) (map.Map.get t6
  k))))))))))))))))))).
intros w1 w11 w2 w21 w22 w12 (h1,h2) o h3 t t1 (h4,(h5,h6)) h7 t2 h8
        o1 h9 t3 i (h10,h11) h12 (h13,(h14,h15)) (h16,h17) (h18,h19) t4
        (h20,h21) o2 h22 oldt t5 j (h23,h24) (h25,(h26,h27)) (h28,(h29,h30))
        oldt1 h31 (h32,h33) (h34,h35) h36 o3 (h37,h38) (h39,h40) (h41,h42) t6
        (h43,h44) k (h45,h46).
(*
intros w1 w11 w2 w21 w22 w12 (h1,h2) o h3 h4 h5 t h6 o1 h7 t1 i
        (h8,h9) h10 (h11,(h12,h13)) (h14,h15) (h16,h17) t2 (h18,h19) o2 h20
        oldt t3 j (h21,h22) (h23,(h24,h25)) (h26,(h27,h28)) oldt1 h29
        (h30,h31) (h32,h33) h34 o3 (h35,h36) (h37,h38) (h39,h40) t4 (h41,h42)
        k (h43,h44).
*)
subst t4 t6 w12 w22 o o1 o2 o3.
unfold min_suffix.
assert (k=j \/ j<k)%Z by omega. intuition.
  (* j=k *)
  subst j.
  rewrite (suffix_cons _ i).
  2: unfold length; simpl; omega.
  rewrite (suffix_cons _ k).
  2: unfold length; simpl; omega.
  rewrite Map.Select_eq; try omega.
  apply min_dist_diff.
  subst; auto.
  rewrite <- (suffix_cons _ i).
  2: unfold length; simpl; omega.
  subst.
  apply h25; omega.
  rewrite <- (suffix_cons _ k).
  subst.
  apply h26. omega.
  unfold length; simpl; omega.
  (* j<k *)
  subst.
  rewrite Map.Select_neq; try omega.
  apply h25. omega.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches Compilers.Compilers Elab.ElabCompilers.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVCPS.
Import Core.Notations.
Import CompilerDefs.Notations.

Require Coq.derive.Derive.

Notation compiler := (compiler string).

Definition let_lang_def : lang :=
  {[l/subst
  [:| "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"exp" "G" "A",
      "e'" : #"exp" (#"ext" "G" "A") "B"
      -----------------------------------------------
      #"let" "e" "e'" : #"exp" "G" "B"
  ];
  [:= "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "v" : #"val" "G" "A",
      "e" : #"exp" (#"ext" "G" "A") "B"
      ----------------------------------------------- ("eval let")
      #"let" (#"ret" "v") "e"
      = #"exp_subst" (#"snoc" #"id" "v") "e"
      : #"exp" "G" "B"
  ] ]}.

Derive let_lang
       SuchThat (elab_lang_ext (exp_subst++value_subst) let_lang_def let_lang)
       As let_lang_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve let_lang_wf : elab_pfs.

Definition let_cps_def : compiler :=
  match # from (let_lang) with
  | {{e #"let" "G" "A" "B" "e" "e'"}} =>
    bind_k 1 (var "e") (var "A")
    {{e#"blk_subst" (#"snoc" (#"snoc" {wkn_n 2} #"hd") {ovar 1}) "e'"}}
  end.

Derive let_cps
       SuchThat (elab_preserving_compiler cps_subst
                                          (cps_lang ++ block_subst ++ value_subst)
                                          let_cps_def
                                          let_cps
                                          let_lang)
       As let_cps_preserving.
Proof. auto_elab_compiler. Qed.
#[export] Hint Resolve let_cps_preserving : elab_pfs.


Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Parsers.Reflective.Syntax.
Set Implicit Arguments.

Local Open Scope list_scope.
Local Open Scope string_scope.

Section syntactify.
  Context (var : TypeCode -> Type).

  Definition syntactify_list {T : SimpleTypeCode} (ls : list (Term var T)) : Term var (clist T)
    := list_rect
         (fun _ => Term _ _)
         (RLiteralApp Rnil noargs)
         (fun x _ xs
          => RLiteralApp Rcons (x :: xs :: noargs))
         ls.

  Definition syntactify_prod {A B : SimpleTypeCode} (xy : Term var A * Term var B) : Term var (A * B)
    := RLiteralApp Rpair (fst xy :: snd xy :: noargs).

  Definition syntactify_nat (n : nat) : Term var cnat
    := nat_rect
         (fun _ => Term _ _)
         (RLiteralApp RO noargs)
         (fun _ n'
          => RLiteralApp RS (n' :: noargs))
         n.

  Definition syntactify_bool (v : bool) : Term var cbool
    := RLiteralApp (Rbool v) noargs.
  Definition syntactify_rchar_expr_ascii (v : Reflective.RCharExpr ascii)
    : Term var crchar_expr_ascii
    := RLiteralApp (Rrchar_expr_ascii v) noargs.
  Definition syntactify_ritem_ascii (v : Reflective.ritem ascii)
    : Term var critem_ascii
    := RLiteralApp (Rritem_ascii v) noargs.
  Definition syntactify_string (v : string)
    : Term var cstring
    := RLiteralApp (Rstring v) noargs.
  Definition syntactify_rproductions
             (Gp : list (string * Reflective.rproductions ascii))
    : Term var _
    := syntactify_list
         (List.map
            (fun xy
             => syntactify_prod
                  (syntactify_string (fst xy),
                   syntactify_list
                     (List.map
                        (fun ls
                         => syntactify_list
                              (List.map
                                 syntactify_ritem_ascii
                                 ls))
                        (snd xy))))
            Gp).
End syntactify.


Require Export LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.PseudoType.
Require Import Stlc.SpecSyntax.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.SpecTyping.
Require Import Utlc.SpecSyntax.
Require Import Utlc.SpecEvaluation.
Require Import Utlc.Inst.
Require Import UVal.UVal.

Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Arith.Wf_nat.
Require Import Omega.

Inductive Direction : Set :=
| dir_lt
| dir_gt.

Definition World := nat.
Definition lev : World → nat := fun w => w.
Definition later : World → World := pred.
Fixpoint lateri (i : nat) : World → World :=
  match i with
    | 0 => id
    | S i => fun w => pred (lateri i w)
  end.

Definition PTRel := PTy → S.Tm → U.UTm → Prop.
Definition PCRel := PTy → S.PCtx → U.PCtx → Prop.

(* Intuitively: observing termination takes a step in addition to the actual evaluation steps *)
Definition Observe (n : nat) (T : nat → Prop) : Prop :=
  match n with
    | 0 => False
    | S n' => T n'
  end.

Lemma lt_le {w w' w''} (fw : w' < w) (fw' : w'' ≤ w') : w'' < w.
Proof.
  unfold lt in *.
  refine (le_trans _ _ _ _ fw).
  refine (le_n_S _ _ fw').
Defined.

Definition prod_rel (R₁ R₂ : S.Tm → U.UTm → Prop) : S.Tm → U.UTm → Prop :=
  fun ts tu =>
    match ts , tu with
      | S.pair ts₁ ts₂ , U.pair tu₁ tu₂ => R₁ ts₁ tu₁ ∧ R₂ ts₂ tu₂
      | _              , _              => False
    end.
Definition sum_rel (R₁ R₂ : S.Tm → U.UTm → Prop) : S.Tm → U.UTm → Prop :=
  fun ts tu =>
    match ts , tu with
      | S.inl ts' , U.inl tu' => R₁ ts' tu'
      | S.inr ts' , U.inr tu' => R₂ ts' tu'
      | _         , _         => False
    end.
Definition arr_rel (R₁ R₂ : S.Tm → U.UTm → Prop) : S.Tm → U.UTm → Prop :=
  fun ts tu =>
    match ts , tu with
      | S.abs τ₁' tsb , U.abs tub =>
        ∀ ts' tu',
          R₁ ts' tu' →
          R₂ (tsb [beta1 ts']) (tub [beta1 tu'])
      | _ , _ => False
    end.

Arguments prod_rel R₁ R₂ !ts !tu.
Arguments sum_rel R₁ R₂ !ts !tu.
Arguments arr_rel R₁ R₂ !ts !tu.

Section LogicalRelation.

  Variable (d: Direction).

  Definition Obs (w : World) (ts : S.Tm) (tu : U.UTm) :=
    match d with
      | dir_lt => Observe (lev w) (S.TerminatingN ts) → U.Terminating tu
      | dir_gt => Observe (lev w) (U.TerminatingN tu) → S.Terminating ts
    end.

  Definition contrel' (w : World) (vr' : ∀ w' : World, w' ≤ w → PTRel) : PCRel :=
   fun τ Cs Cu => ∀ w' (fw : w' ≤ w) ts tu, vr' w' fw τ ts tu → Obs w' (S.pctx_app ts Cs) (U.pctx_app tu Cu).

  Definition termrel' (w : World) (vr' : ∀ w' : World, w' ≤ w → PTRel) : PTRel :=
    fun τ ts tu => ∀ Cs Cu, S.ECtx Cs → U.ECtx Cu → contrel' w vr' τ Cs Cu → Obs w (S.pctx_app ts Cs) (U.pctx_app tu Cu).

  Definition valrel' (w : World) (ind : ∀ w' : World, w' < w → PTRel) : PTRel :=
    fun τ ts tu =>
      OfType τ ts tu ∧
      let latervr : PTRel := fun τ ts tu => ∀ w' (fw : w' < w), ind w' fw τ ts tu in
      let laterlatervr : ∀ w' (fw : w' < w) w'' (fw' : w'' ≤ w'), PTRel := fun w' fw w'' fw' => ind w'' (lt_le fw fw') in
      let vrunit : S.Tm → U.UTm → Prop := fun ts tu => ts = S.unit ∧ tu = U.unit in
      let vrbool : S.Tm → U.UTm → Prop := fun ts tu => (ts = S.true ∧ tu = U.true) ∨ (ts = S.false ∧ tu = U.false) in
      let vrprod : PTy → PTy → S.Tm → U.UTm → Prop :=
          fun τ₁ τ₂ =>
            prod_rel (latervr τ₁) (latervr τ₂) in
      let vrsum : PTy → PTy → S.Tm → U.UTm → Prop :=
          fun τ₁ τ₂ =>
            sum_rel (latervr τ₁) (latervr τ₂) in
      let vrarr : PTy → PTy → S.Tm → U.UTm → Prop :=
          fun τ₁ τ₂ ts tu =>
            ∀ w' (fw : w' < w),
              arr_rel
                (ind w' fw τ₁)
                (termrel' w' (laterlatervr w' fw) τ₂)
                ts tu
      in
      match τ with
        | ptunit => vrunit ts tu
        | ptbool => vrbool ts tu
        | ptprod τ₁ τ₂ => vrprod τ₁ τ₂ ts tu
        | ptsum τ₁ τ₂ => vrsum τ₁ τ₂ ts tu
        | ptarr τ₁ τ₂ => vrarr τ₁ τ₂ ts tu
        | pEmulDV n p => match n with
                           | 0 => ts = S.unit ∧ p = imprecise
                           | S n' => (ts = unkUVal (S n') ∧ p = imprecise) ∨
                                     exists ts',
                                       (ts = inUnit n' ts' ∧ vrunit ts' tu) ∨
                                       (ts = inBool n' ts' ∧ vrbool ts' tu) ∨
                                       (ts = inProd n' ts' ∧ vrprod (pEmulDV n' p) (pEmulDV n' p) ts' tu ∧
                                        OfTypeUtlc (ptprod (pEmulDV n' p) (pEmulDV n' p)) tu) ∨
                                       (ts = inSum n' ts' ∧ vrsum (pEmulDV n' p) (pEmulDV n' p) ts' tu ∧
                                        OfTypeUtlc (ptsum (pEmulDV n' p) (pEmulDV n' p)) tu) ∨
                                       (ts = inArr n' ts' ∧ vrarr (pEmulDV n' p) (pEmulDV n' p) ts' tu ∧
                                        OfTypeUtlc (ptarr (pEmulDV n' p) (pEmulDV n' p)) tu)
                         end
      end.

  Definition valrel (w : World) (τ : PTy)(t₁ : S.Tm) (t₂ : U.UTm) : Prop :=
    Fix lt_wf (fun w => PTRel) valrel' w τ t₁ t₂.

  Lemma valrel_def_funext w (ind₁ ind₂ : ∀ w', w' < w → PTRel) :
    (∀ w' (fw : w' < w), ind₁ w' fw = ind₂ w' fw) →
    valrel' w ind₁ = valrel' w ind₂.
  Proof.
    intros.
    enough (ind₁ = ind₂) as -> by auto.
    extensionality w'.
    extensionality fw.
    trivial.
  Qed.

  Lemma valrel_fixp : ∀ w, valrel w = valrel' w (fun w _ => valrel w).
  Proof.
    refine (Fix_eq lt_wf (fun w => PTRel) valrel' valrel_def_funext).
  Qed.

  Definition contrel (w : World) : PCRel :=
    contrel' w (fun w fw => valrel w).

  Definition termrel (w : World) : PTRel :=
    termrel' w (fun w fw => valrel w).

  Lemma termrel_fixp :
    ∀ w, termrel w = termrel' w (fun w _ => valrel' w (fun w _ => valrel w)).
  Proof.
    unfold termrel.
    intros w.
    f_equal.
    (* Should we avoid functional extensionality? *)
    extensionality w'.
    extensionality fw.
    apply valrel_fixp.
  Qed.

  Definition envrel (w : World) (Γ : PEnv) (γs : Sub S.Tm) (γu : Sub U.UTm) : Prop :=
    ∀ i τ, ⟪ i : τ p∈ Γ ⟫ → valrel w τ (γs i) (γu i).

  Definition OpenLRN (n : nat) (Γ : PEnv) (ts : S.Tm) (tu : U.UTm) (τ : PTy) : Prop :=
    ⟪ repEmulCtx Γ ⊢ ts : repEmul τ ⟫ ∧
    ⟨ pdom Γ ⊢ tu ⟩ ∧
    ∀ w, lev w ≤ n → ∀ γs γu, envrel w Γ γs γu → termrel w τ (ts [ γs ]) (tu [ γu ]).

  Definition OpenLR (Γ : PEnv) (ts : S.Tm) (tu : U.UTm) (τ : PTy) : Prop :=
    ∀ n, OpenLRN n Γ ts tu τ.

  Definition OpenLRCtxN (n : nat) (Cs : S.PCtx) (Cu : U.PCtx) (Γ' : PEnv) (τ' : PTy) (Γ : PEnv) (τ : PTy) : Prop :=
    ⟪ ⊢ Cs : repEmulCtx Γ' , repEmul τ' → repEmulCtx Γ , repEmul τ ⟫ ∧
    ∀ ts tu, OpenLRN n Γ' ts tu τ' -> OpenLRN n Γ (S.pctx_app ts Cs) (U.pctx_app tu Cu) τ.

  Definition OpenLRCtx (Cs : S.PCtx) (Cu : U.PCtx) (Γ' : PEnv) (τ' : PTy) (Γ : PEnv) (τ : PTy) : Prop :=
    ⟪ ⊢ Cs : repEmulCtx Γ' , repEmul τ' → repEmulCtx Γ' , repEmul τ ⟫ ∧
    ∀ ts tu, OpenLR Γ' ts tu τ' → OpenLR Γ (S.pctx_app ts Cs) (U.pctx_app tu Cu) τ.

End LogicalRelation.

Arguments termrel d w τ t₁ t₂ : simpl never.
Arguments valrel d w τ t₁ t₂ : simpl never.
Arguments valrel' d w ind !τ !t₁ !t₂ /.

Notation "⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : τ ⟫" := (OpenLRN d n Γ ts tu τ)
  (at level 0, ts at level 98,
   d at level 98, n at level 98,
   tu at level 98,
   Γ at level 98, τ at level 98,
   format "⟪ Γ ⊩  ts ⟦ d , n ⟧ tu  :  τ  ⟫").

Notation "⟪ Γ ⊩ ts ⟦ d ⟧ tu : τ ⟫" := (OpenLR d Γ ts tu τ)
  (at level 0, ts at level 98,
   d at level 98, tu at level 98,
   Γ at level 98, τ at level 98,
   format "⟪ Γ ⊩  ts ⟦ d ⟧ tu  :  τ  ⟫").

Notation "⟪ ⊩ Cs ⟦ d , n ⟧ Cu : Γ₀ , τ₀ → Γ , τ ⟫" := (OpenLRCtxN d n Cs Cu Γ₀ τ₀ Γ τ)
  (at level 0, Cs at level 98,
   d at level 98, n at level 98,
   Cu at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊩  Cs ⟦ d , n ⟧ Cu  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").

Notation "⟪ ⊩ Cs ⟦ d ⟧ Cu : Γ₀ , τ₀ → Γ , τ ⟫" := (OpenLRCtx d Cs Cu Γ₀ τ₀ Γ τ)
  (at level 0, Cs at level 98,
   d at level 98, Cu at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊩  Cs ⟦ d ⟧ Cu  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").

Section TermRelZero.
  Definition termreli₀ d dfc w τ ts tu :=
    (∃ vs vu, clos_refl_trans_1n S.Tm S.eval ts vs ∧ U.ctxevalStar tu vu ∧
              valrel d w τ vs vu) ∨
    (forall Cs Cu, S.ECtx Cs → U.ECtx Cu → Obs d (lateri dfc w) (S.pctx_app ts Cs) (U.pctx_app tu Cu)).

  Arguments termreli₀ d dfc w τ ts tu : simpl never.

  Definition termrel₀ d w τ ts tu :=
    termreli₀ d 0 w τ ts tu.

  Arguments termrel₀ d w τ ts tu : simpl never.

End TermRelZero.


Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Require Import msl.rmaps.
Require Import msl.rmaps_lemmas.
Require Import language.
Require Import seplogic.

Hint Extern 3 (list_nodups _ = true) => (compute; reflexivity).
Hint Extern 3 (typecheck _ _ = true) => (compute; reflexivity).
Hint Extern 3 (expcheck _ _ = true) => (compute; reflexivity).
Hint Resolve andb_true_intro.

Obligation Tactic := idtac.

Module Semax : SEMAX.

Local Open Scope pred.

(******  CONSTRUCTION OF rmap FOR THE CONT LANGUAGE *****)
Inductive kind := VAL: adr -> kind | FUN: list var -> kind.

Module AV0 <: ADR_VAL0.
 Definition address := adr.
 Definition some_address := 0.
 Definition kind := kind.
End AV0.

Module AV := SimpleAdrVal AV0.
Module R := Rmaps AV.
Module RML := Rmaps_Lemmas R.
Export RML. Export R.
Instance Cross_rmap : Cross_alg rmap := Cross_rmap_simple (fun _ => I).

Obligation Tactic := idtac.

(******  MAPSTO AND RELATED OPERATORS *****)

Program Definition mapsto (v1 v2: adr) : pred rmap :=
  fun w => forall i,
         if eq_dec i v1 then w @ i = YES pfullshare (VAL v2) NoneP else identity (w @ i).
Next Obligation.
 intros. intros ? ? ? ?.
  intro i; specialize (H0 i).
  destruct (eq_dec i v1).
  apply (age1_YES _ _ _ _ _ H); auto.
  destruct (identity_resource (a @ i)) as [? _]. specialize (H1 H0).
  apply identity_resource.
  generalize (age1_resource_at _ _ H i (a @ i)); intro.
  generalize (resource_at_approx a i); intro.
  destruct (a @ i); try contradiction.
  rewrite H2; simpl in *; auto.
  rewrite H2; simpl in *; auto.
Qed.

Lemma mapsto_conflict:
   forall a b c, mapsto a b  *  mapsto a c |-- FF.
  Proof.
    intros.
    intros w  [w1 [w2 [? [? ?]]]]; hnf.
    specialize (H0 a). specialize (H1 a).
    rewrite if_true in * by auto.
    apply (resource_at_join _ _ _ a) in H.
    rewrite H0 in H; rewrite H1 in H; inv H.
    pfullshare_join.
 Qed.

Lemma singleton_rmap_OK:
   forall v v' m,
       resource_fmap (approx (level m))
            oo (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP else core m @  i) =
    (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP else core m @ i).
Proof.
  intros; extensionality i; unfold compose; simpl.
  destruct (eq_dec i v).
  unfold resource_fmap. f_equal. apply preds_fmap_NoneP.
  rewrite <- level_core.
  symmetry; apply resource_at_approx.
Qed.

Definition singleton_rmap  (v v': adr) (m: rmap) : rmap :=
  proj1_sig
  (make_rmap (fun i => if eq_dec i v then YES pfullshare (VAL v') NoneP  else core m @ i )
    I (level m) (singleton_rmap_OK _ _ m)).

Lemma singleton_rmap_level: forall x y m,
      level (singleton_rmap x y m) = level m.
Proof.
  intros.  apply level_make_rmap.
Qed.

Lemma singleton_rmap_mapsto:
   forall x y n, app_pred (mapsto x y) (singleton_rmap x y n).
 Proof.
  intros. hnf. simpl snd.
  unfold singleton_rmap.
  intro; repeat rewrite resource_at_make_rmap.
  change AV.address with adr.
 destruct (eq_dec i x); auto.
 apply resource_at_core_identity.
Qed.

Local Open Scope pred.

Lemma mapsto_uniq: forall (x y: adr) w w', core w = core w' -> mapsto x y w -> mapsto x y w' -> w=w'.
Proof.
  intros.
 apply rmap_ext.
 assert (level (core w) = level (core w')) by congruence.
 do 2 rewrite level_core in H2. auto.
 intro.
 specialize (H0 l); specialize (H1 l).
 destruct (@eq_dec adr _ l x); try congruence.
 apply identity_unit_equiv in H0.
 apply unit_core in H0.
 apply identity_unit_equiv in H1.
 apply unit_core in H1.
 rewrite core_resource_at in *. congruence.
Qed.

Lemma mapsto_e1: forall v1 v2 w,
       app_pred (mapsto v1 v2 * TT) w ->
       w @ v1 = YES pfullshare (VAL v2) NoneP.
Proof.
 intros.
 destruct H as [w1 [w2 [? [? ?]]]].
 hnf in H0.
 specialize (H0 v1).
 apply (resource_at_join _ _ _ v1) in H.
 rewrite if_true in H0 by auto. rewrite H0 in H.
apply join_YES_pfullshare1 in H. inv H; auto.
Qed.

Definition assert := env -> pred rmap.
Bind Scope pred with assert.

(****** PROGRAM SAFETY AS A SEPARATION-LOGIC PREDICATE *)

Program Definition cohere (concrete: heap) : pred rmap :=
 fun w =>
 forall p v, heap_get (concrete) p = Some v  <->
                 w @ p = YES pfullshare (VAL v) NoneP.
Next Obligation.
  unfold hereditary; intros.
  rewrite H0.
  apply age1_YES; auto.
Qed.

Program Definition assert_safe
     (p: program) (vars: varset) (ctl: control) : assert :=
  fun s w => forall s' h, varcompat vars s' ->
                   locals2env s' = s -> cohere h w -> safeN p (s',h,ctl) (level w).
 Next Obligation.
  unfold hereditary; intros.
  eapply safeN_less; [ | apply H0]; auto. subst.
  apply age_level in H.   rewrite H. change R.rmap with rmap. omega.
  clear - H H3. hnf in H3|-*. intros. rewrite H3.
    generalize (age1_YES _ _ p pfullshare (VAL v) H); intros.
  intuition.
 Qed.

Lemma assert_safe0:
        forall p vars k s w,
           (forall w', age w w' -> app_pred (assert_safe p vars k s) w) ->
            app_pred (assert_safe p vars k s) w.
Proof.
  intros.
  case_eq (age1 w); intros.
  apply (H _ H0).
  hnf; repeat intro.
  rewrite age1_level0 in H0. rewrite H0. hnf. econstructor; reflexivity.
Qed.

(******* FUNASSERT, MAKE_WORLD ********************)

Definition funspec := (list var * assert)%type.
Definition funspecs := table adr funspec.

Definition unpack (P: list adr -> pred rmap) (vl: listprod (@cons Type (list adr) nil)):  pred rmap := P (fst vl).

Definition call (P: list var * assert) (vl: list adr) : pred rmap :=
     (!! (length vl = length (fst P)) && snd P (arguments (fst P) vl)).

Program Definition cont (nP: funspec)  (v: adr) : pred rmap :=
  fun w => w @ v = PURE (FUN (fst nP)) (preds_fmap (approx (level w)) (SomeP (list adr::nil)
             (unpack (call nP)))).
Next Obligation.
 intros; intro; intros.
  apply (age1_resource_at a a' H v (PURE (FUN (fst nP)) _));   simpl; auto.
Qed.

Definition funassert (G: funspecs) : pred rmap :=
   (ALL  i:_, ALL P:_,  !! (table_get G i = Some P) --> cont P i)  &&
   (ALL  i:_, ALL P:_,  cont P i --> !! exists P', table_get G i = Some P').

Definition make_world_aux (G: funspecs) (h: heap) (n: nat) (a: adr) : resource :=
   match table_get G a with
   | Some P => PURE (FUN (fst P))
                               (preds_fmap (approx n)
                                      (SomeP (@cons Type (list adr) nil) (unpack (call P))))
   | None => match heap_get h a with
                     | Some v => YES pfullshare (VAL v) NoneP
                     | None => NO
                    end
   end.

Lemma make_world_aux_OK:
  forall G h n,
         resource_fmap (approx n) oo make_world_aux G h n =  make_world_aux G h n.
Proof.
 intros.
 extensionality v;
 unfold make_world_aux, compose.
 destruct (table_get G v). destruct f as [nargs P]. simpl.
 f_equal. f_equal. rewrite <- compose_assoc. rewrite approx_oo_approx. auto.
 destruct (heap_get h v); auto.
 unfold resource_fmap.
 f_equal. apply preds_fmap_NoneP.
Qed.

Definition make_world (G: funspecs) (h: heap) (n: nat) : rmap :=
    proj1_sig (make_rmap (make_world_aux G h n) I n (make_world_aux_OK _ _ _)).

Lemma level_make_world:
  forall h G n, level (make_world G h n) = n.
Proof.
 intros; simpl.
 apply level_make_rmap.
Qed.

Inductive match_specs: forall (p: program) (G: funspecs), Prop :=
| match_specs_nil: match_specs nil nil
| match_specs_cons: forall i vars f p' P G',
         not (In i (map (@fst _ _) p')) ->
         match_specs p' G' ->
         typecheck vars f = true ->
         match_specs ((i,(vars,f))::p') ((i,P)::G').

Lemma match_specs_boundary:
   forall p G i,
   match_specs p G -> i >= boundary p -> table_get G i = None.
Proof.
  induction 1. intros. reflexivity.
  intros. simpl in *.
  destruct (@eq_dec adr _ i i0). subst.
  clear - H2. destruct (boundary p'). exfalso; omega.
 generalize (Max.le_max_l i0 n); intro. exfalso. omega.
 apply IHmatch_specs.
 destruct (boundary p'); try omega.
 generalize (Max.le_max_r i0 n0);  omega.
Qed.

Lemma funassert_e:  forall G i f,
      table_get G i = Some f ->
      funassert G |-- cont f i.
Proof.
  intros.
  unfold funassert.
  apply andp_left1.
  intros w ?. apply H0; auto.
Qed.

Lemma funassert_make_world: forall p G n,
         app_pred (funassert G) (make_world G (initial_heap p) n).
Proof.
 intros ? ? ?.
 forget (initial_heap p) as h.
 split.
 intros i P w ? ?.
 hnf in H0.
 eapply pred_nec_hereditary; try apply H.
 clear w H.
 hnf. unfold make_world; simpl. rewrite resource_at_make_rmap.
 unfold make_world_aux. rewrite H0.
 f_equal. simpl. f_equal. rewrite level_make_rmap.
 reflexivity.
 intros i P w ? ?.
 hnf.
 case_eq (table_get G i); intros. eauto.
 exfalso.
 hnf in H0.
 case_eq (make_world G h n @ i); intros.
 apply (necR_NO _ _ i H) in H2. inversion2 H0 H2.
 apply (necR_YES _ _ i _ _ _ H) in H2. inversion2 H2 H0.
 clear dependent w.
 unfold make_world in H2.
 rewrite resource_at_make_rmap in H2. unfold make_world_aux in H2.
 rewrite H1 in H2. destruct (heap_get h i); inv H2.
Qed.

Lemma cohere_make_world:
  forall p G n,
      match_specs p G ->
     app_pred (cohere (initial_heap p)) (make_world G (initial_heap p) n).
Proof.
 intros.
 hnf.
 intros. unfold make_world, make_world_aux; simpl. rewrite resource_at_make_rmap.
 unfold  initial_heap. simpl. unfold heap_get.
  rename p0 into i.
 destruct (lt_dec i (boundary p)).
 split; intro. inv H0. exfalso.
 revert H0; case_eq (table_get G i); intros. destruct f as [nargs P].
 inv H1. inv H1.
 rewrite (match_specs_boundary p G i); auto; try omega.
 split; intro Hx; inv Hx; auto.
Qed.

Lemma funassert_get:
  forall G v nP,  funassert  G && cont nP v |--
                      EX P':assert, (ALL vl:list adr, |> ! (call nP vl <=> call (fst nP,P') vl)) && !! (table_get G v = Some (fst nP,P')).
Proof.
 intros. intros w [? ?].
 destruct H.
 specialize (H v); specialize (H1 v).
 specialize (H1 _ _ (necR_refl _) H0).
 destruct H1 as [[args P'] ?].
 exists P'.
 specialize (H _ _ (necR_refl _) H1).
 split.
 Focus 2. hnf in H,H0. inversion2 H H0. apply H1.
 clear H1. rename H into H99. rename H0 into H97.
 hnf in H99,H97. rewrite H99 in H97.  apply PURE_inj in H97. destruct H97 as [H H97].
 simpl in H. destruct nP as [na P]. inv H.
 intro vl. intros w' ? w'' ?.
  assert (level w'' < level w). do 3 red in H. apply laterR_level in H.
       apply le_lt_trans with (level w'); auto.
 simpl fst.
  split; intros w''' ? ?.
 match type of H97 with ?A = _ => assert (app_pred (A (vl,tt)) w''') end.
  rewrite H97.
 split.
  change rmap with R.rmap in *.
  change ag_rmap with R.ag_rmap in *.
  apply necR_level in H2; omega.
 apply H3.
  destruct H4. apply H5.
 match type of H97 with _ = ?A => assert (app_pred (A (vl,tt)) w''') end.
  rewrite <- H97.
 split.
  change rmap with R.rmap in *.
  change ag_rmap with R.ag_rmap in *.
  apply necR_level in H2; omega.
 apply H3.
  destruct H4. apply H5.
Qed.

Lemma cont_core: forall P i w, app_pred (cont P i) w <-> app_pred (cont P i) (core w).
Proof.
 intros.
 unfold cont. simpl. rewrite <- core_resource_at.
 split; intro. rewrite H.
 clear. symmetry. rewrite level_core. apply unit_core; constructor.
 rewrite level_core in H.
 generalize (core_unit (w @ i)); intro.
 rewrite H in H0.
 inv H0; auto.
Qed.

Lemma funassert_core: forall G w, app_pred (funassert G) w <-> app_pred (funassert G) (core w).
Proof.
 intros.
 split; intros [? ?]; split; intros i P w' ? ?.
 specialize (H i P _ (necR_refl _) H2).
 apply cont_core in H. eapply pred_nec_hereditary; eauto.
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H4 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence.
 subst z'. clear H5.
 specialize (H0 i P _ H4).
 apply join_core in H3. rewrite cont_core in H2. rewrite H3 in H2. rewrite <- cont_core in H2.
 specialize (H0 H2). apply H0.
 assert (necR (core w) (core w')).
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 apply join_comm in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H1 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence. subst z'.
 apply join_comm in H3.
 generalize (unit_identity _ H3); intro.
 apply identity_unit_equiv in H6. apply unit_core in H6.
 apply join_core in H3. rewrite H6 in H4. rewrite H3 in H4; auto.
 specialize (H i P _ H3 H2).
 apply cont_core in H; auto.
 assert (necR (core w) (core w')).
 generalize (core_unit w); intro.
 unfold unit_for in H3.
 apply join_comm in H3.
 eapply nec_join in H3; eauto.
 destruct H3 as [y' [z' [? [? ?]]]].
 generalize (necR_linear' H1 H5); intro.
 spec H6. apply join_level in H3. destruct H3; congruence. subst z'.
 apply join_comm in H3.
 generalize (unit_identity _ H3); intro.
 apply identity_unit_equiv in H6. apply unit_core in H6.
 apply join_core in H3. rewrite H6 in H4. rewrite H3 in H4; auto.
 specialize (H0 i P _ H3).
 apply H0. rewrite <- cont_core; auto.
Qed.

(**************** ALLOCPOOL ***************************)

Program Definition allocpool (b: adr) : pred rmap :=
   fun w => b>0 /\ forall i, if lt_dec i b then identity (w @ i) else w @ i = YES pfullshare (VAL 0) NoneP.
Next Obligation.
 intros. intro; intros.
  destruct H0; split; auto.
 intro i; specialize (H1 i).
 destruct (lt_dec i b).
  eapply age1_resource_at_identity; eauto.
 apply (age1_YES _ _ _ _ _ H); auto.
Qed.

Lemma allocpool_make_world: forall p G n,
          match_specs p G ->
          app_pred (allocpool (boundary p)) (make_world G (initial_heap p) n).
Proof.
  unfold make_world; intros.
  rename H into H'.
 unfold initial_locals,initial_heap  in *.
 split.
 destruct p; simpl. omega. destruct p. destruct (boundary p0); omega.
 intro loc.
 destruct (make_rmap
        (make_world_aux G
           (fun i : adr => if lt_dec i (boundary p) then None else Some 0) n)
        I n
        (make_world_aux_OK G
           (fun i : adr => if lt_dec i (boundary p) then None else Some 0) n)) as [? [? ?]];
  simpl in *. rewrite e0. unfold make_world_aux.
 unfold heap_get.
 destruct (lt_dec loc (boundary p)).
 destruct (table_get G loc);  apply identity_resource; auto.
 rewrite (match_specs_boundary p G loc); auto.
 omega.
Qed.

Lemma alloc: forall b, allocpool b = ((!! (b > 0) && mapsto b 0) * allocpool (S b)).
Proof.
 intros. apply pred_ext.
  intros w ?.
 destruct H as [H' H].
  destruct (deallocate w
                   (fun i => if lt_dec b i then NO else w @ i)
                   (fun i => if eq_dec b i then NO else w @ i)
               I I) as [w1 [w2 [? ?]]].
 intro l; specialize (H l).
 destruct (eq_dec b l). subst. rewrite if_false by omega. rewrite if_false in H by omega.
 rewrite H; constructor.
 destruct (lt_dec b l).
 rewrite if_false in H by omega.
 rewrite H; constructor.
 rewrite if_true in H.
 apply identity_unit_equiv in H. apply H.
 unfold adr in *; omega.
 exists w1; exists w2; split3; auto.
 split; auto.
 intro i. apply (resource_at_join _ _ _ i) in H0. specialize (H i). rewrite H1 in *.
 clear w1 H1.
 destruct (lt_dec b i).
 rewrite if_false by omega. apply NO_identity.
 destruct (eq_dec i b). subst. rewrite if_false in H by omega. auto.
 rewrite if_true in H. auto.
 unfold adr in *; omega.
 split. omega.
 intro i. apply (resource_at_join _ _ _ i) in H0. specialize (H i). rewrite H1 in *.
 clear w1 H1.
 destruct (lt_dec b i).
 rewrite if_false by omega. rewrite if_false in H by omega. rewrite H in H0. inv H0; auto.
 rewrite if_true by omega.
 destruct (eq_dec i b). subst. rewrite if_false in H by omega. rewrite H in H0; inv H0; auto.
 apply NO_identity. pfullshare_join.
 rewrite if_true in H by (unfold adr in *; omega).
 apply H in H0. rewrite H0; auto.

  intros w [w1 [w2 [? [? ?]]]].
  destruct H0 as [H0' H0]. destruct H1 as [_ H1].
 split; auto.
  intro i. specialize (H0 i); specialize (H1 i). apply (resource_at_join _ _ _ i) in H.
  destruct (lt_dec i b). rewrite if_true in H1 by omega.
  rewrite if_false in H0 by omega. apply H0 in H. rewrite <- H; auto.
  destruct (@eq_dec adr _ i b). subst. rewrite H0 in H. rewrite if_true in H1 by omega.
  apply join_comm in H. apply H1 in H. auto.
  rewrite if_false in H1. rewrite H1 in H. apply H0 in H. auto.
  unfold AV.address, AV0.address, adr in *. omega.
Qed.

Require msl.seplog msl.alg_seplog.
Definition mpred : Type := predicates_hered.pred rmap.
Instance Nm: seplog.NatDed mpred := alg_seplog.algNatDed rmap.
Instance Sm: seplog.SepLog mpred := alg_seplog.algSepLog rmap.
Instance Cm: seplog.ClassicalSep mpred := alg_seplog.algClassicalSep rmap.
Instance Im: seplog.Indir mpred := alg_seplog.algIndir rmap.
Instance Rm: alg_seplog.RecIndir mpred := alg_seplog.algRecIndir rmap.
Instance SIm: seplog.SepIndir mpred := alg_seplog.algSepIndir rmap.
Instance SRm: alg_seplog.SepRec mpred := alg_seplog.algSepRec rmap.

Definition guard (p: program) (G: funspecs) (vars: varset) (P : assert) (k: control) : pred nat :=
     ALL s:env, P s && funassert G >=> assert_safe p vars k s.

Record semaxArg :Type := SemaxArg {
 sa_vars: varset;
 sa_P: assert;
 sa_c: control
}.

Definition believe (semax: semaxArg -> pred nat)
      (p: program) (P: funspec) (f: adr) : pred nat :=
      EX k: list var * control,
        !!(table_get p f = Some k /\ length (fst k) = length (fst P) /\ list_norepet (fst k)) &&
      |> semax (SemaxArg (fst k) (fun s => call P (map s (fst k))) (snd k)).

Definition believe_all (semax: semaxArg -> pred nat) (G: funspecs) (p: program) (G': funspecs) : pred nat :=
  ALL v:adr, ALL args: list var, ALL P: assert,
     !! (table_get G' v = Some (args,P)) -->
     believe semax p (args, fun s => P s && funassert G) v.

Definition semax_ (semax: semaxArg -> pred nat) (a: semaxArg) : pred nat :=
 match a with SemaxArg vars P c =>
     ALL p: program, ALL G: funspecs, believe_all semax G p G --> guard p G vars P c
  end.

Lemma prop_imp {A}{agA: ageable A}:
  forall (P: Prop) (Q: pred A) w, (P -> app_pred Q w) -> app_pred (!!P --> Q) w.
Proof. repeat intro. specialize (H H1). eapply pred_nec_hereditary; eauto.
Qed.

Lemma HOcontractive_semax_ : HOcontractive semax_.
Proof.
  auto 50 with contractive.
Qed.

Definition semax'  := HORec semax_.

Lemma semax'_unfold: forall vars P c,
     semax' (SemaxArg vars P c) =
         ALL p: program, ALL G:funspecs, believe_all semax' G p G --> guard p G vars P c.
Proof.
  intros.
  unfold semax' at 1. rewrite HORec_fold_unfold; auto.
  apply HOcontractive_semax_.
Qed.

Definition semax vars (G: funspecs) (P: assert) (k: control) : Prop :=
       typecheck vars k = true /\ forall n,  semax' (SemaxArg vars (fun s => P s && funassert G) k) n.

Definition semax_func (G: funspecs) (p: program) (G': funspecs) :=
    match_specs p G' /\
    forall n, believe_all semax' G p G' n.

Lemma semax_func_nil: forall G, semax_func G nil nil.
Proof. split; repeat intro. constructor. inv H0. Qed.

Lemma semax_func_cons:
   forall  fs id f vars P (G G': funspecs),
      inlist id (map (@fst adr (list var * control)) fs) = false ->
      list_nodups vars = true ->
      length vars = length (fst P) ->
      semax vars G (fun s => call P (map s vars)) f ->
      semax_func G fs G' ->
      semax_func G ((id, (vars,f))::fs) ((id, P) :: G').
Proof.
intros until G'. intros H0 H Hlen ? ?.
apply inlist_notIn in H0.
destruct H2.
split.
constructor; auto.
destruct H1; auto.
intro.
specialize (H3 n).
intros b nargs' Q.
specialize (H3 b nargs' Q).
intros ? ? ?.
destruct (eq_dec id b).
subst.
Focus 2.
specialize (H3 _ H4).
spec H3.
clear - H5 n0.
hnf in H5|-*.
unfold table_get  in H5; fold @table_get in H5.
rewrite if_false in H5; auto.
clear H5.
destruct H3 as [k [? ?]]; exists k; split; auto.
unfold table_get; fold @table_get.
rewrite if_false; auto.
(* End Focus 2 *)
unfold table_get in H5; fold @table_get in H5.
rewrite if_true in H5; auto.
simpl in H5.
inv H5.
exists (vars,f).
split.
simpl.
rewrite if_true; auto. split; auto. split; auto. apply nodups_norepet. auto.
simpl fst; simpl snd.
hnf; intros.
destruct H1 as [_ H1].
specialize (H1 a'0).
replace (fun s : env =>
           call (nargs', fun s0 : env => Q s0 && funassert G) (map s vars))
 with (fun s : env => call (nargs', Q) (map s vars) && funassert G).
apply H1.
extensionality s. forget (map s vars) as vl.
clear.
apply pred_ext; intros ? ?.
destruct H as [[? ?] ?].
split. apply H. simpl snd in *. split; auto.
destruct H. simpl fst in *; simpl snd in *.
destruct H0; split; auto. split; auto.
Qed.

Lemma semax_G:
   forall vars G P c, semax vars G (fun s => P s && funassert G) c -> semax vars G P c.
Proof.
  intros. destruct H; split; auto.
  intro; specialize (H0 n).
  replace (fun s : env => P s && funassert G) with (fun s : env => P s && funassert G && funassert G);
       auto.
  extensionality s.
  rewrite andp_assoc. f_equal. apply andp_dup.
Qed.

Lemma semax_go:  forall vars G (P: funspec) x ys,
    typecheck vars (Go x ys) = true ->
    semax vars G (fun s => cont P (eval x s) && call P (eval_list ys s)) (Go x ys) .
Proof.
 intros. rename H into TC.
  split; auto.
   intro n; hnf.
   rewrite semax'_unfold.
  intros p G0.
  hnf. intros n' ? ?.
  clear n H.
  intros s w ? w' ?.
  rewrite andp_assoc.
  intros [[H4 H5] [_ GUARDIAN]].
  pose (H3:=True).
  clear G. rename G0 into G.
  remember (eval x s) as v'.
  destruct (funassert_get G v' P w') as [P' [H2 H2']].
  split; auto.
  generalize (H0 _ _ _ _ (necR_refl _) H2'); intro. clear H2'.
  destruct H6 as [[formals k] [[H6 [H6' H6'']] ?]].
  hnf in H6.
 rewrite semax'_unfold in H7.
  apply assert_safe0; intros w'' Hw''.
  assert (LATER: laterR n' (level w'')).
    apply later_nat; apply necR_level in H1; apply age_level in Hw''.
   unfold R.rmap in *; omega. specialize (H2 (eval_list ys s)).
  red in H2. red in H2. red in H2.
  specialize (H2 _ (t_step _ _ _ _ Hw'' )).
  specialize (H7 _ LATER).
  apply (pred_nec_hereditary _ _ _ (laterR_necR LATER)) in H0.
  specialize (H7 p G _ (necR_refl _) H0). clear H0.
  simpl fst in *. simpl snd in *.
  do 3 red in H2.
  apply (pred_hereditary _ _ _ Hw'') in H5.
  specialize (H2 _ (le_refl _)).
  specialize (H7 (locals2env (mk_locals formals (eval_list ys s))) _ (le_refl _) _ (necR_refl _)).
  clear n' H LATER.
  intros ? ? VC L H. rewrite <- L in *. clear L s. rename s' into s.
  assert (step p (s,h, Go x ys) = Some ((mk_locals formals (eval_list ys (locals2env s)), h), k)).
  simpl.
  simpl typecheck in TC.
  rewrite andb_true_iff in TC; destruct TC as [TC1 TC2].
  rewrite (eval_expr_get vars s h x); auto. rewrite <- Heqv'.
  simpl. rewrite H6.  simpl.
  rewrite (eval_expr_get_list vars s h ys); auto.
  rename Hw'' into H12.
  rewrite (age_level _ _ H12).
  rewrite (safeN_step _ _ _ _ H0).
  clear w H1.
  pose (H11:=True).
  spec H7.
  eapply pred_hereditary in GUARDIAN; eauto.
  split; auto.
  split.
  hnf. rewrite map_length. simpl fst. auto.
  split; auto.
  destruct H2 as [? _].
  specialize (H1 _ (necR_refl _) H5).
  simpl.
  unfold call in H1. simpl in H1.
  Transparent arguments.
  unfold arguments in *.
  Opaque arguments.
  replace (map (locals2env (mk_locals formals (eval_list ys (locals2env s)))) formals)
     with (eval_list ys (locals2env s)); [ apply H1 | ].
  destruct H5 as [Hlen H5]. hnf in Hlen.
  assert (length (eval_list ys (locals2env s)) = length formals).
    rewrite H6'. auto.
  forget (eval_list ys (locals2env s)) as vs.
  clear - H2 H6''.
  revert vs H2; induction H6''; intros; destruct vs; inv H2; simpl; auto.
  f_equal. unfold locals2env; simpl. rewrite if_true by auto. auto.
 pattern vs at 1; rewrite (IHH6'' vs) by auto.
 forget (mk_locals tl vs) as y.
 clear - H. induction tl; simpl; auto. f_equal; simpl.
 unfold locals2env; simpl.
 rewrite if_false by (contradict H; simpl in *; intuition). auto.
 apply IHtl. intuition.
  apply H7; auto.
  apply varcompat_mk_locals. unfold eval_list. rewrite map_length. rewrite H6'; auto.
  destruct H5 as [H5 _]; hnf in H5.
  rewrite <- H5.
  clear. induction ys; simpl; omega.
  eapply pred_hereditary; eauto.
Qed.

Lemma semax_assign: forall x y c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => |> subst x (eval y s) P s) (Do x := y ; c).
Proof.
 intros until P; intros TC [TC' ?].
 split.
 simpl in *. destruct y; inv TC; simpl; auto; try rewrite TC'; try rewrite H1; auto.
 intro; intros.
 unfold subst.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [[H6 H6'] H4].
 pose (H5:=True).
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 apply (pred_hereditary _ _ _ H7) in H8.
 specialize (H6 _ (t_step _ _ _ _ H7)).
 apply (pred_hereditary _ _ _ H7) in H4.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 apply (pred_nec_hereditary _ _ _ H10) in H1.
 clear n' w H3 H2 H0 H10.
 hnf in H5.
 assert (step p ((s,h), Do (Var x) := y; c) = Some ((table_set x (eval y (locals2env s)) s, h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto.
 apply (safeN_step _ _ _ _ H0).
  specialize (H (@level _ ag_rmap w')). rewrite semax'_unfold in H.
 specialize (H p G' _ (necR_refl _) H1).
 specialize (H (locals2env (@table_set var _ EqDec_var x (eval y (locals2env s)) s))).
 specialize (H w''). spec H; [rewrite H9; omega | ].
 specialize (H _ (necR_refl _)).
 spec H. split; auto.
 replace  (locals2env (table_set x (eval y (locals2env s)) s))
   with (env_set (locals2env s) x (eval y (locals2env s))); auto.
  split; [ auto | eapply pred_hereditary; eauto].
  clear.
   extensionality i. unfold env_set. unfold locals2env at 3.
   destruct (eq_dec i x). subst. rewrite table_gss; auto. rewrite table_gso; auto.
 apply H; auto.
  clear - VC.
  intros i ?. destruct (eq_dec i x). subst. rewrite table_gss. congruence.
  rewrite table_gso by auto. apply (VC i).
  unfold vs_mem in H. apply ListSet.set_mem_correct1 in H.
  apply ListSet.set_mem_correct2. unfold vs_add in H.
  apply ListSet.set_add_elim2 in H; auto.
Qed.

Lemma semax_if: forall x c1 c2 vars G (P: assert),
    expcheck vars x = true ->
    semax vars G (fun s => !!(eval x s <> 0) && P s) c1 ->
    semax vars G (fun s => !! (eval x s = 0) && P s) c2 ->
    semax vars G P (If x Then c1 Else c2).
Proof.
 intros. rename H into TC.
 destruct H0 as [TC0 H]; destruct H1 as [TC1 H'].
 split.
 simpl; auto.
 intro.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [H5 H4].
 pose (H6:=True).
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 destruct (eq_dec (eval x (locals2env s)) 0).
 (* zero *)
 clear H; rename H' into H.
 subst.
 assert (step p ((s,h), If x Then c1 Else c2) = Some ((s,h), c2)).
 simpl. rewrite (eval_expr_get vars s h x); auto.
 rewrite e; simpl; auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 specialize (H (locals2env s) w'').
 spec H. omega.
 specialize (H _ (necR_refl _)).
 spec H.
  rewrite andp_comm.
 split. eapply pred_hereditary; eauto.
 apply (pred_hereditary _ _ _ H7) in H5.
 rewrite andp_assoc; split; [ |  apply H5].
 hnf; auto.
 apply H; auto.
 apply (pred_nec_hereditary _ _ _ (rt_step _ _ _ _ H7)); auto.
 (* nonzero *)
 subst.
 assert (step p ((s,h), If x Then c1 Else c2) = Some ((s,h), c1)).
 simpl. rewrite (eval_expr_get vars s h x); auto. simpl.  rewrite if_false; auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 specialize (H (locals2env s) w'').
 spec H. omega.
 specialize (H _ (necR_refl _)).
 spec H.
 rewrite andp_comm.
 split. eapply pred_hereditary; eauto.
 apply (pred_hereditary _ _ _ H7) in H5.
 rewrite andp_assoc; split; [ |  apply H5].
 hnf; auto.
 apply H; auto.
 apply (pred_nec_hereditary _ _ _ (rt_step _ _ _ _ H7)); auto.
Qed.

Lemma semax_load: forall x y z c vars G P,
    expcheck vars y = true ->
    semax (vs_add x vars) G P c ->
    semax vars G (fun s => ((mapsto (eval y s) z) * TT) && |> subst x z P s)
               (Do x := Mem y ; c).
Proof.
 intros until P. intros TC [TC' ?].
 split.
 simpl; auto.
 intro n.
 rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [H5 H4].
 destruct H5 as [[? HP] HG].
 unfold subst in HP.
 apply assert_safe0; intros w'' H7.
 specialize (HP _ (t_step _ _ _ _ H7)).
 intros s' h VC L ?. rewrite <- L in *; clear s L; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H8.
 assert (step p ((s,h), Do x := Mem y; c) = Some ((table_set x z s, h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto. simpl.
 replace (heap_get h (eval y (locals2env s))) with (Some z).
 auto.
 symmetry.
 apply H6. apply mapsto_e1; auto.
 apply (safeN_step _ _ _ _ H9). clear H9.
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H9 (pred_nec_hereditary _ _ _ H9 H1)).
 specialize (H (locals2env (@table_set _ _ EqDec_var x z s)) w'').
 spec H.    unfold R.rmap in *; omega.
 specialize (H _ (necR_refl _)).
 spec H. split; [split|].
  rewrite locals2env_table_set. eauto.
  eapply pred_hereditary; eauto.
  eapply pred_hereditary; eauto.
 apply H; auto.
 apply varcompat_add; auto.
 eapply pred_hereditary; eauto.
Qed.

Lemma semax_store: forall x y v c vars G (P: assert),
    expcheck vars x = true ->
    expcheck vars y = true ->
    semax vars G (fun s => mapsto (eval x s) (eval y s) * P s) c ->
    semax vars G (fun s => mapsto (eval x s) v  * P s)  (Do Mem x  := y ; c).
Proof.
 intros until P; intros TCx TCy [TC ?].
 split.
 simpl; auto.
 intro. rewrite semax'_unfold.
 intros p G' n' ? ? s w ? w' ? [[H5 H6] H4].
 apply assert_safe0; intros w'' ?.
 intros s' h VC L ?. rewrite <- L in *; clear L s; rename s' into s.
 generalize (age_level _ _ H7); intro. rewrite H9.
 assert (step p ((s,h), Do Mem x := y; c) = Some ((s, heap_set (eval x (locals2env s)) (eval y (locals2env s)) h), c)).
 simpl. rewrite (eval_expr_get vars s h y); auto. rewrite (eval_expr_get vars s h x); auto.
 apply (safeN_step _ _ _ _ H10).
 specialize (H n'). rewrite semax'_unfold in H.
 assert (necR n' (level w')). apply necR_trans with (level w); auto.
 apply nec_nat. auto. apply necR_level'. auto.
 specialize (H p G' _ H11 (pred_nec_hereditary _ _ _ H11 H1)).
 apply (pred_hereditary _ (level w') (level w'')) in H;
   [ |  apply age_level in H7; rewrite H7; hnf; simpl; auto].
 apply (pred_hereditary _ _ _ H7) in H5.
 apply (pred_hereditary _ _ _ H7) in H6.
 apply (pred_hereditary _ _ _ H7) in H4.
 apply (pred_hereditary _ _ _ H7) in H8.
 clear H1; pose (H1:=True). clear n H0. pose (H0:=True).
 clear n' H2 H11. pose (H2:=True). pose (H11:=True).
 simpl in H8.
clear w' H7 H9 H3.
 pose (H7:=True); pose (H9:=True); pose (H3:=True).
 clear H0 H1.
 destruct H5 as [wa [wb [H0 [HP H1]]]].
 pose (m' := singleton_rmap (eval x (locals2env s)) (eval y (locals2env s)) w'').
 assert (joins m' wb).
 apply resource_at_joins2. unfold m'.
 rewrite singleton_rmap_level.
 apply join_level in H0. destruct H0. auto.
 unfold m'. intro i.
 clear - HP H0.
 apply (resource_at_join _ _ _ i) in H0.
 specialize (HP i).
 unfold singleton_rmap. rewrite resource_at_make_rmap.
 destruct (eq_dec i (eval x (locals2env s))). subst; rewrite if_true in HP; auto.
 exists (YES pfullshare (VAL (eval y (locals2env s))) NoneP).
 rewrite HP in *. inv H0; try pfullshare_join. constructor.
 rewrite if_false in HP by auto.
 exists (wb @ i).
 apply HP in H0. rewrite H0.
 rewrite <- core_resource_at. apply core_unit.
 destruct H5 as [ww H12].
 replace (level w'') with (level ww) in H.
 Focus 2.
 transitivity (level wb).
 apply join_level in H12. destruct H12 as [H12 H13]. symmetry ; apply H13.
 apply join_level in H0; destruct H0; auto.
 specialize (H (locals2env s) ww).
 spec H. simpl. apply le_refl.
 specialize (H _ (necR_refl _)).
 spec H. rewrite andp_assoc. rewrite andp_comm.
 clear - H4 H0 HP H12 H6 H1.
 assert (app_pred ((mapsto (eval x (locals2env s)) v * TT) && (funassert G && funassert G')) w'').
 split; auto. exists wa; exists wb; split3; auto. split; auto.
 destruct H as [? _].
 split.
 apply join_comm in H0. apply join_comm in H12. apply join_core in H0. apply join_core in H12.
 apply funassert_core in H6. apply funassert_core in H4. rewrite H12 in H0.
 split; apply funassert_core; rewrite H0; auto.
 destruct H as [wa' [wb' [? [? ?]]]].
 assert (wa' = wa). eapply mapsto_uniq; eauto.
 apply join_core in H0; apply join_core in H. rewrite H0; rewrite H. auto.
 subst wa'. generalize (join_canc (join_comm H0) (join_comm H)); intro; subst wb'.
  generalize (singleton_rmap_mapsto (eval x (locals2env s)) (eval y (locals2env s)) w''); intro.
 assert (app_pred (mapsto (eval x (locals2env s)) (eval y (locals2env s)) * (TT && (funassert G && funassert G'))) ww).
 exists m'; exists wb; split3; auto.
 split; auto.
 apply join_comm in H0. apply join_comm in H12. apply join_core in H0. apply join_core in H12.
  apply funassert_core in H6. apply funassert_core in H4.
 split; apply funassert_core; rewrite H0; auto.
 exists m'; exists wb; split3; auto.
 replace (level w'') with (level ww).
 Focus 2. simpl. transitivity (level wb).
 clear - H12; apply join_level in H12; destruct H12; symmetry; apply H0.
 clear - H0; apply join_level in H0; destruct H0; apply H0.
 apply H; auto.
 intros i v0. specialize (HP i).
 simpl.
 apply (resource_at_join _ _ _ i) in H12.
 unfold m' in *; clear m'.
 unfold singleton_rmap in H12.
 rewrite resource_at_make_rmap in H12.
 change AV.address with adr in H12.
  specialize (H8 i v0). simpl in H8.

  destruct (eq_dec i (eval x (locals2env s))).
  subst. rewrite heap_gss.
  apply join_unit2_e in H12. rewrite <- H12.
  split; intro Hx; inv Hx; auto.
  apply YES_join_full in H12; auto.
  rewrite H12. apply NO_identity.
  apply join_unit1_e in H12; [ | rewrite <- core_resource_at; apply core_identity].
  rewrite heap_gso; auto.
 apply (resource_at_join _ _ _ i) in H0.
 rewrite <- H12.
 apply HP in H0. rewrite H0; auto.
Qed.

Lemma semax_pre:
  forall P P' vars G c, (forall s, P s |-- P' s) -> semax vars G P' c -> semax vars G P c.
Proof.
 intros. destruct H0 as [TC H0]; split; auto.
 intro n; specialize (H0 n).
 rewrite semax'_unfold in *.
 intros p G'. specialize (H0 p G').
 intros n' ? ?. specialize (H0 _ H1 H2).
 intros s w ? ? ? ?. specialize (H0 s _ H3 _ H4).
 apply H0.
 destruct H5; split; auto. destruct H5;  split; auto. apply H; auto.
Qed.

Lemma semax_exp: forall {A} vars G (P: A -> assert) c,
    typecheck vars c = true ->
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.
Proof.
 intros ? ? ? ? ? TC ?.
 split; auto.
 intro.
 rewrite semax'_unfold.
 intros p G'. intros n' ? ?.
 intros s. intros ? ?. intros ? ?. intros [[[v ?] ?] ?].
 specialize (H v). destruct H as [_ H].
 rewrite semax'_unfold in H. eapply H; eauto. split; auto. split; auto.
Qed.

Lemma semax_exp': forall {A} (any: A) vars G (P: A -> assert) c,
    (forall v:A, semax vars G (P v) c) ->
    semax vars G (fun s => EX v:A, (P v s)) c.
Proof.
 intros ? ? ? ? ? ?.
 split; auto.
 destruct (H any); auto.
 intro.
 rewrite semax'_unfold.
 intros p G'. intros n' ? ?.
 intros s. intros ? ?. intros ? ?. intros [[[v ?] ?] ?].
 specialize (H v). destruct H as [_ H].
 rewrite semax'_unfold in H. eapply H; eauto. split; auto. split; auto.
Qed.

Lemma semax_prop:
  forall (R: Prop) vars G P c,
      typecheck vars c = true ->
      (R -> semax vars G P c) ->
      semax vars G (fun s => !! R && P s) c.
Proof.
  intros R vars G P c TC ?. split; auto. intro n.  rewrite semax'_unfold. intros p G'.
  intros n' ? ? b w ? w' ? [[[? ?] ?] ?].
  destruct (H H4).
  specialize (H9 n). rewrite semax'_unfold in H9.
  eapply H9; eauto. split; auto. split; auto.
Qed.

Definition program_proved (p: program) :=
   exists G, semax_func G p G  /\ table_get G 0 = Some (0::nil, fun s => allocpool (eval (Var 0) s)).

Lemma semax_sound:
  forall p, program_proved p -> forall n, run p n <> None.
Proof.
  intros.
  destruct H as [G [[? ?] ?]].
  generalize (funassert_make_world p G n); intro.
  destruct (semax_go nil G  (0::nil, fun s => allocpool (eval (Var 0) s))
                (Const 0) (Const (boundary p) :: nil) (eq_refl _)) as [_ ?].
  specialize (H3 n).
  rewrite semax'_unfold in H3.
  specialize (H3 p G _ (necR_refl _) (H0 _) (locals2env nil)
                    (make_world G (initial_heap p) n)).
  spec H3. rewrite level_make_world. auto.
  specialize (H3 _ (necR_refl _)).
  spec H3.
  split; auto.
  split; auto.
  split.
  apply (funassert_e _ _ _ H1 _ H2).
  unfold call.
  Transparent arguments. unfold arguments. Opaque arguments.
  simpl snd.
  unfold locals2env, table_get. rewrite if_true; auto.
  split. simpl; auto.
  apply allocpool_make_world; auto.
  hnf in H3.
  specialize (H3 nil (initial_heap p)).
  spec H3. intros i ?. inv H4.
  spec H3. auto.
  spec H3. apply cohere_make_world; auto.
  unfold run; intro.
  destruct H3 as [sk' ?].
  rewrite level_make_world in H3.
 unfold locals,table, var,adr in H3,H4. rewrite H3 in H4; inv H4.
Qed.

End Semax.


Require Import Heaps.
Require SepExpr Expr.
Require Import Provers.
Require Import EquivDec.
Require Import List.
    Require Import ReifySepExpr.
    Require ExprUnify.
Require SepCancel.

Set Implicit Arguments.

Module SepExprTests (B : Heap) (ST : SepTheoryX.SepTheoryX with Module H := B).
  Module Sep := SepExpr.Make ST.
  Module Reify := ReifySepExpr Sep.
  Module SH := SepHeap.Make Sep.
  Module CANCEL := SepCancel.Make ExprUnify.UNIFIER SH.

  (** Just a test separation logic predicate **)
  Section Tests.
    Variable f : forall a b, nat -> ST.hprop a b nil.
    Variable h : forall a b, nat -> ST.hprop a b nil.
    Variable i : forall a b, nat -> ST.hprop a b nil.
    Variable g : bool -> nat -> nat -> nat.

    Ltac isConst e :=
      match e with
        | true => true
        | false => true
        | O => true
        | S ?e => isConst e
        | _ => false
      end.

    Fixpoint all a b (f : nat -> ST.hprop a b nil) (n : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f 0
        | S n => ST.star (f (S n)) (all f n)
      end.

    Fixpoint allb a b (f : nat -> ST.hprop a b nil) (n m : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f m
        | S n => ST.star (f (m - S n)) (allb f n m)
      end.

    Theorem asdf : forall x y : nat, EqNat.beq_nat x y = true -> x = y.
    Admitted.

    Definition nat_type : Expr.type :=
      {| Expr.Impl := nat
       ; Expr.Eqb  := EqNat.beq_nat
       ; Expr.Eqb_correct := asdf
       |}.

    Fixpoint star_all a b (f : nat -> ST.hprop a b nil) (n : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f 0
        | S n => ST.star (f (S n)) (star_all f n)
      end.

    Definition N := 20.
    Definition M := 20.

    Variables pc st : Type.

    Definition try_it_out {ts} (pcV stV : Expr.tvar) (preds : CANCEL.SE.predicates ts pcV stV) (l r : Sep.sexpr ts pcV stV) :
      (SH.SHeap ts pcV stV * SH.SHeap ts pcV stV * ExprUnify.UNIFIER.Subst ts) :=
      let l := SH.hash l in
      let r := SH.hash r in
      @CANCEL.sepCancel ts pcV stV preds (ReflexivityProver.reflexivityProver) 1 tt (snd l) (snd r) (ExprUnify.UNIFIER.Subst_empty _).

    Theorem apply_it ts pcT stT funcs (preds : CANCEL.SE.predicates ts pcT stT) l r cs :
      (let '(l',r',_) := @try_it_out ts pcT stT preds l r in
       @ST.himp (Expr.tvarD ts pcT) (Expr.tvarD ts stT) cs
         (@Sep.sexprD ts pcT stT funcs preds nil nil (SH.sheapD l')) (@Sep.sexprD ts pcT stT funcs preds nil nil (SH.sheapD r'))) ->
      @ST.himp (Expr.tvarD ts pcT) (Expr.tvarD ts stT) cs
        (@Sep.sexprD ts pcT stT funcs preds nil nil l) (@Sep.sexprD ts pcT stT funcs preds nil nil r).
    Proof.
    Admitted.

    Ltac go :=
      match goal with
        | [ |- ST.himp _ ?L ?R ] =>
          let Ts := constr:(Reflect.Tcons pc (Reflect.Tcons st Reflect.Tnil)) in
          Reify.collectTypes_sexpr ltac:(isConst) L Ts ltac:(fun Ts =>
          Reify.collectTypes_sexpr ltac:(isConst) R Ts ltac:(fun Ts =>
          let types := ReifyExpr.extend_all_types Ts (nat_type :: @nil Expr.type) in
          let uvars := eval simpl in (@nil _ : Expr.env types) in
          let gvars := uvars in
          let vars := eval simpl in (@nil Expr.tvar) in
          (** build the funcs **)
          let funcs := constr:(@nil (Expr.signature types)) in
          let pcT := constr:(Expr.tvType 1) in
          let stT := constr:(Expr.tvType 2) in
          (** build the base sfunctions **)
          let preds := constr:(@nil (Sep.predicate types pcT stT)) in
          Reify.reify_sexpr ltac:(isConst) L types funcs pcT stT preds uvars vars ltac:(fun uvars funcs preds L =>
          Reify.reify_sexpr ltac:(isConst) R types funcs pcT stT preds uvars vars ltac:(fun uvars funcs preds R =>
            simple apply (@apply_it types pcT stT funcs preds L R); compute
          ))))
      end.

    Goal let N := 1 in
      forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) N N))
      (ST.star (all (@f pc st) N) (all (@h pc st) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 5 in
      forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) N N))
      (ST.star (all (@f pc st) N) (all (@h pc st) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 10 in
      forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) N N))
      (ST.star (all (@f pc st) N) (all (@h pc st) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 15 in
      forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) N N))
      (ST.star (all (@f pc st) N) (all (@h pc st) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 20 in
      forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) N N))
      (ST.star (all (@f pc st) N) (all (@h pc st) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

(*
    Goal forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) M M))
      (ST.star (all (@f pc st) M) (all (@h pc st) N)).
      unfold N, M; simpl all; simpl allb; intros.
      Time go. reflexivity.
      Time Qed.
*)

(*

    Goal forall c, @ST.himp pc st c
      (ST.star (allb (@h pc st) N N) (allb (@f pc st) M M))
      (ST.star (all (@f pc st) M) (all (@h pc st) N)).
      unfold N, M; simpl all; simpl allb; intros.
      Time ltac_canceler.
    Time Qed.

Time Sep.sep isConst (nat_type :: nil). reflexivity.

    Goal forall a b c x y, @ST.himp a b c (f _ _ (g y (x + x) 1)) (f _ _ 1).
      sep.
    Abort.

    Theorem t1 : forall a b c, @ST.himp a b c (f _ _ 0) (f _ _ 0).
      sep.
    Qed.

    Theorem t2 : forall a b c,
      @ST.himp a b c (ST.star (star_all_back (@h a b) 15 15) (star_all_back (@f a b) 15 15))
                     (ST.star (star_all (@f a b) 15) (star_all (@h a b) 15)).
      sep.
    Qed.

    Theorem t3 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ 2) (f _ _ 1))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t4 : forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => ST.ex (fun x : bool => ST.star (f _ _ (g x 1 2)) (f _ _ 1) )))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t5 : forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => f _ _ y))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t6 : forall a b c, @ST.himp a b c
      (f _ _ 1)
      (ST.ex (fun y : nat => f _ _ y)).
      sep.
    Qed.

    Theorem t7 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ (g true 0 1)) (f _ _ (g true 1 2)))
      (ST.ex (fun y : nat => ST.star (f _ _ (g true 0 y)) (ST.ex (fun z : nat => f _ _ (g true 1 z))))).
      sep.
    Qed.

    Theorem t8 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ (g true 0 1)) (f _ _ (g true 1 2)))
      (ST.ex (fun y : nat => ST.star (f _ _ (g true 1 y)) (ST.ex (fun z : nat => f _ _ (g true 0 z))))).
      sep.
    Qed.

    (** ** Test use of transitivity prover in cancellation *)

    Theorem t9 : forall a b c x y, x = y
      -> @ST.himp a b c  (f _ _ x) (f _ _ y).
      sep.
    Qed.

    Theorem t10 : forall a b c x y, x = y
      -> @ST.himp a b c  (f _ _ y) (f _ _ x).
      sep.
    Qed.

    Theorem t11 : forall a b c x y z, x = y
      -> x = z
      -> @ST.himp a b c  (f _ _ x) (f _ _ y).
      sep.
    Qed.

    Theorem t12 : forall a b c x y u v, x = y
      -> u = v
      -> @ST.himp a b c  (ST.star (f _ _ x) (f _ _ v)) (ST.star (f _ _ y) (f _ _ u)).
      sep.
    Qed.

    Theorem t13 : forall a b c x y z u v, x = y
      -> z = y
      -> u = v
      -> @ST.himp a b c  (ST.star (f _ _ x) (f _ _ v)) (ST.star (f _ _ z) (f _ _ u)).
      sep.
    Qed.
*)

  End Tests.

End SepExprTests.


Require Import maps.
Require Import patterns.

(* This module defines a zipper over patterns to
   allow moving terms of interest to the front by reflection
   rather than by assembling large proof terms.
 *)

Inductive pat_context {Key Elt : Type} : Type :=
    Top
  | LeftOf (p : MapPattern Key Elt) (rest : pat_context)
  | RightOf (p : MapPattern Key Elt) (rest : pat_context)
  .

Fixpoint close {Key Elt} pat ctx : MapPattern Key Elt :=
  match ctx with
    | Top => pat
    | LeftOf p ctx' => close (pat :* p)%pattern ctx'
    | RightOf p ctx' => close (p :* pat)%pattern ctx'
  end.

Fixpoint close_empty {Key Elt} ctx : MapPattern Key Elt :=
  match ctx with
    | Top => mapEmpty%pattern
    | LeftOf p ctx' => close p ctx'
    | RightOf p ctx' => close p ctx'
  end.

Lemma lifting : forall {Key Elt} ctx (p : MapPattern Key Elt),
  PatEquiv (close p ctx) (p :* close_empty ctx).
induction ctx;simpl;intros.
rewrite patEquivUnit. reflexivity.
rewrite 2 IHctx, patEquivAssoc; reflexivity.
rewrite 2 IHctx, patEquivAssoc, patEquivCommAssoc; reflexivity.
Qed.

(* Search through a MapPattern pat for
   the given term target, adding the context
   passed through onto context ctx,
   and ending on success by calling the
   continuation k with the pattern found and
   the constructed context.
 *)
Ltac quote_zipper target pat ctx k :=
  first [unify target pat;k pat ctx
   |  match pat with
      | (?l :* ?r)%pattern =>
          first [let ctx' := constr:(LeftOf r ctx) in
                 quote_zipper target l ctx' k
                |let ctx' := constr:(RightOf l ctx) in
                 quote_zipper target r ctx' k
                ]
      | (asP ?h ?P)%pattern =>
          unify target P;k pat ctx
  end].

(*
Lemma lift_constraint : forall {Key Elt} (h : Map Key Elt) ctx P,
  h |= close (constraint P) ctx <-> (P /\ h |= close_empty ctx).
intros.
rewrite lifting.
(* now extract the P *)
Transparent satisfies.
simpl.
Opaque satisfies.
firstorder.
revert H0;apply pats_good. equate_maps.
eexists;eexists. firstorder (eauto || equate_maps).
Qed.
 *)