(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 Provide standard test objects for all test files.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.

Definition k  := A.
Definition ka := A.
Definition kb := B.

(* Bug 4 i_i does not handle negative numbers! *)
Definition v'    := (i_e (i_i 4)).
Definition v''   := (i_e (i_i 6)).
Definition v     := (i_e (i_i 3)).
Definition v0    := (i_e (i_i Z0)).
Definition v1    := (i_e (i_i 1)).
Definition vi0   := (i_e (i_i Z0)).
Definition vi1   := (i_e (i_i 1)).
Definition vi2   := (i_e (i_i 2)).

Definition e    := (i_e (i_i Z0)).
Definition e'   := (i_e (i_i 1)).
Definition e0   := (i_e (i_i Z0)).
Definition e1   := (i_e (i_i 1)).
Definition e2   := (i_e (i_i 1)).

Definition s  := (retn (i_e (i_i 0))).
Definition s' := (retn (i_e (i_i 0))).
Definition s1 := (retn (i_e (i_i 1))).
Definition s2 := (retn (i_e (i_i 2))).

Definition x     := (EV.var 0).
Definition x'    := (EV.var 3).
Definition y     := (EV.var 1).
Definition y'    := (EV.var 4).
Definition z     := (EV.var 2).
Definition z'    := (EV.var 8).

Definition alpha := (TV.var 0).
Definition beta  := (TV.var 1).
Definition gamma := (TV.var 2).

Definition i     := (i_i 0).
Definition i1    := (i_i 1).
Definition i2    := (i_i 2).
Definition i3    := (i_i 3).

Definition tau  := cint.
Definition tau' := cross cint cint.
Definition t    := cint.
Definition t'   := cross cint cint.
Definition t0   := cint.
Definition t1   := cross cint cint.

Definition p0   := [(i_pe zero_pe)].
Definition p1   := [(i_pe one_pe)].

Definition h    := (H.ctxt x e hdot).

Definition q := aliases.

(* We use these to show that substitution ignores expresions without
  type variables, f, substitutes all alphas falphaalpha, and ignores
  type other type variables, fbetabeta. *)
Definition f           :=
  (dfun tau   x tau (retn (inst (p_e x pdot) tau))).
Definition faa :=
  (dfun tau   x (tv_t alpha) (retn (inst (p_e x pdot) (tv_t alpha)))).
Definition fbb  :=
  (dfun tau   x (tv_t beta) (retn (inst (p_e x pdot) (tv_t beta)))).

Definition applff  := (e_s (appl (f_e f)   (f_e f))).
Definition applfaa := (e_s (appl (f_e faa) (f_e faa))).
Definition applfbb := (e_s (appl (f_e fbb) (f_e fbb))).

Definition ufg  := (ufun gamma A faa).
Definition ufaa := (ufun alpha A faa).
Definition ufbb := (ufun beta  A faa).


(*
 * Usage: You may need "make equiv.vo" before
 * using this file.
 * In vscode, you may also need to add
 * "coqtop.args": [ "-Q", "/path/to/this/dir", "" ]
 * to settings.json.
 *)

Require Export equiv stack.

(* Rules of RPDA A and PDA A' *)

Section RPDA_to_PDA.

Local Open Scope type_scope.  (* for '*' *)

Parameter Sigma : Set.  (* finite alphabet *)

Parameter ruleA :
  Q -> Sigma -> Tst -> Q -> Asgn -> Com -> Prop.

Definition ruleA'_premise phi1 phi2 phi3 tst asgn :=
    composable phi1 phi2 /\
    composableT phi2 phi3 /\
    Phi_tst_asgn tst asgn phi3 /\
    is_equiv_rel phi3.

Inductive ruleA'
  : Q' -> Sigma -> Phi -> Q' -> Com' -> Prop :=
  | ruleA'_skip :
    forall q1 phi2 a phi1 q2 phi3 tst asgn,
    ruleA q1 a tst q2 asgn skip ->
    ruleA'_premise phi1 phi2 phi3 tst asgn ->
    ruleA' (q1, phi2) a phi1
           (q2, compositionT phi2 phi3) skip'
  | ruleA'_pop :
    forall q1 phi2 a phi1 q2 phi3 tst asgn,
    ruleA q1 a tst q2 asgn pop ->
    ruleA'_premise phi1 phi2 phi3 tst asgn ->
    ruleA' (q1, phi2) a phi1
           (q2, composition phi1 (compositionT phi2 phi3)) pop'
  | ruleA'_push :
    forall q1 phi2 a phi1 q2 phi3 tst asgn j,
    ruleA q1 a tst q2 asgn (push j) ->
    ruleA'_premise phi1 phi2 phi3 tst asgn ->
    ruleA' (q1, phi2) a phi1
           (q2, phi_to_Phi_eq_j j phi3) (push' (compositionT phi2 phi3)).

(* Transitions between configurations *)

Definition freshness_p_on_moveA (tst : Tst) (asgn : Asgn) d (u : Stack) :=
  (forall xi, tst xi <> true) -> (exists i, asgn i = true) ->
    Forall (not_contain d) u.

Inductive moveA
  : Config -> Sigma -> D -> Config -> Prop :=
  | MoveA :
    forall tst asgn com z zth u q1 q2 a d theta theta',
    ruleA q1 a tst q2 asgn com ->
    (theta, d, z) |= tst ->
    theta' = update theta asgn d ->
    freshness_p_on_moveA tst asgn d ((z, zth) :: u) ->
    moveA (q1, theta,  ((z, zth) :: u)) a d
          (q2, theta', update_stack ((z, zth) :: u) theta' com).

Inductive moveA'
  : Config' -> Sigma -> Config' -> Prop :=
  | MoveA' :
    forall q1 q2 a z u com',
    ruleA' q1 a z q2 com' ->
    moveA' (q1, (z :: u)) a
           (q2, update_stack' (z :: u) com').

(* Lemmas *)

(* freshness_p_on_moveA *)

Lemma updater_must_exist :
  forall theta e tst asgn th u phi phi3,
    (th, e, theta) |= phi ->
    Phi_tst_asgn tst asgn phi3 ->
    is_equiv_rel phi3 ->
    composableT phi phi3 ->
  exists d,
    (theta, d, e) |= tst /\
    freshness_p_on_moveA tst asgn d u.
Proof.
  intros theta e tst.
  intros asgn th u phi phi3.
  intros Hphi Hphi3 P3eq Hcom.
  destruct P3eq as [_ P3sym _].
  destruct (tst_is_empty_or_not tst)
  as [Htst_empty | Htst_not_empty].
  - (* tst_empty -> ... *)
  destruct (stack_has_outside_data theta e u)
  as [d [Hde [Hth Hu]]].
  exists d.
  unfold freshness_p_on_moveA.
  split; auto.
  (* (theta, d, e) |= tst *)
  unfold models.
  unfold Theta_D_D_models_Tst.
  split.
  * (* forall i, theta i = d <-> tst (inl i) = true *)
  split.
  -- intros H. apply Hth in H. contradiction.
  -- intros H. apply Htst_empty in H. contradiction.
  * (* e = d <-> tst (inr top) = true *)
  split.
  -- intros H. symmetry in H. apply Hde in H. contradiction.
  -- intros H. apply Htst_empty in H. contradiction.
  - (* tst_not_empty *)
  destruct Htst_not_empty as [xi Htst].
  unfold models in Hphi.
  unfold two_Theta_D_models_Phi in Hphi.
  destruct Hphi as [_ H11 _ _ H12].
  unfold Phi_tst_asgn in Hphi3.
  destruct Hphi3 as [H3 _].
  unfold composableT in Hcom.
  destruct Hcom as [Hc1 Hc2].
  unfold composable in Hc1.
  assert (H3' := H3 xi Htst).
  unfold models.
  unfold Theta_D_D_models_Tst.
  case_eq xi.
  + (* xi = inl n -> ... *)
  intros i Hxi.
  exists (theta i).
  split.
  * (* (theta, d, e) |= tst *)
  rewrite Hxi in H3'.
  split.
  -- (* forall j, theta j = theta i <-> tst (inl j) = true *)
  intros j.
  rewrite H11.
  rewrite Hc1.
  rewrite (H3' (inl j)).
  unfold X_.
  split; apply P3sym.
  -- (* e = theta i <-> tst (inr top) = true *)
  split.
  ++ intros He.
  apply (H3' (inr top)).
  unfold X_.
  rewrite<- Hc2.
  rewrite<- H12.
  symmetry.
  exact He.
  ++ intros Ht.
  symmetry.
  rewrite H12.
  rewrite Hc2.
  apply (H3' (inr top)).
  exact Ht.
  * (* freshness_p_on_moveA ... *)
  unfold freshness_p_on_moveA.
  intros H.
  apply H in Htst.
  contradiction.
  + (* xi = inr top -> ... *)
  intros t Hxi.
  destruct t.
  rewrite Hxi in H3'.
  rewrite Hxi in Htst.
  exists e.
  split.
  * (* (theta, d, e) |= tst *)
  split.
  -- (* forall i, theta i = e <-> tst (inl i) = true *)
  intros i.
  rewrite H12.
  rewrite Hc2.
  rewrite (H3' (inl i)).
  unfold X_.
  split; apply P3sym.
  -- (* e = e <-> tst (inr top) = true *)
  rewrite Htst.
  split; auto.
  * (* freshness_p_on_moveA ... *)
  unfold freshness_p_on_moveA.
  intros H.
  apply H in Htst.
  contradiction.
Qed.

Lemma substack_keeps_freshness_p_on_moveA :
  forall tst asgn d a u1 u2,
  freshness_p_on_moveA tst asgn d (u1 ++ (a :: u2)) ->
  freshness_p_on_moveA tst asgn d (u1 ++ u2).
Proof.
  intros tst asgn d a u1 u2.
  unfold freshness_p_on_moveA.
  intros Hfrs Htst Hasgn.
  assert (Hfrs' := Hfrs Htst Hasgn).
  generalize Hfrs'.
  apply (Forall_sublist _ a).
Qed.

(* weak_freshness_p *)

Lemma update_has_weak_freshness_p :
  forall th1 theta z d tst asgn u,
  (theta, d, z) |= tst ->
  freshness_p_on_moveA tst asgn d ((z, th1) :: u) ->
  weak_freshness_p th1 z theta (update theta asgn d).
Proof.
  intros th1 theta z d tst asgn u.
  intros Htst Hfrs_m.
  unfold weak_freshness_p.
  intros i j.
  intros H.
  unfold update in H.
  destruct (tst_is_empty_or_not tst)
  as [Htst_empty | Htst_not_empty].
  ++ (* tst_empty -> ... *)
  generalize dependent H.
  case_eq (asgn j); intros EQasgn H.
  ** (* asgn j = true -> ... *)
  apply ex_intro with (x := j) in EQasgn.
  assert (Hfrs_m' := Hfrs_m Htst_empty EQasgn).
  rewrite Forall_forall in Hfrs_m'.
  assert (Hzin : In (z, th1) ((z, th1) :: u)).
  { apply in_eq. }
  assert (Hm := Hfrs_m' (z, th1) Hzin).
  simpl in Hm.
  apply Hm in H.
  contradiction.
  ** (* asgn j = false -> ... *)
  left.
  exists j.
  exact H.
  ++ (* tst_not_empty -> ... *)
  clear Hfrs_m.
  unfold models in Htst.
  unfold Theta_D_D_models_Tst in Htst.
  destruct Htst as [Htst' Htst_top].
  destruct Htst_not_empty as [xi Htst_true].
  unfold freshness_p.
  case_eq xi.
  ** (* xi = inl n -> ... *)
  intros n EQxi.
  rewrite EQxi in Htst_true.
  rewrite<- Htst' in Htst_true.
  clear xi EQxi.
  left.
  generalize dependent H.
  case (asgn j); intro H.
  --- exists n.
  rewrite Htst_true.
  exact H.
  --- exists j.
  exact H.
  ** (* xi = inr top -> ... *)
  intros t EQxi.
  destruct t.
  rewrite EQxi in Htst_true.
  rewrite<- Htst_top in Htst_true.
  clear xi EQxi.
  generalize dependent H.
  case (asgn j); intro H.
  --- right.
  rewrite Htst_true.
  exact H.
  --- left. exists j.
  exact H.
Qed.

(* moveA *)

Local Lemma keeping_freshness_p_when_skip :
  forall theta zth d z u tst asgn,
  (theta, d, z) |= tst ->
  is_proper_stack ((z, zth) :: u) ->
  freshness_p_on_moveA tst asgn d ((z, zth) :: u) ->
  forall d1 d2 th1 th2,
  In (d1, th1) ((z, zth) :: u) ->
  In (d2, th2) u ->
  freshness_p_on_triple (bot, theta) (d1, th1) (d2, th2) ->
  freshness_p_on_triple     (z, zth) (d1, th1) (d2, th2) ->
  freshness_p_on_triple (bot, update theta asgn d) (d1, th1) (d2, th2).
Proof.
  intros theta zth d z u tst asgn.
  intros Htst Hproper Hfrs_m.
  intros d1 d2 th1 th2.
  intros Hth1 Hth2.
  unfold freshness_p_on_triple.
  unfold freshness_p.
  intros [H1 H2].
  intros [Hz1 Hz2].

  (* destruct Hfrs_m *)
  unfold freshness_p_on_moveA in Hfrs_m.
  destruct (tst_is_empty_or_not tst)
  as [Htst_empty | Htst_not_empty].

  - (* tst_empty -> ... *)
  unfold freshness_p_on_triple.
  unfold freshness_p.
  split.
  ** (* forall i j, th1 i = update ... -> ... *)
  intros i j.
  unfold update.
  case_eq (asgn j); intros EQasgn EQth2.
  +++ (* asgn j = true -> ... *)
  apply ex_intro with (x := j) in EQasgn.
  assert (Hfrs_m' := Hfrs_m Htst_empty EQasgn).
  rewrite Forall_forall in Hfrs_m'.
  assert (Hth2' : In (d2, th2) ((z, zth) :: u)).
  { apply in_cons. exact Hth2. }
  assert (Hm := Hfrs_m' (d2, th2) Hth2').
  simpl in Hm.
  apply Hm in EQth2.
  contradiction.
  +++ (* asgn j = false -> ... *)
  apply H1 with j.
  exact EQth2.
  ** (* forall j, d1 = update ... -> ... *)
  intros j.
  unfold update.
  case_eq (asgn j); intros EQasgn EQd2.
  +++ (* asgn j = true -> ... *)
  apply ex_intro with (x := j) in EQasgn.
  assert (Hfrs_m' := Hfrs_m Htst_empty EQasgn).
  rewrite Forall_forall in Hfrs_m'.
  assert (Hth2' : In (d2, th2) ((z, zth) :: u)).
  { apply in_cons. exact Hth2. }
  assert (Hm := Hfrs_m' (d2, th2) Hth2').
  simpl in Hm.
  (* destruct Hproper *)
  unfold is_proper_stack in Hproper.
  rewrite Forall_forall in Hproper.
  assert (Hprop2 := Hproper (d2, th2) Hth2').
  simpl in Hprop2.
  destruct Hprop2 as [i2 Hprop2].
  rewrite EQd2 in Hprop2.
  symmetry in Hprop2.
  apply Hm in Hprop2.
  contradiction.
  +++ (* asgn j = false -> ... *)
  apply H2 with j.
  exact EQd2.

  - (* tst_not_empty -> ... *)
  clear Hfrs_m.
  unfold models in Htst.
  unfold Theta_D_D_models_Tst in Htst.
  destruct Htst as [Htst' Htst_top].
  destruct Htst_not_empty as [xi Htst_true].
  case_eq xi.
  ** (* xi = inl n -> ... *)
  intros n EQxi.
  rewrite EQxi in Htst_true.
  rewrite<- Htst' in Htst_true.
  clear xi EQxi.

  split.
  --- (* forall i j, th1 i = update ... -> ... *)
  intros i j.
  unfold update.
  case (asgn j); intros EQth2.
  +++ (* asgn j = true -> ... *)
  apply H1 with n.
  rewrite Htst_true.
  exact EQth2.
  +++ (* asgn j = false -> ... *)
  apply H1 with j.
  exact EQth2.
  --- (* forall j, d1 = update ... -> ... *)
  intros j.
  unfold update.
  case (asgn j); intros EQd2.
  +++ (* asgn j = true -> ... *)
  apply H2 with n.
  rewrite Htst_true.
  exact EQd2.
  +++ (* asgn j = false -> ... *)
  apply H2 with j.
  exact EQd2.

  ** (* xi = inr top -> ... *)
  intros t EQxi.
  destruct t.
  rewrite EQxi in Htst_true.
  rewrite<- Htst_top in Htst_true.
  clear xi EQxi.

  (* destruct Hproper *)
  unfold is_proper_stack in Hproper.
  rewrite Forall_forall in Hproper.
  assert (Hzth: In (z, zth) ((z, zth) :: u)).
  { apply in_eq. }
  assert (Hpropz := Hproper (z, zth) Hzth).
  simpl in Hpropz.
  destruct Hpropz as [iz Hpropz].

  split.
  --- (* forall i j, th1 i = update ... -> ... *)
  intros i j.
  unfold update.
  case (asgn j); intros EQth2.
  +++ (* asgn j = true -> ... *)
  apply Hz1 with iz.
  rewrite EQth2.
  rewrite<- Htst_true.
  apply Hpropz.
  +++ (* asgn j = false -> ... *)
  apply H1 with j.
  exact EQth2.
  --- (* forall j, d1 = update ... -> ... *)
  intros j.
  unfold update.
  case (asgn j); intros EQd2.
  +++ (* asgn j = true -> ... *)
  apply Hz2 with iz.
  rewrite EQd2.
  rewrite<- Htst_true.
  apply Hpropz.
  +++ (* asgn j = false -> ... *)
  apply H2 with j.
  exact EQd2.
Qed.

Lemma moveA_keeps_freshness_p_when_skip :
  forall theta zth d z u tst asgn,
  (theta, d, z) |= tst ->
  is_proper_stack ((z, zth) :: u) ->
  freshness_p_on_moveA tst asgn d ((z, zth) :: u) ->
  freshness_p_on_stack theta ((z, zth) :: u) ->
  freshness_p_on_stack (update theta asgn d) ((z, zth) :: u).
Proof.
  intros theta zth d z u tst asgn.
  intros Htst Hproper Hfrs_m Hfrs_s.
  unfold freshness_p_on_stack.
  unfold freshness_p_on_stack in Hfrs_s.
  apply Forall3_cons.
  - (* Forall2 ... ((z, zth) :: u) *)
  apply Forall2_cons.
  + (* Forall ... u *)
  apply Forall_forall.
  intros [d1 th1] H1.
  (* freshness_p_on_triple (, update ...) (z, zth) (d1, th1) *)
  apply (keeping_freshness_p_when_skip _ zth _ z u tst asgn); auto.
  * (* In (z, zth) ((z, zth) :: u) *)
  apply in_eq.
  * (* freshness_p_on_triple (, theta) (z, zth) (d1, th1) *)
  inversion Hfrs_s as [| x1 l1 Hfor2 Hfor3 [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor3.
  inversion Hfor2 as [| x1 l1 Hfor Hfor2' [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor2 Hfor2'.
  rewrite Forall_forall in Hfor.
  apply Hfor.
  exact H1.
  * (* freshness_p_on_triple (z, zth) (z, zth) (d1, th) *)
  unfold freshness_p_on_triple.
  unfold freshness_p.
  split.
  -- intros i j Hth1. now exists j.
  -- intros j Hd1. now exists j.

  + (* Forall2 ... u *)
  induction u as [| [d1 th1] u IHu].
  { apply Forall2_nil. }
  apply Forall2_cons.
  * (* Forall ... u *)
  apply Forall_forall.
  intros [d2 th2] H2.
  (* freshness_p_on_triple (, update ...) (d1, th1) (d2, th2) *)
  apply (keeping_freshness_p_when_skip _ zth _ z ((d1, th1) :: u) tst asgn);
  auto.
  -- apply in_cons. apply in_eq.
  -- apply in_cons. exact H2.
  -- (* freshness_p_on_triple (, theta) (d1, th1) (d2, th2) *)
  inversion Hfrs_s as [| x1 l1 Hfor2 Hfor3 [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor3.
  inversion Hfor2 as [| x1 l1 Hfor Hfor2' [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor2 Hfor.
  inversion Hfor2' as [| x1 l1 Hfor Hfor2 [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor2 Hfor2'.
  rewrite Forall_forall in Hfor.
  apply Hfor.
  exact H2.
  -- (* freshness_p_on_triple (z, zth) (d1, th1) (d2, th2) *)
  inversion Hfrs_s as [| x1 l1 Hfor2 Hfor3 [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor2.
  inversion Hfor3 as [| x1 l1 Hfor2 Hfor3' [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor3 Hfor3'.
  inversion Hfor2 as [| x1 l1 Hfor Hfor2' [EQx1 EQl1]].
  clear x1 EQx1 l1 EQl1 Hfor2 Hfor2'.
  rewrite Forall_forall in Hfor.
  apply Hfor.
  exact H2.

  * (* Forall2 ... u *)
  apply IHu.
  -- now apply (substack_is_proper_stack (d1, th1) ((z, zth) :: nil)).
  -- now apply (substack_keeps_freshness_p_on_moveA _ _ _ (d1,th1) ((z,zth)::nil)).
  -- now apply (Forall3_sublist _ (d1, th1) ((bot,theta)::(z,zth)::nil)).

  - (* Forall3 ... ((z, zth) :: u) *)
  now apply (Forall3_sublist _ (bot, theta) nil).
Qed.

Lemma moveA_keeps_freshness_p :
  forall q theta u a d q' theta' u',
  moveA (q, theta, u) a d (q', theta', u') ->
  is_proper_stack u ->
  freshness_p_on_stack theta u ->
  freshness_p_on_stack theta' u'.
Proof.
  intros q theta u a d q' theta' u'.
  intros HmA Hprop Hfresh.
  inversion HmA as [tst asgn com z zth uu q1 q2 a' d' th1 th2
    HrA Htst EQth' Hfrs_m [EQq1 EQth1 EQu] EQa' EQd' [EQq2 EQth2 EQu']].
  clear q1 EQq1 th1 EQth1 a' EQa' d' EQd' q2 EQq2 th2 EQth2.

  assert (Hskip: freshness_p_on_stack theta' u).
  { rewrite EQth'. rewrite<- EQu.
  apply moveA_keeps_freshness_p_when_skip with tst;
  try rewrite EQu; auto; now rewrite<- EQu.
  }

  case_eq com;
  [intros Hcom | intros Hcom | intros j Hcom];
  rewrite Hcom in EQu';
  rewrite Hcom in HrA;
  clear com Hcom;
  unfold update_stack in EQu'.
  - (* com = pop -> ... *)
  apply (substack_keeps_freshness_p _ (z, zth) nil).
  unfold app.
  rewrite EQu.
  exact Hskip.
  - (* com = skip -> ... *)
  rewrite EQu.
  exact Hskip.
  - (* com = push -> ... *)
  apply push_keeps_freshness_p.
  rewrite EQu.
  exact Hskip.
Qed.

Lemma moveA_keeps_proper_stack :
  forall q theta u a d q' theta' u',
  moveA (q, theta, u) a d (q', theta', u') ->
  is_proper_stack u ->
  is_proper_stack u'.
Proof.
  intros q theta u a d q' theta' u'.
  intros HmA Hproper.
  inversion HmA as [tst asgn com z zth uu q1 q2 a' d' th1 th2
    HrA Htst EQth' Hfrs_m [EQq1 EQth1 EQu] EQa' EQd' [EQq2 EQth2 EQu']].
  clear q1 EQq1 th1 EQth1 a' EQa' d' EQd' q2 EQq2 th2 EQth2.
  case_eq com;
  [intros Hcom | intros Hcom | intros j Hcom];
  rewrite Hcom in EQu';
  rewrite Hcom in HrA;
  clear com Hcom;
  unfold update_stack in EQu'.
  - (* com = pop -> ... *)
  unfold is_proper_stack.
  unfold is_proper_stack in Hproper.
  rewrite<- EQu in Hproper.
  inversion Hproper as [| x l Hz Hproper_u' [EQx EQl]].
  apply Hproper_u'.
  - (* com = skip -> ... *)
  rewrite EQu.
  exact Hproper.
  - (* com = push -> ... *)
  unfold is_proper_stack.
  apply Forall_cons.
  { exists j; reflexivity. }
  unfold is_proper_stack in Hproper.
  rewrite<- EQu in Hproper.
  exact Hproper.
Qed.

(* Theorem on bisimilarity *)

Section Bisimilarity.

Variables q q' : Q.
Variable  theta : Theta.
Variable  phi : Phi.
Variable  u : Stack.
Variable  v : Stack'.
Variable  a : Sigma.

Hypothesis Hfresh : freshness_p_on_stack theta u.
Hypothesis Hproper : is_proper_stack u.
Hypothesis Hu_last : last u (d_0, theta_0) = (d_0, theta_0).
Hypothesis Heq_phi : is_equiv_rel phi.
Hypothesis Heq_v : Forall is_equiv_rel v.

Lemma bisimilar_1 :
  forall d theta' u',
    moveA (q, theta, u) a d (q', theta', u') ->
    config_R_config' (q, theta, u) ((q, phi), v) ->
  exists phi' v',
    moveA' ((q, phi), v) a ((q', phi'), v') /\
    config_R_config' (q', theta', u') ((q', phi'), v').
Proof.
  intros d theta' u'.
  intros HmA HR.
  inversion HmA as [tst asgn com z zth uu q1 q2 a' d' th1 th2
    HrA Htst EQth' Hfrs_m [EQq1 EQth1 EQu] EQa' EQd' [EQq2 EQth2 EQu']].
  clear q1 EQq1 th1 EQth1 a' EQa' d' EQd' q2 EQq2 th2 EQth2.
  assert (Hfresh': freshness_p_on_stack theta' u).
  { rewrite EQth'. rewrite<- EQu.
  rewrite<- EQu in Hproper.
  rewrite<- EQu in Hfresh.
  now apply moveA_keeps_freshness_p_when_skip with tst. }

  case_eq v.
  { (* v = nil -> ... *)
  intro EQv.
  rewrite EQv in HR.
  apply config_R_nil_nil_1 in HR as Hu_nil.
  rewrite Hu_nil in EQu.
  discriminate EQu.
  }
  (* v = phi1 :: vv -> ... *)
  intros phi1 vv EQv.

  inversion HR as [q1 theta1 u1 phi' v1 HsR [EQq1 EQth1 EQu1] [EQphi' EQv1]].
  clear q1 EQq1 theta1 EQth1 u1 EQu1;
  clear phi' EQphi' v1 EQv1.
  inversion HsR
  as [th2 phi' Hphi EQth2 Hu_nil |
      th2 th1 d1 phi' phi1' u1 v1 Hphi HsR1 EQth2 EQu1 EQphi' EQv1].
  { (* nil = u -> ... *)
  rewrite<- EQu in Hu_nil;
  discriminate Hu_nil.
  }
  (* ((d1, th1) :: u1) = u -> ... *)
  clear th2 EQth2 phi' EQphi'.
  rewrite<- EQu in EQu1.
  injection EQu1; clear EQu1.
  intros EQu1 EQth1 EQd1.
  rewrite EQu1 in HsR1; clear u1 EQu1.
  rewrite EQd1 in Hphi; clear d1 EQd1.
  rewrite EQv in EQv1.
  injection EQv1; clear EQv1.
  intros EQv1 EQphi1'.
  rewrite EQv1 in HsR1; clear v1 EQv1.
  rewrite EQphi1' in HsR1; clear phi1' EQphi1'.

  (* composable phi1 phi *)
  assert (Hphi_1: composable phi1 phi).
  { inversion HsR1
  as [th2 phi1' Hphi1 EQth2 EQuu EQphi1' EQvv |
     th2 th1' d1 phi' phi1' uu1 vv1 Hphi' HsR2 EQth2 EQuu1 EQphi' EQvv1].
  -- (* nil = vv -> ... *)
  now apply (double_models_means_composable theta_0 th1 theta d_0 z).
  -- (* (phi1' :: vv1) = vv -> ... *)
  now apply (double_models_means_composable th1' th1 theta d1 z).
  }

  (* weak_freshness_p th1 z theta theta' *)
  assert (Hwfrs: weak_freshness_p th1 z theta theta').
  { rewrite EQth'.
  apply (update_has_weak_freshness_p th1 theta z d tst asgn uu);
  now try rewrite EQth1. }

  (* phi3 *)
  assert (HtstEQth' := conj Htst EQth').
  apply ex_intro with (x := d) in HtstEQth' .
  apply meanings_of_Phi_tst_asgn in HtstEQth'.
  destruct HtstEQth' as [phi3 [Heq_phi3 [Htst_phi3 Hphi3]]].

  (* composableT phi phi3 *)
  assert (Hphi_3: composableT phi phi3).
  { now apply (double_models_means_composableT th1 theta theta' z). }

  case_eq com.
  - (* com = pop -> ... *)
  intros Hcom.
  rewrite Hcom in EQu'.
  rewrite Hcom in HrA.
  clear com Hcom.
  exists (composition phi1 (compositionT phi phi3)).
  exists (update_stack' v pop').
  rewrite EQv.
  split.
  + (* moveA' ... *)
  apply MoveA'.
  now apply ruleA'_pop with (tst := tst) (asgn := asgn).

  + (* config_R_config' ... *)
  unfold update_stack in EQu'.
  unfold update_stack.
  rewrite<- EQu' in HmA.

  unfold update_stack'.
  apply Config_R_config'.

  destruct vv as [| phi0 vv].

  * (* vv = nil -> ... *)
  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |].
  clear th1' EQth1' phi1' EQphi1' EQvv.
  rewrite<- EQuu in EQu.
  rewrite<- EQuu in HsR1.
  rewrite<- EQuu in HmA.

  rewrite<- EQu in Hu_last.
  unfold last in Hu_last.
  injection Hu_last.
  intros EQth1' EQz.
  rewrite EQth1' in EQth1.

  unfold freshness_p_on_moveA in Hfrs_m.

  apply Stack_R_stack'_nil.
  apply (meanings_of_composition theta_0 th1 theta' d_0 z);
  auto.
  -- (* is_equiv_rel phi1 *)
  rewrite Forall_forall in Heq_v.
  apply Heq_v.
  rewrite EQv.
  apply in_eq.
  -- (* freshness_p theta_0 d_0 th1 theta' *)
  unfold freshness_p.
  rewrite EQth1.
  split.
  ++ intros i j H.
  exists i.
  reflexivity.
  ++ intros j H.
  apply proper_bottom.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta' z).

  * (* vv = phi0 :: vv -> ... *)
  inversion HsR1
  as [| th1' th0 d0 phi1' phi0' uu' vv' Hphi1 HsR2
        EQth1' EQuu EQphi1' [EQphi0' EQvv]].
  clear th1' EQth1' phi1' EQphi1' phi0' EQphi0' EQvv.

  apply Stack_R_stack'_cons;
  auto.
  apply (meanings_of_composition th0 th1 theta' d0 z);
  auto.
  -- (* is_equiv_rel phi1 *)
  rewrite Forall_forall in Heq_v.
  apply Heq_v.
  rewrite EQv.
  apply in_eq.
  -- (* freshness_p th0 d0 th1 theta' *)
  rewrite<- EQu in Hfresh'.
  rewrite<- EQuu in Hfresh'.
  unfold freshness_p_on_stack in Hfresh'.
  apply Forall3_hd3 in Hfresh'.
  unfold freshness_p_on_triple in Hfresh'.
  rewrite EQth1.
  exact Hfresh'.
  -- (* (th1, z, theta') |= compositionT ... *)
  now apply meanings_of_compositionT with theta.

  - (* com = skip -> ... *)
  intros Hcom.
  rewrite Hcom in EQu'.
  rewrite Hcom in HrA.
  clear com Hcom.
  exists (compositionT phi phi3).
  exists (update_stack' v skip').
  rewrite EQv.
  split.
  + (* moveA' ... *)
  apply MoveA'.
  now apply ruleA'_skip with (tst := tst) (asgn := asgn).

  + (* config_R_config' ... *)
  rewrite EQu in EQu'.
  unfold update_stack in EQu'.
  unfold update_stack.
  rewrite<- EQu' in HmA.
  clear u' EQu'.
  rewrite<- EQth1.

  unfold update_stack'.
  apply Config_R_config'.

  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |
      th1' th0 d0 phi1' phi0' uu' vv' Hphi1 HsR2
      EQth1' EQuu EQphi1' [EQphi0' EQvv]].
  * (* nil = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1' EQvv.

  apply Stack_R_stack'_cons.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply meanings_of_compositionT with theta.
  -- (* stack_R_stack' th1 nil phi1 nil *)
  now apply Stack_R_stack'_nil.
  * (* phi0' :: vv' = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1'.
  apply Stack_R_stack'_cons.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta').
  -- (* stack_R_stack' th1 ((d0, th0) :: uu') ... *)
  now apply Stack_R_stack'_cons.

  - (* com = push j -> ... *)
  intros j Hcom.
  rewrite Hcom in EQu'.
  rewrite Hcom in HrA.
  clear com Hcom.
  exists (phi_to_Phi_eq_j j phi3).
  exists (update_stack' v (push' (compositionT phi phi3))).
  rewrite EQv.
  split.
  + (* moveA' ... *)
  apply MoveA'.
  now apply ruleA'_push with (tst := tst) (asgn := asgn).

  + (* config_R_config' ... *)
  rewrite EQu in EQu'.
  unfold update_stack in EQu'.
  unfold update_stack.
  rewrite<- EQu' in HmA.
  clear u' EQu'.
  rewrite<- EQth1.

  unfold update_stack'.
  apply Config_R_config'.

  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |
      th1' th0 d0 phi1' phi0' uu' vv' Hphi1 HsR2
      EQth1' EQuu EQphi1' [EQphi0' EQvv]].
  * (* nil = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1' EQvv.

  apply Stack_R_stack'_cons.
  -- (* (theta', theta' j, theta') |= phi_to_Phi_eq_j ... *)
  now apply theta_models_phi_to_Phi_eq_j with z theta.
  -- (* stack_R_stack' theta' ((z, th1) :: nil) ... *)
  apply Stack_R_stack'_cons.
  ++ (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply meanings_of_compositionT with theta.
  ++ (* stack_R_stack' th1 nil phi1 nil *)
  now apply Stack_R_stack'_nil.
  * (* phi0' :: vv' = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1'.
  apply Stack_R_stack'_cons.
  -- (* (theta', theta' j, theta') |= phi_to_Phi_eq_j ... *)
  now apply theta_models_phi_to_Phi_eq_j with z theta.
  -- (* stack_R_stack' theta' ((z, th1) :: ...) ... *)
  apply Stack_R_stack'_cons.
  ++ (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta').
  ++ (* stack_R_stack' th1 ((d0, th0) :: uu') ... *)
  now apply Stack_R_stack'_cons.
Qed.

Lemma bisimilar_2 :
  forall phi' v',
    moveA' ((q, phi), v) a ((q', phi'), v') ->
    config_R_config' (q, theta, u) ((q, phi), v) ->
  exists d theta' u',
    moveA (q, theta, u) a d (q', theta', u') /\
    config_R_config' (q', theta', u') ((q', phi'), v').
Proof.
  intros phi' v'.
  intros HmA' HR.

  inversion HmA' as [q1 q2 a' phi1 vv com' HrA' [EQq1 EQv] EQa' [EQq2 EQv']].
  clear q1 EQq1 q2 EQq2 a' EQa'.

  case_eq u.
  { (* u = nil -> ... *)
  intro EQu.
  rewrite EQu in HR.
  apply config_R_nil_nil_2 in HR as Hv_nil.
  rewrite Hv_nil in EQv.
  discriminate EQv.
  }
  (* u = (z, th1) :: uu -> ... *)
  intros [z th1] uu EQu.

  inversion HR as [q1 theta1 u1 phi'' v1 HsR [EQq1 EQth1 EQu1] [EQphi'' EQv1]].
  clear q1 EQq1 theta1 EQth1 u1 EQu1;
  clear phi'' EQphi'' v1 EQv1.
  inversion HsR
  as [th2 phi'' Hphi EQth2 Hu_nil |
      th2 th1' d1 phi'' phi1' u1 v1 Hphi HsR1 EQth2 EQu1 EQphi'' EQv1].
  { (* nil = u -> ... *)
  rewrite EQu in Hu_nil;
  discriminate Hu_nil.
  }
  (* ((d1, th1) :: u1) = u -> ... *)
  clear th2 EQth2 phi'' EQphi''.
  rewrite EQu in EQu1.
  injection EQu1; clear EQu1.
  intros EQu1 EQth1 EQd1.
  rewrite EQu1 in HsR1; clear u1 EQu1.
  rewrite EQd1 in Hphi; clear d1 EQd1.
  rewrite EQth1 in HsR1.
  rewrite EQth1 in Hphi; clear th1' EQth1.
  rewrite<- EQv in EQv1.
  injection EQv1; clear EQv1.
  intros EQv1 EQphi1'.
  rewrite EQv1 in HsR1; clear v1 EQv1.
  rewrite EQphi1' in HsR1; clear phi1' EQphi1'.

  inversion HrA' as
  [q1 phi'' a' phi1' q2 phi3 tst asgn HrA HrAp
   [EQq1 EQphi''] EQa' EQphi1' [EQq2 EQphi'] Hcom'
  |q1 phi'' a' phi1' q2 phi3 tst asgn HrA HrAp
   [EQq1 EQphi''] EQa' EQphi1' [EQq2 EQphi'] Hcom'
  |q1 phi'' a' phi1' q2 phi3 tst asgn j' HrA HrAp
   [EQq1 EQphi''] EQa' EQphi1' [EQq2 EQphi'] Hcom'];
  clear q1 EQq1 q2 EQq2 a' EQa' phi'' EQphi'' phi1' EQphi1';
  rewrite<- Hcom' in EQv';
  rewrite<- Hcom' in HrA';
  clear com' Hcom';
  destruct HrAp as [Hphi_1 [Hphi_3 [Htst_phi3 P3eq]]];
  assert (H := updater_must_exist
    theta z tst asgn th1 u phi phi3
    Hphi Htst_phi3 P3eq Hphi_3);
  destruct H as [d [Htst Hfrs_m]];

  (* EQth': theta' = update theta asgn d *)
  remember (update theta asgn d) as theta' eqn:EQth';

  (* Hfresh': freshness_p_on_stack theta' u *)
  rewrite EQu in Hproper;
  rewrite EQu in Hfresh;
  rewrite EQu in Hfrs_m;
  apply (moveA_keeps_freshness_p_when_skip theta th1 d z uu tst asgn
  Htst Hproper Hfrs_m)
  in Hfresh as Hfresh';
  rewrite<- EQth' in Hfresh';

  (* Hphi3: (theta, z, theta') |= phi3 *)
  assert (Htst_th' := conj Htst EQth');
  apply ex_intro with (x := d) in Htst_th';
  apply meanings_of_Phi_tst_asgn in Htst_th';
  destruct Htst_th' as [phi3' [P3'eq [Htst_phi3' Hphi3]]];
  apply (double_models_means_composableT th1 theta theta' z phi phi3'
    Hphi) in Hphi3 as Hphi_3';
  assert (EQphi3' := conj Hphi_3' Htst_phi3');
  apply (at_most_one_Phi_tst_asgn tst asgn phi phi3 phi3'
  (conj P3eq P3'eq) (conj Hphi_3 Htst_phi3)) in EQphi3';
  rewrite<- EQphi3' in Hphi3;
  clear phi3' EQphi3' P3'eq Htst_phi3' Hphi_3';

  (* weak_freshness_p th1 z theta theta' *)
  assert (Hwfrs := update_has_weak_freshness_p th1 theta z d tst asgn uu
    Htst Hfrs_m);
  rewrite<- EQth' in Hwfrs.

  - (* com' = skip' -> ... *)
  exists d.
  exists theta'.
  exists (update_stack u theta' skip).
  rewrite EQu.
  split.
  + (* moveA ... *)
  now apply MoveA with tst asgn.

  + (* config_R_config' ... *)
  rewrite<- EQv' in HmA'.
  clear v' EQv'.

  unfold update_stack.
  unfold update_stack'.
  apply Config_R_config'.

  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |
      th1' th0 d0 phi1' phi0' uu' vv' Hphi1 HsR2
      EQth1' EQuu EQphi1' [EQphi0' EQvv]].
  * (* nil = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1' EQvv.

  apply Stack_R_stack'_cons.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply meanings_of_compositionT with theta.
  -- (* stack_R_stack' th1 nil phi1 nil *)
  now apply Stack_R_stack'_nil.
  * (* phi0' :: vv' = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1'.
  apply Stack_R_stack'_cons.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta').
  -- (* stack_R_stack' th1 ((d0, th0) :: uu') ... *)
  now apply Stack_R_stack'_cons.

  - (* com' = pop' -> ... *)
  exists d.
  exists theta'.
  exists (update_stack u theta' pop).
  rewrite EQu.
  split.
  + (* moveA ... *)
  now apply MoveA with tst asgn.

  + (* config_R_config' ... *)
  unfold update_stack' in EQv'.
  rewrite<- EQv' in HmA'.
  clear v' EQv'.

  unfold update_stack.
  unfold update_stack'.
  apply Config_R_config'.

  destruct uu as [| [d0 th0] uu].

  * (* uu = nil -> ... *)
  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |].
  clear th1' EQth1' phi1' EQphi1' EQuu.
  rewrite<- EQvv in EQv.
  rewrite<- EQvv in HsR1.
  rewrite<- EQvv in HmA'.
  clear vv EQvv.

  rewrite EQu in Hu_last.
  unfold last in Hu_last.
  injection Hu_last.
  intros EQth1 EQz.

  unfold freshness_p_on_moveA in Hfrs_m.

  apply Stack_R_stack'_nil.
  apply (meanings_of_composition theta_0 th1 theta' d_0 z);
  auto.
  -- (* is_equiv_rel phi1 *)
  rewrite Forall_forall in Heq_v.
  apply Heq_v.
  rewrite<- EQv.
  apply in_eq.
  -- (* freshness_p theta_0 d_0 th1 theta' *)
  unfold freshness_p.
  rewrite EQth1.
  split.
  ++ intros i j H.
  exists i.
  reflexivity.
  ++ intros j H.
  apply proper_bottom.
  -- (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta' z).

  * (* uu = (d0, th0) :: uu -> ... *)
  inversion HsR1
  as [| th1' th0' d0' phi1' phi0 uu' vv' Hphi1 HsR2
        EQth1' [EQd0' EQth0' EQuu] EQphi1' EQvv].
  clear th1' EQth1' th0' EQth0' d0' EQd0' phi1' EQphi1' EQuu.

  apply Stack_R_stack'_cons;
  auto.
  apply (meanings_of_composition th0 th1 theta' d0 z);
  auto.
  -- (* is_equiv_rel phi1 *)
  rewrite Forall_forall in Heq_v.
  apply Heq_v.
  rewrite<- EQv.
  apply in_eq.
  -- (* freshness_p th0 d0 th1 theta' *)
  unfold freshness_p_on_stack in Hfresh'.
  apply Forall3_hd3 in Hfresh'.
  unfold freshness_p_on_triple in Hfresh'.
  exact Hfresh'.
  -- (* (th1, z, theta') |= compositionT ... *)
  now apply meanings_of_compositionT with theta.

  - (* com' = push' phi4 -> ... *)
  exists d.
  exists theta'.
  exists (update_stack u theta' (push j')).
  rewrite EQu.
  split.
  + (* moveA ... *)
  now apply MoveA with tst asgn.

  + (* config_R_config' ... *)
  rewrite<- EQv' in HmA'.
  clear v' EQv'.

  unfold update_stack.
  unfold update_stack'.
  apply Config_R_config'.

  inversion HsR1
  as [th1' phi1' Hphi1 EQth1' EQuu EQphi1' EQvv |
      th1' th0 d0 phi1' phi0' uu' vv' Hphi1 HsR2
      EQth1' EQuu EQphi1' [EQphi0' EQvv]].
  * (* nil = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1' EQvv.

  apply Stack_R_stack'_cons.
  -- (* (theta', theta' j', theta') |= phi_to_Phi_eq_j ... *)
  now apply theta_models_phi_to_Phi_eq_j with z theta.
  -- (* stack_R_stack' theta' ((z, th1) :: nil) ... *)
  apply Stack_R_stack'_cons.
  ++ (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply meanings_of_compositionT with theta.
  ++ (* stack_R_stack' th1 nil phi1 nil *)
  now apply Stack_R_stack'_nil.
  * (* phi0' :: vv' = vv -> ...*)
  clear th1' EQth1' phi1' EQphi1'.
  apply Stack_R_stack'_cons.
  -- (* (theta', theta' j, theta') |= phi_to_Phi_eq_j ... *)
  now apply theta_models_phi_to_Phi_eq_j with z theta.
  -- (* stack_R_stack' theta' ((z, th1) :: ...) ... *)
  apply Stack_R_stack'_cons.
  ++ (* (th1, z, theta') |= compositionT phi phi3 *)
  now apply (meanings_of_compositionT th1 theta theta').
  ++ (* stack_R_stack' th1 ((d0, th0) :: uu') ... *)
  now apply Stack_R_stack'_cons.
Qed.

End Bisimilarity.

Section Start_config.

Variable q0 : Q.
Hypothesis EQth0 : theta_0 = theta_bot.
Hypothesis EQd0  : d_0 = bot.
Lemma start_configs_satisfy_R :
  config_R_config'
    (q0, theta_bot, ((bot, theta_bot) :: nil))
    ((q0, phi_zero), (phi_zero :: nil)).
Proof.
  assert (H: (theta_bot, bot, theta_bot) |= phi_zero).
  { unfold models.
  unfold two_Theta_D_models_Phi.
  unfold theta_bot.
  unfold phi_zero.
  now repeat split.
  }
  apply Config_R_config'.
  apply Stack_R_stack'_cons;
  [| apply Stack_R_stack'_nil];
  try rewrite EQth0;
  try rewrite EQd0;
  auto.
Qed.

End Start_config.

End RPDA_to_PDA.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  arb\_intersections.v }%*)
(** - This stuff could be put in the algebra contribution as well. We
 define indexed intersections $\bigcap_{i\in I} X_i$ whenever all
 $X_i\subset X$, and arbitrary intersections $\bigcap_{X\in P}X$ for
 $P\subset{\cal P}(A)$.
 - Suppose we have a collection of subsets $A_i$ of a setoid $A$,
 indexed by some index set $I$. Then we may define the
 intersection $\bigcap_{i\in I} A_i \subset A$ as
 $\{a\in A | \forall i\in I.a\in A_i\}$ *)

Set Implicit Arguments.
Unset Strict Implicit.
From Algebra Require Export Parts2.
Require Export Classical_Pred_Type.
Section MAIN.
Section indexed_int.

Variable A : Setoid.
Variable I : Setoid.
Variable f : MAP I (part_set A). (* Picks A_i for i\in I *)

(** - so, given an index set $I$ and an indexing function $f$ mapping
 this set to the part_set (powerset) of X,  (ie. $f(i) = A_i\ (\in (part\_set A))$,)
 then (indexed_intersection f) will be $\bigcap_{i\in I} A_i$. *)

Definition indexed_intersection : part_set A.
simpl in |- *.
apply
 (Build_Predicate (Pred_fun:=fun a : A => forall i : I, in_part a (f i))).
red in |- *.
intros.
apply in_part_comp_l with x.
apply H.
assumption.
Defined.

(* Note that as we used "Variable"s, in this section we can write *)
(* "indexed_intersection" instead of (indexed_intersection f). *)
(* The following Lemma then states that \forall i \in I: intersection \subseteq A_i *)
Lemma indexed_intersection_included_in_subsets :
 forall i : I, included indexed_intersection (f i).
intro.
red in |- *.
intros.
unfold indexed_intersection in H.
simpl in H.
apply H.
Qed.

(* if a \in indexed_intersection then a \in A_i (\forall i \in I) *)
Lemma in_indexed_intersection_then_in_subsets :
 forall a : A,
 in_part a indexed_intersection -> forall i : I, in_part a (f i).
intros.
unfold indexed_intersection in H.
simpl in H.
apply H.
Qed.

(* if a is an element of all A_i, then it is an element of the intersection *)
Lemma in_subsets_then_in_indexed_intersection :
 forall a : A,
 (forall i : I, in_part a (f i)) -> in_part a indexed_intersection.
intros.
unfold indexed_intersection in |- *.
simpl in |- *.
assumption.
Qed.

(* contrarily, if for some i \in I a is not in A_i, then neither is it in *)
(* the indexed intersection *)
Lemma not_in_part_then_not_in_indexed_intersection :
 forall a : A,
 (exists i : I, ~ in_part a (f i)) -> ~ in_part a indexed_intersection.
intros.
inversion H.
simpl in |- *.
intro.
apply H0.
apply H1.
Qed.

Lemma not_in_indexed_intersection_then_not_in_part :
 forall a : A,
 ~ in_part a indexed_intersection -> exists i : I, ~ in_part a (f i).
intros.
simpl in H.
apply (not_all_ex_not I (fun i : I => in_part a (f i))).
assumption.
Qed.

(* if one of the A_i is contained in some subset B, then so is the intersection *)
Lemma subset_included_then_indexed_intersection_included :
 forall B : part_set A,
 (exists i : I, included (f i) B) -> included indexed_intersection B.
intros.
inversion H.
unfold included in |- *.
unfold included in H0.
intros.
apply H0.
simpl in H1.
apply H1.
Qed.

End indexed_int.

(* The following is 'predefined' as "image_map"; I prefer this name: *)
Let range (A B : Setoid) (f : MAP A B) := image f (full A).

Section Compatibility_of_indexed_intersections.
Variable A : Setoid.
Variable I : Setoid.

(** - If $(F_i)_i$ (indexed by $f$) and $(G_j)_j$ (indexed by $g$) denote the same set
 of subsets of $A$, then the indexed intersections of the $F_i$ and $G_j$ are equal *)
Lemma indexed_intersection_comp :
 forall f g : MAP I (part_set A),
 Equal f g -> Equal (indexed_intersection f) (indexed_intersection g).
intros.
simpl in |- *.
unfold eq_part in |- *.
intros.
split.
intro.
simpl in |- *.
simpl in H0.
intro.
apply in_part_comp_r with (f i); auto.
intro.
simpl in |- *.
simpl in H0.
intro.
apply in_part_comp_r with (g i); auto.
apply Sym.
apply H.
Qed.

(** - in fact, even if only the images of the indexing functions are the same, so
 is their intersection (ie. the index sets $I,J$ may not be equal, but (indexing the
 subsets by $F$ and $G$) for all $F_i, i \in I$, there is some $G_j, j \in J$ equal
 to it and vice versa) *)

Variable J : Setoid.
Lemma indexed_intersection_indep_of_indexing :
 forall (f : MAP I (part_set A)) (g : MAP J (part_set A)),
 Equal (range f) (range g) ->
 Equal (indexed_intersection f) (indexed_intersection g).
intros.
simpl in |- *.
unfold eq_part in |- *.
intro a.
split.
simpl in |- *.
intros H0 j.
unfold image in H.
simpl in H.
unfold eq_part in H.
simpl in H.
generalize (H (g j)).
intros (H1, H2).
cut
 (exists j' : J,
    True /\
    (forall a0 : A,
     (in_part a0 (g j) -> in_part a0 (g j')) /\
     (in_part a0 (g j') -> in_part a0 (g j)))).
intro.
generalize (H2 H3).
intro.
inversion_clear H4.
inversion_clear H5.
elim (H6 a).
auto.
exists j.
intuition.
simpl in |- *.
intros H0 i.
unfold image in H.
simpl in H.
unfold eq_part in H.
simpl in H.
generalize (H (f i)).
intros (H1, H2).
cut
 (exists i' : I,
    True /\
    (forall x0 : A,
     (in_part x0 (f i) -> in_part x0 (f i')) /\
     (in_part x0 (f i') -> in_part x0 (f i)))).
intro.
generalize (H1 H3).
intro.
inversion_clear H4.
inversion_clear H5.
elim (H6 a).
auto.
exists i.
intuition.
Qed.
End Compatibility_of_indexed_intersections.

(** - If $I=\emptyset$ then $\bigcap_{i\in I} X_i = A$ *)

Lemma empty_indexed_intersection_gives_full_set :
 forall (A : Setoid) (f : MAP (empty A) (part_set A)),
 Equal (indexed_intersection f) (full A).
intros.
unfold indexed_intersection in |- *; simpl in |- *.
red in |- *; simpl in |- *; simpl in f.
intro a; split.
auto.
intros _ i; inversion_clear i.
simpl in subtype_prf.
contradiction.
Qed.

(** - Fully general intersections of (a set of) sets is introduced as follows: *)

Definition intersection :
  forall A : Setoid, part_set (part_set A) -> part_set A.
intros A P.
simpl in |- *.
apply
 Build_Predicate
  with (fun a : A => forall p : part_set A, in_part p P -> in_part a p).
red in |- *; simpl in |- *.
intros.
apply in_part_comp_l with x; auto with algebra.
Defined.

Section intersection_v_indexed_intersection.

Lemma intersection_to_indexed_intersection :
 forall (A I : Setoid) (f : MAP I (part_set A)),
 Equal (intersection (range f)) (indexed_intersection f).
intros.
simpl in |- *.
red in |- *.
split; simpl in |- *; intros.
generalize (H (f i)).
intro p; apply p.
exists i; split; auto with algebra.
red in |- *.
split; auto.
inversion_clear H0.
inversion_clear H1.
apply in_part_comp_r with (f x0); auto with algebra.
Qed.

End intersection_v_indexed_intersection.
End MAIN.


(**
Coq/SSReflect/MathComp による定理証明

5. 集合の形式化
======
2018_05_03 @suharahiromichi
2020_10_25 @morita_hm : 積集合関連の演算を追記
2020_11_09 @morita_hm : GitLab から Subset の像を追加
https://github.com/morita-hm/proofcafe_private/blob/main/csm_5_set_theory.v
 *)

(**
- csm_5_set_theory.v    全体の内容、および、演習問題 5.1の逆像
- csm_ex_5_1.v          演習問題 5.1 の積集合と差集合
- csm_ex_5_2_a.v        演習問題 5.2
- csm_ex_5_3_a.v        演習問題 5.3
- csm_ex_5_4.v          演習問題 5.4
- csm_ex_5_5.v          演習問題 5.5

- csm_5_set_theory_fintype.v   5.5 finsetを用いた有限集合の形式化（具体的な集合）
- csm_5_set_theory_finset.v    5.6 ライブラリfinset（5.5節までとは独立な内容)
*)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Print All.

(* 5.1 集合、部分集合 *)
Definition mySet (M : Type) := M -> Prop.
Definition belong {M : Type} (A : mySet M) (x : M) : Prop := A x.
Notation "x ∈ A" := (belong A x) (at level 11).
Axiom axiom_mySet : forall (M : Type) (A : mySet M), forall (x : M), x ∈ A \/ ~(x ∈ A).

Definition myEmptySet {M : Type} : mySet M := fun (_ : M) => False.
Definition myMotherSet {M : Type} : mySet M := fun (_ : M) => True.

(* 5.2 包含関係と統合 *)

Definition mySub {M : Type} := fun (A B : mySet M) => forall (x : M), x ∈ A -> x ∈ B.
Notation "A ⊂ B" := (mySub A B) (at level 11).

Section 包含関係.
  Variable M : Type.

  Check mySet M : Type.
  Check myEmptySet : mySet M.
  Check myMotherSet : mySet M.

  Lemma Sub_Mother (A : mySet M) : A ⊂ myMotherSet.
  Proof.
    rewrite /mySub /myMotherSet /belong => x1 H.
    (* Goal : True *)
    done.

    Restart.
      by [].
  Qed.

  Lemma Sub_Empty (A : mySet M) : myEmptySet ⊂ A.
  Proof.
    rewrite /mySub /myEmptySet /belong => x1 H.
    (* H : False *)
    done.

    Restart.
      by [].
  Qed.

  Lemma rfl_Sub (A : mySet M) : A ⊂ A.
  Proof.
    rewrite /mySub /belong => x1 H.
      (* A x1 -> A x1 *)
    done.

    Restart.
      by [].
  Qed.

  Lemma transitive_Sub (A B C : mySet M) : A ⊂ B -> B ⊂ C -> A ⊂ C.
  Proof.
    move=> HAB HBC t HtA.
    (* HBC : B ⊂ C *)
    rewrite /mySub in HBC.  (* 省略可能である。 *)
    (* HBC : forall x : M, x ∈ B -> x ∈ C *)
    (* Goal : t ∈ C *)
    apply: HBC.
    (* Goal : t ∈ B *)

    apply: HAB.
    apply: HtA.

    Restart.
    move=> HAB HBC t HtA.
      by auto.                              (* 導出原理 *)
  Qed.
End 包含関係.

Definition eqmySet {M : Type} (A B : mySet M) := (A ⊂ B) /\ (B ⊂ A).
(* 公理を追加する。 *)
Axiom axiom_ExteqmySet : forall {M : Type} (A B : mySet M), eqmySet A B -> A = B.

Section 等号.
  Variable Mother : Type.

  Lemma rfl_eqS (A : mySet Mother) : A = A.
  Proof. by []. Qed.

  Lemma sym_eqS (A B : mySet Mother) : A = B -> B = A.
  Proof.
    move=> HAB.
      by rewrite HAB.
  Qed.

  (* ここでは、まだ公理は使っていない。 *)
End 等号.

(* 5.3 集合上の演算 *)

Definition myComplement {M : Type} (A : mySet M) : mySet M := fun (x : M) => ~(A x).
Notation "A ^c" := (myComplement A) (at level 11).

Definition myCup {M : Type} (A B : mySet M) : mySet M := fun (x : M) => x ∈ A \/ x ∈ B.
Notation "A ∪ B" := (myCup A B) (at level 11).

Section 演算.
  Variable M : Type.

  (* 追加 *)
  Lemma complement_test x (A : mySet M) : ~ (x ∈ A) <-> x ∈ (A ^c).
  Proof.
    rewrite /myComplement /belong.
    done.
  Qed.
  (* 追加終わり。 *)
  Lemma cEmpty_Mother : (@myEmptySet M)^c = (@myMotherSet M).
  Proof.
    apply: axiom_ExteqmySet.                (* 公理を使用する。 *)
    rewrite /eqmySet.                       (* 省略可能 *)
    split=> x HxM.
    (* Goal : x ∈ myMotherSet *)
    - rewrite /belong.
      done.

    (* Goal : ~ (x ∈ myEmptySet) *)
    - rewrite /myComplement.
      apply/complement_test.                (* 省略可能 *)
      done.

    Restart.
    apply: axiom_ExteqmySet.                (* 公理を使用する。 *)
      by apply: conj; rewrite /myComplement => x HxM.
  Qed.

  Lemma cc_cancel (A : mySet M) : (A^c)^c = A.
  Proof.
    apply: axiom_ExteqmySet.                (* 公理を使用する。 *)
    rewrite /eqmySet.
    by apply: conj; rewrite /myComplement => x H;
       case: (axiom_mySet A x) => HxA.

    Restart.

    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    rewrite /myComplement.
    rewrite /mySub.
    split=> x H.

    Check (axiom_mySet A x) : x ∈ A \/ ~(x ∈ A).

    - case: (axiom_mySet A x) => HxA.
      (* HxA : x∈A の 場合 *)
      + done.
      (* HxA : ~x∈A の 場合 *)
      + Check H HxA : False.
        move/H in HxA.                      (* HxA : False で矛盾 *)
        done.

    - case: (axiom_mySet A x) => HxA.
      (* HxA : x∈A の 場合 *)
      + move=> Hnot_xA.                     (* 二重否定を除去する。 *)
        apply: Hnot_xA.
          by apply: HxA.
      (* HxA : ~x∈A の 場合 *)
      + done.                               (* x∈A かつ ~x ∈ A  で矛盾 *)
  Qed.

  Lemma cMotehr_Empty : (@myMotherSet M)^c = myEmptySet.
  Proof.
      by rewrite -cEmpty_Mother cc_cancel.

      Restart.
    rewrite -cEmpty_Mother.
    rewrite cc_cancel.
    done.
  Qed.

  Lemma myCupA (A B C : mySet M) : (A ∪ B) ∪ C = A ∪ (B ∪ C).
  Proof.
    apply: axiom_ExteqmySet.
    rewrite /eqmySet.
    split=> x [H | H].
    - case: H => H.
      + by left.
      + by right; left.
    - by right; right.
    - by left; left.
    - case: H => H.
      + by left; right.
      + by right.
  Qed.

  Lemma myUnionCompMother (A : mySet M) : A ∪ (A^c) = myMotherSet.
  Proof.
    apply: axiom_ExteqmySet.
(*  rewrite /eqmySet /myComplement /myMotherSet /myCup. *)
    split => [x | x H].
    (* (A ∪ (A ^c)) ⊂ myMotherSet *)
    - done.

    (* (A ∪ (A ^c)) ⊃ myMothearSet*)
    - case: (axiom_mySet A x) => H'.        (* ; by [left | right] *)
      (* H' : x ∈ A  *)
      + left.
      (* Goal : x ∈ A *)
        done.

      (* H' : ~ (x ∈ A) *)
      + right.
        (* Goal : x ∈ (A ^c) *)
        done.
  Qed.
End 演算.

(* 5.4 集合間の写像 *)

Definition myMap {M1 M2 : Type} (A : mySet M1) (B : mySet M2) (f : M1 -> M2) :=
  forall (x : M1), x ∈ A -> f x ∈ B.
Notation "f ∈Map A \to B" := (myMap A B f) (at level 11).

Definition MapCompo {M1 M2 M3 : Type} (f : M2 -> M3) (g : M1 -> M2) : M1 -> M3 :=
  fun (x : M1) => f (g x).
Notation "f ● g" := (MapCompo f g) (at level 11).

(* 定義域Xの像Y *)
(* これだと、部分集合の像を扱うのが難しいので、問5.2を解くためには使わない。 *)
Definition ImgOf {M1 M2 : Type} (f : M1 -> M2) {X : mySet M1} {Y : mySet M2}
           (_ : f ∈Map X \to Y) : mySet M2 :=
  fun (y : M2) => exists (x : M1), y = f x /\ x ∈ X.

(* 定義域Xの部分集合Aの像B @morita_hm - Bについては全射であること。 *)
(* 問5.2のために、部分集合の像を定義するために、定義した。 *)
Definition ImgOfSub {M1 M2 : Type} (f : M1 -> M2) {X : mySet M1} {Y : mySet M2}
           (_ : f ∈Map X \to Y) (A : mySet M1) : mySet M2 :=
  (*                             ~~~~~~~~~~~~~~   ~~~~~~~ *)
  fun (y : M2) => exists (x : M1), y = f x /\ x ∈ A /\ A ⊂ X.

(* 値域Yの部分集合Bの逆像A @morita_hm - Bについては全射であること。 *)
(* 問5.3のために、部分集合の逆像を定義するために、定義した。 *)
Definition InvImgOfSub {M1 M2 : Type} (f : M1 -> M2) {X : mySet M1} {Y : mySet M2}
           (_ : f ∈Map X \to Y) (B : mySet M2) : mySet M1 :=
  (*                             ~~~~~~~~~~~~~~   ~~~~~~~ *)
  fun (x : M1) => exists (y : M2), y = f x /\ y ∈ B /\ B ⊂ Y.

(* 単射 *)
Definition mySetInj {M1 M2 : Type} (f : M1 -> M2) {A : mySet M1} {B : mySet M2}
           (_ : f ∈Map A \to B) : Prop :=
  forall (x y : M1), x ∈ A -> y ∈ A -> f x = f y -> x = y.

(* 全射 *)
Definition mySetSur {M1 M2 : Type} (f : M1 -> M2) {A : mySet M1} {B : mySet M2}
           (_ : f ∈Map A \to B) : Prop :=
  forall (y : M2), y ∈ B -> exists (x : M1), x ∈ A -> f x = y.

(* 全単射 *)
Definition mySetBi {M1 M2 : Type} (f : M1 -> M2) {A : mySet M1} {B : mySet M2}
           (fAB : f ∈Map A \to B) : Prop :=
  mySetInj fAB /\ mySetSur fAB.

Section 写像.
  Variable M1 M2 M3 : Type.
  Variable f : M2 -> M3.
  Variable g : M1 -> M2.
  Variable A : mySet M1.
  Variable B : mySet M2.
  Variable C : mySet M3.
  Hypothesis gAB : g ∈Map A \to B.
  Hypothesis fBC : f ∈Map B \to C.

  Lemma transitive_Inj (fgAC : (f ● g) ∈Map A \to C) :
    mySetInj fBC -> mySetInj gAB -> mySetInj fgAC.
  Proof.
    rewrite /mySetInj => Hinjf Hinjg x y HxA HyA H.
    Check Hinjg x y HxA HyA.
    Check Hinjf (g x) (g y) (gAB HxA) (gAB HyA).
    apply: Hinjg.
    - done.
    - done.
      apply: Hinjf.
      + by apply: gAB.
      + by apply: gAB.
      + by apply: H.
  Qed.

  Lemma CompoTrans : (f ● g) ∈Map A \to C.
  Proof.
    move: gAB fBC.
    rewrite /MapCompo /myMap => Hab Hbc t Ha.
    apply: Hbc.
    apply: Hab.
    apply: Ha.
  Qed.

  Lemma ImSub : (ImgOf gAB) ⊂ B.
  Proof.
    rewrite /ImgOf => t.
    case=> x.
    case=> H1 H2.
    rewrite H1.
      by apply: gAB.
  Qed.
End 写像.

(* END *)


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job.
Require Import prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.arrival.jitter.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path.

(* In this file, we provide definitions and lemmas about task arrivals
   in jitter-aware schedules. *)
Module TaskArrivalWithJitter.

  Import ArrivalSequenceWithJitter SporadicTaskset.
  Export TaskArrival.

  (* First, we identify the arrivals of a particular task. *)
  Section NumberOfArrivals.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and recall the list of jobs with actual arrival time in a given interval. *)
    Let arrivals_between := actual_arrivals_between job_arrival job_jitter arr_seq.

    (* Next, let tsk be any task. *)
    Variable tsk: Task.

    (* By checking the jobs spawned by tsk... *)
    Definition is_job_of_tsk := is_job_of_task job_task tsk.

    (* ...we identify the jobs of tsk that arrived in any interval [t1, t2) ... *)
    Definition actual_arrivals_of_task_between (t1 t2: time) :=
      [seq j <- arrivals_between t1 t2 | is_job_of_tsk j].

    (* ...and also count the number of such job arrivals. *)
    Definition num_actual_arrivals_of_task (t1 t2: time) :=
      size (actual_arrivals_of_task_between t1 t2).

  End NumberOfArrivals.

  (* Next, we prove properties about lists of actual arrivals
     that are sorted by arrival time. *)
  Section DistanceBetweenSporadicJobs.

    Context {Task: eqType}.
    Variable task_period: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence with consistent, duplicate-free arrivals, ... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_consistent_arrivals: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* ...where jobs are sporadic. *)
    Hypothesis H_sporadic_jobs:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* For simplicity, let's define some local names. *)
    Let actual_job_arrival := actual_arrival job_arrival job_jitter.

    (* Next, let tsk be any task to be scheduled. *)
    Variable tsk: Task.

    (* Consider any time interval [t1, t2)... *)
    Variable t1 t2: time.

    (* ...and the associated actual arrivals of task tsk. *)
    Let arriving_jobs := actual_arrivals_of_task_between job_arrival job_jitter
                                                         job_task arr_seq tsk t1 t2.
    Let num_arrivals := num_actual_arrivals_of_task job_arrival job_jitter job_task arr_seq tsk t1 t2.

    (* Then, consider the sequence of such jobs ordered by arrival times... *)
    Let by_arrival_time j j' := job_arrival j <= job_arrival j'.
    Let sorted_jobs := sort by_arrival_time arriving_jobs.

    (* ...and let (nth_job i) denote the i-th job in the sorted sequence. *)
    Variable elem: Job.
    Let nth_job := nth elem sorted_jobs.

    (* First, we recall some trivial properties about nth_job. *)
    Remark sorted_arrivals_properties_of_nth:
      forall idx,
        idx < num_arrivals ->
        t1 <= actual_job_arrival (nth_job idx) < t2 /\
        job_task (nth_job idx) = tsk /\
        arrives_in arr_seq (nth_job idx).
    Proof.
      intros idx LTidx.
      have IN: nth_job idx \in sorted_jobs by rewrite mem_nth // size_sort.
      rewrite mem_sort mem_filter in IN.
      move: IN => /andP [JOB IN]; move: (IN) => LT.
      apply in_actual_arrivals_between_implies_arrived in IN.
      eapply in_actual_arrivals_implies_arrived_between in LT.
      by repeat split; try (by done); apply/eqP.
    Qed.

    (* Next, we conclude that consecutive jobs are different. *)
    Lemma sorted_arrivals_current_differs_from_next:
      forall idx,
        idx < num_arrivals.-1 ->
        nth_job idx <> nth_job idx.+1.
    Proof.
      intros idx LT; apply/eqP.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      rewrite nth_uniq ?size_sort /arriving_jobs
              -/(num_actual_arrivals_of_task _ _ _ _ _ _ _) -/num_arrivals;
        first by rewrite neq_ltn ltnSn orTb.
      - by apply leq_trans with (n := n.+1); last by rewrite EQ.
      - by rewrite EQ ltnS.
      - by rewrite sort_uniq filter_uniq //; apply actual_arrivals_uniq; eauto 1.
    Qed.

    (* Since the list is sorted, we prove that each job arrives at
       least (task_period tsk) time units after the previous job. *)
    Lemma sorted_arrivals_separated_by_period:
      forall idx,
        idx < num_arrivals.-1 ->
        job_arrival (nth_job idx.+1) >= job_arrival (nth_job idx) + task_period tsk.
    Proof.
      have NTH := sorted_arrivals_properties_of_nth.
      have NEQ := sorted_arrivals_current_differs_from_next.
      rename H_sporadic_jobs into SPO.
      intros idx LT.
      destruct num_arrivals eqn:EQ; first by rewrite ltn0 in LT.
      destruct n; [by rewrite ltn0 in LT | simpl in LT].
      exploit (NTH idx);
        [by apply leq_trans with (n := n.+1) | intro NTH1].
      exploit (NTH idx.+1); [by rewrite ltnS | intro NTH2].
      move: NTH1 NTH2 => [_ [JOB1 ARR1]] [_ [JOB2 ARR2]].
      rewrite -JOB1.
      apply SPO; try (by done); [by apply NEQ | by rewrite JOB1 JOB2 |].
      suff ORDERED: by_arrival_time (nth_job idx) (nth_job idx.+1) by done.
      apply sort_ordered;
        first by apply sort_sorted; intros x y; apply leq_total.
      rewrite size_sort.
      rewrite /arriving_jobs -/(num_actual_arrivals_of_task _ _ _ _ _ _ _) -/num_arrivals.
      by rewrite EQ.
    Qed.

    (* If the list of arrivals is not empty, we analyze the distance between
       the first and last jobs. *)
    Section FirstAndLastJobs.

      (* Suppose that there is at least one job, ... *)
      Hypothesis H_at_least_one_job:
        num_arrivals >= 1.

      (* ...in which case we identify the first and last jobs and their
         respective arrival times (note that they could be the same job). *)
      Let j_first := nth_job 0.
      Let j_last := nth_job (num_arrivals.-1).
      Let a_first := job_arrival j_first.
      Let a_last := job_arrival j_last.

      (* By induction, we prove that that each job with index 'idx' arrives at
         least idx*(task_period tsk) units after the first job. *)
      Lemma sorted_arrivals_distance_from_first_job:
        forall idx,
          idx < num_arrivals ->
          job_arrival (nth_job idx) >= a_first + idx * task_period tsk.
      Proof.
        have SEP := sorted_arrivals_separated_by_period.
        unfold sporadic_task_model in *.
        rename H_sporadic_jobs into SPO.
        induction idx; first by intros _; rewrite mul0n addn0.
        intros LT.
        have LT': idx < num_arrivals by apply leq_ltn_trans with (n := idx.+1).
        specialize (IHidx LT').
        apply leq_trans with (n := job_arrival (nth_job idx) + task_period tsk);
          first by rewrite mulSn [task_period _ + _]addnC addnA leq_add2r.
        apply SEP.
        by rewrite -(ltn_add2r 1) 2!addn1 (ltn_predK LT).
      Qed.

      (* Therefore, the first and last jobs are separated by at least
         (num_arrivals - 1) periods. *)
      Corollary sorted_arrivals_distance_between_first_and_last:
        a_last >= a_first + (num_arrivals-1) * task_period tsk.
      Proof.
        rename H_at_least_one_job into TWO.
        have DIST := sorted_arrivals_distance_from_first_job.
        rewrite subn1; apply DIST.
        by destruct num_arrivals; first by rewrite ltn0 in TWO.
      Qed.

    End FirstAndLastJobs.

  End DistanceBetweenSporadicJobs.

End TaskArrivalWithJitter.


From Coq Require Import ZArith.ZArith.

From VST Require Import floyd.proofauto.

From CertiGraph Require Import lib.List_ext.

From CertiGC Require Import model.heapgraph.block.ptr.
From CertiGC Require Import model.heapgraph.graph.
From CertiGC Require Import model.util.

Local Open Scope Z.

Definition root_t : Type := Z + GC_Pointer + Addr.

#[global]Instance root_t_inhabitant : (Inhabitant root_t) := (inl (inl Z.zero)).

Definition root2val (g : HeapGraph)
  (fd : root_t) : val :=
  match fd with
  | inl (inl z) => odd_Z2val z
  | inl (inr p) => GC_Pointer2val p
  | inr v => heapgraph_block_ptr g v
  end.

Definition roots_t : Type := list root_t.

Lemma root_in_outlier :
  forall (roots : roots_t) outlier p,
  In (inl (inr p)) roots -> incl (filter_sum_right (filter_sum_left roots)) outlier -> In p outlier.
Proof.
  (intros).
  (apply H0).
  (rewrite <- filter_sum_right_In_iff, <- filter_sum_left_In_iff).
  assumption.
Qed.

Definition roots_have_no_gen (roots : roots_t) (gen : nat) : Prop := forall v, In (inr v) roots -> addr_gen v <> gen.

Definition outlier_t : Type := list GC_Pointer.


Require Import LL.PLL.CutLElimination.
Require Import LL.PLL.CutCElimination.
Require Import LL.PLL.Tactics.
Set Implicit Arguments.

Section CutElimination.

 Theorem CutElimination i j C A B M N:
      (LL2 i |-- B; C::M -> LL2 j |-- B; (dual C)::N -> LL2 |-- B; M ++ N) /\
      (S (complexity A) = complexity C ->
      LL2 i |-- A::B ; M -> LL2 j |-- B;(! (dual A))::N -> LL2 |-- B; M ++ N).
  Proof with sauto.
    assert(exists w, complexity C = w).
    eexists; auto.
    destruct H as [w H].
    revert H.
    revert i j C A B M N.
    induction w using lt_wf_ind; intros.
    remember (plus i j) as h.
      revert dependent B.
      revert dependent M.
      revert dependent N.
      revert dependent A.
      revert dependent C.

      revert dependent i.
      revert j.
      induction h using lt_wf_ind; intros.
      rename H into CutW.
      rename H0 into CutH.
      rename H1 into compC.

        move B at top.
        move M at top.
        move N at top.
        move C at top.
        move A at top.
        subst.
        rename C into P.
         rename A into Q.
        rename i into a.
        rename j into b.

        split;intros.
       *  eapply (@CutL a b P M N)...
          unfold Tactics.CutH; intros.
          eapply CutH with (m:=i+j)...
          unfold Tactics.CutW; intros.
          eapply CutW with (m:=complexity C)...
        * eapply (@CutC a b P Q M N)...
          unfold Tactics.CutH; intros.
          eapply CutH with (m:=i+j)...
          unfold Tactics.CutW; intros.
          eapply CutW with (m:=complexity C)...
Qed.

 Theorem CutLL2 i j C B M N:
     LL2 i |-- B; C::M ->
     LL2 j |-- B; (dual C)::N ->
     LL2 |-- B; M ++ N.
 Proof.
    eapply CutElimination;auto.
 Qed.

 Theorem CutLL2' C B M N:
     LL2  |-- B; C::M ->
     LL2 |-- B; (dual C)::N ->
     LL2 |-- B; M ++ N.
 Proof with sauto.
   intros.
   apply LL2StoLL2N in H, H0...
   refine (CutLL2 H H0).
 Qed.

Section Application.

(******************************************************)
(*                    INVERTIBILITY: RULE BOT                     *)
(******************************************************)

Lemma invertibility_bot : forall B M, LL2S B  (Bot::M) -> LL2S B  M.
Proof with simpl;auto.
  intros.
  eapply CutLL2' with (C:=One) (M:=[]) (N:=M)...
Qed.

(*******************************************************)
(*                    INVERTIBILITY: RULE PAR                      *)
(*******************************************************)

Lemma invertibility_par : forall B M F G,
                            LL2S B  (F ⅋ G::M) -> LL2S B  (F::G::M).
Proof with simpl;auto.
  intros.
  assert(LL2 |-- B; M ++ [F; G]).
  eapply CutLL2' with (C:=F ⅋ G) (M:=M) (N:=[F;G])...
  LL2tensor (dual F) (dual G) [F] [G].
  1-2: rewrite perm_takeit_8.
  1-2: apply LL2initGen...
rewrite Permutation_app_comm in H0...
Qed.

(********************************************************)
(*                    INVERTIBILITY: RULE QUEST                    *)
(********************************************************)

Lemma invertibility_store : forall B M F,
                            LL2S B  (? F::M) -> LL2S (F::B)  M.
Proof with simpl;auto.
  intros.
  eapply CutLL2' with (C:=! (dual F)) (M:=[]) (N:=M)...
  constructor.
  LL2copy F...
  apply LL2initGen...
  rewrite <- ng_involutive.
  apply LL2weakening...
Qed.

(********************************************************)
(*                    INVERTIBILITY: RULE WITH                     *)
(********************************************************)

Lemma invertibility_with : forall B M F G,
     LL2S B (F & G::M) -> LL2S B (F::M) /\ LL2S B (G::M).
Proof with simpl;sauto.
  intros...
  - assert(LL2 |-- B; M ++ [F]).
    eapply CutLL2' with (C:=F & G) (M:=M) (N:=[F])...
   LL2plus1 (dual F) (dual G) [F].
   rewrite perm_takeit_8.
   apply LL2initGen...
   rewrite Permutation_app_comm in H0...
  - assert(LL2 |-- B; M ++ [G]).
    eapply CutLL2' with (C:=F & G) (M:=M) (N:=[G])...
   LL2plus2 (dual F) (dual G) [G].
   rewrite perm_takeit_8.
   apply LL2initGen...
   rewrite Permutation_app_comm in H0...
Qed.

(********************************************************)
(*                    INVERTIBILITY: RULE BANG                     *)
(********************************************************)

Lemma invertibility_bang : forall B F,
     LL2S B [! F] -> LL2S B [F].
Proof with simpl;sauto.
  intros...
  - assert(LL2 |-- B; [] ++ [F]).
    eapply CutLL2' with (C:= ! F) (M:=[]) (N:=[F])...
    LL2store (dual F) [F].
    LL2copy (dual F)...
   rewrite perm_takeit_8.
   apply LL2initGen...
   rewrite Permutation_app_comm in H0...
Qed.

End Application.
End CutElimination.


From Coq Require Import NArith ZArith Lia String HexString.

From Vyper Require Import Config Calldag.
From Vyper.L30 Require Import AST Callset Descend VarCap.

From Vyper.CheckArith Require Import Builtins CheckedArith.

Definition arithmetic_error
:= Z.of_N
     (List.fold_left (fun x y => N.lor (N.shiftl x 8) y)
       (List.map Ascii.N_of_ascii (list_ascii_of_string "arithmetic error"))
       0%N).

Example hex_arithmetic_error:
  HexString.of_Z arithmetic_error = "0x61726974686d65746963206572726f72"%string.
                                    (*  a r i t h m e t i c   e r r o r *)
Proof. trivial. Qed.

(** AST for [dst = "arithmetic error"; raise dst] *)
Definition ast_raise_arithmetic_error {C: VyperConfig} (dst: N)
: stmt
:= Semicolon (SmallStmt (Const dst (uint256_of_Z arithmetic_error)))
             (SmallStmt (Raise dst)).

(** AST for [scratch[0] = a; scratch[1] = b] *)
Definition ast_pair_to_scratch {C: VyperConfig} (a b: N) (scratch: N)
: stmt
:= Semicolon (SmallStmt (Copy scratch a))
             (SmallStmt (Copy (N.succ scratch) b)).

Definition translate_small_stmt {C: VyperConfig} (B: builtin_names_config)
                                (scratch: N)
                                (ss: small_stmt)
: stmt
:= match ss with
   | UnOp op dst src =>
      match op with
      | L10.AST.BitwiseNot =>
          SmallStmt (BuiltinCall dst (builtin_name_uint256_not B) src 1%N)
      | L10.AST.LogicalNot =>
          SmallStmt (BuiltinCall dst (builtin_name_uint256_iszero B) src 1%N)
      | L10.AST.Neg =>
          (* if src:
               scratch = "arithmetic error"
               raise scratch
             else:
               dst = 0
           *)
          (IfElseStmt src
            (ast_raise_arithmetic_error scratch)
            (SmallStmt (Const dst zero256)))
      end
   | BinOp op dst a b NEpow =>
      match op as op' return op = op' -> _ with
      | L10.AST.BitwiseAnd => fun _ =>
          Semicolon (ast_pair_to_scratch a b scratch)
            (SmallStmt (BuiltinCall dst (builtin_name_uint256_and B) scratch 2%N))
      | L10.AST.BitwiseOr => fun _ =>
          Semicolon (ast_pair_to_scratch a b scratch)
                    (SmallStmt (BuiltinCall dst (builtin_name_uint256_or B) scratch 2%N))
      | L10.AST.BitwiseXor => fun _ =>
          Semicolon (ast_pair_to_scratch a b scratch)
                    (SmallStmt (BuiltinCall dst (builtin_name_uint256_xor B) scratch 2%N))
      | L10.AST.Lt => fun _ =>
          Semicolon (ast_pair_to_scratch a b scratch)
                    (SmallStmt (BuiltinCall dst (builtin_name_uint256_lt B) scratch 2%N))
      | L10.AST.Gt => fun _ =>
          Semicolon (ast_pair_to_scratch b a scratch)
                    (SmallStmt (BuiltinCall dst (builtin_name_uint256_lt B) scratch 2%N))
      | L10.AST.Eq => fun _ =>
          Semicolon (ast_pair_to_scratch a b scratch)
                    (SmallStmt (BuiltinCall dst (builtin_name_uint256_eq B) scratch 2%N))
      | L10.AST.Ne => fun _ =>
          Semicolon
            (ast_pair_to_scratch a b scratch)
            (Semicolon
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_eq B) scratch 2%N))
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_iszero B) dst 1%N)))
      | L10.AST.Ge => fun _ =>
          Semicolon
            (ast_pair_to_scratch a b scratch)
            (Semicolon
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_lt B) scratch 2%N))
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_iszero B) dst 1%N)))
      | L10.AST.Le => fun _ =>
          Semicolon
            (ast_pair_to_scratch b a scratch)
            (Semicolon
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_lt B) scratch 2%N))
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_iszero B) dst 1%N)))
      | L10.AST.Add => fun _ =>
          (*
            scratch[0] = a                                     # a
            scratch[1] = b                                     # a           b
            scratch[1] = builtin("uint256_add", scratch, 2)    # a           a + b
            scratch[2] = a                                     # a           a + b      a
            scratch[0] = builtin("uint256_lt", scratch1, 2)    # a + b < a   a + b      a
            if scratch[0]:
              raise "arithmetic error"
            else:
              dst = scratch[1]
          *)
          Semicolon
            (ast_pair_to_scratch a b scratch)
            (Semicolon
              (SmallStmt (BuiltinCall (N.succ scratch)
                                      (builtin_name_uint256_add B)
                                      scratch 2%N))
              (Semicolon
                (SmallStmt (Copy (scratch + 2)%N a))
                (Semicolon
                  (SmallStmt (BuiltinCall scratch
                                          (builtin_name_uint256_lt B)
                                          (N.succ scratch) 2%N))
                  (IfElseStmt scratch
                    (ast_raise_arithmetic_error scratch)
                    (SmallStmt (Copy dst (N.succ scratch)))))))
      | L10.AST.Sub => fun _ =>
          (*
             scratch0 = a
             scratch1 = b
             scratch2 = builtin("uint256_lt", scratch, 2)
             if scratch2:
               raise "arithmetic error"
             else:
               dst = builtin("uint256_sub", scratch, 2)
          *)
          Semicolon
            (ast_pair_to_scratch a b scratch)
            (Semicolon
              (SmallStmt (BuiltinCall (scratch + 2)%N (builtin_name_uint256_lt B) scratch 2%N))
              (IfElseStmt (scratch + 2)%N
                (ast_raise_arithmetic_error scratch)
                (SmallStmt (BuiltinCall dst (builtin_name_uint256_sub B) scratch 2))))
      | L10.AST.Mul => fun _ =>
          (*
             if a:
               scratch1 = a                                    #       a
               scratch2 = b                                    #       a         b
               scratch0 = builtin("uint256_mul", scratch1, 2)  # a*b   a         b
               scratch1 = builtin("uint256_div", scratch0, 2)  # a*b   a*b/a     b
               scratch1 = builtin("uint256_eq",  scratch1, 2)  # a*b   a*b/a==b  b
               if scratch1:
                 dst = scratch0
               else:
                 raise "arithmetic error"
             else:
               dst = 0
          *)
          IfElseStmt a
            (Semicolon
               (ast_pair_to_scratch a b (N.succ scratch))
               (Semicolon
                 (Semicolon
                   (SmallStmt (BuiltinCall scratch (builtin_name_uint256_mul B)
                                           (N.succ scratch) 2%N))
                   (Semicolon
                     (SmallStmt (BuiltinCall (N.succ scratch) (builtin_name_uint256_div B)
                                             scratch 2%N))
                     (SmallStmt (BuiltinCall (N.succ scratch) (builtin_name_uint256_eq B)
                                             (N.succ scratch) 2%N))))
                 (IfElseStmt (N.succ scratch)
                   (SmallStmt (Copy dst scratch))
                   (ast_raise_arithmetic_error scratch))))
            (SmallStmt (Const dst zero256))
      | L10.AST.Quot => fun _ =>
          (*
             if b:
               scratch[0] = a
               scratch[1] = b
               dst = builtin("uint256_div",  scratch1, 2)
             else
               raise "arithmetic error"
          *)
          IfElseStmt b
            (Semicolon
              (ast_pair_to_scratch a b scratch)
              (SmallStmt (BuiltinCall dst (builtin_name_uint256_div B) scratch 2%N)))
            (ast_raise_arithmetic_error scratch)
      | L10.AST.Mod => fun _ =>
          (*
             if b:
               scratch[0] = a
               scratch[1] = b
               dst = builtin("uint256_mod",  scratch1, 2)
             else
               raise "arithmetic error"
          *)
          IfElseStmt b
                (Semicolon
                  (ast_pair_to_scratch a b scratch)
                  (SmallStmt (BuiltinCall dst (builtin_name_uint256_mod B) scratch 2%N)))
                (ast_raise_arithmetic_error scratch)
      | L10.AST.ShiftRight => fun _ =>
          Semicolon
                (ast_pair_to_scratch a b scratch)
                (SmallStmt (BuiltinCall dst (builtin_name_uint256_shr B) scratch 2%N))
      | L10.AST.ShiftLeft => fun _ =>
          (*
             scratch0 = a                                   #    a
             scratch1 = b                                   #    a            b
             scratch0 = builtin("uint256_shl", scratch, 2)  #    a<<b         b
             scratch1 = builtin("uint256_shr", scratch, 2)  #    a<<b         (a<<b)>>b
             # I had originally written this:
             #   dst = scratch0
             #   scratch0 = a                               #    a            (a<<b)>>b
             # But Coq rejected it because dst may be aliased with a here.
             # Here's the correct code:
             scratch2 = a                                   #    a<<b         (a<<b)>>b    a
             scratch1 = builtin("uint256_eq", scratch1, 2)  #    (a<<b)>>b==a (a<<b)>>b    a
             if scratch1:
               dst = scratch0
             else:
               raise "arithmetic error"
          *)
          Semicolon
             (ast_pair_to_scratch a b scratch)
             (Semicolon
               (SmallStmt (BuiltinCall scratch (builtin_name_uint256_shl B) scratch 2%N))
               (Semicolon
                 (SmallStmt (BuiltinCall (N.succ scratch) (builtin_name_uint256_shr B)
                                         scratch 2%N))
                 (Semicolon
                   (SmallStmt (Copy (scratch + 2)%N a))
                     (Semicolon
                       (SmallStmt (BuiltinCall (N.succ scratch) (builtin_name_uint256_eq B)
                                               (N.succ scratch) 2%N))
                       (IfElseStmt (N.succ scratch)
                         (SmallStmt (Copy dst scratch))
                         (ast_raise_arithmetic_error scratch))))))
      | L10.AST.Pow => fun E => False_rect _ (NEpow E)
      end eq_refl
   | PowConstBase dst base exp =>
       let zbase := Z_of_uint256 base in
       if (zbase =? 0)%Z
         then (* iszero(exp) *)
              SmallStmt (BuiltinCall dst (builtin_name_uint256_iszero B) exp 1%N)
         else
           if (zbase =? 1)%Z
             then SmallStmt (Const dst one256) (* 1 *)
             else
               if (zbase =? 2)%Z
                 then (* scratch1 = exp
                         scratch2 = 256
                         scratch2 = builtin("uint256_lt", scratch1, 2)
                         if scratch2:
                           scratch0 = 1
                           dst = builtin("uint256_shl", scratch0, 2)
                         else:
                           raise "arithmetic error"
                      *)
                      Semicolon
                        (SmallStmt (Copy (N.succ scratch) exp))
                        (Semicolon
                          (SmallStmt (Const (scratch + 2)%N (uint256_of_Z 256%Z)))
                          (Semicolon
                            (SmallStmt (BuiltinCall (scratch + 2)%N
                                                    (builtin_name_uint256_lt B)
                                                    (N.succ scratch) 2%N))
                            (IfElseStmt (scratch + 2)%N
                              (Semicolon
                                (SmallStmt (Const scratch one256))
                                (SmallStmt (BuiltinCall dst
                                                        (builtin_name_uint256_shl B)
                                                        scratch 2%N)))
                              (ast_raise_arithmetic_error scratch))))
                 else (*
                         scratch0 = uint256_max_power base
                         scratch1 = exp
                         scratch2 = builtin("uint256_lt", scratch, 2)
                         if scratch2:
                           raise "arithmetic error"
                         else:
                           scratch0 = base
                           dst = builtin("uint256_pow", scratch, 2)
                      *)
                      Semicolon
                        (SmallStmt (Const scratch
                                     (uint256_of_Z (uint256_max_power zbase))))
                        (Semicolon
                          (SmallStmt (Copy (N.succ scratch) exp))
                          (Semicolon
                            (SmallStmt (BuiltinCall (scratch + 2)%N (builtin_name_uint256_lt B)
                                                    scratch 2))
                            (IfElseStmt (scratch + 2)%N
                              (ast_raise_arithmetic_error scratch)
                              (Semicolon
                                (SmallStmt (Const scratch base))
                                (SmallStmt (BuiltinCall dst (builtin_name_uint256_pow B)
                                                        scratch 2))))))
   | PowConstExp dst base exp =>
      let zexp := Z_of_uint256 exp in
      if (zexp =? 0)%Z
        then SmallStmt (Const dst one256) (* 1 *)
        else
          if (zexp =? 1)%Z
            then (* we do actually have to compute base ** 1 to canonicalize uint256 *)
              Semicolon
                (SmallStmt (Copy scratch base))
                (Semicolon
                  (SmallStmt (Const (N.succ scratch) one256))
                  (SmallStmt (BuiltinCall dst (builtin_name_uint256_pow B)
                                          scratch 2)))
            else (*
                   scratch0 = base
                   scratch1 = uint256_max_base zexp + 1
                   scratch1 = builtin("uint256_lt", scratch, 2)
                   if scratch1:
                     scratch1 = exp
                     dst = builtin("uint256_pow", scratch, 2)
                   else:
                     raise "arithmetic error"
                 *)
             Semicolon
               (SmallStmt (Copy scratch base))
               (Semicolon
                 (SmallStmt (Const (N.succ scratch)
                                   (uint256_of_Z (Z.succ (uint256_max_base zexp)))))
                 (Semicolon
                   (SmallStmt (BuiltinCall (N.succ scratch) (builtin_name_uint256_lt B)
                                           scratch 2))
                   (IfElseStmt (N.succ scratch)
                     (Semicolon
                       (SmallStmt (Const (N.succ scratch) exp))
                       (SmallStmt (BuiltinCall dst (builtin_name_uint256_pow B)
                                               scratch 2)))
                     (ast_raise_arithmetic_error scratch))))
   | _ => SmallStmt ss
   end.

Fixpoint translate_stmt {C: VyperConfig} (B: builtin_names_config)
                        (scratch: N)
                        (s: stmt)
{struct s}
: stmt
:= match s with
   | SmallStmt ss => translate_small_stmt B scratch ss
   | IfElseStmt cond yes no => IfElseStmt cond (translate_stmt B scratch yes)
                                               (translate_stmt B scratch no)
   | Loop var count body => Loop var count (translate_stmt B scratch body)
   | Semicolon a b => Semicolon (translate_stmt B scratch a)
                                (translate_stmt B scratch b)
   end.

Definition translate_decl {C: VyperConfig} (B: builtin_names_config)
                          (d: decl)
: decl
:= match d with
   | StorageVarDecl var => d
   | FunDecl name arity body => FunDecl name arity (translate_stmt B (var_cap_stmt body) body)
   end.

Ltac rr := cbn; trivial;
           repeat rewrite FSet.union_ok;
           repeat rewrite FSet.empty_ok;
           trivial.

Lemma callset_translate_small_stmt {C: VyperConfig}
                                   (B: builtin_names_config)
                                   (scratch: N)
                                   (ss: small_stmt)
                                   (x: string):
  let _ := string_set_impl in
  FSet.has (stmt_callset (translate_small_stmt B scratch ss)) x
   =
  FSet.has (small_stmt_callset ss) x.
Proof.
cbn.
destruct ss; simpl; trivial. (* cbn hangs *)
{ (* UnOp *) destruct op; rr. }
{ (* PowConstBase *)
  destruct Z.eqb. { easy. }
  destruct Z.eqb. { easy. }
  destruct Z.eqb; rr.
}
{ (* PowConstExp *)
  destruct Z.eqb. { easy. }
  destruct Z.eqb; cbn; rr.
}
(* Binop *)
destruct op; simpl; rr.
contradiction.
Qed.

Lemma callset_translate_stmt {C: VyperConfig}
                             (B: builtin_names_config)
                             (scratch: N)
                             (s: stmt)
                             (x: string):
  let _ := string_set_impl in
  FSet.has (stmt_callset (translate_stmt B scratch s)) x
   =
  FSet.has (stmt_callset s) x.
Proof.
cbn.
induction s; cbn; try assumption.
{ (* SmallStmt *) apply callset_translate_small_stmt. }
1-2: repeat rewrite FSet.union_ok;
     rewrite IHs1; rewrite IHs2;
     trivial.
Qed.

Lemma callset_translate_decl {C: VyperConfig}
                             (B: builtin_names_config)
                             (d: decl)
                             (x: string):
  let _ := string_set_impl in
  FSet.has (decl_callset (translate_decl B d)) x
   =
  FSet.has (decl_callset d) x.
Proof.
destruct d; cbn. { easy. }
apply callset_translate_stmt.
Qed.

Local Lemma translate_calldag_helper {C: VyperConfig}
                                     (B: builtin_names_config)
                                     (cd: calldag):
  let H := string_set_impl in
  forall d: decl,
    FSet.is_subset (decl_callset (translate_decl B d)) (decl_callset d) = true.
Proof.
cbn. intro.
apply FSet.is_subset_equal.
apply FSet.equal_ok.
apply callset_translate_decl.
Qed.

Definition translate_calldag {C: VyperConfig}
                             (B: builtin_names_config)
                             (cd: calldag)
:= calldag_map (translate_decl B)
               (translate_calldag_helper B cd)
               cd.

Definition translate_fun_ctx {C: VyperConfig}
                             (B: builtin_names_config)
                             {bound: nat}
                             {cd: calldag}
                             (fc: fun_ctx cd bound)
: fun_ctx (calldag_map (translate_decl B) (translate_calldag_helper B cd) cd) bound
:= fun_ctx_map (translate_decl B) _ cd fc.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. lfind. Admitted.


Require Import Arith.
Require Import Compare_dec.

Require Import Axioms.
Require Import TypeSyntax.

Set Implicit Arguments.

Inductive ty_environment : nat -> Type :=
| ty_nil  : ty_environment 0
| ty_cons : forall i, Set -> ty_environment i -> ty_environment (S i).

Notation "A ;: e" := (ty_cons A e) (at level 61, right associativity).

Definition lookup : forall j i, j < i -> ty_environment i -> Set.
fix 1. intros. destruct j.
 destruct X.
  elimtype False. inversion H.
  apply P.
 destruct X.
  elimtype False. inversion H.
  apply (lookup j i).
   apply lt_S_n. apply H.
   apply X.
Defined.

Definition lookup_var : forall g, variable g -> ty_environment g -> Set.
intros g v e. destruct v as [g i l]. apply (lookup l e).
Defined.

Record preorder (W:Type) : Type := mkPorder
  { preorder_order  :> W -> W -> Prop
  ; preorder_refl   : forall x, preorder_order x x
  ; preorder_trans  : forall x y z, preorder_order x y -> preorder_order y z -> preorder_order x z
  }.

Definition kripke_relation (W:Type) (Worder:preorder W) (A B:Set) (R:W -> A -> B -> Prop) :=
  forall x y a b, Worder x y -> R x a b -> R y a b.

Definition w_eq := fun (W:Type) (A:Set) (w:W) (a b:A) => a = b.

Lemma w_eq_kripke : forall W (Worder:preorder W) A,
  kripke_relation Worder (@w_eq W A).
intros. unfold kripke_relation. unfold w_eq. auto.
Save.

Inductive rel_environment (W:Type) (Worder:preorder W) : forall n, ty_environment n -> ty_environment n -> Type :=
| rel_nil  : rel_environment Worder ty_nil ty_nil
| rel_cons : forall (n:nat) (A B:Set) (env1 env2:ty_environment n) (R:W -> A -> B -> Prop),
  kripke_relation Worder R ->
  rel_environment Worder env1 env2 ->
  rel_environment Worder (A;:env1) (B;:env2).

Notation "R ;; re" := (rel_cons R re) (at level 61, right associativity).

Definition rel_lookup : forall W (Worder:preorder W) i g (l : le (S i) g) e1 e2, rel_environment Worder e1 e2 ->
   W -> lookup l e1 -> lookup l e2 -> Prop.
induction i; intros.
 destruct X.
  elimtype False. inversion l.
  simpl in *. apply R; assumption.
 destruct X.
  elimtype False. inversion l.
  simpl in *. refine (IHi _ _ _ _ X X0 H H0).
Defined.

Lemma rel_lookup_kripke : forall W (Worder:preorder W) (i g : nat) (l:i < g) (e1 e2: ty_environment g) (re:rel_environment Worder e1 e2),
  kripke_relation Worder (rel_lookup l re).
induction i.
 intros. destruct re.
  inversion l.
  simpl in *. unfold kripke_relation. apply k.
 intros. destruct re.
  inversion l.
  simpl in *. unfold kripke_relation. unfold kripke_relation in IHi.
  intros. apply IHi with (l:=lt_S_n i n l) (e1:=env1) (e2:=env2) (re:=re) (x:=x) (y:=y) (a:=a) (b:=b).
   assumption.
   assumption.
Save.

Definition rel_lookup_var : forall W (Worder:preorder W) g (v : variable g) e1 e2, rel_environment Worder e1 e2 ->
  W -> lookup_var v e1 -> lookup_var v e2 -> Prop.
intros. destruct v as [g i l]. eapply rel_lookup.
 apply X. apply X0. apply H. apply H0.
Defined.

Lemma rel_lookup_var_kripke : forall W (Worder:preorder W) (g : nat) (v:variable g) (e1 e2: ty_environment g) (re:rel_environment Worder e1 e2),
  kripke_relation Worder (rel_lookup_var v re).
intros. destruct v. unfold rel_lookup_var.
unfold kripke_relation. apply rel_lookup_kripke.
Save.

Definition diagonal : forall W (Worder:preorder W) (g:nat) (e:ty_environment g), rel_environment Worder e e.
intros. induction e.
 constructor.
 apply rel_cons with (R:=@w_eq W P).
  apply w_eq_kripke.
  assumption.
Defined.

Definition ty_sem_rel (g:nat) (t:type g) :
  { ty_sem : ty_environment g -> Set
  & forall W (Worder:preorder W) (e1 e2 : ty_environment g), rel_environment Worder e1 e2 -> W -> ty_sem e1 -> ty_sem e2 -> Prop }.
induction t.
 (* ty_var *)
 exists (fun e => lookup_var v e).
 intros W Worder e1 e2 re w x1 x2.
 exact (rel_lookup_var v re w x1 x2).
 (* ty_arr *)
 exists (fun e => (projT1 IHt1) e -> (projT1 IHt2) e).
 intros W Worder e1 e2 R w f1 f2.
 exact (forall w' (x1 : projT1 IHt1 e1) (x2 : projT1 IHt1 e2),
               Worder w w' ->
               projT2 IHt1 W Worder e1 e2 R w' x1 x2 ->
               projT2 IHt2 W Worder e1 e2 R w' (f1 x1) (f2 x2)).
 (* ty_forall *)
 exists (fun e => { x : forall (A:Set), (projT1 IHt) (A;:e)
                  | forall W (Worder:preorder W) (A1 A2 : Set) (R : W -> A1 -> A2 -> Prop)
                           (Rkripke:kripke_relation Worder R)
                           w,
                        (projT2 IHt) W Worder (A1;:e) (A2;:e) (Rkripke;;diagonal Worder e) w (x A1) (x A2) }).
 intros W Worder e1 e2 re w x1 x2.
 exact (forall (A1 A2 : Set) (R : W -> A1 -> A2 -> Prop) (Rkripke:kripke_relation Worder R),
           projT2 IHt W Worder (A1;:e1) (A2;:e2) (Rkripke;;re) w (projT1 x1 A1) (projT1 x2 A2)).
Defined.

Definition ty_sem (g:nat) (e:ty_environment g) (t:type g) : Set.
apply (projT1 (ty_sem_rel t) e).
Defined.

Definition ty_rel W (Worder:preorder W) (g:nat) (e1 e2:ty_environment g) (re:rel_environment Worder e1 e2) (t:type g) :
   W -> ty_sem e1 t -> ty_sem e2 t -> Prop.
unfold ty_sem.
intros.
apply (projT2 (ty_sem_rel t) W Worder e1 e2 re X H H0).
Defined.

Lemma heredity : forall W (Worder:preorder W) (g:nat) (e1 e2:ty_environment g) (re:rel_environment Worder e1 e2) (ty:type g),
  kripke_relation Worder (ty_rel re ty).
intros. unfold ty_sem in *. unfold ty_rel in *. induction ty.
 (* ty_var *)
 simpl in *. apply rel_lookup_var_kripke.
 (* ty_arr *)
 simpl in *. unfold kripke_relation. intros.
 apply H0.
  apply (preorder_trans Worder) with (y:=y); assumption.
  apply H2.
 (* ty_forall *)
 simpl in *. unfold kripke_relation in *. intros.
 apply IHty with (x:=x).
  assumption.
  apply H0.
Save.

Lemma rel_lookup_diagonal : forall W (Worder:preorder W) g (e:ty_environment g) i (l:le (S i) g) x y w,
  rel_lookup l (diagonal Worder e) w x y <-> x = y.
induction e; intros; simpl in *.
 inversion l.
 destruct i0; simpl.
  reflexivity.
  apply IHe.
Save.

Lemma rel_lookup_var_diagonal : forall W (Worder:preorder W) g (e : ty_environment g) (v : variable g) x y w,
  rel_lookup_var v (diagonal Worder e) w x y <-> x = y.
intros. destruct v as [g i l]. simpl. apply rel_lookup_diagonal.
Save.

Lemma rel_diagonal : forall W (Worder:preorder W) g (e:ty_environment g) ty w x y,
  ty_rel (diagonal Worder e) ty w x y <-> x = y.
unfold ty_rel. unfold ty_sem. induction ty; simpl; intros.
 (* ty_var *)
 apply rel_lookup_var_diagonal.
 (* ty_arr *)
 split; intros.
  ext z. rewrite <- IHty2. apply H. apply (preorder_refl Worder). rewrite IHty1. reflexivity.
  rewrite IHty2. rewrite IHty1 in H1. subst. reflexivity.
 (* ty_forall *)
 destruct x as [x x_rel]. destruct y as [y y_rel]. simpl in *.
 split; intros.
  apply sig_eq. simpl. ext A. rewrite <- IHty. apply H.
  inversion H. subst. apply x_rel.
Save.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class SeparatingSemantics
      (L: Language)
      {SL: SeparationLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
{
  denote_sepcon: forall x y, Same_set _ (Kdenotation M (x * y)) (StrongSemantics.sepcon (Kdenotation M x) (Kdenotation M y));
  denote_wand: forall x y, Same_set _ (Kdenotation M (x -* y)) (WeakSemantics.wand (Kdenotation M x) (Kdenotation M y))
}.

Class EmpSemantics
      (L: Language)
      {sL: SeparationLanguage L}
      {s'L: SeparationEmpLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_emp: Same_set _ (Kdenotation M emp) WeakSemantics.emp.

Lemma sat_sepcon
      {L: Language}
      {sL: SeparationLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {dsSM: SeparatingSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x * y <->
    exists m0 m1 m2, m0 <= m /\
                     join m1 m2 m0 /\
                     KRIPKE: M , m1 |= x /\
                     KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_sepcon x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_wand
      {L: Language}
      {sL: SeparationLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {dsSM: SeparatingSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x -* y <->
    forall m1 m2, join m m1 m2 ->
                  KRIPKE: M , m1 |= x ->
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_wand x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_emp
      {L: Language}
      {sL: SeparationLanguage L}
      {s'L: SeparationEmpLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {deSM: EmpSemantics L MD M SM}:
  forall (m: Kworlds M), KRIPKE: M, m |= emp <-> increasing m.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_emp.
  split; [apply H | apply H0].
Qed.