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

Require Import Ascii.
(* option type *)

Inductive option (A : Set) : Set :=
  | Some : forall x : A, option A
  | None : option A.

Theorem SomeComp : forall (A : Set) (a b : A), a = b -> Some A a = Some A b.
intros A a b H'; rewrite H'; auto.
Qed.
Hint Resolve SomeComp.
(* Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.
(* Equality is decidable *)

Delimit Scope local_string_scope with string.
Bind Scope local_string_scope with string.

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.
(* Usual append function for string *)

Fixpoint append (s1 : string) : string -> string :=
  fun s2 : string =>
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (append s1' s2)
  end.
(* The number of character of a string *)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.
(* Return the nth character of a string *)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None _
  | String c s' => match n with
                   | O => Some _ c
                   | S n' => get n' s'
                   end
  end.
(* Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
 forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H1; auto.
Qed.
(* The first elements  of (append s1 s2) are the ones of s1 *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (append s1 s2).
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply Lt.lt_S_n; auto.
Qed.
(* The last elements  of (append s1 s2) are the ones of s2 *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (append s1 s2).
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite Plus.plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto.
intros n0; rewrite <- Plus.plus_Snm_nSm; auto.
Qed.
(* substring n m s returns the substring of s that starts
   at position n and of length m
   if this does not make sense it returns "" *)

Fixpoint substring (n m : nat) (s : string) {struct s} : string :=
  match n with
  | O =>
      match m with
      | O => EmptyString
      | S m' =>
          match s with
          | EmptyString => s
          | String c s' => String c (substring 0 m' s')
          end
      end
  | S n' =>
      match s with
      | EmptyString => s
      | String c s' => substring n' m s'
      end
  end.
(* The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.
(* The substring has at most m elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat),
 m <= p -> get p (substring n m s) = None _.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.
(* Check if s1 is a prefix of s2 *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.
(* if s1 is a prefix of s2 we can get s1 by a substring at position O of s2 *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.
(* Check if starting at position n s1 occurs in s2, if
   so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) {struct s2} :
 option nat :=
  match s2 with
  | EmptyString =>
      match n with
      | O =>
          match s1 with
          | EmptyString => Some _ 0
          | String a s1' => None nat
          end
      | S n' => None nat
      end
  | String b s2' =>
      match n with
      | O =>
          match prefix s1 s2 with
          | true => Some _ 0
          | false =>
              match index 0 s1 s2' with
              | Some n => Some _ (S n)
              | None => None nat
              end
          end
      | S n' =>
          match index n' s1 s2' with
          | Some n => Some _ (S n)
          | None => None nat
          end
      end
  end.
(* Dirty trick to evaluate locally that prefix reduces itself *)
Opaque prefix.
(* If the result of index is (Some m), s1 in s2 at position m *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some _ m -> substring m (length s1) s2 = s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; auto.
intros; discriminate.
Qed.
(* If the result of index is (Some m), s1 does not occur in s2 before m *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some _ m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.
(* If the result of index is None, s1 does not occur in s2 after n *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None _ ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.
(* Back to normal for prefix *)
Transparent prefix.
(* If we are searching for the Empty string and the answer is no
   this means that n is greater than the size of s *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None _ -> length s < n.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.
(* Same as index but with no optional type, we return O when it
   does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.


From Undecidability.L Require Export Enumerable InterpreterResults DecidableRecognisable Rice Por.

(** * Markov's principle *)

Lemma re_exists p : enumerable p -> enumerable (fun t => exists s : term, p (s t)).
Proof.
  intros (u & proc_u & spec_u & corr_u).
  exists (lambda (u 0 (lambda (0 (lambda none) (lambda (lambda (some 0))) (lambda none))) none)).
  repeat split; value.
  - intros n.  destruct (spec_u n).
    + left. solveeq.
    + destruct H as ([] & ? & ?).
      * left; solveeq.
      * right. exists t. split. solveeq. eauto.
      * left; solveeq.
  - intros s [t [n H] % corr_u]. exists n. solveeq.
Qed.

Lemma DA p : recognisable p -> recognisable (fun _ => exists t, p t).
Proof.
  intros. eapply enumerable_recognisable.
  change (enumerable (fun t => exists s, (fun x => match x with app s t => p s | _ => False end) (app s t))).
  eapply re_exists. eapply recognisable_enumerable.
  destruct H as (u & pu & Hu).
  pose (v := (lambda (0 (lambda Omega) (lambda (lambda (u 1))) (lambda Omega)))).
  exists v.
  split. subst v; value. destruct s; unfold pi.
  - assert (v (tenc n) ≡ Omega). solveeq. rewrite H. firstorder using eva_Omega.
  - assert (v (tenc (s1 s2)) ≡ u (tenc s1)). solveeq. now rewrite H, Hu.
  - assert (v (tenc (lambda s)) ≡ Omega). solveeq. rewrite H. firstorder using eva_Omega.
Qed.

Definition Markov_Post:= forall p, recognisable p -> recognisable (complement p) -> decidable p.
Definition Markov_Sat := forall p, decidable p -> (~~ exists t, p t) -> exists t, p t.
Definition Markov_Eva := forall s, closed s -> ~~ eva s -> eva s.

Lemma Markov_Post_to_Sat : Markov_Post -> Markov_Sat.
Proof.
  intros post p dec_p H.
  assert (recognisable (fun _ => exists t, p t)). {
    eapply DA. now eapply dec_recognisable. }
  assert (recognisable (fun _ => ~ exists t, p t)). {
    exists D. split; value. intros. firstorder using D_pi. }
  destruct (dec_pdec (post _ H0 H1) I); tauto.
Qed.

Lemma Markov_Sat_to_Eva : Markov_Sat -> Markov_Eva.
Proof.
  intros markov t cls_t Ht.
  pose (q := fun s => exists n, s = var n /\ eval n t <> None).

  assert (decp : decidable q). {
    exists (.\ "s" ; "s" (.\ "n" ; !E "n" !(tenc t) !(lambda T) !F) !(lambda (lambda F)) !(lambda F)).
    split; value. intros s.
    cbn. destruct s.
    - destruct (eval n t) eqn:Eq.
      + left. split. exists n; firstorder congruence. eapply evaluates_equiv; split; value.
        transitivity (E (enc n) (tenc t) (lambda T) F). solveeq. rewrite E_correct, Eq. solveeq.
      + right. split. intros (n' & Hn & E'). inv Hn. congruence. eapply evaluates_equiv; split; value.
        transitivity (E (enc n) (tenc t) (lambda T) F). solveeq. rewrite E_correct, Eq. solveeq.
    - right. split. intros (n' & Hn & E'). inv Hn. solveeq.
    - right. split. intros (n' & Hn & E'). inv Hn. solveeq.
  }

  destruct (markov _ decp) as [t' [v H]].
  - assert (forall P Q : Prop, (P -> Q) -> (~~ P -> ~~ Q)) by tauto. eapply H; try eassumption; eauto.
    intros [v [n Hn] % evaluates_eval].
    exists n. exists n. firstorder congruence.
  - destruct H. subst. destruct (eval v t) eqn:Eq; try congruence.
    eapply eval_evaluates in Eq. eauto.
Qed.

Lemma Markov_Eva_to_Post : Markov_Eva -> Markov_Post.
Proof.
  intros H p [u [[lam_u cls_u] Hu]] [v [[lam_v cls_v] Hv]].
  pose (por_u_v := lambda (O ((App (tenc u) (Q 0))) ((App (tenc v) (Q 0))))).
  exists por_u_v.
  split; subst por_u_v; value. intros t.

  assert (A : eva (O (tenc (u (tenc t))) (tenc (v (tenc t))))). {
    eapply H; value.

    intros A.
    assert (Hnu : ~ eva (u (tenc t))). { intros B. eapply A, O_complete. tauto. }
    assert (Hnv : ~ eva (v (tenc t))). { intros B. eapply A, O_complete. tauto. }
    rewrite <- Hu in Hnu. rewrite <- Hv in Hnv. unfold complement in *. tauto.
  }

  eapply O_sound in A.

  destruct A as [[A [B ?] %evaluates_equiv] | [A [B ?] %evaluates_equiv]].
  - left; split; eauto. rewrite Hu. tauto. eapply evaluates_equiv; split; value.
    dobeta. now rewrite Q_correct, !App_correct, B.
  - right; split; eauto. unfold complement in *. rewrite Hv. tauto.
    eapply evaluates_equiv; split; value. dobeta; now rewrite Q_correct, !App_correct, B.
Qed.


Require Export Common.
Require Export LambdaDollar.
Require Export LambdaLetDollar.

(* ANCHOR Similarity Relation
 *)
Reserved Notation "e ~ₑ e'" (at level 40).
Reserved Notation "v ~ᵥ v'" (at level 40).
Reserved Notation "p ~ₚ p'" (at level 40).
Reserved Notation "j ~ⱼ j'" (at level 40).
Reserved Notation "k ~ₖ k'" (at level 40).
Reserved Notation "t ~ₜ t'" (at level 40).
Inductive sim_tm {A} : tm A → tm' A → Prop :=
| sim_var  : ∀ a, <{ var a }> ~ₑ <| var a |>
| sim_abs  : ∀ e e', e ~ₑ e' → <{ λ  e }> ~ₑ <| λ   e' |>
| sim_s_0  : ∀ e e', e ~ₑ e' → <{ S₀ e }> ~ₑ <| S₀, e' |>
| sim_app  : ∀ e1 e2 e1' e2', e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1   e2 }> ~ₑ <| e1'   e2' |>
| sim_dol  : ∀ e1 e2 e1' e2', e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1 $ e2 }> ~ₑ <| e1' $ e2' |>
| sim_eta  : ∀ (v : val A) (v' : val' A), v ~ₑ v' →
    <{ λ {liftV v} $ 0 }> ~ₑ v'
| sim_eta_dol : ∀ (v1 v2 : val A) (v1' v2' : val' A), v1 ~ₑ v1' → v2 ~ₑ v2' →
    <{ v1 $ v2 }> ~ₑ <| v1' v2' |>
| sim_let : ∀ j e j' e', j ~ⱼ j' → e ~ₑ e' →
    <{ j[e] }> ~ₑ <| let e' in ↑j'[0] |>
with sim_J {A} : J A → J' A → Prop :=
| sim_J_fun : ∀ (e : tm  A) (e' : tm'  A), e ~ₑ e' → J_fun e ~ⱼ J_fun' e'
| sim_J_arg : ∀ (v : val A) (v' : val' A), v ~ₑ v' → J_arg v ~ⱼ J_arg' v'
| sim_J_dol : ∀ (e : tm  A) (e' : tm'  A), e ~ₑ e' → J_dol e ~ⱼ J_dol' e'
where "e ~ₑ e'" := (sim_tm e e')
and   "j ~ⱼ j'" := (sim_J  j j').
Scheme sim_tm_mut := Minimality for sim_tm Sort Prop
with   sim_J_mut  := Minimality for sim_J Sort Prop.
Inductive sim_val {A} : val A → val' A → Prop :=
| sim_val_abs : ∀ v v', val_to_tm v ~ₑ val_to_tm' v' → v ~ᵥ v'
where "v ~ᵥ v'" := (sim_val v v').
Inductive sim_non {A} : non A → non' A → Prop :=
| sim_non_ : ∀ p p', non_to_tm p ~ₑ non_to_tm' p' → p ~ₚ p'
where "p ~ₚ p'" := (sim_non p p').
Inductive sim_K {A} : K A → K' A → Prop :=
| sim_K_nil  :
    K_nil ~ₖ K_nil'
| sim_K_cons : ∀ j j' k k',
    j ~ⱼ j' →
    k ~ₖ k' →
    K_cons j k ~ₖ K_let' k' <| ↑j'[0] |> (* J[K] ~ let x = K' in J'[0] *)
where "k ~ₖ k'" := (sim_K k k').
Inductive sim_T {A} : T A → T' A → Prop :=
| sim_T_nil  :
    T_nil ~ₜ T_nil'
| sim_T_cons : ∀ v v' k k' t t',
    v ~ᵥ v' →
    k ~ₖ k' →
    t ~ₜ t' →
    T_cons v k t ~ₜ T_cons' v' k' t'
where "t ~ₜ t'" := (sim_T t t').
Global Hint Constructors sim_J : core.
Global Hint Constructors sim_K : core.
Global Hint Constructors sim_T : core.
Global Hint Constructors sim_val : core.
Global Hint Constructors sim_non : core.
Global Hint Constructors sim_tm : core.

Lemma sim_let_fun {A} : ∀ (e1 : tm A) e2 e1' e2',
  e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1   e2 }> ~ₑ <| let e1' in (0   ↑e2') |>.
Proof.
  intros. apply (sim_let (J_fun _) _ (J_fun' _)); auto.
Qed.
Lemma sim_let_arg {A} : ∀ (v1 : val A) e2 (v1' : val' A) e2',
  v1 ~ₑ v1' → e2 ~ₑ e2' → <{ v1   e2 }> ~ₑ <| let e2' in ({liftV' v1'}  0 ) |>.
Proof.
  intros. apply (sim_let (J_arg _) _ (J_arg' _)); auto.
Qed.
Lemma sim_let_dol {A} : ∀ (e1 : tm A) e2 e1' e2',
  e1 ~ₑ e1' → e2 ~ₑ e2' → <{ e1 $ e2 }> ~ₑ <| let e1' in (0 $ ↑e2') |>.
Proof.
  intros. apply (sim_let (J_dol _) _ (J_dol' _)); auto.
Qed.
Global Hint Resolve sim_let_fun sim_let_arg sim_let_dol : core.

Fixpoint dollar_to_let {A} (e : tm A) : tm' A :=
  match e with
  | <{ var a }> => <| var a |>
  | <{ λ  e' }> => <| λ   {dollar_to_let e'} |>
  | <{ S₀ e' }> => <| S₀, {dollar_to_let e'} |>
  | <{ e1   e2 }> => <| {dollar_to_let e1}   {dollar_to_let e2} |>
  | <{ e1 $ e2 }> => <| {dollar_to_let e1} $ {dollar_to_let e2} |>
  end.

(* ANCHOR Reflexivity of the Similarity Relation *)

Lemma sim_refl_dollar_to_let : ∀ {A} (e : tm A),
  e ~ₑ dollar_to_let e.
Proof.
  induction e; cbn; auto.
Qed.

Lemma sim_tm_from_sim_val : ∀ {A v} {v' : val' A},
  v ~ᵥ v' →
  v ~ₑ v'.
Proof.
  intros. destruct v, v'; inversion H; clear H; subst; assumption.
Qed.
Global Hint Resolve sim_tm_from_sim_val : core.

Lemma sim_val_inv : ∀ {A} (v : val A) (e' : tm' A),
  v ~ₑ e' → ∃ (v' : val' A), e' = v' /\ v ~ᵥ v'.
Proof.
  intros. destruct v. inversion H; clear H; subst.
  exists (val_abs' e'0); split; auto. repeat constructor; auto.
  repeat eexists. repeat constructor; auto.
  destruct j; inversion H0.
Qed.

Lemma sim_non_inv : ∀ {A} (p : non A) (e' : tm' A),
  p ~ₑ e' → ∃ (p' : non' A), e' = p' /\ p ~ₚ p'.
Proof with split; cbn; auto; cbn; repeat (constructor; cbn); try assumption.
  intros. destruct p; inversion H; clear H; subst;
  try (destruct j; inversion H0; clear H0; subst; inversion H1; clear H1; subst).
  - exists (non_app' <| S₀ |> <| λ e'0 |>)...
  - exists (non_app' e1' e2')...
  - exists (non_let' e'0 <| 0 ↑e' |>)... apply sim_let_fun; auto.
  - exists (non_let' e'0 <| {liftV' v'} 0 |>)... apply sim_let_arg; auto.
  - exists (non_dol' e1' e2')...
  - exists (non_app' v1' v2')...
  - exists (non_let' e'0 <| 0 $ ↑e' |>)... apply sim_let_dol; auto.
Qed.

Ltac reason := repeat(
  match goal with
  | H : val_to_tm ?v ~ₑ ?e' |- _ =>
      let v' := fresh "v'" in
      let Hev := fresh "Hev" in
      let Hv := fresh "Hv" in
      apply sim_val_inv in H as [v' [Hev Hv]]; subst
  | H : non_to_tm ?p ~ₑ ?e' |- _ =>
      let p' := fresh "p'" in
      let Hep := fresh "Hep" in
      let Hp := fresh "Hp" in
      apply sim_non_inv in H as [p' [Hep Hp]]; rewrite Hep in *; clear e' Hep
  | H : val_to_tm' ?v1 = val_to_tm' ?v2 |- _ => apply inj_val' in H
  | H : val_to_tm  ?v1 = val_to_tm  ?v2 |- _ => apply inj_val  in H
  | H : non_to_tm  ?p1 = non_to_tm  ?p2 |- _ => rewrite H in *

  | H : non_to_tm  ?p = val_to_tm  ?v |- _ => destruct v, p; inversion H
  | H : val_to_tm  ?v = non_to_tm  ?p |- _ => destruct v, p; inversion H
  end).

Lemma broken_sim_plug_j_inv_as_term_not_nonvalue : ∀ {A} (j : J A) e term',
  <{ j[e] }> ~ₑ term' →
  (∃ j' e', j ~ⱼ j' /\ e ~ₑ e' /\ ( term' = <| j'[e'] |> \/ term' = <| let e' in ↑j'[0] |>)) \/
  (∃ v v' e', j = J_arg v /\ e ~ₑ e' /\ v ~ᵥ v' /\ term' = <| let v' in 0 ↑e' |>).
Proof.
  intros; destruct j; inversion H; clear H; subst; reason; cbn in *; subst;
  try solve [left; repeat eexists; eauto].
  admit. admit. left; repeat eexists; eauto.
  cbn.
  (* Imposible: v1' v2' = v1' $ v2' *)
Abort.

Lemma sim_plug_j_inv : ∀ {A} (j : J A) (p : non A) term',
  <{ j[p] }> ~ₑ term' →
  (∃ j' p', j ~ⱼ j' /\ p ~ₚ p' /\ ( term' = <| j'[p'] |> \/ term' = <| let p' in ↑j'[0] |>)) \/
  (∃ v v' p', j = J_arg v /\ p ~ₚ p' /\ v ~ᵥ v' /\ term' = <| let v' in 0 {↑(non_to_tm' p')} |>).
Proof.
  intros; destruct j; inversion H; clear H; subst; reason; cbn in *;
  try (inversion Hp; clear Hp; subst);
  try solve [left; repeat eexists; eauto];
  destruct j; inversion H0; clear H0; subst; reason; inversion H1; clear H1; subst; reason; subst; try (inversion Hp; clear Hp; subst);
  try solve [left; repeat eexists; eauto].
  right. repeat eexists; auto.
Qed.

(* k[p] ~ e' -->'* k'[p'] *)
Lemma plug_k_steps_to_similar_k' : ∀ (k : K ∅) (p : non ∅) term',
  <{ k [p] }> ~ₑ term' →
  ∃ (k' : K' ∅) (p' : non' ∅),
    term' -->'* <| k'[ p'] |> /\
    k ~ₖ k' /\
    p ~ₚ p'.
Proof with auto.
  induction k; intros; cbn in *.
  - apply sim_non_inv in H as [p' [H Hp]]; subst.
    exists K_nil'; exists p'; auto.
  - destruct (plug_non_is_non k T_nil p) as [kp Hkp]. cbn in Hkp. rewrite Hkp in H.
    apply sim_plug_j_inv in H as
      [[j' [p' [Hj [Hp [Hsub | Hsub]]]]]
      |[v [v' [p' [Hj [Hp [Hv Hsub]]]]]]
      ]; subst;
    inversion Hp; clear Hp; subst; rewrite <- Hkp in *; clear kp Hkp;
      apply IHk in H as [k' [p'' [Hstep [Hk He]]]].
    * exists (K_let' k' <| ↑j'[0] |>), p''; repeat split; cbn.
      + eapply multi_contr_multi'. apply contr_let'.
        apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
    * exists (K_let' k' <| ↑j'[0] |>), p''; repeat split; cbn.
      + apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
    * eexists (K_let' k' _), p''; repeat split; cbn.
      + eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. rewrite bind_var_subst_lift'.
        eapply multi_contr_multi'. apply (contr_let' (J_arg' _)).
        apply multi_let'. apply Hstep.
      + constructor...
      + inversion He...
Qed.

Lemma plug_t_steps_to_similar_t' : ∀ (t : T ∅) (p : non ∅) term',
  <{ t [p] }> ~ₑ term' →
  ∃ (t' : T' ∅) (p' : non' ∅),
    term' -->'* <| t'[ p'] |> /\
    t ~ₜ t' /\
    p ~ₚ p'.
Proof.
  induction t; intros; cbn in *.
  - apply sim_non_inv in H as [p' [H Hp]]; subst.
    exists T_nil'; exists p'; auto.
  - inversion H; clear H; reason; subst.
    + destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H4.
      apply plug_k_steps_to_similar_k' in H4 as [k' [p' [Hmulti1 [Hk Hp]]]].
      inversion Hp; clear Hp; subst.
      rewrite <- Htp in H.
      apply IHt in H as [t' [p'' [Hmulti2 [Ht Hp2]]]].
      repeat eexists; eauto; cbn.
      apply multi_delim'.
      apply (multi_trans Hmulti1).
      apply (multi_k' Hmulti2).
      inversion Hp2; clear Hp2; subst. auto.
    + destruct (plug_non_is_non k t p) as [tp Htp]; cbn in Htp. rewrite Htp in *.
      destruct v2, tp; inversion H1.
    + destruct j; inversion H0; clear H0; subst.
      inversion H1; clear H1; subst; reason.
      destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H0.
      apply plug_k_steps_to_similar_k' in H0 as [k' [p' [Hmulti1 [Hk Hp]]]].
      inversion Hp; clear Hp; subst.
      rewrite <- Htp in H.
      apply IHt in H as [t' [p'' [Hmulti2 [Ht Hp2]]]].
      repeat eexists; eauto; cbn.
      apply (multi_contr_multi' (contr_let_beta' _ _)).
      cbn. change (map' Some e'0) with (↑e'0). rewrite bind_var_subst_lift'.
      apply multi_delim'.
      apply (multi_trans Hmulti1).
      apply (multi_k' Hmulti2).
      inversion Hp2; clear Hp2; subst. auto.
Qed.

Lemma plug_kt_steps_to_similar_kt' : ∀ (k : K ∅) (t : T ∅) (p : non ∅) term',
  <{ k [t [p]] }> ~ₑ term' →
  ∃ (k' : K' ∅) (t' : T' ∅) (p' : non' ∅),
    term' -->'* <| k'[ t' [p']] |> /\
    k ~ₖ k' /\
    t ~ₜ t' /\
    p ~ₚ p'.
Proof.
  intros.
  destruct (plug_non_is_non K_nil t p) as [tp Htp]; cbn in Htp. rewrite Htp in H.
  apply plug_k_steps_to_similar_k' in H as [k' [p1 [Hmulti1 [Hk Hp1]]]].
  inversion Hp1; clear Hp1; reason; subst.
  rewrite <- Htp in *.
  apply plug_t_steps_to_similar_t' in H as [t' [p2 [Hmulti2 [Ht Hp2]]]].
  inversion Hp2; clear Hp2; reason; subst;
  repeat eexists; eauto;
  apply (multi_trans Hmulti1);
  apply (multi_k' Hmulti2).
Qed.

Lemma sim_map : ∀ {A} {e e' B} {f : A → B},
  e ~ₑ e' →
  map f e ~ₑ map' f e'.
Proof with auto.
  intros. generalize dependent B.
  induction H using sim_tm_mut with
    (P0 := λ A j j', ∀ B (f : A → B), mapJ f j ~ⱼ mapJ' f j');
  intros; cbn; auto; reason; subst;
  try rewrite <- lift_val_to_tm;
  try rewrite <- lift_val_to_tm';
  try rewrite <- lift_map;
  try rewrite <- lift_map'...

  (* sim_eta *)
  rename v'0 into v'.
  destruct (map_val_is_val  v  f) as [v2  Hrv ].
  destruct (map_val_is_val' v' f) as [v2' Hrv'].
  rewrite Hrv; rewrite Hrv'.
  rewrite lift_val_to_tm.
  apply sim_eta.
  rewrite <- Hrv; rewrite <- Hrv'.
  apply IHsim_tm.

  (* sim_eta_dol *)
  rename v'0 into v1'.
  rename v' into v2'.
  destruct (map_val_is_val  v1  f) as [w1  Hrv1 ].
  destruct (map_val_is_val' v1' f) as [w1' Hrv1'].
  destruct (map_val_is_val  v2  f) as [w2  Hrv2 ].
  destruct (map_val_is_val' v2' f) as [w2' Hrv2'].
  rewrite Hrv1; rewrite Hrv1'; rewrite Hrv2; rewrite Hrv2'.
  apply sim_eta_dol.
  rewrite <- Hrv1; rewrite <- Hrv1'...
  rewrite <- Hrv2; rewrite <- Hrv2'...

  (* sim_let *)
  rewrite map_plug_j_is_plug_of_maps.
  rewrite map_plug_j_is_plug_of_maps'; cbn.
  rewrite <- lift_mapJ'.
  apply sim_let...

  (* J *)
  constructor.
  rewrite mapV_is_map; rewrite mapV_is_map'...
Qed.
Global Hint Resolve sim_map : core.

Lemma sim_bind : ∀ {A} {e e' B} {f : A → tm B} {f' : A → tm' B},
  e ~ₑ e' →
  (∀ a, f a ~ₑ f' a) →
  bind f e ~ₑ bind' f' e'.
Proof with auto.
  intros. generalize dependent B.
  induction H using sim_tm_mut with
    (P0 := λ A j j', ∀ B (f : A → tm B) (f' : A → tm' B), (∀ a, f a ~ₑ f' a) → bindJ f j ~ⱼ bindJ' f' j');
  intros; cbn; auto;
  try solve [constructor; apply IHsim_tm; auto; intros [a|]; auto];
  try rewrite <- lift_val_to_tm;
  try rewrite <- lift_val_to_tm';
  try (rewrite bind_lift + rewrite bind_lift'); try rewrite lambda_match_just_some;
  try change (λ a : A, map Some (f a)) with (lift ∘ f);
  try change (λ a : A, map' Some (f' a)) with (lift ∘ f');
  try rewrite <- lift_bind';
  try rewrite <- lift_bind;
  reason; subst; auto.

  (* sim_eta *)
  rename v'0 into v'.
  destruct (bind_val_is_val  v  f ) as [v2  Hrv ].
  destruct (bind_val_is_val' v' f') as [v2' Hrv'].
  rewrite Hrv; rewrite Hrv'.
  rewrite lift_val_to_tm.
  apply sim_eta.
  rewrite <- Hrv; rewrite <- Hrv'...

  (* ṣim_eta_dol *)
  rename v'0 into v1'.
  rename v' into v2'.
  destruct (bind_val_is_val  v1  f ) as [w1  Hrv1 ].
  destruct (bind_val_is_val' v1' f') as [w1' Hrv1'].
  destruct (bind_val_is_val  v2  f ) as [w2  Hrv2 ].
  destruct (bind_val_is_val' v2' f') as [w2' Hrv2'].
  rewrite Hrv1; rewrite Hrv1'; rewrite Hrv2; rewrite Hrv2'.
  apply sim_eta_dol.
  rewrite <- Hrv1; rewrite <- Hrv1'...
  rewrite <- Hrv2; rewrite <- Hrv2'...

  (* sim_let *)
  rewrite bind_plug_j_is_plug_of_binds;
  rewrite bind_plug_j_is_plug_of_binds'.
  rewrite bindJ_lift'. rewrite lambda_match_just_some. cbn. rewrite <- lift_bindJ'.
  apply sim_let...

  (* J *)
  constructor.
  rewrite bindV_is_bind; rewrite bindV_is_bind'...
Qed.
Global Hint Resolve sim_bind : core.

Lemma sim_plug_j : ∀ {A} (j : J A) j' e e',
  j ~ⱼ j' →
  e ~ₑ e' →
  <{ j[e] }> ~ₑ <| j'[e'] |>.
Proof with auto.
  intros; inversion H; clear H; subst; cbn...
Qed.

Lemma sim_plug_k : ∀ {A} (k : K A) k' e e',
  k ~ₖ k' →
  e ~ₑ e' →
  <{ k[e] }> ~ₑ <| k'[e'] |>.
Proof.
  intros. generalize dependent e. generalize dependent e'.
  induction H; intros; cbn; auto.
Qed.

Lemma sim_plug_t : ∀ {A} (t : T A) t' e e',
  t ~ₜ t' →
  e ~ₑ e' →
  <{ t[e] }> ~ₑ <| t'[e'] |>.
Proof.
  induction t; intros; inversion H; clear H; subst; cbn; auto.
  constructor; auto.
  apply sim_plug_k; auto.
Qed.

Lemma sim_lift : ∀ {A} {e : tm A} {e'},
   e ~ₑ  e' →
  ↑e ~ₑ ↑e'.
Proof.
  intros. unfold lift. unfold LiftTm'. unfold LiftTm. apply (sim_map H).
Qed.
Global Hint Resolve sim_lift : core.

Lemma sim_lift_val : ∀ {A} {v : val A} {v'},
  v ~ᵥ v' →
  liftV v ~ᵥ liftV' v'.
Proof.
  intros.
  inversion H; clear H; subst.
  constructor.
  rewrite <- lift_val_to_tm.
  rewrite <- lift_val_to_tm'.
  apply sim_lift; assumption.
Qed.
Global Hint Resolve sim_lift_val : core.

Lemma sim_lift_j : ∀ {A} {j : J A} {j'},
   j ~ⱼ  j' →
  ↑j ~ⱼ ↑j'.
Proof.
  intros. inversion H; clear H; subst; cbn; auto.
  reason; subst.
  apply sim_lift_val in Hv. auto.
Qed.
Global Hint Resolve sim_lift_j : core.

Lemma sim_lift_k : ∀ {A} {k : K A} {k'},
   k ~ₖ  k' →
  ↑k ~ₖ ↑k'.
Proof with auto.
  intros; induction H; cbn...

  assert (map' (option_map Some) <| ↑j'[0] |> = <| ↑↑j'[0] |>) as HH.
    inversion H; clear H; subst; cbn;
    try change (map' Some e') with (↑e');
    try change (mapV' Some v') with (liftV' v');
    repeat rewrite mapV_is_map';
    repeat rewrite <- lift_val_to_tm';
    unfold lift; unfold LiftTm';
    repeat rewrite map_map_law'...
  rewrite HH.
  constructor...
  apply sim_lift_j...
Qed.
Global Hint Resolve sim_lift_k : core.

Lemma sim_subst_lemma : ∀ e e' v (v' : val' ∅),
  e ~ₑ e' →
  v ~ᵥ v' →
  <{ e [0 := v] }> ~ₑ <| e' [0 := v'] |>.
Proof.
  intros. unfold tm_subst0. unfold tm_subst0'.
  apply sim_bind; auto.
  intros [n|]; try destruct n; cbn. auto.
Qed.

Ltac laws := repeat(
  try match goal with
  | |- context C [bind' (var_subst' _) (mapV' Some _)] =>
      rewrite mapV_is_map'
  end;
  try match goal with
  | |- context C [bind  (var_subst  _) (val_to_tm  (liftV  ?v))] =>
      rewrite <- (lift_val_to_tm  v)
  | |- context C [bind' (var_subst' _) (val_to_tm' (liftV' ?v))] =>
      rewrite <- (lift_val_to_tm' v)
  | |- context C [bind  (var_subst  _) (map  Some ?e)] =>
      change (map Some e) with (↑e)
  | |- context C [bind' (var_subst' _) (map' Some ?e)] =>
      change (map' Some e) with (↑e)
  end;
  match goal with
  | |- context C [bind  (var_subst  _) (↑ _)] =>
      rewrite bind_var_subst_lift
  | |- context C [bind' (var_subst' _) (↑ _)] =>
      rewrite bind_var_subst_lift'
  end).

Lemma k_inv_inner' : ∀ (k : K ∅) (k' : K' ∅),
  k ~ₖ k' →
  (k = K_nil /\ k' = K_nil') \/
  (∃ (k2 : K ∅) (k2' : K' ∅) (j2 : J ∅) (j2' : J' ∅),
    k2 ~ₖ k2' /\
    j2 ~ⱼ j2' /\
    (∀ (e  : tm ^∅), <{ ↑k[e ] }> = <{ ↑k2[↑j2[e ]] }>) /\
    (∀ (e' : tm' ∅), <| k'[e'] |> = <| k2'[let e' in ↑j2'[0]] |>)).
Proof with auto.
  induction k; intros; inversion H; clear H; subst; cbn; auto.
  destruct (IHk _ H4) as [[Hk Hk'] | [k2 [k2' [j2 [j2' [Hk2 [Hj2 [Hke Hke']]]]]]]]; subst; right.
  - exists K_nil, K_nil'. repeat eexists...
  - exists (K_cons j k2), (K_let' k2' <| ↑j'[0] |>), j2, j2'; repeat split; auto; intros.
    + rewrite Hke in *. reflexivity.
    + rewrite Hke' in *. reflexivity.
Qed.

Lemma sim_redex_beta : ∀ e (v : val ∅) ev' v',
  <{ λ e }> ~ₑ ev' →
  v ~ᵥ v' → ∃ term',
    <| ev' v' |> -->'* term' /\
    <{ e [0 := v] }> ~ₑ term'.
Proof with auto.
  intros. inversion H; clear H; subst.
  - repeat eexists.
    + apply multi_contr'. apply contr_beta'.
    + apply sim_subst_lemma...

  (* <{ (λ e) v }> = <{ (λ ↑v0 $ 0) v }> ~> <{ v0 $ v }> ~ₑ <{ v0' v' }>, a case where λ$ is behind one step *)
  - repeat eexists.
    + auto.
    + cbn. laws. apply sim_eta_dol...
  - destruct j; inversion H1.
Qed.

(* ANCHOR Simulation Step
 *)
Theorem dollar_step_to_let_multi : ∀ e1 e2 e1',
  e1 --> e2 →
  e1 ~ₑ e1' →
  ∃ e2', e1' -->'* e2' /\ e2 ~ₑ e2'.
Proof with auto.
  intros term1 term2 term1' Hstep Hsim.
  inversion Hstep; clear Hstep; subst.
  inversion H; clear H; subst.
  destruct (redex_is_non r) as [p Hrp]. rewrite Hrp in Hsim.
  apply plug_kt_steps_to_similar_kt' in Hsim as [k' [t' [p' [Hmulti [Hk [Ht Hp]]]]]].
  inversion Hp; clear Hp; subst.
  rewrite <- Hrp in *. clear Hrp p.
  destruct r; cbn in *.

  (* redex_beta *)
  { destruct v.
    inversion H; clear H; subst; reason;
    try (rewrite <- H2 in *; clear p' H2);
    try (rewrite <- H1 in *; clear p' H1);
    try (destruct j; inversion H0; clear H0; subst; inversion H2; clear H2; subst; reason).
    * destruct (sim_redex_beta _ _ _ _ H3 Hv) as [term' [Hmulti2 Hsim]].
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
    * destruct (sim_redex_beta _ _ _ _ H3 Hv) as [term' [Hmulti2 Hsim]].
      rewrite lambda_to_val in H3; reason.
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'.
        eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. laws. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
    * rewrite lambda_to_val in H1. apply inj_val in H1. subst.
      inversion Hv; clear Hv; subst. cbn in H.
      destruct (sim_redex_beta _ _ _ _ H Hv0) as [term' [Hmulti2 Hsim]].
      repeat eexists.
      + apply (multi_trans Hmulti). eapply multi_k'. eapply multi_t'.
        eapply multi_contr_multi'. apply contr_let_beta'.
        cbn. rewrite mapV_is_map'. laws. apply Hmulti2.
      + apply sim_plug_k... apply sim_plug_t...
  }

  (* redex_dollar *)
  { destruct p'; inversion H; clear H; reason; subst.
    + repeat eexists.
      * apply Hmulti.
      * apply sim_plug_k... apply sim_plug_t... constructor...
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        cbn. apply (multi_contr' (contr_dollar' _ _)).
      - apply sim_plug_k... apply sim_plug_t...
    + destruct j; inversion H0; clear H0; subst; inversion H3; clear H3; subst; reason.
      cbn in *.
      repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        apply (multi_contr_multi' (contr_let_beta' _ _)).
        cbn. laws.
        apply (multi_contr' (contr_dollar' _ _)).
      - apply sim_plug_k... apply sim_plug_t...
  }

  (* redex_shift *)
  { change <{ S₀ t0 }> with (non_to_tm (non_s_0 t0)) in H.
    apply (plug_t_steps_to_similar_t' (T_cons v k0 T_nil) _ _) in H as [t'' [p'' [Hmulti' [Ht' Hp']]]].
    inversion Ht'; clear Ht'; subst. inversion H5; clear H5; subst. inversion Hp'; clear Hp'; subst. cbn in *.
    inversion H; clear H; subst; try solve [destruct j; inversion H0].
    rewrite <- H1 in *. clear H1 p''.
    destruct (k_inv_inner' _ _ H4) as [[Hk0 Hk'0] | [k2 [k2' [j2 [j2' [Hk2 [Hj2 [Hke Hke']]]]]]]]; subst.
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        apply (multi_trans Hmulti').
        apply (multi_contr_multi' (contr_shift' v' <| λv' e' |>)).
        apply (multi_contr' (contr_beta' _ _)).
      - apply sim_plug_k... apply sim_plug_t... apply sim_subst_lemma... cbn. constructor. apply sim_eta...
    + repeat eexists.
      - apply (multi_trans Hmulti).
        eapply multi_k'. eapply multi_t'.
        rewrite Hke' in *.
        apply (multi_trans Hmulti').
        eapply multi_trans.
        eapply multi_delim'.
        apply (plug_k_let_reassoc_s_0 _ _ _).
        eapply multi_contr_multi'. rewrite lambda_to_val'. apply contr_dol_let'.
        eapply multi_contr_multi'. rewrite lambda_to_val'. apply contr_shift'.
        apply multi_contr'. apply contr_beta'.
      - apply sim_plug_k... apply sim_plug_t... apply sim_subst_lemma...
        rewrite Hke.
        constructor. constructor. constructor... apply sim_plug_k... apply sim_plug_j...
  }
Qed.

(* ANCHOR Simulation
 *)
Theorem dollar_multi_to_let_multi : ∀ e1 e2 e1',
  e1 -->* e2 →
  e1 ~ₑ e1' →
  ∃ e2', e1' -->'* e2' /\ e2 ~ₑ e2'.
Proof.
  intros. generalize dependent e1'.
  induction H; intros;
  try solve [repeat eexists; auto].

  eapply (dollar_step_to_let_multi _ _ _ H) in H1 as Hstep. destruct Hstep as [e2' [Hmulti1 Hsim1]].
  apply IHmulti in Hsim1 as Hstep. destruct Hstep as [e3' [Hmulti2 Hsim2]].
  repeat eexists.
  - apply (multi_trans Hmulti1 Hmulti2).
  - assumption.
Qed.
(* Print Assumptions dollar_multi_to_let_multi. *)

Theorem dollar_multi_to_let_multi_val : ∀ e (v : val ∅) e',
  e -->* v →
  e ~ₑ e' →
  ∃ (v' : val' ∅), e' -->'* v' /\ v ~ᵥ v'.
Proof.
  intros e v e' Hmulti Hsim.
  destruct (dollar_multi_to_let_multi e v e' Hmulti Hsim) as [v' [Hmulti' Hsim']].
  reason; eauto.
Qed.

Theorem dollar_to_let_equivalent_steps : ∀ e (v : val ∅),
  e -->* v →
  ∃ (v' : val' ∅), dollar_to_let e -->'* v' /\ v ~ᵥ v'.
Proof.
  intros.
  apply (dollar_multi_to_let_multi_val e v (dollar_to_let e) H).
  apply sim_refl_dollar_to_let.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.

See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2013-09-17

* Termination proof of Goedel System T
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil OrdUtil LSimple RelUtil.
From Coq Require Import Structures.Equalities Lia.
From CoLoR Require SetUtil.

(****************************************************************************)
(** ** Type constants of System T. **)

Inductive B : Type := Nat : B.

Lemma eq_B_dec : forall a b : B, {a=b}+{~a=b}.

Proof. (*COQ:decide equality*)destruct a. destruct b. auto. Qed.

(** [Typ] structure for type constants. *)

Module BTyp <: Typ.

  Definition t := B.

End BTyp.

(** [Cmp] structure for type constants. *)

Module BCmp <: Cmp.

  Include BTyp.

  Definition cmp (_ _ : B) := Eq.

  Lemma cmp_opp x y : cmp x y = CompOpp (cmp y x).

  Proof. refl. Qed.

End BCmp.

(** [CmpTransLeibniz] structure for type constants. *)

Module BCmpTransLeibniz <: CmpTransLeibniz.

  Include BCmp.

  Lemma cmp_eq x y : cmp x y = Eq -> x = y.

  Proof. destruct x; destruct y. refl. Qed.

  Lemma cmp_lt_trans x y z : cmp x y = Lt -> cmp y z = Lt -> cmp x z = Lt.

  Proof. fo. Qed.

End BCmpTransLeibniz.

(****************************************************************************)
(** ** Types of System T. *)

Notation TNat := (Base Nat).

(** [Cmp] structure for System T types. *)

Module Ty_Cmp := ST_Cmp BCmp.

(** [CmpTransLeibniz] structure for System T types. *)

Module Ty_CmpTransLeibniz := ST_CmpTransLeibniz BCmpTransLeibniz.

(****************************************************************************)
(** ** Function symbols of System T. *)

Inductive F : Type :=
| Zero : F
| Succ : F
| Rec : Ty B -> F.

(** Well-founded precedence on function symbols. *)

Definition prec f :=
  match f with
    | Zero => 0
    | Succ => 1
    | Rec _ => 2
  end.

(** [Cmp] structure for function symbols.

We use the lexicographic path ordering with Zero < Succ < Rec A and
Rec A < Rec B if A < B. *)

From Coq Require Import Compare_dec.

Module FCmp <: Cmp.

  Definition t := F.

  Definition cmp f g :=
    match f, g with
      | Rec u, Rec v => Ty_Cmp.cmp u v
      | _, _ => Nat.compare (prec f) (prec g)
    end.

  Lemma cmp_opp f g : cmp f g = CompOpp (cmp g f).

  Proof. destruct f; destruct g; try refl. apply Ty_Cmp.cmp_opp. Qed.

End FCmp.

(** [CmpTransLeibniz] structure for function symbols. *)

Module FCmpTransLeibniz <: CmpTransLeibniz.

  Include FCmp.

  Lemma cmp_eq x y : cmp x y = Eq -> x = y.

  Proof.
    destruct x; destruct y; simpl; try (refl||discr).
    intro e. apply Ty_CmpTransLeibniz.cmp_eq in e. subst. refl.
  Qed.

  Lemma cmp_lt_trans x y z : cmp x y = Lt -> cmp y z = Lt -> cmp x z = Lt.

  Proof.
    destruct x; destruct y; destruct z; simpl; try (refl||discr).
    apply Ty_CmpTransLeibniz.cmp_lt_trans.
  Qed.

End FCmpTransLeibniz.

(** [OrderedType] structure for function symbols. *)

Module FMOT := MOT_of_CmpTransLeibniz FCmpTransLeibniz.

Module FOrd := MOT_to_OT FMOT.

(****************************************************************************)
(** ** [L] structure (term algebra) of System T. *)

From CoLoR Require Import VecUtil.

Module L_SystemT <: L_Struct.

  Definition F := F.

  Module FOrd := FOrd.

  Module Export V := NatVar.

  Notation Te := (Te F X).
  Notation Tes := (vector Te).

  Notation Var := (@Var F X).
  Notation Fun := (@Fun F X).
  Notation App := (@App F X).
  Notation Lam := (@Lam F X).

  Notation apps := (@apps F X).
  Notation fv := (@fv F X ens_X).
  Notation eq_term_dec := (@eq_term_dec F X FOrd.eq_dec XOrd.eq_dec).

  Notation FZero := (Fun Zero).
  Notation FSucc := (Fun Succ).
  Definition FRec A := Fun (Rec A).

End L_SystemT.

(****************************************************************************)
(** ** [RS] structure (rewrite rules) of System T. *)

From CoLoR Require Import LCompRewrite.
Import VectorNotations.
Local Open Scope vector_scope.

Module RS_SystemT <: RS_Struct.

  Module Export L := L_SystemT.

  (* Some variables. *)
  Definition u := Var 0.
  Definition v := Var 1.
  Definition n := Var 2.

  Inductive R : relation Te :=
  | rule_Rec_Zero : forall A, R (apps (Fun (Rec A)) [FZero; u; v]) u
  | rule_Rec_Succ : forall A, R (apps (Fun (Rec A)) [apps FSucc [n]; u; v])
                                (apps v [n; apps (FRec A) [n; u; v]]).

  Definition rule := R.

  Global Instance fv_rule : Proper (rule --> Subset) fv.

  Proof.
    intros a b ba. inversion ba; subst; simpl; intro x; set_iff; tauto.
  Qed.

  Definition lhs_fun l r (_ : rule l r) :=
    match head l with
      | Def.Fun f => f
      | _ => Zero (* don't care *)
    end.

  Definition lhs_nb_args l r (_ : rule l r) := 3.

  Definition lhs_args l r :=
    match l as l return forall h : rule l r, Tes (lhs_nb_args h) with
      | Def.App (Def.App (Def.App (Def.Fun _) l1) l2) l3 =>
        fun _ => [l1; l2; l3]
      | _ => fun _ => [FZero; FZero; FZero] (* don't care *)
    end.

  Lemma lhs_ok l r ( h : rule l r) : l = apps (Fun (lhs_fun h)) (lhs_args h).

  Proof. inversion h; subst; refl. Qed.

End RS_SystemT.

(****************************************************************************)
(** ** [ST] structure (types of function symbols) of System T. *)

From Coq Require FMapAVL.

Module ST_SystemT <: ST_Struct.

  Module Export L := L_SystemT.

  Definition So := B.

  Notation Ty := (Ty So).

  Notation TNat := (Base Nat).

  Definition typ f :=
    match f with
      | Zero => TNat
      | Succ => TNat ~~> TNat
      | Rec A => TNat ~~> A ~~> (TNat ~~> A ~~> A) ~~> A
    end.

  Module Export XMap := FMapAVL.Make XOrd.

  Notation En := (@XMap.t Ty).
  Notation empty := (@XMap.empty Ty).
  Notation add := (@XMap.add Ty).
  Notation In := (@XMap.In Ty).
  Notation MapsTo := (@XMap.MapsTo Ty).
  Notation Equal := (@XMap.Equal Ty).
  Notation env := (mk_Env empty add In MapsTo Equal).

End ST_SystemT.

(****************************************************************************)
(** ** [DLQO] structure for the termination proof of System T.

We use [prec] to quasi-order function symbols in a wellfounded way. *)

From CoLoR Require Import SN LCall.

Module DLQO_SystemT <: DLQO_Struct.

  Module Export ST := ST_SystemT.

  Definition C := F.

  Definition code (f : F) := f.

  Import FCmp.

  Definition gtC := Rof gt prec.

  Lemma gtC_wf : WF gtC.

  Proof. apply WF_inverse. apply WF_gt. Qed.

  Definition filter_arity (_ : F) := 1.

  Definition filter (_ : F) := [0].

  Notation gt_call := (@gt_call F X C code gtC).
  Notation gt_args_lex := (@gt_args_lex F X FOrd.eq_dec XOrd.eq_dec ens_X
    var_notin C filter_arity filter).

End DLQO_SystemT.

(****************************************************************************)
(** ** Wellfounded [OrderedType] structure on type constants.

We use the empty relation to quasi-order type constants in a
wellfounded way. *)

From CoLoR Require Import EqUtil.

Module BOrdWF_MOT <: MiniOrderedType.

  Include BTyp.

  Include LeibnizFacts BTyp.

  Definition lt : relation t := empty_rel.

  Global Instance lt_trans : Transitive lt.

  Proof. fo. Qed.

  Lemma lt_not_eq x y : lt x y -> x <> y.

  Proof. fo. Qed.

  Lemma compare x y : Compare lt eq x y.

  Proof. apply EQ. destruct x; destruct y. refl. Qed.

End BOrdWF_MOT.

Module BOrdWF := MOT_to_OT BOrdWF_MOT.

(****************************************************************************)
(** ** [BI] structure (accessible arguments) of System T. *)

From CoLoR Require Import LCompInt.

Module BI_SystemT <: BI_Struct.

  Module Export ST := ST_SystemT.

  Module Export BOrd := BOrdWF.

  Infix "<B" := lt (at level 70).

  Lemma ltB_wf : well_founded lt.

  Proof. intro b. apply Acc_intro. fo. Qed.

  Import SetUtil.

  Inductive acc : F -> set nat :=
  | Acc_Succ : acc Succ 0.

  Definition Acc := acc.

  Lemma Acc_arity f i (hi : Acc f i) : i < arity (typ f).

  Proof. inversion hi; clear hi; subst; simpl; lia. Qed.

  Lemma Acc_ok f i (hi : Acc f i) a :
    occurs a (Vnth (inputs (typ f)) (Acc_arity hi)) ->
    a <B output_base (typ f)
    \/ (a = output_base (typ f)
      /\ pos a (Vnth (inputs (typ f)) (Acc_arity hi))).

  Proof. inversion hi; subst; simpl; clear hi. fo. Qed.

  Notation aeq := (@aeq F X FOrd.eq_dec XOrd.eq_dec ens_X var_notin).
  Notation supterm_acc := (@supterm_acc F X So typ Acc Acc_arity).

End BI_SystemT.

(****************************************************************************)
(** ** [CC] structure for the termination proof of System T. *)

From CoLoR Require Import LCompClos.

Module CC_SystemT <: CC_Struct.

  Module Export BI := BI_SystemT.

  Notation cc := (@cc F X So ens_X env typ Acc Acc_arity).

End CC_SystemT.

(****************************************************************************)
(** ** Termination proof of System T. *)

(*VERY SLOW*)Module Export SN := SN_rewrite CC_SystemT RS_SystemT DLQO_SystemT.

From CoLoR Require Import Lexico.

Import DLQO_SystemT RS_SystemT.

Lemma tr_sn_SystemT : forall E v V, E |- v ~: V -> SN R_aeq v.

Proof.
  apply tr_sn_beta_eta_rewrite_aeq.
  intros l r h; inversion h; subst;
    unfold lhs_fun, lhs_args, lhs_nb_args; simpl.

  (* rule_Rec_Zero *)
  eapply cc_arg' with (i:=1); refl.

  (* rule_Rec_Succ *)
  set (ls := [App FSucc n; u; v]).

  assert (hn : cc gt1 (Rec A) ls ST.empty n TNat).
  eapply cc_acc' with (g:=Succ) (us:=[n]) (i:=0); simpl; try refl.
  eapply cc_arg' with (i:=0); refl.

  assert (hv : cc gt1 (Rec A) ls ST.empty v (TNat ~~> A ~~> A)).
  eapply cc_arg' with (i:=2); simpl; refl.

  assert (hu : cc gt1 (Rec A) ls ST.empty u A).
  eapply cc_arg' with (i:=1); simpl; refl.

  eapply cc_app. eapply cc_app. apply hv. hyp.
  eapply cc_call' with (g:=Rec A) (us:=[n; u; v]); try refl.
  simpl. lia.
  unfold gt1, Def.gt_call, Rof, transp. apply right_lex.
  unfold Def.gt_args_lex, Rof, lexv; simpl. apply lex1. apply opt_intro.
  unfold gt. apply clos_aeq_intro_refl. apply t_step.
  eapply stacc_intro' with (i:=0) (f:=Succ) (ts:=[n]); try refl.
  intros i i1 i2. destruct i. simpl. hyp. destruct i.
  simpl. hyp. destruct i. simpl. hyp. lia.

  Unshelve.
  simpl; lia. simpl; lia. apply Acc_Succ. simpl; lia. simpl; lia. simpl; lia.
  simpl; lia. simpl; lia. simpl; lia. apply Acc_Succ.
Qed.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Import Iron.Language.SystemF2Store.ExpLift.

(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx
  | XLoc _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)

  |  XCon dc ts xs
  => XCon dc (map (substTT d u) ts) (map (substTX d u) xs)

  |  XCase xx alts
  => XCase (substTX d u xx) (map (substTA d u) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (substTT d u) ts) (substTX d u x1) (substTX d u x2)
 end

with substTA (d: nat) (u: ty) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (substTX d u xx)
  end.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d:  nat) (u: exp) (xx: exp) : exp :=
 match xx with
    | XVar ix
    => match nat_compare ix d with
       (* Index matches the one we are substituting for. *)
       | Eq  => u

       (* Index was free in the original expression.
          As we've removed the outermost binder, also decrease this
          index by one. *)
       | Gt  => XVar (ix - 1)

       (* Index was bound in the original expression. *)
       | Lt  => XVar ix
       end

    |  XLoc l
    => XLoc l

    |  XLAM x1
    => XLAM (substXX d (liftTX 0 u) x1)

    |  XAPP x1 t2
    => XAPP (substXX d u x1) t2

    (* Increase the depth as we move across a lambda.
       Also lift free references in the exp being substituted
       across the lambda as we enter it. *)
    |  XLam t1 x2
    => XLam t1 (substXX (S d) (liftXX 1 0 u) x2)

    (* Applications *)
    |  XApp x1 x2
    => XApp (substXX d u x1) (substXX d u x2)

    |  XCon dc ts xs
    => XCon dc ts (map (substXX d u) xs)

    |  XCase x alts
    => XCase (substXX d u x) (map (substXA d u) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (substXX d u x1) (substXX d u x2)
    end

with substXA (d: nat) (u: exp) (aa: alt)
 := match aa with
    |  AAlt (DataCon tag arity) x
    => AAlt (DataCon tag arity)
         (substXX (d + arity)
                  (liftXX arity 0 u) x)
    end.

(* Substitute several expressions.

   Note that in the definition, each time we substitute an
   exp (u), we need to lift it by the number of exps remaining
   in the list (us). This is because we're placing the substitued
   exp under the binders corresponding to the remaining ones.

   The added lifting is then gradually "undone" each time we
   substitue one of the remaining expressions. This happens due
   to the free variable/Gt case in the definition of substX.

   Example:
               (A->B), A |- 0 :: A
               (A->B), A |- 1 :: (A->B)
    (A->B), A, A, (A->B) |- (0 1) [1 0] :: B

    Substitute first exp in list.
            (A->B), A, A |- (2 0) [0] :: B

    We get '2' by adding the length of the remaining substitution
    (1) to the index substituted (1). The argument of the function
    is changed from 1 to 0 by the free variable case of substX.

    Substitute remaining exp in list.
               (A->B), A |- (1 0) :: B

    Here, 0 is subst for 0, and 2 changes to 1 due as it's a free
    variable.
*)
Fixpoint substXXs (d: nat) (us: list exp) (xx: exp) :=
 match us with
 | nil      => xx
 | u :: us' => substXXs d us'
                 (substXX d (liftXX (List.length us') 0 u)
                            xx)
 end.

(* The data constructor of an alternative is unchanged
   by exp substitution. *)
Lemma dcOfAlt_substXA
 : forall d u a
 , dcOfAlt (substXA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substXA : global.

(* The data constructor of an alternative is unchanged
   by type substitution. *)
Lemma dcOfAlt_substTA
 : forall d u a
 , dcOfAlt (substTA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substTA : global.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export fcset.

(* ========= About KAssignable ========= *)

(** is KAssignable in list *)
Definition in_KAssignable_dec (a : KAssignable) l :=
  in_dec KAssignable_dec a l.

(** lists of KAssignables are disjoint *)
Definition KAssignables_disj (l1 l2 : list KAssignable) : bool :=
  disj_dec KAssignable_dec l1 l2.

(** list l1 included in list l2 --- non-strict *)
Definition KAssignables_included (l1 l2 : list KAssignable) : bool :=
  included_dec KAssignable_dec l1 l2.

(* substraction (minus) for KAssagnables *)
Definition KAssignables_minus (l1 l2 : list KAssignable) :=
  minus_dec KAssignable_dec l1 l2.

(** intersection of 2 KAssignable lists *)
Definition KAssignables_inter (l1 l2 : list KAssignable) :=
  inter_dec KAssignable_dec l1 l2.

(* ========= About EAssignable ========= *)

(* To be able to remove assignables from eassignables, EA_all should hold
   a list of assignables as such: [EA_all l], corresponding to the collection
   of all variables except l.
 *)
(* EA_all [] represents V U V' *)
Definition EAssignables := @FCset KAssignable.

(** is KAssignable in EAssignables *)
Definition in_eassignables (a : KAssignable) (e : EAssignables) : bool :=
  in_fcset KAssignable_dec a e.

(** EAssignables e1 and e2 are disjoint *)
Definition eassignables_disj (e1 e2 : EAssignables) : bool :=
  fcset_disj KAssignable_dec e1 e2.

(** returns true if one EAssignable is subset of another *)
Definition eassignables_subset (e1 e2 : EAssignables) : bool :=
  fcset_subset KAssignable_dec e1 e2.

Definition EA_assignables (l : list KAssignable) := FCS_finite l.
Definition EA_all (l : list KAssignable) := FCS_infinite l.

(** append for EAssignables *)
Definition EAssignables_app (e1 e2 : EAssignables) : EAssignables :=
  fcset_app KAssignable_dec e1 e2.

(** intersection of EAssignables *)
Definition EAssignables_inter (e1 e2 : EAssignables) : EAssignables :=
  fcset_inter KAssignable_dec e1 e2.

Definition remove_assignables
           (e : EAssignables)
           (vs : list KAssignable) : EAssignables :=
  fcset_remove_list KAssignable_dec e vs.

Definition remove_eassignables (l1 l2 : EAssignables) : EAssignables :=
  fcset_remove KAssignable_dec l1 l2.

(*========= some KAssignables/EAssignables lemmas =========*)

(** a is in subtraction (minus) of two KAssignable lists,
than a is element of first list and it's not in second list *)
Lemma in_KAssignables_minus :
  forall a l1 l2,
    List.In a (KAssignables_minus l1 l2)
    <-> (List.In a l1 /\ ~ List.In a l2).
Proof.
  apply in_minus_dec.
Qed.

(** a is in intersection of two KAssignable lists,
then a is in both lists *)
Lemma in_KAssignables_inter :
  forall a l1 l2,
    List.In a (KAssignables_inter l1 l2)
    <-> (List.In a l1 /\ List.In a l2).
Proof.
  apply in_inter_dec.
Qed.

(**

  if a is not in intersection of two KAssignable lists,
  then a is not element of either of them

 *)
Lemma in_eassignables_app_false_implies :
  forall a e1 e2,
    in_eassignables a (EAssignables_app e1 e2) = false
    ->
    (
      in_eassignables a e1 = false
      /\
      in_eassignables a e2 = false
    ).
Proof.
  apply in_fcset_app_false_implies.
Qed.

(**

  a is in intersectopn of two EAssignables,
  iff a is element of one of them

 *)
Lemma in_eassignables_app_true_iff :
  forall a e1 e2,
    in_eassignables a (EAssignables_app e1 e2) = true
    <->
    (
      in_eassignables a e1 = true
      \/
      in_eassignables a e2 = true
    ).
Proof.
  apply in_fcset_app_true_iff.
Qed.

(** iff v is in EA_assignables l, then v is in list l *)
Lemma in_eassignables_assignables :
  forall v l,
    in_eassignables v (EA_assignables l) = true
    <-> List.In v l.
Proof.
  apply in_fcset_finite.
Qed.

(** if KAssignables form l1 are included in l2 than l1 is subset of l2 *)
Lemma KAssignables_included_prop :
  forall l1 l2,
    KAssignables_included l1 l2 = true
    <-> subset l1 l2.
Proof.
  apply included_dec_prop.
Qed.
Hint Rewrite KAssignables_included_prop : core.

(** returns true if EAssignables are subset of list of KAssignables *)
Definition eassignables_subset_assignables
           (e : EAssignables)
           (l : list KAssignable) : bool :=
  fcset_subset_list KAssignable_dec e l.

(** if EAssignables e is subset of list of KAssignables l,
as well as a is in e, then a is in lilst l *)
Lemma eassignables_subset_assignables_prop :
  forall e l a,
    eassignables_subset_assignables e l = true
    -> in_eassignables a e = true
    -> List.In a l.
Proof.
  apply fset_subset_list_prop.
Qed.

(** if two list of KAssignables l1 and l2 are disjoint, then l1 and l2 are disjoint *)
Lemma KAssignables_disj_prop :
  forall l1 l2,
    KAssignables_disj l1 l2 = true
    <-> disjoint l1 l2.
Proof.
  apply disj_dec_prop.
Qed.
Hint Rewrite KAssignables_disj_prop : core.

(** if EAssignables e1 is subset of EAssignables subset e2,
and a is in e1 then a is in e2 *)
Lemma eassignables_subset_prop :
  forall e1 e2 a,
    eassignables_subset e1 e2 = true
    -> in_eassignables a e1 = true
    -> in_eassignables a e2 = true.
Proof.
  apply fcset_subset_prop.
Qed.

(** conversion form variable to KAssigable *)
Definition KAssignable_x : KAssignable :=
  KAssignVar (variable "x").

(** we need this in order to prove eassignables_subset_iff lemma *)
Fixpoint KAssignable2str (a : KAssignable) : String.string :=
  match a with
  | KAssignVar (variable x) => x
  | KAssignDiff x => KAssignable2str x
  end.

Lemma fresh_kvariable : FreshFun KVariable.
Proof.
  unfold FreshFun.
  introv.

  exists (variable (String.append "x" (append_string_list (map KVariable2string l)))).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  match goal with
  | [ H : ?a = ?b |- _ ] =>
    assert (KVariable2string a = KVariable2string b) as xx by (rewrite <- H; auto)
  end.
  simpl in xx.
  unfold KAssignable2string in xx.

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list (map KVariable2string l)))) as e.
  { rewrite <- xx; auto. }
  allrw string_length_append.
  omega.
Defined.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma fresh_string : FreshFun String.string.
Proof.
  unfold FreshFun.
  introv.

  exists (String.append "x" (append_string_list l)).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list l))) as e by (rw <- k; auto).
  allrw string_length_append.
  omega.
Defined.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma fresh_kassignable : FreshFun KAssignable.
Proof.
  unfold FreshFun.
  introv.

  exists (KAssignVar (variable (String.append "x" (append_string_list (map KAssignable2string l))))).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  match goal with
  | [ H : ?a = ?b |- _ ] =>
    assert (KAssignable2str a = KAssignable2str b) as xx by (rewrite <- H; auto)
  end.
  simpl in xx.
  unfold KAssignable2string in xx.

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list (map KAssignable2string l)))) as e.
  { unfold KAssignable2string.
    rewrite <- xx.
    clear xx k s extra IHl l.
    induction a; simpl; auto. }
  allrw string_length_append.
  omega.
Defined.

(** iff a is in EAssignables e1 from which EAssignables e2 are removed,
ihant a is in e1, and it's not in e2 *)
Lemma in_eassignables_remove_eassignables :
  forall a e1 e2,
    in_eassignables a (remove_eassignables e1 e2) = true
    <-> (in_eassignables a e1 = true /\ not (in_eassignables a e2 = true)).
Proof.
  apply in_fcset_remove.
Qed.

(** if list of KAssignables is in nil, then l is nil *)
Lemma KAssignables_included_nil_implies :
  forall l, KAssignables_included l [] = true -> l = [].
Proof.
  apply included_dec_nil_implies.
Qed.

(** if e is subset of append of two EAssignables,
then e is subset of both EAssignables *)
Lemma eassignables_subset_app_l_true_iff :
  forall e1 e2 e,
    eassignables_subset (EAssignables_app e1 e2) e = true
    <-> (eassignables_subset e1 e = true /\ eassignables_subset e2 e = true).
Proof.
  apply fcset_subset_app_l_true_iff.
  apply fresh_kassignable.
Qed.

(** if e is susbset of e1 and e is subset of e2, the e is subset of append of e1 and e2 *)
Lemma implies_eassignables_subset_app_r_true :
  forall e1 e2 e,
    (eassignables_subset e e1 = true \/ eassignables_subset e e2 = true)
    -> eassignables_subset e (EAssignables_app e1 e2) = true.
Proof.
  apply implies_fcset_subset_app_r_true.
  apply fresh_kassignable.
Qed.

(** if a is susbset of v then append of a and b is subset of append of v and b *)
Lemma eassignables_subset_app_right :
  forall a b v,
    eassignables_subset a v = true
    -> eassignables_subset (EAssignables_app a b) (EAssignables_app v b) = true.
Proof.
  apply fcset_subset_app_right.
Qed.

(** if a is in intersection of EAssignables e1 and e2, then a is e1 and a is in e2 *)
Lemma in_eassignables_inter_iff :
  forall a e1 e2,
    in_eassignables a (EAssignables_inter e1 e2) = true
    <-> (in_eassignables a e1 = true /\ in_eassignables a e2 = true).
Proof.
  apply in_fcset_inter_iff.
Qed.

(** if e is subset of EAssignables e1 and e is subset of EAssignables e2,
then e is subset of intersection of e1 and e2 *)
Lemma implies_eassignables_subset_inter_l_true :
  forall e1 e2 e,
    (eassignables_subset e1 e = true \/ eassignables_subset e2 e = true)
    -> eassignables_subset (EAssignables_inter e1 e2) e = true.
Proof.
  apply implies_fcset_subset_inter_l_true.
  apply fresh_kassignable.
Qed.

(** if EAssignables e1 is subset of EAssignables e2,
every a which is in e1, is in e2 *)
Lemma eassignables_subset_iff :
  forall e1 e2,
    eassignables_subset e1 e2 = true
    <-> (forall a, in_eassignables a e1 = true -> in_eassignables a e2 = true).
Proof.
  apply fcset_subset_iff.
  apply fresh_kassignable.
Qed.

(** reflexivity for subsets of EAssignables *)
Lemma eassignables_subset_refl :
  forall e, eassignables_subset e e = true.
Proof.
  apply fcset_subset_refl.
Qed.
Hint Resolve eassignables_subset_refl : core.

(** transitivity of subsets of EAssignables *)
Lemma eassignables_subset_trans :
  forall e1 e2 e3,
    eassignables_subset e1 e2 = true
    -> eassignables_subset e2 e3 = true
    -> eassignables_subset e1 e3 = true.
Proof.
  apply fcset_subset_trans.
Qed.

(** if x is removed from e, and then appended to it,
e is subset of that set  *)
Lemma eassignables_subset_app_remove :
  forall e x,
    eassignables_subset e (EAssignables_app (remove_eassignables e x) x) = true.
Proof.
  apply fcset_subset_app_remove.
Qed.

(** subtraction (minus) of l2 on append of l1 and l3
is same as subtraction of l3 from subtraction of l2 from l1 *)
Lemma KAssignables_minus_app_r :
  forall l1 l2 l3,
    KAssignables_minus l1 (l2 ++ l3)
    = KAssignables_minus (KAssignables_minus l1 l2) l3.
Proof.
  apply minus_dec_app_r.
Qed.

(** swap for subtraction (minus) of three lists *)
Lemma KAssignables_minus_swap :
  forall l1 l2 l3,
    KAssignables_minus (KAssignables_minus l1 l2) l3
    = KAssignables_minus (KAssignables_minus l1 l3) l2.
Proof.
  apply minus_dec_swap.
Qed.

(** if l1 is subset of l3, then subtraction (minus) of list l3
from intersection of lists l1 and l2 returns nil *)
Lemma KAssignables_minus_inter_cancel_ss :
  forall l1 l2 l3,
    subset l1 l3
    -> KAssignables_minus (KAssignables_inter l1 l2) l3 = [].
Proof.
  apply minus_inter_dec_cancel_ss.
Qed.

(** subtraction (minus) of list l1 of KAssignables from intersection of
that list with list l2 returns nil *)
Lemma KAssignables_minus_inter_cancel :
  forall l1 l2,
    KAssignables_minus (KAssignables_inter l1 l2) l1 = [].
Proof.
  apply minus_inter_dec_cancel.
Qed.

(** subtraction (minus) and intersection on list of KAssignables can be swapped *)
Lemma KAssignables_inter_minus_swap :
  forall l1 l2 l3,
    KAssignables_inter (KAssignables_minus l1 l2) l3
    = KAssignables_minus (KAssignables_inter l1 l3) l2.
Proof.
  apply inter_minus_dec_swap.
Qed.

(** intersection of list l of KAssignables with nil, returns nil *)
Lemma KAssignables_inter_nil_r :
  forall l, KAssignables_inter l [] = [].
Proof.
  apply inter_dec_nil_r.
Qed.
Hint Rewrite KAssignables_inter_nil_r : core.

(** symmentry of intersection of two lists of KAssignables *)
Lemma KAssignables_inter_sym :
  forall l1 l2,
    eqset
      (KAssignables_inter l1 l2)
      (KAssignables_inter l2 l1).
Proof.
  apply inter_dec_sym.
Qed.

(** equality for EAssignables *)
Definition eassignables_eq (e1 e2 : EAssignables) : Prop :=
  fcset_eq KAssignable_dec e1 e2.

(** reflexivity for equality of EAssignables *)
Lemma eassignables_eq_refl :
  forall e, eassignables_eq e e.
Proof.
  apply fcset_eq_refl.
Qed.
Hint Resolve eassignables_eq_refl : core.

(** iff EAssinables in FCS_infinite l1 (complement of list l1)
are equal to EAssignables in EA_lll l2 (complement of list l2)
list l1 and l2 are equal*)
Lemma eassignables_eq_FCS_infinite :
  forall l1 l2,
    eassignables_eq (FCS_infinite l1) (FCS_infinite l2)
    <-> eqset l1 l2.
Proof.
  apply fcset_eq_FCS_infinite.
Qed.

(** if list l1 is equal to l3, and l2 is equal to l4
list of KAssignables gained by subtraction (minus) of l2 form l2
is same as list of KAssignables gained by subtraction (minus) of l4 form l3 *)
Lemma implies_eqset_KAssignables_minus :
  forall l1 l2 l3 l4,
    eqset l1 l3
    -> eqset l2 l4
    -> eqset (KAssignables_minus l1 l2) (KAssignables_minus l3 l4).
Proof.
  apply implies_eqset_minus_dec.
Qed.

(** associativity of intersection of KAssignables *)
Lemma KAssignables_inter_assoc :
  forall l1 l2 l3,
    KAssignables_inter (KAssignables_inter l1 l2) l3
    = KAssignables_inter l1 (KAssignables_inter l2 l3).
Proof.
  apply inter_dec_assoc.
Qed.

(** associativity for EAassignables *)
Lemma EAssignables_app_assoc :
  forall e1 e2 e3,
    eassignables_eq
      (EAssignables_app (EAssignables_app e1 e2) e3)
      (EAssignables_app e1 (EAssignables_app e2 e3)).
Proof.
  apply fcset_app_assoc.
Qed.

(** list of KAssignables l minus nil returns list l *)
Lemma KAssignables_minus_nil_r :
  forall l, KAssignables_minus l [] = l.
Proof.
  apply minus_dec_nil_r.
Qed.
Hint Rewrite KAssignables_minus_nil_r : core.

(** nil appended to EAssigbales returns EAssignables *)
Lemma EAssignables_app_EA_assignables_nil_r :
  forall e, EAssignables_app e (EA_assignables []) = e.
Proof.
  apply fcset_app_nil_r.
Qed.
Hint Rewrite EAssignables_app_EA_assignables_nil_r : core.

Lemma EAssignables_app_all_left :
  forall e,
    EAssignables_app (EA_all []) e = EA_all [].
Proof.
  apply fcset_app_all_left.
Qed.
Hint Rewrite EAssignables_app_all_left : core.

Lemma EAssignables_app_all_right :
  forall e,
    EAssignables_app e (EA_all []) = EA_all [].
Proof.
  apply fcset_app_all_right.
Qed.
Hint Rewrite EAssignables_app_all_right : core.

Lemma eassignables_subset_all_implies :
  forall V,
    eassignables_subset (EA_all []) V = true
    -> V = EA_all [].
Proof.
  apply fcset_subset_all_implies.
Qed.

Lemma eassignables_disj_prop :
  forall e1 e2 x,
    eassignables_disj e1 e2 = true
    -> in_eassignables x e1 = true
    -> in_eassignables x e2 = false.
Proof.
  apply fcset_disj_prop.
Qed.

Lemma eassignables_subset_nil_implies :
  forall e,
    eassignables_subset e (EA_assignables []) = true
    -> e = EA_assignables [].
Proof.
  apply fcset_subset_nil_implies.
Qed.

Lemma EAssignables_app_eq_nil_implies :
  forall a b,
    EAssignables_app a b = EA_assignables []
    -> (a = EA_assignables [] /\ b = EA_assignables []).
Proof.
  apply fcset_app_eq_nil_implies.
Qed.

Lemma eassignables_disj_sym :
  forall e1 e2 : EAssignables,
    eassignables_disj e1 e2 = true
    -> eassignables_disj e2 e1 = true.
Proof.
  apply fcset_disj_sym.
Qed.

Lemma eassignables_disj_EAssignables_app_l :
  forall e1 e2 e,
    eassignables_disj (EAssignables_app e1 e2) e = true
    <-> (eassignables_disj e1 e = true /\ eassignables_disj e2 e = true).
Proof.
  apply fcset_disj_app_l.
Qed.


(* Liveness Analysis *)

(** Liveness analysis on SpecIR *)
(* Inspired by CompCert analysis over RTL *)

Require Import Coqlib.
Require Import Maps.
Require Import Kildall.
Require Import Lattice.
Require Import IR.
Require Import IRinterpreter.
Require Import Ordered.
Require Import Coq.MSets.MSetPositive.
Require Import common.
Require Import Errors.
Require Import RTL.

(** A register [r] is live at a point [p] if there exists a path
  from [p] to some instruction that uses [r] as argument,
  and [r] is not redefined along this path.
  Liveness can be computed by a backward dataflow analysis.
  The analysis operates over sets of (live) pseudo-registers. *)

(* Basic definitions over register sets *)
Definition regset: Type := PositiveSet.t.
Lemma regset_eq_refl: forall x, PositiveSet.eq x x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_sym: forall x y, PositiveSet.eq x y -> PositiveSet.eq y x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_trans: forall x y z, PositiveSet.eq x y -> PositiveSet.eq y z -> PositiveSet.eq x z.
Proof. apply PositiveSet.eq_equiv. Qed.

(* Definition of the lattice used to compute liveness *)
Module LiveFlatRegset <: SEMILATTICE.

Definition t : Type := regset.

Definition eq (x y: t) : Prop :=
  PositiveSet.Equal x y.

Lemma eq_refl: forall x, eq x x.
Proof. apply regset_eq_refl. Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof. apply regset_eq_sym. Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof. apply regset_eq_trans. Qed.

Definition beq (x y: t) : bool := PositiveSet.equal x y.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold eq. intros. apply PositiveSet.equal_spec. auto.
Qed.

Definition ge (x y: t) : Prop :=
  PositiveSet.Subset y x.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge. intros x y EQ r IN. apply EQ. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge. intros x y z Hxy Hyz r IN. auto.
Qed.

Definition bot: t := PositiveSet.empty.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge. intros x r IN. inv IN.
Qed.

Definition lub (x y: t) : t :=
  PositiveSet.union x y.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  intros x y r IN. apply PositiveSet.union_spec. left. auto.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  intros x y r IN. apply PositiveSet.union_spec. right. auto.
Qed.

End LiveFlatRegset.

Definition live_abs_dr: Type := regset.

(* Starting the analysis, no registers are live *)
Definition live_entry_abs_dr: live_abs_dr :=
  PositiveSet.empty.

(* Associating a live_abs_dr to each label *)
Definition live_abs_state : Type := PMap.t live_abs_dr.
Definition live_absstate_get (pc:label) (abs:live_abs_state) : live_abs_dr :=
  PMap.get pc abs.

(* Inserting a new live register into an abstract set *)
Definition reg_live (r:reg) (adr:live_abs_dr) : live_abs_dr :=
  PositiveSet.add r adr.

(* Removing a new live register from an abstract set *)
Definition reg_dead (r:reg) (adr:live_abs_dr) : live_abs_dr :=
  PositiveSet.remove r adr.

(* Inserting a list of live registers *)
Fixpoint reg_list_live
             (rl: list reg) (lv: live_abs_dr) : live_abs_dr :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_live r1 (reg_list_live rs lv)
  end.

(* Removing a list of live registers *)
Fixpoint reg_list_dead
             (rl: list reg) (lv: live_abs_dr) : live_abs_dr :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_list_dead rs (reg_dead r1 lv)
  end.

(* Various operations on regsets, used in transfer function *)
Definition expr_live (expr: expr) (after: live_abs_dr): live_abs_dr :=
  match expr with
  | ZAR _ => after
  | UNA _ r => reg_live r after
  | BIN _ r1 r2 => reg_live r1 (reg_live r2 after)
  end.

Fixpoint expr_list_live (exl: list expr) (after: live_abs_dr): live_abs_dr :=
  match exl with
  | nil => after
  | e::t => expr_live e (expr_list_live t after)
  end.

Fixpoint varmap_live (vm: varmap) (after: live_abs_dr): live_abs_dr :=
  match vm with
  | nil => after
  | (r,e)::t => expr_live e (varmap_live t after)
  end.

(** Here is the transfer function for the dataflow analysis.
  Since this is a backward dataflow analysis, it takes as argument
  the abstract register set ``after'' the given instruction,
  i.e. the registers that are live after; and it returns as result
  the abstract register set ``before'' the given instruction,
  i.e. the registers that must be live before.
  The general relation between ``live before'' and ``live after''
  an instruction is that a register is live before if either
  it is one of the arguments of the instruction, or it is not the result
  of the instruction and it is live after. *)
(* The transf function that updates live_abs_dr *)
Definition live_dr_transf
            (c: IR.code) (pc: positive) (after: live_abs_dr) : live_abs_dr :=
  match c!pc with
  | None =>
    PositiveSet.empty
  | Some i =>
    match i with
    | Nop next => after
    | IPrint e next => expr_live e after
    | MemSet adreg valreg next =>
      reg_live adreg (reg_live valreg after)
    | MemGet dstreg adreg next =>
      reg_live adreg (reg_dead dstreg after)
    | Call f args retreg next =>
      reg_list_live args (reg_dead retreg after)
    | Cond r tr fl => reg_live r after
    | Return e =>
      expr_live e after
    | Op r ex next =>
      expr_live ex (reg_dead r after)
    | Assume guard tgt vm next =>
        expr_live guard (varmap_live vm after)
    | Anchor tgt vm next =>
        varmap_live vm after
    end
  end.

(** The liveness analysis is then obtained by instantiating the
  general framework for backward dataflow analysis provided by
  module [Kildall].  *)
Module DS := Backward_Dataflow_Solver (LiveFlatRegset) (NodeSetBackward).

Definition list_entries (f: version) : list (label * live_abs_dr) :=
  ((ver_entry f), PositiveSet.empty)::nil.

Definition liveness_analyze (f: version): option live_abs_state :=
  DS.fixpoint (ver_code f) (IR.successors) (live_dr_transf (ver_code f)).

(** Basic property of the liveness information computed by [analyze]. *)
Lemma liveness_successor:
  forall f live n i s,
  liveness_analyze f = Some live ->
  (ver_code f)!n = Some i ->
  In s (successors i) ->
  PositiveSet.Subset (live_dr_transf (ver_code f) s (live_absstate_get s live)) (live_absstate_get n live).
Proof.
  unfold liveness_analyze. intros. eapply DS.fixpoint_solution; eauto.
  intros n0 a H2. unfold live_dr_transf. rewrite H2. unfold DS.L.bot.
  apply DS.L.eq_refl.
Qed.

(* Basic inclusions of regsets *)
Lemma reg_live_subset:
  forall r live, PositiveSet.Subset live (reg_live r live).
Proof.
  unfold PositiveSet.Subset. unfold reg_live. intros.
  apply PositiveSet.add_spec. right. auto.
Qed.

Lemma expr_live_subset:
  forall e rs, PositiveSet.Subset rs (expr_live e rs).
Proof.
  unfold PositiveSet.Subset. unfold expr_live. intros.
  destruct e;
    repeat (apply PositiveSet.add_spec; right); auto.
Qed.

Lemma reg_list_live_subset:
  forall rl rs, PositiveSet.Subset rs (reg_list_live rl rs).
Proof.
  unfold PositiveSet.Subset. induction rl; intros; auto.
  simpl. apply reg_live_subset. apply IHrl. auto.
Qed.

Lemma expr_list_live_subset:
  forall exl rs, PositiveSet.Subset rs (expr_list_live exl rs).
Proof.
  unfold PositiveSet.Subset. induction exl; intros; auto.
  simpl. apply expr_live_subset. auto.
Qed.

Lemma varmap_subset:
  forall v rs, PositiveSet.Subset rs (varmap_live v rs).
Proof.
  unfold PositiveSet.Subset. intros v rs. induction v; intros; auto. destruct a.
  simpl. apply expr_live_subset. apply IHv. auto.
Qed.

Lemma in_or_not:
  forall (l:label) l_fs,
    In l l_fs \/ ~ In l l_fs.
Proof.
  intros l l_fs. induction l_fs.
  - right. unfold not; intros. inv H.
  - poseq_destr a l.
    + left. simpl. left. auto.
    + destruct IHl_fs; [left | right]; simpl; try (right; auto).
      unfold not. intros [EQ | IN]; auto.
Qed.

(** * AGREEEMENT  *)
(* This to relate regmaps with regsets *)
(* But IR_to_RTLBlock uses its own version of agreement *)

(* Two regmaps agree on a regset iff they have the same values
   on the registers of the regset (may be None) *)
Definition agree (rm1 rm2:reg_map) (adr:live_abs_dr) :=
  forall r:reg, PositiveSet.In r adr -> rm1 # r = rm2 # r.

Lemma agree_refl:
  forall rs rm,
    agree rm rm rs.
Proof.
  unfold agree. intros. auto.
Qed.

Lemma agree_sym:
  forall rs rm1 rm2,
    agree rm1 rm2 rs ->
    agree rm2 rm1 rs.
Proof.
  unfold agree. intros. symmetry. auto.
Qed.

Lemma agree_trans:
  forall rs rm1 rm2 rm3,
    agree rm1 rm2 rs ->
    agree rm2 rm3 rs ->
    agree rm1 rm3 rs.
Proof.
  unfold agree. intros. rewrite H; auto.
Qed.

Lemma agree_subset:
  forall rs1 rs2 rms rmo,
    PositiveSet.Subset rs1 rs2 ->
    agree rms rmo rs2 ->
    agree rms rmo rs1.
Proof.
  unfold agree. intros. auto.
Qed.

(* Liveness transfer preserves agree *)
Lemma agree_transfer:
  forall live rms rmo f pc pc' i,
    liveness_analyze f = Some live ->
    (ver_code f)!pc = Some i ->
    In pc' (successors i) ->
    agree rms rmo (live!!pc) ->
    agree rms rmo (live_dr_transf (ver_code f) pc' (live!!pc')).
Proof.
  intros. apply agree_subset with (live!!pc); auto.
  eapply liveness_successor; eauto.
Qed.

(* The following lemmas express the fact that agreeing on the regset obtained
   after adding registers implies agreeing on the original regset
   (which contains less registers) *)
Lemma reg_live_agree:
  forall e rs rms rmo,
    agree rms rmo (reg_live e rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply reg_live_subset.
Qed.

Lemma expr_live_agree:
  forall e rs rms rmo,
    agree rms rmo (expr_live e rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply expr_live_subset.
Qed.

Lemma expr_list_live_agree:
  forall exl rs rms rmo,
    agree rms rmo (expr_list_live exl rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply expr_list_live_subset.
Qed.

Lemma reg_list_live_agree:
  forall exl rs rms rmo,
    agree rms rmo (reg_list_live exl rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply reg_list_live_subset.
Qed.

(* Lemma movelist_live_agree: *)
(*   forall ml rs rms rmo, *)
(*     agree rms rmo (movelist_live ml rs) -> *)
(*     agree rms rmo rs. *)
(* Proof. *)
(*   intros. eapply agree_subset; eauto. apply movelist_subset. *)
(* Qed. *)

Lemma varmap_live_agree:
  forall vm rs rms rmo,
    agree rms rmo (varmap_live vm rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply varmap_subset.
Qed.

(* Lemma synth_live_agree: *)
(*   forall sl rs rms rmo, *)
(*     agree rms rmo (synth_live sl rs) -> *)
(*     agree rms rmo rs. *)
(* Proof. *)
(*   intros. eapply agree_subset; eauto. apply synth_subset. *)
(* Qed. *)

Lemma agree_eval_reg:
  forall r v rs rms rmo ,
    agree rms rmo (reg_live r rs) ->
    eval_reg r rms = OK v ->
    eval_reg r rmo = OK v.
Proof.
  intros. unfold agree in H. unfold eval_reg in H0. rewrite H in H0.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    unfold eval_reg. rewrite H0. simpl. auto.
Qed.

(* If two regmaps agree on the registers used for the evaluation of e,
   then e evaluates to the same value in both regmaps *)
Lemma agree_eval_expr:
  forall e v rs rms rmo ,
    agree rms rmo (expr_live e rs) ->
    eval_expr e rms = OK v ->
    eval_expr e rmo = OK v.
Proof.
  intros. destruct e; simpl in H0.
  - destruct (eval_reg r rms) eqn:EVALL; inv H0.
    destruct (eval_reg r0 rms) eqn:EVALR; inv H2.
    unfold agree in H. unfold eval_reg in EVALL. rewrite H in EVALL.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    unfold eval_reg in EVALR. rewrite H in EVALR.
    2: { simpl. apply PositiveSet.add_spec. right. apply PositiveSet.add_spec. auto. }
    simpl. unfold eval_reg. rewrite EVALL. rewrite EVALR. simpl. auto.
  - destruct (eval_reg r rms) eqn:EVAL; inv H0.
    unfold agree in H. unfold eval_reg in EVAL. rewrite H in EVAL.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    simpl. unfold eval_reg. rewrite EVAL. simpl. auto.
  - destruct z. inv H0. simpl. auto.
Qed.

(* If two regmaps agree on the registers used for the evaluation of
   the list of expressions [le], then [le] evaluates to the same boolean value
   in both regmaps *)
(* Lemma agree_eval_list_expr: *)
(*   forall rs rm1 rm2 le b, *)
(*     agree rm1 rm2 (expr_list_live le rs) -> *)
(*     eval_list_expr le rm1 b -> *)
(*     eval_list_expr le rm2 b. *)
(* Proof. *)
(*   intros. generalize dependent b. induction le; intros; inv H0; try constructor. *)
(*   - eapply agree_eval_expr in EVAL; eauto. *)
(*   - eapply agree_eval_expr in EVALH; eauto. *)
(*     econstructor; eauto. apply IHle; auto. *)
(*     unfold agree in *. intros. apply H. simpl. *)
(*     eapply expr_live_subset; eauto. *)
(* Qed. *)

(* If two regmaps agree on the registers used for the evaluation of
   the list of expressions [le], then each expression of [le] evaluates to the same value
   in both regmaps *)
Lemma agree_eval_list:
  forall rs rm1 rm2 le lv,
    agree rm1 rm2 (expr_list_live le rs) ->
    eval_list le rm1 = OK lv ->
    eval_list le rm2 = OK lv.
Proof.
  intros. generalize dependent lv.
  induction le; intros.
  - inv H0. simpl. auto.
  - simpl in H0. destruct (eval_expr a rm1) eqn:EVAL1; inv H0.
    eapply agree_eval_expr in EVAL1; eauto.
    destruct (eval_list le rm1) eqn:EVAL2; inv H2.
    simpl. rewrite EVAL1. simpl.
    assert (OK l = OK l) by auto. apply IHle in H0.
    2: { eapply agree_subset; eauto. apply expr_live_subset. }
    rewrite H0. simpl. auto.
Qed.

Lemma agree_eval_list_reg:
  forall rs rm1 rm2 le lv,
    agree rm1 rm2 (reg_list_live le rs) ->
    eval_list_reg le rm1 = OK lv ->
    eval_list_reg le rm2 = OK lv.
Proof.
  intros. generalize dependent lv.
  induction le; intros.
  - inv H0. simpl. auto.
  - simpl in H0. destruct (eval_reg a rm1) eqn:EVAL1; inv H0.
    eapply agree_eval_reg in EVAL1; eauto.
    destruct (eval_list_reg le rm1) eqn:EVAL2; inv H2.
    simpl. rewrite EVAL1. simpl.
    assert (OK l = OK l) by auto. apply IHle in H0.
    2: { eapply agree_subset; eauto. simpl.
         apply reg_live_subset. }
    rewrite H0. simpl. auto.
Qed.

(* Auxiliary lemmas on movelists *)
(* If a register is not assigned by a movelist, it contains the same value
   before and after the update *)
(* Lemma not_use_movelist: *)
(*   forall ml r rm rmu, *)
(*     ~(In r (map fst ml)) -> *)
(*     update_movelist ml rm rmu -> *)
(*     rm ! r = rmu ! r. *)
(* Proof. *)
(*   induction ml; intros. *)
(*   - inv H0. auto. *)
(*   - inv H0. poseq_destr r r0. *)
(*     + simpl in H. unfold not in H. *)
(*       exfalso. apply H. left. auto.  *)
(*     + rewrite PTree.gso; auto. simpl in H. *)
(*       eapply Classical_Prop.not_or_and in H as [NEQ NIN]. apply IHml; auto. *)
(* Qed. *)

(* If a register is assigned by a movelist and two regmaps agree on all the
   registers whose value is needed to evaluate all the expressions of
   the movelist, then we can decompose the movelist appropriately *)
(* Lemma reg_in_movelist: *)
(*   forall ml r rs rm1 rm2, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     In r (map fst ml) -> *)
(*     exists ml1 ml2 e rs', *)
(*       ml = ml1 ++ (r,e)::ml2 /\ ~(In r (map fst ml1)) /\ *)
(*       agree rm1 rm2 (expr_live e rs'). *)
(* Proof. *)
(*   induction ml; intros; inv H0. *)
(*   - simpl in H. destruct a. exists nil, ml, e, (movelist_live ml rs). *)
(*     split; auto. *)
(*   - simpl in H. destruct a. *)
(*     apply IHml with r rs rm1 rm2 in H1 as [ml1 [ml2 [e' [rs' [EQ [NIN AGREE]]]]]]. *)
(*     2: { eapply expr_live_agree. eauto. } *)
(*     poseq_destr r r0. *)
(*     + exists nil, (ml1 ++ (r0,e')::ml2), e, (movelist_live (ml1 ++ (r0, e') :: ml2) rs). *)
(*       split; auto. *)
(*     + exists ((r0,e)::ml1), ml2, e', rs'. subst. *)
(*       split; auto; try split; auto. *)
(*       simpl. intros [EQ' | IN]; subst; auto. *)
(* Qed. *)

(* If we assign a register [r] with a movelist, and two regmaps agree on the
   registers used by the expression assigned to [r], then they agree on [r]
   after the update no matter what was the value before *)
(* Lemma use_movelist: *)
(*   forall ml1 ml2 ml r e rs rm1 rm1u rm2 rm2u, *)
(*     ml = ml1 ++ (r,e)::ml2 -> *)
(*     ~(In r (map fst ml1)) -> *)
(*     agree rm1 rm2 (expr_live e rs) -> *)
(*     update_movelist ml rm1 rm1u -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     rm1u ! r = rm2u ! r. *)
(* Proof. *)
(*   induction ml1. *)
(*   - intros. inv H2; inv H4. *)
(*     inv H3. rewrite PTree.gss. rewrite PTree.gss. f_equal. *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     eapply eval_expr_determ; eauto. *)
(*   - intros. inv H2; inv H4. *)
(*     inv H3. assert (r <> r0). *)
(*     { intros contra. apply H0. simpl. left. auto. } *)
(*     rewrite PTree.gso; auto. rewrite PTree.gso; auto. *)
(*     eapply IHml1; eauto. intros contra. simpl in H0. *)
(*     apply H0. right. auto. *)
(* Qed. *)

(* Two agreeing regmaps still agree after having the same update *)
(* Lemma agree_update_movelist_aux: *)
(*   forall ml rs rm1 rm2 rm1u rm2u, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     update_movelist ml rm1 rm1u -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     agree rm1u rm2u (movelist_live ml rs). *)
(* Proof. *)
(*   induction ml; intros; inv H0; inv H1; auto. *)
(*   unfold agree. intros. *)
(*   simpl in H0. simpl in H. poseq_destr r r0. *)
(*   - repeat rewrite PTree.gss. f_equal. *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     eapply eval_expr_determ; eauto. *)
(*   - repeat (rewrite PTree.gso; auto). *)
(*     assert (In r0 (map fst ml) \/ ~(In r0 (map fst ml))) as [IN' | NIN'] by (apply in_or_not). *)
(*     + eapply reg_in_movelist in IN' as [ml1 [ml2 [e' [rs' [EQ [NIN'' AGREE]]]]]]; eauto. *)
(*       * eapply use_movelist; eauto. *)
(*       * eapply expr_live_agree; eauto. *)
(*     + assert (rm1 ! r0 = rm' ! r0). *)
(*       { eapply not_use_movelist; eauto. } *)
(*       assert (rm2 ! r0 = rm'0 ! r0). *)
(*       { eapply not_use_movelist; eauto. } *)
(*       rewrite <- H1. rewrite <- H2. apply H. apply H0. *)
(* Qed. *)

(* Lemma agree_update_movelist: *)
(*   forall rs rm1 rm2 rm2u ml, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     exists rm1u, *)
(*       update_movelist ml rm1 rm1u /\ *)
(*       agree rm1u rm2u (movelist_live ml rs). *)
(* Proof. *)
(*   intros. generalize dependent rm2u. induction ml; intros; inv H0. *)
(*   - exists rm1. split; auto. constructor. *)
(*   - assert (UPDATE':= UPDATE). apply IHml in UPDATE as [rm1u [UPDATE EQ]]. *)
(*     2: { unfold agree in *. intros. apply H. simpl. *)
(*          apply expr_live_subset. auto. } *)
(*     apply agree_sym in H. *)
(*     assert (EVAL':=EVAL). *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     exists (rm1u#r<-v). split; try constructor; eauto. *)
(*     apply agree_sym. eapply agree_update_movelist_aux; eauto; econstructor; eauto. *)
(* Qed. *)

Lemma agree_update_regmap:
  forall rs rm1 rm2 newrm vm,
    agree rm1 rm2 (varmap_live vm rs) ->
    update_regmap vm rm2 = OK newrm ->
    update_regmap vm rm1 = OK newrm.
Proof.
  intros. generalize dependent newrm.
  induction vm; intros; inv H0; auto.
  destruct a. destruct (eval_expr e rm2) eqn:EVAL1; inv H2.
  apply agree_sym in H. eapply agree_eval_expr in EVAL1; eauto.
  simpl. rewrite EVAL1. simpl.
  destruct (update_regmap vm rm2) eqn:EVAL2; inv H1.
  assert (OK r0 = OK r0) by auto. apply IHvm in H0.
  rewrite H0. auto.
  eapply expr_live_agree. apply agree_sym in H. simpl in H. eauto.
Qed.

(* Lemma agree_synthesize_frame: *)
(*   forall rs rm1 rm2 p sl stack, *)
(*     agree rm1 rm2 (synth_live sl rs) -> *)
(*     synthesize_frame p rm2 sl stack -> *)
(*     synthesize_frame p rm1 sl stack. *)
(* Proof. *)
(*   intros. generalize dependent stack. *)
(*   induction sl; intros; inv H0; try constructor; auto. *)
(*   - eapply agree_update_regmap in UPDATE; eauto. *)
(*   - apply IHsl; auto. simpl in H. *)
(*     eapply varmap_live_agree. eauto. *)
(* Qed. *)

(* It is sufficient to agree on all the registers of [rs] excepted [reg]
   before an assignation provided we assign the same value to [reg]
   on both sides *)
Lemma agree_insert_dead:
  forall rs rm rm_opt reg v,
    agree rm rm_opt (reg_dead reg rs) ->
    agree (rm # reg <- v) (rm_opt # reg <- v) rs.
Proof.
  intros. unfold agree in *.
  intros r IN. poseq_destr r reg.
  - rewrite PTree.gss. rewrite PTree.gss. auto.
  - rewrite PTree.gso; auto. rewrite PTree.gso; auto. apply H.
    apply PositiveSet.remove_spec; split; auto.
Qed.

(* updating the rm on both sides *)
Lemma agree_insert:
  forall rs rm rm_opt reg v,
    agree rm rm_opt rs ->
    agree (rm # reg <- v) (rm_opt # reg <- v) rs.
Proof.
  intros. apply agree_subset with (reg_dead reg rs) rs rm rm_opt in H.
  - apply agree_insert_dead. auto.
  - intros r IN. apply PositiveSet.remove_spec in IN as [IN _]. auto.
Qed.

(* Lemma agree_movelist_live: *)
(*   forall ml rs rs' rms rmo, *)
(*     agree rms rmo (movelist_live ml rs) -> *)
(*     agree rms rmo rs -> *)
(*     agree rms rmo rs' -> *)
(*     agree rms rmo (movelist_live ml rs'). *)
(* Proof. *)
(*   induction ml; intros; auto. *)
(*   simpl. destruct a. simpl in H. intros r' IN. *)
(*   destruct e; destruct o; try destruct o0; simpl in *; *)
(*     try (apply (IHml rs rs' rms rmo); assumption); poseq_destr r' r0; *)
(*       try (apply H; apply PositiveSet.add_spec; left; reflexivity). *)
(*   - poseq_destr r' r1. *)
(*     + apply H. apply PositiveSet.add_spec. right. *)
(*       apply PositiveSet.add_spec. left. auto. *)
(*     + apply (IHml rs rs' rms rmo); auto. *)
(*       * eapply agree_subset; try apply H. *)
(*         intros reg IN'. repeat (apply PositiveSet.add_spec; right; auto). *)
(*       * repeat (apply PositiveSet.add_spec in IN as [contra | IN]; auto; *)
(*                 try contradiction). *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(* Qed. *)

(* Lemma movelist_reg_dead_subset: *)
(*   forall ml r rs, *)
(*     PositiveSet.Subset (movelist_dead ml (reg_dead r rs)) (reg_dead r (movelist_dead ml rs)). *)
(* Proof. *)
(*   induction ml; intros. *)
(*   - simpl. intros r' IN. auto. *)
(*   - simpl. destruct a. intros r' IN. poseq_destr r' r0. *)
(*     + apply PositiveSet.remove_spec in IN as [_ contra]. destruct contra. auto. *)
(*     + poseq_destr r' r. *)
(*       * apply PositiveSet.remove_spec in IN as [IN _]. apply IHml in IN. *)
(*         apply PositiveSet.remove_spec in IN as [_ contra]. destruct contra. auto. *)
(*       * repeat (apply PositiveSet.remove_spec; split; auto). *)
(*         apply PositiveSet.remove_spec in IN as [IN _]. apply IHml in IN. *)
(*         apply PositiveSet.remove_spec in IN as [IN _]. auto. *)
(* Qed. *)

(* (* Before an update_movelist, it is sufficient to agree on all the registers *)
(*    of [rs] excepted the registers assigned by the movelist *) *)
(* Lemma agree_movelist_dead: *)
(*   forall ml rs rms rmsu rmo rmou, *)
(*     agree rms rmo (movelist_live ml (movelist_dead ml rs)) -> *)
(*     update_movelist ml rms rmsu -> *)
(*     update_movelist ml rmo rmou -> *)
(*     agree rmsu rmou rs. *)
(* Proof. *)
(*   induction ml; intros; inv H0; inv H1; simpl in H; auto. *)
(*   simpl in H. eapply agree_eval_expr in EVAL; eauto. *)
(*   eapply eval_expr_determ in EVAL0; eauto. *)
(*   inv EVAL0. apply agree_insert_dead. *)
(*   eapply IHml; eauto. *)
(*   apply agree_subset with *)
(*       (movelist_live ml (reg_dead r (movelist_dead ml rs))) *)
(*       (expr_live e (movelist_live ml (reg_dead r (movelist_dead ml rs)))) *)
(*       rms rmo in H; try apply expr_live_subset. *)
(*   eapply agree_movelist_live; eauto. *)
(*   + eapply movelist_live_agree. eauto. *)
(*   + eapply agree_subset. apply movelist_reg_dead_subset. *)
(*     eapply movelist_live_agree. eauto. *)
(* Qed. *)