Set Implicit Arguments.
Require Import Omega Logic List Classes.Morphisms.
Import List Notations.

From cbpv Require Import base syntax.

Scheme value_ind_2 := Induction for value Sort Prop
  with comp_ind_2  := Induction for comp Sort Prop.

Combined Scheme mutind_val_comp from value_ind_2, comp_ind_2.

(** * CBPV Types *)
(**
  Types of CBPV terms.
  Values in valtype are types of values
  and values in comptype are types of computations
*)
(** ** Value Types*)
Inductive valtype : Type :=
| zero: valtype
| one: valtype
| U: comptype -> valtype
| Sigma: valtype -> valtype -> valtype
| cross: valtype -> valtype -> valtype

(** ** Computation Types*)
with comptype : Type :=
| cone: comptype
| F: valtype -> comptype
| Pi: comptype -> comptype -> comptype
| arrow: valtype -> comptype -> comptype.

(** Combined induction schemes for types *)
Scheme valtype_ind_2 := Induction for valtype Sort Prop
  with comptype_ind_2  := Induction for comptype Sort Prop.

Combined Scheme mutind_valtype_comptype from valtype_ind_2, comptype_ind_2.

(** ** Ground Types*)
(** Ground Types, they only contain One, Sums and Pairs *)
Inductive groundtype : Type :=
| gone : groundtype
| gsum : groundtype -> groundtype -> groundtype
| gcross : groundtype -> groundtype -> groundtype.

(** We use the follwing obvious mapping from ground types to valtypes as a coercion,
    which hepls the notion on paper that every ground type is a valtype *)
Fixpoint to_valtype (G: groundtype) :=
  match G with
  | gone => one
  | gsum G1 G2 => Sigma (to_valtype  G1) (to_valtype  G2)
  | gcross G1 G2 => cross (to_valtype  G1) (to_valtype  G2)
  end.

Coercion to_valtype: groundtype >-> valtype.

Fixpoint nat_to_fin {m: nat} (n: nat)  : fin (S (it S n m)) :=
  match n with
  | O => var_zero
  | S n => Some (nat_to_fin n)
  end.

Definition var {m: nat} (n: nat) : value (S (it S n m)) :=
  var_value (nat_to_fin n).

(** We use the following notations for terms  *)
Notation "<{ c }>" := (thunk c).
Notation "c !" := (force c) (at level 50).
Notation "$ <- A ; B" := (letin A B) (at level 55).
Notation "⦉ A ; B ⦊" := (pair A B) (at level 52). (* used to be langle *)
Notation "A → B" := (arrow A B) (at level 53).
Notation "A * B" := (cross A B).
Coercion app : comp >-> Funclass.


Require Export Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Common.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.Notations.
Require Import Fiat.Common.BoolFacts.

Set Implicit Arguments.
Local Open Scope grammar_fixedpoint_scope.

Lemma state_beq_lb {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s s' : state) (H : s = s') : s =b s'.
Proof.
  subst; reflexivity.
Qed.

Lemma state_beq_refl {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s : state) : s =b s.
Proof.
  reflexivity.
Qed.

Lemma state_le_refl {prestate} {fp : grammar_fixedpoint_lattice_data prestate} (s : state) : s <= s.
Proof.
  unfold state_le.
  rewrite state_beq_lb by reflexivity.
  reflexivity.
Qed.

Global Instance state_lt_Irreflexive {T d} : Irreflexive (@state_lt T d).
Proof.
  intros x H.
  induction (state_gt_wf x) as [x H' IH].
  eauto.
Qed.

Global Instance state_le_Reflexive {T d} : Reflexive (@state_le T d).
Proof.
  unfold state_le; repeat intro; rewrite state_beq_refl; reflexivity.
Qed.

Global Instance state_beq_Proper_Proper {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : Proper (state_beq ==> state_beq ==> eq) state_beq.
Proof.
  intros a b H a' b' H'.
  destruct (b =b b') eqn:H'';
    fold_is_true.
  { etransitivity; [ eassumption | ].
    etransitivity; [ eassumption | ].
    symmetry; assumption. }
  { destruct (a =b a') eqn:H'''; trivial;
    rewrite <- H''; clear H''; symmetry;
    fold_is_true.
    etransitivity; [ | eassumption ].
    etransitivity; [ | eassumption ].
    symmetry; assumption. }
Qed.

Global Instance state_beq_Proper_le {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : Proper (state_beq ==> state_beq ==> eq) state_le.
Proof.
  intros a b H a' b' H'.
  unfold state_le.
  rewrite H, H'.
  reflexivity.
Qed.

Global Instance beq_subrelation_le {prestate} {d : grammar_fixedpoint_lattice_data prestate}
  : subrelation state_beq state_le.
Proof.
  intros ?? H.
  setoid_rewrite H.
  reflexivity.
Qed.

Global Instance state_le_Transitive {T d} : Transitive (@state_le T d).
Proof.
  unfold state_le, is_true; repeat intro;
    rewrite Bool.orb_true_iff in *;
    destruct_head or;
    repeat match goal with
           | [ H : context[?x = true] |- _ ] => progress fold (is_true x) in *
           | [ |- context[?x = true] ] => progress fold (is_true x) in *
           | [ H : is_true (?x =b ?y) |- _ ] => rewrite H in *; clear x H
           | _ => left; reflexivity
           | _ => solve [ eauto ]
           | _ => right; etransitivity; eassumption
           end.
Qed.

Lemma bottom_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : ⊥ <= s.
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : s <= ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma no_state_lt_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s < ⊥) = false.
Proof.
  destruct s; reflexivity.
Qed.

Lemma no_state_gt_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ < s) = false.
Proof.
  destruct s; reflexivity.
Qed.

Lemma state_le_bottom_eq_bottom {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s <= ⊥) = (s =b ⊥).
Proof.
  destruct s; reflexivity.
Qed.

Lemma state_ge_top_eq_top {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ <= s) = (s =b ⊤).
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_lub_r {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s ⊔ ⊤) = ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma top_lub_l {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊤ ⊔ s) = ⊤.
Proof.
  destruct s; reflexivity.
Qed.

Lemma bottom_lub_r {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (s ⊔ ⊥) = s.
Proof.
  destruct s; reflexivity.
Qed.

Lemma bottom_lub_l {prestate} {d : grammar_fixedpoint_lattice_data prestate} (s : state)
  : (⊥ ⊔ s) = s.
Proof.
  destruct s; reflexivity.
Qed.

Global Instance state_le_Proper_le {state} {d : grammar_fixedpoint_lattice_data state}
: Proper (@state_le _ d ==> Basics.flip (@state_le _ d) ==> Basics.flip Basics.impl) (@state_le _ d).
Proof.
  unfold Basics.flip; intros ?? H ?? H' H''.
  repeat first [ eassumption | etransitivity; [ eassumption | ] ].
Qed.

Global Instance state_le_Proper_le' {state} {d : grammar_fixedpoint_lattice_data state}
: Proper (@state_le _ d ==> Basics.flip (@state_le _ d) ==> Basics.flip implb) (@state_le _ d).
Proof.
  unfold Basics.flip; intros (*?? [??]*) ?? H ?? H'; subst.
  match goal with |- is_true (implb ?v _) => destruct v eqn:?; simpl; [ | reflexivity ] end.
  repeat first [ eassumption | etransitivity; [ eassumption | ] ].
Qed.

Global Instance state_le_flip_Reflexive {state} {d : grammar_fixedpoint_lattice_data state}
: Reflexive (Basics.flip (@state_le _ d)) | 2.
Proof.
  unfold Basics.flip; intro; reflexivity.
Qed.

Global Instance prestate_le_Antisymmetric {prestate} {fpdata : grammar_fixedpoint_lattice_data prestate}
  : Antisymmetric _ prestate_beq prestate_le.
Proof.
  unfold prestate_le.
  intros x y H0 H1.
  bool_congr_setoid.
  destruct H0 as [H0|H0]; [ | destruct H1 as [H1|H1] ];
    [ assumption
    | symmetry; assumption
    | ].
  exfalso; eapply no_wf_cycle; [ eexact prestate_gt_wf | | ];
    unfold flip; eassumption.
Qed.

Global Instance state_le_Antisymmetric {prestate} {fpdata : grammar_fixedpoint_lattice_data prestate}
  : Antisymmetric _ state_beq state_le.
Proof.
  unfold state_le.
  intros x y H0 H1.
  bool_congr_setoid.
  destruct H0 as [H0|H0]; [ | destruct H1 as [H1|H1] ];
    [ assumption
    | symmetry; assumption
    | ].
  exfalso; eapply no_wf_cycle; [ eexact state_gt_wf | | ];
    unfold flip; eassumption.
Qed.

Global Instance state_beq_Proper_eq {a b}
  : Proper (eq ==> eq ==> eq) (@state_beq a b)
  := _.


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

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

Require Import ssreflect.

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

Class foo (T : Type) := { n : nat }.
Instance five : foo nat := {| n := 5 |}.

Definition bar T {f : foo T} m : Prop :=
  @n _ f = m.

Eval compute in (bar nat 7).

Lemma a : True.
set toto := bar _ 8.
have titi : bar _ 5.
  reflexivity.
have titi2 : bar _ 5 := .
  Fail reflexivity.
  by myadmit.
have totoc (H : bar _ 5) : 3 = 3 := eq_refl.
move/totoc: nat => _.
exact I.
Qed.

Set SsrHave NoTCResolution.

Lemma a' : True.
set toto := bar _ 8.
have titi : bar _ 5.
  Fail reflexivity.
  by myadmit.
have titi2 : bar _ 5 := .
  Fail reflexivity.
  by myadmit.
have totoc (H : bar _ 5) : 3 = 3 := eq_refl.
move/totoc: nat => _.
exact I.
Qed.


Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Sorting.Permutation.
Import ListNotations.
Require Import SImpECommon.
Require Import SImpE.

(*******************************************************************************
*
* SYNTAX
*
*******************************************************************************)

Section Syntax.
  Inductive val2 : Type :=
  | VSingle: val -> val2
  | VPair: val -> val -> val2.

  Definition not_pair_val (v : val2) : Prop :=
    match v with
    | VPair _ _ => False
    | _ => True
    end.
End Syntax.

(*******************************************************************************
*
* SEMANTICS
*
*******************************************************************************)

Section Semantics.
  Definition reg2 : Type := register val2.
  Definition reg_init2 : reg2 := fun x => VSingle (Vnat 0).
  Definition mem2 : Type := memory val2.

  Inductive event2 : Type :=
  | Emp2 : event2
  | Decl2 : exp -> mem2 -> event2
  | Mem2 : mem2 -> event2
  | Out2 : sec_level -> val2 -> event2
  | Update2 : mem2 -> location -> val2 -> event2
  | Assign2 : reg2 -> var -> val2 -> event2
  | ANonEnc2 : com -> event2
  | AEnc2 : forall c c' : com, enc_equiv c c' -> event2
  | EPair : event2 -> event2 -> event2.
  Definition trace2 : Type := list event2.

  Definition val_to_val2 (v: val) : val2 := VSingle v.
  Definition mem_to_mem2 (m: mem) : mem2 := fun x => val_to_val2 (m x).
  Definition reg_to_reg2 (r: reg) : reg2 := fun x => val_to_val2 (r x).
  Function merge_reg (r1 r2 : reg) : reg2 :=
    fun x =>
      if (val_decidable (r1 x) (r2 x)) then VSingle (r1 x) else VPair (r1 x) (r2 x).
  Function merge_mem (m1 m2 : mem) : mem2 :=
    fun l =>
      if (val_decidable (m1 l) (m2 l)) then VSingle (m1 l) else VPair (m1 l) (m2 l).

  Definition event_to_event2 (e: event) : event2 :=
    match e with
      | Mem m => Mem2 (mem_to_mem2 m)
      | Decl e m => Decl2 e (mem_to_mem2 m)
      | Out l v => Out2 l (val_to_val2 v)
      | Update m l v => Update2 (mem_to_mem2 m) l (val_to_val2 v)
      | Assign r x v => Assign2 (reg_to_reg2 r) x (val_to_val2 v)
      | ANonEnc c => ANonEnc2 c
      | AEnc c1 c2 enc_equiv => AEnc2 c1 c2 enc_equiv
      | Emp => Emp2
    end.
  Definition tracepair_len (t: trace * trace) := length (fst t) + length (snd t).
  Function merge_trace (t: trace * trace) {measure tracepair_len t} : trace2 :=
    match fst t, snd t with
    | a1::tl1, a2::tl2 => EPair (event_to_event2 a1)
                                 (event_to_event2 a2) :: (merge_trace (tl1, tl2))
    | a1::tl1, [] => EPair (event_to_event2 a1) Emp2 :: merge_trace (tl1, [])
    | [], a2::tl2 => EPair Emp2 (event_to_event2 a2) :: merge_trace ([], tl2)
    | _, _ => []
    end.
  Proof. all: intros; unfold tracepair_len; rewrite teq, teq0; simpl; omega. Qed.

  Function project_value (v: val2) (is_left: bool): val :=
    match v with
    | VPair v1 v2 => if is_left then v1 else v2
    | VSingle v => v
    end.
  Definition project_reg (r: reg2) (is_left : bool): reg :=
    fun x => match r x with
             | VPair v1 v2 => if is_left then v1 else v2
             | VSingle v => v
          end.
  Definition project_mem (m: mem2) (is_left : bool): mem :=
    fun x => match m x with
             | VPair v1 v2 => if is_left then v1 else v2
             | VSingle v => v
          end.

  Function event2_to_event (e: event2) (is_left: bool): event :=
     match e with
      | Mem2 m => Mem (project_mem m is_left)
      | Decl2 e m => Decl e (project_mem m is_left)
      | Out2 l v => Out l (project_value v is_left)
      | Update2 m l v => Update (project_mem m is_left) l (project_value v is_left)
      | Assign2 r x v => Assign (project_reg r is_left) x (project_value v is_left)
      | ANonEnc2 c => ANonEnc c
      | AEnc2 c1 c2 enc_equiv => AEnc c1 c2 enc_equiv
      | EPair e1 e2 => if is_left then event2_to_event e1 is_left
                        else event2_to_event e2 is_left
      | Emp2 => Emp
     end.
  Function project_trace (t: trace2) (is_left : bool) : trace :=
    match t with
    | [] => []
    | hd :: tl => let hd_proj := (event2_to_event hd is_left) in
      match hd_proj with
      | Emp => project_trace tl is_left
      | _ => hd_proj :: project_trace tl is_left
      end
    end.

  Definition econfig2 : Type := exp * reg2 * mem2.
  Definition ecfg_exp2 (ecfg: econfig2) : exp :=
    match ecfg with (e, _, _) => e end.
  Definition ecfg_reg2 (ecfg: econfig2) : reg2 :=
    match ecfg with (_, r, _) => r end.
  Definition ecfg_mem2 (ecfg: econfig2) : mem2 :=
    match ecfg with (_, _, m) => m end.
  Definition ecfg_update_exp2 (ecfg: econfig2) (e: exp) : econfig2 :=
    match ecfg with (_, r, m) => (e, r, m) end.
  Definition esemantics2 : Type := mode -> loc_mode -> econfig2 -> val2 -> Prop.

   Definition project_ecfg (ecfg : econfig2) (is_left : bool) : econfig :=
    (ecfg_exp2 ecfg, project_reg (ecfg_reg2 ecfg) is_left,
     project_mem (ecfg_mem2 ecfg) is_left).

   Definition contains_nat (v : val2) :=
     (exists n1, v = VSingle (Vnat n1)) \/
     (exists n1 n2, v = VPair (Vnat n1) (Vnat n2)).

   Fixpoint apply_op (op : nat -> nat -> nat) (v1 v2 : val2) :=
     match v1, v2 with
     | VSingle (Vnat n1), VSingle (Vnat n2) => VSingle (Vnat (op n1 n2))
     | VSingle (Vnat n1), VPair (Vnat n2) (Vnat n3) => VPair (Vnat (op n1 n2)) (Vnat (op n1 n3))
     | VPair (Vnat n1) (Vnat n2), VPair (Vnat n3) (Vnat n4) =>
                                  VPair (Vnat (op n1 n3)) (Vnat (op n2 n4))
     | VPair (Vnat n2) (Vnat n3), VSingle (Vnat n1) => VPair (Vnat (op n2 n1)) (Vnat (op n3 n1))
     | _, _ => v1
     end.

   Definition val2_add (v1 v2 :val2) := apply_op (fun x y => x + y) v1 v2.

   Inductive estep2 : esemantics2 :=
   | Estep2_nat : forall md d ecfg n,
       ecfg_exp2 ecfg = Enat n ->
       estep2 md d ecfg (VSingle (Vnat n))
   | Estep2_loc : forall md d ecfg l,
       ecfg_exp2 ecfg = Eloc l ->
       estep2 md d ecfg (VSingle (Vloc l))
   | Estep2_lambda : forall md d ecfg c,
       ecfg_exp2 ecfg = Elambda md c ->
      estep2 md d ecfg (VSingle (Vlambda md c))
   | Estep2_var : forall md d ecfg x v,
       ecfg_exp2 ecfg = Evar x ->
       ecfg_reg2 ecfg x = v ->
       estep2 md d ecfg v
   | Estep2_add : forall md d ecfg e1 e2 v1 v2,
       ecfg_exp2 ecfg = Eadd e1 e2 ->
       estep2 md d (ecfg_update_exp2 ecfg e1) v1 ->
       estep2 md d (ecfg_update_exp2 ecfg e2) v2 ->
       contains_nat v1 /\ contains_nat v2 ->
       estep2 md d ecfg (val2_add v1 v2)
   | Estep2_deref : forall md d ecfg e r m l v,
       ecfg = (Ederef e, r, m) ->
       estep2 md d (e, r, m) (VSingle (Vloc l)) ->
       m l = v ->
       mode_access_ok md d l ->
       estep2 md d ecfg v.

  (* Semantics for commands. *)
   Definition cconfig2 : Type := com * reg2 * mem2.
   Definition cterm2 : Type := reg2 * mem2.
   Definition ccfg_com2 (ccfg: cconfig2) : com :=
     match ccfg with (c, _, _) => c end.
   Definition ccfg_reg2 (ccfg: cconfig2) : reg2 :=
     match ccfg with (_, r, _) => r end.
   Definition ccfg_mem2 (ccfg: cconfig2) : mem2 :=
     match ccfg with (_, _, m) => m end.
   Definition ccfg_update_mem2 (ccfg: cconfig2) (l: location) (v: val2) : mem2 :=
     fun loc => if loc =? l then v
                else (ccfg_mem2 ccfg) loc.
   Definition ccfg_update_reg2 (ccfg: cconfig2) (x: var) (v: val2) : reg2 :=
     fun var => if var =? x then v
                else (ccfg_reg2 ccfg) var.
   Definition ccfg_to_ecfg2 (e: exp) (ccfg : cconfig2) : econfig2 :=
     (e, (ccfg_reg2 ccfg), (ccfg_mem2 ccfg)).
   Definition ccfg_update_com2 (c: com) (ccfg : cconfig2) : cconfig2 :=
     (c, (ccfg_reg2 ccfg), (ccfg_mem2 ccfg)).
   Definition csemantics2 : Type := mode -> loc_mode -> cconfig2 -> cterm2 -> trace2 -> Prop.

   Definition project_ccfg (ccfg : cconfig2) (is_left : bool) : cconfig :=
     (ccfg_com2 ccfg, project_reg (ccfg_reg2 ccfg) is_left,
      project_mem (ccfg_mem2 ccfg) is_left).

  Inductive cstep2 : csemantics2 :=
  | Cstep2_skip : forall md d ccfg,
      ccfg_com2 ccfg = Cskip ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_assign : forall md d ccfg x e v r',
      ccfg_com2 ccfg = Cassign x e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      r' = ccfg_update_reg2 ccfg x v ->
      cstep2 md d ccfg (r', ccfg_mem2 ccfg) [Assign2 (ccfg_reg2 ccfg) x v]
  | Cstep2_declassify : forall md d ccfg x e v r',
      ccfg_com2 ccfg = Cdeclassify x e ->
      exp_novars e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      r' = ccfg_update_reg2 ccfg x v ->
      cstep2 md d ccfg (r', ccfg_mem2 ccfg) [Decl2 e (ccfg_mem2 ccfg)]
  | Cstep2_update : forall md d ccfg e1 e2 l v m',
      ccfg_com2 ccfg = Cupdate e1 e2 ->
      estep2 md d (ccfg_to_ecfg2 e1 ccfg) (VSingle (Vloc l)) ->
      estep2 md d (ccfg_to_ecfg2 e2 ccfg) v ->
      m' = ccfg_update_mem2 ccfg l v ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, m') [Update2 (ccfg_mem2 ccfg) l v]
  | Cstep2_output : forall md d ccfg e sl v,
      ccfg_com2 ccfg = Coutput e sl ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) v ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg)
             [Mem2 (ccfg_mem2 ccfg); Out2 sl v]
  | Cstep2_call : forall md d ccfg e c r' m' tr,
      ccfg_com2 ccfg = Ccall e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vlambda md c)) ->
      cstep2 md d (ccfg_update_com2 c ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_call_div : forall md d ccfg e c1 c2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Ccall e ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vlambda md c1) (Vlambda md c2)) ->
      cstep md d (c1, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      cstep md d (c2, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
            (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  | Cstep2_enclave : forall md d ccfg enc c r' m' tr,
    md = Normal ->
    ccfg_com2 ccfg = Cenclave enc c ->
    cstep2 (Encl enc) d (c, ccfg_reg2 ccfg, ccfg_mem2 ccfg) (r', m') tr ->
    cstep2 md d ccfg (r', m') tr
  | Cstep2_seq_nil : forall md d ccfg,
      ccfg_com2 ccfg = Cseq [] ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_seq_hd : forall md d ccfg hd tl r m tr r' m' tr',
      ccfg_com2 ccfg = Cseq (hd::tl) ->
      cstep2 md d (ccfg_update_com2 hd ccfg) (r, m) tr ->
      cstep2 md d (Cseq tl, r, m) (r', m') tr' ->
      cstep2 md d ccfg (r', m') (tr++tr')
  | Cstep2_if : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 1)) ->
      cstep2 md d (ccfg_update_com2 c1 ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_else : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 0)) ->
      cstep2 md d (ccfg_update_com2 c2 ccfg) (r', m') tr ->
      cstep2 md d ccfg (r', m') tr
  | Cstep2_if_div : forall md d ccfg e c1 c2 n1 n2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Cif e c1 c2 ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vnat n1) (Vnat n2)) ->
      n1 < 2 /\ n2 < 2 ->
      let cleft := (match n1 with
                    | 0 => c2
                    | _ => c1 end) in
      cstep md d (cleft, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      let cright := (match n2 with
                     | 0 => c2
                     | _ => c1 end) in
      cstep md d (cright, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
                  (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  | Cstep2_while_t : forall md d ccfg e c r m tr r' m' tr',
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 1)) ->
      cstep2 md d (ccfg_update_com2 c ccfg) (r, m) tr ->
      cstep2 md d (Cwhile e c,r,m) (r', m') tr' ->
      cstep2 md d ccfg (r', m') (tr++tr')
  | Cstep2_while_f : forall md d ccfg e c,
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VSingle (Vnat 0)) ->
      cstep2 md d ccfg (ccfg_reg2 ccfg, ccfg_mem2 ccfg) []
  | Cstep2_while_div : forall md d ccfg e c n1 n2 r1 m1 t1 r2 m2 t2 rmerge mmerge,
      ccfg_com2 ccfg = Cwhile e c ->
      estep2 md d (ccfg_to_ecfg2 e ccfg) (VPair (Vnat n1) (Vnat n2)) ->
      n1 < 2 /\ n2 < 2 ->
      let cleft := (match n1 with
                    | 0 => Cskip
                    | _ => Cseq [c; Cwhile e c] end) in
      cstep md d (cleft, project_reg (ccfg_reg2 ccfg) true,
                  project_mem (ccfg_mem2 ccfg) true)
                  (r1, m1) t1 ->
      let cright := (match n2 with
                     | 0 => Cskip
                     | _ => Cseq [c; Cwhile e c] end) in
      cstep md d (cright, project_reg (ccfg_reg2 ccfg) false,
                  project_mem (ccfg_mem2 ccfg) false)
            (r2, m2) t2 ->
      merge_reg r1 r2 = rmerge ->
      merge_mem m1 m2 = mmerge ->
      cstep2 md d ccfg (rmerge, mmerge) (merge_trace (t1, t2))
  .
  Hint Constructors cstep2.

  Inductive imm_premise : com -> mode -> reg2 -> mem2 -> reg2 -> mem2 -> trace2 ->
                          com -> mode -> reg2 -> mem2 -> reg2 -> mem2 -> trace2 ->
                          loc_mode -> Prop :=
  | IPcall: forall md d e r m r' m' tr c,
      estep2 md d (e, r, m) (VSingle (Vlambda md c)) ->
      cstep2 md d (c, r, m) (r', m') tr ->
      cstep2 md d (Ccall e, r, m) (r', m') tr ->
      imm_premise c md r m r' m' tr
                  (Ccall e) md r m r' m' tr d
  | IPencl: forall d encl c r m r' m' tr,
      cstep2 (Encl encl) d (c, r, m) (r', m') tr ->
      cstep2 Normal d (Cenclave encl c, r, m) (r', m') tr ->
      imm_premise c (Encl encl) r m r' m' tr
                  (Cenclave encl c) Normal r m r' m' tr d
  | IPseq1: forall md d c rest r m r' m' r'' m'' tr tr',
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cseq rest, r', m') (r'', m'') tr ->
      cstep2 md d (Cseq (c :: rest), r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise c md r m r' m' tr'
                  (Cseq (c :: rest)) md r m r'' m'' (tr'++tr) d
  | IPseq2: forall md d c rest r m r' m' r'' m'' tr tr',
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cseq rest, r', m') (r'', m'') tr ->
      cstep2 md d (Cseq (c :: rest), r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise (Cseq rest) md r' m' r'' m'' tr
                  (Cseq (c :: rest)) md r m r'' m'' (tr' ++ tr) d
  | IPif: forall md d c1 c2 e r m r' m' tr,
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c1, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') (tr) ->
      imm_premise c1 md r m r' m' tr
                  (Cif e c1 c2) md r m r' m' tr d
  | IPelse: forall md d c1 c2 e r m r' m' tr,
      estep2 md d (e, r, m) (VSingle (Vnat 0)) ->
      cstep2 md d (c2, r, m) (r', m') tr ->
      cstep2 md d (Cif e c1 c2, r, m) (r', m') tr ->
      imm_premise c2 md r m r' m' tr (Cif e c1 c2) md r m r' m' tr d
  | IPwhilet1: forall md d c e r m r' m' r'' m'' tr tr',
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cwhile e c, r', m') (r'', m'') tr ->
      cstep2 md d (Cwhile e c, r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise c md r m r' m' tr' (Cwhile e c) md r m r'' m'' (tr' ++ tr) d
  | IPwhilet2: forall md d c e r m r' m' r'' m'' tr tr',
      estep2 md d (e, r, m) (VSingle (Vnat 1)) ->
      cstep2 md d (c, r, m) (r', m') tr' ->
      cstep2 md d (Cwhile e c, r', m') (r'', m'') tr ->
      cstep2 md d (Cwhile e c, r, m) (r'', m'') (tr' ++ tr) ->
      imm_premise (Cwhile e c) md r' m' r'' m'' tr
                  (Cwhile e c) md r m r'' m'' (tr' ++ tr) d
  .
  Hint Constructors imm_premise.
End Semantics.

(*******************************************************************************
*
* SECURITY DEFINITIONS
*
*******************************************************************************)

Section Security_Defn.
  Parameter minit2_left : mem.
  Parameter minit2_right : mem.
  Axiom wf_minit2_left : forall d, meminit_wf minit2_left d.
  Axiom wf_minit2_right : forall d, meminit_wf minit2_right d.
  Definition minit2 := merge_mem minit2_left minit2_right.

  Definition meminit2_wf (m: mem2) d := forall l,
    match m l with
    | VSingle (Vlambda md c) => exists Gm p Gp q rt,
                               Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) /\
                               com_type p md Gm d c Gp
    | VPair (Vlambda md1 c1) (Vlambda md2 c2) =>
      (exists Gm p Gp q rt,
          Loc_Contxt l = Some (Typ (Tlambda Gm p md1 Gp) q, rt) /\
          com_type p md1 Gm d c1 Gp) /\
      (exists Gm p Gp q rt,
          Loc_Contxt l = Some (Typ (Tlambda Gm p md2 Gp) q, rt) /\
          com_type p md2 Gm d c2 Gp)
    | VSingle (Vnat n) => True
    | VPair (Vnat n1) (Vnat n2) => True
    | _ => False
    end.

   Lemma wf_minit2 : forall d: loc_mode, meminit2_wf minit2 d.
   Proof.
     intros.
     unfold minit2.
     unfold meminit2_wf; intros.
     remember (minit2_left l) as vl; remember (minit2_right l) as vr.
     pose (wf_minit2_left d l) as wfl; rewrite <- Heqvl in wfl.
     pose (wf_minit2_right d l) as wfr; rewrite <- Heqvr in wfr.
     unfold merge_mem.
     rewrite <- Heqvl, <- Heqvr.
     destruct (val_decidable vl vr); destruct vl, vr; auto;
       destruct_conjs.
     rewrite H5 in H0; discriminate.
     rewrite H6 in H3; discriminate.
   Qed.

  Definition esc_hatch : Type := exp.
  Definition is_escape_hatch e : Prop := exp_novars e /\ exp_locs_immutable e.

  Definition tobs_sec_level (sl: sec_level) : trace -> trace :=
    filter (fun event => match event with
                         | Out sl' v => sec_level_le_compute sl' sl
                         | AEnc c c' enc_equiv => true
                         | ANonEnc c => true
                         | _ => false
                         end).

  Definition corresponds (G: context) : Prop :=
    (forall l p bt rt, g0 l = p -> Loc_Contxt l = Some (Typ bt p, rt))
    /\ (forall x, G x = Some (Typ Tnat (L))).

  Definition mem_sl_ind (sl: sec_level) :=
    forall l : location,
      sec_level_le (g0 l) sl <-> (project_mem minit2 true) l = (project_mem minit2 false) l.

  (* any memory---implicitly derived from minit2---has values at locations
   * used to compute escape hatches that result in the same value as minit
   * no variables are in the escape hatch, so we can quantify over any r *)
  Definition mem_esc_hatch_ind :=
    forall e, is_escape_hatch e -> forall m v, (exists md d r, estep2 md d (e,r,m) v) ->
                                               exists v', v = VSingle v'.

  Definition secure_prog (sl: sec_level) (d: loc_mode) (c: com) (G: context) : Prop :=
    forall m0 mknown r' m' t tobs,
      merge_mem m0 mknown = minit2 ->
      cstep2 Normal d (c, reg_init2, minit2) (r', m') t ->
      tobs = project_trace t true ->
      mem_sl_ind sl ->
      mem_esc_hatch_ind ->
      tobs_sec_level sl tobs = tobs_sec_level sl (project_trace t false).

    Definition cterm2_ok (md: mode) (G: context) (d: loc_mode) (r: reg2) (m: mem2)
      : Prop :=
      (forall x v1 v2 bt p,
          (r x = VPair v1 v2 /\ G x = Some (Typ bt p)) -> protected p /\ md <> Normal)
      /\ (forall l v1 v2 bt p rt,
          (m l = VPair v1 v2 /\ Loc_Contxt l = Some (Typ bt p, rt))
          -> protected p /\ d l <> Normal)
      /\ mem_sl_ind L
      /\ mem_esc_hatch_ind.

  Definition cconfig2_ok (pc: sec_level) (md: mode) (G: context) (d: loc_mode)
             (c: com) (r: reg2) (m: mem2) (G': context)
    : Prop :=
    com_type pc md G d c G'
    /\ (forall x v1 v2 bt p,
           (r x = VPair v1 v2
            /\ G x = Some (Typ bt p))
           -> protected p /\ md <> Normal)
    /\ (forall l v1 v2 bt p rt,
           ((m l) = VPair v1 v2 /\ Loc_Contxt (l) = Some (Typ bt p, rt))
           -> protected p /\ d l <> Normal)
    /\ mem_sl_ind L
    /\ mem_esc_hatch_ind.

End Security_Defn.

Section Axioms.
   Axiom Initial_State2: forall d r' m',
       exists c md tr, cstep2 md d (c, reg_init2, minit2) (r', m') tr.

   (* This follows from the axiom above and the assumption made in simpe *)
   Axiom pair_wf : forall v v1 v2,
       v = VPair v1 v2 <->
       v1 <> v2 /\
       ((exists n1 n2, v1 = Vnat n1 /\ v2 = Vnat n2) \/
        (exists md1 md2 c1 c2, v1 = Vlambda md1 c1 /\ v2 = Vlambda md2 c2)).
End Axioms.


Require Import VST.floyd.proofauto.
Require Import VST.progs.message.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* This program, and its verification, are described in Chapter 29
   of _Program Logics for Certified Compilers_, by Appel et al., 2014 *)

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh len buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (mf_size-len) (offset_val len buf)
}.

Arguments mf_build {t}.
Arguments mf_size {t}.
Arguments mf_data_assert {t}.
Arguments mf_assert {t}.
Arguments mf_bufprop {t}.
Arguments mf_size_range {t}.
Arguments mf_restbuf {t}.

Definition t_struct_intpair := Tstruct _intpair noattr.
Definition t_struct_message := Tstruct _message noattr.

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  entailer!.
  change 8 with (sizeof (tarray tint 2)).
  apply data_at_memory_block.
Qed.

Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar) ]
          PROP (readable_share sh; writable_share sh';
                mf_data_assert format data;
                align_compatible tint buf)
          LOCAL (temp _p p; temp _buf buf)
          SEP (data_at sh t data p;
                 memory_block sh' (mf_size format) buf)
  POST [ tint ]
         EX len: Z,
          PROP() LOCAL (temp ret_temp (Vint (Int.repr len)))
          SEP( data_at sh t data p;
                 mf_assert format sh' buf len data;
                 mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share, len: Z
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar), _length OF tint ]
          PROP (readable_share sh'; writable_share sh;
                0 <= len <= mf_size format)
          LOCAL (temp _p p;
                 temp _buf buf;
                 temp _length (Vint (Int.repr len)))
          SEP (mf_assert format sh' buf len data;
                 data_at_ sh t p)
  POST [ tvoid ]
          PROP (mf_data_assert format data)  LOCAL ()
          SEP (mf_assert format sh' buf len data;
                 data_at sh t data p).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

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

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr' (serialize_spec format) (fst fg) *
          func_ptr' (deserialize_spec format) (snd fg) *
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

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

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
destruct H as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

change (mf_size intpair_message) with (sizeof (tarray tint 2)).
assert_PROP (field_compatible (tarray tint 2) [] buf).
  entailer!.
  hnf in H; decompose[and] H; repeat split; auto.
  (* TODO: abstract the following proof. *)
  unfold align_compatible in H0 |- *.
  destruct buf; auto.
  constructor.
  intros.
  eapply align_compatible_rec_by_value_inv in H0; [| reflexivity].
  econstructor; [reflexivity |].
  apply Z.divide_add_r; auto.
  exists i0; rewrite Z.mul_comm; auto.
rewrite memory_block_data_at_; auto.
change (data_at_ sh' (tarray tint 2) buf) with
   (data_at sh' (tarray tint 2) [Vundef;Vundef] buf).
forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
Exists 8.
unfold mf_restbuf. simpl.
rewrite memory_block_zero.
entailer!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function.
simpl. Intros. subst len.
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction.
clear H H1 H2.
forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (* p->y = y; *)
forward. (* return; *)
simpl; entailer!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
name buf _buf.

start_function.
set (ipm := gv _intpair_message).
fold cc_default noattr.
make_func_ptr _intpair_deserialize.
make_func_ptr _intpair_serialize.
set (des := gv _intpair_deserialize).
set (ser := gv _intpair_serialize).
gather_SEP 5 6 7.
replace_SEP 0
    (data_at Ews t_struct_message
      (Vint (Int.repr (mf_size intpair_message)), (ser, des)) ipm). {
 entailer!.
 unfold_data_at (data_at _ t_struct_message _ ipm).
 rewrite (field_at_data_at _ _ _ _ ipm).
rewrite data_at_tuint_tint.
(* rewrite <- (mapsto_field_at _ _ [StructField _bufsize] (Vint (Int.repr 8))) by auto with field_compatible. *)
 rewrite <- (mapsto_field_at _ _ [StructField _deserialize] des) by auto with field_compatible.
 rewrite <- (mapsto_field_at _ _ [StructField _serialize] ser) by auto with field_compatible.
 rewrite !field_compatible_field_address by auto with field_compatible.
 simpl.
 normalize.
 cancel.
}
forward. (* p.x = 1; *)
forward. (* p.y = 2; *)
forward. (* ser = intpair_message.serialize; *)

rewrite <- memory_block_data_at__tarray_tuchar_eq by computable.
change (memory_block Tsh 8 buf)
with (memory_block Tsh (mf_size intpair_message) buf).

assert_PROP (align_compatible tint buf).
  entailer!.
  destruct HPbuf; subst; simpl.
  econstructor; [reflexivity | apply Z.divide_0_r].
forward_call (* len = ser(&p, buf); *)
      ((Vint (Int.repr 1), Vint (Int.repr 2)), v_p, buf, Tsh, Tsh).
  split3; auto.
  repeat split; auto.
Intros rest.
simpl.
Intros. subst rest.

forward. (* des = intpair_message.deserialize; *)
forward_call (* des(&q, buf, 8); *)
        ((Vint (Int.repr 1), Vint (Int.repr 2)), v_q, buf, Tsh, Tsh, 8).
  simpl. fold t_struct_intpair. entailer!.
  split3; auto. simpl; computable.
(* after the call *)
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
simpl.
entailer!.
sep_apply (data_at_memory_block Tsh (tarray tint 2) [Vint (Int.repr 1); Vint (Int.repr 2)] buf).
simpl sizeof.
sep_apply (memory_block_data_at__tarray_tuchar Tsh buf 8).
   computable.
entailer!.
Qed.


From Undecidability.L Require Import Tactics.LTactics Functions.EqBool.
From Undecidability.L.Datatypes Require Import LNat LTerm LBool.
Require Import Nat .
Import EqBool.

(* ** Extracted substitution on terms *)
Global
Instance term_substT :
  computableTime' subst (fun s _ => (5, (fun n _ => (1, (fun t _ => ( (size s) * (size s + c__eqbComp nat * 4 + 20), tt)))))).
Proof.
  extract. unfold eqbTime.
  recRel_prettify2. all:unfold eqbTime; cbn [fst snd size].
  all:try rewrite !size_nat_enc.
  all: unfold c__natsizeS, c__natsizeO in *.
  all:try nia.
Qed.


From isla Require Import opsem.

Definition a8016c : isla_trace :=
  Smt (DeclareConst 55%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 55%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop Concat [Val (Val_Bits (BV 32%N 0x0%Z)) Mk_annot; Manyop (Bvmanyarith Bvand) [Unop (Extract 31%N 0%N) (Val (Val_Symbolic 55%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 32%N 0xff%Z)) Mk_annot] Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R0" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  Smt (DeclareConst 59%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 59%Z)) Mk_annot :t:
  Smt (DefineConst 60%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 59%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 60%Z)) Mk_annot :t:
  tnil
.


From Undecidability.Synthetic
     Require Import Definitions Undecidability.

From Undecidability.FOL
     Require Import Sets.FST
                    Semantics.Tarski.FullFacts
                    Semantics.Tarski.FullSoundness
                    Deduction.FullNDFacts
                    Sets.Models.FST_model.

From Undecidability.FOL.Undecidability.Reductions
     Require Import PCPb_to_FST PCPb_to_FSTD ZF_to_FST.

From Undecidability.PCP
     Require Import PCP PCP_undec Reductions.PCPb_iff_dPCPb.

Theorem undecidable_entailment_FSTeq :
  undecidable entailment_FSTeq.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable'. intros B. split.
  - intros HP % (PCP_FSTD (p:=intu)).
    apply soundness in HP. intros I M rho H. apply HP, H.
  - apply PCP_FST.
Qed.

Theorem undecidable_deduction_FST :
  undecidable deduction_FST.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable'. intros B. split.
  - intros HP % (PCP_FSTD (p:=intu)). apply HP.
  - intros HP % soundness. apply PCP_FST.
    intros I M rho H. apply HP. apply H.
Qed.

Theorem undecidable_entailment_FST :
  undecidable entailment_FST.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. apply PCPb_to_FST.PCP_FST.
  apply FST_model.
Qed.

Theorem undecidable_entailment_FSTI :
  undecidable entailment_FSTI.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. rewrite PCPb_iff_dPCPb. split; intros H.
  - destruct H as [s H]. intros M HM rho H1 H2. eapply PCP_FST1; eauto.
    intros sigma psi Hp. apply H2. now constructor.
  - destruct FSTI_model as (D & I & H1 & H2 & H3).
    specialize (H D I (fun _ => @i_func _ _ _ _ eset Vector.nil) H1 H3).
    apply PCP_FST2 in H as [s Hs]; trivial. now exists s.
    intros sigma psi Hp. apply H3. now constructor.
Qed.

Theorem undecidable_deduction_FSTI :
  undecidable deduction_FSTI.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists solvable. intros B. split; intros H.
  - exists FSTeq. split; try apply FSTeq_base. now apply PCPb_to_FSTD.PCP_FSTD.
  - destruct FSTI_model as (D & I & H1 & H2 & H3).
    rewrite PCPb_iff_dPCPb. unshelve eapply PCP_FST2; eauto.
    + exact (fun _ => @i_func _ _ _ _ eset Vector.nil).
    + intros sigma psi Hp. apply H3. now constructor.
    + apply (tsoundness H). intros psi [theta [<-|[<-|[<-|[<-|Hp]]]]|theta].
      1-4: cbn; setoid_rewrite H1; congruence.
      * apply H3. now constructor.
      * apply H3. constructor 2.
Qed.


Require Import Algebra.Utils Algebra.Monad SetoidUtils Algebra.SetoidCat.ListUtils Algebra.SetoidCat Algebra.Monad.StoreHeap Algebra.Monad.ContT Algebra.NearSemiRing Algebra.Monoid Tactics QAL.Definitions Algebra.FoldableFunctor Algebra.SetoidCat.PairUtils Algebra.Functor Algebra.Alternative Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.Applicative Algebra.SetoidCat.BoolUtils Algebra.SetoidCat.UnitUtils Algebra.Monoid.BoolUtils Algebra.Monoid.Alternative Algebra.Alternative.List Algebra.Functor.List Algebra.FoldableFunctor.List Algebra.Monad.Utils QAL.Concrete.Definitions QAL.AbstractStore QAL.AbstractHeap QAL.Command Algebra.Traversable.List Algebra.Functor.Monad Algebra.Applicative.Monad.

Require Import Coq.Lists.List PeanoNat RelationClasses Relation_Definitions Morphisms Coq.Program.Basics SetoidClass.

Module Type BuiltInCommand (PT : PredType) (VT : ValType) (S : AbstractStore VT) (H : AbstractHeap PT VT).
  Module TS := Types PT VT S H.
  Import TS.
  Parameter builtInCommand : Type.
  Parameter builtInCommandS : Setoid builtInCommand.
  Parameter freeVarsBuiltInCommand : builtInCommandS ~> varSetS.
  Parameter interpretBuiltInCommand : builtInCommandS ~> stateS unitS.
End BuiltInCommand.

Module Type Literal (VT : ValType).
  Import VT.
  Parameter literal : Type.
  Parameter literalS : Setoid literal.
  Parameter interpretLiteral : literalS ~> valS.
End Literal.

Section PrimitiveCommand.

  Context
    {literal : Type}
    {pred : Type}
    {builtin : Type}.

  Inductive term :=
  | termVar : var -> term
  | termVal : literal -> term
  .

  Program Instance termS : Setoid term.

  Inductive qalPrimitiveCommand :=
  | pcBuiltIn : builtin -> qalPrimitiveCommand
  | pcInsert : pred -> list term -> qalPrimitiveCommand
  | pcDelete : pred -> list term -> qalPrimitiveCommand
  | pcInsertProp : pred -> list term -> list term -> qalPrimitiveCommand
  | pcDeleteProp : pred -> list term -> list term -> qalPrimitiveCommand
  | pcAtomic : pred -> list term -> qalPrimitiveCommand
  .

  Program Instance qalPrimitiveCommandS : Setoid qalPrimitiveCommand.

End PrimitiveCommand.

Import FSetNatNotations.
Module QALPrimitiveCommand (PT : PredType) (VT : ValType)
       (L : Literal VT) (S : AbstractStore VT) (H : AbstractHeap PT VT) (BC : BuiltInCommand PT VT S H) : PrimitiveCommand PT VT S H.
  Open Scope type_scope.
  Module TS := Types PT VT S H.
  Module CA := CommandAux PT VT S H.
  Import PT VT L S H BC TS CA.

  Definition _termFreeVars (t : (@term literal)) : FVarSet.t :=
    match t with
        | termVal _ => ∅
        | termVar v => ﹛ v ﹜
    end
  .

  Existing Instance termS.

  Instance _termFreeVars_Proper : Proper (equiv ==> equiv) _termFreeVars.
  Proof.
    solve_proper.
  Qed.

  Definition termFreeVars := injF _termFreeVars _.

  Definition tlFreeVars (tl : list term) :=
            fold_right (fun t  fv =>
                      (termFreeVars @ t) ∪ fv) ∅ tl
  .

  Definition _qalPrimitiveCommandFreeVars (pc : @qalPrimitiveCommand literal pred builtInCommand) : FVarSet.t :=
    match pc with
      | pcBuiltIn b => freeVarsBuiltInCommand @ b
      | pcInsert _ tl => tlFreeVars tl
      | pcDelete _ tl => tlFreeVars tl
      | pcInsertProp _ ktl ptl => tlFreeVars ktl ∪ tlFreeVars ptl
      | pcDeleteProp _ ktl ptl => tlFreeVars ktl ∪ tlFreeVars ptl
      | pcAtomic _ tl => tlFreeVars tl
    end
  .

  Existing Instance qalPrimitiveCommandS.
  Instance _qalPrimitiveCommandFreeVars_Proper : Proper (equiv ==> equiv) _qalPrimitiveCommandFreeVars.
   Proof.
    solve_proper.
  Qed.

  Definition qalPrimitiveCommandFreeVars := injF _qalPrimitiveCommandFreeVars _.

  Definition freeVarsPrimitiveCommand := qalPrimitiveCommandFreeVars.

  Definition qalTerm := @term literal.
  Instance qalTermS : Setoid qalTerm := @termS literal.

  Instance argumentVal_Proper : Proper (equiv ==> equiv) (argumentVal val).
  Proof.
    unfold Proper, respectful. intros. auto.
  Qed.

  Definition argumentValS := injF (argumentVal val) _.
  Definition _evalTerm (t : term) : state (argument val) :=
    match t with
      | termVal l => ret @ (argumentValS @ (interpretLiteral @ l))
      | termVar v => getStore >>= ret ∘ (caseMaybeS @ argumentValS @ argumentVar val v) ∘ (S.read @ v)
    end
  .

  Instance _evalTerm_Proper : Proper (equiv ==> equiv) _evalTerm.
  Proof.
    solve_proper.
  Qed.

  Definition evalTerm := injF _evalTerm _.

  Existing Instance sh_Monad.
  Existing Instance monadFunctor.
  Existing Instance monad_Applicative.
  Definition evalTermList : listS (@termS literal) ~> stateS (listS (argumentS _ valS)) := mapM @ evalTerm.

  Definition _evalTermVal (t : term) : state ( val) :=
    match t with
      | termVal l => ret @ (interpretLiteral @ l)
      | termVar v => getStore >>= ret ∘ (S.read @ v) >>= stopNone
    end
  .

  Instance _evalTermVal_Proper : Proper (equiv ==> equiv) _evalTermVal.
  Proof.
    solve_proper.
  Qed.

  Definition evalTermVal := injF _evalTermVal _.

  Definition evalTermListVal : listS (@termS literal) ~> stateS (listS valS) := mapM @ evalTermVal.

  Definition updateStore2 : listS (varS ~*~ valS) ~> S.tS ~~> S.tS :=
    flipS @ (fold_rightS @ (uncurryS @ S.update)).

  Definition _unionWithCurrStore (s : list (var * val)) : state unit :=
    updateStore @ (updateStore2 @ s).

  Instance _unionWithCurrStore_Proper : Proper (equiv ==> equiv) _unionWithCurrStore.
  Proof.
    solve_properS _unionWithCurrStore.
  Qed.

  Definition unionWithCurrStore : listS (varS ~*~ valS) ~> stateS unitS := injF _unionWithCurrStore _.

  Definition _lookupAtom (p : pred) (tl : list (@term literal)) : state (H.l (list (var * val)) _) :=
    (H.lookup @ p)
        <$> (evalTermList @ tl)
        <*> getHeap.

  Instance _lookupAtom_Proper : Proper (equiv ==> equiv ==> equiv) _lookupAtom.
  Proof.
    solve_properS _lookupAtom.
  Qed.
  Definition lookupAtom := injF2 _lookupAtom _.

  Section LookupGeneric.
    Context (p : pred) (tl : list (@term literal)).

    Definition lookupGeneric : state unit :=
      lookupAtom @ p @ tl >>= branchVal >>= unionWithCurrStore.
  End LookupGeneric.
  Instance lookupGeneric_Proper : Proper (equiv ==> equiv ==> equiv) lookupGeneric.
  Proof.
    solve_properS lookupGeneric.
  Qed.

  Section InsertGeneric.
    Context
      (p : pred) (tl : list (@term literal)).

    Definition insertGeneric : state unit :=
      (H.insert @ p
         <$> (evalTermListVal @ tl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End InsertGeneric.
  Instance insertGeneric_Proper : Proper (equiv ==> equiv ==> equiv) insertGeneric.
  Proof.
    solve_properS insertGeneric.
  Qed.

  Section DeleteGeneric.
    Context
      (p : pred) (tl : list (@term literal)).

    Definition deleteGeneric : state unit :=
      (H.delete @ p
         <$> evalTermListVal @ tl
         <*> getHeap) >>= stopNone >>= putHeap.
  End DeleteGeneric.

  Instance DeleteGeneric_Proper : Proper (equiv ==> equiv ==> equiv) deleteGeneric.
  Proof.
    solve_properS deleteGeneric.
  Qed.

  Section InsertPropGeneric.
    Context
      (p : pred) (ktl ptl : list (@term literal)).

    Definition insertPropGeneric : state unit :=
      (H.insertProp @ p
         <$> (evalTermListVal @ ktl)
         <*> (evalTermListVal @ ptl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End InsertPropGeneric.
  Instance insertPropGeneric_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) insertPropGeneric.
  Proof.
    solve_properS insertPropGeneric.
  Qed.

  Section DeletePropGeneric.
    Context
      (p : pred) (ktl ptl : list (@term literal)).

    Definition deletePropGeneric : state unit :=
      (H.deleteProp @ p
         <$> (evalTermListVal @ ktl)
         <*> (evalTermListVal @ ptl)
         <*> getHeap) >>= stopNone >>= putHeap.
  End DeletePropGeneric.

  Instance DeletePropGeneric_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) deletePropGeneric.
  Proof.
    solve_properS deletePropGeneric.
  Qed.

  Fixpoint _reduce (pc : qalPrimitiveCommand)  : state unit :=
    match pc with
      | pcBuiltIn b =>
        interpretBuiltInCommand @ b
      | pcInsert pred tl =>
        insertGeneric pred tl
      | pcDelete pred tl =>
        deleteGeneric pred tl
      | pcInsertProp pred ktl ptl =>
        insertPropGeneric pred ktl ptl
      | pcDeleteProp pred ktl ptl =>
        deletePropGeneric pred ktl ptl
      | pcAtomic pred tl =>
        lookupGeneric pred tl
    end
  .

  Definition reduce : (@qalPrimitiveCommandS literal pred builtInCommand ) ~> stateS unitS := injF _reduce _.
  Definition primitiveCommand := @qalPrimitiveCommand literal pred builtInCommand .
  Definition primitiveCommandS := @qalPrimitiveCommandS literal pred builtInCommand.
  Definition interpretPrimitiveCommand := reduce.
End QALPrimitiveCommand.


Require Import Coq.Lists.List.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.Reify.ReifyClass.

Require Import ExtLib.Core.RelDec.

Set Implicit Arguments.
Set Strict Implicit.

(* This universe is only here as prod_typ otherwise is cast to nat->Prop *)
Inductive prod_typ : nat -> Set :=
| tProd : prod_typ 2.

Definition prod_typ_dec {n} (a : prod_typ n) : forall b, {a = b} + {a <> b} :=
  match a as a in prod_typ n
        return forall b : prod_typ n, {a = b} + {a <> b}
  with
  | tProd =>
    fun b =>
      match b as b in prod_typ 2 return {tProd = b} + {tProd <> b} with
      | tProd => left eq_refl
      end
  end.

Definition prod_typD {n} (t : prod_typ n) : type_for_arity n :=
  match t with
  | tProd => prod
  end.

Section FuncView_prod_type.
  Context {typ : Set}.
  Context {FV : PartialView typ (prod_typ 2 * (typ * typ))}.

  Definition tyProd t u := f_insert (tProd, (t, u)).

  Definition ptrn_tyProd {T : Type} (p : Ptrns.ptrn (typ * typ) T)
  : ptrn (prod_typ 2 * typ * typ) T :=
    fun f U good bad => p (snd (fst f), snd f) U good (fun x => bad f).

  Global Instance ptrn_tyProd_ok {T : Type} {p : ptrn (typ * typ) T}
         {Hok : ptrn_ok p}
  : ptrn_ok (ptrn_tyProd p).
  Proof.
    red; intros.
    destruct x as [[q t] u]; simpl; [destruct (Hok (t, u))].
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl;
      unfold ptrn_tyProd; rewrite H; reflexivity. }
  Qed.

End FuncView_prod_type.

Section RelDec_prod_type.

  Global Instance RelDec_prod_typ (x : nat) : RelDec (@eq (prod_typ x)) := {
    rel_dec := fun a b =>
                 match x with
                 | 2 => true
                 | _ => false
                 end
  }.

  Definition prod_typ_eq (x y : prod_typ 2) : x = y :=
    match x, y with
    | tProd, tProd => eq_refl
    end.

  Global Instance RelDecOk_prod_typ (x : nat) : RelDec_Correct (RelDec_prod_typ x).
  Proof.
    split; intros.
    destruct x; simpl in *; [inversion y|].
    destruct x; simpl in *; [inversion y|].
    destruct x; simpl in *; [|inversion y].
    unfold rel_dec. simpl.
    split; intros; [|reflexivity].
    apply prod_typ_eq.
  Qed.

End RelDec_prod_type.

Section TSym_prod_type.

  Global Instance TSym_prod_typ : TSym prod_typ := {
    symbolD n := prod_typD (n := n);
    symbol_dec n := prod_typ_dec (n := n)
  }.

End TSym_prod_type.

Section ProdTypeReify.
  Context {typ : Set} {FV : PartialView typ (prod_typ 2 * (typ * typ))}.

  Definition reify_tyProd : Command typ :=
    CApp (CApp (CPattern (ls := nil) (RExact (@prod)) tyProd)
               (CRec 0)
               (fun _ x => tyProd x))
         (CRec 0)
         (fun f y => f y).

    Definition reify_prod_typ : Command typ :=
      CFirst (reify_tyProd :: nil).

End ProdTypeReify.

Arguments reify_prod_typ _ {_}.


(* Checking computation of free vars of a term for generalization *)

Definition Decision := fun P : Prop => {P} + {~ P}.
Class SetUnfold (P Q : Prop) : Prop := Build_SetUnfold { set_unfold : P <-> Q
}.

Section Filter_Help.

  Context {A: Type}.
  Context (fold_right : forall A B : Type, (B -> A -> A) -> A -> list B -> A).
  Definition lType2 := (sigT (fun (P : A -> Prop) => forall a, Decision (P
a))).
  Definition test (X: lType2) := let (x, _) := X in x.

  Global Instance foo `{fhl1 : list lType2} m Q:
    SetUnfold (Q)
              (fold_right _ _ (fun (s : lType2) => let (P, _) := s in and (P
m)) (Q) (fhl1)).