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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj6synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult Zero lv0) (mult lv1 lv0)).
Admitted.
QuickChick conj6synthconj4.


From Hammer Require Import Hammer.

Require Coq.Classes.EquivDec.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Structures.EqDep.
Require Import ExtLib.Tactics.Injection.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.TypeTac.

Set Implicit Arguments.
Set Strict Implicit.
Set Printing Universes.

Section type.
Variable T : Type.
Variable F : T -> Type.
Variable ED : EquivDec.EqDec _ (@eq T).
Variable tT : type T.
Variable typF : forall x, type (F x).

Global Instance type_sigT : type (sigT F) :=
{ equal := fun x y =>
equal (projT1 x) (projT1 y) /\
exists pf : projT1 y = projT1 x,
equal (projT2 x) (match pf in _ = t return F t with
| eq_refl => projT2 y
end)
; proper := fun x => proper (projT1 x) /\ proper (projT2 x)
}.

Variable typeOkT : typeOk tT.
Variable typOkF : forall x, typeOk (typF x).

Global Instance typeOk_sigT : typeOk type_sigT.
Proof. hammer_hook "SigT" "SigT.typeOk_sigT".
constructor.
{ destruct x; destruct y; intros. simpl in *. destruct H. destruct H0. subst.
apply only_proper in H; [ | eauto with typeclass_instances ].
apply only_proper in H0; [ | eauto with typeclass_instances ]. intuition. }
{ red. destruct x; intros. do 2 red in H.
do 2 red; simpl in *. intuition.
try solve [ apply equiv_prefl; eauto ].
exists eq_refl.
eapply Proper.preflexive; [ | eapply H1 ].
eauto with typeclass_instances. }
{ red; destruct x; destruct y; intros; simpl in *.
intuition. destruct H1; subst. exists eq_refl. symmetry; assumption. }
{ red; destruct x; destruct y; destruct z; intros; simpl in *; intuition.
etransitivity; eauto.
destruct H2; destruct H3; subst. exists eq_refl. etransitivity; eauto. }
Qed.

Global Instance proper_existT a b : proper a -> proper b -> proper (existT F a b).
Proof. hammer_hook "SigT" "SigT.proper_existT".
red; simpl. intuition.
Qed.

Global Instance proper_projT1 a : proper a -> proper (projT1 a).
Proof. hammer_hook "SigT" "SigT.proper_projT1".
red; simpl. intuition.
Qed.

Global Instance proper_projT2 a : proper a -> proper (projT2 a).
Proof. hammer_hook "SigT" "SigT.proper_projT2".
red; simpl. intuition.
Qed.

End type.

Section injective.
Variable T : Type.
Variable F : T -> Type.
Variable ED : EquivDec.EqDec _ (@eq T).

Global Instance Injective_existT a b d
: Injective (existT F a b = existT F a d) | 1.
refine {| result := b = d |}.
abstract (eauto using inj_pair2).
Defined.

Global Instance Injective_existT_dif a b c d
: Injective (existT F a b = existT F c d) | 2.
refine {| result := exists pf : c = a,
b = match pf in _ = t return F t with
| eq_refl => d
end |}.
abstract (inversion 1; subst; exists eq_refl; auto).
Defined.
End injective.

Lemma eq_sigT_rw
: forall T U F (a b : T) (pf : a = b) s,
match pf in _ = x return @sigT U (F x) with
| eq_refl => s
end =
@existT U (F b) (projT1 s)
match pf in _ = x return F x (projT1 s) with
| eq_refl => (projT2 s)
end.
Proof. hammer_hook "SigT" "SigT.eq_sigT_rw". destruct pf. destruct s; reflexivity. Qed.

Hint Rewrite eq_sigT_rw : eq_rw.


(* 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.

Parameter bag : forall (a:Type) {a_WT:WhyType a}, Type.
Axiom bag_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (bag a).
Existing Instance bag_WhyType.

Parameter nb_occ: forall {a:Type} {a_WT:WhyType a}, a -> (bag a) ->
  BuiltIn.int.

Axiom occ_non_negative : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a))
  (x:a), (0%Z <= (nb_occ x b))%Z.

(* Why3 assumption *)
Definition mem {a:Type} {a_WT:WhyType a}(x:a) (b:(bag a)): Prop :=
  (0%Z < (nb_occ x b))%Z.

(* Why3 assumption *)
Definition eq_bag {a:Type} {a_WT:WhyType a}(a1:(bag a)) (b:(bag a)): Prop :=
  forall (x:a), ((nb_occ x a1) = (nb_occ x b)).

Axiom bag_extensionality : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag
  a)) (b:(bag a)), (eq_bag a1 b) -> (a1 = b).

Parameter empty_bag: forall {a:Type} {a_WT:WhyType a}, (bag a).

Axiom occ_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ((nb_occ x
  (empty_bag :(bag a))) = 0%Z).

Axiom is_empty : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a)),
  (forall (x:a), ((nb_occ x b) = 0%Z)) -> (b = (empty_bag :(bag a))).

Parameter singleton: forall {a:Type} {a_WT:WhyType a}, a -> (bag a).

Axiom occ_singleton : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a),
  ((x = y) /\ ((nb_occ y (singleton x)) = 1%Z)) \/ ((~ (x = y)) /\ ((nb_occ y
  (singleton x)) = 0%Z)).

Axiom occ_singleton_eq : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (y:a), (x = y) -> ((nb_occ y (singleton x)) = 1%Z).

Axiom occ_singleton_neq : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (y:a), (~ (x = y)) -> ((nb_occ y (singleton x)) = 0%Z).

Parameter union: forall {a:Type} {a_WT:WhyType a}, (bag a) -> (bag a) -> (bag
  a).

Axiom occ_union : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (a1:(bag a))
  (b:(bag a)), ((nb_occ x (union a1 b)) = ((nb_occ x a1) + (nb_occ x b))%Z).

Axiom Union_comm : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag a))
  (b:(bag a)), ((union a1 b) = (union b a1)).

Axiom Union_identity : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag a)),
  ((union a1 (empty_bag :(bag a))) = a1).

Axiom Union_assoc : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag a))
  (b:(bag a)) (c:(bag a)), ((union a1 (union b c)) = (union (union a1 b) c)).

Axiom bag_simpl : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag a))
  (b:(bag a)) (c:(bag a)), ((union a1 b) = (union c b)) -> (a1 = c).

Axiom bag_simpl_left : forall {a:Type} {a_WT:WhyType a}, forall (a1:(bag a))
  (b:(bag a)) (c:(bag a)), ((union a1 b) = (union a1 c)) -> (b = c).

(* Why3 assumption *)
Definition add {a:Type} {a_WT:WhyType a}(x:a) (b:(bag a)): (bag a) :=
  (union (singleton x) b).

Axiom occ_add_eq : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a)) (x:a)
  (y:a), (x = y) -> ((nb_occ x (add x b)) = ((nb_occ x b) + 1%Z)%Z).

Axiom occ_add_neq : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a))
  (x:a) (y:a), (~ (x = y)) -> ((nb_occ y (add x b)) = (nb_occ y b)).

Parameter card: forall {a:Type} {a_WT:WhyType a}, (bag a) -> BuiltIn.int.

Axiom Card_empty : forall {a:Type} {a_WT:WhyType a}, ((card (empty_bag :(bag
  a))) = 0%Z).

Axiom Card_zero_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:(bag a)),
  ((card x) = 0%Z) -> (x = (empty_bag :(bag a))).

Axiom Card_singleton : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  ((card (singleton x)) = 1%Z).

Axiom Card_union : forall {a:Type} {a_WT:WhyType a}, forall (x:(bag a))
  (y:(bag a)), ((card (union x y)) = ((card x) + (card y))%Z).

Axiom Card_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (b:(bag a)),
  ((card (add x b)) = (1%Z + (card b))%Z).

Parameter diff: forall {a:Type} {a_WT:WhyType a}, (bag a) -> (bag a) -> (bag
  a).

Axiom Diff_occ : forall {a:Type} {a_WT:WhyType a}, forall (b1:(bag a))
  (b2:(bag a)) (x:a), ((nb_occ x (diff b1 b2)) = (Zmax 0%Z ((nb_occ x
  b1) - (nb_occ x b2))%Z)).

Axiom Diff_empty_right : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag
  a)), ((diff b (empty_bag :(bag a))) = b).

Axiom Diff_empty_left : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a)),
  ((diff (empty_bag :(bag a)) b) = (empty_bag :(bag a))).

Axiom Diff_add : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a)) (x:a),
  ((diff (add x b) (singleton x)) = b).

Axiom Diff_comm : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a))
  (b1:(bag a)) (b2:(bag a)), ((diff (diff b b1) b2) = (diff (diff b b2) b1)).

Axiom Add_diff : forall {a:Type} {a_WT:WhyType a}, forall (b:(bag a)) (x:a),
  (mem x b) -> ((add x (diff b (singleton x))) = b).

Parameter map : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b},
  Type.
Axiom map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

Parameter const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).

Axiom Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Definition array (a:Type) {a_WT:WhyType a} := (map BuiltIn.int a).

Parameter elements: forall {a:Type} {a_WT:WhyType a}, (map BuiltIn.int a)
  -> BuiltIn.int -> BuiltIn.int -> (bag a).

Axiom Elements_empty : forall {a:Type} {a_WT:WhyType a}, forall (a1:(map
  BuiltIn.int a)) (i:BuiltIn.int) (j:BuiltIn.int), (j <= i)%Z ->
  ((elements a1 i j) = (empty_bag :(bag a))).

Axiom Elements_add : forall {a:Type} {a_WT:WhyType a}, forall (a1:(map
  BuiltIn.int a)) (i:BuiltIn.int) (j:BuiltIn.int), (i < j)%Z -> ((elements a1
  i j) = (add (get a1 (j - 1%Z)%Z) (elements a1 i (j - 1%Z)%Z))).

Axiom Elements_singleton : forall {a:Type} {a_WT:WhyType a}, forall (a1:(map
  BuiltIn.int a)) (i:BuiltIn.int) (j:BuiltIn.int), (j = (i + 1%Z)%Z) ->
  ((elements a1 i j) = (singleton (get a1 i))).

(* Why3 goal *)
Theorem Elements_union : forall {a:Type} {a_WT:WhyType a}, forall (a1:(map
  BuiltIn.int a)) (i:BuiltIn.int) (j:BuiltIn.int) (k:BuiltIn.int),
  ((i <= j)%Z /\ (j <= k)%Z) -> ((elements a1 i k) = (union (elements a1 i j)
  (elements a1 j k))).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X _X a i j k (H0, H1).
apply Zlt_lower_bound_ind with (z := j)
     (P := fun k => elements a i k = union (elements a i j) (elements a j k)); auto.
intros x H_ind H.
assert (h: (j = x \/ j < x)%Z) by omega.
  destruct h.
  (*  j = x *)
  subst x.
   rewrite (Elements_empty _ j); auto.
   rewrite Union_identity; auto.
   (* j < x *)
   rewrite (Elements_add _ j); auto.
   rewrite (Elements_add _ i); auto with zarith.
   unfold add.
   rewrite H_ind with (y := (x - 1)%Z); auto with zarith.
   apply bag_extensionality.
   intro z.
   repeat rewrite occ_union; auto with zarith.
Qed.


Require Import TM.Prelim TM.Relations TM.TM.

(** * Alphabet-Lift *)

Section SujectTape.
  Variable sig tau : Type.
  Variable g : tau -> option sig.
  Variable def : sig.

  Definition surject : tau -> sig := fun t => match (g t) with Some s => s | None => def end.

  Definition surjectTape := mapTape surject.

End SujectTape.

Hint Unfold surjectTape : tape.

Section lift_sigma_tau.
  Variable n : nat.
  Variable sig tau : Type.
  Variable g : tau -> option sig.
  Variable def : sig.
  Variable F : Type.

  Definition surjectTapes : tapes tau n -> tapes sig n :=
    Vector.map (surjectTape g def).

  Definition lift_sigma_tau_Rel (R : Rel (tapes sig n) (F * tapes sig n)) :
    Rel (tapes tau n) (F * tapes tau n) :=
    fun tin '(yout,tout) => R (surjectTapes tin) (yout, surjectTapes tout).

  Definition lift_sigma_tau_T (T : Rel (Vector.t (tape sig) n) nat) :
    Rel (Vector.t (tape tau) n) nat :=
    fun tin k => T (surjectTapes tin) k.

  Lemma surjectTapes_nth t i :
    (surjectTapes t)[@i] = surjectTape g def t[@i].
  Proof. unfold surjectTapes. now simpl_vector. Qed.

End lift_sigma_tau.

Arguments surjectTapes {n sig tau} (g) def !t.
Hint Rewrite surjectTapes_nth : tape.

Arguments lift_sigma_tau_Rel {n sig tau} (g def) {F} (R) x y /.
Arguments lift_sigma_tau_T {n sig tau} (g def T) x y /.

Section InjectTape.

  Variable sig tau : Type.
  Variable f : sig -> tau.

  Definition injectTape := mapTape f.
  Definition injectTapes {n: nat} := mapTapes (n := n) f.
End InjectTape.

Section InjectSurject.
  Variable sig tau : Type.
  Variable inj : Retract sig tau.
  Variable def : sig.

  Lemma surject_inject' (l : list sig) :
    List.map (fun t : tau => match Retr_g t with
                          | Some s => s
                          | None => def
                          end) (List.map Retr_f l) = l.
  Proof.
    induction l; cbn.
    - reflexivity.
    - retract_adjoint. f_equal. assumption.
  Qed.

  Lemma surject_inject_tape (t : tape sig) :
    surjectTape Retr_g def (injectTape Retr_f t) = t.
  Proof.
    unfold surjectTape, injectTape, surject.
    destruct t; cbn; f_equal; try rewrite retract_g_adjoint; auto; apply surject_inject'.
  Qed.

  (*
  Lemma surject_inject_tapes {n : nat} (t : Vector.t (tape sig) n) :
    surjectTapes g def (injectTapes f t) = t.
  Proof.
    unfold surjectTapes, injectTapes, mapTapes.
    apply Vector.eq_nth_iff. intros p ? <-.
    erewrite !Vector.nth_map; eauto.
    apply surject_inject_tape.
  Qed.
*)

End InjectSurject.

Section TranslateAct.
  Variable X Y : Type.
  Definition map_act : (X -> Y) -> option X * move -> option Y * move := fun f => map_fst (map_opt f).
End TranslateAct.

Section LiftAlphabet.
  Variable sig tau : finType.
  Variable n : nat.
  Variable F : finType.
  Variable pMSig : pTM sig F n.

  Variable Inj : Retract sig tau.

  Variable def : sig.

  Definition surjectReadSymbols : Vector.t (option tau) n -> Vector.t (option sig) n :=
    Vector.map (map_opt (surject Retr_g def)).

  Definition lift_trans :=
    fun '(q, sym) =>
      let (q', act) := trans (m := projT1 pMSig) (q, surjectReadSymbols sym) in
      (q', Vector.map (map_act Retr_f) act).

  Definition LiftAlphabet_TM : mTM tau n :=
    {| trans := lift_trans;
       start := start (projT1 pMSig);
       halt := halt (m := projT1 pMSig) |}.

  Definition LiftAlphabet :pTM tau F n :=
    (LiftAlphabet_TM; projT2 pMSig).

  Definition surjectConf : (mconfig tau (states LiftAlphabet_TM) n) -> (mconfig sig (states (projT1 pMSig)) n) :=
    fun c => mk_mconfig (cstate c) (surjectTapes Retr_g def (ctapes c)).

  (*
  Definition injectConf : (mconfig sig (states (projT1 pMSig)) n) -> (mconfig tau (states liftM) n) :=
    fun c => mk_mconfig (cstate c) (injectTapes Retr_f (ctapes c)).
*)

  Lemma doAct_surject :
    forall (tape : tape tau) (act : option sig * move) (d : sig),
      doAct (surjectTape Retr_g d tape) act =
      surjectTape Retr_g d (doAct tape (map_act Retr_f act)).
  Proof.
    intros tape. intros (w,m) d; cbn.
    unfold surjectTape, doAct, tape_move, tape_write, surject; cbn.
    destruct tape, m, w; cbn; f_equal; try retract_adjoint; auto.
    - destruct l; cbn; f_equal; now retract_adjoint.
    - destruct l; cbn; f_equal; now retract_adjoint.
    - destruct l0; cbn; f_equal; now retract_adjoint.
    - destruct l0; cbn; f_equal; now retract_adjoint.
  Qed.

  Lemma current_chars_surjectTapes (t : tapes tau n) :
    current_chars (surjectTapes Retr_g def t) = surjectReadSymbols (current_chars t).
  Proof.
    unfold current_chars, surjectTapes, surjectReadSymbols. apply Vector.eq_nth_iff; intros i ? <-. simpl_tape.
    unfold surjectTape, surject. now simpl_tape.
  Qed.

  Lemma LiftAlphabet_comp_step (c : mconfig tau (states (projT1 pMSig)) n) :
    step (M := projT1 pMSig) (surjectConf c) = surjectConf (step (M := LiftAlphabet_TM) c).
  Proof.
    unfold surjectConf. destruct c as [q t]. cbn in *.
    unfold step. cbn -[doAct_multi].
    rewrite current_chars_surjectTapes.
    destruct (trans (q, surjectReadSymbols (current_chars t))) eqn:E. cbn.
    f_equal. unfold doAct_multi, surjectTapes. apply Vector.eq_nth_iff; intros i ? <-. simpl_tape. apply doAct_surject.
  Qed.

  Lemma LiftAlphabet_lift (c1 c2 : mconfig tau (states LiftAlphabet_TM) n) (k : nat) :
    loopM (M := LiftAlphabet_TM) c1 k = Some c2 ->
    loopM (M := projT1 pMSig) (surjectConf c1) k = Some (surjectConf c2).
  Proof.
    unfold loopM. intros H. eapply loop_lift. 3: apply H. auto.
    - intros ? _. apply LiftAlphabet_comp_step.
  Qed.

  Lemma LiftAlphabet_Realise (R : Rel (tapes sig n) (F * tapes sig n)) :
    pMSig ⊨ R ->
    LiftAlphabet ⊨ lift_sigma_tau_Rel Retr_g def R.
  Proof.
    intros H. intros t i outc Hloop. unfold lift_sigma_tau_Rel. hnf in H.
    specialize (H (surjectTapes Retr_g def t) i (mk_mconfig (cstate outc) (surjectTapes Retr_g def (ctapes outc)))).
    cbn in H. apply H.
    now apply (@LiftAlphabet_lift (initc LiftAlphabet_TM t) outc i).
  Qed.

  Lemma LiftAlphabet_unlift (k : nat) iconf (oconf : mconfig sig (states (projT1 pMSig)) n) :
    loopM (surjectConf iconf) k = Some oconf ->
    exists oconf' : mconfig tau (states LiftAlphabet_TM) n,
      loopM iconf k = Some oconf'.
  Proof.
    intros HLoop. unfold loopM in *.
    apply loop_unlift with (f := step(M:=LiftAlphabet_TM)) (h:=haltConf(M:=LiftAlphabet_TM)) in HLoop as (c'&HLoop&->); eauto.
    - intros ? _. now apply LiftAlphabet_comp_step.
  Qed.

  Lemma LiftAlphabet_TerminatesIn (T : Rel (tapes sig n) nat) :
    projT1 pMSig ↓ T ->
    projT1 LiftAlphabet ↓ lift_sigma_tau_T Retr_g def T.
  Proof.
    intros H. hnf. intros tin k HTerm. hnf in HTerm, H. specialize (H _ _ HTerm) as (oconf&HLoop).
    eapply LiftAlphabet_unlift; eauto.
  Qed.

  Lemma LiftAlphabet_RealiseIn (R : Rel (tapes sig n) (F * tapes sig n)) (k : nat) :
    pMSig ⊨c(k) R ->
    LiftAlphabet ⊨c(k) lift_sigma_tau_Rel Retr_g def R.
  Proof.
    intros [H1 H2] % Realise_total. eapply Realise_total. split; cbn in *.
    - now eapply LiftAlphabet_Realise.
    - eapply LiftAlphabet_TerminatesIn in H2. auto.
  Qed.

End LiftAlphabet.

Arguments LiftAlphabet : simpl never.

Ltac smpl_TM_LiftAlphabetSigma :=
  lazymatch goal with
  | [ |- LiftAlphabet _ _ _ ⊨ _] => eapply LiftAlphabet_Realise; swap 1 2
  | [ |- LiftAlphabet _ _ _ ⊨c(_) _] => eapply LiftAlphabet_RealiseIn; swap 1 2
  | [ |- projT1 (LiftAlphabet _ _ _) ↓ _] => eapply LiftAlphabet_TerminatesIn; swap 1 2
  end.
Smpl Add smpl_TM_LiftAlphabetSigma : TM_Correct.


From stdpp Require Export strings.
From stdpp Require Import relations BVnumbers.
From Coq Require Import Ascii.
From stdpp Require Import options.

Class Pretty A := pretty : A → string.
Global Hint Mode Pretty ! : typeclass_instances.

Definition pretty_N_char (x : N) : ascii :=
  match x with
  | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
  | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
  end%char%N.
Lemma pretty_N_char_inj x y :
  (x < 10)%N → (y < 10)%N → pretty_N_char x = pretty_N_char y → x = y.
Proof. compute; intros. by repeat (discriminate || case_match). Qed.

Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string :=
  match decide (0 < x)%N with
  | left H => pretty_N_go_help (x `div` 10)%N
     (Acc_inv acc (N.div_lt x 10 H eq_refl))
     (String (pretty_N_char (x `mod` 10)) s)
  | right _ => s
  end.
(** The argument [S (N.size_nat x)] of [wf_guard] makes sure that computation
works if [x] is a closed term, but that it blocks if [x] is an open term. The
latter prevents unexpected stack overflows, see [tests/pretty.v]. *)
Definition pretty_N_go (x : N) : string → string :=
  pretty_N_go_help x (wf_guard (S (N.size_nat x)) N.lt_wf_0 x).
Global Instance pretty_N : Pretty N := λ x,
  if decide (x = 0)%N then "0" else pretty_N_go x "".

Lemma pretty_N_go_0 s : pretty_N_go 0 s = s.
Proof. done. Qed.
Lemma pretty_N_go_help_irrel x acc1 acc2 s :
  pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s.
Proof.
  revert x acc1 acc2 s; fix FIX 2; intros x [acc1] [acc2] s; simpl.
  destruct (decide (0 < x)%N); auto.
Qed.
Lemma pretty_N_go_step x s :
  (0 < x)%N → pretty_N_go x s
  = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s).
Proof.
  unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x).
  destruct (wf_guard _ _). (* this makes coqchk happy. *)
  unfold pretty_N_go_help at 1; fold pretty_N_go_help.
  by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel.
Qed.

(** Helper lemma to prove [pretty_N_inj] and [pretty_Z_inj]. *)
Lemma pretty_N_go_ne_0 x s : s ≠ "0" → pretty_N_go x s ≠ "0".
Proof.
  revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?.
  assert (x = 0 ∨ 0 < x < 10 ∨ 10 ≤ x)%N as [->|[[??]|?]] by lia.
  - by rewrite pretty_N_go_0.
  - rewrite pretty_N_go_step by done. apply IH.
    { by apply N.div_lt. }
    assert (x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4 ∨ x = 5 ∨ x = 6
          ∨ x = 7 ∨ x = 8 ∨ x = 9)%N by lia; naive_solver.
  - rewrite 2!pretty_N_go_step by (try apply N.div_str_pos_iff; lia).
    apply IH; [|done].
    trans (x `div` 10)%N; apply N.div_lt; auto using N.div_str_pos with lia.
Qed.
(** Helper lemma to prove [pretty_Z_inj]. *)
Lemma pretty_N_go_ne_dash x s s' : s ≠ "-" +:+ s' → pretty_N_go x s ≠ "-" +:+ s'.
Proof.
  revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?.
  assert (x = 0 ∨ 0 < x)%N as [->|?] by lia.
  - by rewrite pretty_N_go_0.
  - rewrite pretty_N_go_step by done. apply IH.
    { by apply N.div_lt. }
    unfold pretty_N_char. by repeat case_match.
Qed.

Global Instance pretty_N_inj : Inj (=@{N}) (=) pretty.
Proof.
  cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' →
    String.length s = String.length s' → x = y ∧ s = s').
  { intros help x y. unfold pretty, pretty_N. intros.
    repeat case_decide; simplify_eq/=; [done|..].
    - by destruct (pretty_N_go_ne_0 y "").
    - by destruct (pretty_N_go_ne_0 x "").
    - by apply (help x y "" ""). }
  assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help.
  { setoid_rewrite <-Nat.le_ngt.
    intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s.
    assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|].
    rewrite pretty_N_go_step by done.
    etrans; [|by eapply IH, N.div_lt]; simpl; lia. }
  intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'.
  assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia;
    rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done.
  { done. }
  { intros -> Hlen. edestruct help; rewrite Hlen; simpl; lia. }
  { intros <- Hlen. edestruct help; rewrite <-Hlen; simpl; lia. }
  intros Hs Hlen.
  apply IH in Hs as [? [= Hchar]];
    [|auto using N.div_lt_upper_bound with lia|simpl; lia].
  split; [|done].
  apply pretty_N_char_inj in Hchar; [|by auto using N.mod_lt..].
  rewrite (N.div_mod x 10), (N.div_mod y 10) by done. lia.
Qed.

Global Instance pretty_nat : Pretty nat := λ x, pretty (N.of_nat x).
Global Instance pretty_nat_inj : Inj (=@{nat}) (=) pretty.
Proof. apply _. Qed.

Global Instance pretty_positive : Pretty positive := λ x, pretty (Npos x).
Global Instance pretty_positive_inj : Inj (=@{positive}) (=) pretty.
Proof. apply _. Qed.

Global Instance pretty_Z : Pretty Z := λ x,
  match x with
  | Z0 => "0" | Zpos x => pretty x | Zneg x => "-" +:+ pretty x
  end%string.
Global Instance pretty_Z_inj : Inj (=@{Z}) (=) pretty.
Proof.
  unfold pretty, pretty_Z.
  intros [|x|x] [|y|y] Hpretty; simplify_eq/=; try done.
  - by destruct (pretty_N_go_ne_0 (N.pos y) "").
  - by destruct (pretty_N_go_ne_0 (N.pos x) "").
  - by edestruct (pretty_N_go_ne_dash (N.pos x) "").
  - by edestruct (pretty_N_go_ne_dash (N.pos y) "").
Qed.


(** printing ⊢k #⊢k# *)
(** printing ⊢s #⊢s# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ↗! #↗# *)
(** printing ↘! #↘# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.
Require Import OperationProperties.
Require Import StructuralProperties.

(** * OPE#<:#

    This file defines the order-preserving sub-environment, or OPE#<:#
 and examines its properties. This file is very similar to the one in
 D#<:# and thus will not be discussed further.
  *)
Reserved Notation "G1 ⊆<⦂ G2" (at level 90).
Inductive ope_sub : env -> env -> Prop :=
|  os_nil :
     nil ⊆<⦂ nil
| os_drop : forall (G1 G2 : env) (x : atom) (T : typ),
    G2 ⊆<⦂ G1 ->
    (x, T) :: G2 ⊆<⦂ G1
| os_keep : forall (G1 G2 : env) (x : atom) (T1 T2 : typ),
    G2 ⊆<⦂ G1 ->
    G2 ⊢F T1 <⦂ T2 ->
    (x, T1) :: G2 ⊆<⦂ (x, T2) :: G1
where "G1 ⊆<⦂ G2" := (ope_sub G2 G1).
Local Hint Constructors ope_sub.

Section OpeProperties.

  Lemma ope_sub_length : forall G1 G2,
    G2 ⊆<⦂ G1 ->
    length G1 <= length G2.
  Proof.
    induction on ope_sub; routine.
  Qed.

  Hint Resolve weaken_subty.

  Lemma ope_narrow_var :
    forall G G' x T,
      G' ⊆<⦂ G ->
      binds x T G ->
      exists T', binds x T' G' /\ (G' ⊢F T' <⦂ T).
  Proof.
    induction on ope_sub; intros.
    - routine.
    - apply IHope_sub in H.
      tidy_up.
      eexists; split; eauto.
      simpl_env; eauto.
    - tidy_up.
      + eexists; split; eauto.
        simpl_env; eauto.
      + apply IHope_sub in H0.
        tidy_up.
        eexists; split; eauto.
        simpl_env; eauto.
  Qed.

  Hint Resolve subty_refl subty_trans.

  Lemma ope_narrow_subty : forall G T U,
      G ⊢F T <⦂ U ->
      forall G',
        G' ⊆<⦂ G ->
        G' ⊢F T <⦂ U.
  Proof.
    induction on subty; intros; eauto 4.
    - eapply ope_narrow_var in H; eroutine.
    - eapply st_all. auto.
      cofinite. eroutine.
  Qed.
  Hint Resolve ope_narrow_subty.

  Lemma ope_sub_trans : forall G1 G2 G3,
      G2 ⊆<⦂ G1 ->
      G3 ⊆<⦂ G2 ->
      G3 ⊆<⦂ G1.
  Proof.
    intros. gen G1. induction H0; intros; auto.
    invert H1; subst; eauto.
  Qed.

  Lemma ope_sub_refl : forall G,
      G ⊆<⦂ G.
  Proof. induction on env; routine. Qed.

  Lemma ope_sub_nil : forall G,
      G ⊆<⦂ nil.
  Proof. induction on env; routine. Qed.

  Lemma ope_sub_app : forall G G1 G2,
      G2 ⊆<⦂ G ->
      G1 ++ G2 ⊆<⦂ G.
  Proof. induction G1; routine. Qed.

  Lemma ope_sub_app_r : forall G G1 G2,
      G ⊆<⦂ G1 ++ G2 ->
      G ⊆<⦂ G2.
  Proof.
    dep induction on ope_sub; eroutine.
    - destruct H0, H1; routine.
    - destruct H0; routine.
      specialize (IHope_sub H0 H1 eq_refl).
      auto.
  Qed.

End OpeProperties.


Require Import CpdtTactics.
From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Sorting.Permutation.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Arith.Peano_dec.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Strings.String.
Require Import Maps.
Require NMaps.
Import ListNotations.

Local Set Warnings "-implicit-core-hint-db".
Local Set Warnings "-deprecated-focus".
Local Set Warnings "-unused-intro-pattern".
Local Set Warnings "-local-declaration".

From Coq Require Import Relations.Relations.
From Coq Require Import Relations.Relation_Definitions.
Hint Constructors clos_refl_trans_1n.

Hint Constructors Permutation.Permutation.

Ltac inv H := inversion H; subst; clear H.
Ltac dtr := repeat (match goal with
                    | [H : _ /\ _ |- _] => destruct H
                    | [H : exists _ , _ |- _] => destruct H
                    end).
Ltac exi := eapply ex_intro.

Set Implicit Arguments.

Require Import SyntaxRuntime.
Require Import Typing.
Require Import OperationalSemantics.

Require Import MetaTheoryBase.
Require Import MetaTheoryTyping.
Require Import MetaTheoryLocalConfluence.

Lemma dry_goes_nowhere : forall c c',
  well_typed c ->
  dry c ->
  (exists n, c -->*[n] c') ->
  c = c'.
Proof using.
  intros; dtr.
  destruct c as [b os rs t].
  remember (C b os rs t) as c.
  eapply dry_normal_form in H0; eauto.
  unfold normal_form in H0.
  destruct x.
  - eauto.
  - exfalso. apply H0. inv H1. eauto.
Qed.
Hint Resolve dry_goes_nowhere.

Lemma well_typed_preservation' : forall c n c',
  well_typed c ->
  c -->*[n] c' ->
  well_typed c'.
Proof using.
  intros c n c' WT Hmulti.
  induction Hmulti; subst; eauto.
  assert (well_typed y) by (eapply well_typed_preservation; eauto).
  eauto.
Qed.
Hint Resolve well_typed_preservation'.

Definition r_complete (p : config -> config -> Prop) :=
  forall cx, (forall cy cy' n m, n > 0 -> m > 0 -> cx -->*[n] cy -> cx -->*[m] cy' -> p cy cy') -> p cx cx.

Axiom principal_of_noe_indo : forall P, r_complete P -> forall cx, P cx cx.

Definition pp cx cy := well_typed cx -> well_typed cy -> cx == cy ->
                                  forall cx' cy' n m,
                                    cx -->*[n] cx' ->
                                    cy -->*[m] cy' ->
                                    cx' -v cy'.

(* we are only interested in reductions that terminate *)
Hypothesis to_dry : forall c, exists n c', c -->*[n] c' /\ dry c'.

Lemma pp_r_complete :
  r_complete pp.
Proof using.
  unfold r_complete; intros.
    unfold pp in *.
  intros.
  rename cy' into cz.
  rename cx' into cy.
  rename H3 into XY.
  rename H4 into XZ.
  assert (H3: 1 + 1 = 2) by auto.
  destruct m; destruct n.
  (* n = 0, m = 0 *)
  - apply star_zero in XY.
    apply star_zero in XZ.
    crush.
  (* n = 0, m > 0 *)
  - inv XY.
    apply star_zero in XZ; subst.
    eapply ex_intro.
    eapply ex_intro.
    split; try split.
    + instantiate (1:=cy).
      crush.
    + instantiate (1:=cy).
      apply ex_intro with (S n).
      apply Step with (y).
      assumption.
      assumption.
    + crush.
  (* n > 0, m = 0 *)
  - inv XZ.
    apply star_zero in XY; subst.
    eapply ex_intro.
    eapply ex_intro.
    split; try split.
    + instantiate (1:=cz).
      apply ex_intro with (S m).
      apply Step with (y).
      assumption.
      assumption.
    + instantiate (1:=cz).
      crush.
    + crush.
  (* n > 0, m > 0 *)
  - inv XY.
    rename y into cy'.
    inv XZ.
    rename y into cz'.
    destruct (local_confluence H1 H5 H7).
    destruct H4. destruct H4. destruct H9. destruct H4. destruct H9.
    rename x into cy''.
    rename x0 into cz''.
    assert (exists n cw, cy -->*[n] cw /\ normal_form cw).
    {
      destruct (@to_dry cy); dtr.
      exists x, x0. destruct x0.
      split; [eauto|eapply dry_normal_form; eauto].
    }
    destruct H11 as [n' H']. destruct H' as [cw cycw]. destruct cycw as [cycw nfcw].
    assert (exists n cw', cy'' -->*[n] cw' /\ normal_form cw').
    {
      destruct (@to_dry cy''); dtr.
      exists x, x0. destruct x0.
      split; [eauto|eapply dry_normal_form; eauto].
    }
    destruct H11 as [n'' H']. destruct H' as [cw' cycw']. destruct cycw' as [cycw' nfcw'].
    assert (exists n cv, cz'' -->*[n] cv /\ normal_form cv).
    {
      destruct (@to_dry cz''); dtr.
      exists x, x0. destruct x0.
      split; [eauto|eapply dry_normal_form; eauto].
    }
    destruct H11 as [n''' H']. destruct H' as [cv cycv]. destruct cycv as [cycv nfcv].
    assert (exists n cv', cz -->*[n] cv' /\ normal_form cv').
    {
      destruct (@to_dry cz); dtr.
      exists x, x0. destruct x0.
      split; [eauto|eapply dry_normal_form; eauto].
    }
    destruct H11 as [n'''' H']. destruct H' as [cv' cycv']. destruct cycv' as [cycv' nfcv'].
    assert (Hsimcy' : cy' == cy') by crush.
    assert (cw == cw').
    {
      edestruct H with (cy:=cy') (cy':=cy') (cx':=cw) (cy'0:=cw') (n:=1) (m:=1); eauto.
      - destruct H11.
        destruct H11.
        destruct H11.
        destruct H12.
        destruct H12.
        assert (x = cw).
        {
          destruct x3.
          - apply star_zero in H11; eauto.
          - inversion H11. subst. exfalso. unfold normal_form in nfcw. apply nfcw. eauto.
        }
        subst.
        assert (x0 = cw').
        {
          destruct x4.
          - apply star_zero in H12; eauto.
          - inversion H12. subst. exfalso. unfold normal_form in nfcw'. apply nfcw'. eauto.
        }
        subst.
        assumption.
    }
    assert (Hsimcz' : cz' == cz') by crush.
    assert (cv == cv').
    {
      edestruct H with (cy:=cz') (cy':=cz') (cx':=cv) (cy'0:=cv') (n:=1); eauto.
      - destruct H12.
        destruct H12.
        destruct H12.
        destruct H13.
        destruct H13.
        assert (x = cv).
        {
          destruct x3.
          - apply star_zero in H12; eauto.
          - inversion H12. subst. exfalso. unfold normal_form in nfcv. apply nfcv. eauto.
        }
        subst.
        assert (x0 = cv').
        {
          destruct x4.
          - apply star_zero in H13; eauto.
          - inversion H13. subst. exfalso. unfold normal_form in nfcv'. apply nfcv'. eauto.
        }
        subst. assumption.
    }
    assert (cw' == cv).
    {
      edestruct H with (cy:=cy'') (cy':=cz'') (cx':=cw') (cy'0:=cv) (n:=S x1) (m:=S x2); eauto.
      - crush.
      - crush.
      - destruct H13.
        destruct H13.
        destruct H13.
        destruct H14.
        destruct H14.
        assert (x = cw').
        {
          destruct x3.
          - apply star_zero in H13; eauto.
          - inversion H13. subst. exfalso. unfold normal_form in nfcw'. apply nfcw'. eauto.
        }
        subst.
        assert (x0 = cv).
        {
          destruct x4.
          - apply star_zero in H14; eauto.
          - inversion H14. subst. exfalso. unfold normal_form in nfcv. apply nfcv. eauto.
        }
        subst. assumption.
    }
    apply ex_intro with cw.
    apply ex_intro with cv'.
    split; try split.
    + eauto.
    + eauto.
    + apply cequiv_trans with cw'; auto.
      apply cequiv_trans with cv; auto.
Qed.

(* Theorem 6.5 and Corollary 6.7 *)
(* Note that eager processing is a set of specific context choices of lazy processing (Fig 14) *)
Theorem confluence :
  forall cx cy cz,
  well_typed cx ->
  (exists n, cx -->*[n] cy) ->
  (exists m, cx -->*[m] cz) ->
  (cy -v cz).
Proof using.
  intros.
  destruct H0.
  destruct H1.
  edestruct (@principal_of_noe_indo pp) with (cx:=cx) (cx':=cy); eauto.
- apply pp_r_complete.
Qed.

Definition init (b : backend) (t : term) := C b [] [] t.

(* Theorem 6.6 *)
Theorem determinism : forall b t i i' i'',
  i = init b t ->
  well_typed i ->
  (exists n, i -->*[n] i') ->
  (exists m, i -->*[m] i'') ->
  dry i' ->
  dry i'' ->
  i' == i''.
Proof using.
  intros.
  copy H1.
  apply confluence with (cy:=i'') in H1; auto.
  dtr.
  assert (i'' = x1) by eauto.
  assert (i' = x2) by eauto.
  subst.
  apply cequiv_symmetric; auto.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Definition assert : val :=
  λ: "v", if: "v" #() then #() else #0 #0. (* #0 #0 is unsafe *)
(* just below ;; *)
Notation "'assert:' e" := (assert (λ: <>, e))%E (at level 99) : expr_scope.

Lemma twp_assert `{heapG Σ} E (Φ : val → iProp Σ) e :
  WP e @ E [{ v, ⌜v = #true⌝ ∧ Φ #() }] -∗
  WP assert (LamV BAnon e)%V @ E [{ Φ }].
Proof.
  iIntros "HΦ". wp_lam.
  wp_apply (twp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
Qed.

Lemma wp_assert `{heapG Σ} E (Φ : val → iProp Σ) e :
  WP e @ E {{ v, ⌜v = #true⌝ ∧ ▷ Φ #() }} -∗
  WP assert (LamV BAnon e)%V @ E {{ Φ }}.
Proof.
  iIntros "HΦ". wp_lam.
  wp_apply (wp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
Qed.


Require Import Zee.lattice.
Require Import Zee.lang.

Require Import Zee.dec Zee.vals Zee.frame Zee.maplike.
Require Import Arith List Coq.Program.Basics Coq.Lists.ListSet Lia Coq.ZArith.BinInt.
Require Import Coq.Classes.RelationClasses.

Section Sem.
  Context {A : Set} {BinOpS : Set} `{lattice A}.
  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition SecTyV := @SecTyV A.
  Definition AtomSecTy := @AtomSecTy A.
  Definition Cmd := @Cmd A BinOpS.
  Definition Expr := @Expr A BinOpS.
  Definition V := @V A.

  Context {δ : string -> option Z}.
  Context {F: string -> option (list (string * Lab) *
                               list (string * Lab) *
                               list (string * SecTy) * Lab * Lab * Cmd) }.
  Context {eval_binop: BinOpS -> V -> V -> V}.
  Context {VarT ArgT LocT MemT : Type} {H_var_finmaplike: FinMapLike VarT string (A + SecTyV)} {H_arg_finmaplike: FinMapLike ArgT string SecTyV} {H_loc_finmaplike: FinMapLike LocT string SecTyV} {H_mem_maplike: MapLike MemT nat V}.
  Definition Frame := @Frame A VarT ArgT LocT MemT _ _ _ _.
  Definition PFrame := @PFrame A VarT ArgT LocT _ _ _.
  Definition EFrame := @EFrame A MemT _.

  Coercion eval_binop : BinOpS >-> Funclass.

  Definition Stk := list Frame.
  Hint Unfold Stk.

  Global Instance HasRange_Stk : HasRange Stk := {}.
  exact (fun stk =>
           let fix visit stk m :=
               match stk with
                 nil => m
               | fr :: stk' => visit stk' (sp_of (eframe_of fr))
               end
           in match stk with
                nil => (0, 0)
              | fr :: stk' => (fp_of (eframe_of fr), visit stk (sp_of (eframe_of fr)))
              end).
  Defined.

  Global Instance ReadableMapLike_Stk : ReadableMapLike Stk nat V := {}.
  - exact (fun stk a =>
             let fix look stk :=
                 match stk with
                   nil => None
                 | fr :: stk' =>
                   match fr ? a with
                     Some v => Some v
                   | None => look stk'
                   end
                 end
             in look stk).
  - exact nil.
  - intros.
    simpl.
    reflexivity.
  Defined.

  Inductive ecfg := make_ecfg
                      {
                        expr_of: Expr;
                        ecfg_fr: Frame
                      }.

  Inductive scfg := make_scfg
                      {
                        secty_of: SecTy;
                        scfg_fr: PFrame
                      }.

  Inductive acfg := make_acfg
                      {
                        asecty_of: AtomSecTy;
                        ascfg_fr: PFrame
                      }.

  Inductive tcfg := make_tcfg
                      {
                        ty_of: Ty;
                        tcfg_fr: PFrame
                      }.

  Inductive kcfg := make_kcfg
                      {
                        lab_of: Lab;
                        kcfg_fr: PFrame
                      }.
  Hint Constructors ecfg scfg acfg tcfg.

  Notation "'⟨' e ',' fr '⟩ₑ'" := (make_ecfg e fr).
  Notation "'⟨' s ',' pfr '⟩ₛ'" := (make_scfg s pfr).
  Notation "'⟨' a ',' pfr '⟩ₐ'" := (make_acfg a pfr).
  Notation "'⟨' t ',' pfr '⟩ₜ'" := (make_tcfg t pfr).
  Notation "'⟨' k ',' pfr '⟩ₖ'" := (make_kcfg k pfr).

  Reserved Notation "kcfg '⇓ₖ' ℓ" (at level 80).

  Inductive EvalLab: kcfg -> A -> Prop :=
  | ElabVar κ ℓ pfr:
      pfr ? κ = Some (inl ℓ) ->
      ⟨LabVar κ, pfr⟩ₖ ⇓ₖ ℓ
  | ElabLit ℓ pfr:
      ⟨Lit ℓ, pfr⟩ₖ ⇓ₖ ℓ
  | ELabJoin k1 k2 ℓ1 ℓ2 pfr:
      ⟨k1, pfr⟩ₖ ⇓ₖ ℓ1 ->
      ⟨k2, pfr⟩ₖ ⇓ₖ ℓ2 ->
      ⟨Join k1 k2, pfr⟩ₖ ⇓ₖ (ℓ1 ⊔ ℓ2)
  | ELabMeet k1 k2 ℓ1 ℓ2 pfr:
      ⟨k1, pfr⟩ₖ ⇓ₖ ℓ1 ->
      ⟨k2, pfr⟩ₖ ⇓ₖ ℓ2 ->
      ⟨Meet k1 k2, pfr⟩ₖ ⇓ₖ (ℓ1 ⊓ ℓ2)
  where "kcfg '⇓ₖ' ℓ" := (EvalLab kcfg ℓ).
  Hint Constructors EvalLab.

  Reserved Notation "tcfg '⇓ₜ' π" (at level 80).
  Reserved Notation "scfg '⇓ₛ' τ" (at level 80).
  Reserved Notation "ecfg '⇓ₑ' τ" (at level 80).
  Reserved Notation "scfg '⇓ₐ' π" (at level 80).

  Fixpoint prodSecTyV (τ1 : SecTyV) (τ2 : SecTyV) : SecTyV :=
    match τ1 with
      ASTyV a => ProdSecTyV a τ2
    | ProdSecTyV a τ => ProdSecTyV a (prodSecTyV τ τ2)
    | NilTyV => τ2
    end.

  Fixpoint prodSecTyVlist (τs : list SecTyV) : SecTyV :=
    match τs with
      nil => NilTyV
    | τ :: τs' => prodSecTyV τ (prodSecTyVlist τs')
    end.

  Global Instance Raiseable_SecTyV : Raiseable SecTyV A := {}.
  Proof.
    intros τ ℓ.
    destruct τ.
    - destruct a.
      eapply ASTyV.
      constructor.
      + assumption.
      + eapply (a ⊔ ℓ).
      + constructor.
        eapply NonSecTyV.
    - eapply (ProdSecTyV a τ).
    - eapply NilTyV.
  Defined.

  Inductive EvalTy: tcfg -> TyV -> Prop :=
  | ETyInt pfr: ⟨IntTy, pfr⟩ₜ ⇓ₜ IntTV
  | ETyPtr k s pfr ℓ τ:
      ⟨k, pfr⟩ₖ ⇓ₖ ℓ ->
      ⟨s, pfr⟩ₛ ⇓ₛ τ ->
      ⟨PtrTy k s, pfr⟩ₜ ⇓ₜ (PtrTV ℓ τ)
  | ETySPtr s1 s2 pfr τ1 τ2:
      ⟨s1, pfr⟩ₛ ⇓ₛ τ1 ->
      ⟨s2, pfr⟩ₛ ⇓ₛ τ2 ->
      ⟨SPtrTy s1 s2, pfr⟩ₜ ⇓ₜ (SPtrTV τ1 τ2)
  | ETyExTy α k s pfr: ⟨ExTyTy α k s, pfr⟩ₜ ⇓ₜ (ExTyTV α s)
  | ETyExLab κ k s pfr: ⟨ExLabTy κ k s, pfr⟩ₜ ⇓ₜ (ExLabTV κ s)
  | ETyRec k s x pfr: ⟨RecTy k x s, pfr⟩ₜ ⇓ₜ (RecTyV x s)
  | ETySizeOf s pfr: ⟨SizeTy s, pfr⟩ₜ ⇓ₜ IntTV
  where "tcfg '⇓ₜ' π" := (EvalTy tcfg π)
  with EvalSecTy: scfg -> SecTyV -> Prop :=
       | ESecTySecTy a pfr τ:
           ⟨a, pfr⟩ₐ ⇓ₐ τ ->
           ⟨ASecTy a, pfr⟩ₛ ⇓ₛ τ
       | ESecTyProd τ1 τ2 (s1 : AtomSecTy) s2 pfr:
           ⟨s1, pfr⟩ₐ ⇓ₐ τ1 ->
           ⟨s2, pfr⟩ₛ ⇓ₛ τ2 ->
           ⟨ProdTy s1 s2, pfr⟩ₛ ⇓ₛ (prodSecTyV τ1 τ2)
       | ESecNilTy pfr:
           ⟨NilTy, pfr⟩ₛ ⇓ₛ NilTyV
  where "scfg '⇓ₛ' τ" := (EvalSecTy scfg τ)
  with EvalAtomSecTy: acfg -> SecTyV -> Prop :=
       | EAtomSecTySecTy t pfr π k ℓ:
           ⟨t, pfr⟩ₜ ⇓ₜ π ->
           ⟨k, pfr⟩ₖ ⇓ₖ ℓ ->
           ⟨STy t k, pfr⟩ₐ ⇓ₐ (STyV π ℓ)
       | ESecTyVar α k τ ℓ pfr:
           pfr ? α = Some (inr τ) ->
           ⟨k, pfr⟩ₖ ⇓ₖ ℓ ->
           ⟨VarTy α k, pfr⟩ₐ ⇓ₐ (τ ^^ ℓ)
  where "scfg ⇓ₐ π" := (EvalAtomSecTy scfg π).
  Hint Constructors EvalTy EvalSecTy EvalAtomSecTy.

  Fixpoint sizeOf (τ : SecTyV) : option nat :=
    match τ with
    | ASTyV _ => Some 1
    | ProdSecTyV _ τ' =>
      match sizeOf τ' with
      | Some n => Some (S n)
      | None => None
      end
    | NilTyV => Some 0
    end.

  Coercion Z.of_nat: nat >-> Z.

  Definition addr_of {X : Type} `{HasRange X} (n : Z) (x : X) : nat :=
    Z.to_nat (n + fp_of x).
  Hint Unfold addr_of.

  Inductive EvalExpr: ecfg -> V -> Prop :=
  | ENum n fr: ⟨Num n, fr⟩ₑ ⇓ₑ VNum n
  | EVar x fr v n:
      δ x = Some n ->
      fr ? addr_of n fr = Some v ->
      ⟨Var x, fr⟩ₑ ⇓ₑ v
  | EBinOp e1 e2 v1 v2 (o : BinOpS) fr:
      ⟨e1, fr⟩ₑ ⇓ₑ v1 ->
      ⟨e2, fr⟩ₑ ⇓ₑ v2 ->
      ⟨BinOp o e1 e2, fr⟩ₑ ⇓ₑ (o v1 v2)
  | ESizeOf s fr τ n:
      ⟨s, pframe_of fr⟩ₛ ⇓ₛ τ ->
      sizeOf τ = Some n ->
      ⟨SizeOf s, fr⟩ₑ ⇓ₑ VNum n
  | EPackTy s1 s2 fr α τ e v k:
      ⟨s1, pframe_of fr⟩ₛ ⇓ₛ τ ->
      ⟨e, fr⟩ₑ ⇓ₑ v ->
      ⟨PackTy s1 e k α s2, fr⟩ₑ ⇓ₑ ExTy τ v
  | EPackLab k1 k2 fr ℓ κ v e s:
      ⟨k1, pframe_of fr⟩ₖ ⇓ₖ ℓ ->
      ⟨e, fr⟩ₑ ⇓ₑ v ->
      ⟨PackLab k1 e k2 κ s, fr⟩ₑ ⇓ₑ ExLab ℓ v
  | EUnroll e fr v:
      ⟨e, fr⟩ₑ ⇓ₑ v ->
      ⟨Unroll e, fr⟩ₑ ⇓ₑ v
  | ERoll e fr v:
      ⟨e, fr⟩ₑ ⇓ₑ v ->
      ⟨Roll e, fr⟩ₑ ⇓ₑ v
  | EAddrOf x fr n:
      δ x = Some n ->
      ⟨AddrOf x, fr⟩ₑ ⇓ₑ (VAddr (addr_of n fr) (version fr))
  where "ecfg '⇓ₑ' v" := (EvalExpr ecfg v).
  Hint Constructors EvalExpr.

  Inductive cfg := make_cfg
                     {
                       cmd_of: Cmd;
                       stck_of: Stk;
                       time_of: nat;
                       ver_of: Version
                     }.
  Hint Constructors cfg.
  Notation "'⟨' c ',' stk ',' q ',' ν '⟩'" := (make_cfg c stk q ν).

  Fixpoint matches (τ : SecTyV) (p : SecPat) : bool :=
    match p with
      PNil =>
      match τ with
        NilTyV => true
      | _ => false
      end
    | PProd ap p =>
      match τ with
        ProdSecTyV a τ => atomMatches a ap && matches τ p
      | _ => false
      end
    | PAtom ap =>
      match ap with
        PVar _ => true
      | ap => match τ with
               ASTyV a => atomMatches a ap
             | _ => false
             end
      end
    end with
  atomMatches (τ : AtomSecTyV) (ap : AtomPat) : bool :=
    match τ with
      STyV π _ =>
      match ap with
        SPat p _ =>
        match π, p with
          IntTV, PInt => true
        | SPtrTV τ1 τ2, PSPtr p1 p2 =>
          matches τ1 p1 && matches τ2 p2
        | PtrTV _ τ, PPtr _ p => matches τ p
        | _, _ => false
        end
      | PVar _ => true
      end
    | NonSecTyV => false
    end.

  Infix "≲" := matches (at level 70).

  Lemma var_matches_all:
    forall τ n,
      τ ≲ (PVar n) = true.
  Proof.
    intros.
    destruct τ; reflexivity.
  Qed.
  Hint Resolve var_matches_all.

  Fixpoint find_match (τ : SecTyV) (pats : list (SecPat * Cmd)) : option (SecPat * Cmd) :=
    match pats with
      nil => None
    | (p, c) :: pats' =>
      if (matches τ p) then Some (p, c)
      else find_match τ pats'
    end.

  Fixpoint close (p : SecPat) (τ : SecTyV) (pfr : PFrame) : option PFrame :=
    match p with
      PAtom ap =>
      match τ with
        ASTyV π => atomClose ap π pfr
      | _ => match ap with
              PVar α => Some (pfr [α ↦ inr τ])
            | _ => None
            end
      end
    | PProd ap p =>
      match τ with
        ProdSecTyV a τ =>
        match atomClose ap a pfr with
          Some pfr' => close p τ pfr'
        | None => None
        end
      | _ => None
      end
    | PNil => Some pfr
    end
  with atomClose (ap : AtomPat) (π : AtomSecTyV) (pfr : PFrame) : option PFrame :=
         match ap with
           SPat p κ =>
           match π with
             STyV ι ℓ =>
             match p, ι with
               PInt, IntTV => Some (pfr [κ ↦ inl ℓ])
             | PSPtr p1 p2, SPtrTV τ1 τ2 =>
               match close p1 τ1 pfr with
                 Some pfr' =>
                 match close p2 τ2 pfr' with
                   Some pfr'' => Some (pfr'' [κ ↦ inl ℓ])
                 | None => None
                 end
               | None => None
               end
             | PPtr x p1, PtrTV ℓ1 τ =>
               match close p1 τ pfr with
                 Some pfr' => Some (pfr' [x ↦ inl ℓ1] [κ ↦ inl ℓ])
               | None => None
               end
             | _, _ => None
             end
           | NonSecTyV => None
           end
         | PVar α => Some (pfr [α ↦ inr (ASTyV π)])
         end.

  Lemma invert_find_match:
    forall τ p pats c,
      find_match τ pats = Some (p, c) ->
      exists pats1 pats2, pats = pats1 ++ (p, c) :: pats2 /\ τ ≲ p = true.
  Proof.
    intros.
    induction pats; intros.
    - discriminate.
    - destruct a.
      cbn in *.
      destruct (τ ≲ s) eqn:?H.
      + inversion H; subst; clear H.
        exists nil; exists pats.
        firstorder.
      + destruct (IHpats H) as [pats1 [pats2 [? ?]]].
        subst.
        clear IHpats.
        exists ((s, c0) :: pats1); exists pats2.
        split; eauto.
  Qed.

  Lemma invert_match_prod:
    forall τ a p,
      (τ ≲ PProd a p) = true ->
      exists ap τ', τ = ProdSecTyV ap τ' /\ ap ≲ a = true /\ τ' ≲ p = true.
  Proof.
    intros.
    induction τ.
    - discriminate.
    - exists a0; exists τ.
      split; eauto.
      simpl in * |-.
      split.
      + symmetry in H.
        eapply Bool.andb_true_eq in H.
        destruct a; easy.
      + symmetry in H.
        eapply Bool.andb_true_eq in H.
        easy.
    - simpl in *.
      discriminate.
  Qed.

  Lemma match_is_sound: forall τ (p : SecPat) fr,
      (τ ≲ p = true -> exists fr', close p τ fr = Some fr')
  with atom_match_is_sound: forall (π : AtomSecTyV) (pat : AtomPat) fr,
      (π ≲ pat = true -> exists fr', atomClose pat π fr = Some fr').
  Proof.
    - intros.
      revert τ H fr.
      induction p.
      + intros.
        eapply invert_match_prod in H.
        destruct H as [ap [τ' [? [? ?]]]].
        subst.
        simpl.
        destruct (atom_match_is_sound ap a fr H1) as [fr' ?].
        destruct (IHp τ' H2 fr') as [fr'' ?].
        exists fr''.
        rewrite -> H.
        assumption.
      + intros.
        destruct τ; try discriminate.
        exists fr.
        reflexivity.
      + intros.
        cbn.
        destruct τ.
        * eapply atom_match_is_sound.
          assumption.
        * cbn in *.
          destruct a; try discriminate.
          eexists.
          reflexivity.
        * destruct a; try discriminate.
          eexists.
          reflexivity.
    - intros.
      induction pat.
      + cbn.
        destruct π; try discriminate.
        * destruct p; cbn in *.
          -- destruct t; (eexists; reflexivity) || discriminate.
          -- destruct t; cbn in *; try discriminate.
             assert (s2 ≲ s0 = true).
             {
               destruct (s2 ≲ s0); reflexivity || discriminate.
             }
             assert (s3 ≲ s1 = true).
             {
               destruct (s3 ≲ s1); try reflexivity.
               rewrite -> H1 in *.
               discriminate.
             }
             destruct (match_is_sound _ _ fr H1) as [fr' ?].
             simpl.
             rewrite -> H3.
             destruct (match_is_sound _ _ fr' H2) as [fr'' ?].
             rewrite -> H4.
             eexists.
             reflexivity.
          -- destruct t; try discriminate.
             destruct (match_is_sound _ _ fr H) as [fr' ?].
             rewrite -> H1.
             eexists. reflexivity.
      + eexists.
        reflexivity.
  Qed.

  Definition set_union := @set_union _ string_dec.
  Definition set_add := @set_add _ string_dec.
  Definition empty_set := empty_set string.

  Fixpoint vars (c : Cmd) : set string :=
    match c with
      CSkip => empty_set
    | CLet x _ _ c => set_add x (vars c)
    | CIf _ c1 c2 => set_union (vars c1) (vars c2)
    | CWhile _ c => vars c
    | CSeq c1 c2 => set_union (vars c1) (vars c2)
    | CWrite _ _ => empty_set
    | CRead _ _ => empty_set
    | CAt _ _ c => vars c
    | CLabIf _ _ c1 c2 => set_union (vars c1) (vars c2)
    | CMatch _ arms => fold_right (fun p => set_union (vars (snd p))) empty_set arms
    | CFP _ => empty_set
    | CCall _ _ _ _ => empty_set
    | CUnpTy _ _ x _ _ c => set_add x (vars c)
    | CUnpLab _ _ x _ _ c => set_add x (vars c)
    | CDelay _ => empty_set
    | CUnsc _ => empty_set
    | CEpi => empty_set
    | CStop => empty_set
    end.

  Definition make_ty_list (xs : list (string * SecTyV)) : SecTyV :=
    prodSecTyVlist (map snd xs).
  Hint Unfold make_ty_list.

  Definition make_pvar (κs : list string) (ℓs : list A) (αs : list string) (τs : list SecTyV) : VarT :=
    fold_right (fun p => update (fst p) (inr (snd p))) (fold_right (fun p => update (fst p) (inl (snd p))) ∅ (combine κs ℓs)) (combine αs τs).
  Hint Unfold make_pvar.

  Inductive make_parg : list (string * SecTy) -> VarT -> ArgT -> ArgT -> Prop :=
    MakePArgNil pvar parg: make_parg nil pvar parg parg
  | MakePArgCons x s τ ss pvar parg parg':
      ⟨s, (Build_PFrame pvar parg ∅)⟩ₛ ⇓ₛ τ ->
      make_parg ss pvar (update x τ parg) parg' ->
      make_parg ((x, s) :: ss) pvar parg parg'.
  Hint Constructors make_parg.

  Definition make_ploc (xs : set string) : LocT :=
    fold_right (fun x => update x (ASTyV NonSecTyV)) ∅ xs.
  Hint Unfold make_ploc.

  Definition make_mem (xs : list string) (vs : list V) (base: nat): option MemT :=
    let fix visit xs vs : option MemT :=
        match (xs, vs) with
          (nil, nil) => Some ∅
        | (x :: xs', v :: vs') =>
          match (visit xs' vs', δ x) with
            (Some m, Some nx) => Some (m [ Z.to_nat (nx + base) ↦ v ])
          | (_, _) => None
          end
        | (_, _) => None
        end
    in visit xs vs.
  Hint Unfold make_mem.

  Reserved Notation "cfg1 '-->' cfg2" (at level 80).

  Inductive Step: cfg -> cfg -> Prop :=
  | SSkip stk q ν: ⟨CSkip, stk, q, ν⟩ --> ⟨CStop, stk, q + 1, ν⟩
  | SLet x s e c stk fr q ν v τ n:
      ⟨s, pframe_of fr⟩ₛ ⇓ₛ τ ->
      ⟨e, fr⟩ₑ ⇓ₑ v ->
      δ x = Some n ->
      ⟨CLet x s e c, fr :: stk, q, ν⟩ -->
      ⟨CSeq c (CUnsc x), Build_Frame (upd_loc x τ (pframe_of fr)) (eframe_of fr [addr_of n fr ↦ v]) :: stk, q + 1, ν⟩
  | SIf1 c1 c2 e fr stk (n : nat) q ν:
      ⟨e, fr⟩ₑ ⇓ₑ VNum n ->
      n <> 0 ->
      ⟨CIf e c1 c2, fr :: stk, q, ν⟩ --> ⟨c1, fr :: stk, q + 1, ν⟩
  | SIf2 c1 c2 e fr stk q ν:
      ⟨e, fr⟩ₑ ⇓ₑ VNum 0 ->
      ⟨CIf e c1 c2, fr :: stk, q, ν⟩ --> ⟨c2, fr :: stk, q + 1, ν⟩
  | SWhile1 c e fr stk n q ν:
      ⟨e, fr⟩ₑ ⇓ₑ VNum n ->
      n <> 0 ->
      ⟨CWhile e c, fr :: stk, q, ν⟩ --> ⟨CSeq c (CWhile e c), fr :: stk, q + 1, ν⟩
  | SWhile2 c e fr stk q ν:
      ⟨e, fr⟩ₑ ⇓ₑ VNum 0 ->
      ⟨CWhile e c, fr :: stk, q, ν⟩ --> ⟨CStop, fr :: stk, q + 1, ν⟩
  | SSeq1 c1 c1' c2 stk stk' q q' ν ν':
      ⟨c1, stk, q, ν⟩ --> ⟨c1', stk', q', ν'⟩ ->
      c1' <> CStop ->
      ⟨CSeq c1 c2, stk, q, ν⟩ --> ⟨CSeq c1' c2, stk', q', ν'⟩
  | SSeq2 c1 c2 stk stk' q q' ν ν':
      ⟨c1, stk, q, ν⟩ --> ⟨CStop, stk', q', ν'⟩ ->
      ⟨CSeq c1 c2, stk, q, ν⟩ --> ⟨c2, stk', q', ν'⟩
  | SWrite e1 e2 stk1 stk2 q fr1 fr2 ν γ a v:
      hd_error (stk1 ++ fr1 :: stk2) = Some fr2 ->
      ⟨e1, fr2⟩ₑ ⇓ₑ VAddr a γ ->
      ⟨e2, fr2⟩ₑ ⇓ₑ v ->
      a ∈ fr1 ->
      version fr1 <= γ ->
      ⟨CWrite e1 e2, stk1 ++ fr1 :: stk2, q, ν⟩ --> ⟨CStop, stk1 ++ (fr1 [a ↦ v]) :: stk2, q + 1, ν⟩
  | SRead e fr a γ x stk q ν n (v : V):
      δ x = Some n ->
      ⟨e, fr⟩ₑ ⇓ₑ VAddr a γ ->
      (fr :: stk) ? a = Some v ->
      ⟨CRead x e, fr :: stk, q, ν⟩ --> ⟨CStop, (fr [addr_of n fr ↦ v]) :: stk, q + 1, ν⟩
  | SAt k e c fr stk q ν n:
      ⟨e, fr⟩ₑ ⇓ₑ VNum n ->
      ⟨CAt k e c, fr :: stk, q, ν⟩ --> ⟨CSeq c (CDelay n), fr :: stk, q + 1, ν⟩
  | SDelay n stk q ν:
      q <= n ->
      ⟨CDelay n, stk, q, ν⟩ --> ⟨CStop, stk, n + 1, ν⟩
  | SLabIf1 k1 k2 c1 c2 stk q ν ℓ1 ℓ2 fr:
      ⟨k1, pframe_of fr⟩ₖ ⇓ₖ ℓ1 ->
      ⟨k2, pframe_of fr⟩ₖ ⇓ₖ ℓ2 ->
      ℓ1 ⊑ ℓ2 ->
      ⟨CLabIf k1 k2 c1 c2, fr :: stk, q, ν⟩ --> ⟨c1, fr :: stk, q + 1, ν⟩
  | SLabIf2 k1 k2 c1 c2 stk q ν ℓ1 ℓ2 fr:
      ⟨k1, pframe_of fr⟩ₖ ⇓ₖ ℓ1 ->
      ⟨k2, pframe_of fr⟩ₖ ⇓ₖ ℓ2 ->
      ~ ℓ1 ⊑ ℓ2 ->
      ⟨CLabIf k1 k2 c1 c2, fr :: stk, q, ν⟩ --> ⟨c2, fr :: stk, q + 1, ν⟩
  | SMatch α pats fr pfr' stk τ q ν p c:
      fr ? α = Some (inr τ) ->
      find_match τ pats = Some (p, c) ->
      close p τ (pframe_of fr) = Some pfr' ->
      ⟨CMatch α pats, fr :: stk, q, ν⟩ --> ⟨c, Build_Frame pfr' (eframe_of fr) :: stk, q + 1, ν⟩
  | SFP x fr stk q ν n τ_arg τ_loc:
      δ x = Some n ->
      make_ty_list (values (parg_of (pframe_of fr))) = τ_arg ->
      make_ty_list (values (ploc_of (pframe_of fr))) = τ_loc ->
      ⟨CFP x, fr :: stk, q, ν⟩ -->
      ⟨CStop, fr [addr_of n fr ↦ ExTy τ_arg (ExTy τ_loc (VAddr (fp_of fr) ν))] :: stk, q + 1, ν⟩
  | SUnpTy α k x s e c fr τ τ1 n v2 stk q ν:
      ⟨e, fr⟩ₑ ⇓ₑ ExTy τ1 v2 ->
      ⟨s, pframe_of fr [α ↦ inr τ1]⟩ₛ ⇓ₛ τ ->
      δ x = Some n ->
      ⟨CUnpTy α k x s e c, fr :: stk, q, ν⟩ -->
      ⟨CSeq c (CUnsc x), Build_Frame (upd_loc x τ (pframe_of fr [α ↦ inr τ1])) (eframe_of fr [addr_of n fr ↦ v2]) :: stk, q + 1, ν⟩
  | SUnpLab κ k x s e c fr τ ℓ1 n v2 stk q ν:
      ⟨e, fr⟩ₑ ⇓ₑ ExLab ℓ1 v2 ->
      ⟨s, pframe_of fr [κ ↦ inl ℓ1]⟩ₛ ⇓ₛ τ ->
      δ x = Some n ->
      ⟨CUnpLab κ k x s e c, fr :: stk, q, ν⟩ -->
      ⟨CSeq c (CUnsc x), Build_Frame (upd_loc x τ (pframe_of fr [κ ↦ inl ℓ1])) (eframe_of fr [addr_of n fr ↦ v2]) :: stk, q + 1, ν⟩
  | SUnsc x fr stk q ν:
      ⟨CUnsc x, fr :: stk, q, ν⟩ --> ⟨CStop, Build_Frame (upd_loc x NonSecTyV (pframe_of fr)) (eframe_of fr) :: stk, q + 1, ν⟩
  | SCall f ks ss es κs αs ss' stk q ν c ℓs τs vs pvar' parg' ploc' xs τ_arg τ_loc m' pfr'' efr'' fr fr_k pc_k:
      F f = Some (κs, αs, ss', fr_k, pc_k, c) ->
      length ks = length ℓs ->
      length ss = length τs ->
      length es = length vs ->
      (forall i ℓ k, nth_error ks i = Some k /\ nth_error ℓs i = Some ℓ -> ⟨k, pframe_of fr⟩ₖ ⇓ₖ ℓ) ->
      (forall i τ s, nth_error ss i = Some s /\ nth_error τs i = Some τ -> ⟨s, pframe_of fr⟩ₛ ⇓ₛ τ) ->
      (forall i v e, nth_error es i = Some e /\ nth_error vs i = Some v -> ⟨e, fr⟩ₑ ⇓ₑ v) ->
      pvar' = make_pvar (map fst κs) ℓs (map fst αs) τs ->
      xs = vars c ->
      make_parg ss' pvar' ∅ parg' ->
      ploc' = make_ploc xs ->

      make_ty_list (values (parg_of (pframe_of fr))) = τ_arg ->
      make_ty_list (values (ploc_of (pframe_of fr))) = τ_loc ->
      make_mem (map fst ss') vs (S (sp_of fr) + length vs) = Some m' ->

      pfr'' = Build_PFrame pvar' parg' ploc' ->
      efr'' = Build_EFrame (S (sp_of fr) + length vs, length xs)
                           (m' [sp_of fr + length vs ↦
                                  ExTy τ_arg (ExTy τ_loc (VAddr (fp_of fr) ν)) ])
                           (version fr) ->

      ⟨CCall f ks ss es, fr :: stk, q, ν⟩ -->
      ⟨CSeq c CEpi, (Build_Frame pfr'' efr'') :: fr :: stk, q + 1, ν + 1⟩
  | SEpi fr stk q ν: ⟨CEpi, fr :: stk, q, ν⟩ --> ⟨CStop, stk, q + 1, ν⟩
  where "cfg1 '-->' cfg2" := (Step cfg1 cfg2).
  Hint Constructors Step.

  Definition initial_stk (c : Cmd) : Stk :=
    let xs := vars c
    in Build_Frame (Build_PFrame ∅ ∅ (make_ploc xs))
                   (Build_EFrame (1, length xs)
                                 (∅ [0 ↦ ExTy NilTyV (ExTy NilTyV (VAddr 0 0))]) 0) :: nil.
  Hint Unfold initial_stk.

  Reserved Notation "cfg1 '-->[' n ']' cfg2" (at level 80).
  Inductive step_many: cfg -> cfg -> nat -> Prop :=
  | StepMany0 C: C -->[0] C
  | StepManyS C C' C'' n:
      C --> C' ->
      C' -->[n] C'' ->
      C -->[S n] C''
  where "cfg1 '-->[' n ']' cfg2" := (step_many cfg1 cfg2 n).
  Hint Constructors step_many.

  Notation "cfg1 '-->*' cfg2" := (exists n, cfg1 -->[n] cfg2) (at level 80).

  Lemma evalLab_det:
    forall (k : Lab) pfr ℓ₁ ℓ₂,
      ⟨ k, pfr ⟩ₖ ⇓ₖ ℓ₁ ->
      ⟨ k, pfr ⟩ₖ ⇓ₖ ℓ₂ -> ℓ₁ = ℓ₂.
  Proof.
    intros.
    revert ℓ₁ ℓ₂ H H1.
    induction k; intros.
    - inversion H; subst; clear H.
      inversion H1; subst; clear H1.
      congruence.
    - inversion H; subst; clear H.
      inversion H1; subst; clear H1.
      reflexivity.
    - inversion H; subst; clear H.
      inversion H1; subst; clear H1.
      f_equal; eauto.
    - inversion H; subst; clear H.
      inversion H1; subst; clear H1.
      f_equal; eauto.
  Qed.
  Hint Resolve evalLab_det : label_eval.

End Sem.

Notation "'⟨' e ',' fr '⟩ₑ'" := (make_ecfg e fr).
Notation "'⟨' s ',' pfr '⟩ₛ'" := (make_scfg s pfr).
Notation "'⟨' a ',' pfr '⟩ₐ'" := (make_acfg a pfr).
Notation "'⟨' t ',' pfr '⟩ₜ'" := (make_tcfg t pfr).
Notation "'⟨' k ',' pfr '⟩ₖ'" := (make_kcfg k pfr).
Notation "kcfg '⇓ₖ' ℓ" := (EvalLab kcfg ℓ) (at level 80).
Notation "tcfg '⇓ₜ' π" := (EvalTy tcfg π) (at level 80).
Notation "scfg '⇓ₛ' τ" := (EvalSecTy scfg τ) (at level 80).
Notation "scfg '⇓ₐ' π" := (EvalAtomSecTy scfg π) (at level 80).
Notation "ecfg '⇓ₑ' v" := (EvalExpr ecfg v) (at level 80).
Notation "'⟨' c ',' stk ',' q ',' ν '⟩'" := (make_cfg c stk q ν).
Notation "cfg1 '-->' cfg2" := (Step cfg1 cfg2) (at level 80).
Notation "cfg1 '-->[' n ']' cfg2" := (step_many cfg1 cfg2 n) (at level 80).
Notation "cfg1 '-->*' cfg2" := (exists n, cfg1 -->[n] cfg2) (at level 80).

  Ltac solve_mapsto :=
    repeat (repeat autounfold with *; cbn;
            match goal with
              [ |- _ [_ ↦ ?v ] ? _ = Some _ ] =>
              rewrite -> lookup_update_eq; reflexivity
            | [ |- _ [_ ↦ ?v ] ? _ = Some _ ] =>
              rewrite -> lookup_update_neq by (easy || lia)
            end).

  Ltac simpl_mapsto :=
    repeat (cbn;
            match goal with
              [ |- context[_ [_ ↦ ?v ] ? _] ] =>
              rewrite -> lookup_update_eq
            | [ |- context[_ [_ ↦ ?v ] ? _] ] =>
              rewrite -> lookup_update_neq by (easy || lia)
            end).

  Ltac solve_in_range := (cbn; lia).

  Ltac eval_level := constructor; repeat constructor.

  Ltac eval_ty :=
    match goal with
      [ |- ⟨IntTy, _⟩ₜ ⇓ₜ _ ] =>
      constructor
    | [ |- ⟨PtrTy _ _, _⟩ₜ ⇓ₜ _ ] =>
      constructor; [ eval_level | eval_secty ]
    | [ |- ⟨SPtrTy _ _, _⟩ₜ ⇓ₜ _] =>
      constructor; [eval_secty | eval_secty]
    | [ |- ⟨_ @ _, _⟩ₜ ⇓ₜ _] =>
      constructor; [eval_secty | eval_secty]
    | [ |- ⟨RecTy _ _ _, _⟩ₜ ⇓ₜ _] =>
      constructor
    | [ |- ⟨ExTyTy _ _ _, _⟩ₜ ⇓ₜ _] =>
      constructor
    | [ |- ⟨ETyExLab _ _ _, _⟩ₜ ⇓ₜ _] =>
      constructor
    end with eval_atomic_secty :=
      match goal with
        [ |- ⟨STy _ _, _⟩ₐ ⇓ₐ _ ] =>
        constructor; [ eval_ty | eval_level]
      | [ |- ⟨VarTy _ _, _⟩ₐ ⇓ₐ _ ] =>
        constructor; [ solve_mapsto | eval_level]
      end with eval_secty :=
        (match goal with
           [ |- ⟨ASecTy _, _⟩ₛ ⇓ₛ _ ] =>
           eapply ESecTySecTy; [eval_atomic_secty]
         | [ |- ⟨ProdTy _ _, _⟩ₛ ⇓ₛ _ ] =>
           eapply ESecTyProd; [eval_atomic_secty | eval_secty]
         | [ |- ⟨_ · _, _⟩ₛ ⇓ₛ _ ] =>
           eapply ESecTyProd; [eval_atomic_secty | eval_secty]
         | [ |- ⟨NilTy, _⟩ₛ ⇓ₛ _ ] =>
           constructor
         end).

  Ltac eval_var :=
    (repeat autounfold with *; cbn; eapply EVar;
     [eassumption | solve_mapsto]).

  Ltac eval_addrof := cbn; eapply EAddrOf; [eassumption].

  Ltac eval_expr :=
    repeat (cbn; (eval_var || eval_addrof || constructor)).

  Ltac step_write :=
    match goal with
      [ |- ⟨_ *= _, ?stk, _, _⟩ --> _] =>
      rewrite <- (app_nil_l stk)
    end; eapply SWrite; [reflexivity | eval_expr | eval_expr | solve_in_range | solve_in_range].

  Ltac step_let :=
    cbn; eapply SLet; [eval_secty | eval_expr | eassumption].

  Ltac step_while1 :=
    eapply SWhile1; [ eval_var | lia ].

  Ltac step_while2 :=
      eapply SWhile2; [ eval_var ].

  Ltac step_while := step_while1 || step_while2.

  Ltac step_match :=
    cbn; eapply SMatch; [cbn; solve_mapsto | cbn; reflexivity | cbn; reflexivity].

  Ltac step_unpack_ty :=
    cbn; eapply SUnpTy; [eval_expr | eval_secty | eassumption].

  Ltac step_seq :=
    match goal with
      [ |- ⟨ CSkip ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ (CLet _ _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CIf _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CWhile _ _) ;; _ , _, _, _⟩ --> _ ] =>
      solve[eapply SSeq1; step_while] || solve[eapply SSeq2; step_while]
    | [ |- ⟨ (_ ;; _) ;; _ , _, _, _⟩ --> _ ] =>
      eapply SSeq1
    | [ |- ⟨ (CWrite _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ (CRead _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ (CAt _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CLabIf _ _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CMatch _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CFP _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ (CCall _ _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CUnpTy _ _ _ _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CUnpLab _ _ _ _ _ _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq1
    | [ |- ⟨ (CDelay _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ (CUnsc _) ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    | [ |- ⟨ CEpi ;; _ , _, _, _⟩ --> _ ] => eapply SSeq2
    end.


From ExtLib Require Export
     ListSet.
From FileSync Require Export
     File.
Export
  FileNotations.
Open Scope file_scope.
Open Scope list_scope.

Definition dirty (g s: node) (p: path) : bool :=
  match cd p g, cd p s with
  | Some n, Some m => negb $ n =? m
  | None  , None   => false
  | _     , _      => true
  end.

Definition dirtyPaths (g s: node) : list path :=
  List.filter (dirty g s) $ lset_union (list_eqb _) (pathsOf g) (pathsOf s).

Definition allPaths (g a b: node) : list path :=
  lset_union (list_eqb _) (dirtyPaths g a) (dirtyPaths g b).

Definition ssrecon (gab: node * node * node) (p: path) : node * node * node :=
  let '(g, a, b) := gab in
  match cd p g, cd p a, cd p b with
  | Some gp, Some ap, Some bp =>
      if ap =? gp
      then (override p bp g, override p bp a, b)
      else
        if bp =? gp
        then (override p ap g, a, override p ap b)
        else
          if ap =? bp
          then (override p ap g, a, b)
          else gab
  | None, Some ap, Some bp =>
      if ap =? bp
      then (override p ap g, a, b)
      else gab
  | Some gp, Some ap, None =>
      if ap =? gp
      then (rmf p g, rmf p a, b)
      else gab
  | Some gp, None, Some bp =>
      if bp =? gp
      then (rmf p g, a, rmf p b)
      else gab
  | None, None, Some bp =>
      (override p bp g, override p bp a, b)
  | None, Some ap, None =>
      (override p ap g, a, override p ap b)
  | _, None, None =>
      (rmf p g, a, b)
  end.

Definition reconset : list path -> node * node * node -> node * node * node :=
  fold_left ssrecon.

Program Fixpoint recon (g a b: node) {measure (size g)} : node * node * node :=
  if a =? g
  then (b, b, b)
  else
    if b =? g
    then (a, a, a)
    else
      if a =? b
      then (a, a, a)
      else
        match a, b with
        | Directory da, Directory db =>
          let dg : mapping := if g is Directory dg then dg else [] in
          let fgab :=
              map
                (fun f : string =>
                   match lookup f dg, lookup f da, lookup f db with
                   | Some g, Some a, Some b =>
                     let '(g', a', b') := recon g a b in
                     (add f g', add f a', add f b')
                   | None, Some a, Some b =>
                     if a =? b
                     then (add f a, id, id)
                     else (id, id, id)
                   | Some g, Some a, None =>
                     if a =? g
                     then (remove f, remove f, id)
                     else (id, id, id)
                   | Some g, None, Some b =>
                     if b =? g
                     then (remove f, id, remove f)
                     else (id, id, id)
                   | None, None, Some b =>
                     (add f b, add f b, id)
                   | None, Some a, None =>
                     (add f a, id, add f a)
                   | _, None, None =>
                     (remove f, id, id)
                   end) (map fst $ dg ++ da ++ db) in
          let '(dg', da', db') :=
              @fold_left (_ * _ * _) (_ * _ * _)
                         (fun '(dg, da, db) '(fg, fa, fb) =>
                           (fg dg, fa da, fb db)) fgab (dg, da, db) in
          (Directory dg', Directory da', Directory db')
        | _, _ => (g, a, b)
        end.
Next Obligation.
  destruct g0; try discriminate.
  rewrite alist_find_alt in Heq_anonymous.
  unfold alist_find' in Heq_anonymous.
  unfold compose in Heq_anonymous.
  destruct (find (fun x : string * node => RelDec.rel_dec f (fst x)) a0) eqn:Hfind;
    try discriminate.
  destruct p.
  inversion Heq_anonymous; subst.
  apply find_some in Hfind.
  intuition.
  eapply size_subdir; eauto.
Defined.

Lemma recon_alt (g a b: node) :
  recon g a b = reconset (allPaths g a b) (g, a, b).
Abort.

Definition conflict (g a b: node) (p: path) : bool :=
  let '(_, a', b') := recon g a b in
  match cd p a', cd p b' with
  | Some ap, Some bp => negb $ ap =? bp
  | None, None => false
  | _, _ => true
  end.