(** This files extends the implementation of finite over [positive] to finite
maps whose keys range over Coq's data type of binary naturals [N]. *)
From stdpp Require Import pmap mapset.
From stdpp Require Export prelude fin_maps.
From stdpp Require Import options.

Local Open Scope N_scope.

Record Nmap (A : Type) : Type := NMap { Nmap_0 : option A; Nmap_pos : Pmap A }.
Global Arguments Nmap_0 {_} _ : assert.
Global Arguments Nmap_pos {_} _ : assert.
Global Arguments NMap {_} _ _ : assert.

Global Instance Nmap_eq_dec `{EqDecision A} : EqDecision (Nmap A).
Proof.
 refine (λ t1 t2,
  match t1, t2 with
  | NMap x t1, NMap y t2 => cast_if_and (decide (x = y)) (decide (t1 = t2))
  end); abstract congruence.
Defined.
Global Instance Nempty {A} : Empty (Nmap A) := NMap None ∅.
Global Opaque Nempty.
Global Instance Nlookup {A} : Lookup N A (Nmap A) := λ i t,
  match i with
  | N0 => Nmap_0 t
  | Npos p => Nmap_pos t !! p
  end.
Global Instance Npartial_alter {A} : PartialAlter N A (Nmap A) := λ f i t,
  match i, t with
  | N0, NMap o t => NMap (f o) t
  | Npos p, NMap o t => NMap o (partial_alter f p t)
  end.
Global Instance Nto_list {A} : FinMapToList N A (Nmap A) := λ t,
  match t with
  | NMap o t =>
     from_option (λ x, [(0,x)]) [] o ++ (prod_map Npos id <$> map_to_list t)
  end.
Global Instance Nomap: OMap Nmap := λ A B f t,
  match t with NMap o t => NMap (o ≫= f) (omap f t) end.
Global Instance Nmerge: Merge Nmap := λ A B C f t1 t2,
  match t1, t2 with
  | NMap o1 t1, NMap o2 t2 => NMap (diag_None f o1 o2) (merge f t1 t2)
  end.
Global Instance Nfmap: FMap Nmap := λ A B f t,
  match t with NMap o t => NMap (f <$> o) (f <$> t) end.

Global Instance: FinMap N Nmap.
Proof.
  split.
  - intros ? [??] [??] H. f_equal; [apply (H 0)|].
    apply map_eq. intros i. apply (H (Npos i)).
  - by intros ? [|?].
  - intros ? f [? t] [|i]; simpl; [done |]. apply lookup_partial_alter.
  - intros ? f [? t] [|i] [|j]; simpl; try intuition congruence.
    intros. apply lookup_partial_alter_ne. congruence.
  - intros ??? [??] []; simpl; [done|]. apply lookup_fmap.
  - intros ? [[x|] t]; unfold map_to_list; simpl.
    + constructor.
      * rewrite elem_of_list_fmap. by intros [[??] [??]].
      * by apply (NoDup_fmap _), NoDup_map_to_list.
    + apply (NoDup_fmap _), NoDup_map_to_list.
  - intros ? t i x. unfold map_to_list. split.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        intros [? | [[??] [??]]]; simplify_eq/=; [done |].
        by apply elem_of_map_to_list.
      * rewrite elem_of_list_fmap; intros [[??] [??]]; simplify_eq/=.
        by apply elem_of_map_to_list.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        destruct i as [|i]; simpl; [intuition congruence |].
        intros. right. exists (i, x). by rewrite elem_of_map_to_list.
      * rewrite elem_of_list_fmap.
        destruct i as [|i]; simpl; [done |].
        intros. exists (i, x). by rewrite elem_of_map_to_list.
  - intros ?? f [??] [|?]; simpl; [done|]; apply (lookup_omap f).
  - intros ??? f [??] [??] [|?]; simpl; [done|]; apply (lookup_merge f).
Qed.

(** * Finite sets *)
(** We construct sets of [N]s satisfying extensional equality. *)
Notation Nset := (mapset Nmap).
Global Instance Nmap_dom {A} : Dom (Nmap A) Nset := mapset_dom.
Global Instance: FinMapDom N Nmap Nset := mapset_dom_spec.


Require Import List.
Require Export Util Get Drop Var Val Isa.Ops IL.Exp
        Envs Map CSet AutoIndTac MoreList OptionMap.
Require Export IL.Events SizeInduction SmallStepRelations StateType.
Require Import SetOperations.

Set Implicit Arguments.

(** * Intermediate Language IL *)

(** ** Syntax *)

(** [args] is the type of the list of variables passed at a goto ... *)
Notation "'args'" := (list op) (at level 0).
(** ... while [params] is the type of the list of formal parameters *)
Notation "'params'" := (list var) (at level 0).

Inductive stmt : Type :=
| stmtLet    (x : var) (e: exp) (s : stmt) : stmt
| stmtIf     (e : op) (s : stmt) (t : stmt) : stmt
| stmtApp    (l : lab) (Y:args) : stmt
| stmtReturn (e : op) : stmt
(* block f Z : rt = s in b *)
| stmtFun    (F:list (params * stmt)) (t : stmt) : stmt.

Instance Stmt_size : Size stmt. gen_Size. Defined.

Lemma stmt_ind'
  : forall P : stmt -> Prop,
       (forall (x : var) (e : exp) (s : stmt), P s -> P (stmtLet x e s)) ->
       (forall (e : op) (s : stmt), P s -> forall t : stmt, P t -> P (stmtIf e s t)) ->
       (forall (l : lab) (Y : args), P (stmtApp l Y)) ->
       (forall e : op, P (stmtReturn e)) ->
       (forall (F : 〔params * stmt〕) (t : stmt),
           P t -> (forall n Zs, get F n Zs -> P (snd Zs)) -> P (stmtFun F t)) -> forall s : stmt, P s.
Proof.
  intros. sind s; destruct s; eauto.
Qed.

(** *** Free, Defined and Occuring Variables *)

Fixpoint freeVars (s:stmt) : set var :=
  match s with
    | stmtLet x e s0 => (freeVars s0 \ singleton x) ∪ Exp.freeVars e
    | stmtIf e s1 s2 => freeVars s1 ∪ freeVars s2 ∪ Ops.freeVars e
    | stmtApp l Y => list_union (List.map Ops.freeVars Y)
    | stmtReturn e => Ops.freeVars e
    | stmtFun s t =>
      list_union (List.map (fun f => (freeVars (snd f) \ of_list (fst f))) s) ∪ freeVars t
  end.

Definition defVarsZs (definedVars:stmt -> set var) (Zs:params*stmt) :=
  of_list (fst Zs) ∪ definedVars (snd Zs).

Definition definedVarsF (definedVars:stmt -> set var)
           (F:list (params*stmt)) :=
  list_union (List.map (defVarsZs definedVars) F).

Fixpoint definedVars (s:stmt) : set var :=
  match s with
    | stmtLet x e s0 => {x; definedVars s0}
    | stmtIf e s1 s2 => definedVars s1 ∪ definedVars s2
    | stmtApp l Y => ∅
    | stmtReturn e => ∅
    | stmtFun F t => (definedVarsF definedVars F) ∪ definedVars t
  end.

Fixpoint occurVars (s:stmt) : set var :=
  match s with
    | stmtLet x e s0 => {x; occurVars s0} ∪ Exp.freeVars e
    | stmtIf e s1 s2 => occurVars s1 ∪ occurVars s2 ∪ Ops.freeVars e
    | stmtApp l Y => list_union (List.map Ops.freeVars Y)
    | stmtReturn e => Ops.freeVars e
    | stmtFun s t =>
      list_union (List.map (fun f => (occurVars (snd f) ∪ of_list (fst f))) s) ∪ occurVars t
  end.

Lemma freeVars_occurVars s
: freeVars s ⊆ occurVars s.
Proof.
  sind s; destruct s; simpl in * |- *; repeat rewrite IH; eauto.
  - cset_tac.
  - rewrite list_union_f_incl. reflexivity.
    intros. destruct y; simpl.
    rewrite IH; cset_tac; intuition; eauto.
Qed.

Lemma occurVars_freeVars_definedVars s
: occurVars s [=] freeVars s ∪ definedVars s.
Proof.
  sind s; destruct s; simpl in * |- *; eauto with cset.
  - rewrite IH; eauto.
    clear_all; cset_tac.
  - repeat rewrite IH; eauto.
    clear_all; cset_tac.
  - cset_tac.
  - cset_tac.
  - rewrite IH; eauto. unfold definedVarsF, defVarsZs.
    repeat setoid_rewrite union_assoc at 1.
    setoid_rewrite union_comm at 5.
    repeat setoid_rewrite <- union_assoc.
    erewrite list_union_f_union.
    rewrite list_union_f_eq. cset_tac.
    simpl. intros. rewrite IH; eauto.
    clear; cset_tac.
Qed.

Lemma definedVars_occurVars s
: definedVars s ⊆ occurVars s.
Proof.
  sind s; destruct s; simpl in * |- *; eauto with cset.
  - unfold definedVarsF, defVarsZs.
    rewrite IH, list_union_f_incl; eauto.
    + reflexivity.
    + intros. destruct y; simpl. rewrite IH; cset_tac.
Qed.

Fixpoint externals (s:stmt) : set var :=
  match s with
  | stmtLet x e s0 => Exp.externals e ∪ externals s0
  | stmtIf e s1 s2 => externals s1 ∪ externals s2
  | stmtApp l Y => {}
  | stmtReturn e => {}
  | stmtFun F t => list_union ((fun Zs => externals (snd Zs)) ⊝ F) ∪ externals t
  end.

Definition defVars' ( Zs:params*stmt) := of_list (fst Zs) ∪ definedVars (snd Zs).

Lemma list_union_definedVars F
  : definedVarsF definedVars F
                 [=] list_union (of_list ⊝ fst ⊝ F) ∪ list_union (definedVars ⊝ snd ⊝ F).
Proof.
  unfold definedVarsF, defVarsZs.
  general induction F; simpl; eauto with cset.
  norm_lunion. rewrite IHF; clear IHF. cset_tac.
Qed.

Lemma list_union_definedVars' F
  : list_union (defVars' ⊝ F)
               [=] list_union (of_list ⊝ fst ⊝ F) ∪ list_union (definedVars ⊝ snd ⊝ F).
Proof.
  general induction F; simpl; eauto with cset.
  norm_lunion. rewrite IHF; clear IHF. unfold defVars' at 1.
  cset_tac.
Qed.

Lemma list_union_definedVarsF_decomp F
  : list_union (defVarsZs definedVars ⊝ F)
               [=] list_union (of_list ⊝ fst ⊝ F) ∪ list_union (definedVars ⊝ snd ⊝ F).
Proof.
  general induction F; simpl.
  - cset_tac.
  - norm_lunion. rewrite IHF.
    unfold defVarsZs at 1. clear.
    cset_tac.
Qed.

(** ** Semantics *)

(** *** Functional Semantics *)
Module F.

  Inductive block : Type :=
    blockI {
      block_E : onv val;
      block_Z : params;
      block_s : stmt;
      block_n : nat
    }.

  Definition labenv := list block.
  Definition state : Type := (labenv * onv val * stmt)%type.

  Definition mkBlock E n f :=
    blockI E (fst f) (snd f) n.

  Inductive step : state -> event -> state -> Prop :=
  | StepLet L E x e b v
    (def:op_eval E e = Some v)
    : step (L, E, stmtLet x (Operation e) b) EvtTau (L, E[x<-Some v], b)

  | StepExtern L E x f Y s vl v
    (def:omap (op_eval E) Y = Some vl)
    : step  (L, E, stmtLet x (Call f Y) s)
            (EvtExtern (ExternI f vl v))
            (L, E[x <- Some v], s)

  | StepIfT L E
    e (b1 b2 : stmt) v
    (def:op_eval E e = Some v)
    (condTrue: val2bool v = true)
    : step (L, E, stmtIf e b1 b2) EvtTau (L, E, b1)

  | StepIfF L E
    e (b1 b2:stmt) v
    (def:op_eval E e = Some v)
    (condFalse: val2bool v = false)
    : step (L, E, stmtIf e b1 b2) EvtTau (L, E, b2)

  | StepGoto L E (l:lab) Y blk vl
    (Ldef:get L l blk)
    (len:length (block_Z blk) = length Y)
    (def:omap (op_eval E) Y = Some vl) E'
    (updOk:(block_E blk) [block_Z blk <-- List.map Some vl] = E')
    : step  (L, E, stmtApp l Y)
            EvtTau
            (drop (l - block_n blk) L, E', block_s blk)

  | StepFun L E
    F (t:stmt)
    : step (L, E, stmtFun F t) EvtTau ((mapi (mkBlock E) F ++ L)%list, E, t).

  Lemma step_internally_deterministic
  : internally_deterministic step.
  Proof.
    hnf; intros.
    inv H; inv H0; split; eauto; try get_functional; try congruence.
  Qed.

  Lemma step_externally_determined
  : externally_determined step.
  Proof.
    hnf; intros.
    inv H; inv H0; eauto; try get_functional; try congruence.
  Qed.

  Lemma step_dec
  : reddec2 step.
  Proof.
    hnf; intros. destruct x as [[L V] []].
    - destruct e.
      + case_eq (op_eval V e); intros. left. do 2 eexists. eauto 20 using step.
        right. stuck.
      + case_eq (omap (op_eval V) Y); intros; try now (right; stuck).
        left; eexists (EvtExtern (ExternI f l (default_val))). eexists; eauto using step.
    - case_eq (op_eval V e); intros.
      left. case_eq (val2bool v); intros; do 2 eexists; eauto using step.
      right. stuck.
    - destruct (get_dec L l) as [[blk A]|?]; [ | right; stuck2 ].
      decide (length (block_Z blk) = length Y); [ | right; stuck2 ].
      case_eq (omap (op_eval V) Y); intros; [ | right; stuck2 ].
      left. do 2 eexists. econstructor; eauto.
    - right; stuck.
    - left. eexists. eauto using step.
  Qed.

  Lemma StepGoto_mapi L blk Y E E'' vl (f:lab) F k
        (Ldef:get L (f - ❬F❭) blk)
        (len:length (F.block_Z blk) = length Y)
        (def:omap (op_eval E) Y = Some vl) E'
        (updOk:F.block_E blk [F.block_Z blk <-- List.map Some vl] = E')
        (ST:f - block_n blk >= ❬mapi (F.mkBlock E'') F❭) (GE: f >= ❬F❭) (EQ:k = f - ❬F❭ - block_n blk)
    : F.step (mapi (F.mkBlock E'') F ++ L, E, stmtApp f Y) EvtTau
             (drop k L,
              E', F.block_s blk).
  Proof.
    subst.
    rewrite <- (mapi_length (F.mkBlock E'')).
    orewrite (f - ❬mapi (F.mkBlock E'') F❭ - block_n blk
              =  (f - block_n blk) - ❬mapi (F.mkBlock E'') F❭).
    rewrite <- (drop_app_gen _ (mapi (F.mkBlock E'') F)); eauto.
    eapply F.StepGoto; eauto.
    rewrite get_app_ge. rewrite mapi_length. eauto. omega.
  Qed.

End F.

(** *** Imperative Semantics *)

Module I.
  Inductive block : Type :=
    blockI {
      block_Z : params;
      block_s : stmt;
      block_n : nat
    }.

  Definition labenv := list block.
  Definition state : Type := (labenv * onv val * stmt)%type.
  Definition mkBlock n f := blockI (fst f) (snd f) n.

  Inductive step : state -> event -> state -> Prop :=
  | StepLet L E x e b v
    (def:op_eval E e = Some v)
    : step (L, E, stmtLet x (Operation e) b) EvtTau (L, E[x<-Some v], b)

  | StepExtern L E x f Y s vl v
               (def:omap (op_eval E) Y = Some vl)
    : step  (L, E, stmtLet x (Call f Y) s)
            (EvtExtern (ExternI f vl v))
            (L, E[x <- Some v], s)

  | StepIfT L E
    e (b1 b2 : stmt) v
    (def:op_eval E e = Some v)
    (condTrue: val2bool v = true)
    : step (L, E, stmtIf e b1 b2) EvtTau (L, E, b1)

  | StepIfF L E
    e (b1 b2:stmt) v
    (def:op_eval E e = Some v)
    (condFalse: val2bool v = false)
    : step (L, E, stmtIf e b1 b2) EvtTau (L, E, b2)

  | StepGoto L E (l:lab) Y blk vl
    (Ldef:get L l blk)
    (len:length (block_Z blk) = length Y)
    (def:omap (op_eval E) Y = Some vl) E'
    (updOk:E[block_Z blk  <-- List.map Some vl] = E')
    : step  (L, E, stmtApp l Y)
            EvtTau
            (drop (l - block_n blk) L, E', block_s blk)

  | StepFun L E
    s (t:stmt)
    : step (L, E, stmtFun s t) EvtTau ((mapi mkBlock s ++ L)%list, E, t).

  Lemma step_internally_deterministic
  : internally_deterministic step.
  Proof.
    hnf; intros.
    inv H; inv H0; split; eauto; try get_functional; try congruence.
  Qed.

  Lemma step_externally_determined
  : externally_determined step.
  Proof.
    hnf; intros.
    inv H; inv H0; eauto; try get_functional; try congruence.
  Qed.

  Lemma step_dec
  : reddec2 step.
  Proof.
    hnf; intros. destruct x as [[L V] []].
    - destruct e.
      + case_eq (op_eval V e); intros. left. do 2 eexists. eauto 20 using step.
        right. stuck.
      + case_eq (omap (op_eval V) Y); intros; try now (right; stuck).
        left; eexists (EvtExtern (ExternI f l default_val)). eexists; eauto using step.
    - case_eq (op_eval V e); intros.
      left. case_eq (val2bool v); intros; do 2 eexists; eauto using step.
      right. stuck.
    - destruct (get_dec L l) as [[blk A]|?]; [| right; stuck2].
      decide (length (block_Z blk) = length Y); [| right; stuck2].
      case_eq (omap (op_eval V) Y); intros; [| right; stuck2].
      left. do 2 eexists. econstructor; eauto.
    - right. stuck2.
    - left. eexists. eauto using step.
  Qed.

  Lemma StepGoto_mapi L blk Y E vl (f:lab) F k
        (Ldef:get L (f - ❬F❭) blk)
        (len:length (I.block_Z blk) = length Y)
        (def:omap (op_eval E) Y = Some vl) E'
        (updOk:E [I.block_Z blk <-- List.map Some vl] = E')
        (ST:f - block_n blk >= ❬mapi I.mkBlock F❭)
        (GE:f >= ❬F❭) (EQ:k = f - ❬F❭ - block_n blk)
    : I.step (mapi I.mkBlock F ++ L, E, stmtApp f Y) EvtTau
             (drop k L,
              E', I.block_s blk).
  Proof.
    subst.
    rewrite <- (mapi_length I.mkBlock).
    orewrite (f - ❬mapi I.mkBlock F❭ - block_n blk
              =  (f - block_n blk) - ❬mapi I.mkBlock F❭).
    rewrite <- (drop_app_gen _ (mapi I.mkBlock F)); eauto.
    eapply I.StepGoto; eauto.
    rewrite get_app_ge. rewrite mapi_length. eauto. omega.
  Qed.

End I.

Definition state_result X (s:X*onv val*stmt) : option val :=
  match s with
    | (_, E, stmtReturn e) => op_eval E e
    | _ => None
  end.

Instance statetype_F : StateType F.state := {
  step := F.step;
  result := (@state_result F.labenv);
  step_dec := F.step_dec;
  step_internally_deterministic := F.step_internally_deterministic;
  step_externally_determined := F.step_externally_determined
}.

Instance statetype_I : StateType I.state := {
  step := I.step;
  result := (@state_result I.labenv);
  step_dec := I.step_dec;
  step_internally_deterministic := I.step_internally_deterministic;
  step_externally_determined := I.step_externally_determined
}.

Ltac single_step_IL :=
  match goal with
  | [ H : agree_on _ ?E ?E', I : val2bool (?E ?x) = true |- step (_, ?E', stmtIf ?x _ _) _ ] =>
    econstructor; eauto; rewrite <- H; eauto; cset_tac; intuition
  | [ H : agree_on _ ?E ?E', I : val2bool (?E ?x) = false |- step (_, ?E', stmtIf ?x _ _) _ ] =>
    econstructor 3; eauto; rewrite <- H; eauto; cset_tac; intuition
  | [ H : val2bool _ = false |- @StateType.step _ statetype_I _ _ _ ] =>
    econstructor 4; try eassumption; try reflexivity
  | [ H : val2bool _ = false |- @StateType.step _ statetype_F _ _ _ ] =>
    econstructor 4; try eassumption; try reflexivity
  | [ H : val2bool _ = true |- @StateType.step _ statetype_I _ _ _ ] =>
    econstructor 3; try eassumption; try reflexivity
  | [ H : val2bool _ = true |- @StateType.step _ statetype_F _ _ _ ] =>
    econstructor 3; try eassumption; try reflexivity
  | [ H : step (?L, _ , stmtApp ?l _) _, H': get ?L (labN ?l) _ |- _] =>
    econstructor; try eapply H'; eauto
(*  | [ H': get ?L ?n _ |- @StateType.step _ _ (?L, _ , stmtApp (LabI ?n) _) _ _] =>
    econstructor; [ eapply H'
                  | simpl; eauto with len
                  | try eassumption
                  | reflexivity]*)
  | [ H': get ?F (labN ?l) _ |- @StateType.step _ _ (mapi _ ?F ++ _, _, stmtApp ?l _) _ _] =>
    econstructor; [ try solve [simpl; eauto using get_app, get_mapi]
                  | simpl; eauto with len
                  | try eassumption; eauto; try reflexivity
                  | reflexivity]
  | [ |- @StateType.step _ _ (?L, _ , stmtApp _ _) _ _] =>
    econstructor; [ try eassumption; try solve [simpl; eauto using get]
                  | simpl; eauto with len
                  | try eassumption; eauto; try reflexivity
                  | reflexivity]
  | [ |- @StateType.step _ _ (_, ?E, stmtLet _ (Operation ?e) _) _ _] =>
    econstructor; eauto
  | [ |- @StateType.step _ _ (_, ?E, stmtFun _ _) _ _] =>
    econstructor; eauto
  end.

Smpl Add single_step_IL : single_step.

Lemma ZL_mapi F L
  : I.block_Z ⊝ (mapi I.mkBlock F ++ L) = fst ⊝ F ++ I.block_Z ⊝ L.
Proof.
  rewrite List.map_app. rewrite map_mapi. unfold mapi.
  erewrite <- mapi_map_ext; [ reflexivity | simpl; reflexivity].
Qed.

Hint Extern 1 =>
match goal with
| [ |- context [ I.block_Z ⊝ (mapi I.mkBlock ?F ++ ?L) ] ] =>
  rewrite (ZL_mapi F L)
| [ |- context [ pair ⊜ (?A ++ ?B) (?C ++ ?D) ] ] =>
  rewrite (zip_app pair A C B D);
    [| eauto with len]
end.

Inductive noFun : stmt->Prop :=
| NoFunLet x e s :
   noFun s
   -> noFun (stmtLet x e s)
| NoFunIf e s t :
   noFun s
   -> noFun t
   -> noFun (stmtIf e s t)
| NoFunCall l Y :
   noFun (stmtApp l Y)
| NoFunExp e :
   noFun (stmtReturn e).

Inductive noCall : stmt->Prop :=
| NoCallLet x e s :
   noCall s
   -> noCall (stmtLet x (Operation e) s)
| NoCallIf e s t :
   noCall s
   -> noCall t
   -> noCall (stmtIf e s t)
| NoCallApp l Y :
   noCall (stmtApp l Y)
| NoCallExp e :
    noCall (stmtReturn e)
| NoAppCall F t
  : (forall n Zs, get F n Zs -> noCall (snd Zs))
    -> noCall t
    -> noCall (stmtFun F t).

Inductive notApp : stmt -> Prop :=
| NotAppLet x e s : notApp (stmtLet x e s)
| NotAppIf e s t : notApp (stmtIf e s t)
| NotAppReturn e : notApp (stmtReturn e)
| NotAppFun F t : notApp (stmtFun F t).


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Export CertiGraph.graph.FiniteGraph.
Require Export CertiGraph.graph.MathGraph.
Require Export CertiGraph.graph.LstGraph.
Require Export CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.UnionFindGraph.

Local Open Scope logic.

Class pPointwiseGraph_GList: Type :=
  {
    addr: Type;
    null: addr;
    SGBA: PointwiseGraphBasicAssum addr (addr * unit)
  }.

#[export] Existing Instance SGBA.

Definition is_null_SGBA {pSGG: pPointwiseGraph_GList} : DecidablePred addr := (existT (fun P => forall a, {P a} + {~ P a}) (fun x => x = null) (fun x => SGBA_VE x null)).

Class sPointwiseGraph_GList {pSGG_Bi: pPointwiseGraph_GList} (DV DE: Type): Type :=
  {
    pred: Type;
    SGP: PointwiseGraphPred addr (addr * unit) (DV * addr) unit pred;
    SGA: PointwiseGraphAssum SGP;
    SGAvs: PointwiseGraphAssum_vs SGP;
    SGAvn: PointwiseGraphAssum_vn SGP null
  }.

#[export] Existing Instances SGP SGA SGAvs.

Section GRAPH_GList.

  Context {pSGG: pPointwiseGraph_GList}.
  Context {DV DE DG: Type}.

  #[global] Instance SGC_GList: PointwiseGraphConstructor addr (addr * unit) DV DE DG (DV * addr) unit.
  Proof.
    refine (Build_PointwiseGraphConstructor _ _ _ _ _ _ _ SGBA _ _).
    + exact (@vgamma addr (addr * unit) SGBA_VE SGBA_EE is_null_SGBA (fun x => (x, tt)) DV DE DG).
    + exact (fun _ _ => tt).
  Defined.

  #[global] Instance L_SGC_GList: Local_PointwiseGraphConstructor addr (addr * unit) DV DE DG (DV * addr) unit.
  Proof.
    refine (Build_Local_PointwiseGraphConstructor
              _ _ _ _ _ _ _ SGBA SGC_GList
              (fun G v => evalid (pg_lg G) (v, tt) /\ src (pg_lg G) (v, tt) = v) _
              (fun _ _ => True) _).
    - intros. simpl. unfold vgamma.  simpl. destruct H as [? ?], H0 as [? ?]. f_equal; auto. pose proof (H3 _ H H5 H0 H6). rewrite <- !H7. clear H7.
      destruct (SGBA_VE (dst (pg_lg G1) (x, tt)) null); auto.
    - intros; simpl. auto.
  Defined.

  Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Notation UFGraph := (@UFGraph addr (addr * unit) _ _ is_null_SGBA (fun x => (x, tt)) DV DE DG).
  Notation LGraph := (@LGraph addr (addr * unit) _ _ DV DE DG).

  #[global] Instance RGF (G: UFGraph): ReachableFiniteGraph G.
  Proof.
    apply Build_ReachableFiniteGraph.
    intros.
    apply finite_reachable_computable with (is_null := is_null_SGBA) in H.
    - destruct H as [l [? ?]]. exists l; auto.
    - apply maGraph.
    - apply (LocalFiniteGraph_FiniteGraph G), finGraph.
    - apply (FiniteGraph_EnumCovered G), finGraph.
  Defined.

  Definition make_set_pregraph (v: addr) (g: PreGraph addr (addr * unit)) := pregraph_add_edge (pregraph_add_vertex g v) (v, tt) v null.

  Lemma is_partial_make_set_pregraph: forall x (g: UFGraph), ~ vvalid g x -> is_partial_graph g (make_set_pregraph x g).
  Proof.
    intros. hnf. simpl. unfold addValidFunc, updateEdgeFunc. split; [|split; [|split]]; intros; [left; auto..| |].
    - destruct (equiv_dec (x, tt) e); auto. hnf in e0. subst e. pose proof (@only_one_edge _ _ _ _ g _ (liGraph g) (src g (x, tt)) (x, tt) H1). simpl in H2.
      assert (src g (x, tt) = src g (x, tt) /\ evalid g (x, tt)) by (split; auto). rewrite H2 in H3. inversion H3. exfalso. rewrite H5 in H. intuition.
    - destruct (equiv_dec (x, tt) e); auto. hnf in e0. subst e. destruct (@valid_graph _ _ _ _ g _ (maGraph g) _ H0) as [? _].
      pose proof (@only_one_edge _ _ _ _ g _ (liGraph g) (src g (x, tt)) (x, tt) H2). assert (src g (x, tt) = src g (x, tt) /\ evalid g (x, tt)) by (split; auto).
      rewrite H3 in H4. inversion H4. exfalso. rewrite H6 in H. intuition.
  Qed.

  Definition make_set_LabeledGraph (v: addr) (g: LabeledGraph addr (addr * unit) DV DE DG) (default_dv: DV) (default_de: DE) (default_dg: DG) : LGraph :=
    Build_LabeledGraph _ _ _ (make_set_pregraph v g) (fun x => if SGBA_VE x v then default_dv else vlabel g x) (fun e => default_de) default_dg.

  Definition make_set_MathGraph (v: addr) (g: PreGraph addr (addr * unit)) (H: v <> null) (Hm: MathGraph g is_null_SGBA): MathGraph (make_set_pregraph v g) is_null_SGBA.
  Proof.
    apply (Build_MathGraph _ is_null_SGBA).
    - intros. simpl. unfold updateEdgeFunc, addValidFunc. destruct (equiv_dec (v, tt) e). 1: intuition. simpl in H0. unfold addValidFunc in H0. destruct H0.
      + destruct Hm. apply valid_graph in H0. destruct H0. split. 1: left; auto. hnf in H1. simpl in H1. destruct H1; [left | right; left]; auto.
      + compute in c. exfalso; intuition.
    - intros. hnf in H0. simpl in H1. destruct H0.
      + subst x. destruct Hm. apply valid_not_null in H0; auto. simpl. auto.
      + subst v. auto.
  Defined.

  Definition make_set_FiniteGraph (v: addr) (g: PreGraph addr (addr * unit)) (Hf: FiniteGraph g): FiniteGraph (make_set_pregraph v g).
  Proof.
    destruct Hf. unfold EnumEnsembles.Enumerable in *. destruct finiteV as [vl [? ?]]. destruct finiteE as [el [? ?]]. constructor; hnf; simpl; unfold addValidFunc.
    - destruct (in_dec SGBA_VE v vl).
      + exists vl. split; auto. intros. unfold In in H0 |-* . rewrite H0. intuition. subst v. rewrite H0 in i. auto.
      + exists (v :: vl). split; [constructor; auto|]. intros. simpl. unfold In in H0 |-* . rewrite H0. intuition.
    - unfold In in H2 |-* . destruct (in_dec SGBA_EE (v, tt) el).
      + exists el. split; auto. intros. rewrite H2. intuition. inversion H4. rewrite H2 in i. auto.
      + exists ((v, tt) :: el). split; [constructor; auto|]. intros. simpl. rewrite H2. intuition.
  Defined.

  Lemma make_set_valid_path_pfoot: forall (v: addr) (g: PreGraph addr (addr * unit)) x p (Hn: v <> null) (Hi: ~ vvalid g v) (Hm: MathGraph g is_null_SGBA),
      x <> v -> pfoot (make_set_pregraph v g) p = x -> valid_path (make_set_pregraph v g) p -> pfoot g p = x /\ valid_path g p.
  Proof.
    intros. destruct p as [p l]. assert (forall e, List.In e l -> e <> (v, tt)). {
      intros. apply (valid_path_strong_evalid _ _ _ e) in H1; auto. hnf in H1. simpl in H1. unfold addValidFunc, updateEdgeFunc in H1.
      destruct H1 as [? [? ?]]. intro. destruct (equiv_dec (v, tt) e). 2: compute in c; auto. destruct H4; auto. destruct Hm. apply valid_not_null in H4; simpl; auto.
    } split.
    - clear H1. revert p H0. induction l; intros. 1: simpl in H0 |-* ; auto.
      assert (forall e : addr * unit, List.In e l -> e <> (v, tt)) by (intros; apply H2; right; auto). specialize (IHl H1). clear H1.
      rewrite pfoot_cons in H0 |-* . simpl dst in H0. unfold updateEdgeFunc in H0. destruct (equiv_dec (v, tt) a).
      + hnf in e. assert (a <> (v, tt)) by (apply H2; left; auto). exfalso; auto.
      + apply IHl; auto.
    - assert (p <> v). {
        intro. subst p. destruct l. 1: simpl in H0; auto. simpl in H1. destruct H1. assert (strong_evalid (make_set_pregraph v g) p) by (destruct l; [|destruct H3]; auto).
        clear H3. hnf in H4. simpl in H4. unfold addValidFunc, updateEdgeFunc in H1, H4. destruct H4 as [? _]. assert (p <> (v, tt)) by (apply H2; left; auto).
        destruct (equiv_dec (v, tt) p). 1: hnf in e; auto. destruct H3; auto. destruct Hm. apply valid_graph in H3. destruct H3 as [? _]. rewrite <- H1 in H3. auto.
      } clear H0. revert p H1 H3. induction l; intros.
      + simpl in H1. unfold addValidFunc in H1. simpl. destruct H1; [|exfalso]; auto.
      + assert (forall e : addr * unit, List.In e l -> e <> (v, tt)) by (intros; apply H2; right; auto). specialize (IHl H0). clear H0.
        assert (a <> (v, tt)) by (apply H2; left; auto). rewrite valid_path_cons_iff in H1 |-* . destruct H1 as [? [? ?]]. split; [|split].
        * simpl in H1. unfold updateEdgeFunc in H1. destruct (equiv_dec (v, tt) a); [exfalso|]; auto.
        * hnf in H4. simpl in H4. unfold addValidFunc, updateEdgeFunc in H4. destruct H4 as [? [? ?]].
          destruct (equiv_dec (v, tt) a); [hnf in e; exfalso|]; auto. destruct H4; [|exfalso]; auto. clear c.
          destruct H6. 2: destruct Hm; apply valid_graph in H4; destruct H4; rewrite H6 in H4; exfalso; auto.
          destruct H7. 2: destruct Hm; apply valid_graph in H4; destruct H4; hnf in H8; simpl in H8; rewrite H7 in H8; exfalso; destruct H8; auto. hnf. split; auto.
        * simpl dst in H5. unfold updateEdgeFunc in H5. destruct (equiv_dec (v, tt) a); [hnf in e; exfalso|]; auto. apply IHl; auto.
          destruct H4 as [? _]. simpl in H4. unfold addValidFunc in H4. destruct H4; [|exfalso]; auto. destruct Hm. apply valid_graph in H4. destruct H4 as [_ ?].
          hnf in H4. simpl in H4. intro. rewrite H6 in H4. destruct H4; auto.
  Qed.

  Definition make_set_LstGraph (v: addr) (g: PreGraph addr (addr * unit)) (Hn: v <> null) (Hi: ~ vvalid g v) (Hm: MathGraph g is_null_SGBA)
             (Hl: LstGraph g (fun x => (x, tt))): LstGraph (make_set_pregraph v g) (fun x => (x, tt)).
  Proof.
    constructor; simpl.
    - unfold addValidFunc, updateEdgeFunc. intros. destruct H.
      + destruct Hl. specialize (only_one_edge x e H). destruct (equiv_dec (v, tt) e).
        * hnf in e0. subst e. rewrite <- only_one_edge. split; intros.
          -- destruct H0. subst v. rewrite only_one_edge. auto.
          -- rewrite only_one_edge in H0. inversion H0. subst v. split; auto.
        * compute in c. rewrite <- only_one_edge. split; intros.
          -- destruct H0. split; auto. destruct H1; auto. exfalso; auto.
          -- destruct H0. split; auto.
      + subst v. split; intros.
        * destruct H. destruct H0; auto. destruct (equiv_dec (x, tt) e).
          -- hnf in e0; auto.
          -- destruct Hm. specialize (valid_graph _ H0). destruct valid_graph. rewrite H in H1. exfalso; auto.
        * destruct (equiv_dec (x, tt) e).
          -- hnf in e0. split; auto.
          -- compute in c. exfalso; auto.
    - intros. destruct_eq_dec x v.
      + subst x. destruct p as [p l]. destruct H as [[? ?] [? _]]. simpl in H. subst p. simpl in H1. destruct l; auto. unfold updateEdgeFunc in H1. destruct H1.
        assert (strong_evalid (make_set_pregraph v g) p) by (simpl in H1; destruct l; [|destruct H1]; auto). hnf in H2. simpl in H2. unfold addValidFunc, updateEdgeFunc in H2.
        destruct H2 as [? [? ?]]. destruct (equiv_dec (v, tt) p).
        * exfalso. destruct H4; auto. destruct Hm. apply valid_not_null in H4; simpl; auto.
        * compute in c. exfalso. destruct H2; auto. destruct Hm. apply valid_graph in H2. destruct H2. subst v. auto.
      + destruct Hl. apply no_loop_path. destruct H as [[? ?] [? ?]]. assert (pfoot g p = x /\ valid_path g p) by (apply (make_set_valid_path_pfoot v); auto).
        destruct H4. split; split; auto.
  Defined.

  Definition make_set_sound (v: addr)  (g: PreGraph addr (addr * unit)) (Hn: v <> null) (Hi: ~ vvalid g v) (Hlmf: LiMaFin g) : LiMaFin (make_set_pregraph v g) :=
    Build_LiMaFin _ (make_set_LstGraph v g Hn Hi ma li) (make_set_MathGraph v g Hn ma) (make_set_FiniteGraph v g fin).

  Definition make_set_Graph (default_dv: DV) (default_de: DE) (default_dg: DG) (v: addr) (g: UFGraph) (Hn: v <> null) (Hi: ~ vvalid g v) : UFGraph :=
    Build_GeneralGraph _ _ _ _ (make_set_LabeledGraph v g default_dv default_de default_dg) (make_set_sound v g Hn Hi (sound_gg g)).

  Lemma uf_under_bound_make_set_graph: forall (default_dv: DV) (default_de: DE) (default_dg: DG) (v: addr) (g: UFGraph) (Hn: v <> null) (Hi: ~ vvalid g v) (extract: DV -> nat),
      extract default_dv = O -> uf_under_bound extract g -> uf_under_bound extract (make_set_Graph default_dv default_de default_dg v g Hn Hi).
  Proof.
    intros. hnf in H0 |-* . simpl. intro x; intros. unfold addValidFunc in H1. destruct (SGBA_VE x v).
    - hnf in e. subst v. destruct H1; [exfalso; auto |]. clear H1. hnf. intros. rewrite H. destruct p as [p l]. destruct l; simpl; auto. exfalso.
      apply pfoot_in_cons in H2. destruct H2 as [e [? ?]]. simpl in H3. unfold updateEdgeFunc in H3. pose proof (valid_path_strong_evalid _ _ _ _ H1 H2). hnf in H4.
      simpl in H4. unfold addValidFunc, updateEdgeFunc in H4. destruct H4 as [? [? ?]]. destruct (equiv_dec (x, tt) e). 1: exfalso; auto. compute in c.
      destruct H4; auto. destruct (@valid_graph _ _ _ _ g _ (maGraph g) _ H4) as [_ ?]. rewrite H3 in H7. destruct H7; auto.
    - compute in c. destruct H1; [|exfalso; auto]. hnf. intros. assert (pfoot g p = x /\ valid_path g p) by (apply (make_set_valid_path_pfoot v); auto; exact (maGraph g)).
      destruct H4. unfold uf_bound in H0. apply H0; auto.
  Qed.

  Definition single_uf_pregraph (v: addr) : PreGraph addr (addr * unit) :=
    pregraph_add_edge (single_vertex_pregraph v) (v, tt) v null.

  Lemma reachabel_single_uf: forall x y, x <> null -> reachable (single_uf_pregraph x) x y <-> x = y.
  Proof.
    intros. split; intros.
    - destruct H0 as [[? ?] [[? ?] [? _]]]. simpl in H0. subst a. destruct l.
      + simpl in H1. auto.
      + destruct H2. simpl in H2. assert (strong_evalid (single_uf_pregraph x) p) by (destruct l; intuition). clear H2. exfalso.
        hnf in H3. simpl in H3. unfold updateEdgeFunc in H3. destruct H3 as [? [_ ?]]. unfold addValidFunc in H2. destruct H2; auto. subst p.
        destruct (equiv_dec (x, tt) (x, tt)); [|compute in c]; auto.
    - subst y. apply reachable_refl. simpl. auto.
  Qed.

  Definition single_uf_LabeledGraph (v: addr) (default_dv: DV) (default_de: DE) (default_dg: DG) : LGraph :=
    Build_LabeledGraph _ _ _ (single_uf_pregraph v) (fun v => default_dv) (fun e => default_de) default_dg.

  Definition single_uf_MathGraph (v: addr) (H: v <> null): MathGraph (single_uf_pregraph v) is_null_SGBA.
  Proof.
    apply (Build_MathGraph _ is_null_SGBA).
    - intros. simpl. unfold updateEdgeFunc.
      destruct (equiv_dec (v, tt) e); intuition.
    - intros. hnf in *. subst v. intuition.
  Defined.

  Definition single_uf_FiniteGraph (v: addr): FiniteGraph (single_uf_pregraph v).
  Proof.
    constructor; hnf.
    - exists (v :: nil). split.
      + constructor. intro. inversion H. constructor.
      + intros. simpl. unfold In. intuition.
    - exists ((v, tt) :: nil). split.
      + constructor. intro. inversion H. constructor.
      + intros. simpl. unfold In, addValidFunc. intuition.
  Defined.

  Definition single_uf_LstGraph (v: addr) (H: v <> null): LstGraph (single_uf_pregraph v) (fun x => (x, tt)).
  Proof.
    constructor; simpl; intros; unfold updateEdgeFunc.
    - unfold addValidFunc. subst. destruct (equiv_dec (x, tt) e); intuition.
    - destruct H0 as [[? _] [? _]]. destruct p as [p l]. simpl in *. subst p.
      destruct l; auto. destruct H1. clear H0. simpl in H1. assert (strong_evalid (single_uf_pregraph v) p) by (destruct l; [|destruct H1]; auto). clear H1.
      hnf in H0. simpl in H0. unfold addValidFunc, updateEdgeFunc in H0. destruct H0 as [? [_ ?]]. exfalso. destruct H0; auto. subst p.
      destruct (equiv_dec (v, tt) (v, tt)); auto. compute in c. apply c; auto.
  Defined.

  Definition single_sound (v: addr) (H: v <> null) : LiMaFin (single_uf_pregraph v) :=
    Build_LiMaFin _ (single_uf_LstGraph v H) (single_uf_MathGraph v H) (single_uf_FiniteGraph v).

  Definition single_Graph (v: addr) (H: v <> null) (default_dv: DV) (default_de: DE) (default_dg: DG): UFGraph :=
    Build_GeneralGraph _ _ _ _ (single_uf_LabeledGraph v default_dv default_de default_dg) (single_sound v H).

End GRAPH_GList.


Require Import List.
Require Import Cps.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Data.Map.FMapAList.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Monads.ReaderMonad ExtLib.Data.Monads.OptionMonad.

Set Implicit Arguments.
Set Strict Implicit.

Module Alpha.
  Import CPS.

  Section maps.
    Variable env_v : Type -> Type.
    Context {Mv : DMap var env_v}.

    Section monadic.
      Variable m : Type -> Type.
      Context {Monad_m : Monad m}.
      Context {Reader_m : MonadReader (env_v var) m}.
      Context {Zero_m : MonadZero m}.

      Import MonadNotation.
      Local Open Scope monad_scope.
      Local Open Scope list_scope.

      Definition alpha_op (o1 o2 : op) : m unit :=
        match o1 , o2 with
          | Var_o v1 , Var_o v2 =>
            x <- ask ;;
            match Maps.lookup v1 x with
              | None => assert (eq_dec v1 v2)
              | Some v1 => assert (eq_dec v1 v2)
            end
          | Con_o c1 , Con_o c2 =>
            assert (eq_dec c1 c2)
          | Int_o z1 , Int_o z2 =>
            assert (eq_dec z1 z2)
          | _ , _ => assert false
        end.

      Fixpoint all2 {T} (p : T -> T -> m unit) (ls1 ls2 : list T) : m unit :=
        match ls1 , ls2 with
          | nil , nil => ret tt
          | l1 :: ls1 , l2 :: ls2 =>
            p l1 l2 ;;
            all2 p ls1 ls2
          | _ , _ => assert false
        end.

      Global Instance RelDec_eq_pattern : RelDec (@eq pattern) :=
      { rel_dec := fun x y =>
        match x , y with
          | Int_p x , Int_p y => eq_dec x y
          | Con_p x , Con_p y => eq_dec x y
          | _ , _ => false
        end }.

      Fixpoint alpha_exp' (e1 e2 : exp) {struct e1} : m unit :=
        match e1, e2 with
          | App_e f1 args1 , App_e f2 args2 =>
            alpha_op f1 f2 ;;
            all2 alpha_op args1 args2
          | Let_e ds1 e1 , Let_e ds2 e2 =>
            (** ignore permutations for now... **)
            alpha_dec ds1 ds2 (alpha_exp' e1 e2)
          | Switch_e op1 br1 e1 , Switch_e op2 br2 e2 =>
            alpha_op op1 op2 ;;
            match e1 , e2 with
              | None , None => assert true
              | Some e1 , Some e2 =>
                alpha_exp' e1 e2
              | _ , _ => assert false
            end ;;
            (fix all2 ls1 ls2 : m unit :=
              match ls1 , ls2 with
                | nil , nil => assert true
                | (p1,e1) :: ls1 , (p2,e2) :: ls2 =>
                  assert (eq_dec p1 p2) ;;
                  alpha_exp' e1 e2
                | _ , _ => assert false
              end) br1 br2
          | Halt_e o1 o1', Halt_e o2 o2'=>
            alpha_op o1 o2 ;;
            alpha_op o1' o2'
          | _ , _ => assert false
        end
      with alpha_dec (d1 d2 : decl) (k : m unit) {struct d1} : m unit :=
        match d1 , d2 with
          | Op_d v1 o1 , Op_d v2 o2 =>
            alpha_op o1 o2 ;;
            local (add v1 v2) k
          | Prim_d v1 p1 args1 , Prim_d v2 p2 args2 =>
            assert (eq_dec p1 p2) ;;
            all2 alpha_op args1 args2 ;;
            local (add v1 v2) k
          | Bind_d v1 w1 p1 args1 , Bind_d v2 w2 p2 args2 =>
            assert (eq_dec p1 p2) ;;
            all2 alpha_op args1 args2 ;;
            local (fun x => add v1 v2 (add w1 w2 x)) k
          | Fn_d v1 a1 e1 , Fn_d v2 a2 e2 =>
            (fix map_multi (x y : list var) (k : m unit) : m unit :=
              match x , y with
                | nil , nil => k
                | x :: xs , y :: ys =>
                  local (add x y) (map_multi xs ys k)
                | _ , _ => assert false
              end) a1 a2 (alpha_exp' e1 e2) ;;
            local (add v1 v2) k
          | _ , _ => assert false
        end.
    End monadic.
  End maps.

  Definition alpha_exp (e1 e2 : exp) : bool :=
    let res := runReader (unOptionT (alpha_exp' (m := optionT (reader (alist var var))) e1 e2)) empty in
    match res with
      | None => false
      | Some _ => true
    end.

  Definition alpha_lam (e1 e2 : exp) : list var -> list var -> bool :=
    (fix build acc l1 l2 {struct l1} : bool :=
      match l1 , l2 with
        | nil , nil =>
          let res := runReader (unOptionT (alpha_exp' (m := optionT (reader (alist var var))) e1 e2)) acc in
          match res with
            | None => false
            | Some _ => true
          end
        | l1 :: ls1 , l2 :: ls2 =>
          build (add l1 l2 acc) ls1 ls2
        | _ , _ => false
      end) empty.

  Module TEST.
    Require Import String.

    (** Test cases needed **)
    Definition f (v : var) : exp := Halt_e (Var_o v) (Var_o (wrapVar "world"%string)).

    Goal (alpha_exp (f (wrapVar "0")) (f (wrapVar "2")) = false)%string.
    Proof. vm_compute; reflexivity. Abort.

    Goal (alpha_exp (f (wrapVar "0")) (f (wrapVar "0")) = true)%string.
    Proof. vm_compute; reflexivity. Abort.

    Goal (alpha_lam (f (wrapVar "0")) (f (wrapVar "1")) (wrapVar "0" :: nil) (wrapVar "1" :: nil) = true)%string.
    Proof. vm_compute; reflexivity. Abort.

    Goal (alpha_lam (f (wrapVar "0")) (f (wrapVar "1")) (wrapVar "0" :: nil) (wrapVar "2" :: nil) = false)%string.
    Proof. vm_compute; reflexivity. Abort.

  End TEST.

End Alpha.


Require Import Lang.Syntax Lang.Bindings.
Set Implicit Arguments.

Section section_ktx.

Context (EV LV V L : Set).

(** Use [t] to fill in the hole of [ktx] *)
Fixpoint ktx_plug
(K : ktx EV LV V L) (t : tm EV LV V L) {struct K} :
tm EV LV V L :=
match K with
| ktx_hole => t
| ktx_op K => tm_op (ktx_plug K t)
| ktx_up K => tm_up (ktx_plug K t)
| ktx_down K X => tm_down X (ktx_plug K t)
| ktx_let K s => tm_let (ktx_plug K t) s
| ktx_throw K s => tm_throw (ktx_plug K t) s
| ktx_app_eff K E => tm_app_eff (ktx_plug K t) E
| ktx_app_lbl K ℓ => tm_app_lbl (ktx_plug K t) ℓ
| ktx_app_tm1 K s => tm_app_tm (ktx_plug K t) s
| ktx_app_tm2 K v => tm_app_tm v (ktx_plug K t)
end.

(** Compose outer evaluation context [K] and inner evaluation context
[J] to form a new evaluation context. *)
Fixpoint ktx_comp
(K : ktx EV LV V L) (J : ktx EV LV V L) {struct K} :
ktx EV LV V L :=
match K with
| ktx_hole => J
| ktx_op K => ktx_op (ktx_comp K J)
| ktx_up K => ktx_up (ktx_comp K J)
| ktx_down K X => ktx_down (ktx_comp K J) X
| ktx_let K t => ktx_let (ktx_comp K J) t
| ktx_throw K t => ktx_throw (ktx_comp K J) t
| ktx_app_eff K E => ktx_app_eff (ktx_comp K J) E
| ktx_app_lbl K ℓ => ktx_app_lbl (ktx_comp K J) ℓ
| ktx_app_tm1 K t => ktx_app_tm1 (ktx_comp K J) t
| ktx_app_tm2 K v => ktx_app_tm2 (ktx_comp K J) v
end.

(** Return [True] iff [X] is not a delimiter in [K]. *)
Fixpoint tunnels (X : var) (K : ktx EV LV V L) : Prop :=
match K with
| ktx_hole => True
| ktx_op K => tunnels X K
| ktx_up K => tunnels X K
| ktx_down K Y => tunnels X K ∧ X ≠ Y
| ktx_let K _ => tunnels X K
| ktx_throw K _ => tunnels X K
| ktx_app_eff K _ => tunnels X K
| ktx_app_lbl K _ => tunnels X K
| ktx_app_tm1 K _ => tunnels X K
| ktx_app_tm2 K _ => tunnels X K
end.

End section_ktx.

Inductive config :=
| config_mk : list var → tm0 → config
.

Notation "⟨ ξ , t ⟩" := (config_mk ξ t) : core_scope.

Inductive step : config → config → Prop :=
(** reduction rules *)
| step_let :
  ∀ ξ (v : val0) t,
  step ⟨ξ, tm_let v t⟩ ⟨ξ, V_subst_tm v t⟩
| step_throw :
  ∀ ξ K t,
  step
  ⟨ξ, tm_throw (val_cont K) t⟩
  ⟨ξ, ktx_plug K t⟩
| step_op :
  ∀ ξ m ι,
  step
  ⟨ξ, tm_op (val_fix m ι)⟩
  ⟨ξ, val_md (V_subst_md (val_fix m ι) m) ι⟩
| step_app_eff :
  ∀ ξ m ι E,
  step
  ⟨ξ, tm_app_eff (val_md (md_ev m) ι) E⟩
  ⟨ξ, val_md (EV_subst_md E m) ι⟩
| step_app_lbl :
  ∀ ξ m ι ℓ,
  step
  ⟨ξ, tm_app_lbl (val_md (md_lv m) ι) ℓ⟩
  ⟨ξ, val_md (LV_subst_md ℓ m) ι⟩
| step_app_tm :
  ∀ ξ m ι (v : val0),
  step
  ⟨ξ, tm_app_tm (val_md (md_tm m) ι) v⟩
  ⟨ξ, val_md (V_subst_md v m) ι⟩
| step_Down :
  ∀ ξ t X,
  X ∉ from_list ξ → (* This arbitrariness of [X] induces non-determinism *)
  step
  ⟨ξ, ⬇ t⟩
  ⟨X :: ξ, ⇩ X (L_subst_tm (lid_f X) t)⟩
| step_down_val :
  ∀ ξ X (v : val0),
  step ⟨ξ, ⇩ X v⟩ ⟨ξ, v⟩
| step_down_up :
  ∀ ξ X K t,
  tunnels X K →
  step
  ⟨ξ, ⇩ X (ktx_plug K (⇧ (val_md (md_res t) (lid_f X))))⟩
  ⟨ξ, V_subst_tm (val_cont (ktx_down K X)) t⟩

(** structural rules *)
| step_ktx_let :
  ∀ ξ₁ ξ₂ t₁ t₂ s,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_let t₁ s⟩ ⟨ξ₂, tm_let t₂ s⟩
| step_ktx_throw :
  ∀ ξ₁ ξ₂ t₁ t₂ s,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_throw t₁ s⟩ ⟨ξ₂, tm_throw t₂ s⟩
| step_ktx_app_tm1 :
  ∀ ξ₁ ξ₂ t₁ t₂ s,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app_tm t₁ s⟩ ⟨ξ₂, tm_app_tm t₂ s⟩
| step_ktx_app_tm2 :
  ∀ ξ₁ ξ₂ (v : val0) t₁ t₂ ,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app_tm v t₁⟩ ⟨ξ₂, tm_app_tm v t₂⟩
| step_ktx_app_eff :
  ∀ ξ₁ ξ₂ t₁ t₂ E,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app_eff t₁ E⟩ ⟨ξ₂, tm_app_eff t₂ E⟩
| step_ktx_app_lbl :
  ∀ ξ₁ ξ₂ t₁ t₂ ℓ,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_app_lbl t₁ ℓ⟩ ⟨ξ₂, tm_app_lbl t₂ ℓ⟩
| step_ktx_op :
  ∀ ξ₁ ξ₂ t₁ t₂ ,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_op t₁⟩ ⟨ξ₂, tm_op t₂⟩
| step_ktx_up :
  ∀ ξ₁ ξ₂ t₁ t₂ ,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, tm_up t₁⟩ ⟨ξ₂, tm_up t₂⟩
| step_ktx_down :
  ∀ ξ₁ ξ₂ t₁ t₂ X,
  step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
  step ⟨ξ₁, ⇩ X t₁⟩ ⟨ξ₂, ⇩ X t₂⟩
.

(** The transitive closure of the reduction relation. *)
Definition step_tran := @Relation_Operators.clos_trans_1n _ step.

(** The reflexive and transitive closure of the reduction relation. *)
Definition step_refl_tran := @Relation_Operators.clos_refl_trans_1n _ step.

(** Reduction in a given number of steps. *)
Inductive step_n : nat → config → config → Prop :=
| step_n_O : ∀ c, step_n O c c
| step_n_S : ∀ n c₁ c₂ c₃,
    step c₁ c₂ →
    step_n n c₂ c₃ →
    step_n (S n) c₁ c₃
.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import Setoid.
Require Import ClassicalExtras.
Require Import List.

Require Import XPrefix.
Require Import Criteria.
Require Import TechnicalLemmas.

(** *our assumptions *)
(**********************************************************)
Hypothesis input_totality_tgt : input_totality tgt.
Hypothesis determinacy_src    : determinacy src.
Hypothesis tgt_sem           : semantics_safety_like tgt.
(**********************************************************)

Lemma three_continuations_tbd :
  forall l t, xprefix (xtbd l) t ->
         ( (exists e, t = tstop l e) \/
                 (t = tsilent l) \/
            (exists e, xprefix (xtbd (snoc l e)) t)).
Proof.
  intros l [] Hpref.
  + simpl in Hpref. apply list_proper_or_equal in Hpref. destruct Hpref.
    ++ subst. left. now exists e.
    ++ right. right. firstorder.
  + simpl in Hpref. apply list_proper_or_equal in Hpref. destruct Hpref.
    ++ subst. right. now left.
    ++ right. right. firstorder.
  + generalize dependent s. induction l.
    ++ right. right. destruct s. now exists e.
    ++ intros [] Hpref. inversion Hpref. simpl.
       destruct (IHl s) as [ [ef FALSE] | [ FALSE | [e0 HH] ]]; try now inversion FALSE; auto.
       now simpl. right. right. exists e0; firstorder.
Qed.

(*********************************************************************************)

Definition myXr (x1 x2: xpref) : Prop :=
  (xpr x1 x2) \/ (xpr x2 x1) \/
  (exists l i1 i2, is_input i1 /\
               is_input i2 /\
               i1 <> i2 /\
               xpr (xtbd (snoc l i1)) x1 /\
               xpr (xtbd (snoc l i2)) x2).

Lemma myXr_symmetric : forall x1 x2, myXr x1 x2 -> myXr x2 x1.
 Proof. firstorder. Qed.

Lemma auXiliary_tstop :
  forall x2 l1 e1 t2, xprefix x2 t2 ->
                  traces_match (tstop l1 e1) t2 -> myXr (xstop l1 e1) x2.
Proof.
  intros x2 l1 e1 t2 xprefix2 [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]].
  + rewrite <- Heq in *. destruct (xsame_ext (xstop l1 e1) x2 (tstop l1 e1)); simpl; auto;
                          [now left |  right; now left].
  + destruct x2, t2; simpl in xprefix2; simpl in l_prefix1, l_prefix2; try now auto.
    ++ inversion xprefix2; subst.
       right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_stream_same_ext l (snoc ll i2) s); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ subst. right. right. now exists ll, i1, i2.
Qed.

Lemma auXiliary_tsilent :
  forall x2 l1 t2, xprefix x2 t2 ->
                traces_match (tsilent l1) t2 -> myXr (xsilent l1) x2.
Proof.
  intros x2 l1 t2 xprefix2 [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]].
  + rewrite <- Heq in *. destruct (xsame_ext (xsilent l1) x2 (tsilent l1)); simpl; auto;
                          [now left |  right; now left].
   + destruct x2, t2; simpl in xprefix2; simpl in l_prefix1, l_prefix2; try now auto.
    ++ inversion xprefix2; subst.
       right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_stream_same_ext l (snoc ll i2) s); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ subst. right. right. now exists ll, i1, i2.
Qed.

Lemma auXiliary_xtbd:
  forall l1 l2 t1 t2, xprefix (xtbd l1) t1 -> xprefix (xtbd l2) t2 ->
                  traces_match t1 t2 -> myXr (xtbd l1) (xtbd l2).
Proof.
  intros l1 l2 t1 t2 xpref1 xpref2 [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]].
  + subst. destruct (xsame_ext (xtbd l1) (xtbd l2) t2); auto; [now left | right; now left].
  + assert (H1: xprefix (xtbd (snoc ll i1)) t1).
    { destruct t1; simpl in *; now auto. }
    assert (H2 : xprefix (xtbd (snoc ll i2)) t2).
    { destruct t2; simpl in *; now auto. }
    destruct (xsame_ext (xtbd l1) (xtbd (snoc ll i1)) t1) as [l1_shorter | l1_longer]; auto.
    ++ destruct (xsame_ext (xtbd l2) (xtbd (snoc ll i2)) t2) as [l2_shorter | l2_longer]; auto.
       destruct (list_proper_or_equal _ _ l1_shorter) as [l1_ll | [a1 l1_ll]]; subst.
       * destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
          ** right. right. now exists ll, i1, i2.
          ** apply list_pref_snoc_pref in l2_ll. right. left. simpl.
             apply (list_list_prefix_trans l2 ll _); auto. now apply snoc_longer.
       * apply list_pref_snoc_pref in l1_ll.
         destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
         **  left. simpl. apply (list_list_prefix_trans l1 ll _ ); auto. now apply snoc_longer.
         ** apply list_pref_snoc_pref in l2_ll. destruct (list_list_same_ext l1 l2 ll); auto;
                                                  [now left | right; now left].
       * destruct (list_proper_or_equal  _ _ l1_shorter); auto; subst.
         ** right. right. now exists ll, i1, i2.
         ** destruct H as [a H]. apply list_pref_snoc_pref in H. left.
            simpl. apply (list_list_prefix_trans l1 ll l2); auto.
            simpl in l2_longer. apply (list_list_prefix_trans ll (snoc ll i2) l2); auto.
            now apply snoc_longer.
    ++ destruct (xsame_ext (xtbd l2) (xtbd (snoc ll i2)) t2) as [l2_shorter | l2_longer]; auto.
       * destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
          ** right. right. now exists ll, i1, i2.
          ** apply list_pref_snoc_pref in l2_ll. right. left. simpl.
             apply (list_list_prefix_trans l2 ll _); auto.
             apply (list_list_prefix_trans ll (snoc ll i1) _); auto. now apply snoc_longer.
        * right. right. now exists ll, i1, i2.
Qed.

Lemma auXiliary_lemma (t1 t2 : trace) :
  traces_match t1 t2 ->
  forall x1 x2,  xprefix x1 t1 -> xprefix x2 t2 -> myXr x1 x2.
Proof.
  intros [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]] x1 x2 xprefix1 xprefix2.
  - subst. unfold myXr. destruct (xsame_ext x1 x2 t2) as [go_left | go_right_left]; auto.
  - destruct x1, x2.
    ++ destruct t1, t2; inversion xprefix1; inversion xprefix2; subst.
       right. right. now exists ll, i1, i2.
    ++ destruct t1; inversion xprefix1; subst.
       apply (auXiliary_tstop (xtbd l0) l1 e0 t2); auto.
       right. now exists ll, i1, i2.
    ++ destruct t1, t2; inversion xprefix1; inversion xprefix2; subst.
       simpl in *. right. right. now exists ll, i1, i2.
    ++ destruct t2; inversion xprefix2; subst. apply myXr_symmetric.
       apply (auXiliary_tstop (xtbd l) l1 e0 t1); auto.
       right. exists ll, i2, i1. repeat (split; try now auto).
    ++ apply (auXiliary_xtbd l l0 t1 t2); auto. right. now exists ll, i1, i2.
    ++ destruct t2; inversion xprefix2; subst. apply myXr_symmetric.
       apply (auXiliary_tsilent (xtbd l) l1 t1); auto.
       right. exists ll, i2, i1. repeat (split; try now auto).
    ++ destruct t1, t2; inversion xprefix1; inversion xprefix2; subst.
       simpl in *. right. right. now exists ll, i1, i2.
    ++ destruct t1; inversion xprefix1; subst.
       apply (auXiliary_tsilent (xtbd l0) l1 t2); auto.
       right. now exists ll, i1, i2.
    ++ destruct t1, t2; inversion xprefix1; inversion xprefix2; subst.
       simpl in *. right. right. now exists ll, i1, i2.
Qed.

Lemma teq_premises_myXr_holds : forall P1 P2,
    (forall Cs t, sem src (Cs [P1]) t <-> sem src (Cs [P2]) t) ->
    (forall Cs x1 x2, xsem (Cs [P1]) x1 -> xsem (Cs [P2]) x2 ->
                 myXr x1 x2).
Proof.
  intros P1 P2 H Cs x1 x2 [t1 [xpref1 sem1]] [t2 [xpref2 sem2]].
    rewrite (H Cs t1) in sem1.
   specialize (determinacy_src (Cs[P2]) t1 t2 sem1 sem2).
   intros Hmatch. now apply (auXiliary_lemma t1 t2).
Qed.

Lemma  longest_in_xsem :
  forall W t, ~ sem tgt W t ->
    exists x, xprefix x t /\ xsem W x /\
     (forall x', xprefix x' t -> xsem W x' -> xpr x' x).
Proof.
  intros W [] HsemWt.
  + destruct (list_longest_in_psem W l) as [ll [Hpref [Hpsem Hmax]]].
    exists (xtbd ll). repeat (split; try now auto).
    intros [] Hx Hsemx.
    ++ inversion Hx; subst. destruct Hsemx as [tx [Hprefxtx Hsemx]].
       destruct tx; inversion Hprefxtx; subst. contradiction.
    ++ simpl in *. apply Hmax; auto.
    ++ inversion Hx.
  + destruct (list_longest_in_psem W l) as [ll [Hpref [Hpsem Hmax]]].
    exists (xtbd ll). repeat (split; try now auto).
    intros [] Hx Hsemx.
    ++ inversion Hx; subst.
    ++ simpl in *. apply Hmax; auto.
    ++ inversion Hx; subst. simpl in *.
       destruct Hsemx as [tx [Hprefxtx Hsemx]].
       destruct tx; inversion Hprefxtx; subst. contradiction.
  + destruct (tgt_sem (tstream s) W) as [l [ebad [Hseml [Hprefl Hnsem_longer]]]]; auto.
    exists (xtbd l). simpl in *. repeat (split; try now auto).
    ++ apply (list_stream_prefix_trans l (snoc l ebad) s); auto.
       now apply snoc_longer.
    ++ intros [] Hpref_x HxsemW; try now inversion Hpref_x.
       simpl in *. destruct (list_stream_same_ext l0 (snoc l ebad) s); auto.
       * apply list_proper_or_equal in H. destruct H as [H | [a H]].
         ** subst. exfalso. apply Hnsem_longer. destruct HxsemW as [tx [H1 H2]].
                 now exists tx.
         ** now apply list_pref_snoc_pref in H.
       * exfalso. apply Hnsem_longer. destruct HxsemW as [tx [H1 H2]].
             exists tx. split; try now auto.
             destruct tx; simpl in *; try now apply (list_list_prefix_trans (snoc l ebad) l0 l1).
             now apply (list_stream_prefix_trans (snoc l ebad) l0 s0).
Qed.

Lemma input_tot_consequence (W : prg tgt): forall l i1 i2,
    is_input i1 -> is_input i2 ->
    xsem W (xtbd (snoc l i1)) -> xsem W (xtbd (snoc l i2)).
Proof.
  intros l i1 i2 Hi1 Hi2 [t [xpref_x_t Hsemt]].
  assert (psem W (ftbd  (snoc l i1))).
  { simpl in *. now exists t. }
  now apply (input_totality_tgt W l i1 i2) in H.
Qed.

Lemma t_being_tstop_leads_to_contra (W1 W2 : prg tgt) t l2 e2
                                    (sem1 : sem tgt W1 t) (sem2 : sem tgt W2 (tstop l2 e2))
                                    (nsem12: ~ sem tgt W2 t)
                                    (xpref_x_t : xprefix (xtbd l2) t)
  :
    (forall x1 x2, xsem W1 x1 -> xsem W2 x2 -> myXr x1 x2) -> False.
Proof.
 intros twoX. destruct t.
 - simpl in *. destruct (twoX (xstop l e) (xstop l2 e2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]].
   now exists (tstop l e). now exists (tstop l2 e2).
   + inversion xpr1; subst. contradiction.
   + inversion xpr2; subst. contradiction.
   + simpl in Hxpr1, Hxpr2.
     apply (list_list_prefix_trans (snoc xx i2) l2 l Hxpr2) in xpref_x_t.
     destruct (list_list_same_ext (snoc xx i1) (snoc xx i2) l) as [F | F]; auto;
       apply Hdiff; apply (list_snoc_diff xx _ _ ) in F; congruence.
 - simpl in xpref_x_t.  destruct (twoX (xsilent l) (xstop l2 e2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]].
    now exists (tsilent l). try now exists (tstop l2 e2).
    + now inversion xpr1.
    + now inversion xpr2.
    + simpl in Hxpr1, Hxpr2.
     apply (list_list_prefix_trans (snoc xx i2) l2 l Hxpr2) in xpref_x_t.
     destruct (list_list_same_ext (snoc xx i1) (snoc xx i2) l) as [F | F]; auto;
       apply Hdiff; apply (list_snoc_diff xx _ _ ) in F; congruence.
 - simpl in xpref_x_t.
   destruct (tgt_sem (tstream s) W2 nsem12) as [l [ebad [Hpsem [Hpref Hnpsem]]]]; auto.
   simpl in Hpref.
   destruct (twoX (xtbd (snoc l ebad)) (xstop l2 e2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]]; auto.
   now exists (tstream s). now exists (tstop l2 e2).
   + simpl in xpr1. apply Hnpsem. now exists (tstop l2 e2).
   + simpl in *.
     apply (list_stream_prefix_trans _ _ s) in Hxpr1; auto.
     apply (list_stream_prefix_trans _ _ s) in Hxpr2; auto.
     destruct (list_stream_same_ext (snoc xx i1) (snoc xx i2) s) as [F | F]; auto;                              apply Hdiff; apply (list_snoc_diff xx _ _) in F; congruence.
Qed.

Lemma t_being_tsilent_leads_to_contra (W1 W2 : prg tgt) t l2
                                      (sem1 : sem tgt W1 t) (sem2 : sem tgt W2 (tsilent l2))
                                      (nsem12: ~ sem tgt W2 t)
                                      (xpref_x_t : xprefix (xtbd l2) t)
  :
    (forall x1 x2, xsem W1 x1 -> xsem W2 x2 -> myXr x1 x2) -> False.
Proof.
 intros twoX. destruct t.
 - simpl in *. destruct (twoX (xstop l e) (xsilent l2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]].
   now exists (tstop l e). now exists (tsilent l2).
   + now inversion xpr1.
   + now inversion xpr2.
   + simpl in Hxpr1, Hxpr2.
     apply (list_list_prefix_trans (snoc xx i2) l2 l Hxpr2) in xpref_x_t.
     destruct (list_list_same_ext (snoc xx i1) (snoc xx i2) l) as [F | F]; auto;
       apply Hdiff; apply (list_snoc_diff xx _ _ ) in F; congruence.
 - simpl in xpref_x_t.  destruct (twoX (xsilent l) (xsilent l2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]].
    now exists (tsilent l). try now exists (tsilent l2).
    + simpl in xpr1. now subst.
    + simpl in xpr2. now subst.
    + simpl in Hxpr1, Hxpr2.
     apply (list_list_prefix_trans (snoc xx i2) l2 l Hxpr2) in xpref_x_t.
     destruct (list_list_same_ext (snoc xx i1) (snoc xx i2) l) as [F | F]; auto;
       apply Hdiff; apply (list_snoc_diff xx _ _ ) in F; congruence.
 - simpl in xpref_x_t.
   destruct (tgt_sem (tstream s) W2 nsem12) as [l [ebad [Hpsem [Hpref Hnpsem]]]]; auto.
   simpl in Hpref.
   destruct (twoX (xtbd (snoc l ebad)) (xsilent l2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]]; auto.
   now exists (tstream s). now exists (tsilent l2).
   + simpl in xpr1. apply Hnpsem. now exists (tsilent l2).
   + simpl in *.
     apply (list_stream_prefix_trans _ _ s) in Hxpr1; auto.
     apply (list_stream_prefix_trans _ _ s) in Hxpr2; auto.
     destruct (list_stream_same_ext (snoc xx i1) (snoc xx i2) s) as [F | F]; auto;                              apply Hdiff; apply (list_snoc_diff xx _ _) in F; congruence.
Qed.

Lemma violates_xmax  (W1 W2 : prg tgt) t t2 l a aa
                     (sem1 : sem tgt W1 t) (sem2 : sem tgt W2 t2)
                     (nsem12: ~ sem tgt W2 t)
                     (xpref_x_t : xprefix (xtbd (snoc l aa)) t)
                     (x_t2 : xprefix (xtbd (snoc l a)) t2)

  :
    (forall x' : xpref, xprefix x' t -> xsem W2 x' -> xpr x' (xtbd l)) ->
    (forall x1 x2, xsem W1 x1 -> xsem W2 x2 ->  myXr x1 x2) -> False.
Proof.
  intros xmax twoX.
  assert (xsem1 : xsem W1 (xtbd (snoc l aa))) by now exists t.
  assert (xsem2 : xsem W2 (xtbd (snoc l a))) by now exists t2.
  specialize (twoX (xtbd (snoc l aa)) (xtbd (snoc l a)) xsem1 xsem2).
  destruct twoX as [xpr1 | [xpr2 | matching]].
  + simpl in xpr1. apply list_snoc_diff in xpr1. subst.
    specialize (xmax (xtbd (snoc l a)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
  + simpl in xpr2. apply list_snoc_diff in xpr2. subst.
    specialize (xmax (xtbd (snoc l aa)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
  + destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff_is [Hxpr1 Hxpr2 ]]]]]]].
    simpl in Hxpr1, Hxpr2.
    apply (list_snoc_pointwise xx l i1 i2 aa a) in Hxpr2; auto.
    destruct Hxpr2 as [H1 H2]. subst.
    apply (input_tot_consequence W2 l a aa) in xsem2; auto.
    specialize (xmax (xtbd (snoc l aa)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
Qed.

Lemma tinp_premises_myXr_holds : forall P1 P2,
    (forall Cs t, sem src (Cs [P1]) t -> sem src (Cs [P2]) t) ->
    (forall Cs x1 x2, xsem (Cs [P1]) x1 -> xsem (Cs [P2]) x2 ->
                 myXr x1 x2).
Proof.
  intros P1 P2 H Cs x1 x2 [t1 [xpref1 sem1]] [t2 [xpref2 sem2]].
  apply (H Cs t1) in sem1.
   specialize (determinacy_src (Cs[P2]) t1 t2 sem1 sem2).
   intros Hmatch. now apply (auXiliary_lemma t1 t2).
Qed.

Theorem R2rXP_RTIP : R2rXP -> RTIP.
Proof.
  rewrite <- R2rXC_R2rXP, R2rXC_R2rXC'. unfold R2rXC', RTIP, beh.
  intros twoX P1 P2 Hsrc Ct t.
  specialize (twoX myXr P1 P2 (tinp_premises_myXr_holds P1 P2 Hsrc) Ct).
  intros case1.
    apply NNPP. intros t_not_sem2.
    destruct (longest_in_xsem (Ct [P2↓]) t t_not_sem2) as [x [xpref_x_t [xsem2_x x_max]]].
    destruct xsem2_x as [t2 [x_t2 t2_sem2]].
    destruct x.
    ++ (* it can only be t2 '=' xstop p e = t *)
       destruct t, t2; auto.
       inversion xpref_x_t; inversion x_t2; subst; congruence.
    ++ destruct (three_continuations_tbd l t2 x_t2) as [t2stop | [t2silent | t2longer]].
       +++ destruct t2stop as [e2 Ht2]. rewrite Ht2 in *.
           now apply (t_being_tstop_leads_to_contra (Ct [P1↓]) (Ct [P2↓]) t l e2).
       +++ rewrite t2silent in *.
           now apply (t_being_tsilent_leads_to_contra  (Ct [P1↓]) (Ct [P2↓]) t l).
       +++ destruct t2longer as [a t2longer].
           destruct (three_continuations_tbd l t xpref_x_t) as [ttstop | [ttsilent | ttlonger]].
           - destruct ttstop as [e ttstop]. subst.
             destruct (twoX (xstop l e) (xtbd (snoc l a))) as [xpr1 | [xpr2 | matching]]; auto.
             now exists (tstop l e). now exists t2.
             -- simpl in xpr2. now apply snoc_strictly_longer in xpr2.
             -- destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2 ]]]]]]].
                simpl in Hxpr1, Hxpr2.
                apply (snocs_aux_lemma xx l i2 i1 a); congruence.
           - subst.
             destruct (twoX (xsilent l) (xtbd (snoc l a))) as [xpr1 | [xpr2 | matching]]; auto.
             now exists (tsilent l). now exists t2.
             -- simpl in xpr2. now apply snoc_strictly_longer in xpr2.
             -- destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2 ]]]]]]].
                simpl in Hxpr1, Hxpr2.
                apply (snocs_aux_lemma xx l i2 i1 a); congruence.
           - destruct ttlonger as [aa ttlonger].
             now apply (violates_xmax (Ct [P1↓]) (Ct [P2↓]) t t2 l a aa).
   ++ (*  it can only be t2 '=' xsilent p e = t *)
      destruct t, t2; auto.
      inversion xpref_x_t; inversion x_t2; subst; congruence.
Qed.

Theorem  R2rXP_RTEP : R2rXP -> RTEP.
Proof. intros H. apply RTIP_RTEP. exact (R2rXP_RTIP H). Qed.


Require Import GhostSimulations.

Require Import Raft.
Require Import RaftRefinementInterface.
Require Import CommonDefinitions.

Require Import LogMatchingInterface.
Require Import SortedInterface.
Require Import AllEntriesIndicesGt0Interface.

Require Import RefinedLogMatchingLemmasInterface.

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

  Context {rri : raft_refinement_interface}.
  Context {lmi : log_matching_interface}.
  Context {si : sorted_interface}.
  Context {aeigt0 : allEntries_indices_gt_0_interface}.

  Lemma ghost_packet :
    forall (net : network (params := raft_refined_multi_params)) p,
      In p (nwPackets net) ->
      In (deghost_packet p) (nwPackets (deghost net)).
  Proof using.
    unfold deghost.
    simpl. intuition.
    apply in_map_iff.
    eexists; eauto.
  Qed.

  Ltac forward_invariant :=
    match goal with
    | [ H : refined_raft_intermediate_reachable _, H' : _ |- _ ] =>
      apply H' in H; clear H'
    end.

  Ltac forward_nw_invariant :=
    match goal with
    | [ H : forall _ _ _ _ _ _ _, In _ _ -> pBody _ = _ -> _,
        H' : In _ _,
        H'' : pBody _ = _ |- _ ] =>
      specialize (H _ _ _ _ _ _ _ H' H'')
    end.

  Lemma entries_contiguous_nw_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_contiguous_nw net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_nw, entries_contiguous_nw in *. intuition.
    find_apply_lem_hyp ghost_packet.
    forward_nw_invariant. red. intuition.
  Qed.

  Lemma entries_gt_0_nw_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_gt_0_nw net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_nw, entries_gt_0_nw in *. intuition.
    find_apply_lem_hyp ghost_packet.
    forward_nw_invariant. break_and.
    find_apply_hyp_hyp. omega.
  Qed.

  Lemma entries_sorted_nw_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_sorted_nw net.
  Proof using si rri.
    intros.
    pose proof (lift_prop _ logs_sorted_invariant).
    forward_invariant.
    unfold log_matching, log_matching_nw, entries_sorted_nw in *. intuition.
    find_apply_lem_hyp ghost_packet.
    unfold logs_sorted in *. break_and.
    unfold logs_sorted_nw in *.
    eauto.
  Qed.

  Lemma entries_gt_0_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_gt_0 net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_hosts, entries_gt_0 in *. intuition.
    match goal with
    | [ H : _ |- _ ] => setoid_rewrite deghost_spec in H
    end.
    eauto.
  Qed.

  Lemma entries_contiguous_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_contiguous net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_hosts, entries_contiguous in *. break_and.
    intros.
    repeat match goal with
    | [ H : _ |- _ ] => setoid_rewrite deghost_spec in H
    end.
    red. intuition eauto.
    find_apply_hyp_hyp. auto.
  Qed.

  Lemma entries_sorted_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_sorted net.
  Proof using si rri.
    intros.
    pose proof (lift_prop _ logs_sorted_invariant).
    forward_invariant.
    unfold entries_sorted, logs_sorted, logs_sorted_host in *. break_and.
    match goal with
    | [ H : _ |- _ ] => setoid_rewrite deghost_spec in H
    end.
    eauto.
  Qed.

  Lemma entries_match_invariant :
    forall net h h',
      refined_raft_intermediate_reachable net ->
      entries_match (log (snd (nwState net h))) (log (snd (nwState net h'))).
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_hosts in *. break_and.
    repeat match goal with
    | [ H : _ |- _ ] => setoid_rewrite deghost_spec in H
    end.
    eauto.
  Qed.

  Lemma entries_match_nw_1_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_match_nw_1 net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_nw, entries_match_nw_1 in *. break_and.
    intros.
    repeat find_apply_lem_hyp ghost_packet.
    match goal with
    | [ H : forall _ _ _ _ _ _ , _,
        Hp : In (deghost_packet ?p) _,
        Hp' : In (deghost_packet ?p') _,
        Hes : pBody ?p = AppendEntries _ _ _ _ ?es _,
        Hes' : pBody ?p' = AppendEntries _ _ _ _ ?es' _,
        He'' : In ?e'' ?es
        |- In ?e'' ?es' ] =>
      specialize (H _ _ _ _ _ _ _ Hp Hes); break_and;
      match goal with
      | [ H' : forall _ _ _ _ _ _ , _ |- _ ] =>
        specialize (H' _ _ _ _ _ _ _ Hp' Hes')
      end
    end.

    match goal with
    | [ H : forall _ _, In _ _ -> _ |- _ ] => eapply H with (e1 := e) (e2 := e'); auto
    end.
  Qed.

  Lemma entries_match_nw_host_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      entries_match_nw_host net.
  Proof using lmi rri.
    intros.
    pose proof (lift_prop _ log_matching_invariant).
    forward_invariant.
    unfold log_matching, log_matching_nw, entries_match_nw_host in *. break_and.
    intros.
    repeat find_apply_lem_hyp ghost_packet.
    forward_nw_invariant. break_and.
    match goal with
    | [  |- context [ snd (nwState ?net ?h) ] ] =>
      replace (snd (nwState net h)) with (nwState (deghost net) h) in * by auto using deghost_spec
    end.
    match goal with
    | [ H : forall _ _ _, In _ ?es -> _,
        He : In ?e ?es,
        He' : In ?e' ?log,
        Hle : eIndex ?e'' <= eIndex ?e
        |- In ?e'' ?log ] =>
      specialize (H _ _ _ He He')
    end.
    repeat concludes; break_and. eauto.
  Qed.

  Lemma allEntries_gt_0_invariant :
    forall net h e,
      refined_raft_intermediate_reachable net ->
      In e (map snd (allEntries (fst (nwState net h)))) ->
      eIndex e > 0.
  Proof using aeigt0.
    intros.
    eapply allEntries_indices_gt_0_invariant; eauto.
  Qed.

  Instance rlmli : refined_log_matching_lemmas_interface.
  Proof.
    constructor.
    - apply entries_contiguous_nw_invariant.
    - apply entries_gt_0_nw_invariant.
    - apply entries_sorted_nw_invariant.
    - apply entries_gt_0_invariant.
    - apply entries_contiguous_invariant.
    - apply entries_sorted_invariant.
    - apply entries_match_invariant.
    - apply entries_match_nw_1_invariant.
    - apply entries_match_nw_host_invariant.
    - apply allEntries_gt_0_invariant.
  Qed.
End RefinedLogMatchingLemmas.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** This module reasons about the precise types of variables in inert contexts. *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import Definitions RecordAndInertTypes ConstrLangAlt ConstrTyping.
Require Import PreciseTyping.

Require Export PreciseTyping.

(** * Precise Typing for Constraints

    This is a replicate of original precise typing for the constraint-based type system.

    The precise flow relation defined for the original system
    simply retrieves type assignments from the environment.
    So we simply reuse the existing definition for the constraint-based system.
 *)

(** ** Precise typing for values *)
Reserved Notation "e '⊢c!v' v ':' T" (at level 40, v at level 59).

Inductive cty_val_p : (constr * ctx) -> val -> typ -> Prop :=

(** [G, x: T ⊢ t^x: U^x]       #
#
    [x fresh]                  #
#
    [――――――――――――――――――――――――] #
#
    [G ⊢! lambda(T)t: forall(T) U]     *)
| cty_all_intro_p : forall L C G T t U,
    (forall x, x \notin L ->
      (C, G & x ~ T) ⊢c open_trm x t : open_typ x U) ->
    (C, G) ⊢c!v val_lambda T t : typ_all T U

(** [G, x: T^x ⊢ ds^x :: T^x]   #
#
    [x fresh]                   #
#
    [―――――――――――――――――――――――]   #
#
    [G ⊢! nu(T)ds :: mu(T)]        *)
| cty_new_intro_p : forall L C G T ds,
    (forall x, x \notin L ->
      (C, G & (x ~ open_typ x T)) /-c open_defs x ds :: open_typ x T) ->
    (C, G) ⊢c!v val_new T ds : typ_bnd T

where "e '⊢c!v' v ':' T" := (cty_val_p e v T).

Hint Constructors cty_val_p.

(** The precise type of a value is inert. *)
Lemma constr_precise_inert_typ : forall C G v T,
    (C, G) ⊢c!v v : T ->
    inert_typ T.
Proof.
  introv Ht. inversions Ht; constructor; rename T0 into T.
  constr_pick_fresh z. assert (Hz: z \notin L) by auto.
  match goal with
  | [H: forall x, _ \notin _ -> _,
     Hz: ?z \notin _ |- _] =>
    specialize (H z Hz);
      pose proof (cty_defs_record_type H);
      assert (Hz': z \notin fv_typ T) by auto;
      apply* record_type_open
  end.
Qed.

Lemma constr_precise_to_general_v: forall C G v T,
    (C, G) ⊢c!v v : T ->
    (C, G) ⊢c trm_val v: T.
Proof.
  intros. induction H; intros; subst; eauto.
Qed.